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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 733 jeremybenn
`/* Implementation of the CSHIFT intrinsic
2
   Copyright 2003, 2007, 2009 Free Software Foundation, Inc.
3
   Contributed by Feng Wang <wf_cs@yahoo.com>
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_'atype_name`)
34
 
35
static void
36
cshift1 (gfc_array_char * const restrict ret,
37
        const gfc_array_char * const restrict array,
38
        const 'atype` * const restrict h,
39
        const 'atype_name` * const restrict pwhich)
40
{
41
  /* r.* indicates the return array.  */
42
  index_type rstride[GFC_MAX_DIMENSIONS];
43
  index_type rstride0;
44
  index_type roffset;
45
  char *rptr;
46
  char *dest;
47
  /* s.* indicates the source array.  */
48
  index_type sstride[GFC_MAX_DIMENSIONS];
49
  index_type sstride0;
50
  index_type soffset;
51
  const char *sptr;
52
  const char *src;
53
  /* h.* indicates the shift array.  */
54
  index_type hstride[GFC_MAX_DIMENSIONS];
55
  index_type hstride0;
56
  const 'atype_name` *hptr;
57
 
58
  index_type count[GFC_MAX_DIMENSIONS];
59
  index_type extent[GFC_MAX_DIMENSIONS];
60
  index_type dim;
61
  index_type len;
62
  index_type n;
63
  int which;
64
  'atype_name` sh;
65
  index_type arraysize;
66
  index_type size;
67
 
68
  if (pwhich)
69
    which = *pwhich - 1;
70
  else
71
    which = 0;
72
 
73
  if (which < 0 || (which + 1) > GFC_DESCRIPTOR_RANK (array))
74
    runtime_error ("Argument ''`DIM''` is out of range in call to ''`CSHIFT''`");
75
 
76
  size = GFC_DESCRIPTOR_SIZE(array);
77
 
78
  arraysize = size0 ((array_t *)array);
79
 
80
  if (ret->data == NULL)
81
    {
82
      int i;
83
 
84
      ret->data = internal_malloc_size (size * arraysize);
85
      ret->offset = 0;
86
      ret->dtype = array->dtype;
87
      for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
88
        {
89
          index_type ub, str;
90
 
91
          ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
92
 
93
          if (i == 0)
94
            str = 1;
95
          else
96
            str = GFC_DESCRIPTOR_EXTENT(ret,i-1) *
97
              GFC_DESCRIPTOR_STRIDE(ret,i-1);
98
 
99
          GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
100
        }
101
    }
102
  else if (unlikely (compile_options.bounds_check))
103
    {
104
      bounds_equal_extents ((array_t *) ret, (array_t *) array,
105
                                 "return value", "CSHIFT");
106
    }
107
 
108
  if (unlikely (compile_options.bounds_check))
109
    {
110
      bounds_reduced_extents ((array_t *) h, (array_t *) array, which,
111
                              "SHIFT argument", "CSHIFT");
112
    }
113
 
114
  if (arraysize == 0)
115
    return;
116
 
117
  extent[0] = 1;
118
  count[0] = 0;
119
  n = 0;
120
 
121
  /* Initialized for avoiding compiler warnings.  */
122
  roffset = size;
123
  soffset = size;
124
  len = 0;
125
 
126
  for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
127
    {
128
      if (dim == which)
129
        {
130
          roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
131
          if (roffset == 0)
132
            roffset = size;
133
          soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
134
          if (soffset == 0)
135
            soffset = size;
136
          len = GFC_DESCRIPTOR_EXTENT(array,dim);
137
        }
138
      else
139
        {
140
          count[n] = 0;
141
          extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
142
          rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
143
          sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
144
 
145
          hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n);
146
          n++;
147
        }
148
    }
149
  if (sstride[0] == 0)
150
    sstride[0] = size;
151
  if (rstride[0] == 0)
152
    rstride[0] = size;
153
  if (hstride[0] == 0)
154
    hstride[0] = 1;
155
 
156
  dim = GFC_DESCRIPTOR_RANK (array);
157
  rstride0 = rstride[0];
158
  sstride0 = sstride[0];
159
  hstride0 = hstride[0];
160
  rptr = ret->data;
161
  sptr = array->data;
162
  hptr = h->data;
163
 
164
  while (rptr)
165
    {
166
      /* Do the shift for this dimension.  */
167
      sh = *hptr;
168
      sh = (div (sh, len)).rem;
169
      if (sh < 0)
170
        sh += len;
171
 
172
      src = &sptr[sh * soffset];
173
      dest = rptr;
174
 
175
      for (n = 0; n < len; n++)
176
        {
177
          memcpy (dest, src, size);
178
          dest += roffset;
179
          if (n == len - sh - 1)
180
            src = sptr;
181
          else
182
            src += soffset;
183
        }
184
 
185
      /* Advance to the next section.  */
186
      rptr += rstride0;
187
      sptr += sstride0;
188
      hptr += hstride0;
189
      count[0]++;
190
      n = 0;
191
      while (count[n] == extent[n])
192
        {
193
          /* When we get to the end of a dimension, reset it and increment
194
             the next dimension.  */
195
          count[n] = 0;
196
          /* We could precalculate these products, but this is a less
197
             frequently used path so probably not worth it.  */
198
          rptr -= rstride[n] * extent[n];
199
          sptr -= sstride[n] * extent[n];
200
          hptr -= hstride[n] * extent[n];
201
          n++;
202
          if (n >= dim - 1)
203
            {
204
              /* Break out of the loop.  */
205
              rptr = NULL;
206
              break;
207
            }
208
          else
209
            {
210
              count[n]++;
211
              rptr += rstride[n];
212
              sptr += sstride[n];
213
              hptr += hstride[n];
214
            }
215
        }
216
    }
217
}
218
 
