c%%A-RCB-0047-SL-18-1 RAT -- EXPLANATIONS c c c Ratfor translates programs written in the Ratfor language c into Fortran. The design of both the Ratfor language and this c preprocessor are given by Kernighan and Plauger in their book c "Software Tools" (Addison-Wesley, Toronto, 1976). This version c of Ratfor is described in A-RCB-0091-SP-1. It is essentially c the same as the language desribed by Kernighan and Plauger c except that: c 1) two new statements, DEFINELIST and BREAK GROUP, are implemented, c 2) the continuation convention is slightly different, c 3) only ' can delimit holleriths (" is used for octal constants), c 4) >> is used for .GT. and << for .LT. since < and > have other c meanings to the F4P compiler. c c Ratfor reads the input line-by-line and breaks each line into c a string of characters. These characters are re-assembled into c tokens: names, hollerith constants, and special characters which c stand alone (e.g. ., *, {). When a name token is found, Ratfor c tries to replace it by its DEFINEd value; if this is possible the c definition is pushed back into the input and rescanned. Subroutine c PUTBAK replaces characters in the input stream with the co-operation c of the input routine, GETCHR. The ability to put strings back into c the input is heavily used in Ratfor. c c The first token on each line is encoded as an integer which is then c used to classify the current statement. Ratfor statements cause c special information describing the statement to be stacked. If c the statement is BREAK, NEXT, }, or non-Ratfor it is scanned till the end. c Then Ratfor goes down its stacks until a { stack entry or the beginning c of the stacks is found. As it scans, Ratfor produces the Fortran needed to c close off each entry on the stack. c c Fortran output code is assembled character-by-character in an output c buffer. When there are 72 characters of data in the buffer, it is dumped c and a continuation card automatically started. c c c Ratfor does a lot of string manipulation. All strings are stored c in LOGICAL*1 vectors with a null ("000) byte at the end to mark c the end. (Terminating string constants with a null is standard c Fortran and RSX practice.) Two other ASCII control characters c are used internally: "004 is returned by the GETCHR routine c at the end of file and "012 is sent by GETCHR at the end of a line. c c c The subroutines comprising Ratfor are grouped in this order: c c 1) setup, c 2) string manipulation, c 3) input, c 4) output, c 5) parsing, c 6) scanning (token builders), c 7) error message printer. c%^ c The integer encoding scheme for key Ratfor tokens is: c c 1 ] c 2 ; c 3 [ c 4 "004 (end of file-must be 4) c 5 non-Ratfor statement c 6 statement label (string of digits at start of statement) c 7 IF c 8 ELSE c 9 WHILE c 10 REPEAT c 11 UNTIL c 12 FOR c 13 DO c 14 BREAK c 15 NEXT c 16 DEFINE c 17 INCLUDE c 18 DEFINELIST c c%^ c Here is the Fortran code resulting from the various Ratfor statements: c c Ratfor Fortran Comments c c IF (EXPR) IF (.NOT.(EXPR)) GO TO L1 c S1 S1 c ELSE L3 GO TO L2 L3 in case S1 ends in C S2 L1 CONTINUE c S2 branch. Prevents c L2 CONTINUE "unreachable code" c error message. c c REPEAT CONTINUE Holds REPEAT'S label. c S1 L1 CONTINUE c S1 c L3 GO TO L1 L3 for NEXT in loop. c L2 CONTINUE L2 for BREAK. c c REPEAT CONTINUE c S1 L1 CONTINUE c UNTIL (EXPR) S1 c L3 IF(.NOT.(EXPR))GO TO L1 c L2 CONTINUE c c WHILE (EXPR) CONTINUE For WHILE'S label. c S1 L1 IF(.NOT.(EXPR))GO TO L2 L1 for NEXT, loop. c S1 c GO TO L1 c L2 CONTINUE For BREAK. c c DO LIMITS DO L1 LIMITS c S1 S1 c L1 CONTINUE For NEXT, DO. c L2 CONTINUE For BREAK. c c FOR(I;EXPR;R) I Initialize. c S1 GO TO L3 Skip re-init 1st. c L1 R Re-initialize. c L3 IF(.NOT.(EXPR))GO TO L2 Top of Loop Test. c S1 c GO TO L1 c L2 CONTINUE For BREAK. c c BREAK GO TO L2 L2 past loop end. c c NEXT GO TO L1 All but REPEAT loops. c or GO TO L3 Repeat loops. c c BREAK GROUP GO TO L1 c c } L1 CONTINUE For BREAK GROUP. c c c When a Ratfor statement is found, L1 is obtained and stacked. We always c have L2=L1+1 and L3=L1+2. C%%A-RCB-0047-SL-18-1 RAT -- MAIN PROGRAM C C RATFOR IS A PREPROCESSOR FOR FORTRAN PROGRAMS WHICH C ALLOWS MODERN CONTROL STRUCTURES LIKE IF-ELSE, WHILE, C REPEAT-UNTIL, FOR, BREAK, AND NEXT. C C C LOGICAL SETUP C 5 IF (.NOT. SETUP(JUNK)) CALL EXIT CALL PARSE GO TO 5 END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE INIT SUBROUTINE INIT C C INIT SHARED DATA C LOGICAL*1 BUF(101), BAKBUF(501), OUTBUF(80), TABLE(2048) LOGICAL*1 CTIME(8),CDATE(9) LOGICAL LSTEND,LISTSW(3) INTEGER NAMES(257), LONG(257),PAGE,FREE COMMON /LUNS/ LUNIN, !RATFOR SOURCE INPUT 1 LUNOUT, !FORTRAN OUTPUT 2 LUNLST, !RATFOR LISTING 3 LUNTTY !TI: FOR ERRORS, MESSAGES COMMON /INPUT/ BUF, !INPUT BUFFER 1 BAKBUF, !CHARS REPLACED IN INPUT BUFFER 2 NOWBUF, !CURRENT POSITION IN INPUT BUFFER 3 NOWBAK, !CURRENT POSITION IN PUT BACK BUFFER 4 LNGTH !SIZE INPUT RECORD-FOR ERROR MESSAGER COMMON /CLINE/ LINECT, !RATFOR LINE NUMBER 1 NUMERR, !COUNTS RATFOR ERRORS 2 LINF4P, !FORTRAN STATEMENT LINE NUMBER 3 LINES !NUMBER OF LINES LISTED ON CURRENT PAGE COMMON /OUT/ OUTBUF, !OUTPUT FORTRAN RECORD BUFFER 1 IP !CURRENT POSTION IN OUTPUT BUFFER COMMON /DEFN/ NAMES, !HASH TABLE POINTERS FOR DEFINE 1 LONG, !LENGTH OF NAMES 2 TABLE, !HOLD AREA FOR DEFINED NAMES & TEXT 3 FREE !FIRST FREE BYTE IN TABLE COMMON /HEAD/ PAGE, !CURRENT LISTING PAGE 1 CTIME, !TIME FOR HEADER 2 CDATE !DATE FOR HEADER COMMON /LASTAT/ LSTEND !TRUE IFF LAST STATEMENT WAS END COMMON /SWLIST/ LISTSW !LISTSW(LUNIN) .TRUE. IF LUNIN TO BE LISTED DATA LUNIN,LUNOUT,LUNLST,LUNTTY/ 1,4,6,5/ LISTSW(1) = .TRUE. LISTSW(2) = .FALSE. LISTSW(3) = .FALSE. LSTEND=.TRUE. LUNIN=1 LUNOUT=4 LUNLST=6 LUNTTY=5 PAGE=1 CALL TIME(CTIME) CALL DATE(CDATE) NOWBUF=0 NOWBAK=0 LINECT=0 NUMERR=0 LINF4P=1 LINES=999 IP=0 DO 10 I=1,257 NAMES(I)=0 10 CONTINUE FREE=1 RETURN END C%%A-RCB-0047-SL-18-1 RAT -- INTEGER FUNCTION LENGTH(STR) INTEGER FUNCTION LENGTH(STR) C C LENGTH RETURNS THE LENGTH OF THE STRING STR. MUCH OF THIS RATFOR C PROCESSOR USES STRING MANIPULATION. ALL STRINGS ARE STORED C IN LOGICAL*1 VECTORS WITH A "000 PLACED AT THE END OF THE C STRING TO MARK THE END. C LOGICAL*1 STR(1000) LENGTH=0 DO 10 I=1,1000 IF(STR(I) .EQ. "000)RETURN LENGTH=LENGTH+1 10 CONTINUE RETURN END C%%A-RCB-0047-SL-18-1 RAT -- LOGICAL FUNCTION EQUAL(S1,S2) LOGICAL FUNCTION EQUAL(S1,S2) LOGICAL*1 S1(1000), S2(1000) C C EQUAL RETURNS .TRUE. IFF S1 AND S2 COMPARE AS EQUAL. C EQUAL=.FALSE. DO 10 I=1,1000 IF(S1(I) .NE. S2(I)) RETURN IF(S1(I) .EQ. "000)GO TO 20 10 CONTINUE 20 EQUAL = .TRUE. RETURN END C%%A-RCB-0047-SL-18-1 RAT -- LOGICAL FUNCTION ALLDIG(LEXSTR) LOGICAL FUNCTION ALLDIG(LEXSTR) LOGICAL*1 LEXSTR(101) C C ALLDIG RETURNS .TRUE. IFF ITS ARGUMENT STRING IS ENTIRELY DIGITS. C ALLDIG=.FALSE. DO 10 I=1,1000 IF(LEXSTR(I) .EQ. "000)GO TO 20 IF(LEXSTR(I) .LT. "060 .OR. LEXSTR(I) .GT. "071)RETURN 10 CONTINUE 20 ALLDIG=.TRUE. RETURN END C%%A-RCB-0047-SL-18-1 RAT -- LOGICAL*1 FUNCTION TYPE(C) LOGICAL*1 FUNCTION TYPE(C) LOGICAL*1 C C C TYPE RETURNS 'A' IF C IS ALPHABETIC, '0' IF C IS A DIGIT, C AND C ITSELF OTHERWISE. C TYPE=C IF(C .GE. "060 .AND. C .LE. "071)TYPE='0' IF((C .GE. "141 .AND. C .LE. "172) 1 .OR. (C .GE. "101 .AND. C .LE. "132)) TYPE='A' RETURN END C%%A-RCB-0047-SL-18-1 RAT -- INTEGER FUNCTION ITOC(NUM,OUT,N) INTEGER FUNCTION ITOC(NUM,OUT,N) INTEGER NUM,N LOGICAL*1 OUT(N), DIGITS(10) DATA DIGITS/'0','1','2','3','4','5','6','7','8','9'/ C C ITOC CONVERTS THE ARGUMENT NUM INTO AN UNSIGNED LOGICAL*1 STRING C WHICH IS STORED IN OUT. THE FUNCTION RETURNS THE STRING LENGTH. C OUT CAN HOLD UP TO N LOGICAL*1S; IF MORE ARE REQUIRED TRUNCATION C OCCURS. C K = IABS(NUM) J = N ITOC=0 10 OUT(J) = DIGITS(MOD(K,10)+1) J=J-1 K=K/10 ITOC=ITOC+1 IF(K .GT. 0 .AND. J .GT. 0) GO TO 10 RETURN END C%%A-RCB-0047-SL-18-1 RAT -- LOGICAL FUNCTION SETUP(JUNK) LOGICAL FUNCTION SETUP(JUNK) PARAMETER YES=1, NO=0 LOGICAL*1 FOUT(41),FLST(41),CJUNK(1) LOGICAL NOMORE COMMON /LUNS/ LUNIN,LUNOUT,LUNLST,LUNTTY C C ATTACH LUNS C 10 CALL ERRSET(43,,.FALSE.,,.FALSE.) CALL ERRSET(29,,.FALSE.,,.FALSE.) IF(LUNOUT .GT. 0) CLOSE(UNIT=LUNOUT) IF(LUNLST .GT. 0) CLOSE(UNIT=LUNLST) CLOSE(UNIT=LUNTTY) CLOSE(UNIT=LUNIN) C CALL INIT C OPEN(UNIT=LUNTTY,NAME='TI:',ERR=120) CALL ASSIGN(LUNLST,'SY:') CLOSE(UNIT=LUNLST) !JUST SET DEFAULT DEVICE IF (NXTMCR(LUNTTY,'RAT',7,NUMOUT) .EQ. YES) GO TO 20 SETUP = .FALSE. RETURN 20 IF (NUMOUT .LE. 2) GO TO 30 CALL MCRERR(LUNTTY,'RAT','TOO MANY OUTPUTS. MAX: 2') GO TO 10 30 IF (NUMOUT .LT. 2) GO TO 40 JUNK = NXTFIL('.FTN',FOUT,41,CJUNK,1) JUNK = NXTFIL('.LST',FLST,41,CJUNK,1) GO TO 50 40 IF (NUMOUT .EQ. 1) JUNK = NXTFIL('.FTN',FOUT,41,CJUNK,1) IF (NUMOUT .EQ. 0) FOUT(1) = "000 FLST(1) = "000 C 50 IF (FLST(1) .EQ. "000) LUNLST = 0 IF (FOUT(1) .EQ. "000) LUNOUT = 0 IF (FOUT(1) .NE. "000) 1 OPEN(UNIT=LUNOUT,NAME=FOUT,ERR=100,CARRIAGECONTROL='LIST', 2 TYPE='NEW') IF (FLST(1) .NE. "000) 1 OPEN(UNIT=LUNLST,NAME=FLST,ERR=110,TYPE='NEW') CALL NEWINP(NOMORE) IF (NOMORE) GO TO 10 SETUP = .TRUE. RETURN C 100 CALL CANT(LUNTTY,'RAT',FOUT) GO TO 10 110 CALL CANT(LUNTTY,'RAT',FLST) IF (LUNOUT .GT. 0) CLOSE (UNIT=LUNOUT,DISP='DELETE') GO TO 10 120 CALL CANT(LUNTTY,'RAT','TI:') GO TO 10 END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE NEWINP(NOMORE) SUBROUTINE NEWINP(NOMORE) PARAMETER NO=0 LOGICAL NOMORE LOGICAL*1 FN(42),CJUNK(1) COMMON /FNMIN/ FN COMMON /LUNS/ LUNIN,LUNOUT,LUNLST,LUNTTY C C NEWINP USES NXTFIL TO OPEN THE NEXT INPUT FILE ON THE MCR LINE. C NOMORE IS RETURNED AS .TRUE. IFF ALL INPUT FILES ARE EXHAUSTED. C NOMORE=.TRUE. CLOSE(UNIT=LUNIN) IF( LUNIN .LE. 1 ) GO TO 10 LUNIN=LUNIN-1 NOMORE=.FALSE. RETURN 10 IF (NXTFIL('.RAT',FN,42,CJUNK,1) .EQ. NO) RETURN IF (FN(1) .EQ. "000) GO TO 10 OPEN(UNIT=LUNIN,NAME=FN,ERR=20,READONLY,TYPE='OLD') NOMORE=.FALSE. RETURN 20 CALL CANT(LUNTTY,'RAT',FN) NOMORE=.TRUE. RETURN END C%%A-RCB-0047-SL-18-1 RAT -- LOGICAL*1 FUNCTION GETCHR(C) LOGICAL*1 FUNCTION GETCHR(C) LOGICAL*1 C,BAKBUF(501),BUF(101) LOGICAL LISTSW(3) COMMON /LUNS/ LUNIN,LUNOUT,LUNLST,LUNTTY COMMON /SWLIST/ LISTSW COMMON /INPUT/ BUF,BAKBUF,NOWBUF,NOWBAK,LNGTH COMMON /CLINE/ LINECT,NUMERR,LINF4P,LINES C C GETCHR RETURNS THE NEXT INPUT CHAR IN GETCHR AND C. AT EOF, "004 IS C SENT; AT END OF LINE "012 (LINEFEED) IS SENT. NOTE THAT SUBROUTINE C PUTBAK ALLOWS CHARS TO BE RETURNED TO THE INPUT STREAM. C IF(NOWBAK .LE. 0)GO TO 20 !JUMP IF PUTBAK CHAR BUFFER EMPTY C=BAKBUF(NOWBAK) GETCHR=C NOWBAK=NOWBAK-1 RETURN 20 IF(NOWBUF .LE. 0 .OR. NOWBUF .GT. N)GO TO 50 !EMPTY INPUT BUFFER C=BUF(NOWBUF) GETCHR=C NOWBUF=NOWBUF+1 RETURN C 50 CONTINUE READ(LUNIN,60,END=80)N,BUF 60 FORMAT(Q,101A1) IF(N .GT. 100)N = 100 IF(N .LE. 0)GO TO 50 LNGTH=N IF (BUF(1).NE.'#' .AND. BUF(1).NE."014)LINECT=LINECT+1 IF (LUNLST.GT.0 .AND. N.GT.0 .AND. LISTSW(LUNIN)) 1 CALL LISTER(LUNLST,BUF,N) IF(BUF(1) .EQ. '#' .OR. BUF(1).EQ."014)GO TO 50 N=N+1 BUF(N)="012 NOWBUF=1 NOWBAK=0 GO TO 20 80 C="004 GETCHR=C NOWBUF=0 RETURN END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE SKIPLF SUBROUTINE SKIPLF LOGICAL*1 GETCHR,C C C SKIP INPUT STREAM PAST NEXT LINEFEED (IE UNTIL NEXT STATEMENT) C 10 IF(GETCHR(C) .EQ. "004)GO TO 20 IF(C .NE. "012)GO TO 10 RETURN 20 CALL PUTBAK(C) RETURN END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE PUTBAK(C) SUBROUTINE PUTBAK(C) LOGICAL*1 C,BAKBUF(501),BUF(101) COMMON /INPUT/ BUF,BAKBUF,NOWBUF,NOWBAK,LNGTH C C PUTS LOGICAL*1 C BACK INTO INPUT STREAM C IF(NOWBAK .GE. 501)CALL ERROR('PUSHBACK BUFFER OVERFLOW-ABORT#') NOWBAK=NOWBAK+1 BAKBUF(NOWBAK)=C RETURN END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE PBSTR(STR) SUBROUTINE PBSTR(STR) LOGICAL*1 STR(1000) C C PUTS STRING STR BACK INTO INPUT. NOTE THAT STRING MUST BE C PUT BACK IN REVERSE ORDER SO THAT IT IS RESCANNED IN RIGHT ORDER. C I=LENGTH(STR) 10 IF(I .LE. 0)RETURN CALL PUTBAK(STR(I)) I=I-1 GO TO 10 END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE LISTER(LUN,OUT,LONG) SUBROUTINE LISTER(LUN,OUT,LONG) LOGICAL*1 OUT(LONG),CTIME(8),CDATE(9),CC,HOLD(6),FN(42) INTEGER LINES,LONG,LUN,PAGE COMMON /CLINE/ LINECT,NUMERR,LINF4P,LINES COMMON /HEAD/ PAGE,CTIME,CDATE COMMON /FNMIN/ FN DATA CC/' '/, HOLD/5*' ', ')'/ C C PUTS THE LONG LOGICAL*1S OF OUT ONTO UNIT LUN, COUNTING C LINES AND PAGES C IF (OUT(1) .NE. "014) GO TO 1 LINES = 999 RETURN 1 IF(LINES .LT. 50)GO TO 10 WRITE(LUN,5) CC,CDATE,CTIME,PAGE,(FN(II),II=1,LENGTH(FN)) 5 FORMAT(A1,'RATFOR VERSION 2',48X,9A1,5X,8A1,15X,'PAGE',I4, 1 T24,42A1) WRITE (LUN,5) ! PUT IN A BLANK LINE PAGE=PAGE+1 CC='1' !DON'T EJECT PRINTER FOR 1ST HEADER LINES=0 10 LINES=LINES+1 HOLD(1)=' ' HOLD(2)=' ' HOLD(3)=' ' HOLD(4)=' ' LNG=ITOC(LINF4P,HOLD(2),4) HOLD(5-LNG)='(' IF(OUT(1) .NE. '#')WRITE(LUN,15) HOLD,LINECT,OUT IF(OUT(1) .EQ. '#')WRITE(LUN,20)OUT 15 FORMAT(' ',6A1,5X,I4,9X,100A1) 20 FORMAT(25X,100A1) RETURN END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE OUTGO(LAB) SUBROUTINE OUTGO(LAB) INTEGER LAB LOGICAL*1 GO(5) DATA GO/ 'G','O','T','O',"000/ C C OUTPUT STATEMENT GOTO LAB C CALL OUTTAB CALL OUTSTR(GO) CALL OUTNUM(LAB) CALL OUTDON RETURN END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE OUTCON(LAB) SUBROUTINE OUTCON(LAB) INTEGER LAB LOGICAL*1 CONT(9) DATA CONT/'C','O','N','T','I','N','U','E',"000/ C C PUT OUT CONTINUE STATEMENT, LABELLED BY LAB IF ITS NON-ZERO C IF(LAB .GT. 0)CALL OUTNUM(LAB) CALL OUTTAB CALL OUTSTR(CONT) CALL OUTDON RETURN END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE OUTNUM(N) SUBROUTINE OUTNUM(N) INTEGER N,LONG LOGICAL*1 HOLD(6) DATA HOLD(6) /"000/ C C PUT N INTO OUTPUT C LONG=ITOC(N,HOLD,5) CALL OUTSTR(HOLD(6-LONG)) RETURN END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE IFGO(LAB) SUBROUTINE IFGO(LAB) INTEGER LAB,NPAR LOGICAL*1 IFNOT(10),TOK,LEXSTR(101),NXTOK,TOK2,BRACKS(3) DATA IFNOT/'I','F','(','.','N','O','T','.','(',"000/ DATA BRACKS/')',')',"000/ C C COLLECT LOGICAL EXPRESSION AND PUT OUT IF(.NOT.(EXPRESSION))GOTO LAB C LABOR=0 !BECOMES NON-ZERO IF FIND !! CALL OUTTAB CALL OUTSTR(IFNOT) IF(NXTOK(LEXSTR,101).NE. '(')GO TO 100 NPAR=1 10 TOK=NXTOK(LEXSTR,101) IF(TOK .EQ. "004 .OR. TOK .EQ. "012)GO TO 100 IF(TOK .EQ. '(')NPAR=NPAR+1 IF(TOK .EQ. ')')NPAR=NPAR-1 IF(TOK .NE. '&' .AND. TOK .NE. "041)GO TO 30 !"041 = ! TOK2=NXTOK(LEXSTR,101) IF(TOK .NE. TOK2)GO TO 25 IF(NPAR .GT. 1)GO TO 110 CALL OUTSTR(BRACKS) IF(TOK .EQ. '&')CALL OUTGO(LAB) IF(TOK .EQ. '&')GO TO 20 IF(LABOR .LE. 0)LABOR=LABGEN(1) LABTMP=LABGEN(1) CALL OUTGO(LABTMP) CALL OUTGO(LABOR) CALL OUTNUM(LABTMP) 20 CALL OUTTAB CALL OUTSTR(IFNOT) GO TO 10 25 CALL PBSTR(LEXSTR) LEXSTR(1)=TOK LEXSTR(2)="000 30 CALL OUTSTR(LEXSTR) IF(NPAR .GT. 0)GO TO 10 CALL OUTCH(')') CALL OUTGO(LAB) IF(LABOR .GT. 0)CALL OUTCON(LABOR) RETURN C 100 CALL ERROR('UNBALANCED PARENTHESES IN LOGICAL EXPRESSION%') CALL PUTBAK(TOK) GO TO 115 110 CALL ERROR('UNBALANCED PARENTHESES BEFORE && OR !!%') 115 CALL SKIPLF RETURN END C%%A-RCB-0047-SL-18-1 RAT -- INTEGER FUNCTION LABGEN(NUM) INTEGER FUNCTION LABGEN(NUM) INTEGER LABEL,NUM DATA LABEL/23000/ C C RESERVE NUM LABELS, RETURN FIRST ONE C IF(LABEL+NUM .GT. 24000)LABEL=23000 LABGEN=LABEL LABEL=LABEL+NUM RETURN END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE EATUP SUBROUTINE EATUP LOGICAL*1 NXTOK, TOK(101),T C C PASS LOGICAL*1S TO OUTPUT UNTIL END OF STATEMENT C 10 T = NXTOK(TOK,101) IF(T .EQ. ';' .OR. T .EQ. "012)RETURN IF(T .EQ. "004 .OR. T .EQ. '[' .OR. T .EQ. ']')GO TO 20 CALL OUTSTR(TOK) GO TO 10 C 20 IF(T .EQ. "004)CALL ERROR('UNEXPECTED EOF%') CALL PUTBAK(T) RETURN END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE OUTSTR(STR) SUBROUTINE OUTSTR(STR) LOGICAL*1 STR(1000),OSPEC2(15) LOGICAL INHOLL,SWITCH DATA OSPEC2/'.','A','N','D','.','.','N','O','T','.','.','O','R','.', 1 ' '/ C C OUTPUTS STRING STR, TRANSLATING ANY &'S, !'S, ^'S WHICH AREN'T IN HOLLERITHS C INHOLL=.FALSE. DO 100 I=1,1000 IF(STR(I) .EQ. "000)RETURN IF(INHOLL) GO TO 70 K=1 IF(STR(I) .EQ. '&')GO TO 30 K=6 IF(STR(I) .EQ. '^')GO TO 30 K=11 IF(STR(I) .EQ. "41)GO TO 30 IF(STR(I) .EQ. '''')INHOLL=.TRUE. IF(INHOLL) SWITCH=.FALSE. CALL OUTCH(STR(I)) GO TO 100 30 DO 35 J=K,K+4 CALL OUTCH(OSPEC2(J)) 35 CONTINUE GO TO 100 C 70 IF(STR(I) .EQ. '''')SWITCH=.NOT. SWITCH IF(STR(I+1) .NE. '''' .AND. SWITCH)INHOLL=.FALSE. CALL OUTCH(STR(I)) 100 CONTINUE RETURN END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE OUTCH(C) SUBROUTINE OUTCH(C) LOGICAL*1 C,OUTBUF(80) COMMON /OUT/ OUTBUF,IP C C PUT LOGICAL*1 C INTO OUTPUT BUFFER AND GENERATE ANY REQUIRED CONTINUATION C IF(IP .LT. 72)GO TO 10 CALL OUTDON DO 5 IP=1,5 OUTBUF(IP)=' ' 5 CONTINUE OUTBUF(6)='1' IP=6 10 IP=IP+1 OUTBUF(IP)=C RETURN END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE OUTTAB SUBROUTINE OUTTAB LOGICAL*1 OUTBUF(80) COMMON /OUT/ OUTBUF,IP C C MAKE SURE OUTPUT POINTER PAST COLUMN 6 C 10 IF(IP .GE. 6)RETURN CALL OUTCH(' ') GO TO 10 END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE OUTDON SUBROUTINE OUTDON LOGICAL*1 OUTBUF(80) COMMON /OUT/ OUTBUF ,IP COMMON /LUNS/ LUNIN,LUNOUT,LUNLST,LUNTTY COMMON /CLINE/ LINECT,NUMERR,LINF4P,LINES C C OUTPUT FORTRAN "CARD", PUT RATFOR STATEMENT NUMBER ON END AFTER ! C IF(IP .LE. 0) GO TO 20 IF(OUTBUF(6) .NE. '1')LINF4P=LINF4P+1 IF(LUNOUT .LE. 0)GO TO 20 DO 5 I=IP+1,IP+7 OUTBUF(I)=' ' 5 CONTINUE OUTBUF(IP+3)='!' JUNK=ITOC(LINECT,OUTBUF(IP+4),4) IP=IP+7 WRITE(LUNOUT,10) (OUTBUF(I),I=1,IP) 10 FORMAT(80A1) 20 IP=0 RETURN END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE PARSE SUBROUTINE PARSE LOGICAL*1 LEXSTR(101) INTEGER LEX,LABVAL(50),LEXTYP(50),SP,TOKEN,LAB LOGICAL NOMORE,ERR COMMON /LUNS/ LUNIN,LUNOUT,LUNLST,LUNTTY COMMON /CLINE/ LINECT,NUMERR,LINF4P,LINES C C GET 1ST TOKEN ON STATEMENT, USE CHKRAT TO CHECK FOR AND HANDLE C RATFOR STATEMENTS. THEN, WHEN GET TO END OF STATEMENT, USE C UNSTAK TO PRODUCE ANY REQUIRED FORTRAN TO CLOSE LOOPS, IF'S, ELSE'S. C SP=1 LEXTYP(1)="004 5 TOKEN=LEX(LEXSTR) IF(TOKEN .EQ. "004)GO TO 300 CALL CHKRAT(LEXTYP(SP),LABVAL(SP),LEXSTR,TOKEN,LAB,ERR) IF(ERR .OR. TOKEN .GT. 15) GO TO 5 C IF( TOKEN .GT. 13 1 .OR.(TOKEN .LT. 7 .AND. TOKEN .NE. 3))GO TO 150 SP=SP+1 !START OF RATFOR STATEMENT IF(SP .GT. 50)CALL ERROR('STACK OVERFLOW - ABORT#') IF(TOKEN .EQ. 3)LAB=LABGEN(1) LEXTYP(SP)=TOKEN !SO REMEMBER TYPE OF STATEMENT LABVAL(SP)=LAB !AND FORTRAN LABEL USED IF( TOKEN .NE. 11)GO TO 200 150 IF(TOKEN .NE. 1) GO TO 160 !HERE TILL 200 HANDLES END OF STATE. IF(LEXTYP(SP) .NE. 3)CALL ERROR('MISSING [%') IF(LEXTYP(SP) .EQ. 3)CALL OUTCON(LABVAL(SP)) IF(LEXTYP(SP) .EQ. 3)SP=SP-1 !POP [ OFF STACK GO TO 170 160 IF(TOKEN .EQ. 5)CALL OTHERC(LEXSTR,SP) !SOME DUMB NON-RATFOR IF(TOKEN .EQ. 15 .OR. TOKEN .EQ. 14) 1 CALL BRKNXT(SP,LEXTYP,LABVAL,TOKEN,LEXSTR) 170 TOKEN=LEX(LEXSTR) !PEEK AT NEXT TOKEN CALL PBSTR(LEXSTR) CALL UNSTAK(SP,LEXTYP,LABVAL,TOKEN) !HANDLES END OF STATE. 200 GO TO 5 C 300 CALL NEWINP(NOMORE) !EOF-LOOK FOR NEXT INPUT IF(.NOT. NOMORE)GO TO 5 !EXCUSE DOUBLE NEGATIVE IF(SP .NE. 1)CALL ERROR('UNEXPECTED EOF-UNCLOSED LOOPS%') IF(NUMERR .GT. 0)WRITE(LUNTTY,310)NUMERR 310 FORMAT('0RAT --',I4,' ERRORS DETECTED'/) RETURN END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE CHKRAT(LEXTYP,LABVAL,LEXSTR,TOKEN,LAB,ERR) SUBROUTINE CHKRAT(LEXTYP,LABVAL,LEXSTR,TOKEN,LAB,ERR) INTEGER LEXTYP,LABVAL,TOKEN,LAB LOGICAL*1 LEXSTR(101) LOGICAL ERR C C IF TOKEN NAMES RATFOR STATEMENT, CALL SUBROUTINE TO HANDLE C ERR=.FALSE. IX = TOKEN-5 IF(IX .LE. 0 .OR. IX .GT. 13)RETURN GOTO(10,20,30,40,50,60,70,80,85,85,90,100,110),IX 10 CALL LABELC(LEXSTR) !HANDLE LABELS RETURN 20 CALL IFCODE(LAB) !IF STATEMENT RETURN 30 IF(LEXTYP .EQ. 7)GO TO 35 CALL ERROR('NO IF FOR THIS ELSE%') ERR=.TRUE. RETURN 35 CALL ELSEIF(LABVAL) RETURN 40 CALL WHILES(LAB) !WHILE STATEMENT RETURN 50 CALL RPEAT(LAB) !REPEAT STATEMENT RETURN 60 IF(LEXTYP .EQ. 10)GO TO 65 CALL ERROR('NO REPEAT FOR THIS UNTIL%') ERR=.TRUE. RETURN 65 CALL UNTILS(LABVAL) RETURN 70 CALL FORCOD(LAB) !FOR STATEMENT RETURN 80 CALL DOCODE(LAB) !DO STATEMENT 85 RETURN 90 CALL DFINE RETURN 100 CALL INCLUD RETURN 110 CALL DEFLST RETURN END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE UNSTAK(SP,LEXTYP,LABVAL,TOKEN) SUBROUTINE UNSTAK(SP,LEXTYP,LABVAL,TOKEN) INTEGER SP,TOKEN,LABVAL(50),LEXTYP(50) C C END OF STATEMENT; GO DOWN STACK REMOVING AS MUCH AS POSSIBLE C 5 IF(SP .LE. 1)RETURN IF(LEXTYP(SP) .EQ. 3 1 .OR. (LEXTYPE(SP) .EQ. 7 .AND. TOKEN .EQ. 8) 2 .OR. (LEXTYPE(SP) .EQ. 10 .AND. TOKEN .EQ. 11))RETURN IX =LEXTYP(SP)-6 IF(IX .GT. 0 .AND. IX .LT. 8)GO TO (10,20,30,30,20,30,40),IX CALL ERROR('INTERNAL ERROR IN UNSTAK-ABORT#') C 10 CALL OUTCON(LABVAL(SP)) !IF GO TO 90 C 20 IF(SP .GT. 2)SP=SP-1 CALL OUTCON(LABVAL(SP)+1) !ELSE, UNTIL GO TO 90 C 30 IF(IX .EQ. 4)CALL OUTNUM(LABVAL(SP)+2) CALL OUTGO(LABVAL(SP)) !WHILE, REPEAT WITHOUT CALL OUTCON(LABVAL(SP)+1) !UNTIL, FOR GO TO 90 C 40 CALL OUTCON(LABVAL(SP)) !DO CALL OUTCON(LABVAL(SP)+1) GO TO 90 C 90 SP=SP-1 GO TO 5 END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE LABELC(LEXSTR) SUBROUTINE LABELC(LEXSTR) LOGICAL*1 LEXSTR(1000),C,NXTOK INTEGER LENGTH C C PUT OUT FORTRAN LABEL AND WARN ABOUT 23000 RANGE C IF(LENGTH(LEXSTR) .NE. 5)GO TO 10 IF(LEXSTR(1) .EQ. '2' .AND. LEXSTR(2) .EQ. '3') 1 CALL ERROR('LABEL IN 23000 RANGE-POSSIBLE CONFLICT@') 10 CALL OUTSTR(LEXSTR) CALL OUTTAB C=NXTOK(LEXSTR,101) IF(C .EQ. "012 .OR. C .EQ. "004 .OR. C .EQ. ']' 1 .OR. C .EQ. '[' .OR. C .EQ. ';')CALL OUTCON(0) CALL PBSTR(LEXSTR) RETURN END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE IFCODE(LAB) SUBROUTINE IFCODE(LAB) INTEGER LAB,LABGEN C C IF STATEMENT C LAB=LABGEN(3) CALL IFGO(LAB) RETURN END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE ELSEIF(LAB) SUBROUTINE ELSEIF(LAB) INTEGER LAB C C ELSE STATEMENT C CALL OUTNUM(LAB+2) !IF STATEMENT BEFORE ELSE IS RETURN, STOP, !ETC., THIS FOOLS F4P INTO THINKING THERE IS !A PATH TO THE ELSE PART CALL OUTGO(LAB+1) CALL OUTCON(LAB) RETURN END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE WHILES(LAB) SUBROUTINE WHILES(LAB) INTEGER LABGEN,LAB C C WHILE STATEMENT C CALL OUTCON(0) !HOLDS LABEL OF WHILE STATEMENT LAB=LABGEN(2) CALL OUTNUM(LAB) CALL IFGO(LAB+1) RETURN END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE RPEAT(LAB) SUBROUTINE RPEAT(LAB) INTEGER LAB,LABGEN C C REPEAT STATEMENT C CALL OUTCON(0) !IN CASE REPEAT IS LABELLED LAB=LABGEN(3) CALL OUTCON(LAB) RETURN END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE UNTILS(LAB) SUBROUTINE UNTILS(LAB) INTEGER LAB C C UNTIL STATEMENT C CALL OUTNUM(LAB+2) CALL IFGO(LAB) RETURN END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE DOCODE(LAB) SUBROUTINE DOCODE(LAB) LOGICAL*1 ST(3) INTEGER LABGEN,LAB DATA ST/'D', 'O', "000/ C C DO STATEMENT C CALL OUTTAB CALL OUTSTR(ST) LAB=LABGEN(2) CALL OUTNUM(LAB) CALL EATUP CALL OUTDON RETURN END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE OTHERC(LEXSTR,SP) SUBROUTINE OTHERC(LEXSTR,SP) LOGICAL*1 LEXSTR(101),TOK,NXTOK,RET(7),FUNAME(7),FIN(4) INTEGER SP LOGICAL EQUAL,LSTEND COMMON /LASTAT/ LSTEND COMMON /CLINE/ LINECT, NUMERR, LINF4P, LINES DATA RET/'R','E','T','U','R','N',"000/, FUNAME(1)/"000/ DATA FIN/'E','N','D',"000/ C C NON-RATFOR; IF FIRST SUBPROGRAM STATEMENT, CHECK FOR AND SAVE FUNCTION C NAME; IF RETURN() LET DORET HANDLE; IF END RESET COUNTERS; AND C IN ALL CASES, EVENTUALLY SEND STATEMENT TO OUTSTR. C CALL OUTTAB IF(.NOT. EQUAL(LEXSTR,RET))GO TO 10 CALL DORET(LEXSTR,FUNAME,RET) LSTEND=.FALSE. RETURN 10 IF(.NOT. LSTEND)GO TO 20 !LSTEND=TRUE=>LAST STATEMENT END CALL LOOKFN(LEXSTR,FUNAME) LSTEND=.FALSE. RETURN 20 CALL OUTSTR(LEXSTR) IF(.NOT. EQUAL(FIN,LEXSTR))GO TO 30 TOK=NXTOK(LEXSTR,101) !PEEK AT TOKEN AFTER END IF(TOK.EQ."012 .OR. TOK.EQ.';' .OR. TOK.EQ.']' 1 .OR. TOK.EQ.'[' .OR. TOK .EQ."004) LSTEND=.TRUE. CALL PBSTR(LEXSTR) 30 CALL EATUP CALL OUTDON IF(.NOT.LSTEND)RETURN FUNAME(1)="000 LINF4P=1 IF(SP .GT. 1)CALL ERROR('UNFINISHED RATFOR STATEMENTS IN THIS 1 SUBPROGRAM%') LINES=999 SP =1 RETURN END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE DORET(LEXSTR,FUNAME,RET) SUBROUTINE DORET(LEXSTR,FUNAME,RET) LOGICAL*1 LEXSTR(101), FUNAME(7), NXTOK,TOK,RET(7) C C HANDLE RETURN(); IF JUST RETURN OR RETURN() NOT IN FUNCTION, C JUST DUMP STATEMENT. C TOK=NXTOK(LEXSTR,101) IF(TOK .NE. '(' .OR. FUNAME(1) .EQ. "000)GO TO 10 CALL OUTSTR(FUNAME) CALL OUTCH('=') CALL OUTCH('(') CALL EATUP CALL OUTDON CALL OUTTAB CALL OUTSTR(RET) CALL OUTDON RETURN C 10 CALL OUTSTR(RET) !NOT RETURN() OR NO FUNCTION NAME CALL PBSTR(LEXSTR) CALL EATUP CALL OUTDON RETURN END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE LOOKFN(LEXSTR,FUNAME) SUBROUTINE LOOKFN(LEXSTR,FUNAME) LOGICAL*1 LEXSTR(101), FUNAME(7), NXTOK, TOK, FUNC(9) LOGICAL GOTFUN,EQUAL DATA FUNC/'F','U','N','C','T','I','O','N',"000/ C C TRY TO FIND KEYWORD FUNCTION, IF CAN SAVE FUNCTION NAME C FUNAME(1) = "000 !ASSUME NO FUNCTION NAME 10 GOTFUN=EQUAL(LEXSTR,FUNC) CALL OUTSTR(LEXSTR) TOK=NXTOK(LEXSTR,101) IF(TOK.EQ.';' .OR. TOK.EQ.']' .OR. TOK.EQ.'[' 1 .OR. TOK.EQ."012 .OR. TOK.EQ."004)GO TO 30 IF(.NOT. GOTFUN)GO TO 10 IF(TOK .NE. 'A')GO TO 30 DO 15 I=1,6 IF(LEXSTR(I) .EQ. "000)GO TO 25 FUNAME(I) = LEXSTR(I) 15 CONTINUE I=7 25 FUNAME(I)="000 30 CALL PBSTR(LEXSTR) CALL EATUP CALL OUTDON RETURN END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE BRKNXT(SP,LEXTYP,LABVAL,TOKEN,LEXSTR) SUBROUTINE BRKNXT(SP,LEXTYP,LABVAL,TOKEN,LEXSTR) INTEGER LABVAL(50),SP,TOKEN,LEXTYP(50) LOGICAL*1 LEXSTR(101),C,GROUP(6),NXTOK LOGICAL EQUAL DATA GROUP/'G','R','O','U','P',"000/ C C BREAK AND NEXT STATEMENT C I = SP+1 C=NXTOK(LEXSTR,101) IF(C .EQ. "012 .OR. C .EQ. ';' 1 .OR. C .EQ. ']' .OR. C .EQ. '[' .OR. C .EQ. "004)GO TO 13 IF(TOKEN .EQ. 15) GO TO 30 IF(C .NE. 'A' .OR. .NOT. EQUAL(LEXSTR,GROUP))GO TO 30 C = NXTOK(LEXSTR,101) IF(C .NE. "012 .AND. C .NE. ';' .AND. C .NE. ']' 1 .AND. C .NE. '[' .AND. C .NE. "004)GO TO 30 IF(C .EQ. ']' .OR. C .EQ. '[' .OR. C .EQ. "004)CALL PUTBAK(C) 10 I=I-1 IF(I .LE. 1)GO TO 40 IF(LEXTYP(I) .NE. 3)GO TO 10 CALL OUTGO(LABVAL(I)) RETURN C 13 IF(C .EQ. ']' .OR. C .EQ. '[' .OR. C .EQ. "004)CALL PUTBAK(C) 15 I=I-1 IF(I .LE. 1) GO TO 20 IF(LEXTYP(I) .NE. 9 .AND. LEXTYP(I) .NE. 10 1 .AND. LEXTYP(I) .NE. 12 .AND. LEXTYP(I) .NE. 13)GO TO 15 IF(TOKEN .EQ. 14)CALL OUTGO(LABVAL(I)+1) IF(TOKEN .EQ. 15 .AND. LEXTYP(I) .EQ. 10) CALL OUTGO(LABVAL(I)+2) IF(TOKEN .EQ. 15 .AND. LEXTYP(I) .NE. 10) CALL OUTGO(LABVAL(I)) RETURN C 20 CALL ERROR('BREAK OR NEXT NOT IN RATFOR LOOP%') RETURN 30 CALL PBSTR(LEXSTR) CALL SKIPLF CALL ERROR('BAD FORM FOR BREAK/NEXT%') RETURN 40 CALL ERROR('BREAK GROUP NOT IN BRACKETED STATEMENT GROUP%') END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE FORCOD(LAB) SUBROUTINE FORCOD(LAB) LOGICAL*1 COND(301),LEXSTR(101),TOK,NXTOK INTEGER NPAR,NCHAR1,NCHAR2,NCHAR3 LOGICAL ERR C C FOR STATEMENT. COLLECT THE 3 PARTS WITH COLECT; SINCE RE-INITIALIZE C OUTPUT BEFORE CONDITION, SAVE CONDITION IN COND C LAB=LABGEN(3) NPAR=1 IF(NXTOK(LEXSTR,101) .NE. '(')GO TO 1000 C CALL COLECT(0,NCHAR1,NPAR,COND,ERR) IF(ERR)GO TO 1000 IF(NCHAR1 .LE. 0)CALL OUTCON(0) !NO INIT-CONT. HOLDS FOR'S LAB 5 IF(NPAR .LE. 0) CALL OUTCON(LAB) !END OF FOR, TOP OF LOOP CONT IF(NPAR .LE. 0)RETURN C CALL COLECT(301,NCHAR2,NPAR,COND,ERR) !COLLECT & SAVE CONDITION IF(ERR)GO TO 1000 IF(NCHAR2 .LE. 0 .AND. NPAR .LE. 0) GO TO 5 C CALL OUTGO(LAB+2) !SKIP RE-INIT ON 1ST LOOP CALL OUTNUM(LAB) NCHAR3=0 IF(NPAR .GT. 0) CALL COLECT(0,NCHAR3,NPAR,COND,ERR) IF(ERR .OR. NPAR .GT. 0)GO TO 1000 IF(NCHAR3 .LE. 0)CALL OUTCON(0) !NO RE-INIT=>TOP OF LOOP CONT IF(NCHAR2 .LE. 0)CALL OUTCON(LAB+2) !NO TEST-LAB FOR INIT TO GOTO IF(NCHAR2 .LE. 0)RETURN CALL PUTBAK(')') !PUT COND BACK INTO INPUT CALL PBSTR(COND) !FOR IFGO TO HANDLE CALL PUTBAK('(') CALL OUTNUM(LAB+2) CALL IFGO(LAB+1) RETURN C 1000 CALL SKIPLF CALL ERROR('BAD FOR - CHECK FOR UNBALANCED PARENTHESES%') RETURN END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE COLECT(L,NUM,NPAR,HOLD,ERR) SUBROUTINE COLECT(L,NUM,NPAR,HOLD,ERR) INTEGER L,NUM,NPAR LOGICAL*1 HOLD(301),LEXSTR(101),NXTOK,TOK LOGICAL ERR C C GET NEXT PART OF FOR; PUT IN HOLD IF L >= 0 (L IS SIZE HOLD), ELSE OUTSTR IT C NUM=0 !COUNTS LOGICAL*1S IN HOLD ERR=.FALSE. IF(L .LE. 0)CALL OUTTAB C 10 TOK = NXTOK(LEXSTR,101) IF(TOK .EQ. "012 .OR. TOK .EQ. "004)GO TO 990 IF(TOK .EQ. ')')NPAR=NPAR-1 IF(TOK .EQ. '(')NPAR=NPAR+1 IF(TOK .EQ. ';' .OR. NPAR .LE. 0)GO TO 50 IF(L .GT. 0)GO TO 20 NUM = 1 !JUST SHOW >= 1 CHAR FOUND CALL OUTSTR(LEXSTR) GO TO 10 20 DO 30 I=1,L IF(LEXSTR(I) .EQ. "000)GO TO 10 NUM=NUM+1 IF(NUM .GT. L-1)GO TO 1000 HOLD(NUM) = LEXSTR(I) 30 CONTINUE GO TO 1000 C 50 IF(NPAR .GT. 1)GO TO 1000 IF(L .LE. 0 .AND. NUM .GT. 0)CALL OUTDON IF(L .GT. 0)HOLD(NUM+1)="000 IF(NPAR .LE. 0)RETURN TOK=NXTOK(LEXSTR,101) !PEEK AT TOKEN AFTER ; IF(TOK .EQ. ')')NPAR = 0 !REPLACE ;) BY ) IF(TOK .NE. ')')CALL PBSTR(LEXSTR) RETURN C 990 CALL PUTBAK(TOK) 1000 ERR=.TRUE. RETURN END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE DEFLST SUBROUTINE DEFLST LOGICAL*1 HOLD(8),LEXSTR(101),NXTOK LOGICAL ALLDIG DATA HOLD/6*' ',"012,"000/ C C DEFINELIST STATEMENT C IF(NXTOK(LEXSTR,101) .NE. 'A')GO TO 50 IF(.NOT. ALLDIG(LEXSTR))GO TO 50 L=LENGTH(LEXSTR) IF(L .GT. 5 .OR. 1 (L .EQ. 5 .AND. LEXSTR(1) .GT. '2'))GO TO 50 NUM=0 DO 10 I=1,6 HOLD(I)=' ' IF(I .LE. L)NUM = NUM*10 + (LEXSTR(I)-"060) 10 CONTINUE IF(NUM .EQ. 0)GO TO 50 20 L=ITOC(NUM,HOLD(2),5) IF(NXTOK(LEXSTR,101) .NE. 'A')GO TO 40 CALL PBSTR(HOLD) CALL PBSTR(LEXSTR) CALL DFINE NUM=NUM+1 GO TO 20 C 40 IF(LEXSTR(1) .EQ. "012)RETURN CALL PBSTR(LEXSTR) CALL SKIPLF CALL ERROR('BAD NAMES LIST%') RETURN 50 CALL ERROR('BAD INTEGER%') CALL SKIPLF RETURN END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE DFINE SUBROUTINE DFINE INTEGER FREE, NAMES(257), LONG(257) LOGICAL*1 LEXSTR(101),GETCHR,C,TABLE(2048),GETTOK COMMON /DEFN/ NAMES, LONG, TABLE,FREE C C DEFINE STATEMENT C C = GETTOK(LEXSTR,101) IF(C .NE. 'A')GO TO 100 !NO NAME IF(LOOKUP(LEXSTR,INDEX) .EQ. -1)GO TO 200 !NO ROOM IN TABLES NAMES(INDEX) = FREE LONG(INDEX) = LENGTH(LEXSTR)+1 !+1 FOR ENDING "000 I=FREE-1 C 10 I=I+1 IF(I .GT. 2048)GO TO 200 TABLE(I) = LEXSTR(I-FREE+1) IF(TABLE(I) .NE. "000)GO TO 10 C 20 IF(GETCHR(C) .EQ. ' ')GO TO 20 IF(C .EQ. "011)GO TO 20 !TABS IF(C .EQ. "004 .OR. C .EQ. "012)GO TO 100 !NO REPLACEMENT TEXT CALL PUTBAK(C) IF(C .EQ. '''')C=GETTOK(LEXSTR,101) !GETTOK GATHERS HOLL IF(C .EQ. '''')GO TO 40 DO 30 J=1,100 IF(GETCHR(C) .EQ. "004)GO TO 100 IF(C.EQ."011 .OR. C.EQ.' ' .OR. C.EQ."012)GO TO 35 LEXSTR(J) = C 30 CONTINUE GO TO 100 35 LEXSTR(J) = "000 40 DO 50 J=1,101 I=I+1 IF(I .GT. 2048)GO TO 200 TABLE(I)=LEXSTR(J) IF(TABLE(I) .EQ. "000)GO TO 60 50 CONTINUE C 60 FREE=I+1 IF(C .NE. "012)CALL SKIPLF RETURN 100 CALL PUTBAK(C) CALL ERROR('BAD DEFINE%') CALL SKIPLF RETURN 200 CALL ERROR('DEFINE TABLES OVERFLOWN-ABORT#') END C%%A-RCB-0047-SL-18-1 RAT -- INTEGER FUNCTION LOOKUP(STR,INDEX) INTEGER FUNCTION LOOKUP(STR,INDEX) LOGICAL*1 TABLE(2048),STR(1000) INTEGER LONG(257),NAMES(257),HASH,HASH1,REHASH,INDEX LOGICAL EQUAL COMMON /DEFN/ NAMES, LONG, TABLE C C RETURN INDEX OF STR IN NAMES TABLE IN LOOKUP AND INDEX C INDEX=HASH(STR) HASH1=INDEX DO 10 I=1,257 IF(NAMES(INDEX) .EQ. 0)GO TO 20 IF( EQUAL(TABLE(NAMES(INDEX)), STR) )GO TO 30 INDEX = REHASH(INDEX,HASH1) 10 CONTINUE C LOOKUP=-1 INDEX=-1 !TABLE IS FULL&NOT THERE RETURN C 20 LOOKUP=0 !NOT IN TABLE, BUT INDEX RETURN !SHOWS WHERE IT SHOULD GO C 30 LOOKUP=INDEX !GOT IT!! RETURN END C%%A-RCB-0047-SL-18-1 RAT -- LOGICAL FUNCTION REPLAC(STR) LOGICAL FUNCTION REPLAC(STR) LOGICAL*1 TABLE(2048),STR(1000) INTEGER LONG(257),NAMES(257),INDEX COMMON /DEFN/ NAMES, LONG, TABLE C C TRY TO REPLACE STR BY ITS DEFINE D VALUE; IF CAN'T, RETURN FALSE C REPLAC=.FALSE. IF(LOOKUP(STR,INDEX) .LE. 0)RETURN CALL PBSTR(TABLE(NAMES(INDEX)+LONG(INDEX))) REPLAC=.TRUE. RETURN END C%%A-RCB-0047-SL-18-1 RAT -- INTEGER FUNCTION HASH(STR) INTEGER FUNCTION HASH(STR) LOGICAL*1 STR(1000) C C COMPUTE HASH INDEX AS SUM CHARS MOD 257 + 1 (NOTE: 257 IS PRIME) C HASH=0 DO 10 I=1,1000 IF(STR(I) .EQ. "000)GO TO 20 HASH = HASH+STR(I) 10 CONTINUE 20 HASH=MOD(HASH,257)+1 RETURN END C%%A-RCB-0047-SL-18-1 RAT -- INTEGER FUNCTION REHASH(OLDHSH,HASH1) INTEGER FUNCTION REHASH(OLDHSH,HASH1) INTEGER HASH1,OLDHSH C C ADD THE HASH REHASH; SINCE TABLE SIZE PRIME, WILL VISIT EVERY ENTRY IN NAMES C REHASH=MOD(OLDHSH+HASH1,257)+1 RETURN END C%%A-RCB-0047-SL-18-1 RAT -- INTEGER FUNCTION LEX(LEXSTR) INTEGER FUNCTION LEX(LEXSTR) LOGICAL*1 NXTOK,LEXSTR(101),CHARS(4) LOGICAL LOOK,ALLDIG DATA CHARS/']', ';', '[', "004/ C C RETURN INTEGER REPRESENTING NEXT TOKEN-RATFOR KEYWORDS HAVE OWN INTEGER C 10 IF(NXTOK(LEXSTR,101) .EQ. "012) GO TO 10 !JUNK EMPTY/BLANK LINE DO 20 LEX=1,4 IF(CHARS(LEX) .EQ. LEXSTR(1))RETURN !CHECK FOR [ ] ; EOF 20 CONTINUE LEX=6 IF(ALLDIG(LEXSTR))RETURN !LABEL LEX=5 IF(.NOT. LOOK(LEXSTR,I)) RETURN !EXIT-NOTHING SPECIAL LEX=I+6 RETURN END C%%A-RCB-0047-SL-18-1 RAT -- LOGICAL FUNCTION LOOK(LEXSTR,IX) LOGICAL FUNCTION LOOK(LEXSTR,IX) LOGICAL*1 LEXSTR(101),TAB(71) INTEGER PNT(12) LOGICAL EQUAL DATA TAB/ 'I','F',"000,'E','L','S','E',"000 1 ,'W','H','I','L','E',"000,'R','E','P','E','A','T',"000 2 ,'U','N','T','I','L',"000,'F','O','R',"000 3 ,'D','O',"000,'B','R','E','A','K',"000 4 ,'N','E','X','T',"000,'D','E','F','I','N','E',"000 5,'I','N','C','L','U','D','E',"000 6,'D','E','F','I','N','E','L','I','S','T',"000/ DATA PNT/1,4,9,15,22,28,32,35,41,46,53,61/ C C SEE IF LEXSTR IS RATFOR KEYWORD C LOOK=.TRUE. DO 10 IX=1,12 IF(EQUAL(LEXSTR,TAB(PNT(IX))))RETURN 10 CONTINUE LOOK=.FALSE. RETURN END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE INCLUD SUBROUTINE INCLUD LOGICAL*1 GETCHR,C,FN(46),MCR(82),SW(2),MCRSAV(82) LOGICAL LISTSW(3) INTEGER POS,POSAVE COMMON /LUNS/ LUNIN,LUNOUT,LUNLST,LUNTTY COMMON /SWLIST/ LISTSW COMMON /MCRNFO/ MCR,POS DATA FN(1),FN(2),FN(3),FN(4),FN(5)/'[','1',',','1',']'/ C C INCLUDE STATEMENT C DO 5 I=1,82 MCRSAV(I)=MCR(I) 5 CONTINUE POSAVE=POS IF(LUNIN .GE. 3)GO TO 120 I=1 20 IF(GETCHR(C) .EQ. "004)GO TO 100 IF (C .EQ. "012 .OR. C .EQ. '#')GO TO 30 IF(C .EQ. ' ' .OR. C .EQ. "011)GO TO 20 IF(I .GT. 49)GO TO 100 MCR(I)=C I=I+1 GO TO 20 30 POS = 1 MCR(I) = "000 JUNK = NXTFIL('.RAT',FN(6),41,SW,2) LUNIN = LUNIN+1 LISTSW(LUNIN) = SW(1) .EQ. 'L' OPEN(UNIT=LUNIN,NAME=FN(6),TYPE='OLD',READONLY,ERR=40) GO TO 50 40 OPEN(UNIT=LUNIN,NAME=FN,TYPE='OLD',READONLY,ERR=110) 50 DO 60 I=1,82 MCR(I) = MCRSAV(I) 60 CONTINUE POS=POSAVE RETURN C 100 CALL PUTBAK(C) CALL ERROR('BAD INCLUDE%') CALL SKIPLF GO TO 50 110 CALL ERROR('CAN''T OPEN INCLUDE FILE%') LUNIN=LUNIN-1 GO TO 50 120 CALL ERROR('INCLUDES NESTED TOO DEEPLY%') CALL SKIPLF GO TO 50 END C%%A-RCB-0047-SL-18-1 RAT -- LOGICAL*1 FUNCTION NXTOK(T,N) LOGICAL*1 FUNCTION NXTOK(T,N) LOGICAL*1 T(N),GETTOK,C LOGICAL REPLAC C C GET NEXT TOKEN AND HANDLE RATFOR CONTINUATION. GETTOK DOES C MOST OF THE WORK. C KOUNT=0 !COUNTS # OF DEFINE REPLACEMENTS 5 NXTOK=GETTOK(T,N) IF(NXTOK .NE. 'A')GO TO 8 IF(.NOT. REPLAC(T)) GO TO 8 KOUNT=KOUNT+1 IF(KOUNT .LE. 100)GO TO 5 CALL ERROR('PROBABLE RECURSIVE DEFINE%') CALL SKIPLF GO TO 5 8 IF(NXTOK .NE. '_' .AND. NXTOK .NE. ',' 1 .AND. NXTOK .NE. '&' .AND. NXTOK .NE. "41)RETURN C = GETTOK(T,N) IF( C .NE. "012)GO TO 10 IF(NXTOK .EQ. '_')GO TO 5 T(1) = NXTOK RETURN 10 CALL PBSTR(T) T(1) = NXTOK T(2) ="000 RETURN END C%%A-RCB-0047-SL-18-1 RAT -- LOGICAL*1 FUNCTION GETTOK(LEXSTR,TOKSIZ) LOGICAL*1 FUNCTION GETTOK(LEXSTR,TOKSIZ) INTEGER TOKSIZ LOGICAL LOGOP,SWITCH LOGICAL*1 GETCHR,TYPE,C,LEXSTR(TOKSIZ) C 5 IF(GETCHR(C) .EQ. ' ')GO TO 5 IF(C .EQ. "011)GO TO 5 CALL PUTBAK(C) DO 20 I=1,TOKSIZ-1 GETTOK=TYPE(GETCHR(LEXSTR(I))) IF(GETTOK .NE. 'A' .AND. GETTOK .NE. '0')GO TO 30 IF(LEXSTR(I) .GE. "141 .AND. LEXSTR(I) .LE. "172) 1 LEXSTR(I)=LEXSTR(I)-"040 20 CONTINUE 25 CALL ERROR('TOKEN TOO LONG%') CALL SKIPLF LEXSTR(TOKSIZ)="000 RETURN 30 IF(I .LE. 1)GO TO 40 !JUMP IF SPECIAL CHAR CALL PUTBAK(LEXSTR(I)) !1 TOO FAR FOR NAMES LEXSTR(I)="000 GETTOK='A' RETURN 40 IF(LEXSTR(1) .NE. '''')GO TO 70 SWITCH=.FALSE. !TOGGLE SWITCH FOR EACH ' DO 45 I=2,TOKSIZ IF(GETCHR(LEXSTR(I)) .EQ. '''')GO TO 42 IF(SWITCH)GO TO 50 42 IF(LEXSTR(I) .EQ. '''')SWITCH = .NOT. SWITCH IF(LEXSTR(I) .EQ. "012 .OR. LEXSTR(I) .EQ. "004)GO TO 55 45 CONTINUE I=1 CALL SKIPLF GO TO 55 50 CALL PUTBAK(LEXSTR(I)) LEXSTR(I) = "000 RETURN 55 IF(LEXSTR(I) .EQ. "004)CALL PUTBAK("004) CALL ERROR('MISSING QUOTE FOR HOLLERITH%') GO TO 5 C 70 IF(LEXSTR(1) .NE. '#')GO TO 80 CALL SKIPLF LEXSTR(1) = "012 80 LEXSTR(2)="000 IF(LOGOP(LEXSTR(1)))GO TO 5 GETTOK=LEXSTR(1) RETURN END C%%A-RCB-0047-SL-18-1 RAT -- LOGICAL FUNCTION LOGOP(C1) LOGICAL FUNCTION LOGOP(C1) LOGICAL*1 C1,C2,GETCHR,SPEC(20),OSPEC(20) DATA SPEC/'=','=','^','=','<','>','>','<','>','=','=','>' 1 ,'=','<','<','=','<','<','>','>'/, 2 OSPEC/'E','Q','N','E','N','E','N','E','G','E','G','E','L','E', 3 'L','E','L','T','G','T'/ C C TRANSLATE RELATIONAL OPERATOR SHORTFORMS BUT LEAVE & , ! AND ^ FOR C OUTSTR SO THAT IFGO CAN LOOK FOR && AND !!. ALSO TRANSLATES THE C CURLY BRACKETS TO [ AND ], THE VERTICAL BAR TO !, AND THE TILDE TO ^. C LOGOP=.FALSE. IF(C1 .EQ. "173) C1= '[' IF(C1 .EQ. "174) C1 = '!' IF(C1 .EQ. "175) C1 = ']' IF(C1 .EQ. "176) C1 = '^' IF(C1 .NE. '>' .AND. C1 .NE. '<' .AND. C1 .NE. '=' 1 .AND. C1 .NE. '^')RETURN C2=GETCHR(C2) DO 10 I=1,20,2 IF(C1 .NE. SPEC(I) .OR. C2 .NE. SPEC(I+1))GO TO 10 CALL PUTBAK('.') CALL PUTBAK(OSPEC(I+1)) CALL PUTBAK(OSPEC(I)) CALL PUTBAK('.') LOGOP=.TRUE. RETURN 10 CONTINUE CALL PUTBAK(C2) RETURN END C%%A-RCB-0047-SL-18-1 RAT -- SUBROUTINE ERROR(MESS) SUBROUTINE ERROR(MESS) LOGICAL*1 MESS(100),BUF(101),BAKBUF(501) COMMON /LUNS/ LUNIN,LUNOUT,LUNLST,LUNTTY COMMON /INPUT/ BUF,BAKBUF,NOWBUF,NOWBAK,LNGTH COMMON /CLINE/ LINECT, NUMERR,LINF4P,LINES C C ERROR MESSAGE PRINTER C IF(LUNLST .LE. 0)WRITE(LUNTTY,10) LINECT,(BUF(I),I=1,LNGTH) 10 FORMAT(1X,I4,2X,100A1) LUN=LUNLST IF(LUNLST .LE. 0)LUN=LUNTTY DO 20 I=1,100 IF(MESS(I) .EQ. '%' .OR. MESS(I) .EQ. '@' 1 .OR. MESS(I) .EQ. '#')GO TO 30 20 CONTINUE MESS(2)='%' I=2 30 N=I-1 IF(MESS(I) .EQ. '@')WRITE(LUN,35)(MESS(K),K=1,N) IF(MESS(I) .NE. '@')WRITE(LUN,40)(MESS(K),K=1,N) WRITE(LUN,45) IF(MESS(I) .NE. '@')NUMERR=NUMERR+1 LINES=LINES+2 IF(MESS(I) .NE. '#')RETURN WRITE(LUNTTY,50) CALL EXIT 35 FORMAT(10X,'**WARNING: ',100A1) 40 FORMAT(10X,'****ERROR: ',100A1) 45 FORMAT(1X) 50 FORMAT('0RAT -- RUN ABORTED'/) END C%%A-RCB-0047-SL-18-1 RAT --