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