home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / fchk294s.zip / ftnchek-2.9.4 / symtab.c < prev    next >
C/C++ Source or Header  |  1996-09-13  |  111KB  |  4,040 lines
  1. /* symtab.c:
  2.  
  3. Contains formerly separate modules:
  4.    I. Symtab: symbol table maintenance routines.
  5.   II. Hash:  hash table functions: hash(), kwd_hash(), rehash()
  6.  III. Intrins: handles recognition & data typing of intrinsic functions.
  7.  
  8.  
  9.     Copyright (C) 1992 by Robert K. Moniot.
  10.     This program is free software.  Permission is granted to
  11.     modify it and/or redistribute it, retaining this notice.
  12.     No guarantees accompany this software.
  13.  
  14.  
  15. */
  16.  
  17. /*
  18.   I. Symtab
  19.  
  20.  
  21.         Symbol table routines for Fortran program checker.
  22.  
  23.       Shared functions defined:
  24.  
  25.  
  26.        call_func(id,arg)     Handles function invocations.
  27.        call_subr(id,arg)     Handles CALL statements.
  28.        declare_type(id,datatype,size) Handles TYPE statements.
  29.        def_arg_name(id)     Handles func/subr argument lists.
  30.        def_array_dim(id,arg) Handles dimensioning declarations.
  31.        def_com_block(id)     Handles common blocks and SAVE stmts.
  32.        def_com_variable(id)     Handles common block lists.
  33.        int def_curr_module(id)     Identifies symbol as current module.
  34.             def_equiv_name(id)     Initializes equivalence list items.
  35.        def_ext_name(id)     Handles external lists.
  36.        def_function(datatype,size,size_text,id,args)
  37.                Installs function name in global table.
  38.        def_intrins_name(id)  Handles intrinsic lists.
  39.        def_parameter(id,value) Handles parameter_defn_item
  40.        def_stmt_function(id) Declares a statement function.
  41.        do_ASSIGN(id)     Handles ASSIGN stmts.
  42.        do_assigned_GOTO(id)     Handles assigned GOTO.
  43.        do_ENTRY(id,args,hashno) Processes ENTRY statement.
  44.        do_RETURN(hashno,keyword) Processes RETURN statement.
  45.        equivalence(id1,id2)     equivalences two variables
  46.        int get_type(symt)     Finds out data type of symbol, or uses implicit
  47.                  typing to establish its type.
  48.        int get_size(symt,type)     Finds out size of symbol's datatype.
  49.     unsigned hash_lookup(s)     Looks up identifier in hashtable.
  50.        init_globals()     Initializes global symbol info.
  51.        init_symtab()     Clears local symbol table & removes locals
  52.                  from stringspace. Also restores default
  53.                  implicit data typing.
  54.  Gsymtab* install_global(t,datatype,storage_class) Installs indentifier in
  55.                 global symbol table.
  56.  Lsymtab* install_local(t,datatype,storage_class) Installs indentifier in
  57.                 local symbol table.
  58. ArgListHeader* make_arg_array(t) Converts list of tokens into list of
  59.                  type-flag pairs.
  60. ArgListHeader* make_dummy_arg_array(t) Converts list of tokens into list of
  61.                  type-flag pairs.
  62. ArgListHeader* make_arrayless_alist() Sets up argument list header for
  63.                 EXTERNAL decl or subprog as actual arg.
  64.  
  65. ComListHeader* make_com_array(t) Converts list of common block tokens into
  66.                  list of dimen_info-type pairs.
  67.        process_lists()     Places pointer to linked list of arrays in
  68.                  global symbol table
  69.        ref_array(id,subscrs) Handles array references
  70.        ref_variable(id)     Handles accessing variable name.
  71.        set_implicit_type(type,size,c1,c2) Processes IMPLICIT statement.
  72.        stmt_function_stmt(id) Finishes processing stmt func defn.
  73.     char * token_name(t)     Returns ptr to token's symbol's name.
  74.        use_actual_arg(id)     Handles using a variable as actual arg.
  75.        use_io_keyword(id_keywd,id_val,class) Handles i/o control specifier.
  76.        use_len_arg(id)     Handles arguments passed to LEN.
  77.        use_lvalue(id)     Handles assignment to a variable.
  78.        use_parameter(id)     Handles data_constant_value &
  79.                  data_repeat_factor.
  80.        use_variable(id)     Sets used-flag for a variable used in expr.
  81.  
  82. */
  83.  
  84. /*  private functions defined:
  85.  arg_count(t)        Counts the number of arguments in a token list.
  86.  call_external(symt,id,arg)    places token list of args into local symtab
  87.  check_intrins_args(arg, defn) Checks call seq of intrinsic functions
  88.  check_stmt_function_args(symt,id,arg)  ditto for statement functions
  89.  find_intrinsic()        Looks up intrinsic functions in table
  90.  find_io_keyword()        Looks up i/o control spec keywords
  91.  reverse_tokenlist(t)        Reverses a linked list of tokens
  92.  make_TL_head();        Initializes a tokenlist header
  93.  new_tokhead();            Allocates space for a tokenlist header
  94. */
  95.  
  96. #include <stdio.h>
  97. #include <string.h>
  98. #include <ctype.h>
  99. #define SYMTAB
  100. #include "ftnchek.h"
  101. #include "symtab.h"
  102. #include "tokdefs.h"
  103.  
  104. #ifdef DEVELOPMENT        /* for maintaining the program */
  105. #define DEBUG_SIZES
  106. #endif
  107.  
  108. PRIVATE long
  109.   parameter_count;    /* Count of parameters for keeping them in order */
  110.  
  111. PRIVATE StrSpace *
  112. curr_loc_strspace;        /* Ptr to current local string space struct */
  113.  
  114. PRIVATE StrSpace *
  115. curr_srctextspace;        /* Ptr to current token string space struct */
  116.  
  117. PRIVATE ParamInfoSpace *
  118. curr_paraminfospace;        /* Ptr to current param info space struct */
  119.  
  120. PRIVATE TokHeadSpace *
  121. curr_tokheadspace;        /* Ptr to current TokHeadSpace struct */
  122.  
  123. PRIVATE TokenSpace *
  124. curr_tokspace;            /* Ptr to current TokenSpace struct */
  125.  
  126. PRIVATE PtrSpace *
  127. curr_ptrspace;            /* Ptr to current PtrSpace struct */
  128.  
  129.  
  130. PROTO(PRIVATE unsigned arg_count,( Token *t ));
  131. PROTO(PRIVATE void call_external,( Lsymtab *symt, Token *id, Token *arg ));
  132. PROTO(PRIVATE void check_intrins_args,( Token *id, Token *arg ));
  133. PROTO(PRIVATE void check_stmt_function_args,( Lsymtab *symt, Token *id, Token *arg ));
  134. PROTO(PRIVATE int cp_tok_src_text,( char *s, Token *t, int max ));
  135. PROTO(PRIVATE int cp_tree_src_text,( char *s, Token *t, int max ));
  136. PROTO(PRIVATE int cp_list_src_text,( char *s, Token *t, int max ));
  137. PROTO(PRIVATE Lsymtab* install_local,( int h, int datatype, int storage_class ));
  138. PROTO(PRIVATE ArgListHeader * make_arg_array,( Token *t ));
  139. PROTO(PRIVATE void make_arg_names,( Token *tlist, ArgListHeader *alhead,
  140.               ArgListHeader *prev_alhead ));
  141. PROTO(PRIVATE ComListHeader * make_com_array,( Token *t ));
  142. PROTO(PRIVATE void make_com_names,( Token *tlist, ComListHeader *clhead,
  143.               ComListHeader *prev_clhead ));
  144. PROTO(PRIVATE ArgListHeader * make_arrayless_alist,( void ));
  145. PROTO(PRIVATE ArgListHeader * make_dummy_arg_array ,( Token *t ));
  146. PROTO(PRIVATE TokenListHeader * make_TL_head,( Token *t ));
  147. PROTO(PRIVATE char * new_local_string,( char *s ));
  148. PROTO(PRIVATE ParamInfo * new_param_info,( void ));
  149. PROTO(PRIVATE TokenListHeader * new_tokhead,( void ));
  150. PROTO(PRIVATE Token * reverse_tokenlist,( Token *t ));
  151. PROTO(PRIVATE void use_function_arg,( Token *id ));
  152. PROTO(PRIVATE void use_len_arg,( Token *id ));
  153. PROTO(PRIVATE unsigned long kwd_hash,( char *s ));
  154. PROTO(PRIVATE void set_intrinsic_numargs, ( char *name, int choice ));
  155. PROTO(PRIVATE IntrinsInfo * find_intrinsic,( char *s ));
  156. PROTO(PRIVATE int find_io_keyword,( char *s ));
  157.  
  158. PROTO(PRIVATE ArgListElement * new_arglistelement,( unsigned count ));
  159. PROTO(PRIVATE ArgListHeader * new_arglistheader,( void ));
  160. PROTO(PRIVATE ComListElement * new_comlistelement,( unsigned count ));
  161. PROTO(PRIVATE ComListHeader * new_comlistheader,( void ));
  162.  
  163. #ifdef DEBUG_SIZES
  164. PROTO(extern void print_sizeofs,( void ));    /* in symtab.c */
  165. #endif
  166.  
  167.  
  168.  
  169. PRIVATE unsigned
  170. #if HAVE_STDC
  171. arg_count(Token *t)            /* Counts the number of arguments in a token list */
  172. #else /* K&R style */
  173. arg_count(t)            /* Counts the number of arguments in a token list */
  174.     Token *t;
  175. #endif /* HAVE_STDC */
  176. {
  177.     unsigned count;
  178.     count = 0;
  179.     while(t != NULL){
  180.         count++;
  181.         t = t->next_token;
  182.     }
  183.     return(count);
  184. }
  185.  
  186.             /* This routine handles the saving of arg lists which
  187.                is done by call_func and call_subr.  Also called
  188.                by def_namelist to save its variable list. */
  189. PRIVATE void
  190. #if HAVE_STDC
  191. call_external(Lsymtab *symt, Token *id, Token *arg)
  192. #else /* K&R style */
  193. call_external(symt,id,arg)
  194.     Lsymtab *symt;
  195.     Token *id,*arg;
  196. #endif /* HAVE_STDC */
  197. {
  198.            TokenListHeader *TH_ptr;
  199.  
  200.         /* Insert the new list onto linked list of token lists */
  201.           TH_ptr= make_TL_head(id);
  202.  
  203.     TH_ptr->tokenlist = (arg == NULL ? NULL: arg->next_token);
  204.     TH_ptr->next = symt->info.toklist;
  205.     symt->info.toklist = TH_ptr;
  206. #ifdef DEBUG_EXPRTREES
  207.     if(debug_latest) {
  208.       fprintf(list_fd,"\nSubprogram %s :: ",symt->name);
  209.       if(arg != NULL)
  210.         print_expr_list(arg->next_token);
  211.     }
  212. #endif
  213. } /*call_external*/
  214.  
  215. void
  216. #if HAVE_STDC
  217. call_func(Token *id, Token *arg)    /* Process function invocation */
  218. #else /* K&R style */
  219. call_func(id,arg)    /* Process function invocation */
  220.     Token *id, *arg;
  221. #endif /* HAVE_STDC */
  222. {
  223.     int t, h=id->value.integer;
  224.     Lsymtab *symt;
  225.     Gsymtab *gsymt;
  226.     IntrinsInfo *defn;
  227.  
  228.     if( (symt = (hashtab[h].loc_symtab)) == NULL){
  229.        symt = install_local(h,type_UNDECL,class_SUBPROGRAM);
  230.               symt->info.toklist = NULL;
  231.     }
  232.  
  233.     t = datatype_of(symt->type);
  234.         /* Symbol seen before: check it & change class */
  235.  
  236.     if(storage_class_of(symt->type) == class_VAR) {
  237.         symt->type = type_byte(class_SUBPROGRAM,t);
  238.         symt->info.toklist = NULL;
  239.       }
  240.  
  241.  
  242.         /* See if intrinsic.  If so, set flag, save info */
  243.     if(!symt->external && !symt->intrinsic
  244.         && (defn = find_intrinsic(symt->name)) != NULL) {
  245.             /* First encounter with intrinsic fcn: store info */
  246.         symt->intrinsic = TRUE;
  247.         symt->info.intrins_info = defn;
  248.     }
  249.  
  250.         /* Update set/used status of variables in arg list.  This
  251.            is deferred to now to allow intrinsics to be treated
  252.            as pure functions regardless of pure_function flag. */
  253.  
  254.     if(arg != NULL) {
  255.         Token *a=arg;
  256.         int nonpure,    /* flag if function may modify arg */
  257.             i_len;        /* special handling for intrinsic LEN */
  258.         if(symt->intrinsic) {
  259.           nonpure = symt->info.intrins_info->intrins_flags&I_NONPURE;
  260.           i_len = symt->info.intrins_info->intrins_flags&I_LEN;
  261.         }
  262.         else {
  263.           nonpure = ! pure_functions;
  264.           i_len = FALSE;
  265.         }
  266.  
  267.             /* Token list is in reverse order.  Restore
  268.                args to original order. */
  269.         arg->next_token = reverse_tokenlist(arg->next_token);
  270.  
  271.           while( (a=a->next_token) != NULL) {
  272.           if(is_true(ID_EXPR,a->TOK_flags)){
  273.         if( nonpure ) {
  274.                  /* Treat impure function like subroutine call */
  275.           use_actual_arg(a);
  276.           use_variable(a);
  277.         }
  278.         else {
  279.           if(i_len)
  280.             use_len_arg(a); /* LEN is sui generis */
  281.           else
  282.                  /* Pure-function invocation checks u-b-s */
  283.             use_function_arg(a);
  284.         }
  285.           }
  286.         }
  287.     }
  288.  
  289.         /* If intrinsic, do checking now.  Otherwise, save arg list
  290.            to be checked later. */
  291.  
  292.     if(symt->intrinsic) {
  293.             /* It is intrinsic: check it */
  294.     check_intrins_args(id,arg);
  295.     }
  296.     else {        /* It is not intrinsic: install in global table */
  297.       switch(storage_class_of(symt->type)) {
  298.     case class_SUBPROGRAM:
  299.       symt->external = TRUE;
  300.       if((!symt->argument) && (gsymt=(hashtab[h].glob_symtab)) == NULL) {
  301.         gsymt = install_global(h,type_UNDECL,class_SUBPROGRAM);
  302.         gsymt->info.arglist = NULL;
  303.       }
  304.             /* store arg list in local table */
  305.       call_external(symt,id,arg);
  306.       break;
  307.     case class_STMT_FUNCTION:
  308.       symt->external = TRUE;
  309.       check_stmt_function_args(symt,id,arg);
  310.       break;
  311.       }
  312.     }
  313.  
  314.     symt->used_flag = TRUE;
  315.     symt->invoked_as_func = TRUE;
  316.  
  317. } /*call_func*/
  318.  
  319.  
  320. void
  321. #if HAVE_STDC
  322. call_subr(Token *id, Token *arg)    /* Process call statements */
  323. #else /* K&R style */
  324. call_subr(id,arg)    /* Process call statements */
  325.     Token *id, *arg;
  326. #endif /* HAVE_STDC */
  327. {
  328.     int t, h=id->value.integer;
  329.     Lsymtab *symt;
  330.     Gsymtab *gsymt;
  331. #ifndef STANDARD_INTRINSICS
  332.     IntrinsInfo *defn;
  333. #endif
  334.     if( (symt = (hashtab[h].loc_symtab)) == NULL){
  335.        symt = install_local(h,type_SUBROUTINE,class_SUBPROGRAM);
  336.           symt->info.toklist = NULL;
  337.     }
  338.  
  339.  
  340.     t=datatype_of(symt->type);
  341.         /* Symbol seen before: check it & change class */
  342.  
  343.     if( (storage_class_of(symt->type) == class_VAR
  344.          || symt->external ) && t == type_UNDECL) {
  345.         t = type_SUBROUTINE;
  346.         symt->info.toklist = NULL;
  347.     }
  348.     symt->type = type_byte(class_SUBPROGRAM,t);
  349.  
  350.     /* Since nonstandard intrinsics include some subroutines,
  351.        see if it is in intrinsic list.  Or
  352.        if declared intrinsic, then accept it as such and
  353.        do checking now.  Otherwise, save arg list
  354.        to be checked later. */
  355. #ifndef STANDARD_INTRINSICS
  356.     if(!symt->external && !symt->intrinsic
  357.         && (defn = find_intrinsic(symt->name)) != NULL) {
  358.             /* First encounter with intrinsic fcn: store info */
  359.         symt->intrinsic = TRUE;
  360.         symt->info.intrins_info = defn;
  361.     }
  362. #endif
  363.  
  364.             /* Token list is in reverse order.  Restore
  365.                args to original order. */
  366.     if(arg != NULL)
  367.     arg->next_token = reverse_tokenlist(arg->next_token);
  368.  
  369.     if(symt->intrinsic) {
  370.             /* It is intrinsic: check it */
  371.     check_intrins_args(id,arg);
  372.     }
  373.     else {        /* It is not intrinsic: install in global table */
  374.     symt->external = TRUE;
  375.     if((!symt->argument) && (gsymt=(hashtab[h].glob_symtab)) == NULL) {
  376.         gsymt = install_global(h,type_UNDECL,class_SUBPROGRAM);
  377.         gsymt->info.arglist = NULL;
  378.     }
  379.             /* store arg list in local table */
  380.     call_external(symt,id,arg);
  381.     }
  382.  
  383.     symt->used_flag = TRUE;
  384.  
  385. }/*call_subr*/
  386.  
  387.         /* This routine catches syntax errors that have to
  388.            wait till END is seen.  At the moment, only looks if
  389.            CHARACTER*(*) declarations are put on the wrong thing.
  390.            Has to wait since can use it for ENTRY pt.
  391.            Also checks if things SAVED that shouldn't be.
  392.            Also fixes size_is_expression flags if IMPLICIT makes
  393.            the variable so.
  394.          */
  395. void
  396. #if HAVE_STDC
  397. check_loose_ends(int curmodhash)
  398.                         /* current_module_hash from fortran.y */
  399. #else /* K&R style */
  400. check_loose_ends(curmodhash)
  401.      int curmodhash;    /* current_module_hash from fortran.y */
  402. #endif /* HAVE_STDC */
  403. {
  404.   int i;
  405.   for(i=0;i<loc_symtab_top;i++) {
  406.  
  407.                 /* Catch illegal CHARACTER*(*) */
  408.     if( datatype_of(loc_symtab[i].type) == type_STRING &&
  409.     loc_symtab[i].size == size_ADJUSTABLE &&
  410.        !(loc_symtab[i].argument ||
  411.        loc_symtab[i].parameter ||
  412.          loc_symtab[i].entry_point) ) {
  413.       syntax_error(NO_LINE_NUM,NO_COL_NUM,loc_symtab[i].name);
  414.       msg_tail("cannot be adjustable size in module");
  415.       msg_tail(hashtab[curmodhash].name);
  416.     }
  417.  
  418.                 /* Catch unSAVEable SAVE */
  419.     if(loc_symtab[i].saved &&
  420.         (loc_symtab[i].common_var ||
  421.      loc_symtab[i].argument ||
  422.      loc_symtab[i].external ||
  423.      loc_symtab[i].parameter ||
  424.      loc_symtab[i].entry_point) ) {
  425.       syntax_error(NO_LINE_NUM,NO_COL_NUM,loc_symtab[i].name);
  426.       msg_tail("cannot be declared in SAVE statement in module");
  427.       msg_tail(hashtab[curmodhash].name);
  428.     }
  429.  
  430.             /* Common block misspelled in SAVE stmt will
  431.                show up as a SAVEd block with no elements */
  432.     if(loc_symtab[i].saved &&
  433.        datatype_of(loc_symtab[i].type) == type_COMMON_BLOCK &&
  434.        loc_symtab[i].info.comlist == NULL) {
  435.       if(misc_warn) {
  436.     warning(NO_LINE_NUM,NO_COL_NUM,loc_symtab[i].name);
  437.     msg_tail(": no such common block in module");
  438.     msg_tail(hashtab[curmodhash].name);
  439.       }
  440.     }
  441.  
  442.             /* If IMPLICIT CHARACTER*(expr) is used, then
  443.                need to fix flag to reflect it. */
  444.     if(datatype_of(loc_symtab[i].type) == type_UNDECL &&
  445.        get_size_text(&loc_symtab[i],type_UNDECL) != NULL) {
  446.       loc_symtab[i].size_is_expression = TRUE;
  447.     }
  448.   }
  449. }
  450.  
  451.         /* check out consistency of intrinsic argument list */
  452. PRIVATE
  453. void
  454. #if HAVE_STDC
  455. check_intrins_args(Token *id, Token *arg)
  456. #else /* K&R style */
  457. check_intrins_args(id, arg)
  458.     Token *id;
  459.     Token *arg;
  460. #endif /* HAVE_STDC */
  461. {
  462.     int h=id->value.integer;
  463.     Lsymtab *symt=hashtab[h].loc_symtab;
  464.     IntrinsInfo *defn=symt->info.intrins_info;
  465.     unsigned args_given = ((arg == NULL)?0:arg_count(arg->next_token));
  466.     int numargs;
  467.     unsigned short flags;
  468.     Token *t;
  469.  
  470.     numargs = defn->num_args;
  471.     flags = defn->intrins_flags;
  472.  
  473.             /* positive numargs: must agree */
  474.     if( (numargs >= 0 && (args_given != numargs))
  475.             /* 1 or 2 arguments allowed */
  476.      || (numargs == I_1or2 && (args_given != 1 && args_given != 2))
  477.             /* numargs == -2: 2 or more */
  478.      || (numargs == I_2up && (args_given < 2))
  479.             /* 0 or 1 argument allowed */
  480.      || (numargs == I_0or1 && (args_given != 0 && args_given != 1)) ){
  481.         unsigned line_num,col_num;
  482.         if(arg==NULL) {line_num=id->line_num; col_num=id->col_num;}
  483.         else {line_num = arg->line_num; col_num = arg->col_num;}
  484.  
  485.         syntax_error(line_num,col_num,
  486.           "wrong number of arguments for intrinsic function");
  487.         msg_tail(defn->name);
  488.     }
  489. #ifdef DEBUG_EXPRTREES
  490.     if(debug_latest) {
  491.       fprintf(list_fd,"\nIntrinsic %s :: ",defn->name);
  492.       if(arg != NULL)
  493.         print_expr_list(arg->next_token);
  494.     }
  495. #endif
  496.     if(arg != NULL && numargs != 0) {
  497.  
  498.       Token *prev_t,    /* one operand in type propagation  */
  499.              fake_op;    /* operator in binexpr_type call */
  500.  
  501.       t = arg->next_token;
  502.                 /* Copy type & size info into result */
  503.       arg->class = t->class;
  504.       arg->subclass = t->subclass;
  505. #ifndef TOK_type
  506.       arg->TOK_type = t->TOK_type;
  507. #endif
  508. #ifndef TOK_flags
  509.       arg->TOK_flags = t->TOK_flags;
  510. #endif
  511.       arg->size = t->size;
  512.       prev_t = t;
  513.  
  514.       while(t != NULL) {
  515.         if(intrins_arg_cmp(defn,t)) {
  516.                 /* Propagate data type thru the list.
  517.                    Resulting type info is stored in
  518.                    args token.  */
  519.           if(prev_t != t && ! (flags & I_MIXED_ARGS) ) {
  520.                 /* Set up a pretend expr term for binexpr */
  521.         fake_op.class = ',';
  522.         fake_op.line_num = prev_t->line_num;
  523.         fake_op.col_num = prev_t->col_num;
  524.         fake_op.src_text = ",";
  525.  
  526.         binexpr_type(prev_t,&fake_op,t,arg);
  527.           }
  528.           prev_t = t;
  529.         }
  530.         t = t->next_token;
  531.       }/* end while */
  532.  
  533.     }/* end arg != NULL */
  534. }/* check_intrins_args */
  535.  
  536.  
  537. PRIVATE
  538. void
  539. #if HAVE_STDC
  540. check_stmt_function_args(Lsymtab *symt, Token *id, Token *arg)
  541. #else /* K&R style */
  542. check_stmt_function_args(symt,id,arg)
  543.     Lsymtab *symt;
  544.     Token *id,*arg;
  545. #endif /* HAVE_STDC */
  546. {
  547.     unsigned n1,n2,n;
  548.     int i;
  549.     Token *t1,*t2;
  550.  
  551.     t1 = symt->info.toklist->tokenlist;
  552.     t2 = ((arg==NULL)? NULL: arg->next_token);
  553.  
  554.     n1 = arg_count(t1);
  555.     n2 = arg_count(t2);
  556.  
  557.     if(n1 != n2) {
  558.         syntax_error(id->line_num,id->col_num,
  559.         "function invoked with incorrect number of arguments");
  560.     }
  561.  
  562.     n = (n1 < n2? n1: n2);
  563.     for(i=0; i<n; i++) {
  564. #ifdef OLDSTUFF
  565.         if( t1->TOK_type != t2->TOK_type) {
  566.         syntax_error(t2->line_num,t2->col_num,
  567.           "function argument is of incorrect datatype");
  568.         }
  569. #else
  570.         stmt_fun_arg_cmp(symt,t1,t2);
  571. #endif
  572.         t1 = t1->next_token;
  573.         t2 = t2->next_token;
  574.     }
  575. }
  576.  
  577.         /* Routines to copy src text strings from an
  578.            expression tree into a char array.  Given max
  579.            no. of chars (excl. nul) to transfer.  Result is
  580.            always nul-terminated.  Total no. of non-nul chars
  581.            stored is returned. */
  582.  
  583. PRIVATE int
  584. #if HAVE_STDC
  585. cp_tok_src_text(char *s, Token *t, int max)    /* Copies src text from a token */
  586.                          /* The destination string */
  587.                           /* Expression tree */
  588.                          /* Max no. of chars to transfer (excl. nul)*/
  589. #else /* K&R style */
  590. cp_tok_src_text(s,t,max)    /* Copies src text from a token */
  591.      char *s;            /* The destination string */
  592.      Token *t;            /* Expression tree */
  593.      int max;            /* Max no. of chars to transfer (excl. nul)*/
  594. #endif /* HAVE_STDC */
  595. {
  596.   int i,j;
  597.  
  598. #ifndef LEX_RAWSTRINGS
  599.   if( ! is_true(LIT_CONST,t->TOK_flags)
  600.      || t->TOK_type != type_byte(class_VAR,type_STRING))
  601. #endif
  602.   {
  603.     j=0;
  604. #if 0 /* this needs to be done only for actual, not dummy arg */
  605.     if(t->TOK_type == type_byte(class_LABEL,type_LABEL))
  606.       s[j++] = '*';        /* for subroutine arg = *label  */
  607. #endif
  608.     for(i=0; j<max && t->src_text[i] != '\0'; i++) {
  609.       s[j++] = t->src_text[i];
  610.     }
  611.   }
  612.  
  613. #ifndef LEX_RAWSTRINGS
  614.   else {                        /* Strings must be undigested */
  615.     int  quote_char;
  616.     quote_char = t->src_text[0];
  617.     for(i=j=0; j<max && t->src_text[i] != '\0'; i++) {
  618.       s[j++] = t->src_text[i];
  619.       if(i>0 && t->src_text[i] == quote_char) /* Double a quoted quote */
  620.     if(j < max)
  621.       s[j++] = quote_char;
  622.     }
  623.     if(j < max)
  624.       s[j++] = quote_char; /* Add the final quote */
  625.   }
  626. #endif
  627.   s[j] = '\0';            /* Terminate with nul character */
  628.   return j;            /* Return total xferred */
  629. }
  630.  
  631. PRIVATE int
  632. #if HAVE_STDC
  633. cp_tree_src_text(char *s, Token *t, int max)    /* Copies src text from expr tree */
  634.                          /* The destination string */
  635.                           /* Expression tree */
  636.                          /* Max number of chars to transfer (exc. nul)*/
  637. #else /* K&R style */
  638. cp_tree_src_text(s,t,max)    /* Copies src text from expr tree */
  639.      char *s;            /* The destination string */
  640.      Token *t;            /* Expression tree */
  641.      int max;            /* Max number of chars to transfer (exc. nul)*/
  642. #endif /* HAVE_STDC */
  643. {
  644.   int ncopied=0;
  645.   if(t != NULL) {
  646.     if(t->left_token == NULL) {    /* Primary */
  647.       ncopied += cp_tok_src_text(s+ncopied,t,max-ncopied);
  648.     }
  649.     else {            /* Expr tree */
  650.       if(t->next_token != (Token *)NULL) {
  651.  
  652.                 /* binary subtree */
  653.         ncopied += cp_tree_src_text(s+ncopied,t->left_token,max-ncopied);
  654.  
  655.         /* root node */
  656.     ncopied += cp_tok_src_text(s+ncopied,t,max-ncopied);
  657.  
  658.         if(t->class == '(') {     /* Array, substring, or function ref */
  659.       ncopied += cp_list_src_text(s+ncopied,t->next_token,max-ncopied);
  660.       if(max-ncopied > 0) {
  661.         s[ncopied++] = ')'; /* Add left parenthesis */
  662.         s[ncopied] = '\0';
  663.       }
  664.     }
  665.     else {
  666.       ncopied += cp_tree_src_text(s+ncopied,t->next_token,max-ncopied);
  667.     }
  668.       }
  669.       else {
  670.                 /* parent node */
  671.         ncopied = cp_tok_src_text(s+ncopied,t,max-ncopied);
  672.  
  673.                 /* unary subtree */
  674.         ncopied += cp_tree_src_text(s+ncopied,t->left_token,max-ncopied);
  675.  
  676.         if(t->class == '(') {     /* Parenthesized subexpression */
  677.       if(max-ncopied > 0) {
  678.         s[ncopied++] = ')'; /* Add left parenthesis */
  679.         s[ncopied] = '\0';
  680.       }
  681.     }
  682.       }
  683.     }
  684.   }
  685.   return ncopied;
  686. }
  687.  
  688. PRIVATE int
  689. #if HAVE_STDC
  690. cp_list_src_text(char *s, Token *t, int max)    /* Copies text from a tokenlist */
  691.                          /* The destination string */
  692.                           /* Expression tree */
  693.                          /* Max number of chars to transfer (exc. nul)*/
  694. #else /* K&R style */
  695. cp_list_src_text(s,t,max)    /* Copies text from a tokenlist */
  696.      char *s;            /* The destination string */
  697.      Token *t;            /* Expression tree */
  698.      int max;            /* Max number of chars to transfer (exc. nul)*/
  699. #endif /* HAVE_STDC */
  700. {
  701.   int ncopied=0;
  702.   while( t != NULL) {
  703.     if(t->left_token == NULL) {    /* Primary */
  704.       ncopied += cp_tok_src_text(s+ncopied,t,max-ncopied);
  705.     }
  706.     else {
  707.                 /* Print tree at this point in list */
  708.       ncopied += cp_tree_src_text(s+ncopied,t->left_token,max-ncopied);
  709.     }
  710.     t = t->next_token;
  711.     if(t != NULL) {        /* If next one coming, print the comma */
  712.       if(max-ncopied > 0) {    /* Parenthesized subexpression */
  713.     s[ncopied++] = ',';
  714.     s[ncopied] = '\0';
  715.       }
  716.     }
  717.   }
  718.   return ncopied;
  719. }
  720.  
  721.  
  722. void
  723. #if HAVE_STDC
  724. declare_type(Token *id, int datatype, long int size, char *size_text)
  725. #else /* K&R style */
  726. declare_type(id,datatype,size,size_text)
  727.     Token *id;
  728.     int datatype;
  729.     long size;
  730.     char *size_text;
  731. #endif /* HAVE_STDC */
  732. {
  733.     int h=id->value.integer;
  734.     Lsymtab *symt=hashtab[h].loc_symtab;
  735.  
  736.     if( (symt) == NULL) {
  737.        symt = install_local(h,datatype,class_VAR);
  738.        symt->size = size;
  739.        symt->size_is_adjustable = id->size_is_adjustable;
  740.        symt->size_is_expression = id->size_is_expression;
  741.     }
  742.     else {           /* Symbol has been seen before: check it */
  743.  
  744.             /* Intrinsic: see if type is consistent */
  745.       if( symt->intrinsic ) {
  746.         IntrinsInfo *defn = symt->info.intrins_info;
  747.         int rettype = defn->result_type,
  748.         argtype = defn->arg_type;
  749.             /* N.B. this test catches many but not all errors */
  750.         if( (rettype != type_GENERIC && datatype != rettype)
  751.          || (rettype == type_GENERIC && !((1<<datatype) & argtype)) ){
  752.           if(misc_warn) {
  753.             warning(id->line_num,id->col_num,
  754.                 "Declared type ");
  755.             msg_tail(type_name[datatype]);
  756.             msg_tail(" is invalid for intrinsic function: ");
  757.             msg_tail(symt->name);
  758.           }
  759.         }
  760.       }
  761.  
  762.       if(datatype_of(symt->type) != type_UNDECL) {
  763.           syntax_error(id->line_num,id->col_num,
  764.         "Symbol redeclared: ");
  765.           msg_tail(symt->name);
  766.       }
  767.       else {
  768.             /* Now give it the declared type */
  769.           symt->type = type_byte(storage_class_of(symt->type),datatype);
  770.           symt->size = size;
  771.           symt->size_is_adjustable = id->size_is_adjustable;
  772.           symt->size_is_expression = id->size_is_expression;
  773.       }
  774.  
  775.             /* Issue error if already defined as a parameter */
  776.       if( symt->parameter ) {
  777.         syntax_error(id->line_num,id->col_num,
  778.              "type declaration must precede PARAMETER definition");
  779.       }
  780.     }
  781.  
  782.         /* If character type, save the source text of the size
  783.            specification.  If it is an array already
  784.            dimensioned, add size_text to tail of src.textvec,
  785.            otherwise place size_text in src.text if it is
  786.            character type, except for parameter, which
  787.            shouldn't happen.
  788.          */
  789.  
  790.     if( datatype_of(symt->type) == type_STRING ) {
  791.       if(symt->array_var) {
  792.         int i, dims = array_dims(symt->info.array_dim);
  793.         char **tvec = new_textvec(dims+1);
  794.  
  795.         for(i=0; i<dims; i++)    /* Copy the old list over */
  796.           tvec[i] = symt->src.textvec[i];
  797.  
  798.         tvec[dims] = size_text; /* Copy size text to new last element */
  799.  
  800.         free_textvec(symt->src.textvec); /* Free the old list */
  801.  
  802.         symt->src.textvec = tvec; /* Replace old list with new */
  803.       }
  804.       else if( ! symt->parameter ) {
  805.         symt->src.text = size_text;
  806.       }
  807.     }
  808.  
  809. #ifdef DEBUG_EXPRTREES
  810.           if(debug_latest) {
  811.         fprintf(list_fd,"\n      %s",type_table[datatype]);
  812.         size_text = get_size_text(symt,0);
  813.         if(size_text != NULL) {
  814.           fprintf(list_fd," * %s",size_text);
  815.         }
  816.         else {
  817.           if(symt->size != size_DEFAULT)
  818.           fprintf(list_fd," * %d",symt->size);
  819.         }
  820.         fprintf(list_fd," %s",symt->name);
  821.           }
  822. #endif
  823.  
  824.             /* Under -port=long-string warn if char size > 255 */
  825.     if(port_long_string) {
  826.       if(datatype == type_STRING && size > 255)
  827.         nonportable(id->line_num,id->col_num,
  828.             "character variable length exceeds 255");
  829.     }
  830. }/*declare_type*/
  831.  
  832.  
  833. void
  834. #if HAVE_STDC
  835. def_arg_name(Token *id)        /* Process items in argument list */
  836. #else /* K&R style */
  837. def_arg_name(id)        /* Process items in argument list */
  838. #endif /* HAVE_STDC */
  839.  
  840. #if HAVE_STDC
  841. #else /* K&R style */
  842.     Token *id;
  843. #endif /* HAVE_STDC */
  844. {
  845.     int h=id->value.integer;
  846.     Lsymtab *symt;
  847.  
  848.     if( (symt=hashtab[h].loc_symtab) == NULL) {
  849.        symt = install_local(h,type_UNDECL,class_VAR);
  850.     }
  851.     else {           /* Symbol has been seen before: check it */
  852.  
  853.     }
  854.     symt->argument = TRUE;
  855. }/*def_arg_name*/
  856.  
  857.  
  858. void
  859. #if HAVE_STDC
  860. def_array_dim(Token *id, Token *arg)    /* Process dimension lists */
  861.                             /* arg previously defined as int */
  862. #else /* K&R style */
  863. def_array_dim(id,arg)    /* Process dimension lists */
  864.     Token *id,*arg;         /* arg previously defined as int */
  865. #endif /* HAVE_STDC */
  866. {
  867.     int h=id->value.integer;
  868.     Lsymtab *symt;
  869.  
  870.  
  871.     if( (symt=hashtab[h].loc_symtab) == NULL) {
  872.        symt = install_local(h,type_UNDECL,class_VAR);
  873.     }
  874.     else {           /* Symbol has been seen before: check it */
  875.        if(storage_class_of(symt->type) != class_VAR) {
  876.           syntax_error(id->line_num,id->col_num,
  877.         "Entity cannot be dimensioned: ");
  878.         msg_tail(symt->name);
  879.           return;
  880.        }
  881.     }
  882.  
  883.     symt->array_var = TRUE;
  884.     if(!equivalence_flag){      /* some checking should be done here */
  885.        if(symt->info.array_dim != 0)
  886.           syntax_error(id->line_num,id->col_num,
  887.         "Array redimensioned");
  888.        else
  889.           symt->info.array_dim = array_dim_info(arg->TOK_dims,
  890.                             arg->TOK_elts);
  891.  
  892.     }
  893.  
  894.         /* Save text of dimension exprs in a list of strings
  895.            in symtab entry.  If array is of type character,
  896.            the text of size expression is already in src.text,
  897.            and is saved at tail of the list of dim strings. */
  898.  
  899.     {
  900.       int i, dims=arg->TOK_dims,
  901.           is_char = (datatype_of(symt->type) == type_STRING);
  902.       char **tvec;
  903.       char *size_text=symt->src.text;
  904.       Token *t;
  905.                 /* Restore dim list to correct order */
  906.       arg->next_token = reverse_tokenlist(arg->next_token);
  907.  
  908.       symt->src.textvec = tvec = new_textvec(is_char?dims+1:dims);
  909.  
  910.                 /* Store dimension expr text in list */
  911.       for(i=0, t=arg->next_token; i<dims; i++, t=t->next_token) {
  912.         tvec[i] = ( t->left_token == NULL ?
  913.                new_tree_text(t):
  914.                new_tree_text(t->left_token) );
  915.       }
  916.                 /* If character type, store size expr
  917.                    text in tail of list. */
  918.       if(is_char)
  919.         tvec[dims] = size_text;
  920.  
  921. #ifdef DEBUG_EXPRTREES
  922.       if(debug_latest) {
  923.         int type=datatype_of(symt->type);
  924.         fprintf(list_fd,"\n      %s",
  925.             (type == type_UNDECL)?"DIMENSION":type_table[type]);
  926.         if(is_char)
  927.           fprintf(list_fd," * %s",symt->src.textvec[dims]);
  928.  
  929.         fprintf(list_fd," %s ( ",symt->name);
  930.         for(i=0; i<dims; i++) {
  931.           fprintf(list_fd,"%s",symt->src.textvec[i]);
  932.           if(i < dims-1)
  933.         fprintf(list_fd," , ");
  934.         }
  935.         fprintf(list_fd," )");
  936.       }
  937. #endif
  938.  
  939.     }
  940.  
  941. }/*def_array_dim*/
  942.  
  943.  
  944. void
  945. #if HAVE_STDC
  946. def_com_block(Token *id, Token *comlist)    /* Process common blocks and save_stmt */
  947. #else /* K&R style */
  948. def_com_block(id,comlist)    /* Process common blocks and save_stmt */
  949.     Token *id, *comlist;
  950. #endif /* HAVE_STDC */
  951.  
  952. {
  953.     int h=id->value.integer;
  954.     Lsymtab *symt;
  955.     Gsymtab *gsymt;
  956.        TokenListHeader *TH_ptr;
  957.     extern unsigned true_prev_stmt_line_num;/* set by fortran.y */
  958.  
  959.         /* Install name in global symbol table */
  960.     if( (gsymt=hashtab[h].com_glob_symtab) == NULL) {
  961.        gsymt = install_global(h,type_COMMON_BLOCK,class_COMMON_BLOCK);
  962.        gsymt->info.comlist = NULL;
  963.     }
  964.  
  965.  
  966.     if( (symt = hashtab[h].com_loc_symtab) == NULL){
  967.        symt = install_local(h,type_COMMON_BLOCK,class_COMMON_BLOCK);
  968.        symt->info.toklist = NULL;
  969.     }
  970.     if(pretty_multiple_common) {
  971.  
  972.         /* Flag declarations of same block in separate statements
  973.            unless separated only by comments. Use front token
  974.            of previous tokenlist which is last token of decl. */
  975.       if(comlist != NULL && symt->info.toklist != NULL
  976.        && symt->info.toklist->tokenlist->line_num < true_prev_stmt_line_num) {
  977.         ugly_code(id->line_num,id->col_num,
  978.         "Common block declared in more than one statement");
  979.       }
  980.     }
  981.  
  982.         /* Insert the new list onto linked list of token lists */
  983.     if(comlist != NULL) {
  984.           /* Will be NULL only for SAVE, in which case skip */
  985.         TH_ptr= make_TL_head(id);
  986.  
  987.          TH_ptr->tokenlist = comlist->next_token;
  988.         TH_ptr->next = symt->info.toklist;
  989.             symt->info.toklist = TH_ptr;
  990.     }
  991.  
  992.        symt->set_flag = TRUE;
  993.     symt->used_flag = TRUE;
  994. }/*def_com_block*/
  995.  
  996.  
  997. void
  998. #if HAVE_STDC
  999. def_com_variable(Token *id)        /* Process items in common block list */
  1000. #else /* K&R style */
  1001. def_com_variable(id)        /* Process items in common block list */
  1002.     Token *id;
  1003. #endif /* HAVE_STDC */
  1004. {
  1005.     int h=id->value.integer;
  1006.     Lsymtab *symt;
  1007.  
  1008.     if( (symt=hashtab[h].loc_symtab) == NULL) {
  1009.        symt = install_local(h,type_UNDECL,class_VAR);
  1010.     }
  1011.     else {           /* Symbol has been seen before: check it */
  1012.         if(symt->common_var) {
  1013.         syntax_error(id->line_num,id->col_num,
  1014.              "Variable cannot be in two different common blocks");
  1015.         }
  1016.         else if(symt->entry_point || symt->parameter ||
  1017.             symt->argument || symt->external || symt->intrinsic) {
  1018.         syntax_error(id->line_num,id->col_num,
  1019.              "Item cannot be placed in common");
  1020.         return;
  1021.         }
  1022.         if(symt->size == size_ADJUSTABLE) {    /* CHARACTER *(*) */
  1023.           syntax_error(id->line_num,id->col_num,
  1024.             "Common variable cannot have adjustable size");
  1025.           symt->size = 1;
  1026.         }
  1027.     }
  1028.     {        /* set flags for all equivalenced vars */
  1029.       Lsymtab *equiv=symt;
  1030.       do{
  1031.     equiv->common_var = TRUE; /* set the flag even if not legit */
  1032.     equiv = equiv->equiv_link;
  1033.       } while(equiv != symt);
  1034.     }
  1035.  
  1036. }/*def_com_variable*/
  1037.  
  1038.  
  1039.     /* This guy sets the flag in symbol table saying the id is the
  1040.        current module.  It returns the hash code for later reference.
  1041.      */
  1042. int
  1043. #if HAVE_STDC
  1044. def_curr_module(Token *id)
  1045. #else /* K&R style */
  1046. def_curr_module(id)
  1047.     Token *id;
  1048. #endif /* HAVE_STDC */
  1049. {
  1050.     int hashno = id->value.integer;
  1051.     hashtab[hashno].loc_symtab->is_current_module = TRUE;
  1052.  
  1053.     return hashno;
  1054. }/*def_curr_module*/
  1055.  
  1056.  
  1057.  
  1058.  
  1059. void
  1060. #if HAVE_STDC
  1061. def_equiv_name(Token *id)        /* Process equivalence list elements */
  1062. #else /* K&R style */
  1063. def_equiv_name(id)        /* Process equivalence list elements */
  1064.     Token *id;
  1065. #endif /* HAVE_STDC */
  1066. {
  1067.   ref_variable(id);        /* Put it in symtab */
  1068.     /* No other action needed: processing of equiv pairs is
  1069.        done by equivalence() */
  1070. }/*def_equiv_name*/
  1071.  
  1072.  
  1073.  
  1074. void
  1075. #if HAVE_STDC
  1076. def_ext_name(Token *id)        /* Process external lists */
  1077. #else /* K&R style */
  1078. def_ext_name(id)        /* Process external lists */
  1079.     Token *id;
  1080. #endif /* HAVE_STDC */
  1081. {
  1082.     int h=id->value.integer;
  1083.     Lsymtab *symt;
  1084.  
  1085.     if( (symt = hashtab[h].loc_symtab) == NULL){
  1086.        symt = install_local(h,type_UNDECL,class_SUBPROGRAM);
  1087.        symt->info.toklist = NULL;
  1088.         }
  1089.     else {
  1090.             /* Symbol seen before: check it & change class */
  1091.  
  1092.         if(storage_class_of(symt->type) == class_VAR) {
  1093.           symt->info.toklist = NULL;
  1094.         }
  1095.         symt->type = type_byte(class_SUBPROGRAM,datatype_of(symt->type));
  1096.     }
  1097.  
  1098.     if(symt->intrinsic){
  1099.         syntax_error(id->line_num,id->col_num,
  1100.         "Cannot declare same subprogram both intrinsic and external:");
  1101.         msg_tail(symt->name);
  1102.     }
  1103.     else{
  1104.         symt->external = TRUE;
  1105.         if(!symt->argument){
  1106.             TokenListHeader *TH_ptr;
  1107.         Gsymtab *gsymt;
  1108.         if( (gsymt=hashtab[h].glob_symtab) == NULL) {
  1109.                gsymt = install_global(h,type_UNDECL,class_SUBPROGRAM);
  1110.                gsymt->info.arglist = NULL;
  1111.         }
  1112.         TH_ptr=make_TL_head(id);
  1113.  
  1114.         TH_ptr->external_decl = TRUE;
  1115.         TH_ptr->next = symt->info.toklist;
  1116.         symt->info.toklist = TH_ptr;
  1117.          }
  1118.       }
  1119.       symt->declared_external = TRUE;
  1120. }/*def_ext_name*/
  1121.  
  1122.  
  1123.  
  1124. void
  1125. #if HAVE_STDC
  1126. def_function(int datatype, long int size, char *size_text, Token *id, Token *args)
  1127. #else /* K&R style */
  1128. def_function(datatype,size,size_text,id,args)
  1129. #endif /* HAVE_STDC */
  1130.                 /* Installs function or subroutine name */
  1131. #if HAVE_STDC
  1132.                                       /* in global table */
  1133. #else /* K&R style */
  1134.     int datatype;                     /* in global table */
  1135.     long size;
  1136.     char *size_text;
  1137.     Token *id,*args;
  1138. #endif /* HAVE_STDC */
  1139. {
  1140.     int storage_class;
  1141.     int h=id->value.integer;
  1142.     Lsymtab *symt;
  1143.     Gsymtab *gsymt;
  1144.     TokenListHeader *TH_ptr;
  1145.        storage_class = class_SUBPROGRAM;
  1146.  
  1147.     if((gsymt = (hashtab[h].glob_symtab)) == NULL) {
  1148.             /* Symbol is new to global symtab: install it */
  1149.       gsymt = install_global(h,datatype,storage_class);
  1150.       gsymt->size = size;
  1151.       gsymt->info.arglist = NULL;
  1152.     }
  1153.     else {
  1154.             /* Symbol is already in global symtab. Put the
  1155.                declared datatype into symbol table. */
  1156.       gsymt->type = type_byte(storage_class,datatype);
  1157.       gsymt->size = size;
  1158.     }
  1159.  
  1160.        if((symt = (hashtab[id->value.integer].loc_symtab)) == NULL) {
  1161.             /* Symbol is new to local symtab: install it.
  1162.                Since this is the current routine, it has
  1163.                storage class of a variable. */
  1164.        symt = install_local(h,datatype,class_VAR);
  1165.        symt->size = size;
  1166.        symt->src.text = size_text;
  1167.     }
  1168.     if(! symt->entry_point)    /* seen before but not as entry */
  1169.        symt->info.toklist = NULL;
  1170.  
  1171.                 /* Restore args list to original order */
  1172.     if(args != NULL)
  1173.       args->next_token = reverse_tokenlist(args->next_token);
  1174.  
  1175.         /* Insert the new list onto linked list of token lists */
  1176.        TH_ptr=make_TL_head(id);
  1177.  
  1178.             /* If this is an implied PROGRAM statement it may
  1179.                occur in an include file, which we do not want
  1180.                to appear in diagnostic messages about it. */
  1181.     if(top_filename != current_filename && datatype == type_PROGRAM) {
  1182.       TH_ptr->filename = top_filename;
  1183.       TH_ptr->line_num = top_file_line_num;
  1184.     }
  1185.  
  1186.     TH_ptr->tokenlist = (args == NULL ? NULL: args->next_token);
  1187.     TH_ptr->next = symt->info.toklist;
  1188.     symt->info.toklist = TH_ptr;
  1189.  
  1190.     symt->entry_point = TRUE;
  1191.  
  1192.         /* library mode: set the flag so no complaint will
  1193.            be issued if function never invoked.  Also, set
  1194.            used_flag if this is a main program, for same reason. */
  1195.     if(library_mode)
  1196.         symt->library_module = TRUE;
  1197.     if(datatype == type_PROGRAM) {
  1198.         symt->used_flag = TRUE;
  1199. #ifdef VCG_SUPPORT        /* Get name of file containing main module */
  1200.         main_filename = top_filename;
  1201. #endif
  1202.     }
  1203.  
  1204. }/*def_function*/
  1205.  
  1206.  
  1207.  
  1208. void
  1209. #if HAVE_STDC
  1210. def_intrins_name(Token *id)        /* Process intrinsic lists */
  1211. #else /* K&R style */
  1212. def_intrins_name(id)        /* Process intrinsic lists */
  1213.     Token *id;
  1214. #endif /* HAVE_STDC */
  1215. {
  1216.     int h=id->value.integer;
  1217.     Lsymtab *symt;
  1218.  
  1219.     if( (symt = hashtab[h].loc_symtab) == NULL){
  1220.        symt = install_local(h,type_UNDECL,class_SUBPROGRAM);
  1221.        symt->info.toklist = NULL;
  1222.         }
  1223.     else {
  1224.             /* Symbol seen before: check it & change class */
  1225.       if(storage_class_of(symt->type) == class_VAR) {
  1226.         symt->info.toklist = NULL;
  1227.       }
  1228.  
  1229.       symt->type = type_byte(class_SUBPROGRAM,datatype_of(symt->type));
  1230.     }
  1231.  
  1232.         /* Place info about intrinsic datatype in local symtab.
  1233.            If not found, it will be treated as external.
  1234.          */
  1235.  
  1236.     if(symt->external){
  1237.         syntax_error(id->line_num,id->col_num,
  1238.            "Cannot declare same subprogram both intrinsic and external:");
  1239.         msg_tail(symt->name);
  1240.     }
  1241.     else{
  1242.       IntrinsInfo *defn;
  1243.       symt->declared_intrinsic = TRUE;
  1244.       if( (defn=find_intrinsic(symt->name)) == NULL ) {
  1245.          if(misc_warn) {
  1246.            warning(id->line_num,id->col_num,
  1247.             "Unknown intrinsic function: ");
  1248.            msg_tail(symt->name);
  1249.            msg_tail("Treated as if user-defined");
  1250.          }
  1251.                 /* Here treat as if EXTERNAL declaration */
  1252.          def_ext_name(id);
  1253.          return;
  1254.        }
  1255.        else {
  1256.             /* Found in info table: set intrins flag and store
  1257.                pointer to definition info. */
  1258.          symt->intrinsic = TRUE;
  1259.          symt->info.intrins_info = defn;
  1260.        }
  1261.     }
  1262.     symt->declared_external = TRUE;
  1263. }/*def_intrins_name*/
  1264.  
  1265. void
  1266. #if HAVE_STDC
  1267. def_namelist(Token *id, Token *list)        /* Process NAMELIST declaration */
  1268. #else /* K&R style */
  1269. def_namelist(id,list)        /* Process NAMELIST declaration */
  1270.      Token *id,*list;
  1271. #endif /* HAVE_STDC */
  1272. {
  1273.     int h=id->value.integer;
  1274.     Lsymtab *symt;
  1275.     extern unsigned true_prev_stmt_line_num;/* set by fortran.y */
  1276.  
  1277.     if( (symt=hashtab[h].loc_symtab) == NULL) {
  1278.                 /* First encounter: install in local symtab */
  1279.       symt = install_local(h,type_NAMELIST,class_NAMELIST);
  1280.       symt->info.toklist = NULL;
  1281.     }
  1282.     else if(pretty_multiple_namelist) {
  1283.  
  1284.         /* Flag declarations of same namelist in separate statements
  1285.            unless separated only by comments. Use front token
  1286.            of previous tokenlist which is last token of decl. */
  1287.       if((symt->info.toklist != NULL) && 
  1288.         (symt->info.toklist->tokenlist->line_num < true_prev_stmt_line_num)) {
  1289.         ugly_code(id->line_num,id->col_num,
  1290.         "Namelist declared in more than one statement");
  1291.       }
  1292.     }
  1293.  
  1294.     call_external(symt,id,list); /* attach list to symt->info.toklist */
  1295.  
  1296. }/*def_namelist*/
  1297.  
  1298.  
  1299. void
  1300. #if HAVE_STDC
  1301. def_namelist_item(Token *id)        /* Process NAMELIST list elements */
  1302. #else /* K&R style */
  1303. def_namelist_item(id)        /* Process NAMELIST list elements */
  1304.     Token *id;
  1305. #endif /* HAVE_STDC */
  1306. {
  1307.   ref_variable(id);        /* Put it in symtab */
  1308. }/*def_namelist_name*/
  1309.  
  1310.  
  1311. #ifdef CHECK_LABELS
  1312. void                /* stub for future statement-label handler */
  1313. def_label(lab)                /* ARGSUSED0 */
  1314.      Token *lab;
  1315. {
  1316. }
  1317. #endif
  1318.  
  1319. void
  1320. #if HAVE_STDC
  1321. def_parameter(Token *id, Token *val)    /* Process parameter_defn_item */
  1322. #else /* K&R style */
  1323. def_parameter(id,val)    /* Process parameter_defn_item */
  1324.     Token *id,*val;
  1325. #endif /* HAVE_STDC */
  1326. {
  1327.     int h=id->value.integer;
  1328.     Lsymtab *symt;
  1329.  
  1330.     if( (symt=hashtab[h].loc_symtab) == NULL) {
  1331.        symt = install_local(h,type_UNDECL,class_VAR);
  1332.     }
  1333.  
  1334.     symt->set_flag = TRUE;
  1335.     symt->parameter = TRUE;
  1336.     symt->info.param = new_param_info();
  1337.     symt->info.param->seq_num = ++parameter_count;
  1338.  
  1339.         /* Integer parameters: save value in symtab entry.  Other
  1340.            types not saved.  Need these since used in array dims */
  1341.     switch(get_type(symt)) {
  1342.         case type_INTEGER:
  1343.             symt->info.param->value.integer = int_expr_value(val);
  1344. #ifdef DEBUG_PARAMETERS
  1345. if(debug_latest)
  1346. (void)fprintf(list_fd,"\nPARAMETER %s = %d",
  1347.           symt->name,symt->info.param->value.integer);
  1348. #endif
  1349.             break;
  1350.             /* Character parameter: if declared adjustable
  1351.                i.e. *(*) then inherit size of const */
  1352.         case type_STRING:
  1353.             if(symt->size == size_ADJUSTABLE
  1354.                && datatype_of(val->TOK_type) == type_STRING)
  1355.               symt->size = val->size;
  1356.             symt->info.param->value.string = char_expr_value(val);
  1357.             break;
  1358.         case type_REAL:
  1359.         case type_DP:
  1360.         case type_COMPLEX:
  1361.             symt->info.param->value.dbl = float_expr_value(val);
  1362.         default:
  1363.             break;
  1364.     }
  1365.  
  1366.             /* Save the source text of value for declaration */
  1367.  
  1368.     symt->info.param->src_text = new_tree_text(
  1369.         (val->left_token == NULL?
  1370.             val:            /* Primary */
  1371.             val->left_token)    /* Expr tree */
  1372.             );
  1373.  
  1374. #ifdef DEBUG_EXPRTREES
  1375.     if(debug_latest) {
  1376.       fprintf(list_fd,"\n      PARAMETER ( %s = %s ) ",
  1377.           symt->name,
  1378.           symt->info.param->src_text);
  1379.     }
  1380. #endif
  1381.  
  1382. }/*def_parameter*/
  1383.  
  1384.  
  1385.  
  1386. void               /* Installs statement function name in local table */
  1387. #if HAVE_STDC
  1388. def_stmt_function(Token *id, Token *args)
  1389. #else /* K&R style */
  1390. def_stmt_function(id, args)
  1391.     Token *id, *args;
  1392. #endif /* HAVE_STDC */
  1393. {
  1394.     int t,h=id->value.integer;
  1395.     Lsymtab *symt;
  1396.        TokenListHeader *TH_ptr;
  1397.  
  1398.        if((symt = (hashtab[h].loc_symtab)) == NULL) {
  1399.             /* Symbol is new to local symtab: install it. */
  1400.  
  1401.        symt = install_local(h,type_UNDECL,class_STMT_FUNCTION);
  1402.        symt->info.toklist = NULL;
  1403.     }
  1404.     else {
  1405.       if(storage_class_of(symt->type) == class_VAR) {
  1406.         symt->info.toklist = NULL;
  1407.       }
  1408.     }
  1409.  
  1410.         /* Restore args to original order for sake of checking phase */
  1411.     if(args != NULL)
  1412.       args->next_token = reverse_tokenlist(args->next_token);
  1413.  
  1414.         /* Save dummy arg list in symbol table */
  1415.         TH_ptr= make_TL_head(id);
  1416.  
  1417.     TH_ptr->tokenlist = (args == NULL ? NULL: args->next_token);
  1418.     TH_ptr->next = symt->info.toklist;
  1419.     symt->info.toklist = TH_ptr;
  1420.  
  1421.     t=datatype_of(symt->type);
  1422.         /* Symbol seen before: check it & change class */
  1423.  
  1424.         /* check, check, check ... */
  1425.     if(storage_class_of(symt->type) == class_VAR)
  1426.        symt->type = type_byte(class_STMT_FUNCTION,t);
  1427.  
  1428.     symt->external = TRUE;
  1429. }/*def_stmt_function*/
  1430.  
  1431.  
  1432.  
  1433.  
  1434. void
  1435. #if HAVE_STDC
  1436. do_ASSIGN(Token *id)        /* Process ASSIGN statement */
  1437. #else /* K&R style */
  1438. do_ASSIGN(id)        /* Process ASSIGN statement */
  1439.     Token *id;
  1440. #endif /* HAVE_STDC */
  1441. {
  1442.     int h=id->value.integer;
  1443.     Lsymtab *symt;
  1444.  
  1445.     if( (symt=hashtab[h].loc_symtab) == NULL) {
  1446.        symt = install_local(h,type_UNDECL,class_VAR);
  1447.     }
  1448.     else {
  1449.        if(get_type(symt) != type_INTEGER) {
  1450.           syntax_error(id->line_num,id->col_num,
  1451.         "Variable must be an integer: ");
  1452.           msg_tail(symt->name);
  1453.        }
  1454.     }
  1455.     {        /* set flags for all equivalenced vars */
  1456.       Lsymtab *equiv=symt;
  1457.       do{
  1458.     equiv->set_flag = TRUE;
  1459.     equiv = equiv->equiv_link;
  1460.       } while(equiv != symt);
  1461.     }
  1462. }/*do_ASSIGN*/
  1463.  
  1464.  
  1465.  
  1466.  
  1467. void
  1468. #if HAVE_STDC
  1469. do_assigned_GOTO(Token *id)        /* Process assigned_goto */
  1470. #else /* K&R style */
  1471. do_assigned_GOTO(id)        /* Process assigned_goto */
  1472.     Token *id;
  1473. #endif /* HAVE_STDC */
  1474. {
  1475.     int h=id->value.integer;
  1476.     Lsymtab *symt;
  1477.  
  1478.     if( (symt=hashtab[h].loc_symtab) == NULL) {
  1479.        symt = install_local(h,type_UNDECL,class_VAR);
  1480.     }
  1481.     else {
  1482.        if(get_type(symt) != type_INTEGER) {
  1483.           syntax_error(id->line_num,id->col_num,
  1484.         "Variable must be an integer: ");
  1485.           msg_tail(symt->name);
  1486.        }
  1487.     }
  1488.     {        /* set flags for all equivalenced vars */
  1489.       Lsymtab *equiv=symt;
  1490.       do{
  1491.     if(! equiv->set_flag)
  1492.        equiv->used_before_set = TRUE;
  1493.     equiv->used_flag = TRUE;
  1494.     equiv = equiv->equiv_link;
  1495.       } while(equiv != symt);
  1496.     }
  1497.  
  1498. }/*do_assigned_GOTO*/
  1499.  
  1500.  
  1501.  
  1502.  
  1503.  
  1504. void
  1505. #if HAVE_STDC
  1506. do_ENTRY(Token *id, Token *args, int hashno)    /* Processes ENTRY statement */
  1507. #else /* K&R style */
  1508. do_ENTRY(id,args,hashno)    /* Processes ENTRY statement */
  1509.     Token *id,*args;
  1510.     int hashno;
  1511. #endif /* HAVE_STDC */
  1512. {
  1513.     int datatype;
  1514.     if(hashno == -1) {    /* -1 signifies headerless program */
  1515.         datatype = type_PROGRAM;
  1516.     }
  1517.     else {
  1518.         datatype = datatype_of(hashtab[hashno].loc_symtab->type);
  1519.     }
  1520.     switch(datatype) {
  1521.         case type_PROGRAM:
  1522.         case type_BLOCK_DATA:
  1523.         case type_COMMON_BLOCK:
  1524.             syntax_error(id->line_num,NO_COL_NUM,
  1525.             "You cannot have an entry statement here");
  1526.         break;
  1527.         case type_SUBROUTINE:    /* Subroutine entry */
  1528.         def_function(type_SUBROUTINE,size_DEFAULT,(char *)NULL,
  1529.                  id,args);
  1530.         break;
  1531.         default:        /* Function entry */
  1532.         def_function(type_UNDECL,size_DEFAULT,(char *)NULL,
  1533.                  id,args);
  1534.         break;
  1535.     }
  1536. }/*do_ENTRY*/
  1537.  
  1538.  
  1539.  
  1540.  
  1541.     /* This routine checks whether a RETURN statement is valid at
  1542.        the present location, and if it is, looks for possible
  1543.        failure to assign return value of function.
  1544.     */
  1545. void
  1546. #if HAVE_STDC
  1547. do_RETURN(int hashno, Token *keyword)
  1548.                    /* current module hash number */
  1549.                        /* tok_RETURN, or tok_END if implied RETURN */
  1550. #else /* K&R style */
  1551. do_RETURN(hashno,keyword)
  1552.     int hashno;    /* current module hash number */
  1553.     Token *keyword;    /* tok_RETURN, or tok_END if implied RETURN */
  1554. #endif /* HAVE_STDC */
  1555. {
  1556.     int i,datatype;
  1557.     if(hashno == -1) {    /* -1 signifies headerless program */
  1558.         datatype = type_PROGRAM;
  1559.     }
  1560.     else {
  1561.         datatype = datatype_of(hashtab[hashno].loc_symtab->type);
  1562.     }
  1563.     switch(datatype) {
  1564.         case type_PROGRAM:
  1565.         case type_BLOCK_DATA:
  1566.         if(keyword->class == tok_RETURN)
  1567.             syntax_error(keyword->line_num,keyword->col_num,
  1568.                 "You cannot have a RETURN statement here!");
  1569.         break;
  1570.         case type_SUBROUTINE:    /* Subroutine return: OK */
  1571.         break;
  1572.         default:        /* Function return: check whether entry
  1573.                    points have been assigned values. */
  1574.         for(i=0; i<loc_symtab_top; i++) {
  1575.             if(storage_class_of(loc_symtab[i].type) == class_VAR
  1576.             && loc_symtab[i].entry_point
  1577.             && ! loc_symtab[i].set_flag ) {
  1578.               if(misc_warn) {
  1579.                 warning(keyword->line_num,keyword->col_num,
  1580.                     loc_symtab[i].name);
  1581.                 msg_tail("not set when RETURN encountered");
  1582.               }
  1583.             }
  1584.         }
  1585.         break;
  1586.     }
  1587.  
  1588. }/*do_RETURN*/
  1589.  
  1590. void
  1591. #if HAVE_STDC
  1592. equivalence(Token *id1, Token *id2)
  1593. #else /* K&R style */
  1594. equivalence(id1,id2)
  1595.      Token *id1, *id2;
  1596. #endif /* HAVE_STDC */
  1597. {
  1598.     int h1=id1->value.integer, h2=id2->value.integer;
  1599.     Lsymtab *symt1,*symt2,*temp;
  1600.  
  1601.         /* install the variables in symtab if not seen before */
  1602.     if( (symt1=hashtab[h1].loc_symtab) == NULL) {
  1603.        symt1 = install_local(h1,type_UNDECL,class_VAR);
  1604.     }
  1605.     if( (symt2=hashtab[h2].loc_symtab) == NULL) {
  1606.        symt2 = install_local(h2,type_UNDECL,class_VAR);
  1607.     }
  1608.             /* Check for legality.  Ought to do complementary
  1609.                checks elsewhere.
  1610.              */
  1611.     if(symt1 == symt2
  1612.        || symt1->parameter || symt2->parameter
  1613.        || symt1->entry_point || symt2->entry_point
  1614.        || symt1->argument || symt2->argument
  1615.        || symt1->external || symt2->external) {
  1616.  
  1617.         syntax_error(id1->line_num,id1->col_num,
  1618.                  "illegal to equivalence these");
  1619.     }
  1620.         /* now swap equiv_links so their equiv lists are united */
  1621.     else {
  1622.         temp = symt1->equiv_link;
  1623.         symt1->equiv_link = symt2->equiv_link;
  1624.         symt2->equiv_link = temp;
  1625.     }
  1626.  
  1627.         /* If either guy is in common, both are in common */
  1628.     if(symt1->common_var || symt2->common_var) {
  1629.         Lsymtab *equiv=symt1;
  1630.         do {
  1631.         equiv->common_var = TRUE;
  1632.         equiv = equiv->equiv_link;
  1633.         } while(equiv != symt1);
  1634.     }
  1635. }
  1636.  
  1637. int
  1638. #if HAVE_STDC
  1639. get_size(Lsymtab *symt, int type)            /* ARGSUSED1 */
  1640. #else /* K&R style */
  1641. get_size(symt,type)            /* ARGSUSED1 */
  1642. #endif /* HAVE_STDC */
  1643.             /* Returns size of symbol if explicitly declared
  1644.                or declared using IMPLICIT type*size statement.
  1645.                Otherwise returns size_DEFAULT. */
  1646. #if HAVE_STDC
  1647.                           /* Evaluated datatype: not used at present */
  1648. #else /* K&R style */
  1649.      Lsymtab *symt;
  1650.      int type;            /* Evaluated datatype: not used at present */
  1651. #endif /* HAVE_STDC */
  1652. {
  1653.   int datasize=symt->size;
  1654.   int datatype = datatype_of(symt->type);
  1655.   if(datatype != type_UNDECL) /* Declared? */
  1656.     return datasize;        /* if declared, use it */
  1657.   else {
  1658.     int first_char=(int)symt->name[0];
  1659.  
  1660.     if(first_char == '$')  first_char = 'Z'+1;
  1661.     if(first_char == '_')  first_char = 'Z'+2;
  1662.  
  1663.     return implicit_size[first_char - 'A'];
  1664.   }
  1665. }
  1666.  
  1667. char *
  1668. #if HAVE_STDC
  1669. get_size_text(Lsymtab *symt, int type)        /* ARGSUSED1 */
  1670.                           /* Evaluated datatype: not used at present */
  1671. #else /* K&R style */
  1672. get_size_text(symt,type)        /* ARGSUSED1 */
  1673.      Lsymtab *symt;
  1674.      int type;            /* Evaluated datatype: not used at present */
  1675. #endif /* HAVE_STDC */
  1676. {
  1677.   int datatype = datatype_of(symt->type);
  1678.   if(datatype != type_UNDECL)
  1679.                 /* Declared: use text in symtab entry */
  1680.     if(symt->array_var)
  1681.       return symt->src.textvec[array_dims(symt->info.array_dim)];
  1682.     else
  1683.       return symt->src.text;
  1684.  
  1685.   else {
  1686.                 /* Undeclared: use implicit value */
  1687.     int first_char=(int)symt->name[0];
  1688.  
  1689.     if(first_char == '$')  first_char = 'Z'+1;
  1690.     if(first_char == '_')  first_char = 'Z'+2;
  1691.  
  1692.     return implicit_len_text[first_char - 'A'];
  1693.   }
  1694. }
  1695.  
  1696. int
  1697. #if HAVE_STDC
  1698. get_type(Lsymtab *symt)    /* Returns data type of symbol, using implicit if necessary */
  1699. #else /* K&R style */
  1700. get_type(symt)    /* Returns data type of symbol, using implicit if necessary */
  1701.     Lsymtab *symt;
  1702. #endif /* HAVE_STDC */
  1703. {
  1704.     int datatype = datatype_of(symt->type);
  1705.  
  1706.     if(datatype != type_UNDECL)    /* Declared? */
  1707.        return datatype;        /*   Yes: use it */
  1708.     else if(storage_class_of(symt->type) == class_SUBPROGRAM
  1709.          && !symt->invoked_as_func )
  1710.                 /* Function never invoked: assume subr */
  1711.        return type_SUBROUTINE;
  1712.     else if (symt->invoked_as_func && symt->intrinsic)
  1713.     {
  1714.         IntrinsInfo *defn;
  1715.  
  1716.         defn = find_intrinsic(symt->name);
  1717.         if (defn != (IntrinsInfo *)NULL)
  1718.         return defn->result_type;
  1719.     }
  1720.  
  1721.     /* Fell through, so type must be determined by first letter of name */
  1722.  
  1723.     {
  1724.       int first_char=(int)symt->name[0];
  1725. #ifdef ALLOW_DOLLARSIGNS
  1726.       if(first_char == '$')  first_char = 'Z'+1;
  1727. #endif
  1728. #ifdef ALLOW_UNDERSCORES
  1729.       if(first_char == '_')  first_char = 'Z'+2;
  1730. #endif
  1731.  
  1732.        return implicit_type[first_char - 'A'];
  1733.     }
  1734. }/*get_type*/
  1735.  
  1736.  
  1737.     /* hash_lookup finds identifier in hashtable and returns its
  1738.        index.  If not found, a new hashtable entry is made for it,
  1739.        and the identifier string s is copied to local stringspace.
  1740.     */
  1741. unsigned
  1742. #if HAVE_STDC
  1743. hash_lookup(char *s)
  1744. #else /* K&R style */
  1745. hash_lookup(s)
  1746.     char *s;
  1747. #endif /* HAVE_STDC */
  1748. {
  1749.         unsigned h;
  1750.     unsigned long hnum;
  1751.  
  1752.     hnum = hash(s);
  1753.  
  1754.     while(h = hnum%HASHSZ, hashtab[h].name != NULL
  1755.               && strcmp(hashtab[h].name,s) != 0) {
  1756.               hnum = rehash(hnum);    /* Resolve clashes */
  1757.     }
  1758.  
  1759.     if(hashtab[h].name == NULL) {
  1760.             hashtab[h].name = new_local_string(s);
  1761.             hashtab[h].loc_symtab = NULL;
  1762.             hashtab[h].glob_symtab = NULL;
  1763.             hashtab[h].com_loc_symtab = NULL;
  1764.             hashtab[h].com_glob_symtab = NULL;
  1765.         }
  1766.     return h;
  1767. }/*hash_lookup*/
  1768.  
  1769. void
  1770. init_tables(VOID)            /* Allocates table space */
  1771. {
  1772. #ifdef DYNAMIC_TABLES        /* tables will be mallocked at runtime */
  1773.     if( ((loc_symtab=(Lsymtab*)calloc(LOCSYMTABSZ,sizeof(Lsymtab)))
  1774.         == (Lsymtab*)NULL) ||
  1775.         ((glob_symtab=(Gsymtab*)calloc(GLOBSYMTABSZ,sizeof(Gsymtab)))
  1776.         == (Gsymtab*)NULL) ||
  1777.         ((hashtab=(HashTable*)calloc(HASHSZ,sizeof(HashTable)))
  1778.         == (HashTable*)NULL)
  1779.       ) {
  1780.       oops_message(OOPS_FATAL,NO_LINE_NUM,NO_COL_NUM,
  1781.                "Cannot malloc space for tables");
  1782.     }
  1783. #endif
  1784. }
  1785.  
  1786. void
  1787. init_globals(VOID)                    /* Clears the global symbol table */
  1788. {
  1789.   glob_symtab_top = 0;    /* Neither of these stmts is really needed. */
  1790.   glob_strings_used = 0;
  1791. }/*init_globals*/
  1792.  
  1793.  
  1794.  
  1795. void
  1796. init_symtab(VOID)                     /* Clears the local symbol table */
  1797. {
  1798.     int i,h;
  1799.     unsigned long hnum;
  1800.  
  1801.     loc_symtab_top = 0;    /* Clear local symtab */
  1802.  
  1803.     curr_loc_strspace = &lstrspace;
  1804.     loc_str_top = 0;    /* Reset storage area for local strings */
  1805.     extra_locstrspace = 0;
  1806.  
  1807.     curr_srctextspace = &srctextspace;
  1808.     srctextspace_top = 0;    /* Reset storage area for token text */
  1809.     extra_srctextspace = 0;
  1810.  
  1811.     curr_tokspace = &tokspace;
  1812.     token_space_top = 0;    /* Reset storage for tokens in lists & trees */
  1813.     extra_tokspace = 0;
  1814.  
  1815.     curr_paraminfospace = ¶minfospace;
  1816.      param_info_space_top = 0;/* Reset storage for parameter info structs */
  1817.     extra_paraminfospace = 0;
  1818.  
  1819.     curr_tokheadspace = &tokheadspace;
  1820.      token_head_space_top = 0;/* Reset storage for tokenlist headers */
  1821.     extra_tokheadspace = 0;
  1822.  
  1823.     curr_ptrspace = &ptrspace;
  1824.     ptrspace_top = 0;    /* Reset storage for array dim textvecs */
  1825.     extra_ptrspace = 0;
  1826.  
  1827.     parameter_count = 0;
  1828.  
  1829.               /* Clears the hash table */
  1830.     for(i=0;i<HASHSZ;i++) {
  1831.         hashtab[i].name = NULL;
  1832.         hashtab[i].loc_symtab = NULL;
  1833.         hashtab[i].com_loc_symtab = NULL;
  1834.         hashtab[i].glob_symtab = NULL;
  1835.         hashtab[i].com_glob_symtab = NULL;
  1836.     }
  1837.  
  1838.               /* Re-establishes global symbols */
  1839.     for(i=0;i<glob_symtab_top;i++) {
  1840.         hnum = hash(glob_symtab[i].name);
  1841.         while (h=hnum % HASHSZ, hashtab[h].name != NULL
  1842.            && strcmp(hashtab[h].name,glob_symtab[i].name) != 0 ) {
  1843.            hnum = rehash(hnum);
  1844.         }
  1845.         hashtab[h].name = glob_symtab[i].name;
  1846.         if(storage_class_of(glob_symtab[i].type) == class_COMMON_BLOCK)
  1847.         hashtab[h].com_glob_symtab = &(glob_symtab[i]);
  1848.         else
  1849.         hashtab[h].glob_symtab = &(glob_symtab[i]);
  1850.  
  1851.     }
  1852.  
  1853.               /* Restores implicit typing to default values.
  1854.                  Note: 27 is '$', 28 is '_' which are default REAL */
  1855.     {
  1856.         int c;
  1857.         for( c=0; c<=('Z'-'A'+2); c++ ) {
  1858.                 implicit_type[c] = type_REAL;
  1859.             implicit_size[c] = size_DEFAULT;
  1860.             implicit_len_text[c] = NULL;
  1861.         }
  1862.         for( c='I'-'A'; c <= 'N'-'A'; c++ )
  1863.             implicit_type[c] = type_INTEGER;
  1864.     }
  1865. }/*init_symtab*/
  1866.  
  1867.  
  1868.  
  1869. Gsymtab*
  1870. #if HAVE_STDC
  1871. install_global(int h, int datatype, int storage_class)    /* Install a global symbol */
  1872.                       /* hash index */
  1873. #else /* K&R style */
  1874. install_global(h,datatype,storage_class)    /* Install a global symbol */
  1875.     int h;            /* hash index */
  1876.     int datatype,storage_class;
  1877. #endif /* HAVE_STDC */
  1878. {
  1879.     Gsymtab *gsymt = &glob_symtab[glob_symtab_top];
  1880.  
  1881.     if(glob_symtab_top == GLOBSYMTABSZ) {
  1882.       oops_message(OOPS_FATAL,line_num,NO_COL_NUM,
  1883. #ifdef LARGE_MACHINE
  1884. "out of space in global symbol table\n\
  1885. Recompile me with larger GLOBSYMTABSZ value\n"
  1886. #else
  1887. "out of space in global symbol table\n\
  1888. Recompile me with LARGE_MACHINE option\n"
  1889. #endif
  1890.         );
  1891.     }
  1892.     else {
  1893.             /* Store symtab pointer in hash table */
  1894.         if(storage_class == class_COMMON_BLOCK)
  1895.         hashtab[h].com_glob_symtab = gsymt;
  1896.         else
  1897.         hashtab[h].glob_symtab = gsymt;
  1898.  
  1899.         clear_symtab_entry(gsymt);
  1900.  
  1901.              /* Duplicate copy of string into global stringspace */
  1902.         gsymt->name = new_global_string(hashtab[h].name);
  1903.  
  1904.             /* Set symtab info fields */
  1905.         gsymt->type = type_byte(storage_class,datatype);
  1906.         gsymt->size = type_size[datatype];
  1907.         if(storage_class == class_COMMON_BLOCK)
  1908.         gsymt->info.comlist = NULL;
  1909.         else
  1910.         gsymt->info.arglist = NULL;
  1911.  
  1912.         gsymt->link.child_list = NULL;
  1913.  
  1914.         ++glob_symtab_top;
  1915.     }
  1916.     return (gsymt);
  1917. }/*install_global*/
  1918.  
  1919.  
  1920. PRIVATE Lsymtab*
  1921. #if HAVE_STDC
  1922. install_local(int h, int datatype, int storage_class)    /* Install a local symbol */
  1923.                       /* hash index */
  1924. #else /* K&R style */
  1925. install_local(h,datatype,storage_class)    /* Install a local symbol */
  1926.     int h;            /* hash index */
  1927.     int datatype,storage_class;
  1928. #endif /* HAVE_STDC */
  1929. {
  1930.     Lsymtab *symt = &loc_symtab[loc_symtab_top];
  1931.     if(loc_symtab_top == LOCSYMTABSZ) {
  1932.       oops_message(OOPS_FATAL,line_num,NO_COL_NUM,
  1933. #ifdef LARGE_MACHINE
  1934. "out of space in local symbol table\n\
  1935. Recompile me with larger LOCSYMTABSZ value\n"
  1936. #else
  1937. "out of space in local symbol table\n\
  1938. Recompile me with LARGE_MACHINE option\n"
  1939. #endif
  1940.         );
  1941.     }
  1942.     else {
  1943.         if(storage_class == class_COMMON_BLOCK)
  1944.         hashtab[h].com_loc_symtab = symt;
  1945.         else
  1946.         hashtab[h].loc_symtab = symt;
  1947.  
  1948.         clear_symtab_entry(symt);
  1949.         symt->name = hashtab[h].name;
  1950.         symt->info.array_dim = 0;
  1951.  
  1952.               /* Set symtab info fields */
  1953.         symt->type = type_byte(storage_class,datatype);
  1954.         symt->size = type_size[datatype];
  1955.         symt->src.text = NULL;
  1956.         symt->equiv_link = symt;    /* equivalenced only to self */
  1957.         if(incdepth > 0)
  1958.           symt->defined_in_include = TRUE;
  1959.         ++loc_symtab_top;
  1960.     }
  1961.     return symt;
  1962. }/*install_local*/
  1963.  
  1964.  
  1965.         /* Get value specified by an integer-expression token.
  1966.            This will be either an identifier, which should be a
  1967.            parameter whose value is in the symbol table, or else
  1968.            an expression token as propagated by exprtype.c
  1969.            routines, with value stored in the token.
  1970.         */
  1971. int
  1972. #if HAVE_STDC
  1973. int_expr_value(Token *t)
  1974. #else /* K&R style */
  1975. int_expr_value(t)
  1976.     Token *t;
  1977. #endif /* HAVE_STDC */
  1978. {
  1979.   if(!is_true(EVALUATED_EXPR,t->TOK_flags)) {/* something bogus */
  1980.                 /* warn if error message not already given */
  1981.     if(is_true(PARAMETER_EXPR,t->TOK_flags))
  1982.       if(misc_warn)
  1983.     warning(t->line_num,t->col_num,
  1984.           "Constant not evaluated: value of 0 assumed");
  1985.   }
  1986.   else {
  1987.     if( is_true(ID_EXPR,t->TOK_flags) ) {
  1988.         /* Identifier: better be a parameter */
  1989.         int h=t->value.integer;
  1990.         Lsymtab *symt = hashtab[h].loc_symtab;
  1991.         if(symt == NULL || !(symt->parameter) ) {
  1992.         syntax_error(t->line_num,t->col_num,
  1993.             "symbolic constant required");
  1994.         }
  1995.         else {
  1996.         return symt->info.param->value.integer;
  1997.         }
  1998.     }
  1999.         /* Otherwise, it is a const or expr, use token.value.integer */
  2000.     else {
  2001.         return t->value.integer;
  2002.     }
  2003.   }
  2004.                 /* Unsuccessful: return value of 0 */
  2005.   return 0;
  2006. }/*int_expr_value*/
  2007.  
  2008. DBLVAL
  2009. #if HAVE_STDC
  2010. float_expr_value(Token *t)
  2011. #else /* K&R style */
  2012. float_expr_value(t)
  2013.     Token *t;
  2014. #endif /* HAVE_STDC */
  2015. {
  2016.   if(is_true(LIT_CONST,t->TOK_flags))
  2017.     return t->value.dbl;
  2018.   else
  2019.     return (DBLVAL)0;        /* float values are not propagated */
  2020. }
  2021.  
  2022. char *
  2023. #if HAVE_STDC
  2024. char_expr_value(Token *t)
  2025. #else /* K&R style */
  2026. char_expr_value(t)
  2027.     Token *t;
  2028. #endif /* HAVE_STDC */
  2029. {
  2030.   if(is_true(LIT_CONST,t->TOK_flags))
  2031.     return t->value.string;
  2032.   else
  2033.     return NULL;        /* char values are not propagated */
  2034. }
  2035.     /* Following routine converts a list of tokens into a list of type-
  2036.        flag pairs. */
  2037.  
  2038. PRIVATE ArgListHeader *
  2039. #if HAVE_STDC
  2040. make_arg_array(Token *t)
  2041.                      /* List of tokens */
  2042. #else /* K&R style */
  2043. make_arg_array(t)
  2044.     Token *t;        /* List of tokens */
  2045. #endif /* HAVE_STDC */
  2046. {
  2047.     int i;
  2048.     unsigned count;
  2049.     Token *s;
  2050.     ArgListElement *arglist;
  2051.     ArgListHeader *alhead;
  2052.  
  2053.     count = arg_count(t);
  2054.     if(((alhead=new_arglistheader())
  2055.                   == (ArgListHeader *) NULL) ||
  2056.       (count != 0 &&
  2057.           ((arglist=new_arglistelement(count))
  2058.                  == (ArgListElement *) NULL))){
  2059.         oops_message(OOPS_FATAL,line_num,NO_COL_NUM,
  2060.                "Out of malloc space for argument list");
  2061.     }
  2062.     s = t;
  2063.     for(i=0; i<count; i++){  /* Here we fill array. */
  2064.  
  2065.         arglist[i].type = s->TOK_type; /* use evaluated type, not symt */
  2066.         arglist[i].size = s->size;
  2067.             /* Keep track of array and external declarations */
  2068.         if( is_true(ID_EXPR,s->TOK_flags) ){
  2069.         int h = s->value.integer;
  2070.         Lsymtab *symt = hashtab[h].loc_symtab;
  2071.         if( (arglist[i].info.array_dim = symt->info.array_dim) == 0)
  2072.                 /* change scalars to 0 dims, size 1 */
  2073.           arglist[i].info.array_dim = array_dim_info(0,1);
  2074.         arglist[i].array_var = symt->array_var;
  2075.         arglist[i].declared_external = symt->declared_external;
  2076.         }
  2077.         else {
  2078.         arglist[i].info.array_dim = array_dim_info(0,1);
  2079.         arglist[i].array_var = FALSE;
  2080.         arglist[i].declared_external = FALSE;
  2081.         }
  2082.  
  2083.         arglist[i].array_element =
  2084.         arglist[i].array_var && !is_true(ARRAY_ID_EXPR,s->TOK_flags);
  2085.  
  2086.         if( is_true(LVALUE_EXPR,s->TOK_flags) ){
  2087.         arglist[i].is_lvalue = TRUE;
  2088.             /* is_true(f,x) yields 0 or non-0: convert to 0 or 1 */
  2089.         arglist[i].set_flag =
  2090.             is_true(SET_FLAG,s->TOK_flags)? TRUE: FALSE;
  2091.         arglist[i].assigned_flag =
  2092.             is_true(ASSIGNED_FLAG,s->TOK_flags)? TRUE: FALSE;
  2093.         arglist[i].used_before_set =
  2094.             is_true(USED_BEFORE_SET,s->TOK_flags)? TRUE: FALSE;
  2095.         }
  2096.         else {    /* it is an expression or constant, not an lvalue */
  2097.         arglist[i].is_lvalue = FALSE;
  2098.         arglist[i].set_flag = TRUE;
  2099.         arglist[i].assigned_flag = FALSE;
  2100.         arglist[i].used_before_set = FALSE;
  2101.         }
  2102.         s = s->next_token;
  2103.     }
  2104.     alhead->numargs = (short)count;
  2105.     alhead->is_defn = FALSE;
  2106.     alhead->is_call = TRUE;
  2107.     alhead->external_decl = FALSE;
  2108.     alhead->actual_arg = FALSE;
  2109.  
  2110.         if (count == 0)
  2111.         alhead->arg_array = NULL;
  2112.     else
  2113.         alhead->arg_array = arglist;
  2114.     return(alhead);
  2115. }/* make_arg_array */
  2116.  
  2117. PRIVATE void
  2118. #if HAVE_STDC
  2119. make_arg_names(Token *tlist, ArgListHeader *alhead, ArgListHeader *prev_alhead)
  2120. #else /* K&R style */
  2121. make_arg_names(tlist, alhead, prev_alhead)
  2122.      Token *tlist;
  2123.      ArgListHeader *alhead, *prev_alhead;
  2124. #endif /* HAVE_STDC */
  2125. {
  2126.     int h, i, n, prev_n;
  2127.     Token *s;
  2128. #ifdef KEEP_ARG_NAMES
  2129.     char *name;
  2130.     char expr_text[MAXEXPRTEXT+2]; /* big enough for 1 extra */
  2131. #else
  2132.     static char expr[]="expr",     /* text strings to use */
  2133.                 var[]="var";
  2134. #endif
  2135.     ArgListElement *arglist, *prev_arglist;
  2136.  
  2137.     n = alhead->numargs;
  2138.     if(n > 0) {
  2139.       arglist = alhead->arg_array;
  2140.       if(prev_alhead != NULL) {
  2141.         prev_n = prev_alhead->numargs;
  2142.         prev_arglist = prev_alhead->arg_array;
  2143.       }
  2144.       for(i=0, s=tlist; i<n; i++, s=s->next_token) {
  2145.                 /* Use symtab name for id's but note that
  2146.                    array elements come thru with ID_EXPR
  2147.                    true but want to use expr tree for them.*/
  2148.         if(is_true(ID_EXPR,s->TOK_flags)
  2149.             && !is_true(ARRAY_ELEMENT_EXPR,s->TOK_flags)) {
  2150. #ifdef KEEP_ARG_NAMES
  2151.           h = s->value.integer;
  2152.           name = hashtab[h].loc_symtab->name;
  2153. #else
  2154.           name = var;
  2155. #endif
  2156.         }
  2157.         else {                /* expression */
  2158. #ifdef KEEP_ARG_NAMES
  2159.           int ncopied;
  2160.           ncopied = cp_tree_src_text(expr_text,
  2161.             (s->left_token == NULL?
  2162.                 s:            /* Primary */
  2163.                 s->left_token),    /* Expr tree */
  2164.             MAXEXPRTEXT+1);
  2165.           if(ncopied > MAXEXPRTEXT)    /* Longer than the limit: */
  2166.                     /* replace tail by dots   */
  2167.         (void)strcpy(expr_text+MAXEXPRTEXT-2,"..");
  2168.           name = expr_text;
  2169. #else
  2170.           arglist[i].name = expr;
  2171. #endif
  2172.         }
  2173. #ifdef KEEP_ARG_NAMES
  2174.                 /* Try to avoid allocating space again */
  2175.         if(prev_alhead != NULL && i < prev_n
  2176.          && strcmp(name,prev_arglist[i].name) == 0) {
  2177.           name = prev_arglist[i].name;
  2178.         }
  2179.         else if(is_true(ID_EXPR,s->TOK_flags)
  2180.             && !is_true(ARRAY_ELEMENT_EXPR,s->TOK_flags)) {
  2181.           if(hashtab[h].glob_symtab != NULL) {
  2182.         name = hashtab[h].glob_symtab->name;
  2183.           }
  2184.           else if(hashtab[h].com_glob_symtab != NULL) {
  2185.         name = hashtab[h].com_glob_symtab->name;
  2186.           }
  2187.           else            /* No luck: put it into global space */
  2188.         name = new_global_string(name);
  2189.         }
  2190.         else
  2191.           name = new_global_string(name);
  2192. #endif
  2193.         arglist[i].name = name;
  2194.       }
  2195.     }
  2196. }
  2197.  
  2198.     /* Following routine converts a list of common block tokens
  2199.         into a list of dimen_info-type pairs. */
  2200.  
  2201. PRIVATE ComListHeader *
  2202. #if HAVE_STDC
  2203. make_com_array(Token *t)
  2204.                      /* List of tokens */
  2205. #else /* K&R style */
  2206. make_com_array(t)
  2207.     Token *t;        /* List of tokens */
  2208. #endif /* HAVE_STDC */
  2209. {
  2210.     Token *s;
  2211.     Lsymtab *symt;
  2212.     int h, i;
  2213.     unsigned count;
  2214.     ComListHeader *clhead;
  2215.     ComListElement *comlist;
  2216.  
  2217.     count = arg_count(t);
  2218.     if(((clhead=new_comlistheader())
  2219.          == (ComListHeader *) NULL) ||
  2220.       (count != 0 &&
  2221.        ((comlist=new_comlistelement(count))
  2222.          == (ComListElement *) NULL))){
  2223.         oops_message(OOPS_FATAL,line_num,NO_COL_NUM,
  2224.                "Out of malloc space for common list");
  2225.     }
  2226.     s = t;
  2227.     for(i=0; i<count; i++){
  2228.        h = s->value.integer;
  2229.        symt = hashtab[h].loc_symtab;
  2230.        comlist[i].name = NULL; /* names are added later by make_com_list */
  2231.        if( (comlist[i].dimen_info = symt->info.array_dim) == 0)
  2232.                 /* change scalars to 0 dims, size 1 */
  2233.          comlist[i].dimen_info = array_dim_info(0,1);
  2234.               comlist[i].type = get_type(symt);
  2235.        comlist[i].size = get_size(symt,(int)comlist[i].type);
  2236.        comlist[i].used = symt->used_flag;
  2237.        comlist[i].set = symt->set_flag;
  2238.        comlist[i].used_before_set = symt->used_before_set;
  2239.        comlist[i].assigned = symt->assigned_flag;
  2240.        if (comlist[i].used)
  2241.         clhead->any_used = TRUE;
  2242.        if (comlist[i].set)
  2243.         clhead->any_set = TRUE;
  2244.        s = s->next_token;
  2245.     }
  2246.     clhead->numargs = (short)count;
  2247.     if (count == 0)
  2248.         clhead->com_list_array = NULL;
  2249.     else
  2250.         clhead->com_list_array = comlist;
  2251.     return(clhead);
  2252. } /* make_com_array */
  2253.  
  2254. PRIVATE void
  2255. #if HAVE_STDC
  2256. make_com_names(Token *tlist, ComListHeader *clhead, ComListHeader *prev_clhead)
  2257. #else /* K&R style */
  2258. make_com_names(tlist, clhead, prev_clhead)
  2259.      Token *tlist;
  2260.      ComListHeader *clhead, *prev_clhead;
  2261. #endif /* HAVE_STDC */
  2262. {
  2263.     int h, i, n, prev_n;
  2264.     Token *s;
  2265.     ComListElement *comlist, *prev_comlist;
  2266.     char *name;
  2267.     comlist = clhead->com_list_array;
  2268.  
  2269.     n = clhead->numargs;
  2270.     if(prev_clhead != NULL) {
  2271.       prev_n = prev_clhead->numargs;
  2272.       prev_comlist = prev_clhead->com_list_array;
  2273.     }
  2274.  
  2275.     for(i=0, s=tlist; i<n; i++, s=s->next_token) {
  2276.       h = s->value.integer;
  2277.       name = hashtab[h].loc_symtab->name;
  2278.  
  2279.         /* Try to avoid allocating new global space for name:
  2280.            Check if the variable matches a global name
  2281.            (unlikely) or name of corresponding variable in
  2282.            previous declaration of same block used the same
  2283.            name (likely), and if so, re-use the global string.
  2284.            Otherwise allocate new space in global table.  */
  2285.  
  2286.       if(prev_clhead != NULL && i < prev_n
  2287.          && strcmp(name,prev_comlist[i].name) == 0) {
  2288.         name = prev_comlist[i].name;
  2289.       }
  2290.       else if(hashtab[h].glob_symtab != NULL) {
  2291.         name = hashtab[h].glob_symtab->name;
  2292.       }
  2293.       else if(hashtab[h].com_glob_symtab != NULL) {
  2294.         name = hashtab[h].com_glob_symtab->name;
  2295.       }
  2296.       else            /* No luck: put it into global space */
  2297.         name = new_global_string(name);
  2298.  
  2299.       comlist[i].name = name;
  2300.     }
  2301. }
  2302.  
  2303. PRIVATE ArgListHeader *
  2304. #if HAVE_STDC
  2305. make_dummy_arg_array (Token *t)
  2306.                      /* List of tokens */
  2307. #else /* K&R style */
  2308. make_dummy_arg_array (t)
  2309.     Token *t;        /* List of tokens */
  2310. #endif /* HAVE_STDC */
  2311. {
  2312.     int i;
  2313.     unsigned count;
  2314.     Token *s;
  2315.     ArgListElement *arglist;
  2316.     ArgListHeader *alhead;
  2317.  
  2318.     count = arg_count(t);
  2319.     if(((alhead=new_arglistheader())
  2320.              == (ArgListHeader *) NULL) ||
  2321.       (count != 0 &&
  2322.           ((arglist=new_arglistelement(count))
  2323.             == (ArgListElement *) NULL))){
  2324.         oops_message(OOPS_FATAL,line_num,NO_COL_NUM,
  2325.                "Out of malloc space for dummy argument list");
  2326.     }
  2327.     s = t;
  2328.     for(i=0; i<count; i++){
  2329.         if( is_true(ID_EXPR,s->TOK_flags) ){
  2330.             int implied_type;
  2331.         int h = s->value.integer;
  2332.         Lsymtab *symt = hashtab[h].loc_symtab;
  2333.         if( (arglist[i].info.array_dim = symt->info.array_dim) == 0)
  2334.                 /* change scalars to 0 dims, size 1 */
  2335.           arglist[i].info.array_dim = array_dim_info(0,1);
  2336.         implied_type = get_type(symt);
  2337.         arglist[i].type = type_byte(storage_class_of(symt->type),
  2338.                         implied_type);
  2339.         arglist[i].size = get_size(symt,implied_type);
  2340.         arglist[i].is_lvalue = TRUE;
  2341.         arglist[i].set_flag = symt->set_flag;
  2342.         arglist[i].assigned_flag = symt->assigned_flag;
  2343.         arglist[i].used_before_set = symt->used_before_set;
  2344.         arglist[i].array_var = symt->array_var;
  2345.         arglist[i].array_element = FALSE;
  2346.         arglist[i].declared_external = symt->declared_external;
  2347.         }
  2348.         else {    /* It is a label */
  2349.         arglist[i].info.array_dim = 0;
  2350.         arglist[i].type = s->TOK_type;
  2351.         arglist[i].size = 0;
  2352.         arglist[i].is_lvalue = FALSE;
  2353.         arglist[i].set_flag = FALSE;    /* Don't currently do labels */
  2354.         arglist[i].assigned_flag = FALSE;
  2355.         arglist[i].used_before_set = FALSE;
  2356.         arglist[i].array_var = FALSE;
  2357.         arglist[i].array_element = FALSE;
  2358.         arglist[i].declared_external = FALSE;
  2359.         }
  2360.         s = s->next_token;
  2361.     }
  2362.     alhead->numargs = (short)count;
  2363.     alhead->is_defn = TRUE;
  2364.     alhead->is_call = FALSE;
  2365.     alhead->external_decl = FALSE;
  2366.     alhead->actual_arg = FALSE;
  2367.  
  2368.         if (count == 0)
  2369.         alhead->arg_array = NULL;
  2370.     else
  2371.         alhead->arg_array = arglist;
  2372.     return(alhead);
  2373. }/* make_dummy_arg_array */
  2374.  
  2375.  
  2376.     /* This routine makes an empty argument list: used for
  2377.        EXTERNAL declarations of subprograms. */
  2378. PRIVATE ArgListHeader *
  2379. make_arrayless_alist(VOID)
  2380. {
  2381.     ArgListHeader *alhead;
  2382.  
  2383.     if(((alhead=new_arglistheader())
  2384.                   == (ArgListHeader *) NULL) ) {
  2385.         oops_message(OOPS_FATAL,line_num,NO_COL_NUM,
  2386.                "Out of malloc space for external decl");
  2387.     }
  2388.  
  2389.     alhead->numargs = 0;
  2390.     alhead->is_defn = FALSE;
  2391.     alhead->is_call = FALSE;
  2392.     alhead->arg_array = NULL;
  2393.  
  2394.     return(alhead);
  2395. }/* make_arrayless_arglist */
  2396.  
  2397. PRIVATE TokenListHeader *    /* Initializes a tokenlist header */
  2398. #if HAVE_STDC
  2399. make_TL_head(Token *t)
  2400. #else /* K&R style */
  2401. make_TL_head(t)
  2402.      Token *t;
  2403. #endif /* HAVE_STDC */
  2404. {
  2405.     TokenListHeader *TH_ptr;
  2406.     TH_ptr = new_tokhead();
  2407.     TH_ptr->line_num = t->line_num;
  2408.     TH_ptr->top_line_num = (current_filename == top_filename?
  2409.                 t->line_num: top_file_line_num);
  2410.       TH_ptr->filename = current_filename;
  2411.                 /* Clear all the flags */
  2412.     TH_ptr->external_decl = FALSE;
  2413.     TH_ptr->actual_arg = FALSE;
  2414.     TH_ptr->tokenlist = NULL;
  2415.     TH_ptr->next = NULL;
  2416.  
  2417.   return TH_ptr;
  2418. }
  2419.  
  2420. #ifndef T_ALLOC
  2421.  
  2422.     /* This routine allocates permanent space for argument list
  2423.        elements in chunks for efficiency.  It returns a pointer to
  2424.        space for count consecutive elements. */
  2425.  
  2426. PRIVATE ArgListElement *
  2427. #if HAVE_STDC
  2428. new_arglistelement(unsigned int count)
  2429. #else /* K&R style */
  2430. new_arglistelement(count)
  2431.      unsigned count;
  2432. #endif /* HAVE_STDC */
  2433. {
  2434.   static unsigned long arglistspace_bot=0;
  2435.   static ArgListElement *arglist_space=NULL;
  2436.  
  2437.   arglist_element_used += count;    /* For -resources */
  2438.  
  2439.   if(arglistspace_bot < count) {
  2440.     unsigned long numalloc = (count > ARGLISTELTSZ? count: ARGLISTELTSZ);
  2441.     arglist_space=(ArgListElement *)calloc(numalloc,sizeof(ArgListElement));
  2442.     if(arglist_space == (ArgListElement *)NULL) {
  2443.       oops_message(OOPS_FATAL,line_num,NO_COL_NUM,
  2444.            "Cannot alloc space for argument list");
  2445.       return (ArgListElement *)NULL; /*NOTREACHED*/
  2446.     }
  2447.     arglistspace_bot = numalloc;
  2448.   }
  2449.                 /* Slots are allocated from top down */
  2450.   arglistspace_bot -= count;
  2451.   return arglist_space + arglistspace_bot;
  2452. }
  2453.  
  2454.     /* This routine allocates permanent space for argument list
  2455.        headers in chunks for efficiency.  Returns a pointer to
  2456.        space for one header. */
  2457.  
  2458. PRIVATE ArgListHeader *
  2459. new_arglistheader(VOID)
  2460. {
  2461.   static unsigned long arglistheadspace_bot=0;
  2462.   static ArgListHeader *arglisthead_space;
  2463.  
  2464.   arglist_head_used++;
  2465.  
  2466.   if(arglistheadspace_bot < 1) {
  2467.     arglisthead_space=
  2468.       (ArgListHeader *)calloc(ARGLISTHEADSZ,sizeof(ArgListHeader));
  2469.     if(arglisthead_space == (ArgListHeader *)NULL) {
  2470.       oops_message(OOPS_FATAL,line_num,NO_COL_NUM,
  2471.            "Cannot alloc space for argument list header");
  2472.       return (ArgListHeader *)NULL; /*NOTREACHED*/
  2473.     }
  2474.     arglistheadspace_bot = ARGLISTHEADSZ;
  2475.   }
  2476.                 /* Slots are allocated from top down */
  2477.   return arglisthead_space + (--arglistheadspace_bot);
  2478. }
  2479.  
  2480.     /* Returns pointer to space for count consecutive common list
  2481.        elements. */
  2482.  
  2483. PRIVATE ComListElement *
  2484. #if HAVE_STDC
  2485. new_comlistelement(unsigned int count)
  2486. #else /* K&R style */
  2487. new_comlistelement(count)
  2488.      unsigned count;
  2489. #endif /* HAVE_STDC */
  2490. {
  2491.   static unsigned long comlistspace_bot=0;
  2492.   static ComListElement *comlist_space=NULL;
  2493.  
  2494.   comlist_element_used += count;    /* For -resources */
  2495.  
  2496.   if(comlistspace_bot < count) {
  2497.     unsigned long numalloc = (count > COMLISTELTSZ? count: COMLISTELTSZ);
  2498.     comlist_space=(ComListElement *)calloc(numalloc,sizeof(ComListElement));
  2499.     if(comlist_space == (ComListElement *)NULL) {
  2500.       oops_message(OOPS_FATAL,line_num,NO_COL_NUM,
  2501.            "Cannot alloc space for common block list");
  2502.       return (ComListElement *)NULL; /*NOTREACHED*/
  2503.     }
  2504.     comlistspace_bot = numalloc;
  2505.   }
  2506.                 /* Slots are allocated from top down */
  2507.   comlistspace_bot -= count;
  2508.   return comlist_space + comlistspace_bot;
  2509. }
  2510.  
  2511.     /* Returns pointer to space for one common block header */
  2512.  
  2513. PRIVATE ComListHeader *
  2514. new_comlistheader(VOID)
  2515. {
  2516.   static unsigned long comlistheadspace_bot=0;
  2517.   static ComListHeader *comlisthead_space;
  2518.  
  2519.   comlist_head_used++;
  2520.  
  2521.   if(comlistheadspace_bot < 1) {
  2522.     comlisthead_space=
  2523.       (ComListHeader *)calloc(COMLISTHEADSZ,sizeof(ComListHeader));
  2524.     if(comlisthead_space == (ComListHeader *)NULL) {
  2525.       oops_message(OOPS_FATAL,line_num,NO_COL_NUM,
  2526.            "Cannot alloc space for common block header");
  2527.       return (ComListHeader *)NULL; /*NOTREACHED*/
  2528.     }
  2529.     comlistheadspace_bot = COMLISTHEADSZ;
  2530.   }
  2531.                 /* Slots are allocated from top down */
  2532.   return comlisthead_space + (--comlistheadspace_bot);
  2533. }
  2534.  
  2535.  
  2536. #endif /*T_ALLOC*/
  2537.  
  2538.  
  2539.         /* this routine allocates room in global stringspace
  2540.            (top down) for string s, and copies it there. */
  2541. char *
  2542. #if HAVE_STDC
  2543. new_global_string(char *s)
  2544. #else /* K&R style */
  2545. new_global_string(s)
  2546.     char *s;
  2547. #endif /* HAVE_STDC */
  2548. {
  2549.   static unsigned long glob_str_bot = 0;
  2550.   static char *glob_strspace;
  2551.  
  2552.   int count = strlen(s) + 1;    /* no. of chars needed including final nul */
  2553.  
  2554.   glob_strings_used += count;    /* keep track for -resource */
  2555.  
  2556.   if(glob_str_bot < count) {
  2557.     unsigned long numalloc = (count > STRSPACESZ? count: STRSPACESZ);
  2558.     glob_strspace = (char *)calloc(numalloc,sizeof(char));
  2559.     if(glob_strspace == (char *)NULL) {
  2560.       oops_message(OOPS_FATAL,line_num,NO_COL_NUM,
  2561.            "Cannot alloc space for global strings");
  2562.       return (char *)NULL; /*NOTREACHED*/
  2563.     }
  2564.     glob_str_bot = numalloc;
  2565.   }
  2566.  
  2567.   glob_str_bot -= count;    /*pre-decrement*/
  2568.   return strcpy(glob_strspace+glob_str_bot,s);
  2569. }/*new_global_string*/
  2570.  
  2571.         /* Allocate space for string s in local string space
  2572.            (bottom up), and copy it there. */
  2573. PRIVATE char *
  2574. #if HAVE_STDC
  2575. new_local_string(char *s)
  2576. #else /* K&R style */
  2577. new_local_string(s)
  2578.     char *s;
  2579. #endif /* HAVE_STDC */
  2580. {
  2581.   int count = strlen(s) + 1;    /* No. of chars needed including final nul */
  2582.   int orig_top = loc_str_top;
  2583.   loc_str_top += count;
  2584.   if(loc_str_top > STRSPACESZ) {
  2585.     StrSpace *new_loc_strspace;
  2586.     new_loc_strspace = (StrSpace *)malloc(sizeof(StrSpace));
  2587.     if(new_loc_strspace == (StrSpace *)NULL) {
  2588.       oops_message(OOPS_FATAL,line_num,NO_COL_NUM,
  2589.            "Cannot alloc space for local strings");
  2590.       return (char *)NULL; /*NOTREACHED*/
  2591.     }
  2592.     else {
  2593.       new_loc_strspace->next = (StrSpace *)NULL;
  2594.       curr_loc_strspace->next = new_loc_strspace;
  2595.     }
  2596.     curr_loc_strspace = curr_loc_strspace->next;
  2597.     extra_locstrspace += orig_top; /* Remember amount used so far */
  2598.     orig_top = 0;
  2599.     loc_str_top = count;
  2600.   }
  2601.   return strcpy(curr_loc_strspace->strspace+orig_top,s);
  2602. }/* new_local_string */
  2603.  
  2604. PRIVATE ParamInfo *
  2605. new_param_info(VOID)        /* Allocates space for parameter info field */
  2606. {
  2607.   if(param_info_space_top == PARAMINFOSPACESZ) {
  2608.     if(curr_paraminfospace->next == (ParamInfoSpace *)NULL) {
  2609.       ParamInfoSpace *new_paraminfospace;
  2610.       if( (new_paraminfospace = (ParamInfoSpace *)malloc(sizeof(ParamInfoSpace)))
  2611.      == (ParamInfoSpace *)NULL) {
  2612.     oops_message(OOPS_FATAL,line_num,NO_COL_NUM,
  2613.              "Cannot alloc space for parameter info");
  2614.     return (ParamInfo *)NULL;    /*NOTREACHED*/
  2615.       }
  2616.       else {
  2617.     new_paraminfospace->next =  (ParamInfoSpace *)NULL;
  2618.     curr_paraminfospace->next = new_paraminfospace;
  2619.       }
  2620.     }
  2621.     curr_paraminfospace = curr_paraminfospace->next;
  2622.     extra_paraminfospace += PARAMINFOSPACESZ;
  2623.     param_info_space_top = 0;
  2624.   }
  2625.   return curr_paraminfospace->paraminfospace + param_info_space_top++;
  2626.  
  2627. }
  2628.  
  2629. void
  2630. #if HAVE_STDC
  2631. free_textvec(char **p)        /*ARGSUSED*/
  2632. #else /* K&R style */
  2633. free_textvec(p)        /*ARGSUSED*/
  2634.      char **p;
  2635. #endif /* HAVE_STDC */
  2636. {
  2637.     /* No action necessary since all the space is freed in
  2638.        a lump at end of processing module */
  2639. }
  2640.  
  2641. char **
  2642. #if HAVE_STDC
  2643. new_textvec(int n)        /* Allocates space for array of n char ptrs */
  2644. #else /* K&R style */
  2645. new_textvec(n)        /* Allocates space for array of n char ptrs */
  2646.      int n;
  2647. #endif /* HAVE_STDC */
  2648. {
  2649.   int orig_top = ptrspace_top;
  2650.   ptrspace_top += n;
  2651.  
  2652.   if( ptrspace_top > PTRSPACESZ) {
  2653.     if(curr_ptrspace->next == (PtrSpace *)NULL) {
  2654.       PtrSpace *new_ptrspace;
  2655.       if( (new_ptrspace = (PtrSpace *)malloc(sizeof(PtrSpace)))
  2656.      == (PtrSpace *)NULL) {
  2657.     oops_message(OOPS_FATAL,line_num,NO_COL_NUM,
  2658.              "Cannot alloc space for pointers to text");
  2659.     return (char **)NULL; /*NOTREACHED*/
  2660.       }
  2661.       else {
  2662.     new_ptrspace->next = (PtrSpace *)NULL;
  2663.     curr_ptrspace->next = new_ptrspace;
  2664.       }
  2665.     }
  2666.     curr_ptrspace = curr_ptrspace->next;
  2667.     extra_ptrspace += orig_top;
  2668.     orig_top = 0;
  2669.     ptrspace_top = n;
  2670.   }
  2671.   return curr_ptrspace->ptrspace + orig_top;
  2672. }
  2673.  
  2674.                 /* Routine to allocate space for
  2675.                    a string containing source text
  2676.                    of a token. */
  2677.  
  2678. char *
  2679. #if HAVE_STDC
  2680. new_src_text_alloc(int size)
  2681.                           /* length counting nul */
  2682. #else /* K&R style */
  2683. new_src_text_alloc(size)
  2684.      int size;            /* length counting nul */
  2685. #endif /* HAVE_STDC */
  2686. {
  2687.   int orig_top = srctextspace_top;
  2688.   srctextspace_top += size;
  2689.  
  2690.   if(srctextspace_top > STRSPACESZ) {
  2691.     StrSpace *new_srctextspace;
  2692.     new_srctextspace = (StrSpace *)malloc(sizeof(StrSpace));
  2693.     if(new_srctextspace == (StrSpace *)NULL) {
  2694.       oops_message(OOPS_FATAL,line_num,col_num,
  2695.            "Cannot alloc space for token text");
  2696.       return (char *)NULL; /*NOTREACHED*/
  2697.     }
  2698.     else {
  2699.       new_srctextspace->next = (StrSpace *)NULL;
  2700.       curr_srctextspace->next = new_srctextspace;
  2701.     }
  2702.     curr_srctextspace = curr_srctextspace->next;
  2703.     extra_srctextspace += orig_top; /* Remember amount used so far */
  2704.     orig_top = 0;
  2705.     srctextspace_top = size;
  2706.   }
  2707.  
  2708.   return curr_srctextspace->strspace + orig_top;
  2709. }
  2710.  
  2711.                 /* Tokens that are 1 char long have their
  2712.                    src_text stored in this array, indexed
  2713.                    by their codes.  Avoids duplication of
  2714.                    strings, wasting space.
  2715.                  */
  2716. PRIVATE char onechar_text[2*(MAX_CHAR_CODE+1)];
  2717.  
  2718.                 /* Routine to get space for string
  2719.                    containing source text of token
  2720.                    and copy it to there.
  2721.                  */
  2722.  
  2723. char *
  2724. #if HAVE_STDC
  2725. new_src_text(char *s, int len)
  2726.                          /* string (final nul not needed) */
  2727.                          /* length not counting nul */
  2728. #else /* K&R style */
  2729. new_src_text(s,len)
  2730.      char *s;            /* string (final nul not needed) */
  2731.      int len;            /* length not counting nul */
  2732. #endif /* HAVE_STDC */
  2733. {
  2734.   int i;
  2735.   char *new_s;
  2736.                 /* If it is a single char, it goes
  2737.                    into the special array.  Otherwise
  2738.                    allocate space for it. */
  2739.   if(len <= 1)
  2740.     new_s = &onechar_text[s[0]*2];
  2741.   else
  2742.     new_s = new_src_text_alloc(len+1);
  2743.  
  2744.   for(i=0; i<len; i++)        /* copy string to new space */
  2745.     new_s[i] = s[i];
  2746.   new_s[i] = '\0';
  2747.  
  2748.   return new_s;
  2749. }
  2750.  
  2751.         /* Copy expr token src text into local stringspace. */
  2752.  
  2753. #define MAXTREETEXT (20*72+1)    /* Enough space for any f77 expression. */
  2754. PRIVATE char tree_text_space[MAXTREETEXT];
  2755.  
  2756. char *
  2757. #if HAVE_STDC
  2758. new_tree_text(Token *t)
  2759. #else /* K&R style */
  2760. new_tree_text(t)
  2761.      Token *t;
  2762. #endif /* HAVE_STDC */
  2763. {
  2764.   (void) cp_tree_src_text(tree_text_space, t, MAXTREETEXT-1);
  2765.   return new_local_string(tree_text_space);
  2766. }
  2767.  
  2768.  
  2769. PRIVATE TokenListHeader *
  2770. new_tokhead(VOID)
  2771. {
  2772.   if(token_head_space_top == TOKHEADSPACESZ) {
  2773.     if(curr_tokheadspace->next == (TokHeadSpace *)NULL) {
  2774.       TokHeadSpace *new_tokheadspace;
  2775.       if( (new_tokheadspace = (TokHeadSpace *)malloc(sizeof(TokHeadSpace)))
  2776.      == (TokHeadSpace *)NULL) {
  2777.     oops_message(OOPS_FATAL,line_num,NO_COL_NUM,
  2778.              "Cannot alloc space for token list header");
  2779.     return (TokenListHeader *)NULL;    /*NOTREACHED*/
  2780.       }
  2781.       else {
  2782.     new_tokheadspace->next =  (TokHeadSpace *)NULL;
  2783.     curr_tokheadspace->next = new_tokheadspace;
  2784.       }
  2785.     }
  2786.     curr_tokheadspace = curr_tokheadspace->next;
  2787.     extra_tokheadspace += TOKHEADSPACESZ;
  2788.     token_head_space_top = 0;
  2789.   }
  2790.   return curr_tokheadspace->tokheadspace + token_head_space_top++;
  2791. }
  2792.  
  2793. Token *
  2794. new_token(VOID)            /* Returns pointer to space for a token */
  2795. {
  2796.   if(token_space_top == TOKENSPACESZ) {
  2797.     /* When token space is used up, go to the next.  If none, then
  2798.        allocate a new one.  The memory is never deallocated, since
  2799.        it will likely be needed again later.  So token space structs
  2800.        are linked into a list. */
  2801.     if(curr_tokspace->next == (TokenSpace *)NULL) {
  2802.       TokenSpace *new_tokspace;
  2803.       if( (new_tokspace = (TokenSpace *)malloc(sizeof(TokenSpace)))
  2804.      == (TokenSpace *)NULL) {
  2805.     oops_message(OOPS_FATAL,line_num,NO_COL_NUM,
  2806.              "Cannot alloc space for tokens");
  2807.     return (Token *)NULL; /*NOTREACHED*/
  2808.       }
  2809.       else {
  2810.     new_tokspace->next =  (TokenSpace *)NULL;
  2811.     curr_tokspace->next = new_tokspace;
  2812.       }
  2813.     }
  2814.     curr_tokspace = curr_tokspace->next;
  2815.     extra_tokspace += TOKENSPACESZ; /* Keep track of how much for -resource */
  2816.     token_space_top = 0;
  2817.   }
  2818.   return curr_tokspace->tokenspace + token_space_top++;
  2819. }
  2820.  
  2821.  
  2822.     /* note_filename():  This routine is called by main prog to give
  2823.        symbol table routines access to current input file name, to be
  2824.        stored in function arg list headers and common list headers, for
  2825.        the use in diagnostic messages. Since filenames are from argv,
  2826.        they are permanent, so pointer is copied, not the string.
  2827.     */
  2828. void
  2829. #if HAVE_STDC
  2830. note_filename(char *s)
  2831. #else /* K&R style */
  2832. note_filename(s)
  2833.     char *s;
  2834. #endif /* HAVE_STDC */
  2835. {
  2836.     current_filename = s;
  2837.     top_filename = s;
  2838. }/* note_filename */
  2839.  
  2840. #ifdef DEBUG_EXPRTREES        /* Routines to print out expr tree src text */
  2841. void
  2842. print_src_text(t)
  2843.      Token *t;
  2844. {
  2845.   char textbuf[256];
  2846.   (void) cp_tok_src_text(textbuf,t,sizeof(textbuf)-1);
  2847.   fprintf(list_fd,"%s",textbuf);
  2848. }
  2849.  
  2850. void
  2851. print_expr_tree(t)
  2852.      Token *t;
  2853. {
  2854.   char textbuf[256];
  2855.   (void) cp_tree_src_text(textbuf,t,sizeof(textbuf)-1);
  2856.   fprintf(list_fd,"%s",textbuf);
  2857. }
  2858.  
  2859. void
  2860. print_expr_list(t)
  2861.      Token *t;
  2862. {
  2863.   char textbuf[256];
  2864.   (void) cp_list_src_text(textbuf,t,sizeof(textbuf)-1);
  2865.   fprintf(list_fd,"%s",textbuf);
  2866. }
  2867. #endif
  2868.  
  2869.  
  2870. void
  2871. #if HAVE_STDC
  2872. process_lists(int curmodhash)  /* Places pointer to linked list of arrays in
  2873.                   global symbol table */
  2874. #else /* K&R style */
  2875. process_lists(curmodhash)  /* Places pointer to linked list of arrays in
  2876.                   global symbol table */
  2877. #endif /* HAVE_STDC */
  2878.  
  2879. #if HAVE_STDC
  2880.                        /* current_module_hash from fortran.y */
  2881. #else /* K&R style */
  2882.     int curmodhash;    /* current_module_hash from fortran.y */
  2883. #endif /* HAVE_STDC */
  2884. {
  2885.     int i, h;
  2886.     unsigned long hnum;
  2887.     Gsymtab *curr_gsymt;
  2888.  
  2889.     Gsymtab *gsymt;
  2890.     TokenListHeader *head_ptr;
  2891.  
  2892.     if( (curr_gsymt=
  2893.          (curmodhash == -1) ? NULL:hashtab[curmodhash].glob_symtab)
  2894.        == NULL) {
  2895.       oops_message(OOPS_NONFATAL,NO_LINE_NUM,NO_COL_NUM,
  2896.           "module not in global symtab:");
  2897.       oops_tail(hashtab[curmodhash].name);
  2898.     }
  2899.     else {
  2900.       if(curr_gsymt->internal_entry) {/* protect ourself */
  2901.         if(misc_warn) {
  2902.           warning(NO_LINE_NUM,NO_COL_NUM,
  2903.             "entry point redefined as module");
  2904.           msg_tail(curr_gsymt->name);
  2905.           msg_tail(": previous definition overridden");
  2906.         }
  2907.         curr_gsymt->link.child_list = NULL;
  2908.       }
  2909.       curr_gsymt->internal_entry = FALSE;
  2910.     }
  2911.  
  2912.     for (i=0; i<loc_symtab_top; i++){
  2913.                 /* Skip things which are not true externals */
  2914.         if(loc_symtab[i].argument || loc_symtab[i].intrinsic ||
  2915.            loc_symtab[i].array_var)
  2916.               continue;
  2917.  
  2918.         head_ptr = loc_symtab[i].info.toklist;
  2919.  
  2920.         hnum=hash(loc_symtab[i].name);
  2921.         while(h=hnum%HASHSZ,hashtab[h].name != NULL
  2922.          && strcmp(hashtab[h].name,loc_symtab[i].name)!=0){
  2923.               hnum = rehash(hnum);      /* Resolve clashes */
  2924.         }
  2925.  
  2926.         switch (storage_class_of(loc_symtab[i].type)){
  2927.             case class_COMMON_BLOCK:
  2928.             if(head_ptr != NULL) {
  2929. if((gsymt=hashtab[h].com_glob_symtab) == NULL) {
  2930.     oops_message(OOPS_NONFATAL,NO_LINE_NUM,NO_COL_NUM,
  2931.          "common block not in global symtab:");
  2932.     oops_tail(loc_symtab[i].name);
  2933. }
  2934. else {
  2935.             Token *tok_ptr;
  2936.                         ComListHeader *c;
  2937.  
  2938.                 /* First we link up possibly multiple
  2939.                    declarations of the same common block
  2940.                    in this module into one big list */
  2941.                 while (tok_ptr = head_ptr->tokenlist,
  2942.                    (head_ptr = head_ptr->next) != NULL){
  2943.                 while(tok_ptr->next_token != NULL){
  2944.                     tok_ptr = tok_ptr->next_token;
  2945.                 }
  2946.                 tok_ptr->next_token = head_ptr->tokenlist;
  2947.             }
  2948.                 /* Original token list is in reverse order.
  2949.                    Reverse it so order is correct. */
  2950.             head_ptr = loc_symtab[i].info.toklist;
  2951.             head_ptr->tokenlist =
  2952.               reverse_tokenlist(head_ptr->tokenlist);
  2953.  
  2954.                 /* Keep a copy for use by makedecls */
  2955.             loc_symtab[i].src.toklist = head_ptr;
  2956.  
  2957.                 /* Now make it into array for global table */
  2958.                 c=make_com_array(head_ptr->tokenlist);
  2959.             c->module = curr_gsymt;
  2960.             c->filename = head_ptr->filename;
  2961.             c->topfile = top_filename;
  2962.             c->line_num = head_ptr->line_num;
  2963.             c->top_line_num = head_ptr->top_line_num;
  2964.             c->saved = global_save || loc_symtab[i].saved;
  2965.  
  2966.                 /* add names to com list */
  2967.             make_com_names(head_ptr->tokenlist,
  2968.                        c,gsymt->info.comlist);
  2969.  
  2970.                         c->next = gsymt->info.comlist;
  2971.             gsymt->info.comlist = c;
  2972.  
  2973.         /* Replace token list by comlist for check_mixed_common */
  2974.             loc_symtab[i].info.comlist = c;
  2975. }
  2976.             }/* end if(head_ptr != NULL) */
  2977.  
  2978.                 break;    /* end case class_COMMON_BLOCK */
  2979.  
  2980.  
  2981.             /* Are we inside a function or subroutine? */
  2982.             case class_VAR:
  2983.                if(loc_symtab[i].entry_point) {
  2984. if((gsymt=hashtab[h].glob_symtab) == NULL) {
  2985.     oops_message(OOPS_NONFATAL,NO_LINE_NUM,NO_COL_NUM,
  2986.     "subprog not in global symtab:");
  2987.     oops_tail(loc_symtab[i].name);
  2988. }
  2989. else {
  2990.                           ArgListHeader *a;
  2991.               int implied_type;
  2992.  
  2993.                 /* Make each token list into an array of
  2994.                    args for global table */
  2995.               while (head_ptr != NULL){
  2996.                  a=make_dummy_arg_array(head_ptr->tokenlist);
  2997.                  make_arg_names(head_ptr->tokenlist,
  2998.                        a,gsymt->info.arglist);
  2999.                  implied_type = get_type(&(loc_symtab[i]));
  3000.                  a->type = type_byte(
  3001.                      class_SUBPROGRAM,implied_type);
  3002.                  a->size = get_size(&(loc_symtab[i]),implied_type);
  3003.                  a->module = curr_gsymt;
  3004.                  a->filename = head_ptr->filename;
  3005.                  a->topfile = top_filename;
  3006.                  a->line_num = head_ptr->line_num;
  3007.                  a->top_line_num = head_ptr->top_line_num;
  3008.  
  3009.                  a->next = gsymt->info.arglist;
  3010.                  gsymt->info.arglist = a;
  3011.             /* store arglist in local symtab for project file */
  3012.                  loc_symtab[i].info.arglist = a;
  3013.                  head_ptr = head_ptr->next;
  3014.                   }/* end while (head_ptr != NULL) */
  3015.  
  3016.               if(loc_symtab[i].set_flag)
  3017.                      gsymt->set_flag = TRUE;
  3018.               if(loc_symtab[i].used_flag)
  3019.                      gsymt->used_flag = TRUE;
  3020.               if(loc_symtab[i].declared_external)
  3021.                  gsymt->declared_external = TRUE;
  3022.               if(loc_symtab[i].library_module)
  3023.                  gsymt->library_module = TRUE;
  3024.               gsymt->defined = TRUE;
  3025.               if(gsymt != curr_gsymt) {
  3026.                 gsymt->internal_entry = TRUE;
  3027.                 gsymt->link.module = curr_gsymt;
  3028.               }
  3029. }
  3030.             }/* end if(loc_symtab[i].entry_point) */
  3031.                 break; /* end case class_VAR */
  3032.  
  3033.                     case class_SUBPROGRAM:
  3034. if((gsymt=hashtab[h].glob_symtab) == NULL) {
  3035.     oops_message(OOPS_NONFATAL,NO_LINE_NUM,NO_COL_NUM,
  3036.     "subprog not in global symtab:");
  3037.     oops_tail(loc_symtab[i].name);
  3038. }
  3039. else {
  3040.                         ArgListHeader *a;
  3041.             int implied_type;
  3042.             while (head_ptr != NULL){
  3043.               if(head_ptr->external_decl || head_ptr->actual_arg)
  3044.                 a=make_arrayless_alist();
  3045.               else {
  3046.                 a=make_arg_array(head_ptr->tokenlist);
  3047.                 make_arg_names(head_ptr->tokenlist,
  3048.                        a,gsymt->info.arglist);
  3049.               }
  3050.               implied_type = get_type(&(loc_symtab[i]));
  3051.               a->type = type_byte(
  3052.                      class_SUBPROGRAM,implied_type);
  3053.               a->size = get_size(&(loc_symtab[i]),implied_type);
  3054.               a->module = curr_gsymt;
  3055.               a->filename = head_ptr->filename;
  3056.               a->topfile = top_filename;
  3057.               a->line_num = head_ptr->line_num;
  3058.               a->top_line_num = head_ptr->top_line_num;
  3059.               a->external_decl = head_ptr->external_decl;
  3060.               a->actual_arg = head_ptr->actual_arg;
  3061.  
  3062.               a->next = gsymt->info.arglist;
  3063.               gsymt->info.arglist = a;
  3064.         /* put arglist into local symtab for project file use */
  3065.               loc_symtab[i].info.arglist = a;
  3066.               head_ptr = head_ptr->next;
  3067.                 }
  3068.             if(loc_symtab[i].used_flag)
  3069.                     gsymt->used_flag = TRUE;
  3070. if(debug_glob_symtab)
  3071. (void)fprintf(list_fd,"\nmodule %s local used=%d global used=%d",
  3072. gsymt->name,loc_symtab[i].used_flag,gsymt->used_flag);
  3073. }
  3074.                 /* Add this guy to linked list of children,
  3075.                    unless never actually used. */
  3076.             if(loc_symtab[i].used_flag) {
  3077.               ChildList *node=
  3078.                 (ChildList *)calloc(1,sizeof(ChildList));
  3079.               node->child = gsymt;
  3080.               node->next = curr_gsymt->link.child_list;
  3081.               curr_gsymt->link.child_list = node;
  3082.             }
  3083.  
  3084.             break;/* end case class_SUBPROGRAM*/
  3085.  
  3086.                     case class_NAMELIST:
  3087.             if(head_ptr != NULL) {
  3088.               Token *tok_ptr;
  3089.  
  3090.                 /* Link up possibly multiple
  3091.                    declarations of the same namelist
  3092.                    in this module into one big list */
  3093.               while (tok_ptr = head_ptr->tokenlist,
  3094.                    (head_ptr = head_ptr->next) != NULL){
  3095.                 while(tok_ptr->next_token != NULL){
  3096.                     tok_ptr = tok_ptr->next_token;
  3097.                 }
  3098.                 tok_ptr->next_token = head_ptr->tokenlist;
  3099.               }
  3100.                 /* Original token lists are in reverse order.
  3101.                    Reverse it so order is correct. */
  3102.             head_ptr = loc_symtab[i].info.toklist;
  3103.             head_ptr->tokenlist =
  3104.               reverse_tokenlist(head_ptr->tokenlist);
  3105.             }
  3106.                 /* Keep a copy for use by makedecls */
  3107.             loc_symtab[i].src.toklist = head_ptr;
  3108.  
  3109.  
  3110.             break;/* end case class_NAMELIST*/
  3111.         }/* end switch */
  3112.  
  3113.         }/* end for (i=0; i<loc_symtab_top; i++) */
  3114.  
  3115. }/* process_lists */
  3116.  
  3117.  
  3118. void
  3119. #if HAVE_STDC
  3120. ref_array(Token *id, Token *subscrs)   /* Array reference: install in symtab */
  3121. #else /* K&R style */
  3122. ref_array(id,subscrs)   /* Array reference: install in symtab */
  3123.     Token *id, *subscrs;
  3124. #endif /* HAVE_STDC */
  3125. {
  3126.     int h=id->value.integer;
  3127.     Lsymtab *symt=hashtab[h].loc_symtab;
  3128.  
  3129.                 /* Restore subscripts to original order */
  3130.     subscrs->next_token = reverse_tokenlist(subscrs->next_token);
  3131.  
  3132.     if(symt == NULL){
  3133.        oops_message(OOPS_NONFATAL,line_num,NO_COL_NUM,
  3134.                "undeclared variable has dim info:");
  3135.        oops_tail(hashtab[h].name);
  3136.        symt = install_local(h,type_UNDECL,class_VAR);
  3137.     }
  3138.     else{    /* check that subscrs match dimension info */
  3139.  
  3140.  
  3141.       if(arg_count(subscrs->next_token)!=array_dims(symt->info.array_dim)){
  3142.           syntax_error(subscrs->line_num,subscrs->col_num,
  3143.             "array");
  3144.           msg_tail(symt->name);
  3145.           msg_tail("referenced with wrong no. of subscripts");
  3146.       }
  3147.     }
  3148.  
  3149. }/* ref_array */
  3150.  
  3151. void
  3152. #if HAVE_STDC
  3153. ref_namelist(Token *id, int stmt_class)
  3154. #else /* K&R style */
  3155. ref_namelist(id,stmt_class)
  3156.      Token *id;
  3157.      int stmt_class;
  3158. #endif /* HAVE_STDC */
  3159. {
  3160.     Token *t;
  3161.     TokenListHeader *toklist;
  3162.     int h=id->value.integer;
  3163.     Lsymtab *symt=hashtab[h].loc_symtab;
  3164.     if(symt == NULL){
  3165.        oops_message(OOPS_NONFATAL,line_num,NO_COL_NUM,
  3166.             "undeclared identifier is a namelist:");
  3167.        oops_tail(hashtab[h].name);
  3168.        symt = install_local(h,type_NAMELIST,class_NAMELIST);
  3169.        symt->info.toklist = NULL;
  3170.     }
  3171.  
  3172.             /* Go thru token list of namelist variables,
  3173.                setting flags appropriately. */
  3174.     toklist = symt->info.toklist;
  3175.     if (toklist != NULL){
  3176.         t = toklist->tokenlist;
  3177.         while(t != NULL){
  3178.             if(stmt_class == tok_READ)
  3179.           use_lvalue(t);
  3180.         else
  3181.           use_variable(t);
  3182.         t = t->next_token;
  3183.         }
  3184.     }
  3185. }
  3186.  
  3187. void
  3188. #if HAVE_STDC
  3189. ref_variable(Token *id)    /* Variable reference: install in symtab */
  3190. #else /* K&R style */
  3191. ref_variable(id)    /* Variable reference: install in symtab */
  3192.     Token *id;
  3193. #endif /* HAVE_STDC */
  3194. {
  3195.     int h=id->value.integer;
  3196.  
  3197.     if( hashtab[h].loc_symtab == NULL) {
  3198.        (void) install_local(h,type_UNDECL,class_VAR);
  3199.     }
  3200.  
  3201. }/*ref_variable*/
  3202.  
  3203.         /* this guy reverses a tokenlist and returns a pointer
  3204.            to the new head. */
  3205. PRIVATE Token *
  3206. #if HAVE_STDC
  3207. reverse_tokenlist(Token *t)
  3208. #else /* K&R style */
  3209. reverse_tokenlist(t)
  3210.     Token *t;
  3211. #endif /* HAVE_STDC */
  3212. {
  3213.     Token *curr,*next,*temp;
  3214.  
  3215.     if(t == NULL)
  3216.         return t;
  3217.  
  3218.     curr = t;
  3219.     next = curr->next_token;
  3220.     while(next != NULL) {
  3221.         temp = next->next_token;
  3222.         next->next_token = curr;
  3223.         curr = next;
  3224.         next = temp;
  3225.     }
  3226.     t->next_token = NULL;        /* former head is now tail */
  3227.     return curr;            /* curr now points to new head */
  3228. }
  3229.  
  3230. void
  3231. #if HAVE_STDC
  3232. save_com_block(Token *id)    /* Process SAVEing of a common block */
  3233.                   /* N.B. Legality checking deferred to END */
  3234. #else /* K&R style */
  3235. save_com_block(id)    /* Process SAVEing of a common block */
  3236.     Token *id;    /* N.B. Legality checking deferred to END */
  3237. #endif /* HAVE_STDC */
  3238. {
  3239.     int h=id->value.integer;
  3240.     Lsymtab *symt;
  3241.  
  3242.             /* N.B. SAVE does not create a global table entry */
  3243.     if( (symt = hashtab[h].com_loc_symtab) == NULL){
  3244.        symt = install_local(h,type_COMMON_BLOCK,class_COMMON_BLOCK);
  3245.        symt->info.toklist = NULL;
  3246.     }
  3247.  
  3248.     if(symt->saved) {
  3249.       syntax_error(id->line_num,id->col_num,
  3250.                "redundant SAVE declaration");
  3251.     }
  3252.     else
  3253.       symt->saved = TRUE;
  3254. }
  3255.  
  3256. void
  3257. #if HAVE_STDC
  3258. save_variable(Token *id)    /* Process SAVEing of a variable */
  3259.                   /* N.B. Legality checking deferred to END */
  3260. #else /* K&R style */
  3261. save_variable(id)    /* Process SAVEing of a variable */
  3262.     Token *id;    /* N.B. Legality checking deferred to END */
  3263. #endif /* HAVE_STDC */
  3264. {
  3265.     int h=id->value.integer;
  3266.     Lsymtab *symt;
  3267.  
  3268.     if( (symt=hashtab[h].loc_symtab) == NULL) {
  3269.        symt = install_local(h,type_UNDECL,class_VAR);
  3270.     }
  3271.  
  3272.     if(symt->saved) {
  3273.       syntax_error(id->line_num,id->col_num,
  3274.                "redundant SAVE declaration");
  3275.     }
  3276.     else {        /* set flags for all equivalenced vars */
  3277.       Lsymtab *equiv=symt;
  3278.       do{
  3279.         equiv->saved = TRUE;
  3280.         equiv = equiv->equiv_link;
  3281.       } while(equiv != symt);
  3282.     }
  3283. }
  3284.  
  3285.     /* Following routine sets the implicit typing of characters in
  3286.        range c1 to c2 to the given type. */
  3287. void
  3288. #if HAVE_STDC
  3289. set_implicit_type(int type, long int size, char *len_text, int c1, int c2)
  3290.                      /* Data type of IMPLICIT declaration */
  3291.                           /* Type size or size_DEFAULT if not given */
  3292.                            /* Source text of length spec */
  3293.                        /* First character of range */
  3294.                        /* Last character of range */
  3295. #else /* K&R style */
  3296. set_implicit_type(type,size,len_text,c1,c2)
  3297.     int type;        /* Data type of IMPLICIT declaration */
  3298.         long size;        /* Type size or size_DEFAULT if not given */
  3299.     char *len_text;        /* Source text of length spec */
  3300.     int c1;            /* First character of range */
  3301.     int c2;            /* Last character of range */
  3302. #endif /* HAVE_STDC */
  3303. {
  3304.     int c;
  3305. #ifdef ALLOW_DOLLARSIGNS
  3306.       if(c1 == '$')  c1 = 'Z'+1;
  3307.       if(c2 == '$')  c2 = 'Z'+1;
  3308. #endif
  3309. #ifdef ALLOW_UNDERSCORES
  3310.       if(c1 == '_')  c1 = 'Z'+2;
  3311.       if(c2 == '_')  c2 = 'Z'+2;
  3312. #endif
  3313.     if(c2 < c1) {
  3314.         yyerror("IMPLICIT range must be in alphabetical order");
  3315.     }
  3316.     else {
  3317.         /* Fill in the lookup table for the given range of chars */
  3318.       for(c=c1; c<=c2; c++) {
  3319.         implicit_type[c-'A'] = type;
  3320.         implicit_size[c-'A'] = size;
  3321.         implicit_len_text[c-'A'] = len_text;
  3322.       }
  3323.     }
  3324. }/*set_implicit_type*/
  3325.  
  3326.  
  3327.         /* Finish processing statement function.
  3328.            Clears all used-before-set flags of ordinary
  3329.            variables. Reason: statement functions are processed
  3330.            like assignment to an array element, setting ubs flags.
  3331.            At this point, no valid setting of ubs flags should
  3332.            be possible, so clearing them will elim false messages.*/
  3333. void
  3334. #if HAVE_STDC
  3335. stmt_function_stmt(Token *id)            /* ARGSUSED0 */
  3336.                            /* Not used at present */
  3337. #else /* K&R style */
  3338. stmt_function_stmt(id)            /* ARGSUSED0 */
  3339.      Token *id;            /* Not used at present */
  3340. #endif /* HAVE_STDC */
  3341. {
  3342.     int i;
  3343.     for(i=0; i<loc_symtab_top; i++) {
  3344.     if(storage_class_of(loc_symtab[i].type) == class_VAR &&
  3345.        ! loc_symtab[i].parameter )
  3346.       loc_symtab[i].used_before_set = FALSE;
  3347.     }
  3348. }/*stmt_function_stmt(id)*/
  3349.  
  3350. char *
  3351. #if HAVE_STDC
  3352. token_name(Token t)
  3353. #else /* K&R style */
  3354. token_name(t)
  3355.     Token t;
  3356. #endif /* HAVE_STDC */
  3357. {
  3358.     return hashtab[t.value.integer].name;
  3359. }/*token_name*/
  3360.  
  3361.  
  3362.  
  3363.  
  3364. void
  3365. #if HAVE_STDC
  3366. use_actual_arg(Token *id)    /* like use_lvalue except does not set assigned_flag */
  3367. #else /* K&R style */
  3368. use_actual_arg(id)    /* like use_lvalue except does not set assigned_flag */
  3369.     Token *id;
  3370. #endif /* HAVE_STDC */
  3371. {
  3372.     int h=id->value.integer;
  3373.     Lsymtab *symt;
  3374.  
  3375.     if((symt=hashtab[h].loc_symtab) == NULL) {
  3376.         symt = install_local(h,type_UNDECL,class_VAR);
  3377.     }
  3378.     else {
  3379.             /* If an external other than an intrinsic, set up
  3380.                tokenlist for "call".  If intrinsic, check
  3381.                legality of this usage.) */
  3382.       if(storage_class_of(symt->type) == class_SUBPROGRAM) {
  3383.         if(symt->intrinsic) {
  3384.           IntrinsInfo *defn = symt->info.intrins_info;
  3385.           if( !(symt->declared_intrinsic) ) {
  3386.         if(misc_warn) {
  3387.           warning(id->line_num,id->col_num,
  3388.                 defn->name);
  3389.           msg_tail("not declared INTRINSIC");
  3390.         }
  3391.           }
  3392.           if( (defn->intrins_flags&I_NOTARG) ) {
  3393.         syntax_error(id->line_num,id->col_num,
  3394.                 defn->name);
  3395.         msg_tail("intrinsic function cannot be a subprogram argument");
  3396.           }
  3397.         }
  3398.         else {        /* External subprogram as actual arg */
  3399.           TokenListHeader *TH_ptr;
  3400.           TH_ptr= make_TL_head(id);
  3401.  
  3402.           TH_ptr->actual_arg = TRUE;
  3403.           TH_ptr->next = symt->info.toklist;
  3404.           symt->info.toklist = TH_ptr;
  3405.         }
  3406.       }
  3407.     }
  3408.  
  3409.     {        /* set flags for all equivalenced vars */
  3410.       Lsymtab *equiv=symt;
  3411.       do{
  3412.     equiv->set_flag = TRUE;
  3413.     equiv = equiv->equiv_link;
  3414.       } while(equiv != symt);
  3415.     }
  3416.  
  3417. }/*use_actual_arg*/
  3418.  
  3419.  
  3420. PRIVATE void
  3421. #if HAVE_STDC
  3422. use_function_arg(Token *id)    /* Like use_variable but invokes use_actual_arg
  3423.                if id is an external (subprogram) passed as
  3424.                arg of a function. This routine is used when
  3425.                pure_functions flag is set. */
  3426. #else /* K&R style */
  3427. use_function_arg(id)    /* Like use_variable but first invokes use_actual_arg
  3428.                only if id is an external (subprogram) passed as
  3429.                arg of a function. This routine is used when
  3430.                pure_functions flag is set. */
  3431.     Token *id;
  3432. #endif /* HAVE_STDC */
  3433. {
  3434.     int h=id->value.integer;
  3435.     Lsymtab *symt;
  3436.  
  3437.     if( (symt=hashtab[h].loc_symtab) == NULL) {
  3438.        symt = install_local(h,type_UNDECL,class_VAR);
  3439.     }
  3440.  
  3441.     if(storage_class_of(symt->type) == class_SUBPROGRAM)
  3442.       use_actual_arg(id);
  3443.  
  3444.     use_variable(id);
  3445.  
  3446. }/*use_function_arg*/
  3447.  
  3448. void
  3449. #if HAVE_STDC
  3450. use_implied_do_index(Token *id)
  3451. #else /* K&R style */
  3452. use_implied_do_index(id)
  3453.     Token *id;
  3454. #endif /* HAVE_STDC */
  3455. {
  3456.         /* Like use_lvalue and use_variable but clears ubs flag.
  3457.                This is because we cannot handle used-before-set
  3458.            properly in this case, and the odds are that ubs
  3459.            was set in the preceding I/O list. */
  3460.     int h=id->value.integer;
  3461.     Lsymtab *symt;
  3462.  
  3463.     use_lvalue(id);
  3464.     use_variable(id);
  3465.     symt=hashtab[h].loc_symtab;
  3466.  
  3467.     symt->used_before_set = FALSE;
  3468. }/*use_implied_do_index*/
  3469.  
  3470.  
  3471.     /* use_io_keyword handles keyword=value fields in i/o control lists */
  3472.  
  3473. #include "iokeywds.h"
  3474.  
  3475. void
  3476. #if HAVE_STDC
  3477. use_io_keyword(Token *keyword, Token *value, int stmt_class)
  3478. #else /* K&R style */
  3479. use_io_keyword(keyword,value,stmt_class)
  3480.      Token *keyword,*value;
  3481.      int stmt_class;
  3482. #endif /* HAVE_STDC */
  3483. {
  3484.     int i, k, stmt_flag=0, type_flag, setit,useit;
  3485.     int hkey=keyword->value.integer;
  3486.     extern int io_internal_file, io_list_directed;/* shared with fortran.y */
  3487.  
  3488.         /* Convert statement_class (a token class) into
  3489.            a bit flag compatible with io_keywords table. */
  3490.     for(i=0; i<NUM_IO_STMTS; i++) {
  3491.     if(local_class[i].stmt_class == stmt_class) {
  3492.         stmt_flag = local_class[i].stmt_flag;
  3493.         break;
  3494.     }
  3495.     }
  3496.     if(stmt_flag == 0) {
  3497.       oops_message(OOPS_NONFATAL,keyword->line_num,keyword->col_num,
  3498.     "not an i/o statement class:");
  3499.       (void)fprintf(stderr,"%d",stmt_class);
  3500.       return;
  3501.     }
  3502.         /* Convert value datatype into
  3503.            a bit flag compatible with io_keywords table.
  3504.            Note that '*' is handled by using type_UNDECL */
  3505.     if(value->class == '*')
  3506.     type_flag = STAR;
  3507.     else
  3508.     type_flag = (1<<datatype_of(value->TOK_type));
  3509.  
  3510.                 /* Look up keyword in table*/
  3511.     k = find_io_keyword(hashtab[hkey].name);
  3512.  
  3513.         /* Not found or nonstandard: issue warning.  Note
  3514.            that not-found is also nonstandard.  All nonstandard
  3515.            I/O keywds are VMS extensions, warn if allow_vms_io=0
  3516.          */
  3517.     if(io_keywords[k].nonstandard
  3518. #ifdef ALLOW_VMS_IO /* special VMS case: OPEN(...,NAME=str,...) */
  3519.        || (io_keywords[k].special && stmt_flag==OP)
  3520. #endif /*ALLOW_VMS_IO*/
  3521.        ) {
  3522.         /* If nonstandard and -f77 flag given, issue warning */
  3523.     if(f77_vms_io) {
  3524.       nonstandard(keyword->line_num,keyword->col_num);
  3525.     }
  3526.  
  3527.  
  3528.     if(io_keywords[k].name == NULL) {
  3529.         if(f77_vms_io) {
  3530.           /* abbrev warning if nonstd message given */
  3531.         msg_tail(": unrecognized keyword");
  3532.         }
  3533.         else {
  3534.           if(misc_warn) {
  3535.         warning(keyword->line_num,keyword->col_num,
  3536.             "Unrecognized keyword");
  3537.           }
  3538.         }
  3539.         if(f77_vms_io || misc_warn) {
  3540.           msg_tail(hashtab[hkey].name);
  3541.           msg_tail("--  Ftnchek may process incorrectly");
  3542.         }
  3543.     }
  3544.     }
  3545.  
  3546.     /* If label expected, switch integer const to label */
  3547.     if( (LAB & io_keywords[k].allowed_types)
  3548.        &&  (type_flag == INT && is_true(LIT_CONST,value->TOK_flags))) {
  3549.     type_flag = LAB;
  3550.     }
  3551.  
  3552.     /*  Now check it out */
  3553.  
  3554.  
  3555.         /* Check if keyword is allowed with statement */
  3556.  
  3557.     if(!(stmt_flag & io_keywords[k].allowed_stmts)) {
  3558.     syntax_error(keyword->line_num,keyword->col_num,
  3559.              "keyword illegal in this context");
  3560.     return;
  3561.     }
  3562.  
  3563.         /* Check if the type is OK */
  3564.  
  3565.     if( !(type_flag & io_keywords[k].allowed_types) ) {
  3566.     syntax_error(value->line_num,value->col_num,
  3567.              "control specifier is incorrect type");
  3568.     return;
  3569.     }
  3570.  
  3571.  
  3572.     /* Now handle usage */
  3573.  
  3574.                 /* internal file?: WRITE(UNIT=str,...) */
  3575.     if(stmt_flag == WR && type_flag == CHR
  3576.         && io_keywords[k].allowed_types == UID) {
  3577.     setit = TRUE;
  3578.     useit = FALSE;
  3579.     }
  3580.                 /* INQUIRE: set it if inquire_set flag true */
  3581.     else if(stmt_flag == INQ && io_keywords[k].inquire_set) {
  3582.     setit = TRUE;
  3583.     useit = FALSE;
  3584.     }
  3585.      /* otherwise use use/set flags in table */
  3586.     else {
  3587.     useit = io_keywords[k].implies_use;
  3588.     setit = io_keywords[k].implies_set;
  3589.     }
  3590.  
  3591.                 /* Keep note if format is '*' */
  3592.     if(value->class == '*' && io_keywords[k].allowed_types == FID ) {
  3593.       io_list_directed = TRUE;
  3594.     }
  3595.  
  3596.             /* Handle NML=namelist */
  3597.     if(type_flag == NML){
  3598.       ref_namelist(value,stmt_class);
  3599.     }
  3600.             /* Update usage status if a variable. */
  3601.     if( is_true(ID_EXPR,value->TOK_flags)) {
  3602.     if(useit) {
  3603.         use_variable(value);
  3604.     }
  3605.     if(setit) {
  3606.         use_lvalue(value);
  3607.     }
  3608.         /* Character variable as unit id = internal file */
  3609.     if(type_flag == CHR && io_keywords[k].allowed_types == UID) {
  3610.       io_internal_file = TRUE;
  3611.     }
  3612.     }
  3613.     else if(setit) {        /* if value is set, must be an lvalue */
  3614.         syntax_error(value->line_num,value->col_num,
  3615.              "variable required");
  3616.         return;
  3617.     }
  3618. }
  3619.  
  3620.  
  3621.         /* Handle VMS OPEN keywords that have no =value */
  3622. void
  3623. #if HAVE_STDC
  3624. use_special_open_keywd(Token *id)
  3625. #else /* K&R style */
  3626. use_special_open_keywd(id)
  3627.      Token *id;
  3628. #endif /* HAVE_STDC */
  3629. {
  3630. #ifdef ALLOW_VMS_IO
  3631.   int i;
  3632.   char *id_name= hashtab[id->value.integer].name;
  3633.  
  3634.   for(i=0; i<NUM_SPECIAL_OPEN_KEYWDS; i++) {
  3635.     if(strcmp(id_name,special_open_keywds[i]) == 0) {
  3636.                 /* found: report nonstandard if requested */
  3637.       if(f77_vms_io)
  3638.     nonstandard(id->line_num,id->col_num);
  3639.       return;
  3640.     }
  3641.   }
  3642. #endif/*ALLOW_VMS_IO*/
  3643.                 /* not found or not VMS: report error */
  3644.   syntax_error(id->line_num,id->col_num,
  3645.            "Illegal control-list item");
  3646. }
  3647.  
  3648. PRIVATE void
  3649. #if HAVE_STDC
  3650. use_len_arg(Token *id)        /* Set the use-flag of arg to intrinsic LEN. */
  3651. #else /* K&R style */
  3652. use_len_arg(id)        /* Set the use-flag of arg to intrinsic LEN. */
  3653.     Token *id;
  3654. #endif /* HAVE_STDC */
  3655. {
  3656.     int h=id->value.integer;
  3657.     Lsymtab *symt;
  3658.  
  3659.     if( (symt=hashtab[h].loc_symtab) == NULL) {
  3660.        symt = install_local(h,type_UNDECL,class_VAR);
  3661.     }
  3662.  
  3663.     {        /* set flags for all equivalenced vars.  Do not set
  3664.            the used-before-set flag since LEN argument does
  3665.            not need to be defined. */
  3666.       Lsymtab *equiv=symt;
  3667.       do{
  3668.     equiv->used_flag = TRUE;
  3669.     equiv = equiv->equiv_link;
  3670.       } while(equiv != symt);
  3671.     }
  3672.  
  3673. }/*use_len_arg*/
  3674.  
  3675. void
  3676. #if HAVE_STDC
  3677. use_lvalue(Token *id)    /* handles scalar lvalue */
  3678. #else /* K&R style */
  3679. use_lvalue(id)    /* handles scalar lvalue */
  3680.     Token *id;
  3681. #endif /* HAVE_STDC */
  3682. {
  3683.     int h=id->value.integer;
  3684.     Lsymtab *symt;
  3685.     if((symt=hashtab[h].loc_symtab) == NULL) {
  3686.         symt = install_local(h,type_UNDECL,class_VAR);
  3687.     }
  3688.     else {
  3689.       /*   check match to previous invocations and update  */
  3690.     }
  3691.     {        /* set flags for all equivalenced vars */
  3692.       Lsymtab *equiv=symt;
  3693.       do{
  3694.     equiv->set_flag = TRUE;
  3695.     equiv->assigned_flag = TRUE;
  3696.     equiv = equiv->equiv_link;
  3697.       } while(equiv != symt);
  3698.     }
  3699.  
  3700. }/*use_lvalue*/
  3701.  
  3702.  
  3703.  
  3704. void                    /* Process data_constant_value & data_repeat_factor */
  3705. #if HAVE_STDC
  3706. use_parameter(Token *id)
  3707. #else /* K&R style */
  3708. use_parameter(id)
  3709.     Token *id;
  3710. #endif /* HAVE_STDC */
  3711. {
  3712.     int h=id->value.integer;
  3713.     Lsymtab *symt;
  3714.  
  3715.     if( (symt=hashtab[h].loc_symtab) == NULL) {
  3716.        symt = install_local(h,type_UNDECL,class_VAR);
  3717.     }
  3718.     if(! symt->parameter) {
  3719.         syntax_error(id->line_num,id->col_num,
  3720.             "must be a parameter");
  3721.         symt->parameter = TRUE;
  3722.     }
  3723.  
  3724.     if(! symt->set_flag) {
  3725.        symt->used_before_set = TRUE;
  3726.     }
  3727.     symt->used_flag = TRUE;
  3728.  
  3729. }/*use_parameter*/
  3730.  
  3731.  
  3732. void
  3733. #if HAVE_STDC
  3734. use_variable(Token *id)        /* Set the use-flag of variable. */
  3735. #else /* K&R style */
  3736. use_variable(id)        /* Set the use-flag of variable. */
  3737.     Token *id;
  3738. #endif /* HAVE_STDC */
  3739. {
  3740.     int h=id->value.integer;
  3741.     Lsymtab *symt;
  3742.  
  3743.     if( (symt=hashtab[h].loc_symtab) == NULL) {
  3744.        symt = install_local(h,type_UNDECL,class_VAR);
  3745.     }
  3746.  
  3747.     {        /* set flags for all equivalenced vars */
  3748.       Lsymtab *equiv=symt;
  3749.       do{
  3750.     if(! equiv->set_flag) {
  3751.        equiv->used_before_set = TRUE;
  3752.     }
  3753.     equiv->used_flag = TRUE;
  3754.     equiv = equiv->equiv_link;
  3755.       } while(equiv != symt);
  3756.     }
  3757.  
  3758. }/*use_variable*/
  3759.  
  3760.  
  3761. /*  End of symtab.c */
  3762.  
  3763. /*
  3764.  
  3765.  II. Hash
  3766.  
  3767. */
  3768.  
  3769. /*    hash.c:
  3770.      performs a hash function
  3771.  
  3772. This was formerly a separate file.
  3773.  
  3774. */
  3775.  
  3776. extern int sixclash;    /* flag to check clashes in 1st 6 chars of name */
  3777.  
  3778. unsigned long
  3779. #if HAVE_STDC
  3780. hash(char *s)
  3781. #else /* K&R style */
  3782. hash(s)
  3783.     char *s;
  3784. #endif /* HAVE_STDC */
  3785. {
  3786.     unsigned long sum = 0, wd;
  3787.     int i = 0,j;
  3788.  
  3789.     int n = strlen(s);
  3790.     if(sixclash && n > 6) n = 6;
  3791.  
  3792.     while (i < n) {
  3793.          wd = 0;
  3794.          for(j=1; j <= sizeof(long) && i < n; i++,j++) {
  3795.             wd += (unsigned long)(s[i] & 0xff) << (sizeof(long) - j) * 8;}
  3796.  
  3797.     sum ^= wd;}
  3798.     return sum;
  3799. }
  3800.  
  3801.         /* Same as hash() but always uses full length of keyword.
  3802.            To keep the keyword table clash-free on any machine,
  3803.            packs only 4 bytes per word even if long is bigger */
  3804. PRIVATE unsigned long
  3805. #if HAVE_STDC
  3806. kwd_hash(char *s)
  3807. #else /* K&R style */
  3808. kwd_hash(s)
  3809.     char *s;
  3810. #endif /* HAVE_STDC */
  3811. {
  3812.     unsigned long sum = 0, wd;
  3813.     int i = 0,j;
  3814.  
  3815.     int n = strlen(s);
  3816.  
  3817.     while (i < n) {
  3818.          wd = 0;
  3819.          for(j=1; j <= 4 && i < n; i++,j++) {
  3820.             wd += (unsigned long)(s[i] & 0xff) << (4 - j) * 8;}
  3821.  
  3822.     sum ^= wd;}
  3823.     return sum;
  3824. }
  3825.  
  3826.  
  3827.  
  3828. /*    rehash.c
  3829.         performs a rehash for resolving clashes.
  3830. */
  3831.  
  3832. #ifdef COUNT_REHASHES
  3833. unsigned long rehash_count=0;
  3834. #endif
  3835.  
  3836. unsigned long
  3837. #if HAVE_STDC
  3838. rehash(long unsigned int hnum)
  3839. #else /* K&R style */
  3840. rehash(hnum)
  3841.     unsigned long hnum;
  3842. #endif /* HAVE_STDC */
  3843. {
  3844. #ifdef COUNT_REHASHES
  3845.     rehash_count++;
  3846. #endif
  3847.     return hnum+1;
  3848. }
  3849.  
  3850.  
  3851. /*  End of hash */
  3852.  
  3853.  
  3854. /*
  3855.  
  3856. III. Intrins
  3857.  
  3858. */
  3859.  
  3860. /* intrinsic.c:
  3861.  
  3862.     Handles datatyping of intrinsic functions.
  3863. */
  3864.  
  3865.  
  3866.     /* File intrinsic.h contains information from Table 5, pp. 15-22
  3867.        to 15-25 of the standard.  Note: num_args == -1 means 1 or 2 args,
  3868.        num_args == -2 means 2 or more args.  Value of arg_type is the OR
  3869.        of all allowable types (I, R, etc. as defined above).  Value of
  3870.        result_type is type returned by function (type_INTEGER, etc.).
  3871.        If result_type is type_GENERIC, function type is same as arg type.
  3872.     */
  3873.  
  3874.  
  3875. PRIVATE IntrinsInfo intrinsic[]={
  3876. #include "intrins.h"
  3877. };
  3878.  
  3879. #define NUM_INTRINSICS (sizeof(intrinsic)/sizeof(intrinsic[0]))
  3880.  
  3881. #define EMPTY 255
  3882.  
  3883. PRIVATE unsigned char intrins_hashtab[INTRINS_HASHSZ];
  3884.  
  3885. /*    init_intrins_hashtab:
  3886.                  Initializes the intrinsic hash table by clearing it to EMPTY
  3887.                  and then hashes all the intrinsic names into the table.
  3888. */
  3889.  
  3890. unsigned long
  3891. init_intrins_hashtab(VOID)
  3892. {
  3893.     unsigned i,h;
  3894.     unsigned long hnum;
  3895.     unsigned long numclashes=0;
  3896.  
  3897.     for(h=0;h<INTRINS_HASHSZ;h++) {
  3898.            intrins_hashtab[h] = EMPTY;
  3899.     }
  3900.     for(i=0; i < NUM_INTRINSICS; i++) {
  3901.        hnum = kwd_hash(intrinsic[i].name);
  3902.        while(h=hnum%INTRINS_HASHSZ, intrins_hashtab[h] != EMPTY) {
  3903.         hnum = rehash(hnum);
  3904.         numclashes++;
  3905.        }
  3906.        intrins_hashtab[h] = i;
  3907.     }
  3908.     return numclashes;
  3909. }
  3910.  
  3911.  
  3912.         /* Function called by main to alter intrinsic table for
  3913.            user-selected options respecting RAND and IARGC.
  3914.          */
  3915. void
  3916. #if HAVE_STDC
  3917. set_intrinsic_options(int option)
  3918. #else /* K&R style */
  3919. set_intrinsic_options(option)
  3920.      int option;
  3921. #endif /* HAVE_STDC */
  3922. {
  3923.                 /* RAND and IRAND use tens digit */
  3924.     set_intrinsic_numargs("RAND",(option/10)%10);
  3925.     set_intrinsic_numargs("IRAND",(option/10)%10);
  3926.                 /* IARGC uses hundreds digit */
  3927.     set_intrinsic_numargs("IARGC",(option/100)%10);
  3928. }
  3929.  
  3930. #if HAVE_STDC
  3931. PRIVATE void set_intrinsic_numargs(char *name, int choice)
  3932.                         /* Name of function to fix up */
  3933.                         /* 0 = none, 1 = one, 2 = either */
  3934. #else /* K&R style */
  3935. PRIVATE void set_intrinsic_numargs(name,choice)
  3936.      char *name;        /* Name of function to fix up */
  3937.      int choice;        /* 0 = none, 1 = one, 2 = either */
  3938. #endif /* HAVE_STDC */
  3939. {
  3940.   IntrinsInfo *defn;
  3941.  
  3942.   if(choice == 2)        /* Convert digit to num_args equivalent */
  3943.     choice = I_0or1;
  3944.  
  3945.   defn = find_intrinsic(name);
  3946.   if(defn != (IntrinsInfo *)NULL) {
  3947.     defn->num_args = choice;
  3948.   }
  3949. }
  3950.  
  3951.  
  3952.     /* Function to look up an intrinsic function name in table.
  3953.        If found, returns ptr to table entry, otherwise NULL.
  3954.     */
  3955. PRIVATE IntrinsInfo *
  3956. #if HAVE_STDC
  3957. find_intrinsic(char *s)
  3958.                         /* given name */
  3959. #else /* K&R style */
  3960. find_intrinsic(s)
  3961.     char *s;            /* given name */
  3962. #endif /* HAVE_STDC */
  3963. {
  3964.     unsigned i, h;
  3965.     unsigned long hnum;
  3966.  
  3967.     hnum = kwd_hash(s);
  3968.     for(;;) {
  3969.       h=hnum%INTRINS_HASHSZ;
  3970.       if( (i=intrins_hashtab[h]) == EMPTY )
  3971.         break;        /* Not found */
  3972.  
  3973.                 /* Something found: see if a match */
  3974.       if( strcmp(s,intrinsic[i].name) == 0  &&
  3975.           ((intrinsic[i].intrins_flags&(I_EXTRA|I_VMS|I_UNIX))==0 ||
  3976.            ((intrinsic[i].intrins_flags&I_EXTRA) && intrinsic_set != 0) ||
  3977.            ((intrinsic[i].intrins_flags&I_UNIX) && intrinsic_set == 2) ||
  3978.            ((intrinsic[i].intrins_flags&I_VMS) && intrinsic_set == 3)
  3979.           ) ) {
  3980.  
  3981.         return &intrinsic[i];
  3982.       }
  3983.       else {        /* No match: try next */
  3984.         hnum = rehash(hnum);
  3985.       }
  3986.     }
  3987.                 /* Not an intrinsic function */
  3988.     return (IntrinsInfo *)NULL;
  3989. }
  3990.  
  3991.     /* find_io_keyword looks up an i/o keyword in io_keywords
  3992.        table and returns its index.  Uses simple linear search
  3993.        since not worth hash overhead.  If not found, returns
  3994.        index of last element of list, which is special. */
  3995. PRIVATE int
  3996. #if HAVE_STDC
  3997. find_io_keyword(char *s)
  3998.                          /* given name */
  3999. #else /* K&R style */
  4000. find_io_keyword(s)
  4001.      char *s;            /* given name */
  4002. #endif /* HAVE_STDC */
  4003. {
  4004.     int i;
  4005.     for(i=0; io_keywords[i].name != NULL; i++) {
  4006.     if(strcmp(io_keywords[i].name, s) == 0) {
  4007.         break;
  4008.     }
  4009.     }
  4010.     return i;
  4011. }
  4012.  
  4013.  
  4014.  
  4015. #ifdef DEBUG_SIZES
  4016. void print_sizeofs()            /* For development: print sizeof for
  4017.                    various data structures */
  4018. {
  4019. #ifdef __STDC__
  4020. #define PrintObjSize(OBJ) (void)fprintf(list_fd,#OBJ " size = %d\n",sizeof(OBJ))
  4021. #else            /* K&R form */
  4022. #define PrintObjSize(OBJ) (void)fprintf(list_fd,"OBJ size = %d\n",sizeof(OBJ))
  4023. #endif
  4024.   PrintObjSize(char *);
  4025.   PrintObjSize(Token);
  4026.   PrintObjSize(Lsymtab);
  4027.   PrintObjSize(Gsymtab);
  4028.   PrintObjSize(HashTable);
  4029.   PrintObjSize(ArgListHeader);
  4030.   PrintObjSize(ArgListElement);
  4031.   PrintObjSize(ComListHeader);
  4032.   PrintObjSize(ComListElement);
  4033.   PrintObjSize(TokenListHeader);
  4034.   PrintObjSize(InfoUnion);
  4035.   PrintObjSize(IntrinsInfo);
  4036.   PrintObjSize(ParamInfo);
  4037.   PrintObjSize(ChildList);
  4038. }
  4039. #endif
  4040.