1 /* Implementation of the IPARITY intrinsic
2 Copyright (C) 2010-2016 Free Software Foundation, Inc.
3 Contributed by Tobias Burnus <burnus@net-b.de>
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"
31 #if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1)
34 extern void iparity_i1 (gfc_array_i1
* const restrict
,
35 gfc_array_i1
* const restrict
, const index_type
* const restrict
);
36 export_proto(iparity_i1
);
39 iparity_i1 (gfc_array_i1
* const restrict retarray
,
40 gfc_array_i1
* const restrict array
,
41 const index_type
* const restrict pdim
)
43 index_type count
[GFC_MAX_DIMENSIONS
];
44 index_type extent
[GFC_MAX_DIMENSIONS
];
45 index_type sstride
[GFC_MAX_DIMENSIONS
];
46 index_type dstride
[GFC_MAX_DIMENSIONS
];
47 const GFC_INTEGER_1
* restrict base
;
48 GFC_INTEGER_1
* restrict dest
;
56 /* Make dim zero based to avoid confusion. */
58 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
60 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
63 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
65 for (n
= 0; n
< dim
; n
++)
67 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
68 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
73 for (n
= dim
; n
< rank
; n
++)
75 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
, n
+ 1);
76 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
82 if (retarray
->base_addr
== NULL
)
84 size_t alloc_size
, str
;
86 for (n
= 0; n
< rank
; n
++)
91 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
93 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
98 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
100 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
102 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_1
));
105 /* Make sure we have a zero-sized array. */
106 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
113 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
114 runtime_error ("rank of return array incorrect in"
115 " IPARITY intrinsic: is %ld, should be %ld",
116 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
119 if (unlikely (compile_options
.bounds_check
))
120 bounds_ifunction_return ((array_t
*) retarray
, extent
,
121 "return value", "IPARITY");
124 for (n
= 0; n
< rank
; n
++)
127 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
132 base
= array
->base_addr
;
133 dest
= retarray
->base_addr
;
136 while (continue_loop
)
138 const GFC_INTEGER_1
* restrict src
;
139 GFC_INTEGER_1 result
;
148 for (n
= 0; n
< len
; n
++, src
+= delta
)
157 /* Advance to the next element. */
162 while (count
[n
] == extent
[n
])
164 /* When we get to the end of a dimension, reset it and increment
165 the next dimension. */
167 /* We could precalculate these products, but this is a less
168 frequently used path so probably not worth it. */
169 base
-= sstride
[n
] * extent
[n
];
170 dest
-= dstride
[n
] * extent
[n
];
174 /* Break out of the look. */
189 extern void miparity_i1 (gfc_array_i1
* const restrict
,
190 gfc_array_i1
* const restrict
, const index_type
* const restrict
,
191 gfc_array_l1
* const restrict
);
192 export_proto(miparity_i1
);
195 miparity_i1 (gfc_array_i1
* const restrict retarray
,
196 gfc_array_i1
* const restrict array
,
197 const index_type
* const restrict pdim
,
198 gfc_array_l1
* const restrict mask
)
200 index_type count
[GFC_MAX_DIMENSIONS
];
201 index_type extent
[GFC_MAX_DIMENSIONS
];
202 index_type sstride
[GFC_MAX_DIMENSIONS
];
203 index_type dstride
[GFC_MAX_DIMENSIONS
];
204 index_type mstride
[GFC_MAX_DIMENSIONS
];
205 GFC_INTEGER_1
* restrict dest
;
206 const GFC_INTEGER_1
* restrict base
;
207 const GFC_LOGICAL_1
* restrict mbase
;
217 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
219 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
223 mbase
= mask
->base_addr
;
225 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
227 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
228 #ifdef HAVE_GFC_LOGICAL_16
232 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
234 runtime_error ("Funny sized logical array");
236 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
237 mdelta
= GFC_DESCRIPTOR_STRIDE_BYTES(mask
,dim
);
239 for (n
= 0; n
< dim
; n
++)
241 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
242 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
243 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
249 for (n
= dim
; n
< rank
; n
++)
251 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
+ 1);
252 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
, n
+ 1);
253 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
259 if (retarray
->base_addr
== NULL
)
261 size_t alloc_size
, str
;
263 for (n
= 0; n
< rank
; n
++)
268 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
270 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
274 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
276 retarray
->offset
= 0;
277 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
281 /* Make sure we have a zero-sized array. */
282 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
286 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_1
));
291 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
292 runtime_error ("rank of return array incorrect in IPARITY intrinsic");
294 if (unlikely (compile_options
.bounds_check
))
296 bounds_ifunction_return ((array_t
*) retarray
, extent
,
297 "return value", "IPARITY");
298 bounds_equal_extents ((array_t
*) mask
, (array_t
*) array
,
299 "MASK argument", "IPARITY");
303 for (n
= 0; n
< rank
; n
++)
306 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
311 dest
= retarray
->base_addr
;
312 base
= array
->base_addr
;
316 const GFC_INTEGER_1
* restrict src
;
317 const GFC_LOGICAL_1
* restrict msrc
;
318 GFC_INTEGER_1 result
;
324 for (n
= 0; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
332 /* Advance to the next element. */
338 while (count
[n
] == extent
[n
])
340 /* When we get to the end of a dimension, reset it and increment
341 the next dimension. */
343 /* We could precalculate these products, but this is a less
344 frequently used path so probably not worth it. */
345 base
-= sstride
[n
] * extent
[n
];
346 mbase
-= mstride
[n
] * extent
[n
];
347 dest
-= dstride
[n
] * extent
[n
];
351 /* Break out of the look. */
367 extern void siparity_i1 (gfc_array_i1
* const restrict
,
368 gfc_array_i1
* const restrict
, const index_type
* const restrict
,
370 export_proto(siparity_i1
);
373 siparity_i1 (gfc_array_i1
* const restrict retarray
,
374 gfc_array_i1
* const restrict array
,
375 const index_type
* const restrict pdim
,
376 GFC_LOGICAL_4
* mask
)
378 index_type count
[GFC_MAX_DIMENSIONS
];
379 index_type extent
[GFC_MAX_DIMENSIONS
];
380 index_type dstride
[GFC_MAX_DIMENSIONS
];
381 GFC_INTEGER_1
* restrict dest
;
389 iparity_i1 (retarray
, array
, pdim
);
392 /* Make dim zero based to avoid confusion. */
394 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
396 for (n
= 0; n
< dim
; n
++)
398 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
404 for (n
= dim
; n
< rank
; n
++)
407 GFC_DESCRIPTOR_EXTENT(array
,n
+ 1);
413 if (retarray
->base_addr
== NULL
)
415 size_t alloc_size
, str
;
417 for (n
= 0; n
< rank
; n
++)
422 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
424 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
428 retarray
->offset
= 0;
429 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
431 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
435 /* Make sure we have a zero-sized array. */
436 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
440 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_1
));
444 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
445 runtime_error ("rank of return array incorrect in"
446 " IPARITY intrinsic: is %ld, should be %ld",
447 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
450 if (unlikely (compile_options
.bounds_check
))
452 for (n
=0; n
< rank
; n
++)
454 index_type ret_extent
;
456 ret_extent
= GFC_DESCRIPTOR_EXTENT(retarray
,n
);
457 if (extent
[n
] != ret_extent
)
458 runtime_error ("Incorrect extent in return value of"
459 " IPARITY intrinsic in dimension %ld:"
460 " is %ld, should be %ld", (long int) n
+ 1,
461 (long int) ret_extent
, (long int) extent
[n
]);
466 for (n
= 0; n
< rank
; n
++)
469 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
472 dest
= retarray
->base_addr
;
480 while (count
[n
] == extent
[n
])
482 /* When we get to the end of a dimension, reset it and increment
483 the next dimension. */
485 /* We could precalculate these products, but this is a less
486 frequently used path so probably not worth it. */
487 dest
-= dstride
[n
] * extent
[n
];