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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [libgfortran/] [generated/] [pack_r16.c] - 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
 
32
#if defined (HAVE_GFC_REAL_16)
33
 
34
/* PACK is specified as follows:
35
 
36
   13.14.80 PACK (ARRAY, MASK, [VECTOR])
37
 
38
   Description: Pack an array into an array of rank one under the
39
   control of a mask.
40
 
41
   Class: Transformational function.
42
 
43
   Arguments:
44
      ARRAY   may be of any type. It shall not be scalar.
45
      MASK    shall be of type LOGICAL. It shall be conformable with ARRAY.
46
      VECTOR  (optional) shall be of the same type and type parameters
47
              as ARRAY. VECTOR shall have at least as many elements as
48
              there are true elements in MASK. If MASK is a scalar
49
              with the value true, VECTOR shall have at least as many
50
              elements as there are in ARRAY.
51
 
52
   Result Characteristics: The result is an array of rank one with the
53
   same type and type parameters as ARRAY. If VECTOR is present, the
54
   result size is that of VECTOR; otherwise, the result size is the
55
   number /t/ of true elements in MASK unless MASK is scalar with the
56
   value true, in which case the result size is the size of ARRAY.
57
 
58
   Result Value: Element /i/ of the result is the element of ARRAY
59
   that corresponds to the /i/th true element of MASK, taking elements
60
   in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is
61
   present and has size /n/ > /t/, element /i/ of the result has the
62
   value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/.
63
 
64
   Examples: The nonzero elements of an array M with the value
65
   | 0 0 0 |
66
   | 9 0 0 | may be "gathered" by the function PACK. The result of
67
   | 0 0 7 |
68
   PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0,
69
   VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12].
70
 
71
There are two variants of the PACK intrinsic: one, where MASK is
72
array valued, and the other one where MASK is scalar.  */
73
 
74
void
75
pack_r16 (gfc_array_r16 *ret, const gfc_array_r16 *array,
76
               const gfc_array_l1 *mask, const gfc_array_r16 *vector)
77
{
78
  /* r.* indicates the return array.  */
79
  index_type rstride0;
80
  GFC_REAL_16 * restrict rptr;
81
  /* s.* indicates the source array.  */
82
  index_type sstride[GFC_MAX_DIMENSIONS];
83
  index_type sstride0;
84
  const GFC_REAL_16 *sptr;
85
  /* m.* indicates the mask array.  */
86
  index_type mstride[GFC_MAX_DIMENSIONS];
87
  index_type mstride0;
88
  const GFC_LOGICAL_1 *mptr;
89
 
90
  index_type count[GFC_MAX_DIMENSIONS];
91
  index_type extent[GFC_MAX_DIMENSIONS];
92
  int zero_sized;
93
  index_type n;
94
  index_type dim;
95
  index_type nelem;
96
  index_type total;
97
  int mask_kind;
98
 
99
  dim = GFC_DESCRIPTOR_RANK (array);
100
 
101
  mptr = mask->data;
102
 
103
  /* Use the same loop for all logical types, by using GFC_LOGICAL_1
104
     and using shifting to address size and endian issues.  */
105
 
106
  mask_kind = GFC_DESCRIPTOR_SIZE (mask);
107
 
108
  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
109
#ifdef HAVE_GFC_LOGICAL_16
110
      || mask_kind == 16
111
#endif
112
      )
113
    {
114
      /*  Do not convert a NULL pointer as we use test for NULL below.  */
115
      if (mptr)
116
        mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
117
    }
118
  else
119
    runtime_error ("Funny sized logical array");
120
 
121
  zero_sized = 0;
122
  for (n = 0; n < dim; n++)
123
    {
124
      count[n] = 0;
125
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
126
      if (extent[n] <= 0)
127
       zero_sized = 1;
128
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
129
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
130
    }
131
  if (sstride[0] == 0)
132
    sstride[0] = 1;
133
  if (mstride[0] == 0)
134
    mstride[0] = mask_kind;
135
 
136
  if (zero_sized)
137
    sptr = NULL;
138
  else
139
    sptr = array->data;
140
 
141
  if (ret->data == NULL || unlikely (compile_options.bounds_check))
142
    {
143
      /* Count the elements, either for allocating memory or
144
         for bounds checking.  */
145
 
146
      if (vector != NULL)
147
        {
148
          /* The return array will have as many
149
             elements as there are in VECTOR.  */
150
          total = GFC_DESCRIPTOR_EXTENT(vector,0);
151
          if (total < 0)
152
            {
153
              total = 0;
154
              vector = NULL;
155
            }
156
        }
157
      else
158
        {
159
          /* We have to count the true elements in MASK.  */
160
          total = count_0 (mask);
161
        }
162
 
163
      if (ret->data == NULL)
164
        {
165
          /* Setup the array descriptor.  */
166
          GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1);
167
 
168
          ret->offset = 0;
169
 
170
          /* internal_malloc_size allocates a single byte for zero size.  */
171
          ret->data = internal_malloc_size (sizeof (GFC_REAL_16) * total);
172
 
173
          if (total == 0)
174
            return;
175
        }
176
      else
177
        {
178
          /* We come here because of range checking.  */
179
          index_type ret_extent;
180
 
181
          ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0);
182
          if (total != ret_extent)
183
            runtime_error ("Incorrect extent in return value of PACK intrinsic;"
184
                           " is %ld, should be %ld", (long int) total,
185
                           (long int) ret_extent);
186
        }
187
    }
188
 
189
  rstride0 = GFC_DESCRIPTOR_STRIDE(ret,0);
190
  if (rstride0 == 0)
191
    rstride0 = 1;
192
  sstride0 = sstride[0];
193
  mstride0 = mstride[0];
194
  rptr = ret->data;
195
 
196
  while (sptr && mptr)
197
    {
198
      /* Test this element.  */
199
      if (*mptr)
200
        {
201
          /* Add it.  */
202
          *rptr = *sptr;
203
          rptr += rstride0;
204
        }
205
      /* Advance to the next element.  */
206
      sptr += sstride0;
207
      mptr += mstride0;
208
      count[0]++;
209
      n = 0;
210
      while (count[n] == extent[n])
211
        {
212
          /* When we get to the end of a dimension, reset it and increment
213
             the next dimension.  */
214
          count[n] = 0;
215
          /* We could precalculate these products, but this is a less
216
             frequently used path so probably not worth it.  */
217
          sptr -= sstride[n] * extent[n];
218
          mptr -= mstride[n] * extent[n];
219
          n++;
220
          if (n >= dim)
221
            {
222
              /* Break out of the loop.  */
223
              sptr = NULL;
224
              break;
225
            }
226
          else
227
            {
228
              count[n]++;
229
              sptr += sstride[n];
230
              mptr += mstride[n];
231
            }
232
        }
233
    }
234
 
235
  /* Add any remaining elements from VECTOR.  */
236
  if (vector)
237
    {
238
      n = GFC_DESCRIPTOR_EXTENT(vector,0);
239
      nelem = ((rptr - ret->data) / rstride0);
240
      if (n > nelem)
241
        {
242
          sstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
243
          if (sstride0 == 0)
244
            sstride0 = 1;
245
 
246
          sptr = vector->data + sstride0 * nelem;
247
          n -= nelem;
248
          while (n--)
249
            {
250
              *rptr = *sptr;
251
              rptr += rstride0;
252
              sptr += sstride0;
253
            }
254
        }
255
    }
256
}
257
 
258
#endif
259
 

powered by: WebSVN 2.1.0

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