PROGRAM RATFOR # ****************** # * FILE=RATRT.RAT * # ****************** # #====================== RT11-DEC VERSION OF RATFOR ======================== # # THIS FILE CONTAINS THE COMPUTER/SYSTEM SPECIFIC PARTS OF RATFOR # # This is the "driver" module for RATFOR for RT-11 V3B or later. This # version of RATFOR was derived from RATFOR-11 Version 20 (PCN# 94) which # was implemented by David Sykes (see below) for RSX-11M. # # The RT-11 CSI provides virtually the same services as the "ICSI.RAT" # module used with the RSX version. The switches are only one character # long instead of two and negation of switches is not supported. # There is no print spooler. So the switches have changed from the RSX # version: # # /C - Compress FORTRAN output by dropping blanks # /D{:n} - Process debug lines to level "n". # If ":n" not given, n defaults to 1. # /H - Display switch information at user's terminal # /L:FOR - Include generated FORTRAN code on RATFOR listing. # /L:DEF - Include symbolic constant table in RATFOR listing. # /L:LC - Output generated FORTRAN code in lower case. # /L:CND - Include code within unsatisfied IFDEF's in listing. # /R - Retain define table from previous command line. # # The "/GO" switch of the RSX-11 version has been replaced by two new # switches (/F and /X) which take advantage of the RT-11 # DEC Command Language System (DCLS): # # /F - Pass RT-11 a "FORTRAN filename" command line, so # that the FORTRAN compiler will automatically # process RATFOR's generated code. The "filename" # is the same as the first filename in the RATFOR # command line. # /X - Pass RT-11 a "EXECUTE/FORTRAN filename" command # line. This causes a complete compile,link and # run sequence to follow RATFOR's completion. The # "filename" is derived as in the /F switch. In # RATDEF.RT, there is a DEFINE which defines # a filespec for the /LINKLIBRARY switch. It is # currently defined as SY:FOROTS.OBJ. # # In the interest of cleanliness, the old style "CALL ASSIGN" I/O has # been deleted. All file hookups use the "OPEN" statements. This means # that this version will run under FORTRAN-11/RT-11 Version 2 or later, # but not under old Version 1C. # # Wherever possible, the original RATRSX.RAT code has been left alone. # The new RT-11 code is not identified explicitly. # # RATFOR-11/RSX Version 20 courtesy: # # David P. Sykes # American Management Systems, Inc. # 1515 Wilson Blvd. # Arlington Va. 22209 # (703) 841-6086 # # RT-11 Conversion: # # Robert B. Denny # Creative System Design Co. # 3452 E. Foothill Blvd. Suite 601 # Pasadena, Ca. 91107 # (213) 355-6836 # # Experimental Version X20.0 13-Mar-80 Initial version # Experimental Version X20.1 18-Mar-80 Many fixes throughout # Experimental Version X20.2 21-Mar-80 I'm getting there... # Experimental Version X20.3 22-Mar-80 Fix handling, it runs. # Prototype Version Y20.4 25-Mar-80 Audit cleanup. For Spring 80 # DECUS. "V" revision when we # get field test results. # # #========================================================================== # # INCLUDE/NL DEFIN INCLUDE RATDEF.RAT #RT-11 VERSION RATFOR DEFINITIONS # ****************************** # * R A T F O R / R T - 1 1 * # ****************************** # # MAIN PROGRAM: # # CONTAINS CODE TO HANDLE USER/OS INTERFACE, GETTING THE COMMAND LINE, # PARSING THE COMMAND LINE, ACTING ON "IMMEDIATE" SWITCHES, FILE # HANDLING, ETC. # # Robert B. Denny # Creative System Design Co. # 3452 E. Foothill Blvd. Suite 601 # Pasadena, Ca. 91107 # (213) 355-6836 # # Prototype Version Y20.4 25-Mar-80 Audit cleanup. For Spring 80 # DECUS. "V" revision when we # get field test results. # # INTEGER DOIT #FLAGS WHETHER TO CLEAR THE DEFINE TABLE INTEGER ERR #RETURNS ERRORS FROM STRLIB CALLS INTEGER BADOPT #INDICATES IF BAD /L:XXX OPTION WAS GIVEN CHARACTER PROMPT(6) #HOLDS PROMPT STRING FOR GETLIN CHARACTER FTNFIL(16) #HOLDS F4 OUTFILE NAME FOR /F AND /X # INCLUDE CFILES.RT #REQUIRES 'NSWT' AND 'NLOP' BE 'DEFINE'D # INCLUDE CLIST # INCLUDE CUCLC # STRING REF " RATFOR ERRORS FOUND" DATA DEFEXT / 3RRAT, 3RFOR, 3RLST, 0 / # DEFAULT EXT'S. DATA LSTOPT / 3RCND, 3RDEF, 3RFOR, 2RLC / #LEGAL /L:xxx options DATA PROMPT / "R", "A", "T", ">", " ", 128 / #PROMPT ... "RAT> " NO CR/LF # # SWITCH DATA INITIALIZATION # DATA SWITCH(1,1) /"C"/ #COMPRESS FORTRAN OUTPUT DATA SWITCH(1,2) /"D"/ #PROCESS DEBUG LINES DATA SWITCH(1,3) /"F"/ #CHAIN TO FORTRAN COMPILER DATA SWITCH(1,4) /"H"/ #HELP!! DATA SWITCH(1,5) /"L"/ #LISTING CONTROLS DATA SWITCH(1,6) /"L"/ DATA SWITCH(1,7) /"L"/ DATA SWITCH(1,8) /"L"/ DATA SWITCH(1,9) /"R"/ #RETAIN DEFINE TABLE DATA SWITCH(1,10) /"X"/ #CHAIN TO 'EXEC/FORT' DCLS CMD # FOR COMPILE-LINK-GO # #========================================================================== # # *** START *** # CALL PRINT(VNUMBER) #ANNOUNCE VERSION # # THIS PROGRAM RUNS UNTIL ^C OR FATAL ERROR, SO... REPEAT [ CLB(1) = EOS CALL HEADR # # GET THE COMMAND LINE, DO IMMEDIATE SWITCHES # BADOPT = NO #RESET BAD OPTION FLAG DO I=1,39 #CLEAR OUT 'SPEC' ARRAY SPEC(I) = 0 CALL RCTRLO #RESET ^O SUPRESSION CALL PRINT(' ') CALL GTLIN(CLB,PROMPT) #PICK UP THE COMMAND LINE I = ICSI(SPEC, DEFEXT, CLB, SWITCH, NSWT) #PARSE COMMAND LINE GO TO (10,11,12,13), I+1 #HANDLE ERROR CASES # 10 IF (SWITCH(2,4) > 0) #IF /H TYPED... [ CALL RATHLP #...CALL HELPER. NEXT #...AND PROMPT AGAIN ] # IF (SPEC(1) == 0 & SPEC(6) == 0) #IF NULL EFFORT... NEXT #...ACT LIKE WE'RE DONE! # #-------------------- DO NORMAL SWITCHES -------------------- # # ** LIST OPTIONS DEFAULT TO 'NO' ** IFPNT = NO # NO UNSAT. CONDITIONALS LC = NO # DO NOT CONVERT TO LOWER CASE F4CODE = NO # NO GENERATED F4 CODE DEFTAB = NO # NO SYMB. CONST. DEFINE TAB. # # GET UP TO 4 /L:xxx SWITCHES. ABORT CLI INTERPRETATION IF ILLEGAL OPT. # FOR ( I=5; SWITCH(2,I) > 0 & I <= 8 & BADOPT == NO ; INCREMENT(I)) [ IF (SWITCH(4,I) == LSTOPT(1)) # /L:CND [ IFPNT = YES NEXT ] IF (SWITCH(4,I) == LSTOPT(2)) # /L:DEF [ DEFTAB = YES NEXT ] IF (SWITCH(4,I) == LSTOPT(3)) # /L:FOR [ F4CODE = YES NEXT ] IF (SWITCH(4,I) == LSTOPT(4)) # /L:LC [ LC = YES NEXT ] ELSE ### BAD LIST OPTION ### BADOPT = YES ] #END OF /L:xxx 'FOR' STATEMENT# # IF (BADOPT == YES) # IF BAD LIST OPTION [ CALL PRINT('Bad /L:xxx option, try again') NEXT ] # # IF (SWITCH(2,1) > 0) # /C COMPRS = YES ELSE COMPRS = NO # IF (SWITCH(2,2) <= 0) # /D{:n} Default n=1 DEBUG = 9999 # = NO DEBUG LINES ELSE IF (SWITCH(2,2) == 2) # NUMERIC ARG GIVEN? DEBUG = SWITCH(4,2) # IF SO, USE IT ELSE DEBUG = 1 # ELSE DEFAULT D TO 1 # IF (SWITCH(2,9) > 0) # /R DOIT = NO # FOUND, SUPRESS CLEARING DEFINITIONS ELSE DOIT = YES # CLEAR DEFINITIONS OTHERWISE # # ** OTHER SWITCHES (/F, /X) CHECKED PRIOR TO TRYING NEXT CMD LINE ** # # #---------------------OPEN FORTRAN OUTPUT FILE---------------------- # # IF (SPEC(1) != 0) [ CALL FSCONV(1) #CONV. RAD50 SPEC TO ASCII. CALL SCOPY(FSPEC, FTNFIL, 16, ERR) #COPY FOR LATER CHAIN VIA RT-11 OPEN (UNIT=STDOUT, NAME=FSPEC, TYPE='NEW', INITIALSIZE=SPEC(5), ERR=20) OUTPUT = YES #OPENED OK, TURN ON OUTPUT FLAG. ] ELSE IF (F4CODE == YES & SPEC(6) != 0) #IF /L:FOR AND LISTFILE GIVEN [ OPEN (UNIT=STDOUT, NAME='RATSCR.DAT', TYPE='SCRATCH', ERR=21) OUTPUT = YES #USE THIS TO LIST FORTRAN OUTPUT ] ELSE OUTPUT = NO #NO OUTPUT FILE GIVEN, NO /L:FOR. # # #------------------------OPEN LISTING FILE-------------------------- # # IF (SPEC(6) != 0) [ CALL FSCONV(6) #CONV. RAD50 SPEC TO ASCII. OPEN (UNIT=LISTOUT, NAME=FSPEC, TYPE='NEW', INITIALSIZE=SPEC(10), CARRIAGECONTROL='LIST', ERR=22) LST(1) = YES #OPENED OK, TURN ON LIST FLAG. ] ELSE LST(1) = NO #NO LISTING FILE GIVEN # # #--------------------PROCESS ALL INPUT FILES------------------------ # # CALL RATGO (DOIT) #OK, INITIALIZE THE PROCESSOR FOR (J=16; SPEC(J) != 0 & J <= 36; J=J+4) #FOR EACH FILE GIVEN... [ CALL FSCONV(J) #CONV. RAD50 SPEC TO ASCII. OPEN (UNIT=STDIN, NAME=FSPEC, TYPE='OLD', ERR=23) CALL PARSE #OK, GO FOR IT!!!! CLOSE( UNIT=STDIN ) #DONE WITH THIS INPUT FILE... NEXT #TRY FOR ANOTHER INPUT FILE # 23 CALL PRINT('Open failure on input file') #OOPS, ERROR.. CALL PRINT(FSPEC) BREAK #BAIL OUT OF INPUT FILE LOOP. ] # # #----------------FINISH UP FOR THIS COMMAND LINE-------------------- # # IF (DEFTAB == YES) CALL DEFLST IF (F4CODE == YES) CALL DUMPIT IF (LST(1) == YES) CLOSE ( UNIT = LISTOUT ) # IF (ERRORS > 0) [ CALL RCTRLO #FORCE THIS TO BE SEEN CALL SITOC ( ERRORS, REF(1), 5 ) #INSERT ASCII ERROR COUNT CALL PRINT ( REF ) #PRINT "xxx RATFOR ERRORS" CLOSE ( UNIT=STDOUT, DISP='DELETE', ERR=30 ) #FORGET FORTRAN FILE 30 CONTINUE #SUPRESS ERRORS HERE ] ELSE #NO ERROR, CLEAN UP NICELY [ CLOSE ( UNIT=STDOUT, ERR=31 ) #CLOSE FORTRAN FILE 31 CONTINUE #WITHOUT ERROR MSGS ] # # #---------------CHAIN TO FORTRAN OR FORTRAN/LINK/GO----------------- # # IF (SWITCH(2,3) != 0 & OUTPUT == YES) # /F SW. GIVEN & OUTFILE REQUESTED [ CALL SCOPY('FORTRAN/NOSWAP ',SPEC,81,ERR) #USE "SPEC" ARRAY TO SET RT-11 CMD. CALL SJOIN(SPEC,FTNFIL,SPEC,81,ERR) #ADD FORTRAN FILE NAME CALL SETCMD(SPEC) CALL EXIT #AND EXIT TO RT-11 ] # IF (SWITCH(2,10) != 0 & OUTPUT == YES) # /X SW. GIVEN $ OUTFILE REQUESTED [ CALL SCOPY('EXEC/FORT/NOSWAP/LINK:',SPEC,81,ERR) #START OF COMMAND LINE CALL SJOIN(SPEC,LINKLIBRARY,81,ERR) #ADD USER'S DEFAULT LINKLIB. CALL SJOIN(SPEC,' ',81,ERR) #SPACE CALL SJOIN(SPEC,FTNFIL) #AND THE FORTRAN FILE NAME. CALL SETCMD(SPEC) #GIVE COMMAND LINE TO RT-11 CALL EXIT #EXIT TO RT-11 ] # #=======================REPEAT FOR NEW COMMAND LINE=========================== # NEXT # #============================================================================= # # ERRORS COME HERE BEFORE LOOPING # 11 CALL PRINT('Syntax error, try again.') #ILLEGAL COMMAND LINE NEXT 12 CALL PRINT('Unknown device, try again.') #ILLEGAL DEVICE SPEC. NEXT 13 CALL PRINT('Option error, try again.') #UNKNOWN OR TOO MANY OPTIONS NEXT 20 CALL PRINT('Open failure on FORTRAN output file') NEXT 21 CALL PRINT('Open failure on scratch file, unit DK:') NEXT 22 CALL PRINT('Open failure on list file') NEXT ] # END SUBROUTINE FSCONV(I) # # FSCONV -- CONVERT RAD50 FILESPECS FROM ICSI TO ASCII STRING FOR FORTRAN # # CALL: # CALL FSCONV(I) # # INPUTS: # I = ELEMENT IN "SPECS" USED BY ICSI OF START OF RAD50 SPEC. # # OUTPUTS: # ASCII FILESPEC STRING IN COMMON CHARACTER ARRAY "FSPEC" # # COMMONS: # FILES -- HAS ARRAYS AND SWITCHES FOR FILES. # # SUBROUTINES USED: # R50ASC (SYSF4) # # Robert B. Denny # Creative System Design Co. # 3452 E. Foothill Blvd. Suite 601 # Pasadena, Ca. 91107 # (213) 355-6836 # # Prototype Version Y20.4 25-Mar-80 Audit cleanup. For Spring 80 # DECUS. "V" revision when we # get field test results. #------------------------------------------------------------ # # INCLUDE CFILES.RT # DO J=1,16 #BLANK OUT FILESPEC STRING FSPEC(J) = " " CALL R50ASC(3, SPEC(I), FSPEC(1)) #DEVICE --> ASCII DO J = 4,2,-1 #BACK UP J OVER BLANKS IF ( FSPEC(J-1) != " ") BREAK FSPEC(J) = ":" #FOLLOW WITH COLON CALL R50ASC(6, SPEC(I+1), FSPEC(J+1)) #FILENAME K = J+7 #K --> LAST CHR IN FILENAME DO J = K,4,-1 #BACK J UP TILL IT POINTS... IF ( FSPEC(J-1) != " ") #...TO FIRST ' ' IN FILENAME BREAK FSPEC(J) = "." #PERIOD CALL R50ASC(3, SPEC(I+3), FSPEC(J+1)) #EXTENSION FSPEC(J+4) = 0 #STRING TERMINATOR # RETURN END SUBROUTINE DUMPIT # # DUMPIT - TO LIST GENERATED FORTRAN SOURCE CODE ON PRINTER # # INTEGER FLINE, ERR CHARACTER FF(2) LOGICAL*1 LERR # INCLUDE CPRTLN # DATA FF /FORMFEED, EOS/ # REWIND STDOUT CALL RATLST (FF, 0, 0) #FORCE ADVANCE PAGE FLINE=0 REPEAT [ CALL GETSTR(STDOUT, PRTBUF, MAXCARD, LERR) #GET THE FORTRAN LINE IF(LERR != 0) [ IF(LERR == -1) BREAK #IF EOF, WE'RE DONE. ELSE CALL ERROR("Error reading .FOR file for listing") #ELSE HARD ERR. ] ELSE [ IF(PRTBUF(1) == FORMFEED) FLINE=0 IF(PRTBUF(1) == BIGC \ PRTBUF(6) == CONTINCHAR \ PRTBUF(1) == FORMFEED) CALL RATLST(PRTBUF, 0, 0) #DON'T NUMBER COMM., CONT. ELSE [ INCREMENT(FLINE) CALL RATLST(PRTBUF, 0, FLINE) #PRINT THE LINE. IF((PRTBUF(7) == BIGI & PRTBUF(8) == BIGF & PRTBUF(9) == BLANK) \ (PRTBUF(7) == LETI & PRTBUF(8) == LETF & PRTBUF(9) == BLANK)) INCREMENT(FLINE) #ADJUST FORTRAN LINE NUMBER ] ] ] # RETURN END INTEGER FUNCTION GETLIN (BUFR) # # GETLIN - TO READ IN ANOTHER LINE FROM THE INPUT FILE FOR NGETCH ## IF LINE BEGINS WITH A '%' IN COL. 1, TRANSFER IT TO THE ## OUTPUT FILE WITH NO PROCESSING AT ALL EXCEPT DELETE THE '%'. ## ALSO, TRANSFER FULL LINE COMMENTS ('#' IN COL 1) TO OUTPUT FILE ## ALSO, LIST EACH LINE AS IT IS READ.EXCEPT WITHIN UNDEFINED IFDEFS ## IF THE /N:CND SWITCH IS PRESENT. # INTERPRET DEBUG LINES ("?" IN COL 1) AS WELL. PROCESS THEM IF # THE LEVEL SPECIFIED IN THE SECOND COL IS >= SPECIFIED DEBUG LEVEL. # # ----REVISION #1---- # FIX HANDLING OF FORMFEEDS. REMOVE FROM THE INPUT BUFFER AND FORCE # NEW PAGE IN LISTING. # R. B. DENNY # 22-MAR-80 # MAKES RATFOR/RT VERSION 20.3 # ------------------- # INTEGER I, ERR, SLEN CHARACTER BUFR(MAXLINE) LOGICAL*1 LERR # INCLUDE CLINE # INCLUDE CPRTLN # INCLUDE CLIST # INCLUDE CUCLC # STRING DLEVL "123456789 " #DEBUG LEVELS # GETLIN=YES REPEAT [ CALL PRTLIN #PRINT LAST LINE BEFORE READING NEXT CALL GETSTR(INFILE(LEVEL), BUFR, MAXCARD, LERR) #READ NEXT INPUT LINE IF (LERR != 0) [ IF (LERR == -1) RETURN (EOF) ELSE CALL ERROR ("Error reading input file.") ] ELSE #READ OK [ CALL STRIM (BUFR) #TRIM ANY TRAILING BLANKS # ## SPECIAL HANDLING OF RATFOR PROCESSOR FEATURES # I = INDEX (BUFR, FORMFEED) ##----REV #1---- IF (I > 0) ##IF THERE'S A IN THERE [ PLINE = 9999 ##FORCE NEW PAGE J = SLEN(BUFR) ##FIND THE LINE LENGTH IF (J == 1) ##IF THAT'S ALL ON THIS LINE [ ##THEN... READY = NO ##...SUPRESS PRINTING IT... NEXT ##...AND GO GET THE NEXT LINE ] IF (I == J) ##IF IS AT END OF LINE BUFR(I) = EOS ##JUST WIPE IT OUT. ELSE ##OTHERWISE, REMOVE THE [ DO K=I,J-1 ##BY SHIFTING LINE LEFT 1 BUFR(K) = BUFR(K+1) BUFR(J) = EOS ##AND RE-TERMINATING STRING ] ] ##-------------- # CALL SCOPY (BUFR, PRTBUF, MAXCARD ,ERR) #SAVE THIS LINE FOR LATER... READY = YES #...PRINTING. # IF (BUFR(1) == QMARK) IF (INDEX(DLEVL, BUFR(2)) >= DEBUG) #CHECK DEBUG LEVEL OF THIS LINE [ BUFR(1) = BLANK #PROCESS THIS DEBUG LINE BUFR(2) = BLANK #BLANKING OUT THE "?N" FIRST ] ELSE NEXT #SKIP THIS DEBUG LINE # IF (BUFR(1) != PERCENT & BUFR(1) != SHARP) BREAK #** NORMAL GOOD LINE ** # IF (INIF == YES) NEXT #SKIP COMM'S & % LINES IN IFDEFS ELSE IF (BUFR(1) == PERCENT) [ CALL PUTLIN (BUFR(2), STDOUT, NO) #OUTPUT % LINE AS IS INCREMENT (FTNLN) #BUMP FORTRAN LINE # ] ELSE IF (COMPRS == NO) #IF NOT IN "COMPRESS" MODE... [ BUFR(1) = BIGC #...PASS COMMENTS TO FORTRAN CALL PUTLIN (BUFR, STDOUT, NO) ] ] ] #REPEAT, GET ANOTHER LINE. # RETURN END SUBROUTINE GETNAM (BUFR, LSTIT) # # GETNAM - GET THE FILE NAME OF AN INCLUDED FILE. # INCLUDE/NL FILE AND INCLUDE FILE/NL BOTH OK, BUT 2ND WON'T BE LISTED RIGHT. # # LEFT ALONE FROM THE RSX VERSION # # INTEGER LSTIT, LEN, SKIP CHARACTER NGETCH, CHAR, BUFR(MAXNAME) # LEN=0 SKIP=NO LSTIT=YES # #SINCE THE STRING MAY CONTAIN SEVERAL TOKENS # AND EVEN SEMICOLONS, FORCE READ THE REST OF THIS LINE AND # TAKE IT TO BE THE FILE NAME SPEC. # WHILE (NGETCH(CHAR) != NEWLINE & CHAR != SHARP & LEN < MAXNAME) [ IF (SKIP == YES & CHAR == BLANK) SKIP=NO #GOT PAST THE SWITCH,RETURN TO NORMAL ELSE IF (CHAR == SLASH) [ #FOUND /NL? SKIP=YES #YES, WE MUST SKIP THE SWITCH NAME LSTIT=NO #WE WON'T PRINT THIS FILE ] ELSE IF (CHAR != BLANK & CHAR != TAB & SKIP == NO) [ INCREMENT(LEN) BUFR(LEN)=CHAR ] ] #GET THE REST OF THE LINE (EXCEPT COMMENTS) AS THE NAME CALL PUTBAK(CHAR) #WE DON'T WANT THE TERMINATOR # BUFR(LEN+1)=EOS # RETURN END SUBROUTINE HEADR # # HEADR - TO FILL IN DAY,DATE,TIME FOR RATLST'S PAGE HEADER. # # REMOVED DAY OF WEEK CODE FOR RT-11 # # INCLUDE CDATIM # DATA DATIM / 25*" "/ # CALL DATE (DATIM(6)) CALL TIME (DATIM(17)) DATIM(25)=EOS #MAKE IT A STRING # RETURN END SUBROUTINE OPENI # # OPENI - TO OPEN INCLUDED FILES FOR RATFOR. # # THE LUN FOR EACH INPUT FILE IS STORED IN INFILE(LEVEL),WHERE # LEVEL IS THE INCLUSION LEVEL (BASIC INPUT FILE=1). # CURRENTLY, THE LUN=THE INCLUSION LEVEL; INFILE(LEVEL)=LEVEL. # IF THE INCLUDE FILE ISN'T FOUND AND THERE WAS NO DEVICE SPECIFIED # (I.E., "DK:" DEFAULT), ANOTHER ATTEMPT IS MADE WITH "SY:" AS THE # DEVICE. THIS ALLOWS COMMON INCLUDES TO BE KEPT ON SY: # CHARACTER BUFR(MAXNAME), BUF2(MAXNAME) INTEGER I, IERR # INCLUDE CLINE # INCLUDE CLIST # STRING RAT ".RAT" #DEFAULT EXTENSION # IF (LEVEL >= NFILES) CALL ERROR ("INCLUDE's too deeply nested.") #RAN OUT OF RT-11 CHANNELS # CALL GETNAM (BUFR, LSTIT) #GET THE FILE NAME AND LIST STATUS INCREMENT (LEVEL) #BUMP INCLUDE LEVEL INFILE(LEVEL)=LEVEL #STORE LUN FOR THIS LEVEL LST(LEVEL)=LSTIT #RECORD LISTING STATUS FOR NEW FILE # IF (INDEX(BUFR, PERIOD) == 0) #ADD AN EXTENSION IF NONE THERE CALL SJOIN(BUFR, RAT, MAXNAME-1, IERR) # CALL ERRSNS OPEN(UNIT=INFILE(LEVEL), NAME=BUFR, READONLY, TYPE='OLD', ERR=11) RETURN #ALL OK # 11 CALL ERRSNS(IERR) IF (IERR == 28 & INDEX(BUFR,COLON) == 0) #IF NOT FOUND AND NO DEV: GIVEN [ BUF2(1) = EOS #ADD "SY:" IN FRONT CALL SINSRT(DEFAULTOPEN, BUF2) CALL SJOIN (BUF2, BUFR, MAXNAME-1, IERR) CALL ERRSNS OPEN(UNIT=INFILE(LEVEL), NAME=BUF2, READONLY, TYPE='OLD', ERR=12) RETURN #THAT ONE DID IT ] # # IF WE GOT THIS FAR, ALL EFFORTS TO OPEN FILE FAILED 12 CALL ERROR ("Open failure on INCLUDE file") RETURN # END SUBROUTINE PRTLIN # # PRTLIN - PRINT A LINE OF SOURCE ON THE RATFOR LISTING # # IF LISTING (BOTH IN GENERAL AND AT THIS PARTICULAR TIME), FIGURE OUT IF # THIS LINE (WHICH IS THE ONE JUST PROCESSED, ONE BEHIND THE ONE JUST READ) # NEEDS RATFOR LINE NUMBER, FTN LINE NUMBER, BOTH, OR NEITHER. CALL RATLST # TO PRINT THE LINE WITH THE CORRECT NUMBER(S). ALSO CONVERT COMMENTS TO # LOWER CASE, IF NEEDED. ALSO KEEP FTN LINE NUMBERS STRAIGHT (NO SMALL PROBLEM). # ARRANGE TO ALWAYS PRINT IFDEF,IFNOTDEF,ENDIF LINES WITH RATFOR NUMBERS, # TO LIST PROPERLY, THESE MUST BE IN UPPER CASE. # NOTE THAT DUMPIT AND DEFLST ALSO USE PRTBUF TO SAVE SPACE. # # INTEGER EQLS, I, FUDGE, KLUGE, FORCIF, IT # INCLUDE CLINE # INCLUDE CPRTLN # INCLUDE CLIST # INCLUDE CUCLC # STRING DLEVL "123456789 " #DEBUG LEVELS STRING INCLU "INCLUDE" #KEYWORDS STRING ENDIF "ENDIFDEF" STRING IFDEFS "IFDEF" STRING IFNOT "IFNOTDEF" STRING DEFI "DEFINE" STRING MACR "MACRO" # IF (LST(1) == YES & READY == YES) #ARE WE EVEN DOING A LISTING? [ FOR (IT=1; PRTBUF(IT) == BLANK \ PRTBUF(IT) == TAB; INCREMENT(IT)) ; #SKIP LEADING BLANKS AND TABS IF ((EQLS(PRTBUF(IT),IFDEFS) == YES) \ (EQLS(PRTBUF(IT),IFNOT) == YES)) FORCIF=YES #WHAT'S FIRST THING ON THIS LINE? ELSE #MUST FORCE LISTING OF 'IFDEF'&'IFNOTDEF' FORCIF=NO # IF (INIF == NO \ IFPNT == YES \ FORCIF == YES) #DO WE WANT TO PRINT? [ IF (LC == YES) [ I=INDEX (PRTBUF, SHARP) #IS THERE COMMENT ON THIS LINE? IF (I > 0) CALL FOLD (PRTBUF(I+1)) #CONVERT COMMENT TO LOWER CASE ] # # DON'T NUMBER UNPROCESSED LINES # IF ((PRTBUF(1) == SHARP) \ (INIF == YES & FORCIF == NO) \ (PRTBUF(1) == QMARK & INDEX(DLEVL,PRTBUF(2)) < DEBUG)) CALL RATLST(PRTBUF, 0, 0) # # RATFOR LINE NUMBER ONLY ON UNPROCESSED LINES AND PROCESSOR FEATURES # ELSE IF ((EQLS(PRTBUF(IT),ENDIF) == YES) \ (EQLS(PRTBUF(IT),MACR) == YES) \ (EQLS(PRTBUF(IT),DEFI) == YES) \ (EQLS(PRTBUF(IT),INCLU) == YES) \ FORCIF == YES) [ IF ((LEVEL > 1) & (PRTBUF(IT+7) == SLASH) & (EQLS(PRTBUF(IT),INCLU) == YES)) [ KLUGE=YES #INCLUDE/NL?, IF SO, LST(LEVEL)=YES #FORCE RATLST TO PRINT IT ] ELSE KLUGE=NO CALL RATLST (PRTBUF, LINECT, 0) #RAT #, NO FTN # INCREMENT (LINECT) IF (KLUGE == YES) #WE FAKED RATLST, NOW LST(LEVEL)=NO #RESET INCLUDED LEVEL TO NO LIST ] # # RATFOR AND FORTRAN NUMBERS ON LINES THAT GENERATED CODE # ELSE [ IF (FORTYP == YES) #THIS LINE IS 'FOR' WITH INIT CLAUSE? FUDGE=1 #YES, BACK OFF AN EXTRA LINE NUMBER ELSE #(ALSO FOR 'UNTIL') FUDGE=0 CALL RATLST (PRTBUF, LINECT, FTNLN-FUDGE) INCREMENT (LINECT) #IF'S USE 2 FTN LINE NUMBERS IF (IFTYP == YES) #NUMBER ON 'IF'S INCREMENT (FTNLN) #FOR THE 'GOTO'. SO ADD IT HERE. ] # READY=NO #PRTBUF NO LONGER VALID ] IFTYP=NO FORTYP=NO ] # RETURN END SUBROUTINE PUTLIN (BUF, FIL, FMTCHR) # # PUTLIN - WRITE A LINE OF FORTRAN CODE TO OUTPUT FILE # # IF OUTPUT IS TO FORTRAN FILE (STDOUT), MAKE FINAL DECISION ABOUT OUTPUT. # IF OUTPUT IS TO ANOTHER FILE (EG LISTING), ASSUME CALLER HAS ALREADY DECIDED. # # INTEGER ERR, FIL CHARACTER BUF(MAXLINE), FMTCHR INCLUDE CLIST # # IF ((OUTPUT == YES & FIL == STDOUT) \ FIL != STDOUT) [ CALL PUTSTR(FIL, BUF, FMTCHR, ERR) IF (ERR == 0) RETURN #STRING OUTPUT OK ELSE #ERROR DURING OUTPUT CALL ERROR("Text output error - PUTLIN") ] # RETURN END SUBROUTINE RATLST (BUFR, LINE, FLINE) # # RATLST - TO PRINT A LINE ON LISTING & DO PAGE HOUSEKEEPING. # # INTEGER N, LINE, SITOC, JUNK, FLINE CHARACTER BUFR(DUMMYSIZE), OUTBUF(133) # INCLUDE CFILES.RT # INCLUDE CLIST # INCLUDE CLINE # INCLUDE CDATIM # STRING STARSS "************" # # ERRORS (LINE=HUGE) WITHIN INCLUDED/NL FILES ARE LISTED, # FOR (N=1; N <= LEVEL; INCREMENT(N)) #TO LIST THIS LINE, ALL LEVELS UP TO IF (LST(N) == NO & LINE <= 9999) #THE CURRENT ONE MUST BE LISTED. RETURN #OTHERWISE, RETURN WITHOUT PRINTING ANYTHING # IF (PLINE > PAGELENGTH \ BUFR(1) == FORMFEED) #ADVANCE PAGE AND DO HEADER [ OUTBUF(1)=FORMFEED OUTBUF(2)=EOS CALL PUTLIN (OUTBUF, LISTOUT, BLANK) #ADVANCE PAGE OUTBUF(1)=BLANK CALL PUTLIN (OUTBUF, LISTOUT, BLANK) CALL PUTLIN (OUTBUF, LISTOUT, BLANK) #BLANK LINES CALL PUTLIN (OUTBUF, LISTOUT, BLANK) INCREMENT (PAGE) CALL SPAD (OUTBUF, 77) CALL SINSRT (VNUMBER, OUTBUF(1)) CALL SINSRT(DATIM, OUTBUF(35)) CALL SINSRT ("PAGE", OUTBUF(71)) JUNK=SITOC (PAGE, OUTBUF(77), 4) CALL PUTLIN (OUTBUF, LISTOUT, BLANK) #PRINT THE HEADING CALL PUTLIN (CLB, LISTOUT, BLANK) OUTBUF(1)=BLANK OUTBUF(2)=EOS CALL PUTLIN (OUTBUF, LISTOUT, BLANK) #BLANK LINES CALL PUTLIN (OUTBUF, LISTOUT, BLANK) PLINE=6 IF (BUFR(1) == FORMFEED) RETURN #DONE IT ] OUTBUF(1)=EOS CALL SPAD (OUTBUF,7) #PRINT FTN LINE #'S IF (FLINE > 0) [ OUTBUF(1)=LPAREN N=SITOC (FLINE, OUTBUF(2), 4) #CONVERT FTN LINE # OUTBUF(N+2)=RPAREN #KLOBBER SITOC'S EOS ] IF (LINE > 0) #DO SOURCE CODE LINE NUMBER IF (LINE > 9999) #ERRORS HAVE LINE=HUGE, CALL SCOPY(STARSS,OUTBUF,15,JUNK) #SO FLAG 'EM ELSE JUNK=SITOC (LINE, OUTBUF(7), 5) #CONVERT RATFOR LINE # CALL SPAD (OUTBUF, 21) FOR (N=1; N <= NFILES; INCREMENT(N)) IF (N <= LEVEL-1) OUTBUF(11+N)=STAR #FLAG INCLUDED FILES CALL SCOPY (BUFR, OUTBUF(14+NFILES), 132-14-NFILES) CALL PUTLIN (OUTBUF, LISTOUT, BLANK) #PRINT THE LINE INCREMENT (PLINE) RETURN END SUBROUTINE SYNERR(MSG) # # SYNERR - REPORT RATFOR SYNTAX ERROR # # CHARACTER BUFOUT(MAXLINE), MSG(MAXLINE) INTEGER I, LASTC EQUIVALENCE (BUFOUT,HEADER) INCLUDE COUTLN INCLUDE CLIST STRING HEADER "C***RATFOR ERROR: " # LASTC=19 FOR(I=1;MSG(I) != EOS & MSG(I) != PERIOD & LASTC < MAXCARD;INCREMENT(I)) [ BUFOUT(LASTC) = MSG(I) INCREMENT (LASTC) ] BUFOUT(LASTC)=EOS INCREMENT (ERRORS) #COUNT ERRORS # # OUTPUT TO STANDARD FILE # IF (OUTP > 0) #FINISH OFF PREVIOUS LINE FIRST CALL OUTDON CALL PUTLIN (BUFOUT, STDOUT, NO) # # OUTPUT TO TERMINAL AND (MAYBE) LISTFILE # IF (LST(1) == YES) CALL RATLST (BUFOUT(2), HUGE, 0) #PRINT WITH '***', PCN 75 CALL RCTRLO #MAKE SURE... CALL PRINT(BUFOUT(2)) #...IT SHOWS ON USER TERMINAL # RETURN END