Category : Miscellaneous Language Source Code
Archive   : FTNCHECK.ZIP
Filename : SYMTAB2.C

/* symtab2.c:

Contains two formerly independent files:
I. exprtype.c -- propagates datatype thru expressions.
II. project.c -- project-file I/O routines.

Copyright (C) 1992 by Robert K. Moniot.
This program is free software. Permission is granted to
modify it and/or redistribute it, retaining this notice.
No guarantees accompany this software.


*/

/* I. */

/* exprtype.c:

Routines to propagate datatype through expressions.

binexpr_type() Yields result type of binary expression.
unexpr_type() Yields result type of unary expression.
assignment_stmt_type() Checks assignment statement type.
func_ref_expr(id,args,result) Forms token for a function invocation.
primary_id_expr() Forms token for primary which is an identifier.
int int_power(x,n) Computes x**n for value propagation.
*/

#include
#include
#include "ftnchek.h"
#include "symtab.h"
#include "tokdefs.h"

PRIVATE int int_power();

/* shorthand for datatypes. must match those in symtab.h */

#define E 0 /* Error for invalid type combos */
#define I 1
#define R 2
#define D 3
#define C 4
#define L 5
#define S 6
#define H 7

#define W 10+ /* Warning for nonstandard type combos */

/* for + - / * ** ANSI book pp. 6-5,6-6 */
/* Mixed double+complex = complex with warning */
unsigned char arith_expr_type[8][8]={
/*E I R D C L S H */
{ E, E, E, E, E, E, E, E }, /* E */
{ E, I, R, D, C, E, E, E }, /* I */
{ E, R, R, D, C, E, E, E }, /* R */
{ E, D, D, D,W C, E, E, E }, /* D */
{ E, C, C,W C, C, E, E, E }, /* C */
{ E, E, E, E, E, E, E, E }, /* L */
{ E, E, E, E, E, E, E, E }, /* S */
{ E, E, E, E, E, E, E, E } /* H */
};

/* for relops. Corresponds to arith type table
except that nonstandard comparisons of like
types have warning, not error. */
unsigned char rel_expr_type[8][8]={
/*E I R D C L S H */
{ E, E, E, E, E, E, E, E }, /* E */
{ E, L, L, L, L, E, E,W L }, /* I */
{ E, L, L, L, L, E, E, E }, /* R */
{ E, L, L, L,W L, E, E, E }, /* D */
{ E, L, L,W L, L, E, E, E }, /* C */
{ E, E, E, E, E,W L, E,W L }, /* L */
{ E, E, E, E, E, E, L, E }, /* S */
{ E,W L, E, E, E,W L, E,W L } /* H */
};

/* Result of assignment: lvalue = expr. Here rows
correspond to type of lvalue, columns to type
of expr */
unsigned char assignment_type[8][8]={
/*E I R D C L S H */
{ E, E, E, E, E, E, E, E }, /* E */
{ E, I, I, I, I, E, E,W I }, /* I */
{ E, R, R, R, R, E, E, E }, /* R */
{ E, D, D, D,W D, E, E, E }, /* D */
{ E, C, C,W C, C, E, E, E }, /* C */
{ E, E, E, E, E, L, E,W L }, /* L */
{ E, E, E, E, E, E, S, E }, /* S */
{ E, E, E, E, E, E, E, E } /* H not possible for lvalue */
};

/* this routine propagates type in binary expressions */

