]>
Commit | Line | Data |
---|---|---|
5ff904cd | 1 | /* Implementation of Fortran symbol manager |
ddd28aec | 2 | Copyright (C) 1995-1997 Free Software Foundation, Inc. |
25d7717e | 3 | Contributed by James Craig Burley. |
5ff904cd JL |
4 | |
5 | This file is part of GNU Fortran. | |
6 | ||
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. | |
11 | ||
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. | |
16 | ||
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. */ | |
21 | ||
22 | #include "proj.h" | |
23 | #include "symbol.h" | |
24 | #include "bad.h" | |
25 | #include "bld.h" | |
26 | #include "com.h" | |
27 | #include "equiv.h" | |
28 | #include "global.h" | |
29 | #include "info.h" | |
30 | #include "intrin.h" | |
31 | #include "lex.h" | |
32 | #include "malloc.h" | |
33 | #include "src.h" | |
34 | #include "st.h" | |
35 | #include "storag.h" | |
36 | #include "target.h" | |
37 | #include "where.h" | |
38 | ||
39 | /* Choice of how to handle global symbols -- either global only within the | |
40 | program unit being defined or global within the entire source file. | |
41 | The former is appropriate for systems where an object file can | |
42 | easily be taken apart program unit by program unit, the latter is the | |
43 | UNIX/C model where the object file is essentially a monolith. */ | |
44 | ||
45 | #define FFESYMBOL_globalPROGUNIT_ 1 | |
46 | #define FFESYMBOL_globalFILE_ 2 | |
47 | ||
48 | /* Choose how to handle global symbols here. */ | |
49 | ||
50 | #if FFECOM_targetCURRENT == FFECOM_targetFFE | |
51 | #define FFESYMBOL_globalCURRENT_ FFESYMBOL_globalPROGUNIT_ | |
52 | #elif FFECOM_targetCURRENT == FFECOM_targetGCC | |
53 | /* Would be good to understand why PROGUNIT in this case too. | |
54 | (1995-08-22). */ | |
55 | #define FFESYMBOL_globalCURRENT_ FFESYMBOL_globalPROGUNIT_ | |
56 | #else | |
57 | #error | |
58 | #endif | |
59 | ||
60 | /* Choose how to handle memory pools based on global symbol stuff. */ | |
61 | ||
62 | #if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_ | |
63 | #define FFESYMBOL_SPACE_POOL_ ffe_pool_program_unit() | |
64 | #elif FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalFILE_ | |
65 | #define FFESYMBOL_SPACE_POOL_ ffe_pool_file() | |
66 | #else | |
67 | #error | |
68 | #endif | |
69 | ||
70 | /* What kind of retraction is needed for a symbol? */ | |
71 | ||
72 | enum _ffesymbol_retractcommand_ | |
73 | { | |
74 | FFESYMBOL_retractcommandDELETE_, | |
75 | FFESYMBOL_retractcommandRETRACT_, | |
76 | FFESYMBOL_retractcommand_ | |
77 | }; | |
78 | typedef enum _ffesymbol_retractcommand_ ffesymbolRetractCommand_; | |
79 | ||
80 | /* This object keeps track of retraction for a symbol and links to the next | |
81 | such object. */ | |
82 | ||
83 | typedef struct _ffesymbol_retract_ *ffesymbolRetract_; | |
84 | struct _ffesymbol_retract_ | |
85 | { | |
86 | ffesymbolRetract_ next; | |
87 | ffesymbolRetractCommand_ command; | |
88 | ffesymbol live; /* Live symbol. */ | |
89 | ffesymbol symbol; /* Backup copy of symbol. */ | |
90 | }; | |
91 | ||
92 | static ffebad ffesymbol_check_token_ (ffelexToken t, char *c); | |
93 | static void ffesymbol_kill_manifest_ (void); | |
94 | static ffesymbol ffesymbol_new_ (ffename n); | |
95 | static ffesymbol ffesymbol_unhook_ (ffesymbol s); | |
96 | static void ffesymbol_whine_state_ (ffebad bad, ffelexToken t, char c); | |
97 | ||
98 | /* Manifest names for unnamed things (as tokens) so we make them only | |
99 | once. */ | |
100 | ||
101 | static ffelexToken ffesymbol_token_blank_common_ = NULL; | |
102 | static ffelexToken ffesymbol_token_unnamed_main_ = NULL; | |
103 | static ffelexToken ffesymbol_token_unnamed_blockdata_ = NULL; | |
104 | ||
105 | /* Name spaces currently in force. */ | |
106 | ||
107 | static ffenameSpace ffesymbol_global_ = NULL; | |
108 | static ffenameSpace ffesymbol_local_ = NULL; | |
109 | static ffenameSpace ffesymbol_sfunc_ = NULL; | |
110 | ||
111 | /* Keep track of retraction. */ | |
112 | ||
113 | static bool ffesymbol_retractable_ = FALSE; | |
114 | static mallocPool ffesymbol_retract_pool_; | |
115 | static ffesymbolRetract_ ffesymbol_retract_first_; | |
116 | static ffesymbolRetract_ *ffesymbol_retract_list_; | |
117 | ||
118 | /* List of state names. */ | |
119 | ||
26f096f9 | 120 | static const char *ffesymbol_state_name_[] = |
5ff904cd JL |
121 | { |
122 | "?", | |
123 | "@", | |
124 | "&", | |
125 | "$", | |
126 | }; | |
127 | ||
128 | /* List of attribute names. */ | |
129 | ||
26f096f9 | 130 | static const char *ffesymbol_attr_name_[] = |
5ff904cd JL |
131 | { |
132 | #define DEFATTR(ATTR,ATTRS,NAME) NAME, | |
133 | #include "symbol.def" | |
134 | #undef DEFATTR | |
135 | }; | |
136 | \f | |
137 | ||
138 | /* Check whether the token text has any invalid characters. If not, | |
139 | return FALSE. If so, if error messages inhibited, return TRUE | |
140 | so caller knows to try again later, else report error and return | |
141 | FALSE. */ | |
142 | ||
143 | static ffebad | |
144 | ffesymbol_check_token_ (ffelexToken t, char *c) | |
145 | { | |
146 | char *p = ffelex_token_text (t); | |
147 | ffeTokenLength len = ffelex_token_length (t); | |
148 | ffebad bad; | |
149 | ffeTokenLength i = 0; | |
150 | ffebad skip_me = ((ffe_case_symbol () == FFE_caseINITCAP) | |
151 | ? FFEBAD_SYMBOL_NOLOWER_INITCAP : FFEBAD + 1); | |
152 | ffebad stop_me = ((ffe_case_symbol () == FFE_caseINITCAP) | |
153 | ? FFEBAD : FFEBAD + 1); | |
154 | if (len == 0) | |
155 | return FFEBAD; | |
156 | ||
157 | bad = ffesrc_bad_char_symbol_init (*p); | |
158 | if (bad == FFEBAD) | |
159 | { | |
160 | for (++i, ++p; i < len; ++i, ++p) | |
161 | { | |
162 | bad = ffesrc_bad_char_symbol_noninit (*p); | |
163 | if (bad == skip_me) | |
164 | continue; /* Keep looking for good InitCap character. */ | |
165 | if (bad == stop_me) | |
166 | break; /* Found good InitCap character. */ | |
167 | if (bad != FFEBAD) | |
168 | break; /* Bad character found. */ | |
169 | } | |
170 | } | |
171 | ||
172 | if (bad != FFEBAD) | |
567f3d36 KG |
173 | { |
174 | if (i >= len) | |
175 | *c = *(ffelex_token_text (t)); | |
176 | else | |
177 | *c = *p; | |
178 | } | |
5ff904cd JL |
179 | |
180 | return bad; | |
181 | } | |
182 | ||
183 | /* Kill manifest (g77-picked) names. */ | |
184 | ||
185 | static void | |
186 | ffesymbol_kill_manifest_ () | |
187 | { | |
188 | if (ffesymbol_token_blank_common_ != NULL) | |
189 | ffelex_token_kill (ffesymbol_token_blank_common_); | |
190 | if (ffesymbol_token_unnamed_main_ != NULL) | |
191 | ffelex_token_kill (ffesymbol_token_unnamed_main_); | |
192 | if (ffesymbol_token_unnamed_blockdata_ != NULL) | |
193 | ffelex_token_kill (ffesymbol_token_unnamed_blockdata_); | |
194 | ||
195 | ffesymbol_token_blank_common_ = NULL; | |
196 | ffesymbol_token_unnamed_main_ = NULL; | |
197 | ffesymbol_token_unnamed_blockdata_ = NULL; | |
198 | } | |
199 | ||
200 | /* Make new symbol. | |
201 | ||
202 | If the "retractable" flag is not set, just return the new symbol. | |
203 | Else, add symbol to the "retract" list as a delete item, set | |
204 | the "have_old" flag, and return the new symbol. */ | |
205 | ||
206 | static ffesymbol | |
207 | ffesymbol_new_ (ffename n) | |
208 | { | |
209 | ffesymbol s; | |
210 | ffesymbolRetract_ r; | |
211 | ||
212 | assert (n != NULL); | |
213 | ||
214 | s = (ffesymbol) malloc_new_ks (FFESYMBOL_SPACE_POOL_, "FFESYMBOL", | |
215 | sizeof (*s)); | |
216 | s->name = n; | |
217 | s->other_space_name = NULL; | |
218 | #if FFEGLOBAL_ENABLED | |
219 | s->global = NULL; | |
220 | #endif | |
221 | s->attrs = FFESYMBOL_attrsetNONE; | |
222 | s->state = FFESYMBOL_stateNONE; | |
223 | s->info = ffeinfo_new_null (); | |
224 | s->dims = NULL; | |
225 | s->extents = NULL; | |
226 | s->dim_syms = NULL; | |
227 | s->array_size = NULL; | |
228 | s->init = NULL; | |
229 | s->accretion = NULL; | |
230 | s->accretes = 0; | |
231 | s->dummy_args = NULL; | |
232 | s->namelist = NULL; | |
233 | s->common_list = NULL; | |
234 | s->sfunc_expr = NULL; | |
235 | s->list_bottom = NULL; | |
236 | s->common = NULL; | |
237 | s->equiv = NULL; | |
238 | s->storage = NULL; | |
239 | #ifdef FFECOM_symbolHOOK | |
240 | s->hook = FFECOM_symbolNULL; | |
241 | #endif | |
242 | s->sfa_dummy_parent = NULL; | |
243 | s->func_result = NULL; | |
244 | s->value = 0; | |
245 | s->check_state = FFESYMBOL_checkstateNONE_; | |
246 | s->check_token = NULL; | |
247 | s->max_entry_num = 0; | |
248 | s->num_entries = 0; | |
249 | s->generic = FFEINTRIN_genNONE; | |
250 | s->specific = FFEINTRIN_specNONE; | |
251 | s->implementation = FFEINTRIN_impNONE; | |
252 | s->is_save = FALSE; | |
253 | s->is_init = FALSE; | |
254 | s->do_iter = FALSE; | |
255 | s->reported = FALSE; | |
256 | s->explicit_where = FALSE; | |
257 | s->namelisted = FALSE; | |
c7e4ee3a | 258 | s->assigned = FALSE; |
5ff904cd JL |
259 | |
260 | ffename_set_symbol (n, s); | |
261 | ||
262 | if (!ffesymbol_retractable_) | |
263 | { | |
264 | s->have_old = FALSE; | |
265 | return s; | |
266 | } | |
267 | ||
268 | r = (ffesymbolRetract_) malloc_new_kp (ffesymbol_retract_pool_, | |
269 | "FFESYMBOL retract", sizeof (*r)); | |
270 | r->next = NULL; | |
271 | r->command = FFESYMBOL_retractcommandDELETE_; | |
272 | r->live = s; | |
273 | r->symbol = NULL; /* No backup copy. */ | |
274 | ||
275 | *ffesymbol_retract_list_ = r; | |
276 | ffesymbol_retract_list_ = &r->next; | |
277 | ||
278 | s->have_old = TRUE; | |
279 | return s; | |
280 | } | |
281 | ||
282 | /* Unhook a symbol from its (soon-to-be-killed) name obj. | |
283 | ||
284 | NULLify the names to which this symbol points. Do other cleanup as | |
285 | needed. */ | |
286 | ||
287 | static ffesymbol | |
288 | ffesymbol_unhook_ (ffesymbol s) | |
289 | { | |
290 | s->other_space_name = s->name = NULL; | |
291 | if ((ffesymbol_attrs (s) & FFESYMBOL_attrsCBLOCK) | |
292 | || (ffesymbol_kind (s) == FFEINFO_kindNAMELIST)) | |
293 | ffebld_end_list (ffesymbol_ptr_to_listbottom (s)); | |
294 | if (s->check_state == FFESYMBOL_checkstatePENDING_) | |
295 | ffelex_token_kill (s->check_token); | |
296 | ||
297 | return s; | |
298 | } | |
299 | ||
300 | /* Issue diagnostic about bad character in token representing user-defined | |
301 | symbol name. */ | |
302 | ||
303 | static void | |
304 | ffesymbol_whine_state_ (ffebad bad, ffelexToken t, char c) | |
305 | { | |
306 | char badstr[2]; | |
307 | ||
308 | badstr[0] = c; | |
309 | badstr[1] = '\0'; | |
310 | ||
311 | ffebad_start (bad); | |
312 | ffebad_here (0, ffelex_token_where_line (t), | |
313 | ffelex_token_where_column (t)); | |
314 | ffebad_string (badstr); | |
315 | ffebad_finish (); | |
316 | } | |
317 | ||
318 | /* Returns a string representing the attributes set. */ | |
319 | ||
26f096f9 | 320 | const char * |
5ff904cd JL |
321 | ffesymbol_attrs_string (ffesymbolAttrs attrs) |
322 | { | |
323 | static char string[FFESYMBOL_attr * 12 + 20]; | |
324 | char *p; | |
325 | ffesymbolAttr attr; | |
326 | ||
327 | p = &string[0]; | |
328 | ||
329 | if (attrs == FFESYMBOL_attrsetNONE) | |
330 | { | |
331 | strcpy (p, "NONE"); | |
332 | return &string[0]; | |
333 | } | |
334 | ||
335 | for (attr = 0; attr < FFESYMBOL_attr; ++attr) | |
336 | { | |
337 | if (attrs & ((ffesymbolAttrs) 1 << attr)) | |
338 | { | |
339 | attrs &= ~((ffesymbolAttrs) 1 << attr); | |
340 | strcpy (p, ffesymbol_attr_name_[attr]); | |
341 | while (*p) | |
342 | ++p; | |
343 | *(p++) = '|'; | |
344 | } | |
345 | } | |
346 | if (attrs == FFESYMBOL_attrsetNONE) | |
347 | *--p = '\0'; | |
348 | else | |
349 | sprintf (p, "?0x%" ffesymbolAttrs_f "x?", attrs); | |
350 | assert (((size_t) (p - &string[0])) < ARRAY_SIZE (string)); | |
351 | return &string[0]; | |
352 | } | |
353 | ||
354 | /* Check symbol's name for validity, considering that it might actually | |
355 | be an intrinsic and thus should not be complained about just yet. */ | |
356 | ||
357 | void | |
358 | ffesymbol_check (ffesymbol s, ffelexToken t, bool maybe_intrin) | |
359 | { | |
360 | char c; | |
361 | ffebad bad; | |
362 | ffeintrinGen gen; | |
363 | ffeintrinSpec spec; | |
364 | ffeintrinImp imp; | |
365 | ||
366 | if (!ffesrc_check_symbol () | |
367 | || ((s->check_state != FFESYMBOL_checkstateNONE_) | |
368 | && ((s->check_state != FFESYMBOL_checkstateINHIBITED_) | |
369 | || ffebad_inhibit ()))) | |
370 | return; | |
371 | ||
372 | bad = ffesymbol_check_token_ (t, &c); | |
373 | ||
374 | if (bad == FFEBAD) | |
375 | { | |
376 | s->check_state = FFESYMBOL_checkstateCHECKED_; | |
377 | return; | |
378 | } | |
379 | ||
380 | if (maybe_intrin | |
381 | && ffeintrin_is_intrinsic (ffelex_token_text (t), NULL, FALSE, | |
382 | &gen, &spec, &imp)) | |
383 | { | |
384 | s->check_state = FFESYMBOL_checkstatePENDING_; | |
385 | s->check_token = ffelex_token_use (t); | |
386 | return; | |
387 | } | |
388 | ||
389 | if (ffebad_inhibit ()) | |
390 | { | |
391 | s->check_state = FFESYMBOL_checkstateINHIBITED_; | |
392 | return; /* Don't complain now, do it later. */ | |
393 | } | |
394 | ||
395 | s->check_state = FFESYMBOL_checkstateCHECKED_; | |
396 | ||
397 | ffesymbol_whine_state_ (bad, t, c); | |
398 | } | |
399 | ||
400 | /* Declare a BLOCKDATA unit. | |
401 | ||
402 | Retrieves or creates the ffesymbol for the specified BLOCKDATA (unnamed | |
403 | if t is NULL). Doesn't actually ensure the named item is a | |
404 | BLOCKDATA; the caller must handle that. */ | |
405 | ||
406 | ffesymbol | |
407 | ffesymbol_declare_blockdataunit (ffelexToken t, ffewhereLine wl, | |
408 | ffewhereColumn wc) | |
409 | { | |
410 | ffename n; | |
411 | ffesymbol s; | |
412 | bool user = (t != NULL); | |
413 | ||
414 | assert (!ffesymbol_retractable_); | |
415 | ||
416 | if (t == NULL) | |
417 | { | |
418 | if (ffesymbol_token_unnamed_blockdata_ == NULL) | |
419 | ffesymbol_token_unnamed_blockdata_ | |
420 | = ffelex_token_new_name (FFETARGET_nameUNNAMED_BLOCK_DATA, wl, wc); | |
421 | t = ffesymbol_token_unnamed_blockdata_; | |
422 | } | |
423 | ||
424 | n = ffename_lookup (ffesymbol_local_, t); | |
425 | if (n != NULL) | |
426 | return ffename_symbol (n); /* This will become an error. */ | |
427 | ||
428 | n = ffename_find (ffesymbol_global_, t); | |
429 | s = ffename_symbol (n); | |
430 | if (s != NULL) | |
431 | { | |
432 | if (user) | |
433 | ffesymbol_check (s, t, FALSE); | |
434 | return s; | |
435 | } | |
436 | ||
437 | s = ffesymbol_new_ (n); | |
438 | if (user) | |
439 | ffesymbol_check (s, t, FALSE); | |
440 | ||
441 | /* A program unit name also is in the local name space. */ | |
442 | ||
443 | n = ffename_find (ffesymbol_local_, t); | |
444 | ffename_set_symbol (n, s); | |
445 | s->other_space_name = n; | |
446 | ||
447 | ffeglobal_new_blockdata (s, t); /* Detect conflicts, when | |
448 | appropriate. */ | |
449 | ||
450 | return s; | |
451 | } | |
452 | ||
453 | /* Declare a common block (named or unnamed). | |
454 | ||
455 | Retrieves or creates the ffesymbol for the specified common block (blank | |
456 | common if t is NULL). Doesn't actually ensure the named item is a | |
457 | common block; the caller must handle that. */ | |
458 | ||
459 | ffesymbol | |
460 | ffesymbol_declare_cblock (ffelexToken t, ffewhereLine wl, ffewhereColumn wc) | |
461 | { | |
462 | ffename n; | |
463 | ffesymbol s; | |
464 | bool blank; | |
465 | ||
466 | assert (!ffesymbol_retractable_); | |
467 | ||
468 | if (t == NULL) | |
469 | { | |
470 | blank = TRUE; | |
471 | if (ffesymbol_token_blank_common_ == NULL) | |
472 | ffesymbol_token_blank_common_ | |
473 | = ffelex_token_new_name (FFETARGET_nameBLANK_COMMON, wl, wc); | |
474 | t = ffesymbol_token_blank_common_; | |
475 | } | |
476 | else | |
477 | blank = FALSE; | |
478 | ||
479 | n = ffename_find (ffesymbol_global_, t); | |
480 | s = ffename_symbol (n); | |
481 | if (s != NULL) | |
482 | { | |
483 | if (!blank) | |
484 | ffesymbol_check (s, t, FALSE); | |
485 | return s; | |
486 | } | |
487 | ||
488 | s = ffesymbol_new_ (n); | |
489 | if (!blank) | |
490 | ffesymbol_check (s, t, FALSE); | |
491 | ||
492 | ffeglobal_new_common (s, t, blank); /* Detect conflicts. */ | |
493 | ||
494 | return s; | |
495 | } | |
496 | ||
497 | /* Declare a FUNCTION program unit (with distinct RESULT() name). | |
498 | ||
499 | Retrieves or creates the ffesymbol for the specified function. Doesn't | |
500 | actually ensure the named item is a function; the caller must handle | |
501 | that. | |
502 | ||
503 | If FUNCTION with RESULT() is specified but the names are the same, | |
504 | pretend as though RESULT() was not specified, and don't call this | |
505 | function; use ffesymbol_declare_funcunit() instead. */ | |
506 | ||
507 | ffesymbol | |
508 | ffesymbol_declare_funcnotresunit (ffelexToken t) | |
509 | { | |
510 | ffename n; | |
511 | ffesymbol s; | |
512 | ||
513 | assert (t != NULL); | |
514 | assert (!ffesymbol_retractable_); | |
515 | ||
516 | n = ffename_lookup (ffesymbol_local_, t); | |
517 | if (n != NULL) | |
518 | return ffename_symbol (n); /* This will become an error. */ | |
519 | ||
520 | n = ffename_find (ffesymbol_global_, t); | |
521 | s = ffename_symbol (n); | |
522 | if (s != NULL) | |
523 | { | |
524 | ffesymbol_check (s, t, FALSE); | |
525 | return s; | |
526 | } | |
527 | ||
528 | s = ffesymbol_new_ (n); | |
529 | ffesymbol_check (s, t, FALSE); | |
530 | ||
531 | /* A FUNCTION program unit name also is in the local name space; handle it | |
532 | here since RESULT() is a different name and is handled separately. */ | |
533 | ||
534 | n = ffename_find (ffesymbol_local_, t); | |
535 | ffename_set_symbol (n, s); | |
536 | s->other_space_name = n; | |
537 | ||
538 | ffeglobal_new_function (s, t);/* Detect conflicts, when appropriate. */ | |
539 | ||
540 | return s; | |
541 | } | |
542 | ||
543 | /* Declare a function result. | |
544 | ||
545 | Retrieves or creates the ffesymbol for the specified function result, | |
546 | whether specified via a distinct RESULT() or by default in a FUNCTION or | |
547 | ENTRY statement. */ | |
548 | ||
549 | ffesymbol | |
550 | ffesymbol_declare_funcresult (ffelexToken t) | |
551 | { | |
552 | ffename n; | |
553 | ffesymbol s; | |
554 | ||
555 | assert (t != NULL); | |
556 | assert (!ffesymbol_retractable_); | |
557 | ||
558 | n = ffename_find (ffesymbol_local_, t); | |
559 | s = ffename_symbol (n); | |
560 | if (s != NULL) | |
561 | return s; | |
562 | ||
563 | return ffesymbol_new_ (n); | |
564 | } | |
565 | ||
566 | /* Declare a FUNCTION program unit with no RESULT(). | |
567 | ||
568 | Retrieves or creates the ffesymbol for the specified function. Doesn't | |
569 | actually ensure the named item is a function; the caller must handle | |
570 | that. | |
571 | ||
572 | This is the function to call when the FUNCTION or ENTRY statement has | |
573 | no separate and distinct name specified via RESULT(). That's because | |
574 | this function enters the global name of the function in only the global | |
575 | name space. ffesymbol_declare_funcresult() must still be called to | |
576 | declare the name for the function result in the local name space. */ | |
577 | ||
578 | ffesymbol | |
579 | ffesymbol_declare_funcunit (ffelexToken t) | |
580 | { | |
581 | ffename n; | |
582 | ffesymbol s; | |
583 | ||
584 | assert (t != NULL); | |
585 | assert (!ffesymbol_retractable_); | |
586 | ||
587 | n = ffename_find (ffesymbol_global_, t); | |
588 | s = ffename_symbol (n); | |
589 | if (s != NULL) | |
590 | { | |
591 | ffesymbol_check (s, t, FALSE); | |
592 | return s; | |
593 | } | |
594 | ||
595 | s = ffesymbol_new_ (n); | |
596 | ffesymbol_check (s, t, FALSE); | |
597 | ||
598 | ffeglobal_new_function (s, t);/* Detect conflicts. */ | |
599 | ||
600 | return s; | |
601 | } | |
602 | ||
603 | /* Declare a local entity. | |
604 | ||
605 | Retrieves or creates the ffesymbol for the specified local entity. | |
606 | Set maybe_intrin TRUE if this name might turn out to name an | |
607 | intrinsic (legitimately); otherwise if the name doesn't meet the | |
608 | requirements for a user-defined symbol name, a diagnostic will be | |
609 | issued right away rather than waiting until the intrinsicness of the | |
610 | symbol is determined. */ | |
611 | ||
612 | ffesymbol | |
613 | ffesymbol_declare_local (ffelexToken t, bool maybe_intrin) | |
614 | { | |
615 | ffename n; | |
616 | ffesymbol s; | |
617 | ||
618 | assert (t != NULL); | |
619 | ||
620 | /* If we're parsing within a statement function definition, return the | |
621 | symbol if already known (a dummy argument for the statement function). | |
622 | Otherwise continue on, which means the symbol is declared within the | |
623 | containing (local) program unit rather than the statement function | |
624 | definition. */ | |
625 | ||
626 | if ((ffesymbol_sfunc_ != NULL) | |
627 | && ((n = ffename_lookup (ffesymbol_sfunc_, t)) != NULL)) | |
628 | return ffename_symbol (n); | |
629 | ||
630 | n = ffename_find (ffesymbol_local_, t); | |
631 | s = ffename_symbol (n); | |
632 | if (s != NULL) | |
633 | { | |
634 | ffesymbol_check (s, t, maybe_intrin); | |
635 | return s; | |
636 | } | |
637 | ||
638 | s = ffesymbol_new_ (n); | |
639 | ffesymbol_check (s, t, maybe_intrin); | |
640 | return s; | |
641 | } | |
642 | ||
643 | /* Declare a main program unit. | |
644 | ||
645 | Retrieves or creates the ffesymbol for the specified main program unit | |
646 | (unnamed main program unit if t is NULL). Doesn't actually ensure the | |
647 | named item is a program; the caller must handle that. */ | |
648 | ||
649 | ffesymbol | |
650 | ffesymbol_declare_programunit (ffelexToken t, ffewhereLine wl, | |
651 | ffewhereColumn wc) | |
652 | { | |
653 | ffename n; | |
654 | ffesymbol s; | |
655 | bool user = (t != NULL); | |
656 | ||
657 | assert (!ffesymbol_retractable_); | |
658 | ||
659 | if (t == NULL) | |
660 | { | |
661 | if (ffesymbol_token_unnamed_main_ == NULL) | |
662 | ffesymbol_token_unnamed_main_ | |
663 | = ffelex_token_new_name (FFETARGET_nameUNNAMED_MAIN, wl, wc); | |
664 | t = ffesymbol_token_unnamed_main_; | |
665 | } | |
666 | ||
667 | n = ffename_lookup (ffesymbol_local_, t); | |
668 | if (n != NULL) | |
669 | return ffename_symbol (n); /* This will become an error. */ | |
670 | ||
671 | n = ffename_find (ffesymbol_global_, t); | |
672 | s = ffename_symbol (n); | |
673 | if (s != NULL) | |
674 | { | |
675 | if (user) | |
676 | ffesymbol_check (s, t, FALSE); | |
677 | return s; | |
678 | } | |
679 | ||
680 | s = ffesymbol_new_ (n); | |
681 | if (user) | |
682 | ffesymbol_check (s, t, FALSE); | |
683 | ||
684 | /* A program unit name also is in the local name space. */ | |
685 | ||
686 | n = ffename_find (ffesymbol_local_, t); | |
687 | ffename_set_symbol (n, s); | |
688 | s->other_space_name = n; | |
689 | ||
690 | ffeglobal_new_program (s, t); /* Detect conflicts. */ | |
691 | ||
692 | return s; | |
693 | } | |
694 | ||
695 | /* Declare a statement-function dummy. | |
696 | ||
697 | Retrieves or creates the ffesymbol for the specified statement | |
698 | function dummy. Also ensures that it has a link to the parent (local) | |
699 | ffesymbol with the same name, creating it if necessary. */ | |
700 | ||
701 | ffesymbol | |
702 | ffesymbol_declare_sfdummy (ffelexToken t) | |
703 | { | |
704 | ffename n; | |
705 | ffesymbol s; | |
706 | ffesymbol sp; /* Parent symbol in local area. */ | |
707 | ||
708 | assert (t != NULL); | |
709 | ||
710 | n = ffename_find (ffesymbol_local_, t); | |
711 | sp = ffename_symbol (n); | |
712 | if (sp == NULL) | |
713 | sp = ffesymbol_new_ (n); | |
714 | ffesymbol_check (sp, t, FALSE); | |
715 | ||
716 | n = ffename_find (ffesymbol_sfunc_, t); | |
717 | s = ffename_symbol (n); | |
718 | if (s == NULL) | |
719 | { | |
720 | s = ffesymbol_new_ (n); | |
721 | s->sfa_dummy_parent = sp; | |
722 | } | |
723 | else | |
724 | assert (s->sfa_dummy_parent == sp); | |
725 | ||
726 | return s; | |
727 | } | |
728 | ||
729 | /* Declare a subroutine program unit. | |
730 | ||
731 | Retrieves or creates the ffesymbol for the specified subroutine | |
732 | Doesn't actually ensure the named item is a subroutine; the caller must | |
733 | handle that. */ | |
734 | ||
735 | ffesymbol | |
736 | ffesymbol_declare_subrunit (ffelexToken t) | |
737 | { | |
738 | ffename n; | |
739 | ffesymbol s; | |
740 | ||
741 | assert (!ffesymbol_retractable_); | |
742 | assert (t != NULL); | |
743 | ||
744 | n = ffename_lookup (ffesymbol_local_, t); | |
745 | if (n != NULL) | |
746 | return ffename_symbol (n); /* This will become an error. */ | |
747 | ||
748 | n = ffename_find (ffesymbol_global_, t); | |
749 | s = ffename_symbol (n); | |
750 | if (s != NULL) | |
751 | { | |
752 | ffesymbol_check (s, t, FALSE); | |
753 | return s; | |
754 | } | |
755 | ||
756 | s = ffesymbol_new_ (n); | |
757 | ffesymbol_check (s, t, FALSE); | |
758 | ||
759 | /* A program unit name also is in the local name space. */ | |
760 | ||
761 | n = ffename_find (ffesymbol_local_, t); | |
762 | ffename_set_symbol (n, s); | |
763 | s->other_space_name = n; | |
764 | ||
765 | ffeglobal_new_subroutine (s, t); /* Detect conflicts, when | |
766 | appropriate. */ | |
767 | ||
768 | return s; | |
769 | } | |
770 | ||
771 | /* Call given fn with all local/global symbols. | |
772 | ||
773 | ffesymbol (*fn) (ffesymbol s); | |
774 | ffesymbol_drive (fn); */ | |
775 | ||
776 | void | |
26f096f9 | 777 | ffesymbol_drive (ffesymbol (*fn) (ffesymbol)) |
5ff904cd JL |
778 | { |
779 | assert (ffesymbol_sfunc_ == NULL); /* Might be ok, but not for current | |
780 | uses. */ | |
781 | ffename_space_drive_symbol (ffesymbol_local_, fn); | |
782 | ffename_space_drive_symbol (ffesymbol_global_, fn); | |
783 | } | |
784 | ||
785 | /* Call given fn with all sfunc-only symbols. | |
786 | ||
787 | ffesymbol (*fn) (ffesymbol s); | |
788 | ffesymbol_drive_sfnames (fn); */ | |
789 | ||
790 | void | |
26f096f9 | 791 | ffesymbol_drive_sfnames (ffesymbol (*fn) (ffesymbol)) |
5ff904cd JL |
792 | { |
793 | ffename_space_drive_symbol (ffesymbol_sfunc_, fn); | |
794 | } | |
795 | ||
796 | /* Dump info on the symbol for debugging purposes. */ | |
797 | ||
8b45da67 | 798 | #if FFECOM_targetCURRENT == FFECOM_targetFFE |
5ff904cd JL |
799 | void |
800 | ffesymbol_dump (ffesymbol s) | |
801 | { | |
802 | ffeinfoKind k; | |
803 | ffeinfoWhere w; | |
804 | ||
805 | assert (s != NULL); | |
806 | ||
807 | if (ffeinfo_size (s->info) != FFETARGET_charactersizeNONE) | |
808 | fprintf (dmpout, "%s:%d%s%s*%" ffetargetCharacterSize_f "u", | |
809 | ffesymbol_text (s), | |
810 | (int) ffeinfo_rank (s->info), | |
811 | ffeinfo_basictype_string (ffeinfo_basictype (s->info)), | |
812 | ffeinfo_kindtype_string (ffeinfo_kindtype (s->info)), | |
813 | ffeinfo_size (s->info)); | |
814 | else | |
815 | fprintf (dmpout, "%s:%d%s%s", | |
816 | ffesymbol_text (s), | |
817 | (int) ffeinfo_rank (s->info), | |
818 | ffeinfo_basictype_string (ffeinfo_basictype (s->info)), | |
819 | ffeinfo_kindtype_string (ffeinfo_kindtype (s->info))); | |
820 | if ((k = ffeinfo_kind (s->info)) != FFEINFO_kindNONE) | |
821 | fprintf (dmpout, "/%s", ffeinfo_kind_string (k)); | |
822 | if ((w = ffeinfo_where (s->info)) != FFEINFO_whereNONE) | |
823 | fprintf (dmpout, "@%s", ffeinfo_where_string (w)); | |
824 | ||
825 | if ((s->generic != FFEINTRIN_genNONE) | |
826 | || (s->specific != FFEINTRIN_specNONE) | |
827 | || (s->implementation != FFEINTRIN_impNONE)) | |
828 | fprintf (dmpout, "{%s:%s:%s}", | |
829 | ffeintrin_name_generic (s->generic), | |
830 | ffeintrin_name_specific (s->specific), | |
831 | ffeintrin_name_implementation (s->implementation)); | |
832 | } | |
8b45da67 | 833 | #endif |
5ff904cd JL |
834 | |
835 | /* Produce generic error message about a symbol. | |
836 | ||
837 | For now, just output error message using symbol's name and pointing to | |
838 | the token. */ | |
839 | ||
840 | void | |
841 | ffesymbol_error (ffesymbol s, ffelexToken t) | |
842 | { | |
843 | if ((t != NULL) | |
844 | && ffest_ffebad_start (FFEBAD_SYMERR)) | |
845 | { | |
846 | ffebad_string (ffesymbol_text (s)); | |
847 | ffebad_here (0, ffelex_token_where_line (t), | |
848 | ffelex_token_where_column (t)); | |
849 | ffebad_here (1, ffesymbol_where_line (s), ffesymbol_where_column (s)); | |
850 | ffebad_finish (); | |
851 | } | |
852 | ||
853 | if (ffesymbol_attr (s, FFESYMBOL_attrANY)) | |
854 | return; | |
855 | ||
856 | ffesymbol_signal_change (s); /* May need to back up to previous version. */ | |
857 | if ((ffesymbol_attrs (s) & FFESYMBOL_attrsCBLOCK) | |
858 | || (ffesymbol_kind (s) == FFEINFO_kindNAMELIST)) | |
859 | ffebld_end_list (ffesymbol_ptr_to_listbottom (s)); | |
860 | ffesymbol_set_attr (s, FFESYMBOL_attrANY); | |
861 | ffesymbol_set_info (s, ffeinfo_new_any ()); | |
862 | ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); | |
863 | if (s->check_state == FFESYMBOL_checkstatePENDING_) | |
864 | ffelex_token_kill (s->check_token); | |
865 | s->check_state = FFESYMBOL_checkstateCHECKED_; | |
866 | s = ffecom_sym_learned (s); | |
867 | ffesymbol_signal_unreported (s); | |
868 | } | |
869 | ||
870 | void | |
871 | ffesymbol_init_0 () | |
872 | { | |
873 | ffesymbolAttrs attrs = FFESYMBOL_attrsetNONE; | |
874 | ||
875 | assert (FFESYMBOL_state == ARRAY_SIZE (ffesymbol_state_name_)); | |
876 | assert (FFESYMBOL_attr == ARRAY_SIZE (ffesymbol_attr_name_)); | |
877 | assert (attrs == FFESYMBOL_attrsetNONE); | |
878 | attrs = ((ffesymbolAttrs) 1 << FFESYMBOL_attr); | |
879 | assert (attrs != 0); | |
880 | } | |
881 | ||
882 | void | |
883 | ffesymbol_init_1 () | |
884 | { | |
885 | #if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalFILE_ | |
886 | ffesymbol_global_ = ffename_space_new (ffe_pool_file ()); | |
887 | #endif | |
888 | } | |
889 | ||
890 | void | |
891 | ffesymbol_init_2 () | |
892 | { | |
893 | } | |
894 | ||
895 | void | |
896 | ffesymbol_init_3 () | |
897 | { | |
898 | #if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_ | |
899 | ffesymbol_global_ = ffename_space_new (ffe_pool_program_unit ()); | |
900 | #endif | |
901 | ffesymbol_local_ = ffename_space_new (ffe_pool_program_unit ()); | |
902 | } | |
903 | ||
904 | void | |
905 | ffesymbol_init_4 () | |
906 | { | |
907 | ffesymbol_sfunc_ = ffename_space_new (ffe_pool_program_unit ()); | |
908 | } | |
909 | ||
910 | /* Look up a local entity. | |
911 | ||
912 | Retrieves the ffesymbol for the specified local entity, or returns NULL | |
913 | if no local entity by that name exists. */ | |
914 | ||
915 | ffesymbol | |
916 | ffesymbol_lookup_local (ffelexToken t) | |
917 | { | |
918 | ffename n; | |
919 | ffesymbol s; | |
920 | ||
921 | assert (t != NULL); | |
922 | ||
923 | n = ffename_lookup (ffesymbol_local_, t); | |
924 | if (n == NULL) | |
925 | return NULL; | |
926 | ||
927 | s = ffename_symbol (n); | |
928 | return s; /* May be NULL here, too. */ | |
929 | } | |
930 | ||
931 | /* Registers the symbol as one that is referenced by the | |
932 | current program unit. Currently applies only to | |
933 | symbols known to have global interest (globals and | |
934 | intrinsics). | |
935 | ||
936 | s is the (global/intrinsic) symbol referenced; t is the | |
937 | referencing token; explicit is TRUE if the reference | |
938 | is, e.g., INTRINSIC FOO. */ | |
939 | ||
940 | void | |
941 | ffesymbol_reference (ffesymbol s, ffelexToken t, bool explicit) | |
942 | { | |
943 | ffename gn; | |
944 | ffesymbol gs = NULL; | |
945 | ffeinfoKind kind; | |
946 | ffeinfoWhere where; | |
947 | bool okay; | |
948 | ||
949 | if (ffesymbol_retractable_) | |
950 | return; | |
951 | ||
952 | if (t == NULL) | |
953 | t = ffename_token (s->name); /* Use the first reference in this program unit. */ | |
954 | ||
955 | kind = ffesymbol_kind (s); | |
956 | where = ffesymbol_where (s); | |
957 | ||
958 | if (where == FFEINFO_whereINTRINSIC) | |
959 | { | |
960 | ffeglobal_ref_intrinsic (s, t, | |
961 | explicit | |
962 | || s->explicit_where | |
963 | || ffeintrin_is_standard (s->generic, s->specific)); | |
964 | return; | |
965 | } | |
966 | ||
967 | if ((where != FFEINFO_whereGLOBAL) | |
968 | && ((where != FFEINFO_whereLOCAL) | |
969 | || ((kind != FFEINFO_kindFUNCTION) | |
970 | && (kind != FFEINFO_kindSUBROUTINE)))) | |
971 | return; | |
972 | ||
973 | gn = ffename_lookup (ffesymbol_global_, t); | |
974 | if (gn != NULL) | |
975 | gs = ffename_symbol (gn); | |
976 | if ((gs != NULL) && (gs != s)) | |
977 | { | |
978 | /* We have just discovered another global symbol with the same name | |
979 | but a different `nature'. Complain. Note that COMMON /FOO/ can | |
980 | coexist with local symbol FOO, e.g. local variable, just not with | |
981 | CALL FOO, hence the separate namespaces. */ | |
982 | ||
983 | ffesymbol_error (gs, t); | |
984 | ffesymbol_error (s, NULL); | |
985 | return; | |
986 | } | |
987 | ||
988 | switch (kind) | |
989 | { | |
990 | case FFEINFO_kindBLOCKDATA: | |
991 | okay = ffeglobal_ref_blockdata (s, t); | |
992 | break; | |
993 | ||
994 | case FFEINFO_kindSUBROUTINE: | |
995 | okay = ffeglobal_ref_subroutine (s, t); | |
996 | break; | |
997 | ||
998 | case FFEINFO_kindFUNCTION: | |
999 | okay = ffeglobal_ref_function (s, t); | |
1000 | break; | |
1001 | ||
1002 | case FFEINFO_kindNONE: | |
1003 | okay = ffeglobal_ref_external (s, t); | |
1004 | break; | |
1005 | ||
1006 | default: | |
1007 | assert ("bad kind in global ref" == NULL); | |
1008 | return; | |
1009 | } | |
1010 | ||
1011 | if (! okay) | |
1012 | ffesymbol_error (s, NULL); | |
1013 | } | |
1014 | ||
1015 | /* Report info on the symbol for debugging purposes. */ | |
1016 | ||
8b45da67 | 1017 | #if FFECOM_targetCURRENT == FFECOM_targetFFE |
5ff904cd JL |
1018 | ffesymbol |
1019 | ffesymbol_report (ffesymbol s) | |
1020 | { | |
1021 | ffeinfoKind k; | |
1022 | ffeinfoWhere w; | |
1023 | ||
1024 | assert (s != NULL); | |
1025 | ||
1026 | if (s->reported) | |
1027 | return s; | |
1028 | ||
1029 | s->reported = TRUE; | |
1030 | ||
1031 | if (ffeinfo_size (s->info) != FFETARGET_charactersizeNONE) | |
1032 | fprintf (dmpout, "\"%s\": %s %s %d%s%s*%" ffetargetCharacterSize_f "u", | |
1033 | ffesymbol_text (s), | |
1034 | ffesymbol_state_string (s->state), | |
1035 | ffesymbol_attrs_string (s->attrs), | |
1036 | (int) ffeinfo_rank (s->info), | |
1037 | ffeinfo_basictype_string (ffeinfo_basictype (s->info)), | |
1038 | ffeinfo_kindtype_string (ffeinfo_kindtype (s->info)), | |
1039 | ffeinfo_size (s->info)); | |
1040 | else | |
1041 | fprintf (dmpout, "\"%s\": %s %s %d%s%s", | |
1042 | ffesymbol_text (s), | |
1043 | ffesymbol_state_string (s->state), | |
1044 | ffesymbol_attrs_string (s->attrs), | |
1045 | (int) ffeinfo_rank (s->info), | |
1046 | ffeinfo_basictype_string (ffeinfo_basictype (s->info)), | |
1047 | ffeinfo_kindtype_string (ffeinfo_kindtype (s->info))); | |
1048 | if ((k = ffeinfo_kind (s->info)) != FFEINFO_kindNONE) | |
1049 | fprintf (dmpout, "/%s", ffeinfo_kind_string (k)); | |
1050 | if ((w = ffeinfo_where (s->info)) != FFEINFO_whereNONE) | |
1051 | fprintf (dmpout, "@%s", ffeinfo_where_string (w)); | |
1052 | fputc ('\n', dmpout); | |
1053 | ||
1054 | if (s->dims != NULL) | |
1055 | { | |
1056 | fprintf (dmpout, " dims: "); | |
1057 | ffebld_dump (s->dims); | |
1058 | fputs ("\n", dmpout); | |
1059 | } | |
1060 | ||
1061 | if (s->extents != NULL) | |
1062 | { | |
1063 | fprintf (dmpout, " extents: "); | |
1064 | ffebld_dump (s->extents); | |
1065 | fputs ("\n", dmpout); | |
1066 | } | |
1067 | ||
1068 | if (s->dim_syms != NULL) | |
1069 | { | |
1070 | fprintf (dmpout, " dim syms: "); | |
1071 | ffebld_dump (s->dim_syms); | |
1072 | fputs ("\n", dmpout); | |
1073 | } | |
1074 | ||
1075 | if (s->array_size != NULL) | |
1076 | { | |
1077 | fprintf (dmpout, " array size: "); | |
1078 | ffebld_dump (s->array_size); | |
1079 | fputs ("\n", dmpout); | |
1080 | } | |
1081 | ||
1082 | if (s->init != NULL) | |
1083 | { | |
1084 | fprintf (dmpout, " init-value: "); | |
1085 | if (ffebld_op (s->init) == FFEBLD_opANY) | |
1086 | fputs ("<any>\n", dmpout); | |
1087 | else | |
1088 | { | |
1089 | ffebld_dump (s->init); | |
1090 | fputs ("\n", dmpout); | |
1091 | } | |
1092 | } | |
1093 | ||
1094 | if (s->accretion != NULL) | |
1095 | { | |
1096 | fprintf (dmpout, " accretion (%" ffetargetOffset_f "d left): ", | |
1097 | s->accretes); | |
1098 | ffebld_dump (s->accretion); | |
1099 | fputs ("\n", dmpout); | |
1100 | } | |
1101 | else if (s->accretes != 0) | |
1102 | fprintf (dmpout, " accretes!! = %" ffetargetOffset_f "d left\n", | |
1103 | s->accretes); | |
1104 | ||
1105 | if (s->dummy_args != NULL) | |
1106 | { | |
1107 | fprintf (dmpout, " dummies: "); | |
1108 | ffebld_dump (s->dummy_args); | |
1109 | fputs ("\n", dmpout); | |
1110 | } | |
1111 | ||
1112 | if (s->namelist != NULL) | |
1113 | { | |
1114 | fprintf (dmpout, " namelist: "); | |
1115 | ffebld_dump (s->namelist); | |
1116 | fputs ("\n", dmpout); | |
1117 | } | |
1118 | ||
1119 | if (s->common_list != NULL) | |
1120 | { | |
1121 | fprintf (dmpout, " common-list: "); | |
1122 | ffebld_dump (s->common_list); | |
1123 | fputs ("\n", dmpout); | |
1124 | } | |
1125 | ||
1126 | if (s->sfunc_expr != NULL) | |
1127 | { | |
1128 | fprintf (dmpout, " sfunc expression: "); | |
1129 | ffebld_dump (s->sfunc_expr); | |
1130 | fputs ("\n", dmpout); | |
1131 | } | |
1132 | ||
1133 | if (s->is_save) | |
1134 | { | |
1135 | fprintf (dmpout, " SAVEd\n"); | |
1136 | } | |
1137 | ||
1138 | if (s->is_init) | |
1139 | { | |
1140 | fprintf (dmpout, " initialized\n"); | |
1141 | } | |
1142 | ||
1143 | if (s->do_iter) | |
1144 | { | |
1145 | fprintf (dmpout, " DO-loop iteration variable (currently)\n"); | |
1146 | } | |
1147 | ||
1148 | if (s->explicit_where) | |
1149 | { | |
1150 | fprintf (dmpout, " Explicit INTRINSIC/EXTERNAL\n"); | |
1151 | } | |
1152 | ||
1153 | if (s->namelisted) | |
1154 | { | |
1155 | fprintf (dmpout, " Namelisted\n"); | |
1156 | } | |
1157 | ||
1158 | if (s->common != NULL) | |
1159 | { | |
1160 | fprintf (dmpout, " COMMON area: %s\n", ffesymbol_text (s->common)); | |
1161 | } | |
1162 | ||
1163 | if (s->equiv != NULL) | |
1164 | { | |
1165 | fprintf (dmpout, " EQUIVALENCE information: "); | |
1166 | ffeequiv_dump (s->equiv); | |
1167 | fputs ("\n", dmpout); | |
1168 | } | |
1169 | ||
1170 | if (s->storage != NULL) | |
1171 | { | |
1172 | fprintf (dmpout, " Storage: "); | |
1173 | ffestorag_dump (s->storage); | |
1174 | fputs ("\n", dmpout); | |
1175 | } | |
1176 | ||
1177 | return s; | |
1178 | } | |
8b45da67 | 1179 | #endif |
5ff904cd JL |
1180 | |
1181 | /* Report info on the symbols. */ | |
1182 | ||
8b45da67 | 1183 | #if FFECOM_targetCURRENT == FFECOM_targetFFE |
5ff904cd JL |
1184 | void |
1185 | ffesymbol_report_all () | |
1186 | { | |
1187 | ffename_space_drive_symbol (ffesymbol_sfunc_, ffesymbol_report); | |
1188 | ffename_space_drive_symbol (ffesymbol_local_, ffesymbol_report); | |
1189 | ffename_space_drive_symbol (ffesymbol_global_, ffesymbol_report); | |
1190 | } | |
8b45da67 | 1191 | #endif |
5ff904cd JL |
1192 | |
1193 | /* Resolve symbol that has become known intrinsic or non-intrinsic. */ | |
1194 | ||
1195 | void | |
1196 | ffesymbol_resolve_intrin (ffesymbol s) | |
1197 | { | |
1198 | char c; | |
1199 | ffebad bad; | |
1200 | ||
1201 | if (!ffesrc_check_symbol ()) | |
1202 | return; | |
1203 | if (s->check_state != FFESYMBOL_checkstatePENDING_) | |
1204 | return; | |
1205 | if (ffebad_inhibit ()) | |
1206 | return; /* We'll get back to this later. */ | |
1207 | ||
1208 | if (ffesymbol_where (s) != FFEINFO_whereINTRINSIC) | |
1209 | { | |
1210 | bad = ffesymbol_check_token_ (s->check_token, &c); | |
1211 | assert (bad != FFEBAD); /* How did this suddenly become ok? */ | |
1212 | ffesymbol_whine_state_ (bad, s->check_token, c); | |
1213 | } | |
1214 | ||
1215 | s->check_state = FFESYMBOL_checkstateCHECKED_; | |
1216 | ffelex_token_kill (s->check_token); | |
1217 | } | |
1218 | ||
1219 | /* Retract or cancel retract list. */ | |
1220 | ||
1221 | void | |
1222 | ffesymbol_retract (bool retract) | |
1223 | { | |
1224 | ffesymbolRetract_ r; | |
1225 | ffename name; | |
1226 | ffename other_space_name; | |
1227 | ffesymbol ls; | |
1228 | ffesymbol os; | |
1229 | ||
1230 | assert (ffesymbol_retractable_); | |
1231 | ||
1232 | ffesymbol_retractable_ = FALSE; | |
1233 | ||
1234 | for (r = ffesymbol_retract_first_; r != NULL; r = r->next) | |
1235 | { | |
1236 | ls = r->live; | |
1237 | os = r->symbol; | |
1238 | switch (r->command) | |
1239 | { | |
1240 | case FFESYMBOL_retractcommandDELETE_: | |
1241 | if (retract) | |
1242 | { | |
1243 | ffecom_sym_retract (ls); | |
1244 | name = ls->name; | |
1245 | other_space_name = ls->other_space_name; | |
1246 | ffesymbol_unhook_ (ls); | |
1247 | malloc_kill_ks (FFESYMBOL_SPACE_POOL_, ls, sizeof (*ls)); | |
1248 | if (name != NULL) | |
1249 | ffename_set_symbol (name, NULL); | |
1250 | if (other_space_name != NULL) | |
1251 | ffename_set_symbol (other_space_name, NULL); | |
1252 | } | |
1253 | else | |
1254 | { | |
1255 | ffecom_sym_commit (ls); | |
1256 | ls->have_old = FALSE; | |
1257 | } | |
1258 | break; | |
1259 | ||
1260 | case FFESYMBOL_retractcommandRETRACT_: | |
1261 | if (retract) | |
1262 | { | |
1263 | ffecom_sym_retract (ls); | |
1264 | ffesymbol_unhook_ (ls); | |
1265 | *ls = *os; | |
1266 | malloc_kill_ks (FFESYMBOL_SPACE_POOL_, os, sizeof (*os)); | |
1267 | } | |
1268 | else | |
1269 | { | |
1270 | ffecom_sym_commit (ls); | |
1271 | ffesymbol_unhook_ (os); | |
1272 | malloc_kill_ks (FFESYMBOL_SPACE_POOL_, os, sizeof (*os)); | |
1273 | ls->have_old = FALSE; | |
1274 | } | |
1275 | break; | |
1276 | ||
1277 | default: | |
1278 | assert ("bad command" == NULL); | |
1279 | break; | |
1280 | } | |
1281 | } | |
1282 | } | |
1283 | ||
1284 | /* Return retractable flag. */ | |
1285 | ||
1286 | bool | |
1287 | ffesymbol_retractable () | |
1288 | { | |
1289 | return ffesymbol_retractable_; | |
1290 | } | |
1291 | ||
1292 | /* Set retractable flag, retract pool. | |
1293 | ||
1294 | Between this call and ffesymbol_retract, any changes made to existing | |
1295 | symbols cause the previous versions of those symbols to be saved, and any | |
1296 | newly created symbols to have their previous nonexistence saved. When | |
1297 | ffesymbol_retract is called, this information either is used to retract | |
1298 | the changes and new symbols, or is discarded. */ | |
1299 | ||
1300 | void | |
1301 | ffesymbol_set_retractable (mallocPool pool) | |
1302 | { | |
1303 | assert (!ffesymbol_retractable_); | |
1304 | ||
1305 | ffesymbol_retractable_ = TRUE; | |
1306 | ffesymbol_retract_pool_ = pool; | |
1307 | ffesymbol_retract_list_ = &ffesymbol_retract_first_; | |
1308 | ffesymbol_retract_first_ = NULL; | |
1309 | } | |
1310 | ||
1311 | /* Existing symbol about to be changed; save? | |
1312 | ||
1313 | Call this function before changing a symbol if it is possible that | |
1314 | the current actions may need to be undone (i.e. one of several possible | |
1315 | statement forms are being used to analyze the current system). | |
1316 | ||
1317 | If the "retractable" flag is not set, just return. | |
1318 | Else, if the symbol's "have_old" flag is set, just return. | |
1319 | Else, make a copy of the symbol and add it to the "retract" list, set | |
1320 | the "have_old" flag, and return. */ | |
1321 | ||
1322 | void | |
1323 | ffesymbol_signal_change (ffesymbol s) | |
1324 | { | |
1325 | ffesymbolRetract_ r; | |
1326 | ffesymbol sym; | |
1327 | ||
1328 | if (!ffesymbol_retractable_ || s->have_old) | |
1329 | return; | |
1330 | ||
1331 | r = (ffesymbolRetract_) malloc_new_kp (ffesymbol_retract_pool_, | |
1332 | "FFESYMBOL retract", sizeof (*r)); | |
1333 | r->next = NULL; | |
1334 | r->command = FFESYMBOL_retractcommandRETRACT_; | |
1335 | r->live = s; | |
1336 | r->symbol = sym = (ffesymbol) malloc_new_ks (FFESYMBOL_SPACE_POOL_, | |
1337 | "FFESYMBOL", sizeof (*sym)); | |
1338 | *sym = *s; /* Make an exact copy of the symbol in case | |
1339 | we need it back. */ | |
1340 | sym->info = ffeinfo_use (s->info); | |
1341 | if (s->check_state == FFESYMBOL_checkstatePENDING_) | |
1342 | sym->check_token = ffelex_token_use (s->check_token); | |
1343 | ||
1344 | *ffesymbol_retract_list_ = r; | |
1345 | ffesymbol_retract_list_ = &r->next; | |
1346 | ||
1347 | s->have_old = TRUE; | |
1348 | } | |
1349 | ||
1350 | /* Returns the string based on the state. */ | |
1351 | ||
26f096f9 | 1352 | const char * |
5ff904cd JL |
1353 | ffesymbol_state_string (ffesymbolState state) |
1354 | { | |
1355 | if (state >= ARRAY_SIZE (ffesymbol_state_name_)) | |
1356 | return "?\?\?"; | |
1357 | return ffesymbol_state_name_[state]; | |
1358 | } | |
1359 | ||
1360 | void | |
1361 | ffesymbol_terminate_0 () | |
1362 | { | |
1363 | } | |
1364 | ||
1365 | void | |
1366 | ffesymbol_terminate_1 () | |
1367 | { | |
1368 | #if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalFILE_ | |
1369 | ffename_space_drive_symbol (ffesymbol_global_, ffesymbol_unhook_); | |
1370 | ffename_space_kill (ffesymbol_global_); | |
1371 | ffesymbol_global_ = NULL; | |
1372 | ||
1373 | ffesymbol_kill_manifest_ (); | |
1374 | #endif | |
1375 | } | |
1376 | ||
1377 | void | |
1378 | ffesymbol_terminate_2 () | |
1379 | { | |
1380 | #if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_ | |
1381 | ffesymbol_kill_manifest_ (); | |
1382 | #endif | |
1383 | } | |
1384 | ||
1385 | void | |
1386 | ffesymbol_terminate_3 () | |
1387 | { | |
1388 | #if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_ | |
1389 | ffename_space_drive_symbol (ffesymbol_global_, ffesymbol_unhook_); | |
1390 | ffename_space_kill (ffesymbol_global_); | |
1391 | #endif | |
1392 | ffename_space_drive_symbol (ffesymbol_local_, ffesymbol_unhook_); | |
1393 | ffename_space_kill (ffesymbol_local_); | |
1394 | #if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_ | |
1395 | ffesymbol_global_ = NULL; | |
1396 | #endif | |
1397 | ffesymbol_local_ = NULL; | |
1398 | } | |
1399 | ||
1400 | void | |
1401 | ffesymbol_terminate_4 () | |
1402 | { | |
1403 | ffename_space_drive_symbol (ffesymbol_sfunc_, ffesymbol_unhook_); | |
1404 | ffename_space_kill (ffesymbol_sfunc_); | |
1405 | ffesymbol_sfunc_ = NULL; | |
1406 | } | |
1407 | ||
1408 | /* Update INIT info to TRUE and all equiv/storage too. | |
1409 | ||
1410 | If INIT flag is TRUE, does nothing. Else sets it to TRUE and calls | |
1411 | on the ffeequiv and ffestorag modules to update their INIT flags if | |
1412 | the <s> symbol has those objects, and also updates the common area if | |
1413 | it exists. */ | |
1414 | ||
1415 | void | |
1416 | ffesymbol_update_init (ffesymbol s) | |
1417 | { | |
1418 | ffebld item; | |
1419 | ||
1420 | if (s->is_init) | |
1421 | return; | |
1422 | ||
1423 | s->is_init = TRUE; | |
1424 | ||
1425 | if ((s->equiv != NULL) | |
1426 | && !ffeequiv_is_init (s->equiv)) | |
1427 | ffeequiv_update_init (s->equiv); | |
1428 | ||
1429 | if ((s->storage != NULL) | |
1430 | && !ffestorag_is_init (s->storage)) | |
1431 | ffestorag_update_init (s->storage); | |
1432 | ||
1433 | if ((s->common != NULL) | |
1434 | && (!ffesymbol_is_init (s->common))) | |
1435 | ffesymbol_update_init (s->common); | |
1436 | ||
1437 | for (item = s->common_list; item != NULL; item = ffebld_trail (item)) | |
1438 | { | |
1439 | if (!ffesymbol_is_init (ffebld_symter (ffebld_head (item)))) | |
1440 | ffesymbol_update_init (ffebld_symter (ffebld_head (item))); | |
1441 | } | |
1442 | } | |
1443 | ||
1444 | /* Update SAVE info to TRUE and all equiv/storage too. | |
1445 | ||
1446 | If SAVE flag is TRUE, does nothing. Else sets it to TRUE and calls | |
1447 | on the ffeequiv and ffestorag modules to update their SAVE flags if | |
1448 | the <s> symbol has those objects, and also updates the common area if | |
1449 | it exists. */ | |
1450 | ||
1451 | void | |
1452 | ffesymbol_update_save (ffesymbol s) | |
1453 | { | |
1454 | ffebld item; | |
1455 | ||
1456 | if (s->is_save) | |
1457 | return; | |
1458 | ||
1459 | s->is_save = TRUE; | |
1460 | ||
1461 | if ((s->equiv != NULL) | |
1462 | && !ffeequiv_is_save (s->equiv)) | |
1463 | ffeequiv_update_save (s->equiv); | |
1464 | ||
1465 | if ((s->storage != NULL) | |
1466 | && !ffestorag_is_save (s->storage)) | |
1467 | ffestorag_update_save (s->storage); | |
1468 | ||
1469 | if ((s->common != NULL) | |
1470 | && (!ffesymbol_is_save (s->common))) | |
1471 | ffesymbol_update_save (s->common); | |
1472 | ||
1473 | for (item = s->common_list; item != NULL; item = ffebld_trail (item)) | |
1474 | { | |
1475 | if (!ffesymbol_is_save (ffebld_symter (ffebld_head (item)))) | |
1476 | ffesymbol_update_save (ffebld_symter (ffebld_head (item))); | |
1477 | } | |
1478 | } |