|
131
|
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)
|
|
|
8 {
|
|
|
9 if (sizeof ('atype_name`) == 1)
|
|
|
10 return memcmp (a, b, n);
|
|
|
11 else
|
|
|
12 return memcmp_char4 (a, b, n);
|
|
|
13
|
|
|
14 }
|
|
|
15
|
|
|
16 #define INITVAL 'initval`
|
|
|
17
|
|
|
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);
|
|
|
22
|
|
|
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)
|
|
|
27 {
|
|
|
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;
|
|
|
34
|
|
|
35 rank = GFC_DESCRIPTOR_RANK (array);
|
|
|
36 if (rank <= 0)
|
|
|
37 runtime_error ("Rank of array needs to be > 0");
|
|
|
38
|
|
|
39 assert (xlen == len);
|
|
|
40
|
|
|
41 /* Initialize return value. */
|
|
|
42 memset (ret, INITVAL, sizeof(*ret) * len);
|
|
|
43
|
|
|
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 }
|
|
|
52
|
|
|
53 base = array->base_addr;
|
|
|
54
|
|
|
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,
|
|
|
98 `
|
|
|
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);
|
|
|
103
|
|
|
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)
|
|
|
108 {
|
|
|
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;
|
|
|
118
|
|
|
119 rank = GFC_DESCRIPTOR_RANK (array);
|
|
|
120 if (rank <= 0)
|
|
|
121 runtime_error ("Rank of array needs to be > 0");
|
|
|
122
|
|
|
123 assert (xlen == len);
|
|
|
124
|
|
|
125 /* Initialize return value. */
|
|
|
126 memset (ret, INITVAL, sizeof(*ret) * len);
|
|
|
127
|
|
|
128 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
|
|
|
129
|
|
|
130 mbase = mask->base_addr;
|
|
|
131
|
|
|
132 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
|
|
|
133 #ifdef HAVE_GFC_LOGICAL_16
|
|
|
134 || mask_kind == 16
|
|
|
135 #endif
|
|
|
136 )
|
|
|
137 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
|
|
|
138 else
|
|
|
139 runtime_error ("Funny sized logical array");
|
|
|
140
|
|
|
141 for (n = 0; n < rank; n++)
|
|
|
142 {
|
|
|
143 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
|
|
|
144 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
|
|
|
145 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
|
|
146 count[n] = 0;
|
|
|
147 if (extent[n] <= 0)
|
|
|
148 return;
|
|
|
149 }
|
|
|
150
|
|
|
151 base = array->base_addr;
|
|
|
152 {
|
|
|
153 ')dnl
|
|
|
154 define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl
|
|
|
155 define(FINISH_MASKED_FOREACH_FUNCTION,
|
|
|
156 ` /* Implementation end. */
|
|
|
157 /* Advance to the next element. */
|
|
|
158 base += sstride[0];
|
|
|
159 mbase += mstride[0];
|
|
|
160 }
|
|
|
161 while (++count[0] != extent[0]);
|
|
|
162 n = 0;
|
|
|
163 do
|
|
|
164 {
|
|
|
165 /* When we get to the end of a dimension, reset it and increment
|
|
|
166 the next dimension. */
|
|
|
167 count[n] = 0;
|
|
|
168 /* We could precalculate these products, but this is a less
|
|
|
169 frequently used path so probably not worth it. */
|
|
|
170 base -= sstride[n] * extent[n];
|
|
|
171 mbase -= mstride[n] * extent[n];
|
|
|
172 n++;
|
|
|
173 if (n >= rank)
|
|
|
174 {
|
|
|
175 /* Break out of the loop. */
|
|
|
176 base = NULL;
|
|
|
177 break;
|
|
|
178 }
|
|
|
179 else
|
|
|
180 {
|
|
|
181 count[n]++;
|
|
|
182 base += sstride[n];
|
|
|
183 mbase += mstride[n];
|
|
|
184 }
|
|
|
185 }
|
|
|
186 while (count[n] == extent[n]);
|
|
|
187 }
|
|
|
188 memcpy (ret, retval, len * sizeof (*ret));
|
|
|
189 }
|
|
|
190 }')dnl
|
|
|
191 define(FOREACH_FUNCTION,
|
|
|
192 `START_FOREACH_FUNCTION
|
|
|
193 $1
|
|
|
194 START_FOREACH_BLOCK
|
|
|
195 $2
|
|
|
196 FINISH_FOREACH_FUNCTION')dnl
|
|
|
197 define(MASKED_FOREACH_FUNCTION,
|
|
|
198 `START_MASKED_FOREACH_FUNCTION
|
|
|
199 $1
|
|
|
200 START_MASKED_FOREACH_BLOCK
|
|
|
201 $2
|
|
|
202 FINISH_MASKED_FOREACH_FUNCTION')dnl
|
|
|
203 define(SCALAR_FOREACH_FUNCTION,
|
|
|
204 `
|
|
|
205 extern void `s'name`'rtype_qual`_'atype_code (atype_name * restrict,
|
|
|
206 gfc_charlen_type,
|
|
|
207 atype * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type);
|
|
|
208 export_proto(`s'name`'rtype_qual`_'atype_code);
|
|
|
209
|
|
|
210 void
|
|
|
211 `s'name`'rtype_qual`_'atype_code (atype_name * restrict ret,
|
|
|
212 gfc_charlen_type xlen, atype * const restrict array,
|
|
|
213 GFC_LOGICAL_4 *mask, gfc_charlen_type len)
|
|
|
214
|
|
|
215 {
|
|
|
216 if (*mask)
|
|
|
217 {
|
|
|
218 name`'rtype_qual`_'atype_code (ret, xlen, array, len);
|
|
|
219 return;
|
|
|
220 }
|
|
|
221 memset (ret, INITVAL, sizeof (*ret) * len);
|
|
|
222 }')dnl
|