void
binexpr_type(term1,operator,term2,result)
Token *term1, *operator, *term2, *result;
{
int op = operator->class,
type1 = datatype_of(term1->class),
type2 = datatype_of(term2->class),
result_type;

if( ! is_computational_type(type1) ) {
syntax_error(term1->line_num,term1->col_num,
"noncomputational primary in expression");
result_type = E;
}
else if( ! is_computational_type(type2) ) {
syntax_error(term2->line_num,term2->col_num,
"noncomputational primary in expression");
result_type = E;
}
else {
switch(op) {
/* arithmetic operators: use lookup table */
case '+':
case '-':
case '*':
case '/':
case tok_power:
result_type = (unsigned)arith_expr_type[type1][type2];
break;

/* relational operators: use lookup table */
case tok_relop:
result_type = (unsigned)rel_expr_type[type1][type2];
break;

/* logical operators: operands should be
logical, but allow integers with a
warning. */
case tok_AND:
case tok_OR:
case tok_EQV:
case tok_NEQV:
if(type1 == L && type2 == L)
result_type = L;
else if(type1 == I && type2 == I)
result_type = W I;
else
result_type = E;
break;

/* // operator: operands must be strings */
case tok_concat:
if(type1 == S && type2 == S)
result_type = S;
else
result_type = E;
break;

default:
syntax_error(operator->line_num,operator->col_num,
"oops--operator unknown: type not propagated");
result_type = type1;
break;
}

if( (type1 != E && type2 != E) )
if( result_type == E) {
syntax_error(operator->line_num,operator->col_num,
"type mismatch in expression");
}
else if(result_type >= (W 0)) { /* W result */
if(f77_standard)
warning(operator->line_num,operator->col_num,
"nonstandard type combination in expression");
result_type -= (W 0);
}
}

result->class = type_byte(class_VAR, result_type);
result->subclass = 0; /* clear all flags */

/* Keep track of constant expressions */
if( is_true(CONST_EXPR,term1->subclass)
&& is_true(CONST_EXPR,term2->subclass)
&& !(op==tok_power && type2!=I) ) { /* exclude **REAL */
make_true(CONST_EXPR,result->subclass);
}
/* Parameter expressions are like constant exprs
except we bend the rules to allow intrinsic functions
and **REAL */
if( is_true(PARAMETER_EXPR,term1->subclass)
&& is_true(PARAMETER_EXPR,term2->subclass) ) {
make_true(PARAMETER_EXPR,result->subclass);
}

/* Remember if integer division was used */
if(result_type == type_INTEGER &&
(op == '/' ||
(is_true(INT_QUOTIENT_EXPR,term1->subclass) ||
is_true(INT_QUOTIENT_EXPR,term2->subclass))) ) {
make_true(INT_QUOTIENT_EXPR,result->subclass);
}

/* Issue warning if integer expr involving division is
later converted to any real type, or if it is used
as an exponent. */
if( is_true(INT_QUOTIENT_EXPR,term1->subclass)
|| is_true(INT_QUOTIENT_EXPR,term2->subclass) ) {

int r=result_type;
if(r == type_LOGICAL) /* relational tests are equivalent */
r = arith_expr_type[type1][type2]; /* to subtraction */

if(op == tok_power && is_true(INT_QUOTIENT_EXPR,term2->subclass) ) {
if(trunc_check)
warning(operator->line_num,operator->col_num,
"integer quotient expr used in exponent");
if( ! is_true(INT_QUOTIENT_EXPR,term1->subclass) )
make_false(INT_QUOTIENT_EXPR,result->subclass);
}
else if( r == type_REAL || r == type_DP || r == type_COMPLEX) {
if(trunc_check)
warning(operator->line_num,operator->col_num,
"integer quotient expr converted to real");
}
}

/* If either term is an identifier, set use flag */
if(is_true(ID_EXPR,term1->subclass))
use_variable(term1);
if(is_true(ID_EXPR,term2->subclass))
use_variable(term2);

/* Propagate the value of integer constant expressions */
if(is_true(CONST_EXPR,result->subclass)) {
if(result_type == type_INTEGER) { /* Only ints propagated */
int a = int_expr_value(term1),
b = int_expr_value(term2),
c;
switch(op) {
case '+': c = a+b; break;
case '-': c = a-b; break;
case '*': c = a*b; break;
case '/': if(b == 0) {
syntax_error(term2->line_num,term2->col_num,
"division by zero attempted");
c = 0;
}
else {
c = a/b;
}
break;
case tok_power: c = int_power(a,b); break;
case tok_AND: c = a&b; break;
case tok_OR: c = a|b; break;
case tok_EQV: c = ~(a^b); break;
case tok_NEQV: c = a^b; break;
default: fprintf(stderr,"Oops--invalid int expr operator");
c = 0; break;
}

result->value.integer = c; /* Result goes into token value */

/* Integer division (including i**neg)
that yields 0 is suspicious. */
if(trunc_check)
if(c==0 && (op=='/' || op==tok_power)) {
warning(operator->line_num,operator->col_num,
"integer const expr yields result of 0");
}
}
}
/* Also nonconstant**neg is 0 unless
nonconstant=1 */
else if(trunc_check)
if(result_type == type_INTEGER && op == tok_power
&& is_true(CONST_EXPR,term2->subclass)
&& int_expr_value(term2) < 0) {
warning(operator->line_num,operator->col_num,
"integer to negative power usually yields 0");
}

}/*binexpr_type*/


/* this routine propagates type in unary expressions */

void
unexpr_type(operator,term1,result)
Token *term1, *operator, *result;
{
int op = operator->class,
type1 = datatype_of(term1->class),
result_type;

if( ! is_computational_type(type1) ) {
syntax_error(term1->line_num,term1->col_num,
"noncomputational primary in expression");
result_type = E;
}
else {
switch(op) {
/* arith operators: use diagonal of lookup table */
case '+':
case '-':
result_type = arith_expr_type[type1][type1];
break;

/* NOT: operand should be
logical, but allow integers with a
warning. */
case tok_NOT:
if(type1 == L)
result_type = L;
else if(type1 == I)
result_type = W I;
else
result_type = E;
break;

default:
syntax_error(operator->line_num,operator->col_num,
"oops: unary operator type not propagated");
result_type = type1;
break;
}

if( type1 != E )
if( result_type == E) {
syntax_error(operator->line_num,operator->col_num,
"type mismatch in expression");
}
else if(result_type >= (W 0)) {
if(f77_standard)
warning(operator->line_num,operator->col_num,
"nonstandard type usage in expression");
result_type -= (W 0);
}
}

result->class = type_byte(class_VAR, result_type);
result->subclass = 0; /* clear all flags */

/* Keep track of constant expressions */
copy_flag(CONST_EXPR,result->subclass,term1->subclass);
copy_flag(PARAMETER_EXPR,result->subclass,term1->subclass);

/* Remember if integer division was used */
if(result_type == type_INTEGER)
copy_flag(INT_QUOTIENT_EXPR,result->subclass,term1->subclass);

if(is_true(ID_EXPR,term1->subclass))
use_variable(term1);

/* Propagate the value of integer constant expressions */
if(is_true(CONST_EXPR,result->subclass)) {
if(result_type == type_INTEGER) { /* Only ints propagated */
int a = int_expr_value(term1),
c;
switch(op) {
case '+': c = a; break;
case '-': c = -a; break;
case tok_NOT: c = ~a; break;
default: fprintf(stderr,"Oops--invalid int expr operator");
c = 0; break;
}

result->value.integer = c; /* Result goes into token value */
}
}
}

