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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 733 jeremybenn
`/* Specific implementation of the PACK intrinsic
2
   Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
3
   Contributed by Paul Brook <paul@nowt.org>
4
 
5
This file is part of the GNU Fortran 95 runtime library (libgfortran).
6
 
7
Libgfortran is free software; you can redistribute it and/or
8
modify it under the terms of the GNU General Public
9
License as published by the Free Software Foundation; either
10
version 3 of the License, or (at your option) any later version.
11
 
12
Ligbfortran is distributed in the hope that it will be useful,
13
but WITHOUT ANY WARRANTY; without even the implied warranty of
14
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15
GNU General Public License for more details.
16
 
17
Under Section 7 of GPL version 3, you are granted additional
18
permissions described in the GCC Runtime Library Exception, version
19
3.1, as published by the Free Software Foundation.
20
 
21
You should have received a copy of the GNU General Public License and
22
a copy of the GCC Runtime Library Exception along with this program;
23
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
24
<http://www.gnu.org/licenses/>.  */
25
 
26
#include "libgfortran.h"
27
#include <stdlib.h>
28
#include <assert.h>
29
#include <string.h>'
30
 
31
include(iparm.m4)dnl
32
 
33
`#if defined (HAVE_'rtype_name`)
34
 
35
/* PACK is specified as follows:
36
 
37
   13.14.80 PACK (ARRAY, MASK, [VECTOR])
38
 
39
   Description: Pack an array into an array of rank one under the
40
   control of a mask.
41
 
42
   Class: Transformational function.
43
 
44
   Arguments:
45
      ARRAY   may be of any type. It shall not be scalar.
46
      MASK    shall be of type LOGICAL. It shall be conformable with ARRAY.
47
      VECTOR  (optional) shall be of the same type and type parameters
48
              as ARRAY. VECTOR shall have at least as many elements as
49
              there are true elements in MASK. If MASK is a scalar
50
              with the value true, VECTOR shall have at least as many
51
              elements as there are in ARRAY.
52
 
53
   Result Characteristics: The result is an array of rank one with the
54
   same type and type parameters as ARRAY. If VECTOR is present, the
55
   result size is that of VECTOR; otherwise, the result size is the
56
   number /t/ of true elements in MASK unless MASK is scalar with the
57
   value true, in which case the result size is the size of ARRAY.
58
 
59
   Result Value: Element /i/ of the result is the element of ARRAY
60
   that corresponds to the /i/th true element of MASK, taking elements
61
   in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is
62
   present and has size /n/ > /t/, element /i/ of the result has the
63
   value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/.
64
 
65
   Examples: The nonzero elements of an array M with the value
66
   | 0 0 0 |
67
   | 9 0 0 | may be "gathered" by the function PACK. The result of
68
   | 0 0 7 |
69
   PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0,
70
   VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12].
71
 
72
There are two variants of the PACK intrinsic: one, where MASK is
73
array valued, and the other one where MASK is scalar.  */
74
 
75
void
76
pack_'rtype_code` ('rtype` *ret, const 'rtype` *array,
77
               const gfc_array_l1 *mask, const 'rtype` *vector)
78
{
79
  /* r.* indicates the return array.  */
80
  index_type rstride0;
81
  'rtype_name` * restrict rptr;
82
  /* s.* indicates the source array.  */
83
  index_type sstride[GFC_MAX_DIMENSIONS];
84
  index_type sstride0;
85
  const 'rtype_name` *sptr;
86
  /* m.* indicates the mask array.  */
87
  index_type mstride[GFC_MAX_DIMENSIONS];
88
  index_type mstride0;
89
  const GFC_LOGICAL_1 *mptr;
90
 
91
  index_type count[GFC_MAX_DIMENSIONS];
92
  index_type extent[GFC_MAX_DIMENSIONS];
93
  int zero_sized;
94
  index_type n;
95
  index_type dim;
96
  index_type nelem;
97
  index_type total;
98
  int mask_kind;
99
 
100
  dim = GFC_DESCRIPTOR_RANK (array);
101
 
102
  mptr = mask->data;
103
 
104
  /* Use the same loop for all logical types, by using GFC_LOGICAL_1
105
     and using shifting to address size and endian issues.  */
106
 
107
  mask_kind = GFC_DESCRIPTOR_SIZE (mask);
108
 
109
  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
110
#ifdef HAVE_GFC_LOGICAL_16
111
      || mask_kind == 16
112
#endif
113
      )
