Forgot your password?
Document Actions
INCLUDE/ALGOL.alg_m is the portion of the Standard LISP interpreter/runtime that is written in Burroughs ALGOL.
INCLUDE/ALGOL.alg_m is the portion of the Standard LISP interpreter/runtime that is written in Burroughs ALGOL.
Size 396.5 kB - File type text/plain
Click here to get the file
File contents
% ADDS MODULAR ARITHMETIC FUNCTIONS 00000003
% ADDS ARBITRARY LENGTH ARITHMETIC 00000004
% CLEANS UP MACRO STRUCTURE 00000005
% IMPLEMENTS A TRACE BACK 00000006
% CHANGES DEFINITIONS OF PSEUDO REGISTERS. 00000007
% SOME IMPROVEMENTS TO GARBAGE COLLECTION 00000008
% ADDS ?HI 1 AS A JERK BACK TO COMMAND LEVEL 00000009
% CHANGES SPREAD, LINK TO $APPLY 00000010
00000099
%===================================================================== 00002800
% STANDARD LISP | 00002810
% | 00002820
% THE FOLLOWING "TWINKLE-BOX" LIGHTS HAVE MEANINGS: | 00002830
% 255 - SEARCHING THE STRING AREA FOR AN ENTRY. | 00002840
% 254 - SYMBOL TABLE SEARCH. | 00002850
% 253 - INITIALIZING THE SYMBOL TABLE. | 00002860
% 252 - INITIALIZING THE STRING SPACE. | 00002870
% 251 - INITIALIZING THE PAIR SPACE. | 00002880
% 249 - LAMBDA BINDING TAKING PLACE. | 00002890
% 248 - SEARCH STACK FOR LAMBDA VARIABLE. | 00002900
% 247 - SEARCH FOR A LABEL AND ITS BINDING. | 00002910
% 246 - CONS. | 00002920
% | 00002930
% IN ADDITION: | 00002940
% 0 - 80 P SPACE PAGE REFERENCE IN CAR, CDR ETC. | 00002950
% 96 - * T SPACE, STACK TOP. | 00002960
%===================================================================== 00002970
00003000
00003100
00003200
00003300
LABEL THU; 00003400
00003500
DEFINE 00003600
FZ = 20#, %FIELD SIZE 00003700
TZ = 19#, %TAG SIZE 00003800
CZ = 39#, %CELL SIZE (FZ+TZ=CZ) 00003900
DZ = 10#, %DECIMAL SIZE FOR BIG NUMBERS 00003910
FIELD = [FZ-1:FZ]#, %FIELD PART OF A CELL. 00004000
TAG = [CZ-1:TZ]#, %TAG PART OF CELL. 00004100
CELL = [CZ-1:CZ]#, %CELL 00004200
IDCELL = [FZ:FZ+1]#, %FIELD PLUS INTERNED BIT 00004300
SHIFTUP = [7:48]#, %SHIFTS LOW ORDER BYTE TO HIGH 00004400
BUCKF = [17:8]#, %BUCKET NUMBER FOR STRINGS 00004500
SLOCF = [9:10]#, %LOCATION OF STRING IN STRING DE00004600
LETERF = [9:8]#, %HIGH ORDER 8 BITS OF SLOCF 00004700
SPGARBF = [15:1]#, %GARBAGE COLLECT BIT FOR STRINGS00004800
FREEF = [14:1]#, %MARKS EMPTY SLOT FOR STRINGS 00004900
ISPPTRF = [13:14]#, %BACK PNTR FROM STRINGS TO ISP 00005000
QSPPTR = [47:13]#, %BACK PNTR TO QSPACE 00005100
00005200
% BITS IN TAG FIELD. 00005300
IDTAG = 1#, %IDENTIFIER 00005400
STRINGTAG = 2#, %STRING 00005500
VECTORTAG = 4#, %VECTOR 00005600
FUNCTTAG = 8#, %FUNCTION-POINTER 00005700
BIGTAG =16#, %TAG FOR BIG NUMBERS 00005710
MAXFIELDV = 2**FZ-1#, %SPECIAL USED AS MARKER IN GC 00005800
00005900
% GLOBAL MAXIMA 00006000
ISPMAX = 8192#, %I SPACE SIZE. 00006100
SSPBSZE = 1024#, %BUCKET SIZE (IN BYTES). 00006200
SSPHBUCKETS= 79#, %WHERE OVERFLOW BUCKETS START. 00006300
SSPBMAX = 160#, %TOTAL NO. OF BUCKETS. 00006400
PAGESIZE = 256#, %PAGE SIZE IN P SPACE 00006600
PPAGEMAX = 256#, %NO OF PAGES IN P SPACE. 00006700
PSPMAX = PAGESIZE*PPAGEMAX#, %P SPACE SIZE. 00006800
VSPMAX = 4096#, %V SPACE SIZE. 00006900
QSPMAX = 6144#, %Q SPACE SIZE. 00007000
BSPMAX = 2048#, %B SPACE SIZE. 00007100
FMAX = 9#, %MAXIMUM NUMBER OF FILES. 00007200
INSZE = 80#, %INPUT BUFFER SIZE. 00007300
GLOBLENGTH = 60#, %NUMBER OF GLOBALS FOR GC. 00007400
PRIMNUM = 120#, %NUMBER OF PRIMATIVES 00007500
00007600
% USEFUL MACROS 00007700
ZCALL(FN) = XCALL((FN).FIELD)#, 00007900
ZTRACT(X) = (X+ZERO)#, 00008000
ZEXTEND(X) = (X-ZERO)#, 00008010
ZEROLIT = (3*2**(CZ-3))#, 00008110
BASE = 10**DZ#, 00008120
BM1 = (10**DZ-1+ZEROLIT)#, 00008130
MINIMUM = 2**(CZ-2)#, 00008140
NUMB[N] = (N+ZEROLIT)#, 00008150
MNULL(X) = CT(X,84) = NIL#, 00008200
MGARBAGEP(X) = BOOLEAN(X).[CZ-1:1]#, 00008300
MINTEGERP(X) = (X).TAG >= BIGTAG#, 00008400
MNUMBERP(X) = CT(X,87).TAG >= BIGTAG#, 00008500
BIGP(X) = (X).TAG = BIGTAG#, 00008510
SMALLP(X) = BOOLEAN(X).[CZ-2:1]#, 00008520
OVERFLOWP(X) = (X).[44:47-CZ] NEQ 1#, %PPDMTL19 00008530
MVECTORP(X) = CT(X,59).TAG = VECTORTAG#, 00008600
MSTRINGP(X) = CT(X,89).TAG = STRINGTAG#, 00008700
MCODEP(X) = CT(X,85).TAG = FUNCTTAG#, 00008800
MIDP(X) = CT(X,86).TAG = IDTAG#, 00008900
MCONSTANTP(X) = CT(X,58).[CZ-2:TZ-2] NEQ 0#, 00009000
STRINGIZE(X) = (X) & STRINGTAG [47:48-FZ]#, 00009200
MPAIRP(X) = CT(X,88).TAG = 0#, 00009300
MATOM(X) = CT(X,79).TAG NEQ 0#, 00009400
MINTERNED(X) = BOOLEAN(X).[FZ:1]#, 00009500
MGLOBALP(X) = BOOLEAN(ISPPNAME[(X).FIELD]).[FZ+1:1]#, 00009600
MFLUIDP(X) = BOOLEAN(ISPPNAME[(X).FIELD]).[FZ+2:1]#, 00009700
MSIMPLE(X) = ((X).TAG NEQ 0 AND (X).TAG NEQ VECTORTAG AND 00009800
(X).TAG NEQ BIGTAG)#, 00009900
RPUSH(X) = BEGIN TSP[SP]:=X; SP:=SP+1 END#, 00010000
RPOP = TSP[SP:=SP-1]#, 00010100
IGNORE(X) = (REAL(BOOLEAN(X) AND BOOLEAN(IGNORABLES)) NEQ 0 00010110
OR X=NIL)#, 00010120
CHECKSTACK(S) = IF (S)+TSPPTR>=TSPMAX THEN EXPANDSTACK#, 00010200
ERRORID = (NIL+3)#, 00010300
BRANDNEW = ((4"FFFF").ISPPTRF)#, 00010400
TRUTH(X) = (REAL(X)+NIL)#; 00010500
00010600
% OTHER USEFUL MACROS 00010700
00010800
00010900
DEFINE 00011000
ZLITER(CHR) = (CHR IN LETTERS)#, 00011100
ZDIGIT(CHR) = (CHR>="0" AND CHR <="9")#, 00011200
XEQUAL = ARG1 := TRUTH(ZEQUAL(ARG1,ARG2))#, 00011300
VCODEP(R) = TRUTH(MCODEP(R))#, 00011400
VIDP(R) = TRUTH(MIDP(R))#, 00011500
VNUMBERP(R) = TRUTH(MNUMBERP(R))#, 00011600
VPAIRP(R) = TRUTH(MPAIRP(R))#, 00011700
VATOM(R) = TRUTH(MATOM(R))#, 00011800
MORDERP(A,B) = TRUTH(A>=B)#, 00011900
VCONSTANTP(R) = TRUTH(MCONSTANTP(R))#, 00012000
VVECTORP(R) = TRUTH(MVECTORP(R))#, 00012100
VNULL(R) = TRUTH(R=NIL)#, 00012200
VSTRINGP(R) = TRUTH(MSTRINGP(R))#, 00012300
MXGLOBALP = ARG1 := IF MIDP(ARG1) THEN 00012400
TRUTH(MGLOBALP(ARG1)) ELSE NIL#, 00012500
MXFLUIDP = ARG1 := IF MIDP(ARG1) THEN 00012600
TRUTH(MFLUIDP(ARG1)) ELSE NIL#, 00012700
ZADDTOCHRS(X) = ((X)*4) & STRINGTAG TAG#, 00012800
MUPLIM = ARG1 := IF MVECTORP(ARG1) THEN 00013100
VSP[ARG1.FIELD] ELSE NIL#, 00013200
MPUTPROP = ISPPROP[ARG1.FIELD] := ARG2#, 00013300
MGETPROP(X) = ISPPROP[(X).FIELD]#, 00013400
MPUTG = ISPVALUE[ARG1.FIELD] := ARG2#, 00013500
MGETG(X) = ISPVALUE[(X).FIELD]#, 00013600
VEQ(A,B) = CT(TRUTH(A=B),26)#, 00013700
VEQN(A,B) = TRUTH(ZEQN(A,B))#, 00013710
VEQUAL(A,B) = TRUTH(ZEQUAL(A,B))#, 00013800
ZEQ(A,B) = CT(A,26) = B#, 00013810
ZMEMQ(A,B) = MMEMQ(A,B) NEQ NIL#, 00013900
ZMEMBER(A,B) = MMEMBER(A,B) NEQ NIL#; 00014000
00014100
00014200
REAL NIL,T,ZERO,ONE,TWO,THREE,ITEMP,MTEMP,MTEMPLOC,ALWAYS,SOMETIMES; 00014300
REAL PRIME,PRIMEZ,PRIMEZZ,PRIMEX; % FOR MODULAR ARITHMETIC FUNCTIONS 00014310
BOOLEAN PRIMEBIG; 00014320
REAL WORKSET,INUSE,RHO,OLDTIME,APAGEMAX,ZA,ZB; %VARIABLES CONTROL GC 00014400
REAL IGNORABLES,QPTR; 00014410
ARRAY RCVLOC[0:0]; % RECEIVING VARIABLE FOR NEWP INTRINSICS 00014420
LONG ARRAY SEARCHPAGE[0:PAGESIZE-1]; % PLACE WHICH ALLOWS SEARCHING 00014430
00014500
00014600
% I SPACE. EACH ELEMENT IS AN IDENTIFIER CONSISTING OF 3 PARTS: 00014700
% (1) POINTER TO A PRINT NAME [I.SP.PNAME(...)] 00014800
% (2) POINTER TO PROPERTY LIST OF IDENTIFIER [ISPPROP(...)] 00014900
% (3) POINTER TO GLOBAL VALUE [ISPVALUE(...)] 00015000
LONG ARRAY ISPPNAME[0:511]; 00015100
ARRAY ISPPROP [0:ISPMAX-1]; 00015200
ARRAY ISPVALUE[0:ISPMAX-1]; 00015300
$ SET OMIT = NOT COUNT 00015400
ARRAY ISPCNT,ISPWEIGHT[0:ISPMAX-1]; 00015500
$ POP OMIT 00015600
REAL ISPFREE,ISPHIGH,AISPMAX; 00015700
00015800
% S SPACE. A BIG OLD CHARACTER STRING. THE FIRST CHARACTER IS 0 - 255 00015900
% AND IS THE STRING LENGTH OF WHAT FOLLOWS. 00016000
EBCDIC ARRAY SSP[0:SSPBMAX,0:63]; 00016100
REAL ZGET1,ZGET2; 00016200
00016300
% P SPACE. DOTTED PAIR SPACE IN TWO ARRAYS. 00016400
ARRAY MCAR,MCDR[0:PSPMAX-1]; 00016500
BOOLEAN ARRAY PPAGEUSEDA[0:(PPAGEMAX) DIV 48]; 00016600
DEFINE PPAGEUSED[X] = PPAGEUSEDA[(PJUNK:=X) DIV 48].[PJUNK MOD 48:1]#;00016700
REAL PJUNK; 00016800
REAL PSPFREE; 00016900
00017000
% V SPACE. JUST POINTERS (THE FIRST ENTRY IS ALWAYS THE UPLIM VALUE) 00017100
% WHICH ARE THE ELEMENTS OF ARRAYS. 00017200
ARRAY VSP[0:VSPMAX-1]; 00017300
REAL VSPFREE; 00017400
00017500
% T SPACE. THIS IS THE STACK WHICH HAS XSUBR NAMES ON IT AND 00017600
% ALL THE LAMBDA BINDINGS. 00017700
ARRAY TSP[0:PAGESIZE]; 00017800
REAL TSPMAX,TSPPTR; 00017900
00018000
% E.SP IS EVAL STACK 00018100
ARRAY ESP[0:PAGESIZE]; 00018200
REAL ES,ESPMAX; 00018300
00018400
% Q.SP IS SPACE WHICH CONTROLS LINKAGE TO GLOBALS, FLUIDS, LITERALS, 00018500
% AND CODE. 00018600
ARRAY QSP[0:QSPMAX-1]; 00018700
REAL CURQPROGPTR,CURSTACKBASE; %FOR BACK TRACKING. 00018800
00018906
% ARITHARRAY1 AND 2 ARE USED FOR ARITHMETIC ON LARGE NUMBERS 00018908
ARRAY ARITHARRAY1,ARITHARRAY2[0:20]; 00018910
00019000
% I/O STUFF HERE. 00019100
EBCDIC ARRAY TLINER,LINER[0:80]; 00019200
REAL SPOCOUNT; 00019300
EBCDIC ARRAY OUTER[0:131]; 00019400
REAL INPTR, OUTPTR, CURCHANIN, CURCHANOUT; 00019500
BOOLEAN FILEINUSEA; 00019600
DEFINE FILEINUSE[X] = FILEINUSEA.[X:1]#, 00019700
FILEINPUT[X] = FILEINUSEA.[X+23:1]#; 00019800
00019900
% GLOBALS ASSOCIATED WITH ERROR/ERRORSET. 00020000
ARRAY ERRS[0:30]; 00020100
00020200
% MISCELLANEOUS DECLARATIONS. 00020300
BOOLEAN STRINGSNEEDIT; %USED BY GARBAGE COLLECTION 00020400
REAL NEWSCNT1,NEWSCNT2; %CONTROLS GARB COLLECT OF STRINGS 00020500
BOOLEAN ATEND; %USED AFTER EOF ON ME. 00020600
BOOLEAN ASKING; %USER IS ASKING FOR STATUS 00020700
BOOLEAN BREAK; %USER HIT BREAK KEY 00020800
BOOLEAN HIGH; %THROWING UNDER A HI 00020810
BOOLEAN RECENTREAD; %LAST TTY I/O WAS A READ 00020900
REAL GGENSYM; %GENSYM COUNTER. 00021000
REAL BASKET; %THROW-BACK. 00021100
BOOLEAN BACKOUT; %TRUE=THROWING. 00021200
EVENT THROW; %CASUED WHEN THROWING 00021300
REAL CATCHCOUNTER; %CATCH RECURSION DEPTH 00021400
REAL THROWCOUNTER; %BUMPED AT EACH THROW 00021500
REAL CATCHER; %BUMPED FOR EACH CATCH 00021600
REAL MICROCOUNT,STARTTRACE; %MICRO INSTRUCTION COUNTER. 00021700
REAL UNBOUND; %UNBOUND VALUE. 00021800
REAL BEGINTIME; %TIME AT BEGINNING. 00021900
REAL GARBAGETIME; %TIME IN GARBAGE COLLECTION 00022000
00022100
TRUTHSET LETTERS("ABCDEFGHIJKLMNOPQRSTUVWXYZ" OR 00022200
"abcdefghijklmnopqrstuvwxyz"); 00022300
TRUTHSET LETTERSNDIGITS("0123456789" OR LETTERS); 00022400
TRUTHSET IDCHARACTERS(LETTERSNDIGITS OR "!"); 00022500
TRUTHSET LETTERSNBANG(LETTERS OR "!"); 00022600
TRUTHSET DIGITSNSIGN("0123456789" OR "+" OR "-"); 00022700
00022800
% GLOBALS ASSOCIATED WITH IDENTIFIERS REQUIRED. 00022900
ARRAY GLOBALVECT[0:GLOBLENGTH+10]; 00023000
DEFINE GLAMBDA = GLOBALVECT[0] #, 00023100
GEOL = GLOBALVECT[1] #, 00023200
GEOF = GLOBALVECT[2] #, 00023300
GATOM = GLOBALVECT[4] #, 00023500
GAPPLY = GLOBALVECT[7] #, 00023800
GEXPR = GLOBALVECT[8] #, 00023900
GFEXPR = GLOBALVECT[9] #, 00024000
GSUBR = GLOBALVECT[10] #, 00024100
GFSUBR = GLOBALVECT[11] #, 00024200
GMACRO = GLOBALVECT[12] #, 00024300
GEMSG = GLOBALVECT[13] #, 00024400
GECHO = GLOBALVECT[14] #, 00024500
GRAISE = GLOBALVECT[15] #, 00024600
GCATCH = GLOBALVECT[17] #, 00024800
GOUTPUT = GLOBALVECT[18] #, 00024900
GINPUT = GLOBALVECT[19] #, 00025000
GBPROG = GLOBALVECT[20] #, 00025100
GFLOATING = GLOBALVECT[22] #, 00025300
GCFLAG = GLOBALVECT[27] #, 00025700
GGETV = GLOBALVECT[28] #, 00025800
GPUTV = GLOBALVECT[29] #, 00025900
GARITHMETIC = GLOBALVECT[31] #, 00026100
GID = GLOBALVECT[32] #, 00026200
GLINELENGTH = GLOBALVECT[33] #, 00026300
GVECTOR = GLOBALVECT[34] #, 00026400
GINTEGER = GLOBALVECT[35] #, 00026500
GREMOB = GLOBALVECT[36] #, 00026600
GMKVECT = GLOBALVECT[37] #, 00026700
GPRINC = GLOBALVECT[38] #, 00026800
GEXPLODE = GLOBALVECT[40] #, 00027000
GSCNVAL = GLOBALVECT[41] #, 00027100
GUNBOUND = GLOBALVECT[42] #, 00027200
GPROMPT = GLOBALVECT[43] #, 00027300
GSETPCHAR = GLOBALVECT[44] #, 00027400
GGLOBAL = GLOBALVECT[46] #, 00027500
GFLUID = GLOBALVECT[47] #, 00027600
GUNFLUID = GLOBALVECT[48] #, 00027700
GIDORSTRING = GLOBALVECT[49] #, 00027800
GINTERN = GLOBALVECT[50] #, 00027900
GOPEN = GLOBALVECT[51] #, 00028000
GINITIALISE = GLOBALVECT[52] #, 00028100
GMOD = GLOBALVECT[53] #; 00028110
00028200
% HERE ARE THE PSEUDO REGISTERS 00028300
00028400
00028500
NUMBER NUM,SNUM,QNUM; 00028600
REAL ARG1,ARG2,ARG3,ARG4,ARG5,ARG6,ARG7,ARG8,ARG9,ARG10,ARG11,ARG12, 00028700
ARG13,ARG14,ARG15,ARG16; 00028800
DEFINE 00028900
ARG'0 = ARG1#, ARG'1 = ARG2#, ARG'2 = ARG3#, ARG'3 = ARG4#, 00029000
ARG'4 = ARG5#, ARG'5 = ARG6#, ARG'6 = ARG7#, ARG'7 = ARG8#, 00029100
ARG'8 = ARG9#, ARG'9 = ARG10#, ARG'10 = ARG11#, ARG'11 = ARG12#, 00029200
ARG'12 = ARG13#, ARG'13 = ARG14#, ARG'14 = ARG15#, ARG'15 = ARG16#; 00029300
DEFINE ARGS[N] = CASE N OF (ARG'0,ARG'1,ARG'2,ARG'3,ARG'4,ARG'5, 00029400
ARG'6,ARG'7,ARG'8,ARG'9,ARG'10,ARG'11, 00029500
ARG'12,ARG'13,ARG'14,ARG'15)#; 00029600
00029800
% MACROS, PROCEDURES AND OTHER DECLARATIONS FOR I/O 00030900
00031000
00031100
% IOFILE IS AN ARRAY OF THE POSSIBLE FILES EXCEPT FOR DATA COMM I/O. 00031200
% THE POINTERS CUR.CHAN.IN, CUR.CHAN.OUT ARE THE ARRAY ELEMENT + 1. 00031300
% FILE 0 IS DATA COMM I/O AND IS TREATED SPECIALLY. 00031400
FILE ME(KIND=REMOTE,MYUSE=IO,MAXRECSIZE=80,UNITS=CHARACTERS); 00031500
FILE ME2(KIND=REMOTE,MYUSE=IO,MAXRECSIZE=80,UNITS=CHARACTERS); 00031600
FILE CARDS(KIND=DISK,FILETYPE=8); 00031700
FILE LINE (KIND=PRINTER,MAXRECSIZE=22); 00031800
FILE FILE1(KIND=DISK,FILETYPE=8); 00031900
FILE FILE2(KIND=DISK,FILETYPE=8); 00032000
FILE FILE3(KIND=DISK,FILETYPE=8); 00032100
FILE FILE4(KIND=DISK,FILETYPE=8); 00032200
FILE FILE5(KIND=DISK,FILETYPE=8); 00032300
FILE FILE6(KIND=DISK,FILETYPE=8); 00032400
FILE FILE7(KIND=DISK,FILETYPE=8); 00032500
SWITCH FILE IOFILE := ME,CARDS,LINE,FILE1,FILE2,FILE3,FILE4,FILE5, 00032600
FILE6,FILE7; 00032700
ARRAY FILEINFO,IOHERE,IOSTOP[0:FMAX]; 00032800
00032900
DEFINE 00033000
CAT = ,#, 00033100
CONVERT(W,N) = CONVERTPTR FOR CONVERTER(W,N)#, 00033200
STRINGLENGTH(A)= REAL(SSP[A.BUCKF,A.SLOCF],1)#, 00033300
ZGETSTRING(A) = SSP[ZGETSTRINGPROC(A),ZGET1] FOR ZGET2#, 00033400
DECIMAL(W,N) = W FOR N DIGITS#, 00033500
FOUR = 6#, 00033600
WRITELINE(S) = 00033700
BEGIN 00033800
REPLACE COLLECTOR BY S; 00033900
WRITELINEPROC(1); 00034000
END#, 00034100
WRITELINEDOUBLE(S) = 00034200
BEGIN 00034300
REPLACE COLLECTOR BY S; 00034400
WRITELINEPROC(2); 00034500
END#, 00034600
WRITETTY(S) = 00034700
BEGIN 00034800
REPLACE COLLECTOR BY S; 00034900
WRITETTYPROC; 00035000
END#, 00035100
WRITEIOFILE(N,S) = 00035200
BEGIN 00035300
REPLACE COLLECTOR BY S; 00035400
WRITEIOPROC(N); 00035500
END#, 00035600
ERRSTOP(S) = 00035700
BEGIN 00035800
REPLACE COLLECTOR[7] BY S; 00035900
ERRORSTOP; 00036000
END#, 00036100
ZDMPATOM(A,L) = 00036200
BEGIN 00036300
STOPCOUNT; 00036350
IF L+PTR>LL THEN XTERPRI; 00036400
STARTCOUNT; 00036450
REPLACE BFR[PTR] BY A; 00036500
PTR:=PTR+L; 00036600
MICROBUMP(7); 00036700
END#; 00036800
00036900
EBCDIC ARRAY COLLECTOR[0:131]; 00037000
POINTER CONVERTPTR; 00037100
ARRAY CONVERTARRAY[0:1]; 00037200
00037300
PROCEDURE WRITELINEPROC(N); VALUE N; REAL N; 00037400
BEGIN LABEL EXIT; 00037500
WRITE(LINE[SPACE N],22,COLLECTOR); 00037600
REPLACE COLLECTOR BY " " FOR 132; 00037700
END OF WRITELINEPROC; 00037800
00037900
PROCEDURE WRITETTYPROC; 00038000
BEGIN LABEL EXIT; 00038100
IF NOT BREAK THEN 00038200
BEGIN 00038300
BREAK := IF ATEND THEN 00038400
WRITE(ME2,80,COLLECTOR) 00038500
ELSE 00038600
WRITE(ME,80,COLLECTOR); 00038700
IF BREAK THEN IF RECENTREAD THEN 00038800
BREAK := IF ATEND THEN 00038900
WRITE(ME2,14,COLLECTOR) 00039000
ELSE 00039100
WRITE(ME,80,COLLECTOR); 00039200
END; 00039300
REPLACE COLLECTOR BY " " FOR 132; 00039400
RECENTREAD := FALSE; 00039500
END OF WRITETTYPROC; 00039600
00039700
PROCEDURE ERRORSTOP; 00039800
BEGIN LABEL EXIT; 00039900
REPLACE COLLECTOR BY "*" FOR 7; 00040000
WRITE(ME,80,COLLECTOR); 00040100
REPLACE COLLECTOR BY "FATAL ERROR " CAT " " FOR 60; 00040200
WRITE(ME,80,COLLECTOR); 00040300
READ(ME); 00040400
REPLACE COLLECTOR BY " " FOR 132; %PPDMTL10 00040500
END OF ERRORSTOP; 00040600
00040700
PROCEDURE EXPANDSTACK; 00040800
BEGIN LABEL EXIT; 00040900
IF TSPMAX>2**15 THEN 00041000
ERRSTOP("STACK OVERFLOW"); 00041100
RESIZE(TSP,TSPMAX:=TSPMAX+PAGESIZE,RETAIN); 00041200
END EXPANDSTACK; 00041300
00041400
00041500
REAL PROCEDURE CONVERTER(W,N); VALUE W,N; REAL W,N; 00041600
BEGIN LABEL EXIT; 00041700
CONVERTARRAY[0]:=W; 00041800
REPLACE CONVERTPTR BY POINTER(CONVERTARRAY[1],4)-N 00041900
FOR N WITH HEXTOEBCDIC; 00042000
CONVERTER:=N; 00042100
END CONVERTER; 00042200
00042300
PROCEDURE WRITEIOPROC(N); VALUE N; REAL N; 00042400
BEGIN LABEL EXIT; 00042500
IF N=0 THEN WRITETTYPROC ELSE 00042600
BEGIN 00042700
WRITE(IOFILE[N],IF N=1 THEN 22 ELSE 14,COLLECTOR); 00042800
REPLACE COLLECTOR BY " " FOR 132; 00042900
END; 00043000
END; 00043100
00043200
$ SET OMIT = COUNT 00043300
DEFINE COUNT(N) = #, MICROBUMP(I) = #, BEGINCOUNT = #, ENDCOUNT = #,00043400
STARTCOUNT = #, STOPCOUNT = #, DECLARECOUNT = #, 00043500
DECLAREANDWEIGH = #, 00043600
PRIMTRACE(N) = #, 00043700
PRIMCOUNTER(N) = #, 00043710
DECLARE(X,N,M) = 00043800
DEFINE X = BEGIN M END##, 00043900
JUMP(B) = B#, 00044000
CT(V,N) = V#; 00044100
$ POP OMIT SET OMIT = NOT COUNT 00044200
DEFINE COUNT(N) = OPCODE[N]:=*+1#, MICROBUMP(I) = MICROCOUNT:=*+I#, 00044300
BEGINCOUNT = C:=-MICROCOUNT; ISPCNT[QSP[QNUM].FIELD]:=*+1#, 00044400
ENDCOUNT = ISPWEIGHT[QSP[QNUM].FIELD] := *+C+MICROCOUNT#, 00044500
STARTCOUNT = C:=C-MICROCOUNT#, STOPCOUNT = C:=C+MICROCOUNT#, 00044600
DECLARECOUNT = REAL C#, 00044700
PRIMCOUNTER(N) = MICROCOUNT:=*+1; 00044710
OPCODE[N]:=*+1; 00044720
OPWEIGHT[N]:=*+C+MICROCOUNT#, 00044730
DECLAREANDWEIGH = REAL C; C:=-MICROCOUNT#; 00044740
ARRAY OPWEIGHT,OPCODE[0:PRIMNUM]; 00044900
ARRAY TRACETABLE[0:PRIMNUM*2]; 00045000
DEFINE 00045100
PRIMTRACE(N) = MICROBUMP(1); COUNT(N)#, 00045200
DECLARE(X,N,M) = 00045300
PROCEDURE X; 00045400
BEGIN M; PRIMTRACE(N) END#; 00045500
BOOLEAN PROCEDURE JUMP(B); VALUE B; BOOLEAN B; 00045600
BEGIN PRIMTRACE(99); JUMP:=B END; 00045700
REAL PROCEDURE CT(V,N); VALUE V,N; REAL V,N; 00045800
BEGIN LABEL EXIT; 00045900
PRIMTRACE(N); 00046000
CT := V; 00046100
END CT; 00046200
$ POP OMIT 00046300
00046400
00046500
% NEWP PRIMATIVES FOR GARBAGE COLLECTION 00047000
00047100
$ SET OMIT = NOT NEWP 00047200
00047300
LIBRARY LISP_SUPPORT(FUNCTIONNAME = "LISPSUPPORT.", %PPDMTL01 00047400
LIBACCESS = BYFUNCTION); %PPDMTL01 00047410
00047500
REAL PROCEDURE STACKOFFSET(V); 00047600
VALUE V; REAL V; LIBRARY LISP_SUPPORT; 00047700
PROCEDURE COPYFROMSTACK(N,P,I); 00047800
VALUE N,I,P; REAL I,N; POINTER P; LIBRARY LISP_SUPPORT; 00047900
REAL PROCEDURE MASKSTACKSEARCHER(V,M,R,I); 00048000
VALUE V,I,M; REAL V,I,M; ARRAY R[0]; LIBRARY LISP_SUPPORT; 00048100
00048200
$ POP OMIT 00048300
00048400
% FORWARD PROCEDURES. 00049100
REAL PROCEDURE ZCONS(A,B); VALUE A,B; REAL A,B; FORWARD; 00049200
PROCEDURE ZERROR(A, B); VALUE A,B; REAL A,B; FORWARD; 00049300
PROCEDURE MLIST(A,B); VALUE A,B; REAL A,B; FORWARD; 00049310
PROCEDURE MTMSMTCH(A,B,C); VALUE A,B,C; REAL A,B,C; FORWARD; 00049400
REAL PROCEDURE ZGETSTRINGPROC(A); VALUE A; REAL A; FORWARD; 00049500
PROCEDURE XCALL(N); VALUE N; REAL N; FORWARD; 00049600
PROCEDURE XTERPRI; FORWARD; 00049700
PROCEDURE YEVAL; FORWARD; 00049800
PROCEDURE YERROR; FORWARD; 00049810
PROCEDURE YINITIALISE; FORWARD; 00049820
PROCEDURE YSTANDARDQ11LISP; FORWARD; 00049830
PROCEDURE YQ01TQ19MSMTCH; FORWARD; 00049840
PROCEDURE ZPATOM(A,B,O); VALUE A,B; REAL A; BOOLEAN B; 00049900
EBCDIC ARRAY O[0]; FORWARD; 00049910
PROCEDURE FAULTPROCESSOR(FA,FN); VALUE FN; REAL FN; ARRAY FA[0]; 00050000
FORWARD; 00050100
00050200
$ PAGE 00050300
%SEGMENT(FASTLOAD); 00050400
PROCEDURE FASTLOAD; 00050500
BEGIN 00050600
% READ THE FILE CREATED BY SLISP/BOOTER. SEE THE DOCUMENTATION OF 00050700
% THIS PROGRAM FOR THE FORMATS OF EACH ENTRY. 00050800
ARRAY BBF[0:30]; 00050900
%FILE INIT (KIND=DISK,MAXRECSIZE=30,BLOCKSIZE=300); 00051000
REAL BPTR, CNT, BNO, I, J, QPROG, TMP; 00051200
POINTER P,Q; 00051300
REAL PROCEDURE FASTFETCH; 00051400
% RETURN THE NEXT ENTRY FROM THE BBF BUFFER. READ A NEW LINE WHEN 00051500
% NECESSARY. 00051600
BEGIN LABEL EOF; REAL J,T; 00051700
IF BPTR>=30 THEN BEGIN 00051800
READ(INIT,30,BBF)[EOF]; 00051900
IF FALSE THEN 00052000
EOF: ERRSTOP("PREMATURE END OF FILE"); 00052100
BPTR := 0; 00052200
END; 00052300
FASTFETCH:=BBF[BPTR]; 00052400
BPTR:=*+1; 00052500
END FASTFETCH; 00052600
00052700
00052800
PROCEDURE FETCHBLOCK(N,P); VALUE N,P; REAL N; POINTER P; 00052900
BEGIN REAL I,J; 00053000
IF I<N THEN 00053100
DO BEGIN 00053200
IF BPTR=30 THEN 00053300
BEGIN 00053400
FASTFETCH; BPTR:=0; 00053500
END; 00053600
J:=MIN(30-BPTR,N-I); 00053700
REPLACE P:P BY POINTER(BBF[BPTR]) FOR J WORDS; 00053800
BPTR:=*+J; 00053900
I:=I+J; 00054000
END UNTIL I>=N; 00054100
END FETCHBLOCK; 00054200
00054300
00054400
BPTR := 30; %FORCE THE FIRST READ. 00054600
IF NOT INIT.PRESENT THEN %QUIT IF NOT FILE AVAILABLE. 00054700
BEGIN 00054800
REPLACE OUTER BY " " FOR 132; 00054810
REPLACE OUTER BY INIT.TITLE; 00054820
ERRSTOP("MISSING INIT FILE: " CAT OUTER FOR 80); 00054830
END; 00054840
WHILE (TMP:=FASTFETCH)<9 DO 00054900
BEGIN %PICK UP THE IDENTIFIER CODE. 00055000
CASE TMP OF BEGIN 00055100
; %0 IS A NOP. 00055200
BEGIN %1 -> READ IN THE IDENTIFIER SPACE ENTRIES. 00055300
CNT := FASTFETCH; %PICK UP THE NUMBER OF ENTRIES. 00055400
IF CNT>=ISPMAX THEN ERRSTOP("ID SPACE JAM"); 00055500
I := MIN((CNT+2*PAGESIZE) DIV PAGESIZE * PAGESIZE,ISPMAX); 00055600
IF I>AISPMAX THEN 00055700
RESIZE(ISPPNAME,AISPMAX:=I,RETAIN); 00055800
FETCHBLOCK(CNT,POINTER(ISPPNAME[0])); 00055900
FETCHBLOCK(CNT,POINTER(ISPVALUE[0])); 00056000
FOR I:=0 STEP 1 UNTIL CNT DO 00056100
BEGIN 00056200
MINTERNED(ISPPNAME[I]) := TRUE; 00056300
ISPPROP[I] := NIL; 00056400
END; 00056500
ISPPNAME[ISPFREE:=CNT] := NIL; 00056510
END IDSPACEBUILD; 00056600
00056700
BEGIN %2 -> READ ALL THE PAIRS. 00056800
PSPFREE := CNT := FASTFETCH; 00056900
IF PSPFREE>=PSPMAX THEN ERRSTOP("P SPACE JAM"); 00057000
FETCHBLOCK(CNT,POINTER(MCAR[0])); 00057100
FETCHBLOCK(CNT,POINTER(MCDR[0])); 00057200
END PAIRSPACEBUILD; 00057700
00057800
BEGIN %3 -> BUILD UP THE STRING SPACE. 00057900
BNO := FASTFETCH; %PICK UP THE BUCKET NUMBER. 00058000
CNT := FASTFETCH; %PICK UP THE BYTE COUNT. 00058100
I:=SIZE(SSP[BNO,*]); 00058200
IF I-3<CNT THEN 00058300
BEGIN 00058400
I:=IF BNO=0 THEN 1024 ELSE 2**FIRSTONE(CNT+4); 00058500
RESIZE(SSP[BNO,*],I); 00058600
END; 00058700
FETCHBLOCK((CNT+5) DIV 6, SSP[BNO,0]); 00058800
IF BNO>0 THEN 00058900
REPLACE SSP[BNO,CNT] BY (I-CNT-2).[15:48] FOR 2; 00059000
END STRINGSPACEBUILD; 00059100
; %4 -> NOT USED. 00059200
BEGIN %5 --> INITIALIZE ONE OF THE ERROR MESSAGES.00059300
CNT := FASTFETCH; %PICK UP GLOBAL ENTRY NUMBER. 00059400
ERRS[CNT] := FASTFETCH; 00059500
END ERRORMSGFETCH; 00059600
00059700
BEGIN %6 --> INITIALIZE GLOBAL IDENTIFIERS. 00059800
CNT := FASTFETCH; %GLOBAL TABLE NUMBER. 00059900
GLOBALVECT[CNT] := FASTFETCH; 00060000
END IDGLOBALBUILD; 00060100
00060200
BEGIN %7 -> NOT USED 00060300
END INITBSPACE; 00060800
00060900
BEGIN %8 -> INITIALIZE A Q SPACE BLOCK. 00061000
CNT := FASTFETCH; %COUNT OF WORDS TO MOVE. 00061100
FETCHBLOCK(CNT,POINTER(QSP[QPROG])); 00061200
QPROG:=*+CNT; 00061300
END INITQSPACE; 00061400
00061500
END CASE; 00061600
END READINIT; 00061700
IF TMP > 10 THEN ERRSTOP(CONVERT(TMP,FOUR) CAT 00061800
" IS AN INVALID FASTLOAD OPCODE"); 00061900
MINTERNED(ISPPNAME[ISPVALUE[GUNBOUND.FIELD].FIELD]) := FALSE; 00062000
UNBOUND := ISPVALUE[GUNBOUND.FIELD]; 00062100
QPTR := QPROG; 00062200
ISPHIGH:=ISPFREE-1; 00062300
END FASTLOAD; 00062400
$PAGE 00062500
00062600
PROCEDURE ANSWERHI; 00062700
BEGIN 00062800
EBCDIC ARRAY A[0:29]; 00062900
PICTURE PRETTYI(P EEEDEEEDEEEDEEE), PRETTYP(ZZZZI99), 00063000
PRETTYT(P EEDEEEI99); 00063100
REAL I,J,K; 00063200
LABEL EXIT; 00063300
IF ATEND THEN WRITETTY("END OF FILE - STANDARD INPUT DEVICE"); 00063400
J := TIME(12) - BEGINTIME; 00063500
REPLACE A BY INTEGER(J*2.4@-4) FOR 12 DIGITS, INTEGER(GARBAGETIME* 00063600
2.4@-4) FOR 12 DIGITS, INTEGER(10000*GARBAGETIME/J) FOR 6 DIGITS;00063700
WRITETTY("TOTAL TIME =" CAT A[5] WITH PRETTYT CAT ", GC TIME =" 00063800
CAT A[17] WITH PRETTYT CAT ", " CAT A[24] WITH PRETTYP CAT "%");00063900
IF CURCHANIN>0 THEN 00063910
WRITETTY("LINE NUMBER = " CAT IOHERE[CURCHANIN] FOR 8 NUMERIC);00063920
WRITETTY("I = " CAT AISPMAX FOR I:5 NUMERIC CAT 00064000
", T = " CAT TSPMAX FOR I:5 NUMERIC CAT 00064100
", E = " CAT ESPMAX FOR I:5 NUMERIC CAT 00064200
", Q = " CAT QPTR FOR I:5 NUMERIC); 00064300
IF MICROCOUNT <= 1 THEN GO TO EXIT; 00064500
REPLACE A BY MICROCOUNT FOR 12 DIGITS; 00064600
WRITETTY(" MICRO-INSTRUCTIONS EXECUTED: " CAT 00064700
A WITH PRETTYI); 00064800
REPLACE A BY (MICROCOUNT DIV (J*2.4@-6)) FOR 12 DIGITS; 00064900
WRITETTY(" INSTRUCTIONS/SECOND: " CAT 00065000
A WITH PRETTYI); 00065100
WRITETTY(" MILLI SECONDS PER INSTRUCTION: " CAT 00065200
((J*2.4@-3)/MICROCOUNT) FOR 6 NUMERIC); 00065300
$ SET OMIT = NOT COUNT 00065400
J:=K:=0; 00065500
FOR I:=0 STEP 1 UNTIL PRIMNUM DO 00065600
BEGIN J:=OPCODE[I]+J; K:=OPWEIGHT[I]+K END; 00065700
K:=K+J; 00065710
FOR I:=0 STEP 1 UNTIL PRIMNUM DO 00065800
IF OPCODE[I]>0 THEN 00065900
BEGIN 00066000
REPLACE A BY OPCODE[I] FOR 12 DIGITS, 00066100
OPCODE[I]*10000 DIV J FOR 6 DIGITS, 00066200
(OPWEIGHT[I]+OPCODE[I])*10000 DIV K FOR 6 DIGITS; 00066210
WRITETTY(A WITH PRETTYI CAT A[12] WITH PRETTYP CAT 00066300
A[18] WITH PRETTYP CAT " " CAT 00066310
POINTER(TRACETABLE[2*I]) FOR 12); 00066400
OPCODE[I]:=OPWEIGHT[I]:=0; 00066500
END; 00066600
REPLACE A BY J FOR 12 DIGITS; 00066700
WRITETTY(A WITH PRETTYI CAT " TOTAL"); 00066800
J:=K:=0; WRITETTY(" "); WRITETTY(" "); 00066900
FOR I:=0 STEP 1 UNTIL ISPHIGH DO 00067000
BEGIN J:=ISPCNT[I]+J; K:=ISPWEIGHT[I]+K END; 00067100
FOR I:=0 STEP 1 UNTIL ISPHIGH DO 00067200
IF ISPCNT[I]>0 THEN 00067300
BEGIN 00067400
REPLACE A BY ISPCNT[I] FOR 12 DIGITS, 00067500
ISPCNT[I]*10000 DIV J FOR 6 DIGITS, 00067600
ISPWEIGHT[I]*10000 DIV K FOR 6 DIGITS; 00067700
WRITETTY(A WITH PRETTYI CAT A[12] WITH PRETTYP CAT 00067800
A[18] WITH PRETTYP CAT " " CAT 00067900
ZGETSTRING(STRINGIZE(ISPPNAME[I]))); 00068000
ISPCNT[I]:=ISPWEIGHT[I]:=0; 00068100
END; 00068200
WRITETTY(" "); 00068300
REPLACE A BY J FOR 12 DIGITS; 00068400
WRITETTY(A WITH PRETTYI CAT " TOTAL"); 00068500
$ POP OMIT 00068600
EXIT: 00068700
ASKING:=FALSE; 00068800
END ANSWERHI; 00068900
00069000
00069100
PROCEDURE TDUMP(MSG, A, B, C); VALUE A,B,C,MSG; BOOLEAN A,B,C; 00069200
REAL MSG; 00069300
BEGIN REAL I,L,TMP,TNP; 00069400
BOOLEAN PRINTIT; 00069500
LABEL EXIT; 00069600
EBCDIC ARRAY LNE[0:131]; 00069700
WRITELINE ("********** " CAT MSG FOR 6 CAT " **********"); 00069800
WRITELINEDOUBLE (" -- BUFFERS/POINTERS --"); 00069900
WRITELINEDOUBLE ("LINER:" CAT LINER FOR 80); 00070000
WRITELINE ("OUTER:" CAT OUTER FOR 126); 00070100
WRITELINE ("INPTR:" CAT DECIMAL(INPTR, 3) CAT 00070200
" OUTPTR:" CAT DECIMAL(OUTPTR, 3) CAT 00070300
" CURCHANIN: " CAT DECIMAL(CURCHANIN, 2) CAT 00070400
" CURCHANOUT: " CAT DECIMAL(CURCHANOUT, 2)); 00070500
WRITELINE ("ISPFREE:" CAT CONVERT(ISPFREE,FOUR) CAT 00070600
" PSPFREE:" CAT CONVERT(PSPFREE,FOUR) CAT 00070700
" VSPFREE:" CAT CONVERT(VSPFREE,FOUR) CAT 00070800
" TSPPTR:" CAT CONVERT(TSPPTR,FOUR)); 00070900
WRITELINE("ARG1-4: " CAT CONVERT(ARG1,FOUR) CAT 00071000
" " CAT CONVERT(ARG2,FOUR) CAT " " CAT 00071100
CONVERT(ARG3,FOUR) CAT " " CAT 00071200
CONVERT(ARG4,FOUR)); 00071300
WRITELINEDOUBLE( 00071400
"MICROCOUNT: " CAT DECIMAL(MICROCOUNT, 8) CAT " BACKOUT: " CAT 00071500
(IF BACKOUT THEN "TRUE " ELSE "FALSE " ) FOR 6); 00071600
00071700
%SEGMENT(TDUMP2); 00071800
IF A THEN 00071900
BEGIN 00072000
WRITELINE (" -- SYMBOL TABLE --"); 00072100
FOR I:=0 STEP 1 UNTIL ISPHIGH DO 00072200
IF ISPPROP[I].FIELD NEQ MAXFIELDV THEN 00072300
WRITELINE(CONVERT(I,4) CAT " " CAT 00072400
CONVERT(ISPPNAME[I].FIELD,4) CAT " " CAT 00072500
CONVERT(ISPPROP[I].TAG,2) CAT " " CAT 00072600
CONVERT(ISPPROP[I].FIELD,4) CAT " " CAT 00072700
CONVERT(ISPVALUE[I].TAG,2) CAT " " CAT 00072800
CONVERT(ISPVALUE[I].FIELD,4) CAT 00072900
(IF MINTERNED(ISPPNAME[I]) THEN " * '" ELSE " '") CAT 00073000
ZGETSTRING(STRINGIZE(ISPPNAME[I])) CAT "' "); 00073100
END SYMBOLTABLEDUMP; 00073200
00073300
%SEGMENT(TDUMP3); 00073400
% DUMP THE PAIR SPACE. 00073500
IF B THEN BEGIN 00073600
I := 0; WRITELINEDOUBLE (" -- P SPACE --"); 00073700
WHILE I<PSPMAX DO 00073800
BEGIN 00073900
IF PPAGEUSED[I DIV PAGESIZE] THEN 00074000
BEGIN 00074100
TNP := I; REPLACE LNE BY CONVERT(TNP,FOUR) CAT " "; 00074200
L:= 8; PRINTIT:=FALSE; 00074300
WHILE I<PSPMAX AND L<115 DO 00074400
BEGIN 00074500
REPLACE LNE[L] BY CONVERT(MCAR[I], 6) CAT " " CAT 00074600
CONVERT(MCDR[I], 6) CAT " "; 00074700
IF MCAR[I] NEQ MAXFIELDV THEN PRINTIT:=TRUE; 00074800
L:=L+15; I:=I+1; 00074900
END DUMPAPAIR; 00075000
IF PRINTIT THEN WRITELINE (LNE FOR L); 00075100
END 00075200
ELSE I:=*+PAGESIZE; 00075300
END DUMPPAIRS; 00075400
00075500
%NOW DUMP THE Q SPACE. 00075600
WRITELINEDOUBLE(" -- Q SPACE --"); 00075700
TNP:=I:=0; L:=8; REPLACE LNE BY CONVERT(TNP, FOUR) CAT " "; 00075800
WHILE I<QPTR DO 00075900
BEGIN 00076000
IF L>=123 THEN BEGIN 00076100
WRITELINE (LNE FOR L); 00076200
TNP := I; 00076300
REPLACE LNE BY CONVERT(TNP, FOUR) CAT " "; L:=8; 00076400
END; 00076500
REPLACE LNE[L] BY CONVERT(QSP[I], FOUR) CAT " "; 00076600
L:=*+7; I:=*+1; 00076700
END DUMPQSPACE; 00076800
WRITELINEDOUBLE (LNE FOR L); 00076900
END PSPACEDUMP; 00077000
00077100
% DUMP THE T SPACE (THE STACK). 00077200
%SEGMENT(TDUMP4); 00077300
IF C THEN BEGIN 00077400
I := TSPPTR - 1; 00077500
WRITELINEDOUBLE(" -- STACK --"); 00077600
WHILE I>0 DO 00077700
BEGIN 00077800
TNP := I; 00077900
WRITELINE ("*** " CAT CONVERT(TNP,FOUR) CAT " '" 00078000
CAT ZGETSTRING(STRINGIZE(ISPPNAME[TSP[I-1].FIELD])) CAT "'"); 00078100
TMP := TSP[I]; 00078200
I := I-2; 00078300
WHILE I>=TMP DO 00078400
BEGIN 00078500
WRITELINE (" " CAT CONVERT(TSP[I],FOUR)); 00078600
I:=I-1; 00078700
END DUMPAFRAME; 00078800
END DUMPSTACK; 00078900
END TSPACEDUMP; 00079000
00079100
EXIT: 00079200
END TDUMP; 00079300
00079400
PROCEDURE XDUMP; 00079500
BEGIN LABEL EXIT; 00079600
DECLAREANDWEIGH; 00079610
MICROBUMP(5); 00079620
PRIMCOUNTER(55); 00079700
TDUMP(" USER ",ARG1 NEQ NIL,ARG2 NEQ NIL,ARG3 NEQ NIL); 00079800
END; 00079900
00080000
PROCEDURE XCHKPOINT; 00080100
BEGIN LABEL EXIT; 00080200
DECLAREANDWEIGH; 00080210
MICROBUMP(5); 00080220
ANSWERHI; 00080300
ARG1:=NIL; 00080400
PRIMCOUNTER(57); 00080500
END; 00080600
00080700
00080800
00080900
% THIS IS THE ARITHMETIC SECTION 00081000
00081010
00081020
00081030
REAL PROCEDURE ZOVERFLOW; 00081040
BEGIN LABEL EXIT; 00081050
ZERROR(119, ERRS[19]); 00081060
END ZOVERFLOW; 00081070
00081080
00081100
00081110
00081120
DEFINE 00081130
VABS[X] = MABS(X)#, 00081140
VMINUS[X] = MMINUS(X)#, 00081150
LPLUS2(X,L) = (IF OVERFLOWP(ITEMP:=X+L) THEN 00081152
VPLUS2(ITEMP-L,NUMB[L]) 00081153
ELSE CT(ITEMP,104))#, 00081154
LDIFF(X,L) = (IF OVERFLOWP(ITEMP:=X-L) THEN 00081155
VDIFFERENCE(ITEMP+L,NUMB[L]) 00081156
ELSE CT(ITEMP,105))#, 00081157
ZEROERR = ZOVERFLOW#; 00081160
00081170
00081180
00081190
REAL PROCEDURE NORMALIZE(L,S,Z); VALUE L,S,Z; REAL L,S,Z; 00081200
BEGIN REAL I,N; 00081210
IF L=1 THEN 00081220
NORMALIZE := IF S<0 THEN 2*ZEROLIT-MCAR[Z] ELSE MCAR[Z] 00081230
ELSE 00081240
BEGIN 00081250
I := ZTRACT(L&S[46:46:1]); 00081260
NORMALIZE := IF L>2 THEN ZCONS(I,Z) & BIGTAG TAG 00081270
ELSE IF OVERFLOWP(N:=ZTRACT( 00081280
(ZEXTEND(MCAR[Z])*BASE+ZEXTEND(MCAR[MCDR[Z]])) &00081290
S [46:46:1])) THEN 00081300
ZCONS(I,Z) & BIGTAG TAG ELSE N; 00081310
END; 00081320
END NORMALIZE; 00081330
00081340
REAL PROCEDURE NUMCHECK(X); VALUE X; REAL X; 00081350
BEGIN LABEL EXIT; 00081360
IF NOT MNUMBERP(X) THEN 00081370
MTMSMTCH(X,GINTEGER,GARITHMETIC); 00081380
END NUMCHECK; 00081390
00081400
REAL PROCEDURE MULTIPLY(X,Y); VALUE X,Y; REAL X,Y; 00081410
BEGIN 00081420
DOUBLE R; 00081430
REAL I,J,Z,L1,L2,L,S,U; 00081440
DEFINE A=ARITHARRAY1#, B=ARITHARRAY2#; 00081450
IF NOT MINTEGERP(X) THEN NUMCHECK(X); 00081460
IF BIGP(X) THEN 00081470
BEGIN 00081480
X.TAG := 0; 00081490
S := ZEXTEND(MCAR[X]); 00081500
L1 := ABS(S)-1; 00081510
IF SIZE(A)<=L1 THEN RESIZE(A,3*L1 DIV 2); 00081520
FOR I:=L1 STEP -1 UNTIL 0 DO 00081530
BEGIN X:=MCDR[X]; A[I]:=ZEXTEND(MCAR[X]) END; 00081540
END 00081550
ELSE 00081560
BEGIN 00081570
S := ZEXTEND(X); 00081580
A[0] := ABS(S); 00081590
L1 := 0; 00081600
END; 00081610
IF NOT MINTEGERP(Y) THEN NUMCHECK(Y); 00081620
IF BIGP(Y) THEN 00081630
BEGIN 00081640
Y.TAG := 0; 00081650
L2 := ZEXTEND(MCAR[Y]); 00081660
S := L2*S; 00081670
L2 := ABS(L2)-1; 00081680
IF SIZE(B)<=L2 THEN RESIZE(B,3*L2 DIV 2); 00081690
FOR I:=L2 STEP -1 UNTIL 0 DO 00081700
BEGIN Y:=MCDR[Y]; B[I]:=ZEXTEND(MCAR[Y]) END; 00081710
END 00081720
ELSE 00081730
BEGIN 00081740
L2 := ZEXTEND(Y); 00081750
S := L2*S; 00081760
B[0] := ABS(L2); 00081770
L2 := 0; 00081780
END; 00081790
L := L1+L2; 00081800
Z := NIL; 00081810
U := -1; 00081820
FOR I:=0 STEP 1 UNTIL L DO 00081830
BEGIN 00081840
IF I<=L2 THEN U:=U+1; 00081850
J := IF I>L1 THEN I-L1 ELSE 0; 00081860
DO R := A[I-J] MUX B[J] + R UNTIL J:=J+1>U; 00081870
Z := ZCONS(ZTRACT(INTEGER(R MOD BASE)),Z); 00081880
R := R DIV BASE; 00081890
END; 00081900
IF R>0 THEN 00081910
BEGIN 00081920
IF R>=BASE THEN 00081930
BEGIN 00081940
Z := ZCONS(ZTRACT(INTEGER(R MOD BASE)),Z); 00081950
R := R DIV BASE; 00081960
L := L+1; 00081970
END; 00081980
Z := ZCONS(ZTRACT(INTEGER(R)),Z); 00081990
L := L+1; 00082000
END; 00082010
MULTIPLY := ZCONS(ZTRACT((L+1)&S[46:46:1]),Z)&BIGTAG TAG; 00082020
END MULTIPLY; 00082030
00082040
00082050
REAL PROCEDURE ADDSUB(X,Y,S); VALUE S,Y,X; REAL S,Y,X; 00082060
BEGIN LABEL EXIT; 00082070
REAL L1,L2,L,H,K,D,E,F,Z; 00082080
00082090
DEFINE ADDON(Z,E) = Z:=MCDR[Z]:=ZCONS(E,NIL)#; 00082100
DEFINE EXCHANGE(Q) = BEGIN 00082110
S:=X; X:=Y; Y:=S; 00082120
L1:=L2+L2-L1; Q; 00082130
END#; 00082140
DEFINE LAYDOWN = BEGIN 00082150
IF E>ZERO THEN ADDON(Z,E) ELSE 00082160
IF Z=ALWAYS THEN L:=L-1 ELSE ADDON(Z,E); 00082170
IF K>0 THEN 00082180
DO ADDON(Z,F) UNTIL (K:=K-1)=0; 00082190
END#; 00082200
00082210
IF NOT MNUMBERP(X) THEN NUMCHECK(X); 00082220
IF SMALLP(X) THEN 00082230
BEGIN 00082240
H := ZEXTEND(X); X := ABS(H); 00082250
IF X>=BASE THEN 00082260
BEGIN L1 := 2; 00082270
X:=ZCONS(ZTRACT(X DIV BASE),ZCONS(ZTRACT(X MOD BASE),00082280
NIL)); 00082290
END ELSE 00082300
BEGIN L1 := 1; 00082310
X := ZCONS(ZTRACT(X),NIL); 00082320
IF H=0 THEN H := 1; 00082330
END; 00082340
MCAR[SOMETIMES] := X; 00082350
END 00082360
ELSE 00082370
BEGIN 00082380
X.TAG := 0; 00082390
H := ZEXTEND(MCAR[X]); L1 := ABS(H); X := MCDR[X]; 00082400
END; 00082410
S := S*H; 00082420
IF NOT MNUMBERP(Y) THEN NUMCHECK(Y); 00082430
IF SMALLP(Y) THEN 00082440
BEGIN 00082450
E := ZEXTEND(Y); Y := ABS(E); 00082460
IF Y>=BASE THEN 00082470
BEGIN L2 := 2; 00082480
Y:=ZCONS(ZTRACT(Y DIV BASE),ZCONS(ZTRACT(Y MOD BASE),00082490
NIL)); 00082500
END ELSE 00082510
BEGIN L2 := 1; 00082520
Y := ZCONS(ZTRACT(Y),NIL); 00082530
END; 00082540
MCDR[SOMETIMES] := Y; 00082550
END 00082560
ELSE 00082570
BEGIN 00082580
Y.TAG := 0; 00082590
E := ZEXTEND(MCAR[Y]); L2 := ABS(E); Y := MCDR[Y]; 00082600
END; 00082610
S := S*E; 00082620
L := MAX(L1,L2); 00082630
E := ZERO; K := 0; Z := ALWAYS; MCDR[Z] := NIL; 00082640
IF S>=0 THEN 00082650
BEGIN 00082660
IF L1<L2 THEN EXCHANGE(;); 00082670
DO BEGIN 00082680
IF L2<L1 THEN 00082690
BEGIN 00082700
D := MCAR[X]; L2 := L2+1; 00082710
END 00082720
ELSE 00082730
BEGIN 00082740
D := MCAR[X] + MCAR[Y] - ZERO; Y := MCDR[Y]; 00082750
END; 00082760
IF D=BM1 THEN K := K+1 00082770
ELSE 00082780
BEGIN 00082790
IF D>BM1 THEN 00082800
BEGIN 00082810
D := D-BASE; E := E+1; F := ZERO; 00082820
END 00082830
ELSE F := BM1; 00082840
LAYDOWN; 00082850
E := D; 00082860
END; 00082870
X := MCDR[X]; 00082880
END UNTIL X=NIL; 00082890
F := BM1; 00082900
END 00082910
ELSE 00082920
BEGIN 00082930
IF L1=L2 THEN 00082940
BEGIN 00082950
WHILE MCAR[X] = MCAR[Y] DO 00082960
BEGIN 00082970
X := MCDR[X]; Y := MCDR[Y]; 00082980
L := L-1; 00082990
IF L=0 THEN 00083000
BEGIN ADDSUB := ZERO; GO TO EXIT END; 00083010
END; 00083020
L1 := L2 := L; 00083030
IF MCAR[X] < MCAR[Y] THEN EXCHANGE(H:=-H); 00083040
END 00083050
ELSE IF L1<L2 THEN EXCHANGE(H:=-H); 00083060
DO BEGIN 00083070
IF L2<L1 THEN 00083080
BEGIN 00083090
D := MCAR[X]; L2 := L2+1; 00083100
END 00083110
ELSE 00083120
BEGIN 00083130
D := MCAR[X] - MCAR[Y] + ZERO; Y := MCDR[Y]; 00083140
END; 00083150
IF D=ZERO THEN K := K+1 00083160
ELSE 00083170
BEGIN 00083180
IF D<ZERO THEN 00083190
BEGIN 00083200
D := D+BASE; E := E-1; F := BM1; 00083210
END 00083220
ELSE F := ZERO; 00083230
LAYDOWN; 00083240
E := D; 00083250
END; 00083260
X := MCDR[X]; 00083270
END UNTIL X=NIL; 00083280
F := ZERO; 00083290
END; 00083300
LAYDOWN; 00083310
ADDSUB := NORMALIZE(L+1,H,MCDR[ALWAYS]); 00083320
MCDR[ALWAYS] := NIL; 00083330
EXIT: 00083340
END ADDSUB; 00083350
00083360
00083370
REAL PROCEDURE DIVISION(X,Y,P); VALUE X,Y,P; REAL X,Y,P; 00083380
BEGIN LABEL EXIT,FINI; 00083390
DOUBLE D,E; 00083400
REAL L1,L2,L,S,Q,R,Z,I,J,K,U,V; 00083410
DEFINE A=ARITHARRAY1#, B=ARITHARRAY2#; 00083420
00083430
DEFINE ADDON(Q,Z) = BEGIN 00083440
IF Q>ZERO THEN 00083450
Z:=MCDR[Z]:=ZCONS(Q,NIL) 00083460
ELSE IF Z=ALWAYS THEN 00083470
L := L-1 00083480
ELSE Z:=MCDR[Z]:=ZCONS(Q,NIL); 00083490
END#; 00083500
00083510
Z := ALWAYS; MCDR[Z] := NIL; 00083520
IF NOT MNUMBERP(X) THEN NUMCHECK(X); 00083530
IF SMALLP(X) THEN 00083540
BEGIN 00083550
R := ZEXTEND(X); X := ABS(R); 00083560
IF X>=BASE THEN 00083570
BEGIN L1 := 2; 00083580
X:=ZCONS(ZTRACT(X DIV BASE),ZCONS(ZTRACT(X MOD BASE),00083590
NIL)); 00083600
END ELSE 00083610
BEGIN L1 := 1; 00083620
X := ZCONS(ZTRACT(X),NIL); 00083630
IF R=0 THEN R := 1; 00083640
END; 00083650
MCAR[SOMETIMES] := X; 00083660
END 00083670
ELSE 00083680
BEGIN 00083690
X.TAG := 0; 00083700
R := ZEXTEND(MCAR[X]); L1 := ABS(R); X := MCDR[X]; 00083710
END; 00083720
IF NOT MNUMBERP(Y) THEN NUMCHECK(Y); 00083730
IF SMALLP(Y) THEN 00083740
BEGIN 00083750
Y := ZEXTEND(Y); S := Y*R; Y := ABS(Y); 00083760
L := L1; 00083770
DO BEGIN 00083780
D := ZEXTEND(MCAR[X]) + BASE MUX V; 00083790
V := INTEGER(D MOD Y); 00083800
IF P>0 THEN 00083810
BEGIN 00083820
Q := ZTRACT(INTEGER(D DIV Y)); 00083830
ADDON(Q,Z); 00083840
END; 00083850
X := MCDR[X]; 00083860
END UNTIL X=NIL; 00083870
V := ZTRACT(V&R[46:46:1]); 00083880
GO TO FINI; 00083890
END; 00083900
Y.TAG := 0; 00083910
L2 := ZEXTEND(MCAR[Y]); 00083920
S := L2*R;; 00083930
L2 := ABS(L2); 00083940
L := L1-L2+1; 00083950
IF SIZE(A)-2<=L1 THEN RESIZE(A,3*L1 DIV 2); 00083955
FOR I:=L1 STEP -1 UNTIL 1 DO 00083960
BEGIN A[I] := ZEXTEND(MCAR[X]); X := MCDR[X] END; 00083970
IF SIZE(B)-2<=L2 THEN RESIZE(B,3*L2 DIV 2); 00083975
FOR J:=L2 STEP -1 UNTIL 1 DO 00083980
BEGIN Y := MCDR[Y]; B[J] := ZEXTEND(MCAR[Y]) END; 00083990
A[L1+1] := A[0] := 0; 00084000
D := B[L2-1] + B[L2] MUX BASE; 00084010
FOR I:=L1 STEP -1 UNTIL L2 DO 00084020
BEGIN 00084030
Q := INTEGER((A[I-1]+(A[I+1] MUX BASE+A[I]) MUX BASE) DIV 00084040
D); 00084050
U := 0; K := I-L2; 00084060
FOR J:=1 STEP 1 UNTIL L2 DO 00084070
BEGIN 00084080
K := K+1; 00084090
E := B[J] MUX Q + U; U := E DIV BASE; 00084100
V := -INTEGER(E MOD BASE) + A[K]; 00084110
IF V<0 THEN 00084120
BEGIN U := U+1; V := V+BASE END; 00084130
A[K] := V; 00084140
END; 00084150
IF A[K+1]<U THEN 00084160
BEGIN 00084170
Q := Q-1; K := I-L2; U := 0; 00084180
FOR J:=1 STEP 1 UNTIL L2 DO 00084190
BEGIN 00084200
K := K+1; 00084210
V := A[K]+B[J]+U; 00084220
IF V<BASE THEN 00084230
U := 0 00084240
ELSE 00084250
BEGIN U := 1; V := V-BASE END; 00084260
A[K] := V; 00084270
END; 00084280
END; 00084290
A[K+1] := 0; 00084300
IF P>0 THEN 00084310
BEGIN Q := ZTRACT(Q); ADDON(Q,Z) END; 00084320
END; 00084330
IF P NEQ 1 THEN 00084340
BEGIN A[0] := 1; 00084350
WHILE A[L2]=0 DO L2:=L2-1; 00084360
IF L2>0 THEN 00084370
BEGIN 00084380
V := NIL; 00084390
FOR J:=1 STEP 1 UNTIL L2 DO 00084400
V := ZCONS(ZTRACT(A[J]),V); 00084410
V := NORMALIZE(L2,R,V); 00084420
END ELSE V := ZERO; 00084430
FINI: 00084440
IF P=0 THEN 00084450
BEGIN 00084460
DIVISION := V; 00084470
GO TO EXIT; 00084480
END; 00084490
END; 00084500
Z := IF Z=ALWAYS THEN ZERO ELSE NORMALIZE(L,S, 00084510
MCDR[ALWAYS]); 00084520
MCDR[ALWAYS] := NIL; 00084530
DIVISION := IF P=1 THEN Z ELSE ZCONS(Z,V); 00084540
EXIT: 00084550
END DIVISION; 00084560
00084570
00084580
REAL PROCEDURE VPLUS2(X,Y); VALUE X,Y; REAL X,Y; 00084590
BEGIN LABEL EXIT; 00084600
DECLAREANDWEIGH; 00084610
IF OVERFLOWP(VPLUS2:=X+Y-ZERO) THEN 00084620
VPLUS2 := ADDSUB(X,Y,1); 00084630
MICROBUMP(5); 00084640
PRIMCOUNTER(29); 00084650
END VPLUS2; 00084670
00084680
REAL PROCEDURE VDIFFERENCE(X,Y); VALUE X,Y; REAL X,Y; 00084690
BEGIN LABEL EXIT; 00084700
DECLAREANDWEIGH; 00084705
IF NOT SMALLP(X) THEN 00084710
VDIFFERENCE := ADDSUB(X,Y,-1) 00084720
ELSE IF OVERFLOWP(VDIFFERENCE:=X-Y+ZERO) THEN 00084730
VDIFFERENCE := ADDSUB(X,Y,-1); 00084740
MICROBUMP(6); 00084750
PRIMCOUNTER(31); 00084760
END VDIFFERENCE; 00084780
00084790
REAL PROCEDURE MMINUS(X); VALUE X; REAL X; 00084800
BEGIN LABEL EXIT; 00084810
IF OVERFLOWP(MMINUS:=2*ZEROLIT-X) THEN 00084820
MMINUS := IF BIGP(X) THEN 00084830
ZCONS(-MCAR[X.FIELD]+2*ZEROLIT,MCDR[X.FIELD])& 00084840
BIGTAG TAG 00084842
ELSE ADDSUB(ZERO,X,1); 00084850
MICROBUMP(5); 00084860
END MMINUS; 00084870
00084880
REAL PROCEDURE MABS(X); VALUE X; REAL X; 00084890
BEGIN LABEL EXIT; 00084900
MABS := IF X>=ZERO THEN X ELSE 00084910
IF X>MINIMUM THEN 2*ZEROLIT-X ELSE 00084920
IF X=MINIMUM THEN ADDSUB(ZERO,X,-1) ELSE 00084930
IF NOT BIGP(X) THEN NUMCHECK(X) ELSE 00084940
IF MCAR[X.FIELD]>ZERO THEN X ELSE 00084950
ZCONS(-MCAR[X.FIELD]+2*ZEROLIT,MCDR[X.FIELD])&BIGTAG TAG; 00084960
END MABS; 00084970
00084980
REAL PROCEDURE VTIMES2(X,Y); VALUE X,Y; REAL X,Y; 00084990
BEGIN LABEL EXIT; 00085000
DECLAREANDWEIGH; 00085010
IF OVERFLOWP(VTIMES2 := (X-ZERO)*(Y-ZERO) + ZERO) THEN 00085020
VTIMES2 := MULTIPLY(X,Y); 00085030
MICROBUMP(6); 00085040
PRIMCOUNTER(30); 00085050
END VTIMES2; 00085070
00085080
REAL PROCEDURE VQUOTIENT(X,Y); VALUE X,Y; REAL X,Y; 00085090
BEGIN LABEL EXIT; 00085100
DECLAREANDWEIGH; 00085110
IF Y=ZERO THEN ZEROERR; 00085120
IF SMALLP(REAL(BOOLEAN(X) AND BOOLEAN(Y))) AND X>MINIMUM THEN 00085130
VQUOTIENT := (X-ZERO) DIV (Y-ZERO) + ZERO ELSE 00085140
VQUOTIENT := DIVISION(X,Y,1); 00085150
MICROBUMP(10); 00085160
PRIMCOUNTER(31); 00085170
END VQUOTIENT; 00085190
00085200
REAL PROCEDURE VREMAINDER(X,Y); VALUE X,Y; REAL X,Y; 00085210
BEGIN LABEL EXIT; 00085220
DECLAREANDWEIGH; 00085230
IF Y=ZERO THEN ZEROERR; 00085240
VREMAINDER := IF SMALLP(REAL(BOOLEAN(X) AND BOOLEAN(Y))) THEN 00085250
(X-ZERO) MOD (Y-ZERO) + ZERO 00085260
ELSE DIVISION(X,Y,0); 00085270
MICROBUMP(9); 00085280
PRIMCOUNTER(36); 00085290
END VREMAINDER; 00085310
00085320
REAL PROCEDURE VEXPT(X,Y); VALUE X,Y; REAL X,Y; 00085330
BEGIN 00085340
DEFINE P=MCAR[SOMETIMES]#, Q=MCDR[SOMETIMES]#; 00085350
DECLAREANDWEIGH; 00085360
IF X=ONE THEN VEXPT := ONE ELSE 00085370
IF X=ZERO THEN VEXPT := ZERO ELSE 00085380
IF X+1=ZERO THEN 00085390
BEGIN 00085400
IF BIGP(Y) THEN 00085410
BEGIN Y.TAG := 0; 00085420
P := ABS(MCAR[Y]-ZERO); 00085430
WHILE P>0 DO 00085440
BEGIN Y := MCDR[Y]; P := P-1 END; 00085450
Y := MCAR[X]; 00085460
END; 00085470
VEXPT := IF BOOLEAN(Y) THEN X ELSE ONE; 00085480
END ELSE 00085490
IF BIGP(Y) THEN 00085500
BEGIN 00085510
IF MCAR[Y.FIELD]<ZERO THEN 00085520
VEXPT := ZERO ELSE ZOVERFLOW; 00085530
END ELSE 00085540
IF Y<ZERO THEN VEXPT := ZERO ELSE 00085550
BEGIN 00085560
MICROBUMP(5); 00085570
P := ONE; Q := X; Y := Y-ZERO; 00085580
WHILE Y>0 DO 00085590
BEGIN 00085600
MICROBUMP(6); 00085610
IF BOOLEAN(Y) THEN 00085620
P := IF P=ONE THEN Q ELSE VTIMES2(P,Q); 00085630
Y := Y.[38:38]; 00085640
IF Y>0 THEN Q := VTIMES2(Q,Q); 00085650
END; 00085660
VEXPT := P; 00085670
END; 00085680
P := Q := NIL; 00085690
MICROBUMP(10); 00085700
PRIMCOUNTER(61); 00085710
END VEXPT; 00085730
00085740
BOOLEAN PROCEDURE ZLESSP(A,B); VALUE A,B; REAL A,B; 00085750
BEGIN LABEL EXIT; 00085760
DECLAREANDWEIGH; 00085770
IF SMALLP(REAL(BOOLEAN(A) AND BOOLEAN(B))) THEN 00085780
BEGIN 00085790
ZLESSP := A<B; 00085800
MICROBUMP(3); 00085810
GO TO EXIT; 00085820
END; 00085830
IF SMALLP(REAL(BOOLEAN(A) OR BOOLEAN(B))) THEN 00085840
BEGIN 00085850
ZLESSP := IF BIGP(B) THEN MCAR[B.FIELD]>ZERO ELSE 00085860
IF BIGP(A) THEN MCAR[A.FIELD]<ZERO ELSE 00085870
NUMCHECK(A)>NUMCHECK(B); 00085880
MICROBUMP(5); 00085890
GO TO EXIT; 00085900
END; 00085910
IF NOT BIGP(REAL(BOOLEAN(A) AND BOOLEAN(B))) THEN 00085920
BEGIN NUMCHECK(A); NUMCHECK(B) END; 00085930
MICROBUMP(5); 00085940
A.TAG := 0; B.TAG := 0; 00085950
DO BEGIN 00085960
IF MCAR[A] NEQ MCAR[B] THEN 00085970
BEGIN 00085980
MICROBUMP(3); 00085990
ZLESSP := MCAR[A]<MCAR[B]; 00086000
GO TO EXIT; 00086010
END; 00086020
MICROBUMP(4); 00086030
A := MCDR[A]; B := MCDR[B]; 00086040
END UNTIL B=NIL; 00086050
EXIT: 00086060
MICROBUMP(4); 00086070
PRIMCOUNTER(34); 00086080
END ZLESSP; 00086100
00086110
BOOLEAN PROCEDURE ZGREATERP(A,B); VALUE A,B; REAL A,B; 00086120
BEGIN LABEL EXIT; 00086130
DECLAREANDWEIGH; 00086140
IF SMALLP(REAL(BOOLEAN(A) AND BOOLEAN(B))) THEN 00086150
BEGIN 00086160
ZGREATERP := A>B; 00086170
MICROBUMP(3); 00086180
GO TO EXIT; 00086190
END; 00086200
IF SMALLP(REAL(BOOLEAN(A) OR BOOLEAN(B))) THEN 00086210
BEGIN 00086220
ZGREATERP := IF BIGP(B) THEN MCAR[B.FIELD]<ZERO ELSE 00086230
IF BIGP(A) THEN MCAR[A.FIELD]>ZERO ELSE 00086240
NUMCHECK(A)<NUMCHECK(B); 00086250
MICROBUMP(5); 00086260
GO TO EXIT; 00086270
END; 00086280
IF NOT BIGP(REAL(BOOLEAN(A) AND BOOLEAN(B))) THEN 00086290
BEGIN NUMCHECK(A); NUMCHECK(B) END; 00086300
MICROBUMP(5); 00086310
A.TAG := 0; B.TAG := 0; 00086320
DO BEGIN 00086330
IF MCAR[A] NEQ MCAR[B] THEN 00086340
BEGIN 00086350
MICROBUMP(3); 00086360
ZGREATERP := MCAR[A]>MCAR[B]; 00086370
GO TO EXIT; 00086380
END; 00086390
MICROBUMP(4); 00086400
A := MCDR[A]; B := MCDR[B]; 00086410
END UNTIL B=NIL; 00086420
EXIT: 00086430
MICROBUMP(4); 00086440
PRIMCOUNTER(33); 00086450
END ZGREATERP; 00086470
00086480
BOOLEAN PROCEDURE ZEQN(A,B); VALUE A,B; REAL A,B; 00086490
BEGIN LABEL EXIT; 00086500
DECLAREANDWEIGH; 00086510
IF ZEQN:=A=B THEN GO TO EXIT; 00086520
IF BIGP(A) THEN IF BIGP(B) THEN 00086530
BEGIN A.TAG := 0; B.TAG := 0; 00086540
MICROBUMP(5); 00086550
WHILE MCAR[A] = MCAR[B] DO 00086560
BEGIN MICROBUMP(4); 00086570
A := MCDR[A]; 00086580
IF A=NIL THEN 00086590
BEGIN ZEQN := TRUE; GO TO EXIT END; 00086600
B := MCDR[B]; 00086610
END; 00086620
END; 00086630
EXIT: 00086640
MICROBUMP(4); 00086650
PRIMCOUNTER(27); 00086660
END ZEQN; 00086680
00086690
00086700
DEFINE XPLUS2 = ARG1:=VPLUS2(ARG1,ARG2)#, 00086800
XTIMES2 = ARG1:=VTIMES2(ARG1,ARG2)#, 00086900
XQUOTIENT = ARG1:=VQUOTIENT(ARG1,ARG2)#, 00087000
XREMAINDER = ARG1:=VREMAINDER(ARG1,ARG2)#, 00087100
XDIFFERENCE = ARG1:=VDIFFERENCE(ARG1,ARG2)#, 00087200
XGREATERP = ARG1:=TRUTH(ZGREATERP(ARG1,ARG2))#, 00087300
XLESSP = ARG1:=TRUTH(ZLESSP(ARG1,ARG2))#, 00087400
XEXPT = ARG1:=VEXPT(ARG1,ARG2)#, 00087500
XEQ = ARG1:=VEQ(ARG1,ARG2)#, 00087600
XEQN = ARG1:=TRUTH(ZEQN(ARG1,ARG2))#; 00087605
00087610
00087620
% THIS SECTIONS CONTAINS MODULAR ARITHMETIC FUNCTIONS 00087622
00087624
00087626
DECLARE(XCMOD,7,BEGIN 00087630
IF BIGP(ARG1) THEN 00087632
ARG1 := DIVISION(ARG1,PRIMEZ,0); 00087634
IF ARG1>=PRIMEZ THEN 00087636
ARG1 := (ARG1-ZERO) MOD PRIME+ZERO 00087640
ELSE IF ARG1<ZERO THEN 00087650
ARG1 := (ARG1-PRIMEX) MOD PRIME+ZERO; 00087660
END); 00087665
00087670
DECLARE(XCPLUS,8,ARG1 := -(IF ARG1+ARG2>=PRIMEZZ THEN 00087680
PRIMEZ ELSE ZERO)+ARG1+ARG2); 00087690
00087700
DECLARE(XCTIMES,9,ARG1 := ZTRACT(IF PRIMEBIG THEN 00087710
INTEGER(ZEXTEND(ARG1) MUX ZEXTEND(ARG2) MOD 00087720
PRIME) ELSE 00087730
ZEXTEND(ARG1)*ZEXTEND(ARG2) MOD PRIME)); 00087740
00087750
DECLARE(XCDIF,10,ARG1 := (IF ARG1<ARG2 THEN PRIMEZ ELSE ZERO)+ 00087760
ARG1-ARG2); 00087770
00087780
00087790
PROCEDURE XSETMOD; 00087800
BEGIN REAL D,G; 00087810
DECLAREANDWEIGH; 00087820
G := D := ISPVALUE[GMOD.FIELD]; 00087830
IF ARG1=NIL THEN 00087840
G := NIL 00087850
ELSE 00087860
IF NOT SMALLP(ARG1) THEN 00087870
BEGIN MLIST(ARG1,ERRS[20]); ZERROR(120,ARG1) END 00087880
ELSE 00087890
IF ARG1>ONE THEN 00087900
BEGIN 00087910
G := PRIMEZ := ARG1; 00087920
PRIMEZZ := G+ZERO; 00087930
PRIME := G-ZERO; 00087940
PRIMEX := ZERO MOD PRIME; 00087950
PRIMEBIG := OVERFLOWP(ZTRACT(PRIME**2)); 00087960
MICROBUMP(6); 00087965
END; 00087970
ARG1 := D; 00087980
ISPVALUE[GMOD.FIELD] := G; 00087990
MICROBUMP(6); 00087995
PRIMCOUNTER(4); 00088000
END XSETMOD; 00088020
00088030
PROCEDURE XCRECIP; 00088040
BEGIN REAL A,B,X,Y,R; 00088050
DECLAREANDWEIGH; 00088060
X := PRIME; Y := ZEXTEND(ARG1); A := 1; 00088070
WHILE Y>0 DO 00088080
BEGIN 00088090
R := -(X DIV Y)*A+B; 00088100
B := A; A := R; 00088110
R := X MOD Y; 00088120
X := Y; Y := R; 00088130
END; 00088140
B := (IF B>0 THEN 0 ELSE PRIME) + (B MOD PRIME); 00088150
ARG1 := ZTRACT(B); 00088160
MICROBUMP(10); 00088170
PRIMCOUNTER(6); 00088180
END XCRECIP; 00088200
00088210
00088220
PROCEDURE HI; 00091000
BEGIN REAL N; 00091010
ARRAY A[0:500]; 00091020
LABEL EXIT; 00091030
N := MYSELF.TASKVALUE; MYSELF.TASKVALUE := 0; 00091040
CASE N OF 00091050
BEGIN 00091060
0: ASKING := TRUE; 00091070
1: ON INVALIDINDEX[A:N], 00091080
BEGIN 00091090
HIGH := TRUE; 00091095
FAULTPROCESSOR(A,-4); 00091100
GO TO EXIT; 00091120
END; 00091130
N := MCAR[-1]; 00091140
ELSE:; 00091145
END; 00091150
EXIT: 00091340
END HI; 00091350
00091360
INTERRUPT ANSWER; HI; 00091370
00091380
PROCEDURE INITFREECHAIN; 00091600
BEGIN 00091610
REAL P,S; 00091620
S:=PSPFREE DIV PAGESIZE; 00091630
WHILE P<=S DO 00091640
BEGIN 00091650
PPAGEUSED[P]:=TRUE; 00091660
P:=P+1; 00091670
END INITPAGEUSED; 00091680
INUSE:=P*PAGESIZE; 00091690
WORKSET:=PSPFREE; 00091700
RHO:=100; 00091710
WHILE P<PPAGEMAX DO 00091720
BEGIN 00091730
PPAGEUSED[P]:=FALSE; 00091740
P:=P+1; 00091750
END INITPAGEFREE; 00091760
P:=PSPFREE; S:=(PSPFREE+PAGESIZE) DIV PAGESIZE * PAGESIZE; 00091770
DO BEGIN 00091780
MCAR[P]:=MAXFIELDV; % MARK WITH SILLY NUMBER. 00091790
P:=MCDR[P]:=P+1; 00091800
END UNTIL P=S; 00091810
MCDR[P-1]:=-1; 00091820
P:=MYSELF.COREESTIMATE; 00091830
P:=(P-50000) DIV 2; 00091840
P:=MAX(PSPFREE+PAGESIZE*4,P); 00091850
P:=(P+PAGESIZE) DIV PAGESIZE; 00091860
APAGEMAX:=MIN(PPAGEMAX,P); 00091870
WRITETTY("PAIR SPACE =" CAT APAGEMAX FOR 4 NUMERIC CAT " PAGES"); 00091880
P:=ISPFREE; 00091890
DO BEGIN 00091900
ISPPNAME[P]:=0; ISPPROP[P]:=MAXFIELDV; 00091910
ISPVALUE[P].FIELD:=P+1; 00091920
ISPVALUE[P].TAG:=IDTAG; 00091930
P:=P+1; 00091940
END UNTIL P=AISPMAX; 00091950
ISPVALUE[AISPMAX-1].FIELD:=ISPMAX+1; 00091960
VSP[0]:=VSPMAX-2; VSP[1]:=-1; % INITIALLY ONE OBJECT FULL LENGTH. 00091970
END INITFREECHAIN; 00091980
00091990
PROCEDURE INITIALIZE; 00092000
BEGIN 00092100
REAL TMP; 00092200
00092300
% LARGE SYSTEM INITIALIZATIONS 00092400
$ SET OMIT = SLOWSTACK OR COUNT 00092410
MTEMP:="LOCAL "; 00092420
MTEMPLOC:=STACKOFFSET(MTEMP); 00092430
MTEMPLOC:=MASKSTACKSEARCHER("LOCAL ",4"FFFFFFFFFF00",RCVLOC,MTEMPLOC); 00092440
$ POP OMIT 00092460
TSPMAX := ESPMAX := PAGESIZE; 00092500
ATTACH ANSWER TO MYSELF.EXCEPTIONEVENT; 00092600
ENABLE ANSWER; 00092700
CONVERTPTR:=POINTER(CONVERTARRAY,8); 00092800
REPLACE COLLECTOR BY " " FOR 132; 00092900
WRITETTY("OPTIONS SET: " CAT 00093000
$ POP OMIT SET OMIT = NOT COUNT 00093300
" COUNT" CAT 00093400
$ POP OMIT SET OMIT = NOT SLOWSTACK 00093500
" SLOWSTACK" CAT 00093600
$ POP OMIT SET OMIT = NOT NEWP 00093620
" NEWP INTRINSICS" CAT 00093640
$ POP OMIT SET OMIT = NOT FASTLINK 00093700
" FASTLINK" CAT 00093800
$ POP OMIT 00094700
" "); 00094800
NIL := 0 & IDTAG TAG; 00094900
T := TRUTH(TRUE); 00095000
ZERO := ZEROLIT; ONE := ZERO+1; TWO := ONE+1; THREE := TWO+1; 00095100
$ SET OMIT = NOT COUNT 00095500
FILL TRACETABLE WITH 00095600
"EXPLODE ", %0 00095700
"CATCH ", %1 00095800
"LENGTHC ", %2 00095900
"GENSYM ", %3 00096000
"SETMOD ", %4 00096100
"COMPRESS ", %5 00096200
"CRECIP ", %6 00096300
"CMOD ", %7 00096400
"CPLUS ", %8 00096500
"CTIMES ", %9 00096600
"CDIF ", %10 00096700
"REMOB ", %11 00096800
"RCONS ", %12 00096900
"NCONS ", %13 00097000
"CONS ", %14 00097100
"RPLACA ", %15 00097200
"RPLACD ", %16 00097300
"TERPRI ", %17 00097400
"PRINC ", %18 00097500
"THROW ", %19 00097600
"INTERN ", %20 00097700
"READCH ", %21 00097800
"LAMBIND ", %22 00097900
"QUIT ", %23 00098000
"PATOM ", %24 00098100
"PATOM2 ", %25 00098200
"EQ ", %26 00098300
"EQN ", %27 00098400
"RECLAIM ", %28 00098500
"PLUS2 ", %29 00098600
"TIMES2 ", %30 00098700
"DIFFERENCE ", %31 00098800
"QUOTIENT ", %32 00098900
"GREATERP ", %33 00099000
"LESSP ", %34 00099100
"SCAN ", %35 00099200
"REMAINDER ", %36 00099300
"UNSTACK ", %37 00099400
"CLOSE ", %38 00099500
"EJECT ", %39 00099600
"$APPLY ", %40 00099700
"OPEN ", %41 00099800
"POSN ", %42 00099900
"RDS ", %43 00100000
"WRS ", %44 00100100
"XXFNPTR ", %45 00100200
"GETV ", %46 00100300
"MKVECT ", %47 00100400
"PUTV ", %48 00100500
"UPLIM ", %49 00100600
"TIME ", %50 00100700
"PUTPROP ", %51 00100800
"GETPROP ", %52 00100900
"PUTG ", %53 00101000
"GETG ", %54 00101100
"DUMP ", %55 00101200
"ORDERP ", %56 00101300
"CHKPOINT ", %57 00101400
"CONSTANTP ", %58 00101500
"VECTORP ", %59 00101600
"SETPCHAR ", %60 00101700
"EXPT ", %61 00101800
"EQUAL ", %62 00101900
"LENGTH ", %63 00102000
"REVERSIP ", %64 00102100
"MEMQ ", %65 00102200
"MEMBER ", %66 00102300
"LITER ", %67 00102400
"DIGIT ", %68 00102500
"GET ", %69 00102600
"GETD ", %70 00102700
"GLOBALP ", %71 00102800
"FLUIDP ", %72 00102900
"GLOBAL ", %73 00103000
"FLUID ", %74 00103100
"UNFLUID ", %75 00103200
"PUTD ", %76 00103300
"CALL FSUBR ", %77 00103400
"CALL SUBR ", %78 00103500
"ATOM ", %79 00103600
"LIST ", %80 00103700
"QUOTE ", %81 00103800
"CAR ", %82 00103900
"CDR ", %83 00104000
"NULL ", %84 00104100
"CODEP ", %85 00104110
"IDP ", %86 00104120
"NUMBERP ", %87 00104130
"PAIRP ", %88 00104140
"STRINGP ", %89 00104150
"ALLOC ", %90 00104700
"DEALLOC ", %91 00104800
"M-PROGBIND ", %92 00104900
"M-LAMBBIND ", %93 00105000
"STORE ", %94 00105100
"STOREXXXXX ", %95 00105200
"SET LOCAL ", %96 00105300
"XXXX ", %97 00105400
"GO TO ", %98 00105500
"COND JUMP ", %99 00105600
"LOAD ", %100 00105700
"FAST-LINK ", %101 00105710
"SLOW-LINK ", %102 00105720
"M-LINK ", %103 00105730
"LIT PLUS ", %104 00105732
"LIT DIFF ", %105 00105734
0; 00105800
$ POP OMIT 00105900
00106000
%SET UP POINTERS. 00106100
ISPFREE := PSPFREE := VSPFREE := GGENSYM := 0; 00106200
TSP[0] := 0; TSPPTR := 1; %STACK BOTTOM AND POINTER. 00106300
INPTR := -1; 00106400
CURCHANOUT := CURCHANIN := OUTPTR := 0; 00106500
FILEINUSEA:=FALSE; %NONE OF THE AUXILIARY FILES ARE IN USE. 00106600
REPLACE LINER BY " " FOR INSZE; 00106700
REPLACE OUTER BY " " FOR 132; 00106800
MICROCOUNT := 1; %MICRO COUNTER TO 1. 00106900
ARG16 := NIL; %REG 16 = NIL ALWAYS!!! 00107000
AISPMAX := 512; 00107100
00107200
%READ THE INIT FILE. 00107300
FASTLOAD; 00107400
00107500
%BUILD THE FREE CELL LIST. 00107600
INITFREECHAIN; 00107700
ALWAYS := ZCONS(NIL,NIL); SOMETIMES := ZCONS(NIL,NIL); 00108110
YINITIALISE; 00108200
TMP:=GINITIALISE.FIELD; 00108300
QPTR := ISPPNAME[TMP].QSPPTR-1; 00108400
ISPVALUE[TMP] := ISPPROP[TMP] := NIL; 00108600
GINITIALISE := NIL; 00108700
$ SET OMIT = NOT COUNT 00108800
ISPCNT[TMP] := ISPWEIGHT[TMP] := 0; 00108900
$ POP OMIT 00109000
GARBAGETIME := 0; 00109010
OLDTIME := BEGINTIME := TIME(12); 00109020
END INITIALIZE; 00109100
00109200
00109500
PROCEDURE RMARKCELL(GP); VALUE GP; REAL GP; 00109600
BEGIN REAL BP,SP,GA,GB,I; 00109700
BP := SP := TSPPTR+1; 00109800
IF SP+1>=TSPMAX THEN 00109900
EXPANDSTACK; 00110000
RPUSH(-1); % TO RECOGNIZE FINISH. 00110100
DO BEGIN 00110200
IF SP+1>=TSPMAX THEN 00110300
EXPANDSTACK; 00110400
IF MPAIRP(GP) THEN 00110500
BEGIN 00110600
GB:=MCAR[GP]; 00110700
IF MGARBAGEP(GB) THEN 00110800
GP:=RPOP 00110900
ELSE 00111000
BEGIN 00111100
MGARBAGEP(MCAR[GP]):=TRUE; 00111200
IF IGNORE(GB) THEN 00111300
BEGIN 00111310
GB:=MCDR[GP]; 00111320
GP:=IF IGNORE(GB) THEN RPOP ELSE GB 00111330
END 00111340
ELSE 00111350
BEGIN 00111360
GP:=MCDR[GP]; 00111370
IF NOT IGNORE(GP) THEN 00111380
RPUSH(GP); 00111390
GP:=GB; 00111400
END; 00111410
END; 00111500
END ELSE 00111600
IF MIDP(GP) THEN 00111700
BEGIN 00111800
GB:=ISPVALUE[GP.FIELD]; 00111810
IF MGARBAGEP(GB) THEN 00111900
GP:=RPOP 00112000
ELSE 00112100
BEGIN 00112200
MGARBAGEP(ISPVALUE[GP.FIELD]):=TRUE; 00112400
IF STRINGSNEEDIT THEN 00112600
RPUSH(STRINGIZE(ISPPNAME[GP.FIELD])); 00112700
IF IGNORE(GB) THEN 00112710
BEGIN 00112720
GB:=ISPPROP[GP.FIELD]; 00112730
GP:=IF IGNORE(GB) THEN RPOP ELSE GB; 00112740
END 00112750
ELSE 00112760
BEGIN 00112770
GP:=ISPPROP[GP.FIELD]; 00112780
IF NOT IGNORE(GP) THEN 00112790
RPUSH(GP); 00112800
GP:=GB 00112810
END; 00112820
END; 00112900
END ELSE 00113000
IF MSTRINGP(GP) THEN 00113100
BEGIN 00113200
GB:=GP.BUCKF; GP:=GP.SLOCF; 00113500
IF GB>0 THEN 00113600
REPLACE SSP[GB,GP+1] BY (REAL(SSP[GB,GP+1],2)&1 SPGARBF)00113700
.[15:48] FOR 2; 00113800
GP:=RPOP; 00114000
END ELSE 00114100
IF MVECTORP(GP) THEN 00114200
BEGIN 00114300
IF NOT MGARBAGEP(VSP[GP.FIELD]) THEN 00114400
BEGIN 00114700
GB := ZEXTEND(VSP[GP:=GP.FIELD])+1; 00114800
MGARBAGEP(VSP[GP]):=TRUE; 00114900
WHILE GB+SP>=TSPMAX DO EXPANDSTACK; 00115000
I:=1; 00115010
DO BEGIN 00115030
GA:=VSP[GP+I]; 00115040
IF NOT IGNORE(GA) THEN 00115050
RPUSH(GA); 00115060
END UNTIL I:=I+1>GB; 00115070
END; 00115500
GP:=RPOP; 00115510
END ELSE 00115600
IF BIGP(GP) THEN 00115610
GP.TAG := 0 00115620
ELSE GP:=RPOP; 00115630
END UNTIL SP=BP; 00115900
END RMARKCELL; 00116000
00116100
00116200
PROCEDURE ZGARBAGE(Y); VALUE Y; REAL Y; 00116300
% THIS IS THE GARBAGE COLLECTOR. IT EXPECTS ONE ARGUMENT IN Y 00116400
% WHICH IS A STRING GIVING THE REASON FOR THE GARBAGECOLLECTION. 00116500
BEGIN LABEL FINDUSED,FINI; 00116600
REAL S,P,Q,R,PAVAILABLE,IAVAILABLE,GP; 00116700
REAL T1,T2,T3,NUWORK,NUINUSE; 00116800
ARRAY FA[0:500]; 00116900
00117000
DEFINE MARKCELL(X) = 00117100
BEGIN 00117200
GP:=X; 00117300
IF NOT IGNORE(GP) THEN 00117350
IF NOT MGARBAGEP(IF MIDP(GP) THEN ISPVALUE[GP.FIELD] ELSE 00117400
IF MPAIRP(GP) THEN MCAR[GP] ELSE 0) THEN 00117410
RMARKCELL(GP); 00117600
END MARKCELL#; 00117700
00117800
00117900
T1:=TIME(12); 00118000
DISABLE ANSWER; 00118010
IF ISPVALUE[GCFLAG.FIELD] NEQ NIL THEN 00118100
BEGIN 00118200
CASE Y OF 00118300
BEGIN 00118400
REPLACE CONVERTPTR BY "PAIR SPACE "; 00118500
REPLACE CONVERTPTR BY "ID SPACE "; 00118600
REPLACE CONVERTPTR BY "USER REQUEST"; 00118700
REPLACE CONVERTPTR BY "VECTOR SPACE"; 00118800
END; 00118900
WRITETTY("GARBAGE COLLECTION FOR " CAT CONVERTPTR FOR 12); 00119000
END; 00119100
IF ISPVALUE[GCFLAG.FIELD] = ONE THEN 00119200
BEGIN 00119300
P:=0; 00119400
ON ZERODIVIDE[FA:P]: 00119500
FAULTPROCESSOR(FA,1); 00119600
P:=P/P; 00119700
END; 00119800
% THAT PUTS OUT THE MESSAGE IF NECESSARY; 00119900
STRINGSNEEDIT := NEWSCNT1>NEWSCNT2; 00119990
IGNORABLES.TAG := 00120000
IF STRINGSNEEDIT THEN FUNCTTAG ELSE FUNCTTAG+STRINGTAG; 00120010
IGNORABLES:=IGNORABLES+MINIMUM; 00120020
MGARBAGEP(IGNORABLES):=TRUE; 00120030
NEWSCNT2 := NEWSCNT1; 00120100
FOR P:=1 STEP 1 UNTIL APAGEMAX DO 00120200
PPAGEUSED[P]:=FALSE; 00120300
PPAGEUSED[0]:=TRUE; % MARK FOR NIL. 00120400
S:=QPTR-1; % THE Q POINTER. 00120410
MGARBAGEP(ISPVALUE[NIL.FIELD]):=TRUE; 00120500
Q:=GLOBLENGTH; 00120510
GLOBALVECT[Q:=Q+1]:=ISPPROP[NIL.FIELD]; 00120600
GLOBALVECT[Q:=Q+1]:=STRINGIZE(ISPPNAME[NIL.FIELD]); 00120700
GLOBALVECT[Q:=Q+1]:=ZA; GLOBALVECT[Q:=Q+1]:=ZB; 00120900
ZA := ZB := NIL; 00121000
GLOBALVECT[Q:=Q+1]:=ALWAYS; GLOBALVECT[Q:=Q+1]:=SOMETIMES; 00121010
FOR P:=0 STEP 1 UNTIL Q DO 00121100
MARKCELL(GLOBALVECT[P]); % MARK THE GLOBALS. 00121200
FOR P:=0 STEP 1 UNTIL 15 DO 00121300
MARKCELL(ARGS[P]); 00121400
P:=0; 00121500
IF STRINGSNEEDIT THEN DO MARKCELL(ERRS[P]) UNTIL ERRS[P:=P+1] = 0; 00121600
FOR P:=0 STEP 1 UNTIL S DO 00121700
MARKCELL(QSP[P]); 00121800
% MARK THE STACK NOW; 00121900
FOR P:=1 STEP 1 UNTIL ES DO 00122000
MARKCELL(ESP[P]); 00122100
Q := TSPPTR - 1; % THE INITIAL STACKFRAME; 00122200
WHILE Q>0 DO 00122300
BEGIN 00122400
P:=TSP[Q] -1; % THE NEXT FRAME, -1 FOR OFFSET 00122500
Q:=Q-1; 00122600
R:=(IF TSP[Q]=GBPROG THEN 3 ELSE 0)+P; % IGNORE FUNNIES IN BPROG 00122700
DO BEGIN 00122800
MARKCELL(TSP[Q]); 00122900
Q:=Q-1; 00123000
END UNTIL Q<=R; % FINISHED FRAME; 00123100
Q:=P; 00123200
END SCANSTACK; 00123300
$ SET OMIT = SLOWSTACK OR COUNT 00123400
P:=STACKOFFSET(P); S:=MTEMPLOC; MTEMP:="LOCAL "; 00123500
WHILE P:=MASKSTACKSEARCHER("LOCAL ",4"FFFFFFFFFF00",RCVLOC,P-1) > S DO 00123600
BEGIN 00123700
R:=RCVLOC[0].[6:7]; 00123800
IF R>0 THEN 00123900
BEGIN 00124000
CHECKSTACK(R); 00124100
COPYFROMSTACK(R,POINTER(TSP[TSPPTR]),P+1); 00124200
Q:=TSPPTR; 00124300
TSPPTR:=Q+R; 00124400
DO BEGIN 00124500
MARKCELL(TSP[Q]); 00124600
Q:=Q+1; 00124700
END UNTIL Q=TSPPTR; 00124800
TSPPTR:=*-R; 00124900
END; 00125000
END; 00125100
$ POP OMIT 00125200
% END OF PHASE ONE. NOW HAVE TO DO SCAN OF OBLIST RECHAINING 00125300
% AND THEN THE LINEAR SCAN OF THE P AND I SPACES; 00125400
%SEGMENT(PHASE2); 00125500
P:=1; 00126200
DO BEGIN 00126300
IF MINTERNED(ISPPNAME[P]) THEN 00126400
IF NOT MGARBAGEP(ISPVALUE[P]) THEN 00126500
IF ISPVALUE[P] NEQ NIL THEN RMARKCELL(P&IDTAG TAG) ELSE 00126600
IF ISPPROP[P] NEQ NIL THEN RMARKCELL(P&IDTAG TAG) ELSE 00126700
IF MGLOBALP(P) THEN RMARKCELL(P&IDTAG TAG) ELSE 00126800
IF MFLUIDP(P) THEN RMARKCELL(P&IDTAG TAG); 00126900
P:=P+1 00127000
END UNTIL P>ISPHIGH; 00127100
T2:=TIME(12); 00127200
00127300
% THE USED STORE IS NOW MARKED. WE MUST DO A LINEAR SCAN 00127400
% OF THE I AND P SPACES TO CONSTRUCT A FREE CHAIN; 00127500
R:=APAGEMAX-1; % TOP PAGE; 00127600
PSPFREE:=-1; % JUST IN CASE IT WAS I SPACE. 00127700
PAVAILABLE:=0; 00127800
DO BEGIN 00127900
P:=(R+1)*PAGESIZE-1; % TOP OF THE PAGE; 00128000
Q := 0; MGARBAGEP(Q) := TRUE; 00128100
REPLACE SEARCHPAGE BY POINTER(MCAR[PAGESIZE*R]) FOR PAGESIZE WORDS; 00128150
IF MASKSEARCH(Q,Q,SEARCHPAGE[PAGESIZE-1])>=0 THEN 00128200
BEGIN 00128300
NUINUSE:=*+PAGESIZE; 00128400
PPAGEUSED[R] := TRUE; 00128500
S:=P-PAGESIZE; 00128600
DO BEGIN 00128700
Q:=MCAR[P]; 00128900
IF NOT MGARBAGEP(Q) THEN 00129000
BEGIN 00129100
PAVAILABLE:=*+1; 00129200
MCAR[P]:=MAXFIELDV; % PLACE ON FREE LIST; 00129300
MCDR[P]:=PSPFREE; 00129400
PSPFREE:=P; 00129500
END 00129600
ELSE % JUST UNMARK; 00129700
BEGIN NUWORK:=*+1; 00129800
MGARBAGEP(MCAR[P]):=FALSE; 00129900
END; 00130000
P:=P-1; 00130100
END UNTIL P=S; 00130200
END 00130300
ELSE 00130400
BEGIN 00130500
PPAGEUSED[R] := FALSE; 00130600
PAVAILABLE := *+PAGESIZE; 00130700
END; 00130800
R:=*-1; 00130900
END UNTIL R<0; 00131000
IF ISPFREE=ISPMAX+1 OR Y=1 THEN 00131100
IF AISPMAX<ISPMAX THEN 00131200
RESIZE(ISPPNAME,AISPMAX:=*+PAGESIZE,RETAIN); 00131300
P:=AISPMAX - 1; % THE BASE OF THE I SPACE; 00131400
ISPFREE:=ISPMAX+1; 00131500
IAVAILABLE:=0; 00131600
ISPHIGH:=0; 00131700
DO BEGIN 00131800
IF NOT MGARBAGEP(ISPVALUE[P]) THEN BEGIN 00132000
IAVAILABLE:=*+1; 00132100
ISPVALUE[P].FIELD:=ISPFREE; 00132200
ISPVALUE[P].TAG:=IDTAG; 00132300
ISPPNAME[P]:=ISPPROP[P]:=MAXFIELDV; 00132400
ISPFREE:=P; 00132500
END 00132600
ELSE BEGIN 00132700
MGARBAGEP(ISPVALUE[P]):=FALSE; 00132800
IF ISPHIGH=0 THEN ISPHIGH:=P; 00132900
END; 00133000
P:=P-1; 00133100
END UNTIL P<0; 00133200
R:=1; 00133300
IF STRINGSNEEDIT THEN 00133400
DO BEGIN 00133500
P:=0; 00133600
WHILE S:=(Q:=REAL(SSP[R,P],3)).[23:8] > 0 DO 00133700
BEGIN 00133800
IF BOOLEAN(Q).SPGARBF THEN 00133900
BEGIN 00134000
REPLACE SSP[R,P] BY (Q&0 SPGARBF).[23:48] FOR 3; 00134100
P:=P+S+3; 00134200
END 00134300
ELSE 00134400
BEGIN 00134500
Q:=P; 00134600
DO BEGIN 00134700
P:=P+S+3; 00134800
S:=REAL(SSP[R,P],1); 00134900
END UNTIL P-Q+S>255 OR S=0 OR 00135000
BOOLEAN(REAL(SSP[R,P],3).SPGARBF); 00135100
REPLACE SSP[R,Q] BY (0&1 FREEF & (P-Q-3)[23:8]).[23:48] 00135200
FOR 3; 00135300
END; 00135400
END; 00135500
R:=R+1; 00135600
END UNTIL P=0 AND R>SSPHBUCKETS; 00135700
P:=0; VSPFREE:=-1; R:=-1; 00135800
DO BEGIN 00135900
Q:=P; 00136000
WHILE P<VSPMAX DO 00136100
BEGIN % END OF VECTOR SPACE. 00136200
IF MGARBAGEP(VSP[P]) THEN BEGIN 00136300
MGARBAGEP(VSP[P]):=FALSE; GO TO FINDUSED; END; 00136400
P:=P+VSP[P].FIELD+2; 00136500
END; 00136600
FINDUSED: 00136700
IF P NEQ Q THEN BEGIN 00136800
VSP[Q]:=P-Q-2; % LENGTH OF GAP. 00136900
VSP[Q+1]:=-1; % TERMINATE THE CHAIN. 00137000
IF R<0 THEN VSPFREE:=Q ELSE VSP[R+1]:=Q; 00137100
R:=Q; 00137200
END; 00137300
IF P>=VSPMAX THEN GO TO FINI; % FINISHED. 00137400
P:=P+VSP[P].FIELD+2; 00137500
END UNTIL FALSE; 00137600
FINI: 00137700
IF PAVAILABLE<4*PAGESIZE THEN 00137800
BEGIN 00137900
P:=APAGEMAX; 00138000
APAGEMAX:=MIN(APAGEMAX+4,PPAGEMAX); 00138100
PAVAILABLE:=*+(APAGEMAX-P)*PAGESIZE; 00138200
END; 00138300
T3:=TIME(12); 00138400
GARBAGETIME:=T3-T1+GARBAGETIME; 00138500
IF ISPVALUE[GCFLAG.FIELD] NEQ NIL THEN 00138600
IF NOT BREAK THEN 00138700
BEGIN 00138800
WRITETTY("GC END; PAIR AVAIL = " CAT DECIMAL(PAVAILABLE,6) 00138900
CAT ", SYMBOL AVAIL = " CAT DECIMAL(IAVAILABLE,4)); 00139000
BREAK:=WRITE(ME,<2A6," =",I6,",",F10.3>, 00139100
"PREV F","REE ",INUSE-WORKSET,(T1-OLDTIME)*2.4@-3/ 00139200
(INUSE-WORKSET), 00139300
"TOTAL ","PAIRS ",NUINUSE,(T3-T2)*2.4@-3/NUINUSE, 00139400
"IN USE"," PAIRS",NUWORK,(T2-T1)*2.4@-3/NUWORK); 00139500
BREAK:=WRITE(ME,<"TOTAL TIME = ",F7.2,", GC TIME =",F7.2, 00139600
", THIS TIME =", F5.2,F7.2,"%">, 00139700
(T3-BEGINTIME)*2.4@-6,GARBAGETIME*2.4@-6,(T3-T1)*2.4@-6, 00139800
100*GARBAGETIME/(T3-BEGINTIME)); 00139900
END; 00140000
INUSE:=NUINUSE; WORKSET:=NUWORK; OLDTIME:=T3; 00140100
ENABLE ANSWER; 00140110
IF (PAVAILABLE=0) OR (IAVAILABLE=0) THEN 00140200
ZERROR(110, ERRS[10]); 00140300
END ZGARBAGE; 00140400
00140500
00140600
PROCEDURE XRECLAIM; 00140700
BEGIN LABEL EXIT; 00140800
DECLAREANDWEIGH; 00140810
ARG1:=NIL; ZGARBAGE(2); 00140900
MICROBUMP(5); 00140910
PRIMCOUNTER(28); 00141000
END XRECLAIM; 00141100
00141200
$PAGE 00141300
%SEGMENT(T.SPACE); 00141400
00141500
00144400
DEFINE ZPUSH(WHAT) = 00144500
BEGIN 00144600
TSP[TSPPTR] := WHAT; 00144700
TSPPTR:=TSPPTR+1; 00144800
END ZPUSH#; 00144900
00145000
00145600
DECLARE(XQUOTE,81,ARG1:=MCAR[ARG1]); 00145700
00145800
REAL PROCEDURE ZBIND(FRML,ACTUAL); 00145900
% PROCEDURE BINDS THE ACTUAL PARAMETERS TO THE FRML AND PLACES 00146000
% THEM ON THE STACK WITH LAMBDA AS THE FUNCTION NAME. 00146100
% IF NILLER IS TRUE THEN BIND THE VALUES TO NIL AND DON'T WORRY ABOUT 00146200
% ACTUAL (USED BY PROG FOR PROG VARIABLES). 00146300
VALUE FRML,ACTUAL; 00146400
REAL FRML,ACTUAL; 00146500
BEGIN REAL OLD,A1,A2; 00146600
BOOLEAN NILLER; 00146700
DECLAREANDWEIGH; 00146750
NILLER := ACTUAL=NIL; 00146800
OLD := TSPPTR; %BACK CHAIN POINTER HERE. 00147000
CHECKSTACK(18); 00147100
A2 := NIL; 00147200
WHILE MPAIRP(FRML) AND (MPAIRP(ACTUAL) OR NILLER) DO 00147300
BEGIN MICROBUMP(7); 00147400
A1 := MCAR[FRML]; 00147500
IF NOT NILLER THEN 00147600
BEGIN 00147700
A2 := MCAR[ACTUAL]; 00147800
ACTUAL := MCDR[ACTUAL]; 00147900
MICROBUMP(2); 00148000
END; 00148100
ZPUSH(ISPVALUE[A1.FIELD]); %VALUE HERE. 00148200
ZPUSH(A1); %VARIABLE NAME HERE. 00148300
ISPVALUE[A1.FIELD] := A2; 00148400
FRML := MCDR[FRML]; %NEXT FORMAL PARAMETER. 00148500
END; 00148600
ZPUSH(GLAMBDA); %ADD LAMBDA AS THE FUNCTION NAME.%PPDMTL05 00148610
ZPUSH(OLD); %ADD THE BACK CHAIN POINTER. %PPDMTL05 00148620
IF FRML NEQ ACTUAL THEN %ERROR IF BOTH LISTS ARE NOT EMPTY. 00148700
ZERROR(120, ERRS[11]); 00148800
%PPDMTL05 00148900
%PPDMTL05 00149000
ZBIND := NIL; 00149100
MICROBUMP(13); 00149200
PRIMCOUNTER(22); 00149210
END ZBIND; 00149300
00149400
00149500
DEFINE XLAMBIND = ARG1 := ZBIND(ARG1,ARG2)#; 00149600
00149700
00149800
PROCEDURE ZSPREAD; 00149900
% PROCEDURE SPREADS THE ACTUAL PARAMETERS IN ACTUAL LIST AMONG THE 00150000
% REGISTERS ARG1 -> ARG14. 00150100
BEGIN REAL I; 00150200
LABEL EXIT; 00150300
DECLAREANDWEIGH; 00150400
MICROBUMP(5); 00150500
ZA := ARG1; 00150600
I := ARG2; 00150610
IF MATOM(I) THEN 00150700
BEGIN ARG1 := NIL; GO TO EXIT END; 00150800
'FOR NUM:=0 STEP 1 UNTIL 13 DO 00150900
'BEGIN 00151000
MICROBUMP(3); 00151100
ARG'NUM := MCAR[I]; 00151200
I := MCDR[I]; 00151300
IF MATOM(I) THEN GO TO EXIT; 00151400
'END; 00151500
ZERROR(107,ERRS[7]); 00151600
EXIT: 00151700
PRIMCOUNTER(40); 00151800
END ZSPREAD; 00152000
00152100
DEFINE XAPPLY = 00152110
% USER INTERFACE TO ZCALL. PUT FN-POINTER IN $FN GLOBAL; 00152120
BEGIN 00152130
ZSPREAD; 00152140
STOPCOUNT; 00152150
ZCALL(ZA); 00152160
STARTCOUNT; 00152170
END XAPPLY#; 00152180
00152190
DEFINE XLINK = #, XSPREAD = XAPPLY#; 00152195
00152200
PROCEDURE ZUNSTACK; 00152300
BEGIN REAL I,J; 00152400
DECLAREANDWEIGH; 00152410
MICROBUMP(8); 00152420
J := TSPPTR-1; 00152500
TSPPTR := I := TSP[J]; 00152600
J := J-2; 00152700
WHILE I<J DO 00152800
BEGIN 00152900
ISPVALUE[TSP[I+1].FIELD] := TSP[I]; 00153000
I := I+2; 00153100
MICROBUMP(4); 00153110
END; 00153200
PRIMTRACE(37); 00153210
END ZUNSTACK; 00153300
00153400
00153500
PROCEDURE XTHROW; 00153600
% POPS THE STACK UNTIL THE CATCH FUNCTION IS FOUND. SETS BACKOUT. 00153700
% PTR IS SET TO THE TOP OF THE STACK AT THIS POINT. 00153800
% IF TB IS NON-NIL, A TRACEBACK IS GENERATED. 00153900
BEGIN 00154000
REAL PTR,I; 00154100
ARRAY A[0:100]; 00154110
LABEL EXIT; 00154200
DECLAREANDWEIGH; 00154210
BASKET := ARG1; 00154400
PTR := TSPPTR - 1; 00154600
IF ARG2 NEQ NIL THEN %DISPLAY A TRACEBACK MESSAGE. 00154700
BEGIN 00154800
STOPCOUNT; 00154850
XTERPRI; 00154900
REPLACE OUTER BY "***** ERROR TRACEBACK.."; 00155000
OUTPTR := 23; 00155100
XTERPRI; 00155200
ON ZERODIVIDE[A:I]: FAULTPROCESSOR(A,1); 00155210
I := I/I; 00155220
STARTCOUNT; 00155300
MICROBUMP(5); 00155310
END; 00155400
MICROBUMP(9); 00155500
WHILE TSP[PTR] NEQ 0 DO 00155600
BEGIN 00155700
MICROBUMP(7); 00155800
IF TSP[PTR-1] = GCATCH THEN %WE'RE THERE. 00155900
BEGIN MICROBUMP(200); 00156000
PRIMCOUNTER(19); 00156050
PTR:=*+1; %NEW STACK TOP. 00156100
BACKOUT := TRUE; %BACK OUT GRACEFULLY. 00156200
TSPPTR :=PTR; 00156300
THROWCOUNTER := *+1; 00156400
CAUSE(THROW); 00156500
IF HIGH THEN BEGIN HIGH := FALSE; GO TO EXIT END; 00156510
ERRSTOP("NO CATCHER FOR THROW"); 00156600
END; 00156700
IF TSP[PTR-1] = GBPROG THEN 00157700
BEGIN 00157800
MICROBUMP(2); 00157900
CURQPROGPTR := TSP[TSP[PTR]]; 00158000
CURSTACKBASE := TSP[TSP[PTR]+2]; 00158100
END; 00158200
IF TSP[PTR-1] = GLAMBDA THEN 00158300
BEGIN 00158400
I := TSP[PTR]; 00158500
WHILE I+1<PTR DO 00158600
BEGIN 00158700
ISPVALUE[TSP[I+1].FIELD] := TSP[I]; 00158800
I := I+2; 00158900
END; 00159000
END; 00159100
PTR := TSP[PTR] - 1; 00159200
END; 00159300
ERRSTOP("STACK UNDERFLOW DURING BACK TRACK"); 00159400
EXIT: 00159410
END XTHROW; 00159500
$PAGE 00159600
%SEGMENT(PRIMITIVES); 00159700
DEFINE XCODEP=ARG1:=VCODEP(ARG1)#, 00159800
XIDP=ARG1:=VIDP(ARG1)#, 00159900
XNUMBERP=ARG1:=VNUMBERP(ARG1)#, 00160000
XPAIRP=ARG1:=VPAIRP(ARG1)#, 00160100
XATOM=ARG1:=VATOM(ARG1)#, 00160200
XCONSTANTP=ARG1:=VCONSTANTP(ARG1)#, 00160400
XVECTORP=ARG1:=VVECTORP(ARG1)#, 00160500
XSTRINGP=ARG1:=VSTRINGP(ARG1)#; 00160600
DECLARE(XGLOBALP,71,MXGLOBALP); 00160700
DECLARE(XFLUIDP,72,MXFLUIDP); 00160800
DECLARE(XORDERP,56,ARG1:=MORDERP(ARG1,ARG2)); 00160810
00160900
REAL PROCEDURE ZCONS(A,B); VALUE A,B; REAL A,B; 00161000
% PICKS UP THE NEXT FREE CELL. IF P.SP.FREE IS NEGATIVE THEN LOOK 00161100
% FOR AN EMPTY PAGE. IF NO SUCH PAGE CALL THE GARBAGE COLLECTOR. 00161200
BEGIN 00161300
REAL I; 00161400
DECLAREANDWEIGH; 00161450
IF PSPFREE<0 THEN 00161500
BEGIN 00161600
IF RHO*WORKSET<INUSE OR INUSE=PAGESIZE*APAGEMAX THEN 00161700
BEGIN ZA:=A; ZB:=B; 00161800
ZGARBAGE(0); 00161900
END; 00162000
IF PSPFREE<0 THEN 00162100
BEGIN 00162200
WHILE PPAGEUSED[I] DO I:=I+1; 00162300
INUSE:=*+PAGESIZE; 00162400
PPAGEUSED[I]:=TRUE; 00162500
PSPFREE:=I:=I*PAGESIZE; 00162600
DO I:=MCDR[I]:=I+1 UNTIL I-(PAGESIZE-1) = PSPFREE; 00162700
MCDR[I]:=-1; 00162800
REPLACE MCAR[PSPFREE] BY MAXFIELDV FOR PAGESIZE WORDS; 00162900
END; 00163000
END; 00163100
MCAR[I := ZCONS := PSPFREE] := A; 00163200
PSPFREE := MCDR[PSPFREE]; 00163300
MCDR[I] := B; 00163400
MICROBUMP(8); 00163500
PRIMCOUNTER(14); 00163600
END ZCONS; 00163700
00163800
00163900
DEFINE XCONS = ARG1:=ZCONS(ARG1,ARG2)#; 00164000
DECLARE(XNCONS,13,ARG1:=ZCONS(ARG1,NIL)); 00164100
DECLARE(XRCONS,12,ARG1:=ZCONS(ARG2,ARG1)); 00164200
DECLARE(XCAR,82,ARG1:=MCAR[ARG1]); 00164300
DECLARE(XCDR,83,IF ARG1 NEQ NIL THEN %PPDMTL11 00164400
ARG1:=MCDR[ARG1]); %PPDMTL11 00164410
DECLARE(XNULL,84,ARG1:=TRUTH(ARG1=NIL)); 00164500
00164600
00164700
PROCEDURE MLIST(A,B); VALUE A,B; REAL A,B; 00164800
BEGIN LABEL EXIT; 00164900
ARG1:=A; 00165000
ARG1 := ZCONS(A,ZCONS(B,NIL)); 00165100
MICROBUMP(6); 00165200
END MLIST; 00165300
00165400
00165500
PROCEDURE MTMSMTCH(A,B,C); VALUE A,B,C; REAL A,B,C; 00165600
BEGIN LABEL EXIT; 00165700
ARG1:=A; ARG2:=B; ARG3:=C; 00165800
IF NOT BACKOUT THEN YQ01TQ19MSMTCH; 00165900
END MTMSMTCH; 00166000
00166100
DECLARE(XRPLACA,15,MCAR[ARG1]:=ARG2); 00166200
DECLARE(XRPLACD,16,MCDR[ARG1]:=ARG2); 00166300
DECLARE(XPUTPROP,51,MPUTPROP); 00166400
DECLARE(XGETPROP,52,ARG1:=MGETPROP[ARG1]); 00166500
DECLARE(XPUTG,53,MPUTG); 00166600
DECLARE(XGETG,54,ARG1:=MGETG[ARG1]); 00166700
00166800
00166900
REAL PROCEDURE ZGET(A,B); VALUE A,B; REAL A,B; 00167000
BEGIN REAL U,V; 00167100
LABEL EXIT; 00167200
DECLAREANDWEIGH; 00167250
IF MIDP(A) THEN 00167300
BEGIN MICROBUMP(2); 00167400
U:=ISPPROP[A.FIELD]; 00167500
IF U NEQ NIL THEN 00167600
DO BEGIN MICROBUMP(5); 00167700
V:=MCAR[U]; 00167800
IF MPAIRP(V) THEN 00167900
IF MCAR[V] = B THEN 00168000
BEGIN 00168100
ZGET:=MCDR[V]; 00168200
GO TO EXIT; 00168300
END; 00168400
U:=MCDR[U]; 00168500
END UNTIL U=NIL; 00168600
END; 00168700
ZGET:=NIL; 00168800
EXIT: 00168900
MICROBUMP(5); 00169000
PRIMCOUNTER(69); 00169020
END ZGET; 00169100
00169200
DEFINE XGET=ARG1:=ZGET(ARG1,ARG2)#; 00169300
00169400
PROCEDURE XGETD; 00169500
BEGIN REAL W; 00169600
LABEL EXIT; 00169700
DECLAREANDWEIGH; 00169750
IF NOT MIDP(ARG1) THEN 00169800
BEGIN ARG1:=NIL; GO TO EXIT END; 00169900
ARG1 := ISPVALUE[ARG1.FIELD]; 00170000
IF MATOM(ARG1) THEN 00170100
BEGIN 00170200
ARG1 := NIL; 00170300
MICROBUMP(1); 00170400
END 00170500
ELSE 00170600
BEGIN 00170700
MICROBUMP(4); 00170800
W:=MCAR[ARG1]; 00170900
IF GSUBR NEQ W THEN 00171000
IF GFSUBR NEQ W THEN 00171100
IF GEXPR NEQ W THEN 00171200
IF GFEXPR NEQ W THEN 00171300
IF GMACRO NEQ W THEN 00171400
ARG1 := NIL; 00171500
END; 00171600
EXIT: 00171700
MICROBUMP(6); 00171800
PRIMCOUNTER(70); 00171900
END XGETD; 00172000
00172100
00172200
PROCEDURE XPUTD; 00172300
BEGIN REAL I; 00172400
DECLAREANDWEIGH; 00172450
ISPVALUE[ARG1.FIELD] := ARG2; 00172500
I:=ISPPNAME[ARG1.FIELD].QSPPTR-1; 00172600
IF I>=0 THEN 00172700
QSP[I].[46:1]:=1; 00172800
MICROBUMP(6); 00172900
PRIMCOUNTER(76); 00173000
END XPUTD; 00173100
00173110
00173120
PROCEDURE XTIME; 00173130
BEGIN INTEGER I; 00173140
DECLAREANDWEIGH; 00173150
I := (TIME(12)-BEGINTIME)*2.4@-3; % MILLI-SECONDS 00173160
ARG1 := ZTRACT(I); 00173170
MICROBUMP(5); 00173180
PRIMCOUNTER(50); 00173190
END XTIME; 00173210
00173220
REAL PROCEDURE SEARCHFORNAME(A); ARRAY A[0]; 00173300
BEGIN REAL I,J,K; 00173310
POINTER P,Q; 00173320
ARRAY B[0:80]; 00173330
EBCDIC ARRAY S[0:35]; 00173335
LABEL EXIT; 00173340
IF NOT PROCS.PRESENT THEN 00173350
BEGIN SEARCHFORNAME := 8; GO TO EXIT END; 00173360
J := PROCS.LASTRECORD+1; 00173370
P := POINTER(B[12]); 00173380
DO BEGIN K:=(I+J) DIV 2; 00173390
READ(PROCS[K],80,B); 00173400
IF P>A FOR 8 THEN J:=K ELSE I:=K; 00173410
END UNTIL J-I<2; 00173420
READ(PROCS[I],80,B); 00173430
SCAN P:B UNTIL = "P"; 00173440
P := P+10; 00173450
SCAN P:P WHILE = " "; 00173460
IF P="Y" THEN 00173470
BEGIN P:=P+1; I:=72; 00173480
REPLACE Q:A+8 BY " "; 00173490
REPLACE S BY 00173495
"*$!" CAT """ CAT "#%'()=+-<>^\~|@.&?[]/,:;Q"; 00173500
DO BEGIN 00173510
I:=I-1; 00173515
IF P="Q" THEN 00173520
BEGIN 00173530
J:=INTEGER(P+1,2); P:=P+3; 00173540
REPLACE Q:Q BY S[J] FOR 1; 00173550
END 00173560
ELSE REPLACE Q:Q BY P:P FOR 1; 00173570
END UNTIL NOT P IN ALPHA; 00173580
END 00173590
ELSE 00173600
BEGIN 00173610
IF P="X" OR P="Z" OR P="V" THEN 00173620
P:=P+1; 00173630
REPLACE A+8 BY " ", P FOR I:72 WHILE IN ALPHA; 00173640
END; 00173650
SEARCHFORNAME := 82-I; 00173660
EXIT: 00173670
END SEARCHFORNAME; 00173680
00173690
PROCEDURE FAULTPROCESSOR(FA,FN); VALUE FN; REAL FN; ARRAY FA[0]; 00174200
BEGIN 00174300
REAL I,J; 00174400
POINTER P,Q; 00174500
ARRAY FB[0:22]; 00174600
IF FN=4 THEN 00174610
BEGIN 00174620
WRITETTY("INVALID INDEX"); 00174630
WRITETTY("ARG1-4 = " CAT 00174700
CONVERT(ARG1,10) CAT " " CAT 00174800
CONVERT(ARG2,10) CAT " " CAT 00174900
CONVERT(ARG3,10) CAT " " CAT 00175000
CONVERT(ARG4,10)); 00175100
END; 00175110
FA[SIZE(FA)-1] := "()."; 00175200
SCAN P:FA UNTIL = "("; 00175300
WHILE P NEQ "()." DO 00175400
BEGIN 00175500
P := P+1; 00175600
REPLACE FB BY P:P FOR 8; 00175700
I := SEARCHFORNAME(FB); 00175800
WRITETTY(FB FOR I); 00175900
SCAN P:P UNTIL = "("; 00176000
END; 00176100
IF ABS(FN)=4 THEN 00176400
BEGIN %INVALID INDEX 00176500
ISPVALUE[GEMSG.FIELD] := ERRS[IF FN=4 THEN 17 ELSE 14]; 00176600
ARG1:=ERRORID; 00176700
ARG2:=NIL; 00176800
XTHROW; 00176900
END; 00177000
END; 00177100
00177200
PROCEDURE ZCATCH; 00177300
% ARG1 IS REEVALUATED. IF A THROW OCCURS DURING THE EVALUATION, THE 00177400
% VALUE FROM THROW (IN BASKET) IS RETURNED, OTHERWISE A LIST OF THE 00177500
% VALUE OF ARG1 IS RETURNED. 00177600
BEGIN 00177700
ARRAY FA[0:500]; 00177800
REAL FN,K,S; 00177900
LABEL FL; 00178000
INTERRUPT THUD; 00178100
IF CATCHCOUNTER=K THEN 00178200
IF THROWCOUNTER>CATCHER THEN 00178300
BEGIN 00178400
CATCHER := *+1; 00178500
GO TO FL; 00178600
END; 00178700
DECLAREANDWEIGH; 00178710
MICROBUMP(100); 00178720
CHECKSTACK(2); 00178800
ZPUSH(GCATCH); %MARK THE STACK. 00179000
ZPUSH(TSPPTR-1); 00179100
ON INVALIDINDEX[FA:FN], 00179200
BEGIN 00179300
FAULTPROCESSOR(FA,4); 00179400
GO TO FL; 00179500
END; 00179600
ATTACH THUD TO THROW; 00179700
K:=CATCHCOUNTER:=*+1; 00179800
S:=ES; 00179900
STOPCOUNT; 00179910
YEVAL; %SO DO IT. 00180000
STARTCOUNT; 00180010
FL: 00180100
DETACH THUD; 00180200
CATCHCOUNTER:=*-1; 00180300
ES:=S; 00180400
IF BACKOUT THEN BEGIN %AHA! A THROW HAS OCCURRED. 00180500
BACKOUT := FALSE; %THROW IS COMPLETE. 00180600
ARG1 := BASKET; %VALUE TO RETURN. 00180700
END 00180800
ELSE BEGIN %RETURN (VALUE . NIL) 00180900
ARG2 := NIL; 00181000
XCONS; 00181100
END; 00181200
TSPPTR := TSP[TSPPTR-1]; 00181300
PRIMCOUNTER(1); 00181310
END ZCATCH; 00181400
00181500
00181600
DEFINE XCATCH = BEGIN STOPCOUNT; ZCATCH; STARTCOUNT END#; 00181700
00181800
00181900
PROCEDURE ZERROR(NUM, MSG); VALUE NUM,MSG; REAL NUM,MSG; 00182000
% ISOLATE XERROR FROM THE SYSTEM. 00182100
BEGIN LABEL EXIT; 00182200
ARG1 := ZTRACT(NUM); %ERROR NUMBER AS ARG1. 00182300
ARG2 := MSG; 00182400
IF NOT BACKOUT THEN YERROR; 00182500
END ZERROR; 00182600
00182605
PROCEDURE XQUIT; 00182610
BEGIN 00182620
DECLAREANDWEIGH; 00182630
PRIMCOUNTER(23); 00182635
RECENTREAD := ATEND := TRUE; BREAK := FALSE; 00182640
CLOSE(ME); 00182650
ANSWERHI; 00182660
GO TO THU; 00182670
END XQUIT; 00182680
00182700
PROCEDURE XSETPCHAR; 00182800
BEGIN REAL S; 00182900
DECLAREANDWEIGH; 00182950
IF MIDP(ARG1) THEN 00183000
S:=STRINGIZE(ISPPNAME[ARG1.FIELD]) 00183100
ELSE 00183200
IF MSTRINGP(ARG1) THEN 00183300
S:=ARG1 00183400
ELSE 00183500
MTMSMTCH(ARG1,GIDORSTRING,GSETPCHAR); 00183600
ARG1:=ISPVALUE[GPROMPT.FIELD]; 00183700
ISPVALUE[GPROMPT.FIELD] := S; 00183800
MICROBUMP(10); 00183900
PRIMCOUNTER(60); 00184000
END XSETPCHAR; 00184100
00184200
00184300
REAL PROCEDURE ZREADCH(PTR,BFR); 00184400
% PROCEDURE PICKS UP THE NEXT INPUT CHARACTER FROM THE SELECTED 00184500
% INPUT FILE (CUR.CHAN.IN) AT POSITION I. IF I < 0 THEN A NEW LINE 00184600
% IS REQUIRED. IF I > 80 THEN RETURN END-OF-LINE. @(4)00@ MEANS 00184700
% $EOF$ TO READCH, @(4)01@ MEANS $EOL$ TO READCH. 00184800
% IF !*RAISE IS T CHANGE LOWER CASES TO UPPER CASES. IF !*ECHO IS T, 00184900
% THEN DISPLAY THE LINE ON THE CURRENTLY SELECTED INPUT DEVICE. 00185000
REAL PTR; EBCDIC ARRAY BFR[0]; 00185100
BEGIN REAL I,J; 00185200
LABEL EXIT,EOFME,EOFYOU; 00185300
I:=PTR; 00185400
IF I < 0 THEN 00185500
BEGIN 00185600
IF ASKING THEN ANSWERHI; 00185610
IF CURCHANIN = 0 THEN 00185700
BEGIN 00185800
REPLACE COLLECTOR BY ZGETSTRING(ISPVALUE[GPROMPT. 00186000
FIELD]) CAT " "; 00186100
WHILE WRITE(ME[STOP],ZGET2+1,COLLECTOR) DO; 00186200
REPLACE COLLECTOR BY " " FOR 132; 00186300
ATEND := RECENTREAD := TRUE; BREAK := FALSE; 00186400
READ(ME,80,LINER)[EOFME]; 00186500
ATEND:=FALSE; 00186600
IF ASKING THEN 00186700
BEGIN 00186800
EOFME: 00186900
ANSWERHI; 00187000
IF ATEND THEN GO TO THU 00187100
END; 00187200
REPLACE BFR BY LINER FOR INSZE; %MOVE LINE TO INPUT BUFFER. 00187300
END 00187400
ELSE 00187500
BEGIN 00187600
READ(IOFILE[CURCHANIN],INSZE,BFR)[EOFYOU]; 00187700
IF FALSE THEN 00187800
BEGIN %BACK TO ME WHEN END OF FILE. 00187900
EOFYOU: 00188000
CURCHANIN := 0; 00188100
ZREADCH:=0; %RETURN $EOF$. 00188200
I:=-2; 00188300
GO TO EXIT; 00188400
END; 00188500
IF FILEINFO[CURCHANIN]<INSZE THEN 00188600
BEGIN 00188610
J := INTEGER(BFR[FILEINFO[CURCHANIN]],8); 00188620
REPLACE BFR[FILEINFO[CURCHANIN]] BY " " FOR INSZE- 00188700
FILEINFO[CURCHANIN]; 00188800
END 00188810
ELSE 00188820
J := IOHERE[CURCHANIN]+100; 00188830
IOHERE[CURCHANIN] := J; 00188840
IF J>IOSTOP[CURCHANIN] THEN GO TO EOFYOU; 00188850
END; 00188900
IF NOT MNULL(ISPVALUE[GECHO.FIELD]) THEN %ECHO? 00189000
WRITEIOFILE(CURCHANOUT,BFR FOR 00189100
IF CURCHANOUT=0 THEN INSZE ELSE ZEXTEND(ISPVALUE[ 00189200
GLINELENGTH.FIELD])); 00189300
MICROBUMP(30); 00189400
END GETANDECHO; 00189500
00189600
IF I>=INSZE THEN %SHOULD $EOL$ BE RETURNED? 00189700
BEGIN 00189800
I := -2; %FORCE READ NEXT TIME. 00189900
ZREADCH:=1; %1 %RETURN $EOL$. %PPDMTL12 00190000
GO TO EXIT; 00190100
END; 00190200
00190300
IF I<=0 THEN 00190400
BEGIN 00190500
IF NOT MNULL(ISPVALUE[GRAISE.FIELD]) THEN 00190600
FOR I:=0 STEP 6 UNTIL INSZE DO 00190700
REPLACE BFR[I] BY REAL(BOOLEAN(REAL(BFR[I],6)) OR 00190800
BOOLEAN(" ")) FOR 6; 00190900
I:=0; 00191000
END; 00191100
ZREADCH:=REAL(BFR[I],1); 00191200
EXIT: 00191300
PTR:=I+1; 00191400
MICROBUMP(8); 00191500
END ZREADCH; 00191600
00191700
00191800
REAL PROCEDURE ZADDTOSTRINGS(A,L); VALUE A,L; POINTER A; REAL L; 00191900
% PROCEDURE ADDS THE CHARACTER STRING A TO THE STRING AREA BY HASHING ON00192000
% ON THE FIRST TWO CHARACTERS IF LONGER THAN ONE CHARACTER AND THEN 00192100
% DOING A LINEAR SEARCH IN THE HASH BUCKET OR AN OVERFLOW AREA. SINGLE 00192200
% CHARACTER STRINGS STAND FOR THEMSELVES. 00192300
BEGIN LABEL EXIT; 00192400
REAL R,BUCKET,SPTR,LEN,W,WL,WB; 00192500
% SINGLE CHARACTER IDS STAND FOR THEMSELVES. 00192600
IF L = 1 THEN 00192700
BEGIN 00192800
SPTR:=REAL(A,1)*4; 00192900
GO TO EXIT; 00193000
END; 00193100
% COMPUTE THE BUCKET NUMBER ON THE FIRST SIX CHARACTERS OF A. 00193200
R:=REAL(A,MIN(L,6)); 00193300
R:=(R.[47:14]+R.[33:34]+L) MOD SSPHBUCKETS+1; 00193400
%SEARCH ALL BUCKETS UNTIL THE STRING IS FOUND OR THE END OF THE BUCKET00193500
%CHAIN IS REACHED. 00193600
WL:=SSPBSZE; 00193700
FOR BUCKET:=R, SSPHBUCKETS+1 STEP 1 UNTIL SSPBMAX-1 DO 00193800
BEGIN 00193900
MICROBUMP(7); 00194000
SPTR := 0; 00194100
WHILE LEN:=(R:=REAL(SSP[BUCKET,SPTR],3)).[23:8] > 0 DO 00194200
BEGIN 00194300
MICROBUMP(8); 00194400
IF BOOLEAN(R.FREEF) THEN 00194500
BEGIN 00194600
IF L+3<LEN OR LEN=L THEN 00194700
IF WL>LEN THEN 00194800
IF BUCKET<=SSPHBUCKETS OR WL=SSPBSZE THEN 00194900
BEGIN W:=SPTR; WL:=LEN; WB:=BUCKET END; 00195000
END 00195100
ELSE 00195200
IF LEN = L THEN 00195300
IF SSP[BUCKET,SPTR+3]=A FOR L THEN 00195400
GO TO EXIT; 00195500
SPTR:=*+LEN+3; 00195600
END; 00195700
%IF THERE IS ROOM IN THIS BUCKET, THEN THERE IS NO NEED TO SEARCH FURT00195800
%BECAUSE IT WON'T BE THERE. 00195900
MICROBUMP(10); 00196000
IF WL=SSPBSZE THEN 00196100
BEGIN 00196200
IF R-3<L THEN 00196300
BEGIN 00196400
LEN:=SIZE(SSP[BUCKET,*]); 00196500
IF LEN<SSPBSZE THEN 00196600
BEGIN 00196700
RESIZE(SSP[BUCKET,*],2*LEN,RETAIN); 00196800
R:=R+LEN; 00196900
IF 2*LEN >= SSPBSZE THEN NEWSCNT1 := *+1; 00197000
END; 00197100
END; 00197200
IF L+3<=R THEN 00197300
BEGIN 00197400
REPLACE SSP[BUCKET,SPTR] BY L.SHIFTUP FOR 1, 00197500
BRANDNEW.[15:48] FOR 2, 00197600
A FOR L, (R-L-3).[23:48] FOR 3; 00197700
IF NEWSCNT1>0 THEN NEWSCNT1 := *+1; 00197800
GO TO EXIT; 00197900
END; 00198000
END 00198100
ELSE 00198200
BEGIN 00198300
REPLACE SSP[WB,W] BY L.SHIFTUP FOR 1, 00198400
BRANDNEW.[15:48] FOR 2, A FOR L; 00198500
IF WL>L THEN 00198600
REPLACE SSP[WB,W+3+L] BY (0&1 FREEF & (WL-L-3)[23:8]). 00198700
[23:48] FOR 3; 00198800
SPTR:=W; BUCKET:=WB; 00198900
GO TO EXIT; 00199000
END; 00199100
%TRY SEARCH ANOTHER BUCKET. 00199200
END; 00199300
ERRSTOP("STRING SPACE JAM"); 00199400
EXIT: 00199500
ZADDTOSTRINGS := SPTR & BUCKET BUCKF & STRINGTAG TAG; 00199600
MICROBUMP(9); 00199700
END ZADDTOSTRINGS; 00199800
00199900
00200000
REAL PROCEDURE ZGETSTRINGPROC(A); VALUE A; REAL A; 00200100
% RETURN THE STRING ASSOCIATED WITH A. STOP IF A NOT A STRING PTR. 00200200
BEGIN 00200300
REAL BNO,SPTR,L; 00200400
IF NOT MSTRINGP(A) THEN 00200500
ERRSTOP("NON-STRING --> " CAT CONVERT(A,FOUR)); 00200600
BNO:=A.BUCKF; 00200700
ZGETSTRINGPROC:=BNO; 00200800
SPTR:=A.SLOCF; 00200900
ZGET2:=REAL(SSP[BNO,SPTR],1); 00201000
ZGET1:=SPTR+3; 00201100
MICROBUMP(8); 00201200
END ZGETSTRINGPROC; 00201300
00201400
00201500
REAL PROCEDURE ZIDSPACE; 00201600
% PROCEDURE RETURNS THE NEXT FREE SLOT IN THE IDENTIFIER SPACE. 00201700
BEGIN LABEL EXIT; 00201800
IF ISPFREE=ISPMAX+1 THEN 00201900
ZGARBAGE(1); 00202000
IF ISPFREE>ISPHIGH THEN ISPHIGH:=ISPFREE; 00202100
ISPFREE:=ISPVALUE[ZIDSPACE:=ISPFREE].FIELD; 00202200
MICROBUMP(6); 00202300
END ZIDSPACE; 00202400
00202500
00202600
PROCEDURE XINTERN; 00202700
% SEARCHES THE OBLIST FOR AN OCCURRENCE OF AN IDENTIFIER WITH 00202800
% PRINT NAME OF ARG1 AND RETURNS THAT ID IF FOUND, OR CREATES 00202900
% A NEW ONE IF NOT. 00203000
BEGIN REAL TPTR,U,S,I,J; 00203100
LABEL FOUND,THERE,NOTTHERE; 00203200
DECLAREANDWEIGH; 00203250
IF MIDP(ARG1) THEN 00203300
U:=STRINGIZE(ISPPNAME[ARG1.FIELD]) 00203400
ELSE 00203500
IF MSTRINGP(ARG1) THEN 00203600
U:=ARG1 00203700
ELSE 00203800
MTMSMTCH(ARG1,GIDORSTRING,GINTERN); 00203900
MINTERNED(U) := TRUE; 00204000
S:=REAL(SSP[U.BUCKF,U.SLOCF+1],2); 00204100
IF S=BRANDNEW THEN GO TO NOTTHERE; 00204200
IF ISPPNAME[S].IDCELL=U.IDCELL THEN 00204300
GO THERE; 00204400
S := MAXFIELDV; 00204500
MINTERNED(S) := TRUE; 00204600
MICROBUMP(3); 00204700
FOR I:=0 STEP 128 UNTIL ISPHIGH DO 00204800
BEGIN MICROBUMP(30); 00204900
J:=ISPPNAME[I]; 00205000
IF I>0 THEN 00205100
ISPPNAME[I]:=U; 00205200
TPTR:=MASKSEARCH(U,S,ISPPNAME[MIN(I+128,ISPHIGH)]); 00205300
ISPPNAME[I]:=J; 00205400
IF TPTR>I OR TPTR=0 THEN 00205500
BEGIN 00205600
S:=TPTR; 00205700
GO TO FOUND; 00205800
END; 00205900
END; 00206000
NOTTHERE: 00206100
IF MSTRINGP(ARG1) THEN 00206200
ISPPNAME[S := ZIDSPACE] := ARG1 %SAVE THE PRINT NAME. 00206300
ELSE 00206400
S:=ARG1.FIELD; 00206500
ISPPNAME[S].TAG := 0; 00206600
MINTERNED(ISPPNAME[S]):=TRUE; 00206700
ISPPROP[S] := NIL; %EMTPY SO FAR. 00206800
ISPVALUE[S] := UNBOUND; 00206900
MICROBUMP(6); 00207000
FOUND: 00207100
REPLACE SSP[U.BUCKF,U.SLOCF+1] BY S.[15:48] FOR 2; 00207200
MICROBUMP(2); 00207300
THERE: 00207400
ARG1.TAG := IDTAG; %BUILD A NEW ENTRY TO RETURN AND PLACE 00207500
ARG1.FIELD := S; 00207600
MICROBUMP(11); 00207700
PRIMCOUNTER(20); 00207800
END XINTERN; 00207900
00208000
00208100
PROCEDURE CHRINTERN(CHR); VALUE CHR; REAL CHR; 00208200
BEGIN REAL R,S; 00208300
LABEL EXIT; 00208400
MICROBUMP(8); 00208500
S:=ZADDTOCHRS(CHR); 00208600
MINTERNED(S) := TRUE; 00208700
R := REAL(SSP[0,S.SLOCF+1],2); 00208800
IF R<BRANDNEW THEN 00208900
IF ISPPNAME[R].IDCELL = S.IDCELL THEN 00209000
BEGIN 00209100
MICROBUMP(2); 00209200
ARG1 := R&IDTAG TAG; 00209300
GO TO EXIT; 00209400
END; 00209500
ARG1 := S&STRINGTAG TAG;; 00209600
XINTERN; 00209700
EXIT: 00209800
END CHRINTERN; 00209900
00210000
00210100
PROCEDURE XREMOB; 00210200
% TYPE MISMATCH ERROR IF NOT AN ID. TURN OFF THE INTERN FLAG IF 00210300
% IT IS ON AND AN ID. 00210400
BEGIN LABEL EXIT; 00210500
DECLAREANDWEIGH; 00210550
IF NOT MIDP(ARG1) THEN 00210600
MTMSMTCH(ARG1, GID, GREMOB); 00210700
MINTERNED(ISPPNAME[ARG1.FIELD]) := FALSE; 00210800
MICROBUMP(5); 00211000
PRIMCOUNTER(11); 00211050
END XREMOB; 00211100
00211200
00211300
PROCEDURE XGLOBAL; 00211400
BEGIN REAL P; 00211500
DECLAREANDWEIGH; 00211550
WHILE MPAIRP(ARG1) DO 00211600
BEGIN 00211700
P:=MCAR[ARG1]; 00211800
IF NOT MIDP(P) THEN 00211900
MTMSMTCH(P,GID,GGLOBAL); 00212000
IF MFLUIDP(P) THEN 00212100
BEGIN 00212200
MLIST(P,ERRS[15]); 00212300
ZERROR(115,ARG1); 00212400
END; 00212500
MGLOBALP(P):=TRUE; 00212600
IF ISPVALUE[P.FIELD] = UNBOUND THEN 00212700
ISPVALUE[P.FIELD] := NIL; 00212800
ARG1 := MCDR[ARG1]; 00212900
MICROBUMP(8); 00213000
END; 00213100
ARG1 := NIL; 00213200
MICROBUMP(5); 00213300
PRIMCOUNTER(73); 00213400
END XGLOBAL; 00213500
00213600
00213700
PROCEDURE XFLUID; 00213800
BEGIN REAL P; 00213900
DECLAREANDWEIGH; 00213950
WHILE MPAIRP(ARG1) DO 00214000
BEGIN 00214100
P:=MCAR[ARG1]; 00214200
IF NOT MIDP(P) THEN 00214300
MTMSMTCH(P,GID,GFLUID); 00214400
IF MGLOBALP(P) THEN 00214500
BEGIN 00214600
MLIST(P,ERRS[16]); 00214700
ZERROR(116,ARG1); 00214800
END; 00214900
MFLUIDP(P) := TRUE; 00215000
IF ISPVALUE[P.FIELD] = UNBOUND THEN 00215100
ISPVALUE[P.FIELD] := NIL; 00215200
ARG1:=MCDR[ARG1]; 00215300
MICROBUMP(8); 00215400
END; 00215500
ARG1:=NIL; 00215600
MICROBUMP(5); 00215700
PRIMCOUNTER(74); 00215800
END XFLUID; 00215900
00216000
00216100
PROCEDURE XUNFLUID; 00216200
BEGIN REAL P; 00216300
DECLAREANDWEIGH; 00216350
WHILE MPAIRP(ARG1) DO 00216400
BEGIN 00216500
P:=MCAR[ARG1]; 00216600
IF NOT MIDP(P) THEN 00216700
MTMSMTCH(P,GID,GUNFLUID); 00216800
MFLUIDP(P) := FALSE; 00216900
ARG1:=MCDR[ARG1]; 00217000
MICROBUMP(5); 00217100
END; 00217200
ARG1:=NIL; 00217300
MICROBUMP(5); 00217400
PRIMCOUNTER(75); 00217500
END XUNFLUID; 00217600
00217700
00217800
EBCDIC ARRAY ZRATOMARRAY[0:80]; 00217900
PROCEDURE ZRATOM(PTR,BFR,SZE); 00218000
% PROCEDURE READS THE NEXT ATOM FROM THE INPUT STRING AND RETURNS 00218100
% AS FOLLOWS: 00218200
% 0 - IDENTIFIER, ARG1 = POINTER TO ITS STRING. 00218300
% 1 - STRING, ARG1 = POINTER TO ITS STRING. 00218400
% 2 - INTEGER, ARG1 = INTEGER VALUE AND TAG. 00218500
% 3 - CHARACTER, ARG1 = SINGLE CHARACTER. 00218600
% 4 - $EOF$. 00218700
% 5 - FUNCTION-POINTER. ARG1 = VALUE AND TAG. 00218800
VALUE SZE; REAL PTR,SZE; EBCDIC ARRAY BFR[0]; 00218900
BEGIN REAL I,J,CHR,R,S; 00219000
LABEL SINGLE; 00219100
DEFINE IDS=ZRATOMARRAY#,STRNGS=ZRATOMARRAY#; 00219200
DECLAREANDWEIGH; 00219250
00219300
% SKIP TO THE FIRST NON-BLANK CHARACTER. 00219400
R:=PTR; 00219500
DO BEGIN 00219600
IF R<=0 OR R>=SZE THEN 00219700
DO UNTIL CHR:=ZREADCH(R,BFR) NEQ 1 00219800
ELSE 00219900
BEGIN 00220000
CHR:=REAL(BFR[R],1); 00220100
IF CHR=" " THEN 00220200
BEGIN 00220300
MICROBUMP(10); 00220400
SCAN BFR[R] FOR S:SZE-R WHILE = " "; 00220500
R:=SZE-S; 00220600
IF R<SZE THEN 00220700
CHR:=REAL(BFR[R],1); 00220800
END; 00220900
R:=R+1; 00221000
END; 00221100
MICROBUMP(5); 00221200
END UNTIL CHR NEQ " "; 00221300
00221400
IF CHR = 0 THEN ARG1:=4 ELSE %$EOF$ HERE. 00221500
00221600
% IF WE HAVE AN IDENTIFER POSSIBLE HERE, THEN READ UP TO 24 CHARACTERS 00221700
% INTO IDS AND PUT INTO STRING TABLE. 00221800
IF CHR IN LETTERSNBANG THEN 00221900
BEGIN 00222000
R:=R-1; 00222100
DO BEGIN 00222200
MICROBUMP(13); 00222300
IF CHR="!" THEN 00222400
BEGIN 00222500
MICROBUMP(4); 00222600
REPLACE IDS[I] BY BFR[R+1] FOR 1; 00222700
I:=I+1; R:=R+2; 00222800
END; 00222900
S:=SZE-R; 00223000
REPLACE IDS[I] BY BFR[R] FOR J:S WHILE IN LETTERSNDIGITS; 00223100
I:=S-J+I; R:=SZE-J; 00223200
CHR:=REAL(BFR[R],1); 00223300
END UNTIL NOT (CHR IN IDCHARACTERS); 00223400
J := ZADDTOSTRINGS(IDS,MIN(I,24)); %RETURN A STRING PTR. 00223500
IF I > 24 THEN %PPDMTL02 00223550
WRITETTY ("Truncated to 24 characters"); %PPDMTL02 00223560
ARG1 := 0; 00223600
MICROBUMP(6); 00223700
END FORMID ELSE 00223800
00223900
% IF A NUMBER, COLLECT THE DIGITS, COMPRESS AND RETURN THE PROPER 00224000
% TAG WITH INTEGER VALUE TRUNCATED TO 16 BITS. 00224100
IF CHR IN DIGITSNSIGN THEN 00224200
BEGIN 00224300
S:=1; 00224400
IF CHR="-" OR CHR="+" THEN 00224500
BEGIN 00224600
IF ARG1 NEQ NIL THEN GO TO SINGLE; 00224700
IF CHR="-" THEN S:=-1; 00224800
CHR:=ZREADCH(R,BFR); 00224900
IF NOT ZDIGIT(CHR) THEN 00225000
BEGIN 00225100
R:=*-1; 00225200
CHR:=IF S=1 THEN "+" ELSE "-"; 00225300
GO TO SINGLE; 00225400
END; 00225500
END; 00225600
SCAN BFR[R] FOR I:SZE-R WHILE >= "0"; 00225700
R:=R-1; I:=-R-I+SZE; 00225800
IF I>DZ THEN 00225810
BEGIN REAL L,Z; Z:=NIL; 00225820
J:=R+I-DZ; 00225830
WHILE J>=R DO 00225840
BEGIN 00225850
Z:=ZCONS(ZTRACT(INTEGER(BFR[J],DZ)),Z); L:=L+1; J:=J-DZ; 00225860
END; 00225870
IF R-J<DZ THEN 00225880
BEGIN 00225890
Z:=ZCONS(ZTRACT(INTEGER(BFR[R],DZ-R+J)),Z); L:=L+1; 00225900
END; 00225910
J:=NORMALIZE(L,S,Z); 00225920
END 00225930
ELSE 00225940
J:=ZTRACT(INTEGER(BFR[R],I)*S); 00225950
ARG1:=2; 00225955
R:=R+I; 00225960
IF BFR[R]="." THEN 00225970
IF BFR[R+1]>="0" THEN 00225980
BEGIN R:=R+1; 00225990
SCAN BFR[R] FOR I:SZE-R WHILE >= "0"; 00226000
R:=SZE-I; 00226010
J:=GFLOATING; 00226020
ARG1:=1; 00226030
END; 00226040
MICROBUMP(20); 00226300
END FORMINTEGER ELSE 00226400
00226500
% IF A STRING, THEN GET ALL THE CHARACTERS. 00226600
IF CHR = """ THEN 00226700
BEGIN %GET THE FIRST 80 CHARACTERS OF THE STRING. 00226800
I:=0; 00226810
DO BEGIN 00226820
MICROBUMP(22); 00226830
REPLACE STRNGS[I] BY BFR[R] FOR S:SZE-R UNTIL = """; 00226900
I:=I+SZE-R-S; 00227000
R:=SZE-S+1; 00227010
IF S>0 THEN 00227020
IF BFR[R]=""" THEN 00227100
BEGIN 00227110
REPLACE STRNGS[I] BY """; 00227120
I:=I+1; 00227130
R:=R+1; 00227140
S:=-1; 00227145
MICROBUMP(10); 00227147
END 00227150
END UNTIL S>=0; 00227160
J:=ZADDTOSTRINGS(STRNGS,MIN(I,SZE)); 00227200
ARG1 := 1; 00227300
MICROBUMP(7); 00227400
END FORMSTRING ELSE 00227500
00227600
IF CHR = "#" THEN 00227700
BEGIN %BUILD A FUNCTION POINTER. 00227800
IF ARG1 NEQ NIL THEN GO TO SINGLE; 00227900
FOR I:=15 STEP -4 UNTIL 3 DO 00228000
J.[I:4] := IF CHR:=ZREADCH(R,BFR)<"0" THEN CHR+9 ELSE CHR; 00228100
J.TAG := FUNCTTAG; 00228200
ARG1 := 5; 00228300
MICROBUMP(30); 00228400
END FORMFNPTR ELSE 00228500
00228600
%ANYTHING ELSE RETURN AS 3, A SINGLE CHARACTER. 00228700
BEGIN 00228800
SINGLE: 00228900
MICROBUMP(6); 00229000
J := ZADDTOCHRS(CHR); 00229100
ARG1 := 3; 00229200
END; 00229300
00229400
PTR:=R; 00229500
ISPVALUE[GSCNVAL.FIELD] := J; 00229600
ARG1 := ZTRACT(ARG1); 00229700
MICROBUMP(8); 00229800
PRIMCOUNTER(35); 00229810
END ZRATOM; 00229900
00230000
00230100
DEFINE XSCAN = ZRATOM(INPTR,LINER,INSZE)#; 00230200
00230300
%SEGMENT(OUTPUT); 00230400
00230500
00230600
EBCDIC ARRAY ZPATOMARRAY[0:179]; 00230700
00230710
PROCEDURE ZPATOM(LL, ESC, OUTER); 00230800
% PROCEDURE DUMPS A SINGLE ATOM TO THE OUTPUT LINE BFR AT LOCATION 00230900
% PTR. LL IS THE MAXIMUM LENGTH OF THE LINE. 00231000
% IF ESC IS TRUE, PRINT ATOM WITH SPECIAL ESCAPE CHARACTERS. 00231100
VALUE LL,ESC; REAL LL; BOOLEAN ESC; 00231200
EBCDIC ARRAY OUTER[0]; 00231210
BEGIN REAL PP,PR,PL,CH; 00231300
POINTER P,Q; 00231400
DEFINE ATOM = ARG1#; 00231500
DEFINE BFR = OUTER#; 00231600
DEFINE PTR = OUTPTR#; 00231700
DEFINE TMP=ZPATOMARRAY#; 00231800
DECLAREANDWEIGH; 00231850
IF LL=0 THEN LL:=ZEXTEND(ISPVALUE[GLINELENGTH.FIELD]); 00231900
IF MSTRINGP(ATOM) THEN %DUMP A STRING. 00232000
BEGIN 00232100
PP := STRINGLENGTH(ATOM); 00232200
IF ESC THEN 00232210
BEGIN 00232220
REPLACE TMP[PP+1] BY ZGETSTRING(ATOM); 00232230
PR := PP+1; PL := PR+PP; PP := PR; 00232240
DO BEGIN 00232250
SCAN TMP[PR] FOR CH:PL-PR UNTIL = """; 00232260
MICROBUMP(PL-PR-CH+6); 00232270
IF CH>0 THEN 00232280
BEGIN 00232290
PP := PP-1; PR := PL-CH; 00232300
REPLACE TMP[PP] BY TMP[PP+1] FOR PR-PP CAT """; 00232310
PR := PR+1; 00232330
END; 00232340
MICROBUMP(8); 00232350
END UNTIL CH=0; 00232360
PP := PP-1; REPLACE TMP[PP] BY """; 00232370
REPLACE TMP[PL] BY """; 00232380
ZDMPATOM(TMP[PP] FOR PL+1-PP,PL+1-PP); 00232390
MICROBUMP(18); 00232400
END 00232410
00232420
ELSE 00232500
BEGIN 00232510
ZDMPATOM(ZGETSTRING(ATOM), PP); 00232600
MICROBUMP(4); 00232700
END; 00232710
END 00232800
ELSE IF MCODEP(ATOM) THEN %DUMP A FUNCTION POINTER. 00232900
ZDMPATOM("#" CAT CONVERT(ATOM.FIELD,4), 5) 00233000
ELSE IF SMALLP(ATOM) THEN %DUMP AN INTEGER. 00233100
BEGIN 00233200
CH := ZEXTEND(ATOM); 00233300
REPLACE TMP BY CH FOR 12 DIGITS; 00233400
SCAN TMP FOR PP:11 WHILE = "0"; 00233500
PP:=PP+1; PR:=12-PP; 00233600
IF CH<0 THEN 00233700
BEGIN 00233800
PP := PP+1; PR := PR-1; 00233900
REPLACE TMP[PR] BY "-"; 00234000
END; 00234100
ZDMPATOM(TMP[PR] FOR PP,PP); 00234200
MICROBUMP(15); 00234300
END 00234400
ELSE IF MIDP(ATOM) THEN %DUMP A PRINT NAME. 00234500
BEGIN 00234600
CH := STRINGIZE(ISPPNAME[ATOM.FIELD]); 00234700
IF NOT ESC THEN 00234800
BEGIN 00234900
MICROBUMP(9); 00235000
PP := STRINGLENGTH(CH); 00235100
ZDMPATOM(ZGETSTRING(CH),PP) 00235200
END 00235300
ELSE BEGIN 00235400
MICROBUMP(18); 00235500
REPLACE TMP BY ZGETSTRING(CH); 00235600
PL:=PP:=ZGET2; 00235700
P:=TMP[0]; Q:=TMP[PL]; 00235800
WHILE PP>0 DO 00235900
BEGIN 00236000
MICROBUMP(10); 00236100
REPLACE Q:Q BY P:P FOR PP:PP WHILE IN LETTERSNDIGITS; 00236200
IF PP>0 THEN 00236300
BEGIN 00236400
PR:=PR+1; 00236500
REPLACE Q:Q BY "!", P:P FOR 1; 00236600
PP:=PP-1; 00236700
END; 00236800
END; 00236900
PP:=PL+PR; 00237000
ZDMPATOM(TMP[PL] FOR PP,PP); 00237100
END 00237110
END 00237120
ELSE IF BIGP(ATOM) THEN %DUMP AN INTEGER. 00237130
BEGIN 00237140
CH := ZEXTEND(MCAR[MCDR[ATOM:=ATOM.FIELD]]); 00237150
REPLACE TMP BY CH FOR 12 DIGITS; 00237160
SCAN TMP FOR PP:11 WHILE = "0"; 00237170
PP:=PP+1; PR:=12-PP; 00237180
IF MCAR[ATOM]<ZERO THEN 00237190
BEGIN 00237200
PP := PP+1; PR := PR-1; 00237210
REPLACE TMP[PR] BY "-"; 00237220
END; 00237230
ATOM:=MCDR[MCDR[ATOM]]; 00237240
DO BEGIN MICROBUMP(8); 00237250
CH:=ZEXTEND(MCAR[ATOM]); 00237260
REPLACE TMP[PP+PR] BY CH FOR DZ DIGITS; 00237270
PP:=PP+DZ; 00237280
IF PP>LL THEN 00237290
BEGIN 00237300
ZDMPATOM(TMP[PR] FOR LL,LL); 00237310
REPLACE TMP[0] BY TMP[PR+LL] FOR PP-LL; 00237320
PR:=0; PP:=PP-LL; 00237330
MICROBUMP(7); 00237340
END; 00237350
ATOM:=MCDR[ATOM]; 00237360
END UNTIL ATOM=NIL; 00237370
ZDMPATOM(TMP[PR] FOR PP,PP); 00237380
MICROBUMP(17); 00237390
END; 00237395
MICROBUMP(4); 00237500
PRIMCOUNTER(25-REAL(ESC)); 00237550
END ZPATOM; 00237600
00237700
00237800
DEFINE XPATOM = ZPATOM(0,TRUE,OUTER)#; 00237900
DEFINE XPATOM2 = ZPATOM(0,FALSE,OUTER)#; 00238000
00238100
00238200
PROCEDURE XGENSYM; 00238300
% ADDS A GENSYM TO THE SYMBOL TABLE AND THE STRING SPACE. 00238400
% GGENSYM IS THE NUMBER WHICH KEEPS GETTING ADDED. 00238500
BEGIN LABEL EXIT; 00238600
DECLAREANDWEIGH; 00238650
ARG1 := ZIDSPACE; 00238700
REPLACE CONVERTPTR BY "G" CAT DECIMAL(GGENSYM,5); 00238800
ISPPNAME[ARG1] := ZADDTOSTRINGS(CONVERTPTR,6)&0 TAG; 00238900
ISPPROP[ARG1] := ISPVALUE[ARG1] := NIL; 00239000
ARG1.TAG := IDTAG; 00239100
GGENSYM:=*+1; %MOVE TO NEXT GENSYM PLEASE. 00239200
MICROBUMP(13); 00239400
PRIMCOUNTER(3); 00239450
END XGENSYM; 00239500
00239600
00239700
PROCEDURE XREADCH; 00239800
% PROCEDURE PICKS UP NEXT CHARACTER FROM BUFFER. IF CHARACTER IS 00239900
% 0 THEN RETURN $EOF$, IF 1 THEN RETURN $EOL$. 00240000
BEGIN REAL CHR; 00240100
DECLAREANDWEIGH; 00240150
IF INPTR>0 AND INPTR<INSZE THEN 00240200
BEGIN 00240300
CHRINTERN(REAL(LINER[INPTR],1)); 00240400
INPTR := INPTR+1; 00240500
END 00240600
ELSE 00240700
IF (CHR := ZREADCH(INPTR, LINER)) <= 1 THEN %PICK UP A CHARACTER 00240800
IF CHR = 0 THEN %RETURN $EOF$. 00240900
ARG1 := GEOF 00241000
ELSE 00241100
ARG1 := GEOL %RETURN $EOL$. 00241200
ELSE 00241300
CHRINTERN(CHR); 00241400
MICROBUMP(8); 00241500
PRIMCOUNTER(21); 00241600
END XREADCH; 00241700
00241800
00241900
PROCEDURE XTERPRI; 00242000
% TERMINATES THE PRINT LINE AND DUMPS TO THE SELECTED FILE. 00242100
BEGIN LABEL EXIT; 00242200
DECLAREANDWEIGH; 00242250
WRITEIOFILE(CURCHANOUT,OUTER FOR OUTPTR); 00242300
OUTPTR:=0; 00242400
MICROBUMP(45); 00242500
PRIMCOUNTER(17); 00242600
END XTERPRI; 00242700
00242800
00242900
PROCEDURE XPRINC; 00243000
% A TYPE MISMATCH ERROR IF ARGUMENT IS NOT AN ID. PRINT THE FIRST 00243100
% CHARACTER OF IT IF IT IS. 00243200
BEGIN LABEL EXIT; 00243300
DECLAREANDWEIGH; 00243350
IF NOT MIDP(ARG1) THEN %TYPE MISMATCH ERROR. 00243400
MTMSMTCH(ARG1, GID, GPRINC) ELSE 00243500
BEGIN STOPCOUNT; 00243510
IF ARG1 = GEOL THEN XTERPRI %DO A TERPRI() IF ARGUMENT IS $EOL$. 00243600
ELSE XPATOM; %OTHERWISE PRINT THE ATOM. 00243700
STARTCOUNT END; 00243710
MICROBUMP(5); 00243800
PRIMCOUNTER(18); 00243900
END XPRINC; 00244000
00244100
00244200
PROCEDURE XCLOSE; 00244300
% CLOSE THE FILE WHOSE NUMBER IS GIVEN. DO NOT CLOSE DATA COMM 00244400
% I/O AS THIS WILL CAUSE TROUBLE. 00244500
BEGIN REAL TARG1; 00244600
DECLAREANDWEIGH; 00244610
MICROBUMP(20000); 00244620
TARG1 := ZEXTEND(ARG1); 00244700
IF TARG1 > FMAX OR TARG1 < 0 THEN %YEECH, BAD CHANNEL NUMBER. 00244800
BEGIN 00244900
MLIST(ARG1, ERRS[3]); 00245000
ZERROR(103, ARG1); 00245100
END 00245200
ELSE 00245300
IF TARG1>0 THEN 00245400
IF FILEINUSE[TARG1] THEN 00245500
BEGIN 00245600
IF FILEINPUT[TARG1] THEN 00245700
CLOSE(IOFILE[TARG1]) 00245800
ELSE 00245900
CLOSE (IOFILE[TARG1], CRUNCH); %PPDMTL06 00246000
FILEINUSE[TARG1]:=FALSE; 00246100
FILEINPUT[TARG1]:=FALSE; 00246200
END; 00246300
PRIMCOUNTER(38); 00246400
END XCLOSE; 00246500
00246600
00246700
PROCEDURE XEJECT; 00246800
% SKIP TO TOP OF PAGE ON SOME FILE. 00246900
BEGIN LABEL EXIT; 00247000
DECLAREANDWEIGH; 00247010
MICROBUMP(50); 00247020
IF CURCHANOUT = 0 THEN WRITETTY(4"0C") ELSE 00247100
IF CURCHANOUT = 2 THEN WRITE(LINE[SKIP 1]) ELSE 00247110
WRITE(IOFILE[CURCHANOUT]); % ??? PAGE (" "); 00247200
ARG1 := NIL; 00247210
PRIMCOUNTER(39); 00247300
END XEJECT; 00247400
00247500
00247600
PROCEDURE ZERR(A,S); VALUE A,S; REAL A,S; 00247700
% INTERNAL PROCEDURE FOR HANDLING ERROR 12. 00247800
BEGIN REAL TARG1; 00247900
TARG1 := ARG1; 00248000
ARG1:=A; 00248100
ARG2:=TARG1; 00248200
MLIST(ERRS[S], ARG1); 00248300
ARG1:=ZCONS(ARG2,ARG1); 00248400
ZERROR(105, ARG1); 00248500
END ZERR; 00248600
00248700
00248800
PROCEDURE XOPEN; 00248900
% ARG1 IS A LIST OF 1 -> 3 STRINGS WHICH FORM THE NAME OF THE FILE 00249000
% TO OPEN. ARG2 MUST BE EITHER INPUT OR OUTPUT. THE SELECTED CHANNEL 00249100
% NUMBER WHICH IS A POINTER TO IOFILE IS RETURNED. 00249200
BEGIN REAL TMP,TARG1,PTR,START,STOP,I,J,K,V; 00249300
EBCDIC ARRAY FID[0:119]; 00249400
POINTER P; 00249500
LABEL EXIT; 00249600
DECLAREANDWEIGH; 00249700
MICROBUMP(20000); 00249710
REPLACE FID BY 0 FOR 20 WORDS; 00249800
START := STOP := -1; 00249810
TARG1 := ARG1; 00249820
IF MPAIRP(TARG1) THEN 00249830
BEGIN 00249840
TMP := MCDR[ARG1]; TARG1 := MCAR[ARG1]; 00249850
WHILE START<0 DO 00249860
BEGIN 00249870
START := STOP; 00249880
IF MATOM(TMP) THEN 00249890
MTMSMTCH(TMP,GINTEGER,GOPEN); 00249900
STOP := MCAR[TMP]; 00249910
IF NOT SMALLP(STOP) THEN 00249920
MTMSMTCH(STOP,GINTEGER,GOPEN); 00249930
STOP := ZEXTEND(STOP); 00249935
TMP := MCDR[TMP]; 00249940
END; 00249950
END 00249960
ELSE 00249970
BEGIN 00249980
STOP := 100000000; 00249990
START := 0; 00250000
END; 00250010
IF MIDP(TARG1) THEN 00250020
IF TARG1 NEQ NIL THEN 00250100
TARG1 := STRINGIZE(ISPPNAME[TARG1.FIELD]); 00250200
IF MSTRINGP(TARG1) THEN 00250300
REPLACE FID BY ZGETSTRING(TARG1) CAT "." 00250400
ELSE 00250500
MTMSMTCH(TARG1,GIDORSTRING,GOPEN); 00250600
SCAN P:FID UNTIL = 0; 00250700
REPLACE P BY "."; 00250800
00250900
% ERROR IF NOT INPUT OR OUTPUT REQUESTED. 00251000
IF ARG2 NEQ GINPUT AND ARG2 NEQ GOUTPUT THEN 00251100
BEGIN 00251200
MLIST(ARG2, ERRS[6]); 00251300
ZERROR(106, ARG1); 00251400
END; 00251600
00251700
% SELECT CARDS AND PRINTER SPECIALLY. OTHERS, SEARCH THE FILE LIST. 00251800
PTR := IF FID = "CARDS." THEN 1 00252000
ELSE IF FID = "PRINTER." THEN 2 ELSE 3; 00252100
IF PTR = 3 THEN %FILES OTHER THAN CARDS/PRINTER. 00252200
BEGIN 00252300
WHILE FILEINUSE[PTR] DO 00252400
BEGIN 00252500
PTR:=PTR+1; 00252600
IF PTR > FMAX THEN %ERROR, NO UNUSED FILES. 00252700
BEGIN 00252800
MLIST(TARG1, ERRS[4]); 00252900
ZERROR(104, ARG1); 00253000
END; 00253200
END; 00253300
REPLACE IOFILE[PTR].TITLE BY FID; 00253400
END; 00253500
00253600
% IF AN INPUT FILE, OPEN IT (UNLESS AN ERROR), SET FLAGS AND POINTERS 00253700
% AND RETURN THE CHANNEL NUMBER. 00253800
IF ARG2 = GINPUT THEN 00253900
BEGIN 00254000
IF PTR = 2 THEN %PPDMTL08 00254010
BEGIN %PPDMTL08 00254020
MLIST (TARG1, ERRS[4]); %PPDMTL08 00254030
ZERROR (104, ARG1); %PPDMTL08 00254040
END %PPDMTL08 00254050
ELSE BEGIN %PPDMTL08 00254060
IOFILE[PTR](AREASIZE=0,AREAS=0,FILETYPE=8); 00254100
IF NOT IOFILE[PTR].PRESENT THEN 00254200
BEGIN 00254300
MLIST(TARG1, ERRS[3]); 00254400
ZERROR(103,ARG1); 00254500
END 00254600
ELSE 00254700
BEGIN 00254800
ARG1 := ZTRACT(PTR); 00254900
FILEINPUT[PTR]:=TRUE; 00255000
TMP := IOFILE[PTR].FILEKIND; 00255100
IF TMP >= 32 AND TMP <= 63 THEN %PPDMTL04 00255110
BEGIN %PPDMTL04 00255120
MLIST (TARG1, ERRS[4]); %PPDMTL04 00255130
ZERROR (104, ARG1); %PPDMTL04 00255140
END; %PPDMTL04 00255150
TMP := IF TMP=VALUE(ALGOLSYMBOL) OR TMP=VALUE(SEQDATA) THEN 72 ELSE 00255200
IF TMP=VALUE(DATA) OR TMP=VALUE(CDATA) THEN 80 ELSE 80; 00255300
FILEINFO[PTR] := TMP; 00255400
IOHERE[PTR] := START; IOSTOP[PTR] := STOP; 00255410
IF STOP < 100000000 THEN 00255420
BEGIN 00255430
IF TMP=80 THEN 00255440
BEGIN IOHERE[PTR]:=*-100; 00255442
J := (START+99) DIV 100 - 1 00255450
END 00255455
ELSE 00255460
BEGIN 00255470
P := FID[72]; 00255475
I := -1; J := IOFILE[PTR].LASTRECORD; 00255480
WHILE J-I>1 DO 00255490
BEGIN 00255500
K := (I+J).[38:38]; 00255510
READ(IOFILE[PTR][K],14,FID); 00255520
V := INTEGER(P,8); 00255530
IF V=START THEN I:=K; 00255540
IF V<START THEN I:=K ELSE J:=K; 00255550
END; 00255560
END; 00255570
IF J<=0 THEN 00255572
REWIND(IOFILE[PTR]) 00255574
ELSE 00255576
READ(IOFILE[PTR][J-1],14,FID); 00255578
END; 00255580
END; 00255590
END %PPDMTL08 00255595
END 00255600
ELSE %DO ALMOST THE SAME FOR OUTPUT. 00255700
BEGIN 00255800
IF PTR>2 THEN %PPDMTL09 00255810
BEGIN %PPDMTL09 00255820
IF IOFILE[PTR].RESIDENT THEN %PPDMTL09 00255825
WRITETTY ("This file already exists. A CLOSE will override it."); 00255830
%PPDMTL09 00255831
IOFILE[PTR](MAXRECSIZE=15,BLOCKSIZE=300,AREASIZE=600, %PPDMTL09 00255900
AREAS=40,FILETYPE=0); %PPDMTL09 00256000
END; %PPDMTL09 00256010
ARG1 := ZTRACT(PTR); 00256100
FILEINPUT[PTR]:=FALSE; 00256200
END; 00256300
EXIT: 00256350
FILEINUSE[PTR] := TRUE; %MARK FILE AS IN USE. 00256400
PRIMCOUNTER(41); 00256600
END XOPEN; 00256700
00256800
00256900
DECLARE(XPOSN,42,ARG1:=ZTRACT(OUTPTR)); 00257000
00257100
00257200
PROCEDURE XRDS; 00257300
% SETS CUR.CHAN.IN TO NUMERIC ARGUMENT IF 0 OR 1. 0-ME, 1-CARDS. 00257400
BEGIN REAL TMP; 00257500
DECLAREANDWEIGH; 00257550
TMP := IF ARG1=NIL THEN 0 ELSE ZEXTEND(ARG1); 00257600
IF TMP > FMAX OR TMP < 0 THEN 00257700
ZERR(GINPUT,5); 00257800
IF TMP > 0 THEN %MAKE SURE FILE IS OPEN. 00257900
IF NOT FILEINUSE[TMP] OR NOT FILEINPUT[TMP] THEN 00258000
ZERR(GINPUT,5); 00258100
ARG1 := ZTRACT(CURCHANIN); %OLD CHANNEL. 00258200
CURCHANIN := TMP; 00258300
INPTR := -1; %FORCE A READ. 00258400
MICROBUMP(13); 00258500
PRIMCOUNTER(43); 00258600
END XRDS; 00258700
00258800
00258900
PROCEDURE XWRS; 00259000
% SAME AS XRDS BUT CUR.CHAN.OUT IS CHANGED. 00259100
BEGIN REAL TMP; 00259200
DECLAREANDWEIGH; 00259250
TMP := IF ARG1=NIL THEN 0 ELSE ZEXTEND(ARG1); 00259300
IF TMP>FMAX OR TMP<0 THEN %ERROR IF NUMBER TOO LARGE. 00259400
ZERR(GOUTPUT,5); 00259500
IF TMP>0 THEN %MAKE SURE FILE IS OPENED. 00259600
IF NOT FILEINUSE[TMP] OR FILEINPUT[TMP] THEN 00259700
ZERR(GOUTPUT,5); 00259800
ARG1 := ZTRACT(CURCHANOUT); 00259900
CURCHANOUT := TMP; 00260000
MICROBUMP(12); 00260100
PRIMCOUNTER(44); 00260200
END XWRS; 00260300
00260400
00260500
EBCDIC ARRAY EXPCOMARRAY[0:131]; 00260700
00260710
PROCEDURE XEXPLODE; 00260800
% PRINT THE ATOM IN ARG1 INTO A SPECIAL BUFFER AND THEN BUILD IT 00260900
% INTO A LIST OF CHARACTERS AND RETURN IT. 00261000
BEGIN REAL PTR,S; 00261100
DEFINE TMP=EXPCOMARRAY#; 00261200
DECLAREANDWEIGH; 00261250
IF MPAIRP(ARG1) OR MVECTORP(ARG1) THEN 00261300
MTMSMTCH(ARG1, GATOM, GEXPLODE); 00261400
PTR := OUTPTR; 00261600
OUTPTR := 0; 00261700
IF BIGP(ARG1) THEN 00261710
BEGIN 00261720
S:=ABS(ZEXTEND(MCAR[ARG1.FIELD]))*DZ+3; 00261730
IF SIZE(TMP)<=S THEN 00261740
BEGIN 00261742
RESIZE(TMP,2*S); 00261744
RESIZE(ZPATOMARRAY,2*S); 00261746
END; 00261748
END 00261750
ELSE 00261760
S:=132; 00261770
STOPCOUNT; 00261780
ZPATOM(S,TRUE,TMP); %GET THE CHARACTERS. 00261800
STARTCOUNT; 00261890
S := NIL; %A POINTER TO PREVIOUS ELEMENT. 00261900
DO BEGIN 00262000
CHRINTERN(REAL(TMP[OUTPTR:=OUTPTR-1],1)); 00262100
STOPCOUNT; 00262150
S := ZCONS(ARG1,S); %CHARACTER FIRST ADDED AS AN ID. 00262200
STARTCOUNT; 00262250
MICROBUMP(4); 00262300
END UNTIL OUTPTR=0; 00262400
ARG1 := S; 00262500
OUTPTR := PTR; 00262700
MICROBUMP(12); 00262800
PRIMCOUNTER(0); 00262900
END XEXPLODE; 00263000
00263100
00263200
PROCEDURE XCOMPRESS; 00263300
% BUILD THE CHARACTERS IN THE LIST IN ARG1 INTO AN ATOM AND RETURN. 00263400
% 101 ERROR IF ANYTHING BAD GOES WRONG. 00263500
BEGIN REAL PTR,TMP,L; 00263600
DEFINE HBUF=EXPCOMARRAY#; 00263700
LABEL EXIT,ERR; 00263800
DECLAREANDWEIGH; 00263850
00263900
% BUILD THE LIST OF CHARACTERS INTO STRING IN HBUF BUFFER. 00264000
TMP:=132; 00264100
WHILE MPAIRP(ARG1) DO 00264200
BEGIN 00264300
L:=MCAR[ARG1]; 00264400
IF MIDP(L) THEN 00264500
REPLACE HBUF[PTR] BY ZGETSTRING(STRINGIZE(ISPPNAME[L.FIELD])) 00264600
ELSE 00264700
IF SMALLP(L) THEN 00264800
BEGIN 00264900
L:=ZEXTEND(L)+"0"; 00265000
IF L>"9" THEN GO TO ERR; 00265100
REPLACE HBUF[PTR] BY L.SHIFTUP FOR 1; 00265200
END 00265300
ELSE GO TO ERR; 00265400
PTR:=*+1; 00265500
IF PTR>=TMP THEN 00265510
BEGIN 00265520
IF PTR>=SIZE(HBUF) THEN RESIZE(HBUF,2*PTR); 00265530
TMP:=SIZE(HBUF); 00265540
END; 00265550
ARG1 := MCDR[ARG1]; 00265600
MICROBUMP(11); 00265700
END BUILDCHARS; 00265800
00265900
% BUILD THE ATOM USING RATOM. 00266000
REPLACE HBUF[PTR] BY " "; 00266010
ARG1 := NIL; 00266100
TMP:=0; 00266120
STOPCOUNT; 00266150
ZRATOM(TMP, HBUF, PTR+1); 00266200
STARTCOUNT; 00266250
IF ARG1=ZERO THEN 00266300
BEGIN 00266400
MICROBUMP(3); 00266500
L:=ZIDSPACE; 00266600
ISPPNAME[L]:=ISPVALUE[GSCNVAL.FIELD]&0TAG; 00266700
ISPPROP[L]:=ISPVALUE[L]:=NIL; 00266800
ARG1:=L & IDTAG TAG; 00266900
END 00267000
ELSE 00267100
ARG1 := ISPVALUE[GSCNVAL.FIELD]; 00267200
IF TMP < PTR THEN %ERROR IF NOT ALL CHARACTERS USED. 00267300
ERR: 00267400
ZERROR(101, ERRS[1]); 00267500
EXIT: 00267600
MICROBUMP(17); 00267700
PRIMCOUNTER(5); 00267800
END XCOMPRESS; 00267900
00267910
00267920
PROCEDURE XLENGTHC; 00267930
BEGIN REAL I,J; 00267940
DEFINE A = EXPCOMARRAY#; 00267945
DECLAREANDWEIGH; 00267947
IF MSTRINGP(ARG1) THEN 00267950
ARG1 := STRINGLENGTH(ARG1) 00267960
ELSE 00267970
IF MIDP(ARG1) THEN 00267980
BEGIN 00267990
ARG1 := ISPPNAME[ARG1.FIELD]; 00267992
ARG1 := STRINGLENGTH(ARG1); 00267994
END 00267996
ELSE 00268000
IF MCODEP(ARG1) THEN 00268010
ARG1 := 5 00268020
ELSE 00268030
IF SMALLP(ARG1) THEN 00268040
BEGIN 00268050
MICROBUMP(15); 00268055
I := ZEXTEND(ARG1); 00268060
REPLACE A BY I FOR 12 DIGITS; 00268070
SCAN A FOR J:11 WHILE = "0"; 00268080
ARG1 := (IF I<0 THEN 2 ELSE 1)+J; 00268090
END 00268091
ELSE 00268092
IF BIGP(ARG1) THEN 00268094
BEGIN 00268096
MICROBUMP(20); 00268097
I := ZEXTEND(MCAR[MCDR[ARG1.FIELD]]); 00268098
REPLACE A BY I FOR DZ DIGITS; 00268100
SCAN A FOR J:DZ WHILE = "0"; 00268102
I := ZEXTEND(MCAR[ARG1.FIELD]); 00268104
ARG1 := (IF I>0 THEN (I-1)*DZ ELSE (-I-1)*DZ+1)+J; 00268106
END 00268108
ELSE MTMSMTCH(ARG1,GATOM,GEXPLODE); 00268110
ARG1 := ZTRACT(ARG1); 00268120
MICROBUMP(6); 00268130
PRIMCOUNTER(2); 00268140
END XLENGTHC; 00268160
00268170
00268180
PROCEDURE XGETV; 00268200
% RETRIEVES THE ELEMNT OF A VECTOR. TYPE MISMATCH ERROR OCCURS IF 00268300
% ARG1 IS NOT A VECTOR, OR ARG2 IS NOT AN INTEGER. 00268400
BEGIN LABEL EXIT; 00268500
DECLAREANDWEIGH; 00268550
IF NOT MVECTORP(ARG1) THEN 00268600
MTMSMTCH(ARG1, GVECTOR, GGETV); 00268700
IF NOT SMALLP(ARG2) THEN 00268800
MTMSMTCH(ARG2, GINTEGER, GGETV); 00268900
IF ARG2<ZERO OR VSP[ARG1.FIELD] < ARG2 00269000
THEN BEGIN %SUBSCRIPT RANGE ERROR. 00269100
ARG3 := ARG2; 00269200
MLIST(ARG3, ERRS[8]); 00269300
ZERROR(108, ARG1); 00269400
END 00269500
ELSE ARG1 := VSP[ARG1+ARG2-(0&VECTORTAG TAG+ZEROLIT-1)]; 00269600
MICROBUMP(10); 00269700
PRIMCOUNTER(46); 00269800
END XGETV; 00269900
00270000
PROCEDURE GETVECTOR(L); VALUE L; REAL L; 00270100
% GET A VECTOR FROM THE V SPACE BY SOME TECHNIQUE. 00270200
% RETURNS NUMBER (SIZE) IF NOT ALLOCATED. 00270300
BEGIN REAL P,Q,TMP; 00270400
Q:=-1; 00270500
P:=VSPFREE; 00270600
IF L>0 THEN 00270700
DO BEGIN 00270800
IF VSP[P]=L THEN BEGIN 00270900
VSP[P]:=ARG1; 00271000
ARG1:=P; 00271100
ARG1.TAG:=VECTORTAG; 00271200
IF Q<0 THEN VSPFREE:=VSP[P+1] 00271300
ELSE VSP[Q+1]:=VSP[P+1]; 00271400
P:=-1; 00271500
MICROBUMP(9); 00271600
END 00271700
ELSE 00271800
IF VSP[P]>L+1 THEN BEGIN 00271900
TMP:=P; 00272000
VSP[P+L+2]:=VSP[P]-L-2; 00272100
VSP[P]:=ARG1; 00272200
VSP[P+L+3]:=VSP[P+1]; 00272300
IF Q<0 THEN VSPFREE:=P+L+2 00272400
ELSE VSP[Q+1]:=P+L+2; 00272500
ARG1 := TMP; 00272600
ARG1.TAG:=VECTORTAG; 00272700
P:=-1; 00272800
MICROBUMP(12); 00272900
END 00273000
ELSE 00273100
BEGIN 00273200
Q:=P; 00273300
P:=VSP[Q+1]; 00273400
MICROBUMP(5); 00273500
END; 00273600
END UNTIL P<0; 00273700
MICROBUMP(5); 00273800
END GETVECTOR; 00273900
00274000
PROCEDURE XMKVECT; 00274100
% CREATE A VECTOR OF LENGTH OF THE SINGLE ARGUMENT. TYPE MISMTACH 00274200
% ERROR CHECKING ONLY. 00274300
BEGIN REAL I,J; 00274400
DECLAREANDWEIGH; 00274450
IF NOT SMALLP(ARG1) THEN BEGIN 00274500
MTMSMTCH(ARG1, GINTEGER, GMKVECT); 00274600
END 00274700
ELSE BEGIN %INTEGER ARGUMENT, CHECK FOR SIZE. 00274800
J:=ZEXTEND(ARG1); 00274900
GETVECTOR(J); 00275000
IF SMALLP(ARG1) THEN BEGIN 00275100
ZGARBAGE(3); 00275200
GETVECTOR(J); 00275300
IF SMALLP(ARG1) THEN BEGIN 00275400
MLIST(ARG1,ERRS[9]); 00275500
ZERROR(109,ARG1); 00275600
END; 00275700
END; 00275800
I:=ARG1.FIELD+1; 00275900
DO BEGIN 00276000
VSP[I] := NIL; 00276100
I:=I+1; 00276200
MICROBUMP(4); 00276300
J:=*-1 ; 00276400
END UNTIL J<0; 00276500
END; 00276600
MICROBUMP(7); 00276700
PRIMCOUNTER(47); 00276800
END XMKVECT; 00276900
00277000
00277100
PROCEDURE XPUTV; 00277200
% PLACES ARG3 AT POSITION ARG2 IN VECTOR ARG1. TYPE MISMATCH CHECKING 00277300
% ON ARG1, ARG2 AND SUBSCRIPT RANGE CHECKING ON ARG2. 00277400
BEGIN LABEL EXIT; 00277500
DECLAREANDWEIGH; 00277550
IF NOT MVECTORP(ARG1) THEN 00277600
MTMSMTCH(ARG1, GVECTOR, GPUTV); 00277700
IF NOT SMALLP(ARG2) THEN 00277800
MTMSMTCH(ARG2, GINTEGER, GPUTV); 00277900
IF ARG2<ZERO OR VSP[ARG1.FIELD] < ARG2 00278000
THEN BEGIN %SUBSCRIPT RANGE ERROR. 00278100
ARG3 := ARG2; 00278200
MLIST(ARG3, ERRS[8]); 00278300
ZERROR(108, ARG1); 00278400
END 00278500
ELSE ARG1 := VSP[ARG1+ARG2-(0&VECTORTAG TAG+ZEROLIT-1)] := ARG3; 00278600
MICROBUMP(10); 00278700
PRIMCOUNTER(48); 00278800
END XPUTV; 00278900
00279000
00279100
DECLARE(XUPLIM,49,MUPLIM); 00279200
$PAGE 00279300
00279400
00280300
00280400
REAL PROCEDURE ZREGLIST(N); VALUE N; REAL N; 00280500
% PROCEDURE BUILDS A LIST OF THE REGISTER 1 -> N AND RETURNS 00280600
% A POINTER TO IT. 00280700
BEGIN LABEL EXIT; 00280800
REAL A; 00280900
MICROBUMP(3*N+5); 00281000
A := NIL; 00281100
WHILE N>0 DO 00281200
A := ZCONS(ARGS[N:=N-1], A); 00281300
ZREGLIST:=A; 00281400
END ZREGLIST; 00281500
00281600
00281700
00281800
BOOLEAN PROCEDURE ZEQUAL(P,Q); VALUE P,Q; REAL P,Q; 00281900
BEGIN LABEL L,EXIT; 00282000
DECLAREANDWEIGH; 00282050
L: MICROBUMP(3); 00282100
IF P=Q THEN BEGIN ZEQUAL:=TRUE; GO TO EXIT; END; 00282200
IF P.TAG NEQ Q.TAG THEN GO TO EXIT; 00282300
IF MPAIRP(P) THEN 00282400
BEGIN 00282500
MICROBUMP(2); 00282600
STOPCOUNT; 00282650
IF NOT ZEQUAL(MCAR[P],MCAR[Q]) THEN 00282700
BEGIN 00282710
STARTCOUNT; 00282720
GO TO EXIT; 00282730
END; 00282740
STARTCOUNT; 00282750
MICROBUMP(2); 00282800
P:=MCDR[P]; Q:=MCDR[Q]; GO TO L; 00282900
END; 00283000
MICROBUMP(1); 00283010
IF BIGP(P) THEN 00283020
BEGIN 00283030
MICROBUMP(3); 00283040
P.TAG:=0; Q.TAG:=0; 00283045
DO BEGIN 00283050
IF MCAR[P] NEQ MCAR[Q] THEN GO TO EXIT; 00283060
MICROBUMP(4); 00283070
P:=MCDR[P]; Q:=MCDR[Q]; 00283080
END UNTIL Q=NIL; 00283090
ZEQUAL:=TRUE; 00283100
GO TO EXIT; 00283110
END; 00283120
MICROBUMP(1); 00283130
IF NOT MVECTORP(P) THEN GO TO EXIT; 00283200
MICROBUMP(1); 00283300
IF VSP[P.FIELD] NEQ VSP[Q.FIELD] THEN GO TO EXIT; 00283400
MICROBUMP(6); 00283500
ZEQUAL := POINTER(VSP[P.FIELD+1]) = POINTER(VSP[Q.FIELD+1]) 00283600
FOR (ZEXTEND(VSP[P.FIELD])+1)*6; 00283700
EXIT: 00283800
MICROBUMP(3); 00283900
PRIMCOUNTER(62); 00284000
END ZEQUAL; 00284100
00284200
00284300
PROCEDURE XLENGTH; 00284400
BEGIN REAL I; 00284500
DECLAREANDWEIGH; 00284550
WHILE MPAIRP(ARG1) DO 00284600
BEGIN 00284700
I:=I+1; 00284800
ARG1:=MCDR[ARG1]; 00284900
MICROBUMP(3); 00285000
END; 00285100
ARG1:=ZTRACT(I); 00285200
MICROBUMP(5); 00285300
PRIMCOUNTER(63); 00285400
END XLENGTH; 00285500
00285600
00285700
PROCEDURE XREVERSIP; 00285800
BEGIN REAL P,Q; 00285900
DECLAREANDWEIGH; 00285950
Q:=NIL; 00286000
WHILE ARG1 NEQ NIL DO 00286100
BEGIN 00286200
P:=MCDR[ARG1]; 00286300
MCDR[ARG1]:=Q; 00286400
Q:=ARG1; 00286500
ARG1:=P; 00286600
MICROBUMP(5); 00286700
END; 00286800
ARG1:=Q; 00286900
MICROBUMP(6); 00287000
PRIMCOUNTER(64); 00287100
END XREVERSIP; 00287200
00287300
00287400
REAL PROCEDURE MMEMQ(P,Q); VALUE P,Q; REAL P,Q; 00287500
BEGIN LABEL EXIT; 00287600
DECLAREANDWEIGH; 00287650
IF Q NEQ NIL THEN 00287700
DO BEGIN 00287800
MICROBUMP(3); 00287900
IF MCAR[Q] = P THEN GO TO EXIT; 00288000
Q:=MCDR[Q]; 00288100
END UNTIL Q=NIL; 00288200
EXIT: 00288300
MMEMQ:=Q; 00288400
MICROBUMP(5); 00288500
PRIMCOUNTER(65); 00288600
END MMEMQ; 00288700
00288800
00288900
REAL PROCEDURE MMEMBER(P,Q); VALUE P,Q; REAL P,Q; 00289000
BEGIN LABEL EXIT; 00289100
DECLAREANDWEIGH; 00289150
IF Q NEQ NIL THEN 00289200
IF MSIMPLE(P) THEN 00289300
DO BEGIN MICROBUMP(3); 00289400
IF MCAR[Q]=P THEN GO TO EXIT; 00289500
Q:= MCDR[Q]; 00289600
END UNTIL Q=NIL 00289700
ELSE 00289800
DO BEGIN MICROBUMP(3); 00289900
STOPCOUNT; 00289950
IF ZEQUAL(P,MCAR[Q]) THEN 00290000
BEGIN 00290010
STARTCOUNT; 00290020
GO TO EXIT; 00290030
END; 00290040
STARTCOUNT; 00290050
Q:=MCDR[Q]; 00290100
END UNTIL Q=NIL; 00290200
EXIT: 00290300
MMEMBER:=Q; 00290400
MICROBUMP(7); 00290500
PRIMCOUNTER(66); 00290650
END MMEMBER; 00290700
00290800
00290900
DEFINE XMEMQ = ARG1:=MMEMQ(ARG1,ARG2)#; 00291000
DEFINE XMEMBER = ARG1:=MMEMBER(ARG1,ARG2)#; 00291100
00291200
00291300
PROCEDURE XLITER; 00291400
BEGIN REAL S; 00291500
DECLAREANDWEIGH; 00291550
S:=NIL; 00291600
IF MIDP(ARG1) THEN 00291700
IF (ARG1:=ISPPNAME[ARG1.FIELD]).BUCKF = 0 THEN %SINGLE CHARACTER 00291800
IF ZLITER(ARG1.LETERF) THEN S:=T; 00291900
ARG1:=S; 00292000
MICROBUMP(8); 00292100
PRIMCOUNTER(67); 00292200
END ZLITER; 00292300
00292400
00292500
PROCEDURE XDIGIT; 00292600
BEGIN REAL S; 00292700
DECLAREANDWEIGH; 00292750
S:=NIL; 00292800
%PPDMTL07 00292900
%PPDMTL07 00293000
IF ZDIGIT(ARG1.LETERF) THEN S:=T; 00293100
ARG1:=S; 00293200
MICROBUMP(8); 00293300
PRIMCOUNTER(68); 00293400
END ZDIGIT; 00293500
00293600
00293700
$PAGE 00293800
00293900
00294000
DEFINE ALGOLPRIMATIVE(N) = 00294100
BEGIN 00294200
00294300
CASE N OF 00294400
BEGIN 00294500
XEXPLODE; %[0] 00294600
ZCATCH; %[1] 00294700
XLENGTHC; %[2] 00294800
XGENSYM; %[3] 00294900
XSETMOD; %[4] 00295000
XCOMPRESS; %[5] 00295100
XCRECIP; %[6] 00295200
XCMOD; %[7] 00295300
XCPLUS; %[8] 00295400
XCTIMES; %[9] 00295500
XCDIF; %[10] 00295600
XREMOB; %[11] 00295700
XRCONS; %[12] 00295800
XNCONS; %[13] 00295900
XCONS; %[14] 00296000
XRPLACA; %[15] 00296100
XRPLACD; %[16] 00296200
XTERPRI; %[17] 00296300
XPRINC; %[18] 00296400
XTHROW; %[19] 00296500
XINTERN; %[20] 00296600
XREADCH; %[21] 00296700
XLAMBIND; %[22] 00296800
XQUIT; %[23] 00296900
XPATOM; %[24] 00297000
XPATOM2; %[25] 00297100
XEQ; %[26] 00297200
XEQN; %[27] 00297300
XRECLAIM; %[28] 00297400
XPLUS2; %[29] 00297500
XTIMES2; %[30] 00297600
XDIFFERENCE; %[31] 00297700
XQUOTIENT; %[32] 00297800
XGREATERP; %[33] 00297900
XLESSP; %[34] 00298000
XSCAN; %[35] 00298100
XREMAINDER; %[36] 00298200
ZUNSTACK; %[37] 00298300
XCLOSE; %[38] 00298400
XEJECT; %[39] 00298500
XAPPLY; %[40] 00298600
XOPEN; %[41] 00298700
XPOSN; %[42] 00298800
XRDS; %[43] 00298900
XWRS; %[44] 00299000
; %[45] 00299100
XGETV; %[46] 00299200
XMKVECT; %[47] 00299300
XPUTV; %[48] 00299400
XUPLIM; %[49] 00299500
XTIME; %[50] 00299600
XPUTPROP; %[51] 00299700
XGETPROP; %[52] 00299800
XPUTG; %[53] 00299900
XGETG; %[54] 00300000
XDUMP; %[55] 00300100
XORDERP; %[56] 00300200
XCHKPOINT; %[57] 00300300
XCONSTANTP; %[58] 00300400
XVECTORP; %[59] 00300500
XSETPCHAR; %[60] 00300600
XEXPT; %[61] 00300700
XEQUAL; %[62] 00300800
XLENGTH; %[63] 00300900
XREVERSIP; %[64] 00301000
XMEMQ; %[65] 00301100
XMEMBER; %[66] 00301200
XLITER; %[67] 00301300
XDIGIT; %[68] 00301400
XGET; %[69] 00301500
XGETD; %[70] 00301600
XGLOBALP; %[71] 00301700
XFLUIDP; %[72] 00301800
XGLOBAL; %[73] 00301900
XFLUID; %[74] 00302000
XUNFLUID; %[75] 00302100
XPUTD; %[76] 00302200
; %[77] 00302300
; %[78] 00302400
XATOM; %[79] 00302500
ZLIST; %[80] 00302600
XQUOTE; %[81] 00302700
XCAR; %[82] 00302800
XCDR; %[83] 00302900
XNULL; %[84] 00303000
XCODEP; %[85] 00303010
XIDP; %[86] 00303020
XNUMBERP; %[87] 00303030
XPAIRP; %[88] 00303040
XSTRINGP; %[89] 00303050
END CASE; 00303100
00303200
END ALGOLPRIMATIVE#; 00303300
00303400
$PAGE 00303500
%SEGMENT(B.MANAGEMENT); 00303600
00303700
00303800
00303900
00304000
$PAGE 00304100
00304200
DEFINE ZEVAL = 00304300
BEGIN 00304400
IF NOT MCONSTANTP(ARG1) THEN 00304500
IF MIDP(ARG1) THEN 00304600
BEGIN 00304700
MTEMP := ARG1; 00304800
ARG1 := ISPVALUE[MTEMP.FIELD]; 00304900
IF ARG1 = UNBOUND THEN 00305000
BEGIN 00305100
MLIST(ERRS[18],MTEMP); 00305200
ZERROR(100,ARG1); 00305300
END; 00305400
END 00305500
ELSE YEVAL; 00305600
END ZEVAL#; 00305700
00305800
DEFINE XFSUBR = 00305900
BEGIN 00306000
PRIMTRACE(77); 00306100
STOPCOUNT; 00306200
ZCALL(ARG2); 00306300
STARTCOUNT; 00306400
END XFSUBR#; 00306500
00306600
DEFINE XSUBR = 00306700
BEGIN 00306800
PRIMTRACE(78); 00306900
STOPCOUNT; 00307000
ZGET1 := ZSUBR; 00307100
STARTCOUNT; 00307200
MICROBUMP((13+5*MTEMP)); 00307300
STOPCOUNT; 00307400
ZCALL(ZGET1); 00307500
STARTCOUNT; 00307600
END XSUBR#; 00307700
00307800
REAL PROCEDURE ZSUBR; 00307900
BEGIN REAL N,L; 00308000
LABEL L1,L2,L3,L4,L5,L6,L7,L8,L9,L10,L11,L12,L13,L14; 00308100
SWITCH S := L1,L2,L3,L4,L5,L6,L7,L8,L9,L10,L11,L12,L13,L14; 00308200
MICROBUMP((MTEMP:=-1)); 00308300
ZSUBR := ARG1; 00308400
L := ARG2; 00308500
IF L NEQ NIL THEN 00308600
BEGIN 00308700
IF ES+16>ESPMAX THEN 00308800
RESIZE(ESP,ESPMAX:=ESPMAX+PAGESIZE,RETAIN); 00308900
ESP[ES:=ES+1] := L; %PROTECT L 00309000
N:=ES; 00309100
DO BEGIN 00309200
ARG1 := MCAR[L]; 00309300
ZEVAL; 00309400
ESP[ES:=ES+1] := ARG1; 00309500
L := MCDR[L]; 00309600
END UNTIL L=NIL; 00309700
L := ES-N; 00309800
ES := N; 00309900
GO TO S[L]; 00310000
L14: ARG14 := ESP[ES+14]; 00310100
L13: ARG13 := ESP[ES+13]; 00310200
L12: ARG12 := ESP[ES+12]; 00310300
L11: ARG11 := ESP[ES+11]; 00310400
L10: ARG10 := ESP[ES+10]; 00310500
L9: ARG9 := ESP[ES+9]; 00310600
L8: ARG8 := ESP[ES+8]; 00310700
L7: ARG7 := ESP[ES+7]; 00310800
L6: ARG6 := ESP[ES+6]; 00310900
L5: ARG5 := ESP[ES+5]; 00311000
L4: ARG4 := ESP[ES+4]; 00311100
L3: ARG3 := ESP[ES+3]; 00311200
L2: ARG2 := ESP[ES+2]; 00311300
L1: ARG1 := ESP[ES+1]; 00311400
ES := ES-1; 00311500
MICROBUMP((MTEMP:=L)); 00311600
END; 00311700
END ZSUBR; 00311800
00311900
PROCEDURE ZLIST; 00312000
BEGIN REAL Y,U; 00312100
DECLAREANDWEIGH; 00312200
U := ARG1; 00312400
IF U NEQ NIL THEN 00312500
BEGIN 00312600
ESP[ES:=ES+1] := U; 00312700
ARG1 := MCAR[U]; 00312800
STOPCOUNT; ZEVAL; STARTCOUNT; 00312900
Y := ZCONS(ARG1,NIL); 00313000
ESP[ES:=ES+1] := Y; 00313100
WHILE (U:=MCDR[U]) NEQ NIL DO 00313200
BEGIN 00313300
ARG1 := MCAR[U]; 00313400
STOPCOUNT; ZEVAL; STARTCOUNT; 00313500
Y := MCDR[Y] := ZCONS(ARG1,NIL); 00313600
MICROBUMP(3); 00313700
END; 00313800
ARG1 := ESP[ES]; 00313900
ES := ES-2; 00314000
MICROBUMP(7); 00314100
END; 00314200
MICROBUMP(5); 00314300
PRIMCOUNTER(80); 00314400
STOPCOUNT; 00314500
MICROBUMP((MTEMP:=-C)); 00314600
END ZLIST; 00314700
00314800
DEFINE XLIST = 00314900
BEGIN 00315000
STOPCOUNT; 00315100
ZLIST; 00315200
STARTCOUNT; 00315300
MICROBUMP((-MTEMP)); 00315400
END XLIST#; 00315500
$PAGE 00315600
00500100
00500200
00500300
00500400
% HERE ARE THE DEFINITIONS WHICH MAKE LISP ==> ALGOL WORK 00500500
00500600
DEFINE 00500700
00500800
GLOBAL[N] = ISPVALUE[QSP[QNUM+N].FIELD]#, 00500900
QUOTE[N] = QSP[QNUM+N]#, 00501000
FLUID[N] = ISPVALUE[QSP[QNUM+N].FIELD]#; 00501100
00501500
PROCEDURE MPROGBIND(Q); VALUE Q; REAL Q; 00501600
BEGIN REAL CNT,TPTR,I; 00501700
DECLAREANDWEIGH; 00501750
TPTR := TSPPTR; %BACK CHAIN POINTER. 00501800
CNT := ZEXTEND(QSP[Q]); 00501900
CHECKSTACK(CNT*2+2); 00502000
MICROBUMP(9); 00502100
WHILE I<CNT DO %BUILD THE A FRAME. 00502500
BEGIN 00502600
MICROBUMP(4); 00502700
ZPUSH(ISPVALUE[QSP[Q:=Q+1].FIELD]); 00502800
ISPVALUE[QSP[Q].FIELD] := NIL; 00502900
ZPUSH(QSP[Q]); %VARIABLE NAME FROM Q SPACE. 00503000
I:=I+1; 00503100
END BUILDAFRAME; 00503200
ZPUSH(GLAMBDA); %THIS IS WHERE BINDINGS OCCUR. 00503300
ZPUSH(TPTR); %BACKWARDS LINK. 00503400
PRIMCOUNTER(92); 00503450
END MPROGBIND; 00503500
00503600
PROCEDURE MLAMBIND(Q); VALUE Q; REAL Q; 00503700
BEGIN REAL CNT,TPTR,I,X; 00503800
DECLAREANDWEIGH; 00503850
TPTR := TSPPTR; %BACK CHAIN POINTER. 00503900
CNT := ZEXTEND(QSP[Q]); 00504000
CHECKSTACK(CNT*2+2); 00504100
MICROBUMP(9); 00504200
WHILE I<CNT DO 00504600
BEGIN 00504700
MICROBUMP(5); 00504800
X := (ARGS[ZEXTEND(QSP[Q:=*+1])]); %VALUE IN REGISTER 00504900
ZPUSH(ISPVALUE[QSP[Q:=Q+1].FIELD]); 00505000
ISPVALUE[QSP[Q].FIELD] := X; 00505100
ZPUSH(QSP[Q]); %VARIABLE NAME. 00505200
I:=I+1; 00505300
END BUILDAFRAME; 00505400
ZPUSH(GLAMBDA); %AN A FRAME IS HERE. 00505500
ZPUSH(TPTR); %BACK CHAIN POINTER. 00505600
PRIMCOUNTER(93); 00505650
END MLAMBIND; 00505700
00505800
00505900
REAL PROCEDURE MLINK(Q,N); VALUE Q,N; REAL Q,N; 00506000
BEGIN REAL FN; 00506100
LABEL EXIT; 00506200
PRIMTRACE(103); 00506400
FN := ISPVALUE[Q.FIELD]; 00507900
IF MPAIRP(FN) THEN %ONLY WORKS IF DEFINED FUNCTION. 00508000
IF MCAR[FN] = GEXPR OR MCAR[FN] = GFEXPR OR 00508100
MCAR[FN] = GMACRO THEN BEGIN %MOVE REGISTERS TO LIST THEN 00508200
ARG2 := ZREGLIST(N); 00508300
ARG1 := MCDR[FN]; 00508400
MLINK:=MCDR[ISPVALUE[GAPPLY.FIELD]].FIELD; %APPLY ARGS 00508500
GO TO EXIT; 00508600
END 00508700
ELSE IF MCAR[FN] = GFSUBR OR MCAR[FN] = GSUBR THEN 00508800
BEGIN 00508900
MLINK := MCDR[FN].FIELD; 00509000
GO TO EXIT; 00509100
END; 00509200
MLIST(Q, ERRS[2]); %UNDEFINED FUNCITON. 00509300
ZERROR(102, ARG1); 00509400
EXIT: 00509500
END MLINK; 00509600
00509700
00509800
$ SET OMIT = SLOWSTACK OR COUNT 00509900
00510000
DEFINE MALLOC(L,Q) = #, MDEALLOC = #, 00510100
XDEALLOC = #, KDEALLOC = #; 00510110
00510200
$ POP OMIT SET OMIT = NOT SLOWSTACK AND NOT COUNT 00511200
00511300
PROCEDURE MALLOC(L,Q); VALUE L,Q; REAL L,Q; 00511400
BEGIN REAL TPTR; 00511500
L:=L.[6:7]; 00511600
CHECKSTACK(L+5); 00511700
COUNT(90); 00511800
TPTR := TSPPTR; %BACK CHAIN POINTER. 00511900
ZPUSH(CURQPROGPTR); %Q-SPACE BASE OF PREVIOUS ENTRY. 00512000
CURQPROGPTR := Q; 00512100
ZPUSH(0); 00512200
ZPUSH(CURSTACKBASE); 00512300
CURSTACKBASE := TSPPTR; %NEW STACK BASE. 00512400
%PUSH WWWWWWWW NILS ONTO THE STACK. 00512500
MICROBUMP(1); 00512600
REPLACE TSP[TSPPTR] BY NIL FOR L WORDS; 00513300
TSPPTR:=*+L; 00513400
ZPUSH(GBPROG); %!$BPROG IS SPECIAL FRAME NAME. 00513500
ZPUSH(TPTR); %BACK CHAIN POINTER. 00513600
END MALLOC; 00513700
00513800
DEFINE MDEALLOC = 00513900
BEGIN 00514000
TSPPTR := TSP[TSPPTR-1]; 00514100
CURQPROGPTR := TSP[TSPPTR]; 00514200
CURSTACKBASE := TSP[TSPPTR + 2]; 00514300
END MDEALLOC#; 00514400
00514500
DECLARE(XDEALLOC,91,MDEALLOC); 00514510
DEFINE KDEALLOC = ENDCOUNT; XDEALLOC#; 00514520
00514530
$ POP OMIT 00514600
00514700
00514800
$ SET OMIT = FASTLINK 00515200
00515300
DEFINE CORRECTLINK(Q,N) = 00515400
IF QSP[Q] < 0 THEN 00515500
BEGIN 00515600
XCALL(MLINK(QSP[Q],N)); 00515700
GO TO EXIT; 00515800
END#; 00515900
00516000
$ POP OMIT SET OMIT = NOT FASTLINK 00516100
00516200
DEFINE CORRECTLINK(Q,N) = #; 00516300
00516400
$ POP OMIT 00516500
00516600
00516700
DEFINE 00516800
KPROGBIND(Q) = MPROGBIND(QNUM+Q)#, 00516900
KLAMBIND(Q) = MLAMBIND(QNUM+Q)#, 00517000
KFREERST = ZUNSTACK#, 00517100
XUNSTACK = ZUNSTACK#; 00518100
00518200
00518300
$ SET OMIT = NOT SLOWSTACK AND NOT COUNT 00518400
00518500
DEFINE KALLOC(L,Q,N) = 00518600
DECLARECOUNT; 00518700
'LET QNUM := Q; 00518800
CORRECTLINK(Q,N); 00518900
MALLOC(L,Q); 00519000
BEGINCOUNT#, 00519100
LOCAL[N] = TSP[CURSTACKBASE+N]#; 00519200
00519300
$ POP OMIT SET OMIT = SLOWSTACK OR COUNT 00519400
00519500
DEFINE KALLOC(L,Q,N) = 00519700
'LET SNUM := (L).[6:7]; 00519800
'IF SNUM>0 THEN 00519900
'BEGIN REAL V; 'END; 00520000
'FOR NUM:=1 STEP 1 UNTIL SNUM DO 00520100
'BEGIN REAL V'NUM; 'END; 00520200
'IF SNUM>0 THEN 00520400
'BEGIN V:="LOCAL " & SNUM [6:7]; 'END; 00520500
'LET QNUM := Q; 00520600
CORRECTLINK(Q,N)#, 00520700
LOCAL[N] = 'LET SNUM:=N+1; V'SNUM#; 00521000
00521100
$POP OMIT 00521200
00521300
$ SET OMIT = COUNT 00521900
00521910
DEFINE 00522000
KLOAD(R,E) = R := E#, 00522100
KSTORE(G,R) = GLOBAL[G] := R#, 00522300
KSET(S,R) = LOCAL[S] := R#, 00522400
00522405
KLINK(N,F) = F#, 00522410
KGOTO(L) = GO TO L#, 00522420
00522430
KJUMPNIL(L) = IF ARG1=NIL THEN GO TO L#, 00522440
KJUMPT(L) = IF ARG1 NEQ NIL THEN GO TO L#, 00522450
00522460
IFTRUE(L,B) = IF B THEN GO TO L#, 00522470
IFNOT(L,B) = IF NOT B THEN GO TO L#; 00522480
00522600
00522700
$ POP OMIT SET OMIT = NOT COUNT 00522800
00522810
DEFINE 00522900
KLOAD(R,E) = R := CT(E,100)#, 00523000
KSTORE(G,R) = GLOBAL[G] := CT(R,94)#; 00523100
00523400
PROCEDURE KSET(R,S); VALUE R,S; REAL R,S; 00524700
BEGIN 00524800
LOCAL[R] := S; 00524900
PRIMTRACE(96); 00525000
END; 00525100
00525200
DEFINE 00525300
KLINK(N,F) = PRIMTRACE(101); STOPCOUNT; F; STARTCOUNT#, 00525310
KGOTO(L) = PRIMTRACE(98); GO TO L#, 00525320
00525330
KJUMPNIL(L) = IF JUMP(ARG1=NIL) THEN GO TO L#, 00525340
KJUMPT(L) = IF JUMP(ARG1 NEQ NIL) THEN GO TO L#, 00525350
00525360
IFTRUE(L,B) = IF JUMP(B) THEN GO TO L#, 00525370
IFNOT(L,B) = IF JUMP(NOT B) THEN GO TO L#; 00525380
00525400
$ POP OMIT 00525900
00526000
DEFINE KUNDEFINED(S,N) = 00526100
BEGIN REAL I,J; 00526200
DEFINE A=EXPCOMARRAY#; 00526300
REPLACE A BY S; 00526400
SCAN A FOR I:80 UNTIL ="."; 00526500
J := ARG1; ARG1 := ZADDTOSTRINGS(A,80-I); 00526600
XINTERN; 00526700
I := ARG1; ARG1 :=J; 00526800
XCALL(MLINK(I,N)); 00526900
END#; 00527000
00527100
$PAGE 08000100
08000200
08000300
08000600
PROCEDURE XCALL(N); VALUE N; REAL N; 08000700
BEGIN LABEL EXIT; 08000800
COUNT(102); 08001100
IF N<255 THEN 08001200
ALGOLPRIMATIVE(N) 08001300
ELSE 08001400
BEGIN 08001500
CASE N-256 OF 08001600
BEGIN LISTOFPROCCALLS END; 08001700
END; 08002300
EXIT: 08002400
END OF XCALL; 08002500
08002600
08002700
08002800
COMMENT PROCEDURE (FOR TRACE BACK); 08999999
09000100
09000200
INITIALIZE; %GET THINGS SET UP. 09000300
YSTANDARDQ11LISP; 09000700
09000800
THU: 09001300
09001400
% END OF IT. 09999999
% 10000100
%********************************************************************* 10000200
%** ** 10000300
%** COMMENTS ON THE PATCHES WRITTEN BY MONTREAL PPD ** 10000400
%** ** 10000500
%********************************************************************* 10000600
% 10000700
%PPDMTL01 08/12/85 L. SANS CARTIER 10000800
%THIS PATCH WILL CHANGE THE ACCESS TO THE LISP LIBRARY. UP TO NOW, IT 10000900
%WAS IMPLEMENTED AS A SIMPLE OBJECT LIBRARY; IT WILL BE NOW A "SUPPORT 10001000
%LIBRARY". 10001100
% 10001200
%PPDMTL02 08/23/85 L. SANS CARTIER 10001300
%THIS WILL ADD AN ERROR MESSAGE IN THE CASE THAT AN IDENTIFIER HAVING 10001400
%MORE THAN 24 CHARACTERS IS USED. (--LISP--) 10001500
% 10001600
%PPDMTL04 08/23/85 L. SANS CARTIER 10002100
%THIS WILL DETECT THE CASE WHEN A CODE FILE IS GIVEN TO THE INPUT 10002200
%COMMAND "IN". (--REDUCE--) 10002300
% 10002400
%PPDMTL05 08/23/85 L. SANS CARTIER 10002500
%LINES 148900 AND 149000 HAD BEEN MOVED RIGHT AFTER LINE 148600 IN 10002600
%ORDER TO REMOVE THE "STACK UNDERFLOW" ERROR THAT OCCURED WHEN A CALL 10002700
%WITH EITHER TOO FEW OR TOO MUCH ARGUMENTS. (--LISP-- AND --REDUCE--) 10002800
% 10002900
%PPDMTL06 08/23/85 L. SANS CARTIER 10003000
%THIS IS TO CREATE OUTPUT DISK FILES AS SMALL AS POSSIBLE ("CRUNCH"). 10003100
%(--LISP-- AND --REDUCE--) 10003200
% 10003300
%PPDMTL07 08/23/85 L. SANS CARTIER 10003400
%THE FUNCTION "DIGIT" WASN'T WORKING AT ALL. THIS WILL CORRECT IT. 10003500
%(--LISP--) 10003600
% 10003700
%PPDMTL08 08/23/85 L. SANS CARTIER 10003800
%AN ERROR SHOULD BE DETECTED WHEN THE PRINTER IS OPENED IN INPUT MODE. 10003900
%(--LISP--) 10004000
% 10004100
%PPDMTL09 08/23/85 L. SANS CARTIER 10004200
%WHEN THE USER TRIES TO WRITE ON A DISK FILE THAT ALREADY EXISTS, A 10004300
%WARNING SHOULD BE GIVEN. (--LISP--) 10004400
% 10004500
%PPDMTL10 08/23/85 L. SANS CARTIER 10004600
%THIS WILL ALLOW THE USER TO CONTINUE AFTER A "FATAL ERROR" IS GIVEN. 10004700
%UP TO NOW, THE NEXT COMMAND ALWAYS PRODUCED A "SEG ARRAY ERROR" AND 10004800
%THEN DS-ED. 10004900
% **************** IMPORTANT NOTE TO THE USER ***************** 10005000
% * AFTER THE FATAL ERROR MESSAGE IS GIVEN, THE PROGRAM WILL * 10005100
% * WAIT FOR ANOTHER COMMAND (BUT WITHOUT GIVING THE PROMPT). * 10005200
% * THE NEXT COMMAND WILL BE A DUMMY ONE AND WILL ONLY MAKE * 10005300
% * THE PROGRAM GIVE THE PROMPT. THE USER WILL THEN BE ABLE * 10005400
% * TO CONTINUE NORMALLY. * 10005500
% ************************************************************* 10005600
%YOU MAY WISH TO REMOVE THIS PATCH IF THE FORMER RESULTS WERE MORE 10005700
%SUITED TO YOUR SPECIFIC NEEDS. 10005800
% 10005900
%PPDMTL11 08/23/85 L. SANS CARTIER 10006000
%THIS PATCH WILL ENABLE LISP TO RETURN NIL (INSTEAD OF AN INVALID 10006100
%INDEX) WHENEVER "CDR NIL" IS ASKED FOR. (--LISP--) 10006200
% 10006300
%PPDMTL19 01/08/86 L. SANS CARTIER 10006310
%THIS PATCH WILL ENABLE LISP TO WORK ON A9 MACHINES. BECAUSE THE A9 DO 10006320
%NOT NORMALIZE FLOATING POINT NUMBERS IN THE SAME WAY THAN THE A3 DOES, 10006330
%THE OVERFLOW TEST DIDN'T ALWAYS GIVE THE SAME RESULTS ON THE 2 MACHINES10006340
%EVENTHOUGH ACTUALLY THE VALUE WAS THE SAME. 10006350
% 10006360
%PPDMTL12 08/23/85 L. SANS CARTIER 10006400
%THE END-OF-LINE ("EOL") WAS NOT RECOGNIZED BY READCH. (--LISP--) 10006500