home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / FTNCHK32.ZIP / prsymtab.c < prev    next >
C/C++ Source or Header  |  1993-02-16  |  51KB  |  1,839 lines
  1. /* prsymtab.c:
  2.  
  3.         Routines associated with printing of symbol table info
  4.  
  5.     Copyright (C) 1992 by Robert K. Moniot.
  6.     This program is free software.  Permission is granted to
  7.     modify it and/or redistribute it, retaining this notice.
  8.     No guarantees accompany this software.
  9.  
  10.     Shared functions defined:
  11.  
  12.         arg_array_cmp()   Compares subprogram calls with defns.
  13.         check_arglists()  Scans global symbol table for subprograms
  14.                   and finds subprogram defn if it exists.
  15.         check_comlists()  Scans global symbol table for common blocks.
  16.         com_cmp_strict()      Compares lists of common variables.
  17.         debug_symtabs()    Prints debugging info about symbol tables.
  18.         print_loc_symbols(curmodhash) Prints local symtab info.
  19.  
  20.     Private functions defined:
  21.         check_mixed_common() checks common for nonportable mixed type
  22.         sort_symbols()      Sorts the list of names of a given category.
  23.         swap_symptrs()      Swaps a pair of pointers.
  24.         check_flags()     Outputs messages about used-before-set etc.
  25.         print_symbols(sym_list,n,do_types) Prints symbol lists.
  26.         print_variables(sym_list,n)  Prints variable symbol table
  27. */
  28.  
  29. #include <stdio.h>
  30. #include <ctype.h>
  31. #include <string.h>
  32. #include "ftnchek.h"
  33. #include "symtab.h"
  34.  
  35.  
  36. PRIVATE int
  37. has_nonalnum();
  38.  
  39. PRIVATE unsigned
  40. find_sixclashes(), print_variables(), print_symbols();
  41.  
  42.  
  43. PRIVATE void
  44. swap_symptrs(), sort_symbols(), check_flags(), check_mixed_common(),
  45. com_cmp_lax(),com_cmp_strict(), arg_array_cmp(),
  46. print_tokenlist(), visit_child(), sort_child_list();
  47.  
  48.             /* Shorthand for check control settings */
  49. #define check_array_dims (array_arg_check&01) /* levels 1 and 3 */
  50. #define check_array_size (array_arg_check&02) /* levels 2 and 3 */
  51. #define check_set_used    (usage_check&01) /* levels 1 and 3 */
  52. #define check_unused    (usage_check&02) /* levels 2 and 3 */
  53.  
  54. #define pluralize(n) ((n)==1? "":"s")    /* singular/plural suffix for n */
  55.  
  56. #define CMP_ERR_LIMIT 3    /* stop printing errors after this many */
  57.  
  58. PRIVATE void
  59. arg_array_cmp(name,args1,args2)
  60.              /* Compares subprogram calls with definition */
  61.     char *name;
  62.     ArgListHeader *args1, *args2;
  63. {
  64.     int i,
  65.         typerr = 0,
  66.         usage_err = 0;
  67.     int  n,
  68.          n1 = args1->numargs,
  69.          n2 = args2->numargs;
  70.     ArgListElement *a1 = args1->arg_array,
  71.                *a2 = args2->arg_array;
  72.  
  73.     n = (n1 > n2) ? n2: n1;        /* n = min(n1,n2) */
  74.  
  75.     if (n1 != n2){
  76.     fprintf(list_fd,"\nSubprogram %s: varying number of arguments:",name);
  77.     fprintf(list_fd,"\n\t%s with %d argument%s in module %s line %u file %s",
  78.             args1->is_defn? "Defined":"Invoked",
  79.                 n1,pluralize(n1),
  80.             args1->module->name,
  81.             args1->line_num,
  82.             args1->filename);
  83.  
  84.     fprintf(list_fd,"\n\t%s with %d argument%s in module %s line %u file %s",
  85.             args2->is_defn? "Defined":"Invoked",
  86.             n2,pluralize(n2),
  87.             args2->module->name,
  88.             args2->line_num,
  89.             args2->filename);
  90.         }
  91.  
  92.     {    /* Look for type mismatches */
  93.         typerr = 0;
  94.         for (i=0; i<n; i++) {
  95.         if(a1[i].type != a2[i].type){
  96.             int t1 = datatype_of(a1[i].type),
  97.             t2 = datatype_of(a2[i].type);
  98.  
  99.             /* Allow hollerith to match integer or logical */
  100.             if( (t1 == type_HOLLERITH
  101.                && (t2 == type_INTEGER || t2 == type_LOGICAL))
  102.              || (t2 == type_HOLLERITH
  103.                && (t1 == type_INTEGER || t1 == type_LOGICAL))
  104.        && (storage_class_of(a1[i].type)==storage_class_of(a1[i].type)) )
  105.                   continue;
  106.  
  107.             /* stop after limit: probably a cascade */
  108.             if(++typerr > CMP_ERR_LIMIT) {
  109.                 fprintf(list_fd,"\n etc...");
  110.                 break;
  111.             }
  112.  
  113.             if(typerr == 1)
  114.     fprintf(list_fd,"\nSubprogram %s:  argument data type mismatch",
  115.                  name);
  116.  
  117.     fprintf(list_fd, "\n  at position %d:", i+1);
  118.     fprintf(list_fd,"\n\t%s %s %s in module %s line %u file %s",
  119.                 args1->is_defn? "Dummy type": "Actual type",
  120.                 type_name[t1],
  121.                 class_name[storage_class_of(a1[i].type)],
  122.                 args1->module->name,
  123.                 args1->line_num,
  124.                 args1->filename);
  125.     fprintf(list_fd,"\n\t%s %s %s in module %s line %u file %s",
  126.                 args2->is_defn? "Dummy type": "Actual type",
  127.                 type_name[t2],
  128.                 class_name[storage_class_of(a2[i].type)],
  129.                 args2->module->name,
  130.                 args2->line_num,
  131.                 args2->filename);
  132.             if(args1->is_defn
  133.             && storage_class_of(a1[i].type) == class_SUBPROGRAM
  134.             && storage_class_of(a2[i].type) != class_SUBPROGRAM
  135.             && datatype_of(a1[i].type) != type_SUBROUTINE
  136.             && ! a1[i].declared_external )
  137.    fprintf(list_fd,"\n\t(possibly it is an array which was not declared)");
  138.         }
  139.         }
  140.     }/* end look for type mismatches */
  141.  
  142.  
  143.          /* Check arrayness of args only if defn exists */
  144.     if( args1->is_defn ) {
  145.         int arrayness_errs = 0;
  146.         unsigned long diminfo1,diminfo2,dims1,dims2,size1,size2;
  147.  
  148.         for (i=0; i<n; i++) {
  149.           if(storage_class_of(a1[i].type) == class_VAR
  150.           && storage_class_of(a2[i].type) == class_VAR) {
  151.  
  152.             /* Allow holleriths to match arrays.  Type
  153.                match was checked above, so they will
  154.                be matching arrays of integer or logical. */
  155.             if( datatype_of(a1[i].type) == type_HOLLERITH
  156.              || datatype_of(a2[i].type) == type_HOLLERITH )
  157.                   continue;
  158.  
  159.         diminfo1 = a1[i].info.array_dim;
  160.         diminfo2 = a2[i].info.array_dim;
  161.         dims1 = array_dims(diminfo1);
  162.         dims2 = array_dims(diminfo2);
  163.         size1 = array_size(diminfo1);
  164.         size2 = array_size(diminfo2);
  165. #if DEBUG_PRSYMTAB
  166. if(debug_latest){
  167. fprintf(list_fd,"\n%s arg %d: array_var=%d%d array_element=%d%d",
  168. name,i+1,
  169. a1[i].array_var,a2[i].array_var,
  170. a1[i].array_element,a2[i].array_element);
  171. fprintf(list_fd,"\nDummy dims=%ld size=%ld",dims1,size1);
  172. fprintf(list_fd,"\nActual dims=%ld size=%ld",dims2,size2);
  173. }
  174. #endif
  175.  
  176.         if( a1[i].array_var ) {    /* I. Dummy arg is array */
  177.             if( a2[i].array_var ) {
  178.             if( a2[i].array_element ) {
  179.                     /*   A. Actual arg is array elt */
  180.                     /*    Warn on check_array_dims. */
  181.                 if(check_array_dims) {
  182.                 /* stop after limit: probably a cascade */
  183.                 if(++arrayness_errs > CMP_ERR_LIMIT) {
  184.                       fprintf(list_fd,"\n etc...");
  185.                       break;
  186.                 }
  187.  
  188.                 if(arrayness_errs == 1)
  189.  fprintf(list_fd,"\nSubprogram %s:  argument arrayness mismatch",
  190.                  name);
  191.  
  192.  fprintf(list_fd, "\n  at position %d:", i+1);
  193.  
  194.  fprintf(list_fd,
  195.     "\n\tDummy arg is whole array in module %s line %u file %s",
  196.                 args1->module->name,
  197.                 args1->line_num,
  198.                 args1->filename);
  199.  fprintf(list_fd,
  200.     "\n\tActual arg is array element in module %s line %u file %s",
  201.                 args2->module->name,
  202.                 args2->line_num,
  203.                 args2->filename);
  204.                 }
  205.             }
  206.             else {
  207.                     /*   B. Actual arg is whole array */
  208.                     /*    Warn if dims or sizes differ */
  209.  
  210.             /* size = 0 or 1 means adjustable: OK to differ */
  211.                 if( (check_array_size &&
  212.                   (size1 > 1 && size2 > 1 && size1 != size2))
  213.                  || (check_array_dims &&
  214.                   (dims1 != dims2)) ) {
  215.  
  216.                 /* stop after limit: probably a cascade */
  217.                 if(++arrayness_errs > CMP_ERR_LIMIT) {
  218.                       fprintf(list_fd,"\n etc...");
  219.                       break;
  220.                 }
  221.  
  222.                 if(arrayness_errs == 1)
  223.  fprintf(list_fd,"\nSubprogram %s:  argument arrayness mismatch",
  224.                  name);
  225.  
  226.  fprintf(list_fd, "\n  at position %d:", i+1);
  227.  
  228.  fprintf(list_fd,
  229.      "\n\tDummy arg %ld dim%s size %ld in module %s line %u file %s",
  230.                 dims1,pluralize(dims1),
  231.                 size1,
  232.                 args1->module->name,
  233.                 args1->line_num,
  234.                 args1->filename);
  235.  fprintf(list_fd,
  236.     "\n\tActual arg %ld dim%s size %ld in module %s line %u file %s",
  237.                 dims2,pluralize(dims2),
  238.                 size2,
  239.                 args2->module->name,
  240.                 args2->line_num,
  241.                 args2->filename);
  242.  
  243.                 }
  244.             }
  245.             }
  246.             else {
  247.                     /*   C. Actual arg is scalar */
  248.                     /*    Warn in all cases */
  249.  
  250.                 /* stop after limit: probably a cascade */
  251.                 if(++arrayness_errs > CMP_ERR_LIMIT) {
  252.                       fprintf(list_fd,"\n etc...");
  253.                       break;
  254.                 }
  255.  
  256.                 if(arrayness_errs == 1)
  257.  fprintf(list_fd,"\nSubprogram %s:  argument arrayness mismatch",
  258.                  name);
  259.  
  260.  fprintf(list_fd, "\n  at position %d:", i+1);
  261.  
  262.  fprintf(list_fd,
  263.     "\n\tDummy arg is array in module %s line %u file %s",
  264.                 args1->module->name,
  265.                 args1->line_num,
  266.                 args1->filename);
  267.  fprintf(list_fd,
  268.     "\n\tActual arg is scalar in module %s line %u file %s",
  269.                 args2->module->name,
  270.                 args2->line_num,
  271.                 args2->filename);
  272.  
  273.             }
  274.         } /* end dummy is array case */
  275.  
  276.         else {            /* II. Dummy arg is scalar */
  277.             if( a2[i].array_var ) {
  278.             if( a2[i].array_element ) {
  279.                     /*   A. Actual arg is array elt */
  280.                     /*    OK */
  281.             }
  282.             else {
  283.                     /*   B. Actual arg is whole array */
  284.                     /*    Warn in all cases */
  285.  
  286.                 /* stop after limit: probably a cascade */
  287.                 if(++arrayness_errs > CMP_ERR_LIMIT) {
  288.                       fprintf(list_fd,"\n etc...");
  289.                       break;
  290.                 }
  291.  
  292.                 if(arrayness_errs == 1)
  293.  fprintf(list_fd,"\nSubprogram %s:  argument arrayness mismatch",
  294.                  name);
  295.  
  296.  fprintf(list_fd, "\n  at position %d:", i+1);
  297.  
  298.  fprintf(list_fd,
  299.     "\n\tDummy arg is scalar in module %s line %u file %s",
  300.                 args1->module->name,
  301.                 args1->line_num,
  302.                 args1->filename);
  303.  fprintf(list_fd,
  304.     "\n\tActual arg is whole array in module %s line %u file %s",
  305.                 args2->module->name,
  306.                 args2->line_num,
  307.                 args2->filename);
  308.             }
  309.             }
  310.             else {
  311.                     /*   C. Actual arg is scalar */
  312.                     /*    OK */
  313.             }
  314.  
  315.  
  316.         } /* end dummy is scalar case */
  317.  
  318.           } /* end if class_VAR */
  319.         }/* end for (i=0; i<n; i++) */
  320.     }/* if( args1->is_defn ) */
  321.  
  322.  
  323.          /* Check usage of args only if defn exists */
  324.     if(check_set_used && args1->is_defn) {
  325.         usage_err = 0;
  326.  
  327.         for (i=0; i<n; i++) {
  328.         int nonlvalue_out = (a1[i].assigned_flag && !a2[i].is_lvalue),
  329.             nonset_in = (a1[i].used_before_set && !a2[i].set_flag);
  330.  
  331. #if DEBUG_PRSYMTAB
  332. if(debug_latest) {
  333. fprintf(list_fd,
  334. "\nUsage check: %s[%d] dummy asgnd %d ubs %d  actual lvalue %d set %d",
  335. args1->module->name,
  336. i+1,
  337. a1[i].assigned_flag,
  338. a1[i].used_before_set,
  339. a2[i].is_lvalue,
  340. a2[i].set_flag);
  341. }
  342. #endif
  343.  
  344.         if(nonlvalue_out || nonset_in) {
  345.  
  346.             /* stop after limit: probably a cascade */
  347.             if(++usage_err > CMP_ERR_LIMIT) {
  348.                 fprintf(list_fd,"\n etc...");
  349.                 break;
  350.             }
  351.             if(usage_err == 1)
  352.   fprintf(list_fd,"\nSubprogram %s:  argument usage mismatch",
  353.                  name);
  354.  
  355.   fprintf(list_fd, "\n  at position %d:", i+1);
  356.  
  357.             if(nonlvalue_out) {
  358.   fprintf(list_fd,
  359.     "\n\tDummy arg is modified in module %s line %u file %s",
  360.                 args1->module->name,
  361.                 args1->line_num,
  362.                 args1->filename);
  363.   fprintf(list_fd,
  364.     "\n\tActual arg is const or expr in module %s line %u file %s",
  365.                 args2->module->name,
  366.                 args2->line_num,
  367.                 args2->filename);
  368.             }
  369.             else
  370.  
  371.             if(nonset_in) {
  372.   fprintf(list_fd,
  373.     "\n\tDummy arg used before set in module %s line %u file %s",
  374.                 args1->module->name,
  375.                 args1->line_num,
  376.                 args1->filename);
  377.   fprintf(list_fd,
  378.     "\n\tActual arg not set in module %s line %u file %s",
  379.                 args2->module->name,
  380.                 args2->line_num,
  381.                 args2->filename);
  382.             }
  383.         }
  384.         }
  385.     }/*end if(check_set_used && args->is_defn) */
  386.  
  387. }/* arg_array_cmp */
  388.  
  389.  
  390.         /* Macro for testing whether an arglist or comlist header is
  391.            irrelevant for purposes of error checking: i.e. it comes
  392.            from an unvisited library module. */
  393. #define irrelevant(list) ((list)->module->library_module &&\
  394.                 !(list)->module->visited_somewhere)
  395.  
  396.  
  397.  
  398. void
  399. check_arglists()    /* Scans global symbol table for subprograms */
  400. {                       /* and finds subprogram defn if it exists */
  401.     unsigned i;
  402.     ArgListHeader *defn_list, *alist;
  403.  
  404.     for (i=0; i<glob_symtab_top; i++){
  405. if(debug_latest){
  406. printf("\n%s: type 0x%x lib %d int %d vis %d vis-smw %d",
  407.        glob_symtab[i].name,
  408.        glob_symtab[i].type,
  409.        glob_symtab[i].library_module,
  410.        glob_symtab[i].internal_entry,
  411.        glob_symtab[i].visited,
  412.        glob_symtab[i].visited_somewhere
  413.        );
  414. }
  415.                 /* Skip common blocks */
  416.         if(storage_class_of(glob_symtab[i].type) != class_SUBPROGRAM)
  417.         continue;
  418. if(debug_latest)printf(": class OK");
  419.                 /* Skip unvisited library modules */
  420.         if(glob_symtab[i].library_module && !glob_symtab[i].visited)
  421.         continue;
  422. if(debug_latest)printf(": status OK");
  423.  
  424.         if((alist=glob_symtab[i].info.arglist) == NULL){
  425.           fprintf(list_fd,
  426.               "\nOops--global symbol %s has no argument lists",
  427.               glob_symtab[i].name);
  428.         }
  429.         else{    /* alist != NULL */
  430.         int num_defns= 0;
  431.         ArgListHeader *list_item;
  432.  
  433.             /* use 1st invocation instead of defn if no defn */
  434.         defn_list = alist;
  435.  
  436.                 /* Find a definition in the linked list of
  437.                    usages.  Count how many defns found. */
  438.         list_item = alist;
  439.         while(list_item != NULL){
  440.             if(list_item->is_defn){
  441.             if(ext_def_check && num_defns > 0) {/* multiple defn */
  442.                 if(num_defns == 1) {
  443.     fprintf(list_fd,"\nSubprogram %s multiply defined:",
  444.                 glob_symtab[i].name);
  445.     fprintf(list_fd,"\n\tin module %s line %u file %s",
  446.                 defn_list->module->name,
  447.                 defn_list->line_num,
  448.                 defn_list->filename);
  449.                 }
  450.    fprintf(list_fd,"\n\tin module %s line %u file %s",
  451.                 list_item->module->name,
  452.                 list_item->line_num,
  453.                 list_item->filename);
  454.             }
  455.  
  456.             ++num_defns;
  457.             defn_list = list_item;    /* Use last defn found */
  458.             }
  459.             else { /* ! list_item->is_defn */
  460.                 /* Here treat use as actual arg like call */
  461.             if(list_item->is_call || list_item->actual_arg){
  462.                  /* Use last call by a visited or nonlibrary
  463.                     module as defn if no defn found */
  464.               if(!defn_list->is_defn
  465.                  && !irrelevant(list_item) )
  466.                 defn_list = list_item;
  467.                 }
  468.             }
  469.  
  470.             list_item = list_item->next;
  471.         }
  472.         if(num_defns == 0){
  473.                 /* If no defn found, and all calls are
  474.                    from unvisited library modules, skip. */
  475.           if(irrelevant(defn_list))
  476.             continue;
  477.                 /* If no definitions found, report error
  478.                    unless -noext is given */
  479.            if(ext_def_check) {
  480.     fprintf(list_fd, "\nSubprogram %s never defined",
  481.                 glob_symtab[i].name);
  482.             if(!glob_symtab[i].used_flag)
  483.     fprintf(list_fd," nor invoked");
  484.  
  485.     fprintf(list_fd, "\n\t%s in module %s line %u file %s",
  486.                 (defn_list->external_decl)?"declared":"invoked",
  487.                 defn_list->module->name,
  488.                 defn_list->line_num,
  489.                 defn_list->filename);
  490.             /* Warn if it seems it may just be an array they
  491.                forgot to declare */
  492.               if(defn_list->numargs != 0
  493.              && datatype_of(defn_list->type) != type_SUBROUTINE
  494.              && ! glob_symtab[i].declared_external) {
  495.             if(novice_help)
  496.     fprintf(list_fd,"\n\t(possibly it is an array which was not declared)");
  497.               }
  498.            }
  499.         }
  500.                 /* If definition is found but module is
  501.                    not in call tree, report it unless -lib */
  502.         else{    /* num_defns != 0 */
  503.             if(!glob_symtab[i].visited
  504.                && datatype_of(glob_symtab[i].type) != type_BLOCK_DATA
  505.                && !glob_symtab[i].library_module) {
  506.             fprintf(list_fd,"\nSubprogram %s never invoked",
  507.                 glob_symtab[i].name);
  508.     fprintf(list_fd, "\n\tdefined in module %s line %u file %s",
  509.                 defn_list->module->name,
  510.                 defn_list->line_num,
  511.                 defn_list->filename);
  512.             }
  513.         }
  514.  
  515.             /* Now check defns/invocations for consistency.  If
  516.                no defn, 1st invocation will serve. Here treat
  517.                use as actual arg like call.  Ignore calls & defns
  518.                in unvisited library modules. */
  519.         if(defn_list->is_defn || !defn_list->external_decl) {
  520.           while(alist != NULL){
  521.             int typerrs = 0;
  522.             if(alist != defn_list && !alist->external_decl
  523.                && !irrelevant(alist)) {
  524.                     if(alist->type != defn_list->type){
  525.                 int t1 = datatype_of(defn_list->type),
  526.                     t2 = datatype_of(alist->type);
  527.                     if(typerrs++ == 0){
  528.    fprintf(list_fd,"\nSubprogram %s invoked inconsistently:",
  529.                        glob_symtab[i].name);
  530.    fprintf(list_fd,"\n\t%s type %s in module %s line %u file %s",
  531.                     defn_list->is_defn? "Defined":"Invoked",
  532.                     type_name[t1],
  533.                     defn_list->module->name,
  534.                     defn_list->line_num,
  535.                     defn_list->filename);
  536.                 }
  537.    fprintf(list_fd,"\n\t%s type %s in module %s line %u file %s",
  538.                     alist->is_defn? "Defined":"Invoked",
  539.                     type_name[t2],
  540.                     alist->module->name,
  541.                     alist->line_num,
  542.                     alist->filename);
  543.                 }
  544.             }
  545.             alist = alist->next;
  546.  
  547.           }/* end while(alist != NULL) */
  548.             }/* end if(defn) */
  549.  
  550.         alist = glob_symtab[i].info.arglist;
  551.         while(alist != NULL){
  552.           /* Here we require true call, not use as actual arg.
  553.              Also, do not compare multiple defns against each
  554.              other. */
  555.             if(alist != defn_list &&
  556.                (defn_list->is_defn || defn_list->is_call) &&
  557.                (alist->is_call && !irrelevant(alist)) ){
  558.                 arg_array_cmp(glob_symtab[i].name,defn_list,alist);
  559.             }
  560.             alist = alist->next;
  561.  
  562.         }/* end while(alist != NULL) */
  563.         }/* end else <alist != NULL> */
  564.     }/* end for (i=0; i<glob_symtab_top; i++) */
  565. }
  566.  
  567.  
  568. void
  569. check_comlists()        /* Scans global symbol table for common blocks */
  570. {
  571.     unsigned i, model_n;
  572.     ComListHeader *first_list, *model, *clist;
  573.  
  574.     if(comcheck_strictness == 0)
  575.         return;
  576.  
  577.     for (i=0; i<glob_symtab_top; i++){
  578.         if (storage_class_of(glob_symtab[i].type) != class_COMMON_BLOCK)
  579.         continue;
  580.         if((first_list=glob_symtab[i].info.comlist) == NULL){
  581.         fprintf(list_fd,"\nCommon block %s never defined",
  582.             glob_symtab[i].name);
  583.         }
  584.         else {
  585.               /* Find instance with most variables to use as model */
  586.         model=first_list;
  587.         model_n = first_list->numargs;
  588.         clist = model;
  589.         while( (clist=clist->next) != NULL ){
  590.             if(clist->numargs >= model_n /* if tie, use earlier */
  591.             /* also if model is from an unvisited library
  592.                module, take another */
  593.                || irrelevant(model) ) {
  594.             model = clist;
  595.             model_n = clist->numargs;
  596.             }
  597.         }
  598.  
  599.         if( irrelevant(model) )
  600.           continue;    /* skip if irrelevant */
  601.  
  602.         clist = first_list;
  603.         while( clist != NULL ){
  604.             if(clist != model && !irrelevant(clist)) {
  605.             if(comcheck_strictness <= 2)
  606.               com_cmp_lax(glob_symtab[i].name,model,clist);
  607.             else
  608.               com_cmp_strict(glob_symtab[i].name,model,clist);
  609.             }
  610.             clist = clist->next;
  611.         }
  612.         }
  613.     }
  614. } /* check_comlists */
  615.  
  616.  
  617.  
  618. PRIVATE void
  619. com_cmp_lax(name,c1,c2)        /* Common-list check at levels 1 & 2 */
  620.      char *name;
  621.      ComListHeader *c1,*c2;
  622. {
  623.     int i1,i2,            /* count of common variables in each block */
  624.     done1,done2,        /* true when end of block reached */
  625.     type1,type2;        /* type of variable presently in scan */
  626.     unsigned long
  627.     len1,len2,        /* length of variable remaining */
  628.     word1,word2,        /* number of "words" scanned */
  629.     words1,words2,        /* number of "words" in block */
  630.     jump;            /* number of words to skip next in scan */
  631.  
  632.     int n1=c1->numargs,n2=c2->numargs; /* variable count for each block */
  633.     ComListElement *a1=c1->com_list_array, *a2=c2->com_list_array;
  634.  
  635.                 /* Count words in each list */
  636.     words1=words2=0;
  637.     for(i1=0; i1<n1; i1++)
  638.       words1 += array_size(a1[i1].dimen_info);
  639.     for(i2=0; i2<n2; i2++)
  640.       words2 += array_size(a2[i2].dimen_info);
  641.  
  642.     if(comcheck_strictness >= 2 && words1 != words2) {
  643. fprintf(list_fd,"\nCommon block %s: varying length:", name);
  644. fprintf(list_fd,
  645.     "\n\tDeclared with %ld word%s in module %s line %u file %s",
  646.         words1, pluralize(words1),
  647.         c1->module->name,
  648.         c1->line_num,
  649.         c1->filename);
  650. fprintf(list_fd,
  651.     "\n\tDeclared with %ld word%s in module %s line %u file %s",
  652.         words2, pluralize(words2),
  653.         c2->module->name,
  654.         c2->line_num,
  655.         c2->filename);
  656.     }
  657.  
  658.                 /* Now check type matches */
  659.     done1=done2=FALSE;
  660.     i1=i2=0;
  661.     len1=len2=0;
  662.     word1=word2=1;
  663.     for(;;) {
  664.     if(len1 == 0) {        /* move to next variable in list 1 */
  665.         if(i1 == n1) {
  666.         done1 = TRUE;
  667.         }
  668.         else {
  669.         type1 = a1[i1].type;
  670.         len1 = array_size(a1[i1].dimen_info);
  671.         ++i1;
  672.         }
  673.     }
  674.     if(len2 == 0) {        /* move to next variable in list 2 */
  675.         if(i2 == n2) {
  676.         done2 = TRUE;
  677.         }
  678.         else {
  679.         type2 = a2[i2].type;
  680.         len2 = array_size(a2[i2].dimen_info);
  681.         ++i2;
  682.         }
  683.     }
  684.  
  685.     if(done1 || done2){    /* either list exhausted? */
  686.         break;        /* then stop checking */
  687.     }
  688.  
  689.     if(type1 != type2) {    /* type clash? */
  690. fprintf(list_fd,"\nCommon block %s: data type mismatch",
  691.         name);
  692. fprintf(list_fd,
  693.     "\n\tWord %ld is type %s in module %s line %u file %s",
  694.             word1,
  695.             type_name[type1],
  696.             c1->module->name,
  697.             c1->line_num,
  698.             c1->filename);
  699. fprintf(list_fd,
  700.     "\n\tWord %ld is type %s in module %s line %u file %s",
  701.             word2,
  702.             type_name[type2],
  703.             c2->module->name,
  704.             c2->line_num,
  705.             c2->filename);
  706.         break;        /* stop checking at first mismatch */
  707.     }
  708.             /* Advance along list by largest possible
  709.                step that does not cross a variable boundary
  710.              */
  711.     jump = len1 < len2? len1: len2;    /* min(len1,len2) */
  712.     len1 -= jump;
  713.     len2 -= jump;
  714.     word1 += jump;
  715.     word2 += jump;
  716.     }/* end for(;;) */
  717. }
  718.  
  719. PRIVATE void
  720. com_cmp_strict(name,c1,c2)    /* Common-list check at levels 1 & 2 */
  721.     char *name;
  722.     ComListHeader *c1, *c2;
  723. {
  724.     int i,
  725.         typerr = 0,
  726.         dimerr = 0;
  727.     short n,
  728.           n1 = c1->numargs,
  729.           n2 = c2->numargs;
  730.     ComListElement *a1 = c1->com_list_array,
  731.                *a2 = c2->com_list_array;
  732.  
  733.     n = (n1 > n2) ? n2: n1;
  734.     for (i=0; i<n; i++){
  735.         if(a1[i].type != a2[i].type){
  736.         typerr = 1;
  737.         break;
  738.         }
  739.     }
  740.     for (i=0; i<n; i++){
  741.         if(a1[i].dimen_info != a2[i].dimen_info){
  742.         dimerr = 1;
  743.         break;
  744.         }
  745.     }
  746.     if(n1 != n2){
  747. fprintf(list_fd,"\nCommon block %s: varying length:", name);
  748. fprintf(list_fd,
  749.     "\n\tDeclared with %d variable%s in module %s line %u file %s",
  750.                 n1,pluralize(n1),
  751.             c1->module->name,
  752.             c1->line_num,
  753.             c1->filename);
  754. fprintf(list_fd,
  755.     "\n\tDeclared with %d variable%s in module %s line %u file %s",
  756.             n2,pluralize(n2),
  757.             c2->module->name,
  758.             c2->line_num,
  759.             c2->filename);
  760.         }
  761.     if(typerr){
  762.         typerr = 0;        /* start count over again */
  763.     fprintf(list_fd,"\nCommon block %s: data type mismatch",
  764.             name);
  765.         for (i=0; i<n; i++) {
  766.         if(a1[i].type != a2[i].type){
  767.             int t1 = datatype_of(a1[i].type),
  768.             t2 = datatype_of(a2[i].type);
  769.  
  770.                 /* stop after limit: probably a cascade */
  771.             if(++typerr > CMP_ERR_LIMIT) {
  772.                 fprintf(list_fd,"\n etc...");
  773.                 break;
  774.             }
  775.  
  776. fprintf(list_fd, "\n  at position %d:", i+1);
  777. fprintf(list_fd,"\n\tVariable declared type %s in module %s line %u file %s",
  778.                 type_name[t1],
  779.                 c1->module->name,
  780.                 c1->line_num,
  781.                 c1->filename);
  782. fprintf(list_fd,"\n\tVariable declared type %s in module %s line %u file %s",
  783.                 type_name[t2],
  784.                 c2->module->name,
  785.                 c2->line_num,
  786.                 c2->filename);
  787.  
  788.         }
  789.         }
  790.     }
  791.     if(dimerr){
  792.         dimerr = 0;        /* start count over again */
  793.     fprintf(list_fd,"\nCommon block %s: array dimen/size mismatch",
  794.         name);
  795.         for (i=0; i<n; i++){
  796.         unsigned long d1, d2, s1, s2;
  797.  
  798.         if((d1=array_dims(a1[i].dimen_info)) !=
  799.             (d2=array_dims(a2[i].dimen_info))){
  800.  
  801.                 /* stop after limit: probably a cascade */
  802.             if(++dimerr > CMP_ERR_LIMIT) {
  803.                 fprintf(list_fd,"\n etc...");
  804.                 break;
  805.             }
  806. fprintf(list_fd, "\nat position %d:", i+1);
  807. fprintf(list_fd,
  808.     "\n\tDeclared with %ld dimension%s in module %s line %u file %s",
  809.                 d1,pluralize(d1),
  810.                 c1->module->name,
  811.                 c1->line_num,
  812.                 c1->filename);
  813. fprintf(list_fd,
  814.     "\n\tDeclared with %ld dimension%s in module %s line %u file %s",
  815.                 d2,pluralize(d2),
  816.                 c2->module->name,
  817.                 c2->line_num,
  818.                 c2->filename);
  819.         }
  820.  
  821.         if((s1=array_size(a1[i].dimen_info)) !=
  822.             (s2=array_size(a2[i].dimen_info))){
  823.  
  824.                 /* stop after limit: probably a cascade */
  825.             if(++dimerr > CMP_ERR_LIMIT) {
  826.                 fprintf(list_fd,"\n etc...");
  827.                 break;
  828.             }
  829.     fprintf(list_fd, "\nat position %d:", i+1);
  830.     fprintf(list_fd,
  831.     "\n\tDeclared with size %ld in module %s line %u file %s",
  832.                 s1,
  833.                 c1->module->name,
  834.                 c1->line_num,
  835.                 c1->filename);
  836.     fprintf(list_fd,
  837.     "\n\tDeclared with size %ld in module %s line %u file %s",
  838.                 s2,
  839.                 c2->module->name,
  840.                 c2->line_num,
  841.                 c2->filename);
  842.         }
  843.         }
  844.     }
  845. }/*com_cmp_strict*/
  846.  
  847. PRIVATE void
  848. sort_symbols(sp,n)      /* sorts a given list */
  849.     Lsymtab *sp[];
  850.     unsigned n;
  851. {
  852.     int i,j,swaps;
  853.     for(i=0;i<n;i++) {
  854.         swaps = 0;
  855.         for(j=n-1;j>=i+1;j--) {
  856.         if((strcmp(sp[j-1]->name, sp[j]->name)) > 0) {
  857.            swap_symptrs(&sp[j-1], &sp[j]);
  858.            swaps ++;
  859.         }
  860.         }
  861.         if(swaps == 0) break;
  862.     }
  863. }
  864.  
  865.  
  866. PRIVATE void            /* swaps two pointers */
  867. swap_symptrs(x_ptr,y_ptr)
  868.     Lsymtab **x_ptr,**y_ptr;
  869. {
  870.     Lsymtab *temp = *x_ptr;
  871.     *x_ptr = *y_ptr;
  872.     *y_ptr = temp;
  873. }
  874.  
  875.  
  876. void
  877. print_loc_symbols(curmodhash)
  878.      int curmodhash;        /* hash entry of current module */
  879. {
  880.     Lsymtab *sym_list[LOCSYMTABSZ]; /* temp. list of symtab entries to print */
  881.     int    mod_type,        /* datatype of this module */
  882.     this_is_a_function;    /* flag for treating funcs specially */
  883.     Lsymtab *module;         /* entry of current module in symtab */
  884.     char *mod_name;        /* module name */
  885.     unsigned
  886.     com_vars_modified=0,    /* count of common variables which are set */
  887.     args_modified=0,    /* count of arguments which are set */
  888.     imps=0,            /* count of implicitly declared identifiers */
  889.     numentries;        /* count of entry points of module */
  890.  
  891.  
  892.  
  893.             /* Keep track of symbol table and string usage */
  894.     if(loc_symtab_top > max_loc_symtab) {
  895.     max_loc_symtab = loc_symtab_top;
  896.     }
  897.     if(loc_str_top > max_loc_strings) {
  898.     max_loc_strings = loc_str_top;
  899.     }
  900.     if(token_space_top > max_token_space) {
  901.         max_token_space = token_space_top;
  902.     }
  903.             /* Global symbols only increase in number */
  904.     max_glob_symtab = glob_symtab_top;
  905.     max_glob_strings = STRSPACESZ - glob_str_bot;
  906.  
  907.  
  908.  
  909.             /* Set up name & type, and see what kind of module it is */
  910.  
  911.           module = hashtab[curmodhash].loc_symtab;
  912.  
  913.           mod_name = module->name;
  914.           mod_type = get_type(module);
  915.  
  916.           if(  mod_type != type_PROGRAM
  917.         && mod_type != type_SUBROUTINE
  918.         && mod_type != type_COMMON_BLOCK
  919.         && mod_type != type_BLOCK_DATA )
  920.             this_is_a_function = TRUE;
  921.           else
  922.             this_is_a_function = FALSE;
  923.  
  924.                   /* Print name & type of the module */
  925.     if(do_symtab) {
  926.       unsigned i;
  927.       for(i=0,numentries=0;i<loc_symtab_top;i++) {
  928.     if(loc_symtab[i].entry_point)
  929.       sym_list[numentries++] = &loc_symtab[i];
  930.       }
  931.  
  932.        if(numentries > 1) {
  933.           sort_symbols(sym_list,numentries);
  934.        }
  935.  
  936.  
  937.       fprintf(list_fd,"\n\nModule %s:",mod_name);
  938.       if( this_is_a_function ) fprintf(list_fd," func:");
  939.       fprintf(list_fd," %4s",type_name[mod_type]);
  940.             /* Print a * next to non-declared function name */
  941.       if(datatype_of(module->type) == type_UNDECL ) {
  942.             fprintf(list_fd,"*");
  943.             imps++;
  944.       }
  945.       fprintf(list_fd,"\n");
  946.  
  947.  
  948.                 /* Print Entry Points (skip if only one,
  949.                    since it is same as module name) */
  950.       if(do_symtab && numentries > 1) {
  951.           fprintf(list_fd,"\nEntry Points\n");
  952.           (void) print_symbols(list_fd,sym_list,numentries,FALSE);
  953.       }
  954.  
  955.             /* End of printing module name and entry points */
  956.     }/*if(do_symtab)*/
  957.  
  958.  
  959.  
  960.                 /* Print the externals */
  961.  
  962.     if(do_symtab) {
  963.         unsigned i,n;
  964.     for(i=0,n=0;i<loc_symtab_top;i++) {
  965.         if(storage_class_of(loc_symtab[i].type) == class_SUBPROGRAM) {
  966.                 sym_list[n++] = &loc_symtab[i];
  967.         }
  968.     }
  969.     if(n != 0) {
  970.           sort_symbols(sym_list,n);
  971.  
  972.  
  973.           fprintf(list_fd,"\nExternal subprograms referenced:\n");
  974.           imps += print_symbols(list_fd,sym_list,n,TRUE);
  975.     }
  976.  
  977.       }/*if(do_symtab)*/
  978.  
  979.  
  980.                 /* Print list of statement functions */
  981.     if(do_symtab) {
  982.            unsigned i,n;
  983.  
  984.        for(i=0,n=0;i<loc_symtab_top;i++) {
  985.            if(storage_class_of(loc_symtab[i].type) == class_STMT_FUNCTION){
  986.                 sym_list[n++] = &loc_symtab[i];
  987.            }
  988.        }
  989.        if(n != 0) {
  990.           sort_symbols(sym_list,n);
  991.           fprintf(list_fd,"\nStatement functions defined:\n");
  992.           imps += print_symbols(list_fd,sym_list,n,TRUE);
  993.         }
  994.     }/*if(do_symtab)*/
  995.  
  996.  
  997.                 /* Print the common blocks */
  998.     if(do_symtab || port_check) {
  999.            unsigned i,numblocks;
  1000.  
  1001.        for(i=0,numblocks=0;i<loc_symtab_top;i++) {
  1002.           if(storage_class_of(loc_symtab[i].type) == class_COMMON_BLOCK) {
  1003.                 sym_list[numblocks++] = &loc_symtab[i];
  1004.           }
  1005.        }
  1006.  
  1007.        if(numblocks != 0) {
  1008.           sort_symbols(sym_list,numblocks);
  1009.           if(do_symtab) {
  1010.           fprintf(list_fd,"\nCommon blocks referenced:\n");
  1011.           (void) print_symbols(list_fd,sym_list,numblocks,FALSE);
  1012.           }
  1013.           if(port_check) {
  1014.             check_mixed_common(list_fd,sym_list,numblocks);
  1015.           }
  1016.        }
  1017.      }/*if(do_symtab||port_check)*/
  1018.  
  1019.                 /* Print the namelists */
  1020.     if(do_symtab) {
  1021.            unsigned i,numlists;
  1022.  
  1023.        for(i=0,numlists=0;i<loc_symtab_top;i++) {
  1024.           if(storage_class_of(loc_symtab[i].type) == class_NAMELIST) {
  1025.                 sym_list[numlists++] = &loc_symtab[i];
  1026.           }
  1027.        }
  1028.  
  1029.        if(numlists != 0) {
  1030.           sort_symbols(sym_list,numlists);
  1031.           if(do_symtab) {
  1032.           fprintf(list_fd,"\nNamelists defined:\n");
  1033.           (void) print_symbols(list_fd,sym_list,numlists,FALSE);
  1034.           }
  1035.         }
  1036.  
  1037.     }/* End printing the namelists */
  1038.                 /* Process the variables */
  1039.  
  1040.     if(do_symtab || usage_check) {
  1041.         unsigned i,n;
  1042.  
  1043.     for(i=0,n=0;i<loc_symtab_top;i++) {
  1044.            if(storage_class_of(loc_symtab[i].type) == class_VAR
  1045.            && (!loc_symtab[i].entry_point || this_is_a_function)) {
  1046.           sym_list[n++] = &loc_symtab[i];
  1047.           if(loc_symtab[i].argument && loc_symtab[i].set_flag) {
  1048.             if(++args_modified <= 3)
  1049.             if(this_is_a_function && pure_functions)
  1050.                 fprintf(list_fd,
  1051.                   "\nFunction %s %s argument %s",
  1052.                   mod_name,
  1053.                   loc_symtab[i].assigned_flag?
  1054.                     "modifies":"may modify",
  1055.                   loc_symtab[i].name);
  1056.           }
  1057.           if(loc_symtab[i].common_var && loc_symtab[i].set_flag) {
  1058.             if(++com_vars_modified <= 3)
  1059.             if(this_is_a_function && pure_functions)
  1060.                 fprintf(list_fd,
  1061.                   "\nFunction %s %s common variable %s",
  1062.                   mod_name,
  1063.                   loc_symtab[i].assigned_flag?
  1064.                     "modifies":"may modify",
  1065.                   loc_symtab[i].name);
  1066.           }
  1067.            }
  1068.     }
  1069.     if(args_modified > 3 || com_vars_modified > 3)
  1070.       if(this_is_a_function && pure_functions)
  1071.         fprintf(list_fd,"\netc...");
  1072.     if(n != 0) {
  1073.        sort_symbols(sym_list,n);
  1074.  
  1075.             /* Print the variables */
  1076.  
  1077.        if(do_symtab) {
  1078.           fprintf(list_fd,"\nVariables:\n ");
  1079.           imps += print_variables(sym_list,n);
  1080.        }
  1081.         }
  1082.             /* Explain the asterisk on implicitly defined
  1083.                identifiers.  Note that this message will
  1084.                be given also if functions implicitly defined */
  1085.     if(do_symtab && imps != 0) {
  1086.          fprintf(list_fd,"\n* Variable not declared.");
  1087.          fprintf(list_fd," Type has been implicitly defined.\n");
  1088.     }
  1089.  
  1090.     if(usage_check) {
  1091.       if(do_symtab || do_list)
  1092.         fprintf(list_fd,"\n");
  1093.       if(check_unused) {
  1094.         check_flags(sym_list,n,0,0,0,
  1095.               "declared but never referenced",mod_name);
  1096.         check_flags(sym_list,n,0,1,0,
  1097.               "set but never used",mod_name);
  1098.       }
  1099.       if(check_set_used) {
  1100.         check_flags(sym_list,n,1,0,1,
  1101.               "used before set",mod_name);
  1102.         check_flags(sym_list,n,1,1,1,
  1103.               "may be used before set",mod_name);
  1104.       }
  1105.  
  1106.     }/*end if(usage_check)*/
  1107.  
  1108.     if(do_symtab || do_list)
  1109.       fprintf(list_fd,"\n");
  1110.  
  1111.     }/* end if(do_symtab || usage_check) */
  1112.  
  1113.             /* List all undeclared vars & functions */
  1114.     if(decls_required || implicit_none) {
  1115.         unsigned i,n;
  1116.  
  1117.     for(i=0,n=0;i<loc_symtab_top;i++) {
  1118.         if(datatype_of(loc_symtab[i].type) == type_UNDECL
  1119.         && ! loc_symtab[i].intrinsic /* omit intrinsics */
  1120.                 /* omit subroutines called */
  1121.         && (!loc_symtab[i].external || loc_symtab[i].invoked_as_func)
  1122.            ) {
  1123.         sym_list[n++] = &loc_symtab[i];
  1124.         }
  1125.     }
  1126.     if(n != 0) {
  1127.         sort_symbols(sym_list,n);
  1128.         fprintf(list_fd,"\nIdentifiers of undeclared type in module %s:",
  1129.             mod_name);
  1130.         (void) print_symbols(list_fd,sym_list,n,FALSE);
  1131.     }
  1132.     }/*if(decls_required || implicit_none)*/
  1133.  
  1134.         /* issue portability warning for identifiers
  1135.            longer than 6 characters
  1136.         */
  1137.     if(f77_standard) {
  1138.         unsigned i,n;
  1139.     for(i=0,n=0;i<loc_symtab_top;i++) {
  1140.            if(strlen(loc_symtab[i].name) > 6)
  1141.           sym_list[n++] = &loc_symtab[i];
  1142.     }
  1143.  
  1144.     if(n != 0) {
  1145.  
  1146.        sort_symbols(sym_list,n);
  1147.  
  1148.        ++warning_count;
  1149.  
  1150.        fprintf(list_fd,
  1151.        "\nNames longer than 6 chars in module %s (nonstandard):",
  1152.             mod_name);
  1153.        (void) print_symbols(list_fd,sym_list,n,FALSE);
  1154.     }
  1155.     }
  1156.  
  1157.     /* If -f77 flag given, list names with underscore or dollarsign */
  1158.  
  1159. #if ALLOW_UNDERSCORES || ALLOW_DOLLARSIGNS
  1160.     if(f77_standard) {
  1161.         unsigned i,n;
  1162.     for(i=0,n=0;i<loc_symtab_top;i++) {
  1163.             /* Find all names with nonstd chars, but
  1164.                exclude internal names like %MAIN */
  1165.            if(has_nonalnum(loc_symtab[i].name) &&
  1166.           loc_symtab[i].name[0] != '%')
  1167.           sym_list[n++] = &loc_symtab[i];
  1168.     }
  1169.  
  1170.     if(n != 0) {
  1171.  
  1172.        sort_symbols(sym_list,n);
  1173.  
  1174.        ++warning_count;
  1175.  
  1176.        fprintf(list_fd,
  1177.        "\nNames containing nonstandard characters in module %s:",
  1178.             mod_name);
  1179.        (void) print_symbols(list_fd,sym_list,n,FALSE);
  1180.     }
  1181.     }/*if(f77_standard)*/
  1182. #endif
  1183.  
  1184.             /* Print out clashes in first six chars of name */
  1185.     if(sixclash) {
  1186.      unsigned n;
  1187.      n = find_sixclashes(sym_list);
  1188.      if(n != 0) {
  1189.         sort_symbols(sym_list,n);
  1190.         fprintf(list_fd,
  1191.     "\nIdentifiers which are not unique in first six chars in module %s:"
  1192.         ,mod_name);
  1193.         (void) print_symbols(list_fd,sym_list,n,FALSE);
  1194.      }/* end if(n != 0) */
  1195.     }/* end if(sixclash) */
  1196.  
  1197.  
  1198.         /* If portability flag was given, check equivalence
  1199.            groups for mixed type. */
  1200.     if(port_check) {
  1201.         unsigned i,j,n;
  1202.     int caption_given=FALSE;
  1203.     unsigned imps=0;
  1204.     Lsymtab *equiv;
  1205.  
  1206.         /* scan thru table for equivalenced variables */
  1207.     for(i=0;i<loc_symtab_top;i++) {
  1208.         if(storage_class_of(loc_symtab[i].type) == class_VAR
  1209.            && loc_symtab[i].equiv_link != (equiv= &loc_symtab[i]) ){
  1210.         n=0;
  1211.         do {
  1212.             if(equiv < &loc_symtab[i]) { /* skip groups done before */
  1213.             n=0;
  1214.             break;
  1215.             }
  1216.             sym_list[n++] = equiv;
  1217.             equiv = equiv->equiv_link;
  1218.         } while(equiv != &loc_symtab[i]); /* complete the circle */
  1219.                 /* Check for mixed types */
  1220.         if(n != 0) {
  1221.             int mixed_type = FALSE;
  1222.             for(j=1; j<n; j++) {
  1223.             if(get_type(sym_list[j]) != get_type(sym_list[j-1])) {
  1224.                 mixed_type = TRUE;
  1225.                 break;
  1226.             }
  1227.             }
  1228.  
  1229.             if(mixed_type) {
  1230.             sort_symbols(sym_list,n);
  1231.             if(caption_given)/* give short or long caption */
  1232.                 fprintf(list_fd," and");
  1233.             else {
  1234.                 fprintf(list_fd,
  1235.                 "\nMixed types equivalenced in module %s",
  1236.                     mod_name);
  1237.                 fprintf(list_fd,
  1238.                     " (not portable):");
  1239.                 caption_given = TRUE;
  1240.             }
  1241.             imps += print_symbols(list_fd,sym_list,n,TRUE);
  1242.             }
  1243.         }
  1244.         }
  1245.     }
  1246.     if(imps != 0) {
  1247.          fprintf(list_fd,"\n* Variable not declared.");
  1248.          fprintf(list_fd," Type has been implicitly defined.\n");
  1249.     }
  1250.  
  1251.     }/*if(port_check)*/
  1252.  
  1253. }/* print_loc_symbols */
  1254.  
  1255. PRIVATE int
  1256. has_nonalnum(s)    /* Returns TRUE if s contains a non-alphanumeric character */
  1257.    char *s;
  1258. {
  1259.    while( *s != '\0' )
  1260.      if( ! isalnum( (int)(*s++) ) )
  1261.        return TRUE;
  1262.    return FALSE;
  1263. }
  1264.  
  1265.      /* This routine prints symbol names neatly.  If do_types is true
  1266.     also prints types, with * next to implicitly
  1267.     typed identifiers, and returns count thereof. */
  1268.  
  1269. PRIVATE unsigned
  1270. print_symbols(fd,sym_list,n,do_types)
  1271.      FILE *fd;
  1272.      Lsymtab *sym_list[];
  1273.      unsigned n;
  1274.      int do_types;
  1275. {
  1276.      unsigned i,col=0,len,implicits=0;
  1277.  
  1278.      fprintf(fd,"\n");
  1279.  
  1280.      for(i=0;i<n;i++) {
  1281.       len = strlen(sym_list[i]->name);
  1282.       col += len = (len <= 10? 10: len) + 9;
  1283.       if(col > 78) {
  1284.         fprintf(fd,"\n");
  1285.         col = len;
  1286.       }
  1287.       fprintf(fd,"%10s",sym_list[i]->name);
  1288.       if( do_types ) {
  1289.         if(sym_list[i]->intrinsic)
  1290.           fprintf(fd,": intrns ");
  1291.         else
  1292.           fprintf(fd,": %4s%1s  ",
  1293.             type_name[get_type(sym_list[i])],
  1294.             (datatype_of(sym_list[i]->type) == type_UNDECL)?
  1295.               (implicits++,"*" ) : ""
  1296.             );
  1297.       }
  1298.       else
  1299.         fprintf(fd,"%9s","");
  1300.      }
  1301.  
  1302.      fprintf(fd,"\n");
  1303.  
  1304.      return implicits;
  1305.  
  1306. }/*print_symbols*/
  1307.  
  1308.  
  1309.  
  1310.     /* This routine prints the variables nicely, and returns
  1311.         count of number implicitly defined.
  1312.      */
  1313. PRIVATE unsigned
  1314. print_variables(sym_list,n)
  1315.      Lsymtab *sym_list[];
  1316.      unsigned n;
  1317. {
  1318.      unsigned i,implicits=0;
  1319.  
  1320.      fprintf(list_fd,"\n ");
  1321.  
  1322.      for(i=0; i<4; i++) {
  1323.       fprintf(list_fd,"%5sName Type Dims","");
  1324.               /* 12345678901234567890 template for above*/
  1325.      }
  1326.      for(i=0; i<n; i++) {
  1327.       if(i % 4 == 0)
  1328.          fprintf(list_fd,"\n");
  1329.       else
  1330.          fprintf(list_fd," ");
  1331.  
  1332.       fprintf(list_fd,"%10s",sym_list[i]->name);
  1333.             /* Print a * next to non-declared variables */
  1334.       fprintf(list_fd," %4s%1s",
  1335.              type_name[get_type(sym_list[i])],
  1336.              (datatype_of(sym_list[i]->type) == type_UNDECL )?
  1337.                  (implicits++,"*") : ""
  1338.           );
  1339.  
  1340.             /* print no. of dimensions next to var name */
  1341.       if(sym_list[i]->array_var) {
  1342.         fprintf(list_fd," %ld",
  1343.                    array_dims(sym_list[i]->info.array_dim));
  1344.       }
  1345.       else {
  1346.           fprintf(list_fd,"%2s","");
  1347.       }
  1348.     }
  1349.  
  1350.     fprintf(list_fd,"\n");
  1351.  
  1352.     return implicits;
  1353.  
  1354. }/*print_variables*/
  1355.  
  1356.  
  1357.     /* Search thru local symbol table for clashes where identifiers
  1358.        are not unique in 1st six characters. Return value =
  1359.        number of clashes found, with pointers to symbol table
  1360.        entries of clashers in array list. */
  1361. PRIVATE unsigned
  1362. find_sixclashes(list)
  1363.     Lsymtab *list[];
  1364. {
  1365.     unsigned i,h, clashes=0;
  1366.     int class;
  1367.     unsigned long hnum;
  1368.  
  1369.     for(i=0; i<loc_symtab_top; i++) {    /* Scan thru symbol table */
  1370.         class = storage_class_of(loc_symtab[i].type);
  1371.         hnum = hash( loc_symtab[i].name );
  1372.                 /* First look for a clash of any kind.
  1373.                    (N.B. this loop will never quit if hash
  1374.                    table is full, but let's not worry) */
  1375.         while( (h=hnum % HASHSZ), hashtab[h].name != (char *)NULL) {
  1376.         /* Now see if the clashing name is used locally and still
  1377.            clashes at 6 chars.  Treat common blocks separately. */
  1378.  
  1379.          if((class == class_COMMON_BLOCK &&
  1380.               (
  1381.            hashtab[h].com_loc_symtab != NULL
  1382.            && strcmp( hashtab[h].name,loc_symtab[i].name) != 0
  1383.            && strncmp(hashtab[h].name,loc_symtab[i].name,6) == 0
  1384.           )
  1385.         )  ||
  1386.          (class != class_COMMON_BLOCK &&
  1387.           (
  1388.            hashtab[h].loc_symtab != NULL
  1389.            && strcmp( hashtab[h].name,loc_symtab[i].name) != 0
  1390.            && strncmp(hashtab[h].name,loc_symtab[i].name,6) == 0
  1391.           )
  1392.          )
  1393.            ) {
  1394.                 /* If so, then i'th symbol is a clash */
  1395.  
  1396.             list[clashes++] = &loc_symtab[i];
  1397.             break;
  1398.         }
  1399.         else {
  1400.             hnum = rehash(hnum);
  1401.         }
  1402.         }
  1403.     }
  1404.     return clashes;
  1405. }
  1406.  
  1407.  
  1408. PRIVATE void
  1409. print_arg_array(arglist)        /* prints type and flag info for arguments */
  1410.     ArgListHeader *arglist;
  1411. {
  1412.     int i, count;
  1413.     ArgListElement *a;
  1414.  
  1415.     count = arglist->numargs;
  1416.     if(arglist->external_decl || arglist->actual_arg)
  1417.       count = 0;
  1418.     a = arglist->arg_array;
  1419.     fprintf(list_fd,"\nArg list in module %s file %s line %u:",
  1420.         arglist->module->name, arglist->filename, arglist->line_num);
  1421.     fprintf(list_fd,"\n\tdef%d call%d ext%d arg%d",
  1422.         arglist->is_defn,
  1423.         arglist->is_call,
  1424.         arglist->external_decl,
  1425.         arglist->actual_arg);
  1426.     if(count == 0)
  1427.         fprintf(list_fd,"\n(Empty list)");
  1428.     else {
  1429.         for (i=0; i<count; i++) {
  1430.         fprintf(list_fd,
  1431.             "\n\t%d %s: lv%d st%d as%d ub%d ar%d ae%d ex%d",
  1432.             i+1,
  1433.             type_name[datatype_of(a[i].type)],
  1434.                 a[i].is_lvalue,
  1435.                 a[i].set_flag,
  1436.                 a[i].assigned_flag,
  1437.                 a[i].used_before_set,
  1438.                 a[i].array_var,
  1439.                 a[i].array_element,
  1440.                 a[i].declared_external);
  1441.         if(a[i].array_var)
  1442.             fprintf(list_fd,"(%ld,%ld)",
  1443.             array_dims(a[i].info.array_dim),
  1444.             array_size(a[i].info.array_dim) );
  1445.         fprintf(list_fd,", ");
  1446.         }
  1447.     }
  1448. }/* print_arg_array */
  1449.  
  1450.  
  1451.            /* prints type and dimen info for common vars */
  1452. PRIVATE void
  1453. print_com_array(cmlist)
  1454.     ComListHeader *cmlist;
  1455. {
  1456.     int i, count;
  1457.     ComListElement *c;
  1458.  
  1459.     count = cmlist->numargs;
  1460.     c = cmlist->com_list_array;
  1461.     fprintf(list_fd,"\nCom list in module %s file %s line %u:",
  1462.         cmlist->module->name, cmlist->filename, cmlist->line_num);
  1463.     fprintf(list_fd,"\n\t");
  1464.     if(count == 0)
  1465.         fprintf(list_fd,"(Empty list)");
  1466.     else {
  1467.         for (i=0; i<count; i++){
  1468.         fprintf(list_fd,"%s",type_name[datatype_of(c[i].type)]);
  1469.         if(c[i].dimen_info)
  1470.             fprintf(list_fd,":%ldD(%ld)",array_dims(c[i].dimen_info),
  1471.                        array_size(c[i].dimen_info));
  1472.         fprintf(list_fd,", ");
  1473.         }
  1474.     }
  1475. }/* print_com_array */
  1476.  
  1477.  
  1478. PRIVATE void
  1479. print_tokenlist(toklist)        /* prints list of token names or types */
  1480.     TokenListHeader *toklist;
  1481. {
  1482.     int numargs=0;
  1483.     Token *t;
  1484.     fprintf(list_fd,"\n");
  1485.     if (toklist == NULL){
  1486.         fprintf(list_fd,"\t(No list)");
  1487.     }
  1488.     else {
  1489.         t = toklist->tokenlist;
  1490.         while(t != NULL){
  1491.         ++numargs;
  1492.         fprintf(list_fd," ");
  1493.         if ( is_true(ID_EXPR,t->subclass) )
  1494.             fprintf(list_fd,"%s ",token_name(*t));
  1495.         else
  1496.             fprintf(list_fd,"%s ",type_name[datatype_of(t->class)]);
  1497.         t = t->next_token;
  1498.         }
  1499.         if(numargs == 0)
  1500.             fprintf(list_fd,"\t(Empty list)");
  1501.     }
  1502. }/* print_tokenlist */
  1503.  
  1504.  
  1505. void
  1506. debug_symtabs()     /* Debugging output: hashtable and symbol tables */
  1507. {
  1508.   if(debug_loc_symtab) {
  1509.     fprintf(list_fd,"\n Debugging of local symbol table disabled");
  1510.     return;
  1511.   }
  1512.  
  1513.     if(debug_hashtab) {
  1514.         int i;
  1515.     fprintf(list_fd,"\n\nContents of hashtable\n");
  1516.     for(i=0; i<HASHSZ; i++) {
  1517.         if(hashtab[i].name != NULL) {
  1518.           fprintf(list_fd,"\n%4d %s",i,hashtab[i].name);
  1519.           if(hashtab[i].loc_symtab != NULL)
  1520.         fprintf(list_fd," loc %d",hashtab[i].loc_symtab-loc_symtab);
  1521.           if(hashtab[i].glob_symtab != NULL)
  1522.         fprintf(list_fd,
  1523.             " glob %d",hashtab[i].glob_symtab-glob_symtab);
  1524.           if(hashtab[i].com_loc_symtab != NULL)
  1525.         fprintf(list_fd,
  1526.             " Cloc %d",hashtab[i].com_loc_symtab-loc_symtab);
  1527.           if(hashtab[i].com_glob_symtab != NULL)
  1528.         fprintf(list_fd,
  1529.             " Cglob %d",hashtab[i].com_glob_symtab-glob_symtab);
  1530.         }
  1531.     }
  1532.     }
  1533.  
  1534.     if(debug_glob_symtab) {
  1535.         int i;
  1536.     fprintf(list_fd,"\n\nContents of global symbol table");
  1537.  
  1538.     for(i=0; i<glob_symtab_top; i++) {
  1539.         fprintf(list_fd,
  1540.         "\n%4d %s type 0x%x=%s,%s: ",
  1541.         i,
  1542.         glob_symtab[i].name,
  1543.         glob_symtab[i].type,
  1544.         class_name[storage_class_of(glob_symtab[i].type)],
  1545.         type_name[datatype_of(glob_symtab[i].type)]
  1546.          );
  1547.         fprintf(list_fd,
  1548.       "usd%d set%d asg%d ubs%d lib%d int%d invf%d vis%d smw%d incl%d ext%d ",
  1549.         glob_symtab[i].used_flag,
  1550.         glob_symtab[i].set_flag,
  1551.         glob_symtab[i].assigned_flag,
  1552.         glob_symtab[i].used_before_set,
  1553.         glob_symtab[i].library_module,
  1554.         glob_symtab[i].internal_entry,
  1555.         glob_symtab[i].invoked_as_func,
  1556.         glob_symtab[i].visited,
  1557.         glob_symtab[i].visited_somewhere,
  1558.         glob_symtab[i].defined_in_include,
  1559.         glob_symtab[i].declared_external
  1560.             );
  1561.         switch(storage_class_of(glob_symtab[i].type)){
  1562.         case class_COMMON_BLOCK:{
  1563.             ComListHeader *clist;
  1564.             clist=glob_symtab[i].info.comlist;
  1565.             while(clist != NULL){
  1566.             print_com_array(clist);
  1567.             clist = clist->next;
  1568.             }
  1569.             break;
  1570.         }
  1571.         case class_SUBPROGRAM:{
  1572.             ArgListHeader *alist;
  1573.             alist=glob_symtab[i].info.arglist;
  1574.             while(alist != NULL){
  1575.             print_arg_array(alist);
  1576.             alist = alist->next;
  1577.             }
  1578.             break;
  1579.         }
  1580.         }
  1581.     }
  1582.     }
  1583.  
  1584. }/* debug_symtabs*/
  1585.  
  1586.  
  1587. PRIVATE void
  1588. check_mixed_common(fd,sym_list,n)
  1589.      FILE *fd;
  1590.      Lsymtab *sym_list[];
  1591.      unsigned n;
  1592. {
  1593.     int i;
  1594.     for(i=0; i<n; i++) {
  1595.     ComListHeader *chead = sym_list[i]->info.comlist;
  1596.     ComListElement *clist;
  1597.     int j,nvars;
  1598.     int has_char=FALSE,has_nonchar=FALSE;
  1599.     int size, next_size;
  1600.  
  1601.     if(chead == NULL)
  1602.       continue;
  1603.     clist=chead->com_list_array;
  1604.     nvars = chead->numargs;
  1605.  
  1606.     if(nvars > 0)
  1607.       size = type_size[datatype_of(clist[0].type)];
  1608.  
  1609.     for(j=0; j<nvars; j++) {
  1610.  
  1611.        /* Check conformity to ANSI rule: no mixing char with other types */
  1612.  
  1613.       if(datatype_of(clist[j].type) == type_STRING)
  1614.         has_char = TRUE;
  1615.       else
  1616.         has_nonchar = TRUE;
  1617.       if(has_char && has_nonchar) {
  1618.         fprintf(fd,
  1619.             "\nCommon block %s line %u module %s has mixed",
  1620.             sym_list[i]->name,
  1621.             chead->line_num,
  1622.             chead->module->name);
  1623.         fprintf(fd,"\n  character and non-character variables");
  1624.         fprintf(fd," (may not be portable)");
  1625.         break;
  1626.       }
  1627.  
  1628.     /* Check that variables are in descending order of type size */
  1629.  
  1630.       if( (next_size = type_size[datatype_of(clist[j].type)]) > size ) {
  1631.         fprintf(fd,
  1632.             "\nCommon block %s line %u module %s has long data type",
  1633.             sym_list[i]->name,
  1634.             chead->line_num,
  1635.             chead->module->name);
  1636.         fprintf(fd,
  1637.             "\n  following short data type (may not be portable)");
  1638.         break;
  1639.       }
  1640.       size = next_size;
  1641.     }
  1642.     }
  1643. }
  1644.  
  1645.  
  1646. PRIVATE
  1647. void
  1648. check_flags(list,n,used,set,ubs,msg,mod_name)
  1649.     Lsymtab *list[];
  1650.     unsigned n;
  1651.     unsigned used,set,ubs;
  1652.     char *msg,*mod_name;
  1653. {
  1654.     int matches=0,col=0,unused_args=0,i,len;
  1655.     unsigned pattern = flag_combo(used,set,ubs);
  1656.  
  1657.     for(i=0;i<n;i++) {
  1658.         if( list[i]->common_var )    /* common vars are immune */
  1659.            continue;
  1660.                 /* for args, do only 'never used' */
  1661.         if( list[i]->argument && pattern != flag_combo(0,0,0) )
  1662.            continue;
  1663.  
  1664. #ifdef ALLOW_INCLUDE
  1665.                 /* Skip variables 'declared but not used'
  1666.                    and parameters 'set but never used'
  1667.                    if defined in include file. */
  1668.  
  1669.         if( list[i]->defined_in_include &&
  1670.            ( pattern == flag_combo(0,0,0)
  1671.            || (list[i]->parameter && pattern == flag_combo(0,1,0)) ) )
  1672.             continue;
  1673. #endif
  1674.             /*  function return val: ignore 'set but never used' */
  1675.         if( list[i]->entry_point && pattern == flag_combo(0,1,0) )
  1676.         continue;
  1677.  
  1678.         if(flag_combo(list[i]->used_flag,list[i]->set_flag,
  1679.            list[i]->used_before_set) == pattern) {
  1680.          if(matches++ == 0)
  1681.             fprintf(list_fd,"\nVariables %s in module %s:\n",
  1682.                 msg,mod_name);
  1683.          len = strlen(list[i]->name);
  1684.          col += len = (len <= 10? 10: len) + 9;
  1685.          if(col > 78) {
  1686.            fprintf(list_fd,"\n");
  1687.            col = len;
  1688.          }
  1689.          fprintf(list_fd,"%10s",list[i]->name);
  1690.                 /* arg never used: tag with asterisk */
  1691.          fprintf(list_fd,"%-9s",
  1692.              list[i]->argument? (++unused_args,"*") : "" );
  1693.         }
  1694.     }
  1695.     if(unused_args > 0)
  1696.         fprintf(list_fd,"\n  * Dummy argument");
  1697.     if(matches > 0)
  1698.         fprintf(list_fd,"\n");
  1699. }
  1700.  
  1701. void
  1702. visit_children()
  1703. {
  1704.   int i,num_mains;
  1705.  
  1706.   if(print_call_tree)
  1707.     fprintf(list_fd,"\nTree of subprogram calls:");
  1708.  
  1709.   for(i=0; i<glob_symtab_top; i++) {
  1710.     if(storage_class_of(glob_symtab[i].type) == class_SUBPROGRAM
  1711.        && ! glob_symtab[i].internal_entry) {
  1712.       sort_child_list(glob_symtab[i].link.child_list);
  1713.     }
  1714.   }
  1715.  
  1716.                 /* Visit children of all main progs */
  1717.   for(i=0,num_mains=0; i<glob_symtab_top; i++) {
  1718.     if(storage_class_of(glob_symtab[i].type) == class_SUBPROGRAM
  1719.        && datatype_of(glob_symtab[i].type) == type_PROGRAM) {
  1720.       visit_child(&glob_symtab[i],0);
  1721.       ++num_mains;
  1722.     }
  1723.   }
  1724.                 /* If no main program found, give
  1725.                    warning unless -noextern was set */
  1726.   if(num_mains == 0) {
  1727.     if(print_call_tree)
  1728.       fprintf(list_fd,"\n  (no main program found)");
  1729.     else if(ext_def_check)
  1730.       fprintf(list_fd,"\nNo main program found");
  1731.  
  1732.         /* If no main, visit trees rooted at unvisited
  1733.            nonlibrary routines, as the
  1734.            next best thing.
  1735.          */
  1736.     for(i=0; i<glob_symtab_top; i++) {
  1737.       if(storage_class_of(glob_symtab[i].type) == class_SUBPROGRAM
  1738.     && !glob_symtab[i].library_module && !glob_symtab[i].used_flag) {
  1739.       visit_child(&glob_symtab[i],0);
  1740.       }
  1741.     }
  1742.   }
  1743.   if(print_call_tree)
  1744.     fprintf(list_fd,"\n");
  1745. }
  1746.  
  1747.  
  1748.                 /* Depth-first search of call tree */
  1749. PRIVATE void
  1750. visit_child(gsymt,level)
  1751.      Gsymtab *gsymt;
  1752.      int level;
  1753. {
  1754.   static char fmt[]="%000s";    /* Variable format for indenting names */
  1755.   ChildList *child_list;
  1756.   int i,n;
  1757.  
  1758.  
  1759.   if(print_call_tree) {
  1760.     fprintf(list_fd,"\n");
  1761.     if(level > 0) {
  1762.       sprintf(fmt,"%%%ds",level*4); /* indent 4 spaces per nesting level */
  1763.       fprintf(list_fd,fmt,"");
  1764.     }
  1765.     fprintf(list_fd,"%s",gsymt->name);
  1766.   }
  1767.  
  1768.  
  1769.  
  1770.                 /* Visit its unvisited children.  Note
  1771.                    that children of internal entry are
  1772.                    taken as those of its superior module.
  1773.                  */
  1774.   child_list = (gsymt->internal_entry?gsymt->link.module:gsymt)
  1775.            ->link.child_list;
  1776.  
  1777.                 /* If already visited, do not visit its
  1778.                    children, but give note to reader if it
  1779.                    has some. */
  1780.   if(gsymt->visited) {
  1781.     if(print_call_tree && child_list != NULL)
  1782.       fprintf(list_fd," (see above)");
  1783.   }
  1784.   else {
  1785.                 /* Mark node as visited */
  1786.     gsymt->visited = TRUE;
  1787.                 /* Record that containing module
  1788.                    is visited via this entry point*/
  1789.     if(gsymt->internal_entry)
  1790.       gsymt->link.module->visited_somewhere = TRUE;
  1791.     else
  1792.       gsymt->visited_somewhere = TRUE;
  1793.  
  1794.     ++level;            /* move to next level */
  1795.     while(child_list != NULL) {
  1796.       visit_child(child_list->child,level);
  1797.       child_list = child_list->next;
  1798.     }
  1799.   }
  1800. }
  1801.  
  1802.                 /* Insertion sort of child list.
  1803.                    Also removes duplicates which
  1804.                    can be introduced via multiple
  1805.                    defns or via project files. */
  1806. PRIVATE void
  1807. sort_child_list(child_list)
  1808.      ChildList *child_list;
  1809. {
  1810.   ChildList *front,*prev,*next;
  1811.   Gsymtab *temp;
  1812.   prev = NULL;
  1813.  
  1814.   while(child_list != NULL) {
  1815.             /* Scan thru list for lexicographically lowest name */
  1816.     front=child_list;
  1817.     for(next=child_list->next; next != NULL; next = next->next) {
  1818.       if(strcmp(front->child->name,next->child->name) > 0) {
  1819.     front = next;
  1820.       }
  1821.     }
  1822.             /* Swap child pointers so front is first */
  1823.     if(front != child_list) {
  1824.       temp = front->child;
  1825.       front->child = child_list->child;
  1826.       child_list->child = temp;
  1827.     }
  1828.             /* If duplicate, remove from list */
  1829.     if(prev != NULL && prev->child == child_list->child)
  1830.       prev->next = child_list->next;
  1831.     else
  1832.       prev = child_list;
  1833.     child_list = child_list->next;
  1834.   }
  1835. }
  1836.  
  1837.  
  1838.  
  1839.