home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / fchk294s.zip / ftnchek-2.9.4 / plsymtab.c < prev    next >
C/C++ Source or Header  |  1996-03-18  |  68KB  |  2,523 lines
  1. /* plsymtab.c:
  2.  
  3.         Routines associated with printing of local 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.         debug_symtabs()    Prints debugging info about symbol tables.
  13.         print_loc_symbols(curmodhash) Prints local symtab info.
  14.  
  15.     Private functions defined:
  16.         has_nonalnum()      True if string has non-alphanumeric char
  17.         sort_symbols()      Sorts the list of names of a given category.
  18.         swap_symptrs()      Swaps a pair of pointers.
  19.         check_flags()     Outputs messages about used-before-set etc.
  20.         check_mixed_common() checks common for nonportable mixed type
  21.         print_symbols(sym_list,n,do_types) Prints symbol lists.
  22.         print_variables(sym_list,n)  Prints variable symbol table
  23.         find_sixclashes() Finds variables with the same first 6 chars.
  24.         identify_module(mod_name) Prints module name and file name.
  25. */
  26.  
  27. #include <stdio.h>
  28. #include <ctype.h>
  29. #include <string.h>
  30. #include "ftnchek.h"
  31. #define PLSYMTAB
  32. #include "symtab.h"
  33.  
  34.                 /* Declarations of local functions */
  35.  
  36. PROTO(PRIVATE void sort_positions,( Lsymtab *sp[], int n ));
  37. PROTO(PRIVATE void sort_symbols,( Lsymtab *sp[], int n ));
  38. PROTO(PRIVATE void swap_symptrs,( Lsymtab **x_ptr, Lsymtab **y_ptr ));
  39. PROTO(PRIVATE void identify_module,( char *mod_name ));
  40. PROTO(PRIVATE int has_nonalnum,( char *s ));
  41. PROTO(PRIVATE int print_symbols,( FILE *fd, Lsymtab *sym_list[], int n, int
  42.               do_types ));
  43. PROTO(PRIVATE int print_variables,( Lsymtab *sym_list[], int n ));
  44. PROTO(PRIVATE int print_var_type,( FILE *fd, Lsymtab *symt ));
  45. PROTO(PRIVATE int find_sixclashes,( Lsymtab *list[] ));
  46. #ifdef DEBUG_SYMTABS
  47. PROTO(PRIVATE void print_arg_array,( ArgListHeader *arglist ));
  48. PROTO(PRIVATE void print_com_array,( ComListHeader *cmlist ));
  49. PROTO(PRIVATE void print_tokenlist,( TokenListHeader *toklist ));
  50. #endif
  51. PROTO(PRIVATE int make_sym_list,( Lsymtab *sym_list[], int (*select)(Lsymtab
  52.                                   *sym_entry) ));
  53. PROTO(PRIVATE void check_mixed_common,( FILE *fd, Lsymtab *sym_list[], int n ));
  54. PROTO(PRIVATE void check_flags,( Lsymtab *list[], int n, unsigned used,
  55.              unsigned set, unsigned ubs, char *msg, char
  56.              *mod_name ));
  57.  
  58. PROTO(PRIVATE void append_char_to_fragment,( int c ));
  59. PROTO(PRIVATE void append_string_to_fragment,( char *s ));
  60. PROTO(PRIVATE void append_expr_text_to_fragment,( char *s ));
  61. PROTO(PRIVATE void make_declarations,( Lsymtab *sym_list[], char *mod_name ));
  62. PROTO(PRIVATE void maybe_print_module_header,( void ));
  63. PROTO(PRIVATE void new_fragment,( void ));
  64. PROTO(PRIVATE void print_blanks,( int nblanks ));
  65. PROTO(PRIVATE void print_common_decls,( Lsymtab *sym_entry ));
  66. PROTO(PRIVATE void print_empty_comment_line,( void ));
  67. PROTO(PRIVATE void print_equivalence_decls,( Lsymtab *sym_entry ));
  68. PROTO(PRIVATE int count_undeclared_variables,( Lsymtab *sym_entry ));
  69. PROTO(PRIVATE void print_list_decls,( Lsymtab *sym_list[], int n, char
  70.                   *header, char *list_type_name ));
  71. PROTO(PRIVATE int print_list_name,( char *list_type_name, char *name ));
  72. PROTO(PRIVATE void print_declaration_class,( Lsymtab *sym_list[], int n, char
  73.                      *header ));
  74. PROTO(PRIVATE void print_one_list_decls,( Lsymtab *sym_entry, char
  75.                   *list_type_name, char **pheader, int
  76.                   *pnd ));
  77. PROTO(PRIVATE void print_parameter_statement,( Lsymtab *symt ));
  78. PROTO(PRIVATE void print_selected_declarations,( Lsymtab *sym_list[], int n,
  79.                      int the_type, char
  80.                      *type_name, char **pheader ));
  81. PROTO(PRIVATE int print_type_name,( int the_type, char *type_name, int
  82.                 the_size, Lsymtab *symt ));
  83. PROTO(PRIVATE int select_arguments,( Lsymtab *sym_entry ));
  84. PROTO(PRIVATE int select_commons,( Lsymtab *sym_entry ));
  85. PROTO(PRIVATE int select_externals_by_name,( Lsymtab *sym_entry ));
  86. PROTO(PRIVATE int select_externals_by_type,( Lsymtab *sym_entry ));
  87. PROTO(PRIVATE int select_intrinsics_by_name,( Lsymtab *sym_entry ));
  88. PROTO(PRIVATE int select_intrinsics_by_type,( Lsymtab *sym_entry ));
  89. PROTO(PRIVATE int select_locals,( Lsymtab *sym_entry ));
  90. PROTO(PRIVATE int select_common_blocks,( Lsymtab *sym_entry ));
  91. PROTO(PRIVATE int select_namelists,( Lsymtab *sym_entry ));
  92. PROTO(PRIVATE int select_parameters,( Lsymtab *sym_entry ));
  93. PROTO(PRIVATE int select_statement_functions,( Lsymtab *sym_entry ));
  94. PROTO(PRIVATE int sf3_internal_name,( Lsymtab *sym_entry ));
  95.  
  96.  
  97.  
  98. PRIVATE void
  99. #if HAVE_STDC
  100. sort_positions(Lsymtab **sp, int n) /* sort a given list by sequence num instead of name */
  101. #else /* K&R style */
  102. sort_positions(sp,n) /* sort a given list by sequence num instead of name */
  103.     Lsymtab *sp[];
  104.     int n;
  105. #endif /* HAVE_STDC */
  106. {
  107.     int i,j,swaps;
  108.  
  109.     for (i = 0; i < n; i++)
  110.     {
  111.     swaps = 0;
  112.     for (j = n-1; j >= i+1; j--)
  113.     {
  114.         if ( sp[j-1]->info.param->seq_num > sp[j]->info.param->seq_num )
  115.         {
  116.         swap_symptrs(&sp[j-1], &sp[j]);
  117.         swaps ++;
  118.         }
  119.     }
  120.     if(swaps == 0)
  121.         break;
  122.     }
  123. }
  124.  
  125.  
  126. PRIVATE void
  127. #if HAVE_STDC
  128. sort_symbols(Lsymtab **sp, int n)      /* sorts a given list */
  129. #else /* K&R style */
  130. sort_symbols(sp,n)      /* sorts a given list */
  131.     Lsymtab *sp[];
  132.     int n;
  133. #endif /* HAVE_STDC */
  134. {
  135.     int i,j,swaps;
  136.     for(i=0;i<n;i++) {
  137.         swaps = 0;
  138.         for(j=n-1;j>=i+1;j--) {
  139.         if((strcmp(sp[j-1]->name, sp[j]->name)) > 0) {
  140.            swap_symptrs(&sp[j-1], &sp[j]);
  141.            swaps ++;
  142.         }
  143.         }
  144.         if(swaps == 0) break;
  145.     }
  146. }
  147.  
  148.  
  149. PRIVATE void            /* swaps two pointers */
  150. #if HAVE_STDC
  151. swap_symptrs(Lsymtab **x_ptr, Lsymtab **y_ptr)
  152. #else /* K&R style */
  153. swap_symptrs(x_ptr,y_ptr)
  154.     Lsymtab **x_ptr,**y_ptr;
  155. #endif /* HAVE_STDC */
  156. {
  157.     Lsymtab *temp = *x_ptr;
  158.     *x_ptr = *y_ptr;
  159.     *y_ptr = temp;
  160. }
  161.  
  162.  
  163. /* Routine to print module name and file name just once in standard
  164.    format is shared by print_loc_symbols, check_mixed_common and check_flags*/
  165. PRIVATE int any_warnings;
  166.  
  167. PRIVATE void
  168. #if HAVE_STDC
  169. identify_module(char *mod_name)
  170. #else /* K&R style */
  171. identify_module(mod_name)
  172.      char *mod_name;
  173. #endif /* HAVE_STDC */
  174. {
  175.   if(do_symtab) {
  176.     (void)fprintf(list_fd,"\nWarning: ");
  177.   }
  178.   else {
  179.     if(any_warnings++ == 0) { /* 1st message of this module? */
  180.       if(novice_help) {        /* Old-style format */
  181.     (void)fprintf(list_fd,
  182.         "\nWarning in module %s file %s:",
  183.         mod_name,current_filename);
  184.       }
  185.       else {            /* Lint-style format */
  186.     (void)fprintf(list_fd,
  187.         "\n\"%s\" module %s: Warning:",
  188.         current_filename,mod_name);
  189.       }
  190.     }
  191.     (void)fprintf(list_fd,"\n   ");    /* Details go indented on next line */
  192.   }
  193.   ++warning_count;        /* Count these warnings too */
  194. }
  195.  
  196.  
  197. void
  198. #if HAVE_STDC
  199. print_loc_symbols(int curmodhash)
  200.                             /* hash entry of current module */
  201. #else /* K&R style */
  202. print_loc_symbols(curmodhash)
  203.      int curmodhash;        /* hash entry of current module */
  204. #endif /* HAVE_STDC */
  205. {
  206. #ifdef DYNAMIC_TABLES        /* tables will be mallocked at runtime */
  207.     static Lsymtab **sym_list=(Lsymtab **)NULL;
  208. #else
  209.     Lsymtab *sym_list[LOCSYMTABSZ]; /* temp. list of symtab entries to print */
  210. #endif
  211.     int    mod_type,        /* datatype of this module */
  212.     this_is_a_function;    /* flag for treating funcs specially */
  213.     Lsymtab *module;         /* entry of current module in symtab */
  214.     char *mod_name;        /* module name */
  215.     int
  216.     com_vars_modified=0,    /* count of common variables which are set */
  217.     args_modified=0,    /* count of arguments which are set */
  218.     imps=0,            /* count of implicitly declared identifiers */
  219.     numentries;        /* count of entry points of module */
  220.  
  221.     if (dcl_fd == (FILE*)NULL)
  222.     dcl_fd = stdout;
  223.  
  224. #ifdef DYNAMIC_TABLES
  225.     if(sym_list == (Lsymtab **)NULL) { /* Initialize if not done before */
  226.       if( (sym_list=(Lsymtab **)calloc(LOCSYMTABSZ,sizeof(Lsymtab *)))
  227.      == (Lsymtab **)NULL) {
  228.       oops_message(OOPS_FATAL,NO_LINE_NUM,NO_COL_NUM,
  229.                "Cannot malloc space for local symbol list");
  230.       }
  231.     }
  232. #endif
  233.  
  234.     any_warnings=0;        /* for identify_module(mod_name); */
  235.  
  236.                 /* Keep track of statement counts
  237.                    for -resource  */
  238.     tot_exec_stmt_count += exec_stmt_count;
  239.     if(exec_stmt_count > max_exec_stmt_count)
  240.     max_exec_stmt_count = exec_stmt_count;
  241.  
  242.             /* Keep track of symbol table and string usage */
  243.     if(loc_symtab_top > max_loc_symtab) {
  244.     max_loc_symtab = loc_symtab_top;
  245.     }
  246.     if(loc_str_top + extra_locstrspace > max_loc_strings) {
  247.     max_loc_strings = loc_str_top + extra_locstrspace;
  248.     }
  249.     if(srctextspace_top + extra_srctextspace > max_srctextspace) {
  250.       max_srctextspace = srctextspace_top + extra_srctextspace;
  251.     }
  252.     if(token_head_space_top + extra_tokheadspace > max_tokenlists) {
  253.       max_tokenlists=token_head_space_top + extra_tokheadspace;
  254.     }
  255.     if(param_info_space_top + extra_paraminfospace > max_paraminfo) {
  256.       max_paraminfo=param_info_space_top + extra_paraminfospace;
  257.     }
  258.     if(token_space_top + extra_tokspace > max_token_space) {
  259.     max_token_space = token_space_top + extra_tokspace;
  260.     }
  261.     if(ptrspace_top + extra_ptrspace > max_ptrspace) {
  262.       max_ptrspace = ptrspace_top + extra_ptrspace;
  263.     }
  264.             /* Global symbols only increase in number */
  265.     max_glob_symtab = glob_symtab_top;
  266.  
  267.  
  268.         /* Set up name & type, and see what kind of module it is */
  269.  
  270.           module = hashtab[curmodhash].loc_symtab;
  271.  
  272.           mod_name = module->name;
  273.           mod_type = get_type(module);
  274.  
  275.           if(  mod_type != type_PROGRAM
  276.         && mod_type != type_SUBROUTINE
  277.         && mod_type != type_COMMON_BLOCK
  278.         && mod_type != type_BLOCK_DATA )
  279.             this_is_a_function = TRUE;
  280.           else
  281.             this_is_a_function = FALSE;
  282.  
  283.                 /* Print name & type of the module */
  284.     if(do_symtab) {
  285.       int i;
  286.       for(i=0,numentries=0;i<loc_symtab_top;i++) {
  287.     if(loc_symtab[i].entry_point)
  288.       sym_list[numentries++] = &loc_symtab[i];
  289.       }
  290.  
  291.        if(numentries > 1) {
  292.           sort_symbols(sym_list,numentries);
  293.        }
  294.  
  295.  
  296.       (void)fprintf(list_fd,"\n\nModule %s:",mod_name);
  297.       if( this_is_a_function ) (void)fprintf(list_fd," func:");
  298.       (void)fprintf(list_fd," %4s",type_name[mod_type]);
  299.             /* Print a * next to non-declared function name */
  300.       if(datatype_of(module->type) == type_UNDECL ) {
  301.             (void)fprintf(list_fd,"*");
  302.             imps++;
  303.       }
  304.       (void)fprintf(list_fd,"\n");
  305.  
  306.  
  307.                 /* Print Entry Points (skip if only one,
  308.                    since it is same as module name) */
  309.       if(do_symtab && numentries > 1) {
  310.           (void)fprintf(list_fd,"\nEntry Points\n");
  311.           (void) print_symbols(list_fd,sym_list,numentries,FALSE);
  312.       }
  313.  
  314.             /* End of printing module name and entry points */
  315.     }/*if(do_symtab)*/
  316.  
  317.  
  318.  
  319.                 /* Print the externals */
  320.  
  321.     if(do_symtab) {
  322.     int i,n;
  323.     for(i=0,n=0;i<loc_symtab_top;i++) {
  324.         if(storage_class_of(loc_symtab[i].type) == class_SUBPROGRAM) {
  325.           sym_list[n++] = &loc_symtab[i];
  326.         }
  327.     }
  328.     if(n != 0) {
  329.           sort_symbols(sym_list,n);
  330.  
  331.           if (do_symtab)
  332.           {
  333.           (void)fprintf(list_fd,"\nExternal subprograms referenced:\n");
  334.           imps += print_symbols(list_fd,sym_list,n,TRUE);
  335.           }
  336.     }
  337.  
  338.       }/*if(do_symtab)*/
  339.  
  340.  
  341.                 /* Print list of statement functions */
  342.     if(do_symtab || check_ext_unused) {
  343.        int i,n;
  344.  
  345.        for(i=0,n=0;i<loc_symtab_top;i++) {
  346.            if(storage_class_of(loc_symtab[i].type) == class_STMT_FUNCTION){
  347.           sym_list[n++] = &loc_symtab[i];
  348.            }
  349.        }
  350.        if(n != 0) {
  351.           sort_symbols(sym_list,n);
  352.           if(do_symtab) {
  353.         (void)fprintf(list_fd,"\nStatement functions defined:\n");
  354.         imps += print_symbols(list_fd,sym_list,n,TRUE);
  355.           }
  356.           if(check_ext_unused) {
  357.         check_flags(sym_list,n,0,1,0,
  358.          "Statement functions declared but never referenced",mod_name);
  359.           }
  360.         }
  361.     }/*if(do_symtab)*/
  362.  
  363.  
  364.                 /* Print the common blocks */
  365.     if(do_symtab || port_common_alignment || f77_mixed_common) {
  366.        int i,numblocks;
  367.  
  368.        for(i=0,numblocks=0;i<loc_symtab_top;i++) {
  369.           if(storage_class_of(loc_symtab[i].type) == class_COMMON_BLOCK) {
  370.           sym_list[numblocks++] = &loc_symtab[i];
  371.           }
  372.        }
  373.  
  374.        if(numblocks != 0) {
  375.           sort_symbols(sym_list,numblocks);
  376.           if(do_symtab) {
  377.           (void)fprintf(list_fd,"\nCommon blocks referenced:\n");
  378.           (void) print_symbols(list_fd,sym_list,numblocks,FALSE);
  379.           }
  380.           if(port_common_alignment || f77_mixed_common) {
  381.             check_mixed_common(list_fd,sym_list,numblocks);
  382.           }
  383.        }
  384.      }/*if(do_symtab||port_common_alignment||f77_mixed_common)*/
  385.  
  386.                 /* Print the namelists */
  387.     if(do_symtab) {
  388.        int i,numlists;
  389.  
  390.        for(i=0,numlists=0;i<loc_symtab_top;i++) {
  391.           if(storage_class_of(loc_symtab[i].type) == class_NAMELIST) {
  392.           sym_list[numlists++] = &loc_symtab[i];
  393.           }
  394.        }
  395.  
  396.        if(numlists != 0) {
  397.           sort_symbols(sym_list,numlists);
  398.           if(do_symtab) {
  399.           (void)fprintf(list_fd,"\nNamelists defined:\n");
  400.           (void) print_symbols(list_fd,sym_list,numlists,FALSE);
  401.           }
  402.         }
  403.  
  404.     }/* End printing the namelists */
  405.                 /* Process the variables */
  406.  
  407.     if(do_symtab || var_usage_check) {
  408.     int i,n;
  409.  
  410.     for(i=0,n=0;i<loc_symtab_top;i++) {
  411.            if(storage_class_of(loc_symtab[i].type) == class_VAR
  412.            && (!loc_symtab[i].entry_point || this_is_a_function)) {
  413.           sym_list[n++] = &loc_symtab[i];
  414.           if(loc_symtab[i].argument && loc_symtab[i].set_flag) {
  415.             if(++args_modified <= 3)
  416.             if(this_is_a_function && pure_functions) {
  417.                 identify_module(mod_name);
  418.                 (void)fprintf(list_fd,
  419.                   "Function %s %s argument %s",
  420.                   mod_name,
  421.                   loc_symtab[i].assigned_flag?
  422.                     "modifies":"may modify",
  423.                   loc_symtab[i].name);
  424.             }
  425.           }
  426.           if(loc_symtab[i].common_var && loc_symtab[i].set_flag) {
  427.             if(++com_vars_modified <= 3)
  428.             if(this_is_a_function && pure_functions) {
  429.                 identify_module(mod_name);
  430.                 (void)fprintf(list_fd,
  431.                   "Function %s %s common variable %s",
  432.                   mod_name,
  433.                   loc_symtab[i].assigned_flag?
  434.                     "modifies":"may modify",
  435.                   loc_symtab[i].name);
  436.             }
  437.           }
  438.            }
  439.     }
  440.     if(args_modified > 3 || com_vars_modified > 3)
  441.       if(this_is_a_function && pure_functions)
  442.         (void)fprintf(list_fd,"\netc...");
  443.     if(n != 0) {
  444.        sort_symbols(sym_list,n);
  445.  
  446.             /* Print the variables */
  447.  
  448.        if(do_symtab) {
  449.           (void)fprintf(list_fd,"\nVariables:\n ");
  450.           imps += print_variables(sym_list,n);
  451.        }
  452.     }
  453.             /* Explain the asterisk on implicitly defined
  454.                identifiers.  Note that this message will
  455.                be given also if functions implicitly defined */
  456.     if(do_symtab && imps != 0) {
  457.          (void)fprintf(list_fd,"\n* Variable not declared.");
  458.          (void)fprintf(list_fd," Type has been implicitly defined.\n");
  459.          ++warning_count;
  460.     }
  461.  
  462.     if(var_usage_check) {
  463.       if(do_symtab || do_list)
  464.         (void)fprintf(list_fd,"\n");
  465.       if(check_var_unused) {
  466.         check_flags(sym_list,n,0,0,0,
  467.               "Variables declared but never referenced",mod_name);
  468.         check_flags(sym_list,n,0,1,0,
  469.               "Variables set but never used",mod_name);
  470.       }
  471.       if(check_var_set_used) {
  472.         check_flags(sym_list,n,1,0,1,
  473.               "Variables used before set",mod_name);
  474.         check_flags(sym_list,n,1,1,1,
  475.               "Variables may be used before set",mod_name);
  476.       }
  477.  
  478.     }/*end if(var_usage_check)*/
  479.  
  480.     if(do_symtab || do_list)
  481.       (void)fprintf(list_fd,"\n");
  482.  
  483.     }/* end if(do_symtab || var_usage_check) */
  484.  
  485.             /* List all undeclared vars & functions */
  486.     if(decls_required || implicit_none) {
  487.     int i,n;
  488.  
  489.     for(i=0,n=0;i<loc_symtab_top;i++) {
  490.         if(datatype_of(loc_symtab[i].type) == type_UNDECL
  491.         && ! loc_symtab[i].intrinsic /* omit intrinsics */
  492.                 /* omit subroutines called */
  493.         && (!loc_symtab[i].external || loc_symtab[i].invoked_as_func)
  494.            ) {
  495.         sym_list[n++] = &loc_symtab[i];
  496.         }
  497.     }
  498.     if(n != 0) {
  499.         sort_symbols(sym_list,n);
  500.         identify_module(mod_name);
  501.         (void)fprintf(list_fd,
  502.             "Identifiers of undeclared type");
  503.         (void) print_symbols(list_fd,sym_list,n,FALSE);
  504.     }
  505.     }/*if(decls_required || implicit_none)*/
  506.  
  507.             /* Under -f77, list any nonstandard intrinsics used */
  508.     if(f77_intrinsics) {
  509.       int i,n;
  510.       for(i=0,n=0;i<loc_symtab_top;i++) {
  511.     if(storage_class_of(loc_symtab[i].type) == class_SUBPROGRAM
  512.        && loc_symtab[i].intrinsic &&
  513.        (loc_symtab[i].info.intrins_info->intrins_flags & I_NONF77)) {
  514.       sym_list[n++] = &loc_symtab[i];
  515.     }
  516.       }
  517.       if(n != 0) {
  518.     sort_symbols(sym_list,n);
  519.     identify_module(mod_name);
  520.     (void)fprintf(list_fd,"Nonstandard intrinsic functions referenced:\n");
  521.     (void) print_symbols(list_fd,sym_list,n,FALSE);
  522.       }
  523.     }/*if(f77_standard)*/
  524.  
  525.  
  526.         /* issue -f77 warning for identifiers
  527.            longer than 6 characters
  528.         */
  529.     if(f77_long_names) {
  530.     int i,n;
  531.     for(i=0,n=0;i<loc_symtab_top;i++) {
  532.            if(strlen(loc_symtab[i].name) > (unsigned)6)
  533.           sym_list[n++] = &loc_symtab[i];
  534.     }
  535.  
  536.     if(n != 0) {
  537.  
  538.        sort_symbols(sym_list,n);
  539.  
  540.        identify_module(mod_name);
  541.        (void)fprintf(list_fd,
  542.            "Names longer than 6 chars (nonstandard):");
  543.        (void) print_symbols(list_fd,sym_list,n,FALSE);
  544.     }
  545.     }
  546.  
  547.     /* If -f77 flag given, list names with underscore or dollarsign */
  548.  
  549.     if(f77_underscores || f77_dollarsigns) {
  550.     int i,n;
  551.     for(i=0,n=0;i<loc_symtab_top;i++) {
  552.             /* Find all names with nonstd chars, but
  553.                exclude internal names like %MAIN */
  554.            if(has_nonalnum(loc_symtab[i].name) &&
  555.           loc_symtab[i].name[0] != '%')
  556.           sym_list[n++] = &loc_symtab[i];
  557.     }
  558.  
  559.     if(n != 0) {
  560.  
  561.        sort_symbols(sym_list,n);
  562.  
  563.        identify_module(mod_name);
  564.  
  565.        (void)fprintf(list_fd,
  566.            "Names containing nonstandard characters");
  567.        (void) print_symbols(list_fd,sym_list,n,FALSE);
  568.     }
  569.     }/*if(f77_underscores || f77_dollarsigns)*/
  570.  
  571.             /* Print out clashes in first six chars of name */
  572.     if(sixclash) {
  573.      int n;
  574.      n = find_sixclashes(sym_list);
  575.      if(n != 0) {
  576.         sort_symbols(sym_list,n);
  577.         identify_module(mod_name);
  578.         (void)fprintf(list_fd,
  579.             "Identifiers which are not unique in first six chars");
  580.         (void) print_symbols(list_fd,sym_list,n,FALSE);
  581.      }/* end if(n != 0) */
  582.     }/* end if(sixclash) */
  583.  
  584.  
  585.         /* If portability flag was given, check equivalence
  586.            groups for mixed type. */
  587.     if(port_mixed_equiv || port_mixed_size || local_wordsize==0) {
  588.     int i,j,n;
  589.     int imps=0;
  590.     Lsymtab *equiv;
  591.  
  592.         /* scan thru table for equivalenced variables */
  593.     for(i=0;i<loc_symtab_top;i++) {
  594.         if(storage_class_of(loc_symtab[i].type) == class_VAR
  595.            && loc_symtab[i].equiv_link != (equiv= &loc_symtab[i]) ){
  596.         n=0;
  597.         do {
  598.             if(equiv < &loc_symtab[i]) { /* skip groups done before */
  599.             n=0;
  600.             break;
  601.             }
  602.             sym_list[n++] = equiv;
  603.             equiv = equiv->equiv_link;
  604.         } while(equiv != &loc_symtab[i]); /* complete the circle */
  605.                 /* Check for mixed types */
  606.         if(n != 0) {
  607.             int mixed_type = FALSE, mixed_size = FALSE,
  608.             mixed_default_size = FALSE;
  609.             int t1,t2,s1,s2,defsize1,defsize2;
  610.  
  611.             t1 = get_type(sym_list[0]);
  612.             s1 = get_size(sym_list[0],t1);
  613.             defsize1 = (s1 == size_DEFAULT);
  614.             if(s1 == size_DEFAULT) s1 = type_size[t1];
  615.             for(j=1; j<n; j++) {
  616.               t2 = get_type(sym_list[j]);
  617.               s2 = get_size(sym_list[j],t2);
  618.               defsize2 = (s2 == size_DEFAULT);
  619.               if(s2 == size_DEFAULT) s2 = type_size[t2];
  620.               if( t1 == t2 ) {
  621.             if( t1 != type_STRING ){
  622.                 /* Same non-char types: size must match */
  623.               if( s1 != s2 ) {
  624.                 mixed_size = TRUE;
  625.                 break;
  626.               }
  627.               else if(defsize1 != defsize2) {
  628.                 mixed_default_size = TRUE;
  629.                 break;
  630.               }
  631.             }
  632.               }
  633.               else {/* Different types */
  634.                 /* It is nonportable to equivalence:
  635.                      Real*8 to Double or
  636.                      Complex*16 to DComplex */
  637.             if(type_category[t1] == type_category[t2]) {
  638.               if( s1 != s2 ) {
  639.                 mixed_size = TRUE;
  640.                 break;
  641.               }
  642.               else if(defsize1 != defsize2) {
  643.                 mixed_default_size = TRUE;
  644.                 break;
  645.               }
  646.             }
  647.                 /* It is standard and portable to equivalence:
  648.                      Real to Complex or
  649.                      Double to DComplex */
  650.             else if(equiv_type[t1] == equiv_type[t2]) {
  651.               if( ((type_category[t1] == type_COMPLEX)?
  652.                 s1 != 2*s2: s2 != 2*s1) ) {
  653.                 mixed_size = TRUE;
  654.                 break;
  655.               }
  656.               else if(defsize1 != defsize2) {
  657.                 mixed_default_size = TRUE;
  658.                 break;
  659.               }
  660.             }
  661.             else {
  662.               mixed_type = TRUE;
  663.               break;
  664.             }
  665.               }/*end else different types*/
  666.  
  667.               t1 = t2;
  668.               s1 = s2;
  669.               defsize1 = defsize2;
  670.             }/*end for j*/
  671.  
  672.             if( (mixed_type && port_mixed_equiv) ||
  673.                ((mixed_size || mixed_default_size) &&
  674.             (port_mixed_size || local_wordsize==0)) )  {
  675.             sort_symbols(sym_list,n);
  676.             identify_module(mod_name);
  677.             (void)fprintf(list_fd,
  678.                    "Mixed %s equivalenced (not portable):",
  679.                     mixed_type?"types":
  680.                       mixed_size?"sizes":
  681.                        "default and explicit size items");
  682.  
  683.             imps += print_symbols(list_fd,sym_list,n,TRUE);
  684.             }
  685.         }
  686.         }
  687.     }
  688.     if(imps != 0) {
  689.          identify_module(mod_name);
  690.          (void)fprintf(list_fd,"* Variable not declared.");
  691.          (void)fprintf(list_fd," Type has been implicitly defined.\n");
  692.     }
  693.  
  694.     }/*if(port_mixed_size/type)*/
  695.  
  696.     make_declarations(sym_list,mod_name);
  697. }/* print_loc_symbols */
  698.  
  699.  
  700. PRIVATE int
  701. #if HAVE_STDC
  702. has_nonalnum(char *s)    /* Returns TRUE if s contains a non-alphanumeric character
  703.            and -f77, or if it has $ or _ and that is not allowed  */
  704. #else /* K&R style */
  705. has_nonalnum(s)    /* Returns TRUE if s contains a non-alphanumeric character
  706.            and -f77, or if it has $ or _ and that is not allowed  */
  707.    char *s;
  708. #endif /* HAVE_STDC */
  709. {
  710.    while( *s != '\0' ) {
  711.      if( (f77_dollarsigns && (*s) == '$')
  712.       || (f77_underscores && (*s) == '_') )
  713.        return TRUE;
  714.      s++;
  715.    }
  716.    return FALSE;
  717. }
  718.  
  719.  
  720.      /* This routine prints symbol names neatly.  If do_types is true
  721.     also prints types, with * next to implicitly
  722.     typed identifiers, and returns count thereof. */
  723.  
  724. PRIVATE int
  725. #if HAVE_STDC
  726. print_symbols(FILE *fd, Lsymtab **sym_list, int n, int do_types)
  727. #else /* K&R style */
  728. print_symbols(fd,sym_list,n,do_types)
  729.      FILE *fd;
  730.      Lsymtab *sym_list[];
  731.      int n;
  732.      int do_types;
  733. #endif /* HAVE_STDC */
  734. {
  735.      int i,col=0,len,implicits=0;
  736.  
  737.      (void)fprintf(fd,"\n");
  738.  
  739.      for(i=0;i<n;i++) {
  740.       len = strlen(sym_list[i]->name);/* len=actual length of name */
  741.                 /* Revise len to max(10,len)+extra 9=width
  742.                    of field to be printed.  Adjust column
  743.                    count to see where this will take us. */
  744.       col += len = (len <= 10? 10: len) + 9;
  745.                 /* If this will run past 78 start a new line */
  746.       if(col > 78) {
  747.         (void)fprintf(fd,"\n");
  748.         col = len;
  749.       }
  750.       (void)fprintf(fd,"%10s",sym_list[i]->name);/* Print the name in 10 cols */
  751.  
  752.       if( do_types ) {    /* Optionally print the datatype */
  753.         if(sym_list[i]->intrinsic)
  754.           (void)fprintf(fd,": intrns ");
  755.         else {
  756.           (void)fprintf(fd,":");
  757.           (void) print_var_type(fd,sym_list[i]);
  758.           if(datatype_of(sym_list[i]->type) == type_UNDECL) {
  759.         implicits++; /* Flag and count undeclareds */
  760.         (void)fprintf(fd,"*");
  761.           }
  762.           else if(sym_list[i]->size == size_DEFAULT)
  763.         (void)fprintf(fd," ");
  764.           (void)fprintf(fd,"  ");
  765.         }
  766.       }
  767.       else            /* Otherwise just 9 blanks */
  768.         (void)fprintf(fd,"%9s","");
  769.      }
  770.  
  771.      (void)fprintf(fd,"\n");
  772.  
  773.      return implicits;
  774.  
  775. }/*print_symbols*/
  776.  
  777.  
  778.     /* This routine prints the variables nicely, and returns
  779.         count of number implicitly defined.
  780.      */
  781. PRIVATE int
  782. #if HAVE_STDC
  783. print_variables(Lsymtab **sym_list, int n)
  784. #else /* K&R style */
  785. print_variables(sym_list,n)
  786.      Lsymtab *sym_list[];
  787.      int n;
  788. #endif /* HAVE_STDC */
  789. {
  790.      int i,implicits=0,adjustables=0;
  791.  
  792.      (void)fprintf(list_fd,"\n ");
  793.  
  794.      for(i=0; i<4; i++) {
  795.       (void)fprintf(list_fd,"%5sName Type Dims","");
  796.               /* 12345678901234567890 template for above*/
  797.      }
  798.      for(i=0; i<n; i++) {
  799.  
  800.       if(i % 4 == 0)
  801.          (void)fprintf(list_fd,"\n");
  802.       else
  803.          (void)fprintf(list_fd," ");
  804.  
  805.       (void)fprintf(list_fd,"%10s",sym_list[i]->name);
  806.       adjustables += print_var_type(list_fd,sym_list[i]);
  807.  
  808.             /* Print a * next to implicitly declared variables */
  809.       if(datatype_of(sym_list[i]->type) == type_UNDECL ) {
  810.         implicits++;
  811.         (void)fprintf(list_fd,"*");
  812.       }
  813.       else if(sym_list[i]->size == size_DEFAULT)
  814.         (void)fprintf(list_fd," "); /* print blank if no size or * */
  815.  
  816.  
  817.             /* print no. of dimensions next to var name */
  818.       if(sym_list[i]->array_var) {
  819.         (void)fprintf(list_fd," %ld",
  820.                    array_dims(sym_list[i]->info.array_dim));
  821.       }
  822.       else {
  823.         (void)fprintf(list_fd,"%2s","");
  824.       }
  825.     }
  826.  
  827.     if(adjustables > 0)
  828.       (void)fprintf(list_fd,"\nchar+ indicates adjustable size");
  829.     (void)fprintf(list_fd,"\n");
  830.  
  831.     return implicits;
  832.  
  833. }/*print_variables*/
  834.  
  835.  
  836. PRIVATE int
  837. #if HAVE_STDC
  838. print_var_type(FILE *fd, Lsymtab *symt)    /* Prints type name then size if explicit */
  839. #else /* K&R style */
  840. print_var_type(fd,symt)    /* Prints type name then size if explicit */
  841. #endif /* HAVE_STDC */
  842.             /* Returns 1 if adjustable size, else 0 */
  843. #if HAVE_STDC
  844. #else /* K&R style */
  845.      FILE *fd;
  846.      Lsymtab *symt;
  847. #endif /* HAVE_STDC */
  848. {
  849.   int adjustable=0;
  850.   int t = get_type(symt);
  851.   int s = get_size(symt,t);
  852.  
  853.       (void)fprintf(fd," %4s",type_name[t]);
  854.  
  855.         /* Usually either size or * will be printed, and usually
  856.            size is 1 digit.  So mostly we print 1 column in
  857.            the next set of (void)fprintf's.  Output will be ragged
  858.            if size > 9 or implicit type has explicit size. */
  859.       if( s != size_DEFAULT ) {
  860.         if(t != type_STRING || s > 1)
  861.           (void)fprintf(fd,"%d",s);
  862.         else
  863.           if(s == size_ADJUSTABLE) {
  864.         adjustable++;
  865.         (void)fprintf(fd,"+");
  866.           }
  867.           else
  868.         (void)fprintf(fd," ");
  869.       }
  870.   return adjustable;
  871. }
  872.  
  873.  
  874.     /* Search thru local symbol table for clashes where identifiers
  875.        are not unique in 1st six characters. Return value =
  876.        number of clashes found, with pointers to symbol table
  877.        entries of clashers in array list. */
  878. PRIVATE int
  879. #if HAVE_STDC
  880. find_sixclashes(Lsymtab **list)
  881. #else /* K&R style */
  882. find_sixclashes(list)
  883.     Lsymtab *list[];
  884. #endif /* HAVE_STDC */
  885. {
  886.     int i,h, clashes=0;
  887.     int class;
  888.     unsigned long hnum;
  889.  
  890.     for(i=0; i<loc_symtab_top; i++) {    /* Scan thru symbol table */
  891.         class = storage_class_of(loc_symtab[i].type);
  892.         hnum = hash( loc_symtab[i].name );
  893.                 /* First look for a clash of any kind.
  894.                    (N.B. this loop will never quit if hash
  895.                    table is full, but let's not worry) */
  896.         while( (h=hnum % HASHSZ), hashtab[h].name != (char *)NULL) {
  897.         /* Now see if the clashing name is used locally and still
  898.            clashes at 6 chars.  Treat common blocks separately. */
  899.  
  900.          if((class == class_COMMON_BLOCK &&
  901.           (
  902.            hashtab[h].com_loc_symtab != NULL
  903.            && strcmp( hashtab[h].name,loc_symtab[i].name) != 0
  904.            && strncmp(hashtab[h].name,loc_symtab[i].name,6) == 0
  905.           )
  906.         )  ||
  907.          (class != class_COMMON_BLOCK &&
  908.           (
  909.            hashtab[h].loc_symtab != NULL
  910.            && strcmp( hashtab[h].name,loc_symtab[i].name) != 0
  911.            && strncmp(hashtab[h].name,loc_symtab[i].name,6) == 0
  912.           )
  913.          )
  914.            ) {
  915.                 /* If so, then i'th symbol is a clash */
  916.  
  917.             list[clashes++] = &loc_symtab[i];
  918.             break;
  919.         }
  920.         else {
  921.             hnum = rehash(hnum);
  922.         }
  923.         }
  924.     }
  925.     return clashes;
  926. }
  927.  
  928.  
  929. #ifdef DEBUG_SYMTABS
  930. PRIVATE void
  931. print_arg_array(arglist)    /* prints type and flag info for arguments */
  932.     ArgListHeader *arglist;
  933. {
  934.     int i, count;
  935.     ArgListElement *a;
  936.  
  937.     count = arglist->numargs;
  938.     if(arglist->external_decl || arglist->actual_arg)
  939.       count = 0;
  940.     a = arglist->arg_array;
  941.     (void)fprintf(list_fd,"\nArg list in module %s file %s line %u:",
  942.         arglist->module->name, arglist->filename, arglist->line_num);
  943.     (void)fprintf(list_fd,"\n\tdef%d call%d ext%d arg%d",
  944.         arglist->is_defn,
  945.         arglist->is_call,
  946.         arglist->external_decl,
  947.         arglist->actual_arg);
  948.     if(count == 0)
  949.         (void)fprintf(list_fd,"\n(Empty list)");
  950.     else {
  951.         for (i=0; i<count; i++) {
  952.         (void)fprintf(list_fd,
  953.             "\n\t%d %s: lv%d st%d as%d ub%d ar%d ae%d ex%d",
  954.             i+1,
  955.             type_name[datatype_of(a[i].type)],
  956.                 a[i].is_lvalue,
  957.                 a[i].set_flag,
  958.                 a[i].assigned_flag,
  959.                 a[i].used_before_set,
  960.                 a[i].array_var,
  961.                 a[i].array_element,
  962.                 a[i].declared_external);
  963.         if(a[i].array_var)
  964.             (void)fprintf(list_fd,"(%ld,%ld)",
  965.             array_dims(a[i].info.array_dim),
  966.             array_size(a[i].info.array_dim) );
  967.         (void)fprintf(list_fd,", ");
  968.         }
  969.     }
  970. }/* print_arg_array */
  971. #endif
  972.  
  973. #ifdef DEBUG_SYMTABS
  974.            /* prints type and dimen info for common vars */
  975. PRIVATE void
  976. print_com_array(cmlist)
  977.     ComListHeader *cmlist;
  978. {
  979.     int i, count;
  980.     ComListElement *c;
  981.  
  982.     count = cmlist->numargs;
  983.     c = cmlist->com_list_array;
  984.     (void)fprintf(list_fd,"\nCom list in module %s file %s line %u:",
  985.         cmlist->module->name, cmlist->filename, cmlist->line_num);
  986.     (void)fprintf(list_fd,"\n\t");
  987.     if(count == 0)
  988.         (void)fprintf(list_fd,"(Empty list)");
  989.     else {
  990.         for (i=0; i<count; i++){
  991.         (void)fprintf(list_fd,"%s",type_name[datatype_of(c[i].type)]);
  992.         if(c[i].dimen_info)
  993.             (void)fprintf(list_fd,":%ldD(%ld)",array_dims(c[i].dimen_info),
  994.                        array_size(c[i].dimen_info));
  995.         (void)fprintf(list_fd,", ");
  996.         }
  997.     }
  998. }/* print_com_array */
  999. #endif
  1000.  
  1001.  
  1002. #if 0 /* debugging code not currently in use */
  1003. PRIVATE void
  1004. print_tokenlist(toklist)    /* prints list of token names or types */
  1005.     TokenListHeader *toklist;
  1006. {
  1007.     int numargs=0;
  1008.     Token *t;
  1009.     (void)fprintf(list_fd,"\n");
  1010.     if (toklist == NULL){
  1011.         (void)fprintf(list_fd,"\t(No list)");
  1012.     }
  1013.     else {
  1014.         t = toklist->tokenlist;
  1015.         while(t != NULL){
  1016.         ++numargs;
  1017.         (void)fprintf(list_fd," ");
  1018.         if ( is_true(ID_EXPR,t->TOK_flags) )
  1019.             (void)fprintf(list_fd,"%s ",token_name(*t));
  1020.         else
  1021.             (void)fprintf(list_fd,"%s ",
  1022.                   type_name[datatype_of(t->TOK_type)]);
  1023.         t = t->next_token;
  1024.         }
  1025.         if(numargs == 0)
  1026.             (void)fprintf(list_fd,"\t(Empty list)");
  1027.     }
  1028. }/* print_tokenlist */
  1029. #endif
  1030.  
  1031.  
  1032. PRIVATE int
  1033. #if HAVE_STDC
  1034. make_sym_list(Lsymtab **sym_list, int (*select) (Lsymtab *))
  1035. #else /* K&R style */
  1036. make_sym_list(sym_list,select)
  1037.      Lsymtab *sym_list[];
  1038.      PROTO(int (*select),( Lsymtab *sym_entry ));
  1039. #endif /* HAVE_STDC */
  1040. {
  1041.     int i;
  1042.     int n;
  1043.  
  1044.     for (i = 0, n = 0; i < loc_symtab_top; ++i)
  1045.     {
  1046.     if (select(&loc_symtab[i]))
  1047.         sym_list[n++] = &loc_symtab[i];
  1048.     }
  1049.     if (n > 0)
  1050.     {
  1051.     /* original PARAMETER statement order must be preserved so that
  1052.        the expressions do not refer to as-yet-undefined parameter names */
  1053.     if (select == select_parameters)
  1054.         sort_positions(sym_list,n);
  1055.     else
  1056.         sort_symbols(sym_list,n);
  1057.     }
  1058.     return (n);
  1059. }
  1060.  
  1061.  
  1062. PRIVATE void
  1063. #if HAVE_STDC
  1064. check_mixed_common(FILE *fd, Lsymtab **sym_list, int n)
  1065. #else /* K&R style */
  1066. check_mixed_common(fd,sym_list,n)
  1067.      FILE *fd;
  1068.      Lsymtab *sym_list[];
  1069.      int n;
  1070. #endif /* HAVE_STDC */
  1071. {
  1072.     int i;
  1073.     for(i=0; i<n; i++) {
  1074.     ComListHeader *chead = sym_list[i]->info.comlist;
  1075.     ComListElement *clist;
  1076.     char *mod_name;
  1077.     int j,nvars;
  1078.     int has_char=FALSE,has_nonchar=FALSE;
  1079.     int prev_size = 0;
  1080.       /* initialize to remove lint warning about use before definition */
  1081.     int this_size, this_type;
  1082.  
  1083.     if(chead == NULL)
  1084.       continue;
  1085.  
  1086.     mod_name = chead->module->name;
  1087.     clist=chead->com_list_array;
  1088.     nvars = chead->numargs;
  1089.  
  1090.     for(j=0; j<nvars; j++) {
  1091.  
  1092.        /* Check conformity to ANSI rule: no mixing char with other types */
  1093.  
  1094.       if( (this_type=datatype_of(clist[j].type)) == type_STRING) {
  1095.         has_char = TRUE;
  1096.         this_size = 1;/* char type size is 1 for alignment purposes */
  1097.       }
  1098.       else { /* other types use declared sizes */
  1099.         has_nonchar = TRUE;
  1100.         if( (this_size=clist[j].size) == size_DEFAULT)
  1101.           this_size = type_size[this_type];
  1102.       }
  1103.       if(has_char && has_nonchar) {
  1104.         if(f77_mixed_common){
  1105.           identify_module(mod_name);
  1106.           (void)fprintf(fd,
  1107.            "Common block %s line %u has mixed",
  1108.            sym_list[i]->name,
  1109.            chead->line_num);
  1110.           (void)fprintf(fd,
  1111.            "\n  character and non-character variables (nonstandard)");
  1112.         }
  1113.         break;
  1114.       }
  1115.  
  1116.     /* Check that variables are in descending order of type size */
  1117.  
  1118.      if(j > 0) {
  1119.       if( this_size > prev_size ) {
  1120.         if(port_common_alignment) {
  1121.           identify_module(mod_name);
  1122.           (void)fprintf(fd,
  1123.             "Common block %s line %u has long data type",
  1124.             sym_list[i]->name,
  1125.             chead->line_num);
  1126.           (void)fprintf(fd,
  1127.             "\n  following short data type (may not be portable)");
  1128.         }
  1129.         break;
  1130.       }
  1131.      }
  1132.      prev_size = this_size;
  1133.     }
  1134.     }
  1135. }
  1136.  
  1137.  
  1138. PRIVATE void
  1139. #if HAVE_STDC
  1140. check_flags(Lsymtab **list, int n, unsigned int used, unsigned int set, unsigned int ubs, char *msg, char *mod_name)
  1141. #else /* K&R style */
  1142. check_flags(list,n,used,set,ubs,msg,mod_name)
  1143.     Lsymtab *list[];
  1144.     int n;
  1145.     unsigned used,set,ubs;
  1146.     char *msg,*mod_name;
  1147. #endif /* HAVE_STDC */
  1148. {
  1149.     int matches=0,col=0,unused_args=0,i,len;
  1150.     unsigned pattern = flag_combo(used,set,ubs);
  1151.  
  1152.     for(i=0;i<n;i++) {
  1153.         if( list[i]->common_var )    /* common vars are immune */
  1154.            continue;
  1155.                 /* for args, do only 'never used' */
  1156.         if( list[i]->argument && pattern != flag_combo(0,0,0) )
  1157.            continue;
  1158.  
  1159. #ifdef ALLOW_INCLUDE
  1160.                 /* Skip variables 'declared but not used'
  1161.                    and parameters 'set but never used'
  1162.                    if defined in include file. */
  1163.  
  1164.         if( list[i]->defined_in_include &&
  1165.            ( pattern == flag_combo(0,0,0)
  1166.            || (list[i]->parameter && pattern == flag_combo(0,1,0)) ) )
  1167.         continue;
  1168. #endif
  1169.             /*  function return val: ignore 'set but never used' */
  1170.         if( list[i]->entry_point && pattern == flag_combo(0,1,0) )
  1171.         continue;
  1172.  
  1173.         if(flag_combo(list[i]->used_flag,list[i]->set_flag,
  1174.            list[i]->used_before_set) == pattern) {
  1175.          if(matches++ == 0) {
  1176.            identify_module(mod_name);
  1177.            (void)fprintf(list_fd,
  1178.                 "%s:\n",
  1179.                 msg);
  1180.          }
  1181.          len = strlen(list[i]->name);
  1182.          col += len = (len <= 10? 10: len) + 9;
  1183.          if(col > 78) {
  1184.            (void)fprintf(list_fd,"\n");
  1185.            col = len;
  1186.          }
  1187.          (void)fprintf(list_fd,"%10s",list[i]->name);
  1188.                 /* arg never used: tag with asterisk */
  1189.          (void)fprintf(list_fd,"%-9s",
  1190.              list[i]->argument? (++unused_args,"*") : "" );
  1191.         }
  1192.     }
  1193.     if(unused_args > 0)
  1194.         (void)fprintf(list_fd,"\n  * Dummy argument");
  1195.     if(matches > 0)
  1196.         (void)fprintf(list_fd,"\n");
  1197. }
  1198.  
  1199.  
  1200. void
  1201. debug_symtabs(VOID)     /* Debugging output: hashtable and symbol tables */
  1202. {
  1203. #ifdef DEBUG_SYMTABS
  1204.   if(debug_loc_symtab) {
  1205.     (void)fprintf(list_fd,"\n Debugging of local symbol table disabled");
  1206.     return;
  1207.   }
  1208.  
  1209.     if(debug_hashtab) {
  1210.     int i;
  1211.     (void)fprintf(list_fd,"\n\nContents of hashtable\n");
  1212.     for(i=0; i<HASHSZ; i++) {
  1213.         if(hashtab[i].name != NULL) {
  1214.           (void)fprintf(list_fd,"\n%4d %s",i,hashtab[i].name);
  1215.           if(hashtab[i].loc_symtab != NULL)
  1216.         (void)fprintf(list_fd," loc %d",hashtab[i].loc_symtab-loc_symtab);
  1217.           if(hashtab[i].glob_symtab != NULL)
  1218.         (void)fprintf(list_fd,
  1219.             " glob %d",hashtab[i].glob_symtab-glob_symtab);
  1220.           if(hashtab[i].com_loc_symtab != NULL)
  1221.         (void)fprintf(list_fd,
  1222.             " Cloc %d",hashtab[i].com_loc_symtab-loc_symtab);
  1223.           if(hashtab[i].com_glob_symtab != NULL)
  1224.         (void)fprintf(list_fd,
  1225.             " Cglob %d",hashtab[i].com_glob_symtab-glob_symtab);
  1226.         }
  1227.     }
  1228.     }
  1229.  
  1230.     if(debug_glob_symtab) {
  1231.     int i;
  1232.     (void)fprintf(list_fd,"\n\nContents of global symbol table");
  1233.  
  1234.     for(i=0; i<glob_symtab_top; i++) {
  1235.         (void)fprintf(list_fd,
  1236.         "\n%4d %s type 0x%x=%s,%s: ",
  1237.         i,
  1238.         glob_symtab[i].name,
  1239.         glob_symtab[i].type,
  1240.         class_name[storage_class_of(glob_symtab[i].type)],
  1241.         type_name[datatype_of(glob_symtab[i].type)]
  1242.          );
  1243.         (void)fprintf(list_fd,
  1244.       "usd%d set%d asg%d ubs%d lib%d int%d invf%d vis%d smw%d incl%d ext%d ",
  1245.         glob_symtab[i].used_flag,
  1246.         glob_symtab[i].set_flag,
  1247.         glob_symtab[i].assigned_flag,
  1248.         glob_symtab[i].used_before_set,
  1249.         glob_symtab[i].library_module,
  1250.         glob_symtab[i].internal_entry,
  1251.         glob_symtab[i].invoked_as_func,
  1252.         glob_symtab[i].visited,
  1253.         glob_symtab[i].visited_somewhere,
  1254.         glob_symtab[i].defined_in_include,
  1255.         glob_symtab[i].declared_external
  1256.             );
  1257.         switch(storage_class_of(glob_symtab[i].type)){
  1258.         case class_COMMON_BLOCK:{
  1259.             ComListHeader *clist;
  1260.             clist=glob_symtab[i].info.comlist;
  1261.             while(clist != NULL){
  1262.             print_com_array(clist);
  1263.             clist = clist->next;
  1264.             }
  1265.             break;
  1266.         }
  1267.         case class_SUBPROGRAM:{
  1268.             ArgListHeader *alist;
  1269.             alist=glob_symtab[i].info.arglist;
  1270.             while(alist != NULL){
  1271.             print_arg_array(alist);
  1272.             alist = alist->next;
  1273.             }
  1274.             break;
  1275.         }
  1276.         }
  1277.     }
  1278.     }
  1279. #endif
  1280. }/* debug_symtabs*/
  1281.  
  1282.  
  1283. /*----------------Additions for declaration file output----------------*/
  1284.  
  1285. /* Originally written by Nelson H.F. Beebe before source text was
  1286.    saved in the symbol table.  Rewritten by R. Moniot to make use
  1287.    of said text. */
  1288.  
  1289. /* Only make_declarations() is used by the above routines */
  1290.  
  1291.  
  1292. PROTO(PRIVATE char * get_dimension_list,( Lsymtab *symt ));
  1293. PROTO(PRIVATE char * get_parameter_value,( Lsymtab *symt ));
  1294. PROTO(PRIVATE char * get_size_expression,( Lsymtab *symt ));
  1295.  
  1296.  
  1297. #if 0            /* This is how Beebe wrote it */
  1298. #define ACTUAL_SIZE(p)        (((p)->size == 0) ? \
  1299.                  std_size[the_type] : (p)->size)
  1300. #else
  1301.         /* This is what it has to be if IMPLICIT types supported */
  1302. #define ACTUAL_SIZE(p)        (get_size((p),sym_type))
  1303. #endif
  1304.  
  1305. #define DCL_FLAGS_DECLARATIONS                0x0001
  1306. #define DCL_FLAGS_ONLY_UNDECLARED            0x0002
  1307. #define DCL_FLAGS_COMPACT                0x0004
  1308. #define DCL_FLAGS_USE_CONTINUATIONS            0x0008
  1309. #define DCL_FLAGS_KEYWORDS_LOWERCASE            0x0010
  1310. #define DCL_FLAGS_VARIABLES_AND_CONSTANTS_LOWERCASE    0x0020
  1311. #define DCL_FLAGS_EXCLUDE_SFTRAN3_INTERNAL_VARIABLES    0x0040
  1312. #define DCL_FLAGS_ASTERISK_COMMENT_CHARACTER        0x0080
  1313. #define DCL_FLAGS_LOWERCASE_COMMENT_CHARACTER        0x0100
  1314. #define DCL_NO_ARRAY_DIMENSIONS                0x0200
  1315. #define COLUMN_WIDTH        13
  1316. #define DECLARE_ONLY_UNDECLARED() (make_dcls & DCL_FLAGS_ONLY_UNDECLARED)
  1317. #define DECLARE_COMPACT()    (make_dcls & DCL_FLAGS_COMPACT)
  1318. #define NO_CONTINUATION_LINES() (!(make_dcls & DCL_FLAGS_USE_CONTINUATIONS))
  1319. #define SF3_DECLARATIONS()    \
  1320.         (make_dcls & DCL_FLAGS_EXCLUDE_SFTRAN3_INTERNAL_VARIABLES)
  1321. #define ASTERISK_COMMENT_CHAR()    \
  1322.         (make_dcls & DCL_FLAGS_ASTERISK_COMMENT_CHARACTER)
  1323. #define KEYWORDS_LOWERCASE()    (make_dcls & DCL_FLAGS_KEYWORDS_LOWERCASE)
  1324. #define LOWERCASE_COMMENT_CHARACTER() \
  1325.         (make_dcls & DCL_FLAGS_LOWERCASE_COMMENT_CHARACTER)
  1326. #define VARIABLES_AND_CONSTANTS_LOWERCASE() \
  1327.         (make_dcls & DCL_FLAGS_VARIABLES_AND_CONSTANTS_LOWERCASE)
  1328. #define ARRAY_VARS_DIMENSIONED() \
  1329.         (!(make_dcls & DCL_NO_ARRAY_DIMENSIONS))
  1330.  
  1331. #ifndef FIRST_VARIABLE_COLUMN
  1332. #define FIRST_VARIABLE_COLUMN    26      /* to match Extended PFORT Verifier */
  1333. #endif
  1334. #define NEXT_COLUMN(column)    (FIRST_VARIABLE_COLUMN + \
  1335.                 (((column) - FIRST_VARIABLE_COLUMN + \
  1336.                 COLUMN_WIDTH - 1) / COLUMN_WIDTH)*COLUMN_WIDTH)
  1337.  
  1338. #define isaletter(C)    isalpha((int)(C))
  1339.  
  1340.     /* define isidletter to allow underscore and/or dollar sign  */
  1341. #define isidletter(C)    (isalpha((int)(C)) || (C) == '_' || (C) == '$')
  1342.  
  1343.  
  1344. #define makelower(C) (isupper((int)(C)) ? tolower((int)(C)) : (int)(C))
  1345. #define makeupper(C) (islower((int)(C)) ? toupper((int)(C)) : (int)(C))
  1346.  
  1347. PRIVATE char *begin_module;
  1348.  
  1349. #define MAX_STMT        (72 + 19*72 + 1) /* longest Fortran stmt */
  1350.  
  1351. PRIVATE char stmt_fragment[MAX_STMT];
  1352.  
  1353. PRIVATE char comment_char = 'C'; /* default value */
  1354.  
  1355. PRIVATE int std_size[] =    /* NB: depends on type_XXX order in symtab.h */
  1356. {
  1357.     0,                    /* unknown */
  1358.     4,                    /* INTEGER*4 */
  1359.     4,                    /* REAL*4 */
  1360.     8,                    /* DOUBLE PRECISION == REAL*8 */
  1361.     8,                    /* COMPLEX*8 */
  1362.     16,                    /* DOUBLE COMPLEX == COMPLEX*16 */
  1363.     4,                    /* LOGICAL*4 */
  1364.     1                    /* CHARACTER*1 == CHARACTER */
  1365. };
  1366.  
  1367. PRIVATE int
  1368. pos_fragment = 0;        /* cursor in stmt_fragment buffer */
  1369.  
  1370.  
  1371. PRIVATE void
  1372. #if HAVE_STDC
  1373. append_char_to_fragment(int c)
  1374. #else /* K&R style */
  1375. append_char_to_fragment(c)
  1376. int c;
  1377. #endif /* HAVE_STDC */
  1378. {
  1379.     if (pos_fragment < (MAX_STMT - 1))
  1380.     stmt_fragment[pos_fragment++] = c;
  1381. }
  1382.  
  1383.  
  1384. PRIVATE void
  1385. #if HAVE_STDC
  1386. append_string_to_fragment(char *s)
  1387. #else /* K&R style */
  1388. append_string_to_fragment(s)
  1389. char *s;
  1390. #endif /* HAVE_STDC */
  1391. {
  1392.     while (*s)
  1393.     append_char_to_fragment(*s++);
  1394. }
  1395.  
  1396.             /* Appends source text of an expression, up- or
  1397.                down-casing the letters according to pref. */
  1398. PRIVATE void
  1399. #if HAVE_STDC
  1400. append_expr_text_to_fragment(char *s)
  1401. #else /* K&R style */
  1402. append_expr_text_to_fragment(s)
  1403.   char *s;
  1404. #endif /* HAVE_STDC */
  1405. {
  1406.     int quote_char, inside_quote;
  1407.     inside_quote = FALSE;
  1408.     for (; *s; ++s) {
  1409.       if(! inside_quote) {
  1410.     if(*s == '\'' || *s == '"') { /* Start of a quote */
  1411.       inside_quote = TRUE;
  1412.       quote_char = *s;
  1413.     }
  1414.     append_char_to_fragment(VARIABLES_AND_CONSTANTS_LOWERCASE()
  1415.                 ? makelower(*s) : makeupper(*s));
  1416.       }
  1417.       else {            /* inside quote */
  1418.     if(*s == quote_char) { /* End of quote (quoted quote_char is handled
  1419.                   as if consecutive strings) */
  1420.       inside_quote=FALSE;
  1421.     }
  1422.     append_char_to_fragment(*s);
  1423.       }
  1424.     }
  1425. }
  1426.  
  1427.  
  1428. PRIVATE char *
  1429. #if HAVE_STDC
  1430. get_dimension_list(Lsymtab *symt)
  1431. #else /* K&R style */
  1432. get_dimension_list(symt)
  1433.      Lsymtab *symt;
  1434. #endif /* HAVE_STDC */
  1435. {
  1436.     int n, dims;
  1437.  
  1438.         /* Get list of array dimensions from symbol table */
  1439.  
  1440.     new_fragment();
  1441.  
  1442.     append_char_to_fragment('(');
  1443.  
  1444.     dims = array_dims(symt->info.array_dim);
  1445.     for (n = 0; n < dims; ++n)
  1446.     {
  1447.     if (n > 0)
  1448.         append_char_to_fragment(',');
  1449.     append_expr_text_to_fragment(symt->src.textvec[n]);
  1450.     }
  1451.  
  1452.     append_char_to_fragment(')');
  1453.     append_char_to_fragment('\0');
  1454.  
  1455.     return (&stmt_fragment[0]);
  1456. }
  1457.  
  1458.  
  1459.  
  1460.  
  1461. PRIVATE char *
  1462. #if HAVE_STDC
  1463. get_parameter_value(Lsymtab *symt)
  1464. #else /* K&R style */
  1465. get_parameter_value(symt)
  1466.      Lsymtab *symt;
  1467. #endif /* HAVE_STDC */
  1468. {
  1469.     /* Construct parameter list "(NAME = value)" */
  1470.  
  1471.     new_fragment();
  1472.     append_char_to_fragment('(');
  1473.  
  1474.     append_expr_text_to_fragment(symt->name);
  1475.  
  1476.     append_string_to_fragment(" = ");
  1477.  
  1478.     append_expr_text_to_fragment(symt->info.param->src_text);
  1479.  
  1480.     append_char_to_fragment(')');
  1481.     append_char_to_fragment('\0');
  1482.     return (&stmt_fragment[0]);
  1483. }
  1484.  
  1485.  
  1486.  
  1487. PRIVATE char *
  1488. #if HAVE_STDC
  1489. get_size_expression(Lsymtab *symt)
  1490. #else /* K&R style */
  1491. get_size_expression(symt)
  1492.      Lsymtab *symt;
  1493. #endif /* HAVE_STDC */
  1494. {
  1495.     /* Get a CHARACTER size expression from the symbol table */
  1496.  
  1497.     new_fragment();
  1498.  
  1499.     append_char_to_fragment('*');
  1500.  
  1501.     append_expr_text_to_fragment(get_size_text(symt,0));
  1502.  
  1503.     append_char_to_fragment('\0');
  1504.  
  1505.     return (&stmt_fragment[0]);
  1506. }
  1507.  
  1508. PRIVATE void
  1509. #if HAVE_STDC
  1510. make_declarations(Lsymtab **sym_list, char *mod_name)
  1511. #else /* K&R style */
  1512. make_declarations(sym_list,mod_name)
  1513.      Lsymtab *sym_list[];
  1514.      char *mod_name;
  1515. #endif /* HAVE_STDC */
  1516. {
  1517.     char *header;
  1518.     char begin[72+1+2+1];
  1519.     int len_current_filename = strlen(current_filename);
  1520.  
  1521.     if (!make_dcls)
  1522.     return;
  1523.  
  1524.     make_dcls |= DCL_FLAGS_DECLARATIONS; /* any non-zero value selects */
  1525.  
  1526.     if (LOWERCASE_COMMENT_CHARACTER())
  1527.     comment_char = 'c';
  1528.     else if (ASTERISK_COMMENT_CHAR())
  1529.     comment_char = '*';
  1530.     else
  1531.     comment_char = 'C';
  1532.  
  1533.  
  1534.     /* In the event there are no declarations to be output, we want
  1535.        the declaration file to be empty, because that reduces the
  1536.        number of files that the user has to deal with.  In fact, if it
  1537.        IS empty, it will be deleted on close.  Instead of printing the
  1538.        module header comment here, we point a global pointer at it,
  1539.        and then in the print_xxx() functions, print the header before
  1540.        the first declaration that is output.
  1541.  
  1542.        We also need to take care not be overwrite the begin[] array,
  1543.        which could happen if the module name or file name are
  1544.        exceptionally long.  We therefore take at most 8 characters
  1545.        from the start of the module name, and at most 12 (because 12 =
  1546.        8 + 1 + 3 for IBM PC DOS), from the END of the filename,
  1547.        discarding a long directory path prefix if necessary. */
  1548.  
  1549.  
  1550.     (void)sprintf(begin,
  1551.           "%c====>Begin Module %-8s   File %-12s   %s\n%c\n",
  1552.           comment_char,
  1553.           mod_name,
  1554.           (len_current_filename > 12) ?
  1555.             (current_filename + len_current_filename - 12) :
  1556.             current_filename,
  1557.           DECLARE_ONLY_UNDECLARED() ?
  1558.             "Undeclared variables" : "All variables",
  1559.           comment_char);
  1560.     begin_module = &begin[0];
  1561.  
  1562.     print_selected_declarations(sym_list,
  1563.                 make_sym_list(sym_list,
  1564.                           select_intrinsics_by_name),
  1565.                 type_ERROR, "INTRINSIC",
  1566.                 (header = "Intrinsic functions", &header));
  1567.     print_declaration_class(sym_list,
  1568.                 make_sym_list(sym_list,select_intrinsics_by_type),
  1569.                 "Built-in functions");
  1570.  
  1571.     print_selected_declarations(sym_list,
  1572.                 make_sym_list(sym_list,
  1573.                           select_externals_by_name),
  1574.                 type_ERROR, "EXTERNAL",
  1575.                 (header = "External functions", &header));
  1576.     print_declaration_class(sym_list,
  1577.                 make_sym_list(sym_list,select_externals_by_type),
  1578.                 (char*)NULL);
  1579.  
  1580.     print_declaration_class(sym_list,
  1581.                 make_sym_list(sym_list,select_statement_functions),
  1582.                 "Statement functions");
  1583.  
  1584.     print_declaration_class(sym_list,
  1585.                 make_sym_list(sym_list,select_parameters),
  1586.                 "Parameter variables");
  1587.  
  1588.     print_declaration_class(sym_list,
  1589.                 make_sym_list(sym_list,select_arguments),
  1590.                 "Argument variables");
  1591.  
  1592.     print_declaration_class(sym_list,
  1593.                 make_sym_list(sym_list,select_locals),
  1594.                 "Local variables");
  1595.  
  1596.     print_list_decls(sym_list,
  1597.                 make_sym_list(sym_list,select_common_blocks),
  1598.                 "Common blocks","COMMON");
  1599.  
  1600.     print_list_decls(sym_list,
  1601.                 make_sym_list(sym_list,select_namelists),
  1602.                 "Namelists","NAMELIST");
  1603.  
  1604.     if (begin_module == (char*)NULL) /* then need a trailer comment */
  1605.     (void)fprintf(dcl_fd,
  1606.               "%c====>End Module   %-8s   File %-12s\n",
  1607.               comment_char,
  1608.               mod_name,
  1609.               (len_current_filename > 12) ?
  1610.                 (current_filename + len_current_filename - 12) :
  1611.                 current_filename);
  1612.  
  1613. }
  1614.  
  1615.  
  1616.  
  1617. PRIVATE void
  1618. maybe_print_module_header(VOID)
  1619. {
  1620.     if (begin_module != (char*)NULL)
  1621.     {        /* print module header comment only once */
  1622.     (void)fputs(begin_module, dcl_fd);
  1623.     begin_module = (char*)NULL;
  1624.     }
  1625. }
  1626.  
  1627.  
  1628.  
  1629. PRIVATE void
  1630. new_fragment(VOID)
  1631. {
  1632.     pos_fragment = 0;
  1633. }
  1634.  
  1635.  
  1636.  
  1637. PRIVATE void
  1638. #if HAVE_STDC
  1639. print_blanks(int nblanks)
  1640. #else /* K&R style */
  1641. print_blanks(nblanks)
  1642. int    nblanks;
  1643. #endif /* HAVE_STDC */
  1644. {
  1645.     for ( ; nblanks > 0; --nblanks)
  1646.     (void)putc(' ',dcl_fd);
  1647. }
  1648.  
  1649.                 /* Routine to print namelist and
  1650.                    common declarations. */
  1651.  
  1652. PRIVATE void
  1653. #if HAVE_STDC
  1654. print_common_decls(Lsymtab *sym_entry)
  1655.                             /* COMMON block symbol table entry */
  1656. #else /* K&R style */
  1657. print_common_decls(sym_entry)
  1658.      Lsymtab *sym_entry;    /* COMMON block symbol table entry */
  1659. #endif /* HAVE_STDC */
  1660. {
  1661.     int h;
  1662.     int n;
  1663.     Token *t;
  1664.  
  1665. #ifdef DYNAMIC_TABLES        /* tables will be mallocked at runtime */
  1666.     static Lsymtab **sym_list=(Lsymtab **)NULL;
  1667.  
  1668.     if(sym_list == (Lsymtab **)NULL) { /* Initialize if not done before */
  1669.       if( (sym_list=(Lsymtab **)calloc(LOCSYMTABSZ,sizeof(Lsymtab *)))
  1670.      == (Lsymtab **)NULL) {
  1671.       oops_message(OOPS_FATAL,NO_LINE_NUM,NO_COL_NUM,
  1672.                "Cannot malloc space for local symbol list");
  1673.       }
  1674.     }
  1675. #else
  1676.     Lsymtab *sym_list[LOCSYMTABSZ]; /* temp. list of symtab entries to print */
  1677. #endif
  1678.  
  1679.     for (n = 0, t = sym_entry->src.toklist->tokenlist;
  1680.      t != NULL;
  1681.      t = t->next_token)
  1682.       {
  1683.     h = t->value.integer;
  1684.     sym_list[n++] = hashtab[h].loc_symtab;
  1685.       }
  1686.  
  1687.     if (n > 0)
  1688.     {
  1689.     sort_symbols(sym_list,n);
  1690.     print_declaration_class(sym_list, n, "Common variables");
  1691.     }
  1692. }
  1693.  
  1694.  
  1695. PRIVATE void
  1696. print_empty_comment_line(VOID)
  1697. {
  1698.     (void)putc(comment_char,dcl_fd);
  1699.     (void)putc('\n',dcl_fd);
  1700. }
  1701.  
  1702.  
  1703. PRIVATE void
  1704. #if HAVE_STDC
  1705. print_equivalence_decls(Lsymtab *sym_entry)
  1706.                             /* COMMON block symbol table entry */
  1707. #else /* K&R style */
  1708. print_equivalence_decls(sym_entry)
  1709.      Lsymtab *sym_entry;    /* COMMON block symbol table entry */
  1710. #endif /* HAVE_STDC */
  1711. {
  1712.     int h;
  1713.     int n;
  1714.     Lsymtab *s;
  1715.     Token *t;
  1716.  
  1717. #ifdef DYNAMIC_TABLES        /* tables will be mallocked at runtime */
  1718.     static Lsymtab **sym_list=(Lsymtab **)NULL;
  1719.  
  1720.     if(sym_list == (Lsymtab **)NULL) { /* Initialize if not done before */
  1721.       if( (sym_list=(Lsymtab **)calloc(LOCSYMTABSZ,sizeof(Lsymtab *)))
  1722.      == (Lsymtab **)NULL) {
  1723.       oops_message(OOPS_FATAL,NO_LINE_NUM,NO_COL_NUM,
  1724.                "Cannot malloc space for local symbol list");
  1725.       }
  1726.     }
  1727. #else
  1728.     Lsymtab *sym_list[LOCSYMTABSZ]; /* temp. list of symtab entries to print */
  1729. #endif
  1730.  
  1731.     for (n = 0, t = sym_entry->src.toklist->tokenlist;
  1732.      t != NULL;
  1733.      t = t->next_token)
  1734.     {
  1735.     h = t->value.integer;
  1736.     for (s = hashtab[h].loc_symtab, s = s->equiv_link;
  1737.          (s != NULL) && (s != hashtab[h].loc_symtab);
  1738.          s = s->equiv_link)
  1739.         sym_list[n++] = s;
  1740.     }
  1741.  
  1742.     if (n > 0)
  1743.     {
  1744.     sort_symbols(sym_list,n);
  1745.     print_declaration_class(sym_list, n,
  1746.                 "Equivalenced common variables");
  1747.     }
  1748. }
  1749.  
  1750.  
  1751. PRIVATE int
  1752. #if HAVE_STDC
  1753. count_undeclared_variables(Lsymtab *sym_entry)
  1754. #else /* K&R style */
  1755. count_undeclared_variables(sym_entry)
  1756.      Lsymtab *sym_entry;
  1757. #endif /* HAVE_STDC */
  1758. {
  1759.     int count, h;
  1760.     Token *t;
  1761.     Lsymtab *symt;
  1762.  
  1763.     for (count = 0, t = sym_entry->src.toklist->tokenlist;
  1764.      t != NULL;
  1765.      t = t->next_token)
  1766.     {            /* Loop over members */
  1767.     h = t->value.integer;
  1768.     symt = hashtab[h].loc_symtab;
  1769.     if (datatype_of(symt->type) == type_UNDECL)
  1770.         count++;
  1771.     }
  1772.     return (count);
  1773. }
  1774.  
  1775.  
  1776. PRIVATE void
  1777. #if HAVE_STDC
  1778. print_list_decls(Lsymtab **sym_list, int n, char *header, char *list_type_name)
  1779. #else /* K&R style */
  1780. print_list_decls(sym_list, n, header, list_type_name)
  1781.      Lsymtab *sym_list[];
  1782.      int n;
  1783.      char *header;
  1784.      char *list_type_name;
  1785. #endif /* HAVE_STDC */
  1786. {
  1787.     int i, nd;
  1788.  
  1789.     if (DECLARE_ONLY_UNDECLARED() &&
  1790.     (strcmp(list_type_name,"NAMELIST") == 0)) /* These lists are always declared */
  1791.       return;
  1792.  
  1793.     nd = 0;
  1794.     for (i=0; i<n; i++)
  1795.     {                    /* Loop over COMMON or NAMELIST lists */
  1796.     if (sym_list[i]->src.toklist != NULL)
  1797.     {
  1798.         if (strcmp(list_type_name,"COMMON") == 0)
  1799.         {                /* then COMMON list */
  1800.         if (!DECLARE_ONLY_UNDECLARED() ||
  1801.             (DECLARE_ONLY_UNDECLARED() &&
  1802.              (count_undeclared_variables(sym_list[i]) > 0)))
  1803.         {
  1804.             print_common_decls(sym_list[i]);
  1805.             if (!DECLARE_ONLY_UNDECLARED())
  1806.                 print_one_list_decls(sym_list[i], list_type_name,
  1807.                          &header, &nd);
  1808.             print_equivalence_decls(sym_list[i]);
  1809.         }
  1810.         }
  1811.         else            /* must be NAMELIST list */
  1812.             print_one_list_decls(sym_list[i], list_type_name, &header, &nd);
  1813.     }
  1814.     }
  1815.  
  1816.     if ((nd > 0) && (strcmp(list_type_name,"COMMON") != 0))
  1817.     print_empty_comment_line();
  1818. }
  1819.                 /* routine to print COMMON or NAMELIST
  1820.                    name between slashes. */
  1821. PRIVATE int
  1822. #if HAVE_STDC
  1823. print_list_name(char *list_type_name, char *name)
  1824. #else /* K&R style */
  1825. print_list_name(list_type_name,name)
  1826.   char *list_type_name;
  1827.   char *name;
  1828. #endif /* HAVE_STDC */
  1829. {
  1830.     int column, len;
  1831.     char *p;
  1832.  
  1833.     maybe_print_module_header();
  1834.  
  1835.                 /* Compact mode:   COMMON /blknam/
  1836.                    Padded mode:    COMMON / blknam /
  1837.                  */
  1838.     print_blanks(6);
  1839.     column = 6;
  1840.  
  1841.     for (p = list_type_name; *p; ++p, ++column)
  1842.     (void)putc(KEYWORDS_LOWERCASE() ? makelower(*p) : makeupper(*p),
  1843.            dcl_fd);
  1844.  
  1845.     print_blanks(1);
  1846.     column++;
  1847.  
  1848.     (void)putc('/',dcl_fd);
  1849.     column++;
  1850.  
  1851.     if (!DECLARE_COMPACT())
  1852.       {
  1853.     print_blanks(1);
  1854.     column++;
  1855.       }
  1856.     len = 0;
  1857.     if (strcmp(name,blank_com_name) != 0) {
  1858.       for (p=name; *p; ++p, ++len)
  1859.     (void)putc(VARIABLES_AND_CONSTANTS_LOWERCASE() ?
  1860.            makelower(*p) : makeupper(*p),dcl_fd);
  1861.     }
  1862.     column += len;
  1863.     if (!DECLARE_COMPACT())
  1864.       {
  1865.     if (len <= 6)        /* Max standard length */
  1866.       {
  1867.         print_blanks(7-len); /* Print padding */
  1868.         column += 7-len;
  1869.       }
  1870.       }
  1871.  
  1872.     (void)putc('/',dcl_fd);
  1873.     column++;
  1874.  
  1875.     if (DECLARE_COMPACT())
  1876.     {
  1877.     print_blanks(1);
  1878.     column++;
  1879.     }
  1880.     else if (column < FIRST_VARIABLE_COLUMN)
  1881.     {
  1882.     print_blanks(FIRST_VARIABLE_COLUMN-column);
  1883.     column = FIRST_VARIABLE_COLUMN;
  1884.     }
  1885.     else  if (column == FIRST_VARIABLE_COLUMN)
  1886.     {
  1887.     print_blanks(1);
  1888.     column++;
  1889.     print_blanks(NEXT_COLUMN(column)-column);
  1890.     column = NEXT_COLUMN(column);
  1891.     }
  1892.     else
  1893.     {
  1894.     print_blanks(NEXT_COLUMN(column)-column);
  1895.     column = NEXT_COLUMN(column);
  1896.     }
  1897.     return column;
  1898. }
  1899.  
  1900.  
  1901. PRIVATE void
  1902. #if HAVE_STDC
  1903. print_declaration_class(Lsymtab **sym_list, int n, char *header)
  1904. #else /* K&R style */
  1905. print_declaration_class(sym_list, n, header)
  1906.      Lsymtab *sym_list[];
  1907.      int n;
  1908.      char *header;
  1909. #endif /* HAVE_STDC */
  1910. {
  1911.     int t;
  1912.     static int type_table[] =    /* table defining output declaration order */
  1913.     {            /* (alphabetical by type name) */
  1914.     type_STRING,
  1915.     type_COMPLEX,
  1916.     type_DCOMPLEX,
  1917.     type_DP,
  1918.     type_INTEGER,
  1919.     type_LOGICAL,
  1920.     type_REAL,
  1921.     };
  1922.  
  1923.     if (n > 0)
  1924.     {
  1925.     for (t = 0; t < sizeof(type_table)/sizeof(type_table[0]); ++t)
  1926.         print_selected_declarations(sym_list, n, type_table[t],
  1927.                     (char*)NULL, &header);
  1928.     }
  1929. }
  1930.  
  1931.  
  1932. PRIVATE void
  1933. #if HAVE_STDC
  1934. print_one_list_decls(Lsymtab *sym_entry, char *list_type_name, char **pheader, int *pnd)
  1935. #else /* K&R style */
  1936. print_one_list_decls(sym_entry, list_type_name, pheader, pnd)
  1937.      Lsymtab *sym_entry;
  1938.      char *list_type_name;
  1939.      char **pheader;
  1940.      int *pnd;
  1941. #endif /* HAVE_STDC */
  1942. {
  1943.     int column, need, next_column, nv;
  1944.     int ncontin;
  1945.     int h;
  1946.     Token *t;
  1947.     Lsymtab *symt;
  1948.     char *p;
  1949.  
  1950.     column = 0;
  1951.     ncontin = 0;        /* count of continuation lines */
  1952.     nv = 0;        /* count of variables in statement */
  1953.     for(t = sym_entry->src.toklist->tokenlist;
  1954.     t != NULL;
  1955.     t = t->next_token)
  1956.       {            /* Loop over members */
  1957.         h = t->value.integer;
  1958.         symt = hashtab[h].loc_symtab;
  1959.         if (column == 0)        /* at beginning of line, so */
  1960.           {            /* we need a type name */
  1961.             maybe_print_module_header();
  1962.             if ((*pheader != (char*)NULL) &&
  1963.                 (strcmp(list_type_name,"COMMON") != 0))
  1964.               {                /* print header only once */
  1965.                 (void)fprintf(dcl_fd,"%c     %s\n", comment_char,*pheader);
  1966.                 print_empty_comment_line();
  1967.                 *pheader = (char*)NULL; /* so we don't print it again */
  1968.               }
  1969.             column = print_list_name(list_type_name,sym_entry->name);
  1970.             nv = 0;        /* no variables yet in statement */
  1971.             ncontin = 0;
  1972.             ++(*pnd);            /* count declarations produced */
  1973.           }
  1974.         if (DECLARE_COMPACT())
  1975.           next_column = (nv==0?column:column + 2);
  1976.         else
  1977.           next_column = NEXT_COLUMN(nv==0?column:column + 2);
  1978.         need = (int)strlen(symt->name);
  1979.         if ((next_column + need) > 72)  /* then must start new line */
  1980.           {
  1981.             (void)putc('\n',dcl_fd);
  1982.             if (nv>0 && (strcmp(list_type_name,"COMMON") == 0) &&
  1983.                 (NO_CONTINUATION_LINES() || ncontin == 19))
  1984.               {
  1985.                 column = print_list_name(list_type_name,sym_entry->name);
  1986.                 nv = 0;    /* no variables yet in statement */
  1987.                 ncontin = 0;
  1988.               }
  1989.             else
  1990.               {
  1991.                 print_blanks(5);
  1992.                 (void)putc('x',dcl_fd);
  1993.                 column = 6;
  1994.                 if (DECLARE_COMPACT())
  1995.                   next_column = (nv==0?column:column + 2);
  1996.                 else
  1997.                   next_column = NEXT_COLUMN(nv==0?column:column + 2);
  1998.                 ++ncontin;
  1999.               }
  2000.           }
  2001.         if (nv > 0)        /* multiple variables */
  2002.           {
  2003.             (void)fputs(", ",dcl_fd);
  2004.             print_blanks(next_column - column - 2);
  2005.             column = next_column;
  2006.           }
  2007.         for (p = symt->name; *p; ++p)
  2008.           (void)putc(VARIABLES_AND_CONSTANTS_LOWERCASE() ?
  2009.                      makelower(*p) : makeupper(*p),dcl_fd);
  2010.  
  2011.         column += need;
  2012.         nv++;            /* count variables */
  2013.       }
  2014.     if ((nv > 0) && (strcmp(list_type_name,"COMMON") == 0))
  2015.       {
  2016.         if (column > 0)
  2017.               (void)putc('\n',dcl_fd);
  2018.           print_empty_comment_line();
  2019.           column = 0;
  2020.       }
  2021.     if (column > 0)
  2022.     (void)putc('\n',dcl_fd);
  2023. }
  2024.  
  2025.  
  2026. PRIVATE void
  2027. #if HAVE_STDC
  2028. print_parameter_statement(Lsymtab *symt)
  2029. #else /* K&R style */
  2030. print_parameter_statement(symt)
  2031.      Lsymtab *symt;
  2032. #endif /* HAVE_STDC */
  2033. {
  2034.     int column;
  2035.     int need;
  2036.     int i;
  2037.  
  2038.     column = print_type_name(type_ERROR,"PARAMETER",0,symt);
  2039.     need = strlen(get_parameter_value(symt));
  2040.     if ((column + need) > 72)    /* then too long to fit on current line */
  2041.     {
  2042.     (void)fputs("\n     x",dcl_fd);
  2043.     column = 6;
  2044.     if ((column + need) > 72)
  2045.     {    /* long parameter setting requires line break */
  2046.         for (i = 0; stmt_fragment[i]; ++i)
  2047.         {
  2048.         if (column == 72)
  2049.         {
  2050.             (void)fputs("\n     x",dcl_fd);
  2051.             column = 6;
  2052.         }
  2053.         (void)putc((int)stmt_fragment[i],dcl_fd);
  2054.         column++;
  2055.         }
  2056.     }
  2057.     else
  2058.         (void)fputs(stmt_fragment,dcl_fd);
  2059.     }
  2060.     else            /* fits on current line */
  2061.     (void)fputs(stmt_fragment,dcl_fd);
  2062.     (void)putc('\n',dcl_fd);
  2063. }
  2064.  
  2065.  
  2066. PRIVATE void
  2067. #if HAVE_STDC
  2068. print_selected_declarations(Lsymtab **sym_list, int n, int the_type, char *type_name, char **pheader)
  2069. #else /* K&R style */
  2070. print_selected_declarations(sym_list, n, the_type, type_name, pheader)
  2071.      Lsymtab *sym_list[];
  2072.      int n;
  2073.      int the_type;
  2074.      char *type_name;
  2075.      char **pheader;
  2076. #endif /* HAVE_STDC */
  2077. {
  2078.     int column, i, last_size, need, next_column, nt, nv, ncontin,
  2079.     raw_type, sym_type, sym_size;
  2080.     char *p;
  2081.  
  2082.     column = 0;
  2083.     last_size = 0;
  2084.     nt = 0;                /* count of type declaration stmts */
  2085.     nv = 0;                /* count of variables in statement */
  2086.     for (i = 0; i < n; ++i)
  2087.     {                /* loop over variables */
  2088.     raw_type = datatype_of(sym_list[i]->type);
  2089.     if (DECLARE_ONLY_UNDECLARED())
  2090.     {
  2091.         if (raw_type != type_UNDECL)
  2092.         continue; /* want declarations only for undeclared vars */
  2093.         if (sym_list[i]->external) /* and not for explicit EXTERNAL */
  2094.         continue;
  2095.         if (sym_list[i]->intrinsic) /* and not for explicit INTRINSIC */
  2096.         continue;
  2097.     }
  2098.     sym_type = (raw_type == type_UNDECL) ?
  2099.         get_type(sym_list[i]) : datatype_of(sym_list[i]->type);
  2100.  
  2101.     if ((the_type != type_ERROR) && (sym_type != the_type))
  2102.         continue;
  2103.  
  2104.     sym_size = ACTUAL_SIZE(sym_list[i]);
  2105.     if ((nv > 0) && (sym_size != last_size))
  2106.     {    /* have new length modifier, so must start new declaration */
  2107.         (void)putc('\n',dcl_fd);
  2108.         nt++;        /* count type declaration statements */
  2109.         column = 0;
  2110.         ncontin = 0;
  2111.         nv = 0;
  2112.     }
  2113.     if (column == 0)        /* at beginning of line, so */
  2114.     {                /* we need a type name */
  2115.         maybe_print_module_header();
  2116.         if (*pheader != (char*)NULL)
  2117.         {                /* print header only once */
  2118.         (void)fprintf(dcl_fd,"%c     %s\n",comment_char,*pheader);
  2119.         print_empty_comment_line();
  2120.         *pheader = (char*)NULL;    /* so we don't print it again */
  2121.         }
  2122.         column = print_type_name(the_type,type_name, sym_size,
  2123.                      sym_list[i]);
  2124.         last_size = sym_size;
  2125.         nv = 0;        /* no variables yet in statement */
  2126.         ncontin = 0;
  2127.     }
  2128.     if (DECLARE_COMPACT())
  2129.         next_column = (nv==0?column:column + 2);
  2130.     else
  2131.         next_column = NEXT_COLUMN(nv==0?column:column + 2);
  2132.     need = (int)strlen(sym_list[i]->name);
  2133.  
  2134.     if (sym_list[i]->array_var     /* leave space for "(...)" */
  2135.         && ARRAY_VARS_DIMENSIONED())
  2136.         need += strlen(get_dimension_list(sym_list[i]));
  2137.  
  2138.     if ((next_column + need) > 72)  /* then must start new declaration */
  2139.     {
  2140.         (void)putc('\n',dcl_fd);
  2141.         nt++;        /* count type declaration statements */
  2142.         if (nv>0 && (NO_CONTINUATION_LINES() || ncontin == 19))
  2143.           {
  2144.         column = print_type_name(the_type,type_name, sym_size,
  2145.                      sym_list[i]);
  2146.         ncontin = 0;
  2147.         nv = 0;        /* no variables yet in statement */
  2148.           }
  2149.         else
  2150.           {
  2151.         print_blanks(5);
  2152.         (void)putc('x',dcl_fd);
  2153.         column = 6;
  2154.         if (DECLARE_COMPACT())
  2155.           next_column = (nv==0?column:column + 2);
  2156.         else
  2157.           next_column = NEXT_COLUMN(nv==0?column:column + 2);
  2158.         ++ncontin;
  2159.           }
  2160.         last_size = sym_size;
  2161.     }
  2162.     if (nv > 0)        /* multiple variables */
  2163.     {
  2164.         (void)fputs(", ",dcl_fd);
  2165.         print_blanks(next_column - column - 2);
  2166.         column = next_column;
  2167.     }
  2168.     for (p = sym_list[i]->name; *p; ++p)
  2169.         (void)putc(VARIABLES_AND_CONSTANTS_LOWERCASE() ?
  2170.                makelower(*p) : makeupper(*p),dcl_fd);
  2171.     if (sym_list[i]->array_var
  2172.         && ARRAY_VARS_DIMENSIONED())
  2173.         (void)fputs(stmt_fragment,dcl_fd);
  2174.     column += need;
  2175.     nv++;            /* count variables */
  2176.     if (sym_list[i]->parameter)
  2177.     {
  2178.         (void)putc('\n',dcl_fd);
  2179.         print_parameter_statement(sym_list[i]);
  2180.         column = 0;
  2181.         nt++;
  2182.         nv = 0;
  2183.     }
  2184.     }
  2185.     if (column > 0)
  2186.     {
  2187.     (void)putc('\n',dcl_fd);
  2188.     nt++;            /* count type declaration statements */
  2189.     }
  2190.     if (nt > 0)
  2191.     print_empty_comment_line();
  2192. }
  2193.  
  2194.  
  2195. PRIVATE int
  2196. #if HAVE_STDC
  2197. print_type_name(int the_type, char *type_name, int the_size, Lsymtab *symt)
  2198.                         /* type_ERROR if type_name non-NULL */
  2199.                            /* non-NULL overrides type_table[] use */
  2200. #else /* K&R style */
  2201. print_type_name(the_type,type_name,the_size,symt)
  2202. int    the_type;        /* type_ERROR if type_name non-NULL */
  2203. char    *type_name;        /* non-NULL overrides type_table[] use */
  2204. int    the_size;
  2205. Lsymtab *symt;
  2206. #endif /* HAVE_STDC */
  2207. {                /* return value is last column printed */
  2208.     int column;
  2209.     char digits[sizeof("*18446744073709551616")]; /* big enough for 2^64 */
  2210.     char *p;
  2211.     char *size_expression;
  2212.  
  2213.     maybe_print_module_header();
  2214.     print_blanks(6);
  2215.     column = 6;
  2216.  
  2217.     for (p = (type_name == (char*)NULL) ? type_table[the_type] : type_name;
  2218.      *p; ++p, ++column)
  2219.     (void)putc(KEYWORDS_LOWERCASE() ? makelower(*p) : makeupper(*p),
  2220.            dcl_fd);
  2221.     if (symt != NULL) {
  2222.       if (((symt->size_is_adjustable && (the_type == type_STRING))) ||
  2223.       (the_size == size_ADJUSTABLE)) /* happens only for CHARACTER*(*) */
  2224.     {
  2225.         /* size_is_adjustable overrides the_size because def_parameter() */
  2226.         /* in symtab.c replaced size_ADJUSTABLE with actual size. */
  2227.         (void)fputs("*(*)",dcl_fd);
  2228.         column += 4;
  2229.     }
  2230.       else if (symt->size_is_expression && (the_type == type_STRING))
  2231.     {
  2232.         size_expression = get_size_expression(symt);
  2233.         (void)fputs(size_expression,dcl_fd);
  2234.         column += strlen(size_expression);
  2235.     }
  2236.       else if ((the_size > 0) &&
  2237.            (the_type != type_ERROR) &&
  2238.            (the_size != std_size[the_type]))
  2239.     {    /* supply length modifier for non-standard type sizes */
  2240.         (void)sprintf(digits,"*%d",the_size);
  2241.         (void)fputs(digits,dcl_fd);
  2242.         column += strlen(digits);
  2243.     }
  2244.     }
  2245.     if (DECLARE_COMPACT())
  2246.     {
  2247.     print_blanks(1);
  2248.     column++;
  2249.     }
  2250.     else if (column < FIRST_VARIABLE_COLUMN)
  2251.     {
  2252.     print_blanks(FIRST_VARIABLE_COLUMN-column);
  2253.     column = FIRST_VARIABLE_COLUMN;
  2254.     }
  2255.     else  if (column == FIRST_VARIABLE_COLUMN)
  2256.     {
  2257.     print_blanks(1);
  2258.     column++;
  2259.     print_blanks(NEXT_COLUMN(column)-column);
  2260.     column = NEXT_COLUMN(column);
  2261.     }
  2262.     else
  2263.     {
  2264.     print_blanks(NEXT_COLUMN(column)-column);
  2265.     column = NEXT_COLUMN(column);
  2266.     }
  2267.     return (column);
  2268. }
  2269.  
  2270.  
  2271. PRIVATE int
  2272. #if HAVE_STDC
  2273. select_arguments(Lsymtab *sym_entry)
  2274. #else /* K&R style */
  2275. select_arguments(sym_entry)
  2276.     Lsymtab *sym_entry;
  2277. #endif /* HAVE_STDC */
  2278. {
  2279.     /* return (symbol is a module argument) */
  2280.     if (sym_entry->declared_external ||
  2281.     sym_entry->invoked_as_func)
  2282.     return (0);
  2283.     else if (sym_entry->argument)
  2284.     return (1);
  2285.     else
  2286.     return (0);
  2287. }
  2288.  
  2289.  
  2290. PRIVATE int
  2291. #if HAVE_STDC
  2292. select_commons(Lsymtab *sym_entry)
  2293. #else /* K&R style */
  2294. select_commons(sym_entry)
  2295.     Lsymtab *sym_entry;
  2296. #endif /* HAVE_STDC */
  2297. {
  2298.     /* return (symbol is in a COMMON block) */
  2299.     if (sym_entry->common_var)
  2300.     return (1);
  2301.     else
  2302.     return (0);
  2303. }
  2304.  
  2305.  
  2306. PRIVATE int
  2307. #if HAVE_STDC
  2308. select_externals_by_name(Lsymtab *sym_entry)
  2309. #else /* K&R style */
  2310. select_externals_by_name(sym_entry)
  2311.     Lsymtab *sym_entry;
  2312. #endif /* HAVE_STDC */
  2313. {
  2314.     /* return (symbol is external and must appear in EXTERNAL declaration) */
  2315.  
  2316.     if (sym_entry->declared_intrinsic) /* must appear first, because symbols */
  2317.     return (0); /* can be both declared_intrinsic and declared_external*/
  2318.             /* ??? is this a bug in ftnchek 2.7 ??? */
  2319.     else if (storage_class_of(sym_entry->type) == class_STMT_FUNCTION)
  2320.     return (0);
  2321.     else if (sym_entry->declared_external)
  2322.     return (1);
  2323.     else if (sym_entry->declared_intrinsic || sym_entry->intrinsic)
  2324.     return (0);
  2325.     else if (sym_entry->invoked_as_func)
  2326.     return (1);
  2327.     else
  2328.     return (0);
  2329. }
  2330.  
  2331.  
  2332. PRIVATE int
  2333. #if HAVE_STDC
  2334. select_externals_by_type(Lsymtab *sym_entry)
  2335. #else /* K&R style */
  2336. select_externals_by_type(sym_entry)
  2337.     Lsymtab *sym_entry;
  2338. #endif /* HAVE_STDC */
  2339. {
  2340.     /* return (symbol is external and must appear in a type declaration) */
  2341.     if (storage_class_of(sym_entry->type) == class_STMT_FUNCTION)
  2342.     return (0);
  2343.     else if (sym_entry->declared_external)
  2344.     return (1);
  2345.     else if (sym_entry->declared_intrinsic)
  2346.     return (0);
  2347.     else if (sym_entry->intrinsic)
  2348.     {
  2349.     if (datatype_of(sym_entry->type) == type_UNDECL)
  2350.     {            /* user provided no type declaration */
  2351.         if ((sym_entry->info.intrins_info)->result_type == type_GENERIC)
  2352.         return (0);    /* generics CANNOT have explicit type */
  2353.         else
  2354.         return (1);    /* not generic, so has explicit type */
  2355.     }
  2356.     else            /* user supplied an explicit type */
  2357.         return (1);
  2358.     }
  2359.     else if (sym_entry->invoked_as_func)
  2360.     return (1);
  2361.     else
  2362.     return (0);
  2363. }
  2364.  
  2365.  
  2366. PRIVATE int
  2367. #if HAVE_STDC
  2368. select_intrinsics_by_name(Lsymtab *sym_entry)
  2369. #else /* K&R style */
  2370. select_intrinsics_by_name(sym_entry)
  2371.     Lsymtab *sym_entry;
  2372. #endif /* HAVE_STDC */
  2373. {
  2374.     /* return (symbol is intrinsic and must appear in INTRINSIC declaration) */
  2375.     if (sym_entry->declared_intrinsic)
  2376.     return (1);
  2377.     else
  2378.     return (0);
  2379. }
  2380.  
  2381.  
  2382. PRIVATE int
  2383. #if HAVE_STDC
  2384. select_intrinsics_by_type(Lsymtab *sym_entry)
  2385. #else /* K&R style */
  2386. select_intrinsics_by_type(sym_entry)
  2387.     Lsymtab *sym_entry;
  2388. #endif /* HAVE_STDC */
  2389. {
  2390.     /* return (symbol is intrinsic and must appear in a type declaration) */
  2391.     if (sym_entry->intrinsic &&
  2392.     ((sym_entry->info.intrins_info)->result_type == type_GENERIC))
  2393.     return (0);
  2394.     else
  2395.     return (select_intrinsics_by_name(sym_entry));
  2396. }
  2397.  
  2398.  
  2399. PRIVATE int
  2400. #if HAVE_STDC
  2401. select_locals(Lsymtab *sym_entry)
  2402. #else /* K&R style */
  2403. select_locals(sym_entry)
  2404.     Lsymtab *sym_entry;
  2405. #endif /* HAVE_STDC */
  2406. {
  2407.     /* return (symbol is a local variable) */
  2408.  
  2409.     if (SF3_DECLARATIONS() && sf3_internal_name(sym_entry))
  2410.     return (0);
  2411.     else if (sym_entry->argument ||
  2412.     sym_entry->common_var ||
  2413.     sym_entry->declared_external ||
  2414.     sym_entry->declared_intrinsic ||
  2415.     sym_entry->entry_point ||
  2416.     sym_entry->external ||
  2417.     sym_entry->intrinsic ||
  2418.     sym_entry->invoked_as_func ||
  2419.     sym_entry->parameter)
  2420.     return (0);
  2421.     else
  2422.     return (1);
  2423. }
  2424.  
  2425.  
  2426. PRIVATE int
  2427. #if HAVE_STDC
  2428. select_common_blocks(Lsymtab *sym_entry)
  2429. #else /* K&R style */
  2430. select_common_blocks(sym_entry)
  2431.     Lsymtab *sym_entry;
  2432. #endif /* HAVE_STDC */
  2433. {
  2434.     /* return (symbol is a COMMON block name) */
  2435.     if (storage_class_of(sym_entry->type) == class_COMMON_BLOCK)
  2436.     return (1);
  2437.     else
  2438.     return (0);
  2439. }
  2440.  
  2441. PRIVATE int
  2442. #if HAVE_STDC
  2443. select_namelists(Lsymtab *sym_entry)
  2444. #else /* K&R style */
  2445. select_namelists(sym_entry)
  2446.     Lsymtab *sym_entry;
  2447. #endif /* HAVE_STDC */
  2448. {
  2449.     /* return (symbol is a NAMELIST name) */
  2450.     if (storage_class_of(sym_entry->type) == class_NAMELIST)
  2451.     return (1);
  2452.     else
  2453.     return (0);
  2454. }
  2455.  
  2456. PRIVATE int
  2457. #if HAVE_STDC
  2458. select_parameters(Lsymtab *sym_entry)
  2459. #else /* K&R style */
  2460. select_parameters(sym_entry)
  2461.     Lsymtab *sym_entry;
  2462. #endif /* HAVE_STDC */
  2463. {
  2464.     /* return (symbol is a PARAMETER name) */
  2465.     if (sym_entry->parameter)
  2466.     return (1);
  2467.     else
  2468.     return (0);
  2469. }
  2470.  
  2471.  
  2472.  
  2473. PRIVATE int
  2474. #if HAVE_STDC
  2475. select_statement_functions(Lsymtab *sym_entry)
  2476. #else /* K&R style */
  2477. select_statement_functions(sym_entry)
  2478.      Lsymtab *sym_entry;
  2479. #endif /* HAVE_STDC */
  2480. {
  2481.     if (storage_class_of(sym_entry->type) == class_STMT_FUNCTION)
  2482.     return (1);
  2483.     else
  2484.     return (0);
  2485. }
  2486.  
  2487.  
  2488. PRIVATE int
  2489. #if HAVE_STDC
  2490. sf3_internal_name(Lsymtab *sym_entry)
  2491. #else /* K&R style */
  2492. sf3_internal_name(sym_entry)
  2493.      Lsymtab *sym_entry;
  2494. #endif /* HAVE_STDC */
  2495. {    /* Return (symbol is an SFTRAN3 internal name). */
  2496.     char *p = sym_entry->name;
  2497.  
  2498.     /* The SFTRAN3 preprocessor uses internal names of the form NPRddd,
  2499.        NXdddd, N2dddd, and N3dddd, where d is a decimal digit. */
  2500.  
  2501.     if ((p[0] != 'N') || (strlen(p) != 6))
  2502.     return (0);
  2503.     switch (p[1])
  2504.     {
  2505.     case 'P':
  2506.     if ((p[2] == 'R') && isdigit(p[3]) && isdigit(p[4]) && isdigit(p[5]))
  2507.         return (1);
  2508.     else
  2509.         return (0);
  2510.  
  2511.     case 'X':                   /* fall through */
  2512.     case '2':                   /* fall through */
  2513.     case '3':
  2514.     if (isdigit(p[2]) && isdigit(p[3]) && isdigit(p[4]) && isdigit(p[5]))
  2515.         return (1);
  2516.     else
  2517.         return (0);
  2518.  
  2519.     default:
  2520.     return (0);
  2521.     }
  2522. }
  2523.