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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [libgfortran/] [m4/] [ifunction.m4] - Blame information for rev 733

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 733 jeremybenn
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
dnl
6
dnl Pass the implementation for a single section as the parameter to
7
dnl {MASK_}ARRAY_FUNCTION.
8
dnl The variables base, delta, and len describe the input section.
9
dnl For masked section the mask is described by mbase and mdelta.
10
dnl These should not be modified. The result should be stored in *dest.
11
dnl The names count, extent, sstride, dstride, base, dest, rank, dim
12
dnl retarray, array, pdim and mstride should not be used.
13
dnl The variable n is declared as index_type and may be used.
14
dnl Other variable declarations may be placed at the start of the code,
15
dnl The types of the array parameter and the return value are
16
dnl atype_name and rtype_name respectively.
17
dnl Execution should be allowed to continue to the end of the block.
18
dnl You should not return or break from the inner loop of the implementation.
19
dnl Care should also be taken to avoid using the names defined in iparm.m4
20
define(START_ARRAY_FUNCTION,
21
`
22
extern void name`'rtype_qual`_'atype_code (rtype * const restrict,
23
        atype * const restrict, const index_type * const restrict);
24
export_proto(name`'rtype_qual`_'atype_code);
25
 
26
void
27
name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
28
        atype * const restrict array,
29
        const index_type * const restrict pdim)
30
{
31
  index_type count[GFC_MAX_DIMENSIONS];
32
  index_type extent[GFC_MAX_DIMENSIONS];
33
  index_type sstride[GFC_MAX_DIMENSIONS];
34
  index_type dstride[GFC_MAX_DIMENSIONS];
35
  const atype_name * restrict base;
36
  rtype_name * restrict dest;
37
  index_type rank;
38
  index_type n;
39
  index_type len;
40
  index_type delta;
41
  index_type dim;
42
  int continue_loop;
43
 
44
  /* Make dim zero based to avoid confusion.  */
45
  dim = (*pdim) - 1;
46
  rank = GFC_DESCRIPTOR_RANK (array) - 1;
47
 
48
  len = GFC_DESCRIPTOR_EXTENT(array,dim);
49
  if (len < 0)
50
    len = 0;
51
  delta = GFC_DESCRIPTOR_STRIDE(array,dim);
52
 
53
  for (n = 0; n < dim; n++)
54
    {
55
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
56
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
57
 
58
      if (extent[n] < 0)
59
        extent[n] = 0;
60
    }
61
  for (n = dim; n < rank; n++)
62
    {
63
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
64
      extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
65
 
66
      if (extent[n] < 0)
67
        extent[n] = 0;
68
    }
69
 
70
  if (retarray->data == NULL)
71
    {
72
      size_t alloc_size, str;
73
 
74
      for (n = 0; n < rank; n++)
75
        {
76
          if (n == 0)
77
            str = 1;
78
          else
79
            str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
80
 
81
          GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
82
 
83
        }
84
 
85
      retarray->offset = 0;
86
      retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
87
 
88
      alloc_size = sizeof (rtype_name) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
89
                   * extent[rank-1];
90
 
91
      retarray->data = internal_malloc_size (alloc_size);
92
      if (alloc_size == 0)
93
        {
94
          /* Make sure we have a zero-sized array.  */
95
          GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
96
          return;
97
 
98
        }
99
    }
100
  else
101
    {
102
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
103
        runtime_error ("rank of return array incorrect in"
104
                       " u_name intrinsic: is %ld, should be %ld",
105
                       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
106
                       (long int) rank);
107
 
108
      if (unlikely (compile_options.bounds_check))
109
        bounds_ifunction_return ((array_t *) retarray, extent,
110
                                 "return value", "u_name");
111
    }
112
 
113
  for (n = 0; n < rank; n++)
114
    {
115
      count[n] = 0;
116
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
117
      if (extent[n] <= 0)
118
        return;
119
    }
120
 
121
  base = array->data;
122
  dest = retarray->data;
123
 
124
  continue_loop = 1;
125
  while (continue_loop)
126
    {
127
      const atype_name * restrict src;
128
      rtype_name result;
129
      src = base;
130
      {
131
')dnl
132
define(START_ARRAY_BLOCK,
133
`       if (len <= 0)
134
          *dest = '$1`;
135
        else
136
          {
137
            for (n = 0; n < len; n++, src += delta)
138
              {
139
')dnl
140
define(FINISH_ARRAY_FUNCTION,
141
`             }
142
            '$1`
143
            *dest = result;
144
          }
145
      }
146
      /* Advance to the next element.  */
147
      count[0]++;
148
      base += sstride[0];
149
      dest += dstride[0];
150
      n = 0;
151
      while (count[n] == extent[n])
152
        {
153
          /* When we get to the end of a dimension, reset it and increment
154
             the next dimension.  */
155
          count[n] = 0;
156
          /* We could precalculate these products, but this is a less
157
             frequently used path so probably not worth it.  */
158
          base -= sstride[n] * extent[n];
159
          dest -= dstride[n] * extent[n];
160
          n++;
161
          if (n == rank)
162
            {
163
              /* Break out of the look.  */
164
              continue_loop = 0;
165
              break;
166
            }
167
          else
168
            {
169
              count[n]++;
170
              base += sstride[n];
171
              dest += dstride[n];
172
            }
173
        }
174
    }
175
}')dnl
176
define(START_MASKED_ARRAY_FUNCTION,
177
`
178
extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict,
179
        atype * const restrict, const index_type * const restrict,
180
        gfc_array_l1 * const restrict);
181
export_proto(`m'name`'rtype_qual`_'atype_code);
182
 
183
void
184
`m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
185
        atype * const restrict array,
186
        const index_type * const restrict pdim,
187
        gfc_array_l1 * const restrict mask)
188
{
189
  index_type count[GFC_MAX_DIMENSIONS];
190
  index_type extent[GFC_MAX_DIMENSIONS];
191
  index_type sstride[GFC_MAX_DIMENSIONS];
192
  index_type dstride[GFC_MAX_DIMENSIONS];
193
  index_type mstride[GFC_MAX_DIMENSIONS];
194
  rtype_name * restrict dest;
195
  const atype_name * restrict base;
196
  const GFC_LOGICAL_1 * restrict mbase;
197
  int rank;
198
  int dim;
199
  index_type n;
200
  index_type len;
201
  index_type delta;
202
  index_type mdelta;
203
  int mask_kind;
204
 
205
  dim = (*pdim) - 1;
206
  rank = GFC_DESCRIPTOR_RANK (array) - 1;
207
 
208
  len = GFC_DESCRIPTOR_EXTENT(array,dim);
209
  if (len <= 0)
210
    return;
211
 
212
  mbase = mask->data;
213
 
214
  mask_kind = GFC_DESCRIPTOR_SIZE (mask);
215
 
216
  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
217
#ifdef HAVE_GFC_LOGICAL_16
218
      || mask_kind == 16
219
#endif
220
      )
221
    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
222
  else
223
    runtime_error ("Funny sized logical array");
224
 
225
  delta = GFC_DESCRIPTOR_STRIDE(array,dim);
226
  mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
227
 
228
  for (n = 0; n < dim; n++)
229
    {
230
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
231
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
232
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
233
 
234
      if (extent[n] < 0)
235
        extent[n] = 0;
236
 
237
    }
238
  for (n = dim; n < rank; n++)
239
    {
240
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
241
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
242
      extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
243
 
244
      if (extent[n] < 0)
245
        extent[n] = 0;
246
    }
247
 
248
  if (retarray->data == NULL)
249
    {
250
      size_t alloc_size, str;
251
 
252
      for (n = 0; n < rank; n++)
253
        {
254
          if (n == 0)
255
            str = 1;
256
          else
257
            str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
258
 
259
          GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
260
 
261
        }
262
 
263
      alloc_size = sizeof (rtype_name) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
264
                   * extent[rank-1];
265
 
266
      retarray->offset = 0;
267
      retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
268
 
269
      if (alloc_size == 0)
270
        {
271
          /* Make sure we have a zero-sized array.  */
272
          GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
273
          return;
274
        }
275
      else
276
        retarray->data = internal_malloc_size (alloc_size);
277
 
278
    }
279
  else
280
    {
281
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
282
        runtime_error ("rank of return array incorrect in u_name intrinsic");
283
 
284
      if (unlikely (compile_options.bounds_check))
285
        {
286
          bounds_ifunction_return ((array_t *) retarray, extent,
287
                                   "return value", "u_name");
288
          bounds_equal_extents ((array_t *) mask, (array_t *) array,
289
                                "MASK argument", "u_name");
290
        }
291
    }
292
 
293
  for (n = 0; n < rank; n++)
294
    {
295
      count[n] = 0;
296
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
297
      if (extent[n] <= 0)
298
        return;
299
    }
300
 
301
  dest = retarray->data;
302
  base = array->data;
303
 
304
  while (base)
305
    {
306
      const atype_name * restrict src;
307
      const GFC_LOGICAL_1 * restrict msrc;
308
      rtype_name result;
309
      src = base;
310
      msrc = mbase;
311
      {
312
')dnl
313
define(START_MASKED_ARRAY_BLOCK,
314
`       if (len <= 0)
315
          *dest = '$1`;
316
        else
317
          {
318
            for (n = 0; n < len; n++, src += delta, msrc += mdelta)
319
              {
320
')dnl
321
define(FINISH_MASKED_ARRAY_FUNCTION,
322
`             }
323
            *dest = result;
324
          }
325
      }
326
      /* Advance to the next element.  */
327
      count[0]++;
328
      base += sstride[0];
329
      mbase += mstride[0];
330
      dest += dstride[0];
331
      n = 0;
332
      while (count[n] == extent[n])
333
        {
334
          /* When we get to the end of a dimension, reset it and increment
335
             the next dimension.  */
336
          count[n] = 0;
337
          /* We could precalculate these products, but this is a less
338
             frequently used path so probably not worth it.  */
339
          base -= sstride[n] * extent[n];
340
          mbase -= mstride[n] * extent[n];
341
          dest -= dstride[n] * extent[n];
342
          n++;
343
          if (n == rank)
344
            {
345
              /* Break out of the look.  */
346
              base = NULL;
347
              break;
348
            }
349
          else
350
            {
351
              count[n]++;
352
              base += sstride[n];
353
              mbase += mstride[n];
354
              dest += dstride[n];
355
            }
356
        }
357
    }
358
}')dnl
359
define(SCALAR_ARRAY_FUNCTION,
360
`
361
extern void `s'name`'rtype_qual`_'atype_code (rtype * const restrict,
362
        atype * const restrict, const index_type * const restrict,
363
        GFC_LOGICAL_4 *);
364
export_proto(`s'name`'rtype_qual`_'atype_code);
365
 
366
void
367
`s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
368
        atype * const restrict array,
369
        const index_type * const restrict pdim,
370
        GFC_LOGICAL_4 * mask)
371
{
372
  index_type count[GFC_MAX_DIMENSIONS];
373
  index_type extent[GFC_MAX_DIMENSIONS];
374
  index_type dstride[GFC_MAX_DIMENSIONS];
375
  rtype_name * restrict dest;
376
  index_type rank;
377
  index_type n;
378
  index_type dim;
379
 
380
 
381
  if (*mask)
382
    {
383
      name`'rtype_qual`_'atype_code (retarray, array, pdim);
384
      return;
385
    }
386
  /* Make dim zero based to avoid confusion.  */
387
  dim = (*pdim) - 1;
388
  rank = GFC_DESCRIPTOR_RANK (array) - 1;
389
 
390
  for (n = 0; n < dim; n++)
391
    {
392
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
393
 
394
      if (extent[n] <= 0)
395
        extent[n] = 0;
396
    }
397
 
398
  for (n = dim; n < rank; n++)
399
    {
400
      extent[n] =
401
        GFC_DESCRIPTOR_EXTENT(array,n + 1);
402
 
403
      if (extent[n] <= 0)
404
        extent[n] = 0;
405
    }
406
 
407
  if (retarray->data == NULL)
408
    {
409
      size_t alloc_size, str;
410
 
411
      for (n = 0; n < rank; n++)
412
        {
413
          if (n == 0)
414
            str = 1;
415
          else
416
            str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
417
 
418
          GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
419
 
420
        }
421
 
422
      retarray->offset = 0;
423
      retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
424
 
425
      alloc_size = sizeof (rtype_name) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
426
                   * extent[rank-1];
427
 
428
      if (alloc_size == 0)
429
        {
430
          /* Make sure we have a zero-sized array.  */
431
          GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
432
          return;
433
        }
434
      else
435
        retarray->data = internal_malloc_size (alloc_size);
436
    }
437
  else
438
    {
439
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
440
        runtime_error ("rank of return array incorrect in"
441
                       " u_name intrinsic: is %ld, should be %ld",
442
                       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
443
                       (long int) rank);
444
 
445
      if (unlikely (compile_options.bounds_check))
446
        {
447
          for (n=0; n < rank; n++)
448
            {
449
              index_type ret_extent;
450
 
451
              ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
452
              if (extent[n] != ret_extent)
453
                runtime_error ("Incorrect extent in return value of"
454
                               " u_name intrinsic in dimension %ld:"
455
                               " is %ld, should be %ld", (long int) n + 1,
456
                               (long int) ret_extent, (long int) extent[n]);
457
            }
458
        }
459
    }
460
 
461
  for (n = 0; n < rank; n++)
462
    {
463
      count[n] = 0;
464
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
465
    }
466
 
467
  dest = retarray->data;
468
 
469
  while(1)
470
    {
471
      *dest = '$1`;
472
      count[0]++;
473
      dest += dstride[0];
474
      n = 0;
475
      while (count[n] == extent[n])
476
        {
477
          /* When we get to the end of a dimension, reset it and increment
478
             the next dimension.  */
479
          count[n] = 0;
480
          /* We could precalculate these products, but this is a less
481
             frequently used path so probably not worth it.  */
482
          dest -= dstride[n] * extent[n];
483
          n++;
484
          if (n == rank)
485
            return;
486
          else
487
            {
488
              count[n]++;
489
              dest += dstride[n];
490
            }
491
        }
492
    }
493
}')dnl
494
define(ARRAY_FUNCTION,
495
`START_ARRAY_FUNCTION
496
$2
497
START_ARRAY_BLOCK($1)
498
$3
499
FINISH_ARRAY_FUNCTION($4)')dnl
500
define(MASKED_ARRAY_FUNCTION,
501
`START_MASKED_ARRAY_FUNCTION
502
$2
503
START_MASKED_ARRAY_BLOCK($1)
504
$3
505
FINISH_MASKED_ARRAY_FUNCTION')dnl

powered by: WebSVN 2.1.0

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