219
void cshift1_'atype_kind` (gfc_array_char * const restrict,
220
        const gfc_array_char * const restrict,
221
        const 'atype` * const restrict,
222
        const 'atype_name` * const restrict);
223
export_proto(cshift1_'atype_kind`);
224
 
225
void
226
cshift1_'atype_kind` (gfc_array_char * const restrict ret,
227
        const gfc_array_char * const restrict array,
228
        const 'atype` * const restrict h,
229
        const 'atype_name` * const restrict pwhich)
230
{
231
  cshift1 (ret, array, h, pwhich);
232
}
233
 
234
 
235
void cshift1_'atype_kind`_char (gfc_array_char * const restrict ret,
236
        GFC_INTEGER_4,
237
        const gfc_array_char * const restrict array,
238
        const 'atype` * const restrict h,
239
        const 'atype_name` * const restrict pwhich,
240
        GFC_INTEGER_4);
241
export_proto(cshift1_'atype_kind`_char);
242
 
243
void
244
cshift1_'atype_kind`_char (gfc_array_char * const restrict ret,
245
        GFC_INTEGER_4 ret_length __attribute__((unused)),
246
        const gfc_array_char * const restrict array,
247
        const 'atype` * const restrict h,
248
        const 'atype_name` * const restrict pwhich,
249
        GFC_INTEGER_4 array_length __attribute__((unused)))
250
{
251
  cshift1 (ret, array, h, pwhich);
252
}
253
 
254
 
255
void cshift1_'atype_kind`_char4 (gfc_array_char * const restrict ret,
256
        GFC_INTEGER_4,
257
        const gfc_array_char * const restrict array,
258
        const 'atype` * const restrict h,
259
        const 'atype_name` * const restrict pwhich,
260
        GFC_INTEGER_4);
261
export_proto(cshift1_'atype_kind`_char4);
262
 
263
void
264
cshift1_'atype_kind`_char4 (gfc_array_char * const restrict ret,
265
        GFC_INTEGER_4 ret_length __attribute__((unused)),
266
        const gfc_array_char * const restrict array,
267
        const 'atype` * const restrict h,
268
        const 'atype_name` * const restrict pwhich,
269
        GFC_INTEGER_4 array_length __attribute__((unused)))
270
{
271
  cshift1 (ret, array, h, pwhich);
272
}
273
 
274
#endif'

powered by: WebSVN 2.1.0

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