Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 981 lines (658 sloc) 28.905 kb
4c6fcac 7/28
andyv authored
1
2 /* Common and equivalence block handling
3 Copyright (C) 2000-2003 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
5
6 This file is part of G95.
7
8 G95 is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
11 any later version.
12
13 G95 is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with G95; see the file COPYING. If not, write to
20 the Free Software Foundation, 59 Temple Place - Suite 330,
ce769c2 3/17
andyv authored
21 Boston, MA 02111-1307, USA. */
22
23
4c6fcac 7/28
andyv authored
24 /* Transform common blocks. An integral part of this is processing
25 * EQUIVALENCE variables. Equivalenced variables that are not in a
26 * common block end up in a private block of their own.
27 *
28 * Each common block is a global character array of some length. The
29 * blank common has its own name that is an otherwise inaccessible
30 * name. Variables within the block are represented as an array
31 * element within the block. While it should be possible to declare
32 * the areas as a union, it seems much easier to represent things this
33 * way, particularly for an initialized common (a block of bytes).
34 *
35 * So if two variables are equivalenced, they just point to a common
36 * area in memory.
37 *
38 * Mathematically, laying out an equivalence block is equivalent to
ce769c2 3/17
andyv authored
39 * solving a linear system of equations. The matrix is a sparse
40 * matrix in which each row contains all zero elements except for a +1
41 * and a -1, a sort of a generalized Vandermonde matrix. The matrix
42 * is usually block diagonal. The system can be overdetermined,
43 * underdetermined or have a unique solution. If the system is
44 * inconsistent, the program is not standard conforming. The solution
45 * vector is integral, since all of the pivots are +1 or -1.
4c6fcac 7/28
andyv authored
46 *
47 * How we lay out an equivalence block is a little less complicated.
48 * In an equivalence list with n elements, there are n-1 conditions to
49 * be satisfied. The conditions partition the variables into what we
50 * will call segments. If A and B are equivalenced then A and B are
51 * in the same segment. If B and C are equivalenced as well, then A,
52 * B and C are in a segment and so on. Each segment is a block of
53 * memory that has one or more variables equivalenced in some way. A
54 * common block is made up of a series of segments that are joined one
55 * after the other. In the linear system, a segment is a block
56 * diagonal.
57 *
58 * To lay out a segment we first start with some variable and
59 * determine its length. The first variable is assumed to start at
60 * offset one and extends to however long it is. We then traverse the
61 * list of equivalences to find an unused condition that involves at
62 * least one of the variables currently in the segment.
63 *
64 * Each equivalence condition amounts to the condition B+b=C+c where B
65 * and C are the offsets of the B and C variables, and b and c are
66 * constants which are nonzero for array elements, substrings or
67 * structure components. So for
68 *
69 * EQUIVALENCE(B(2), C(3))
70 * we have
71 * B + 2*size of B's elements = C + 3*size of C's elements.
72 *
73 * If B and C are known we check to see if the condition already
74 * holds. If B is known we can solve for C. Since we know the length
75 * of C, we can see if the minimum and maximum extents of the segment
76 * are affected. Eventually, we make a full pass through the
77 * equivalence list without finding any new conditions and the segment
78 * is fully specified.
79 *
80 * At this point, the segment is added to the current common block.
ce769c2 3/17
andyv authored
81 * The seed symbol in the common block determines the extent of the
82 * segment, the rest of the variables are along for the ride. The
4c6fcac 7/28
andyv authored
83 * usual case here is that there are no equivalence statements and the
84 * common block is series of segments with one variable each, which is
85 * a diagonal matrix in the matrix formulation.
86 *
87 * Once all common blocks have been created, the list of equivalences
88 * is examined for still-unused equivalence conditions. If these
89 * exist, a variable from an unused equivalence is placed into a
90 * private block in order to start a new segment, which is built as
91 * usual. This process continues until all equivalenced variables
ce769c2 3/17
andyv authored
92 * have been put into a block.
93 *
94 * The overall process for creating common blocks is to examine all
95 * common blocks within the source file, and create those common
96 * blocks that are initialized. The remaining common blocks are
97 * created as uninitialied memory. When processing program units, we
98 * again loop over common blocks in the program unit. The variables
99 * within the common are then declared as offsets within the block.
100 */
101
4c6fcac 7/28
andyv authored
102 #include "trans.h"
ce769c2 3/17
andyv authored
103
104
105 typedef struct segment_info {
106 g95_symbol *sym;
107 int offset, length;
108 struct segment_info *next;
109 g95_equiv *rule;
110 } segment_info;
111
112 static segment_info *current_segment, *current_common;
113 static int common_length, real_common, seen_init;
4c6fcac 7/28
andyv authored
114
ce769c2 3/17
andyv authored
115 static tree blank_common_decl;
116 static g95_locus blank_common_locus;
117 static int blank_common_length, blank_common_seen=0;
118
119
4c6fcac 7/28
andyv authored
120 #define get_segment_info() g95_getmem(sizeof(segment_info))
ce769c2 3/17
andyv authored
121
122
123
124
125 /* get_mpz()-- Given an expression node, make sure it is a constant
126 * integer and return the mpz_t value. */
4c6fcac 7/28
andyv authored
127
ce769c2 3/17
andyv authored
128 static mpz_t *get_mpz(g95_expr *n) {
4c6fcac 7/28
andyv authored
129
ce769c2 3/17
andyv authored
130 if (n->type != EXPR_CONSTANT)
131 g95_internal_error("get_mpz(): Not an integer constant");
4c6fcac 7/28
andyv authored
132
ce769c2 3/17
andyv authored
133 return &n->value.integer;
134 }
135
136
4c6fcac 7/28
andyv authored
137
138
ce769c2 3/17
andyv authored
139 /* calculate_offset()-- Given a single element of an equivalence list,
140 * figure out the offset from the base symbol. For simple variables
141 * or full arrays, this is simply zero. For an array element we have
142 * to calculate the array element number and multiply by the element
143 * size. For a substring we have to calculate the further reference. */
4c6fcac 7/28
andyv authored
144
ce769c2 3/17
andyv authored
145 static int calculate_offset(g95_expr *x) {
146 int q, element_size, off;
147 g95_typespec *element_type;
148 g95_array_spec *a;
149 g95_ref *ref;
150
151 off = 0;
152 element_type = &x->symbol->ts;
153
154 a = x->symbol->as;
155
156 for(ref=x->ref; ref; ref=ref->next)
157 switch(ref->type) {
158 case REF_ARRAY:
159 switch(ref->u.ar.type) {
160 case AR_FULL:
161 break;
162
163 case AR_ELEMENT:
164 q = g95_element_number(&ref->u.ar, a);
165 element_size = int_size_in_bytes(g95_typenode_for_spec(element_type));
166
167 off += q * element_size;
168 break;
4c6fcac 7/28
andyv authored
169
ce769c2 3/17
andyv authored
170 default:
171 g95_internal_error("calculate_offset(): Bad array reference");
172 }
173
174 break;
4c6fcac 7/28
andyv authored
175
ce769c2 3/17
andyv authored
176 case REF_COMPONENT:
177 abort(); /* Can't happen */
178 break;
179
180 case REF_SUBSTRING:
181 if (ref->u.ss.start != NULL)
182 off += mpz_get_ui(*get_mpz(ref->u.ss.start)) - 1;
4c6fcac 7/28
andyv authored
183
ce769c2 3/17
andyv authored
184 break;
4c6fcac 7/28
andyv authored
185 }
186
ce769c2 3/17
andyv authored
187 return off;
188 }
189
190
191
192
4c6fcac 7/28
andyv authored
193 /* find_segment_info()-- Given a symbol, find it in the current list
ce769c2 3/17
andyv authored
194 * segment list. Returns NULL if not found. */
195
196 static segment_info *find_segment_info(g95_symbol *symb) {
197 segment_info *p;
198
199 for(p=current_segment; p; p=p->next)
200 if (p->sym == symb) return p;
4c6fcac 7/28
andyv authored
201
ce769c2 3/17
andyv authored
202 return NULL;
203 }
204
205
206
207
208 /* seg_compare()-- Compare the offsets for two segments. */
4c6fcac 7/28
andyv authored
209
ce769c2 3/17
andyv authored
210 static int seg_compare(const void *a, const void *b) {
211 segment_info *i, *u;
212
213 i = *((segment_info **) a);
214 u = *((segment_info **) b);
215
216 return i->offset - u->offset;
217 }
218
219
220
221
222 /* equivalence_conflict()-- Complain about a symbol at two offsets */
4c6fcac 7/28
andyv authored
223
ce769c2 3/17
andyv authored
224 static void equivalence_conflict(char *name0, g95_equiv *rule, int h, int t) {
225
226 g95_error("EQUIVALENCE conflict, '%s' at %L has conflicting "
227 "offsets %d and %d", name0, &rule->expr->where, h, t);
228 }
4c6fcac 7/28
andyv authored
229
230
ce769c2 3/17
andyv authored
231
232
233 /* g95_element_number()-- Given an array specification and an array
234 * reference, figure out the array element number (zero based).
235 * Bounds and elements are guaranteed to be constants. */
236
237 int g95_element_number(g95_array_ref *ref, g95_array_spec *a) {
238 mpz_t multiplier, offs, ext, k, *index, *lower, *up;
239 int r, dim;
240
241 dim = a->rank;
242 mpz_init_set_ui(multiplier, 1);
243 mpz_init_set_ui(offs, 0);
244 mpz_init(ext);
245 mpz_init(k);
4c6fcac 7/28
andyv authored
246
ce769c2 3/17
andyv authored
247 for(r=0; r<dim; r++) {
248 if (ref->dimen_type[r] != DIMEN_ELEMENT)
249 g95_internal_error("g95_element_number(): Bad dimension type");
250
251 lower = get_mpz(a->lower[r]);
252 up = get_mpz(a->upper[r]);
253 index = get_mpz(ref->start[r]);
254
255 mpz_sub(k, *index, *lower);
4c6fcac 7/28
andyv authored
256
ce769c2 3/17
andyv authored
257 mpz_mul(k, k, multiplier);
258 mpz_add(offs, offs, k);
4c6fcac 7/28
andyv authored
259
ce769c2 3/17
andyv authored
260 mpz_sub(ext, *get_mpz(a->upper[r]), *get_mpz(a->lower[r]));
261 mpz_add_ui(ext, ext, 1);
262
263 if (mpz_sgn(ext) < 0) mpz_set_ui(ext, 0);
4c6fcac 7/28
andyv authored
264
ce769c2 3/17
andyv authored
265 mpz_mul(multiplier, multiplier, ext);
266 }
267
268 r = mpz_get_ui(offs);
269
270 mpz_clear(multiplier);
271 mpz_clear(offs);
272 mpz_clear(ext);
273 mpz_clear(k);
4c6fcac 7/28
andyv authored
274
ce769c2 3/17
andyv authored
275 return r;
276 }
277
278
4c6fcac 7/28
andyv authored
279
280
ce769c2 3/17
andyv authored
281 /* calculate_length()-- Given a variable symbol, calculate the total
282 * length in bytes of the variable. */
4c6fcac 7/28
andyv authored
283
ce769c2 3/17
andyv authored
284 static int calculate_length(g95_symbol *symb) {
285 int m, element_size;
286 mpz_t elements;
4c6fcac 7/28
andyv authored
287
ce769c2 3/17
andyv authored
288 if (symb->as != NULL && symb->attr.pointer)
289 return int_size_in_bytes(g95_get_array_desc(symb->as->rank));
290
291 if (symb->attr.pointer) return int_size_in_bytes(pchar_type_node);
292
293 element_size = int_size_in_bytes(g95_typenode_for_spec(&symb->ts));
294 if (symb->as == NULL) return element_size;
4c6fcac 7/28
andyv authored
295
ce769c2 3/17
andyv authored
296 /* Calculate the number of elements in the array */
297
298 if (g95_array_spec_size(symb->as, &elements) == FAILURE)
299 g95_internal_error("calculate_length(): Unable to determine array size");
300
301 m = mpz_get_ui(elements);
302 mpz_clear(elements);
303
304 return m*element_size;;
305 }
306
307
308
309
310 /* check_init()-- If the given symbol is initialized, record the fact. */
4c6fcac 7/28
andyv authored
311
ce769c2 3/17
andyv authored
312 static void check_init(g95_symbol *symb) {
313
314 if (symb->value != NULL || symb->attr.data)
315 seen_init = 1;
316 }
4c6fcac 7/28
andyv authored
317
ce769c2 3/17
andyv authored
318
319
4c6fcac 7/28
andyv authored
320
ce769c2 3/17
andyv authored
321 /* common_identifier()-- Given a common name, return an identifier for it. */
322
323 static tree common_identifier(char *nam) {
324 g95_symbol s;
325
326 if (nam == NULL)
327 return get_identifier(BLANK_COMMON_NAME);
328
329 memset(&s, '\0', sizeof(s));
330 strcpy(s.name, nam);
331
332 s.attr.flavor = FL_BLOCK_DATA; /* A global name */
333
334 return g95_sym_identifier(&s, NULL);
335 }
4c6fcac 7/28
andyv authored
336
337
338
339
ce769c2 3/17
andyv authored
340 /* unmark_equivalences()-- Given a namespace, mark all of the
341 * equivalences as unused. */
4c6fcac 7/28
andyv authored
342
ce769c2 3/17
andyv authored
343 static void unmark_equivalences(g95_namespace *names) {
344 g95_equiv *v, *d;
4c6fcac 7/28
andyv authored
345
ce769c2 3/17
andyv authored
346 for(v=names->equiv; v; v=v->next)
347 for(d=v; d; d=d->eq)
348 d->used = 0;
349 }
350
351
4c6fcac 7/28
andyv authored
352
353
ce769c2 3/17
andyv authored
354 /* sort_common()-- Sort the current_common list so that all of the
355 * nodes are in order of ascending offsets. */
356
357 static void sort_common(void) {
358 segment_info *t, **w;
359 int h, f;
4c6fcac 7/28
andyv authored
360
ce769c2 3/17
andyv authored
361 if (current_common == NULL) return;
4c6fcac 7/28
andyv authored
362
ce769c2 3/17
andyv authored
363 f = 0;
364 t = current_common;
365 while(t != NULL) {
366 t = t->next;
367 f++;
368 }
369
370 w = g95_getmem(f*sizeof(segment_info *));
4c6fcac 7/28
andyv authored
371
ce769c2 3/17
andyv authored
372 t = current_common;
373 for(h=0; h<f; h++) {
374 w[h] = t;
375 t = t->next;
376 }
377
378 qsort(w, f, sizeof(segment_info *), seg_compare);
4c6fcac 7/28
andyv authored
379
ce769c2 3/17
andyv authored
380 current_common = w[0];
381
382 for(h=0; h<f-1; h++)
383 w[h]->next = w[h+1];
384
385 w[f-1]->next = NULL;
386
387 g95_free(w);
388 }
389
390
4c6fcac 7/28
andyv authored
391
392
393 /* confirm_condition()-- Given two equivalence structures that are
394 * both already in the list, make sure that this new condition is not
ce769c2 3/17
andyv authored
395 * violated, generating an error if it is. */
396
397 static void confirm_condition(segment_info *d, g95_equiv *eq0,
398 segment_info *w, g95_equiv *eq2) {
399 int offset1, offset2;
4c6fcac 7/28
andyv authored
400
ce769c2 3/17
andyv authored
401 offset1 = calculate_offset(eq0->expr);
402 offset2 = calculate_offset(eq2->expr);
403
404 if (d->offset + offset1 != w->offset + offset2)
405 equivalence_conflict(d->sym->name, eq0, d->offset + offset1,
406 w->offset + offset2);
407 }
4c6fcac 7/28
andyv authored
408
ce769c2 3/17
andyv authored
409
410
411
412 /* build_common_vars()-- Given a common block, create the declarations
413 * for those variables, which consists of an offset into the common block. */
4c6fcac 7/28
andyv authored
414
ce769c2 3/17
andyv authored
415 static void build_common_vars(tree block) {
416 tree o, dtype, d, storage;
417 variable_info info;
418 segment_info *w;
4c6fcac 7/28
andyv authored
419
ce769c2 3/17
andyv authored
420 block = build1(ADDR_EXPR, pchar_type_node, block);
421
422 for(w=current_common; w; w=w->next) {
423 o = build_int_2(w->offset, 0);
424
425 g95_symbol_vinfo(w->sym, &info);
426 dtype = g95_get_descriptor(&info);
427
428 if (info.as == NULL || info.pointer) {
429 dtype = build_pointer_type(dtype);
430 w->sym->backend_decl = build(PLUS_EXPR, dtype, block, o);
431 } else {
432 g95_get_storage(&info); /* Create the descriptor */
433 d = build_decl(VAR_DECL, g95_sym_identifier(w->sym, NULL), dtype);
434 info.desc = d;
435
436 if (g95_module_symbol(w->sym)) {
437 TREE_ADDRESSABLE(d) = 1;
438 TREE_STATIC(d) = 1;
439 }
440
441 storage = build(PLUS_EXPR, pchar_type_node, block, o);
442 g95_init_descriptor(&info, d, storage);
443
444 w->sym->backend_decl = d;
445 pushdecl(d);
446 }
447 }
448 }
449
450
451
452
453 /* blank_block()-- Declare a blank character array that will hold a
454 * common that is uninitialized at least in the current source file. */
455
456 static tree blank_block(tree identifier, int leng) {
457 tree dec, tmp1;
458
459 tmp1 = build_int_2(leng, 0);
460 tmp1 = build_range_type(g95_default_integer, integer_one_node, tmp1);
461 tmp1 = build_array_type(g95_character1_type_node, tmp1);
462
463 dec = build_decl(VAR_DECL, identifier, tmp1);
4c6fcac 7/28
andyv authored
464
ce769c2 3/17
andyv authored
465 TREE_PUBLIC(dec) = 1;
466 TREE_STATIC(dec) = 1;
467 DECL_COMMON(dec) = 1;
468
469 pushdecl(dec);
470 rest_of_decl_compilation(dec, NULL, 1, 0);
4c6fcac 7/28
andyv authored
471
ce769c2 3/17
andyv authored
472 return dec;
473 }
474
475
476
477
4c6fcac 7/28
andyv authored
478 /* find_equivalence()-- Given a symbol, search through the equivalence
479 * lists for an unused condition that involves the symbol. If a rule
480 * is found, we return nonzero, the rule is marked as used and the eq1
ce769c2 3/17
andyv authored
481 * and eq2 pointers point to the rule. */
482
483 static int find_equivalence(g95_symbol *symb, g95_equiv **q, g95_equiv **eq2){
484 g95_equiv *u, *z;
485
486 for(u=symb->ns->equiv; u; u=u->next)
487 for(z=u->eq; z; z=z->eq) {
488 if (z->used) continue;
489
490 if (u->expr->symbol == symb || z->expr->symbol == symb) {
491 *q = u;
492 *eq2 = z;
493
494 check_init(u->expr->symbol);
495 check_init(z->expr->symbol);
496 return 1;
497 }
498 }
4c6fcac 7/28
andyv authored
499
ce769c2 3/17
andyv authored
500 return 0;
501 }
502
503
4c6fcac 7/28
andyv authored
504
ce769c2 3/17
andyv authored
505
506 /* free_current_common()-- Free the list of segments. */
507
508 static void free_current_common(void) {
509 segment_info *n;
510
511 while(current_common != NULL) {
512 n = current_common->next;
513 g95_free(current_common);
514 current_common = n;
515 }
516 }
4c6fcac 7/28
andyv authored
517
518
ce769c2 3/17
andyv authored
519
520
521 /* build_uninitialized_common()-- Traverse the global symbol tree
522 * looking for uninitialized common blocks. Create these as character
523 * arrays of the correct size. */
524
525 static void build_uninitialized_common(g95_gsymbol *t) {
526 tree identifier;
527
528 if (t == NULL) return;
529
530 build_uninitialized_common(t->left);
531 build_uninitialized_common(t->right);
532
533 if (t->type == GSYM_COMMON && t->backend_decl == NULL_TREE) {
534 identifier = common_identifier(t->name);
535 t->backend_decl = blank_block(identifier, t->size);
536 }
537 }
538
539
540
541
542 /* new_condition()-- Add a new segment_info structure to the current
543 * eq1 is already in the list at s1, eq2 is not. */
544
545 static void new_condition(segment_info *o, g95_equiv *q, g95_equiv *eq0) {
546 int offset1, offset2;
547 segment_info *r;
548
549 offset1 = calculate_offset(q->expr);
550 offset2 = calculate_offset(eq0->expr);
551
552 r = get_segment_info();
553
554 r->sym = eq0->expr->symbol;
555 r->offset = o->offset + offset1 - offset2;
556 r->length = calculate_length(eq0->expr->symbol);
557 r->rule = q;
558
559 r->next = current_segment;
560 current_segment = r;
561
562 if (real_common && r->offset < 0)
563 g95_error("EQUIVALENCE involving '%s' at %L caused the storage block "
564 "to be extended before the first variable", o->sym->name,
565 &q->expr->where);
566 }
567
568
569
570
571 /* add_condition()-- At this point we have a new equivalence condition
572 * to process. If both variables are already present, then we are
573 * confirming that the condition holds. Otherwise we are adding a new
574 * variable to the segment list. */
575
576 static void add_condition(g95_equiv *q, g95_equiv *eq2) {
577 segment_info *t, *v;
578
579 eq2->used = 1;
580
581 t = find_segment_info(q->expr->symbol);
582 v = find_segment_info(eq2->expr->symbol);
583
584 if (t == NULL && v == NULL) abort(); /* Can't happen */
585 if (t != NULL && v == NULL) new_condition(t, q, eq2);
586 if (t == NULL && v != NULL) new_condition(v, eq2, q);
587 if (t != NULL && v != NULL) confirm_condition(t, q, v, eq2);
588 }
589
590
591
592
4c6fcac 7/28
andyv authored
593 /* add_equivalences()-- Function for adding symbols to current
594 * segment. Returns zero if the segment was modified. Equivalence
595 * rules are considered to be between the first expression in the list
596 * and each of the other expressions in the list. Symbols are scanned
ce769c2 3/17
andyv authored
597 * multiple times because a symbol can be equivalenced more than once. */
598
599 static int add_equivalences(void) {
600 int segment_modified;
601 g95_equiv *eq1, *q;
602 segment_info *e;
603
604 segment_modified = 0;
605
606 for(e=current_segment; e; e=e->next)
607 if (find_equivalence(e->sym, &eq1, &q)) break;
608
609 if (e != NULL) {
610 add_condition(eq1, q);
611 segment_modified = 1;
612 }
613
614 return segment_modified;
615 }
616
617
618
619
620 /* new_segment()-- Given a seed symbol, create a new segment
621 * consisting of that symbol and all of the symbols equivalenced with
622 * that symbol. In a real common, the seed symbols are placed next to
623 * one another, causing equivalenced symbols to possible overlap in
624 * various ways. In an equivalence common, the segments do not
625 * overlap. */
626
627 static void new_segment(g95_symbol *symb) {
628 int o, seg_start, seg_end;
629 segment_info *c;
630
631 check_init(symb);
632
633 for(c=current_common; c; c=c->next)
634 if (c->sym == symb) break;
4c6fcac 7/28
andyv authored
635
ce769c2 3/17
andyv authored
636 /* If the current symbol is already in the common, make sure the
637 * offset is correct. Any equivalances to this symbol have already
638 * been processed in that case. */
4c6fcac 7/28
andyv authored
639
ce769c2 3/17
andyv authored
640 if (c != NULL) {
641 if (c->offset != common_length)
642 equivalence_conflict(c->sym->name, c->rule, c->offset, common_length);
643
644 common_length += c->length;
645 } else { /* New symbol */
646 current_segment = c = get_segment_info();
647 current_segment->sym = symb;
648 current_segment->offset = common_length;
649 current_segment->length = calculate_length(symb);
4c6fcac 7/28
andyv authored
650
ce769c2 3/17
andyv authored
651 while(add_equivalences());
652
653 if (real_common)
654 common_length += c->length;
655 else {
656 seg_start = current_segment->offset;
657 seg_end = current_segment->offset + current_segment->length;
658
659 for(c=current_segment->next; c; c=c->next) {
660 if (c->offset < seg_start) seg_start = c->offset;
661
662 o = c->offset + c->length;
663 if (o > seg_end) seg_end = o;
664 }
665
666 /* Translate the segment to the right place. */
667
668 o = common_length - seg_start;
669 for(c=current_segment; c; c=c->next)
670 c->offset += o;
671
672 common_length += seg_end - seg_start;
673 }
674
675 /* Append the current segment to the current common */
676
677 c = current_segment;
678 while(c->next != NULL)
679 c = c->next;
680
681 c->next = current_common;
682 current_common = current_segment;
683 current_segment = NULL;
684 }
685 }
686
687
688
689
690 /* traverse_common()-- Traverse a single common block, figuring out
691 * where each element is located. */
692
693 static void traverse_common(g95_common_head *common) {
694 g95_symbol *symb;
695 segment_info *a;
696 int w;
697
698 current_common = NULL;
699 common_length = 0;
700 real_common = 1;
701 seen_init = 0;
702
703 for(symb=common->head; symb; symb=symb->common_next)
704 new_segment(symb);
705
706 if (!real_common) { /* shift things to a zero offset */
707 w = 0;
708 for(a=current_common; a; a=a->next)
709 if (a->offset < w) w = a->offset;
710
711 w = -w;
712 for(a=current_common; a; a=a->next)
713 a->offset += w;
4c6fcac 7/28
andyv authored
714 }
715
ce769c2 3/17
andyv authored
716 /* Figure out the real length of the common block. It may have been
717 * extended by an equivalence. */
718
719 for(a=current_common; a; a=a->next) {
720 w = a->offset + a->length;
721 if (w > common_length) common_length = w;
722 }
4c6fcac 7/28
andyv authored
723 }
724
725
ce769c2 3/17
andyv authored
726
727
728 /* build_common_decl()-- Declare memory for an initialized common
729 * block and create declarations for all of the elements. */
730
731 static tree build_common_decl(tree identifier) {
732 tree dec, initial_value;
733 segment_info *i;
734 int scalar;
735
736 sort_common();
737 g95_start_common();
738
739 for(i=current_common; i; i=i->next)
740 g95_init_common_var(i->sym, i->offset);
741
742 scalar = current_common == NULL ||
743 (current_common->next == NULL &&
744 current_common->sym->as == NULL);
745
746 initial_value = g95_data_initializer(scalar);
747 dec = build_decl(VAR_DECL, identifier, TREE_TYPE(initial_value));
748
749 TREE_PUBLIC(dec) = 1;
750 TREE_STATIC(dec) = 1;
751 DECL_COMMON(dec) = 1;
752
753 DECL_INITIAL(dec) = initial_value;
4c6fcac 7/28
andyv authored
754
ce769c2 3/17
andyv authored
755 pushdecl(dec);
756 rest_of_decl_compilation(dec, NULL, 1, 0);
757
758 return dec;
759 }
4c6fcac 7/28
andyv authored
760
ce769c2 3/17
andyv authored
761
762
763
764 /* trans_common()-- Work function for translating a named common block. */
765
766 static void trans_common(g95_symtree *s) {
767 g95_gsymbol *v;
768
769 if (s == NULL) return;
4c6fcac 7/28
andyv authored
770
ce769c2 3/17
andyv authored
771 trans_common(s->left);
772 trans_common(s->right);
4c6fcac 7/28
andyv authored
773
ce769c2 3/17
andyv authored
774 traverse_common(s->n.common);
775
776 v = g95_find_gsymbol(g95_gsym_root, s->name);
777 build_common_vars(v->backend_decl);
778
779 free_current_common();
780 }
781
782
783
784
785 /* finish_equivalences()-- Create a new block that contains all
786 * remaining equivalences. We just add symbols until no rules are
787 * left. */
788
789 static void finish_equivalences(g95_namespace *namesp) {
790 tree identifier, d;
791 g95_equiv *k, *t;
792
793 current_common = NULL;
794 common_length = 0;
795 real_common = 0;
796 seen_init = 0;
4c6fcac 7/28
andyv authored
797
ce769c2 3/17
andyv authored
798 for(k=namesp->equiv; k; k=k->next)
799 for(t=k->eq; t; t=t->eq) {
800 if (t->used) continue;
4c6fcac 7/28
andyv authored
801
ce769c2 3/17
andyv authored
802 new_segment(k->expr->symbol);
803 break;
804 }
4c6fcac 7/28
andyv authored
805
ce769c2 3/17
andyv authored
806 if (current_common != NULL) {
807 identifier = g95_unique_identifier("equiv.common");
808
809 d = (seen_init)
810 ? build_common_decl(identifier)
811 : blank_block(identifier, common_length);
812
813 build_common_vars(d);
814 free_current_common();
815 }
4c6fcac 7/28
andyv authored
816 }
817
818
ce769c2 3/17
andyv authored
819
820
821 /* init_black_common()-- See about initializing the blank common if it
822 * is initialized. */
4c6fcac 7/28
andyv authored
823
ce769c2 3/17
andyv authored
824 static void init_blank_common(g95_common_head *common) {
825
826 if (common->head == NULL) return;
827 blank_common_seen = 1;
828
829 traverse_common(common);
830
831 if (blank_common_length < common_length)
832 blank_common_length = common_length;
4c6fcac 7/28
andyv authored
833
ce769c2 3/17
andyv authored
834 if (seen_init) {
835 if (blank_common_decl != NULL_TREE)
836 g95_error("Blank common at %L is initialized in another program unit",
837 &blank_common_locus);
838 else {
839 blank_common_decl = build_common_decl(common_identifier(NULL));
840 blank_common_locus = common->where;
841 }
842 }
843
844 free_current_common();
845 }
846
847
848
849
850 /* g95_trans_common()-- Create common variables within a namespace.
851 * Unlike other variables, these have to be created before code,
852 * because the backend_decl depends on the rest of the common
853 * block. */
4c6fcac 7/28
andyv authored
854
ce769c2 3/17
andyv authored
855 void g95_trans_common(g95_namespace *namesp) {
4c6fcac 7/28
andyv authored
856
ce769c2 3/17
andyv authored
857 unmark_equivalences(namesp);
858
859 if (namesp->blank_common.head != NULL) {
860 traverse_common(&namesp->blank_common);
861 build_common_vars(blank_common_decl);
862 free_current_common();
863 }
864
865 trans_common(namesp->common_root);
866
867 finish_equivalences(namesp);
4c6fcac 7/28
andyv authored
868 }
869
870
ce769c2 3/17
andyv authored
871
872
873 /* init_common()-- Figure out how big a particular common is, make
874 * sure the size is consistent and initialize a block if necessary. */
875
876 static void init_common(g95_symtree *sta) {
877 g95_common_head *common;
878 g95_gsymbol *e;
879 char *name0;
880
881 common = sta->n.common;
882 name0 = sta->name;
4c6fcac 7/28
andyv authored
883
ce769c2 3/17
andyv authored
884 traverse_common(sta->n.common);
885 e = g95_get_gsymbol(name0);
4c6fcac 7/28
andyv authored
886
ce769c2 3/17
andyv authored
887 switch(e->type) {
888 case GSYM_UNKNOWN:
889 e->type = GSYM_COMMON;
890 e->size = common_length;
891 e->where = common->where;
892 break;
893
894 case GSYM_COMMON:
895 if (e->size != common_length && strcmp(name0, BLANK_COMMON_NAME) != 0) {
896 g95_warning(121, "COMMON block '%s' is %d bytes at %L and %d bytes "
897 "at %L", name0, common_length, &common->where, e->size,
898 &e->where);
4c6fcac 7/28
andyv authored
899
ce769c2 3/17
andyv authored
900 if (common_length > e->size)
901 e->size = common_length;
902 }
903
904 break;
4c6fcac 7/28
andyv authored
905
ce769c2 3/17
andyv authored
906 default:
907 g95_global_used(e, &common->where);
908 e = NULL;
909 goto done;
910 }
4c6fcac 7/28
andyv authored
911
ce769c2 3/17
andyv authored
912 /* If the common is initialized, declare it now */
913
914 if (seen_init) {
915 if (e->backend_decl == NULL_TREE)
916 e->backend_decl = build_common_decl(common_identifier(name0));
917 else
918 g95_error("COMMON block '%s' at %L is initialized in another program "
919 "unit", &common->where, name0);
920 }
4c6fcac 7/28
andyv authored
921
ce769c2 3/17
andyv authored
922 done:
923 free_current_common();
924 }
925
926
927
928
929 /* init_common0()-- Traverse all common blocks within a namespace,
930 * figuring out how large each block is, and taking care of an
931 * initialization if present. */
4c6fcac 7/28
andyv authored
932
ce769c2 3/17
andyv authored
933 static void init_common0(g95_symtree *st) {
4c6fcac 7/28
andyv authored
934
ce769c2 3/17
andyv authored
935 if (st == NULL) return;
936
937 init_common0(st->left);
938 init_common0(st->right);
939
940 init_common(st);
941 }
942
943
944
945
946 /* init_common1()-- Traverse namespaces. */
4c6fcac 7/28
andyv authored
947
ce769c2 3/17
andyv authored
948 static void init_common1(g95_namespace *n) {
4c6fcac 7/28
andyv authored
949
ce769c2 3/17
andyv authored
950 if (n == NULL) return;
951
952 while(n != NULL) {
953 init_blank_common(&n->blank_common);
954
955 unmark_equivalences(n);
956 init_common0(n->common_root);
957 init_common1(n->contained);
958
959 n = n->sibling;
960 }
961 }
962
963
964
965
966 /* g95_init_common()-- Recursively scan all common blocks in all
967 * namespaces. Build up the sizes of common blocks, and
968 * initializations. */
969
970 void g95_init_common(g95_namespace *ns) {
971 tree identifier;
4c6fcac 7/28
andyv authored
972
ce769c2 3/17
andyv authored
973 init_common1(ns);
974 build_uninitialized_common(g95_gsym_root);
975
976 if (blank_common_seen && blank_common_decl == NULL_TREE) {
977 identifier = common_identifier(NULL);
978 blank_common_decl = blank_block(identifier, blank_common_length);
979 }
980 }
Something went wrong with that request. Please try again.