/*  ftnchek.c:

	Main program for Fortran Syntax Checker.
*/

/*

Copyright (c) 1999 by Robert K. Moniot.

Permission is hereby granted, free of charge, to any person obtaining a
copy of this software and associated documentation files (the "Software"),
to deal in the Software without restriction, including without limitation
the rights to use, copy, modify, merge, publish, distribute, sublicense,
and/or sell copies of the Software, and to permit persons to whom the
Software is furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in
all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL
ROBERT K. MONIOT OR FORDHAM UNIVERSITY BE LIABLE FOR ANY CLAIM, DAMAGES OR
OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
OTHER DEALINGS IN THE SOFTWARE.

Except as contained in this notice, the name of ftnchek shall not be used
in advertising or otherwise to promote the sale, use or other dealings in
this Software without prior written authorization from the author.

*/



/*
	Top-level input/output is done here: opening and closing files,
	and printing error, warning, and informational messages.

	Shared functions defined:
		print_a_line()	Prints source code line.
		yyerror()	Error messages from yyparse and elsewhere.
		syntax_error()	Error messages with line and column num.
		warning()	Warning messages.
		nonportable()	Portability warnings.
		wrapup()	Look at cross references, etc.
*/

#include <stdio.h>
#include <string.h>
#include <ctype.h>
#ifdef DEVELOPMENT             /* For maintaining the program */
#define DEBUG_SIZES
#endif
#define MAIN
#include "ftnchek.h"

#ifdef VMS
#define unlink(s) remove(s)
#else
PROTO( int unlink,( const char *pathname ) );
#endif

typedef enum {		/* for isacheck fields.  Used to suppress -nocheck */
 NOT_A_CHECK, IS_A_CHECK
} isacheck_t;

				/* Define warn_option_list struct here */
typedef struct {
  char *name;
  int *flag;
  char *explanation;
} WarnOptionList;


typedef struct {
    char *name;			/* user knows the setting by this name */
    char **strvalue;		/* the string argument goes here */
    char *turnon, *turnoff;	/* e.g. "all", "none" */
    isacheck_t isacheck;	/* tells -nocheck to turn it off */
    WarnOptionList *option_list;/* this holds the set of options */
				/* For compatibility with -option=num form: */
    PROTO(void (*numeric_form_handler),(int num, char *setting_name));
    char *explanation;		/* for use by -help */
} StrsettingList;


PROTO( char * add_ext,( char *s, char *ext ));

PROTO(PRIVATE char * append_extension,( char *s, char *ext, int mode ));

PROTO(PRIVATE void append_include_path,( char *new_path ));

PROTO(PRIVATE int cistrncmp,( char *s1, char *s2, unsigned n ));

PROTO(PRIVATE void error_summary,( char *fname ));

PROTO(PRIVATE void error_message,( unsigned lineno, unsigned colno, char *s,
			   char *tag ));

PROTO(PRIVATE void get_env_options,( void ));

PROTO(PRIVATE void get_rc_options,( void ));

PROTO(PRIVATE FILE *find_rc,( void ));

PROTO( int has_extension,( char *name, char *ext ));

PROTO(PRIVATE void lintstyle_error_message,( unsigned lineno, unsigned colno,
				     char *s, char *tag ));

PROTO(PRIVATE void list_options,( FILE *fd ));

PROTO(PRIVATE void list_warn_options,(WarnOptionList warn_option[]));

PROTO(int main,( int argc, char *argv[] ));

PROTO(PRIVATE void make_env_name,( char *env_name, char *option_name ));

PROTO(PRIVATE char * new_ext,( char *s, char *ext ));

PROTO(PRIVATE void oldstyle_error_message,( unsigned lineno, unsigned colno,
				    char *s, char *tag ));

PROTO(PRIVATE void open_outfile,( char *s ));

PROTO(PRIVATE void do_preps,( void ));

#ifdef DEBUG_SIZES
PROTO(extern void print_sizeofs,( void ));	/* in symtab.c */
#endif

PROTO(PRIVATE void print_version_number,( void ));

PROTO(PRIVATE void process_warn_string,
 ( char *warn_string, WarnOptionList warn_option[] ));

PROTO(PRIVATE int str_to_num,(char *s));

PROTO(PRIVATE int read_setting,( char *s, int *setvalue, char *name, int
			 minlimit, int maxlimit, int turnoff, int
			 turnon, int min_default_value, int
			 max_default_value ));

PROTO(PRIVATE void resource_summary,( void ));

PROTO(PRIVATE void set_option,( char *s, char *where ));

PROTO(PRIVATE void set_warn_option,
 ( char *s, WarnOptionList warn_option[] ));

PROTO(PRIVATE void set_warn_option_value, ( int *flag, int value));

PROTO(PRIVATE void mutual_exclude, (  WarnOptionList wList[], char *opt_name,
		      int *thisflag, int *otherflags[] ));

PROTO(PRIVATE void argcheck_numeric_option, ( int value, char *setting_name ));

PROTO(PRIVATE void arraycheck_numeric_option, ( int value, char *setting_name ));

PROTO(PRIVATE void calltree_numeric_option, ( int value, char *setting_name ));

PROTO(PRIVATE void comcheck_numeric_option, ( int value, char *setting_name ));

PROTO(PRIVATE void intrinsic_numeric_option,( int value, char *setting_name ));

PROTO(PRIVATE void makedcl_numeric_option, ( int value, char *setting_name ));

PROTO(PRIVATE void source_numeric_option, ( int value, char *setting_name ));

PROTO(PRIVATE void usage_numeric_option, ( int value, char *setting_name ));

PROTO(PRIVATE void numeric_option_error,( char *s, int minlimit, int maxlimit ));

PROTO(PRIVATE int wildcard_match, (char *pat, char *str));

PROTO(PRIVATE void src_file_in,( char *infile ));

PROTO(PRIVATE void turn_off_checks,( void ));

PROTO(PRIVATE void update_str_options,( StrsettingList *strset ));

PROTO(PRIVATE void wrapup,( void ));



PRIVATE int project_file_input;	/* true if input is from .prj file */

#define full_output	(do_list || do_symtab)

PRIVATE unsigned long intrins_clashes;	
				/* count of intrinsic hashtable clashes */
#ifdef COUNT_REHASHES
extern unsigned long rehash_count; /* count of calls to rehash() */
#endif

	/* Here we define the commandline options.  Most options are boolean
	   switchopts, with "no" prefix to unset them.  Others (called
	   settings) are numeric quantities, defined using "=num".
	   A third category (strsettings) are string quantities, eg filenames.
	   The argument "?" will cause list of options to be printed out.
	   For VMS, options can be prefixed with either "-" or "/",
	   but messages will use the canonical form.  Since VMS allows
	   options to be smushed together, end-of-option is signalled by
	   either NUL or the / of next option.
	 */

#ifdef OPTION_PREFIX_SLASH
#define OPT_PREFIX '/'	/* Canonical VMS prefix for commandline options */
#define END_OF_OPT( C )  ((C) == '\0' || (C) == '/')
#else
#define OPT_PREFIX '-'	/* Canonical Unix prefix for commandline options */
#define END_OF_OPT( C )  ((C) == '\0')
#endif

#define OPT_MATCH_LEN 3	/* Options are matched only in 1st 3 chars */
#define NUM_SWITCHES (sizeof(switchopt)/sizeof(switchopt[0]))
#define NUM_SETTINGS (sizeof(setting)/sizeof(setting[0]))
#define NUM_STRSETTINGS (sizeof(strsetting)/sizeof(strsetting[0]))

/*	Adding new options:

	   New options with boolean (switchopt) or numeric (setting)
	   values can be added to the lists below by inserting a definition
	   using the same syntax as the others, and declaring the
	   controlled variable with a line in ftnchek.h of the form:
	   	OPT(type,name,default-value);
	   No other changes are needed.  (For boolean options, make
	   sure they precede "-debug" in order for them to appear in
	   the -help page.)

	   New options with string values (strsetting) are added
	   similarly, but they have option_list and numeric_form_handler
	   fields that must also be defined.  The strsettings come in
	   two flavors: those whose string value is used literally
	   (like -include) and those whose string value is a list of
	   sub-options (like -f77).  For the first type, just set the
	   option_list and numeric_form_handler fields to NULL.  For
	   the second type, create a new WarnOptionList following the
	   pattern of f77_warn_option.  This list must precede the
	   strsettings definition.  For each item in this list, a
	   corresponding variable must be declared with an OPT
	   statement in ftnchek.h.  Then insert the name of this list
	   into the option_list field of the strsetting entry.  The
	   numeric_form_handler field is used for strsettings that
	   used to take a numeric value and have been converted to the
	   option-list form.  See usage_numeric_handler for an example
	   of how these work.  This field is NULL if there is no
	   handler.  If there is a handler, put its prototype with the
	   others above, add the code at a suitable point in this
	   file, and put its name in the numeric_form_handler field of
	   the WarnOptionList.

*/


/* Option definitions: */

		/* List of switches is defined first.  Each entry gives the
		   name and the corresponding flag variable to be set
		   or cleared.  See set_option() for processing of switches.

		   N.B. list_options() will suppress printing of any options
		   whose explanation starts with "debug" unless the -debug
		   switch was previously given.
		 */
PRIVATE struct {
    char *name;			/* User knows it by this name */
    int *switchflag;		/* Pointer to variable that controls it */
    char *explanation;		/* For use by -help */
    isacheck_t isacheck;	/* Tells -nocheck to turn it off */
} switchopt[]={
	{"check",	&do_check,
		 "perform checking",IS_A_CHECK},
	{"crossref",	&print_xref_list,
		 "print call cross-reference list",IS_A_CHECK},
	{"declare",	&decls_required,
		 "list undeclared variables",IS_A_CHECK},
	{"division",	&div_check,
		 "catch possible div by 0",IS_A_CHECK},
	{"extern",	&usage_ext_undefined,
		 "check if externals defined",IS_A_CHECK},
	{"help",	&help_screen,
		 "print help screen",NOT_A_CHECK},
	{"library",	&library_mode,
		 "treat next files as library",NOT_A_CHECK},
#ifdef EOLSKIP
	{"linebreak",	&eol_is_space,
		 "treat linebreaks as space",NOT_A_CHECK},
#endif
	{"list",	&do_list,
		 "print program listing",IS_A_CHECK},
	{"novice",	&novice_help,
		 "extra help for novices",IS_A_CHECK},
	{"project",	&make_project_file,
		 "create project file",NOT_A_CHECK},
	{"pure",	&pure_functions,
		 "functions have no side effects",IS_A_CHECK},
	{"quiet",	&quiet,
		 "less verbose output",NOT_A_CHECK},
	{"reference",	&print_ref_list,
		 "print who-calls-who reference list",IS_A_CHECK},
	{"resources",	&show_resources,
		 "show info on resource usage",IS_A_CHECK},
	{"sixchar",	&sixclash,
		 "catch nonunique names",IS_A_CHECK},
	{"sort",	&print_topo_sort,
		 "prerequisite-order sort of modules",IS_A_CHECK},
	{"symtab",	&do_symtab,
		 "print symbol table info",IS_A_CHECK},
#ifdef VCG_SUPPORT
	{"vcg",		&print_vcg_list,
		 "print call graph in vcg format",IS_A_CHECK},
#endif
	{"version",	&print_version,
		 "print version number",NOT_A_CHECK},
	{"volatile",	&comcheck_volatile,
		 "assume volatile common blocks",IS_A_CHECK},

	{"debug",	&debug_latest,
		 "debug latest code",IS_A_CHECK},
	{"global",	&debug_glob_symtab,
		 "debug global symtab info",IS_A_CHECK},
	{"grammar",	&debug_parser,
		 "debug printout in parser",IS_A_CHECK},
	{"hashtable",	&debug_hashtab,
		 "debug printout of hashtable",IS_A_CHECK},
	{"local",	&debug_loc_symtab,
		 "debug local symtab info",IS_A_CHECK},
#ifdef DEBUG_FORLEX
	{"tokens",	&debug_lexer,
		 "debug printout in lexer",IS_A_CHECK},
#endif
	{"yydebug",	&yydebug,
		 "debug via yydebug",IS_A_CHECK},
};


		/* List of settings is defined here. Each entry gives
		   the name, the corresponding variable, the range
		   of permitted values, the value for turning it off,
		   the values to assign if below or above the limits rsptly,
		   whether it is a check to be turned off by -nocheck,
		   followed by brief explanation.
		   See set_option() for processing. */
PRIVATE struct {
    char *name;
    int *setvalue;
    int minlimit,maxlimit,turnoff,turnon,min_default_value,max_default_value;
    isacheck_t isacheck;
    char *explanation;
} setting[]={
  {"columns",	&max_stmt_col,  72, MAXLINE, 72, MAXLINE, 72, MAXLINE, NOT_A_CHECK,
			"max line length processed"},
  {"errors",&error_cascade_limit, 0, 999, 0, DEF_ERROR_CASCADE_LIMIT, 0, 999, NOT_A_CHECK,
			"max number of error messages per cascade"},
  {"pointersize",&given_ptrsize, 1, 16, PTRSIZE, PTRSIZE, 1, 16, NOT_A_CHECK,
			"standard pointer size in bytes"},
  {"wordsize",	&given_wordsize, 0, 16, 0, BpW, 0, 16, NOT_A_CHECK,
			"standard wordsize in bytes (0=no default)"},
  {"wrap",	&wrap_column, 0, 999, 0, WRAP_COLUMN, 0, 999, NOT_A_CHECK,
			"width of page to wrap error messages"},
};


		/* Now we define the various "warn list" options.
		   Each entry in the array has the name of the
		   sub-option, the address of the flag variable it
		   controls, and an explanation used when printing the
		   help page for the option.

		   Each list must be alphabetized or at least options with
		   matching prefix strings must be adjacent.  When a
		   new option list is defined, it must also be entered
		   into strsetting array below.
		*/
