home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / FTNCHK32.ZIP / symtab2.c < prev    next >
C/C++ Source or Header  |  1993-02-16  |  38KB  |  1,311 lines
  1. /* symtab2.c:
  2.  
  3.     Contains two formerly independent files:
  4.        I.  exprtype.c -- propagates datatype thru expressions.
  5.        II. project.c  -- project-file I/O routines.
  6.  
  7.     Copyright (C) 1992 by Robert K. Moniot.
  8.     This program is free software.  Permission is granted to
  9.     modify it and/or redistribute it, retaining this notice.
  10.     No guarantees accompany this software.
  11.  
  12.  
  13. */
  14.  
  15. /* I. */
  16.  
  17. /*  exprtype.c:
  18.  
  19.     Routines to propagate datatype through expressions.
  20.  
  21.     binexpr_type()        Yields result type of binary expression.
  22.     unexpr_type()        Yields result type of unary expression.
  23.     assignment_stmt_type()    Checks assignment statement type.
  24.     func_ref_expr(id,args,result) Forms token for a function invocation.
  25.     primary_id_expr()    Forms token for primary which is an identifier.
  26.     int    int_power(x,n)        Computes x**n for value propagation.
  27. */
  28.  
  29. #include <stdio.h>
  30. #include <string.h>
  31. #include "ftnchek.h"
  32. #include "symtab.h"
  33. #include "tokdefs.h"
  34.  
  35. PRIVATE int int_power();
  36.  
  37.     /* shorthand for datatypes.  must match those in symtab.h */
  38.  
  39. #define E 0    /*  Error for invalid type combos  */
  40. #define I 1
  41. #define R 2
  42. #define D 3
  43. #define C 4
  44. #define L 5
  45. #define S 6
  46. #define H 7
  47.  
  48. #define W 10+        /*  Warning for nonstandard type combos */
  49.  
  50.             /* for  + - / * **    ANSI book pp. 6-5,6-6    */
  51.                 /* Mixed double+complex = complex with warning */
  52. unsigned char arith_expr_type[8][8]={
  53. /*E   I   R   D   C   L   S   H   */
  54. { E,  E,  E,  E,  E,  E,  E,  E },    /* E */
  55. { E,  I,  R,  D,  C,  E,  E,  E },    /* I */
  56. { E,  R,  R,  D,  C,  E,  E,  E },    /* R */
  57. { E,  D,  D,  D,W C,  E,  E,  E },    /* D */
  58. { E,  C,  C,W C,  C,  E,  E,  E },    /* C */
  59. { E,  E,  E,  E,  E,  E,  E,  E },    /* L */
  60. { E,  E,  E,  E,  E,  E,  E,  E },    /* S */
  61. { E,  E,  E,  E,  E,  E,  E,  E }    /* H */
  62. };
  63.  
  64.             /* for  relops.  Corresponds to arith type table
  65.                except that nonstandard comparisons of like
  66.                types have warning, not error. */
  67. unsigned char rel_expr_type[8][8]={
  68. /*E   I   R   D   C   L   S   H   */
  69. { E,  E,  E,  E,  E,  E,  E,  E },    /* E */
  70. { E,  L,  L,  L,  L,  E,  E,W L },    /* I */
  71. { E,  L,  L,  L,  L,  E,  E,  E },    /* R */
  72. { E,  L,  L,  L,W L,  E,  E,  E },    /* D */
  73. { E,  L,  L,W L,  L,  E,  E,  E },    /* C */
  74. { E,  E,  E,  E,  E,W L,  E,W L },    /* L */
  75. { E,  E,  E,  E,  E,  E,  L,  E },    /* S */
  76. { E,W L,  E,  E,  E,W L,  E,W L }    /* H */
  77. };
  78.  
  79.             /* Result of assignment:  lvalue = expr.  Here rows
  80.                correspond to type of lvalue, columns to type
  81.                of expr */
  82. unsigned char assignment_type[8][8]={
  83. /*E   I   R   D   C   L   S   H   */
  84. { E,  E,  E,  E,  E,  E,  E,  E },    /* E */
  85. { E,  I,  I,  I,  I,  E,  E,W I },    /* I */
  86. { E,  R,  R,  R,  R,  E,  E,  E },    /* R */
  87. { E,  D,  D,  D,W D,  E,  E,  E },    /* D */
  88. { E,  C,  C,W C,  C,  E,  E,  E },    /* C */
  89. { E,  E,  E,  E,  E,  L,  E,W L },    /* L */
  90. { E,  E,  E,  E,  E,  E,  S,  E },    /* S */
  91. { E,  E,  E,  E,  E,  E,  E,  E }    /* H not possible for lvalue */
  92. };
  93.  
  94.     /* this routine propagates type in binary expressions */
  95.  
  96. void
  97. binexpr_type(term1,operator,term2,result)
  98.     Token *term1, *operator, *term2, *result;
  99. {
  100.     int    op = operator->class,
  101.     type1 = datatype_of(term1->class),
  102.     type2 = datatype_of(term2->class),
  103.     result_type;
  104.  
  105.     if( ! is_computational_type(type1) ) {
  106.         syntax_error(term1->line_num,term1->col_num,
  107.             "noncomputational primary in expression");
  108.         result_type = E;
  109.     }
  110.     else if( ! is_computational_type(type2) ) {
  111.         syntax_error(term2->line_num,term2->col_num,
  112.             "noncomputational primary in expression");
  113.         result_type = E;
  114.     }
  115.     else {
  116.     switch(op) {
  117.                 /* arithmetic operators: use lookup table */
  118.         case '+':
  119.         case '-':
  120.         case '*':
  121.         case '/':
  122.         case tok_power:
  123.         result_type = (unsigned)arith_expr_type[type1][type2];
  124.         break;
  125.  
  126.                 /* relational operators: use lookup table */
  127.          case tok_relop:
  128.         result_type = (unsigned)rel_expr_type[type1][type2];
  129.         break;
  130.  
  131.                 /*  logical operators: operands should be
  132.                     logical, but allow integers with a
  133.                     warning. */
  134.         case tok_AND:
  135.         case tok_OR:
  136.         case tok_EQV:
  137.         case tok_NEQV:
  138.         if(type1 == L && type2 == L)
  139.             result_type = L;
  140.         else if(type1 == I && type2 == I)
  141.             result_type = W I;
  142.         else
  143.             result_type = E;
  144.         break;
  145.  
  146.                 /*  // operator: operands must be strings */
  147.         case tok_concat:
  148.         if(type1 == S && type2 == S)
  149.             result_type = S;
  150.         else
  151.             result_type = E;
  152.         break;
  153.  
  154.         default:
  155.         syntax_error(operator->line_num,operator->col_num,
  156.             "oops--operator unknown: type not propagated");
  157.         result_type = type1;
  158.         break;
  159.     }
  160.  
  161.     if( (type1 != E && type2 != E) )
  162.         if( result_type == E) {
  163.         syntax_error(operator->line_num,operator->col_num,
  164.             "type mismatch in expression");
  165.         }
  166.         else if(result_type >= (W 0)) {    /* W result */
  167.           if(f77_standard)
  168.         warning(operator->line_num,operator->col_num,
  169.             "nonstandard type combination in expression");
  170.           result_type -= (W 0);
  171.         }
  172.     }
  173.  
  174.     result->class = type_byte(class_VAR, result_type);
  175.     result->subclass = 0;    /* clear all flags */
  176.  
  177.         /* Keep track of constant expressions */
  178.     if( is_true(CONST_EXPR,term1->subclass)
  179.      && is_true(CONST_EXPR,term2->subclass)
  180.          && !(op==tok_power && type2!=I) ) { /* exclude **REAL */
  181.         make_true(CONST_EXPR,result->subclass);
  182.     }
  183.         /* Parameter expressions are like constant exprs
  184.            except we bend the rules to allow intrinsic functions
  185.            and **REAL */
  186.     if( is_true(PARAMETER_EXPR,term1->subclass)
  187.      && is_true(PARAMETER_EXPR,term2->subclass) ) {
  188.         make_true(PARAMETER_EXPR,result->subclass);
  189.     }
  190.  
  191.         /* Remember if integer division was used */
  192.     if(result_type == type_INTEGER &&
  193.        (op == '/' ||
  194.         (is_true(INT_QUOTIENT_EXPR,term1->subclass) ||
  195.          is_true(INT_QUOTIENT_EXPR,term2->subclass))) ) {
  196.         make_true(INT_QUOTIENT_EXPR,result->subclass);
  197.     }
  198.  
  199.         /* Issue warning if integer expr involving division is
  200.            later converted to any real type, or if it is used
  201.            as an exponent. */
  202.     if( is_true(INT_QUOTIENT_EXPR,term1->subclass)
  203.     || is_true(INT_QUOTIENT_EXPR,term2->subclass) ) {
  204.  
  205.     int r=result_type;
  206.     if(r == type_LOGICAL)        /* relational tests are equivalent */
  207.         r = arith_expr_type[type1][type2];        /* to subtraction */
  208.  
  209.     if(op == tok_power && is_true(INT_QUOTIENT_EXPR,term2->subclass) ) {
  210.       if(trunc_check)
  211.         warning(operator->line_num,operator->col_num,
  212.             "integer quotient expr used in exponent");
  213.       if( ! is_true(INT_QUOTIENT_EXPR,term1->subclass) )
  214.         make_false(INT_QUOTIENT_EXPR,result->subclass);
  215.     }
  216.     else if( r == type_REAL || r == type_DP || r == type_COMPLEX) {
  217.       if(trunc_check)
  218.         warning(operator->line_num,operator->col_num,
  219.                 "integer quotient expr converted to real");
  220.     }
  221.     }
  222.  
  223.             /* If either term is an identifier, set use flag */
  224.     if(is_true(ID_EXPR,term1->subclass))
  225.     use_variable(term1);
  226.     if(is_true(ID_EXPR,term2->subclass))
  227.     use_variable(term2);
  228.  
  229.         /* Propagate the value of integer constant expressions */
  230.     if(is_true(CONST_EXPR,result->subclass)) {
  231.     if(result_type == type_INTEGER) {    /* Only ints propagated */
  232.       int a = int_expr_value(term1),
  233.           b = int_expr_value(term2),
  234.           c;
  235.       switch(op) {
  236.         case '+': c = a+b; break;
  237.         case '-': c = a-b; break;
  238.         case '*': c = a*b; break;
  239.         case '/': if(b == 0) {
  240.             syntax_error(term2->line_num,term2->col_num,
  241.                 "division by zero attempted");
  242.             c = 0;
  243.               }
  244.               else {
  245.             c = a/b;
  246.               }
  247.               break;
  248.         case tok_power: c = int_power(a,b); break;
  249.         case tok_AND: c = a&b; break;
  250.         case tok_OR: c = a|b; break;
  251.         case tok_EQV: c = ~(a^b); break;
  252.         case tok_NEQV: c = a^b; break;
  253.         default: fprintf(stderr,"Oops--invalid int expr operator");
  254.             c = 0; break;
  255.       }
  256.  
  257.       result->value.integer = c;    /* Result goes into token value */
  258.  
  259.                 /* Integer division (including i**neg)
  260.                    that yields 0 is suspicious.  */
  261.       if(trunc_check)
  262.         if(c==0 && (op=='/' || op==tok_power)) {
  263.           warning(operator->line_num,operator->col_num,
  264.                 "integer const expr yields result of 0");
  265.         }
  266.     }
  267.       }
  268.                 /* Also nonconstant**neg is 0 unless
  269.                    nonconstant=1 */
  270.       else if(trunc_check)
  271.     if(result_type == type_INTEGER && op == tok_power
  272.           && is_true(CONST_EXPR,term2->subclass)
  273.           && int_expr_value(term2) < 0) {
  274.       warning(operator->line_num,operator->col_num,
  275.           "integer to negative power usually yields 0");
  276.     }
  277.  
  278. }/*binexpr_type*/
  279.  
  280.  
  281.     /* this routine propagates type in unary expressions */
  282.  
  283. void
  284. unexpr_type(operator,term1,result)
  285.     Token *term1, *operator, *result;
  286. {
  287.    int    op = operator->class,
  288.     type1 = datatype_of(term1->class),
  289.     result_type;
  290.  
  291.     if( ! is_computational_type(type1) ) {
  292.         syntax_error(term1->line_num,term1->col_num,
  293.             "noncomputational primary in expression");
  294.         result_type = E;
  295.     }
  296.     else {
  297.     switch(op) {
  298.             /* arith operators: use diagonal of lookup table */
  299.         case '+':
  300.         case '-':
  301.         result_type = arith_expr_type[type1][type1];
  302.         break;
  303.  
  304.                 /*  NOT: operand should be
  305.                     logical, but allow integers with a
  306.                     warning. */
  307.         case tok_NOT:
  308.         if(type1 == L)
  309.             result_type = L;
  310.         else if(type1 == I)
  311.             result_type = W I;
  312.         else
  313.             result_type = E;
  314.         break;
  315.  
  316.         default:
  317.         syntax_error(operator->line_num,operator->col_num,
  318.             "oops: unary operator type not propagated");
  319.         result_type = type1;
  320.         break;
  321.     }
  322.  
  323.     if( type1 != E )
  324.         if( result_type == E) {
  325.         syntax_error(operator->line_num,operator->col_num,
  326.             "type mismatch in expression");
  327.         }
  328.         else if(result_type >= (W 0)) {
  329.           if(f77_standard)
  330.         warning(operator->line_num,operator->col_num,
  331.             "nonstandard type usage in expression");
  332.           result_type -= (W 0);
  333.         }
  334.     }
  335.  
  336.     result->class = type_byte(class_VAR, result_type);
  337.     result->subclass = 0;    /* clear all flags */
  338.  
  339.         /* Keep track of constant expressions */
  340.     copy_flag(CONST_EXPR,result->subclass,term1->subclass);
  341.     copy_flag(PARAMETER_EXPR,result->subclass,term1->subclass);
  342.  
  343.         /* Remember if integer division was used */
  344.     if(result_type == type_INTEGER)
  345.         copy_flag(INT_QUOTIENT_EXPR,result->subclass,term1->subclass);
  346.  
  347.     if(is_true(ID_EXPR,term1->subclass))
  348.     use_variable(term1);
  349.  
  350.         /* Propagate the value of integer constant expressions */
  351.     if(is_true(CONST_EXPR,result->subclass)) {
  352.     if(result_type == type_INTEGER) {    /* Only ints propagated */
  353.       int a = int_expr_value(term1),
  354.           c;
  355.       switch(op) {
  356.         case '+': c = a; break;
  357.         case '-': c = -a; break;
  358.         case tok_NOT: c = ~a; break;
  359.         default: fprintf(stderr,"Oops--invalid int expr operator");
  360.             c = 0; break;
  361.       }
  362.  
  363.       result->value.integer = c;    /* Result goes into token value */
  364.     }
  365.     }
  366. }
  367.  
  368.     /* this routine propagates type in assignment statements */
  369.  
  370. void
  371. assignment_stmt_type(term1,equals,term2)
  372.     Token *term1, *equals, *term2;
  373. {
  374.     int type1 = datatype_of(term1->class),
  375.     type2 = datatype_of(term2->class),
  376.     result_type;
  377.  
  378.  
  379.     if( ! is_computational_type(type1) ) {
  380.         syntax_error(term1->line_num,term1->col_num,
  381.             "noncomputational primary in expression");
  382.         result_type = E;
  383.     }
  384.     else if( ! is_computational_type(type2) ) {
  385.         syntax_error(term2->line_num,term2->col_num,
  386.             "noncomputational primary in expression");
  387.         result_type = E;
  388.     }
  389.     else {
  390.     result_type = (unsigned)assignment_type[type1][type2];
  391.  
  392.  
  393.     if( (type1 != E && type2 != E) )
  394.         if( result_type == E) {
  395.         syntax_error(equals->line_num,equals->col_num,
  396.             "type mismatch in assignment statement");
  397.         }
  398.         else if(result_type >= (W 0)) {        /* W result */
  399.           if(f77_standard)
  400.         warning(equals->line_num,equals->col_num,
  401.         "nonstandard type combination in assignment statement");
  402.           result_type -= (W 0);
  403.         }
  404.         else {    /* Watch for truncation to lower precision type */
  405.           if(trunc_check)
  406.         if(is_computational_type(result_type) &&
  407.            result_type < type2) {
  408.              warning(equals->line_num,equals->col_num,
  409.                      type_name[type2]);
  410.              msg_tail("truncated to");
  411.              msg_tail(type_name[result_type]);
  412.          }
  413.         }
  414.     }
  415.  
  416.  
  417.         /* Issue warning if integer expr involving division is
  418.            later converted to any real type. */
  419.     if(trunc_check)
  420.       if( is_true(INT_QUOTIENT_EXPR,term2->subclass) ) {
  421.  
  422.     int r=result_type;
  423.  
  424.     if( r == type_REAL || r == type_DP || r == type_COMPLEX)
  425.         warning(equals->line_num,equals->col_num,
  426.             "integer quotient expr converted to real");
  427.       }
  428.  
  429.  
  430.     if(is_true(ID_EXPR,term2->subclass))
  431.     use_variable(term2);
  432.  
  433.     use_lvalue(term1);
  434. }
  435.  
  436.     /* Make an expression-token for a function invocation */
  437.  
  438. void
  439. func_ref_expr(id,args,result)
  440.     Token *id,*args,*result;
  441. {
  442.     Lsymtab *symt;
  443.     IntrinsInfo *defn;
  444.     int rettype;
  445.  
  446.     symt = hashtab[id->value.integer].loc_symtab;
  447.  
  448.     if( symt->intrinsic ) {
  449.         defn = symt->info.intrins_info;
  450.             /* Intrinsic functions: type stored in info field */
  451.         rettype = defn->result_type;
  452.  
  453.         /* Generic Intrinsic functions: use arg type of 1st arg */
  454.         if(rettype == type_GENERIC) {
  455.         rettype = ( (args->next_token == NULL)?
  456.             type_UNDECL : args->next_token->class );
  457.                         /* special case */
  458.         if(rettype == type_COMPLEX && strcmp(symt->name,"ABS") == 0)
  459.             rettype = type_REAL;
  460.         }
  461.     }
  462.     else {
  463.         rettype = get_type(symt);
  464.     }
  465.         /* referencing function makes it no longer a class_SUBPROGRAM
  466.            but an expression. */
  467.     result->class = type_byte(class_VAR,rettype);
  468.     result->subclass = 0;    /* clear all flags */
  469.  
  470.         /* If intrinsic and all arguments are PARAMETER_EXPRs,
  471.            then result is one too. */
  472.     if( symt->intrinsic ) {
  473.       while( (args=args->next_token) != NULL ) {
  474.         if( !is_true(PARAMETER_EXPR,args->subclass) )
  475.           return;
  476.       }
  477.       make_true(PARAMETER_EXPR,result->subclass);
  478.     }
  479. }
  480.  
  481.  
  482.  
  483.         /* Make an expression-token for primary consisting of
  484.            a symbolic name */
  485.  
  486. void
  487. primary_id_expr(id,primary)
  488.     Token *id,*primary;
  489. {
  490.     Lsymtab *symt;
  491.     symt = hashtab[id->value.integer].loc_symtab;
  492.     primary->class = type_byte( storage_class_of(symt->type),
  493.                           get_type(symt) );
  494.     primary->subclass = 0;
  495.  
  496.     make_true(ID_EXPR,primary->subclass);
  497.  
  498.     if( storage_class_of(symt->type) == class_VAR) {
  499.         if(symt->parameter) {
  500.             make_true(CONST_EXPR,primary->subclass);
  501.             make_true(PARAMETER_EXPR,primary->subclass);
  502.         }
  503.         else {
  504.             make_true(LVALUE_EXPR,primary->subclass);
  505.         }
  506.         if(symt->array_var)
  507.             make_true(ARRAY_ID_EXPR,primary->subclass);
  508.         if(symt->set_flag || symt->common_var || symt->parameter
  509.                   || symt->argument)
  510.             make_true(SET_FLAG,primary->subclass);
  511.         if(symt->assigned_flag)
  512.             make_true(ASSIGNED_FLAG,primary->subclass);
  513.         if(symt->used_before_set)
  514.             make_true(USED_BEFORE_SET,primary->subclass);
  515.     }
  516.     else if(storage_class_of(symt->type) == class_STMT_FUNCTION) {
  517.         make_true(STMT_FUNCTION_EXPR,primary->subclass);
  518.     }
  519.  
  520. if(debug_parser){
  521.     fprintf(list_fd,"\nprimary %s: class=0x%x subclass=0x%x",
  522.         symt->name,primary->class,primary->subclass);
  523. }
  524. }
  525.  
  526.  
  527.     /* Integer power: uses recursion x**n = (x**(n/2))**2 */
  528. PRIVATE int
  529. int_power(x,n)
  530.     int x,n;
  531. {
  532.     int temp;
  533.             /* Order of tests puts commonest cases first */
  534.     if(n > 1) {
  535.         temp = int_power(x,n>>1);
  536.         temp *= temp;
  537.         if(n&1) return temp*x;    /* Odd n */
  538.         else    return temp;    /* Even n */
  539.     }
  540.     else if(n == 1) return x;
  541.     else if(n < 0) return 1/int_power(x,-n);    /* Usually 0 */
  542.     else return 1;
  543. }
  544.                 /* Undefine special macros */
  545. #undef E
  546. #undef I
  547. #undef R
  548. #undef D
  549. #undef C
  550. #undef L
  551. #undef S
  552. #undef H
  553. #undef W
  554.  
  555.  
  556. /* II. */
  557.  
  558. /* project.c:
  559.     Project-file I/O routines.  Routines included:
  560.  
  561.     Shared routines:
  562.        void proj_file_out() writes data from symbol table to project file.
  563.        void proj_file_in() reads data from project file to symbol table.
  564.  
  565.     Private routines:
  566.         int has_defn()        TRUE if external has defn in current file
  567.         int has_call()        TRUE if external has call in current file
  568.         int count_com_defns() Counts multiple common defns.
  569.         void proj_alist_out() Outputs argument lists
  570.         void proj_clist_out() Outputs common lists
  571.         void proj_arg_info_in()  Inputs argument lists
  572.         void proj_com_info_in()  Inputs common lists
  573. */
  574.  
  575. #include <string.h>
  576.  
  577. #ifdef __STDC__
  578. #include <stdlib.h>
  579. #else
  580. char *calloc(),*malloc();
  581. void exit();
  582. #endif
  583.  
  584. /* Note: compilation option PROJ_KEEPALL
  585.  
  586.    Define the symbol PROJ_KEEPALL to make Ftnchek create project files
  587.    with complete global symbol table information.  Otherwise, the default
  588.    action is: in library mode, keep only subprogram definitions, those
  589.    external references not defined in the current file, and only one
  590.    instance of each common block.  In non-library mode, the default is to
  591.    keep, besides the above, one call of a given routine from each module,
  592.    and all common block declarations.
  593.    This flag is useful mainly for debugging purposes.
  594. */
  595.  
  596. PRIVATE int has_defn(), has_call();
  597. PRIVATE void proj_alist_out(),proj_clist_out(),
  598.   proj_arg_info_in(),proj_com_info_in();
  599.  
  600. PRIVATE int count_com_defns();
  601.  
  602.  
  603. PRIVATE int
  604. has_defn(alist)            /* Returns TRUE if list has defns */
  605.    ArgListHeader *alist;
  606. {
  607.   while( alist != NULL && alist->topfile == top_filename ) {
  608.     if(alist->is_defn)
  609.       return TRUE;
  610.     alist = alist->next;
  611.   }
  612.   return FALSE;
  613. }
  614.  
  615.  
  616. PRIVATE int
  617. has_call(alist)        /* Returns TRUE if list has calls or defns  */
  618.    ArgListHeader *alist;
  619. {
  620.   while( alist != NULL && alist->topfile == top_filename) {
  621.     if( alist->is_call || alist->actual_arg )
  622.     return TRUE;
  623.     alist = alist->next;
  624.   }
  625.   return FALSE;
  626. }
  627.  
  628. PRIVATE int
  629. count_com_defns(clist)        /* Returns number of common decls in list  */
  630.    ComListHeader *clist;
  631. {
  632.   int count=0;
  633.   while( clist != NULL && clist->topfile == top_filename ) {
  634.     ++count;
  635.     clist = clist->next;
  636.   }
  637.   return count;
  638. }
  639.  
  640.  
  641.     /* proj_file_out: writes data from symbol table to project file. */
  642.  
  643. #define WRITE_STR(LEADER,S)    (fprintf(fd,LEADER), fprintf(fd," %s",S))
  644. #define WRITE_NUM(LEADER,NUM)    (fprintf(fd,LEADER), fprintf(fd," %d",NUM))
  645. #define NEXTLINE    fprintf(fd,"\n")
  646.  
  647. void
  648. proj_file_out(fd)
  649.      FILE *fd;
  650. {
  651.   Gsymtab *sym_list[GLOBSYMTABSZ]; /* temp. list of symtab entries to print */
  652.   BYTE sym_has_defn[GLOBSYMTABSZ];
  653.   BYTE sym_has_call[GLOBSYMTABSZ];
  654.  
  655.   if(fd == NULL)
  656.     return;
  657.  
  658.   WRITE_STR("file",top_filename);
  659.   NEXTLINE;
  660.  
  661.   {    /* Make list of subprograms defined or referenced in this file */
  662.     int i,numexts,numdefns,numcalls,do_defns,pass;
  663.     ArgListHeader *alist;
  664.     for(i=0,numexts=numdefns=numcalls=0;i<glob_symtab_top;i++) {
  665.       if(storage_class_of(glob_symtab[i].type) == class_SUBPROGRAM &&
  666.     (alist=glob_symtab[i].info.arglist) != NULL) {
  667.             /* Look for defns and calls of this guy. */
  668.  
  669.     if( (sym_has_defn[numexts]=has_defn(alist)) != (BYTE) FALSE )
  670.        numdefns++;
  671.     if( (sym_has_call[numexts]= (has_call(alist)
  672.         /* keep only externals not satisfied in this file */
  673. #ifndef PROJ_KEEPALL
  674.             && (!library_mode || !sym_has_defn[numexts])
  675. #endif
  676.                   )) != (BYTE) FALSE )
  677.        numcalls++;
  678.     if(sym_has_defn[numexts] || sym_has_call[numexts])
  679.       sym_list[numexts++] = &glob_symtab[i];
  680.       }
  681.     }
  682.  
  683.         /* List all subprogram defns, then all calls */
  684.     for(pass=0,do_defns=TRUE; pass<2; pass++,do_defns=!do_defns) {
  685.  
  686.       if(do_defns)
  687.     WRITE_NUM(" entries",numdefns);
  688.       else
  689.     WRITE_NUM(" externals",numcalls);
  690.       NEXTLINE;
  691.  
  692.       for(i=0; i<numexts; i++) {
  693.     if( (do_defns && sym_has_defn[i]) || (!do_defns && sym_has_call[i]) ){
  694.       if(do_defns)
  695.         WRITE_STR(" entry",sym_list[i]->name);
  696.       else
  697.         WRITE_STR(" external",sym_list[i]->name);
  698.  
  699.       WRITE_NUM(" class",storage_class_of(sym_list[i]->type));
  700.       WRITE_NUM(" type",datatype_of(sym_list[i]->type));
  701.       fprintf(fd," flags %d %d %d %d %d %d %d %d",
  702.           sym_list[i]->used_flag,
  703.           sym_list[i]->set_flag,
  704.           sym_list[i]->invoked_as_func,
  705.           sym_list[i]->declared_external,
  706.           /* N.B. library_module included here but is not restored */
  707.           sym_list[i]->library_module,
  708.           0,0,0);    /* for possible future use */
  709.       NEXTLINE;
  710.       proj_alist_out(sym_list[i],fd,do_defns,(int)sym_has_defn[i]);
  711.     }
  712.       }/* end for i */
  713.       NEXTLINE;
  714.     }/*end for pass */
  715.   }
  716.  
  717.   {
  718.     int i,numblocks,numdefns;
  719.     ComListHeader *clist;
  720.     for(i=0,numblocks=numdefns=0;i<glob_symtab_top;i++) {
  721.       if(storage_class_of(glob_symtab[i].type) == class_COMMON_BLOCK
  722.      && (clist=glob_symtab[i].info.comlist) != NULL &&
  723.      clist->topfile == top_filename ) {
  724. #ifndef PROJ_KEEPALL
  725.             /* No keepall: save only one com decl if -lib mode */
  726.     if(library_mode)
  727.       numdefns++;
  728.     else
  729. #endif            /* keepall or -nolib mode: keep all com decls */
  730.       numdefns += count_com_defns(clist);
  731.  
  732.     sym_list[numblocks++] = &glob_symtab[i];
  733.       }
  734.     }
  735.     WRITE_NUM(" comblocks",numdefns);
  736.     NEXTLINE;
  737.     for(i=0; i<numblocks; i++) {
  738.       proj_clist_out(sym_list[i],fd);
  739.     }
  740.     NEXTLINE;
  741.   }
  742. }
  743.  
  744.  
  745.  
  746.  
  747.     /* proj_alist_out: writes arglist data from symbol table to
  748.        project file. */
  749.  
  750. PRIVATE void
  751. proj_alist_out(gsymt,fd,do_defns,locally_defined)
  752.      Gsymtab *gsymt;
  753.      FILE *fd;
  754.      int do_defns,locally_defined;
  755. {
  756.   ArgListHeader *a=gsymt->info.arglist;
  757.   ArgListElement *arg;
  758.   int i,n;
  759.   unsigned long diminfo;
  760.   Gsymtab *last_calling_module;
  761.  
  762.  
  763.         /* This loop runs thru only those arglists that were
  764.             created in the current top file. */
  765.     last_calling_module = NULL;
  766.     while( a != NULL && a->topfile == top_filename) {
  767.         /* do_defns mode: output only definitions */
  768.      if( (do_defns && a->is_defn) || (!do_defns && !a->is_defn) )
  769. #ifndef PROJ_KEEPALL
  770.         /* keep only externals not satisfied in this file in -lib
  771.            mode, otherwise keep one actual call from each module. */
  772.     if( a->is_defn
  773.        || !locally_defined
  774.        || (!library_mode && (a->is_call || a->actual_arg)
  775.        && a->module != last_calling_module))
  776. #endif
  777.      {
  778.       last_calling_module = a->module;
  779.       if(a->is_defn)
  780.      fprintf(fd," defn\n");
  781.       else
  782.      fprintf(fd," call\n");
  783.  
  784.       WRITE_STR(" module",a->module->name);
  785.       WRITE_STR(" file",a->filename);
  786.       WRITE_NUM(" line",a->line_num);
  787.       WRITE_NUM(" class",storage_class_of(a->type));
  788.       WRITE_NUM(" type",datatype_of(a->type));
  789.       fprintf(fd," flags %d %d %d %d",
  790.           a->is_defn,
  791.           a->is_call,
  792.           a->external_decl,
  793.           a->actual_arg);
  794.       NEXTLINE;
  795.       n=a->numargs;
  796.       if(a->is_defn || a->is_call) {
  797.     WRITE_NUM(" args",n);
  798.     NEXTLINE;
  799.       }
  800.  
  801.       /* Next lines, 1 per argument: type, array dims, array size, flags */
  802.       arg = a->arg_array;
  803.       for(i=0; i<n; i++) {
  804.     WRITE_NUM(" arg",i+1);
  805.     WRITE_NUM(" class",storage_class_of(arg[i].type));
  806.     WRITE_NUM(" type",datatype_of(arg[i].type));
  807.     diminfo = (
  808.            ((storage_class_of(arg[i].type) == class_VAR) &&
  809.            is_computational_type(datatype_of(arg[i].type))) ?
  810.              arg[i].info.array_dim: 0 );
  811.     WRITE_NUM(" dims",array_dims(diminfo));
  812.     WRITE_NUM(" size",array_size(diminfo));
  813.     fprintf(fd," flags %d %d %d %d %d %d %d %d",
  814.         arg[i].is_lvalue,
  815.         arg[i].set_flag,
  816.         arg[i].assigned_flag,
  817.         arg[i].used_before_set,
  818.         arg[i].array_var,
  819.         arg[i].array_element,
  820.         arg[i].declared_external,
  821.         0);        /* possible flag for future use */
  822.     NEXTLINE;
  823.       }
  824.      }/* end if(do_defn...)*/
  825.      a = a->next;
  826.    }/* end while(a!=NULL)*/
  827.    fprintf(fd," end\n");
  828. }/*proj_alist_out*/
  829.  
  830.  
  831.  
  832.     /* proj_clist_out writes common var list data from symbol
  833.        table to project file. */
  834.  
  835. PRIVATE void
  836. proj_clist_out(gsymt,fd)
  837.      Gsymtab *gsymt;
  838.      FILE *fd;
  839. {
  840.     ComListHeader *c=gsymt->info.comlist;
  841.     ComListElement *cvar;
  842.     int i,n;
  843.  
  844.     while( c != NULL && c->topfile == top_filename ) {
  845.  
  846.       WRITE_STR(" block",gsymt->name);
  847.       WRITE_NUM(" class",storage_class_of(gsymt->type));
  848.       WRITE_NUM(" type",datatype_of(gsymt->type));
  849.       NEXTLINE;
  850.       WRITE_STR(" module",c->module->name);
  851.       WRITE_STR(" file",c->filename);
  852.       WRITE_NUM(" line",c->line_num);
  853.       WRITE_NUM(" flags",c->flags);
  854.       NEXTLINE;
  855.       WRITE_NUM(" vars",n=c->numargs);
  856.       NEXTLINE;
  857.  
  858.     /* Next lines, 1 per variable: class, type, array dims, array size */
  859.       cvar = c->com_list_array;
  860.       for(i=0; i<n; i++) {
  861.     WRITE_NUM(" var",i+1);
  862.     WRITE_NUM(" class",storage_class_of(cvar[i].type));
  863.     WRITE_NUM(" type",datatype_of(cvar[i].type));
  864.     WRITE_NUM(" dims",array_dims(cvar[i].dimen_info));
  865.     WRITE_NUM(" size",array_size(cvar[i].dimen_info));
  866.       NEXTLINE;
  867.       }
  868.             /* keepall or -nolib: loop thru all defns.
  869.                Otherwise only keep the first. */
  870. #ifndef PROJ_KEEPALL
  871.       if(library_mode)
  872.     break;
  873. #endif
  874.       c = c->next;
  875.     }/* end while c != NULL */
  876. }
  877.  
  878. #undef WRITE_STR
  879. #undef WRITE_NUM
  880. #undef NEXTLINE
  881.  
  882.  
  883.     /* proj_file_in:
  884.        Reads a project file, storing info in global symbol table.
  885.        See proj_file_out and its subroutines for the current
  886.        project file format.
  887.      */
  888. #define MAXNAME 127 /* Max string that will be read in: see READ_STR below */
  889.  
  890.  
  891.             /* Macros for error-flagging input */
  892.  
  893. PRIVATE int nil()/* to make lint happy */
  894. { return 0; }
  895.  
  896. #define READ_ERROR (fprintf(stderr,\
  897.      "Oops-- error reading project file at line %d\n",proj_line_num),\
  898.      exit(1),nil())
  899. #define READ_OK nil()
  900.  
  901. #define READ_FIRST_STR(LEADER,STR) (fscanf(fd,LEADER),fscanf(fd,"%127s",STR))
  902. #define READ_STR(LEADER,STR) ((fscanf(fd,LEADER),\
  903.                    fscanf(fd,"%127s",STR))==1? READ_OK:READ_ERROR)
  904. #define READ_NUM(LEADER,NUM) ((fscanf(fd,LEADER),\
  905.                    fscanf(fd,"%d",&NUM))==1? READ_OK:READ_ERROR)
  906. #define NEXTLINE {int c;while( (c=fgetc(fd)) != EOF && c != '\n') continue;\
  907.             if(c == EOF) READ_ERROR; else ++proj_line_num;}
  908.  
  909.  
  910. int proj_line_num;    /* Line number in proj file for diagnostic output */
  911.  
  912. void
  913. proj_file_in(fd)
  914.   FILE *fd;
  915. {
  916.   char buf[MAXNAME+1],*topfilename=NULL;
  917.   int retval;
  918.   unsigned numentries,ientry, numexts,iext, numblocks,iblock;
  919.  
  920.  
  921.   proj_line_num = 1;
  922.  
  923.  while( (retval=READ_FIRST_STR("file",buf)) == 1) {
  924.  
  925.         /* Save filename in permanent storage */
  926.    topfilename = strcpy(malloc(strlen(buf)+1),buf);
  927.    NEXTLINE;
  928. #ifdef DEBUG_PROJECT
  929.  printf("read file %s\n",topfilename);
  930. #endif
  931.  
  932.  
  933.   READ_NUM(" entries",numentries); /* Get no. of entry points */
  934.   NEXTLINE;
  935. #ifdef DEBUG_PROJECT
  936.  printf("read entries %d\n",numentries);
  937. #endif
  938.                 /* Read defn arglists */
  939.   for(ientry=0; ientry<numentries; ientry++) {
  940.       proj_arg_info_in(fd,topfilename,TRUE);
  941.   }
  942.   NEXTLINE;
  943.  
  944.   READ_NUM(" externals",numexts);    /* Get no. of external refs */
  945. #ifdef DEBUG_PROJECT
  946.  printf("read exts %d\n",numexts);
  947. #endif
  948.   NEXTLINE;
  949.  
  950.                 /* Read invocation & ext def arglists */
  951.   for(iext=0; iext<numexts; iext++) {
  952.     proj_arg_info_in(fd,topfilename,FALSE);
  953.   }
  954.   NEXTLINE;
  955.  
  956.  
  957.             /* Read common block info */
  958.  
  959.    READ_NUM(" comblocks",numblocks);
  960. #ifdef DEBUG_PROJECT
  961.  printf("read num blocks %d\n",numblocks);
  962. #endif
  963.    NEXTLINE;
  964.  
  965.    for(iblock=0; iblock<numblocks; iblock++) {
  966.      proj_com_info_in(fd,topfilename);
  967.    }
  968.    NEXTLINE;
  969.  
  970.  }/* end while(retval == 1) */
  971.  
  972.  if(retval != EOF) READ_ERROR;
  973.  
  974.  init_symtab();        /* Clear out local strspace */
  975. }
  976.  
  977. static char *prev_file_name="";/* used to reduce number of callocs */
  978.  
  979.             /* Read arglist info */
  980. PRIVATE void
  981. proj_arg_info_in(fd,filename,is_defn)
  982.     FILE *fd;
  983.     char *filename;        /* name of toplevel file */
  984.     int is_defn;
  985.   {
  986.     char id_name[MAXNAME+1],module_name[MAXNAME+1],sentinel[6];
  987.     char file_name[MAXNAME+1];
  988.     int id_class,id_type;
  989.     unsigned
  990.           id_used_flag,
  991.           id_set_flag,
  992.           id_invoked,
  993.           id_declared,
  994.           id_library_module,
  995.           future1,future2,future3;
  996.  
  997.     unsigned h;
  998.     Gsymtab *gsymt, *module;
  999.     unsigned alist_class,alist_type,alist_is_defn,alist_is_call,
  1000.        alist_external_decl,alist_actual_arg;
  1001.     unsigned alist_line;
  1002.     unsigned numargs,iarg,arg_num,arg_class,arg_type,arg_dims,arg_size;
  1003.     unsigned            /* Flags for arguments */
  1004.         arg_is_lvalue,
  1005.         arg_set_flag,
  1006.         arg_assigned_flag,
  1007.         arg_used_before_set,
  1008.         arg_array_var,
  1009.         arg_array_element,
  1010.         arg_declared_external,
  1011.         arg_future_flag;    /* possible flag for future use */
  1012.  
  1013.     if(is_defn)
  1014.     READ_STR(" entry",id_name); /* Entry point name */
  1015.     else
  1016.     READ_STR(" external",id_name); /* External name */
  1017.     READ_NUM(" class",id_class); /* class as in symtab */
  1018.     READ_NUM(" type",id_type); /* type as in symtab */
  1019.     if(fscanf(fd," flags %d %d %d %d %d %d %d %d",
  1020.           &id_used_flag,
  1021.           &id_set_flag,
  1022.           &id_invoked,
  1023.           &id_declared,
  1024.           &id_library_module,
  1025.           &future1,&future2,&future3) != 8) READ_ERROR;
  1026.     NEXTLINE;
  1027.  
  1028. #ifdef DEBUG_PROJECT
  1029.  printf("read id name %s class %d type %d\n",
  1030. id_name,id_class,id_type);
  1031. #endif
  1032.  
  1033.                 /* Create global symtab entry */
  1034.     h = hash_lookup(id_name);
  1035.     if( (gsymt = hashtab[h].glob_symtab) == NULL)
  1036.       gsymt = install_global(h,id_type,class_SUBPROGRAM);
  1037.  
  1038.         /* Set library_module flag if project file was created
  1039.            with -lib mode in effect, or is now taken in -lib mode */
  1040.     if(is_defn && (library_mode || id_library_module)) {
  1041.       gsymt->library_module = TRUE;
  1042.     }
  1043.  
  1044.     if(id_used_flag)
  1045.       gsymt->used_flag = TRUE;
  1046.     if(id_set_flag)
  1047.       gsymt->set_flag = TRUE;
  1048.     if(id_invoked)
  1049.       gsymt->invoked_as_func = TRUE;
  1050.     if(id_declared)
  1051.       gsymt->declared_external = TRUE;
  1052.  
  1053.    while(   fscanf(fd,"%5s",sentinel),
  1054. #ifdef DEBUG_PROJECT
  1055.  printf("sentinel=[%s]\n",sentinel),
  1056. #endif
  1057.      strcmp(sentinel,(is_defn?"defn":"call")) == 0) {
  1058.       ArgListHeader *ahead;
  1059.       ArgListElement *alist;
  1060.  
  1061.       NEXTLINE;
  1062.  
  1063.       READ_STR(" module",module_name);
  1064.       READ_STR(" file",file_name);
  1065.       READ_NUM(" line",alist_line); /* line number */
  1066.       READ_NUM(" class",alist_class);    /* class as in ArgListHeader */
  1067.       READ_NUM(" type",alist_type); /* type as in ArgListHeader */
  1068.       if(fscanf(fd," flags %d %d %d %d",
  1069.         &alist_is_defn,
  1070.         &alist_is_call,
  1071.         &alist_external_decl,
  1072.         &alist_actual_arg) != 4) READ_ERROR;
  1073.       NEXTLINE;
  1074. #ifdef DEBUG_PROJECT
  1075.  printf("read alist class %d type %d line %d\n",
  1076. alist_class,alist_type,alist_line);
  1077. #endif
  1078.         /* Find current module in symtab. If not there, make
  1079.            a global symtab entry for it. It will be filled
  1080.            in eventually when processing corresponding entry.
  1081.          */
  1082.  
  1083.       h = hash_lookup(module_name);
  1084.       if( (module = hashtab[h].glob_symtab) == NULL) {
  1085.     module = install_global(h,type_UNDECL,class_SUBPROGRAM);
  1086.       }
  1087.       if(module->internal_entry) {
  1088.     fprintf(list_fd,"\nWarning: entry point %s redefined as module",
  1089.         module->name);
  1090.     fprintf(list_fd,"\n\tin project file: redefinition ignored");
  1091.       }
  1092.       else {
  1093.     if(is_defn) {
  1094.       if(module != gsymt) {
  1095. #ifdef DEBUG_PROJECT
  1096.         printf("\nLinking entry %s to module %s",
  1097.            gsymt->name,module->name);
  1098. #endif
  1099.         gsymt->internal_entry = TRUE;
  1100.         gsymt->link.module=module; /* interior entry: link it to module */
  1101.       }
  1102.     }
  1103.     else {            /* call: add to child list */
  1104.         /* Avoid duplication on child list.  It will have just
  1105.            been placed there on previous project-file entry,
  1106.            so it will be the first child on the list.
  1107.         */
  1108. #ifdef DEBUG_PROJECT
  1109.       printf("\nChild %s of module %s",
  1110.          gsymt->name,module->name);
  1111. #endif
  1112.       if(module->link.child_list == NULL
  1113.          || module->link.child_list->child != gsymt) {
  1114.         ChildList *node=
  1115.           (ChildList *)calloc(1,sizeof(ChildList));
  1116. #ifdef DEBUG_PROJECT
  1117.         printf(" linked in");
  1118. #endif
  1119.         node->child = gsymt;
  1120.         node->next = module->link.child_list;
  1121.         module->link.child_list = node;
  1122.       }
  1123. #ifdef DEBUG_PROJECT
  1124.       else {
  1125.         printf(" (duplicate)");
  1126.       }
  1127. #endif
  1128.     }
  1129.       }
  1130.  
  1131.       if(alist_is_defn || alist_is_call) {
  1132.       READ_NUM(" args",numargs);
  1133.       NEXTLINE;
  1134.       }
  1135.       else
  1136.     numargs = 0;
  1137.  
  1138. #ifdef DEBUG_PROJECT
  1139.  printf("read numargs %d\n",numargs);
  1140. #endif
  1141. /*
  1142. **      if(!is_defn) {
  1143. **    gsymt->used_flag = TRUE;
  1144. **      }
  1145. */
  1146.                 /* Create arglist structure */
  1147.       if(((ahead=(ArgListHeader *) calloc(1, sizeof(ArgListHeader)))
  1148.                   == (ArgListHeader *) NULL) ||
  1149.       (numargs != 0 &&
  1150.           ((alist=(ArgListElement *) calloc(numargs,sizeof(ArgListElement)))
  1151.                  == (ArgListElement *) NULL))){
  1152.         fprintf(stderr, "Oops: Out of space for argument list\n");
  1153.         exit(1);
  1154.       }
  1155.  
  1156.             /* Initialize arglist and link it to symtab */
  1157.       ahead->type = type_byte(alist_class,alist_type);
  1158.       ahead->numargs = numargs;
  1159.       ahead->arg_array = (numargs==0? NULL: alist);
  1160.       ahead->module = module;
  1161.       ahead->topfile = filename;
  1162.             /* try to avoid reallocating space for same name */
  1163.       ahead->filename =
  1164.     (strcmp(file_name,filename)==0? filename:
  1165.      (strcmp(file_name,prev_file_name)==0? prev_file_name:
  1166.       (prev_file_name=strcpy(malloc(strlen(file_name)+1),file_name))));
  1167.  
  1168.       ahead->line_num = alist_line;
  1169.       ahead->is_defn = alist_is_defn;
  1170.       ahead->is_call = alist_is_call;
  1171.       ahead->external_decl = alist_external_decl;
  1172.       ahead->actual_arg = alist_actual_arg;
  1173.       ahead->next = gsymt->info.arglist;
  1174.       gsymt->info.arglist = ahead;
  1175.  
  1176.             /* Fill arglist array from project file */
  1177.       for(iarg=0; iarg<numargs; iarg++) {
  1178.     READ_NUM(" arg",arg_num);    if(arg_num != iarg+1) READ_ERROR;
  1179.     READ_NUM(" class",arg_class);
  1180.     READ_NUM(" type",arg_type);
  1181.     READ_NUM(" dims",arg_dims);
  1182.     READ_NUM(" size",arg_size);
  1183.     if(fscanf(fd," flags %d %d %d %d %d %d %d %d",
  1184.         &arg_is_lvalue,
  1185.         &arg_set_flag,
  1186.         &arg_assigned_flag,
  1187.         &arg_used_before_set,
  1188.         &arg_array_var,
  1189.         &arg_array_element,
  1190.         &arg_declared_external,
  1191.         &arg_future_flag) != 8) READ_ERROR;
  1192.  
  1193.     alist[iarg].info.array_dim = array_dim_info(arg_dims,arg_size);
  1194.     alist[iarg].type = type_byte(arg_class,arg_type);
  1195.     alist[iarg].is_lvalue = arg_is_lvalue;
  1196.     alist[iarg].set_flag = arg_set_flag;
  1197.     alist[iarg].assigned_flag = arg_assigned_flag;
  1198.     alist[iarg].used_before_set = arg_used_before_set;
  1199.     alist[iarg].array_var = arg_array_var;
  1200.     alist[iarg].array_element = arg_array_element;
  1201.     alist[iarg].declared_external = arg_declared_external;
  1202.     NEXTLINE;
  1203. #ifdef DEBUG_PROJECT
  1204.  printf("read arg num %d\n",arg_num);
  1205. #endif
  1206.       }
  1207.  
  1208.     }/* end while( sentinel == "defn"|"call") */
  1209.  
  1210.     if(strcmp(sentinel,"end") != 0) READ_ERROR;
  1211.     NEXTLINE;
  1212. }
  1213.  
  1214.  
  1215. PRIVATE void
  1216. proj_com_info_in(fd,filename)
  1217.      FILE *fd;
  1218.      char *filename;
  1219. {
  1220.     char id_name[MAXNAME+1],module_name[MAXNAME+1];
  1221.     char file_name[MAXNAME+1];
  1222.     unsigned id_class,id_type;
  1223.     unsigned clist_flags,clist_line;
  1224.     unsigned numvars,ivar,var_num,var_class,var_type,var_dims,var_size;
  1225.  
  1226.       unsigned h;
  1227.       Gsymtab *gsymt, *module;
  1228.       ComListHeader *chead;
  1229.       ComListElement *clist;
  1230.  
  1231.  
  1232.     READ_STR(" block",id_name);
  1233.     READ_NUM(" class",id_class);
  1234.     READ_NUM(" type",id_type);
  1235. #ifdef DEBUG_PROJECT
  1236.  printf("read com name %s class %d type %d\n",
  1237. id_name,id_class,id_type);
  1238. #endif
  1239.     NEXTLINE;
  1240.  
  1241.     READ_STR(" module",module_name);
  1242.     READ_STR(" file",file_name);
  1243.     READ_NUM(" line",clist_line);
  1244.     READ_NUM(" flags",clist_flags);
  1245.     NEXTLINE;
  1246.  
  1247.     READ_NUM(" vars",numvars);
  1248. #ifdef DEBUG_PROJECT
  1249.  printf("read flags %d line %d\n",clist_flags,clist_line);
  1250. #endif
  1251.     NEXTLINE;
  1252.                 /* Create global symtab entry */
  1253.     h = hash_lookup(id_name);
  1254.     if( (gsymt = hashtab[h].com_glob_symtab) == NULL)
  1255.       gsymt = install_global(h,id_type,id_class);
  1256.  
  1257.  
  1258.                 /* Create arglist structure */
  1259.     if(((chead=(ComListHeader *) calloc(1, sizeof(ComListHeader)))
  1260.                   == (ComListHeader *) NULL) ||
  1261.       (numvars != 0 &&
  1262.           ((clist=(ComListElement *) calloc(numvars,sizeof(ComListElement)))
  1263.                  == (ComListElement *) NULL))){
  1264.         fprintf(stderr, "Oops: Out of space for common list\n");
  1265.         exit(1);
  1266.       }
  1267.  
  1268.         /* Find current module in symtab. If not there, make
  1269.            a global symtab entry for it.  This is bogus, since
  1270.            all modules should have been defined previously. */
  1271.  
  1272.       h = hash_lookup(module_name);
  1273.       if( (module = hashtab[h].glob_symtab) == NULL) {
  1274.     fprintf(stderr,"\nWarning-- something's bogus in project file\n");
  1275.     module = install_global(h,type_UNDECL,class_SUBPROGRAM);
  1276.       }
  1277.  
  1278.             /* Initialize arglist and link it to symtab */
  1279.       chead->numargs = numvars;
  1280.       chead->flags = clist_flags;
  1281.       chead->line_num = clist_line;
  1282.       chead->com_list_array = (numvars==0? NULL: clist);
  1283.       chead->module = module;
  1284.       chead->topfile = filename;
  1285.             /* try to avoid reallocating space for same name */
  1286.       chead->filename =
  1287.     (strcmp(file_name,filename)==0? filename:
  1288.      (strcmp(file_name,prev_file_name)==0? prev_file_name:
  1289.       (prev_file_name=strcpy(malloc(strlen(file_name)+1),file_name))));
  1290.  
  1291.       chead->next = gsymt->info.comlist;
  1292.       gsymt->info.comlist = chead;
  1293.  
  1294.             /* Fill comlist array from project file */
  1295.     for(ivar=0; ivar<numvars; ivar++) {
  1296.       READ_NUM(" var",var_num); if(var_num != ivar+1) READ_ERROR;
  1297.       READ_NUM(" class",var_class);
  1298.       READ_NUM(" type",var_type);
  1299.       READ_NUM(" dims",var_dims);
  1300.       READ_NUM(" size",var_size);
  1301.       NEXTLINE;
  1302. #ifdef DEBUG_PROJECT
  1303.  printf("read class %d type %d dims %d size %d\n",var_class,var_type,
  1304. var_dims,var_size);
  1305. #endif
  1306.       clist[ivar].dimen_info = array_dim_info(var_dims,var_size);
  1307.       clist[ivar].type = type_byte(var_class,var_type);
  1308.     }
  1309. }/*proj_com_info_in*/
  1310.  
  1311.