/* this routine propagates type in assignment statements */

void
assignment_stmt_type(term1,equals,term2)
Token *term1, *equals, *term2;
{
int type1 = datatype_of(term1->class),
type2 = datatype_of(term2->class),
result_type;


if( ! is_computational_type(type1) ) {
syntax_error(term1->line_num,term1->col_num,
"noncomputational primary in expression");
result_type = E;
}
else if( ! is_computational_type(type2) ) {
syntax_error(term2->line_num,term2->col_num,
"noncomputational primary in expression");
result_type = E;
}
else {
result_type = (unsigned)assignment_type[type1][type2];


if( (type1 != E && type2 != E) )
if( result_type == E) {
syntax_error(equals->line_num,equals->col_num,
"type mismatch in assignment statement");
}
else if(result_type >= (W 0)) { /* W result */
if(f77_standard)
warning(equals->line_num,equals->col_num,
"nonstandard type combination in assignment statement");
result_type -= (W 0);
}
else { /* Watch for truncation to lower precision type */
if(trunc_check)
if(is_computational_type(result_type) &&
result_type < type2) {
warning(equals->line_num,equals->col_num,
type_name[type2]);
msg_tail("truncated to");
msg_tail(type_name[result_type]);
}
}
}


/* Issue warning if integer expr involving division is
later converted to any real type. */
if(trunc_check)
if( is_true(INT_QUOTIENT_EXPR,term2->subclass) ) {

int r=result_type;

if( r == type_REAL || r == type_DP || r == type_COMPLEX)
warning(equals->line_num,equals->col_num,
"integer quotient expr converted to real");
}


if(is_true(ID_EXPR,term2->subclass))
use_variable(term2);

use_lvalue(term1);
}

/* Make an expression-token for a function invocation */

void
func_ref_expr(id,args,result)
Token *id,*args,*result;
{
Lsymtab *symt;
IntrinsInfo *defn;
int rettype;

symt = hashtab[id->value.integer].loc_symtab;

if( symt->intrinsic ) {
defn = symt->info.intrins_info;
/* Intrinsic functions: type stored in info field */
rettype = defn->result_type;

/* Generic Intrinsic functions: use arg type of 1st arg */
if(rettype == type_GENERIC) {
rettype = ( (args->next_token == NULL)?
type_UNDECL : args->next_token->class );
/* special case */
if(rettype == type_COMPLEX && strcmp(symt->name,"ABS") == 0)
rettype = type_REAL;
}
}
else {
rettype = get_type(symt);
}
/* referencing function makes it no longer a class_SUBPROGRAM
but an expression. */
result->class = type_byte(class_VAR,rettype);
result->subclass = 0; /* clear all flags */

/* If intrinsic and all arguments are PARAMETER_EXPRs,
then result is one too. */
if( symt->intrinsic ) {
while( (args=args->next_token) != NULL ) {
if( !is_true(PARAMETER_EXPR,args->subclass) )
return;
}
make_true(PARAMETER_EXPR,result->subclass);
}
}



/* Make an expression-token for primary consisting of
a symbolic name */

void
primary_id_expr(id,primary)
Token *id,*primary;
{
Lsymtab *symt;
symt = hashtab[id->value.integer].loc_symtab;
primary->class = type_byte( storage_class_of(symt->type),
get_type(symt) );
primary->subclass = 0;

make_true(ID_EXPR,primary->subclass);

if( storage_class_of(symt->type) == class_VAR) {
if(symt->parameter) {
make_true(CONST_EXPR,primary->subclass);
make_true(PARAMETER_EXPR,primary->subclass);
}
else {
make_true(LVALUE_EXPR,primary->subclass);
}
if(symt->array_var)
make_true(ARRAY_ID_EXPR,primary->subclass);
if(symt->set_flag || symt->common_var || symt->parameter
|| symt->argument)
make_true(SET_FLAG,primary->subclass);
if(symt->assigned_flag)
make_true(ASSIGNED_FLAG,primary->subclass);
if(symt->used_before_set)
make_true(USED_BEFORE_SET,primary->subclass);
}
else if(storage_class_of(symt->type) == class_STMT_FUNCTION) {
make_true(STMT_FUNCTION_EXPR,primary->subclass);
}

if(debug_parser){
fprintf(list_fd,"\nprimary %s: class=0x%x subclass=0x%x",
symt->name,primary->class,primary->subclass);
}
}