PRIVATE WarnOptionList
 argcheck_warn_option[]={
  {
#if ARGCHECK_ALL
   "all"	 /* used by -help */
#else
   "none"
#endif
     , (int *)NULL,"Function Argument Mismatch Warning"},/* Title for list */
  {"arrayness",		&argcheck_arrayness,
				"argument arrayness mismatch"},
  {"type",		&argcheck_argtype,
				"argument type mismatch"},
  {"function-type",	&argcheck_functype,
				"function type mismatch"},
  {"number",		&argcheck_argnumber,
				"wrong number of arguments"},
  {(char *)NULL, (int *)NULL, (char *)NULL},
};

PRIVATE WarnOptionList
 arraycheck_warn_option[]={
  {
#if ARRAYCHECK_ALL
   "all"	 /* used by -help */
#else
   "none"
#endif
     , (int *)NULL,"Argument Arrayness Mismatch Warning"},/* Title for list */
  {"dimensions",	&arraycheck_dims,
				"different number of dimensions"},
  {"size",		&arraycheck_size,
				"different number of elements"},
  {(char *)NULL, (int *)NULL, (char *)NULL},
};

PRIVATE WarnOptionList
 calltree_option[]={	/* not really a warning */
  {
   "none"	 /* used by -help */
     , (int *)NULL,"Call-Tree Output"},/* Title for list */
  {"prune",		&call_tree_prune,
				"prune repeated subtrees"},
  {"reference",		&print_ref_list,
				"produce call tree in who-calls-who format"},
  {"sort",		&call_tree_sort,
				"sort call tree alphabetically"},
  {"tree",		&print_call_tree,
				"produce call tree in text format"},
#ifdef VCG_SUPPORT
  {"vcg",		&print_vcg_list,
				"produce call tree in vcg format"},
#endif
  {(char *)NULL, (int *)NULL, (char *)NULL},
};

PRIVATE WarnOptionList
 comcheck_warn_option[]={
  {
#if COMCHECK_ALL
   "dimensions,exact,length,type"	 /* used by -help */
#else
   "none"
#endif
     , (int *)NULL,"Common Block Mismatch Warning"},/* Title for list */
  {"dimensions",	&comcheck_dims,
				"arrays differ in dimensions"},
  {"exact",		&comcheck_by_name,
				"require variable-by-variable correspondence"},
  {"length",		&comcheck_length,
				"blocKs differ in total length"},
  {"type",		&comcheck_type,
				"data type mismatch at corresponding locations"},
  {"volatile",		&comcheck_volatile,
				"assume blocks are volatile"},
  {(char *)NULL, (int *)NULL, (char *)NULL},
};

		/* Here define list of -f77 warning options.  These are set
		   or cleared by -[no]f77=list option.  Note that the variables
		   are FALSE if feature is ALLOWED, and TRUE if feature is
		   to be WARNED about.
		 */
PRIVATE WarnOptionList
 f77_warn_option[]={
  {
#if F77_ALL
   "all"	 /* used by -help */
#else
   "none"
#endif
     , (int *)NULL,		"Fortran 77 Warning"},	/* Title for list */
  {"accept-type",	&f77_accept_type,
				"ACCEPT and TYPE I/O statements"},
  {"array-bounds",	&f77_array_bounds,
				"array bounds expressions"},
  {"assignment-stmt",	&f77_assignment,
				"assignment involving array"},
  {"automatic-array",	&f77_automatic_array,
				"local array of variable size"},
  {"backslash",		&f77_unix_backslash,
				"Unix backslash escape in strings"},
  {"byte",		&f77_byte,
				"BYTE data type"},
  {"common-subprog-name",&f77_common_subprog_name,
				"Common block & subprog with same name"},
  {"construct-name",	&f77_construct_name,
				"Construct names on DO statements"},
  {"continuation",	&f77_20_continue,
				"More than 19 continuation lines"},
  {"cpp",		&f77_unix_cpp,
				"Unix C preprocessor directives"},
  {"cycle-exit",	&f77_cycle_exit,
				"CYCLE or EXIT statement"},
  {"d-comment",		&f77_d_comment,
				"Debug comments starting with D"},
  {"dec-tab"	,	&f77_dec_tabs,
				"DEC Fortran tab-formatted source"},
  {"do-enddo",		&f77_do_enddo,
				"DO loop extensions"},
  {"double-complex",	&f77_double_complex,
				"Double complex datatype"},
  {"format-dollarsign",	&f77_format_dollarsigns,
				"$ control code in FORMAT"},
  {"format-edit-descr",	&f77_format_extensions,
				"Nonstandard edit descriptors"},
  {"function-noparen",	&f77_function_noparen,
				"FUNCTION defined without parens"},
  {"implicit-none",	&f77_implicit_none,
				"IMPLICIT NONE statement"},
  {"include",		&f77_include,
				"INCLUDE statement"},
  {"inline-comment",	&f77_inline_comment,
				"Inline comments starting with !"},
  {"internal-list-io",	&f77_internal_list_io,
				"List-directed I/O to internal file"},
  {"intrinsic",		&f77_intrinsics,
				"Nonstandard intrinsic functions"},
  {"io-keywords",	&f77_io_keywords,
				"Nonstandard I/O keywords"},
  {"long-line",		&f77_overlength,
				"Statements with code past 72 columns"},
  {"long-name",		&f77_long_names,
				"Identifiers over 6 chars"},
  {"mixed-common",	&f77_mixed_common,
				"Mixed char and nonchar data in common"},
  {"mixed-expr",	&f77_mixed_expr,
				"Incompatible type combinations in exprs"},
  {"name-dollarsign",	&f77_dollarsigns,
				"$ in identifiers"},
  {"name-underscore",	&f77_underscores,
				"Underscores in variable names"},
  {"namelist",		&f77_namelist,
				"NAMELIST statement"},
  {"param-implicit-type",&f77_param_implicit_type,
				"implicit typing of PARAMETERs"},
  {"param-intrinsic",	&f77_param_intrinsic,
				"Intrinsics and **real in PARAMETER defns"},
  {"param-noparen",	&f77_param_noparen,
				"PARAMETER statement without parens"},
  {"pointer",		&f77_cray_pointers,
				"Cray pointer syntax"},
  {"quad-constant",	&f77_quad_constants,
				"Quad precision constants like 1.23Q4"},
  {"quotemark",		&f77_quotemarks,
				"Strings delimited by \"quote marks\""},
  {"relops",		&f77_relops,
				"Relational operators < <= == /= > >="},
  {"statement-order",	&f77_stmt_order,
				"Statement out of order"},
  {"typeless-constant",	&f77_typeless_constants,
				"Typeless constants like Z'19AF'"},
  {"type-size",		&f77_typesize,
				"Sized type declarations like REAL*8"},
  {"variable-format",	&f77_variable_format,
				"Variable format repeat spec or field size"},
  {"vms-io",		&f77_io_keywords, /* same as "io-keywords" */
				"Nonstandard I/O keywords"},
  {(char *)NULL, (int *)NULL, (char *)NULL},
};


PRIVATE WarnOptionList
 f90_warn_option[]={
  {
#if F90_ALL
   "all"	 /* used by -help */
#else
   "none"
#endif
     , (int *)NULL,	"Fortran 90 Violation Warning"},/* Title for list */
  {"accept-type",	&f90_accept_type,
				"ACCEPT and TYPE I/O statements"},
  {"backslash",		&f90_unix_backslash,
				"Unix backslash escape in strings"},
  {"byte",		&f90_byte,
				"BYTE data type"},
  {"cpp",		&f90_unix_cpp,
				"Unix C preprocessor directives"},
  {"d-comment",		&f90_d_comment,
				"Debug comments starting with D"},
  {"dec-tab"	,	&f90_dec_tabs,
				"DEC Fortran tab-formatted source"},
  {"double-complex",	&f90_double_complex,
				"Double complex datatype"},
  {"format-dollarsign",	&f90_format_dollarsigns,
				"$ control code in FORMAT"},
  {"format-edit-descr",	&f90_format_extensions,
				"Nonstandard edit descriptors"},
  {"function-noparen",	&f90_function_noparen,
				"FUNCTION defined without parens"},
  {"intrinsic",		&f90_intrinsics,
				"Nonstandard intrinsic functions"},
  {"io-keywords",	&f90_io_keywords,
				"Nonstandard I/O keywords"},
  {"long-line",		&f90_overlength,
				"Statements with code past 72 columns"},
  {"mixed-expr",	&f90_mixed_expr,
				"Incompatible type combinations in exprs"},
  {"name-dollarsign",	&f90_dollarsigns,
				"$ in identifiers"},
  {"param-implicit-type",&f90_param_implicit_type,
				"implicit typing of PARAMETERs"},
  {"param-noparen",	&f90_param_noparen,
				"PARAMETER statement without parens"},
  {"pointer",		&f90_cray_pointers,
				"Cray pointer syntax"},
  {"quad-constant",	&f90_quad_constants,
				"Quad precision constants like 1.23Q4"},
  {"statement-order",	&f90_stmt_order,
				"Statement out of order"},
  {"type-size",		&f90_typesize,
				"Sized type declarations like REAL*8"},
  {"typeless-constant",	&f90_typeless_constants,
				"Nonstandard constants like X'19AF'"},
  {"variable-format",	&f90_variable_format,
				"Variable format repeat spec or field size"},
  {"vms-io",		&f90_io_keywords, /* same as "io-keywords" */
				"Nonstandard I/O keywords"},
  {(char *)NULL, (int *)NULL, (char *)NULL},
};

PRIVATE WarnOptionList
 f95_warn_option[]={
  {
#if F95_ALL
   "all"	 /* used by -help */
#else
   "none"
#endif
     , (int *)NULL,	"Fortran 95 Violation Warning"},/* Title for list */
  {"real-do",	&f95_real_do,
				"real DO variable"},
  {"pause",	&f95_pause,
				"PAUSE stmt"},
  {"assign",	&f95_assign,
				"ASSIGN stmt, assigned GOTO, assigned format"},
  {"h-edit",	&f95_Hedit,
				"H edit descriptor"},
  {(char *)NULL, (int *)NULL, (char *)NULL},
};

#ifndef STANDARD_INTRINSICS
PRIVATE WarnOptionList
 intrinsic_option[]={
  {
 	 /* Define -help message. This is not done right... */
#if (DEF_INTRINSIC_SET & 2)
  "unix"
#else
#if (DEF_INTRINSIC_SET & 4)
   "vms"
#else
#if (DEF_INTRINSIC_SET & 1)
   "common"
#else
   "none"
#endif
#endif
#endif

     , (int *)NULL,		"Intrinsic Function"},	/* Title for list */
  {"extra",		&intrinsic_set_extra,
			"recognize commonly supported nonstandard intrinsics"},
  {"iargc-no-argument",	&intrinsic_iargc_no_argument,
				"iargc takes no arguments"},
  {"iargc-one-argument",&intrinsic_iargc_one_argument,
				"iargc takes one argument"},
  {"rand-no-argument",	&intrinsic_rand_no_argument,
				"rand takes no arguments"},
  {"rand-one-argument",	&intrinsic_rand_one_argument,
				"rand takes one argument"},
  {"unix",		&intrinsic_set_unix,
				"recognize some unix intrinsics"},
  {"vms",		&intrinsic_set_vms,
				"recognize some vms intrinsics"},
  {(char *)NULL, (int *)NULL, (char *)NULL},
};
#endif /* not STANDARD_INTRINSICS */


			/* makedcls is not really a warning list,
			   but it uses the same style of control. */
PRIVATE WarnOptionList
 makedcl_warn_option[]={
  {"none"			/* used by -help */
     , (int *)NULL,		"Make Type-Declarations"}, /* Title for list */

  {"asterisk-comment",	&dcl_asterisk_comment_character,
				"use asterisk as comment character"},
  {"comment-char-lowercase",&dcl_lowercase_comment_character,
				"use lowercase c as comment character"},
  {"compact",		&dcl_compact,
				"compact output format"},
  {"declarations",	&dcl_declarations,
				"produce file of declarations"},
  {"exclude-sftran3",	&dcl_excl_sftran3_internal_vars,
				"omit SFTRAN3 internal variables"},
  {"keywords-lowercase",&dcl_keywords_lowercase,
				"output keywords in lowercase"},
  {"suppress-array-dimensions",&dcl_no_array_dimensions,
				"do not declare array dimensions"},
  {"undeclared-only",	&dcl_only_undeclared,
				"declare only undeclared things"},
  {"use-continuation-lines",&dcl_use_continuations,
				" use continuation lines"},
  {"vars-and-consts-lowercase",&dcl_vars_and_consts_lowercase,
				"output variables and constants in lowercase"},
  {(char *)NULL, (int *)NULL, (char *)NULL},
};

