C define(VAX) C location of system-wide "SYMBOLS." file C maximum field for integer strings C must be highest lu for standard files C definitions for macro processor C put on a file named 'macsym' C pushback buffer for ngetch and putbak C max chars in a definition C max depth of file inclusion C max chars in all definitions C max chars in a token C number of characters per integer C----------------------------------------------------------------------- C definitions for the Ratfiv preprocessor C put on a file named 'ratsym' C max space for for reinit clauses C function name size in dfunct C max stack depth for parser C max length of format in read, write, encode,decode C max number of chars in string declares per module C max stack for switch statement C min number of cases to generate branch table C reciprocal of density neccessary for branch table C max chars in all definitions C literal toggle flag C number base flag C ARCHIVE RATFIV.HDR 51 27-DEC-81 22:35:41 C C C C RATFIV structured Fortran compiler C ================================== C C Authors: Original by B. Kernighan and P. J. Plauger, C with rewrites and enhancements by David Hanson and C friends (U. of Arizona), Joe Sventek and Debbie C Scherrer (Lawrence Berkely Laboratory), and C William P. Wood, Jr. (Institute For Cancer Research). C C Address: William P. Wood, Jr. C Computer Center C Institute For Cancer Research C 7701 Burholme Ave. C Philadelphia, Pa. 19111 C (215) 728 2760 C C Version: 2.0 C C Date: December 27, 1981 C C C C ******************************************************* C * * C * THIS SOFTWARE WAS DEVELOPED WITH SUPPORT * C * FROM THE NATIONAL INSTITUTES OF HEALTH: * C * NIH CA06927 * C * NIH CA22780 * C * * C * DIRECT INQUIRIES TO: * C * COMPUTER CENTER * C * THE INSTITUTE FOR CANCER RESEARCH * C * 7701 BURHOLME AVENUE * C * PHILADELPHIA, PENNSYLVANIA 19111 * C * * C * NO WARRANTY OR REPRESENTATION, EXPRESS OR * C * IMPLIED, IS MADE WITH RESPECT TO THE * C * CORRECTNESS, COMPLETENESS, OR USEFULNESS * C * OF THIS SOFTWARE, NOR THAT USE OF THIS * C * SOFTWARE MIGHT NOT INFRINGE PRIVATELY * C * OWNED RIGHTS. * C * * C * NO LIABILITY IS ASSUMED WITH RESPECT TO * C * THE USE OF, OR FOR DAMAGES RESULTING FROM * C * THE USE OF THIS SOFTWARE * C * * C ******************************************************* C C ARCHIVE ADDCHR.RAT 11 30-NOV-81 14:23:57 C addchr - put c in buf(bp) if it fits, increment bp SUBROUTINE ADDCHR(C, BUF, BP, MAXSIZ) INTEGER BP, MAXSIZ BYTE C, BUF(1) IF (.NOT.(BP .GT. MAXSIZ)) GOTO 2000 CALL FATAL('string buffer overflow.') 2000 CONTINUE BUF(BP) = C BP = BP + 1 RETURN END C ARCHIVE ADDSTR.RAT 10 30-NOV-81 14:23:57 C addstr - put s in buf(bp) by repeated calls to addchr SUBROUTINE ADDSTR(S, BUF, BP, MAXSIZ) BYTE S(1), BUF(1) INTEGER BP, MAXSIZ INTEGER I I = 1 2020 IF (.NOT.(S(I) .NE. 0)) GOTO 2040 CALL ADDCHR(S(I), BUF, BP, MAXSIZ) 2030 I = I + 1 GOTO 2020 2040 CONTINUE RETURN END C ARCHIVE BALPAR.RAT 34 30-NOV-81 14:23:57 C balpar - copy balanced paren string SUBROUTINE BALPAR BYTE GETTOK BYTE T, TOKEN(201) INTEGER NLPAR IF (.NOT.(GETTOK(TOKEN, 201) .NE. 40)) GOTO 2050 CALL SYNERR('missing left paren.') RETURN 2050 CONTINUE CALL OUTSTR(TOKEN) NLPAR = 1 2070 CONTINUE T = GETTOK(TOKEN, 201) IF (.NOT.(T .EQ. 59 .OR. T .EQ. -10 .OR. T .EQ. 93 .OR. T .EQ. 9 *1 .OR. (T .LT. 0 .AND. T .NE. 1))) GOTO 2100 CALL PBSTR(TOKEN) GOTO 2090 2100 CONTINUE IF (.NOT.(T .EQ. 10)) GOTO 2120 C delete newlines TOKEN(1) = 0 GOTO 2130 2120 CONTINUE IF (.NOT.(T .EQ. 40)) GOTO 2140 NLPAR = NLPAR + 1 GOTO 2130 2140 CONTINUE IF (.NOT.(T .EQ. 41)) GOTO 2160 NLPAR = NLPAR - 1 C else nothing special 2160 CONTINUE 2130 CONTINUE CALL OUTSTR(TOKEN) IF (.NOT.(T .EQ. 44)) GOTO 2180 CALL OUTCH(32) 2180 CONTINUE 2080 IF (.NOT.(NLPAR .LE. 0)) GOTO 2070 2090 CONTINUE IF (.NOT.(NLPAR .NE. 0)) GOTO 2200 CALL SYNERR('missing parenthesis in condition.') 2200 CONTINUE RETURN END C ARCHIVE BRKNXT.RAT 35 30-NOV-81 14:23:57 C brknxt - generate code for break n and next n; n = 1 is default SUBROUTINE BRKNXT(SP, LEXTYP, LABVAL, TOKEN) INTEGER LABVAL(100), LEXTYP(100), SP, TOKEN INTEGER I, N, ALLDIG, CTOI BYTE T, PTOKEN(201), GETTOK N = 0 T = GETTOK(PTOKEN, 201) IF (.NOT.(ALLDIG(PTOKEN) .EQ. 1)) GOTO 2220 C have break n or next n I = 1 N = CTOI(PTOKEN, I) - 1 GOTO 2230 2220 CONTINUE IF (.NOT.(T .NE. 59)) GOTO 2240 C default case CALL PBSTR(PTOKEN) 2240 CONTINUE 2230 CONTINUE I = SP 2260 IF (.NOT.(I .GT. 0)) GOTO 2280 IF (.NOT.(LEXTYP(I) .EQ. -64 .OR. LEXTYP(I) .EQ. -54 .OR. LEXTYP *(I) .EQ. -56 .OR. LEXTYP(I) .EQ. -61)) GOTO 2290 IF (.NOT.(N .GT. 0)) GOTO 2310 N = N - 1 C seek proper level GOTO 2270 2310 CONTINUE IF (.NOT.(TOKEN .EQ. -52)) GOTO 2330 C output break label LABVAL(I) = IABS(LABVAL(I)) CALL OUTGO(LABVAL(I) + 10, 1) GOTO 2340 2330 CONTINUE CALL OUTGO(IABS(LABVAL(I)), 1) 2340 CONTINUE RETURN 2290 CONTINUE 2270 I = I - 1 GOTO 2260 2280 CONTINUE IF (.NOT.(TOKEN .EQ. -52)) GOTO 2350 CALL SYNERR('illegal break.') GOTO 2360 2350 CONTINUE CALL SYNERR('illegal next.') 2360 CONTINUE RETURN END C ARCHIVE CASCOD.RAT 60 30-NOV-81 14:23:58 C switch statement - routines involved are cascod, caslab, swcode, swend, swvar C cascod - generate code for case or default label SUBROUTINE CASCOD(LAB, TOKEN) INTEGER LAB, TOKEN, L, LB, UB, I, J, LABGEN BYTE TOK(201), T, GETTOK, CASLAB C# Preprocessor common block used to hold switch info C Put on a file named 'cswtch' C Used only by ratfiv preprocessor COMMON/CSWTCH/SWTOP, SWLAST, SWSTAK(500) C current switch entry; init = 0 INTEGER SWTOP C next available position; init = 1 INTEGER SWLAST C switch information INTEGER SWSTAK IF (.NOT.(SWTOP .LE. 0)) GOTO 2370 CALL SYNERR('illegal case or default.') RETURN 2370 CONTINUE C terminate previous case CALL OUTGO(LAB + 10, 1) L = LABGEN(1) IF (.NOT.(TOKEN .EQ. -72)) GOTO 2390 C case n[,n]... : ... 2410 IF (.NOT.(CASLAB(LB, T) .NE. -10)) GOTO 2420 UB = LB IF (.NOT.(T .EQ. 45)) GOTO 2430 JUNK = CASLAB(UB, T) 2430 CONTINUE IF (.NOT.(LB .GT. UB)) GOTO 2450 CALL SYNERR('illegal range in case label.') UB = LB 2450 CONTINUE IF (.NOT.(SWLAST+3 .GT. 500)) GOTO 2470 CALL FATAL('switch table overflow.') 2470 CONTINUE I = SWTOP + 3 2490 IF (.NOT.(I .LT. SWLAST)) GOTO 2510 IF (.NOT.(LB .LE. SWSTAK(I))) GOTO 2520 GOTO 2510 2520 CONTINUE IF (.NOT.(LB .LE. SWSTAK(I+1))) GOTO 2540 CALL SYNERR('duplicate case label.') 2540 CONTINUE 2530 CONTINUE 2500 I = I + 3 GOTO 2490 2510 CONTINUE IF (.NOT.(I .LT. SWLAST .AND. UB .GE. SWSTAK(I))) GOTO 2560 CALL SYNERR('duplicate case label.') 2560 CONTINUE J = SWLAST 2580 IF (.NOT.(J .GT. I)) GOTO 2600 C insert new entry SWSTAK(J + 2) = SWSTAK(J - 1) 2590 J = J - 1 GOTO 2580 2600 CONTINUE SWSTAK(I) = LB SWSTAK(I + 1) = UB SWSTAK(I + 2) = L SWSTAK(SWTOP + 1) = SWSTAK(SWTOP + 1) + 1 SWLAST = SWLAST + 3 IF (.NOT.(T .NE. 44)) GOTO 2610 GOTO 2420 2610 CONTINUE GOTO 2410 2420 CONTINUE GOTO 2400 2390 CONTINUE C default : ... T = GETTOK(TOK, 201) IF (.NOT.(SWSTAK(SWTOP+2) .NE. 0)) GOTO 2630 CALL SYNERR('multiple defaults in switch statement.') GOTO 2640 2630 CONTINUE SWSTAK(SWTOP + 2) = L 2640 CONTINUE 2400 CONTINUE IF (.NOT.(T .EQ. -10)) GOTO 2650 CALL PUTBAK( - 10) GOTO 2660 2650 CONTINUE IF (.NOT.(T .NE. 58)) GOTO 2670 CALL SYNERR('missing colon in case or default label.') 2670 CONTINUE 2660 CONTINUE CALL INDEN( - (2)) CALL OUTCON(L) CALL INDEN(2) RETURN END C ARCHIVE CASLAB.RAT 33 30-NOV-81 14:23:58 C caslab - get one case label BYTE FUNCTION CASLAB(N, T) INTEGER N, I, S BYTE T, TOK(201), GETTOK, GTSKNL, ESC INTEGER CTOI, ALLDIG, ELENTH T = GTSKNL(TOK, 201) IF (.NOT.(T .EQ. -10)) GOTO 2690 CASLAB = T RETURN 2690 CONTINUE IF (.NOT.(T .EQ. 45)) GOTO 2710 S = - 1 GOTO 2720 2710 CONTINUE S = + 1 2720 CONTINUE IF (.NOT.(T .EQ. 45 .OR. T .EQ. 43)) GOTO 2730 T = GETTOK(TOK, 201) 2730 CONTINUE IF (.NOT.(ALLDIG(TOK) .EQ. 1)) GOTO 2750 I = 1 N = S*CTOI(TOK, I) GOTO 2760 2750 CONTINUE IF (.NOT.(((T) .EQ. 39 .OR. (T) .EQ. 34) .AND. ELENTH(TOK) .EQ. 3) *) GOTO 2770 C character constant I = 2 N = ESC(TOK, I) GOTO 2760 2770 CONTINUE CALL SYNERR('invalid case label.') N = 0 2760 CONTINUE T = GTSKNL(TOK, 201) CASLAB = T RETURN END C ARCHIVE DFUNCT.RAT 16 30-NOV-81 14:23:58 C dfunct - define the current function name SUBROUTINE DFUNCT C-------------------------------------------------------------------------- C# preprocessor common block to hold current function name C put on a file named 'cfname' C Used only by ratfiv preprocessor COMMON/CFNAME/FCNAME(35) Ctext of current function name BYTE FCNAME BYTE T, GETTOK BYTE FUNCT(9) DATA FUNCT(1)/102/,FUNCT(2)/117/,FUNCT(3)/110/,FUNCT(4)/99/,FUNCT( *5)/116/,FUNCT(6)/105/,FUNCT(7)/111/,FUNCT(8)/110/,FUNCT(9)/0/ T = GETTOK(FCNAME, 35) CALL PBSTR(FCNAME) CALL OTHERC(FUNCT) IF (.NOT.(T .NE. 1)) GOTO 2790 CALL ERRLIN(FCNAME) CALL SYNERR('bad function name.') FCNAME(1) = 0 2790 CONTINUE RETURN END C ARCHIVE DOBASE.RAT 24 30-NOV-81 14:23:58 C dobase - convert number in base to decimal SUBROUTINE DOBASE(BASE, TOKEN, TOKSIZ, I) INTEGER BASE, TOKSIZ, I, N, CN, ITOC BYTE TOKEN(1), C, NGETCH, CUPPER IF (.NOT.(BASE .GT. 1 .AND. BASE .LE. 36)) GOTO 2810 C got one N = 0 2830 CONTINUE C = CUPPER(NGETCH(C)) IF (.NOT.(C .GE. 65 .AND. C .LE. 90)) GOTO 2860 CN = C - 65 + 10 GOTO 2870 2860 CONTINUE IF (.NOT.(C .GE. 48 .AND. C .LE. 57)) GOTO 2880 CN = C - 48 GOTO 2870 2880 CONTINUE GOTO 2850 2870 CONTINUE IF (.NOT.(CN .GE. BASE)) GOTO 2900 CALL SYNERR('digit inconsistent with base.') 2900 CONTINUE 2840 N = BASE*N + CN GOTO 2830 2850 CONTINUE CALL PUTBAK(C) I = ITOC(N, TOKEN, TOKSIZ) GOTO 2820 2810 CONTINUE CALL SYNERR('number base out of range.') 2820 CONTINUE RETURN END C ARCHIVE DOCODE.RAT 18 30-NOV-81 14:23:59 C docode - generate code for beginning of do SUBROUTINE DOCODE(LAB) INTEGER LABGEN INTEGER LAB C-------------------------------------------------------------------- C# preprocessor common block to hold 'goto' flags and current label C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/LABEL, XFER C holds next label for goto, etc. INTEGER LABEL C YES if just made transfer; else NO INTEGER XFER BYTE DOSTR(4) DATA DOSTR(1)/100/,DOSTR(2)/111/,DOSTR(3)/32/,DOSTR(4)/0/ XFER = 0 CALL OUTTAB CALL OUTSTR(DOSTR) LAB = LABGEN(2) CALL OUTNUM(LAB) CALL OUTCH(32) CALL EATUP CALL INDEN(2) LAB = - LAB RETURN END C ARCHIVE DOSTAT.RAT 10 30-NOV-81 14:23:59 C dostat - generate code for end of do statement SUBROUTINE DOSTAT(LAB) INTEGER LAB CALL INDEN( - (2)) CALL OUTCON(IABS(LAB)) IF (.NOT.(LAB .GT. 0)) GOTO 2920 C break seen CALL OUTCON(LAB + 10) 2920 CONTINUE RETURN END C ARCHIVE EATUP.RAT 51 30-NOV-81 14:23:59 C eatup - process rest of statement SUBROUTINE EATUP BYTE GETTOK, TYPE BYTE PTOKEN(201), T, TOKEN(201) INTEGER NLPAR, LENGTH C------------------------------------------------------------------ C# preprocessor common block to hold output characters C put on a file named 'coutln' C Used only by ratfiv preprocessor COMMON/COUTLN/OUTP, INDENT, OUTBUF(134) C last position filled in outbuf; init = 0 INTEGER OUTP C current indent level (tab position) INTEGER INDENT C output lines collected here BYTE OUTBUF C------------------------------------------------------------------ NLPAR = 0 2940 CONTINUE T = GETTOK(TOKEN, 201) IF (.NOT.(T .EQ. 59 .OR. T .EQ. 10)) GOTO 2970 GOTO 2960 2970 CONTINUE IF (.NOT.(T .EQ. 93 .OR. T .EQ. 91 .OR. (T .LT. 0 .AND. T .NE. 1 *))) GOTO 2990 CALL PBSTR(TOKEN) GOTO 2960 2990 CONTINUE 2980 CONTINUE IF (.NOT.(T .EQ. -10)) GOTO 3010 CALL SYNERR('unexpected EOF.') CALL PBSTR(TOKEN) GOTO 2960 3010 CONTINUE IF (.NOT.(T .EQ. 44 .OR. T .EQ. 43 .OR. T .EQ. 45 .OR. T .EQ. 42 * .OR. T .EQ. 40 .OR. T .EQ. 38 .OR. T .EQ. 124 .OR. T .EQ. 33 .OR. * T .EQ. 61 .OR. T .EQ. 126 .OR. T .EQ. 94 .OR. T .EQ. 62 .OR. T .E *Q. 60 .OR. T .EQ. 92)) GOTO 3030 3050 IF (.NOT.(GETTOK(PTOKEN, 201) .EQ. 10)) GOTO 3060 GOTO 3050 3060 CONTINUE CALL PBSTR(PTOKEN) 3030 CONTINUE IF (.NOT.(T .EQ. 40)) GOTO 3070 NLPAR = NLPAR + 1 GOTO 3080 3070 CONTINUE IF (.NOT.(T .EQ. 41)) GOTO 3090 NLPAR = NLPAR - 1 3090 CONTINUE 3080 CONTINUE IF (.NOT.(T .EQ. 43 .OR. T .EQ. 45 .OR. TOKEN(1) .EQ. 61)) GOTO *3110 CALL OUTCH(32) CALL OUTSTR(TOKEN) CALL OUTCH(32) GOTO 3120 3110 CONTINUE IF (.NOT.((T .EQ. 1) .AND. (TYPE(OUTBUF(OUTP)) .EQ. 3))) GOTO 31 *30 CALL OUTCH(32) CALL OUTSTR(TOKEN) GOTO 3120 3130 CONTINUE IF (.NOT.(T .EQ. 44)) GOTO 3150 CALL OUTSTR(TOKEN) CALL OUTSTR(32) GOTO 3120 3150 CONTINUE CALL OUTSTR(TOKEN) 3120 CONTINUE 2950 IF (.NOT.(NLPAR .LT. 0)) GOTO 2940 2960 CONTINUE IF (.NOT.(NLPAR .NE. 0)) GOTO 3170 CALL SYNERR('unbalanced parentheses.') 3170 CONTINUE IF (.NOT.(T .NE. -51)) GOTO 3190 CALL OUTDON GOTO 3200 3190 CONTINUE CALL OUTCH(32) 3200 CONTINUE RETURN END C ARCHIVE ELENTH.RAT 18 16-DEC-81 23:13:26 C calculate length of buf, taking quotes and escaped characters into account C two quotes in a row in a quoted string count as one INTEGER FUNCTION ELENTH(BUF) BYTE BUF(1), C BYTE ESC, NQC INTEGER I, N IF (.NOT.(((BUF(1)) .EQ. 39 .OR. (BUF(1)) .EQ. 34))) GOTO 3210 N = 1 GOTO 3220 3210 CONTINUE N = 0 3220 CONTINUE I = N + 1 3230 IF (.NOT.(BUF(I) .NE. 0)) GOTO 3250 C = NQC(BUF, I, BUF(1), C) C = ESC(BUF, I) N = N + 1 3240 I = I + 1 GOTO 3230 3250 CONTINUE ELENTH = (N) RETURN END C ARCHIVE ELSEF.RAT 26 30-NOV-81 14:24:00 C elsef - generate code for end of if before else SUBROUTINE ELSEF(ENDLAB, ELSLAB, ELSTYP) INTEGER ENDLAB, ELSLAB, ELSTYP C------------------------------------------------------------------ C# preprocessor common block to hold flags C put on a file named 'cflags' C Used only by ratfiv preprocessor COMMON/CFLAGS/INFORM, F77, HOLLER C when .true., < and > aren't C converted to .lt. and .gt. C when .true., output is Fortran 77 C when .true., hollerith strings LOGICAL INFORM, F77, HOLLER C are output instead of quoted strings C-------------------------------------------------------------------- C# preprocessor common block to hold 'goto' flags and current label C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/LABEL, XFER C holds next label for goto, etc. INTEGER LABEL C YES if just made transfer; else NO INTEGER XFER BYTE ELSES(5) DATA ELSES(1)/101/,ELSES(2)/108/,ELSES(3)/115/,ELSES(4)/101/,ELSES *(5)/0/ IF (.NOT.(F77)) GOTO 3260 CALL INDEN( - (2)) CALL OUTTAB CALL OUTSTR(ELSES) IF (.NOT.(ELSTYP .EQ. -74)) GOTO 3280 CALL OUTCH(32) GOTO 3290 3280 CONTINUE CALL OUTDON 3290 CONTINUE GOTO 3270 3260 CONTINUE CALL OUTGO(ENDLAB, 1) CALL INDEN( - (2)) CALL OUTCON(ELSLAB) 3270 CONTINUE IF (.NOT.(ELSTYP .EQ. -55)) GOTO 3300 CALL INDEN(2) 3300 CONTINUE XFER = 0 RETURN END C ARCHIVE FCLAUS.RAT 33 30-NOV-81 14:24:00 C process "for" init or re-init clause SUBROUTINE FCLAUS BYTE GETTOK BYTE TOKEN(201), T INTEGER BRACK IF (.NOT.(GETTOK(TOKEN, 201) .EQ. 91)) GOTO 3320 C { mother } BRACK = 1 GOTO 3330 3320 CONTINUE CALL PBSTR(TOKEN) C other BRACK = 0 3330 CONTINUE 3340 CONTINUE T = GETTOK(TOKEN, 201) IF (.NOT.(T .EQ. 93 .AND. BRACK .EQ. 1)) GOTO 3370 IF (.NOT.(GETTOK(TOKEN, 201) .NE. 59)) GOTO 3390 CALL SYNERR('invalid for clause.') CALL PBSTR(TOKEN) 3390 CONTINUE GOTO 3360 3370 CONTINUE IF (.NOT.(T .EQ. -10)) GOTO 3410 CALL PBSTR(TOKEN) CALL SYNERR('unexpected EOF.') GOTO 3360 3410 CONTINUE IF (.NOT.(T .NE. 59)) GOTO 3430 CALL OTHERC(TOKEN) 3430 CONTINUE 3350 IF (.NOT.(BRACK .EQ. 0)) GOTO 3340 3360 CONTINUE RETURN END C ARCHIVE FORCOD.RAT 109 30-NOV-81 14:24:00 C forcod - beginning of for statement SUBROUTINE FORCOD(LAB) BYTE GETTOK BYTE T, TOKEN(201) INTEGER LENGTH, LABGEN INTEGER I, J, LAB, NLPAR C .true. if condition part is empty LOGICAL EMPTYC C-------------------------------------------------------------------------- C# preprocessor common block to hold info about 'for' statements C put on a file named 'cfor' C Used only by ratfiv preprocessor COMMON/CFOR/FORDEP, FORSTK(250) C current depth of for statements INTEGER FORDEP C stack of reinit strings BYTE FORSTK C------------------------------------------------------------------ C# preprocessor common block to hold flags C put on a file named 'cflags' C Used only by ratfiv preprocessor COMMON/CFLAGS/INFORM, F77, HOLLER C when .true., < and > aren't C converted to .lt. and .gt. C when .true., output is Fortran 77 C when .true., hollerith strings LOGICAL INFORM, F77, HOLLER C are output instead of quoted strings BYTE IFNOT(10) BYTE WHILES(10) BYTE TRUES(9) DATA IFNOT(1)/105/,IFNOT(2)/102/,IFNOT(3)/32/,IFNOT(4)/40/,IFNOT(5 *)/46/,IFNOT(6)/110/,IFNOT(7)/111/,IFNOT(8)/116/,IFNOT(9)/46/,IFNOT *(10)/0/ DATA WHILES(1)/100/,WHILES(2)/111/,WHILES(3)/32/,WHILES(4)/119/,WH *ILES(5)/104/,WHILES(6)/105/,WHILES(7)/108/,WHILES(8)/101/,WHILES(9 *)/32/,WHILES(10)/0/ DATA TRUES(1)/40/,TRUES(2)/46/,TRUES(3)/116/,TRUES(4)/114/,TRUES(5 *)/117/,TRUES(6)/101/,TRUES(7)/46/,TRUES(8)/41/,TRUES(9)/0/ EMPTYC = .FALSE. LAB = LABGEN(3) CALL OUTCON(0) IF (.NOT.(GETTOK(TOKEN, 201) .NE. 40)) GOTO 3450 CALL SYNERR('missing left paren.') RETURN 3450 CONTINUE IF (.NOT.(GETTOK(TOKEN, 201) .NE. 59)) GOTO 3470 C real init clause CALL PBSTR(TOKEN) CALL FCLAUS 3470 CONTINUE IF (.NOT.(GETTOK(TOKEN, 201) .EQ. 59)) GOTO 3490 C empty condition EMPTYC = .TRUE. IF (.NOT.(F77)) GOTO 3510 CALL OUTTAB CALL OUTSTR(WHILES) CALL OUTSTR(TRUES) CALL OUTDON GOTO 3520 3510 CONTINUE CALL OUTCON(LAB) 3520 CONTINUE GOTO 3500 3490 CONTINUE C non-empty condition CALL PBSTR(TOKEN) IF (.NOT.(F77)) GOTO 3530 CALL OUTTAB CALL OUTSTR(WHILES) GOTO 3540 3530 CONTINUE CALL OUTNUM(LAB) CALL OUTTAB CALL OUTSTR(IFNOT) 3540 CONTINUE CALL OUTCH(40) NLPAR = 0 3550 IF (.NOT.(NLPAR .GE. 0)) GOTO 3560 T = GETTOK(TOKEN, 201) IF (.NOT.(T .EQ. 59)) GOTO 3570 GOTO 3560 3570 CONTINUE IF (.NOT.(T .EQ. 40)) GOTO 3590 NLPAR = NLPAR + 1 GOTO 3600 3590 CONTINUE IF (.NOT.(T .EQ. 41)) GOTO 3610 NLPAR = NLPAR - 1 3610 CONTINUE 3600 CONTINUE IF (.NOT.(T .EQ. -10)) GOTO 3630 CALL PBSTR(TOKEN) RETURN 3630 CONTINUE IF (.NOT.(T .NE. 10)) GOTO 3650 CALL OUTSTR(TOKEN) 3650 CONTINUE GOTO 3550 3560 CONTINUE CALL OUTCH(41) IF (.NOT.(F77)) GOTO 3670 CALL OUTDON GOTO 3680 3670 CONTINUE CALL OUTCH(41) CALL OUTCH(32) CALL OUTGO(LAB + 20, 0) 3680 CONTINUE IF (.NOT.(NLPAR .LT. 0)) GOTO 3690 CALL SYNERR('invalid for clause.') 3690 CONTINUE 3500 CONTINUE C stack reinit clause FORDEP = FORDEP + 1 J = 1 I = 1 3710 IF (.NOT.(I .LT. FORDEP)) GOTO 3730 C find end J = J + LENGTH(FORSTK(J)) + 1 3720 I = I + 1 GOTO 3710 3730 CONTINUE C null, in case no reinit FORSTK(J) = 0 NLPAR = 0 3740 IF (.NOT.(NLPAR .GE. 0)) GOTO 3750 T = GETTOK(TOKEN, 201) IF (.NOT.(T .EQ. 40)) GOTO 3760 NLPAR = NLPAR + 1 GOTO 3770 3760 CONTINUE IF (.NOT.(T .EQ. 41)) GOTO 3780 NLPAR = NLPAR - 1 3780 CONTINUE 3770 CONTINUE IF (.NOT.(T .EQ. -10)) GOTO 3800 CALL PBSTR(TOKEN) GOTO 3750 3800 CONTINUE IF (.NOT.(NLPAR .GE. 0 .AND. T .NE. 10)) GOTO 3820 IF (.NOT.(T .EQ. 43 .OR. T .EQ. 45 .OR. TOKEN(1) .EQ. 61)) GOT *O 3840 TOKEN(1) = 32 TOKEN(2) = T TOKEN(3) = 32 TOKEN(4) = 0 GOTO 3850 3840 CONTINUE IF (.NOT.(T .EQ. 44)) GOTO 3860 TOKEN(2) = 32 TOKEN(3) = 0 3860 CONTINUE 3850 CONTINUE IF (.NOT.(J+LENGTH(TOKEN) .GE. 250)) GOTO 3880 CALL FATAL('for clause too long.') 3880 CONTINUE CALL SCOPY(TOKEN, 1, FORSTK, J) J = J + LENGTH(TOKEN) 3820 CONTINUE GOTO 3740 3750 CONTINUE CALL INDEN(2) C label for next's LAB = LAB + 10 IF (.NOT.(F77 .OR. EMPTYC)) GOTO 3900 LAB = - LAB 3900 CONTINUE RETURN END C ARCHIVE FORMA.RAT 81 30-NOV-81 14:24:00 C forma - output format statement for write, read, encode, and decode SUBROUTINE FORMA(TOKEN) BYTE TOKEN(1), T, TOK(201), FORST(600) BYTE GETTOK, GTSKNL INTEGER J, LENGTH, LABGEN, LAB C------------------------------------------------------------------ C# preprocessor common block to hold flags C put on a file named 'cflags' C Used only by ratfiv preprocessor COMMON/CFLAGS/INFORM, F77, HOLLER C when .true., < and > aren't C converted to .lt. and .gt. C when .true., output is Fortran 77 C when .true., hollerith strings LOGICAL INFORM, F77, HOLLER C are output instead of quoted strings BYTE FORM(7) DATA FORM(1)/102/,FORM(2)/111/,FORM(3)/114/,FORM(4)/109/,FORM(5)/9 *7/,FORM(6)/116/,FORM(7)/0/ CALL OUTTAB CALL OUTSTR(TOKEN) T = GETTOK(TOK, 201) IF (.NOT.(T .NE. 40)) GOTO 3920 CALL PBSTR(TOK) CALL EATUP RETURN 3920 CONTINUE CALL OUTSTR(TOK) CALL SKPOUT(T) IF (.NOT.(T .EQ. -10)) GOTO 3940 RETURN 3940 CONTINUE IF (.NOT.(T .EQ. 41)) GOTO 3960 CALL EATUP RETURN 3960 CONTINUE T = GTSKNL(TOK, 201) IF (.NOT.(T .NE. 40)) GOTO 3980 CALL PBSTR(TOK) 4000 CONTINUE CALL SKPOUT(T) IF (.NOT.(T .EQ. -10)) GOTO 4030 RETURN 4030 CONTINUE 4010 IF (.NOT.(T .EQ. 41)) GOTO 4000 CALL EATUP GOTO 3990 3980 CONTINUE LAB = LABGEN(1) CALL OUTNUM(LAB) J = 1 FORST(1) = 0 NLPAR = 0 Cdon't convert < and > to .lt. and .gt. INFORM = .TRUE. 4050 CONTINUE T = GETTOK(TOK, 201) IF (.NOT.(T .EQ. -10)) GOTO 4080 CALL PBSTR(TOK) CALL SYNERR('unexpected EOF.') INFORM = .FALSE. RETURN 4080 CONTINUE IF (.NOT.(T .EQ. 40)) GOTO 4100 NLPAR = NLPAR + 1 GOTO 4110 4100 CONTINUE IF (.NOT.(T .EQ. 41)) GOTO 4120 NLPAR = NLPAR - 1 4120 CONTINUE 4110 CONTINUE IF (.NOT.(NLPAR .GE. 0 .AND. T .NE. 10)) GOTO 4140 IF (.NOT.(J+LENGTH(TOK) .GE. 600)) GOTO 4160 CALL SYNERR('format too long.') GOTO 4070 4160 CONTINUE CALL SCOPY(TOK, 1, FORST, J) J = J + LENGTH(TOK) 4140 CONTINUE 4060 IF (.NOT.(NLPAR .LT. 0)) GOTO 4050 4070 CONTINUE INFORM = .FALSE. 4180 CONTINUE CALL SKPOUT(T) IF (.NOT.(T .EQ. -10)) GOTO 4210 RETURN 4210 CONTINUE 4190 IF (.NOT.(T .EQ. 41)) GOTO 4180 CALL EATUP CALL INDEN(2) CALL OUTNUM(LAB) CALL OUTTAB CALL OUTSTR(FORM) CALL OUTCH(40) CALL OUTSTR(FORST) CALL OUTCH(41) CALL OUTDON CALL INDEN( - (2)) 3990 CONTINUE RETURN END C ARCHIVE FORS.RAT 34 30-NOV-81 14:24:01 C fors - process end of for statement SUBROUTINE FORS(LAB) INTEGER LENGTH INTEGER I, J, LAB C-------------------------------------------------------------------------- C# preprocessor common block to hold info about 'for' statements C put on a file named 'cfor' C Used only by ratfiv preprocessor COMMON/CFOR/FORDEP, FORSTK(250) C current depth of for statements INTEGER FORDEP C stack of reinit strings BYTE FORSTK C-------------------------------------------------------------------- C# preprocessor common block to hold 'goto' flags and current label C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/LABEL, XFER C holds next label for goto, etc. INTEGER LABEL C YES if just made transfer; else NO INTEGER XFER C------------------------------------------------------------------ C# preprocessor common block to hold flags C put on a file named 'cflags' C Used only by ratfiv preprocessor COMMON/CFLAGS/INFORM, F77, HOLLER C when .true., < and > aren't C converted to .lt. and .gt. C when .true., output is Fortran 77 C when .true., hollerith strings LOGICAL INFORM, F77, HOLLER C are output instead of quoted strings BYTE ENDDOS(7) DATA ENDDOS(1)/101/,ENDDOS(2)/110/,ENDDOS(3)/100/,ENDDOS(4)/32/,EN *DDOS(5)/100/,ENDDOS(6)/111/,ENDDOS(7)/0/ XFER = 0 J = 1 I = 1 4230 IF (.NOT.(I .LT. FORDEP)) GOTO 4250 J = J + LENGTH(FORSTK(J)) + 1 4240 I = I + 1 GOTO 4230 4250 CONTINUE CALL OUTNUM(IABS(LAB)) IF (.NOT.(LENGTH(FORSTK(J)) .GT. 0)) GOTO 4260 CALL PUTBAK(59) CALL PBSTR(FORSTK(J)) CALL FCLAUS GOTO 4270 4260 CONTINUE IF (.NOT.(F77)) GOTO 4280 CALL OUTCON(0) 4280 CONTINUE 4270 CONTINUE CALL INDEN( - (2)) IF (.NOT.(F77)) GOTO 4300 CALL OUTTAB CALL OUTSTR(ENDDOS) CALL OUTDON GOTO 4310 4300 CONTINUE CALL OUTGO(IABS(LAB) - 10, 1) 4310 CONTINUE IF (.NOT.(LAB .GT. 0)) GOTO 4320 CALL OUTCON(LAB + 10) 4320 CONTINUE FORDEP = FORDEP - 1 RETURN END C ARCHIVE GETTOK.RAT 10 30-NOV-81 14:24:01 C gettok - get token after processing by deftok BYTE FUNCTION GETTOK(TOKEN, TOKSIZ) BYTE TOKEN(1), DEFTOK INTEGER TOKSIZ 4340 CONTINUE GETTOK = DEFTOK(TOKEN, TOKSIZ) 4350 IF (.NOT.(GETTOK .NE. 32 .AND. GETTOK .NE. 9)) GOTO 4340 RETURN END C ARCHIVE GTOKENR.RAT 121 15-DEC-81 23:44:58 C gtoken - get token for Ratfiv BYTE FUNCTION GTOKEN(TOKEN, TOKSIZ) BYTE NGETCH, TYPE INTEGER I, TOKSIZ, J, CTOI, ALLDIG BYTE C, TOKEN(1) C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV BYTE TOOLNG(16) DATA TOOLNG(1)/116/,TOOLNG(2)/111/,TOOLNG(3)/107/,TOOLNG(4)/101/,T *OOLNG(5)/110/,TOOLNG(6)/32/,TOOLNG(7)/116/,TOOLNG(8)/111/,TOOLNG(9 *)/111/,TOOLNG(10)/32/,TOOLNG(11)/108/,TOOLNG(12)/111/,TOOLNG(13)/1 *10/,TOOLNG(14)/103/,TOOLNG(15)/46/,TOOLNG(16)/0/ I = 1 4370 IF (.NOT.(I .LE. TOKSIZ)) GOTO 4390 GTOKEN = TYPE(NGETCH(TOKEN(I))) IF (.NOT.(GTOKEN .NE. 3 .AND. GTOKEN .NE. 2 .AND. GTOKEN .NE. 95 * .AND. GTOKEN .NE. 36)) GOTO 4400 GOTO 4390 4400 CONTINUE 4380 I = I + 1 GOTO 4370 4390 CONTINUE C = TOKEN(1) IF (.NOT.(I .GT. 1)) GOTO 4420 C some alpha seen GTOKEN = 1 IF (.NOT.(I .GT. TOKSIZ)) GOTO 4440 I = TOKSIZ - 1 CALL SYNERR(TOOLNG) GOTO 4450 4440 CONTINUE C = TOKEN(I) TOKEN(I) = 0 I = I - 1 IF (.NOT.(C .EQ. 37)) GOTO 4460 C check for base other than 10 IF (.NOT.(ALLDIG(TOKEN) .EQ. 1)) GOTO 4480 J = 1 CALL DOBASE(CTOI(TOKEN, J), TOKEN, TOKSIZ, I) IF (.NOT.(TOKEN(1) .EQ. 45)) GOTO 4500 GTOKEN = 45 I = 1 CALL PBSTR(TOKEN(2)) 4500 CONTINUE GOTO 4490 4480 CONTINUE CALL PUTBAK(37) 4490 CONTINUE GOTO 4470 4460 CONTINUE CALL PUTBAK(C) 4470 CONTINUE 4450 CONTINUE GOTO 4430 4420 CONTINUE IF (.NOT.(((C) .EQ. 39 .OR. (C) .EQ. 34) .OR. C .EQ. 96)) GOTO 452 *0 C Accented strings are passed through as literal strings, with the accents C being stripped off of the output. Any characters (except EOF) may appear C within accents. C Two occurrences of the initial quote character (', ", or `) within a string C in a row are interpreted as a single literal occurrence of that character. C Unbalanced occurrences of ' or " are allowed on a line and are passed C through as themselves. GTOKEN = C I = 2 4540 IF (.NOT.(I .LT. TOKSIZ)) GOTO 4560 IF (.NOT.(NGETCH(TOKEN(I)) .EQ. C)) GOTO 4570 IF (.NOT.(NGETCH(TOKEN(I+1)) .NE. C)) GOTO 4590 CALL PUTBAK(TOKEN(I + 1)) GOTO 4560 4590 CONTINUE I = I + 1 4600 CONTINUE GOTO 4580 4570 CONTINUE IF (.NOT.(C .EQ. 96 .AND. TOKEN(I) .EQ. -10)) GOTO 4610 CALL SYNERR('EOF in literal string.') TOKEN(I) = 96 CALL PUTBAK( - 10) GOTO 4560 4610 CONTINUE IF (.NOT.(C .NE. 96 .AND. (TOKEN(I) .EQ. 10 .OR. TOKEN(I) .EQ. * -10))) GOTO 4630 IF (.NOT.(TOKEN(I) .EQ. -10)) GOTO 4650 CALL SYNERR('EOF in quoted string.') C allow unbalanced quote on line 4650 CONTINUE 4670 IF (.NOT.(I .GT. 1 .AND. TOKEN(I) .NE. C)) GOTO 4690 CALL PUTBAK(TOKEN(I)) 4680 I = I - 1 GOTO 4670 4690 CONTINUE IF (.NOT.(I .GT. 1)) GOTO 4700 CALL PUTBAK(C) I = I - 1 4700 CONTINUE GOTO 4560 4630 CONTINUE 4580 CONTINUE 4550 I = I + 1 GOTO 4540 4560 CONTINUE IF (.NOT.(I .GE. TOKSIZ)) GOTO 4720 IF (.NOT.(C .EQ. 96)) GOTO 4740 CALL SYNERR('missing accent.') GOTO 4750 4740 CONTINUE CALL SYNERR('missing quote.') 4750 CONTINUE CALL SYNERR(TOOLNG) IF (.NOT.(TOKEN(I-1) .EQ. C)) GOTO 4760 I = I - 2 GOTO 4770 4760 CONTINUE I = I - 1 4770 CONTINUE TOKEN(I) = C 4720 CONTINUE GOTO 4430 4520 CONTINUE IF (.NOT.(CP .EQ. 0)) GOTO 4780 C not in a macro? IF (.NOT.(C .EQ. 123)) GOTO 4800 C allow { for [ TOKEN(1) = 91 GTOKEN = 91 GOTO 4810 4800 CONTINUE IF (.NOT.(C .EQ. 125)) GOTO 4820 C allow } for ] TOKEN(1) = 93 GTOKEN = 93 GOTO 4810 4820 CONTINUE IF (.NOT.(C .EQ. 35)) GOTO 4840 C output comments CALL OUTCOM(TOKEN) TOKEN(1) = 10 GTOKEN = 10 GOTO 4810 4840 CONTINUE IF (.NOT.(C .EQ. 62 .OR. C .EQ. 60 .OR. C .EQ. 126 .OR. C .EQ. 3 *3 .OR. C .EQ. 94 .OR. C .EQ. 92 .OR. C .EQ. 61 .OR. C .EQ. 38 .OR. * C .EQ. 124)) GOTO 4860 IF (.NOT.(TOKSIZ .LT. 11)) GOTO 4880 CALL SYNERR('gtoken: shouldn''t happen.') GOTO 4890 4880 CONTINUE CALL RELATE(TOKEN, I) 4890 CONTINUE 4860 CONTINUE 4810 CONTINUE 4780 CONTINUE 4430 CONTINUE TOKEN(I + 1) = 0 RETURN END C ARCHIVE GTSKNL.RAT 10 30-NOV-81 14:24:02 C gtsknl - get next token, skip newlines BYTE FUNCTION GTSKNL(TOKEN, TOKSIZ) BYTE TOKEN(1), GETTOK INTEGER TOKSIZ 4900 CONTINUE GTSKNL = GETTOK(TOKEN, TOKSIZ) 4910 IF (.NOT.(GTSKNL .NE. 10)) GOTO 4900 RETURN END C ARCHIVE IFCODE.RAT 25 30-NOV-81 14:24:02 C ifcode - generate initial code for if SUBROUTINE IFCODE(LAB) INTEGER LABGEN INTEGER LAB C------------------------------------------------------------------ C# preprocessor common block to hold flags C put on a file named 'cflags' C Used only by ratfiv preprocessor COMMON/CFLAGS/INFORM, F77, HOLLER C when .true., < and > aren't C converted to .lt. and .gt. C when .true., output is Fortran 77 C when .true., hollerith strings LOGICAL INFORM, F77, HOLLER C are output instead of quoted strings C-------------------------------------------------------------------- C# preprocessor common block to hold 'goto' flags and current label C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/LABEL, XFER C holds next label for goto, etc. INTEGER LABEL C YES if just made transfer; else NO INTEGER XFER BYTE IFS(4) BYTE THENS(6) DATA IFS(1)/105/,IFS(2)/102/,IFS(3)/32/,IFS(4)/0/ DATA THENS(1)/32/,THENS(2)/116/,THENS(3)/104/,THENS(4)/101/,THENS( *5)/110/,THENS(6)/0/ XFER = 0 IF (.NOT.(F77)) GOTO 4930 CALL OUTTAB CALL OUTSTR(IFS) CALL BALPAR CALL OUTSTR(THENS) CALL OUTDON GOTO 4940 4930 CONTINUE LAB = LABGEN(2) CALL IFGO(LAB) 4940 CONTINUE CALL INDEN(2) RETURN END C ARCHIVE IFGO.RAT 13 30-NOV-81 14:24:02 C ifgo - generate 'if (.not.(...)) goto lab' SUBROUTINE IFGO(LAB) INTEGER LAB BYTE IFNOT(10) DATA IFNOT(1)/105/,IFNOT(2)/102/,IFNOT(3)/32/,IFNOT(4)/40/,IFNOT(5 *)/46/,IFNOT(6)/110/,IFNOT(7)/111/,IFNOT(8)/116/,IFNOT(9)/46/,IFNOT *(10)/0/ C get to column 7 CALL OUTTAB C 'if (.not.' CALL OUTSTR(IFNOT) C collect and output condition CALL BALPAR C ')' CALL OUTCH(41) CALL OUTCH(32) C ' goto lab' CALL OUTGO(LAB, 0) RETURN END C ARCHIVE IFS.RAT 24 30-NOV-81 14:24:02 C ifs - generate code for end of if SUBROUTINE IFS(SP, LEXTYP, LABVAL) INTEGER SP, LEXTYP(100), LABVAL(100) C------------------------------------------------------------------ C# preprocessor common block to hold flags C put on a file named 'cflags' C Used only by ratfiv preprocessor COMMON/CFLAGS/INFORM, F77, HOLLER C when .true., < and > aren't C converted to .lt. and .gt. C when .true., output is Fortran 77 C when .true., hollerith strings LOGICAL INFORM, F77, HOLLER C are output instead of quoted strings C-------------------------------------------------------------------- C# preprocessor common block to hold 'goto' flags and current label C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/LABEL, XFER C holds next label for goto, etc. INTEGER LABEL C YES if just made transfer; else NO INTEGER XFER BYTE ENDIFS(7) DATA ENDIFS(1)/101/,ENDIFS(2)/110/,ENDIFS(3)/100/,ENDIFS(4)/32/,EN *DIFS(5)/105/,ENDIFS(6)/102/,ENDIFS(7)/0/ XFER = 0 CALL INDEN( - (2)) IF (.NOT.(F77)) GOTO 4950 CALL OUTTAB CALL OUTSTR(ENDIFS) CALL OUTDON GOTO 4960 4950 CONTINUE I4970 = (LEXTYP(SP)) GOTO 4970 4990 CONTINUE CALL OUTCON(LABVAL(SP)) GOTO 4980 5000 CONTINUE CALL OUTCON(LABVAL(SP - 1)) GOTO 4980 5010 CONTINUE CALL OUTCON(LABVAL(SP)) CALL OUTCON(LABVAL(SP - 1)) GOTO 4980 4970 CONTINUE IF (I4970 .EQ. -74) GOTO 5010 IF (I4970 .EQ. -57) GOTO 4990 IF (I4970 .EQ. -55) GOTO 5000 4980 CONTINUE 4960 CONTINUE SP = SP - 1 RETURN END C ARCHIVE INDEN.RAT 8 30-NOV-81 14:24:03 C inden - indent or outdent the tab position SUBROUTINE INDEN(IND) INTEGER IND C------------------------------------------------------------------ C# preprocessor common block to hold output characters C put on a file named 'coutln' C Used only by ratfiv preprocessor COMMON/COUTLN/OUTP, INDENT, OUTBUF(134) C last position filled in outbuf; init = 0 INTEGER OUTP C current indent level (tab position) INTEGER INDENT C output lines collected here BYTE OUTBUF C------------------------------------------------------------------ INDENT = MAX0(0, INDENT + IND) RETURN END C ARCHIVE INIRAT.RAT 97 30-NOV-81 14:24:03 C inirat - initialize table and install keywords SUBROUTINE INIRAT INTEGER SET BYTE SDEFIN(7), VDEFIN(2) BYTE SINCLU(8), VINCLU(2) BYTE SFUNCT(9), VFUNCT(2) BYTE SDO(3), VDO(2) BYTE SIF(3), VIF(2) BYTE SELSE(5), VELSE(2) BYTE SWHILE(6), VWHILE(2) BYTE SFOR(4), VFOR(2) BYTE SREPEA(7), VREPEA(2) BYTE SUNTIL(6), VUNTIL(2) BYTE SNEXT(5), VNEXT(2) BYTE SBREAK(6), VBREAK(2) BYTE SRETUR(7), VRETUR(2) BYTE SREAD(5), VREAD(2) BYTE SWRITE(6), VWRITE(2) BYTE SENCOD(7), VENCOD(2) BYTE SDECOD(7), VDECOD(2) BYTE SFORMA(7), VFORMA(2) BYTE SSTRNG(7), VSTRNG(2) BYTE SSWTCH(7), VSWTCH(2) BYTE SCASE(5), VCASE(2) BYTE SDEFAL(8), VDEFAL(2) DATA SDEFIN/100, 101, 102, 105, 110, 101, 0/, VDEFIN/ - 20, 0/ DATA SINCLU/105, 110, 99, 108, 117, 100, 101, 0/, VINCLU/ - 50, 0/ DATA SFUNCT/102, 117, 110, 99, 116, 105, 111, 110, 0/, VFUNCT/ - 5 *1, 0/ DATA SDO/100, 111, 0/, VDO/ - 54, 0/ DATA SIF/105, 102, 0/, VIF/ - 57, 0/ DATA SELSE/101, 108, 115, 101, 0/, VELSE/ - 55, 0/ DATA SWHILE/119, 104, 105, 108, 101, 0/, VWHILE/ - 64, 0/ DATA SFOR/102, 111, 114, 0/, VFOR/ - 56, 0/ DATA SREPEA/114, 101, 112, 101, 97, 116, 0/, VREPEA/ - 61, 0/ DATA SUNTIL/117, 110, 116, 105, 108, 0/, VUNTIL/ - 63, 0/ DATA SNEXT/110, 101, 120, 116, 0/, VNEXT/ - 59, 0/ DATA SBREAK/98, 114, 101, 97, 107, 0/, VBREAK/ - 52, 0/ DATA SRETUR/114, 101, 116, 117, 114, 110, 0/, VRETUR/ - 62, 0/ DATA SREAD/114, 101, 97, 100, 0/, VREAD/ - 66, 0/ DATA SWRITE/119, 114, 105, 116, 101, 0/, VWRITE/ - 65, 0/ DATA SENCOD/101, 110, 99, 111, 100, 101, 0/, VENCOD/ - 67, 0/ DATA SDECOD/100, 101, 99, 111, 100, 101, 0/, VDECOD/ - 68, 0/ DATA SFORMA/102, 111, 114, 109, 97, 116, 0/, VFORMA/ - 69, 0/ DATA SSTRNG/115, 116, 114, 105, 110, 103, 0/, VSTRNG/ - 70, 0/ DATA SSWTCH/115, 119, 105, 116, 99, 104, 0/, VSWTCH/ - 71, 0/ DATA SCASE/99, 97, 115, 101, 0/, VCASE/ - 72, 0/ DATA SDEFAL/100, 101, 102, 97, 117, 108, 116, 0/, VDEFAL/ - 73, 0/ CALL INSUPL(SDEFIN, VDEFIN, SET(SET(SET(0, 10), 11), 1)) CALL INSUPL(SINCLU, VINCLU, 0) CALL INSUPL(SFUNCT, VFUNCT, 0) CALL INSUPL(SDO, VDO, 0) CALL INSUPL(SIF, VIF, 0) CALL INSUPL(SELSE, VELSE, 0) CALL INSUPL(SWHILE, VWHILE, 0) CALL INSUPL(SFOR, VFOR, 0) CALL INSUPL(SREPEA, VREPEA, 0) CALL INSUPL(SUNTIL, VUNTIL, 0) CALL INSUPL(SNEXT, VNEXT, 0) CALL INSUPL(SBREAK, VBREAK, 0) CALL INSUPL(SRETUR, VRETUR, 0) CALL INSUPL(SREAD, VREAD, 0) CALL INSUPL(SWRITE, VWRITE, 0) CALL INSUPL(SENCOD, VENCOD, 0) CALL INSUPL(SDECOD, VDECOD, 0) CALL INSUPL(SFORMA, VFORMA, 0) CALL INSUPL(SSTRNG, VSTRNG, 0) CALL INSUPL(SSWTCH, VSWTCH, 0) CALL INSUPL(SCASE, VCASE, 0) CALL INSUPL(SDEFAL, VDEFAL, 0) RETURN END C ARCHIVE LABELC.RAT 15 30-NOV-81 14:24:03 C labelc - output statement number SUBROUTINE LABELC(LEXSTR) BYTE LEXSTR(1) INTEGER LENGTH, I C-------------------------------------------------------------------- C# preprocessor common block to hold 'goto' flags and current label C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/LABEL, XFER C holds next label for goto, etc. INTEGER LABEL C YES if just made transfer; else NO INTEGER XFER C can't suppress goto's now XFER = 0 I = LENGTH(LEXSTR) IF (.NOT.(LEXSTR(I) .EQ. 48)) GOTO 5020 IF (.NOT.(I .GT. 4 .OR. (LEXSTR(1) .NE. 49 .AND. I .EQ. 4))) GOT *O 5040 CALL SYNERR('warning: possible label conflict.') 5040 CONTINUE 5020 CONTINUE CALL OUTSTR(LEXSTR) CALL OUTTAB RETURN END C ARCHIVE LABGEN.RAT 9 30-NOV-81 14:24:03 C labgen - generate n consecutive labels, return first one INTEGER FUNCTION LABGEN(N) INTEGER N C-------------------------------------------------------------------- C# preprocessor common block to hold 'goto' flags and current label C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/LABEL, XFER C holds next label for goto, etc. INTEGER LABEL C YES if just made transfer; else NO INTEGER XFER LABGEN = LABEL LABEL = LABEL + N*10 RETURN END C ARCHIVE LEX.RAT 20 30-NOV-81 14:24:04 C lex - return lexical type of token INTEGER FUNCTION LEX(LEXSTR) BYTE GETTOK BYTE LEXSTR(201) INTEGER ALLDIG 5060 IF (.NOT.(GETTOK(LEXSTR, 201) .EQ. 10)) GOTO 5070 GOTO 5060 5070 CONTINUE LEX = LEXSTR(1) IF (.NOT.(LEX .LT. 0 .OR. LEX .EQ. -10 .OR. LEX .EQ. 59 .OR. LEX . *EQ. 91 .OR. LEX .EQ. 93)) GOTO 5080 GOTO 5090 5080 CONTINUE IF (.NOT.(ALLDIG(LEXSTR) .EQ. 1)) GOTO 5100 LEX = - 53 GOTO 5090 5100 CONTINUE IF (.NOT.(LEX .EQ. 37)) GOTO 5120 LEX = - 58 GOTO 5090 5120 CONTINUE LEX = - 60 5090 CONTINUE RETURN END C ARCHIVE LITRAL.RAT 37 1-DEC-81 11:18:38 C litral - process literal Fortran lines SUBROUTINE LITRAL BYTE NGETCH, C INTEGER NB C-------------------------------------------------------------------- C# preprocessor common block to hold 'goto' flags and current label C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/LABEL, XFER C holds next label for goto, etc. INTEGER LABEL C YES if just made transfer; else NO INTEGER XFER C Finish off any left-over characters CALL OUTDON XFER = 0 NB = 0 5140 IF (.NOT.(NGETCH(C) .EQ. 32)) GOTO 5160 5150 NB = NB + 1 GOTO 5140 5160 CONTINUE IF (.NOT.(C .NE. 10)) GOTO 5170 C literal on this line only 5190 IF (.NOT.(NB .GT. 0)) GOTO 5210 CALL PUTCH(32, 2) 5200 NB = NB - 1 GOTO 5190 5210 CONTINUE 5220 CONTINUE IF (.NOT.(C .EQ. -10)) GOTO 5250 GOTO 10 5250 CONTINUE CALL PUTCH(C, 2) 5230 IF (.NOT.(NGETCH(C) .EQ. 10)) GOTO 5220 CALL PUTCH(10, 2) C loop until matching toggle found GOTO 5180 5170 CONTINUE 5270 IF (.NOT.(NGETCH(C) .NE. 37)) GOTO 5280 5290 CONTINUE IF (.NOT.(C .EQ. -10)) GOTO 5320 GOTO 10 5320 CONTINUE CALL PUTCH(C, 2) 5300 IF (.NOT.(NGETCH(C) .EQ. 10)) GOTO 5290 CALL PUTCH(10, 2) GOTO 5270 5280 CONTINUE 5180 CONTINUE RETURN 10 CALL PUTBAK( - 10) CALL SYNERR('EOF in literal fortran code.') RETURN END C ARCHIVE NQC.RAT 13 30-NOV-81 14:24:04 C nqc - get next character from quoted character string BYTE FUNCTION NQC(LIN, I, Q, C) BYTE LIN(1), Q, C INTEGER I C = LIN(I) IF (.NOT.(C .EQ. Q)) GOTO 5340 IF (.NOT.(LIN(I+1) .EQ. Q)) GOTO 5360 I = I + 1 GOTO 5370 5360 CONTINUE C = 0 5370 CONTINUE 5340 CONTINUE NQC = (C) RETURN END C ARCHIVE OTHERC.RAT 11 30-NOV-81 14:24:04 C otherc - output ordinary Fortran statement SUBROUTINE OTHERC(LEXSTR) BYTE LEXSTR(1) C-------------------------------------------------------------------- C# preprocessor common block to hold 'goto' flags and current label C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/LABEL, XFER C holds next label for goto, etc. INTEGER LABEL C YES if just made transfer; else NO INTEGER XFER XFER = 0 CALL OUTTAB CALL OUTSTR(LEXSTR) CALL EATUP RETURN END C ARCHIVE OUTCH.RAT 18 30-NOV-81 14:24:05 C outch - put one character into output buffer SUBROUTINE OUTCH(C) BYTE C INTEGER I C------------------------------------------------------------------ C# preprocessor common block to hold output characters C put on a file named 'coutln' C Used only by ratfiv preprocessor COMMON/COUTLN/OUTP, INDENT, OUTBUF(134) C last position filled in outbuf; init = 0 INTEGER OUTP C current indent level (tab position) INTEGER INDENT C output lines collected here BYTE OUTBUF C------------------------------------------------------------------ IF (.NOT.(OUTP .GE. 72)) GOTO 5380 C continuation card CALL OUTDON I = 1 5400 IF (.NOT.(I .LT. 6)) GOTO 5420 OUTBUF(I) = 32 5410 I = I + 1 GOTO 5400 5420 CONTINUE OUTBUF(6) = 42 OUTP = 6 5380 CONTINUE OUTP = OUTP + 1 OUTBUF(OUTP) = C RETURN END C ARCHIVE OUTCOM.RAT 24 30-NOV-81 14:24:05 C outcom - output comments SUBROUTINE OUTCOM(TOKEN) BYTE TOKEN(1), NGETCH INTEGER J C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV C------------------------------------------------------------------ C# preprocessor common block to hold output characters C put on a file named 'coutln' C Used only by ratfiv preprocessor COMMON/COUTLN/OUTP, INDENT, OUTBUF(134) C last position filled in outbuf; init = 0 INTEGER OUTP C current indent level (tab position) INTEGER INDENT C output lines collected here BYTE OUTBUF C------------------------------------------------------------------ IF (.NOT.(DEFSTK(DEFCNT) .AND. (OUTP .LT. 6 .OR. OUTBUF(6) .EQ. 32 *))) GOTO 5430 CALL PUTCH(67, 2) J = 2 5450 IF (.NOT.(NGETCH(TOKEN(1)) .NE. 10)) GOTO 5470 IF (.NOT.(J .GT. 80)) GOTO 5480 CALL PUTCH(10, 2) CALL PUTCH(67, 2) J = 2 5480 CONTINUE CALL PUTCH(TOKEN(1), 2) 5460 J = J + 1 GOTO 5450 5470 CONTINUE CALL PUTCH(10, 2) GOTO 5440 5430 CONTINUE 5500 IF (.NOT.(NGETCH(TOKEN(1)) .NE. 10)) GOTO 5510 GOTO 5500 5510 CONTINUE 5440 CONTINUE RETURN END C ARCHIVE OUTCON.RAT 17 30-NOV-81 14:24:05 C outcon - output 'n continue' SUBROUTINE OUTCON(N) INTEGER N C-------------------------------------------------------------------- C# preprocessor common block to hold 'goto' flags and current label C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/LABEL, XFER C holds next label for goto, etc. INTEGER LABEL C YES if just made transfer; else NO INTEGER XFER C------------------------------------------------------------------ C# preprocessor common block to hold output characters C put on a file named 'coutln' C Used only by ratfiv preprocessor COMMON/COUTLN/OUTP, INDENT, OUTBUF(134) C last position filled in outbuf; init = 0 INTEGER OUTP C current indent level (tab position) INTEGER INDENT C output lines collected here BYTE OUTBUF C------------------------------------------------------------------ BYTE CONTIN(9) DATA CONTIN(1)/99/,CONTIN(2)/111/,CONTIN(3)/110/,CONTIN(4)/116/,CO *NTIN(5)/105/,CONTIN(6)/110/,CONTIN(7)/117/,CONTIN(8)/101/,CONTIN(9 *)/0/ XFER = 0 IF (.NOT.(N .LE. 0 .AND. OUTP .EQ. 0)) GOTO 5520 C don't need unlabeled continues RETURN 5520 CONTINUE IF (.NOT.(N .GT. 0)) GOTO 5540 CALL OUTNUM(N) 5540 CONTINUE CALL OUTTAB CALL OUTSTR(CONTIN) CALL OUTDON RETURN END C ARCHIVE OUTDON.RAT 12 1-DEC-81 10:48:24 C outdon - finish off an output line SUBROUTINE OUTDON C------------------------------------------------------------------ C# preprocessor common block to hold output characters C put on a file named 'coutln' C Used only by ratfiv preprocessor COMMON/COUTLN/OUTP, INDENT, OUTBUF(134) C last position filled in outbuf; init = 0 INTEGER OUTP C current indent level (tab position) INTEGER INDENT C output lines collected here BYTE OUTBUF C------------------------------------------------------------------ IF (.NOT.(OUTP .GT. 0)) GOTO 5560 OUTBUF(OUTP + 1) = 10 OUTBUF(OUTP + 2) = 0 CALL PUTLIN(OUTBUF, 2) OUTP = 0 5560 CONTINUE RETURN END C ARCHIVE OUTGO.RAT 16 30-NOV-81 14:24:06 C outgo - output 'goto n' SUBROUTINE OUTGO(N, NEWXF) INTEGER N, NEWXF C------------------------------------------------------------------ C# preprocessor common block to hold output characters C put on a file named 'coutln' C Used only by ratfiv preprocessor COMMON/COUTLN/OUTP, INDENT, OUTBUF(134) C last position filled in outbuf; init = 0 INTEGER OUTP C current indent level (tab position) INTEGER INDENT C output lines collected here BYTE OUTBUF C------------------------------------------------------------------ C-------------------------------------------------------------------- C# preprocessor common block to hold 'goto' flags and current label C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/LABEL, XFER C holds next label for goto, etc. INTEGER LABEL C YES if just made transfer; else NO INTEGER XFER BYTE GOTO(6) DATA GOTO(1)/103/,GOTO(2)/111/,GOTO(3)/116/,GOTO(4)/111/,GOTO(5)/3 *2/,GOTO(6)/0/ IF (.NOT.(XFER .EQ. 1)) GOTO 5580 RETURN 5580 CONTINUE XFER = NEWXF CALL OUTTAB CALL OUTSTR(GOTO) CALL OUTNUM(N) CALL OUTDON RETURN END C ARCHIVE OUTNUM.RAT 11 30-NOV-81 14:24:06 C outnum - output decimal number SUBROUTINE OUTNUM(INT) INTEGER INT, I, J INTEGER ITOC BYTE STR(7) I = ITOC(INT, STR, 7) J = 1 5600 IF (.NOT.(J .LE. I)) GOTO 5620 CALL OUTCH(STR(J)) 5610 J = J + 1 GOTO 5600 5620 CONTINUE RETURN END C ARCHIVE OUTSTR.RAT 49 30-NOV-81 14:24:07 C outstr - output string SUBROUTINE OUTSTR(STR) C***NOTE*** - modified to put out quoted strings unless /HOLLERITH C switch was specified on the command line C and to strip ACCENT chars BYTE C, Q, STR(1), CUPPER, NQC INTEGER I, J, K C------------------------------------------------------------------ C# preprocessor common block to hold flags C put on a file named 'cflags' C Used only by ratfiv preprocessor COMMON/CFLAGS/INFORM, F77, HOLLER C when .true., < and > aren't C converted to .lt. and .gt. C when .true., output is Fortran 77 C when .true., hollerith strings LOGICAL INFORM, F77, HOLLER C are output instead of quoted strings I = 1 5630 IF (.NOT.(STR(I) .NE. 0)) GOTO 5650 C = STR(I) IF (.NOT.(C .EQ. 96)) GOTO 5660 I = I + 1 5680 CONTINUE IF (.NOT.(STR(I) .EQ. 96)) GOTO 5710 IF (.NOT.(STR(I+1) .EQ. 96)) GOTO 5730 I = I + 1 GOTO 5740 5730 CONTINUE GOTO 5700 5740 CONTINUE 5710 CONTINUE CALL OUTCH(STR(I)) 5690 I = I + 1 GOTO 5680 5700 CONTINUE GOTO 5670 5660 CONTINUE IF (.NOT.(STR(I+1) .EQ. 0 .OR. .NOT.((C) .EQ. 39 .OR. (C) .EQ. 3 *4))) GOTO 5750 CALL OUTCH(CUPPER(C)) GOTO 5670 5750 CONTINUE IF (.NOT.(HOLLER)) GOTO 5770 C hollerith output? Q = C I = I + 1 K = 0 J = I 5790 IF (.NOT.(NQC(STR,J,Q,C) .NE. 0)) GOTO 5810 C find end K = K + 1 5800 J = J + 1 GOTO 5790 5810 CONTINUE CALL OUTNUM(K) CALL OUTCH(72) 5820 IF (.NOT.(NQC(STR,I,Q,C) .NE. 0)) GOTO 5840 CALL OUTCH(C) 5830 I = I + 1 GOTO 5820 5840 CONTINUE GOTO 5670 5770 CONTINUE C quoted output Q = C CALL OUTCH(39) I = I + 1 5850 IF (.NOT.(NQC(STR,I,Q,C) .NE. 0)) GOTO 5870 IF (.NOT.(C .EQ. 39)) GOTO 5880 C ' -> '' CALL OUTCH(39) 5880 CONTINUE CALL OUTCH(C) 5860 I = I + 1 GOTO 5850 5870 CONTINUE CALL OUTCH(39) 5670 CONTINUE 5640 I = I + 1 GOTO 5630 5650 CONTINUE RETURN END C ARCHIVE OUTTAB.RAT 11 30-NOV-81 14:24:07 C outtab - get past column 6 SUBROUTINE OUTTAB INTEGER I, MOD C------------------------------------------------------------------ C# preprocessor common block to hold output characters C put on a file named 'coutln' C Used only by ratfiv preprocessor COMMON/COUTLN/OUTP, INDENT, OUTBUF(134) C last position filled in outbuf; init = 0 INTEGER OUTP C current indent level (tab position) INTEGER INDENT C output lines collected here BYTE OUTBUF C------------------------------------------------------------------ I = MOD(INDENT, 44) + 6 5900 IF (.NOT.(OUTP .LT. I)) GOTO 5910 CALL OUTCH(32) GOTO 5900 5910 CONTINUE RETURN END C ARCHIVE PARSE.RAT 140 1-DEC-81 09:55:07 C parse - parse Ratfiv source program SUBROUTINE PARSE BYTE LEXSTR(201) INTEGER LEX INTEGER LAB, LABVAL(100), LEXTYP(100), SP, TOKEN, I C------------------------------------------------------------------ C# preprocessor common block to hold output characters C put on a file named 'coutln' C Used only by ratfiv preprocessor COMMON/COUTLN/OUTP, INDENT, OUTBUF(134) C last position filled in outbuf; init = 0 INTEGER OUTP C current indent level (tab position) INTEGER INDENT C output lines collected here BYTE OUTBUF C------------------------------------------------------------------ C----------------------------------------------------------------------- C preprocessor common block to hold info about lines and included files C put on a file named 'cline' C used by ratfiv preproccessor and macro COMMON/CLINE/LEVEL, INFILE(4), LINECT(4), FNAMP(4), FNAMES(136), I *OIN(134) C level of file inclusion; init = 1 INTEGER LEVEL C file number(level); init infile(1) = STDIN INTEGER INFILE C line count on input file(level); init = 1 INTEGER LINECT C next free slot in fnames INTEGER FNAMP C stack of open file names BYTE FNAMES C input buffer BYTE IOIN C---------------------------------------------------------------------- C preprocessor common block to hold input characters C Put on a file called 'cdefio' C Used by ratfiv preprocessor and macro COMMON/CDEFIO/BP, BPLOW, BPSAVE(4), BUF(900) C next available character; init = 0 INTEGER BP C bottom of push-back buffer at current file level INTEGER BPLOW C holds bplow for active file levels INTEGER BPSAVE C pushed-back characters BYTE BUF C-------------------------------------------------------------------------- C# preprocessor common block to hold info about 'for' statements C put on a file named 'cfor' C Used only by ratfiv preprocessor COMMON/CFOR/FORDEP, FORSTK(250) C current depth of for statements INTEGER FORDEP C stack of reinit strings BYTE FORSTK C-------------------------------------------------------------------------- C# preprocessor common block to hold current function name C put on a file named 'cfname' C Used only by ratfiv preprocessor COMMON/CFNAME/FCNAME(35) Ctext of current function name BYTE FCNAME C-------------------------------------------------------------------- C# preprocessor common block to hold 'goto' flags and current label C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/LABEL, XFER C holds next label for goto, etc. INTEGER LABEL C YES if just made transfer; else NO INTEGER XFER C------------------------------------------------------------------ C# preprocessor common block to hold flags C put on a file named 'cflags' C Used only by ratfiv preprocessor COMMON/CFLAGS/INFORM, F77, HOLLER C when .true., < and > aren't C converted to .lt. and .gt. C when .true., output is Fortran 77 C when .true., hollerith strings LOGICAL INFORM, F77, HOLLER C are output instead of quoted strings C# preprocessor common block for holding string statement info C Put on a file called 'csbuf' C Used only by ratfiv preprocessor COMMON/CSBUF/SBP, SBUF(600) C next available character position; init = 1 INTEGER SBP C saved for data statements BYTE SBUF C# Preprocessor common block used to hold switch info C Put on a file named 'cswtch' C Used only by ratfiv preprocessor COMMON/CSWTCH/SWTOP, SWLAST, SWSTAK(500) C current switch entry; init = 0 INTEGER SWTOP C next available position; init = 1 INTEGER SWLAST C switch information INTEGER SWSTAK BYTE SDECOD(7) BYTE SENCOD(7) BYTE SREAD(5) BYTE SWRITE(6) BYTE SFORMA(7) C initialize variables for current input file DATA SDECOD(1)/100/,SDECOD(2)/101/,SDECOD(3)/99/,SDECOD(4)/111/,SD *ECOD(5)/100/,SDECOD(6)/101/,SDECOD(7)/0/ DATA SENCOD(1)/101/,SENCOD(2)/110/,SENCOD(3)/99/,SENCOD(4)/111/,SE *NCOD(5)/100/,SENCOD(6)/101/,SENCOD(7)/0/ DATA SREAD(1)/114/,SREAD(2)/101/,SREAD(3)/97/,SREAD(4)/100/,SREAD( *5)/0/ DATA SWRITE(1)/119/,SWRITE(2)/114/,SWRITE(3)/105/,SWRITE(4)/116/,S *WRITE(5)/101/,SWRITE(6)/0/ DATA SFORMA(1)/102/,SFORMA(2)/111/,SFORMA(3)/114/,SFORMA(4)/109/,S *FORMA(5)/97/,SFORMA(6)/116/,SFORMA(7)/0/ OUTP = 0 INDENT = 0 LEVEL = 1 FNAMP(1) = 1 LINECT(1) = 0 BP = 0 SBP = 1 FORDEP = 0 C controls conversion of > and < to .gt. and .lt. INFORM = .FALSE. FCNAME(1) = 0 XFER = 0 LABEL = 2000 SWTOP = 0 SWLAST = 1 SP = 1 LEXTYP(1) = - 10 TOKEN = LEX(LEXSTR) 5920 IF (.NOT.(TOKEN .NE. -10)) GOTO 5940 I5950 = (TOKEN) GOTO 5950 5970 CONTINUE CALL OTHERC(LEXSTR) GOTO 5960 5980 CONTINUE CALL IFCODE(LAB) SP = SP + 1 GOTO 5960 5990 CONTINUE IF (.NOT.(LEXTYP(SP) .EQ. -57 .OR. LEXTYP(SP) .EQ. -74)) GOTO *6000 IF (.NOT.(LEX(LEXSTR) .EQ. -57)) GOTO 6020 C have "else if ..." LEXTYP(SP) = - 74 GOTO 6030 6020 CONTINUE CALL PBSTR(LEXSTR) LEXTYP(SP) = - 55 6030 CONTINUE CALL ELSEF(LABVAL(SP - 1), LABVAL(SP), LEXTYP(SP)) IF (.NOT.(LEXTYP(SP) .EQ. -74)) GOTO 6040 CALL IFCODE(LABVAL(SP)) 6040 CONTINUE GOTO 6010 6000 CONTINUE TOKEN = - 75 CALL SYNERR('illegal else.') 6010 CONTINUE GOTO 5960 6060 CONTINUE CALL DOCODE(LAB) GOTO 5960 6070 CONTINUE CALL WHILEC(LAB) GOTO 5960 6080 CONTINUE CALL FORCOD(LAB) GOTO 5960 6090 CONTINUE CALL REPCOD(LAB) GOTO 5960 6100 CONTINUE CALL BRKNXT(SP, LEXTYP, LABVAL, TOKEN) GOTO 5960 6110 CONTINUE CALL LABELC(LEXSTR) GOTO 5960 6120 CONTINUE CALL SWCODE(LAB) GOTO 5960 6130 CONTINUE IF (.NOT.(SP .GT. 1 .AND. LEXTYP(MAX0(1, SP-1)) .EQ. -71)) GOT *O 6140 CALL CASCOD(LABVAL(SP - 1), TOKEN) GOTO 6150 6140 CONTINUE TOKEN = - 75 CALL SYNERR('illegal case or default.') 6150 CONTINUE GOTO 5960 6160 CONTINUE CALL FORMA(SWRITE) GOTO 5960 6170 CONTINUE CALL FORMA(SREAD) GOTO 5960 6180 CONTINUE CALL FORMA(SENCOD) GOTO 5960 6190 CONTINUE CALL FORMA(SDECOD) GOTO 5960 6200 CONTINUE INFORM = .TRUE. CALL OTHERC(SFORMA) INFORM = .FALSE. GOTO 5960 6210 CONTINUE CALL RINCLU GOTO 5960 6220 CONTINUE CALL DFUNCT GOTO 5960 6230 CONTINUE CALL RETCOD GOTO 5960 6240 CONTINUE CALL STRDCL GOTO 5960 6250 CONTINUE CALL LITRAL GOTO 5960 6260 CONTINUE IF (.NOT.(TOKEN .EQ. 93)) GOTO 6270 IF (.NOT.(LEXTYP(SP) .EQ. 91)) GOTO 6290 SP = SP - 1 GOTO 6300 6290 CONTINUE CALL SYNERR('illegal right brace.') 6300 CONTINUE 6270 CONTINUE GOTO 5960 5950 CONTINUE I5950 = I5950+74 IF (I5950 .LT. 1 .OR. I5950 .GT. 24) GOTO 6260 GOTO (6130,6130,6120,6240,6200,6190,6180,6170,6160,6070,6260,623 *0,6090,5970,6100,6250,5980,6080,5990,6060,6110,6100,6220,6210), I5 *950 5960 CONTINUE IF (.NOT.(TOKEN .EQ. -57 .OR. TOKEN .EQ. -64 .OR. TOKEN .EQ. -56 * .OR. TOKEN .EQ. -61 .OR. TOKEN .EQ. -71 .OR. TOKEN .EQ. -54 .OR. *TOKEN .EQ. -53 .OR. TOKEN .EQ. 91)) GOTO 6310 C beginning of statement SP = SP + 1 IF (.NOT.(SP .GT. 100)) GOTO 6330 CALL FATAL('stack overflow in parser.') 6330 CONTINUE C stack type and value LEXTYP(SP) = TOKEN LABVAL(SP) = LAB IF (.NOT.(TOKEN .EQ. -57)) GOTO 6350 LEXTYP(SP - 1) = TOKEN LABVAL(SP - 1) = LAB + 10 6350 CONTINUE GOTO 6320 6310 CONTINUE IF (.NOT.(TOKEN .NE. -55)) GOTO 6370 C end of statement - prepare to unstack C peek at next token TOKEN = LEX(LEXSTR) CALL PBSTR(LEXSTR) CALL UNSTAK(SP, LEXTYP, LABVAL, TOKEN) 6370 CONTINUE 6320 CONTINUE 5930 TOKEN = LEX(LEXSTR) GOTO 5920 5940 CONTINUE IF (.NOT.(SP .NE. 1)) GOTO 6390 CALL SYNERR('unexpected EOF.') 6390 CONTINUE RETURN END C ARCHIVE RAT5S.RAT 83 1-DEC-81 11:28:22 C rat5s - driver subroutine for ratfiv compiler SUBROUTINE RAT5S INTEGER GETARG, OPEN, PMATCH BYTE BUF(134) INTEGER I, ARG1 C----------------------------------------------------------------------- C preprocessor common block to hold info about lines and included files C put on a file named 'cline' C used by ratfiv preproccessor and macro COMMON/CLINE/LEVEL, INFILE(4), LINECT(4), FNAMP(4), FNAMES(136), I *OIN(134) C level of file inclusion; init = 1 INTEGER LEVEL C file number(level); init infile(1) = STDIN INTEGER INFILE C line count on input file(level); init = 1 INTEGER LINECT C next free slot in fnames INTEGER FNAMP C stack of open file names BYTE FNAMES C input buffer BYTE IOIN C needed to set input file C------------------------------------------------------------------ C# preprocessor common block to hold flags C put on a file named 'cflags' C Used only by ratfiv preprocessor COMMON/CFLAGS/INFORM, F77, HOLLER C when .true., < and > aren't C converted to .lt. and .gt. C when .true., output is Fortran 77 C when .true., hollerith strings LOGICAL INFORM, F77, HOLLER C are output instead of quoted strings BYTE SYMBLS(8) C file containing general definitions BYTE SYMFLG(9) C /SYMBOLS switch BYTE F77SW(5) C Fortran 77 switch BYTE HOLLSW(11) C output hollerith strings switch BYTE STDINN(6) C STDIN string DATA SYMBLS(1)/83/,SYMBLS(2)/89/,SYMBLS(3)/77/,SYMBLS(4)/66/,SYMBL *S(5)/79/,SYMBLS(6)/76/,SYMBLS(7)/83/,SYMBLS(8)/0/ DATA SYMFLG(1)/47/,SYMFLG(2)/83/,SYMFLG(3)/89/,SYMFLG(4)/77/,SYMFL *G(5)/66/,SYMFLG(6)/79/,SYMFLG(7)/76/,SYMFLG(8)/83/,SYMFLG(9)/0/ DATA F77SW(1)/47/,F77SW(2)/70/,F77SW(3)/55/,F77SW(4)/55/,F77SW(5)/ *0/ DATA HOLLSW(1)/47/,HOLLSW(2)/72/,HOLLSW(3)/79/,HOLLSW(4)/76/,HOLLS *W(5)/76/,HOLLSW(6)/69/,HOLLSW(7)/82/,HOLLSW(8)/73/,HOLLSW(9)/84/,H *OLLSW(10)/72/,HOLLSW(11)/0/ DATA STDINN(1)/83/,STDINN(2)/84/,STDINN(3)/68/,STDINN(4)/73/,STDIN *N(5)/78/,STDINN(6)/0/ C initialize macro processor CALL INIMAC C initialize ratfiv CALL INIRAT F77 = .FALSE. HOLLER = .FALSE. ARG1 = 1 6410 IF (.NOT.(GETARG(ARG1,BUF,134) .NE. -10)) GOTO 6430 IF (.NOT.(BUF(1) .NE. 47)) GOTO 6440 GOTO 6430 6440 CONTINUE IF (.NOT.(PMATCH(BUF, SYMFLG) .EQ. 1)) GOTO 6460 C read file containing standard defs CALL SCOPY(SYMBLS, 1, FNAMES, 1) INFILE(1) = OPEN(SYMBLS, 'R') IF (.NOT.(INFILE(1) .EQ. -1)) GOTO 6480 C then try system-wide symbols file C get location of system-wide file CALL USRBIN(FNAMES) I = 1 6500 IF (.NOT.(FNAMES(I) .NE. 0)) GOTO 6520 C move pointer to end 6510 I = I + 1 GOTO 6500 6520 CONTINUE C copy remainder of name CALL SCOPY(SYMBLS, 1, FNAMES, I) INFILE(1) = OPEN(FNAMES, 'R') 6480 CONTINUE IF (.NOT.(INFILE(1) .EQ. -1)) GOTO 6530 CALL ERROR('can''t open symbols file.') GOTO 6540 6530 CONTINUE CALL PARSE CALL CLOSE(INFILE(1)) 6540 CONTINUE GOTO 6450 6460 CONTINUE IF (.NOT.(PMATCH(BUF, F77SW) .EQ. 1)) GOTO 6550 F77 = .TRUE. GOTO 6450 6550 CONTINUE IF (.NOT.(PMATCH(BUF, HOLLSW) .EQ. 1)) GOTO 6570 HOLLER = .TRUE. GOTO 6450 6570 CONTINUE CALL PUTLIN(BUF, 3) CALL ERROR(': illegal switch.') C loop through all input files 6450 CONTINUE 6420 ARG1 = ARG1 + 1 GOTO 6410 6430 CONTINUE I = ARG1 6590 CONTINUE IF (.NOT.(GETARG(I, BUF, 134) .EQ. -10)) GOTO 6620 IF (.NOT.(I .NE. ARG1)) GOTO 6640 GOTO 6610 6640 CONTINUE INFILE(1) = 5 CALL SCOPY(STDINN, 1, FNAMES, 1) GOTO 6630 6620 CONTINUE IF (.NOT.(BUF(1) .EQ. 63 .AND. BUF(2) .EQ. 0)) GOTO 6660 CALL REMARK('usage: rat[/symbols][/hollerith][/f77] [file ... *] [>outfile].') GOTO 6630 6660 CONTINUE IF (.NOT.(BUF(1) .EQ. 45 .AND. BUF(2) .EQ. 0)) GOTO 6680 INFILE(1) = 5 CALL SCOPY(STDINN, 1, FNAMES, 1) GOTO 6630 6680 CONTINUE INFILE(1) = OPEN(BUF, 'R') CALL SCOPY(BUF, 1, FNAMES, 1) IF (.NOT.(INFILE(1) .EQ. -1)) GOTO 6700 CALL CANT(BUF) 6700 CONTINUE 6630 CONTINUE CALL PARSE IF (.NOT.(INFILE(1) .NE. 5)) GOTO 6720 CALL CLOSE(INFILE(1)) 6720 CONTINUE 6600 I = I + 1 GOTO 6590 6610 CONTINUE RETURN END C ARCHIVE RATMAIN.RAT 7 1-DEC-81 11:29:40 C ratfiv -- main program C remove this if necessary on your system PROGRAM RATFIV CALL INITR4 CALL RAT5S CALL ENDR4 END C ARCHIVE RELATE.RAT 61 30-NOV-81 14:24:09 C relate - convert relational shorthands into long form SUBROUTINE RELATE(TOKEN, LAST) BYTE NGETCH BYTE TOKEN(1) INTEGER LENGTH INTEGER LAST C------------------------------------------------------------------ C# preprocessor common block to hold flags C put on a file named 'cflags' C Used only by ratfiv preprocessor COMMON/CFLAGS/INFORM, F77, HOLLER C when .true., < and > aren't C converted to .lt. and .gt. C when .true., output is Fortran 77 C when .true., hollerith strings LOGICAL INFORM, F77, HOLLER C are output instead of quoted strings BYTE DOTGE(9), DOTGT(9), DOTLT(9), DOTLE(9) BYTE DOTNE(9), DOTNOT(8), DOTEQ(9), DOTAND(10), DOTOR(9) DATA DOTGE/96, 32, 46, 71, 69, 46, 32, 96, 0/ DATA DOTGT/96, 32, 46, 71, 84, 46, 32, 96, 0/ DATA DOTLE/96, 32, 46, 76, 69, 46, 32, 96, 0/ DATA DOTLT/96, 32, 46, 76, 84, 46, 32, 96, 0/ DATA DOTNE/96, 32, 46, 78, 69, 46, 32, 96, 0/ DATA DOTEQ/96, 32, 46, 69, 81, 46, 32, 96, 0/ DATA DOTOR/96, 32, 46, 79, 82, 46, 32, 96, 0/ DATA DOTAND/96, 32, 46, 65, 78, 68, 46, 32, 96, 0/ DATA DOTNOT/96, 46, 78, 79, 84, 46, 96, 0/ IF (.NOT.(NGETCH(TOKEN(2)) .NE. 61)) GOTO 6740 CALL PUTBAK(TOKEN(2)) 6740 CONTINUE IF (.NOT.(TOKEN(1) .EQ. 62)) GOTO 6760 IF (.NOT.(TOKEN(2) .EQ. 61)) GOTO 6780 CALL SCOPY(DOTGE, 1, TOKEN, 1) GOTO 6790 6780 CONTINUE IF (.NOT.(INFORM)) GOTO 6800 TOKEN(2) = 0 GOTO 6790 6800 CONTINUE CALL SCOPY(DOTGT, 1, TOKEN, 1) 6790 CONTINUE GOTO 6770 6760 CONTINUE IF (.NOT.(TOKEN(1) .EQ. 60)) GOTO 6820 IF (.NOT.(TOKEN(2) .EQ. 61)) GOTO 6840 CALL SCOPY(DOTLE, 1, TOKEN, 1) GOTO 6850 6840 CONTINUE IF (.NOT.(INFORM)) GOTO 6860 TOKEN(2) = 0 GOTO 6850 6860 CONTINUE CALL SCOPY(DOTLT, 1, TOKEN, 1) 6850 CONTINUE GOTO 6770 6820 CONTINUE IF (.NOT.(TOKEN(1) .EQ. 126 .OR. TOKEN(1) .EQ. 33 .OR. TOKEN(1) .E *Q. 94)) GOTO 6880 IF (.NOT.(TOKEN(2) .EQ. 61)) GOTO 6900 CALL SCOPY(DOTNE, 1, TOKEN, 1) GOTO 6910 6900 CONTINUE CALL SCOPY(DOTNOT, 1, TOKEN, 1) 6910 CONTINUE GOTO 6770 6880 CONTINUE IF (.NOT.(TOKEN(1) .EQ. 61)) GOTO 6920 IF (.NOT.(TOKEN(2) .EQ. 61)) GOTO 6940 CALL SCOPY(DOTEQ, 1, TOKEN, 1) GOTO 6950 6940 CONTINUE TOKEN(2) = 0 6950 CONTINUE GOTO 6770 6920 CONTINUE IF (.NOT.(TOKEN(1) .EQ. 38)) GOTO 6960 CALL SCOPY(DOTAND, 1, TOKEN, 1) GOTO 6770 6960 CONTINUE IF (.NOT.(TOKEN(1) .EQ. 124 .OR. TOKEN(1) .EQ. 92)) GOTO 6980 CALL SCOPY(DOTOR, 1, TOKEN, 1) C can't happen GOTO 6770 6980 CONTINUE TOKEN(2) = 0 6770 CONTINUE LAST = LENGTH(TOKEN) RETURN END C ARCHIVE REPCOD.RAT 12 30-NOV-81 14:24:09 C repcod - generate code for beginning of repeat SUBROUTINE REPCOD(LAB) INTEGER LABGEN INTEGER LAB C in case there was a label CALL OUTCON(0) LAB = LABGEN(3) CALL OUTCON(LAB) CALL INDEN(2) C label to go on next's LAB = - (LAB + 10) RETURN END C ARCHIVE RETCOD.RAT 29 30-NOV-81 14:24:09 C retcod - generate code for return SUBROUTINE RETCOD BYTE TOKEN(201), GETTOK, T C-------------------------------------------------------------------------- C# preprocessor common block to hold current function name C put on a file named 'cfname' C Used only by ratfiv preprocessor COMMON/CFNAME/FCNAME(35) Ctext of current function name BYTE FCNAME C-------------------------------------------------------------------- C# preprocessor common block to hold 'goto' flags and current label C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/LABEL, XFER C holds next label for goto, etc. INTEGER LABEL C YES if just made transfer; else NO INTEGER XFER BYTE RETRN(7) BYTE EQS(4) DATA RETRN(1)/114/,RETRN(2)/101/,RETRN(3)/116/,RETRN(4)/117/,RETRN *(5)/114/,RETRN(6)/110/,RETRN(7)/0/ DATA EQS(1)/32/,EQS(2)/61/,EQS(3)/32/,EQS(4)/0/ T = GETTOK(TOKEN, 201) IF (.NOT.(T .EQ. 59 .OR. T .EQ. 10 .OR. T .EQ. -10 .OR. T .EQ. 93 *.OR. T .EQ. 91 .OR. (T .LT. 0 .AND. T .NE. 1))) GOTO 7000 CALL PBSTR(TOKEN) GOTO 7010 7000 CONTINUE CALL PBSTR(TOKEN) CALL OUTTAB IF (.NOT.(FCNAME(1) .EQ. 0)) GOTO 7020 CALL SYNERR('return: no function defined.') GOTO 7030 7020 CONTINUE CALL OUTSTR(FCNAME) CALL OUTSTR(EQS) 7030 CONTINUE CALL EATUP 7010 CONTINUE CALL OUTTAB CALL OUTSTR(RETRN) CALL OUTDON XFER = 1 RETURN END C ARCHIVE RINCLU.RAT 29 16-DEC-81 23:27:37 C rinclu - do include for ratfiv SUBROUTINE RINCLU BYTE FILE(34), T, BUF(201), NQC, C, BRKCHR(5) BYTE GETTOK, DEFTOK INTEGER I, J, INDEX DATA BRKCHR/59, 32, 9, 10, 0/ T = GETTOK(BUF, 201) IF (.NOT.(((T) .EQ. 39 .OR. (T) .EQ. 34) .AND. BUF(2) .NE. 0)) GOT *O 7040 C include "file" or 'file' I = 1 J = 2 7060 IF (.NOT.(I .LE. 34 .AND. NQC(BUF,J,T,C) .NE. 0)) GOTO 7080 FILE(I) = C I = I + 1 7070 J = J + 1 GOTO 7060 7080 CONTINUE C include file GOTO 7050 7040 CONTINUE I = 1 7090 IF (.NOT.(T .NE. -10 .AND. INDEX(BRKCHR,T) .EQ. 0)) GOTO 7110 J = 1 7120 IF (.NOT.(I .LE. 34 .AND. BUF(J) .NE. 0)) GOTO 7140 FILE(I) = BUF(J) I = I + 1 7130 J = J + 1 GOTO 7120 7140 CONTINUE 7100 T = DEFTOK(BUF, 201) GOTO 7090 7110 CONTINUE 7050 CONTINUE IF (.NOT.(I .GT. 34)) GOTO 7150 CALL SYNERR('include file name too long.') GOTO 7160 7150 CONTINUE FILE(I) = 0 CALL INCLUD(FILE) 7160 CONTINUE RETURN END C ARCHIVE SKPOUT.RAT 26 30-NOV-81 14:24:10 SUBROUTINE SKPOUT(T) BYTE T, TOK(201), GETTOK INTEGER NLPAR NLPAR = 0 7170 CONTINUE T = GETTOK(TOK, 201) IF (.NOT.(T .EQ. -10)) GOTO 7200 CALL PBSTR(TOK) CALL SYNERR('unexpected EOF.') RETURN 7200 CONTINUE IF (.NOT.(T .EQ. 40)) GOTO 7220 NLPAR = NLPAR + 1 GOTO 7230 7220 CONTINUE IF (.NOT.(T .EQ. 41)) GOTO 7240 NLPAR = NLPAR - 1 7240 CONTINUE 7230 CONTINUE IF (.NOT.(T .NE. 10)) GOTO 7260 CALL OUTSTR(TOK) IF (.NOT.(T .EQ. 44)) GOTO 7280 CALL OUTCH(32) 7280 CONTINUE 7260 CONTINUE 7180 IF (.NOT.(NLPAR .LT. 0 .OR. (T .EQ. 44 .AND. NLPAR .EQ. 0))) GOTO *7170 IF (.NOT.(T .EQ. 41)) GOTO 7300 CALL OUTCH(32) 7300 CONTINUE RETURN END C ARCHIVE STRDCL.RAT 102 30-NOV-81 14:24:10 C strdcl - generate code for string declaration SUBROUTINE STRDCL BYTE T, TOKEN(201), GETTOK, ESC, NQC, Q, C INTEGER I, J, K, N, LEN INTEGER LENGTH, CTOI, LEX, ELENTH C$ character dchar(MAXTOK) C# preprocessor common block for holding string statement info C Put on a file called 'csbuf' C Used only by ratfiv preprocessor COMMON/CSBUF/SBP, SBUF(600) C next available character position; init = 1 INTEGER SBP C saved for data statements BYTE SBUF BYTE CHAR(5) BYTE DAT(6) BYTE EOSS(2) C$ character char(11), dat(6), eoss(5) C$ data char/LETC, LETH, LETA, LETR, LETA, LETC, LETT, LETE, LETR, SLASH, EOS/, C$ dat /LETD, LETA, LETT, LETA, BLANK, EOS/, C$ eoss /BIGE, BIGO, BIGS, SLASH, EOS/ DATA CHAR(1)/98/,CHAR(2)/121/,CHAR(3)/116/,CHAR(4)/101/,CHAR(5)/0/ DATA DAT(1)/100/,DAT(2)/97/,DAT(3)/116/,DAT(4)/97/,DAT(5)/32/,DAT( *6)/0/ DATA EOSS(1)/48/,EOSS(2)/0/ 7320 CONTINUE T = GETTOK(TOKEN, 201) IF (.NOT.(T .NE. 1)) GOTO 7350 CALL SYNERR('missing string token.') 7350 CONTINUE CALL OUTTAB CALL OUTSTR(CHAR) C$ call pbstr(char) #use defined meaning of "character" C$ repeat C$ { C$ t = gettok(dchar, MAXTOK) C$ if (t == SLASH) C$ break C$ call outstr (dchar) C$ } C separator in declaration CALL OUTCH(32) CALL OUTSTR(TOKEN) C save for later CALL ADDSTR(TOKEN, SBUF, SBP, 600) CALL ADDCHR(0, SBUF, SBP, 600) IF (.NOT.(GETTOK(TOKEN, 201) .NE. 40)) GOTO 7370 C make size same as initial value LEN = ELENTH(TOKEN) + 1 IF (.NOT.(((TOKEN(1)) .EQ. 39 .OR. (TOKEN(1)) .EQ. 34) .AND. T *OKEN(2) .NE. 0)) GOTO 7390 LEN = LEN - 2 7390 CONTINUE GOTO 7380 7370 CONTINUE C form is string name(size) init T = GETTOK(TOKEN, 201) I = 1 LEN = CTOI(TOKEN, I) IF (.NOT.(TOKEN(I) .NE. 0)) GOTO 7410 CALL SYNERR('invalid string size.') 7410 CONTINUE IF (.NOT.(GETTOK(TOKEN, 201) .NE. 41)) GOTO 7430 CALL SYNERR('missing right paren.') GOTO 7440 7430 CONTINUE T = GETTOK(TOKEN, 201) 7440 CONTINUE 7380 CONTINUE CALL OUTCH(40) CALL OUTNUM(LEN) CALL OUTCH(41) CALL OUTDON IF (.NOT.(((TOKEN(1)) .EQ. 39 .OR. (TOKEN(1)) .EQ. 34) .AND. TOK *EN(2) .NE. 0)) GOTO 7450 Q = TOKEN(1) I = 2 7470 IF (.NOT.(NQC(TOKEN,I,Q,C) .NE. 0)) GOTO 7490 CALL ADDCHR(C, SBUF, SBP, 600) 7480 I = I + 1 GOTO 7470 7490 CONTINUE GOTO 7460 7450 CONTINUE CALL ADDSTR(TOKEN, SBUF, SBP, 600) 7460 CONTINUE CALL ADDCHR(0, SBUF, SBP, 600) C peek at next token T = GETTOK(TOKEN, 201) IF (.NOT.(T .EQ. 44)) GOTO 7500 C string ..., ... 7520 IF (.NOT.(GETTOK(TOKEN, 201) .EQ. 10)) GOTO 7530 GOTO 7520 7530 CONTINUE 7500 CONTINUE CALL PBSTR(TOKEN) 7330 IF (.NOT.(T .NE. 44)) GOTO 7320 T = LEX(TOKEN) CALL PBSTR(TOKEN) IF (.NOT.(T .NE. -70)) GOTO 7540 C dump accumulated data statements I = 1 7560 IF (.NOT.(I .LT. SBP)) GOTO 7580 CALL OUTTAB CALL OUTSTR(DAT) K = 1 J = I + LENGTH(SBUF(I)) + 1 7590 CONTINUE IF (.NOT.(K .GT. 1)) GOTO 7620 CALL OUTCH(44) 7620 CONTINUE CALL OUTSTR(SBUF(I)) CALL OUTCH(40) CALL OUTNUM(K) CALL OUTCH(41) CALL OUTCH(47) IF (.NOT.(SBUF(J) .EQ. 0)) GOTO 7640 GOTO 7610 7640 CONTINUE N = ESC(SBUF, J) CALL OUTNUM(N) CALL OUTCH(47) K = K + 1 7600 J = J + 1 GOTO 7590 7610 CONTINUE CALL OUTSTR(EOSS) CALL OUTCH(47) C$ call pbstr(eoss) # use defined meaning of EOS C$ repeat { C$ t = gettok(token, MAXTOK) C$ call outstr(token) C$ } until (t == SLASH) CALL OUTDON 7570 I = J + 1 GOTO 7560 7580 CONTINUE SBP = 1 7540 CONTINUE RETURN END C ARCHIVE SWCODE.RAT 34 30-NOV-81 14:24:11 C swcode - generate code for beginning of switch statement SUBROUTINE SWCODE(LAB) INTEGER LAB, LABGEN BYTE TOK(201), GETTOK C# Preprocessor common block used to hold switch info C Put on a file named 'cswtch' C Used only by ratfiv preprocessor COMMON/CSWTCH/SWTOP, SWLAST, SWSTAK(500) C current switch entry; init = 0 INTEGER SWTOP C next available position; init = 1 INTEGER SWLAST C switch information INTEGER SWSTAK C-------------------------------------------------------------------- C# preprocessor common block to hold 'goto' flags and current label C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/LABEL, XFER C holds next label for goto, etc. INTEGER LABEL C YES if just made transfer; else NO INTEGER XFER BYTE EQS(4) DATA EQS(1)/32/,EQS(2)/61/,EQS(3)/32/,EQS(4)/0/ LAB = LABGEN(2) IF (.NOT.(SWLAST+3 .GT. 500)) GOTO 7660 CALL FATAL('switch table overflow.') 7660 CONTINUE SWSTAK(SWLAST) = SWTOP SWSTAK(SWLAST + 1) = 0 SWSTAK(SWLAST + 2) = 0 SWTOP = SWLAST SWLAST = SWLAST + 3 XFER = 0 C Innn=(e) CALL OUTTAB CALL SWVAR(LAB) CALL OUTSTR(EQS) CALL BALPAR CALL OUTDON C goto L CALL OUTGO(LAB, 1) CALL INDEN(2) 7680 IF (.NOT.(GETTOK(TOK, 201) .EQ. 10)) GOTO 7690 GOTO 7680 7690 CONTINUE IF (.NOT.(TOK(1) .NE. 91)) GOTO 7700 CALL SYNERR('missing left brace in switch statement.') CALL PBSTR(TOK) 7700 CONTINUE CALL PUTBAK(91) RETURN END C ARCHIVE SWEND.RAT 98 30-NOV-81 14:24:11 C swend - finish off switch statement; generate dispatch code SUBROUTINE SWEND(LAB) INTEGER LAB, LB, UB, N, I, J C# Preprocessor common block used to hold switch info C Put on a file named 'cswtch' C Used only by ratfiv preprocessor COMMON/CSWTCH/SWTOP, SWLAST, SWSTAK(500) C current switch entry; init = 0 INTEGER SWTOP C next available position; init = 1 INTEGER SWLAST C switch information INTEGER SWSTAK BYTE SIF(5) BYTE SLT(14) BYTE SGT(7) BYTE SGOTO(7) BYTE SEQ(7) BYTE SGE(7) BYTE SLE(7) BYTE SAND(8) BYTE EQS(4) DATA SIF(1)/105/,SIF(2)/102/,SIF(3)/32/,SIF(4)/40/,SIF(5)/0/ DATA SLT(1)/32/,SLT(2)/46/,SLT(3)/108/,SLT(4)/116/,SLT(5)/46/,SLT( *6)/32/,SLT(7)/49/,SLT(8)/32/,SLT(9)/46/,SLT(10)/111/,SLT(11)/114/, *SLT(12)/46/,SLT(13)/32/,SLT(14)/0/ DATA SGT(1)/32/,SGT(2)/46/,SGT(3)/103/,SGT(4)/116/,SGT(5)/46/,SGT( *6)/32/,SGT(7)/0/ DATA SGOTO(1)/103/,SGOTO(2)/111/,SGOTO(3)/116/,SGOTO(4)/111/,SGOTO *(5)/32/,SGOTO(6)/40/,SGOTO(7)/0/ DATA SEQ(1)/32/,SEQ(2)/46/,SEQ(3)/101/,SEQ(4)/113/,SEQ(5)/46/,SEQ( *6)/32/,SEQ(7)/0/ DATA SGE(1)/32/,SGE(2)/46/,SGE(3)/103/,SGE(4)/101/,SGE(5)/46/,SGE( *6)/32/,SGE(7)/0/ DATA SLE(1)/32/,SLE(2)/46/,SLE(3)/108/,SLE(4)/101/,SLE(5)/46/,SLE( *6)/32/,SLE(7)/0/ DATA SAND(1)/32/,SAND(2)/46/,SAND(3)/97/,SAND(4)/110/,SAND(5)/100/ *,SAND(6)/46/,SAND(7)/32/,SAND(8)/0/ DATA EQS(1)/32/,EQS(2)/61/,EQS(3)/32/,EQS(4)/0/ LB = SWSTAK(SWTOP + 3) UB = SWSTAK(SWLAST - 2) N = SWSTAK(SWTOP + 1) C terminate last case CALL OUTGO(LAB + 10, 1) CALL INDEN( - (2)) IF (.NOT.(SWSTAK(SWTOP+2) .EQ. 0)) GOTO 7720 C default default label SWSTAK(SWTOP + 2) = LAB + 10 7720 CONTINUE C L continue CALL OUTCON(LAB) IF (.NOT.(N .GE. 4 .AND. UB-LB+1 .LE. 3*N .AND. LB .GT. -32767)) G *OTO 7740 C output branch table IF (.NOT.(LB .NE. 1)) GOTO 7760 C L Innn=Innn-lb+1 CALL OUTTAB CALL SWVAR(LAB) CALL OUTSTR(EQS) CALL SWVAR(LAB) IF (.NOT.(LB .LT. 1)) GOTO 7780 CALL OUTCH(43) 7780 CONTINUE CALL OUTNUM( - LB + 1) CALL OUTDON 7760 CONTINUE C if(Innn.lt.1.or.Innn.gt.ub-lb+1)goto default CALL OUTTAB CALL OUTSTR(SIF) CALL SWVAR(LAB) CALL OUTSTR(SLT) CALL SWVAR(LAB) CALL OUTSTR(SGT) CALL OUTNUM(UB - LB + 1) CALL OUTCH(41) CALL OUTCH(32) CALL OUTGO(SWSTAK(SWTOP + 2), 0) C goto (....),Innn CALL OUTTAB CALL OUTSTR(SGOTO) J = LB I = SWTOP + 3 7800 IF (.NOT.(I .LT. SWLAST)) GOTO 7820 7830 IF (.NOT.(J .LT. SWSTAK(I))) GOTO 7850 C fill in vacancies CALL OUTNUM(SWSTAK(SWTOP + 2)) CALL OUTCH(44) 7840 J = J + 1 GOTO 7830 7850 CONTINUE J = SWSTAK(I + 1) - SWSTAK(I) 7860 IF (.NOT.(J .GE. 0)) GOTO 7880 C fill in range CALL OUTNUM(SWSTAK(I + 2)) IF (.NOT.(J .GT. 0)) GOTO 7890 CALL OUTCH(44) 7890 CONTINUE 7870 J = J - 1 GOTO 7860 7880 CONTINUE J = SWSTAK(I + 1) + 1 IF (.NOT.(I .LT. SWLAST-3)) GOTO 7910 CALL OUTCH(44) 7910 CONTINUE 7810 I = I + 3 GOTO 7800 7820 CONTINUE CALL OUTCH(41) CALL OUTCH(44) CALL OUTCH(32) CALL SWVAR(LAB) CALL OUTDON GOTO 7750 7740 CONTINUE IF (.NOT.(N .GT. 0)) GOTO 7930 C output linear search form I = SWTOP + 3 7950 IF (.NOT.(I .LT. SWLAST)) GOTO 7970 C if(Innn CALL OUTTAB CALL OUTSTR(SIF) CALL SWVAR(LAB) IF (.NOT.(SWSTAK(I) .EQ. SWSTAK(I+1))) GOTO 7980 C .eq.... CALL OUTSTR(SEQ) CALL OUTNUM(SWSTAK(I)) GOTO 7990 7980 CONTINUE C .ge.lb.and.Innn.le.ub CALL OUTSTR(SGE) CALL OUTNUM(SWSTAK(I)) CALL OUTSTR(SAND) CALL SWVAR(LAB) CALL OUTSTR(SLE) CALL OUTNUM(SWSTAK(I + 1)) 7990 CONTINUE C ) goto ... CALL OUTCH(41) CALL OUTCH(32) CALL OUTGO(SWSTAK(I + 2), 0) 7960 I = I + 3 GOTO 7950 7970 CONTINUE IF (.NOT.(LAB+10 .NE. SWSTAK(SWTOP+2))) GOTO 8000 CALL OUTGO(SWSTAK(SWTOP + 2), 1) 8000 CONTINUE 7930 CONTINUE 7750 CONTINUE C L+10 continue CALL OUTCON(LAB + 10) C pop switch stack SWLAST = SWTOP SWTOP = SWSTAK(SWTOP) RETURN END C ARCHIVE SWVAR.RAT 8 30-NOV-81 14:24:12 C swvar - output switch variable Innn, where nnn = lab SUBROUTINE SWVAR(LAB) INTEGER LAB CALL OUTCH(73) CALL OUTNUM(LAB) RETURN END C ARCHIVE UNSTAK.RAT 26 30-NOV-81 14:24:12 C unstak - unstack at end of statement SUBROUTINE UNSTAK(SP, LEXTYP, LABVAL, TOKEN) INTEGER LABVAL(100), LEXTYP(100), SP, TOKEN 8020 IF (.NOT.(SP .GT. 1)) GOTO 8040 IF (.NOT.(LEXTYP(SP) .EQ. 91)) GOTO 8050 GOTO 8040 8050 CONTINUE IF (.NOT.((LEXTYP(SP) .EQ. -57 .OR. LEXTYP(SP) .EQ. -74) .AND. T *OKEN .EQ. -55)) GOTO 8070 GOTO 8040 8070 CONTINUE I8090 = (LEXTYP(SP)) GOTO 8090 8110 CONTINUE CALL IFS(SP, LEXTYP, LABVAL) GOTO 8100 8120 CONTINUE CALL DOSTAT(LABVAL(SP)) GOTO 8100 8130 CONTINUE CALL WHILES(LABVAL(SP)) GOTO 8100 8140 CONTINUE CALL FORS(LABVAL(SP)) GOTO 8100 8150 CONTINUE CALL UNTILS(LABVAL(SP), TOKEN) GOTO 8100 8160 CONTINUE CALL SWEND(LABVAL(SP)) GOTO 8100 8090 CONTINUE I8090 = I8090+75 IF (I8090 .LT. 1 .OR. I8090 .GT. 21) GOTO 8100 GOTO (8110,8100,8100,8160,8100,8100,8100,8100,8100,8100,8130,810 *0,8100,8150,8100,8100,8100,8110,8140,8110,8120), I8090 8100 CONTINUE 8030 SP = SP - 1 GOTO 8020 8040 CONTINUE RETURN END C ARCHIVE UNTILS.RAT 20 30-NOV-81 14:24:12 C untils - generate code for until or end of repeat SUBROUTINE UNTILS(LAB, TOKEN) BYTE PTOKEN(201) INTEGER LEX INTEGER JUNK, LAB, TOKEN C-------------------------------------------------------------------- C# preprocessor common block to hold 'goto' flags and current label C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/LABEL, XFER C holds next label for goto, etc. INTEGER LABEL C YES if just made transfer; else NO INTEGER XFER XFER = 0 CALL INDEN( - (2)) CALL OUTNUM(IABS(LAB)) IF (.NOT.(TOKEN .EQ. -63)) GOTO 8170 JUNK = LEX(PTOKEN) CALL IFGO(IABS(LAB) - 10) GOTO 8180 8170 CONTINUE CALL OUTGO(IABS(LAB) - 10, 1) 8180 CONTINUE IF (.NOT.(LAB .GT. 0)) GOTO 8190 C break seen CALL OUTCON(LAB + 10) 8190 CONTINUE RETURN END C ARCHIVE WHILEC.RAT 22 30-NOV-81 14:24:12 C whilec - generate code for beginning of while SUBROUTINE WHILEC(LAB) INTEGER LABGEN INTEGER LAB C------------------------------------------------------------------ C# preprocessor common block to hold flags C put on a file named 'cflags' C Used only by ratfiv preprocessor COMMON/CFLAGS/INFORM, F77, HOLLER C when .true., < and > aren't C converted to .lt. and .gt. C when .true., output is Fortran 77 C when .true., hollerith strings LOGICAL INFORM, F77, HOLLER C are output instead of quoted strings BYTE WHILES(10) DATA WHILES(1)/100/,WHILES(2)/111/,WHILES(3)/32/,WHILES(4)/119/,WH *ILES(5)/104/,WHILES(6)/105/,WHILES(7)/108/,WHILES(8)/101/,WHILES(9 *)/32/,WHILES(10)/0/ C unlabeled continue, in case there was a label CALL OUTCON(0) LAB = LABGEN(2) CALL OUTNUM(LAB) IF (.NOT.(F77)) GOTO 8210 CALL OUTTAB CALL OUTSTR(WHILES) CALL BALPAR CALL OUTDON LAB = - LAB GOTO 8220 8210 CONTINUE CALL IFGO(LAB + 10) 8220 CONTINUE CALL INDEN(2) RETURN END C ARCHIVE WHILES.RAT 20 30-NOV-81 14:24:13 C whiles - generate code for end of while SUBROUTINE WHILES(LAB) INTEGER LAB C------------------------------------------------------------------ C# preprocessor common block to hold flags C put on a file named 'cflags' C Used only by ratfiv preprocessor COMMON/CFLAGS/INFORM, F77, HOLLER C when .true., < and > aren't C converted to .lt. and .gt. C when .true., output is Fortran 77 C when .true., hollerith strings LOGICAL INFORM, F77, HOLLER C are output instead of quoted strings C-------------------------------------------------------------------- C# preprocessor common block to hold 'goto' flags and current label C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/LABEL, XFER C holds next label for goto, etc. INTEGER LABEL C YES if just made transfer; else NO INTEGER XFER BYTE ENDDOS(7) DATA ENDDOS(1)/101/,ENDDOS(2)/110/,ENDDOS(3)/100/,ENDDOS(4)/32/,EN *DDOS(5)/100/,ENDDOS(6)/111/,ENDDOS(7)/0/ CALL INDEN( - (2)) IF (.NOT.(F77)) GOTO 8230 CALL OUTTAB CALL OUTSTR(ENDDOS) CALL OUTDON XFER = 0 GOTO 8240 8230 CONTINUE CALL OUTGO(LAB, 1) 8240 CONTINUE IF (.NOT.(LAB .GT. 0)) GOTO 8250 C break seen or not Fortran 77 output CALL OUTCON(LAB + 10) 8250 CONTINUE RETURN END C ARCHIVE MACRO.HDR 51 27-DEC-81 22:35:12 C C C C MACRO preprocessor C ================== C C Authors: Original by B. Kernighan and P. J. Plauger, C with rewrites and enhancements by David Hanson and C friends (U. of Arizona), Joe Sventek and Debbie C Scherrer (Lawrence Berkely Laboratory), and C William P. Wood, Jr. (Institute For Cancer Research). C C Address: William P. Wood, Jr. C Computer Center C Institute For Cancer Research C 7701 Burholme Ave. C Philadelphia, Pa. 19111 C (215) 728 2760 C C Version: 2.0 C C Date: December 27, 1981 C C C C ******************************************************* C * * C * THIS SOFTWARE WAS DEVELOPED WITH SUPPORT * C * FROM THE NATIONAL INSTITUTES OF HEALTH: * C * NIH CA06927 * C * NIH CA22780 * C * * C * DIRECT INQUIRIES TO: * C * COMPUTER CENTER * C * THE INSTITUTE FOR CANCER RESEARCH * C * 7701 BURHOLME AVENUE * C * PHILADELPHIA, PENNSYLVANIA 19111 * C * * C * NO WARRANTY OR REPRESENTATION, EXPRESS OR * C * IMPLIED, IS MADE WITH RESPECT TO THE * C * CORRECTNESS, COMPLETENESS, OR USEFULNESS * C * OF THIS SOFTWARE, NOR THAT USE OF THIS * C * SOFTWARE MIGHT NOT INFRINGE PRIVATELY * C * OWNED RIGHTS. * C * * C * NO LIABILITY IS ASSUMED WITH RESPECT TO * C * THE USE OF, OR FOR DAMAGES RESULTING FROM * C * THE USE OF THIS SOFTWARE * C * * C ******************************************************* C C ARCHIVE ARGTYP.RAT 43 16-DEC-81 23:37:39 C argtyp - return flags for argument types in defn INTEGER FUNCTION ARGTYP(DEFN) BYTE DEFN(1) INTEGER ATYPE, I, J, N, FOUND(10), SET, INDEX, ISSET BYTE DIGITS(11) BYTE AMPERR(46) DATA DIGITS(1)/48/,DIGITS(2)/49/,DIGITS(3)/50/,DIGITS(4)/51/,DIGIT *S(5)/52/,DIGITS(6)/53/,DIGITS(7)/54/,DIGITS(8)/55/,DIGITS(9)/56/,D *IGITS(10)/57/,DIGITS(11)/0/ DATA AMPERR(1)/97/,AMPERR(2)/114/,AMPERR(3)/103/,AMPERR(4)/117/,AM *PERR(5)/109/,AMPERR(6)/101/,AMPERR(7)/110/,AMPERR(8)/116/,AMPERR(9 *)/115/,AMPERR(10)/32/,AMPERR(11)/99/,AMPERR(12)/97/,AMPERR(13)/110 */,AMPERR(14)/110/,AMPERR(15)/111/,AMPERR(16)/116/,AMPERR(17)/32/,A *MPERR(18)/98/,AMPERR(19)/101/,AMPERR(20)/32/,AMPERR(21)/98/,AMPERR *(22)/111/,AMPERR(23)/116/,AMPERR(24)/104/,AMPERR(25)/32/,AMPERR(26 *)/110/,AMPERR(27)/117/,AMPERR(28)/109/,AMPERR(29)/101/,AMPERR(30)/ *114/,AMPERR(31)/105/,AMPERR(32)/99/,AMPERR(33)/32/,AMPERR(34)/97/, *AMPERR(35)/110/,AMPERR(36)/100/,AMPERR(37)/32/,AMPERR(38)/38/,AMPE *RR(39)/32/,AMPERR(40)/116/,AMPERR(41)/121/,AMPERR(42)/112/,AMPERR( *43)/101/,AMPERR(44)/115/,AMPERR(45)/46/,AMPERR(46)/0/ DO 2000 I = 1, 10 FOUND(I) = 0 2000 CONTINUE ATYPE = 0 I = 1 2020 IF (.NOT.(DEFN(I) .NE. 0)) GOTO 2040 IF (.NOT.(DEFN(I) .EQ. 36 .OR. DEFN(I) .EQ. 37)) GOTO 2050 N = INDEX(DIGITS, DEFN(I + 1)) IF (.NOT.(DEFN(I+1) .EQ. 38)) GOTO 2070 IF (.NOT.(ISSET(ATYPE, 11) .EQ. 0)) GOTO 2090 DO 2110 J = 1, 10 IF (.NOT.(FOUND(J) .NE. 0)) GOTO 2130 CALL SYNERR(AMPERR) GOTO 2030 2130 CONTINUE 2110 CONTINUE ATYPE = SET(ATYPE, 11) 2090 CONTINUE N = 2 2070 CONTINUE IF (.NOT.(N .NE. 0)) GOTO 2150 ATYPE = SET(ATYPE, 10) IF (.NOT.(DEFN(I+1) .NE. 38 .AND. ISSET(ATYPE, 11) .EQ. 1)) *GOTO 2170 CALL SYNERR(AMPERR) N = 2 GOTO 2180 2170 CONTINUE IF (.NOT.(FOUND(N) .NE. 0 .AND. FOUND(N) .NE. DEFN(I))) GOTO * 2190 CALL SYNERR('argument cannot be both eval type and noeval *type.') GOTO 2180 2190 CONTINUE FOUND(N) = DEFN(I) IF (.NOT.(DEFN(I) .EQ. 37)) GOTO 2210 ATYPE = SET(ATYPE, N - 1) 2210 CONTINUE 2180 CONTINUE DEFN(I) = 36 DEFN(I + 1) = DIGITS(N) 2150 CONTINUE 2050 CONTINUE 2030 I = I + 1 GOTO 2020 2040 CONTINUE ARGTYP = (ATYPE) RETURN END C ARCHIVE DEFTOK.RAT 131 18-DEC-81 00:37:53 C deftok - get token, process macro invocations BYTE FUNCTION DEFTOK(TOKEN, TOKSIZ) BYTE TOKEN(1), DEFN(500) INTEGER J, NLB, TOKSIZ, ARGTY BYTE GTOKEN INTEGER LOOKUP, PUSH, LENGTH, ISSET, NOEVAL C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV C-------------------------------------------------------------------- C# preprocessor common block to hold definitions C put on a file named 'clook' C Used by ratfiv preprocessor, macro, and form tools COMMON/CLOOK/AVAIL, TABPTR(127), TABLE(5501) Cfirst location in table; init = 1 INTEGER AVAIL Cname poiners; init = 0 INTEGER TABPTR Cactual text of names and definitions BYTE TABLE C---------------------------------------------------------------------- C preprocessor common block to hold input characters C Put on a file called 'cdefio' C Used by ratfiv preprocessor and macro COMMON/CDEFIO/BP, BPLOW, BPSAVE(4), BUF(900) C next available character; init = 0 INTEGER BP C bottom of push-back buffer at current file level INTEGER BPLOW C holds bplow for active file levels INTEGER BPSAVE C pushed-back characters BYTE BUF C----------------------------------------------------------------------- C preprocessor common block to hold info about lines and included files C put on a file named 'cline' C used by ratfiv preproccessor and macro COMMON/CLINE/LEVEL, INFILE(4), LINECT(4), FNAMP(4), FNAMES(136), I *OIN(134) C level of file inclusion; init = 1 INTEGER LEVEL C file number(level); init infile(1) = STDIN INTEGER INFILE C line count on input file(level); init = 1 INTEGER LINECT C next free slot in fnames INTEGER FNAMP C stack of open file names BYTE FNAMES C input buffer BYTE IOIN BYTE BALP(3) DATA BALP(1)/40/,BALP(2)/41/,BALP(3)/0/ 2230 IF (.NOT.(LEVEL .GT. 0)) GOTO 2250 DEFTOK = GTOKEN(TOKEN, TOKSIZ) 2260 IF (.NOT.(DEFTOK .NE. -10)) GOTO 2280 IF (.NOT.(DEFTOK .EQ. 1)) GOTO 2290 IF (.NOT.(LOOKUP(TOKEN, DEFN, ARGTY) .EQ. 0)) GOTO 2310 IF (.NOT.(CP .EQ. 0)) GOTO 2330 IF (.NOT.(DEFSTK(DEFCNT))) GOTO 2350 RETURN 2350 CONTINUE GOTO 2340 2330 CONTINUE CALL PUTTOK(TOKEN) 2340 CONTINUE GOTO 2320 2310 CONTINUE IF (.NOT.(NOEVAL(CP, AP, CALLST, ARGSTK) .EQ. 1)) GOTO 2370 CALL PUTTOK(TOKEN) GOTO 2320 2370 CONTINUE C defined; put it in eval stack CP = CP + 1 IF (.NOT.(CP .GT. 30)) GOTO 2390 CALL FATAL('call stack overflow.') 2390 CONTINUE CALLST(CP) = AP AP = PUSH(ARGTY, ARGSTK, AP) AP = PUSH(EP, ARGSTK, AP) C stack definition CALL PUTTOK(DEFN) CALL PUTCHR(0) AP = PUSH(EP, ARGSTK, AP) C stack name CALL PUTTOK(TOKEN) CALL PUTCHR(0) AP = PUSH(EP, ARGSTK, AP) IF (.NOT.(ISSET(ARGTY, 10) .EQ. 1)) GOTO 2410 J = 0 2430 CONTINUE C peek at next DEFTOK = GTOKEN(TOKEN, TOKSIZ) J = J + 1 2440 IF (.NOT.(DEFTOK .NE. 32)) GOTO 2430 CALL PBSTR(TOKEN) IF (.NOT.(DEFTOK .NE. 40)) GOTO 2460 C add ( ) if not present 2480 IF (.NOT.(J .GT. 1)) GOTO 2500 CALL PUTBAK(32) 2490 J = J - 1 GOTO 2480 2500 CONTINUE CALL PBSTR(BALP) 2460 CONTINUE GOTO 2420 2410 CONTINUE CALL PBSTR(BALP) 2420 CONTINUE PLEV(CP) = 0 2320 CONTINUE GOTO 2300 2290 CONTINUE IF (.NOT.(CP .EQ. 0)) GOTO 2510 C not in a macro at all IF (.NOT.(DEFSTK(DEFCNT))) GOTO 2530 RETURN 2530 CONTINUE GOTO 2300 2510 CONTINUE IF (.NOT.(DEFTOK .EQ. 40)) GOTO 2550 IF (.NOT.(PLEV(CP) .GT. 0)) GOTO 2570 CALL PUTTOK(TOKEN) 2570 CONTINUE PLEV(CP) = PLEV(CP) + 1 GOTO 2300 2550 CONTINUE IF (.NOT.(DEFTOK .EQ. 41)) GOTO 2590 PLEV(CP) = PLEV(CP) - 1 IF (.NOT.(PLEV(CP) .GT. 0)) GOTO 2610 CALL PUTTOK(TOKEN) GOTO 2620 2610 CONTINUE C end of argument list CALL PUTCHR(0) CALL EVAL(CALLST(CP) + 1, CALLST(CP) + 2, AP - CALLST(CP) *- 3) C pop eval stack AP = CALLST(CP) EP = ARGSTK(AP + 1) CP = CP - 1 2620 CONTINUE GOTO 2300 2590 CONTINUE IF (.NOT.(DEFTOK .EQ. 44 .AND. PLEV(CP) .EQ. 1)) GOTO 2630 C new argument IF (.NOT.(ISSET(ARGSTK(CALLST(CP)), 11) .EQ. 1)) GOTO 2650 C allow commas in argument CALL PUTTOK(TOKEN) GOTO 2660 2650 CONTINUE CALL PUTCHR(0) IF (.NOT.(AP-CALLST(CP)-3 .GE. 9)) GOTO 2670 CALL SYNERR('too many arguments passed to a macro.') GOTO 2680 2670 CONTINUE AP = PUSH(EP, ARGSTK, AP) 2680 CONTINUE 2660 CONTINUE GOTO 2300 2630 CONTINUE C just stack it CALL PUTTOK(TOKEN) 2300 CONTINUE 2270 DEFTOK = GTOKEN(TOKEN, TOKSIZ) GOTO 2260 2280 CONTINUE IF (.NOT.(INFILE(LEVEL) .NE. 5)) GOTO 2690 C here on EOF; pop back to last file CALL CLOSE(INFILE(LEVEL)) 2690 CONTINUE C restore bottom of push-back buffer BPLOW = BPSAVE(LEVEL) 2240 LEVEL = LEVEL - 1 GOTO 2230 2250 CONTINUE IF (.NOT.(CP .NE. 0 .OR. DEFCNT .GT. 1)) GOTO 2710 CALL SYNERR('unexpected EOF.') 2710 CONTINUE C in case called more than once DEFTOK = - 10 TOKEN(1) = - 10 TOKEN(2) = 0 RETURN END C ARCHIVE DOARTH.RAT 30 30-NOV-81 14:32:08 C doarth - arithmetic interpreter SUBROUTINE DOARTH(IARGS, NARGS) INTEGER IARGS, NARGS INTEGER CTOI INTEGER K, OP1, OP2, A BYTE OP C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV IF (.NOT.(NARGS .GT. 0)) GOTO 2730 A = ARGSTK(IARGS + 1) OP1 = CTOI(EVALST, A) K = 2 2750 IF (.NOT.(K+1 .LE. NARGS)) GOTO 2770 OP = EVALST(ARGSTK(IARGS + K)) A = ARGSTK(IARGS + K + 1) OP2 = CTOI(EVALST, A) IF (.NOT.(OP .EQ. 43)) GOTO 2780 OP1 = OP1 + OP2 GOTO 2790 2780 CONTINUE IF (.NOT.(OP .EQ. 45)) GOTO 2800 OP1 = OP1 - OP2 GOTO 2790 2800 CONTINUE IF (.NOT.(OP .EQ. 42)) GOTO 2820 OP1 = OP1*OP2 GOTO 2790 2820 CONTINUE IF (.NOT.(OP .EQ. 47 .AND. OP2 .NE. 0)) GOTO 2840 OP1 = OP1/OP2 GOTO 2790 2840 CONTINUE CALL SYNERR('arith error.') 2790 CONTINUE 2760 K = K + 2 GOTO 2750 2770 CONTINUE 2730 CONTINUE CALL PBNUM(OP1) RETURN END C ARCHIVE DODEF.RAT 32 30-NOV-81 14:32:09 C dodef - install definition in table SUBROUTINE DODEF(IARGS, NARGS) INTEGER A1, IARGS, NARGS, ARGTYP, I BYTE C, NGETCH, TYPE C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV IF (.NOT.(NARGS .GE. 1)) GOTO 2860 A1 = ARGSTK(IARGS + 1) I = 0 2880 CONTINUE IF (.NOT.(TYPE(EVALST(A1+I)) .NE. 3 .AND. EVALST(A1+I) .NE. 95 * .AND. EVALST(A1+I) .NE. 36 .AND. (I .EQ. 0 .OR. TYPE(EVALST(A1+I) *) .NE. 2))) GOTO 2910 CALL ERRLIN(EVALST(A1)) CALL SYNERR('illegal macro name.') GOTO 10 2910 CONTINUE I = I + 1 2890 IF (.NOT.(EVALST(A1+I) .EQ. 44 .OR. EVALST(A1+I) .EQ. 0)) GOTO 2 *880 IF (.NOT.(EVALST(A1+I) .NE. 0)) GOTO 2930 EVALST(A1 + I) = 0 CALL INSTAL(EVALST(A1), EVALST(A1 + I + 1), ARGTYP(EVALST(A1 + * I + 1))) GOTO 2940 2930 CONTINUE CALL INSTAL(EVALST(A1), 0, 0) 2940 CONTINUE 2860 CONTINUE 10 IF (.NOT.(NGETCH(C) .NE. 10)) GOTO 2950 CALL PUTBAK(C) 2950 CONTINUE RETURN END C ARCHIVE DOELSD.RAT 13 30-NOV-81 14:32:09 C doelsd - handle _elsedef SUBROUTINE DOELSD BYTE C, NGETCH C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV IF (.NOT.(DEFCNT .LE. 1)) GOTO 2970 CALL SYNERR('bad _elsedef.') GOTO 2980 2970 CONTINUE DEFSTK(DEFCNT) = DEFSTK(DEFCNT - 1) .AND. .NOT.DEFSTK(DEFCNT) 2980 CONTINUE IF (.NOT.(NGETCH(C) .NE. 10)) GOTO 2990 CALL PUTBAK(C) 2990 CONTINUE RETURN END C ARCHIVE DOENDD.RAT 13 30-NOV-81 14:32:09 C doendd - handle _enddef SUBROUTINE DOENDD BYTE C, NGETCH C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV IF (.NOT.(DEFCNT .LE. 1)) GOTO 3010 CALL SYNERR('bad _enddef.') GOTO 3020 3010 CONTINUE DEFCNT = DEFCNT - 1 3020 CONTINUE IF (.NOT.(NGETCH(C) .NE. 10)) GOTO 3030 CALL PUTBAK(C) 3030 CONTINUE RETURN END C ARCHIVE DOIF.RAT 14 30-NOV-81 14:32:09 C doif - select one of two (macro) arguments /*/sor/macror/doif SUBROUTINE DOIF(IARGS, NARGS) INTEGER EQUAL INTEGER IARGS, NARGS C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV IF (.NOT.(NARGS .LT. 3)) GOTO 3050 RETURN 3050 CONTINUE IF (.NOT.(EQUAL(EVALST(ARGSTK(IARGS+1)), EVALST(ARGSTK(IARGS+2))) *.EQ. 1)) GOTO 3070 C subarrays CALL PBSTR(EVALST(ARGSTK(IARGS + 3))) GOTO 3080 3070 CONTINUE IF (.NOT.(NARGS .GE. 4)) GOTO 3090 CALL PBSTR(EVALST(ARGSTK(IARGS + 4))) 3090 CONTINUE 3080 CONTINUE RETURN END C ARCHIVE DOIFD.RAT 18 30-NOV-81 14:32:09 C doifd - do ifdef builtin macro SUBROUTINE DOIFD(IARGS, NARGS) INTEGER IARGS, NARGS, LOCDEF, JUNK1, JUNK2 BYTE C, NGETCH C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV DEFCNT = DEFCNT + 1 IF (.NOT.(DEFCNT .GT. 20)) GOTO 3110 CALL FATAL('_ifdefs nested too deeply.') 3110 CONTINUE DEFSTK(DEFCNT) = DEFSTK(DEFCNT - 1) IF (.NOT.(DEFSTK(DEFCNT))) GOTO 3130 IF (.NOT.(NARGS .GT. 0)) GOTO 3150 IF (.NOT.(LOCDEF(EVALST(ARGSTK(IARGS+1)), JUNK1, JUNK2, C) .NE *. 1)) GOTO 3170 DEFSTK(DEFCNT) = .FALSE. 3170 CONTINUE 3150 CONTINUE 3130 CONTINUE IF (.NOT.(NGETCH(C) .NE. 10)) GOTO 3190 CALL PUTBAK(C) 3190 CONTINUE RETURN END C ARCHIVE DOINCL.RAT 12 1-DEC-81 11:46:04 C doincl - handle file inclusion for macro SUBROUTINE DOINCL(IARGS, NARGS) INTEGER IARGS, NARGS BYTE NGETCH, C C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV C----------------------------------------------------------------------- C preprocessor common block to hold info about lines and included files C put on a file named 'cline' C used by ratfiv preproccessor and macro COMMON/CLINE/LEVEL, INFILE(4), LINECT(4), FNAMP(4), FNAMES(136), I *OIN(134) C level of file inclusion; init = 1 INTEGER LEVEL C file number(level); init infile(1) = STDIN INTEGER INFILE C line count on input file(level); init = 1 INTEGER LINECT C next free slot in fnames INTEGER FNAMP C stack of open file names BYTE FNAMES C input buffer BYTE IOIN IF (.NOT.(NGETCH(C) .NE. 10)) GOTO 3210 CALL PUTBAK(C) 3210 CONTINUE CALL INCLUD(EVALST(ARGSTK(IARGS + 1))) RETURN END C ARCHIVE DOINCR.RAT 12 30-NOV-81 14:32:10 C doincr - increment macro argument by 1 SUBROUTINE DOINCR(IARGS, NARGS) INTEGER CTOI INTEGER IARGS, NARGS, K C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV IF (.NOT.(NARGS .NE. 0)) GOTO 3230 K = ARGSTK(IARGS + 1) CALL PBNUM(CTOI(EVALST, K) + 1) 3230 CONTINUE RETURN END C ARCHIVE DOIND.RAT 12 30-NOV-81 14:32:10 C doind - get index of arg2 in arg1 SUBROUTINE DOIND(IARGS, NARGS) INTEGER IARGS, NARGS INTEGER INDEX C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV IF (.NOT.(NARGS .EQ. 1)) GOTO 3250 CALL PBNUM(0) GOTO 3260 3250 CONTINUE IF (.NOT.(NARGS .GE. 2)) GOTO 3270 CALL PBNUM(INDEX(EVALST(ARGSTK(IARGS + 1)), EVALST(ARGSTK(IARGS *+ 2)))) 3270 CONTINUE 3260 CONTINUE RETURN END C ARCHIVE DOLEN.RAT 12 30-NOV-81 14:32:10 C dolen - get length of argument SUBROUTINE DOLEN(IARGS, NARGS) INTEGER IARGS, NARGS INTEGER LENGTH C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV IF (.NOT.(NARGS .LT. 1)) GOTO 3290 CALL PBNUM(0) GOTO 3300 3290 CONTINUE CALL PBNUM(LENGTH(EVALST(ARGSTK(IARGS + 1)))) 3300 CONTINUE RETURN END C ARCHIVE DOSUB.RAT 29 30-NOV-81 14:32:10 C dosub - select macro substring SUBROUTINE DOSUB(IARGS, NARGS) INTEGER CTOI, LENGTH INTEGER AP1, FC, IARGS, NARGS, K, NC, BS C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV IF (.NOT.(NARGS .EQ. 0)) GOTO 3310 RETURN 3310 CONTINUE IF (.NOT.(NARGS .EQ. 1)) GOTO 3330 BS = 1 GOTO 3340 3330 CONTINUE K = ARGSTK(IARGS + 2) BS = CTOI(EVALST, K) 3340 CONTINUE IF (.NOT.(NARGS .LE. 2)) GOTO 3350 NC = 32767 GOTO 3360 3350 CONTINUE K = ARGSTK(IARGS + 3) C number of characters NC = CTOI(EVALST, K) 3360 CONTINUE C target string AP1 = ARGSTK(IARGS + 1) C first char of substring FC = AP1 + BS - 1 IF (.NOT.(FC .GE. AP1 .AND. FC .LT. AP1+LENGTH(EVALST(AP1)))) GOTO * 3370 C subarrays K = FC + MIN0(NC, LENGTH(EVALST(FC))) - 1 3390 IF (.NOT.(K .GE. FC)) GOTO 3410 CALL PUTBAK(EVALST(K)) 3400 K = K - 1 GOTO 3390 3410 CONTINUE 3370 CONTINUE RETURN END C ARCHIVE DOUND.RAT 17 30-NOV-81 14:32:11 C dound - undefine a macro and garbage collect SUBROUTINE DOUND(IARGS, NARGS) INTEGER IARGS, NARGS, A1, I, INDEX BYTE NGETCH, C C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV IF (.NOT.(NARGS .GE. 1)) GOTO 3420 A1 = ARGSTK(IARGS + 1) I = INDEX(EVALST(A1), 44) IF (.NOT.(I .NE. 0)) GOTO 3440 EVALST(A1 + I - 1) = 0 3440 CONTINUE CALL UNDEF(EVALST(A1)) 3420 CONTINUE IF (.NOT.(NGETCH(C) .NE. 10)) GOTO 3460 CALL PUTBAK(C) 3460 CONTINUE RETURN END C ARCHIVE ERRLIN.RAT 12 30-NOV-81 14:32:11 C errlin - save a string to output to STDOUT and to ERROUT SUBROUTINE ERRLIN(MESS) BYTE MESS(1) INTEGER I, J, LENGTH C cerrbf - holds an error message for later output by synerr COMMON/CERRBF/ERRBUF(201) BYTE ERRBUF J = LENGTH(ERRBUF) I = J + 1 3480 IF (.NOT.(I .LT. 201 .AND. MESS(I-J) .NE. 0)) GOTO 3500 ERRBUF(I) = MESS(I - J) 3490 I = I + 1 GOTO 3480 3500 CONTINUE ERRBUF(I) = 0 RETURN END C ARCHIVE EVAL.RAT 63 4-DEC-81 13:25:18 C eval - expand args: evaluate builtin or push back defn SUBROUTINE EVAL(IDEFN, IARGS, NARGS) INTEGER INDEX, LENGTH INTEGER ARGNO, IDEFN, IARGS, NARGS, K, T, TD C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV BYTE DIGITS(11) DATA DIGITS(1)/48/,DIGITS(2)/49/,DIGITS(3)/50/,DIGITS(4)/51/,DIGIT *S(5)/52/,DIGITS(6)/53/,DIGITS(7)/54/,DIGITS(8)/55/,DIGITS(9)/56/,D *IGITS(10)/57/,DIGITS(11)/0/ T = ARGSTK(IDEFN) TD = EVALST(T) IF (.NOT.(TD .LT. 0)) GOTO 3510 IF (.NOT.(TD .EQ. -27)) GOTO 3530 CALL DOIFD(IARGS, NARGS) GOTO 3540 3530 CONTINUE IF (.NOT.(TD .EQ. -28)) GOTO 3550 CALL DOELSD GOTO 3540 3550 CONTINUE IF (.NOT.(TD .EQ. -29)) GOTO 3570 CALL DOENDD GOTO 3540 3570 CONTINUE IF (.NOT.(TD .EQ. -22)) GOTO 3590 CALL DOINCR(IARGS, NARGS) GOTO 3540 3590 CONTINUE IF (.NOT.(TD .EQ. -23)) GOTO 3610 CALL DOSUB(IARGS, NARGS) GOTO 3540 3610 CONTINUE IF (.NOT.(TD .EQ. -21)) GOTO 3630 CALL DOIF(IARGS, NARGS) GOTO 3540 3630 CONTINUE IF (.NOT.(TD .EQ. -24)) GOTO 3650 CALL DOARTH(IARGS, NARGS) GOTO 3540 3650 CONTINUE IF (.NOT.(TD .EQ. -25)) GOTO 3670 CALL DOLEN(IARGS, NARGS) GOTO 3540 3670 CONTINUE IF (.NOT.(TD .EQ. -26)) GOTO 3690 CALL DOIND(IARGS, NARGS) GOTO 3540 3690 CONTINUE IF (.NOT.(TD .EQ. -30)) GOTO 3710 IF (.NOT.(DEFSTK(DEFCNT))) GOTO 3730 CALL DOINCL(IARGS, NARGS) 3730 CONTINUE GOTO 3540 3710 CONTINUE IF (.NOT.(TD .EQ. -20)) GOTO 3750 IF (.NOT.(DEFSTK(DEFCNT))) GOTO 3770 CALL DODEF(IARGS, NARGS) 3770 CONTINUE GOTO 3540 3750 CONTINUE IF (.NOT.(TD .EQ. -31)) GOTO 3790 IF (.NOT.(DEFSTK(DEFCNT))) GOTO 3810 CALL DOUND(IARGS, NARGS) 3810 CONTINUE C just pass it along GOTO 3540 3790 CONTINUE CALL PUTBAK(EVALST(T)) 3540 CONTINUE GOTO 3520 3510 CONTINUE K = T + LENGTH(EVALST(T)) - 1 3830 IF (.NOT.(K .GT. T)) GOTO 3850 IF (.NOT.(EVALST(K-1) .NE. 36)) GOTO 3860 CALL PUTBAK(EVALST(K)) GOTO 3870 3860 CONTINUE ARGNO = INDEX(DIGITS, EVALST(K)) - 1 IF (.NOT.(ARGNO .GE. 0 .AND. ARGNO .LE. NARGS)) GOTO 3880 CALL PBSTR(EVALST(ARGSTK(IARGS + ARGNO))) C skip over $ K = K - 1 GOTO 3890 3880 CONTINUE IF (.NOT.(ARGNO .EQ. -1)) GOTO 3900 C wasn't a digit CALL PUTBAK(EVALST(K)) GOTO 3890 3900 CONTINUE C skip over $ K = K - 1 3890 CONTINUE 3870 CONTINUE 3840 K = K - 1 GOTO 3830 3850 CONTINUE IF (.NOT.(K .EQ. T)) GOTO 3920 C do last character CALL PUTBAK(EVALST(K)) 3920 CONTINUE 3520 CONTINUE RETURN END C ARCHIVE FATAL.RAT 8 30-NOV-81 14:32:11 C fatal - handle fatal error SUBROUTINE FATAL(MESS) BYTE MESS(1) CALL SYNERR(MESS) CALL ERROR(0) RETURN END C ARCHIVE GETINT.RAT 11 30-NOV-81 14:32:12 C getint - get an integer from table INTEGER FUNCTION GETINT(TABLE) BYTE TABLE(2), C(2) INTEGER I, J EQUIVALENCE(I, C) DO 3940 J = 1, 2 C(J) = TABLE(J) 3940 CONTINUE GETINT = I RETURN END C ARCHIVE GTOKENM.RAT 42 30-NOV-81 14:32:12 C ARCHIVE INCLUD.RAT 26 1-DEC-81 11:47:48 C includ - handle file inclusion SUBROUTINE INCLUD(FILE) BYTE FILE(1) INTEGER LENGTH, OPEN C----------------------------------------------------------------------- C preprocessor common block to hold info about lines and included files C put on a file named 'cline' C used by ratfiv preproccessor and macro COMMON/CLINE/LEVEL, INFILE(4), LINECT(4), FNAMP(4), FNAMES(136), I *OIN(134) C level of file inclusion; init = 1 INTEGER LEVEL C file number(level); init infile(1) = STDIN INTEGER INFILE C line count on input file(level); init = 1 INTEGER LINECT C next free slot in fnames INTEGER FNAMP C stack of open file names BYTE FNAMES C input buffer BYTE IOIN C---------------------------------------------------------------------- C preprocessor common block to hold input characters C Put on a file called 'cdefio' C Used by ratfiv preprocessor and macro COMMON/CDEFIO/BP, BPLOW, BPSAVE(4), BUF(900) C next available character; init = 0 INTEGER BP C bottom of push-back buffer at current file level INTEGER BPLOW C holds bplow for active file levels INTEGER BPSAVE C pushed-back characters BYTE BUF IF (.NOT.(LEVEL .GE. 4)) GOTO 3960 CALL SYNERR('includes nested too deeply.') GOTO 3970 3960 CONTINUE INFILE(LEVEL + 1) = OPEN(FILE, 'R') IF (.NOT.(INFILE(LEVEL+1) .EQ. -1)) GOTO 3980 CALL ERRLIN(FILE) CALL SYNERR('can''t open included file.') GOTO 3990 3980 CONTINUE LEVEL = LEVEL + 1 LINECT(LEVEL) = 0 FNAMP(LEVEL) = FNAMP(LEVEL - 1) + LENGTH(FNAMES(FNAMP(LEVEL - *1))) + 1 CALL SCOPY(FILE, 1, FNAMES, FNAMP(LEVEL)) BPSAVE(LEVEL) = BPLOW BPLOW = BP 3990 CONTINUE 3970 CONTINUE RETURN END C ARCHIVE INIMAC.RAT 80 30-NOV-81 22:50:44 C inimac - initialize macro preproccessor SUBROUTINE INIMAC C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV C-------------------------------------------------------------------- C# preprocessor common block to hold definitions C put on a file named 'clook' C Used by ratfiv preprocessor, macro, and form tools COMMON/CLOOK/AVAIL, TABPTR(127), TABLE(5501) Cfirst location in table; init = 1 INTEGER AVAIL Cname poiners; init = 0 INTEGER TABPTR Cactual text of names and definitions BYTE TABLE C---------------------------------------------------------------------- C preprocessor common block to hold input characters C Put on a file called 'cdefio' C Used by ratfiv preprocessor and macro COMMON/CDEFIO/BP, BPLOW, BPSAVE(4), BUF(900) C next available character; init = 0 INTEGER BP C bottom of push-back buffer at current file level INTEGER BPLOW C holds bplow for active file levels INTEGER BPSAVE C pushed-back characters BYTE BUF C cerrbf - holds an error message for later output by synerr COMMON/CERRBF/ERRBUF(201) BYTE ERRBUF INTEGER SET, ARGTYP BYTE MACNAM(7), MACTYP(2) BYTE UNDNAM(7), UNDTYP(2) BYTE INCNAM(6), INCTYP(2) BYTE SUBNAM(8), SUBTYP(2) BYTE IFENAM(8), IFETYP(2) BYTE ARINAM(7), ARITYP(2) BYTE LENNAM(5), LENTYP(2) BYTE INDNAM(7), INDTYP(2) BYTE IFDNAM(7), IFDTYP(2) BYTE ELSNAM(9), ELSTYP(2) BYTE ENDNAM(8), ENDTYP(2) BYTE ICLNAM(9), ICLTYP(2) BYTE IFNNAM(8) BYTE IFNDEF(19) BYTE REPNAM(8) BYTE REPDEF(21) DATA IFNNAM(1)/95/,IFNNAM(2)/105/,IFNNAM(3)/102/,IFNNAM(4)/110/,IF *NNAM(5)/100/,IFNNAM(6)/101/,IFNNAM(7)/102/,IFNNAM(8)/0/ DATA IFNDEF(1)/95/,IFNDEF(2)/105/,IFNDEF(3)/102/,IFNDEF(4)/100/,IF *NDEF(5)/101/,IFNDEF(6)/102/,IFNDEF(7)/40/,IFNDEF(8)/37/,IFNDEF(9)/ *49/,IFNDEF(10)/41/,IFNDEF(11)/95/,IFNDEF(12)/101/,IFNDEF(13)/108/, *IFNDEF(14)/115/,IFNDEF(15)/101/,IFNDEF(16)/100/,IFNDEF(17)/101/,IF *NDEF(18)/102/,IFNDEF(19)/0/ DATA REPNAM(1)/95/,REPNAM(2)/114/,REPNAM(3)/101/,REPNAM(4)/112/,RE *PNAM(5)/100/,REPNAM(6)/101/,REPNAM(7)/102/,REPNAM(8)/0/ DATA REPDEF(1)/95/,REPDEF(2)/117/,REPDEF(3)/110/,REPDEF(4)/100/,RE *PDEF(5)/101/,REPDEF(6)/102/,REPDEF(7)/40/,REPDEF(8)/37/,REPDEF(9)/ *38/,REPDEF(10)/41/,REPDEF(11)/95/,REPDEF(12)/109/,REPDEF(13)/97/,R *EPDEF(14)/99/,REPDEF(15)/114/,REPDEF(16)/111/,REPDEF(17)/40/,REPDE *F(18)/37/,REPDEF(19)/38/,REPDEF(20)/41/,REPDEF(21)/0/ DATA MACNAM/95, 109, 97, 99, 114, 111, 0/, MACTYP/ - 20, 0/ DATA UNDNAM/95, 117, 110, 100, 101, 102, 0/, UNDTYP/ - 31, 0/ DATA INCNAM/95, 105, 110, 99, 114, 0/, INCTYP/ - 22, 0/ DATA SUBNAM/95, 115, 117, 98, 115, 116, 114, 0/, SUBTYP/ - 23, 0/ DATA IFENAM/95, 105, 102, 101, 108, 115, 101, 0/, IFETYP/ - 21, 0/ DATA ARINAM/95, 97, 114, 105, 116, 104, 0/, ARITYP/ - 24, 0/ DATA LENNAM/95, 108, 101, 110, 0/, LENTYP/ - 25, 0/ DATA INDNAM/95, 105, 110, 100, 101, 120, 0/, INDTYP/ - 26, 0/ DATA IFDNAM/95, 105, 102, 100, 101, 102, 0/, IFDTYP/ - 27, 0/ DATA ELSNAM/95, 101, 108, 115, 101, 100, 101, 102, 0/, ELSTYP/ - 2 *8, 0/ DATA ENDNAM/95, 101, 110, 100, 100, 101, 102, 0/, ENDTYP/ - 29, 0/ DATA ICLNAM/95, 105, 110, 99, 108, 117, 100, 101, 0/, ICLTYP/ - 30 *, 0/ AVAIL = 1 I = 1 4000 IF (.NOT.(I .LE. 127)) GOTO 4020 TABPTR(I) = 0 4010 I = I + 1 GOTO 4000 4020 CONTINUE CALL INSUPL(MACNAM, MACTYP, SET(SET(SET(0, 10), 11), 1)) CALL INSUPL(UNDNAM, UNDTYP, SET(SET(SET(0, 10), 11), 1)) CALL INSUPL(INCNAM, INCTYP, SET(0, 10)) CALL INSUPL(SUBNAM, SUBTYP, SET(0, 10)) CALL INSUPL(IFENAM, IFETYP, SET(SET(SET(0, 10), 3), 4)) CALL INSUPL(ARINAM, ARITYP, SET(0, 10)) CALL INSUPL(LENNAM, LENTYP, SET(SET(0, 10), 11)) CALL INSUPL(INDNAM, INDTYP, SET(0, 10)) CALL INSUPL(IFDNAM, IFDTYP, SET(SET(0, 10), 1)) CALL INSUPL(ELSNAM, ELSTYP, 0) CALL INSUPL(ENDNAM, ENDTYP, 0) CALL INSUPL(ICLNAM, ICLTYP, SET(SET(0, 10), 11)) CALL INSUPL(IFNNAM, IFNDEF, ARGTYP(IFNDEF)) CALL INSUPL(REPNAM, REPDEF, ARGTYP(REPDEF)) C initialize pointers, etc. BP = 0 BPSAVE(1) = 0 BPLOW = 0 CP = 0 AP = 1 EP = 1 DEFCNT = 1 DEFSTK(1) = .TRUE. ERRBUF(1) = 0 RETURN END C ARCHIVE INSTAL.RAT 30 30-NOV-81 14:32:12 C instal - add name and definition to table SUBROUTINE INSTAL(NAME, DEFN, FLAG) BYTE DEFN(500), NAME(201), C INTEGER LENGTH INTEGER DLEN, NLEN, FLAG C-------------------------------------------------------------------- C# preprocessor common block to hold definitions C put on a file named 'clook' C Used by ratfiv preprocessor, macro, and form tools COMMON/CLOOK/AVAIL, TABPTR(127), TABLE(5501) Cfirst location in table; init = 1 INTEGER AVAIL Cname poiners; init = 0 INTEGER TABPTR Cactual text of names and definitions BYTE TABLE IF (.NOT.(NAME(1) .NE. 0)) GOTO 4030 NLEN = LENGTH(NAME) + 1 DLEN = LENGTH(DEFN) + 1 IF (.NOT.(DLEN .GT. 500)) GOTO 4050 CALL ERRLIN(NAME) CALL SYNERR('definition too long.') RETURN 4050 CONTINUE IF (.NOT.(AVAIL+NLEN+DLEN+2*2 .GT. 5501+1)) GOTO 4070 CALL ERRLIN(NAME) CALL FATAL('too many definitions.') RETURN 4070 CONTINUE CALL SETINT(TABLE(AVAIL + 2), FLAG) CALL SCOPY(NAME, 1, TABLE, AVAIL + 2*2) CALL SCOPY(DEFN, 1, TABLE, AVAIL + NLEN + 2*2) C = TABLE(AVAIL + 2*2) CALL SETINT(TABLE(AVAIL), TABPTR(C)) TABPTR(C) = AVAIL AVAIL = AVAIL + NLEN + DLEN + 2*2 4030 CONTINUE RETURN END C ARCHIVE INSUPL.RAT 11 30-NOV-81 14:32:13 C insupl - install upper and lower case versions of name SUBROUTINE INSUPL(NAME, DEFN, FLAG) BYTE NAME(201), DEFN(500), FNAME(201) INTEGER FLAG CALL INSTAL(NAME, DEFN, FLAG) CALL SCOPY(NAME, 1, FNAME, 1) CALL UPPER(FNAME) CALL INSTAL(FNAME, DEFN, FLAG) RETURN END C ARCHIVE ISSET.RAT 11 30-NOV-81 14:32:13 C isset - return YES if bit n is set in flags INTEGER FUNCTION ISSET(FLAGS, N) INTEGER FLAGS, N INTEGER BITMSK(12) DATA BITMSK/1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024, 2048/ ISSET = 0 IF (.NOT.(MOD(FLAGS/BITMSK(N+1), 2) .EQ. 1)) GOTO 4090 ISSET = 1 4090 CONTINUE RETURN END C ARCHIVE LOCDEF.RAT 23 30-NOV-81 14:32:13 C locdef - locate name, extract definition from table INTEGER FUNCTION LOCDEF(NAME, I, J, C) BYTE NAME(201) INTEGER I, J, K, C INTEGER GETINT C-------------------------------------------------------------------- C# preprocessor common block to hold definitions C put on a file named 'clook' C Used by ratfiv preprocessor, macro, and form tools COMMON/CLOOK/AVAIL, TABPTR(127), TABLE(5501) Cfirst location in table; init = 1 INTEGER AVAIL Cname poiners; init = 0 INTEGER TABPTR Cactual text of names and definitions BYTE TABLE IF (.NOT.(NAME(1) .NE. 0)) GOTO 4110 C = NAME(1) I = TABPTR(C) 4130 IF (.NOT.(I .GT. 0)) GOTO 4150 J = I + 2*2 K = 1 4160 IF (.NOT.(NAME(K) .EQ. TABLE(J) .AND. NAME(K) .NE. 0)) GOTO 41 *80 J = J + 1 4170 K = K + 1 GOTO 4160 4180 CONTINUE IF (.NOT.(NAME(K) .EQ. TABLE(J))) GOTO 4190 C got one J = J + 1 LOCDEF = 1 RETURN 4190 CONTINUE 4140 I = GETINT(TABLE(I)) GOTO 4130 4150 CONTINUE 4110 CONTINUE LOCDEF = 0 RETURN END C ARCHIVE LOOKUP.RAT 13 30-NOV-81 14:32:13 C lookup - locate name, extract definition from table INTEGER FUNCTION LOOKUP(NAME, DEFN, FLAG) BYTE DEFN(500), NAME(201), C INTEGER FLAG, I, J, LOCDEF, GETINT C-------------------------------------------------------------------- C# preprocessor common block to hold definitions C put on a file named 'clook' C Used by ratfiv preprocessor, macro, and form tools COMMON/CLOOK/AVAIL, TABPTR(127), TABLE(5501) Cfirst location in table; init = 1 INTEGER AVAIL Cname poiners; init = 0 INTEGER TABPTR Cactual text of names and definitions BYTE TABLE LOOKUP = LOCDEF(NAME, I, J, C) IF (.NOT.(LOOKUP .EQ. 1)) GOTO 4210 CALL SCOPY(TABLE, J, DEFN, 1) FLAG = GETINT(TABLE(I + 2)) 4210 CONTINUE RETURN END C ARCHIVE MACMAIN.RAT 50 1-DEC-81 11:26:17 C ARCHIVE NGETCH.RAT 32 1-DEC-81 09:42:51 C ngetch - get a (possibly pushed back) character BYTE FUNCTION NGETCH(C) BYTE C INTEGER I, GETLIN C---------------------------------------------------------------------- C preprocessor common block to hold input characters C Put on a file called 'cdefio' C Used by ratfiv preprocessor and macro COMMON/CDEFIO/BP, BPLOW, BPSAVE(4), BUF(900) C next available character; init = 0 INTEGER BP C bottom of push-back buffer at current file level INTEGER BPLOW C holds bplow for active file levels INTEGER BPSAVE C pushed-back characters BYTE BUF C----------------------------------------------------------------------- C preprocessor common block to hold info about lines and included files C put on a file named 'cline' C used by ratfiv preproccessor and macro COMMON/CLINE/LEVEL, INFILE(4), LINECT(4), FNAMP(4), FNAMES(136), I *OIN(134) C level of file inclusion; init = 1 INTEGER LEVEL C file number(level); init infile(1) = STDIN INTEGER INFILE C line count on input file(level); init = 1 INTEGER LINECT C next free slot in fnames INTEGER FNAMP C stack of open file names BYTE FNAMES C input buffer BYTE IOIN 4230 CONTINUE IF (.NOT.(BP .LE. BPLOW)) GOTO 4260 I = GETLIN(IOIN, INFILE(LEVEL)) IF (.NOT.(I .EQ. -10)) GOTO 4280 C = - 10 NGETCH = (C) RETURN 4280 CONTINUE LINECT(LEVEL) = LINECT(LEVEL) + 1 4300 CONTINUE C push ioin on pushback buffer BP = BP + 1 BUF(BP) = IOIN(I) I = I - 1 4310 IF (.NOT.(I .EQ. 0)) GOTO 4300 4260 CONTINUE C = BUF(BP) BP = BP - 1 IF (.NOT.(C .EQ. 95)) GOTO 4330 IF (.NOT.(BP .GT. BPLOW)) GOTO 4350 IF (.NOT.(BUF(BP) .EQ. 10)) GOTO 4370 BP = BP - 1 GOTO 4240 4370 CONTINUE 4350 CONTINUE 4330 CONTINUE NGETCH = (C) RETURN 4240 GOTO 4230 END C ARCHIVE NOEVAL.RAT 9 30-NOV-81 14:32:14 C noeval - check if macro arguments should be evaluated now INTEGER FUNCTION NOEVAL(CP, AP, CALLST, ARGSTK) INTEGER CP, AP, CALLST(1), ARGSTK(1), ISSET NOEVAL = 0 IF (.NOT.(CP .NE. 0)) GOTO 4390 NOEVAL = ISSET(ARGSTK(CALLST(CP)), AP - CALLST(CP) - 3) 4390 CONTINUE RETURN END C ARCHIVE PBNUM.RAT 9 30-NOV-81 14:32:14 C pbnum - convert number to string, push back on input SUBROUTINE PBNUM(N) INTEGER N, I, ITOC BYTE STR(7) I = ITOC(N, STR, 7) CALL PBSTR(STR) RETURN END C ARCHIVE PBSTR.RAT 10 30-NOV-81 14:32:14 C pbstr - push string back onto input SUBROUTINE PBSTR(IN) BYTE IN(1) INTEGER LENGTH INTEGER I I = LENGTH(IN) 4410 IF (.NOT.(I .GT. 0)) GOTO 4430 CALL PUTBAK(IN(I)) 4420 I = I - 1 GOTO 4410 4430 CONTINUE RETURN END C ARCHIVE PUSH.RAT 10 30-NOV-81 14:32:15 C push - push ep onto argstk, return new pointer ap /*/sor/macror/push INTEGER FUNCTION PUSH(EP, ARGSTK, AP) INTEGER AP, ARGSTK(120), EP IF (.NOT.(AP .GT. 120)) GOTO 4440 CALL FATAL('argument stack overflow.') 4440 CONTINUE ARGSTK(AP) = EP PUSH = AP + 1 RETURN END C ARCHIVE PUTBAK.RAT 11 1-DEC-81 09:29:28 C putbak - push character back onto input SUBROUTINE PUTBAK(C) BYTE C C---------------------------------------------------------------------- C preprocessor common block to hold input characters C Put on a file called 'cdefio' C Used by ratfiv preprocessor and macro COMMON/CDEFIO/BP, BPLOW, BPSAVE(4), BUF(900) C next available character; init = 0 INTEGER BP C bottom of push-back buffer at current file level INTEGER BPLOW C holds bplow for active file levels INTEGER BPSAVE C pushed-back characters BYTE BUF BP = BP + 1 IF (.NOT.(BP .GT. 900)) GOTO 4460 CALL FATAL('too many characters pushed back.') 4460 CONTINUE BUF(BP) = C RETURN END C ARCHIVE PUTCHR.RAT 11 30-NOV-81 14:32:15 C putchr - put single char into eval stack SUBROUTINE PUTCHR(C) BYTE C C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV IF (.NOT.(EP .GT. 500)) GOTO 4480 CALL FATAL('evaluation stack overflow.') 4480 CONTINUE EVALST(EP) = C EP = EP + 1 RETURN END C ARCHIVE PUTTOK.RAT 9 3-DEC-81 09:35:40 C puttok - put token into eval stack SUBROUTINE PUTTOK(STR) BYTE STR(201) INTEGER I I = 1 4500 IF (.NOT.(STR(I) .NE. 0)) GOTO 4520 CALL PUTCHR(STR(I)) 4510 I = I + 1 GOTO 4500 4520 CONTINUE RETURN END C ARCHIVE SET.RAT 11 30-NOV-81 14:32:15 C set - return flags with bit n set INTEGER FUNCTION SET(FLAGS, N) INTEGER FLAGS, N INTEGER BITMSK(12), ISSET DATA BITMSK/1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024, 2048/ SET = FLAGS IF (.NOT.(ISSET(FLAGS, N) .NE. 1)) GOTO 4530 SET = FLAGS + BITMSK(N + 1) 4530 CONTINUE RETURN END C ARCHIVE SETINT.RAT 8 30-NOV-81 14:32:16 C setint - put an integer into table SUBROUTINE SETINT(TABLE, VAL) BYTE TABLE(2), VAL(2) DO 4550 I = 1, 2 TABLE(I) = VAL(I) 4550 CONTINUE RETURN END C ARCHIVE SYN2.RAT 24 30-NOV-81 14:32:16 C syn2 - report Ratfiv syntax error SUBROUTINE SYN2(MSG, F) BYTE LC(7), MSG(1) INTEGER ITOC INTEGER I, JUNK, F C----------------------------------------------------------------------- C preprocessor common block to hold info about lines and included files C put on a file named 'cline' C used by ratfiv preproccessor and macro COMMON/CLINE/LEVEL, INFILE(4), LINECT(4), FNAMP(4), FNAMES(136), I *OIN(134) C level of file inclusion; init = 1 INTEGER LEVEL C file number(level); init infile(1) = STDIN INTEGER INFILE C line count on input file(level); init = 1 INTEGER LINECT C next free slot in fnames INTEGER FNAMP C stack of open file names BYTE FNAMES C input buffer BYTE IOIN BYTE SERROR(17) BYTE IN(5) DATA SERROR(1)/63/,SERROR(2)/32/,SERROR(3)/101/,SERROR(4)/114/,SER *ROR(5)/114/,SERROR(6)/111/,SERROR(7)/114/,SERROR(8)/32/,SERROR(9)/ *97/,SERROR(10)/116/,SERROR(11)/32/,SERROR(12)/108/,SERROR(13)/105/ *,SERROR(14)/110/,SERROR(15)/101/,SERROR(16)/32/,SERROR(17)/0/ DATA IN(1)/32/,IN(2)/105/,IN(3)/110/,IN(4)/32/,IN(5)/0/ CALL PUTLIN(SERROR, F) IF (.NOT.(LEVEL .GE. 1)) GOTO 4570 I = LEVEL GOTO 4580 4570 CONTINUE C for EOF errors I = 1 4580 CONTINUE JUNK = ITOC(LINECT(I), LC, 7) CALL PUTLIN(LC, F) CALL PUTLIN(IN, F) CALL PUTLIN(FNAMES(FNAMP(I)), F) CALL PUTCH(58, F) CALL PUTCH(32, F) CALL PUTLIN(MSG, F) CALL PUTCH(10, F) RETURN END C ARCHIVE SYNERR.RAT 13 30-NOV-81 14:32:16 C synerr - report ratfiv syntax error SUBROUTINE SYNERR(MSG) BYTE MSG(1) C cerrbf - holds an error message for later output by synerr COMMON/CERRBF/ERRBUF(201) BYTE ERRBUF CALL XITSTA(3) CALL PUTLIN(ERRBUF, 3) CALL SYN2(MSG, 3) CALL PUTLIN(ERRBUF, 2) CALL SYN2(MSG, 2) ERRBUF(1) = 0 RETURN END C ARCHIVE UNDEF.RAT 33 30-NOV-81 14:32:16 C undef - undefine a macro and garbage collect SUBROUTINE UNDEF(NAME) BYTE NAME(201), C INTEGER I, J, K, KNEXT, L, DEFLEN, LOCDEF, LENGTH, GETINT C-------------------------------------------------------------------- C# preprocessor common block to hold definitions C put on a file named 'clook' C Used by ratfiv preprocessor, macro, and form tools COMMON/CLOOK/AVAIL, TABPTR(127), TABLE(5501) Cfirst location in table; init = 1 INTEGER AVAIL Cname poiners; init = 0 INTEGER TABPTR Cactual text of names and definitions BYTE TABLE IF (.NOT.(LOCDEF(NAME, I, J, C) .EQ. 1)) GOTO 4590 IF (.NOT.(TABPTR(C) .EQ. I)) GOTO 4610 TABPTR(C) = GETINT(TABLE(I)) GOTO 4620 4610 CONTINUE K = TABPTR(C) 4630 IF (.NOT.(GETINT(TABLE(K)) .NE. I)) GOTO 4650 4640 K = GETINT(TABLE(K)) GOTO 4630 4650 CONTINUE CALL SETINT(TABLE(K), GETINT(TABLE(I))) 4620 CONTINUE J = J + LENGTH(TABLE(J)) + 1 DEFLEN = J - I DO 4660 L = 1, 127 IF (.NOT.(TABPTR(L) .GT. I)) GOTO 4680 K = TABPTR(L) TABPTR(L) = TABPTR(L) - DEFLEN 4700 IF (.NOT.(GETINT(TABLE(K)) .GT. I)) GOTO 4720 KNEXT = GETINT(TABLE(K)) CALL SETINT(TABLE(K), KNEXT - DEFLEN) 4710 K = KNEXT GOTO 4700 4720 CONTINUE 4680 CONTINUE 4660 CONTINUE 4730 IF (.NOT.(J .LT. AVAIL)) GOTO 4750 TABLE(I) = TABLE(J) I = I + 1 4740 J = J + 1 GOTO 4730 4750 CONTINUE AVAIL = I 4590 CONTINUE RETURN END