home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / fchek284.zip / pgsymtab.c < prev    next >
C/C++ Source or Header  |  1996-03-29  |  68KB  |  2,461 lines
  1. /* pgsymtab.c:
  2.  
  3.         Routines associated with printing of global symbol table info
  4.  
  5.     Copyright (C) 1993 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.         check_com_usage() Checks usage status of common blocks & vars
  17.  
  18.  
  19.     Private functions defined:
  20.         arg_array_cmp()      Compares arg lists of subprog calls/defns
  21.         com_cmp_lax()      Compares common blocks at strictness 1,2
  22.         com_cmp_strict()  Compares common blocks at strictness 3
  23.         com_element_usage() Checks set/used status of common variables
  24.         com_block_usage() Checks for dead common blocks & variables
  25.         print_modules()      Prints names from a list of gsymt pointers.
  26.         sort_gsymbols()      Sorts the list of gsymt names.
  27.         swap_gsymptrs()      Swaps a pair of pointers.
  28.         visit_child()      Recursively visits callees of module,
  29.                   printing call tree as it goes.
  30.         visit_child_reflist() Recursively visits callees of module,
  31.                   printing reference list as it goes.
  32.         print_crossrefs() Prints list of callers of module.
  33.         toposort()      Topological sort of call tree.
  34.         sort_child_list() Sorts linked list of callees.
  35. */
  36.  
  37. #include <stdio.h>
  38. #include <ctype.h>
  39. #include <string.h>
  40. #include "ftnchek.h"
  41. #define PGSYMTAB
  42. #include "symtab.h"
  43.  
  44.  
  45. PRIVATE void
  46. com_cmp_lax(),com_cmp_strict(), arg_array_cmp(),
  47. visit_child(),visit_child_reflist(),sort_child_list();
  48. #ifdef VCG_SUPPORT
  49. PRIVATE void visit_child_vcg();
  50. #endif
  51.  
  52. PRIVATE void
  53. print_crossrefs(),sort_gsymbols(),swap_gsymptrs();
  54.  
  55. PRIVATE int
  56. toposort();
  57.  
  58. PRIVATE void
  59. com_element_usage(), com_block_usage(), print_modules();
  60.  
  61.  
  62.         /* Macro for testing whether an arglist or comlist header is
  63.            irrelevant for purposes of error checking: i.e. it comes
  64.            from an unvisited library module. */
  65. #define irrelevant(list) ((list)->module->library_module &&\
  66.                 !(list)->module->visited_somewhere)
  67.  
  68. #define pluralize(n) ((n)==1? "":"s")    /* singular/plural suffix for n */
  69.  
  70. #define CMP_ERR_LIMIT 3    /* stop printing errors after this many */
  71.  
  72.  
  73. PRIVATE int cmp_error_count;
  74. PRIVATE int
  75. cmp_error_head(name,message)
  76.      char *name,*message;
  77.     /* Increment error count, and if it is 1, print header for arg
  78.        mismatch error messages.  If it is past limit, print "etc"
  79.        and return TRUE, otherwise return FALSE.
  80.        */
  81. {
  82.         /* stop after limit: probably a cascade */
  83.     if(++cmp_error_count > CMP_ERR_LIMIT) {
  84.       (void)fprintf(list_fd,"\n etc...");
  85.       return TRUE;
  86.     }
  87.     if(cmp_error_count == 1)
  88.       (void)fprintf(list_fd,"\nSubprogram %s: %s",name,message);
  89.     return FALSE;
  90. }
  91. PRIVATE void
  92. arg_error_locate(alh)    /* Gives module, line, filename for error messages */
  93.      ArgListHeader *alh;
  94. {
  95.   if(novice_help) {        /* oldstyle messages */
  96.     (void)fprintf(list_fd," in module %s line %u file %s",
  97.             alh->module->name,
  98.             alh->line_num,
  99.             alh->filename);
  100.     if(alh->filename != alh->topfile) /* Track include filename */
  101.       (void)fprintf(list_fd," (included at line %u in %s)",
  102.             alh->top_line_num,
  103.             alh->topfile);
  104.   }
  105.   else {            /* lint-style messages */
  106.     (void)fprintf(list_fd," in module %s of \"%s\", line %u",
  107.             alh->module->name,
  108.             alh->filename,
  109.             alh->line_num);
  110.     if(alh->filename != alh->topfile) /* Track include filename */
  111.       (void)fprintf(list_fd," (\"%s\", line %u)",
  112.             alh->topfile,
  113.             alh->top_line_num);
  114.   }
  115. }
  116.  
  117. PRIVATE void
  118. com_error_locate(clh)    /* Gives module, line, filename for error messages */
  119.      ComListHeader *clh;
  120. {
  121.   if(novice_help) {        /* oldstyle messages */
  122.     (void)fprintf(list_fd," in module %s line %u file %s",
  123.             clh->module->name,
  124.             clh->line_num,
  125.             clh->filename);
  126.     if(clh->filename != clh->topfile) /* Track include filename */
  127.       (void)fprintf(list_fd," (included at line %u in %s)",
  128.             clh->top_line_num,
  129.             clh->topfile);
  130.   }
  131.   else    {            /* lint-style messages */
  132.     (void)fprintf(list_fd," in module %s of \"%s\", line %u",
  133.             clh->module->name,
  134.             clh->filename,
  135.             clh->line_num);
  136.     if(clh->filename != clh->topfile) /* Track include filename */
  137.       (void)fprintf(list_fd," (\"%s\", line %u)",
  138.             clh->topfile,
  139.             clh->top_line_num);
  140.   }
  141. }
  142.  
  143. PRIVATE void
  144. arg_array_cmp(name,args1,args2)
  145.              /* Compares subprogram calls with definition */
  146.     char *name;
  147.     ArgListHeader *args1, *args2;
  148. {
  149.     int i;
  150.     int  n,
  151.          n1 = args1->numargs,
  152.          n2 = args2->numargs;
  153.     ArgListElement *a1 = args1->arg_array,
  154.                *a2 = args2->arg_array;
  155.  
  156.     n = (n1 > n2) ? n2: n1;        /* n = min(n1,n2) */
  157.  
  158.     if (check_args_number && n1 != n2){
  159.       cmp_error_count = 0;
  160.       (void) cmp_error_head(name,"varying number of arguments:");
  161.  
  162.       (void)fprintf(list_fd,"\n    %s with %d argument%s",
  163.             args1->is_defn? "Defined":"Invoked",
  164.                 n1,pluralize(n1));
  165.       arg_error_locate(args1);
  166.  
  167.       (void)fprintf(list_fd,"\n    %s with %d argument%s",
  168.             args2->is_defn? "Defined":"Invoked",
  169.             n2,pluralize(n2));
  170.       arg_error_locate(args2);
  171.     }
  172.  
  173.     if(check_args_type)
  174.     {    /* Look for type mismatches */
  175.         cmp_error_count = 0;
  176.         for (i=0; i<n; i++) {
  177.           int c1 = storage_class_of(a1[i].type),
  178.               c2 = storage_class_of(a2[i].type),
  179.           t1 = datatype_of(a1[i].type),
  180.               t2 = datatype_of(a2[i].type),
  181.           s1 = a1[i].size,
  182.           s2 = a2[i].size,
  183.           defsize1 = (s1==size_DEFAULT),
  184.           defsize2 = (s2==size_DEFAULT);
  185.                 /* cmptype is type to use for mismatch test.
  186.                    Basically cmptype=type but DP matches
  187.                    REAL, DCPX matches CPLX, and hollerith
  188.                    matches any numeric or logical type
  189.                    but not  character.  The single/double
  190.                    match will be deferred to size check. */
  191.           int cmptype1= (t1==type_HOLLERITH && t2!=type_STRING)?
  192.                 t2:type_category[t1];
  193.           int cmptype2= (t2==type_HOLLERITH && t1!=type_STRING)?
  194.                 t1:type_category[t2];
  195.  
  196.         /* If -portability, do not translate default sizes so
  197.            they will never match explicit sizes. */
  198.           if(!(port_check || local_wordsize==0)) {
  199.         if(defsize1)
  200.           s1 = type_size[t1];
  201.         if(defsize2)
  202.           s2 = type_size[t2];
  203.           }
  204.  
  205.           if(s1 < 0 || s2 < 0) { /* char size_ADJUSTABLE or UNKNOWN */
  206.         s1 = s2 = size_DEFAULT;    /* suppress warnings on size */
  207.         defsize1 = defsize2 = TRUE;
  208.           }
  209.  
  210.              /* Require exact match between storage classes and
  211.                 compatible data type.  If that is OK, then for
  212.                 non-char args require exact size match.  For char
  213.                 and hollerith defer size check to other section.
  214.               */
  215.         if( (c1 != c2) || (cmptype1 != cmptype2) || ( (s1 != s2) &&
  216.             is_num_log_type(t1) && is_num_log_type(t2) ) ) {
  217.  
  218.         if(cmp_error_head(name," argument data type mismatch"))
  219.           break;
  220.  
  221.         (void)fprintf(list_fd, "\n  at position %d:", i+1);
  222. #ifdef KEEP_ARG_NAMES
  223.         (void)fprintf(list_fd,"\n    %s arg %s is type %s",
  224.                 args1->is_defn? "Dummy": "Actual",
  225.                 a1[i].name,
  226.                 type_name[t1]);
  227. #else
  228.         (void)fprintf(list_fd,"\n    %s type %s",
  229.                 args1->is_defn? "Dummy": "Actual",
  230.                 type_name[t1]);
  231. #endif
  232.         if(!defsize1)
  233.           (void)fprintf(list_fd,"*%d",s1);
  234.         (void)fprintf(list_fd," %s",
  235.             class_name[storage_class_of(a1[i].type)]);
  236.         arg_error_locate(args1);
  237.  
  238. #ifdef KEEP_ARG_NAMES
  239.         (void)fprintf(list_fd,"\n    %s arg %s is type %s",
  240.                 args2->is_defn? "Dummy": "Actual",
  241.                 a2[i].name,
  242.                 type_name[t2]);
  243. #else
  244.         (void)fprintf(list_fd,"\n    %s type %s",
  245.                 args2->is_defn? "Dummy": "Actual",
  246.                 type_name[t2]);
  247. #endif
  248.         if(!defsize2)
  249.           (void)fprintf(list_fd,"*%d",s2);
  250.         (void)fprintf(list_fd," %s",
  251.             class_name[storage_class_of(a2[i].type)]);
  252.         arg_error_locate(args2);
  253.  
  254.         if(args1->is_defn
  255.             && storage_class_of(a1[i].type) == class_SUBPROGRAM
  256.             && storage_class_of(a2[i].type) != class_SUBPROGRAM
  257.             && datatype_of(a1[i].type) != type_SUBROUTINE
  258.             && ! a1[i].declared_external )
  259.           (void)fprintf(list_fd,
  260.              "\n    (possibly it is an array which was not declared)");
  261.           }
  262.                 /* If no class/type/elementsize clash,
  263.                    and if comparing dummy vs. actual,
  264.                    check character and hollerith sizes */
  265.           else if(args1->is_defn) {
  266.                 /* Character: check size but skip *(*)
  267.                    and dummy array vs. actual array element.
  268.                  */
  269.         if(t1 == type_STRING && s1 > 0 && s2 > 0 &&
  270.           !(a1[i].array_var && a2[i].array_element)) {
  271.             unsigned long
  272.               dims1,dims2,size1,size2;
  273.  
  274.             if(a1[i].array_var) {
  275.               dims1 = array_dims(a1[i].info.array_dim);
  276.               size1 = array_size(a1[i].info.array_dim);
  277.             }
  278.             else {
  279.               dims1 = 0;
  280.               size1 = 1;
  281.             }
  282.             if(a2[i].array_var && !a2[i].array_element) {
  283.               dims2 = array_dims(a2[i].info.array_dim);
  284.               size2 = array_size(a2[i].info.array_dim);
  285.             }
  286.             else {
  287.               dims2 = 0;
  288.               size2 = 1;
  289.             }
  290.  
  291.                 /* standard requires dummy <= actual size.
  292.                      */
  293.           if( (s1*size1 > s2*size2 &&
  294.               (dims1==0 || size1>1) && (dims2==0 || size2>1)) ) {
  295.  
  296.             if(cmp_error_head(name," argument mismatch"))
  297.                 break;
  298.  
  299.             (void)fprintf(list_fd, "\n  at position %d:", i+1);
  300. #ifdef KEEP_ARG_NAMES
  301.             (void)fprintf(list_fd,"\n    Dummy arg %s is type %s*%d",
  302.                 a1[i].name,
  303.                 type_name[t1],s1);
  304. #else
  305.             (void)fprintf(list_fd,"\n    Dummy type %s*%d",
  306.                 type_name[t1],s1);
  307. #endif
  308.             if(dims1 > 0)
  309.               (void)fprintf(list_fd,"(%lu)",size1);
  310.             arg_error_locate(args1);
  311.  
  312. #ifdef KEEP_ARG_NAMES
  313.             (void)fprintf(list_fd,"\n    Actual arg %s is type %s*%d",
  314.                 a2[i].name,
  315.                 type_name[t2],s2);
  316. #else
  317.             (void)fprintf(list_fd,"\n    Actual type %s*%d",
  318.                 type_name[t2],s2);
  319. #endif
  320.             if(dims2 > 0)
  321.               (void)fprintf(list_fd,"(%lu)",size2);
  322.             arg_error_locate(args2);
  323.           }/*end if char size mismatch*/
  324.         }/*end if type==char*/
  325.  
  326.         else if(t2 == type_HOLLERITH) {
  327.             /* Allow hollerith to match any noncharacter type of
  328.                at least equal aggregate size.  */
  329.             unsigned long dims1,size1;
  330.             if(a1[i].array_var) {
  331.               dims1 = array_dims(a1[i].info.array_dim);
  332.               size1 = array_size(a1[i].info.array_dim);
  333.             }
  334.             else {
  335.               dims1 = 0;
  336.               size1 = 1;
  337.             }
  338.             if(s2 > s1*size1 && (dims1==0 || size1>1)) {
  339.  
  340.               if(cmp_error_head(name," argument mismatch"))
  341.                 break;
  342.  
  343.               (void)fprintf(list_fd, "\n  at position %d:", i+1);
  344. #ifdef KEEP_ARG_NAMES
  345.               (void)fprintf(list_fd,"\n    Dummy arg %s is type %s",
  346.                 a1[i].name,
  347.                 type_name[t1]);
  348. #else
  349.               (void)fprintf(list_fd,"\n    Dummy type %s",
  350.                 type_name[t1]);
  351. #endif
  352.               if(!defsize1)
  353.             (void)fprintf(list_fd,"*%d",s1);
  354.               if(dims1 > 0)
  355.             (void)fprintf(list_fd,"(%lu)",size1);
  356.               arg_error_locate(args1);
  357.  
  358. #ifdef KEEP_ARG_NAMES
  359.               (void)fprintf(list_fd,"\n    Actual arg %s is type %s*%d",
  360.                 a2[i].name,
  361.                 type_name[t2],s2);
  362. #else
  363.               (void)fprintf(list_fd,"\n    Actual type %s*%d",
  364.                 type_name[t2],s2);
  365. #endif
  366.               arg_error_locate(args2);
  367.             }/*end if holl size mismatch*/
  368.         }/*end if type==holl*/
  369.           }
  370.         }/*end for i*/
  371.     }/* end look for type && size mismatches */
  372.  
  373.  
  374.          /* Check arrayness of args only if defn exists */
  375.     if(check_args_type && args1->is_defn ) {
  376.         cmp_error_count = 0;
  377.         for (i=0; i<n; i++) {
  378.             /* Skip if class or datatype mismatch.  This
  379.                also skips holleriths which were checked above.
  380.                Do not process externals.
  381.              */
  382.           if(datatype_of(a2[i].type) != type_HOLLERITH &&
  383.          storage_class_of(a1[i].type) == class_VAR &&
  384.          storage_class_of(a2[i].type) == class_VAR) {
  385.  
  386.         if( a1[i].array_var ) {    /* I. Dummy arg is array */
  387.             if( a2[i].array_var ) {
  388.             if( a2[i].array_element ) {
  389.                     /*   A. Actual arg is array elt */
  390.                     /*    Warn on check_array_dims. */
  391.                 if(check_array_dims) {
  392.  
  393.                   if(cmp_error_head(
  394.                       name," argument arrayness mismatch"))
  395.                 break;
  396.  
  397.                   (void)fprintf(list_fd,"\n  at position %d:", i+1);
  398.  
  399. #ifdef KEEP_ARG_NAMES
  400.                   (void)fprintf(list_fd,
  401.                      "\n    Dummy arg %s is whole array",
  402.                      a1[i].name);
  403. #else
  404.                   (void)fprintf(list_fd,"\n    Dummy arg is whole array");
  405. #endif
  406.                   arg_error_locate(args1);
  407.  
  408. #ifdef KEEP_ARG_NAMES
  409.                   (void)fprintf(list_fd,
  410.                     "\n    Actual arg %s is array element",
  411.                     a2[i].name);
  412. #else
  413.                   (void)fprintf(list_fd,"\n    Actual arg is array element");
  414. #endif
  415.                   arg_error_locate(args2);
  416.                 }
  417.             }/* end case I.A. */
  418.  
  419.             else {
  420.                     /*   B. Actual arg is whole array */
  421.                     /*    Warn if dims or sizes differ */
  422.               unsigned long
  423.                 diminfo1,diminfo2,dims1,dims2,size1,size2,
  424.                 cmpsize1,cmpsize2;
  425.               diminfo1 = a1[i].info.array_dim;
  426.               diminfo2 = a2[i].info.array_dim;
  427.               dims1 = array_dims(diminfo1);
  428.               dims2 = array_dims(diminfo2);
  429.               cmpsize1 = size1 = array_size(diminfo1);
  430.               cmpsize2 = size2 = array_size(diminfo2);
  431.                 /* For char arrays relevant size is no. of
  432.                    elements times element size. But use
  433.                    no. of elements if *(*) involved. */
  434.               if(datatype_of(a1[i].type) == type_STRING
  435.                  && a1[i].size > 0 && a2[i].size > 0) {
  436.                 cmpsize1 *= a1[i].size;
  437.                 cmpsize2 *= a2[i].size;
  438.               }
  439.  
  440.             /* size = 0 or 1 means variable-dim: OK to differ */
  441.               if( (check_array_size &&
  442.                   (size1>1 && size2>1 && cmpsize1 != cmpsize2))
  443.                  || (check_array_dims &&
  444.                   (dims1 != dims2)) ) {
  445.  
  446.  
  447.                 if(cmp_error_head(
  448.                     name," argument arrayness mismatch"))
  449.                       break;
  450.  
  451.                 (void)fprintf(list_fd,"\n  at position %d:", i+1);
  452.  
  453. #ifdef KEEP_ARG_NAMES
  454.                 (void)fprintf(list_fd,
  455.                     "\n    Dummy arg %s has %ld dim%s size %ld",
  456.                     a1[i].name,
  457.                     dims1,pluralize(dims1),
  458.                     size1);
  459. #else
  460.                 (void)fprintf(list_fd,
  461.                     "\n    Dummy arg %ld dim%s size %ld",
  462.                     dims1,pluralize(dims1),
  463.                     size1);
  464. #endif
  465.                 if(datatype_of(a1[i].type) == type_STRING &&
  466.                    a1[i].size > 0)
  467.                   (void)fprintf(list_fd,"*%ld",a1[i].size);
  468.                 arg_error_locate(args1);
  469.  
  470. #ifdef KEEP_ARG_NAMES
  471.                 (void)fprintf(list_fd,
  472.                     "\n    Actual arg %s has %ld dim%s size %ld",
  473.                     a2[i].name,
  474.                     dims2,pluralize(dims2),
  475.                     size2);
  476. #else
  477.                 (void)fprintf(list_fd,
  478.                     "\n    Actual arg %ld dim%s size %ld",
  479.                     dims2,pluralize(dims2),
  480.                     size2);
  481. #endif
  482.                 if(datatype_of(a2[i].type) == type_STRING
  483.                    && a2[i].size > 0)
  484.                   (void)fprintf(list_fd,"*%ld",a2[i].size);
  485.                 arg_error_locate(args2);
  486.               }/* end if size mismatch */
  487.             }/* end case I.B. */
  488.             }
  489.             else {
  490.                     /*   C. Actual arg is scalar */
  491.                     /*    Warn in all cases */
  492.  
  493.                   if(cmp_error_head(
  494.                 name," argument arrayness mismatch"))
  495.               break;
  496.  
  497.             (void)fprintf(list_fd,"\n  at position %d:", i+1);
  498.  
  499. #ifdef KEEP_ARG_NAMES
  500.             (void)fprintf(list_fd,"\n    Dummy arg %s is array",
  501.                       a1[i].name);
  502. #else
  503.             (void)fprintf(list_fd,"\n    Dummy arg is array");
  504. #endif
  505.             arg_error_locate(args1);
  506.  
  507. #ifdef KEEP_ARG_NAMES
  508.             (void)fprintf(list_fd,"\n    Actual arg %s is scalar",
  509.                       a2[i].name);
  510. #else
  511.             (void)fprintf(list_fd,"\n    Actual arg is scalar");
  512. #endif
  513.             arg_error_locate(args2);
  514.             }/* end case I.C. */
  515.         } /* end dummy is array, case I. */
  516.  
  517.         else {            /* II. Dummy arg is scalar */
  518.             if( a2[i].array_var ) {
  519.             if( a2[i].array_element ) {
  520.                     /*   A. Actual arg is array elt */
  521.                     /*    OK */
  522.             }
  523.             else {
  524.                     /*   B. Actual arg is whole array */
  525.                     /*    Warn in all cases */
  526.  
  527.               if(cmp_error_head(
  528.                    name," argument arrayness mismatch"))
  529.                 break;
  530.  
  531.               (void)fprintf(list_fd,"\n  at position %d:", i+1);
  532.  
  533. #ifdef KEEP_ARG_NAMES
  534.               (void)fprintf(list_fd,
  535.                   "\n    Dummy arg %s is scalar",
  536.                   a1[i].name);
  537. #else
  538.               (void)fprintf(list_fd,"\n    Dummy arg is scalar");
  539. #endif
  540.               arg_error_locate(args1);
  541.  
  542. #ifdef KEEP_ARG_NAMES
  543.               (void)fprintf(list_fd,
  544.                   "\n    Actual arg %s is whole array",
  545.                    a2[i].name);
  546. #else
  547.               (void)fprintf(list_fd,"\n    Actual arg is whole array");
  548. #endif
  549.               arg_error_locate(args2);
  550.  
  551.             }/* end case II.B. */
  552.             }
  553.             else {
  554.                     /*   C. Actual arg is scalar */
  555.                     /*    OK */
  556.             }
  557.  
  558.         } /* end dummy is scalar, case II */
  559.  
  560.           } /* end if class_VAR */
  561.         }/* end for (i=0; i<n; i++) */
  562.     }/* if( args1->is_defn ) */
  563.  
  564.  
  565.          /* Check usage of args only if defn exists */
  566.     if(check_set_used && args1->is_defn) {
  567.  
  568.         cmp_error_count = 0;
  569.         for (i=0; i<n; i++) {
  570.           if(storage_class_of(a1[i].type) == class_VAR &&
  571.          storage_class_of(a2[i].type) == class_VAR ) {
  572.         int nonlvalue_out = (a1[i].assigned_flag && !a2[i].is_lvalue),
  573.             nonset_in = (a1[i].used_before_set && !a2[i].set_flag);
  574.  
  575. #if DEBUG_PGSYMTAB
  576. if(debug_latest) {
  577. (void)fprintf(list_fd,
  578. "\nUsage check: %s[%d] dummy asgnd %d ubs %d  actual lvalue %d set %d",
  579. args1->module->name,
  580. i+1,
  581. a1[i].assigned_flag,
  582. a1[i].used_before_set,
  583. a2[i].is_lvalue,
  584. a2[i].set_flag);
  585. }
  586. #endif
  587.  
  588.         if(nonlvalue_out || nonset_in) {
  589.  
  590.           if(cmp_error_head(name," argument usage mismatch"))
  591.              break;
  592.  
  593.           (void)fprintf(list_fd,"\n  at position %d:", i+1);
  594.  
  595.           if(nonlvalue_out) {
  596. #ifdef KEEP_ARG_NAMES
  597.             (void)fprintf(list_fd,"\n    Dummy arg %s is modified",
  598.                   a1[i].name);
  599. #else
  600.             (void)fprintf(list_fd,"\n    Dummy arg is modified");
  601. #endif
  602.             arg_error_locate(args1);
  603.  
  604. #ifdef KEEP_ARG_NAMES
  605.             (void)fprintf(list_fd,"\n    Actual arg %s is const or expr",
  606.                   a2[i].name);
  607. #else
  608.             (void)fprintf(list_fd,"\n    Actual arg is const or expr");
  609. #endif
  610.             arg_error_locate(args2);
  611.           }
  612.           else if(nonset_in) {
  613.  
  614. #ifdef KEEP_ARG_NAMES
  615.             (void)fprintf(list_fd,"\n    Dummy arg %s used before set",
  616.                   a1[i].name);
  617. #else
  618.             (void)fprintf(list_fd,"\n    Dummy arg used before set");
  619. #endif
  620.             arg_error_locate(args1);
  621.  
  622. #ifdef KEEP_ARG_NAMES
  623.             (void)fprintf(list_fd,"\n    Actual arg %s not set",
  624.                   a2[i].name);
  625. #else
  626.             (void)fprintf(list_fd,"\n    Actual arg not set");
  627. #endif
  628.             arg_error_locate(args2);
  629.           }
  630.         }
  631.           }
  632.         }
  633.     }/*end if(check_set_used && args->is_defn) */
  634.  
  635. }/* arg_array_cmp */
  636.  
  637.  
  638.  
  639. void
  640. check_arglists()    /* Scans global symbol table for subprograms */
  641. {                       /* and finds subprogram defn if it exists */
  642.     unsigned i;
  643.     ArgListHeader *defn_list, *alist;
  644.  
  645.     for (i=0; i<glob_symtab_top; i++){
  646.  
  647.                 /* Skip common blocks */
  648.         if(storage_class_of(glob_symtab[i].type) != class_SUBPROGRAM)
  649.         continue;
  650.  
  651.                 /* Skip unvisited library modules */
  652.         if(glob_symtab[i].library_module && !glob_symtab[i].visited)
  653.         continue;
  654.  
  655.  
  656.         if((alist=glob_symtab[i].info.arglist) == NULL){
  657.           oops_message(OOPS_NONFATAL,NO_LINE_NUM,NO_COL_NUM,
  658.               "global symbol has no argument lists:");
  659.           oops_tail(glob_symtab[i].name);
  660.         }
  661.         else{    /* alist != NULL */
  662.         int num_defns= 0;
  663.         ArgListHeader *list_item;
  664.  
  665.             /* use 1st invocation instead of defn if no defn */
  666.         defn_list = alist;
  667.  
  668.                 /* Find a definition in the linked list of
  669.                    usages.  Count how many defns found. */
  670.         list_item = alist;
  671.         while(list_item != NULL){
  672.             if(list_item->is_defn){
  673.             if(ext_def_check && num_defns > 0) {/* multiple defn */
  674.                 if(num_defns == 1) {
  675.                   (void)fprintf(list_fd,
  676.                       "\nSubprogram %s multiply defined:\n    ",
  677.                       glob_symtab[i].name);
  678.                   arg_error_locate(defn_list);
  679.                 }
  680.                 (void)fprintf(list_fd,"\n    ");
  681.                 arg_error_locate(list_item);
  682.             }
  683.             ++num_defns;
  684.             defn_list = list_item;    /* Use last defn found */
  685.             }
  686.             else { /* ! list_item->is_defn */
  687.                 /* Here treat use as actual arg like call */
  688.             if(list_item->is_call || list_item->actual_arg){
  689.                  /* Use last call by a visited or nonlibrary
  690.                     module as defn if no defn found */
  691.               if(!defn_list->is_defn
  692.                  && !irrelevant(list_item) )
  693.                 defn_list = list_item;
  694.                 }
  695.             }
  696.  
  697.             list_item = list_item->next;
  698.         }
  699.         if(num_defns == 0){
  700.                 /* If no defn found, and all calls are
  701.                    from unvisited library modules, skip. */
  702.           if(irrelevant(defn_list))
  703.             continue;
  704.                 /* If no definitions found, report error
  705.                    unless -noext is given */
  706.            if(ext_def_check) {
  707.              (void)fprintf(list_fd,
  708.                  "\nSubprogram %s never defined",
  709.                  glob_symtab[i].name);
  710.              if(!glob_symtab[i].used_flag)
  711.                (void)fprintf(list_fd," nor invoked");
  712.  
  713.              (void)fprintf(list_fd, "\n    %s",
  714.                  (defn_list->external_decl)?"declared":"invoked");
  715.              arg_error_locate(defn_list);
  716.  
  717.             /* Warn if it seems it may just be an array they
  718.                forgot to declare */
  719.               if(defn_list->numargs != 0
  720.              && datatype_of(defn_list->type) != type_SUBROUTINE
  721.              && ! glob_symtab[i].declared_external) {
  722.             if(novice_help)
  723.               (void)fprintf(list_fd,
  724.         "\n    (possibly it is an array which was not declared)");
  725.               }
  726.            }
  727.         }
  728.                 /* If definition is found but module is
  729.                    not in call tree, report it unless -lib */
  730.         else{    /* num_defns != 0 */
  731.             if(!glob_symtab[i].visited
  732.                && datatype_of(glob_symtab[i].type) != type_BLOCK_DATA
  733.                && !glob_symtab[i].library_module) {
  734.             (void)fprintf(list_fd,"\nSubprogram %s never invoked",
  735.                 glob_symtab[i].name);
  736.             (void)fprintf(list_fd, "\n    defined");
  737.             arg_error_locate(defn_list);
  738.             }
  739.         }
  740.  
  741.             /* Now check defns/invocations for consistency.  If
  742.                no defn, 1st invocation will serve. Here treat
  743.                use as actual arg like call.  Ignore calls & defns
  744.                in unvisited library modules. */
  745.         if( check_args_type &&
  746.            (defn_list->is_defn || !defn_list->external_decl)) {
  747.           while(alist != NULL){
  748.             int typerrs = 0;
  749.             if(alist != defn_list && !alist->external_decl
  750.                && !irrelevant(alist)) {
  751.               int c1 = storage_class_of(defn_list->type),
  752.                   c2 = storage_class_of(alist->type),
  753.                   t1 = datatype_of(defn_list->type),
  754.                   t2 = datatype_of(alist->type),
  755.                   s1 = defn_list->size,
  756.                   s2 = alist->size,
  757.                   defsize1 = (s1 == size_DEFAULT),
  758.                   defsize2 = (s2 == size_DEFAULT),
  759.                   cmptype1= type_category[t1],
  760.                   cmptype2= type_category[t2];
  761.         /* If -portability, do not translate default sizes so
  762.            they will never match explicit sizes. */
  763.               if(!(port_check || local_wordsize==0)) {
  764.                 if(defsize1)
  765.                   s1 = type_size[t1];
  766.                 if(defsize2)
  767.                   s2 = type_size[t2];
  768.               }
  769.  
  770.               if(s1 < 0 || s2 < 0){ /*size_ADJUSTABLE or UNKNOWN*/
  771.                 s1 = s2 = size_DEFAULT;/* suppress size warnings */
  772.                 defsize1 = defsize2 = TRUE;
  773.               }
  774.                 /* Check class, type, and size */
  775.               if( (c1 != c2) || (cmptype1 != cmptype2) ||
  776.                  ( (s1 != s2) &&
  777.                 /*exclude char size-only mismatch betw calls */
  778.                   (t1 != type_STRING ||
  779.                     defn_list->is_defn || alist->is_defn )) ){
  780.  
  781.                     if(typerrs++ == 0){
  782.                   (void)fprintf(list_fd,
  783.                     "\nSubprogram %s invoked inconsistently:",
  784.                      glob_symtab[i].name);
  785.                   (void)fprintf(list_fd,
  786.                     "\n    %s type %s",
  787.                     defn_list->is_defn? "Defined":"Invoked",
  788.                     type_name[t1]);
  789.                   if(!defsize1)
  790.                     (void)fprintf(list_fd,"*%d",s1);
  791.                   arg_error_locate(defn_list);
  792.                 }
  793.                 (void)fprintf(list_fd,
  794.                     "\n    %s type %s",
  795.                     alist->is_defn? "Defined":"Invoked",
  796.                     type_name[t2]);
  797.                 if(!defsize2)
  798.                   (void)fprintf(list_fd,"*%d",s2);
  799.                 arg_error_locate(alist);
  800.               }
  801.             }
  802.             alist = alist->next;
  803.  
  804.           }/* end while(alist != NULL) */
  805.             }/* end if(defn) */
  806.  
  807.         alist = glob_symtab[i].info.arglist;
  808.         while(alist != NULL){
  809.           /* Here we require true call, not use as actual arg.
  810.              Also, do not compare multiple defns against each
  811.              other. */
  812.             if(alist != defn_list &&
  813.                (defn_list->is_defn || defn_list->is_call) &&
  814.                (alist->is_call && !irrelevant(alist)) ){
  815.                 arg_array_cmp(glob_symtab[i].name,defn_list,alist);
  816.             }
  817.             alist = alist->next;
  818.  
  819.         }/* end while(alist != NULL) */
  820.         }/* end else <alist != NULL> */
  821.     }/* end for (i=0; i<glob_symtab_top; i++) */
  822. }
  823.  
  824.  
  825.  
  826. void
  827. check_comlists()        /* Scans global symbol table for common blocks */
  828. {
  829.     unsigned i, model_n;
  830.     ComListHeader *first_list, *model, *clist;
  831.  
  832.     if(check_com_off)
  833.         return;
  834.  
  835.     for (i=0; i<glob_symtab_top; i++){
  836.  
  837.         if (storage_class_of(glob_symtab[i].type) != class_COMMON_BLOCK)
  838.         continue;
  839.  
  840.         if((first_list=glob_symtab[i].info.comlist) == NULL){
  841.         (void)fprintf(list_fd,"\nCommon block %s never defined",
  842.             glob_symtab[i].name);
  843.         }
  844.         else {
  845.               /* Find instance with most variables to use as model */
  846.         model=first_list;
  847.         model_n = first_list->numargs;
  848.         clist = model;
  849.         while( (clist=clist->next) != NULL ){
  850.             if(clist->numargs >= model_n /* if tie, use earlier */
  851.             /* also if model is from an unvisited library
  852.                module, take another */
  853.                || irrelevant(model) ) {
  854.             model = clist;
  855.             model_n = clist->numargs;
  856.             }
  857.         }
  858.  
  859.         if( irrelevant(model) )
  860.           continue;    /* skip if irrelevant */
  861.  
  862.             /* Check consistent SAVEing of block:
  863.                If SAVEd in one module, must be SAVEd in all.
  864.                Main prog is an exception: SAVE ignored there. */
  865.           {
  866.         ComListHeader *saved_list, *unsaved_list;
  867.         saved_list = unsaved_list = (ComListHeader *)NULL;
  868.         clist = first_list;
  869.         while( clist != NULL ){
  870.  
  871.             if(!irrelevant(clist) && clist->module->type !=
  872.                type_byte(class_SUBPROGRAM,type_PROGRAM) ) {
  873.  
  874.               if(clist->saved)
  875.             saved_list = clist;
  876.               else
  877.             unsaved_list = clist;
  878.             }
  879.             clist = clist->next;
  880.         }
  881.         if(saved_list != (ComListHeader *)NULL &&
  882.            unsaved_list != (ComListHeader *)NULL) {
  883.               (void)fprintf(list_fd,
  884.                 "\nCommon block %s not SAVED consistently",
  885.                 glob_symtab[i].name);
  886.               (void)fprintf(list_fd,
  887.                   "\n    is SAVED");
  888.               com_error_locate(saved_list);
  889.               (void)fprintf(list_fd,
  890.                   "\n    is not SAVED");
  891.               com_error_locate(unsaved_list);
  892.         }
  893.           }
  894.  
  895.  
  896.                 /* Now check agreement of common lists */
  897.         clist = first_list;
  898.         while( clist != NULL ){
  899.             if(clist != model && !irrelevant(clist)) {
  900.  
  901.             if(check_com_byname)
  902.               com_cmp_strict(glob_symtab[i].name,model,clist);
  903.             else
  904.               com_cmp_lax(glob_symtab[i].name,model,clist);
  905.             }
  906.             clist = clist->next;
  907.         }
  908.         }
  909.     }
  910. } /* check_comlists */
  911.  
  912.  
  913.  
  914. PRIVATE void
  915. com_cmp_lax(name,c1,c2)        /* Common-list check at levels 1 & 2 */
  916.      char *name;
  917.      ComListHeader *c1,*c2;
  918. {
  919.     int i1,i2,            /* count of common variables in each block */
  920.     done1,done2,        /* true when end of block reached */
  921.     type1,type2;        /* type of variable presently in scan */
  922.     unsigned long
  923.     len1,len2,        /* length of variable remaining */
  924.         size1,size2,        /* unit size of variable */
  925.     word1,word2,        /* number of "words" scanned */
  926.     words1,words2,        /* number of "words" in block */
  927.         defsize1,defsize2,    /* default size used? */
  928.     jump;            /* number of words to skip next in scan */
  929.     int byte_oriented=FALSE,    /* character vs numeric block */
  930.         type_clash;        /* flag for catching clashes */
  931.     int n1=c1->numargs,n2=c2->numargs; /* variable count for each block */
  932.     int numerrs;
  933.     ComListElement *a1=c1->com_list_array, *a2=c2->com_list_array;
  934.  
  935.                 /* Count words in each list */
  936.     words1=words2=0;
  937.     for(i1=0; i1<n1; i1++) {
  938.       size1 = a1[i1].size;
  939.       if(size1 == size_DEFAULT)
  940.     size1 = type_size[a1[i1].type];
  941.       else
  942.     byte_oriented = TRUE;
  943.       words1 += array_size(a1[i1].dimen_info)*size1;
  944.     }
  945.     for(i2=0; i2<n2; i2++) {
  946.       size2 = a2[i2].size;
  947.       if(size2 == size_DEFAULT)
  948.     size2 = type_size[a2[i2].type];
  949.       else
  950.     byte_oriented = TRUE;
  951.       words2 += array_size(a2[i2].dimen_info)*size2;
  952.     }
  953.     /* If not byte oriented, then sizes are all multiples of
  954.        BpW and can be reported as words according to F77 std. */
  955.     if(!byte_oriented) {
  956.       words1 /= BpW;
  957.       words2 /= BpW;
  958.     }
  959.     if(check_com_lengths && words1 != words2) {
  960.       (void)fprintf(list_fd,
  961.           "\nCommon block %s: varying length:", name);
  962.       (void)fprintf(list_fd,
  963.           "\n    Has %ld %s%s",
  964.         words1,
  965.         byte_oriented? "byte":"word",
  966.         pluralize(words1));
  967.       com_error_locate(c1);
  968.       (void)fprintf(list_fd,
  969.           "\n    Has %ld %s%s",
  970.         words2,
  971.         byte_oriented? "byte":"word",
  972.         pluralize(words2));
  973.       com_error_locate(c2);
  974.     }
  975.  
  976.                 /* Now check type matches */
  977.     done1=done2=FALSE;
  978.     i1=i2=0;
  979.     len1=len2=0;
  980.     word1=word2=1;
  981.     numerrs=0;
  982.     for(;;) {
  983.     if(len1 == 0) {        /* move to next variable in list 1 */
  984.         if(i1 == n1) {
  985.         done1 = TRUE;
  986.         }
  987.         else {
  988.         type1 = a1[i1].type;
  989.         size1 = a1[i1].size;
  990.         defsize1 = (size1 == size_DEFAULT);
  991.         if(defsize1)
  992.           size1 = type_size[type1];
  993.         if(!byte_oriented)
  994.           size1 /= BpW;    /* convert bytes to words */
  995.         len1 = array_size(a1[i1].dimen_info)*size1;
  996.         ++i1;
  997.         }
  998.     }
  999.     if(len2 == 0) {        /* move to next variable in list 2 */
  1000.         if(i2 == n2) {
  1001.         done2 = TRUE;
  1002.         }
  1003.         else {
  1004.         type2 = a2[i2].type;
  1005.         size2 = a2[i2].size;
  1006.         defsize2 = (size2 == size_DEFAULT);
  1007.         if(defsize2)
  1008.           size2 = type_size[type2];
  1009.         if(!byte_oriented)
  1010.           size2 /= BpW;
  1011.         len2 = array_size(a2[i2].dimen_info)*size2;
  1012.         ++i2;
  1013.         }
  1014.     }
  1015.  
  1016.     if(done1 || done2){    /* either list exhausted? */
  1017.         break;        /* then stop checking */
  1018.     }
  1019.  
  1020.         /* Look for type clash.  Allow explicitly sized real to
  1021.            match double of equal size.
  1022.            Allow real to match complex whose parts are of equal size.
  1023.            Within same type category, size diff counts as clash
  1024.            except with char.
  1025.            Also issue warning under -portability or -nowordsize
  1026.            if an explicit size is matched to an implicit size. */
  1027.     type_clash = FALSE;
  1028.     if( (type_category[type1] == type_category[type2]) ) {
  1029.       if( type1 != type_STRING &&
  1030.           (size1 != size2
  1031.            || ((port_check||local_wordsize==0) && defsize1 != defsize2))) {
  1032.         type_clash = TRUE;
  1033.       }
  1034.     }
  1035.     else /* different type categories */ {
  1036.                 /* Equiv_type matches complex to real */
  1037.       if(equiv_type[type1] != equiv_type[type2]) {
  1038.         type_clash = TRUE;
  1039.       }
  1040.       else {
  1041.         if( type_category[type1] == type_COMPLEX ) {
  1042.           type_clash = (size1 != 2*size2);
  1043.         }
  1044.         else {
  1045.                 /* 2nd block has complex */
  1046.           type_clash = (size2 != 2*size1);
  1047.         }
  1048.                   /* Give warning anyway if default size
  1049.                    is matched to explicit. */
  1050.         if( (port_check||local_wordsize==0) && defsize1 != defsize2 )
  1051.           type_clash = TRUE;
  1052.       }
  1053.     }
  1054.  
  1055.     if(type_clash) {
  1056.          if(++numerrs > 3) {
  1057.            (void)fprintf(list_fd,"\netc...");
  1058.            break;        /* stop checking after third mismatch */
  1059.          }
  1060.          if(numerrs == 1)
  1061.            (void)fprintf(list_fd,
  1062.                "\nCommon block %s: data type mismatch",
  1063.                name);
  1064.          (void)fprintf(list_fd,"\n    %s %ld is type %s",
  1065.              byte_oriented?"Byte":"Word",
  1066.              word1,
  1067.              type_name[type1]);
  1068.          if(!defsize1)
  1069.            (void)fprintf(list_fd,"*%lu",
  1070.                size1);
  1071.          com_error_locate(c1);
  1072.  
  1073.          (void)fprintf(list_fd,"\n    %s %ld is type %s",
  1074.              byte_oriented?"Byte":"Word",
  1075.              word2,
  1076.              type_name[type2]);
  1077.          if(!defsize2)
  1078.            (void)fprintf(list_fd,"*%lu",
  1079.                size2);
  1080.          com_error_locate(c2);
  1081.     }
  1082.  
  1083.             /* Advance along list by largest possible
  1084.                step that does not cross a variable boundary.
  1085.                If matching complex to real, only advance
  1086.                the real part.
  1087.              */
  1088.     jump = len1 < len2? len1: len2;    /* min(len1,len2) */
  1089.     len1 -= jump;
  1090.     len2 -= jump;
  1091.     word1 += jump;
  1092.     word2 += jump;
  1093.     }/* end for(;;) */
  1094. }
  1095.  
  1096. PRIVATE void
  1097. com_cmp_strict(name,c1,c2)    /* Common-list check at level 3 */
  1098.     char *name;
  1099.     ComListHeader *c1, *c2;
  1100. {
  1101.     int i,
  1102.         typerr,        /* count of type/size mismatches */
  1103.         dimerr;        /* count of array dim/size mismatches */
  1104.     short n,
  1105.           n1 = c1->numargs,
  1106.           n2 = c2->numargs;
  1107.     ComListElement *a1 = c1->com_list_array,
  1108.                *a2 = c2->com_list_array;
  1109.  
  1110.     n = (n1 > n2) ? n2: n1;
  1111.     if(n1 != n2){
  1112.       (void)fprintf(list_fd,
  1113.           "\nCommon block %s: varying length:", name);
  1114.       (void)fprintf(list_fd,
  1115.           "\n    Has %d variable%s",
  1116.           n1,pluralize(n1));
  1117.       com_error_locate(c1);
  1118.  
  1119.       (void)fprintf(list_fd,
  1120.           "\n    Has %d variable%s",
  1121.           n2,pluralize(n2));
  1122.       com_error_locate(c2);
  1123.         }
  1124. #if DEBUG_PGSYMTAB
  1125. if(debug_latest){
  1126. (void)fprintf(list_fd,"block %s",name);
  1127. (void)fprintf(list_fd,"\n\t1=in module %s line %u file %s (%s)",
  1128.             c1->module->name,
  1129.             c1->line_num,
  1130.             c1->topfile
  1131.                 c1->filename);
  1132. (void)fprintf(list_fd,"\n\t2=in module %s line %u file %s (%s)",
  1133.             c2->module->name,
  1134.             c2->line_num,
  1135.             c2->topfile,
  1136.                 c2->filename);
  1137. }
  1138. #endif
  1139.     typerr = 0;
  1140.     for (i=0; i<n; i++) {
  1141.       int t1 = datatype_of(a1[i].type),
  1142.           t2 = datatype_of(a2[i].type),
  1143.           s1 = a1[i].size,
  1144.           s2 = a2[i].size,
  1145.           defsize1 = (s1==size_DEFAULT),
  1146.           defsize2 = (s2==size_DEFAULT);
  1147.         /* If -portability, do not translate default sizes so
  1148.            they will never match explicit sizes. */
  1149.      if(!(port_check || local_wordsize==0)) {
  1150.        if(defsize1)
  1151.          s1 = type_size[t1];
  1152.        if(defsize2)
  1153.          s2 = type_size[t2];
  1154.      }
  1155.  
  1156.         if( t1 != t2 || s1 != s2 ) {
  1157.                 /* stop after limit: probably a cascade */
  1158.             if(++typerr > CMP_ERR_LIMIT) {
  1159.                 (void)fprintf(list_fd,"\n etc...");
  1160.                 break;
  1161.             }
  1162.  
  1163.                 if(typerr == 1)
  1164.               (void)fprintf(list_fd,
  1165.                   "\nCommon block %s: data type mismatch",
  1166.                   name);
  1167.             (void)fprintf(list_fd, "\n  at position %d:", i+1);
  1168.  
  1169.             (void)fprintf(list_fd,
  1170.                 "\n    Variable %s has type %s",
  1171.                 a1[i].name,
  1172.                 type_name[t1]);
  1173.             if(!defsize1)
  1174.               (void)fprintf(list_fd,"*%d",s1);
  1175.             com_error_locate(c1);
  1176.  
  1177.             (void)fprintf(list_fd,
  1178.                 "\n    Variable %s has type %s",
  1179.                 a2[i].name,
  1180.                  type_name[t2]);
  1181.             if(!defsize2)
  1182.               (void)fprintf(list_fd,"*%d",s2);
  1183.             com_error_locate(c2);
  1184.  
  1185.         }/*end if(type or size mismatch)*/
  1186.     }/*end for(i=0; i<n; i++)*/
  1187.  
  1188.  
  1189.     dimerr = 0;
  1190.     for (i=0; i<n; i++){
  1191.         unsigned long d1, d2, s1, s2;
  1192.  
  1193.         if((d1=array_dims(a1[i].dimen_info)) !=
  1194.             (d2=array_dims(a2[i].dimen_info))){
  1195.  
  1196.                 /* stop after limit: probably a cascade */
  1197.             if(++dimerr > CMP_ERR_LIMIT) {
  1198.                 (void)fprintf(list_fd,"\n etc...");
  1199.                 break;
  1200.             }
  1201.             if(dimerr == 1)
  1202.               (void)fprintf(list_fd,
  1203.                   "\nCommon block %s: array dimen/size mismatch",
  1204.                   name);
  1205.             (void)fprintf(list_fd, "\nat position %d:", i+1);
  1206.  
  1207.             (void)fprintf(list_fd,
  1208.                 "\n    Variable %s has %ld dimension%s",
  1209.                 a1[i].name,
  1210.                 d1,pluralize(d1));
  1211.             com_error_locate(c1);
  1212.  
  1213.             (void)fprintf(list_fd,
  1214.                 "\n    Variable %s has %ld dimension%s",
  1215.                 a2[i].name,
  1216.                 d2,pluralize(d2));
  1217.             com_error_locate(c2);
  1218.         }/*end if(num dims mismatch)*/
  1219.  
  1220.         if((s1=array_size(a1[i].dimen_info)) !=
  1221.             (s2=array_size(a2[i].dimen_info))){
  1222.  
  1223.                 /* stop after limit: probably a cascade */
  1224.             if(++dimerr > CMP_ERR_LIMIT) {
  1225.                 (void)fprintf(list_fd,"\n etc...");
  1226.                 break;
  1227.             }
  1228.             if(dimerr == 1)
  1229.               (void)fprintf(list_fd,
  1230.                   "\nCommon block %s: array dimen/size mismatch",
  1231.                   name);
  1232.             (void)fprintf(list_fd,
  1233.                 "\nat position %d:", i+1);
  1234.  
  1235.             (void)fprintf(list_fd,
  1236.                 "\n    Variable %s has size %ld",
  1237.                 a1[i].name,
  1238.                 s1);
  1239.             com_error_locate(c1);
  1240.  
  1241.             (void)fprintf(list_fd,
  1242.                 "\n    Variable %s has size %ld",
  1243.                 a2[i].name,
  1244.                 s2);
  1245.             com_error_locate(c2);
  1246.  
  1247.         }/*end if(array size mismatch)*/
  1248.     }/*end for(i=0; i<n; i++)*/
  1249.  
  1250. }/*com_cmp_strict*/
  1251.  
  1252.  
  1253. /**  Common block and common variable usage checks.  Implemented
  1254.  **  by John Quinn, Jan-May 1993.  Some modifications made by RKM.
  1255.  **/
  1256.  
  1257. void
  1258. check_com_usage()
  1259. {
  1260. #ifdef DYNAMIC_TABLES        /* tables will be mallocked at runtime */
  1261.     Gsymtab  **gsymlist;
  1262. #else
  1263.     Gsymtab  *gsymlist[GLOBSYMTABSZ];
  1264. #endif
  1265.     int  i,numentries,numblocks;
  1266.     ComListHeader  *cmlist;
  1267.  
  1268. #ifdef DYNAMIC_TABLES
  1269.       if( (gsymlist=(Gsymtab **)calloc(glob_symtab_top,sizeof(Gsymtab *)))
  1270.      == (Gsymtab **)NULL) {
  1271.       oops_message(OOPS_FATAL,NO_LINE_NUM,NO_COL_NUM,
  1272.                "Cannot malloc space for common block list");
  1273.       }
  1274. #endif
  1275.  
  1276.                 /* Print cross-reference list */
  1277.     if(print_xref_list) {
  1278.     for(i=numblocks=0;i<glob_symtab_top;i++){ /* loop thru global table */
  1279.        if (storage_class_of(glob_symtab[i].type) == class_COMMON_BLOCK){
  1280.  
  1281.          cmlist = glob_symtab[i].info.comlist;
  1282.          numentries=0;
  1283.  
  1284. #ifdef DEBUG_COM_USAGE
  1285.          (void)fprintf(list_fd, "\n Common Block %s:\n",glob_symtab[i].name );
  1286. #endif
  1287.  
  1288.          while (cmlist != NULL){ /* loop thru declarations */
  1289.  
  1290.              if(! irrelevant(cmlist)  &&
  1291.             (cmlist->any_used || cmlist->any_set))
  1292.            gsymlist[numentries++] = cmlist->module;
  1293. #ifdef DEBUG_COM_USAGE
  1294.          print_comvar_usage(cmlist);
  1295. #endif
  1296.          cmlist = cmlist->next;
  1297.  
  1298.           }  /* end of while */
  1299.  
  1300.          if (numentries >0){ /* print modules that declare this block*/
  1301.  
  1302.            if(numblocks++ == 0)
  1303.          (void)fprintf(list_fd,
  1304.                "\n        Common block cross-reference list:\n");
  1305.  
  1306.            (void)fprintf(list_fd, "\nCommon Block %s used in:\n" ,
  1307.             glob_symtab[i].name );
  1308.  
  1309.            sort_gsymbols(gsymlist,numentries);
  1310.  
  1311.            print_modules((unsigned)numentries,gsymlist);
  1312.  
  1313.          }  /* end of if */
  1314.  
  1315.  
  1316.        } /* end of if */
  1317.  
  1318.     } /* end of for */
  1319.  
  1320.     if(numblocks > 0)
  1321.       (void)fprintf(list_fd,"\n");
  1322.  
  1323.     }/* end if print_xref_list */
  1324.  
  1325.                 /* Print out usage info */
  1326.     if(usage_check > 0) {
  1327.     for(i=0;i<glob_symtab_top;i++){ /* loop thru global table */
  1328.        if (storage_class_of(glob_symtab[i].type) == class_COMMON_BLOCK){
  1329.  
  1330.            com_block_usage(glob_symtab[i].name,
  1331.                  glob_symtab[i].info.comlist );
  1332.        }
  1333.     }
  1334.     }
  1335. #ifdef DYNAMIC_TABLES
  1336.     (void) cfree(gsymlist);
  1337. #endif
  1338. }
  1339.  
  1340. PRIVATE void
  1341. print_modules(n,list)    /* formatting of module names */
  1342.     unsigned n;
  1343.     Gsymtab *list[];
  1344. {
  1345.     unsigned col=0,len,j;
  1346.  
  1347.         for (j=0;j<n;j++){
  1348.       if(list[j]->internal_entry) {
  1349.          len=strlen(list[j]->link.module->name);
  1350.          col+= len= (len<=10? 10:len) +9;
  1351.          if (col >78){
  1352.             fprintf(list_fd, "\n");
  1353.             col = len;
  1354.          } /* end of if */
  1355.          fprintf(list_fd,"   %10s entry",list[j]->link.module->name);
  1356.          len=strlen(list[j]->name)+1;
  1357.          col+= len;
  1358.          if (col >78){
  1359.             fprintf(list_fd, "\n");
  1360.             col = len;
  1361.          } /* end of if */
  1362.          fprintf(list_fd," %s",list[j]->name);
  1363.        }
  1364.        else {
  1365.          len=strlen(list[j]->name);
  1366.          col+= len= (len<=10? 10:len) +3;
  1367.          if (col >78){
  1368.             (void)fprintf(list_fd, "\n");
  1369.             col = len;
  1370.          } /* end of if */
  1371.  
  1372.          (void)fprintf(list_fd,"   %10s",list[j]->name);
  1373.        }
  1374.  
  1375.  
  1376.      } /* end of for */
  1377. }
  1378.  
  1379.  
  1380.  
  1381. #ifdef DEBUG_COM_USAGE
  1382.  
  1383. print_comvar_usage(comlist)
  1384.  
  1385.     ComListHeader *comlist;
  1386. {
  1387.         int i, count;
  1388.       ComListElement *c;
  1389.  
  1390.       count = comlist->numargs;
  1391.       c = comlist->com_list_array;
  1392.  
  1393. /* prints out caller module and any_used, any_set flags in CLhead */
  1394.  
  1395.     (void)fprintf(list_fd, "\nModule %s  any_used %u any_set %u\n",
  1396.                 comlist->module->name, comlist->any_used, comlist->any_set);
  1397.  
  1398.         if((comlist->any_used || comlist-> any_set||1) ){
  1399.            for (i=0; i<count; i++){
  1400.  
  1401. /* prints out all four flags for each element in array */
  1402.  
  1403.               (void)fprintf(list_fd,
  1404.         "\n Element %d (%s) used %u set %u used bf set %u asgnd %u\n"
  1405.               , i+1
  1406.               , c[i].name
  1407.               , c[i].used
  1408.               , c[i].set
  1409.               , c[i].used_before_set
  1410.               , c[i].assigned);
  1411.        } /* end of for */
  1412.  
  1413.         } /* end of if */
  1414. }
  1415. #endif
  1416.  
  1417.     /* Check used, set status of common block.  First it looks for
  1418.        whether the block is totally unused, and if so prints a warning
  1419.        and returns.  Otherwise, if block is unused by some modules,
  1420.        it says which ones.  Meanwhile, it finds the declaration with
  1421.        the most elements to use as reference.  If common strictness
  1422.        is 3 (variable by variable) then it OR's the usage flags of
  1423.        each block variable among different declarations, saving the
  1424.        result in reference list.  Passes off to com_element_usage
  1425.        to print usage of individual common variables.
  1426.        */
  1427. PRIVATE int any_com_warning;
  1428. #define IDENTIFY_COMBLOCK if(any_com_warning++ == 0) \
  1429.         (void)fprintf(list_fd,"\nCommon block %s:",name)
  1430.  
  1431. PRIVATE void
  1432. com_block_usage(name,cl1)
  1433.      char *name;
  1434.      ComListHeader *cl1;
  1435. {
  1436.      ComListHeader *ref_cl,    /* reference decl: has most elements */
  1437.          *cur_cl;        /* running cursor thru decls  */
  1438.      int j,n,ref_n;
  1439.      int block_any_used, block_any_set;
  1440.      int block_unused_somewhere;
  1441.      ComListElement *ref_list, *c;
  1442.  
  1443.     any_com_warning = 0; /* used to print block name once only */
  1444.  
  1445.         block_any_used = block_any_set = FALSE;
  1446.     block_unused_somewhere = FALSE;
  1447.     ref_n = cl1->numargs;
  1448.         ref_cl= cl1;
  1449.     cur_cl = cl1;
  1450.     while (cur_cl!=NULL){  /* traverses CLheads */
  1451.       if(! irrelevant(cur_cl) ) {
  1452.  
  1453.             if (cur_cl->any_used){  /* stores TRUE if any are TRUE */
  1454.         block_any_used = TRUE;
  1455.             }
  1456.         if (cur_cl->any_set){   /* stores TRUE if any are TRUE */
  1457.         block_any_set = TRUE;
  1458.         }
  1459.         if( ! (cur_cl->any_used || cur_cl->any_set) &&
  1460.         ! cur_cl->module->defined_in_include ) {
  1461.           block_unused_somewhere = TRUE;
  1462.         }
  1463.    /* if any_set and any_used false after this loop block never used */
  1464.  
  1465.         if (cur_cl->numargs > ref_n){ /* find largest array */
  1466.         ref_cl = cur_cl;
  1467.         ref_n = cur_cl->numargs;
  1468.             } /* end of if */
  1469.       }/* end if not irrelevant */
  1470.       cur_cl = cur_cl->next;
  1471.     }
  1472.  
  1473.         if(irrelevant(ref_cl))    /* Block not declared by modules in calltree */
  1474.       return;
  1475.  
  1476.      if(! (block_any_used || block_any_set) ) {    /* Totally unused */
  1477.        if(check_unused) {
  1478.      IDENTIFY_COMBLOCK;
  1479.      (void)fprintf(list_fd," unused");
  1480.        }
  1481.      }
  1482.      else {
  1483.                 /* If block used somewhere but not everywhere,
  1484.                    report it. */
  1485.         if(block_unused_somewhere && check_unused) {
  1486.       IDENTIFY_COMBLOCK;
  1487.       (void)fprintf(list_fd," unused");
  1488.       cur_cl = cl1;
  1489.       while (cur_cl!=NULL){  /* traverses CLheads */
  1490.         if(! irrelevant(cur_cl) ) {
  1491.           if( ! (cur_cl->any_used || cur_cl->any_set) &&
  1492.           ! cur_cl->module->defined_in_include ) {
  1493.         (void)fprintf(list_fd,"\n  ");
  1494.         com_error_locate(cur_cl);
  1495.           }
  1496.         }
  1497.         cur_cl = cur_cl->next;
  1498.       }
  1499.     }/* end if block_unused_somewhere */
  1500.  
  1501.     if(! check_com_byname) {
  1502.                 /* If not variablewise checking, just
  1503.                    give general warnings. */
  1504.       if (!block_any_set){
  1505.         if(check_set_used) {
  1506.           IDENTIFY_COMBLOCK;
  1507.           (void)fprintf (list_fd," No elements are set, but some are used.");
  1508.         }
  1509.       }
  1510.       if (!block_any_used){
  1511.         if(check_set_used) {
  1512.           IDENTIFY_COMBLOCK;
  1513.           (void)fprintf (list_fd," No elements are used, but some are set.");
  1514.         }
  1515.       }
  1516.         }
  1517.     else {    /* strictness == 3 */
  1518.                 /* Now go thru the details for each element */
  1519.       ref_list = ref_cl->com_list_array;
  1520.       ref_cl->any_used = block_any_used;
  1521.       ref_cl->any_set = block_any_set;
  1522.  
  1523. /* traversing elements in arrays and storing OR'd values in largest array*/
  1524.  
  1525.       cur_cl = cl1;
  1526.       while (cur_cl!=NULL){
  1527.         if(! irrelevant(cur_cl) ) {
  1528.           c = cur_cl->com_list_array;
  1529.           n = cur_cl->numargs;
  1530.           for (j=0; j<n; j++){
  1531.         if (c[j].used) {
  1532.           ref_list[j].used = TRUE;
  1533.         }
  1534.         if (c[j].set){
  1535.           ref_list[j].set = TRUE;
  1536.         }
  1537.         if (c[j].used_before_set){
  1538.           ref_list[j].used_before_set = TRUE;
  1539.         }
  1540.         if (c[j].assigned){
  1541.           ref_list[j].assigned = TRUE;
  1542.         }
  1543.           }
  1544.         }
  1545.         cur_cl = cur_cl->next;
  1546.       }
  1547.       com_element_usage(name, ref_cl, ref_list, ref_n);
  1548.     }
  1549.      }
  1550. }
  1551.  
  1552.  
  1553. PRIVATE void
  1554. com_element_usage(name,  r_cl, r_list, r_num)
  1555.  
  1556.     char *name;
  1557.     ComListHeader *r_cl;
  1558.         ComListElement  *r_list;
  1559.     int r_num;
  1560.  
  1561. {
  1562.     int i,col, warnings;
  1563.  
  1564.      if (r_cl->any_used || r_cl->any_set){  /* if false block not used */
  1565.  
  1566.         if(check_set_used) {
  1567.           warnings = 0;
  1568.           for (i=0; i<r_num; i++){ /* Count used-not-set cases */
  1569.         if (r_list[i].used && !r_list[i].set){
  1570.           warnings++;
  1571.         }
  1572.           }
  1573.           if(warnings > 0) {
  1574.         IDENTIFY_COMBLOCK;
  1575.         (void)fprintf (list_fd,
  1576.              "\n  Elements used but never set:");
  1577.         if(warnings == r_num) {
  1578.           (void)fprintf(list_fd," all");
  1579.         }
  1580.         else {
  1581.           for (i=0,col=30; i<r_num; i++){
  1582.             if (r_list[i].used && !r_list[i].set){
  1583.               if( (col += 1+(int)strlen(r_list[i].name)) > 78 ) {
  1584.             (void)fprintf(list_fd,"\n");
  1585.             col = 6;
  1586.               }
  1587.               (void)fprintf(list_fd, " %s",
  1588.                     r_list[i].name);
  1589.             }
  1590.           }
  1591.             }
  1592.           }
  1593.         }
  1594.  
  1595.         if(check_unused) {
  1596.           warnings = 0;
  1597.           for (i=0; i<r_num; i++){ /* Count set-not-used cases */
  1598.         if (r_list[i].set && !r_list[i].used){
  1599.           warnings++;
  1600.         }
  1601.           }
  1602.           if(warnings > 0) {
  1603.         IDENTIFY_COMBLOCK;
  1604.         (void)fprintf (list_fd,
  1605.              "\n  Elements set but never used:");
  1606.         if(warnings == r_num) {
  1607.           (void)fprintf(list_fd," all");
  1608.         }
  1609.         else {
  1610.           for (i=0,col=30; i<r_num; i++){
  1611.             if (r_list[i].set && !r_list[i].used){
  1612.               if( (col += 1+(int)strlen(r_list[i].name)) > 78 ) {
  1613.             (void)fprintf(list_fd,"\n");
  1614.             col = 6;
  1615.               }
  1616.               (void)fprintf (list_fd, " %s",
  1617.                      r_list[i].name);
  1618.             }
  1619.               }
  1620.             }
  1621.           }
  1622.         }
  1623.  
  1624.         warnings = 0;
  1625.         for (i=0,col=30; i<r_num; i++){
  1626.           if(!r_list[i].set && !r_list[i].used &&
  1627.          !r_list[i].used_before_set){
  1628.             if(check_unused) {
  1629.               IDENTIFY_COMBLOCK;
  1630.               if (warnings++ == 0 ){
  1631.             (void)fprintf (list_fd,
  1632.                  "\n  Elements never used, never set:");
  1633.               }
  1634.               if( (col += 1+(int)strlen(r_list[i].name)) > 78 ) {
  1635.             (void)fprintf(list_fd,"\n");
  1636.             col = 6;
  1637.               }
  1638.               (void)fprintf (list_fd, " %s",
  1639.                      r_list[i].name);
  1640.             }
  1641.         }
  1642.         }
  1643.     }
  1644.     else{    /* This cannot be reached if called only when block is used */
  1645.       if(check_unused) {
  1646.         IDENTIFY_COMBLOCK;
  1647.         (void)fprintf (list_fd," not used.");
  1648.       }
  1649.     }            /* any_used and any_set are both false */
  1650.  
  1651.  
  1652.  
  1653. }
  1654. /** End of common block and variable usage checks **/
  1655.  
  1656.                 /* Things used for common undef check */
  1657. PRIVATE int com_tree_error;
  1658. PRIVATE int block_is_volatile();
  1659. PRIVATE ComListHeader *com_tree_check(), *com_declared_by();
  1660. PRIVATE int numvisited;
  1661.  
  1662. void
  1663. visit_children()
  1664. {
  1665.   int i,
  1666.     num_mains,        /* number of main programs */
  1667.     num_roots;        /* number of uncalled nonlibrary modules */
  1668.   Gsymtab* main_module;
  1669.  
  1670.   num_roots =  0;
  1671.   for(i=0; i<glob_symtab_top; i++) {
  1672.     if(storage_class_of(glob_symtab[i].type) == class_SUBPROGRAM
  1673.        && ! glob_symtab[i].internal_entry) {
  1674.       sort_child_list(glob_symtab[i].link.child_list);
  1675.      /* Count defined but uncalled non-library modules for use later */
  1676.       if(glob_symtab[i].defined && !glob_symtab[i].used_flag &&
  1677.      !glob_symtab[i].library_module)
  1678.       ++num_roots;    /* Count tree roots for use if no mains */
  1679.     }
  1680.   }
  1681.  
  1682.   if(print_ref_list)
  1683.     (void)fprintf(list_fd,"\nList of subprogram references:");
  1684. #ifdef VCG_SUPPORT
  1685.   else if(print_vcg_list)
  1686.     (void)fprintf(list_fd,"\nVCG description of call graph:");
  1687. #endif
  1688.   else if(print_call_tree)
  1689.     (void)fprintf(list_fd,"\nTree of subprogram calls:");
  1690.  
  1691.                 /* Visit children of all main progs */
  1692.   for(i=0,num_mains=0; i<glob_symtab_top; i++) {
  1693.     if(glob_symtab[i].type == type_byte(class_SUBPROGRAM,type_PROGRAM)) {
  1694.       main_module = &glob_symtab[i];
  1695.       if(print_ref_list)
  1696.     visit_child_reflist(main_module);
  1697. #ifdef VCG_SUPPORT
  1698.       else if(print_vcg_list)
  1699.     visit_child_vcg(main_module,1);
  1700. #endif
  1701.       else
  1702.     visit_child(main_module,0);
  1703.       ++num_mains;
  1704.     }
  1705.   }
  1706.                 /* If no main program found, give
  1707.                    warning unless -noextern was set */
  1708.   if(num_mains == 0) {
  1709.     if(print_call_tree || print_ref_list
  1710. #ifdef VCG_SUPPORT
  1711.        || print_vcg_list
  1712. #endif
  1713.        ) {
  1714.       (void)fprintf(list_fd,"\n  (no main program found)");
  1715.     }
  1716.     else if(ext_def_check) {
  1717.       (void)fprintf(list_fd,
  1718.     "\nNo main program found");
  1719.     }
  1720.         /* If no main, visit trees rooted at uncalled
  1721.            nonlibrary routines, as the next best thing.
  1722.            If there are no uncalled nonlib modules, use
  1723.            uncalled library routines.  If there are no uncalled
  1724.            routines, then there is a cycle!
  1725.          */
  1726.     for(i=0; i<glob_symtab_top; i++) {
  1727.       if(storage_class_of(glob_symtab[i].type) == class_SUBPROGRAM
  1728.     && glob_symtab[i].defined && !glob_symtab[i].used_flag &&
  1729.      (num_roots == 0 || !glob_symtab[i].library_module) ) {
  1730.     if(print_ref_list)
  1731.       visit_child_reflist(&glob_symtab[i]);
  1732. #ifdef VCG_SUPPORT
  1733.     else if(print_vcg_list)
  1734.       visit_child_vcg(main_module,1);
  1735. #endif
  1736.     else
  1737.       visit_child(&glob_symtab[i],1); /* indent all trees one level */
  1738.       }
  1739.     }
  1740.   }
  1741.   if(print_call_tree || print_ref_list)
  1742.     (void)fprintf(list_fd,"\n");
  1743. #ifdef VCG_SUPPORT
  1744.   if(print_vcg_list)
  1745.     (void)fprintf(list_fd,"\nEnd of VCG description\n");
  1746. #endif
  1747.  
  1748.  
  1749.             /* Print list of callers of all visited
  1750.                or non-library modules, if -crossref
  1751.                flag given. */
  1752.   if(print_xref_list) {
  1753.     print_crossrefs();
  1754.   }
  1755.  
  1756.             /* Print linkage-order list of modules. */
  1757.   if( print_topo_sort ) {
  1758.     (void) toposort(glob_symtab,(int)glob_symtab_top);
  1759.   }
  1760.  
  1761.             /* Check that common blocks retain definition
  1762.                status between uses. */
  1763.   if(check_com_tree || check_volatile_com){
  1764.     if(num_mains != 1) {
  1765.       if(check_com_tree)
  1766.     (void)fprintf(list_fd,
  1767.         "\nCommon definition check requires single main program");
  1768.       if(check_volatile_com)
  1769.     (void)fprintf(list_fd,
  1770.         "\nCommon volatility check requires single main program");
  1771.     }
  1772.     else {
  1773.       numvisited = 0;        /* need headcount in case of cycle */
  1774.       for(i=0; i<glob_symtab_top; i++) {
  1775.     if(glob_symtab[i].visited_somewhere)
  1776.       numvisited++;
  1777.       }
  1778.       for(i=0; i<glob_symtab_top; i++) {
  1779.     if(storage_class_of(glob_symtab[i].type) == class_COMMON_BLOCK) {
  1780.       if( block_is_volatile(glob_symtab[i].info.comlist,main_module) ) {
  1781.         if(check_volatile_com) {
  1782.           (void)fprintf(list_fd,
  1783.            "\nCommon block %s is volatile",
  1784.            glob_symtab[i].name);
  1785.         }
  1786.         if(check_com_tree) {
  1787.           com_tree_error=0;
  1788.           (void)com_tree_check(&glob_symtab[i],main_module,0);
  1789.         }
  1790.       }
  1791.     }
  1792.       }
  1793.     }
  1794.   }
  1795. }
  1796.  
  1797.     /* Returns TRUE unless block is SAVED by any module, or declared by
  1798.        the actual main program or in a BLOCK DATA subprogram. */
  1799. PRIVATE int
  1800. block_is_volatile(clist,main_module)
  1801.      ComListHeader *clist;
  1802.      Gsymtab *main_module;
  1803. {
  1804.   int t;
  1805.   while(clist != NULL) {
  1806.     if( clist->saved ||
  1807.        (t=datatype_of(clist->module->type)) == type_BLOCK_DATA
  1808.        || (t == type_PROGRAM && clist->module == main_module)) {
  1809.       return FALSE;
  1810.     }
  1811.     clist = clist->next;
  1812.   }
  1813.   return TRUE;
  1814. }
  1815.  
  1816.  /* If block declared by module, returns pointer to the comlist
  1817.     header which describes it.  Otherwise returns NULL. */
  1818. PRIVATE ComListHeader *
  1819. com_declared_by(comblock,module)
  1820.      Gsymtab *comblock,*module;
  1821. {
  1822.   ComListHeader *clist=comblock->info.comlist;
  1823.   while(clist != NULL) {
  1824.     if(clist->module == module) {
  1825.       if(clist->saved) {
  1826.     com_tree_error = TRUE;    /* not so, but causes bailout */
  1827.       }
  1828.       return clist;
  1829.     }
  1830.     clist = clist->next;
  1831.   }
  1832.   return NULL;
  1833. }
  1834.  
  1835.  
  1836.         /* Checks whether common block can become undefined
  1837.            between activations of some module that declares it.
  1838.            Should only be done for blocks that are volatile, i.e.
  1839.            that are not SAVED or declared in main or block_data.
  1840.            Rules used are:
  1841.              (1) Block is declared in two subtrees whose roots
  1842.                  are called by a given module, and not in
  1843.              the given module itself or above.
  1844.              (2) Block is declared and elements accessed in a module
  1845.                  called by a given module, and not declared in the
  1846.              module itself or above.  (Module that declares it but
  1847.              does not access elements, can be holding the
  1848.              block active for its children.)
  1849.            Since Rule 2 is likely to be wrong often due to Ftnchek's
  1850.            lack of knowledge about whether a routine is invoked
  1851.            more than once, it is suppressed for now.
  1852.         */
  1853. PRIVATE ComListHeader *
  1854. com_tree_check(comblock,module,level)
  1855.      Gsymtab *comblock,*module;
  1856.      int level;
  1857. {
  1858.   ComListHeader *clist;
  1859.  
  1860.     /* The following only protects against recursion.  It is not
  1861.        a full-fledged cycle detector just a stopper. */
  1862.   if(level > numvisited) {
  1863.     (void)fprintf(list_fd,
  1864.         "\nWarning: Call tree has a cycle containing module %s\n",
  1865.         module->name);
  1866.     com_tree_error = TRUE;
  1867.     return NULL;
  1868.   }
  1869.  
  1870.         /* If this module declares the block, return its clist */
  1871.   if( (clist=com_declared_by(comblock,module)) != NULL) {
  1872. #ifdef DEBUG_SAVE
  1873.       (void)fprintf(list_fd,"\n%s declared by %s",comblock->name,module->name);
  1874. #endif
  1875.     return clist;
  1876.   }
  1877.   else {    /* Otherwise see if it is declared in subtree */
  1878.     int any_child_declares_it;
  1879.     ComListHeader *declaring_clist, *this_clist;
  1880.     ChildList *child_list;
  1881.  
  1882.     any_child_declares_it=FALSE;
  1883.     declaring_clist=NULL;
  1884.                 /* Scan list of children */
  1885.     child_list = (module->internal_entry?module->link.module:module)
  1886.            ->link.child_list;
  1887.     while(child_list != NULL) {
  1888.       this_clist = com_tree_check(comblock,child_list->child,level+1);
  1889.                 /* Error was detected below: bail out */
  1890.       if(com_tree_error) {
  1891.     return NULL;
  1892.       }
  1893.       else if(this_clist != NULL) {
  1894.                 /* Subtree contains the block */
  1895.     if(any_child_declares_it               /* Rule 1 */
  1896. #ifdef COMTREE_RULE_2
  1897.        || (this_clist->any_used || this_clist->any_set) /* Rule 2 */
  1898. #endif
  1899.     ){
  1900.       (void)fprintf(list_fd,
  1901.     "\nWarning: Common block %s may become undefined between activations",
  1902.         comblock->name);
  1903.       (void)fprintf(list_fd,"\n    ");
  1904.       com_error_locate(this_clist);
  1905.       if(declaring_clist != NULL && declaring_clist != this_clist) {
  1906.         (void)fprintf(list_fd,"\n    ");
  1907.         com_error_locate(declaring_clist);
  1908.       }
  1909.       (void)fprintf(list_fd,"\n        ");
  1910.       (void)fprintf(list_fd,
  1911.           "during activation of module %s",
  1912.           module->name);
  1913.       com_tree_error = TRUE;
  1914.       return NULL;
  1915.     }
  1916.     else {
  1917.       any_child_declares_it = TRUE;
  1918.       declaring_clist = this_clist;
  1919.     }
  1920.       }
  1921.  
  1922.       child_list = child_list->next;
  1923.     }
  1924.         /* If any subtree declares it, say so */
  1925.     return declaring_clist;
  1926.   }
  1927. }
  1928.  
  1929.  
  1930.  
  1931.                 /* Depth-first search of call tree */
  1932. PRIVATE void
  1933. visit_child(gsymt,level)
  1934.      Gsymtab *gsymt;
  1935.      int level;
  1936. {
  1937.   static char fmt[]="%000s";    /* Variable format for indenting names */
  1938.   ChildList *child_list;
  1939.  
  1940.  
  1941.   if(print_call_tree) {
  1942.     (void)fprintf(list_fd,"\n");
  1943.     if(level > 0) {
  1944.       (void)sprintf(fmt,"%%%ds",level*4); /* indent 4 spaces per nesting level */
  1945.       (void)fprintf(list_fd,fmt,"");
  1946.     }
  1947.     if(gsymt->internal_entry)
  1948.       (void)fprintf(list_fd,"%s entry ",gsymt->link.module->name);
  1949.     (void)fprintf(list_fd,"%s",gsymt->name);
  1950.   }
  1951.  
  1952.  
  1953.  
  1954.                 /* Visit its unvisited children.  Note
  1955.                    that children of internal entry are
  1956.                    taken as those of its superior module.
  1957.                  */
  1958.   child_list = (gsymt->internal_entry?gsymt->link.module:gsymt)
  1959.            ->link.child_list;
  1960.  
  1961.                 /* If already visited, do not visit its
  1962.                    children, but give note to reader if it
  1963.                    has some. */
  1964.   if(gsymt->visited) {
  1965.     if(print_call_tree && child_list != NULL)
  1966.       (void)fprintf(list_fd," (see above)");
  1967.   }
  1968.   else {
  1969.                 /* Mark node as visited */
  1970.     gsymt->visited = TRUE;
  1971.                 /* Record that containing module
  1972.                    is visited via this entry point*/
  1973.     if(gsymt->internal_entry)
  1974.       gsymt->link.module->visited_somewhere = TRUE;
  1975.     else
  1976.       gsymt->visited_somewhere = TRUE;
  1977.  
  1978.     ++level;            /* move to next level */
  1979.     while(child_list != NULL) {
  1980.       visit_child(child_list->child,level);
  1981.       child_list = child_list->next;
  1982.     }
  1983.   }
  1984. }
  1985.  
  1986. /*** visit_child_reflist
  1987.  
  1988. Same as visit_child, except it does a breadth-first search of the call
  1989. tree, and prints the results in the form of a who-calls-who list.
  1990.  
  1991. Contributed by: Gerome Emmanuel : Esial Troisieme annee
  1992.         Projet commun Esial / Ecole des mines
  1993.         INERIS
  1994.         E-mail: gerome@mines.u-nancy.fr
  1995. Date received: 20-APR-1993
  1996. Modified slightly to make it compatible as alternative to call-tree and
  1997. to make output format consistent.
  1998. ***/
  1999.  
  2000. PRIVATE void
  2001. visit_child_reflist(gsymt)
  2002.      Gsymtab *gsymt;
  2003. {
  2004.   ChildList *child_list;
  2005.  
  2006.   child_list = (gsymt->internal_entry?gsymt->link.module:gsymt)
  2007.                    ->link.child_list;
  2008.  
  2009.                                 /* If already visited, do not visit its
  2010.                                    children, but give note to reader if it
  2011.                                    has some. */
  2012.   if(!gsymt->visited) {
  2013.                                 /* Mark node as visited */
  2014.     gsymt->visited = TRUE;
  2015.                                 /* Record that containing module
  2016.                                    is visited via this entry point*/
  2017.     if(gsymt->internal_entry)
  2018.       gsymt->link.module->visited_somewhere = TRUE;
  2019.     else
  2020.       gsymt->visited_somewhere = TRUE;
  2021.  
  2022.     if(print_ref_list)        /* Print callees neatly if desired */
  2023.     {
  2024. #ifdef DYNAMIC_TABLES        /* tables will be mallocked at runtime */
  2025.       Gsymtab  **gsymlist;
  2026. #else
  2027.       Gsymtab  *gsymlist[GLOBSYMTABSZ];
  2028. #endif
  2029.       ChildList *child_list2;
  2030.       unsigned numcalls;
  2031.  
  2032. #ifdef DYNAMIC_TABLES
  2033.       if( (gsymlist=(Gsymtab **)calloc(glob_symtab_top,sizeof(Gsymtab *)))
  2034.      == (Gsymtab **)NULL) {
  2035.       oops_message(OOPS_FATAL,NO_LINE_NUM,NO_COL_NUM,
  2036.                "Cannot malloc space for reference list");
  2037.       }
  2038. #endif
  2039.  
  2040.       (void)fprintf(list_fd,"\n%s calls:",gsymt->name);
  2041.  
  2042.       numcalls = 0;
  2043.       child_list2 = child_list;
  2044.       while(child_list2 != NULL)
  2045.       {
  2046.         gsymlist[numcalls++] = child_list2->child;
  2047.         child_list2 = child_list2->next;
  2048.       }
  2049.  
  2050.       if(numcalls == (unsigned)0)
  2051.         (void)fprintf(list_fd," none");
  2052.       else {
  2053.         (void)fprintf(list_fd,"\n");
  2054.         print_modules(numcalls,gsymlist);
  2055.       }
  2056. #ifdef DYNAMIC_TABLES
  2057.       (void) cfree(gsymlist);
  2058. #endif
  2059.     }
  2060.  
  2061.     while(child_list != NULL) {
  2062.       visit_child_reflist(child_list->child);
  2063.       child_list = child_list->next;
  2064.     }
  2065.   }
  2066. }
  2067.  
  2068. /* visit_child_vcg:
  2069.   
  2070.   Same as visit_child_reflist except it provides output suitable for
  2071.   visualisation of the call graph, using the vcg graph visualisation
  2072.   program.  VCG is freely available from ftp.cs.uni-sb.de and
  2073.   elsewhere. It was written by G. Sander of the University of
  2074.   Saarland, Germany.
  2075.  
  2076.   Contributed by:  P.A.Rubini@cranfield.ac.uk
  2077.   Date: 3-APR-1995
  2078. */
  2079.  
  2080. #ifdef VCG_SUPPORT
  2081. PRIVATE void
  2082. visit_child_vcg(gsymt,level)
  2083.      Gsymtab *gsymt;
  2084.      int level;
  2085. {
  2086.   ArgListHeader *arglist;
  2087.   ChildList *child_list;
  2088.  
  2089.   child_list = (gsymt->internal_entry?gsymt->link.module:gsymt)
  2090.                    ->link.child_list;
  2091.  
  2092.                                 /* If already visited, do not visit its
  2093.                                    children, but give note to reader if it
  2094.                                    has some. */
  2095.   if(!gsymt->visited) {
  2096.                                 /* Mark node as visited */
  2097.     gsymt->visited = TRUE;
  2098.                                 /* Record that containing module
  2099.                                    is visited via this entry point*/
  2100.     if(gsymt->internal_entry)
  2101.       gsymt->link.module->visited_somewhere = TRUE;
  2102.     else
  2103.       gsymt->visited_somewhere = TRUE;
  2104.  
  2105.     if(print_vcg_list)        /* Print callees neatly if desired */
  2106.     {
  2107. #ifdef DYNAMIC_TABLES        /* tables will be mallocked at runtime */
  2108.       Gsymtab  **gsymlist;
  2109. #else
  2110.       Gsymtab  *gsymlist[GLOBSYMTABSZ];
  2111. #endif
  2112.       ChildList *child_list2;
  2113.       int j;
  2114.       unsigned numcalls;
  2115.  
  2116. #ifdef DYNAMIC_TABLES
  2117.       if( (gsymlist=(Gsymtab **)calloc(glob_symtab_top,sizeof(Gsymtab *)))
  2118.      == (Gsymtab **)NULL) {
  2119.       oops_message(OOPS_FATAL,NO_LINE_NUM,NO_COL_NUM,
  2120.                "Cannot malloc space for reference list");
  2121.       }
  2122. #endif
  2123.  
  2124.     numcalls = 0;
  2125.     child_list2 = child_list;
  2126.     while(child_list2 != NULL)
  2127.       {
  2128.         gsymlist[numcalls++] = child_list2->child;
  2129.         child_list2 = child_list2->next;
  2130.       }
  2131.  
  2132.     arglist = gsymt->info.arglist;
  2133.     while(arglist != NULL) {
  2134.       if ( arglist->is_defn ) {
  2135.  
  2136.          (void)fprintf(list_fd,"\n\ngraph: {\ntitle:\"[%s]\"\n",gsymt->name);
  2137.          (void)fprintf(list_fd,"node: { title: \"%s\" label: \"%s \\n (%s)\" info1:\"%d\" }\n",
  2138.                     gsymt->name,gsymt->name,
  2139.                     arglist->filename,
  2140.                     level );
  2141.  
  2142.  
  2143.       if(numcalls != (unsigned)0) {
  2144.         for (j=0;j<numcalls;j++){
  2145.            arglist = gsymlist[j]->info.arglist;
  2146.            while(arglist != NULL) {
  2147.              if ( arglist->is_defn ) {
  2148.             (void)fprintf(list_fd,"edge: { sourcename: \"%s\" targetname: \"%s\" class:%d} \n",
  2149.                 gsymt->name,gsymlist[j]->name,
  2150.                             level );
  2151.             break ;
  2152.              }
  2153.                      arglist = arglist->next;
  2154.            }
  2155.         }
  2156.       }
  2157.           break;
  2158.       }
  2159.       arglist = arglist->next;
  2160.     }
  2161. #ifdef DYNAMIC_TABLES
  2162.       (void) cfree(gsymlist);
  2163. #endif
  2164.  
  2165.     ++level;            /* move to next level */
  2166.  
  2167. /*  while(child_list != NULL) {
  2168.       visit_child_vcg(child_list->child,level);
  2169.       child_list = child_list->next;
  2170.     } */
  2171.  
  2172.     for (j=0;j<numcalls;j++){
  2173.        arglist = gsymlist[j]->info.arglist;
  2174.        while(arglist != NULL) {
  2175.           if ( arglist->is_defn ) {
  2176.              visit_child_vcg(gsymlist[j],level);
  2177.              break ;
  2178.           }
  2179.           arglist = arglist->next;
  2180.        }
  2181.     }
  2182.     (void)fprintf(list_fd,"}\n");
  2183.     }
  2184.   }
  2185. }
  2186.  
  2187. #endif /* VCG_SUPPORT */
  2188.  
  2189.  
  2190. PRIVATE void
  2191. print_crossrefs()
  2192. {
  2193. #ifdef DYNAMIC_TABLES        /* tables will be mallocked at runtime */
  2194.       Gsymtab  **gsymlist, **modulelist;
  2195. #else
  2196.   Gsymtab  *gsymlist[GLOBSYMTABSZ], *modulelist[GLOBSYMTABSZ];
  2197. #endif
  2198.   ArgListHeader *args;
  2199.   int  i,numentries;
  2200.   unsigned numcalls;
  2201.  
  2202. #ifdef DYNAMIC_TABLES
  2203.       if( (gsymlist=(Gsymtab **)calloc(glob_symtab_top,sizeof(Gsymtab *)))
  2204.      == (Gsymtab **)NULL ||
  2205.      (modulelist=(Gsymtab **)calloc(glob_symtab_top,sizeof(Gsymtab *)))
  2206.      == (Gsymtab **)NULL) {
  2207.       oops_message(OOPS_FATAL,NO_LINE_NUM,NO_COL_NUM,
  2208.                "Cannot malloc space for crossref list");
  2209.       }
  2210. #endif
  2211.  
  2212.                 /* Gather up all relevant subprograms */
  2213.   for(i=0,numentries=0; i<glob_symtab_top; i++) {
  2214.     if(storage_class_of(glob_symtab[i].type) == class_SUBPROGRAM
  2215.        && (glob_symtab[i].visited || !glob_symtab[i].library_module)) {
  2216.       gsymlist[numentries++] = &glob_symtab[i];
  2217.     }
  2218.   }
  2219.  
  2220.   if(numentries > 0) {
  2221.     (void)fprintf(list_fd,"\n\n        Cross-reference list:\n");
  2222.  
  2223.                 /* Sort the subprograms */
  2224.     sort_gsymbols(gsymlist,numentries);
  2225.  
  2226.                 /* Print their callers */
  2227.     for(i=0; i<numentries; i++) {
  2228.       (void)fprintf(list_fd,"\n");
  2229.       if(gsymlist[i]->internal_entry)
  2230.     (void)fprintf(list_fd,"%s entry ",gsymlist[i]->link.module->name);
  2231.       (void)fprintf(list_fd,"%s",gsymlist[i]->name);
  2232.  
  2233.       numcalls=0;
  2234.       args = gsymlist[i]->info.arglist;
  2235.       while(args != NULL) {        /* Gather up callers */
  2236.     if(!args->is_defn) {
  2237.                 /* (eliminate duplicates) */
  2238.       if(numcalls==(unsigned) 0 || args->module != modulelist[numcalls-1])
  2239.         modulelist[numcalls++] = args->module;
  2240.     }
  2241.     args = args->next;
  2242.       }
  2243.  
  2244.       if(numcalls == (unsigned) 0)
  2245.     (void)fprintf(list_fd," not called");
  2246.       else {
  2247.     (void)fprintf(list_fd," called by:\n");
  2248.     sort_gsymbols(modulelist,(int)numcalls); /* Sort the callers */
  2249.     print_modules(numcalls,modulelist);
  2250.       }
  2251.     }
  2252.     (void)fprintf(list_fd,"\n");
  2253.   }
  2254. #ifdef DYNAMIC_TABLES
  2255.       (void) cfree(gsymlist);
  2256.       (void) cfree(modulelist);
  2257. #endif
  2258. }
  2259.  
  2260.  
  2261.     /* Topological sort of the call tree.  Based closely on algorithm
  2262.        on page 314 of Horowitz and Sahni, Fundamentals of Data
  2263.        Structures.  Returns TRUE if successful, FALSE if failed
  2264.        due to a cycle being detected.
  2265.      */
  2266. PRIVATE void print_cycle_nodes(); /* Routine for error diagnostics */
  2267.  
  2268. PRIVATE int
  2269. toposort(gsymt,nsym)
  2270.      Gsymtab gsymt[];
  2271.      int nsym;
  2272. {
  2273.   int i,num_nodes, node_count;
  2274.   ChildList *child_list;
  2275.   Gsymtab *child_module;    /* Called module's top entry point */
  2276. #ifdef DYNAMIC_TABLES        /* tables will be mallocked at runtime */
  2277.   int *parent_count;
  2278.   Gsymtab **node_list;
  2279. #else
  2280.   int parent_count[GLOBSYMTABSZ];
  2281.   Gsymtab *node_list[GLOBSYMTABSZ];
  2282. #endif
  2283.  
  2284. #ifdef DYNAMIC_TABLES
  2285.       if( (parent_count=(int *)calloc(glob_symtab_top,sizeof(int)))
  2286.      == (int *)NULL ||
  2287.      (node_list=(Gsymtab **)calloc(glob_symtab_top,sizeof(Gsymtab *)))
  2288.      == (Gsymtab **)NULL) {
  2289.       oops_message(OOPS_FATAL,NO_LINE_NUM,NO_COL_NUM,
  2290.                "Cannot malloc space for module sort");
  2291.       }
  2292. #endif
  2293.             /* Initialize array of links/counts */
  2294.   for(i=0; i<nsym; i++)
  2295.     parent_count[i] = 0;    /* In-order of module as node */
  2296.  
  2297.             /* Traverse child lists, incrementing their
  2298.                parent counts.
  2299.              */
  2300.   for(i=0,num_nodes=0; i<nsym; i++) {
  2301.     if(gsymt[i].visited_somewhere) { /* skip entry pts and com blocks */
  2302.       ++num_nodes;
  2303.       child_list = gsymt[i].link.child_list;
  2304.       while(child_list != NULL) {
  2305.                 /* If child is an internal entry, substitute
  2306.                    top entry point of its subprogram unit. */
  2307.     if( (child_module=child_list->child)->internal_entry )
  2308.       child_module = child_module->link.module;
  2309.     ++parent_count[child_module - gsymt]; /* index into table */
  2310.     child_list = child_list->next;
  2311.       }
  2312.     }
  2313.   }
  2314.  
  2315.   {                /* Start of the sort */
  2316.     int top=0;
  2317.     int j,k;
  2318.  
  2319.     for(i=0; i<nsym; i++) {
  2320.       if(gsymt[i].visited_somewhere && parent_count[i] == 0) {
  2321.     parent_count[i] = top;    /* Link now-parentless module into stack */
  2322.     top = i+1;
  2323.       }
  2324.     }
  2325.     for(i=0,node_count=0; i<num_nodes; i++) {
  2326.       if(top == 0) {
  2327.     if(print_topo_sort) {
  2328.       (void)fprintf(list_fd,"\nCall tree has a cycle");
  2329.       print_cycle_nodes(gsymt,nsym,node_list,node_count,parent_count);
  2330.     }
  2331.     break;
  2332.       }
  2333.       j = top-1;
  2334.       top = parent_count[j];    /* Recover the link */
  2335.  
  2336.                 /* Print the next module */
  2337.       if(print_topo_sort) {
  2338.     node_list[node_count++] = &gsymt[j];
  2339.     parent_count[j] = -1;
  2340.       }
  2341.             /* Decrease parent count of its children */
  2342.       child_list = gsymt[j].link.child_list;
  2343.       while(child_list != NULL) {
  2344.     if( (child_module=child_list->child)->internal_entry )
  2345.       child_module = child_module->link.module;
  2346.     k = child_module - gsymt;
  2347.     if(--parent_count[k] == 0) { /* Now parentless? Stack it*/
  2348.       parent_count[k] = top;
  2349.       top = k+1;
  2350.     }
  2351.     child_list = child_list->next;
  2352.       }
  2353.     }
  2354.   }/*end sort*/
  2355.  
  2356.   if(print_topo_sort && node_count > 0) {
  2357.     (void)fprintf(list_fd,"\nList of called modules in prerequisite order:\n");
  2358.     print_modules(node_count,node_list);
  2359.     (void)fprintf(list_fd,"\n");
  2360.   }
  2361.  
  2362. #ifdef DYNAMIC_TABLES
  2363.   (void) cfree(parent_count);
  2364.   (void) cfree(node_list);
  2365. #endif
  2366.  
  2367.   return (node_count==num_nodes);    /* Success = TRUE */
  2368. }
  2369.  
  2370.         /* Traces back to find nodes not listed in topological
  2371.            sort.  They are the cycle nodes and their descendants.
  2372.          */
  2373. PRIVATE void
  2374. print_cycle_nodes(gsymt,nsym,node_list,node_count,parent_count)
  2375.      Gsymtab gsymt[];
  2376.      int nsym;
  2377.      Gsymtab *node_list[];
  2378.      int node_count;
  2379.      int parent_count[];
  2380. {
  2381.   int i;
  2382.   int k=node_count;
  2383.   for(i=0; i<nsym; i++) {
  2384.     if(gsymt[i].visited_somewhere) {
  2385.       if(parent_count[i] != -1)    /* Not tagged */
  2386.     node_list[k++] = &gsymt[i];
  2387.     }
  2388.   }
  2389.   if(k > node_count)
  2390.     (void)fprintf(list_fd," containing some of the following modules:\n");
  2391.   print_modules(k-node_count,node_list+node_count);
  2392. }
  2393.  
  2394.  
  2395.                 /* Insertion sort of child list.
  2396.                    Also removes duplicates which
  2397.                    can be introduced via multiple
  2398.                    defns or via project files. */
  2399. PRIVATE void
  2400. sort_child_list(child_list)
  2401.      ChildList *child_list;
  2402. {
  2403.   ChildList *front,*prev,*next;
  2404.   Gsymtab *temp;
  2405.   prev = NULL;
  2406.  
  2407.   while(child_list != NULL) {
  2408.             /* Scan thru list for lexicographically lowest name */
  2409.     front=child_list;
  2410.     for(next=child_list->next; next != NULL; next = next->next) {
  2411.       if(strcmp(front->child->name,next->child->name) > 0) {
  2412.     front = next;
  2413.       }
  2414.     }
  2415.             /* Swap child pointers so front is first */
  2416.     if(front != child_list) {
  2417.       temp = front->child;
  2418.       front->child = child_list->child;
  2419.       child_list->child = temp;
  2420.     }
  2421.             /* If duplicate, remove from list */
  2422.     if(prev != NULL && prev->child == child_list->child)
  2423.       prev->next = child_list->next;
  2424.     else
  2425.       prev = child_list;
  2426.     child_list = child_list->next;
  2427.   }
  2428. }
  2429.  
  2430.  
  2431.  
  2432. PRIVATE void
  2433. sort_gsymbols ( glist,n )   /* bubble sort, same as sort_symbols */
  2434.     Gsymtab *glist[];
  2435.     int n;
  2436. {
  2437.     int i,j,swaps;
  2438.  
  2439.     for (i=0; i<n; i++ ){
  2440.         swaps = 0;
  2441.         for  (j=n-1; j>=i+1; j--){
  2442.         if ((strcmp (glist[j-1]->name, glist[j]->name)) >0) {
  2443.             swap_gsymptrs(&glist[j-1], &glist[j] );
  2444.             swaps++;
  2445.         }
  2446.         }
  2447.         if (swaps == 0) break;
  2448.     }
  2449.  
  2450.  
  2451. }
  2452.  
  2453. PRIVATE void
  2454. swap_gsymptrs (x_ptr, y_ptr)    /* swap pointers */
  2455.     Gsymtab **x_ptr,**y_ptr;
  2456. {
  2457.     Gsymtab *temp = *x_ptr;
  2458.     *x_ptr = *y_ptr;
  2459.     *y_ptr = temp;
  2460. }
  2461.