/* Integer power: uses recursion x**n = (x**(n/2))**2 */
PRIVATE int
int_power(x,n)
int x,n;
{
int temp;
/* Order of tests puts commonest cases first */
if(n > 1) {
temp = int_power(x,n>>1);
temp *= temp;
if(n&1) return temp*x; /* Odd n */
else return temp; /* Even n */
}
else if(n == 1) return x;
else if(n < 0) return 1/int_power(x,-n); /* Usually 0 */
else return 1;
}
/* Undefine special macros */
#undef E
#undef I
#undef R
#undef D
#undef C
#undef L
#undef S
#undef H
#undef W


/* II. */

/* project.c:
Project-file I/O routines. Routines included:

Shared routines:
void proj_file_out() writes data from symbol table to project file.
void proj_file_in() reads data from project file to symbol table.

Private routines:
int has_defn() TRUE if external has defn in current file
int has_call() TRUE if external has call in current file
int count_com_defns() Counts multiple common defns.
void proj_alist_out() Outputs argument lists
void proj_clist_out() Outputs common lists
void proj_arg_info_in() Inputs argument lists
void proj_com_info_in() Inputs common lists
*/

#include

#ifdef __STDC__
#include
#else
char *calloc(),*malloc();
void exit();
#endif

/* Note: compilation option PROJ_KEEPALL

Define the symbol PROJ_KEEPALL to make Ftnchek create project files
with complete global symbol table information. Otherwise, the default
action is: in library mode, keep only subprogram definitions, those
external references not defined in the current file, and only one
instance of each common block. In non-library mode, the default is to
keep, besides the above, one call of a given routine from each module,
and all common block declarations.
This flag is useful mainly for debugging purposes.
*/

PRIVATE int has_defn(), has_call();
PRIVATE void proj_alist_out(),proj_clist_out(),
proj_arg_info_in(),proj_com_info_in();

PRIVATE int count_com_defns();


PRIVATE int
has_defn(alist) /* Returns TRUE if list has defns */
ArgListHeader *alist;
{
while( alist != NULL && alist->topfile == top_filename ) {
if(alist->is_defn)
return TRUE;
alist = alist->next;
}
return FALSE;
}


PRIVATE int
has_call(alist) /* Returns TRUE if list has calls or defns */
ArgListHeader *alist;
{
while( alist != NULL && alist->topfile == top_filename) {
if( alist->is_call || alist->actual_arg )
return TRUE;
alist = alist->next;
}
return FALSE;
}

PRIVATE int
count_com_defns(clist) /* Returns number of common decls in list */
ComListHeader *clist;
{
int count=0;
while( clist != NULL && clist->topfile == top_filename ) {
++count;
clist = clist->next;
}
return count;
}


/* proj_file_out: writes data from symbol table to project file. */

#define WRITE_STR(LEADER,S) (fprintf(fd,LEADER), fprintf(fd," %s",S))
#define WRITE_NUM(LEADER,NUM) (fprintf(fd,LEADER), fprintf(fd," %d",NUM))
#define NEXTLINE fprintf(fd,"\n")

