%CONTROL X'FFFFFFF2' %EXTERNALROUTINE POP2(%STRING(63)POPPARM); %EXTERNALINTEGERFNSPEC EVENT(%INTEGER I) !POP2 INTERPRETER FOR EMAS %CONSTSTRING(25) IDENTIFICATION="EMAS POP2: V1.1 08/01/78" ! %SYSTEMROUTINESPEC OUTFILE(%STRING(15) S %INTEGER L,M,P %C %INTEGERNAME C,F) %EXTERNALSTRINGFNSPEC SSFMESSAGE %EXTERNALROUTINESPEC DEFINE(%STRING(63) S) %EXTERNALINTEGERFNSPEC EXIST(%STRING(15)S) %EXTERNALROUTINESPEC CLEAR(%STRING(63) S) %EXTERNALLONGREALFNSPEC CPUTIME %EXTERNALROUTINESPEC PROMPT(%STRING(17) S) %EXTERNALINTEGERFNSPEC TEST INT(%INTEGER C %STRING(15) S) %EXTERNALROUTINESPEC E(%STRING(63) S) ! ! REPRESENTATION OF POP2 VALUES:- ! ...000 : INTEGER (TRUE VALUE * 8) ! ...100 : REAL (TRUE FP VALUE WITH LS BITS FORCED) ! ....10 : COMPOUND (BYTE ADDRESS OF FIRST WORD MINUS TWO) ! ....01 : FUNCTION ! ! ....00 MAY ALSO BE PRIVATE ADDRESS ! ! DISCRIMINATION OF COMPOUND VALUES:- ! PAIR < WORDMIN (=NIL) ! WORDMIN <= WORD < STRIPMIN ! STRIPMIN <= STRIP, (FUNCTION BODY) ! ! REPRESENTATION OF PAIR:- ! 2 FRONT ! 6 BACK ! ! REPRESENTATION OF WORD:- ! 2 VALUE ! 6 C1(6):C2(6):C3(6):C4(6):C5(6):0(2) C IS SYMBOL+1 ! 10 C6(6):C7(6):C8(6):HASHLINK(14) (ZERO FOR NULL) ! 14 TYPE(8):MEANING(24) ! ! REPRESENTATION OF STRIP (RECORD):- ! 2 NUMBER(16):SIZE(8):CLASS(8) ! 6 FIRST COMPONENT WORD ! ...... ! ! DISCRIMINATION OF FUNCTIONS:- ! 0000 0000 ....01 : COMPILED FUNCTION BODY ! (BYTE ADDRESS OF FIRST WORD MINUS THREE) ! XXXX XXXX ....01 : BUILT-IN FUNCTION (EXECUTABLE FORM PLUS ONE) ! ! POP2 CHARACTER VALUES (NOMINAL VALUE * 8) ! *SYM0 = 0* %CONSTINTEGER SYMSP=128, SYMNL=136, SYMA=264, SYMZ=464 %CONSTINTEGER SYMLP=192, SYMRP=200, SYMLB=472, SYMRB=488, SYMPC=168 %CONSTINTEGER SYMMINUS=232, SYMDOT=240, SYMCOLON=80 %CONSTINTEGER SYMLA=96, SYMRA=112, SYM9=72, SYMQUOTE=144 %CONSTINTEGER SYMOPENQ=184, SYMCLOSEQ=256, SYMDOLLAR=480 %CONSTINTEGER SYMSUBTEN=120, SYMEND=152 %CONSTINTEGER SYMNLX=X'C0000088'; !IE SYMNL + FLAG + SIGNBIT ! %CONSTBYTEINTEGERARRAY ISO TO POP(0:127) = %C 64, 64, 64, 64, 64, 64, 64, 64, 64, 16, 17, 17, 17, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 19, 64, 64, 64, 64, 64, 64, 16, 32, 18, 20, 60, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 64, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 64, 61, 62, 64, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 64, 61, 62, 64 ! %CONSTBYTEINTEGERARRAY POP TO ISO(0:63) = %C '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', ':', ';', '<', '=', '>', '?', ' ', 10, 34, 25, '#', '%', '&','''', '(', ')', '*', '+', ',', '-', '.', '/', '!', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', '[', '$', ']', '^', ' ' ! %CONSTINTEGER UNASS=12; !IMPOSSIBLE REAL VALUE ! ! STRUCTURE CLASS CONSTANTS %CONSTINTEGER CSTRIPCLASS=X'18', FULLSTRIPCLASS=X'1C', REFCLASS=X'20' %CONSTINTEGER CSTRIPINFO=X'618', FULLSTRIPINFO=X'1C' %CONSTINTEGER REFHEADER=X'00010020' ! WORD TYPE MASKS %CONSTINTEGER TYPEBITS=X'FF000000' %CONSTINTEGER SYNBIT=X'80000000', CANBIT=X'40000000'; !*SYN IS SIGN* %CONSTINTEGER MACBIT=X'20000000', CLOSERBIT=X'20000000'; !*MAC=CLOSE* %CONSTINTEGER VARBITS=X'3F000000', VARBIT=X'10000000' %CONSTINTEGER PRECBITS=X'0F000000', SIGBITS=X'BF000000' ! POP-MACHINE INSTRUCTION MASKS %CONSTINTEGER OPBITS=X'FF000000'; !* OPBITS = TYPEBITS * %CONSTINTEGER FOPBITS=X'FF000001' %CONSTINTEGER ADBITS=X'00FFFFFF' ! POP-MACHINE OP-CODES (& RELATED FUNCTIONS) REQUIRED EXPLICITLY %CONSTINTEGER APPLY=X'74000000' %CONSTINTEGER SUBXFUN=X'8D000001', RECREFFUN=X'8E000001' %CONSTINTEGER RECCONSFUN=X'37000001' %CONSTINTEGER STORE=X'B0000000' %CONSTINTEGER NOT=X'55000000', PR=X'6B000000' %CONSTINTEGER CHARINFUN=X'3B000001' %CONSTINTEGER JUMPFALS=X'B4000000', JUMPTRUE=X'B6000000' %CONSTINTEGER INITXFUN=X'B2000001', RECDESTFUN=X'B3000001' %CONSTINTEGER CHAROUTFUN=X'B1000001' %CONSTINTEGER LOADIMM=X'30000004', GETFROZ=X'31000000' %CONSTINTEGER RESUME=X'28800000' %CONSTINTEGER RETURN=X'20000000' %CONSTINTEGER JUMP=X'34000000', JUMPBACK=X'35000000' %CONSTINTEGER ITEMINFUN=X'32000001' %CONSTINTEGER STARTFUN=X'21800001' ! PSEUDO-OPCODES %CONSTINTEGER SAVEMASK=X'FC000000', VARSAVE=X'80000000' %CONSTINTEGER INSAVE=X'81000000', OUTSAVE=X'82000000' %CONSTINTEGER INSAVEBIT=X'01000000', OUTSAVEBIT=X'02000000' ! POP WORDS REQUIRED EXPLICITLY (CONSTANT ADDRESSES) ! * ORDER OF DECLARATION MUST MATCH SETUP ORDER * %INTEGER NIL,UNDEF,TERMIN,TERMINVAL,FALSE %INTEGER NONMAC,LP,LB,QUOTE,LAMBDA,RB,DOT,ARROW,SEMICOLON,COLON,PARROW %INTEGER FUNCTION,MACRO,OPERATION,EXIT,CLOSE,RP,END,GOON %INTEGER COMPIL,PLUS,MINUS,PRIMLIM %INTEGER SYNTAX,CMPND,INTGR,STRIP,IN,OUT,EDIT %INTEGER CUCHARIN,CUCHAROUT,PROGLIST,DEBUG,DEBSP ! ! STORE BOUNDARIES (CONSTANT ADDRESSES - IN ASCENDING ORDER) %INTEGER STOREBASE,STREAM0,STREAMLIM,STACKMIN,STACKLIM %INTEGER WORDMIN,STRIPMIN,STORELIM ! OTHER CONSTANT ADDRESSES %INTEGER BASEPROG,WORDBASE,ZERO ! STACK AND LIMIT POINTERS %INTEGER ITEMHI,CLASSLO,ASP,SP,SPBAR,CSP,PAIRLO,WORDHI,STRIPHI %INTEGER PAIRFREE,WORDFREE,SYSLIM,BASEITEM ! INPUT/OUTPUT STATUS VARIABLES %INTEGER SYM,POS,POS1,ERROR,ERRPOS,MON %INTEGER STREAMMAX,INREF,OUTREF,OUTSYM %INTEGER MACSTREAM,MACEND,NONMACFLAG,INTFLAG ! ! POP-MACHINE REGISTERS %INTEGER A,B,INST,PC; !BASIC MACHINE CONTEXT %REAL XA,XB; !WORKING REGISTERS FOR REALS %INTEGER CODEBASE,PVBASE ! %BYTEINTEGERARRAY CHAR(1:81) %INTEGERARRAY INDEX(0:127) ! ! %ROUTINESPEC EXECUTE(%INTEGER FUN) ! %ROUTINE ANNOUNCE(%STRING(18) S) ! ENSURE OUTPUT 0 SELECTED AND PRINT STRING S %IF OUTREF # STREAM0 %START OUTREF = STREAM0; SELECT OUTPUT(0) %FINISH INTEGER(CUCHAROUT+2) = CHAROUTFUN+STREAM0 NEWLINE %IF OUTSYM # SYMNL; OUTSYM = SYMNL PRINT STRING(S) %END %ROUTINE CROAK(%STRING(15) S) ! REPORT DISASTROUS ERROR ANNOUNCE("!!!".S); %MONITOR; %STOP %END %INTEGERFN INTERRUPT INTFLAG = 50 %IF INTFLAG = 0 %AND TEST INT(0,"POP") = 0 %RESULT = INTFLAG %END %ROUTINE PUSH(%INTEGER V) ! ADD V TO AUXILIARY STACK ASP = ASP+4; %MONITOR 4 %IF ASP >= SP INTEGER(ASP) = V %END %ROUTINE PLANT(%INTEGER V) ! ADD V TO COMPILER STACK CSP = CSP+4; %MONITOR 4 %IF CSP >= PAIRLO INTEGER(CSP) = V %END %ROUTINE SAVE(%INTEGER V) ! ADD V TO USER STACK SP = SP-4; %MONITOR 4 %IF SP <= ASP INTEGER(SP) = V %END %INTEGERFN SAVED %MONITOR 3 %IF SP >= SPBAR; SP = SP+4 %RESULT = INTEGER(SP-4) %END %ROUTINE SEAL ! CREATE FALSE BOTTOM ON USER STACK SP = SP-4; %MONITOR 4 %IF SP <= ASP INTEGER(SP) = SPBAR; SPBAR = SP %END %ROUTINE UNSEAL %MONITOR 19 %IF SP # SPBAR SPBAR = INTEGER(SP); SP = SP+4 %END %INTEGERFN NEWCLASS(%INTEGER DATAWORD) CLASSLO = CLASSLO-4 CROAK("NO CLASSES") %IF CLASSLO <= ITEMHI INTEGER(CLASSLO) = DATAWORD %RESULT = STACKMIN-CLASSLO %END %INTEGERFN CLASSNO(%INTEGER V) %RESULT = 4 %IF V&7 = 0; !INTEGER %RESULT = 8 %IF V&3 = 0; !REAL %RESULT = 12 %IF V&2 = 0; !FUNCTION %RESULT = 16 %IF V < NIL; !PAIR %RESULT = 20 %IF V < STRIPMIN; !WORD %RESULT = BYTEINTEGER(V+5) %END %ROUTINE PUT SYM(%INTEGER K) %INTEGER F F = INTEGER(CUCHAROUT+2) %IF F&FOPBITS = CHAROUTFUN %START F = F-CHAROUTFUN %IF F # OUTREF %START OUTREF = F; SELECT OUTPUT((OUTREF-STREAM0)>>3) %FINISH OUTSYM = K %IF F = STREAM0 PRINT SYMBOL(POP TO ISO(K>>3)) %FINISH %ELSE %START SAVE(A); SAVE(B); SEAL; SAVE(K) EXECUTE(F) UNSEAL; B = SAVED; A = SAVED %FINISH %END %ROUTINE PUT INT(%INTEGER V) PUT INT(V//10) %AND V = V-(V//10)*10 %IF V >= 10 PUT SYM(V<<3) %END %INTEGERFN CHARWORD(%INTEGER W,I) %RESULT = 63*8 %IF I <= 0 %OR I > 8*8 I = I//8*6 %IF I <= 30 %THEN I = INTEGER(W+6)>>(30-I) %C %ELSE I = INTEGER(W+10)>>(60-I) %RESULT = (I<<1-1*8)&(63*8) %END %STRINGFN WORDTOSTRING(%INTEGER W) %STRING(8) S; %INTEGER K,L L = 0 %WHILE L < 8 %CYCLE K = CHARWORD(W,(L+1)<<3) %EXIT %IF K = 63*8 L = L+1; CHARNO(S,L) = POP TO ISO(K>>3) %REPEAT LENGTH(S) = L %RESULT = S %END %ROUTINE PUT STRING(%INTEGER V) %INTEGER I,L I = 0; L = INTEGER(V+2)>>16 %WHILE L # 0 %CYCLE L = L-1; I = I-6 V = V+4 %AND I = 24 %IF I < 0 PUT SYM((INTEGER(V+2)>>I<<1)&(63*8)) %REPEAT %END %ROUTINE PUT REAL(%LONGREAL X %INTEGER P,Q) %INTEGER SIGN,R SIGN = 0; X = -X %AND SIGN = SYMMINUS %IF X < 0 X = X+0.5/10**Q; !ROUND R = 1; X = X/10 %AND R = R+1 %WHILE X >= 10 P = P-1 %AND PUT SYM(SYMSP) %WHILE P > R PUT SYM(SIGN) %IF SIGN # 0 %CYCLE R = R-1,-1,-Q PUT SYM(SYMDOT) %IF R = -1 PUT SYM(INTPT(X)<<3); X = FRACPT(X)*10 %REPEAT %END %ROUTINE PUT ITEM(%INTEGER V) %INTEGER I,C %SWITCH S(1:6) INTFLAG = INTFLAG-1 %RETURN %IF INTFLAG <= 0 %AND INTERRUPT <= 0 C = CLASSNO(V) %IF C > CSTRIPCLASS %START PUT SYM(SYMLA) PUT ITEM(INTEGER(STACKMIN-C)) PUT SYM(SYMRA) %RETURN %FINISH ->S(C>>2) S(1): !INTEGER V = V//8 V = -V %AND PUT SYM(SYMMINUS) %IF V < 0 PUT INT(V) %RETURN S(2): !REAL V = V&(\7) PUT REAL(REAL(ADDR(V)),0,3) %RETURN S(3): !FUNCTION %IF V&OPBITS # 0 %START; !BUILT-IN FUNCTION V = V>>24<<4+WORDMIN; !FUNCTION NAME %IF V >= PRIMLIM %START; !UPDATER: DOWNDATE V = V!!X'300'; V = V!!X'800' %IF V >= X'900' PUT ITEM(ARROW) %FINISH %FINISH %ELSE %START PUT SYM(SYMDOLLAR) V = INTEGER(V+7); !FNPROPS V = INTEGER(V+2) %IF V&2 # 0 %AND V < NIL; !FRONT IF PAIR %RETURN %UNLESS V&2 # 0 %AND WORDMIN < V < STRIPMIN %FINISH S(5): !WORD %CYCLE I = 1*8,1*8,8*8 C = CHARWORD(V,I) %EXIT %IF C = 63*8 PUT SYM(C) %REPEAT %RETURN S(6): !CSTRIP PUT SYM(SYMOPENQ) PUT STRING(V) PUT SYM(SYMCLOSEQ) %RETURN S(4): !PAIR PUT SYM(SYMLB) %CYCLE PUT ITEM(INTEGER(V+2)); !FRONT V = INTEGER(V+6); !BACK %EXIT %UNLESS V&2 # 0 %AND V < NIL PUT SYM(SYMSP) %REPEAT PUT SYM(SYMDOT) %AND PUT ITEM(V) %IF V # NIL PUT SYM(SYMRB) %END %ROUTINE PRINT(%INTEGER V) ! FOR ERRORS -- PRINT QUOTES ROUND WORD EXCEPT NIL, ETC %IF V&2 # 0 %AND FALSE < V < STRIPMIN %START PUT SYM(SYMQUOTE); PUT ITEM(V); PUT SYM(SYMQUOTE) %FINISH %ELSE PUT ITEM(V) %END %ROUTINE COMMENT(%STRING(7) S %INTEGER W) ! REPORT MINOR COMPILATION ERROR ANNOUNCE(S) %IF OUTSYM = SYMNL %OR S # " VARS " PUT SYM(SYMSP); PUT ITEM(W) PUT SYM(SYMNL) %IF S # " VARS " %END %ROUTINE MONITOR(%INTEGER P) ! PRINT FUNCTION NAME AND VARIABLES SELECTED BY MON ! P IS ADDRESS OF FIRST INSTRUCTION ! INSAVEBIT: INPUT VARS, OUTSAVEBIT: OUTPUT VARS, VARSAVE: ALL VARS %INTEGER Q PUT ITEM(P-15); !FUNCTION %WHILE INTEGER(P)&SAVEMASK = VARSAVE %CYCLE %IF INTEGER(P)&MON # 0 %START B = INTEGER(P)&ADBITS; !'WORD' ASSOCIATED WITH VAR Q = INTEGER(B+2); !VALUE %IF Q # UNASS %START SPACES(2); PUT ITEM(B) PRINT SYMBOL('='); PRINT(Q) %FINISH %FINISH P = P+4 %REPEAT PUT SYM(SYMNL) %END %ROUTINE FORCE RETURN ! UNSTACK ONE LEVEL (EXECUTION OR COMPILATION) %IF PC >= STRIPMIN %START; !IN USER FUNCTION %WHILE INTEGER(PC)&OPBITS # RETURN %CYCLE; !FIND (FIRST) RETURN PC = PC+INTEGER(PC)&ADBITS %C %IF INTEGER(PC)&X'FE000000' = X'30000000'; !LOADIMM, GETFROZ PC = PC+4 %REPEAT PC = PC+4-INTEGER(PC)&ADBITS; !FIRST INST PRINT STRING(" IN ") %AND MONITOR(PC) %IF MON # 0 %WHILE INTEGER(PC)&SAVEMASK = VARSAVE %CYCLE; !RESTORE VARS INTEGER(INTEGER(PC)&ADBITS+2) = INTEGER(ASP) ASP = ASP-4; PC = PC+4 %REPEAT %FINISH %ELSE %START %IF PC = 0 %START; !COMPILING %IF MON # 0 %AND CODEBASE # 0 %START PRINT STRING(" COMPILING $") PUT ITEM(INTEGER(CODEBASE+4)) PUT SYM(SYMNL) %FINISH CSP = PVBASE-16 PVBASE = INTEGER(CSP+16); CODEBASE = INTEGER(CSP+12) INTEGER(PROGLIST+2) = INTEGER(CSP+8) ASP = INTEGER(CSP+4) %FINISH %FINISH PC = INTEGER(ASP); ASP = ASP-4 %END %INTEGERFN PAIRCELL(%INTEGER FRONT,BACK) %INTEGER P P = PAIRFREE %IF P # 0 %START PAIRFREE = INTEGER(P+2) %FINISH %ELSE %START CROAK("NO LIST CELLS") %IF PAIRLO-8 <= CSP PAIRLO = PAIRLO-8; P = PAIRLO %FINISH INTEGER(P+2) = FRONT; INTEGER(P+6) = BACK %RESULT = P %END %INTEGERFN WORDCELL(%INTEGER W1,W2) %INTEGER P P = WORDHI WORDHI = WORDHI+16 CROAK("NO WORD CELLS") %IF WORDHI > STRIPMIN INTEGER(P+2) = UNASS; INTEGER(P+6) = W1 INTEGER(P+10) = W2; INTEGER(P+14) = UNDEF %RESULT = P %END %INTEGERFN WORDLOOK(%INTEGER W1,W2) %INTEGER HASH,W,P %INTEGERNAME Q W = W1!!W2; HASH = 0 %WHILE W # 0 %CYCLE HASH = HASH<<1+W&63 W = W>>6 %REPEAT Q == INDEX(HASH&127) %WHILE Q&X'3FFF' # 0 %CYCLE P = (Q&X'3FFF')<<4+WORDBASE %RESULT = P %IF INTEGER(P+6) = W1 %C %AND INTEGER(P+10)&(\X'3FFF') = W2 Q == INTEGER(P+10) %REPEAT P = WORDCELL(W1,W2) Q = Q+(P-WORDBASE)>>4 %RESULT = P %END %INTEGERFN VAR(%INTEGER V,TYPE) %INTEGER T,W T = INTEGER(V+14); !EXISTING TYPE+MEANING %IF T&SIGBITS # 0 %START; !V IS ALREADY VAR %RESULT = V %IF T&CANBIT = 0 %RESULT = (INTEGER(V+10)&X'3FFF')<<4+WORDBASE %FINISH %RESULT = V %IF TYPE = 0 INTEGER(V+14) = T!TYPE; !MARK V AS VAR %RESULT = V %IF T&CANBIT = 0 W = WORDCELL(INTEGER(V+6),INTEGER(V+10)); !CREATE NEW PSEUDO-WORD INTEGER(W+14) = TYPE INTEGER(V+10) = INTEGER(V+10)&(\X'3FFF')!((W-WORDBASE)>>4) %RESULT = W %END %INTEGERFN STRIPCELL(%INTEGER STRIPINFO) !RESULT IS ALWAYS EXISTING STRIPHI !AFTER CALL, STRIPHI IS ALWAYS AT STRIP LIMIT %INTEGER K,L K = STRIPINFO>>16; !NO OF COMPONENTS L = STRIPINFO>>8&31; !COMPONENT SIZE K = (K-1)//(32//L)+1 %IF L # 0 K = K<<2+4; !SIZE OF STRIP IN BYTES (+4 FOR HEADER) CROAK("NO STRIP SPACE") %IF STRIPHI+K > STORELIM INTEGER(STRIPHI+2) = STRIPINFO; STRIPHI = STRIPHI+K %RESULT = STRIPHI-K %END %INTEGERFN INITSTRIP(%INTEGER STRIPINFO) %INTEGER P,Q P = STRIPCELL(STRIPINFO); Q = STRIPHI %CYCLE Q = Q-4 %RESULT = P %IF Q = P %MONITOR 3 %IF SP = SPBAR INTEGER(Q+2) = INTEGER(SP); SP = SP+4 %REPEAT %END %ROUTINE ITEMISE(%INTEGER REPREF) ! FORM UP ITEM USING REPEATER SPECIFIED BY REPREF ! PENDING SYMBOL(S) STORED IN INTEGER(REPREF) ! IF REPREF < STREAMLIM, REPEATER IS STREAM (REPREF-STREAM0)>>3 ! OTHERWISE, REPEATER FUNCTION IS IN INTEGER(REPREF+4) %INTEGER LAST,J,K,R,V1,V2 %LONGREAL X ! %INTEGERFN SYMTYPE(%INTEGER S) %CONSTINTEGER SIGNSET1=B'10101100010100000111010000000000' %CONSTINTEGER SIGNSET2=B'01010000000000000000000000000000' %RESULT = 2 %IF S <= SYM9 %OR SYMA <= S <= SYMZ S = S>>3 %RESULT = SIGNSET1>>S&1 %IF S < 32 %RESULT = SIGNSET2>>(S-32)&1 %END %ROUTINE READ SYM LAST = SYM %IF SYM&X'1FF' = SYMNL %START POS = 0 %FINISH %IF REPREF < STREAMLIM %START %IF REPREF # INREF %START INREF = REPREF; SELECT INPUT((INREF-STREAM0)>>3) %FINISH READ CH(SYM) %AND SYM = ISO TO POP(SYM&127) %UNTIL SYM # 64 SYM = SYM<<3 %FINISH %ELSE %START SEAL EXECUTE(INTEGER(REPREF+4)) SYM = SAVED; SYM = SYMEND %IF SYM&X'FFFFF807' # 0 UNSEAL %FINISH POS = POS+1 %IF POS # 81; CHAR(POS) = SYM>>3 %END J = 0; K = 0; R = 10 SYM = INTEGER(REPREF) %IF SYM&X'7E000' # 0 %START; !TWO SYMBOLS PENDING LAST = SYM>>9; SYM = SYM&X'1FF' POS1 = POS-1 %FINISH %ELSE %START READ SYM %WHILE SYM < 0 %OR SYM = SYMSP %OR SYM = SYMNL %IF SYM = SYMEND %START SYM = SYM+X'80000000'; !FAULT 9 NEXT TIME A = TERMINVAL ->FIN %FINISH POS1 = POS READ SYM %FINISH !NEXT TWO SYMBOLS NOW IN LAST AND SYM %IF LAST <= SYM9 %START; !DIGIT X = LAST>>3 %IF SYM = SYMCOLON %AND (X=2 %OR X=8) %START; !BINARY,OCTAL? READ SYM ->HOLD %IF SYM > SYM9 R = INT(X); X = 0 %FINISH X = X*R+(SYM>>3) %AND READ SYM %WHILE SYM <= SYM9 %IF SYM = SYMDOT %START; !REAL? READ SYM ->FRAC %IF SYM <= SYM9 HOLD: SYM = LAST<<9+SYM %FINISH A = INT(X)<<3 ->FIN %FINISH %IF LAST = SYMDOT %AND SYM <= SYM9 %START; !REAL WITHOUT INT PART X = 0 FRAC: %UNTIL SYM > SYM9 %CYCLE J = J+1; X = X+(SYM>>3)/(R**J) READ SYM %REPEAT %IF SYM = SYMSUBTEN %START; !EXPONENT J = 0; READ SYM; K = 1 %AND READ SYM %IF SYM = SYMMINUS J = J*10+(SYM>>3) %AND READ SYM %WHILE SYM <= SYM9 %IF K = 0 %THEN X = X*(R**J) %ELSE X = X/(R**J) %FINISH A = INTEGER(ADDR(X))&(\7)+4; !LOW-ORDER 3 BITS = 1 0 0 ->FIN %FINISH %IF LAST = SYMOPENQ %START; !STRING %CYCLE K = K-1000000 %IF SYM = SYMOPENQ; !NESTED STRING %IF SYM = SYMCLOSEQ %START %EXIT %IF K >= 0; K = K+1000000 %FINISH K = K+1; J = J-6 J = 24 %AND SAVE(0) %IF J < 0; !WORD BOUNDARY INTEGER(SP) = INTEGER(SP)+SYM>>1<FIN %FINISH V1 = (LAST+1*8)<<23; V2 = 0; !WORD J = 24; K = SYMTYPE(LAST) ->PACK %IF (LAST = SYMLP %OR LAST = SYMLB) %AND SYM = SYMPC ->PACK %IF LAST = SYMPC %AND (SYM = SYMRP %OR SYM = SYMRB) %WHILE 0 # K = SYMTYPE(SYM) %CYCLE PACK: J = J-6 %IF J >= 0 %THEN V1 = V1!((SYM+1*8)>>1)<= -18 %FINISH READ SYM %REPEAT A = WORDLOOK(V1,V2) FIN:INTEGER(REPREF) = SYM %END %ROUTINE READ PROGRAM ITEM %INTEGER P,Q L1: P = INTEGER(PROGLIST+2); !VALUE OF PROGLIST %MONITOR 10 %UNLESS P&2 # 0 %AND P < NIL; !MUST BE PAIR Q = INTEGER(P+6); !BACK %IF Q&1 = 0 %START; !NOT FUNCTION A = INTEGER(P+2); !TAKE FRONT AS ITEM INTEGER(PROGLIST+2) = Q; !SET PROGLIST TO BACK %FINISH %ELSE %START %IF Q&FOPBITS = ITEMINFUN %START; !FUNCTION CREATED BY INCHARITEM ITEMISE(Q-ITEMINFUN) %FINISH %ELSE %START EXECUTE(Q); A = SAVED %FINISH A = GOON %IF A = TERMINVAL %FINISH NONMACFLAG = 0 %AND %RETURN %IF NONMACFLAG # 0 NONMACFLAG = 1 %AND ->L1 %IF A = NONMAC %IF A&2 # 0 %AND WORDMIN <= A < STRIPMIN %C %AND INTEGER(A+14)&SIGBITS = MACBIT %START; !MACRO SEAL; EXECUTE(INTEGER(VAR(A,0)+2)); UNSEAL INTEGER(MACEND+6) = INTEGER(PROGLIST+2) INTEGER(PROGLIST+2) = MACSTREAM MACSTREAM = NIL; MACEND = ADDR(MACSTREAM)-6 ->L1 %FINISH %END %ROUTINE TEST REALS ! TEST OPERANDS NUMERIC, CONVERT INTEGER TO REAL %MONITOR 11 %IF (A!B)&3 # 0 INTEGER(ADDR(XA)) = A&(\7); XA = A//8 %IF A&7 = 0 INTEGER(ADDR(XB)) = B&(\7); XB = B//8 %IF B&7 = 0 %END %REALFN REALB %MONITOR 10 %IF B&3 # 0 INTEGER(ADDR(XB)) = B&(\7); XB = B//8 %IF B&7 = 0 %RESULT = XB %END %ROUTINE EXECUTE(%INTEGER FUN) %INTEGER I,J,K,P,Q,W1,W2,SAVEDINST %INTEGER CSTATE,OPENER,LAST,CSPBAR,SAVEOP,VTYPE %INTEGER TYPE,LABPOS %CONSTINTEGER IDENTSTATE=X'2D3FFF01', CONSTSTATE=X'253FFF00' %CONSTINTEGER SKIPSTATE=X'FFFFFF0F' %CONSTINTEGER LPRPBITS=X'08001000', RPBIT=X'00001000' %CONSTINTEGER INITSTATE=X'FFFFFF00' %SWITCH X(X'00':X'CF') %SWITCH C(0:47) %SWITCH D(0:15) ASP = ASP+4; ->ER31 %IF ASP >= SP INTEGER(ASP) = PC PC = STACKMIN; !ADDRESS OF 'RESUME' INST SAVEDINST = INST; INST = APPLY; B = FUN ->CALL ! ER30:%MONITOR 3 ER31:%MONITOR 4 ER20:%MONITOR 10 ER21:%MONITOR 11 ER22:B = TERMINVAL %IF B = UNASS ERROR = 22 %MONITOR 16 ! X(X'74'): !APPLY CALL: ->ER20 %IF B&1 = 0; !NOT FUNCTION -> INST = B-1 %AND ->X00 %IF B&OPBITS # 0; !BUILT-IN -> ASP = ASP+4; ->ER31 %IF ASP >= SP INTEGER(ASP) = PC PC = B+15; !FIRST INST (PURE WORD ADDRESS) %IF INTEGER(PC)&SAVEMASK = VARSAVE %START PC = PC+4 %UNTIL INTEGER(PC)&SAVEMASK # VARSAVE I = PC %UNTIL I = B+15 %CYCLE; !SAVE IN REVERSE ORDER I = I-4 J = INTEGER(I)&ADBITS ASP = ASP+4; ->ER31 %IF ASP >= SP INTEGER(ASP) = INTEGER(J+2) %IF INTEGER(I)&INSAVEBIT = 0 %START; !NOT INPUT VAR INTEGER(J+2) = UNASS; !INITIALISE TO UNASS %FINISH %ELSE %START ->ER30X %IF SP = SPBAR; !STACK EMPTY -> INTEGER(J+2) = INTEGER(SP); SP = SP+4 %FINISH %REPEAT %FINISH %IF INTEGER(DEBUG+2) # 0 %AND INTEGER(B+3)&4 # 0 %START I = INTEGER(DEBSP+2); I = 0 %IF I&X'FFFFFF07' # 0 INTEGER(DEBSP+2) = I+8 ANNOUNCE(" "); SPACES(I>>3); PRINT SYMBOL('>') MON = INSAVEBIT; MONITOR(B+15) %FINISH ->X0 ER30X: !MUST COMPLETE SOMEHOW %CYCLE INTEGER(J+2) = UNASS %EXIT %IF I = B+15 I = I-4 J = INTEGER(I)&ADBITS ASP = ASP+4; ->ER31 %IF ASP >= SP INTEGER(ASP) = INTEGER(J+2) %REPEAT ->ER30 X(X'C4'): !APPLY UPDATER ->ER20 %IF X'70000001' # B&X'70000001' # 1; !NOT 'UPDATABLE' INST = B&X'7FFFFFFF'!!X'B0000001' %AND ->X10 %IF B&OPBITS # 0 SAVE(A); B = INTEGER(B+11) ->CALL ! X(X'B8'): !->DUP-> ((DEFIES DESCRIPTION)) A = SAVED X(X'B0'): !-> (STORE) INTEGER(INST&ADBITS+2) = A; !*STORE HAS IMMEDIATE OPERAND* X(X'B5'): !"ERASE" !EXECUTION POINT WHEN A FREE X0: INST = INTEGER(PC); PC = PC+4 X00:B = INST&ADBITS %IF B = 0 %START; !NO OPERAND SPECIFIED - POP STACK ->ER30 %IF SP = SPBAR B = INTEGER(SP); SP = SP+4 %FINISH %ELSE %START %IF B&3 = 3 %START; !VARIABLE REFERENCE B = INTEGER(B+1) ->ER22 %IF B = UNASS %FINISH %FINISH; !OTHERWISE B AS IMMEDIATE OPERAND %IF INST < 0 %START; !BINARY OPERATOR ->ER30 %IF SP = SPBAR A = INTEGER(SP); SP = SP+4 %FINISH ->X(INST>>24) ! X(X'88'): !DUP-> (DUPLICATE & STORE) INTEGER(INST&ADBITS+2) = A ->X1 X(X'30'): !LOAD IMMEDIATE - FROM WORD AFTER INST B = INTEGER(PC); PC = PC+4 X(X'00'): !<- (LOAD) LOADB: A = B X(X'B7'): !"IDENTFN" !EXECUTION POINT WHEN A OCCUPIED X1: INST = INTEGER(PC); PC = PC+4 X10:B = INST&ADBITS %IF B = 0 %START B = A %IF INST < 0 %START ->ER30 %IF SP = SPBAR A = INTEGER(SP); SP = SP+4 %FINISH %FINISH %ELSE %START %IF B&3 = 3 %START B = INTEGER(B+1) ->ER22 %IF B = UNASS %FINISH %IF INST >= 0 %START SP = SP-4; ->ER31 %IF SP <= ASP INTEGER(SP) = A %FINISH %FINISH ->X(INST>>24) ! X(X'20'): !RETURN PC = PC-B; !FIRST INST %IF INTEGER(DEBUG+2) # 0 %AND INTEGER(PC-12)&4 # 0 %START I = INTEGER(DEBSP+2)-8; I = 0 %IF I&X'FFFFFF07' # 0 INTEGER(DEBSP+2) = I ANNOUNCE(" "); SPACES(I>>3); PRINT SYMBOL('<') MON = OUTSAVEBIT; MONITOR(PC) %FINISH %WHILE INTEGER(PC)&SAVEMASK = VARSAVE %CYCLE A = INTEGER(PC)&ADBITS %IF INTEGER(PC)&OUTSAVEBIT # 0 %START SP = SP-4; INTEGER(SP) = INTEGER(A+2) %FINISH INTEGER(A+2) = INTEGER(ASP); ASP = ASP-4 PC = PC+4 %REPEAT PC = INTEGER(ASP); ASP = ASP-4 ->X0 X(X'A9'): !"QBUG" ->ER20 %IF A&FOPBITS # 1 !USE CLASS SLOT OF HEADER FOR FLAG (OK?) %IF B # 0 %THEN INTEGER(A+3) = INTEGER(A+3)!4 %C %ELSE INTEGER(A+3) = INTEGER(A+3)&(\4) ->X0 X(X'34'): !JUMP PC = PC+B ->X0 X(X'35'): !JUMP BACK PC = PC-B INTFLAG = INTFLAG-1 ->X0 %IF INTFLAG > 0 %OR INTERRUPT > 0 ->POPRDY X(X'B4'): !JUMP FALSE PC = PC+B %IF A = 0 ->X0 X(X'B6'): !JUMP TRUE PC = PC+B %IF A # 0 ->X0 ! X(X'90'): !"=" ->TRU %IF A = B FALS: A = 0 ->X1 X(X'91'): !"\=" ->FALS %IF A = B TRU: A = 1*8 ->X1 X(X'92'): !"<=" ->TRU %IF (A!!B)&(\4) = 0 %AND A&3 = 0 X(X'93'): !"<" %IF (A!B)&7 = 0 %START ->TRU %IF A < B ->FALS %FINISH TEST REALS; ->TRU %IF XA < XB ->FALS X(X'95'): !">=" ->TRU %IF (A!!B)&(\4) = 0 %AND A&3 = 0 X(X'94'): !">" %IF (A!B)&7 = 0 %START ->TRU %IF A > B ->FALS %FINISH TEST REALS; ->TRU %IF XA > XB ->FALS X(X'96'): !"+" A = A+B %AND ->X1 %IF (A!B)&7 = 0 TEST REALS; XA = XA+XB RSET: A = INTEGER(ADDR(XA))&(\7)+4 ->X1 X(X'97'): !"-" A = A-B %AND ->X1 %IF (A!B)&7 = 0 TEST REALS; XA = XA-XB ->RSET X(X'51'): !"INTOF" A = INTPT(REALB)*8 ->X1 X(X'52'): !"REALOF" ->ER20 %IF B&7 # 0 XA = B//8 ->RSET X(X'53'): !"SIGN" ->ER20 %IF B&3 # 0 ->FALS %IF B&(\4) = 0 ->TRU %IF B > 0 A = -1*8 ->X1 X(X'98'): !"*" A = A//8*B %AND ->X1 %IF (A!B)&7 = 0 TEST REALS; XA = XA*XB ->RSET X(X'99'): !"/" TEST REALS; XA = XA/XB ->RSET X(X'9A'): !"//" ->ER20 %IF (A!B)&7 # 0 I = A//B; B = A-I*B; A = I*8 PUSHB: SP = SP-4; ->ER31 %IF SP <= ASP INTEGER(SP) = B ->X1 X(X'9B'): !"^" ->ER20 %IF B&7 # 0 TEST REALS; XA = XA**(B//8) ->RSET X(X'62'): !"SIN" XA = SIN(REALB) ->RSET X(X'63'): !"COS" XA = COS(REALB) ->RSET X(X'64'): !"TAN" XA = TAN(REALB) ->RSET X(X'65'): !"ARCTAN" XA = ARCTAN(1,REALB) ->RSET X(X'66'): !"SQRT" XA = SQRT(REALB) ->RSET X(X'67'): !"LOG" XA = LOG(REALB) ->RSET X(X'68'): !"EXP" XA = EXP(REALB) ->RSET X(X'3F'): !"POPTIME" XA = CPUTIME ->RSET X(X'3E'): !"COREUSED" A = (WORDHI-PAIRLO+STRIPHI-STRIPMIN+10000)<<3 ->X1 X(X'A0'): !"LOGAND" ->ER20 %IF (A!B)&7 # 0 A = A&B ->X1 X(X'A1'): !"LOGOR" ->ER20 %IF (A!B)&7 # 0 A = A!B ->X1 X(X'5F'): !"LOGNOT" ->ER20 %IF B&7 # 0 A = B!!(\7) ->X1 X(X'A2'): !"LOGSHIFT" ->ER20 %IF (A!B)&7 # 0 I = B//8 %IF I >= 0 %THEN A = A<>(-I)&(\7) ->X1 X(X'55'): !"NOT" ->TRU %IF B = 0 ->FALS X(X'A3'): !"BOOLAND" ->FALS %IF B = 0 ->X1 X(X'A4'): !"BOOLOR" ->TRU %IF B # 0 ->X1 X(X'A6'): !"SAMEDATA" ->TRU %IF CLASSNO(A) = CLASSNO(B) ->FALS X(X'56'): !"ISCOMPND" ->TRU %IF B&3 # 0 ->FALS X(X'57'): !"ISINTEGER" ->TRU %IF B&7 = 0 ->FALS X(X'58'): !"ISREAL" ->TRU %IF B&7 = 4 ->FALS X(X'59'): !"ISWORD" ->TRU %IF B&2 # 0 %AND WORDMIN <= B < STRIPMIN ->FALS X(X'5A'): !"ISFUNC" ->TRU %IF B&1 # 0 ->FALS X(X'5B'): !"ATOM" ->TRU %UNLESS B&2 # 0 %AND B < NIL ->FALS X(X'5C'): !"ISLIST" ->TRU %IF B = NIL X(X'5D'): !"ISLINK" ->FALS %UNLESS B&2 # 0 %AND B < NIL A = INTEGER(B+6); !BACK ->TRU %IF A&2 # 0 %AND A <= NIL ->FALS %IF A&1 = 0 A = INTEGER(B+2); !FRONT (FALSE,NOT) ->X1 ! %ROUTINE SOLIDIFY ! SOLIDIFY LIST B WHEN BACK DISCOVERED TO BE FUNCTION %INTEGER I B = NIL %AND %RETURN %IF INTEGER(B+2) = 0 SAVE(A); SAVE(B); SEAL EXECUTE(INTEGER(B+6)) I = SAVED UNSEAL; B = INTEGER(SP); A = INTEGER(SP+4); SP = SP+8 %IF I # TERMINVAL %START INTEGER(B+2) = I INTEGER(B+6) = PAIRCELL(1*8,INTEGER(B+6)) %FINISH %ELSE %START INTEGER(B+2) = 0 B = NIL %FINISH %END %ROUTINE LIST TO STACK %MONITOR 10 %UNLESS B&2 # 0 %AND B <= NIL SEAL %WHILE B&2 # 0 %AND B < NIL %CYCLE %IF INTEGER(B+6)&1 # 0 %START SOLIDIFY; %EXIT %IF B = NIL %FINISH SP = SP-4; %MONITOR 4 %IF SP <= ASP INTEGER(SP) = INTEGER(B+2); B = INTEGER(B+6) %REPEAT %END X(X'5E'): !"NULL" ->ER20 %UNLESS B&2 # 0 %AND B <= NIL ->TRU %IF B = NIL ->FALS %IF INTEGER(B+6)&1 = 0 SOLIDIFY ->TRU %IF B = NIL ->FALS X(X'9C'): !"::" X(X'9E'): !"CONS" ->ER20 %UNLESS B&2 # 0 %AND B <= NIL X(X'9F'): !"CONSPAIR" CP: A = PAIRCELL(A,B) ->X1 X(X'42'): !"FNTOLIST" ->ER20 %IF B&1 = 0 A = 1*8 ->CP X(X'76'): !"HD" ->ER20 %UNLESS B&2 # 0 %AND B < NIL %IF INTEGER(B+6)&1 # 0 %START SOLIDIFY X(X'77'): !"FRONT" FRN: ->ER20 %UNLESS B&2 # 0 %AND B < NIL %FINISH A = INTEGER(B+2) ->X1 X(X'C6'): !->"HD" ->ER20 %UNLESS B&2 # 0 %AND B < NIL %IF INTEGER(B+6)&1 # 0 %START SOLIDIFY X(X'C7'): !->"FRONT" ->ER20 %UNLESS B&2 # 0 %AND B < NIL %FINISH INTEGER(B+2) = A ->X0 X(X'78'): !"TL" ->ER20 %UNLESS B&2 # 0 %AND B < NIL A = INTEGER(B+6) ->X1 %IF A&1 = 0 SOLIDIFY X(X'79'): !"BACK" BAC:->ER20 %UNLESS B&2 # 0 %AND B < NIL A = INTEGER(B+6) ->X1 X(X'C8'): !->"TL" ->ER20 %UNLESS B&2 # 0 %AND B < NIL %IF INTEGER(B+6)&1 # 0 %START SOLIDIFY X(X'C9'): !->"BACK" ->ER20 %UNLESS B&2 # 0 %AND B < NIL %FINISH INTEGER(B+6) = A ->X0 X(X'43'): !"DEST" ->ER20 %UNLESS B&2 # 0 %AND B < NIL A = INTEGER(B+6) %IF A&1 # 0 %START SOLIDIFY X(X'44'): !"DESTPAIR" ->ER20 %UNLESS B&2 # 0 %AND B < NIL A = INTEGER(B+6); !BACK %FINISH B = INTEGER(B+2); !FRONT ->PUSHB X(X'4B'): !"COPYLIST" LIST TO STACK X(X'2A'): !"%]" (DECORATED RB) PC=PC+4 %AND ->MR1 %IF INTEGER(PC) = X'69000000'; !MACRESULTS -> A = NIL STACK TO LIST: A = PAIRCELL(INTEGER(SP),A) %AND SP = SP+4 %WHILE SP # SPBAR UNSEAL ->X1 X(X'9D'): !"<>" ->ER20 %UNLESS A&2 # 0 %AND A <= NIL I = B; B = A; A = I LIST TO STACK ->STACK TO LIST X(X'54'): !"REV" LIST TO STACK I = SPBAR; A = NIL I = I-4 %AND A = PAIRCELL(INTEGER(I),A) %WHILE I # SP R1: SP = SPBAR; UNSEAL ->X1 X(X'61'): !"LENGTH" LIST TO STACK A = (SPBAR-SP)<<1; !>>2<<3 ->R1 X(X'69'): !"MACRESULTS" LIST TO STACK MR1:I = SPBAR %WHILE I # SP %CYCLE I = I-4 INTEGER(MACEND+6) = PAIRCELL(INTEGER(I),NIL) MACEND = INTEGER(MACEND+6) %REPEAT SP = SPBAR; UNSEAL ->X0 X(X'40'): !"CONSREF" A = STRIPCELL(REFHEADER) INTEGER(A+6) = B ->X1 X(X'41'): !"DESTREF" X(X'7A'): !"CONT" ->ER20 %UNLESS CLASSNO(B) = REFCLASS A = INTEGER(B+6) ->X1 X(X'CA'): !->"CONT" ->ER20 %UNLESS CLASSNO(B) = REFCLASS INTEGER(B+6) = A ->X0 X(X'48'): !"CONSWORD" ->ER20 %IF B&7 # 0 %OR B <= 0 W1 = 0; W2 = 0 I = 30-B>>3*6 %WHILE I # 30 %CYCLE A = SAVED ->ER21 %IF A&X'FFFFF807' # 0 %OR A = 63*8 %IF I >= 0 %THEN W1 = W1!(A+1*8)>>1<= -18 %FINISH I = I+6 %REPEAT A = WORDLOOK(W1,W2) ->X1 X(X'A5'): !"CHARWORD" ->ER20 %UNLESS A&2 # 0 %AND WORDMIN <= A < STRIPMIN ->ER20 %UNLESS B&7 = 0 I = CHARWORD(A,B) CW: ->ER20 %IF I = 63*8 A = I ->X1 X(X'45'): !"DESTWORD" ->ER20 %UNLESS B&2 # 0 %AND WORDMIN <= B < STRIPMIN A = 0 %CYCLE I = CHARWORD(B,A+1*8) %EXIT %IF I = 63*8 SAVE(I); A = A+1*8 %REPEAT ->X1 X(X'46'): !"IDENTPROPS" ->ER20 %UNLESS B&2 # 0 %AND WORDMIN <= B < STRIPMIN B = INTEGER(B+14)&SIGBITS A = UNDEF; ->X1 %IF B = 0 A = SYNTAX; ->X1 %IF B < 0 A = MACRO; ->X1 %IF B = MACBIT A = (B&PRECBITS)>>21; !>>24<<3 ->X1 X(X'7C'): !"DATAWORD" A = INTEGER(STACKMIN-CLASSNO(B)) ->X1 X(X'CC'): !->"DATAWORD" I = CLASSNO(B) ->ER20 %IF I <= REFCLASS %OR (A&2 # 0 %AND A >= STRIPMIN) INTEGER(STACKMIN-I) = A ->X0 X(X'3D'): !"STACKLENGTH" A = (SPBAR-SP)<<1; !>>2<<3 ->X1 X(X'09'): !"(%" SAVE(UNDEF); !WILL BECOME UPDATER !SEAL WILL BECOME GETFROZ X(X'0B'): !"[%" (DECORATED LB) SEAL ->X0 X(X'A7'): !"PARTAPPLY" SAVE(A); SAVE(UNDEF); LIST TO STACK X(X'2B'): !"%)" ! 7 FNPROPS ! 11 UPDATER ! 15 'GETFROZ' ! FROZ VALS ! 19+ FUN ! 23+ RETURN B = INTEGER(SPBAR+8); ->ER20 %IF B&1 = 0 SAVE(B); SAVE(RETURN+SPBAR-SP+8) J = SPBAR+12; SPBAR = INTEGER(SPBAR) INTEGER(J-12) = GETFROZ+J-SP-16; !FROZVAL BYTES + 4 I = J-SP !CREATE FUNCTION CELL A = INITSTRIP(I<<14)-1; !>>2<<16 ->X1 %IF X'70000000' # B&X'70000000' # 0 %IF B&OPBITS = 0 %THEN B = INTEGER(B+11) %C %ELSE B = B&X'7FFFFFFF'!!X'B0000000' %IF B # UNDEF %START SP = J-I; INTEGER(SP+4) = B INTEGER(A+11) = INITSTRIP(I<<14)-1 %FINISH ->X1 X(X'31'): !GETFROZ %WHILE B > 4 %CYCLE SP = SP-4; ->ER31 %IF SP <= ASP INTEGER(SP) = INTEGER(PC) PC = PC+4; B = B-4 %REPEAT B = INTEGER(PC); PC = PC+4 INST = APPLY ->CALL X(X'75'): !"VALOF" ->ER20 %UNLESS B&2 # 0 %AND WORDMIN <= B < STRIPMIN B = VAR(B,VARBIT) ->ER20 %IF INTEGER(B+14) < 0; !SYNTAX -> A = INTEGER(B+2) A = UNDEF %IF A = UNASS ->X1 X(X'C5'): !->"VALOF" ->ER20 %UNLESS B&2 # 0 %AND WORDMIN <= B < STRIPMIN B = VAR(B,VARBIT) ->ER20 %IF B < SYSLIM; !PROTECTED -> INTEGER(B+2) = A ->X0 X(X'7B'): !"MEANING" ->ER20 %UNLESS B&2 # 0 %AND WORDMIN <= B < STRIPMIN A = INTEGER(B+14)&ADBITS ->X1 X(X'CB'): !->"MEANING" ->ER20 %UNLESS B&2 # 0 %AND WORDMIN <= B < STRIPMIN ->ER20 %UNLESS A&TYPEBITS = 0; !(RESTRICTION) INTEGER(B+14) = INTEGER(B+14)&TYPEBITS+A ->X0 X(X'7D'): !"FNPROPS" ->ER20 %IF B&1 = 0 ->LOADB %IF B&OPBITS # 0; !B ITSELF IF BUILT-IN A = INTEGER(B+7) ->X1 X(X'CD'): !->"FNPROPS" ->ER20 %IF B&FOPBITS # 1 INTEGER(B+7) = A ->X0 X(X'7E'): !"UPDATER" ->ER20 %IF X'70000001' # B&X'70000001' # 1 %IF B&OPBITS = 0 %THEN A = INTEGER(B+11) %C %ELSE A = B&X'7FFFFFFF'!!X'B0000000' ->X1 X(X'CE'): !->"UPDATER" ->ER20 %IF B&FOPBITS # 1 %OR A&1 = 0 INTEGER(B+11) = A ->X0 X(X'7F'): !"FNPART" ->ER20 %IF B&FOPBITS # 1 I = INTEGER(B+15)!!GETFROZ; ->ER20 %IF I&OPBITS # 0 A = INTEGER(B+I+15) ->X1 X(X'CF'): !->"FNPART" ->ER20 %IF B&FOPBITS # 1 %OR A&1 = 0 I = INTEGER(B+15)!!GETFROZ; ->ER20 %IF I&OPBITS # 0 INTEGER(B+I+15) = A ->X0 X(X'47'): !"BOUNDSLIST" A = 1*8 X(X'8B'): !"FROZVAL" FV: ->ER20 %IF B&FOPBITS # 1 I = INTEGER(B+15)!!GETFROZ; ->ER20 %IF I&OPBITS # 0 ->ER20 %UNLESS A&7 = 0 %AND A > 0 %AND A>>1 < I A = INTEGER(B+A>>1+15) ->X1 X(X'BB'): !->"FROZVAL" ->ER20 %IF B&FOPBITS # 1 I = INTEGER(B+15)!!GETFROZ; ->ER20 %IF I&OPBITS # 0 ->ER20 %UNLESS A&7 = 0 %AND A > 0 %AND A>>1 < I INTEGER(B+A>>1+15) = SAVED ->X0 X(X'49'): !"COPY" ->LOADB %IF B&2 = 0 B = PAIRCELL(INTEGER(B+2),INTEGER(B+6)) %IF B < WORDMIN ->LOADB %IF B < STRIPMIN A = STRIPCELL(INTEGER(B+2)) P = A; Q = B %CYCLE P = P+4; Q = Q+4 %EXIT %IF P = STRIPHI INTEGER(P+2) = INTEGER(Q+2) %REPEAT ->X1 X(X'AE'): !"STRIPFNS" B = 0 %IF B = CMPND; ->ER20 %IF B&X'FFFFFF07' # 0 I = NEWCLASS(A) B = INITXFUN+B<<5+I; !>>3<<8 A = SUBXFUN+I ->PUSHB X(X'4E'): !"INIT" J = FULLSTRIPINFO ->IN1 X(X'4F'): !"INITC" J = CSTRIPINFO ->IN1 X(X'B2'): !INITX J = B; B = A IN1:->ER20 %IF B&X'FFF80007' # 0 A = STRIPCELL(B<<13+J); !>>3<<16 P = A %CYCLE P = P+4 %EXIT %IF P = STRIPHI INTEGER(P+2) = UNASS %REPEAT ->X1 X(X'4A'): !"DATALENGTH" %IF B&2 = 0 %START ->TRU %IF B&3 = 0; !SIMPLE (1) ->FALS %IF B&OPBITS # 0; !BUILT-IN FUNCTION (0) I = INTEGER(B+15)!!GETFROZ; ->FALS %IF I&OPBITS # 0 A = I<<1-1*8 ->X1 %FINISH A = INTEGER(B+2)>>13 %AND ->X1 %IF B >= STRIPMIN; !>>16<<3 ->FALS %IF B = NIL; !(0) A = 2*8 %AND ->X1 %IF B < NIL %CYCLE A = 8*8,-1*8,1*8 %EXIT %IF CHARWORD(B,A) # 63*8 %REPEAT ->X1 X(X'AA'): !"SUBANY" ->ER20 %UNLESS A&7 = 0 %AND A > 0 %IF B&2 = 0 %START ->FV %IF B&1 # 0 ->LOADB %IF A = 1*8 ->ER20 %FINISH Q = 1 %AND ->SB3 %IF B >= STRIPMIN %IF B <= NIL %START ->FRN %IF A = 1*8 ->BAC %IF A = 2*8 ->ER20 %FINISH I = CHARWORD(B,A) ->CW X(X'89'): !"SUBSCR" J = FULLSTRIPCLASS ->SB1 X(X'8A'): !"SUBSCRC" J = CSTRIPCLASS ->SB1 X(X'8D'): !SUBX J = B; B = A; A = SAVED SB1:Q = 1 SB2:->ER20 %UNLESS B&2 # 0 %AND B >= STRIPMIN ->ER20 %UNLESS BYTEINTEGER(B+5) = J; !TEST CORRECT CLASS ->ER20 %UNLESS A&7 = 0 SB3:->ER20 %UNLESS 0 < A <= INTEGER(B+2)>>13; !>>16<<3 J = BYTEINTEGER(B+4); !COMPONENT SIZE %IF J = 0 %START; !FULL WORD %IF Q # 0 %START K = INTEGER(B+A>>1+2) ->ER22 %IF K = UNASS A = K ->X1 %FINISH INTEGER(B+A>>1+2) = INTEGER(SP); SP = SP+4 ->X0 %FINISH I = A>>3 K = 32//J; !NUM PER WORD P = (I-1)//K; !WORD DISPLACEMENT I = 32-(I-P*K)*J; !SHIFT FACTOR P = P<<2+B K = ((INTEGER(P+6)>>I)&(1<X1 %IF Q # 0 B = INTEGER(SP); SP = SP+4 ->ER20 %IF B&7 # 0 Q = B>>3 ->ER20 %IF Q>>J # 0 INTEGER(P+6) = INTEGER(P+6)!!((Q!!K)<X0 X(X'B9'): !->"SUBSCR" J = FULLSTRIPCLASS ->TS1 X(X'BA'): !->"SUBSCRC" J = CSTRIPCLASS ->TS1 X(X'BD'): !->SUBX J = B; B = A; A = SAVED TS1:Q = 0 ->ER30 %IF SP = SPBAR ->SB2 X(X'AF'): !"RECORDFNS" LIST TO STACK I = 0 %WHILE SP # SPBAR %CYCLE B = INTEGER(SP) ->ER20 %IF B # CMPND %AND B&X'FFFFFF07' # 0 SP = SP+4 I = I+X'10000'; ->ER20 %IF I&OPBITS # 0 %REPEAT UNSEAL B = NEWCLASS(A) SAVE(RECCONSFUN+I+B) A = RECDESTFUN+B J = 0 %WHILE J < I %CYCLE J = J+X'10000' SAVE(A); A = RECREFFUN+J+B %REPEAT ->X1 X(X'37'): !RECCONS A = INITSTRIP(B) ->X1 X(X'B3'): !RECDEST ->ER20 %UNLESS A&2 # 0 %AND A >= STRIPMIN ->ER20 %UNLESS BYTEINTEGER(A+5) = B P = A; Q = SP-INTEGER(A+2)>>14 ->ER31 %IF Q <= ASP %WHILE SP # Q %CYCLE SP = SP-4; P = P+4 INTEGER(SP) = INTEGER(P+2) %REPEAT ->X0 X(X'8E'): !RECREF ->ER20 %UNLESS A&2 # 0 %AND A >= STRIPMIN ->ER20 %UNLESS BYTEINTEGER(A+5) = B&X'FF' A = INTEGER(A+B>>14+2) ->X1 X(X'BE'): !->RECREF ->ER20 %UNLESS A&2 # 0 %AND A >= STRIPMIN ->ER20 %UNLESS BYTEINTEGER(A+5) = B&X'FF' INTEGER(A+B>>14+2) = SAVED ->X0 X(X'3B'): !"CHARIN" A = INTEGER(B) %IF A < 0 %START %IF B # INREF %START INREF = B; SELECT INPUT((B-STREAM0)>>3) %FINISH READ CH(K) %AND K = ISO TO POP(K) %UNTIL K # 64 A = K<<3 %FINISH INTEGER(B) = A!X'80000000' ->X1 %IF A # SYMEND A = TERMINVAL ->X1 X(X'B1'): !"CHAROUT" %IF A&X'FFFFFE07' = 0 %START %IF B # OUTREF %START OUTREF = B; SELECT OUTPUT((B-STREAM0)>>3) %FINISH OUTSYM = A %IF B = STREAM0 PRINT SYMBOL(POP TO ISO(A>>3)) ->X0 %FINISH ->ER20 %IF A # TERMINVAL ->X0 %IF B = STREAM0 OUTREF = STREAM0; SELECT OUTPUT(0) CLOSE STREAM((B-STREAM0)>>3) ->X0 X(X'32'): !ITEMIN ITEMISE(B) ->X1 X(X'3C'): !"ITEMREAD" READ PROGRAM ITEM ->X1 X(X'6C'): !"PRINT" SAVE(B) X(X'6B'): !"PR" PUT SYM(SYMSP) %IF B&X'80000003' = 0; !NON-NEGATIVE NUMBER PUT ITEM(B) ->X0 X(X'6F'): !"PRSTRING" ->ER20 %UNLESS CLASSNO(B) = CSTRIPCLASS PUT STRING(B) ->X0 X(X'AB'): !"PRREAL" ->ER20 %IF (A!B)&X'FFFFFC07' # 0 I = B; B = SAVED; PUT REAL(REALB,A>>3,I>>3) ->X0 X(X'6D'): !"NL" ->ER20 %IF B&X'FFFFFC07' # 0 PUT SYM(SYMNL) %AND B = B-1*8 %WHILE B > 0 ->X0 X(X'6E'): !"SP" ->ER20 %IF B&X'FFFFFC07' # 0 PUT SYM(SYMSP) %AND B = B-1*8 %WHILE B > 0 ->X0 X(X'4C'): !"SHOW" ->PRDICT %IF B&FOPBITS # 1 P = B+7; K = INTEGER(B+3)>>14 I = X'30000008'; !FOR FNPROPS,UPDATER %WHILE K > 0 %CYCLE %IF I&X'FE000000' = X'30000000' %AND I&ADBITS # 0 %START !LOADIMM AND GETFROZ -- FOLLOWED BY VALUES J = INTEGER(P); I = I-4 %FINISH %ELSE %START I = INTEGER(P) %IF I&OPBITS # 0 %THEN PUT ITEM(I&OPBITS+1) %C %ELSE PUT SYM(SYMLA) %AND PUT SYM(SYMMINUS) J = I&ADBITS J = J-1 %IF I&3 = 3 J = 0 %IF J = STREAM0 J = J<<1 %IF I&X'70000003' = X'30000000'; !ROUGH TEST %FINISH PUT SYM(SYMSP); PUT ITEM(J) PUT SYM(SYMNL) P = P+4; K = K-4 %REPEAT PUT SYM(SYMNL) ->X0 PRDICT: %CYCLE I = 0,1,127 WRITE(I,3); J = INDEX(I) %WHILE J # 0 %CYCLE K = J<<4+WORDBASE; PUT SYM(SYMSP); PUT ITEM(K) J = INTEGER(K+10)&X'3FFF' %REPEAT PUT SYM(SYMNL) %REPEAT PUT SYM(SYMNL) ->X0 X(X'38'): !"SETPOP" MON = 0 %MONITOR 32 X(X'2F'): !"GOON" PC = 0 MON = 0; FORCE RETURN ->X0 X(X'18'): !":" X(X'19'): !"=>" ANNOUNCE("**") J = SPBAR %WHILE J # SP %CYCLE J = J-4; PUT SYM(SYMSP); PRINT(INTEGER(J)) PRINT SYMBOL(',') %IF J # SP %REPEAT PUT SYM(SYMNL) SP = SPBAR ->X0 X(X'6A'): !"POPMESS" LIST TO STACK A = NIL K = A %AND A = B %AND B = SAVED %WHILE SP # SPBAR UNSEAL %IF B = EXIT %START %STOP %FINISH ->ER20 %IF B # IN %AND B # OUT %AND B # COMPIL %AND B # EDIT ->ER21 %UNLESS A&2 # 0 %AND WORDMIN < A < STRIPMIN J = STREAMMAX+8 INTEGER(J) = SYMNLX; INTEGER(J+4) = A I = STREAM0; I = I+8 %UNTIL INTEGER(I+4) = A %IF INTEGER(I) # SYMNLX %AND B # OUT %START INTEGER(I) = SYMNLX %IF INREF # STREAM0 %START INREF = STREAM0; SELECT INPUT(0) %FINISH CLOSE STREAM((I-STREAM0)>>3) %FINISH %IF B = EDIT %START %IF K = NIL %THEN %START %IF EXIST(WORDTOSTRING(A))=0 %THEN E(".NULL/".WORDTOSTRING(A)) %C %ELSE E(WORDTOSTRING(A)) %FINISH %ELSE E(WORDTOSTRING(A)."/".WORDTOSTRING(K)) ->X0 %FINISH %IF I = J %START CROAK("NO STREAMS") %IF I = STREAMLIM; STREAMMAX = I J = '0'; K = (I-STREAM0)>>3+'0' J = J+1 %AND K = K-10 %IF K > '9' DEFINE("ST".TOSTRING(J).TOSTRING(K).",".WORDTOSTRING(A)) %FINISH A = CHAROUTFUN A = CHARINFUN %IF B # OUT A = A+I ->X1 %IF B # COMPIL B = A X(X'4D'): !"INCHARITEM" X(X'50'): !"COMPILE" ->ER20 %IF B&1 = 0 A = B!!CHARINFUN %IF A&OPBITS # 0 %START; !REPEATER NOT CHARIN(STREAM) A = STREAMLIM A = A+8 %UNTIL A = ITEMHI %OR INTEGER(A+4) = B %IF A = ITEMHI %START ITEMHI = ITEMHI+8 CROAK("NO ITEMS") %IF ITEMHI >= CLASSLO INTEGER(A) = SYMNLX; INTEGER(A+4) = B %FINISH %FINISH A = A+ITEMINFUN ->X1 %IF INST&OPBITS = X'4D000000'; !INCHARITEM INTEGER(CUCHARIN+2) = B; !SET CUCHARIN B = PAIRCELL(1*8,A); !FNTOLIST ->PV X(X'39'): !"POPREADY" INTFLAG = 50 POPRDY: ANNOUNCE(" POPREADY ") X(X'21'): !START B = BASEPROG INTEGER(B+2) = 1*8; INTEGER(B+6) = ITEMINFUN+BASEITEM %IF BASEITEM = STREAM0 %START; !EXCEPT AT OUTSET %IF INREF # STREAM0 %START INREF = STREAM0; SELECT INPUT(0) %FINISH %IF INTEGER(INREF)&X'1FF' # SYMNL %START READ CH(K) %UNTIL K = NL %FINISH %FINISH INTEGER(BASEITEM) = SYMNLX ->PV ! ! C O M P I L A T I O N S E C T I O N ! %ROUTINE PLANT INST(%INTEGER OP) %IF OP&ADBITS = 0 %AND CSP # CSPBAR %C %AND INTEGER(CSP)&OPBITS = 0 %START INTEGER(CSP) = INTEGER(CSP)+OP %FINISH %ELSE %START PLANT(OP) %FINISH %END %ROUTINE LOOKUP LABEL(%INTEGER L) LABPOS = SPBAR %CYCLE LABPOS = LABPOS-8; %EXIT %IF LABPOS < SP %RETURN %IF INTEGER(LABPOS+4) = L %REPEAT %MONITOR 4 %IF LABPOS <= ASP SP = LABPOS INTEGER(LABPOS) = 0; INTEGER(LABPOS+4) = L %END %ROUTINE PLANT JUMP(%INTEGER J,P) %INTEGER Q Q = INTEGER(P) %IF Q > 0 %START; !LABEL DEFINED PLANT(JUMPBACK+CSP+4-Q); !ALWAYS UNCONDITIONAL %FINISH %ELSE %START J = J!!X'02000000' %AND CSP = CSP-4 %IF J < 0 %C %AND CSP # CSPBAR %AND INTEGER(CSP) = NOT PLANT(J+Q&ADBITS) INTEGER(P) = X'80000000'+CSP %FINISH %END %ROUTINE UNCHAIN(%INTEGER P) %INTEGER NEXT,Q CSPBAR = CSP Q = INTEGER(P)&ADBITS; INTEGER(P) = 0 %WHILE Q # 0 %CYCLE NEXT = INTEGER(Q)&ADBITS INTEGER(Q) = INTEGER(Q)&OPBITS+CSP-Q Q = NEXT %REPEAT %END X(X'60'): !"POPVAL" PV: ->ER20 %UNLESS B&2 # 0 %AND B < NIL POS = 0; POS1 = 0 PUSH(PC) PLANT(ASP) PLANT(INTEGER(PROGLIST+2)); INTEGER(PROGLIST+2) = B PLANT(CODEBASE); PLANT(PVBASE) PVBASE = CSP; CODEBASE = 0 X(X'17'): !STOP (SEMICOLON) X(X'2D'): !STOP (END) PUSH(TERMINVAL); !SOLE NON-NEG OPENER START: CSP = PVBASE; CSPBAR = CSP PC = 0; INST = 0 ANNOUNCE("") PROMPT(" :") GET0: CSTATE = INITSTATE; OPENER = TERMINVAL; A = TERMINVAL C(22): !"," C(31): !"CANCEL" C(18): !"COMMENT" C(6): !"NONOP" C(7): !"NONMAC" (SHOULDN'T GET HERE) GET: LAST = A; READ PROGRAM ITEM; PROMPT(":") %IF A&2 # 0 %AND WORDMIN <= A < STRIPMIN %START; !WORD TYPE = INTEGER(A+14)&TYPEBITS %IF TYPE >= 0 %START; !NOT SYNTAX %IF TYPE&PRECBITS = 0 %START; !ORDINARY IDENT ->ERR %IF CSTATE<<1 >= 0 %FINISH %ELSE %START; !OPERATOR ->ERR %IF CSTATE<<2 >= 0 %FINISH %FINISH %ELSE %START; !SYNTAX ->ERR %IF CSTATE<<(TYPE>>24&31) >= 0 %FINISH %FINISH %ELSE %START; !CONST ->ERR %IF CSTATE >= 0 ->CONST %IF CSTATE&15 = 0 %FINISH ->D(CSTATE&15) %IF CSTATE&15 # 0; !CONTEXT-CONTROLLLED -> NEXT: ->IDENT %IF TYPE >= 0 %AND TYPE&PRECBITS = 0; !ORDINARY IDENT -> %CYCLE; !POP LOWER PRECEDENCE OPERATORS P = INTEGER(ASP) %EXIT %IF P&TYPEBITS <= 0 %OR P&TYPEBITS > TYPE&VARBITS P = P&ADBITS; ASP = ASP-4 Q = 0; Q = INTEGER(CSP) %IF CSP # CSPBAR %IF P = ARROW %START ->AERR %IF X'70000000' # Q&X'70000000' # 0; !NOT UPDATABLE -> %IF Q&OPBITS = 0 %START; !LOAD: MUST BE VAR, NOT PROTECTED ->AERR %IF Q&3 # 3 %OR Q < SYSLIM Q = Q-1; !IMMEDIATE OPERAND FOR STORE %FINISH !MAP INST TO 'UPDATE' INTEGER(CSP) = Q&X'7FFFFFFF'!!X'B0000000' %FINISH %ELSE %START Q = P+1 %AND PLANT(Q) %IF P # DOT P = APPLY %IF Q&X'FF000003' = 3 %AND ZERO < Q < PRIMLIM %START P = INTEGER(Q+1)-1; CSP = CSP-4 %FINISH PLANT INST(P) %FINISH %REPEAT ->OPERATOR %IF TYPE >= 0 ->GERR %IF A >= FUNCTION %AND INTEGER(P&ADBITS+2)<<(TYPE>>24&31) >= 0 LPNEXT: CSTATE = INTEGER(A+2) ->C((A-WORDMIN)>>4) D(6): !WORD AFTER "NONOP" IDENT: CSTATE = IDENTSTATE ->GET D(1): !WORD AFTER IDENT %IF A = COLON %AND CODEBASE # 0 %START LOOKUP LABEL(LAST) %IF INTEGER(LABPOS) <= 0 %THEN UNCHAIN(LABPOS) %C %ELSE COMMENT(" DUP ",LAST) INTEGER(LABPOS) = CSP ->GET0 %FINISH COMMENT(" VARS ",LAST) %IF INTEGER(LAST+14)&SIGBITS = 0 LAST = VAR(LAST,VARBIT) PUSH(VARBIT+LAST) %AND ->LPNEXT %IF A = LP %IF CSP # CSPBAR %AND INTEGER(CSP) = STORE+LAST %START INTEGER(CSP) = INTEGER(CSP)-X'28000000'; !->(B0) => DUP->(88) %FINISH %ELSE %START PLANT(LAST+1); !LOAD VAR %FINISH ->NEXT OPERATOR: PLANT(ZERO) %IF (A=PLUS %OR A=MINUS) %AND CSTATE < 0 A = VAR(A,0) CSTATE = INITSTATE C(20): !"." C(21): !"->" TYPE = TYPE&X'7FFFFFFF'; !NO SYNTAX BIT C(8): !"(" PUSHOP: ASP = ASP+4; %MONITOR 4 %IF ASP >= SP SETOP: INTEGER(ASP) = TYPE+A ->GET D(2): !WORD AFTER QUOTE CSTATE = CSTATE+1; !ADVANCE STATE ->GET D(3): !ITEM AFTER QUOTED WORD ->ERR %IF A # QUOTE A = LAST CONST: PLANT(LOADIMM) %AND CSPBAR = CSP+4 %IF A&OPBITS # 0 P = A; P = ZERO %IF A = 0 PLANT(P) CSTATE = CONSTSTATE ->GET C(10): !"[" (LB) SEAL D(4): !& AFTER LB %IF A = RB %START A = NIL %WHILE INTEGER(SP) # LB %CYCLE A = PAIRCELL(INTEGER(SP),A); SP = SP+4 %REPEAT SP = SP+4 UNSEAL %AND ->CONST %IF SP = SPBAR %FINISH SAVE(A) C(12): !QUOTE NMGET: NONMACFLAG = 1 ->GET C(9): !"(%" C(11): !"[%" PLANT((A-WORDMIN)<<20+X'800000') ->PUSHOP C(43): !"%)" C(42): !"%]" PLANT((A-WORDMIN)<<20+X'800000') C(44): !")" ASP = ASP-4 ->GET C(14): !"IF" P = 0 IF1:->LERR %IF CODEBASE = 0 PUSH(P); PUSH(0); PUSH(0) ->PUSHOP C(15): !"LOOPIF" P = CSP; CSPBAR = CSP ->IF1 C(36): !"AND" PLANT JUMP(JUMPFALS,ASP-4) ->SETOP C(37): !"OR" PLANT JUMP(JUMPTRUE,ASP-8) ->SETOP C(38): !"THEN" PLANT JUMP(JUMPFALS,ASP-4) UNCHAIN(ASP-8) ->SETOP C(35): !"ELSEIF" C(34): !"ELSE" PLANT JUMP(JUMP,ASP-12) UNCHAIN(ASP-4) ->SETOP C(40): !"EXIT" PLANT(RETURN+CSP-CODEBASE-4) C(41): !"CLOSE" %IF INTEGER(ASP-12) <= 0 %THEN UNCHAIN(ASP-12) %C %ELSE PLANT JUMP(JUMP,ASP-12); !IF/LOOPIF UNCHAIN(ASP-4) ASP = ASP-16 ->GET C(32): !"RETURN" PLANT(RETURN+CSP-CODEBASE-4) C(33): !"GOTO" ->LERR %IF CODEBASE = 0 ->GET D(5): !WORD AFTER "GOTO" LOOKUP LABEL(A) PLANT JUMP(JUMP,LABPOS) ->GET0 D(7): !WORDS AFTER "CANCEL" ->GET0 %IF A = SEMICOLON INTEGER(A+14) = INTEGER(A+14)&ADBITS!CANBIT ->GET D(14): !ITEMS AFTER "COMMENT" ->GET0 %IF A = SEMICOLON ->NMGET ! %ROUTINE DECLARE %INTEGER P,Q A = VAR(A,VTYPE) %IF A < SYSLIM %OR INTEGER(A+14)&TYPEBITS # VTYPE %START COMMENT(" CLASH ",A); %RETURN %FINISH %RETURN %IF CODEBASE = 0 P = CODEBASE+12; !FIRST INSTRUCTION OF FUNCTION %WHILE P <= CSP %AND INTEGER(P)&SAVEMASK = VARSAVE %CYCLE COMMENT(" DUP ",A) %IF INTEGER(P)&ADBITS = A P = P+4 %REPEAT Q = CSP; CSP = CSP+4; %MONITOR 4 %IF CSP >= PAIRLO INTEGER(Q+4) = INTEGER(Q) %AND Q = Q-4 %WHILE Q >= P INTEGER(P) = SAVEOP+A %END C(28): !"OPERATION" OPENER = TYPE+A GETP: CSTATE = CSTATE+X'80000003'; !ADVANCE STATE, INCLUDE CONST ->GET D(11): D(12): !ITEM AFTER "OPERATION" ->ERR %UNLESS A&7 = 0 %AND 0 < A <= 9*8 VTYPE = A<<21+VARBIT; !>>3<<24 CSTATE = CSTATE-X'80000003'; !RESTORE STATE ->GET C(27): !"MACRO" OPENER = TYPE+A GETM: VTYPE = MACBIT ->NMGET C(26): !"FUNCTION" OPENER = TYPE+A C(29): !"VARS" SAVEOP = VARSAVE GETV: VTYPE = VARBIT %IF CSTATE&RPBIT = 0 ->GET D(8): !WORD AFTER "FUNCTION" ETC ->ERR %IF TYPE < 0 SAVEOP = VARSAVE DECLARE CSTATE = CSTATE+1 ->FUNSTART C(13): !"LAMBDA" OPENER = TYPE+A FUNSTART: PUSH(CODEBASE); PUSH(OPENER) CODEBASE = CSP PLANT(A); PLANT(UNDEF); !FNPROPS, UPDATER SEAL; !SEAL MAIN STACK SAVEOP = INSAVE ->GETV D(9): !PROCESSING VARS DECLARE %AND ->GETV %IF TYPE >= 0 ->C9 %IF A = SEMICOLON SAVEOP = OUTSAVE %AND ->GET %IF A = PARROW %AND SAVEOP = INSAVE CSTATE = CSTATE!!LPRPBITS %AND ->GET %IF A = LP %OR A = RP ->GETM %IF A = MACRO ->GETP %IF A = OPERATION ->VERR ! C(45): !"END" !CHECK LABELS %WHILE SP < SPBAR %CYCLE %IF INTEGER(SP) < 0 %START; !LABEL NOT DEFINED UNCHAIN(SP) COMMENT(" LAB ",INTEGER(SP+4)) %FINISH SP = SP+8 %REPEAT UNSEAL !CREATE FUNCTION PLANT(RETURN+CSP-CODEBASE-4) A = STRIPCELL((CSP-CODEBASE)<<14)-1; !>>2<<16 Q = STRIPHI %WHILE CSP # CODEBASE %CYCLE Q = Q-4; INTEGER(Q+2) = INTEGER(CSP); CSP = CSP-4 %REPEAT ASP = ASP-8; CODEBASE = INTEGER(ASP+4) Q = INTEGER(A+7); !FNPROPS (FUNCTION NAME) ->CONST %IF Q = LAMBDA PLANT(A); PLANT(STORE+Q) ! C(23): !; C9: A = SEMICOLON ->GET0 %UNLESS INTEGER(ASP) >= 0 C(47): !"GOON" PLANT((A-WORDMIN)<<20+X'800000') PC = PVBASE+4; ASP = INTEGER(PVBASE-12) PROMPT(">") ->X0 C(24): !":" C(25): !"=>" PLANT((A-WORDMIN)<<20+X'800000') %AND ->C9 %IF CODEBASE = 0 PLANT INST(PR) ->GET0 C(39): !"SWITCH" C(16): !"]" (RB) C(17): !"$" C(30): !"SECTION" C(46): !"ENDSECTION" ERROR = 1; ->REPORT VERR:LAST = OPENER&ADBITS ERR: ERROR = 2; ->REPORT GERR:LAST = INTEGER(ASP)&ADBITS ERROR = 3; ->REPORT AERR:ERROR = 4; ->REPORT LERR:ERROR = 5; ->REPORT REPORT: P = A ANNOUNCE(" ERROR"); WRITE(ERROR,1) SPACES(2) %AND PUT ITEM(LAST) %IF LAST # TERMINVAL SPACES(2) %AND PUT ITEM(P) %IF ERROR # 4 PUT SYM(SYMNL) ->C99 %IF POS = 0 ERRPOS = POS1 CSTATE = SKIPSTATE D(15): !SKIPPING ->NMGET %UNLESS A = END %OR A = GOON %OR SYM = SYMNL %OR POS = 81 %IF POS # 0 %START ANNOUNCE("*") %CYCLE P = 1,1,POS PRINT SYMBOL('!') %IF P = ERRPOS %AND ERROR # 4 PRINT SYMBOL(POPTOISO(CHAR(P))) %REPEAT %FINISH ->START %IF CODEBASE = 0 C99:MON = VARSAVE %MONITOR 32 ! X(X'28'): !RESUME INST = SAVEDINST PC = INTEGER(ASP); ASP = ASP-4 %END; ! E X E C U T E ! !MAIN PROGRAM ! %INTEGER I,J,K,P ! ! %FAULT 1,2,5,6,17,21,22,23,24,25,27 ->ER20 %IF EVENT(1) = 0 %THEN ->ER20 %IF EVENT(2) = 0 %THEN ->ER20 %IF EVENT(5) = 0 %THEN ->ER20 %IF EVENT(17) = 0 %THEN ->ER20 %IF EVENT(21) = 0 %THEN ->ER20 %IF EVENT(22) = 0 %THEN ->ER20 %IF EVENT(23) = 0 %THEN ->ER20 %IF EVENT(24) = 0 %THEN ->ER20 %IF EVENT(25) = 0 %THEN ->ER20 %IF EVENT(27) = 0 %THEN ->ER20 %IF EVENT(6) = 0 %THEN ->ER20 ! %FAULT 10->ER20, 11->ER21, 16->ER0 %IF EVENT(10) = 0 %THEN ->ER20 %IF EVENT(11) = 0 %THEN ->ER21 %IF EVENT(16) = 0 %THEN ->ER0 ! %FAULT 3->ER30, 4->ER31 %IF EVENT(3) = 0 %THEN ->ER30 %IF EVENT(4) = 0 %THEN ->ER31 ! %FAULT 7->ER39, 9->ER29, 19->ER32 %IF EVENT(7) = 0 %THEN ->ER39 %IF EVENT(9) = 0 %THEN ->ER29 %IF EVENT(19) = 0 %THEN ->ER32 ! %FAULT 32 ->ER5 %IF EVENT(32) = 0 %THEN ->ER5 ! ! ! %ROUTINE SETUP %INTEGER I,J,K,Q,W1,W2 W1 = 0; W2 = 0 READ CH(K) %UNTIL K # ' ' %AND K # NL I = 26 %WHILE K # '_' %AND K # '!' %CYCLE K = ISO TO POP(K)+1 %IF I >= 0 %THEN W1 = W1!K<= -16; %FINISH READ CH(K) I = I-6 %REPEAT INTEGER(P) = WORDHI %AND P = P+4 %IF K = '!' I = 0; J = 0 %CYCLE READ CH(K) I = J<<24 %AND J = 0 %AND READ CH(K) %IF K = '_' %EXIT %UNLESS '0' <= K <= 'F' K = K-('A'-'0'-10) %IF K >= 'A' J = J<<4+(K-'0') %REPEAT %IF K # 'P' %THEN Q = WORDLOOK(W1,W2) %C %ELSE Q = WORDCELL(W1,W2); !VISIBLE/PRIVATE %IF K >= 'R' %START J = J+Q %IF K = 'R'; !SELF-REF (EG NIL) J = J+STREAM0 %IF K = 'T' J = J+(Q-WORDMIN)<<20+1 %IF K = 'S' %OR K = 'T'; !SYS FUNCTION I = VARBIT %IF I = 0 %FINISH INTEGER(Q+2) = J; INTEGER(Q+14) = I %END !INITIAL ENTRY NEWLINE PRINT STRING(IDENTIFICATION) NEWLINE OUTFILE("POPTEMP",-262144,262144,X'40000000',STOREBASE,I) PRINT STRING(SSFMESSAGE) %AND %STOP %IF I # 0 STREAM0 = STOREBASE+16; !ALLOW FOR EMAS HEADER STREAMLIM = STREAM0+128 STACKMIN = STREAMLIM+256; !ITEM INFO -> <- CLASS INFO STACKLIM = STACKMIN+6000; !AUX STACK -> <- MAIN STACK (1500 SLOTS) WORDMIN = STACKLIM+150002; !COMP STACK -> <- PAIRS (C 18000 PAIRS) STRIPMIN = WORDMIN+16000; !1000 'WORDS' -> !STRIPS (C 90000 BYTES) -> STORELIM = STOREBASE+262146 WORDBASE = WORDMIN-16; !FOR RELATIVISING HASH LINKS STREAMMAX = STREAM0 RESTART: PAIRFREE = 0; WORDFREE = 0 ITEMHI = STREAMLIM; CLASSLO = STACKMIN PAIRLO = WORDMIN-40; BASEPROG = PAIRLO WORDHI = WORDMIN; STRIPHI = STRIPMIN %CYCLE I = 0,1,127 INDEX(I) = 0 %REPEAT %IF POPPARM # "" %START DEFINE("ST15,ECMI05.POPSET11+".POPPARM) %FINISH %ELSE DEFINE("ST15,ECMI05.POPSET11") BASEITEM = STREAM0+15*8; !FOR READING POPSET FILE SELECT INPUT(15); INREF = BASEITEM; OUTREF = STREAM0 P = ADDR(NIL) UNDEF = WORDMIN+16; !*USED BY WORDCELL* %CYCLE I = 1,1,214 SETUP %REPEAT ZERO = FALSE+1 INTEGER(STREAM0) = SYMNLX; OUTSYM = SYMNL %CYCLE I = 0,16,7*16 CLASSLO = CLASSLO-4 INTEGER(CLASSLO) = INTGR+I %REPEAT INTEGER(STACKMIN-12) = FUNCTION; !DATAWORD NOT IN SEQUENCE SYSLIM = PRIMLIM; !*WHILE COMPILING SYSLIB* AGAIN: INTFLAG = 50 NONMACFLAG = 0; MACSTREAM = NIL; MACEND = ADDR(MACSTREAM)-6 INST = 0; PC = 0; CODEBASE = 0; PVBASE = 0 ASP = STACKMIN INTEGER(STACKMIN) = RESUME SP = STACKLIM; SPBAR = SP CSP = STACKLIM EXECUTE(STARTFUN) RESET: SYSLIM = SYNTAX; BASEITEM = STREAM0 ANNOUNCE(" SETPOP ") ->AGAIN ! ! ER21:ERROR = 20; J = 1; ->ER1; !OPERANDS ERROR ER20:ERROR = 20; !OPERAND(S) ERROR ER0:J = 0 ER1:P = NIL-8 K = INST&ADBITS-1 K = B %AND B = NIL %IF K&3 # 2 %OR K < SYSLIM INTEGER(P+2) = K; INTEGER(P+6) = B %IF INST < 0 %OR J # 0 %START P = P-8 INTEGER(P+2) = A; INTEGER(P+6) = P+8 %FINISH ->ERR ER29:ERROR = 29; ->ER2; !INPUT ENDED ER30:ERROR = 30; ->ER2; !STACK UNDERFLOW ER31:ERROR = 31; ->ER2; !STACK OVERFLOW ER32:ERROR = 32; ->ER2; !GARBAGE ON STACK ER39:ERROR = 39; !SWITCH LABEL NOT SET ER2:P = NIL ERR: %IF INST&OPBITS # 0 %START P = P-8 INTEGER(P+2) = INST&OPBITS+1; INTEGER(P+6) = P+8 %FINISH ! ANNOUNCE(" ERROR"); WRITE(ERROR,1) SPACES(2) %AND PUT ITEM(P) %IF P # NIL PUT SYM(SYMNL) ! ->RESET %IF ERROR = 31 MON = VARSAVE ! ER5:FORCE RETURN %WHILE PVBASE # 0 ->RESET %END %EXTERNALROUTINE LOGOPOP(%STRING(63)S) %IF S# "" %THEN POP2(S."+ECMI05.LOGSET11")%ELSE POP2("ECMI05.LOGSET11") %END %EXTERNALINTEGERFN EVENT(%INTEGER N) *L _ 1,N *LR _ 10,8 *BAL _ 15,80(12) *LA _ 8,0(10) *LA _ 10,0 *ST _ 11,44(8) *LR _ 1,10 *LM _ 4,15,16(8) *BCR _ 15,15 %RESULT=1 %END %ENDOFFILE