PRIVATE WarnOptionList
 port_warn_option[]={
  {
#if PORT_ALL
   "all"	 /* used by -help */
#else
   "none"
#endif
     , (int *)NULL,		"Portability Warning"},	/* Title for list */
  {"backslash",		&port_backslash,
				"Backslash in standard-conforming strings"},
  {"common-alignment",	&port_common_alignment,
				"COMMON not in descending size order"},
  {"hollerith",		&port_hollerith,
				"Hollerith constants (except in FORMAT)"},
  {"long-string",	&port_long_string,
				"Strings over 255 chars long"},
  {"mixed-equivalence",	&port_mixed_equiv,
				"Different data types equivalenced"},
  {"mixed-size",	&port_mixed_size,
				"Default and explicit size types mixed"},
  {"real-do",		&port_real_do,
				"Non-integer DO loops"},
  {"param-implicit-type",&port_param_implicit_type,
			"Implicit type of PARAMETER differs from default type"},
  {"tab",		&port_tabs,
				"Tabs in source code"},
  {(char *)NULL, (int *)NULL, (char *)NULL},
};

PRIVATE WarnOptionList
 pretty_warn_option[]={
  {
#if PRETTY_ALL
   "all"	 /* used by -help */
#else
   "none"
#endif
     , (int *)NULL,		"Appearance Warning"},	/* Title for list */
  {"embedded-space",	&pretty_extra_space,
				"Space in variable names or operators"},
  {"continuation",	&pretty_contin,
				"Continuation mark following comment line"},
  {"long-line",		&pretty_overlength,
				"Lines over 72 columns"},
  {"missing-space",	&pretty_no_space,
				"Missing space between variable & keyword"},
  {"multiple-common",	&pretty_multiple_common,
				"COMMON declared in multiple stmts"},
  {"multiple-namelist",	&pretty_multiple_namelist,
				"NAMELIST declared in multiple stmts"},
  {"parentheses",	&pretty_parens,
				"Parentheses around a variable"},
  {(char *)NULL, (int *)NULL, (char *)NULL},

};

			/* Source format is not really a warning list,
			   but it uses the same style of control. */
PRIVATE WarnOptionList
 source_form_option[]={
  {
#if VMS_INCLUDE
   "vms-include"       /* For -help.  This ignores the unlikely possibility
			  that other options may also be turned on by default. */
#else
   "none"
#endif
     , (int *)NULL,		"Source Format"}, /* Title for list */
  {"dec-parameter-standard-type",&source_dec_param_std_type,
				"DEC Fortran PARAMETERs typed as if standard"},
  {"dec-tab",   	&source_dec_tab,
				"DEC Fortran tab-format"},
  {"parameter-implicit-type",&source_param_implicit,
				"implicit typing of PARAMETERs by value"},
  {"unix-backslash",	&source_unix_backslash,
				"UNIX-style backslash escape char"},
  {"vms-include",	&source_vms_include,
				"VMS-style INCLUDE statement"},
  {(char *)NULL, (int *)NULL, (char *)NULL},

 };

PRIVATE WarnOptionList
 trunc_warn_option[]={
  {
#if TRUNC_ALL
   "all"	 /* used by -help */
#else
   "none"
#endif
     , (int *)NULL,		"Truncation Warning"},	/* Title for list */
  {"int-div-exponent",	&trunc_int_div_exponent,
				"int/int used as exponent"},
  {"int-div-real",	&trunc_int_div_real,
				"int/int converted to real"},
  {"int-div-zero",	&trunc_int_div_zero,
				"int/int = constant 0 "},
  {"int-neg-power",	&trunc_int_neg_power,
				"int**(-int), usually equals 0"},
  {"promotion",		&trunc_promotion,
				"lower precision promoted to higher"},
  {"real-do-index",	&trunc_real_do_index,
				"real DO index with int bounds"},
  {"real-subscript",	&trunc_real_subscript,
				"real array subscript"},
  {"significant-figures",&trunc_sigfigs,
				"single precision const overspecified"},
  {"size-demotion",		&trunc_size_demotion,
			"higher precision truncated to lower, same type"},
  {"type-demotion",		&trunc_type_demotion,
			"higher precision truncated to lower, different type"},
  {(char *)NULL, (int *)NULL, (char *)NULL},

};

PRIVATE WarnOptionList
 usage_warn_option[]={
  {
#if USAGE_ALL
   "all"	 /* used by -help */
#else
   "none"
#endif
     , (int *)NULL,		"Usage Warning"},	/* Title for list */
  {"arg-alias",		&usage_arg_alias_modified,
		"scalar argument same as another is modified"},
  {"arg-array-alias",	&usage_array_alias_modified,
		"argument in same array as another is modified"},
  {"arg-common-alias",		&usage_arg_common_modified,
		"scalar argument same as common variable, either is modified"},
  {"arg-common-array-alias",	&usage_array_common_modified,
		"array argument same as common variable, either is modified"},
  {"arg-const-modified",	&usage_arg_modified,
		"constant or expression argument is modified"},
  {"com-block-unused",	&usage_com_block_unused,
		"whole common block declared but not used"},
  {"com-block-volatile", &usage_com_block_volatile,
		"common block may lose definition if volatile"},
  {"com-var-set-unused",	&usage_com_var_set_unused,
		"common variable set but not used"},
  {"com-var-uninitialized",	&usage_com_var_uninitialized,
		"common variable used but not set"},
  {"com-var-unused",	&usage_com_var_unused,
		"common variable declared but not used"},
  {"ext-multiply-defined",	&usage_ext_multiply_defined,
		"external multiply defined"},
  {"ext-declared-only",	&usage_ext_declared_only,
		"name declared EXTERNAL but not defined or used"},
  {"ext-undefined",	&usage_ext_undefined,	/* Also touched by -extern */
		"external declared or used but not defined (= -external)"},
  {"ext-unused",	&usage_ext_unused,
		"external defined but not used"},
  {"var-set-unused",	&usage_var_set_unused,
		"local variable set but not used"},
  {"var-uninitialized",	&usage_var_uninitialized,
		"local variable used before set"},
  {"var-unused",	&usage_var_unused,
		"local variable declared but not used"},
  {(char *)NULL, (int *)NULL, (char *)NULL},
};

		/* List of strsettings is defined here. Each entry
		   gives the name of the corresponding string
		   variable, value to set if "=str" omitted, and brief
		   explanation.  See set_option() for processing. */

/*** (struct was declared above: repeated in comment here for reference)
StrsettingList {
    char *name;
    char **strvalue;
    char *turnon, *turnoff;
    isacheck_t isacheck;
    WarnOptionList *option_list;
    PROTO(void (*numeric_form_handler),(int num, char *setting_name));
    char *explanation;
};***/

PRIVATE StrsettingList strsetting[]={
  {"arguments",	&argcheck_warn_list, "all", "none", IS_A_CHECK,
     argcheck_warn_option, argcheck_numeric_option,
     "check subprogram argument agreement"},
  {"array",	&arraycheck_warn_list, "all", "none", IS_A_CHECK,
     arraycheck_warn_option, arraycheck_numeric_option,
     "check subprogram argument arrayness agreement"},
  {"calltree",	&calltree_opt_list, "tree", "none", NOT_A_CHECK,
     calltree_option, calltree_numeric_option,
     "subprogram call graph options"},
  {"common",	&comcheck_warn_list, "all", "none", IS_A_CHECK,
     comcheck_warn_option, comcheck_numeric_option,
     "check for common block mismatches"},
  {"f77",	&f77_warn_list,	"all", "none", IS_A_CHECK,
     f77_warn_option, NULL,
     "warn about non-F77 extensions"},
  {"f90",	&f90_warn_list,	"all", "none", IS_A_CHECK,
     f90_warn_option, NULL,
     "warn about non-F90 syntax"},
  {"f95",	&f95_warn_list,	"all", "none", IS_A_CHECK,
     f95_warn_option, NULL,
     "warn about non-F95 syntax"},
#ifdef ALLOW_INCLUDE
  {"include",	&include_path,  (char *)NULL, (char *)NULL, NOT_A_CHECK,
     (WarnOptionList *)NULL, NULL,
     "include-file directory"},
#endif
#ifndef STANDARD_INTRINSICS
  {"intrinsic", &intrinsic_option_list, "all", "none", NOT_A_CHECK,
     intrinsic_option, intrinsic_numeric_option,
     "specify intrinsic function options"},
#endif
			/* makedcls: turnon="declarations" instead of "all" */
  {"makedcls",  &makedcl_warn_list, "declarations", "none", NOT_A_CHECK,
     makedcl_warn_option, makedcl_numeric_option,
    "make type declaration statements:"},
  {"output",	&out_fname,	(char *)NULL, (char *)NULL, NOT_A_CHECK,
     (WarnOptionList *)NULL, NULL,
     "output file name"},
  {"portability",&port_warn_list,"all", "none", IS_A_CHECK,
     port_warn_option, NULL,
     "warn about portability problems"},
  {"pretty",	&pretty_warn_list,"all", "none", IS_A_CHECK,
     pretty_warn_option, NULL,
     "warn about deceiving appearances"},
  {"source",	&source_form_list,"all", "none", NOT_A_CHECK,
     source_form_option, source_numeric_option,
     "select source format options"},
  {"truncation",&trunc_warn_list,"all", "none", IS_A_CHECK,
     trunc_warn_option, NULL,
     "check for truncation pitfalls"},
  {"usage",	&usage_warn_list,"all", "none", IS_A_CHECK,
     usage_warn_option, usage_numeric_option,
     "warn about variable and common block usage problems"},
};


PRIVATE int must_open_outfile=FALSE; /* Flag set to TRUE when out=name given */
PRIVATE int checks_on=TRUE; /* Keep track whether -nocheck was given */

PRIVATE char *dclfile;
PRIVATE int actioncount=0;
int
#if HAVE_STDC
main(int argc, char **argv)
#else /* K&R style */
main(argc,argv)
	int argc;
	char *argv[];
#endif /* HAVE_STDC */
{
	int iarg;
	int filecount=0;
	char *infile,*srcfile,*projfile;

				/* The shell_mung routine from GNU can be
				   used to expand wildcards etc. for VMS.
				*/
#ifdef USE_SHELL_MUNG
	shell_mung(&argc,&argv,1,NULL);
#endif

	list_fd = stdout;
	project_fd = (FILE *) NULL;
	error_count = 0;
	warning_count = 0;
	include_path_list = (IncludePathNode*) NULL;

	get_env_options();	/* Pick up options from environment */
	get_rc_options();	/* Pick up options from "rc" file */

	init_tables();		/* Initialize tables */
	init_keyhashtab();
	intrins_clashes = init_intrins_hashtab();
	init_globals();
	init_symtab();

	for(iarg=1; iarg < argc; iarg++) {

	  int argchar=0;/* location of start of option */
			/* Note to maintainer: since the /option version
			   has a loop here instead of an if, do not
			   use continue but goto next_arg for skipping
			   to the next argument.  This is a mess, isn't it?
			 */
#ifdef OPTION_PREFIX_SLASH
	  do {			/* loop on flags within argv[iarg] */
#endif
	    if( argv[iarg][argchar] == '-'
#ifdef OPTION_PREFIX_SLASH
		 || argv[iarg][argchar] == '/'	/* Allow VMS /option form */
#endif
					 ) {
			/* Process flags here */

		set_option(&argv[iarg][argchar],"commandline");

			/* Handle -version, -help, or -f77=help */
		if(print_version) goto do_action;

		if(help_screen) goto do_action;

				/* Allow checking to be turned off */
		if( !do_check && checks_on ) {
		  turn_off_checks();
		  checks_on = FALSE;	/* remember it was done */
		}

	    }
	    else if(strcmp(&argv[iarg][argchar],"?") == 0) {
		    help_screen = TRUE;
		    goto do_action;
	    }/*end of processing options*/

	    else {	/* Process file arguments */
do_action:

		if( must_open_outfile )
		    open_outfile(out_fname);

		if(actioncount == 0) {
		  print_version_number();
		}
		++actioncount;	/* Cause exit w/o reading stdin below */

			/* Honor -version, -help and -f77=help options */
		if(print_version) {
		  print_version = FALSE;
		  goto next_arg;
		}

		if(help_screen) {
		  help_screen = FALSE;
		  list_options(list_fd);
		}
		else {	/* Process files here */

		    if(filecount == 0)
		      do_preps(); /* Any preparations needed before processing */

		    ++filecount;

		    srcfile = add_ext(&argv[iarg][argchar],DEF_SRC_EXTENSION);
		    projfile = new_ext(&argv[iarg][argchar],DEF_PROJ_EXTENSION);
		    dclfile =  new_ext(&argv[iarg][argchar],DEF_DCL_EXTENSION);
#ifdef VCG_SUPPORT
				/* Initialize main_filename to 1st file arg */
		    if(main_filename == (char *)NULL)
		      main_filename = argv[iarg];
#endif
				/* Project file mode: open source for reading
				   and .prj file for writing. */
		    if(make_project_file) {

		      infile = srcfile;

		      if( has_extension(infile,DEF_PROJ_EXTENSION) ) {
			(void)fprintf(stderr,
			 "Input from %s disallowed in project mode\n",infile);
			goto next_arg;
		      }

		      if( (input_fd = fopen(infile,"r")) == (FILE *)NULL ) {
			(void)fprintf(stderr,"Cannot open file %s\n",infile);
			goto next_arg;
		      }

		      project_fd = fopen(projfile,"w");
		      project_file_input = FALSE;
		    }
		    else {
			/* Non project file mode: if input file extension
			   given, use it.  Otherwise read project file
			   if it exists else read source file. */
		      if( &argv[iarg][argchar]==srcfile
		       || (input_fd = fopen(projfile,"r")) == (FILE *)NULL) {
			infile = srcfile;
			if( (input_fd = fopen(infile,"r")) == (FILE *)NULL ) {
			  (void)fflush(list_fd);
			  (void)fprintf(stderr,"Cannot open file %s\n",infile);
			  goto next_arg;
			}
			project_file_input =
			  has_extension(infile,DEF_PROJ_EXTENSION);
		      }
		      else {
			infile = projfile;
			project_file_input = TRUE;
		      }
		    }

		    /* now that we have a source file, try to open the 
		       declaration file */
		    dcl_fd = (dcl_declarations &&  ! project_file_input) ?
		      fopen(dclfile,"w") : (FILE*)NULL;

				/* Always print input .f file name.  If
				   verbose mode, print .prj file names too.
				 */
		    if(!quiet || !project_file_input)
		      (void)fprintf(list_fd,"\nFile %s:%s",
			      infile,
			      full_output?"\n":""
			      );

				/* In verbose mode, print .prj output
				   file name to stderr.  Always print
				   error message if couldn't open it. */
		    if( make_project_file ) {
		      if(project_fd != (FILE *)NULL) {
			if(!quiet) {
			  (void)fflush(list_fd);
			  (void)fprintf(stderr,
				  "\nProject file is %s\n",projfile);
			}
		      }
		      else {
			(void)fflush(list_fd);
			(void)fprintf(stderr,
				"\nCannot open %s for output\n",projfile);
		      }
		    }


		    if(project_file_input) {

		        current_filename = projfile;
			proj_file_in(input_fd);

		    }
		    else {

		      src_file_in(infile);

		    }

		    (void) fclose(input_fd);
		}/*end processing file args*/
	      }
next_arg:
#ifdef OPTION_PREFIX_SLASH
				/* Here we allow /opts to be stuck together */
	    while(argv[iarg][++argchar] != '\0'
		 && argv[iarg][argchar] != '/') /* look for next opt */
	      continue;

	  } while(argv[iarg][argchar] != '\0'); /*end do-while*/
#else
	  continue;
#endif
	}	/* end for-loop on argument list */


				/* No files given: read stdin */
	if(actioncount == 0) {

		print_version_number();

		if( must_open_outfile )
		    open_outfile(out_fname);

		do_preps();	/* Any preparations needed before processing */

		if(make_project_file) {
		      projfile = STDIN_PROJ_FILENAME;
		      if( (project_fd = fopen(projfile,"w")) == (FILE *)NULL) {
			(void)fflush(list_fd);
			(void)fprintf(stderr,
				"\nCannot open %s for output\n",projfile);
		      }
		      else {
			if(!quiet) {
			  (void)fflush(list_fd);
			  (void)fprintf(stderr,
				"\nProject file is %s\n",projfile);
			}
		      }
		}

		++filecount;
		input_fd = stdin;

		src_file_in("std_input");
	}
	if(filecount > 0) {
	  wrapup();
	  (void)fprintf(list_fd,"\n");
	}

	if(show_resources)
	    resource_summary();

	exit(0);
	return 0;/*NOTREACHED*/
}

				/* do_preps does anything necessary prior
				   to processing 1st file, such as setting
				   the intrinsic function options.  It is
				   only called once.
				*/