void
proj_file_out(fd)
FILE *fd;
{
Gsymtab *sym_list[GLOBSYMTABSZ]; /* temp. list of symtab entries to print */
BYTE sym_has_defn[GLOBSYMTABSZ];
BYTE sym_has_call[GLOBSYMTABSZ];

if(fd == NULL)
return;

WRITE_STR("file",top_filename);
NEXTLINE;

{ /* Make list of subprograms defined or referenced in this file */
int i,numexts,numdefns,numcalls,do_defns,pass;
ArgListHeader *alist;
for(i=0,numexts=numdefns=numcalls=0;i if(storage_class_of(glob_symtab[i].type) == class_SUBPROGRAM &&
(alist=glob_symtab[i].info.arglist) != NULL) {
/* Look for defns and calls of this guy. */

if( (sym_has_defn[numexts]=has_defn(alist)) != (BYTE) FALSE )
numdefns++;
if( (sym_has_call[numexts]= (has_call(alist)
/* keep only externals not satisfied in this file */
#ifndef PROJ_KEEPALL
&& (!library_mode || !sym_has_defn[numexts])
#endif
)) != (BYTE) FALSE )
numcalls++;
if(sym_has_defn[numexts] || sym_has_call[numexts])
sym_list[numexts++] = &glob_symtab[i];
}
}

/* List all subprogram defns, then all calls */
for(pass=0,do_defns=TRUE; pass<2; pass++,do_defns=!do_defns) {

if(do_defns)
WRITE_NUM(" entries",numdefns);
else
WRITE_NUM(" externals",numcalls);
NEXTLINE;

for(i=0; i if( (do_defns && sym_has_defn[i]) || (!do_defns && sym_has_call[i]) ){
if(do_defns)
WRITE_STR(" entry",sym_list[i]->name);
else
WRITE_STR(" external",sym_list[i]->name);

WRITE_NUM(" class",storage_class_of(sym_list[i]->type));
WRITE_NUM(" type",datatype_of(sym_list[i]->type));
fprintf(fd," flags %d %d %d %d %d %d %d %d",
sym_list[i]->used_flag,
sym_list[i]->set_flag,
sym_list[i]->invoked_as_func,
sym_list[i]->declared_external,
/* N.B. library_module included here but is not restored */
sym_list[i]->library_module,
0,0,0); /* for possible future use */
NEXTLINE;
proj_alist_out(sym_list[i],fd,do_defns,(int)sym_has_defn[i]);
}
}/* end for i */
NEXTLINE;
}/*end for pass */
}

{
int i,numblocks,numdefns;
ComListHeader *clist;
for(i=0,numblocks=numdefns=0;i if(storage_class_of(glob_symtab[i].type) == class_COMMON_BLOCK
&& (clist=glob_symtab[i].info.comlist) != NULL &&
clist->topfile == top_filename ) {
#ifndef PROJ_KEEPALL
/* No keepall: save only one com decl if -lib mode */
if(library_mode)
numdefns++;
else
#endif /* keepall or -nolib mode: keep all com decls */
numdefns += count_com_defns(clist);

sym_list[numblocks++] = &glob_symtab[i];
}
}
WRITE_NUM(" comblocks",numdefns);
NEXTLINE;
for(i=0; i proj_clist_out(sym_list[i],fd);
}
NEXTLINE;
}
}




/* proj_alist_out: writes arglist data from symbol table to
project file. */

PRIVATE void
proj_alist_out(gsymt,fd,do_defns,locally_defined)
Gsymtab *gsymt;
FILE *fd;
int do_defns,locally_defined;
{
ArgListHeader *a=gsymt->info.arglist;
ArgListElement *arg;
int i,n;
unsigned long diminfo;
Gsymtab *last_calling_module;


/* This loop runs thru only those arglists that were
created in the current top file. */
last_calling_module = NULL;
while( a != NULL && a->topfile == top_filename) {
/* do_defns mode: output only definitions */
if( (do_defns && a->is_defn) || (!do_defns && !a->is_defn) )
#ifndef PROJ_KEEPALL
/* keep only externals not satisfied in this file in -lib
mode, otherwise keep one actual call from each module. */
if( a->is_defn
|| !locally_defined
|| (!library_mode && (a->is_call || a->actual_arg)
&& a->module != last_calling_module))
#endif
{
last_calling_module = a->module;
if(a->is_defn)
fprintf(fd," defn\n");
else
fprintf(fd," call\n");

WRITE_STR(" module",a->module->name);
WRITE_STR(" file",a->filename);
WRITE_NUM(" line",a->line_num);
WRITE_NUM(" class",storage_class_of(a->type));
WRITE_NUM(" type",datatype_of(a->type));
fprintf(fd," flags %d %d %d %d",
a->is_defn,
a->is_call,
a->external_decl,
a->actual_arg);
NEXTLINE;
n=a->numargs;
if(a->is_defn || a->is_call) {
WRITE_NUM(" args",n);
NEXTLINE;
}

/* Next lines, 1 per argument: type, array dims, array size, flags */
arg = a->arg_array;
for(i=0; i WRITE_NUM(" arg",i+1);
WRITE_NUM(" class",storage_class_of(arg[i].type));
WRITE_NUM(" type",datatype_of(arg[i].type));
diminfo = (
((storage_class_of(arg[i].type) == class_VAR) &&
is_computational_type(datatype_of(arg[i].type))) ?
arg[i].info.array_dim: 0 );
WRITE_NUM(" dims",array_dims(diminfo));
WRITE_NUM(" size",array_size(diminfo));
fprintf(fd," flags %d %d %d %d %d %d %d %d",
arg[i].is_lvalue,
arg[i].set_flag,
arg[i].assigned_flag,
arg[i].used_before_set,
arg[i].array_var,
arg[i].array_element,
arg[i].declared_external,
0); /* possible flag for future use */
NEXTLINE;
}
}/* end if(do_defn...)*/
a = a->next;
}/* end while(a!=NULL)*/
fprintf(fd," end\n");
}/*proj_alist_out*/



/* proj_clist_out writes common var list data from symbol
table to project file. */

