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