PRIVATE void
do_preps(VOID)
{

  init_typesizes();	/* Put -wordsize and -pointersize into effect */

#ifndef STANDARD_INTRINSICS
  set_intrinsic_options(); /* Make intrinsic table match -intrinsic setting */
#endif
}

PRIVATE void
#if HAVE_STDC
src_file_in(char *infile)
                  		/* input filename */
#else /* K&R style */
src_file_in(infile)
     char *infile;		/* input filename */
#endif /* HAVE_STDC */
{
	note_filename(infile);

	init_scan();
	init_parser();

	(void) yyparse();

	finish_scan();

	if(make_project_file) {
		  proj_file_out(project_fd);
		  (void) fclose(project_fd);
	}

	if ((dcl_declarations) && (dcl_fd != stdout))
	{

	    if (ftell(dcl_fd) == 0L)	/* delete an empty .dcl file */
            {
              /* some systems like OS/2 lock open files and can't  */
              /* remove an open file unless closed. SAD-10/96      */
	        (void) fclose(dcl_fd);   /* close file */
		(void) unlink(dclfile);
            }
	    else {
	      (void) fclose(dcl_fd);
	    }
	}

	if(port_tabs && (tab_filename != (char *)NULL)) {
	  if(tab_filename != top_filename) {
	    nonportable(NO_LINE_NUM,NO_COL_NUM,
			"Included file");
	    msg_tail(tab_filename);
	  }
	  else {
	    nonportable(NO_LINE_NUM,NO_COL_NUM,
		      "File");
	  }
	  msg_tail("contains tabs");
	}

	error_summary(infile);
}

PRIVATE void
print_version_number(VOID)
{
  if((full_output || !quiet) && !print_version)
    (void)fprintf(list_fd,"\n");
  (void)fprintf(list_fd,"%s",VERSION_NUMBER);
  if(help_screen || print_version)
    (void)fprintf(list_fd," %s",PATCHLEVEL);
  if(full_output || !quiet || print_version)
    (void)fprintf(list_fd,"\n");
}

PRIVATE void
#if HAVE_STDC
error_summary(char *fname)		/* Print out count of errors in file */
#else /* K&R style */
error_summary(fname)		/* Print out count of errors in file */
	char *fname;
#endif /* HAVE_STDC */
{
	FILE *fd = list_fd;

	if(full_output ||
	   (!quiet && error_count+warning_count != 0))
	  (void)fprintf(fd,"\n");

	if(full_output || !quiet || error_count != 0)
	  (void)fprintf(fd,"\n %u syntax error%s detected in file %s",
			error_count, error_count==1? "":"s",
			fname);

	if(warning_count != 0)
		(void)fprintf(fd,"\n %u warning%s issued in file %s",
			warning_count, warning_count==1? "":"s",
			fname);

	if(full_output ||
	   (!quiet && error_count+warning_count != 0))
	  (void)fprintf(fd,"\n");

	error_count = 0;
	warning_count = 0;
}

void
#if HAVE_STDC
print_a_line(FILE *fd, char *line, unsigned int num)  /* Print source line with line number */
#else /* K&R style */
print_a_line(fd,line,num)  /* Print source line with line number */
	FILE *fd;
	char *line;
	unsigned num;
#endif /* HAVE_STDC */
{
	(void)fprintf(fd,"\n %6u ",num); /* Print line number */

#ifdef DEC_TABS
				/* Tab-formatted source lines: tab in
				   col 1-6 moves to col 7. */
	if(source_dec_tab) {
	  int i,col;
	  for(i=0,col=1; col < 7 && line[i] != '\0'; i++) {
	    if(line[i] == '\t') {
	      do{
		(void)fprintf(fd," ");
	      } while(++col < 7);
	    }
	    else {
		(void)fprintf(fd,"%c",line[i]);
		++col;
	    }
	  }
	  (void)fprintf(fd,"%s",line+i);
	}
	else
#endif
	  (void)fprintf(fd,"%s",line);
}


void
#if HAVE_STDC
yyerror(char *s)
#else /* K&R style */
yyerror(s)
	char *s;
#endif /* HAVE_STDC */
{
	syntax_error(line_num,col_num,s);
}


void
#if HAVE_STDC
syntax_error(unsigned int lineno, unsigned int colno, char *s)		/* Syntax error message */
#else /* K&R style */
syntax_error(lineno,colno,s)		/* Syntax error message */
	unsigned lineno,colno;
	char *s;
#endif /* HAVE_STDC */
{
	++error_count;
	error_message(lineno,colno,s,"Error");
}

void
#if HAVE_STDC
warning(unsigned int lineno, unsigned int colno, char *s)		/* Print warning message */
#else /* K&R style */
warning(lineno,colno,s)		/* Print warning message */
	unsigned lineno,colno;
	char *s;
#endif /* HAVE_STDC */
{
	++warning_count;

	error_message(lineno,colno,s,"Warning");
}

void
#if HAVE_STDC
ugly_code(unsigned int lineno, unsigned int colno, char *s)		/* -pretty message */
#else /* K&R style */
ugly_code(lineno,colno,s)		/* -pretty message */
	unsigned lineno,colno;
	char *s;
#endif /* HAVE_STDC */
{
	++warning_count;

	error_message(lineno,colno,s,"Possibly misleading appearance");
}

void
#if HAVE_STDC
nonstandard(unsigned int lineno, unsigned int colno, int f90, int f95)
#else /* K&R style */
nonstandard(lineno,colno, f90, f95)
     unsigned lineno,colno;
     int f90, f95;
#endif /* HAVE_STDC */
{
	++warning_count;
	if( f95 ) {
	  error_message(lineno,colno,"Syntax deleted in Fortran 95","Warning");
	}
	else {
	  error_message(lineno,colno,"Nonstandard syntax","Warning");
	  if( f90 )
	    msg_tail("(not adopted in Fortran 90)");
	}
}

void
#if HAVE_STDC
nonportable(unsigned int lineno, unsigned int colno, char *s) /* Print warning about nonportable construction */
#else /* K&R style */
nonportable(lineno,colno,s) /* Print warning about nonportable construction */
	unsigned lineno,colno;
	char *s;
#endif /* HAVE_STDC */
{
	++warning_count;
	error_message(lineno,colno,s,"Nonportable usage");
}

/* error_message prints out error messages and warnings.  It
   now comes in two flavors.  If using lintstyle_error_message(),
   messages are produced in style like UNIX lint:

	"main.f", line nn, col nn: Error: your message here

   Otherwise messages by oldstyle_error_message in old ftnchek style:

	Error near line nn col nn file main.f: your message here

   At this time, oldstyle_error_message is used when -novice is
   in effect, lintstyle_error_message otherwise.
*/

PRIVATE int errmsg_col;
	/* Crude macro to give number of digits in line and column numbers.
	   Used by line wrap computation. */
#define NUM_DIGITS(n) ((n)<10?1:((n)<100?2:((n)<1000?3:(n)<10000?4:5)))

PRIVATE void
#if HAVE_STDC
error_message(unsigned int lineno, unsigned int colno, char *s, char *tag)
#else /* K&R style */
error_message(lineno,colno,s,tag)
	unsigned lineno,colno;
	char *s,*tag;
#endif /* HAVE_STDC */
{
  if(novice_help)
    oldstyle_error_message(lineno,colno,s,tag);
  else
    lintstyle_error_message(lineno,colno,s,tag);
}

PRIVATE void
#if HAVE_STDC
lintstyle_error_message(unsigned int lineno, unsigned int colno, char *s, char *tag)
#else /* K&R style */
lintstyle_error_message(lineno,colno,s,tag)
	unsigned lineno,colno;
	char *s,*tag;
#endif /* HAVE_STDC */
{
	int icol;
	extern unsigned prev_stmt_line_num; /* shared with advance.c */

	errmsg_col=1;		/* Keep track of line length */

			/* Print the character ^ under the column number.
			   But if colno == 0, error occurred in prior line.
			   If colno is NO_COL_NUM, then print message
			   without any column number given.
			 */

	if(lineno != NO_LINE_NUM) {
	    if(colno == NO_COL_NUM) {
		    /* colno == NO_COL_NUM means don't give column number.*/
		(void)flush_line_out(lineno);/* print line if not printed yet */
	    }
	    else if(colno != 0) {
			/* print line if not printed yet */
		if( flush_line_out(lineno) ) {
				/* If it was printed, put ^ under the col */
		    (void)fprintf(list_fd,"\n%8s","");

		    for(icol=1; icol<colno; icol++)
			(void)fprintf(list_fd," ");
		    (void)fprintf(list_fd,"^");
		}
	    }
	    else {		/* colno == 0 */
			/* print line if not printed yet */
		(void)flush_line_out(prev_stmt_line_num);
	    }
	}

	(void)fprintf(list_fd,"\n\"%s\"",current_filename);
	errmsg_col += 2+strlen(current_filename);

	if(lineno != NO_LINE_NUM) { /* nonlocal error-- don't flush */
	    if(colno == NO_COL_NUM) {
		(void)fprintf(list_fd,
		   ", near line %u",lineno);
		errmsg_col += 12+NUM_DIGITS(lineno);
	    }
	    else if(colno != 0) {
		(void)fprintf(list_fd,
		   ", line %u col %u",lineno,colno);
		errmsg_col += 12+NUM_DIGITS(lineno);
	    }
	    else {		/* colno == 0 */
		(void)fprintf(list_fd,
		   ", near line %u",prev_stmt_line_num);
		errmsg_col += 12+NUM_DIGITS(lineno);
	    }
	}

	(void)fprintf(list_fd,": %s:",tag); /* "Warning", "Error", etc. */
	errmsg_col += 3+strlen(tag);

	msg_tail(s); /* now append the message string */
}

				/* Our own style messages */
PRIVATE void
#if HAVE_STDC
oldstyle_error_message(unsigned int lineno, unsigned int colno, char *s, char *tag)
#else /* K&R style */
oldstyle_error_message(lineno,colno,s,tag)
	unsigned lineno,colno;
	char *s,*tag;
