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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 733 jeremybenn
`/* Specific implementation of the UNPACK intrinsic
2
   Copyright 2008, 2009 Free Software Foundation, Inc.
3
   Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on
4
   unpack_generic.c by Paul Brook <paul@nowt.org>.
5
 
6
This file is part of the GNU Fortran 95 runtime library (libgfortran).
7
 
8
Libgfortran is free software; you can redistribute it and/or
9
modify it under the terms of the GNU General Public
10
License as published by the Free Software Foundation; either
11
version 3 of the License, or (at your option) any later version.
12
 
13
Ligbfortran is distributed in the hope that it will be useful,
14
but WITHOUT ANY WARRANTY; without even the implied warranty of
15
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16
GNU General Public License for more details.
17
 
18
Under Section 7 of GPL version 3, you are granted additional
19
permissions described in the GCC Runtime Library Exception, version
20
3.1, as published by the Free Software Foundation.
21
 
22
You should have received a copy of the GNU General Public License and
23
a copy of the GCC Runtime Library Exception along with this program;
24
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
25
<http://www.gnu.org/licenses/>.  */
26
 
27
#include "libgfortran.h"
28
#include <stdlib.h>
29
#include <assert.h>
30
#include <string.h>'
31
 
32
include(iparm.m4)dnl
33
 
34
`#if defined (HAVE_'rtype_name`)
35
 
36
void
37
unpack0_'rtype_code` ('rtype` *ret, const 'rtype` *vector,
38
                 const gfc_array_l1 *mask, const 'rtype_name` *fptr)
39
{
40
  /* r.* indicates the return array.  */
41
  index_type rstride[GFC_MAX_DIMENSIONS];
42
  index_type rstride0;
43
  index_type rs;
44
  'rtype_name` * restrict rptr;
45
  /* v.* indicates the vector array.  */
46
  index_type vstride0;
47
  'rtype_name` *vptr;
48
  /* Value for field, this is constant.  */
49
  const 'rtype_name` fval = *fptr;
50
  /* m.* indicates the mask array.  */
51
  index_type mstride[GFC_MAX_DIMENSIONS];
52
  index_type mstride0;
53
  const GFC_LOGICAL_1 *mptr;
54
 
55
  index_type count[GFC_MAX_DIMENSIONS];
56
  index_type extent[GFC_MAX_DIMENSIONS];
57
  index_type n;
58
  index_type dim;
59
 
60
  int empty;
61
  int mask_kind;
62
 
63
  empty = 0;
64
 
65
  mptr = mask->data;
66
 
67
  /* Use the same loop for all logical types, by using GFC_LOGICAL_1
68
     and using shifting to address size and endian issues.  */
69
 
70
  mask_kind = GFC_DESCRIPTOR_SIZE (mask);
71
 
72
  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
73
#ifdef HAVE_GFC_LOGICAL_16
74
      || mask_kind == 16
75
#endif
76
      )
77
    {
78
      /*  Do not convert a NULL pointer as we use test for NULL below.  */
79
      if (mptr)
80
        mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
81
    }
82
  else
83
    runtime_error ("Funny sized logical array");
84
 
85
  if (ret->data == NULL)