PRIVATE void
proj_clist_out(gsymt,fd)
Gsymtab *gsymt;
FILE *fd;
{
ComListHeader *c=gsymt->info.comlist;
ComListElement *cvar;
int i,n;

while( c != NULL && c->topfile == top_filename ) {

WRITE_STR(" block",gsymt->name);
WRITE_NUM(" class",storage_class_of(gsymt->type));
WRITE_NUM(" type",datatype_of(gsymt->type));
NEXTLINE;
WRITE_STR(" module",c->module->name);
WRITE_STR(" file",c->filename);
WRITE_NUM(" line",c->line_num);
WRITE_NUM(" flags",c->flags);
NEXTLINE;
WRITE_NUM(" vars",n=c->numargs);
NEXTLINE;

/* Next lines, 1 per variable: class, type, array dims, array size */
cvar = c->com_list_array;
for(i=0; i WRITE_NUM(" var",i+1);
WRITE_NUM(" class",storage_class_of(cvar[i].type));
WRITE_NUM(" type",datatype_of(cvar[i].type));
WRITE_NUM(" dims",array_dims(cvar[i].dimen_info));
WRITE_NUM(" size",array_size(cvar[i].dimen_info));
NEXTLINE;
}
/* keepall or -nolib: loop thru all defns.
Otherwise only keep the first. */
#ifndef PROJ_KEEPALL
if(library_mode)
break;
#endif
c = c->next;
}/* end while c != NULL */
}

#undef WRITE_STR
#undef WRITE_NUM
#undef NEXTLINE


/* proj_file_in:
Reads a project file, storing info in global symbol table.
See proj_file_out and its subroutines for the current
project file format.
*/
#define MAXNAME 127 /* Max string that will be read in: see READ_STR below */


/* Macros for error-flagging input */

PRIVATE int nil()/* to make lint happy */
{ return 0; }

#define READ_ERROR (fprintf(stderr,\
"Oops-- error reading project file at line %d\n",proj_line_num),\
exit(1),nil())
#define READ_OK nil()

#define READ_FIRST_STR(LEADER,STR) (fscanf(fd,LEADER),fscanf(fd,"%127s",STR))
#define READ_STR(LEADER,STR) ((fscanf(fd,LEADER),\
fscanf(fd,"%127s",STR))==1? READ_OK:READ_ERROR)
#define READ_NUM(LEADER,NUM) ((fscanf(fd,LEADER),\
fscanf(fd,"%d",&NUM))==1? READ_OK:READ_ERROR)
#define NEXTLINE {int c;while( (c=fgetc(fd)) != EOF && c != '\n') continue;\
if(c == EOF) READ_ERROR; else ++proj_line_num;}


int proj_line_num; /* Line number in proj file for diagnostic output */

void
proj_file_in(fd)
FILE *fd;
{
char buf[MAXNAME+1],*topfilename=NULL;
int retval;
unsigned numentries,ientry, numexts,iext, numblocks,iblock;


proj_line_num = 1;

while( (retval=READ_FIRST_STR("file",buf)) == 1) {

/* Save filename in permanent storage */
topfilename = strcpy(malloc(strlen(buf)+1),buf);
NEXTLINE;
#ifdef DEBUG_PROJECT
printf("read file %s\n",topfilename);
#endif


READ_NUM(" entries",numentries); /* Get no. of entry points */
NEXTLINE;
#ifdef DEBUG_PROJECT
printf("read entries %d\n",numentries);
#endif
/* Read defn arglists */
for(ientry=0; ientry proj_arg_info_in(fd,topfilename,TRUE);
}
NEXTLINE;

READ_NUM(" externals",numexts); /* Get no. of external refs */
#ifdef DEBUG_PROJECT
printf("read exts %d\n",numexts);
#endif
NEXTLINE;

/* Read invocation & ext def arglists */
for(iext=0; iext proj_arg_info_in(fd,topfilename,FALSE);
}
NEXTLINE;


/* Read common block info */

READ_NUM(" comblocks",numblocks);
#ifdef DEBUG_PROJECT
printf("read num blocks %d\n",numblocks);
#endif
NEXTLINE;

for(iblock=0; iblock proj_com_info_in(fd,topfilename);
}
NEXTLINE;

}/* end while(retval == 1) */

if(retval != EOF) READ_ERROR;

init_symtab(); /* Clear out local strspace */
}

static char *prev_file_name="";/* used to reduce number of callocs */

