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 3-MAR-82 00:04:15 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.1 C C Date: March 3, 1982 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 44 3-MAR-82 00:06:42 C argtyp - return flags for argument types in defn C - caution this routine modifies defn!!! INTEGER FUNCTION ARGTYP(DEFN) BYTE DEFN(1) INTEGER ATYPE, I, J, N, FOUND(10), SET, INDEXX, 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 = INDEXX(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 134 3-FEB-82 11:26:59 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 .OR. BP .GT. BPLOW)) GOTO 2240 DEFTOK = GTOKEN(TOKEN, TOKSIZ) 2250 IF (.NOT.(DEFTOK .NE. -10)) GOTO 2270 IF (.NOT.(DEFTOK .EQ. 1)) GOTO 2280 IF (.NOT.(LOOKUP(TOKEN, DEFN, ARGTY) .EQ. 0)) GOTO 2300 IF (.NOT.(CP .EQ. 0)) GOTO 2320 IF (.NOT.(DEFSTK(DEFCNT))) GOTO 2340 RETURN 2340 CONTINUE GOTO 2330 2320 CONTINUE CALL PUTTOK(TOKEN) 2330 CONTINUE GOTO 2310 2300 CONTINUE IF (.NOT.(NOEVAL(CP, AP, CALLST, ARGSTK) .EQ. 1)) GOTO 2360 CALL PUTTOK(TOKEN) GOTO 2310 2360 CONTINUE C defined; put it in eval stack CP = CP + 1 IF (.NOT.(CP .GT. 30)) GOTO 2380 CALL FATAL('call stack overflow.') 2380 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 2400 J = 0 2420 CONTINUE C peek at next DEFTOK = GTOKEN(TOKEN, TOKSIZ) J = J + 1 2430 IF (.NOT.(DEFTOK .NE. 32)) GOTO 2420 CALL PBSTR(TOKEN) IF (.NOT.(DEFTOK .NE. 40)) GOTO 2450 C add ( ) if not present 2470 IF (.NOT.(J .GT. 1)) GOTO 2490 CALL PUTBAK(32) 2480 J = J - 1 GOTO 2470 2490 CONTINUE CALL PBSTR(BALP) 2450 CONTINUE GOTO 2410 2400 CONTINUE CALL PBSTR(BALP) 2410 CONTINUE PLEV(CP) = 0 2310 CONTINUE GOTO 2290 2280 CONTINUE IF (.NOT.(CP .EQ. 0)) GOTO 2500 C not in a macro at all IF (.NOT.(DEFSTK(DEFCNT))) GOTO 2520 RETURN 2520 CONTINUE GOTO 2290 2500 CONTINUE IF (.NOT.(DEFTOK .EQ. 40)) GOTO 2540 IF (.NOT.(PLEV(CP) .GT. 0)) GOTO 2560 CALL PUTTOK(TOKEN) 2560 CONTINUE PLEV(CP) = PLEV(CP) + 1 GOTO 2290 2540 CONTINUE IF (.NOT.(DEFTOK .EQ. 41)) GOTO 2580 PLEV(CP) = PLEV(CP) - 1 IF (.NOT.(PLEV(CP) .GT. 0)) GOTO 2600 CALL PUTTOK(TOKEN) GOTO 2610 2600 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 2610 CONTINUE GOTO 2290 2580 CONTINUE IF (.NOT.(DEFTOK .EQ. 44 .AND. PLEV(CP) .EQ. 1)) GOTO 2620 C new argument IF (.NOT.(ISSET(ARGSTK(CALLST(CP)), 11) .EQ. 1)) GOTO 2640 C allow commas in argument CALL PUTTOK(TOKEN) GOTO 2650 2640 CONTINUE CALL PUTCHR(0) IF (.NOT.(AP-CALLST(CP)-3 .GE. 9)) GOTO 2660 CALL SYNERR('too many arguments passed to a macro.') GOTO 2670 2660 CONTINUE AP = PUSH(EP, ARGSTK, AP) 2670 CONTINUE 2650 CONTINUE GOTO 2290 2620 CONTINUE C just stack it CALL PUTTOK(TOKEN) 2290 CONTINUE 2260 DEFTOK = GTOKEN(TOKEN, TOKSIZ) GOTO 2250 2270 CONTINUE IF (.NOT.(LEVEL .GT. 0)) GOTO 2680 IF (.NOT.(INFILE(LEVEL) .NE. 5)) GOTO 2700 C here on EOF; pop back to last file CALL CLOSE(INFILE(LEVEL)) 2700 CONTINUE C restore bottom of push-back buffer BPLOW = BPSAVE(LEVEL) LEVEL = LEVEL - 1 2680 CONTINUE GOTO 2230 2240 CONTINUE IF (.NOT.(CP .NE. 0 .OR. DEFCNT .GT. 1)) GOTO 2720 CALL SYNERR('unexpected EOF.') 2720 CONTINUE C in case called at EOF 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 2740 A = ARGSTK(IARGS + 1) OP1 = CTOI(EVALST, A) K = 2 2760 IF (.NOT.(K+1 .LE. NARGS)) GOTO 2780 OP = EVALST(ARGSTK(IARGS + K)) A = ARGSTK(IARGS + K + 1) OP2 = CTOI(EVALST, A) IF (.NOT.(OP .EQ. 43)) GOTO 2790 OP1 = OP1 + OP2 GOTO 2800 2790 CONTINUE IF (.NOT.(OP .EQ. 45)) GOTO 2810 OP1 = OP1 - OP2 GOTO 2800 2810 CONTINUE IF (.NOT.(OP .EQ. 42)) GOTO 2830 OP1 = OP1*OP2 GOTO 2800 2830 CONTINUE IF (.NOT.(OP .EQ. 47 .AND. OP2 .NE. 0)) GOTO 2850 OP1 = OP1/OP2 GOTO 2800 2850 CONTINUE CALL SYNERR('arith error.') 2800 CONTINUE 2770 K = K + 2 GOTO 2760 2780 CONTINUE 2740 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 2870 A1 = ARGSTK(IARGS + 1) I = 0 2890 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 2920 CALL ERRLIN(EVALST(A1)) CALL SYNERR('illegal macro name.') GOTO 10 2920 CONTINUE I = I + 1 2900 IF (.NOT.(EVALST(A1+I) .EQ. 44 .OR. EVALST(A1+I) .EQ. 0)) GOTO 2 *890 IF (.NOT.(EVALST(A1+I) .NE. 0)) GOTO 2940 EVALST(A1 + I) = 0 CALL INSTAL(EVALST(A1), EVALST(A1 + I + 1), ARGTYP(EVALST(A1 + * I + 1))) GOTO 2950 2940 CONTINUE CALL INSTAL(EVALST(A1), 0, 0) 2950 CONTINUE 2870 CONTINUE 10 IF (.NOT.(NGETCH(C) .NE. 10)) GOTO 2960 CALL PUTBAK(C) 2960 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 2980 CALL SYNERR('bad _elsedef.') GOTO 2990 2980 CONTINUE DEFSTK(DEFCNT) = DEFSTK(DEFCNT - 1) .AND. .NOT.DEFSTK(DEFCNT) 2990 CONTINUE IF (.NOT.(NGETCH(C) .NE. 10)) GOTO 3000 CALL PUTBAK(C) 3000 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 3020 CALL SYNERR('bad _enddef.') GOTO 3030 3020 CONTINUE DEFCNT = DEFCNT - 1 3030 CONTINUE IF (.NOT.(NGETCH(C) .NE. 10)) GOTO 3040 CALL PUTBAK(C) 3040 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 3060 RETURN 3060 CONTINUE IF (.NOT.(EQUAL(EVALST(ARGSTK(IARGS+1)), EVALST(ARGSTK(IARGS+2))) *.EQ. 1)) GOTO 3080 C subarrays CALL PBSTR(EVALST(ARGSTK(IARGS + 3))) GOTO 3090 3080 CONTINUE IF (.NOT.(NARGS .GE. 4)) GOTO 3100 CALL PBSTR(EVALST(ARGSTK(IARGS + 4))) 3100 CONTINUE 3090 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 3120 CALL FATAL('_ifdefs nested too deeply.') 3120 CONTINUE DEFSTK(DEFCNT) = DEFSTK(DEFCNT - 1) IF (.NOT.(DEFSTK(DEFCNT))) GOTO 3140 IF (.NOT.(NARGS .GT. 0)) GOTO 3160 IF (.NOT.(LOCDEF(EVALST(ARGSTK(IARGS+1)), JUNK1, JUNK2, C) .NE *. 1)) GOTO 3180 DEFSTK(DEFCNT) = .FALSE. 3180 CONTINUE 3160 CONTINUE 3140 CONTINUE IF (.NOT.(NGETCH(C) .NE. 10)) GOTO 3200 CALL PUTBAK(C) 3200 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 3220 CALL PUTBAK(C) 3220 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 3240 K = ARGSTK(IARGS + 1) CALL PBNUM(CTOI(EVALST, K) + 1) 3240 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 INDEXX 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 3260 CALL PBNUM(0) GOTO 3270 3260 CONTINUE IF (.NOT.(NARGS .GE. 2)) GOTO 3280 CALL PBNUM(INDEXX(EVALST(ARGSTK(IARGS + 1)), EVALST(ARGSTK(IARGS * + 2)))) 3280 CONTINUE 3270 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 3300 CALL PBNUM(0) GOTO 3310 3300 CONTINUE CALL PBNUM(LENGTH(EVALST(ARGSTK(IARGS + 1)))) 3310 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 3320 RETURN 3320 CONTINUE IF (.NOT.(NARGS .EQ. 1)) GOTO 3340 BS = 1 GOTO 3350 3340 CONTINUE K = ARGSTK(IARGS + 2) BS = CTOI(EVALST, K) 3350 CONTINUE IF (.NOT.(NARGS .LE. 2)) GOTO 3360 NC = 32767 GOTO 3370 3360 CONTINUE K = ARGSTK(IARGS + 3) C number of characters NC = CTOI(EVALST, K) 3370 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 * 3380 C subarrays K = FC + MIN0(NC, LENGTH(EVALST(FC))) - 1 3400 IF (.NOT.(K .GE. FC)) GOTO 3420 CALL PUTBAK(EVALST(K)) 3410 K = K - 1 GOTO 3400 3420 CONTINUE 3380 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, INDEXX 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 3430 A1 = ARGSTK(IARGS + 1) I = INDEXX(EVALST(A1), 44) IF (.NOT.(I .NE. 0)) GOTO 3450 EVALST(A1 + I - 1) = 0 3450 CONTINUE CALL UNDEF(EVALST(A1)) 3430 CONTINUE IF (.NOT.(NGETCH(C) .NE. 10)) GOTO 3470 CALL PUTBAK(C) 3470 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 3490 IF (.NOT.(I .LT. 201 .AND. MESS(I-J) .NE. 0)) GOTO 3510 ERRBUF(I) = MESS(I - J) 3500 I = I + 1 GOTO 3490 3510 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 INDEXX, 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 3520 IF (.NOT.(TD .EQ. -27)) GOTO 3540 CALL DOIFD(IARGS, NARGS) GOTO 3550 3540 CONTINUE IF (.NOT.(TD .EQ. -28)) GOTO 3560 CALL DOELSD GOTO 3550 3560 CONTINUE IF (.NOT.(TD .EQ. -29)) GOTO 3580 CALL DOENDD GOTO 3550 3580 CONTINUE IF (.NOT.(TD .EQ. -22)) GOTO 3600 CALL DOINCR(IARGS, NARGS) GOTO 3550 3600 CONTINUE IF (.NOT.(TD .EQ. -23)) GOTO 3620 CALL DOSUB(IARGS, NARGS) GOTO 3550 3620 CONTINUE IF (.NOT.(TD .EQ. -21)) GOTO 3640 CALL DOIF(IARGS, NARGS) GOTO 3550 3640 CONTINUE IF (.NOT.(TD .EQ. -24)) GOTO 3660 CALL DOARTH(IARGS, NARGS) GOTO 3550 3660 CONTINUE IF (.NOT.(TD .EQ. -25)) GOTO 3680 CALL DOLEN(IARGS, NARGS) GOTO 3550 3680 CONTINUE IF (.NOT.(TD .EQ. -26)) GOTO 3700 CALL DOIND(IARGS, NARGS) GOTO 3550 3700 CONTINUE IF (.NOT.(TD .EQ. -30)) GOTO 3720 IF (.NOT.(DEFSTK(DEFCNT))) GOTO 3740 CALL DOINCL(IARGS, NARGS) 3740 CONTINUE GOTO 3550 3720 CONTINUE IF (.NOT.(TD .EQ. -20)) GOTO 3760 IF (.NOT.(DEFSTK(DEFCNT))) GOTO 3780 CALL DODEF(IARGS, NARGS) 3780 CONTINUE GOTO 3550 3760 CONTINUE IF (.NOT.(TD .EQ. -31)) GOTO 3800 IF (.NOT.(DEFSTK(DEFCNT))) GOTO 3820 CALL DOUND(IARGS, NARGS) 3820 CONTINUE C just pass it along GOTO 3550 3800 CONTINUE CALL PUTBAK(EVALST(T)) 3550 CONTINUE GOTO 3530 3520 CONTINUE K = T + LENGTH(EVALST(T)) - 1 3840 IF (.NOT.(K .GT. T)) GOTO 3860 IF (.NOT.(EVALST(K-1) .NE. 36)) GOTO 3870 CALL PUTBAK(EVALST(K)) GOTO 3880 3870 CONTINUE ARGNO = INDEXX(DIGITS, EVALST(K)) - 1 IF (.NOT.(ARGNO .GE. 0 .AND. ARGNO .LE. NARGS)) GOTO 3890 CALL PBSTR(EVALST(ARGSTK(IARGS + ARGNO))) C skip over $ K = K - 1 GOTO 3900 3890 CONTINUE IF (.NOT.(ARGNO .EQ. -1)) GOTO 3910 C wasn't a digit CALL PUTBAK(EVALST(K)) GOTO 3900 3910 CONTINUE C skip over $ K = K - 1 3900 CONTINUE 3880 CONTINUE 3850 K = K - 1 GOTO 3840 3860 CONTINUE IF (.NOT.(K .EQ. T)) GOTO 3930 C do last character CALL PUTBAK(EVALST(K)) 3930 CONTINUE 3530 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 3950 J = 1, 2 C(J) = TABLE(J) 3950 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 3970 IF (.NOT.(I .LT. TOKSIZ)) GOTO 3990 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 4000 GOTO 3990 4000 CONTINUE 3980 I = I + 1 GOTO 3970 3990 CONTINUE IF (.NOT.(TOKEN(1) .EQ. 96)) GOTO 4020 C leave stuff in here alone I = 2 4040 IF (.NOT.(I .LT. TOKSIZ)) GOTO 4060 IF (.NOT.(NGETCH(TOKEN(I)) .EQ. 96)) GOTO 4070 IF (.NOT.(NGETCH(TOKEN(I+1)) .NE. 96)) GOTO 4090 CALL PUTBAK(TOKEN(I + 1)) GOTO 4060 4090 CONTINUE I = I + 1 4100 CONTINUE GOTO 4080 4070 CONTINUE IF (.NOT.(TOKEN(I) .EQ. -10)) GOTO 4110 CALL SYNERR('EOF in literal string.') CALL PUTBAK( - 10) TOKEN(I) = 96 GOTO 4060 4110 CONTINUE 4080 CONTINUE 4050 I = I + 1 GOTO 4040 4060 CONTINUE 4020 CONTINUE IF (.NOT.(I .GE. TOKSIZ)) GOTO 4130 CALL FATAL('token too long.') 4130 CONTINUE IF (.NOT.(I .GT. 1 .AND. TOKEN(1) .NE. 96)) GOTO 4150 C some alpha was seen CALL PUTBAK(TOKEN(I)) I = I - 1 GTOKEN = 1 C else single character token 4150 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 4170 CALL SYNERR('includes nested too deeply.') GOTO 4180 4170 CONTINUE INFILE(LEVEL + 1) = OPEN(FILE, 'R') IF (.NOT.(INFILE(LEVEL+1) .EQ. -1)) GOTO 4190 CALL ERRLIN(FILE) CALL SYNERR('can''t open included file.') GOTO 4200 4190 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 4200 CONTINUE 4180 CONTINUE RETURN END C ARCHIVE INIMAC.RAT 82 3-MAR-82 00:02:51 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 IFNOTN(10) BYTE IFNOTD(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 IFNOTN(1)/95/,IFNOTN(2)/105/,IFNOTN(3)/102/,IFNOTN(4)/110/,IF *NOTN(5)/111/,IFNOTN(6)/116/,IFNOTN(7)/100/,IFNOTN(8)/101/,IFNOTN(9 *)/102/,IFNOTN(10)/0/ DATA IFNOTD(1)/95/,IFNOTD(2)/105/,IFNOTD(3)/102/,IFNOTD(4)/100/,IF *NOTD(5)/101/,IFNOTD(6)/102/,IFNOTD(7)/40/,IFNOTD(8)/37/,IFNOTD(9)/ *49/,IFNOTD(10)/41/,IFNOTD(11)/95/,IFNOTD(12)/101/,IFNOTD(13)/108/, *IFNOTD(14)/115/,IFNOTD(15)/101/,IFNOTD(16)/100/,IFNOTD(17)/101/,IF *NOTD(18)/102/,IFNOTD(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 4210 IF (.NOT.(I .LE. 127)) GOTO 4230 TABPTR(I) = 0 4220 I = I + 1 GOTO 4210 4230 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(IFNOTN, IFNOTD, ARGTYP(IFNOTD)) 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 4240 NLEN = LENGTH(NAME) + 1 DLEN = LENGTH(DEFN) + 1 IF (.NOT.(DLEN .GT. 500)) GOTO 4260 CALL ERRLIN(NAME) CALL SYNERR('definition too long.') RETURN 4260 CONTINUE IF (.NOT.(AVAIL+NLEN+DLEN+2*2 .GT. 10001+1)) GOTO 4280 CALL ERRLIN(NAME) CALL FATAL('too many definitions.') RETURN 4280 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 4240 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 4300 ISSET = 1 4300 CONTINUE RETURN END C ARCHIVE LOCDEF.RAT 23 3-FEB-82 23:24:23 C locdef - locate name INTEGER FUNCTION LOCDEF(NAME, I, J, C) BYTE NAME(201), C INTEGER I, J, K 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 4320 C = NAME(1) I = TABPTR(C) 4340 IF (.NOT.(I .GT. 0)) GOTO 4360 J = I + 2*2 K = 1 4370 IF (.NOT.(NAME(K) .EQ. TABLE(J) .AND. NAME(K) .NE. 0)) GOTO 43 *90 J = J + 1 4380 K = K + 1 GOTO 4370 4390 CONTINUE IF (.NOT.(NAME(K) .EQ. TABLE(J))) GOTO 4400 C got one J = J + 1 LOCDEF = 1 RETURN 4400 CONTINUE 4350 I = GETINT(TABLE(I)) GOTO 4340 4360 CONTINUE 4320 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 4420 CALL SCOPY(TABLE, J, DEFN, 1) FLAG = GETINT(TABLE(I + 2)) 4420 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 4440 CONTINUE FNAMP(1) = 1 LEVEL = 1 LINECT(1) = 0 IF (.NOT.(GETARG(I, FILE, 134) .EQ. -10)) GOTO 4470 IF (.NOT.(I .NE. 1)) GOTO 4490 GOTO 4460 4490 CONTINUE INFILE(LEVEL) = 5 CALL SCOPY(STDINN, 1, FNAMES, 1) GOTO 4480 4470 CONTINUE IF (.NOT.(FILE(1) .EQ. 63 .AND. FILE(2) .EQ. 0)) GOTO 4510 CALL REMARK('usage: macro [file ...].') GOTO 4480 4510 CONTINUE IF (.NOT.(FILE(1) .EQ. 45 .AND. FILE(2) .EQ. 0)) GOTO 4530 INFILE(LEVEL) = 5 CALL SCOPY(STDINN, 1, FNAMES, 1) GOTO 4480 4530 CONTINUE INFILE(LEVEL) = OPEN(FILE, 'R') CALL SCOPY(FILE, 1, FNAMES, 1) IF (.NOT.(INFILE(LEVEL) .EQ. -1)) GOTO 4550 CALL CANT(FILE) 4550 CONTINUE 4480 CONTINUE 4570 IF (.NOT.(DEFTOK(TOKEN, 201) .NE. -10)) GOTO 4580 IF (.NOT.(TOKEN(1) .EQ. 96)) GOTO 4590 J = 2 4610 CONTINUE IF (.NOT.(TOKEN(J) .EQ. 96)) GOTO 4640 IF (.NOT.(TOKEN(J+1) .EQ. 96)) GOTO 4660 J = J + 1 GOTO 4670 4660 CONTINUE GOTO 4630 4670 CONTINUE 4640 CONTINUE CALL PUTCH(TOKEN(J), 2) 4620 J = J + 1 GOTO 4610 4630 CONTINUE GOTO 4600 4590 CONTINUE CALL PUTLIN(TOKEN, 2) 4600 CONTINUE GOTO 4570 4580 CONTINUE 4450 I = I + 1 GOTO 4440 4460 CONTINUE CALL ENDR4 END C ARCHIVE NGETCH.RAT 35 3-FEB-82 13:22:38 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 4680 CONTINUE IF (.NOT.(BP .LE. BPLOW)) GOTO 4710 IF (.NOT.(LEVEL .GT. 0)) GOTO 4730 I = GETLIN(IOIN, INFILE(LEVEL)) GOTO 4740 4730 CONTINUE I = - 10 4740 CONTINUE IF (.NOT.(I .EQ. -10)) GOTO 4750 C = - 10 NGETCH = (C) RETURN 4750 CONTINUE LINECT(LEVEL) = LINECT(LEVEL) + 1 4770 CONTINUE C push ioin on pushback buffer BP = BP + 1 BUF(BP) = IOIN(I) I = I - 1 4780 IF (.NOT.(I .EQ. 0)) GOTO 4770 4710 CONTINUE C = BUF(BP) BP = BP - 1 IF (.NOT.(C .EQ. 95)) GOTO 4800 IF (.NOT.(BP .GT. BPLOW)) GOTO 4820 IF (.NOT.(BUF(BP) .EQ. 10)) GOTO 4840 BP = BP - 1 GOTO 4690 4840 CONTINUE 4820 CONTINUE 4800 CONTINUE NGETCH = (C) RETURN 4690 GOTO 4680 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 4860 NOEVAL = ISSET(ARGSTK(CALLST(CP)), AP - CALLST(CP) - 3) 4860 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) 4880 IF (.NOT.(I .GT. 0)) GOTO 4900 CALL PUTBAK(IN(I)) 4890 I = I - 1 GOTO 4880 4900 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 4910 CALL FATAL('argument stack overflow.') 4910 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 4930 CALL FATAL('too many characters pushed back.') 4930 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 4950 CALL FATAL('evaluation stack overflow.') 4950 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 4970 IF (.NOT.(STR(I) .NE. 0)) GOTO 4990 CALL PUTCHR(STR(I)) 4980 I = I + 1 GOTO 4970 4990 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 5000 SET = FLAGS + BITMSK(N + 1) 5000 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 5020 I = 1, 2 TABLE(I) = VAL(I) 5020 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 5040 I = LEVEL GOTO 5050 5040 CONTINUE C for EOF errors I = 1 5050 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 5060 IF (.NOT.(TABPTR(C) .EQ. I)) GOTO 5080 TABPTR(C) = GETINT(TABLE(I)) GOTO 5090 5080 CONTINUE K = TABPTR(C) 5100 IF (.NOT.(GETINT(TABLE(K)) .NE. I)) GOTO 5120 5110 K = GETINT(TABLE(K)) GOTO 5100 5120 CONTINUE CALL SETINT(TABLE(K), GETINT(TABLE(I))) 5090 CONTINUE J = J + LENGTH(TABLE(J)) + 1 DEFLEN = J - I DO 5130 L = 1, 127 IF (.NOT.(TABPTR(L) .GT. I)) GOTO 5150 K = TABPTR(L) TABPTR(L) = TABPTR(L) - DEFLEN 5170 IF (.NOT.(GETINT(TABLE(K)) .GT. I)) GOTO 5190 KNEXT = GETINT(TABLE(K)) CALL SETINT(TABLE(K), KNEXT - DEFLEN) 5180 K = KNEXT GOTO 5170 5190 CONTINUE 5150 CONTINUE 5130 CONTINUE 5200 IF (.NOT.(J .LT. AVAIL)) GOTO 5220 TABLE(I) = TABLE(J) I = I + 1 5210 J = J + 1 GOTO 5200 5220 CONTINUE AVAIL = I 5060 CONTINUE RETURN END