github.com/retro-software.B5500-software
1
0
Fork 0
mirror of https://github.com/retro-software/B5500-software.git synced 2026-01-25 03:15:38 +00:00
Code Issues Releases Wiki Activity
retro-software.B5500-software/Mark-XVI/LISP/APTLIB.alg_m
Paul Kimpel 753366644a 1. Move /trunk/SYMBOL directory to /trunk/Mark-XVI/SYMBOL. 
2. Commit Mark XVI LISP/APTLIB interpreter, transcribed by Fausto Saporino of Naples, Italy, and generously donated to the project.
2013-06-30 13:35:10 +00:00

1613 lines
129 KiB
Plaintext
Raw Blame History

? COMPILE LISP/LISP WITH XALGOL LIBRARY
? XALGOL STACK = 1000
?LABEL 0 0CARD
$ CARD LIST SINGLE
BEGIN %8 SEPTEMBER 1969 00001000
% 00002000
% CONSTANT DEFINES 00003000
% 00004000
FILE DATA REMOTE(2,10); 00005000
DEFINE MEMORYROWS = 127#,NOOFPROCESSOPS=44#,STKSZ=2#; 00006000
REAL LASTUSEDSPACE,XADDR,LINKTONIL,CARADDR,NEXTTOKEN; 00007000
REAL HASH,PRIORITY,TKNO,LABTAB,T,XX1,XX2; 00008000
POINTER CP;ARRAY JUNKARRAY[0:0],STACK[0:STKSZ,0:511]; 00009000
DEFINE CHR=JUNKARRAY[0]#,LEXTREE=HASH#; 00010000
REAL LASTRPID,STACKPOSITION; 00011000
BOOLEAN TRACE; 00012000
REAL ATOMUNDEF,NULLIST,AT0,AT1,AT2,AT3,AT4,AT5,AT6,AT7,RC1,RC9; 00013000
ARRAY SYSMARRAY[0:2], TYPEARRAY[0:15]; 00014000
ARRAY PROCESSARRAY[0:NOOFPROCESSOPS]; 00015000
ARRAY MEMORY[0:MEMORYROWS, 0:511]; 00016000
ARRAY C1[0:0], C2[0:0],C3[0:0],C4[0:0],C5[0:0],C6[0:0]; 00016050
REAL CURROW; 00016060
DEFINE TYPE = [22:4]#, 00017000
ADDR=[18:19]#; 00018000
DEFINE TYPEGARBAGE =0#, 00019000
TYPECONS=1#, 00020000
TYPELIST=2#, 00021000
TYPEAREA=3#, 00022000
TYPEFIELD=4#, 00023000
TYPESYMB=5#, 00024000
TYPELOGIC=6#, 00025000
TYPELINK =7#, 00026000
TYPEPROCESS=8#, 00027000
TYPEMONITOR=9#, 00028000
TYPEGENERAL=10#, 00029000
TYPETOKEN=11#, 00030000
TYPECODE=11#; 00031000
% 00032000
% TOKEN ASSIGNMENTS 00033000
% 00034000
% 1 TO 30= ALGOL RETURN LABELS 00035000
% 100 = ASGN 00036000
% 101 = REF 00037000
% 102 = CAR 00038000
% 103 = CDR 00039000
% 104 = CONS 00040000
% 105 = NEWSYMB 00041000
% 106 = AMTSPACE 00042000
% 107 = MAKE 00043000
% 108 = PRINT 00044000
% 109 = INLEX 00045000
% 110 = GCL 00046000
% 111 = CREATE 00047000
% 112 = DELETE 00048000
% 113 = SUSPEND 00049000
% 114 = RESUME 00050000
% 115 = RETURN 00051000
% 116 = IDENTITY 00052000
% 117 = HALT 00053000
% 118 = 00054000
% 119 = 00055000
% 120 = TRACE 00056000
% 121 = EQLIST 00057000
% 122 = QUOTE 00058000
% 123 = ASGNENV 00059000
% 124 = REFENV 00060000
% 125 = EXE 00061000
% 126 = DEBUG 00062000
% 127 = LDMODE 00063000
% 128 = CONSTRUCT 00064000
% 129 = AREA 00065000
% 130 = TOKEN 00066000
% 131 = SINGLESTEP 00067000
% 132 = UP 00068000
% 133 = DP 00069000
% 134 = READ 00070000
% 135 = 00071000
% 136 = LIST 00072000
% 137 = COND 00073000
% 138 = EQ 00074000
% 139 = ATOM 00075000
% 140 = BLOCKOP 00076000
% 141 = NEQ 00077000
% 142 = IF 00078000
% 143 = NONTERM 00079000
%144=USERL 00079010
%145=LTAB 00079020
%146=COPY 00079030
%147=ADD 00079035
%148=SUB 00079040
%149=MUL 00079045
%150 =DIV 00079050
%151=EX 00079055
%152=NEG 00079060
% 00080000
% 512 TO 576 = SPECIAL CHARACTERS 00081000
% 00082000
% 118 = ALTERNATIVE OP IN BNF INTERPRETERS 00083000
% 1000 = RESULT VARIABLE FOR BASE LANGUAGE 00084000
% 1001 = LIST FORMAL PARAMETER 00085000
% 1002 = QUOTED FORMAL PARAMETER 00086000
% 1003 = QUOTED LIST FORMAL PARAMETER 00087000
% 1004 = BASE LANGUAGE INTERPRETER 00088000
% 1005 = BNF INTERPRETER 00089000
% 1006 = STRING VARIABLE FOR BNF 00090000
% 1007 = QUOTED SYMBOL IN SCANNER 00091000
% 1008 = SINGLE STEP VARIABLE 00092000
% 1009 = TRACE VARIABLE 00093000
% 1010 = REMOTE TERMINAL DEVICE 00094000
% 1011 = DISK DEVICE 00095000
% 1012 = # IN BNF ALTERNATIVE 00096000
% 1013 = LEXUNIT 00097000
% 1014 = ID 00098000
% 1015 = INT 00099000
% 1016 = SPCHAR 00100000
% 1017 = CODE GENERATOR INTERPRETER 00101000
% 1018 = TREE VARIABLE IN BNF INTERPRETER 00102000
% 1019 = N VARIABLE IN BNF INTERPRETER 00103000
%1020 = NUMBER 00103010
% 00104000
% 2000 TO 10000 = IDENTIFIERS 00105000
% 00106000
% 262144 TO 524287 = USER TOKENS 00107000
% 00108000
% DEFINED SUBROUTINES 00109000
% 00110000
DEFINE FNS(FNS1)=PSCAN(1,FNS1,F)#,STATS=PSCAN(0,0,V1)#; 00111000
DEFINE M[M1]=(IF BOOLEAN(M1)THEN 00112000
MEMORY[(M1).[18:9],(M1).[9:9]].[22:23] ELSE 00113000
MEMORY[(M1).[18:9],(M1).[9:9]].[45:23])#, 00114000
STEPSPACE=(LASTUSEDSPACE:=LASTUSEDSPACE+1)#, 00115000
AT(AT1)=(AT0+AT1)#, 00116000
TOKEN(TOKEN1)=(TKNO+TOKEN1)#, 00117000
ATOM(ATOM1)=((T:=ATOM1.TYPE)=TYPELOGIC OR T=TYPESYMB OR T=TYPETOKEN)#, 00118000
DELETE(DELETE1)=BEGIN ASGN(AT2,DELETE1,ATOMDELETED)END#, 00119000
SUSPEND(SUSPEND1)=BEGIN IF REF(AT2,SUSPEND1) NEQ ATOMRESUMED THEN 00120000
PRIMERROR("SPND",SUSPEND1)ELSE ASGN(AT2,SUSPEND1,ATOMSUSPENDED)END#, 00121000
AMTSPACE=((0&(MEMORYROWS+1)[18:8:9])-LASTUSEDSPACE-1)#, 00122000
ATOMUND=ATOMUNDEF#, 00123000
ATOMCAR=AT1#, 00124000
ATOMCDR=AT0#, 00125000
ATOMASSO=AT0#, 00126000
ATOMPRIORITY=AT1#, 00127000
ATOMSUSPENDED=AT1#, 00128000
ATOMRESUMED=AT2#, 00129000
ATOMDELETED=AT3#, 00130000
LOGIC(LOGIC1)=MAKE(TYPELOGIC,LOGIC1)#, 00131000
DEC(DEC1)=(DEC1-1)#, 00132000
MAKE(MAKE1,MAKE2)=((MAKE2)&(MAKE1)[22:3:4])#, 00133000
QQ(QQ1)=QU(1,QQ1)#, 00134000
UQ=QU(2,0)#, 00135000
INQ(INQ1)=QU(3,INQ1)#, 00136000
GCL=QU(4,0)#; 00137000
DEFINE SMEM(SMEM1)=QU(6," "&SMEM1[41:35:36])#; 00138000
DEFINE LMEM(LMEM1)=QU(7," "&LMEM1[41:35:36])#; 00139000
DEFINE INLEX(INLEX1)=IL(1,0,0,INLEX1)#,INTLX=IL(0,0,0,0)#, 00140000
LOADMODE(LOADMODE1,LOADMODE2)=IL(2,LOADMODE1,LOADMODE2,0)#; 00141000
DEFINE ID(ID1)=(ID1.TYPE=TYPECODE AND ID1.ADDR LSS 10000 00142000
AND ID1.ADDR GEQ 2000)#, 00143000
INT(INT1)=(INT1.TYPE=TYPELOGIC)#, 00144000
NBR(NBR1)=(NBR1.TYPE=TYPELOGIC OR (IF NBR1.TYPE=TYPEAREA 00144010
THEN (IF REF(AT0,NBR1).ADDR EQL 3 THEN TRUE ELSE FALSE)ELSE FALSE))#, 00144020
SPCHAR(SPCHAR1)=(SPCHAR1.TYPE=TYPECODE AND SPCHAR1.ADDR 00145000
LEQ 576 AND SPCHAR1.ADDR GEQ 512)#; 00146000
% 00147000
% FORWARD PROCEDURE DECLARATIONS 00148000
% 00149000
REAL PROCEDURE TAIL(STRING); VALUE STRING; REAL STRING; FORWARD; 00150000
REAL PROCEDURE USERS(F);REAL F ;FORWARD; 00151000
REAL PROCEDURE USERL(X);REAL X ;FORWARD; 00152000
REAL PROCEDURE PSCAN(IJ,X,F);REAL X,F;INTEGER IJ;FORWARD; 00153000
REAL PROCEDURE BNFTREE(F);REAL F ;FORWARD; 00154000
PROCEDURE MEMSAVE(X,N,Y); 00155000
VALUE N,Y;ARRAY X[0];REAL N,Y; FORWARD; 00156000
PROCEDURE UNSAVE(X,N,FID); 00157000
VALUE FID;ARRAY X[0];REAL N,FID;FORWARD; 00158000
PROCEDURE GARBAGECOLLECT(QMEM,N); 00159000
VALUE N;ARRAY QMEM[0];REAL N; 00160000
FORWARD; 00161000
REAL PROCEDURE COPY(X);VALUE X;REAL X;FORWARD; 00162000
PROCEDURE DOTRACE(PROCESS);VALUE PROCESS;REAL PROCESS;FORWARD; 00163000
PROCEDURE EQLIST(X,Y);VALUE X,Y;REAL X,Y;FORWARD; 00164000
PROCEDURE PRINT(X);VALUE X;REAL X;FORWARD; 00165000
PROCEDURE UREAD(FIL,BUF);VALUE FIL;REAL FIL;ARRAY BUF[0];FORWARD; 00166000
BOOLEAN PROCEDURE EQ(X,Y);VALUE X,Y;REAL X,Y;FORWARD; 00167000
REAL PROCEDURE LEXFIND;FORWARD; 00168000
REAL PROCEDURE QU(P,Y); 00169000
VALUE P,Y;INTEGER P;REAL Y; 00170000
FORWARD; 00171000
PROCEDURE PRIMERROR(A,V); 00172000
VALUE A,V;REAL A,V;FORWARD; 00173000
REAL PROCEDURE CONS(X,Y);VALUE X,Y;REAL X,Y;FORWARD; 00174000
REAL PROCEDURE CAR(X);VALUE X;REAL X; FORWARD; 00175000
REAL PROCEDURE CDR(X);VALUE X;REAL X; FORWARD; 00176000
PROCEDURE MASGN(A,V);VALUE A,V;REAL A,V;FORWARD; 00177000
PROCEDURE RESUME(PROCESS);VALUE PROCESS;REAL PROCESS;FORWARD; 00178000
PROCEDURE RETURN(PROCESS,VAL); 00179000
VALUE PROCESS,VAL;REAL PROCESS,VAL;FORWARD; 00180000
PROCEDURE DEBUG;FORWARD; 00181000
PROCEDURE INTERP;FORWARD; 00182000
PROCEDURE SYSM;FORWARD; 00183000
REAL PROCEDURE CREATE(START,ENV,INTERPRETER,PROCESS); 00184000
VALUE START,ENV,INTERPRETER,PROCESS; 00185000
REAL START,ENV,INTERPRETER,PROCESS;FORWARD; 00186000
PROCEDURE ASGN(X,Y,Z);VALUE X,Y,Z;REAL X,Y,Z;FORWARD; 00187000
REAL PROCEDURE NEWSYMB(ASSO);VALUE ASSO;REAL ASSO;FORWARD; 00188000
REAL PROCEDURE REF(X,Y);VALUE X,Y;REAL X,Y; 00189000
FORWARD; 00190000
REAL PROCEDURE HANGON (X,Y); 00191000
VALUE X,Y; REAL X,Y;FORWARD; 00192000
REAL PROCEDURE IL(M,C,CM,F); 00193000
INTEGER M; REAL C,CM,F; FORWARD; 00194000
REAL PROCEDURE CHAR(P,N); 00195000
POINTER P; INTEGER N; FORWARD; 00196000
REAL PROCEDURE PMAKE(T,N);VALUE T,N;REAL T,N;FORWARD; 00197000
REAL PROCEDURE DA(X);VALUE X;REAL X;FORWARD; 00197010
REAL PROCEDURE AD(X);VALUE X;REAL X;FORWARD; 00197020
REAL PROCEDURE AR(X,Y,Z);VALUE X,Y,Z;REAL X,Y,Z;FORWARD; 00197030
PROCEDURE APLPNT(X);VALUE X;REAL X;FORWARD; 00197040
REAL PROCEDURE TAIL(STRING);VALUE STRING;REAL STRING; 00198000
BEGIN REAL X; 00198010
IF CAR(TAIL:=X:=CDR(STRING)).TYPE=TYPEAREA AND NOT NBR(CAR(X)) THEN 00199000
ASGN(AT0,STRING,(TAIL:=CONS(USERS(CAR(X)),X))) END; 00200000
REAL PROCEDURE QU(P,Y); 00201000
VALUE P,Y;INTEGER P;REAL Y; 00202000
BEGIN OWN INTEGER N;REAL V; 00203000
DEFINE PR(PR1)=(PR1.[41:19])#; 00204000
FORMAT F1(I4,": ",A4,I6,", ",A4,I6); 00205000
INTEGER L,LP; ALPHA A; 00206000
LABEL B1,B2,BB,BB1; 00207000
SWITCH PSW:=B1,B2,BB,B2,B2,B2,B2,B2; 00208000
GO TO PSW[P]; 00209000
BB:N:=0; 00210000
V:=MAKE(TYPELOGIC,0); 00211000
Y:=CONS(LABTAB,CONS(Y,NULLIST)); 00212000
P:=8; 00213000
GO TO BB1; 00214000
B1:QU:=ATOMUND; 00215000
V:=REF(ATOMPRIORITY,Y); 00216000
BB1:N:=N+1; 00217000
A:=Y&V[45:22:23]; 00218000
B2: BEGIN OWN ALPHA ARRAY X[0:N]; 00219000
LABEL B3,B4,B5,B6,B7,B8,B9; 00220000
LABEL B10,QDUMP,MEMDP,MEMLD,QIN,QSET; 00221000
INTEGER I,K,IS; 00222000
ALPHA XS; 00223000
SWITCH SW:=B3,B4,B5,B10,QDUMP,MEMDP,MEMLD,QIN,QSET; 00224000
GO TO SW[P]; 00225000
QSET:K:=LASTUSEDSPACE.[18:18]+2; 00225010
FOR I:=0 STEP 1 UNTIL N DO 00225020
X[I]:=MEMORY[(K+I).[17:9],(K+I).[8:9]]; 00225030
LABTAB:=CAR(X[0].[45:23]);HASH:=CAR(CDR(X[0].[45:23])); 00225031
GO TO B9; 00225040
QIN: X[0]:=Y&Y[45:22:23]; 00226000
GO TO B3; 00227000
QDUMP:FOR P:=0 STEP 1 UNTIL N DO 00228000
WRITE(DATA,F1,P,TYPEARRAY[X[P].[45:4]],X[P].[41:19], 00229000
TYPEARRAY[X[P].TYPE],X[P].ADDR); 00230000
GO TO B9; 00231000
MEMDP:MEMSAVE(X,N,Y); GO TO B9; 00232000
MEMLD:UNSAVE(X,N,Y);P:=9;GO TO B2; 00233000
B10:GARBAGECOLLECT(X,N); 00234000
LABTAB:=CAR(X[0].[45:23]); 00235000
HASH:=CAR(CDR(X[0].[45:23]));GO TO B9; 00236000
B3:X[N]:=A; 00237000
; 00238000
I:=N; 00239000
B6:IS:=I DIV 2; 00240000
IF I LSS 2 THEN GO TO B9 00241000
ELSE IF PR(X[I]) GTR PR(X[IS]) THEN 00242000
BEGIN XS:=X[IS]; 00243000
X[IS]:=X[I]; 00244000
X[I]:=XS; 00245000
I:=IS; GO TO B6 END 00246000
ELSE GO TO B9; 00247000
B4:QU:=X[1].[22:23]; 00248000
X[0]:=X[0]&X[1][22:22:23]; 00249000
00250000
I:=1 00251000
; 00252000
IS:= 2|I; 00253000
WHILE IS LSS N DO BEGIN 00254000
IF PR(X[IS]) GTR PR(X[IS+1]) 00255000
THEN BEGIN X[I]:=X[IS]; 00256000
I:=IS END 00257000
ELSE BEGIN X[I]:=X[IS+1]; 00258000
I:=IS+1 END; 00259000
IS:=2|I END 00260000
; 00261000
IF IS GTR N THEN BEGIN 00262000
N:=N-1 00263000
; 00264000
FOR K:=I STEP 1 UNTIL N DO 00265000
X[K]:=X[K+1]; 00266000
IF N EQL 0 THEN BEGIN 00267000
N:=N+1; GO TO B9 END END 00268000
ELSE BEGIN N:=N-1;X[I]:=X[IS]END; 00269000
P:=3; GO TO B2; 00270000
B5:P:=2; 00271000
B9: PRIORITY:=X[1].[45:23] END 00272000
END QU; 00273000
PROCEDURE PRIMERROR (A,V); 00274000
VALUE A,V;REAL A,V; 00275000
BEGIN FORMAT F1("SERR:",A4,X1,A4,I6); 00276000
WRITE(DATA,F1,A,TYPEARRAY[V.TYPE],V.ADDR); 00277000
A:=0/0; 00278000
END PRIMERROR; 00279000
% 00280000
% B A S E L A N G U A G E I N T E R P R E T E R 00281000
% 00282000
%ROUTINE INTERPRET(PROCESS)= 00283000
% [ INT1: WHEN STATUS/PROCESS NEQ "SUSPENDED"; 00284000
% IF STATUS/PROCESS NEQ "RESUMED" THEN DELETE(SELF); 00285000
% INSTVAL(PROCESS); 00286000
% GO TO INT1 ]; 00287000
% 00288000
%ROUTINE INSTVAL(PROCESS)= 00289000
% [ INST:= INST/NEXT/PROCESS; 00290000
% NEXT/PROCESS:= SUCCESSOR/NEXT/PROCESS; 00291000
% ARGVAL(INST, PROCESS); 00292000
% RETURN(CALLER/SELF); DELETE(SELF) ]; 00293000
% 00294000
%ROUTINE ARGVAL(ARG,PROCESS)= 00295000
% [ IF ATOM(ARG) THEN ARG:= I(ARG)/ENV/PROCESS ELSE 00296000
% ARG:= APPLY(OPVAL(AP/ARG,PROCESS),ARGLIST/ARG,PROCESS); 00297000
% RETURN(CALLER/SELF,ARG); DELETE(SELF)]; 00298000
% 00299000
%ROUTINE OPVAL(OP,PROCESS)= 00300000
% [ IF NOT ATOM(OP) THEN OP:= ARGVAL(OP,PROCESS); 00301000
% IF ATOM OP THEN OP:= I(OP)/MACHINE; 00302000
% RETURN(CALLER/SELF,OP); DELETE(SELF) ]; 00303000
% 00304000
%ROUTINE APPLY(ROUTINE,ARGLIST,PROCESS)= 00305000
% IF ATOM(ROUTINE) THEN 00306000
% [RETURN(CALLER/SELG, PRIMVAL(ROUTINE, 00307000
% LISTVAL(ARGLIST,PROCESS),PROCESS)); DELETE(SELF)]; 00308000
% ENV:=PARAPASS(FPARA/ROUTINE,MAKE("CONSTRUCT"), 00309000
% ARGLIST,PROCESS); 00310000
% RETURN(CALLER/SELF, CALL(ROUTINE,ENV,PROCESS)); 00311000
% DELETE(SELF) ]; 00312000
% 00313000
%ROUTINE CALL(ROUTINE,ENV,PROCESS)= 00314000
% [ RESUME(CREATE(START/ROUTINE,ENV,INTERPRETER/ROUTINE, 00315000
% PROCESS)); 00316000
% DELETE(SELF) ]; 00317000
% 00318000
%ROUTINE PARAPASS(FPARA,ENV,ARGLIST,PROCESS)= 00319000
% [ IF FPARA NEQ "NIL" AND ARGLIST NEQ "NIL" THEN 00320000
% IF CAR(FPARA) = "UNDEF" THEN 00321000
% CAR(CDR(FPARA))/ENV:= LISTVAL(ARGLIST,PROCESS) ELSE 00322000
% [ CAR(FPARA)/ENV:= ARGVAL(CAR(ARGLIST),PROCESS); 00323000
% ENV:= PARAPASS(CDR(FPARA),ENV,CDR(ARGLIST),PROCESS) ]; 00324000
% RETURN(CALLER/SELF,ENV) ]; 00325000
% 00326000
%ROUTINE LISTVAL(ARGLIST,PROCESS)= 00327000
% [ IF ARGLIST="NIL" THEN 00328000
% RETURN(CALLER/SELF,"NIL") ELSE 00329000
% RETURN(CALLER/SELF,CONS(ARGVAL(CAR(ARGLIST),PROCESS), 00330000
% LISTVAL(CDR(ARGLIST),PROCESS)) ]; 00331000
% 00332000
PROCEDURE INTERP; 00333000
BEGIN REAL ARG,ARGLIST,STRING,OP,ENV,FPARA,SAV,T,PROCESS; 00334000
DEFINE ROUTINE=OP#; 00335000
DEFINE GET1=CAR(ARG)#,GET=CAR((ARG:=CDR(ARG)))#; 00336000
DEFINE STACK(STACK1)=SAV:=CONS(STACK1,SAV)#, 00337000
EXIT=BEGIN T:=CAR(SAV);SAV:=CDR(SAV); 00338000
IF T.TYPE NEQ TYPECODE THEN PRIMERROR("EXIT",T); 00339000
GO TO RETSW[T.ADDR]END#; 00340000
LABEL INTERPRET,INSTVAL,ARGVAL,APPLY,CALL,OPVAL,PARAPASS, 00341000
LISTVAL,PRIMVAL,RETURNVAL,INT1,OP1,L1, 00342000
R1,R2,R3,R4,R5,R6,R7,R8,R9,R10,R11,R12,R13,R14,R15, 00343000
R16,R17,R18,R19,R20,R21,R22,R23,R24,R25,R26,R27,R28,R29,R30,R31, 00344000
R32,R33,R34,R35,R36,R37,R38,R39,R40,R41,R42,R43,R44,R45, 00345000
R46,LEND,R47,R48,R49,R50,R51,R52,R53,R54,R55,R56,R57; 00346000
SWITCH RETSW:=R1,R2,R3,R4,R5,R6,R7,R8,R9,R10,R11,R12,R13,R14,R15, 00347000
R16,R17,R18,R19,R20,R21,R22,R23,R24,R25,R26,R27,R28,R29,R30,R31, 00348000
R32,R33,R34,R35,R36,R37,R38,R39,R40,R41,R42,R43,R44,R45,R46,R47,R48, 00349000
R49,R50,R51,R52,R53,R54,R55,R56,R57; 00350000
REAL RC2,RC3,RC4,RC5,RC6,RC7,RC8,RC10; 00350001
REAL PROCEDURE UNSTCK(SAV);REAL SAV; 00351000
BEGIN UNSTCK:=CAR(SAV);SAV:=CDR(SAV)END; 00352000
DEFINE LV(LV1)=BEGIN STACK(MAKE(TYPECODE,LV1)); 00353000
GO TO LISTVAL;END#; 00354000
DEFINE UNSTACK=UNSTCK(SAV)#; 00355000
LABEL BNFINSTVAL,BNFEXITVAL,BNFTERMVAL,BNFRETURNVAL, 00356000
BNFNONTERMVAL,WAITRETURN,BNFL1,BNFL2,BNFL3; 00357000
REAL INST,X,VAL; 00358000
DEFINE STR=CODE(1006)#,SLEXUNIT=CODE(1013)#, 00359000
SID=CODE(1014)#,SINT=CODE(1015)#, 00360000
SSPCHAR=CODE(1016)#,SQUOTE=CODE(122)#, 00361000
SCGINT=CODE(1017)#,TREE=CODE(1018)#, 00362000
N=CODE(1019)#,CODE(CODE1)=TOKEN(CODE1)#; 00363000
DEFINE SNBR=CODE(1020)#; 00364000
BOOLEAN PROCEDURE LOOK1(X,Y);VALUE X,Y;REAL X,Y; 00364010
IF(X=SLEXUNIT)OR(X=SID AND ID(Y)) OR(X=SINT AND INT(Y)) 00364020
OR(X=SNBR AND NBR(Y))OR(X=SSPCHAR AND SPCHAR(Y)) 00364030
OR(X=Y)OR(X.TYPE EQL TYPELIST) 00364040
OR(X=CODE(1012)) THEN LOOK1:=TRUE ELSE LOOK1:=FALSE; 00364050
PROCESS:=UQ; 00364060
SAV:=REF(AT7,PROCESS); 00365000
RC2:=MAKE(TYPECODE,2); 00366000
RC3:=MAKE(TYPECODE,3); 00367000
RC4:=MAKE(TYPECODE,4); 00368000
RC5:=MAKE(TYPECODE,5); 00369000
RC6:=MAKE(TYPECODE,6); 00370000
RC7:=MAKE(TYPECODE,7); 00371000
RC8:=MAKE(TYPECODE,8); 00372000
RC10:=MAKE(TYPECODE,10); 00373000
EXIT; 00374000
INTERPRET:R1: %(PROCESS) 00375000
IF REF(AT2,PROCESS) NEQ ATOMRESUMED THEN GO TO INT1; 00376000
IF REF(AT1,PROCESS) LSS PRIORITY THEN 00377000
BEGIN STACK(RC1);T:=QQ(PROCESS); 00378000
INT1:ASGN(AT7,PROCESS,SAV); 00379000
PROCESS:=UQ;SAV:=REF(AT7,PROCESS); EXIT END; 00380000
IF TRACE THEN BEGIN ASGN(AT7,PROCESS,SAV); 00381000
DOTRACE(PROCESS) END; 00382000
STACK(RC1); 00383000
IF (OP:=REF(AT5,PROCESS))=TOKEN(1004) THEN GO TO INSTVAL; 00384000
IF OP=TOKEN(1005) THEN GO TO BNFINSTVAL; 00385000
IF OP=TOKEN(1017) THEN GO TO INSTVAL; 00386000
ASGN(AT1,(ENV:=PMAKE(TYPECONS,0)),PROCESS); 00387000
GO TO CALL; 00388000
INSTVAL: %(PROCESS)=ARG 00389000
ARG:=REF(AT3,PROCESS); 00390000
ASGN(AT3,PROCESS,CDR(ARG)); 00391000
IF ARG=NULLIST THEN GO TO RETURNVAL; 00392000
ARG:=CAR(ARG); 00393000
STACK(TOKEN(27)); GO TO ARGVAL;R27: 00394000
ASGN(TOKEN(1000),REF(AT4,PROCESS),ARG); 00395000
EXIT; 00396000
ARGVAL: %(ARG,PROCESS)=ARG 00397000
IF ATOM(ARG) THEN ARG:=REF(ARG,REF(AT4,PROCESS)) ELSE 00398000
BEGIN STACK(CDR(ARG)); 00399000
OP:=CAR(ARG); 00400000
STACK(RC2); GO TO OPVAL;R2: 00401000
ARGLIST:=UNSTACK; 00402000
GO TO APPLY END; EXIT; 00403000
APPLY: %(OP,ARGLIST,PROCESS)=ARG 00404000
IF ROUTINE.TYPE=TYPECODE THEN GO TO PRIMVAL; 00405000
FPARA:=REF(AT1,ROUTINE); 00406000
ENV:=PMAKE(TYPECONS,0); 00407000
STACK(ROUTINE); 00408000
STACK(RC3);GO TO PARAPASS; R3: 00409000
ROUTINE:=UNSTACK; 00410000
%GO TO CALL; 00411000
CALL: %(OP,ENV,PROCESS)=ARG 00412000
ASGN(AT7,PROCESS,SAV); 00413000
PROCESS:=CREATE(REF(AT2,ROUTINE),ENV,REF(AT3,ROUTINE),PROCESS); 00413010
R39:ASGN(AT2,PROCESS,ATOMRESUMED); 00414000
GO TO INTERPRET; 00415000
R9:IF REF(AT5,PROCESS)=CODE(1005) THEN %BNFINT 00416000
BEGIN VAL:=UNSTACK;GO TO BNFRETURNVAL END; 00417000
ARG:=UNSTACK; 00418000
EXIT; 00419000
OPVAL: %(OP,PROCESS)=ARG 00420000
IF ATOM(OP) THEN GO TO OP1; 00421000
BEGIN 00422000
ARG:=OP; 00423000
STACK(RC4); GO TO ARGVAL;R4: 00424000
OP:=ARG END; 00425000
OP1:EXIT; 00426000
PARAPASS: %(FPARA,ENV,ARGLIST,PROCESS)=ENV 00427000
IF FPARA NEQ NULLIST THEN IF ARGLIST NEQ NULLIST THEN 00428000
IF CAR(FPARA)=ATOMUNDEF THEN 00429000
BEGIN STACK(ENV);STACK(CAR(CDR(FPARA))); 00430000
STACK(RC5);GO TO LISTVAL;R5: 00431000
ASGN(UNSTACK,UNSTACK,ARG)END ELSE 00432000
BEGIN STACK(FPARA);STACK(ENV);STACK(CDR(ARGLIST)); 00433000
ARG:=CAR(ARGLIST); 00434000
STACK(RC6);GO TO ARGVAL;R6: 00435000
ARGLIST:=UNSTACK;ENV:=UNSTACK;FPARA:=UNSTACK; 00436000
ASGN(CAR(FPARA),ENV,ARG); 00437000
FPARA:=CDR(FPARA);GO TO PARAPASS;END; 00438000
EXIT; 00439000
LISTVAL: %(ARGLIST,PROCESS)=ARG 00440000
IF ARGLIST NEQ NULLIST THEN 00441000
BEGIN STACK(CDR(ARGLIST));ARG:=CAR(ARGLIST); 00442000
STACK(RC7);GO TO ARGVAL;R7: 00443000
ARGLIST:=UNSTACK;STACK(ARG); 00444000
STACK(RC8);GO TO LISTVAL;R8: 00445000
ARG:=CONS(UNSTACK,ARG); 00446000
END ELSE ARG:=ARGLIST; EXIT; 00447000
RETURNVAL: %(PROCESS) 00448000
IF(OP:=REF(AT6,PROCESS))NEQ ATOMUNDEF THEN 00449000
BEGIN ARG:=REF(TOKEN(1000),REF(AT4,PROCESS)); 00450000
RETURN(OP,ARG)END; 00451000
DELETE(PROCESS);GO TO INT1 ; 00452000
BNFINSTVAL: %(PROCESS) 00453000
ASGN(AT3,PROCESS,CDR((INST:=REF(AT3,PROCESS)))); 00454000
IF INST=NULLIST THEN GO TO BNFEXITVAL ELSE 00455000
IF ATOM((ARG:=CAR(INST))) THEN GO TO BNFTERMVAL ELSE 00456000
GO TO BNFNONTERMVAL; 00457000
00458000
BNFEXITVAL: %(PROCESS) 00459000
SUSPEND(PROCESS); RETURN(COPY(REF(AT6,PROCESS)),PROCESS); 00460000
ASGN(AT5,PROCESS,SCGINT); EXIT; 00461000
00462000
BNFTERMVAL: %(ARG,PROCESS) 00463000
X:=CAR((STRING:=REF(STR,(ENV:=REF(AT4,PROCESS))))); 00464000
IF ARG=SLEXUNIT THEN GO TO BNFL1; 00465000
IF ARG=SID THEN GO TO (IF ID(X) THEN BNFL1 ELSE BNFL2); 00466000
IF ARG=SINT THEN GO TO (IF INT(X) THEN BNFL1 ELSE BNFL2); 00467000
IF ARG=SSPCHAR THEN GO TO (IF SPCHAR(X) THEN BNFL1 ELSE BNFL2); 00468000
IF ARG=SNBR THEN GO TO(IF NBR(X) THEN BNFL1 ELSE BNFL2); 00469000
IF ARG=(OP:=CODE(117)) THEN GO TO PRIMVAL; 00469010
IF ARG=CODE(1012) THEN GO TO BNFEXITVAL; 00470000
IF X=ARG THEN 00471000
ASGN(STR,ENV,TAIL(STRING)) ELSE GO TO BNFL2; 00472000
EXIT; 00473000
BNFL1: INST:=CONS(SQUOTE,CONS(X,NULLIST)); 00474000
X:=CREATE(CONS(INST,NULLIST),PMAKE(TYPECONS,0),SCGINT,PROCESS); 00475000
ASGN(STR,ENV,TAIL(STRING)); 00476000
ASGN(TREE,ENV,CONS(X,REF(TREE,ENV))); 00477000
ASGN(N,ENV,REF(N,ENV)+1);EXIT; 00478000
BNFL2:DELETE(PROCESS); EXIT; 00479000
00480000
BNFRETURNVAL: %(PROCESS,VAL) 00481000
ASGN(AT4,PROCESS,ENV:=COPY(REF(AT4,PROCESS))); 00482000
ASGN(TREE,ENV,CONS(VAL,REF(TREE,ENV))); 00483000
ASGN(STR,ENV,REF(STR,REF(AT4,VAL))); 00484000
ASGN(N,ENV,REF(N,ENV)+1); EXIT; 00485000
00486000
BNFNONTERMVAL: %(ARG,PROCESS) 00487000
IF CAR(ARG) NEQ CODE(118) THEN PRIMERROR("BNF ",ARG); 00488000
X:=NULLIST;ENV:=REF(AT4,PROCESS); 00489000
ARGLIST:=CDR(ARG); 00490000
WHILE ARGLIST NEQ NULLIST DO 00491000
IF LOOK1(CAR(CAR(ARGLIST)),CAR(REF(STR,ENV))) THEN 00492000
BEGIN ENV:=COPY(ENV); 00493000
ASGN(TREE,ENV,NULLIST); 00493010
ASGN(N,ENV,AT0); 00494000
X:=CONS(CREATE(CAR(ARGLIST),ENV,CODE(1005),PROCESS),X); 00495000
ARGLIST:=CDR(ARGLIST) END ELSE ARGLIST:=CDR(ARGLIST) ; 00496000
GO TO WAITRETURN; 00497000
WAITRETURN: %(X) 00498000
WHILE X NEQ NULLIST DO 00499000
BEGIN RESUME(CAR(X)); X:=CDR(X) END; 00500000
GO TO INT1; 00501000
PRIMVAL: %(OP,ARGLIST,PROCESS)=ARG 00502000
CASE ROUTINE.ADDR-100 OF BEGIN 00503000
IF ATOM(CAR(ARGLIST)) THEN % ASGN=CODE 100 00504000
BEGIN STACK(CAR(ARGLIST)); ARGLIST:=CDR(ARGLIST); 00505000
LV(41);R41:ASGN(UNSTACK,GET1,ARG:=GET) END ELSE 00506000
BEGIN LV(11);R11:ASGN(GET1,GET,(ARG:=GET))END; %ASGN=CODE100 00507000
IF ATOM(CAR(ARGLIST)) THEN % REF=CODE 101 00508000
BEGIN STACK(CAR(ARGLIST));ARGLIST:=CDR(ARGLIST); 00509000
LV(42);R42:ARG:=REF(UNSTACK,GET1) END ELSE 00510000
BEGIN LV(12);R12:ARG:=REF(GET1,GET)END; %REF=CODE101 00511000
BEGIN LV(13);R13:ARG:=CAR(GET1)END; %CAR=CODE 102 00512000
BEGIN LV(14);R14:ARG:=CDR(GET1)END; %CDR=CODE103 00513000
BEGIN LV(15);R15:ARG:=CONS(GET1,GET)END; %CONS=CODE 104 00514000
BEGIN LV(16);R16:ARG:=NEWSYMB(GET1)END; %NEWSYMB 00515000
ARG:=AMTSPACE; %AMTSPACE 00516000
BEGIN LV(17);R17:ARG:=PMAKE(GET1.TYPE,GET)END; %MAKE 00517000
BEGIN LV(18);R18:PRINT((ARG:=GET1))END; %PRINT 00518000
BEGIN LV(19);R19:ARG:=INLEX(GET1)END; %INLEX 00519000
BEGIN SUSPEND(PROCESS);RESUME(PROCESS);GCL; 00520000
PROCESS:=UQ;ARG:=AMTSPACE END; % GCL 00521000
BEGIN LV(20);R20:ARG:=CREATE(GET1,GET,GET,GET)END; %CREATE 00522000
BEGIN LV(21);R21: DELETE(GET1);ARG:=ATOMUNDEF END;%DELETE 00522010
BEGIN LV(22);R22: ARG:=GET1;SUSPEND(ARG)END; %SUSPEND 00523000
BEGIN LV(23);R23:RESUME((ARG:=GET1))END; %RESUME 00524000
BEGIN LV(24);R24:RETURN(GET1,(ARG:=GET))END; %RETURN=CODE115 00525000
BEGIN LV(25);R25:ARG:=GET1 END; %IDENTITY=CODE116 00526000
BEGIN SUSPEND(PROCESS);SMEM("RERUN1") ; GO TO LEND END;%HALT = CODE 1100527000
PRIMERROR("C118",PROCESS);%RESERVED FOR CODE118 00528000
PRIMERROR("C119",PROCESS);%RESERVED FOR CODE119 00529000
BEGIN LV(33);R33:ASGN(TOKEN(1009),REF(AT4,PROCESS), 00530000
(ARG:=GET))END; % TRACE=CODE120 00531000
BEGIN LV(26);R26:EQLIST(GET1,(ARG:=GET))END; %EQLIST 00532000
ARG:=CAR(ARGLIST); %QUOTE=CODE122 00533000
IF ATOM(CAR(ARGLIST)) THEN % ASGNENV=CODE 123 00534000
BEGIN STACK(CAR(ARGLIST)); ARGLIST:=CDR(ARGLIST); 00535000
LV(43);R43:ASGN(UNSTACK,REF(AT4,PROCESS),(ARG:=GET1)) END ELSE 00536000
BEGIN LV(28);R28:ASGN(GET1,REF(AT4,PROCESS),(ARG:=GET))END;%ASGNENV=CODE00537000
IF ATOM(CAR(ARGLIST)) THEN %REFENV=CODE 124 00538000
BEGIN STACK(CAR(ARGLIST)); ARGLIST:=CDR(ARGLIST); 00539000
LV(44);R44:ARG:=REF(UNSTACK,REF(AT4,PROCESS)) END ELSE 00540000
BEGIN LV(29);R29:ARG:=REF(GET1,REF(AT4,PROCESS))END; %REFENV=CODE124 00541000
BEGIN LV(30);R30:ARG:=GET1;GO TO ARGVAL END; %EXE=CODE125 00542000
DEBUG; %DEBUG=CODE126 00543000
BEGIN LV(49);R49:ARG:=LOADMODE(GET1,GET) END; %LDMODE=127 00544000
ARG:=PMAKE(TYPECONS,0); %CONSTRUCT=CODE128 00545000
BEGIN LV(31);R31:ARG:=PMAKE(TYPEAREA,GET1)END; 00546000
%AREA = CODE129 00547000
BEGIN LV(48);R48:ARG:=TOKEN(GET1.ADDR) END;%TOKEN=CODE 130 00548000
BEGIN LV(32);R32:ASGN(TOKEN(1008),REF(AT4,PROCESS), 00549000
(ARG:=GET1))END; % SINGLESTEP=CODE131 00550000
BEGIN ASGN(AT1,PROCESS,REF(AT1,PROCESS)+1); 00551000
ARG:=ATOMUNDEF END; %UP=CODE132 00552000
BEGIN ASGN(AT1,PROCESS,REF(AT1,PROCESS)-1); 00553000
ARG:=ATOMUNDEF END; %DP=CODE133 00554000
;%BEGIN LV(34);R34:UREAD((ARG:=GET1))END; %READ=CODE134 00555000
;% RESERVED FOR CODE 135 00556000
GO TO LISTVAL; % LIST=CODE 136 00557000
BEGIN STACK(CDR(ARGLIST)); ARG:=CAR(ARGLIST); %COND=CODE 137 00558000
STACK(TOKEN(36));GO TO ARGVAL;R36:ARGLIST:=UNSTACK; 00559000
IF ARG.TYPE=TYPELOGIC THEN 00560000
BEGIN ARG:=(IF BOOLEAN(ARG) THEN CAR(ARGLIST) ELSE REF(AT2,ARGLIST)); 00561000
GO TO ARGVAL END ELSE ARG:=ATOMUNDEF END; 00562000
BEGIN LV(37);R37:ARG:=(IF EQ(GET1,GET) THEN AT(524287) 00563000
ELSE AT0) END; % EQ=CODE 138 00564000
BEGIN LV(38);R38:ARG:=GET1; % ATOM=CODE 139 00565000
ARG:=(IF ATOM(ARG) THEN AT(524287) ELSE AT0) END; 00566000
BEGIN PROCESS:=CREATE(ARGLIST,REF(AT4,PROCESS),REF(AT5, 00567000
PROCESS),PROCESS); 00568000
GO TO R29 END ; % BLOCKOP=CODE 140 00569000
BEGIN LV(40);R40:ARG:=(IF EQ(GET1,GET) THEN AT0 00570000
ELSE AT(524287)) END; % NEG=CODE 141 00571000
BEGIN STACK(CAR(CDR(ARGLIST))); ARG:=CAR(ARGLIST);%IF=CODE 142 00572000
STACK(TOKEN(45));GO TO ARGVAL;R45:ARGLIST:=UNSTACK; 00573000
IF BOOLEAN(ARG) THEN ASGN(AT3,PROCESS,ARGLIST) END; 00574000
BEGIN ENV:=REF(AT4,PROCESS);%NONTERM=CODE143 00575000
ASGN(STR,ENV,AT0); 00576000
BNFL3:IF (ARG:=REF(N,ENV)).ADDR GTR 0 THEN 00577000
BEGIN ASGN(N,ENV,ARG-1);ASGN(STR,ENV,REF(STR,ENV)+1); 00577050
ASGN(AT6,ARG:=REF(ARG,REF(TREE,ENV)),PROCESS); 00578000
STACK(CODE(46));RESUME(ARG); 00579000
GO TO INT1;R46: 00579050
ENV:=REF(AT4,PROCESS); 00580000
ASGN(REF(STR,ENV),ENV,ARG);GO TO BNFL3 END; 00581000
ARG:=REF(AT1,ENV); 00582000
ASGN(TREE,ENV,ATOMUNDEF); 00583000
ASGN(STR,ENV,ATOMUNDEF); 00583050
ASGN(N,ENV,ATOMUNDEF) END NONTERM; 00584000
BEGIN LV(47);R47:ARG:=USERL(GET1) END;%USERL=CODE 144 00585000
ARG:=LABTAB; %LTAB=CODE 145 00586000
BEGIN LV(50);R50:ARG:=COPY(GET1) END; %COPY=CODE 146 00586010
BEGIN LV(51);R51:ARG:=AR(0,GET1,GET) END; %ADD=CODE 147 00586020
BEGIN LV(52);R52:ARG:=AR(1,GET1,GET) END; %SUB=CODE 148 00586030
BEGIN LV(53);R53:ARG:=AR(2,GET1,GET) END; %MUL=CODE 149 00586035
BEGIN LV(54);R54:ARG:=AR(3,GET1,GET) END; %DIV=CODE 150 00586040
BEGIN LV(55);R55:ARG:=AR(4,GET1,GET) END; %EX=CODE 151 00586045
BEGIN LV(56);R56:ARG:=AR(2,GET1,AD(-1)) END; %NEG=CODE 152 00586050
BEGIN LV(57);R57:ARG:=IF LOOK1(GET1,GET) THEN AT(524287) 00586055
ELSE AT0 END % LOOK1=CODE 153 00586060
END CASE STATEMENT; 00586070
EXIT; 00586080
L1:ASGN(AT7,PROCESS,SAV);DOTRACE(PROCESS); 00587000
R10:R35:R34: % THESE ARE TO BE LATER MOVED 00588000
LEND:XX1:=PROCESS; END INTERP; 00589000
PROCEDURE GARBAGECOLLECT(QMEM,N); 00590000
VALUE N;ARRAY QMEM[0];REAL N; 00591000
BEGIN REAL RP,WP,X,XADDR,BASE,TYP,I; 00592000
LABEL L1,L2,L3,L4,L5,L6; 00593000
ARRAY TMEM[0:MEMORYROWS,0:511]; 00594000
DEFINE CP(CP1,CP2)=%CONSTRUCT PROCESSING 00595000
BEGIN IF (X:=M[XADDR]).TYPE NEQ TYPEGARBAGE THEN 00596000
BEGIN TMASGN((WP:=WP+1),X); 00597000
MASGN(XADDR,MAKE(TYPEGARBAGE,WP)); 00598000
CP1(RP,MAKE(XADDR.TYPE,WP),CP2)END ELSE 00599000
CP1(RP,MAKE(XADDR.TYPE,X),CP2)END#; 00600000
DEFINE LP(LP1,LP2)= 00601000
BEGIN IF (X:=CAR(XADDR)).TYPE = TYPEGARBAGE THEN 00602000
LP1(RP,MAKE(TYPELIST,X),LP2)ELSE 00603000
IF CARADDR=NULLIST THEN LP1(RP,NULLIST,LP2)ELSE 00604000
BEGIN LP1(RP,MAKE(TYPELIST,(WP:=WP+1)),LP2)#, 00605000
LLP(LLP1)=TMASGN(WP,X); 00606000
MASGN(CARADDR,MAKE(TYPEGARBAGE,WP)); 00607000
XADDR:=CDR(XADDR); 00608000
IF (X:=CAR(XADDR)).TYPE NEQ TYPEGARBAGE THEN 00609000
IF CARADDR NEQ NULLIST THEN 00610000
BEGIN WP:=WP+1;GO TO LLP1 END ELSE 00611000
TMASGN((WP:=WP+1),LINKTONIL)ELSE 00612000
TMASGN((WP:=WP+1),MAKE(TYPELINK,X))END END #; 00613000
DEFINE TM[TM1]=(IF BOOLEAN(TM1) THEN 00614000
TMEM[(TM1).[18:9],(TM1).[9:9]].[22:23]ELSE 00615000
TMEM[(TM1).[18:9],(TM1).[9:9]].[45:23])#, 00616000
Q[Q1]=(IF BOOLEAN(Q1) THEN QMEM[Q1.[10:10]].[22:23] ELSE 00617000
QMEM[Q1.[10:10]].[45:23])#, 00618000
TMASGN(TMASGN1,TMASGN2)=TA(TMASGN1,TMASGN2,TMEM)#, 00619000
QASGN(QASGN1,QASGN2)=QA(QASGN1,QASGN2,QMEM)#; 00620000
PROCEDURE TA(A,V,M);VALUE A,V;REAL A,V;ARRAY M[0,0]; 00621000
IF BOOLEAN(A) THEN M[A.[18:9],A.[9:9]].[22:23]:=V ELSE 00622000
M[A.[18:9],A.[9:9]].[45:23]:=V; 00623000
PROCEDURE QA(A,V,M);VALUE A,V;REAL A,V;ARRAY M[0]; 00624000
IF BOOLEAN(A) THEN M[A.[10:10]].[22:23]:=V ELSE 00625000
M[A.[10:10]].[45:23]:=V; 00626000
FORMAT F1("GCL:",I6," WORDS RECOVERED.",I6," WORDS IN USE."); 00627000
WP:=0; 00628000
% COPY FROM M TO TM UPSIDE DOWN USING Q 00629000
FOR RP:=N+N+1 STEP -1 UNTIL 0 DO 00630000
CASE (XADDR:=Q[RP]).TYPE OF 00631000
BEGIN PRIMERROR("GCL1",XADDR);%GARBAGE 00632000
L1:CP(QA,QMEM); %CONSTRUCT 00633000
LP(QA,QMEM);L2:LLP(L2);%LIST 00634000
L5:IF (X:=M[XADDR]).TYPE=TYPEGARBAGE THEN %AREA 00635000
QASGN(RP,MAKE(XADDR.TYPE,X))ELSE 00636000
BEGIN WP:=WP+1; 00637000
FOR I:=X.ADDR STEP -1 UNTIL 0 DO 00638000
TMASGN(WP+I,M[XADDR-I]); 00639000
QASGN(RP,MAKE(XADDR.TYPE,WP)); 00640000
MASGN(XADDR,MAKE(TYPEGARBAGE,WP)); 00641000
WP:=WP+X.ADDR END; 00642000
PRIMERROR("GCL2",XADDR); %FIELD 00643000
IF XADDR NEQ ATOMUNDEF THEN GO TO L1; %SYMBOL 00644000
; %LOGIC 00645000
PRIMERROR("GCL3",XADDR); %LINK 00646000
GO TO L5; %PROCESS 00647000
GO TO L5; %MONITOR 00648000
GO TO L5; %GENERAL 00649000
; %TOKEN 00650000
PRIMERROR("GCL4",XADDR); %TP12 00651000
PRIMERROR("GCL5",XADDR); %TP13 00652000
PRIMERROR("GCL6",XADDR); %TP14 00653000
PRIMERROR("GCL7",XADDR); %TP15 00654000
END CASE STATEMENT; 00655000
%COPY FROM M TO TM UPSIDE DOWN USING TM 00656000
FOR RP:=1 STEP 1 UNTIL WP DO 00657000
CASE (XADDR:=TM[RP]).TYPE OF BEGIN 00658000
PRIMERROR("GCL8",XADDR); %GARBAGE 00659000
L3:CP(TA,TMEM); %CONSTRUCT 00660000
LP(TA,TMEM);L4:LLP(L4);%LIST 00661000
L6:IF (X:=M[XADDR]).TYPE=TYPEGARBAGE THEN %AREA 00662000
TMASGN(RP,MAKE(XADDR.TYPE,X))ELSE 00663000
BEGIN WP:=WP+1; 00664000
FOR I:=X.ADDR STEP -1 UNTIL 0 DO 00665000
TMASGN(WP+I,M[XADDR-I]); 00666000
TMASGN(RP,MAKE(XADDR.TYPE,WP)); 00667000
MASGN(XADDR,MAKE(TYPEGARBAGE,WP)); 00668000
WP:=WP+X.ADDR END; 00669000
PRIMERROR("GCL9",XADDR); %FIELD 00670000
IF XADDR NEQ ATOMUNDEF THEN GO TO L3; %SYMBOL 00671000
; %LOGIC 00672000
; %LINK 00673000
GO TO L6; %PROCESS 00674000
GO TO L6; %MONITOR 00675000
GO TO L6; %GENERAL 00676000
; %TOKEN 00677000
END CASE STATEMENT; 00678000
% COPY FROM TM TO M AND INVERT 00679000
BASE:=WP+1; 00680000
LASTUSEDSPACE:=0; 00681000
FOR RP:=WP STEP -1 UNTIL 1 DO 00682000
BEGIN X:=TM[RP]; 00683000
IF (TYP:=X.TYPE) NEQ TYPELOGIC THEN 00684000
IF TYP NEQ TYPECODE THEN 00685000
IF X.ADDR NEQ 524287 THEN 00686000
X:=MAKE(TYP,BASE-X.ADDR); 00687000
MASGN(STEPSPACE,X) END; 00688000
% FIX ADDRESSES IN Q 00689000
FOR RP:=N+N+1 STEP -1 UNTIL 0 DO 00690000
IF (TYP:=Q[RP].TYPE) NEQ TYPELOGIC THEN 00691000
IF TYP NEQ TYPECODE THEN 00692000
IF Q[RP].ADDR NEQ 524287 THEN 00693000
QASGN(RP,MAKE(TYP,BASE-Q[RP].ADDR)); 00694000
WRITE(DATA,F1,AMTSPACE,LASTUSEDSPACE); 00695000
END GARBAGE COLLECT; 00696000
REAL PROCEDURE COPY(X);VALUE X;REAL X; 00697000
BEGIN LABEL L1,L2;REAL I; 00698000
CASE X.TYPE OF BEGIN 00699000
L1:PRIMERROR("COPY",X); %GARBAGE 00700000
MASGN((COPY:=PMAKE(X.TYPE,0)),COPY(M[X]));%CONSTRUCT 00701000
COPY:=(IF X=NULLIST THEN NULLIST ELSE CONS(CAR(X),COPY(CDR 00702000
(X)))); %LIST 00703000
L2:BEGIN FOR I:=M[X].ADDR STEP -1 UNTIL 0 DO %AREA 00704000
MASGN(STEPSPACE, M[X-I]); 00705000
COPY:=MAKE(X.TYPE,LASTUSEDSPACE)END; 00706000
GO TO L1; %FIELD 00707000
COPY:=X; %SYMBOL 00708000
COPY:=X; %LOGIC 00709000
GO TO L1; %LINK 00710000
GO TO L2; %PROCESS 00711000
GO TO L2; %MONITOR 00712000
GO TO L2; %GENERAL 00713000
COPY:=X; %TOKEN 00714000
END CASE STATEMENT; 00715000
END COPY; 00716000
BOOLEAN PROCEDURE EQ(X,Y);VALUE X,Y; REAL X,Y; 00717000
IF X=Y THEN EQ:=TRUE ELSE 00718000
IF X.TYPE NEQ Y.TYPE THEN EQ:= FALSE ELSE 00719000
IF X.TYPE NEQ TYPELIST THEN EQ := FALSE ELSE 00720000
BEGIN X:=CAR(X); X:=CARADDR; 00721000
Y:=CAR(Y);EQ:=X=CARADDR 00722000
END OF EQ; 00723000
REAL PROCEDURE CAR(Y);VALUE Y;REAL Y; 00724000
BEGIN LABEL L1,L2; 00725000
IF Y.TYPE NEQ TYPELIST THEN 00726000
IF Y.TYPE NEQ TYPELINK THEN PRIMERROR("CAR ",Y); 00727000
IF Y=NULLIST THEN GO TO L2; 00728000
L1:CARADDR:=Y; 00729000
IF (Y:=M[Y]).TYPE=TYPELINK THEN 00730000
IF Y NEQ LINKTONIL THEN GO TO L1 ELSE 00731000
L2:BEGIN CAR:=ATOMUNDEF; 00732000
CARADDR:=NULLIST END ELSE 00733000
CAR:=Y END CAR; 00734000
REAL PROCEDURE CDR(Y);VALUE Y;REAL Y; 00735000
BEGIN Y:=CAR(Y); 00736000
IF CARADDR NEQ NULLIST THEN Y:=CAR(MAKE(TYPELIST,DEC(CARADDR))); 00737000
CDR:=MAKE(TYPELIST,CARADDR); 00738000
END CDR; 00739000
PROCEDURE EQLIST(X,Y);VALUE X,Y;REAL X,Y; 00740000
BEGIN REAL T1,T2;LABEL LEND; 00741000
T1:=CAR(Y);T1:=CARADDR;T2:=CAR(X); 00742000
IF T1=CARADDR THEN GO TO LEND; 00743000
IF CARADDR=NULLIST THEN PRIMERROR("EQL2",X); 00744000
MASGN(X,MAKE(TYPELINK,T1)); 00745000
LEND:END EQLIST; 00746000
REAL PROCEDURE CONS(X,Y);VALUE X,Y;REAL X,Y; 00747000
BEGIN IF Y.TYPE NEQ TYPELIST THEN PRIMERROR("CONS",Y); 00748000
IF Y.ADDR NEQ LASTUSEDSPACE THEN MASGN(STEPSPACE,MAKE(TYPELINK,Y)); 00749000
MASGN(STEPSPACE,X); 00750000
CONS:=MAKE(TYPELIST,LASTUSEDSPACE)END CONS; 00751000
REAL PROCEDURE REF(X,Y);VALUE X,Y;REAL X,Y; 00752000
BEGIN LABEL L1,L2,L3,L4;REAL T1,T2; 00753000
CASE Y.TYPE OF 00754000
BEGIN PRIMERROR("REF1",Y);%GARBAGE 00755000
L1:BEGIN T1:=M[Y];%CONSTRUCT 00756000
L2:IF CAR(T1) NEQ ATOMUNDEF THEN 00757000
IF CAR(T1) NEQ X THEN 00758000
BEGIN T1:=CDR(T1)-1;GO TO L2 END ELSE 00759000
REF:=CAR(CDR(T1))ELSE 00760000
REF:=ATOMUNDEF END; 00761000
IF X=ATOMCAR THEN REF:=CAR(Y) ELSE%LIST 00762000
IF X=ATOMCDR THEN REF:=CDR(Y) ELSE 00763000
IF X.TYPE NEQ TYPELOGIC THEN REF:=ATOMUNDEF ELSE 00764000
BEGIN FOR X:=X.ADDR STEP -1 UNTIL 2 DO Y:=CDR(Y); 00765000
REF:=CAR(Y) END; 00766000
L3:BEGIN IF X.TYPE=TYPELOGIC THEN %AREA 00767000
IF X.ADDR LEQ M[Y].ADDR THEN 00768000
BEGIN REF:=M[Y-X.ADDR];GO TO L4 END; 00769000
REF:=ATOMUNDEF; 00770000
L4:END; 00771000
PRIMERROR("REF4",Y);%FIELD 00772000
IF X=ATOMASSO THEN %SYMBOL 00773000
REF:=(IF Y=ATOMUNDEF THEN Y ELSE M[Y])ELSE 00774000
PRIMERROR("REF5",Y); 00775000
PRIMERROR("REF6",Y);%LOGIC 00776000
PRIMERROR("REF7",Y);%LINK 00777000
GO TO L3; %PROCESS 00778000
GO TO L3;%MONITOR 00779000
PRIMERROR("REF8",Y);%GENERAL 00780000
PRIMERROR("REF9",Y);%CODE 00781000
END CASE STATEMENT; 00782000
END REF; 00783000
PROCEDURE ASGN(X,Y,Z);VALUE X,Y,Z;REAL X,Y,Z; 00784000
BEGIN LABEL L1,L2,L3;REAL T1,T2; 00785000
CASE Y.TYPE OF 00786000
BEGIN PRIMERROR("ASG1",Y);%GARBAGE 00787000
L1:BEGIN T1:=M[Y];%CONSTRUCT 00788000
IF X=ATOMUNDEF THEN PRIMERROR("ASGD",Y); 00789000
L2:IF CAR(T1) NEQ ATOMUNDEF THEN 00790000
IF CAR(T1) NEQ X THEN 00791000
BEGIN T1:=DEC(CDR(T1));GO TO L2 END ELSE 00792000
IF Z NEQ ATOMUNDEF THEN 00793000
MASGN(CDR(T1),Z) ELSE 00794000
IF T1=M[Y] THEN MASGN(Y,CDR(CDR(T1)))ELSE 00795000
MASGN(T1,MAKE(TYPELINK,CDR(CDR(T1))))ELSE 00796000
IF Z NEQ ATOMUNDEF THEN MASGN(Y,CONS(X,CONS(Z,M[Y])))END; 00797000
BEGIN T1:=CAR(Y);%LIST 00798000
IF CARADDR=NULLIST THEN PRIMERROR("ASG0",Y); 00799000
IF X=ATOMCAR THEN MASGN(CARADDR,Z)ELSE 00800000
IF X=ATOMCDR THEN 00801000
IF Z.TYPE NEQ TYPELIST THEN PRIMERROR("ASGC",Z)ELSE 00802000
MASGN(CARADDR,MAKE(TYPELINK,CONS(M[CARADDR],Z)))ELSE 00803000
IF X.TYPE NEQ TYPELOGIC THEN PRIMERROR("ASG2",X ) ELSE 00804000
BEGIN T1:=CARADDR; 00805000
FOR X:=X.ADDR STEP -1 UNTIL 2 DO 00806000
BEGIN IF (Y:=CDR(Y))=NULLIST THEN MASGN(T1-1,(Y:=MAKE(TYPELINK, 00807000
CONS(ATOMUNDEF,NULLIST)))); 00808000
T1:=Y END; 00809000
MASGN(Y,Z) END END; 00810000
L3:BEGIN IF X.TYPE NEQ TYPELOGIC THEN PRIMERROR("ASG3",X);%AREA 00811000
IF (X:=X.ADDR) GTR M[Y].ADDR THEN PRIMERROR("ASGA",Y); 00812000
IF X=0 THEN 00813000
IF X.TYPE NEQ TYPELOGIC OR X GTR M[Y] THEN PRIMERROR("ASGB",Z); 00814000
MASGN(Y-X,Z)END; 00815000
PRIMERROR("ASG4",Y);%FIELD 00816000
IF X=ATOMASSO AND Y NEQ ATOMUNDEF THEN MASGN(Y,Z)ELSE%SYMBOL 00817000
PRIMERROR("ASG5",Y); 00818000
PRIMERROR("ASG6",Y);%LOGIC 00819000
PRIMERROR("ASG7",Y);%LINK 00820000
GO TO L3; %PROCESS 00821000
GO TO L3;%MONITOR 00822000
PRIMERROR("ASG8",Y);%GENERAL 00823000
PRIMERROR("ASG9",Y);%CODE 00824000
END CASE STATEMENT; 00825000
END ASGN; 00826000
REAL PROCEDURE PMAKE(T,N);VALUE T,N;REAL T,N; 00827000
BEGIN LABEL L1,L2,L3; REAL I; 00828000
CASE T OF BEGIN 00829000
L1:PRIMERROR("MK1 ",T); %GARBAGE 00830000
L2:BEGIN MASGN(STEPSPACE,NULLIST); %CONSTRUCT 00831000
PMAKE:=MAKE(T,LASTUSEDSPACE)END; 00832000
PMAKE:= NULLIST; %LIST 00833000
L3:IF N.TYPE NEQ TYPELOGIC THEN PRIMERROR("MK2 ",N)ELSE%AREA 00834000
BEGIN FOR I:=N.ADDR STEP -1 UNTIL 1 DO 00835000
MASGN(STEPSPACE,ATOMUNDEF); 00836000
MASGN(STEPSPACE,N); 00837000
PMAKE:=MAKE(T,LASTUSEDSPACE)END; 00838000
GO TO L1; %FIELD 00839000
PMAKE:=NEWSYMB(N); %SYMBOL 00840000
PMAKE:=AT0; %LOGIC 00841000
GO TO L1; %LINK 00842000
GO TO L3; %PROCESS 00843000
GO TO L3; %MONITOR 00844000
GO TO L3;%GENERAL 00845000
PMAKE:=NEXTTOKEN:=NEXTTOKEN+1; %TOKEN 00846000
END CASE STATEMENT; 00847000
END PMAKE; 00848000
REAL PROCEDURE NEWSYMB(ASSO);VALUE ASSO;REAL ASSO; 00849000
BEGIN MASGN(STEPSPACE,ASSO); 00850000
NEWSYMB:=MAKE(TYPESYMB,LASTUSEDSPACE)END NEWSYMB; 00851000
REAL PROCEDURE CHAR(P,N); 00852000
POINTER P; INTEGER N; 00853000
BEGIN REAL ARRAY X[0:0]; 00854000
X[0]:=0; 00855000
IF N LSS 8 AND N GTR 0 THEN 00856000
REPLACE POINTER(X)+(8-N) BY P FOR N; 00857000
CHAR:=X[0] END; % END OF CHAR 00858000
REAL PROCEDURE HANGON (X,Y); 00859000
VALUE X,Y; REAL X,Y; 00860000
BEGIN LABEL L1,L2; 00861000
POINTER P;REAL ARRAY XD[0:0],X1[0:0];REAL Z 00862000
; 00863000
P:=POINTER(STACK[STACKPOSITION.[18:7],*])+STACKPOSITION.[11:12]; 00864000
X1[0]:=1;Z:=NULLIST; 00865000
WHILE Y NEQ NULLIST DO 00866000
BEGIN Z:=CONS(CAR(Y),Z);Y:=CDR(Y)END; 00867000
WHILE Z NEQ NULLIST DO 00868000
BEGIN 00869000
XD[0]:=CAR(Z); 00870000
REPLACE P:=P+1 BY POINTER(XD)+7 FOR 1; 00871000
X1[0]:=X1[0]+1; 00872000
Z:=CDR(Z) END; 00873000
REPLACE POINTER(STACK[STACKPOSITION.[18:7],*])+ 00874000
STACKPOSITION.[11:12] BY POINTER(X1)+7 FOR 1; 00875000
IF X1[0] EQL 2 THEN BEGIN 00876000
X1[0]:=LOADMODE(XD[0],X1[0]).ADDR; 00877000
IF X1[0] EQL 2 OR X1[0] EQL 66 THEN BEGIN 00878000
HANGON:=TOKEN(XD[0].ADDR+512);X1[0]:=LOADMODE(XD[0],X1[0]); 00879000
GO TO L2 END; 00880000
X1[0]:=LOADMODE(XD[0],X1[0]) END; 00881000
HANGON:=LEXFIND; 00882000
L2:END OF HANGON; 00883000
REAL PROCEDURE IL(M,C,CM,F); 00884000
INTEGER M; REAL C,CM,F; 00885000
BEGIN % PROCEDURE BLOCK; 00886000
DEFINE N=72#, NCPW=8#; 00887000
DEFINE FILIN=DATA#, 00888000
LAST="$"#; 00889000
DEFINE TOTCHAR = 64#; 00890000
DEFINE X=LEXTREE#; 00891000
BEGIN % OWN BLOCK; 00892000
OWN ALPHA ARRAY D[0:N DIV NCPW]; 00893000
OWN REAL ARRAY MODE [0:TOTCHAR]; 00894000
OWN INTEGER COUNT; 00895000
OWN POINTER P; 00896000
OWN REAL ARRAY SS[0:63]; 00897000
CASE M OF BEGIN 00898000
BEGIN INTEGER I; % M IS 0; 00898050
I:=0; 00899000
WHILE I LEQ 9 DO 00900000
BEGIN MODE[I]:=1;I:=I+1 END; 00901000
WHILE I LEQ 63 DO 00902000
BEGIN MODE[I]:=0; I:=I+1 END; 00903000
MODE[" "] := 3; 00904000
MODE[I]:=68; 00905000
FILL SS[*] WITH ".","[","(","&","$","*",")",";", 00906000
""","/",",","%","=","]",""","#","@",":","+","?","|" ; 00907000
FOR I:=0 STEP 1 UNTIL 20 DO MODE[SS[I]]:=2 ; 00907050
COUNT:=0 END ; % E0 M0 00907060
BEGIN % M IS 1; 00907080
LABEL L1,L2,L3,L4,L5,L6; 00908000
INTEGER I,J,IE;REAL IL1; 00909000
BOOLEAN EOL,IE1; 00910000
REAL E; 00911000
REAL Y; 00912000
I:=0; 00913000
L4: IF COUNT EQL 0 THEN 00914000
BEGIN 00915000
UREAD(F,D[*]); 00916000
P:=POINTER(D); 00917000
GO TO L6; 00918000
END 00919000
ELSE IF COUNT EQL N 00920000
THEN BEGIN 00921000
E:=MAKE(TYPELOGIC,LAST); 00922000
J:=MODE[TOTCHAR].[5:6]; 00923000
EOL:=TRUE END 00924000
ELSE L6:BEGIN 00925000
E:=MAKE(TYPELOGIC,CHAR(P,1)); 00926000
J:=MODE[CHAR(P,1)];P:=P+1; 00927000
EOL:=BOOLEAN(J.[6:1]); 00928000
J:=J.[5:6] END; 00929000
L5: CASE J OF BEGIN 00930000
BEGIN % -J IS 0; 00931000
CASE I OF BEGIN 00932000
BEGIN % I IS 0; 00933000
Y:=CONS(E,NULLIST); 00934000
I:=1; 00935000
GO TO L1 END; % E0 I0 00936000
BEGIN % I IS 1; 00937000
Y:=CONS(E,Y); 00938000
GO TO L1 END; % E0 I1; 00939000
BEGIN %I IS 2 00940000
J:=2;GO TO L5 END % E0 I2 00941000
END % CASE OF I; 00942000
END; % E0 -J0 00943000
BEGIN % -J IS 1; 00944000
CASE I OF BEGIN 00945000
BEGIN % I IS 0; 00946000
IL1:=E.ADDR; I:=2;IE1:=FALSE; 00947000
GO TO L1 END; % E0 I0; 00948000
BEGIN % I IS 1; 00949000
Y:=CONS(E,Y); 00950000
GO TO L1 END; % EQ I1; 00951000
BEGIN % I IS 2; 00952000
IF IE1 THEN 00953000
IL1:=IL1+E.ADDR/10|(IE:=IE+1) ELSE 00954000
IL1:=IL1|10+E.ADDR; 00954010
GO TO L1 END % E0 I2; 00954020
END % CASES OF I; 00955000
END; % E0 -J1; 00956000
BEGIN % -J IS 2 SPECIAL; 00957000
CASE I OF BEGIN 00958000
BEGIN % I IS 0; 00959000
IL:=HANGON(X,CONS(E,NULLIST)); 00960000
GO TO L3 END; % E0 I0; 00961000
BEGIN % I IS 1; 00962000
IL:=HANGON(X,Y); 00963000
P:=P-1; 00964000
GO TO L2 END; % E0 I1; 00965000
BEGIN % I IS 2; 00966000
IF E.ADDR EQL "." THEN 00967000
BEGIN IE:=0;IE1:=TRUE;GO TO L1 END; 00968000
IL:=AD(IL1);IE1:=FALSE; 00968010
P:=P-1; GO TO L2 END % E0 I2; 00968020
END % CASES OF I; 00969000
END;% E0 -J2; 00970000
BEGIN % -J IS 3 SPACE; 00971000
CASE I OF BEGIN 00972000
BEGIN % I IS 0; 00973000
GO TO L1 END; % E0 I0; 00974000
BEGIN % I IS 1; 00975000
IL:=HANGON(X,Y); 00976000
GO TO L3 END; % E0 I1; 00977000
BEGIN % I IS 2; 00978000
IL:=AD(IL1);IE1:=FALSE; 00979000
GO TO L3 END % E0 I2; 00980000
END % CASES OF I; 00981000
END; % E0 -J3; 00982000
00983000
BEGIN % -J IS 4 IGNORE; 00984000
GO TO L1 END % E0-J4; 00985000
END;% CASES OF -J; 00986000
L1: IF EOL THEN COUNT:=0 00987000
ELSE COUNT:=COUNT+1; 00988000
GO TO L4; 00989000
L3: IF EOL THEN COUNT:=0 00990000
ELSE COUNT:=COUNT+1; 00991000
L2: END; % E0 M1 00992000
BEGIN % M IS 2; 00993000
IL:=MAKE(TYPELOGIC,MODE[C.ADDR]); 00994000
MODE[ C.ADDR]:=CM.ADDR; 00995000
END % E0 M2; 00996000
END % CASES OF M; 00997000
END % OWN BLOCK; 00998000
END;% PROCEDURE BLOCK *** END OF INLEX *** 00999000
REAL PROCEDURE LEXFIND; 01000000
BEGIN INTEGER T1,T,T2,T3; 01001000
DEFINE X=STACKPOSITION#, 01002000
P(P1)=POINTER(STACK[(P1.[18:7]),*])+P1.[11:12]#; 01003000
LABEL LEND; 01004000
CHR:=0; 01005000
REPLACE CP BY P(X) FOR 1; 01006000
T1:=CHR; 01007000
REPLACE CP-5 BY P(X) FOR (IF T1 LSS 6 THEN T1 ELSE 6); 01008000
T:=T3:=REF((T2:=AT(CHR MOD 127 )+1), HASH); 01009000
WHILE T NEQ NULLIST DO 01010000
IF P(X) NEQ P((CAR(T)-2000)) FOR T1 THEN 01011000
T:=CDR(T) ELSE 01012000
BEGIN LEXFIND:=CAR(T); GO TO LEND END; 01013000
ASGN(T2,HASH,CONS(LEXFIND:=TOKEN(X+2000),T3)); 01014000
X:=X+T1; 01015000
LEND:END LEXFIND; 01016000
PROCEDURE UREAD(FIL,BUF); VALUE FIL; REAL FIL; ARRAY BUF[0]; 01017000
BEGIN 01018000
FILE IN DISKFIL DISK RANDOM (1,10,150,SAVE 999); 01019000
POINTER PX; 01020000
LABEL REM, L1,EOF; 01021000
REAL MFID,FID,N,X; 01022000
IF REF(AT6,FIL)=TOKEN(1010)THEN GO TO REM; %REMOTE DEVICE 01023000
IF REF(AT6,FIL)=TOKEN(1011)THEN %DISK 01024000
BEGIN CHR:=0; 01025000
X:= REF(AT2,FIL)-2000; 01026000
PX:=POINTER(STACK[(X.[18:7]),*])+(X.[11:12]); 01027000
REPLACE CP BY PX:PX FOR 1; 01028000
N:=(IF CHR GTR 7 THEN 7 ELSE (CHR-1)); 01029000
REPLACE CP-5 BY " " FOR 6; 01030000
REPLACE CP-6 BY PX:PX FOR N; 01031000
MFID:=CHR; 01032000
CHR:=0; 01033000
X:= REF(AT3,FIL)-2000; 01034000
PX:=POINTER(STACK[(X.[18:7]),*])+(X.[11:12]); 01035000
REPLACE CP BY PX:PX FOR 1; 01036000
N:=(IF CHR GTR 7 THEN 7 ELSE (CHR-1)); 01037000
REPLACE CP-5 BY " " FOR 6; 01038000
REPLACE CP-6 BY PX:PX FOR N; 01039000
FID:=CHR; 01040000
FILL DISKFIL WITH MFID, FID; 01041000
READ(DISKFIL [REF(AT1,FIL).ADDR],10,BUF[*])[EOF]; 01042000
WRITE(DATA,10,BUF[*]); 01043000
ASGN(AT1,FIL,REF(AT1,FIL)+1); 01043010
GO TO L1 END; 01044000
EOF: PRIMERROR("URED",FIL); 01045000
REM: READ(DATA,9,BUF[*]); 01046000
L1: END UREAD; 01047000
PROCEDURE MEMSAVE(X,N,Y); 01048000
VALUE N,Y;ARRAY X[0];REAL N,Y; 01049000
BEGIN INTEGER I,K;REAL M00; 01050000
SAVE FILE MEMFL DISK SERIAL[20:25] (2,512,512,SAVE 999); 01051000
FILL MEMFL WITH Y,TIME(-1); 01052000
K:=LASTUSEDSPACE.[18:18]+1; 01053000
MEMORY[K.[17:9],K.[8:9]]:=M00:=MEMORY[0,0]; 01054000
MEMORY[0,0]:=N&LASTUSEDSPACE[45:22:23]; 01055000
FOR I:=0 STEP 1 UNTIL N DO BEGIN 01056000
K:=K+1; MEMORY[K.[17:9],K.[8:9]]:=X[I] END; 01057000
FOR I:=0 STEP 1 UNTIL K.[17:9] DO 01058000
WRITE (MEMFL,512,MEMORY[I,*]); 01059000
STACK[0,0]:=STACKPOSITION; I:=-1; 01060000
WHILE I:=I+1 LEQ STACKPOSITION.[18:7] DO 01061000
WRITE (MEMFL,512,STACK[I,*]); 01062000
LOCK(MEMFL); 01063000
MEMORY[0,0]:=M00;END OF SAVE; 01064000
PROCEDURE UNSAVE(X,N,FID); 01065000
VALUE FID;ARRAY X[0];REAL N,FID; 01066000
BEGIN INTEGER I,K; 01067000
SAVE FILE MEMFL DISK SERIAL(1,512,512); 01068000
IF BOOLEAN(XX1)THEN FILL MEMFL WITH FID,TIME(-1)ELSE 01069000
FILL MEMFL WITH FID, XX2 & "B0005"[41:29:30]; 01070000
READ (MEMFL,512,MEMORY[0,*]); 01071000
LASTUSEDSPACE:=M[0].ADDR; N:=M[1].ADDR; 01072000
K:=LASTUSEDSPACE.[18:18]+N+2; 01073000
FOR I:=1 STEP 1 UNTIL K.[17:9] DO 01074000
READ (MEMFL,512,MEMORY[I,*]); K:=K-N; 01075000
READ (MEMFL,512,STACK[0,*]); 01076000
STACKPOSITION:=STACK[0,0]; I:=0; 01077000
WHILE I:=I+1 LEQ STACKPOSITION.[18:7] DO 01078000
READ (MEMFL,512,STACK[I,*]); 01079000
MEMORY[0,0]:=MEMORY[(K-1).[17:9],(K-1).[8:9] 01080000
] END OF UNSAVE; 01081000
REAL PROCEDURE BNFTREE(F); 01082000
REAL F; 01083000
BEGIN INTEGER I; 01084000
REAL X,Y,Y1,Z,Z1; 01085000
LABEL L1,L2,L3,L4,L5,L6,L7; 01086000
REAL ARRAY SS[0:5]; 01087000
PROCEDURE ERR(I);INTEGER I; 01088000
BEGIN 01089000
FORMAT F1(X3,"$ ON LHS"); 01090000
FORMAT F2(X3,"NON-TERMINAL IS TYPE LOGIC"); 01091000
CASE I OF BEGIN; 01092000
WRITE(DATA,F1); 01093000
WRITE(DATA,F2); 01094000
END END OF ERR; 01095000
SWITCH SW :=L5,L6,L4; 01096000
FILL SS[*] WITH "=",";","$",":","@","#"; 01097000
FOR I:= 0 STEP 1 UNTIL 5 DO BEGIN 01098000
X:=LOADMODE(SS[I],2); 01099000
X:=CONS(MAKE(TYPELOGIC,SS[I]),NULLIST); 01100000
SS[I]:=HANGON(X,X) END; 01101000
X:=LOADMODE("%",68); 01102000
L6:Z:=CONS(MAKE(TYPECODE,118),NULLIST); 01103000
Y1:=CONS(ATOMUNDEF,NULLIST); 01104000
WHILE (X:=USERS(F)) NEQ SS[0] DO BEGIN 01105000
IF X EQL SS[2] THEN BEGIN ERR(1);GO TO L4 END; %$ ON LHS 01106000
IF X.TYPE EQL TYPELOGIC THEN BEGIN ERR(2); GO TO L4 END; % LOGIC ON L01107000
EQLIST(Y1,(Y1:=USERL(X))) END; 01108000
IF(X:=USERS(F)) EQL SS[4] AND CAR(Y1) NEQ ATOMUNDEF 01109000
THEN BEGIN EQLIST(Z,Y1); GO TO L5 END 01110000
ELSE BEGIN EQLIST(Y1,Z); Y1:=Y:=CONS(MAKE(TYPECODE,119),NULLIST); 01111000
GO TO L7 END; 01112000
L5:Y1:=Y:=CONS(MAKE(TYPECODE,119),NULLIST); 01113000
L2:X:=USERS(F); 01114000
L7:IF X EQL SS[2] THEN BEGIN 01115000
ASGN(ATOMCDR,Y1,(Y1:=CONS(USERS(F),NULLIST))); 01116000
GO TO L2 END; % TERMINAL 01117000
IF X EQL SS[4] THEN 01118000
BEGIN I:=1; GO TO L3 END; % @ 01119000
IF X EQL SS[5] THEN 01120000
BEGIN 01121000
ASGN(ATOMCDR,Y1,(Y1:=CONS(USERL(X),NULLIST))); 01122000
ASGN(ATOMCDR,Y1,FNS(X)); 01123000
GO TO L7 END; 01124000
IF X EQL SS[1] THEN 01125000
BEGIN I:=2; GO TO L3 END; % SEMICOLON 01126000
IF X EQL SS[3] THEN 01127000
BEGIN I:=3; GO TO L3 END; % COLON 01128000
IF X.TYPE EQL TYPELOGIC THEN BEGIN ERR(2); GO TO L4 END; % NON-TERMINA01129000
ASGN(ATOMCDR,Y1,(Y1:=CONS(USERL(X),NULLIST))); 01130000
GO TO L2; 01131000
L3:ASGN(ATOMCDR,Z,CONS(CDR(Y),CDR(Z))); 01132000
GO TO SW[I]; 01133000
L4:BNFTREE:=LABTAB 01134000
END; % END OF BNFTREE 01135000
REAL PROCEDURE DA(X);VALUE X;REAL X; 01136000
BEGIN IF X.TYPE EQL TYPELOGIC THEN 01137000
DA:=X.ADDR ELSE 01138000
IF X.TYPE EQL TYPEAREA 01138010
THEN DA:=0&REF(AT1,X)[46:8:9]&REF(AT2,X)[37:18:19] 01138011
&REF(AT3,X)[18:18:19]ELSE PRIMERROR("DA",X) END; 01138012
REAL PROCEDURE AD(X);VALUE X;REAL X;IF X GTR 0 AND 01138013
X.[38:39] LSS 524288 THEN AD:=MAKE(TYPELOGIC,X) 01138014
ELSE BEGIN REAL AD1;AD1:=AD:=PMAKE(TYPEAREA,MAKE(TYPELOGIC,3)); 01138015
ASGN(AT1,AD1,MAKE(TYPELOGIC,X.[46:9])); 01138016
ASGN(AT2,AD1,MAKE(TYPELOGIC,X.[37:19])); 01138017
ASGN(AT3,AD1,MAKE(TYPELOGIC,X.[18:19]))END ; 01138018
REAL PROCEDURE AR(X,Y,Z);VALUE X,Y,Z;REAL X,Y,Z; 01138019
BEGIN REAL AR1,AR2; 01138020
REAL PROCEDURE FN(I,J,K);VALUE I,J,K;REAL I,J,K; 01138021
BEGIN REAL F;CASE I OF BEGIN 01138030
F:=J+K;F:=J-K;F:=J|K;F:=J/K;F:=J*K END; %END OF CASE 01138035
FN:=AD(F) END; 01138040
IF Y.TYPE EQL TYPELIST THEN 01138045
BEGIN AR2:=AR1:=CONS(ATOMUNDEF,NULLIST); 01138050
IF Z.TYPE EQL TYPELIST THEN 01138055
BEGIN WHILE Y NEQ NULLIST AND Z NEQ NULLIST DO 01138060
BEGIN ASGN(AT0,AR1,AR1:=CONS(FN(X,DA(CAR(Y)),DA(CAR(Z))), 01138065
NULLIST));Y:=CDR(Y);Z:=CDR(Z) END; 01138070
IF Y NEQ Z THEN PRIMERROR("AR",Y) ELSE AR:=CDR(AR2) END 01138080
ELSE BEGIN Z:=DA(Z); 01138085
WHILE Y NEQ NULLIST DO BEGIN 01138090
ASGN(AT0,AR1,AR1:=CONS(FN(X,DA(CAR(Y)),Z),NULLIST)); 01138100
Y:=CDR(Y) END; AR:=CDR(AR2) END 01138105
END ELSE IF Z.TYPE EQL TYPELIST THEN 01138110
BEGIN Y:=DA(Y);AR2:=AR1:=CONS(ATOMUNDEF,NULLIST); 01138115
WHILE Z NEQ NULLIST DO BEGIN 01138120
ASGN(AT0,AR1,AR1:=CONS(FN(X,Y,DA(CAR(Z))),NULLIST)); 01138125
Z:=CDR(Z) END; AR:=CDR(AR2) END 01138130
ELSE AR:=FN(X,DA(Y),DA(Z)) END; 01138140
PROCEDURE RETURN(PROCESS,VAL);VALUE PROCESS,VAL; 01138145
REAL PROCESS,VAL; 01139000
BEGIN IF PROCESS.TYPE NEQ TYPEPROCESS THEN PRIMERROR("RTRN", 01140000
PROCESS); 01141000
ASGN(AT7,PROCESS,CONS(RC9,CONS(VAL,REF(AT7,PROCESS)))); 01142000
PROCESS:=QQ(PROCESS)END RETURN; 01143000
PROCEDURE RESUME(PROCESS);VALUE PROCESS; REAL PROCESS; 01144000
BEGIN IF PROCESS.TYPE NEQ TYPEPROCESS THEN 01145000
PRIMERROR("RSM1",PROCESS); 01146000
IF REF(AT2,PROCESS) NEQ ATOMSUSPENDED THEN 01147000
PRIMERROR("RSM2",PROCESS); 01148000
ASGN(AT2,PROCESS,ATOMRESUMED); 01149000
ASGN(AT7,PROCESS,CONS(RC1,REF(AT7,PROCESS))); 01150000
PROCESS:=QQ(PROCESS) END RESUME; 01151000
REAL PROCEDURE CREATE(START,ENV,INTERPRETER,PROCESS); 01152000
VALUE START,ENV,INTERPRETER,PROCESS; 01153000
REAL START,ENV,INTERPRETER,PROCESS; 01154000
BEGIN REAL Y; 01155000
Y:=PMAKE(TYPEPROCESS,LOGIC(7)); 01156000
ASGN(AT1,Y,REF(AT1,PROCESS)); 01157000
ASGN(AT2,Y,ATOMSUSPENDED); 01158000
ASGN(AT3,Y,START); 01159000
ASGN(AT4,Y,ENV); 01160000
ASGN(AT5,Y,INTERPRETER); 01161000
ASGN(AT6,Y,PROCESS); 01162000
ASGN(AT7,Y,NULLIST); 01163000
CREATE:=Y END CREATE; 01164000
PROCEDURE DEBUG; 01165000
BEGIN FORMAT F1(8U),F2(A4,I6),F3(I6,":",A4,I6), 01166000
NOTE1("DEBUG?"), 01167000
NOTE2("INVALID PROCESS OPERATION"), 01168000
NOTE3("INVALID TYPE ON FIRST PARAMETER"), 01169000
NOTE4("INVALID TYPE ON SECOND PARAMETER"), 01170000
NOTE5("INVALID TYPE ON THIRD PARAMETER"), 01171000
NOTE7("SYSTEM SAVE AS FILE--",A6), 01172000
NOTE8("SYSTEM LOADED FROM FILE--",A6), 01173000
NOTE9("#"), 01174000
NOTE10("SYSTEM LOADED FROM FILE--",A6,X1,A2), 01175000
NOTE6("NO PREVIOUS EXECUTE"); 01176000
FORMAT FMTLUSP("AMTSPACE=",I6,", LASTUSEDSPACE=",I6); 01177000
REAL OP,T1,V1,T2,V2,T3,V3,I,JUNK,J; 01178000
REAL ENV,PROCESS,X; 01179000
BOOLEAN APLI;REAL APLENV,AP1,AP2,AP3,AP4; 01180000
LABEL L1,L2,L3,L4,L5,L6,LEND; 01180010
MONITOR ZERO; 01181000
DEFINE PP(PP1,PP2,PP3)=J:=0;WHILE TYPEARRAY[J] NEQ PP1 DO 01182000
IF J NEQ 15 THEN J:=J+1 ELSE 01183000
BEGIN WRITE(DATA,PP2);GO TO L2 END; 01184000
PP3:=MAKE(J,PP3)#, 01185000
P1=BEGIN PP(T1,NOTE3,V1)END#, 01186000
P2=BEGIN P1;PP(T2,NOTE4,V2)END#, 01187000
P3=BEGIN P2;PP(T3,NOTE5,V3)END#; 01188000
ZERO:=L2; 01189000
L1:WRITE(DATA,NOTE1); 01190000
L2:T1:=T2:=T3:="SYMB"; 01191000
V1:=V2:=V3:=524287; 01192000
READ(DATA[STOP],F1,OP,T1,V1,T2,V2,T3,V3,JUNK); 01193000
FOR I:=0 STEP 1 UNTIL NOOFPROCESSOPS DO 01194000
IF OP=PROCESSARRAY[I] THEN GO TO L3; 01195000
WRITE(DATA,NOTE2);GO TO L2; 01196000
L3:CASE I OF BEGIN 01197000
GO TO LEND; % E N D 01198000
BEGIN P3;ASGN(V1,V2,(V1:=V3))END; %ASGN 01199000
BEGIN P2; V1:=REF(V1,V2) END; %REF 01200000
BEGIN P1;V1:=QQ(V1);GO TO L2 END; %QQ 01201000
V1:=UQ; %UQ 01202000
BEGIN P1;V1:=CAR(V1) END; %CAR 01203000
BEGIN P1;V1:=CDR(V1) END; %CDR 01204000
BEGIN P2;V1:=CONS(V1,V2) END; %CONS 01205000
BEGIN P1;V1:=NEWSYMB(V1)END; %NEWSYMB 01206000
BEGIN WRITE(DATA,FMTLUSP,AMTSPACE,LASTUSEDSPACE);GO TO L2 END;%AMTSP 01207000
BEGIN P2;V1:=PMAKE(V1.TYPE,V2)END; %MAKE 01208000
BEGIN P1;PRINT(V1);WRITE(DATA,NOTE9);GO TO L2 END; %PRINT 01209000
;%BEGIN P3;V1:=LOADMODE(V1,V2,V3)END; %LDMODE 01210000
BEGIN GCL;GO TO L2 END;%GCL 01211000
BEGIN P1;IF V1 NEQ ATOMUNDEF THEN %INTERP 01212000
RESUME(V1);INTERP;GO TO L2 END; 01213000
V1:=LABTAB; 01214000
V1:=LEXTREE; 01215000
BEGIN P1;V1:=USERS(V1) END; % USERS 01216000
BEGIN SMEM(T1);WRITE(DATA,NOTE7,T1);GO TO L2 END;%SMEM 01217000
BEGIN XX1:=1;LMEM(T1); %LMEM 01218000
APLI:=FALSE; 01219000
WRITE(DATA,NOTE8,T1); 01219010
I:=41;T1:="LIST";V1:=REF(AT2,REF(TOKEN(2742),LABTAB)).ADDR; 01220000
T2:="AREA";V2:=REF(TOKEN(2608),LABTAB);GO TO L3 END; 01221000
BEGIN P1;V1:=STATS END;% PSCAN 01222000
BEGIN P1;V1:=BNFTREE(V1) END; % BNFTRE 01223000
BEGIN P2;V2:=USERS(V2);ASGN(V2,LABTAB,V1)END; % INCODE 01224000
BEGIN V1:=QU(5,0);WRITE(DATA,NOTE9);GO TO L2 END; %QDUMP 01225000
BEGIN FOR I:=T1 STEP 1 UNTIL V1 DO %DUMP 01226000
WRITE(DATA,F3,I,TYPEARRAY[M[I].TYPE],M[I].ADDR); 01227000
WRITE(DATA,NOTE9);GO TO L2 END; 01228000
BEGIN P1;PRIMERROR(T2,V1);GO TO L2 END; 01229000
BEGIN P1;MASGN(T2,V1) END; %MASGN 01230000
BEGIN P1; XX1:=V1;XX2:=T2;V1:=QU(5,1);GO TO L2 END;%QASGN 01231000
V1:=M[T1]; %M 01232000
BEGIN XX2:=T1;V1:=QU(5,2)END; %Q 01233000
BEGIN P1;ENV:=IF APLI THEN APLENV 01233010
ELSE PMAKE(TYPECONS,0); % EXE 01234000
LOADMODE("$",2); 01235000
PROCESS:= CREATE(NULLIST,ENV,TOKEN(1004),CONS(AT(262144),NULLIST)); 01236000
ASGN(AT6,PROCESS,ATOMUNDEF); 01237000
L4:ASGN(AT2,PROCESS,ATOMSUSPENDED); 01238000
ASGN(AT3,PROCESS,(X:=V1)); 01239000
WHILE CDR(X) NEQ NULLIST DO X:=CDR(X); 01240000
ASGN(AT0,X,CONS(CONS(TOKEN(117),NULLIST),NULLIST)); 01241000
RESUME (PROCESS); 01242000
INTERP; 01243000
ENV:=REF(AT4,PROCESS:=XX1); 01244000
ASGN(AT7,PROCESS,NULLIST); 01244010
V1:=REF(TOKEN(1000),ENV); 01244020
IF APLI THEN BEGIN APLPNT(V1); APLENV:=ENV; 01244025
I:=36;T1:="LIST";T2:="AREA";V1:=REF(TOKEN(5003),LABTAB); 01244030
V2:=REF(AT2,V1).ADDR;V1:=REF(AT1,V1).ADDR; 01245000
GO TO L3 END ; 01247000
END; 01248000
IF PROCESS.TYPE EQL TYPEPROCESS THEN GO TO L4 %CEXE 01249000
ELSE BEGIN WRITE(DATA,NOTE6);GO TO L2 END; 01250000
BEGIN XX1:=0;XX2:=" "; 01251000
LMEM(T1);WRITE(DATA,NOTE10,T1);GO TO L2 END; 01252000
BEGIN ARRAY X[0:9]; %READ 01253000
P1; UREAD(V1,X); 01254000
WRITE(DATA,9,X[*]); GO TO L2 END; 01255000
BEGIN POINTER SP,XP; % DSTACK 01256000
REAL N; ARRAY X[0:8]; 01257000
XP:=POINTER(X); SP:=POINTER(STACK[0,*]); 01258000
CHR:=N:=8; 01259000
WHILE N LSS STACKPOSITION DO 01260000
BEGIN REPLACE XP BY " " FOR 72; 01261000
REPLACE CP BY SP+N FOR 1; 01262000
REPLACE XP BY N+2000 FOR 4 DIGITS; 01263000
REPLACE XP+6 BY SP+N+1 FOR CHR-1; 01264000
N:=N+CHR; 01265000
WRITE(DATA,9,X[*]) END; 01266000
WRITE(DATA,NOTE9);GO TO L2 END DSTACK; 01267000
BEGIN P1;X:=V1; % MODELD 01268000
L6:V1:=ATOMUNDEF;T1:=3;T2:=T3:=0; 01269000
READ(DATA,F1,V1,T1,T2,T3,V2,V3,OP,JUNK); 01270000
IF V1=ATOMUNDEF THEN GO TO L2; 01271000
V1:=AT(V1+1);T1:=T1&T2[14:3:4]&T3[18:3:4]; 01272000
ASGN(V1,X,AT(T1));GO TO L6 END; 01273000
BEGIN P2;ENV:=PMAKE(TYPECONS,0); %PARSE 01274000
ASGN(TOKEN(1018),ENV,NULLIST); 01275000
ASGN(TOKEN(1019),ENV,AT0); 01276000
ASGN(TOKEN(1006),ENV,CONS(USERS(V2),CONS(V2,NULLIST))); 01277000
PROCESS:=CREATE(NULLIST,ENV,TOKEN(1005),CONS(AT(262144),NULLIST)); 01278000
ASGN(AT6,PROCESS,ATOMUNDEF); 01279000
ASGN(AT3,PROCESS,CONS(V1,CONS(TOKEN(117),NULLIST))); 01280000
ASGN(AT7,PROCESS,NULLIST); 01281000
RESUME(PROCESS); INTERP; 01281010
IF APLI THEN 01281020
BEGIN T1:="PRCS";V1:=XX1.ADDR; 01281030
I:=37;GO TO L3 END; 01282000
V1:=XX1 END PARSE; 01283000
BEGIN P1;WHILE PRIORITY.ADDR GTR 0 DO JUNK:=UQ;%TRANS 01284000
ASGN(AT3,V1,CONS(CONS(TOKEN(143),NULLIST),CONS( 01284001
CONS(TOKEN(117),NULLIST),NULLIST))); 01284050
ASGN(AT7,V1,NULLIST);ASGN(AT5,V1,TOKEN(1017)); 01284060
RESUME(V1); 01285000
INTERP; 01286000
V1:=REF(AT1,REF(AT4,XX1)); 01286010
IF APLI THEN 01286020
BEGIN T1:="LIST";V1:=V1.ADDR; 01286030
I:=30;GO TO L3 END END TRANS ; 01287000
BEGIN TRACE:=NOT TRACE; GO TO L2 END;%TRACE 01288000
BEGIN PRINT(HASH);GO TO L2 END; %HASH 01288010
BEGIN INTERP;V1:=XX1;END;%RSTART 01288020
BEGIN APLI:=TRUE;I:=36; 01288030
ASGN(TOKEN(5003),LABTAB,CONS(MAKE(TYPELIST,V1), 01288035
CONS(MAKE(TYPEAREA,V2),NULLIST))); 01288040
APLENV:=PMAKE(TYPECONS,0); GO TO L3 END; %APL 01288050
BEGIN XX1:=1;LMEM(T1);APLI:=FALSE; 01288060
WRITE(DATA,NOTE8,T1);GO TO L2 END; % LSTRT 01289000
END CASE STATEMENT; 01290000
L5:WRITE(DATA,F2,TYPEARRAY[V1.TYPE],V1.ADDR); 01291000
GO TO L2; 01292000
LEND:END DEBUG; 01293000
PROCEDURE DOTRACE(PROCESS);VALUE PROCESS;REAL PROCESS; 01294000
BEGIN PRINT(PROCESS); 01295000
PRINT(REF(AT3,PROCESS)); 01296000
PRINT(REF(AT4,PROCESS)); 01297000
PRINT(REF(AT7,PROCESS))END DOTRACE; 01298000
PROCEDURE MASGN(A,V);VALUE A,V;REAL A,V; 01299000
BEGIN IF BOOLEAN(A) THEN 01300000
MEMORY[A.[18:9],A.[9:9]].[22:23]:=V ELSE 01301000
MEMORY[A.[18:9],A.[9:9]].[45:23]:=V END MASGN; 01302000
PROCEDURE PRINT(X);VALUE X;REAL X; 01303000
BEGIN REAL I; 01304000
LABEL L1,L2; 01305000
FORMAT F1(":",A4,I6), 01306000
F2(X3,A4,I6,"=",A4,I6), 01307000
F3(X3,I4,"=",A4,I6), 01308000
F4(X3,I4,"=NIL"); 01309000
WRITE(DATA,F1,TYPEARRAY[X.TYPE],X.ADDR); 01310000
CASE X.TYPE OF BEGIN 01311000
; %GARBAGE 01312000
L1:BEGIN X:=M[X]; %CONS 01313000
WHILE X NEQ NULLIST DO 01314000
BEGIN WRITE(DATA,F2,TYPEARRAY[CAR(X).TYPE],CAR(X).ADDR, 01315000
TYPEARRAY[CAR((X:=CDR(X))).TYPE],CAR(X).ADDR); 01316000
X:=CDR(X)END END; 01317000
BEGIN I:=1; WHILE X NEQ NULLIST DO %LIST 01318000
BEGIN WRITE(DATA,F3,I,TYPEARRAY[CAR(X).TYPE],CAR(X).ADDR); 01319000
I:=I+1;X:=CDR(X) END; 01320000
WRITE(DATA,F4)END; 01321000
L2:FOR I:=0 STEP 1 UNTIL M[X].ADDR DO %AREA 01322000
WRITE(DATA,F3,I,TYPEARRAY[M[X-I].TYPE],M[X-I].ADDR); 01323000
;%FIELD 01324000
;%SYMBOL 01325000
;%LOGIC 01326000
;%LINK 01327000
GO TO L2; %PROCESS 01328000
GO TO L2; %MONITOR 01329000
GO TO L2;%GENERAL 01330000
END CASE STATEMENT; 01331000
END PRINT; 01331010
PROCEDURE APLPNT(X);VALUE X;REAL X; 01331015
BEGIN REAL I;FORMAT F1(X2,R12.5),F2(A4,I6); 01331020
I:=0; 01331025
IF X.TYPE EQL TYPELIST THEN BEGIN 01331030
WHILE X NEQ NULLIST DO BEGIN 01331035
IF NBR(CAR(X)) THEN 01331040
BEGIN IF I MOD 4 EQL 3 THEN WRITE(DATA,F1,DA(CAR(X))) 01331045
ELSE WRITE(DATA[STOP],F1,DA(CAR(X))); 01331050
I:=I+1;X:=CDR(X) END ELSE BEGIN 01331060
WRITE(DATA,F2,TYPEARRAY[X.TYPE],X.ADDR); 01331065
X:=NULLIST END END;WRITE (DATA) END 01331070
ELSE IF NBR(X) THEN WRITE(DATA,F1,DA(X)) 01331075
ELSE WRITE(DATA,F2,TYPEARRAY[X.TYPE],X.ADDR) END; 01332000
PROCEDURE SYSM; 01333000
BEGIN FORMAT F1(5U), 01334000
NOTE1("SYSTEM?"), 01335000
NOTE2("INVALID OPERATION"), 01336000
NOTE3("CANDE?"); 01337000
ARRAY X[0:4];INTEGER I; 01338000
DEFINE LA=X[0],X[1],X[2],X[3],X[4]#; 01339000
LABEL L1,L2,L3,LEND; 01340000
LASTUSEDSPACE:=0;CURROW:= 0 ; 01341000
NEXTTOKEN:=TOKEN(2000); 01342000
TRACE:=FALSE; 01343000
CP:=POINTER(JUNKARRAY)+7; 01344000
HASH:=PMAKE(TYPEAREA,AT(127)); 01345000
FOR I:=AT1 STEP 1 UNTIL AT(127)DO ASGN(I,HASH,NULLIST); 01346000
STACKPOSITION:=8; 01347000
MASGN (0,LINKTONIL); 01348000
LABTAB:=PMAKE(TYPECONS,0); 01349000
INQ(HASH); 01350000
INTLX; 01358000
DEBUG; 01361000
LEND:END SYSM; 01362000
REAL PROCEDURE USERS(F); 01363000
REAL F; 01364000
BEGIN REAL X,X1; 01365000
USERS:=INLEX(F) 01366000
END OF USERS; 01367000
REAL PROCEDURE USERL(X); 01368000
REAL X; 01369000
BEGIN 01370000
IF (USERL:=REF(X,LABTAB)) EQL ATOMUNDEF THEN 01371000
ASGN(X,LABTAB,(USERL:=CONS(ATOMUNDEF,NULLIST))); 01372000
END OF USERL; 01373000
REAL PROCEDURE PSCAN(IJ,X,F);REAL X,F;INTEGER IJ; 01374000
BEGIN OWN REAL ARRAY SS[0:11]; 01375000
REAL Y; 01376000
PROCEDURE ERR; 01377000
BEGIN 01378000
FORMAT F1(X3,"ARG MISSING"); 01379000
WRITE(DATA,F1) END; 01380000
REAL PROCEDURE QT(X);VALUE X;REAL X; 01381000
IF REF(X,LABTAB) NEQ ATOMUNDEF THEN BEGIN 01382000
IF (X:=USERL(X)) EQL TOKEN(1007) THEN 01383000
QT:=CONS(TOKEN(122),CONS(QT(USERS(F)),NULLIST)) 01384000
ELSE QT:=X END ELSE QT:=X; 01385000
REAL PROCEDURE FSCAN(X,Y,F);VALUE X; REAL X,Y,F; 01386000
BEGIN REAL FSTK,F1,FN; 01387000
LABEL L1,L2,L3,L4,L5,L6,LEND; 01388000
FSTK:=NULLIST; 01389000
L1: IF Y NEQ SS[0] THEN BEGIN FSCAN:=X; GO TO LEND END; 01390000
F1:=FN:=CONS(X,NULLIST); 01391000
L2: IF (X:=USERS(F)) EQL SS[4] THEN 01392000
BEGIN X:=ATOMUNDEF; GO TO L4 END; %DUMMY ARG 01393000
IF X EQL SS[1] THEN 01394000
BEGIN X:=ATOMUNDEF; GO TO L5 END; % DUMMY ARG LIST 01395000
L6:X:=QT(X); 01396000
IF (Y:=USERS(F)) EQL SS[4] THEN 01397000
L4: BEGIN ASGN (ATOMCDR,FN,(FN:=CONS(X,NULLIST))); 01398000
GO TO L2 END; % COMMA 01399000
IF Y EQL SS[1] THEN 01400000
BEGIN ASGN (ATOMCDR,FN,CONS(X,NULLIST)); 01401000
L5:X:=FN:=F1; 01402000
IF CAR(FSTK) EQL ATOMUNDEF THEN 01403000
BEGIN Y:=USERS(F);GO TO L1 END; 01404000
; F1:=CAR(FSTK); FSTK:=CDR(FSTK); 01405000
FN:=CAR(FSTK); 01406000
FSTK:=CDR(FSTK); 01407000
GO TO L6 END; % RPAREN 01408000
IF X EQL QT(SS[8]) THEN 01409000
BEGIN X:=USERL(Y); GO TO L6 END; % LABEL 01410000
FSTK:=CONS(FN,FSTK); 01411000
FSTK:=CONS(F1,FSTK); 01412000
GO TO L1; 01413000
LEND: END OF FSCAN; 01414000
REAL PROCEDURE SSCAN(F); 01415000
REAL F; 01416000
BEGIN REAL X,Y,Z,S1,S2; 01417000
LABEL L1,L2,L3,L4,L5,LEND,L6; 01418000
SSCAN:=Z:=CONS(ATOMUNDEF,NULLIST); 01419000
GO TO L1; 01420000
L3:Z:=CONS(ATOMUNDEF,NULLIST); 01421000
L2:L1: IF (X:=USERS(F)) EQL SS[10] OR X EQL SS[1] THEN 01422000
L6:BEGIN 01423000
GO TO LEND END % END 01424000
ELSE L5: IF X EQL SS[5] THEN 01425000
GO TO L1; % SEMICOLON 01426000
IF (Y:=USERS(F)) EQL SS[6] THEN 01427000
BEGIN EQLIST(USERL(X),Z); 01428000
GO TO L1 END % COLON 01429000
ELSE ASGN(ATOMCAR,Z,FSCAN(QT(X),Y,F)); 01430000
IF ATOM(CAR(Z)) THEN BEGIN ERR;GO TO L2 END; 01431000
IF (X:=Y) EQL SS[5] THEN 01432000
BEGIN ASGN(ATOMCDR,Z,(Z:=CONS(ATOMUNDEF,NULLIST))); 01433000
GO TO L2 END % NO SUCCESSOR GIVEN 01434000
;IF X EQL SS[10] THEN GO TO L6 01435000
; IF X EQL SS[1] THEN GO TO LEND 01436000
ELSE ASGN(ATOMCDR,Z,CONS(ATOMUNDEF,NULLIST)); EQLIST(REF(AT0,Z),USERL( 01437000
X)); 01438000
GO TO L3; % SUCCESSOR GIVEN 01439000
LEND: END OF SSCAN; 01440000
PROCEDURE LDSS; BEGIN INTEGER I,J,K,KK; REAL STK; 01441000
FILL SS[*] WITH "E","N","D","R","O","U","T","I","N","E"; 01442000
K:=2;KK:=0; FOR J:=0 STEP 1 UNTIL 1 DO 01443000
BEGIN STK:=NULLIST; 01444000
FOR I:=KK STEP 1 UNTIL K DO 01445000
STK:=CONS(MAKE(TYPELOGIC,SS[I]),STK); 01446000
SS[J+10]:=HANGON(STK,STK); 01447000
K:=9;KK:=3 END; 01448000
FILL SS[*] WITH "(",")","[","]",",",";",":","*","#"; 01449000
FOR I:=0 STEP 1 UNTIL 8 DO 01450000
BEGIN K:=LOADMODE(SS[I],2); 01451000
STK:=CONS(MAKE(TYPELOGIC,SS[I]),NULLIST); 01452000
SS[I]:=HANGON(STK,STK) END; 01453000
K:=LOADMODE("%",68) 01454000
END OF LDSS; 01455000
LDSS; 01456000
CASE IJ OF BEGIN 01457000
PSCAN:=SSCAN(F); 01458000
IF (Y:=QT(USERS(F))) EQL SS[0] 01459000
THEN BEGIN PSCAN:=SSCAN(F); 01460000
X:= USERS(F) END ELSE 01461000
BEGIN X:= USERS(F); PSCAN:=CONS(FSCAN(Y,X,F),NULLIST) 01462000
END END END OF PSCAN; 01463000
AT0:=LOGIC(0); 01464000
AT1:=LOGIC(1); 01465000
AT2:=LOGIC(2); 01466000
AT3:=LOGIC(3); 01467000
AT4:=LOGIC(4); 01468000
AT5:=LOGIC(5); 01469000
AT6:=LOGIC(6); 01470000
AT7:=LOGIC(7); 01471000
TKNO:=MAKE(TYPETOKEN,0); 01472000
RC1:=MAKE(TYPECODE,1); 01473000
RC9:=MAKE(TYPECODE,9); 01474000
ATOMUNDEF:=MAKE(TYPESYMB+1,0)-1; 01475000
LINKTONIL:=MAKE(TYPELINK+1,0)-1; 01476000
NULLIST:=MAKE(TYPELIST+1,0)-1; 01477000
FILL SYSMARRAY[*] WITH "END","DEBUG"; 01478000
FILL PROCESSARRAY[*] WITH "END","ASGN","REF","QQ","UQ","CAR", 01479000
"CDR","CONS","NEWSYM","AMTSP","MAKE","PRINT", 01480000
"LDMODE","GCL","INTERP","LABEL","NODES", 01481000
"USERS","SMEM","LMEM","PSCAN","BNFTRE","INCODE","QDUMP", 01482000
"DUMP","PERROR","MAASGN","QASGN","M","Q","EXE","CEXE","LOAD", 01483000
"READ","DSTACK","MODELD","PARSE","TRANS","TRACE","HASH","RSTART", 01483010
"APL","PARLD"; 01484000
FILL TYPEARRAY[*] WITH "GRBG","CONS","LIST","AREA", 01485000
"BITS","SYMB","LGIC","LINK", 01486000
"PRCS","MNTR","GNRL","CODE", 01487000
"TP12","TP13","TP14","TP15"; 01488000
SYSM; 01489000
END. END PROGRAM 01490000
? END
Reference in New Issue View Git Blame Copy Permalink