#endif /* HAVE_STDC */
{
	int icol;
	extern unsigned prev_stmt_line_num; /* shared with advance.c */

	errmsg_col=1;		/* Keep track of line length */

			/* Print the character ^ under the column number.
			   But if colno == 0, error occurred in prior line.
			   If colno is NO_COL_NUM, then print message
			   without any column number given.
			 */

	if(lineno == NO_LINE_NUM) { /* nonlocal error-- don't flush */
	  (void)fprintf(list_fd,"\n%s",tag);
	  errmsg_col += strlen(tag);
	}
	else {
	    if(colno == NO_COL_NUM) {
		    /* colno == NO_COL_NUM means don't give column number.*/
		(void)flush_line_out(lineno);/* print line if not printed yet */
		(void)fprintf(list_fd,
		   "\n%s near line %u",tag,lineno);
		errmsg_col += 11+NUM_DIGITS(lineno)+(unsigned)strlen(tag);
	    }
	    else if(colno != 0) {
			/* print line if not printed yet */
		if( flush_line_out(lineno) ) {
				/* If it was printed, put ^ under the col */
		    (void)fprintf(list_fd,"\n%8s","");

		    for(icol=1; icol<colno; icol++)
			(void)fprintf(list_fd," ");
		    (void)fprintf(list_fd,"^");
		}
		(void)fprintf(list_fd,
		   "\n%s near line %u col %u",tag,lineno,colno);
		errmsg_col += 16+NUM_DIGITS(lineno)+NUM_DIGITS(colno)
		  +(unsigned)strlen(tag);
	    }
	    else {		/* colno == 0 */
			/* print line if not printed yet */
		(void)flush_line_out(prev_stmt_line_num);
		(void)fprintf(list_fd,
		   "\n%s near line %u",tag,prev_stmt_line_num);
		errmsg_col += 11+NUM_DIGITS(lineno)+(unsigned)strlen(tag);
	    }
	}

	if(!full_output		/* If not listing, append file name */
	   || incdepth > 0){	/* Append include-file name if we are in one */
	  if(lineno == NO_LINE_NUM) { /* if no line no, preposition needed */
	    (void)fprintf(list_fd," in");
	    errmsg_col += 3;
	  }
	  (void)fprintf(list_fd," file %s",current_filename);
	  errmsg_col += 6+(unsigned)strlen(current_filename);
	}

	(void)fprintf(list_fd,":");
	errmsg_col++;

	msg_tail(s); /* now append the message string */
}

		/* msg_tail appends string s to current error message.
		   It prints one word at a time, starting a new line
		   when the message gets to be too long for one line.
		 */
void
#if HAVE_STDC
msg_tail(char *s)
#else /* K&R style */
msg_tail(s)
    char *s;
#endif /* HAVE_STDC */
{
	int wordstart,wordend,leading_skip,wordchars;

	(void)fprintf(list_fd," ");
	errmsg_col++;
	wordstart=0;
		/* Each iteration of loop prints leading space and the
		   nonspace characters of a word.  Loop invariant: wordstart
		   is index of leading space at start of word, wordend is
		   index of space char following word. */
	while(s[wordstart] != '\0') {
	  leading_skip = TRUE;
	  for(wordend=wordstart; s[wordend] != '\0'; wordend++) {
	    if(leading_skip) {	/* If skipping leading space chars */
	      if(!isspace(s[wordend]))
		leading_skip = FALSE; /* go out of skip mode at nonspace */
	    }
	    else {		/* If scanning word chars */
	      if(isspace(s[wordend]))
		break;		/* quit loop when space char found */
	    }
	  }
	  wordchars = wordend-wordstart;
				/* If word doesn't fit, wrap to next line */
	  if( wrap_column > 0 && (errmsg_col += wordchars) > wrap_column) {
	    (void)fprintf(list_fd,"\n");
	    errmsg_col = wordchars;
	  }
				/* Print the word */
	  while(wordstart < wordend) {
	    (void)putc(s[wordstart++],list_fd);
	  }
	}
}


void
#if HAVE_STDC
oops_message(int severity, unsigned int lineno, unsigned int colno, char *s)
#else /* K&R style */
oops_message(severity,lineno,colno,s)
	int severity;
	unsigned lineno,colno;
	char *s;
#endif /* HAVE_STDC */
{
	(void)fflush(list_fd);
	(void)fprintf(stderr,"\nOops");
	if(lineno != NO_LINE_NUM) {
	  (void)fprintf(stderr," at line %u",lineno);
	  if(colno != NO_COL_NUM)
	    (void)fprintf(stderr," at col %u",colno);
	}
	(void)fprintf(stderr," in file %s",current_filename);
	(void)fprintf(stderr," -- %s",s);
	if(severity == OOPS_FATAL) {
	  (void)fprintf(stderr,"\nFtnchek aborted\n");
	  exit(1);
	}
}

void
#if HAVE_STDC
oops_tail(char *s)
#else /* K&R style */
oops_tail(s)
	char *s;
#endif /* HAVE_STDC */
{
	(void)fprintf(stderr," %s",s);
}

/*	get_env_options picks up any options defined in the
	environment.  A switch or setting is defined according to
	the value of an environment variable whose name is the switch
	or setting name (uppercased), prefixed by the string
	ENV_PREFIX (e.g.  FTNCHEK_).  For settings and strsettings,
	the value of the environment variable gives the value to be
	used.  For switches, the environment variable is set to "0" or
	"NO" to turn the switch off, or to any other value (including
	null) to turn it on.
*/

PRIVATE void
get_env_options(VOID)
{
		/* Size of env_option_name must be at least 1 +
                   strlen(ENV_PREFIX) + max over i of strlen of
                   switchopt[i].name, setting[i].name,
                   strsetting[i].name.
		*/
#define ENV_OPTION_NAME_LEN 32
	char env_option_name[ENV_OPTION_NAME_LEN];
	char *value;
	int i, checklen;
	
			/* The following code checks size of
                           ENV_OPTION_NAME_LEN, which may become too small
                           as option names are added. This could be
                           commented out in released code, but it's a
                           minor overhead for insurance.
			*/
	checklen = 0;
	for(i=0; i<NUM_SWITCHES; i++) {
	  checklen = MAX(checklen,strlen(switchopt[i].name));
	}
	for(i=0; i<NUM_SETTINGS; i++) {
	  checklen = MAX(checklen,strlen(setting[i].name));
	}
	for(i=0; i<NUM_STRSETTINGS; i++) {
	  checklen = MAX(checklen,strlen(strsetting[i].name));
	}
	checklen += sizeof(ENV_PREFIX)+1;
	if(ENV_OPTION_NAME_LEN < checklen) {
	  fprintf(stderr,"\nOops -- ENV_OPTION_NAME_LEN=%d too small: make it %d\n",
		  ENV_OPTION_NAME_LEN, checklen);
	  exit(1);
	}


				/* OK, now we get down to it. */

	for(i=0; i<NUM_SWITCHES; i++) {
			/* Construct the env variable name for switch i */
	    make_env_name( env_option_name, switchopt[i].name);

			/* See if it is defined */
	    if( (value = getenv(env_option_name)) != (char *)NULL) {
		*(switchopt[i].switchflag) =
			!(strcmp(value,"0")==0 || strcmp(value,"NO")==0 );
	    }

	}

	for(i=0; i<NUM_SETTINGS; i++) {
			/* Construct the env variable name for setting i */
	    make_env_name( env_option_name, setting[i].name);
			/* See if it is defined */
	    if( (value = getenv(env_option_name)) != (char *)NULL) {
		if(read_setting(value, setting[i].setvalue, setting[i].name,
				setting[i].minlimit, setting[i].maxlimit,
				setting[i].turnon,
				setting[i].turnoff,
				setting[i].min_default_value,
				setting[i].max_default_value) != 0) {
		  (void)fflush(list_fd);
		  (void)fprintf(stderr,"Env setting garbled: %s=%s: ignored\n",
				env_option_name,value);
		}
	    }
	}


	for(i=0; i<NUM_STRSETTINGS; i++) {
			/* Construct the env variable name for setting i */
	    make_env_name( env_option_name, strsetting[i].name);
			/* See if it is defined */
	    if( (value = getenv(env_option_name)) != (char *)NULL) {

				/* setenv nothing or "1" or "YES" --> turnon*/
	      if(value[0] == '\0'
		 || cistrncmp(value,"1",strlen(value)) == 0
		 || cistrncmp(value,"yes",strlen(value)) == 0
		 ) {
		*(strsetting[i].strvalue) = strsetting[i].turnon;
	      }
	      else if(cistrncmp(value,"no",strlen(value)) == 0) {
		*(strsetting[i].strvalue) = strsetting[i].turnoff;
	      }
	      else {		/* Otherwise use the given value */
	        *(strsetting[i].strvalue) = value;
	      }

	      if( *(strsetting[i].strvalue) == (char *)NULL ) {
		(void)fflush(list_fd);
		(void)fprintf(stderr,
			 "Environment variable %s needs string value: ignored\n",
			 env_option_name);
	      }
	      else {
		update_str_options(&strsetting[i]);
	      }
	    }
	}
}

		/* Routine to concatenate ENV_PREFIX onto option name
		   and uppercase the result.
		*/
PRIVATE void
#if HAVE_STDC
make_env_name(char *env_name, char *option_name)
#else /* K&R style */
make_env_name( env_name, option_name)
	char *env_name, *option_name;
#endif /* HAVE_STDC */
{
    int i,c;

    (void)strcat(strcpy(env_name,ENV_PREFIX),option_name);
    for(i=sizeof(ENV_PREFIX)-1; (c=env_name[i]) != '\0'; i++) {
	if( islower(c) )
	    env_name[i] = toupper(c);
    }
}

		/* get_rc_options picks up options from an "rc" file.
		 */
PRIVATE void
get_rc_options(VOID)
{
  FILE *rc_fp;
  char rc_option_string[MAX_RC_LINE];
  int i;

  rc_option_string[0] = '-';

  if( (rc_fp = find_rc()) != (FILE *)NULL ) {
    for(;;) {
      if( fgets(rc_option_string+1,sizeof(rc_option_string)-1,rc_fp)
	 == (char *)NULL)
	break;
				/* Terminate line at start of comment.
				   This also changes final \n to \0. */
      for(i=1; rc_option_string[i] != '\0'; i++) {
	if(rc_option_string[i] == RC_COMMENT_CHAR ||
	   isspace(rc_option_string[i])) {
	  rc_option_string[i] = '\0';
	  break;
	}
      }
      if(i==1)			/* Skip blank line */
	continue;

      set_option(rc_option_string,"startup file");
    }
  }
}

		/* find_rc locates the "rc" file. */
PRIVATE FILE *
find_rc(VOID)
{
  FILE *fp;
  char *fname;
  char *homedir=getenv("HOME");

			/* Allocate enough space to hold rc file name.
			   Now you see why so many apps have buffer-overrun
			   bugs. */
  if( (fname = malloc(MAX(sizeof(UNIX_RC_FILE),sizeof(NONUNIX_RC_FILE)) +
		      (homedir!=NULL?strlen(homedir):
#ifdef SPECIAL_HOMEDIR
			strlen(SPECIAL_HOMEDIR)
#else
			0
#endif
		      )
#ifdef UNIX
		        +1	/* for the "/" */
#endif
		      )) == (char *)NULL ) {
    (void)fflush(list_fd);
    (void)fprintf(stderr,"\nCannot allocate memory for init file path");
    return (FILE *)NULL;
  }

			/* Look first for file in local directory */
  (void)strcpy(fname,UNIX_RC_FILE);
  if( (fp=fopen(fname,"r")) == (FILE *)NULL) {

			/* Look for alternate name in local directory */
    (void)strcpy(fname,NONUNIX_RC_FILE);
    if( (fp=fopen(fname,"r")) == (FILE *)NULL) {


			/* Allow local option of special home directory
			   for non-unix (usually VMS) systems. */
#ifdef SPECIAL_HOMEDIR
      if(homedir == (char *)NULL) {
	homedir = SPECIAL_HOMEDIR;
      }
#endif
			/* If not found, look in home directory */
      if(homedir != (char *)NULL) {
	(void)strcpy(fname,homedir);
#ifdef UNIX
	(void)strcat(fname,"/");
#endif
	(void)strcat(fname,UNIX_RC_FILE);
	
	if( (fp=fopen(fname,"r")) == (FILE *)NULL) {


			/* If look for alternate name in home directory */
	  (void)strcpy(fname,homedir);
#ifdef UNIX
	  (void)strcat(fname,"/");
#endif
	  (void)strcat(fname,NONUNIX_RC_FILE);
	  if( (fp=fopen(fname,"r")) == (FILE *)NULL) {
				/* no more alternatives */
	  }
	}
      }/* end if homedir != NULL */
    }
  }

  free(fname);
  return fp;
}


	/* set_option processes an option from command line.  Argument
	   s is the option string. First look if s starts with "no" or
	   "no-", and if so, check if the rest matches a boolean switch name
	   from list in switchopt[].  If it matches, corresponding
	   flag is set to FALSE.  If no match, then s is compared to
	   the same switch names without the "no", and if match is
	   found, corresponding flag is set to TRUE.  Finally, special
	   flags are handled.  If still no match, an error message is
	   generated.  */

PRIVATE void
#if HAVE_STDC
set_option(char *s, char *where)
	        		/* Option to interpret, including initial - */
	            		/* String to identify cmd line vs rc file */
#else /* K&R style */
set_option(s,where)
	char *s,		/* Option to interpret, including initial - */
	     *where;		/* String to identify cmd line vs rc file */
