OLD | NEW |
1 /* Special implementation of the SPREAD intrinsic | 1 /* Special implementation of the SPREAD intrinsic |
2 Copyright 2008, 2009 Free Software Foundation, Inc. | 2 Copyright 2008, 2009 Free Software Foundation, Inc. |
3 Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on | 3 Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on |
4 spread_generic.c written by Paul Brook <paul@nowt.org> | 4 spread_generic.c written by Paul Brook <paul@nowt.org> |
5 | 5 |
6 This file is part of the GNU Fortran 95 runtime library (libgfortran). | 6 This file is part of the GNU Fortran 95 runtime library (libgfortran). |
7 | 7 |
8 Libgfortran is free software; you can redistribute it and/or | 8 Libgfortran is free software; you can redistribute it and/or |
9 modify it under the terms of the GNU General Public | 9 modify it under the terms of the GNU General Public |
10 License as published by the Free Software Foundation; either | 10 License as published by the Free Software Foundation; either |
(...skipping 51 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
62 if (rrank > GFC_MAX_DIMENSIONS) | 62 if (rrank > GFC_MAX_DIMENSIONS) |
63 runtime_error ("return rank too large in spread()"); | 63 runtime_error ("return rank too large in spread()"); |
64 | 64 |
65 if (along > rrank) | 65 if (along > rrank) |
66 runtime_error ("dim outside of rank in spread()"); | 66 runtime_error ("dim outside of rank in spread()"); |
67 | 67 |
68 ncopies = pncopies; | 68 ncopies = pncopies; |
69 | 69 |
70 if (ret->data == NULL) | 70 if (ret->data == NULL) |
71 { | 71 { |
| 72 |
| 73 size_t ub, stride; |
| 74 |
72 /* The front end has signalled that we need to populate the | 75 /* The front end has signalled that we need to populate the |
73 return array descriptor. */ | 76 return array descriptor. */ |
74 ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank; | 77 ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank; |
75 dim = 0; | 78 dim = 0; |
76 rs = 1; | 79 rs = 1; |
77 for (n = 0; n < rrank; n++) | 80 for (n = 0; n < rrank; n++) |
78 { | 81 { |
79 » ret->dim[n].stride = rs; | 82 » stride = rs; |
80 » ret->dim[n].lbound = 0; | |
81 if (n == along - 1) | 83 if (n == along - 1) |
82 { | 84 { |
83 » ret->dim[n].ubound = ncopies - 1; | 85 » ub = ncopies - 1; |
84 rdelta = rs; | 86 rdelta = rs; |
85 rs *= ncopies; | 87 rs *= ncopies; |
86 } | 88 } |
87 else | 89 else |
88 { | 90 { |
89 count[dim] = 0; | 91 count[dim] = 0; |
90 » extent[dim] = source->dim[dim].ubound + 1 | 92 » extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); |
91 » » - source->dim[dim].lbound; | 93 » sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); |
92 » sstride[dim] = source->dim[dim].stride; | |
93 rstride[dim] = rs; | 94 rstride[dim] = rs; |
94 | 95 |
95 » ret->dim[n].ubound = extent[dim]-1; | 96 » ub = extent[dim] - 1; |
96 rs *= extent[dim]; | 97 rs *= extent[dim]; |
97 dim++; | 98 dim++; |
98 } | 99 } |
| 100 GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride); |
99 } | 101 } |
100 ret->offset = 0; | 102 ret->offset = 0; |
101 if (rs > 0) | 103 if (rs > 0) |
102 ret->data = internal_malloc_size (rs * sizeof(GFC_INTEGER_4)); | 104 ret->data = internal_malloc_size (rs * sizeof(GFC_INTEGER_4)); |
103 else | 105 else |
104 { | 106 { |
105 ret->data = internal_malloc_size (1); | 107 ret->data = internal_malloc_size (1); |
106 return; | 108 return; |
107 } | 109 } |
108 } | 110 } |
109 else | 111 else |
110 { | 112 { |
111 int zero_sized; | 113 int zero_sized; |
112 | 114 |
113 zero_sized = 0; | 115 zero_sized = 0; |
114 | 116 |
115 dim = 0; | 117 dim = 0; |
116 if (GFC_DESCRIPTOR_RANK(ret) != rrank) | 118 if (GFC_DESCRIPTOR_RANK(ret) != rrank) |
117 runtime_error ("rank mismatch in spread()"); | 119 runtime_error ("rank mismatch in spread()"); |
118 | 120 |
119 if (unlikely (compile_options.bounds_check)) | 121 if (unlikely (compile_options.bounds_check)) |
120 { | 122 { |
121 for (n = 0; n < rrank; n++) | 123 for (n = 0; n < rrank; n++) |
122 { | 124 { |
123 index_type ret_extent; | 125 index_type ret_extent; |
124 | 126 |
125 » ret_extent = ret->dim[n].ubound + 1 - ret->dim[n].lbound; | 127 » ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n); |
126 if (n == along - 1) | 128 if (n == along - 1) |
127 { | 129 { |
128 » » rdelta = ret->dim[n].stride; | 130 » » rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); |
129 | 131 |
130 if (ret_extent != ncopies) | 132 if (ret_extent != ncopies) |
131 runtime_error("Incorrect extent in return value of SPREAD" | 133 runtime_error("Incorrect extent in return value of SPREAD" |
132 " intrinsic in dimension %ld: is %ld," | 134 " intrinsic in dimension %ld: is %ld," |
133 " should be %ld", (long int) n+1, | 135 " should be %ld", (long int) n+1, |
134 (long int) ret_extent, (long int) ncopies); | 136 (long int) ret_extent, (long int) ncopies); |
135 } | 137 } |
136 else | 138 else |
137 { | 139 { |
138 count[dim] = 0; | 140 count[dim] = 0; |
139 » » extent[dim] = source->dim[dim].ubound + 1 | 141 » » extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); |
140 » » - source->dim[dim].lbound; | |
141 if (ret_extent != extent[dim]) | 142 if (ret_extent != extent[dim]) |
142 runtime_error("Incorrect extent in return value of SPREAD" | 143 runtime_error("Incorrect extent in return value of SPREAD" |
143 " intrinsic in dimension %ld: is %ld," | 144 " intrinsic in dimension %ld: is %ld," |
144 " should be %ld", (long int) n+1, | 145 " should be %ld", (long int) n+1, |
145 (long int) ret_extent, | 146 (long int) ret_extent, |
146 (long int) extent[dim]); | 147 (long int) extent[dim]); |
147 | 148 |
148 if (extent[dim] <= 0) | 149 if (extent[dim] <= 0) |
149 zero_sized = 1; | 150 zero_sized = 1; |
150 » » sstride[dim] = source->dim[dim].stride; | 151 » » sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); |
151 » » rstride[dim] = ret->dim[n].stride; | 152 » » rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); |
152 dim++; | 153 dim++; |
153 } | 154 } |
154 } | 155 } |
155 } | 156 } |
156 else | 157 else |
157 { | 158 { |
158 for (n = 0; n < rrank; n++) | 159 for (n = 0; n < rrank; n++) |
159 { | 160 { |
160 if (n == along - 1) | 161 if (n == along - 1) |
161 { | 162 { |
162 » » rdelta = ret->dim[n].stride; | 163 » » rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); |
163 } | 164 } |
164 else | 165 else |
165 { | 166 { |
166 count[dim] = 0; | 167 count[dim] = 0; |
167 » » extent[dim] = source->dim[dim].ubound + 1 | 168 » » extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); |
168 » » - source->dim[dim].lbound; | |
169 if (extent[dim] <= 0) | 169 if (extent[dim] <= 0) |
170 zero_sized = 1; | 170 zero_sized = 1; |
171 » » sstride[dim] = source->dim[dim].stride; | 171 » » sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); |
172 » » rstride[dim] = ret->dim[n].stride; | 172 » » rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); |
173 dim++; | 173 dim++; |
174 } | 174 } |
175 } | 175 } |
176 } | 176 } |
177 | 177 |
178 if (zero_sized) | 178 if (zero_sized) |
179 return; | 179 return; |
180 | 180 |
181 if (sstride[0] == 0) | 181 if (sstride[0] == 0) |
182 sstride[0] = 1; | 182 sstride[0] = 1; |
(...skipping 58 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
241 if (GFC_DESCRIPTOR_RANK (ret) != 1) | 241 if (GFC_DESCRIPTOR_RANK (ret) != 1) |
242 runtime_error ("incorrect destination rank in spread()"); | 242 runtime_error ("incorrect destination rank in spread()"); |
243 | 243 |
244 if (along > 1) | 244 if (along > 1) |
245 runtime_error ("dim outside of rank in spread()"); | 245 runtime_error ("dim outside of rank in spread()"); |
246 | 246 |
247 if (ret->data == NULL) | 247 if (ret->data == NULL) |
248 { | 248 { |
249 ret->data = internal_malloc_size (ncopies * sizeof (GFC_INTEGER_4)); | 249 ret->data = internal_malloc_size (ncopies * sizeof (GFC_INTEGER_4)); |
250 ret->offset = 0; | 250 ret->offset = 0; |
251 ret->dim[0].stride = 1; | 251 GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1); |
252 ret->dim[0].lbound = 0; | |
253 ret->dim[0].ubound = ncopies - 1; | |
254 } | 252 } |
255 else | 253 else |
256 { | 254 { |
257 if (ncopies - 1 > (ret->dim[0].ubound - ret->dim[0].lbound) | 255 if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1) |
258 » » » / ret->dim[0].stride) | 256 » » » / GFC_DESCRIPTOR_STRIDE(ret,0)) |
259 runtime_error ("dim too large in spread()"); | 257 runtime_error ("dim too large in spread()"); |
260 } | 258 } |
261 | 259 |
262 dest = ret->data; | 260 dest = ret->data; |
263 stride = ret->dim[0].stride; | 261 stride = GFC_DESCRIPTOR_STRIDE(ret,0); |
264 | 262 |
265 for (n = 0; n < ncopies; n++) | 263 for (n = 0; n < ncopies; n++) |
266 { | 264 { |
267 *dest = *source; | 265 *dest = *source; |
268 dest += stride; | 266 dest += stride; |
269 } | 267 } |
270 } | 268 } |
271 | 269 |
272 #endif | 270 #endif |
273 | 271 |
OLD | NEW |