/* Read arglist info */
PRIVATE void
proj_arg_info_in(fd,filename,is_defn)
FILE *fd;
char *filename; /* name of toplevel file */
int is_defn;
{
char id_name[MAXNAME+1],module_name[MAXNAME+1],sentinel[6];
char file_name[MAXNAME+1];
int id_class,id_type;
unsigned
id_used_flag,
id_set_flag,
id_invoked,
id_declared,
id_library_module,
future1,future2,future3;

unsigned h;
Gsymtab *gsymt, *module;
unsigned alist_class,alist_type,alist_is_defn,alist_is_call,
alist_external_decl,alist_actual_arg;
unsigned alist_line;
unsigned numargs,iarg,arg_num,arg_class,arg_type,arg_dims,arg_size;
unsigned /* Flags for arguments */
arg_is_lvalue,
arg_set_flag,
arg_assigned_flag,
arg_used_before_set,
arg_array_var,
arg_array_element,
arg_declared_external,
arg_future_flag; /* possible flag for future use */

if(is_defn)
READ_STR(" entry",id_name); /* Entry point name */
else
READ_STR(" external",id_name); /* External name */
READ_NUM(" class",id_class); /* class as in symtab */
READ_NUM(" type",id_type); /* type as in symtab */
if(fscanf(fd," flags %d %d %d %d %d %d %d %d",
&id_used_flag,
&id_set_flag,
&id_invoked,
&id_declared,
&id_library_module,
&future1,&future2,&future3) != 8) READ_ERROR;
NEXTLINE;

#ifdef DEBUG_PROJECT
printf("read id name %s class %d type %d\n",
id_name,id_class,id_type);
#endif

/* Create global symtab entry */
h = hash_lookup(id_name);
if( (gsymt = hashtab[h].glob_symtab) == NULL)
gsymt = install_global(h,id_type,class_SUBPROGRAM);

/* Set library_module flag if project file was created
with -lib mode in effect, or is now taken in -lib mode */
if(is_defn && (library_mode || id_library_module)) {
gsymt->library_module = TRUE;
}

if(id_used_flag)
gsymt->used_flag = TRUE;
if(id_set_flag)
gsymt->set_flag = TRUE;
if(id_invoked)
gsymt->invoked_as_func = TRUE;
if(id_declared)
gsymt->declared_external = TRUE;

while( fscanf(fd,"%5s",sentinel),
#ifdef DEBUG_PROJECT
printf("sentinel=[%s]\n",sentinel),
#endif
strcmp(sentinel,(is_defn?"defn":"call")) == 0) {
ArgListHeader *ahead;
ArgListElement *alist;

NEXTLINE;

READ_STR(" module",module_name);
READ_STR(" file",file_name);
READ_NUM(" line",alist_line); /* line number */
READ_NUM(" class",alist_class); /* class as in ArgListHeader */
READ_NUM(" type",alist_type); /* type as in ArgListHeader */
if(fscanf(fd," flags %d %d %d %d",
&alist_is_defn,
&alist_is_call,
&alist_external_decl,
&alist_actual_arg) != 4) READ_ERROR;
NEXTLINE;
#ifdef DEBUG_PROJECT
printf("read alist class %d type %d line %d\n",
alist_class,alist_type,alist_line);
#endif
/* Find current module in symtab. If not there, make
a global symtab entry for it. It will be filled
in eventually when processing corresponding entry.
*/

h = hash_lookup(module_name);
if( (module = hashtab[h].glob_symtab) == NULL) {
module = install_global(h,type_UNDECL,class_SUBPROGRAM);
}
if(module->internal_entry) {
fprintf(list_fd,"\nWarning: entry point %s redefined as module",
module->name);
fprintf(list_fd,"\n\tin project file: redefinition ignored");
}
else {
if(is_defn) {
if(module != gsymt) {
#ifdef DEBUG_PROJECT
printf("\nLinking entry %s to module %s",
gsymt->name,module->name);
#endif
gsymt->internal_entry = TRUE;
gsymt->link.module=module; /* interior entry: link it to module */
}
}
else { /* call: add to child list */
/* Avoid duplication on child list. It will have just
been placed there on previous project-file entry,
so it will be the first child on the list.
*/
#ifdef DEBUG_PROJECT
printf("\nChild %s of module %s",
gsymt->name,module->name);
#endif
if(module->link.child_list == NULL
|| module->link.child_list->child != gsymt) {
ChildList *node=
(ChildList *)calloc(1,sizeof(ChildList));
#ifdef DEBUG_PROJECT
printf(" linked in");
#endif
node->child = gsymt;
node->next = module->link.child_list;
module->link.child_list = node;
}
#ifdef DEBUG_PROJECT
else {
printf(" (duplicate)");
}
#endif
}
}

if(alist_is_defn || alist_is_call) {
READ_NUM(" args",numargs);
NEXTLINE;
}
else
numargs = 0;

#ifdef DEBUG_PROJECT
printf("read numargs %d\n",numargs);
#endif
/*
** if(!is_defn) {
** gsymt->used_flag = TRUE;
** }
*/
/* Create arglist structure */
if(((ahead=(ArgListHeader *) calloc(1, sizeof(ArgListHeader)))
== (ArgListHeader *) NULL) ||
(numargs != 0 &&
((alist=(ArgListElement *) calloc(numargs,sizeof(ArgListElement)))
== (ArgListElement *) NULL))){
fprintf(stderr, "Oops: Out of space for argument list\n");
exit(1);
}

/* Initialize arglist and link it to symtab */
ahead->type = type_byte(alist_class,alist_type);
ahead->numargs = numargs;
ahead->arg_array = (numargs==0? NULL: alist);
ahead->module = module;
ahead->topfile = filename;
/* try to avoid reallocating space for same name */
ahead->filename =
(strcmp(file_name,filename)==0? filename:
(strcmp(file_name,prev_file_name)==0? prev_file_name:
(prev_file_name=strcpy(malloc(strlen(file_name)+1),file_name))));

ahead->line_num = alist_line;
ahead->is_defn = alist_is_defn;
ahead->is_call = alist_is_call;
ahead->external_decl = alist_external_decl;
ahead->actual_arg = alist_actual_arg;
ahead->next = gsymt->info.arglist;
gsymt->info.arglist = ahead;

/* Fill arglist array from project file */
for(iarg=0; iarg READ_NUM(" arg",arg_num); if(arg_num != iarg+1) READ_ERROR;
READ_NUM(" class",arg_class);
READ_NUM(" type",arg_type);
READ_NUM(" dims",arg_dims);
READ_NUM(" size",arg_size);
if(fscanf(fd," flags %d %d %d %d %d %d %d %d",
&arg_is_lvalue,
&arg_set_flag,
&arg_assigned_flag,
&arg_used_before_set,
&arg_array_var,
&arg_array_element,
&arg_declared_external,
&arg_future_flag) != 8) READ_ERROR;

alist[iarg].info.array_dim = array_dim_info(arg_dims,arg_size);
alist[iarg].type = type_byte(arg_class,arg_type);
alist[iarg].is_lvalue = arg_is_lvalue;
alist[iarg].set_flag = arg_set_flag;
alist[iarg].assigned_flag = arg_assigned_flag;
alist[iarg].used_before_set = arg_used_before_set;
alist[iarg].array_var = arg_array_var;
alist[iarg].array_element = arg_array_element;
alist[iarg].declared_external = arg_declared_external;
NEXTLINE;
#ifdef DEBUG_PROJECT
printf("read arg num %d\n",arg_num);
#endif
}

}/* end while( sentinel == "defn"|"call") */

if(strcmp(sentinel,"end") != 0) READ_ERROR;
NEXTLINE;
}


