/* 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 <stdio.h>
#include <string.h>
#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 -		/*  Warning for nonstandard type combos */

			/* for  + - / * **	ANSI book pp. 6-5,6-6	*/
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,  E,  E,  E,  E },	/* D */
{ E,  C,  C,  E,  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. */
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,  E,  E,  E,  E },	/* D */
{ E,  L,  L,  E,  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 */
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,  D,  E,  E,  E },	/* D */
{ E,  C,  C,  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 = arith_expr_type[type1][type2];
		break;

				/* relational operators: use lookup table */
 	    case tok_relop:
		result_type = 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 < 0) {		/* W result */
		warning(operator->line_num,operator->col_num,
			"nonstandard type combination in expression");
		result_type = -result_type;
	    }
    }

    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)  ) {
		make_true(CONST_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) ) {
	    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) {
	    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 */
	}
    }

}/*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 < 0) {
		warning(operator->line_num,operator->col_num,
			"nonstandard type usage in expression");
		result_type = -result_type;
	    }
    }

    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);

		/* 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 = 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 < 0) {		/* W result */
		warning(equals->line_num,equals->col_num,
		"nonstandard type combination in assignment statement");
		result_type = -result_type;
	    }
	    else {	/* Watch for truncation to lower precision type */
		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( 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;
{
	symtab *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 */
}



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

void
primary_id_expr(id,primary)
	Token *id,*primary;
{
	symtab *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);
		}
		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 <string.h>

#ifdef __STDC__
#include <stdlib.h>
#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.  Default is to keep
   only subprogram definitions, those external references not defined in
   the current file, and only one instance of each common block.

   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();

#ifdef PROJ_KEEPALL
PRIVATE int count_com_defns();
#endif


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;
}

#ifdef PROJ_KEEPALL
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;
}
#endif

	/* 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;
{
  symtab *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<glob_symtab_top;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
				   && !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<numexts; 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<glob_symtab_top;i++) {
      if(storage_class_of(glob_symtab[i].type) == class_COMMON_BLOCK
	 && (clist=glob_symtab[i].info.comlist) != NULL &&
	 clist->topfile == top_filename ) {
#ifdef PROJ_KEEPALL
	numdefns += count_com_defns(clist);
#else				/* No keepall: save only one decl */
	numdefns++;
#endif
	sym_list[numblocks++] = &glob_symtab[i];
      }
    }
    WRITE_NUM(" comblocks",numdefns);
    NEXTLINE;
    for(i=0; i<numblocks; 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(symt,fd,do_defns,locally_defined)
     symtab *symt;
     FILE *fd;
     int do_defns,locally_defined;
{
  ArgListHeader *a=symt->info.arglist;
  ArgListElement *arg;
  int i,n;
  unsigned long diminfo;


		/* This loop runs thru only those arglists that were
		    created in the current top file. */
    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 */
    if( a->is_defn
       || !locally_defined )
#endif
     {
      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<n; 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(symt,fd)
     symtab *symt;
     FILE *fd;
{
    ComListHeader *c=symt->info.comlist;
    ComListElement *cvar;
    int i,n;
#ifdef PROJ_KEEPALL
    while			/* keepall: loop thru all defns */
#else
    if				/* no keepall: just save one defn */
#endif
      (c != NULL && c->topfile == top_filename) {

      WRITE_STR(" block",symt->name);
      WRITE_NUM(" class",storage_class_of(symt->type));
      WRITE_NUM(" type",datatype_of(symt->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<n; 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;
      }
      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<numentries; 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<numexts; 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<numblocks; 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;
    symtab *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 taken in lib mode */
    if(is_defn && library_mode) {
      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;
		/* library_module not copied, since it usually used to
		   suppress messages while making project file. */
/*    if(id_library_module)
**      gsymt->library_module = TRUE;
*/
   while(   fscanf(fd,"%5s",sentinel),
#ifdef DEBUG_PROJECT
 printf("sentinel=[%s]=%d\n",sentinel,strcmp(sentinel,"more")),
#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(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<numargs; 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;
      symtab *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<numvars; 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*/