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
|
145
|
119 if (mask == NULL)
|
|
120 {
|
|
121 name`'rtype_qual`_'atype_code (ret, xlen, array, len);
|
|
122 return;
|
|
123 }
|
|
124
|
131
|
125 rank = GFC_DESCRIPTOR_RANK (array);
|
|
126 if (rank <= 0)
|
|
127 runtime_error ("Rank of array needs to be > 0");
|
|
128
|
|
129 assert (xlen == len);
|
|
130
|
|
131 /* Initialize return value. */
|
|
132 memset (ret, INITVAL, sizeof(*ret) * len);
|
|
133
|
|
134 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
|
|
135
|
|
136 mbase = mask->base_addr;
|
|
137
|
|
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");
|
|
146
|
|
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 }
|
|
156
|
|
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
|
|
199 $1
|
|
200 START_FOREACH_BLOCK
|
|
201 $2
|
|
202 FINISH_FOREACH_FUNCTION')dnl
|
|
203 define(MASKED_FOREACH_FUNCTION,
|
|
204 `START_MASKED_FOREACH_FUNCTION
|
|
205 $1
|
|
206 START_MASKED_FOREACH_BLOCK
|
|
207 $2
|
|
208 FINISH_MASKED_FOREACH_FUNCTION')dnl
|
|
209 define(SCALAR_FOREACH_FUNCTION,
|
|
210 `
|
|
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);
|
|
215
|
|
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
|
|
221 {
|
145
|
222 if (mask == NULL || *mask)
|
131
|
223 {
|
|
224 name`'rtype_qual`_'atype_code (ret, xlen, array, len);
|
|
225 return;
|
|
226 }
|
|
227 memset (ret, INITVAL, sizeof (*ret) * len);
|
|
228 }')dnl
|