/*=================================================================== 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); } }