1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- SYSTEM.GENERIC_ARRAY_OPERATIONS --
9 -- Copyright (C) 2006-2007, 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
158 (J
- R
'First (1) + Right
'First (1),
159 K
- R
'First (2) + Right
'First (2)));
164 end Matrix_Matrix_Elementwise_Operation
;
166 ------------------------------------------------
167 -- Matrix_Matrix_Scalar_Elementwise_Operation --
168 ------------------------------------------------
170 function Matrix_Matrix_Scalar_Elementwise_Operation
173 Z
: Z_Scalar
) return Result_Matrix
175 R
: Result_Matrix
(X
'Range (1), X
'Range (2));
178 if X
'Length (1) /= Y
'Length (1)
179 or else X
'Length (2) /= Y
'Length (2)
181 raise Constraint_Error
with
182 "matrices are of different dimension in elementwise operation";
185 for J
in R
'Range (1) loop
186 for K
in R
'Range (2) loop
190 Y
(J
- R
'First (1) + Y
'First (1),
191 K
- R
'First (2) + Y
'First (2)),
197 end Matrix_Matrix_Scalar_Elementwise_Operation
;
199 -----------------------------------------
200 -- Vector_Vector_Elementwise_Operation --
201 -----------------------------------------
203 function Vector_Vector_Elementwise_Operation
205 Right
: Right_Vector
) return Result_Vector
207 R
: Result_Vector
(Left
'Range);
210 if Left
'Length /= Right
'Length then
211 raise Constraint_Error
with
212 "vectors are of different length in elementwise operation";
215 for J
in R
'Range loop
216 R
(J
) := Operation
(Left
(J
), Right
(J
- R
'First + Right
'First));
220 end Vector_Vector_Elementwise_Operation
;
222 ------------------------------------------------
223 -- Vector_Vector_Scalar_Elementwise_Operation --
224 ------------------------------------------------
226 function Vector_Vector_Scalar_Elementwise_Operation
229 Z
: Z_Scalar
) return Result_Vector
231 R
: Result_Vector
(X
'Range);
234 if X
'Length /= Y
'Length then
235 raise Constraint_Error
with
236 "vectors are of different length in elementwise operation";
239 for J
in R
'Range loop
240 R
(J
) := Operation
(X
(J
), Y
(J
- X
'First + Y
'First), Z
);
244 end Vector_Vector_Scalar_Elementwise_Operation
;
246 -----------------------------------------
247 -- Matrix_Scalar_Elementwise_Operation --
248 -----------------------------------------
250 function Matrix_Scalar_Elementwise_Operation
252 Right
: Right_Scalar
) return Result_Matrix
254 R
: Result_Matrix
(Left
'Range (1), Left
'Range (2));
257 for J
in R
'Range (1) loop
258 for K
in R
'Range (2) loop
259 R
(J
, K
) := Operation
(Left
(J
, K
), Right
);
264 end Matrix_Scalar_Elementwise_Operation
;
266 -----------------------------------------
267 -- Vector_Scalar_Elementwise_Operation --
268 -----------------------------------------
270 function Vector_Scalar_Elementwise_Operation
272 Right
: Right_Scalar
) return Result_Vector
274 R
: Result_Vector
(Left
'Range);
277 for J
in R
'Range loop
278 R
(J
) := Operation
(Left
(J
), Right
);
282 end Vector_Scalar_Elementwise_Operation
;
284 -----------------------------------------
285 -- Scalar_Matrix_Elementwise_Operation --
286 -----------------------------------------
288 function Scalar_Matrix_Elementwise_Operation
290 Right
: Right_Matrix
) return Result_Matrix
292 R
: Result_Matrix
(Right
'Range (1), Right
'Range (2));
295 for J
in R
'Range (1) loop
296 for K
in R
'Range (2) loop
297 R
(J
, K
) := Operation
(Left
, Right
(J
, K
));
302 end Scalar_Matrix_Elementwise_Operation
;
304 -----------------------------------------
305 -- Scalar_Vector_Elementwise_Operation --
306 -----------------------------------------
308 function Scalar_Vector_Elementwise_Operation
310 Right
: Right_Vector
) return Result_Vector
312 R
: Result_Vector
(Right
'Range);
315 for J
in R
'Range loop
316 R
(J
) := Operation
(Left
, Right
(J
));
320 end Scalar_Vector_Elementwise_Operation
;
322 ---------------------------
323 -- Matrix_Matrix_Product --
324 ---------------------------
326 function Matrix_Matrix_Product
328 Right
: Right_Matrix
) return Result_Matrix
330 R
: Result_Matrix
(Left
'Range (1), Right
'Range (2));
333 if Left
'Length (2) /= Right
'Length (1) then
334 raise Constraint_Error
with
335 "incompatible dimensions in matrix multiplication";
338 for J
in R
'Range (1) loop
339 for K
in R
'Range (2) loop
341 S
: Result_Scalar
:= Zero
;
343 for M
in Left
'Range (2) loop
345 * Right
(M
- Left
'First (2) + Right
'First (1), K
);
354 end Matrix_Matrix_Product
;
356 ---------------------------
357 -- Matrix_Vector_Product --
358 ---------------------------
360 function Matrix_Vector_Product
362 Right
: Right_Vector
) return Result_Vector
364 R
: Result_Vector
(Left
'Range (1));
367 if Left
'Length (2) /= Right
'Length then
368 raise Constraint_Error
with
369 "incompatible dimensions in matrix-vector multiplication";
372 for J
in Left
'Range (1) loop
374 S
: Result_Scalar
:= Zero
;
376 for K
in Left
'Range (2) loop
377 S
:= S
+ Left
(J
, K
) * Right
(K
- Left
'First (2) + Right
'First);
385 end Matrix_Vector_Product
;
391 function Outer_Product
393 Right
: Right_Vector
) return Matrix
395 R
: Matrix
(Left
'Range, Right
'Range);
398 for J
in R
'Range (1) loop
399 for K
in R
'Range (2) loop
400 R
(J
, K
) := Left
(J
) * Right
(K
);
411 procedure Transpose
(A
: Matrix
; R
: out Matrix
) is
413 for J
in R
'Range (1) loop
414 for K
in R
'Range (2) loop
415 R
(J
, K
) := A
(K
- R
'First (2) + A
'First (1),
416 J
- R
'First (1) + A
'First (2));
421 -------------------------------
422 -- Update_Matrix_With_Matrix --
423 -------------------------------
425 procedure Update_Matrix_With_Matrix
(X
: in out X_Matrix
; Y
: Y_Matrix
) is
427 if X
'Length (1) /= Y
'Length (1)
428 or else X
'Length (2) /= Y
'Length (2)
430 raise Constraint_Error
with
431 "matrices are of different dimension in update operation";
434 for J
in X
'Range (1) loop
435 for K
in X
'Range (2) loop
436 Update
(X
(J
, K
), Y
(J
- X
'First (1) + Y
'First (1),
437 K
- X
'First (2) + Y
'First (2)));
440 end Update_Matrix_With_Matrix
;
442 -------------------------------
443 -- Update_Vector_With_Vector --
444 -------------------------------
446 procedure Update_Vector_With_Vector
(X
: in out X_Vector
; Y
: Y_Vector
) is
448 if X
'Length /= Y
'Length then
449 raise Constraint_Error
with
450 "vectors are of different length in update operation";
453 for J
in X
'Range loop
454 Update
(X
(J
), Y
(J
- X
'First + Y
'First));
456 end Update_Vector_With_Vector
;
464 First_1
: Integer := 1;
465 First_2
: Integer := 1) return Matrix
467 R
: Matrix
(First_1
.. Check_Unit_Last
(First_1
, Order
, First_1
),
468 First_2
.. Check_Unit_Last
(First_2
, Order
, First_2
));
471 R
:= (others => (others => Zero
));
473 for J
in 0 .. Order
- 1 loop
474 R
(First_1
+ J
, First_2
+ J
) := One
;
487 First
: Integer := 1) return Vector
489 R
: Vector
(First
.. Check_Unit_Last
(Index
, Order
, First
));
491 R
:= (others => Zero
);
496 ---------------------------
497 -- Vector_Matrix_Product --
498 ---------------------------
500 function Vector_Matrix_Product
502 Right
: Matrix
) return Result_Vector
504 R
: Result_Vector
(Right
'Range (2));
507 if Left
'Length /= Right
'Length (2) then
508 raise Constraint_Error
with
509 "incompatible dimensions in vector-matrix multiplication";
512 for J
in Right
'Range (2) loop
514 S
: Result_Scalar
:= Zero
;
517 for K
in Right
'Range (1) loop
518 S
:= S
+ Left
(J
- Right
'First (1) + Left
'First) * Right
(K
, J
);
526 end Vector_Matrix_Product
;
528 end System
.Generic_Array_Operations
;