OpenCores
URL https://opencores.org/ocsvn/scarts/scarts/trunk

Subversion Repositories scarts

[/] [scarts/] [trunk/] [toolchain/] [scarts-gcc/] [gcc-4.1.1/] [libgfortran/] [m4/] [iforeach.m4] - Blame information for rev 14

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 14 jlechner 
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 95 Runtime Library (libgfortran)
4 
dnl Distributed under the GNU GPL with exception.  See COPYING for details.
5 
define(START_FOREACH_FUNCTION,
6 
`
7 
extern void name`'rtype_qual`_'atype_code (rtype * retarray, atype *array);
8 
export_proto(name`'rtype_qual`_'atype_code);
9 
 
10 
void
11 
name`'rtype_qual`_'atype_code (rtype * retarray, atype *array)
12 
{
13 
  index_type count[GFC_MAX_DIMENSIONS];
14 
  index_type extent[GFC_MAX_DIMENSIONS];
15 
  index_type sstride[GFC_MAX_DIMENSIONS];
16 
  index_type dstride;
17 
  atype_name *base;
18 
  rtype_name *dest;
19 
  index_type rank;
20 
  index_type n;
21 
 
22 
  rank = GFC_DESCRIPTOR_RANK (array);
23 
  if (rank <= 0)
24 
    runtime_error ("Rank of array needs to be > 0");
25 
 
26 
  if (retarray->data == NULL)
27 
    {
28 
      retarray->dim[0].lbound = 0;
29 
      retarray->dim[0].ubound = rank-1;
30 
      retarray->dim[0].stride = 1;
31 
      retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
32 
      retarray->offset = 0;
33 
      retarray->data = internal_malloc_size (sizeof (rtype_name) * rank);
34 
    }
35 
  else
36 
    {
37 
      if (GFC_DESCRIPTOR_RANK (retarray) != 1)
38 
        runtime_error ("rank of return array does not equal 1");
39 
 
40 
      if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
41 
        runtime_error ("dimension of return array incorrect");
42 
 
43 
      if (retarray->dim[0].stride == 0)
44 
        retarray->dim[0].stride = 1;
45 
    }
46 
 
47 
  /* TODO:  It should be a front end job to correctly set the strides.  */
48 
 
49 
  if (array->dim[0].stride == 0)
50 
    array->dim[0].stride = 1;
51 
 
52 
  dstride = retarray->dim[0].stride;
53 
  dest = retarray->data;
54 
  for (n = 0; n < rank; n++)
55 
    {
56 
      sstride[n] = array->dim[n].stride;
57 
      extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
58 
      count[n] = 0;
59 
      if (extent[n] <= 0)
60 
        {
61 
          /* Set the return value.  */
62 
          for (n = 0; n < rank; n++)
63 
            dest[n * dstride] = 0;
64 
          return;
65 
        }
66 
    }
67 
 
68 
  base = array->data;
69 
 
70 
  /* Initialize the return value.  */
71 
  for (n = 0; n < rank; n++)
72 
    dest[n * dstride] = 0;
73 
  {
74 
')dnl
75 
define(START_FOREACH_BLOCK,
76 
`  while (base)
77 
    {
78 
      {
79 
        /* Implementation start.  */
80 
')dnl
81 
define(FINISH_FOREACH_FUNCTION,
82 
`        /* Implementation end.  */
83 
      }
84 
      /* Advance to the next element.  */
85 
      count[0]++;
86 
      base += sstride[0];
87 
      n = 0;
88 
      while (count[n] == extent[n])
89 
        {
90 
          /* When we get to the end of a dimension, reset it and increment
91 
             the next dimension.  */
92 
          count[n] = 0;
93 
          /* We could precalculate these products, but this is a less
94 
             frequently used path so proabably not worth it.  */
95 
          base -= sstride[n] * extent[n];
96 
          n++;
97 
          if (n == rank)
98 
            {
99 
              /* Break out of the loop.  */
100 
              base = NULL;
101 
              break;
102 
            }
103 
          else
104 
            {
105 
              count[n]++;
106 
              base += sstride[n];
107 
            }
108 
        }
109 
    }
110 
  }
111 
}')dnl
112 
define(START_MASKED_FOREACH_FUNCTION,
113 
`
114 
extern void `m'name`'rtype_qual`_'atype_code (rtype *, atype *, gfc_array_l4 *);
115 
export_proto(`m'name`'rtype_qual`_'atype_code);
116 
 
117 
void
118 
`m'name`'rtype_qual`_'atype_code (rtype * retarray, atype *array,
119 
                                  gfc_array_l4 * mask)
120 
{
121 
  index_type count[GFC_MAX_DIMENSIONS];
122 
  index_type extent[GFC_MAX_DIMENSIONS];
123 
  index_type sstride[GFC_MAX_DIMENSIONS];
124 
  index_type mstride[GFC_MAX_DIMENSIONS];
125 
  index_type dstride;
126 
  rtype_name *dest;
127 
  atype_name *base;
128 
  GFC_LOGICAL_4 *mbase;
129 
  int rank;
130 
  index_type n;
131 
 
132 
  rank = GFC_DESCRIPTOR_RANK (array);
133 
  if (rank <= 0)
134 
    runtime_error ("Rank of array needs to be > 0");
135 
 
136 
  if (retarray->data == NULL)
137 
    {
138 
      retarray->dim[0].lbound = 0;
139 
      retarray->dim[0].ubound = rank-1;
140 
      retarray->dim[0].stride = 1;
141 
      retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
142 
      retarray->offset = 0;
143 
      retarray->data = internal_malloc_size (sizeof (rtype_name) * rank);
144 
    }
145 
  else
146 
    {
147 
      if (GFC_DESCRIPTOR_RANK (retarray) != 1)
148 
        runtime_error ("rank of return array does not equal 1");
149 
 
150 
      if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
151 
        runtime_error ("dimension of return array incorrect");
152 
 
153 
      if (retarray->dim[0].stride == 0)
154 
        retarray->dim[0].stride = 1;
155 
    }
156 
 
157 
  /* TODO:  It should be a front end job to correctly set the strides.  */
158 
 
159 
  if (array->dim[0].stride == 0)
160 
    array->dim[0].stride = 1;
161 
 
162 
  if (mask->dim[0].stride == 0)
163 
    mask->dim[0].stride = 1;
164 
 
165 
  dstride = retarray->dim[0].stride;
166 
  dest = retarray->data;
167 
  for (n = 0; n < rank; n++)
168 
    {
169 
      sstride[n] = array->dim[n].stride;
170 
      mstride[n] = mask->dim[n].stride;
171 
      extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
172 
      count[n] = 0;
173 
      if (extent[n] <= 0)
174 
        {
175 
          /* Set the return value.  */
176 
          for (n = 0; n < rank; n++)
177 
            dest[n * dstride] = 0;
178 
          return;
179 
        }
180 
    }
181 
 
182 
  base = array->data;
183 
  mbase = mask->data;
184 
 
185 
  if (GFC_DESCRIPTOR_SIZE (mask) != 4)
186 
    {
187 
      /* This allows the same loop to be used for all logical types.  */
188 
      assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
189 
      for (n = 0; n < rank; n++)
190 
        mstride[n] <<= 1;
191 
      mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
192 
    }
193 
 
194 
 
195 
  /* Initialize the return value.  */
196 
  for (n = 0; n < rank; n++)
197 
    dest[n * dstride] = 0;
198 
  {
199 
')dnl
200 
define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl
201 
define(FINISH_MASKED_FOREACH_FUNCTION,
202 
`        /* Implementation end.  */
203 
      }
204 
      /* Advance to the next element.  */
205 
      count[0]++;
206 
      base += sstride[0];
207 
      mbase += mstride[0];
208 
      n = 0;
209 
      while (count[n] == extent[n])
210 
        {
211 
          /* When we get to the end of a dimension, reset it and increment
212 
             the next dimension.  */
213 
          count[n] = 0;
214 
          /* We could precalculate these products, but this is a less
215 
             frequently used path so proabably not worth it.  */
216 
          base -= sstride[n] * extent[n];
217 
          mbase -= mstride[n] * extent[n];
218 
          n++;
219 
          if (n == rank)
220 
            {
221 
              /* Break out of the loop.  */
222 
              base = NULL;
223 
              break;
224 
            }
225 
          else
226 
            {
227 
              count[n]++;
228 
              base += sstride[n];
229 
              mbase += mstride[n];
230 
            }
231 
        }
232 
    }
