ftnchek.c

这是一个Linux下的集成开发环境

	if (hig_fp && hig_fp != out_fp)
		fclose(hig_fp);

	Paf_Pipe_Close();

	if (encoding) {
	    Tcl_FreeEncoding(encoding);
	    Tcl_Finalize();
	}

	exit(0);

	return 0;/* make lint happy */
}

PRIVATE void
src_file_in(infile)
     char *infile;		/* input filename */
{
	if (infile)
		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(port_check && tab_count != 0) {
	  nonportable(NO_LINE_NUM,NO_COL_NUM,
		      "File contains tabs");
	}

	error_summary(infile);
}


PRIVATE void
error_summary(fname)		/* Print out count of errors in file */
	char *fname;
{
#ifdef ERROR_MESS
	FILE *fd = list_fd;

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

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

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

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

	error_count = 0;
	warning_count = 0;
#endif
}

#if 0
PRIVATE void
print_version_number()
{
  if(full_output || verbose)
    fprintf(list_fd,"\n");
  fprintf(list_fd,"%s",VERSION_NUMBER);
  if(help_screen)
    fprintf(list_fd," %s",PATCHLEVEL);
  if(full_output || verbose)
    fprintf(list_fd,"\n");
}
#endif

void
print_a_line(fd,line,num)  /* Print source line with line number */
	FILE *fd;
	char *line;
	unsigned num;
{
	fprintf(fd,"\n %6u %s",num,line);
}


int
yyerror(s)
	char *s;
{
#ifdef ERROR_MESS
	syntax_error(line_num,col_num,s);
#endif
	return 0;
}


void
syntax_error(lineno,colno,s)		/* Syntax error message */
	unsigned lineno,colno;
	char *s;
{
#ifdef ERROR_MESS
	++error_count;
	error_message(lineno,colno,s,"Error");
#endif
}

void
warning(lineno,colno,s)		/* Print warning message */
	unsigned lineno,colno;
	char *s;
{
#ifdef ERROR_MESS
	++warning_count;
	error_message(lineno,colno,s,"Warning");
#endif
}

void
ugly_code(lineno,colno,s)		/* -pretty message */
	unsigned lineno,colno;
	char *s;
{
#ifdef ERROR_MESS
	++warning_count;
	error_message(lineno,colno,s,"Possibly misleading appearance");
#endif
}

void
nonstandard(lineno,colno)
     unsigned lineno,colno;
{
#ifdef ERROR_MESS
	++warning_count;
	error_message(lineno,colno,"Nonstandard syntax","Warning");
#endif
}

void
nonportable(lineno,colno,s) /* Print warning about nonportable construction */
	unsigned lineno,colno;
	char *s;
{
#ifdef ERROR_MESS
	++warning_count;
	error_message(lineno,colno,s,"Nonportable usage");
#endif
}

/* 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.
*/

#ifdef ERROR_MESS
PRIVATE int errmsg_col;
#endif
	/* 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)))

#ifdef ERROR_MESS
PRIVATE void
error_message(lineno,colno,s,tag)
	unsigned lineno,colno;
	char *s,*tag;
{
  if(novice_help)
    oldstyle_error_message(lineno,colno,s,tag);
  else
    lintstyle_error_message(lineno,colno,s,tag);
}

PRIVATE void
lintstyle_error_message(lineno,colno,s,tag)
	unsigned lineno,colno;
	char *s,*tag;
{
	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 */
		    fprintf(list_fd,"\n%8s","");

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

	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) {
		fprintf(list_fd,
		   ", near line %u",lineno);
		errmsg_col += 12+NUM_DIGITS(lineno);
	    }
	    else if(colno != 0) {
		fprintf(list_fd,
		   ", line %u col %u",lineno,colno);
		errmsg_col += 12+NUM_DIGITS(lineno);
	    }
	    else {		/* colno == 0 */
		fprintf(list_fd,
		   ", near line %u",prev_stmt_line_num);
		errmsg_col += 12+NUM_DIGITS(lineno);
	    }
	}

	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
oldstyle_error_message(lineno,colno,s,tag)
	unsigned lineno,colno;
	char *s,*tag;
{
	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 */
	  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 */
		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 */
		    fprintf(list_fd,"\n%8s","");

		    for(icol=1; icol<colno; icol++)
			fprintf(list_fd," ");
		    fprintf(list_fd,"^");
		}
		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);
		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 */
	    fprintf(list_fd," in");
	    errmsg_col += 3;
	  }
	  fprintf(list_fd," file %s",current_filename);
	  errmsg_col += 6+(unsigned)strlen(current_filename);
	}

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

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

		/* 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
msg_tail(s)
    char *s;
{
#ifdef ERROR_MESS
	int wordstart,wordend,leading_skip,wordchars;

	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) {
	    fprintf(list_fd,"\n");
	    errmsg_col = wordchars;
	  }
				/* Print the word */
	  while(wordstart < wordend) {
	    fputc(s[wordstart++],list_fd);
	  }
	}
#endif
}


void
oops_message(severity,lineno,colno,s)
	int severity;
	unsigned lineno,colno;
	char *s;
{
#ifdef ERROR_MESS
    {
	fprintf(stderr,"\nOops");
	if(lineno != NO_LINE_NUM) {
	  fprintf(stderr," at line %u",lineno);
	  if(colno != NO_COL_NUM)
	    fprintf(stderr," at col %u",colno);
	}
	fprintf(stderr," in file %s",current_filename);
	fprintf(stderr," -- %s",s);
	if(severity == OOPS_FATAL) {
	  fprintf(stderr,"\nFtnchek aborted\n");
	  (void) exit(1);
	}
    }
#endif
}

void
oops_tail(s)
	char *s;
{
#ifdef ERROR_MESS
    {
	fprintf(stderr," %s",s);
    }
#endif
}

/*	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()
{
	char env_option_name[32];
	char *value;
	int i;
	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].turnoff) != 0)
			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) {
		    *(strsetting[i].strvalue) = value;

			/* Handle necessary action for  -out=listfile */
		if(strsetting[i].strvalue == &out_fname)
			must_open_outfile = TRUE;
	    }
	}
}

		/* Routine to concatenate ENV_PREFIX onto option name
		   and uppercase the result.
		*/
PRIVATE void
make_env_name( env_name, option_name)