* sh.c (prepare_move_operand): Check if operand 0 is an invalid
[official-gcc.git] / gcc / f / global.c
blob73c6ec50cb35c13a699548ba5089574b42acb954
1 /* global.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1997, 2003 Free Software Foundation, Inc.
3 Contributed by James Craig Burley.
5 This file is part of GNU Fortran.
7 GNU Fortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
12 GNU Fortran 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 General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Fortran; see the file COPYING. If not, write to
19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
20 02111-1307, USA.
22 Related Modules:
24 Description:
25 Manages information kept across individual program units within a single
26 source file. This includes reporting errors when a name is defined
27 multiple times (for example, two program units named FOO) and when a
28 COMMON block is given initial data in more than one program unit.
30 Modifications:
33 /* Include files. */
35 #include "proj.h"
36 #include "global.h"
37 #include "info.h"
38 #include "lex.h"
39 #include "malloc.h"
40 #include "name.h"
41 #include "symbol.h"
42 #include "top.h"
44 /* Externals defined here. */
47 /* Simple definitions and enumerations. */
50 /* Internal typedefs. */
53 /* Private include files. */
56 /* Internal structure definitions. */
59 /* Static objects accessed by functions in this module. */
61 #if FFEGLOBAL_ENABLED
62 static ffenameSpace ffeglobal_filewide_ = NULL;
63 static const char *const ffeglobal_type_string_[] =
65 [FFEGLOBAL_typeNONE] "??",
66 [FFEGLOBAL_typeMAIN] "main program",
67 [FFEGLOBAL_typeEXT] "external",
68 [FFEGLOBAL_typeSUBR] "subroutine",
69 [FFEGLOBAL_typeFUNC] "function",
70 [FFEGLOBAL_typeBDATA] "block data",
71 [FFEGLOBAL_typeCOMMON] "common block",
72 [FFEGLOBAL_typeANY] "?any?"
74 #endif
76 /* Static functions (internal). */
79 /* Internal macros. */
82 /* Call given fn with all globals
84 ffeglobal (*fn)(ffeglobal g);
85 ffeglobal_drive(fn); */
87 #if FFEGLOBAL_ENABLED
88 void
89 ffeglobal_drive (ffeglobal (*fn) (ffeglobal))
91 if (ffeglobal_filewide_ != NULL)
92 ffename_space_drive_global (ffeglobal_filewide_, fn);
95 #endif
96 /* ffeglobal_new_ -- Make new global
98 ffename n;
99 ffeglobal g;
100 g = ffeglobal_new_(n); */
102 #if FFEGLOBAL_ENABLED
103 static ffeglobal
104 ffeglobal_new_ (ffename n)
106 ffeglobal g;
108 assert (n != NULL);
110 g = (ffeglobal) malloc_new_ks (malloc_pool_image (), "FFEGLOBAL",
111 sizeof (*g));
112 g->n = n;
113 g->hook = FFECOM_globalNULL;
114 g->tick = 0;
116 ffename_set_global (n, g);
118 return g;
121 #endif
122 /* ffeglobal_init_1 -- Initialize per file
124 ffeglobal_init_1(); */
126 void
127 ffeglobal_init_1 ()
129 #if FFEGLOBAL_ENABLED
130 if (ffeglobal_filewide_ != NULL)
131 ffename_space_kill (ffeglobal_filewide_);
132 ffeglobal_filewide_ = ffename_space_new (malloc_pool_image ());
133 #endif
136 /* ffeglobal_init_common -- Initial value specified for common block
138 ffesymbol s; // the ffesymbol for the common block
139 ffelexToken t; // the token with the point of initialization
140 ffeglobal_init_common(s,t);
142 For back ends where file-wide global symbols are not maintained, does
143 nothing. Otherwise, makes sure this common block hasn't already been
144 initialized in a previous program unit, and flag that it's been
145 initialized in this one. */
147 void
148 ffeglobal_init_common (ffesymbol s, ffelexToken t)
150 #if FFEGLOBAL_ENABLED
151 ffeglobal g;
153 g = ffesymbol_global (s);
155 if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON))
156 return;
157 if (g->type == FFEGLOBAL_typeANY)
158 return;
160 if (g->tick == ffe_count_2)
161 return;
163 if (g->tick != 0)
165 if (g->u.common.initt != NULL)
167 ffebad_start (FFEBAD_COMMON_ALREADY_INIT);
168 ffebad_string (ffesymbol_text (s));
169 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
170 ffebad_here (1, ffelex_token_where_line (g->u.common.initt),
171 ffelex_token_where_column (g->u.common.initt));
172 ffebad_finish ();
175 /* Complain about just one attempt to reinit per program unit, but
176 continue referring back to the first such successful attempt. */
178 else
180 if (g->u.common.blank)
182 /* Not supposed to initialize blank common, though it works. */
183 ffebad_start (FFEBAD_COMMON_BLANK_INIT);
184 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
185 ffebad_finish ();
188 g->u.common.initt = ffelex_token_use (t);
191 g->tick = ffe_count_2;
192 #endif
195 /* ffeglobal_new_common -- New common block
197 ffesymbol s; // the ffesymbol for the new common block
198 ffelexToken t; // the token with the name of the common block
199 bool blank; // TRUE if blank common
200 ffeglobal_new_common(s,t,blank);
202 For back ends where file-wide global symbols are not maintained, does
203 nothing. Otherwise, makes sure this symbol hasn't been seen before or
204 is known as a common block. */
206 void
207 ffeglobal_new_common (ffesymbol s, ffelexToken t, bool blank)
209 #if FFEGLOBAL_ENABLED
210 ffename n;
211 ffeglobal g;
213 if (ffesymbol_global (s) == NULL)
215 n = ffename_find (ffeglobal_filewide_, t);
216 g = ffename_global (n);
218 else
220 g = ffesymbol_global (s);
221 n = NULL;
224 if ((g != NULL) && (g->type == FFEGLOBAL_typeANY))
225 return;
227 if ((g != NULL) && (g->type != FFEGLOBAL_typeNONE))
229 if (g->type == FFEGLOBAL_typeCOMMON)
231 /* The names match, so the "blankness" should match too! */
232 assert (g->u.common.blank == blank);
234 else
236 /* This global name has already been established,
237 but as something other than a common block. */
238 if (ffe_is_globals () || ffe_is_warn_globals ())
240 ffebad_start (ffe_is_globals ()
241 ? FFEBAD_FILEWIDE_ALREADY_SEEN
242 : FFEBAD_FILEWIDE_ALREADY_SEEN_W);
243 ffebad_string (ffelex_token_text (t));
244 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
245 ffebad_here (1, ffelex_token_where_line (g->t),
246 ffelex_token_where_column (g->t));
247 ffebad_finish ();
249 g->type = FFEGLOBAL_typeANY;
252 else
254 if (g == NULL)
256 g = ffeglobal_new_ (n);
257 g->intrinsic = FALSE;
259 else if (g->intrinsic
260 && !g->explicit_intrinsic
261 && ffe_is_warn_globals ())
263 /* Common name previously used as intrinsic. Though it works,
264 warn, because the intrinsic reference might have been intended
265 as a ref to an external procedure, but g77's vast list of
266 intrinsics happened to snarf the name. */
267 ffebad_start (FFEBAD_INTRINSIC_GLOBAL);
268 ffebad_string (ffelex_token_text (t));
269 ffebad_string ("common block");
270 ffebad_string ("intrinsic");
271 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
272 ffebad_here (1, ffelex_token_where_line (g->t),
273 ffelex_token_where_column (g->t));
274 ffebad_finish ();
276 g->t = ffelex_token_use (t);
277 g->type = FFEGLOBAL_typeCOMMON;
278 g->u.common.have_pad = FALSE;
279 g->u.common.have_save = FALSE;
280 g->u.common.have_size = FALSE;
281 g->u.common.blank = blank;
284 ffesymbol_set_global (s, g);
285 #endif
288 /* ffeglobal_new_progunit_ -- New program unit
290 ffesymbol s; // the ffesymbol for the new unit
291 ffelexToken t; // the token with the name of the unit
292 ffeglobalType type; // the type of the new unit
293 ffeglobal_new_progunit_(s,t,type);
295 For back ends where file-wide global symbols are not maintained, does
296 nothing. Otherwise, makes sure this symbol hasn't been seen before. */
298 void
299 ffeglobal_new_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type)
301 #if FFEGLOBAL_ENABLED
302 ffename n;
303 ffeglobal g;
305 n = ffename_find (ffeglobal_filewide_, t);
306 g = ffename_global (n);
307 if ((g != NULL) && (g->type == FFEGLOBAL_typeANY))
308 return;
310 if ((g != NULL)
311 && ((g->type == FFEGLOBAL_typeMAIN)
312 || (g->type == FFEGLOBAL_typeSUBR)
313 || (g->type == FFEGLOBAL_typeFUNC)
314 || (g->type == FFEGLOBAL_typeBDATA))
315 && g->u.proc.defined)
317 /* This program unit has already been defined. */
318 if (ffe_is_globals () || ffe_is_warn_globals ())
320 ffebad_start (ffe_is_globals ()
321 ? FFEBAD_FILEWIDE_ALREADY_SEEN
322 : FFEBAD_FILEWIDE_ALREADY_SEEN_W);
323 ffebad_string (ffelex_token_text (t));
324 ffebad_here (0, ffelex_token_where_line (t),
325 ffelex_token_where_column (t));
326 ffebad_here (1, ffelex_token_where_line (g->t),
327 ffelex_token_where_column (g->t));
328 ffebad_finish ();
330 g->type = FFEGLOBAL_typeANY;
332 else if ((g != NULL)
333 && (g->type != FFEGLOBAL_typeNONE)
334 && (g->type != FFEGLOBAL_typeEXT)
335 && (g->type != type))
337 /* A reference to this program unit has been seen, but its
338 context disagrees about the new definition regarding
339 what kind of program unit it is. (E.g. `call foo' followed
340 by `function foo'.) But `external foo' alone doesn't mean
341 disagreement with either a function or subroutine, though
342 g77 normally interprets it as a request to force-load
343 a block data program unit by that name (to cope with libs). */
344 if (ffe_is_globals () || ffe_is_warn_globals ())
346 ffebad_start (ffe_is_globals ()
347 ? FFEBAD_FILEWIDE_DISAGREEMENT
348 : FFEBAD_FILEWIDE_DISAGREEMENT_W);
349 ffebad_string (ffelex_token_text (t));
350 ffebad_string (ffeglobal_type_string_[type]);
351 ffebad_string (ffeglobal_type_string_[g->type]);
352 ffebad_here (0, ffelex_token_where_line (t),
353 ffelex_token_where_column (t));
354 ffebad_here (1, ffelex_token_where_line (g->t),
355 ffelex_token_where_column (g->t));
356 ffebad_finish ();
358 g->type = FFEGLOBAL_typeANY;
360 else
362 if (g == NULL)
364 g = ffeglobal_new_ (n);
365 g->intrinsic = FALSE;
366 g->u.proc.n_args = -1;
367 g->u.proc.other_t = NULL;
369 else if ((ffesymbol_basictype (s) != FFEINFO_basictypeNONE)
370 && (g->type == FFEGLOBAL_typeFUNC)
371 && ((ffesymbol_basictype (s) != g->u.proc.bt)
372 || (ffesymbol_kindtype (s) != g->u.proc.kt)
373 || ((ffesymbol_size (s) != FFETARGET_charactersizeNONE)
374 && (ffesymbol_size (s) != g->u.proc.sz))))
376 /* The previous reference and this new function definition
377 disagree about the type of the function. I (Burley) think
378 this rarely occurs, because when this code is reached,
379 the type info doesn't appear to be filled in yet. */
380 if (ffe_is_globals () || ffe_is_warn_globals ())
382 ffebad_start (ffe_is_globals ()
383 ? FFEBAD_FILEWIDE_TYPE_MISMATCH
384 : FFEBAD_FILEWIDE_TYPE_MISMATCH_W);
385 ffebad_string (ffelex_token_text (t));
386 ffebad_here (0, ffelex_token_where_line (t),
387 ffelex_token_where_column (t));
388 ffebad_here (1, ffelex_token_where_line (g->t),
389 ffelex_token_where_column (g->t));
390 ffebad_finish ();
392 g->type = FFEGLOBAL_typeANY;
393 return;
395 if (g->intrinsic
396 && !g->explicit_intrinsic
397 && ffe_is_warn_globals ())
399 /* This name, previously used as an intrinsic, now is known
400 to also be a global procedure name. Warn, since the previous
401 use as an intrinsic might have been intended to refer to
402 this procedure. */
403 ffebad_start (FFEBAD_INTRINSIC_GLOBAL);
404 ffebad_string (ffelex_token_text (t));
405 ffebad_string ("global");
406 ffebad_string ("intrinsic");
407 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
408 ffebad_here (1, ffelex_token_where_line (g->t),
409 ffelex_token_where_column (g->t));
410 ffebad_finish ();
412 g->t = ffelex_token_use (t);
413 if ((g->tick == 0)
414 || (g->u.proc.bt == FFEINFO_basictypeNONE)
415 || (g->u.proc.kt == FFEINFO_kindtypeNONE))
417 g->u.proc.bt = ffesymbol_basictype (s);
418 g->u.proc.kt = ffesymbol_kindtype (s);
419 g->u.proc.sz = ffesymbol_size (s);
421 /* If there's a known disagreement about the kind of program
422 unit, then don't even bother tracking arglist argreement. */
423 if ((g->tick != 0)
424 && (g->type != type))
425 g->u.proc.n_args = -1;
426 g->tick = ffe_count_2;
427 g->type = type;
428 g->u.proc.defined = TRUE;
431 ffesymbol_set_global (s, g);
432 #endif
435 /* ffeglobal_pad_common -- Check initial padding of common area
437 ffesymbol s; // the common area
438 ffetargetAlign pad; // the initial padding
439 ffeglobal_pad_common(s,pad,ffesymbol_where_line(s),
440 ffesymbol_where_column(s));
442 In global-enabled mode, make sure the padding agrees with any existing
443 padding established for the common area, otherwise complain.
444 In global-disabled mode, warn about nonzero padding. */
446 void
447 ffeglobal_pad_common (ffesymbol s, ffetargetAlign pad, ffewhereLine wl,
448 ffewhereColumn wc)
450 #if FFEGLOBAL_ENABLED
451 ffeglobal g;
453 g = ffesymbol_global (s);
454 if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON))
455 return; /* Let someone else catch this! */
456 if (g->type == FFEGLOBAL_typeANY)
457 return;
459 if (!g->u.common.have_pad)
461 g->u.common.have_pad = TRUE;
462 g->u.common.pad = pad;
463 g->u.common.pad_where_line = ffewhere_line_use (wl);
464 g->u.common.pad_where_col = ffewhere_column_use (wc);
466 if (pad != 0)
468 char padding[20];
470 sprintf (&padding[0], "%" ffetargetAlign_f "u", pad);
471 ffebad_start (FFEBAD_COMMON_INIT_PAD);
472 ffebad_string (ffesymbol_text (s));
473 ffebad_string (padding);
474 ffebad_string ((pad == 1)
475 ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
476 ffebad_here (0, wl, wc);
477 ffebad_finish ();
480 else
482 if (g->u.common.pad != pad)
484 char padding_1[20];
485 char padding_2[20];
487 sprintf (&padding_1[0], "%" ffetargetAlign_f "u", pad);
488 sprintf (&padding_2[0], "%" ffetargetAlign_f "u", g->u.common.pad);
489 ffebad_start (FFEBAD_COMMON_DIFF_PAD);
490 ffebad_string (ffesymbol_text (s));
491 ffebad_string (padding_1);
492 ffebad_here (0, wl, wc);
493 ffebad_string (padding_2);
494 ffebad_string ((pad == 1)
495 ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
496 ffebad_string ((g->u.common.pad == 1)
497 ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
498 ffebad_here (1, g->u.common.pad_where_line, g->u.common.pad_where_col);
499 ffebad_finish ();
502 if (g->u.common.pad < pad)
504 g->u.common.pad = pad;
505 g->u.common.pad_where_line = ffewhere_line_use (wl);
506 g->u.common.pad_where_col = ffewhere_column_use (wc);
509 #endif
512 /* Collect info for a global's argument. */
514 void
515 ffeglobal_proc_def_arg (ffesymbol s, int argno, const char *name, ffeglobalArgSummary as,
516 ffeinfoBasictype bt, ffeinfoKindtype kt,
517 bool array)
519 ffeglobal g = ffesymbol_global (s);
520 ffeglobalArgInfo_ ai;
522 assert (g != NULL);
524 if (g->type == FFEGLOBAL_typeANY)
525 return;
527 assert (g->u.proc.n_args >= 0);
529 if (argno >= g->u.proc.n_args)
530 return; /* Already complained about this discrepancy. */
532 ai = &g->u.proc.arg_info[argno];
534 /* Maybe warn about previous references. */
536 if ((ai->t != NULL)
537 && ffe_is_warn_globals ())
539 const char *refwhy = NULL;
540 const char *defwhy = NULL;
541 bool warn = FALSE;
543 switch (as)
545 case FFEGLOBAL_argsummaryREF:
546 if ((ai->as != FFEGLOBAL_argsummaryREF)
547 && (ai->as != FFEGLOBAL_argsummaryNONE)
548 && ((ai->as != FFEGLOBAL_argsummaryDESCR) /* Choose better message. */
549 || (ai->bt != FFEINFO_basictypeCHARACTER)
550 || (ai->bt == bt)))
552 warn = TRUE;
553 refwhy = "passed by reference";
555 break;
557 case FFEGLOBAL_argsummaryDESCR:
558 if ((ai->as != FFEGLOBAL_argsummaryDESCR)
559 && (ai->as != FFEGLOBAL_argsummaryNONE)
560 && ((ai->as != FFEGLOBAL_argsummaryREF) /* Choose better message. */
561 || (bt != FFEINFO_basictypeCHARACTER)
562 || (ai->bt == bt)))
564 warn = TRUE;
565 refwhy = "passed by descriptor";
567 break;
569 case FFEGLOBAL_argsummaryPROC:
570 if ((ai->as != FFEGLOBAL_argsummaryPROC)
571 && (ai->as != FFEGLOBAL_argsummarySUBR)
572 && (ai->as != FFEGLOBAL_argsummaryFUNC)
573 && (ai->as != FFEGLOBAL_argsummaryNONE))
575 warn = TRUE;
576 refwhy = "a procedure";
578 break;
580 case FFEGLOBAL_argsummarySUBR:
581 if ((ai->as != FFEGLOBAL_argsummaryPROC)
582 && (ai->as != FFEGLOBAL_argsummarySUBR)
583 && (ai->as != FFEGLOBAL_argsummaryNONE))
585 warn = TRUE;
586 refwhy = "a subroutine";
588 break;
590 case FFEGLOBAL_argsummaryFUNC:
591 if ((ai->as != FFEGLOBAL_argsummaryPROC)
592 && (ai->as != FFEGLOBAL_argsummaryFUNC)
593 && (ai->as != FFEGLOBAL_argsummaryNONE))
595 warn = TRUE;
596 refwhy = "a function";
598 break;
600 case FFEGLOBAL_argsummaryALTRTN:
601 if ((ai->as != FFEGLOBAL_argsummaryALTRTN)
602 && (ai->as != FFEGLOBAL_argsummaryNONE))
604 warn = TRUE;
605 refwhy = "an alternate-return label";
607 break;
609 default:
610 break;
613 if ((refwhy != NULL) && (defwhy == NULL))
615 /* Fill in the def info. */
617 switch (ai->as)
619 case FFEGLOBAL_argsummaryNONE:
620 defwhy = "omitted";
621 break;
623 case FFEGLOBAL_argsummaryVAL:
624 defwhy = "passed by value";
625 break;
627 case FFEGLOBAL_argsummaryREF:
628 defwhy = "passed by reference";
629 break;
631 case FFEGLOBAL_argsummaryDESCR:
632 defwhy = "passed by descriptor";
633 break;
635 case FFEGLOBAL_argsummaryPROC:
636 defwhy = "a procedure";
637 break;
639 case FFEGLOBAL_argsummarySUBR:
640 defwhy = "a subroutine";
641 break;
643 case FFEGLOBAL_argsummaryFUNC:
644 defwhy = "a function";
645 break;
647 case FFEGLOBAL_argsummaryALTRTN:
648 defwhy = "an alternate-return label";
649 break;
651 #if 0
652 case FFEGLOBAL_argsummaryPTR:
653 defwhy = "a pointer";
654 break;
655 #endif
657 default:
658 defwhy = "???";
659 break;
663 if (!warn
664 && (bt != FFEINFO_basictypeHOLLERITH)
665 && (bt != FFEINFO_basictypeTYPELESS)
666 && (bt != FFEINFO_basictypeNONE)
667 && (ai->bt != FFEINFO_basictypeHOLLERITH)
668 && (ai->bt != FFEINFO_basictypeTYPELESS)
669 && (ai->bt != FFEINFO_basictypeNONE))
671 /* Check types. */
673 if ((bt != ai->bt)
674 && ((bt != FFEINFO_basictypeREAL)
675 || (ai->bt != FFEINFO_basictypeCOMPLEX))
676 && ((bt != FFEINFO_basictypeCOMPLEX)
677 || (ai->bt != FFEINFO_basictypeREAL)))
679 warn = TRUE; /* We can cope with these differences. */
680 refwhy = "one type";
681 defwhy = "some other type";
684 if (!warn && (kt != ai->kt))
686 warn = TRUE;
687 refwhy = "one precision";
688 defwhy = "some other precision";
692 if (warn)
694 char num[60];
696 if (name == NULL)
697 sprintf (&num[0], "%d", argno + 1);
698 else
700 if (strlen (name) < 30)
701 sprintf (&num[0], "%d (named `%s')", argno + 1, name);
702 else
703 sprintf (&num[0], "%d (named `%.*s...')", argno + 1, 30, name);
705 ffebad_start (FFEBAD_FILEWIDE_ARG_W);
706 ffebad_string (ffesymbol_text (s));
707 ffebad_string (num);
708 ffebad_string (refwhy);
709 ffebad_string (defwhy);
710 ffebad_here (0, ffelex_token_where_line (g->t), ffelex_token_where_column (g->t));
711 ffebad_here (1, ffelex_token_where_line (ai->t), ffelex_token_where_column (ai->t));
712 ffebad_finish ();
716 /* Define this argument. */
718 if (ai->t != NULL)
719 ffelex_token_kill (ai->t);
720 if ((as != FFEGLOBAL_argsummaryPROC)
721 || (ai->t == NULL))
722 ai->as = as; /* Otherwise leave SUBR/FUNC info intact. */
723 ai->t = ffelex_token_use (g->t);
724 if (name == NULL)
725 ai->name = NULL;
726 else
728 ai->name = malloc_new_ks (malloc_pool_image (),
729 "ffeglobalArgInfo_ name",
730 strlen (name) + 1);
731 strcpy (ai->name, name);
733 ai->bt = bt;
734 ai->kt = kt;
735 ai->array = array;
738 /* Collect info on #args a global accepts. */
740 void
741 ffeglobal_proc_def_nargs (ffesymbol s, int n_args)
743 ffeglobal g = ffesymbol_global (s);
745 assert (g != NULL);
747 if (g->type == FFEGLOBAL_typeANY)
748 return;
750 if (g->u.proc.n_args >= 0)
752 if (g->u.proc.n_args == n_args)
753 return;
755 if (ffe_is_warn_globals ())
757 ffebad_start (FFEBAD_FILEWIDE_NARGS_W);
758 ffebad_string (ffesymbol_text (s));
759 if (g->u.proc.n_args > n_args)
760 ffebad_string ("few");
761 else
762 ffebad_string ("many");
763 ffebad_here (0, ffelex_token_where_line (g->u.proc.other_t),
764 ffelex_token_where_column (g->u.proc.other_t));
765 ffebad_here (1, ffelex_token_where_line (g->t),
766 ffelex_token_where_column (g->t));
767 ffebad_finish ();
771 /* This is new info we can use in cross-checking future references
772 and a possible future definition. */
774 g->u.proc.n_args = n_args;
775 g->u.proc.other_t = NULL; /* No other reference yet. */
777 if (n_args == 0)
779 g->u.proc.arg_info = NULL;
780 return;
783 g->u.proc.arg_info
784 = (ffeglobalArgInfo_) malloc_new_ks (malloc_pool_image (),
785 "ffeglobalArgInfo_",
786 n_args * sizeof (g->u.proc.arg_info[0]));
787 while (n_args-- > 0)
788 g->u.proc.arg_info[n_args].t = NULL;
791 /* Verify that the info for a global's argument is valid. */
793 bool
794 ffeglobal_proc_ref_arg (ffesymbol s, int argno, ffeglobalArgSummary as,
795 ffeinfoBasictype bt, ffeinfoKindtype kt,
796 bool array, ffelexToken t)
798 ffeglobal g = ffesymbol_global (s);
799 ffeglobalArgInfo_ ai;
801 assert (g != NULL);
803 if (g->type == FFEGLOBAL_typeANY)
804 return FALSE;
806 assert (g->u.proc.n_args >= 0);
808 if (argno >= g->u.proc.n_args)
809 return TRUE; /* Already complained about this discrepancy. */
811 ai = &g->u.proc.arg_info[argno];
813 /* Warn about previous references. */
815 if (ai->t != NULL)
817 const char *refwhy = NULL;
818 const char *defwhy = NULL;
819 bool fail = FALSE;
820 bool warn = FALSE;
822 switch (as)
824 case FFEGLOBAL_argsummaryNONE:
825 if (g->u.proc.defined)
827 fail = TRUE;
828 refwhy = "omitted";
829 defwhy = "not optional";
831 break;
833 case FFEGLOBAL_argsummaryVAL:
834 if (ai->as != FFEGLOBAL_argsummaryVAL)
836 fail = TRUE;
837 refwhy = "passed by value";
839 break;
841 case FFEGLOBAL_argsummaryREF:
842 if ((ai->as != FFEGLOBAL_argsummaryREF)
843 && (ai->as != FFEGLOBAL_argsummaryNONE)
844 && ((ai->as != FFEGLOBAL_argsummaryDESCR) /* Choose better message. */
845 || (ai->bt != FFEINFO_basictypeCHARACTER)
846 || (ai->bt == bt)))
848 fail = TRUE;
849 refwhy = "passed by reference";
851 break;
853 case FFEGLOBAL_argsummaryDESCR:
854 if ((ai->as != FFEGLOBAL_argsummaryDESCR)
855 && (ai->as != FFEGLOBAL_argsummaryNONE)
856 && ((ai->as != FFEGLOBAL_argsummaryREF) /* Choose better message. */
857 || (bt != FFEINFO_basictypeCHARACTER)
858 || (ai->bt == bt)))
860 fail = TRUE;
861 refwhy = "passed by descriptor";
863 break;
865 case FFEGLOBAL_argsummaryPROC:
866 if ((ai->as != FFEGLOBAL_argsummaryPROC)
867 && (ai->as != FFEGLOBAL_argsummarySUBR)
868 && (ai->as != FFEGLOBAL_argsummaryFUNC)
869 && (ai->as != FFEGLOBAL_argsummaryNONE))
871 fail = TRUE;
872 refwhy = "a procedure";
874 break;
876 case FFEGLOBAL_argsummarySUBR:
877 if ((ai->as != FFEGLOBAL_argsummaryPROC)
878 && (ai->as != FFEGLOBAL_argsummarySUBR)
879 && (ai->as != FFEGLOBAL_argsummaryNONE))
881 fail = TRUE;
882 refwhy = "a subroutine";
884 break;
886 case FFEGLOBAL_argsummaryFUNC:
887 if ((ai->as != FFEGLOBAL_argsummaryPROC)
888 && (ai->as != FFEGLOBAL_argsummaryFUNC)
889 && (ai->as != FFEGLOBAL_argsummaryNONE))
891 fail = TRUE;
892 refwhy = "a function";
894 break;
896 case FFEGLOBAL_argsummaryALTRTN:
897 if ((ai->as != FFEGLOBAL_argsummaryALTRTN)
898 && (ai->as != FFEGLOBAL_argsummaryNONE))
900 fail = TRUE;
901 refwhy = "an alternate-return label";
903 break;
905 #if 0
906 case FFEGLOBAL_argsummaryPTR:
907 if ((ai->as != FFEGLOBAL_argsummaryPTR)
908 && (ai->as != FFEGLOBAL_argsummaryNONE))
910 fail = TRUE;
911 refwhy = "a pointer";
913 break;
914 #endif
916 default:
917 break;
920 if ((refwhy != NULL) && (defwhy == NULL))
922 /* Fill in the def info. */
924 switch (ai->as)
926 case FFEGLOBAL_argsummaryNONE:
927 defwhy = "omitted";
928 break;
930 case FFEGLOBAL_argsummaryVAL:
931 defwhy = "passed by value";
932 break;
934 case FFEGLOBAL_argsummaryREF:
935 defwhy = "passed by reference";
936 break;
938 case FFEGLOBAL_argsummaryDESCR:
939 defwhy = "passed by descriptor";
940 break;
942 case FFEGLOBAL_argsummaryPROC:
943 defwhy = "a procedure";
944 break;
946 case FFEGLOBAL_argsummarySUBR:
947 defwhy = "a subroutine";
948 break;
950 case FFEGLOBAL_argsummaryFUNC:
951 defwhy = "a function";
952 break;
954 case FFEGLOBAL_argsummaryALTRTN:
955 defwhy = "an alternate-return label";
956 break;
958 #if 0
959 case FFEGLOBAL_argsummaryPTR:
960 defwhy = "a pointer";
961 break;
962 #endif
964 default:
965 defwhy = "???";
966 break;
970 if (!fail && !warn
971 && (bt != FFEINFO_basictypeHOLLERITH)
972 && (bt != FFEINFO_basictypeTYPELESS)
973 && (bt != FFEINFO_basictypeNONE)
974 && (ai->bt != FFEINFO_basictypeHOLLERITH)
975 && (ai->bt != FFEINFO_basictypeNONE)
976 && (ai->bt != FFEINFO_basictypeTYPELESS))
978 /* Check types. */
980 if ((bt != ai->bt)
981 && ((bt != FFEINFO_basictypeREAL)
982 || (ai->bt != FFEINFO_basictypeCOMPLEX))
983 && ((bt != FFEINFO_basictypeCOMPLEX)
984 || (ai->bt != FFEINFO_basictypeREAL)))
986 if (((bt == FFEINFO_basictypeINTEGER)
987 && (ai->bt == FFEINFO_basictypeLOGICAL))
988 || ((bt == FFEINFO_basictypeLOGICAL)
989 && (ai->bt == FFEINFO_basictypeINTEGER)))
990 warn = TRUE; /* We can cope with these differences. */
991 else
992 fail = TRUE;
993 refwhy = "one type";
994 defwhy = "some other type";
997 if (!fail && !warn && (kt != ai->kt))
999 fail = TRUE;
1000 refwhy = "one precision";
1001 defwhy = "some other precision";
1005 if (fail && ! g->u.proc.defined)
1007 /* No point failing if we're worried only about invocations. */
1008 fail = FALSE;
1009 warn = TRUE;
1012 if (fail && ! ffe_is_globals ())
1014 warn = TRUE;
1015 fail = FALSE;
1018 if (fail || (warn && ffe_is_warn_globals ()))
1020 char num[60];
1022 if (ai->name == NULL)
1023 sprintf (&num[0], "%d", argno + 1);
1024 else
1026 if (strlen (ai->name) < 30)
1027 sprintf (&num[0], "%d (named `%s')", argno + 1, ai->name);
1028 else
1029 sprintf (&num[0], "%d (named `%.*s...')", argno + 1, 30, ai->name);
1031 ffebad_start (fail ? FFEBAD_FILEWIDE_ARG : FFEBAD_FILEWIDE_ARG_W);
1032 ffebad_string (ffesymbol_text (s));
1033 ffebad_string (num);
1034 ffebad_string (refwhy);
1035 ffebad_string (defwhy);
1036 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1037 ffebad_here (1, ffelex_token_where_line (ai->t), ffelex_token_where_column (ai->t));
1038 ffebad_finish ();
1039 return (fail ? FALSE : TRUE);
1042 if (warn)
1043 return TRUE;
1046 /* Define this argument. */
1048 if (ai->t != NULL)
1049 ffelex_token_kill (ai->t);
1050 if ((as != FFEGLOBAL_argsummaryPROC)
1051 || (ai->t == NULL))
1052 ai->as = as;
1053 ai->t = ffelex_token_use (g->t);
1054 ai->name = NULL;
1055 ai->bt = bt;
1056 ai->kt = kt;
1057 ai->array = array;
1058 return TRUE;
1061 bool
1062 ffeglobal_proc_ref_nargs (ffesymbol s, int n_args, ffelexToken t)
1064 ffeglobal g = ffesymbol_global (s);
1066 assert (g != NULL);
1068 if (g->type == FFEGLOBAL_typeANY)
1069 return FALSE;
1071 if (g->u.proc.n_args >= 0)
1073 if (g->u.proc.n_args == n_args)
1074 return TRUE;
1076 if (g->u.proc.defined && ffe_is_globals ())
1078 ffebad_start (FFEBAD_FILEWIDE_NARGS);
1079 ffebad_string (ffesymbol_text (s));
1080 if (g->u.proc.n_args > n_args)
1081 ffebad_string ("few");
1082 else
1083 ffebad_string ("many");
1084 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1085 ffebad_here (1, ffelex_token_where_line (g->t),
1086 ffelex_token_where_column (g->t));
1087 ffebad_finish ();
1088 return FALSE;
1091 if (ffe_is_warn_globals ())
1093 ffebad_start (FFEBAD_FILEWIDE_NARGS_W);
1094 ffebad_string (ffesymbol_text (s));
1095 if (g->u.proc.n_args > n_args)
1096 ffebad_string ("few");
1097 else
1098 ffebad_string ("many");
1099 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1100 ffebad_here (1, ffelex_token_where_line (g->t),
1101 ffelex_token_where_column (g->t));
1102 ffebad_finish ();
1105 return TRUE; /* Don't replace the info we already have. */
1108 /* This is new info we can use in cross-checking future references
1109 and a possible future definition. */
1111 g->u.proc.n_args = n_args;
1112 g->u.proc.other_t = ffelex_token_use (t);
1114 /* Make this "the" place we found the global, since it has the most info. */
1116 if (g->t != NULL)
1117 ffelex_token_kill (g->t);
1118 g->t = ffelex_token_use (t);
1120 if (n_args == 0)
1122 g->u.proc.arg_info = NULL;
1123 return TRUE;
1126 g->u.proc.arg_info
1127 = (ffeglobalArgInfo_) malloc_new_ks (malloc_pool_image (),
1128 "ffeglobalArgInfo_",
1129 n_args * sizeof (g->u.proc.arg_info[0]));
1130 while (n_args-- > 0)
1131 g->u.proc.arg_info[n_args].t = NULL;
1133 return TRUE;
1136 /* Return a global for a promoted symbol (one that has heretofore
1137 been assumed to be local, but since discovered to be global). */
1139 ffeglobal
1140 ffeglobal_promoted (ffesymbol s)
1142 #if FFEGLOBAL_ENABLED
1143 ffename n;
1144 ffeglobal g;
1146 assert (ffesymbol_global (s) == NULL);
1148 n = ffename_find (ffeglobal_filewide_, ffename_token (ffesymbol_name (s)));
1149 g = ffename_global (n);
1151 return g;
1152 #else
1153 return NULL;
1154 #endif
1157 /* Register a reference to an intrinsic. Such a reference is always
1158 valid, though a warning might be in order if the same name has
1159 already been used for a global. */
1161 void
1162 ffeglobal_ref_intrinsic (ffesymbol s, ffelexToken t, bool explicit)
1164 #if FFEGLOBAL_ENABLED
1165 ffename n;
1166 ffeglobal g;
1168 if (ffesymbol_global (s) == NULL)
1170 n = ffename_find (ffeglobal_filewide_, t);
1171 g = ffename_global (n);
1173 else
1175 g = ffesymbol_global (s);
1176 n = NULL;
1179 if ((g != NULL) && (g->type == FFEGLOBAL_typeANY))
1180 return;
1182 if ((g != NULL) && (g->type != FFEGLOBAL_typeNONE))
1184 if (! explicit
1185 && ! g->intrinsic
1186 && ffe_is_warn_globals ())
1188 /* This name, previously used as a global, now is used
1189 for an intrinsic. Warn, since this new use as an
1190 intrinsic might have been intended to refer to
1191 the global procedure. */
1192 ffebad_start (FFEBAD_INTRINSIC_GLOBAL);
1193 ffebad_string (ffelex_token_text (t));
1194 ffebad_string ("intrinsic");
1195 ffebad_string ("global");
1196 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1197 ffebad_here (1, ffelex_token_where_line (g->t),
1198 ffelex_token_where_column (g->t));
1199 ffebad_finish ();
1202 else
1204 if (g == NULL)
1206 g = ffeglobal_new_ (n);
1207 g->tick = ffe_count_2;
1208 g->type = FFEGLOBAL_typeNONE;
1209 g->intrinsic = TRUE;
1210 g->explicit_intrinsic = explicit;
1211 g->t = ffelex_token_use (t);
1213 else if (g->intrinsic
1214 && (explicit != g->explicit_intrinsic)
1215 && (g->tick != ffe_count_2)
1216 && ffe_is_warn_globals ())
1218 /* An earlier reference to this intrinsic disagrees with
1219 this reference vis-a-vis explicit `intrinsic foo',
1220 which suggests that the one relying on implicit
1221 intrinsicacity might have actually intended to refer
1222 to a global of the same name. */
1223 ffebad_start (FFEBAD_INTRINSIC_EXPIMP);
1224 ffebad_string (ffelex_token_text (t));
1225 ffebad_string (explicit ? "explicit" : "implicit");
1226 ffebad_string (explicit ? "implicit" : "explicit");
1227 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1228 ffebad_here (1, ffelex_token_where_line (g->t),
1229 ffelex_token_where_column (g->t));
1230 ffebad_finish ();
1234 g->intrinsic = TRUE;
1235 if (explicit)
1236 g->explicit_intrinsic = TRUE;
1238 ffesymbol_set_global (s, g);
1239 #endif
1242 /* Register a reference to a global. Returns TRUE if the reference
1243 is valid. */
1245 bool
1246 ffeglobal_ref_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type)
1248 #if FFEGLOBAL_ENABLED
1249 ffename n = NULL;
1250 ffeglobal g;
1252 /* It is never really _known_ that an EXTERNAL statement
1253 names a BLOCK DATA by just looking at the program unit,
1254 so override a different notion here. */
1255 if (type == FFEGLOBAL_typeBDATA)
1256 type = FFEGLOBAL_typeEXT;
1258 g = ffesymbol_global (s);
1259 if (g == NULL)
1261 n = ffename_find (ffeglobal_filewide_, t);
1262 g = ffename_global (n);
1263 if (g != NULL)
1264 ffesymbol_set_global (s, g);
1267 if ((g != NULL) && (g->type == FFEGLOBAL_typeANY))
1268 return TRUE;
1270 if ((g != NULL)
1271 && (g->type != FFEGLOBAL_typeNONE)
1272 && (g->type != FFEGLOBAL_typeEXT)
1273 && (g->type != type)
1274 && (type != FFEGLOBAL_typeEXT))
1276 /* Disagreement about (fully refined) class of program unit
1277 (main, subroutine, function, block data). Treat EXTERNAL/
1278 COMMON disagreements distinctly. */
1279 if ((((type == FFEGLOBAL_typeBDATA)
1280 && (g->type != FFEGLOBAL_typeCOMMON))
1281 || ((g->type == FFEGLOBAL_typeBDATA)
1282 && (type != FFEGLOBAL_typeCOMMON)
1283 && ! g->u.proc.defined)))
1285 #if 0 /* This is likely to just annoy people. */
1286 if (ffe_is_warn_globals ())
1288 /* Warn about EXTERNAL of a COMMON name, though it works. */
1289 ffebad_start (FFEBAD_FILEWIDE_TIFF);
1290 ffebad_string (ffelex_token_text (t));
1291 ffebad_string (ffeglobal_type_string_[type]);
1292 ffebad_string (ffeglobal_type_string_[g->type]);
1293 ffebad_here (0, ffelex_token_where_line (t),
1294 ffelex_token_where_column (t));
1295 ffebad_here (1, ffelex_token_where_line (g->t),
1296 ffelex_token_where_column (g->t));
1297 ffebad_finish ();
1299 #endif
1301 else if (ffe_is_globals () || ffe_is_warn_globals ())
1303 ffebad_start (ffe_is_globals ()
1304 ? FFEBAD_FILEWIDE_DISAGREEMENT
1305 : FFEBAD_FILEWIDE_DISAGREEMENT_W);
1306 ffebad_string (ffelex_token_text (t));
1307 ffebad_string (ffeglobal_type_string_[type]);
1308 ffebad_string (ffeglobal_type_string_[g->type]);
1309 ffebad_here (0, ffelex_token_where_line (t),
1310 ffelex_token_where_column (t));
1311 ffebad_here (1, ffelex_token_where_line (g->t),
1312 ffelex_token_where_column (g->t));
1313 ffebad_finish ();
1314 g->type = FFEGLOBAL_typeANY;
1315 return (! ffe_is_globals ());
1319 if ((g != NULL)
1320 && (type == FFEGLOBAL_typeFUNC))
1322 /* If just filling in this function's type, do so. */
1323 if ((g->tick == ffe_count_2)
1324 && (ffesymbol_basictype (s) != FFEINFO_basictypeNONE)
1325 && (ffesymbol_kindtype (s) != FFEINFO_kindtypeNONE))
1327 g->u.proc.bt = ffesymbol_basictype (s);
1328 g->u.proc.kt = ffesymbol_kindtype (s);
1329 g->u.proc.sz = ffesymbol_size (s);
1331 /* Make sure there is type agreement. */
1332 if (g->type == FFEGLOBAL_typeFUNC
1333 && g->u.proc.bt != FFEINFO_basictypeNONE
1334 && ffesymbol_basictype (s) != FFEINFO_basictypeNONE
1335 && (ffesymbol_basictype (s) != g->u.proc.bt
1336 || ffesymbol_kindtype (s) != g->u.proc.kt
1337 /* CHARACTER*n disagreements matter only once a
1338 definition is involved, since the definition might
1339 be CHARACTER*(*), which accepts all references. */
1340 || (g->u.proc.defined
1341 && ffesymbol_size (s) != g->u.proc.sz
1342 && ffesymbol_size (s) != FFETARGET_charactersizeNONE
1343 && g->u.proc.sz != FFETARGET_charactersizeNONE)))
1345 int error;
1347 /* Type mismatch between function reference/definition and
1348 this subsequent reference (which might just be the filling-in
1349 of type info for the definition, but we can't reach here
1350 if that's the case and there was a previous definition).
1352 It's an error given a previous definition, since that
1353 implies inlining can crash the compiler, unless the user
1354 asked for no such inlining. */
1355 error = (g->tick != ffe_count_2
1356 && g->u.proc.defined
1357 && ffe_is_globals ());
1358 if (error || ffe_is_warn_globals ())
1360 ffebad_start (error
1361 ? FFEBAD_FILEWIDE_TYPE_MISMATCH
1362 : FFEBAD_FILEWIDE_TYPE_MISMATCH_W);
1363 ffebad_string (ffelex_token_text (t));
1364 if (g->tick == ffe_count_2)
1366 /* Current reference fills in type info for definition.
1367 The current token doesn't necessarily point to the actual
1368 definition of the function, so use the definition pointer
1369 and the pointer to the pre-definition type info. */
1370 ffebad_here (0, ffelex_token_where_line (g->t),
1371 ffelex_token_where_column (g->t));
1372 ffebad_here (1, ffelex_token_where_line (g->u.proc.other_t),
1373 ffelex_token_where_column (g->u.proc.other_t));
1375 else
1377 /* Current reference is not a filling-in of a current
1378 definition. The current token is fine, as is
1379 the previous-mention token. */
1380 ffebad_here (0, ffelex_token_where_line (t),
1381 ffelex_token_where_column (t));
1382 ffebad_here (1, ffelex_token_where_line (g->t),
1383 ffelex_token_where_column (g->t));
1385 ffebad_finish ();
1386 if (error)
1387 g->type = FFEGLOBAL_typeANY;
1388 return FALSE;
1393 if (g == NULL)
1395 g = ffeglobal_new_ (n);
1396 g->t = ffelex_token_use (t);
1397 g->tick = ffe_count_2;
1398 g->intrinsic = FALSE;
1399 g->type = type;
1400 g->u.proc.defined = FALSE;
1401 g->u.proc.bt = ffesymbol_basictype (s);
1402 g->u.proc.kt = ffesymbol_kindtype (s);
1403 g->u.proc.sz = ffesymbol_size (s);
1404 g->u.proc.n_args = -1;
1405 ffesymbol_set_global (s, g);
1407 else if (g->intrinsic
1408 && !g->explicit_intrinsic
1409 && (g->tick != ffe_count_2)
1410 && ffe_is_warn_globals ())
1412 /* Now known as a global, this name previously was seen as an
1413 intrinsic. Warn, in case the previous reference was intended
1414 for the same global. */
1415 ffebad_start (FFEBAD_INTRINSIC_GLOBAL);
1416 ffebad_string (ffelex_token_text (t));
1417 ffebad_string ("global");
1418 ffebad_string ("intrinsic");
1419 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1420 ffebad_here (1, ffelex_token_where_line (g->t),
1421 ffelex_token_where_column (g->t));
1422 ffebad_finish ();
1425 if ((g->type != type)
1426 && (type != FFEGLOBAL_typeEXT))
1428 /* We've learned more, so point to where we learned it. */
1429 g->t = ffelex_token_use (t);
1430 g->type = type;
1431 g->hook = FFECOM_globalNULL; /* Discard previous _DECL. */
1432 g->u.proc.n_args = -1;
1435 return TRUE;
1436 #endif
1439 /* ffeglobal_save_common -- Check SAVE status of common area
1441 ffesymbol s; // the common area
1442 bool save; // TRUE if SAVEd, FALSE otherwise
1443 ffeglobal_save_common(s,save,ffesymbol_where_line(s),
1444 ffesymbol_where_column(s));
1446 In global-enabled mode, make sure the save info agrees with any existing
1447 info established for the common area, otherwise complain.
1448 In global-disabled mode, do nothing. */
1450 void
1451 ffeglobal_save_common (ffesymbol s, bool save, ffewhereLine wl,
1452 ffewhereColumn wc)
1454 #if FFEGLOBAL_ENABLED
1455 ffeglobal g;
1457 g = ffesymbol_global (s);
1458 if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON))
1459 return; /* Let someone else catch this! */
1460 if (g->type == FFEGLOBAL_typeANY)
1461 return;
1463 if (!g->u.common.have_save)
1465 g->u.common.have_save = TRUE;
1466 g->u.common.save = save;
1467 g->u.common.save_where_line = ffewhere_line_use (wl);
1468 g->u.common.save_where_col = ffewhere_column_use (wc);
1470 else
1472 if ((g->u.common.save != save) && ffe_is_pedantic ())
1474 ffebad_start (FFEBAD_COMMON_DIFF_SAVE);
1475 ffebad_string (ffesymbol_text (s));
1476 ffebad_here (save ? 0 : 1, wl, wc);
1477 ffebad_here (save ? 1 : 0, g->u.common.pad_where_line, g->u.common.pad_where_col);
1478 ffebad_finish ();
1481 #endif
1484 /* ffeglobal_size_common -- Establish size of COMMON area
1486 ffesymbol s; // the common area
1487 ffetargetOffset size; // size in units
1488 if (ffeglobal_size_common(s,size)) // new size is largest seen
1490 In global-enabled mode, set the size if it current size isn't known or is
1491 smaller than new size, and for non-blank common, complain if old size
1492 is different from new. Return TRUE if the new size is the largest seen
1493 for this COMMON area (or if no size was known for it previously).
1494 In global-disabled mode, do nothing. */
1496 #if FFEGLOBAL_ENABLED
1497 bool
1498 ffeglobal_size_common (ffesymbol s, ffetargetOffset size)
1500 ffeglobal g;
1502 g = ffesymbol_global (s);
1503 if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON))
1504 return FALSE;
1505 if (g->type == FFEGLOBAL_typeANY)
1506 return FALSE;
1508 if (!g->u.common.have_size)
1510 g->u.common.have_size = TRUE;
1511 g->u.common.size = size;
1512 return TRUE;
1515 if ((g->tick > 0) && (g->tick < ffe_count_2)
1516 && (g->u.common.size < size))
1518 char oldsize[40];
1519 char newsize[40];
1521 /* Common block initialized in a previous program unit, which
1522 effectively freezes its size, but now the program is trying
1523 to enlarge it. */
1525 sprintf (&oldsize[0], "%" ffetargetOffset_f "d", g->u.common.size);
1526 sprintf (&newsize[0], "%" ffetargetOffset_f "d", size);
1528 ffebad_start (FFEBAD_COMMON_ENLARGED);
1529 ffebad_string (ffesymbol_text (s));
1530 ffebad_string (oldsize);
1531 ffebad_string (newsize);
1532 ffebad_string ((g->u.common.size == 1)
1533 ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
1534 ffebad_string ((size == 1)
1535 ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
1536 ffebad_here (0, ffelex_token_where_line (g->u.common.initt),
1537 ffelex_token_where_column (g->u.common.initt));
1538 ffebad_here (1, ffesymbol_where_line (s),
1539 ffesymbol_where_column (s));
1540 ffebad_finish ();
1542 else if ((g->u.common.size != size) && !g->u.common.blank)
1544 char oldsize[40];
1545 char newsize[40];
1547 /* Warn about this even if not -pedantic, because putting all
1548 program units in a single source file is the only way to
1549 detect this. Apparently UNIX-model linkers neither handle
1550 nor report when they make a common unit smaller than
1551 requested, such as when the smaller-declared version is
1552 initialized and the larger-declared version is not. So
1553 if people complain about strange overwriting, we can tell
1554 them to put all their code in a single file and compile
1555 that way. Warnings about differing sizes must therefore
1556 always be issued. */
1558 sprintf (&oldsize[0], "%" ffetargetOffset_f "d", g->u.common.size);
1559 sprintf (&newsize[0], "%" ffetargetOffset_f "d", size);
1561 ffebad_start (FFEBAD_COMMON_DIFF_SIZE);
1562 ffebad_string (ffesymbol_text (s));
1563 ffebad_string (oldsize);
1564 ffebad_string (newsize);
1565 ffebad_string ((g->u.common.size == 1)
1566 ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
1567 ffebad_string ((size == 1)
1568 ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
1569 ffebad_here (0, ffelex_token_where_line (g->t),
1570 ffelex_token_where_column (g->t));
1571 ffebad_here (1, ffesymbol_where_line (s),
1572 ffesymbol_where_column (s));
1573 ffebad_finish ();
1576 if (size > g->u.common.size)
1578 g->u.common.size = size;
1579 return TRUE;
1582 return FALSE;
1585 #endif
1586 void
1587 ffeglobal_terminate_1 ()