home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / FTNCHK32.ZIP / symtab.c < prev    next >
C/C++ Source or Header  |  1993-02-16  |  60KB  |  2,276 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) 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,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.     unsigned hash_lookup(s)     Looks up identifier in hashtable.
  49.        init_globals()     Initializes global symbol info.
  50.        init_symtab()     Clears local symbol table & removes locals
  51.                  from stringspace. Also restores default
  52.                  implicit data typing.
  53.  Gsymtab* install_global(t,datatype,storage_class) Installs indentifier in
  54.                 global symbol table.
  55.  Lsymtab* install_local(t,datatype,storage_class) Installs indentifier in
  56.                 local symbol table.
  57. ArgListHeader* make_arg_array(t) Converts list of tokens into list of
  58.                  type-flag pairs.
  59. ArgListHeader* make_dummy_arg_array(t) Converts list of tokens into list of
  60.                  type-flag pairs.
  61. ArgListHeader* make_arrayless_alist() Sets up argument list header for
  62.                 EXTERNAL decl or subprog as actual arg.
  63. ComListHeader* make_com_array(t) Converts list of common block tokens into
  64.                  list of dimen_info-type pairs.
  65.        process_lists()     Places pointer to linked list of arrays in
  66.                  global symbol table
  67.        ref_array(id,subscrs) Handles array references
  68.        ref_variable(id)     Handles accessing variable name.
  69.        set_implicit_type(type,c1,c2) Processes IMPLICIT statement.
  70.        stmt_function_stmt(id) Finishes processing stmt func defn.
  71.     char * token_name(t)     Returns ptr to token's symbol's name.
  72.        use_actual_arg(id)     Handles using a variable as actual arg.
  73.        use_io_keyword(id_keywd,id_val,class) Handles i/o control specifier.
  74.        use_lvalue(id)     Handles assignment to a variable.
  75.        use_parameter(id)     Handles data_constant_value &
  76.                  data_repeat_factor.
  77.        use_variable(id)     Sets used-flag for a variable used in expr.
  78.  
  79. */
  80.  
  81. /*  private functions defined:
  82.  arg_count(t)        Counts the number of arguments in a token list.
  83.  call_external(symt,id,arg)    places token list of args into local symtab
  84.  check_intrins_args(arg, defn) Checks call seq of intrinsic functions
  85.  check_stmt_function_args(symt,id,arg)  ditto for statement functions
  86.  find_intrinsic()        Looks up intrinsic functions in table
  87.  find_io_keyword()        Looks up i/o control spec keywords
  88.  reverse_tokenlist(t)        Reverses a linked list of tokens
  89.  make_TL_head();        Initializes a tokenlist header
  90. */
  91.  
  92. #include <stdio.h>
  93. #include <string.h>
  94. #include <ctype.h>
  95. #define SYMTAB
  96. #include "ftnchek.h"
  97. #include "symtab.h"
  98. #include "tokdefs.h"
  99. #ifdef __STDC__
  100. #include <stdlib.h>
  101. #else
  102. char *calloc();
  103. void exit();
  104. #endif
  105.  
  106.  
  107. PRIVATE
  108. unsigned arg_count();
  109.  
  110. PRIVATE void
  111. call_external(),
  112. check_intrins_args(),
  113. check_stmt_function_args();
  114.  
  115. PRIVATE int
  116. find_io_keyword();
  117.  
  118. PRIVATE Token *
  119. reverse_tokenlist();
  120.  
  121. PRIVATE TokenListHeader *    /* Initializes a tokenlist header */
  122. make_TL_head();
  123.  
  124. PRIVATE
  125. ArgListHeader *make_dummy_arg_array(),*make_arg_array(),
  126.  *make_arrayless_alist();
  127.  
  128. PRIVATE
  129. ComListHeader *make_com_array();
  130.  
  131. PRIVATE
  132. IntrinsInfo *find_intrinsic();
  133.  
  134. PRIVATE unsigned
  135. arg_count(t)            /* Counts the number of arguments in a token list */
  136.     Token *t;
  137. {
  138.     unsigned count;
  139.     count = 0;
  140.     while(t != NULL){
  141.         count++;
  142.         t = t->next_token;
  143.     }
  144.     return(count);
  145. }
  146.  
  147.             /* This routine handles the saving of arg lists which
  148.                is done by call_func and call_subr.  Also called
  149.                by def_namelist to save its variable list. */
  150. PRIVATE void
  151. call_external(symt,id,arg)
  152.     Lsymtab *symt;
  153.     Token *id,*arg;
  154. {
  155.            TokenListHeader *TH_ptr;
  156.  
  157.         /* Insert the new list onto linked list of token lists */
  158.           TH_ptr= make_TL_head(id);
  159.  
  160.     TH_ptr->tokenlist = (arg == NULL ? NULL: arg->next_token);
  161.     TH_ptr->next = symt->info.toklist;
  162.     symt->info.toklist = TH_ptr;
  163. } /*call_external*/
  164.  
  165. void
  166. call_func(id,arg)    /* Process function invocation */
  167.     Token *id, *arg;
  168. {
  169.     int t, h=id->value.integer;
  170.     Lsymtab *symt;
  171.     Gsymtab *gsymt;
  172.     IntrinsInfo *defn;
  173.  
  174.     if( (symt = (hashtab[h].loc_symtab)) == NULL){
  175.        symt = install_local(h,type_UNDECL,class_SUBPROGRAM);
  176.               symt->info.toklist = NULL;
  177.     }
  178.  
  179.     t = datatype_of(symt->type);
  180.         /* Symbol seen before: check it & change class */
  181.  
  182.     if(storage_class_of(symt->type) == class_VAR) {
  183.         symt->type = type_byte(class_SUBPROGRAM,t);
  184.         symt->info.toklist = NULL;
  185.       }
  186.  
  187.  
  188.         /* See if intrinsic.  If so, set flag, save info */
  189.     if(!symt->external && !symt->intrinsic
  190.         && (defn = find_intrinsic(symt->name)) != NULL) {
  191.             /* First encounter with intrinsic fcn: store info */
  192.         symt->intrinsic = TRUE;
  193.         symt->info.intrins_info = defn;
  194.     }
  195.  
  196.         /* Update set/used status of variables in arg list.  This
  197.            is deferred to now to allow intrinsics to be treated
  198.            as pure functions regardless of pure_function flag. */
  199.  
  200.     if(arg != NULL) {
  201.         Token *a=arg;
  202.           while( (a=a->next_token) != NULL) {
  203.           if(is_true(ID_EXPR,a->subclass)){
  204.         if( ! (pure_functions || symt->intrinsic)) {
  205.           use_actual_arg(a);
  206.           use_variable(a);
  207.         }
  208.         else {
  209.           use_function_arg(a);
  210.         }
  211.           }
  212.         }
  213.     }
  214.  
  215.         /* If intrinsic, do checking now.  Otherwise, save arg list
  216.            to be checked later. */
  217.  
  218.     if(symt->intrinsic) {
  219.             /* It is intrinsic: check it */
  220.     check_intrins_args(arg,symt->info.intrins_info);
  221.     }
  222.     else {        /* It is not intrinsic: install in global table */
  223.       switch(storage_class_of(symt->type)) {
  224.     case class_SUBPROGRAM:
  225.       symt->external = TRUE;
  226.       if((!symt->argument) && (gsymt=(hashtab[h].glob_symtab)) == NULL) {
  227.         gsymt = install_global(h,type_UNDECL,class_SUBPROGRAM);
  228.         gsymt->info.arglist = NULL;
  229.       }
  230.             /* store arg list in local table */
  231.       call_external(symt,id,arg);
  232.       break;
  233.     case class_STMT_FUNCTION:
  234.       symt->external = TRUE;
  235.       check_stmt_function_args(symt,id,arg);
  236.       break;
  237.       }
  238.     }
  239.  
  240.     symt->used_flag = TRUE;
  241.     symt->invoked_as_func = TRUE;
  242.  
  243. } /*call_func*/
  244.  
  245.  
  246. void
  247. call_subr(id,arg)    /* Process call statements */
  248.     Token *id, *arg;
  249. {
  250.     int t, h=id->value.integer;
  251.     Lsymtab *symt;
  252.     Gsymtab *gsymt;
  253.  
  254.     if( (symt = (hashtab[h].loc_symtab)) == NULL){
  255.        symt = install_local(h,type_SUBROUTINE,class_SUBPROGRAM);
  256.           symt->info.toklist = NULL;
  257.     }
  258.  
  259.  
  260.     t=datatype_of(symt->type);
  261.         /* Symbol seen before: check it & change class */
  262.  
  263.     if(t == type_UNDECL) {
  264.         t = type_SUBROUTINE;
  265.         symt->info.toklist = NULL;
  266.     }
  267.     symt->type = type_byte(class_SUBPROGRAM,t);
  268.  
  269.     /* Assume CALL cannot refer to intrinsic, so don't look to
  270.        see if it is in intrinsic list.
  271.        But if declared intrinsic, then accept it as such and
  272.        do checking now.  Otherwise, save arg list
  273.        to be checked later. */
  274.  
  275.     if(symt->intrinsic) {
  276.             /* It is intrinsic: check it */
  277.     check_intrins_args(arg,symt->info.intrins_info);
  278.     }
  279.     else {        /* It is not intrinsic: install in global table */
  280.     symt->external = TRUE;
  281.     if((!symt->argument) && (gsymt=(hashtab[h].glob_symtab)) == NULL) {
  282.         gsymt = install_global(h,type_UNDECL,class_SUBPROGRAM);
  283.         gsymt->info.arglist = NULL;
  284.     }
  285.             /* store arg list in local table */
  286.     call_external(symt,id,arg);
  287.     }
  288.  
  289.     symt->used_flag = TRUE;
  290.  
  291. }/*call_subr*/
  292.  
  293.  
  294.         /* check out consistency of intrinsic argument list */
  295. PRIVATE
  296. void
  297. check_intrins_args(arg, defn)
  298.     Token *arg;
  299.     IntrinsInfo *defn;
  300. {
  301.     int i;
  302.     unsigned args_given = arg_count(arg->next_token);
  303.     int type,firsttype;
  304.     int numargs,argtype;
  305.     Token *t;
  306.  
  307.     numargs = defn->num_args;
  308.     argtype = defn->arg_type;
  309.  
  310.  
  311.             /* positive numargs: must agree */
  312.     if( (numargs > 0 && (args_given != numargs))
  313.             /* numargs == -1: 1 or 2 */
  314.      || (numargs == -1 && (args_given != 1 && args_given != 2))
  315.             /* numargs == -2: 2 or more */
  316.      || (numargs == -2 && (args_given < 2)) ){
  317.         syntax_error(arg->line_num,arg->col_num,
  318.           "intrinsic function used with wrong number of arguments: ");
  319.         msg_tail(defn->name);
  320.     }
  321.     if(arg == NULL) return;
  322.  
  323.     t = arg->next_token;
  324.     for(i=0; i<args_given; i++) {
  325.         type = datatype_of(t->class);
  326.  
  327.         if(i == 0)
  328.         firsttype = type;
  329.  
  330.         if(!( (1<<type) & argtype )) {
  331.         syntax_error(t->line_num,t->col_num,
  332.         "illegal argument data type for intrinsic function");
  333.         }
  334.  
  335.         if(firsttype != type) {
  336.         syntax_error(t->line_num,t->col_num,
  337.         "intrinsic function argument data types differ");
  338.         }
  339.         t = t->next_token;
  340.     }
  341. }/* check_intrins_args */
  342.  
  343.  
  344. PRIVATE
  345. void
  346. check_stmt_function_args(symt,id,arg)
  347.     Lsymtab *symt;
  348.     Token *id,*arg;
  349. {
  350.     unsigned n1,n2,n;
  351.     int i;
  352.     Token *t1,*t2;
  353.  
  354.     t1 = symt->info.toklist->tokenlist;
  355.     t2 = reverse_tokenlist( (arg==NULL? NULL : arg->next_token) );
  356.  
  357.     n1 = arg_count(t1);
  358.     n2 = arg_count(t2);
  359.  
  360.     if(n1 != n2) {
  361.         syntax_error(id->line_num,id->col_num,
  362.         "function invoked with incorrect number of arguments");
  363.     }
  364.  
  365.     n = (n1 < n2? n1: n2);
  366.     for(i=0; i<n; i++) {
  367.  
  368.         if( t1->class != t2->class) {
  369.         syntax_error(t2->line_num,t2->col_num,
  370.           "function argument is of incorrect datatype");
  371.         }
  372.         t1 = t1->next_token;
  373.         t2 = t2->next_token;
  374.     }
  375. }
  376.  
  377.  
  378. void
  379. declare_type(id,datatype)
  380.     Token *id;
  381.     int datatype;
  382. {
  383.     int h=id->value.integer;
  384.     Lsymtab *symt;
  385.  
  386.     if( (symt=hashtab[h].loc_symtab) == NULL) {
  387.        symt = install_local(h,datatype,class_VAR);
  388.     }
  389.     else {           /* Symbol has been seen before: check it */
  390.  
  391.             /* Intrinsic: see if type is consistent */
  392.       if( symt->intrinsic ) {
  393.         IntrinsInfo *defn = symt->info.intrins_info;
  394.         int rettype = defn->result_type,
  395.         argtype = defn->arg_type;
  396.             /* N.B. this test catches many but not all errors */
  397.         if( (rettype != type_GENERIC && datatype != rettype)
  398.          || (rettype == type_GENERIC && !((1<<datatype) & argtype)) ){
  399.             warning(id->line_num,id->col_num,
  400.                 "Declared type ");
  401.             msg_tail(type_name[datatype]);
  402.             msg_tail(" is invalid for intrinsic function: ");
  403.             msg_tail(symt->name);
  404.           }
  405.       }
  406.  
  407.       if(datatype_of(symt->type) != type_UNDECL) {
  408.           syntax_error(id->line_num,id->col_num,
  409.         "Symbol redeclared: ");
  410.           msg_tail(symt->name);
  411.       }
  412.       else {
  413.             /* Now give it the declared type */
  414.           symt->type = type_byte(storage_class_of(symt->type),datatype);
  415.       }
  416.     }
  417. }/*declare_type*/
  418.  
  419.  
  420. void
  421. def_arg_name(id)        /* Process items in argument list */
  422.  
  423.     Token *id;
  424. {
  425.     int h=id->value.integer;
  426.     Lsymtab *symt;
  427.  
  428.     if( (symt=hashtab[h].loc_symtab) == NULL) {
  429.        symt = install_local(h,type_UNDECL,class_VAR);
  430.     }
  431.     else {           /* Symbol has been seen before: check it */
  432.  
  433.     }
  434.     symt->argument = TRUE;
  435. }/*def_arg_name*/
  436.  
  437.  
  438. void
  439. def_array_dim(id,arg)    /* Process dimension lists */
  440.     Token *id,*arg;         /* arg previously defined as int */
  441. {
  442.     int h=id->value.integer;
  443.     Lsymtab *symt;
  444.  
  445.  
  446.     if( (symt=hashtab[h].loc_symtab) == NULL) {
  447.        symt = install_local(h,type_UNDECL,class_VAR);
  448.     }
  449.     else {           /* Symbol has been seen before: check it */
  450.        if(storage_class_of(symt->type) != class_VAR) {
  451.           syntax_error(id->line_num,id->col_num,
  452.         "Entity cannot be dimensioned: ");
  453.         msg_tail(symt->name);
  454.           return;
  455.        }
  456.     }
  457.     symt->array_var = TRUE;
  458.     if(!equivalence_flag){      /* some checking should be done here */
  459.        if(symt->info.array_dim != 0)
  460.           syntax_error(id->line_num,id->col_num,
  461.         "Array redimensioned");
  462.        else
  463.           symt->info.array_dim = array_dim_info(arg->class,arg->subclass);
  464.     }
  465. }/*def_array_dim*/
  466.  
  467.  
  468. void
  469. def_com_block(id,comlist)    /* Process common blocks and save_stmt */
  470.     Token *id, *comlist;
  471.  
  472. {
  473.     int h=id->value.integer;
  474.     Lsymtab *symt;
  475.     Gsymtab *gsymt;
  476.        TokenListHeader *TH_ptr;
  477.  
  478.         /* Install name in global symbol table */
  479.     if( (gsymt=hashtab[h].com_glob_symtab) == NULL) {
  480.        gsymt = install_global(h,type_COMMON_BLOCK,class_COMMON_BLOCK);
  481.        gsymt->info.comlist = NULL;
  482.     }
  483.  
  484.  
  485.     if( (symt = hashtab[h].com_loc_symtab) == NULL){
  486.        symt = install_local(h,type_COMMON_BLOCK,class_COMMON_BLOCK);
  487.        symt->info.toklist = NULL;
  488.     }
  489.  
  490.         /* Insert the new list onto linked list of token lists */
  491.     if(comlist != NULL) {
  492.           /* Will be NULL only for SAVE, in which case skip */
  493.         TH_ptr= make_TL_head(id);
  494.  
  495.          TH_ptr->tokenlist = comlist->next_token;
  496.         TH_ptr->next = symt->info.toklist;
  497.             symt->info.toklist = TH_ptr;
  498.     }
  499.  
  500.        symt->set_flag = TRUE;
  501.     symt->used_flag = TRUE;
  502. }/*def_com_block*/
  503.  
  504.  
  505. void
  506. def_com_variable(id)        /* Process items in common block list */
  507.     Token *id;
  508. {
  509.     int h=id->value.integer;
  510.     Lsymtab *symt;
  511.  
  512.     if( (symt=hashtab[h].loc_symtab) == NULL) {
  513.        symt = install_local(h,type_UNDECL,class_VAR);
  514.     }
  515.     else {           /* Symbol has been seen before: check it */
  516.         if(symt->common_var) {
  517.         syntax_error(id->line_num,id->col_num,
  518.              "Variable cannot be in two different common blocks");
  519.         }
  520.         else if(symt->entry_point || symt->parameter ||
  521.             symt->argument || symt->external || symt->intrinsic) {
  522.         syntax_error(id->line_num,id->col_num,
  523.              "Item cannot be placed in common");
  524.         }
  525.     }
  526.     {        /* set flags for all equivalenced vars */
  527.       Lsymtab *equiv=symt;
  528.       do{
  529.     equiv->common_var = TRUE; /* set the flag even if not legit */
  530.     equiv = equiv->equiv_link;
  531.       } while(equiv != symt);
  532.     }
  533.  
  534. }/*def_com_variable*/
  535.  
  536.  
  537.     /* This guy sets the flag in symbol table saying the id is the
  538.        current module.  It returns the hash code for later reference.
  539.      */
  540. int
  541. def_curr_module(id)
  542.     Token *id;
  543. {
  544.     int hashno = id->value.integer;
  545.     hashtab[hashno].loc_symtab->is_current_module = TRUE;
  546.  
  547.     return hashno;
  548. }/*def_curr_module*/
  549.  
  550.  
  551.  
  552.  
  553. void
  554. def_equiv_name(id)        /* Process equivalence list elements */
  555.     Token *id;
  556. {
  557.   ref_variable(id);        /* Put it in symtab */
  558.     /* No other action needed: processing of equiv pairs is
  559.        done by equivalence() */
  560. }/*def_equiv_name*/
  561.  
  562.  
  563.  
  564. void
  565. def_ext_name(id)        /* Process external lists */
  566.     Token *id;
  567. {
  568.     int h=id->value.integer;
  569.     Lsymtab *symt;
  570.  
  571.     if( (symt = hashtab[h].loc_symtab) == NULL){
  572.        symt = install_local(h,type_UNDECL,class_SUBPROGRAM);
  573.        symt->info.toklist = NULL;
  574.         }
  575.     else {
  576.             /* Symbol seen before: check it & change class */
  577.  
  578.         if(storage_class_of(symt->type) == class_VAR) {
  579.           symt->info.toklist = NULL;
  580.         }
  581.         symt->type = type_byte(class_SUBPROGRAM,datatype_of(symt->type));
  582.     }
  583.  
  584.     if(symt->intrinsic){
  585.         syntax_error(id->line_num,id->col_num,
  586.         "Cannot declare same subprogram both intrinsic and external:");
  587.         msg_tail(symt->name);
  588.     }
  589.     else{
  590.         symt->external = TRUE;
  591.         if(!symt->argument){
  592.             TokenListHeader *TH_ptr;
  593.         Gsymtab *gsymt;
  594.         if( (gsymt=hashtab[h].glob_symtab) == NULL) {
  595.                gsymt = install_global(h,type_UNDECL,class_SUBPROGRAM);
  596.                gsymt->info.arglist = NULL;
  597.         }
  598.         TH_ptr=make_TL_head(id);
  599.  
  600.         TH_ptr->external_decl = TRUE;
  601.         TH_ptr->next = symt->info.toklist;
  602.         symt->info.toklist = TH_ptr;
  603.          }
  604.       }
  605.       symt->declared_external = TRUE;
  606. }/*def_ext_name*/
  607.  
  608.  
  609.  
  610. void
  611. def_function(datatype,id,args)
  612.                 /* Installs function or subroutine name */
  613.     int datatype;                     /* in global table */
  614.     Token *id,*args;
  615. {
  616.     int storage_class;
  617.     int h=id->value.integer;
  618.     Lsymtab *symt;
  619.     Gsymtab *gsymt;
  620.     TokenListHeader *TH_ptr;
  621.        storage_class = class_SUBPROGRAM;
  622.  
  623.     if((gsymt = (hashtab[h].glob_symtab)) == NULL) {
  624.             /* Symbol is new to global symtab: install it */
  625.       gsymt = install_global(h,datatype,storage_class);
  626.       gsymt->info.arglist = NULL;
  627.     }
  628.     else {
  629.             /* Symbol is already in global symtab. Put the
  630.                declared datatype into symbol table. */
  631.       gsymt->type = type_byte(storage_class,datatype);
  632.     }
  633.  
  634.        if((symt = (hashtab[id->value.integer].loc_symtab)) == NULL) {
  635.             /* Symbol is new to local symtab: install it.
  636.                Since this is the current routine, it has
  637.                storage class of a variable. */
  638.        symt = install_local(h,datatype,class_VAR);
  639.     }
  640.     if(! symt->entry_point)    /* seen before but not as entry */
  641.        symt->info.toklist = NULL;
  642.  
  643.  
  644.         /* Insert the new list onto linked list of token lists */
  645.        TH_ptr=make_TL_head(id);
  646.  
  647.     TH_ptr->tokenlist = (args == NULL ? NULL: args->next_token);
  648.     TH_ptr->next = symt->info.toklist;
  649.     symt->info.toklist = TH_ptr;
  650.  
  651.     symt->entry_point = TRUE;
  652.  
  653.         /* library mode: set the flag so no complaint will
  654.            be issued if function never invoked.  Also, set
  655.            used_flag if this is a main program, for same reason. */
  656.     if(library_mode)
  657.         symt->library_module = TRUE;
  658.     if(datatype == type_PROGRAM)
  659.         symt->used_flag = TRUE;
  660. }/*def_function*/
  661.  
  662.  
  663.  
  664. void
  665. def_intrins_name(id)        /* Process intrinsic lists */
  666.     Token *id;
  667. {
  668.     int h=id->value.integer;
  669.     Lsymtab *symt;
  670.  
  671.     if( (symt = hashtab[h].loc_symtab) == NULL){
  672.        symt = install_local(h,type_UNDECL,class_SUBPROGRAM);
  673.        symt->info.toklist = NULL;
  674.         }
  675.     else {
  676.             /* Symbol seen before: check it & change class */
  677.       if(storage_class_of(symt->type) == class_VAR) {
  678.         symt->info.toklist = NULL;
  679.       }
  680.  
  681.       symt->type = type_byte(class_SUBPROGRAM,datatype_of(symt->type));
  682.     }
  683.  
  684.         /* Place info about intrinsic datatype in local symtab.
  685.            If not found, it will be treated as external.
  686.          */
  687.  
  688.     if(symt->external){
  689.         syntax_error(id->line_num,id->col_num,
  690.            "Cannot declare same subprogram both intrinsic and external:");
  691.         msg_tail(symt->name);
  692.     }
  693.     else{
  694.       IntrinsInfo *defn;
  695.       if( (defn=find_intrinsic(symt->name)) == NULL ) {
  696.          warning(id->line_num,id->col_num,
  697.             "Unknown intrinsic function: ");
  698.          msg_tail(symt->name);
  699.          msg_tail("\nTreated as if user-defined");
  700.                 /* Here treat as if EXTERNAL declaration */
  701.          def_ext_name(id);
  702.          return;
  703.        }
  704.        else {
  705.             /* Found in info table: set intrins flag and store
  706.                pointer to definition info. */
  707.          symt->intrinsic = TRUE;
  708.          symt->info.intrins_info = defn;
  709.        }
  710.     }
  711.     symt->declared_external = TRUE;
  712. }/*def_intrins_name*/
  713.  
  714. void
  715. def_namelist(id,list)        /* Process NAMELIST declaration */
  716.      Token *id,*list;
  717. {
  718.     int h=id->value.integer;
  719.     Lsymtab *symt;
  720.  
  721.     if( (symt=hashtab[h].loc_symtab) != NULL) {
  722.       syntax_error(id->line_num,id->col_num,
  723.             "name is already in use");
  724.     }
  725.     else {
  726.       symt = install_local(h,type_NAMELIST,class_NAMELIST);
  727.       symt->info.toklist = NULL;
  728.       call_external(symt,id,list); /* attach list to symt->info.toklist */
  729.     }
  730.  
  731. }/*def_namelist*/
  732.  
  733.  
  734. void
  735. def_namelist_item(id)        /* Process NAMELIST list elements */
  736.     Token *id;
  737. {
  738.   ref_variable(id);        /* Put it in symtab */
  739. }/*def_namelist_name*/
  740.  
  741. void
  742. def_parameter(id,val)        /* Process parameter_defn_item */
  743.     Token *id,*val;
  744. {
  745.     int h=id->value.integer;
  746.     Lsymtab *symt;
  747.  
  748.     if( (symt=hashtab[h].loc_symtab) == NULL) {
  749.        symt = install_local(h,type_UNDECL,class_VAR);
  750.     }
  751.  
  752.     symt->set_flag = TRUE;
  753.     symt->parameter = TRUE;
  754.  
  755.         /* Integer parameters: save value in symtab entry.  Other
  756.            types not saved.  Need these since used in array dims */
  757.     switch(get_type(symt)) {
  758.         case type_INTEGER:
  759.             symt->info.int_value = int_expr_value(val);
  760.             break;
  761.         default:
  762.             break;
  763.     }
  764. }/*def_parameter*/
  765.  
  766.  
  767.  
  768. void               /* Installs statement function name in local table */
  769. def_stmt_function(id, args)
  770.     Token *id, *args;
  771. {
  772.     int t,h=id->value.integer;
  773.     Lsymtab *symt;
  774.        TokenListHeader *TH_ptr;
  775.  
  776.        if((symt = (hashtab[h].loc_symtab)) == NULL) {
  777.             /* Symbol is new to local symtab: install it. */
  778.  
  779.        symt = install_local(h,type_UNDECL,class_STMT_FUNCTION);
  780.        symt->info.toklist = NULL;
  781.     }
  782.     else {
  783.       if(storage_class_of(symt->type) == class_VAR) {
  784.         symt->info.toklist = NULL;
  785.       }
  786.     }
  787.  
  788.         /* Save dummy arg list in symbol table */
  789.         TH_ptr= make_TL_head(id);
  790.  
  791.     TH_ptr->tokenlist = (args == NULL ? NULL: args->next_token);
  792.     TH_ptr->next = symt->info.toklist;
  793.     symt->info.toklist = TH_ptr;
  794.  
  795.         /* Reverse the token list for sake of checking phase */
  796.     TH_ptr->tokenlist = reverse_tokenlist(TH_ptr->tokenlist);
  797.  
  798.     t=datatype_of(symt->type);
  799.         /* Symbol seen before: check it & change class */
  800.  
  801.         /* check, check, check ... */
  802.     if(storage_class_of(symt->type) == class_VAR)
  803.        symt->type = type_byte(class_STMT_FUNCTION,t);
  804.  
  805.     symt->external = TRUE;
  806. }/*def_stmt_function*/
  807.  
  808.  
  809.  
  810.  
  811. void
  812. do_ASSIGN(id)        /* Process ASSIGN statement */
  813.     Token *id;
  814. {
  815.     int h=id->value.integer;
  816.     Lsymtab *symt;
  817.  
  818.     if( (symt=hashtab[h].loc_symtab) == NULL) {
  819.        symt = install_local(h,type_UNDECL,class_VAR);
  820.     }
  821.     else {
  822.        if(get_type(symt) != type_INTEGER) {
  823.           syntax_error(id->line_num,id->col_num,
  824.         "Variable must be an integer: ");
  825.           msg_tail(symt->name);
  826.        }
  827.     }
  828.     {        /* set flags for all equivalenced vars */
  829.       Lsymtab *equiv=symt;
  830.       do{
  831.     equiv->set_flag = TRUE;
  832.     equiv = equiv->equiv_link;
  833.       } while(equiv != symt);
  834.     }
  835. }/*do_ASSIGN*/
  836.  
  837.  
  838.  
  839.  
  840. void
  841. do_assigned_GOTO(id)        /* Process assigned_goto */
  842.     Token *id;
  843. {
  844.     int h=id->value.integer;
  845.     Lsymtab *symt;
  846.  
  847.     if( (symt=hashtab[h].loc_symtab) == NULL) {
  848.        symt = install_local(h,type_UNDECL,class_VAR);
  849.     }
  850.     else {
  851.        if(get_type(symt) != type_INTEGER) {
  852.           syntax_error(id->line_num,id->col_num,
  853.         "Variable must be an integer: ");
  854.           msg_tail(symt->name);
  855.        }
  856.     }
  857.     {        /* set flags for all equivalenced vars */
  858.       Lsymtab *equiv=symt;
  859.       do{
  860.     if(! equiv->set_flag)
  861.        equiv->used_before_set = TRUE;
  862.     equiv->used_flag = TRUE;
  863.     equiv = equiv->equiv_link;
  864.       } while(equiv != symt);
  865.     }
  866.  
  867. }/*do_assigned_GOTO*/
  868.  
  869.  
  870.  
  871.  
  872.  
  873. void
  874. do_ENTRY(id,args,hashno)    /* Processes ENTRY statement */
  875.     Token *id,*args;
  876.     int hashno;
  877. {
  878.     int datatype;
  879.     if(hashno == -1) {    /* -1 signifies headerless program */
  880.         datatype = type_PROGRAM;
  881.     }
  882.     else {
  883.         datatype = datatype_of(hashtab[hashno].loc_symtab->type);
  884.     }
  885.     switch(datatype) {
  886.         case type_PROGRAM:
  887.         case type_BLOCK_DATA:
  888.         case type_COMMON_BLOCK:
  889.             syntax_error(id->line_num,NO_COL_NUM,
  890.             "You cannot have an entry statement here");
  891.         break;
  892.         case type_SUBROUTINE:    /* Subroutine entry */
  893.         def_function(type_SUBROUTINE,id,args);
  894.         break;
  895.         default:        /* Function entry */
  896.         def_function(type_UNDECL,id,args);
  897.         break;
  898.     }
  899. }/*do_ENTRY*/
  900.  
  901.  
  902.  
  903.  
  904.     /* This routine checks whether a RETURN statement is valid at
  905.        the present location, and if it is, looks for possible
  906.        failure to assign return value of function.
  907.     */
  908. void
  909. do_RETURN(hashno,keyword)
  910.     int hashno;    /* current module hash number */
  911.     Token *keyword;    /* tok_RETURN, or tok_END if implied RETURN */
  912. {
  913.     int i,datatype;
  914.     if(hashno == -1) {    /* -1 signifies headerless program */
  915.         datatype = type_PROGRAM;
  916.     }
  917.     else {
  918.         datatype = datatype_of(hashtab[hashno].loc_symtab->type);
  919.     }
  920.     switch(datatype) {
  921.         case type_PROGRAM:
  922.         case type_BLOCK_DATA:
  923.         if(keyword->class == tok_RETURN)
  924.             syntax_error(keyword->line_num,keyword->col_num,
  925.                 "You cannot have a RETURN statement here!");
  926.         break;
  927.         case type_SUBROUTINE:    /* Subroutine return: OK */
  928.         break;
  929.         default:        /* Function return: check whether entry
  930.                    points have been assigned values. */
  931.         for(i=0; i<loc_symtab_top; i++) {
  932.             if(storage_class_of(loc_symtab[i].type) == class_VAR
  933.             && loc_symtab[i].entry_point
  934.             && ! loc_symtab[i].set_flag ) {
  935.                 warning(keyword->line_num,keyword->col_num,
  936.                     loc_symtab[i].name);
  937.                 msg_tail("not set when RETURN encountered");
  938.             }
  939.         }
  940.         break;
  941.     }
  942.  
  943. }/*do_RETURN*/
  944.  
  945. void
  946. equivalence(id1,id2)
  947.      Token *id1, *id2;
  948. {
  949.     int h1=id1->value.integer, h2=id2->value.integer;
  950.     Lsymtab *symt1,*symt2,*temp;
  951.  
  952.         /* install the variables in symtab if not seen before */
  953.     if( (symt1=hashtab[h1].loc_symtab) == NULL) {
  954.        symt1 = install_local(h1,type_UNDECL,class_VAR);
  955.     }
  956.     if( (symt2=hashtab[h2].loc_symtab) == NULL) {
  957.        symt2 = install_local(h2,type_UNDECL,class_VAR);
  958.     }
  959.             /* Check for legality.  Ought to do complementary
  960.                checks elsewhere.
  961.              */
  962.     if(symt1 == symt2
  963.        || symt1->parameter || symt2->parameter
  964.        || symt1->entry_point || symt2->entry_point
  965.        || symt1->argument || symt2->argument
  966.        || symt1->external || symt2->external) {
  967.  
  968.         syntax_error(id1->line_num,id1->col_num,
  969.                  "illegal to equivalence these");
  970.     }
  971.         /* now swap equiv_links so their equiv lists are united */
  972.     else {
  973.         temp = symt1->equiv_link;
  974.         symt1->equiv_link = symt2->equiv_link;
  975.         symt2->equiv_link = temp;
  976.     }
  977.  
  978.         /* If either guy is in common, both are in common */
  979.     if(symt1->common_var || symt2->common_var) {
  980.         Lsymtab *equiv=symt1;
  981.         do {
  982.         equiv->common_var = TRUE;
  983.         equiv = equiv->equiv_link;
  984.         } while(equiv != symt1);
  985.     }
  986. }
  987.  
  988. int
  989. get_type(symt)    /* Returns data type of symbol, using implicit if necessary */
  990.     Lsymtab *symt;
  991. {
  992.     int datatype = datatype_of(symt->type);
  993.  
  994.     if(datatype != type_UNDECL)    /* Declared? */
  995.        return datatype;        /*   Yes: use it */
  996.     else if(storage_class_of(symt->type) == class_SUBPROGRAM
  997.          && !symt->invoked_as_func )
  998.                 /* Function never invoked: assume subr */
  999.        return type_SUBROUTINE;
  1000.     else            /* Otherwise use implicit type */
  1001. #if ALLOW_UNDERSCORES
  1002.        return (isupper((int)symt->name[0]))?
  1003.          implicit_type[symt->name[0] - 'A']:
  1004.            type_REAL;    /* 1st char underscore => REAL */
  1005. #else
  1006.        return implicit_type[symt->name[0] - 'A'];
  1007. #endif
  1008. }/*get_type*/
  1009.  
  1010.  
  1011.     /* hash_lookup finds identifier in hashtable and returns its
  1012.        index.  If not found, a new hashtable entry is made for it,
  1013.        and the identifier string s is copied to local stringspace.
  1014.     */
  1015. unsigned
  1016. hash_lookup(s)
  1017.     char *s;
  1018. {
  1019.         unsigned h;
  1020.     unsigned long hnum;
  1021.  
  1022.     hnum = hash(s);
  1023.  
  1024.     while(h = hnum%HASHSZ, hashtab[h].name != NULL
  1025.               && strcmp(hashtab[h].name,s) != 0) {
  1026.               hnum = rehash(hnum);    /* Resolve clashes */
  1027.     }
  1028.  
  1029.     if(hashtab[h].name == NULL) {
  1030.             hashtab[h].name = new_local_string(s);
  1031.             hashtab[h].loc_symtab = NULL;
  1032.             hashtab[h].glob_symtab = NULL;
  1033.             hashtab[h].com_loc_symtab = NULL;
  1034.             hashtab[h].com_glob_symtab = NULL;
  1035.         }
  1036.     return h;
  1037. }/*hash_lookup*/
  1038.  
  1039. void
  1040. init_globals()                    /* Clears the global symbol table */
  1041. {
  1042.     glob_str_bot = STRSPACESZ;
  1043. }/*init_globals*/
  1044.  
  1045.  
  1046.  
  1047. void
  1048. init_symtab()                     /* Clears the local symbol table */
  1049. {
  1050.     int i,h;
  1051.     unsigned long hnum;
  1052.  
  1053.     loc_symtab_top = 0;
  1054.     loc_str_top = 0;
  1055.     token_space_top = 0;
  1056.  
  1057.               /* Clears the hash table */
  1058.     for(i=0;i<HASHSZ;i++) {
  1059.         hashtab[i].name = NULL;
  1060.         hashtab[i].loc_symtab = NULL;
  1061.         hashtab[i].com_loc_symtab = NULL;
  1062.         hashtab[i].glob_symtab = NULL;
  1063.         hashtab[i].com_glob_symtab = NULL;
  1064.     }
  1065.  
  1066.               /* Re-establishes global symbols */
  1067.     for(i=0;i<glob_symtab_top;i++) {
  1068.         hnum = hash(glob_symtab[i].name);
  1069.         while (h=hnum % HASHSZ, hashtab[h].name != NULL
  1070.            && strcmp(hashtab[h].name,glob_symtab[i].name) != 0 ) {
  1071.            hnum = rehash(hnum);
  1072.         }
  1073.         hashtab[h].name = glob_symtab[i].name;
  1074.         if(storage_class_of(glob_symtab[i].type) == class_COMMON_BLOCK)
  1075.         hashtab[h].com_glob_symtab = &(glob_symtab[i]);
  1076.         else
  1077.         hashtab[h].glob_symtab = &(glob_symtab[i]);
  1078.  
  1079.     }
  1080.  
  1081.               /* Restores implicit typing to default values */
  1082.     {
  1083.         int c;
  1084.         for( c=0; c<26; c++ )
  1085.                 implicit_type[c] = type_REAL;
  1086.         for( c='I'-'A'; c <= 'N'-'A'; c++ )
  1087.             implicit_type[c] = type_INTEGER;
  1088.     }
  1089. }/*init_symtab*/
  1090.  
  1091.  
  1092.  
  1093. Gsymtab*
  1094. install_global(h,datatype,storage_class)    /* Install a global symbol */
  1095.     int h;            /* hash index */
  1096.     int datatype,storage_class;
  1097. {
  1098.     Gsymtab *gsymt = &glob_symtab[glob_symtab_top];
  1099.  
  1100.     if(glob_symtab_top == GLOBSYMTABSZ) {
  1101.         fprintf(stderr,
  1102.             "\nOops! out of space in global symbol table.\n");
  1103.         exit(1);
  1104.     }
  1105.     else {
  1106.             /* Store symtab pointer in hash table */
  1107.         if(storage_class == class_COMMON_BLOCK)
  1108.         hashtab[h].com_glob_symtab = gsymt;
  1109.         else
  1110.         hashtab[h].glob_symtab = gsymt;
  1111.  
  1112.         clear_symtab_entry(gsymt);
  1113.  
  1114.              /* Duplicate copy of string into global stringspace */
  1115.         gsymt->name = new_global_string(hashtab[h].name);
  1116.  
  1117.             /* Set symtab info fields */
  1118.         gsymt->type = type_byte(storage_class,datatype);
  1119.         if(storage_class == class_COMMON_BLOCK)
  1120.         gsymt->info.comlist = NULL;
  1121.         else
  1122.         gsymt->info.arglist = NULL;
  1123.  
  1124.         gsymt->link.child_list = NULL;
  1125.  
  1126.         ++glob_symtab_top;
  1127.     }
  1128.     return (gsymt);
  1129. }/*install_global*/
  1130.  
  1131.  
  1132. Lsymtab*
  1133. install_local(h,datatype,storage_class)    /* Install a local symbol */
  1134.     int h;            /* hash index */
  1135.     int datatype,storage_class;
  1136. {
  1137.     Lsymtab *symt = &loc_symtab[loc_symtab_top];
  1138.     if(loc_symtab_top == LOCSYMTABSZ) {
  1139.         fprintf(stderr,
  1140.             "\nOops! out of space in local symbol table.\n");
  1141.         exit(1);
  1142.     }
  1143.     else {
  1144.         if(storage_class == class_COMMON_BLOCK)
  1145.         hashtab[h].com_loc_symtab = symt;
  1146.         else
  1147.         hashtab[h].loc_symtab = symt;
  1148.  
  1149.         clear_symtab_entry(symt);
  1150.         symt->name = hashtab[h].name;
  1151.         symt->info.array_dim = 0;
  1152.  
  1153.               /* Set symtab info fields */
  1154.         symt->type = type_byte(storage_class,datatype);
  1155.         symt->equiv_link = symt;    /* equivalenced only to self */
  1156.         if(incdepth > 0)
  1157.           symt->defined_in_include = TRUE;
  1158.         ++loc_symtab_top;
  1159.     }
  1160.     return symt;
  1161. }/*install_local*/
  1162.  
  1163.  
  1164.         /* Get value specified by an integer-expression token.
  1165.            This will be either an identifier, which should be a
  1166.            parameter whose value is in the symbol table, or else
  1167.            an expression token as propagated by exprtype.c
  1168.            routines, with value stored in the token.
  1169.         */
  1170. int
  1171. int_expr_value(t)
  1172.     Token *t;
  1173. {
  1174.     if(! is_true(CONST_EXPR,t->subclass) ) {
  1175.     syntax_error(t->line_num,t->col_num,"constant expression required");
  1176.     return 0;
  1177.     }
  1178.     else {
  1179.     if( is_true(ID_EXPR,t->subclass) ) {
  1180.         /* Identifier: better be a parameter */
  1181.         int h=t->value.integer;
  1182.         Lsymtab *symt = hashtab[h].loc_symtab;
  1183.         if(symt == NULL || !(symt->parameter) ) {
  1184.         syntax_error(t->line_num,t->col_num,
  1185.             "constant expression required");
  1186.         return 0;
  1187.         }
  1188.         else {
  1189.         return symt->info.int_value;
  1190.         }
  1191.     }
  1192.         /* Otherwise, it is a const or expr, use token.value.integer */
  1193.     else {
  1194.         return t->value.integer;
  1195.     }
  1196.     }
  1197. }/*int_expr_value*/
  1198.  
  1199.  
  1200.     /* Following routine converts a list of tokens into a list of type-
  1201.        flag pairs. */
  1202.  
  1203. PRIVATE ArgListHeader *
  1204. make_arg_array(t)
  1205.     Token *t;        /* List of tokens */
  1206. {
  1207.     int i;
  1208.     unsigned count;
  1209.     Token *s;
  1210.     ArgListElement *arglist;
  1211.     ArgListHeader *alhead;
  1212.  
  1213.     count = arg_count(t);
  1214.     if(((alhead=(ArgListHeader *) calloc(1, sizeof(ArgListHeader)))
  1215.                   == (ArgListHeader *) NULL) ||
  1216.       (count != 0 &&
  1217.           ((arglist=(ArgListElement *) calloc(count,sizeof(ArgListElement)))
  1218.                  == (ArgListElement *) NULL))){
  1219.         fprintf(stderr, "Out of space for argument list");
  1220.         exit(1);
  1221.     }
  1222.     s = t;                  /* List of tokens is in reverse order. */
  1223.     for(i=count-1; i>=0; i--){  /* Here we fill array in original order. */
  1224.  
  1225.         arglist[i].type = s->class; /* use evaluated type, not symt */
  1226.  
  1227.             /* Keep track of array and external declarations */
  1228.         if( is_true(ID_EXPR,s->subclass) ){
  1229.         int h = s->value.integer;
  1230.         Lsymtab *symt = hashtab[h].loc_symtab;
  1231.         if( (arglist[i].info.array_dim = symt->info.array_dim) == 0)
  1232.                 /* change scalars to 0 dims, size 1 */
  1233.           arglist[i].info.array_dim = array_dim_info(0,1);
  1234.         arglist[i].array_var = symt->array_var;
  1235.         arglist[i].declared_external = symt->declared_external;
  1236.         }
  1237.         else {
  1238.         arglist[i].info.array_dim = 0;
  1239.         arglist[i].array_var = FALSE;
  1240.         arglist[i].declared_external = FALSE;
  1241.         }
  1242.  
  1243.         arglist[i].array_element =
  1244.         arglist[i].array_var && !is_true(ARRAY_ID_EXPR,s->subclass);
  1245.  
  1246.         if( is_true(LVALUE_EXPR,s->subclass) ){
  1247.         arglist[i].is_lvalue = TRUE;
  1248.             /* is_true(f,x) yields 0 or non-0: convert to 0 or 1 */
  1249.         arglist[i].set_flag =
  1250.             is_true(SET_FLAG,s->subclass)? TRUE: FALSE;
  1251.         arglist[i].assigned_flag =
  1252.             is_true(ASSIGNED_FLAG,s->subclass)? TRUE: FALSE;
  1253.         arglist[i].used_before_set =
  1254.             is_true(USED_BEFORE_SET,s->subclass)? TRUE: FALSE;
  1255.         }
  1256.         else {    /* it is an expression or constant, not an lvalue */
  1257.         arglist[i].is_lvalue = FALSE;
  1258.         arglist[i].set_flag = TRUE;
  1259.         arglist[i].assigned_flag = FALSE;
  1260.         arglist[i].used_before_set = FALSE;
  1261.         }
  1262.         s = s->next_token;
  1263.     }
  1264.     alhead->numargs = count;
  1265.     alhead->is_defn = FALSE;
  1266.     alhead->is_call = TRUE;
  1267.     alhead->external_decl = FALSE;
  1268.     alhead->actual_arg = FALSE;
  1269.  
  1270.         if (count == 0)
  1271.         alhead->arg_array = NULL;
  1272.     else
  1273.         alhead->arg_array = arglist;
  1274.     return(alhead);
  1275. }/* make_arg_array */
  1276.  
  1277.  
  1278.     /* Following routine converts a list of common block tokens
  1279.         into a list of dimen_info-type pairs. */
  1280.  
  1281. PRIVATE ComListHeader *
  1282. make_com_array(t)
  1283.     Token *t;        /* List of tokens */
  1284. {
  1285.     Token *s;
  1286.     Lsymtab *symt;
  1287.     int h, i;
  1288.     unsigned count;
  1289.     ComListHeader *clhead;
  1290.     ComListElement *comlist;
  1291.  
  1292.     count = arg_count(t);
  1293.     if(((clhead=(ComListHeader *) calloc(1,sizeof(ComListHeader)))
  1294.          == (ComListHeader *) NULL) ||
  1295.       (count != 0 &&
  1296.        ((comlist=(ComListElement *) calloc(count,sizeof(ComListElement)))
  1297.          == (ComListElement *) NULL))){
  1298.         fprintf(stderr, "Out of space for common list");
  1299.         exit(1);
  1300.     }
  1301.     s = t;
  1302.     for(i=count-1; i>=0; i--){
  1303.        h = s->value.integer;
  1304.        symt = hashtab[h].loc_symtab;
  1305.        if( (comlist[i].dimen_info = symt->info.array_dim) == 0)
  1306.                 /* change scalars to 0 dims, size 1 */
  1307.          comlist[i].dimen_info = array_dim_info(0,1);
  1308.        comlist[i].type = get_type(symt);
  1309.        s = s->next_token;
  1310.     }
  1311.     clhead->numargs = count;
  1312.     if (count == 0)
  1313.         clhead->com_list_array = NULL;
  1314.     else
  1315.         clhead->com_list_array = comlist;
  1316.     return(clhead);
  1317. } /* make_com_array */
  1318.  
  1319.  
  1320. PRIVATE ArgListHeader *
  1321. make_dummy_arg_array (t)
  1322.     Token *t;        /* List of tokens */
  1323. {
  1324.     int i;
  1325.     unsigned count;
  1326.     Token *s;
  1327.     ArgListElement *arglist;
  1328.     ArgListHeader *alhead;
  1329.  
  1330.     count = arg_count(t);
  1331.     if(((alhead=(ArgListHeader *) calloc(1, sizeof(ArgListHeader)))
  1332.              == (ArgListHeader *) NULL) ||
  1333.       (count != 0 &&
  1334.           ((arglist=(ArgListElement *) calloc(count,sizeof(ArgListElement)))
  1335.             == (ArgListElement *) NULL))){
  1336.         fprintf(stderr, "Out of space for argument list");
  1337.         exit(1);
  1338.     }
  1339.     s = t;                  /* List of tokens is in reverse order. */
  1340.     for(i=count-1; i>=0; i--){  /* Here we fill array in original order. */
  1341.         if( is_true(ID_EXPR,s->subclass) ){
  1342.         int h = s->value.integer;
  1343.         Lsymtab *symt = hashtab[h].loc_symtab;
  1344.         if( (arglist[i].info.array_dim = symt->info.array_dim) == 0)
  1345.                 /* change scalars to 0 dims, size 1 */
  1346.           arglist[i].info.array_dim = array_dim_info(0,1);
  1347.         arglist[i].type = type_byte(storage_class_of(symt->type),
  1348.                         get_type(symt));
  1349.         arglist[i].is_lvalue = TRUE;
  1350.         arglist[i].set_flag = symt->set_flag;
  1351.         arglist[i].assigned_flag = symt->assigned_flag;
  1352.         arglist[i].used_before_set = symt->used_before_set;
  1353.         arglist[i].array_var = symt->array_var;
  1354.         arglist[i].array_element = FALSE;
  1355.         arglist[i].declared_external = symt->declared_external;
  1356.         }
  1357.         else {    /* It is a label */
  1358.         arglist[i].info.array_dim = 0;
  1359.         arglist[i].type = s->class;
  1360.         arglist[i].is_lvalue = FALSE;
  1361.         arglist[i].set_flag = FALSE;    /* Don't currently do labels */
  1362.         arglist[i].assigned_flag = FALSE;
  1363.         arglist[i].used_before_set = FALSE;
  1364.         arglist[i].array_var = FALSE;
  1365.         arglist[i].array_element = FALSE;
  1366.         arglist[i].declared_external = FALSE;
  1367.         }
  1368.         s = s->next_token;
  1369.     }
  1370.     alhead->numargs = count;
  1371.     alhead->is_defn = TRUE;
  1372.     alhead->is_call = FALSE;
  1373.     alhead->external_decl = FALSE;
  1374.     alhead->actual_arg = FALSE;
  1375.  
  1376.         if (count == 0)
  1377.         alhead->arg_array = NULL;
  1378.     else
  1379.         alhead->arg_array = arglist;
  1380.     return(alhead);
  1381. }/* make_dummy_arg_array */
  1382.  
  1383.  
  1384.     /* This routine makes an empty argument list: used for
  1385.        EXTERNAL declarations of subprograms. */
  1386. PRIVATE ArgListHeader *
  1387. make_arrayless_alist()
  1388. {
  1389.     ArgListHeader *alhead;
  1390.  
  1391.     if(((alhead=(ArgListHeader *) calloc(1, sizeof(ArgListHeader)))
  1392.                   == (ArgListHeader *) NULL) ) {
  1393.         fprintf(stderr, "Out of space for external decl\n");
  1394.         exit(1);
  1395.     }
  1396.  
  1397.     alhead->numargs = 0;
  1398.     alhead->is_defn = FALSE;
  1399.     alhead->is_call = FALSE;
  1400.     alhead->arg_array = NULL;
  1401.  
  1402.     return(alhead);
  1403. }/* make_arrayless_arglist */
  1404.  
  1405. PRIVATE TokenListHeader *    /* Initializes a tokenlist header */
  1406. make_TL_head(t)
  1407.      Token *t;
  1408. {
  1409.   TokenListHeader *TH_ptr;
  1410.  
  1411.           if((TH_ptr=(TokenListHeader *) calloc(1,sizeof(TokenListHeader)))
  1412.         == (TokenListHeader *) NULL){
  1413.        fprintf(stderr,"Out of space for token list");
  1414.        exit(1);
  1415.     }
  1416.  
  1417.     TH_ptr->line_num = t->line_num;
  1418.       TH_ptr->filename = current_filename;
  1419.                 /* Clear all the flags */
  1420.     TH_ptr->external_decl = FALSE;
  1421.     TH_ptr->actual_arg = FALSE;
  1422.     TH_ptr->tokenlist = NULL;
  1423.     TH_ptr->next = NULL;
  1424.  
  1425.   return TH_ptr;
  1426. }
  1427.  
  1428.         /* this routine allocates room in global part (top down)
  1429.            of stringspace for string s, and copies it there */
  1430. char *
  1431. new_global_string(s)
  1432.     char *s;
  1433. {
  1434.     glob_str_bot -= strlen(s) + 1;    /*pre-decrement*/
  1435.     if( glob_str_bot < loc_str_top ) {
  1436.         fprintf(stderr,"\noops: out of global stringspace.\n");
  1437.         exit(1);
  1438.     }
  1439.     return strcpy(strspace+glob_str_bot,s);
  1440. }/*new_global_string*/
  1441.  
  1442.         /* Allocate space for string s in local (bottom up)
  1443.            string space, and copy it there */
  1444. char *
  1445. new_local_string(s)
  1446.     char *s;
  1447. {
  1448.     char *start = strspace + loc_str_top;
  1449.     loc_str_top += strlen(s) + 1;    /* post-increment */
  1450.     if(loc_str_top > glob_str_bot) {
  1451.         fprintf(stderr,"\noops: out of stringspace\n");
  1452.          exit(1);
  1453.     }
  1454.  
  1455.     return strcpy(start,s);
  1456. }/* new_local_string */
  1457.  
  1458. Token *
  1459. new_token()            /* Returns pointer to space for a token */
  1460. {
  1461.   if(token_space_top == TOKENSPACESZ)
  1462.     return (Token *)NULL;
  1463.   else
  1464.     return tokenspace + token_space_top++;
  1465. }
  1466.  
  1467.     /* note_filename():  This routine is called by main prog to give
  1468.        symbol table routines access to current input file name, to be
  1469.        stored in function arg list headers and common list headers, for
  1470.        the use in diagnostic messages. Since filenames are from argv,
  1471.        they are permanent, so pointer is copied, not the string.
  1472.     */
  1473. void
  1474. note_filename(s)
  1475.     char *s;
  1476. {
  1477.     current_filename = s;
  1478.     top_filename = s;
  1479. }/* note_filename */
  1480.  
  1481.  
  1482.  
  1483. void
  1484. process_lists(curmodhash)  /* Places pointer to linked list of arrays in
  1485.                   global symbol table */
  1486.     int curmodhash;    /* current_module_hash from fortran.y */
  1487. {
  1488.     int i, h;
  1489.     unsigned long hnum;
  1490.     Gsymtab *curr_gsymt;
  1491.  
  1492.     Gsymtab *gsymt;
  1493.     TokenListHeader *head_ptr;
  1494.  
  1495.     if( (curr_gsymt=
  1496.          (curmodhash == -1) ? NULL:hashtab[curmodhash].glob_symtab)
  1497.        == NULL) {
  1498.       fprintf(stderr,"\nOops: module %s not in global symtab",
  1499.           hashtab[curmodhash].name);
  1500.     }
  1501.     else {
  1502.       if(curr_gsymt->internal_entry) {/* protect ourself */
  1503.         fprintf(list_fd,"\nWarning: entry point %s redefined as module",
  1504.             curr_gsymt->name);
  1505.         fprintf(list_fd,": previous definition overridden");
  1506.         curr_gsymt->link.child_list = NULL;
  1507.       }
  1508.       curr_gsymt->internal_entry = FALSE;
  1509.     }
  1510.  
  1511.     for (i=0; i<loc_symtab_top; i++){
  1512.                 /* Skip things which are not true externals */
  1513.         if(loc_symtab[i].argument || loc_symtab[i].intrinsic ||
  1514.            loc_symtab[i].array_var)
  1515.               continue;
  1516.  
  1517.         head_ptr = loc_symtab[i].info.toklist;
  1518.  
  1519.         hnum=hash(loc_symtab[i].name);
  1520.         while(h=hnum%HASHSZ,hashtab[h].name != NULL
  1521.          && strcmp(hashtab[h].name,loc_symtab[i].name)!=0){
  1522.               hnum = rehash(hnum);      /* Resolve clashes */
  1523.         }
  1524.  
  1525.         switch (storage_class_of(loc_symtab[i].type)){
  1526.             case class_COMMON_BLOCK:
  1527.             if(head_ptr != NULL) {
  1528. if((gsymt=hashtab[h].com_glob_symtab) == NULL)
  1529.     fprintf(stderr,"\nOops! common block %s not in global symtab",
  1530.     loc_symtab[i].name);
  1531. else {
  1532.             Token *tok_ptr;
  1533.                         ComListHeader *c;
  1534.  
  1535.                 /* First we link up possibly multiple
  1536.                    declarations of the same common block
  1537.                    in this module into one big list */
  1538.                 while (tok_ptr = head_ptr->tokenlist,
  1539.                    (head_ptr = head_ptr->next) != NULL){
  1540.                 while(tok_ptr->next_token != NULL){
  1541.                     tok_ptr = tok_ptr->next_token;
  1542.                 }
  1543.                 tok_ptr->next_token = head_ptr->tokenlist;
  1544.             }
  1545.  
  1546.                 /* Now make it into array for global table */
  1547.                 c=make_com_array(loc_symtab[i].info.toklist->tokenlist);
  1548.             c->module = curr_gsymt;
  1549.             c->line_num = loc_symtab[i].info.toklist->line_num;
  1550.             c->filename = loc_symtab[i].info.toklist->filename;
  1551.             c->topfile = top_filename;
  1552.  
  1553.                         c->next = gsymt->info.comlist;
  1554.             gsymt->info.comlist = c;
  1555.         /* Replace token list by comlist for project file use */
  1556.             loc_symtab[i].info.comlist = c;
  1557. }
  1558.             }/* end if(head_ptr != NULL) */
  1559.  
  1560.                 break;    /* end case class_COMMON_BLOCK */
  1561.  
  1562.  
  1563.             /* Are we inside a function or subroutine? */
  1564.             case class_VAR:
  1565.                if(loc_symtab[i].entry_point) {
  1566. if((gsymt=hashtab[h].glob_symtab) == NULL)
  1567.     fprintf(stderr,"\nOops! subprog %s not in global symtab",
  1568.     loc_symtab[i].name);
  1569. else {
  1570.                           ArgListHeader *a;
  1571.  
  1572.                 /* Make each token list into an array of
  1573.                    args for global table */
  1574.               while (head_ptr != NULL){
  1575.                  a=make_dummy_arg_array(head_ptr->tokenlist);
  1576.  
  1577.                  a->type = type_byte(
  1578.                      class_SUBPROGRAM,
  1579.                  get_type(&(loc_symtab[i])));
  1580.                  a->module = curr_gsymt;
  1581.                  a->filename = head_ptr->filename;
  1582.                  a->topfile = top_filename;
  1583.                  a->line_num = head_ptr->line_num;
  1584.  
  1585.                  a->next = gsymt->info.arglist;
  1586.                  gsymt->info.arglist = a;
  1587.             /* store arglist in local symtab for project file */
  1588.                  loc_symtab[i].info.arglist = a;
  1589.                  head_ptr = head_ptr->next;
  1590.                   }/* end while (head_ptr != NULL) */
  1591.  
  1592.               if(loc_symtab[i].set_flag)
  1593.                      gsymt->set_flag = TRUE;
  1594.               if(loc_symtab[i].used_flag)
  1595.                      gsymt->used_flag = TRUE;
  1596.               if(loc_symtab[i].declared_external)
  1597.                  gsymt->declared_external = TRUE;
  1598.               if(loc_symtab[i].library_module)
  1599.                  gsymt->library_module = TRUE;
  1600.               if(gsymt != curr_gsymt) {
  1601.                 gsymt->internal_entry = TRUE;
  1602.                 gsymt->link.module = curr_gsymt;
  1603.               }
  1604. }
  1605.             }/* end if(loc_symtab[i].entry_point) */
  1606.  
  1607.                 break; /* end case class_VAR */
  1608.  
  1609.                     case class_SUBPROGRAM:
  1610. if((gsymt=hashtab[h].glob_symtab) == NULL)
  1611.     fprintf(stderr,"\nOops! subprog %s not in global symtab",
  1612.     loc_symtab[i].name);
  1613. else {
  1614.                         ArgListHeader *a;
  1615.             while (head_ptr != NULL){
  1616.               if(head_ptr->external_decl || head_ptr->actual_arg)
  1617.                 a=make_arrayless_alist();
  1618.               else
  1619.                 a=make_arg_array(head_ptr->tokenlist);
  1620.  
  1621.               a->type = type_byte(
  1622.                      class_SUBPROGRAM,
  1623.                  get_type(&(loc_symtab[i])));
  1624.               a->module = curr_gsymt;
  1625.               a->filename = head_ptr->filename;
  1626.               a->topfile = top_filename;
  1627.               a->line_num = head_ptr->line_num;
  1628.               a->external_decl = head_ptr->external_decl;
  1629.               a->actual_arg = head_ptr->actual_arg;
  1630.  
  1631.               a->next = gsymt->info.arglist;
  1632.               gsymt->info.arglist = a;
  1633.         /* put arglist into local symtab for project file use */
  1634.               loc_symtab[i].info.arglist = a;
  1635.               head_ptr = head_ptr->next;
  1636.                 }
  1637.             if(loc_symtab[i].used_flag)
  1638.                     gsymt->used_flag = TRUE;
  1639. if(debug_glob_symtab)
  1640. fprintf(list_fd,"\nmodule %s local used=%d global used=%d",
  1641. gsymt->name,loc_symtab[i].used_flag,gsymt->used_flag);
  1642. }
  1643.                 /* Add this guy to linked list of children,
  1644.                    unless never actually used. */
  1645.             if(loc_symtab[i].used_flag) {
  1646.               ChildList *node=
  1647.                 (ChildList *)calloc(1,sizeof(ChildList));
  1648.               node->child = gsymt;
  1649.               node->next = curr_gsymt->link.child_list;
  1650.               curr_gsymt->link.child_list = node;
  1651.             }
  1652.  
  1653.             break;/* end case class_SUBPROGRAM*/
  1654.  
  1655.         }/* end switch */
  1656.  
  1657.         }/* end for (i=0; i<loc_symtab_top; i++) */
  1658.  
  1659. }/* process_lists */
  1660.  
  1661.  
  1662. void
  1663. ref_array(id,subscrs)   /* Array reference: install in symtab */
  1664.     Token *id, *subscrs;
  1665. {
  1666.     int h=id->value.integer;
  1667.     Lsymtab *symt=hashtab[h].loc_symtab;
  1668.  
  1669.     if(symt == NULL){
  1670.        fprintf(stderr, "\nOops -- undeclared variable %s has dim info",
  1671.                 hashtab[h].name);
  1672.        symt = install_local(h,type_UNDECL,class_VAR);
  1673.     }
  1674.     else{    /* check that subscrs match dimension info */
  1675.  
  1676.  
  1677.       if(arg_count(subscrs->next_token)!=array_dims(symt->info.array_dim)){
  1678.           syntax_error(subscrs->line_num,subscrs->col_num,
  1679.             "array");
  1680.           msg_tail(symt->name);
  1681.           msg_tail("referenced with wrong no. of subscripts");
  1682.       }
  1683.     }
  1684. }/* ref_array */
  1685.  
  1686. void
  1687. ref_namelist(id,stmt_class)
  1688.      Token *id;
  1689.      int stmt_class;
  1690. {
  1691.     int numargs=0;
  1692.     Token *t;
  1693.     TokenListHeader *toklist;
  1694.     int h=id->value.integer;
  1695.     Lsymtab *symt=hashtab[h].loc_symtab;
  1696.     if(symt == NULL){
  1697.        fprintf(stderr, "\nOops -- undeclared identifier %s is a namelist",
  1698.                 hashtab[h].name);
  1699.        symt = install_local(h,type_NAMELIST,class_NAMELIST);
  1700.        symt->info.toklist = NULL;
  1701.     }
  1702.  
  1703.             /* Go thru token list of namelist variables,
  1704.                setting flags appropriately. */
  1705.     toklist = symt->info.toklist;
  1706.     if (toklist != NULL){
  1707.         t = toklist->tokenlist;
  1708.         while(t != NULL){
  1709.             if(stmt_class == tok_READ)
  1710.           use_lvalue(t);
  1711.         else
  1712.           use_variable(t);
  1713.         t = t->next_token;
  1714.         }
  1715.     }
  1716. }
  1717.  
  1718. void
  1719. ref_variable(id)    /* Variable reference: install in symtab */
  1720.     Token *id;
  1721. {
  1722.     int h=id->value.integer;
  1723.  
  1724.     if( hashtab[h].loc_symtab == NULL) {
  1725.        (void) install_local(h,type_UNDECL,class_VAR);
  1726.     }
  1727.  
  1728. }/*ref_variable*/
  1729.  
  1730.         /* this guy reverses a tokenlist and returns a pointer
  1731.            to the new head. */
  1732. PRIVATE Token *
  1733. reverse_tokenlist(t)
  1734.     Token *t;
  1735. {
  1736.     Token *curr,*next,*temp;
  1737.  
  1738.     if(t == NULL)
  1739.         return t;
  1740.  
  1741.     curr = t;
  1742.     next = curr->next_token;
  1743.     while(next != NULL) {
  1744.         temp = next->next_token;
  1745.         next->next_token = curr;
  1746.         curr = next;
  1747.         next = temp;
  1748.     }
  1749.     t->next_token = NULL;        /* former head is now tail */
  1750.     return curr;            /* curr now points to new head */
  1751. }
  1752.  
  1753.     /* Following routine sets the implicit typing of characters in
  1754.        range c1 to c2 to the given type. */
  1755. void
  1756. set_implicit_type(type,c1,c2)
  1757.     int type,        /* Data type of IMPLICIT declaration */
  1758.         c1,            /* First character of range */
  1759.         c2;            /* Last character of range */
  1760. {
  1761.     int c;
  1762.  
  1763.     if(c2 < c1) {
  1764.         yyerror("IMPLICIT range must be in alphabetical order");
  1765.     }
  1766.  
  1767.         /* Fill in the lookup table for the given range of chars */
  1768.     for(c=c1; c<=c2; c++)
  1769.         implicit_type[c-'A'] = type;
  1770. }/*set_implicit_type*/
  1771.  
  1772.         /* Finish processing statement function.
  1773.            Clears all used-before-set flags of ordinary
  1774.            variables. Reason: statement functions are processed
  1775.            like assignment to an array element, setting ubs flags.
  1776.            At this point, no valid setting of ubs flags should
  1777.            be possible, so clearing them will elim false messages.*/
  1778. void
  1779. stmt_function_stmt(id)
  1780.      Token *id;
  1781. {
  1782.     int i;
  1783.     for(i=0; i<loc_symtab_top; i++) {
  1784.     if(storage_class_of(loc_symtab[i].type) == class_VAR &&
  1785.        ! loc_symtab[i].parameter )
  1786.       loc_symtab[i].used_before_set = FALSE;
  1787.     }
  1788. }/*stmt_function_stmt(id)*/
  1789.  
  1790. char *
  1791. token_name(t)
  1792.     Token t;
  1793. {
  1794.     return hashtab[t.value.integer].name;
  1795. }/*token_name*/
  1796.  
  1797.  
  1798.  
  1799.  
  1800. void
  1801. use_actual_arg(id)    /* like use_lvalue except does not set assigned_flag */
  1802.     Token *id;
  1803. {
  1804.     int h=id->value.integer;
  1805.     Lsymtab *symt;
  1806.  
  1807.     if((symt=hashtab[h].loc_symtab) == NULL) {
  1808.         symt = install_local(h,type_UNDECL,class_VAR);
  1809.     }
  1810.     else {
  1811.             /* if an external, set up tokenlist for "call"  */
  1812.       if(storage_class_of(symt->type) == class_SUBPROGRAM) {
  1813.           TokenListHeader *TH_ptr;
  1814.           TH_ptr= make_TL_head(id);
  1815.  
  1816.           TH_ptr->actual_arg = TRUE;
  1817.           TH_ptr->next = symt->info.toklist;
  1818.           symt->info.toklist = TH_ptr;
  1819.       }
  1820.     }
  1821.  
  1822.     {        /* set flags for all equivalenced vars */
  1823.       Lsymtab *equiv=symt;
  1824.       do{
  1825.     equiv->set_flag = TRUE;
  1826.     equiv = equiv->equiv_link;
  1827.       } while(equiv != symt);
  1828.     }
  1829.  
  1830. }/*use_actual_arg*/
  1831.  
  1832.  
  1833. void
  1834. use_function_arg(id)    /* Like use_variable but invokes use_actual_arg
  1835.                if id is an external (subprogram) passed as
  1836.                arg of a function. This routine is used when
  1837.                pure_functions flag is set. */
  1838.     Token *id;
  1839. {
  1840.     int h=id->value.integer;
  1841.     Lsymtab *symt;
  1842.  
  1843.     if( (symt=hashtab[h].loc_symtab) == NULL) {
  1844.        symt = install_local(h,type_UNDECL,class_VAR);
  1845.     }
  1846.  
  1847.     if(storage_class_of(symt->type) == class_SUBPROGRAM)
  1848.       use_actual_arg(id);
  1849.     else
  1850.       use_variable(id);
  1851.  
  1852. }/*use_function_arg*/
  1853.  
  1854. void
  1855. use_implied_do_index(id)
  1856.     Token *id;
  1857. {
  1858.         /* Like use_lvalue and use_variable but clears ubs flag.
  1859.                This is because we cannot handle used-before-set
  1860.            properly in this case, and the odds are that ubs
  1861.            was set in the preceding I/O list. */
  1862.     int h=id->value.integer;
  1863.     Lsymtab *symt;
  1864.  
  1865.     use_lvalue(id);
  1866.     use_variable(id);
  1867.     symt=hashtab[h].loc_symtab;
  1868.  
  1869.     symt->used_before_set = FALSE;
  1870. }/*use_implied_do_index*/
  1871.  
  1872.  
  1873.     /* use_io_keyword handles keyword=value fields in i/o control lists */
  1874.  
  1875. #include "iokeywds.h"
  1876.  
  1877. void
  1878. use_io_keyword(keyword,value,stmt_class)
  1879.      Token *keyword,*value;
  1880.      int stmt_class;
  1881. {
  1882.     int i, k, stmt_flag=0, type_flag, setit,useit;
  1883.     int hkey=keyword->value.integer;
  1884.  
  1885.         /* Convert statement_class (a token class) into
  1886.            a bit flag compatible with io_keywords table. */
  1887.     for(i=0; i<NUM_IO_STMTS; i++) {
  1888.     if(local_class[i].stmt_class == stmt_class) {
  1889.         stmt_flag = local_class[i].stmt_flag;
  1890.         break;
  1891.     }
  1892.     }
  1893.     if(stmt_flag == 0) {
  1894.     fprintf(list_fd,"\nOops -- %d is not an i/o statement class",
  1895.         stmt_class);
  1896.     return;
  1897.     }
  1898.         /* Convert value datatype into
  1899.            a bit flag compatible with io_keywords table.
  1900.            Note that '*' is handled by using type_UNDECL */
  1901.     if(value->class == '*')
  1902.     type_flag = STAR;
  1903.     else
  1904.     type_flag = (1<<datatype_of(value->class));
  1905.  
  1906.                 /* Look up keyword in table*/
  1907.     k = find_io_keyword(hashtab[hkey].name);
  1908.  
  1909.         /* Not found or nonstandard: issue warning.  Note
  1910.            that not-found is also nonstandard. */
  1911.     if(io_keywords[k].nonstandard
  1912. #ifdef VMS_IO /* special VMS case: OPEN(...,NAME=str,...) */
  1913.        || (io_keywords[k].special && stmt_flag==OP)
  1914. #endif /*VMS_IO*/
  1915.        ) {
  1916.         /* If nonstandard and -f77 flag given, issue warning */
  1917.     if(f77_standard) {
  1918.         nonstandard(keyword->line_num,keyword->col_num);
  1919.     }
  1920.     if(io_keywords[k].name == NULL) {
  1921.         if(f77_standard) {    /* abbrev warning if nonstd message given */
  1922.         msg_tail(": unrecognized keyword");
  1923.         }
  1924.         else {
  1925.         warning(keyword->line_num,keyword->col_num,
  1926.         "Unrecognized keyword");
  1927.         }
  1928.         msg_tail(hashtab[hkey].name);
  1929.         msg_tail("--\n  Ftnchek may process incorrectly");
  1930.     }
  1931.     }
  1932.  
  1933.     /* If label expected, switch integer const to label */
  1934.     if( (LAB & io_keywords[k].allowed_types)
  1935.        &&  (type_flag == INT && is_true(NUM_CONST,value->subclass))) {
  1936.     type_flag = LAB;
  1937.     }
  1938.  
  1939.     /*  Now check it out */
  1940.  
  1941.  
  1942.         /* Check if keyword is allowed with statement */
  1943.  
  1944.     if(!(stmt_flag & io_keywords[k].allowed_stmts)) {
  1945.     syntax_error(keyword->line_num,keyword->col_num,
  1946.              "keyword illegal in this context");
  1947.     return;
  1948.     }
  1949.  
  1950.         /* Check if the type is OK */
  1951.  
  1952.     if( !(type_flag & io_keywords[k].allowed_types) ) {
  1953.     syntax_error(value->line_num,value->col_num,
  1954.              "control specifier is incorrect type");
  1955.     return;
  1956.     }
  1957.  
  1958.  
  1959.     /* Now handle usage */
  1960.  
  1961.                 /* internal file?: WRITE(UNIT=str,...) */
  1962.     if(stmt_flag == WR && type_flag == CHR
  1963.         && io_keywords[k].allowed_types == UID) {
  1964.     setit = TRUE;
  1965.     useit = FALSE;
  1966.     }
  1967.                 /* INQUIRE: set it if inquire_set flag true */
  1968.     else if(stmt_flag == INQ && io_keywords[k].inquire_set) {
  1969.     setit = TRUE;
  1970.     useit = FALSE;
  1971.     }
  1972.                 /* otherwise use use/set flags in table */
  1973.     else {
  1974.     useit = io_keywords[k].implies_use;
  1975.     setit = io_keywords[k].implies_set;
  1976.     }
  1977.  
  1978.             /* Handle NML=namelist */
  1979.     if(type_flag == NML){
  1980.       ref_namelist(value,stmt_class);
  1981.     }
  1982.             /* Update usage status if a variable. */
  1983.     if(useit) {
  1984.     if( is_true(ID_EXPR,value->subclass)) {
  1985.         use_variable(value);
  1986.     }
  1987.     }
  1988.     if(setit) {            /* if value is set, must be an lvalue */
  1989.     if( is_true(ID_EXPR,value->subclass)) {
  1990.         use_lvalue(value);
  1991.     }
  1992.     else {
  1993.         syntax_error(value->line_num,value->col_num,
  1994.              "variable required");
  1995.         return;
  1996.     }
  1997.     }
  1998. }
  1999.  
  2000.  
  2001.         /* Handle VMS OPEN keywords that have no =value */
  2002. void
  2003. use_special_open_keywd(id)
  2004.      Token *id;
  2005. {
  2006. #ifdef VMS_IO
  2007.   int i;
  2008.   char *id_name= hashtab[id->value.integer].name;
  2009.  
  2010.   for(i=0; i<NUM_SPECIAL_OPEN_KEYWDS; i++) {
  2011.     if(strcmp(id_name,special_open_keywds[i]) == 0) {
  2012.                 /* found: report nonstandard if requested */
  2013.       if(f77_standard)
  2014.     nonstandard(id->line_num,id->col_num);
  2015.       return;
  2016.     }
  2017.   }
  2018. #endif/*VMS_IO*/
  2019.                 /* not found or not VMS: report error */
  2020.   syntax_error(id->line_num,id->col_num,
  2021.            "Illegal control-list item");
  2022. }
  2023.  
  2024. void
  2025. use_lvalue(id)    /* handles scalar lvalue */
  2026.     Token *id;
  2027. {
  2028.     int h=id->value.integer;
  2029.     Lsymtab *symt;
  2030.     if((symt=hashtab[h].loc_symtab) == NULL) {
  2031.         symt = install_local(h,type_UNDECL,class_VAR);
  2032.     }
  2033.     else {
  2034.       /*   check match to previous invocations and update  */
  2035.     }
  2036.     {        /* set flags for all equivalenced vars */
  2037.       Lsymtab *equiv=symt;
  2038.       do{
  2039.     equiv->set_flag = TRUE;
  2040.     equiv->assigned_flag = TRUE;
  2041.     equiv = equiv->equiv_link;
  2042.       } while(equiv != symt);
  2043.     }
  2044.  
  2045. }/*use_lvalue*/
  2046.  
  2047.  
  2048.  
  2049. void                    /* Process data_constant_value & data_repeat_factor */
  2050. use_parameter(id)
  2051.     Token *id;
  2052. {
  2053.     int h=id->value.integer;
  2054.     Lsymtab *symt;
  2055.  
  2056.     if( (symt=hashtab[h].loc_symtab) == NULL) {
  2057.        symt = install_local(h,type_UNDECL,class_VAR);
  2058.     }
  2059.     if(! symt->parameter) {
  2060.         syntax_error(id->line_num,id->col_num,
  2061.             "must be a parameter");
  2062.         symt->parameter = TRUE;
  2063.     }
  2064.  
  2065.     if(! symt->set_flag) {
  2066.        symt->used_before_set = TRUE;
  2067.     }
  2068.     symt->used_flag = TRUE;
  2069.  
  2070. }/*use_parameter*/
  2071.  
  2072.  
  2073. void
  2074. use_variable(id)        /* Set the use-flag of variable. */
  2075.     Token *id;
  2076. {
  2077.     int h=id->value.integer;
  2078.     Lsymtab *symt;
  2079.  
  2080.     if( (symt=hashtab[h].loc_symtab) == NULL) {
  2081.        symt = install_local(h,type_UNDECL,class_VAR);
  2082.     }
  2083.  
  2084.     {        /* set flags for all equivalenced vars */
  2085.       Lsymtab *equiv=symt;
  2086.       do{
  2087.     if(! equiv->set_flag) {
  2088.        equiv->used_before_set = TRUE;
  2089.     }
  2090.     equiv->used_flag = TRUE;
  2091.     equiv = equiv->equiv_link;
  2092.       } while(equiv != symt);
  2093.     }
  2094.  
  2095. }/*use_variable*/
  2096.  
  2097.  
  2098. /*  End of symtab.c */
  2099.  
  2100. /*
  2101.  
  2102.  II. Hash
  2103.  
  2104. */
  2105.  
  2106. /*    hash.c:
  2107.      performs a hash function
  2108.  
  2109. This was formerly a separate file.
  2110.  
  2111. */
  2112.  
  2113. extern int sixclash;    /* flag to check clashes in 1st 6 chars of name */
  2114.  
  2115. unsigned long
  2116. hash(s)
  2117.     char *s;
  2118. {
  2119.     unsigned long sum = 0, wd;
  2120.     int i = 0,j;
  2121.  
  2122.     int n = strlen(s);
  2123.     if(sixclash && n > 6) n = 6;
  2124.  
  2125.     while (i < n) {
  2126.          wd = 0;
  2127.          for(j=1; j <= sizeof(long) && i < n; i++,j++) {
  2128.             wd += (unsigned long)(s[i] & 0xff) << (sizeof(long) - j) * 8;}
  2129.  
  2130.     sum ^= wd;}
  2131.     return sum;
  2132. }
  2133.  
  2134.         /* Same as hash() but always uses full length of keyword.
  2135.            To keep the keyword table clash-free on any machine,
  2136.            packs only 4 bytes per word even if long is bigger */
  2137. unsigned long
  2138. kwd_hash(s)
  2139.     char *s;
  2140. {
  2141.     unsigned long sum = 0, wd;
  2142.     int i = 0,j;
  2143.  
  2144.     int n = strlen(s);
  2145.  
  2146.     while (i < n) {
  2147.          wd = 0;
  2148.          for(j=1; j <= 4 && i < n; i++,j++) {
  2149.             wd += (unsigned long)(s[i] & 0xff) << (4 - j) * 8;}
  2150.  
  2151.     sum ^= wd;}
  2152.     return sum;
  2153. }
  2154.  
  2155.  
  2156.  
  2157. /*    rehash.c
  2158.         performs a rehash for resolving clashes.
  2159. */
  2160.  
  2161. #ifdef COUNT_REHASHES
  2162. unsigned long rehash_count=0;
  2163. #endif
  2164.  
  2165. unsigned long
  2166. rehash(hnum)
  2167.     unsigned long hnum;
  2168. {
  2169. #ifdef COUNT_REHASHES
  2170.     rehash_count++;
  2171. #endif
  2172.     return hnum+1;
  2173. }
  2174.  
  2175.  
  2176. /*  End of hash */
  2177.  
  2178.  
  2179. /*
  2180.  
  2181. III. Intrins
  2182.  
  2183. */
  2184.  
  2185. /* intrinsic.c:
  2186.  
  2187.     Handles datatyping of intrinsic functions.
  2188. */
  2189.  
  2190.  
  2191.     /* File intrinsic.h contains information from Table 5, pp. 15-22
  2192.        to 15-25 of the standard.  Note: num_args == -1 means 1 or 2 args,
  2193.        num_args == -2 means 2 or more args.  Value of arg_type is the OR
  2194.        of all allowable types (I, R, etc. as defined above).  Value of
  2195.        result_type is type returned by function (type_INTEGER, etc.).
  2196.        If result_type is type_GENERIC, function type is same as arg type.
  2197.     */
  2198.  
  2199.  
  2200. IntrinsInfo intrinsic[]={
  2201. #include "intrins.h"
  2202. };
  2203.  
  2204. #define NUM_INTRINSICS (sizeof(intrinsic)/sizeof(intrinsic[0]))
  2205.  
  2206. #define EMPTY 255
  2207.  
  2208. unsigned char intrins_hashtab[INTRINS_HASHSZ];
  2209.  
  2210. /*    init_intrins_hashtab:
  2211.                  Initializes the intrinsic hash table by clearing it to EMPTY
  2212.                  and then hashes all the intrinsic names into the table.
  2213. */
  2214.  
  2215. unsigned long
  2216. init_intrins_hashtab()
  2217. {
  2218.     unsigned i,h;
  2219.     unsigned long hnum;
  2220.     unsigned long numclashes=0;
  2221.  
  2222.     for(h=0;h<INTRINS_HASHSZ;h++) {
  2223.            intrins_hashtab[h] = EMPTY;
  2224.     }
  2225.     for(i=0; i < NUM_INTRINSICS; i++) {
  2226.        hnum = kwd_hash(intrinsic[i].name);
  2227.        while(h=hnum%INTRINS_HASHSZ, intrins_hashtab[h] != EMPTY) {
  2228.         hnum = rehash(hnum);
  2229.         numclashes++;
  2230.        }
  2231.        intrins_hashtab[h] = i;
  2232.     }
  2233.     return numclashes;
  2234. }
  2235.  
  2236.     /* Function to look up an intrinsic function name in table.
  2237.        If found, returns ptr to table entry, otherwise NULL.
  2238.     */
  2239. PRIVATE IntrinsInfo *
  2240. find_intrinsic(s)
  2241.     char *s;            /* given name */
  2242. {
  2243.     unsigned i, h;
  2244.     unsigned long hnum;
  2245.  
  2246.     hnum = kwd_hash(s);
  2247.     while( h=hnum%INTRINS_HASHSZ, (i=intrins_hashtab[h]) != EMPTY &&
  2248.         strcmp(s,intrinsic[i].name) != 0) {
  2249.             hnum = rehash(hnum);
  2250.     }
  2251.  
  2252.     if(i != EMPTY) {
  2253.         return &intrinsic[i];
  2254.     }
  2255.     else
  2256.         return (IntrinsInfo *)NULL;
  2257. }
  2258.  
  2259.     /* find_io_keyword looks up an i/o keyword in io_keywords
  2260.        table and returns its index.  Uses simple linear search
  2261.        since not worth hash overhead.  If not found, returns
  2262.        index of last element of list, which is special. */
  2263. PRIVATE int
  2264. find_io_keyword(s)
  2265.      char *s;            /* given name */
  2266. {
  2267.     int i;
  2268.     for(i=0; io_keywords[i].name != NULL; i++) {
  2269.     if(strcmp(io_keywords[i].name, s) == 0) {
  2270.         break;
  2271.     }
  2272.     }
  2273.     return i;
  2274. }
  2275.  
  2276.