#endif /* HAVE_STDC */
{
	int i, offset;
		/* look for noswitch flags first since otherwise
		   an option starting with no might take precedence.
		 */
	offset=1;	/* offset is no. of chars from s[0] to switch name */
	if( strncmp(s+1,"no",2) == 0 ) {
	  offset=3;
	  if( s[offset] == '-' )	/* Allow "no" or "no-" */
	    offset=4;
	}

	if( offset != 1 ) {	/* "no" found */
	    for(i=0; i<NUM_SWITCHES; i++) {
		if( strncmp(s+offset,switchopt[i].name,OPT_MATCH_LEN) == 0) {
		    *(switchopt[i].switchflag) = FALSE;
		    return;
		}
	    }

		/* -noswitch not found: look for -nosetting flag */
	    for(i=0; i<NUM_SETTINGS; i++) {
		if( strncmp(s+offset,setting[i].name,OPT_MATCH_LEN) == 0) {
		    *(setting[i].setvalue) = setting[i].turnoff;
		    return;
		}
	    }
	}

				/* Next look for switches */
	for(i=0; i<NUM_SWITCHES; i++) {
	    if( strncmp(s+1,switchopt[i].name,OPT_MATCH_LEN) == 0) {
		*(switchopt[i].switchflag) = TRUE;
		return;
	    }
	}

		/* Handle settings of form "-opt=number" */
	for(i=0; i<NUM_SETTINGS; i++)
	    if( strncmp(s+1,setting[i].name,OPT_MATCH_LEN) == 0) {
		char *numstr;

		numstr = s + OPT_MATCH_LEN;
		while(++numstr, ! END_OF_OPT(*numstr) )
		{
		    if((*numstr == '=') || (*numstr == ':'))
		    {			/* Find the assignment operator */
			numstr++;
			break;
		    }
		}
		if(read_setting(numstr, setting[i].setvalue, setting[i].name,
				setting[i].minlimit, setting[i].maxlimit,
				setting[i].turnoff,
				setting[i].turnon,
				setting[i].min_default_value,
				setting[i].max_default_value) != 0) {
		  (void)fflush(list_fd);
		  (void)fprintf(stderr,"Setting garbled: %s: ignored\n",s);
		}
		return;
	    }


		/* Handle settings of form "-opt=string" */
	for(i=0; i<NUM_STRSETTINGS; i++) {
	    int is_a_turnoff=FALSE;

				/* First look for setting prefixed by "no"
				   if it allows turnon/turnoff. */
	    if( strsetting[i].turnoff != (char *)NULL &&
	       offset != 1 &&
	       strncmp(s+offset,strsetting[i].name,OPT_MATCH_LEN) == 0) {
	      is_a_turnoff=TRUE;
	    }

	    if(is_a_turnoff ||
	       strncmp(s+1,strsetting[i].name,OPT_MATCH_LEN) == 0) {
		char *strstart;
		int numchars;

		strstart = s + offset + OPT_MATCH_LEN;
		while( *strstart != '=' && *strstart != ':'
		      && ! END_OF_OPT(*strstart) )
			strstart++;	/* Find the = sign */
		if( END_OF_OPT(*strstart) ) {
				/* no = sign: use turnon/turnoff */
		  if(is_a_turnoff)
		    *(strsetting[i].strvalue) = strsetting[i].turnoff;
		  else
		    *(strsetting[i].strvalue) = strsetting[i].turnon;
		}
		else {		/* = sign found: use it but forbid -no form */
		    if(is_a_turnoff) {
		      (void)fflush(list_fd);
		      (void)fprintf(stderr,
			      "No string setting allowed for %s: ignored\n",s);
		      return;
		    }
		    ++strstart;	/* skip past the "=" */
				/* In VMS,MSDOS worlds, user might not leave
				   blank space between options.  If string
				   is followed by '/', must make a properly
				   terminated copy.  In any case, make a
				   copy in case this option comes from
				   the rc file. */
		    for(numchars=0;!END_OF_OPT(strstart[numchars]);numchars++)
		      continue;

		    *(strsetting[i].strvalue) = (char *)malloc(numchars+1);
		    (void)strncpy( *(strsetting[i].strvalue),
			       strstart,numchars);
		    (*(strsetting[i].strvalue))[numchars] = '\0';
		}

			/* Handle actions needed after new strsetting
			   is read. If it was a turn-on where turnon is
			   NULL, give a warning. */
		if( *(strsetting[i].strvalue) == (char *)NULL ) {
		  (void)fflush(list_fd);
		  (void)fprintf(stderr,
				"String setting missing: %s: ignored\n",s);
		}
		else {
		  update_str_options(&strsetting[i]);
		}

		return;
	    }

	}
		/* No match found: issue error message */

	(void)fflush(list_fd);
	(void)fprintf(stderr,"\nUnknown %s switch: %s\n",where,s);
}


	/* Routine to read integer setting from string s and check if valid */

PRIVATE int
#if HAVE_STDC
read_setting(char *s, int *setvalue, char *name, int minlimit, int maxlimit, int turnoff, int turnon, int min_default_value, int max_default_value)
#else /* K&R style */
read_setting(s, setvalue, name, minlimit, maxlimit, turnoff, turnon,
	     min_default_value,
	     max_default_value)
	char *s;
	int *setvalue;
	char *name;
	int minlimit, maxlimit,
	     turnon, turnoff,
	     min_default_value, max_default_value;
#endif /* HAVE_STDC */
{
	int given_val;

	if(strcmp(s,"NO")==0) {	/* -setting=no */
	  *(setvalue) = turnoff;
	}
	else if(END_OF_OPT(*s)) { /* -setting */
	  *(setvalue) = turnon;
	}
	else if(sscanf(s,"%d", &given_val) == 0) {
	    return -1;	/* error return: garbled setting */
	}
	else {		/* If outside limits, set to default */
	    int Ok=TRUE;
	    if(given_val < minlimit) {
		given_val = min_default_value;
		Ok = FALSE;
	    }
	    else if(given_val > maxlimit) {
		given_val = max_default_value;
		Ok = FALSE;
	    }

	    if(! Ok ) {
	        (void)fflush(list_fd);
		(void)fprintf(stderr,"\nSetting: %s",name);
		(void)fprintf(stderr," outside limits %d to %d",
				minlimit,maxlimit);
		(void)fprintf(stderr,": set to default %d\n",given_val);
	    }

	    *(setvalue) = given_val;
	}
	return 0;
}

			/* Handle actions needed to update things after
			   getting a non-null strsetting option.
			 */
PRIVATE void
#if HAVE_STDC
update_str_options(StrsettingList *strset)
#else /* K&R style */
update_str_options(strset)
  StrsettingList *strset;
#endif /* HAVE_STDC */
{

			/* Handle necessary action for  -out=listfile */
  if(strset->strvalue == &out_fname)
    must_open_outfile = TRUE;

				/* Update include path */
#ifdef ALLOW_INCLUDE
  if(strset->strvalue == &include_path) {
    append_include_path(include_path);
  }
#endif

				/* Handle warnings like -f77=list */
  if(strset->option_list != (WarnOptionList *)NULL) {
    char *s = *(strset->strvalue);
    int numvalue;
				/* Allow old-fashioned -flag=num for some */
    if( strset->numeric_form_handler != NULL &&
	(numvalue = str_to_num(s)) >= 0 ) {
      (*(strset->numeric_form_handler))(numvalue,strset->name);
    }
    else {
      process_warn_string(s, strset->option_list);
    }
  }
}

			/* Routine to return -1 if string is not all
                           digits and not null; otherwise returns
                           integer value of string. */
PRIVATE int
#if HAVE_STDC
str_to_num(char *s)
#else
str_to_num(s)
     char *s;
#endif
{
  int value=0;

  if( s == NULL || *s == '\0' )
    return -1;

  while( *s != '\0' ) {
    if(! isdigit(*s) )
      return -1;
    else
      value = value*10 + ((*s)-'0');
    s++;
  }
  return value;
}

#define MAX_OPT_LEN 32		/* Big enough to hold any option name */

				/* Process list of warn options.  Return
				   TRUE if "help" requested, else FALSE */
PRIVATE void
#if HAVE_STDC
process_warn_string(char *warn_string, WarnOptionList *warn_option)
                     		/* Names of options to set */
                                            /* array where options defined */
           			/* size of warn_option array */
#else /* K&R style */
process_warn_string( warn_string, warn_option )
     char *warn_string;		/* Names of options to set */
     WarnOptionList warn_option[]; /* array where options defined */
#endif /* HAVE_STDC */
{
  int i,c;
  char opt_buf[MAX_OPT_LEN+1];

  if(strcmp(warn_string,"help") == 0) { /* Print warning help screen */
    list_warn_options(warn_option);
    return;
  }
  else {
				/* Loop on warn options in string */
    while(!END_OF_OPT(*warn_string)) {
				/* Copy next warn option into buffer */
      for(i=0; !END_OF_OPT(*warn_string); ) {
	c = *warn_string++;
	if(c == ',' || c == ':') /* quit when reach next warn option */
	  break;
	if(i<MAX_OPT_LEN)
	  opt_buf[i++] = c;
      }
      opt_buf[i] = '\0';

      set_warn_option(opt_buf, warn_option );
    }
  }
  return;
}

			/* Routine to print list of warning options */
PRIVATE void
#if HAVE_STDC
list_warn_options(WarnOptionList *warn_option)
#else /* K&R style */
list_warn_options(warn_option)
     WarnOptionList warn_option[]; /* array of defns */
#endif /* HAVE_STDC */
{
  int i;

  ++actioncount;	/* Treat as an action so if no files, quit */

  (void)fprintf(list_fd,"\n%s Options:",warn_option[0].explanation);
  for(i=1; warn_option[i].name != (char *)NULL; i++) {
    (void)fprintf(list_fd,"\n  %s [%s]: %s",
	    warn_option[i].name,
	    *(warn_option[i].flag)? "yes" : "no",
	    warn_option[i].explanation);
  }
  (void)fprintf(list_fd,"\nPrefix option name with no- to turn off option");
  (void)fprintf(list_fd,"\nSpecial keywords:");
  (void)fprintf(list_fd,"\n  %s: %s","help","Print this list");
  (void)fprintf(list_fd,"\n  %s: %s","all","Set all options");
  (void)fprintf(list_fd,"\n  %s: %s","none","Clear all options");
  (void)fprintf(list_fd,"\n");
}

			/* Routine to set warning options to given values */
PRIVATE void
#if HAVE_STDC
set_warn_option(char *s, WarnOptionList *warn_option)
#else /* K&R style */
set_warn_option(s, warn_option )
     char *s;
     WarnOptionList *warn_option;
#endif /* HAVE_STDC */
{
  int i, matchlen, offset;
  int value;

  if(s == NULL)		/* This happens when -nocheck handles -intrinsic */
    return;

			/* Special keyword "all": set all options on */
  if(strcmp(s,"all") == 0) {
	for(i=1; warn_option[i].name != (char *)NULL; i++)
	  set_warn_option_value(warn_option[i].flag,TRUE);
	return;
  }
			/* Special keyword "none": set all options off */
  else if(strcmp(s,"none") == 0 ) {
	for(i=1; warn_option[i].name != (char *)NULL; i++)
	  set_warn_option_value(warn_option[i].flag,FALSE);
	return;
  }
  else {
				/* Look for "no-" prefix on option name */
    if(strncmp(s,"no-",strlen("no-")) == 0) {
      offset = strlen("no-");
      value = FALSE;
    }
    else {
      offset = 0;
      value = TRUE;
    }
				/* See if the given option has a wildcard */
    if( strchr(s,'*') == NULL ) {

				/* No wildcard: go thru list to find a
				   match at minimum nonambiguous length.
				*/
     for(i=1,matchlen=1; warn_option[i].name != (char *)NULL; i++) {
			/* Look for a match at current matchlen, then 
			  if found see if unique.  List must have names
			  with matching prefixes adjacent. */
      while(strncmp(s+offset,warn_option[i].name,matchlen) == 0) {
	if(warn_option[i+1].name == (char *)NULL ||
	   strncmp(s+offset,warn_option[i+1].name,matchlen) != 0) {
	  set_warn_option_value(warn_option[i].flag,value);
	  return;
	}
	else {
	  if(   s[offset+matchlen] == '\0'
	     || warn_option[i].name[matchlen] == '\0') {
	    (void)fflush(list_fd);
	    (void)fprintf(stderr,
		   "\nAmbiguous %s Option: %s: ignored\n",
			  warn_option[0].explanation,s);
	    return;
	  }
	  ++matchlen;
	}
      }
     }
    }
    else {
				/* Wildcard in pattern: find all matches. */
     int matches=0;
     for(i=1; warn_option[i].name != (char *)NULL; i++) {
       if( wildcard_match(s+offset,warn_option[i].name) == 0 ) {
	 ++matches;
	 set_warn_option_value(warn_option[i].flag,value);
       }
     }
				/* If nothing matched, drop out for warning */
     if(matches > 0 ) {
       return;
     }
    }
  }
  (void)fflush(list_fd);
  (void)fprintf(stderr,"\nNo Such %s Option: %s: ignored\n",
			  warn_option[0].explanation,s);
  return;
}


		/* set_warn_option_value sets values of warnlist-style flags,
		   and also handles special cases of mutually exclusive
		   flags and suchlike.
		 */
PRIVATE void 
#if HAVE_STDC
set_warn_option_value(int *flag, int value)
#else /* K&R style */
set_warn_option_value(flag, value )
     int *flag;
     int value;
