Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

3/17

  • Loading branch information...
commit ce769c22b333ceb1c0612c30bb75ffc7404b83c0 1 parent f3646c8
andyv authored
Sorry, we could not display the entire diff because it was too big.
4,209 arith.c
2,105 additions, 2,104 deletions not shown
3,189 array.c
@@ -20,1877 +20,1878 @@ the Free Software Foundation, 59 Temple Place - Suite 330,
20 20 Boston, MA 02111-1307, USA. */
21 21
22 22 #include <string.h>
23   -
  23 +
24 24 #include "g95.h"
  25 +
  26 +
  27 +static match match_array_cons_element(g95_constructor **);
  28 +
  29 +typedef struct cons_stack {
  30 + g95_iterator *iterator;
  31 + struct cons_stack *previous;
  32 +} cons_stack;
  33 +
  34 +static cons_stack *stack_base;
25 35
26   -
27   -static match match_array_cons_element(g95_constructor **);
28   -
29   -typedef struct cons_stack {
30   - g95_iterator *iterator;
31   - struct cons_stack *previous;
32   -} cons_stack;
33   -
34   -static cons_stack *stack_base;
35   -
36   -static try check_constructor(g95_constructor *, try (*)(g95_expr *));
37   -
38   -typedef struct iterator_stack {
39   - g95_symbol *variable;
40   - mpz_t value;
  36 +static try check_constructor(g95_constructor *, try (*)(g95_expr *));
41 37
42   - struct iterator_stack *prev;
43   -} iterator_stack;
44   -
45   -static iterator_stack *iter_stack;
46   -
47   -typedef struct {
48   - int extract_count, extract_n;
49   - g95_expr *extracted;
50   - mpz_t *count;
51   - g95_constructor *head, *tail;
  38 +typedef struct iterator_stack {
  39 + g95_symbol *variable;
  40 + mpz_t value;
52 41
  42 + struct iterator_stack *prev;
  43 +} iterator_stack;
  44 +
  45 +static iterator_stack *iter_stack;
  46 +
  47 +typedef struct {
  48 + int extract_count, extract_n;
  49 + g95_expr *extracted;
  50 + mpz_t *count;
  51 + g95_constructor *head, *tail;
  52 +
53 53 try (*expand_work_function)(g95_expr *);
54 54 } expand_info;
55 55
56   -static expand_info current_expand;
  56 +static expand_info current_expand;
  57 +
  58 +static g95_typespec constructor_ts;
  59 +static enum { CONS_START, CONS_GOOD, CONS_BAD } cons_state;
  60 +int g95_constructor_string_length;
57 61
58   -static g95_typespec constructor_ts;
59   -static enum { CONS_START, CONS_GOOD, CONS_BAD } cons_state;
60   -int g95_constructor_string_length;
  62 +static try expand_constructor(g95_constructor *);
61 63
62   -static try expand_constructor(g95_constructor *);
63   -
64   -
  64 +
  65 +
  66 +/* array_function_size()-- Deduce the size of an array-value intrinsic
  67 + * for a couple common inquiry functions. */
  68 +
  69 +static try array_function_size(g95_expr *e, mpz_t *rslt) {
  70 +g95_intrinsic_sym *is;
65 71
66   -/* g95_append_constructor()-- Given an array constructor expression,
67   - * append the new expression node onto the constructor. */
68   -
69   -void g95_append_constructor(g95_expr *start, g95_expr *new) {
70   -g95_constructor *c;
71   -
72   - if (start->value.constructor == NULL)
73   - start->value.constructor = c = g95_get_constructor();
74   - else {
75   - c = start->value.constructor;
76   - while(c->next)
77   - c=c->next;
  72 + is = e->value.function.isym;
  73 + if (is == NULL) return FAILURE;
  74 +
  75 + /* TODO: follow elemental functions into their arguments */
  76 +
  77 + switch(is->generic_id) {
  78 + case G95_ISYM_MINLOC:
  79 + case G95_ISYM_MAXLOC:
  80 + case G95_ISYM_SHAPE:
  81 + case G95_ISYM_LBOUND:
  82 + case G95_ISYM_UBOUND:
  83 + /* Special cases where the size of the array is equal to the rank
  84 + * of the first argument. The second argument (DIM) must not be
  85 + * present. */
  86 +
  87 + if (e->value.function.actual->next != NULL) break;
  88 +
  89 + mpz_init_set_ui(*rslt, e->value.function.actual->u.expr->rank);
  90 + return SUCCESS;
  91 + }
78 92
79   - c->next = g95_get_constructor();
80   - c = c->next;
81   - }
82   -
83   - c->expr = new;
  93 + return FAILURE;
  94 +}
  95 +
84 96
85   - if (new->ts.type != start->ts.type || new->ts.kind != start->ts.kind)
86   - g95_internal_error("g95_append_constructor(): New node has wrong kind");
87   -}
88   -
89   -
90 97
91 98
92   -/* ref_dimen_size()-- Get the number of elements in an array section */
  99 +/* match_subscript()-- Match a single dimension of an array reference.
  100 + * This can be a single element or an array section. Any modifications
  101 + * we've made to the ar structure are cleaned up by the caller. */
  102 +
  103 +static match match_subscript(g95_array_ref *a, int initial) {
  104 +match d;
  105 +int u;
93 106
94   -static try ref_dimen_size(g95_array_ref *ar, g95_array_spec *as, int dimen,
95   - mpz_t *rslt) {
96   -mpz_t u, low, stride;
97   -try f;
98   -
99   - switch(ar->dimen_type[dimen]) {
100   - case DIMEN_ELEMENT:
101   - mpz_init(*rslt);
102   - mpz_set_ui(*rslt, 1);
103   - f = SUCCESS;
104   - break;
105   -
106   - case DIMEN_VECTOR:
107   - f = g95_array_size(ar->start[dimen], rslt); /* Recurse! */
108   - break;
  107 + u = a->dimen;
  108 +
  109 + a->c_where[u] = g95_current_locus;
  110 + a->start[u] = a->end[u] = a->stride[u] = NULL;
  111 +
  112 + /* We can't be sure of the difference between DIMEN_ELEMENT and
  113 + * DIMEN_VECTOR until we know the type of the element itself at
  114 + * resolution time. */
109 115
110   - case DIMEN_RANGE:
111   - mpz_init(u);
112   - mpz_init(low);
113   - mpz_init(stride);
114   - f = FAILURE;
115   -
116   - if (ar->start[dimen] == NULL) {
117   - if (as->lower[dimen] == NULL ||
118   - as->lower[dimen]->type != EXPR_CONSTANT) goto cleanup;
119   - mpz_set(low, as->lower[dimen]->value.integer);
120   - } else {
121   - if (ar->start[dimen]->type != EXPR_CONSTANT) goto cleanup;
122   - mpz_set(low, ar->start[dimen]->value.integer);
123   - }
124   -
125   - if (ar->end[dimen] == NULL) {
126   - if (as->upper[dimen] == NULL ||
127   - as->upper[dimen]->type != EXPR_CONSTANT) goto cleanup;
128   - mpz_set(u, as->upper[dimen]->value.integer);
129   - } else {
130   - if (ar->end[dimen]->type != EXPR_CONSTANT) goto cleanup;
131   - mpz_set(u, ar->end[dimen]->value.integer);
132   - }
133   -
134   - if (ar->stride[dimen] == NULL)
135   - mpz_set_ui(stride, 1);
136   - else {
137   - if (ar->stride[dimen]->type != EXPR_CONSTANT) goto cleanup;
138   - mpz_set(stride, ar->stride[dimen]->value.integer);
139   - }
  116 + a->dimen_type[u] = DIMEN_UNKNOWN;
  117 +
  118 + if (g95_match_char(':') == MATCH_YES) goto end_element;
  119 +
  120 + /* Get start element */
140 121
141   - mpz_init(*rslt);
142   - mpz_sub(*rslt, u, low);
143   - mpz_add(*rslt, *rslt, stride);
144   - mpz_div(*rslt, *rslt, stride);
  122 + if (initial)
  123 + d = g95_match_init_expr(&a->start[u]);
  124 + else
  125 + d = g95_match_expr(&a->start[u]);
  126 +
  127 + if (d == MATCH_NO) g95_error("Expected array subscript at %C");
  128 + if (d != MATCH_YES) return MATCH_ERROR;
  129 +
  130 + if (g95_match_char(':') == MATCH_NO) return MATCH_YES;
  131 +
  132 +/* Get an optional end element. Because we've seen the colon, we
  133 + * definitely have a range along this dimension. */
  134 +
  135 +end_element:
  136 + a->dimen_type[u] = DIMEN_RANGE;
145 137
146   - /* Zero stride caught earlier */
  138 + if (initial)
  139 + d = g95_match_init_expr(&a->end[u]);
  140 + else
  141 + d = g95_match_expr(&a->end[u]);
  142 +
  143 + if (d == MATCH_ERROR) return MATCH_ERROR;
147 144
148   - if (mpz_cmp_ui(*rslt, 0) < 0) mpz_set_ui(*rslt, 0);
149   - f = SUCCESS;
  145 +/* See if we have an optional stride */
  146 +
  147 + if (g95_match_char(':') == MATCH_YES) {
  148 + d = initial ? g95_match_init_expr(&a->stride[u])
  149 + : g95_match_expr(&a->stride[u]);
150 150
151   - cleanup:
152   - mpz_clear(u);
153   - mpz_clear(low);
154   - mpz_clear(stride);
155   - return f;
  151 + if (d == MATCH_NO) g95_error("Expected array subscript stride at %C");
  152 + if (d != MATCH_YES) return MATCH_ERROR;
  153 + }
  154 +
  155 + return MATCH_YES;
  156 +}
  157 +
  158 +
  159 +
  160 +
  161 +/* match_array_element_spec()-- Match a single array element
  162 + * specification. The return values as well as the upper and lower
  163 + * bounds of the array spec are filled in according to what we see on
  164 + * the input. The caller makes sure individual specifications make
  165 + * sense as a whole.
  166 + *
  167 + * Parsed Lower Upper Returned
  168 + * ------------------------------------
  169 + * : NULL NULL AS_DEFERRED
  170 + * x 1 x AS_EXPLICIT
  171 + * x: x NULL AS_ASSUMED_SHAPE
  172 + * x:y x y AS_EXPLICIT
  173 + * x:* x NULL AS_ASSUMED_SIZE
  174 + * * 1 NULL AS_ASSUMED_SIZE
  175 + * Anything else AS_UNKNOWN */
  176 +
  177 +static array_type match_array_element_spec(g95_array_spec *a) {
  178 +g95_expr **upper, **low;
  179 +match c;
  180 +
  181 + low = &a->lower[a->rank - 1];
  182 + upper = &a->upper[a->rank - 1];
  183 +
  184 + if (g95_match_char('*') == MATCH_YES) {
  185 + *low = g95_int_expr(1);
  186 + return AS_ASSUMED_SIZE;
  187 + }
156 188
157   - default:
158   - g95_internal_error("ref_dimen_size(): Bad dimen type");
159   - }
160   -
161   - return f;
162   -}
163   -
164   -
165   -
  189 + if (g95_match_char(':') == MATCH_YES) return AS_DEFERRED;
166 190
167   -/* spec_dimen_size()-- Get the size of single dimension of an array
168   - * specification. The array is guaranteed to be one dimensional */
169   -
170   -static try spec_dimen_size(g95_array_spec *as, int dimen, mpz_t *rslt) {
  191 + c = g95_match_expr(upper);
  192 + if (c == MATCH_NO)
  193 + g95_error("Expected expression in array specification at %C");
  194 + if (c != MATCH_YES) return AS_UNKNOWN;
  195 +
  196 + if (g95_match_char(':') == MATCH_NO) {
  197 + *low = g95_int_expr(1);
  198 + return AS_EXPLICIT;
  199 + }
  200 +
  201 + *low = *upper;
  202 + *upper = NULL;
  203 +
  204 + if (g95_match_char('*') == MATCH_YES) return AS_ASSUMED_SIZE;
  205 +
  206 + c = g95_match_expr(upper);
  207 + if (c == MATCH_ERROR) return AS_UNKNOWN;
  208 + if (c == MATCH_NO) return AS_ASSUMED_SHAPE;
171 209
172   - if (as == NULL || as->type != AS_EXPLICIT ||
173   - as->lower[dimen]->type != EXPR_CONSTANT ||
174   - as->upper[dimen]->type != EXPR_CONSTANT) {
  210 + return AS_EXPLICIT;
  211 +}
175 212
176   - return FAILURE;
177   - }
  213 +
  214 +
  215 +
  216 +/* g95_show_array_ref()-- Show an array reference */
  217 +
  218 +void g95_show_array_ref(g95_array_ref *ar) {
  219 +int i;
178 220
179   - mpz_init(*rslt);
  221 + g95_status_char('(');
  222 +
  223 + switch(ar->type) {
  224 + case AR_FULL:
  225 + g95_status("FULL");
  226 + break;
  227 +
  228 + case AR_SECTION:
  229 + for(i=0; i<ar->dimen; i++) {
  230 + if (ar->start[i] != NULL)
  231 + g95_show_expr(ar->start[i]);
  232 +
  233 + g95_status_char(':');
  234 +
  235 + if (ar->end[i] != NULL)
  236 + g95_show_expr(ar->end[i]);
  237 +
  238 + if (ar->stride[i] != NULL) {
  239 + g95_status_char(':');
  240 + g95_show_expr(ar->stride[i]);
  241 + }
180 242
181   - mpz_sub(*rslt, as->upper[dimen]->value.integer,
182   - as->lower[dimen]->value.integer);
  243 + if (i != ar->dimen-1) g95_status(" , ");
  244 + }
  245 + break;
  246 +
  247 + case AR_ELEMENT:
  248 + for(i=0; i<ar->dimen; i++) {
  249 + g95_show_expr(ar->start[i]);
  250 + if (i != ar->dimen - 1) g95_status(" , ");
  251 + }
  252 + break;
  253 +
  254 + case AR_UNKNOWN:
  255 + g95_status("UNKNOWN");
  256 + break;
  257 +
  258 + default:
  259 + g95_internal_error("g95_show_array_ref(): Unknown array reference");
  260 + }
  261 +
  262 + g95_status_char(')');
  263 +}
  264 +
  265 +
  266 +
  267 +
  268 +/* g95_free_array_ref()-- Free an array reference structure and
  269 + * everything it points to. */
  270 +
  271 +void g95_free_array_ref(g95_array_ref *as) {
  272 +int e;
183 273
184   - mpz_add_ui(*rslt, *rslt, 1);
185   -
186   - return SUCCESS;
187   -}
  274 + for(e=0; e<G95_MAX_DIMENSIONS; e++) {
  275 + g95_free_expr(as->start[e]);
  276 + g95_free_expr(as->end[e]);
  277 + g95_free_expr(as->stride[e]);
  278 + }
  279 +
  280 + g95_free(as);
  281 +}
  282 +
  283 +
  284 +
  285 +
  286 +/* g95_copy_array_ref()-- Copy an array reference structure */
  287 +
  288 +g95_array_ref *g95_copy_array_ref(g95_array_ref *s1) {
  289 +g95_array_ref *d;
  290 +int c;
188 291
  292 + if (s1 == NULL) return NULL;
  293 +
  294 + d = g95_get_array_ref();
  295 + *d = *s1;
  296 +
  297 + for(c=0; c<G95_MAX_DIMENSIONS; c++) {
  298 + d->start[c] = g95_copy_expr(s1->start[c]);
  299 + d->end[c] = g95_copy_expr(s1->end[c]);
  300 + d->stride[c] = g95_copy_expr(s1->stride[c]);
  301 + }
  302 +
  303 + return d;
  304 +}
  305 +
  306 +
189 307
190 308
  309 +/* g95_match_array_constructor()-- Match an array constructor */
  310 +
  311 +match g95_match_array_constructor(g95_expr **r) {
  312 +g95_constructor *h, *end, *n;
  313 +g95_locus where;
  314 +g95_expr *e2;
  315 +match v;
  316 +
  317 + if (g95_match(" (/") == MATCH_NO &&
  318 + g95_match_char('[') == MATCH_NO) return MATCH_NO;
191 319
192   -/* g95_copy_array_ref()-- Copy an array reference structure */
  320 + where = g95_current_locus;
  321 + h = end = NULL;
193 322
194   -g95_array_ref *g95_copy_array_ref(g95_array_ref *src) {
195   -g95_array_ref *d;
196   -int b;
197   -
198   - if (src == NULL) return NULL;
  323 + if (g95_match(" /)") == MATCH_YES ||
  324 + g95_match_char(']') == MATCH_YES) goto empty; /* Special case */
  325 +
  326 + for(;;) {
  327 + v = match_array_cons_element(&n);
  328 + if (v == MATCH_ERROR) goto cleanup;
  329 + if (v == MATCH_NO) goto syntax;
  330 +
  331 + if (h == NULL)
  332 + h = n;
  333 + else
  334 + end->next = n;
  335 +
  336 + end = n;
199 337
200   - d = g95_get_array_ref();
201   - *d = *src;
202   -
203   - for(b=0; b<G95_MAX_DIMENSIONS; b++) {
204   - d->start[b] = g95_copy_expr(src->start[b]);
205   - d->end[b] = g95_copy_expr(src->end[b]);
206   - d->stride[b] = g95_copy_expr(src->stride[b]);
  338 + if (g95_match_char(',') == MATCH_NO) break;
207 339 }
208 340
209   - return d;
210   -}
211   -
  341 + if (g95_match(" /)") == MATCH_NO &&
  342 + g95_match_char(']') == MATCH_NO) goto syntax;
212 343
  344 +empty:
  345 + e2 = g95_get_expr();
  346 +
  347 + e2->type = EXPR_ARRAY;
  348 + e2->value.constructor = h;
  349 + /* Size must be calculated at resolution time */
  350 +
  351 + e2->where = where;
  352 + e2->rank = 1;
213 353
214   -
215   -/* g95_expanded_ac()-- Returns nonzero if an array constructor has
216   - * been completely expanded (no iterators) and zero if iterators are
217   - * present. */
  354 + *r = e2;
  355 + return MATCH_YES;
  356 +
  357 +syntax:
  358 + g95_error("Syntax error in array constructor at %C");
  359 +
  360 +cleanup:
  361 + g95_free_constructor(h);
  362 + return MATCH_ERROR;
  363 +}
  364 +
218 365
219   -int g95_expanded_ac(g95_expr *s) {
220   -g95_constructor *o;
221 366
222   - if (s->type == EXPR_ARRAY)
223   - for(o=s->value.constructor; o; o=o->next)
224   - if (o->iterator != NULL || !g95_expanded_ac(o->expr)) return 0;
225 367
226   - return 1;
227   -}
228   -
229   -
230   -
  368 +/* g95_simplify_iteration_var()-- Given an initialization expression
  369 + * that is a variable reference, substitute the current value of the
  370 + * iteration variable. */
  371 +
  372 +try g95_simplify_iterator_var(g95_expr *c) {
  373 +iterator_stack *j;
  374 +
  375 + for(j=iter_stack; j; j=j->prev)
  376 + if (c->symbol == j->variable) break;
  377 +
  378 + if (j == NULL) return FAILURE; /* Variable not found */
231 379
232   -/* g95_compare_array_spec()-- Compares two array specifications. */
  380 + g95_replace_expr(c, g95_int_expr(0));
  381 +
  382 + mpz_set(c->value.integer, j->value);
  383 +
  384 + return SUCCESS;
  385 +}
233 386
234   -int g95_compare_array_spec(g95_array_spec *as1, g95_array_spec *as2) {
235   -int t, w, o;
236 387
237   - if (as1 == NULL && as2 == NULL) return 1;
238   -
239   - if (as1 == NULL || as2 == NULL) return 0;
240   -
241   - if (as1->rank != as2->rank) return 0;
242 388
243   - if (as1->rank == 0) return 1;
244   -
245   - if (as1->type != as2->type) return 0;
246   -
247   - if (as1->type == AS_EXPLICIT)
248   - for(t=0; t<as1->rank; t++) {
249   - if (g95_extract_int(as1->lower[t], &w) != NULL) goto error;
250   - if (g95_extract_int(as2->lower[t], &o) != NULL) goto error;
251   - if (w != o) return 0;
252 389
253   - if (g95_extract_int(as1->upper[t], &w) != NULL) goto error;
254   - if (g95_extract_int(as2->upper[t], &o) != NULL) goto error;
255   - if (w != o) return 0;
256   - }
257   -
258   - return 1;
  390 +/* g95_expanded_ac()-- Returns nonzero if an array constructor has
  391 + * been completely expanded (no iterators) and zero if iterators are
  392 + * present. */
259 393
260   -error:
261   - g95_internal_error("g95_compare_array_spec(): Array spec clobbered");
262   - return 0; /* Keep the compiler happy */
263   -}
264   -
265   -
266   -
267   -
268   -/* resolve_array_bound()-- Takes an array bound, resolves the expression,
269   - * that make up the shape and check associated constraints. */
270   -
271   -static try resolve_array_bound(g95_expr *y, int check_constant) {
  394 +int g95_expanded_ac(g95_expr *f) {
  395 +g95_constructor *u;
272 396
273   - if (y == NULL) return SUCCESS;
274   -
275   - if (g95_resolve_expr(y) == FAILURE ||
276   - g95_specification_expr(y) == FAILURE ||
277   - g95_simplify_expr(y, 0) == FAILURE) return FAILURE;
278   -
279   - if (check_constant && g95_is_constant_expr(y) == 0) {
280   - g95_error("Bounds of array '%s' at %L must be constant",
281   - y->symbol->name, &y->where);
282   - return FAILURE;
283   - }
  397 + if (f->type == EXPR_ARRAY)
  398 + for(u=f->value.constructor; u; u=u->next)
  399 + if (u->iterator != NULL || !g95_expanded_ac(u->expr)) return 0;
  400 +
  401 + return 1;
  402 +}
  403 +
284 404
  405 +
  406 +
  407 +#ifndef IN_GCC
  408 +try g95_expand_ac_element(g95_expr *n) {
285 409 return SUCCESS;
286   -}
287   -
  410 +}
  411 +#endif
  412 +
  413 +
  414 +
  415 +
  416 +/* extract_element()-- Work function that extracts a particular
  417 + * element from an array constructor, freeing the rest. */
  418 +
  419 +static try extract_element(g95_expr *w) {
288 420
  421 + if (w->rank != 0) { /* Something unextractable */
  422 + g95_free_expr(w);
  423 + return FAILURE;
  424 + }
289 425
290   -
291   -/* g95_match_array_constructor()-- Match an array constructor */
292   -
293   -match g95_match_array_constructor(g95_expr **result) {
294   -g95_constructor *h, *tail, *n1;
295   -g95_expr *e1;
296   -locus loc;
297   -match g;
298   -
299   - if (g95_match(" (/") == MATCH_NO &&
300   - g95_match_char('[') == MATCH_NO) return MATCH_NO;
301   -
302   - loc = *g95_current_locus();
303   - h = tail = NULL;
304   -
305   - if (g95_match(" /)") == MATCH_YES ||
306   - g95_match_char(']') == MATCH_YES) goto empty; /* Special case */
  426 + if (current_expand.extract_count == current_expand.extract_n)
  427 + current_expand.extracted = w;
  428 + else
  429 + g95_free_expr(w);
  430 +
  431 + current_expand.extract_count++;
  432 + return SUCCESS;
  433 +}
307 434
308   - for(;;) {
309   - g = match_array_cons_element(&n1);
310   - if (g == MATCH_ERROR) goto cleanup;
311   - if (g == MATCH_NO) goto syntax;
312   -
313   - if (h == NULL)
314   - h = n1;
315   - else
316   - tail->next = n1;
  435 +
  436 +
  437 +
  438 +/* g95_match_array_ref()-- Match an array reference, whether it is the
  439 + * whole array or a particular elements or a section. */
317 440
318   - tail = n1;
  441 +match g95_match_array_ref(g95_array_ref *spec, int init) {
  442 +match i;
  443 +
  444 + memset(spec, '\0', sizeof(spec));
319 445
320   - if (g95_match_char(',') == MATCH_NO) break;
  446 + if (g95_match_char('(') != MATCH_YES) {
  447 + spec->type = AR_FULL;
  448 + spec->dimen = 0;
  449 + return MATCH_YES;
321 450 }
322 451
323   - if (g95_match(" /)") == MATCH_NO &&
324   - g95_match_char(']') == MATCH_NO) goto syntax;
325   -
326   -empty:
327   - e1 = g95_get_expr();
328   -
329   - e1->type = EXPR_ARRAY;
330   - e1->value.constructor = h;
331   - /* Size must be calculated at resolution time */
332   -
333   - e1->where = loc;
334   - e1->rank = 1;
  452 + spec->type = AR_UNKNOWN;
335 453
336   - *result = e1;
337   - return MATCH_YES;
  454 + for(spec->dimen=0; spec->dimen<G95_MAX_DIMENSIONS; spec->dimen++) {
  455 + i = match_subscript(spec, init);
  456 + if (i == MATCH_ERROR) goto error;
  457 +
  458 + if (g95_match_char(')') == MATCH_YES) goto matched;
338 459
339   -syntax:
340   - g95_error("Syntax error in array constructor at %C");
341   -
342   -cleanup:
343   - g95_free_constructor(h);
344   - return MATCH_ERROR;
345   -}
346   -
  460 + if (g95_match_char(',') != MATCH_YES) {
  461 + g95_error("Invalid form of array reference at %C");
  462 + goto error;
  463 + }
  464 + }
347 465
348   -
349   -
350   -/* g95_show_array_ref()-- Show an array reference */
351   -
352   -void g95_show_array_ref(g95_array_ref *as) {
353   -int b;
354   -
355   - g95_status_char('(');
356   -
357   - switch(as->type) {
358   - case AR_FULL:
359   - g95_status("FULL");
360   - break;
361   -
362   - case AR_SECTION:
363   - for(b=0; b<as->dimen; b++) {
364   - if (as->start[b] != NULL)
365   - g95_show_expr(as->start[b]);
366   -
367   - g95_status_char(':');
368   -
369   - if (as->end[b] != NULL)
370   - g95_show_expr(as->end[b]);
371   -
372   - if (as->stride[b] != NULL) {
373   - g95_status_char(':');
374   - g95_show_expr(as->stride[b]);
375   - }
376   -
377   - if (b != as->dimen-1) g95_status(" , ");
378   - }
379   - break;
380   -
381   - case AR_ELEMENT:
382   - for(b=0; b<as->dimen; b++) {
383   - g95_show_expr(as->start[b]);
384   - if (b != as->dimen - 1) g95_status(" , ");
385   - }
386   - break;
387   -
388   - case AR_UNKNOWN:
389   - g95_status("UNKNOWN");
390   - break;
391   -
392   - default:
393   - g95_internal_error("g95_show_array_ref(): Unknown array reference");
394   - }
395   -
396   - g95_status_char(')');
397   -}
398   -
399   -
  466 + g95_error("Array reference at %C cannot have more than "
  467 + stringize(G95_MAX_DIMENSIONS) " dimensions");
400 468
401   -
402   -/* g95_resolve_array_spec()-- Takes an array specification, resolves
403   - * the expressions that make up the shape and make sure everything is
404   - * integral. */
405   -
406   -try g95_resolve_array_spec(g95_array_spec *ref, int check_constant) {
407   -g95_expr *e;
408   -int v;
409   -
410   - if (ref == NULL) return SUCCESS;
  469 +error:
  470 + return MATCH_ERROR;
411 471
412   - for(v=0; v<ref->rank; v++) {
413   - e = ref->lower[v];
414   - if (resolve_array_bound(e, check_constant) == FAILURE) return FAILURE;
415   -
416   - e = ref->upper[v];
417   - if (resolve_array_bound(e, check_constant) == FAILURE) return FAILURE;
418   - }
419   -
420   - return SUCCESS;
421   -}
422   -
423   -
424   -
  472 +matched:
  473 + spec->dimen++;
  474 + return MATCH_YES;
  475 +}
425 476
426   -/* extract_element()-- Work function that extracts a particular
427   - * element from an array constructor, freeing the rest. */
428 477
429   -static try extract_element(g95_expr *o) {
430   -
431   - if (o->rank != 0) { /* Something unextractable */
432   - g95_free_expr(o);
433   - return FAILURE;
434   - }
435 478
436   - if (current_expand.extract_count == current_expand.extract_n)
437   - current_expand.extracted = o;
438   - else
439   - g95_free_expr(o);
  479 +
  480 +/* g95_free_array_spec()-- Free all of the expressions associated with
  481 + * array bounds specifications */
440 482
441   - current_expand.extract_count++;
442   - return SUCCESS;
443   -}
  483 +void g95_free_array_spec(g95_array_spec *as) {
  484 +int u;
444 485
  486 + if (as == NULL) return;
  487 +
  488 + for(u=0; u<as->rank; u++) {
  489 + g95_free_expr(as->lower[u]);
  490 + g95_free_expr(as->upper[u]);
  491 + }
445 492
446   -
447   -
448   -/* g95_free_constructor()-- Free chains of g95_constructor structures */
449   -
450   -void g95_free_constructor(g95_constructor *h) {
451   -g95_constructor *nxt;
  493 + g95_free(as);
  494 +}
452 495
453   - if (h == NULL) return;
454 496
455   - for(; h; h=nxt) {
456   - nxt = h->next;
457   -
458   - g95_free_expr(h->expr);
459   - if (h->iterator != NULL) g95_free_iterator(h->iterator, 1);
460   - g95_free(h);
461   - }
462   -}
463 497
464 498
  499 +/* copy_iterator()-- Copy an iterator structure */
  500 +
  501 +static g95_iterator *copy_iterator(g95_iterator *source) {
  502 +g95_iterator *d1;
  503 +
  504 + if (source == NULL) return NULL;
  505 +
  506 + d1 = g95_get_iterator();
  507 +
  508 + d1->var = g95_copy_expr(source->var);
  509 + d1->start = g95_copy_expr(source->start);
  510 + d1->end = g95_copy_expr(source->end);
  511 + d1->step = g95_copy_expr(source->step);
465 512
  513 + return d1;
  514 +}
466 515
467   -static try ref_size(g95_array_ref *ref, g95_array_spec *as, mpz_t *r) {
468   -mpz_t size;
469   -int u;
470   -
471   - mpz_init_set_ui(*r, 1);
472   -
473   - for(u=0; u<ref->dimen; u++) {
474   - if (ref_dimen_size(ref, as, u, &size) == FAILURE) {
475   - mpz_clear(*r);
476   - return FAILURE;
477   - }
478 516
479   - mpz_mul(*r, *r, size);
480   - mpz_clear(size);
481   - }
  517 +
  518 +
  519 +/* resolve_array_bound()-- Takes an array bound, resolves the expression,
  520 + * that make up the shape and check associated constraints. */
  521 +
  522 +static try resolve_array_bound(g95_expr *t, int check_constant) {
  523 +
  524 + if (t == NULL) return SUCCESS;
482 525
483   - return SUCCESS;
  526 + if (g95_resolve_expr(t) == FAILURE ||
  527 + g95_specification_expr(t) == FAILURE ||
  528 + g95_simplify_expr(t, 0) == FAILURE) return FAILURE;
  529 +
  530 + if (check_constant && g95_is_constant_expr(t) == 0) {
  531 + g95_error("Bounds of array '%s' at %L must be constant",
  532 + t->symbol->name, &t->where);
  533 + return FAILURE;
  534 + }
  535 +
  536 + return SUCCESS;
484 537 }
485 538
486 539
487   -
488   -
489   -/* match_subscript()-- Match a single dimension of an array reference.
490   - * This can be a single element or an array section. Any modifications
491   - * we've made to the ar structure are cleaned up by the caller. */
492 540
493   -static match match_subscript(g95_array_ref *ar, int iv) {
494   -match x;
495   -int y;
496   -
497   - y = ar->dimen;
  541 +
  542 +/* count_elements()-- Work function that counts the number of elements
  543 + * present in a constructor. */
  544 +
  545 +static try count_elements(g95_expr *s) {
  546 +mpz_t res;
498 547
499   - ar->c_where[y] = *g95_current_locus();
500   - ar->start[y] = ar->end[y] = ar->stride[y] = NULL;
501   -
502   - /* We can't be sure of the difference between DIMEN_ELEMENT and
503   - * DIMEN_VECTOR until we know the type of the element itself at
504   - * resolution time. */
  548 + if (s->rank == 0)
  549 + mpz_add_ui(*current_expand.count, *current_expand.count, 1);
  550 + else {
  551 + if (g95_array_size(s, &res) == FAILURE) {
  552 + g95_free_expr(s);
  553 + return FAILURE;
  554 + }
505 555
506   - ar->dimen_type[y] = DIMEN_UNKNOWN;
  556 + mpz_add(*current_expand.count, *current_expand.count,
  557 + res);
  558 + mpz_clear(res);
  559 + }
  560 +
  561 + g95_free_expr(s);
  562 + return SUCCESS;
  563 +}
  564 +
  565 +
507 566
508   - if (g95_match_char(':') == MATCH_YES) goto end_element;
509 567
510   - /* Get start element */
511   -
512   - if (iv)
513   - x = g95_match_init_expr(&ar->start[y]);
514   - else
515   - x = g95_match_expr(&ar->start[y]);
516   -
517   - if (x == MATCH_NO) g95_error("Expected array subscript at %C");
518   - if (x != MATCH_YES) return MATCH_ERROR;
  568 +/* g95_copy_constructor()-- Copy a constructor structure. */
519 569
520   - if (g95_match_char(':') == MATCH_NO) return MATCH_YES;
521   -
522   -/* Get an optional end element. Because we've seen the colon, we
523   - * definitely have a range along this dimension. */
524   -
525   -end_element:
526   - ar->dimen_type[y] = DIMEN_RANGE;
527   -
528   - if (iv)
529   - x = g95_match_init_expr(&ar->end[y]);
530   - else
531   - x = g95_match_expr(&ar->end[y]);
  570 +g95_constructor *g95_copy_constructor(g95_constructor *s1) {
  571 +g95_constructor *dst;
532 572
533   - if (x == MATCH_ERROR) return MATCH_ERROR;
534   -
535   -/* See if we have an optional stride */
536   -
537   - if (g95_match_char(':') == MATCH_YES) {
538   - x = iv ? g95_match_init_expr(&ar->stride[y])
539   - : g95_match_expr(&ar->stride[y]);
540   -
541   - if (x == MATCH_NO) g95_error("Expected array subscript stride at %C");
542   - if (x != MATCH_YES) return MATCH_ERROR;
543   - }
544   -
545   - return MATCH_YES;
546   -}
547   -
548   -
549   -
550   -
551   -/* g95_free_array_spec()-- Free all of the expressions associated with
552   - * array bounds specifications */
553   -
554   -void g95_free_array_spec(g95_array_spec *as) {
555   -int a;
556   -
557   - if (as == NULL) return;
558   -
559   - for(a=0; a<as->rank; a++) {
560   - g95_free_expr(as->lower[a]);
561   - g95_free_expr(as->upper[a]);
562   - }
563   -
564   - g95_free(as);
565   -}
566   -
  573 + if (s1 == NULL) return NULL;
567 574
568   -
569   -
570   -/* g95_simplify_iteration_var()-- Given an initialization expression
571   - * that is a variable reference, substitute the current value of the
572   - * iteration variable. */
573   -
574   -try g95_simplify_iterator_var(g95_expr *a) {
575   -iterator_stack *o;
576   -
577   - for(o=iter_stack; o; o=o->prev)
578   - if (a->symbol == o->variable) break;
579   -
580   - if (o == NULL) return FAILURE; /* Variable not found */
581   -
582   - g95_replace_expr(a, g95_int_expr(0));
  575 + dst = g95_get_constructor();
  576 + dst->where = s1->where;
  577 + dst->expr = g95_copy_expr(s1->expr);
  578 + dst->iterator = copy_iterator(s1->iterator);
583 579
584   - mpz_set(a->value.integer, o->value);
585   -
586   - return SUCCESS;
587   -}
588   -
  580 + dst->next = g95_copy_constructor(s1->next);
589 581
590   -
591   -
592   -static mstring array_specs[] = {
593   - minit("AS_EXPLICIT", AS_EXPLICIT),
594   - minit("AS_ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
595   - minit("AS_DEFERRED", AS_DEFERRED),
596   - minit("AS_ASSUMED_SIZE", AS_ASSUMED_SIZE),
597   - minit(NULL, 0) };
598   -
599   -void g95_show_array_spec(g95_array_spec *ref) {
600   -int g;
601   -
602   - if (ref == NULL) {
603   - g95_status("()");
604   - return;
605   - }
  582 + return dst;
  583 +}
  584 +
  585 +
  586 +
  587 +
  588 +/* g95_start_constructor()-- Start an array constructor. The
  589 + * constructor starts with zero elements and should be appended to by
  590 + * g95_append_constructor(). */
  591 +
  592 +g95_expr *g95_start_constructor(bt dtype, int k, g95_locus *where) {
  593 +g95_expr *res;
606 594
607   - g95_status("(%d", ref->rank);
  595 + res = g95_get_expr();
608 596
609   - if (ref->rank != 0) {
610   - g95_status(" %s ", g95_code2string(array_specs, ref->type));
611   -
612   - for(g=0; g<ref->rank; g++) {
613   - g95_show_expr(ref->lower[g]);
614   - g95_status_char(' ');
615   - g95_show_expr(ref->upper[g]);
616   - g95_status_char(' ');
617   - }
618   - }
  597 + res->type = EXPR_ARRAY;
  598 + res->rank = 1;
619 599
620   - g95_status(")");
  600 + res->ts.type = dtype;
  601 + res->ts.kind = k;
  602 + res->where = *where;
  603 +
  604 + return res;
621 605 }
622 606
623 607
624   -
625   -
626   -/* expand_expr()-- Expand an expression with that is inside of a
627   - * constructor, recursing into other constructors if present. */
628   -
629   -static try expand_expr(g95_expr *s) {
630   -
631   - if (s->type == EXPR_ARRAY)
632   - return expand_constructor(s->value.constructor);
633   -
634   - s = g95_copy_expr(s);
635 608
636   - if (g95_simplify_expr(s, 1) == FAILURE) {
637   - g95_free_expr(s);
638   - return FAILURE;
639   - }
640   -
641   - return current_expand.expand_work_function(s);
642   -}
643   -
644   -
645   -
646   -
  609 +
647 610 /* g95_set_array_spec()-- Given a symbol and an array specification,
648 611 * modify the symbol to have that array specification. The error
649 612 * locus is needed in case something goes wrong. On failure, the
650   - * caller must free the spec. */
651   -
652   -try g95_set_array_spec(g95_symbol *symb, g95_array_spec *a, locus *error_loc) {
653   -
654   - if (a == NULL) return SUCCESS;
655   -
656   - if (g95_add_dimension(&symb->attr, error_loc) == FAILURE) return FAILURE;
657   -
658   - symb->as = a;
659   -
660   - return SUCCESS;
661   -}
  613 + * caller must free the spec. */
662 614
663   -
664   -
665   -
666   -/* g95_check_constructor()-- Checks a constructor to see if it is a
667   - * particular kind of expression-- specification, restricted,
668   - * or initialization as determined by the check_function. */
669   -
670   -try g95_check_constructor(g95_expr *e1,
671   - try (*check_function)(g95_expr *)) {
672   -cons_stack *base_save;
673   -try w;
  615 +try g95_set_array_spec(g95_symbol *sy, g95_array_spec *ref,
  616 + g95_locus *error_loc) {
674 617
675   - base_save = stack_base;
676   - stack_base = NULL;
  618 + if (ref == NULL) return SUCCESS;
  619 +
  620 + if (g95_add_dimension(&sy->attr, error_loc) == FAILURE) return FAILURE;
  621 +
  622 + sy->as = ref;
  623 +
  624 + return SUCCESS;
  625 +}
  626 +
  627 +
  628 +
  629 +
  630 +/* g95_match_array_spec()-- Matches an array specification,
  631 + * incidentally figuring out what sort it is. */
677 632
678   - w = check_constructor(e1->value.constructor, check_function);
679   - stack_base = base_save;
680   -
681   - return w;
682   -}
683   -
684   -
685   -
686   -
687   -/* count_elements()-- Work function that counts the number of elements
688   - * present in a constructor. */
689   -
690   -static try count_elements(g95_expr *c) {
691   -mpz_t res;
692   -
693   - if (c->rank == 0)
694   - mpz_add_ui(*current_expand.count, *current_expand.count, 1);
695   - else {
696   - if (g95_array_size(c, &res) == FAILURE) {
697   - g95_free_expr(c);
698   - return FAILURE;
699   - }
700   -
701   - mpz_add(*current_expand.count, *current_expand.count,
702   - res);
703   - mpz_clear(res);
  633 +match g95_match_array_spec(g95_array_spec **asp) {
  634 +array_type current_type;
  635 +g95_array_spec *as;
  636 +int o;
  637 +
  638 + if (g95_match_char('(') != MATCH_YES) {
  639 + *asp = NULL;
  640 + return MATCH_NO;
  641 + }
  642 +
  643 + as = g95_get_array_spec();
  644 +
  645 + for(o=0; o<G95_MAX_DIMENSIONS; o++) {
  646 + as->lower[o] = NULL;
  647 + as->upper[o] = NULL;
704 648 }
705 649
706   - g95_free_expr(c);
707   - return SUCCESS;
708   -}
709   -
710   -
  650 + as->rank = 1;
711 651
712   -
713   -/* array_function_size()-- Deduce the size of an array-value intrinsic
714   - * for a couple common inquiry functions. */
715   -
716   -static try array_function_size(g95_expr *x, mpz_t *res) {
717   -g95_intrinsic_sym *isym;
718   -
719   - isym = x->value.function.isym;
720   - if (isym == NULL) return FAILURE;
721   -
722   - /* TODO: follow elemental functions into their arguments */
723   -
724   - switch(isym->generic_id) {
725   - case G95_ISYM_MINLOC:
726   - case G95_ISYM_MAXLOC:
727   - case G95_ISYM_SHAPE:
728   - case G95_ISYM_LBOUND:
729   - case G95_ISYM_UBOUND:
730   - /* Special cases where the size of the array is equal to the rank
731   - * of the first argument. The second argument (DIM) must not be
732   - * present. */
733   -
734   - if (x->value.function.actual->next != NULL) break;
  652 + for(;;) {
  653 + current_type = match_array_element_spec(as);
  654 +
  655 + if (as->rank == 1) {
  656 + if (current_type == AS_UNKNOWN) goto cleanup;
  657 + as->type = current_type;
  658 + } else
  659 + switch(as->type) { /* See how current spec meshes with the existing */