C max card size C maximum field for integer strings C must be 2 more than MAXCARD C must be highest lu for standard files 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 Wood (Institute For Cancer Research). C C Address: William Wood C Computer Center C Institute For Cancer Research C 7701 Burholme Ave. C Philadelphia, Pa. 19111 C (215) 728 2760 C C Version: 1.0 C C Date: May 14, 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 * THIS SOFTWARE WAS DESIGNED FOR USE ON A * C * PDP-11/70 OPERATING UNDER IAS V3.0 USING * C * THE FORTRAN-IV PLUS COMPILER. * C * * C ******************************************************* C C ARCHIVE RATMAIN.RAT 10 04-MAY-81 18:21:45 C# ratfiv -- main program C include symbol definitions C# /macsym/ - definitions for macro processor C put on a file named 'macsym' C pushback buffer for ngetch and putbak Cmax chars in a definition Cmax files which can be open at a time Cmax depth of file inclusion C(should be max nbr open files allowed - 4) Cmax chars in all definitions Cmax chars in a token C number of characters per integer C----------------------------------------------------------------------- C# definitions for the preprocessor (hashed version from Dave Hanson) C put on a file named 'rat4sym' C Used by ratfiv preprocessor, macro, and form tools C characters for outnum C (should be compatible with "putdec") C max space for for reinit clauses C function name size in gettok 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 CALL INITR4 CALL RATFIV CALL ENDR4 END C ARCHIVE RAT4S.RAT 73 06-MAY-81 14:35:47 C#ratfiv - driver subroutine for ratfiv compiler /*/sor/rat4r/rat4s SUBROUTINE RATFIV INTEGER GETARG, OPEN, PMATCH, INDEX BYTE BUF(134) Cfile containing general definitions BYTE SYM(34) Cstandard part of file spec for symbols BYTE SYMBLS(8) C /SYMBOLS flag BYTE SYMFLG(9) C STDIN string BYTE STDINN(6) INTEGER I, ARG1 Cneeded to set input file 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(4*34) 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 initialize standard part of file specification DATA SYMBLS/83, 89, 77, 66, 79, 76, 83, 0/ DATA SYMFLG/47, 83, 89, 77, 66, 79, 76, 83, 0/ DATA STDINN/83, 84, 68, 73, 78, 0/ C initialize macro processor CALL INIMAC Cinitialize variables CALL INIRAT ARG1 = 1 IF (.NOT.(GETARG(1, BUF, 134) .NE. -10)) GOTO 2000 IF (.NOT.(PMATCH(BUF, SYMFLG) .EQ. 1)) GOTO 2020 ARG1 = 2 C read file containing standard definitions INFILE(1) = OPEN(SYMBLS, 'R') CALL SCOPY(SYMBLS, 1, FNAMES, 1) IF (.NOT.(INFILE(1) .EQ. -1)) GOTO 2040 C get portion of file name for usr/bin CALL USRBIN(SYM) I = 1 2060 IF (.NOT.(SYM(I) .NE. 0)) GOTO 2080 C move pointer to end 2070 I = I + 1 GOTO 2060 2080 CONTINUE C copy remainder of name into sym CALL SCOPY(SYMBLS, 1, SYM, I) CALL SCOPY(SYM, 1, FNAMES, 1) INFILE(1) = OPEN(SYM, 'R') 2040 CONTINUE IF (.NOT.(INFILE(1) .EQ. -1)) GOTO 2090 CALL ERROR('can''t open symbols file.') GOTO 2100 2090 CONTINUE CALL PARSE CALL CLOSE(INFILE(1)) 2100 CONTINUE C loop through all input files 2020 CONTINUE 2000 CONTINUE I = ARG1 2110 CONTINUE IF (.NOT.(GETARG(I, BUF, 134) .EQ. -10)) GOTO 2140 IF (.NOT.(I .NE. ARG1)) GOTO 2160 GOTO 2130 2160 CONTINUE INFILE(1) = 5 CALL SCOPY(STDINN, 1, FNAMES, 1) GOTO 2150 2140 CONTINUE IF (.NOT.(BUF(1) .EQ. 63 .AND. BUF(2) .EQ. 0)) GOTO 2180 CALL REMARK('usage: rat [file ...] >outfile.') GOTO 2190 2180 CONTINUE IF (.NOT.(BUF(1) .EQ. 45 .AND. BUF(2) .EQ. 0)) GOTO 2200 INFILE(1) = 5 CALL SCOPY(STDINN, 1, FNAMES, 1) GOTO 2210 2200 CONTINUE INFILE(1) = OPEN(BUF, 'R') CALL SCOPY(BUF, 1, FNAMES, 1) IF (.NOT.(INFILE(1) .EQ. -1)) GOTO 2220 CALL CANT(BUF) 2220 CONTINUE 2210 CONTINUE 2190 CONTINUE 2150 CONTINUE CALL PARSE IF (.NOT.(INFILE(1) .NE. 5)) GOTO 2240 CALL CLOSE(INFILE(1)) 2240 CONTINUE 2120 I = I + 1 GOTO 2110 2130 CONTINUE RETURN END C ARCHIVE BALPAR.RAT 34 05-MAY-81 20:38:13 C# balpar - copy balanced paren string SUBROUTINE BALPAR BYTE GETTOK BYTE T, TOKEN(200) INTEGER NLPAR IF (.NOT.(GETTOK(TOKEN, 200) .NE. 40)) GOTO 2260 CALL SYNERR('missing left paren.') RETURN 2260 CONTINUE CALL OUTSTR(TOKEN) NLPAR = 1 2280 CONTINUE T = GETTOK(TOKEN, 200) 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. -100))) GOTO 2310 CALL PBSTR(TOKEN) GOTO 2300 2310 CONTINUE IF (.NOT.(T .EQ. 13)) GOTO 2330 C delete newlines TOKEN(1) = 0 GOTO 2340 2330 CONTINUE IF (.NOT.(T .EQ. 40)) GOTO 2350 NLPAR = NLPAR + 1 GOTO 2360 2350 CONTINUE IF (.NOT.(T .EQ. 41)) GOTO 2370 NLPAR = NLPAR - 1 C else nothing special 2370 CONTINUE 2360 CONTINUE 2340 CONTINUE CALL OUTSTR(TOKEN) IF (.NOT.(T .EQ. 44)) GOTO 2390 CALL OUTCH(32) 2390 CONTINUE 2290 IF (.NOT.(NLPAR .LE. 0)) GOTO 2280 2300 CONTINUE IF (.NOT.(NLPAR .NE. 0)) GOTO 2410 CALL SYNERR('missing parenthesis in condition.') 2410 CONTINUE RETURN END C ARCHIVE BRKNXT.RAT 38 13-MAY-81 01:39:42 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(200), GETTOK C-------------------------------------------------------------------- C# preprocessor common block to hold 'goto' flags C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/XFER CYES if just made transfer; else NO INTEGER XFER N = 0 T = GETTOK(PTOKEN, 200) IF (.NOT.(ALLDIG(PTOKEN) .EQ. 1)) GOTO 2430 C have break n or next n I = 1 N = CTOI(PTOKEN, I) - 1 GOTO 2440 2430 CONTINUE IF (.NOT.(T .NE. 59)) GOTO 2450 C default case CALL PBSTR(PTOKEN) 2450 CONTINUE 2440 CONTINUE I = SP 2470 IF (.NOT.(I .GT. 0)) GOTO 2490 IF (.NOT.(LEXTYP(I) .EQ. -64 .OR. LEXTYP(I) .EQ. -54 .OR. LEXTYP *(I) .EQ. -71 .OR. LEXTYP(I) .EQ. -56 .OR. LEXTYP(I) .EQ. -61)) GOT *O 2500 IF (.NOT.(N .GT. 0)) GOTO 2520 N = N - 1 C seek proper level GOTO 2480 2520 CONTINUE IF (.NOT.(TOKEN .EQ. -52)) GOTO 2540 CALL OUTGO(LABVAL(I) + 10) GOTO 2550 2540 CONTINUE IF (.NOT.(LEXTYP(I) .EQ. -71)) GOTO 2560 CALL SYNERR('illegal next.') GOTO 2570 2560 CONTINUE CALL OUTGO(LABVAL(I)) 2570 CONTINUE 2550 CONTINUE XFER = 1 RETURN 2500 CONTINUE 2480 I = I - 1 GOTO 2470 2490 CONTINUE IF (.NOT.(TOKEN .EQ. -52)) GOTO 2580 CALL SYNERR('illegal break.') GOTO 2590 2580 CONTINUE CALL SYNERR('illegal next.') 2590 CONTINUE RETURN END C ARCHIVE DOCODE.RAT 21 05-MAY-81 21:26:43 C# docode - generate code for beginning of do SUBROUTINE DOCODE(LAB) INTEGER LABGEN INTEGER LAB C-------------------------------------------------------------------- C# preprocessor common block to hold 'goto' flags C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/XFER CYES if just made transfer; else NO INTEGER XFER C string dostr 'do' BYTE DOSTR(4) DATA DOSTR(1), DOSTR(2), DOSTR(3), DOSTR(4)/68, 79, 32, 0/ XFER = 0 CALL OUTTAB CALL OUTSTR(DOSTR) LAB = LABGEN(2) CALL OUTNUM(LAB) CALL OUTCH(32) CALL EATUP CALL INDEN(2) RETURN END C ARCHIVE DOSTAT.RAT 9 11-APR-80 02:36:44 C# dostat - generate code for end of do statement SUBROUTINE DOSTAT(LAB) INTEGER LAB CALL OUTDEN(2) CALL OUTCON(LAB) CALL OUTCON(LAB + 10) RETURN END C ARCHIVE EATUP.RAT 52 07-MAY-81 13:31:32 C# eatup - process rest of statement; interpret continuations SUBROUTINE EATUP BYTE GETTOK, TYPE BYTE PTOKEN(200), T, TOKEN(200) 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 2600 CONTINUE T = GETTOK(TOKEN, 200) IF (.NOT.(T .EQ. 59)) GOTO 2630 GOTO 2620 2630 CONTINUE IF (.NOT.(T .EQ. 13 .OR. T .EQ. 93 .OR. T .EQ. 91 .OR. (T .LT. * 0 .AND. T .NE. -100))) GOTO 2650 CALL PBSTR(TOKEN) GOTO 2620 2650 CONTINUE 2640 CONTINUE IF (.NOT.(T .EQ. -10)) GOTO 2670 CALL SYNERR('unexpected EOF.') CALL PBSTR(TOKEN) GOTO 2620 2670 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 2690 2710 IF (.NOT.(GETTOK(PTOKEN, 200) .EQ. 13)) GOTO 2720 GOTO 2710 2720 CONTINUE CALL PBSTR(PTOKEN) 2690 CONTINUE IF (.NOT.(T .EQ. 40)) GOTO 2730 NLPAR = NLPAR + 1 GOTO 2740 2730 CONTINUE IF (.NOT.(T .EQ. 41)) GOTO 2750 NLPAR = NLPAR - 1 2750 CONTINUE 2740 CONTINUE IF (.NOT.(T .EQ. 43 .OR. T .EQ. 45 .OR. TOKEN(1) .EQ. 61)) GOTO *2770 CALL OUTCH(32) CALL OUTSTR(TOKEN) CALL OUTCH(32) GOTO 2780 2770 CONTINUE IF (.NOT.((T .EQ. -100) .AND. (TYPE(OUTBUF(OUTP)) .EQ. 1))) GO *TO 2790 CALL OUTCH(32) CALL OUTSTR(TOKEN) GOTO 2800 2790 CONTINUE IF (.NOT.(T .EQ. 44)) GOTO 2810 CALL OUTSTR(TOKEN) CALL OUTSTR(32) GOTO 2820 2810 CONTINUE CALL OUTSTR(TOKEN) 2820 CONTINUE 2800 CONTINUE 2780 CONTINUE 2610 IF (.NOT.(NLPAR .LT. 0)) GOTO 2600 2620 CONTINUE IF (.NOT.(NLPAR .NE. 0)) GOTO 2830 CALL SYNERR('unbalanced parentheses.') 2830 CONTINUE IF (.NOT.(T .NE. -51)) GOTO 2850 CALL OUTDON GOTO 2860 2850 CONTINUE CALL OUTCH(32) 2860 CONTINUE RETURN END C ARCHIVE ELSEF.RAT 10 11-APR-80 11:44:18 C# elsef - generate code for end of if before else SUBROUTINE ELSEF(LAB) INTEGER LAB CALL OUTGO(LAB + 10) CALL OUTDEN(1) CALL OUTCON(LAB) CALL INDEN(1) RETURN END C ARCHIVE FORCOD.RAT 96 05-MAY-81 21:26:46 C# forcod - beginning of for statement SUBROUTINE FORCOD(LAB) BYTE GETTOK BYTE T, TOKEN(200) INTEGER LENGTH, LABGEN INTEGER I, J, LAB, NLPAR 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(100) C current depth of for statements INTEGER FORDEP C stack of reinit strings BYTE FORSTK C string ifnot 'if (.not.' BYTE IFNOT(10) DATA IFNOT(1)/73/ DATA IFNOT(2)/70/ DATA IFNOT(3)/32/ DATA IFNOT(4)/40/ DATA IFNOT(5)/46/ DATA IFNOT(6)/78/ DATA IFNOT(7)/79/ DATA IFNOT(8)/84/ DATA IFNOT(9)/46/ DATA IFNOT(10)/0/ LAB = LABGEN(3) CALL OUTCON(0) IF (.NOT.(GETTOK(TOKEN, 200) .NE. 40)) GOTO 2870 CALL SYNERR('missing left paren.') RETURN 2870 CONTINUE IF (.NOT.(GETTOK(TOKEN, 200) .NE. 59)) GOTO 2890 C real init clause CALL PBSTR(TOKEN) CALL OUTTAB CALL EATUP 2890 CONTINUE IF (.NOT.(GETTOK(TOKEN, 200) .EQ. 59)) GOTO 2910 C empty condition CALL OUTCON(LAB) GOTO 2920 2910 CONTINUE C non-empty condition CALL PBSTR(TOKEN) CALL OUTNUM(LAB) CALL OUTTAB CALL OUTSTR(IFNOT) CALL OUTCH(40) NLPAR = 0 2930 IF (.NOT.(NLPAR .GE. 0)) GOTO 2940 T = GETTOK(TOKEN, 200) IF (.NOT.(T .EQ. 59)) GOTO 2950 GOTO 2940 2950 CONTINUE IF (.NOT.(T .EQ. 40)) GOTO 2970 NLPAR = NLPAR + 1 GOTO 2980 2970 CONTINUE IF (.NOT.(T .EQ. 41)) GOTO 2990 NLPAR = NLPAR - 1 2990 CONTINUE 2980 CONTINUE IF (.NOT.(T .EQ. -10)) GOTO 3010 CALL PBSTR(TOKEN) RETURN 3010 CONTINUE IF (.NOT.(T .NE. 13)) GOTO 3030 CALL OUTSTR(TOKEN) 3030 CONTINUE GOTO 2930 2940 CONTINUE CALL OUTCH(41) CALL OUTCH(41) CALL OUTCH(32) CALL OUTGO(LAB + 20) IF (.NOT.(NLPAR .LT. 0)) GOTO 3050 CALL SYNERR('invalid for clause.') 3050 CONTINUE 2920 CONTINUE C stack reinit clause FORDEP = FORDEP + 1 J = 1 I = 1 3070 IF (.NOT.(I .LT. FORDEP)) GOTO 3090 C find end J = J + LENGTH(FORSTK(J)) + 1 3080 I = I + 1 GOTO 3070 3090 CONTINUE C null, in case no reinit FORSTK(J) = 0 NLPAR = 0 3100 IF (.NOT.(NLPAR .GE. 0)) GOTO 3110 T = GETTOK(TOKEN, 200) IF (.NOT.(T .EQ. 40)) GOTO 3120 NLPAR = NLPAR + 1 GOTO 3130 3120 CONTINUE IF (.NOT.(T .EQ. 41)) GOTO 3140 NLPAR = NLPAR - 1 3140 CONTINUE 3130 CONTINUE IF (.NOT.(T .EQ. -10)) GOTO 3160 CALL PBSTR(TOKEN) GOTO 3110 3160 CONTINUE IF (.NOT.(NLPAR .GE. 0 .AND. T .NE. 13)) GOTO 3180 IF (.NOT.(T .EQ. 43 .OR. T .EQ. 45 .OR. TOKEN(1) .EQ. 61)) GOT *O 3200 TOKEN(1) = 32 TOKEN(2) = T TOKEN(3) = 32 TOKEN(4) = 0 GOTO 3210 3200 CONTINUE IF (.NOT.(T .EQ. 44)) GOTO 3220 TOKEN(2) = 32 TOKEN(3) = 0 3220 CONTINUE 3210 CONTINUE IF (.NOT.(J+LENGTH(TOKEN) .GE. 100)) GOTO 3240 CALL FATAL('for clause too long.') 3240 CONTINUE CALL SCOPY(TOKEN, 1, FORSTK, J) J = J + LENGTH(TOKEN) 3180 CONTINUE GOTO 3100 3110 CONTINUE CALL INDEN(2) C label for next's LAB = LAB + 10 RETURN END C ARCHIVE FORS.RAT 24 11-APR-80 02:36:47 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(100) C current depth of for statements INTEGER FORDEP C stack of reinit strings BYTE FORSTK C-------------------------------------------------------------------- C# preprocessor common block to hold 'goto' flags C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/XFER CYES if just made transfer; else NO INTEGER XFER XFER = 0 CALL OUTNUM(LAB) J = 1 I = 1 3260 IF (.NOT.(I .LT. FORDEP)) GOTO 3280 J = J + LENGTH(FORSTK(J)) + 1 3270 I = I + 1 GOTO 3260 3280 CONTINUE IF (.NOT.(LENGTH(FORSTK(J)) .GT. 0)) GOTO 3290 CALL OUTTAB CALL OUTSTR(FORSTK(J)) CALL OUTDON 3290 CONTINUE CALL OUTGO(LAB - 10) CALL OUTDEN(2) CALL OUTCON(LAB + 10) FORDEP = FORDEP - 1 RETURN END C ARCHIVE IFCODE.RAT 13 11-APR-80 02:36:51 C# ifcode - generate initial code for if SUBROUTINE IFCODE(LAB) INTEGER LABGEN INTEGER LAB C-------------------------------------------------------------------- C# preprocessor common block to hold 'goto' flags C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/XFER CYES if just made transfer; else NO INTEGER XFER XFER = 0 LAB = LABGEN(2) CALL IFGO(LAB) CALL INDEN(2) RETURN END C ARCHIVE IFGO.RAT 24 25-MAR-80 01:23:02 C# ifgo - generate 'if (.not.(...)) goto lab' SUBROUTINE IFGO(LAB) INTEGER LAB C string ifnot 'if (.not.' BYTE IFNOT(10) DATA IFNOT(1)/73/ DATA IFNOT(2)/70/ DATA IFNOT(3)/32/ DATA IFNOT(4)/40/ DATA IFNOT(5)/46/ DATA IFNOT(6)/78/ DATA IFNOT(7)/79/ DATA IFNOT(8)/84/ DATA IFNOT(9)/46/ DATA 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) RETURN END C ARCHIVE INIRAT.RAT 97 12-MAY-81 12:23:30 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), 1), 2)) 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 18 10-APR-80 10:05:44 C# labelc - output statement number SUBROUTINE LABELC(LEXSTR) BYTE LEXSTR(1) INTEGER LENGTH, I C-------------------------------------------------------------------- C# preprocessor common block to hold 'goto' flags C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/XFER CYES if just made transfer; else NO INTEGER XFER C can't suppress goto's now XFER = 0 C if (length(lexstr) == 5) # warn about 23xxx labels C if (lexstr(1) == DIG2 & lexstr(2) == DIG3) I = LENGTH(LEXSTR) IF (.NOT.(LEXSTR(I) .EQ. 48)) GOTO 3310 IF (.NOT.(I .GT. 4 .OR. (LEXSTR(1) .NE. 49 .AND. I .EQ. 4))) GOT *O 3330 CALL SYNERR('warning: possible label conflict.') 3330 CONTINUE 3310 CONTINUE CALL OUTSTR(LEXSTR) CALL OUTTAB RETURN END C ARCHIVE LITRAL.RAT 38 12-MAY-81 13:30:56 C# litral - process literal ratfiv lines SUBROUTINE LITRAL INTEGER GETLIN 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(4*34) 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 Finish off any left-over characters IF (.NOT.(OUTP .GT. 0)) GOTO 3350 CALL OUTDON 3350 CONTINUE C if not blank, output only this line CALL GETLIN(OUTBUF, INFILE(LEVEL)) C as a literal line LINECT(LEVEL) = LINECT(LEVEL) + 1 I = 1 3370 IF (.NOT.(OUTBUF(I) .EQ. 32)) GOTO 3390 3380 I = I + 1 GOTO 3370 3390 CONTINUE IF (.NOT.(OUTBUF(I) .EQ. -10)) GOTO 3400 GOTO 10 3400 CONTINUE IF (.NOT.(OUTBUF(I) .NE. 13)) GOTO 3420 CALL PUTLIN(OUTBUF, 2) GOTO 3430 3420 CONTINUE Cloop through input until matching toggle found 3440 IF (.NOT.(GETLIN(OUTBUF, INFILE(LEVEL)) .NE. -10)) GOTO 3450 LINECT(LEVEL) = LINECT(LEVEL) + 1 I = 1 3460 IF (.NOT.(OUTBUF(I) .EQ. 32)) GOTO 3480 3470 I = I + 1 GOTO 3460 3480 CONTINUE IF (.NOT.(OUTBUF(I) .EQ. 37)) GOTO 3490 GOTO 3450 3490 CONTINUE CALL PUTLIN(OUTBUF, 2) GOTO 3440 3450 CONTINUE IF (.NOT.(OUTBUF(1) .EQ. -10)) GOTO 3510 10 CALL PUTBAK( - 10) CALL SYNERR('EOF in literal fortran code.') 3510 CONTINUE 3430 CONTINUE OUTP = 0 RETURN END C ARCHIVE LABGEN.RAT 9 10-APR-80 10:05:45 C# labgen - generate n consecutive labels, return first one INTEGER FUNCTION LABGEN(N) INTEGER LABEL, N DATA LABEL/2000/ LABGEN = LABEL LABEL = LABEL + N*10 RETURN END C ARCHIVE LEX.RAT 20 05-MAY-81 21:10:44 C# lex - return lexical type of token INTEGER FUNCTION LEX(LEXSTR) BYTE GETTOK BYTE LEXSTR(200) INTEGER ALLDIG 3530 IF (.NOT.(GETTOK(LEXSTR, 200) .EQ. 13)) GOTO 3540 GOTO 3530 3540 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 3550 GOTO 3560 3550 CONTINUE IF (.NOT.(ALLDIG(LEXSTR) .EQ. 1)) GOTO 3570 LEX = - 53 GOTO 3580 3570 CONTINUE IF (.NOT.(LEX .EQ. 37)) GOTO 3590 LEX = - 58 GOTO 3600 3590 CONTINUE LEX = - 60 3600 CONTINUE 3580 CONTINUE 3560 CONTINUE RETURN END C ARCHIVE OTHERC.RAT 12 05-MAY-81 21:26:50 C# otherc - output ordinary Fortran statement SUBROUTINE OTHERC(LEXSTR) BYTE LEXSTR(1) C-------------------------------------------------------------------- C# preprocessor common block to hold 'goto' flags C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/XFER CYES if just made transfer; else NO INTEGER XFER XFER = 0 CALL OUTTAB CALL OUTSTR(LEXSTR) CALL EATUP RETURN END C ARCHIVE OUTCH.RAT 18 25-MAR-80 01:23:06 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 3610 C continuation card CALL OUTDON I = 1 3630 IF (.NOT.(I .LT. 6)) GOTO 3650 OUTBUF(I) = 32 3640 I = I + 1 GOTO 3630 3650 CONTINUE OUTBUF(6) = 42 OUTP = 6 3610 CONTINUE OUTP = OUTP + 1 OUTBUF(OUTP) = C RETURN END C ARCHIVE OUTCON.RAT 28 25-MAR-80 01:23:06 C# outcon - output 'n continue' SUBROUTINE OUTCON(N) INTEGER N C-------------------------------------------------------------------- C# preprocessor common block to hold 'goto' flags C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/XFER CYES 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------------------------------------------------------------------ C string contin 'continue' BYTE CONTIN(9) DATA CONTIN(1)/67/ DATA CONTIN(2)/79/ DATA CONTIN(3)/78/ DATA CONTIN(4)/84/ DATA CONTIN(5)/73/ DATA CONTIN(6)/78/ DATA CONTIN(7)/85/ DATA CONTIN(8)/69/ DATA CONTIN(9)/0/ XFER = 0 IF (.NOT.(N .LE. 0 .AND. OUTP .EQ. 0)) GOTO 3660 C don't need unlabeled continues RETURN 3660 CONTINUE IF (.NOT.(N .GT. 0)) GOTO 3680 CALL OUTNUM(N) 3680 CONTINUE CALL OUTTAB CALL OUTSTR(CONTIN) CALL OUTDON RETURN END C ARCHIVE OUTDON.RAT 11 25-MAR-80 01:23:06 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------------------------------------------------------------------ OUTBUF(OUTP + 1) = 13 OUTBUF(OUTP + 2) = 0 CALL PUTLIN(OUTBUF, 2) OUTP = 0 RETURN END C ARCHIVE OUTGO.RAT 22 25-MAR-80 01:23:06 C# outgo - output 'goto n' SUBROUTINE OUTGO(N) INTEGER N C-------------------------------------------------------------------- C# preprocessor common block to hold 'goto' flags C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/XFER CYES if just made transfer; else NO INTEGER XFER C string goto 'goto' BYTE GOTO(6) DATA GOTO(1)/71/ DATA GOTO(2)/79/ DATA GOTO(3)/84/ DATA GOTO(4)/79/ DATA GOTO(5)/32/ DATA GOTO(6)/0/ IF (.NOT.(XFER .EQ. 1)) GOTO 3700 RETURN 3700 CONTINUE CALL OUTTAB CALL OUTSTR(GOTO) CALL OUTNUM(N) CALL OUTDON RETURN END C ARCHIVE OUTNUM.RAT 32 13-MAY-81 00:15:22 C# outnum - output positive decimal number SUBROUTINE OUTNUM(N) BYTE CHARS(10) INTEGER D, I, M C string digits '0123456789' BYTE DIGITS(11) DATA DIGITS(1)/48/ DATA DIGITS(2)/49/ DATA DIGITS(3)/50/ DATA DIGITS(4)/51/ DATA DIGITS(5)/52/ DATA DIGITS(6)/53/ DATA DIGITS(7)/54/ DATA DIGITS(8)/55/ DATA DIGITS(9)/56/ DATA DIGITS(10)/57/ DATA DIGITS(11)/0/ M = IABS(N) I = 0 3720 CONTINUE I = I + 1 D = MOD(M, 10) CHARS(I) = DIGITS(D + 1) M = M/10 3730 IF (.NOT.(M .EQ. 0 .OR. I .GE. 10)) GOTO 3720 3740 CONTINUE IF (.NOT.(N .LT. 0)) GOTO 3750 CALL OUTCH(45) 3750 CONTINUE 3770 IF (.NOT.(I .GT. 0)) GOTO 3790 CALL OUTCH(CHARS(I)) 3780 I = I - 1 GOTO 3770 3790 CONTINUE RETURN END C ARCHIVE OUTSTR.RAT 45 06-MAY-81 10:42:55 C# outstr - output string SUBROUTINE OUTSTR(STR) C***NOTE*** - strings on BKY were converted to nL... format, a C hollerith string terminated with a zero byte. C***NOTE*** - modified to put out quoted literals C and to strip ACCENT chars BYTE C, STR(1), CUPPER INTEGER I, J I = 1 3800 IF (.NOT.(STR(I) .NE. 0)) GOTO 3820 C = STR(I) IF (.NOT.(C .EQ. 96)) GOTO 3830 I = I + 1 3850 CONTINUE IF (.NOT.(STR(I) .EQ. 96)) GOTO 3880 IF (.NOT.(STR(I+1) .EQ. 96)) GOTO 3900 I = I + 1 GOTO 3910 3900 CONTINUE GOTO 3870 3910 CONTINUE 3880 CONTINUE CALL OUTCH(STR(I)) 3860 I = I + 1 GOTO 3850 3870 CONTINUE GOTO 3840 3830 CONTINUE IF (.NOT.((C .NE. 39 .AND. C .NE. 34) .OR. STR(I+1) .EQ. 0)) G *OTO 3920 CALL OUTCH(CUPPER(C)) GOTO 3930 3920 CONTINUE CALL OUTCH(39) I = I + 1 3940 IF (.NOT.(STR(I) .NE. C)) GOTO 3960 IF (.NOT.(STR(I) .EQ. 39)) GOTO 3970 C "'" -> '''' CALL OUTCH(39) 3970 CONTINUE CALL OUTCH(STR(I)) 3950 I = I + 1 GOTO 3940 3960 CONTINUE CALL OUTCH(39) C i = i + 1 C for (j = i; str(j) != c; j = j + 1) # find end C ; C call outnum(j-i) C call outch (BIGH) #NOTBKY C #BKY call outch (BIGL) C for ( ; i < j; i = i + 1) C call outch(str(i)) 3930 CONTINUE 3840 CONTINUE 3810 I = I + 1 GOTO 3800 3820 CONTINUE RETURN END C ARCHIVE OUTTAB.RAT 11 11-APR-80 02:38:45 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 3990 IF (.NOT.(OUTP .LT. I)) GOTO 4000 CALL OUTCH(32) GOTO 3990 4000 CONTINUE RETURN END C ARCHIVE PARSE.RAT 123 13-MAY-81 13:45:19 C# parse - parse Ratfiv source program SUBROUTINE PARSE BYTE LEXSTR(200) BYTE SDECOD(7), SENCOD(7), SREAD(5), SWRITE(6), SFORMA(7) 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(4*34) 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---------------------------------------------------------------------- C# preprocessor common block to hold input characters C Put on a file called 'cdefio' C Used by ratfiv preprocessor, macro, form, and shell tools COMMON/CDEFIO/BP, BUF(600) C next available character; init = 0 INTEGER BP 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(100) 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(20) Ctext of current function name BYTE FCNAME C-------------------------------------------------------------------- C# preprocessor common block to hold 'goto' flags C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/XFER CYES 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 C when .true., < and > aren't LOGICAL INFORM C converted to .lt. and .gt. C------------------------------------------------------------------ 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 DATA SREAD/82, 69, 65, 68, 0/ DATA SWRITE/87, 82, 73, 84, 69, 0/ DATA SENCOD/69, 78, 67, 79, 68, 69, 0/ DATA SDECOD/68, 69, 67, 79, 68, 69, 0/ DATA SFORMA/70, 79, 82, 77, 65, 84, 0/ Cinitialize variables for current input file OUTP = 0 INDENT = 0 LEVEL = 1 FNAMP(1) = 1 LINECT(1) = 1 BP = 0 SBP = 1 FORDEP = 0 C controls conversion of > and < to .gt. and .lt. INFORM = .FALSE. FCNAME(1) = 0 XFER = 0 SWTOP = 0 SWLAST = 1 SP = 1 LEXTYP(1) = - 10 TOKEN = LEX(LEXSTR) 4010 IF (.NOT.(TOKEN .NE. -10)) GOTO 4030 I4040=(TOKEN) GOTO 4040 4060 CONTINUE CALL OTHERC(LEXSTR) GOTO 4050 4070 CONTINUE CALL IFCODE(LAB) GOTO 4050 4080 CONTINUE IF (.NOT.(LEXTYP(SP) .EQ. -57)) GOTO 4090 CALL ELSEF(LABVAL(SP)) GOTO 4100 4090 CONTINUE CALL SYNERR('illegal else.') 4100 CONTINUE GOTO 4050 4110 CONTINUE CALL DOCODE(LAB) GOTO 4050 4120 CONTINUE CALL WHILEC(LAB) GOTO 4050 4130 CONTINUE CALL FORCOD(LAB) GOTO 4050 4140 CONTINUE CALL REPCOD(LAB) GOTO 4050 4150 CONTINUE CALL BRKNXT(SP, LEXTYP, LABVAL, TOKEN) GOTO 4050 4160 CONTINUE CALL LABELC(LEXSTR) GOTO 4050 4170 CONTINUE CALL SWCODE(LAB) GOTO 4050 4180 CONTINUE I = SP 4190 IF (.NOT.(I .GT. 0)) GOTO 4210 C find most recent switch IF (.NOT.(LEXTYP(I) .EQ. -71)) GOTO 4220 GOTO 4210 4220 CONTINUE 4200 I = I - 1 GOTO 4190 4210 CONTINUE IF (.NOT.(I .EQ. 0)) GOTO 4240 CALL SYNERR('illegal case or default.') GOTO 4250 4240 CONTINUE CALL CASCOD(LABVAL(I), TOKEN) 4250 CONTINUE GOTO 4050 4260 CONTINUE CALL FORMA(SWRITE) GOTO 4050 4270 CONTINUE CALL FORMA(SREAD) GOTO 4050 4280 CONTINUE CALL FORMA(SENCOD) GOTO 4050 4290 CONTINUE CALL FORMA(SDECOD) GOTO 4050 4300 CONTINUE INFORM = .TRUE. CALL OTHERC(SFORMA) INFORM = .FALSE. GOTO 4050 4310 CONTINUE CALL RINCLU GOTO 4050 4320 CONTINUE CALL DFUNCT GOTO 4050 4330 CONTINUE CALL RETCOD GOTO 4050 4340 CONTINUE CALL STRDCL GOTO 4050 4350 CONTINUE CALL LITRAL GOTO 4050 4360 CONTINUE IF (.NOT.(TOKEN .EQ. 93)) GOTO 4370 IF (.NOT.(LEXTYP(SP) .EQ. 91)) GOTO 4390 SP = SP - 1 GOTO 4400 4390 CONTINUE CALL SYNERR('illegal right brace.') 4400 CONTINUE 4370 CONTINUE GOTO 4050 4040 CONTINUE I4040=I4040+74 IF (I4040.LT.1.OR.I4040.GT.24)GOTO 4360 GOTO (4180,4180,4170,4340,4300,4290,4280,4270,4260,4120,4360,433 *0,4140,4060,4150,4350,4070,4130,4080,4110,4160,4150,4320,4310), I4 *040 4050 CONTINUE IF (.NOT.(TOKEN .EQ. -57 .OR. TOKEN .EQ. -55 .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 4410 C beginning of statement SP = SP + 1 IF (.NOT.(SP .GT. 100)) GOTO 4430 CALL FATAL('stack overflow in parser.') 4430 CONTINUE C stack type and value LEXTYP(SP) = TOKEN LABVAL(SP) = LAB GOTO 4420 4410 CONTINUE C end of statement - prepare to unstack C peek at next token TOKEN = LEX(LEXSTR) CALL PBSTR(LEXSTR) CALL UNSTAK(SP, LEXTYP, LABVAL, TOKEN) 4420 CONTINUE 4020 TOKEN = LEX(LEXSTR) GOTO 4010 4030 CONTINUE IF (.NOT.(SP .NE. 1)) GOTO 4450 CALL SYNERR('unexpected EOF.') 4450 CONTINUE RETURN END C ARCHIVE RELATE.RAT 61 06-MAY-81 16:47:39 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 C when .true., < and > aren't LOGICAL INFORM C converted to .lt. and .gt. C------------------------------------------------------------------ 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 4470 CALL PUTBAK(TOKEN(2)) 4470 CONTINUE IF (.NOT.(TOKEN(1) .EQ. 62)) GOTO 4490 IF (.NOT.(TOKEN(2) .EQ. 61)) GOTO 4510 CALL SCOPY(DOTGE, 1, TOKEN, 1) GOTO 4520 4510 CONTINUE IF (.NOT.(INFORM)) GOTO 4530 TOKEN(2) = 0 GOTO 4540 4530 CONTINUE CALL SCOPY(DOTGT, 1, TOKEN, 1) 4540 CONTINUE 4520 CONTINUE GOTO 4500 4490 CONTINUE IF (.NOT.(TOKEN(1) .EQ. 60)) GOTO 4550 IF (.NOT.(TOKEN(2) .EQ. 61)) GOTO 4570 CALL SCOPY(DOTLE, 1, TOKEN, 1) GOTO 4580 4570 CONTINUE IF (.NOT.(INFORM)) GOTO 4590 TOKEN(2) = 0 GOTO 4600 4590 CONTINUE CALL SCOPY(DOTLT, 1, TOKEN, 1) 4600 CONTINUE 4580 CONTINUE GOTO 4560 4550 CONTINUE IF (.NOT.(TOKEN(1) .EQ. 126 .OR. TOKEN(1) .EQ. 33 .OR. TOKEN(1 *) .EQ. 94)) GOTO 4610 IF (.NOT.(TOKEN(2) .EQ. 61)) GOTO 4630 CALL SCOPY(DOTNE, 1, TOKEN, 1) GOTO 4640 4630 CONTINUE CALL SCOPY(DOTNOT, 1, TOKEN, 1) 4640 CONTINUE GOTO 4620 4610 CONTINUE IF (.NOT.(TOKEN(1) .EQ. 61)) GOTO 4650 IF (.NOT.(TOKEN(2) .EQ. 61)) GOTO 4670 CALL SCOPY(DOTEQ, 1, TOKEN, 1) GOTO 4680 4670 CONTINUE TOKEN(2) = 0 4680 CONTINUE GOTO 4660 4650 CONTINUE IF (.NOT.(TOKEN(1) .EQ. 38)) GOTO 4690 CALL SCOPY(DOTAND, 1, TOKEN, 1) GOTO 4700 4690 CONTINUE IF (.NOT.(TOKEN(1) .EQ. 124 .OR. TOKEN(1) .EQ. 92)) GOTO * 4710 CALL SCOPY(DOTOR, 1, TOKEN, 1) GOTO 4720 4710 CONTINUE C can't happen TOKEN(2) = 0 4720 CONTINUE 4700 CONTINUE 4660 CONTINUE 4620 CONTINUE 4560 CONTINUE 4500 CONTINUE LAST = LENGTH(TOKEN) RETURN END C ARCHIVE REPCOD.RAT 12 11-APR-80 02:38:49 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 40 05-MAY-81 21:26:53 C# retcod - generate code for return SUBROUTINE RETCOD BYTE TOKEN(200), 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(20) Ctext of current function name BYTE FCNAME C-------------------------------------------------------------------- C# preprocessor common block to hold 'goto' flags C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/XFER CYES if just made transfer; else NO INTEGER XFER C string retrn 'return' C string eqstr ' = ' BYTE RETRN(7) BYTE EQSTR(4) DATA RETRN(1)/82/ DATA RETRN(2)/69/ DATA RETRN(3)/84/ DATA RETRN(4)/85/ DATA RETRN(5)/82/ DATA RETRN(6)/78/ DATA RETRN(7)/0/ DATA EQSTR/32, 61, 32, 0/ T = GETTOK(TOKEN, 200) IF (.NOT.(T .EQ. 59 .OR. T .EQ. 13 .OR. T .EQ. -10 .OR. T .EQ. 93 *.OR. T .EQ. 91 .OR. (T .LT. 0 .AND. T .NE. -100))) GOTO 4730 CALL PBSTR(TOKEN) GOTO 4740 4730 CONTINUE CALL PBSTR(TOKEN) CALL OUTTAB IF (.NOT.(FCNAME(1) .EQ. 0)) GOTO 4750 CALL SYNERR('return: no function defined.') GOTO 4760 4750 CONTINUE CALL OUTSTR(FCNAME) CALL OUTSTR(EQSTR) 4760 CONTINUE CALL EATUP 4740 CONTINUE CALL OUTTAB CALL OUTSTR(RETRN) CALL OUTDON XFER = 1 RETURN END C ARCHIVE UNSTAK.RAT 32 12-MAY-81 22:39:40 C# unstak - unstack at end of statement SUBROUTINE UNSTAK(SP, LEXTYP, LABVAL, TOKEN) INTEGER LABVAL(100), LEXTYP(100), SP, TOKEN 4770 IF (.NOT.(SP .GT. 1)) GOTO 4790 IF (.NOT.(LEXTYP(SP) .EQ. 91)) GOTO 4800 GOTO 4790 4800 CONTINUE IF (.NOT.(LEXTYP(SP) .EQ. -57 .AND. TOKEN .EQ. -55)) GOTO 4820 GOTO 4790 4820 CONTINUE IF (.NOT.(LEXTYP(SP) .EQ. -57)) GOTO 4840 CALL OUTDEN(2) CALL OUTCON(LABVAL(SP)) GOTO 4850 4840 CONTINUE IF (.NOT.(LEXTYP(SP) .EQ. -55)) GOTO 4860 IF (.NOT.(SP .GT. 2)) GOTO 4880 SP = SP - 1 4880 CONTINUE CALL OUTDEN(2) CALL OUTCON(LABVAL(SP) + 10) GOTO 4870 4860 CONTINUE IF (.NOT.(LEXTYP(SP) .EQ. -54)) GOTO 4900 CALL DOSTAT(LABVAL(SP)) GOTO 4910 4900 CONTINUE IF (.NOT.(LEXTYP(SP) .EQ. -64)) GOTO 4920 CALL WHILES(LABVAL(SP)) GOTO 4930 4920 CONTINUE IF (.NOT.(LEXTYP(SP) .EQ. -56)) GOTO 4940 CALL FORS(LABVAL(SP)) GOTO 4950 4940 CONTINUE IF (.NOT.(LEXTYP(SP) .EQ. -61)) GOTO 4960 CALL UNTILS(LABVAL(SP), TOKEN) GOTO 4970 4960 CONTINUE IF (.NOT.(LEXTYP(SP) .EQ. -71)) GOTO 4980 CALL SWEND(LABVAL(SP)) 4980 CONTINUE 4970 CONTINUE 4950 CONTINUE 4930 CONTINUE 4910 CONTINUE 4870 CONTINUE 4850 CONTINUE 4780 SP = SP - 1 GOTO 4770 4790 CONTINUE RETURN END C ARCHIVE UNTILS.RAT 20 11-APR-80 02:38:51 C# untils - generate code for until or end of repeat SUBROUTINE UNTILS(LAB, TOKEN) BYTE PTOKEN(200) INTEGER LEX INTEGER JUNK, LAB, TOKEN C-------------------------------------------------------------------- C# preprocessor common block to hold 'goto' flags C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/XFER CYES if just made transfer; else NO INTEGER XFER XFER = 0 CALL OUTNUM(LAB) IF (.NOT.(TOKEN .EQ. -63)) GOTO 5000 JUNK = LEX(PTOKEN) CALL IFGO(LAB - 10) GOTO 5010 5000 CONTINUE CALL OUTGO(LAB - 10) 5010 CONTINUE CALL OUTDEN(2) CALL OUTCON(LAB + 10) RETURN END C ARCHIVE WHILEC.RAT 12 11-APR-80 02:38:51 C# whilec - generate code for beginning of while SUBROUTINE WHILEC(LAB) INTEGER LABGEN INTEGER LAB C unlabeled continue, in case there was a label CALL OUTCON(0) LAB = LABGEN(2) CALL OUTNUM(LAB) CALL IFGO(LAB + 10) CALL INDEN(2) RETURN END C ARCHIVE WHILES.RAT 9 11-APR-80 02:38:57 C# whiles - generate code for end of while SUBROUTINE WHILES(LAB) INTEGER LAB CALL OUTGO(LAB) CALL OUTDEN(2) CALL OUTCON(LAB + 10) RETURN END C ARCHIVE INDEN.RAT 7 11-APR-80 11:42:04 C# inden - indent 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 = INDENT + IND RETURN END C ARCHIVE OUTDEN.RAT 7 11-APR-80 11:42:05 C# outden - outdent the tab position SUBROUTINE OUTDEN(OUT) INTEGER OUT 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 = INDENT - OUT RETURN END C ARCHIVE FORMAT.RAT 82 05-MAY-81 21:26:56 C forma - output format statement for write, read, encode, and decode SUBROUTINE FORMA(TOKEN) BYTE TOKEN(1), T, TOK(200), FORST(500) BYTE GETTOK BYTE FORM(7) 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 C when .true., < and > aren't LOGICAL INFORM C converted to .lt. and .gt. C------------------------------------------------------------------ DATA FORM/70, 79, 82, 77, 65, 84, 0/ CALL OUTTAB CALL OUTSTR(TOKEN) T = GETTOK(TOK, 200) IF (.NOT.(T .NE. 40)) GOTO 5020 CALL PBSTR(TOK) CALL EATUP RETURN 5020 CONTINUE CALL OUTSTR(TOK) CALL SKPOUT(T) IF (.NOT.(T .EQ. -10)) GOTO 5040 RETURN 5040 CONTINUE IF (.NOT.(T .EQ. 41)) GOTO 5060 CALL EATUP RETURN 5060 CONTINUE T = GETTOK(TOK, 200) IF (.NOT.(T .NE. 40)) GOTO 5080 CALL PBSTR(TOK) 5100 CONTINUE CALL SKPOUT(T) IF (.NOT.(T .EQ. -10)) GOTO 5130 RETURN 5130 CONTINUE 5110 IF (.NOT.(T .EQ. 41)) GOTO 5100 5120 CONTINUE CALL EATUP GOTO 5090 5080 CONTINUE LAB = LABGEN(1) CALL OUTNUM(LAB) J = 1 FORST(1) = 0 NLPAR = 0 Cdon't convert < and > to .lt. and .gt. INFORM = .TRUE. 5150 CONTINUE T = GETTOK(TOK, 200) IF (.NOT.(T .EQ. -10)) GOTO 5180 CALL PBSTR(TOK) CALL SYNERR('unexpected EOF.') INFORM = .FALSE. RETURN 5180 CONTINUE IF (.NOT.(T .EQ. 40)) GOTO 5200 NLPAR = NLPAR + 1 GOTO 5210 5200 CONTINUE IF (.NOT.(T .EQ. 41)) GOTO 5220 NLPAR = NLPAR - 1 5220 CONTINUE 5210 CONTINUE IF (.NOT.(NLPAR .GE. 0 .AND. T .NE. 13)) GOTO 5240 IF (.NOT.(J+LENGTH(TOK) .GE. 500)) GOTO 5260 CALL SYNERR('format too long.') GOTO 5170 5260 CONTINUE CALL SCOPY(TOK, 1, FORST, J) J = J + LENGTH(TOK) 5240 CONTINUE 5160 IF (.NOT.(NLPAR .LT. 0)) GOTO 5150 5170 CONTINUE INFORM = .FALSE. 5280 CONTINUE CALL SKPOUT(T) IF (.NOT.(T .EQ. -10)) GOTO 5310 RETURN 5310 CONTINUE 5290 IF (.NOT.(T .EQ. 41)) GOTO 5280 5300 CONTINUE 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 OUTDEN(2) 5090 CONTINUE RETURN END C ARCHIVE SKPOUT.RAT 26 25-JUN-80 23:57:37 SUBROUTINE SKPOUT(T) BYTE T, TOK(200), GETTOK INTEGER NLPAR NLPAR = 0 5330 CONTINUE T = GETTOK(TOK, 200) IF (.NOT.(T .EQ. -10)) GOTO 5360 CALL PBSTR(TOK) CALL SYNERR('unexpected EOF.') RETURN 5360 CONTINUE IF (.NOT.(T .EQ. 40)) GOTO 5380 NLPAR = NLPAR + 1 GOTO 5390 5380 CONTINUE IF (.NOT.(T .EQ. 41)) GOTO 5400 NLPAR = NLPAR - 1 5400 CONTINUE 5390 CONTINUE IF (.NOT.(T .NE. 13)) GOTO 5420 CALL OUTSTR(TOK) IF (.NOT.(T .EQ. 44)) GOTO 5440 CALL OUTCH(32) 5440 CONTINUE 5420 CONTINUE 5340 IF (.NOT.(NLPAR .LT. 0 .OR. (T .EQ. 44 .AND. NLPAR .EQ. 0))) GOT *O 5330 5350 CONTINUE IF (.NOT.(T .EQ. 41)) GOTO 5460 CALL OUTCH(32) 5460 CONTINUE RETURN END C ARCHIVE RINCLU.RAT 32 13-MAY-81 16:24:11 C rinclu - do include for ratfiv SUBROUTINE RINCLU BYTE FILE(34), T, GETTOK, BUF(200) INTEGER I, J T = GETTOK(BUF, 200) IF (.NOT.(T .EQ. 39 .OR. T .EQ. 34)) GOTO 5480 C include "file" or 'file' I = 1 5500 IF (.NOT.(BUF(I+1) .NE. 0)) GOTO 5520 IF (.NOT.(I .GT. 34)) GOTO 5530 CALL SYNERR('include file name too long.') RETURN 5530 CONTINUE FILE(I) = BUF(I + 1) 5510 I = I + 1 GOTO 5500 5520 CONTINUE FILE(MAX0(I - 1, 1)) = 0 GOTO 5490 5480 CONTINUE C include file I = 0 5550 IF (.NOT.(T .NE. 13 .AND. T .NE. 59)) GOTO 5570 J = 1 5580 IF (.NOT.(BUF(J) .NE. 0)) GOTO 5600 I = I + 1 IF (.NOT.(I .GE. 34)) GOTO 5610 CALL SYNERR('include file name too long.') RETURN 5610 CONTINUE FILE(I) = BUF(J) 5590 J = J + 1 GOTO 5580 5600 CONTINUE 5560 T = GETTOK(BUF, 200) GOTO 5550 5570 CONTINUE FILE(I + 1) = 0 5490 CONTINUE CALL INCLUD(FILE, T) RETURN END C ARCHIVE DFUNCT.RAT 16 05-MAY-81 18:05:01 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(20) Ctext of current function name BYTE FCNAME BYTE T, GETTOK, FUNCT(9) DATA FUNCT/70, 85, 78, 67, 84, 73, 79, 78, 0/ T = GETTOK(FCNAME, 20) CALL PBSTR(FCNAME) CALL OTHERC(FUNCT) IF (.NOT.(T .NE. -100)) GOTO 5630 CALL ERRLIN(FCNAME) CALL SYNERR('bad function name') FCNAME(1) = 0 5630 CONTINUE RETURN END C ARCHIVE GTOKENR.RAT 92 13-MAY-81 20:20:13 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) 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 COMMON/CMACRO/AP, ARGSTK(120), CALLST(30), PLEV(30) 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 I = 1 5650 IF (.NOT.(I .LT. TOKSIZ-1)) GOTO 5670 GTOKEN = TYPE(NGETCH(TOKEN(I))) IF (.NOT.(GTOKEN .NE. 1 .AND. GTOKEN .NE. 2 .AND. GTOKEN .NE. 95 * .AND. GTOKEN .NE. 46)) GOTO 5680 GOTO 5670 5680 CONTINUE 5660 I = I + 1 GOTO 5650 5670 CONTINUE IF (.NOT.(TOKEN(1) .EQ. 96)) GOTO 5700 C leave stuff in here alone I = 2 5720 IF (.NOT.(I .LT. TOKSIZ-1)) GOTO 5740 IF (.NOT.(NGETCH(TOKEN(I)) .EQ. 96)) GOTO 5750 IF (.NOT.(NGETCH(TOKEN(I+1)) .NE. 96)) GOTO 5770 CALL PUTBAK(TOKEN(I + 1)) GOTO 5740 5770 CONTINUE I = I + 1 5780 CONTINUE GOTO 5760 5750 CONTINUE IF (.NOT.(TOKEN(I) .EQ. -10)) GOTO 5790 CALL SYNERR('EOF in literal string.') TOKEN(I) = 96 CALL PUTBAK( - 10) GOTO 5740 5790 CONTINUE 5760 CONTINUE 5730 I = I + 1 GOTO 5720 5740 CONTINUE IF (.NOT.(I .GE. TOKSIZ-1)) GOTO 5810 I = TOKSIZ - 1 TOKEN(I) = 96 5810 CONTINUE 5700 CONTINUE IF (.NOT.(I .GE. TOKSIZ-1)) GOTO 5830 CALL SYNERR('token too long.') 5830 CONTINUE IF (.NOT.(I .GT. 1 .AND. TOKEN(1) .NE. 96)) GOTO 5850 C some alpha seen C = TOKEN(I) TOKEN(I) = 0 IF (.NOT.(C .EQ. 37)) GOTO 5870 C check for base other than 10 IF (.NOT.(ALLDIG(TOKEN) .EQ. 1)) GOTO 5890 J = 1 CALL DOBASE(CTOI(TOKEN, J), TOKEN, TOKSIZ, I) GOTO 5900 5890 CONTINUE CALL PUTBAK(37) 5900 CONTINUE GOTO 5880 5870 CONTINUE CALL PUTBAK(C) 5880 CONTINUE GTOKEN = - 100 GOTO 5860 5850 CONTINUE IF (.NOT.(TOKEN(1) .EQ. 39 .OR. TOKEN(1) .EQ. 34)) GOTO 5910 I = 2 5930 IF (.NOT.(NGETCH(TOKEN(I)) .NE. TOKEN(1))) GOTO 5950 IF (.NOT.(TOKEN(I) .EQ. 13)) GOTO 5960 5980 IF (.NOT.(I .GT. 1)) GOTO 6000 C C CALL PUTBAK(TOKEN(I)) 5990 I = I - 1 GOTO 5980 6000 CONTINUE GOTO 5950 5960 CONTINUE IF (.NOT.(I .GE. TOKSIZ-1)) GOTO 6010 CALL SYNERR('missing quote.') TOKEN(I) = TOKEN(1) CALL PUTBAK(13) GOTO 5950 6010 CONTINUE 5970 CONTINUE 5940 I = I + 1 GOTO 5930 5950 CONTINUE GOTO 5920 5910 CONTINUE IF (.NOT.(CP .EQ. 0)) GOTO 6030 C not in a macro? IF (.NOT.(TOKEN(1) .EQ. 123)) GOTO 6050 C allow { for [ TOKEN(1) = 91 GTOKEN = 91 GOTO 6060 6050 CONTINUE IF (.NOT.(TOKEN(1) .EQ. 125)) GOTO 6070 C allow } for ] TOKEN(1) = 93 GTOKEN = 93 GOTO 6080 6070 CONTINUE IF (.NOT.(TOKEN(1) .EQ. 35)) GOTO 6090 C output comments CALL PUTCH(67, 2) 6110 IF (.NOT.(NGETCH(TOKEN(1)) .NE. 13)) GOTO 6120 CALL PUTCH(TOKEN(1), 2) GOTO 6110 6120 CONTINUE CALL PUTCH(13, 2) GTOKEN = 13 GOTO 6100 6090 CONTINUE IF (.NOT.(TOKEN(1) .EQ. 62 .OR. TOKEN(1) .EQ. 60 .OR. *TOKEN(1) .EQ. 126 .OR. TOKEN(1) .EQ. 33 .OR. TOKEN(1) .EQ. 94 .OR. * TOKEN(1) .EQ. 92 .OR. TOKEN(1) .EQ. 61 .OR. TOKEN(1) .EQ. 38 .OR. * TOKEN(1) .EQ. 124)) GOTO 6130 IF (.NOT.(TOKSIZ .LT. 10)) GOTO 6150 CALL SYNERR('shouldn''t happen.') GOTO 6160 6150 CONTINUE CALL RELATE(TOKEN, I) 6160 CONTINUE 6130 CONTINUE 6100 CONTINUE 6080 CONTINUE 6060 CONTINUE 6030 CONTINUE 5920 CONTINUE 5860 CONTINUE TOKEN(I + 1) = 0 RETURN END C ARCHIVE GETTOK.RAT 10 12-MAY-81 22:39:45 C gettok - get token after processing by deftok BYTE FUNCTION GETTOK(TOKEN, TOKSIZ) BYTE TOKEN(1), DEFTOK INTEGER TOKSIZ 6170 CONTINUE GETTOK = DEFTOK(TOKEN, TOKSIZ) 6180 IF (.NOT.(GETTOK .NE. 32 .AND. GETTOK .NE. 9)) GOTO 6170 6190 CONTINUE RETURN END C ARCHIVE DOBASE.RAT 24 12-MAY-81 11:29:37 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 6200 C got one N = 0 6220 CONTINUE C = CUPPER(NGETCH(C)) IF (.NOT.(C .GE. 65 .AND. C .LE. 90)) GOTO 6250 CN = C - 65 + 10 GOTO 6260 6250 CONTINUE IF (.NOT.(C .GE. 48 .AND. C .LE. 57)) GOTO 6270 CN = C - 48 GOTO 6280 6270 CONTINUE GOTO 6240 6280 CONTINUE 6260 CONTINUE IF (.NOT.(CN .GE. BASE)) GOTO 6290 CALL SYNERR('number inconsistent with base.') 6290 CONTINUE 6230 N = BASE*N + CN GOTO 6220 6240 CONTINUE CALL PUTBAK(C) I = ITOC(N, TOKEN, TOKSIZ) GOTO 6210 6200 CONTINUE CALL SYNERR('number base out of range.') 6210 CONTINUE RETURN END C ARCHIVE STRDCL.RAT 95 12-MAY-81 14:55:40 C strdcl - generate code for string declaration SUBROUTINE STRDCL BYTE T, TOKEN(200), GETTOK, ESC INTEGER I, J, K, N, LEN INTEGER LENGTH, CTOI, LEX, ELENTH BYTE DCHAR(200) 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/ T = GETTOK(TOKEN, 200) IF (.NOT.(T .NE. -100)) GOTO 6310 CALL SYNERR('missing string token.') 6310 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, 200) .NE. 40)) GOTO 6330 C make size same as initial value LEN = ELENTH(TOKEN) + 1 IF (.NOT.(TOKEN(1) .EQ. 39 .OR. TOKEN(1) .EQ. 34)) GOTO 6350 LEN = LEN - 2 6350 CONTINUE GOTO 6340 6330 CONTINUE C form is string name(size) init T = GETTOK(TOKEN, 200) I = 1 LEN = CTOI(TOKEN, I) IF (.NOT.(TOKEN(I) .NE. 0)) GOTO 6370 CALL SYNERR('invalid string size.') 6370 CONTINUE IF (.NOT.(GETTOK(TOKEN, 200) .NE. 41)) GOTO 6390 CALL SYNERR('missing right paren.') GOTO 6400 6390 CONTINUE T = GETTOK(TOKEN, 200) 6400 CONTINUE 6340 CONTINUE CALL OUTCH(40) CALL OUTNUM(LEN) CALL OUTCH(41) CALL OUTDON IF (.NOT.(TOKEN(1) .EQ. 39 .OR. TOKEN(1) .EQ. 34)) GOTO 6410 LEN = LENGTH(TOKEN) TOKEN(LEN) = 0 CALL ADDSTR(TOKEN(2), SBUF, SBP, 600) GOTO 6420 6410 CONTINUE CALL ADDSTR(TOKEN, SBUF, SBP, 600) 6420 CONTINUE CALL ADDCHR(0, SBUF, SBP, 600) C peek at next token T = LEX(TOKEN) CALL PBSTR(TOKEN) IF (.NOT.(T .NE. -70)) GOTO 6430 C dump accumulated data statements I = 1 6450 IF (.NOT.(I .LT. SBP)) GOTO 6470 CALL OUTTAB CALL OUTSTR(DAT) K = 1 J = I + LENGTH(SBUF(I)) + 1 6480 CONTINUE IF (.NOT.(K .GT. 1)) GOTO 6510 CALL OUTCH(44) 6510 CONTINUE CALL OUTSTR(SBUF(I)) CALL OUTCH(40) CALL OUTNUM(K) CALL OUTCH(41) CALL OUTCH(47) IF (.NOT.(SBUF(J) .EQ. 0)) GOTO 6530 GOTO 6500 6530 CONTINUE N = ESC(SBUF, J) CALL OUTNUM(N) CALL OUTCH(47) K = K + 1 6490 J = J + 1 GOTO 6480 6500 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 6460 I = J + 1 GOTO 6450 6470 CONTINUE SBP = 1 6430 CONTINUE RETURN END C ARCHIVE ADDSTR.RAT 10 12-MAY-81 12:24:10 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 6550 IF (.NOT.(S(I) .NE. 0)) GOTO 6570 CALL ADDCHR(S(I), BUF, BP, MAXSIZ) 6560 I = I + 1 GOTO 6550 6570 CONTINUE RETURN END C ARCHIVE ADDCHR.RAT 11 12-MAY-81 12:24:11 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 6580 CALL FATAL('string buffer overflow.') 6580 CONTINUE BUF(BP) = C BP = BP + 1 RETURN END C ARCHIVE ELENTH.RAT 15 12-MAY-81 12:24:11 C calculate length of buf, taking escaped characters into account INTEGER FUNCTION ELENTH(BUF) BYTE BUF(1), C BYTE ESC INTEGER I, N N = 0 I = 1 6600 IF (.NOT.(BUF(I) .NE. 0)) GOTO 6620 C = ESC(BUF, I) N = N + 1 6610 I = I + 1 GOTO 6600 6620 CONTINUE ELENTH = N RETURN END C ARCHIVE CASCOD.RAT 65 14-MAY-81 21:24:51 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(200), 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 C-------------------------------------------------------------------- C# preprocessor common block to hold 'goto' flags C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/XFER CYES if just made transfer; else NO INTEGER XFER IF (.NOT.(SWTOP .LE. 0)) GOTO 6630 CALL SYNERR('illegal case or default.') RETURN 6630 CONTINUE C terminate previous case CALL OUTGO(LAB + 10) XFER = 1 L = LABGEN(1) IF (.NOT.(TOKEN .EQ. -72)) GOTO 6650 C case n[,n]... : ... 6670 IF (.NOT.(CASLAB(LB, T) .NE. -10)) GOTO 6680 UB = LB IF (.NOT.(T .EQ. 45)) GOTO 6690 JUNK = CASLAB(UB, T) 6690 CONTINUE IF (.NOT.(LB .GT. UB)) GOTO 6710 CALL SYNERR('illegal range in case label.') UB = LB 6710 CONTINUE IF (.NOT.(SWLAST+3 .GT. 500)) GOTO 6730 CALL FATAL('switch table overflow.') 6730 CONTINUE I = SWTOP + 3 6750 IF (.NOT.(I .LT. SWLAST)) GOTO 6770 IF (.NOT.(LB .LE. SWSTAK(I))) GOTO 6780 GOTO 6770 6780 CONTINUE IF (.NOT.(LB .LE. SWSTAK(I+1))) GOTO 6800 CALL SYNERR('duplicate case label.') 6800 CONTINUE 6790 CONTINUE 6760 I = I + 3 GOTO 6750 6770 CONTINUE IF (.NOT.(I .LT. SWLAST .AND. UB .GE. SWSTAK(I))) GOTO 6820 CALL SYNERR('duplicate case label.') 6820 CONTINUE J = SWLAST 6840 IF (.NOT.(J .GT. I)) GOTO 6860 C insert new entry SWSTAK(J + 2) = SWSTAK(J - 1) 6850 J = J - 1 GOTO 6840 6860 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 .EQ. 58)) GOTO 6870 GOTO 6680 6870 CONTINUE IF (.NOT.(T .NE. 44)) GOTO 6890 CALL SYNERR('illegal case syntax.') 6890 CONTINUE 6880 CONTINUE GOTO 6670 6680 CONTINUE GOTO 6660 6650 CONTINUE C default : ... T = GETTOK(TOK, 200) IF (.NOT.(SWSTAK(SWTOP+2) .NE. 0)) GOTO 6910 CALL SYNERR('multiple defaults in switch statement.') GOTO 6920 6910 CONTINUE SWSTAK(SWTOP + 2) = L 6920 CONTINUE 6660 CONTINUE IF (.NOT.(T .EQ. -10)) GOTO 6930 CALL PUTBAK( - 10) GOTO 6940 6930 CONTINUE IF (.NOT.(T .NE. 58)) GOTO 6950 CALL SYNERR('missing colon in case or default label.') 6950 CONTINUE 6940 CONTINUE XFER = 0 CALL OUTDEN(2) CALL OUTCON(L) CALL INDEN(2) RETURN END C ARCHIVE CASLAB.RAT 36 14-MAY-81 21:24:53 C caslab - get one case label BYTE FUNCTION CASLAB(N, T) INTEGER N, I, S BYTE T, TOK(200), GETTOK INTEGER CTOI, ALLDIG, LENGTH T = GETTOK(TOK, 200) 6970 IF (.NOT.(T .EQ. 13)) GOTO 6980 T = GETTOK(TOK, 200) GOTO 6970 6980 CONTINUE IF (.NOT.(T .EQ. -10)) GOTO 6990 CASLAB = T RETURN 6990 CONTINUE IF (.NOT.(T .EQ. 45)) GOTO 7010 S = - 1 GOTO 7020 7010 CONTINUE S = + 1 7020 CONTINUE IF (.NOT.(T .EQ. 45 .OR. T .EQ. 43)) GOTO 7030 T = GETTOK(TOK, 200) 7030 CONTINUE IF (.NOT.(ALLDIG(TOK) .EQ. 1)) GOTO 7050 I = 1 N = S*CTOI(TOK, I) GOTO 7060 7050 CONTINUE IF (.NOT.((T .EQ. 34 .OR. T .EQ. 39) .AND. LENGTH(TOK) .EQ. 3)) *GOTO 7070 C char const N = TOK(2) GOTO 7080 7070 CONTINUE CALL SYNERR('invalid case label.') N = 0 7080 CONTINUE 7060 CONTINUE T = GETTOK(TOK, 200) 7090 IF (.NOT.(T .EQ. 13)) GOTO 7100 T = GETTOK(TOK, 200) GOTO 7090 7100 CONTINUE CASLAB = T RETURN END C ARCHIVE SWCODE.RAT 34 13-MAY-81 00:54:24 C swcode - generate code for beginning of switch statement SUBROUTINE SWCODE(LAB) INTEGER LAB, LABGEN BYTE TOK(200), 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 C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/XFER CYES if just made transfer; else NO INTEGER XFER LAB = LABGEN(2) IF (.NOT.(SWLAST+3 .GT. 500)) GOTO 7110 CALL FATAL('switch table overflow.') 7110 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 OUTCH(61) CALL BALPAR CALL OUTDON C goto L CALL OUTGO(LAB) XFER = 1 CALL INDEN(2) 7130 IF (.NOT.(GETTOK(TOK, 200) .EQ. 13)) GOTO 7140 GOTO 7130 7140 CONTINUE IF (.NOT.(TOK(1) .NE. 91)) GOTO 7150 CALL SYNERR('missing left brace in switch statement.') CALL PBSTR(TOK) 7150 CONTINUE CALL PUTBAK(91) RETURN END C ARCHIVE SWEND.RAT 96 13-MAY-81 12:04:02 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 C-------------------------------------------------------------------- C# preprocessor common block to hold 'goto' flags C put on a file named 'cgoto' C Used only by ratfiv preprocessor COMMON/CGOTO/XFER CYES if just made transfer; else NO INTEGER XFER BYTE SIF(5) BYTE SLT(10) BYTE SGT(5) BYTE SGOTO(7) BYTE SEQ(5) BYTE SGE(5) BYTE SLE(5) BYTE SAND(6) DATA SIF(1)/105/,SIF(2)/102/,SIF(3)/32/,SIF(4)/40/,SIF(5)/0/ DATA SLT(1)/46/,SLT(2)/108/,SLT(3)/116/,SLT(4)/46/,SLT(5)/49/,SLT( *6)/46/,SLT(7)/111/,SLT(8)/114/,SLT(9)/46/,SLT(10)/0/ DATA SGT(1)/46/,SGT(2)/103/,SGT(3)/116/,SGT(4)/46/,SGT(5)/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)/46/,SEQ(2)/101/,SEQ(3)/113/,SEQ(4)/46/,SEQ(5)/0/ DATA SGE(1)/46/,SGE(2)/103/,SGE(3)/101/,SGE(4)/46/,SGE(5)/0/ DATA SLE(1)/46/,SLE(2)/108/,SLE(3)/101/,SLE(4)/46/,SLE(5)/0/ DATA SAND(1)/46/,SAND(2)/97/,SAND(3)/110/,SAND(4)/100/,SAND(5)/46/ *,SAND(6)/0/ LB = SWSTAK(SWTOP + 3) UB = SWSTAK(SWLAST - 2) N = SWSTAK(SWTOP + 1) C terminate last case CALL OUTGO(LAB + 10) CALL OUTDEN(2) IF (.NOT.(SWSTAK(SWTOP+2) .EQ. 0)) GOTO 7170 C default default label SWSTAK(SWTOP + 2) = LAB + 10 7170 CONTINUE XFER = 0 C L continue CALL OUTCON(LAB) IF (.NOT.(N .GE. 3 .AND. UB-LB+1 .LT. 2*N)) GOTO 7190 C output branch table IF (.NOT.(LB .NE. 1)) GOTO 7210 C L Innn=Innn-lb+1 CALL OUTTAB CALL SWVAR(LAB) CALL OUTCH(61) CALL SWVAR(LAB) IF (.NOT.(LB .LT. 1)) GOTO 7230 CALL OUTCH(43) 7230 CONTINUE CALL OUTNUM( - LB + 1) CALL OUTDON 7210 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 OUTGO(SWSTAK(SWTOP + 2)) C goto (....),Innn CALL OUTTAB CALL OUTSTR(SGOTO) J = LB I = SWTOP + 3 7250 IF (.NOT.(I .LT. SWLAST)) GOTO 7270 7280 IF (.NOT.(J .LT. SWSTAK(I))) GOTO 7300 C fill in vacancies CALL OUTNUM(SWSTAK(SWTOP + 2)) CALL OUTCH(44) 7290 J = J + 1 GOTO 7280 7300 CONTINUE J = SWSTAK(I + 1) - SWSTAK(I) 7310 IF (.NOT.(J .GE. 0)) GOTO 7330 C fill in range CALL OUTNUM(SWSTAK(I + 2)) IF (.NOT.(J .GT. 0)) GOTO 7340 CALL OUTCH(44) 7340 CONTINUE 7320 J = J - 1 GOTO 7310 7330 CONTINUE J = SWSTAK(I + 1) + 1 IF (.NOT.(I .LT. SWLAST-3)) GOTO 7360 CALL OUTCH(44) 7360 CONTINUE 7260 I = I + 3 GOTO 7250 7270 CONTINUE CALL OUTCH(41) CALL OUTCH(44) CALL OUTCH(32) CALL SWVAR(LAB) CALL OUTDON GOTO 7200 7190 CONTINUE IF (.NOT.(N .GT. 0)) GOTO 7380 C output linear search form I = SWTOP + 3 7400 IF (.NOT.(I .LT. SWLAST)) GOTO 7420 C if(Innn CALL OUTTAB CALL OUTSTR(SIF) CALL SWVAR(LAB) IF (.NOT.(SWSTAK(I) .EQ. SWSTAK(I+1))) GOTO 7430 C .eq.... CALL OUTSTR(SEQ) CALL OUTNUM(SWSTAK(I)) GOTO 7440 7430 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)) 7440 CONTINUE C ) goto ... CALL OUTCH(41) CALL OUTGO(SWSTAK(I + 2)) 7410 I = I + 3 GOTO 7400 7420 CONTINUE IF (.NOT.(LAB+10 .NE. SWSTAK(SWTOP+2))) GOTO 7450 CALL OUTGO(SWSTAK(SWTOP + 2)) 7450 CONTINUE 7380 CONTINUE 7200 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 12-MAY-81 22:39:54 C swvar - output switch variable Innn, where nnn = lab SUBROUTINE SWVAR(LAB) INTEGER LAB CALL OUTCH(73) CALL OUTNUM(LAB) RETURN END C ARCHIVE MACMAIN.RAT 61 10-MAY-81 15:03:58 C compiling for RATFIV or somebody C# macro - expand macros with arguments /*/sor/macror/macros C include symbols file C program macro C STDIN string C ARCHIVE DODEF.RAT 22 10-MAY-81 15:03:59 C# dodef - install definition in table /*/sor/macror/dodef SUBROUTINE DODEF(IARGS, NARGS) INTEGER A1, IARGS, NARGS, ARGTYP 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) 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 COMMON/CMACRO/AP, ARGSTK(120), CALLST(30), PLEV(30) 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 7470 A1 = ARGSTK(IARGS + 1) IF (.NOT.(TYPE(EVALST(A1)) .NE. 1 .AND. EVALST(A1) .NE. 95 .AND. * EVALST(A1) .NE. 0)) GOTO 7490 CALL ERRLIN(EVALST(A1)) CALL SYNERR('non-alphanumeric name.') GOTO 7500 7490 CONTINUE IF (.NOT.(NARGS .GT. 1)) GOTO 7510 CALL INSTAL(EVALST(A1), EVALST(ARGSTK(IARGS + 2)), ARGTYP(EV *ALST(ARGSTK(IARGS + 2)))) GOTO 7520 7510 CONTINUE C subarrays CALL INSTAL(EVALST(A1), 0, 0) 7520 CONTINUE 7500 CONTINUE 7470 CONTINUE IF (.NOT.(NGETCH(C) .NE. 13)) GOTO 7530 CALL PUTBAK(C) 7530 CONTINUE RETURN END C ARCHIVE DOIF.RAT 14 10-MAY-81 15:04:00 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) 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 COMMON/CMACRO/AP, ARGSTK(120), CALLST(30), PLEV(30) 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 7550 RETURN 7550 CONTINUE IF (.NOT.(EQUAL(EVALST(ARGSTK(IARGS+1)), EVALST(ARGSTK(IARGS+2))) *.EQ. 1)) GOTO 7570 C subarrays CALL PBSTR(EVALST(ARGSTK(IARGS + 3))) GOTO 7580 7570 CONTINUE IF (.NOT.(NARGS .GE. 4)) GOTO 7590 CALL PBSTR(EVALST(ARGSTK(IARGS + 4))) 7590 CONTINUE 7580 CONTINUE RETURN END C ARCHIVE DOINCR.RAT 12 10-MAY-81 15:04:00 C# doincr - increment macro argument by 1 /*/sor/macror/doincr 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) 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 COMMON/CMACRO/AP, ARGSTK(120), CALLST(30), PLEV(30) 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 7610 K = ARGSTK(IARGS + 1) CALL PBNUM(CTOI(EVALST, K) + 1) 7610 CONTINUE RETURN END C ARCHIVE DOSUB.RAT 29 10-MAY-81 15:04:01 C# dosub - select macro substring /*/sor/macror/dosub 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) 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 COMMON/CMACRO/AP, ARGSTK(120), CALLST(30), PLEV(30) 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 7630 RETURN 7630 CONTINUE IF (.NOT.(NARGS .EQ. 1)) GOTO 7650 BS = 1 GOTO 7660 7650 CONTINUE K = ARGSTK(IARGS + 2) BS = CTOI(EVALST, K) 7660 CONTINUE IF (.NOT.(NARGS .LE. 2)) GOTO 7670 NC = 200 GOTO 7680 7670 CONTINUE K = ARGSTK(IARGS + 3) C number of characters NC = CTOI(EVALST, K) 7680 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 * 7690 C subarrays K = FC + MIN0(NC, LENGTH(EVALST(FC))) - 1 7710 IF (.NOT.(K .GE. FC)) GOTO 7730 CALL PUTBAK(EVALST(K)) 7720 K = K - 1 GOTO 7710 7730 CONTINUE 7690 CONTINUE RETURN END C ARCHIVE EVAL.RAT 73 10-MAY-81 15:04:01 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) 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 COMMON/CMACRO/AP, ARGSTK(120), CALLST(30), PLEV(30) 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 string digits '0123456789' BYTE DIGITS(11) DATA DIGITS(1)/48/ DATA DIGITS(2)/49/ DATA DIGITS(3)/50/ DATA DIGITS(4)/51/ DATA DIGITS(5)/52/ DATA DIGITS(6)/53/ DATA DIGITS(7)/54/ DATA DIGITS(8)/55/ DATA DIGITS(9)/56/ DATA DIGITS(10)/57/ DATA DIGITS(11)/0/ T = ARGSTK(IDEFN) TD = EVALST(T) IF (.NOT.(TD .LT. 0)) GOTO 7740 IF (.NOT.(TD .EQ. -27)) GOTO 7760 CALL DOIFD(IARGS, NARGS) GOTO 7770 7760 CONTINUE IF (.NOT.(TD .EQ. -28)) GOTO 7780 CALL DOELSD GOTO 7790 7780 CONTINUE IF (.NOT.(TD .EQ. -29)) GOTO 7800 CALL DOENDD GOTO 7810 7800 CONTINUE IF (.NOT.(.NOT.DEFSTK(DEFCNT))) GOTO 7820 GOTO 7830 7820 CONTINUE IF (.NOT.(TD .EQ. -20)) GOTO 7840 CALL DODEF(IARGS, NARGS) GOTO 7850 7840 CONTINUE IF (.NOT.(TD .EQ. -22)) GOTO 7860 CALL DOINCR(IARGS, NARGS) GOTO 7870 7860 CONTINUE IF (.NOT.(TD .EQ. -23)) GOTO 7880 CALL DOSUB(IARGS, NARGS) GOTO 7890 7880 CONTINUE IF (.NOT.(TD .EQ. -21)) GOTO 7900 CALL DOIF(IARGS, NARGS) GOTO 7910 7900 CONTINUE IF (.NOT.(TD .EQ. -24)) GOTO 7920 CALL DOARTH(IARGS, NARGS) GOTO 7930 7920 CONTINUE IF (.NOT.(TD .EQ. -25)) GOTO 7940 CALL DOLEN(IARGS, NARGS) GOTO 7950 7940 CONTINUE IF (.NOT.(TD .EQ. -26)) GOTO 7960 CALL DOIND(IARGS, NARGS) GOTO 7970 7960 CONTINUE IF (.NOT.(TD .EQ. -30)) GOTO 7980 CALL DOINCL(IARGS, NARGS) GOTO 7990 7980 CONTINUE IF (.NOT.(TD .EQ. -31)) GOTO 8000 CALL DOUND(IARGS, NARGS) GOTO 8010 8000 CONTINUE C just pass it along CALL PUTBAK(EVALST(T)) 8010 CONTINUE 7990 CONTINUE 7970 CONTINUE 7950 CONTINUE 7930 CONTINUE 7910 CONTINUE 7890 CONTINUE 7870 CONTINUE 7850 CONTINUE 7830 CONTINUE 7810 CONTINUE 7790 CONTINUE 7770 CONTINUE GOTO 7750 7740 CONTINUE IF (.NOT.(.NOT.DEFSTK(DEFCNT))) GOTO 8020 GOTO 8030 8020 CONTINUE K = T + LENGTH(EVALST(T)) - 1 8040 IF (.NOT.(K .GT. T)) GOTO 8060 IF (.NOT.(EVALST(K-1) .NE. 36)) GOTO 8070 CALL PUTBAK(EVALST(K)) GOTO 8080 8070 CONTINUE ARGNO = INDEX(DIGITS, EVALST(K)) - 1 IF (.NOT.(ARGNO .GE. 0 .AND. ARGNO .LE. NARGS)) GOTO 8090 CALL PBSTR(EVALST(ARGSTK(IARGS + ARGNO))) C skip over $ K = K - 1 GOTO 8100 8090 CONTINUE IF (.NOT.(ARGNO .EQ. -1)) GOTO 8110 C wasn't a digit CALL PUTBAK(EVALST(K)) GOTO 8120 8110 CONTINUE C skip over $ K = K - 1 8120 CONTINUE 8100 CONTINUE 8080 CONTINUE 8050 K = K - 1 GOTO 8040 8060 CONTINUE IF (.NOT.(K .EQ. T)) GOTO 8130 C do last character CALL PUTBAK(EVALST(K)) 8130 CONTINUE 8030 CONTINUE 7750 CONTINUE RETURN END C ARCHIVE GTOKENM.RAT 41 10-MAY-81 15:04:03 C# gtoken - get alphanumeric string or single non-alph for macro C leave stuff in here alone C some alpha was seen C else single character token C ARCHIVE PBNUM.RAT 28 10-MAY-81 15:04:03 C# pbnum - convert number to string, push back on input /*/sor/macror/pbnum SUBROUTINE PBNUM(N) INTEGER MOD, IABS INTEGER M, N, NUM C string digits '0123456789' BYTE DIGITS(11) DATA DIGITS(1)/48/ DATA DIGITS(2)/49/ DATA DIGITS(3)/50/ DATA DIGITS(4)/51/ DATA DIGITS(5)/52/ DATA DIGITS(6)/53/ DATA DIGITS(7)/54/ DATA DIGITS(8)/55/ DATA DIGITS(9)/56/ DATA DIGITS(10)/57/ DATA DIGITS(11)/0/ NUM = IABS(N) 8150 CONTINUE M = MOD(NUM, 10) CALL PUTBAK(DIGITS(M + 1)) NUM = NUM/10 8160 IF (.NOT.(NUM .EQ. 0)) GOTO 8150 8170 CONTINUE IF (.NOT.(N .LT. 0)) GOTO 8180 CALL PUTBAK(45) 8180 CONTINUE RETURN END C ARCHIVE PUSH.RAT 10 10-MAY-81 15:04:04 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 8200 CALL FATAL('argument stack overflow.') 8200 CONTINUE ARGSTK(AP) = EP PUSH = AP + 1 RETURN END C ARCHIVE PUTTOK.RAT 9 10-MAY-81 15:04:05 C# puttok-put token either on output or into eval stack /*/sor/macror/puttok SUBROUTINE PUTTOK(STR) BYTE STR(200) INTEGER I I = 1 8220 IF (.NOT.(STR(I) .NE. 0)) GOTO 8240 CALL PUTCHR(STR(I)) 8230 I = I + 1 GOTO 8220 8240 CONTINUE RETURN END C ARCHIVE PUTCHR.RAT 11 10-MAY-81 15:04:05 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) 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 COMMON/CMACRO/AP, ARGSTK(120), CALLST(30), PLEV(30) 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 8250 CALL FATAL('evaluation stack overflow.') 8250 CONTINUE EVALST(EP) = C EP = EP + 1 RETURN END C ARCHIVE DOARTH.RAT 30 12-MAY-81 13:21:47 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) 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 COMMON/CMACRO/AP, ARGSTK(120), CALLST(30), PLEV(30) 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 8270 A = ARGSTK(IARGS + 1) OP1 = CTOI(EVALST, A) K = 2 8290 IF (.NOT.(K+1 .LE. NARGS)) GOTO 8310 OP = EVALST(ARGSTK(IARGS + K)) A = ARGSTK(IARGS + K + 1) OP2 = CTOI(EVALST, A) IF (.NOT.(OP .EQ. 43)) GOTO 8320 OP1 = OP1 + OP2 GOTO 8330 8320 CONTINUE IF (.NOT.(OP .EQ. 45)) GOTO 8340 OP1 = OP1 - OP2 GOTO 8350 8340 CONTINUE IF (.NOT.(OP .EQ. 42)) GOTO 8360 OP1 = OP1*OP2 GOTO 8370 8360 CONTINUE IF (.NOT.(OP .EQ. 47)) GOTO 8380 OP1 = OP1/OP2 GOTO 8390 8380 CONTINUE CALL SYNERR('arith error.') 8390 CONTINUE 8370 CONTINUE 8350 CONTINUE 8330 CONTINUE 8300 K = K + 2 GOTO 8290 8310 CONTINUE 8270 CONTINUE CALL PBNUM(OP1) RETURN END C ARCHIVE INSTAL.RAT 30 10-MAY-81 15:04:06 C# instal - add name and definition to table SUBROUTINE INSTAL(NAME, DEFN, FLAG) BYTE DEFN(500), NAME(200), 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(5500) 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 8400 NLEN = LENGTH(NAME) + 1 DLEN = LENGTH(DEFN) + 1 IF (.NOT.(DLEN .GT. 500)) GOTO 8420 CALL ERRLIN(NAME) CALL SYNERR('definition too long.') RETURN 8420 CONTINUE IF (.NOT.(AVAIL+NLEN+DLEN+2*2 .GT. 5500+1)) GOTO 8440 CALL ERRLIN(NAME) CALL SYNERR('too many definitions.') RETURN 8440 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 8400 CONTINUE RETURN END C ARCHIVE LOOKUP.RAT 13 10-MAY-81 15:04:07 C# lookup - locate name, extract definition from table INTEGER FUNCTION LOOKUP(NAME, DEFN, FLAG) BYTE DEFN(500), NAME(200), 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(5500) 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 8460 CALL SCOPY(TABLE, J, DEFN, 1) FLAG = GETINT(TABLE(I + 2)) 8460 CONTINUE RETURN END C ARCHIVE UNDEF.RAT 33 10-MAY-81 15:04:07 C undef - undefine a macro and garbage collect SUBROUTINE UNDEF(NAME) BYTE NAME(200), 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(5500) 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 8480 IF (.NOT.(TABPTR(C) .EQ. I)) GOTO 8500 TABPTR(C) = GETINT(TABLE(I)) GOTO 8510 8500 CONTINUE K = TABPTR(C) 8520 IF (.NOT.(GETINT(TABLE(K)) .NE. I)) GOTO 8540 8530 K = GETINT(TABLE(K)) GOTO 8520 8540 CONTINUE CALL SETINT(TABLE(K), GETINT(TABLE(I))) 8510 CONTINUE J = J + LENGTH(TABLE(J)) + 1 DEFLEN = J - I DO 8550 L = 1, 127 IF (.NOT.(TABPTR(L) .GT. I)) GOTO 8570 K = TABPTR(L) TABPTR(L) = TABPTR(L) - DEFLEN 8590 IF (.NOT.(GETINT(TABLE(K)) .GT. I)) GOTO 8610 KNEXT = GETINT(TABLE(K)) CALL SETINT(TABLE(K), KNEXT - DEFLEN) 8600 K = KNEXT GOTO 8590 8610 CONTINUE 8570 CONTINUE 8550 CONTINUE 8560 CONTINUE 8620 IF (.NOT.(J .LT. AVAIL)) GOTO 8640 TABLE(I) = TABLE(J) I = I + 1 8630 J = J + 1 GOTO 8620 8640 CONTINUE AVAIL = I 8480 CONTINUE RETURN END C ARCHIVE LOCDEF.RAT 23 10-MAY-81 15:04:08 C# locdef - locate name, extract definition from table INTEGER FUNCTION LOCDEF(NAME, I, J, C) BYTE NAME(200) 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(5500) 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 8650 C = NAME(1) I = TABPTR(C) 8670 IF (.NOT.(I .GT. 0)) GOTO 8690 J = I + 2*2 K = 1 8700 IF (.NOT.(NAME(K) .EQ. TABLE(J) .AND. NAME(K) .NE. 0)) GOTO 87 *20 J = J + 1 8710 K = K + 1 GOTO 8700 8720 CONTINUE IF (.NOT.(NAME(K) .EQ. TABLE(J))) GOTO 8730 C got one J = J + 1 LOCDEF = 1 RETURN 8730 CONTINUE 8680 I = GETINT(TABLE(I)) GOTO 8670 8690 CONTINUE 8650 CONTINUE LOCDEF = 0 RETURN END C ARCHIVE NGETCH.RAT 27 10-MAY-81 15:04:09 C# ngetch - get a (possibly pushed back) character BYTE FUNCTION NGETCH(C) BYTE GETCH BYTE C, C2 C---------------------------------------------------------------------- C# preprocessor common block to hold input characters C Put on a file called 'cdefio' C Used by ratfiv preprocessor, macro, form, and shell tools COMMON/CDEFIO/BP, BUF(600) C next available character; init = 0 INTEGER BP 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(4*34) 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 IF (.NOT.(BP .GT. 0)) GOTO 8750 C = BUF(BP) BP = BP - 1 GOTO 8760 8750 CONTINUE 10 C = GETCH(C, INFILE(LEVEL)) IF (.NOT.(C .EQ. 95)) GOTO 8770 C2 = GETCH(C2, INFILE(LEVEL)) IF (.NOT.(C2 .EQ. 13)) GOTO 8790 LINECT(LEVEL) = LINECT(LEVEL) + 1 GOTO 10 8790 CONTINUE CALL PUTBAK(C2) 8770 CONTINUE 8760 CONTINUE IF (.NOT.(C .EQ. 13)) GOTO 8810 LINECT(LEVEL) = LINECT(LEVEL) + 1 8810 CONTINUE NGETCH = C RETURN END C ARCHIVE PBSTR.RAT 10 10-MAY-81 15:04:09 C# pbstr - push string back onto input SUBROUTINE PBSTR(IN) BYTE IN(1) INTEGER LENGTH INTEGER I I = LENGTH(IN) 8830 IF (.NOT.(I .GT. 0)) GOTO 8850 CALL PUTBAK(IN(I)) 8840 I = I - 1 GOTO 8830 8850 CONTINUE RETURN END C ARCHIVE PUTBAK.RAT 14 10-MAY-81 15:04:10 C# putbak - push character back onto input SUBROUTINE PUTBAK(C) BYTE 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(4*34) 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---------------------------------------------------------------------- C# preprocessor common block to hold input characters C Put on a file called 'cdefio' C Used by ratfiv preprocessor, macro, form, and shell tools COMMON/CDEFIO/BP, BUF(600) C next available character; init = 0 INTEGER BP C pushed-back characters BYTE BUF BP = BP + 1 IF (.NOT.(BP .GT. 600)) GOTO 8860 CALL FATAL('too many characters pushed back.') 8860 CONTINUE BUF(BP) = C IF (.NOT.(C .EQ. 13)) GOTO 8880 LINECT(LEVEL) = LINECT(LEVEL) - 1 8880 CONTINUE RETURN END C ARCHIVE SETINT.RAT 8 10-MAY-81 15:04:10 C setint - put an integer into table SUBROUTINE SETINT(TABLE, VAL) BYTE TABLE(2), VAL(2) DO 8900 I = 1, 2 TABLE(I) = VAL(I) 8900 CONTINUE 8910 CONTINUE RETURN END C ARCHIVE GETINT.RAT 11 10-MAY-81 15:04:11 C getint - get an integer from table INTEGER FUNCTION GETINT(TABLE) BYTE TABLE(2), C(2) INTEGER I, J EQUIVALENCE(I, C) DO 8920 J = 1, 2 C(J) = TABLE(J) 8920 CONTINUE 8930 CONTINUE GETINT = I RETURN END C ARCHIVE DOIND.RAT 12 10-MAY-81 15:04:11 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) 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 COMMON/CMACRO/AP, ARGSTK(120), CALLST(30), PLEV(30) 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 8940 CALL PBNUM(0) GOTO 8950 8940 CONTINUE IF (.NOT.(NARGS .GE. 2)) GOTO 8960 CALL PBNUM(INDEX(EVALST(ARGSTK(IARGS + 1)), EVALST(ARGSTK(IARG *S + 2)))) 8960 CONTINUE 8950 CONTINUE RETURN END C ARCHIVE DOLEN.RAT 12 10-MAY-81 15:04:12 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) 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 COMMON/CMACRO/AP, ARGSTK(120), CALLST(30), PLEV(30) 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 8980 CALL PBNUM(0) GOTO 8990 8980 CONTINUE CALL PBNUM(LENGTH(EVALST(ARGSTK(IARGS + 1)))) 8990 CONTINUE RETURN END C ARCHIVE DOIFD.RAT 18 10-MAY-81 15:04:12 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) 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 COMMON/CMACRO/AP, ARGSTK(120), CALLST(30), PLEV(30) 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 9000 CALL FATAL('_ifdefs nested too deeply.') 9000 CONTINUE DEFSTK(DEFCNT) = DEFSTK(DEFCNT - 1) IF (.NOT.(DEFSTK(DEFCNT))) GOTO 9020 IF (.NOT.(NARGS .GT. 0)) GOTO 9040 IF (.NOT.(LOCDEF(EVALST(ARGSTK(IARGS+1)), JUNK1, JUNK2, C) .NE *. 1)) GOTO 9060 DEFSTK(DEFCNT) = .FALSE. 9060 CONTINUE 9040 CONTINUE 9020 CONTINUE IF (.NOT.(NGETCH(C) .NE. 13)) GOTO 9080 CALL PUTBAK(C) 9080 CONTINUE RETURN END C ARCHIVE NOEVAL.RAT 9 10-MAY-81 15:04:13 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 9100 NOEVAL = ISSET(ARGSTK(CALLST(CP)), AP - CALLST(CP) - 3) 9100 CONTINUE RETURN END C ARCHIVE DOELSD.RAT 13 10-MAY-81 15:04:13 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) 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 COMMON/CMACRO/AP, ARGSTK(120), CALLST(30), PLEV(30) 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 9120 CALL SYNERR('bad _elsedef.') GOTO 9130 9120 CONTINUE DEFSTK(DEFCNT) = DEFSTK(DEFCNT - 1) .AND. .NOT.DEFSTK(DEFCNT) 9130 CONTINUE IF (.NOT.(NGETCH(C) .NE. 13)) GOTO 9140 CALL PUTBAK(C) 9140 CONTINUE RETURN END C ARCHIVE DOENDD.RAT 13 10-MAY-81 15:04:14 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) 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 COMMON/CMACRO/AP, ARGSTK(120), CALLST(30), PLEV(30) 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 9160 CALL SYNERR('bad _enddef.') GOTO 9170 9160 CONTINUE DEFCNT = DEFCNT - 1 9170 CONTINUE IF (.NOT.(NGETCH(C) .NE. 13)) GOTO 9180 CALL PUTBAK(C) 9180 CONTINUE RETURN END C ARCHIVE DOINCL.RAT 33 13-MAY-81 20:20:23 C doincl - handle file inclusion for macro SUBROUTINE DOINCL(IARGS, NARGS) INTEGER IARGS, NARGS, I, J, A BYTE NGETCH, C, FILE(34) 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) 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 COMMON/CMACRO/AP, ARGSTK(120), CALLST(30), PLEV(30) 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(4*34) 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 BYTE INCERR(28) DATA INCERR(1)/105/,INCERR(2)/110/,INCERR(3)/99/,INCERR(4)/108/,IN *CERR(5)/117/,INCERR(6)/100/,INCERR(7)/101/,INCERR(8)/32/,INCERR(9) */102/,INCERR(10)/105/,INCERR(11)/108/,INCERR(12)/101/,INCERR(13)/3 *2/,INCERR(14)/110/,INCERR(15)/97/,INCERR(16)/109/,INCERR(17)/101/, *INCERR(18)/32/,INCERR(19)/116/,INCERR(20)/111/,INCERR(21)/111/,INC *ERR(22)/32/,INCERR(23)/108/,INCERR(24)/111/,INCERR(25)/110/,INCERR *(26)/103/,INCERR(27)/46/,INCERR(28)/0/ IF (.NOT.(NGETCH(C) .NE. 13)) GOTO 9200 CALL PUTBAK(C) 9200 CONTINUE I = 0 J = 1 9220 IF (.NOT.(J .LE. NARGS)) GOTO 9240 A = ARGSTK(IARGS + J) 9250 IF (.NOT.(EVALST(A) .NE. 0)) GOTO 9270 I = I + 1 IF (.NOT.(I .GE. 34)) GOTO 9280 CALL SYNERR(INCERR) RETURN 9280 CONTINUE FILE(I) = EVALST(A) 9260 A = A + 1 GOTO 9250 9270 CONTINUE IF (.NOT.(J .LT. NARGS)) GOTO 9300 I = I + 1 IF (.NOT.(I .GE. 34)) GOTO 9320 CALL SYNERR(INCERR) RETURN 9320 CONTINUE FILE(I) = 44 9300 CONTINUE 9230 J = J + 1 GOTO 9220 9240 CONTINUE FILE(I + 1) = 0 CALL INCLUD(FILE, C) RETURN END C ARCHIVE DEFTOK.RAT 124 10-MAY-81 15:04:15 C deftok - get token, process macro invocations BYTE FUNCTION DEFTOK(TOKEN, TOKSIZ) BYTE TOKEN(1), DEFN(500) INTEGER J, NLB, TOKSIZ, ARGTY BYTE BALP(3) 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) 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 COMMON/CMACRO/AP, ARGSTK(120), CALLST(30), PLEV(30) 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(5500) 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, macro, form, and shell tools COMMON/CDEFIO/BP, BUF(600) C next available character; init = 0 INTEGER BP 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(4*34) 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 DATA BALP/40, 41, 0/ 9340 IF (.NOT.(LEVEL .GT. 0)) GOTO 9360 DEFTOK = GTOKEN(TOKEN, TOKSIZ) 9370 IF (.NOT.(DEFTOK .NE. -10)) GOTO 9390 IF (.NOT.(.NOT.DEFSTK(DEFCNT))) GOTO 9400 IF (.NOT.(LOOKUP(TOKEN, DEFN, ARGTY) .EQ. 1)) GOTO 9420 IF (.NOT.(DEFN(1) .EQ. -27)) GOTO 9440 CALL DOIFD(0, 0, 0) GOTO 9450 9440 CONTINUE IF (.NOT.(DEFN(1) .EQ. -28)) GOTO 9460 CALL DOELSD GOTO 9470 9460 CONTINUE IF (.NOT.(DEFN(1) .EQ. -29)) GOTO 9480 CALL DOENDD 9480 CONTINUE 9470 CONTINUE 9450 CONTINUE 9420 CONTINUE GOTO 9410 9400 CONTINUE IF (.NOT.(DEFTOK .EQ. -100)) GOTO 9500 IF (.NOT.(LOOKUP(TOKEN, DEFN, ARGTY) .EQ. 0)) GOTO 9520 IF (.NOT.(CP .EQ. 0)) GOTO 9540 RETURN 9540 CONTINUE CALL PUTTOK(TOKEN) 9550 CONTINUE GOTO 9530 9520 CONTINUE IF (.NOT.(NOEVAL(CP, AP, CALLST, ARGSTK) .EQ. 1)) GOTO 9 *560 CALL PUTTOK(TOKEN) GOTO 9570 9560 CONTINUE C defined; put it in eval stack CP = CP + 1 IF (.NOT.(CP .GT. 30)) GOTO 9580 CALL FATAL('call stack overflow.') 9580 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 9600 J = 0 9620 CONTINUE C peek at next DEFTOK = GTOKEN(TOKEN, TOKSIZ) J = J + 1 9630 IF (.NOT.(DEFTOK .NE. 32)) GOTO 9620 9640 CONTINUE CALL PBSTR(TOKEN) IF (.NOT.(DEFTOK .NE. 40)) GOTO 9650 C add ( ) if not present 9670 IF (.NOT.(J .GT. 1)) GOTO 9690 CALL PUTBAK(32) 9680 J = J - 1 GOTO 9670 9690 CONTINUE CALL PBSTR(BALP) 9650 CONTINUE GOTO 9610 9600 CONTINUE CALL PBSTR(BALP) 9610 CONTINUE PLEV(CP) = 0 9570 CONTINUE 9530 CONTINUE GOTO 9510 9500 CONTINUE IF (.NOT.(CP .EQ. 0)) GOTO 9700 C not in a macro at all RETURN 9700 CONTINUE IF (.NOT.(DEFTOK .EQ. 91)) GOTO 9720 IF (.NOT.(NOEVAL(CP, AP, CALLST, ARGSTK) .EQ. 1)) GOTO * 9740 CALL PUTTOK(TOKEN) GOTO 9750 9740 CONTINUE C strip one level of [] NLB = 1 9760 CONTINUE DEFTOK = GTOKEN(TOKEN, TOKSIZ) IF (.NOT.(DEFTOK .EQ. 91)) GOTO 9790 NLB = NLB + 1 GOTO 9800 9790 CONTINUE IF (.NOT.(DEFTOK .EQ. 93)) GOTO 9810 NLB = NLB - 1 IF (.NOT.(NLB .EQ. 0)) GOTO 9830 GOTO 9780 9830 CONTINUE GOTO 9820 9810 CONTINUE IF (.NOT.(DEFTOK .EQ. -10)) GOTO 9850 CALL SYNERR('EOF in bracketed string.') CALL PUTBAK( - 10) GOTO 9780 9850 CONTINUE 9820 CONTINUE 9800 CONTINUE CALL PUTTOK(TOKEN) 9770 GOTO 9760 9780 CONTINUE 9750 CONTINUE GOTO 9730 9720 CONTINUE IF (.NOT.(DEFTOK .EQ. 40)) GOTO 9870 IF (.NOT.(PLEV(CP) .GT. 0)) GOTO 9890 CALL PUTTOK(TOKEN) 9890 CONTINUE PLEV(CP) = PLEV(CP) + 1 GOTO 9880 9870 CONTINUE IF (.NOT.(DEFTOK .EQ. 41)) GOTO 9910 PLEV(CP) = PLEV(CP) - 1 IF (.NOT.(PLEV(CP) .GT. 0)) GOTO 9930 CALL PUTTOK(TOKEN) GOTO 9940 9930 CONTINUE C end of argument list CALL PUTCHR(0) CALL EVAL(CALLST(CP) + 1, CALLST(CP) + 2, AP - C *ALLST(CP) - 3) C pop eval stack AP = CALLST(CP) EP = ARGSTK(AP + 1) CP = CP - 1 9940 CONTINUE GOTO 9920 9910 CONTINUE IF (.NOT.(DEFTOK .EQ. 44 .AND. PLEV(CP) .EQ. 1)) G *OTO 9950 C new argument CALL PUTCHR(0) AP = PUSH(EP, ARGSTK, AP) GOTO 9960 9950 CONTINUE C just stack it CALL PUTTOK(TOKEN) 9960 CONTINUE 9920 CONTINUE 9880 CONTINUE 9730 CONTINUE 9710 CONTINUE 9510 CONTINUE 9410 CONTINUE 9380 DEFTOK = GTOKEN(TOKEN, TOKSIZ) GOTO 9370 9390 CONTINUE IF (.NOT.(INFILE(LEVEL) .NE. 5)) GOTO 9970 C here on EOF; pop back to last file CALL CLOSE(INFILE(LEVEL)) 9970 CONTINUE 9350 LEVEL = LEVEL - 1 GOTO 9340 9360 CONTINUE IF (.NOT.(CP .NE. 0)) GOTO 9990 CALL SYNERR('unexpected EOF.') 9990 CONTINUE C in case called more than once DEFTOK = - 10 TOKEN(1) = - 10 TOKEN(2) = 0 RETURN END C ARCHIVE INIMAC.RAT 73 10-MAY-81 15:04:17 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) 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 COMMON/CMACRO/AP, ARGSTK(120), CALLST(30), PLEV(30) 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(5500) 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, macro, form, and shell tools COMMON/CDEFIO/BP, BUF(600) C next available character; init = 0 INTEGER BP C pushed-back characters BYTE BUF C cerrbf - holds an error message for later output by synerr COMMON/CERRBF/ERRBUF(200) BYTE ERRBUF INTEGER SET 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) 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 10010 IF (.NOT.(I .LE. 127)) GOTO 10030 TABPTR(I) = 0 10020 I = I + 1 GOTO 10010 10030 CONTINUE CALL INSUPL(MACNAM, MACTYP, SET(SET(SET(0, 10), 1), 2)) CALL INSUPL(UNDNAM, UNDTYP, SET(SET(0, 10), 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(0, 10)) 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), 1)) C initialize pointers, etc. BP = 0 CP = 0 AP = 1 EP = 1 DEFCNT = 1 DEFSTK(1) = .TRUE. ERRBUF(1) = 0 RETURN END C ARCHIVE DOUND.RAT 12 10-MAY-81 15:04:18 C dound - undefine a macro and garbage collect SUBROUTINE DOUND(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) 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 COMMON/CMACRO/AP, ARGSTK(120), CALLST(30), PLEV(30) 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 10040 CALL UNDEF(EVALST(ARGSTK(IARGS + 1))) 10040 CONTINUE IF (.NOT.(NGETCH(C) .NE. 13)) GOTO 10060 CALL PUTBAK(C) 10060 CONTINUE RETURN END C ARCHIVE INCLUD.RAT 30 10-MAY-81 15:42:26 C includ - handle file inclusion INTEGER FUNCTION INCLUD(FILE, C) BYTE FILE(1), C INTEGER LENGTH, OPEN, TLEV 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(4*34) 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 INCLUD = 0 TLEV = LEVEL IF (.NOT.(C .EQ. 13)) GOTO 10080 C so error line numbers correct LINECT(TLEV) = LINECT(TLEV) - 1 10080 CONTINUE IF (.NOT.(LEVEL .GE. 4)) GOTO 10100 CALL SYNERR('includes nested too deeply.') GOTO 10110 10100 CONTINUE INFILE(LEVEL + 1) = OPEN(FILE, 'R') IF (.NOT.(INFILE(LEVEL+1) .EQ. -1)) GOTO 10120 CALL ERRLIN(FILE) CALL SYNERR('can''t open include.') GOTO 10130 10120 CONTINUE LEVEL = LEVEL + 1 LINECT(LEVEL) = 1 FNAMP(LEVEL) = FNAMP(LEVEL - 1) + LENGTH(FNAMES(FNAMP(LEVEL - *1))) + 1 CALL SCOPY(FILE, 1, FNAMES, FNAMP(LEVEL)) INCLUD = 1 10130 CONTINUE 10110 CONTINUE IF (.NOT.(C .EQ. 13)) GOTO 10140 LINECT(TLEV) = LINECT(TLEV) + 1 10140 CONTINUE RETURN END C ARCHIVE ERRLIN.RAT 9 10-MAY-81 15:04:19 C errlin - output a string to STDOUT and to ERROUT SUBROUTINE ERRLIN(MESS) BYTE MESS(1) INTEGER LENGTH C cerrbf - holds an error message for later output by synerr COMMON/CERRBF/ERRBUF(200) BYTE ERRBUF CALL SCOPY(MESS, 1, ERRBUF, LENGTH(ERRBUF) + 1) RETURN END C ARCHIVE INSUPL.RAT 11 10-MAY-81 15:04:20 C insupl - install upper and lower case vesions of name SUBROUTINE INSUPL(NAME, DEFN, FLAG) BYTE NAME(200), DEFN(500), FNAME(200) 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 SYNERR.RAT 13 10-MAY-81 15:04:20 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(200) 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 SYN2.RAT 49 10-MAY-81 15:04:21 C# syn2 - report Ratfiv syntax error SUBROUTINE SYN2(MSG, F) BYTE LC(10), 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(4*34) 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 string serror '? error at line ' BYTE SERROR(17) C string in ' in ' BYTE IN(5) DATA SERROR(1)/63/ DATA SERROR(2)/32/ DATA SERROR(3)/101/ DATA SERROR(4)/114/ DATA SERROR(5)/114/ DATA SERROR(6)/111/ DATA SERROR(7)/114/ DATA SERROR(8)/32/ DATA SERROR(9)/97/ DATA SERROR(10)/116/ DATA SERROR(11)/32/ DATA SERROR(12)/108/ DATA SERROR(13)/105/ DATA SERROR(14)/110/ DATA SERROR(15)/101/ DATA SERROR(16)/32/ DATA SERROR(17)/0/ DATA IN(1)/32/ DATA IN(2)/105/ DATA IN(3)/110/ DATA IN(4)/32/ DATA IN(5)/0/ CALL PUTLIN(SERROR, F) IF (.NOT.(LEVEL .GE. 1)) GOTO 10160 I = LEVEL GOTO 10170 10160 CONTINUE C for EOF errors I = 1 10170 CONTINUE JUNK = ITOC(LINECT(I), LC, 10) 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(13, F) RETURN END C ARCHIVE ARGTYP.RAT 36 10-MAY-81 15:04:22 C argtyp - return flags for argument types in defn INTEGER FUNCTION ARGTYP(DEFN) BYTE DEFN(1), DIGITS(11) INTEGER I, N, FOUND(10), SET DATA DIGITS/48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 0/ DO 10180 I = 1, 10 FOUND(I) = 0 10180 CONTINUE 10190 CONTINUE ARGTYP = 0 I = 1 10200 IF (.NOT.(DEFN(I) .NE. 0)) GOTO 10220 IF (.NOT.(DEFN(I) .EQ. 36)) GOTO 10230 N = INDEX(DIGITS, DEFN(I + 1)) IF (.NOT.(N .NE. 0)) GOTO 10250 DEFN(I) = 36 ARGTYP = SET(ARGTYP, 10) IF (.NOT.(FOUND(N) .EQ. 37)) GOTO 10270 CALL SYNERR('argument cannot be both eval type and noeval *type.') GOTO 10280 10270 CONTINUE FOUND(N) = 36 10280 CONTINUE 10250 CONTINUE GOTO 10240 10230 CONTINUE IF (.NOT.(DEFN(I) .EQ. 37)) GOTO 10290 N = INDEX(DIGITS, DEFN(I + 1)) IF (.NOT.(N .NE. 0)) GOTO 10310 DEFN(I) = 36 ARGTYP = SET(ARGTYP, 10) IF (.NOT.(FOUND(N) .EQ. 36)) GOTO 10330 CALL SYNERR('argument cannot be both eval type and noeva *l type.') GOTO 10340 10330 CONTINUE FOUND(N) = 37 ARGTYP = SET(ARGTYP, N - 1) 10340 CONTINUE 10310 CONTINUE 10290 CONTINUE 10240 CONTINUE 10210 I = I + 1 GOTO 10200 10220 CONTINUE RETURN END C ARCHIVE SET.RAT 11 10-MAY-81 15:04:22 C set - return flags with bit n set INTEGER FUNCTION SET(FLAGS, N) INTEGER FLAGS, N INTEGER BITMSK(11), ISSET DATA BITMSK/1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024/ SET = FLAGS IF (.NOT.(ISSET(FLAGS, N) .NE. 1)) GOTO 10350 SET = FLAGS + BITMSK(N + 1) 10350 CONTINUE RETURN END C ARCHIVE ISSET.RAT 11 10-MAY-81 15:04:23 C isset - return YES if bit n is set in flags INTEGER FUNCTION ISSET(FLAGS, N) INTEGER FLAGS, N INTEGER BITMSK(11) DATA BITMSK/1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024/ ISSET = 0 IF (.NOT.(MOD(FLAGS/BITMSK(N+1), 2) .EQ. 1)) GOTO 10370 ISSET = 1 10370 CONTINUE RETURN END C ARCHIVE FATAL.RAT 8 13-MAY-81 15:12:43 C fatal - handle fatal error SUBROUTINE FATAL(MESS) BYTE MESS(1) CALL SYNERR(MESS) CALL ERROR(0) RETURN END