**** OVERDRIVE - Fortran preprocessor ***** -STITL INITIALIZATIONS -TITLE OVERDRIVE PREPROCESSOR PROTOTYPE -SPACE 2 * *** KEYWORD SETTINGS *** -SPACE 2 -NOFAIL VER = '89.1' VERSION = CENTER('Overdrive version ' VER,70) &ANCHOR = 1 &TRIM = 1 &FULLSCAN = 1 &STLIMIT = 500000 &CODE = 12 *** changes *** * 89.1 add MacFortran COMPILER output option *** PROBLEMS *** * put some indication in listing of NOLIST op * list FIRST of ISNs when more than 1 * list FIRST of internal labels when more than one. * put ISN on comments in listing if ISN has changed from last * CHANGE MORE POPS TO POPCS. * IN MULTIPLE SUBPROGRAM PROCESSION, AN ERROR IN THE FIRST * ISN'T HANDLED WELL? *** ENHANCEMENTS *** * GENERATE DECLARATIONS FOR LOGICAL EXIT VARIABLES * FLAG GOTO'S * RECOGNIZE PROC INVOCATIONS WITHOUT UNDERSCORES. * ADD RECURSION TO PROCS * ALLOW PARAMETERS OF PROCS DEFINED BEFORE CALL -SPACE 2 * *** DATA TYPE DEFINITIONS *** -SPACE 2 DATA('E(TY,L1,L2,MISC1,MISC2,MISC3,BEG)') DATA('PSTATUS(PRCNAME,PLABEL,RETVAR,RETLABELS,EPILABE,PPARAM,CALLEDBY,CALLSON,DEFAT)') DATA('NODE(CLASS,TYP,VAL,MINSIZTHIS,MINSIZEREM,NEXT)') -STITL INITIAL STRING AND PATTERN DEFINITIONS INITIAL BDUPL = ARRAY('0:132') B132 = DUPL(' ',132) BDUPL<0> = NULL I = 1 LOOP WHILE LE(I,132) BDUPL = SUBSTR(B132,1,I) I = I + 1 ENDLOOP B12 = BDUPL<12> B70 = BDUPL<70> *** PATTERNS *** Q = "'" &ALPHABET BREAK("'") . P1 LEN(1) REM . P2 NONQ = P1 P2 B = SPAN(' ') OPTB = (B | '') -SPACE 2 MAXQBAL = ARBNO(SPAN(NONQ) | "'" BREAK("'") "'") QBAL = ARBNO(NOTANY("'") | "'" BREAK("'") "'") NONQ BREAK('(') . P1 LEN(1) REM . P2 (P1 P2) BREAK(')') . P1 LEN(1) REM . P2 NONQP = P1 P2 MAXQPBAL = ARBNO(SPAN(NONQP) | '(' *MAXQPBAL ')' | "'" BREAK("'") "'") QPBAL = ARBNO('(' *QPBAL ')' | "'" BREAK("'") "'" | NOTANY("'()")) QSTRING = ("'" BREAK("'") LEN(1) (*QSTRING | NULL)) ALPHA = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ$' NUM = '0123456789' BREAKERS = '+-*/.(),=: ' RE = RPOS(0) XXX = (FENCE $ XX) VARIABLE = (ANY(ALPHA) (SPAN(ALPHA NUM) | '')) NUMBER = SPAN(NUM) VARNUMPAT = (VARIABLE | NUMBER) RPOS(0) SKIP_TO_SEMI1 = Q BREAK(Q) Q | NOTANY(Q) BREAK("';") SKIP_TO_SEMI = BREAK("';") ARBNO(SKIP_TO_SEMI1) * * ///////////// PATTERNS TO MATCH CONSTANTS /////////////////////// * OPTN = ((NUMBER | NULL) . N) CHARCON = "'" BREAK("'") LEN(1) (*CHARCON | NULL) SIGN = ('-' | NULL) EXPONENT = ('E' | 'D') ('+' | '-' | '') NUMBER INTCON = SIGN NUMBER LOGCON = '.TRUE.' | '.FALSE.' REALCON = SIGN ((NUMBER '.' (NUMBER | NULL) | + (NUMBER | NULL) '.' NUMBER) (EXPONENT | NULL) | + NUMBER EXPONENT) CMPLXCON = '(' REALCON ',' REALCON ')' CONPAT = REALCON | CHARCON | LOGCON | INTCON | CMPLXCON * * * EDURE = ('EDURE' | '') FNAME = SPAN(ALPHA NUM) . PROCNAME PNAME = (((ANY(ALPHA) (SPAN(ALPHA NUM '_') | '')) . PROCNAME) + ('(' MAXQPBAL . ACTPAR ')' | NULL . ACTPAR)) + OPTB (',' OPTB | RE) *** PATTERN TO DETECT LOGICAL EXPRESSIONS THAT FORTRAN H *** IS UNABLE TO COMPILE EFFICIENTLY. Used by PUTIF DOTOP = ARBNO(BREAK(".'") ("'" BREAK("'") "'" *DOTOP | '.')) BADIF = DOTOP ('NOT.' OPTB '(' | 'AND.' | 'OR.') **** PATTERN USED TO MATCH INTERNAL PROCEDURE CALL *** CALLPAT = (( 'INVOKE' B PNAME + | (ANY(ALPHA) (SPAN(ALPHA NUM) | '') '_' + SPAN(ALPHA NUM '_')) . PROCNAME ) + ('(' MAXQPBAL . ACTPAR ')' | NULL . ACTPAR) XXX RE) OPND = ('(' MAXQPBAL . LEXP ')') GOTOPAT = ('GO' OPTB 'TO' | 'RETURN' | 'STOP') + (SPAN(' 0123456789') | NULL) RE EXITLOOPPAT = 'EXIT' OPTB 'LOOP' XXX NEXTLOOPPAT = 'NEXT' OPTB 'LOOP' XXX EXITPROCPAT = 'EXIT' OPTB 'PROC' EDURE XXX RE IOPAT = (('READ' | 'WRITE') OPTB '(' BAL ',' OPTB) . P1 + ('(' BAL ')' | 'FMT' OPTB '=' OPTB QSTRING | NULL) . FMT + (OPTB ANY(',)') REM) . P2 TXTPAT = (OPTB "'" BREAKX("'") . TEXT "'" OPTB RE) *** PATTERNS USED IN PARSING THE LOOP STATEMENT *** BPOPND = OPTB '(' QPBAL . X ')' IFPAT = 'IF' OPTB FENCE OPND + ((OPTB 'THEN' | NULL) RE *TYPE('IF') + | (OPTB NOTANY(' =') REM) . IFOBJ *TYPE('FTNIF')) * THE THEN VAR IS UNUSED NOW BUT MAY BE USED FOR STD CHECKING ELSEPAT = ('ELSE' OPTB + ( RE *TYPE('ELSE') + | 'IF' XXX OPTB OPND (OPTB 'THEN' | NULL) RE + *TYPE('ELSEIF') + | 'CASE' XXX RE *TYPE('ELSECASE'))) ENDPAT = ('END' OPTB + ( RE *TYPE('ENDPGM') + | 'CASE' XXX RE *TYPE('ENDCASE') + | 'IF' RE *TYPE('ENDIF') + | 'LOOP' XXX *TYPE('ENDLOOP') + | 'PROC' EDURE XXX RE *TYPE('ENDPROC') + | 'INDENT' XXX RE *TYPE('ENDINDENT'))) DOPAT = 'DO' OPTB 'CASE' OPTB XXX OPND RE *TYPE('DOCASE') SUBPGMPAT = (('SUBROUTINE' | + ((('INTEGER' | 'LOGICAL' | 'REAL' | 'CHARACTER' | + 'EXTERNAL' | 'ENTRY' | + 'DIMENSION' | 'COMMON' | 'DATA') FENCE *TYPE('DCL') + ('*' NUMBER | NULL)) | NULL) OPTB 'FUNCTION') OPTB FNAME) + *TYPE('SUBPGM') LISTOPTPAT = ('ON' | 'OFF' | 'PUSHON' | 'PUSHOFF' | 'POP') LISTPAT = ('*' *TYPE('STARCOM') + | 'OPTION' B (NOTANY(ALPHA) ABORT | NULL) REM . OPTVAL *TYPE('OPTION') + | 'EJECT' OPTB (NOTANY(NUM) ABORT | OPTN RE) *TYPE('EJECT') + | 'INDENT' RE *TYPE('INDENT') + | 'LIST' B LISTOPTPAT . X RE *TYPE('LIST') + | 'SPACE' OPTB (NOTANY(NUM) ABORT | OPTN RE) *TYPE('SPACE') + | 'SUBTITLE' XXX TXTPAT *TYPE('SUBTITLE') + | 'TITLE' TXTPAT *TYPE('TITLE')) STMPAT1 = + ( IFPAT + | ELSEPAT + | 'CASE' OPTB OPND RE *TYPE('CASE') + | 'LOOP' (B | RE) *TYPE('LOOP') + | DOPAT + | ENDPAT + | EXITLOOPPAT *TYPE('EXITLOOP') + | NEXTLOOPPAT *TYPE('NEXTLOOP') + | CALLPAT *TYPE('INVOKE') + | GOTOPAT *TYPE('GOTO') + | LISTPAT + | 'PARAMETER' *TYPE('PARAMETER') + | 'PROC' EDURE B PNAME RE *TYPE('PROC') + | EXITPROCPAT *TYPE('EXITPROC') + | SUBPGMPAT + | 'FORMAT' *TYPE('FORMAT') + | 'DEBUG' RE *TYPE('DEBUGGER') + | IOPAT *TYPE('IOFMT')) STMPAT = STMPAT1 REM . BACK ENDINITIAL -STITL OTHER INITIALIZATIONS * *** OTHER INITIALIZATIONS *** STACKTRACE = 'NO' EOF = 'NO' ERRORS = ARRAY(50) ERRNO = 0 WARNING = ARRAY(50) WARNNO = 0 SOURCE = ARRAY(21) SOURCELN = ARRAY(21) SOURCEOLN = ARRAY(21) *** SET UP A STACK FOR THE LISTING ON/OFF STATUS LISTSTK = ARRAY(10) *** THE CONTNT ARRAY CONTAINS A TABLE OF CONTENTS WHICH IS BUILT UP *** OF TITLES, SUBTITLES, AND PROCEDURE NAMES. IT IS PRINTED AT THE *** END OF THE LISTING IF THE 'CONTENTS' OPTION IS ACTIVE. *** THE VARIABLE 'NXTCON' POINTS TO THE FIRST UNUSED ELEMENT IN THE *** CONTNT ARRAY. CONTNT = ARRAY(200) *** THE 'STACK' ARRAY CONTAINS THE STACK FOR ALL OVERDRIVE STRUCTURE STACK = ARRAY(50) *** INITIALIZE SETTABLE PARAMETERS *** FRED = 'NO' * NOT BEING RUN FOR INTERNAL DEBUGGING * BLDCON = 'ON' * COPYCOM = 'NO' * DO NOT COPY COMMENTS TO TARGET MODULE * FLAGGOTO = 'NO' * Don't flag GOTO's * XREF = 'YES' * DO GENERATE A CROSS-REFERENCE * LISTING = 'YES' * DO GENERATE A LISTING * COMPUTE_INDENT('. ') * SET THE INDENT AMOUNT TO '. ' * DOINDT = 'YES' * DO INDENTATION * * LABELTYPE = 'LINE' LNUM = 99999 VNUM = 99999 LPFX = '9' * GENERATED LABELS COUNT DOWN FROM START * LDECL = 'NO' * DON'T GEN LOGICAL DECLS FOR EXIT VARIABLES COMPILER = 'FTNG' * DEFAULT TO FTNG ISN COUNTING/code generation. * Other values: FTNH and MACFORTRAN PARDECL = 'NO' * Don't generate declarations for variables in * PARAMETER statements. If 'YES' generate both * the proper type declaration, and a DATA statement * to initialize each variable. VERYFIRST = 'YES' LOAD('SYSPAR()STRING') LOAD('SYSTOD()STRING') LOAD('SCREPLY()', 'UNSP:SPITLIB') LOAD('SSNOOP(STRING,STRING)', 'UNSP:SPITLIB') * * SSNOOP is used to record information on the use of * OVERDRIVE. It can be deleted. LOAD('SREAD(STRING,INTEGER,INTEGER)STRING', 'UNSP:SPITLIB') LOAD('SWRITE(STRING,STRING,INTEGER,INTEGER)INTEGER','UNSP:SPITLIB') * S1 = UNIT * S2 = STRING TO BE WRITTEN * I1 = INTEGER MTS LINE NUMBER * I2 = I/O MODIFIER BITS * S3 = RETURNED NULL STRING OUTPUT(.PRINTER,'SPRINT') OUTPUT(.SERCOM,'SERCOM') *** process options *** PARFIELD = SYSPAR() OPTPROC(PARFIELD) *** Collect some statistics on OVERDRIVE usage. *** SSNOOP('W008:OVERSTATS(*L+1) ','VER=' VER ',PAR=' PARFIELD) -STITL INITIALIZATION FOR EACH PROGRAM NEXTPGM TODAY = DATE() ' ' SYSTOD() NXTCON = 1 PTABLE = TABLE(50) LEVEL = 0 DCLIST = TABLE() IF IDENT(COMPILER,'FTNH') *** COUNT ISN'S AS DOES FORTRAN H *** ISN = 1 ELSE *** COUNT LIKE FORTRAN G AND OTHERS(?) *** ISN = 0 ENDIF INITTITLE = CENTER('MAIN',70) TITLETEXT = INITTITLE SUBTITLETEXT = '' FOOTERTEXT = '' LPP = 58 LASTFMT = '' LASTFMTISN = 0 SUBPGMNAME = 'MAIN' NEWHEADER = 'YES' LINENO = 12345 FIRSTL = 0 PAGENO = 1 NEWHEADER = 'YES' PSTCOM = 'NO' PARAMS = 'NO' LISTPTR = 0 * LISTING ON/OFF STACK POINTER PARTABLE = TABLE(25) PARSCANPAT1 = FAIL GOTOPRECEDES = 'NO' SOURCELABEL = ' ' MAXLABEL = 0 * MAX LABEL GENERATED SO FAR IF LABEL=LINE INTLABELS = NULL * LIST OF GENERATED LABELS TO PRINT -STITL THE MAIN INPUT LOOP NEXTI IF NOT STMT = GETSTMT() ERR('MISSING END STATEMENT') FSTMT = ' END' :(ENDPGM) ENDIF LISTLEVEL = LEVEL STMT ANY('C*$') :S(COMMENT) IF STMT SPAN(' ') ('*' *TYPE('STARCOM') + | RPOS(0) *TYPE('BCOM') + | ';*' *TYPE('SEMICOM')) :($STMTYPE) ENDIF STMTYPE = 'FORTRAN' *** LOOK FOR AND REPLACE PARAMETERS *** PARFND = 'NO' IF IDENT(PARAMS,'YES') *** DO PARAMETER REPLACEMENT *** LOOP WHILE STMT PARSCANPAT = PAR1 PARTABLE PAR2 PARFND = 'YES' ENDLOOP ENDIF -STITL LOOK FOR AN OVERDRIVE STATEMENT IF STMT LEN(5) . SOURCELABEL SPAN(' ') . FRONT REM . FSTMT *** IT LOOKS LIKE IT'S A STATEMENT *** XX = 'NO ERRORS' IF FSTMT STMPAT *** ITS AN OVERDRIVE STATEMENT *** IDENT(STMTYPE,'') :S(ERRMAIN1) IF DIFFER(SOURCELABEL,' ') IF SOURCELABEL ARB SPAN('0123456789') . LABEL PUTLABEL(LABEL) ELSE ERR('BAD CHARS "' SOURCELABEL '" IN LABEL FIELD') ENDIF ENDIF ELSE *** THIS IS NOT AN OVERDRIVE STATEMENT - THERE ARE *** TWO POSSIBILITIES. (1) IT REALLY ISN'T AN OVERDRIVE *** STATEMENT AND SHOULD BE TREATED AS A FORTRAN STMT OR *** (2) IT IS AN OVERDRIVE STATEMENT WHICH FAILED TO *** BE PROPERLY MATCHED BECAUSE OF SOME SYNTACTICAL *** ERROR. IT IS SOMETIMES POSSIBLE TO RECOGNIZE THIS *** SECOND CASE BY THE VALUE OF THE VARIABLE 'XX'. *** INITIALLY 'XX' IS SET TO A NON-NULL VALUE BUT MAY BE *** ALTERED TO A NULL VALUE IN CERTAIN CIRCUMSTANCES *** WHEN IT IS THOUGHT THAT THIS SHOULD HAVE BEEN AN *** OVERDRIVE STATEMENT. IF IDENT(XX,NULL) *** THIS IS AN ERRONEOUS STATEMENT *** IF STMT BAL RPOS(0) *** IT'S PAREN BALANCED - ERROR IS ELSEWHERE *** ERR('ERRONEOUS OVERDRIVE STATEMENT') ELSE *** THE PARENS ARE THE PROBLEM *** ERR('UNBALANCED PARENTHESES') ENDIF ENDIF ENDIF ELSE ERR('Illegal Statement') :(NEXT) ENDIF :($STMTYPE) -SPACE NEXT LISTLINE() :(NEXTI) ERRMAIN1 ERR('STMPAT MATCH BUT NULL STMTYPE') :(FORTRAN) -STITL END OF PROGRAM PROCESSING ENDPGM PARRAY = NULL IF PARRAY = CONVERT(PTABLE,'ARRAY') LOOP FOR I = 1 WHILE PSTATE = PARRAY *** THE EPILABE FIELD HAS ONE OF THE FOLLOWING *** THREE VALUES *** 1. THE LABEL TO GENERATE ON THE PROC EPILOGUE *** 2. NULL - PROC WAS INVOKED BUT NOT DEFINED. *** 3. 'UNUSED' - EPILOGUE IS UNNECESSARY (E.G., *** THE PROC TERMINATED WITH A GOTO. IF DIFFER(EPILABE(PSTATE),'') IF DIFFER(EPILABE(PSTATE),'UNUSED') *** PUT OUT THE PROC EPILOGUES BEFORE THE END *** PUTLABEL(EPILABE(PSTATE)) RL = RETLABELS(PSTATE) IF DIFFER(RL,'') PUTSTMT('GO TO ' RETVAR(PSTATE) ',(' + SUBSTR(RL,1,SIZE(RL) - 1) ')') ELSE ERR('PROC "' PRCNAME(PSTATE) '" WAS DEFINED,' + ' BUT NEVER INVOKED.',0) ENDIF ENDIF ELSE ERR('PROC "' PRCNAME(PSTATE) '" WAS INVOKED,' + ' BUT NEVER DEFINED.') PUTLABEL(PLABEL(PSTATE)) PUTSTMT('GOTO ' RETVAR(PSTATE) ',(' + SUBSTR(RETLABELS(PSTATE),1, + SIZE(RETLABELS(PSTATE)) - 1) ')') ENDIF ENDLOOP ENDIF DUMPLABEL() PUTSTMT(FSTMT) LISTLINE() IF NE(LEVEL,0) FLUSH() ENDIF IF IDENT(LISTING,'YES') *** PUT OUT A FOOTER ON THE LAST PAGE *** PRINTER = '< ' SUBPGMNAME + ' PAGE ' PAGENO - 1 ' ' SUBTITLETEXT IF IDENT(BLDCON,'ON') *** PRINT OUT THE TABLE OF CONTENTS *** *** BUT ONLY IF THERE ARE MORE THAN 3 ENTRIES AND *** THE LISTING IS ALREADY AT LEAST 4 PAGES LONG. IF GT(NXTCON,2) IF GT(PAGENO,3) *** OK - PRINT IT *** PRINTER = '1TABLE OF CONTENTS FOR ' SUBPGMNAME PRINTER = '0LINE NUMBER TITLE/SUBTITLE' PRINTER = ' ' I = 1 LOOP WHILE LT(I,NXTCON) PRINTER = CONTNT I = I + 1 ENDLOOP ENDIF ENDIF ENDIF *** PUT OUT A PROCEDURE XREF *** IF IDENT(XREF,'YES') IF DIFFER(PARRAY,NULL) PRINTER = '2PROCEDURE XREF FOR ' SUBPGMNAME PRINTER = '0NAME(DEFINITION) REFERENCES' PRINTER = ' ' HSORT(PARRAY) LOOP FOR I = 1 WHILE PSTATE = PARRAY PNAME = PARRAY '(' DEFAT(PSTATE) ')' PNAME = RPAD(PNAME,20) TEMP = CALLEDBY(PSTATE) IF TEMP ',' = ENDIF REFLINE = PNAME 'CALLED BY:' TEMP REFFIX = ' ' LOOP WHILE REFLINE (LEN(100) BREAK(',') ',') . R = PRINTER = REFFIX R REFFIX = ' ' ENDLOOP IF DIFFER(REFLINE,NULL) PRINTER = REFFIX REFLINE ENDIF TEMP = CALLSON(PSTATE) IF TEMP BREAKX(',') . TEMP ',' RPOS(0) ENDIF REFLINE = ' CALLS ON :' TEMP REFFIX = ' ' LOOP WHILE REFLINE (LEN(100) BREAK(',') ',') . R = PRINTER = REFFIX R REFFIX = ' ' ENDLOOP IF DIFFER(REFLINE,NULL) PRINTER = REFFIX REFLINE ENDIF ENDLOOP ENDIF ENDIF ENDIF *** WARNING MESSAGES *** IF GT(WARNNO,0) PRINTER = ' ' PRINTER = ' WARNING MESSAGES ' PRINTER = ' ' I = 1 LOOP WHILE LE(I,WARNNO) PRINTER = ' **** WARNING AT LINE ' WARNING IF SCREPLY() SERCOM = ' **** WARNING AT LINE ' WARNING ENDIF I = I + 1 ENDLOOP WARNNO = 0 ENDIF *** PRODUCE ERROR SUMMARY ON PRINTER *** IF GT(ERRNO,0) PRINTER = ' ' PRINTER = ' ERROR MESSAGES ' PRINTER = ' ' I = 1 LOOP WHILE LE(I,ERRNO) PRINTER = ' **** ERROR AT LINE ' ERRORS IF SCREPLY() SERCOM = ' **** ERROR AT LINE ' ERRORS ENDIF I = I + 1 ENDLOOP ERRNO = 0 ENDIF IDENT(EOF,'NO') :S(NEXTPGM) IF EQ(&CODE,12) *** ASSUME NO ERRORS IF UNCHANGED FROM 12 *** &CODE = 0 ENDIF :(END) -STITL REGULAR FORTRAN STATEMENTS *** REGULAR FORTRAN STATEMENTS *** FORTRAN *** REGULAR FORTRAN STATEMENTS *** PUTFSTMT() :(NEXT) *** FORTRAN DECLARATIONS - THESE ARE PROCESSED SEPARATELY SO THAT *** LABELS ARE NEVER GENERATED ON THEM DCL DUMPLABEL() :(FORTRAN) *** COMMENTS AND MTS COMMANDS ARE PROCESSED HERE. *** COMMENT IF STMT '$' *** MTS COMMAND *** LISTCOM(STMT) IF GE(SIZE(STMT),72) LOOP WHILE STMT LEN(72) . CONTINU = PUTLINE(CONTINU '-') ENDLOOP IF IDENT(STMT,'') PUTLINE(' ') ENDIF ELSE IF STMT '$' ('continue with ' | 'CONTINUE WITH ') BREAK(' ') . FILENAME IF IDENT(COMPILER, 'MACFORTRAN') PUTLINE('include ' FILENAME) ELSE PUTLINE(STMT) ENDIF ELSE PUTLINE(STMT) ENDIF ENDIF ELSEIF STMT 'C' *** C-TYPE FORTRAN COMMENT *** LISTCOM(STMT) IF IDENT(COPYCOM,'YES') COMMENT2 IF GT(SIZE(STMT),72) STMT LEN(72) . CONTINU = PUTLINE(CONTINU) LOOP WHILE STMT LEN(71) . CONTINU = PUTLINE('C' CONTINU) ENDLOOP PUTLINE('C' STMT) ELSE PUTLINE(STMT) ENDIF ENDIF ELSEIF STMT '*' *** *-TYPE FORTRAN COMMENTS *** LISTCOM(STMT) *** ????? SHOULD PROBABLY INSURE FEWER THAN 72 CHAR AS ABOV OCOM2 IF IDENT(COPYCOM,'YES') IF IDENT(COMPILER, 'MACFORTRAN') PUTLINE(STMT) ELSE STMT LEN(1) = 'C' :(COMMENT2) ENDIF ENDIF ENDIF :(NEXTI) *** Blank line *** BCOM IF GT(LINENO,LPP) *** list blank lines anywhere expect at top of page *** LISTLINE() ENDIF IF IDENT(COPYCOM,'YES') IF IDENT(COMPILER, 'MACFORTRAN') PUTLINE(' ') ELSE PUTLINE('C') ENDIF ENDIF :(NEXTI) *** Overdrive comment beginning with ';*' *** SEMICOM STMT ARB . X ';' = ' ' X *** fall through *** *** Overdrive comment beginning with '*' *** STARCOM LISTLINE() IF IDENT(COPYCOM,'YES') IF IDENT(COMPILER, 'MACFORTRAN') STMT ARB . X '*' = X '!' PUTLINE(STMT) ELSE STMT LEN(1) = 'C' :(COMMENT2) ENDIF ENDIF :(NEXTI) *** DEBUGGING STATEMENT 'DEBUG' USES SPITDEBUG *** DEBUGGER DEBUG('OVERDRIVE DEBUG COMMAND') :(NEXTI) -STITL FORTRAN IF STATEMENT * This section handles FORTRAN IF statements. * the possible actions are as follows: * * 1. Arithmetic IF * This is passed on without any special action. * * 2. Logical IF, object statement is FORTRAN * The ISN is counted differently for FTN G and H. * * 3. Logical IF, object statement is OVERDRIVE * A branch is generated around whatever code * the OVERDRIVE statement generates. * The only allowable OVERDRIVE statements are: * EXITLOOP * EXITPROC * INVOKE * NEXTLOOP * READ & WRITE * INITIAL ARITHIFPAT = OPTB NUMBER ',' AFTERIFPAT = (OPTB (CALLPAT *TYPE('IFINVOKE') + | NEXTLOOPPAT *TYPE('IFNEXTLOOP') + | EXITLOOPPAT *TYPE('IFEXITLOOP') + | EXITPROCPAT *TYPE('IFEXITPROC') + | IOPAT *TYPE('IFIO'))) + REM . BACK ENDINITIAL FTNIF IF IFOBJ ARITHIFPAT *** This is an arithmetic IF, ignore it *** IF DIFFER(SOURCELABEL,' ') ERASELABEL() ENDIF :(FORTRAN) ELSEIF IFOBJ AFTERIFPAT *** This logical IF has an OVERDRIVE object *** IF IDENT(COMPILER, 'MACFORTRAN') DO CASE (STMTYPE) CASE ('IFNEXTLOOP') PUTSTMT('IF (' LEXP ') CYCLE') CASE ('IFEXITLOOP') PUTSTMT('IF (' LEXP ') THEN') GENEXITLOOP() CASE ('IFEXITPROC') PUTSTMT('IF (' LEXP ') THEN') GENEXITPROC() PUTSTMT('END IF') CASE ('IFINVOKE') PUTSTMT('IF (' LEXP ') THEN') GENINVOKE(PROCNAME,ACTPAR,FILELINE) PUTSTMT('END IF') CASE ('IFIO') PUTSTMT('IF (' LEXP ') THEN') GENIOFMT(P1,FMT,P2) PUTSTMT('END IF') ELSECASE ERR("IF STATEMENT PROBLEM:" IFOBJ) ENDCASE PUTLABEL(IFLL) ELSE IFLL = GENLABEL() PUTIF(LNOT(LEXP),'GOTO ' IFLL) DO CASE (STMTYPE) CASE ('IFNEXTLOOP') PUTSTMT(GENNEXTLOOP()) CASE ('IFEXITLOOP') GENEXITLOOP() CASE ('IFEXITPROC') GENEXITPROC() CASE ('IFINVOKE') GENINVOKE(PROCNAME,ACTPAR,FILELINE) CASE ('IFIO') GENIOFMT(P1,FMT,P2) ELSECASE ERR("IF STATEMENT PROBLEM:" IFOBJ) ENDCASE PUTLABEL(IFLL) ENDIF ELSE *** must be a FORTRAN statement as object *** IF LEXP BADIF AND DIFFER(COMPILER,'MACFORTRAN') *** The expression is too complicated for Fortran H, help it. PUTIF(LEXP,IFOBJ) ELSE IF DIFFER(SOURCELABEL,' ') ERASELABEL() ENDIF PUTFSTMT() IF IDENT(COMPILER,'FTNH') ISN = ISN + 1 ENDIF ENDIF :(NEXT) ENDIF :(NEXT) SUBTITLE 'IF / ELSEIF / ELSE / ENDIF' * The IF push element contains the following possible * field values. * * TY = 'IF' * L1 = LABEL OF NEXT ELSEIF ELSE OR ENDIF * L2 = NULL * TY = 'ELSEIF' * L1 = LABEL OF NEXT ELSEIF ELSE OR ENDIF * L2 = LABEL OF ENDIF * TY = 'ELSE' * L1 = LABEL OF ENDIF * L2 = NULL * IF IF IDENT(COMPILER, 'MACFORTRAN') PUTSTMT('IF (' LEXP ') THEN') ELSE L = GENLABEL() PUTIF(LNOT(LEXP),'GO TO ' L) ENDIF LISTLEVEL = LEVEL PUSH(E('IF',L,,,,,FILELINE)) :(NEXT) ELSEIF IF DIFFER(SOURCELABEL,' ') ERR('LABELS ARE ILLEGAL ON ELSEIF STMTS') ENDIF IF NOT TOP = POP() ERR('ELSEIF OUTSIDE OF IF STRUCTURE') :(FORTRAN) ENDIF IF NOT TY(TOP) 'IF' | 'ELSEIF' ERR('ELSEIF MUST HAVE PRECEDING IF OR ELSEIF') :(RESTACK) ENDIF IF IDENT(COMPILER, 'MACFORTRAN') PUTSTMT('ELSE IF (' LEXP ') THEN') ELSE IF DIFFER(GOTOPRECEDES,'YES') *** GEN GOTO TO ENDIF IF NO PRECEDING GOTO *** IF IDENT(L2(TOP),NULL) *** GENERATE LABEL FOR ENDIF IF DON'T ALREADY HAVE ONE L2(TOP) = GENLABEL() ENDIF PUTSTMT('GO TO ' L2(TOP)) ENDIF PUTLABEL(L1(TOP)) LA = GENLABEL() PUTIF(LNOT(LEXP),'GO TO ' LA) ENDIF LISTLEVEL = LEVEL PUSH(E('ELSEIF',LA,L2(TOP),,,,BEG(TOP))) :(NEXT) ELSE IF DIFFER(SOURCELABEL,' ') ERR('ELSE MUST NOT BE LABELLED') :(FORTRAN) ENDIF IF NOT TOP = POP() ERR('ELSE OUTSIDE OF AN IF STRUCTURE') :(FORTRAN) ENDIF IF IDENT(COMPILER, 'MACFORTRAN') PUTSTMT('ELSE') ELSE IF IDENT(GOTOPRECEDES,'YES') *** PRECEDED BY A GOTO - DON'T GEN ANOTHER *** L = L2(TOP) ELSE *** NO PRECEDING GOTO - PUT IN A GOTO TO ENDIF *** IF IDENT(TY(TOP),'IF') *** PRECEDED BY IF *** L = GENLABEL() ELSEIF IDENT(TY(TOP),'ELSEIF') *** PRECEDED BY ELSEIF *** IF IDENT(L2(TOP),NULL) *** NO LABEL WAS GENERATED BY THE ELSEIF. THIS *** THIS COULD HAPPEN IF A GOTO PRECEDED EVERY ELSEIF. L = GENLABEL() ELSE *** THE NORMAL CASE, WE HAVE A LABEL L = L2(TOP) ENDIF ELSE ERR('ELSE must be preceded by IF or ELSEIF') :(RESTACK) ENDIF PUTSTMT('GO TO ' L) ENDIF PUTLABEL(L1(TOP)) ENDIF LISTLEVEL = LEVEL PUSH(E('ELSE',L,,,,,BEG(TOP))) :(NEXT) ENDIF IF NOT TOP = POP() ERR('ENDIF OUTSIDE OF IF STRUCTURE') :(FORTRAN) ENDIF IF TY(TOP) 'IF' | 'ELSE' RPOS(0) | 'ELSEIF' *** PRECEDED BY IF OR ELSE OR ELSEIF *** IF IDENT(COMPILER, 'MACFORTRAN') PUTSTMT('END IF') ELSE PUTLABEL(L1(TOP)) IF DIFFER(L2(TOP),NULL) *** PUT OUT SECOND LABEL IF NECESSARY *** PUTLABEL(L2(TOP)) ENDIF ENDIF ELSE *** ERROR *** ERR('ENDIF MUST BE PRECEDED BY IF, ELSEIF OR ELSE') :(RESTACK) ENDIF LISTLEVEL = LEVEL :(NEXT) -STITL LOOP * THE LOOP STATEMENT HAS THE FOLLOWING FORM: * * 'LOOP' FOLLOWED BY ANY NUMBER OF THE FOLLOWING CLAUSES * 'WHILE' (LOGICAL EXPRESSION) * 'UNTIL' (LOGICAL EXPRESSION) * 'FOR' (ITERATION) * 'EXIT' (LOOP IDENTIFIER LIST) * NOTHING * * 'ENDLOOP' * NOTHING * 'REPEAT WHILE' (LOGICAL EXPRESSION) * 'REPEAT UNTIL' (LOGICAL EXPRESSION) * * AND MAY INCLUDE THE FOLLOWING: * EXITLOOP (OPTIONAL LOOP IDENTIFIER) * NEXTLOOP (OPTIONAL LOOP IDENTIFIER) * */////////////////////////////////////////////////////////////////// * * THE STACK ELEMENT FOR A LOOP HAS THE FOLLOWING FIELDS * TY = 'LOOP' * L1 = LABEL AT FRONT OF LOOP * L2 = LABEL AT END OF LOOP * MISC1 = EXITS, IF ANY * MISC2 = NEXTLOOP LABEL AT ENDLOOP, IF REQUIRED. * */////////////////////////////////////////////////////////////////// INITIAL FORPAT = 'FOR' BPOPND EXITPAT = 'EXIT' BPOPND WHILEPAT = 'WHILE' BPOPND UNTILPAT = 'UNTIL' BPOPND ITERPAT = BREAK('=') . ITVAR '=' BAL . X1 + (',' (NULL | BAL) . X2 | NULL . X2) + (',' BAL . X3 | '' . X3) RE CONSTEST = OPTB ('-' | NULL) . SIGN NUMBER OPTB RPOS(0) ARBEXITPAT = ARB . F EXITPAT ARBFORPAT = ARB . F FORPAT ARBWHILEPAT = ARB . F WHILEPAT ARBUNTILPAT = ARB . F UNTILPAT ENDINITIAL LOOP BACK OPTB ('FOR' | 'WHILE' | 'EXIT' | 'UNTIL' | RE) :F(FORTRAN) LTOP = GENLABEL() LBOT = GENLABEL() *** EXIT CLAUSE *** IF BACK ARBEXITPAT = F *** PROCESS EXIT LIST *** EXITS = TABLE() LOOP WHILE X OPTB (VARIABLE | CHARCON) . V OPTB (',' | RPOS(0)) = EXITS = 'YES' IF NOT V "'" *** If this is a variable, then initialize, maybe dcl IF IDENT(LDECL,'YES') *** WE SHOULD DECLARE THIS IF IT HASN'T BEEN ALREADY IF IDENT(DCLIST,NULL) *** FIRST TIME AS AN EXIT VARIABLE, DECLARE IT DUMPLABEL() PUTSTMT('LOGICAL ' V) DCLIST = 'YES' ENDIF ENDIF PUTSTMT(V ' = .FALSE.') ENDIF ENDLOOP IF DIFFER(X,NULL) ERR('EXIT CLAUSE ON LOOP INCORRECT') ENDIF ELSE EXITS = NULL ENDIF IF BACK ARBFORPAT = F IF X ITERPAT *** GENERATE FOR ITERATION CODE *** *** FOR COMPATIBILITY WITH FORTRAN77 THE EQUIVALENT LOOP *** (1) ITERATION VARIABLE WILL BE DEFINED ON EXIT *** (2) CHANGES TO THE VARIABLES IN THE FINAL VALUE OR *** INCREMENT WILL NOT AFFECT THE LOOP'S OPERATION. *** HOWEVER, TRANSFERS INTO THE LOOP AND CHANGES TO THE *** ITERATION VARIABLE WILL NOT BE DETECTED. *** PROCESS THE FINAL VALUE AND ITS ASSIGNMENT *** IF DIFFER(X2,NULL) *** THERE MAY BE NO FINAL VALUE *** IF NOT X2 CONSTEST *** IF THE FINAL VALUE IS NOT AN INTEGER, ASSIGN TO A *** CREATED VARIABLE SO IT WILL NOT BE AFFECTED BY *** CHANGES WITHIN THE LOOP. I2 = GENVAR() PUTSTMT(I2 '=' X2) X2 = I2 ENDIF ENDIF *** PROCESS INITIAL VALUE AND ITS ASSIGNMENT *** *** This must come after the final value assignment in *** case the iteration variable is referenced in the *** final value. IF DIFFER(ITVAR,X1) *** IF THE ITERATION VARIABLE IS THE SAME AS THE *** INITIAL VALUE, SKIP INITIAL ASSIGNMENT. PUTSTMT(ITVAR ' = ' X1) ENDIF *** PROCESS THE INCREMENT AND ITS ASSIGNMENT *** COMP = '.GT.' IF IDENT(X3,NULL) *** THE DEFAULT INCREMENT IS 1 *** X3 = '1' ELSE *** THERE IS AN INCREMENT SPECIFIED *** IF X3 CONSTEST IF IDENT(SIGN,'-') *** NEGATIVE INTEGER CONSTANT INCREMENTS CAUSE *** THE COMPARISON TO BE MADE THE OTHER WAY. COMP = '.LT.' ENDIF ELSE *** IF NOT NUMBER, MAKE INITIAL ASSIGNMENT TO A *** CREATED VARIABLE SO THAT THE VALUE WILL NOT *** BE CHANGED WITHIN THE LOOP. I3 = GENVAR() PUTSTMT(I3 '=' X3) X3 = I3 ENDIF ENDIF *** PUT OUT INCREMENT AND TEST CODE *** *** SKIP AROUND INCREMENT THE FIRST TIME *** L = GENLABEL() PUTSTMT('GO TO ' L) *** PUT LABEL AT TOP OF LOOP PUTLABEL(LTOP) PUTSTMT(ITVAR '=' ITVAR '+(' X3 ')') PUTLABEL(L) IF DIFFER(X2,NULL), PUTIF(ITVAR COMP X2,'GO TO ' LBOT) ELSE ERR('BADLY FORMED ITERATION (FOR) PARAMETERS') ENDIF ELSE *** PUT OUT THE LABEL AT THE TOP OF THE LOOP NOW *** PUTLABEL(LTOP) ENDIF IF BACK ARBWHILEPAT = F *** PROCESS WHILE CONDITION *** PUTIF(LNOT(X),'GO TO ' LBOT) ENDIF IF BACK ARBUNTILPAT = F *** PROCESS THE UNTIL CONDITION *** PUTIF(X,'GO TO ' LBOT) ENDIF IF DIFFER(TRIM(BACK),NULL) ERR('LOOP CLAUSE NOT RECOGNIZABLE') ENDIF *** PUSH A LOOP ELEMENT ONTO THE STRUCTURE STACK *** LISTLEVEL = LEVEL PUSH(E('LOOP',LTOP,LBOT,EXITS)) :(NEXT) SUBTITLE 'ENDLOOP' INITIAL REPEATPAT = OPTB 'REPEAT' B ENDINITIAL ENDLOOP IF NOT TOP = POP() ERR('ENDLOOP OUTSIDE LOOP STRUCTURE') :(FORTRAN) ENDIF IF DIFFER(TY(TOP),'LOOP') ERR('ENDLOOP WITHOUT MATCHING LOOP') :(RESTACK) ENDIF *** THE CODE GENERATED BY THE ENDLOOP STATEMENT DEPENDS ON *** SEVERAL CONDITIONS. *** (1) NO CONDITIONS ON ENDLOOP GENERATES: *** GOTO TOP-OF-LOOP *** (2) REPEAT WHILE (L) GENERATES: *** IF (L) GOTO TOP-OF-LOOP *** (3) REPEAT UNTIL (L) GENERATES: *** IF .NOT.(L) GOTO TOP-OF-LOOP *** (4) REPEAT UNTIL (L1) WHILE (L2) GENERATES: *** IF (L1) GOTO END-OF-LOOP *** IF (L2) GOTO TOP-OF-LOOP *** *** A LABEL MAY BE GENERATED AT THE BEGINNING OF THE *** ENDLOOP CODE IF THERE WAS A NEXTLOOP. IF DIFFER(MISC2(TOP),NULL) *** THERE IS A NEXTLOOP LABEL TO GENERATE *** PUTLABEL(MISC2(TOP)) ENDIF IF BACK REPEATPAT = *** THERE IS EITHER AN UNTIL, WHILE, OR BOTH *** IF BACK ARB . F UNTILPAT OPTB = F *** AN UNTIL CONDITION, BUT IS THERE ALSO A WHILE *** UNTILX = X IF BACK WHILEPAT = *** THERE ARE BOTH UNTIL AND WHILE CONDITIONS *** PUTIF(UNTILX,'GOTO ' L2(TOP)) PUTIF( X,'GOTO ' L1(TOP)) ELSE *** JUST AN UNTIL CONDITION *** PUTIF(LNOT(X),'GO TO ' L1(TOP)) ENDIF ELSEIF BACK WHILEPAT = *** A WHILE CONDITION *** PUTIF(X,'GOTO ' L1(TOP)) ELSE *** SOMETHING IS WRONG *** ERR('UNRECOGNIZED "ENDLOOP REPEAT" OPTION: ' BACK) ENDIF ELSE *** NO CONDITIONS ON ENDLOOP *** PUTSTMT('GOTO ' L1(TOP)) ENDIF IF DIFFER(BACK,NULL) *** SOMETHING UNEXPECTED ON ENDLOOP *** ERR('ENDLOOP NOT FOLLOWED BY "REPEAT" BEFORE: ' BACK) ENDIF PUTLABEL(L2(TOP)) LISTLEVEL = LEVEL :(NEXT) -STITL EXITLOOP * THE EXITLOOP STATEMENT MAY BE FOLLOWED BY OPTIONAL EXIT VARIAB * WHICH WILL BE SET TO FALSE AND THEN A BRANCH WILL BE MADE TO THE * EXIT LABEL FOR THE CORRESPONDING LOOP. INITIAL SIGNALPAT = OPTB '(' OPTB (VARIABLE | CHARCON) . X OPTB ')' RE EXITNEXTOPNDPAT = B (VARIABLE | CHARCON) . X RPOS(0) ENDINITIAL EXITLOOP GENEXITLOOP() :(NEXT) GENEXITLOOP PROC ()X,ELEM X = NULL IF BACK SIGNALPAT IF NOT X "'" *** SET THE EXIT VARIABLE TO .TRUE. *** PUTSTMT(X ' = .TRUE.') ENDIF ELSEIF BACK EXITNEXTOPNDPAT *** THERE SHOULD HAVE BEEN PARENS, BUT WILL DO WITH WARN IF NOT X "'" PUTSTMT(X ' = .TRUE.') ENDIF WARN('EXITLOOP ARGUMENT SHOULD BE IN PARENTHESES') ENDIF IF IDENT(COMPILER,'MACFORTRAN') AND IDENT(X, NULL) PUTSTMT('EXIT') ELSEIF ELEM = FINDLOOP(X) PUTSTMT('GO TO ' L2(ELEM)) ELSE ERR('EXITLOOP OCCURS OUTSIDE OF ANY LOOP') ENDIF ENDPROC SUBTITLE 'NEXTLOOP' * THE NEXTLOOP STATEMENT MAY BE FOLLOWED BY OPTIONAL EXIT VARIAB * TO IDENTFY THE LOOP TO BE CONTINUED. A BRANCH WILL BE MADE TO THE * ENDLOOP OF THE INNERMOST LOOP IF THERE IS NO EXIT VARIABLE OR * CHARACTER STRING OR THE THE CORRESPONDING ENDLOOP IF THERE IS * AN EXIT IDENTIFIER. NEXTLOOP PUTSTMT(GENNEXTLOOP()) GOTOPRECEDES = 'YES' :(NEXT) GENNEXTLOOP PROC ()X,ELEM X = NULL IF BACK SIGNALPAT ELSEIF BACK EXITNEXTOPNDPAT *** THERE SHOULD HAVE BEEN PARENS, BUT WILL DO WITH WARN WARN('NEXTLOOP ARGUMENT SHOULD BE IN PARENTHESES') ENDIF IF IDENT(COMPILER, 'MACFORTRAN') AND IDENT(X, NULL) GENNEXTLOOP = 'CYCLE' ELSEIF ELEM = FINDLOOP(X) IF IDENT(MISC2(ELEM),NULL) MISC2(ELEM) = GENLABEL() ENDIF GENNEXTLOOP = 'GO TO ' MISC2(ELEM) ELSE ERR('NEXTLOOP OCCURS OUTSIDE OF ANY LOOP') ENDIF ENDPROC -STITL INVOKE / PROC / ENDPROC *** THE PROC STACK ELEMENT HAS THE FOLLOWING FIELDS: *** *** TY = 'PROC' *** L1 = LABEL OF STATEMENT FOLLOWING THE ENDPROC *** L2 = PROCNAME *** *** EACH PSTATUS DATA ELEMENT IN PTABLE HAS THE FOLLOWING FIELDS: *** *** PRCNAME - PROCEDURE NAME *** PLABEL - LABEL AT BEGINNING OF PROC *** RETVAR - VARIABLE WHICH CONTAINS THE RETURN LABEL *** RETLABELS - LIST OF LABELS (FOLLOWED BY COMMAS) THAT *** ARE RETURNED TO. *** EPILABE - LABEL OF THE PROCEDURE EPILOGUE. *** PPARAM - LIST OF FORMAL PARAMETERS (UNUSED) *** REFS - LINE NUMBERS AND PROCEDURE NAMES OF REFERENCES *** -SPACE2 INVOKE IF IDENT(COPYCOM,'YES') PUTLINE('C INVOKE ' PROCNAME) ENDIF GENINVOKE(PROCNAME,ACTPAR) :(NEXT) GENINVOKE PROC (PROCNAME,APAR)RETLABE,PSTATE RETLABE = GENLABEL() PSTATE = PTABLE IF IDENT(PSTATE,'') *** FIRST REFERENCE TO THIS PROC - BUILD ENTRY *** PSTATE = PSTATUS(PROCNAME,GENLABEL(),GENVAR(),,,',',) IF DIFFER(APAR,NULL) *** THERE SHOULDN'T BE ANY PARAMETERS ONTHIS CALL ERR('PROC WITH PARAMETERS MUST BE DEFINED BEFORE' + ' CALL') ENDIF ENDIF *** ADD RETURN LABEL TO OTHERS FOR THIS PROC ENTRY RETLABELS(PSTATE) = RETLABELS(PSTATE) RETLABE ',' *** ADD REFERENCE TO THE REFERENCES *** *** PREFIX THE REFERENCE WITH THE NAME OF THE *** PROCEDURE WE ARE IN, IF ANY. IF IDENT(XREF,'YES') *** FOR CROSS-REFERENCING, THE PROCEDURE NAME *** AND ALL THE REFERENCES FROM WITHIN THAT *** PROCEDURE ARE RECORDED IN PARENTHESES *** FOLLOWING. *** *** INPROC CONTAINS THE NAME OF THE PROCEDURE *** THAT WE ARE CURRENTLY INSIDE OF. *** CALLEES CONTAINS A LIST OF THE PROCEDURES *** THAT ARE CALLED FROM THE CURRENT *** PROCEDURE (INPROC). WE NEED THIS *** INORDER TO CLOSE OUT THE PARENTHESIZED *** LIST OF REFERENCES WHEN THE PROCEDURE *** DEFINITION IS TERMINATED. IDENT(INPROC,NULL) :S(GENINVOKE1) IF NOT CALLEDBY(PSTATE) BREAKX(',') ',' INPROC '(' IF IDENT(CALLEDBY(PSTATE),NULL) CALLEDBY(PSTATE) = ',' INPROC '(' CLEANLINE(FILELINE) ELSE CALLEDBY(PSTATE) = CALLEDBY(PSTATE) ',' INPROC '(' CLEANLINE(FILELINE) ENDIF CALLEES = PROCNAME ',' CALLEES ELSE GENINVOKE1 CALLEDBY(PSTATE) = CALLEDBY(PSTATE) ',' CLEANLINE(FILELINE) ENDIF ENDIF IF DIFFER(APAR,NULL) *** PROCESS THE PROCEDURE PARAMETERS *** FP = PPARAM(PSTATE) AP = APAR ',' LOOP WHILE FP BREAK(',') . P ',' = *** GET EACH FORMAL PARAMETER *** IF AP BAL . A ',' = *** ASSIGN ACTUAL PARAM TO FORMAL PARAM PUTSTMT(P ' = ' A) ELSE *** NOT ENOUGH ACTUAL PARAMETERS *** ERR('TOO FEW ACTUAL PARAMETERS ON' PROCNAME) ENDIF ENDLOOP ELSEIF DIFFER(PPARAM(PSTATE),',') ERR('MISSING ACTUAL PARAMETERS ON ' PROCNAME) ENDIF PUTSTMT('ASSIGN ' RETLABE ' TO ' RETVAR(PSTATE)) PUTSTMT('GO TO ' PLABEL(PSTATE)) PUTLABEL(RETLABE) PTABLE = PSTATE ENDPROC -SPACE 5 PROC IF IDENT(COPYCOM,'YES') PUTLINE('C PROC ' PROCNAME) ENDIF INPROC = PROCNAME CALLEES = NULL GENPROC(PROCNAME,'YES',ACTPAR,CLEANLINE(FILELINE)) :(NEXT) GENPROC PROC (PROCNAME,LISTFLAG,FPAR,LINEN)L,PSTATE IF GT(LEVEL,0) ERR('PROC MAY NOT BE DEFINED WITHIN ANY STRUCTURE') FLUSH() ENDIF IF IDENT(GOTOPRECEDES,'YES') *** PRECEDED BY GOTO, NO NEED FOR ONE AROUND PROC *** L = '' ELSE *** GENERATE A GOTO AROUND THE PROC *** L = GENLABEL() PUTSTMT('GO TO ' L) ENDIF IF IDENT(LISTFLAG,'YES') *** GENERATE SEPARATOR FROM PRECEDING TEXT *** IF GT(LINENO,LPP - 8) *** NOT ENOUGH ROOM ON THIS PAGE, EJECT *** LINENO = 123456 ELSE *** PUT OUT BLANK, DASHED & BLANK LINES *** LISTERINE(' ') LISTERINE(' ' DUPL('-',60)) LISTERINE(' ') ENDIF ENDIF PSTATE = PTABLE IF IDENT(PSTATE,'') *** THIS PROC HAS NOT BEEN REFERENCED PREVIOUSLY *** PSTATE = PSTATUS(PROCNAME,GENLABEL(),GENVAR(),,,FPAR ',',,,LINEN) PTABLE = PSTATE ELSE *** ADD DEFINITION TO REFS *** IF IDENT(XREF,'YES') DEFAT(PSTATE) = LINEN ENDIF ENDIF PUTLABEL(PLABEL(PSTATE)) PUSH(E('PROC',L,PROCNAME,,,,LINEN)) ENDPROC -SPACE 4 ENDPROC IF IDENT(INPROC,NULL) *** We are not in a procedure *** ERR('ENDPROCEDURE without matching PROCEDURE') ELSE CALLSON(PTABLE) = CALLEES *** CLOSE OUT XREF LISTS IF NECESSARY *** IF IDENT(XREF,'YES') LOOP WHILE CALLEES BREAK(',') . PROCNAME ',' = PSTATE = PTABLE CALLEDBY(PSTATE) = CALLEDBY(PSTATE) ') ' ENDLOOP ENDIF INPROC = NULL GENENDPROC() ENDIF :(NEXT) GENENDPROC PROC ()L IF NOT TOP = POP() ERR('ENDPROC WITHOUT MATCHING PROC') :(RESTACK) ENDIF IF NE(LEVEL,0) ERR('UNCLOSED STRUCTURES AT END OF PROC') FLUSH() ENDIF IF DIFFER(TY(TOP),'PROC') ERR('ENDPROC WITHOUT MATCHING PROC') :(NEXT) ENDIF IF IDENT(GOTOPRECEDES,'NO') L = EPILABE(PTABLE) IF IDENT(L,NULL) *** GENERATE A LABEL IF NECESSARY *** L = GENLABEL() EPILABE(PTABLE) = L ENDIF PUTSTMT('GO TO ' L) GOTOPRECEDES = 'YES' ELSE *** NO NEED FOR AN EPILOGUE BECAUSE THE PROCEDURE *** WAS ALREADY TERMINATED WITH A BRANCH IF IDENT(EPILABE(PTABLE),NULL) *** WAS NEVER USED AND WE STILL DON'T NEED IT ** EPILABE(PTABLE) = 'UNUSED' ENDIF ENDIF IF DIFFER(L1(TOP),'') *** THERE WAS A BRANCH AROUND THIS PROC DEF *** PUTLABEL(L1(TOP)) ENDIF LISTLEVEL = LEVEL ENDPROC EXITPROC GENEXITPROC() :(NEXT) GENEXITPROC PROC () IF ELEM = FINDPROC() *** WE HAVE FOUND THE ENCLOSING PROC *** L = EPILABE(PTABLE) IF IDENT(L,NULL) *** WE MUST GENERATE THE EPILOGUE LABEL AS THIS *** IS THE FIRST REFERENCE L = GENLABEL() EPILABE(PTABLE) = L ENDIF PUTSTMT('GO TO ' L) GOTOPRECEDES = 'YES' ELSE *** WE ARE NOT IN A PROC *** ERR('EXITPROC MUST OCCUR WITHIN A PROC') ENDIF ENDPROC -STITL DO CASE / CASE / ELSE CASE / END CASE * * THE CASE STATEMENT IS OF THE FOLLOWING FORM: * * DOCASE (iexp) * CASE (icon,...) * ... * CASE (icon,...) * . * . * . * ELSECASE * ... * ENDCASE * * Code is generated for this in the following manner. The DOCASE * statement generates a GOTO to the prologue code which is produced * either at the ELSECASE statement, if there is one, or the ENDCASE. * (It saves one GOTO to generate it at the ELSECASE). * A label is generated for each CASE statement and the maximum and * minimum case values are recorded as the CASE statements are * processed. The prologue code looks something like the following: * * IF (conval.GE.min .OR. conval.LE.max) * + GOTO (LABEL,...),CONVAL-MIN+1 * else fall through to the ELSECASE out of ENDCASE. * * THE CASE STRUCTURE STACK ELEMENT FIELDS ARE: * INITIAL DATA('DOCASE(TY,BEG,ENDLABEL,PROLABEL,CONVAL,CASEPAIRS,CASEMIN,CASEMAX)') ENDINITIAL * * One of these elements is on the stack following the DOCASE or * CASE statements. A different element is used for ELSECASE. * * TY = 'DOCASE' (this field is in every structure) * BEG = source line number (in every structure) * ENDLABEL = label at end of case structure * PROLABEL = label on case prologue * CONVAL = control value specified on DOCASE * CASEPAIRS = case number / case label pairs * CASEMIN = minimum case number * CASEMAX = maximum case number INITIAL DATA('ELSECASE(TY,BEG,ENDLABEL)') ENDINITIAL * * One of these elements is on the stack following an ELSECASE. * * TY = 'DOCASE' (this field is in every structure) * BEG = source line number (in every structure) * ENDLABEL = label at end of case structure -SPACE 3 INITIAL CASEPAT2 = OPTB (('-' | NULL) NUMBER) . N OPTB (',' | RE) ENDINITIAL DOCASE IF IDENT(LEXP,NULL) ERR('MISSING CONTROL VALUE IN DOCASE STATEMENT') ENDIF *** GENERATE A GOTO TO THE PROLOGUE WHICH WILL BE GENERATED *** AT THE ELSECASE, IF THERE IS ONE, OR THE ENDCASE OTHERWIS L = GENLABEL() PUTSTMT('GO TO ' L) *** REMEMBER AS GOTO SO FIRST CASE DOESN'T GEN EXTRA GOTO *** GOTOPRECEDES = 'YES' PUSH(DOCASE('DOCASE',FILELINE,,L,LEXP)) :(NEXT) -SPACE 4 CASE IF NOT TOP = POP() ERR('CASE WITHOUT PRECEDING DO CASE') :(FORTRAN) ENDIF IF DIFFER(TY(TOP),'DOCASE') ERR('CASE WITHOUT MATCHING DO CASE') :(RESTACK) ENDIF IF DIFFER(GOTOPRECEDES,'YES') *** LAST STM WASN'T GOTO SO GENERATE GOTO TO END *** IF IDENT(ENDLABEL(TOP),'') *** FIRST TIME LABEL AT END WAS NEEDED *** ENDLABEL(TOP) = GENLABEL() ENDIF *** PUT GOTO AT END OF PREVIOUS CASE *** PUTSTMT('GO TO ' ENDLABEL(TOP)) ENDIF L = GENLABEL() PUTLABEL(L) LOOP WHILE LEXP CASEPAT2 = CASEPAIRS(TOP) = CASEPAIRS(TOP) N '=' L ',' N = CONVERT(N,'INTEGER') IF IDENT(CASEMAX(TOP),NULL) CASEMAX(TOP) = N ELSEIF GT(N,CASEMAX(TOP)) CASEMAX(TOP) = N ENDIF IF IDENT(CASEMIN(TOP),NULL) CASEMIN(TOP) = N ELSEIF LT(N,CASEMIN(TOP)) CASEMIN(TOP) = N ENDIF ENDLOOP IF DIFFER(LEXP,'') ERR('ILLEGAL CASE VALUE(S)') ENDIF LISTLEVEL = LEVEL PUSH(TOP) IF DIFFER(SOURCELABEL,' ') ERR('NO LABEL MAY BE ON CASE') ENDIF :(NEXT) -SPACE 4 ELSECASE IF NOT TOP = POP() ERR('ELSE CASE WITHOUT PRECEDING DO CASE') :(FORTRAN) ENDIF IF DIFFER(TY(TOP),'DOCASE') ERR('ELSE CASE WITHOUT MATCHING DO CASE') :(RESTACK) ENDIF IF DIFFER(GOTOPRECEDES,'YES') *** NEED GOTO FROM END OF LAST CASE *** IF IDENT(ENDLABEL(TOP),'') *** FIRST TIME LABEL AT END IS NEEDED *** ENDLABEL(TOP) = GENLABEL() ENDIF PUTSTMT('GO TO ' ENDLABEL(TOP)) ENDIF PUTLABEL(PROLABEL(TOP)) *** GENERATE A LABEL FOR OMITTED CASES L = GENLABEL() GENCASEPRO(L) PUTLABEL(L) LISTLEVEL = LEVEL PUSH(ELSECASE('ELSECASE',BEG(TOP),ENDLABEL(TOP))) IF DIFFER(SOURCELABEL,' ') ERR('NO LABEL MAY BE ON ELSECASE') ENDIF :(NEXT) -SPACE 4 ENDCASE IF NOT TOP = POP() ERR('ENDCASE WITHOUT PRECEDING STRUCTURE') :(RESTACK) ENDIF IF IDENT(TY(TOP),'DOCASE') *** GO TO AROUND PROLOG, THEN THE PROLOG *** IF DIFFER(GOTOPRECEDES,'YES') *** WE NEED A GOTO AROUND THE PROLOG *** IF IDENT(ENDLABEL(TOP),'') *** GENERATE THE NEEDED LABEL *** ENDLABEL(TOP) = GENLABEL() ENDIF PUTSTMT('GO TO ' ENDLABEL(TOP)) ENDIF PUTLABEL(PROLABEL(TOP)) GENCASEPRO(ENDLABEL(TOP)) ELSE IF DIFFER(TY(TOP),'ELSECASE') ERR('ENDCASE WITHOUT MATCHING DOCASE') :(RESTACK) ENDIF ENDIF PUTLABEL(ENDLABEL(TOP)) LISTLEVEL = LEVEL IF DIFFER(SOURCELABEL,' ') ERR('NO LABEL MAY BE ON ENDCASE') ENDIF :(NEXT) -STITL IMBEDDED FORMATS IN READ AND WRITE IOFMT GENIOFMT(P1,FMT,P2) :(NEXT) GENIOFMT PROC (P1,FMT,P2)SFMT,X SFMT = FMT IF FMT 'FMT=' = *** ANSI IMBEDDED FMT= TYPE OF FORMAT *** REPLACE OUTER QUOTES WITH PARENS AND *** UNDOUBLE INNER QUOTES IF NOT FMT "'" RTAB(1) . X "'" = '(' X ')' ERR('SOMETHING IS WRONG WITH FORMATS',12) ENDIF I = 0 LOOP WHILE FMT (TAB(I) BREAKX("'")) . X "''" @J = X "'" I = J - 1 ENDLOOP ENDIF IF DIFFER(FMT,'') *** THIS DEFINES A NEW FORMAT *** LASTFMT = GENLABEL() LASTFMTISN = ISN PUTLABEL(LASTFMT) PUTSTMT('FORMAT ' FMT) ELSE *** NO FORMAT - USE LAST ONE GENERATED *** IF IDENT(LASTFMT,'') ERR('NO PREVIOUS IMBEDDED FORMAT HAS OCCURRED') :(NEXT) ENDIF IF LT(LASTFMTISN,ISN - 10) ERR('LAST IMBEDDED FORMAT WAS MORE THAN 10 STMS AGO') ENDIF ENDIF PUTSTMT(P1 LASTFMT P2) ENDPROC -SPACE FORMAT GOTOTEMP = GOTOPRECEDES IF IDENT(SOURCELABEL,' ') *** THIS FORMAT ESTABLISHES THE DEFAULT FORMAT *** LASTFMT = GENLABEL() LASTFMTISN = ISN PUTLABEL(LASTFMT) ELSE ERASELABEL() ENDIF PUTFSTMT() GOTOPRECEDES = GOTOTEMP :(NEXT) -STITL PARAMETER STATEMENT INITIAL PARPAT = OPTB VARIABLE . V OPTB '=' OPTB CONPAT . C + OPTB (',' | '') PARPARTEST = OPTB '(' QPBAL . BACK ')' RPOS(0) ENDINITIAL PARAMETER IF NOT BACK PARPARTEST * WARN('PARENTHESES MISSING FROM PARAMETER STATEMENT') ENDIF LOOP WHILE BACK PARPAT = IF GT(SIZE(V),6) WARN('Parameter names longer than 6 characters not legal in Fortran') ENDIF IF DIFFER(PARDECL,'YES') *** Make PARAMETER substitution *** PARTABLE = C PARSCANPAT1 = PARSCANPAT1 | V ELSE *** Generate declarations for PARAMETERs *** IF C ('+' | '-' | '') SPAN('0123456789') RPOS(0) OR C "'" *** INTEGER (or character to treat as such) *** PUTSTMT('INTEGER ' V) ELSEIF C '.TRUE.' | '.FALSE.' *** LOGICAL, nicht Wahr? *** PUTSTMT('LOGICAL ' V) ELSE *** Assume it is REAL *** PUTSTMT('REAL ' V) ENDIF PUTSTMT('DATA ' V '/' C '/') ENDIF ENDLOOP IF DIFFER(BACK,'') ERR('GARBAGE IN PARAMETER STMT = "' BACK '"') ENDIF IF DIFFER(PARDECL,'YES') PARSCANPAT = (QBAL ANY(BREAKERS)) . PAR1 + (PARSCANPAT1) . PAR + (ANY(BREAKERS) | RPOS(0)) . PAR2 *??? THIS PAT DOESN'T WORK QUITE RIGHT FOR QUOTES ??? PARAMS = 'YES' ENDIF :(NEXT) -STITL LISTING CONTROL FUNCTIONS SPACE IF LE(LINENO,LPP) IF NE(FIRSTL,LINENO) *** WE DON'T DO THE SPACING IF ALREADY AT THE TOP OF *** A PAGE. IF IDENT(N,NULL) N = 1 ENDIF IF GT(LINENO + N,LPP) LINENO = 123456 ELSE LOOP WHILE GT(N,0) LISTERINE(' ') N = N - 1 ENDLOOP ENDIF ENDIF ENDIF :(NEXTI) -SPACE 4 EJECT IF NE(FIRSTL,LINENO) *** DON'T DO THE EJECT IF WE ARE AT THE TOP OF *** A PAGE ALREADY. IF DIFFER(N,NULL) *** THERE IS A NUMBER ON THE EJECT *** IF GT(N,LPP - LINENO) *** EJECT IF THERE'S NOT ENOUGH ROOM ON PAGE *** LINENO = 123456 ENDIF ELSE *** ALWAYS EJECT IF NO OPERAND ON EJECT *** LINENO = 123456 ENDIF ENDIF :(NEXTI) -SPACE 3 * THE LIST COMMAND MAY BE FOLLOWED BY ONE OF THE FOLLOWING KEYWORDS: * LIST (ON | OFF | PUSHON | PUSHOFF | POP) LIST DOCASE (X) CASE ('ON','') LISTING = 'YES' CASE ('OFF') LISTING = 'NO' CASE ('PUSHON') IF GT(LISTPTR,9) ERR('TOO MANY LIST PUSHONS') ELSE LISTPTR = LISTPTR + 1 LISTSTK = LISTING ENDIF LISTING = 'YES' CASE ('PUSHOFF') IF GT(LISTPTR,9) ERR('TOO MANY LIST PUSHOFFS') ELSE LISTPTR = LISTPTR + 1 LISTSTK = LISTING ENDIF LISTING = 'NO' CASE ('POP') IF LE(LISTPTR,0) ERR('TOO MANY LISTING POPS') LISTING = 'YES' ELSE LISTING = LISTSTK LISTPTR = LISTPTR - 1 ENDIF ELSECASE ERR('UNDEFINED LIST OPTION:' X) ENDCASE :(NEXTI) -SPACE 3 TITLE TITLETEXT = CENTER(TEXT,70) SUBTITLETEXT = '' IF IDENT(COPYCOM,'YES') PUTLINE('C ' TEXT) ENDIF LINENO = 123456 NEWHEADER = 'YES' IF IDENT(BLDCON,'ON') IF DIFFER(TEXT,NULL) *** PUT TITLE IN TABLE OF CONTENTS *** TABCON(TEXT) ENDIF ENDIF :(NEXTI) -SPACE 3 SUBTITLE SUBTITLETEXT = CENTER(TEXT,70) IF IDENT(COPYCOM,'YES') PUTLINE('C ' TEXT) ENDIF LINENO = 123456 NEWHEADER = 'YES' IF IDENT(BLDCON,'ON') IF DIFFER(TEXT,NULL) *** PUT SUBTITLE IN TABLE OF CONTENTS *** TABCON(TEXT) ENDIF ENDIF :(NEXTI) -SPACE 3 GOTO IF DIFFER(SOURCELABEL,' ') ERASELABEL() ENDIF PUTFSTMT() GOTOPRECEDES = 'YES' :(NEXT) -SPACE 3 SUBPGM SUBPGMNAME = PROCNAME IF IDENT(TITLETEXT,INITTITLE) *** DEFAULT TITLE TO SUBPGM NAME *** TITLETEXT = CENTER(SUBPGMNAME,70) ENDIF :(FORTRAN) -SPACE 3 INDENT LISTLEVEL = LEVEL PUSH(E('INDENT',,,,,,FILELINE)) :(NEXT) -SPACE 3 ENDINDENT IF POPC('INDENT') LISTLEVEL = LEVEL ENDIF :(NEXT) -STITL 'OPTION PROCESSING' INITIAL OPTPAT = (BREAK(',=') . KEY LEN(1) | (LEN(1) REM) . KEY) ENDINITIAL OPTION OPTPROC(OPTVAL) :(NEXT) OPTPROC PROC (OPTVAL)KEY *** this procedure scans an option list and sets the *** appropriate switches and values. It is called *** at the beginning to process the PAR field and *** for each occurrene of the OPTION statement. LOOP WHILE OPTVAL OPTPAT = DO CASE (KEY) CASE ('FRED') *** INVOKE *SPITDEBUG WHEN THIS IS ENCOUNTERED. THIS *** feature is only intended for implementer debugging. DEBUG('YES MASTER') FRED = 'YES' CASE ('COMPILER') *** THE COMPILER OPTION IS USED TO SPECIFY WHICH COMPILER *** OVERDRIVE SHOULD PRODUCE ITS OUTPUT FOR. THE ONLY *** DIFFERENCE THAT IS CURRENTLY RELEVANT IS FTNG VS. *** FTNH WRT ISN COUNTING. IF NOT OPTVAL ('FTNH' | 'FTNG' | 'MACFORTRAN') . COMPILER (',' | RPOS(0)) = ERR('COMPILER= option is invalid (must be FTNG, FTNH, or MACFORTRAN') ENDIF CASE ('INDENT') *** INDENT SETS THE INDENTATION STRING *** *** INDENT='STRING' DOINDT = 'YES' IF OPTVAL ("'" BREAK("'") . IND "'") (',' | RPOS(0)) = COMPUTE_INDENT(IND) ELSE ERR('Bad indent value') ENDIF CASE ('NOINDENT') *** TURNS AUTO INDENTATION OFF *** DOINDT = 'NO' CASE ('LDECL') *** GENERATE DECLARATIONS FOR LOGICAL EXIT VARIABLES *** LDECL = 'YES' CASE ('NOLDECL') *** DON'T GEN DECLS FOR LOGICAL EXIT VARIABLES *** LDECL = 'NO' CASE ('CONTENTS') *** SETS CONTENTS COLLECTION ON *** BLDCON = 'ON' CASE ('NOCONTENTS') *** TURN TABLE OF CONTENTS COLLECTION OFF *** BLDCON = 'OFF' CASE ('LIST') *** turns on listing *** LISTING = 'YES' CASE ('NOLIST') *** turns off listing *** LISTING = 'NO' CASE ('NOXREF') *** TURN XREF OPTION OFF *** XREF = 'NO' CASE ('XREF') *** TURN XREF ON *** XREF = 'YES' CASE ('NOFLAGGOTO') *** Don't flag GOTOs *** FLAGGOTO = 'NO' CASE ('FLAGGOTO') *** Flag GOTOs *** FLAGGOTO = 'NO' CASE ('NOCOM') *** DON'T CARRY COMMENTS OVER INTO OBJ *** COPYCOM = 'NO' CASE ('COM') *** CARRY COMMENTS OVER INTO OBJ *** COPYCOM = 'YES' CASE ('PARDECL') *** Declare PARAMETER variables and initialize them *** with a DATA statement. PARDECL = 'YES' CASE ('NOPARDECL') *** Make PARAMETER substitutions *** PARDECL = 'NO' CASE ('START') *** OBSOLETE OBSOLETE OBSOLETE OBSOLETE OBSOLETE *** *** SETS FIRST VALUE OF ALL GENERATED LABELS AND VARS *** Why is this warning commented out???? * WARN('THE START= OPTION IS OBSOLETE, USE LABEL=') OPTVAL SPAN('0123456789') . LNUM (',' | NULL) = CASE ('LABEL') *** SETS GENERATED LABELS TO EITHER THE LINE NUMBER OR *** STARTING FROM THE START VALUE DOWN. *** WITH LABEL=LINE OR LABEL=NUMBER. IF NOT OPTVAL ('LINE' | NUMBER) . LABELTYPE (',' | NULL) = *** THIS IS AN ERROR *** ERR('ILLEGAL LABEL= OPTION:' OPTVAL) ENDIF IF DIFFER(LABELTYPE,'LINE') *** SET INITIAL VALUE FOR GENERATED LABELS AND VARS LNUM = LABELTYPE LABELTYPE = 'NUMBER' ENDIF CASE ('LPFX') *** LPFX=SINGLE DIGIT *** WILL SET THE PREFIX USED IN FRONT OF LABELS *** CREATED FROM THE SOURCE LINE NUMBERS. IF NOT OPTVAL ANY('0123456789') . LPFX (',' | '') = *** MUST NOT BE A SINGLE DIGIT *** ERR('OPTION LPFX= REQUIRES A SINGLE DIGIT') ENDIF CASE ('STACKTRACE') STACKTRACE = 'YES' CASE ('NOSTACKTRACE') STACKTRACE = 'NO' ELSECASE ERR('UNRECOGNIZED OPTION: "' KEY '"') ENDCASE ENDLOOP IF OPTVAL SPAN(', ') = ENDIF IF DIFFER(OPTVAL,'') ERR('UNRECOGNIZED OPTIONS: "' OPTVAL '"') ENDIF ENDPROC -STITL MISC FUNCTIONS INITIAL M3PAT = BREAK('=') . N '=' BREAK(',') . L ',' ENDINITIAL GENCASEPRO PROC (DEFAULTL)LARRAY,X,LABELLIST,L,N,I,COUNT *** ??? *** CHECK THIS ARITHMETIC COUNT = CASEMAX(TOP) - CASEMIN(TOP) + 1 LARRAY = ARRAY(COUNT,DEFAULTL) LOOP WHILE CASEPAIRS(TOP) M3PAT = *** ASSOCIATE CASE NUM WITH CORRESPONDING LABEL *** **** ??? *** CHECK THIS ARITHMETIC LARRAY = L ENDLOOP I = 1 LOOP WHILE LE(I,COUNT) *** BUILD LIST OF LEGAL LABEL VALUES FOR GOTO *** LABELLIST = LABELLIST ',' LARRAY I = I + 1 ENDLOOP IF NOT LABELLIST ',' = ERR('SOMETHING IS WRONG WITH CASE PROLOGS',12) ENDIF * * *** SCALE AND CHECK THE CONTROL VALUE *** * X = CONVAL(TOP) IF NE(CASEMIN(TOP),1) *** ADJUST FOR MINIMUM CASE VALUE *** X = '(' X ')-(' CASEMIN(TOP) - 1 ')' ENDIF IF NOT X VARNUMPAT PUTSTMT('I99999 = ' X) X = 'I99999' ENDIF * * *** GENERATE THE CONTROL VALUE TEST AND COMPUTED GOTO * PUTIF( X '.GE.1.AND.' X '.LE.' COUNT, + 'GOTO(' LABELLIST '),' X) ENDPROC -SPACE 5 CANREPLY PROC () SCREPLY() :F(FRETURN) ENDPROC -SPACE 5 FINDLOOP PROC (EXIT)L L = LEVEL LOOP WHILE FINDLOOP = STACK IF IDENT(TY(FINDLOOP),'LOOP') *** WE HAVE A LOOP, ARE WE LOOKING FOR AN EXIT? IDENT(EXIT,NULL) :S(RETURN) IF DIFFER(MISC1(FINDLOOP),NULL) IDENT(MISC1(FINDLOOP),'YES') :S(RETURN) ENDIF ENDIF L = L - 1 ENDLOOP :(FRETURN) ENDPROC -SPACE 5 FINDPROC PROC ()L L = LEVEL LOOP WHILE FINDPROC = STACK IDENT(TY(FINDPROC),'PROC') :S(RETURN) L = L - 1 ENDLOOP :(FRETURN) ENDPROC -SPACE 5 COMPUTE_INDENT PROC (IND)INDL,I *** COMPUTES THE INDENTATION TO BE USED IN THE *** LISTING. THIS IS CALLED TO INITIALIZE THE *** GLOBAL INDENT ARRAY AND CALLED AGAIN IF THE *** INDENTATION STRING IS EVER CHANGED. INDENT = ARRAY('0:20') INDENT<0> = NULL INDENT<20> = DUPL(IND,20) INDL = SIZE(IND) I = 1 LOOP WHILE LE(I,19) *** CALCULATE THE INDENTATION VALUES *** INDENT = SUBSTR(INDENT<20>,1,I * INDL) I = I + 1 ENDLOOP ENDPROC -SPACE 5 CENTER PROC (T,S) *** CENTER RETURNS A STRING OF LENGTH S WITH *** *** THE STRING T CENTERED IN IT WITH *** *** SURROUNDING BLANKS. *** CENTER = RPAD(LPAD(T,(S + SIZE(T)) / 2,' '),S,' ') ENDPROC -SPACE 4 ERR PROC (ERRCOM,SEVERITY) IF IDENT(SEVERITY,'') *** THE DEFAULT SEVERITY IS 8 WHICH STOPS FORTRAN *** SEVERITY = 8 ENDIF IF GT(SEVERITY,0) IF EQ(&CODE,12) *** SINCE &CODE STARTS AT 12, THIS IS THE FIRST ERROR &CODE = SEVERITY ELSE *** REPLACE IF THE CODE IS GREATER THAT PREVIOUSLY IF GT(SEVERITY,&CODE) *** THE MAX SEVERITY ERROR APPLIES TO ENTIRE RUN *** &CODE = SEVERITY ENDIF ENDIF ENDIF ERRNO = ERRNO + 1 IF GT(ERRNO,50) IF CANREPLY() SERCOM = ' **** OVERDRIVE TRANSLATION TERMINATED ****' SERCOM = ' **** MORE THAN 50 ERRORS IS UNNATURAL. ****' ENDIF :(END) ENDIF ERRORS = SOURCEOLN<1> ' *** ' ERRCOM IF CANREPLY() SERCOM = ' ' SERCOM = ' ' SOURCEOLN<1> ' ' STMT SERCOM = ' *** ' ERRCOM ENDIF IF IDENT(FRED,'YES') *** SPEAK TO MY CREATOR *** DEBUG('YOU CALLED MASTER?') ENDIF LISTERINE('**** ' ERRCOM) ENDPROC -SPACE 5 GENVAR PROC () *** CREATES AN INTEGER VARIABLE *** VNUM = VNUM - 1 GENVAR = 'I' LPAD(VNUM,5,'0') ENDPROC -SPACE 5 RESTACK PUSH(TOP) :(NEXT) -STITL LISTING PROCEDURES LISTCOM PROC (C) LISTERINE(B12 SOURCEOLN<1> C) ENDPROC -SPACE 5 INITIAL BOXINDENT = DUPL(' ',23) BOXINDENTB = DUPL(' ',24) BOXINDENTSTAR = BOXINDENT '*' STAR72 = DUPL('*',72) BOXLINE1 = ' ' BOXINDENT '*' B70 '*' BOXTOP = '1' BOXINDENT STAR72 BOXBOT = ' ' BOXINDENT STAR72 ENDINITIAL LISTERINE PROC (LL) DIFFER(LISTING,'YES') :S(RETURN) LINENO = LINENO + 1 IF GT(LINENO,LPP) *** A NEW PAGE *** *** BUT FIRST PUT OUT A FOOTER *** IF GT(PAGENO,1) PRINTER = '< ' SUBPGMNAME + ' PAGE ' PAGENO - 1 ' ' FOOTERTEXT ENDIF FOOTERTEXT = SUBTITLETEXT IF IDENT(NEWHEADER,'YES') *** PUT A BOX AROUND THE NEW HEADER *** LEFTD = BOXINDENTSTAR RIGHTD = '*' CARRIAGE = ' ' BOXLINE = BOXLINE1 IF IDENT(VERYFIRST,'YES') *** GLITCH BECAUSE SPITBOL DOES PAGE EJECT *** PRINTER = BOXBOT LINENO = 1 ELSE PRINTER = BOXTOP PRINTER = BOXLINE LINENO = 2 ENDIF ELSE LEFTD = BOXINDENTB RIGHTD = '' CARRIAGE = '1' BOXLINE = ' ' LINENO = 0 ENDIF IF IDENT(VERYFIRST,'YES') PRINTER = CARRIAGE LEFTD VERSION RIGHTD PRINTER = BOXLINE LINENO = LINENO + 2 VERYFIRST = 'NO' ENDIF PRINTER = CARRIAGE LEFTD TITLETEXT RIGHTD ' ' + TODAY ' PAGE ' PAGENO + ' ' SUBPGMNAME PRINTER = BOXLINE LINENO = LINENO + 2 IF DIFFER(SUBTITLETEXT,'') PRINTER = ' ' LEFTD SUBTITLETEXT RIGHTD PRINTER = BOXLINE LINENO = LINENO + 2 ENDIF IF IDENT(NEWHEADER,'YES') PRINTER = BOXBOT LINENO = LINENO + 1 NEWHEADER = 'NO' ENDIF PRINTER = ' ' PRINTER = ' LABEL ISN LINE' PRINTER = ' ' LINENO = LINENO + 3 PAGENO = PAGENO + 1 *** REMEMBER FIRST LINE COUNT SO CAN IGNORE SPACES *** AND EJECTS WHEN THEY OCCUR AT TOP OF PAGE FIRSTL = LINENO ENDIF PRINTER = LL ENDPROC -SPACE 5 INITIAL LLPAT1 = LEN(6) OPTB . INTAB LLPAT2 = LEN(6) . P1 OPTB . INTAB REM . PART2 ENDINITIAL LISTLINE PROC ()SN,SL,EXTRA,LNOUT,INTAB,ISNOUT,TABSIZE DIFFER(LISTING,'YES') :S(RETURN) IF IDENT(SOURCE<1>,'') *** BAD NEWS *** ERR('INTERNAL ERROR - UNABLE TO LIST SOURCE',12) ENDIF *** SET UP INTERNAL LABEL *** INTLABELS = ' ' RPAD(INTLABELS,6) *** SET UP INTERNAL STATEMENT NUMBER (ISN) *** IF EQ(ISN,LASTISN) SN = ' ' ELSE SN = LPAD(ISN,4,' ') LASTISN = ISN ENDIF ISNOUT = RPAD(SN,4,' ') ' ' IF IDENT(DOINDT,'YES') *** INDENT THE LINE *** IAMOUNT = INDENT IF SOURCE<1> LLPAT1 TABSIZE = SIZE(INTAB) LOOP FOR SL = 1 WHILE DIFFER(SOURCE,'') *** OUTPUT EACH LINE *** SOURCE LLPAT2 LNOUT = SOURCEOLN EXTRA = SIZE(INTAB) - TABSIZE IF LT(EXTRA,0) EXTRA = 0 ENDIF LISTERINE(INTLABELS ISNOUT LNOUT P1 IAMOUNT BDUPL PART2) ENDLOOP ELSE *** IT MUST BE A BLANK (I.E. SHORT) LINE *** LISTERINE(B12 SOURCEOLN<1> ' ' IAMOUNT) ENDIF ELSE *** NO AUTOMATIC INDENTATION *** LOOP FOR SL = 1 WHILE DIFFER(SOURCE,'') LNOUT = SOURCEOLN LISTERINE(INTLABELS ISNOUT LNOUT SOURCE) ENDLOOP ENDIF INTLABELS = NULL ENDPROC -STITL LNOT (LOGICAL NOTTER) PROCEDURE INITIAL **** PATTERNS AND TABLE USED BY THE LNOT FUNCTION OPPOSITE = TABLE() OPPOSITE<'.LT.'> = '.GE.' OPPOSITE<'.LE.'> = '.GT.' OPPOSITE<'.EQ.'> = '.NE.' OPPOSITE<'.NE.'> = '.EQ.' OPPOSITE<'.GE.'> = '.LT.' OPPOSITE<'.GT.'> = '.LE.' LOPER = ('.' ('LT' | 'LE' | 'EQ' | 'NE' | 'GE' | 'GT') '.') LNORPAT = QPBAL . LEFT '.OR.' REM . RIGHT LNANDPAT = QPBAL . LEFT '.AND.' REM . RIGHT LNNOTPAT = LEXP OPTB '.NOT.' REM . LNOT LNPAT1 = QPBAL . LEFT LOPER . OPER REM . RIGHT LNPAT2 = OPTB '(' QPBAL . LEFT ')' OPTB RPOS(0) LNPAT3 = OPTB VARIABLE OPTB ('(' QPBAL ')' | NULL) OPTB RPOS(0) QPBALOR = QPBAL '.OR.' ENDINITIAL LNOT PROC (LEXP)LEFT,OPER,RIGHT,T1,T2 *** RETURNS NEGATED FTN LOGICAL EXPRESSION *** IF LEXP LNORPAT T1 = LNOT(LEFT) IF T1 QPBALOR T1 = '(' T1 ')' ENDIF T2 = LNOT(RIGHT) IF T2 QPBALOR T2 = '(' T2 ')' ENDIF LNOT = T1 '.AND.' T2 ELSEIF LEXP LNANDPAT LNOT = LNOT(LEFT) '.OR.' LNOT(RIGHT) ELSEIF LEXP LNNOTPAT ELSEIF LEXP LNPAT1 LOOP WHILE OPER BREAK(' ') . T1 SPAN(' ') = T1 ENDLOOP LNOT = LEFT OPPOSITE RIGHT ELSEIF LEXP LNPAT2 LNOT = LNOT(LEFT) ELSE IF LEXP LNPAT3 LNOT = '.NOT.' LEXP ELSE LNOT = '.NOT.(' LEXP ')' ENDIF ENDIF ENDPROC -STITL MISC PROCEDURES TYPE PROC (ST) STMTYPE = ST ENDPROC -SPACE 5 PUSH PROC (ELEM) *** THIS PROCEDURE INCREMENTS THE STACK LEVEL AND THEN *** PUTS ITS PARAMETER ONTO THIS NEW TOP OF THE STACK. LEVEL = LEVEL + 1 STACK = ELEM ENDPROC -SPACE 5 POP PROC () POP = STACK :F(FRETURN) LEVEL = LEVEL - 1 ENDPROC -SPACE 5 POPC PROC (MUSTBE) *** THE POPC PROCEDURE POPS THE TOP ELEMENT OFF THE STACK *** AND IN ADDITION CHECKS TO MAKE SURE THAT THE TY *** FIELD IS THE SAME AS THE PARAMETER 'MUSTBE'. IF NOT, *** POPC ATTEMPTS TO GENERATE THE MOST APPROPRIATE ERROR *** COMMENT AND LEAVE THE STACK POSITIONED CORRECTLY BY *** EXAMINING THE STACK ELEMENTS ADJACENT TO THE TOP. *** THE SITUATIONS ARE DESCRIBED BELOW WHERE AN 'X' *** STANDS FOR AN INCORRECT ELEMENT AND 'C' STANDS FOR A *** CORRECT ELEMENT. *** *** XXX - POP STACK AND GIVE ERROR *** XXC - DON'T POP STACK - EXTRA C *** CXX - POP STACK TWICE - MISSING X BEGINNING *** CXC - DON'T POP STACK - EITHER MISSING BEG X OR ? IF POPC = STACK *** THERE WAS SOMETHING THERE *** IF IDENT(TY(POPC),MUSTBE) *** EVERYTHING IS OK *** LEVEL = LEVEL - 1 :(RETURN) ELSE *** NOT VERY GOOD *** IF IDENT(TY(STACK),MUSTBE) *** PROBABLY AN EXTRA ENDER *** ERR("TOO MANY " MUSTBE "'S") ELSE *** LET'S SEE WHAT CAME BEFORE *** IF GT(LEVEL,1) IF IDENT(TY(STACK),MUSTBE) *** PROBABLY MISSING END FOR TOP *** ERR('MISSING END FOR ' STACK) LEVEL = LEVEL - 2 ELSE ERR('MISSING BEGINNING FOR ' MUSTBE) ENDIF ELSE ERR('MISSING BEGINNING FOR ' MUSTBE) ENDIF :(FRETURN) ENDIF ENDIF ELSE ERR('MISSING ' MUSTBE) :(FRETURN) ENDIF ENDPROC -STITL SORT * Program 13.2 HSORT, from Gimpel, Algorithms in SNOBOL4 * (modified by Fred Swartz to use SNOSTORM and to work on * arrays resulting from table conversion) * * HSORT(A,I,N) will sort the strings in array A, A * ..., A in ascending sequence. HSORT calls itself * recursively. * HSORT PROC (A,I,N)J,K,CRITERION * *** Entry point: If more than 2 items remain skip. *** If only one item is to be sorted, just return. IF IDENT(I,NULL) I = 1 ENDIF IF IDENT(N,NULL) PROTOTYPE(A) SPAN('0123456789') . N N = N + 0 ENDIF IF LE(N - I,1) GE(I,N) :S(RETURN) IF LGT(A,A) SWAP(I,N) ENDIF :(RETURN) ENDIF *** Obtain CRITERION to be used for partitioning array *** into two groups. CRITERION = A<(I + N) / 2,1> *** J will move through the array from the bottom looking *** for an element >= CRITERION. K will move through the *** array from the top looking for an element <= CRITERION J = I - 1 K = N + 1 HSORT_UP J = J + 1 LLE(CRITERION,A) :F(HSORT_UP) HSORT_DOWN K = K - 1 LLE(A,CRITERION) :F(HSORT_DOWN) *** If J is still < K, interchange and go back. IF LT(J,K) SWAP(J,K) :(HSORT_UP) ENDIF *** We are done partitioning the elements. K will serve *** as a convenient dividing line. Sorting will be *** accomplished by sorting the 2 subarrays. Might as *** well use HSORT to do this. HSORT(A,I,K) HSORT(A,K + 1,N) ENDPROC SWAP PROC (I,J)TEMP TEMP = A A = A A = TEMP TEMP = A A = A A = TEMP ENDPROC -STITL OUTPUT TEXT PROCEDURES PUTSTMT PROC (S)P *** PUTS OUT ONE STATEMENT INTO THE TARGET MODULE *** ISN = ISN + 1 GOTOPRECEDES = 'NO' IF DIFFER(PUTLABELS,'') *** PUT A LABEL ON THE TARGET STATEMENT *** P = RPAD(PUTLABELS,5,' ') FRONT S PUTLABELS = NULL ELSE *** NO LABEL *** P = ' ' FRONT S ENDIF PUTLINE(P) ENDPROC -SPACE 5 PUTFSTMT PROC ()SL1,LABEL,I *** THIS PROC PUTS ONE STATEMENT INTO THE TARGET *** MODULE. IT COPIES THE STATEMENT SOURCE FROM *** THE SOURCE ARRAY AFTER DETERMINING IF IT *** IS NECESSARY TO PUT OUT ANY LABELS ON OR *** BEFORE IT. IF IDENT(PSTCOM,'YES') OR IDENT(PARFND,'YES') *** DO THIS PROCESSING IF COMMENT IS APPENDED *** IF DIFFER(SOURCELABEL,' ') PUTLABEL(SOURCELABEL) ENDIF PUTSTMT(FSTMT) ELSE *** JUST LET THOSE STATEMENTS ZIP THROUGH *** ISN = ISN + 1 GOTOPRECEDES = 'NO' SL1 = SOURCE<1> IF DIFFER(PUTLABELS,'') *** THERE IS A LABEL WAITING TO GO OUT *** *** TRY TO PUT IT ON THIS STATEMENT *** IF IDENT(SOURCELABEL,' ') *** PUT PUTLABELS ON SOURCE *** IF SL1 LEN(5) = RPAD(PUTLABELS,5,' ') PUTLABELS = NULL ELSE ERR('Bad label field') ENDIF ELSE *** PUT THE SAVED LABEL OUT ON A CONTINUE *** DUMPLABEL() ENDIF ENDIF PUTLINE(SL1) I = 2 LOOP WHILE DIFFER(SOURCE,'') PUTLINE(SOURCE) I = I + 1 ENDLOOP ENDIF ENDPROC -SPACE 5 PUTLINE PROC (OL)Q *** WRITES ONE LINE INTO THE TARGET MODULE FILE *** IF GT(SIZE(OL),72) *** BREAK INTO CONTINUED LINES *** OL LEN(72) . Q = SWRITE('2',Q,OUTLN,2) OUTLN = OUTLN + 1 LOOP WHILE OL LEN(66) . Q = *** PUT OUT EACH LINE OF THE CONTINUATION *** SWRITE('2',' *' Q,OUTLN,2) OUTLN = OUTLN + 1 ENDLOOP IF DIFFER(OL,'') SWRITE('2',' *' OL,OUTLN,2) OUTLN = OUTLN + 1 ENDIF ELSE SWRITE('2',OL,OUTLN,2) OUTLN = OUTLN + 1 ENDIF ENDPROC EJECT INITIAL *** ??? WARNING - WILL NOT WORK FOR QUOTED BLANKS PUTIFPAT1 = OPTB (NOTANY(' ') ARB (NOTANY(' ') | NULL)) . COND OPTB RE PUTIFPAT2 = OPTB (NOTANY(' ') ARB (NOTANY(' ') | NULL)) . STMT OPTB RE PUTIFPAT3 = '(' MAXQPBAL . COND ')' RPOS(0) PUTIFPAT4 = OPTB '.NOT.' OPTB '(' QPBAL . COND ')' OPTB RPOS(0) PUTIFOR = QPBAL . X '.OR.' QPBAL . Y RPOS(0) PUTIFAND = QPBAL . X '.AND.' QPBAL . Y RPOS(0) ENDINITIAL PUTIF PROC (COND,STMT)X,Y,L *** PUTIF puts out an IF statement. It worries about ISN counting *** for Fortran H and G, and will break up a condition that is *** is too complicated for Fortran H to understand into multiple IFs. *** Remove leading and trailing blanks from the arguments COND PUTIFPAT1 STMT PUTIFPAT2 * * *** Change all double blanks to single blanks * * LOOP WHILE COND ARB . X ' ' = X ' ' * ENDLOOP * LOOP WHILE STMT ARB . X ' ' = X ' ' * ENDLOOP * *** Next remove leading and trailing parens. LOOP WHILE COND PUTIFPAT3 ENDLOOP *** See if COND is too complicated for Fortran H to understand IF NOT COND BADIF PUTSTMT('IF (' COND ') ' STMT) IF IDENT(COMPILER,'FTNH') ISN = ISN + 1 ENDIF *** Must break it up, make sure object is a GOTO statement ELSE IF NOT STMT GOTOPAT L = GENLABEL() PUTIF(LNOT(COND), 'GO TO ' L) PUTSTMT(STMT) PUTLABEL(L) *** Process .NOT. ( ... ) ELSEIF COND PUTIFPAT4 *** Push it thorough LNOT and see if it helps any X = LNOT(COND) IF X '.NOT.(' COND ')' RPOS(0) *** LNOT didn't understand it ????? PUTSTMT('IF (' X ') ' STMT) IF IDENT(COMPILER,'FTNH') ISN = ISN + 1 ENDIF ELSE *** LNOT made it better, recurse PUTIF(X,STMT) ENDIF *** Process top level .OR. ELSE IF COND PUTIFOR PUTIF(X,STMT) PUTIF(Y,STMT) *** Process top level .AND. ELSE IF COND PUTIFAND L = GENLABEL() PUTIF(LNOT(X), 'GO TO ' L) PUTIF(Y,STMT) PUTLABEL(L) *** If none of the above succeed, we have an OVERDRIVE error ELSE ERR('INVALID IF STATEMENT (OVERDRIVE ERROR):' + 'IF (' COND ')' STMT) ENDIF ENDPROC -STITL LABEL PROCEDURES ERASELABEL PROC () PUTLABELS = ENDPROC -SPACE 5 DUMPLABEL PROC ()L IF DIFFER(PUTLABELS,NULL) ISN = ISN + 1 PUTLINE(RPAD(PUTLABELS,5,' ') FRONT 'CONTINUE') PUTLABELS = NULL GOTOPRECEDES = 'NO' ENDIF ENDPROC -SPACE 5 GENLABEL PROC ()INT *** CREATES A LABEL *** IF IDENT(LABELTYPE,'LINE') *** GENERATE THE LABEL FROM THE INTEGER PORTION OF *** THE LAST SOURCE STATEMENT FILE LINE NUMBER *** BY PREFIXING THE INTEGRAL PORTION OF THE LINE *** NUMBER WITH LPFX. IF THE LINE NUMBER HAS ALREADY *** BEEN USED BEFORE (WE CAN TELL BY LOOKING AT *** MAXLABEL), THEN THE VALUE OF MAXLABEL+1 IS *** USED IN PLACE OF THE LINENUMBER. INT = SOURCELN<1> / 1000 IF GE(INT,9000) *** IF ANY LINE NUMBER EXCEEDS 9000, THEN *** OVERDRIVE WILL SHIFT INTO THE LABEL=NUMBER *** MODE FOR THE REMAINDER OF THE COMPILATION. LABELTYPE = 'NUMBER' :(GENLABEL2) ENDIF IF LE(INT,MAXLABEL) *** WE HAVE ALREADY BEEN HERE, USE MAXLABEL+1 MAXLABEL = MAXLABEL + 1 GENLABEL = LPFX MAXLABEL ELSE *** USE THE INTEGRAL PART OF THE LINE NUMBER *** GENLABEL = LPFX INT MAXLABEL = INT ENDIF ELSE *** GENERATE THE LABEL BY COUNTING LNUM DOWN *** GENLABEL2 LNUM = LNUM - 1 GENLABEL = LNUM ENDIF ENDPROC -SPACE 5 PUTLABEL PROC (LABE) *** RECORDS ONE LABEL FOR THE NEXT TARGET STATEMENT *** *** IF THERE IS ALREADY A LABEL WAITING TO GO OUT, *** *** IT PUTS OUT THE OLDEST LABEL ON A CONTINUE STMT *** IDENT(LABE,'') :S(RETURN) IF LABE LPFX *** ANY LABEL BEGINNING WITH LPFX IS ASSUMED TO BE *** A GENERATED LABEL TO BE PRINTED IN THE LISTING IF IDENT(INTLABELS,NULL) *** RECORD THE FIRST ONE *** INTLABELS = LABE ELSEIF NOT INTLABELS BREAK('+') *** PUT A '+' ON THE END IF THERE IS MORE THAN 1 INTLABELS = INTLABELS '+' ENDIF ENDIF IF DIFFER(PUTLABELS,NULL) *** PUT OUT THE PREVIOUS LABEL FIRST *** DUMPLABEL() ENDIF PUTLABELS = LABE GOTOPRECEDES = 'NO' ENDPROC -STITL INPUT PROCEDURES GETLINE PROC (L,LN,INTLN)FR,BK,SIGN *** GET NEXT LINE FROM SOURCE FILE *** IF TRIM(SREAD('SCARDS')) ('-' | '') . SIGN BREAK('#') . $INTLN '#' REM . $L IF IDENT($L,NULL) *** MAKE NULL LINE INTO ONE BLANK $L = ' ' ENDIF IF LT(SIZE($INTLN),3) *** THERE IS ONLY A FRACTIONAL LINE NUMBER *** FR = SIGN BK = LPAD($INTLN,3,'0') ELSE *** BOTH AN INTEGER AND FRACTIONAL PART *** $INTLN RTAB(3) . FR REM . BK IF DIFFER(SIGN,NULL) FR = SIGN FR ENDIF ENDIF IF BK ARB . BK SPAN('0') RPOS(0) ENDIF $LN = LPAD(FR,7) '.' RPAD(BK,4) ELSE EOF = 'YES' :(FRETURN) ENDIF ENDPROC -SPACE 5 GETSTMT PROC ()SL *** GET ONE STATEMENT FROM THE SOURCE FILE *** IF IDENT(STMT2,'') *** NO STATEMENT IS WAITING IN THE BUFFER *** GETLINE(.STMT,.FILELINE,.INTERNAL) :F(FRETURN) IF LT(OUTLN,INTERNAL) OUTLN = INTERNAL ELSE OUTLN = OUTLN + 1 ENDIF SOURCE<1> = STMT SOURCELN<1> = INTERNAL SOURCEOLN<1> = FILELINE ELSE *** USE THE STATEMENT WAITING IN THE BUFFER *** STMT = STMT2 SOURCE<1> = STMT2 SOURCELN<1> = INTERNAL2 SOURCEOLN<1> = FILELINE2 FILELINE = FILELINE2 IF LT(OUTLN,INTERNAL2) OUTLN = INTERNAL2 ELSE OUTLN = OUTLN + 1 ENDIF STMT2 = '' ENDIF SL = 2 IF GETLINE(.STMT2,.FILELINE2,.INTERNAL2) LOOP WHILE STMT2 ' ' NOTANY(' ') *** KEEP LOOKING FOR CONTINUATION LINES *** IF LE(SL,20) SOURCE = STMT2 SOURCELN = INTERNAL2 SOURCEOLN = FILELINE2 STMT = STMT SUBSTR(STMT2,7,SIZE(STMT2) - 6) SL = SL + 1 ELSE ERR('More than 19 continuation lines') ENDIF GETLINE(.STMT2,.FILELINE2,.INTERNAL2) :F(FRETURN) ENDLOOP SOURCE = '' ELSE EOF = 'YES' ENDIF COMCHECK() GETSTMT = STMT ENDPROC -SPACE 4 INITIAL FIND_SEMI = (LEN(6) SKIP_TO_SEMI) . S ';' REM . C ENDINITIAL COMCHECK PROC ()S,C,CC PSTCOM = 'NO' IF NOT S 'C' | '*' | SPAN(' ') '*' *** Not a comment *** IF STMT FIND_SEMI *** Everything after the ;* is a comment unless *** the whole statement is a comment or it is *** between quotes. IF C '*' *** It's only a comment if it's followed by * STMT = TRIM(S) IF DIFFER(S,NULL) *** Let all blanks go on through PSTCOM = 'YES' IF IDENT(COPYCOM,'YES') *** Put out the appended comment *** LOOP WHILE C (LEN(71) | LEN(1) REM) . CC = PUTLINE('C' CC) ENDLOOP ENDIF ENDIF ELSE ERR('Lone semicolon. Remainder of line ignored') STMT = TRIM(S) PSTCOM = 'YES' ENDIF ENDIF ENDIF ENDPROC -SPACE 4 FLUSH PROC () ERR('*** UNCLOSED OVERDRIVE STRUCTURES:') LOOP WHILE TOP = POP() ERR(' ' TY(TOP) ' BEGINNING AT ' BEG(TOP)) ENDLOOP :(RETURN) ENDPROC TABCON PROC (TXT) *** THIS PROCEDURE ADDS THE ENTRY 'TXT' TO THE *** TABLE OF CONTENTS ARRAY, ALONG WITH THE CURRENT *** PAGE NUMBER. CONTNT = ' ' FILELINE ' ' TXT NXTCON = NXTCON + 1 ENDPROC WARN PROC (MESSAGE) *** SAVE UP WARNING MESSAGES TO BE PRINTED AT END *** IF LT(WARNNO,50) WARNNO = WARNNO + 1 WARNING = SOURCEOLN<1> ' *** ' MESSAGE ENDIF ENDPROC CLEANLINE PROCEDURE (L)P1 *** Takes blanks and trailing '.' from MTS linenumber LOOP WHILE L BREAK(' ') . P1 SPAN(' ') = P1 ENDLOOP IF L BREAKX('.') . L '.' RPOS(0) ENDIF CLEANLINE = L ENDPROCEDURE END