| 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 |