86
    {
87
      /* The front end has signalled that we need to populate the
88
         return array descriptor.  */
89
      dim = GFC_DESCRIPTOR_RANK (mask);
90
      rs = 1;
91
      for (n = 0; n < dim; n++)
92
        {
93
          count[n] = 0;
94
          GFC_DIMENSION_SET(ret->dim[n], 0,
95
                            GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);
96
          extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
97
          empty = empty || extent[n] <= 0;
98
          rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
99
          mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
100
          rs *= extent[n];
101
        }
102
      ret->offset = 0;
103
      ret->data = internal_malloc_size (rs * sizeof ('rtype_name`));
104
    }
105
  else
106
    {
107
      dim = GFC_DESCRIPTOR_RANK (ret);
108
      for (n = 0; n < dim; n++)
109
        {
110
          count[n] = 0;
111
          extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
112
          empty = empty || extent[n] <= 0;
113
          rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
114
          mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
115
        }
116
      if (rstride[0] == 0)
117
        rstride[0] = 1;
118
    }
119
 
120
  if (empty)
121
    return;
122
 
123
  if (mstride[0] == 0)
124
    mstride[0] = 1;
125
 
126
  vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
127
  if (vstride0 == 0)
128
    vstride0 = 1;
129
  rstride0 = rstride[0];
130
  mstride0 = mstride[0];
131
  rptr = ret->data;
132
  vptr = vector->data;
133
 
134
  while (rptr)
135
    {
136
      if (*mptr)
137
        {
138
          /* From vector.  */
139
          *rptr = *vptr;
140
          vptr += vstride0;
141
        }
142
      else
143
        {
144
          /* From field.  */
145
          *rptr = fval;
146
        }
147
      /* Advance to the next element.  */
148
      rptr += rstride0;
149
      mptr += mstride0;
150
      count[0]++;
151
      n = 0;
152
      while (count[n] == extent[n])
153
        {
154
          /* When we get to the end of a dimension, reset it and increment
155
             the next dimension.  */
156
          count[n] = 0;
157
          /* We could precalculate these products, but this is a less
158
             frequently used path so probably not worth it.  */
159
          rptr -= rstride[n] * extent[n];
160
          mptr -= mstride[n] * extent[n];
161
          n++;
162
          if (n >= dim)
163
            {
164
              /* Break out of the loop.  */
165
              rptr = NULL;
166
              break;
167
            }
168
          else
169
            {
170
              count[n]++;
171
              rptr += rstride[n];
172
              mptr += mstride[n];
173
            }
174
        }
175
    }
176
}
177
 
178
void
179
unpack1_'rtype_code` ('rtype` *ret, const 'rtype` *vector,
180
                 const gfc_array_l1 *mask, const 'rtype` *field)
181
{
182
  /* r.* indicates the return array.  */
183
  index_type rstride[GFC_MAX_DIMENSIONS];
184
  index_type rstride0;
185
  index_type rs;
186
  'rtype_name` * restrict rptr;
187
  /* v.* indicates the vector array.  */
188
  index_type vstride0;
189
  'rtype_name` *vptr;
190
  /* f.* indicates the field array.  */
191
  index_type fstride[GFC_MAX_DIMENSIONS];
192
  index_type fstride0;
193
  const 'rtype_name` *fptr;
194
  /* m.* indicates the mask array.  */
195
  index_type mstride[GFC_MAX_DIMENSIONS];
196
  index_type mstride0;
197
  const GFC_LOGICAL_1 *mptr;
198
 
199
  index_type count[GFC_MAX_DIMENSIONS];
200
  index_type extent[GFC_MAX_DIMENSIONS];
201
  index_type n;
202
  index_type dim;
203
 
204
  int empty;
205
  int mask_kind;
206
 
207
  empty = 0;
208
 
209
  mptr = mask->data;
210
 
211
  /* Use the same loop for all logical types, by using GFC_LOGICAL_1
212
     and using shifting to address size and endian issues.  */
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
    {
222
      /*  Do not convert a NULL pointer as we use test for NULL below.  */
223
      if (mptr)
224
        mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
225
    }
226
  else
227
    runtime_error ("Funny sized logical array");
228
 
229
  if (ret->data == NULL)
230
    {
231
      /* The front end has signalled that we need to populate the
232
         return array descriptor.  */
233
      dim = GFC_DESCRIPTOR_RANK (mask);
234
      rs = 1;
235
      for (n = 0; n < dim; n++)
236
        {
237
          count[n] = 0;
238
          GFC_DIMENSION_SET(ret->dim[n], 0,
239
                            GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);
240
          extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
241
          empty = empty || extent[n] <= 0;
242
          rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
243
          fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n);
244
          mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
245
          rs *= extent[n];
246
        }
247
      ret->offset = 0;
248
      ret->data = internal_malloc_size (rs * sizeof ('rtype_name`));
249
    }
250
  else
251
    {
252
      dim = GFC_DESCRIPTOR_RANK (ret);
253
      for (n = 0; n < dim; n++)
254
        {
255
          count[n] = 0;
256
          extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
257
          empty = empty || extent[n] <= 0;
258
          rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
259
          fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n);
260
          mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
261
        }
262
      if (rstride[0] == 0)
263
        rstride[0] = 1;
264
    }
265
 
266
  if (empty)
267
    return;
268
 
269
  if (fstride[0] == 0)
270
    fstride[0] = 1;
271
  if (mstride[0] == 0)
272
    mstride[0] = 1;
273
 
274
  vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
275
  if (vstride0 == 0)
276
    vstride0 = 1;
277
  rstride0 = rstride[0];
278
  fstride0 = fstride[0];
279
  mstride0 = mstride[0];
280
  rptr = ret->data;
281
  fptr = field->data;
282
  vptr = vector->data;
283
 
284
  while (rptr)
285
    {
286
      if (*mptr)
287
        {
288
          /* From vector.  */
289
          *rptr = *vptr;
290
          vptr += vstride0;
291
        }
292
      else
293
        {
294
          /* From field.  */
295
          *rptr = *fptr;
296
        }
297
      /* Advance to the next element.  */
298
      rptr += rstride0;
299
      fptr += fstride0;
300
      mptr += mstride0;
301
      count[0]++;
302
      n = 0;
303
      while (count[n] == extent[n])
304
        {
305
          /* When we get to the end of a dimension, reset it and increment
306
             the next dimension.  */
307
          count[n] = 0;
308
          /* We could precalculate these products, but this is a less
309
             frequently used path so probably not worth it.  */
310
          rptr -= rstride[n] * extent[n];
311
          fptr -= fstride[n] * extent[n];
312
          mptr -= mstride[n] * extent[n];
313
          n++;
314
          if (n >= dim)
315
            {
316
              /* Break out of the loop.  */
317
              rptr = NULL;
318
              break;
319
            }
320
          else
321
            {
322
              count[n]++;
323
              rptr += rstride[n];
324
              fptr += fstride[n];
325
              mptr += mstride[n];
326
            }
327
        }
328
    }
329
}
330
 
331
#endif
332
'

powered by: WebSVN 2.1.0

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