1 /* Implementation of the PRODUCT intrinsic
2 Copyright (C) 2002-2018 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
5 This file is part of the GNU Fortran runtime library (libgfortran).
7 Libgfortran is free software; you can redistribute it and/or
8 modify it under the terms of the GNU General Public
9 License as published by the Free Software Foundation; either
10 version 3 of the License, or (at your option) any later version.
12 Libgfortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 Under Section 7 of GPL version 3, you are granted additional
18 permissions described in the GCC Runtime Library Exception, version
19 3.1, as published by the Free Software Foundation.
21 You should have received a copy of the GNU General Public License and
22 a copy of the GCC Runtime Library Exception along with this program;
23 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24 <http://www.gnu.org/licenses/>. */
26 #include "libgfortran.h"
29 #if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_REAL_8)
32 extern void product_r8 (gfc_array_r8
* const restrict
,
33 gfc_array_r8
* const restrict
, const index_type
* const restrict
);
34 export_proto(product_r8
);
37 product_r8 (gfc_array_r8
* const restrict retarray
,
38 gfc_array_r8
* const restrict array
,
39 const index_type
* const restrict pdim
)
41 index_type count
[GFC_MAX_DIMENSIONS
];
42 index_type extent
[GFC_MAX_DIMENSIONS
];
43 index_type sstride
[GFC_MAX_DIMENSIONS
];
44 index_type dstride
[GFC_MAX_DIMENSIONS
];
45 const GFC_REAL_8
* restrict base
;
46 GFC_REAL_8
* restrict dest
;
54 /* Make dim zero based to avoid confusion. */
55 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
58 if (unlikely (dim
< 0 || dim
> rank
))
60 runtime_error ("Dim argument incorrect in PRODUCT intrinsic: "
61 "is %ld, should be between 1 and %ld",
62 (long int) dim
+ 1, (long int) rank
+ 1);
65 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
68 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
70 for (n
= 0; n
< dim
; n
++)
72 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
73 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
78 for (n
= dim
; n
< rank
; n
++)
80 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
, n
+ 1);
81 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
87 if (retarray
->base_addr
== NULL
)
89 size_t alloc_size
, str
;
91 for (n
= 0; n
< rank
; n
++)
96 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
98 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
102 retarray
->offset
= 0;
103 GFC_DTYPE_COPY_SETRANK(retarray
,array
,rank
);
105 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
107 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_REAL_8
));
110 /* Make sure we have a zero-sized array. */
111 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
118 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
119 runtime_error ("rank of return array incorrect in"
120 " PRODUCT intrinsic: is %ld, should be %ld",
121 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
124 if (unlikely (compile_options
.bounds_check
))
125 bounds_ifunction_return ((array_t
*) retarray
, extent
,
126 "return value", "PRODUCT");
129 for (n
= 0; n
< rank
; n
++)
132 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
137 base
= array
->base_addr
;
138 dest
= retarray
->base_addr
;
141 while (continue_loop
)
143 const GFC_REAL_8
* restrict src
;
153 #if ! defined HAVE_BACK_ARG
154 for (n
= 0; n
< len
; n
++, src
+= delta
)
164 /* Advance to the next element. */
169 while (count
[n
] == extent
[n
])
171 /* When we get to the end of a dimension, reset it and increment
172 the next dimension. */
174 /* We could precalculate these products, but this is a less
175 frequently used path so probably not worth it. */
176 base
-= sstride
[n
] * extent
[n
];
177 dest
-= dstride
[n
] * extent
[n
];
181 /* Break out of the loop. */
196 extern void mproduct_r8 (gfc_array_r8
* const restrict
,
197 gfc_array_r8
* const restrict
, const index_type
* const restrict
,
198 gfc_array_l1
* const restrict
);
199 export_proto(mproduct_r8
);
202 mproduct_r8 (gfc_array_r8
* const restrict retarray
,
203 gfc_array_r8
* const restrict array
,
204 const index_type
* const restrict pdim
,
205 gfc_array_l1
* const restrict mask
)
207 index_type count
[GFC_MAX_DIMENSIONS
];
208 index_type extent
[GFC_MAX_DIMENSIONS
];
209 index_type sstride
[GFC_MAX_DIMENSIONS
];
210 index_type dstride
[GFC_MAX_DIMENSIONS
];
211 index_type mstride
[GFC_MAX_DIMENSIONS
];
212 GFC_REAL_8
* restrict dest
;
213 const GFC_REAL_8
* restrict base
;
214 const GFC_LOGICAL_1
* restrict mbase
;
224 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
227 if (unlikely (dim
< 0 || dim
> rank
))
229 runtime_error ("Dim argument incorrect in PRODUCT intrinsic: "
230 "is %ld, should be between 1 and %ld",
231 (long int) dim
+ 1, (long int) rank
+ 1);
234 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
238 mbase
= mask
->base_addr
;
240 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
242 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
243 #ifdef HAVE_GFC_LOGICAL_16
247 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
249 runtime_error ("Funny sized logical array");
251 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
252 mdelta
= GFC_DESCRIPTOR_STRIDE_BYTES(mask
,dim
);
254 for (n
= 0; n
< dim
; n
++)
256 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
257 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
258 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
264 for (n
= dim
; n
< rank
; n
++)
266 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
+ 1);
267 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
, n
+ 1);
268 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
274 if (retarray
->base_addr
== NULL
)
276 size_t alloc_size
, str
;
278 for (n
= 0; n
< rank
; n
++)
283 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
285 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
289 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
291 retarray
->offset
= 0;
292 GFC_DTYPE_COPY_SETRANK(retarray
,array
,rank
);
296 /* Make sure we have a zero-sized array. */
297 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
301 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_REAL_8
));
306 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
307 runtime_error ("rank of return array incorrect in PRODUCT intrinsic");
309 if (unlikely (compile_options
.bounds_check
))
311 bounds_ifunction_return ((array_t
*) retarray
, extent
,
312 "return value", "PRODUCT");
313 bounds_equal_extents ((array_t
*) mask
, (array_t
*) array
,
314 "MASK argument", "PRODUCT");
318 for (n
= 0; n
< rank
; n
++)
321 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
326 dest
= retarray
->base_addr
;
327 base
= array
->base_addr
;
331 const GFC_REAL_8
* restrict src
;
332 const GFC_LOGICAL_1
* restrict msrc
;
339 for (n
= 0; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
347 /* Advance to the next element. */
353 while (count
[n
] == extent
[n
])
355 /* When we get to the end of a dimension, reset it and increment
356 the next dimension. */
358 /* We could precalculate these products, but this is a less
359 frequently used path so probably not worth it. */
360 base
-= sstride
[n
] * extent
[n
];
361 mbase
-= mstride
[n
] * extent
[n
];
362 dest
-= dstride
[n
] * extent
[n
];
366 /* Break out of the loop. */
382 extern void sproduct_r8 (gfc_array_r8
* const restrict
,
383 gfc_array_r8
* const restrict
, const index_type
* const restrict
,
385 export_proto(sproduct_r8
);
388 sproduct_r8 (gfc_array_r8
* const restrict retarray
,
389 gfc_array_r8
* const restrict array
,
390 const index_type
* const restrict pdim
,
391 GFC_LOGICAL_4
* mask
)
393 index_type count
[GFC_MAX_DIMENSIONS
];
394 index_type extent
[GFC_MAX_DIMENSIONS
];
395 index_type dstride
[GFC_MAX_DIMENSIONS
];
396 GFC_REAL_8
* restrict dest
;
405 product_r8 (retarray
, array
, pdim
, back
);
407 product_r8 (retarray
, array
, pdim
);
411 /* Make dim zero based to avoid confusion. */
413 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
415 if (unlikely (dim
< 0 || dim
> rank
))
417 runtime_error ("Dim argument incorrect in PRODUCT intrinsic: "
418 "is %ld, should be between 1 and %ld",
419 (long int) dim
+ 1, (long int) rank
+ 1);
422 for (n
= 0; n
< dim
; n
++)
424 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
430 for (n
= dim
; n
< rank
; n
++)
433 GFC_DESCRIPTOR_EXTENT(array
,n
+ 1);
439 if (retarray
->base_addr
== NULL
)
441 size_t alloc_size
, str
;
443 for (n
= 0; n
< rank
; n
++)
448 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
450 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
454 retarray
->offset
= 0;
455 GFC_DTYPE_COPY_SETRANK(retarray
,array
,rank
);
457 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
461 /* Make sure we have a zero-sized array. */
462 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
466 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_REAL_8
));
470 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
471 runtime_error ("rank of return array incorrect in"
472 " PRODUCT intrinsic: is %ld, should be %ld",
473 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
476 if (unlikely (compile_options
.bounds_check
))
478 for (n
=0; n
< rank
; n
++)
480 index_type ret_extent
;
482 ret_extent
= GFC_DESCRIPTOR_EXTENT(retarray
,n
);
483 if (extent
[n
] != ret_extent
)
484 runtime_error ("Incorrect extent in return value of"
485 " PRODUCT intrinsic in dimension %ld:"
486 " is %ld, should be %ld", (long int) n
+ 1,
487 (long int) ret_extent
, (long int) extent
[n
]);
492 for (n
= 0; n
< rank
; n
++)
495 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
498 dest
= retarray
->base_addr
;
506 while (count
[n
] == extent
[n
])
508 /* When we get to the end of a dimension, reset it and increment
509 the next dimension. */
511 /* We could precalculate these products, but this is a less
512 frequently used path so probably not worth it. */
513 dest
-= dstride
[n
] * extent
[n
];