#endif /* HAVE_STDC */
{
  /* handle mutual exclusions here */

  if( value && (
		    flag == &print_call_tree
		 || flag == &print_ref_list
#ifdef VCG_SUPPORT
		 || flag == &print_vcg_list
#endif
	       ) ) {

    static int *calltree_mutual_exc_flags[]={
      &print_call_tree,
      &print_ref_list,
#ifdef VCG_SUPPORT
      &print_vcg_list,
#endif
      (int *)NULL
    };
    mutual_exclude(calltree_option,"calltree",
		   flag, calltree_mutual_exc_flags);
  }
				/* Here we actually set the value. */
  *flag = value;
}

PRIVATE void
#if HAVE_STDC
mutual_exclude(  WarnOptionList wList[], char *opt_name,
		      int *thisflag, int *otherflags[] )
#else
mutual_exclude( wList, opt_name,
		      thisflag, otherflags )
     WarnOptionList wList[];
     char *opt_name;
     int *thisflag;
     int *otherflags[];
#endif
{
  int i,j, thisflag_index= -1;
				/* Find thisflag in the list */
  for(i=0; wList[i].name != NULL; i++) {
    if(wList[i].flag == thisflag) {
      thisflag_index = i;
      break;
    }
  }
  if( thisflag_index < 0 ) {
    oops_message(OOPS_FATAL,NO_LINE_NUM,NO_COL_NUM,"mutual_exclude routine");
  }
  else {
    for(j=0; otherflags[j] != NULL; j++) {

      if( otherflags[j] == thisflag ) /* thisflag cannot conflict with self */
	continue;

      if( *(otherflags[j]) ) {	/* exclusion conflict found: trace it */
	for(i=0; wList[i].name != NULL; i++) {
	  if(wList[i].flag == otherflags[j]) {
	    (void)fprintf(stderr,
	       "\nWarning: %c%s option %s overrides previous option %s\n",
#ifdef OPTION_PREFIX_SLASH
		    '/',
#else
		    '-',
#endif
		    opt_name,
		    wList[thisflag_index].name,wList[i].name);
	    break;
	  }
	}
	*(otherflags[j]) = FALSE; /* turn off the conflicting option */
      }
    }
  }
}


			/* The next few routines implement the
                          "grandfathering" of those settings that
                          were changed from numeric to warning-option
                          string form, so the numeric form will still
			  be acceptable.
			*/

PRIVATE void
#if HAVE_STDC
argcheck_numeric_option( int value, char *setting_name )
#else
argcheck_numeric_option( value, setting_name )
     int value;
     char *setting_name;
#endif
{
  if( value < 0 || value > 3) {
    numeric_option_error(setting_name,0,3);
    return;
  }
  argcheck_argnumber = ((value & 01) != 0);
  argcheck_arrayness =  argcheck_argtype = argcheck_functype = ((value & 02) != 0);
}

PRIVATE void
#if HAVE_STDC
arraycheck_numeric_option( int value, char *setting_name )
#else
arraycheck_numeric_option( value, setting_name )
     int value;
     char *setting_name;
#endif
{
  if( value < 0 || value > 3) {
    numeric_option_error(setting_name,0,3);
    return;
  }
  arraycheck_dims = ((value & 01) != 0);
  arraycheck_size = ((value & 02) != 0);
}

PRIVATE void
#if HAVE_STDC
calltree_numeric_option( int value, char *setting_name )
#else
calltree_numeric_option( value, setting_name )
     int value;
     char *setting_name;
#endif
{
  int format;
  if( value < 0 || value > 15) {
    numeric_option_error(setting_name,0,15);
    return;
  }

  format = (value & 0x3); /* Low-order two bits => output format */
			/* if no format specified, tree is default
			   provided number is nonzero. */
  print_call_tree = (format == 1) || (format == 0 && value != 0);
  print_ref_list  = (format == 2);
#ifdef VCG_SUPPORT
  print_vcg_list  = (format == 3);
#endif

  call_tree_prune = ((value & 0x4) == 0); /* Include 4 for no-prune */
  call_tree_sort  = ((value & 0x8) == 0); /* Include 8 for no-sort */
}

PRIVATE void
#if HAVE_STDC
comcheck_numeric_option( int value, char *setting_name )
#else
comcheck_numeric_option( value, setting_name )
     int value;
     char *setting_name;
#endif
{
  if( value < 0 || value > 3) {
    numeric_option_error(setting_name,0,3);
    return;
  }
  comcheck_type     = (value >= 1);
  comcheck_length   = (value >= 2);
  comcheck_dims = comcheck_by_name  = (value == 3);
/*comcheck_volatile was controlled by -volatile flag, not here. */
}


PRIVATE void
#if HAVE_STDC
intrinsic_numeric_option( int value, char *setting_name )
#else
intrinsic_numeric_option( value, setting_name )
     int value;
     char *setting_name;
#endif
{

  int intrins_set = value % 10;
  int rand_form = (value/10) % 10;
  int iargc_form = (value/100) % 10;

  if( value < 0 || intrins_set > 3 || rand_form > 2 || iargc_form > 2) {
    numeric_option_error(setting_name,0,223);
    return;
  }

  intrinsic_set_extra = (intrins_set != 0);

  intrinsic_set_unix = (intrins_set == 2);

  intrinsic_set_vms = (intrins_set == 3);

  intrinsic_rand_no_argument = (rand_form == 0 || rand_form == 2);

  intrinsic_rand_one_argument = (rand_form == 1 || rand_form == 2);

  intrinsic_iargc_no_argument = (iargc_form == 0 || iargc_form == 2);

  intrinsic_iargc_one_argument = (iargc_form == 1 || iargc_form == 2);

}

PRIVATE void
#if HAVE_STDC
makedcl_numeric_option( int value, char *setting_name )
#else
makedcl_numeric_option( value, setting_name )
     int value;
     char *setting_name;
#endif
{
  /* makedcls options, old style = sum of numbers as spelled out below */
  if( value < 0 || value > 1023 ) {
    numeric_option_error(setting_name,0,1023);
    return;
  }

 dcl_declarations			= (value != 0);
 dcl_only_undeclared			= ((value & 0x0002) != 0);
 dcl_compact				= ((value & 0x0004) != 0);
 dcl_use_continuations			= ((value & 0x0008) != 0);
 dcl_keywords_lowercase			= ((value & 0x0010) != 0);
 dcl_vars_and_consts_lowercase		= ((value & 0x0020) != 0);
 dcl_excl_sftran3_internal_vars		= ((value & 0x0040) != 0);
 dcl_asterisk_comment_character		= ((value & 0x0080) != 0);
 dcl_lowercase_comment_character	= ((value & 0x0100) != 0);
 dcl_no_array_dimensions		= ((value & 0x0200) != 0);
}

PRIVATE void
#if HAVE_STDC
source_numeric_option( int value, char *setting_name )
#else
source_numeric_option( value, setting_name )
     int value;
     char *setting_name;
#endif
{
  /* source format options, old style = sum of:
     1=DEC Fortran tab-format
     2=VMS-style INCLUDE statement
     4=UNIX-style backslash escape char
     8=implicit typing of standard-form PARAMETERs
    16=standard typing of DEC-Fortran-form PARAMETERs
  */

  if( value < 0 || value > 15 ) {
    numeric_option_error(setting_name,0,15);
    return;
  }
  source_dec_tab = ((value & 1) != 0);
  source_vms_include = ((value & 2) != 0);
  source_unix_backslash = ((value & 4) != 0);
  source_param_implicit = ((value & 8) != 0);
  source_dec_param_std_type = ((value & 0x10) != 0);
}


PRIVATE void
#if HAVE_STDC
usage_numeric_option( int value, char *setting_name )
#else
usage_numeric_option( value, setting_name )
     int value;
     char *setting_name;
#endif
{

  int var_usage = value % 10;
  int com_usage = (value/10) % 10;
  int ext_usage = (value/100) % 10;

  if( value < 0 || var_usage > 3 || com_usage > 3 || ext_usage > 3 ) {
    numeric_option_error(setting_name,0,333);
    return;
  }
			/* Set flag variables according to the old rules:
			   ones digit = vars, tens = com, hundreds = ext
			   1 = used-not-defined, 2 = unused, 3 = all

			   Note: the variable com-block-volatile is not
			   touched here.
			*/

  usage_var_uninitialized = usage_arg_modified =
    usage_arg_alias_modified = usage_array_alias_modified =
    usage_arg_common_modified = usage_array_common_modified = ((var_usage & 0x1)!=0);

  usage_var_set_unused = usage_var_unused = ((var_usage & 0x2)!=0);

  usage_com_var_uninitialized = ((com_usage & 0x1)!=0);

  usage_com_var_set_unused = usage_com_block_unused =
    usage_com_var_unused = ((com_usage & 0x2)!=0);

  usage_ext_multiply_defined = usage_ext_declared_only =
    usage_ext_undefined = ((ext_usage & 0x1)!=0);

  usage_ext_unused = ((ext_usage & 0x2)!=0);

}

PRIVATE void
#if HAVE_STDC
numeric_option_error( char *setting_name, int minlimit, int maxlimit )
#else
numeric_option_error( setting_name, minlimit, maxlimit )
     char *setting_name;
     int minlimit;
     int maxlimit;
#endif
{
    (void)fflush(list_fd);
    (void)fprintf(stderr,"\nSetting: %s outside limits %d to %d",
		  setting_name,minlimit,maxlimit);
    (void)fprintf(stderr,": setting ignored\n");
}


	/* Routine to turn off all switches and numeric settings except
	   -word and -wrap.  The effect is as if -no had been given
	   for each switch and setting.  Useful when other features
	   like calltree are being used and checking is not needed.
	*/
PRIVATE void turn_off_checks(VOID)
{
	int i;

				/* Put all switches to FALSE */
	for(i=0; i<NUM_SWITCHES; i++) {
	  if(switchopt[i].isacheck == IS_A_CHECK)
	    *(switchopt[i].switchflag) = FALSE;
	}

				/* Put all settings to turnoff value */
	for(i=0; i<NUM_SETTINGS; i++) {
	  if(setting[i].isacheck == IS_A_CHECK)
	    *(setting[i].setvalue) = setting[i].turnoff;
	}

				/* Turn off warn lists */
	for(i=0; i<NUM_STRSETTINGS; i++) {
	  if( strsetting[i].isacheck == IS_A_CHECK
	    && strsetting[i].option_list != (WarnOptionList *)NULL ) {
	    set_warn_option( strsetting[i].turnoff,
			      strsetting[i].option_list);
				/* Set strvalue so -help reports correctly */
	    *(strsetting[i].strvalue) = strsetting[i].turnoff;
	  }
	}
				/* Turn off checks without own options */
	misc_warn = FALSE;

}

				/* Routine to compare a string str against
				   a pattern pat, which can contain '*' to
				   match any character string.  Returns 0
				   (like strcmp) if match, 1 if not.
				*/
PRIVATE int
#if HAVE_STDC
wildcard_match(char *pat, char *str)
#else /* K&R style */
wildcard_match(pat, str)
  char *pat;
  char *str;
#endif /* HAVE_STDC */
{
  register char *s, *p;			/* pointers that run thru each */
  register int sc, pc;			/* current str char and pat char */
  s = str;
  p = pat;
  for( pc = *p++, sc = *s++; pc != '\0'; pc = *p++, sc = *s++ ) {
    if( pc != '*' ) {
      if(sc != pc) {
	return 1;		/* mismatch found */
      }
    }
    else {			/* wildcard found */
      do {
	pc = *p++;
      } while( pc == '*' );	/* skip past the wildcard */

      if(pc == '\0') {
	return 0;		/* pattern ends with '*' => match */
      }
      else {
				/* Try to match rest of patt with str starting
				   at some point from here to end. We do a
				   small optimization to avoid the recursive
				   call in many cases. */
	while(sc != '\0') { 
	  if( sc == pc && wildcard_match(p,s) == 0 )
	    return 0;
	  sc = *s++;
	}
	return 1;		/* No match found */
      }
    }
  }
  return (sc != '\0');		/* End of pattern: OK if end of string */
}


PRIVATE void
#if HAVE_STDC
open_outfile(char *s)		/* open the output file for listing */
#else /* K&R style */
open_outfile(s)		/* open the output file for listing */
	char *s;
#endif /* HAVE_STDC */
{
	char *fullname;		/* given name plus extension */
	FILE *fd;

	must_open_outfile = FALSE;	/* Turn off the flag */

	if(s == (char *) NULL || *s == '\0') {
		return;		/* No filename: no action  */
	}

	fullname = add_ext(s,DEF_LIST_EXTENSION);
	(void)fflush(list_fd);
	if( (fd = fopen(fullname,"w")) == (FILE *)NULL) {
		(void)fprintf(stderr,"\nCannot open %s for output\n",fullname);
	}
	else {
		(void)fprintf(stderr,"\nOutput sent to file %s\n",fullname);
		list_fd = fd;
	}
}


PRIVATE void
#if HAVE_STDC
list_options(FILE *fd)/* List all commandline options, strsettings, and settings */
#else /* K&R style */
list_options(fd)/* List all commandline options, strsettings, and settings */
     FILE *fd;
