1 /* $Id: project.c,v 1.12 2002/08/24 15:54:17 moniot Rel $
2
3 project.c:
4
5 Project-file I/O routines.
6
7
8 Copyright (c) 2001 by Robert K. Moniot.
9
10 Permission is hereby granted, free of charge, to any person
11 obtaining a copy of this software and associated documentation
12 files (the "Software"), to deal in the Software without
13 restriction, including without limitation the rights to use,
14 copy, modify, merge, publish, distribute, sublicense, and/or
15 sell copies of the Software, and to permit persons to whom the
16 Software is furnished to do so, subject to the following
17 conditions:
18
19 The above copyright notice and this permission notice shall be
20 included in all copies or substantial portions of the
21 Software.
22
23 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY
24 KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE
25 WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
26 PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
27 COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
28 LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
29 OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
30 SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
31
32 Acknowledgement: the above permission notice is what is known
33 as the "MIT License."
34
35 Routines included:
36
37 Shared routines:
38 void proj_file_out() writes data from symbol table to project file.
39 void proj_file_in() reads data from project file to symbol table.
40
41 Private routines:
42 int has_defn() TRUE if external has defn in current file
43 int has_call() TRUE if external has call in current file
44 int count_com_defns() Counts multiple common defns.
45 void proj_alist_out() Outputs argument lists
46 void proj_clist_out() Outputs common lists
47 void proj_arg_info_in() Inputs argument lists
48 void proj_com_info_in() Inputs common lists
49 */
50
51 #include <stdio.h>
52 #include <string.h>
53 #include "ftnchek.h"
54 #define PROJECT
55 #include "symtab.h"
56 #include <string.h>
57
58 /* Two options, proj_trim_calls and proj_trim_common, control whether
59 Ftnchek creates project files with partial or complete global
60 symbol table information. If these options are TRUE (the usual
61 case), the action is: in library mode, keep only subprogram
62 definitions, those external references not defined in the current
63 file, and only one instance of each common block. In non-library
64 mode, keep, besides the above, one call of a given routine from
65 each module, and all common block declarations. Setting
66 proj_trim_calls to FALSE causes all definitions and calls to be
67 kept. Setting proj_trim_common to FALSE causes all common block
68 instances to be kept. (In this case the action is the same whether
69 or not in library mode.) These options formerly were controlled by
70 compile-time define PROJ_KEEPALL. They are useful mainly for
71 debugging ftnchek and for using the project files for purposes
72 other than ftnchek. */
73
74 #define PROJFILE_COOKIE "FTNCHEK_" /* first part of magic cookie */
75
76
77 PROTO(PRIVATE int count_com_defns,( ComListHeader *clist ));
78 PROTO(PRIVATE char *getstrn,(char s[], int n, FILE *fd));
79 PROTO(PRIVATE int has_call,( ArgListHeader *alist ));
80 PROTO(PRIVATE int has_defn,( ArgListHeader *alist ));
81 PROTO(PRIVATE int nil,( void ));
82 PROTO(PRIVATE void proj_alist_out,( Gsymtab *gsymt, FILE *fd, int
83 do_defns, int locally_defined ));
84 PROTO(PRIVATE void proj_arg_info_in,( FILE *fd, char *filename, int is_defn ));
85 PROTO(PRIVATE void proj_clist_out,( Gsymtab *gsymt, FILE *fd ));
86 PROTO(PRIVATE void proj_com_info_in,( FILE *fd, char *filename ));
87
88
89
90 PRIVATE int
91 #if HAVE_STDC
has_defn(ArgListHeader * alist)92 has_defn(ArgListHeader *alist) /* Returns TRUE if list has defns */
93 #else /* K&R style */
94 has_defn(alist) /* Returns TRUE if list has defns */
95 ArgListHeader *alist;
96 #endif /* HAVE_STDC */
97 {
98 while( alist != NULL && alist->topfile == top_filename ) {
99 if(alist->is_defn)
100 return TRUE;
101 alist = alist->next;
102 }
103 return FALSE;
104 }
105
106
107 PRIVATE int
108 #if HAVE_STDC
has_call(ArgListHeader * alist)109 has_call(ArgListHeader *alist) /* Returns TRUE if list has calls or defns */
110 #else /* K&R style */
111 has_call(alist) /* Returns TRUE if list has calls or defns */
112 ArgListHeader *alist;
113 #endif /* HAVE_STDC */
114 {
115 while( alist != NULL && alist->topfile == top_filename) {
116 if( alist->is_call || alist->actual_arg )
117 return TRUE;
118 alist = alist->next;
119 }
120 return FALSE;
121 }
122
123 PRIVATE int
124 #if HAVE_STDC
count_com_defns(ComListHeader * clist)125 count_com_defns(ComListHeader *clist) /* Returns number of common decls in list */
126 #else /* K&R style */
127 count_com_defns(clist) /* Returns number of common decls in list */
128 ComListHeader *clist;
129 #endif /* HAVE_STDC */
130 {
131 int count=0;
132 while( clist != NULL && clist->topfile == top_filename ) {
133 ++count;
134 clist = clist->next;
135 }
136 return count;
137 }
138
139
140 /* proj_file_out: writes data from symbol table to project file. */
141
142 #define WRITE_STR(LEADER,S) (void)(fprintf(fd,LEADER), fprintf(fd," %s",S))
143 #define WRITE_ARG(LEADER,S) (void)(fprintf(fd,LEADER), fprintf(fd," %s",S))
144 #define WRITE_NUM(LEADER,NUM) (void)(fprintf(fd,LEADER), fprintf(fd," %ld",NUM))
145 #define NEXTLINE (void)fprintf(fd,"\n")
146
147 void
148 #if HAVE_STDC
proj_file_out(FILE * fd)149 proj_file_out(FILE *fd)
150 #else /* K&R style */
151 proj_file_out(fd)
152 FILE *fd;
153 #endif /* HAVE_STDC */
154 {
155 Gsymtab *sym_list[GLOBSYMTABSZ]; /* temp. list of symtab entries to print */
156 char sym_has_defn[GLOBSYMTABSZ];
157 char sym_has_call[GLOBSYMTABSZ];
158
159 if(fd == NULL)
160 return;
161
162 WRITE_STR(PROJFILE_COOKIE,PROJECT_VERSION); /* magic cookie */
163 NEXTLINE;
164
165 WRITE_STR("file",top_filename);
166 NEXTLINE;
167
168 { /* Make list of subprograms defined or referenced in this file */
169 int i,numexts,numdefns,numcalls,do_defns,pass;
170 ArgListHeader *alist;
171 for(i=0,numexts=numdefns=numcalls=0;i<glob_symtab_top;i++) {
172 if(storage_class_of(glob_symtab[i].type) == class_SUBPROGRAM &&
173 (alist=glob_symtab[i].info.arglist) != NULL) {
174 /* Look for defns and calls of this guy. */
175
176 if( (sym_has_defn[numexts]=has_defn(alist)) != FALSE )
177 numdefns++;
178 if( (sym_has_call[numexts]= (has_call(alist)
179 /* keep only externals not satisfied in this file unless
180 -project=no-trim-calls given.
181 */
182 && (!proj_trim_calls ||
183 (!library_mode || !sym_has_defn[numexts]))
184 )) != FALSE )
185 numcalls++;
186 if(sym_has_defn[numexts] || sym_has_call[numexts])
187 sym_list[numexts++] = &glob_symtab[i];
188 }
189 }
190
191 /* List all subprogram defns, then all calls */
192 for(pass=0,do_defns=TRUE; pass<2; pass++,do_defns=!do_defns) {
193
194 if(do_defns)
195 WRITE_NUM(" entries",(long)numdefns);
196 else
197 WRITE_NUM(" externals",(long)numcalls);
198 NEXTLINE;
199
200 for(i=0; i<numexts; i++) {
201 if( (do_defns && sym_has_defn[i]) || (!do_defns && sym_has_call[i]) ){
202 if(do_defns)
203 WRITE_STR(" entry",sym_list[i]->name);
204 else
205 WRITE_STR(" external",sym_list[i]->name);
206
207 WRITE_NUM(" class",(long)storage_class_of(sym_list[i]->type));
208 WRITE_NUM(" type",(long)datatype_of(sym_list[i]->type));
209 WRITE_NUM(" size",(long)sym_list[i]->size);
210 /* Flag values stored are cumulative only for current file
211 so they will not depend on what files were previously
212 read in current run. When project file is read, flags
213 will be ORed into Gsymtab as is done in process_lists.
214 */
215 (void)fprintf(fd," flags %d %d %d %d %d %d %d %d",
216 sym_list[i]->used_this_file,
217 sym_list[i]->set_this_file,
218 sym_list[i]->invoked_as_func_this_file,
219 sym_list[i]->declared_external_this_file,
220 /* N.B. library_module included here but is not restored */
221 sym_list[i]->library_module,
222 0, /* Flags for possible future use */
223 0,
224 0);
225 NEXTLINE;
226 proj_alist_out(sym_list[i],fd,do_defns,(int)sym_has_defn[i]);
227 }
228 }/* end for i */
229 NEXTLINE;
230 }/*end for pass */
231 }
232
233 {
234 int i,numblocks,numdefns;
235 ComListHeader *clist;
236 for(i=0,numblocks=numdefns=0;i<glob_symtab_top;i++) {
237 if(storage_class_of(glob_symtab[i].type) == class_COMMON_BLOCK
238 && (clist=glob_symtab[i].info.comlist) != NULL &&
239 clist->topfile == top_filename ) {
240 /* No keepall: save only one com decl if -lib mode */
241 if( proj_trim_common && library_mode)
242 numdefns++;
243 else
244 /* keepall or -nolib mode: keep all com decls */
245 numdefns += count_com_defns(clist);
246
247 sym_list[numblocks++] = &glob_symtab[i];
248 }
249 }
250 WRITE_NUM(" comblocks",(long)numdefns);
251 NEXTLINE;
252 for(i=0; i<numblocks; i++) {
253 proj_clist_out(sym_list[i],fd);
254 }
255 NEXTLINE;
256 }
257 }
258
259
260
261
262 /* proj_alist_out: writes arglist data from symbol table to
263 project file. */
264
265 PRIVATE void
266 #if HAVE_STDC
proj_alist_out(Gsymtab * gsymt,FILE * fd,int do_defns,int locally_defined)267 proj_alist_out(Gsymtab *gsymt, FILE *fd, int do_defns, int locally_defined)
268 #else /* K&R style */
269 proj_alist_out(gsymt,fd,do_defns,locally_defined)
270 Gsymtab *gsymt;
271 FILE *fd;
272 int do_defns,locally_defined;
273 #endif /* HAVE_STDC */
274 {
275 ArgListHeader *a=gsymt->info.arglist;
276 ArgListElement *arg;
277 int i,n;
278 unsigned long diminfo;
279 Gsymtab *last_calling_module;
280
281
282 /* This loop runs thru only those arglists that were
283 created in the current top file. */
284 last_calling_module = NULL;
285 while( a != NULL && a->topfile == top_filename) {
286 /* do_defns mode: output only definitions */
287 if( (do_defns && a->is_defn) || (!do_defns && !a->is_defn) )
288
289 /* keep only externals not satisfied in this file in -lib
290 mode, otherwise keep one actual call from each module. */
291 if( ! proj_trim_calls ||
292 (a->is_defn
293 || !locally_defined
294 || (!library_mode && (a->is_call || a->actual_arg)
295 && a->module != last_calling_module)) )
296
297 {
298 last_calling_module = a->module;
299 if(a->is_defn)
300 (void)fprintf(fd," defn\n");
301 else
302 (void)fprintf(fd," call\n");
303
304 WRITE_STR(" module",a->module->name);
305 WRITE_STR(" file",a->filename);
306 WRITE_NUM(" line",(long)a->line_num);
307 WRITE_NUM(" top",(long)a->top_line_num);
308 WRITE_NUM(" class",(long)storage_class_of(a->type));
309 WRITE_NUM(" type",(long)datatype_of(a->type));
310 WRITE_NUM(" size",(long)a->size);
311 (void)fprintf(fd," flags %d %d %d %d",
312 a->is_defn,
313 a->is_call,
314 a->external_decl,
315 a->actual_arg);
316 NEXTLINE;
317 n=a->numargs;
318 if(a->is_defn || a->is_call) {
319 WRITE_NUM(" args",(long)n);
320 NEXTLINE;
321 }
322
323 /* Next lines, 2 per argument.
324 1st line: position number & name or source text of expr
325 2nd line: type, array dims, array size, flags
326 */
327 arg = a->arg_array;
328 for(i=0; i<n; i++) {
329 WRITE_NUM(" arg",(long)i+1);
330 WRITE_ARG(" name",arg[i].name);
331 NEXTLINE;
332 WRITE_NUM(" class",(long)storage_class_of(arg[i].type));
333 WRITE_NUM(" type",(long)datatype_of(arg[i].type));
334 WRITE_NUM(" size",(long)arg[i].size);
335 diminfo = (
336 ((storage_class_of(arg[i].type) == class_VAR) &&
337 is_computational_type(datatype_of(arg[i].type))) ?
338 arg[i].info.array_dim: 0 );
339 WRITE_NUM(" dims",(long)array_dims(diminfo));
340 WRITE_NUM(" elts",(long)array_size(diminfo));
341 { char *cblk;
342 if( arg[i].common_block == (Gsymtab *)NULL )
343 cblk = "-"; /* place holder if no block name */
344 else
345 cblk = arg[i].common_block->name;
346 WRITE_STR(" cblk",cblk);
347 }
348 WRITE_NUM(" cndx",(long)arg[i].common_index);
349 WRITE_NUM(" same",(long)arg[i].same_as);
350 (void)fprintf(fd," flags %d %d %d %d %d %d %d %d",
351 arg[i].is_lvalue,
352 arg[i].set_flag,
353 arg[i].assigned_flag,
354 arg[i].used_before_set,
355 arg[i].array_var,
356 arg[i].array_element,
357 arg[i].declared_external,
358 arg[i].active_do_var);
359 NEXTLINE;
360 }
361 }/* end if(do_defn...)*/
362 a = a->next;
363 }/* end while(a!=NULL)*/
364 (void)fprintf(fd," end\n");
365 }/*proj_alist_out*/
366
367
368
369 /* proj_clist_out writes common var list data from symbol
370 table to project file. */
371
372 PRIVATE void
373 #if HAVE_STDC
proj_clist_out(Gsymtab * gsymt,FILE * fd)374 proj_clist_out(Gsymtab *gsymt, FILE *fd)
375 #else /* K&R style */
376 proj_clist_out(gsymt,fd)
377 Gsymtab *gsymt;
378 FILE *fd;
379 #endif /* HAVE_STDC */
380 {
381 ComListHeader *c=gsymt->info.comlist;
382 ComListElement *cvar;
383 int i,n;
384
385 while( c != NULL && c->topfile == top_filename ) {
386
387 WRITE_STR(" block",gsymt->name);
388 WRITE_NUM(" class",(long)storage_class_of(gsymt->type));
389 WRITE_NUM(" type",(long)datatype_of(gsymt->type));
390 NEXTLINE;
391 WRITE_STR(" module",c->module->name);
392 WRITE_STR(" file",c->filename);
393 WRITE_NUM(" line",(long)c->line_num);
394 WRITE_NUM(" top",(long)c->top_line_num);
395 (void)fprintf(fd," flags %d %d %d %d",
396 c->any_used,
397 c->any_set,
398 c->saved,
399 0); /* Flag for possible future use */
400 NEXTLINE;
401 WRITE_NUM(" vars",(long)(n=c->numargs));
402 NEXTLINE;
403
404 /* Next lines, 2 per variable.
405 1st line: position number, name.
406 2nd line: class, type, array dims, array size
407 */
408 cvar = c->com_list_array;
409 for(i=0; i<n; i++) {
410 WRITE_NUM(" var",(long)i+1);
411 WRITE_STR(" name",cvar[i].name);
412 NEXTLINE;
413 WRITE_NUM(" class",(long)storage_class_of(cvar[i].type));
414 WRITE_NUM(" type",(long)datatype_of(cvar[i].type));
415 WRITE_NUM(" size",(long)cvar[i].size);
416 WRITE_NUM(" dims",(long)array_dims(cvar[i].dimen_info));
417 WRITE_NUM(" elts",(long)array_size(cvar[i].dimen_info));
418 (void)fprintf(fd," flags %d %d %d %d %d %d %d %d",
419 cvar[i].used,
420 cvar[i].set,
421 cvar[i].used_before_set,
422 cvar[i].assigned,
423 0, /* possible flags for future use */
424 0,
425 0,
426 0);
427 NEXTLINE;
428 }
429 /* keepall or -nolib: loop thru all defns.
430 Otherwise only keep the first. */
431 if(proj_trim_common && library_mode)
432 break;
433 c = c->next;
434 }/* end while c != NULL */
435 }
436
437 #undef WRITE_STR
438 #undef WRITE_NUM
439 #undef NEXTLINE
440
441
442 /* proj_file_in:
443 Reads a project file, storing info in global symbol table.
444 See proj_file_out and its subroutines for the current
445 project file format.
446 */
447 #define MAXNAME 127 /* Max string that will be read in: see READ_STR below */
448
449
450 /* Macros for error-flagging input */
451
nil(VOID)452 PRIVATE int nil(VOID)/* to make lint happy */
453 { return 0; }
454
455 #define READ_ERROR (oops_message(OOPS_FATAL,proj_line_num,NO_COL_NUM,\
456 "error reading project file"),nil())
457 #define READ_OK nil()
458
459 #define READ_FIRST_STR(LEADER,STR) (fscanf(fd,LEADER), \
460 fscanf(fd,"%127s",STR))
461 #define READ_STR(LEADER,STR) ((void)((fscanf(fd,LEADER)==0 &&\
462 fscanf(fd,"%127s",STR)==1)? READ_OK:READ_ERROR))
463 #define READ_ARG(LEADER,STR) ((void)((fscanf(fd,LEADER)==0 && fgetc(fd)==' ' &&\
464 (getstrn(STR,MAXNAME+1,fd)!=NULL)==1)? READ_OK:READ_ERROR))
465 #define READ_NUM(LEADER,NUM) ((void)((fscanf(fd,LEADER)==0 &&\
466 fscanf(fd,"%d",&NUM)==1)? READ_OK:READ_ERROR))
467 #define READ_LONG(LEADER,NUM) ((void)((fscanf(fd,LEADER)==0 &&\
468 fscanf(fd,"%ld",&NUM)==1)? READ_OK:READ_ERROR))
469 #define NEXTLINE {int c;while( (c=fgetc(fd)) != EOF && c != '\n') continue;\
470 if(c == EOF) READ_ERROR; else ++proj_line_num;}
471
472
473 PRIVATE unsigned proj_line_num;
474 /* Line number in proj file for diagnostic output */
475
476 void
477 #if HAVE_STDC
proj_file_in(FILE * fd)478 proj_file_in(FILE *fd)
479 #else /* K&R style */
480 proj_file_in(fd)
481 FILE *fd;
482 #endif /* HAVE_STDC */
483 {
484 char buf[MAXNAME+1],*topfilename=NULL;
485 int retval;
486 unsigned numentries,ientry, numexts,iext, numblocks,iblock;
487
488 proj_line_num = 1;
489
490 /* Allow project file to contain (manually) concatenated project files.
491 These will be processed as if the separate project files were
492 sequentially provided as arguments.
493 */
494 do {
495
496 while( (retval=READ_FIRST_STR(PROJFILE_COOKIE,buf)) == 1) {
497 if( strcmp(buf,PROJECT_VERSION) != 0 ) {
498 (void)fprintf(stderr,
499 "\nProject file is not correct version -- must be re-created\n");
500 exit(1);
501 }
502 NEXTLINE;
503 /* Save filename in permanent storage */
504 READ_STR("file",buf);
505 topfilename = new_global_string(buf);
506 NEXTLINE;
507 #ifdef DEBUG_PROJECT
508 printf("\nread file %s\n",topfilename);
509 #endif
510
511
512 READ_NUM(" entries",numentries); /* Get no. of entry points */
513 NEXTLINE;
514 #ifdef DEBUG_PROJECT
515 printf("read entries %d\n",numentries);
516 #endif
517 /* Read defn arglists */
518 for(ientry=0; ientry<numentries; ientry++) {
519 proj_arg_info_in(fd,topfilename,TRUE);
520 }
521 NEXTLINE;
522
523 READ_NUM(" externals",numexts); /* Get no. of external refs */
524 #ifdef DEBUG_PROJECT
525 printf("read exts %d\n",numexts);
526 #endif
527 NEXTLINE;
528
529 /* Read invocation & ext def arglists */
530 for(iext=0; iext<numexts; iext++) {
531 proj_arg_info_in(fd,topfilename,FALSE);
532 }
533 NEXTLINE;
534
535
536 /* Read common block info */
537
538 READ_NUM(" comblocks",numblocks);
539 #ifdef DEBUG_PROJECT
540 printf("read num blocks %d\n",numblocks);
541 #endif
542 NEXTLINE;
543
544 for(iblock=0; iblock<numblocks; iblock++) {
545 proj_com_info_in(fd,topfilename);
546 }
547 NEXTLINE;
548
549 }/* end while(retval == 1) */
550
551 init_symtab(); /* Clear out local strspace */
552
553 /* End of a logical project file. Continue to read any others
554 concatenated together. */
555 } while(retval != EOF);
556 }
557
558 static char *prev_file_name="";/* used to reduce number of callocs */
559
560 /* Read arglist info */
561 PRIVATE void
562 #if HAVE_STDC
proj_arg_info_in(FILE * fd,char * filename,int is_defn)563 proj_arg_info_in(FILE *fd, char *filename, int is_defn)
564 /* name of toplevel file */
565 #else /* K&R style */
566 proj_arg_info_in(fd,filename,is_defn)
567 FILE *fd;
568 char *filename; /* name of toplevel file */
569 int is_defn;
570 #endif /* HAVE_STDC */
571 {
572 char id_name[MAXNAME+1],module_name[MAXNAME+1],sentinel[6];
573 char file_name[MAXNAME+1];
574 char arg_name[MAXNAME+1];
575
576 #ifndef KEEP_ARG_NAMES
577 static char var[]="var", /* text strings to use for now */
578 expr[]="expr";
579 #endif
580 int id_class,id_type;
581 long id_size;
582 unsigned
583 id_used_flag,
584 id_set_flag,
585 id_invoked,
586 id_declared,
587 id_library_module,
588 future1,future2,future3;
589
590 unsigned h;
591 Gsymtab *gsymt, *module;
592 unsigned alist_class,alist_type,alist_is_defn,alist_is_call,
593 alist_external_decl,alist_actual_arg;
594 unsigned alist_line, alist_topline;
595 long alist_size;
596 unsigned numargs,iarg,arg_num,arg_class,arg_type,arg_dims;
597 unsigned long arg_elts;
598 long arg_size;
599 char arg_common_block[MAXNAME+1];
600 long arg_common_index;
601 int arg_same_as;
602 unsigned /* Flags for arguments */
603 arg_is_lvalue,
604 arg_set_flag,
605 arg_assigned_flag,
606 arg_used_before_set,
607 arg_array_var,
608 arg_array_element,
609 arg_declared_external,
610 arg_active_do_var;
611
612 if(is_defn)
613 READ_STR(" entry",id_name); /* Entry point name */
614 else
615 READ_STR(" external",id_name); /* External name */
616 READ_NUM(" class",id_class); /* class as in symtab */
617 READ_NUM(" type",id_type); /* type as in symtab */
618 READ_LONG(" size",id_size); /* size as in symtab */
619 if(fscanf(fd," flags %d %d %d %d %d %d %d %d",
620 &id_used_flag,
621 &id_set_flag,
622 &id_invoked,
623 &id_declared,
624 &id_library_module,
625 &future1,&future2,&future3) != 8) READ_ERROR;
626 NEXTLINE;
627
628 #ifdef DEBUG_PROJECT
629 printf("read id name %s class %d type %d\n",
630 id_name,id_class,id_type);
631 #endif
632
633 /* Create global symtab entry */
634 h = hash_lookup(id_name);
635 if( (gsymt = hashtab[h].glob_symtab) == NULL) {
636 gsymt = install_global((int)h,id_type,class_SUBPROGRAM);
637 gsymt->size = id_size;
638 }
639 else if(is_defn)
640 gsymt->size = id_size;
641
642 /* Set library_module flag if project file was created
643 with -lib mode in effect, or is now taken in -lib mode */
644 if(is_defn && (library_mode || id_library_module)) {
645 gsymt->library_module = TRUE;
646 }
647 if(is_defn)
648 gsymt->defined = TRUE;
649 if(id_used_flag)
650 gsymt->used_flag = TRUE;
651 if(id_set_flag)
652 gsymt->set_flag = TRUE;
653 if(id_invoked)
654 gsymt->invoked_as_func = TRUE;
655 if(id_declared)
656 gsymt->declared_external = TRUE;
657
658 while( fscanf(fd,"%5s",sentinel),
659 #ifdef DEBUG_PROJECT
660 printf("sentinel=[%s]\n",sentinel),
661 #endif
662 strcmp(sentinel,(is_defn?"defn":"call")) == 0) {
663 ArgListHeader *ahead;
664 ArgListElement *alist;
665 #ifdef KEEP_ARG_NAMES
666 ArgListHeader *prev_ahead;
667 ArgListElement *prev_alist;
668 unsigned prev_n;
669 #endif
670
671 NEXTLINE;
672
673 READ_STR(" module",module_name);
674 READ_STR(" file",file_name);
675 READ_NUM(" line",alist_line); /* line number */
676 READ_NUM(" top",alist_topline); /* topfile line number */
677 READ_NUM(" class",alist_class); /* class as in ArgListHeader */
678 READ_NUM(" type",alist_type); /* type as in ArgListHeader */
679 READ_LONG(" size",alist_size); /* size as in ArgListHeader */
680 if(fscanf(fd," flags %d %d %d %d",
681 &alist_is_defn,
682 &alist_is_call,
683 &alist_external_decl,
684 &alist_actual_arg) != 4) READ_ERROR;
685 NEXTLINE;
686 #ifdef DEBUG_PROJECT
687 printf("read alist class %d type %d line %d\n",
688 alist_class,alist_type,alist_line);
689 #endif
690 /* Find current module in symtab. If not there, make
691 a global symtab entry for it. It will be filled
692 in eventually when processing corresponding entry.
693 */
694
695 h = hash_lookup(module_name);
696 if( (module = hashtab[h].glob_symtab) == NULL) {
697 module = install_global((int)h,type_UNDECL,class_SUBPROGRAM);
698 }
699 if(module->internal_entry) {
700 warning(NO_LINE_NUM,NO_COL_NUM,
701 "entry point redefined as module");
702 msg_tail(module->name);
703 msg_tail(": redefinition ignored");
704 }
705 else {
706 if(is_defn) {
707 if(module != gsymt) {
708 #ifdef DEBUG_PROJECT
709 printf("\nLinking entry %s to module %s",
710 gsymt->name,module->name);
711 #endif
712 gsymt->internal_entry = TRUE;
713 gsymt->link.module=module; /* interior entry: link it to module */
714 }
715 }
716 else { /* call: add to child list */
717 /* Avoid duplication on child list. It will have just
718 been placed there on previous project-file entry,
719 so it will be the first child on the list.
720 */
721 #ifdef DEBUG_PROJECT
722 printf("\nChild %s of module %s",
723 gsymt->name,module->name);
724 #endif
725 if(module->link.child_list == NULL
726 || module->link.child_list->child != gsymt) {
727 ChildList *node=
728 (ChildList *)calloc(1,sizeof(ChildList));
729 #ifdef DEBUG_PROJECT
730 printf(" linked in");
731 #endif
732 node->child = gsymt;
733 node->next = module->link.child_list;
734 module->link.child_list = node;
735 }
736 #ifdef DEBUG_PROJECT
737 else {
738 printf(" (duplicate)");
739 }
740 #endif
741 }
742 }
743
744 if(alist_is_defn || alist_is_call) {
745 READ_NUM(" args",numargs);
746 NEXTLINE;
747 }
748 else
749 numargs = 0;
750
751 #ifdef DEBUG_PROJECT
752 printf("read numargs %d\n",numargs);
753 #endif
754 /*
755 ** if(!is_defn) {
756 ** gsymt->used_flag = TRUE;
757 ** }
758 */
759 /* Create arglist structure */
760 if(((ahead=(ArgListHeader *) calloc(1, sizeof(ArgListHeader)))
761 == (ArgListHeader *) NULL) ||
762 (numargs != 0 &&
763 ((alist=(ArgListElement *) calloc(numargs,sizeof(ArgListElement)))
764 == (ArgListElement *) NULL))){
765 oops_message(OOPS_FATAL,proj_line_num,NO_COL_NUM,
766 "out of malloc space for argument list");
767 }
768
769 /* Initialize arglist and link it to symtab */
770 ahead->type = type_byte(alist_class,alist_type);
771 ahead->size = alist_size;
772 ahead->numargs = (short)numargs;
773 ahead->arg_array = (numargs==0? NULL: alist);
774 ahead->module = module;
775 ahead->topfile = filename;
776 /* try to avoid reallocating space for same name */
777 ahead->filename =
778 (strcmp(file_name,filename)==0? filename:
779 (strcmp(file_name,prev_file_name)==0? prev_file_name:
780 (prev_file_name=new_global_string(file_name))));
781
782 ahead->line_num = alist_line;
783 ahead->top_line_num = alist_topline;
784 ahead->is_defn = alist_is_defn;
785 ahead->is_call = alist_is_call;
786 ahead->external_decl = alist_external_decl;
787 ahead->actual_arg = alist_actual_arg;
788 ahead->next = prev_ahead = gsymt->info.arglist;
789 gsymt->info.arglist = ahead;
790 if(prev_ahead != NULL) {
791 prev_n = prev_ahead->numargs;
792 prev_alist = prev_ahead->arg_array;
793 }
794
795 /* Fill arglist array from project file */
796 for(iarg=0; iarg<numargs; iarg++) {
797 READ_NUM(" arg",arg_num); if(arg_num != iarg+1) READ_ERROR;
798 READ_ARG(" name",arg_name);
799 READ_NUM(" class",arg_class);
800 READ_NUM(" type",arg_type);
801 READ_LONG(" size",arg_size);
802 READ_NUM(" dims",arg_dims);
803 READ_LONG(" elts",arg_elts);
804 READ_STR(" cblk",arg_common_block);
805 READ_LONG(" cndx",arg_common_index);
806 READ_NUM(" same",arg_same_as);
807 if(fscanf(fd," flags %d %d %d %d %d %d %d %d",
808 &arg_is_lvalue,
809 &arg_set_flag,
810 &arg_assigned_flag,
811 &arg_used_before_set,
812 &arg_array_var,
813 &arg_array_element,
814 &arg_declared_external,
815 &arg_active_do_var) != 8) READ_ERROR;
816
817 #ifdef KEEP_ARG_NAMES
818 /* Economize storage by re-using previously allocated
819 space for same name in prior call if any */
820 alist[iarg].name = (prev_ahead != NULL && iarg < prev_n &&
821 strcmp(arg_name,prev_alist[iarg].name) == 0) ?
822 prev_alist[iarg].name:
823 new_global_string(arg_name);
824 #else
825 if(strcmp(arg_name,expr) == 0) /* For now, just use "var" and "expr" */
826 alist[iarg].name = expr;
827 else
828 alist[iarg].name = var;
829 #endif
830 alist[iarg].info.array_dim = array_dim_info(arg_dims,arg_elts);
831 alist[iarg].type = type_byte(arg_class,arg_type);
832 alist[iarg].size = arg_size;
833 if( strcmp(arg_common_block,"-") == 0 ) { /* indicator for "none" */
834 alist[iarg].common_block = (Gsymtab *)NULL;
835 }
836 else {
837 Gsymtab *g_symt;
838 int hh = hash_lookup(arg_common_block);
839 /* Block may not have been seen yet since common
840 decls come at end of project file. There is a
841 risk that block could end up in Gsymtab with no
842 definition, but only if project file is corrupt.
843 */
844 if( (g_symt = hashtab[hh].com_glob_symtab) == NULL)
845 g_symt = install_global(hh,type_COMMON_BLOCK,class_COMMON_BLOCK);
846 alist[iarg].common_block = g_symt;
847 }
848 alist[iarg].common_index = arg_common_index;
849 alist[iarg].same_as = (short)arg_same_as;
850 alist[iarg].is_lvalue = arg_is_lvalue;
851 alist[iarg].set_flag = arg_set_flag;
852 alist[iarg].assigned_flag = arg_assigned_flag;
853 alist[iarg].used_before_set = arg_used_before_set;
854 alist[iarg].array_var = arg_array_var;
855 alist[iarg].array_element = arg_array_element;
856 alist[iarg].declared_external = arg_declared_external;
857 alist[iarg].active_do_var = arg_active_do_var;
858 NEXTLINE;
859 #ifdef DEBUG_PROJECT
860 printf("read arg num %d name %s\n",arg_num,arg_name);
861 #endif
862 }
863
864 }/* end while( sentinel == "defn"|"call") */
865
866 if(strcmp(sentinel,"end") != 0) READ_ERROR;
867 NEXTLINE;
868 }
869
870
871 PRIVATE void
872 #if HAVE_STDC
proj_com_info_in(FILE * fd,char * filename)873 proj_com_info_in(FILE *fd, char *filename)
874 #else /* K&R style */
875 proj_com_info_in(fd,filename)
876 FILE *fd;
877 char *filename;
878 #endif /* HAVE_STDC */
879 {
880 char id_name[MAXNAME+1],module_name[MAXNAME+1];
881 char file_name[MAXNAME+1];
882 char var_name[MAXNAME+1];
883 unsigned id_class,id_type;
884 unsigned /* Flags in ComListHeader */
885 clist_any_used,
886 clist_any_set,
887 clist_saved,
888 clist_future;
889 unsigned clist_line,clist_topline;
890 unsigned numvars,prev_n,ivar,var_num,var_class,var_type,var_dims;
891 unsigned long var_elts;
892 unsigned /* Flags for common variables */
893 var_used,
894 var_set,
895 var_used_before_set,
896 var_assigned,
897 var_future_4,
898 var_future_3,
899 var_future_2,
900 var_future_1;
901 long var_size;
902 int h;
903 Gsymtab *gsymt, *module;
904 ComListHeader *chead,*prev_chead;
905 ComListElement *clist,*prev_clist;
906
907
908 READ_STR(" block",id_name);
909 READ_NUM(" class",id_class);
910 READ_NUM(" type",id_type);
911 #ifdef DEBUG_PROJECT
912 printf("read com name %s class %d type %d\n",
913 id_name,id_class,id_type);
914 #endif
915 NEXTLINE;
916
917 READ_STR(" module",module_name);
918 READ_STR(" file",file_name);
919 READ_NUM(" line",clist_line);
920 READ_NUM(" top",clist_topline);
921 if(fscanf(fd," flags %d %d %d %d",
922 &clist_any_used,
923 &clist_any_set,
924 &clist_saved,
925 &clist_future) != 4) READ_ERROR;
926 NEXTLINE;
927
928 READ_NUM(" vars",numvars);
929 #ifdef DEBUG_PROJECT
930 printf("read module %s file %s",module_name,file_name);
931 printf(" flags %d %d %d %d line %d\n",
932 clist_any_used,
933 clist_any_set,
934 clist_saved,
935 clist_future,
936 clist_line);
937 #endif
938 NEXTLINE;
939 /* Create global symtab entry */
940 h = hash_lookup(id_name);
941 if( (gsymt = hashtab[h].com_glob_symtab) == NULL)
942 gsymt = install_global(h,(int)id_type,(int)id_class);
943
944
945 /* Create arglist structure */
946 if(((chead=(ComListHeader *) calloc(1, sizeof(ComListHeader)))
947 == (ComListHeader *) NULL) ||
948 (numvars != 0 &&
949 ((clist=(ComListElement *) calloc(numvars,sizeof(ComListElement)))
950 == (ComListElement *) NULL))){
951 oops_message(OOPS_FATAL,proj_line_num,NO_COL_NUM,
952 "out of malloc space for common list");
953 }
954
955 /* Find current module in symtab. If not there, make
956 a global symtab entry for it. This is bogus, since
957 all modules should have been defined previously. */
958
959 h = hash_lookup(module_name);
960 if( (module = hashtab[h].glob_symtab) == NULL) {
961 (void)fprintf(stderr,"\nWarning-- something's bogus in project file\n");
962 module = install_global(h,type_UNDECL,class_SUBPROGRAM);
963 }
964
965 /* Initialize arglist and link it to symtab */
966 chead->numargs = (short)numvars;
967 chead->line_num = clist_line;
968 chead->top_line_num = clist_topline;
969 chead->com_list_array = (numvars==0? NULL: clist);
970 chead->module = module;
971 chead->topfile = filename;
972 chead->any_used = clist_any_used;
973 chead->any_set = clist_any_set;
974 chead->saved = clist_saved;
975 /* try to avoid reallocating space for same name */
976 chead->filename =
977 (strcmp(file_name,filename)==0? filename:
978 (strcmp(file_name,prev_file_name)==0? prev_file_name:
979 (prev_file_name=new_global_string(file_name))));
980
981 chead->next = prev_chead = gsymt->info.comlist;
982 gsymt->info.comlist = chead;
983 if(prev_chead != NULL) {
984 prev_n = prev_chead->numargs;
985 prev_clist = prev_chead->com_list_array;
986 }
987
988 /* Fill comlist array from project file */
989 for(ivar=0; ivar<numvars; ivar++) {
990 READ_NUM(" var",var_num); if(var_num != ivar+1) READ_ERROR;
991 READ_STR(" name",var_name);
992 NEXTLINE;
993 READ_NUM(" class",var_class);
994 READ_NUM(" type",var_type);
995 READ_LONG(" size",var_size);
996 READ_NUM(" dims",var_dims);
997 READ_LONG(" elts",var_elts);
998 if(fscanf(fd," flags %d %d %d %d %d %d %d %d",
999 &var_used,
1000 &var_set,
1001 &var_used_before_set,
1002 &var_assigned,
1003 &var_future_4,
1004 &var_future_3,
1005 &var_future_2,
1006 &var_future_1) != 8) READ_ERROR;
1007 NEXTLINE;
1008 #ifdef DEBUG_PROJECT
1009 printf("read name %s class %d type %d dims %d size %d\n",
1010 var_name,var_class,var_type,var_dims,var_size);
1011 #endif
1012 /* Economize storage by re-using previously allocated
1013 space for same name in prior decl if any */
1014 clist[ivar].name = (prev_chead != NULL && ivar < prev_n &&
1015 strcmp(var_name,prev_clist[ivar].name) == 0) ?
1016 prev_clist[ivar].name:
1017 new_global_string(var_name);
1018
1019 clist[ivar].dimen_info = array_dim_info(var_dims,var_elts);
1020 clist[ivar].type = type_byte(var_class,var_type);
1021 clist[ivar].size = var_size;
1022 clist[ivar].used = var_used;
1023 clist[ivar].set = var_set;
1024 clist[ivar].used_before_set = var_used_before_set;
1025 clist[ivar].assigned = var_assigned;
1026 }
1027 }/*proj_com_info_in*/
1028
1029 /* Function to read n-1 characters, or up to newline, whichever
1030 * comes first. Differs from fgets in that the newline is replaced
1031 * by null, and characters up to newline (if any) past the n-1st
1032 * are read and thrown away.
1033 * Returns NULL when end-of-file or error is encountered.
1034 */
1035 PRIVATE char *
1036 #if HAVE_STDC
getstrn(char * s,int n,FILE * fd)1037 getstrn(char *s, int n, FILE *fd)
1038 #else /* K&R style */
1039 getstrn(s,n,fd)
1040 char s[];
1041 int n;
1042 FILE *fd;
1043 #endif /* HAVE_STDC */
1044 {
1045 int i=0,c;
1046
1047 while( (c=getc(fd)) != '\n' ) {
1048 if(c == EOF)
1049 return NULL;
1050
1051 if(i < n-1)
1052 s[i++] = c;
1053 }
1054 s[i] = '\0';
1055 return s;
1056 }
1057