Trailing-Edge
-
PDP-10 Archives
-
decuslib20-02
-
decus/20-0057/execph.sno
There are 2 other files named execph.sno in the archive. Click here to see a list.
* * * * * * * * *
* * DECLARATIONS * * * * *
* * * * * * * * *
*
* LOCAL
*
DECLARE('SNOBOL.SUBPROGRAM','EXECPH')
DECLARE('OPTION','NO.STNO')
DECLARE('PURGE.VARIABLE',ALL)
DECLARE('PURGE.LABEL',ALL)
DECLARE('EXTERNAL.FUNCTION','GETSTA,PUTOUT,GETITM,ERRMSG,STXERR,
.NEWLAB,SUBS,PARLIT,GETATR,NEWNAM')
DECLARE('INTEGER','SW,I,J,NPAR,VARTYP,OBJTYP,RGL,LOPER,ROPER,
.OPER,TYPE,RSTFLG,MAXLVL,MODFLG,FAILFL,TML,LSGN,RTYP,RSGN,RTYPE,TP,
.DEDFLG')
DECLARE('ENTRY.FUNCTION','INIEXE()')
DECLARE('ENTRY.FUNCTION','EXECPH()VARCOD,PATCOD,OBJCOD,STACOD,
.GOTCOD,EVLCOD,STR1,STR2')
*
* SYSTEM COMMON
*
* TABLES AND LISTS
DECLARE('EXTERNAL.VARIABLE',
.'SYMBTB,XNAMTB,KEYWTB,CTRLTB,DECLTB,CROSTB,CONSTB,ENTFTB,DSIZTB,
.BOPRTB,UOPRTB')
DECLARE('EXTERNAL.VARIABLE',
.'ENTRLS,EXTRLS,FORTLS')
* ARRAYS
DECLARE('EXTERNAL.VARIABLE',
.'PTVRAR,PTFNAR,PRIMAR,GOTOAR,DECLAR,PROGAR,VARBAR,MACHAR,STENAR,BOPRAR,
.UOPRAR,PATRAR,EXPRAR,AROPAR,ARITAR,EACTAR')
* PARAMETERS (STRINGS,DATATYPES)
DECLARE('EXTERNAL.VARIABLE',
.'C,INDENT,SPLASH,ITNAM,ITENT,NOFAIL,SNONAM,SUBNAM,PARBLK,PRGNAM,STARTP,
.TEMLOC,P1,P2,P3,P4,P5')
* PARAMETERS (INTEGERS)
DECLARE('EXTERNAL.VARIABLE',
.'P,OBJFLG,LISTSR,INTGER,ITTYP,ITATR,PRGALV,PRGALL,PRGALF,STNFLG,HSHSIZ,
.STRTIM,DMPFLG,LISTOB,STNO,MAXTMP')
DECLARE('INTEGER',
.'P,OBJFLG,LISTSR,INTGER,ITTYP,ITATR,PRGALV,PRGALL,PRGALF,STNFLG,HSHSIZ,
.STRTIM,DMPFLG,LISTOB,STNO,MAXTMP')
DECLARE('EXTERNAL.VARIABLE',
.'XNATRB,VTATRB,VDATRB,LTATRB,FTATRB,FDATRB,TXATRB,VNATRB,VXATRB,VIATRB,
.VGATRB,LIATRB,LGATRB,FIATRB,FGATRB,FXATRB,SKATRB,SDATRB,BTATRB')
DECLARE('INTEGER',
.'XNATRB,VTATRB,VDATRB,LTATRB,FTATRB,FDATRB,TXATRB,VNATRB,VXATRB,VIATRB,
.VGATRB,LIATRB,LGATRB,FIATRB,FGATRB,FXATRB,SKATRB,SDATRB,BTATRB')
DECLARE('EXTERNAL.VARIABLE',
.'XNVATR,XNLATR,XNFATR,XNXMSK,VTVATR,VDDATR,VDPATR,VDDMSK,LTDATR,LTTMSK,
.FTFATR,FDPATR,FDIATR,FDDMSK,TXTATR,TXTMSK,VNNATR,VXXATR,VIPATR,VGGATR,
.LIPATR,LGGATR,FIPATR,FGGATR,FXXATR,FXXMSK,SKRATR,SDRATR,BTRATR')
DECLARE('INTEGER',
.'XNVATR,XNLATR,XNFATR,XNXMSK,VTVATR,VDDATR,VDPATR,VDDMSK,LTDATR,LTTMSK,
.FTFATR,FDPATR,FDIATR,FDDMSK,TXTATR,TXTMSK,VNNATR,VXXATR,VIPATR,VGGATR,
.LIPATR,LGGATR,FIPATR,FGGATR,FXXATR,FXXMSK,SKRATR,SDRATR,BTRATR')
* SPECIAL CHARACTERS,CHARACTER SEQUENCES, AND CHARACTER CLASSES
DECLARE('EXTERNAL.VARIABLE',
.'FFCHR,CRLCHR,LFCHR,CRCHR,SQCHR,DQCHR,TBCHR,LCSCHR,BLNCHR,EQLCHR,
.QTSCHR,ELTCHR,LBCHR')
* PATTERNS AND MATCHES
DECLARE('EXTERNAL.VARIABLE',
.'COMSPT,INTGPT,BLNKPT,OPBLPT,PCOMPT,PCPRMT,IDENPT,DCLCMT,RSIDPT,LABLPT,
.POPRMT,IDENMT,SQLTPT,DQLTPT,LBDCPT,IDDCPT')
*
* MINIMAL SYMBOL TABLE
*
DECLARE('UNPURGE.VARIABLE','INIEXE,EXECPH,VARCOD,PATCOD,OBJCOD,
.STACOD,GOTCOD,EVLCOD,STR1,STR2,PR.X,TP,ROPER,PR.U,PR.L,NOD,NPAR,DEFSTR,
.GETLIT,GETINT,MODFLG,GETREL,DEFLAB,GETLAB,DEFVAR,GETDVR,GETVAR,GTOPTY,
.I,GTPVAL,PUTTRE,G.EX,E.EX,RSTFLG,EVLCOD,V.EX,P.EX,TLAB1,TLAB2,P.VR,
.U.EX,FUNC,MAXLVL,FAILFL,S.EX,DEDVAR,S.PR,S.VR,D.EX,RTYPE,D.PR,A.EX,
.RGL,LSGN,LOPER')
DECLARE('UNPURGE.LABEL','INIEXE EXECPH PR.X PR.U PR.L DEFSTR
. GETLIT GETINT GETREL DEFLAB GETLAB DEFVAR GETVAR GTOPTY GTPVAL PUTTRE
. G.EX E.EX V.EX P.EX P.VR U.EX S.EX S.PR S.VR D.EX D.PR A.EX A B C D
. E F G')
DECLARE('PURGE.FUNCTION','DEFINE,DATA,DIFFER,IDENT,DATATYPE,
.ITEM,SUBSTR,REPLACE,APPLY,SIZE')
* * * * * * * * *
* * INITIALIZE EXECUTABLE STATEMENT PHASE * *
* * * * * * * * *
INIEXE DEFINE('PR.X()TP,ROPER')
DEFINE('PR.U()TP,ROPER')
DEFINE('PR.L()NOD,NPAR,TP,ROPER')
DEFINE('DEFSTR(STR1)')
DEFINE('GETLIT(STR1)')
DEFINE('GETINT(STR1,MODFLG)')
DEFINE('GETREL(STR1,MODFLG)')
DEFINE('DEFLAB()')
DEFINE('GETLAB()')
DEFINE('DEFVAR()')
DEFINE('GETDVR(STR1)')
DEFINE('GETVAR(STR1)')
DEFINE('GTOPTY(I)')
DEFINE('GTPVAL(NOD)')
DEFINE('PUTTRE(NOD)')
DEFINE('G.EX()')
DEFINE('E.EX(NOD)NPAR,RSTFLG,EVLCOD')
DEFINE('V.EX(NOD)')
DEFINE('P.EX(NOD,ROPER)TLAB1,TLAB2')
DEFINE('P.VR(NOD)ROPER')
DEFINE('U.EX(NOD,FUNC,MAXLVL)FAILFL')
DEFINE('S.EX(NOD,DEDVAR)NPAR')
DEFINE('S.PR(NOD)ROPER')
DEFINE('S.VR(NOD,MODFLG)TLAB1,NPAR')
DEFINE('D.EX(NOD,MODFLG)ROPER,RTYPE')
DEFINE('D.PR(NOD,MODFLG)ROPER,RTYPE,TLAB1')
DEFINE('A.EX(NOD,MODFLG,RGL)ROPER,RTYPE,LSGN,LOPER')
DATA('SYM(INAM,ATRB)')
DATA('CRS(NEXT,CRSI)')
DATA('NOD(FRNT,BACK)')
DATA('BON(OPTY,LFTS,RGTS)')
DATA('ELN(OPTY,SBJT,PVAL)')
DATA('PLN(NXTL,PARP,PVAL)')
EMPTMT = TAB(*P) @TP (RPOS(0) ! SPAN(BLNCHR) @TP (RPOS(0)
. ! ':'))
MAXLVL = 12 :(RETURN)
* * * * * * * * *
* * GENERATE CODE PREAMBLE * * * *
* * * * * * * * *
EXECPH PRGNAM = ?DIFFER(SNONAM) SNONAM :S(PRGHD1)
PRGNAM = ?DIFFER(SUBNAM) SUBNAM :S(PRGHD1)
PRGNAM = '.MAIN.'
SNONAM = PRGNAM
PRGHD1 ?INE(OBJFLG + LISTOB,0) :F(PRGHD7)
PUTOUT(SUBS(DECLAR<1>,PRGNAM))
STR1 = ENTRLS
STR2 = DECLAR<2>
SW = 1 :(PRGHD3)
PRGHD2 STR1 = EXTRLS
STR2 = DECLAR<4>
SW =
PRGHD3 STR3 =
I =
PRGHD4 (?IDENT(STR1) ?PUTOUT(STR3)) :F(PRGHD5)
?IEQ(SW,0) :F(PRGHD2)S(PRGHD7)
PRGHD5 STR3 = ?IEQ(I,0) SUBS(STR2,CRSI(STR1)) :S(PRGHD6)
STR3 = STR3 SUBS(DECLAR<3>,CRSI(STR1))
PRGHD6 STR1 = NEXT(STR1)
(?IGE(I,9) ?PUTOUT(STR3)) :S(PRGHD3)
I = I + 1 :(PRGHD4)
PRGHD7 ENTRLS =
EXTRLS =
PARBLK = NEWLAB()
TEMLOC = NEWLAB()
PRGNAM = INAM(DEFSTR(PRGNAM))
STARTP = ?DIFFER(SNONAM) NEWLAB() :F(CHKEOF)
STARTL = NEWLAB()
PUTOUT(SUBS(PROGAR<1>,STARTP,HSHSIZ,PARBLK,STARTL))
* CHECK IF DECLPH HIT EOF
CHKEOF IDENT(C) :F(LABL)S(NOEND)
* * * * * * * * *
* * STATEMENT PROCESSING LOOP * * *
* * * * * * * * *
*
STLOOP C = GETSTA() :F(NOEND)
*
* PROCESS LABEL FIELD
LABL C @P LABLPT @P :F(BODY)
PUTOUT(SUBS(PROGAR<6>,DEFLAB())) :S(BODY)
(?DIFFER(ITNAM,'END') ?ERRMSG('MULTIPLY-DEFINED LABEL: ' ITNAM
. ', IGNORED')) :S(BODY)
DIFFER(SNONAM) :F(LABL2)
C LEN(*P) BLNKPT @P LABLPT :F(LABL1)
PUTOUT(SUBS(PROGAR<5>,STARTL,GETLAB())) :(LABL2)
LABL1 PUTOUT(SUBS(PROGAR<4>,STARTL,STARTP))
LABL2 PUTOUT(PROGAR<2>) :(RETURN)
NOEND (?ERRMSG('NO END STATEMENT') ?DIFFER(SNONAM)) :S(LABL1)F(LABL2
.)
*
* PROCESS STATEMENT BODY
BODY STACOD =
VARCOD =
PATCOD =
OBJCOD =
TML =
DEDFLG = 1
* CHECK FOR EMPTY BODY
C EMPTMT :F(BODY1)
P = TP :(GOTO)
BODY1 P = ?INE(P,TP) TP :F(SYNTAX)
DEDFLG =
* PARSE SUBJECT
VARCOD = PR.U() :F(ERRPTR)
C EMPTMT :S(DEGEN)
P = ?INE(P,TP) TP :F(SYNTAX)
* CHECK FOR ASSIGNMENT
C LEN(*P) NOTANY(EQLCHR) :F(PARSOB)
* PARSE PATTERN
PATCOD = PR.X() :F(ERRPTR)
C EMPTMT :S(MATCH)
P = ?INE(P,TP) TP :F(SYNTAX)
* PARSE EQUALS BEFORE OBJECT
PARSOB C LEN(*P) ANY(EQLCHR) @P :F(SYNTAX)
C EMPTMT :S(PARSFN)
P = ?INE(P,TP) TP :F(SYNTAX)
OBJCOD = PR.X() :F(ERRPTR)
C EMPTMT :S(PARSFN)
P = TP :(SYNTAX)
PARSFN P = TP
IDENT(PATCOD) :F(REPLAC)S(ASSIGN)
* DEGENERATE
DEGEN P = TP
VARTYP = GTOPTY(OPTY(VARCOD))
DEDFLG = ?ILE(VARTYP,1) 1
VARTYP = ?ILE(VARTYP,3) REMDR(VARTYP,2) :F(DEGEN1)
STACOD = D.EX(VARCOD,VARTYP) :F(ERRPTR)S(GOTO)
DEGEN1 STACOD = E.EX(VARCOD) :F(ERRPTR)S(GOTO)
* ASSIGNMENT
ASSIGN VARTYP = GTOPTY(OPTY(VARCOD))
(?ILE(VARTYP,1) ?ILE(OPER,1)) :F(ASGSTR)
I = ?IEQ(OPER,1) SBJT(VARCOD) :F(DASG1)
P = ?ILE(I,7) ?ERRMSG('ASSIGNMENT TO PROTECTED KEYWORD')
. PVAL(VARCOD) :S(ERRPTR)
VARCOD = SUBS(VARBAR<1>,I) :(DASG2)
DASG1 VARCOD = GETDVR(SBJT(VARCOD))
DASG2 STACOD = ?IDENT(OBJCOD) SUBS(VARBAR<3>,VARCOD) :S(GOTO)
OBJTYP = GTOPTY(OPTY(OBJCOD))
VARTYP = ?IGT(OBJTYP,3) VARTYP + 2 :S(DASG3)
DEDFLG = ?ILE(OBJTYP,1) 1
STACOD = NOD(D.EX(OBJCOD,VARTYP),SUBS(VARBAR<2>,VARCOD))
. :F(ERRPTR)S(GOTO)
DASG3 P = ?IEQ(OBJTYP,5) ?ERRMSG('ILLEGAL ASSIGNMENT TO DEDICA
.TED VAR') PVAL(VARCOD) :S(ERRPTR)
STACOD = NOD(S.EX(OBJCOD),SUBS(VARBAR<5>,VARTYP,VARCOD))
. :F(ERRPTR)S(GOTO)
ASGSTR ITATR = ?IEQ(OPER,0) ATRB(SBJT(VARCOD)) :F(ASGVAR)
ITTYP =
(?GETATR() ?IEQ(VDATRB,VDDATR)) :F(ASGIDF)
STACOD = S.EX(OBJCOD,GETDVR(SBJT(VARCOD))) :F(ERRPTR)S(GOTO)
ASGIDF P = ?IEQ(VDATRB,VDPATR) ?ERRMSG('IMPROPER USE OF PATTERN P
.RIMITIVE') PVAL(VARCOD) :S(ERRPTR)
STACOD = ?IDENT(OBJCOD) SUBS(VARBAR<6>,GETVAR(SBJT(VARCOD)))
. :S(GOTO)
STACOD = NOD(E.EX(OBJCOD),SUBS(VARBAR<7>,GETVAR(SBJT(VARCOD))))
. :F(ERRPTR)S(GOTO)
ASGVAR STACOD = S.VR(VARCOD,1) :F(ERRPTR)
STACOD = ?IDENT(OBJCOD) NOD(STACOD,VARBAR<8>) :S(GOTO)
STACOD = NOD(NOD(STACOD,VARBAR<9>),NOD(E.EX(OBJCOD),VARBAR<10>
.)) :F(ERRPTR)S(GOTO)
* REPLACEMENT
REPLAC NPAR =
EVLCOD =
STACOD = P.EX(PATCOD) :F(ERRPTR)
STACOD = ?IEQ(NPAR,0) NOD(NOD(SUBS(MACHAR<2>,-1),MACHAR<3>),
.STACOD) :S(REPL2)
STACOD = NOD(SUBS(MACHAR<2>,NPAR + 1),STACOD)
REPL2 STACOD = ?DIFFER(EVLCOD) NOD(EVLCOD,STACOD)
OBJCOD = ?IDENT(OBJCOD) MACHAR<9> :S(REPL3)
OBJCOD = S.EX(OBJCOD) :F(ERRPTR)
REPL3 STACOD = NOD(NOD(MACHAR<1>,STACOD),NOD(NOD(MACHAR<7>,OBJCOD),
.MACHAR<8>))
(?GTOPTY(OPTY(VARCOD)) ?IEQ(OPER,0) ?IEQ(TYPE,4)) :F(REPL4)
VARCOD = GETVAR(SBJT(VARCOD)) ?IEQ(VDATRB,0) :F(REPL4)
STACOD = NOD(NOD(SUBS(MACHAR<5>,VARCOD),STACOD),SUBS(VARBAR<7>,
.VARCOD)) :(GOTO)
REPL4 VARCOD = V.EX(VARCOD) :F(ERRPTR)
STACOD = NOD(NOD(VARCOD,NOD(VARBAR<9>,MACHAR<6>)),NOD(STACOD,
.VARBAR<10>)) :(GOTO)
* MATCH
MATCH P = TP
VARCOD = S.PR(VARCOD) :F(ERRPTR)
NPAR =
EVLCOD =
STACOD = P.EX(PATCOD) :F(ERRPTR)
STACOD = ?IEQ(NPAR,0) NOD(NOD(SUBS(MACHAR<2>,-1),MACHAR<3>),
.STACOD) :S(MATCH1)
STACOD = NOD(SUBS(MACHAR<2>,NPAR + 1),STACOD)
MATCH1 STACOD = ?DIFFER(EVLCOD) NOD(EVLCOD,STACOD)
STACOD = NOD(NOD(VARCOD,MACHAR<1>),NOD(STACOD,MACHAR<4>))
*
* PROCESS GOTO FIELD
GOTO GOTCOD =
GLOBF = NOFAIL
C LEN(*P) @TP (RPOS(0) ! ':' NSPAN(BLNCHR) @TP)
. :F(SYNTAX)
P = ?INE(P,TP) TP :F(STLFIN)
C LEN(*P) ANY('SF') $ STR1 @P :S(GOTO2)
* UNCONDITIONAL GOTO
GOTCOD = G.EX() :F(ERRPTR)
DIFFER(DATATYPE(GOTCOD),'NOD') :F(GOTO1)
GLOBF = ?IDENT(GLOBF) GOTCOD
GOTCOD = SUBS(GOTOAR<5>,GOTCOD) :(GOTO7)
GOTO1 GLOBF = ?IDENT(GLOBF) NEWLAB() :F(GOTO7)
GOTCOD = NOD(SUBS(GOTOAR<4>,GLOBF),GOTCOD) :(GOTO7)
* CONDITIONAL GOTO(S)
GOTO2 IDENT(STR1,'F') :F(GOTO5)
* FAILURE GOTO
STR1 = G.EX() :F(ERRPTR)
GLOBF = ?DIFFER(DATATYPE(STR1),'NOD') STR1 :S(GOTO3)
GLOBF = NEWLAB()
GOTCOD = NOD(SUBS(GOTOAR<4>,GLOBF),STR1)
* CHECK FOR SUCCESS GOTO FOLLOWING FAILURE
GOTO3 C LEN(*P) NSPAN(BLNCHR) 'S' @P :S(GOTO4)
STR1 = ?DIFFER(GOTCOD) NEWLAB() :F(GOTO7)
GOTCOD = NOD(NOD(SUBS(GOTOAR<5>,STR1),GOTCOD),SUBS(GOTOAR<4>,
.STR1)) :(GOTO7)
GOTO4 STR1 = G.EX() :F(ERRPTR)
STR1 = ?DIFFER(DATATYPE(STR1),'NOD') SUBS(GOTOAR<5>,STR1)
GOTCOD = ?IDENT(GOTCOD) STR1 :S(GOTO7)
GOTCOD = NOD(STR1,GOTCOD)
* SUCCESS GOTO
GOTO5 GOTCOD = G.EX() :F(ERRPTR)
GOTCOD = ?DIFFER(DATATYPE(GOTCOD),'NOD') SUBS(GOTOAR<5>,GOTCOD)
* CHECK FOR FAILURE GOTO FOLLOWING SUCCESS
C LEN(*P) NSPAN(BLNCHR) 'F' @P :S(GOTO6)
GLOBF = ?IEQ(DEDFLG,0) NEWLAB() :F(GOTO7)
GOTCOD = NOD(GOTCOD,SUBS(GOTOAR<4>,GLOBF)) :(GOTO7)
GOTO6 STR1 = G.EX() :F(ERRPTR)
GLOBF = ?DIFFER(DATATYPE(STR1),'NOD') STR1 :S(GOTO7)
GLOBF = NEWLAB()
GOTCOD = NOD(GOTCOD,NOD(SUBS(GOTOAR<4>,GLOBF),STR1))
* CHECK FOR CLEAN ENDING
GOTO7 C LEN(*P) NSPAN(BLNCHR) @P RPOS(0) :F(SYNTAX)
*
* OUTPUT CODE FOR STATEMENT ENTRY, BODY, AND GOTO
STLFIN GLOBF = ?IDENT(GLOBF) ?IEQ(DEDFLG,0) NEWLAB() :F(STLFN1)
GOTCOD = SUBS(GOTOAR<4>,GLOBF)
STLFN1 ?INE(OBJFLG + LISTOB,0) :F(STLOOP)
(?ILT(STNFLG,0) ?IEQ(DEDFLG,1)) :S(STLFN2)
PUTOUT(SUBS(STENAR<STNFLG>,GLOBF,STNO))
STLFN2 (?DIFFER(STACOD) ?PUTTRE(STACOD))
(?DIFFER(GOTCOD) ?PUTTRE(GOTCOD)) :(STLOOP)
* ERRORS
SYNTAX STXERR('ERROR IN SYNTAX') :(ERRCLR)
ERRPTR STXERR()
ERRCLR STACOD = PROGAR<7>
GOTCOD =
GLOBF = :(STLFN1)
* * * * * * * * *
* * SUBROUTINES * * * * *
* * * * * * * * *
* PR.X()TP,ROPER PARSE EXPRESSION
* PARSES A SERIES OF ELEMENTS SEPARATED BY THE BINARY OPERATIONS
* **,^,/,*,+,-,$,.,(SPACE), AND !, AND BUILDS A TEXT TREE WITH THE
* LOWEST PRECEDENCE OPERATOR AT THE TOP. **,^,(SPACE), AND ! ARE
* CONSIDERED RIGHT-ASSOCIATIVE, AND THE REST LEFT-ASSOCIATIVE
*
PR.X ROPER = 42
RGL =
PR.X0 PR.X = BON(ROPER + LSHIFT(RGL,6),PR.X,PR.U()) :F(FRETURN)
C LEN(*P) SPAN(BLNCHR) @RGL :F(PR.X9)
C LEN(*RGL) (ANY('^*/+-.$!') ! '**') . STR1 SPAN(BLNCHR)
. @P :F(PR.X8)
ROPER = BOPRTB[STR1]
PR.X1 I = RSHIFT(ROPER,1)
PR.X2 RGL = OPTY(PR.X)
LOPER = AND(RGL,63)
J = RSHIFT(LOPER,1)
?IGE(I,J) :F(PR.X0)
?IEQ(I,J) :F(PR.X3)
(?INE(I,15) ?INE(I,19) ?INE(I,20)) :F(PR.X0)
PR.X = ?IEQ(I,21) RGTS(PR.X) :S(RETURN)
PR.X3 STR1 = LFTS(PR.X)
LFTS(PR.X) = RGTS(STR1)
RGTS(STR1) = PR.X
J = ITEM(BOPRAR<J>,GTOPTY(OPTY(LFTS(PR.X))),GTOPTY(OPTY(
.RGTS(PR.X))))
P = ?IEQ(J,7) RSHIFT(RGL,6) :F(PR.X5)
PR.X4 ERRMSG('IMPROPER TYPE FOR OPERATOR') :(FRETURN)
PR.X5 J = ?IEQ(J,6) TYPE :F(PR.X7)
J = ?IEQ(OPER,11) GTOPTY(OPTY(LFTS(PR.X))) :S(PR.X6)
J = ?GTOPTY(OPTY(LFTS(PR.X))) ?INE(OPER,11) 4 :S(PR.X7)
PR.X6 J = ?ILE(J,1) J + 2
PR.X7 OPTY(PR.X) = LSHIFT(LOPER,3) + J
PR.X = STR1 :(PR.X2)
PR.X8 C LEN(*RGL) NOTANY(':=_)>],') :F(PR.X9)
ROPER = 38
P = RGL :(PR.X1)
PR.X9 ROPER = 42 :(PR.X1)
* * * * * * * * *
* PR.U()TP,ROPER PARSE ELEMENT
* PARSES A SINGLE ELEMENT AND RETURNS THE ELN DATATYPE FOR IT
*
PR.U TP = P
* CONVERT FIRST CHAR INTO CHARACTERS A-G REPRESENTING: A-UNRECOGNIZA-
* BLE, B-KEYWORD, C-UNARY OPERATOR, D-STRING LITERAL, E-NUMERIC, F-OPEN
* PARENTHESIS, G-ALPHABETIC
STR1 = SUBSTR(C,1,P) :S($REPLACE(STR1,&ALPHABET,ELTCHR))
* UNRECOGNIZABLE ELEMENT
A ERRMSG('UNRECOGNIZABLE ELEMENT') :(FRETURN)
* KEYWORD
B P = P + 1
C IDENMT :F(PR.U2)
PR.U = KEYWTB[ITNAM]
I = ?DIFFER(PR.U) 0 :F(PR.U2)
I = ?IEQ(PR.U / 2,3) 4
DMPFLG = ?IEQ(PR.U,18) 1
I = I + 8
PR.U1 PR.U = ELN(I,PR.U,TP) :(RETURN)
PR.U2 P = ?ERRMSG('UNRECOGNIZABLE KEYWORD') TP + 1 :(FRETURN)
* UNARY OPERATOR
C ROPER = UOPRTB[STR1]
P = P + 1
PR.U = PR.U() :F(FRETURN)
I = ITEM(UOPRAR<ROPER>,GTOPTY(OPTY(PR.U)))
P = ?IEQ(I,7) TP :S(PR.X4)
I = LSHIFT(ROPER,3) + I :(PR.U1)
* STRING LITERAL
D P = P + 1
ITPAT = ?IDENT(STR1,SQCHR) SQLTPT :S(PR.U3)
ITPAT = DQLTPT
PR.U3 ITNAM = PARLIT(STR1,ITPAT) :F(A)
P = P + 1
PR.U = ?DIFFER(ITNAM) DEFSTR()
I = 36 :(PR.U1)
* NUMERIC
E C LEN(*P) INTGPT NSPAN('.') $ STR1 @P :F(A)
ITATR =
ITNAM = ?IDENT(STR1) INTGER :F(PR.U5)
I = 16
PR.U4 ITPTR = .CONSTB[ITNAM]
PR.U = ?DIFFER($ITPTR) $ITPTR :S(PR.U1)
ITATR = ?IEQ(I,16) ?ILE(INTGER,262143) 262144 + INTGER
$ITPTR = SYM(NEWNAM(),ITATR)
PR.U = $ITPTR :(PR.U1)
PR.U5 P = ?DIFFER(STR1,'.') P - 1 :S(A)
ITNAM = INTGER
INTGER =
C LEN(*P) NSPAN('0123456789') $ STR1 @P
P = ?IGE(SIZE(STR1),10) P - SIZE(STR1) :S(A)
ITNAM = ITNAM + ('0.' STR1)
I = 25 :(PR.U4)
* OPEN PARENTHESIS
F C POPRMT :F(A)
PR.U = PR.X() :F(FRETURN)
C PCPRMT :F(PR.U9)
I = 56 + GTOPTY(OPTY(PR.U)) :(PR.U1)
* ALPHABETIC
G C IDENMT (ANY('(<[') ! '') $ STR1 :F(A)
PR.U = ?IDENT(STR1) DEFVAR() :F(PR.U6)
I = ?ILE(VDATRB,VDDATR) 4 :S(PR.U1)
I = ?ILT(VDATRB,VDPATR) VDATRB / VDDATR - 2 :S(PR.U1)
I = 5 :(PR.U1)
PR.U6 ITATR = ?IDENT(STR1,'(') FTFATR + PRGALF :F(PR.U7)
ITTYP = 2
GETITM()
ATRB(ITENT) = ?IEQ(FTATRB,0) OR(ITATR,FTFATR)
I = FDATRB / FDPATR
I = ?ILE(I,1) I + 4
C POPRMT :F(A)
PR.U = ELN(48 + I,PR.L(),TP) :F(FRETURN)
C PCPRMT :F(PR.U9)S(RETURN)
PR.U7 PR.U = ?DEFVAR() ?IEQ(VDATRB,0) ELN(44,'',STR1) :F(PR.U10)
C LEN(*P) STR1 NSPAN(BLNCHR) @P :F(A)
SBJT(PR.U) = PR.L() :F(FRETURN)
STR1 = PVAL(PR.U)
STR1 = ?IDENT(STR1,'<') '>' :S(PR.U8)
STR1 = ']'
PR.U8 C LEN(*P) NSPAN(BLNCHR) @P STR1 @P :F(PR.U9)
PVAL(PR.U) = TP :(RETURN)
PR.U9 P = ?STXERR('UNBALANCED EXPRESSION OR PARM LIST') TP
. :(FRETURN)
PR.U10 P = ?ERRMSG('ILLEGAL ARRAY REF, DEDICATED VAR') TP
. :(FRETURN)
* * * * * * * * *
* PR.L()NOD,NPAR,TP,ROPER PARSE PARAMETER LIST
* PARSES 0 OR MORE EXPRESSIONS SEPARATED BY COMMAS, AND RETURNS
* A PLN DATATYPE FOR THE LIST. EXPECTS ITENT SET TO THE VARIABLE
* OR FUNCTION ENTRY, AND SETS PVAL OF THE FIRST PLN TO THE # OF
* PARMS * 8 + THE MAX OF THE TYPES OF ALL PARMS
*
PR.L PR.L = PLN('',ITENT,0)
C LEN(*P) ANY(')>]') :S(RETURN)
NOD = .NXTL(PR.L)
PR.L1 TP = P
STR1 = PR.X() :F(FRETURN)
NPAR = NPAR + 1
ROPER = ?IGT(GTOPTY(OPTY(STR1)),ROPER) TYPE
$NOD = PLN('',STR1,TP)
C LEN(*P) PCOMPT @P :F(PR.L2)
NOD = .NXTL($NOD) :(PR.L1)
PR.L2 PVAL(PR.L) = ?ILE(NPAR,15) LSHIFT(NPAR,3) + ROPER
. :S(RETURN)
ERRMSG('TOO MANY (>15) PARAMETERS IN LIST') :(FRETURN)
* * * * * * * * *
* DEFSTR(STR1) DEFINE STRING
* SETS STRING BLOCK ATTRIBUTE AND RETURNS ITENT
*
DEFSTR ITNAM = ?DIFFER(STR1) STR1
ITTYP = 3
ITATR = SKRATR
DEFSTR = ?GETITM() ITENT
ATRB(ITENT) = ?IEQ(SKATRB,0) OR(ITATR,SKRATR) :(RETURN)
* * * * * * * * *
* GETLIT(STR1) GET STRING DESCRIPTOR NAME
* SETS DESCRIPTOR ATTRIBUTE, RETURNS DESCRIPTOR LOC
*
GETLIT ATRB(STR1) = OR(ATRB(STR1),SDRATR)
GETLIT = 'S' INAM(STR1) :(RETURN)
* * * * * * * * *
* GETINT(STR1,MODFLG) GET INTEGER
* IF MODFLG IS 0, GETS LOC OF CONST OR IMMED VAL. IF MODFLG IS
* 1, GETS LOC OF DESCRIPTOR. IF MODFLG IS -1, GETS LOC OF CONST,
* EVEN IF VALUE CAN BE IMMEDIATE
*
GETINT ITATR = ATRB(STR1)
?ILE(MODFLG,0) :F(GETIN1)
GETINT = ?IEQ(MODFLG,0) ?INE(AND(ITATR,262144),0) SUBS(ARITAR<
.29>,AND(ITATR,262143)) :S(RETURN)
ATRB(STR1) = OR(ITATR,1048576)
GETINT = 'K' INAM(STR1) :(RETURN)
GETIN1 ATRB(STR1) = OR(ITATR,524288)
GETINT = 'I' INAM(STR1) :(RETURN)
* * * * * * * * *
* GETREL(STR1,MODFLG) GET REAL
* IF MODFLG IS 0 OR -1, GETS LOC OF CONST. IF MODFLG IS 1, GETS
* LOC OF DESCRIPTOR
*
GETREL ITATR = ATRB(STR1)
ATRB(STR1) = ?ILE(MODFLG,0) OR(ITATR,1048576) :F(GETRE1)
GETREL = 'C' INAM(STR1) :(RETURN)
GETRE1 ATRB(STR1) = OR(ITATR,524288)
GETREL = 'R' INAM(STR1) :(RETURN)
* * * * * * * * *
* DEFLAB() DEFINE LABEL
* EXPECTS LABEL IN ITNAM, RETURNS INTERNAL SYMBOL OR FAILS IF AL-
* READY DEFINED
*
DEFLAB ITTYP = 1
ITATR = PRGALL
(?GETITM() ?INE(LTATRB,LTDATR)) :F(FRETURN)
ATRB(ITENT) = OR(ITATR - LTATRB,LTDATR)
DEFLAB = ?INE(XNATRB,XNLATR) 'L' INAM(ITENT) :S(RETURN)
DEFLAB = XNAMTB[INAM(ITENT)] :(RETURN)
* * * * * * * * *
* GETLAB() GET LABEL NAME
* EXPECTS LABEL IN ITNAM, RETURNS INTERNAL SYMBOL
*
GETLAB ITTYP = 1
ITATR = 2 * LTDATR + PRGALL
GETITM()
ATRB(ITENT) = ?IEQ(LTATRB,0) OR(ITATR,2 * LTDATR + PRGALL)
GETLAB = ?INE(XNATRB,XNLATR) 'L' INAM(ITENT) :S(RETURN)
GETLAB = XNAMTB[INAM(ITENT)] :(RETURN)
* * * * * * * * *
* DEFVAR() DEFINE VARIABLE
* EXPECTS ITNAM SET TO VARIABLE NAME, RETURNS ENTRY
*
DEFVAR ITTYP =
ITATR = VTVATR + PRGALV
DEFVAR = ?GETITM() ITENT
ATRB(ITENT) = ?IEQ(VTATRB,0) OR(ITATR,VTVATR + PRGALV)
. :(RETURN)
* * * * * * * * *
* GETDVR(STR1) GET DEDICATED VARIABLE LOC
*
GETDVR ITTYP =
ITATR = ATRB(STR1)
GETDVR = ?GETATR() ?INE(XNATRB,XNVATR) 'V' INAM(STR1)
. :S(RETURN)
GETDVR = XNAMTB[INAM(STR1)] :(RETURN)
* * * * * * * * *
* GETVAR(STR1) GET VARIABLE NAMETYPE LOC
*
GETVAR ITTYP =
ITATR = ATRB(STR1)
ATRB(STR1) = ?GETATR() ?INE(VDATRB,0) OR(ITATR,VNNATR)
. :F(GETVA1)
GETVAR = 'N' INAM(STR1) :(RETURN)
GETVA1 GETVAR = ?INE(XNATRB,XNVATR) 'N' INAM(STR1) :S(RETURN)
GETVAR = XNAMTB[INAM(STR1)] :(RETURN)
* * * * * * * * *
* GTOPTY(I) GET OPER AND TYPE
* SETS OPER AND TYPE FROM I = OPER*8 + TYPE, RETURNS TYPE
*
GTOPTY OPER = RSHIFT(I,3)
TYPE = AND(I,7)
GTOPTY = TYPE :(RETURN)
* * * * * * * * *
* GTPVAL(NOD) GETS LEFTMOST PVAL OF TEXT TREE
* RETURNS THE LEFTMOST POINTER IN A TREE OF BINARY OPERATIONS
*
GTPVAL NOD = ?GTOPTY(OPTY(NOD)) ?IGE(OPER,30) LFTS(NOD) :S(GTPVAL)
GTPVAL = PVAL(NOD) :(RETURN)
* * * * * * * * *
* PUTTRE(NOD) OUTPUT OBJECT TREE
* OUTPUTS COMPONENTS OF TREE IN LEFT-TO-RIGHT,BOTTOM-TO-TOP SE-
* QUENCE
*
PUTTRE (?IDENT(DATATYPE(NOD),'NOD') ?PUTTRE(FRNT(NOD)) ?PUTTRE(BACK(
.NOD))) :S(RETURN)
PUTOUT(NOD) :(RETURN)
* * * * * * * * *
* G.EX() GOTO EXPRESSION PARSE AND CODE GENERATION
* RETURNS STRING (LABEL NAME) IF SIMPLE LABEL OR INDIRECT LITERAL,
* OR CODE NOD OTHERWISE
*
G.EX C POPRMT :F(G.EX6)
C IDENMT :F(G.EX3)
G.EX1 G.EX = GETLAB()
G.EX2 C PCPRMT :F(G.EX6)S(RETURN)
G.EX3 P = ?IDENT(SUBSTR(C,1,P),'$') P + 1 :F(G.EX6)
C LEN(*P) ANY(QTSCHR) $ STR1 @P :F(G.EX5)
ITPAT = ?IDENT(STR1,SQCHR) SQLTPT :S(G.EX4)
ITPAT = DQLTPT
G.EX4 ITNAM = PARLIT(STR1,ITPAT) :F(G.EX6)S(G.EX1)
G.EX5 G.EX = PR.U() :F(FRETURN)
TP = P
VARTYP = GTOPTY(OPTY(G.EX))
G.EX = NOD(S.PR(G.EX),GOTOAR<3>) :F(FRETURN)
P = TP
G.EX = ?IGT(VARTYP,1) NOD(GOTOAR<2>,G.EX) :(G.EX2)
G.EX6 ERRMSG('BAD GOTO SYNTAX') :(FRETURN)
* * * * * * * * *
* E.EX(NOD)NPAR,RSTFLG,EVLCOD EXPRESSION
* IF NOD IS AN EXPLICIT PATTERN, GENERATES CODE FOR A PATTERN
* EXPRESSION WHICH RETURNS A PATTERN DESCRIPTOR IN R1. OTHERWISE
* GENERATES CODE FOR A STRING EXPRESSION WHICH RETURNS A DES-
* CRIPTOR IN R1
*
E.EX (?GTOPTY(OPTY(NOD)) ?INE(TYPE,5)) :F(E.EX1)
E.EX = S.EX(NOD) :F(FRETURN)S(RETURN)
E.EX1 E.EX = P.EX(NOD,OPER) :F(FRETURN)
STR1 = NEWLAB()
STR2 = SUBS(PATRAR<1>,(-2 * RSTFLG + 1) * (NPAR + 1),STR1)
STR2 = ?IEQ(NPAR,0) NOD(STR2,PATRAR<2>)
E.EX = NOD(NOD(STR2,E.EX),SUBS(PATRAR<3>,STR1))
E.EX = ?DIFFER(EVLCOD) NOD(EVLCOD,E.EX) :(RETURN)
* * * * * * * * *
* V.EX(NOD) VARIABLE EXPRESSION
* ACCEPTS A NODE WHICH IS EITHER AN IDENTIFIER, UNPROTECTED KEY-
* WORD, OR STRING VARIABLE, AND RETURNS CODE THAT LEAVES A NAME
* DESCRIPTOR IN R1
*
V.EX I = ?GTOPTY(OPTY(NOD)) ?IEQ(OPER,1) SBJT(NOD) :F(V.EX1)
P = ?ILE(I,7) ?ERRMSG('ASSIGNMENT TO PROTECTED KEYWORD')
. PVAL(NOD) :S(FRETURN)
V.EX = SUBS(VARBAR<12>,I) :(RETURN)
V.EX1 V.EX = ?IEQ(OPER,0) GETVAR(SBJT(NOD)) :F(V.EX2)
V.EX = ?INE(VDATRB,VDPATR) SUBS(VARBAR<11>,V.EX) :S(RETURN)
P = ?ERRMSG('IMPROPER USE OF PATTERN PRIMITIVE') PVAL(NOD)
. :(FRETURN)
V.EX2 V.EX = S.VR(NOD,1) :F(FRETURN)S(RETURN)
* * * * * * * * *
* P.EX(NOD,ROPER)TLAB1,TLAB2 PATTERN EXPRESSION
* GENERATES CODE FOR PATTERN EXPRESSIONS, RETURNING THE MATCH CODE
* AS VALUE, AND APPENDING ANY EVALUATION CODE TO THE CODE CON-
* TAINED IN EVLCOD. MAY INCREMENT NPAR AND/OR SET RSTFLG
*
P.EX ROPER = ?IEQ(ROPER,0) ?GTOPTY(OPTY(NOD)) OPER
?IGT(ROPER,35) :F(P.EX7)
* BINARY PATTERN OPERATOR
?IEQ(ROPER,40) :F(P.EX3)
* ALTERNATION
TLAB1 = NEWLAB()
TLAB2 = NEWLAB()
P.EX = NOD(NOD(SUBS(PATRAR<4>,TLAB2),P.EX(LFTS(NOD))),
.SUBS(PATRAR<5>,TLAB1,TLAB2)) :F(FRETURN)
P.EX1 NOD = RGTS(NOD)
TLAB2 = ?GTOPTY(OPTY(NOD)) ?IEQ(OPER,40) NEWLAB() :S(P.EX2)
P.EX = NOD(P.EX,NOD(NOD(PATRAR<7>,P.EX(NOD,OPER)),SUBS(
.PATRAR<8>,TLAB1))) :F(FRETURN)
P.EXR RSTFLG = 1 :(RETURN)
P.EX2 P.EX = NOD(P.EX,NOD(NOD(SUBS(PATRAR<6>,TLAB2),P.EX(LFTS(NOD))
.),SUBS(PATRAR<5>,TLAB1,TLAB2))) :F(FRETURN)S(P.EX1)
P.EX3 ?IEQ(ROPER,38) :F(P.EX6)
* PATTERN CONCATENATION
P.EX = P.EX(LFTS(NOD)) :F(FRETURN)
P.EX4 NOD = RGTS(NOD)
(?GTOPTY(OPTY(NOD)) ?IEQ(OPER,38)) :F(P.EX5)
P.EX = NOD(P.EX,P.EX(LFTS(NOD))) :F(FRETURN)S(P.EX4)
P.EX5 P.EX = NOD(P.EX,P.EX(NOD,OPER)) :F(FRETURN)S(RETURN)
* IMMEDIATE AND CONDITIONAL PATTERN ASSIGNMENT
P.EX6 P.EX = NOD(NOD(PATRAR<9>,P.EX(LFTS(NOD))),NOD(P.VR(RGTS(NOD))
.,PATRAR<ROPER - 26>)) :F(FRETURN)S(P.EXR)
*
* PATTERN PRIMARY
P.EX7 ?IGE(ROPER,16) :F(P.EX14)
?ILT(ROPER,30) :F(P.EX11)
NOD = SBJT(NOD)
(?GTOPTY(OPTY(NOD)) ?IEQ(ROPER,16)) :F(P.EX8)
* CURSOR POSITION ASSIGNMENT
P.EX = ?IEQ(OPER + TYPE,0) SUBS(PATRAR<12>,GETDVR(SBJT(NOD)))
. :S(RETURN)
P.EX = NOD(P.VR(NOD),PATRAR<14>) :F(FRETURN)S(RETURN)
* UNEVALUATED EXPRESSION
P.EX8 ?IEQ(OPER,4) :F(P.EX10)
P.EX9 P.EX = ?DIFFER(SBJT(NOD)) SUBS(PATRAR<15>,GETLIT(SBJT(NOD)))
. :(RETURN)
P.EX10 ROPER = OPER
P.EX = U.EX(NOD,'S.PR',11) :F(FRETURN)
P.EX = ?INE(ROPER,11) NOD(P.EX,PATRAR<16>) :F(RETURN)S(P.EXR)
* SUM, TERM, OR FACTOR
P.EX11 STR1 = S.EX(NOD) :F(FRETURN)
P.EX12 STR1 = NOD(STR1,PATRAR<17>)
P.EX = PATRAR<20>
P.EX13 NPAR = NPAR + 1
P.EX = SUBS(P.EX,NPAR)
EVLCOD = ?IDENT(EVLCOD) STR1 :S(RETURN)
EVLCOD = NOD(EVLCOD,STR1) :(RETURN)
* STRING OR PATTERN PRIMARIES
P.EX14 ?INE(TYPE,5) :F(P.EX15)
?INE(ROPER,4) :F(P.EX9)
STR1 = S.PR(NOD) :F(FRETURN)S(P.EX12)
P.EX15 NOD = ?IEQ(ROPER,7) SBJT(NOD) :F(P.EX16)
* PARENTHESIZED EXPR
ROPER = :(P.EX)
* PRIMITIVE PATTERN VARIABLE OR FUNCTION
P.EX16 OPER = ?IEQ(ROPER,0) AND(ATRB(SBJT(NOD)),TXTMSK) / TXTATR
. :F(P.EX17)
* FAIL, FENCE, ABORT, ARB, BAL, SUCCEED, REM
P.EX = PTVRAR<OPER>
(?INE(OPER,1) ?INE(OPER,3) ?INE(OPER,7)) :F(RETURN)S(P.EXR)
P.EX17 STR1 = SBJT(NOD)
ROPER = AND(ATRB(PARP(STR1)),TXTMSK) / TXTATR
(?GTOPTY(PVAL(STR1)) ?INE(OPER,1)) :F(P.EX19)
P.EX18 P = ?ERRMSG('IMPROPER ARG(S) TO PATTERN PRIMITIVE') PVAL(
.NOD) :(FRETURN)
P.EX19 NOD = PARP(NXTL(STR1))
P.EX = PTFNAR<ROPER>
?ILE(ROPER,5) :F(P.EX25)
* LEN, TAB, RTAB, POS, RPOS
(?GTOPTY(OPTY(NOD)) ?ILE(TYPE,4)) :F(P.EX22)
P.EX = ?IEQ(OPER,2) NOD(SUBS(PATRAR<21>,GETINT(SBJT(NOD))),
.P.EX) :S(RETURN)
?ILE(TYPE,3) :F(P.EX20)
STR1 = NOD(D.EX(NOD),PATRAR<22>) :F(FRETURN)S(P.EX21)
P.EX20 STR1 = NOD(S.EX(NOD),PATRAR<24>) :F(FRETURN)
P.EX21 P.EX = NOD(PATRAR<23>,P.EX) :(P.EX13)
P.EX22 P.EX = ?IEQ(OPER,17) NOD(PATRAR<25>,P.EX) :F(P.EX18)
NOD = SBJT(NOD)
(?GTOPTY(OPTY(NOD)) ?ILE(TYPE,4)) :F(P.EX18)
STR2 = ?ILE(TYPE,3) 'D.EX' :F(P.EX23)
I = ?IGE(TYPE,2) 11 :S(P.EX24)
I = 8 :(P.EX24)
P.EX23 STR2 = 'S.EX'
I = 11
P.EX = NOD(PATRAR<26>,P.EX)
P.EX24 P.EX = NOD(U.EX(NOD,STR2,I),P.EX) :F(FRETURN)S(RETURN)
P.EX25 ?ILE(ROPER,12) :F(P.EX28)
* SPAN, BREAK, ANY, NOTANY, NSPAN, BREAKX, BREAKQ
(?ILE(TYPE,4) ?GTOPTY(OPTY(NOD))) :F(P.EX27)
STR2 = ?IEQ(OPER,4) SBJT(NOD) :F(P.EX26)
P.EX = ?DIFFER(STR2) NOD(SUBS(PATRAR<27>,'B' INAM(STR2)),
.P.EX) :F(P.EX18)
STR1 = .ATRB(STR2)
$STR1 = OR($STR1,BTRATR)
RSTFLG = ?IEQ(ROPER,11) 1 :(RETURN)
P.EX26 STR1 = NOD(S.EX(NOD),PATRAR<29>) :F(FRETURN)
P.EX = NOD(PATRAR<19>,P.EX)
RSTFLG = ?IEQ(ROPER,11) 1 :(P.EX13)
P.EX27 P.EX = ?IEQ(OPER,17) NOD(PATRAR<28>,P.EX) :F(P.EX18)
NOD = SBJT(NOD)
?ILE(GTOPTY(OPTY(NOD)),4) :F(P.EX18)
P.EX = NOD(U.EX(NOD,'S.EX',11),P.EX) :F(FRETURN)
RSTFLG = ?IEQ(ROPER,11) 1 :(RETURN)
* ARBNO
P.EX28 TLAB1 = NEWLAB()
P.EX = NOD(SUBS(FRNT(P.EX),TLAB1),NOD(P.EX(NOD),SUBS(BACK(
.P.EX),TLAB1))) :F(FRETURN)S(P.EXR)
* * * * * * * * *
* P.VR(NOD)ROPER PATTERN VARIABLE
* GENERATES MATCH CODE THAT PRODUCES A NAME DATATYPE IN R1, WITH
* ANY EVALUATION CODE BEING ADDED TO EVLCOD
*
P.VR NOD = ?GTOPTY(OPTY(NOD)) ?IEQ(OPER,17) SBJT(NOD) :S(P.VR1)
ROPER = OPER
P.VR = V.EX(NOD) :F(FRETURN)
STR1 = ?IGT(ROPER,1) NOD(P.VR,PATRAR<18>) :F(RETURN)
NPAR = NPAR + 1
P.VR = SUBS(PATRAR<30>,NPAR)
EVLCOD = ?IDENT(EVLCOD) STR1 :S(RETURN)
EVLCOD = NOD(EVLCOD,STR1) :(RETURN)
P.VR1 P.VR = U.EX(NOD,'V.EX',11) :F(FRETURN)S(RETURN)
* * * * * * * * *
* U.EX(NOD,FUNC,MAXLVL)FAILFL
* GENERATES MATCH CODE FOR UNEVALUATED EXPRESSIONS OF TYPE SPE-
* CIFIED BY FUNC, WITH ARITHMETIC RESTRICTED TO LEVEL SPECIFIED
* BY MAXLVL
*
U.EX U.EX = APPLY(FUNC,NOD) :F(FRETURN)
(?GTOPTY(OPTY(NOD)) ?INE(OPER,0) ?IGT(TYPE,1)) :F(RETURN)
U.EX = ?IEQ(FAILFL,0) NOD(PATRAR<31>,NOD(U.EX,PATRAR<32>))
. :S(RETURN)
U.EX = NOD(PATRAR<33>,NOD(U.EX,PATRAR<34>)) :(RETURN)
* * * * * * * * *
* S.EX(NOD,DEDVAR)NPAR STRING EXPRESSION
* GENERATES CODE FOR STRING CONCATENATION AND NON-DEDICATED ARITH-
* METIC WHICH LEAVES DESCRIPTOR IN R1, OR SAVES STRING IN DEDVAR
*
S.EX ?IEQ(GTOPTY(OPTY(NOD)),5) :F(S.EX0)
S.EXE P = ?ERRMSG('BAD CONTEXT FOR PATTERN') GTPVAL(NOD)
. :(FRETURN)
S.EX0 ?ILT(OPER,30) :F(S.EX2)
* STRING PRIMARY
S.EX = S.PR(NOD) :F(FRETURN)
S.EX1 S.EX = ?DIFFER(DEDVAR) NOD(S.EX,SUBS(VARBAR<5>,1,DEDVAR))
. :(RETURN)
S.EX2 NPAR = ?ILE(TYPE,3) REMDR(TYPE,2) :F(S.EX3)
* DEDICATED EXPRESSION
S.EX = NOD(D.EX(NOD,NPAR),EXPRAR<NPAR + 3>)
. :F(FRETURN)S(S.EX1)
S.EX3 ?IEQ(OPER,38) :F(S.EX9)
* STRING CONCATENATION
S.EX = S.EX(LFTS(NOD)) :F(FRETURN)
S.EX4 (?GTOPTY(OPTY(LFTS(NOD))) ?INE(OPER,11) ?INE(OPER,12)) :F(S.EX5)
NPAR = NPAR + 1
S.EX = NOD(S.EX,EXPRAR<1>)
S.EX5 NOD = RGTS(NOD)
(?GTOPTY(OPTY(NOD)) ?IEQ(OPER,38) ?IGT(TYPE,3)) :F(S.EX6)
S.EX = NOD(S.EX,S.EX(LFTS(NOD))) :F(FRETURN)S(S.EX4)
S.EX6 S.EX = NOD(S.EX,S.EX(NOD)) :F(FRETURN)
(?GTOPTY(OPTY(NOD)) ?INE(OPER,11) ?INE(OPER,12)) :F(S.EX8)
NPAR = NPAR + 1
S.EX7 ?IGT(NPAR,1) :F(S.EX1)
S.EX = ?IDENT(DEDVAR) NOD(S.EX,SUBS(EXPRAR<2>,NPAR))
. :S(RETURN)
S.EX = ?ILE(NPAR,15) NOD(S.EX,SUBS(VARBAR<4>,NPAR,DEDVAR))
. :S(RETURN)
S.EX = NOD(S.EX,SUBS(EXPRAR<2>,NPAR)) :(S.EX1)
S.EX8 S.EX = ?IGT(NPAR,0) NOD(S.EX,EXPRAR<6>) :(S.EX7)
* UNDEDICATED ARITHMETIC OPERATIONS
S.EX9 NPAR = OPER
S.EX = NOD(NOD(S.EX(LFTS(NOD)),EXPRAR<1>),NOD(S.EX(RGTS(NOD))
.,EXPRAR<NPAR - 25>)) :F(FRETURN)S(S.EX1)
* * * * * * * * *
* S.PR(NOD)ROPER STRING PRIMARY
* GENERATES CODE FOR STRING PRIMARIES WHICH LEAVES DESCRIPTOR IN
* R1
*
S.PR (?GTOPTY(OPTY(NOD)) ?ILE(TYPE,3)) :F(S.PR2)
ROPER = ?INE(OPER,2) ?INE(OPER,3) REMDR(TYPE,2) :F(S.PR1)
* DEDICATED PRIMARY
S.PR = NOD(D.PR(NOD,ROPER),EXPRAR<ROPER + 3>)
. :F(FRETURN)S(RETURN)
* INTEGER OR REAL CONSTANT
S.PR1 S.PR = ?IEQ(OPER,2) SUBS(VARBAR<11>,GETINT(SBJT(NOD),1))
. :S(RETURN)
S.PR = SUBS(VARBAR<11>,GETREL(SBJT(NOD),1)) :(RETURN)
S.PR2 ?ILE(OPER,10) :F(S.PR6)
?ILE(OPER,4) :F(S.PR5)
STR1 = ?IEQ(OPER,4) SBJT(NOD) :F(S.PR3)
* STRING LITERAL
S.PR = ?DIFFER(STR1) SUBS(VARBAR<11>,GETLIT(STR1)) :S(RETURN)
S.PR = EXPRAR<13> :(RETURN)
* &ALPHABET OR &RTNTYPE KEYWORD
S.PR3 S.PR = ?IEQ(OPER,1) SUBS(EXPRAR<11>,SUBS(VARBAR<1>,SBJT(NOD))
.) :S(RETURN)
* IDENTIFIER
S.PR = ?INE(TYPE,5) SUBS(EXPRAR<12>,GETVAR(SBJT(NOD)))
. :F(S.EXE)
* DEDICATED STRING
S.PR = ?IEQ(VDATRB,VDDATR) NOD(S.PR,EXPRAR<14>) :(RETURN)
* PARENTHESIZED EXPR
S.PR5 NOD = ?IEQ(OPER,7) SBJT(NOD) :F(S.PR5A)
S.PR = S.EX(NOD) :F(FRETURN)S(RETURN)
* STRING VARIABLE
S.PR5A S.PR = S.VR(NOD) :F(FRETURN)S(RETURN)
S.PR6 ROPER = ?INE(OPER,15) OPER :F(S.PR7)
* ?, \, +, -
S.PR = S.PR(SBJT(NOD)) :F(FRETURN)
* +
?INE(ROPER,13) :F(RETURN)
* ?, -
S.PR = ?INE(ROPER,12) NOD(S.PR,EXPRAR<ROPER + 2>) :S(S.PR8)
* \
STR1 = NEWLAB()
S.PR = NOD(SUBS(EXPRAR<15>,STR1),NOD(S.PR,SUBS(EXPRAR<17>,
.STR1))) :(RETURN)
* .
S.PR7 S.PR = V.EX(SBJT(NOD)) :F(FRETURN)S(RETURN)
* TRY TO OPTIMIZE ? A LITTLE
S.PR8 STR1 = ?IEQ(ROPER,11) SBJT(NOD) :F(RETURN)
STR1 = ?GTOPTY(OPTY(STR1)) ?ILE(TYPE,3) ?IEQ(OPER,6)
. FRNT(FRNT(FRNT(S.PR))) :F(RETURN)
* ELIMINATES THE MOVING OF RESULT TO R1 AND CONVERSION TO DESCRIPTOR
* MODE IN THE CASE OF ?FORTRAN.FUNC
FRNT(S.PR) = STR1 :(RETURN)
* * * * * * * * *
* S.VR(NOD,MODFLG)TLAB1,NPAR STRING VARIABLE
* GENERATES CODE FOR INDIRECTION, ARRAY REFERENCES, AND NON-
* FORTRAN FUNCTION CALLS, LEAVING VALUE IN R1 IF CALL FOR VALUE
* (MODFLG=0), OR NAME DESCR IN R1 IF CALL FOR NAME (MODFLG=1)
*
S.VR (?GTOPTY(OPTY(NOD)) ?INE(TYPE,5)) :F(S.EXE)
?INE(TYPE,4) :F(S.VR1)
S.VR0 P = ?ERRMSG('ILLEGAL VARIABLE EXPRESSION') GTPVAL(NOD)
. :(FRETURN)
S.VR1 S.VR = ?IEQ(OPER,10) EXPRAR<18 + MODFLG> :F(S.VR2)
S.VR = NOD(S.PR(SBJT(NOD)),S.VR) :F(FRETURN)S(RETURN)
S.VR2 NOD = ?IGE(OPER,5) ?ILE(OPER,6) SBJT(NOD) :F(S.VR0)
TLAB1 = ?IEQ(OPER,5) GETVAR(PARP(NOD)) :S(S.VR3)
FAILFL = 1
ITTYP = 2
ITATR = ATRB(PARP(NOD))
TLAB1 = ?GETATR() ?INE(XNATRB,XNFATR) 'F' INAM(PARP(NOD))
. :S(S.VR3)
TLAB1 = XNAMTB[INAM(PARP(NOD))]
S.VR3 NPAR = RSHIFT(PVAL(NOD),3)
TLAB1 = SUBS(EXPRAR<OPER + 2 * MODFLG + 16>,NPAR,TLAB1)
S.VR = ?IEQ(NPAR,0) TLAB1 :S(RETURN)
NOD = NXTL(NOD)
S.VR = E.EX(PARP(NOD)) :F(FRETURN)
S.VR4 NPAR = NPAR - 1
S.VR = ?IEQ(NPAR,0) NOD(S.VR,TLAB1) :S(RETURN)
NOD = NXTL(NOD)
S.VR = NOD(S.VR,NOD(EXPRAR<1>,E.EX(PARP(NOD))))
. :F(FRETURN)S(S.VR4)
* * * * * * * * *
* D.EX(NOD,MODFLG)ROPER,RTYPE DEDICATED EXPRESSION
* GENERATES CODE THAT RETURNS INTEGER (MODFLG=0) OR REAL
* (MODFLG=1) IN R1
*
D.EX ?INE(GTOPTY(OPTY(NOD)),5) :F(S.EXE)
?ILT(OPER,30) :F(D.EX1)
* DEDICATED PRIMARY
D.EX = D.PR(NOD,MODFLG) :F(FRETURN)S(RETURN)
D.EX1 ?ILE(TYPE,1) :F(D.EX2)
* PURE DEDICATED EXPRESSION
D.EX = A.EX(NOD,MODFLG) :F(FRETURN)S(RETURN)
D.EX2 ?IEQ(TYPE,4) :F(D.EX3)
* DESCRIPTOR EXPRESSION
D.EX = NOD(S.EX(NOD),ARITAR<1 + MODFLG>) :F(FRETURN)S(RETURN)
D.EX3 ?IEQ(OPER,38) :F(D.EX5)
* CONCATENATION OF ? AND DED EXPR (OR VICE VERSA), OR CONCATENATION
* OF ? AND ?
(?GTOPTY(OPTY(LFTS(NOD))) ?IEQ(OPER,11)) :F(D.EX4)
D.EX = NOD(S.EX(LFTS(NOD)),D.EX(RGTS(NOD),MODFLG))
. :F(FRETURN)S(RETURN)
D.EX4 D.EX = NOD(NOD(D.EX(LFTS(NOD),MODFLG),ARITAR<3>),NOD(S.EX(
.RGTS(NOD)),ARITAR<4>)) :F(FRETURN)S(RETURN)
D.EX5 ROPER = ?IGE(OPER,32) OPER :F(D.EX7)
* IMPURE DEDICATED *, /, +, -
RTYPE = REMDR(TYPE,2)
D.EX = D.EX(LFTS(NOD),RTYPE) :F(FRETURN)
STR1 = RGTS(NOD)
(?GTOPTY(OPTY(STR1)) ?IGE(TYPE,2)) :F(D.EX6A)
* RIGHT SIDE IMPURE
D.EX = NOD(NOD(D.EX,ARITAR<3>),NOD(D.EX(STR1,RTYPE),NOD(
.ARITAR<5>,SUBS(ARITAR<ROPER - 26>,AROPAR<ROPER,RTYPE>)))) :F(FRETURN)
* ADJUST TYPE IF NECESSARY
D.EX6 D.EX = ?INE(RTYPE,MODFLG) NOD(D.EX,ARITAR<10 + MODFLG>)
. :(RETURN)
* RIGHT SIDE PURE
D.EX6A STR1 = A.EX(STR1,RTYPE,2) :F(FRETURN)
D.EX = ?DIFFER(STR1) NOD(D.EX,STR1)
D.EX = ?IGE(ROPER,34) NOD(D.EX,SUBS(ARITAR<16>,
.AROPAR<RSGN * (69 - ROPER) + (1 - RSGN) * ROPER,RTYPE>,SUBS(ARITAR<13>,
.'1',RLOC))) :S(D.EX6)
D.EX = NOD(D.EX,SUBS(ARITAR<16>,AROPAR<ROPER,RTYPE>,SUBS(
.ARITAR<13>,'1',RLOC)))
D.EX = ?INE(RSGN,0) NOD(D.EX,SUBS(ARITAR<17>,'1')) :(D.EX6)
* DEDICATED ** (ALWAYS IMPURE)
D.EX7 RTYPE = REMDR(TYPE,2)
D.EX = D.EX(LFTS(NOD),RTYPE) :F(FRETURN)
ROPER = RTYPE * 2
I = RTYPE
STR1 = RGTS(NOD)
(?GTOPTY(OPTY(STR1)) ?IEQ(RTYPE,1) ?IEQ(REMDR(TYPE,2),0))
. :F(D.EX8)
ROPER = 1
I =
D.EX8 D.EX = NOD(NOD(D.EX,ARITAR<3>),NOD(D.EX(STR1,I),NOD(ARITAR<5>
.,ARITAR<18 + ROPER>))) :(D.EX6)
* * * * * * * * *
* D.PR(NOD,MODFLG)ROPER,RTYPE,TLAB1 DEDICATED PRIMARY
* GENERATES CODE THAT RETURNS INTEGER (MODFLG=0) OR REAL
* (MODFLG=1) IN R1
*
D.PR ?INE(GTOPTY(OPTY(NOD)),5) :F(S.EXE)
?ILE(TYPE,1) :F(D.PR1)
* PURE DEDICATED EXPRESSION
D.PR = A.EX(NOD,MODFLG) :F(FRETURN)S(RETURN)
D.PR1 ?IEQ(TYPE,4) :F(D.PR2)
* DESCRIPTOR PRIMARY
D.PR = ?IEQ(OPER,0) SUBS(ARITAR<21 + MODFLG>,GETVAR(SBJT(
.NOD))) :S(RETURN)
D.PR = NOD(S.PR(NOD),ARITAR<1 + MODFLG>) :F(FRETURN)S(RETURN)
D.PR2 ROPER = ?IGE(OPER,13) OPER :F(D.PR3)
* UNARY + OR -
D.PR = D.PR(SBJT(NOD),MODFLG) :F(FRETURN)
D.PR = ?IEQ(ROPER,14) NOD(D.PR,SUBS(ARITAR<17>,'1'))
. :(RETURN)
D.PR3 ?IEQ(OPER,7) :F(D.PR3A)
* PARENTHESIZED EXPR
D.PR = D.EX(SBJT(NOD),MODFLG) :F(FRETURN)S(RETURN)
* FORTRAN FUNCTION CALL
D.PR3A ROPER = TML
RTYPE = TYPE - 2
FAILFL = 1
NOD = SBJT(NOD)
TLAB1 = XNAMTB[INAM(PARP(NOD))]
TLAB1 = SUBS(ARITAR<23>,TLAB1)
D.PR4 NOD = NXTL(NOD)
STR1 = ?DIFFER(NOD) PARP(NOD) :F(D.PR11)
(?GTOPTY(OPTY(STR1)) ?IEQ(TYPE,5)) :S(S.EXE)
?ILE(TYPE,3) :F(D.PR8)
TYPE = ?ILE(OPER,3) ?INE(OPER,1) TYPE * 2 :F(D.PR6)
STR1 = SBJT(STR1)
RLOC = ?IEQ(OPER,0) GETDVR(STR1) :S(D.PR5)
RLOC = ?IEQ(OPER,2) GETINT(STR1,-1) :S(D.PR5)
RLOC = GETREL(STR1,-1)
D.PR5 TLAB1 = NOD(TLAB1,SUBS(ARITAR<24>,TYPE,RLOC)) :(D.PR4)
D.PR6 TYPE = REMDR(TYPE,2)
TLAB1 = NOD(TLAB1,SUBS(ARITAR<24>,TYPE * 2,SUBS(ARITAR<25>,
.TEMLOC,TML)))
TML = TML + 1
STR1 = NOD(D.EX(STR1,TYPE),SUBS(VARBAR<2>,SUBS(ARITAR<25>,
.TEMLOC,TML - 1))) :F(FRETURN)
D.PR7 D.PR = ?DIFFER(D.PR) NOD(D.PR,STR1) :S(D.PR4)
D.PR = STR1 :(D.PR4)
D.PR8 TYPE = ?ILE(OPER,4) ?INE(OPER,1) 5 :F(D.PR10)
STR1 = ?IEQ(OPER,4) SBJT(STR1) :F(D.PR9)
RLOC = ?DIFFER(STR1) SUBS(ARITAR<25>,'A' INAM(STR1),'1')
. :S(D.PR5)
P = ?ERRMSG('NULL IS BAD ARG FOR FORTRAN') PVAL(NOD)
. :(FRETURN)
D.PR9 STR2 = SBJT(STR1)
ITATR = ATRB(STR2)
RLOC = ?GETATR() ?IEQ(VDATRB,VDDATR) SUBS(ARITAR<25>,GETDVR(
.STR2),'2') :S(D.PR5)
D.PR10 TLAB1 = NOD(TLAB1,SUBS(ARITAR<24>,'0',SUBS(ARITAR<25>,TEMLOC,
.TML)))
TML = TML + 1
STR1 = NOD(S.EX(STR1),SUBS(VARBAR<5>,'2',SUBS(ARITAR<25>,
.TEMLOC,TML - 1))) :F(FRETURN)S(D.PR7)
* FINISHED
D.PR11 MAXTMP = ?IGT(TML,MAXTMP) TML
TML = ROPER
TLAB1 = NOD(TLAB1,ARITAR<26>)
D.PR = ?DIFFER(D.PR) NOD(D.PR,TLAB1) :S(D.PR12)
D.PR = TLAB1
D.PR12 STR1 = ARITAR<27>
STR1 = ?INE(MODFLG,RTYPE) NOD(STR1,ARITAR<10 + MODFLG>)
D.PR = NOD(D.PR,STR1) :(RETURN)
* * * * * * * * *
* A.EX(NOD,MODFLG,RGL)ROPER,RTYPE,LSGN,LOPER PURE DEDI-
* CATED ARITHMETIC EXPRESSION
* GENERATES CODE, AND ASSURES RESULT IN R1 WITH NORMAL SIGN SENSE
* IF RGL=0, OTHERWISE RESULT IS IN RLOC, OF TYPE RTYP (0-REGIS-
* TER, 1-STORAGE), AND WITH SIGN SENSE RSGN (0-NORMAL, 1-
* REVERSED). OPERATIONS ARE AT REGISTER LEVEL RGL
*
A.EX LOPER = ?IEQ(RGL,0) 1 :F(A.EX1)
RGL = 1
A.EX1 RTYPE = REMDR(GTOPTY(OPTY(NOD)),2)
ROPER = OPER
?IGT(RGL,MAXLVL) :F(A.EX2)
P = ?ERRMSG('NESTING TOO DEEP, SIMPLIFY EXPR') GTPVAL(NOD)
. :(FRETURN)
A.EX2 ?IGE(OPER,32) :F(A.EX8)
A.EX = A.EX(LFTS(NOD),RTYPE,RGL) :F(FRETURN)
A.EX = ?INE(RTYP,0) SUBS(ARITAR<16>,ARITAR<14 + RSGN>,SUBS(
.ARITAR<13>,RGL,RLOC)) :F(A.EX3)
RSGN =
A.EX3 LSGN = RSGN
STR1 = A.EX(RGTS(NOD),RTYPE,RGL + 1) :F(FRETURN)
A.EX = ?IEQ(RTYP,0) NOD(A.EX,STR1)
A.EX = ?ILE(ROPER,33) NOD(A.EX,SUBS(ARITAR<16>,AROPAR<ROPER,
.RTYPE>,SUBS(ARITAR<13>,RGL,RLOC))) :F(A.EX4)
RSGN = XOR(RSGN,LSGN) :(A.EX5)
A.EX4 A.EX = NOD(A.EX,SUBS(ARITAR<16>,AROPAR<34 + XOR(ROPER - 34,
.XOR(LSGN,RSGN)),RTYPE>,SUBS(ARITAR<13>,RGL,RLOC)))
RSGN = LSGN
A.EX5 RTYP =
RLOC = SUBS(ARITAR<12>,RGL)
A.EX6 ?INE(MODFLG,RTYPE) :F(A.EX7)
A.EX = ?IEQ(RGL,1) NOD(A.EX,ARITAR<10 + MODFLG>) :S(A.EX7)
A.EX = NOD(A.EX,SUBS(ARITAR<28>,RGL)) :(RETURN)
A.EX7 A.EX = ?IEQ(LOPER,1) ?INE(RSGN,0) NOD(A.EX,SUBS(ARITAR<17>,
.RGL)) :F(RETURN)
RSGN = :(RETURN)
A.EX8 ?ILE(OPER,3) :F(A.EX11)
STR1 = SBJT(NOD)
RLOC = ?IEQ(OPER,0) GETDVR(STR1) :S(A.EX9)
RLOC = ?IEQ(OPER,2) GETINT(STR1) :S(A.EX9)
RLOC = ?IEQ(OPER,3) GETREL(STR1) :S(A.EX9)
RLOC = SUBS(VARBAR<1>,STR1)
A.EX9 RTYP = 1
RSGN =
(?INE(LOPER,1) ?IEQ(MODFLG,RTYPE)) :S(RETURN)
A.EX10 A.EX = SUBS(ARITAR<16>,ARITAR<14 + RSGN>,SUBS(ARITAR<13>,
.RGL,RLOC))
RSGN = :(A.EX5)
A.EX11 ROPER = ?IEQ(OPER,7) 13
A.EX = A.EX(SBJT(NOD),MODFLG,RGL) :F(FRETURN)
RSGN = XOR(RSGN,ROPER - 13)
RTYPE = ?IEQ(LOPER,1) MODFLG :F(RETURN)
?IEQ(RTYP,0) :F(A.EX10)S(A.EX6)
* * * * * * * * *
END