URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc3/] [gcc/] [ada/] [s-gearop.adb] - Rev 593
Go to most recent revision | Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- -- S Y S T E M . G E N E R I C _ A R R A Y _ O P E R A T I O N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- <http://www.gnu.org/licenses/>. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ package body System.Generic_Array_Operations is -- The local function Check_Unit_Last computes the index -- of the last element returned by Unit_Vector or Unit_Matrix. -- A separate function is needed to allow raising Constraint_Error -- before declaring the function result variable. The result variable -- needs to be declared first, to allow front-end inlining. function Check_Unit_Last (Index : Integer; Order : Positive; First : Integer) return Integer; pragma Inline_Always (Check_Unit_Last); function Square_Matrix_Length (A : Matrix) return Natural is begin if A'Length (1) /= A'Length (2) then raise Constraint_Error with "matrix is not square"; end if; return A'Length (1); end Square_Matrix_Length; --------------------- -- Check_Unit_Last -- --------------------- function Check_Unit_Last (Index : Integer; Order : Positive; First : Integer) return Integer is begin -- Order the tests carefully to avoid overflow if Index < First or else First > Integer'Last - Order + 1 or else Index > First + (Order - 1) then raise Constraint_Error; end if; return First + (Order - 1); end Check_Unit_Last; ------------------- -- Inner_Product -- ------------------- function Inner_Product (Left : Left_Vector; Right : Right_Vector) return Result_Scalar is R : Result_Scalar := Zero; begin if Left'Length /= Right'Length then raise Constraint_Error with "vectors are of different length in inner product"; end if; for J in Left'Range loop R := R + Left (J) * Right (J - Left'First + Right'First); end loop; return R; end Inner_Product; ---------------------------------- -- Matrix_Elementwise_Operation -- ---------------------------------- function Matrix_Elementwise_Operation (X : X_Matrix) return Result_Matrix is R : Result_Matrix (X'Range (1), X'Range (2)); begin for J in R'Range (1) loop for K in R'Range (2) loop R (J, K) := Operation (X (J, K)); end loop; end loop; return R; end Matrix_Elementwise_Operation; ---------------------------------- -- Vector_Elementwise_Operation -- ---------------------------------- function Vector_Elementwise_Operation (X : X_Vector) return Result_Vector is R : Result_Vector (X'Range); begin for J in R'Range loop R (J) := Operation (X (J)); end loop; return R; end Vector_Elementwise_Operation; ----------------------------------------- -- Matrix_Matrix_Elementwise_Operation -- ----------------------------------------- function Matrix_Matrix_Elementwise_Operation (Left : Left_Matrix; Right : Right_Matrix) return Result_Matrix is R : Result_Matrix (Left'Range (1), Left'Range (2)); begin if Left'Length (1) /= Right'Length (1) or else Left'Length (2) /= Right'Length (2) then raise Constraint_Error with "matrices are of different dimension in elementwise operation"; end if; for J in R'Range (1) loop for K in R'Range (2) loop R (J, K) := Operation (Left (J, K), Right (J - R'First (1) + Right'First (1), K - R'First (2) + Right'First (2))); end loop; end loop; return R; end Matrix_Matrix_Elementwise_Operation; ------------------------------------------------ -- Matrix_Matrix_Scalar_Elementwise_Operation -- ------------------------------------------------ function Matrix_Matrix_Scalar_Elementwise_Operation (X : X_Matrix; Y : Y_Matrix; Z : Z_Scalar) return Result_Matrix is R : Result_Matrix (X'Range (1), X'Range (2)); begin if X'Length (1) /= Y'Length (1) or else X'Length (2) /= Y'Length (2) then raise Constraint_Error with "matrices are of different dimension in elementwise operation"; end if; for J in R'Range (1) loop for K in R'Range (2) loop R (J, K) := Operation (X (J, K), Y (J - R'First (1) + Y'First (1), K - R'First (2) + Y'First (2)), Z); end loop; end loop; return R; end Matrix_Matrix_Scalar_Elementwise_Operation; ----------------------------------------- -- Vector_Vector_Elementwise_Operation -- ----------------------------------------- function Vector_Vector_Elementwise_Operation (Left : Left_Vector; Right : Right_Vector) return Result_Vector is R : Result_Vector (Left'Range); begin if Left'Length /= Right'Length then raise Constraint_Error with "vectors are of different length in elementwise operation"; end if; for J in R'Range loop R (J) := Operation (Left (J), Right (J - R'First + Right'First)); end loop; return R; end Vector_Vector_Elementwise_Operation; ------------------------------------------------ -- Vector_Vector_Scalar_Elementwise_Operation -- ------------------------------------------------ function Vector_Vector_Scalar_Elementwise_Operation (X : X_Vector; Y : Y_Vector; Z : Z_Scalar) return Result_Vector is R : Result_Vector (X'Range); begin if X'Length /= Y'Length then raise Constraint_Error with "vectors are of different length in elementwise operation"; end if; for J in R'Range loop R (J) := Operation (X (J), Y (J - X'First + Y'First), Z); end loop; return R; end Vector_Vector_Scalar_Elementwise_Operation; ----------------------------------------- -- Matrix_Scalar_Elementwise_Operation -- ----------------------------------------- function Matrix_Scalar_Elementwise_Operation (Left : Left_Matrix; Right : Right_Scalar) return Result_Matrix is R : Result_Matrix (Left'Range (1), Left'Range (2)); begin for J in R'Range (1) loop for K in R'Range (2) loop R (J, K) := Operation (Left (J, K), Right); end loop; end loop; return R; end Matrix_Scalar_Elementwise_Operation; ----------------------------------------- -- Vector_Scalar_Elementwise_Operation -- ----------------------------------------- function Vector_Scalar_Elementwise_Operation (Left : Left_Vector; Right : Right_Scalar) return Result_Vector is R : Result_Vector (Left'Range); begin for J in R'Range loop R (J) := Operation (Left (J), Right); end loop; return R; end Vector_Scalar_Elementwise_Operation; ----------------------------------------- -- Scalar_Matrix_Elementwise_Operation -- ----------------------------------------- function Scalar_Matrix_Elementwise_Operation (Left : Left_Scalar; Right : Right_Matrix) return Result_Matrix is R : Result_Matrix (Right'Range (1), Right'Range (2)); begin for J in R'Range (1) loop for K in R'Range (2) loop R (J, K) := Operation (Left, Right (J, K)); end loop; end loop; return R; end Scalar_Matrix_Elementwise_Operation; ----------------------------------------- -- Scalar_Vector_Elementwise_Operation -- ----------------------------------------- function Scalar_Vector_Elementwise_Operation (Left : Left_Scalar; Right : Right_Vector) return Result_Vector is R : Result_Vector (Right'Range); begin for J in R'Range loop R (J) := Operation (Left, Right (J)); end loop; return R; end Scalar_Vector_Elementwise_Operation; --------------------------- -- Matrix_Matrix_Product -- --------------------------- function Matrix_Matrix_Product (Left : Left_Matrix; Right : Right_Matrix) return Result_Matrix is R : Result_Matrix (Left'Range (1), Right'Range (2)); begin if Left'Length (2) /= Right'Length (1) then raise Constraint_Error with "incompatible dimensions in matrix multiplication"; end if; for J in R'Range (1) loop for K in R'Range (2) loop declare S : Result_Scalar := Zero; begin for M in Left'Range (2) loop S := S + Left (J, M) * Right (M - Left'First (2) + Right'First (1), K); end loop; R (J, K) := S; end; end loop; end loop; return R; end Matrix_Matrix_Product; --------------------------- -- Matrix_Vector_Product -- --------------------------- function Matrix_Vector_Product (Left : Matrix; Right : Right_Vector) return Result_Vector is R : Result_Vector (Left'Range (1)); begin if Left'Length (2) /= Right'Length then raise Constraint_Error with "incompatible dimensions in matrix-vector multiplication"; end if; for J in Left'Range (1) loop declare S : Result_Scalar := Zero; begin for K in Left'Range (2) loop S := S + Left (J, K) * Right (K - Left'First (2) + Right'First); end loop; R (J) := S; end; end loop; return R; end Matrix_Vector_Product; ------------------- -- Outer_Product -- ------------------- function Outer_Product (Left : Left_Vector; Right : Right_Vector) return Matrix is R : Matrix (Left'Range, Right'Range); begin for J in R'Range (1) loop for K in R'Range (2) loop R (J, K) := Left (J) * Right (K); end loop; end loop; return R; end Outer_Product; --------------- -- Transpose -- --------------- procedure Transpose (A : Matrix; R : out Matrix) is begin for J in R'Range (1) loop for K in R'Range (2) loop R (J, K) := A (K - R'First (2) + A'First (1), J - R'First (1) + A'First (2)); end loop; end loop; end Transpose; ------------------------------- -- Update_Matrix_With_Matrix -- ------------------------------- procedure Update_Matrix_With_Matrix (X : in out X_Matrix; Y : Y_Matrix) is begin if X'Length (1) /= Y'Length (1) or else X'Length (2) /= Y'Length (2) then raise Constraint_Error with "matrices are of different dimension in update operation"; end if; for J in X'Range (1) loop for K in X'Range (2) loop Update (X (J, K), Y (J - X'First (1) + Y'First (1), K - X'First (2) + Y'First (2))); end loop; end loop; end Update_Matrix_With_Matrix; ------------------------------- -- Update_Vector_With_Vector -- ------------------------------- procedure Update_Vector_With_Vector (X : in out X_Vector; Y : Y_Vector) is begin if X'Length /= Y'Length then raise Constraint_Error with "vectors are of different length in update operation"; end if; for J in X'Range loop Update (X (J), Y (J - X'First + Y'First)); end loop; end Update_Vector_With_Vector; ----------------- -- Unit_Matrix -- ----------------- function Unit_Matrix (Order : Positive; First_1 : Integer := 1; First_2 : Integer := 1) return Matrix is R : Matrix (First_1 .. Check_Unit_Last (First_1, Order, First_1), First_2 .. Check_Unit_Last (First_2, Order, First_2)); begin R := (others => (others => Zero)); for J in 0 .. Order - 1 loop R (First_1 + J, First_2 + J) := One; end loop; return R; end Unit_Matrix; ----------------- -- Unit_Vector -- ----------------- function Unit_Vector (Index : Integer; Order : Positive; First : Integer := 1) return Vector is R : Vector (First .. Check_Unit_Last (Index, Order, First)); begin R := (others => Zero); R (Index) := One; return R; end Unit_Vector; --------------------------- -- Vector_Matrix_Product -- --------------------------- function Vector_Matrix_Product (Left : Left_Vector; Right : Matrix) return Result_Vector is R : Result_Vector (Right'Range (2)); begin if Left'Length /= Right'Length (2) then raise Constraint_Error with "incompatible dimensions in vector-matrix multiplication"; end if; for J in Right'Range (2) loop declare S : Result_Scalar := Zero; begin for K in Right'Range (1) loop S := S + Left (J - Right'First (1) + Left'First) * Right (K, J); end loop; R (J) := S; end; end loop; return R; end Vector_Matrix_Product; end System.Generic_Array_Operations;
Go to most recent revision | Compare with Previous | Blame | View Log