hppa: Implement TARGET_ATOMIC_ASSIGN_EXPAND_FENV
[official-gcc.git] / libgfortran / m4 / iforeach-s2.m4
blob63fde458ef1ac32b455a6bf9f7606f79d3052bc3
1 dnl Support macro file for intrinsic functions.
2 dnl Contains the generic sections of the array functions.
3 dnl This file is part of the GNU Fortran Runtime Library (libgfortran)
4 dnl Distributed under the GNU GPL with exception.  See COPYING for details.
5 define(START_FOREACH_FUNCTION,
6 `static inline int
7 compare_fcn (const atype_name *a, const atype_name *b, gfc_charlen_type n)
9   if (sizeof ('atype_name`) == 1)
10     return memcmp (a, b, n);
11   else
12     return memcmp_char4 (a, b, n);
16 #define INITVAL 'initval`
18 extern void 'name`'rtype_qual`_'atype_code (atype_name * restrict,
19         gfc_charlen_type,
20         atype * const restrict array, gfc_charlen_type);
21 export_proto(name`'rtype_qual`_'atype_code);
23 void
24 name`'rtype_qual`_'atype_code` ('atype_name` * restrict ret,
25         gfc_charlen_type xlen,
26         'atype` * const restrict array, gfc_charlen_type len)
28   index_type count[GFC_MAX_DIMENSIONS];
29   index_type extent[GFC_MAX_DIMENSIONS];
30   index_type sstride[GFC_MAX_DIMENSIONS];
31   const 'atype_name` *base;
32   index_type rank;
33   index_type n;
35   rank = GFC_DESCRIPTOR_RANK (array);
36   if (rank <= 0)
37     runtime_error ("Rank of array needs to be > 0");
39   assert (xlen == len);
41   /* Initialize return value.  */
42   memset (ret, INITVAL, sizeof(*ret) * len);
44   for (n = 0; n < rank; n++)
45     {
46       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
47       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
48       count[n] = 0;
49       if (extent[n] <= 0)
50         return;
51     }
53   base = array->base_addr;
55   {
56 ')dnl
57 define(START_FOREACH_BLOCK,
58 `  while (base)
59     {
60       do
61         {
62           /* Implementation start.  */
63 ')dnl
64 define(FINISH_FOREACH_FUNCTION,
65 `         /* Implementation end.  */
66           /* Advance to the next element.  */
67           base += sstride[0];
68         }
69       while (++count[0] != extent[0]);
70       n = 0;
71       do
72         {
73           /* When we get to the end of a dimension, reset it and increment
74              the next dimension.  */
75           count[n] = 0;
76           /* We could precalculate these products, but this is a less
77              frequently used path so probably not worth it.  */
78           base -= sstride[n] * extent[n];
79           n++;
80           if (n >= rank)
81             {
82               /* Break out of the loop.  */
83               base = NULL;
84               break;
85             }
86           else
87             {
88               count[n]++;
89               base += sstride[n];
90             }
91         }
92       while (count[n] == extent[n]);
93     }
94    memcpy (ret, retval, len * sizeof (*ret));
95   }
96 }')dnl
97 define(START_MASKED_FOREACH_FUNCTION,
99 extern void `m'name`'rtype_qual`_'atype_code (atype_name * restrict,
100        gfc_charlen_type, atype * const restrict array,
101        gfc_array_l1 * const restrict mask, gfc_charlen_type len);
102 export_proto(`m'name`'rtype_qual`_'atype_code);
104 void
105 `m'name`'rtype_qual`_'atype_code (atype_name * const restrict ret,
106         gfc_charlen_type xlen, atype * const restrict array,
107         gfc_array_l1 * const restrict mask, gfc_charlen_type len)
109   index_type count[GFC_MAX_DIMENSIONS];
110   index_type extent[GFC_MAX_DIMENSIONS];
111   index_type sstride[GFC_MAX_DIMENSIONS];
112   index_type mstride[GFC_MAX_DIMENSIONS];
113   const atype_name *base;
114   GFC_LOGICAL_1 *mbase;
115   int rank;
116   index_type n;
117   int mask_kind;
119   if (mask == NULL)
120     {
121       name`'rtype_qual`_'atype_code (ret, xlen, array, len);
122       return;
123     }
125   rank = GFC_DESCRIPTOR_RANK (array);
126   if (rank <= 0)
127     runtime_error ("Rank of array needs to be > 0");
129   assert (xlen == len);
131 /* Initialize return value.  */
132   memset (ret, INITVAL, sizeof(*ret) * len);
134   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
136   mbase = mask->base_addr;
138   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
139 #ifdef HAVE_GFC_LOGICAL_16
140       || mask_kind == 16
141 #endif
142       )
143     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
144   else
145     runtime_error ("Funny sized logical array");
147   for (n = 0; n < rank; n++)
148     {
149       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
150       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
151       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
152       count[n] = 0;
153       if (extent[n] <= 0)
154         return;
155     }
157   base = array->base_addr;
158   {
159 ')dnl
160 define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl
161 define(FINISH_MASKED_FOREACH_FUNCTION,
162 `         /* Implementation end.  */
163           /* Advance to the next element.  */
164           base += sstride[0];
165           mbase += mstride[0];
166         }
167       while (++count[0] != extent[0]);
168       n = 0;
169       do
170         {
171           /* When we get to the end of a dimension, reset it and increment
172              the next dimension.  */
173           count[n] = 0;
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           mbase -= mstride[n] * extent[n];
178           n++;
179           if (n >= rank)
180             {
181               /* Break out of the loop.  */
182               base = NULL;
183               break;
184             }
185           else
186             {
187               count[n]++;
188               base += sstride[n];
189               mbase += mstride[n];
190             }
191         }
192       while (count[n] == extent[n]);
193     }
194     memcpy (ret, retval, len * sizeof (*ret));
195   }
196 }')dnl
197 define(FOREACH_FUNCTION,
198 `START_FOREACH_FUNCTION
200 START_FOREACH_BLOCK
202 FINISH_FOREACH_FUNCTION')dnl
203 define(MASKED_FOREACH_FUNCTION,
204 `START_MASKED_FOREACH_FUNCTION
206 START_MASKED_FOREACH_BLOCK
208 FINISH_MASKED_FOREACH_FUNCTION')dnl
209 define(SCALAR_FOREACH_FUNCTION,
211 extern void `s'name`'rtype_qual`_'atype_code (atype_name * restrict,
212         gfc_charlen_type,
213         atype * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type);
214 export_proto(`s'name`'rtype_qual`_'atype_code);
216 void
217 `s'name`'rtype_qual`_'atype_code (atype_name * restrict ret,
218         gfc_charlen_type xlen, atype * const restrict array,
219         GFC_LOGICAL_4 *mask, gfc_charlen_type len)
220         
222   if (mask == NULL || *mask)
223     {
224       name`'rtype_qual`_'atype_code (ret, xlen, array, len);
225       return;
226     }
227   memset (ret, INITVAL, sizeof (*ret) * len);
228 }')dnl