#endif /* HAVE_STDC */
{
	int i;

			/* Print the copyright notice */
	(void)fprintf(fd,"\n%s",COPYRIGHT_DATE);
	(void)fprintf(fd,"\n%s\n",COPYRIGHT_NOTICE);

		/* Note: Headings say "default" but to be accurate they
		   should say "current value".  This would be confusing. */
	(void)fprintf(fd,"\nCommandline options [default]:");
	for(i=0; i<NUM_SWITCHES; i++) {

	  if( !debug_latest &&
	     strncmp(switchopt[i].explanation,"debug",5) == 0)
	    continue;		/* skip debug switches unless debug mode */

	  (void)fprintf(fd,"\n    %c[no]%s",OPT_PREFIX,switchopt[i].name);
	  (void)fprintf(fd," [%s]",*(switchopt[i].switchflag)? "yes": "no");
	  (void)fprintf(fd,": %s",switchopt[i].explanation);
	}
		/* String settings follow switches w/o their own heading */
	for(i=0; i<NUM_STRSETTINGS; i++) {
	  if( !debug_latest &&
	     strncmp(strsetting[i].explanation,"debug",5) == 0)
	    continue;		/* skip debug settings unless debug mode */

	  (void)fprintf(fd,"\n    %c%s=str ",OPT_PREFIX,strsetting[i].name);
			/* If strvalue has been given, list it.  Otherwise,
			   if this has an optionlist, the default value is
			   given as 'name' of option 0, which is the title
			   entry of the list.
			*/
	  (void)fprintf(fd,"[%s]",
		*(strsetting[i].strvalue)?
			*(strsetting[i].strvalue):
			strsetting[i].option_list != (WarnOptionList *)NULL?
			   strsetting[i].option_list[0].name:
			   "NONE");
	  (void)fprintf(fd,": %s",strsetting[i].explanation);
	  if( strsetting[i].option_list != (WarnOptionList *)NULL )
	    (void)fprintf(fd,"\n        Use %c%s=help for list of options",
#ifdef OPTION_PREFIX_SLASH
			  '/',
#else
			  '-',
#endif
			  strsetting[i].name);
	}

	(void)fprintf(fd,"\nSettings (legal range) [default]:");
	for(i=0; i<NUM_SETTINGS; i++) {

	  if( !debug_latest &&
	     strncmp(setting[i].explanation,"debug",5) == 0)
	    continue;		/* skip debug settings unless debug mode */

	  (void)fprintf(fd,"\n    %c%s=dd ",OPT_PREFIX,setting[i].name);
	  (void)fprintf(fd,"(%d to %d) ",setting[i].minlimit,
		  setting[i].maxlimit);
	  (void)fprintf(fd,"[%d]",*(setting[i].setvalue));
	  (void)fprintf(fd,": %s",setting[i].explanation);
	}

    (void)fprintf(fd,
	"\n(First %d chars of option name significant)\n",OPT_MATCH_LEN);
}


PRIVATE void
wrapup(VOID)	/* look at cross references, etc. */
{

	if(debug_hashtab || debug_glob_symtab)
	  debug_symtabs();

				/* VCG output file uses stem of file
				   containing main prog or 1st file on
				   command line. If none, output is to stdout.
				 */
#ifdef VCG_SUPPORT
	if(print_vcg_list) {
	  vcg_fd = (input_fd == stdin || main_filename == (char *)NULL)?
	    stdout :
	    fopen(new_ext(main_filename,DEF_VCG_EXTENSION) ,"w");
	}
#endif

	visit_children();	/* Make call tree & check visited status */
	check_com_usage();	/* Look for unused common stuff */
	check_comlists();	/* Look for common block mismatches */
	check_arglists();	/* Look for subprog defn/call mismatches */

#ifdef DEBUG_GLOBAL_STRINGS
	if(debug_latest)
	  print_global_strings();
#endif
}


#define MODE_DEFAULT_EXT 1
#define MODE_REPLACE_EXT 2
PRIVATE char *
#if HAVE_STDC
append_extension(char *s, char *ext, int mode)
#else /* K&R style */
append_extension(s,ext,mode)
     char *s,*ext;
     int mode;
#endif /* HAVE_STDC */
{
		/* MODE_DEFAULT_EXT: Adds extension to file name s if
		   none is present, and returns a pointer to the
		   new name.  If extension was added, space is allocated
		   for the new name.  If not, simply  returns pointer
		   to original name.  MODE_REPLACE_EXT: same, except given
		   extension replaces given one if any.
		*/
	int i,len;
	char *newname;
#ifdef OPTION_PREFIX_SLASH	/* set len=chars to NUL or start of /opt */
	for(len=0; s[len] != '\0' && s[len] != '/'; len++)
	  continue;
#else
	len=(unsigned)strlen(s);
#endif
		/* Search backwards till find the dot, but do not
		   search past directory delimiter
		*/
	for(i=len-1; i>0; i--) {
	    if(s[i] == '.'
#ifdef UNIX
	       || s[i] == '/'
#endif
#ifdef VMS
	       || s[i] == ']' || s[i] == ':'
#endif
#ifdef MSDOS
	       || s[i] == '\\' || s[i] == ':'
#endif
	       )
		break;
	}

	if(mode == MODE_REPLACE_EXT) {
	  if(s[i] == '.')	/* declare length = up to the dot */
	    len = i;
	  newname = (char *) malloc( (unsigned)(len+(unsigned)strlen(ext)+1) );
	  (void)strncpy(newname,s,len);
	  (void)strcpy(newname+len,ext);
	}
	else {			/* MODE_DEFAULT_EXT */
#ifdef OPTION_PREFIX_SLASH
		/* create new string if new ext or trailing /option */
	  if(s[i] != '.' || s[len] != '\0') {
	    if(s[i] != '.') {	/* no extension given */
	      newname = (char *) malloc( (unsigned)(len+
						    (unsigned)strlen(ext)+1) );
	      (void)strncpy(newname,s,len);
	      (void)strcpy(newname+len,ext);
	    }
	    else {		/* extension given but /option follows */
	      newname = (char *) malloc( (unsigned)(len+1) );
	      (void)strncpy(newname,s,len);
	    }
	  }
#else
	  if(s[i] != '.') {
	    newname = (char *) malloc( (unsigned)(len+
						  (unsigned)strlen(ext)+1) );
	    (void)strcpy(newname,s);
	    (void)strcat(newname,ext);
	  }
#endif
	  else {
	    newname = s;	/* use as is */
	  }
	}

	return newname;
}

		/* Adds default extension to source file name, replacing
		   any that is present, and returns a pointer to the
		   new name.  Space is allocated for the new name.
		*/
char *
#if HAVE_STDC
add_ext(char *s, char *ext)			/* adds default filename extension to s */
#else /* K&R style */
add_ext(s,ext)			/* adds default filename extension to s */
	char *s,*ext;
#endif /* HAVE_STDC */
{
  return append_extension(s,ext,MODE_DEFAULT_EXT);
}

PRIVATE char *
#if HAVE_STDC
new_ext(char *s, char *ext)
#else /* K&R style */
new_ext(s,ext)
	char *s,*ext;
#endif /* HAVE_STDC */
{
  return append_extension(s,ext,MODE_REPLACE_EXT);
}


PRIVATE int
#if HAVE_STDC
cistrncmp(char *s1, char *s2, unsigned int n)			/* case-insensitive strncmp */
#else /* K&R style */
cistrncmp(s1,s2,n)			/* case-insensitive strncmp */
     char *s1,*s2;
     unsigned n;
#endif /* HAVE_STDC */
{
  while( n != 0 &&
      (isupper(*s1)?tolower(*s1):*s1) == (isupper(*s2)?tolower(*s2):*s2) ) {
    if(*s1 == '\0')
      return 0;
    if(*s2 == '\0')
      break;
    ++s1; ++s2; --n;
  }
  return n==0? 0: *s1 - *s2;
}

int
#if HAVE_STDC
has_extension(char *name, char *ext)		/* true if name ends in ext */
#else /* K&R style */
has_extension(name,ext)		/* true if name ends in ext */
  char *name,*ext;
#endif /* HAVE_STDC */
{
  unsigned name_len, ext_len;
  int stem_len;
  ext_len = strlen(ext);

#ifdef VMS	/* shell_glob adds version number: filename.ext;1 */
  if(strrchr(name,';') != (char *)NULL) {
    name_len = strrchr(name,';') - name; /* distance to the semicolon */
  }
  else
#endif
    name_len=strlen(name);	/* distance to the null */

  stem_len = (unsigned)(name_len - ext_len); /* distance to the dot */

  if( stem_len >= 0 &&
     (name_len-stem_len) == ext_len &&
     cistrncmp(name+stem_len,ext,ext_len) == 0 )
    return TRUE;
  else
    return FALSE;
}

		/* Add an include directory path to list of paths */
#ifdef ALLOW_INCLUDE
PRIVATE void
#if HAVE_STDC
append_include_path(char *new_path)
#else /* K&R style */
append_include_path(new_path)
     char *new_path;
#endif /* HAVE_STDC */
{
  IncludePathNode *new_path_node, *p;
  if((new_path_node=(IncludePathNode *)malloc(sizeof(IncludePathNode)))
     ==(IncludePathNode *)NULL) {
    (void)fflush(list_fd);
    (void)fprintf(stderr,"\nmalloc error getting path list");
  }
  else {
    new_path_node->link = (IncludePathNode *)NULL;
    new_path_node->include_path = new_path;
				/* Append the new node at end of list */
    if((p=include_path_list) == (IncludePathNode *)NULL)
      include_path_list = new_path_node;
    else {
      while(p->link != (IncludePathNode *)NULL)
	p = p->link;
      p->link = new_path_node;
    }
  }
#ifdef DEBUG_INCLUDE_PATH	/* Print path as it grows */
  if(getenv("DEBUG")) {
    (void)fprintf(list_fd,"\nINCLUDE path=");
    for(p=include_path_list; p != (IncludePathNode *)NULL; p=p->link) {
      (void)fprintf(list_fd,"%s ",p->include_path);
    }
    (void)fprintf(list_fd,"\n");
  }
#endif
}
#endif/*ALLOW_INCLUDE*/

PRIVATE void
resource_summary(VOID)
{
#ifdef DEBUG_SIZES
  if(debug_latest)
    print_sizeofs();	/* give sizeof various things */
#endif

  (void)fprintf(list_fd,
   "\n     Here are the amounts of ftnchek's resources that were used:\n");

  (void)fprintf(list_fd,
   "\nSource lines processed = %lu statement + %lu comment = %lu total",
		tot_stmt_line_count,
		tot_line_count-tot_stmt_line_count, /*tot_comment_line_count*/
		tot_line_count);

  (void)fprintf(list_fd,
   "\nTotal executable statements = %lu, max in any module = %lu",
		tot_exec_stmt_count,
		max_exec_stmt_count);

  (void)fprintf(list_fd,
   "\nTotal number of modules in program = %lu",
		tot_module_count);

  (void)fprintf(list_fd,
   "\nMax identifier name chars used = %lu local, %lu global, chunk size %lu",
			max_loc_strings,
			glob_strings_used,
			(unsigned long)STRSPACESZ);
  (void)fprintf(list_fd,
    "\nMax token text chars used = %lu, chunk size %lu ",
			max_srctextspace,
			(unsigned long)STRSPACESZ);
  (void)fprintf(list_fd,
    "\nMax local symbols used =  %lu out of %lu available",
			max_loc_symtab,
			(unsigned long)LOCSYMTABSZ);
  (void)fprintf(list_fd,
    "\nMax global symbols used = %lu out of %lu available",
			max_glob_symtab,
			(unsigned long)GLOBSYMTABSZ);
  (void)fprintf(list_fd,
    "\nMax number of parameter info fields used = %lu, chunk size = %lu",
			max_paraminfo,
			(unsigned long)PARAMINFOSPACESZ);
  (void)fprintf(list_fd,
    "\nMax number of tokenlists used = %lu, chunk size = %lu",
			max_tokenlists,
			(unsigned long)TOKHEADSPACESZ);
  (void)fprintf(list_fd,
    "\nMax token list/tree space used = %lu, chunk size = %lu",
			max_token_space,
			(unsigned long)TOKENSPACESZ);
  (void)fprintf(list_fd,
    "\nNumber of subprogram invocations = %lu totaling %lu args",
			arglist_head_used,
			arglist_element_used);
  (void)fprintf(list_fd,
    "\nArgument list header and element chunk sizes = %lu and %lu",
			(unsigned long)ARGLISTHEADSZ,
			(unsigned long)ARGLISTELTSZ);
  (void)fprintf(list_fd,
    "\nNumber of common block decls = %lu totaling %lu variables",
			comlist_head_used,
			comlist_element_used);
  (void)fprintf(list_fd,
    "\nCommon list header and element chunk sizes = %lu and %lu",
			(unsigned long)COMLISTHEADSZ,
			(unsigned long)COMLISTELTSZ);
  (void)fprintf(list_fd,
    "\nNumber of array dim ptrs used = %lu, chunk size = %lu",
			max_ptrspace,
			(unsigned long)PTRSPACESZ);

#ifdef DEBUG_SIZES
  (void)fprintf(list_fd,
    "\nIdentifier hashtable size = %6lu",
			(unsigned long)HASHSZ);
#ifdef KEY_HASH/* not used any more*/
  (void)fprintf(list_fd,
    "\nKeyword hashtable size = %6lu",
			(unsigned long)KEYHASHSZ);
#endif
#ifdef COUNT_REHASHES
  (void)fprintf(list_fd,
    "\nIdentifier rehash count = %6lu",
			rehash_count);
#endif
  (void)fprintf(list_fd,
    "\nIntrinsic function hashtable size=%6lu, clash count=%lu",
			(unsigned long)INTRINS_HASHSZ,
			intrins_clashes);
#endif /*DEBUG_SIZES*/

  (void)fprintf(list_fd,"\n\n");
}