C define(VAX) C location of system-wide "SYMBOLS." file C maximum field for integer strings C must be highest lu for standard files C definitions for macro processor C put on a file named 'macsym' C pushback buffer for ngetch and putbak C max chars in a definition C max depth of file inclusion C max chars in all definitions C max chars in a token C number of characters per integer C ARCHIVE MACRO.HDR 51 27-DEC-81 22:35:12 C C C C MACRO preprocessor C ================== C C Authors: Original by B. Kernighan and P. J. Plauger, C with rewrites and enhancements by David Hanson and C friends (U. of Arizona), Joe Sventek and Debbie C Scherrer (Lawrence Berkely Laboratory), and C William P. Wood, Jr. (Institute For Cancer Research). C C Address: William P. Wood, Jr. C Computer Center C Institute For Cancer Research C 7701 Burholme Ave. C Philadelphia, Pa. 19111 C (215) 728 2760 C C Version: 2.0 C C Date: December 27, 1981 C C C C ******************************************************* C * * C * THIS SOFTWARE WAS DEVELOPED WITH SUPPORT * C * FROM THE NATIONAL INSTITUTES OF HEALTH: * C * NIH CA06927 * C * NIH CA22780 * C * * C * DIRECT INQUIRIES TO: * C * COMPUTER CENTER * C * THE INSTITUTE FOR CANCER RESEARCH * C * 7701 BURHOLME AVENUE * C * PHILADELPHIA, PENNSYLVANIA 19111 * C * * C * NO WARRANTY OR REPRESENTATION, EXPRESS OR * C * IMPLIED, IS MADE WITH RESPECT TO THE * C * CORRECTNESS, COMPLETENESS, OR USEFULNESS * C * OF THIS SOFTWARE, NOR THAT USE OF THIS * C * SOFTWARE MIGHT NOT INFRINGE PRIVATELY * C * OWNED RIGHTS. * C * * C * NO LIABILITY IS ASSUMED WITH RESPECT TO * C * THE USE OF, OR FOR DAMAGES RESULTING FROM * C * THE USE OF THIS SOFTWARE * C * * C ******************************************************* C C ARCHIVE ARGTYP.RAT 43 16-DEC-81 23:37:39 C argtyp - return flags for argument types in defn INTEGER FUNCTION ARGTYP(DEFN) BYTE DEFN(1) INTEGER ATYPE, I, J, N, FOUND(10), SET, INDEX, ISSET BYTE DIGITS(11) BYTE AMPERR(46) DATA DIGITS(1)/48/,DIGITS(2)/49/,DIGITS(3)/50/,DIGITS(4)/51/,DIGIT *S(5)/52/,DIGITS(6)/53/,DIGITS(7)/54/,DIGITS(8)/55/,DIGITS(9)/56/,D *IGITS(10)/57/,DIGITS(11)/0/ DATA AMPERR(1)/97/,AMPERR(2)/114/,AMPERR(3)/103/,AMPERR(4)/117/,AM *PERR(5)/109/,AMPERR(6)/101/,AMPERR(7)/110/,AMPERR(8)/116/,AMPERR(9 *)/115/,AMPERR(10)/32/,AMPERR(11)/99/,AMPERR(12)/97/,AMPERR(13)/110 */,AMPERR(14)/110/,AMPERR(15)/111/,AMPERR(16)/116/,AMPERR(17)/32/,A *MPERR(18)/98/,AMPERR(19)/101/,AMPERR(20)/32/,AMPERR(21)/98/,AMPERR *(22)/111/,AMPERR(23)/116/,AMPERR(24)/104/,AMPERR(25)/32/,AMPERR(26 *)/110/,AMPERR(27)/117/,AMPERR(28)/109/,AMPERR(29)/101/,AMPERR(30)/ *114/,AMPERR(31)/105/,AMPERR(32)/99/,AMPERR(33)/32/,AMPERR(34)/97/, *AMPERR(35)/110/,AMPERR(36)/100/,AMPERR(37)/32/,AMPERR(38)/38/,AMPE *RR(39)/32/,AMPERR(40)/116/,AMPERR(41)/121/,AMPERR(42)/112/,AMPERR( *43)/101/,AMPERR(44)/115/,AMPERR(45)/46/,AMPERR(46)/0/ DO 2000 I = 1, 10 FOUND(I) = 0 2000 CONTINUE ATYPE = 0 I = 1 2020 IF (.NOT.(DEFN(I) .NE. 0)) GOTO 2040 IF (.NOT.(DEFN(I) .EQ. 36 .OR. DEFN(I) .EQ. 37)) GOTO 2050 N = INDEX(DIGITS, DEFN(I + 1)) IF (.NOT.(DEFN(I+1) .EQ. 38)) GOTO 2070 IF (.NOT.(ISSET(ATYPE, 11) .EQ. 0)) GOTO 2090 DO 2110 J = 1, 10 IF (.NOT.(FOUND(J) .NE. 0)) GOTO 2130 CALL SYNERR(AMPERR) GOTO 2030 2130 CONTINUE 2110 CONTINUE ATYPE = SET(ATYPE, 11) 2090 CONTINUE N = 2 2070 CONTINUE IF (.NOT.(N .NE. 0)) GOTO 2150 ATYPE = SET(ATYPE, 10) IF (.NOT.(DEFN(I+1) .NE. 38 .AND. ISSET(ATYPE, 11) .EQ. 1)) *GOTO 2170 CALL SYNERR(AMPERR) N = 2 GOTO 2180 2170 CONTINUE IF (.NOT.(FOUND(N) .NE. 0 .AND. FOUND(N) .NE. DEFN(I))) GOTO * 2190 CALL SYNERR('argument cannot be both eval type and noeval *type.') GOTO 2180 2190 CONTINUE FOUND(N) = DEFN(I) IF (.NOT.(DEFN(I) .EQ. 37)) GOTO 2210 ATYPE = SET(ATYPE, N - 1) 2210 CONTINUE 2180 CONTINUE DEFN(I) = 36 DEFN(I + 1) = DIGITS(N) 2150 CONTINUE 2050 CONTINUE 2030 I = I + 1 GOTO 2020 2040 CONTINUE ARGTYP = (ATYPE) RETURN END C ARCHIVE DEFTOK.RAT 131 18-DEC-81 00:37:53 C deftok - get token, process macro invocations BYTE FUNCTION DEFTOK(TOKEN, TOKSIZ) BYTE TOKEN(1), DEFN(500) INTEGER J, NLB, TOKSIZ, ARGTY BYTE GTOKEN INTEGER LOOKUP, PUSH, LENGTH, ISSET, NOEVAL C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV C-------------------------------------------------------------------- C# preprocessor common block to hold definitions C put on a file named 'clook' C Used by ratfiv preprocessor, macro, and form tools COMMON/CLOOK/AVAIL, TABPTR(127), TABLE(10001) Cfirst location in table; init = 1 INTEGER AVAIL Cname poiners; init = 0 INTEGER TABPTR Cactual text of names and definitions BYTE TABLE C---------------------------------------------------------------------- C preprocessor common block to hold input characters C Put on a file called 'cdefio' C Used by ratfiv preprocessor and macro COMMON/CDEFIO/BP, BPLOW, BPSAVE(4), BUF(900) C next available character; init = 0 INTEGER BP C bottom of push-back buffer at current file level INTEGER BPLOW C holds bplow for active file levels INTEGER BPSAVE C pushed-back characters BYTE BUF C----------------------------------------------------------------------- C preprocessor common block to hold info about lines and included files C put on a file named 'cline' C used by ratfiv preproccessor and macro COMMON/CLINE/LEVEL, INFILE(4), LINECT(4), FNAMP(4), FNAMES(136), I *OIN(134) C level of file inclusion; init = 1 INTEGER LEVEL C file number(level); init infile(1) = STDIN INTEGER INFILE C line count on input file(level); init = 1 INTEGER LINECT C next free slot in fnames INTEGER FNAMP C stack of open file names BYTE FNAMES C input buffer BYTE IOIN BYTE BALP(3) DATA BALP(1)/40/,BALP(2)/41/,BALP(3)/0/ 2230 IF (.NOT.(LEVEL .GT. 0)) GOTO 2250 DEFTOK = GTOKEN(TOKEN, TOKSIZ) 2260 IF (.NOT.(DEFTOK .NE. -10)) GOTO 2280 IF (.NOT.(DEFTOK .EQ. 1)) GOTO 2290 IF (.NOT.(LOOKUP(TOKEN, DEFN, ARGTY) .EQ. 0)) GOTO 2310 IF (.NOT.(CP .EQ. 0)) GOTO 2330 IF (.NOT.(DEFSTK(DEFCNT))) GOTO 2350 RETURN 2350 CONTINUE GOTO 2340 2330 CONTINUE CALL PUTTOK(TOKEN) 2340 CONTINUE GOTO 2320 2310 CONTINUE IF (.NOT.(NOEVAL(CP, AP, CALLST, ARGSTK) .EQ. 1)) GOTO 2370 CALL PUTTOK(TOKEN) GOTO 2320 2370 CONTINUE C defined; put it in eval stack CP = CP + 1 IF (.NOT.(CP .GT. 30)) GOTO 2390 CALL FATAL('call stack overflow.') 2390 CONTINUE CALLST(CP) = AP AP = PUSH(ARGTY, ARGSTK, AP) AP = PUSH(EP, ARGSTK, AP) C stack definition CALL PUTTOK(DEFN) CALL PUTCHR(0) AP = PUSH(EP, ARGSTK, AP) C stack name CALL PUTTOK(TOKEN) CALL PUTCHR(0) AP = PUSH(EP, ARGSTK, AP) IF (.NOT.(ISSET(ARGTY, 10) .EQ. 1)) GOTO 2410 J = 0 2430 CONTINUE C peek at next DEFTOK = GTOKEN(TOKEN, TOKSIZ) J = J + 1 2440 IF (.NOT.(DEFTOK .NE. 32)) GOTO 2430 CALL PBSTR(TOKEN) IF (.NOT.(DEFTOK .NE. 40)) GOTO 2460 C add ( ) if not present 2480 IF (.NOT.(J .GT. 1)) GOTO 2500 CALL PUTBAK(32) 2490 J = J - 1 GOTO 2480 2500 CONTINUE CALL PBSTR(BALP) 2460 CONTINUE GOTO 2420 2410 CONTINUE CALL PBSTR(BALP) 2420 CONTINUE PLEV(CP) = 0 2320 CONTINUE GOTO 2300 2290 CONTINUE IF (.NOT.(CP .EQ. 0)) GOTO 2510 C not in a macro at all IF (.NOT.(DEFSTK(DEFCNT))) GOTO 2530 RETURN 2530 CONTINUE GOTO 2300 2510 CONTINUE IF (.NOT.(DEFTOK .EQ. 40)) GOTO 2550 IF (.NOT.(PLEV(CP) .GT. 0)) GOTO 2570 CALL PUTTOK(TOKEN) 2570 CONTINUE PLEV(CP) = PLEV(CP) + 1 GOTO 2300 2550 CONTINUE IF (.NOT.(DEFTOK .EQ. 41)) GOTO 2590 PLEV(CP) = PLEV(CP) - 1 IF (.NOT.(PLEV(CP) .GT. 0)) GOTO 2610 CALL PUTTOK(TOKEN) GOTO 2620 2610 CONTINUE C end of argument list CALL PUTCHR(0) CALL EVAL(CALLST(CP) + 1, CALLST(CP) + 2, AP - CALLST(CP) *- 3) C pop eval stack AP = CALLST(CP) EP = ARGSTK(AP + 1) CP = CP - 1 2620 CONTINUE GOTO 2300 2590 CONTINUE IF (.NOT.(DEFTOK .EQ. 44 .AND. PLEV(CP) .EQ. 1)) GOTO 2630 C new argument IF (.NOT.(ISSET(ARGSTK(CALLST(CP)), 11) .EQ. 1)) GOTO 2650 C allow commas in argument CALL PUTTOK(TOKEN) GOTO 2660 2650 CONTINUE CALL PUTCHR(0) IF (.NOT.(AP-CALLST(CP)-3 .GE. 9)) GOTO 2670 CALL SYNERR('too many arguments passed to a macro.') GOTO 2680 2670 CONTINUE AP = PUSH(EP, ARGSTK, AP) 2680 CONTINUE 2660 CONTINUE GOTO 2300 2630 CONTINUE C just stack it CALL PUTTOK(TOKEN) 2300 CONTINUE 2270 DEFTOK = GTOKEN(TOKEN, TOKSIZ) GOTO 2260 2280 CONTINUE IF (.NOT.(INFILE(LEVEL) .NE. 5)) GOTO 2690 C here on EOF; pop back to last file CALL CLOSE(INFILE(LEVEL)) 2690 CONTINUE C restore bottom of push-back buffer BPLOW = BPSAVE(LEVEL) 2240 LEVEL = LEVEL - 1 GOTO 2230 2250 CONTINUE IF (.NOT.(CP .NE. 0 .OR. DEFCNT .GT. 1)) GOTO 2710 CALL SYNERR('unexpected EOF.') 2710 CONTINUE C in case called more than once DEFTOK = - 10 TOKEN(1) = - 10 TOKEN(2) = 0 RETURN END C ARCHIVE DOARTH.RAT 30 30-NOV-81 14:32:08 C doarth - arithmetic interpreter SUBROUTINE DOARTH(IARGS, NARGS) INTEGER IARGS, NARGS INTEGER CTOI INTEGER K, OP1, OP2, A BYTE OP C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV IF (.NOT.(NARGS .GT. 0)) GOTO 2730 A = ARGSTK(IARGS + 1) OP1 = CTOI(EVALST, A) K = 2 2750 IF (.NOT.(K+1 .LE. NARGS)) GOTO 2770 OP = EVALST(ARGSTK(IARGS + K)) A = ARGSTK(IARGS + K + 1) OP2 = CTOI(EVALST, A) IF (.NOT.(OP .EQ. 43)) GOTO 2780 OP1 = OP1 + OP2 GOTO 2790 2780 CONTINUE IF (.NOT.(OP .EQ. 45)) GOTO 2800 OP1 = OP1 - OP2 GOTO 2790 2800 CONTINUE IF (.NOT.(OP .EQ. 42)) GOTO 2820 OP1 = OP1*OP2 GOTO 2790 2820 CONTINUE IF (.NOT.(OP .EQ. 47 .AND. OP2 .NE. 0)) GOTO 2840 OP1 = OP1/OP2 GOTO 2790 2840 CONTINUE CALL SYNERR('arith error.') 2790 CONTINUE 2760 K = K + 2 GOTO 2750 2770 CONTINUE 2730 CONTINUE CALL PBNUM(OP1) RETURN END C ARCHIVE DODEF.RAT 32 30-NOV-81 14:32:09 C dodef - install definition in table SUBROUTINE DODEF(IARGS, NARGS) INTEGER A1, IARGS, NARGS, ARGTYP, I BYTE C, NGETCH, TYPE C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV IF (.NOT.(NARGS .GE. 1)) GOTO 2860 A1 = ARGSTK(IARGS + 1) I = 0 2880 CONTINUE IF (.NOT.(TYPE(EVALST(A1+I)) .NE. 3 .AND. EVALST(A1+I) .NE. 95 * .AND. EVALST(A1+I) .NE. 46 .AND. EVALST(A1+I) .NE. 36 .AND. (I .E *Q. 0 .OR. TYPE(EVALST(A1+I)) .NE. 2))) GOTO 2910 CALL ERRLIN(EVALST(A1)) CALL SYNERR('illegal macro name.') GOTO 10 2910 CONTINUE I = I + 1 2890 IF (.NOT.(EVALST(A1+I) .EQ. 44 .OR. EVALST(A1+I) .EQ. 0)) GOTO 2 *880 IF (.NOT.(EVALST(A1+I) .NE. 0)) GOTO 2930 EVALST(A1 + I) = 0 CALL INSTAL(EVALST(A1), EVALST(A1 + I + 1), ARGTYP(EVALST(A1 + * I + 1))) GOTO 2940 2930 CONTINUE CALL INSTAL(EVALST(A1), 0, 0) 2940 CONTINUE 2860 CONTINUE 10 IF (.NOT.(NGETCH(C) .NE. 10)) GOTO 2950 CALL PUTBAK(C) 2950 CONTINUE RETURN END C ARCHIVE DOELSD.RAT 13 30-NOV-81 14:32:09 C doelsd - handle _elsedef SUBROUTINE DOELSD BYTE C, NGETCH C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV IF (.NOT.(DEFCNT .LE. 1)) GOTO 2970 CALL SYNERR('bad _elsedef.') GOTO 2980 2970 CONTINUE DEFSTK(DEFCNT) = DEFSTK(DEFCNT - 1) .AND. .NOT.DEFSTK(DEFCNT) 2980 CONTINUE IF (.NOT.(NGETCH(C) .NE. 10)) GOTO 2990 CALL PUTBAK(C) 2990 CONTINUE RETURN END C ARCHIVE DOENDD.RAT 13 30-NOV-81 14:32:09 C doendd - handle _enddef SUBROUTINE DOENDD BYTE C, NGETCH C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV IF (.NOT.(DEFCNT .LE. 1)) GOTO 3010 CALL SYNERR('bad _enddef.') GOTO 3020 3010 CONTINUE DEFCNT = DEFCNT - 1 3020 CONTINUE IF (.NOT.(NGETCH(C) .NE. 10)) GOTO 3030 CALL PUTBAK(C) 3030 CONTINUE RETURN END C ARCHIVE DOIF.RAT 14 30-NOV-81 14:32:09 C doif - select one of two (macro) arguments /*/sor/macror/doif SUBROUTINE DOIF(IARGS, NARGS) INTEGER EQUAL INTEGER IARGS, NARGS C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV IF (.NOT.(NARGS .LT. 3)) GOTO 3050 RETURN 3050 CONTINUE IF (.NOT.(EQUAL(EVALST(ARGSTK(IARGS+1)), EVALST(ARGSTK(IARGS+2))) *.EQ. 1)) GOTO 3070 C subarrays CALL PBSTR(EVALST(ARGSTK(IARGS + 3))) GOTO 3080 3070 CONTINUE IF (.NOT.(NARGS .GE. 4)) GOTO 3090 CALL PBSTR(EVALST(ARGSTK(IARGS + 4))) 3090 CONTINUE 3080 CONTINUE RETURN END C ARCHIVE DOIFD.RAT 18 30-NOV-81 14:32:09 C doifd - do ifdef builtin macro SUBROUTINE DOIFD(IARGS, NARGS) INTEGER IARGS, NARGS, LOCDEF, JUNK1, JUNK2 BYTE C, NGETCH C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV DEFCNT = DEFCNT + 1 IF (.NOT.(DEFCNT .GT. 20)) GOTO 3110 CALL FATAL('_ifdefs nested too deeply.') 3110 CONTINUE DEFSTK(DEFCNT) = DEFSTK(DEFCNT - 1) IF (.NOT.(DEFSTK(DEFCNT))) GOTO 3130 IF (.NOT.(NARGS .GT. 0)) GOTO 3150 IF (.NOT.(LOCDEF(EVALST(ARGSTK(IARGS+1)), JUNK1, JUNK2, C) .NE *. 1)) GOTO 3170 DEFSTK(DEFCNT) = .FALSE. 3170 CONTINUE 3150 CONTINUE 3130 CONTINUE IF (.NOT.(NGETCH(C) .NE. 10)) GOTO 3190 CALL PUTBAK(C) 3190 CONTINUE RETURN END C ARCHIVE DOINCL.RAT 12 1-DEC-81 11:46:04 C doincl - handle file inclusion for macro SUBROUTINE DOINCL(IARGS, NARGS) INTEGER IARGS, NARGS BYTE NGETCH, C C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV C----------------------------------------------------------------------- C preprocessor common block to hold info about lines and included files C put on a file named 'cline' C used by ratfiv preproccessor and macro COMMON/CLINE/LEVEL, INFILE(4), LINECT(4), FNAMP(4), FNAMES(136), I *OIN(134) C level of file inclusion; init = 1 INTEGER LEVEL C file number(level); init infile(1) = STDIN INTEGER INFILE C line count on input file(level); init = 1 INTEGER LINECT C next free slot in fnames INTEGER FNAMP C stack of open file names BYTE FNAMES C input buffer BYTE IOIN IF (.NOT.(NGETCH(C) .NE. 10)) GOTO 3210 CALL PUTBAK(C) 3210 CONTINUE CALL INCLUD(EVALST(ARGSTK(IARGS + 1))) RETURN END C ARCHIVE DOINCR.RAT 12 30-NOV-81 14:32:10 C doincr - increment macro argument by 1 SUBROUTINE DOINCR(IARGS, NARGS) INTEGER CTOI INTEGER IARGS, NARGS, K C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV IF (.NOT.(NARGS .NE. 0)) GOTO 3230 K = ARGSTK(IARGS + 1) CALL PBNUM(CTOI(EVALST, K) + 1) 3230 CONTINUE RETURN END C ARCHIVE DOIND.RAT 12 30-NOV-81 14:32:10 C doind - get index of arg2 in arg1 SUBROUTINE DOIND(IARGS, NARGS) INTEGER IARGS, NARGS INTEGER INDEX C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV IF (.NOT.(NARGS .EQ. 1)) GOTO 3250 CALL PBNUM(0) GOTO 3260 3250 CONTINUE IF (.NOT.(NARGS .GE. 2)) GOTO 3270 CALL PBNUM(INDEX(EVALST(ARGSTK(IARGS + 1)), EVALST(ARGSTK(IARGS *+ 2)))) 3270 CONTINUE 3260 CONTINUE RETURN END C ARCHIVE DOLEN.RAT 12 30-NOV-81 14:32:10 C dolen - get length of argument SUBROUTINE DOLEN(IARGS, NARGS) INTEGER IARGS, NARGS INTEGER LENGTH C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV IF (.NOT.(NARGS .LT. 1)) GOTO 3290 CALL PBNUM(0) GOTO 3300 3290 CONTINUE CALL PBNUM(LENGTH(EVALST(ARGSTK(IARGS + 1)))) 3300 CONTINUE RETURN END C ARCHIVE DOSUB.RAT 29 30-NOV-81 14:32:10 C dosub - select macro substring SUBROUTINE DOSUB(IARGS, NARGS) INTEGER CTOI, LENGTH INTEGER AP1, FC, IARGS, NARGS, K, NC, BS C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV IF (.NOT.(NARGS .EQ. 0)) GOTO 3310 RETURN 3310 CONTINUE IF (.NOT.(NARGS .EQ. 1)) GOTO 3330 BS = 1 GOTO 3340 3330 CONTINUE K = ARGSTK(IARGS + 2) BS = CTOI(EVALST, K) 3340 CONTINUE IF (.NOT.(NARGS .LE. 2)) GOTO 3350 NC = 32767 GOTO 3360 3350 CONTINUE K = ARGSTK(IARGS + 3) C number of characters NC = CTOI(EVALST, K) 3360 CONTINUE C target string AP1 = ARGSTK(IARGS + 1) C first char of substring FC = AP1 + BS - 1 IF (.NOT.(FC .GE. AP1 .AND. FC .LT. AP1+LENGTH(EVALST(AP1)))) GOTO * 3370 C subarrays K = FC + MIN0(NC, LENGTH(EVALST(FC))) - 1 3390 IF (.NOT.(K .GE. FC)) GOTO 3410 CALL PUTBAK(EVALST(K)) 3400 K = K - 1 GOTO 3390 3410 CONTINUE 3370 CONTINUE RETURN END C ARCHIVE DOUND.RAT 17 30-NOV-81 14:32:11 C dound - undefine a macro and garbage collect SUBROUTINE DOUND(IARGS, NARGS) INTEGER IARGS, NARGS, A1, I, INDEX BYTE NGETCH, C C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV IF (.NOT.(NARGS .GE. 1)) GOTO 3420 A1 = ARGSTK(IARGS + 1) I = INDEX(EVALST(A1), 44) IF (.NOT.(I .NE. 0)) GOTO 3440 EVALST(A1 + I - 1) = 0 3440 CONTINUE CALL UNDEF(EVALST(A1)) 3420 CONTINUE IF (.NOT.(NGETCH(C) .NE. 10)) GOTO 3460 CALL PUTBAK(C) 3460 CONTINUE RETURN END C ARCHIVE ERRLIN.RAT 12 30-NOV-81 14:32:11 C errlin - save a string to output to STDOUT and to ERROUT SUBROUTINE ERRLIN(MESS) BYTE MESS(1) INTEGER I, J, LENGTH C cerrbf - holds an error message for later output by synerr COMMON/CERRBF/ERRBUF(201) BYTE ERRBUF J = LENGTH(ERRBUF) I = J + 1 3480 IF (.NOT.(I .LT. 201 .AND. MESS(I-J) .NE. 0)) GOTO 3500 ERRBUF(I) = MESS(I - J) 3490 I = I + 1 GOTO 3480 3500 CONTINUE ERRBUF(I) = 0 RETURN END C ARCHIVE EVAL.RAT 63 4-DEC-81 13:25:18 C eval - expand args: evaluate builtin or push back defn SUBROUTINE EVAL(IDEFN, IARGS, NARGS) INTEGER INDEX, LENGTH INTEGER ARGNO, IDEFN, IARGS, NARGS, K, T, TD C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV BYTE DIGITS(11) DATA DIGITS(1)/48/,DIGITS(2)/49/,DIGITS(3)/50/,DIGITS(4)/51/,DIGIT *S(5)/52/,DIGITS(6)/53/,DIGITS(7)/54/,DIGITS(8)/55/,DIGITS(9)/56/,D *IGITS(10)/57/,DIGITS(11)/0/ T = ARGSTK(IDEFN) TD = EVALST(T) IF (.NOT.(TD .LT. 0)) GOTO 3510 IF (.NOT.(TD .EQ. -27)) GOTO 3530 CALL DOIFD(IARGS, NARGS) GOTO 3540 3530 CONTINUE IF (.NOT.(TD .EQ. -28)) GOTO 3550 CALL DOELSD GOTO 3540 3550 CONTINUE IF (.NOT.(TD .EQ. -29)) GOTO 3570 CALL DOENDD GOTO 3540 3570 CONTINUE IF (.NOT.(TD .EQ. -22)) GOTO 3590 CALL DOINCR(IARGS, NARGS) GOTO 3540 3590 CONTINUE IF (.NOT.(TD .EQ. -23)) GOTO 3610 CALL DOSUB(IARGS, NARGS) GOTO 3540 3610 CONTINUE IF (.NOT.(TD .EQ. -21)) GOTO 3630 CALL DOIF(IARGS, NARGS) GOTO 3540 3630 CONTINUE IF (.NOT.(TD .EQ. -24)) GOTO 3650 CALL DOARTH(IARGS, NARGS) GOTO 3540 3650 CONTINUE IF (.NOT.(TD .EQ. -25)) GOTO 3670 CALL DOLEN(IARGS, NARGS) GOTO 3540 3670 CONTINUE IF (.NOT.(TD .EQ. -26)) GOTO 3690 CALL DOIND(IARGS, NARGS) GOTO 3540 3690 CONTINUE IF (.NOT.(TD .EQ. -30)) GOTO 3710 IF (.NOT.(DEFSTK(DEFCNT))) GOTO 3730 CALL DOINCL(IARGS, NARGS) 3730 CONTINUE GOTO 3540 3710 CONTINUE IF (.NOT.(TD .EQ. -20)) GOTO 3750 IF (.NOT.(DEFSTK(DEFCNT))) GOTO 3770 CALL DODEF(IARGS, NARGS) 3770 CONTINUE GOTO 3540 3750 CONTINUE IF (.NOT.(TD .EQ. -31)) GOTO 3790 IF (.NOT.(DEFSTK(DEFCNT))) GOTO 3810 CALL DOUND(IARGS, NARGS) 3810 CONTINUE C just pass it along GOTO 3540 3790 CONTINUE CALL PUTBAK(EVALST(T)) 3540 CONTINUE GOTO 3520 3510 CONTINUE K = T + LENGTH(EVALST(T)) - 1 3830 IF (.NOT.(K .GT. T)) GOTO 3850 IF (.NOT.(EVALST(K-1) .NE. 36)) GOTO 3860 CALL PUTBAK(EVALST(K)) GOTO 3870 3860 CONTINUE ARGNO = INDEX(DIGITS, EVALST(K)) - 1 IF (.NOT.(ARGNO .GE. 0 .AND. ARGNO .LE. NARGS)) GOTO 3880 CALL PBSTR(EVALST(ARGSTK(IARGS + ARGNO))) C skip over $ K = K - 1 GOTO 3890 3880 CONTINUE IF (.NOT.(ARGNO .EQ. -1)) GOTO 3900 C wasn't a digit CALL PUTBAK(EVALST(K)) GOTO 3890 3900 CONTINUE C skip over $ K = K - 1 3890 CONTINUE 3870 CONTINUE 3840 K = K - 1 GOTO 3830 3850 CONTINUE IF (.NOT.(K .EQ. T)) GOTO 3920 C do last character CALL PUTBAK(EVALST(K)) 3920 CONTINUE 3520 CONTINUE RETURN END C ARCHIVE FATAL.RAT 8 30-NOV-81 14:32:11 C fatal - handle fatal error SUBROUTINE FATAL(MESS) BYTE MESS(1) CALL SYNERR(MESS) CALL ERROR(0) RETURN END C ARCHIVE GETINT.RAT 11 30-NOV-81 14:32:12 C getint - get an integer from table INTEGER FUNCTION GETINT(TABLE) BYTE TABLE(2), C(2) INTEGER I, J EQUIVALENCE(I, C) DO 3940 J = 1, 2 C(J) = TABLE(J) 3940 CONTINUE GETINT = I RETURN END C ARCHIVE GTOKENM.RAT 42 30-NOV-81 14:32:12 C gtoken - get alphanumeric string or single non-alph for macro BYTE FUNCTION GTOKEN(TOKEN, TOKSIZ) BYTE NGETCH, TYPE INTEGER I, TOKSIZ BYTE TOKEN(1) I = 1 3960 IF (.NOT.(I .LT. TOKSIZ)) GOTO 3980 GTOKEN = TYPE(NGETCH(TOKEN(I))) IF (.NOT.(GTOKEN .NE. 3 .AND. GTOKEN .NE. 2 .AND. GTOKEN .NE. 95 * .AND. GTOKEN .NE. 46 .AND. GTOKEN .NE. 36)) GOTO 3990 GOTO 3980 3990 CONTINUE 3970 I = I + 1 GOTO 3960 3980 CONTINUE IF (.NOT.(TOKEN(1) .EQ. 96)) GOTO 4010 C leave stuff in here alone I = 2 4030 IF (.NOT.(I .LT. TOKSIZ)) GOTO 4050 IF (.NOT.(NGETCH(TOKEN(I)) .EQ. 96)) GOTO 4060 IF (.NOT.(NGETCH(TOKEN(I+1)) .NE. 96)) GOTO 4080 CALL PUTBAK(TOKEN(I + 1)) GOTO 4050 4080 CONTINUE I = I + 1 4090 CONTINUE GOTO 4070 4060 CONTINUE IF (.NOT.(TOKEN(I) .EQ. -10)) GOTO 4100 CALL SYNERR('EOF in literal string.') CALL PUTBAK( - 10) TOKEN(I) = 96 GOTO 4050 4100 CONTINUE 4070 CONTINUE 4040 I = I + 1 GOTO 4030 4050 CONTINUE 4010 CONTINUE IF (.NOT.(I .GE. TOKSIZ)) GOTO 4120 CALL FATAL('token too long.') 4120 CONTINUE IF (.NOT.(I .GT. 1 .AND. TOKEN(1) .NE. 96)) GOTO 4140 C some alpha was seen CALL PUTBAK(TOKEN(I)) I = I - 1 GTOKEN = 1 C else single character token 4140 CONTINUE TOKEN(I + 1) = 0 RETURN END C ARCHIVE INCLUD.RAT 26 1-DEC-81 11:47:48 C includ - handle file inclusion SUBROUTINE INCLUD(FILE) BYTE FILE(1) INTEGER LENGTH, OPEN C----------------------------------------------------------------------- C preprocessor common block to hold info about lines and included files C put on a file named 'cline' C used by ratfiv preproccessor and macro COMMON/CLINE/LEVEL, INFILE(4), LINECT(4), FNAMP(4), FNAMES(136), I *OIN(134) C level of file inclusion; init = 1 INTEGER LEVEL C file number(level); init infile(1) = STDIN INTEGER INFILE C line count on input file(level); init = 1 INTEGER LINECT C next free slot in fnames INTEGER FNAMP C stack of open file names BYTE FNAMES C input buffer BYTE IOIN C---------------------------------------------------------------------- C preprocessor common block to hold input characters C Put on a file called 'cdefio' C Used by ratfiv preprocessor and macro COMMON/CDEFIO/BP, BPLOW, BPSAVE(4), BUF(900) C next available character; init = 0 INTEGER BP C bottom of push-back buffer at current file level INTEGER BPLOW C holds bplow for active file levels INTEGER BPSAVE C pushed-back characters BYTE BUF IF (.NOT.(LEVEL .GE. 4)) GOTO 4160 CALL SYNERR('includes nested too deeply.') GOTO 4170 4160 CONTINUE INFILE(LEVEL + 1) = OPEN(FILE, 'R') IF (.NOT.(INFILE(LEVEL+1) .EQ. -1)) GOTO 4180 CALL ERRLIN(FILE) CALL SYNERR('can''t open included file.') GOTO 4190 4180 CONTINUE LEVEL = LEVEL + 1 LINECT(LEVEL) = 0 FNAMP(LEVEL) = FNAMP(LEVEL - 1) + LENGTH(FNAMES(FNAMP(LEVEL - *1))) + 1 CALL SCOPY(FILE, 1, FNAMES, FNAMP(LEVEL)) BPSAVE(LEVEL) = BPLOW BPLOW = BP 4190 CONTINUE 4170 CONTINUE RETURN END C ARCHIVE INIMAC.RAT 80 30-NOV-81 22:50:44 C inimac - initialize macro preproccessor SUBROUTINE INIMAC C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV C-------------------------------------------------------------------- C# preprocessor common block to hold definitions C put on a file named 'clook' C Used by ratfiv preprocessor, macro, and form tools COMMON/CLOOK/AVAIL, TABPTR(127), TABLE(10001) Cfirst location in table; init = 1 INTEGER AVAIL Cname poiners; init = 0 INTEGER TABPTR Cactual text of names and definitions BYTE TABLE C---------------------------------------------------------------------- C preprocessor common block to hold input characters C Put on a file called 'cdefio' C Used by ratfiv preprocessor and macro COMMON/CDEFIO/BP, BPLOW, BPSAVE(4), BUF(900) C next available character; init = 0 INTEGER BP C bottom of push-back buffer at current file level INTEGER BPLOW C holds bplow for active file levels INTEGER BPSAVE C pushed-back characters BYTE BUF C cerrbf - holds an error message for later output by synerr COMMON/CERRBF/ERRBUF(201) BYTE ERRBUF INTEGER SET, ARGTYP BYTE MACNAM(7), MACTYP(2) BYTE UNDNAM(7), UNDTYP(2) BYTE INCNAM(6), INCTYP(2) BYTE SUBNAM(8), SUBTYP(2) BYTE IFENAM(8), IFETYP(2) BYTE ARINAM(7), ARITYP(2) BYTE LENNAM(5), LENTYP(2) BYTE INDNAM(7), INDTYP(2) BYTE IFDNAM(7), IFDTYP(2) BYTE ELSNAM(9), ELSTYP(2) BYTE ENDNAM(8), ENDTYP(2) BYTE ICLNAM(9), ICLTYP(2) BYTE IFNNAM(8) BYTE IFNDEF(19) BYTE REPNAM(8) BYTE REPDEF(21) DATA IFNNAM(1)/95/,IFNNAM(2)/105/,IFNNAM(3)/102/,IFNNAM(4)/110/,IF *NNAM(5)/100/,IFNNAM(6)/101/,IFNNAM(7)/102/,IFNNAM(8)/0/ DATA IFNDEF(1)/95/,IFNDEF(2)/105/,IFNDEF(3)/102/,IFNDEF(4)/100/,IF *NDEF(5)/101/,IFNDEF(6)/102/,IFNDEF(7)/40/,IFNDEF(8)/37/,IFNDEF(9)/ *49/,IFNDEF(10)/41/,IFNDEF(11)/95/,IFNDEF(12)/101/,IFNDEF(13)/108/, *IFNDEF(14)/115/,IFNDEF(15)/101/,IFNDEF(16)/100/,IFNDEF(17)/101/,IF *NDEF(18)/102/,IFNDEF(19)/0/ DATA REPNAM(1)/95/,REPNAM(2)/114/,REPNAM(3)/101/,REPNAM(4)/112/,RE *PNAM(5)/100/,REPNAM(6)/101/,REPNAM(7)/102/,REPNAM(8)/0/ DATA REPDEF(1)/95/,REPDEF(2)/117/,REPDEF(3)/110/,REPDEF(4)/100/,RE *PDEF(5)/101/,REPDEF(6)/102/,REPDEF(7)/40/,REPDEF(8)/37/,REPDEF(9)/ *38/,REPDEF(10)/41/,REPDEF(11)/95/,REPDEF(12)/109/,REPDEF(13)/97/,R *EPDEF(14)/99/,REPDEF(15)/114/,REPDEF(16)/111/,REPDEF(17)/40/,REPDE *F(18)/37/,REPDEF(19)/38/,REPDEF(20)/41/,REPDEF(21)/0/ DATA MACNAM/95, 109, 97, 99, 114, 111, 0/, MACTYP/ - 20, 0/ DATA UNDNAM/95, 117, 110, 100, 101, 102, 0/, UNDTYP/ - 31, 0/ DATA INCNAM/95, 105, 110, 99, 114, 0/, INCTYP/ - 22, 0/ DATA SUBNAM/95, 115, 117, 98, 115, 116, 114, 0/, SUBTYP/ - 23, 0/ DATA IFENAM/95, 105, 102, 101, 108, 115, 101, 0/, IFETYP/ - 21, 0/ DATA ARINAM/95, 97, 114, 105, 116, 104, 0/, ARITYP/ - 24, 0/ DATA LENNAM/95, 108, 101, 110, 0/, LENTYP/ - 25, 0/ DATA INDNAM/95, 105, 110, 100, 101, 120, 0/, INDTYP/ - 26, 0/ DATA IFDNAM/95, 105, 102, 100, 101, 102, 0/, IFDTYP/ - 27, 0/ DATA ELSNAM/95, 101, 108, 115, 101, 100, 101, 102, 0/, ELSTYP/ - 2 *8, 0/ DATA ENDNAM/95, 101, 110, 100, 100, 101, 102, 0/, ENDTYP/ - 29, 0/ DATA ICLNAM/95, 105, 110, 99, 108, 117, 100, 101, 0/, ICLTYP/ - 30 *, 0/ AVAIL = 1 I = 1 4200 IF (.NOT.(I .LE. 127)) GOTO 4220 TABPTR(I) = 0 4210 I = I + 1 GOTO 4200 4220 CONTINUE CALL INSUPL(MACNAM, MACTYP, SET(SET(SET(0, 10), 11), 1)) CALL INSUPL(UNDNAM, UNDTYP, SET(SET(SET(0, 10), 11), 1)) CALL INSUPL(INCNAM, INCTYP, SET(0, 10)) CALL INSUPL(SUBNAM, SUBTYP, SET(0, 10)) CALL INSUPL(IFENAM, IFETYP, SET(SET(SET(0, 10), 3), 4)) CALL INSUPL(ARINAM, ARITYP, SET(0, 10)) CALL INSUPL(LENNAM, LENTYP, SET(SET(0, 10), 11)) CALL INSUPL(INDNAM, INDTYP, SET(0, 10)) CALL INSUPL(IFDNAM, IFDTYP, SET(SET(0, 10), 1)) CALL INSUPL(ELSNAM, ELSTYP, 0) CALL INSUPL(ENDNAM, ENDTYP, 0) CALL INSUPL(ICLNAM, ICLTYP, SET(SET(0, 10), 11)) CALL INSUPL(IFNNAM, IFNDEF, ARGTYP(IFNDEF)) CALL INSUPL(REPNAM, REPDEF, ARGTYP(REPDEF)) C initialize pointers, etc. BP = 0 BPSAVE(1) = 0 BPLOW = 0 CP = 0 AP = 1 EP = 1 DEFCNT = 1 DEFSTK(1) = .TRUE. ERRBUF(1) = 0 RETURN END C ARCHIVE INSTAL.RAT 30 30-NOV-81 14:32:12 C instal - add name and definition to table SUBROUTINE INSTAL(NAME, DEFN, FLAG) BYTE DEFN(500), NAME(201), C INTEGER LENGTH INTEGER DLEN, NLEN, FLAG C-------------------------------------------------------------------- C# preprocessor common block to hold definitions C put on a file named 'clook' C Used by ratfiv preprocessor, macro, and form tools COMMON/CLOOK/AVAIL, TABPTR(127), TABLE(10001) 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 4230 NLEN = LENGTH(NAME) + 1 DLEN = LENGTH(DEFN) + 1 IF (.NOT.(DLEN .GT. 500)) GOTO 4250 CALL ERRLIN(NAME) CALL SYNERR('definition too long.') RETURN 4250 CONTINUE IF (.NOT.(AVAIL+NLEN+DLEN+2*2 .GT. 10001+1)) GOTO 4270 CALL ERRLIN(NAME) CALL FATAL('too many definitions.') RETURN 4270 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 4230 CONTINUE RETURN END C ARCHIVE INSUPL.RAT 11 30-NOV-81 14:32:13 C insupl - install upper and lower case versions of name SUBROUTINE INSUPL(NAME, DEFN, FLAG) BYTE NAME(201), DEFN(500), FNAME(201) INTEGER FLAG CALL INSTAL(NAME, DEFN, FLAG) CALL SCOPY(NAME, 1, FNAME, 1) CALL UPPER(FNAME) CALL INSTAL(FNAME, DEFN, FLAG) RETURN END C ARCHIVE ISSET.RAT 11 30-NOV-81 14:32:13 C isset - return YES if bit n is set in flags INTEGER FUNCTION ISSET(FLAGS, N) INTEGER FLAGS, N INTEGER BITMSK(12) DATA BITMSK/1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024, 2048/ ISSET = 0 IF (.NOT.(MOD(FLAGS/BITMSK(N+1), 2) .EQ. 1)) GOTO 4290 ISSET = 1 4290 CONTINUE RETURN END C ARCHIVE LOCDEF.RAT 23 30-NOV-81 14:32:13 C locdef - locate name, extract definition from table INTEGER FUNCTION LOCDEF(NAME, I, J, C) BYTE NAME(201) INTEGER I, J, K, C INTEGER GETINT C-------------------------------------------------------------------- C# preprocessor common block to hold definitions C put on a file named 'clook' C Used by ratfiv preprocessor, macro, and form tools COMMON/CLOOK/AVAIL, TABPTR(127), TABLE(10001) 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 4310 C = NAME(1) I = TABPTR(C) 4330 IF (.NOT.(I .GT. 0)) GOTO 4350 J = I + 2*2 K = 1 4360 IF (.NOT.(NAME(K) .EQ. TABLE(J) .AND. NAME(K) .NE. 0)) GOTO 43 *80 J = J + 1 4370 K = K + 1 GOTO 4360 4380 CONTINUE IF (.NOT.(NAME(K) .EQ. TABLE(J))) GOTO 4390 C got one J = J + 1 LOCDEF = 1 RETURN 4390 CONTINUE 4340 I = GETINT(TABLE(I)) GOTO 4330 4350 CONTINUE 4310 CONTINUE LOCDEF = 0 RETURN END C ARCHIVE LOOKUP.RAT 13 30-NOV-81 14:32:13 C lookup - locate name, extract definition from table INTEGER FUNCTION LOOKUP(NAME, DEFN, FLAG) BYTE DEFN(500), NAME(201), C INTEGER FLAG, I, J, LOCDEF, GETINT C-------------------------------------------------------------------- C# preprocessor common block to hold definitions C put on a file named 'clook' C Used by ratfiv preprocessor, macro, and form tools COMMON/CLOOK/AVAIL, TABPTR(127), TABLE(10001) 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 4410 CALL SCOPY(TABLE, J, DEFN, 1) FLAG = GETINT(TABLE(I + 2)) 4410 CONTINUE RETURN END C ARCHIVE MACMAIN.RAT 50 1-DEC-81 11:26:17 C macro - expand macros with arguments C remove this if necessary on your system PROGRAM MACRO C----------------------------------------------------------------------- C preprocessor common block to hold info about lines and included files C put on a file named 'cline' C used by ratfiv preproccessor and macro COMMON/CLINE/LEVEL, INFILE(4), LINECT(4), FNAMP(4), FNAMES(136), I *OIN(134) C level of file inclusion; init = 1 INTEGER LEVEL C file number(level); init infile(1) = STDIN INTEGER INFILE C line count on input file(level); init = 1 INTEGER LINECT C next free slot in fnames INTEGER FNAMP C stack of open file names BYTE FNAMES C input buffer BYTE IOIN INTEGER GETARG, I, J, OPEN BYTE DEFTOK BYTE FILE(134), TOKEN(201) BYTE STDINN(6) DATA STDINN(1)/83/,STDINN(2)/84/,STDINN(3)/68/,STDINN(4)/73/,STDIN *N(5)/78/,STDINN(6)/0/ CALL INITR4 CALL INIMAC I = 1 4430 CONTINUE FNAMP(1) = 1 LEVEL = 1 LINECT(1) = 0 IF (.NOT.(GETARG(I, FILE, 134) .EQ. -10)) GOTO 4460 IF (.NOT.(I .NE. 1)) GOTO 4480 GOTO 4450 4480 CONTINUE INFILE(LEVEL) = 5 CALL SCOPY(STDINN, 1, FNAMES, 1) GOTO 4470 4460 CONTINUE IF (.NOT.(FILE(1) .EQ. 63 .AND. FILE(2) .EQ. 0)) GOTO 4500 CALL REMARK('usage: macro [file ...].') GOTO 4470 4500 CONTINUE IF (.NOT.(FILE(1) .EQ. 45 .AND. FILE(2) .EQ. 0)) GOTO 4520 INFILE(LEVEL) = 5 CALL SCOPY(STDINN, 1, FNAMES, 1) GOTO 4470 4520 CONTINUE INFILE(LEVEL) = OPEN(FILE, 'R') CALL SCOPY(FILE, 1, FNAMES, 1) IF (.NOT.(INFILE(LEVEL) .EQ. -1)) GOTO 4540 CALL CANT(FILE) 4540 CONTINUE 4470 CONTINUE 4560 IF (.NOT.(DEFTOK(TOKEN, 201) .NE. -10)) GOTO 4570 IF (.NOT.(TOKEN(1) .EQ. 96)) GOTO 4580 J = 2 4600 CONTINUE IF (.NOT.(TOKEN(J) .EQ. 96)) GOTO 4630 IF (.NOT.(TOKEN(J+1) .EQ. 96)) GOTO 4650 J = J + 1 GOTO 4660 4650 CONTINUE GOTO 4620 4660 CONTINUE 4630 CONTINUE CALL PUTCH(TOKEN(J), 2) 4610 J = J + 1 GOTO 4600 4620 CONTINUE GOTO 4590 4580 CONTINUE CALL PUTLIN(TOKEN, 2) 4590 CONTINUE GOTO 4560 4570 CONTINUE 4440 I = I + 1 GOTO 4430 4450 CONTINUE CALL ENDR4 END C ARCHIVE NGETCH.RAT 32 1-DEC-81 09:42:51 C ngetch - get a (possibly pushed back) character BYTE FUNCTION NGETCH(C) BYTE C INTEGER I, GETLIN C---------------------------------------------------------------------- C preprocessor common block to hold input characters C Put on a file called 'cdefio' C Used by ratfiv preprocessor and macro COMMON/CDEFIO/BP, BPLOW, BPSAVE(4), BUF(900) C next available character; init = 0 INTEGER BP C bottom of push-back buffer at current file level INTEGER BPLOW C holds bplow for active file levels INTEGER BPSAVE C pushed-back characters BYTE BUF C----------------------------------------------------------------------- C preprocessor common block to hold info about lines and included files C put on a file named 'cline' C used by ratfiv preproccessor and macro COMMON/CLINE/LEVEL, INFILE(4), LINECT(4), FNAMP(4), FNAMES(136), I *OIN(134) C level of file inclusion; init = 1 INTEGER LEVEL C file number(level); init infile(1) = STDIN INTEGER INFILE C line count on input file(level); init = 1 INTEGER LINECT C next free slot in fnames INTEGER FNAMP C stack of open file names BYTE FNAMES C input buffer BYTE IOIN 4670 CONTINUE IF (.NOT.(BP .LE. BPLOW)) GOTO 4700 I = GETLIN(IOIN, INFILE(LEVEL)) IF (.NOT.(I .EQ. -10)) GOTO 4720 C = - 10 NGETCH = (C) RETURN 4720 CONTINUE LINECT(LEVEL) = LINECT(LEVEL) + 1 4740 CONTINUE C push ioin on pushback buffer BP = BP + 1 BUF(BP) = IOIN(I) I = I - 1 4750 IF (.NOT.(I .EQ. 0)) GOTO 4740 4700 CONTINUE C = BUF(BP) BP = BP - 1 IF (.NOT.(C .EQ. 95)) GOTO 4770 IF (.NOT.(BP .GT. BPLOW)) GOTO 4790 IF (.NOT.(BUF(BP) .EQ. 10)) GOTO 4810 BP = BP - 1 GOTO 4680 4810 CONTINUE 4790 CONTINUE 4770 CONTINUE NGETCH = (C) RETURN 4680 GOTO 4670 END C ARCHIVE NOEVAL.RAT 9 30-NOV-81 14:32:14 C noeval - check if macro arguments should be evaluated now INTEGER FUNCTION NOEVAL(CP, AP, CALLST, ARGSTK) INTEGER CP, AP, CALLST(1), ARGSTK(1), ISSET NOEVAL = 0 IF (.NOT.(CP .NE. 0)) GOTO 4830 NOEVAL = ISSET(ARGSTK(CALLST(CP)), AP - CALLST(CP) - 3) 4830 CONTINUE RETURN END C ARCHIVE PBNUM.RAT 9 30-NOV-81 14:32:14 C pbnum - convert number to string, push back on input SUBROUTINE PBNUM(N) INTEGER N, I, ITOC BYTE STR(7) I = ITOC(N, STR, 7) CALL PBSTR(STR) RETURN END C ARCHIVE PBSTR.RAT 10 30-NOV-81 14:32:14 C pbstr - push string back onto input SUBROUTINE PBSTR(IN) BYTE IN(1) INTEGER LENGTH INTEGER I I = LENGTH(IN) 4850 IF (.NOT.(I .GT. 0)) GOTO 4870 CALL PUTBAK(IN(I)) 4860 I = I - 1 GOTO 4850 4870 CONTINUE RETURN END C ARCHIVE PUSH.RAT 10 30-NOV-81 14:32:15 C push - push ep onto argstk, return new pointer ap /*/sor/macror/push INTEGER FUNCTION PUSH(EP, ARGSTK, AP) INTEGER AP, ARGSTK(120), EP IF (.NOT.(AP .GT. 120)) GOTO 4880 CALL FATAL('argument stack overflow.') 4880 CONTINUE ARGSTK(AP) = EP PUSH = AP + 1 RETURN END C ARCHIVE PUTBAK.RAT 11 1-DEC-81 09:29:28 C putbak - push character back onto input SUBROUTINE PUTBAK(C) BYTE C C---------------------------------------------------------------------- C preprocessor common block to hold input characters C Put on a file called 'cdefio' C Used by ratfiv preprocessor and macro COMMON/CDEFIO/BP, BPLOW, BPSAVE(4), BUF(900) C next available character; init = 0 INTEGER BP C bottom of push-back buffer at current file level INTEGER BPLOW C holds bplow for active file levels INTEGER BPSAVE C pushed-back characters BYTE BUF BP = BP + 1 IF (.NOT.(BP .GT. 900)) GOTO 4900 CALL FATAL('too many characters pushed back.') 4900 CONTINUE BUF(BP) = C RETURN END C ARCHIVE PUTCHR.RAT 11 30-NOV-81 14:32:15 C putchr - put single char into eval stack SUBROUTINE PUTCHR(C) BYTE C C -cmacro- common block C put on a file called 'cmacro' C Used only by the macro tool COMMON/CMACRO/CP, EP, EVALST(500), DEFCNT, DEFSTK(20), AP, ARGSTK( *120), CALLST(30), PLEV(30) C current call stack pointer INTEGER CP C next free position in evalst INTEGER EP C evaluation stack BYTE EVALST C depth of _ifdef nesting LOGICAL DEFCNT C remembers status of _ifdef levels LOGICAL DEFSTK C pointer to next available space in argstk INTEGER AP C pointers to evalst INTEGER ARGSTK C points to invocation frames in argstk INTEGER CALLST C parenthesis level at current invocation frame INTEGER PLEV IF (.NOT.(EP .GT. 500)) GOTO 4920 CALL FATAL('evaluation stack overflow.') 4920 CONTINUE EVALST(EP) = C EP = EP + 1 RETURN END C ARCHIVE PUTTOK.RAT 9 3-DEC-81 09:35:40 C puttok - put token into eval stack SUBROUTINE PUTTOK(STR) BYTE STR(201) INTEGER I I = 1 4940 IF (.NOT.(STR(I) .NE. 0)) GOTO 4960 CALL PUTCHR(STR(I)) 4950 I = I + 1 GOTO 4940 4960 CONTINUE RETURN END C ARCHIVE SET.RAT 11 30-NOV-81 14:32:15 C set - return flags with bit n set INTEGER FUNCTION SET(FLAGS, N) INTEGER FLAGS, N INTEGER BITMSK(12), ISSET DATA BITMSK/1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024, 2048/ SET = FLAGS IF (.NOT.(ISSET(FLAGS, N) .NE. 1)) GOTO 4970 SET = FLAGS + BITMSK(N + 1) 4970 CONTINUE RETURN END C ARCHIVE SETINT.RAT 8 30-NOV-81 14:32:16 C setint - put an integer into table SUBROUTINE SETINT(TABLE, VAL) BYTE TABLE(2), VAL(2) DO 4990 I = 1, 2 TABLE(I) = VAL(I) 4990 CONTINUE RETURN END C ARCHIVE SYN2.RAT 24 30-NOV-81 14:32:16 C syn2 - report Ratfiv syntax error SUBROUTINE SYN2(MSG, F) BYTE LC(7), MSG(1) INTEGER ITOC INTEGER I, JUNK, F C----------------------------------------------------------------------- C preprocessor common block to hold info about lines and included files C put on a file named 'cline' C used by ratfiv preproccessor and macro COMMON/CLINE/LEVEL, INFILE(4), LINECT(4), FNAMP(4), FNAMES(136), I *OIN(134) C level of file inclusion; init = 1 INTEGER LEVEL C file number(level); init infile(1) = STDIN INTEGER INFILE C line count on input file(level); init = 1 INTEGER LINECT C next free slot in fnames INTEGER FNAMP C stack of open file names BYTE FNAMES C input buffer BYTE IOIN BYTE SERROR(17) BYTE IN(5) DATA SERROR(1)/63/,SERROR(2)/32/,SERROR(3)/101/,SERROR(4)/114/,SER *ROR(5)/114/,SERROR(6)/111/,SERROR(7)/114/,SERROR(8)/32/,SERROR(9)/ *97/,SERROR(10)/116/,SERROR(11)/32/,SERROR(12)/108/,SERROR(13)/105/ *,SERROR(14)/110/,SERROR(15)/101/,SERROR(16)/32/,SERROR(17)/0/ DATA IN(1)/32/,IN(2)/105/,IN(3)/110/,IN(4)/32/,IN(5)/0/ CALL PUTLIN(SERROR, F) IF (.NOT.(LEVEL .GE. 1)) GOTO 5010 I = LEVEL GOTO 5020 5010 CONTINUE C for EOF errors I = 1 5020 CONTINUE JUNK = ITOC(LINECT(I), LC, 7) CALL PUTLIN(LC, F) CALL PUTLIN(IN, F) CALL PUTLIN(FNAMES(FNAMP(I)), F) CALL PUTCH(58, F) CALL PUTCH(32, F) CALL PUTLIN(MSG, F) CALL PUTCH(10, F) RETURN END C ARCHIVE SYNERR.RAT 13 30-NOV-81 14:32:16 C synerr - report ratfiv syntax error SUBROUTINE SYNERR(MSG) BYTE MSG(1) C cerrbf - holds an error message for later output by synerr COMMON/CERRBF/ERRBUF(201) BYTE ERRBUF CALL XITSTA(3) CALL PUTLIN(ERRBUF, 3) CALL SYN2(MSG, 3) CALL PUTLIN(ERRBUF, 2) CALL SYN2(MSG, 2) ERRBUF(1) = 0 RETURN END C ARCHIVE UNDEF.RAT 33 30-NOV-81 14:32:16 C undef - undefine a macro and garbage collect SUBROUTINE UNDEF(NAME) BYTE NAME(201), C INTEGER I, J, K, KNEXT, L, DEFLEN, LOCDEF, LENGTH, GETINT C-------------------------------------------------------------------- C# preprocessor common block to hold definitions C put on a file named 'clook' C Used by ratfiv preprocessor, macro, and form tools COMMON/CLOOK/AVAIL, TABPTR(127), TABLE(10001) 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 5030 IF (.NOT.(TABPTR(C) .EQ. I)) GOTO 5050 TABPTR(C) = GETINT(TABLE(I)) GOTO 5060 5050 CONTINUE K = TABPTR(C) 5070 IF (.NOT.(GETINT(TABLE(K)) .NE. I)) GOTO 5090 5080 K = GETINT(TABLE(K)) GOTO 5070 5090 CONTINUE CALL SETINT(TABLE(K), GETINT(TABLE(I))) 5060 CONTINUE J = J + LENGTH(TABLE(J)) + 1 DEFLEN = J - I DO 5100 L = 1, 127 IF (.NOT.(TABPTR(L) .GT. I)) GOTO 5120 K = TABPTR(L) TABPTR(L) = TABPTR(L) - DEFLEN 5140 IF (.NOT.(GETINT(TABLE(K)) .GT. I)) GOTO 5160 KNEXT = GETINT(TABLE(K)) CALL SETINT(TABLE(K), KNEXT - DEFLEN) 5150 K = KNEXT GOTO 5140 5160 CONTINUE 5120 CONTINUE 5100 CONTINUE 5170 IF (.NOT.(J .LT. AVAIL)) GOTO 5190 TABLE(I) = TABLE(J) I = I + 1 5180 J = J + 1 GOTO 5170 5190 CONTINUE AVAIL = I 5030 CONTINUE RETURN END