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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [libgfortran/] [m4/] [ifunction_logical.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 95 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
        gfc_array_l1 * 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
        gfc_array_l1 * 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 GFC_LOGICAL_1 * 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 src_kind;
43
  int continue_loop;
44
 
45
  /* Make dim zero based to avoid confusion.  */
46
  dim = (*pdim) - 1;
47
  rank = GFC_DESCRIPTOR_RANK (array) - 1;
48
 
49
  src_kind = GFC_DESCRIPTOR_SIZE (array);
50
 
51
  len = GFC_DESCRIPTOR_EXTENT(array,dim);
52
  if (len < 0)
53
    len = 0;
54
 
55
  delta = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
56
 
57
  for (n = 0; n < dim; n++)
58
    {
59
      sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n);
60
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
61
 
62
      if (extent[n] < 0)
63
        extent[n] = 0;
64
    }
65
  for (n = dim; n < rank; n++)
66
    {
67
      sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n + 1);
68
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n + 1);
69
 
70
      if (extent[n] < 0)
71
        extent[n] = 0;
72
    }
73
 
74
  if (retarray->data == NULL)
75
    {
76
      size_t alloc_size, str;
77
 
78
      for (n = 0; n < rank; n++)
79
        {
80
          if (n == 0)
81
            str = 1;
82
          else
83
            str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
84
 
85
          GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
86
 
87
        }
88
 
89
      retarray->offset = 0;
90
      retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
91
 
92
      alloc_size = sizeof (rtype_name) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
93
                   * extent[rank-1];
94
 
95
      if (alloc_size == 0)
96
        {
97
          /* Make sure we have a zero-sized array.  */
98
          GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
99
          return;
100
        }
101
      else
102
        retarray->data = internal_malloc_size (alloc_size);
103
    }
104
  else
105
    {
106
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
107
        runtime_error ("rank of return array incorrect in"
108
                       " u_name intrinsic: is %ld, should be %ld",
109
                       (long int) GFC_DESCRIPTOR_RANK (retarray),
110
                       (long int) rank);
111
 
112
      if (unlikely (compile_options.bounds_check))
113
        {
114
          for (n=0; n < rank; n++)
115
            {
116
              index_type ret_extent;
117
 
118
              ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
119
              if (extent[n] != ret_extent)
120
                runtime_error ("Incorrect extent in return value of"
121
                               " u_name intrinsic in dimension %d:"
122
                               " is %ld, should be %ld", (int) n + 1,
123
                               (long int) ret_extent, (long int) extent[n]);
124
            }
125
        }
126
    }
127
 
128
  for (n = 0; n < rank; n++)
129
    {
130
      count[n] = 0;
131
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
132
      if (extent[n] <= 0)
133
        return;
134
    }
135
 
136
  base = array->data;
137
 
138
  if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8
139
#ifdef HAVE_GFC_LOGICAL_16
140
      || src_kind == 16
141
#endif
142
    )
143
    {
144
      if (base)
145
        base = GFOR_POINTER_TO_L1 (base, src_kind);
146
    }
147
  else
148
    internal_error (NULL, "Funny sized logical array in u_name intrinsic");
149
 
150
  dest = retarray->data;
151
 
152
  continue_loop = 1;
153
  while (continue_loop)
154
    {
155
      const GFC_LOGICAL_1 * restrict src;
156
      rtype_name result;
157
      src = base;
158
      {
159
')dnl
160
define(START_ARRAY_BLOCK,
161
`        if (len <= 0)
162
          *dest = '$1`;
163
        else
164
          {
165
            for (n = 0; n < len; n++, src += delta)
166
              {
167
')dnl
168
define(FINISH_ARRAY_FUNCTION,
169
    `          }
170
            *dest = result;
171
          }
172
      }
173
      /* Advance to the next element.  */
174
      count[0]++;
175
      base += sstride[0];
176
      dest += dstride[0];
177
      n = 0;
178
      while (count[n] == extent[n])
179
        {
180
          /* When we get to the end of a dimension, reset it and increment
181
             the next dimension.  */
182
          count[n] = 0;
183
          /* We could precalculate these products, but this is a less
184
             frequently used path so probably not worth it.  */
185
          base -= sstride[n] * extent[n];
186
          dest -= dstride[n] * extent[n];
187
          n++;
188
          if (n == rank)
189
            {
190
              /* Break out of the look.  */
191
              continue_loop = 0;
192
              break;
193
            }
194
          else
195
            {
196
              count[n]++;
197
              base += sstride[n];
198
              dest += dstride[n];
199
            }
200
        }
201
    }
202
}')dnl
203
define(ARRAY_FUNCTION,
204
`START_ARRAY_FUNCTION
205
$2
206
START_ARRAY_BLOCK($1)
207
$3
208
FINISH_ARRAY_FUNCTION')dnl

powered by: WebSVN 2.1.0

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