|
|
/*===================================================================
THE ORDER IN WHICH FUNCTIONS ARE DEFINED
boolean isvaxalpha(int ch)
int delete_spaces(char string[])
int char_in_string(int ch, char string[])
int getsch(P_STATEMENT statement, P_POSITION pos, boolean long_lines)
int skip_ov_string(boolean skip_comments, P_STATEMENT statement,
P_POSITION pos)
void find_statement_end(P_STATEMENT statement, P_POSITION pos)
boolean compare_chars(int ch, P_STATEMENT statement, P_POSITION pos)
boolean find_string(P_STATEMENT statement, P_POSITION start_pos,
P_POSITION end_pos, char string[], int *ch)
int firstnonblank(char string[])
boolean iscomment(char text_line[], int text_len)
boolean iscont(char text_line[])
boolean issepar(int ch)
boolean isinclude(boolean file_open, P_STATEMENT statement,
P_INCLUDE_FILES incf)
int get_line(char curr_line[], int *line_len, char line_mark[],
boolean read_marks, INCLUDE_FILES *incf, int maxline)
boolean isend(char text_line[])
boolean get_statement(P_STATEMENT statement, P_INCLUDE_FILES incf,
boolean read_marks, boolean write_marks,
boolean intra_comments, boolean do_not_include,
int maxline, FILE *aux1)
void putsch(P_STATEMENT statement, P_POSITION pos, int ch, char line_mark[])
void convert_extended_statement(P_STATEMENT statement,
P_STATEMENT aux_statement,
int maxline,
boolean remove_comments,
FILE *auxf)
boolean decomment(boolean remove_comments, boolean write_marks,
P_STATEMENT statement, FILE *aux1)
void check_option_conflict(int argc, char *argv[],
char conflicting_options[], char valoptions[])
void unknown_option(int argc, char *argv[],
char allowed_options[], char valoptions[])
int find_option(int argc, char *argv[], char option, char option_string[])
boolean cut(P_STATEMENT statement, P_POSITION start, P_POSITION end,
int maxline, char string[], int maxslen)
boolean paste(P_STATEMENT statement, P_POSITION pos, P_POSITION pose,
int maxline, char string[])
boolean convert_to_decimal(P_STATEMENT statement, int maxline)
long extract_label(P_STATEMENT statement)
boolean change_label_field(long label, P_STATEMENT statement)
int find_label_position(long label, P_LABELS labels)
boolean save_label(long label, P_LABELS labels)
long fetch_new_label(long seed_label, P_LABELS labels)
long get_label(P_STATEMENT statement, P_POSITION start_pos,
P_POSITION end_pos, int *ch)
int isdo(P_POSITION do_starts, P_POSITION do_ends, P_POSITION label_starts,
P_POSITION label_ends, long *do_label, P_STATEMENT statement)
boolean isassign(P_STATEMENT statement, P_POSITION start_pos,
P_LABLIST label_list)
boolean isgoto(P_STATEMENT statement, P_POSITION start_pos,
P_LABLIST label_list)
boolean isif(P_STATEMENT statement, P_POSITION start_pos,
P_LABLIST label_list)
boolean change_labels_in_statement(P_STATEMENT statement, int n_do_labels,
long do_labels[], int maxline)
boolean convert_accept_type(P_STATEMENT statement, int maxline)
boolean find_equal(P_STATEMENT statement, P_POSITION equal_pos)
boolean type_declarations(P_STATEMENT statement,
P_STATEMENT data_statement,
boolean convert_types,
int maxline)
void write_statement(P_STATEMENT statement, boolean write_marks,
FILE *outfile)
========================================================================*/
/* Options:
-i filename input file name (-i may be omitted), if none stdin
-o filename output file name (-o may be omitted), if none stdout
-n ddd maximum length of the line, chars in column ddd or
larger are truncated. Default is 80.
-r remove in-line comments and place them before the
statement as regular comments (defults is do not
change them)
-R remove in line comments (they are gone...)
-l change letters to lowercase outside comments and strings
-u change letters to uppercase outside comments and strings
-a convert ACCEPT/TYPE to READ/WRITE
-x convert octal and hex constants
-t convert types and sizes in type declarations
-E EXTENDED_SOURCE lines
-L output will contain line numbers
-S perform all conversions to more standard FORTRAN
-I do not include INCLUDE files in out file
-d debugg option, temporary files not deleted
-h help
*/
#ifdef SUNC
#undef SUNC
#endif
#define SUNC 1 /* if 1 then SUNC C compiler, 0 standard C */
#include
#include
#include
#if SUNC
#define remove unlink
#define SEEK_SET 0
#else
#include
#endif
#define boolean int
#define TRUE 1
#define FALSE 0
#define MAXHEX 15 /* maximum number of chars in hex const */
#define MAXOCT 20 /* maximum number of chars in oct const */
#define MAXINCLUDE 10 /* maximum depth of include file
nesting */
#define SEPAR "/,.(-+*=:" /* characters considered separators
which can be found before Hollerith */
#define INCSTAT "INCLUDE" /* include statement syntax (no spaces)*/
#define INCFSTART "\'\"(" /* chars which start file name */
#define INCFEND "\'\"()" /* chars which end file name */
#define MAXCONT 100 /* max number of continuation lines */
#define MAXLABELS 1000 /* max number of labels in a subroutine */
#define MAXLABLIST 100 /* max number of labels on the computed or
assigned GOTO statement */
#define MAXLINE 133 /* maximum code line length incl \0 */
#define OPTIONS "rRluionLtSxahdIE" /* options defined for this program */
#define VALUEOPTIONS "ion" /* options which have values */
#define NOGOTO 0 /* If statement is not GOTO */
#define UNCGOTO 1 /* unconditional GOTO label */
#define COMPGOTO 2 /* computed GOTO (lab1, lab2....) [,] I */
#define ASSGOTO 3 /* assigned GOTO I [[,] (lab1, lab2...)]*/
#define NOIF 0 /* not IF statement */
#define ARTHIF 1 /* IF(expr)lab1, lab2, lab3 */
#define LOGIF 2 /* IF(expr) statement */
#define BLOCKIF 3 /* IF(expr) THEN .... ENDIF */
#define NOTDOLOOP 0 /* not a DO loop */
#define DOLOOPUNL 1 /* unlabeled DO...ENDDO */
#define DOLOOPLAB 2 /* DO labeled loop */
#define DOWHILEUNL 3 /* unlabeled DO WHILE ... ENDDO */
#define DOWHILELAB 4 /* labeled DO label WHILE ... */
#define MAXDONEST 20 /* maximum level of DO nesting */
#define MAXNAMELEN 80 /* length of longest file name */
#define MAXEXTRLEN 500 /* maximum string length to extract */
#define MAXCONSTL 4000 /* maximum length of constant list */
typedef struct
{
char s[MAXCONT][MAXLINE]; /* holds lines of the statment */
int nc; /* number of continuation lines */
char m[MAXCONT][10]; /* line markers dd,dddddd */
} STATEMENT; /* structure holding FORTRAN statement */
typedef STATEMENT *P_STATEMENT;
typedef struct
{
int ni; /* number of opened include files */
FILE *inf[MAXINCLUDE]; /* file pointer of opened files */
char in[MAXINCLUDE][MAXNAMELEN]; /* file names of opened files */
long n_lin[MAXINCLUDE]; /* number of lines read from file */
char ll[MAXINCLUDE][MAXLINE]; /* last line read from the file */
char lm[MAXINCLUDE][10]; /* last mark in the file */
} INCLUDE_FILES;
/* current depth of include files
ni = 0, input file
ni = 1, include from input file
ni = 2, include from include
etc. */
typedef INCLUDE_FILES *P_INCLUDE_FILES;
typedef struct
{
int cn; /* position of char on statement line */
int ln; /* continuation line number */
} POSITION;
typedef POSITION *P_POSITION;
typedef struct /* this structure holds labels for */
{ /* current routine */
int n_lab;
long l[MAXLABELS];
} LABELS;
typedef LABELS *P_LABELS;
typedef struct /* This structure holds list of labels */
{ /* e.g. from computed GOTO statement */
int n_l; /* no. of labels in the list (-1 none) */
long lab[MAXLABLIST]; /* labels */
POSITION lstart[MAXLABLIST]; /* position where label starts */
POSITION lend[MAXLABLIST]; /* position where label ends */
} LABLIST;
typedef LABLIST *P_LABLIST;
/*==========================================================================*/
boolean
EOF_found, /* if EOF found in input file */
program_end; /* TRUE if end of input file */
/*==========================================================================*/
/*==========================================================================*/
/* isvaxalpha() checks if character ch is a letter, $ or _ (chars which can
appear in VAX variable name. Returns TRUE of FALSE. */
#if SUNC
boolean isvaxalpha(ch)
int ch;
#else
boolean isvaxalpha(int ch)
#endif
{
if((isalpha(ch) != 0) || (ch == '$') || (ch == '_'))
return(TRUE);
else
return(FALSE);
}
/*=================================================================*/
/* function delete_spaces deletes spaces at the end of the string.
Returns length of truncated string. */
#if SUNC
int delete_spaces(string)
char string[];
#else
int delete_spaces(char string[])
#endif
{
int l;
l = strlen(string) - 1;
while (l >= 0)
{
if(isspace(string[l]) != 0) /* if space */
l--;
else
break;
}
l++;
string[l] = '\0';
return(l);
}
/*==========================================================================*/
/* function char_in_string returns position of char ch in string if char
is present or 0 if char is not present. First char in string is 1, second
is 2, etc. For example char_in_string('b',"abcd") returns 2. '\0' is not
included
*/
#if SUNC
int char_in_string(ch, string)
char ch;
char string[];
#else
int char_in_string(int ch, char string[])
#endif
{
int i;
int ch1;
i = 0;
while ( (ch1 = string[i++]) != '\0' )
{
if(ch1 == ch)
return(i);
}
return(0);
}
/*==========================================================================*/
/* function getsch() gets next character from statement. If no more
chars in the statement then EOF is returned. It operates on structure
called position (it is just a column and line of the statement:
cn, ln, On exit from routine, they point to the place
where last char was taken. If long lines is TRUE, statement lines
are read beyond column 72 (to process EXTENDED statements of VAX FORTRAN).
*/
#if SUNC
int getsch(statement, pos, long_lines)
P_STATEMENT statement;
P_POSITION pos;
boolean long_lines;
#else
int getsch(P_STATEMENT statement, P_POSITION pos, boolean long_lines)
#endif
{
POSITION old_pos;
old_pos = *pos;
pos->cn++;
if( ((long_lines == FALSE) && (pos->cn >= 72)) ||
(statement->s[pos->ln][pos->cn] == '\0'))
{
if(pos->ln == statement->nc)
return(EOF);
pos->cn = 6;
pos->ln++;
}
return(statement->s[pos->ln][pos->cn]);
}
/*======================================================================*/
/* function skip_ov_string reads the next character from the statement
array and if it is a beginning of the string, it moves pointer in
the current statemenmt to a character following the string
(be it a string enclosed in quotes or a string given by a Hollerith
constant). If character on entry was a space, the routine returns first
non blank character after the space. If this character is an opening
string quote, the first non blank character after quote will be returned.
If current character opens a Hollerith constant (e.g. 4Habcd ),
the first non blank character after expression is returned.
If there are no more characters in the statement the EOF is returned.
If skip_comments is set to TRUE, routine skips in-line comments
(comments starting with !). If skip_comments is false, routine
returns ! char when found. If you call the routine when
your statement pointer is within a string or within comment,
you will get garbage. */
#if SUNC
int skip_ov_string(skip_comments, statement, pos)
boolean skip_comments;
P_STATEMENT statement;
P_POSITION pos;
#else
int skip_ov_string(boolean skip_comments, P_STATEMENT statement,
P_POSITION pos)
#endif
{
int i, ch, l, k, cho;
char H_count[7];
POSITION spos;
ch = ' ';
Start:
if(ch == EOF)
return(EOF);
do { ch = getsch(statement, pos, FALSE); } /* skip spaces */
while ( (isspace(ch) != 0) && (ch != EOF) );
if(ch == EOF) /* if no more characters in the statement */
return(EOF);
if(ch == '!')
{
if(skip_comments == TRUE)
{
if(pos->ln == statement->nc) /* if last line of statement */
return(EOF);
else /* start next continuation line */
{
pos->ln++;
pos->cn = 5;
goto Start;
}
}
else
return('!');
}
if(ch == '\'')
{ /* look for next quote */
while ( (ch = getsch(statement, pos, FALSE)) != '\'' )
{
if(ch == EOF) /* error if quote not paired */
{
fprintf(stderr,"Unpaired quote in string at line %s !\n",
statement->m[pos->ln]);
exit(1);
}
}
goto Start; /* get next char after string */
}
if(isdigit(ch) == 0) /* if no digit, no Hollerith constant */
return(ch);
l = -1; /* counts digits before H */
/* save current char and its position */
cho = ch;
spos = *pos;
while ( (l < 5) && ((isdigit(ch) != 0) || (isspace(ch) != 0)) )
{
if(isdigit(ch) != 0)
H_count[++l] = (char)ch;
ch = getsch(statement, pos, FALSE);
}
if((ch != 'h') && (ch != 'H')) /* not Hollerith */
{
*pos = spos; /* restore status and return with last char */
return(cho);
}
statement->s[pos->ln][pos->cn] = 'H'; /* change to capitol H */
H_count[++l] = '\0';
k = atoi(H_count); /* convert count to integer */
if(k == 0) {
fprintf(stderr,
"Zero count with Hollerith constant at line %s !\n",
statement->m[pos->ln]);
exit(1);
}
for (i = 1; i <= k; i++) /* skip over whole Hollerith const */
{
ch = getsch(statement, pos, FALSE);
if(ch == EOF) /* error in Hollerith constant */
{
fprintf(stderr, "Hollerith constant wrong at line %s !\n",
statement->m[pos->ln]);
exit(1);
}
}
goto Start;
}
/*=====================================================================*/
/* find_statement_end returns the postion of the character following
the last significant character of the statement. If it so happens
that the statement ends exacly at 71st column (column 72 of FORTRAN
statement) new continuation line is appended, '\0' put in 6th column
(clumn 7 of FORTRAN statement) and the position of this \0 returned.
This statement is meant to help paste things to the end of the statement
*/
#if SUNC
int find_statement_end(statement, pos)
P_STATEMENT statement;
P_POSITION pos;
#else
void find_statement_end(P_STATEMENT statement, P_POSITION pos)
#endif
{
pos->cn = 5;
pos->ln = 0;
/* find position of last characteer */
while (skip_ov_string(TRUE, statement, pos) != EOF);
if(pos->cn >= 72) /* if statement ends on last available column (72) */
{
++statement->nc;
if(statement->nc > MAXCONT)
{
fprintf(stderr,"Too many continuation lines at %s !\n",
statement->m[statement->nc - 1]);
exit(1);
}
/* 123456 */
strcpy(statement->s[statement->nc], " ");
strcpy(statement->m[statement->nc], statement->m[statement->nc - 1]);
pos->cn = 6;
pos->ln = statement->nc;
}
return;
}
/*=====================================================================*/
/* compare_chars gets new character from the statement and compares it
with the given char. The lettercase does not matter (e.g. B = b,
b = B, B = B and b = b). If characters match, function returns TRUE.
if characters do not match function restores pointers to the previous
char (ungets the char) and returns FALSE */
#if SUNC
boolean compare_chars(ch, statement, pos)
int ch;
P_STATEMENT statement;
P_POSITION pos;
#else
boolean compare_chars(int ch, P_STATEMENT statement, P_POSITION pos)
#endif
{
int ch1;
POSITION old_pos;
old_pos = *pos; /* save entry position */
if(islower(ch) != 0)
ch = toupper(ch1);
ch1 = skip_ov_string(TRUE, statement, pos);
if(islower(ch1) != 0)
ch1 = toupper(ch1);
if(ch1 == ch)
return(TRUE);
else
{
*pos = old_pos;
return(FALSE);
}
}
/*=====================================================================*/
/* function find_string looks for the string in the statement
starting from next position after start_pos. Only white space allowed
before the string. If string found, the start_pos and end_pos point
at the first and the last char of the string in the statement.
ch returns the code of character following string (or EOF if nothing
follows string).
If string not found, or initial start_pos messed up, function returns
FALSE and original start_pos.
Watch !, start_pos is input/output, end_pos is output.
Letter case makes no difference. In-line comments and strings are
excluded from search. However, if you start within a string or comment
you might find what you are not looking for.*/
#if SUNC
boolean find_string(statement, start_pos, end_pos, string, ch)
P_STATEMENT statement;
P_POSITION start_pos;
P_POSITION end_pos;
char string[];
int *ch;
#else
boolean find_string(P_STATEMENT statement, P_POSITION start_pos,
P_POSITION end_pos, char string[], int *ch)
#endif
{
int str_len, i;
POSITION old_pos, pos;
*ch = ' ';
str_len = strlen(string);
if(str_len == 0)
return(FALSE);
if((start_pos->ln > statement->nc) || (start_pos->cn < 5))
return(FALSE);
i = strlen(statement->s[start_pos->ln]);
if(start_pos->cn >= i)
return(FALSE);
old_pos = *start_pos;
*end_pos = old_pos;
for (i = 0; i < str_len; i++)
{
if(compare_chars(string[i], statement, end_pos) == FALSE)
{
*end_pos = old_pos;
*start_pos = old_pos;
return(FALSE);
}
if(i == 0)
*start_pos = *end_pos;
}
pos = *end_pos;
*ch = skip_ov_string(TRUE, statement, &pos);
return(TRUE);
}
/*=====================================================================*/
/* function firstnonblank finds the position of the first non-blank
char in the string. If strings contains no non-blank characters
function returns -1 */
#if SUNC
int firstnonblank(string)
char string[];
#else
int firstnonblank(char string[])
#endif
{
int position, i;
int ch;
position = -1;
i = 0;
while ( (ch = string[i]) != '\0' )
{
if( isspace(ch) == 0 ) /* if non-blank char found */
{
position = i;
break;
}
i++;
}
return(position);
}
/*======================================================================*/
/* function iscomment returns TRUE if current line is nothing but a comment
and converts comment into standard Fortran comment line */
#if SUNC
boolean iscomment(text_line, text_len)
char text_line[];
int text_len;
#else
boolean iscomment(char text_line[], int text_len)
#endif
{
int ch, fnb;
if(program_end == TRUE)
return(TRUE);
if(text_len < 6) /* empty lines considered comments */
{
if(text_len > 0)
text_line[0] = 'C';
return(TRUE);
}
fnb = firstnonblank(text_line); /* find first nonblank char */
if(fnb == -1) /* spaces only considered comment */
{
text_line[0] = 'C';
return(TRUE);
}
if(fnb == 5) /* if continuation line */
return(FALSE);
ch = text_line[fnb];
if((fnb < 5) && (isdigit(ch)) != 0) /* if digit in label field */
return(FALSE);
if(((fnb == 0) && (isdigit(ch) == 0)) || (ch == '!'))
/* not digit at column 1 is comment, first char is ! is comment */
{
text_line[0] = 'C';
return(TRUE);
}
if(ch == '!') /* if not continuation and ! is first char, */
{
text_line[0] = 'C';
return(TRUE);
}
return(FALSE); /* otherwise it is a statement */
}
/*======================================================================*/
/* function iscont returns TRUE if current line is a continuation line
and FALSE otherwise */
#if SUNC
boolean iscont(text_line)
char text_line[];
#else
boolean iscont(char text_line[])
#endif
{
int fnb;
char ch;
if(program_end == TRUE)
return(FALSE);
fnb = firstnonblank(text_line);
if(fnb >= 0)
ch = text_line[fnb];
else
ch = ' ';
if(fnb == 5)
{
if(ch == '0')
return(FALSE);
return(TRUE);
}
return(FALSE);
}
/*======================================================================*/
/* function issepar returns TRUE if character is on the list of separators
and FALSE otherwise */
#if SUNC
boolean issepar(ch)
int ch;
#else
boolean issepar(int ch)
#endif
{
int ch1;
boolean what;
int i;
what = FALSE;
i = 0;
while ( (ch1 = SEPAR[i]) != '\0')
{
if(ch == ch1)
{
what = TRUE;
break;
}
i++;
}
return(what);
}
/*======================================================================*/
/* function isinclude checks if current line is an include statement.
if it is a VAX Fortran include and file_open is TRUE,
it tries to open a file to be included. If file is successfully opened,
routine returns TRUE and converts the INCLUDE statement to a comment.
if line is not INCLUDE statement, the routine return FALSE;
If file cannot be found in the current directory, routine gives
error message and exits the program. */
#if SUNC
boolean isinclude(file_open, statement, incf)
boolean file_open;
P_STATEMENT statement;
P_INCLUDE_FILES incf;
#else
boolean isinclude(boolean file_open, P_STATEMENT statement,
P_INCLUDE_FILES incf)
#endif
{
int i, k, n, li, fnb;
int ch;
POSITION pos;
FILE *inp;
if(program_end == TRUE)
return(FALSE);
li = strlen(INCSTAT); /* find number of chars in include statement */
fnb = firstnonblank(statement->s[0]);
if(fnb <= 5) /* if comment, label or blank line */
return(FALSE);
pos.cn = 5; /* Initialize data for getsch routine */
pos.ln = 0;
/* check if first chars on statement line are INCLUDE */
k = 0;
while ((ch = getsch(statement, &pos, FALSE)) != EOF)
{
if(isspace(ch) == 0) /* if not space */
{
if(islower(ch) != 0)
ch = toupper(ch);
if(ch != INCSTAT[k]) /* not INCLUDE, return */
return (FALSE);
k++;
if(k >= li) /* if all characters match, break the loop */
break;
}
}
if(ch == EOF)
return(FALSE);
/* look for file start */
while((ch = getsch(statement, &pos, FALSE)) != EOF)
{
if(isspace(ch) == 0)
{
if(char_in_string(ch, INCFSTART) == 0)
break;
}
}
if(ch == EOF)
return(FALSE);
/* include statement was found */
n = ++incf->ni;
if( n >= MAXINCLUDE )
{
fprintf(stderr,
"Too many nested INCLUDE statements at line %s !\n",
statement->m[pos.ln]);
exit(1);
}
/* collect file name in incl_names */
incf->in[n][0] = (char)ch;
k = 1;
while ((ch = getsch(statement, &pos, FALSE)) != EOF)
{
if(isspace(ch) == 0)
{
if( k >= MAXNAMELEN)
{
fprintf(stderr,
"Include file name too long at line %s in file %s !\n",
statement->m[0], incf->in[n-1]);
exit(1);
}
incf->in[n][k] = (char)ch;
if(char_in_string(ch, INCFEND) > 0)
break;
k++;
}
}
incf->in[n][k] = '\0'; /* terminate file name string */
/* comment out include statement */
for (i = 0; i <= statement->nc; i++)
{
statement->s[i][0] = 'C';
for (k = 1; k <= 3; k++)
statement->s[i][k] = '*';
}
if(file_open == TRUE)
{
/* try to open include file and advance level of nesting */
if( (inp = fopen(incf->in[n],"r")) == NULL)
{
fprintf(stderr,"Failed to open INCLUDE file %s at line %s !\n",
incf->in[n], statement->m[pos.ln]);
exit(1);
}
incf->inf[n] = inp;
}
/* initialize number of lines to 0 */
incf->n_lin[n] = 0L;
return(TRUE);
}
/*======================================================================*/
/* function get_line reads line from current input file. It returns EOF
if end of file was found, otherwise it returns last character read
(which should be \n). The line is stored in curr_line as a
null terminated string (new line not included). The line_len
variable is set to number of characters in the line. The function also
unfolds TAB character in label field according to VAX Fortran
interpretation adding appropriate number of spaces.
Arguments:
curr_line - string containing currently read in line
line_len - no. of chars in curr_line
line_mark - marker of current line (inc file number/ line number)
read_marks - if TRUE, line markers are read from the file
if FALSE, line markers are created from current line
number and include file nesting level
line_no - is advanced when line is read in
incf - structure holding currently opened input/include files
aux1 - pointer to current output file
maxline - maximum number of characters on the line, characters
to the right of maxline are truncated.
line_marker is a string in the form dd,dddddd. First number
is current include file nesting level and second is a line number
in currently opened file */
#if SUNC
int get_line(curr_line, line_len, line_mark, read_marks,
incf, maxline)
char curr_line[];
int *line_len;
char line_mark[];
boolean read_marks;
INCLUDE_FILES *incf;
int maxline;
#else
int get_line(char curr_line[], int *line_len, char line_mark[],
boolean read_marks, INCLUDE_FILES *incf, int maxline)
#endif
{
boolean nonblank, mark_read_in;
static char aux_string[MAXLINE];
int i, j, l, k, n, ch;
long line_no;
FILE *inp;
n = incf->ni;
inp = incf->inf[n]; /* get current input file */
line_no = ++(incf->n_lin[n]); /* advance no. of lines */
nonblank = FALSE;
mark_read_in = FALSE;
*line_len = 0;
curr_line[0] = '\0';
if(program_end == TRUE)
return(EOF);
if(EOF_found == TRUE)
{
program_end = TRUE;
return(EOF);
}
k = 0;
while ( (ch = fgetc(inp)) != EOF) /* read next char */
{
if((read_marks == TRUE) && (k < 9))
{
line_mark[k++] = (char)ch;
if(k == 9)
line_mark[k] = '\0';
}
else /* if line mark read in or not reading marks */
{
if(isspace(ch) == 0)
nonblank = TRUE;
curr_line[(*line_len)++] = (char)ch;
if(ch == '\n') /* if new line, terminate string */
{
curr_line[--(*line_len)] = '\0';
break;
}
if(*line_len >= maxline) /* skip last chars of long lines */
(*line_len)--;
}
}
if(read_marks == FALSE) /* if marks created from line numbers */
sprintf(line_mark,"%2d,%6ld", incf->ni, line_no);
if(ch != EOF)
{
strcpy(incf->ll[incf->ni], curr_line); /* save last line & mark */
strcpy(incf->lm[incf->ni], line_mark);
}
else
{
if(n == 0) /* if input file */
{
EOF_found = TRUE;
curr_line[*line_len] = '\0';
if((*line_len < 2) || (nonblank == FALSE))
{
*line_len = 0;
curr_line[0] = '\0';
return(EOF);
}
}
else /* if coming back from include file */
{
fclose(inp); /* close include file */
n = --(incf->ni); /* nesting level - 1 */
inp = incf->inf[n]; /* get file pointer */
strcpy(curr_line, incf->ll[n]); /* get last line to buffer */
strcpy(line_mark, incf->lm[n]);
*line_len = strlen(curr_line);
}
}
strcpy(aux_string, curr_line);
for (i = 0; i <= *line_len; i++)
{
if(i > 5)
break;
ch = aux_string[i];
curr_line[i] = (char)ch;
if(ch == '\t')
{
l = 0;
if(i == 5) /* if TAB in column 6 */
curr_line[i] = ' ';
else if(i < 5) /* if TAB in columns 1-5 */
{
curr_line[i] = ' ';
if(isdigit(aux_string[i+1]) != 0) /* if tab followed by digit */
l = 4 - i;
else
l = 5 - i;
for (j = 1; j <= l; j++) /* fill in spaces in label field */
curr_line[i+j] = ' ';
k = i+l+1;
for (j = i+1; j <= *line_len; j++) /* append rest of the line */
curr_line[k++] = aux_string[j];
*line_len = (*line_len) + l;
}
break;
}
}
return(ch);
}
/*======================================================================*/
/* function isend checks if current line is an END statement. It returns
TRUE if line is an END statement and FALSE if not */
#if SUNC
boolean isend(text_line)
char text_line[];
#else
boolean isend(char text_line[])
#endif
{
int i, l, ch;
char aux_string[7];
for (i = 0; i < 5; i++) /* only spaces or digits allowed before END */
{
ch = text_line[i];
if((isspace(ch) == 0) && (isdigit(ch) == 0))
return(FALSE);
}
if(isspace(text_line[5]) == 0)
return(FALSE);
l = 0;
i = 6;
while ( ((ch = text_line[i]) != '\0') && (i < 72) && (l < 6) )
{
if(isspace(ch) == 0)
{
if(islower(ch) != 0)
ch = toupper(ch);
aux_string[l++] = (char)ch;
}
i++;
}
aux_string[l] = '\0';
if(aux_string[3] == '!') /* if comment folowing END */
aux_string[3] = '\0';
l = strlen(aux_string);
if(l == 3)
{
if( (aux_string[0] == 'E') &&
(aux_string[1] == 'N') &&
(aux_string[2] == 'D') )
return(TRUE);
}
return(FALSE);
}
/*==========================================================================*/
/* function get_statement() collects statement and all its continuation lines
into structure statement. If read_marks is TRUE, marks are read in from
input file, otherwise they are formed from current line number in
get_line() function. If write_marks is TRUE, marks are written to
aux1 file (only comment lines are written by this routine).
if do_not_include is TRUE, comments from INCLUDE files are not
written to output.
Lines longer than maxline ar truncated to maxline.
If intra_comments is TRUE, commenst are allowed between continuation
lines. FALSE means that comments are not allowed between continuation
lines, or in other words, statement line encountered before the comment
line is the last line of the statement.
If error occurs (e.g. too many continuation lines) function aborts the
program. Comment lines are send to aux1 file directly.
Function returns FALSE if end of the routine (it checks for END statement)
was found or end of input file was reached. Otherwise it returns TRUE. */
#if SUNC
boolean get_statement(statement, incf, read_marks, write_marks, intra_comments,
do_not_include, maxline, aux1)
P_STATEMENT statement;
P_INCLUDE_FILES incf;
boolean read_marks;
boolean write_marks;
boolean intra_comments;
boolean do_not_include;
int maxline;
FILE *aux1;
#else
boolean get_statement(P_STATEMENT statement, P_INCLUDE_FILES incf,
boolean read_marks, boolean write_marks,
boolean intra_comments, boolean do_not_include,
int maxline, FILE *aux1)
#endif
{
boolean comm_line;
int i, n;
char file_depth[3];
static char curr_line[MAXLINE];
static char line_mark[10];
static int line_len;
static boolean fill_in_line = TRUE;
if(program_end == TRUE)
{
statement->nc = -1;
return(FALSE);
}
Collect_statement:
n = (statement->nc = -1);
/* if first call to get_statement in new file or call after END statement */
if((incf->n_lin[incf->ni] == 0L) || (fill_in_line == TRUE))
{
get_line(curr_line, &line_len, line_mark, read_marks, incf, maxline);
}
fill_in_line = FALSE;
/* collect continuation lines if present */
while (program_end != TRUE)
{
if((isend(curr_line) == TRUE) && (n == -1))
{
statement->nc = 0;
strcpy(statement->s[0], curr_line);
strcpy(statement->m[0], line_mark);
curr_line[0] = '\0';
line_len = 0;
fill_in_line = TRUE;
return(FALSE);
}
comm_line = iscomment(curr_line, line_len);
if((n >= 0) && (intra_comments == FALSE) && (comm_line == TRUE))
break;
while (comm_line == TRUE)
{
file_depth[0] = line_mark[0];
file_depth[1] = line_mark[1];
file_depth[2] = '\0';
i = atoi(file_depth);
if((i == 0) || (do_not_include == FALSE))
{
if(write_marks == TRUE)
fprintf(aux1, "%s", line_mark);
fprintf(aux1, "%s\n", curr_line);
}
get_line(curr_line, &line_len, line_mark, read_marks, incf, maxline);
comm_line = iscomment(curr_line, line_len);
if(program_end == TRUE)
return(FALSE);
}
/* save the line if it is continuation line of it was 1st call */
if( (iscont(curr_line) == TRUE) || ( n == -1 ) )
{
n = ++(statement->nc);
if(n >= MAXCONT)
{
fprintf(stderr,
"Too many continuation lines at line %s !\n",line_mark);
exit(1);
}
strcpy(statement->s[n], curr_line);
strcpy(statement->m[n], line_mark);
get_line(curr_line, &line_len, line_mark, read_marks, incf, maxline);
}
else if(iscomment(curr_line, line_len) == FALSE)
{
break;
}
} /* while (program end */
if(isinclude(TRUE, statement, incf) == TRUE)
{
for (i = 0; i <= n; i++) /* write commented include to file */
{
if(write_marks == TRUE)
fprintf(aux1, "%s", statement->m[i]);
fprintf(aux1,"%s\n", statement->s[i]);
}
goto Collect_statement; /* read new statement from new file */
}
if(program_end == TRUE)
return(FALSE);
else
return(TRUE);
}
/*==========================================================================*/
/* putsch() puts char to a statement at position pos and advances position
and statement->nc if necessary. When position reaches column 72, the
current line is terminated with '\0' and new continuation line is
started. The pointer to line marker is supplied as line_mark
if ch is EOF then '\0' is written at current position and pos is
not advanced */
#if SUNC
int putsch(statement, pos, ch, line_mark)
P_STATEMENT statement;
P_POSITION pos;
int ch;
char line_mark[];
#else
void putsch(P_STATEMENT statement, P_POSITION pos, int ch, char line_mark[])
#endif
{
int cont_line, k;
if(ch == EOF) /* EOF stands for end of string */
ch = '\0';
if(pos->cn == 72) /* if end of line reached */
{
statement->s[pos->ln][72] = '\0';
if(ch == '\0') /* if it is also end of statement */
return;
(pos->ln)++; /* start new continuation line */
if(pos->ln > MAXCONT)
{
fprintf(stderr,"Too many continuation lines at line %s !\n",
line_mark);
exit(1);
}
pos->cn = 6;
statement->nc = pos->ln; /* advance no. of continuation lines */
/* convert to range 1 to 9 */
cont_line = statement->nc;
k = cont_line/9;
cont_line = cont_line - k*9 +1;
/* 123456 Initialize new continuation line */
sprintf(statement->s[pos->ln]," %1d ", cont_line);
strcpy(statement->m[pos->ln], line_mark);
}
statement->s[pos->ln][pos->cn] = (char)ch;
/* advance position if not EOF */
if(ch != '\0')
(pos->cn)++;
return;
}
/*==========================================================================*/
/* convert_extended_statement() converts EXTEND_SOURCE lines to normal
statement lines. statement on input is a pointer to original statement.
On output statement will contain the converted statement. aux_statement
is a pointer to auxiliary storage of a type of STATEMENT. If argument
remove_comments is FALSE, end-of-line (!) comments are converted to
standard FORTRAN comments and sent to file auxf. If this argument is TRUE,
end-of-line comments are removed.
*/
#if SUNC
int convert_extended_statement(statement, aux_statement, maxline,
remove_comments, auxf)
P_STATEMENT statement;
P_STATEMENT aux_statement;
int maxline;
boolean remove_comments;
FILE *auxf;
#else
void convert_extended_statement(P_STATEMENT statement,
P_STATEMENT aux_statement,
int maxline,
boolean remove_comments,
FILE *auxf)
#endif
{
int i, ch, l, k, cho, nc_orig, n_ch;
char H_count[7];
POSITION orig_pos, aux_pos, old_pos;
boolean quote_on;
char string[MAXLINE];
nc_orig = statement->nc;
/* initialize aux statement first line */
for (i = 0; i < 6; i++)
aux_statement->s[0][i] = statement->s[0][i];
strcpy(aux_statement->m[0], statement->m[0]);
orig_pos.cn = 5;
orig_pos.ln = 0;
aux_pos.cn = 6;
aux_pos.ln = 0;
quote_on = FALSE;
while ( (ch = getsch(statement, &orig_pos, TRUE) ) != EOF)
{
if(ch == '\'')
{
if(quote_on == TRUE)
quote_on = FALSE;
else
quote_on = TRUE;
}
if((ch == '!') && (quote_on == FALSE)) /* send ! comment to file */
{
if(remove_comments == FALSE)
{
k = strlen(statement->s[orig_pos.ln]);
/* find length of resulting comment */
if(k - orig_pos.cn > maxline)
k = orig_pos.cn + maxline;
/* copy comment to a string */
l = 0;
for (i = orig_pos.cn; i < k; i++)
{
string[l] = statement->s[orig_pos.ln][i];
l++;
}
/* terminate string and put C in front */
string[l] = '\0';
string[0] = 'C';
/* send comment to a file */
fprintf(auxf,"%s%s\n",statement->m[orig_pos.ln], string);
}
/* get next line */
(orig_pos.ln)++;
if(orig_pos.ln > nc_orig)
break;
orig_pos.cn = 5;
/* get next character */
continue;
}
/* save current char in aux_string */
putsch(aux_statement, &aux_pos, ch, statement->m[orig_pos.ln]);
/* check if Hollerith */
if((quote_on == FALSE) && (isdigit(ch) != 0))
{
/* save old position in case it is not */
old_pos = orig_pos;
cho = ch;
n_ch = 0; /* saves number of chars in Hollerith count */
/* collecy Hollerith count */
l = -1;
while( ( l < 5) && ((isdigit(ch) != 0) || (isspace(ch) != 0)) )
{
n_ch++;
if(isdigit(ch) != 0)
H_count[++l] = (char)ch;
ch = getsch(statement, &orig_pos, TRUE);
}
/* if it is Hollerith */
if((ch == 'h') || (ch == 'H'))
{
n_ch++;
H_count[++l] = '\0';
k = atoi(H_count);
if(k == 0)
{
fprintf(stderr,
"Zero count with Hollerith constant at line %s !\n",
statement->m[old_pos.ln]);
exit(1);
}
/* put count and H to aux_statement */
for (i = 1; i < l; i++)
{
ch = H_count[i];
putsch(aux_statement, &aux_pos, ch, statement->m[old_pos.ln]);
}
ch = 'H';
putsch(aux_statement, &aux_pos, ch, statement->m[old_pos.ln]);
/* scan Hollerith characters */
for(i = 1; i <= k; i++)
{
ch = getsch(statement, &orig_pos, TRUE);
if(ch == EOF)
{
fprintf(stderr,"Hollerith constant wrong at line %s !\n",
statement->m[old_pos.ln]);
exit(1);
}
/* save characters in aux_statement */
putsch(aux_statement, &aux_pos, ch, statement->m[orig_pos.ln]);
}
}
else /* if not Hollerith constant */
orig_pos = old_pos; /* read next char */
}
}
/* terminate statement */
putsch(aux_statement, &aux_pos, EOF, statement->m[nc_orig]);
aux_statement->nc = aux_pos.ln;
/* now copy aux_statement to statement */
*statement = *aux_statement;
return;
}
/*==========================================================================*/
/* function decomment() removes in line comments (!) from the current
statement if remove_comments is TRUE. If remove_comments is FALSE,
comments are converted to standard comments (C in 1st column) and,
sent to temporary file aux1 before the statement. Function returns TRUE if
comment found and FALSE otherwise */
#if SUNC
boolean decomment(remove_comments, write_marks, statement, aux1)
boolean remove_comments;
boolean write_marks;
P_STATEMENT statement;
FILE *aux1;
#else
boolean decomment(boolean remove_comments, boolean write_marks,
P_STATEMENT statement, FILE *aux1)
#endif
{
int ch, i;
boolean c_found;
POSITION pos;
c_found = FALSE; /* no comment found yet */
/* initialize to starting position in the statement */
pos.cn = 5;
pos.ln = 0;
while( (ch = skip_ov_string(FALSE, statement, &pos)) != EOF)
{
if(ch == '!')
{
c_found = TRUE;
if(remove_comments == FALSE)
{
/* send comment to aux1 file */
if(write_marks == TRUE)
fprintf(aux1,"%s",statement->m[pos.ln]);
fputc('C',aux1);
for (i = 1; i < pos.cn; i++)
fputc(' ',aux1);
i = pos.cn;
while( (ch = statement->s[pos.ln][i]) != '\0')
{
i++;
fputc(ch, aux1);
}
fputc('\n', aux1);
}
/* erase comment and skip trailing spaces */
statement->s[pos.ln][pos.cn] = '\0';
i = delete_spaces(statement->s[pos.ln]);
if(pos.ln == statement->nc) /* if no more continuation lines */
break;
else
{
pos.ln++;
pos.cn = 5;
}
}
}
return(c_found);
}
/*======================================================================*/
/* function check_option_conflict aborts program if confilicting options
found on command line. conflicting_options is a string which contains
conflicting options. valoptions are options vollowed by value.
Other parameters have standard meaning */
#if SUNC
check_option_conflict(argc, argv, conflicting_options, valoptions)
int argc;
char *argv[];
char conflicting_options[];
char valoptions[];
#else
void check_option_conflict(int argc, char *argv[],
char conflicting_options[], char valoptions[])
#endif
{
int n_rep, i, j, k, l1, l, ch;
l = strlen(conflicting_options);
n_rep = 0;
for (i = 1; i < argc; i++)
{
if(argv[i][0] == '-')
{
l1 = strlen(argv[i]);
if(char_in_string(argv[i][1], valoptions) > 0)
l1 = 1;
for (k = 1; k < l1; k++)
{
ch = argv[i][k];
for (j = 0; j < l; j++) /* count hits */
{
if(ch == conflicting_options[j])
n_rep++;
}
if(n_rep > 1)
{
fprintf(stderr,"You have to choose only one from {%s}\n",
conflicting_options);
exit(1);
}
}
}
}
}
/*======================================================================*/
/* function unknown_option aborts program if option given on command
line is not among allowed options given in allowed_options */
#if SUNC
unknown_option(argc, argv, allowed_options, valoptions)
int argc;
char *argv[];
char allowed_options[], valoptions[];
#else
void unknown_option(int argc, char *argv[],
char allowed_options[], char valoptions[])
#endif
{
int i, j, k, l1, l, ch;
boolean found;
l = strlen(allowed_options);
for (i = 1; i < argc; i++)
{
if(argv[i][0] == '-')
{
l1 = strlen(argv[i]);
if( char_in_string(argv[i][1], valoptions) > 0)
l1 = 2;
for (k = 1; k < l1; k++)
{
ch = argv[i][k];
found = FALSE;
for (j = 0; j < l; j++) /* check if present */
{
if(ch == allowed_options[j])
{
found = TRUE;
break;
}
}
if(found == FALSE)
{
fprintf(stderr,"Option %c is not allowed !\n", ch);
exit(1);
}
}
}
}
}
/*======================================================================*/
/* function find_option returns argument number if option was found and
0 if option was not found. Option can be followed by a value which
is returned as option_string. In this case function returns the position
of a value rather then option For example if command line is:
test -i inpfile -o outfile
the call find_option(argc, argv, 'i', fname) will return
2 as function value and "inpfile" as fname
however if command line is
test -iinpfile -o outfile
call will return 1 as function value and "inpfile" as fname
*/
#if SUNC
int find_option (argc, argv, valoptions, option, option_string)
int argc; /* no of arguments from command line */
char *argv[]; /* arguments from command line */
char valoptions[];
char option; /* char holding option code (e.g. l for -l option) */
char option_string[]; /* returns value of the option (e.g. -f junk or -fjunk
returns junk in option_string). This string is of
use if option has value */
#else
int find_option(int argc, char *argv[], char valoptions[], char option,
char option_string[])
#endif
{
int i, j, k, l, l1, m;
int arg_n; /* holds the argument number corresponding to option */
arg_n = 0;
option_string[0] = '\0'; /* initialize option value to null string */
if(argc > 0)
{
for (i = 1; i < argc; i++)
{
if(argv[i][0] == '-') /* some option found */
{
l = strlen(argv[i]);
if(l == 1)
{
fprintf(stderr,"- is not followed by option letter !\n");
exit(1);
}
/* if first letter is option with value, do not look of options in
option value which follows */
if(char_in_string(argv[i][1], valoptions) > 0)
l1 = 2;
else
l1 = l;
for (j = 1; j < l1; j++)
{
if((char_in_string(argv[i][j], valoptions) > 0) && (j > 1))
{
fprintf(stderr,
"Option which has value must follow - immediately !\n");
exit(1);
}
if(option == argv[i][j])
{
arg_n = i; /* the option has been found */
if(j < l-1) /* if more charactes after option letter */
{ /* take subsequent chars as option value */
m = 0;
for (k = j+1; k <= l; k++, m++)
option_string[m] = argv[i][k];
}
else if(i < argc-1 ) /* take next argument as option value */
{
arg_n++;
strcpy(option_string, argv[i+1]);
}
break;
}
} /* end for (j */
} /* end if(argv */
} /* end for (i */
} /* end if(argc */
return(arg_n);
}
/*=====================================================================*/
/* cut removes a string of chars from start to end from the statement
to a string. If start or end are bad or within in-line comment
routine returns FALSE. if more characters to extract than maxslen
the routine return FALSE. It is assumed that you do not cut things from
strings or Hollerith constants.
*/
#if SUNC
boolean cut(statement, start, end, maxline, string, maxslen)
P_STATEMENT statement;
P_POSITION start;
P_POSITION end;
char string[];
int maxslen;
#else
boolean cut(P_STATEMENT statement, P_POSITION start, P_POSITION end,
int maxline, char string[], int maxslen)
#endif
{
int ch, i, k, l, comm_pos, line_len, n_available, n_needed;
boolean blank_last;
POSITION cpos;
if(start->ln > end->ln)
return(FALSE);
if((start->ln == end->ln) && (start->cn > end->cn))
return(FALSE);
if((start->ln < 0) || (start->ln > statement->nc) ||
(end->ln < 0) || (end->ln > statement->nc))
return(FALSE);
if((start->cn < 6) || (end->cn < 6))
return(FALSE);
l = strlen(statement->s[start->ln]);
if(start->cn >= l)
return(FALSE);
l = strlen(statement->s[end->ln]);
if(end->cn >= l)
return(FALSE);
/* delete inline comments from lines start to end-1 and save
comment position on line end */
cpos.cn = 5;
cpos.ln = 0;
comm_pos = 0;
while( (ch = skip_ov_string(FALSE, statement, &cpos)) != EOF)
{
if(cpos.ln > end->ln)
break;
if(ch == '!')
{
/* do not insert to comments */
if((cpos.ln == start->ln) && (start->cn >= cpos.cn))
return(FALSE);
if((cpos.ln == end->ln) && (end->cn >= cpos.cn))
return(FALSE);
/* delete inline comments in text being cut */
if((cpos.ln >= start->ln) && (cpos.ln < end->ln))
{
statement->s[cpos.ln][cpos.cn] = '\0';
++cpos.ln;
cpos.cn = 5;
continue;
}
else if(cpos.ln == end->ln)
{
comm_pos = cpos.cn;
break;
}
}
}
/* extract string from statement */
cpos.cn = start->cn - 1;
cpos.ln = start->ln;
k = 0;
while( (ch = getsch(statement, &cpos, FALSE)) != EOF )
{
string[k++] = (char)ch;
if(k >= maxslen)
return(FALSE);
if((cpos.ln == end->ln) && (cpos.cn == end->cn))
break;
}
string[k] = '\0';
/* if there is no comment on last line and garbage in columns 73 and up,
clean the garbage */
if(comm_pos == 0)
{
l = strlen(statement->s[end->ln]);
if( l > 72 )
statement->s[end->ln][72] = '\0';
line_len = delete_spaces(statement->s[end->ln]);
}
else
line_len = comm_pos;
/* check if there is anything after end on the last line */
blank_last = TRUE;
for (i = end->cn + 1; i < line_len; i++)
{
if(isspace(statement->s[end->ln][i]) == 0)
{
blank_last = FALSE;
break;
}
}
if(blank_last == FALSE)
{
/* move chars on last line either to 1st line or to the beginning
of last line. If framgment of the last line left after deletion
is to long to fit into columns start->cn to 71, the last line will
be moved to next line following the first line, otherwise, last line
will be appended to the remaining fragment of first line */
n_needed = line_len - end->cn - 1; /* no of chars left on last line */
n_available = 72 - start->cn; /* No. of chars available on first line */
if(n_needed > n_available) /* last line will be only shifted left */
{
l = 6; /* move characters to the left */
k = start->ln + 1; /* will follow on next continuation line */
statement->s[start->ln][start->cn] = '\0'; /* terminate first line */
}
else
{
l = start->cn; /* will follow remaining chars on first line */
k = start->ln;
}
/* move characters */
i = end->cn + 1;
do
{
statement->s[k][l] = (char)(ch = statement->s[end->ln][i]);
l++;
if(l > maxline) /* skip chars at the end of long lines */
l--;
i++;
}
while (ch != '\0');
}
else /* if last line is a blank line */
{
k = start->ln;
statement->s[k][start->cn] = '\0';
}
/* check if lines following deletion need be moved forward */
if(end->ln > k)
{
i = end->ln;
while (i < statement->nc)
{
k++;
i++;
strcpy(statement->s[k], statement->s[i]);
}
statement->nc = k;
}
return(TRUE);
}
/*=====================================================================*/
/* paste, inserts string into statement at position given by pos.
The position of last character of the string after insertion is
returned in pose.
It is assumed that you do not paste into a string or Hollerith
constant.
The characters following starting at pos are pushed to right to make
space for string being inserted. If necessary, additional continuation
lines are created. If string too long (not enough continuation lines)
FALSE is returned. FALSE is also returned if instertion at label
field or within an in-line comment.
String to insert "1234 ".
Line before insert:
column
|
v
DO I = 1, N
Line after insert:
DO 1234 I = 1, N
*/
#if SUNC
boolean paste(statement, pos, pose, maxline, string)
P_STATEMENT statement;
P_POSITION pos, pose;
int maxline;
char string[];
#else
boolean paste(P_STATEMENT statement, P_POSITION pos, P_POSITION pose,
int maxline, char string[])
#endif
{
int ch, i, k, l, comm_pos, str_len, line_length, new_lines,
last_char;
char first_line[MAXLINE];
POSITION cpos;
*pose = *pos;
str_len = strlen(string); /* get length of the string */
if((pos->cn < 6) || (pos->cn > 71))
return(FALSE);
if(pos->ln > statement->nc)
return(FALSE);
line_length = strlen(statement->s[pos->ln]);
/* find if there is a ! comment on the insertion line */
cpos.cn = 5;
cpos.ln = 0;
comm_pos = 0;
while( (ch = skip_ov_string(FALSE, statement, &cpos)) != EOF)
{
if( (ch == '!') && (cpos.ln == pos->ln) )
{
comm_pos = cpos.cn; /* !-comment position found */
if(comm_pos < 6) /* comment should not appear here */
return(FALSE);
break;
}
if(cpos.ln > pos->ln) /* no !-comment on line */
break;
}
/* last_char is the last significant character of the statement line */
if(comm_pos == 0) /* if no in-line comment */
{
if(line_length > 72)
{
line_length = 72;
statement->s[pos->ln][72] = '\0';
last_char = 71;
}
else
last_char = line_length - 1;
}
else
last_char = comm_pos - 1;
if((comm_pos != 0) && (pos->cn > last_char)) /* if insertion into comment */
return(FALSE);
new_lines = (str_len + last_char - 6)/66; /* no. of new lines needed */
/* check if not too many continuation lines */
if( (statement->nc + new_lines) >= MAXCONT )
return(FALSE);
/* open new_lines in statement */
if(new_lines > 0)
{
for (i = statement->nc; i > pos->ln; i--)
{
strcpy(statement->s[i+new_lines], statement->s[i]);
strcpy(statement->m[i+new_lines], statement->m[i]);
}
statement->nc = statement->nc + new_lines;
}
/* copy chars following insertion point to first_line */
k = 0;
for(i = pos->cn; i < line_length; i++)
first_line[k++] = statement->s[pos->ln][i];
first_line[k] = '\0';
/* insert string */
l = str_len + line_length - 6;
cpos = *pos;
k = 0;
for (i = 0; i <= l; i++)
{
if(i < str_len) /* switch to original statement end when string gone */
ch = string[i];
else
ch = first_line[i - str_len];
if(i == str_len-1) /* save position of last char of inserted string */
*pose = cpos;
statement->s[cpos.ln][cpos.cn] = (char)ch;
cpos.cn++;
/* open new line */
if((cpos.cn > 71) && ((pos->ln + new_lines) != cpos.ln))
{
statement->s[cpos.ln][cpos.cn] = '\0'; /* terminate current line */
k++; /* cont line number */
if(k > 9)
k = 1;
cpos.ln++;
/* initialize label field 123456 */
sprintf(statement->s[cpos.ln]," %1d ", k);
/* copy line mark from previous line */
strcpy(statement->m[cpos.ln], statement->m[cpos.ln - 1]);
cpos.cn = 6;
}
if(cpos.cn > maxline)
{
statement->s[cpos.ln][maxline] = '\0';
cpos.cn--;
}
}
return(TRUE);
}
/*======================================================================*/
/* function convert_to_decimal converts octal and hexadecimal constants
to decimal. Returns true if conversions were performed.
*/
#if SUNC
boolean convert_to_decimal(statement, maxline)
P_STATEMENT statement;
int maxline;
#else
boolean convert_to_decimal(P_STATEMENT statement, int maxline)
#endif
{
int i, ch, ch1, l, k, cho, d, quote_len;
char H_count[7];
POSITION spos, pos, qstart, qend;
boolean OX_changed, quote_found;
char OXconstant[MAXOCT+1];
char digits[17];
unsigned long OX, place, base;
char extr_string[MAXEXTRLEN];
pos.cn = 5;
pos.ln = 0;
OX_changed = FALSE;
quote_found = FALSE;
quote_len = 0;
Start:
do { ch = getsch(statement, &pos, FALSE); } /* skip spaces */
while ( (isspace(ch) != 0) && (ch != EOF) );
if(ch == EOF) /* if no more characters in the statement */
return(OX_changed);
if(ch == '!')
{
if(pos.ln == statement->nc) /* if last line of statement */
return(OX_changed);
else /* start next continuation line */
{
pos.ln++;
pos.cn = 5;
goto Start;
}
}
/* check for octal or hex constants */
if((quote_found == TRUE) && (quote_len < MAXOCT) && (quote_len >= 0))
{
if((i = char_in_string(ch, "oOxX")) > 0)
{
qend = pos; /* include O or X */
if(i < 3) /* if octal constant */
{
strcpy(digits,"01234567");
base = 8L;
}
else
{
strcpy(digits,"0123456789ABCDEF");
base = 16L;
}
/* Convert constant to a number */
OX = 0;
place = 1;
for (i = quote_len; i >= 0; i--)
{
ch1 = OXconstant[i];
if(islower(ch1) != 0)
ch1 = toupper(ch1);
if((d = char_in_string(ch1, digits)) == 0)
{
fprintf(stderr,"Invalid octal/hex constant at line %s !\n",
statement->m[pos.ln]);
exit(1);
}
OX = OX + place*(d - 1L);
place = place*base;
}
if(cut(statement, &qstart, &qend, maxline, extr_string,
MAXEXTRLEN) == FALSE)
{
fprintf(stderr,"Cannot cut out OCT/HEX constant at line %s \n",
statement->m[qstart.ln]);
exit(1);
}
sprintf(extr_string,"%lu",OX);
if(paste(statement, &qstart, &qend, maxline, extr_string) != TRUE)
{
fprintf(stderr,
"Failed to paste converted OCT/HEX constant at line %s !\n",
statement->m[qstart.ln]);
exit(1);
}
OX_changed = TRUE;
pos = qend;
quote_found = FALSE;
goto Start;
} /* end if ch1 O or X after quote */
} /* end if quote found and length < MAXOCT */
quote_found = FALSE;
if(ch == '\'')
{
qstart = pos;
quote_len = -1; /* look for next quote */
while ( (ch = getsch(statement, &pos, FALSE)) != '\'' )
{
if(ch == EOF) /* error if quote not paired */
{
fprintf(stderr,"Unpaired quote in string at line %s !\n",
statement->m[pos.ln]);
exit(1);
}
if(isspace(ch) == 0)
{
quote_len++;
if(quote_len < MAXOCT)
OXconstant[quote_len] = (char)ch;
}
}
if((quote_len >= 0) && (quote_len < MAXOCT))
{
quote_found = TRUE;
qend = pos;
OXconstant[quote_len+1] = '\0';
}
goto Start; /* get next char after string */
}
if(isdigit(ch) == 0) /* if no digit, no Hollerith constant */
goto Start;
l = -1; /* Counts digits before H */
/* save current char and its position */
cho = ch;
spos = pos;
while ( (l < 5) && ((isdigit(ch) != 0) || (isspace(ch) != 0)) )
{
if(isdigit(ch) != 0)
H_count[++l] = (char)ch;
ch = getsch(statement, &pos, FALSE);
}
if((ch != 'h') && (ch != 'H')) /* not Hollerith */
{
pos = spos; /* restore status and return with last char */
goto Start;
}
H_count[++l] = '\0';
k = atoi(H_count); /* convert count to integer */
if(k == 0) {
fprintf(stderr,
"Zero count with Hollerith constant at line %s !\n",
statement->m[pos.ln]);
exit(1);
}
for (i = 1; i <= k; i++) /* skip over whole Hollerith const */
{
ch = getsch(statement, &pos, FALSE);
if(ch == EOF) /* error in Hollerith constant */
{
fprintf(stderr, "Hollerith constant wrong at line %s !\n",
statement->m[pos.ln]);
exit(1);
}
}
goto Start;
}
/*======================================================================*/
/* extract_label returns label from label field or 0 if there is no label */
#if SUNC
long extract_label(statement)
P_STATEMENT statement;
#else
long extract_label(P_STATEMENT statement)
#endif
{
int i, l, ch;
long lab;
char lab_field[6];
l = 0;
for (i = 0; i < 5; i++)
{
ch = statement->s[0][i];
if( (isspace(ch) == 0) && (isdigit(ch) == 0) )
return(0L);
if(isdigit(ch) != 0)
lab_field[l++] = (char)ch;
}
lab_field[l] = '\0';
if(l > 0)
lab = atol(lab_field);
else
lab = 0L;
return(lab);
}
/*=================================================================*/
/* function change_label_field replaces contents of label field
with a new label. If label messed up, function returns FALSE */
#if SUNC
boolean change_label_field(label, statement)
long label;
P_STATEMENT statement;
#else
boolean change_label_field(long label, P_STATEMENT statement)
#endif
{
int i;
char label_field[10];
if((label < 1L) || (label > 99999L))
return(FALSE);
sprintf(label_field,"%5ld",label);
for (i = 0; i < 5; i++)
statement->s[0][i] = label_field[i];
}
/*=============================================================*/
/* function find_label_position() returns position of the first
label which is greater or equal to the argument */
#if SUNC
int find_label_position(label, labels)
long label;
P_LABELS labels;
#else
int find_label_position(long label, P_LABELS labels)
#endif
{
int l, u, m;
if((label < 1L) || (label > 99999L))
return(0);
/* binary search for label position. Label will be inserted before m */
l = 0;
u = labels->n_lab;
do
{
m = (l+u)/2;
if( label <= labels->l[m])
{
if(label > labels->l[m-1])
break;
u = m - 1;
}
if( label > labels->l[m])
l = m + 1;
}
while (TRUE);
return(m);
}
/*=====================================================================*/
/* function save_label saves label in in structure labels.
Structure labels is initialized to labels.n_lab = 1;
labels.l[0] = 0 (labels is always greater than 0) and
labels.l[1] = 100000 (labels have only up to 5 decimal places,
so they are always less than 100000). Returns FALSE if label
out of order.
Labels are ordered in ascending order */
#if SUNC
boolean save_label(label, labels)
long label;
P_LABELS labels;
#else
boolean save_label(long label, P_LABELS labels)
#endif
{
int i, k, m;
if((label < 1L) || (label > 99999L))
return(FALSE);
/* binary search for label position. Label will be inserted before m */
m = find_label_position(label, labels);
if(m == 0)
return(FALSE);
/* check if labels was already saved */
if(labels->l[m] == label)
return(FALSE);
k = ++labels->n_lab;
if(k >= MAXLABELS)
{
fprintf(stderr,"Too many labels per routine !\n");
fprintf(stderr,
"This program can only handle %d labels per routine.\n",MAXLABELS);
exit(1);
}
/* move labels to the right to make a space for new label */
for (i = k; i > m; i--)
labels->l[i] = labels->l[i-1];
/* save new label */
labels->l[m] = label;
return(TRUE);
}
/*=========================================================================*/
/* fetch_new_label returns unique label which was not assigned in the
routine. This label is automatically added to existing labels.
The label_found will be first unused label >= seed_label */
#if SUNC
long fetch_new_label(seed_label, labels)
long seed_label;
P_LABELS labels;
#else
long fetch_new_label(long seed_label, P_LABELS labels)
#endif
{
int i, k, m;
if((seed_label < 1L) || (seed_label >= 99999L))
seed_label = 5000;
/* binary search for label position. Label will be inserted before m */
m = find_label_position(seed_label, labels);
if(m == 0)
return(0);
if(seed_label == labels->l[m]) /* if seed_label exists */
{
while ( (labels->l[m+1] - labels->l[m]) < 2L ) /* look for a gap */
m++;
seed_label = labels->l[m] + 1L; /* take next label */
m++; /* move labels one up from this position */
}
k = ++labels->n_lab;
if(k >= MAXLABELS)
{
fprintf(stderr,"Too many labels per routine !\n");
fprintf(stderr,
"This program can only handle %d labels per routine.\n",MAXLABELS);
exit(1);
}
/* move labels to the right to make a space for new label */
for (i = k; i > m; i--)
labels->l[i] = labels->l[i-1];
/* save new label */
labels->l[m] = seed_label;
return(seed_label);
}
/* get_label() returns label following position start_pos. If valid label
present, get_label > 0, start_pos and end_pos return position of
label first character and last character, respectively. The value of
first nondigit character terminating the label is also returned as ch;
if valid label not found, get_label returns 0L, start_pos and end_pos
are equal to value of end_pos on entry and ch = EOF.
Watch ! start_pos is output only, end_pos is input/output */
#if SUNC
long get_label(statement, start_pos, end_pos, ch)
P_STATEMENT statement;
P_POSITION start_pos;
P_POSITION end_pos;
int *ch;
#else
long get_label(P_STATEMENT statement, P_POSITION start_pos,
P_POSITION end_pos, int *ch)
#endif
{
long label;
POSITION spos, epos, old_pos;
char labstr[7];
int ch1, l;
old_pos = *start_pos;
*end_pos = *start_pos;
l = -1;
while ( (ch1 = skip_ov_string(TRUE, statement, end_pos)) != EOF)
{
if(l < 0)
spos = *end_pos; /* position of 1st digit of label */
if(isdigit(ch1) == 0)
break;
labstr[++l] = (char)ch1;
epos = *end_pos; /* position of last digit of label */
if( l > 4 ) /* label cannot have more than 5 digits */
break;
}
if((l < 0) || (l > 4)) /* if label messed up */
{
*start_pos = old_pos;
*end_pos = old_pos;
*ch = EOF;
return(0L);
}
labstr[l+1] = '\0'; /* terminate label string */
label = atol(labstr);
*start_pos = spos;
*end_pos = epos;
*ch = ch1;
return(label);
}
/*==========================================================================*/
/* function isdo checks the statement for DO or DO WHILE loop. Returns
DO type (0 - not DO, 1 - DO loop unlabelled, 2 DO labelled loop.
3 - DO WHILE unlabeled, 4 - DO WHILE labelled. It also assignes
value to variable do_label. If do_label > 0, it is labeled
do statement, if label = 0, it is unlabeled do statement.
For unlabeled do statements label_starts returns next char after DO
keyword */
#if SUNC
int isdo(do_starts, do_ends, label_starts, label_ends, do_label, statement)
P_POSITION do_starts, do_ends, label_starts, label_ends;
long *do_label;
P_STATEMENT statement;
#else
int isdo(P_POSITION do_starts, P_POSITION do_ends, P_POSITION label_starts,
P_POSITION label_ends, long *do_label, P_STATEMENT statement)
#endif
{
int ch, n_paren;
POSITION pos, e_pos;
do_starts->cn = 0;
do_starts->ln = 0;
do_ends->cn = 0;
do_ends->ln = 0;
label_starts->cn = 0;
label_starts->ln = 0;
label_ends->cn = 0;
label_ends->ln = 0;
pos.ln = 0;
pos.cn = 5;
*do_label = 0L;
/* check if first letter is D */
if(compare_chars('D', statement, &pos) == FALSE)
return(NOTDOLOOP);
*do_starts = pos;
if(compare_chars('O', statement, &pos) == FALSE)
return(NOTDOLOOP);
*do_ends = pos;
*label_starts = pos;
*do_label = get_label(statement, label_starts, label_ends, &ch);
if(*do_label > 0L)
pos = *label_ends;
if((*do_label > 0L) && (ch == ',')) /* skip comma after label if present */
{
ch = skip_ov_string(TRUE, statement, &pos); /* gets comma */
*label_ends = pos; /* assume , as a part of the label */
}
ch = skip_ov_string(TRUE, statement, &pos);
if(*do_label == 0L)
{
*label_starts = pos;
*label_ends = pos;
}
/* there must be now a letter (beginning of WHILE or control variable) */
if( isvaxalpha(ch) == 0 )
return(NOTDOLOOP);
/* now there goes either a variable name or a WHILE( */
if((ch != 'W') && (ch != 'w')) /* if not WHILE */
goto Check_DO_loop;
if(compare_chars('H', statement, &pos) == FALSE)
goto Check_DO_loop;
if(compare_chars('I', statement, &pos) == FALSE)
goto Check_DO_loop;
if(compare_chars('L', statement, &pos) == FALSE)
goto Check_DO_loop;
if(compare_chars('E', statement, &pos) == FALSE)
goto Check_DO_loop;
e_pos = pos; /* save position of E in WHILE */
if(compare_chars('(', statement, &pos) == FALSE)
{
ch = skip_ov_string(TRUE, statement, &pos);
if((ch == '=') || (isalnum(ch) != 0) || (ch == '_') || (ch == '$'))
goto Check_DO_loop;
else
return(NOTDOLOOP);
}
else /* WHILE( was found */
{
*do_ends = e_pos; /* E was an end of DO */
if( *do_label > 0 )
{
return(DOWHILELAB);
}
else
{
return(DOWHILEUNL);
}
}
Check_DO_loop:
/* Here we might have a DO loop. The beginning of unlabeled DO is:
DO [label [,]] variable = expresion, ....
only digits or letters allowed before =
expression has always paired parantheses */
if(ch != '=') /* check if = was already found */
{
while ( (ch = skip_ov_string(TRUE, statement, &pos)) != '=' )
{
/* if not digit, letter, underscore or dollar sign */
if( (isalnum(ch) == 0) && (ch != '_') && (ch != '$') )
return(FALSE);
}
}
n_paren = 0;
while ( (ch = skip_ov_string(TRUE, statement, &pos)) != EOF )
{
if( ch == '(' )
n_paren++;
if( ch == ')' )
n_paren--;
if( (ch == ',') && (n_paren == 0) ) /* valid DO found */
{
if( *do_label > 0 )
{
return(DOLOOPLAB);
}
else
{
return(DOLOOPUNL);
}
}
}
return(NOTDOLOOP); /* comma not found, it is not DO */
}
/*==========================================================================*/
/* isassign() checks if current statement has an ASSIGN statement
following position start_pos. It returns TRUE, a label list (containing
only one label), start_pos pointing at statement end, if statement contains
ASSIGN statement. It returns FALSE and start_pos points at original
position.
ASSIGN statement has format ASSIGN label TO variable
*/
#if SUNC
boolean isassign(statement, start_pos, label_list)
P_STATEMENT statement;
P_POSITION start_pos;
P_LABLIST label_list;
#else
boolean isassign(P_STATEMENT statement, P_POSITION start_pos,
P_LABLIST label_list)
#endif
{
POSITION old_pos, end_pos;
long label;
int i, ch;
old_pos = *start_pos;
label_list->n_l = -1;
if(find_string(statement, start_pos, &end_pos, "ASSIGN", &ch) == FALSE)
goto Not_Assign;
*start_pos = end_pos;
label = get_label(statement, start_pos, &end_pos, &ch);
if(label <= 0L)
goto Not_Assign;
label_list->lab[0] = label;
label_list->lstart[0] = *start_pos;
label_list->lend[0] = end_pos;
*start_pos = end_pos;
/* check if TO follows label */
if(find_string(statement, start_pos, &end_pos, "TO", &ch) == FALSE)
goto Not_Assign;
*start_pos = end_pos;
/* check if variable name follows TO */
i = 0;
while ((ch = skip_ov_string(TRUE, statement, start_pos)) != EOF)
{
if((i == 0) && (isvaxalpha(ch) == FALSE))
goto Not_Assign;
if((isdigit(ch) == 0) && (isvaxalpha(ch) == 0))
goto Not_Assign;
i++;
}
label_list->n_l = 0;
return(TRUE);
Not_Assign:
*start_pos = old_pos;
return(FALSE);
}
/*==========================================================================*/
/* isgoto() checks if GOTO statement follows start_pos. If no GOTO, then
function returns NOGOTO (0) and original start_pos.
If GOTO found, function returns type of GOTO and label_list.
Types of GOTO are:
NOGOTO (1) it is not GOTO
UNCGOTO (1) unconditional GOTO label
COMPGOTO (2) computed GOTO (lab1, lab2....) [,] expression
ASSGOTO (3) assigned GOTO variable [[,] (lab1, lab2....)]
*/
#if SUNC
boolean isgoto(statement, start_pos, label_list)
P_STATEMENT statement;
P_POSITION start_pos;
P_LABLIST label_list;
#else
boolean isgoto(P_STATEMENT statement, P_POSITION start_pos,
P_LABLIST label_list)
#endif
{
POSITION old_pos, end_pos, pos;
int i, ch;
long label;
old_pos = *start_pos;
label_list->n_l = -1;
if(find_string(statement, start_pos, &end_pos, "GOTO", &ch) == FALSE)
goto Not_goto;
pos = end_pos;
if(isdigit(ch) != 0)
goto Unconditional;
else if(ch == '(')
goto Computed;
else if(isvaxalpha(ch) != FALSE)
goto Assigned;
else
goto Not_goto;
Unconditional:
label = get_label(statement, &pos, &end_pos, &ch);
if((label == 0L) || (ch != EOF)) /* no label or something after digits */
goto Not_goto;
label_list->n_l = 0;
label_list->lab[0] = label;
label_list->lstart[0] = pos;
label_list->lend[0] = end_pos;
*start_pos = end_pos;
ch = skip_ov_string(TRUE, statement, start_pos); /* should point at EOF */
return(UNCGOTO);
Computed:
ch = skip_ov_string(TRUE, statement, &pos); /* skip '(' */
ch = ',';
i = -1;
while (ch == ',') /* loop starts pointing at '(' */
{
i++;
if(i >= MAXLABLIST)
{
fprintf(stderr,
"Too many labels in COMPUTED GOTO statement at line %s !\n",
statement->m[start_pos->ln]);
exit(1);
}
label = get_label(statement, &pos, &end_pos, &ch);
/* if valid label found save it and prepare for next */
if((label != 0L) && ((ch == ',') || (ch == ')')))
{
label_list->n_l = i;
label_list->lab[i] = label;
label_list->lstart[i] = pos;
label_list->lend[i] = end_pos;
ch = skip_ov_string(TRUE, statement, &end_pos); /* get , or ) */
pos = end_pos;
}
else
goto Not_goto;
}
/* Syntax is GOTO (lab1 [, lab2....]) [,] expression */
/* check if we are here: ^ */
if(ch != ')')
goto Not_goto;
/* there should be no '=' in expression */
while ( (ch = skip_ov_string(TRUE, statement, &end_pos)) != EOF)
{
if(ch == '=')
goto Not_goto;
}
return(COMPGOTO);
Assigned:
/* the syntax of ASSIGNED GOTO is:
GOTO variable [[,] (lab1 [, lab2.....])] */
while ( (ch = skip_ov_string(TRUE, statement, &pos)) != EOF)
{
if((isvaxalpha(ch) == FALSE) && (isdigit(ch) == 0))
break;
}
if(ch == ',')
ch = skip_ov_string(TRUE, statement, &pos);
if((ch != EOF) && (ch != '('))
goto Not_goto;
if(ch == EOF) /* label list is optional */
{
return(ASSGOTO);
}
ch = ',';
i = -1;
while (ch == ',')
{
i++;
if(i >= MAXLABLIST)
{
fprintf(stderr,
"Too many labels in ASSIGNED GOTO statement at line %s !\n",
statement->m[start_pos->ln]);
exit(1);
}
label = get_label(statement, &pos, &end_pos, &ch);
/* if valid label found save it and prepare for next */
if((label != 0L) && ((ch == ',') || (ch == ')')))
{
label_list->n_l = i;
label_list->lab[i] = label;
label_list->lstart[i] = pos;
label_list->lend[i] = end_pos;
ch = skip_ov_string(TRUE, statement, &end_pos); /* get , or ) */
pos = end_pos;
}
else
goto Not_goto;
}
/* Syntax is GOTO var [,] (lab1 [, lab2....]) */
/* check if we are here: ^ */
if(ch != ')')
goto Not_goto;
ch = skip_ov_string(TRUE, statement, &end_pos);
if(ch != EOF) /* Nothing should follow label list */
goto Not_goto;
return(ASSGOTO);
Not_goto: /* if syntax is not that of GOTO */
*start_pos = old_pos;
label_list->n_l = -1;
return(NOGOTO);
}
/*=======================================================================*/
/* isif checks if current expression is an IF statement following
position start_pos (remember: arithmetic IF can follow logical IF)
If it is IF, function returns type of IF, a position of the closing
paranthesis of condition and a label_list (if arithmetic IF). If not IF,
function returns NOIF and original pos. Types of IF are:
NOIF (0) not if statement
ARTHIF (1) IF(expr)lab1, lab2, lab3
LOGIF (2) IF(expr) statement
BLOCKIF (3) IF(expr) THEN .... ENDIF */
#if SUNC
boolean isif(statement, start_pos, label_list)
P_STATEMENT statement;
P_POSITION start_pos;
P_LABLIST label_list;
#else
boolean isif(P_STATEMENT statement, P_POSITION start_pos,
P_LABLIST label_list)
#endif
{
POSITION old_pos, pos, pos1;
int i, ch, n_paren;
long label;
old_pos = *start_pos;
label_list->n_l = -1;
if(find_string(statement, start_pos, &pos, "IF", &ch) == FALSE)
goto Not_IF;
/* IF followed by ( */
if(ch != '(')
goto Not_IF;
pos1 = pos;
pos = *start_pos;
n_paren = 0;
while ( (ch = skip_ov_string(TRUE, statement, &pos)) != EOF)
{
if( ch == '(' )
n_paren++;
if( ch == ')' )
{
n_paren--;
if(n_paren == 0)
break;
}
}
if(ch == EOF)
goto Not_IF;
*start_pos = pos; /* save position of ) closing condition */
ch = skip_ov_string(TRUE, statement, &pos);
pos = *start_pos;
if(isdigit(ch) != 0)
goto Arithmetic;
else if(isvaxalpha(ch) == TRUE)
goto Logical_or_Block;
else
goto Not_IF;
Arithmetic:
for (i = 0; i < 3; i++)
{
label = get_label(statement, &pos, &pos1, &ch);
/* if valid label found save it and prepare for next */
if((label != 0L) && ((ch == ',') || (ch == EOF)))
{
label_list->n_l = i;
label_list->lab[i] = label;
label_list->lstart[i] = pos;
label_list->lend[i] = pos1;
ch = skip_ov_string(TRUE, statement, &pos1); /* get , or EOF */
pos = pos1;
}
else
goto Not_IF;
}
if(ch == EOF)
{
return(ARTHIF);
}
else
goto Not_IF;
Logical_or_Block:
/* check if block if */
if(find_string(statement, &pos, &pos1, "THEN", &ch) == TRUE)
{
if(ch != EOF)
goto Not_IF;
else
{
return(BLOCKIF);
}
}
return(LOGIF);
Not_IF:
*start_pos = old_pos;
return(NOIF);
}
/*==========================================================================*/
/* change_labels_in_statement() changes labels in the statement, if statement
contained labels refering to the shared terminal statement of DO loops.
It uses n_do_labels and do_labels array for information about current
nesting of DO loops. Returns TRUE if some labels were changed. This
routine can only be called in the pass which splits shared terminal DO
statements
*/
#if SUNC
boolean change_labels_in_statement(statement, n_do_labels, do_labels, maxline)
P_STATEMENT statement;
int n_do_labels;
long do_labels[];
int maxline;
#else
boolean change_labels_in_statement(P_STATEMENT statement, int n_do_labels,
long do_labels[], int maxline)
#endif
{
POSITION pos, start_pos, end_pos;
LABLIST label_list;
int stat_type, i, j, k;
long label;
boolean label_changed;
char extr_string[MAXEXTRLEN];
if(n_do_labels == 0)
return(FALSE);
label_changed = FALSE;
/* start at the beginning */
pos.cn = 5;
pos.ln = 0;
/* check if this is IF */
stat_type = isif(statement, &pos, &label_list);
/* if it is arithmetic, label_list is in */
if(stat_type == ARTHIF)
goto Change_all_labels;
/* block if does not have labels */
if(stat_type == BLOCKIF)
return(FALSE);
/* check if ASSIGN (standalone or following IF) */
if(isassign(statement, &pos, &label_list) == TRUE)
goto Change_all_labels;
/* check if GOTO */
if(isgoto(statement, &pos, &label_list) != NOGOTO)
goto Change_all_labels;
else
return(FALSE);
Change_all_labels:
if(label_list.n_l < 0) /* if no labels (e.g. assigned GOTO) */
return(FALSE);
/* start processing last label first, so previous labels not moved */
for (i = label_list.n_l; i >= 0; i--)
{
for (j = 1; j <= n_do_labels; j++) /* scan DO nesting list */
{
if(label_list.lab[i] == do_labels[j]) /* if label appears on both */
{
if(j < n_do_labels) /* if DO labels is not a last_do_label */
{
if(do_labels[j+1] < 0L) /* if terminal statement shared */
{
k = j;
while (k <= n_do_labels) /* find last negative label */
{
k++;
if(do_labels[k] > 0)
break;
}
k = k - 1;
start_pos = label_list.lstart[i];
end_pos = label_list.lend[i];
label = -do_labels[k];
/* cut old label */
if(cut(statement, &start_pos, &end_pos, maxline, extr_string,
MAXEXTRLEN) != TRUE)
{
fprintf(stderr,
"Error cutting out old label %ld at line %s\n",
label_list.lab[i], statement->m[0]);
exit(1);
}
/* convert new label to string */
sprintf(extr_string,"%ld",label);
/* paste in new label */
if(paste(statement, &start_pos, &end_pos, maxline,
extr_string) != TRUE)
{
fprintf(stderr,
"Error pasting new label %ld at line %s\n",
label, statement->m[0]);
exit(1);
}
label_changed = TRUE;
}
}
}
} /* end for j */
} /* end for i */
return(label_changed);
}
/*==========================================================================*/
/* convert_accept_type() converts ACCEPT and TYPE statement to corresponding
READ and WRITE statements. If ACCEPT/TYPE converted, TRUE is returned.
*/
#if SUNC
boolean convert_accept_type(statement, maxline)
P_STATEMENT statement;
int maxline;
#else
boolean convert_accept_type(P_STATEMENT statement, int maxline)
#endif
{
POSITION start_pos, end_pos, pos, pos1;
char extr_string[MAXEXTRLEN];
LABLIST label_list;
int stat_type, ch, k;
char lab_str[80];
char paste_str[15];
long label;
start_pos.cn = 5;
start_pos.ln = 0;
end_pos = start_pos;
stat_type = isif(statement, &start_pos, &label_list);
if((stat_type != NOIF) && (stat_type != LOGIF))
goto Not_A_T;
if(find_string(statement, &start_pos, &end_pos, "ACCEPT", &ch) == FALSE)
{
start_pos = end_pos;
if(find_string(statement, &start_pos, &end_pos, "TYPE", &ch) == FALSE)
goto Not_A_T;
else
strcpy(paste_str, "WRITE(*,");
}
else
strcpy(paste_str, "READ(*,");
pos = end_pos;
/* check what follows ACCEPT or TYPE */
if(isdigit(ch) != 0)
{
label = get_label(statement, &pos, &pos1, &ch);
if((label == 0L) || (ch != ','))
goto Not_A_T;
/* make end_pos point at comma */
end_pos = pos1;
ch = skip_ov_string(TRUE, statement, &end_pos);
/*prepare label string */
sprintf(lab_str,"%ld)",label);
}
else if(ch == '*')
{
ch = skip_ov_string(TRUE, statement, &pos); /* skip '*' */
ch = skip_ov_string(TRUE, statement, &pos);
if(ch != ',')
goto Not_A_T;
/* make end_pos point at ' */
end_pos = pos;
/*prepare label string */
strcpy(lab_str,"*)");
}
else if(isvaxalpha(ch) != FALSE)
{
ch = skip_ov_string(TRUE, statement, &pos); /* first letter '*' */
lab_str[0] = (char)ch;
k = 1;
while( (ch = skip_ov_string(TRUE, statement, &pos)) != EOF)
{
lab_str[k] = (char)ch;
if((isdigit(ch) == 0) && (isvaxalpha(ch) == FALSE))
goto Not_A_T;
/* end_pos will point at last char of namelist name */
end_pos = pos;
k++;
}
lab_str[k++] = ')';
lab_str[k] = '\0';
}
else
goto Not_A_T;
if(cut(statement, &start_pos, &end_pos, maxline, extr_string,
MAXEXTRLEN) != TRUE)
{
fprintf(stderr,"Error cutting out ACCEPT/TYPE statement at line %s !\n",
statement->s[start_pos.ln]);
exit(1);
}
sprintf(extr_string,"%s%s",paste_str, lab_str);
if(paste(statement, &start_pos, &end_pos, maxline, extr_string) != TRUE)
{
fprintf(stderr,"Error replacing ACCEPT/TYPE statement at line %s !\n",
statement->s[start_pos.ln]);
exit(1);
}
return(TRUE);
Not_A_T:
return(FALSE);
}
/*===================================================================*/
/* find_equal looks for position of equal sign in the statement. If found,
equal_pos is set to position of equal sign and function returns TRUE.
If no equal sign, function returns FALSE and equal_pos points at the
end of the statement. '=' inside strings are not checked.
*/
#if SUNC
boolean find_equal(statement, equal_pos)
P_STATEMENT statement;
P_POSITION equal_pos;
#else
boolean find_equal(P_STATEMENT statement, P_POSITION equal_pos)
#endif
{
int ch;
equal_pos->cn = 5;
equal_pos->ln = 0;
while ( (ch = skip_ov_string(TRUE, statement, equal_pos) ) != EOF )
{
if(ch == '=')
return(TRUE);
}
return(FALSE);
}
/*==========================================================================*/
/* type_declarations removes variable initialization from type declarations
end produces a DATA statement. For example statement
REAL*8 A(10)/10*3.0/, B/2.0/
is split into two statements:
REAL*8 A(10),B
DATA A/10*3.0/,B/2.0/
if convert_types is TRUE, the type keyword is brutally converted as:
BYTE -> INTEGER
REAL*8 -> DOUBLE PRECISION
REAL*16 -> DOUBLE PRECISION
DOUBLE COMPLEX -> COMPLEX
and all size modifiers (*m) removed except in CHARACTER declarations.
There is no way to make type conversion good, so I have chosen to
make it simple.
The routine returns TRUE if any modifications have been made.
*/
#if SUNC
boolean type_declarations(statement, data_statement, convert_types, maxline)
P_STATEMENT statement;
P_STATEMENT data_statement;
boolean convert_types;
int maxline;
#else
boolean type_declarations(P_STATEMENT statement,
P_STATEMENT data_statement,
boolean convert_types,
int maxline)
#endif
{
POSITION start_pos, end_pos, pos, pos1, data_start, data_end,
slash_start, slash_end, after_name, prev_pos;
int i, m, k, l, ch, n_paren_d, n_paren_c, type_class;
long size_in_bytes;
boolean constant_found, slash, still_space, replace_keyword;
char extr_string[MAXCONSTL], var_name[MAXCONSTL+MAXLINE];
char type_size[10];
static char VAX_types[9][17] = {
"BYTE",
"LOGICAL",
"INTEGER",
"REAL",
"COMPLEX",
"DOUBLECOMPLEX",
"DOUBLEPRECISION",
"CHARACTER*(*)",
"CHARACTER" };
constant_found = FALSE;
/* initialize data_statement */
data_statement->nc = 0;
/* 012345678901 */
strcpy(data_statement->s[0]," DATA ");
strcpy(data_statement->m[0], statement->m[0]);
data_start.cn = 11;
data_start.ln = 0;
pos.cn = 5;
pos.ln = 0;
/* check if equal sign present ('=' cannot appear in type declaration) */
start_pos = pos;
if(find_equal(statement, &start_pos) == TRUE)
{
data_statement->nc = -1;
return(FALSE);
}
/* check if type declaration */
for (i = 0; i < 9; i++)
{
type_class = i;
type_size[0] = '\0';
size_in_bytes = 0L;
start_pos = pos;
if(find_string(statement, &start_pos, &end_pos, VAX_types[i], &ch) == TRUE)
{
/* check if size given and skip it of present */
if(ch == '*')
{
pos1 = end_pos;
/* skip star */
ch = skip_ov_string(TRUE, statement, &pos1);
l = 0;
/* skip digits, variable has to start with letter and save size*/
while ( isdigit(ch = skip_ov_string(TRUE, statement, &pos1)) != 0 )
{
if(l < 9)
type_size[l++] = (char)ch;
else
{
fprintf(stderr,"Size modifier wrong on line %s !\n",
statement->m[pos1.ln]);
exit(1);
}
end_pos = pos1;
}
type_size[l] = '\0';
if(l > 0)
size_in_bytes = atol(type_size);
}
goto Find_clists;
}
}
/* not type declaration */
data_statement->nc = -1;
return(FALSE);
Find_clists:
replace_keyword = FALSE;
/* if type conversions requested find if keyword need be changed */
if(convert_types == TRUE)
{
if(type_class == 0) /* if BYTE */
{
replace_keyword = TRUE;
if(size_in_bytes < 2L) /* if no size or *1 size */
strcpy(var_name,"INTEGER");
else
strcpy(var_name,"LOGICAL");
}
else if(type_class == 3) /* if REAL */
{
if(size_in_bytes > 4L) /* if *8 or *16 */
{
replace_keyword = TRUE;
strcpy(var_name,"DOUBLE PRECISION");
}
}
else if(type_class == 5) /* if DOUBLE COMPLEX */
{
replace_keyword = TRUE;
strcpy(var_name,"COMPLEX");
}
}
/* remove old type and put the new one */
if(replace_keyword == TRUE) /* if keyword to be changed */
{
if(cut(statement, &start_pos, &end_pos, maxline,
extr_string, MAXCONSTL) != TRUE)
{
fprintf(stderr,"Failed to cut out the old type at line %s \n",
statement->m[start_pos.ln]);
exit(1);
}
if(paste(statement, &start_pos, &end_pos, maxline, var_name) != TRUE)
{
fprintf(stderr,"Failed to paste in new type at line %s \n",
statement->m[start_pos.ln]);
exit(1);
}
}
n_paren_d = 0;
n_paren_c = 0;
slash = FALSE;
l = -1;
pos = end_pos;
prev_pos = pos;
while( (ch = skip_ov_string(TRUE, statement, &pos) ) != EOF)
{
/* if size indicator, skip size */
if((ch == '*') && (n_paren_d == 0) && (slash == FALSE) )
{
while (isdigit(ch = skip_ov_string(TRUE, statement, &pos)) != 0)
;
}
if(ch == '(')
{
if(slash == FALSE)
n_paren_d++;
else
n_paren_c++;
}
if(ch == ')')
{
if(slash == FALSE)
n_paren_d--;
else
n_paren_c--;
}
if((ch == ',') && (n_paren_d == 0) && (slash == FALSE))
{
l = -1;
var_name[0] = '\0';
}
if((n_paren_d == 0) && (slash == FALSE) && (ch != ')') && (ch != ','))
{
l++;
if(l >= MAXLINE - 3)
{
fprintf(stderr,"Variable name too long at line %s !\n",
statement->m[pos.ln]);
exit(1);
}
var_name[l] = (char)ch;
}
if(ch == '/')
{
if((n_paren_d == 0) && (n_paren_c == 0) && (slash == FALSE))
{
var_name[l] = '\0';
slash_start = pos;
after_name = pos;
slash = TRUE;
}
else if((n_paren_d == 0) && (n_paren_c == 0) && (slash == TRUE))
{
slash_end = pos;
slash = FALSE;
if(constant_found == TRUE) /* if constant found before */
{ /* add comma in front of variable */
strcpy(extr_string, var_name);
strcpy(var_name, ", ");
strcat(var_name, extr_string);
}
constant_found = TRUE;
/* cut out constant list /..../ */
if(cut(statement, &slash_start, &slash_end, maxline, extr_string,
MAXCONSTL) != TRUE )
{
fprintf(stderr,"Error when cutting out /.../ at line %s \n",
statement->m[slash_start.ln]);
exit(1);
}
/* delete spaces following openning '/' and preceding closing '/' */
m = strlen(extr_string);
i = m-2;
while (isspace(extr_string[i]) != 0)
{
extr_string[i] = '/';
extr_string[i+1] = '\0';
i--;
}
m = i+2; /* new length */
k = 0;
still_space = TRUE;
for (i = 1; i <= m; i++)
{
ch = extr_string[i];
if(still_space == TRUE)
{
if(isspace(ch) != 0)
k = k + 1;
else
{
still_space = FALSE;
extr_string[i-k] = (char)ch;
}
}
else
extr_string[i-k] = (char)ch;
}
m = m - k; /* new length */
/* combine variable name and /.../ in var_name */
strcat(var_name, extr_string);
/* append the piece to data_statement */
if(paste(data_statement, &data_start, &data_end,
maxline, var_name) != TRUE)
{
fprintf(stderr,"Error when pasting %s from line %s to DATA \n",
var_name, statement->m[slash_start.ln]);
exit(1);
}
data_start = data_end;
/* move to the space following last inserted char */
ch = getsch(data_statement, &data_start, FALSE);
pos = after_name;
/* if / was the last char of statement we might be at the end */
if(statement->s[pos.ln][pos.cn] == '\0')
break;
/* prepare var_name for next name */
l = -1;
var_name[0] = '\0';
prev_pos = pos;
}
}
} /* end while */
if((n_paren_d != 0) || (n_paren_c != 0) || (slash == TRUE))
{
fprintf(stderr,"Unbalanced parantheses at line %s !\n",
statement->m[0]);
exit(1);
}
/* if convert_type is TRUE, remove all *m modifiers from the statement */
if((convert_types == TRUE) && (type_class < 7))
{
pos.cn = 5;
pos.ln = 0;
n_paren_d = 0;
while ( (ch = skip_ov_string(TRUE, statement, &pos)) != EOF )
{
if(ch == '(')
n_paren_d++;
else if(ch == ')')
n_paren_d--;
if((ch == '*') && (n_paren_d == 0))
{
start_pos = pos;
pos1 = pos;
while(isdigit(skip_ov_string(TRUE, statement, &pos1)) != 0)
end_pos = pos1;
if(cut(statement, &start_pos, &end_pos, maxline, extr_string,
MAXCONSTL) != TRUE)
{
fprintf(stderr,
"Failure to cut out size modifier (*m) at line %s \n",
statement->m[start_pos.ln]);
exit(1);
}
replace_keyword = TRUE;
ch = statement->s[start_pos.ln][start_pos.cn];
if(ch == '\0')
break;
if(ch == '(')
n_paren_d = 1;
}
}
}
if(constant_found == FALSE) /* if no DATA statement created */
data_statement->nc = -1;
if((constant_found == TRUE) || (replace_keyword == TRUE))
return(TRUE);
else
return(FALSE);
}
/*==========================================================================*/
#if SUNC
int write_statement(statement, write_marks, outfile)
P_STATEMENT statement;
boolean write_marks;
FILE *outfile;
#else
void write_statement(P_STATEMENT statement, boolean write_marks,
FILE *outfile)
#endif
{
int i;
for (i = 0; i <= statement->nc; i++)
{
if(write_marks == TRUE)
fprintf(outfile, "%s", statement->m[i]);
fprintf(outfile, "%s\n", statement->s[i]);
}
}
/*==========================================================================*/
int main(argc, argv)
int argc;
char *argv[];
{
int ch;
int i, j, k, l;
int
maxline, /* actual limit for line length, if set */
n_files, /* no. of files given on command line */
args_with_files[3], /* argument numbers holding file names */
do_type, /* type of DO loop found */
n_do_labels; /* no of nested DO's sharing terminal */
int
start_column[MAXDONEST]; /* start column where to put continue */
boolean
inp_program_end, /* holds status of program_end for inpf */
inp_EOF_found, /* holds status of EOF_founf fot inpf */
comment_out, /* if TRUE statement commented out */
remove_comments, /* if TRUE !-comments are removed */
convert_comments, /* if TRUE !-comments are converted */
make_lower, /* if TRUE change to lowercase */
make_upper, /* if TRUE change to uppercase */
cnv_accept_type, /* if TRUE ACCEPT/TYPE changed to
READ/WRITE */
convert_types, /* If TRUE VAX types converted to F77 */
cnv_OX, /* if TRUE octal and hex converted */
debug_on, /* if TRUE, temp files not deleted */
do_not_include, /* don't include statements from INCLUDE */
at_the_start, /* set to TRUE if 1st line of routine */
long_lines, /* if TRUE, source has EXTENDED lines */
list_line_marks; /* if TRUE line markers send to output */
P_STATEMENT statement, /* pntr to variable for statement */
data_statement; /* for DATA statement */
P_INCLUDE_FILES incf, incf1; /* holds currently opened include files */
P_LABELS labels; /* to hold labels found in routine */
POSITION
do_starts, /* position of D in DO statement */
do_ends, /* position of O in DO or E in WHILE */
label_starts, /* position of 1st digit of label in DO */
label_ends, /* position of last digit of label in DO*/
start_pos,
end_pos,
pos; /* auxiliary */
char
curr_line[MAXLINE], /* currently read line */
file_name[MAXNAMELEN], /* file name from option line */
temp_name1[MAXNAMELEN], /* name of temp file1 (aux1) */
temp_name2[MAXNAMELEN], /* name of temp file2 (aux2) */
extr_string[MAXEXTRLEN]; /* string to hold cut/paste things */
long
last_do_label, /* Label number assigned last DO */
last_label, /* last label found in label field */
new_label,
do_labels[MAXDONEST], /* Storage for new labels assigned to
nested DO's sharing terminal stat. */
label_do[MAXDONEST], /* store labels which appear before
DO WHILE loop */
do_label; /* labels extracted from DO statement */
FILE
*inpf, /* file with VAX code */
*outf, /* file with Standarized code */
*aux1, /* auxiliary file 1 (holds one subroutine) */
*aux2; /* auxiliary file 2 (holds one subroutine) */
boolean
inside_sub; /* TRUE if END statement not found in get_statement */
static char
copyright[] = "Jan K. Labanowski, 1990";
/* initialize file pointer to null */
inpf = NULL;
outf = NULL;
aux1 = NULL;
aux2 = NULL;
EOF_found = FALSE;
program_end = FALSE;
fprintf(stderr,"%s\n", copyright);
/* check if info requested */
i = 0;
do
{
if((argc == 1) ||
((argv[i][0] == '?') || ((argv[i][0] == '-') && (argv[i][1] == '?'))) ||
((argv[i][0] == 'h') || ((argv[i][0] == '-') && (argv[i][1] == 'h'))))
{
fprintf(stderr,
"This program converts some non-standard features of VAX Fortran to standard\n"
);
fprintf(stderr,
"ANSI FORTRAN 77. It is assumed that the source in VAX FORTRAN is error free.\n"
);
fprintf(stderr,
"By default program converts unlabeled DO...END DO loops, DO WHILE loops, \n"
);
fprintf(stderr,
"constant lists in type declarations, INCLUDEs files, and unfolds TABs in \n"
);
fprintf(stderr,
"the label field. Additional actions can be requested by options below:\n"
);
fprintf(stderr,
" -a convert ACCEPT/TYPE -x convert octal/hex constants\n"
);
fprintf(stderr,
" -l convert letters to lowercase -u convert letters to uppercase\n"
);
fprintf(stderr,
" -r convert ! comments -R remove ! comments\n"
);
fprintf(stderr,
" -t convert VAX types -I skip INCLUDE files in output\n"
);
fprintf(stderr,
" -i input file name -o output file name\n"
);
fprintf(stderr,
" -n ddd line length -L line numbers in output\n"
);
fprintf(stderr,
" -S perform all conversions -d debugging run\n"
);
fprintf(stderr,
" -E you must enter this option if program contains EXTEND_SOURCE lines.\n"
);
fprintf(stderr,
"To learn more about each option, enter option followed by h (e.g. -ih).\n"
);
fprintf(stderr,
"Error messages contain level of INCLUDE nesting followed by line number.\n"
);
fprintf(stderr,
"You have to enter something on the command line before you can run this\n"
);
fprintf(stderr,
"program. If you do not know what, -n80 is a good choice.\n"
);
fprintf(stderr,
"Program is not copyrighted and you are permitted to copy it.\n"
);
fprintf(stderr,
"Comments and bug reports to: Jan K. Labanowski,\n"
);
fprintf(stderr,
"Ohio Supercomputer Center, 1224 Kinnear Road, Columbus, OH 43212\n"
);
fprintf(stderr,
"Phone: 614-292-9279, E-mail: jkl@ccl.net, JKL@OHSTPY.BITNET\n"
);
exit(0);
}
i++;
}
while ( i < argc );
if( (i = find_option(argc, argv, VALUEOPTIONS, 'h', curr_line) ) != 0)
{
k = strlen(argv[i]);
if((k > 3) || (argv[i][2] != 'h'))
{
fprintf(stderr,"One option at a time please...\n");
exit(0);
}
}
unknown_option(argc, argv, OPTIONS, VALUEOPTIONS);
check_option_conflict(argc, argv, "rR", VALUEOPTIONS);
check_option_conflict(argc, argv, "rE", VALUEOPTIONS);
check_option_conflict(argc, argv, "lu", VALUEOPTIONS);
check_option_conflict(argc, argv, "SR", VALUEOPTIONS);
if(find_option(argc, argv, VALUEOPTIONS, 'a', curr_line) != 0)
{
if((curr_line[0] == 'h') && (curr_line[1] == '\0'))
{
fprintf(stderr,
" Option: -a\n"
);
fprintf(stderr,
"This option converts ACCEPT fmt,list and TYPE fmt,list statements\n"
);
fprintf(stderr,
"to corresponding READ(*,fmt)list and WRITE(*,fmt)list statements,\n"
);
fprintf(stderr,
"e.g., statement ACCEPT 100, n, m is converted to READ(*,100)n, m\n"
);
fprintf(stderr,
"Example: \n"
);
fprintf(stderr,
" vaxtostd -a -l -i myprogram.for -o myprogram.f\n"
);
fprintf(stderr,
"is equivalent to\n"
);
fprintf(stderr,
" vaxtostd -al myprogram.for myprogram.f\n"
);
fprintf(stderr,
"VAX FORTRAN input taken from file myprogram.for and converted FORTRAN\n"
);
fprintf(stderr,
"source is sent to file myprogram.f. The ACCEPT/TYPE statements are\n"
);
fprintf(stderr,
"converted to READ/WRITE and letters are changed to lower case\n"
);
exit(0);
}
cnv_accept_type = TRUE;
}
else
cnv_accept_type = FALSE;
if(find_option(argc, argv, VALUEOPTIONS, 'I', curr_line) != 0)
{
if((curr_line[0] == 'h') && (curr_line[1] == '\0'))
{
fprintf(stderr,
" Option: -I\n"
);
fprintf(stderr,
"By default, the contents of INCLUDE files is incorporated in the converted\n"
);
fprintf(stderr,
"program. You can prevent it by using -I option. The include files will be\n"
);
fprintf(stderr,
"read and analysed, but will not be saved in output file.\n"
);
fprintf(stderr,
"Example:\n"
);
fprintf(stderr,
" vaxtostd -IS myprog.for myprog.f\n"
);
fprintf(stderr,
"Performs all conversions but does not send INCLUDE files contents to the\n"
);
fprintf(stderr,
"output file myprog.f.\n"
);
exit(0);
}
do_not_include = TRUE;
}
else
do_not_include = FALSE;
if(find_option(argc, argv, VALUEOPTIONS, 'E', curr_line) != 0)
{
if((curr_line[0] == 'h') && (curr_line[1] == '\0'))
{
fprintf(stderr,
"Option: -E\n"
);
fprintf(stderr,
"The standard FORTRAN skips characters in columns 73 and higher. The VAX\n"
);
fprintf(stderr,
"FORTRAN allows for statement field to continue up to column 132 provided \n"
);
fprintf(stderr,
"that /EXTEND_SOURCE compiler option is used. To deal with programs written\n"
);
fprintf(stderr,
"this way, you have to use -E options. As a result, the long lines will be\n"
);
fprintf(stderr,
"chopped into pieces to fit 7-72 statement field of standard FORTRAN. \n"
);
fprintf(stderr,
"The end-of-line comments (!) will be converted to standard FORTRAN comments\n"
);
fprintf(stderr,
"and placed before first line of the statement. You can also remove these\n"
);
fprintf(stderr,
"comments by using -R option. By default, this program treats characters in\n"
);
fprintf(stderr,
"columns 73 and up as comments and does not include them when analysing\n"
);
fprintf(stderr,
"syntax.\n"
);
fprintf(stderr,
"Example:\n"
);
fprintf(stderr,
" vaxtostd -ESR myprog.for myprog.f\n"
);
fprintf(stderr,
"performs all conversions for VAX source with extended lines and removes\n"
);
fprintf(stderr,
"end-of-line comments.\n"
);
exit(0);
}
long_lines = TRUE;
}
else
long_lines = FALSE;
if(find_option(argc, argv, VALUEOPTIONS, 't', curr_line) != 0)
{
if((curr_line[0] == 'h') && (curr_line[1] == '\0'))
{
fprintf(stderr,
" Option -t\n"
);
fprintf(stderr,
"This option performs brutal conversion of VAX data types into FORTRAN 77\n"
);
fprintf(stderr,
"types. By default, type conversions are not performed. There is no good way\n"
);
fprintf(stderr,
"of performing type conversions since standard ANSI FORTRAN 77 does not have\n"
);
fprintf(stderr,
"many of the types available in VAX FORTRAN. You most likely will have to ad-\n"
);
fprintf(stderr,
"just types manually in the converted program with your favorite editor. This\n");
fprintf(stderr,
"program only replaces the keyword in type declarations and skips size modi-\n"
);
fprintf(stderr,
"fiers ( star followed by variable size in bytes ). \n"
);
fprintf(stderr,
"The conversions are performed according to following chart:\n"
);
fprintf(stderr,
" VAX types FORTRAN 77 type\n"
);
fprintf(stderr,
" BYTE, BYTE*1 INTEGER\n"
);
fprintf(stderr,
" BYTE*2, BYTE*4 LOGICAL\n"
);
fprintf(stderr,
" all INTEGER types INTEGER\n"
);
fprintf(stderr,
" REAL*4 REAL\n"
);
fprintf(stderr,
" REAL*8, REAL*16 DOUBLE PRECISION\n"
);
fprintf(stderr,
" all COMPLEX COMPLEX\n"
);
fprintf(stderr,
"Example:\n"
);
fprintf(stderr,
" vaxtostd -IRtax -imyprog.for -omyprog.f\n"
);
fprintf(stderr,
"In addition to default conversions performs type conversions, ACCEPT/TYPE\n"
);
fprintf(stderr,
"to READ/WRITE, octal/hex constants, removes end-of-line comments and\n"
);
fprintf(stderr,
"does not incorporate INCLUDE files in the converted program\n"
);
exit(0);
}
convert_types = TRUE;
}
else
convert_types = FALSE;
if(find_option(argc, argv, VALUEOPTIONS, 'x', curr_line) != 0)
{
if((curr_line[0] == 'h') && (curr_line[1] == '\0'))
{
fprintf(stderr,
" Option: -x\n"
);
fprintf(stderr,
"This option converts octal and hexadecimal constants to corresponding\n"
);
fprintf(stderr,
"decimal values. E.g '11'o is converted to 9 and 'FF'X to 255. Be carefull\n"
);
fprintf(stderr,
"to take these conversion for granted. Octal and hexadecimal constants are\n"
);
fprintf(stderr,
"in most cases used for describing machine specific parameters and you might\n"
);
fprintf(stderr,
"need much more work to make program run on the non-VAX computer than merely\n"
);
fprintf(stderr,
"changing the constants to a decimal form.\n"
);
fprintf(stderr,
"Example:\n"
);
fprintf(stderr,
" vaxtostd -xalR -i myprog.for -o myprog.f\n"
);
fprintf(stderr,
"will change constants to a decimal form, convert ACCEPT/TYPE statements,\n"
);
fprintf(stderr,
"change letters to lowercase, and erase in-line comments (! comments).\n"
);
exit(0);
}
cnv_OX = TRUE;
}
else
cnv_OX = FALSE;
if(find_option(argc, argv, VALUEOPTIONS, 'L', curr_line) != 0)
{
if((curr_line[0] == 'h') && (curr_line[1] == '\0'))
{
fprintf(stderr,
" Option: -L\n"
);
fprintf(stderr,
"This option is for debugging purposes. It will save line numbers in the\n"
);
fprintf(stderr,
"output file together with statements. \n"
);
fprintf(stderr,
"Example:\n"
);
fprintf(stderr,
" vaxtostd -LSd myprog.for myprog.f\n"
);
fprintf(stderr,
"will perform debugging run of the program with all conversions requested\n"
);
fprintf(stderr,
"and will save line numbers in the output file.\n"
);
exit(0);
}
list_line_marks = TRUE;
}
else
list_line_marks = FALSE;
if(find_option(argc, argv, VALUEOPTIONS, 'd', curr_line) != 0)
{
if((curr_line[0] == 'h') && (curr_line[1] == '\0'))
{
fprintf(stderr,
" Option: -d\n"
);
fprintf(stderr,
"This program assumes that the VAX source is error free. It does only very\n"
);
fprintf(stderr,
"limited checking for syntax correctness. This program will also expose its\n"
);
fprintf(stderr,
"bugs with time. Option -d helps locate on which stage the error occurred.\n"
);
fprintf(stderr,
"This code analyses and converts VAX source in stages, one routine at a time.\n"
);
fprintf(stderr,
"Partially converted code is stored in termporary files whose file names are:\n"
);
fprintf(stderr,
"junk*.ax1 and junk*.ax2 ( star stands for some number ). Normally these \n"
);
fprintf(stderr,
"files are deleted after errorless run, however with -d option you can\n"
);
fprintf(stderr,
"preserve these files for analysis. The source is analysed in four PASses:\n"
);
fprintf(stderr,
" PAS1: saves labels for routine, extracts constants from type declarations,\n"
);
fprintf(stderr,
" changes types, changes labeled ENDDO's to CONTINUE's, converts octal\n"
);
fprintf(stderr,
" hex constants, ACCEPT/TYPE statements, and ! comments. To: junk*.ax1\n"
);
fprintf(stderr,
" PAS2: splits shared terminal statements of DO loops into separate state-\n"
);
fprintf(stderr,
" ments for each loop. Changes labels in DO's, GOTO's, ASSIGN's and\n"
);
fprintf(stderr,
" arithmetic IF's accordingly. Output saved in junk*.ax2.\n"
);
fprintf(stderr,
" PAS3: converts unlabeled DO...ENDDO to labeled DO...CONTINUE and unlabeled\n"
);
fprintf(stderr,
" DO...WHILE to IF...GOTO statements. Output overwrites junk*.ax1\n"
);
fprintf(stderr,
" PAS4: converts labeled DO...WHILE loops to IF...GOTO combination. Also\n"
);
fprintf(stderr,
" letter case is changed if requested. Output goes to output file.\n"
);
exit(0);
}
debug_on = TRUE;
}
else
debug_on = FALSE;
if(find_option(argc, argv, VALUEOPTIONS, 'R', curr_line) != 0)
{
if((curr_line[0] == 'h') && (curr_line[1] == '\0'))
{
fprintf(stderr,
" Option: -R\n"
);
fprintf(stderr,
"This option deleted all end-of-line comments (comments starting in state-\n"
);
fprintf(stderr,
"field and preceded by !). By default end-of-line comments are not affected\n"
);
fprintf(stderr,
"since many FORTRAN compilers tolerate them. However, they are not standard.\n"
);
fprintf(stderr,
"See also option -r (convert end-of-line comments).\n"
);
fprintf(stderr,
"Example:\n"
);
fprintf(stderr,
" vaxtostd -RE vaxprog.for newprog.f\n"
);
fprintf(stderr,
"removes comments in the program containing extended source lines.\n"
);
exit(0);
}
remove_comments = TRUE;
}
else
remove_comments = FALSE;
if(find_option(argc, argv, VALUEOPTIONS, 'r', curr_line) != 0)
{
if((curr_line[0] == 'h') && (curr_line[1] == '\0'))
{
fprintf(stderr,
" Option: -r\n"
);
fprintf(stderr,
"This option converts end-of-line VAX comments (comments preceded by !) to\n"
);
fprintf(stderr,
"standard FORTRAN comments (C in column 1). Comments are extracted from sta-\n"
);
fprintf(stderr,
"tement lines and placed before the 1st line of statement. To preserve orig-\n"
);
fprintf(stderr,
"inal layout of the program, the comment text is preceded by appropriate num-\n"
);
fprintf(stderr,
"ber of spaces to start in the same column as in original VAX source.\n"
);
fprintf(stderr,
"The -r option has no effect when -E (extended source lines) was spacified.\n"
);
fprintf(stderr,
"In this case all end-of-line comments are converted to standard C comments.\n"
);
fprintf(stderr,
"By default the end-of_line comments are not affected (except for -E option).\n"
);
fprintf(stderr,
"See also option -R (remove end-of-line comments).\n"
);
fprintf(stderr,
"Example: \n"
);
fprintf(stderr,
" vaxtostd -r myprog.for\n"
);
fprintf(stderr,
"converts comments and performs minimal set of conversions, and shows the\n"
);
fprintf(stderr,
"converted program on your terminal\n"
);
exit(0);
}
convert_comments = TRUE;
}
else
convert_comments = FALSE;
if(find_option(argc, argv, VALUEOPTIONS, 'S', curr_line) != 0)
{
if((curr_line[0] == 'h') && (curr_line[1] == '\0'))
{
fprintf(stderr,
" Option: -S\n"
);
fprintf(stderr,
"This option requests that all conversions which make FORTRAN more standard\n"
);
fprintf(stderr,
"be performed. In addition to default conversions, the following options are\n"
);
fprintf(stderr,
"activated: -artux (change ACCEPT/TYPE, convert end-of-line comments, change\n"
);
fprintf(stderr,
"types, change to uppercase, convert osctal/hex constants to decimal).\n"
);
fprintf(stderr,
"Example:\n"
);
fprintf(stderr,
" vaxtostd -SE myprog.for myprog.f\n"
);
fprintf(stderr,
"performs all conversions on the VAX program with extended lines.\n"
);
exit(0);
}
make_upper = TRUE;
make_lower = FALSE;
convert_comments = TRUE;
remove_comments = FALSE;
cnv_accept_type = TRUE;
cnv_OX = TRUE;
convert_types = TRUE;
}
if(find_option(argc, argv, VALUEOPTIONS, 'l', curr_line) != 0)
{
if((curr_line[0] == 'h') && (curr_line[1] == '\0'))
{
fprintf(stderr,
" Option: -l\n"
);
fprintf(stderr,
"This option changes all letters outside character constants, Hollerith\n"
);
fprintf(stderr,
"constants and comments to lowercase. Many FORTRAN compilers accept lower-\n"
);
fprintf(stderr,
"case letters which are considered by many people more readable than upper-\n"
);
fprintf(stderr,
"case ones. If neither -l nor -u options is specified, lettercase is not\n"
);
fprintf(stderr,
"changed.\n"
);
fprintf(stderr,
"Example:\n"
);
fprintf(stderr,
" vaxtostd -l prog.for prog.f\n"
);
fprintf(stderr,
"converts letters to lowercase. It will also convert DO...ENDDO loops,\n"
);
fprintf(stderr,
"DO WHILE loops, remove variable initialization to a separate DATA state-\n"
);
fprintf(stderr,
"ment, include INCLUDE files, unfold TABs in label field, and append sepa-\n"
);
fprintf(stderr,
"rate terminal statements to nested DO loops which share terminal statement.\n"
);
exit(0);
}
make_lower = TRUE;
}
else
make_lower = FALSE;
if(find_option(argc, argv, VALUEOPTIONS, 'u', curr_line) != 0)
{
if((curr_line[0] == 'h') && (curr_line[1] == '\0'))
{
fprintf(stderr,
" Option: -u\n"
);
fprintf(stderr,
"This option changes all letters outside character constants, Hollerith\n"
);
fprintf(stderr,
"constants and comments to uppercase. Some FORTRAN compilers may not accept\n"
);
fprintf(stderr,
"lowercase letters. If neither -l nor -u options is specified, lettercase is\n"
);
fprintf(stderr,
"not changed.\n"
);
fprintf(stderr,
"Example:\n"
);
fprintf(stderr,
" vaxtostd -u prog.for prog.f\n"
);
fprintf(stderr,
"converts letters to uppercase. It will also convert DO...ENDDO loops,\n"
);
fprintf(stderr,
"DO WHILE loops, remove variable initialization to a separate DATA state-\n"
);
fprintf(stderr,
"ment, include INCLUDE files, unfold TABs in label field, and append sepa-\n"
);
fprintf(stderr,
"rate terminal statements to nested DO loops which share terminal statement.\n"
);
exit(0);
}
make_upper = TRUE;
}
else
make_upper = FALSE;
/* get -n option (max. chars on line) */
maxline = 80; /* default is 80 characters */
if(find_option(argc, argv, VALUEOPTIONS, 'n', curr_line) != 0)
{
if((curr_line[0] == 'h') && (curr_line[1] == '\0'))
{
fprintf(stderr,
" Option: -n ddd or -nddd\n"
);
fprintf(stderr,
"This option allows you to specify maximum line length. The ddd is up to \n"
);
fprintf(stderr,
"three digits specifying maximum line length in characters. If your VAX pro-\n"
);
fprintf(stderr,
"gram does not contain EXTEND_SOURCE statements, columns 73 and up can be \n"
);
fprintf(stderr,
"used for comments (traditinally columns 73-80 were used for card numbers).\n"
);
fprintf(stderr,
"Program by default truncates lines to 80 character long. If you have long\n"
);
fprintf(stderr,
"comments you can change it by this option. If -E option is used, comments\n"
);
fprintf(stderr,
"longer than 80 characters are truncated. You can extend comment length up\n"
);
fprintf(stderr,
"to 132 by using this option. \n"
);
fprintf(stderr,
"Example: \n"
);
fprintf(stderr,
" vaxtostd -S -n72 vaxprogram.for myprogram.f\n"
);
fprintf(stderr,
"will erase all characters in columns 73 and up and perform default conver-\n"
);
fprintf(stderr,
"sions to make source code more standard FORTRAN.\n"
);
exit(0);
}
l = strlen(curr_line);
if(l == 0)
{
fprintf(stderr,"No line length given with option -n !\n");
exit(1);
}
/* check if all digits */
for (i = 0; i < l; i++)
{
if(isdigit(curr_line[i]) == 0)
{
fprintf(stderr,"Option -n must be followed by digits only !\n");
exit(1);
}
}
maxline = atoi(curr_line);
if(maxline < 72)
{
fprintf(stderr,"Line length reset to 72 characters long !\n");
maxline = 72;
}
if(maxline > 132)
{
fprintf(stderr,"Line length reset to 132 characters long !\n");
maxline = 132;
}
}
n_files = 0;
/* check if input file given with option -i */
if(find_option(argc, argv, VALUEOPTIONS, 'i', file_name) != 0)
/* check if on line */
{
if((file_name[0] == 'h') && (file_name[1] == '\0'))
{
fprintf(stderr,
" Option: -i file_name or -ifile_name\n"
);
fprintf(stderr,
"This option allows you to specify an input file from which the VAX source\n"
);
fprintf(stderr,
"will be taken. You can skip -i and enter input file name without an option.\n"
);
fprintf(stderr,
"In this case the first file name on the command line will be taken as\n"
);
fprintf(stderr,
"input. If you do not specify an input file, the standard input is assumed.\n"
);
fprintf(stderr,
"Example: \n"
);
fprintf(stderr,
" vaxtostd -EIu -i myprogram.for > myprogram.f\n"
);
fprintf(stderr,
"is equivalent to\n"
);
fprintf(stderr,
" vaxtostd -EIu -o myprogram.f myprogram.for \n"
);
fprintf(stderr,
"is equivalent ro\n"
);
fprintf(stderr,
" vaxtistd -EIu -o myprogram.f < myprogram.for\n"
);
fprintf(stderr,
"VAX FORTRAN source is taken from file myprogram.for. The source contains\n"
);
fprintf(stderr,
"lines with statement field extending beyond column 72. Contents of INCLUDE\n"
);
fprintf(stderr,
"files will not be sent to output file myprogram.f. All letters outside char-\n"
);
fprintf(stderr,
"acter constants, Hollerith constants and comments will be changed to upper-\n"
);
fprintf(stderr,
"case. \n"
);
exit(0);
}
if(strlen(file_name) == 0)
{
fprintf(stderr,"No name for input file given with option -i !\n");
exit(1);
}
if((inpf = fopen(file_name, "r")) == NULL)
{
fprintf(stderr,"File %s cannot be opened as input !\n", file_name);
exit(1);
}
n_files++;
}
/* check if output file given with option -o */
if(find_option(argc, argv, VALUEOPTIONS, 'o', file_name) != 0)
/* check if on line */
{
if((file_name[0] == 'h') && (file_name[1] == '\0'))
{
fprintf(stderr,
" Option: -o file_name or -ofile_name\n"
);
fprintf(stderr,
"This option allows you to specify an output file to which the converted\n"
);
fprintf(stderr,
"source code is sent. You can skip -o and enter output file name without this\n"
);
fprintf(stderr,
"option. In this case the second file name on the command line will be taken\n"
);
fprintf(stderr,
"as output. If you do not specify an output file, the standard output is\n"
);
fprintf(stderr,
"assumed.\n"
);
fprintf(stderr,
"Example:\n"
);
fprintf(stderr,
" vaxtostd -SE -i myprogram.for -omyprogram.f\n"
);
fprintf(stderr,
"is equivalent to\n"
);
fprintf(stderr,
" vaxtostd -SE myprogram.for myprogram.f\n"
);
fprintf(stderr,
"is equivalent to\n"
);
fprintf(stderr,
" vaxtostd -SE myprogram.f \n"
);
fprintf(stderr,
"All standard conversions will be performed to make source program closer\n"
);
fprintf(stderr,
"to ANSI FORTRAN 77 standard. It is assumed that VAX FORTRAN source has\n"
);
fprintf(stderr,
"lines whose statement field extends beyond column 72\n"
);
exit(0);
}
if(strlen(file_name) == 0)
{
fprintf(stderr,"No name for output file given with option -o !\n");
exit(1);
}
if((outf = fopen(file_name, "r")) != NULL)
{
fprintf(stderr,
"Output file %s already exists! I will not overwrite it... \n",
file_name);
exit(1);
}
fclose(outf);
if((outf = fopen(file_name, "w")) == NULL)
{
fprintf(stderr,"File %s cannot be opened as output !\n", file_name);
exit(1);
}
n_files++;
}
/* check if files given on command line without option -i or -o */
k = 0;
for (i = 1; i < argc; i++)
{
if(argv[i][0] != '-') /* if filename on command line */
{
if(i > 1)
{
if(argv[i-1][0] == '-') /* if previous arg was an option */
{
l = strlen(argv[i-1]);
ch = argv[i-1][1];
/* check if value option followed by value (these are taken care*/
if((char_in_string(ch, VALUEOPTIONS) > 0) && (l == 2))
continue;
}
}
k++;
if(k < 3)
args_with_files[k] = i;
}
}
if(k + n_files > 2)
{
fprintf(stderr, "You specified more than two files on command line !\n");
exit(1);
}
if(k > 0) /* if some files were given without -i/-o option */
{
i = args_with_files[1];
if(inpf == NULL) /* if input was not opened */
{
i = args_with_files[1];
if((inpf = fopen(argv[i], "r")) == NULL)
{
fprintf(stderr,
"File %s cannot be opened as input !\n", argv[i]);
exit(1);
}
i = args_with_files[k]; /* the next one if given is output */
k--; /* this file consumed */
}
if(k > 0)
{
if(outf == NULL) /* if output file wasn not opened */
{
if((outf = fopen(argv[i], "r")) != NULL)
{
fprintf(stderr,
"Output file %s already exists! I will not overwrite it... \n",
argv[i]);
exit(1);
}
fclose(outf);
if((outf = fopen(argv[i], "w")) == NULL)
{
fprintf(stderr,"File %s cannot be opened as output !\n",
argv[i]);
exit(1);
}
}
}
}
if(inpf == NULL) /* if input file not given, use standard input */
inpf = stdin;
if(outf == NULL) /* if output file not given, use standard output */
outf = stdout;
/* open temporary files for holding current routine */
for (i = 0; i < 9999; i++)
{
sprintf(temp_name1,"junk%d.ax1",i);
sprintf(temp_name2,"junk%d.ax2",i);
/* check if file temp file exists */
if(((aux1 = fopen(temp_name1,"r")) == NULL) &&
((aux2 = fopen(temp_name2,"r")) == NULL) )
{
aux1 = fopen(temp_name1, "w"); /* open temp files for writing */
aux2 = fopen(temp_name2, "w");
break;
}
fclose(aux1);
fclose(aux2);
}
/* Close temp files for now */
fclose(aux1);
fclose(aux2);
/* allocate memory for variables */
statement = (P_STATEMENT)malloc(sizeof(STATEMENT));
if(statement == NULL)
{
fprintf(stderr,
"Error when allocating storage for statement structure !\n");
exit(1);
}
/* allocate memory for variables */
data_statement = (P_STATEMENT)malloc(sizeof(STATEMENT));
if(data_statement == NULL)
{
fprintf(stderr,
"Error when allocating storage for statement structure !\n");
exit(1);
}
incf = (P_INCLUDE_FILES)malloc(sizeof(INCLUDE_FILES));
if(incf == NULL)
{
fprintf(stderr,"Error when allocating storage for incf structure !\n");
exit(1);
}
incf1 = (P_INCLUDE_FILES)malloc(sizeof(INCLUDE_FILES));
if(incf1 == NULL)
{
fprintf(stderr,"Error when allocating storage for incf1 structure !\n");
exit(1);
}
labels = (P_LABELS)malloc(sizeof(LABELS));
if(labels == NULL)
{
fprintf(stderr,"Error when allocating storage for labels structure !\n");
exit(1);
}
/* initialize variables for reading input file */
program_end = FALSE;
EOF_found = FALSE;
incf->inf[0] = inpf;
incf->n_lin[0] = 0L;
incf->ni = 0;
strcpy(incf->in[0], "INPUT FILE");
/* read routines */
while (program_end == FALSE)
{
/*initialize labels for routine*/
labels->n_lab = 1;
labels->l[0] = 0L; /* real labels have to be larger than 0 */
labels->l[1] = 200000L; /* and smaller than 10000 (5 digits) */
/* open aux1 file for writing */
if( (aux1 = fopen(temp_name1, "w")) == NULL)
{
fprintf(stderr,"Error when opening temp file %s !\n",temp_name1);
exit(1);
}
/* loop until END statement found */
at_the_start = TRUE;
do
{
if(long_lines == TRUE)
k = 132;
else
k = maxline;
inside_sub = get_statement(statement,incf,FALSE,TRUE, TRUE,
do_not_include, k, aux1);
if(statement->nc < 0)
goto Close_files;
if(long_lines == TRUE)
convert_extended_statement(statement, data_statement, maxline,
remove_comments, aux1);
/* print first line of routine if debug is on */
if((debug_on == TRUE) && (at_the_start == TRUE))
fprintf(stderr,"PAS 1\n%s\n\n",statement->s[0]);
at_the_start = FALSE;
if((convert_comments == TRUE) || (remove_comments == TRUE))
decomment(remove_comments, TRUE, statement, aux1);
if(cnv_accept_type == TRUE)
convert_accept_type(statement, maxline);
if(type_declarations(statement, data_statement,
convert_types, maxline) == TRUE)
{
write_statement(statement, TRUE, aux1);
write_statement(data_statement, TRUE, aux1);
continue;
}
if(cnv_OX == TRUE)
convert_to_decimal(statement, maxline);
/* comment out IMPLICIT NONE & OPTIONS */
comment_out = FALSE;
if(find_string(statement, &start_pos,
&end_pos,"IMPLICITNONE", &ch) == TRUE)
{
if(ch == EOF)
comment_out = TRUE;
}
start_pos.cn = 5;
start_pos.ln = 0;
if(find_string(statement, &start_pos,
&end_pos, "OPTIONS/", &ch) == TRUE)
comment_out = TRUE;
if(comment_out == TRUE)
{
for (i = 0; i <= statement->nc; i++)
{
/* statement in 1st pass does not have empty lines */
statement->s[i][0] = 'C';
for (j = 1; j < 4; j++)
statement->s[i][j] = '*';
}
}
if( (last_label = extract_label(statement)) != 0L)
{
if(save_label(last_label, labels) == FALSE)
{
fprintf(stderr,"Repeated label at line %s !\n",
statement->m[0]);
exit(1);
}
/* change all labeled ENDDO's to CONTINUE's */
start_pos.cn = 5;
start_pos.ln = 0;
if(find_string(statement,&start_pos, &end_pos, "ENDDO", &ch) == TRUE)
{
if(ch == EOF)
{
cut(statement, &start_pos, &end_pos, maxline, extr_string,
MAXEXTRLEN);
paste(statement, &start_pos, &end_pos, maxline, "CONTINUE");
}
}
}
/* write statement to aux1 */
write_statement(statement, TRUE, aux1);
} /* end of inside routine */
while (inside_sub == TRUE);
/* save flags for input file */
inp_program_end = program_end;
inp_EOF_found = EOF_found;
program_end = FALSE;
EOF_found = FALSE;
/* close aux1 file to flush buffer */
fclose(aux1);
/* now reopen aux1 file for reading and aux2 for writing */
if( (aux1 = fopen(temp_name1, "r")) == NULL)
{
fprintf(stderr,"File %s was deleted when this program ran !\n",
temp_name1);
exit(1);
}
if( (aux2 = fopen(temp_name2, "w")) == NULL)
{
fprintf(stderr,"Cannot open temp file %s !\n",
temp_name2);
exit(1);
}
/* Now read the subroutine from aux1 file and write to aux2 */
/* This pass splits shared terminal statements of DO loops */
incf1->inf[0] = aux1;
incf1->n_lin[0] = 0L;
incf1->ni = 0;
strcpy(incf1->in[0], temp_name1);
/* loop until END statement found */
/* this part adds separate terminal statement to DO loops
which share terminal statement */
last_do_label = 0L;
n_do_labels = 0;
do_labels[0] = 0L;
at_the_start = TRUE;
do
{
inside_sub = get_statement(statement,incf1,TRUE,TRUE, FALSE,
do_not_include, maxline, aux2);
/* print first line of routine if debug is on */
if((debug_on == TRUE) && (at_the_start == TRUE))
fprintf(stderr,"PAS 2\n%s\n\n",statement->s[0]);
if((inside_sub == FALSE) && (n_do_labels != 0))
{
fprintf(stderr,"Wrong nesting of DO loops at line %s !\n",
statement->m[0]);
exit(1);
}
at_the_start = FALSE;
if( (do_type = isdo(&do_starts, &do_ends, &label_starts, &label_ends,
&do_label, statement)) != NOTDOLOOP)
{
/* if labeled DO's */
if((do_type == DOLOOPLAB) || (do_type == DOWHILELAB))
{
/* if new label, increase nesting lebel */
if(last_do_label != do_label)
{
n_do_labels++;
if(n_do_labels >= MAXDONEST)
{
fprintf(stderr,"Too many nested loops at line %s !\n",
statement->m[0]);
exit(1);
}
do_labels[n_do_labels] = do_label;
last_do_label = do_label;
start_column[n_do_labels] =
do_starts.cn > 60 ? 6 : do_starts.cn;
}
else /* if labels equal, i.e. DO's share terminal statement */
{
/* get new unused label */
new_label = fetch_new_label(last_do_label, labels);
if(new_label == 0L)
{
fprintf(stderr,
"Error when assigning new label for DO statement at line %s !\n",
statement->m[0]);
exit(1);
}
n_do_labels++;
if(n_do_labels >= MAXDONEST)
{
fprintf(stderr,"Too many nested loops at line %s !\n",
statement->m[0]);
exit(1);
}
/* save new label as negative to mark that it is new label */
do_labels[n_do_labels] = -new_label;
start_column[n_do_labels] =
do_starts.cn > 60 ? 6 : do_starts.cn;
/* replace old label with new label */
if(cut(statement, &label_starts, &label_ends, maxline,
extr_string, MAXEXTRLEN) != TRUE)
{
fprintf(stderr,
"Cannot cut the label out of DO statement at line %s !",
statement->m[label_starts.ln]);
exit(1);
}
/* prepare string with new label and paste it */
sprintf(extr_string,"%ld",new_label);
if(paste(statement, &label_starts, &label_ends, maxline,
extr_string) != TRUE)
{
fprintf(stderr,
"Cannot paste the label into DO statement at line %s !",
statement->m[label_starts.ln]);
exit(1);
}
}
}
} /* end if isdo */
/* make changes in GOTO's, ASSIGNS and IF's reflecting new labels */
change_labels_in_statement(statement, n_do_labels, do_labels, maxline);
/* Look for terminal statement of DO */
if( (new_label = extract_label(statement)) != 0L )
{
if(new_label == last_do_label)
{
/* check if this terminal statement is shared */
if(do_labels[n_do_labels] < 0L)
{
new_label = -do_labels[n_do_labels--];
change_label_field(new_label, statement);
/* write statement to aux2 */
write_statement(statement, TRUE, aux2);
/* write termination statements for all other loops
which shared terminal statement and remove labels from
the do_labels stack */
do
{
new_label = do_labels[n_do_labels];
last_do_label = new_label;
if(last_do_label < 0L)
last_do_label = -last_do_label;
fprintf(aux2,"%s%5ld ", statement->m[0], last_do_label);
k = start_column[n_do_labels];
for (i = 6; i < k; i++)
fputc(' ',aux2);
fprintf(aux2,"CONTINUE\n");
n_do_labels--;
if(n_do_labels < 0)
{
fprintf(stderr,
"Internal program error at DO nesting.\n");
exit(1);
}
}
while (new_label < 0L);
/* find previous last_do_label */
i = n_do_labels;
while (do_labels[i] < 0L)
i--;
last_do_label = do_labels[i];
continue; /* statements were already sent to aux2 */
}
else /* if do_label[n_do_labels] > 0 */
{
if(last_do_label != do_labels[n_do_labels])
{
fprintf(stderr,"DO loop nesting messed up at line %s !\n",
statement->m[0]);
exit(1);
}
else
{
/* find previous last_do_label */
n_do_labels--;
if(n_do_labels < 0)
{
fprintf(stderr,"DO nesting messed up at line %s ?\n",
statement->m[0]);
exit(1);
}
i = n_do_labels;
while (do_labels[i] < 0)
i--;
last_do_label = do_labels[i];
}
} /* end do_label > 0 */
} /* end if last_do_label = label */
} /* extracted label > 0 */
/* write statement to aux2 */
write_statement(statement, TRUE, aux2);
} /* end of inside routine */
while (inside_sub == TRUE);
program_end = FALSE;
EOF_found = FALSE;
/* close files aux1 and aux2 and reopen them with w and r modes */
fclose(aux1);
fclose(aux2);
if( (aux1 = fopen(temp_name1, "w") ) == NULL)
{
fprintf(stderr,"Cannot open file temporary %s \n", temp_name1);
exit(1);
}
if( (aux2 = fopen(temp_name2, "r") ) == NULL)
{
fprintf(stderr,"Temp file %s was deleted when this program ran !\n",
temp_name2);
exit(1);
}
/* this pass converts unlabeled DO loops to labeled DO loops and
unlabeled DO WHILE loops to IF...GOTO */
incf1->inf[0] = aux2;
incf1->n_lin[0] = 0L;
incf1->ni = 0;
strcpy(incf1->in[0], temp_name2);
/* loop until END statement found */
last_label = 1L;
last_do_label = 0L;
n_do_labels = 0;
do_labels[0] = 0L;
label_do[0] = 0L;
at_the_start = TRUE;
do
{
inside_sub = get_statement(statement,incf1,TRUE,TRUE, FALSE,
do_not_include, maxline, aux1);
/* print first line of routine if debug is on */
if((debug_on == TRUE) && (at_the_start == TRUE))
fprintf(stderr,"PAS 3\n%s\n\n",statement->s[0]);
if((inside_sub == FALSE) && (n_do_labels != 0))
{
fprintf(stderr,"Wrong nesting of DO loops at line %s !\n",
statement->m[0]);
exit(1);
}
at_the_start = FALSE;
/* keep here last label encountered. Also align labels */
if((new_label = extract_label(statement)) != 0)
{
last_label = new_label;
change_label_field(new_label, statement);
}
if( (do_type = isdo(&do_starts, &do_ends, &label_starts, &label_ends,
&do_label, statement)) != NOTDOLOOP)
{
/* if unlabeled DO's */
if((do_type == DOLOOPUNL) || (do_type == DOWHILEUNL))
{
if(do_type == DOLOOPUNL)
{
new_label = fetch_new_label(last_label, labels);
if(new_label == 0L)
{
fprintf(stderr,"Error allocating new label at line %s \n",
statement->m[0]);
exit(1);
}
n_do_labels++;
if(n_do_labels >= MAXDONEST)
{
fprintf(stderr,"To many nested loops at line %s !\n",
statement->m[0]);
exit(1);
}
do_labels[n_do_labels] = new_label; /* positive DO loop */
last_do_label = new_label;
start_column[n_do_labels] =
do_starts.cn > 60 ? 6 : do_starts.cn;
/* paste new label in */
sprintf(extr_string, "%ld ", new_label);
if(paste(statement, &label_starts, &label_ends, maxline,
extr_string) == FALSE)
{
fprintf(stderr,"Error when pasting in label at line %s \n",
statement->m[0]);
exit(1);
}
}
else /* if unlabeled DO WHILE loop */
{
new_label = extract_label(statement);
if(new_label == 0L) /* no label infront of DO WHILE */
{
new_label = fetch_new_label(last_label, labels);
change_label_field(new_label, statement);
}
n_do_labels++;
if(n_do_labels >= MAXDONEST)
{
fprintf(stderr,"To many nested loops at line %s !\n",
statement->m[0]);
exit(1);
}
do_labels[n_do_labels] = -new_label; /* negative DO WHILE */
last_do_label = new_label;
start_column[n_do_labels] =
do_starts.cn > 60 ? 6 : do_starts.cn;
/* convert DO WHILE to IF(...)THEN */
if(cut(statement, &do_starts, &do_ends, maxline, extr_string,
MAXEXTRLEN) != TRUE)
{
fprintf(stderr,
"Cannot cut DO WHILE out of statement at line %s \n",
statement->m[0]);
exit(1);
}
if(paste(statement, &do_starts, &do_ends,
maxline, "IF") != TRUE)
{
fprintf(stderr,
"Failed to replace DO WHILE with IF on line %s \n",
statement->m[0]);
exit(1);
}
/* append THEN to the end */
find_statement_end(statement, &start_pos);
if(paste(statement, &start_pos, &end_pos, maxline,
"THEN") != TRUE)
{
fprintf(stderr,
"Failed to append THEN after DO WHILE at line %s \n",
statement->m[do_starts.ln]);
exit(1);
}
}
} /* end if unlabeled DO or DO WHILE */
} /* end if isdo */
else /* if other statement than DO */
{
/* now check if ENDDO present */
start_pos.cn = 5;
start_pos.ln = 0;
if(find_string(statement, &start_pos, &end_pos, "ENDDO", &ch) == TRUE)
{
if(ch == EOF)
{
/* all labeled ENDDO's were replaced in PAS 1 */
cut(statement, &start_pos, &end_pos, maxline, extr_string,
MAXEXTRLEN);
if(do_labels[n_do_labels] > 0L) /* if unlabeled DO */
{
paste(statement, &start_pos, &end_pos, maxline, "CONTINUE");
change_label_field(last_do_label, statement);
}
else /* if DO WHILE terminal statement */
{
sprintf(extr_string,"GOTO %ld", last_do_label);
paste(statement, &start_pos, &end_pos, maxline, extr_string);
/* append ENDIF to the statement */
j = ++(statement->nc);
k = start_column[n_do_labels];
for (i = 0; i < k; i++)
statement->s[j][i] = ' ';
strcpy(extr_string,"END IF");
for (i = 0; i <= 6; i++)
statement->s[j][k++] = extr_string[i];
strcpy(statement->m[j], statement->m[0]);
}
/* get next loop label to be closed */
n_do_labels--;
if(n_do_labels < 0)
{
fprintf(stderr,
"Wrong nesting of unlabeled DO loopls at line %s !\n",
statement->m[0]);
exit(1);
}
last_do_label = do_labels[n_do_labels];
if(last_do_label < 0L) /* if its is a DOWHILE label */
last_do_label = -last_do_label;
} /* end if ch = EOF */
} /* end if ENDDO */
} /* end else not DO */
/* write statement to aux1 */
write_statement(statement, TRUE, aux1);
}
while (inside_sub == TRUE);
program_end = FALSE;
EOF_found = FALSE;
/* close files aux1 and aux2 and reopen aux1 for reading */
fclose(aux1);
fclose(aux2);
if( (aux1 = fopen(temp_name1, "r")) == NULL)
{
fprintf(stderr,"Temp file %s was deleted when this program ran !\n",
temp_name1);
exit(1);
}
/* this pass converts labeled DO WHILE loops to IF GOTO statements */
incf1->inf[0] = aux1;
incf1->n_lin[0] = 0L;
incf1->ni = 0;
strcpy(incf1->in[0], "AUX1 FILE");
/* loop until END statement found */
last_label = 1L;
last_do_label = 0L;
n_do_labels = 0;
do_labels[0] = 0L;
label_do[0] = 0L;
at_the_start = TRUE;
do
{
inside_sub = get_statement(statement,incf1,TRUE,list_line_marks, FALSE,
do_not_include, maxline, outf);
/* print first line of routine if debug is on */
if((debug_on == TRUE) && (at_the_start == TRUE))
fprintf(stderr,"PAS 4\n%s\n\n",statement->s[0]);
at_the_start = FALSE;
if((inside_sub == FALSE) && (n_do_labels != 0))
{
fprintf(stderr,"Wrong nesting of DO loops at line %s !\n",
statement->m[0]);
exit(1);
}
/* keep here last label encountered. */
if((new_label = extract_label(statement)) != 0)
last_label = new_label;
if(isdo(&do_starts, &do_ends, &label_starts, &label_ends,
&do_label, statement) == DOWHILELAB )
{
if(new_label == 0L)
{
new_label = fetch_new_label(last_label, labels);
if(new_label == 0L)
{
fprintf(stderr,"Error allocating new label at line %s \n",
statement->m[0]);
exit(1);
}
change_label_field(new_label, statement);
}
n_do_labels++;
if(n_do_labels >= MAXDONEST)
{
fprintf(stderr,"To many nested loops at line %s !\n",
statement->m[0]);
exit(1);
}
label_do[n_do_labels] = new_label; /* label in front of DOWHILE */
do_labels[n_do_labels] = do_label; /* label of teminal statement */
start_column[n_do_labels] =
do_starts.cn > 60 ? 6 : do_starts.cn;
last_do_label = do_label;
if(cut(statement, &do_starts, &do_ends, maxline, extr_string,
MAXEXTRLEN) != TRUE)
{
fprintf(stderr,
"Cannot cut the DO WHILE out of statement at line %s \n",
statement->m[0]);
exit(1);
}
if(paste(statement, &do_starts, &do_ends, maxline, "IF") != TRUE)
{
fprintf(stderr,
"Failed to replace DO WHILE with IF on line %s \n",
statement->m[0]);
exit(1);
}
/* Now append THEN to the end */
find_statement_end(statement, &start_pos);
if(paste(statement, &start_pos, &end_pos, maxline, "THEN") != TRUE)
{
fprintf(stderr,
"Failed to append THEN after DO WHILE at line %s \n",
statement->m[0]);
exit(1);
}
}
else if(new_label != 0L) /* if some statement with label */
{
if(new_label == last_do_label) /* terminal statement of DO WHILE */
{
if(statement->nc + 2 >= MAXCONT)
{
fprintf(stderr,"Too many continuation lines at %s \n",
statement->m[statement->nc]);
exit(1);
}
/* append GOTO and END IF statements */
k = start_column[n_do_labels];
for (i = 0; i < k; i++)
extr_string[i] = ' ';
extr_string[k] = '\0';
j = ++(statement->nc);
sprintf(statement->s[j],"%sGOTO %ld",
extr_string, label_do[n_do_labels]);
strcpy(statement->m[j],statement->m[statement->nc-1]);
j = ++(statement->nc);
sprintf(statement->s[j], "%sEND IF", extr_string);
strcpy(statement->m[statement->nc],statement->m[statement->nc-1]);
n_do_labels--;
if(n_do_labels < 0)
{
fprintf(stderr,
"Wrong nesting of unlabeled DO loopls at line %s !\n",
statement->m[0]);
exit(1);
}
last_do_label = do_labels[n_do_labels];
}
}
/* convert to lower or upper case if requested */
if((make_lower == TRUE) || (make_upper == TRUE))
{
pos.cn = 5;
pos.ln = 0;
while ((ch = skip_ov_string(TRUE, statement, &pos)) != EOF)
{
if(make_lower == TRUE)
{
if(isupper(ch) != 0)
statement->s[pos.ln][pos.cn] = (char)tolower(ch);
}
else
{
if(islower(ch) != 0)
statement->s[pos.ln][pos.cn] = (char)toupper(ch);
}
}
}
/* find if statement comes from INCLUDE file */
curr_line[0] = statement->m[0][0];
curr_line[1] = statement->m[0][1];
curr_line[2] = '\0';
k = atoi(curr_line); /* if k > 0 then statement from INCLUDE file */
/* write statement to outf */
if((do_not_include == FALSE) || (k == 0))
write_statement(statement, list_line_marks, outf);
}
while (inside_sub == TRUE);
/* close file aux1 */
fclose(aux1);
/* prepare labels for next routine */
labels->n_lab = 0;
labels->l[0] = 0L;
labels->l[1] = 200000L;
/* restore input file flags */
program_end = inp_program_end;
EOF_found = inp_EOF_found;
} /* end while program_end */
Close_files:
free(labels);
free(incf1);
free(incf);
free(data_statement);
free(statement);
/* close temp file */
fclose(aux1);
fclose(aux2);
fclose(inpf);
fclose(outf);
/* delete temp files */
if(debug_on == FALSE)
{
remove(temp_name1);
remove(temp_name2);
}
}
|