114
    {
115
      /*  Do not convert a NULL pointer as we use test for NULL below.  */
116
      if (mptr)
117
        mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
118
    }
119
  else
120
    runtime_error ("Funny sized logical array");
121
 
122
  zero_sized = 0;
123
  for (n = 0; n < dim; n++)
124
    {
125
      count[n] = 0;
126
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
127
      if (extent[n] <= 0)
128
       zero_sized = 1;
129
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
130
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
131
    }
132
  if (sstride[0] == 0)
133
    sstride[0] = 1;
134
  if (mstride[0] == 0)
135
    mstride[0] = mask_kind;
136
 
137
  if (zero_sized)
138
    sptr = NULL;
139
  else
140
    sptr = array->data;
141
 
142
  if (ret->data == NULL || unlikely (compile_options.bounds_check))
143
    {
144
      /* Count the elements, either for allocating memory or
145
         for bounds checking.  */
146
 
147
      if (vector != NULL)
148
        {
149
          /* The return array will have as many
150
             elements as there are in VECTOR.  */
151
          total = GFC_DESCRIPTOR_EXTENT(vector,0);
152
          if (total < 0)
153
            {
154
              total = 0;
155
              vector = NULL;
156
            }
157
        }
158
      else
159
        {
160
          /* We have to count the true elements in MASK.  */
161
          total = count_0 (mask);
162
        }
163
 
164
      if (ret->data == NULL)
165
        {
166
          /* Setup the array descriptor.  */
167
          GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1);
168
 
169
          ret->offset = 0;
170
 
171
          /* internal_malloc_size allocates a single byte for zero size.  */
172
          ret->data = internal_malloc_size (sizeof ('rtype_name`) * total);
173
 
174
          if (total == 0)
175
            return;
176
        }
177
      else
178
        {
179
          /* We come here because of range checking.  */
180
          index_type ret_extent;
181
 
182
          ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0);
183
          if (total != ret_extent)
184
            runtime_error ("Incorrect extent in return value of PACK intrinsic;"
185
                           " is %ld, should be %ld", (long int) total,
186
                           (long int) ret_extent);
187
        }
188
    }
189
 
190
  rstride0 = GFC_DESCRIPTOR_STRIDE(ret,0);
191
  if (rstride0 == 0)
192
    rstride0 = 1;
193
  sstride0 = sstride[0];
194
  mstride0 = mstride[0];
195
  rptr = ret->data;
196
 
197
  while (sptr && mptr)
198
    {
199
      /* Test this element.  */
200
      if (*mptr)
201
        {
202
          /* Add it.  */
203
          *rptr = *sptr;
204
          rptr += rstride0;
205
        }
206
      /* Advance to the next element.  */
207
      sptr += sstride0;
208
      mptr += mstride0;
209
      count[0]++;
210
      n = 0;
211
      while (count[n] == extent[n])
212
        {
213
          /* When we get to the end of a dimension, reset it and increment
214
             the next dimension.  */
215
          count[n] = 0;
216
          /* We could precalculate these products, but this is a less
217
             frequently used path so probably not worth it.  */
218
          sptr -= sstride[n] * extent[n];
219
          mptr -= mstride[n] * extent[n];
220
          n++;
221
          if (n >= dim)
222
            {
223
              /* Break out of the loop.  */
224
              sptr = NULL;
225
              break;
226
            }
227
          else
228
            {
229
              count[n]++;
230
              sptr += sstride[n];
231
              mptr += mstride[n];
232
            }
233
        }
234
    }
235
 
236
  /* Add any remaining elements from VECTOR.  */
237
  if (vector)
238
    {
239
      n = GFC_DESCRIPTOR_EXTENT(vector,0);
240
      nelem = ((rptr - ret->data) / rstride0);
241
      if (n > nelem)
242
        {
243
          sstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
244
          if (sstride0 == 0)
245
            sstride0 = 1;
246
 
247
          sptr = vector->data + sstride0 * nelem;
248
          n -= nelem;
249
          while (n--)
250
            {
251
              *rptr = *sptr;
252
              rptr += rstride0;
253
              sptr += sstride0;
254
            }
255
        }
256
    }
257
}
258
 
259
#endif
260
'

powered by: WebSVN 2.1.0

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