233 
  }
234 
}')dnl
235 
define(FOREACH_FUNCTION,
236 
`START_FOREACH_FUNCTION
237 
$1
238 
START_FOREACH_BLOCK
239 
$2
240 
FINISH_FOREACH_FUNCTION')dnl
241 
define(MASKED_FOREACH_FUNCTION,
242 
`START_MASKED_FOREACH_FUNCTION
243 
$1
244 
START_MASKED_FOREACH_BLOCK
245 
$2
246 
FINISH_MASKED_FOREACH_FUNCTION')dnl
247 
define(SCALAR_FOREACH_FUNCTION,
248 
`
249 
extern void `s'name`'rtype_qual`_'atype_code (rtype * const restrict,
250 
        atype * const restrict, GFC_LOGICAL_4 *);
251 
export_proto(`s'name`'rtype_qual`_'atype_code);
252 
 
253 
void
254 
`s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
255 
        atype * const restrict array,
256 
        GFC_LOGICAL_4 * mask)
257 
{
258 
  index_type rank;
259 
  index_type dstride;
260 
  index_type n;
261 
  rtype_name *dest;
262 
 
263 
  if (*mask)
264 
    {
265 
      name`'rtype_qual`_'atype_code (retarray, array);
266 
      return;
267 
    }
268 
 
269 
  rank = GFC_DESCRIPTOR_RANK (array);
270 
 
271 
  if (rank <= 0)
272 
    runtime_error ("Rank of array needs to be > 0");
273 
 
274 
  if (retarray->data == NULL)
275 
    {
276 
      retarray->dim[0].lbound = 0;
277 
      retarray->dim[0].ubound = rank-1;
278 
      retarray->dim[0].stride = 1;
279 
      retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
280 
      retarray->offset = 0;
281 
      retarray->data = internal_malloc_size (sizeof (rtype_name) * rank);
282 
    }
283 
  else
284 
    {
285 
      if (GFC_DESCRIPTOR_RANK (retarray) != 1)
286 
        runtime_error ("rank of return array does not equal 1");
287 
 
288 
      if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
289 
        runtime_error ("dimension of return array incorrect");
290 
 
291 
      if (retarray->dim[0].stride == 0)
292 
        retarray->dim[0].stride = 1;
293 
    }
294 
 
295 
  dstride = retarray->dim[0].stride;
296 
  dest = retarray->data;
297 
  for (n = 0; n<rank; n++)
298 
    dest[n * dstride] = $1 ;
299 
}')dnl

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.