]>
Commit | Line | Data |
---|---|---|
6de9cd9a DN |
1 | /* Generic implementation of the RESHAPE intrinsic |
2 | Copyright 2002 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 (libgfor). | |
6 | ||
7 | Libgfor is free software; you can redistribute it and/or | |
8 | modify it under the terms of the GNU Lesser General Public | |
9 | License as published by the Free Software Foundation; either | |
10 | version 2.1 of the License, or (at your option) any later version. | |
11 | ||
12 | Ligbfor 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 Lesser General Public License for more details. | |
16 | ||
17 | You should have received a copy of the GNU Lesser General Public | |
18 | License along with libgfor; see the file COPYING.LIB. If not, | |
19 | write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
20 | Boston, MA 02111-1307, USA. */ | |
21 | ||
22 | #include "config.h" | |
23 | #include <stdlib.h> | |
24 | #include <assert.h> | |
25 | #include <string.h> | |
26 | #include "libgfortran.h" | |
27 | ||
7f68c75f RH |
28 | extern void unpack1 (const gfc_array_char *, const gfc_array_char *, |
29 | const gfc_array_l4 *, const gfc_array_char *); | |
30 | iexport_proto(unpack1); | |
7d7b8bfe | 31 | |
6de9cd9a | 32 | void |
7f68c75f RH |
33 | unpack1 (const gfc_array_char *ret, const gfc_array_char *vector, |
34 | const gfc_array_l4 *mask, const gfc_array_char *field) | |
6de9cd9a DN |
35 | { |
36 | /* r.* indicates the return array. */ | |
37 | index_type rstride[GFC_MAX_DIMENSIONS]; | |
38 | index_type rstride0; | |
39 | char *rptr; | |
40 | /* v.* indicates the vector array. */ | |
41 | index_type vstride0; | |
42 | char *vptr; | |
43 | /* f.* indicates the field array. */ | |
44 | index_type fstride[GFC_MAX_DIMENSIONS]; | |
45 | index_type fstride0; | |
46 | const char *fptr; | |
47 | /* m.* indicates the mask array. */ | |
48 | index_type mstride[GFC_MAX_DIMENSIONS]; | |
49 | index_type mstride0; | |
50 | const GFC_LOGICAL_4 *mptr; | |
51 | ||
52 | index_type count[GFC_MAX_DIMENSIONS]; | |
53 | index_type extent[GFC_MAX_DIMENSIONS]; | |
54 | index_type n; | |
55 | index_type dim; | |
56 | index_type size; | |
57 | index_type fsize; | |
58 | ||
59 | size = GFC_DESCRIPTOR_SIZE (ret); | |
60 | /* A field element size of 0 actually means this is a scalar. */ | |
61 | fsize = GFC_DESCRIPTOR_SIZE (field); | |
62 | dim = GFC_DESCRIPTOR_RANK (ret); | |
63 | for (n = 0; n < dim; n++) | |
64 | { | |
65 | count[n] = 0; | |
66 | extent[n] = ret->dim[n].ubound + 1 - ret->dim[n].lbound; | |
67 | rstride[n] = ret->dim[n].stride * size; | |
68 | fstride[n] = field->dim[n].stride * fsize; | |
69 | mstride[n] = mask->dim[n].stride; | |
70 | } | |
71 | if (rstride[0] == 0) | |
72 | rstride[0] = size; | |
73 | if (fstride[0] == 0) | |
74 | fstride[0] = fsize; | |
75 | if (mstride[0] == 0) | |
76 | mstride[0] = 1; | |
77 | ||
78 | vstride0 = vector->dim[0].stride * size; | |
79 | if (vstride0 == 0) | |
80 | vstride0 = size; | |
81 | rstride0 = rstride[0]; | |
82 | fstride0 = fstride[0]; | |
83 | mstride0 = mstride[0]; | |
84 | rptr = ret->data; | |
85 | fptr = field->data; | |
86 | mptr = mask->data; | |
87 | vptr = vector->data; | |
88 | ||
6de9cd9a DN |
89 | /* Use the same loop for both logical types. */ |
90 | if (GFC_DESCRIPTOR_SIZE (mask) != 4) | |
91 | { | |
92 | if (GFC_DESCRIPTOR_SIZE (mask) != 8) | |
93 | runtime_error ("Funny sized logical array"); | |
94 | for (n = 0; n < dim; n++) | |
95 | mstride[n] <<= 1; | |
96 | mstride0 <<= 1; | |
97 | mptr = GFOR_POINTER_L8_TO_L4 (mptr); | |
98 | } | |
99 | ||
100 | while (rptr) | |
101 | { | |
102 | if (*mptr) | |
103 | { | |
104 | /* From vector. */ | |
105 | memcpy (rptr, vptr, size); | |
106 | vptr += vstride0; | |
107 | } | |
108 | else | |
109 | { | |
110 | /* From field. */ | |
111 | memcpy (rptr, fptr, size); | |
112 | } | |
113 | /* Advance to the next element. */ | |
114 | rptr += rstride0; | |
115 | fptr += fstride0; | |
116 | mptr += mstride0; | |
117 | count[0]++; | |
118 | n = 0; | |
119 | while (count[n] == extent[n]) | |
120 | { | |
121 | /* When we get to the end of a dimension, reset it and increment | |
122 | the next dimension. */ | |
123 | count[n] = 0; | |
124 | /* We could precalculate these products, but this is a less | |
125 | frequently used path so proabably not worth it. */ | |
126 | rptr -= rstride[n] * extent[n]; | |
127 | fptr -= fstride[n] * extent[n]; | |
128 | mptr -= mstride[n] * extent[n]; | |
129 | n++; | |
130 | if (n >= dim) | |
131 | { | |
132 | /* Break out of the loop. */ | |
133 | rptr = NULL; | |
134 | break; | |
135 | } | |
136 | else | |
137 | { | |
138 | count[n]++; | |
139 | rptr += rstride[n]; | |
140 | fptr += fstride[n]; | |
141 | mptr += mstride[n]; | |
142 | } | |
143 | } | |
144 | } | |
145 | } | |
7f68c75f | 146 | iexport(unpack1); |
6de9cd9a | 147 | |
7f68c75f RH |
148 | extern void unpack0 (const gfc_array_char *, const gfc_array_char *, |
149 | const gfc_array_l4 *, char *); | |
150 | export_proto(unpack0); | |
7d7b8bfe | 151 | |
6de9cd9a | 152 | void |
7f68c75f RH |
153 | unpack0 (const gfc_array_char *ret, const gfc_array_char *vector, |
154 | const gfc_array_l4 *mask, char *field) | |
6de9cd9a DN |
155 | { |
156 | gfc_array_char tmp; | |
157 | ||
158 | tmp.dtype = 0; | |
159 | tmp.data = field; | |
7f68c75f | 160 | unpack1 (ret, vector, mask, &tmp); |
6de9cd9a | 161 | } |