1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- SYSTEM.GENERIC_ARRAY_OPERATIONS --
9 -- Copyright (C) 2006, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 package body System.Generic_Array_Operations is
36 -- The local function Check_Unit_Last computes the index
37 -- of the last element returned by Unit_Vector or Unit_Matrix.
38 -- A separate function is needed to allow raising Constraint_Error
39 -- before declaring the function result variable. The result variable
40 -- needs to be declared first, to allow front-end inlining.
42 function Check_Unit_Last
45 First : Integer) return Integer;
46 pragma Inline_Always (Check_Unit_Last);
48 function Square_Matrix_Length (A : Matrix) return Natural is
50 if A'Length (1) /= A'Length (2) then
51 raise Constraint_Error with "matrix is not square";
55 end Square_Matrix_Length;
61 function Check_Unit_Last
64 First : Integer) return Integer is
66 -- Order the tests carefully to avoid overflow
69 or else First > Integer'Last - Order + 1
70 or else Index > First + (Order - 1)
72 raise Constraint_Error;
75 return First + (Order - 1);
82 function Inner_Product
87 R : Result_Scalar := Zero;
90 if Left'Length /= Right'Length then
91 raise Constraint_Error with
92 "vectors are of different length in inner product";
95 for J in Left'Range loop
96 R := R + Left (J) * Right (J - Left'First + Right'First);
102 ----------------------------------
103 -- Matrix_Elementwise_Operation --
104 ----------------------------------
106 function Matrix_Elementwise_Operation (X : X_Matrix) return Result_Matrix is
107 R : Result_Matrix (X'Range (1), X'Range (2));
110 for J in R'Range (1) loop
111 for K in R'Range (2) loop
112 R (J, K) := Operation (X (J, K));
117 end Matrix_Elementwise_Operation;
119 ----------------------------------
120 -- Vector_Elementwise_Operation --
121 ----------------------------------
123 function Vector_Elementwise_Operation (X : X_Vector) return Result_Vector is
124 R : Result_Vector (X'Range);
127 for J in R'Range loop
128 R (J) := Operation (X (J));
132 end Vector_Elementwise_Operation;
134 -----------------------------------------
135 -- Matrix_Matrix_Elementwise_Operation --
136 -----------------------------------------
138 function Matrix_Matrix_Elementwise_Operation
140 Right : Right_Matrix)
143 R : Result_Matrix (Left'Range (1), Left'Range (2));
145 if Left'Length (1) /= Right'Length (1)
146 or else Left'Length (2) /= Right'Length (2)
148 raise Constraint_Error with
149 "matrices are of different dimension in elementwise operation";
152 for J in R'Range (1) loop
153 for K in R'Range (2) loop
154 R (J, K) := Operation (Left (J, K), Right (J, K));
159 end Matrix_Matrix_Elementwise_Operation;
161 ------------------------------------------------
162 -- Matrix_Matrix_Scalar_Elementwise_Operation --
163 ------------------------------------------------
165 function Matrix_Matrix_Scalar_Elementwise_Operation
168 Z : Z_Scalar) return Result_Matrix
170 R : Result_Matrix (X'Range (1), X'Range (2));
173 if X'Length (1) /= Y'Length (1)
174 or else X'Length (2) /= Y'Length (2)
176 raise Constraint_Error with
177 "matrices are of different dimension in elementwise operation";
180 for J in R'Range (1) loop
181 for K in R'Range (2) loop
182 R (J, K) := Operation (X (J, K), Y (J, K), Z);
187 end Matrix_Matrix_Scalar_Elementwise_Operation;
189 -----------------------------------------
190 -- Vector_Vector_Elementwise_Operation --
191 -----------------------------------------
193 function Vector_Vector_Elementwise_Operation
195 Right : Right_Vector) return Result_Vector
197 R : Result_Vector (Left'Range);
200 if Left'Length /= Right'Length then
201 raise Constraint_Error with
202 "vectors are of different length in elementwise operation";
205 for J in R'Range loop
206 R (J) := Operation (Left (J), Right (J));
210 end Vector_Vector_Elementwise_Operation;
212 ------------------------------------------------
213 -- Vector_Vector_Scalar_Elementwise_Operation --
214 ------------------------------------------------
216 function Vector_Vector_Scalar_Elementwise_Operation
219 Z : Z_Scalar) return Result_Vector
221 R : Result_Vector (X'Range);
224 if X'Length /= Y'Length then
225 raise Constraint_Error with
226 "vectors are of different length in elementwise operation";
229 for J in R'Range loop
230 R (J) := Operation (X (J), Y (J), Z);
234 end Vector_Vector_Scalar_Elementwise_Operation;
236 -----------------------------------------
237 -- Matrix_Scalar_Elementwise_Operation --
238 -----------------------------------------
240 function Matrix_Scalar_Elementwise_Operation
242 Right : Right_Scalar) return Result_Matrix
244 R : Result_Matrix (Left'Range (1), Left'Range (2));
247 for J in R'Range (1) loop
248 for K in R'Range (2) loop
249 R (J, K) := Operation (Left (J, K), Right);
254 end Matrix_Scalar_Elementwise_Operation;
256 -----------------------------------------
257 -- Vector_Scalar_Elementwise_Operation --
258 -----------------------------------------
260 function Vector_Scalar_Elementwise_Operation
262 Right : Right_Scalar) return Result_Vector
264 R : Result_Vector (Left'Range);
267 for J in R'Range loop
268 R (J) := Operation (Left (J), Right);
272 end Vector_Scalar_Elementwise_Operation;
274 -----------------------------------------
275 -- Scalar_Matrix_Elementwise_Operation --
276 -----------------------------------------
278 function Scalar_Matrix_Elementwise_Operation
280 Right : Right_Matrix) return Result_Matrix
282 R : Result_Matrix (Right'Range (1), Right'Range (2));
285 for J in R'Range (1) loop
286 for K in R'Range (2) loop
287 R (J, K) := Operation (Left, Right (J, K));
292 end Scalar_Matrix_Elementwise_Operation;
294 -----------------------------------------
295 -- Scalar_Vector_Elementwise_Operation --
296 -----------------------------------------
298 function Scalar_Vector_Elementwise_Operation
300 Right : Right_Vector) return Result_Vector
302 R : Result_Vector (Right'Range);
305 for J in R'Range loop
306 R (J) := Operation (Left, Right (J));
310 end Scalar_Vector_Elementwise_Operation;
312 ---------------------------
313 -- Matrix_Matrix_Product --
314 ---------------------------
316 function Matrix_Matrix_Product
318 Right : Right_Matrix) return Result_Matrix
320 R : Result_Matrix (Left'Range (1), Right'Range (2));
323 if Left'Length (2) /= Right'Length (1) then
324 raise Constraint_Error with
325 "incompatible dimensions in matrix multiplication";
328 for J in R'Range (1) loop
329 for K in R'Range (2) loop
331 S : Result_Scalar := Zero;
333 for M in Left'Range (2) loop
335 * Right (M - Left'First (2) + Right'First (1), K);
344 end Matrix_Matrix_Product;
346 ---------------------------
347 -- Matrix_Vector_Product --
348 ---------------------------
350 function Matrix_Vector_Product
352 Right : Right_Vector) return Result_Vector
354 R : Result_Vector (Left'Range (1));
357 if Left'Length (2) /= Right'Length then
358 raise Constraint_Error with
359 "incompatible dimensions in matrix-vector multiplication";
362 for J in Left'Range (1) loop
364 S : Result_Scalar := Zero;
366 for K in Left'Range (2) loop
367 S := S + Left (J, K) * Right (K - Left'First (2) + Right'First);
375 end Matrix_Vector_Product;
381 function Outer_Product
383 Right : Right_Vector) return Matrix
385 R : Matrix (Left'Range, Right'Range);
388 for J in R'Range (1) loop
389 for K in R'Range (2) loop
390 R (J, K) := Left (J) * Right (K);
401 procedure Transpose (A : Matrix; R : out Matrix) is
403 for J in R'Range (1) loop
404 for K in R'Range (2) loop
405 R (J, K) := A (J - R'First (1) + A'First (1),
406 K - R'First (2) + A'First (2));
411 -------------------------------
412 -- Update_Matrix_With_Matrix --
413 -------------------------------
415 procedure Update_Matrix_With_Matrix (X : in out X_Matrix; Y : Y_Matrix) is
417 if X'Length (1) /= Y'Length (1)
418 or else X'Length (2) /= Y'Length (2)
420 raise Constraint_Error with
421 "matrices are of different dimension in update operation";
424 for J in X'Range (1) loop
425 for K in X'Range (2) loop
426 Update (X (J, K), Y (J - X'First (1) + Y'First (1),
427 K - X'First (2) + Y'First (2)));
430 end Update_Matrix_With_Matrix;
432 -------------------------------
433 -- Update_Vector_With_Vector --
434 -------------------------------
436 procedure Update_Vector_With_Vector (X : in out X_Vector; Y : Y_Vector) is
438 if X'Length /= Y'Length then
439 raise Constraint_Error with
440 "vectors are of different length in update operation";
443 for J in X'Range loop
444 Update (X (J), Y (J - X'First + Y'First));
446 end Update_Vector_With_Vector;
454 First_1 : Integer := 1;
455 First_2 : Integer := 1) return Matrix
457 R : Matrix (First_1 .. Check_Unit_Last (First_1, Order, First_1),
458 First_2 .. Check_Unit_Last (First_2, Order, First_2));
461 R := (others => (others => Zero));
463 for J in 0 .. Order - 1 loop
464 R (First_1 + J, First_2 + J) := One;
477 First : Integer := 1) return Vector
479 R : Vector (First .. Check_Unit_Last (Index, Order, First));
481 R := (others => Zero);
486 ---------------------------
487 -- Vector_Matrix_Product --
488 ---------------------------
490 function Vector_Matrix_Product
492 Right : Matrix) return Result_Vector
494 R : Result_Vector (Right'Range (2));
497 if Left'Length /= Right'Length (2) then
498 raise Constraint_Error with
499 "incompatible dimensions in vector-matrix multiplication";
502 for J in Right'Range (2) loop
504 S : Result_Scalar := Zero;
507 for K in Right'Range (1) loop
508 S := S + Left (J - Right'First (1) + Left'First) * Right (K, J);
516 end Vector_Matrix_Product;
518 end System.Generic_Array_Operations;