1 /* $Id: symtab.c,v 1.45 2003/08/07 19:37:48 moniot Exp $
2
3 Definitions of symbol table maintenance routines and
4 hash table functions
5
6
7 Copyright (c) 1999 by Robert K. Moniot.
8
9 Permission is hereby granted, free of charge, to any person obtaining a
10 copy of this software and associated documentation files (the "Software"),
11 to deal in the Software without restriction, including without limitation
12 the rights to use, copy, modify, merge, publish, distribute, sublicense,
13 and/or sell copies of the Software, and to permit persons to whom the
14 Software is furnished to do so, subject to the following conditions:
15
16 The above copyright notice and this permission notice shall be included in
17 all copies or substantial portions of the Software.
18
19 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
20 IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
21 FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
22 ROBERT K. MONIOT OR FORDHAM UNIVERSITY BE LIABLE FOR ANY CLAIM, DAMAGES OR
23 OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
24 ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
25 OTHER DEALINGS IN THE SOFTWARE.
26
27 Except as contained in this notice, the name of ftnchek shall not be used
28 in advertising or otherwise to promote the sale, use or other dealings in
29 this Software without prior written authorization from the author.
30
31
32
33 */
34
35 /*
36 I. Symtab
37
38
39 Symbol table routines for Fortran program checker.
40
41 Shared functions defined:
42
43
44 call_func(id,arg) Handles function invocations.
45 call_subr(id,arg) Handles CALL statements.
46 declare_type(id,datatype,size) Handles TYPE statements.
47 def_arg_name(id) Handles func/subr argument lists.
48 def_array_dim(id,arg) Handles dimensioning declarations.
49 def_com_block(id) Handles common blocks and SAVE stmts.
50 def_com_variable(id) Handles common block lists.
51 int def_curr_module(id) Identifies symbol as current module.
52 def_equiv_name(id) Initializes equivalence list items.
53 def_ext_name(id) Handles external lists.
54 def_function(datatype,size,size_text,id,args)
55 Installs function name in global table.
56 def_intrins_name(id) Handles intrinsic lists.
57 def_parameter(id,value) Handles parameter_defn_item
58 def_stmt_function(id) Declares a statement function.
59 do_ASSIGN(id) Handles ASSIGN stmts.
60 do_assigned_GOTO(id) Handles assigned GOTO.
61 do_ENTRY(id,args,hashno) Processes ENTRY statement.
62 do_RETURN(hashno,keyword) Processes RETURN statement.
63 equivalence(id1,id2) equivalences two variables
64 int get_type(symt) Finds out data type of symbol, or uses implicit
65 typing to establish its type.
66 int get_size(symt,type) Finds out size of symbol's datatype.
67 unsigned hash_lookup(s) Looks up identifier in hashtable.
68 init_globals() Initializes global symbol info.
69 init_symtab() Clears local symbol table & removes locals
70 from stringspace. Also restores default
71 implicit data typing.
72 Gsymtab* install_global(t,datatype,storage_class) Installs indentifier in
73 global symbol table.
74 Lsymtab* install_local(t,datatype,storage_class) Installs indentifier in
75 local symbol table.
76 ref_array(id,subscrs) Handles array references
77 ref_variable(id) Handles accessing variable name.
78 set_implicit_type(type,size,c1,c2) Processes IMPLICIT statement.
79 stmt_function_stmt(id) Finishes processing stmt func defn.
80 char * token_name(t) Returns ptr to token's symbol's name.
81 use_actual_arg(id) Handles using a variable as actual arg.
82 use_io_keyword(id_keywd,id_val,class) Handles i/o control specifier.
83 use_len_arg(id) Handles arguments passed to LEN.
84 use_lvalue(id) Handles assignment to a variable.
85 use_parameter(id) Handles data_constant_value &
86 data_repeat_factor.
87 use_variable(id) Sets used-flag for a variable used in expr.
88
89 */
90
91 /* private functions defined:
92 call_external(symt,id,arg) places token list of args into local symtab
93 check_intrins_args(arg, defn) Checks call seq of intrinsic functions
94 check_stmt_function_args(symt,id,arg) ditto for statement functions
95 */
96
97 #include <stdio.h>
98 #include <string.h>
99 #include <ctype.h>
100 #define SYMTAB
101 #include "ftnchek.h"
102 #include "symtab.h"
103 #include "symspace.h"
104 #include "symutils.h"
105 #include "intrins.h"
106 #include "tokdefs.h"
107
108 #ifdef DEVELOPMENT /* for maintaining the program */
109 #define DEBUG_SIZES
110 #endif
111
112
113
114 PROTO(PRIVATE void call_external,( Lsymtab *symt, Token *id, Token *arg ));
115 PROTO(PRIVATE void check_intrins_args,( Token *id, Token *arg ));
116 PROTO(PRIVATE void check_stmt_function_args,( const Lsymtab *symt, Token *id, Token *arg ));
117 PROTO(PRIVATE Lsymtab* install_local,( int h, int datatype, int storage_class ));
118 PROTO(PRIVATE void use_function_arg,( Token *id ));
119 PROTO(PRIVATE void use_len_arg,( Token *id ));
120
121
122
123 #ifdef DEBUG_SIZES
124 PROTO(extern void print_sizeofs,( void )); /* in symtab.c */
125 #endif
126
127
128 /* Apply an attribute to a variable */
129 /* N.B. Legality checking deferred to END */
130 /* N. extra B.: allocatable, pointer, and target flags ignored at present */
131
132 void
apply_attr(Token * id,int attr)133 apply_attr(Token *id, /* token of variable to apply attr to */
134 int attr) /* token class of attr to apply */
135 {
136 int h=id->value.integer;
137 Lsymtab *symt;
138
139 if( (symt=hashtab[h].loc_symtab) == NULL) {
140 symt = install_local(h,type_UNDECL,class_VAR);
141 symt->line_declared = id->line_num;
142 symt->file_declared = inctable_index;
143 }
144
145 /* macro to set an attribute bit in symtab: if already set, flag
146 the error, otherwise set the bit in all equivalenced entries.
147 */
148 #define check_and_set_attr( ATTRBIT ) if( (symt->ATTRBIT) ) { \
149 syntax_error(id->line_num,id->col_num,"redundant"); \
150 msg_tail(keytok_name(attr)); msg_tail("declaration"); } \
151 else { Lsymtab *equiv=symt; \
152 do{ \
153 equiv->ATTRBIT = TRUE; \
154 equiv = equiv->equiv_link; \
155 } while(equiv != symt); }
156
157 switch( attr )
158 {
159 case tok_ALLOCATABLE:
160 check_and_set_attr(allocatable);
161 break;
162 case tok_POINTER:
163 check_and_set_attr(pointer);
164 break;
165 case tok_SAVE:
166 check_and_set_attr(saved);
167 break;
168 case tok_TARGET:
169 check_and_set_attr(target);
170 break;
171 }
172 #undef check_and_set_attr
173 }
174 /* This routine handles the saving of arg lists which
175 is done by call_func and call_subr. Also called
176 by def_namelist to save its variable list. */
177 PRIVATE void
178 #if HAVE_STDC
call_external(Lsymtab * symt,Token * id,Token * arg)179 call_external(Lsymtab *symt, Token *id, Token *arg)
180 #else /* K&R style */
181 call_external(symt,id,arg)
182 Lsymtab *symt;
183 Token *id,*arg;
184 #endif /* HAVE_STDC */
185 {
186 TokenListHeader *TH_ptr;
187
188 /* Insert the new list onto linked list of token lists */
189 TH_ptr= make_TL_head(id);
190
191 TH_ptr->tokenlist = (arg == NULL ? NULL: arg->next_token);
192 TH_ptr->next = symt->info.toklist;
193 symt->info.toklist = TH_ptr;
194 #ifdef DEBUG_EXPRTREES
195 if(debug_latest) {
196 fprintf(list_fd,"\nSubprogram %s :: ",symt->name);
197 if(arg != NULL)
198 print_expr_list(arg->next_token);
199 }
200 #endif
201 } /*call_external*/
202
203 void
204 #if HAVE_STDC
call_func(Token * id,Token * arg)205 call_func(Token *id, Token *arg) /* Process function invocation */
206 #else /* K&R style */
207 call_func(id,arg) /* Process function invocation */
208 Token *id, *arg;
209 #endif /* HAVE_STDC */
210 {
211 int t, h=id->value.integer;
212 Lsymtab *symt;
213 Gsymtab *gsymt;
214 IntrinsInfo *defn;
215
216 if( (symt = (hashtab[h].loc_symtab)) == NULL){
217 symt = install_local(h,type_UNDECL,class_SUBPROGRAM);
218 symt->info.toklist = NULL;
219 }
220 else { /* protect ourself against nonsense */
221 if( symt->array_var || symt->parameter ) {
222 syntax_error(id->line_num,id->col_num,
223 "identifier was previously declared a non-function:");
224 msg_tail(symt->name);
225 symt->array_var = symt->parameter = FALSE;
226 symt->info.toklist = NULL;
227 }
228 }
229
230
231 t = datatype_of(symt->type);
232 /* Symbol seen before: check it & change class */
233
234 if(storage_class_of(symt->type) == class_VAR) {
235 symt->type = type_byte(class_SUBPROGRAM,t);
236 symt->info.toklist = NULL;
237 }
238
239
240 /* See if intrinsic. If so, set flag, save info */
241 if(!symt->external && !symt->intrinsic && !symt->argument
242 && (defn = find_intrinsic(symt->name)) != NULL) {
243 /* First encounter with intrinsic fcn: store info */
244 symt->intrinsic = TRUE;
245 symt->info.intrins_info = defn;
246 }
247
248 /* Update set/used status of variables in arg list. This
249 is deferred to now to allow intrinsics to be treated
250 as pure functions regardless of pure_function flag. */
251
252 if(arg != NULL) {
253 Token *a=arg;
254 intrins_flags_t
255 nonpure, /* flag if function may modify arg */
256 i_len; /* special handling for intrinsic LEN */
257 if(symt->intrinsic) {
258 nonpure = symt->info.intrins_info->intrins_flags&I_NONPURE;
259 i_len = symt->info.intrins_info->intrins_flags&I_LEN;
260 }
261 else {
262 nonpure = ! pure_functions;
263 i_len = FALSE;
264 }
265
266 /* Token list is in reverse order. Restore
267 args to original order. */
268 arg->next_token = reverse_tokenlist(arg->next_token);
269
270 while( (a=a->next_token) != NULL) {
271 if(is_true(ID_EXPR,a->TOK_flags)){
272 if( nonpure ) {
273 /* Treat impure function like subroutine call */
274 use_actual_arg(a);
275 use_variable(a);
276 }
277 else {
278 if(i_len)
279 use_len_arg(a); /* LEN is sui generis */
280 else
281 /* Pure-function invocation checks u-b-s */
282 use_function_arg(a);
283 }
284 }
285 }
286 }
287
288 /* If intrinsic, do checking now. Otherwise, save arg list
289 to be checked later. */
290
291 if(symt->intrinsic) {
292 /* It is intrinsic: check it */
293 if(misc_warn)
294 check_intrins_args(id,arg);
295 }
296 else { /* It is not intrinsic: install in global table */
297 switch(storage_class_of(symt->type)) {
298 case class_SUBPROGRAM:
299 symt->external = TRUE;
300 if((!symt->argument) && (gsymt=(hashtab[h].glob_symtab)) == NULL) {
301 gsymt = install_global(h,type_UNDECL,class_SUBPROGRAM);
302 gsymt->info.arglist = NULL;
303 }
304 /* store arg list in local table */
305 call_external(symt,id,arg);
306 break;
307 case class_STMT_FUNCTION:
308 symt->external = TRUE;
309 if(misc_warn)
310 check_stmt_function_args(symt,id,arg);
311 break;
312 }
313 }
314
315 if(! symt->used_flag) { /* record first line where used */
316 symt->line_used = id->line_num;
317 symt->file_used = inctable_index;
318 }
319
320 symt->used_flag = TRUE;
321 symt->invoked_as_func = TRUE;
322
323 } /*call_func*/
324
325
326 void
327 #if HAVE_STDC
call_subr(Token * id,Token * arg)328 call_subr(Token *id, Token *arg) /* Process call statements */
329 #else /* K&R style */
330 call_subr(id,arg) /* Process call statements */
331 Token *id, *arg;
332 #endif /* HAVE_STDC */
333 {
334 int t, h=id->value.integer;
335 Lsymtab *symt;
336 Gsymtab *gsymt;
337 #ifndef STANDARD_INTRINSICS
338 IntrinsInfo *defn;
339 #endif
340 if( (symt = (hashtab[h].loc_symtab)) == NULL){
341 symt = install_local(h,type_SUBROUTINE,class_SUBPROGRAM);
342 symt->info.toklist = NULL;
343 }
344 else { /* protect ourself against nonsense */
345 if( symt->array_var || symt->parameter ) {
346 syntax_error(id->line_num,id->col_num,
347 "identifier was previously declared a non-subroutine:");
348 msg_tail(symt->name);
349 symt->array_var = symt->parameter = FALSE;
350 symt->info.toklist = NULL;
351 }
352 }
353
354
355 t=datatype_of(symt->type);
356 /* Symbol seen before: check it & change class */
357
358 if( (storage_class_of(symt->type) == class_VAR
359 || symt->external ) && t == type_UNDECL) {
360 t = type_SUBROUTINE;
361 symt->info.toklist = NULL;
362 }
363 symt->type = type_byte(class_SUBPROGRAM,t);
364
365 /* Since nonstandard intrinsics include some subroutines,
366 see if it is in intrinsic list. Or
367 if declared intrinsic, then accept it as such and
368 do checking now. Otherwise, save arg list
369 to be checked later. */
370 #ifndef STANDARD_INTRINSICS
371 if(!symt->external && !symt->intrinsic
372 && (defn = find_intrinsic(symt->name)) != NULL) {
373 /* First encounter with intrinsic fcn: store info */
374 symt->intrinsic = TRUE;
375 symt->info.intrins_info = defn;
376 }
377 #endif
378
379 /* Token list is in reverse order. Restore
380 args to original order. */
381 if(arg != NULL)
382 arg->next_token = reverse_tokenlist(arg->next_token);
383
384 if(symt->intrinsic) {
385 /* It is intrinsic: check it */
386 if(misc_warn)
387 check_intrins_args(id,arg);
388 }
389 else { /* It is not intrinsic: install in global table */
390 symt->external = TRUE;
391 if((!symt->argument) && (gsymt=(hashtab[h].glob_symtab)) == NULL) {
392 gsymt = install_global(h,type_UNDECL,class_SUBPROGRAM);
393 gsymt->info.arglist = NULL;
394 }
395 /* store arg list in local table */
396 call_external(symt,id,arg);
397 }
398
399 if(! symt->used_flag) { /* record first line where used */
400 symt->line_used = id->line_num;
401 symt->file_used = inctable_index;
402 }
403
404 symt->used_flag = TRUE;
405
406 }/*call_subr*/
407
408 /* check out consistency of intrinsic argument list */
409 PRIVATE
410 void
411 #if HAVE_STDC
check_intrins_args(Token * id,Token * arg)412 check_intrins_args(Token *id, Token *arg)
413 #else /* K&R style */
414 check_intrins_args(id, arg)
415 Token *id;
416 Token *arg;
417 #endif /* HAVE_STDC */
418 {
419 int h=id->value.integer;
420 Lsymtab *symt=hashtab[h].loc_symtab;
421 IntrinsInfo *defn=symt->info.intrins_info;
422 unsigned args_given = ((arg == NULL)?0:arg_count(arg->next_token));
423 int numargs;
424 unsigned short flags;
425 Token *t;
426
427 numargs = defn->num_args;
428 flags = defn->intrins_flags;
429
430 /* positive numargs: must agree */
431 if( (numargs >= 0 && (args_given != (unsigned)numargs))
432 /* 1 or 2 arguments allowed */
433 || (numargs == I_1or2 && (args_given != 1 && args_given != 2))
434 /* numargs == -2: 2 or more */
435 || (numargs == I_2up && (args_given < 2))
436 /* 0 or 1 argument allowed */
437 || (numargs == I_0or1 && (args_given != 0 && args_given != 1)) ){
438 LINENO_t linenum;
439 COLNO_t colnum;
440 if(arg==NULL) {linenum=id->line_num; colnum=id->col_num;}
441 else {linenum = arg->line_num; colnum = arg->col_num;}
442
443 syntax_error(linenum,colnum,
444 "wrong number of arguments for intrinsic function");
445 msg_tail(defn->name);
446 }
447 #ifdef DEBUG_EXPRTREES
448 if(debug_latest) {
449 fprintf(list_fd,"\nIntrinsic %s :: ",defn->name);
450 if(arg != NULL)
451 print_expr_list(arg->next_token);
452 }
453 #endif
454 if(arg != NULL && numargs != 0) {
455
456 Token *prev_t, /* one operand in type propagation */
457 fake_op; /* operator in binexpr_type call */
458
459 t = arg->next_token;
460 /* Copy type & size info into result */
461 arg->tclass = t->tclass;
462 arg->tsubclass = t->tsubclass;
463 #ifndef TOK_type
464 arg->TOK_type = t->TOK_type;
465 #endif
466 #ifndef TOK_flags
467 arg->TOK_flags = t->TOK_flags;
468 #endif
469 arg->size = t->size;
470 prev_t = t;
471
472 while(t != NULL) {
473 if(intrins_arg_cmp(defn,t)) {
474 /* Propagate data type thru the list.
475 Resulting type info is stored in
476 args token. */
477 if(prev_t != t && ! (flags & I_MIXED_ARGS) ) {
478 /* Set up a pretend expr term for binexpr */
479 fake_op.tclass = ',';
480 fake_op.line_num = prev_t->line_num;
481 fake_op.col_num = prev_t->col_num;
482 fake_op.src_text = ",";
483
484 binexpr_type(prev_t,&fake_op,t,arg);
485 }
486 prev_t = t;
487 }
488 t = t->next_token;
489 }/* end while */
490
491 }/* end arg != NULL */
492 }/* check_intrins_args */
493
494
495 PRIVATE
496 void
497 #if HAVE_STDC
check_stmt_function_args(const Lsymtab * symt,Token * id,Token * arg)498 check_stmt_function_args(const Lsymtab *symt, Token *id, Token *arg)
499 #else /* K&R style */
500 check_stmt_function_args(symt,id,arg)
501 Lsymtab *symt;
502 Token *id,*arg;
503 #endif /* HAVE_STDC */
504 {
505 unsigned n1,n2,n;
506 unsigned i;
507 Token *t1,*t2;
508
509 t1 = symt->info.toklist->tokenlist;
510 t2 = ((arg==NULL)? NULL: arg->next_token);
511
512 n1 = arg_count(t1);
513 n2 = arg_count(t2);
514
515 if(n1 != n2) {
516 syntax_error(id->line_num,id->col_num,
517 "function invoked with incorrect number of arguments");
518 }
519
520 n = (n1 < n2? n1: n2);
521 for(i=0; i<n; i++) {
522 #ifdef OLDSTUFF
523 if( t1->TOK_type != t2->TOK_type) {
524 syntax_error(t2->line_num,t2->col_num,
525 "function argument is of incorrect datatype");
526 }
527 #else
528 stmt_fun_arg_cmp(symt,t1,t2);
529 #endif
530 t1 = t1->next_token;
531 t2 = t2->next_token;
532 }
533 }
534
535
536 void
537 #if HAVE_STDC
declare_type(Token * id,int datatype,long int size,char * size_text)538 declare_type(Token *id, int datatype, long int size, char *size_text)
539 #else /* K&R style */
540 declare_type(id,datatype,size,size_text)
541 Token *id;
542 int datatype;
543 long size;
544 char *size_text;
545 #endif /* HAVE_STDC */
546 {
547 int h=id->value.integer;
548 Lsymtab *symt=hashtab[h].loc_symtab;
549
550 if( (symt) == NULL) {
551 symt = install_local(h,datatype,class_VAR);
552 symt->size = size;
553 symt->size_is_adjustable = id->size_is_adjustable;
554 symt->size_is_expression = id->size_is_expression;
555 symt->line_declared = id->line_num;
556 symt->file_declared = inctable_index;
557 }
558 else { /* Symbol has been seen before: check it */
559
560 /* Intrinsic: see if type is consistent */
561 if( symt->intrinsic ) {
562 IntrinsInfo *defn = symt->info.intrins_info;
563 int rettype = defn->result_type,
564 argtype = defn->arg_type;
565 /* N.B. this test catches many but not all errors */
566 if( (rettype != type_GENERIC && datatype != rettype)
567 || (rettype == type_GENERIC && !((1<<datatype) & argtype)) ){
568 if(misc_warn) {
569 warning(id->line_num,id->col_num,
570 "Declared type ");
571 msg_tail(type_name[datatype]);
572 msg_tail(" is invalid for intrinsic function: ");
573 msg_tail(symt->name);
574 }
575 }
576 }
577
578 if(datatype_of(symt->type) != type_UNDECL) {
579 syntax_error(id->line_num,id->col_num,
580 "symbol redeclared: ");
581 msg_tail(symt->name);
582 }
583 else {
584 /* Now give it the declared type */
585 symt->type = type_byte(storage_class_of(symt->type),datatype);
586 symt->size = size;
587 symt->size_is_adjustable = id->size_is_adjustable;
588 symt->size_is_expression = id->size_is_expression;
589 /* Type declaration overrides implicit
590 declarations as line where declared.
591 */
592 symt->line_declared = id->line_num;
593 symt->file_declared = inctable_index;
594 }
595
596 /* Issue error if already defined as a parameter */
597 if( symt->parameter ) {
598 syntax_error(id->line_num,id->col_num,
599 "type declaration must precede PARAMETER definition");
600 }
601 }
602
603 /* If character type, save the source text of the size
604 specification. If it is an array already
605 dimensioned, add size_text to tail of src.textvec,
606 otherwise place size_text in src.text if it is
607 character type, except for parameter, which
608 shouldn't happen.
609 */
610
611 if( datatype_of(symt->type) == type_STRING ) {
612 if(symt->array_var) {
613 int i, dims = array_dims(symt->info.array_dim);
614 char **tvec = new_textvec(dims+1);
615
616 for(i=0; i<dims; i++) /* Copy the old list over */
617 tvec[i] = symt->src.textvec[i];
618
619 tvec[dims] = size_text; /* Copy size text to new last element */
620
621 free_textvec(symt->src.textvec); /* Free the old list */
622
623 symt->src.textvec = tvec; /* Replace old list with new */
624 }
625 else if( ! symt->parameter ) {
626 symt->src.text = size_text;
627 }
628 }
629
630 #ifdef DEBUG_EXPRTREES
631 if(debug_latest) {
632 fprintf(list_fd,"\n %s",type_table[datatype]);
633 size_text = get_size_text(symt,0);
634 if(size_text != NULL) {
635 fprintf(list_fd," * %s",size_text);
636 }
637 else {
638 if(symt->size != size_DEFAULT)
639 fprintf(list_fd," * %d",symt->size);
640 }
641 fprintf(list_fd," %s",symt->name);
642 }
643 #endif
644
645 /* Under -port=long-string warn if char size > 255 */
646 if(port_long_string) {
647 if(datatype == type_STRING && size > 255)
648 nonportable(id->line_num,id->col_num,
649 "character variable length exceeds 255");
650 }
651 }/*declare_type*/
652
653 void
654 #if HAVE_STDC
def_arg_name(Token * id)655 def_arg_name(Token *id) /* Process items in argument list */
656 #else /* K&R style */
657 def_arg_name(id) /* Process items in argument list */
658 #endif /* HAVE_STDC */
659
660 #if HAVE_STDC
661 #else /* K&R style */
662 Token *id;
663 #endif /* HAVE_STDC */
664 {
665 int h=id->value.integer;
666 Lsymtab *symt;
667
668 if( (symt=hashtab[h].loc_symtab) == NULL) {
669 symt = install_local(h,type_UNDECL,class_VAR);
670 symt->line_declared = id->line_num;
671 symt->file_declared = inctable_index;
672 }
673 else { /* Symbol has been seen before: check it */
674
675 }
676 symt->argument = TRUE;
677 }/*def_arg_name*/
678
679
680 void
681 #if HAVE_STDC
def_array_dim(Token * id,Token * arg)682 def_array_dim(Token *id, Token *arg) /* Process dimension lists */
683 /* arg previously defined as int */
684 #else /* K&R style */
685 def_array_dim(id,arg) /* Process dimension lists */
686 Token *id,*arg; /* arg previously defined as int */
687 #endif /* HAVE_STDC */
688 {
689 int h=id->value.integer;
690 Lsymtab *symt;
691
692
693 if( (symt=hashtab[h].loc_symtab) == NULL) {
694 symt = install_local(h,type_UNDECL,class_VAR);
695 symt->line_declared = id->line_num;
696 symt->file_declared = inctable_index;
697 }
698 else { /* Symbol has been seen before: check it */
699 if(storage_class_of(symt->type) != class_VAR ||
700 symt->parameter || symt->entry_point) {
701 syntax_error(id->line_num,id->col_num,
702 "Entity cannot be dimensioned: ");
703 msg_tail(symt->name);
704 return;
705 }
706 }
707
708 symt->array_var = TRUE;
709 if(!equivalence_flag){ /* some checking should be done here */
710 if(symt->info.array_dim != 0)
711 syntax_error(id->line_num,id->col_num,
712 "Array redimensioned");
713 else
714 symt->info.array_dim = array_dim_info(arg->TOK_dims,
715 arg->TOK_elts);
716
717 }
718
719 /* Save text of dimension exprs in a list of strings
720 in symtab entry. If array is of type character,
721 the text of size expression is already in src.text,
722 and is saved at tail of the list of dim strings. */
723
724 {
725 int i, dims=arg->TOK_dims,
726 is_char = (datatype_of(symt->type) == type_STRING);
727 char **tvec;
728 char *size_text=symt->src.text;
729 Token *t;
730 int auto_array=FALSE; /* records whether automatic array */
731 /* Restore dim list to correct order */
732 arg->next_token = reverse_tokenlist(arg->next_token);
733
734 symt->src.textvec = tvec = new_textvec(is_char?dims+1:dims);
735
736 /* Store dimension expr text in list */
737 for(i=0, t=arg->next_token; i<dims; i++, t=t->next_token) {
738 tvec[i] = ( t->left_token == NULL ?
739 new_tree_text(t):
740 new_tree_text(t->left_token) );
741
742 /* Do some -f77 checking while we're here */
743 if( !symt->argument && !is_true(PARAMETER_EXPR,t->TOK_flags) ) {
744 /* Section 5.1.2.1 */
745 auto_array = TRUE;
746 if(f77_automatic_array ) {
747 nonstandard(t->line_num,t->col_num,0,0);
748 msg_tail(": local array cannot have variable size");
749 }
750 }
751 }
752 /* Novices sometimes put FUNCTION decl late.
753 Only likely in a type declaration stmt.
754 */
755 if(auto_array && novice_help && curr_stmt_class != tok_DIMENSION
756 && curr_stmt_class != tok_COMMON
757 && strncmp(symt->name,"FUNCTION",8) == 0) {
758 warning(id->line_num,id->col_num,
759 "Possible intended function declaration is not first line of module");
760 }
761 /* If character type, store size expr
762 text in tail of list. */
763 if(is_char)
764 tvec[dims] = size_text;
765
766 #ifdef DEBUG_EXPRTREES
767 if(debug_latest) {
768 int type=datatype_of(symt->type);
769 fprintf(list_fd,"\n %s",
770 (type == type_UNDECL)?"DIMENSION":type_table[type]);
771 if(is_char)
772 fprintf(list_fd," * %s",symt->src.textvec[dims]);
773
774 fprintf(list_fd," %s ( ",symt->name);
775 for(i=0; i<dims; i++) {
776 fprintf(list_fd,"%s",symt->src.textvec[i]);
777 if(i < dims-1)
778 fprintf(list_fd," , ");
779 }
780 fprintf(list_fd," )");
781 }
782 #endif
783
784 }
785
786 }/*def_array_dim*/
787
788
789 void
790 #if HAVE_STDC
def_com_block(Token * id,Token * comlist)791 def_com_block(Token *id, Token *comlist) /* Process common blocks and save_stmt */
792 #else /* K&R style */
793 def_com_block(id,comlist) /* Process common blocks and save_stmt */
794 Token *id, *comlist;
795 #endif /* HAVE_STDC */
796
797 {
798 int h=id->value.integer;
799 Lsymtab *symt;
800 Gsymtab *gsymt;
801 TokenListHeader *TH_ptr;
802 extern LINENO_t true_prev_stmt_line_num;/* set by fortran.y */
803
804 /* Install name in global symbol table */
805 if( (gsymt=hashtab[h].com_glob_symtab) == NULL) {
806 gsymt = install_global(h,type_COMMON_BLOCK,class_COMMON_BLOCK);
807 gsymt->info.comlist = NULL;
808 }
809
810
811 if( (symt = hashtab[h].com_loc_symtab) == NULL){
812 symt = install_local(h,type_COMMON_BLOCK,class_COMMON_BLOCK);
813 symt->info.toklist = NULL;
814 }
815
816 /* Record 1st location of declaration */
817 if( symt->info.toklist == NULL ) {
818 symt->line_declared = id->line_num;
819 symt->file_declared = inctable_index;
820 }
821
822 if(pretty_multiple_common) {
823
824 /* Flag declarations of same block in separate statements
825 unless separated only by comments. Use front token
826 of previous tokenlist which is last token of decl. */
827 if( symt->info.toklist != NULL
828 && symt->info.toklist->tokenlist->line_num < true_prev_stmt_line_num) {
829 ugly_code(id->line_num,id->col_num,
830 "Common block declared in more than one statement");
831 }
832 }
833
834 /* Insert the new list onto linked list of token lists */
835 if(comlist != NULL) {
836 /* Will be NULL only for SAVE, in which case skip */
837 TH_ptr= make_TL_head(id);
838
839 TH_ptr->tokenlist = comlist->next_token;
840 TH_ptr->next = symt->info.toklist;
841 symt->info.toklist = TH_ptr;
842 {
843 /* For each variable in the list, record a pointer
844 to this common block and variable's index in
845 the block. Note that token list is still in
846 reverse order at this time, so we count backwards.
847 */
848 Token *c = comlist->next_token;
849 int indx;
850 /* Add to the block's total count, and
851 start indexing there. */
852 indx = (symt->common_index += arg_count(c));
853 while(c != NULL) {
854 Lsymtab *com_var = hashtab[c->value.integer].loc_symtab;
855 com_var->common_block = gsymt;
856 com_var->common_index = indx--;
857 c = c->next_token;
858 }
859 }
860 }
861
862 if(! symt->used_flag) { /* record first line where used */
863 symt->line_used = id->line_num;
864 symt->file_used = inctable_index;
865 }
866
867 if(! symt->set_flag) { /* record first line where set */
868 symt->line_set = id->line_num;
869 symt->file_set = inctable_index;
870 }
871
872 symt->set_flag = TRUE;
873 symt->used_flag = TRUE;
874 }/*def_com_block*/
875
876
877 void
878 #if HAVE_STDC
def_com_variable(Token * id)879 def_com_variable(Token *id) /* Process items in common block list */
880 #else /* K&R style */
881 def_com_variable(id) /* Process items in common block list */
882 Token *id;
883 #endif /* HAVE_STDC */
884 {
885 int h=id->value.integer;
886 Lsymtab *symt;
887
888 if( (symt=hashtab[h].loc_symtab) == NULL) {
889 symt = install_local(h,type_UNDECL,class_VAR);
890 symt->line_declared = id->line_num;
891 symt->file_declared = inctable_index;
892 }
893 else { /* Symbol has been seen before: check it */
894 if(symt->common_var /* Already in common? */
895 /* But if it is equivalenced, suppress
896 the warning. Equivs in common are not
897 handled in present version. */
898 && symt->equiv_link == symt ) {
899 syntax_error(id->line_num,id->col_num,
900 "Variable cannot be in common twice");
901 }
902 else if(symt->entry_point || symt->parameter ||
903 symt->argument || symt->external || symt->intrinsic) {
904 syntax_error(id->line_num,id->col_num,
905 "Item cannot be placed in common");
906 return;
907 }
908 if(symt->size == size_ADJUSTABLE) { /* CHARACTER *(*) */
909 syntax_error(id->line_num,id->col_num,
910 "Common variable cannot have adjustable size");
911 symt->size = 1;
912 }
913 }
914 { /* set flags for all equivalenced vars */
915 Lsymtab *equiv=symt;
916 do{
917 equiv->common_var = TRUE; /* set the flag even if not legit */
918 equiv = equiv->equiv_link;
919 } while(equiv != symt);
920 }
921
922 }/*def_com_variable*/
923
924
925 /* This guy sets the flag in symbol table saying the id is the
926 current module. It returns the hash code for later reference.
927 Also bookmarks the source line so the declaration can be found
928 in src buffer (currently only used by mkhtml).
929 */
930 int
931 #if HAVE_STDC
def_curr_module(Token * id)932 def_curr_module(Token *id)
933 #else /* K&R style */
934 def_curr_module(id)
935 Token *id;
936 #endif /* HAVE_STDC */
937 {
938 int hashno = id->value.integer;
939 hashtab[hashno].loc_symtab->is_current_module = TRUE;
940
941 mark_module_srcline(id->line_num); /* save mkhtml_bookmark */
942
943 return hashno;
944 }/*def_curr_module*/
945
946
947 void
def_do_variable(Token * id)948 def_do_variable(Token *id) /* Treat DO index variable in DO stmt */
949 {
950 int h=id->value.integer;
951 Lsymtab *symt;
952 if((symt=hashtab[h].loc_symtab) == NULL) {
953 symt = install_local(h,type_UNDECL,class_VAR);
954 symt->line_declared = id->line_num;
955 symt->file_declared = inctable_index;
956 }
957 else {
958 if(symt->active_do_var) {
959 syntax_error(id->line_num,id->col_num,
960 "DO variable is already in use in an enclosing DO loop");
961 }
962 }
963
964 { /* set flags for all equivalenced vars */
965 Lsymtab *equiv=symt;
966 do{
967 if(! equiv->set_flag) { /* record first line where set */
968 equiv->line_set = id->line_num;
969 equiv->file_set = inctable_index;
970 }
971 if(! equiv->used_flag) { /* record first line where used */
972 equiv->line_used = id->line_num;
973 equiv->file_used = inctable_index;
974 }
975 equiv->set_flag = TRUE;
976 equiv->assigned_flag = TRUE;
977 equiv->used_flag = TRUE;
978 equiv->active_do_var = TRUE;
979 equiv = equiv->equiv_link;
980 } while(equiv != symt);
981 }
982 }
983
984
985 void
986 #if HAVE_STDC
def_equiv_name(Token * id)987 def_equiv_name(Token *id) /* Process equivalence list elements */
988 #else /* K&R style */
989 def_equiv_name(id) /* Process equivalence list elements */
990 Token *id;
991 #endif /* HAVE_STDC */
992 {
993 ref_variable(id); /* Put it in symtab */
994 /* No other action needed: processing of equiv pairs is
995 done by equivalence() */
996 }/*def_equiv_name*/
997
998
999
1000 void
1001 #if HAVE_STDC
def_ext_name(Token * id)1002 def_ext_name(Token *id) /* Process external lists */
1003 #else /* K&R style */
1004 def_ext_name(id) /* Process external lists */
1005 Token *id;
1006 #endif /* HAVE_STDC */
1007 {
1008 int h=id->value.integer;
1009 Lsymtab *symt;
1010
1011 if( (symt = hashtab[h].loc_symtab) == NULL){
1012 symt = install_local(h,type_UNDECL,class_SUBPROGRAM);
1013 symt->info.toklist = NULL;
1014 symt->line_declared = id->line_num;
1015 symt->file_declared = inctable_index;
1016 }
1017 else if(symt->entry_point){ /* protect ourself from nonsense */
1018 syntax_error(id->line_num,id->col_num,
1019 "Subprogram cannot declare itself external:");
1020 msg_tail(symt->name);
1021 return;
1022 }
1023 else if(symt->array_var || symt->parameter){ /* worse nonsense */
1024 syntax_error(id->line_num,id->col_num,
1025 "Identifier was previously declared non-external:");
1026 msg_tail(symt->name);
1027 return;
1028 }
1029 else {
1030 /* Symbol seen before: check it & change class */
1031
1032 if(storage_class_of(symt->type) == class_VAR) {
1033 symt->info.toklist = NULL;
1034 }
1035 symt->type = type_byte(class_SUBPROGRAM,datatype_of(symt->type));
1036 }
1037
1038 if(symt->intrinsic){
1039 syntax_error(id->line_num,id->col_num,
1040 "Cannot declare same subprogram both intrinsic and external:");
1041 msg_tail(symt->name);
1042 }
1043 else{
1044 symt->external = TRUE;
1045 if(!symt->argument){
1046 TokenListHeader *TH_ptr;
1047 Gsymtab *gsymt;
1048 if( (gsymt=hashtab[h].glob_symtab) == NULL) {
1049 gsymt = install_global(h,type_UNDECL,class_SUBPROGRAM);
1050 gsymt->info.arglist = NULL;
1051 }
1052 TH_ptr=make_TL_head(id);
1053
1054 TH_ptr->external_decl = TRUE;
1055 TH_ptr->next = symt->info.toklist;
1056 symt->info.toklist = TH_ptr;
1057 }
1058 }
1059 symt->declared_external = TRUE;
1060
1061 }/*def_ext_name*/
1062
1063
1064
1065 void
1066 #if HAVE_STDC
def_function(int datatype,long int size,char * size_text,Token * id,Token * args)1067 def_function(int datatype, long int size, char *size_text, Token *id, Token *args)
1068 #else /* K&R style */
1069 def_function(datatype,size,size_text,id,args)
1070 #endif /* HAVE_STDC */
1071 /* Installs function or subroutine name */
1072 #if HAVE_STDC
1073 /* in global table */
1074 #else /* K&R style */
1075 int datatype; /* in global table */
1076 long size;
1077 char *size_text;
1078 Token *id,*args;
1079 #endif /* HAVE_STDC */
1080 {
1081 int storage_class;
1082 int h=id->value.integer;
1083 Lsymtab *symt;
1084 Gsymtab *gsymt;
1085 TokenListHeader *TH_ptr;
1086 storage_class = class_SUBPROGRAM;
1087
1088 if((symt = (hashtab[h].loc_symtab)) == NULL) {
1089 /* Symbol is new to local symtab: install it.
1090 Since this is the current routine, it has
1091 storage class of a variable. */
1092 symt = install_local(h,datatype,class_VAR);
1093 symt->line_declared = id->line_num;
1094 symt->file_declared = inctable_index;
1095 symt->size = size;
1096 symt->src.text = size_text;
1097 }
1098
1099 if(! symt->entry_point) /* seen before but not as entry */
1100 symt->info.toklist = NULL;
1101
1102 if(symt->external) { /* warn if entry point was declared external */
1103 syntax_error(id->line_num,id->col_num,
1104 "Entry point was declared external:");
1105 msg_tail(symt->name);
1106 /* try to undo the damage */
1107 symt->type = type_byte(class_VAR,datatype_of(symt->type));
1108 symt->external = FALSE;
1109 }
1110
1111 if((gsymt = (hashtab[h].glob_symtab)) == NULL) {
1112 /* Symbol is new to global symtab: install it */
1113 gsymt = install_global(h,datatype,storage_class);
1114 gsymt->size = size;
1115 gsymt->info.arglist = NULL;
1116 }
1117 else {
1118 /* Symbol is already in global symtab. Put the
1119 declared datatype into symbol table. */
1120 gsymt->type = type_byte(storage_class,datatype);
1121 gsymt->size = size;
1122 }
1123
1124 /* Restore args list to original order */
1125 if(args != NULL)
1126 args->next_token = reverse_tokenlist(args->next_token);
1127
1128 /* Insert the new list onto linked list of token lists */
1129 TH_ptr=make_TL_head(id);
1130
1131 /* If this is an implied PROGRAM statement it may
1132 occur in an include file, which we do not want
1133 to appear in diagnostic messages about it. */
1134 if(top_filename != current_filename && datatype == type_PROGRAM) {
1135 TH_ptr->filename = top_filename;
1136 TH_ptr->line_num = top_file_line_num;
1137 }
1138
1139 TH_ptr->tokenlist = (args == NULL ? NULL: args->next_token);
1140 TH_ptr->next = symt->info.toklist;
1141 symt->info.toklist = TH_ptr;
1142
1143 symt->entry_point = TRUE;
1144
1145 /* library mode: set the flag so no complaint will
1146 be issued if function never invoked. */
1147 if(library_mode)
1148 symt->library_module = TRUE;
1149 if(datatype == type_PROGRAM) {
1150 #ifdef VCG_SUPPORT /* Get name of file containing main module */
1151 main_filename = top_filename;
1152 #endif
1153 }
1154
1155 }/*def_function*/
1156
1157
1158
1159 void
1160 #if HAVE_STDC
def_intrins_name(Token * id)1161 def_intrins_name(Token *id) /* Process intrinsic lists */
1162 #else /* K&R style */
1163 def_intrins_name(id) /* Process intrinsic lists */
1164 Token *id;
1165 #endif /* HAVE_STDC */
1166 {
1167 int h=id->value.integer;
1168 Lsymtab *symt;
1169
1170 if( (symt = hashtab[h].loc_symtab) == NULL){
1171 symt = install_local(h,type_UNDECL,class_SUBPROGRAM);
1172 symt->line_declared = id->line_num;
1173 symt->file_declared = inctable_index;
1174 symt->info.toklist = NULL;
1175 }
1176 else {
1177 /* Symbol seen before: check it & change class */
1178 if(storage_class_of(symt->type) == class_VAR) {
1179 symt->info.toklist = NULL;
1180 }
1181
1182 symt->type = type_byte(class_SUBPROGRAM,datatype_of(symt->type));
1183 }
1184
1185 /* Place info about intrinsic datatype in local symtab.
1186 If not found, it will be treated as external.
1187 */
1188
1189 if(symt->external){
1190 syntax_error(id->line_num,id->col_num,
1191 "Cannot declare same subprogram both intrinsic and external:");
1192 msg_tail(symt->name);
1193 }
1194 else{
1195 IntrinsInfo *defn;
1196 symt->declared_intrinsic = TRUE;
1197 if( (defn=find_intrinsic(symt->name)) == NULL ) {
1198 if(misc_warn) {
1199 warning(id->line_num,id->col_num,
1200 "Unknown intrinsic function: ");
1201 msg_tail(symt->name);
1202 msg_tail("Treated as if user-defined");
1203 }
1204 /* Here treat as if EXTERNAL declaration */
1205 def_ext_name(id);
1206 return;
1207 }
1208 else {
1209 /* Found in info table: set intrins flag and store
1210 pointer to definition info. */
1211 symt->intrinsic = TRUE;
1212 symt->info.intrins_info = defn;
1213 }
1214 }
1215 symt->declared_external = TRUE;
1216 }/*def_intrins_name*/
1217
1218 void
1219 #if HAVE_STDC
def_namelist(Token * id,Token * list)1220 def_namelist(Token *id, Token *list) /* Process NAMELIST declaration */
1221 #else /* K&R style */
1222 def_namelist(id,list) /* Process NAMELIST declaration */
1223 Token *id,*list;
1224 #endif /* HAVE_STDC */
1225 {
1226 int h=id->value.integer;
1227 Lsymtab *symt;
1228 extern LINENO_t true_prev_stmt_line_num;/* set by fortran.y */
1229
1230 if( (symt=hashtab[h].loc_symtab) == NULL) {
1231 /* First encounter: install in local symtab */
1232 symt = install_local(h,type_NAMELIST,class_NAMELIST);
1233 symt->line_declared = id->line_num;
1234 symt->file_declared = inctable_index;
1235 symt->info.toklist = NULL;
1236 }
1237 /* protect ourself against nonsense */
1238 else if( symt->array_var || symt->parameter || symt->entry_point ) {
1239 syntax_error(id->line_num,id->col_num,
1240 "identifier was previously declared a non-namelist");
1241 return;
1242 }
1243 else if(pretty_multiple_namelist) {
1244
1245 /* Flag declarations of same namelist in separate statements
1246 unless separated only by comments. Use front token
1247 of previous tokenlist which is last token of decl. */
1248 if((symt->info.toklist != NULL) &&
1249 (symt->info.toklist->tokenlist->line_num < true_prev_stmt_line_num)) {
1250 ugly_code(id->line_num,id->col_num,
1251 "Namelist declared in more than one statement");
1252 }
1253 }
1254
1255 call_external(symt,id,list); /* attach list to symt->info.toklist */
1256
1257 }/*def_namelist*/
1258
1259
1260 void
1261 #if HAVE_STDC
def_namelist_item(Token * id)1262 def_namelist_item(Token *id) /* Process NAMELIST list elements */
1263 #else /* K&R style */
1264 def_namelist_item(id) /* Process NAMELIST list elements */
1265 Token *id;
1266 #endif /* HAVE_STDC */
1267 {
1268 ref_variable(id); /* Put it in symtab */
1269 }/*def_namelist_name*/
1270
1271
1272 void
1273 #if HAVE_STDC
def_parameter(Token * id,Token * val,int noparen)1274 def_parameter(Token *id, Token *val, int noparen)/* Process parameter_defn_item */
1275 #else /* K&R style */
1276 def_parameter(id,val,noparen) /* Process parameter_defn_item */
1277 Token *id,*val;
1278 int noparen; /* parenthesis-less form */
1279 #endif /* HAVE_STDC */
1280 {
1281 int h=id->value.integer;
1282 Lsymtab *symt;
1283
1284 if( (symt=hashtab[h].loc_symtab) == NULL) {
1285 symt = install_local(h,type_UNDECL,class_VAR);
1286 symt->line_declared = id->line_num;
1287 symt->file_declared = inctable_index;
1288 }
1289 else { /* protect ourself against nonsense */
1290 if( symt->array_var || symt->external || symt->intrinsic
1291 || symt->entry_point ) {
1292 syntax_error(id->line_num,id->col_num,
1293 "identifier cannot be a parameter:");
1294 msg_tail(symt->name);
1295 return;
1296 }
1297 }
1298
1299 if(! symt->set_flag) { /* record first line where set */
1300 symt->line_set = id->line_num;
1301 symt->file_set = inctable_index;
1302 }
1303
1304 symt->set_flag = TRUE;
1305 symt->parameter = TRUE;
1306 symt->info.param = new_param_info();
1307 symt->info.param->seq_num = ++parameter_count;
1308
1309 /* If parameter type is not declared, then if it is DEC
1310 parenthesis-less form (and -source=dec-param not given)
1311 or if standard form and -source=parameter-implicit option
1312 is given, get type from value. Warn about it under -f77,
1313 or under -port if the data type is not same as F77 default.
1314 */
1315 if( ((noparen && !source_dec_param_std_type)
1316 ||(!noparen && source_param_implicit)) &&
1317 (datatype_of(symt->type) == type_UNDECL) ) {
1318 int val_type = datatype_of(val->TOK_type);
1319 if( f77_param_implicit_type || f90_param_implicit_type ) {
1320 nonstandard(id->line_num,id->col_num,f90_param_implicit_type,0);
1321 msg_tail(": PARAMETER implicitly typed");
1322 if( get_type(symt) != val_type )
1323 msg_tail("differently from default type");
1324 }
1325 else if( port_param_implicit_type &&
1326 get_type(symt) != val_type ) {
1327 nonportable(id->line_num,id->col_num,
1328 ": PARAMETER implicitly typed differently from default type");
1329 }
1330 symt->type = type_byte(class_VAR,val_type);
1331 symt->size = val->size;
1332 }
1333
1334 /* Integer parameters: save value in symtab entry. Other
1335 types not saved. Need these since used in array dims */
1336 switch(get_type(symt)) {
1337 case type_INTEGER:
1338 symt->info.param->value.integer = int_expr_value(val);
1339 #ifdef DEBUG_PARAMETERS
1340 if(debug_latest)
1341 (void)fprintf(list_fd,"\nPARAMETER %s = %d",
1342 symt->name,symt->info.param->value.integer);
1343 #endif
1344 break;
1345 /* Character parameter: if declared adjustable
1346 i.e. *(*) then inherit size of const */
1347 case type_STRING:
1348 if(symt->size == size_ADJUSTABLE
1349 && datatype_of(val->TOK_type) == type_STRING)
1350 symt->size = val->size;
1351 symt->info.param->value.string = char_expr_value(val);
1352 break;
1353 case type_REAL:
1354 case type_DP:
1355 case type_COMPLEX:
1356 symt->info.param->value.dbl = float_expr_value(val);
1357 default:
1358 break;
1359 }
1360
1361 /* Save the source text of value for declaration */
1362
1363 symt->info.param->src_text = new_tree_text(
1364 (val->left_token == NULL?
1365 val: /* Primary */
1366 val->left_token) /* Expr tree */
1367 );
1368
1369 #ifdef DEBUG_EXPRTREES
1370 if(debug_latest) {
1371 fprintf(list_fd,"\n PARAMETER ( %s = %s ) ",
1372 symt->name,
1373 symt->info.param->src_text);
1374 }
1375 #endif
1376
1377 }/*def_parameter*/
1378
1379
1380
1381 void /* Installs statement function name in local table */
1382 #if HAVE_STDC
def_stmt_function(Token * id,Token * args)1383 def_stmt_function(Token *id, Token *args)
1384 #else /* K&R style */
1385 def_stmt_function(id, args)
1386 Token *id, *args;
1387 #endif /* HAVE_STDC */
1388 {
1389 int t,h=id->value.integer;
1390 Lsymtab *symt;
1391 TokenListHeader *TH_ptr;
1392
1393 if((symt = (hashtab[h].loc_symtab)) == NULL) {
1394 /* Symbol is new to local symtab: install it. */
1395
1396 symt = install_local(h,type_UNDECL,class_STMT_FUNCTION);
1397 symt->info.toklist = NULL;
1398 }
1399 else {
1400 if(storage_class_of(symt->type) == class_VAR) {
1401 symt->info.toklist = NULL;
1402 }
1403 }
1404 symt->line_declared = id->line_num;
1405 symt->file_declared = inctable_index;
1406
1407 /* Restore args to original order for sake of checking phase */
1408 if(args != NULL)
1409 args->next_token = reverse_tokenlist(args->next_token);
1410
1411 /* Save dummy arg list in symbol table */
1412 TH_ptr= make_TL_head(id);
1413
1414 TH_ptr->tokenlist = (args == NULL ? NULL: args->next_token);
1415 TH_ptr->next = symt->info.toklist;
1416 symt->info.toklist = TH_ptr;
1417
1418 t=datatype_of(symt->type);
1419 /* Symbol seen before: check it & change class */
1420
1421 /* check, check, check ... */
1422 if(storage_class_of(symt->type) == class_VAR)
1423 symt->type = type_byte(class_STMT_FUNCTION,t);
1424
1425 symt->external = TRUE;
1426 }/*def_stmt_function*/
1427
1428
1429
1430
1431 void
1432 #if HAVE_STDC
do_ASSIGN(Token * id)1433 do_ASSIGN(Token *id) /* Process ASSIGN statement */
1434 #else /* K&R style */
1435 do_ASSIGN(id) /* Process ASSIGN statement */
1436 Token *id;
1437 #endif /* HAVE_STDC */
1438 {
1439 int h=id->value.integer;
1440 Lsymtab *symt;
1441
1442 if( (symt=hashtab[h].loc_symtab) == NULL) {
1443 symt = install_local(h,type_UNDECL,class_VAR);
1444 symt->line_declared = id->line_num;
1445 symt->file_declared = inctable_index;
1446 }
1447 else {
1448 if(get_type(symt) != type_INTEGER) {
1449 syntax_error(id->line_num,id->col_num,
1450 "Variable must be an integer: ");
1451 msg_tail(symt->name);
1452 }
1453 if(symt->active_do_var) {
1454 syntax_error(id->line_num,id->col_num,
1455 "Cannot assign label to active DO index");
1456 }
1457 }
1458
1459 { /* set flags for all equivalenced vars */
1460 Lsymtab *equiv=symt;
1461 do{
1462 if(! equiv->set_flag) { /* record first line where set */
1463 equiv->line_set = id->line_num;
1464 equiv->file_set = inctable_index;
1465 }
1466 equiv->set_flag = TRUE;
1467 equiv = equiv->equiv_link;
1468 } while(equiv != symt);
1469 }
1470 }/*do_ASSIGN*/
1471
1472
1473
1474
1475 void
1476 #if HAVE_STDC
do_assigned_GOTO(Token * id)1477 do_assigned_GOTO(Token *id) /* Process assigned_goto */
1478 #else /* K&R style */
1479 do_assigned_GOTO(id) /* Process assigned_goto */
1480 Token *id;
1481 #endif /* HAVE_STDC */
1482 {
1483 int h=id->value.integer;
1484 Lsymtab *symt;
1485
1486 if( (symt=hashtab[h].loc_symtab) == NULL) {
1487 symt = install_local(h,type_UNDECL,class_VAR);
1488 symt->line_declared = id->line_num;
1489 symt->file_declared = inctable_index;
1490 }
1491 else {
1492 if(get_type(symt) != type_INTEGER) {
1493 syntax_error(id->line_num,id->col_num,
1494 "Variable must be an integer: ");
1495 msg_tail(symt->name);
1496 }
1497 }
1498
1499 { /* set flags for all equivalenced vars */
1500 Lsymtab *equiv=symt;
1501 do{
1502 if(! equiv->used_flag) { /* record first line where used */
1503 equiv->line_used = id->line_num;
1504 equiv->file_used = inctable_index;
1505 }
1506 if(! equiv->set_flag)
1507 equiv->used_before_set = TRUE;
1508 equiv->used_flag = TRUE;
1509 equiv = equiv->equiv_link;
1510 } while(equiv != symt);
1511 }
1512
1513 }/*do_assigned_GOTO*/
1514
1515
1516
1517
1518
1519 void
1520 #if HAVE_STDC
do_ENTRY(Token * id,Token * args,int hashno)1521 do_ENTRY(Token *id, Token *args, int hashno) /* Processes ENTRY statement */
1522 #else /* K&R style */
1523 do_ENTRY(id,args,hashno) /* Processes ENTRY statement */
1524 Token *id,*args;
1525 int hashno;
1526 #endif /* HAVE_STDC */
1527 {
1528 int datatype;
1529 if(hashno == -1) { /* -1 signifies headerless program */
1530 datatype = type_PROGRAM;
1531 }
1532 else {
1533 datatype = datatype_of(hashtab[hashno].loc_symtab->type);
1534 }
1535 switch(datatype) {
1536 case type_PROGRAM:
1537 case type_BLOCK_DATA:
1538 case type_COMMON_BLOCK:
1539 syntax_error(id->line_num,NO_COL_NUM,
1540 "You cannot have an entry statement here");
1541 break;
1542 case type_SUBROUTINE: /* Subroutine entry */
1543 def_function(type_SUBROUTINE,size_DEFAULT,(char *)NULL,
1544 id,args);
1545 break;
1546 default: /* Function entry */
1547 def_function(type_UNDECL,size_DEFAULT,(char *)NULL,
1548 id,args);
1549 break;
1550 }
1551 }/*do_ENTRY*/
1552
1553
1554
1555
1556 /* This routine checks whether a RETURN statement is valid at
1557 the present location, and if it is, looks for possible
1558 failure to assign return value of function. Returns 1
1559 if RETURN is valid here, 0 if not.
1560 */
1561 int
1562 #if HAVE_STDC
do_RETURN(int hashno,Token * keyword)1563 do_RETURN(int hashno, Token *keyword)
1564 /* current module hash number */
1565 /* tok_RETURN, or tok_END if implied RETURN */
1566 #else /* K&R style */
1567 do_RETURN(hashno,keyword)
1568 int hashno; /* current module hash number */
1569 Token *keyword; /* tok_RETURN, or tok_END if implied RETURN */
1570 #endif /* HAVE_STDC */
1571 {
1572 int i,datatype, valid=1;
1573 if(hashno == -1) { /* -1 signifies headerless program */
1574 datatype = type_PROGRAM;
1575 }
1576 else {
1577 datatype = datatype_of(hashtab[hashno].loc_symtab->type);
1578 }
1579 switch(datatype) {
1580 case type_PROGRAM:
1581 case type_BLOCK_DATA:
1582 if(keyword->tclass == tok_RETURN) {
1583 syntax_error(keyword->line_num,keyword->col_num,
1584 "You cannot have a RETURN statement here!");
1585 valid = 0;
1586 }
1587 break;
1588 case type_SUBROUTINE: /* Subroutine return: OK */
1589 break;
1590 default: /* Function return: check whether entry
1591 points have been assigned values. */
1592 for(i=0; i<loc_symtab_top; i++) {
1593 if(storage_class_of(loc_symtab[i].type) == class_VAR
1594 && loc_symtab[i].entry_point
1595 && ! loc_symtab[i].set_flag ) {
1596 if(misc_warn) {
1597 warning(keyword->line_num,keyword->col_num,
1598 loc_symtab[i].name);
1599 msg_tail("not set when RETURN encountered");
1600 }
1601 }
1602 }
1603 break;
1604 }
1605 return valid;
1606 }/*do_RETURN*/
1607
1608 void
1609 #if HAVE_STDC
equivalence(Token * id1,Token * id2)1610 equivalence(Token *id1, Token *id2)
1611 #else /* K&R style */
1612 equivalence(id1,id2)
1613 Token *id1, *id2;
1614 #endif /* HAVE_STDC */
1615 {
1616 int h1=id1->value.integer, h2=id2->value.integer;
1617 Lsymtab *symt1,*symt2,*temp;
1618
1619 /* install the variables in symtab if not seen before */
1620 if( (symt1=hashtab[h1].loc_symtab) == NULL) {
1621 symt1 = install_local(h1,type_UNDECL,class_VAR);
1622 symt1->line_declared = id1->line_num;
1623 symt1->file_declared = inctable_index;
1624 }
1625 if( (symt2=hashtab[h2].loc_symtab) == NULL) {
1626 symt2 = install_local(h2,type_UNDECL,class_VAR);
1627 symt2->line_declared = id2->line_num;
1628 symt2->file_declared = inctable_index;
1629 }
1630 /* Check for legality. Ought to do complementary
1631 checks elsewhere.
1632 */
1633 if(symt1 == symt2
1634 || symt1->parameter || symt2->parameter
1635 || symt1->entry_point || symt2->entry_point
1636 || symt1->argument || symt2->argument
1637 || symt1->external || symt2->external) {
1638
1639 syntax_error(id1->line_num,id1->col_num,
1640 "illegal to equivalence these");
1641 }
1642 /* now swap equiv_links so their equiv lists are united */
1643 else {
1644 temp = symt1->equiv_link;
1645 symt1->equiv_link = symt2->equiv_link;
1646 symt2->equiv_link = temp;
1647 }
1648
1649 /* If either guy is in common, both are in common */
1650 if(symt1->common_var || symt2->common_var) {
1651 Lsymtab *equiv=symt1;
1652 do {
1653 equiv->common_var = TRUE;
1654 equiv = equiv->equiv_link;
1655 } while(equiv != symt1);
1656 }
1657 }
1658
1659 int
1660 #if HAVE_STDC
get_size(const Lsymtab * symt,int type)1661 get_size(const Lsymtab *symt, int type) /* ARGSUSED1 */
1662 #else /* K&R style */
1663 get_size(symt,type) /* ARGSUSED1 */
1664 #endif /* HAVE_STDC */
1665 /* Returns size of symbol if explicitly declared
1666 or declared using IMPLICIT type*size statement.
1667 Otherwise returns size_DEFAULT. */
1668 #if HAVE_STDC
1669 /* Evaluated datatype: not used at present */
1670 #else /* K&R style */
1671 Lsymtab *symt;
1672 int type; /* Evaluated datatype: not used at present */
1673 #endif /* HAVE_STDC */
1674 {
1675 int datasize=symt->size;
1676 int datatype = datatype_of(symt->type);
1677 if(datatype != type_UNDECL) /* Declared? */
1678 return datasize; /* if declared, use it */
1679 else {
1680 int first_char=(int)symt->name[0];
1681
1682 if(first_char == '$') first_char = 'Z'+1;
1683 if(first_char == '_') first_char = 'Z'+2;
1684
1685 return implicit_size[first_char - 'A'];
1686 }
1687 }
1688
1689 char *
1690 #if HAVE_STDC
get_size_text(const Lsymtab * symt,int type)1691 get_size_text(const Lsymtab *symt, int type) /* ARGSUSED1 */
1692 /* Evaluated datatype: not used at present */
1693 #else /* K&R style */
1694 get_size_text(symt,type) /* ARGSUSED1 */
1695 Lsymtab *symt;
1696 int type; /* Evaluated datatype: not used at present */
1697 #endif /* HAVE_STDC */
1698 {
1699 int datatype = datatype_of(symt->type);
1700 if(datatype != type_UNDECL) {
1701 /* Declared: use text in symtab entry */
1702 if(symt->array_var)
1703 return symt->src.textvec[array_dims(symt->info.array_dim)];
1704 else
1705 return symt->src.text;
1706 }
1707 else {
1708 /* Undeclared: use implicit value */
1709 int first_char=(int)symt->name[0];
1710
1711 if(first_char == '$') first_char = 'Z'+1;
1712 if(first_char == '_') first_char = 'Z'+2;
1713
1714 return implicit_len_text[first_char - 'A'];
1715 }
1716 }
1717
1718 int
1719 #if HAVE_STDC
get_type(const Lsymtab * symt)1720 get_type(const Lsymtab *symt) /* Returns data type of symbol, using implicit if necessary */
1721 #else /* K&R style */
1722 get_type(symt) /* Returns data type of symbol, using implicit if necessary */
1723 Lsymtab *symt;
1724 #endif /* HAVE_STDC */
1725 {
1726 int datatype = datatype_of(symt->type);
1727
1728 if(datatype != type_UNDECL) /* Declared? */
1729 return datatype; /* Yes: use it */
1730 else if(storage_class_of(symt->type) == class_SUBPROGRAM
1731 && !symt->invoked_as_func )
1732 /* Function never invoked: assume subr */
1733 return type_SUBROUTINE;
1734 else if (symt->invoked_as_func && symt->intrinsic)
1735 {
1736 IntrinsInfo *defn;
1737
1738 defn = find_intrinsic(symt->name);
1739 if (defn != (IntrinsInfo *)NULL)
1740 return defn->result_type;
1741 }
1742
1743 /* Fell through, so type must be determined by first letter of name */
1744
1745 {
1746 int first_char=(int)symt->name[0];
1747 /* kluge: treat any nonalpha chars other than _
1748 as if they are $.
1749 */
1750 if( !isalpha(first_char) && first_char != '_' )
1751 first_char = 'Z'+1;
1752 if(first_char == '_') first_char = 'Z'+2;
1753
1754 return implicit_type[first_char - 'A'];
1755 }
1756 }/*get_type*/
1757
1758
1759 /* hash_lookup finds identifier in hashtable and returns its
1760 index. If not found, a new hashtable entry is made for it,
1761 and the identifier string s is copied to local stringspace.
1762 */
1763 unsigned
1764 #if HAVE_STDC
hash_lookup(char * s)1765 hash_lookup(char *s)
1766 #else /* K&R style */
1767 hash_lookup(s)
1768 char *s;
1769 #endif /* HAVE_STDC */
1770 {
1771 unsigned h;
1772 unsigned long hnum;
1773
1774 hnum = hash(s);
1775
1776 while(h = hnum%HASHSZ, hashtab[h].name != NULL
1777 && strcmp(hashtab[h].name,s) != 0) {
1778 hnum = rehash(hnum); /* Resolve clashes */
1779 }
1780
1781 if(hashtab[h].name == NULL) {
1782 hashtab[h].name = new_local_string(s);
1783 hashtab[h].loc_symtab = NULL;
1784 hashtab[h].glob_symtab = NULL;
1785 hashtab[h].com_loc_symtab = NULL;
1786 hashtab[h].com_glob_symtab = NULL;
1787 }
1788 return h;
1789 }/*hash_lookup*/
1790
1791 void
init_tables(VOID)1792 init_tables(VOID) /* Allocates table space */
1793 {
1794 #ifdef DYNAMIC_TABLES /* tables will be mallocked at runtime */
1795 if( ((loc_symtab=(Lsymtab*)calloc(LOCSYMTABSZ,sizeof(Lsymtab)))
1796 == (Lsymtab*)NULL) ||
1797 ((glob_symtab=(Gsymtab*)calloc(GLOBSYMTABSZ,sizeof(Gsymtab)))
1798 == (Gsymtab*)NULL) ||
1799 ((hashtab=(HashTable*)calloc(HASHSZ,sizeof(HashTable)))
1800 == (HashTable*)NULL)
1801 ) {
1802 oops_message(OOPS_FATAL,NO_LINE_NUM,NO_COL_NUM,
1803 "Cannot malloc space for tables");
1804 }
1805 #endif
1806 }
1807
1808
1809
1810
1811 Gsymtab*
1812 #if HAVE_STDC
install_global(int h,int datatype,int storage_class)1813 install_global(int h, int datatype, int storage_class) /* Install a global symbol */
1814 /* hash index */
1815 #else /* K&R style */
1816 install_global(h,datatype,storage_class) /* Install a global symbol */
1817 int h; /* hash index */
1818 int datatype,storage_class;
1819 #endif /* HAVE_STDC */
1820 {
1821 Gsymtab *gsymt = &glob_symtab[glob_symtab_top];
1822
1823 if(glob_symtab_top == GLOBSYMTABSZ) {
1824 oops_message(OOPS_FATAL,line_num,NO_COL_NUM,
1825 #ifdef LARGE_MACHINE
1826 "out of space in global symbol table\n\
1827 Recompile me with larger GLOBSYMTABSZ value\n"
1828 #else
1829 "out of space in global symbol table\n\
1830 Recompile me with LARGE_MACHINE option\n"
1831 #endif
1832 );
1833 }
1834 else {
1835 /* Store symtab pointer in hash table */
1836 if(storage_class == class_COMMON_BLOCK)
1837 hashtab[h].com_glob_symtab = gsymt;
1838 else
1839 hashtab[h].glob_symtab = gsymt;
1840
1841 clear_symtab_entry(gsymt);
1842
1843 /* Duplicate copy of string into global stringspace */
1844 gsymt->name = new_global_string(hashtab[h].name);
1845
1846 /* Set symtab info fields */
1847 gsymt->type = type_byte(storage_class,datatype);
1848 gsymt->size = type_size[datatype];
1849 if(storage_class == class_COMMON_BLOCK)
1850 gsymt->info.comlist = NULL;
1851 else
1852 gsymt->info.arglist = NULL;
1853
1854 gsymt->link.child_list = NULL;
1855
1856 ++glob_symtab_top;
1857 }
1858 return (gsymt);
1859 }/*install_global*/
1860
1861
1862 PRIVATE Lsymtab*
1863 #if HAVE_STDC
install_local(int h,int datatype,int storage_class)1864 install_local(int h, int datatype, int storage_class) /* Install a local symbol */
1865 /* hash index */
1866 #else /* K&R style */
1867 install_local(h,datatype,storage_class) /* Install a local symbol */
1868 int h; /* hash index */
1869 int datatype,storage_class;
1870 #endif /* HAVE_STDC */
1871 {
1872 Lsymtab *symt = &loc_symtab[loc_symtab_top];
1873 if(loc_symtab_top == LOCSYMTABSZ) {
1874 oops_message(OOPS_FATAL,line_num,NO_COL_NUM,
1875 #ifdef LARGE_MACHINE
1876 "out of space in local symbol table\n\
1877 Recompile me with larger LOCSYMTABSZ value\n"
1878 #else
1879 "out of space in local symbol table\n\
1880 Recompile me with LARGE_MACHINE option\n"
1881 #endif
1882 );
1883 }
1884 else {
1885 if(storage_class == class_COMMON_BLOCK)
1886 hashtab[h].com_loc_symtab = symt;
1887 else
1888 hashtab[h].loc_symtab = symt;
1889
1890 clear_symtab_entry(symt);
1891 symt->name = hashtab[h].name;
1892 symt->info.array_dim = 0;
1893
1894 /* Set symtab info fields */
1895 symt->type = type_byte(storage_class,datatype);
1896 symt->size = type_size[datatype];
1897 symt->src.text = NULL;
1898 symt->equiv_link = symt; /* equivalenced only to self */
1899 symt->common_block = (Gsymtab*)NULL;
1900 symt->common_index = 0;
1901 if(incdepth > 0)
1902 symt->defined_in_include = TRUE;
1903 symt->line_declared = symt->line_set = symt->line_used = NO_LINE_NUM;
1904 /* initialize indices in incfile table */
1905 symt->file_declared = symt->file_set = symt->file_used = -1;
1906 ++loc_symtab_top;
1907 }
1908 return symt;
1909 }/*install_local*/
1910
1911
1912 /* Get value specified by an integer-expression token.
1913 This will be either an identifier, which should be a
1914 parameter whose value is in the symbol table, or else
1915 an expression token as propagated by exprtype.c
1916 routines, with value stored in the token.
1917 */
1918 int
1919 #if HAVE_STDC
int_expr_value(Token * t)1920 int_expr_value(Token *t)
1921 #else /* K&R style */
1922 int_expr_value(t)
1923 Token *t;
1924 #endif /* HAVE_STDC */
1925 {
1926 if(!is_true(EVALUATED_EXPR,t->TOK_flags)) {/* something bogus */
1927 /* warn if error message not already given */
1928 if(is_true(PARAMETER_EXPR,t->TOK_flags))
1929 if(misc_warn)
1930 warning(t->line_num,t->col_num,
1931 "Constant not evaluated: value of 0 assumed");
1932 }
1933 else {
1934 if( is_true(ID_EXPR,t->TOK_flags) ) {
1935 /* Identifier: better be a parameter */
1936 int h=t->value.integer;
1937 Lsymtab *symt = hashtab[h].loc_symtab;
1938 if(symt == NULL || !(symt->parameter) ) {
1939 syntax_error(t->line_num,t->col_num,
1940 "symbolic constant required");
1941 }
1942 else {
1943 return symt->info.param->value.integer;
1944 }
1945 }
1946 /* Otherwise, it is a const or expr, use token.value.integer */
1947 else {
1948 return t->value.integer;
1949 }
1950 }
1951 /* Unsuccessful: return value of 0 */
1952 return 0;
1953 }/*int_expr_value*/
1954
1955 DBLVAL
1956 #if HAVE_STDC
float_expr_value(Token * t)1957 float_expr_value(Token *t)
1958 #else /* K&R style */
1959 float_expr_value(t)
1960 Token *t;
1961 #endif /* HAVE_STDC */
1962 {
1963 if(is_true(LIT_CONST,t->TOK_flags))
1964 return t->value.dbl;
1965 else
1966 return (DBLVAL)0; /* float values are not propagated */
1967 }
1968
1969 char *
1970 #if HAVE_STDC
char_expr_value(Token * t)1971 char_expr_value(Token *t)
1972 #else /* K&R style */
1973 char_expr_value(t)
1974 Token *t;
1975 #endif /* HAVE_STDC */
1976 {
1977 if(is_true(LIT_CONST,t->TOK_flags))
1978 return t->value.string;
1979 else
1980 return NULL; /* char values are not propagated */
1981 }
1982
1983
1984
1985 /* note_filename(): This routine is called by main prog to give
1986 symbol table routines access to current input file name, to be
1987 stored in function arg list headers and common list headers, for
1988 the use in diagnostic messages. Since filenames are from argv,
1989 they are permanent, so pointer is copied, not the string.
1990 */
1991 void
1992 #if HAVE_STDC
note_filename(char * s)1993 note_filename(char *s)
1994 #else /* K&R style */
1995 note_filename(s)
1996 char *s;
1997 #endif /* HAVE_STDC */
1998 {
1999 current_filename = s;
2000 top_filename = s;
2001 }/* note_filename */
2002
2003 /* Routine to output expression tree via msg_tail. For use
2004 in error/warning routines.
2005 */
2006 void
msg_expr_tree(const Token * t)2007 msg_expr_tree(const Token *t)
2008 {
2009 char textbuf[25];
2010 int ncopied = cp_tree_src_text(textbuf,
2011 t->left_token == NULL?t:t->left_token,
2012 sizeof(textbuf)-1);
2013 msg_tail(textbuf);
2014 if( ncopied == sizeof(textbuf)-1 )
2015 msg_tail("..");
2016 }
2017
2018 #ifdef DEBUG_EXPRTREES /* Routines to print out expr tree src text */
2019 void
print_src_text(t)2020 print_src_text(t)
2021 Token *t;
2022 {
2023 char textbuf[256];
2024 (void) cp_tok_src_text(textbuf,t,sizeof(textbuf)-1);
2025 fprintf(list_fd,"%s",textbuf);
2026 }
2027
2028 void
print_expr_tree(t)2029 print_expr_tree(t)
2030 Token *t;
2031 {
2032 char textbuf[256];
2033 (void) cp_tree_src_text(textbuf,t,sizeof(textbuf)-1);
2034 fprintf(list_fd,"%s",textbuf);
2035 }
2036
2037 void
print_expr_list(t)2038 print_expr_list(t)
2039 Token *t;
2040 {
2041 char textbuf[256];
2042 (void) cp_list_src_text(textbuf,t,sizeof(textbuf)-1);
2043 fprintf(list_fd,"%s",textbuf);
2044 }
2045 #endif
2046
2047
2048
2049
2050 void
2051 #if HAVE_STDC
ref_array(Token * id,Token * subscrs)2052 ref_array(Token *id, Token *subscrs) /* Array reference: install in symtab */
2053 #else /* K&R style */
2054 ref_array(id,subscrs) /* Array reference: install in symtab */
2055 Token *id, *subscrs;
2056 #endif /* HAVE_STDC */
2057 {
2058 int h=id->value.integer;
2059 Lsymtab *symt=hashtab[h].loc_symtab;
2060
2061 /* Restore subscripts to original order */
2062 subscrs->next_token = reverse_tokenlist(subscrs->next_token);
2063
2064 if(symt == NULL){
2065 oops_message(OOPS_NONFATAL,line_num,NO_COL_NUM,
2066 "undeclared variable has dim info:");
2067 oops_tail(hashtab[h].name);
2068 symt = install_local(h,type_UNDECL,class_VAR);
2069 symt->line_declared = id->line_num;
2070 symt->file_declared = inctable_index;
2071 }
2072 else{ /* check that subscrs match dimension info */
2073
2074
2075 if(arg_count(subscrs->next_token)!=array_dims(symt->info.array_dim)){
2076 syntax_error(subscrs->line_num,subscrs->col_num,
2077 "array");
2078 msg_tail(symt->name);
2079 msg_tail("referenced with wrong no. of subscripts");
2080 }
2081 }
2082
2083 }/* ref_array */
2084
2085 void
2086 #if HAVE_STDC
ref_namelist(Token * id,int stmt_class)2087 ref_namelist(Token *id, int stmt_class)
2088 #else /* K&R style */
2089 ref_namelist(id,stmt_class)
2090 Token *id;
2091 int stmt_class;
2092 #endif /* HAVE_STDC */
2093 {
2094 Token *t;
2095 TokenListHeader *toklist;
2096 int h=id->value.integer;
2097 Lsymtab *symt=hashtab[h].loc_symtab;
2098 if(symt == NULL){
2099 oops_message(OOPS_NONFATAL,line_num,NO_COL_NUM,
2100 "undeclared identifier is a namelist:");
2101 oops_tail(hashtab[h].name);
2102 symt = install_local(h,type_NAMELIST,class_NAMELIST);
2103 symt->line_declared = id->line_num;
2104 symt->file_declared = inctable_index;
2105 symt->info.toklist = NULL;
2106 }
2107
2108 /* Go thru token list of namelist variables,
2109 setting flags appropriately. We can't use
2110 use_lvalue or use_variable here, since the
2111 line number of token in list is that of the
2112 namelist declaration, so we use our own code here.
2113 */
2114 toklist = symt->info.toklist;
2115 if (toklist != NULL){
2116 t = toklist->tokenlist;
2117 while(t != NULL){
2118 /* set flags for all equivalenced vars */
2119
2120 int th=t->value.integer;
2121 Lsymtab *tsymt,*equiv;
2122 if((tsymt=hashtab[th].loc_symtab) == NULL) { /* can't happen */
2123 tsymt = install_local(th,type_UNDECL,class_VAR);
2124 tsymt->line_declared = id->line_num;
2125 tsymt->file_declared = inctable_index;
2126 }
2127 equiv=tsymt;
2128 if(stmt_class == tok_READ) /* code like use_lvalue */
2129 do{
2130 if(! equiv->set_flag) { /* record first line where set */
2131 equiv->line_set = id->line_num;
2132 equiv->file_set = inctable_index;
2133 }
2134 equiv->set_flag = TRUE;
2135 equiv->assigned_flag = TRUE;
2136 equiv = equiv->equiv_link;
2137 } while(equiv != tsymt);
2138 else /* tok_WRITE: code like use_variable */
2139 do{
2140 if(! equiv->used_flag) { /* record first line where used */
2141 equiv->line_used = id->line_num;
2142 equiv->file_used = inctable_index;
2143 }
2144 if(! equiv->set_flag) {
2145 equiv->used_before_set = TRUE;
2146 }
2147 equiv->used_flag = TRUE;
2148 equiv = equiv->equiv_link;
2149 } while(equiv != tsymt);
2150 t = t->next_token;
2151 }
2152 }
2153 }
2154
2155 void
2156 #if HAVE_STDC
ref_identifier(Token * id)2157 ref_identifier(Token *id) /* Identifier reference: install in symtab */
2158 #else /* K&R style */
2159 ref_identifier(id)
2160 Token *id;
2161 #endif /* HAVE_STDC */
2162 {
2163 int h=id->value.integer;
2164 Lsymtab *symt = hashtab[h].loc_symtab;
2165 if( symt == NULL) {
2166 symt = install_local(h,type_UNDECL,class_VAR);
2167 }
2168
2169 }/*ref_identifier*/
2170
2171 void
2172 #if HAVE_STDC
ref_variable(Token * id)2173 ref_variable(Token *id) /* Variable reference: install in symtab */
2174 #else /* K&R style */
2175 ref_variable(id) /* Variable reference: install in symtab */
2176 Token *id;
2177 #endif /* HAVE_STDC */
2178 {
2179 int h=id->value.integer;
2180 Lsymtab *symt = hashtab[h].loc_symtab;
2181 if( symt == NULL) {
2182 symt = install_local(h,type_UNDECL,class_VAR);
2183 }
2184 if(symt->line_declared == NO_LINE_NUM) {
2185 symt->line_declared = id->line_num; /* implicit declaration */
2186 symt->file_declared = inctable_index;
2187 }
2188 }/*ref_variable*/
2189
2190
2191 void
2192 #if HAVE_STDC
save_com_block(Token * id)2193 save_com_block(Token *id) /* Process SAVEing of a common block */
2194 /* N.B. Legality checking deferred to END */
2195 #else /* K&R style */
2196 save_com_block(id) /* Process SAVEing of a common block */
2197 Token *id; /* N.B. Legality checking deferred to END */
2198 #endif /* HAVE_STDC */
2199 {
2200 int h=id->value.integer;
2201 Lsymtab *symt;
2202
2203 /* N.B. SAVE does not create a global table entry */
2204 if( (symt = hashtab[h].com_loc_symtab) == NULL){
2205 symt = install_local(h,type_COMMON_BLOCK,class_COMMON_BLOCK);
2206 symt->info.toklist = NULL;
2207 /* record location in case never declared */
2208 symt->line_declared = id->line_num;
2209 symt->file_declared = inctable_index;
2210 }
2211
2212 if(symt->saved) {
2213 syntax_error(id->line_num,id->col_num,
2214 "redundant SAVE declaration");
2215 }
2216 else
2217 symt->saved = TRUE;
2218 }
2219
2220
2221 /* Following routine sets the implicit typing of characters in
2222 range c1 to c2 to the given type. */
2223 void
2224 #if HAVE_STDC
set_implicit_type(int type,long int size,char * len_text,int c1,int c2)2225 set_implicit_type(int type, long int size, char *len_text, int c1, int c2)
2226 /* Data type of IMPLICIT declaration */
2227 /* Type size or size_DEFAULT if not given */
2228 /* Source text of length spec */
2229 /* First character of range */
2230 /* Last character of range */
2231 #else /* K&R style */
2232 set_implicit_type(type,size,len_text,c1,c2)
2233 int type; /* Data type of IMPLICIT declaration */
2234 long size; /* Type size or size_DEFAULT if not given */
2235 char *len_text; /* Source text of length spec */
2236 int c1; /* First character of range */
2237 int c2; /* Last character of range */
2238 #endif /* HAVE_STDC */
2239 {
2240 int c;
2241
2242 if(c1 == '$') c1 = 'Z'+1;
2243 if(c2 == '$') c2 = 'Z'+1;
2244
2245 if(c1 == '_') c1 = 'Z'+2;
2246 if(c2 == '_') c2 = 'Z'+2;
2247
2248 if(c2 < c1) {
2249 yyerror("IMPLICIT range must be in alphabetical order");
2250 }
2251 else {
2252 /* Fill in the lookup table for the given range of chars */
2253 for(c=c1; c<=c2; c++) {
2254 implicit_type[c-'A'] = type;
2255 implicit_size[c-'A'] = size;
2256 implicit_len_text[c-'A'] = len_text;
2257 }
2258 }
2259 }/*set_implicit_type*/
2260
2261
2262 /* Finish processing statement function.
2263 Clears all used-before-set flags of ordinary
2264 variables. Reason: statement functions are processed
2265 like assignment to an array element, setting ubs flags.
2266 At this point, no valid setting of ubs flags should
2267 be possible, so clearing them will elim false messages.*/
2268 void
2269 #if HAVE_STDC
stmt_function_stmt(Token * id)2270 stmt_function_stmt(Token *id) /* ARGSUSED0 */
2271 /* Not used at present */
2272 #else /* K&R style */
2273 stmt_function_stmt(id) /* ARGSUSED0 */
2274 Token *id; /* Not used at present */
2275 #endif /* HAVE_STDC */
2276 {
2277 int i;
2278 for(i=0; i<loc_symtab_top; i++) {
2279 if(storage_class_of(loc_symtab[i].type) == class_VAR &&
2280 ! loc_symtab[i].parameter )
2281 loc_symtab[i].used_before_set = FALSE;
2282 }
2283 }/*stmt_function_stmt(id)*/
2284
2285 char *
2286 #if HAVE_STDC
token_name(Token * t)2287 token_name(Token *t)
2288 #else /* K&R style */
2289 token_name(t)
2290 Token *t;
2291 #endif /* HAVE_STDC */
2292 {
2293 return hashtab[t->value.integer].name;
2294 }/*token_name*/
2295
2296
2297 void
undef_do_variable(int h)2298 undef_do_variable( int h ) /* Make DO index variable inactive */
2299 {
2300 Lsymtab *symt=hashtab[h].loc_symtab;
2301 if( symt != NULL ) /* Just in case: it should always be defined */
2302 { /* set flags for all equivalenced vars */
2303 Lsymtab *equiv=symt;
2304 do{
2305 equiv->active_do_var = FALSE;
2306 equiv = equiv->equiv_link;
2307 } while(equiv != symt);
2308 }
2309 }
2310
2311
2312 void
2313 #if HAVE_STDC
use_actual_arg(Token * id)2314 use_actual_arg(Token *id) /* like use_lvalue except does not set assigned_flag */
2315 #else /* K&R style */
2316 use_actual_arg(id) /* like use_lvalue except does not set assigned_flag */
2317 Token *id;
2318 #endif /* HAVE_STDC */
2319 {
2320 int h=id->value.integer;
2321 Lsymtab *symt;
2322
2323 if((symt=hashtab[h].loc_symtab) == NULL) {
2324 symt = install_local(h,type_UNDECL,class_VAR);
2325 symt->line_declared = id->line_num;
2326 symt->file_declared = inctable_index;
2327 }
2328 else {
2329 /* If an external other than an intrinsic, set up
2330 tokenlist for "call". If intrinsic, check
2331 legality of this usage.) */
2332 if(storage_class_of(symt->type) == class_SUBPROGRAM) {
2333 if(symt->intrinsic) {
2334 IntrinsInfo *defn = symt->info.intrins_info;
2335 if( !(symt->declared_intrinsic) ) {
2336 if(misc_warn) {
2337 warning(id->line_num,id->col_num,
2338 defn->name);
2339 msg_tail("not declared INTRINSIC");
2340 }
2341 }
2342 if( (defn->intrins_flags&I_NOTARG) ) {
2343 syntax_error(id->line_num,id->col_num,
2344 defn->name);
2345 msg_tail("intrinsic function cannot be a subprogram argument");
2346 }
2347 }
2348 else { /* External subprogram as actual arg */
2349 TokenListHeader *TH_ptr;
2350 TH_ptr= make_TL_head(id);
2351
2352 TH_ptr->actual_arg = TRUE;
2353 TH_ptr->next = symt->info.toklist;
2354 symt->info.toklist = TH_ptr;
2355 }
2356 }
2357 }
2358
2359 { /* set flags for all equivalenced vars */
2360 Lsymtab *equiv=symt;
2361 do{
2362 if(! equiv->set_flag) { /* record first line where set */
2363 equiv->line_set = id->line_num;
2364 equiv->file_set = inctable_index;
2365 }
2366 equiv->set_flag = TRUE;
2367 equiv = equiv->equiv_link;
2368 } while(equiv != symt);
2369 }
2370
2371 }/*use_actual_arg*/
2372
2373
2374 PRIVATE void
2375 #if HAVE_STDC
use_function_arg(Token * id)2376 use_function_arg(Token *id) /* Like use_variable but invokes use_actual_arg
2377 if id is an external (subprogram) passed as
2378 arg of a function. This routine is used when
2379 pure_functions flag is set. */
2380 #else /* K&R style */
2381 use_function_arg(id) /* Like use_variable but first invokes use_actual_arg
2382 only if id is an external (subprogram) passed as
2383 arg of a function. This routine is used when
2384 pure_functions flag is set. */
2385 Token *id;
2386 #endif /* HAVE_STDC */
2387 {
2388 int h=id->value.integer;
2389 Lsymtab *symt;
2390
2391 if( (symt=hashtab[h].loc_symtab) == NULL) {
2392 symt = install_local(h,type_UNDECL,class_VAR);
2393 symt->line_declared = id->line_num;
2394 symt->file_declared = inctable_index;
2395 }
2396
2397 if(storage_class_of(symt->type) == class_SUBPROGRAM)
2398 use_actual_arg(id);
2399
2400 use_variable(id);
2401
2402 }/*use_function_arg*/
2403
2404 void
2405 #if HAVE_STDC
use_implied_do_index(Token * id)2406 use_implied_do_index(Token *id)
2407 #else /* K&R style */
2408 use_implied_do_index(id)
2409 Token *id;
2410 #endif /* HAVE_STDC */
2411 {
2412 /* Like use_lvalue and use_variable but clears ubs flag.
2413 This is because we cannot handle used-before-set
2414 properly in this case, and the odds are that ubs
2415 was set in the preceding I/O list. */
2416 int h=id->value.integer;
2417 Lsymtab *symt;
2418
2419 use_lvalue(id);
2420 use_variable(id);
2421 symt=hashtab[h].loc_symtab;
2422
2423 symt->used_before_set = FALSE;
2424 }/*use_implied_do_index*/
2425
2426
2427 PRIVATE void
2428 #if HAVE_STDC
use_len_arg(Token * id)2429 use_len_arg(Token *id) /* Set the use-flag of arg to intrinsic LEN. */
2430 #else /* K&R style */
2431 use_len_arg(id) /* Set the use-flag of arg to intrinsic LEN. */
2432 Token *id;
2433 #endif /* HAVE_STDC */
2434 {
2435 int h=id->value.integer;
2436 Lsymtab *symt;
2437
2438 if( (symt=hashtab[h].loc_symtab) == NULL) {
2439 symt = install_local(h,type_UNDECL,class_VAR);
2440 symt->line_declared = id->line_num;
2441 symt->file_declared = inctable_index;
2442 }
2443
2444 { /* set flags for all equivalenced vars. Do not set
2445 the used-before-set flag since LEN argument does
2446 not need to be defined. */
2447 Lsymtab *equiv=symt;
2448 do{
2449 if(! equiv->used_flag) { /* record first line where used */
2450 equiv->line_used = id->line_num;
2451 equiv->file_used = inctable_index;
2452 }
2453 equiv->used_flag = TRUE;
2454 equiv = equiv->equiv_link;
2455 } while(equiv != symt);
2456 }
2457
2458 }/*use_len_arg*/
2459
2460 void
2461 #if HAVE_STDC
use_lvalue(Token * id)2462 use_lvalue(Token *id) /* handles scalar lvalue */
2463 #else /* K&R style */
2464 use_lvalue(id) /* handles scalar lvalue */
2465 Token *id;
2466 #endif /* HAVE_STDC */
2467 {
2468 int h=id->value.integer;
2469 Lsymtab *symt;
2470 if((symt=hashtab[h].loc_symtab) == NULL) {
2471 symt = install_local(h,type_UNDECL,class_VAR);
2472 symt->line_declared = id->line_num;
2473 symt->file_declared = inctable_index;
2474 }
2475 else {
2476 /* check match to previous invocations and update */
2477 }
2478
2479 /* F77 standard section 11.10.5 prohibits modifying
2480 DO variable except thru loop mechanism.
2481 */
2482 if(symt->active_do_var) {
2483 if(usage_do_var_modified) {
2484 syntax_error(id->line_num,id->col_num,
2485 "active DO index is modified");
2486 }
2487 }
2488
2489 { /* set flags for all equivalenced vars */
2490 Lsymtab *equiv=symt;
2491 do{
2492 if(! equiv->set_flag) { /* record first line where set */
2493 equiv->line_set = id->line_num;
2494 equiv->file_set = inctable_index;
2495 }
2496 equiv->set_flag = TRUE;
2497 equiv->assigned_flag = TRUE;
2498 equiv = equiv->equiv_link;
2499 } while(equiv != symt);
2500 }
2501
2502 }/*use_lvalue*/
2503
2504
2505
2506 void /* Process data_constant_value & data_repeat_factor */
2507 #if HAVE_STDC
use_parameter(Token * id)2508 use_parameter(Token *id)
2509 #else /* K&R style */
2510 use_parameter(id)
2511 Token *id;
2512 #endif /* HAVE_STDC */
2513 {
2514 int h=id->value.integer;
2515 Lsymtab *symt;
2516
2517 if( (symt=hashtab[h].loc_symtab) == NULL) {
2518 symt = install_local(h,type_UNDECL,class_VAR);
2519 symt->line_declared = id->line_num;
2520 symt->file_declared = inctable_index;
2521 }
2522 if(! symt->parameter) {
2523 syntax_error(id->line_num,id->col_num,
2524 "must be a parameter");
2525 /*** symt->parameter = TRUE;**/ /*oops: must define info etc.*/
2526 }
2527
2528 if(! symt->set_flag) {
2529 symt->used_before_set = TRUE;
2530 }
2531
2532 if(! symt->used_flag) { /* record first line where used */
2533 symt->line_used = id->line_num;
2534 symt->file_used = inctable_index;
2535 }
2536
2537 symt->used_flag = TRUE;
2538
2539 }/*use_parameter*/
2540
2541
2542 void
2543 #if HAVE_STDC
use_variable(Token * id)2544 use_variable(Token *id) /* Set the use-flag of variable. */
2545 #else /* K&R style */
2546 use_variable(id) /* Set the use-flag of variable. */
2547 Token *id;
2548 #endif /* HAVE_STDC */
2549 {
2550 int h=id->value.integer;
2551 Lsymtab *symt;
2552
2553 if( (symt=hashtab[h].loc_symtab) == NULL) {
2554 symt = install_local(h,type_UNDECL,class_VAR);
2555 symt->line_declared = id->line_num;
2556 symt->file_declared = inctable_index;
2557 }
2558
2559 { /* set flags for all equivalenced vars */
2560 Lsymtab *equiv=symt;
2561 do{
2562 if(! equiv->used_flag) { /* record first line where used */
2563 equiv->line_used = id->line_num;
2564 equiv->file_used = inctable_index;
2565 }
2566 if(! equiv->set_flag) {
2567 equiv->used_before_set = TRUE;
2568 }
2569 equiv->used_flag = TRUE;
2570 equiv = equiv->equiv_link;
2571 } while(equiv != symt);
2572 }
2573
2574 }/*use_variable*/
2575
2576
2577 /* Routine to provide a string with type followed by one of: "",
2578 "*n" where n is the declared size of an item, "(l)" where
2579 l is the declared array length of an item, or "*n(l)".
2580 Note: cannot be used twice in same statement, since
2581 it uses a static buffer for the result.
2582 */
2583 char *
2584 #if HAVE_STDC
typespec(int t,int has_size,long size,int has_len,long len)2585 typespec(int t, int has_size, long size, int has_len, long len)
2586 #else /* K&R style */
2587 typespec(t,has_size, size, has_len, len)
2588 int t; /* data type code */
2589 int has_size, /* whether it has *size spec */
2590 has_len; /* whether it has (len) spec */
2591 long size, /* value of size */
2592 len; /* value of len */
2593 #endif /* HAVE_STDC */
2594 {
2595 /* Size of buffer allows 3 digits for each byte,
2596 which is slightly more than necessary.
2597 */
2598 static char buf[MAX_TYPESPEC];
2599 strncpy(buf,type_name[t],4); buf[4] = '\0';
2600 if(has_size) {
2601 (void) sprintf(buf+strlen(buf),"*%ld",size);
2602 }
2603 if(has_len) {
2604 (void) sprintf(buf+strlen(buf),"(%ld)",len);
2605 }
2606
2607 return buf;
2608 }
2609
2610
2611 /* End of symtab.c */
2612
2613 /*
2614
2615 II. Hash
2616
2617 */
2618
2619 /* hash.c:
2620 performs a hash function
2621
2622 This was formerly a separate file.
2623
2624 */
2625
2626 extern int sixclash; /* flag to check clashes in 1st 6 chars of name */
2627
2628 unsigned long
2629 #if HAVE_STDC
hash(const char * s)2630 hash(const char *s)
2631 #else /* K&R style */
2632 hash(s)
2633 char *s;
2634 #endif /* HAVE_STDC */
2635 {
2636 unsigned long sum = 0, wd;
2637 unsigned j;
2638
2639 if(sixclash) { /* special hashing for six-char limit */
2640 unsigned i = 0;
2641 while (i < 6 && s[i] != '\0') {
2642 wd = 0;
2643 for(j=1; j <= sizeof(long) && i < 6 && s[i] != '\0'; i++,j++) {
2644 wd += (unsigned long)(s[i] & 0xff) << (sizeof(long) - j) * 8;}
2645
2646 sum ^= wd;}
2647 }
2648 else { /* the usual case */
2649 while( *s != '\0' ) {
2650 wd = 0;
2651 for(j=1; j <= sizeof(long) && *s != '\0'; j++) {
2652 wd += (unsigned long)(*s++ & 0xff) << (sizeof(long) - j) * 8;}
2653
2654 sum ^= wd;}
2655 }
2656 return sum;
2657 }
2658
2659
2660
2661 /* rehash
2662 performs a rehash for resolving clashes.
2663 */
2664
2665 #ifdef COUNT_REHASHES
2666 unsigned long rehash_count=0;
2667 #endif
2668
2669 unsigned long
2670 #if HAVE_STDC
rehash(unsigned long hnum)2671 rehash(unsigned long hnum)
2672 #else /* K&R style */
2673 rehash(hnum)
2674 unsigned long hnum;
2675 #endif /* HAVE_STDC */
2676 {
2677 #ifdef COUNT_REHASHES
2678 rehash_count++;
2679 #endif
2680 return hnum+1;
2681 }
2682
2683
2684 /* End of hash */
2685
2686
2687
2688
2689
2690 #ifdef DEBUG_SIZES
print_sizeofs()2691 void print_sizeofs() /* For development: print sizeof for
2692 various data structures */
2693 {
2694 #ifdef __STDC__
2695 #define PrintObjSize(OBJ) (void)fprintf(list_fd,#OBJ " size = %d\n",sizeof(OBJ))
2696 #else /* K&R form */
2697 #define PrintObjSize(OBJ) (void)fprintf(list_fd,"OBJ size = %d\n",sizeof(OBJ))
2698 #endif
2699 PrintObjSize(char *);
2700 PrintObjSize(Token);
2701 PrintObjSize(Lsymtab);
2702 PrintObjSize(Gsymtab);
2703 PrintObjSize(HashTable);
2704 PrintObjSize(ArgListHeader);
2705 PrintObjSize(ArgListElement);
2706 PrintObjSize(ComListHeader);
2707 PrintObjSize(ComListElement);
2708 PrintObjSize(TokenListHeader);
2709 PrintObjSize(InfoUnion);
2710 PrintObjSize(IntrinsInfo);
2711 PrintObjSize(ParamInfo);
2712 PrintObjSize(ChildList);
2713 }
2714 #endif
2715