PRIVATE void
proj_com_info_in(fd,filename)
FILE *fd;
char *filename;
{
char id_name[MAXNAME+1],module_name[MAXNAME+1];
char file_name[MAXNAME+1];
unsigned id_class,id_type;
unsigned clist_flags,clist_line;
unsigned numvars,ivar,var_num,var_class,var_type,var_dims,var_size;

unsigned h;
Gsymtab *gsymt, *module;
ComListHeader *chead;
ComListElement *clist;


READ_STR(" block",id_name);
READ_NUM(" class",id_class);
READ_NUM(" type",id_type);
#ifdef DEBUG_PROJECT
printf("read com name %s class %d type %d\n",
id_name,id_class,id_type);
#endif
NEXTLINE;

READ_STR(" module",module_name);
READ_STR(" file",file_name);
READ_NUM(" line",clist_line);
READ_NUM(" flags",clist_flags);
NEXTLINE;

READ_NUM(" vars",numvars);
#ifdef DEBUG_PROJECT
printf("read flags %d line %d\n",clist_flags,clist_line);
#endif
NEXTLINE;
/* Create global symtab entry */
h = hash_lookup(id_name);
if( (gsymt = hashtab[h].com_glob_symtab) == NULL)
gsymt = install_global(h,id_type,id_class);


/* Create arglist structure */
if(((chead=(ComListHeader *) calloc(1, sizeof(ComListHeader)))
== (ComListHeader *) NULL) ||
(numvars != 0 &&
((clist=(ComListElement *) calloc(numvars,sizeof(ComListElement)))
== (ComListElement *) NULL))){
fprintf(stderr, "Oops: Out of space for common list\n");
exit(1);
}

/* Find current module in symtab. If not there, make
a global symtab entry for it. This is bogus, since
all modules should have been defined previously. */

h = hash_lookup(module_name);
if( (module = hashtab[h].glob_symtab) == NULL) {
fprintf(stderr,"\nWarning-- something's bogus in project file\n");
module = install_global(h,type_UNDECL,class_SUBPROGRAM);
}

/* Initialize arglist and link it to symtab */
chead->numargs = numvars;
chead->flags = clist_flags;
chead->line_num = clist_line;
chead->com_list_array = (numvars==0? NULL: clist);
chead->module = module;
chead->topfile = filename;
/* try to avoid reallocating space for same name */
chead->filename =
(strcmp(file_name,filename)==0? filename:
(strcmp(file_name,prev_file_name)==0? prev_file_name:
(prev_file_name=strcpy(malloc(strlen(file_name)+1),file_name))));

chead->next = gsymt->info.comlist;
gsymt->info.comlist = chead;

/* Fill comlist array from project file */
for(ivar=0; ivar READ_NUM(" var",var_num); if(var_num != ivar+1) READ_ERROR;
READ_NUM(" class",var_class);
READ_NUM(" type",var_type);
READ_NUM(" dims",var_dims);
READ_NUM(" size",var_size);
NEXTLINE;
#ifdef DEBUG_PROJECT
printf("read class %d type %d dims %d size %d\n",var_class,var_type,
var_dims,var_size);
#endif
clist[ivar].dimen_info = array_dim_info(var_dims,var_size);
clist[ivar].type = type_byte(var_class,var_type);
}
}/*proj_com_info_in*/