github.com/retro-software.B5500-software
1
0
Fork 0
mirror of https://github.com/retro-software/B5500-software.git synced 2026-01-13 15:17:03 +00:00
Code Issues Releases Wiki Activity
retro-software.B5500-software/APL-WU-Kildall/APL-IMAGE.alg_m

7274 lines
582 KiB
Plaintext
Raw Blame History

BEGIN 00000100
% THIS APL/B5500 PROGRAM WAS DEVELOPED BY THE COMPUTER SCIENCE GROUP 00000200
% AT THE UNIVERSITY OF WASHINGTON UNDER THE SPONSORSHIP OF PROFESSOR 00000300
% HELLMUT GOLDE. THE PROGRAM MAY BE NOT BE OFFERED FOR SALE OR LEASE 00000400
% IN ITS ORIGINAL OR ANY MODIFIED FORM. ANY PUBLICATION RELATING TO 00000500
% THIS PROGRAM OR ANY MODIFICATION OF THE PROGRAM MUST EXPLICITLY CREDIT00000600
% THE COMPUTER SCIENCE GROUP OF THE UNIVERSITY OF WASHINGTON AND THE 00000700
% PRINCIPAL IMPLEMENTORS, GARY KILDALL, LEROY SMITH, SALLY SWEDINE, 00000800
% AND MARY ZOSEL. COMPUTER RESOURCES FOR THE DEVELOPMENT OF THE 00000900
% PROGRAM WERE MADE AVAILABLE BY THE UNIVERSITY OF WASHINGTON COMPUTER 00001000
% CENTER. 00001100
DEFINE VERSIONDATE="1-11-71"# ; 00001200
%MODIFICATIONS FOR B-5500 TIME-SHARING MCP MADE BY: 00001300
% JOSE HERNANDEZ, BURROUGHS CORPORATION. 00001400
BOOLEAN BREAKFLAG; 00001500
ARRAY GTA[0:1]; 00001600
LABEL FINIS; %GO THERE WHEN YOU ARE IN TROUBLE (SPOUT A MESSAGE) 00001700
BOOLEAN PROCEDURE LIBRARIAN(A,B); VALUE A,B; REAL A,B; FORWARD; 00001800
LABEL FAULTL; % FAULT LABEL 00001900
MONITOR EXPOVR,INTOVR,INDEX:=INDEXF,FLAG,ZERO; 00002000
REAL BIGGEST, NULLV; 00002100
INTEGER STACKSIZE,LIBSIZE; 00002200
REAL STATUSWORD,CORELOC; 00002300
BOOLEAN RETURN; 00002400
BOOLEAN MEMBUG,DEBUG; 00002500
COMMENT MEMBUG SWITCHES ---------------------- 00002600
BIT FUNCTION BIT FUNCTION 00002700
----------------------------------------------------------------- 00002800
1 25 00002900
2 26 00003000
3 27 00003100
4 28 00003200
5 DUMP TYPES @ INSERT 30 00003300
6 DUMP TYPES @ DELETE 30 00003400
7 31 00003500
8 32 00003600
9 33 00003700
10 34 00003800
11 35 00003900
12 36 00004000
13 37 00004100
14 38 00004200
15 39 00004300
16 40 00004400
17 41 00004500
18 42 00004600
19 43 00004700
20 DUMP INDEX 44 00004800
21 45 00004900
22 DUMP TYPES 46 00005000
23 CHECK TYPES 47 00005100
24 DUMP BUFFER #S 00005200
; 00005300
FILE PRINT 4 "SYSTEMS" " BOX " (1,15); 00005400
FILE TWXIN 19(2,30),TWXOUT 19(2,10); 00005500
% 00005600
DEFINE 00005700
PAGESIZE=120#, 00005800
AREASIZE=40#, 00005900
CF=[26:13]#, COMMENT COUNT FIELD -- NUMBER OF ITEMS ON PAGE; 00006000
TF=[39:9] #, COMMENT T-FIELD (TYPE FIELD); 00006100
FF=[9:1]#, COMMENT FULL FIELD FOR SEQUENTIAL STORAGE; 00006200
AF=[1:23] #, COMMENT A-FIELD; 00006300
BF=[24:23]#, COMMENT B-FIELD; 00006400
MF=[1:1]#, COMMENT METHOD OF STORAGE FIELD; 00006500
SF=[13:13]#, COMMENT SEQUENTIAL STORAGE SIZE FIELD (#CHRS); 00006600
BOOL=[47:1]#, 00006700
SKIP=1#, COMMENT --AMOUNT OF SPACE RESERVED AT THE 00006800
START OF EACH PAGE; 00006900
ALLOWANCE=10#, COMMENT --DEVIATION FROM THE AVERAGE PAGE SIZE 00007000
ALLOWED BEFORE CORRECTION; 00007100
RECSIZE=2#, 00007200
MAXPAGES=20#, 00007300
PAGESPACE=20#, 00007400
NEXTP=[42:6]#, 00007500
LASTP=[36:6]#, 00007600
PAGEF=[19:11]#, 00007700
BUFF=[12:6]#, 00007800
CHANGEDBIT=[1:1]#, 00007900
MBUFF=8#, 00008000
SBUFF=4#, 00008100
FLAGB=[18:1]#, COMMENT FLAG BIT FOR BUFFER MAINTENANCE; 00008200
EXTRAROOM=1#, 00008300
LIBJOB="/APLIBE"#,%MFID FOR APL SYSTEM FILE 00008400
ENDOFDEFINES=#; 00008500
REAL PROCEDURE CDR(X); VALUE X; REAL X; CDR:=X.NEXTP; 00008600
PROCEDURE RPLACD(X,Y); VALUE Y;REAL X,Y; X.NEXTP:=Y; 00008700
BOOLEAN PROCEDURE NULL(X); VALUE X; REAL X; NULL:=X.NEXTP=0; 00008800
BOOLEAN STREAM PROCEDURE EOFMARK(SK,RS,A); VALUE SK,RS; 00008900
BEGIN LABEL NO; SI:=A; SK(SI:=SI+8); 00009000
RS(8( 2(IF SB THEN JUMP OUT 3 TO NO; SKIP SB); 00009100
3(IF SB THEN SKIP SB ELSE JUMP OUT 3 TO NO); IF SB THEN 00009200
JUMP OUT 2 TO NO; SKIP SB));TALLY:=1;EOFMARK:=TALLY; 00009300
NO: 00009400
END; 00009500
STREAM PROCEDURE MARKEOF(SK,RS,A); VALUE SK,RS; 00009600
BEGIN DI:=A; 00009700
SK(DI:=DI+8); 00009800
RS(8(DS:=2RESET; DS:=3SET; DS:=RESET)); 00009900
END; 00010000
SAVE FILE ESTABLISH DISK [MAXPAGES:AREASIZE] 00010100
(1,PAGESIZE,SAVE 100); 00010200
FILE NEWDISK DISK (1,PAGESIZE); 00010300
FILE DISK1 DISK (1,PAGESIZE), 00010400
DISK2 DISK (1,PAGESIZE), 00010500
DISK3 DISK (1,PAGESIZE), 00010600
DISK4 DISK (1,PAGESIZE), 00010700
DISK5 DISK (1,PAGESIZE), 00010800
DISK6 DISK (1,PAGESIZE), 00010900
DISK7 DISK (1,PAGESIZE), 00011000
DISK8 DISK (1,PAGESIZE); 00011100
SWITCH FILE POINTERS:=DISK1,DISK1,DISK2,DISK3,DISK4,DISK5,DISK6,DISK7, 00011200
DISK8; 00011300
PROCEDURE SETPOINTERNAMES; 00011400
BEGIN 00011500
IF NOT LIBRARIAN(LIBJOB,TIME(-1)) THEN 00011600
BEGIN 00011700
WRITE(ESTABLISH); 00011800
MARKEOF(SKIP,RECSIZE,ESTABLISH(0)); 00011900
WRITE(ESTABLISH[1]); 00012000
WRITE(ESTABLISH[MAXPAGES|AREASIZE-1]); 00012100
LOCK(ESTABLISH); 00012200
CLOSE(ESTABLISH) 00012300
;LIBSIZE~-1; 00012400
END 00012500
END; 00012600
DEFINE 00012700
LIBMAINTENANCE=0#, 00012800
MESSDUM=#; 00012900
PROCEDURE MEMORY(MODE,TYPE,A,N,M);VALUE MODE,TYPE; 00013000
INTEGER MODE,TYPE,N,M; ARRAY A[0]; FORWARD; 00013100
STREAM PROCEDURE MOVE(A,N,B); VALUE N; 00013200
BEGIN SI:=A; DI:=B; DS:=N WDS; 00013300
END; 00013400
PROCEDURE MESSAGE(I); VALUE I; INTEGER I; 00013500
BEGIN 00013600
FORMAT F("MEMORY ERROR",I5); 00013700
COMMENT CHANGE LINE 3050 TO WRITE(PRINT,SF[I]) FOR MEMORY ERROR PROBS. 00013800
THIS FORMAT IS NOW EXCLUDED SINCE MEMORY IS SEEMINGLY WELL DEBUGED 00013900
SWITCH FORMAT SF:= 00014000
("LIBRARY MAINTENANCE IN PROGRESS."), 00014100
("SYSTEM ERROR--MEMORY ACCESS WITH EXPRESSION FOR N OR M."), 00014200
("SYSTEM ERROR--IMPROPER ARGUMENTS TO FREEPAGE."), 00014300
("SYSTEM ERROR--TOO LARGE A SUBSCRIPT FOR TYPE SPECIFIED."), 00014400
("SYSTEM ERROR--TYPE CANNOT BE ZERO WHEN INSERTING OR DELETING."), 00014500
("SYSTEM ERROR--CHARACTER STTRING TOO LONG TO STORE."), 00014600
("SYSTEM ERROR--ATTEMPT TO INSERT NON-SEQUENTIAL ELEMENT", 00014700
"IN TYPE A STORAGE."), 00014800
("SYSTEM ERROR--NO BLANKS IN PAGES."), 00014900
("SYSTEM ERROR--ATTEMPTED BINARY SEARCH OF UNORDERED DATA."), 00015000
("SYSTEM ERROR--BINARY SEARCH OF UNALLOCATED DATA ATTEMPTED."), 00015100
("SYSTEM ERROR--BINARY SEARCH FOUND A BLANK PAGE."), 00015200
("SYSTEM ERROR--DELETION OF TYPE B STORAGE NOT IMPLEMENTED."), 00015300
("SYSTEM ERROR--ATTEMPT TO DELETE FROM NON-EXISTENT STORAGE."), 00015400
("SYSTEM ERROR--ATTEMPT TO DELETE RECORD FROM OUTSIDE", 00015500
" ALLOCATED STORAGE."), 00015600
("SYSTEM ERROR--ATTEMPTED MEMORY SEARCH WITH -N- TOO LARGE."), 00015700
("SYSTEM ERROR--ATTEMPT TO CHANGE PREVIOUSLY DESIGNATED STORAGE", 00015800
" KIND"), 00015900
("SYSTEM ERROR--POINTERS TO DATA TYPES OVERLAP."), 00016000
(" "); 00016100
WRITE(PRINT,SF[I]); 00016200
IF I GTR 0 THEN 00016300
BEGIN 00016400
INTEGER GT1,GT2,GT3; 00016500
MEMORY(10,GT1,GTA,GT2,GT3); 00016600
GO TO FINIS; 00016700
END; 00016800
END; 00016900
PROCEDURE MEMORY(MODE,TYPE,A,N,M); VALUE MODE,TYPE; 00017000
INTEGER MODE,TYPE,N,M; ARRAY A[0]; 00017100
BEGIN 00017200
DEFINE T64= DI:=LOC T; DI:=DI+1; DS:=7 CHR#; 00017300
STREAM PROCEDURE WRITERECS(PAGE,A,SKP,NB,NR,NS,RL); 00017400
VALUE SKP,NB,NR,NS,RL; 00017500
BEGIN 00017600
COMMENT -- NS IS THE NUMBER OF WORDS TO SAVE (ON THE 00017700
TAIL OF THE PAGE); 00017800
LOCAL T,T1,T2,TT; 00017900
COMMENT -- MOVE TO POSITION FOR WRITE; 00018000
SI:=LOC NB; T64; SI:=PAGE; SKP(SI:=SI+8); 00018100
T(2(32(RL(SI:=SI+8)))); NB(RL(SI:=SI+8)); 00018200
T1:=SI; COMMENT -- RECORDS WILL BE WRITTEN HERE; 00018300
COMMENT -- SKIP OVER TO END OF RECORDS TO BE SAVED; 00018400
DI:=LOC TT; SI:=LOC NS; DI:=DI+1; DS:=7CHR; 00018500
SI:=T1; COMMENT MOVE TO THE END OF THE FIELD TO BE SAVED; 00018600
TT(2(32(RL(SI:=SI+8)))); NS(RL(SI:=SI+8)); 00018700
T2:=SI; COMMENT -- END OF FIELD TO BE SAVED; 00018800
SI:=LOC NR; T64; DI:=T2; 00018900
T(2(32(RL(DI:=DI+8)))); NR(RL(DI:=DI+8)); 00019000
SI:=T2; SI:=SI-8; DI:=DI-8; 00019100
TT(2(32(RL(DS:=WDS; SI:=SI-16; DI:=DI-16)))); 00019200
NS(RL(DS:=WDS; SI:=SI-16; DI:=DI-16)); 00019300
COMMENT -- HAVE ACCOMPLISHED THE "SAVE", NOW DO THE WRITE; 00019400
SI:=A; DI:=T1; 00019500
T(2(32(DS:=RL WDS))); NR(DS:=RL WDS) 00019600
END; 00019700
STREAM PROCEDURE READRECS(PAGE,A,SKP,NB,NR,NM,RL); 00019800
VALUE SKP,NB,NR,NM,RL; 00019900
BEGIN 00020000
COMMENT 00020100
SKP = "SKIP" - - THE NUMBER OF WORDS TO JUMP OVER 00020200
NB = "NUMBER BEFORE" -- " " RECORDS TO SKIP BEFORE 00020300
READING THE RECORD, 00020400
NR = "NUMBER OF RECORDS" " " " " READ FROM THE 00020500
BUFFER, 00020600
NM ="NUMBER TO MOVE" - - " " " " MOVE OVER TO 00020700
THE PREVIOUSLY READ AREA, 00020800
RL ="RECORD LENGTH" - - THE LENGTH OF EACH ITEM 00020900
; 00021000
LOCAL T,T1,T2; 00021100
SI:=LOC NB; T64; SI:=PAGE; SKP(SI:=SI+8); 00021200
T(2(32(RL(SI:=SI+8)))); NB(RL(SI:=SI+8)); 00021300
T1:=SI; 00021400
COMMENT - - T1 NOW HAS THE STARTING POSITION FOR THE READ; 00021500
SI:=LOC NR; T64; SI:=T1; DI:=A; 00021600
T(2(32(DS:=RL WDS))); NR(DS:=RL WDS); 00021700
T2:=SI; COMMENT T2 CONTAINS THE END OF THE READ; 00021800
SI:=LOC NM; T64; SI:=T2; DI:=T1; 00021900
T(2(32(DS:=RL WDS))); NM(DS:=RL WDS) 00022000
END READRECS; 00022100
DEFINE MOVEALONG= 00022200
DI:=LOC C; DI:=DI+6; DS:=2CHR; DI:=LOC Z; 00022300
TSI:=SI; TALLY:=TALLY+1; 00022400
IF TOGGLE THEN 00022500
BEGIN SI:=LOC C; SI:=SI+6; 00022600
IF 2 SC NEQ DC THEN 00022700
BEGIN TAL:=TALLY; SI:=LOC TAL; SI:=SI+7; 00022800
IF SC="0" THEN 00022900
BEGIN TALLY:=TMP; TALLY:=TALLY+1; TMP:=TALLY; 00023000
TALLY:=0; 00023100
END ELSE 00023200
BEGIN SI:=LOC Z; IF SC LEQ"9" THEN ; 00023300
END 00023400
END ELSE 00023500
BEGIN DI:=TDI; SI:=LOC SIZE; SI:=SI+6; DS:=2CHR; 00023600
TDI:=DI; SI:=SI-2; DI:=LOC C64; DI:=DI+7 ; DS:=CHR; 00023700
SI:=NEW; DI:=TDI; C64(2(DS:=32CHR)); DS:=SIZE CHR; 00023800
TDI:=DI; SI:=TSI; DI:=LOC C; DI:=DI+6; 00023900
DS:=2CHR; TSI:=SI; 00024000
TALLY:=TAL;CHRSTORE:=TALLY; SI:=LOC TMP; SI:=SI+7; 00024100
DI:=LOC CHRSTORE; DI:=DI+6; DS:=CHR END 00024200
END; 00024300
SI:=LOC C; DI:=LOC C64; DI:=DI+1; DS:=7CHR; DI:=TDI; SI:=SI-1; 00024400
DS:=2CHR; SI:=TSI; 00024500
C64(2(DS:=32CHR)); DS:=C CHR; TDI:=DI; TSI:=SI#; 00024600
INTEGER STREAM PROCEDURE CHRSTORE(A,SKP,B,NEW,NB,SIZE,NA,MODE, 00024700
PAGESIZE); VALUE SKP,NB,SIZE,NA,MODE,PAGESIZE; 00024800
BEGIN LOCAL T,C,TSI,TDI, 00024900
Z,C64,TMP,TAL; 00025000
LABEL DONE; 00025100
SI:=LOC NB; T64; 00025200
SI:=LOC MODE; SI:=SI+7; 00025300
IF SC="0" THEN ; COMMENT SET TOGGLE; 00025400
SI:=A; DI:=B; SKP(DS:=8CHR); 00025500
TSI:=SI; TDI:=DI; 00025600
T(2(32(MOVEALONG))); NB(MOVEALONG); 00025700
COMMENT NOW HAVE MOVED UP TO NB; 00025800
IF TOGGLE THEN 00025900
BEGIN TALLY:=TAL; CHRSTORE:=TALLY; SI:=LOC TMP; SI:=SI+7; 00026000
DI:=LOC CHRSTORE; DI:=DI+6; DS:=CHR; 00026100
SI:=LOC SIZE; SI:=SI+6; DI:=TDI; DS:=2CHR; TDI:=DI; 00026200
SI:=LOC SIZE; DI:=LOC C64; DI:=DI+1; DS:=7CHR; SI:=NEW; 00026300
DI:=TDI; C64(2(DS:=32CHR)); DS:=SIZE CHR; 00026400
END ELSE 00026500
BEGIN TSI:=SI; TDI:=DI; 00026600
SI:=LOC MODE; SI:=SI+7; 00026700
IF SC="1" THEN 00026800
COMMENT REMOVE AN ENTRY HERE; 00026900
BEGIN DI:=LOC C; DI:=DI+6; SI:=TSI; DS:=2CHR; 00027000
TSI:=SI; DI:=LOC C64; DI:=DI+1; SI:=LOC C; 00027100
DS:=7CHR; SI:=TSI; C64(2(SI:=SI+32)); SI:=SI+C; 00027200
TSI:=SI; DI:=LOC CHRSTORE; SI:=LOC C; DS:=WDS; 00027300
DI:=TDI; DS:=2LIT"0"; TDI:=DI; 00027400
END ELSE 00027500
IF SC="2" THEN 00027600
COMMENT READ OUT AND ENTRY; 00027700
BEGIN DI:=LOC C; DI:=DI+6; SI:=TSI; DS:=2CHR; 00027800
TSI:=SI; DI:=LOC C64; DI:=DI+1; SI:=LOC C; 00027900
DS:=7CHR; SI:=TSI; DI:=NEW; 00028000
C64(2(DS:=32CHR)); DS:=C CHR; 00028100
SI:=LOC C; DI:=LOC CHRSTORE; DS:=WDS; GO DONE END; 00028200
SI:=LOC NA; T64; SI:=TSI; DI:=TDI; 00028300
T(2(32(TDI:=DI; DI:=LOC C; DI:=DI+6; DS:=2CHR; 00028400
TSI:=SI; SI:=LOC C; DI:=LOC C64; DI:=DI+1; DS:=7CHR; 00028500
SI:=SI-1;DI:=TDI;DS:=2CHR;SI:=TSI;C64(2(DS:=32CHR));DS:=C CHR))); 00028600
NA( TDI:=DI; DI:=LOC C; DI:=DI+6; DS:=2CHR; TSI:=SI; 00028700
SI:=LOC C;DI:=LOC C64;DI:=DI+1;DS:=7CHR;SI:=SI-1; 00028800
DI:=TDI;DS:=2CHR;SI:=TSI;C64(2(DS:=32CHR));DS:=C CHR); 00028900
END; 00029000
SI:=LOC PAGESIZE; T64; SI:=B; DI:=A; 00029100
%CARD LIST UNSAFE 00029200
COMMENT $CARD LIST UNSAFE; 00029300
T(2(DS:=32WDS)); DS:=PAGESIZE WDS; 00029400
%CARD LIST SAFE 00029500
COMMENT $CARD LIST SAFE; 00029600
DONE: 00029700
END; 00029800
STREAM PROCEDURE SETNTH(P,K,N); VALUE K,N; 00029900
BEGIN DI:=P; SI:=LOC K; N(DI:=DI+8); DS:=WDS END; 00030000
BOOLEAN STREAM PROCEDURE LESS(A,AN,B,BN,K); VALUE K,AN,BN; 00030100
BEGIN 00030200
SI:=A; DI:=B; SI:=SI+AN; DI:=DI+BN; 00030300
IF K SC LSS DC THEN TALLY:=1; 00030400
LESS:=TALLY; 00030500
END; 00030600
REAL STREAM PROCEDURE ADDD(A,B); VALUE A,B; 00030700
BEGIN SI:=LOC A; DI:=LOC B; DS:=8ADD; SI:=LOC B; 00030800
DI:=LOC ADDD; DS:=WDS 00030900
END; 00031000
INTEGER PROCEDURE FREEPAGE(INDEX,TYPEZERO,START,FINISH); 00031100
VALUE TYPEZERO,START,FINISH; INTEGER TYPEZERO,START,FINISH; 00031200
ARRAY INDEX[0,0]; 00031300
IF START GTR FINISH THEN MESSAGE(2) ELSE 00031400
BEGIN ARRAY T[0:RECSIZE+EXTRAROOM+SKIP-1],P[0:FINISH-START]; 00031500
INTEGER I,J,K,R; 00031600
R:=RECSIZE+EXTRAROOM+SKIP; 00031700
J:=START-(FINISH+1); 00031800
FOR I:=FINISH STEP -1 UNTIL TYPEZERO DO 00031900
IF K:=(I+J) LSS TYPEZERO THEN 00032000
BEGIN T[R-1]:=P[TYPEZERO-K-1]; 00032100
MOVE(T,R,INDEX[I,0]) 00032200
END ELSE 00032300
BEGIN IF I GEQ START THEN P[FINISH-I]:=INDEX[I,R-1]; 00032400
MOVE(INDEX[K,0],R,INDEX[I,0]); 00032500
END; 00032600
FREEPAGE:=TYPEZERO-J; 00032700
END; 00032800
INTEGER PROCEDURE SEARCHL(A,B,N,MIN,MAX,NP); VALUE N,MIN,MAX; 00032900
INTEGER N,MIN,MAX,NP; 00033000
ARRAY A[0,0]; REAL B; 00033100
BEGIN 00033200
INTEGER I,T; 00033300
FOR I:=MIN STEP 1 WHILE T:=T+A[I,0].CF LEQ B AND I LSS MAX-1 DO; 00033400
IF T LSS B THEN 00033500
BEGIN MESSAGE(3); SEARCHL:=NP:=0; 00033600
END ELSE 00033700
BEGIN SEARCHL:=I; NP:=B-T+A[I,0].CF 00033800
END 00033900
END; 00034000
PROCEDURE SORT(A,P,N,C); VALUE P,N,C; INTEGER P,N,C; 00034100
ARRAY A[0,0]; 00034200
BEGIN INTEGER R; 00034300
BEGIN 00034400
ARRAY T[0:R:=RECSIZE+EXTRAROOM+SKIP-1]; 00034500
LABEL ENDJ; 00034600
INTEGER I,J,L,K,M,SK; R:=R+1; 00034700
SK:=SKIP TIMES 8; 00034800
K:=N-P+1; I:=1; DO UNTIL (I:=I TIMES 2) GTR K; 00034900
M:=I-1; 00035000
WHILE (M:=M DIV 2) NEQ 0 DO 00035100
BEGIN K:=N-M; J:=P; 00035200
DO BEGIN 00035300
L:=(I:=J)+M; 00035400
DO BEGIN 00035500
IF A[L,0].TF GTR A[I,0].TF THEN GO ENDJ; 00035600
IF A[L,0].TF EQL A[I,0].TF THEN 00035700
IF NOT(LESS(A[L,0],SK,A[I,0],SK,C)) THEN 00035800
GO ENDJ; 00035900
MOVE(A[L,0],R,T); MOVE(A[I,0],R,A[L,0]); 00036000
MOVE(T,R,A[I,0]) 00036100
END UNTIL (I:=(L:=I)-M) LSS P; 00036200
ENDJ: 00036300
END UNTIL (J:=J+1) GTR K; 00036400
END 00036500
END 00036600
END SORT; 00036700
COMMENT - - - - - - - - - - - - - - - - - - - - - - - - - - 00036800
MODE MEANING 00036900
---- ------- 00037000
1 = INTERROGATE TYPE 00037100
2 = INSERT RECORD REL ADDRS N 00037200
(RELATIVE TO START OF LAST PAGE) 00037300
3 = RETURN THE NUMBER OF RECORDS (M) 00037400
4 = " ITEM AT RECORD # N 00037500
5 = INSERT " " " " " 00037600
6 = DELETE " " " " " 00037700
7 = SEARCH FOR THE RECORD -A- 00037800
8 = FILE OVERFLOW, INCREASE BY N 00037900
9 = FILE MAINTENANCE 00038000
10 = EMERGENCY FILE MAINTENANCE 00038100
11 SET STORAGE KIND 00038200
12= ALTER STORAGE ALLOCATION RESOURCES 00038300
13= RELEASE "TYPE" STORAGE TO SYSTEM 00038400
14= CLOSE ALL PAGES FOR AREA TRANSITION 00038500
NOTE THAT WHEN SEQUENTIAL STORAGE MAINTENANCE IS DONE, N 00038600
WILL ALWAYS INDICATE THE ADDRESS OF THE STRING RELATIVE TO 00038700
THE TYPE SPECIFIED, AND M WILL ALWAYS BE THE LENGTH OF THE 00038800
STRING IN -A- (EITHER AS INPUT OR OUTPUT) 00038900
; 00039000
PROCEDURE UPDATE(T,L,U,D); VALUE L,U,D; INTEGER L,U,D; 00039100
ARRAY T[0]; 00039200
BEGIN INTEGER I,J,K; 00039300
FOR I:=L STEP 1 UNTIL U DO 00039400
BEGIN J:=T[I].AF+D; T[I].AF:=J; 00039500
J:=T[I].BF+D; T[I].BF:=J 00039600
END 00039700
END; 00039800
OWN INTEGER CURPAGE,NPAGES,NTYPES,P,PS,U,L; 00039900
OWN INTEGER FIRST,AVAIL,MAXBUFF,CURBUFF; 00040000
REAL GT1; 00040100
LABEL MOREPAGES; 00040200
COMMENT 00040300
IF MEMBUG.[21:1] THEN DUMPMEMORY(MODE,TYPE,N,M); 00040400
IF MODE=8 THEN NPAGES:=NPAGES+N; 00040500
MOREPAGES: 00040600
BEGIN 00040700
OWN BOOLEAN POINTERSET, TYPESET; 00040800
INTEGER I, T, NR; 00040900
OWN ARRAY BUF[0:MBUFF], TYPS[0:511]; 00041000
OWN ARRAY INDX[0:NPAGES,0:RECSIZE+EXTRAROOM+SKIP-1]; 00041100
PROCEDURE SETTYPES; 00041200
BEGIN INTEGER I, T; 00041300
FOR I := 0 STEP 1 UNTIL NPAGES DO 00041400
IF INDX[I,0].TF NEQ T THEN 00041500
BEGIN 00041600
TYPS[T].BF := I; TYPS[T:=INDX[I,0].TF].AF := I; 00041700
TYPS[T].BOOL := INDX[I,0].MF; 00041800
END; 00041900
TYPS[T].BF := I; 00042000
END SETTYPES; 00042100
REAL PROCEDURE BUFFNUMBER(I); VALUE I; INTEGER I; 00042200
BEGIN INTEGER K,L,M; 00042300
LABEL D; 00042400
DEFINE B=BUF#; 00042500
IF( IF K:=INDX[I,P].BUFF=0 THEN TRUE ELSE BUF[K].PAGEF 00042600
NEQ INDX[I,P].PAGEF+1) THEN 00042700
BEGIN IF NULL(K:=CDR(AVAIL)) THEN 00042800
BEGIN K:=CDR(FIRST); 00042900
WHILE M:=CDR(B[K]) NEQ 0 DO 00043000
BEGIN L:=K; K:=M; END; 00043100
RPLACD(B[L],0); 00043200
IF BOOLEAN(B[K].CHANGEDBIT) THEN 00043300
WRITE(POINTERS[K][B[K].PAGEF-1]); 00043400
B[K].CHANGEDBIT:=0; 00043500
END ELSE RPLACD(AVAIL,CDR(B[K])); 00043600
B[K].PAGEF:=INDX[I,P].PAGEF+1; 00043700
INDX[I,P].BUFF:=K; 00043800
READ(POINTERS[K][INDX[I,P].PAGEF]); 00043900
END ELSE 00044000
IF CDR(FIRST)=K THEN GO TO D ELSE 00044100
BEGIN L:=CDR(FIRST); 00044200
WHILE M:=CDR(B[L]) NEQ K DO L:=M; 00044300
RPLACD(B[L],CDR(B[M])); 00044400
END; 00044500
RPLACD(B[K],CDR(FIRST)); RPLACD(FIRST,K); 00044600
D: BUFFNUMBER:=K 00044700
END; 00044800
PROCEDURE MARK(I); VALUE I; INTEGER I; 00044900
BUF[INDX[I,P].BUFF].CHANGEDBIT:=1; 00045000
BOOLEAN PROCEDURE WRITEBUFFER; 00045100
BEGIN INTEGER I; 00045200
I:=CDR(FIRST); 00045300
WHILE NOT NULL(I) DO 00045400
IF BOOLEAN(BUF[I].CHANGEDBIT) THEN 00045500
BEGIN WRITEBUFFER:=TRUE; 00045600
BUF[I].CHANGEDBIT:=0; 00045700
WRITE(POINTERS[I][BUF[I].PAGEF-1]); 00045800
RPLACD(I,0); 00045900
END ELSE I:=CDR(BUF[I]); 00046000
END; 00046100
IF NOT POINTERSET THEN 00046200
BEGIN LABEL EOF; 00046300
READ(POINTERS[1][NPAGES])[EOF]; 00046400
IF EOFMARK(SKIP,RECSIZE,POINTERS[1](0))THEN GO TO EOF; 00046500
MOVE(POINTERS[1](0),1,T); 00046600
COMMENT -- USE T TO DETERMIN THE VARIABLE REC SIZE LATER; 00046700
MOVE(POINTERS[1](0),RECSIZE+SKIP,INDX[NPAGES,0]); 00046800
INDX[NPAGES,RECSIZE+1].PAGEF:=NPAGES; 00046900
NPAGES:=NPAGES+1; 00047000
GO TO MOREPAGES; 00047100
COMMENT - - INITIALIZE VARIABLES; 00047200
EOF: POINTERSET:=TRUE; 00047300
U:=PAGESIZE-SKIP-PAGESPACE; 00047400
L:=(U-ALLOWANCE)/RECSIZE; 00047500
U:=(U+ALLOWANCE+RECSIZE/2)/RECSIZE; 00047600
PS:=(U+L)/2; 00047700
CURPAGE:=NPAGES:=NPAGES-1; 00047800
CURBUFF:=1; 00047900
P:=RECSIZE+SKIP; 00048000
FOR T:=1 STEP 1 UNTIL SBUFF DO RPLACD(BUF[T],T+1); 00048100
RPLACD(BUF[SBUFF],0); RPLACD(AVAIL,1); 00048200
MAXBUFF:=SBUFF; 00048300
T:=0; 00048400
SORT(INDX,0,NPAGES,RECSIZE TIMES 8); 00048500
FOR I:=0 STEP 1 UNTIL NPAGES DO 00048600
IF INDX[I,0].TF GTR T THEN T:=INDX[I,0].TF; 00048700
NTYPES:=T; 00048800
END; 00048900
IF TYPE GTR NTYPES THEN NTYPES:=TYPE; 00049000
IF NOT TYPESET THEN 00049100
BEGIN TYPESET:=TRUE; SETTYPES; 00049200
COMMENT 00049300
IF MEMBUG THEN DUMPINDEX(TYPS,NTYPES,INDX,RECSIZE, 00049400
P); 00049500
END; 00049600
COMMENT --- DECIDE WHETHER TO SAVE CURRENT PAGE BEFORE GOING ON; 00049700
IF MODE=2 THEN 00049800
BEGIN MODE:=5; NR:=N 00049900
END ELSE 00050000
IF MODE GEQ 4 THEN %MAY BE FILE MAINTENANCE 00050100
IF MODE GEQ 8 THEN %IS FILE MAINTENANCE 00050200
ELSE %WE MAY BE GOING TO 00050300
IF MODE NEQ 7 THEN %ANOTHER PAGE 00050400
BEGIN 00050500
IF TYPE=0 THEN BEGIN MESSAGE(4); MODE:=0 END ELSE 00050600
IF TYPS[TYPE].AF=TYPS[TYPE].BF THEN 00050700
IF TYPS[0].BF GTR 0 THEN 00050800
BEGIN INTEGER J,K; REAL PG; 00050900
K:=TYPS[0].BF-1; TYPS[0].BF:=K; PG:=INDX[K,P]; 00051000
FOR I:=1 STEP 1 UNTIL TYPE-1 DO 00051100
IF (T:=TYPS[I]).AF NEQ T.BF THEN 00051200
BEGIN FOR K:=T.AF STEP 1 UNTIL T.BF -1 DO 00051300
MOVE(INDX[K,0],P+EXTRAROOM,INDX[K-1,0]); 00051400
TYPS[I].AF:=T.AF-1; TYPS[I].BF:=K:=T.BF-1 00051500
END; 00051600
IF CURPAGE GTR TYPS[0].BF THEN 00051700
IF CURPAGE LEQ K THEN CURPAGE:=CURPAGE-1; 00051800
TYPS[TYPE].BF:=K+1; TYPS[TYPE].AF:=K; 00051900
INDX[K,P]:=PG; INDX[K,0]:=0; INDX[K,0].TF:=TYPE; 00052000
IF TYPS[TYPE].BOOL=1 THEN 00052100
BEGIN SETNTH(INDX[K,0],0,1); INDX[K,0].MF:=1 00052200
END; 00052300
COMMENT 00052400
IF MEMBUG.[22:1] THEN DUMPTYPES(MODE,TYPS,NTYPES); 00052500
MEMORY(MODE,TYPE,A,N,M); MODE:=0 00052600
END ELSE 00052700
BEGIN T:=1; MEMORY(8,TYPE,A,T,M); MEMORY(MODE,TYPE,A,N,M);00052800
MODE:=0 00052900
END ELSE 00053000
IF NOT( BOOLEAN(TYPS[TYPE].BOOL) AND MODE=5) THEN 00053100
CURBUFF:=BUFFNUMBER(CURPAGE:= 00053200
SEARCHL(INDX,N,NPAGES,TYPS[TYPE].AF,TYPS[TYPE].BF, 00053300
NR) ); 00053400
COMMENT 00053500
IF MEMBUG.[23:1] THEN CHECKTYPES(TYPS,NTYPES); 00053600
END; 00053700
COMMENT 00053800
IF MEMBUG.[20:1] THEN DUMPINDEX(TYPS,NTYPES,INDX,RECSIZE,P); 00053900
COMMENT 00054000
IF MEMBUG.[24:1] THEN DUMPBUFF(BUF,FIRST,AVAIL); 00054100
CASE MODE OF 00054200
BEGIN 00054300
%------- MODE=0 ------- RESERVED --------------- 00054400
; 00054500
%------- MODE=1 --------------------------------------------------00054600
IF M=0 THEN N:=TYPS[TYPE].BOOL ELSE 00054700
IF M=1 THEN 00054800
BEGIN FOR I:=1 STEP 1 UNTIL NTYPES DO 00054900
IF (T:=TYPS[I]).AF=T.BF THEN 00055000
BEGIN N:=I; I:=NTYPES+1 00055100
END; 00055200
IF I=NTYPES+1 THEN N:=NTYPES+1 00055300
END; 00055400
%------- MODE=2 ------- RESERVED --------------- 00055500
; 00055600
%------- MODE=3 ------- RETURN THE NUMBER OF RECORDS---- 00055700
BEGIN COMMENT IF TYPE LSS 0 THEN THE TOTAL NUMBER 00055800
OF PAGES IS GIVEN, OTHERWISE THE NUMBER OF "TYPE" PAGES IS 00055900
GIVEN; 00056000
FOR I:=0 STEP 1 UNTIL NPAGES DO 00056100
IF INDX[I,0].TF=TYPE OR TYPE LSS 0 THEN 00056200
NR:=NR+INDX[I,0].CF; 00056300
M:=NR 00056400
END; 00056500
%------- MODE=4 ------- RETURN ITEM AT SUBSCRIPT N ----- 00056600
IF NR GEQ INDX[CURPAGE,0].CF THEN MESSAGE(3) ELSE 00056700
IF BOOLEAN (TYPS[TYPE].BOOL) THEN COMMENT SEQUENTIAL STORAGE; 00056800
BEGIN ARRAY B[0:PAGESIZE]; 00056900
M:=CHRSTORE(POINTERS[CURBUFF](0),2,B,A,NR,0,0,2,0); 00057000
END ELSE 00057100
BEGIN 00057200
M:=RECSIZE|8; 00057300
READRECS(POINTERS[CURBUFF](0),A,SKIP,NR,1,0,RECSIZE); 00057400
END; 00057500
%------- MODE=5 ------- INSERT ITEM AT SUBSCRIPT N; 00057600
BEGIN INTEGER K,J,S; REAL PG; 00057700
IF BOOLEAN(TYPS[TYPE].BOOL) THEN 00057800
COMMENT FIND A PLACE FOR THE CHARACTER STRING OF LENGTH 00057900
M; 00058000
IF M GTR (PAGESIZE-SKIP-1)|8-2 THEN MESSAGE(5) COMMENT 00058100
THIS CHARACTER STRING IS TOO LONG ; ELSE 00058200
BEGIN ARRAY C[0:PAGESIZE]; 00058300
STREAM PROCEDURE ADDZERO(CHARS,POINTER); VALUE CHARS; 00058400
BEGIN LOCAL T; 00058500
SI:=LOC CHARS; DI:=LOC T; DI:=DI+1; DS:=7CHR; 00058600
DI:=POINTER; T(2(DI:=DI+32)); CHARS(DI:=DI+1); 00058700
DS:=2LIT"0"; 00058800
END; 00058900
BOOLEAN B,NOTLASTPAGE; 00059000
LABEL TRYITAGAIN; 00059100
TRYITAGAIN: 00059200
FOR I:=(T:=TYPS[TYPE]).AF STEP 1 WHILE I LSS T.BF AND 00059300
NOT B DO 00059400
IF NOT(B:=((PAGESIZE-SKIP-1)|8-(GT1:=INDX[I,0]).SF)GEQ M+2 00059500
AND NOT BOOLEAN(GT1.FF)) THEN S:=S+GT1.CF ELSE I:=I-1; 00059600
NOTLASTPAGE:=B AND I NEQ T.BF-1; 00059700
COMMENT IF B IS TRUE, THEN A PAGE HAS BEEN FOUND; 00059800
IF NOT B THEN COMMENT GET A PAGE THAT IS FREE; 00059900
BEGIN 00060000
COMMENT 00060100
IF MEMBUG.[5:1] THEN DUMPTYPES(5,1,TYPS,NTYPES); 00060200
IF TYPS[0].BF=0 THEN BEGIN K:=CURPAGE; T:=1; 00060300
MEMORY(8,TYPE,A,T,M); CURPAGE:=K+1 00060400
END 00060500
ELSE 00060600
IF (PAGESIZE-SKIP-1)|8-INDX[(I:=I-1)-1,0].SF GTR 2 THEN 00060700
BEGIN 00060800
CURBUFF:=BUFFNUMBER(CURPAGE:=I-1); 00060900
ADDZERO((GT1:=INDX[CURPAGE,0].SF)+8|(SKIP+1),POINTERS 00061000
[CURBUFF](0)); 00061100
INDX[CURPAGE,0].SF:=GT1+2; 00061200
INDX[CURPAGE,0].CF:=INDX[CURPAGE,0].CF+1; 00061300
COMMENT SINCE ALLOCATING A NEW PAGE, SET COUNT TO 00061400
ONE MORE AND FREEZE THE COUNT; 00061500
S:=S+1; % SINCE THE COUNT INCREASED 00061600
MOVE(INDX[CURPAGE,0],SKIP+1,POINTERS[CURBUFF](0)); 00061700
MARK(CURPAGE); 00061800
END; 00061900
T:=TYPS[0].BF; TYPS[0].BF:=T:=T-1; 00062000
COMMENT T IS THE SUBSCRIPT INTO THE NEW PAGE; 00062100
PG:=INDX[T,P]; COMMENT PG HOLDS THE NEW PAGE #; 00062200
FOR K:=T+1 STEP 1 UNTIL I DO 00062300
MOVE(INDX[K,0],RECSIZE+SKIP+EXTRAROOM,INDX[K-1,0]); 00062400
T:=TYPS[TYPE].AF; TYPS[TYPE].AF:=T-1; 00062500
INDX[I,P]:=PG; UPDATE(TYPS,1,TYPE-1,-1); 00062600
IF CURPAGE GTR TYPS[0].BF THEN IF CURPAGE LEQ 00062700
I THEN CURPAGE:=CURPAGE-1; 00062800
INDX[I,0]:=0; INDX[I,0].MF:=1; INDX[I,0].TF:=TYPE; 00062900
COMMENT MUST ALSO ASSIGN A NUMBER TO THIS PAGE 00063000
(TO BE STORED IN THE PAGE) TO KEEP IT IN SEQUENCE 00063100
WITHIN THIS TYPE; 00063200
IF (T:=TYPS[TYPE]).AF LSS T.BF-1 THEN 00063300
T:=INDX[T.BF-1,1] ELSE T:=0; 00063400
SETNTH(INDX[I,0],ADDD(1,T),1); 00063500
COMMENT END OF THE INITIALIZATION OF THE INDEX ARRAY, 00063600
WE STILL HAVE TO MAKE SOME ENTRIES INTO THE PAGE 00063700
WHICH WE WILL DO BELOW; 00063800
END OF TEST FOR NEW PAGE; 00063900
COMMENT I IS SET TO THE PROPER SUBSCRIPT FOR THE CHR STORE; 00064000
CURBUFF:=BUFFNUMBER(CURPAGE:=I); 00064100
COMMENT NOW THE CORRECT PAGE IS IN CORE. 00064200
------------------------------ 00064300
M= NUMBER OF CHARACTERS IN A (ON INPUT) 00064400
N= ADDRESS OF A WITHIN IN THIS TYPE (ON OUTPUT 00064500
------------------------------; 00064600
K:=INDX[I,0]; 00064700
T:=CHRSTORE(POINTERS[CURBUFF](0),SKIP+1,C,A,K.CF,M,0,0, 00064800
PAGESIZE); 00064900
COMMENT K.CF IS THE NUMBER OF ITEMS ALREADY IN THIS 00065000
PAGE. IF THERE IS A SEGMENT WHICH IS NULL, IT WILL 00065100
BE FOUND AND ASSIGNED AS THE SEG NUMBER FOR 00065200
THIS CHARACTER STRING (T). IF NOT, IT WILL STICK THE 00065300
STRING ON THE END (WE KNOW THERE IS ENOUGH ROOM 00065400
SINCE WE CHECKED INDX[I,0].SF -- THE NUMBER OF CHRS USED 00065500
IN THIS PAGE, OR WE CREATED A NEW PAGE); 00065600
N:=S+T; S:=K.SF; COMMENT S CONTAINS THE # OF CHRS USED UP; 00065700
IF T:=T+1 GTR K.CF THEN COMMENT ADDED THE STRING ON THE END; 00065800
IF NOTLASTPAGE THEN % PAGE ALREADY FULL 00065900
BEGIN S:=0; B:=FALSE; INDX[I,0].FF:=1; 00066000
MOVE(INDX[I,0],SKIP+1,POINTERS[CURBUFF](0)); 00066100
MARK(CURPAGE); GO TRYITAGAIN; END ELSE 00066200
BEGIN K.CF:=T; S:=S+2; 00066300
END 00066400
ELSE IF T=K.CF AND NOTLASTPAGE THEN INDX[I,0].FF:=1; 00066500
00066600
INDX[I,0].CF:=K.CF; INDX[I,0].SF:=S+M; 00066700
MOVE(INDX[I,0],SKIP+1,POINTERS[CURBUFF](0)); 00066800
MARK(CURPAGE); 00066900
COMMENT THE PAGE DESCRIPTOR HAS BEEN UPDATED; 00067000
COMMENT 00067100
IF MEMBUG.[5:1] THEN DUMPTYPES(5,2,TYPS,NTYPES); 00067200
END ELSE COMMENT KIND OF STORAGE IS SORTED; 00067300
IF NR GTR (T:=INDX[CURPAGE,0].CF) THEN 00067400
COMMENT SUBSCRIPT IS NOT IN THE MIDDLE OF THE PAGE; 00067500
MESSAGE(6) ELSE 00067600
BEGIN 00067700
IF T GEQ U THEN COMMENT WILL EXCEED UPPER PAGE BOUND; 00067800
BEGIN ARRAY B[0:RECSIZE TIMES 00067900
(T-PS+(I:=(IF NR GEQ PS THEN 0 ELSE 1)))-1]; 00068000
COMMENT B IS JUST BIG ENOUGH TO CARRY THE 00068100
EXCESS FROM THE OLD PAGE; 00068200
READRECS(POINTERS[CURBUFF](0),B,SKIP,PS-I, 00068300
J:=(T-PS+I),0,RECSIZE); 00068400
COMMENT -- B NOW HAS THE EXCESS; 00068500
INDX[CURPAGE,0].CF:=T-J; SETNTH(POINTERS[CURBUFF](0), 00068600
INDX[CURPAGE,0],0); 00068700
MARK(CURPAGE); 00068800
IF TYPS[0].BF=0 THEN 00068900
BEGIN K:=CURPAGE; T:=1; 00069000
MEMORY(8,TYPE,A,T,M); CURPAGE:=K+1; 00069100
END; 00069200
COMMENT -- ASSIGN A FREE PAGE (SUBS T); 00069300
T:=TYPS[0].BF; TYPS[0].BF:=T:=T-1; 00069400
00069500
PG:=INDX[T,P]; 00069600
FOR K:=T+1 STEP 1 UNTIL CURPAGE DO 00069700
MOVE(INDX[K,0],RECSIZE+SKIP+EXTRAROOM,INDX[K-1,0]); 00069800
INDX[CURPAGE,P]:=PG; 00069900
T:=0;T.CF:=J;T.TF:=TYPE; 00070000
CURBUFF:=BUFFNUMBER(CURPAGE); 00070100
WRITERECS(POINTERS[CURBUFF](0),B,SKIP,0,J,0,RECSIZE); 00070200
SETNTH(POINTERS[CURBUFF](0),T,0); 00070300
MOVE(POINTERS[CURBUFF](0),RECSIZE+SKIP,INDX[CURPAGE,0]); 00070400
MARK(CURPAGE); 00070500
T:=TYPS[TYPE].AF; TYPS[TYPE].AF:=T-1; 00070600
UPDATE(TYPS,1,TYPE-1,-1); 00070700
IF J=0 THEN MESSAGE(7); 00070800
IF BOOLEAN (I) THEN 00070900
COMMENT I=0 IMPLIES THE RECORD GOES TO NEW PAGE, 00071000
I=1 IMPLIES THE RECORD GOES TO NOOLD PAGE; 00071100
BEGIN 00071200
T:=INDX[CURPAGE:=CURPAGE-1,0].CF; 00071300
CURBUFF:=BUFFNUMBER(CURPAGE); 00071400
; COMMENT OLD PAGE IS NOW BACK; 00071500
END ELSE 00071600
BEGIN T:=J; NR:=NR-PS 00071700
END 00071800
END; 00071900
WRITERECS(POINTERS[CURBUFF](0),A,SKIP,NR,1,T-NR,RECSIZE); 00072000
T:=INDX[CURPAGE,0].CF; INDX[CURPAGE,0].CF:=T+1; 00072100
SETNTH(POINTERS[CURBUFF](0),INDX[CURPAGE,0],0); 00072200
IF NR=0 THEN MOVE(POINTERS[CURBUFF](0),RECSIZE+SKIP,INDX 00072300
[CURPAGE,0]); MARK(CURPAGE); 00072400
END; 00072500
END; 00072600
%------- MODE=6 ------- DELETE A RECORD FROM THE FILE ---- 00072700
IF (T:=TYPS[TYPE]).AF=T.BF THEN MESSAGE(12) COMMENT 00072800
ATTEMPT TO DELETE NON-EXISTENT STORAGE; 00072900
ELSE 00073000
IF NR GEQ(T:=INDX[CURPAGE,0].CF) THEN MESSAGE(13) COMMENT 00073100
ATTEMPT TO DELETE OUTSIDE STORAGE RANGE; ELSE 00073200
IF BOOLEAN(T.BOOL) THEN COMMENT SEQUENTIAL STORAGE; 00073300
BEGIN COMMENT NR IS THE RECORD TO DELETE; 00073400
ARRAY B[0:PAGESIZE-1]; 00073500
COMMENT PAGESIZE -1 SHOULD BE COMPUTED TO THE EXACT 00073600
NUMBER OF WORDS TO MOVE -- IT WOULD SPEED THINGS UP; 00073700
INTEGER L; 00073800
T:=INDX[CURPAGE,0]; COMMENT T.CF IS THE NUMBER OF 00073900
RECORDS ON THIS PAGE, T.SF IS THE NUMBER OF CHRS; 00074000
L:=CHRSTORE(POINTERS[CURBUFF](0),SKIP+1,B,A,NR,0,T.CF 00074100
-NR-1,1,PAGESIZE); 00074200
COMMENT WE WILL BRING BACK THE NUMBER OF CHRS IN M; 00074300
M:=L; 00074400
MARK(CURPAGE); 00074500
COMMENT MAKE CHANGES TO THE CHARACTER COUNT; 00074600
INDX[CURPAGE,0].SF:=T.SF-L; 00074700
INDX[CURPAGE,0].FF:=0; % PAGE IS CERTAINLY NOT FULL NOW 00074800
COMMENT AND WE ARE DONE WITH THE DELETION; 00074900
MOVE(INDX[CURPAGE,0],SKIP+1,POINTERS[CURBUFF](0)); 00075000
END 00075100
ELSE 00075200
BEGIN ARRAY A[0:RECSIZE-1]; 00075300
INDX[CURPAGE,0].CF:=I-1; 00075400
SETNTH(POINTERS[CURBUFF](0),INDX[CURPAGE,0],0); 00075500
IF I GTR 1 THEN 00075600
BEGIN 00075700
READRECS(POINTERS[CURBUFF](0),A,SKIP,NR,1,I-NR-1,RECSIZE); 00075800
MARK(CURPAGE); 00075900
IF NR=0 THEN 00076000
MOVE(POINTERS[CURBUFF](0),RECSIZE+SKIP,INDX[CURPAGE,0]) 00076100
END ELSE COMMENT FREE THE EMPTY PAGE; 00076200
BEGIN MARK(CURPAGE); 00076300
;TYPS[0].BF:=FREEPAGE(INDX,TYPS[0].BF,CURPAGE,CURPAGE); 00076400
UPDATE(TYPS,1,TYPE-1,1); TYPS[TYPE].AF:=T.AF+1; 00076500
COMMENT 00076600
IF MEMBUG.[6:1] THEN DUMPTYPES(MODE,TYPS,NTYPES); 00076700
END 00076800
END; 00076900
%------- MODE=7 ------- SEARCH FOR A RECORD FROM THE FILE --- 00077000
IF N GTR 3 THEN MESSAGE(14) ELSE 00077100
COMMENT RETURN RECORD CLOSEST (BUT LESS THAN OR EQUAL TO) TO 00077200
THE CONTENT OF -A-. A WILL BE REPLACED BY THE RECORD FOUND; 00077300
IF BOOLEAN((I:=TYPS[TYPE]).BOOL) THEN 00077400
MESSAGE(8) COMMENT BINARY SEARCH OF NON-SEQUENTIAL DATA; 00077500
ELSE 00077600
IF I.AF=I.BF THEN MESSAGE(9) COMMENT --NO STORAGE OF 00077700
THIS TYPE ALLOCATED AS YET; 00077800
ELSE BEGIN 00077900
INTEGER F,U,L; 00078000
ARRAY B[0:RECSIZE-1]; 00078100
U:=TYPS[TYPE].BF; L:=TYPS[TYPE].AF; 00078200
WHILE U-L GTR 1 DO 00078300
IF LESS(A,0,INDX[F:=(U+L) DIV 2,0],8,M) THEN U:=F ELSE L:=F; 00078400
CURBUFF:=BUFFNUMBER(CURPAGE:=L); 00078500
L:=0; U:=INDX[CURPAGE,0].CF; 00078600
IF L-U=0 THEN MESSAGE(10) COMMENT BINARY SEARCH FOUND 00078700
A PAGE WITH NO RECORDS; 00078800
ELSE BEGIN 00078900
WHILE U-L GTR 1 DO 00079000
BEGIN READRECS(POINTERS[CURBUFF](0),B,SKIP, 00079100
F:=(U+L) DIV 2,1,0,RECSIZE); 00079200
IF LESS(A,0,B,0,M) THEN U:=F ELSE L:=F 00079300
END; 00079400
COMMENT ----------------------------------- 00079500
ON INPUT: 00079600
N=0 IMPLIES DO NOT PLACE RECORD INTO FILE 00079700
IF RECORD IS FOUND. RETURN RELA- 00079800
TIVE POSITION OF THE CLOSEST RECORD 00079900
IN THIS PAGE. 00080000
N=1 " DO NO PLACE IN FILE. RETURN ABSO- 00080100
LUTE SUBSCRIPT OF CLOSSEST RECORD. 00080200
N=2 " PLACE RECORD INTO FILE IF NOT FOUND. 00080300
RETURN RELATIVE POSITION OF RECORD. 00080400
N=3 " PLACE RECORD INTO FILE, IF NOT 00080500
FOUND, RETURN ABS SUBSCRIPT OF 00080600
THE RECORD. 00080700
ON OUTPUT: 00080800
M=0 " RECORD FOUND WAS EQUAL TO RECORD 00080900
SOUGHT. 00081000
M=1 " RECORD FOUND WAS GREATER THAN THE 00081100
SOUGHT. 00081200
M=2 " RECORD FOUND WAS LESS THAN THE 00081300
RECORD SOUGHT. 00081400
; 00081500
READRECS(POINTERS[CURBUFF](0),B,SKIP,L,1,0,RECSIZE); 00081600
IF LESS(A,0,B,0,M) THEN M:=1 ELSE 00081700
IF LESS(B,0,A,0,M) THEN M:=2 ELSE 00081800
M:=0; 00081900
T:=0; IF BOOLEAN(N) THEN 00082000
FOR I:=TYPS[TYPE].AF STEP 1 UNTIL CURPAGE-1 DO 00082100
T:=T+INDX[I,0].CF; 00082200
IF N GTR 1 THEN IF M GEQ 1 THEN 00082300
MEMORY(2,TYPE,A,L+M-1,NR); 00082400
MOVE(B,RECSIZE,A); 00082500
N:=T+L; 00082600
END 00082700
END; 00082800
%------- MODE=8 ------- FILE OVERFLOW, FIX ARRAYS AND PAGES 00082900
BEGIN BOOLEAN TOG; 00083000
ARRAY A[0:PAGESIZE-1]; T:=NPAGES-N+1; 00083100
IF TOG:=(T DIV AREASIZE) LSS (NPAGES DIV AREASIZE ) OR 00083200
(T=NPAGES AND T MOD AREASIZE =0) THEN 00083300
MEMORY(14,TYPE,A,N,M); 00083400
FOR I:=T STEP 1 UNTIL NPAGES DO 00083500
BEGIN WRITE(NEWDISK[I],PAGESIZE,A[*]);INDX[I,P].PAGEF:=I END; 00083600
MARKEOF(SKIP,RECSIZE,NEWDISK(0)); 00083700
WRITE(NEWDISK[I]); 00083800
TYPS[0].BF:=FREEPAGE(INDX,TYPS[0].BF,T,NPAGES); 00083900
UPDATE(TYPS,1,NTYPES,NPAGES-T+1); 00084000
IF TOG THEN CLOSE(NEWDISK); 00084100
END; 00084200
%------- MODE=9 ------- FILE MAINTENANCE ------------------ 00084300
BEGIN BOOLEAN ITHPAGEIN; 00084400
INTEGER I,J,K,T1,T2,T3,M,W,Q; 00084500
ARRAY A,B[0:PAGESIZE-1]; 00084600
COMMENT 00084700
MONITOR PRINT(Q,W,N, I,J,K,T1,T2,T3,M,A,B); 00084800
IF I:=TYPS[0].BF LEQ NPAGES THEN 00084900
DO 00085000
BEGIN COMMENT OUTER "DO-LOOP" TO FIND TROUBLE WITH 00085100
THE FILE; 00085200
IF T1:=(Q:=INDX[I,0]).CF LSS L THEN COMMENT MAY BE CORRECTABLE;00085300
IF NOT BOOLEAN((Q:=TYPS[Q.TF]).BOOL) THEN 00085400
COMMENT -- THIS PAGE IS CORRECTABLE; 00085500
IF I NEQ NPAGES THEN 00085600
COMMENT -- THIS IS NOT THE LAST PAGE OF THE FILE; 00085700
IF (J:=I+1) LSS Q.BF THEN 00085800
COMMENT -- THIS IS NOT THE LAST PAGE OF THIS TYPE; 00085900
BEGIN COMMENT -- FIND RECORDS TO MOVE INTO 00086000
THIS PAGE; 00086100
DO IF T2:=INDX[J,0].CF GTR 0 THEN 00086200
COMMENT THIS PAGE HAS RECS TO MOVE; 00086300
BEGIN COMMENT HOW MANY; 00086400
IF T2 LSS K:=PS-T1 THEN K:=T2; 00086500
IF NOT ITHPAGEIN THEN 00086600
BEGIN COMMENT BRING IN PAGE I; 00086700
MOVE(POINTERS[BUFFNUMBER(I)](0), 00086800
PAGESIZE,B); ITHPAGEIN:=TRUE 00086900
END; 00087000
COMMENT -- BRING IN PAGE J; 00087100
CURBUFF:=BUFFNUMBER(CURPAGE:=J); 00087200
COMMENT -- MOVE SOME INTO A; 00087300
READRECS(POINTERS[CURBUFF](0),A,SKIP,0,K, 00087400
T2:=T2-K,RECSIZE); INDX[J,0].CF:=T2; 00087500
IF T2=0 THEN 00087600
COMMENT SET THIS PAGE FREE; 00087700
INDX[J,0]:=0; 00087800
SETNTH(POINTERS[CURBUFF](0),INDX[J,0],0); 00087900
MOVE(POINTERS[CURBUFF](0),RECSIZE+SKIP,INDX[J 00088000
,0]); MARK(CURPAGE); 00088100
COMMENT -- PUT THE RECORDS INTO PAGE I; 00088200
WRITERECS(B,A,SKIP,T1,K,0,RECSIZE); 00088300
END 00088400
ELSE K:=0 COMMENT SINCE NO CONTRI- 00088500
BUTION; 00088600
UNTIL T1:=T1+K GEQ PS OR J:=J+1 GEQ Q.BF; 00088700
INDX[I,0].CF:=T1; B[0]:=INDX[I,0]; 00088800
COMMENT -- PUT THE PAGE BACK OUT ON DISK; 00088900
MOVE(B,RECSIZE+SKIP,INDX[I,0]); 00089000
MOVE(B,PAGESIZE,POINTERS[CURBUFF:=BUFFNUMBER 00089100
(I)](0)); SORT(INDX,0,NPAGES,RECSIZE|8); 00089200
MARK(CURPAGE:=I); SETTYPES; 00089300
N:=1; 00089400
END 00089500
ELSE N:=0 COMMENT LAST PAGE OF THIS TYPE; 00089600
ELSE N:=0 COMMENT LAST PAGE OF FILE; 00089700
ELSE N:=0 COMMENT PAGE CANNOT BE CHANGED; 00089800
ELSE N:=0 COMMENT THIS PAGE IS NOT TOO SMALL; 00089900
END UNTIL I:=I+1 GTR NPAGES OR N NEQ 0 ELSE N:=0; 00090000
IF I GTR NPAGES THEN N:=REAL(WRITEBUFFER); 00090100
END OF FILE UPDATE; 00090200
%------- MODE=10 ------EEMERGENCY FILE MAINTENANCE ------- 00090300
DO MEMORY(9,TYPE,A,N,M) UNTIL N NEQ 1 00090400
%------- MODE=11 ------- SET THE KIND OF STORAGE FOR TYPE ----------00090500
;COMMENT TYPE "TYPE" STORAGE IS BEING SET TO SEQUENTIAL; 00090600
IF TYPE=0 THEN MESSAGE(4) ELSE 00090700
IF (T:=TYPS[TYPE]).AF= T.BF THEN TYPS[TYPE].BOOL:=1 ELSE 00090800
MESSAGE(15); COMMENT ATTEMPT TO CHANGE KINDS IN MIDSTREAM; 00090900
%------- MODE=12 ----------- ALTER STORAGE ALLOCATION RESOURCES--- 00091000
COMMENT N IS THE "FACTOR" (PERCENT OF RESOURCES | 100), 00091100
AND M IS THE STORAGE "LEVEL" (0 IS THE ONLY ONE THAT 00091200
DOES ANYTHING ON THE B5500); 00091300
BEGIN INTEGER J,K; 00091400
BOOLEAN TOG; 00091500
IF T:=N|(MBUFF-1)/100+1 GTR MAXBUFF THEN 00091600
BEGIN COMMENT ADD TO AVAILABLE LIST; 00091700
FOR I:=CDR(FIRST),CDR(AVAIL) DO 00091800
WHILE NOT NULL(I) DO 00091900
BEGIN BUF[I].FLAGB:=1; I:=CDR(BUF[I]); 00092000
END; 00092100
FOR I:=MAXBUFF+1 STEP 1 UNTIL T DO 00092200
BEGIN WHILE BUF[K:=K+1].FLAGB=1 DO; 00092300
BUF[K]:=0; RPLACD(BUF[K],CDR(AVAIL)); 00092400
RPLACD(AVAIL,K) 00092500
END; 00092600
MAXBUFF:=T; 00092700
FOR I:=1 STEP 1 UNTIL MBUFF DO BUF[I].FLAGB:=0; 00092800
END ELSE 00092900
IF T LSS MAXBUFF THEN 00093000
BEGIN COMMENT CUT DOWN ON THE NUMBER OF BUFFERS; 00093100
I:=CDR(FIRST); 00093200
FOR J:=1 STEP 1 UNTIL MAXBUFF DO 00093300
IF TOG THEN 00093400
IF NOT NULL(I) THEN 00093500
IF J GEQ T THEN 00093600
BEGIN K:=CDR(BUF[I]); BUF[I]:=0 00093700
; I:=K END 00093800
ELSE I:=CDR(BUF[I]) 00093900
ELSE 00094000
ELSE 00094100
IF TOG:=NULL(I) THEN 00094200
BEGIN J:=J-1; I:=CDR(AVAIL) 00094300
END 00094400
ELSE 00094500
IF J EQL T THEN 00094600
BEGIN K:=CDR(BUF[I]); RPLACD(BUF[I],0); 00094700
I:=K END ELSE 00094800
IF J GTR T THEN 00094900
BEGIN 00095000
IF BOOLEAN(BUF[I].CHANGEDBIT) THEN 00095100
WRITE(POINTERS[I][BUF[I].PAGEF-1]); 00095200
K:=CDR(BUF[I]); 00095300
CLOSE(POINTERS[I]); 00095400
BUF[I]:=0; I:=K 00095500
END ELSE I:=CDR(BUF[I]) 00095600
; 00095700
MAXBUFF:=T 00095800
END; 00095900
END; 00096000
%------- MODE=13 ------- RELEASE "TYPE" STORAGE TO SYSTEM ----------00096100
IF (T:=TYPS[TYPE]).BF GTR T.AF THEN 00096200
BEGIN INTEGER J; 00096300
J:=T.BF-1; 00096400
FOR I:=T.AF STEP 1 UNTIL J DO 00096500
BEGIN CURBUFF:=BUFFNUMBER(I); 00096600
SETNTH(POINTERS[CURBUFF](0),0,0); MARK(CURPAGE:=I); 00096700
END; 00096800
TYPS[0].BF:=FREEPAGE(INDX,TYPS[0].BF,T.AF,J); 00096900
UPDATE(TYPS,1,TYPE-1,J-T.AF+1); 00097000
TYPS[TYPE].BF:=T.AF; TYPS[TYPE].BOOL:=0; 00097100
END; 00097200
%------- MODE=14 ------ RELEASE ALL PAGES FOR TRANSITION -----------00097300
BEGIN INTEGER K; 00097400
I:=CDR(FIRST); 00097500
WHILE NOT NULL(I) DO 00097600
BEGIN IF BOOLEAN(BUF[I].CHANGEDBIT ) THEN WRITE(POINTERS[I] 00097700
[BUF[I].PAGEF-1]); CLOSE(POINTERS[I]); 00097800
K:=CDR(BUF[I]); BUF[I]:=0; 00097900
RPLACD(BUF[I],CDR(AVAIL)); RPLACD(AVAIL,I); I:=K 00098000
END ; CURPAGE:=CURBUFF:=-1; RPLACD(FIRST,0); 00098100
END; 00098200
END OF CASE STMT; 00098300
00098400
END OF INNER BLOCK; 00098500
END OF PROCEDURE; 00098600
INTEGER QM,QN; 00098700
ARRAY QA[0:0]; 00098800
PROCEDURE NAME(MFID,FID); VALUE MFID,FID; REAL MFID,FID; 00098900
BEGIN INTEGER I; FILL NEWDISK WITH MFID,FID; 00099000
FOR I:=0 STEP 1 UNTIL MBUFF DO 00099100
FILL POINTERS[I] WITH MFID,FID; 00099200
FILL ESTABLISH WITH MFID,FID; 00099300
SETPOINTERNAMES 00099400
END; 00099500
PROCEDURE SEQUENTIAL(UNIT); VALUE UNIT; INTEGER UNIT; 00099600
MEMORY(11,UNIT,QA,QN,QM); 00099700
INTEGER PROCEDURE CONTENTS(UNIT,N,AR); VALUE UNIT,N; 00099800
INTEGER UNIT,N; ARRAY AR[0]; 00099900
BEGIN 00100000
MEMORY(4,UNIT,AR,N,QM); CONTENTS:=QM; 00100100
END; 00100200
PROCEDURE DELETE1(UNIT,N); VALUE UNIT,N; INTEGER UNIT,N; 00100300
MEMORY(6,UNIT,QA,N,QM); 00100400
INTEGER PROCEDURE SEARCHORD(UNIT,REC,LOC,M); VALUE UNIT,M; 00100500
INTEGER UNIT,LOC,M; ARRAY REC[0]; 00100600
BEGIN LOC:=1; 00100700
MEMORY(7,UNIT,REC,LOC,M); 00100800
SEARCHORD:=M; 00100900
END; 00101000
PROCEDURE STOREORD(UNIT,REC,N); VALUE UNIT,N; INTEGER UNIT,N; 00101100
ARRAY REC[0]; 00101200
MEMORY(5,UNIT,REC,N,QM); 00101300
PROCEDURE STOREORDR(UNIT,REC,N); VALUE UNIT,N; INTEGER UNIT,N; 00101400
ARRAY REC[0]; 00101500
MEMORY(2,UNIT,REC,N,QM); 00101600
BOOLEAN PROCEDURE MAINTENANCE; 00101700
BEGIN MEMORY(9,0,QA,QN,QM); MAINTENANCE:=QN=1 00101800
END; 00101900
PROCEDURE WRAPUP; MEMORY(10,0,QA,QN,QM); 00102000
INTEGER PROCEDURE STORESEQ(UNIT,REC,N); VALUE UNIT,N; INTEGER UNIT, N; 00102100
ARRAY REC[0]; 00102200
BEGIN 00102300
MEMORY(5,UNIT,REC,QN,N); STORESEQ:=QN; 00102400
END; 00102500
PROCEDURE DELETEN(UNIT,N,M); VALUE UNIT,N,M; INTEGER UNIT,N,M; 00102600
BEGIN M:=M-N; 00102700
DO MEMORY(6,UNIT,QA,N,QM) UNTIL M:=M-1 LSS 0; 00102800
END; 00102900
INTEGER PROCEDURE NEXTUNIT; 00103000
BEGIN MEMORY(1,0,QA,QN,1); NEXTUNIT:=QN 00103100
END; 00103200
INTEGER PROCEDURE SIZE(UNIT); VALUE UNIT; INTEGER UNIT; 00103300
BEGIN MEMORY(3,UNIT,QA,QN,QM); SIZE:=QM 00103400
END; 00103500
PROCEDURE ALLOCATE(J,FACTOR); VALUE J,FACTOR; INTEGER J; 00103600
REAL FACTOR; 00103700
BEGIN 00103800
QN:=ENTIER( ABS( (FACTOR | 100) MOD 101)); 00103900
MEMORY(12,0,QA,QN,J) 00104000
END; 00104100
PROCEDURE RELEASEUNIT(UNIT); VALUE UNIT; INTEGER UNIT; 00104200
MEMORY(13,UNIT,QA,QN,QM); 00104300
DEFINE 00104400
ALLOWQUESIZE=4#, 00104500
ACOUNT=ACCUM[0].[1:11]#, 00104600
DATADESC=[1:1]#, 00104700
SCALAR=[4:1]#, 00104800
NAMED=[3:1]#, 00104900
CHRMODE=[5:1]#, 00105000
CHECKT=5#, % NUMBER OF TIMES THRU EXECUTE BEFORE CHECK 00105100
CCIF=18:36:12#, 00105200
CDID=1:43:5#, 00105300
CSPF=30:30:18#, 00105400
CRF=24:42:6#, 00105500
CLOCF=6:30:18#, 00105600
PF=[1:17]#, 00105700
XEQMODE=1#, 00105800
FUNCMODE=2#, 00105900
CALCMODE=0#, 00106000
INPUTMODE=3#, 00106100
ERRORMODE=4#, 00106200
FUNCTION=1#, 00106300
CURRENTMODE = PSRM[0]#, 00106400
VARIABLES = PSRM[1]#, 00106500
VARSIZE = PSRM[2]#, 00106600
FUNCPOINTER = PSRM[3]#, 00106700
FUNCSEQ = PSRM[4]#, 00106800
CURLINE = PSRM[5]#, 00106900
STACKBASE = PSRM[6]#, 00107000
INCREMENT = STACKBASE#, %FUNCMODE/CALCMODE 00107100
SYMBASE = PSRM[7]#, 00107200
FUNCSIZE = SYMBASE#, %FUNCMODE/CALCMODE 00107300
USERMASK = PSRM[8]#, 00107400
SEED = PSRM[10]#, 00107500
ORIGIN = PSRM[11]#, 00107600
FUZZ = PSRM[12]#, 00107700
FSTART = 9#, %PSR[9] IS WHERE NAME OF CURRENTLY EDITED FCN GOES 00107800
PSRSIZE = 13#, 00107900
PSR = PSRM[*]#, 00108000
WF=[18:8]#, 00108100
WDSPERREC=10#, 00108200
WDSPERBLK=30#, 00108300
NAREAS=10#, 00108400
SIZEAREAS=210#, 00108500
LIBF1=[6:15]#, 00108600
LIBF2=[22:16]#, 00108700
LIBF3=[38:10]#, 00108800
LIBSPACES=1#, 00108900
IDENT=RESULT=1#, 00109000
SPECIAL=RESULT=3#, 00109100
NUMERIC=RESULT=2#, 00109200
REPLACELOC=0#, 00109300
REPLACEV=4#, 00109400
SPF=[30:18]#, 00109500
RF=[24:6]#, 00109600
DID=[1:5]#, 00109700
XRF=[12:18]#, 00109800
DDPNSW=30#, % DATA DESC PRESENT NAMED SCALAR WORD 00109900
DDNNVW=20#, %DATA DESC NON-PRES NAMED VECTOR WORD 00110000
DDNUVW=16#, %DATA DESC NONPRES..(POINTS INTO SYM TAB FOR LOCALS) 00110100
DDPUVW=24#, % DATA DESC PRESENT UNNAMED VECTOR WORD 00110200
DDNNSW=22#, % DATA DESC NON-PRES NAMED SCALAR WORD 00110300
PDC=10#, % DROG DESC CALC MODE 00110400
INTO=0#, 00110500
DDPUSW=26#, % DATA DESC PRESENT UNNAMED SCALAR WORK (MODE) 00110600
DDPUSC=27#, % DATA DESC PRESENT UNNAMED SCALAR CHR 00110700
DDPUVC=25#, % DATA DESC PRESENT UNNAMED VECTOR CHR 00110800
DDPNVC=29#, %DATA DESC PRES PERMANENT VECTOR CHAR MODE 00110900
DDPNVW=28#, %DATA DESC PRES NAMED VEC WORD (NAMED=PERMANENT) 00111000
OUTOF=1#, 00111100
NAMEDNULLV=0&7[1:45:3]#, %DLUDGE...NAMED VERSION OF NULLV 00111200
BACKP=[6:18]#, 00111300
SCALARDATA=0#, 00111400
ARRAYDATA=2#, 00111500
DATATYPE=[4:1]#, 00111600
ARRAYTYPE=[5:1]#, 00111700
CHARARRAY=1#, 00111800
NUMERICARRAY=0#, 00111900
BLOCKSIZE=30#, %#WORDS OF CONTIGUOUS DATA IN SEQUENTIAL STORE 00112000
VARTYPE=[42:6]#, 00112100
WS=WORKSPACE#, 00112200
DIMPTR=SPF#, 00112300
INPTR=BACKP#, 00112400
QUADIN=[18:3]#, 00112500
QUADINV=18:45:3#, 00112600
STATEVECTORSIZE=16#, 00112700
SUSPENDED=[5:1]#, 00112800
SUSPENDVAR=[2:1]#, 00112900
CTYPEF=3:45:3#, 00113000
CSUSVAR=2:47:1#, 00113100
CNAMED=3:47:1#, 00113200
MAXWORDSTORE=3960#, %APL PREVENTS CREATION OF ARRAYS BIGGER THAN 00113300
%3960 ELEMENTS. THIS NUMBER IS THE PRODUCT OF 00113400
%4,(NUMBER OF POINTERS TO SEQUENTIAL STORE 00113500
%BLOCKS THAT ARE STORED IN ONE WORD) 00113600
%30, (BLOCKSIZE), 00113700
%AND 33, (SIZE OF ARRAY USED TO STORE THESE 00113800
%POINTERS IN GETARRAY, MOVEARRAY, AND 00113900
%RELEASEARRAY). SUBSCRIPTS ALLOWS 8|3960 00114000
%ELEMENTS IF THEY ARE CHARACTERS. 00114100
%HOWEVER, SP WILL GET FULL BEFORE THAT SINCE 00114200
%BIGGEST SP SIZE IS CURRENTLY 3584 00114300
MAXBUFFSIZE=30#, 00114400
MAXHEADERARGS=30#, 00114500
BUFFERSIZE=BUFFSIZE#, 00114600
LINEBUFFER=LINEBUFF#, 00114700
LINEBUFF = OUTBUFF[*]#, 00114800
APPENDTOBUFFER=APPENDTOBUFF#, 00114900
FOUND=TARRAY[0]#, 00115000
EOB=TARRAY[1]#, 00115100
MANT=TARRAY[2]#, 00115200
MANTLEN=TARRAY[3]#, 00115300
FRAC=TARRAY[4]#, 00115400
FRACLEN=TARRAY[5]#, 00115500
POWER=TARRAY[6]#, 00115600
POWERLEN=TARRAY[7]#, 00115700
MANTSIGN=TARRAY[8]#, 00115800
TABSIZE = 43#, 00115900
LOGINCODES=1#, 00116000
LOGINPHRASE=2#, 00116100
LIBRARY=1#, 00116200
WORKSPACEUNIT=2#, 00116300
RTPAREN=9#, 00116400
MASTERMODE=USERMASK.[1:1]#, 00116500
EDITOG=USERMASK.[2:1]#, 00116600
POLBUG=USERMASK.[3:1]#, 00116700
FPTF=9#, % FUNCTION POINTER FIELD (STARTS AT CHR POS 9) 00116800
FSQF=11#, % FUNCTION SEQNTL FIELD 00116900
FFL=2#, % FUNCTION FIELD LENGTH (2 CHR POSITIONS) 00117000
CRETURN=3:47:1#, 00117100
RETURNVALUE=[3:1]#, 00117200
CNUMBERARGS=4:46:2#, 00117300
NUMBERARGS=[4:2]#, 00117400
RETURNVAL=1#, 00117500
NOSYNTAX=USERMASK.[4:1]#, 00117600
LINESIZE=USERMASK.[41:7]#, 00117700
DIGITS=USERMASK.[37:4]#, 00117800
SUSPENSION=USERMASK.SUSPENDED#, 00117900
SAVEDWS=USERMASK.[7:1]#, 00118000
DELTOG=USERMASK.[6:1]#, 00118100
DELCHR="$"#, %USED IN DELPRESENT (IN FUNCTIONHANDLER) 00118200
MAXMESS=27#, 00118300
USERTOP=21#, 00118400
MARGINSIZE=6#, 00118500
LFTBRACKET=SPECIAL AND ACCUM[0]=11#, 00118600
QUADV=SPECIAL AND ACCUM[0]=10#, 00118700
QUOTEV=ACCUM[0]=20#, 00118800
EXPANDV=38#, 00118900
SLASHV=6#, 00119000
GOTOV=5#, 00119100
DOTV=17#, 00119200
ROTV=37#, 00119300
RGTBRACKET=SPECIAL AND ACCUM[0]=12#, 00119400
DELV=SPECIAL AND ACCUM[0]=13#, 00119500
PLUS = SPECIAL AND ACCUM[0] = 48#, 00119600
MINUS = SPECIAL AND ACCUM[0] = 49#, 00119700
NEGATIVE = SPECIAL AND ACCUM[0] = 51#, 00119800
TIMES = SPECIAL AND ACCUM[0] = 50#, 00119900
LOGS = SPECIAL AND ACCUM[0] = 54#, 00120000
SORTUP = SPECIAL AND ACCUM[0] = 55#, 00120100
SORTDN = SPECIAL AND ACCUM[0] = 56#, 00120200
NAND = SPECIAL AND ACCUM[0] = 58#, 00120300
NOR = SPECIAL AND ACCUM[0] = 59#, 00120400
TAKE = SPECIAL AND ACCUM[0] = 60#, 00120500
DROPIT = SPECIAL AND ACCUM[0] = 61#, 00120600
LFTARROW = SPECIAL AND ACCUM[0] = 04#, 00120700
TRANS = SPECIAL AND ACCUM[0] = 05#, 00120800
SLASH = SPECIAL AND ACCUM[0] = 06#, 00120900
INTDIVIDE = SPECIAL AND ACCUM[0] = 07#, 00121000
LFTPAREN = SPECIAL AND ACCUM[0] = 08#, 00121100
RGTPAREN = SPECIAL AND ACCUM[0] = 09#, 00121200
QUOTEQUAD = SPECIAL AND ACCUM[0] = 14#, 00121300
SEMICOLON = SPECIAL AND ACCUM[0] = 15#, 00121400
COMMA = SPECIAL AND ACCUM[0] = 16#, 00121500
DOT = SPECIAL AND ACCUM[0] = 17#, 00121600
STAR = SPECIAL AND ACCUM[0] = 18#, 00121700
AT = SPECIAL AND ACCUM[0] = 19#, 00121800
QUOTE = SPECIAL AND ACCUM[0] = 20#, 00121900
BOOLAND = SPECIAL AND ACCUM[0] = 21#, 00122000
BOOLOR = SPECIAL AND ACCUM[0] = 22#, 00122100
BOOLNOT = SPECIAL AND ACCUM[0] = 23#, 00122200
LESSTHAN = SPECIAL AND ACCUM[0] = 24#, 00122300
LESSEQ = SPECIAL AND ACCUM[0] = 25#, 00122400
EQUAL = SPECIAL AND ACCUM[0] = 26#, 00122500
GRTEQ = SPECIAL AND ACCUM[0] = 27#, 00122600
GREATER = SPECIAL AND ACCUM[0] = 28#, 00122700
NOTEQ = SPECIAL AND ACCUM[0] = 29#, 00122800
CEILING = SPECIAL AND ACCUM[0] = 30#, 00122900
FLOOR = SPECIAL AND ACCUM[0] = 31#, 00123000
STICK = SPECIAL AND ACCUM[0] = 32#, 00123100
EPSILON = SPECIAL AND ACCUM[0] = 33#, 00123200
RHO = SPECIAL AND ACCUM[0] = 34#, 00123300
IOTA = SPECIAL AND ACCUM[0] = 35#, 00123400
TRACE = SPECIAL AND ACCUM[0] = 36#, 00123500
PHI = SPECIAL AND ACCUM[0] = 37#, 00123600
EXPAND = SPECIAL AND ACCUM[0] = 38#, 00123700
BASVAL = SPECIAL AND ACCUM[0] = 39#, 00123800
EXCLAMATION = SPECIAL AND ACCUM[0] = 40#, 00123900
MINUSLASH = SPECIAL AND ACCUM[0] = 41#, 00124000
QUESTION = SPECIAL AND ACCUM[0] = 42#, 00124100
OSLASH = SPECIAL AND ACCUM[0] = 43#, 00124200
TAU = SPECIAL AND ACCUM[0] = 44#, 00124300
CIRCLE = SPECIAL AND ACCUM[0] = 45#, 00124400
LOCKIT =IDENT AND ACCUM[0]="4LOCK "#, 00124500
COLON = SPECIAL AND ACCUM[0] = 47#, 00124600
QUADLFTARROW=51#, 00124700
REDUCT=52#, 00124800
ROTATE=53#, 00124900
SCANV=57#, 00125000
LINEBUFFSIZE=17#, 00125100
MAXPOLISH=100#, MESSIZE=10#, 00125200
MAXCONSTANT=30#, 00125300
MAXMEMACCESSES=3584#, %MAXSPROWS | SPRSIZE 00125400
MAXSYMBOL=30#, 00125500
MAXSPROWS=28#, 00125600
TYPEFIELD=[3:3]#, 00125700
OPTYPE=[1:2]#, 00125800
LOCFIELD=BACKP#, 00125900
ADDRFIELD=SPF#, 00126000
SYMTYPE=[3:3]#, 00126100
OPERAND=5#, 00126200
CONSTANT=2#, 00126300
OPERATOR=3#, 00126400
LOCALVAR=4#, 00126500
SYMTABSIZE=1#, 00126600
LFTPARENV=8#, 00126700
RGTPARENV=9#, 00126800
LFTBRACKETV=11#, 00126900
RGTBRACKETV=12#, 00127000
SEMICOLONV=15#, 00127100
QUAD=10#, 00127200
QQUAD=14#, 00127300
LFTARROWV=4#, 00127400
SORTUPV=55#, 00127500
SORTDNV=56#, 00127600
ALPHALABEL=1#, 00127700
NUMERICLABEL=2#, 00127800
NEXTLINE=0#, 00127900
ERRORCOND=3#, 00128000
PRESENCE=[2:1]#, 00128100
CHANGE=[1:1]#, 00128200
XEQ=1#, 00128300
CLEARCORE=2#, 00128400
WRITECORE=3#, 00128500
%%% 00128600
%%% 00128700
XEQUTE=1#, 00128800
SLICE=120#, %TIME SLICE IN 60THS OF A SECOND 00128900
ALLOC=2#, 00129000
WRITEBACK=3#, 00129100
LOOKATSTACK=5#, 00129200
00129300
LEN=[1:23]#, 00129400
NEXT=[24:24]#, 00129500
LOC=L.[30:11],L.[41:7]#, 00129600
NOC=N.[30:11],N.[41:7]#, 00129700
MOC=M.[30:11],M.[41:7]#, 00129800
SPRSIZE=128#, % SP ROW SIZE 00129900
NILADIC=0#, 00130000
MONADIC=1#, 00130100
DYADIC=2#, 00130200
TRIADIC=3#, 00130300
DEPTHERROR=1#, 00130400
DOMAINERROR=2#, 00130500
INDEXERROR=4#, 00130600
LABELERROR=5#, 00130700
LENGTHERROR=6#, 00130800
NONCEERROR=7#, 00130900
RANKERROR=8#, 00131000
SYNTAXERROR=9#, 00131100
SYSTEMERROR=10#, 00131200
VALUEERROR=11#, 00131300
SPERROR=12#, 00131400
KITEERROR=13#, 00131500
STREAMBASE=59823125#, 00131600
APLOGGED=[10:1]#, 00131700
APLHEADING=[11:1]#, 00131800
CSTATION = STATION#, 00131900
CAPLOGGED=10:47:1#, 00132000
CAPHEADING=11:47:1#, 00132100
APLCODE = STATIONPARAMS#, 00132200
00132300
00132400
SPECMODE = BOUNDARY.[1:3]#, 00132500
DISPLAYING=1#, 00132600
EDITING=2#, 00132700
DELETING=3#, 00132800
RESEQUENCING=4#, 00132900
LOWER = BOUNDARY.[4:22]#, 00133000
UPPER = BOUNDARY.[26:22]#, 00133100
OLDBUFFER = OLDINPBUFFER[*]#, 00133200
00133300
ENDEFINES=#; 00133400
REAL ADDRESS, ABSOLUTEADDRESS, 00133500
LADDRESS; 00133600
BOOLEAN LINETOG; %GO TO NEXT LINE IF TRUE WHEN WRITING OUT 00133700
INTEGER BUFFSIZE,ITEMCOUNT,RESULT, 00133800
LOGINSIZE, 00133900
%%% 00134000
ERR, 00134100
NROWS, 00134200
%%% 00134300
CUSER; 00134400
LABEL ENDOFJOB,TRYAGAIN; 00134500
REAL GT1,GT2,GT3; 00134600
DEFINE LINE=PRINT#; 00134700
SAVE ARRAY BUFFER[0:MAXBUFFSIZE]; 00134800
ARRAY TARRAY[0:8], 00134900
COMMENT PROGRAM STATE REGISTER; 00135000
PSRM[0:PSRSIZE], 00135100
OLDINPBUFFER[0:MAXBUFFSIZE], 00135200
SP[0:27, 0:SPRSIZE-1], 00135300
IDTABLE[0:TABSIZE], 00135400
MESSTAB[0:MAXMESS], 00135500
JIGGLE[0:0], 00135600
SCR[0:2], 00135700
CORRESPONDENCE[0:7], 00135800
ACCUM[0:MAXBUFFSIZE]; 00135900
DEFINE OUTBUFFSIZE=29#,CLOGGED=7:47:1#,STU=15:9:9#; 00136000
ARRAY OUTBUFF[0:OUTBUFFSIZE]; 00136100
ALPHA STATION, JOBNUM, STATIONPARAMS, BOUNDARY; 00136200
INTEGER CHRCOUNT, WORKSPACE; 00136300
00136400
STREAM PROCEDURE INITBUFF(B,BUFFSIZE); VALUE BUFFSIZE; 00136500
BEGIN 00136600
DI~B; BUFFSIZE(DS~8LIT" "); DS~LIT"~"; 00136700
END; 00136800
STREAM PROCEDURE TRANSFER(A,AS,B,BS,L); VALUE AS,BS,L; 00136900
BEGIN LOCAL T,U,V; 00137000
SI:=LOC AS; DI:=LOC T; DI:=DI+1; DS:=7CHR; 00137100
SI:=LOC BS; DI:=LOC U; DI:=DI+1; DS:=7CHR; 00137200
SI:=LOC L; DI:=LOC V; DI:=DI+1; DS:=7CHR; 00137300
SI:=A; T(2(SI:=SI+32)); SI:=SI+AS; 00137400
DI:=B; U(2(DI:=DI+32)); DI:=DI+BS; 00137500
V(2(DS:=32CHR)); DS:=L CHR; 00137600
END; 00137700
REAL PROCEDURE NUMBER; FORWARD; %LINE 111500 00137800
BOOLEAN PROCEDURE SCAN; 00137900
BEGIN 00138000
REAL STREAM PROCEDURE GNC(ADDR,ACC); VALUE ADDR; 00138100
BEGIN SI:=ADDR; DI:=ACC; DI:=DI+7; DS:=CHR; GNC:=SI; 00138200
DI:=ACC; SKIP DB; DS:=SET; END OF GNC; 00138300
REAL STREAM PROCEDURE RESWD(TAB,BUF,ADDR,EOB,FOUND,K); 00138400
VALUE ADDR,K; 00138500
BEGIN 00138600
LOCAL T,TSI,TDI; 00138700
LABEL TRY,L,KEEPGOING,FINIS,RESTORE; 00138800
LABEL NUMBERFOUND; 00138900
DI:=EOB; DS:=8LIT"0"; DI:=FOUND; DS:=8LIT"0"; 00139000
SI:=ADDR; 00139100
L: IF SC NEQ " " THEN GO TO KEEPGOING; 00139200
SI:=SI+1; 00139300
GO TO L; 00139400
KEEPGOING: 00139500
RESWD:=SI; 00139600
ADDR:=SI; 00139700
IF SC GEQ "0" THEN IF SC LEQ "9" THEN GO TO NUMBERFOUND; 00139800
IF SC="#" THEN GO TO NUMBERFOUND; 00139900
IF SC="@" THEN GO TO NUMBERFOUND; 00140000
IF SC="." THEN 00140100
BEGIN SI:=SI+1; 00140200
IF SC GEQ "0" THEN IF SC LEQ "9" THEN 00140300
GO TO NUMBERFOUND; SI:=SI-1; 00140400
END; 00140500
DI:=LOC T; DS:=2RESET; DS:=2SET; DS:=2RESET; 00140600
DI:=LOC T; 00140700
IF SC=DC THEN 00140800
BEGIN DI:=EOB; DI:=DI+7; DS:=LIT"1"; 00140900
GO TO FINIS 00141000
END; 00141100
SI:=TAB; TSI:=SI; 00141200
TRY: 00141300
IF SC="0" THEN 00141400
BEGIN SI:=ADDR; 00141500
IF SC=ALPHA THEN 00141600
IF SC GEQ"0" THEN 00141700
IF SC LEQ "9" THEN 00141800
NUMBERFOUND: 00141900
TALLY:=2 ELSE TALLY := 0 00142000
ELSE TALLY:=1 00142100
ELSE TALLY:=3; 00142200
T:=TALLY; SI:=LOC T; SI:=SI+7; DI:=FOUND; DI:=DI+7; 00142300
DS:=CHR; GO FINIS; 00142400
END; 00142500
DI:=LOC T; DI:=DI+7; DS:=CHR; 00142600
DI:=ADDR; 00142700
IF T SC=DC THEN 00142800
BEGIN 00142900
TSI:=SI; TDI:=DI; SI:=SI-1; 00143000
IF SC=ALPHA THEN 00143100
BEGIN DI:=DI+16; SI:=TDI; 00143200
IF SC NEQ " " THEN IF SC =ALPHA THEN ; 00143300
END; 00143400
SI:=TSI; 00143500
END ELSE GO TO RESTORE; 00143600
IF TOGGLE THEN 00143700
RESTORE: 00143800
BEGIN SI:=SI+K; DI:=ADDR; GO TO TRY 00143900
END; 00144000
DI:=FOUND; DS:=K OCT; 00144100
DI:=TDI; RESWD:=DI; 00144200
FINIS: 00144300
END; 00144400
REAL STREAM PROCEDURE ACCUMULATE(ACC,EOB,ADDR); VALUE ADDR; 00144500
BEGIN LOCAL T; LABEL EOBL,E,ON,L; 00144600
DI:=ACC; 9(DS:=8LIT" "); 00144700
DI:=EOB; DS:=8LIT"0"; SI:=ADDR; DI:=LOC T; SKIP 2 DB; 00144800
DS:=2SET; DI:=LOC T; 00144900
63(IF SC=ALPHA THEN TALLY:=TALLY+1 ELSE JUMP OUT TO E; 00145000
SI:=SI+1); 00145100
L: IF SC=ALPHA THEN BEGIN SI:=SI+1; GO L END ELSE GO ON; 00145200
IF SC=" " THEN GO ON; 00145300
E: IF SC = DC THEN ; 00145400
SI:=SI-1; IF TOGGLE THEN GO TO EOBL ELSE GO ON; 00145500
EOBL: DI:=EOB; DI:=DI+7; DS:=LIT"1"; 00145600
ON: ACCUMULATE:=SI; DI:=ACC; T:=TALLY; SI:=LOC T; SI:=SI+6; 00145700
DS:=2CHR; SI:=ADDR; DS:=T CHR; 00145800
END OF ACCUMULATE; 00145900
BOOLEAN STREAM PROCEDURE ARROW(ADDR,I); VALUE ADDR,I; 00146000
BEGIN SI:=ADDR; SI:=SI-1; DI:=LOC I; DI:=DI+7; 00146100
IF SC=DC THEN TALLY:=1; ARROW :=TALLY 00146200
END OF ARROW; 00146300
IF NOT BOOLEAN(EOB) THEN BEGIN 00146400
LADDRESS:=ADDRESS; 00146500
ADDRESS:=RESWD(IDTABLE,BUFFER,ADDRESS,EOB,FOUND,2); 00146600
IF RESULT:=FOUND NEQ 0 THEN BEGIN 00146700
IF RESULT=1 THEN ADDRESS:=ACCUMULATE(ACCUM,EOB,ADDRESS) 00146800
ELSE IF RESULT=2 THEN ACCUM[0]:=NUMBER 00146900
ELSE IF RESULT=3 THEN ADDRESS:=GNC(ADDRESS,ACCUM) 00147000
ELSE BEGIN ACCUM[0]:=RESULT; RESULT:=3 END; 00147100
ITEMCOUNT:=ITEMCOUNT+1; 00147200
SCAN:=TRUE; 00147300
IF ARROW(ADDRESS,31) THEN 00147400
BEGIN EOB:=1; SCAN:=FALSE END; 00147500
END ELSE EOB:=1; 00147600
END; 00147700
END OF THE SCAN PROCEDURE; 00147800
PROCEDURE FORMROW(CC,BL,A,S,N); VALUE CC,BL,S,N; 00147900
INTEGER CC,BL,S,N; ARRAY A[0]; FORWARD 00148000
; 00148100
PROCEDURE INDENT(R); VALUE R; REAL R; FORWARD; 00148200
PROCEDURE TERPRINT; FORWARD; 00148300
PROCEDURE PROCESS(MODE);VALUE MODE;INTEGER MODE; FORWARD; 00148400
REAL STREAM PROCEDURE ABSADDR(A); 00148500
BEGIN SI:=A; ABSADDR:=SI 00148600
END; 00148700
BOOLEAN PROCEDURE LIBRARIAN(MFID,FID); VALUE MFID,FID; 00148800
REAL MFID,FID; 00148900
BEGIN 00149000
REAL ARRAY A[0:6]; FILE DF DISK(1,1); 00149100
REAL T; 00149200
COMMENT LIBRARIAN IS TRUE IF MFID/FID IS PRESENT ON DISK; 00149300
FILL DF WITH MFID,FID; 00149400
SEARCH(DF,A[*]); 00149500
LIBRARIAN:= 00149600
A[0]!-1; 00149700
END; 00149800
FILE SPO 11(1,3); 00149900
PROCEDURE SPOUT(K); VALUE K; INTEGER K; 00150000
BEGIN FORMAT ERRF("APL ERROR:",I8,A1); 00150100
WRITE(SPO,ERRF,K,31); 00150200
END; 00150300
PROCEDURE INITIALIZETABLE; 00150400
BEGIN DEFINE STARTSEGMENT= #; 00150500
INTEGER I; 00150600
LADDRESS:= 00150700
ABSOLUTEADDRESS:=ABSADDR(BUFFER); 00150800
BIGGEST := REAL(NOT FALSE) & 0[1:46:2]; 00150900
NULLV := 0 & 3[1:46:2]; 00151000
STATUSWORD~REAL(BOOLEAN(STATUSWORD) OR BOOLEAN(1)); 00151100
JOBNUM~TIME(-1); 00151200
STATION~0&1[CLOGGED]&STATUSWORD[STU]; 00151300
FILL JIGGLE[*] WITH OCT5757575757575737;%CARRIAGE RETURNS LEFT ARROW00151400
FILL IDTABLE[*] WITH 00151500
"1+481-49", "1&501%07", "1.171@19", "1#411(08", 00151600
"1)091/06", "3XEQ623L", "OG541;15", OCT0333777601040177, 00151700
%CAST IN ABOVE LINE IS REALLY 3["]141" 00151800
"202:=042", "[]101[11", "1]123AND", "212OR223", 00151900
"NOT233LS", "S243LEQ2", "53GEQ273", "GTR283NE", "Q292=:05", 00152000
"2GO051=2", "63MAX304", "CEIL303F", "LR313MIN", 00152100
"314RESD3","23ABS323","RHO341*1","84IOTA35", 00152200
"1|384RND", "M425TRAN", "S431$133", "PHI374FA", 00152300
"CT404COM", "B406CIRC", "LE456SOR", "TUP556SO", 00152400
"RTDN561:", "474NAND5", "83NOR594", "TAKE604D", 00152500
"ROP613RE", "P446BASV", "AL393EPS", "331,1600"; 00152600
COMMENT IDTABLE IS TABLE OF RESERVED WORDS AND SPECIAL SYMBOLS. 00152700
FORMAT IS NUMBER OF CHARACTERS IN SYMBOL, FOLLOWED BY SYMBOL 00152800
ITSELF, FOLLOWED BY A TWO-DIGIT DECIMAL CODE WHICH APL USES 00152900
FOR THE RESERVED WORD--LIKE IN THE EXECUTION CASE STATEMENT AND 00153000
IN SYNTAX CHECKING. FOR SCAN TO WORK, THE TWO-DIGIT CODE MUST 00153100
BE GREATER THAN 3 AND IDTABLE MUST HAVE AT LEAST ONE "0" AT THE 00153200
END TO MARK THE END. TABSIZE IS THE DEFINE (LINE 30000) GIVING 00153300
THE SIZE OF TDTABLE; 00153400
IF STACKSIZE=0 THEN STACKSIZE:=100 ELSE 00153500
IF STACKSIZE GTR 1022 THEN STACKSIZE:=1022; 00153600
BUFFSIZE:=MAXBUFFSIZE; 00153700
LINETOG := TRUE; %USUALLY GO TO NEXT LINE WHEN WRITING OUT 00153800
00153900
INITBUFF(OUTBUFF, 10); 00154000
INITBUFF(BUFFER,BUFFSIZE); 00154100
NROWS:=-1; 00154200
NAME(LIBJOB,TIME(-1)); 00154300
FILL MESSTAB[*] WITH 00154400
"4SAVE ", 00154500
"4LOAD ", 00154600
"5CLEAR ", 00154700
"4COPY ", 00154800
"4VARS ", 00154900
"3FNS ", 00155000
"6LOGGED", 00155100
"3MSG ", 00155200
"5WIDTH ", 00155300
"3OPR ", 00155400
"6DIGITS", 00155500
"3OFF ", 00155600
"6ORIGIN", 00155700
"4SEED ", 00155800
"4FUZZ ", 00155900
"3SYN ", 00156000
"5NOSYN ", 00156100
"5STORE ", 00156200
"5ABORT ", 00156300
"2SI ", 00156400
"3SIV ", 00156500
"5ERASE ", 00156600
%--------------MASTERMODE BELOW HERE...(SEE USERTOP)-------- 00156700
"6ASSIGN", 00156800
"6DELETE", 00156900
"4LIST ", 00157000
"5DEBUG ", 00157100
"5FILES "; 00157200
00157300
IF LIBSIZE=-1 THEN 00157400
BEGIN LIBSIZE~1;GTA[0]~" ";STOREORD(LIBRARY,GTA,0);WRAPUP; 00157500
END ELSE BEGIN LIBSIZE~SIZE(LIBRARY); 00157600
FOR I~1 STEP 1 UNTIL LIBSIZE-1 DO 00157700
BEGIN GT1~CONTENTS(LIBRARY,I,ACCUM); 00157800
IF NOT LIBRARIAN(ACCUM[0],TIME(-1)) THEN 00157900
BEGIN DELETE1(LIBRARY,I);LIBSIZE~LIBSIZE-1;END; 00158000
IF (LOGINSIZE:=SIZE(LOGINCODES)=0) THEN 00158100
END; 00158200
END; 00158300
FILL CORRESPONDENCE[*] WITH 00158400
OCT1111111111110311, 00158500
OCT1111111111111111, 00158600
OCT1104111121221113, 00158700
OCT2014151617100706, 00158800
OCT1111111111111112, 00158900
OCT1111111111111100, 00159000
OCT0201111111251111, 00159100
OCT2324111111111111; 00159200
COMMENT CORRESPONDENCE GIVES THE CORRESPONDENCE BETWEEN THE 00159300
APL CODES FOR DYADIC SCALAR OPERATORS (EXCEPT CIRCLE) AND 00159400
THEIR POSITIONS IN THE "CASE STATEMENT" IN "OPERATION". 00159500
E.G. APL CODE 7 IS "OPERATION" CODE 3 IN OCTAL (FOR DIVIDE). 00159600
IF N-TH CHARACTER IN CORRESPONDECE IS OCTAL 11, THEN N 00159700
IS NOT AN APL CODE FOR A DYADIC SCALAR OPERATOR. CHARACTER 00159800
COUNT STARTS AT 1 FOR FIRST CHARACTER. TO MAKE IT COME OUT 00159900
RIGHT, STREAM PROCEDURE GETOP IS ACTUALLY CALLED WITH APL 00160000
OPERATION CODE MINUS 1; 00160100
END; 00160200
REAL STREAM PROCEDURE CONV(ADDR,N); 00160300
VALUE N,ADDR; 00160400
BEGIN SI:=ADDR; 00160500
DI:=LOC CONV; 00160600
DS:=N OCT; END; 00160700
REAL STREAM PROCEDURE BUMP(ADDR,N); VALUE ADDR,N; 00160800
BEGIN SI:=ADDR; SI:=SI+N; BUMP:=SI; END; 00160900
REAL PROCEDURE NUMBER; 00161000
BEGIN REAL NCHR; 00161100
LABEL GETFRAC,GETPOWER,QUIT,KITE; 00161200
MONITOR EXPOVR; 00161300
REAL PROCEDURE INTCON(COUNT); VALUE COUNT; 00161400
REAL COUNT; 00161500
BEGIN REAL TLO,THI,T; INTEGER N; 00161600
BOOLEAN DPTOG; DEFINE ADDR=ADDRESS#; 00161700
COMMENT: VALUE OF INTCON IS THE CONVERSION OF AN INTEGER 00161800
CONSISTING OF COUNT NUMERICAL CHARACTERS STARTING 00161900
AT THE CHARACTER ADDRESS. ADDRESS IS SET TO POINT 00162000
TO THE NEXT CHARACTER DURING INTCON; 00162100
DPTOG:=COUNT GTR 8; 00162200
THI:=T:=CONV(ADDR,N:=COUNT MOD 8); 00162300
ADDR:=BUMP(ADDR,N); 00162400
COUNT:=COUNT DIV 8; 00162500
FOR N:=1 STEP 1 UNTIL COUNT DO BEGIN 00162600
IF DPTOG THEN BEGIN 00162700
DOUBLE(THI,TLO,100000000.0,0,|,CONV(ADDR,8), 00162800
0,+,:=,THI,TLO); 00162900
T:=THI 00163000
END ELSE T:=T|100000000 + CONV(ADDR,8); 00163100
ADDR:=BUMP(ADDR,8); END; 00163200
INTCON:=T; 00163300
END OF INTCON; 00163400
INTEGER STREAM PROCEDURE SUBSCAN(ADDR,NEXT); VALUE ADDR; 00163500
BEGIN SI:=ADDR; 00163600
63(IF SC GEQ "0" THEN 00163700
IF SC LEQ "9" THEN BEGIN SI:=SI+1; TALLY:=TALLY+1; 00163800
END ELSE JUMP OUT); 00163900
DI:=NEXT; DI:=DI+7; DS:=1 CHR; SUBSCAN:=TALLY; 00164000
END; 00164100
COMMENT--VALUE OF SUBSCAN IS NUMBER OF NUMERIC CHARACTERS 00164200
FOUND. NEXT CONTAINS THE FIRST NON-NUMERIC CHARACTER; 00164300
EXPOVR:=KITE; 00164400
MANTSIGN:=1; 00164500
MANT:=MANTLEN:=POWER:=POWERLEN:=FRAC:=FRACLEN:=0; 00164600
MANTLEN:=SUBSCAN(ADDRESS,NCHR); 00164700
IF MANTLEN=0 AND NCHR="#" THEN BEGIN 00164800
MANTSIGN:=-1; 00164900
ADDRESS:=BUMP(ADDRESS,1); 00165000
MANTLEN:=SUBSCAN(ADDRESS,NCHR); END; 00165100
IF MANTLEN=0 THEN BEGIN ADDRESS:=BUMP(ADDRESS,1); 00165200
IF NCHR="." THEN GO TO GETFRAC 00165300
ELSE IF NCHR="@" OR NCHR="E" THEN GO TO GETPOWER 00165400
ELSE BEGIN ERR:=SYNTAXERROR; 00165500
GO TO QUIT; END; END; 00165600
MANT:=INTCON(MANTLEN); 00165700
IF NCHR="." THEN BEGIN ADDRESS:=BUMP(ADDRESS,1); GO GETFRAC END; 00165800
IF NCHR="@" OR NCHR="E" THEN BEGIN 00165900
ADDRESS:=BUMP(ADDRESS,1); GO TO GETPOWER END; 00166000
IF NCHR=12 THEN EOB:=1; 00166100
GO TO QUIT; 00166200
GETFRAC: FRACLEN:=SUBSCAN(ADDRESS,NCHR); 00166300
IF FRACLEN=0 THEN BEGIN ERR:=SYNTAXERROR; GO TO QUIT; END; 00166400
FRAC:=INTCON(FRACLEN); 00166500
IF NCHR="@" OR NCHR="E" THEN BEGIN 00166600
ADDRESS:=BUMP(ADDRESS,1); GO TO GETPOWER; END; 00166700
IF NCHR=12 THEN EOB:=1 ELSE 00166800
IF NCHR="." OR NCHR="#" THEN ERR:=SYNTAXERROR; 00166900
GO TO QUIT; 00167000
GETPOWER: 00167100
POWERLEN:=SUBSCAN(ADDRESS,NCHR); 00167200
IF POWERLEN=0 THEN BEGIN 00167300
IF NCHR="-" OR NCHR="#" THEN POWER:=-1 00167400
ELSE IF NCHR="+" THEN POWER:=1 00167500
ELSE BEGIN ERR:=SYNTAXERROR; GO TO QUIT; END; 00167600
POWERLEN:=SUBSCAN(ADDRESS:=BUMP(ADDRESS,1), NCHR); 00167700
END ELSE POWER:=1; 00167800
IF POWERLEN=0 THEN ERR:=SYNTAXERROR 00167900
ELSE BEGIN 00168000
POWER:=INTCON(POWERLEN)|POWER; 00168100
IF NCHR="#" OR NCHR="@" OR NCHR="." 00168200
THEN ERR:=SYNTAXERROR; END; 00168300
GO TO QUIT; 00168400
KITE: ERR:=KITEERROR; 00168500
QUIT: IF ERR=0 THEN 00168600
NUMBER:=IF MANTLEN+FRACLEN=0 THEN 00168700
IF POWERLEN=0 THEN 0 00168800
ELSE MANTSIGN|10*ENTIER(POWER) 00168900
ELSE MANTSIGN|(MANT|10*ENTIER(POWER) 00169000
+ FRAC|10*ENTIER(POWER-FRACLEN)) ELSE EOB:=1; 00169100
END OF NUMBER; 00169200
STREAM PROCEDURE APPENDTOBUFF(BUF,NBUF,NBLANK,A,SA,NA); 00169300
VALUE NBUF,NBLANK,SA,NA; 00169400
BEGIN LOCAL T; 00169500
LOCAL TSI,TDI; 00169600
SI:=LOC NBUF; DI:=LOC T; DI:=DI+1; DS:=7CHR; 00169700
DI:=BUF; T(2(DI:=DI+32)); DI:=DI+NBUF; 00169800
NBLANK(DS:=LIT" "); TDI:=DI; 00169900
SI:=LOC SA; DI:=LOC T; DI:=DI+1; DS:=7CHR; 00170000
SI:=A; T(2(SI:=SI+32)); SI:=SI+SA; 00170100
TSI:=SI; SI:=LOC NA; DI:=LOC T; DI:=DI+1; DS:=7CHR; 00170200
SI:=TSI; DI:=TDI; T(2(DS:=32CHR)); DS:=NA CHR 00170300
END; 00170400
PROCEDURE TERPRINT; 00170500
BEGIN LABEL BK; 00170600
STREAM PROCEDURE FINISHBUFF(BUF,N,TER);VALUE N,TER; 00170700
BEGIN LOCAL T; 00170800
SI:=LOC TER;SI:=SI+7;IF SC="1" THEN; 00170900
SI:=LOC N; DI:=LOC T; DI:=DI+1; DS:=7 CHR; 00171000
DI:=BUF; T(2(DI:=DI+32));DI:=DI+N; 00171100
IF TOGGLE THEN DS:=2 LIT"{!"; %CARRIAGE RETURN/LINE FEED 00171200
DS:=RESET;DS:=5 SET; %END OF MESSAGE LEFT ARROW 00171300
END OF FINISHBUFF; 00171400
IF CHRCOUNT NEQ 0 THEN BEGIN 00171500
FINISHBUFF(OUTBUFF,CHRCOUNT,LINETOG); 00171600
CHRCOUNT:=0; 00171700
IF LINETOG THEN 00171800
WRITE(TWXOUT,9,OUTBUFF[*])[BK:BK] ELSE 00171900
WRITE(TWXOUT[STOP],9,OUTBUFF[*])[BK:BK]; 00172000
INITBUFF(OUTBUFF, 10); 00172100
END; 00172200
IF FALSE THEN 00172300
BK: IF CURRENTMODE=XEQMODE THEN BREAKFLAG:=TRUE; 00172400
END OF TERPRINT; 00172500
PROCEDURE FORMWD(CC,WD); VALUE CC,WD; REAL WD; INTEGER CC; 00172600
BEGIN 00172700
INTEGER I,K,L; 00172800
COMMENT CC=-1 STAY ON LINE, OUTPUT, DON"T GO TO NEXT LINE 00172900
COMMENT CC=0 STAY ON THIS LINE, MORE TO COME. 00173000
CC=1 STAY ON THIS LINE BUT TERMINATE PRINT. 00173100
CC=2 SKIP TO NEXT LINE - MORE TO COME. 00173200
CC=3 SKIP TO NEXT LINE - TERMINATE PRINT.; 00173300
REAL STREAM PROCEDURE OCTAL(I); VALUE I; 00173400
BEGIN SI:=LOC I; DI:=LOC OCTAL; DS:=8OCT 00173500
END; 00173600
IF L:=LINESIZE LEQ 9 OR L GTR 72 THEN L:=72; K:=2; 00173700
IF CC GTR 1 AND CHRCOUNT GTR 0THEN TERPRINT; 00173800
IF CHRCOUNT+(I:=OCTAL(WD.[1:11])) GTR L THEN 00173900
00174000
BEGIN APPENDTOBUFF(LINEBUFFER,CHRCOUNT, 00174100
0,WD,2,K:=L-CHRCOUNT); 00174200
CHRCOUNT:=L; TERPRINT; 00174300
00174400
I:=I-K; 00174500
00174600
END; 00174700
APPENDTOBUFF(LINEBUFFER,CHRCOUNT,0,WD,K,I); 00174800
00174900
CHRCOUNT:=CHRCOUNT+I; 00175000
IF BOOLEAN(CC) THEN 00175100
IF CC=-1 THEN BEGIN LINETOG:=FALSE; 00175200
TERPRINT; LINETOG:=TRUE 00175300
END ELSE TERPRINT; 00175400
END; 00175500
BOOLEAN PROCEDURE FUNCTIONHEADER(SPECS,HADDR); 00175600
ARRAY SPECS[0]; REAL HADDR; FORWARD; 00175700
00175800
00175900
00176000
REAL PROCEDURE LINENUMBER(R); VALUE R; REAL R; 00176100
COMMENT STARTS ON 8030000; 00176200
FORWARD; 00176300
00176400
PROCEDURE INDENT(R); VALUE R; REAL R; 00176500
BEGIN 00176600
INTEGER STREAM PROCEDURE FORM(A,I,K);VALUE K,I; 00176700
BEGIN 00176800
LOCAL T1,T2; 00176900
LABEL SHORT,L,M,FINIS; 00177000
TALLY:=K; FORM:=TALLY; 00177100
SI:=LOC I; DI:=LOC T1; IF 8SC=DC THEN 00177200
BEGIN DI:=A; K(DS:=LIT" "); GO FINIS 00177300
END; 00177400
SI:=LOC I; DI:=A; TALLY:=3; DS:=LIT"["; 00177500
IF SC GTR "0" THEN IF SC LSS "0" THEN ; 00177600
3(TALLY:=TALLY+1; IF TOGGLE THEN DS:=CHR ELSE 00177700
IF SC NEQ "0" THEN DS:=CHR ELSE 00177800
BEGIN TALLY:=TALLY+63; SI:=SI+1 00177900
END ); 00178000
DS:=CHR; T1:=TALLY; TALLY:=4; SI:=SI+3; 00178100
4(IF SC NEQ "0" THEN JUMP OUT TO M; 00178200
TALLY:=TALLY+63; SI:=SI-1); GO TO L; 00178300
M: 00178400
T2:=TALLY; SI:=LOC I; SI:=SI+4; DS:=LIT"."; DS:=T2 CHR; 00178500
TALLY:=T1; TALLY:=TALLY+T2; TALLY:=TALLY+1; T1:=TALLY; 00178600
L: 00178700
DS:=LIT"]"; TALLY:=K; 00178800
T1(TALLY:=TALLY+63; T2:=TALLY; SI:=LOC T2; SI:=SI+7; 00178900
IF SC="0" THEN JUMP OUT TO SHORT); 00179000
T2(DS:=LIT" "); GO FINIS; 00179100
SHORT: 00179200
TALLY:=T1; TALLY:=TALLY+1; FORM:=TALLY; DS:=LIT" "; 00179300
FINIS: 00179400
DS:=RESET; DS:=5SET; 00179500
END; 00179600
IF R LSS 0 THEN R:=LINENUMBER(-R) ELSE R:=ABS(R); % -0 00179700
CHRCOUNT:=FORM(LINEBUFF,R,MARGINSIZE)+1 00179800
00179900
END; 00180000
INTEGER PROCEDURE HEADER(ADDR1,ADDR2,BUF); VALUE ADDR1,ADDR2; 00180100
INTEGER ADDR1, ADDR2; ARRAY BUF[0]; 00180200
BEGIN 00180300
INTEGER STREAM PROCEDURE HEADRR(ADDR1,ADDR2,BUF); VALUE ADDR1, 00180400
ADDR2; 00180500
BEGIN 00180600
LOCAL C,T,TDI; 00180700
LOCAL QM,AR; 00180800
LABEL L,ENDSCAN,M,N; 00180900
DI:=LOC QM; DS:=2RESET; DS:=2SET; 00181000
DI:=LOC AR; DS:=RESET; DS:=5SET; 00181100
DI:=BUF; 00181200
SI:=ADDR1; 00181300
L: T:=SI; TDI:=DI; 00181400
DI:=LOC QM; IF SC=DC THEN GO TO ENDSCAN; 00181500
DI:=LOC AR; SI:=SI-1; IF SC=DC THEN GO TO ENDSCAN; 00181600
SI:=LOC T; DI:=LOC ADDR2; 00181700
IF 8SC=DC THEN COMMENT END OF SCAN; 00181800
GO TO ENDSCAN; 00181900
SI:=T; DI:=TDI; DS:=CHR; 00182000
GO TO L; 00182100
ENDSCAN: 00182200
SI:=TDI; 00182300
M: SI:=SI-1; 00182400
IF SC=" " THEN GO TO M; 00182500
SI:=SI+1; 00182600
ADDR2:=SI; 00182700
SI:=BUF; 00182800
N: T:=SI; DI:=LOC ADDR2; 00182900
SI:=LOC T; 00183000
IF 8SC NEQ DC THEN 00183100
BEGIN 00183200
TALLY:=TALLY+1; TDI:=TALLY; 00183300
SI:=LOC TDI; SI:=SI+7; 00183400
IF SC="0" THEN 00183500
BEGIN TALLY:=C; TALLY:=TALLY+1; C:=TALLY; 00183600
TALLY:=0; 00183700
END; 00183800
SI:=T; SI:=SI+1; GO TO N; 00183900
END; 00184000
HEADRR:=TALLY; SI:=LOC C; DI:=LOC HEADRR; SI:=SI+1; DS:=6 CHR; 00184100
END; 00184200
HEADER:=HEADRR(ADDR1,ADDR2,BUF); 00184300
END OF PHONY HEADER; 00184400
PROCEDURE STARTSCAN; 00184500
BEGIN 00184600
00184700
00184800
00184900
LADDRESS:= 00185000
ADDRESS:=ABSOLUTEADDRESS; 00185100
BEGIN TERPRINT; 00185200
END; 00185300
READ(TWXIN[STOP],29,BUFFER[*]); 00185400
BUFFER[30]:=0&31[1:43:5]; 00185500
ITEMCOUNT:=0; 00185600
EOB:=0 00185700
END; 00185800
PROCEDURE FORMROW(CC,BL,A,S,N); VALUE CC,BL,S,N; INTEGER CC,BL, 00185900
S,N; ARRAY A[0]; 00186000
COMMENT: CC--SAME CODE AS IN FORMWD, LINE 253000 00186100
BL--#BLANKS TO PUT IN FRONT OF IT 00186200
A--ARRAY WHERE THE STUFF TO PUT ON LINE IS STORED 00186300
S--#CHARACTERS TO SKIP AT START OF A 00186400
N--#CHARACTERS TO TAKE FROM A TO PUT ON OUTPUT LINE; 00186500
BEGIN INTEGER K; 00186600
INTEGER T; 00186700
IF CC GTR 1 AND CHRCOUNT GTR 0 THEN TERPRINT; 00186800
IF K:=LINESIZE LEQ 9 OR K GTR 72 THEN K:=72; 00186900
WHILE CHRCOUNT+N+BL GTR K DO 00187000
BEGIN 00187100
APPENDTOBUFFER(LINEBUFFER,CHRCOUNT,BL,A,S,T:=K-CHRCOUNT-BL); 00187200
CHRCOUNT:=K; TERPRINT; 00187300
S:=S+T; N:=N-T; 00187400
BL:=0; 00187500
END; 00187600
APPENDTOBUFFER(LINEBUFFER,CHRCOUNT,BL,A,S,N); 00187700
00187800
CHRCOUNT:=CHRCOUNT+N+BL; 00187900
IF BOOLEAN(CC) THEN 00188000
IF CC=-1 THEN BEGIN LINETOG:=FALSE; 00188100
TERPRINT; LINETOG:=TRUE; 00188200
END ELSE TERPRINT; 00188300
END; 00188400
PROCEDURE NUMBERCON(R,A); VALUE R; REAL R; ARRAY A[0]; 00188500
BEGIN FORMAT F(F24.*), G(E24.*); 00188600
REAL S; DEFINE MAXIM = 10@9#; 00188700
00188800
STREAM PROCEDURE ADJUST(A,B); 00188900
BEGIN LOCAL T,FRAC,MANT,T1,TSI,TDI; 00189000
DI:=LOC T; DI:=DI+1; T1:=DI; 00189100
SI:=B; DI:=A; DI:=DI+2; 00189200
24(IF SC=" " THEN SI:=SI+1 ELSE 00189300
BEGIN TSI:=SI; SI:=LOC T; 00189400
IF SC="1" THEN; SI:=TSI; 00189500
IF TOGGLE THEN 00189600
IF SC NEQ "0" THEN 00189700
IF SC="@" THEN BEGIN 00189800
TSI:=SI; DI:=T1; DS:=LIT"1"; JUMP OUT; 00189900
END ELSE FRAC:=TALLY 00190000
ELSE TALLY := TALLY+0 00190100
ELSE 00190200
IF SC="." THEN 00190300
BEGIN MANT:=TALLY; TDI:=DI; DI:=LOC T; DS:= 00190400
LIT"1"; TALLY:=0;DI:=TDI; 00190500
END; 00190600
TALLY:=TALLY+1; DS:=CHR 00190700
END); 00190800
SI:=LOC MANT; SI:=SI+7; IF SC="0" THEN MANT:=TALLY; 00190900
00191000
TALLY:=MANT; SI:=LOC FRAC; SI:=SI+7; IF SC GTR "0" 00191100
THEN TALLY:=TALLY+1; TALLY:=TALLY+FRAC; MANT:=TALLY; 00191200
SI:=T1; IF SC="1" THEN BEGIN 00191300
DI:=A; DI:=DI+MANT; DI:=DI+2; 00191400
SI:=TSI; DS:=4CHR; 00191500
TALLY:=TALLY+4; MANT:=TALLY; END; 00191600
SI:=LOC MANT; SI:=SI+6; DI:=A; DS:=2CHR; 00191700
END; 00191800
IF S:=ABS(R) GEQ MAXIM OR S LEQ 10*(-DIGITS) AND S NEQ 0 THEN 00191900
WRITE(SCR[*],G,DIGITS,R) ELSE 00192000
WRITE(SCR[*],F,DIGITS,R); 00192100
ADJUST(A,SCR) 00192200
END; 00192300
PROCEDURE STOREPSR; 00192400
BEGIN INTEGER I; 00192500
DELETE1(WORKSPACE,0); 00192600
I:=STORESEQ(WORKSPACE,PSR,PSRSIZE|8); 00192700
COMMENT USED TO CALL WRAPUP; 00192800
END; 00192900
PROCEDURE RESCANLINE; 00193000
BEGIN ADDRESS:=ABSOLUTEADDRESS; EOB:=0; END; 00193100
PROCEDURE PROCESS(MODE);VALUE MODE; INTEGER MODE; FORWARD; 00193200
PROCEDURE MESSAGEHANDLER; FORWARD; 00193300
PROCEDURE FUNCTIONHANDLER; FORWARD; 00193400
PROCEDURE ERRORMESS(N,ADDR,R); VALUE N,ADDR,R; REAL R; 00193500
INTEGER N;REAL ADDR;FORWARD; COMMENT LINE 5000000; 00193600
STREAM PROCEDURE SETFIELD(A,S,L,R); VALUE S,L,R; 00193700
BEGIN DI:=A; DI:=DI+S; SI:=LOC R; SI:=SI+8; L(SI:=SI-1); 00193800
DS:=L CHR; 00193900
END; 00194000
COMMENT: VALUE OF GETFIELD IS L CHARACTERS, STARTING AT J-TH 00194100
CHARACTER OF A, RIGHT-ADJUSTED. L MUST BE LEQ 8 AND 00194200
J MUST BE LESS THAT 64; 00194300
REAL STREAM PROCEDURE GETFIELD(A,S,L); VALUE S,L; 00194400
BEGIN SI:=A; SI:=SI+S; DI:=LOC GETFIELD; DI:=DI+8; L(DI:=DI-1); 00194500
DS:=L CHR; 00194600
END; 00194700
REAL PROCEDURE TOPLINE(ORD); VALUE ORD; INTEGER ORD; 00194800
BEGIN 00194900
INTEGER STREAM PROCEDURE CON(A); VALUE A; 00195000
BEGIN SI:=LOC A; DI:=LOC CON; DS:=8OCT END; 00195100
ARRAY A[0:1]; INTEGER I; 00195200
I:=CONTENTS(ORD,SIZE(ORD)-1,A); 00195300
TOPLINE:=CON(A[0])/10000 00195400
END; 00195500
BOOLEAN PROCEDURE FUNCTIONHEADER(SPECS,HADDR); 00195600
ARRAY SPECS[0]; REAL HADDR; 00195700
BEGIN 00195800
LABEL A,B,C; 00195900
INTEGER P; 00196000
DEFINE NOTE=HADDR.[24:24]:=ADDRESS#,P8=8|P+1#; 00196100
ERR:=0; 00196200
SPECS[0]:=SPECS[1]:=SPECS[2]:=SPECS[3]:=0; 00196300
NOTE; HADDR.[1:23]:=GT1:=ADDRESS; 00196400
IF SCAN AND IDENT THEN 00196500
BEGIN 00196600
TRANSFER(ACCUM,2,SPECS,1,7); 00196700
NOTE; 00196800
IF SCAN THEN 00196900
IF LFTARROW THEN 00197000
BEGIN 00197100
SPECS[1]:=1; 00197200
SPECS[3]:=1; 00197300
TRANSFER(SPECS,1,SPECS,33,7); 00197400
GT2:=ADDRESS; 00197500
IF SCAN AND IDENT THEN 00197600
BEGIN 00197700
TRANSFER(ACCUM,2,SPECS,1,7); 00197800
NOTE; 00197900
IF SCAN THEN 00198000
C: IF IDENT THEN 00198100
BEGIN 00198200
P:=(SPECS[3]:=SPECS[3]+1)+3; 00198300
TRANSFER(ACCUM,2,SPECS,P8,7); 00198400
SPECS[2]:=1; 00198500
NOTE; 00198600
IF SCAN THEN IF IDENT THEN 00198700
BEGIN SPECS[2]:=2; 00198800
P:=(SPECS[3]:=SPECS[3]+1)+2; 00198900
TRANSFER(SPECS,1,SPECS,P8+8,7); 00199000
TRANSFER(SPECS,P8,SPECS,1,7); 00199100
TRANSFER(ACCUM,2,SPECS,P8,7); 00199200
00199300
B: NOTE; IF SCAN THEN 00199400
A: IF SEMICOLON THEN IF SCAN THEN 00199500
IF IDENT THEN 00199600
BEGIN 00199700
P:=(SPECS[3]:=SPECS[3]+1)+3; 00199800
TRANSFER(ACCUM,2,SPECS,P8,7); 00199900
GO TO B; 00200000
END ELSE GO TO A 00200100
ELSE ELSE ELSE 00200200
END ELSE GO TO A 00200300
ELSE END 00200400
ELSE GO TO A ELSE 00200500
END ELSE ERRORMESS(ERR:=1,GT2,0) 00200600
END ELSE GO TO C 00200700
ELSE 00200800
END ELSE ERRORMESS(ERR:=SYNTAXERROR,GT1,0); 00200900
FUNCTIONHEADER:=ERR=0; 00201000
ADDRESS:=HADDR.[24:24]; 00201100
END FUNCTIONHEADER; 00201200
00201300
INTEGER PROCEDURE DAYTIME(B); ARRAY B[0]; FORWARD; 00201400
COMMENT ON LINE 8014000, ARRAY B MUST HAVE LENGTH 00201500
AT LEAST 3 WDS; 00201600
PROCEDURE EDITLINE; FORWARD; 00201700
INTEGER PROCEDURE LENGTH(A,M);VALUE M; BOOLEAN M; ARRAY A[0]; 00201800
FORWARD; COMMENT LINE 8007900; 00201900
BOOLEAN PROCEDURE LABELSCAN(L,K); VALUE K; INTEGER K; 00202000
ARRAY L[0]; FORWARD; COMMENT LINE 8013910; 00202100
00202200
00202300
PROCEDURE CHECKSEQ(SEQ,L,INC); REAL SEQ,L,INC; FORWARD; 00202400
COMMENT ON LINE 8040000; 00202500
PROCEDURE RELEASEARRAY(D);VALUE D; REAL D; 00202600
BEGIN COMMENT RELEASE PERMANENT STORAGE FOR THE ARRAY DESC D; 00202700
INTEGER K,J,PT; 00202800
ARRAY BLOCK[0:32]; %SEE MAXWORDSTORE, LINE 17260 00202900
ARRAY TEMP[0:1]; 00203000
IF D.RF NEQ 0 THEN 00203100
BEGIN DELETE1(WS,D.DIMPTR); 00203200
K:=CONTENTS(WS,D.INPTR,BLOCK)-1; 00203300
DELETE1(WS,D.INPTR); 00203400
FOR J:=0 STEP 2 UNTIL K DO 00203500
BEGIN TRANSFER(BLOCK,J,TEMP,6,2); 00203600
PT:=TEMP[0]; DELETE1(WS,PT); END; 00203700
END; 00203800
END; 00203900
PROCEDURE TRANSFERSP(DIR,SP,L,B,M,N); VALUE DIR,N,M,L; 00204000
INTEGER DIR,N,M,L; 00204100
ARRAY SP[0,0],B[0]; 00204200
BEGIN COMMENT 00204300
DIR= INTO: TRANSFER N WORDS FROM B[L] INTO SP[M] 00204400
(ACTUALLY SP[*,M] SINCE ARRAY ROW IS USUALLY THE ARG) 00204500
DIR= OUTOF (OPPOSITE); 00204600
STREAM PROCEDURE MOVER(DIR,SP,M,B,L,N); VALUE DIR, 00204700
L,M,N; 00204800
BEGIN LOCAL T; 00204900
SI:=LOC L; DI:=LOC T; DI:=DI+1; DS:=7CHR; 00205000
SI:=SP; T(16(SI:=SI+32)); L(SI:=SI+8); L:=SI; 00205100
SI:=LOC M; DI:=LOC T; DI:=DI+1; DS:=7CHR; 00205200
SI:=B; T(16(SI:=SI+32)); M(SI:=SI+8); M:=SI; 00205300
SI:=LOC N; DI:=LOC T; DI:=DI+1; DS:=7CHR; 00205400
SI:=LOC DIR; SI:=SI+7; 00205500
IF SC="0" THEN 00205600
BEGIN SI:=M; DI:=L 00205700
END ELSE 00205800
BEGIN SI:=L ; DI:=M 00205900
END; 00206000
T(2(DS:=32WDS)); DS:=N WDS; 00206100
END; 00206200
INTEGER K; 00206300
WHILE N:=N-K GTR 0 DO 00206400
MOVER(DIR,SP[(L:=L+K)DIV SPRSIZE,*], 00206500
M:=M+K,B,K:=L MOD SPRSIZE, 00206600
K:=MIN(SPRSIZE-K,N)) 00206700
END; 00206800
00206900
PROCEDURE DUMPOLISH(SP,PD); VALUE PD; REAL PD; ARRAY SP[0,0]; 00207000
BEGIN INTEGER L; 00207100
LABEL SKIPREST; 00207200
INTEGER I,N,M,U; REAL T; 00207300
L:=PD.SPF; 00207400
I:=SP[LOC]+L; 00207500
FOR L:=L+2 STEP 1 UNTIL I DO 00207600
IF (T:=SP[LOC]).TYPEFIELD=FUNCTION THEN 00207700
BEGIN % OUTPUT MESSAGE AND NAME 00207800
FORMWD(2,"5FUNC: "); 00207900
N:=T.LOCFIELD; % N HAS LOCATION OF DESCRIPTOR 00208000
N:=N-1; % BACK UP ONE TO GET NAME 00208100
GTA[0]:=SP[NOC]; 00208200
FORMROW(1,1,GTA,1,7); 00208300
END 00208400
ELSE % MIGHT BE AN OPERATOR 00208500
IF T.TYPEFIELD=OPERATOR THEN 00208600
BEGIN COMMENT OUTPUT MESSAGE AND OP CODE; 00208700
FORMWD(2,"5ATOR: "); 00208800
NUMBERCON(T.OPTYPE,ACCUM); 00208900
FORMROW(0,1,ACCUM,2,ACOUNT); 00209000
NUMBERCON(T.LOCFIELD,ACCUM); 00209100
FORMROW(1,1,ACCUM,2,ACOUNT); 00209200
END ELSE %MAY BE A CONSTANT 00209300
IF T.TYPEFIELD=CONSTANT THEN 00209400
BEGIN COMMENT GET DATA DESCRIPTOR; 00209500
N:=T.LOCFIELD; 00209600
FORMWD(2,"5CONS: "); 00209700
T:=SP[NOC]; %T HAS THE DATA DESCRIPTOR 00209800
IF T.SPF=0 THEN BEGIN % A NULL VECTOR 00209900
FORMWD(1,"4NULL "); 00210000
GO TO SKIPREST; END; 00210100
N:=T.SPF; %N HAS THE SCALAR OR TOP OF VECTOR LOC. 00210200
IF BOOLEAN(T.SCALAR) THEN M:=U:=N ELSE 00210300
BEGIN U:=SP[NOC]+N; M:=N+1; %UPPER AND LOWER BOUNDS 00210400
END; 00210500
IF BOOLEAN(T.CHRMODE) THEN %CHARACTER FORMAT 00210600
BEGIN COMMENT SP[NOC] IS NUMBER OF CHRS; 00210700
TRANSFERSP(OUTOF,SP,M,BUFFER,0,ENTIER(((T:= 00210800
SP[NOC])-1)DIV 8+1)); 00210900
FORMROW(1,1,BUFFER,0,T); 00211000
END ELSE % SHOULD TEST FOR NULL...DO IT LATER. 00211100
FOR N:=M STEP 1 UNTIL U DO 00211200
BEGIN NUMBERCON(SP[NOC],ACCUM); 00211300
FORMROW(0,1,ACCUM,2,ACOUNT); 00211400
END; 00211500
TERPRINT; 00211600
SKIPREST: 00211700
END ELSE COMMENT MUST BE AN OPERAND; 00211800
IF T.TYPEFIELD=LOCALVAR THEN 00211900
BEGIN FORMWD(2,"5LOCL: "); 00212000
N:=T.SPF; % N HAS LOCATION OF NAME; 00212100
GTA[0]:=SP[NOC]; % PUT NAME IN GTA 00212200
FORMROW(1,1,GTA,1,7); 00212300
END ELSE 00212400
BEGIN COMMENT TREAT IT AS VARIABLE; 00212500
N:=T.LOCFIELD; COMMENT N HAS LOC OF DESCRIPTOR; 00212600
N:=N-1; COMMENT BACKUP OVER THE DESCRIPTOR; 00212700
GTA[0]:=SP[NOC]; 00212800
FORMWD(2,"5AND : "); 00212900
FORMROW(1,1,GTA,1,7); 00213000
END; 00213100
END; 00213200
00213300
PROCEDURE PROCESS(MODE); VALUE MODE; INTEGER MODE; 00213400
BEGIN 00213500
OWN INTEGER J; 00213600
OWN REAL RESULTD; 00213700
LABEL EXPOVRL,INTOVRL,INDEXL,FLAGL,ZEROL; 00213800
MONITOR EXPOVR,INTOVR,INDEX,FLAG,ZERO; 00213900
LABEL DEBUGSP; %DEBUGGING PURPOSES ONLY. 00214000
INTEGER PROCEDURE BUILDCONSTANT(LASTCONSTANT); 00214100
INTEGER LASTCONSTANT; FORWARD; 00214200
INTEGER PROCEDURE GETSPACE(LENGTH); VALUE LENGTH; 00214300
INTEGER LENGTH; FORWARD; 00214400
PROCEDURE OPERANDTOSYMTAB(L);VALUE L;INTEGER L;FORWARD; 00214500
REAL PROCEDURE BUILDALPHA(LASTCONSTANT); 00214600
INTEGER LASTCONSTANT; FORWARD; 00214700
INTEGER PROCEDURE BUILDNULL(LASTCONSTANT); 00214800
INTEGER LASTCONSTANT; FORWARD; 00214900
PROCEDURE SCRATCHDATA(D);VALUE D;REAL D; FORWARD; 00215000
COMMENT LINE 3121400; 00215100
PROCEDURE FORGETPROGRAM(U);VALUE U;REAL U; FORWARD; 00215200
COMMENT ANALYZE IS IN PROCESS BECAUSE OWN ARRAY SP 00215300
IS ADDRESSED INCORRECTLY OTHERWISE; 00215400
REAL PROCEDURE ANALYZE(DISPLAYOP); VALUE DISPLAYOP;BOOLEAN DISPLAYOP; 00215500
BEGIN COMMENT 00215600
BC= BUILDCONSTANT, 00215700
GS= GET SPACE PROCEDURE ; 00215800
ARRAY INFIX[0:MAXPOLISH]; 00215900
00216000
INTEGER LASTCONSTANT; 00216100
DEFINE GS=GETSPACE#; 00216200
BOOLEAN STREAM PROCEDURE EQUAL(A,B); 00216300
BEGIN SI:=A; SI:=SI+1; DI:=B; DI:=DI+2; 00216400
IF 7SC=DC THEN TALLY:=1; 00216500
EQUAL:=TALLY; 00216600
END; 00216700
PROCEDURE UNSTACK(DEST,L,ORIG,OTOP,N,CHR1,CHR2); 00216800
VALUE N,CHR1,CHR2; 00216900
INTEGER N,CHR1,CHR2,L,OTOP; 00217000
ARRAY DEST[0,0],ORIG[0]; 00217100
BEGIN 00217200
REAL T,U; 00217300
WHILE OTOP GTR 0 AND N GTR 0 AND ERR=0 DO 00217400
IF(IF (T:=ORIG[OTOP]).TYPEFIELD=FUNCTION THEN FALSE ELSE 00217500
U:=T.LOCFIELD=CHR1 OR U=CHR2) THEN %UNSTACK 00217600
BEGIN 00217700
IF N GTR 1 THEN 00217800
IF U=CHR2 THEN ERR:=SYNTAXERROR ELSE 00217900
OTOP:=OTOP-1; 00218000
N:=N-1; 00218100
END ELSE 00218200
COMMENT WE ARE LOOKING AT AN OPERATOR OR A FUNCTION; 00218300
00218400
00218500
BEGIN 00218600
IF J NEQ 0 THEN 00218700
BEGIN L:=L+1; 00218800
DEST[LOC]:=ORIG[OTOP] 00218900
END; 00219000
OTOP:=OTOP-1 00219100
END; 00219200
IF N GTR 1 THEN ERR:=SYNTAXERROR; 00219300
END; 00219400
INTEGER ITOP,K,L,I; 00219500
INTEGER M,N,FLOC; REAL T; 00219600
LABEL SKIPSCAN,FILLER; 00219700
LABEL SPFULLAB; 00219800
00219900
00220000
PROCEDURE FORGETSPACE(L,LENGTH,SP); VALUE L,LENGTH; 00220100
INTEGER L,LENGTH; ARRAY SP[0,0]; 00220200
BEGIN IF LENGTH GTR 0 THEN 00220300
BEGIN SP[LOC]:=SP[0,0]; 00220400
SP[LOC].LEN:=LENGTH; SP[0,0]:=L 00220500
END; 00220600
END; 00220700
00220800
IF CURRENTMODE=FUNCMODE OR STACKBASE=0 THEN FLOC:=0 ELSE 00220900
00221000
BEGIN L:=STACKBASE+1;L:=SP[LOC].SPF+1;M:=SP[LOC].SPF+L; 00221100
FLOC:= IF M=L OR BOOLEAN(T:=SP[MOC]).SUSPENDED THEN 0 ELSE T.SPF00221200
00221300
END; 00221400
00221500
T:=ADDRESS; 00221600
ITOP:=0; 00221700
DO 00221800
SKIPSCAN: 00221900
IF ITOP LSS MAXPOLISH THEN 00222000
BEGIN 00222100
INFIX[ITOP:=ITOP+1].ADDRFIELD:=T; 00222200
IF SPECIAL THEN 00222300
IF QUOTEV THEN % CONSTANT VECTOR 00222400
BEGIN INFIX[ITOP].TYPEFIELD:=CONSTANT; 00222500
IF T:=BUILDALPHA(LASTCONSTANT) NEQ 0 THEN 00222600
INFIX[ITOP].LOCFIELD:=T ELSE ERR:=SYNTAXERROR 00222700
END ELSE % ORDINARY OPERATOR 00222800
BEGIN INFIX[ITOP].TYPEFIELD:=OPERATOR; 00222900
INFIX[ITOP].LOCFIELD:=ENTIER(ACCUM[0]); 00223000
END ELSE 00223100
IF NUMERIC THEN 00223200
IF ERR NEQ 0 THEN COMMENT NOTHING; ELSE 00223300
BEGIN INFIX[ITOP].TYPEFIELD:=CONSTANT; 00223400
IF CURRENTMODE=FUNCMODE THEN 00223500
COMMENT DO NOT STORE NUMERIC IN SCRATCH PAD; 00223600
DO UNTIL NOT SCAN OR NOT NUMERIC %THE NULL STATEMENT 00223700
ELSE 00223800
BEGIN 00223900
T:=BUILDCONSTANT(LASTCONSTANT); 00224000
IF T=0 THEN ERR:=IF ERR=0 THEN VALUEERROR ELSE ERR ELSE 00224100
INFIX[ITOP].LOCFIELD:=T; 00224200
END; 00224300
IF EOB=0 AND ERR=0 THEN GO TO SKIPSCAN; 00224400
END ELSE 00224500
IF IDENT THEN 00224600
BEGIN INFIX[ITOP].DID:=OPERAND; %SET OPTYPE=NILADIC 00224700
IF NOT(FUNCMODE EQL CURRENTMODE) THEN 00224800
BEGIN J:=0; 00224900
IF FLOC GTR 0 THEN %CHECK LOCAL NAMES 00225000
BEGIN L:=FLOC+2; 00225100
K:=SP[LOC]-2;%LAST ALPHA POINTER IN TABLE 00225200
%SHOULD CONVERT TO BINARY SEARCH 00225300
T:=L+4; 00225400
FOR L:=T STEP 2 UNTIL K DO 00225500
IF EQUAL(SP[LOC],ACCUM) THEN 00225600
BEGIN J:=L;L:=K;I:=0; 00225700
INFIX[ITOP].SPF:=J; 00225800
INFIX[ITOP].RF:=M-FLOC; 00225900
J:=(J-T+2)/2; 00226000
END; 00226100
END; 00226200
00226300
00226400
IF J EQL 0 THEN 00226500
BEGIN COMMENT LOOK IN SP SYMBOL TABLE; 00226600
IF L:=SYMBASE NEQ 0 THEN COMMENT OK TO LOOK; 00226700
BEGIN T:=SP[LOC];K:=L+T; 00226800
COMMENT T=N VARS TIMES 2. K IS TOP LIMIT; 00226900
FOR L:=L +1 STEP 2 UNTIL K DO 00227000
IF EQUAL(SP[LOC],ACCUM) THEN 00227100
BEGIN 00227200
INFIX[ITOP].TYPEFIELD:=I:=SP[LOC].TYPEFIELD; 00227300
L:=J:=L+1; 00227400
IF I=FUNCTION THEN BEGIN 00227500
INFIX[ITOP].RF:=SP[LOC].RETURNVALUE; 00227600
INFIX[ITOP].OPTYPE:=SP[LOC].NUMBERARGS;END; 00227700
L:=K; 00227800
END; 00227900
IF J EQL 0 THEN 00228000
IF T LSS MAXSYMBOL|2 THEN %INSERT ID 00228100
BEGIN L:=K+1; %NEXT AVAILABLE. 00228200
FILLER: SETFIELD(GTA,0,1,0); 00228300
TRANSFER(ACCUM,2,GTA,1,7); 00228400
SP[LOC]:=GTA[0];%STORE VARIABLE NAME 00228500
OPERANDTOSYMTAB(L);%SET TYPEFIELD AND DESC. 00228600
IF GT1=FUNCTION THEN%FUNCTION-FIX INFIX 00228700
BEGIN 00228800
INFIX[ITOP].OPTYPE:=GTA[1].NUMBERARGS; 00228900
INFIX[ITOP].TYPEFIELD:=FUNCTION; 00229000
INFIX[ITOP].RF:=GTA[1].RETURNVALUE; 00229100
END; 00229200
J:=L+1; 00229300
L:=SYMBASE;SP[LOC]:=T+2;%UPDATE SYM TAB # 00229400
END ELSE SPFULLAB: ERR:=SPERROR;%TAB FULL 00229500
END ELSE %CREATE SYMBOL TABLE 00229600
BEGIN 00229700
SYMBASE:=L:=GS(MAXSYMBOL|2+1); 00229800
IF ERR NEQ 0 THEN 00229900
BEGIN SYMBASE:=0; 00230000
GO TO SPFULLAB; 00230100
END; 00230200
T:=0; L:=L+1; 00230300
GO TO FILLER; 00230400
END 00230500
END ELSE INFIX[ITOP].DID:=LOCALVAR&1[44:47:1]; 00230600
INFIX[ITOP].LOCFIELD:=J 00230700
END 00230800
END ELSE ERR:=SYSTEMERROR; 00230900
IF ERR EQL 0 THEN T:=ADDRESS 00231000
END ELSE ERR:=SPERROR 00231100
UNTIL NOT(SCAN AND ERR=0); %DROP THRU WHEN INPUT FIN OR ERR 00231200
COMMENT NOW LOOK FOR THE POLISH; 00231300
IF ERR NEQ 0 THEN 00231400
BEGIN ERRORMESS(ERR,INFIX[ITOP].ADDRFIELD,0); 00231500
END ELSE 00231600
BEGIN COMMENT MAKE UP THE POLISH; 00231700
ARRAY OPERATORS[0:ITOP]; 00231800
BOOLEAN PROCEDURE ANDORATOR (VAR,TYPE); 00231900
VALUE VAR, TYPE; 00232000
REAL VAR,TYPE; 00232100
BEGIN 00232200
REAL T; 00232300
LABEL OPERAN, ATOR; 00232400
COMMENT PROCEDURE TRUE IF VAR IS OF TYPE SPECIFIED; 00232500
IF T:=VAR.TYPEFIELD=OPERATOR THEN 00232600
IF T:=VAR.LOCFIELD NEQ RGTPARENV AND T NEQ 00232700
QQUAD AND T NEQ QUAD AND T NEQ 00232800
RGTBRACKETV THEN GO ATOR 00232900
ELSE GO OPERAN 00233000
ELSE 00233100
IF T=FUNCTION THEN 00233200
IF VAR.OPTYPE GTR NILADIC THEN 00233300
ATOR: ANDORATOR:=TYPE=OPERATOR 00233400
ELSE GO OPERAN 00233500
ELSE 00233600
OPERAN: ANDORATOR:=TYPE=OPERAND; 00233700
END OF ANDORATOR; 00233800
BOOLEAN PROCEDURE RGTOPERAND(VAR); VALUE VAR; REAL VAR; 00233900
BEGIN REAL T; DEFINE RT=RGTOPERAND:=TRUE#; 00234000
IF T:=VAR.TYPEFIELD=OPERAND OR T=CONSTANT OR T=LOCALVAR THEN RT 00234100
ELSE IF T=OPERATOR AND VAR.LOCFIELD=LFTPARENV THEN RT 00234200
ELSE IF T=FUNCTION AND VAR.OPTYPE LEQ MONADIC THEN RT; 00234300
END OF RGTOPERAND; 00234400
BOOLEAN VALID; 00234500
INTEGER OTOP; 00234600
INTEGER BCT,N; REAL COLONCTR; 00234700
LABEL STACKOPERAND, STACKFUNCTION; 00234800
DEFINE PTOP=L#; 00234900
LABEL AROUND, NOK, OK, LFTARROWL, LFTPARENL, RGTPARENL, 00235000
SLASHL,EXPL,ROTL,MONADICL,DYADICL,ERRL,SORTL, 00235100
SEMICOLONL, QUADL, DOTL, RELATIONL, 00235200
LFTBRACKETL, RGTBRACKETL, QUOTEQUADL; 00235300
SWITCH OPERATORSWITCH:= % IN GROUPS OF 5, STARTING AT 1 00235400
NOK, NOK, NOK, LFTARROWL, % 1-4 00235500
MONADICL, SLASHL, OK, LFTPARENL,RGTPARENL, %5-9 00235600
QUADL,LFTBRACKETL,RGTBRACKETL,ERRL,QUOTEQUADL, %10-14 00235700
SEMICOLONL, OK, DOTL, OK, OK, % 15-19 00235800
OK,DYADICL,DYADICL,MONADICL,RELATIONL, % 20-24 00235900
RELATIONL, RELATIONL, RELATIONL, RELATIONL, 00236000
RELATIONL, % 25-29 00236100
OK, OK, OK, OK, OK, %30-34 00236200
OK, OK, ROTL, EXPL, OK, % 35-39 00236300
OK,OK,OK,OK,DYADICL, %40-44 00236400
OK, OK, ERRL, OK, OK, %45-49 00236500
OK, NOK, NOK, NOK, OK, % 50-54 00236600
SORTL,SORTL,OK,OK,OK, % 55-59 00236700
DYADICL, DYADICL, MONADICL; % 60-62 00236800
%----------------------------------------------- 00236900
COMMENT GET AN AREA OF SCRATCH PAD IF WE ARE NOT IN 00237000
THE SYNTAX CHECKING MODE; 00237100
J:=(IF CURRENTMODE=FUNCMODE THEN 0 ELSE 00237200
GS(ITOP+3)); 00237300
I:=ITOP+1; 00237400
COMMENT A QUICK SYNTAX CHECK; 00237500
IF ANDORATOR(INFIX[ITOP],OPERATOR) THEN ERR:=SYNTAXERROR; 00237600
L:=J+1; COMMENT POLISH WILL START TWO UP IN ARRAY; 00237700
WHILE ERR=0 AND I GTR 1 DO 00237800
IF T:=INFIX[I:=I-1].TYPEFIELD=OPERATOR THEN 00237900
BEGIN 00238000
GO OPERATORSWITCH[INFIX[I].LOCFIELD]; 00238100
ROTL: 00238200
IF I=1 OR NOT ANDORATOR(INFIX[I-1],OPERAND) THEN GO OK; 00238300
T:=INFIX[I]; 00238400
T.LOCFIELD:=ROTATE; 00238500
T.OPTYPE:=IF INFIX[I].OPTYPE NEQ DYADIC THEN MONADIC ELSE DYADIC; 00238600
INFIX[I]:=T; GO TO STACKFUNCTION; 00238700
EXPL: 00238800
SLASHL: BEGIN DEFINE STARTSEGMENT= #; %///////////////////// 00238900
IF INFIX[I-1].TYPEFIELD=FUNCTION THEN GO ERRL ELSE 00239000
IF ANDORATOR(INFIX[I-1],OPERATOR) THEN 00239100
BEGIN 00239200
INFIX[I].LOCFIELD:=IF INFIX[I].LOCFIELD=SLASHV THEN 00239300
REDUCT ELSE SCANV; 00239400
00239500
IF INFIX[I].OPTYPE NEQ DYADIC THEN INFIX[I].OPTYPE:=MONADIC; 00239600
GO OK; 00239700
END 00239800
ELSE 00239900
00240000
IF INFIX[I].OPTYPE NEQ DYADIC THEN INFIX[I].OPTYPE:=MONADIC; 00240100
IF I=1 THEN 00240200
00240300
BEGIN 00240400
ERR:=SYNTAXERROR; 00240500
GO AROUND; 00240600
END; 00240700
GO OK; END; 00240800
SORTL: 00240900
IF I=1 OR ANDORATOR(INFIX[I-1],OPERATOR) THEN GO OK ELSE GO ERRL; 00241000
LFTPARENL: 00241100
K:=I; 00241200
UNSTACK(SP,PTOP,OPERATORS,OTOP,2,RGTPARENV,RGTBRACKETV); 00241300
GO AROUND; 00241400
RELATIONL: 00241500
DYADICL: 00241600
IF I GTR 1 THEN 00241700
IF ANDORATOR(INFIX[I-1],OPERAND) THEN 00241800
BEGIN 00241900
INFIX[I].OPTYPE:=DYADIC; 00242000
GO STACKFUNCTION; 00242100
END; 00242200
IF (GT3:=(T:=INFIX[I+1]).LOCFIELD=REDUCT OR GT3=SCANV) 00242300
AND T.TYPEFIELD=OPERATOR THEN GO OK; 00242400
IF(T:=INFIX[I-1]).LOCFIELD=DOTV AND T.TYPEFIELD=OPERATOR THEN GO OK;00242500
GO TO ERRL; 00242600
MONADICL: 00242700
IF I=1 OR ANDORATOR(INFIX[I-1],OPERATOR) 00242800
THEN BEGIN 00242900
INFIX[I].OPTYPE:=MONADIC; 00243000
GO TO STACKFUNCTION; 00243100
END 00243200
ELSE 00243300
GO ERRL; 00243400
LFTBRACKETL: 00243500
IF BCT:=BCT-1 LSS 0 THEN ERR:=SYNTAXERROR; 00243600
UNSTACK(SP,PTOP,OPERATORS,OTOP,1,RGTBRACKETV,RGTPARENV); 00243700
IF OTOP=1 THEN BEGIN 00243800
ERR:=SYNTAXERROR; GO AROUND; END 00243900
ELSE IF J NEQ 0 THEN 00244000
BEGIN 00244100
IF T:=INFIX[I-1].TYPEFIELD=OPERAND OR T=LOCALVAR THEN 00244200
BEGIN DEFINE STARTSEGMENT= #; %/////////////////////////// 00244300
%LFTBRACKET PART OF SUBSCRIPTED VARIABLE 00244400
IF OPERATORS[OTOP].OPTYPE=0 THEN GO TO ERRL; 00244500
COMMENT IF ABOVE TRUE THEN THERE WAS AN OPERAND TO THE RITE;00244600
L:=L+1; 00244700
N:=GT1:=GETSPACE(1); 00244800
SP[NOC]:=COLONCTR+1; % STORE NUMBER OF DIMENSIONS 00244900
N:=GETSPACE(1); % BUILD A DESCRIPTOR FOR # OF DIMENSIONS 00245000
T.SPF:=GT1; 00245100
T.DID:=DDPNSW; 00245200
T.BACKP:=LASTCONSTANT; 00245300
SP[NOC]:=T; 00245400
T:=INFIX[I]; 00245500
T.LOCFIELD:=LASTCONSTANT:=N; % LINK TO CONSTANT CHAIN 00245600
T.TYPEFIELD:=CONSTANT; 00245700
SP[LOC]:=T; % PUT ON POLISH 00245800
L:=L+1; 00245900
IF OPERATORS[OTOP].OPTYPE=3 THEN % LEFT SIDE OF REPLACEOP 00246000
INFIX[I-1].TYPEFIELD:=REPLACELOC; 00246100
SP[LOC]:=INFIX[I-1]; % PLACE OPERAND ON POLISH 00246200
L:=L+1; 00246300
SP[LOC]:=INFIX[I]; % COLLAPSE OPERATOR TO POLISH 00246400
I:=I-1; 00246500
END 00246600
ELSE IF T:=INFIX[I-1].LOCFIELD=SLASHV OR 00246700
T=EXPANDV OR T=ROTV OR T=SORTUPV OR T=SORTDNV THEN 00246800
IF INFIX[I-1].TYPEFIELD=OPERATOR AND OPERATORS[OTOP] 00246900
.OPTYPE=0 THEN INFIX[I-1].OPTYPE:=DYADIC 00247000
ELSE ERR:=SYNTAXERROR 00247100
ELSE ERR:=SYNTAXERROR; 00247200
END; 00247300
COLONCTR:=OPERATORS[OTOP:=OTOP-1]; 00247400
IF OTOP:=OTOP-1 LSS 0 THEN ERR:=SYNTAXERROR; 00247500
GO AROUND; 00247600
RGTPARENL: 00247700
IF OTOP LSS ITOP DIV 2 THEN ELSE ERR:=SYNTAXERROR; 00247800
OPERATORS[OTOP:=OTOP+1]:=INFIX[I]; 00247900
GO AROUND; 00248000
RGTBRACKETL: BEGIN DEFINE STARTSEGMENT= #; %/////////////////// 00248100
BCT:=BCT+1; 00248200
IF OTOP+2 GEQ ITOP THEN 00248300
BEGIN 00248400
ERR:=SYNTAXERROR; 00248500
GO AROUND; 00248600
END; 00248700
OPERATORS[OTOP:=OTOP+1]:=COLONCTR; 00248800
GT1:=OPERATORS[OTOP:=OTOP+1]:=INFIX[I]; COLONCTR:=0; 00248900
IF I NEQ ITOP THEN 00249000
IF GT1.OPTYPE NEQ 3 THEN 00249100
OPERATORS[OTOP].OPTYPE:=IF RGTOPERAND(INFIX[I+1]) THEN 00249200
0 ELSE 2 00249300
ELSE 00249400
ELSE OPERATORS[OTOP].OPTYPE:=2; 00249500
IF J NEQ 0 AND INFIX[I-1].LOCFIELD=SEMICOLONV THEN 00249600
BEGIN 00249700
T.LOCFIELD:=BUILDNULL(LASTCONSTANT); 00249800
T.TYPEFIELD:=CONSTANT; 00249900
L:=L+1; K:=I; 00250000
SP[LOC]:=T; 00250100
END; 00250200
GO AROUND; END; 00250300
LFTARROWL: 00250400
IF I=1 THEN ERR:=SYNTAXERROR 00250500
ELSE 00250600
IF T:=INFIX[I-1].TYPEFIELD=OPERAND OR T=LOCALVAR THEN 00250700
INFIX[I-1].TYPEFIELD:=REPLACELOC 00250800
ELSE 00250900
IF T=OPERATOR THEN 00251000
IF T:=INFIX[I-1].LOCFIELD=QUAD OR T=QUADLFTARROW THEN 00251100
INFIX[I:=I-1].LOCFIELD:=QUADLFTARROW 00251200
ELSE IF T=RGTBRACKETV THEN INFIX[I-1].OPTYPE:=3 00251300
%WILL TEST LATER TO INDICATE REPLACEMENT IN MATRIX 3105154 00251400
ELSE ERR:=SYNTAXERROR 00251500
ELSE ERR:=SYNTAXERROR; 00251600
IF ERR=0 THEN GO OK ELSE GO AROUND; 00251700
QUOTEQUADL: 00251800
QUADL: 00251900
COMMENT INPUT IS BEING REQUESTED; 00252000
GO TO STACKOPERAND; 00252100
DOTL: BEGIN DEFINE STARTSEGMENT=#; %//////////////////////////// 00252200
IF I GTR 2 THEN 00252300
IF (T:=INFIX[I-1]).TYPEFIELD=OPERATOR AND 00252400
ANDORATOR(T,OPERATOR) THEN 00252500
IF (T:=INFIX[I+1]).TYPEFIELD=OPERATOR AND 00252600
ANDORATOR(T,OPERATOR) THEN 00252700
IF ANDORATOR(INFIX[I-2],OPERAND) THEN 00252800
COMMENT THEN SYNTAX OK; 00252900
BEGIN 00253000
COMMENT STACK OPERATORS SO THAT IF GIVEN A+.XB 00253100
POLISH IS BA.+X; 00253200
OPERATORS[OTOP].OPTYPE:=TRIADIC; 00253300
OPERATORS[OTOP:=OTOP+1]:=INFIX[I-1]; 00253400
INFIX[I].OPTYPE:=TRIADIC; 00253500
OPERATORS[OTOP:=OTOP+1]:=INFIX[I]; 00253600
I:=I-1; 00253700
VALID:=TRUE; 00253800
END; 00253900
IF NOT VALID THEN ERR:=SYNTAXERROR; 00254000
VALID:=FALSE; 00254100
GO AROUND; END; 00254200
SEMICOLONL: BEGIN DEFINE STARTSEGMENT=#; %////////////////////// 00254300
IF BCT NEQ 0 THEN 00254400
BEGIN 00254500
COLONCTR:=COLONCTR+1; 00254600
IF I-1=0 THEN ERR:=SYNTAXERROR 00254700
ELSE 00254800
BEGIN 00254900
UNSTACK(SP,PTOP,OPERATORS,OTOP,1,RGTBRACKETV,RGTPARENV); 00255000
IF J NEQ 0 AND (T:=INFIX[I-1].LOCFIELD=SEMICOLONV 00255100
OR T =LFTBRACKETV) THEN BEGIN 00255200
T.LOCFIELD:=BUILDNULL(LASTCONSTANT); 00255300
T.TYPEFIELD:=CONSTANT; 00255400
L:=L+1; K:=I; 00255500
SP[LOC]:=T; 00255600
END; 00255700
END 00255800
END 00255900
ELSE COMMENT MUST BE MIXED MODE EXPRESSION; 00256000
BEGIN 00256100
IF ANDORATOR(T:=INFIX[I-1],OPERATOR) THEN 00256200
IF T.LOCFIELD NEQ SEMICOLONV THEN GO ERRL; 00256300
UNSTACK(SP,PTOP,OPERATORS,OTOP,1,RGTPARENV,RGTBRACKETV); 00256400
OPERATORS[OTOP:=OTOP+1]:=INFIX[I]; 00256500
END; 00256600
GO AROUND; 00256700
END; 00256800
NOK: 00256900
ERR:=SYNTAXERROR; 00257000
GO AROUND; 00257100
ERRL: 00257200
ERR:=SYNTAXERROR; 00257300
GO AROUND; 00257400
OK: 00257500
IF INFIX[I].OPTYPE NEQ 0 THEN GO TO STACKFUNCTION ELSE 00257600
IF I LSS 2 THEN INFIX[I].OPTYPE:=MONADIC ELSE 00257700
INFIX[I].OPTYPE:=IF ANDORATOR(INFIX[I-1],OPERATOR) THEN 00257800
MONADIC ELSE DYADIC; 00257900
00258000
00258100
STACKFUNCTION: 00258200
IF I=K-1 THEN OPERATORS[OTOP:=OTOP+1]:=INFIX[I] 00258300
ELSE 00258400
BEGIN 00258500
UNSTACK(SP,PTOP,OPERATORS,OTOP,1,RGTPARENV,RGTBRACKETV); 00258600
OPERATORS[OTOP:=OTOP+1]:=INFIX[I]; 00258700
END; 00258800
GO AROUND; 00258900
AROUND: 00259000
END % OF PROCESSING AN OPERATOR---- 00259100
ELSE % COULD BE A FUNCTION 00259200
IF INFIX[I].TYPEFIELD=FUNCTION THEN 00259300
IF (T:=INFIX[I]).OPTYPE GEQ MONADIC THEN 00259400
GO TO STACKFUNCTION 00259500
ELSE 00259600
IF T.RF=RETURNVAL THEN GO TO STACKOPERAND 00259700
ELSE % MUST NOT RETURN A VALUE 00259800
IF I=1 THEN GO TO STACKOPERAND 00259900
ELSE ERR:=SYNTAXERROR 00260000
ELSE % MUST BE AN OPERAND, CONSTANT OR LOCAL 00260100
STACKOPERAND: 00260200
BEGIN DEFINE STARTSEGMENT=#; %/////////////////////////////// 00260300
IF ITOP=1 THEN ELSE 00260400
IF I=ITOP AND I NEQ 1 THEN 00260500
IF ANDORATOR(INFIX[I-1],OPERAND) THEN 00260600
IF INFIX[I-1].LOCFIELD=RGTBRACKETV THEN 00260700
ELSE GO ERRL 00260800
ELSE 00260900
ELSE 00261000
IF I=1 AND I NEQ ITOP THEN 00261100
IF RGTOPERAND(INFIX[I+1]) THEN GO ERRL 00261200
ELSE 00261300
ELSE 00261400
IF ANDORATOR(INFIX[I-1],OPERAND) OR RGTOPERAND(INFIX[I+1]) 00261500
THEN 00261600
IF INFIX[I-1].LOCFIELD=RGTBRACKETV THEN 00261700
ELSE GO ERRL; 00261800
IF J NEQ 0 THEN 00261900
BEGIN L:=L+1; 00262000
SP[LOC]:=INFIX[I]; 00262100
END; K:=I; 00262200
UNSTACK(SP,PTOP,OPERATORS,OTOP,1,RGTPARENV,RGTBRACKETV); 00262300
END; % OF GOING THROUGH INFIX 00262400
IF ERR NEQ 0 THEN ERRORMESS(ERR,INFIX[I].ADDRFIELD,0) ELSE 00262500
WHILE OTOP GTR 0 AND ERR=0 DO 00262600
BEGIN IF T:=OPERATORS[OTOP].LOCFIELD=RGTPARENV OR 00262700
T=RGTBRACKETV THEN 00262800
IF OPERATORS[OTOP].TYPEFIELD=OPERATOR THEN 00262900
ERRORMESS(ERR:=SYNTAXERROR,OPERATORS[OTOP].ADDRFIELD 00263000
,0); 00263100
IF J NEQ 0 THEN 00263200
BEGIN L:=L+1; 00263300
SP[LOC]:=OPERATORS[OTOP] 00263400
END; OTOP:=OTOP-1; 00263500
END; 00263600
IF J NEQ 0 AND DISPLAYOP THEN 00263700
IF SP[LOC].TYPEFIELD NEQ OPERATOR OR 00263800
T:=SP[LOC].LOCFIELD NEQ LFTARROWV 00263900
AND T NEQ QUADLFTARROW AND T NEQ GOTOV THEN 00264000
BEGIN COMMENT ADD DIISPLAY OPERATOR TO POLISH; 00264100
L:=L+1; 00264200
T.TYPEFIELD:=OPERATOR; 00264300
T.OPTYPE:=MONADIC; 00264400
T.LOCFIELD:=QUADLFTARROW; 00264500
SP[LOC]:=T; 00264600
END; 00264700
IF J NEQ 0 THEN 00264800
IF ERR NEQ 0 THEN FORGETSPACE (J,ITOP+3,SP) ELSE 00264900
COMMENT STORE POLISH AND BUFFER; 00265000
BEGIN COMMENT SAVE LENGTH OF POLISH; 00265100
DEFINE STARTSEGMENT=#; %//////////////////////////////////// 00265200
T:=L-J; % DELETE ANY EXTRA SPACE ALLOCATED FOR POLISH 00265300
IF T LSS ITOP+2 THEN FORGETSPACE(L+1,2+ITOP-T,SP); 00265400
COMMENT THEN GETSPACE FOR BUFFER; 00265500
L:=GS(((K:=LENGTH(BUFFER, CURRENTMODE= 00265600
CALCMODE))-1) DIV 8 +2); 00265700
COMMENT L IS THE ADDRESS OF THE BUFFER; 00265800
SP[LOC]:=K; %NUMBER OF CHARACTERS IN THE BUFFER; 00265900
TRANSFERSP(INTO,SP,L+1,BUFFER,0,ENTIER((K+7)DIV 8)); 00266000
COMMENT WE HAVE MOVED IN THE BUFFER; 00266100
K:=L; %SAVE THE ADDRESS OF THE BUFFER; 00266200
L:=J+1; % ONE WORD UP IN THE POLISH 00266300
SP[LOC].SPF:=K; %STORE ADDRESS OF BUFFER 00266400
SP[LOC].RF:=1; % SET THE RANK TO 1 00266500
SP[LOC].DID:=DDPNVC; 00266600
L:=L-1; %SET THE LENGTH OF POLISH 00266700
SP[LOC]:=T; %STORE THE LENGTH OF THE POLISH 00266800
T:=0; T.SPF:=J; T.RF:=1; %SET UP PROG DESC IN T 00266900
T.BACKP:=LASTCONSTANT; 00267000
T.DID:=PDC; ANALYZE:=T; 00267100
COMMENT DEBUG THE POLISH IF NECESSARY; 00267200
IF POLBUG=1 THEN DUMPOLISH(SP,T); 00267300
END; 00267400
%-------------------------------------------------- 00267500
END; 00267600
END; 00267700
PROCEDURE OPERANDTOSYMTAB(L);VALUE L;INTEGER L; 00267800
BEGIN 00267900
INTEGER N; 00268000
TRANSFER(ACCUM,2,GTA,0,7); 00268100
IF(IF VARIABLES=0 THEN FALSE ELSE 00268200
SEARCHORD(VARIABLES,GTA,GT1,7)=0) THEN 00268300
BEGIN 00268400
SP[LOC].TYPEFIELD:=GT1:=GETFIELD(GTA,7,1); 00268500
IF GT1=FUNCTION THEN 00268600
BEGIN 00268700
L:=L+1;SP[LOC]:=GTA[1] 00268800
END ELSE %MUST BE AN OPERAND 00268900
BEGIN 00269000
SP[LOC].TYPEFIELD:=OPERAND; 00269100
L:=L+1; 00269200
IF GT1=0 THEN % THIS IS THE SCALAR CASE 00269300
BEGIN N:=GETSPACE(1); 00269400
SP[LOC]:=N&DDPNSW[CDID]; 00269500
SP[NOC]:=GTA[1]; 00269600
END ELSE %IT MUST BE A VECTOR 00269700
SP[LOC]:=GTA[1]; 00269800
END; 00269900
END ELSE % NOT IN THE SYMBOL TABLE 00270000
BEGIN 00270100
SP[LOC].TYPEFIELD:=GT1:=OPERAND; 00270200
L:=L+1; SP[LOC]:=NAMEDNULLV; 00270300
% THE UNDEFINED SYMBOL IS A NULL 00270400
00270500
END; 00270600
END; %OF PROCEDURE OPERANDTOSYMTAB 00270700
INTEGER PROCEDURE GETSPACE(LENGTH); VALUE LENGTH; 00270800
INTEGER LENGTH; 00270900
BEGIN 00271000
LABEL ENDGETSPACE,SPOVERFLOW; 00271100
MONITOR INDEX; 00271200
INTEGER L,NEXTAREA,LASTAREA,OLDROW,K; 00271300
INTEGER MEMCHECK; 00271400
REAL LINK; 00271500
INDEX:=SPOVERFLOW; 00271600
NEXTAREA:=SP[0,0]; 00271700
LASTAREA:=0; 00271800
DO BEGIN COMMENT FIND A LARGE ENOUGH AREA; 00271900
IF MEMCHECK:=MEMCHECK+1 GTR MAXMEMACCESSES THEN %ERR 00272000
BEGIN GETSPACE:=-1@10; ERR:=SPERROR; 00272100
GO TO ENDGETSPACE END; 00272200
IF NEXTAREA =0 THEN COMMENT END OF STORAGE; 00272300
BEGIN 00272400
IF NROWS:=(OLDROW:=NROWS)+K:=ENTIER(LENGTH/ 00272500
SPRSIZE+1) 00272600
GTR MAXSPROWS THEN %OFF THE END OF SP 00272700
BEGIN COMMENT TAKE EASY WAY IOUT FOR NOW; 00272800
GETSPACE:=-1@10; %CAUSE INVALID INDEX 00272900
NROWS:=OLDROW; ERR:=SPERROR; 00273000
GO TO ENDGETSPACE; 00273100
END; 00273200
K:=K|SPRSIZE; 00273300
00273400
L:=LASTAREA; 00273500
IF OLDROW = -1 THEN COMMENT FORST RQOW OF SP; 00273600
BEGIN SP[0,0].NEXT:=L:=1; K:=K-1 00273700
END ELSE 00273800
BEGIN SP[LOC].NEXT:=(OLDROW+1)|SPRSIZE; 00273900
L:=(OLDROW+1)|SPRSIZE; 00274000
END; 00274100
SP[LOC].LEN:=K; SP[LOC].NEXT:=0; 00274200
NEXTAREA:=L 00274300
END ELSE L:=NEXTAREA; 00274400
LINK:=SP[LOC]; 00274500
K:=LINK.LEN-LENGTH; 00274600
IF K LSS 0 THEN COMMENT NOT ENOUGH ROOM; 00274700
BEGIN L:=LASTAREA:=NEXTAREA; 00274800
NEXTAREA:=LINK.NEXT 00274900
END; 00275000
END UNTIL K GEQ 0; 00275100
IF K GTR 0 THEN 00275200
BEGIN ;L:=L+LENGTH; 00275300
SP[LOC]:=0; 00275400
SP[LOC].LEN:=K; SP[LOC].NEXT:=LINK.NEXT; 00275500
END ELSE L:=LINK.NEXT; 00275600
K:=L; L:=LASTAREA; 00275700
COMMENT ZERO OUT THE STORAGE BEFORE ALLOCATION; 00275800
SP[LOC].NEXT:=K; K:=NEXTAREA+LENGTH-1; 00275900
FOR L:=GETSPACE:=NEXTAREA STEP 1 UNTIL K DO SP[LOC]:=0; 00276000
IF FALSE THEN SPOVERFLOW: BEGIN 00276100
GETSPACE:=-1@10;ERR:=SPERROR END; 00276200
ENDGETSPACE: 00276300
END OF GETSPACE; 00276400
PROCEDURE FORGETSPACE(LOCATE,LENGTH); VALUE LOCATE,LENGTH; 00276500
INTEGER LOCATE,LENGTH; 00276600
BEGIN INTEGER L; 00276700
IF LENGTH GTR 0 THEN BEGIN 00276800
L:=LOCATE; 00276900
SP[LOC]:=SP[0,0]; 00277000
SP[LOC].LEN:=LENGTH; 00277100
SP[0,0]:=L; 00277200
END; 00277300
END; 00277400
INTEGER PROCEDURE BUILDNULL(LASTCONSTANT); 00277500
INTEGER LASTCONSTANT; 00277600
BEGIN REAL T, N; 00277700
IF NOT CURRENTMODE=FUNCMODE THEN 00277800
BEGIN 00277900
T:=0; 00278000
T.DID:=DDPNVW; 00278100
T.BACKP:=LASTCONSTANT; 00278200
LASTCONSTANT:=BUILDNULL:=N:=GETSPACE(1); 00278300
SP[NOC]:=T; 00278400
END; 00278500
END OF BUILDNULL; 00278600
00278700
INTEGER PROCEDURE BUILDCONSTANT(LASTCONSTANT); 00278800
INTEGER LASTCONSTANT; 00278900
BEGIN ARRAY A[0:MAXCONSTANT]; 00279000
INTEGER ATOP,L,K; 00279100
REAL AP; 00279200
DEFINE GS=GETSPACE#; 00279300
DO 00279400
A[ATOP:=ATOP+1]:=ACCUM[0] 00279500
UNTIL NOT SCAN OR NOT NUMERIC OR ATOP = MAXCONSTANT; 00279600
IF MAXCONSTANT=ATOP OR ERR NEQ 0 THEN COMMENT AN ERROR; 00279700
ELSE 00279800
00279900
IF ATOP=1 THEN COMMENT SCALAR FOUND; 00280000
BEGIN L:=K:=GS(1); 00280100
SP[LOC]:=A[1]; 00280200
BUILDCONSTANT:=L:=GETSPACE(1); 00280300
SP[LOC]:=K&DDPNSW[CDID]&LASTCONSTANT[CLOCF]; 00280400
LASTCONSTANT:=L; 00280500
END ELSE COMMENT VECTOR; 00280600
BEGIN L:=K:=GS(ATOP+1); 00280700
TRANSFERSP(INTO,SP,L+1,A,1,ATOP); 00280800
SP[LOC]:=ATOP; 00280900
BUILDCONSTANT:=L:=GS(1); %VECTOR DESCRIPTOR 00281000
SP[LOC]:=K&1[CRF]&DDPNVW[CDID]&LASTCONSTANT[CLOCF]; 00281100
LASTCONSTANT:=L; 00281200
END 00281300
00281400
END; 00281500
OWN INTEGER OLDDATA,REALLYERROR; 00281600
INTEGER L,N,M; 00281700
OWN REAL ST,T,U; 00281800
LABEL EXECUTION,PROCESSEXIT; 00281900
DEFINE STLOC=ST.[30:11],ST.[41:7]#, 00282000
STMINUS=(ST-1).[30:11],(ST-1).[41:7]#, 00282100
AREG=SP[STLOC]#, 00282200
BREG=SP[STMINUS]#, 00282300
BACKPT=6:36:12#, 00282400
CI=18:36:12#, 00282500
SPTSP=30:30:18#, 00282600
PROGMKS=0#, 00282700
IMKS=2#, 00282800
FMKS=1#, 00282900
00283000
BACKF=[6:12]#, 00283100
CIF=[18:12]#, 00283200
ENDEF=#; 00283300
PROCEDURE PACK(L,OFFSET,N);VALUE L,OFFSET,N;INTEGER L,OFFSET,N; 00283400
FORWARD; 00283500
INTEGER PROCEDURE UNPACK(S,OFFSET,N);VALUE S,OFFSET,N; 00283600
INTEGER S,OFFSET,N; FORWARD; 00283700
PROCEDURE PUSH; 00283800
IF ST LSS STACKSIZE+STACKBASE THEN ST:=ST+1 ELSE 00283900
ERR:=DEPTHERROR; 00284000
PROCEDURE POP; 00284100
BEGIN REAL U; 00284200
IF ST GTR STACKBASE THEN 00284300
IF BOOLEAN((U:=AREG).NAMED)OR NOT BOOLEAN(U.PRESENCE) 00284400
THEN ST:=ST-1 ELSE 00284500
BEGIN COMMENT GET RID OF SP STORAGE FOR THIS VARIABLE; 00284600
IF U.SPF NEQ 0 AND BOOLEAN(U.DATADESC) THEN 00284700
SCRATCHDATA(U); 00284800
00284900
ST:=ST-1; 00285000
END 00285100
ELSE ERR:=SYSTEMERROR; 00285200
END; 00285300
REAL PROCEDURE GETARRAY(DESCRIPTOR); VALUE DESCRIPTOR; 00285400
REAL DESCRIPTOR; 00285500
BEGIN 00285600
INTEGER R,I,J,K,L,LL,TOTAL,PT; 00285700
REAL T; 00285800
ARRAY BLOCK[0:BLOCKSIZE],DIMVECTOR[0:32]; 00285900
%SEE MAXWORDSTORE, LINE 17260 00286000
00286100
T:=DESCRIPTOR; 00286200
IF (R:=DESCRIPTOR.RF=0) THEN T.DIMPTR:=0 00286300
ELSE BEGIN 00286400
I:=CONTENTS(WS,DESCRIPTOR.DIMPTR,DIMVECTOR); 00286500
TOTAL:=1; 00286600
FOR I:=0 STEP 1 UNTIL R-1 DO 00286700
TOTAL:=TOTAL|DIMVECTOR[I]; 00286800
IF DESCRIPTOR.ARRAYTYPE=CHARARRAY THEN 00286900
TOTAL:=ENTIER((TOTAL+7) DIV 8); 00287000
TOTAL:=TOTAL+R; 00287100
LL:=GETSPACE(TOTAL); 00287200
TRANSFERSP(INTO,SP,LL,DIMVECTOR,0,R); 00287300
L:=LL+R; 00287400
J:=CONTENTS(WS,DESCRIPTOR.INPTR,DIMVECTOR)-1; 00287500
GTA[0]:=0; 00287600
FOR I:=0 STEP 2 UNTIL J DO 00287700
BEGIN 00287800
TRANSFER(DIMVECTOR,I,GTA,6,2); 00287900
PT:=GTA[0]; 00288000
K:=CONTENTS(WS,PT,BLOCK); 00288100
TRANSFERSP(INTO,SP,L,BLOCK,0, 00288200
(K:=ENTIER((K+7)DIV 8))); 00288300
L:=L+K; 00288400
END; 00288500
T.DIMPTR:=L; 00288600
END; 00288700
T.INPTR:=0; 00288800
T.PRESENCE:=1; 00288900
GETARRAY:=T; 00289000
END; 00289100
INTEGER PROCEDURE FINDSIZE(D);VALUE D; REAL D; 00289200
BEGIN 00289300
INTEGER I,J,M,R; 00289400
J:=1; I:=D.SPF; R:=D.RF+I-1; 00289500
IF I NEQ 0 THEN 00289600
FOR M:=I STEP 1 UNTIL R DO J:=J|SP[MOC]; 00289700
FINDSIZE:=J; 00289800
END PROCEDURE FINDSIZE; 00289900
00290000
INTEGER PROCEDURE NUMELEMENTS(D); VALUE D; REAL D; 00290100
BEGIN 00290200
INTEGER I; 00290300
GT1:=I:=FINDSIZE(D); 00290400
IF D.ARRAYTYPE=CHARARRAY THEN 00290500
I:=ENTIER((I+7) DIV 8); 00290600
NUMELEMENTS:=I; 00290700
END; 00290800
PROCEDURE SCRATCHDATA(D); VALUE D; REAL D; 00290900
BEGIN 00291000
INTEGER T,R; 00291100
IF BOOLEAN(D.SCALAR) THEN T:=1 ELSE 00291200
IF R:=D.RF = 0 THEN T:=0 ELSE %BONAFIDE VECTOR 00291300
BEGIN T:=NUMELEMENTS(D)+R; 00291400
00291500
END; 00291600
IF T NEQ 0 THEN FORGETSPACE(D.SPF,T); 00291700
END; 00291800
COMMENT RELEASEARRAY HAS BEEN MOVED WOUT OF PROCESS SO THAT IT 00291900
CAN BE CALLED ELSEWHERE; 00292000
REAL PROCEDURE MOVEARRAY(SPDESC); VALUE SPDESC; 00292100
REAL SPDESC; 00292200
COMMENT MOVE THE ARRAY FROM SCRATCHPAD TO PERMANENT 00292300
STORAGE AND CONSTRUCT NEW DESCRIPTOR; 00292400
BEGIN 00292500
INTEGER TOTAL,R,J,M,K; 00292600
REAL T; 00292700
ARRAY BLOCK[0:BLOCKSIZE],BUFFER[0:32]; %SEE MAXWORDSTORE, LINE 1726000292800
T:=SPDESC; 00292900
TRANSFERSP(OUTOF,SP,SPDESC.SPF,BUFFER,0,R:=SPDESC.RF); 00293000
T.DIMPTR:=STORESEQ(WS,BUFFER,8|R); 00293100
TOTAL:=NUMELEMENTS(SPDESC); 00293200
M:=SPDESC.SPF+R; 00293300
K:=ENTIER(TOTAL DIV BLOCKSIZE)-1; 00293400
FOR J:=0 STEP 1 UNTIL K DO BEGIN 00293500
TRANSFERSP(OUTOF,SP,M,BLOCK,0,BLOCKSIZE); 00293600
R:=STORESEQ(WS,BLOCK,BLOCKSIZE|8); 00293700
TRANSFER(R,6,BUFFER,J|2,2); 00293800
M:=M+BLOCKSIZE; 00293900
END; 00294000
IF J:=TOTAL-(K:=K+1)|BLOCKSIZE GTR 0 THEN 00294100
BEGIN 00294200
TRANSFERSP(OUTOF,SP,M,BLOCK,0,J); %GET REMAINDER OF MATRIX 00294300
R:=STORESEQ(WS,BLOCK,J|8); 00294400
TRANSFER(R,6,BUFFER,K|2,2); 00294500
K:=K+1; 00294600
END; 00294700
T.INPTR:=STORESEQ(WS,BUFFER,K|K); 00294800
MOVEARRAY:=T; 00294900
END; 00295000
PROCEDURE WRITEBACK; 00295100
COMMENT COPY CHANGED VARIABLES INTO PREMANENT STORAGE; 00295200
BEGIN 00295300
INTEGER I,J,K,L,M,NUM; 00295400
REAL T; 00295500
ARRAY NEWDESC[0:1],OLDDESC [0:1]; 00295600
L:=SYMBASE; 00295700
NUM:=SP[LOC]-1; 00295800
L:=L-1; 00295900
FOR I:=1 STEP 2 UNTIL NUM DO BEGIN 00296000
L:=L+2; 00296100
IF ((T:=SP[LOC]).TYPEFIELD) NEQ FUNCTION THEN 00296200
IF BOOLEAN(T.CHANGE) THEN BEGIN 00296300
IF VARIABLES=0 THEN 00296400
00296500
BEGIN VARIABLES:=NEXTUNIT; 00296600
T:=CURRENTMODE; 00296700
VARSIZE:=1; STOREPSR; 00296800
CURRENTMODE:=T; VARSIZE:=0; 00296900
END; 00297000
M:=L+1;WHILE(T:=SP[MOC]).BACKP NEQ 0 AND T.PRESENCE=1 00297100
AND(GT1:=GT1+1)LSS MAXMEMACCESSES DO M:=T.BACKP;GT1:=0; 00297200
GTA[0]:=SP[LOC];GTA[1]:=T; 00297300
TRANSFER(GTA,1,NEWDESC,0,7); 00297400
00297500
SETFIELD(NEWDESC,7,1, IF BOOLEAN(T.SCALAR) 00297600
THEN SCALARDATA ELSE ARRAYDATA); 00297700
MOVE(NEWDESC,1,OLDDESC); K:=1; 00297800
IF (IF VARSIZE=0 THEN FALSE ELSE 00297900
K:=SEARCHORD(VARIABLES,NEWDESC,J,7)=0) 00298000
THEN BEGIN 00298100
K:=CONTENTS(VARIABLES,J,OLDDESC); 00298200
DELETE1(VARIABLES,J); 00298300
IF GETFIELD(OLDDESC,7,1)=ARRAYDATA THEN 00298400
RELEASEARRAY(OLDDESC[1]); 00298500
END ELSE 00298600
BEGIN VARSIZE:=VARSIZE+1; J:=J+K-1; 00298700
MOVE(OLDDESC,1,NEWDESC); 00298800
END; 00298900
SETFIELD(NEWDESC,7,1,IF BOOLEAN(T.SCALAR) 00299000
THEN SCALARDATA ELSE ARRAYDATA); 00299100
IF BOOLEAN(T.SCALAR) THEN 00299200
BEGIN M:=T.SPF; 00299300
NEWDESC[1]:=SP[MOC]; 00299400
END ELSE %A VECTEOR 00299500
BEGIN T.PRESENCE:=0; 00299600
NEWDESC[1]:=(IF T.RF NEQ 0 THEN 00299700
MOVEARRAY(T) ELSE T) 00299800
END; 00299900
STOREORD(VARIABLES,NEWDESC,J); 00300000
00300100
END; 00300200
END; 00300300
END; 00300400
PROCEDURE SPCOPY(S,D,N);VALUE S,D,N;INTEGER S,D,N; 00300500
BEGIN 00300600
INTEGER K; 00300700
WHILE (N:=N-K) GTR 0 DO 00300800
TRANSFERSP(INTO,SP,(D:=D+K),SP[(S:=S+K)DIV SPRSIZE,*], 00300900
K:=S MOD SPRSIZE,K:=MIN(N,SPRSIZE-K)); 00301000
END; 00301100
INTEGER PROCEDURE CHAIN(D,CHAINLOC); VALUE D,CHAINLOC; 00301200
INTEGER CHAINLOC; REAL D; 00301300
BEGIN 00301400
INTEGER M; 00301500
CHAIN:=M:=GETSPACE(1); 00301600
D.LOCFIELD:=CHAINLOC; 00301700
SP[MOC]:=D; 00301800
END; 00301900
PROCEDURE SCRATCHAIN(L); VALUE L; INTEGER L; 00302000
BEGIN 00302100
REAL R; 00302200
WHILE L NEQ 0 DO BEGIN 00302300
SCRATCHDATA(R:=SP[LOC]); 00302400
FORGETSPACE(L,1); 00302500
IF L=R.LOCFIELD THEN L:=0 ELSE 00302600
L:=R.LOCFIELD; 00302700
END; 00302800
END; 00302900
PROCEDURE RESTORELOCALS(FPTR);VALUE FPTR;REAL FPTR; 00303000
BEGIN 00303100
INTEGER L,M,N,I,K,FLOC; 00303200
REAL T; 00303300
M:=FPTR.LOCFIELD; 00303400
L:=FPTR.SPF+2;K:=SP[LOC]-2;%LAST ALPHA POINTER 00303500
T:=L+4; 00303600
FOR I:=T STEP 2 UNTIL K DO % ONCE FOR EACH LOCAL 00303700
BEGIN 00303800
M:=M+1;N:=SP[MOC].SPF; %LOCATION IN SYMBOL TABLE 00303900
T:=SP[NOC];L:=T.BACKP;T.BACKP:=0;T.NAMED:=0; 00304000
SP[MOC]:=T;%COPY OF DESCRIPTOR TO STACK 00304100
IF L=0 THEN 00304200
BEGIN N:=N-1; GTA[0]:=SP[NOC]; 00304300
TRANSFER(GTA,1,ACCUM,2,7); OPERANDTOSYMTAB(N); 00304400
END 00304500
ELSE BEGIN SP[NOC]:=SP[LOC];FORGETSPACE(L,1);END; 00304600
END; 00304700
END; % OF PROCEDURE RESTORELOCALS 00304800
OWN INTEGER FUNCLOC,POLLOC,LASTMKS,POLTOP,CINDEX; 00304900
PROCEDURE STEPLINE(LABELED); VALUE LABELED; 00305000
BOOLEAN LABELED; 00305100
00305200
BEGIN 00305300
LABEL ENDFUNC,TERMINATE,DONE; 00305400
LABEL BUMPLINE; 00305500
LABEL TRYNEXT; 00305600
REAL STREAM PROCEDURE CON(A); VALUE A; 00305700
BEGIN SI:=LOC A; DI:=LOC CON; DS:=8DEC; 00305800
END; 00305900
INTEGER C; 00306000
REAL N,T,L,TLAST,M,BASE; 00306100
COMMENT 00306200
MONITOR PRINT (FUNCLOC,POLLOC,LASTMKS,POLTOP,CINDEX,N,T,L, 00306300
TLAST,M,BASE); 00306400
L:=FUNCLOC;M:=SP[LOC].SPF+L; 00306500
IF BOOLEAN(SP[MOC].SUSPENDED) THEN 00306600
BEGIN %RESUME A SUSPENDED FUNCTI+ON 00306700
SP[MOC].SUSPENDED:=0;%REMOVE SUSPENDED BIT 00306800
RESTORELOCALS(SP[MOC]); 00306900
SP[LOC].RF:=N:=SP[LOC].RF-1; 00307000
IF N LEQ 0 THEN SUSPENSION:=0;% NO MORE SUSPENDED FNS 00307100
END; 00307200
IF LABELED THEN %MAKE INITIAL CHECKS AND CHANGES; 00307300
BEGIN 00307400
IF NOT BOOLEAN((T:=AREG).PRESENCE) OR L:=T.SPF=0 00307500
THEN 00307600
BEGIN LABELED:=FALSE; GO TO BUMPLINE; 00307700
END; 00307800
IF BOOLEAN (T.CHRMODE) THEN GO TO TERMINATE; 00307900
L:=L+T.RF; %PICK UP THE FIRST ELEMENT OF THE ARRAY 00308000
IF T:=SP[LOC] GTR 9999.99994 OR T LSS 0 THEN 00308100
T:=0; 00308200
T:=CON(ENTIER(T|10000+.5)) 00308300
END; BUMPLINE: 00308400
L:=LASTMKS; TLAST:=SP[LOC].BACKF; 00308500
C:=(LASTMKS:=SP[MOC].LOCFIELD)-STACKBASE;%LOC OF FMKS 00308600
WHILE TLAST GTR C DO %STRIP OFF CURRENT LINE 00308700
BEGIN L:=TLAST+STACKBASE;TLAST:=(N:=SP[LOC]).BACKF; 00308800
IF N.DID=IMKS THEN SCRATCHAIN(N.SPF); 00308900
END; 00309000
WHILE ST GEQ L AND ERR=0 DO POP; 00309100
IF ERR NEQ 0 THEN GO TO DONE; 00309200
M:=BASE:=SP[MOC].SPF;%LOC OF LABEL TABLE 00309300
TRYNEXT: 00309400
N:=SP[MOC]+M+1; % N IS ONE BUIGGER THAN TOP 00309500
M:=M+2; M:=SP[MOC]+2; % M IS ON THE FIRST POINTER 00309600
IF LABELED THEN %BINARY SEARCH FOR THE DESIRED LINE 00309700
BEGIN 00309800
IF N-M LSS 2 THEN GO TO ENDFUNC; 00309900
WHILE N-M GTR 2 AND C LSS 1@8 DO 00310000
00310100
BEGIN L:=M+ENTIER((N-M)DIV 4)|2; C:=C+1; 00310200
IF T LSS SP[LOC] THEN N:=L ELSE M:=L 00310300
END; 00310400
IF C=1@8 THEN GO TO TERMINATE; 00310500
IF SP[MOC] NEQ T THEN GO ENDFUNC; T:=M; 00310600
%T HAS THE SP LOCATION OF THE CORRECT LABEL 00310700
END ELSE %BUMP THE POINTER 00310800
IF T:=CURLINE+2+BASE GEQ N OR T LSS M THEN GO ENDFUNC; 00310900
M:=T+1; CURLINE:=T-BASE; %M IS SET TO PROG DESC 00311000
IF NOT BOOLEAN((T:=SP[MOC]).PRESENCE) THEN %MAKE POLISH 00311100
BEGIN N:=BASE+1;N:=SP[NOC].SPF;%SEQ STORAGE UNIT 00311200
INITBUFF(BUFFER,BUFFSIZE); 00311300
N:=CONTENTS(N,T,BUFFER); %GET TEXT 00311400
RESCANLINE; WHILE LABELSCAN(GTA,0) DO; %CLEAR LABELS 00311500
IF BOOLEAN(EOB) THEN % AN EMPTY LINE--BUMP POINTER 00311600
BEGIN M:=BASE;LABELED:=FALSE;GO TO TRYNEXT;END ELSE 00311700
IF T:=ANALYZE(TRUE)=0 THEN % NO GOOD 00311800
GO TO DONE; 00311900
SP[MOC]:=T; %SAVE THE POLISH DESCRIPTOR AT M 00312000
END; 00312100
PUSH; IF ERR NEQ 0 THEN GO TO DONE; 00312200
AREG:=(L:=ENTIER(M))&1[CCIF]&TLAST[BACKPT]; 00312300
LASTMKS:=ST; 00312400
POLLOC:=SP[LOC].SPF; 00312500
L:=T.SPF; POLTOP:=SP[LOC]; CINDEX:=1; 00312600
GO TO DONE; 00312700
ENDFUNC: 00312800
%ARRIVE HERE WHEN FUNCTION IS COMPLETED. 00312900
%GET RESULT OF FUNCTION 00313000
M:=FUNCLOC;M:=SP[MOC].SPF+M;N:=TLAST:=SP[MOC].LOCFIELD; 00313100
M:=SP[NOC].SPF;M:=SP[MOC]; 00313200
COMMENT I CANNOT CONJURE UP A CASE WHERE A USER RETURNS TO A 00313300
FUNCTION WHOSE DESCRIPTOR HAS BEEN PUSHED DOWN BY A SUSPENDED 00313400
VARIABLE.IF THIS HAPPENS-HOPE FOR A GRACEFUL CRASH; 00313500
%M IS THE DESCRIPTOR FOR THE FUNCTION, TLAST IS BASE ADDRESS 00313600
00313700
IF BOOLEAN(M.RETURNVALUE) THEN %GET THE RESULT 00313800
BEGIN 00313900
N:=M.SPF+5;%RELATIVE LOCATION OF RESULT 00314000
N:=SP[NOC]+TLAST; %LOCATION IN STACK OF RESKLULT 00314100
T:=SP[NOC]; SP[NOC].NAMED:=1; N:=T; 00314200
END; 00314300
WHILE ST GEQ TLAST AND ERR=0 DO POP; %GET RID OF TEMPS 00314400
OLDDATA:=(T:=AREG).SPF; POP;% GET RID OF INTERRUPT MKS 00314500
IF ERR NEQ 0 THEN GO TO DONE; 00314600
IF BOOLEAN(M.RETURNVALUE) THEN %REPLACE RESULT 00314700
BEGIN PUSH; IF ERR NEQ 0 THEN GO TO DONE; 00314800
AREG:=N; %RESULT OF CALL 00314900
END; 00315000
L:=STACKBASE+1;L:=SP[LOC].SPF;M:=SP[LOC].SPF+L; 00315100
00315200
SP[MOC]:=0;SP[LOC].SPF:=(M:=M-1)-L; 00315300
COMMENT NOW INITIATE ANY OLD FUNCTIONS, AND GET POLISH 00315400
GOING; 00315500
LASTMKS:=N:=T.BACKF+STACKBASE; %LOCATION OF PROGRAM DESC. 00315600
T:=SP[NOC]; % PICK UP PROGRAM DESCRIPTOR 00315700
N:=T.SPF; %LOCATION OF POLISH DESCRIPTOR 00315800
POLLOC:=(N:=SP[NOC].SPF); 00315900
POLTOP:=SP[NOC]; 00316000
CINDEX:=T.CIF; 00316100
IF M NEQ L THEN % GET LAST FUNCTION STARTED 00316200
BEGIN N:=SP[MOC].LOCFIELD; 00316300
T:=SP[NOC]; 00316400
CURLINE:=T.CIF 00316500
END ELSE CURLINE:=0; 00316600
GO TO DONE; 00316700
TERMINATE: 00316800
ERR:=LABELERROR; 00316900
DONE: 00317000
END; 00317100
00317200
PROCEDURE FIXTAKEORDROP(LDESC,RDESC,OPT,MAP,SIZEMAP,SIZE); 00317300
VALUE LDESC,RDESC,OPT; REAL LDESC,RDESC; 00317400
INTEGER OPT, SIZE; ARRAY MAP, SIZEMAP[1]; 00317500
BEGIN INTEGER LRANK,LSIZE,L,M,RRANK,N,I,TOP,PUT; 00317600
DEFINE TAKE = OPT = 2#; 00317700
INTEGER LNUM, RNUM; LABEL QUIT; 00317800
IF LSIZE := FINDSIZE(LDESC) NEQ RRANK := RDESC.RF AND LSIZE NEQ 1 00317900
OR LRANK:=LDESC.RF GTR 1 AND LSIZE NEQ 1 00318000
OR L := LDESC.SPF=0 00318100
OR M := RDESC.SPF = 0 THEN BEGIN 00318200
ERR:=DOMAINERROR; GO TO QUIT; END; 00318300
L := L + LRANK; 00318400
00318500
SIZE := 1; 00318600
FOR I := 1 STEP 1 UNTIL RRANK DO BEGIN 00318700
RNUM:=SP[MOC]; 00318800
LNUM:=IF TAKE THEN SP[LOC] ELSE (PUT:=SP[LOC])-SIGN(PUT)|RNUM; 00318900
IF ABS(LNUM) GTR RNUM THEN BEGIN 00319000
ERR:=DOMAINERROR; GO TO QUIT; END; 00319100
IF LNUM = 0 THEN BEGIN 00319200
SIZE := 0; GO TO QUIT; END; 00319300
IF LNUM = 0 THEN BEGIN 00319400
SIZEMAP[1] := LNUM; 00319500
MAP[I] . SPF := 0; 00319600
MAP[I] . RF := 1; 00319700
END ELSE BEGIN 00319800
LNUM:=ABS(LNUM); 00319900
PUT := RNUM - LNUM +ORIGIN; 00320000
MAP[I].SPF := N := GETSPACE(LNUM+1); 00320100
SIZEMAP[I] := SP[NOC] := LNUM; 00320200
TOP := N + LNUM; 00320300
FOR N:=N+1 STEP 1 UNTIL TOP DO BEGIN 00320400
SP[NOC]:=PUT; PUT:=PUT+1; END; 00320500
MAP[I].RF := 1; 00320600
MAP[I] := - MAP[I]; 00320700
END; 00320800
IF LSIZE NEQ 1 THEN L:=L+1; 00320900
M:=M+1; 00321000
SIZE:=SIZE | LNUM; 00321100
END; 00321200
QUIT: END PROCEDURE FIXTAKEORDROP; 00321300
REAL PROCEDURE SUBSCRIPTS(DIRECTION,D,RANK); 00321400
VALUE DIRECTION,D,RANK; REAL D,RANK; INTEGER DIRECTION; 00321500
BEGIN COMMENT THIS PROCEDURE EVALUATES A SET OF SUBSCRIPTS 00321600
,POPS THEM OFF THE STACK, AND RESTURNS WITH A DESC. 00321700
FOR THE ITEM REFERENCED; 00321800
LABEL GOHOME,DONE; 00321900
INTEGER SIZE,I,L,M,N,VALUW; 00322000
INTEGER ADDRESS,NOTSCAL,DIM,LEVEL,TEMP,K,J; 00322100
REAL SUBDESC,T; 00322200
BOOLEAN DCHARS; 00322300
STREAM PROCEDURE TCHAR(A,B,C,D);VALUE B,D; 00322400
BEGIN SI:=A;SI:=SI+B;DI:=C;DI:=DI+D;DS:=CHR;END; 00322500
ARRAY MAP[1:RANK],SIZEMAP[1:RANK]; 00322600
ARRAY BLOCKSIZE[1:RANK],POINTER[0:RANK],PROGRESS[1:RANK]; 00322700
INTEGER PROCEDURE SUBINDEX(M,S,P);VALUE M,S,P;REAL M,S,P; 00322800
IF M LSS 0 THEN BEGIN M:=-M; 00322900
M:=P+M.SPF+M.RF-1;SUBINDEX:=SP[MOC]-ORIGIN;END 00323000
ELSE SUBINDEX:=(IF S=1 THEN M.SPF ELSE M.SPF+P-1); 00323100
COMMENT 00323200
MONITOR PRINT(I,L,M,N,VALUE,ADDRESS,T,ERR,MAP,SIZEMAP, 00323300
SIZE,D,RANK,DIRECTION); 00323400
DCHARS:=BOOLEAN(D.CHRMODE); 00323500
IF DIRECTION GTR 1 THEN % THIS IS A TAKE OR DROP 00323600
BEGIN 00323700
NOTSCAL:=1; 00323800
FIXTAKEORDROP(AREG,BREG,DIRECTION,MAP,SIZEMAP,SIZE); 00323900
IF ERR NEQ 0 THEN GO TO GOHOME; 00324000
IF SIZE=0 THEN BEGIN D.DID:=DDPUVW; D.RF:=1; 00324100
D.SPF:=0; SUBSCRIPTS:=D; GO TO GOHOME; END; 00324200
%IF SIZE=0 AND TAKE OR DROP, RESULT IS A NULL 00324300
END ELSE BEGIN 00324400
IF RANK NEQ D.RF THEN BEGIN ERR:=RANKERROR;GO TO GOHOME;END; 00324500
SIZE:=1; 00324600
N:=D.SPF-1; 00324700
L:=ST-1; % LOCATE THE EXECUTION STACK 00324800
FOR I:=1 STEP 1 UNTIL RANK DO 00324900
BEGIN 00325000
L:=L-1; SUBDESC:=SP[LOC]; % WANDER INTO EXEC STACK 00325100
IF ERR NEQ 0 THEN GO TO GOHOME; 00325200
N:=N+1; 00325300
IF BOOLEAN(SUBDESC.SCALAR) THEN 00325400
BEGIN M:=SUBDESC.SPF; 00325500
IF (VALUW:=SP[MOC]-ORIGIN) GEQ SP[NOC] 00325600
OR VALUW LSS 0 THEN BEGIN ERR:=INDEXERROR;GO TO 00325700
GOHOME; END; 00325800
MAP[I]:=VALUW; SIZEMAP[I]:=1; 00325900
END ELSE % CHECK FOR A NULL 00326000
IF SUBDESC.SPF=0 THEN % THIS IS A NULL 00326100
BEGIN 00326200
NOTSCAL:=1; 00326300
SIZE:=SIZE|(M:=SP[NOC]); 00326400
MAP[I].RF:=1;SIZEMAP[I]:=M; 00326500
END ELSE % IT MUST BE A VECTOR 00326600
BEGIN DEFINE STARTSEGMENT=#; %////////////////////////// 00326700
00326800
00326900
NOTSCAL:= 1; 00327000
MAP[I]:=-((M:=SUBDESC.SPF)&SUBDESC.RF[CRF]); 00327100
SIZE:=SIZE|(SIZEMAP[I]:=FINDSIZE(SUBDESC)); 00327200
J:=SP[NOC]+ORIGIN;M:=M+SUBDESC.RF;T:=SIZEMAP[I]+M 00327300
-1; 00327400
FOR M:=M STEP 1 UNTIL T DO 00327500
IF SP[MOC] GEQ J OR SP[MOC] LSS ORIGIN THEN 00327600
BEGIN ERR:=INDEXERROR; GO TO GOHOME; END; 00327700
END; 00327800
END; % OF THE FOR STATEMENT 00327900
END; 00328000
IF SIZE LEQ 0 THEN BEGIN ERR:=INDEXERROR;GO TO GOHOME;END; 00328100
IF SIZE=1 AND NOT BOOLEAN(NOTSCAL) THEN %SCALAR REFERENCED 00328200
BEGIN 00328300
DEFINE STARTSEGMENT=#; %//////////////////////////////// 00328400
N:=D.SPF; M:=RANK-1; 00328500
FOR I:=1 STEP 1 UNTIL M DO 00328600
BEGIN N:= N+1; 00328700
ADDRESS:=SP[NOC]|(ADDRESS+MAP[I]); 00328800
END; 00328900
ADDRESS:=ADDRESS+MAP[RANK] +1; 00329000
IF DIRECTION=OUTOF THEN 00329100
IF DCHARS THEN BEGIN 00329200
N:=(ADDRESS+7)DIV 8+N;J:=(ADDRESS-1)MOD 8; 00329300
T:=M:=GETSPACE(2);SP[MOC]:=1;M:=M+1; 00329400
SP[MOC]:=0; TCHAR(SP[NOC],J,SP[MOC],0); 00329500
SUBSCRIPTS:=T&1[CRF]&DDPUVC[CDID]; 00329600
END ELSE 00329700
BEGIN N:= ADDRESS+N; 00329800
M:=GETSPACE(1);SP[MOC]:=SP[NOC]; 00329900
T:=M; T.DID:=DDPUSW; 00330000
SUBSCRIPTS:=T; 00330100
END ELSE % DIRECTION IS INTO 00330200
BEGIN 00330300
L:=L-1;SUBSCRIPTS:=SUBDESC:=SP[LOC]; 00330400
IF DCHARS AND FINDSIZE(SUBDESC)=1 OR 00330500
BOOLEAN(SUBDESC.SCALAR) THEN 00330600
BEGIN 00330700
L:=GETSPACE(N:=(NUMELEMENTS(D)+D.RF)); 00330800
SPCOPY(D.SPF,L,N); % MAKE A NEW COPY 00330900
IF DCHARS THEN BEGIN 00331000
N:=(ADDRESS+7)DIV 8+L;J:=(ADDRESS-1)MOD 8; 00331100
M:=SUBDESC.SPF;IF SP[MOC] GTR 1 OR SUBDESC.RF 00331200
NEQ 1 THEN BEGIN ERR:=DOMAINERROR;GO TO 00331300
GOHOME;END; 00331400
M:=M+1;TCHAR(SP[MOC],0,SP[NOC],J); 00331500
END ELSE BEGIN 00331600
M:=L+ADDRESS+D.RF-1; 00331700
N:=SUBDESC.SPF; 00331800
SP[MOC]:=SP[NOC]; %PERFORM THE REPLACEMENT 00331900
END; 00332000
N:=D.LOCFIELD;I:=SP[NOC].BACKP; 00332100
SP[NOC]:=D&L[CSPF]&I[CLOCF];%STORE NEW DESC 00332200
OLDDATA:=CHAIN(D,OLDDATA); 00332300
IF BOOLEAN(D.NAMED) THEN BEGIN 00332400
N:=N-1;IF I=0 AND SP[NOC].SUSPENDVAR=0 00332500
THEN SP[NOC].CHANGE:=1%MUST BE A REAL GLOBAL 00332600
END ELSE %MUST BE A LOCAL VARIABLE 00332700
AREG.NAMED:=1; %DONT LET IT BE FORGOTTEN 00332800
END ELSE ERR:=RANKERROR; 00332900
END; 00333000
END ELSE % A VECTOR IS REFERENCED 00333100
BEGIN % START WITH INITIALIZATION 00333200
N:=D.SPF+D.RF;BLOCKSIZE[RANK]:=PROGRESS[RANK]:=J:=1; 00333300
FOR I:=RANK-1 STEP -1 UNTIL 1 DO 00333400
BEGIN N:=N-1; 00333500
J:=BLOCKSIZE[I]:=J|SP[NOC]; 00333600
PROGRESS[I]:=1; 00333700
END; 00333800
K:=POINTER[1]:=SUBINDEX(MAP[1],SIZEMAP[1],PROGRESS[1]) 00333900
|BLOCKSIZE[1]; 00334000
FOR I:=2 STEP 1 UNTIL RANK DO 00334100
K:=POINTER[I]:=K+SUBINDEX(MAP[I],SIZEMAP[I], 00334200
PROGRESS[I])|BLOCKSIZE[I]; 00334300
DIM:=0; 00334400
FOR I:=1 STEP 1 UNTIL RANK DO 00334500
IF SIZEMAP[I] GTR 1 THEN DIM:=DIM+MAP[I].RF; 00334600
IF DCHARS THEN BEGIN TEMP:=D; D.SPF:=UNPACK(D.SPF, 00334700
RANK,FINDSIZE(D)); IF DIM=0 THEN DIM:=1; END; 00334800
IF DIRECTION GTR 0 THEN % OUTOF..TAKE.. OR DROP 00334900
BEGIN DEFINE STARTSEGMENT=#; %////////////////////////// 00335000
IF SIZE+DIM GTR MAXWORDSTORE THEN BEGIN ERR:=KITEERROR; GO TO 00335100
GOHOME END ELSE TEMP:=L:=GETSPACE(SIZE+DIM); %RPOOM FOR RESULT 00335200
IF DIM GTR 0 THEN 00335300
IF DIM=1 THEN BEGIN SP[LOC]:=SIZE; L:=L+1;END 00335400
ELSE FOR I:=1 STEP 1 UNTIL RANK DO 00335500
IF SIZEMAP[I] GTR 1 THEN 00335600
IF (M:=MAP[I].SPF)=0 THEN BEGIN SP[LOC]:= 00335700
SIZEMAP[I];L:=L+1;END ELSE 00335800
BEGIN N:=M+MAP[I].RF-1; 00335900
00336000
FOR M:=M STEP 1 UNTIL N DO BEGIN 00336100
SP[LOC]:=SP[MOC];L:=L+1;END; 00336200
END; 00336300
COMMENT THIS INITIALIZES RESULT DIM VECTOR; 00336400
ADDRESS:= D.SPF+D.RF; 00336500
END ELSE % DIRECTION IS INTO 00336600
BEGIN DEFINE STARTSEGMENT=#; %///////////////// 00336700
L:=L-1; SUBSCRIPTS:=SUBDESC:=SP[LOC]; 00336800
IF FINDSIZE(SUBDESC) NEQ SIZE THEN 00336900
BEGIN ERR:=RANKERROR; GO TO GOHOME;END; 00337000
N:=SUBDESC.RF; 00337100
IF BOOLEAN(SUBDESC.CHRMODE) THEN SUBDESC.SPF:= 00337200
UNPACK(SUBDESC.SPF,N,FINDSIZE(SUBDESC)); 00337300
IF DCHARS THEN L:= D.SPF ELSE BEGIN 00337400
L:=GETSPACE(N:=(NUMELEMENTS(D)+D.RF)); 00337500
SPCOPY(D.SPF,L,N); % MAKE FRESH COPY TO PATCH INTO 00337600
END; 00337700
ADDRESS:=L+D.RF; % SP LOCATION TO STORE INTO 00337800
N:=D.LOCFIELD;I:=SP[NOC].BACKP; 00337900
SP[NOC]:=D&L[CSPF]&I[CLOCF];%STORE NEW DESC. 00338000
OLDDATA:=CHAIN(IF DCHARS THEN TEMP ELSE D,OLDDATA); 00338100
IF BOOLEAN(D.NAMED ) THEN BEGIN 00338200
N:=N-1;IF I=0 AND SP[NOC].SUSPENDVAR=0 00338300
THEN SP[NOC].CHANGE:=1%MUST BE A REAL GLOCAL 00338400
END ELSE %IT MUST BE A LOCAL VARIABLE 00338500
AREG.NAMED:=1;%DONT LET IT BE FORGOTTEN ON POP 00338600
L:=SUBDESC.SPF+SUBDESC.RF;%POINT TO SOURCE 00338700
END; 00338800
00338900
00339000
WHILE TRUE DO % RECURSIVE EVALUATION LOOP 00339100
BEGIN N:=POINTER[RANK]+ADDRESS; 00339200
LEVEL:=RANK; 00339300
IF DIRECTION GTR 0 THEN %OUTOF..TAKE..DROP 00339400
BEGIN SP[LOC]:=SP[NOC]; L:=L+1; 00339500
END ELSE BEGIN % INTO 00339600
SP[NOC]:= SP[LOC];L:=L+1; END; 00339700
WHILE PROGRESS[LEVEL]GEQ SIZEMAP[LEVEL] DO 00339800
BEGIN PROGRESS[LEVEL]:=1 ; %LOOK FOR MORE WORK 00339900
IF LEVEL:=LEVEL-1 LEQ 0 THEN GO TO DONE; 00340000
END; 00340100
COMMENT THERE IS MORE ON THIS LEVEL; 00340200
PROGRESS[LEVEL]:=PROGRESS[LEVEL]+1; 00340300
K:=POINTER[LEVEL]:=POINTER[LEVEL-1] +SUBINDEX( 00340400
MAP[LEVEL],SIZEMAP[LEVEL],PROGRESS[LEVEL])| 00340500
BLOCKSIZE[LEVEL];%POINTER[0] IS 0 00340600
FOR I:=LEVEL+1 STEP 1 UNTIL RANK DO 00340700
K:=POINTER[I]:=K+SUBINDEX(MAP[I],SIZEMAP[I], 00340800
PROGRESS[I])|BLOCKSIZE[I]; 00340900
END; % OF RECURSIVE EVALUATION LOOP 00341000
DONE: IF DIRECTION GTR 0 THEN % OUTOF TAKE OR DROP 00341100
IF DCHARS THEN BEGIN PACK(TEMP,DIM,SIZE); 00341200
FORGETSPACE(D.SPF,RANK+FINDSIZE(D)); 00341300
SUBSCRIPTS:=TEMP&DIM[CRF]&DDPUVC[CDID]; 00341400
END ELSE % THIS IS A NUMERIC VECTOR 00341500
IF DIM=0 THEN SUBSCRIPTS:=TEMP&DDPUSW[CDID] ELSE 00341600
SUBSCRIPTS:=TEMP&DIM[CRF]&DDPUVW[CDID] 00341700
ELSE % THE DIRECTION IS INTO 00341800
BEGIN IF BOOLEAN(SUBDESC.CHRMODE) THEN 00341900
FORGETSPACE(SUBDESC.SPF,FINDSIZE(SUBDESC)+1); 00342000
IF DCHARS THEN PACK(D.SPF,RANK,FINDSIZE(D)); 00342100
END; 00342200
00342300
END; 00342400
GOHOME: IF DIRECTION GTR 1 THEN 00342500
FOR I:=1 STEP 1 UNTIL RANK DO 00342600
IF MAP[I] LSS 0 THEN FORGETSPACE(MAP[I].SPF,SIZEMAP[I]+1); 00342700
END; % OF SUBSCRIPTS PROCEDURE 00342800
PROCEDURE IMS(N); VALUE N; INTEGER N; 00342900
BEGIN COMMENT N=0 FOR REGULAR INTERRUPT MKS 00343000
N=1 FOR QQUAD INTERRUPT MKS 00343100
N=2 FOR QUAD INTERRUPT MKS 00343200
N=3 FOR EXECUTION LINE FOLLOWING 00343300
N=4 FOR SUSPENDED FUNCTION; 00343400
INTEGER L,M; 00343500
00343600
PUSH;AREG:=OLDDATA&(LASTMKS-STACKBASE) 00343700
[BACKPT]&N[QUADINV]&IMKS[CDID]; 00343800
IF N NEQ 4 THEN BEGIN L:=LASTMKS;SP[LOC].CIF:=CINDEX;END; 00343900
L:=STACKBASE+1;L:=SP[LOC].SPF +1; 00344000
IF (M:=SP[LOC].SPF) NEQ 0 THEN % SAVE CURLINE 00344100
BEGIN L:=L+M; L:=SP[LOC].LOCFIELD; 00344200
SP[LOC].CIF:=CURLINE; 00344300
END; 00344400
LASTMKS:=ST; 00344500
END; 00344600
PROCEDURE DISPLAYCHARV(D); VALUE D; REAL D; 00344700
BEGIN INTEGER I,J,K,L,M,NWORDS,NJ,T,NMAT,II,JJ,WDLINE,F,CC; 00344800
COMMENT WDLINE=#WORDS NEEDED TO FILL A TELETYPE LINE 00344900
NWORDS=#WORDS NEEDED TO GET F CHARACTERS FOR LAST 00345000
TELETYPE LINE OF A ROW 00345100
F=#CHARACTERS IN LAST TELETYPE LINE OF A ROW 00345200
T=#TELETYPE LINES NEEDED PER ROW BEYOND FIRST LINE 00345300
NMAT=#MATRICES TO BE PRINTED OUT (1 IF RANK=2); 00345400
L := (T:=D.SPF) + (NJ:=D.RF) - 1; 00345500
J := SP[LOC]; %J IS NUMBER OF CHARACTERS PER ROW 00345600
IF NJ GTR 1 THEN BEGIN 00345700
L:=L-1; K:=SP[LOC] 00345800
END ELSE K := 1; %K IS NUMBER OF ROWS PER MATRIX 00345900
00346000
L := T + NJ; 00346100
NMAT := FINDSIZE(D) DIV (J|K); 00346200
WDLINE := (LINESIZE+6) DIV 8 + 1; 00346300
IF II:=J-LINESIZE GTR 0 THEN BEGIN 00346400
T:= II DIV (I:=LINESIZE-2)+(IF II MOD I=0 THEN 0 ELSE 1); 00346500
NWORDS:=((F:=II-(T-1)|I)+6) DIV 8 + 1; 00346600
END ELSE BEGIN NWORDS:=((F:=J)+6)DIV 8 + 1; T:=0; END; 00346700
FOR II:=1 STEP 1 UNTIL NMAT DO BEGIN 00346800
FOR I:=1 STEP 1 UNTIL K DO BEGIN 00346900
CC:=0; 00347000
FOR JJ:=1 STEP 1 UNTIL T DO BEGIN 00347100
TRANSFERSP(OUTOF,SP,L+M DIV 8,BUFFER,0,WDLINE); 00347200
FORMROW(3,CC,BUFFER,ENTIER(M MOD 8),NJ:=LINESIZE-CC); 00347300
M := M + NJ; CC := 2; END; 00347400
IF I=K AND II=NMAT THEN IF L+M DIV 8 + NWORDS GTR 00347500
(1+NROWS)|SPRSIZE THEN NWORDS:=NWORDS-1; 00347600
%TO TAKE CARE OF BEING AT THE END OF SP 00347700
TRANSFERSP(OUTOF,SP,L+M DIV 8, BUFFER,0,NWORDS); 00347800
FORMROW(3,CC,BUFFER,ENTIER(M MOD 8), F); 00347900
M := M + F; 00348000
END; 00348100
FORMWD(3,"1 "); 00348200
END; 00348300
END OF CHARACTER DISPLAY PROCEDURE; 00348400
REAL PROCEDURE SEMICOL; 00348500
BEGIN COMMENT FORM CHAR STRING FROM TWO DESCRIPTORS; 00348600
INTEGER J,K,L; 00348700
REAL LD, RD; 00348800
STREAM PROCEDURE BLANKS(B,J,K);VALUE J,K; 00348900
BEGIN LOCAL T,U; 00349000
SI:=LOC K; DI:=LOC U; DI:=DI+1; DS:=7 CHR; 00349100
SI:=LOC J; DI:=LOC T; DI:=DI+1; DS:=7 CHR; 00349200
DI:=B; U(2(DI:=DI+32));; DI:= DI+K; 00349300
T(2(DS:=32 LIT " "));J(DS:=1 LIT " "); 00349400
END; 00349500
PROCEDURE MOVEC(J,L,K);VALUE J,L,K; INTEGER J,L,K; 00349600
BEGIN INTEGER I; 00349700
IF(J+K+8) GTR MAXBUFFSIZE|8 THEN ERR:=LENGTHERROR ELSE 00349800
BEGIN TRANSFERSP(OUTOF,SP,L,BUFFER,ENTIER((J+7)DIV 8), 00349900
ENTIER((K+7) DIV 8)); 00350000
IF I:=(J MOD 8) NEQ 0 THEN TRANSFER(BUFFER,J+8-I, 00350100
BUFFER,J,K); END; 00350200
END; 00350300
INTEGER PROCEDURE MOVEN(J,L,K);VALUE J,L,K;INTEGER J,L,K; 00350400
BEGIN INTEGER I;K:=K+L-1; I:=MAXBUFFSIZE|8; 00350500
BLANKS(BUFFER,I-J,J); 00350600
FOR L:= L STEP 1 UNTIL K DO 00350700
BEGIN NUMBERCON(SP[LOC],ACCUM); 00350800
TRANSFER(ACCUM,2,BUFFER,J:=J+1,ACOUNT); 00350900
IF (J:=J+ACOUNT)GTR I THEN BEGIN L:=K;ERR:=LENGTHERROR; 00351000
END;END; 00351100
MOVEN:=J; 00351200
END; 00351300
LD := AREG; RD := BREG; 00351400
IF L:=LD.RF GTR 1 THEN ERR:= RANKERROR ELSE 00351500
IF LD.SPF NEQ 0 THEN 00351600
IF BOOLEAN(LD.CHRMODE) THEN MOVEC(0,L+LD.SPF,J:=FINDSIZE 00351700
(LD))ELSE J:=MOVEN(0,L+LD.SPF,FINDSIZE(LD)); 00351800
IF L:=RD.RF GTR 1 OR ERR NEQ 0 THEN ERR:=RANKERROR ELSE 00351900
IF RD.SPF NEQ 0 THEN IF BOOLEAN(RD.CHRMODE) THEN 00352000
BEGIN MOVEC(J,L+RD.SPF,K:=FINDSIZE(RD));J:=J+K; 00352100
END ELSE J:=MOVEN(J,L+RD.SPF,FINDSIZE(RD)); 00352200
IF ERR=0 THEN 00352300
IF J=0 THEN SEMICOL:=NULLV ELSE 00352400
BEGIN L:=GETSPACE((K:=ENTIER((J+7)DIV 8))+1); 00352500
TRANSFERSP(INTO,SP,L+1,BUFFER,0,K); 00352600
SP[LOC]:=J; SEMICOL:=L&1[CRF]&DDPUVC[CDID]; 00352700
END; 00352800
00352900
END; 00353000
BOOLEAN PROCEDURE SETUPLINE; 00353100
BEGIN REAL T;INTEGER M; 00353200
IF T:=ANALYZE(FALSE) NEQ 0 THEN % WE HAVE A PROGRAM DESC 00353300
BEGIN IMS(3); 00353400
M:=GETSPACE(1); SP[MOC]:=T; 00353500
LASTMKS:=ST-STACKBASE; 00353600
PUSH; IF ERR=0 THEN 00353700
BEGIN AREG:=PROGMKS&LASTMKS[BACKPT]&1[CI]&M[SPTSP]; 00353800
POLLOC:=M:=T.SPF; POLTOP:=SP[MOC]; 00353900
LASTMKS:=LASTMKS+1+STACKBASE; CINDEX:=1; 00354000
END; 00354100
SETUPLINE:=TRUE; 00354200
END ELSE SETUPLINE:=FALSE; 00354300
END; 00354400
BOOLEAN PROCEDURE POPPROGRAM(OLDDATA,LASTMKS); 00354500
REAL OLDDATA,LASTMKS; 00354600
BEGIN LABEL EXIT;REAL L,M,N; 00354700
WHILE TRUE DO 00354800
BEGIN 00354900
WHILE(L:=AREG).DATADESC NEQ 0 AND ERR=0 DO POP; 00355000
IF L.DID=PROGMKS THEN 00355100
IF L=0 THEN %SOMETHING IS FUNNY...CONTINUE POPPING 00355200
POP 00355300
ELSE BEGIN 00355400
LASTMKS:=M:=L.BACKF+STACKBASE; 00355500
IF L.BACKF NEQ 0 AND NOT ((N:=SP[MOC]).DID=IMKS 00355600
AND N.QUADIN=4) THEN POPPROGRAM:=TRUE; 00355700
IF N.DID NEQ FMKS THEN 00355800
FORGETPROGRAM(L);POP;GO TO EXIT; 00355900
END ELSE %NOT A PROGRAM MKS 00356000
IF L.DID=FMKS THEN 00356100
BEGIN % MUST CUT BACK STATE VECTOR 00356200
M:=STACKBASE+1;M:=SP[MOC].SPF+1;N:=SP[MOC].SPF+M; 00356300
IF BOOLEAN(SP[NOC].SUSPENDED) THEN BEGIN SP[MOC].RF:=L:=00356400
SP[MOC].RF-1;IF L=0 THEN SUSPENSION:=0;END; 00356500
SP[NOC]:=0;SP[MOC].SPF:=N-M-1;POP; 00356600
END ELSE % NOT A FMKS EITHER 00356700
IF L.DID=IMKS THEN 00356800
BEGIN SCRATCHAIN(OLDDATA);OLDDATA:=L.SPF;POP;END; 00356900
IF ERR NEQ 0 THEN GO TO EXIT; 00357000
END; % OF THE DO 00357100
EXIT: END;%OF PROCEDURE POPPROGRAM 00357200
REAL PROCEDURE BUILDALPHA(LASTCONSTANT); 00357300
INTEGER LASTCONSTANT; 00357400
BEGIN 00357500
ARRAY B[0:BUFFSIZE]; 00357600
REAL R; 00357700
INTEGER L,N; 00357800
REAL STREAM PROCEDURE GETCHRS(ADDR,B); VALUE ADDR; 00357900
BEGIN LOCAL C1,C2,TDI,TSI,QM; 00358000
LOCAL ARROW; 00358100
LABEL L,DSONE,FINIS,ERR; 00358200
DI:=LOC QM; DS:=2RESET; DS:=2SET; 00358300
DI:=LOC ARROW; DS:=RESET; DS:=7SET; 00358400
DI:=B; DS:=8LIT"0"; 00358500
SI:=ADDR; 00358600
L: 00358700
IF SC=""" THEN % MAY BE DOUBLE QUOTE 00358800
BEGIN 00358900
SI:=SI+1; 00359000
IF SC=""" THEN % GET RID OF QUOTE 00359100
GO TO DSONE; 00359200
COMMENT ELSE WE ARE LOOKING PAST THE RH QUOTE; 00359300
GO TO FINIS; 00359400
END ELSE % LOOK FOR THE QUESTION MARK 00359500
BEGIN TDI:=DI; DI:=LOC QM; 00359600
IF SC=DC THEN % END OF BUFFER ENCOUNTERED 00359700
GO TO ERR; 00359800
SI:=SI-1; DI:=LOC ARROW; 00359900
IF SC=DC THEN %FOUND LEFT ARROW 00360000
GO TO ERR; 00360100
SI:=SI-1; DI:=TDI; GO TO DSONE 00360200
END; 00360300
DSONE: DS:=CHR; TALLY:=TALLY+1; 00360400
C2:=TALLY; TSI:=SI; SI:=LOC C2; SI:=SI+7; 00360500
IF SC="0" THEN 00360600
BEGIN TALLY:=C1; TALLY:=TALLY+1; C1:=TALLY; 00360700
TALLY:=0; 00360800
END; 00360900
SI:=TSI; 00361000
GO TO L; 00361100
FINIS: GETCHRS:=SI; 00361200
DI:=B; SI:=LOC C1; SI:=SI+1; DS:=7CHR; SI:=LOC C2; 00361300
SI:=SI+7; DS:=CHR; 00361400
ERR: 00361500
END; 00361600
IF R:=GETCHRS(ADDRESS,B) NEQ 0 THEN % GOT A VECTOR 00361700
IF NOT CURRENTMODE=FUNCMODE THEN 00361800
BEGIN ADDRESS:=R; 00361900
COMMENT B[0] HAS THE LENGTH OF THE STRING; 00362000
IF R:=B[0] GEQ 1 THEN COMMENT A VECTOR; 00362100
BEGIN 00362200
L:=GETSPACE(N:=(R-1)DIV 8+2); 00362300
TRANSFERSP(INTO,SP,L,B,0,N); 00362400
SP[LOC]:=R; 00362500
END; 00362600
N:=GETSPACE(1); 00362700
R:= L; 00362800
R.DID:=DDPNVC; 00362900
R.BACKP:=LASTCONSTANT; 00363000
LASTCONSTANT:=N; 00363100
IF B[0]=0 THEN R.DID:=DDPNVW %NULL BECAUSE .SPF=.RF=0 00363200
%DON"T WANT CHARACTER NULL TO LOOK LIKE CHARS 00363300
ELSE R.RF:=1; 00363400
SP[NOC]:=R; 00363500
COMMENT WE HAVE BUILT THE VECTOR AND DESCRIPTOR 00363600
BUILDALPHA:=N; 00363700
END 00363800
ELSE BEGIN BUILDALPHA:=1;ADDRESS:=R END; 00363900
%ELSE WE HAVE AN ERROR (MISSING " ETC.) 00364000
END; % OF THE BUILD ALPHA PROCEDURE; 00364100
PROCEDURE PACK(L,OFFSET,N); VALUE L,OFFSET,N; 00364200
INTEGER L,OFFSET,N; 00364300
BEGIN 00364400
LABEL QUIT; 00364500
INTEGER M,T,MB,S; 00364600
STREAM PROCEDURE PACKEM(A,B,N); VALUE N; 00364700
BEGIN LOCAL T; 00364800
SI:=LOC N; DI:=LOC T; DI:=DI+1; DS:=7CHR; 00364900
SI:=A; DI:=B; 00365000
T(2(32(SI:=SI+7; DS:=CHR))); N(SI:=SI+7; DS:=CHR); 00365100
END; 00365200
IF N = 0 THEN GO TO QUIT; 00365300
T:=(M:=L:=L+OFFSET)+N; 00365400
MB:=MAXBUFFSIZE DIV 8 | 8; 00365500
WHILE M LSS T DO 00365600
BEGIN 00365700
TRANSFERSP(OUTOF,SP,M,BUFFER,0,MB:=MIN(MB,T-M)); 00365800
PACKEM(BUFFER,ACCUM,MB); 00365900
TRANSFERSP(INTO,SP,L,ACCUM,0,S:=(MB+7)DIV 8); 00366000
L:=L+S; M:=M+MB; 00366100
END; 00366200
FORGETSPACE(L,T-L); 00366300
QUIT: END PROCEDURE PACK; 00366400
INTEGER PROCEDURE UNPACK(S,OFFSET,N); VALUE N,S,OFFSET; 00366500
INTEGER N,S,OFFSET; 00366600
BEGIN 00366700
INTEGER L,M,K,MB,T; 00366800
LABEL QUIT; 00366900
STREAM PROCEDURE UNPACKEM(A,B,N); VALUE N; 00367000
BEGIN 00367100
LOCAL T; 00367200
SI:=LOC N; DI:=LOC T; DI:=DI+1; DS:=7CHR; 00367300
SI:=A; DI:=B; 00367400
T(2(32(DS:=7LIT"0"; DS:=CHR))); 00367500
N(DS:=7LIT"0"; DS:=CHR); 00367600
END; 00367700
IF N = 0 THEN BEGIN UNPACK := S; GO TO QUIT; END; 00367800
UNPACK:=L:=GETSPACE(OFFSET+N); K:=S+OFFSET-1; 00367900
FOR M:=S STEP 1 UNTIL K DO; 00368000
BEGIN SP[LOC]:=SP[MOC]; L:=L+1 00368100
END; 00368200
K:=L+N; S:=S+OFFSET; 00368300
MB:=MAXBUFFSIZE DIV 8; 00368400
N := MB | 8; 00368500
WHILE L LSS K DO 00368600
BEGIN 00368700
TRANSFERSP(OUTOF,SP,S,BUFFER,0,M:=MIN(MB,(K-L+7)DIV 8)); 00368800
UNPACKEM(BUFFER,ACCUM, M:= MIN(K-L, M|8)); 00368900
TRANSFERSP(INTO,SP,L,ACCUM,0,M); 00369000
L := L+N; S:= S+MB; 00369100
END; 00369200
QUIT: END PROCEDURE UNPACK; 00369300
PROCEDURE TRANSPOSE; 00369400
BEGIN INTEGER M,N,L,I,ROW,COL,RANK,OUTER,INNER; REAL NEWDESC; 00369500
INTEGER SIZE,J,MAT,TOP,START; BOOLEAN CHARACTER; 00369600
LABEL QUIT; DEFINE GIVEUP=GO TO QUIT#; 00369700
REAL NULL, DESC; 00369800
DEFINE RESULT=RESULTD#; 00369900
NULL := AREG; DESC := BREG; 00370000
IF L:=DESC.SPF=0 THEN BEGIN ERR:=DOMAINERROR; GIVEUP; END; 00370100
RANK := DESC.RF; 00370200
SIZE := FINDSIZE(DESC); 00370300
IF RANK LSS 2 THEN BEGIN NEWDESC:=DESC; 00370400
%THEN THE TRANSPOSE IS THE THING ITSELF 00370500
NEWDESC.NAMED:=0; 00370600
NEWDESC.SPF := N:=GETSPACE(RANK+SIZE); 00370700
SPCOPY(L,N,RANK+SIZE); 00370800
GO TO QUIT; END; 00370900
IF DESC.ARRAYTYPE=1 THEN BEGIN 00371000
L:=UNPACK(L,RANK,SIZE); 00371100
CHARACTER := TRUE; END; 00371200
N:=L+RANK-1; COL := SP[NOC]; 00371300
N:=N-1; ROW := SP[NOC]; 00371400
TOP := SIZE DIV (MAT:=ROW|COL); 00371500
NEWDESC := DESC; 00371600
NEWDESC.SPF := M := GETSPACE(SIZE+RANK); 00371700
SPCOPY (L,M,RANK-2); 00371800
N:=M+RANK-1; SP[NOC]:=ROW; 00371900
N:=N-1; SP[NOC] := COL; 00372000
J:=0; M:=M+RANK; 00372100
WHILE J LSS TOP DO BEGIN 00372200
OUTER:=(START:=L+RANK+J|MAT) + COL - 1; 00372300
FOR I:=START STEP 1 UNTIL OUTER DO BEGIN INNER:=I+MAT-1; 00372400
FOR N:=I STEP COL UNTIL INNER DO 00372500
BEGIN SP[MOC] := SP[NOC]; M:=M+1; END; END; 00372600
J:=J+1; END; 00372700
QUIT: IF CHARACTER THEN BEGIN NEWDESC.ARRAYTYPE:=1; 00372800
FORGETSPACE(L,SIZE+RANK); 00372900
PACK(NEWDESC.SPF, RANK,SIZE); END; 00373000
RESULTD := NEWDESC; 00373100
END PROCEDURE TRANSPOSE; 00373200
BOOLEAN PROCEDURE MATCHDIM(DESC1,DESC2); REAL DESC1,DESC2; 00373300
BEGIN INTEGER I,L,M,TOP; LABEL DONE; 00373400
MATCHDIM:= TRUE; 00373500
IF DESC1.RF NEQ DESC2.RF THEN BEGIN MATCHDIM:=FALSE; 00373600
ERR:=RANKERROR; GO TO DONE; END; 00373700
I:=DESC1.SPF; M:=DESC2.SPF; TOP:=I+DESC1.RF-1; 00373800
FOR L:=I STEP 1 UNTIL TOP DO BEGIN 00373900
IF SP[LOC] NEQ SP[MOC] THEN BEGIN MATCHDIM:=FALSE; 00374000
ERR:=LENGTHERROR; GO TO DONE; END; 00374100
M:=M+1; END; 00374200
DONE: END PROCEDURE MATCHDIM; 00374300
INTEGER PROCEDURE RANDINT(A,B,U); VALUE A,B; 00374400
REAL A,B,U; 00374500
BEGIN DEFINE QQMODUL = 67108864#, QQMULT = 8189#, 00374600
QQRANDOM=(U:=U|QQMULT MOD QQMODUL)/QQMODUL#; 00374700
RANDINT := (B-A+1)|QQRANDOM+A-.5; 00374800
END PROCEDURE RANDINT; 00374900
BOOLEAN PROCEDURE BOOLTYPE(A,B); REAL A,B; 00375000
BEGIN IF ABS(A-1) LEQ FUZZ THEN A:=1; 00375100
IF ABS(A) LEQ FUZZ THEN A:=0; 00375200
IF ABS(B-1) LEQ FUZZ THEN B:=1; 00375300
IF ABS(B) LEQ FUZZ THEN B:=0; 00375400
BOOLTYPE := (IF A=1 OR A=0 AND B=1 OR B=0 THEN TRUE 00375500
ELSE FALSE); END PROCEDURE BOOLTYPE; 00375600
REAL PROCEDURE GAMMA(X); REAL X; 00375700
COMMENT THIS PROCEDURE WAS TAKEN FROM ACM ALGORITHM 31. 00375800
THE ONLY DIFFERENCE IS THAT THERE IS NO PROVISION FOR 00375900
X LEQ 0 SINCE IT WILL NOT BE CALLED IN THAT CASE. IT 00376000
IS SUPPOSED TO GIVE ACCURACY TO 7 DIGITS; 00376100
BEGIN REAL H,Y; LABEL A1, A2; 00376200
H := 1; Y := X; 00376300
A1: IF Y = 2 THEN GO TO A2 ELSE IF Y LSS 2 THEN BEGIN 00376400
H:=H/Y; Y:=Y+1; GO TO A1 END 00376500
ELSE IF Y GEQ 3 THEN BEGIN 00376600
Y:=Y-1; H:=H|Y; GO TO A1 END 00376700
ELSE BEGIN Y := Y - 2; 00376800
H := (((((((.0016063118 | Y + .0051589951) | Y 00376900
+ .0044511400) | Y + .0721101567) | Y 00377000
+ .0821117404) | Y + .4117741955) | Y 00377100
+ .4227874605) | Y + .9999999758) | H END; 00377200
A2: GAMMA := H; 00377300
END OF PROCEDURE GAMMA; 00377400
BOOLEAN PROCEDURE EXCLAM(MARG,NARG,M,ANS); VALUE MARG,NARG,M; 00377500
REAL MARG,NARG,ANS; INTEGER M; 00377600
BEGIN INTEGER N,I; REAL DENOM; LABEL PUT; 00377700
EXCLAM := TRUE; 00377800
IF I:=NARG.[1:8] NEQ 0 OR DENOM:=MARG.[1:8] NEQ 0 THEN BEGIN 00377900
IF MARG LSS 0 OR NARG LSS 0 THEN BEGIN EXCLAM:=FALSE; 00378000
GO TO PUT; END; 00378100
IF M=0 THEN ANS:=GAMMA(NARG) ELSE BEGIN 00378200
IF (NARG-MARG) LEQ 0 THEN BEGIN EXCLAM:=FALSE; GO TO PUT END; 00378300
ANS := 1; 00378400
IF I=0 THEN FOR I:=2 STEP 1 UNTIL NARG DO ANS:=ANS|I 00378500
ELSE ANS:=GAMMA(NARG); 00378600
IF DENOM=0 THEN BEGIN DENOM:=1; FOR I:=2 STEP 1 UNTIL MARG DO 00378700
DENOM:=DENOM|I END ELSE DENOM:=GAMMA(MARG); 00378800
ANS := ANS / (DENOM | GAMMA(NARG-MARG)); 00378900
END; 00379000
GO TO PUT; END; 00379100
IF M=0 THEN BEGIN ANS := 1; 00379200
FOR I:=1 STEP 1 UNTIL NARG DO ANS:=ANS|I; 00379300
GO TO PUT; END 00379400
ELSE BEGIN IF MARG GTR NARG THEN 00379500
BEGIN ANS:=0; GO TO PUT; END; 00379600
IF MARG=0 THEN BEGIN ANS:=1; GO TO PUT; END; 00379700
ANS := NARG - MARG + 1; 00379800
FOR I:=NARG-MARG+2 STEP 1 UNTIL NARG DO ANS:=ANS|I; 00379900
DENOM := 1; 00380000
FOR I:=2 STEP 1 UNTIL MARG DO DENOM:=DENOM|I; 00380100
ANS := ANS / DENOM; END; 00380200
PUT: END PROCEDURE EXCLAM; 00380300
BOOLEAN PROCEDURE OPERATION(LEFT,RIGHT,LPTR,OP,ANS); 00380400
COMMENT: OP DEFINES THE APL OPERATORS AS FOLLOWS: 00380500
OP APL OPERATOR OP APL OPERATOR 00380600
0 + 10 FACT-COMB 00380700
1 TIMES 11 LSS 00380800
2 - 12 = 00380900
3 DIV 13 GEQ 00381000
4 * 14 GTR 00381100
5 RNDM 15 NEQ 00381200
6 RESD-ABS 16 LEQ 00381300
7 MIN-FLR 17 AND 00381400
8 MAX-CEIL 18 OR 00381500
9 NOT 19 NAND 00381600
20 NOR 00381700
21 LN-LOG 00381800
THE "CIRCLE" OPERATORS FOLLOW. 00381900
22 PI | 30 SQRT(1-B*2) 00382000
23 ARCTANH 31 SIN 00382100
24 ARCCOSH 32 COS 00382200
25 ARCSINH 33 TAN 00382300
26 SQRT(B*2-1) 34 SQRT(1+B*2) 00382400
27 ARCTAN 35 SINH 00382500
28 ARCCOS 36 COSH 00382600
29 ARCSIN 37 TANH; 00382700
00382800
COMMENT: LPTR IS LSS 0 IF THE CALL COMES FROM A 00382900
REDUCTION TYPE PROCEDURE. 00383000
LPTR = 0 IF OPERATOR IS MONADIC. 00383100
LPTR GTR 0 IF OPERATOR IS DYADIC. 00383200
LPTR LSS 0 IF COMES FORM REDUCTION TYPE OPERATION; 00383300
VALUE LEFT,RIGHT,LPTR,OP; 00383400
REAL LEFT,RIGHT,LPTR,OP; 00383500
REAL ANS; 00383600
BEGIN LABEL PUT,DOMAIN,KITE; DEFINE GIVEUP=GO TO PUT#; 00383700
DEFINE MAXEXP=158.037557167#, 00383800
MINEXP=-103.7216898#; 00383900
MONITOR INTOVR, ZERO, EXPOVR; 00384000
OPERATION:=TRUE; 00384100
IF LPTR LSS 0 THEN IF OP GTR 10 AND OP LSS 21 THEN 00384200
IF NOT BOOLTYPE(LEFT,RIGHT) THEN GO TO DOMAIN; 00384300
IF OP = 45 THEN IF LPTR=0 THEN OP:=22 00384400
ELSE IF ABS(LEFT) GTR 7 THEN GO TO DOMAIN 00384500
ELSE OP := LEFT + 30; 00384600
IF OP GTR 16 AND OP LSS 21 THEN IF NOT BOOLTYPE(LEFT,RIGHT) 00384700
THEN GO TO DOMAIN; 00384800
ZERO:=DOMAIN; INTOVR:=KITE; EXPOVR:=KITE; 00384900
CASE OP OF BEGIN 00385000
ANS := LEFT + RIGHT; 00385100
ANS := IF LPTR=0 THEN SIGN(RIGHT) ELSE LEFT | RIGHT; 00385200
ANS := LEFT - RIGHT; 00385300
ANS := LEFT / RIGHT; 00385400
IF LPTR=0 THEN IF RIGHT GTR MINEXP AND RIGHT LSS MAXEXP 00385500
THEN ANS:=EXP(RIGHT) ELSE GO TO KITE 00385600
ELSE IF RIGHT.[3:6]=0 THEN ANS:=LEFT*ENTIER(RIGHT) 00385700
ELSE IF LEFT GTR 0 THEN IF ANS:=RIGHT|LN(LEFT) GTR MINEXP 00385800
AND ANS LSS MAXEXP THEN 00385900
ANS:=EXP(ANS) ELSE GO TO KITE 00386000
ELSE IF LEFT=0 AND RIGHT GTR 0 THEN ANS:=0 00386100
ELSE GO TO DOMAIN; 00386200
IF LPTR NEQ 0 THEN BEGIN ERR:=SYSTEMERROR; GIVEUP; END ELSE 00386300
IF RIGHT LSS ORIGIN THEN GO TO DOMAIN ELSE 00386400
ANS := RANDINT(ORIGIN,RIGHT,SEED); 00386500
IF LPTR=0 THEN ANS := ABS(RIGHT) ELSE 00386600
BEGIN IF LEFT=0 THEN IF RIGHT GEQ 0 THEN 00386700
ANS := RIGHT ELSE GO TO DOMAIN 00386800
ELSE IF (ANS:=RIGHT MOD LEFT) LSS 0 00386900
THEN ANS:=ANS + ABS(LEFT); END; 00387000
ANS := (IF LPTR=0 THEN ENTIER(RIGHT+FUZZ) 00387100
ELSE IF LEFT LEQ RIGHT THEN LEFT ELSE RIGHT); 00387200
ANS := (IF LPTR=0 THEN -ENTIER(-RIGHT+FUZZ) 00387300
ELSE IF LEFT GTR RIGHT THEN LEFT ELSE RIGHT); 00387400
IF LPTR NEQ 0 THEN BEGIN ERR:=SYNTAXERROR; GIVEUP; END 00387500
ELSE IF NOT BOOLTYPE(0,RIGHT) THEN 00387600
BEGIN ERR:=DOMAINERROR; GIVEUP; END 00387700
ELSE ANS := (IF RIGHT=1 THEN 0 ELSE 1); 00387800
IF NOT EXCLAM(LEFT,RIGHT,LPTR,ANS) THEN GO TO DOMAIN; 00387900
00388000
ANS := (IF RIGHT-LEFT GTR FUZZ|ABS(RIGHT) THEN 1 ELSE 0); 00388100
ANS:=(IF ABS(LEFT-RIGHT) LEQ FUZZ|ABS(RIGHT) THEN 1 ELSE 0); 00388200
ANS:=(IF RIGHT-LEFT LEQ FUZZ|ABS(RIGHT) THEN 1 ELSE 0); 00388300
ANS:=(IF LEFT-RIGHT GTR FUZZ|ABS(RIGHT) THEN 1 ELSE 0); 00388400
ANS:=(IF ABS(LEFT-RIGHT) GTR FUZZ|ABS(RIGHT) THEN 1 ELSE 0); 00388500
ANS:=(IF LEFT-RIGHT LEQ FUZZ|ABS(RIGHT) THEN 1 ELSE 0); 00388600
ANS := RIGHT | LEFT; %AND 00388700
ANS := IF RIGHT + LEFT = 0 THEN 0 ELSE 1; %OR 00388800
ANS := IF RIGHT | LEFT = 1 THEN 0 ELSE 1; %NAND 00388900
ANS := IF RIGHT + LEFT = 0 THEN 1 ELSE 0; %NOR 00389000
IF RIGHT LEQ 0 THEN GO TO DOMAIN ELSE IF LPTR=0 THEN 00389100
ANS:=LN(RIGHT) ELSE 00389200
IF LEFT LEQ 1 THEN GO TO DOMAIN ELSE 00389300
ANS := LN(RIGHT) / LN(LEFT); %LOGARITHMS 00389400
ANS := 3.1415926536 | RIGHT; 00389500
IF ABS(RIGHT) GEQ 1 THEN GO TO DOMAIN ELSE 00389600
ANS:= .5|LN((1+RIGHT)/(1-RIGHT)); %ARCTANH 00389700
00389800
IF RIGHT LSS 1 THEN GO TO DOMAIN ELSE 00389900
ANS:=LN(RIGHT+SQRT(RIGHT|RIGHT-1)); %ARCCOSH 00390000
ANS := LN(RIGHT + SQRT(RIGHT|RIGHT+1)); %ACRSINH 00390100
00390200
IF ABS(RIGHT) LSS 1 THEN GO TO DOMAIN ELSE 00390300
ANS:=SQRT(RIGHT|RIGHT-1); 00390400
ANS := ARCTAN(RIGHT); 00390500
IF ABS(RIGHT) GTR 1 THEN GO TO DOMAIN ELSE 00390600
IF RIGHT=0 THEN ANS:=1.5707963268 ELSE 00390700
ANS:=ARCTAN(SQRT(1-RIGHT*2)/RIGHT); %ARCCOS 00390800
IF ABS(RIGHT) GTR 1 THEN GO TO DOMAIN ELSE 00390900
ANS:=ARCTAN(RIGHT/ SQRT(1-RIGHT*2)); %ARCSIN 00391000
IF ABS(RIGHT) GTR 1 THEN GO TO DOMAIN ELSE 00391100
ANS := SQRT(1-RIGHT*2); 00391200
ANS := SIN(RIGHT); 00391300
ANS := COS(RIGHT); 00391400
ANS := SIN(RIGHT) / COS(RIGHT); %TAN 00391500
ANS := SQRT(1+RIGHT|RIGHT); 00391600
ANS := (EXP(RIGHT) - EXP(-RIGHT))/2; %SINH 00391700
ANS := (EXP(RIGHT) + EXP(-RIGHT))/2; %COSH 00391800
ANS := ((OP:=EXP(RIGHT))-(ANS:=EXP(-RIGHT)))/(OP+ANS); %TANH 00391900
END; 00392000
GO TO PUT; 00392100
KITE: ERR:=KITEERROR; GO TO PUT; 00392200
DOMAIN: ERR:=DOMAINERROR; 00392300
PUT: IF ERR NEQ 0 THEN OPERATION := FALSE; 00392400
END PROCEDURE OPERATION; 00392500
PROCEDURE ARITH(OP); VALUE OP; 00392600
INTEGER OP; 00392700
COMMENT: ARITH HANDLES ALL APL OPERATORS THAT EMPLOY THE 00392800
VECTOR-VECTOR, SCALAR-VECTOR, SCALAR-SCALAR, VECTOR-SCALAR 00392900
FEATURE. DESC1 AND DESC2 ARE THE DESCRIPTORS FOR THE 00393000
LEFTHAND AND RIGHTHAND OPERANDS, RESPECTIVELY. IF 00393100
IF DESC1 = 0, THE OPERATOR IS TAKEN TO BE MONADIC. 00393200
IF DESC.SPF = 0, THE OPERAND IS NULL AND A DOMAIN ERROR 00393300
RESULTS EXCEPT IN THE CASE OF MULTIPLICATION. 00393400
OP IS AN INTERNAL OPERATION CODE FOR THE OPERATOR, WHICH 00393500
DEPENDS ON THE CASE STATEMENT IN THE OPERATION PROCEDURE.; 00393600
BEGIN INTEGER L,M,I,N,SIZE,RANK1,RANK2,TOP, 00393700
FORGETL, FORGETM; 00393800
REAL DESC,LEFT,RIGHT,ANS,SIZE1,SIZE2,DESC1,DESC2; 00393900
LABEL DONE, LEFTSCALE, SCALVECT, DOMAIN, VECTSCAL; 00394000
BOOLEAN CHAR1, CHAR2; 00394100
DESC1 := AREG; DESC2 := BREG; 00394200
L:=DESC1.SPF; M:=DESC2.SPF; 00394300
RANK1:=DESC1.RF; RANK2:=DESC2.RF; 00394400
SIZE1:=FINDSIZE(DESC1); SIZE2:=FINDSIZE(DESC2); 00394500
IF(CHAR1:=DESC1.ARRAYTYPE=1) OR (CHAR2:=DESC2.ARRAYTYPE=1) 00394600
THEN BEGIN IF OP LSS 11 OR OP GTR 16 00394700
OR NOT(CHAR1 AND CHAR2) AND NOT(OP=12 OR OP=15) 00394800
THEN BEGIN CHAR1:=CHAR2:=FALSE; GO TO DOMAIN; END; 00394900
IF CHAR1 THEN 00395000
FORGETL := L := UNPACK(L,RANK1,SIZE1); 00395100
IF CHAR2 THEN 00395200
FORGETM := M := UNPACK(M,RANK2,SIZE2); END; 00395300
00395400
00395500
IF M=0 THEN BEGIN IF OP NEQ 1 THEN GO TO DOMAIN 00395600
ELSE BEGIN DESC := NULLV; 00395700
GO TO DONE; END; END; 00395800
IF L=0 THEN BEGIN 00395900
IF DESC1.DID NEQ 0 THEN 00396000
IF OP=1 THEN BEGIN DESC:=NULLV; GO TO DONE; END 00396100
ELSE GO TO DOMAIN; 00396200
IF OP GTR 10 AND OP LSS 21 THEN GO TO DOMAIN; 00396300
LEFT := OP MOD 2; GO TO LEFTSCALE; END; 00396400
IF SIZE1=1 00396500
THEN BEGIN L:=L+RANK1; LEFT:=SP[LOC]; 00396600
GO TO LEFTSCALE; END; 00396700
IF SIZE2=1 THEN BEGIN 00396800
% DESC1 IS A VECTOR, DESC2 IS A SCALAR; 00396900
VECTSCAL: M:=M+RANK2; RIGHT:=SP[MOC]; 00397000
I := GETSPACE( SIZE:=SIZE1+RANK1); 00397100
DESC.SPF:=I; DESC.DID:=DDPUVW; SPCOPY(L,I,RANK1); 00397200
L:=L+RANK1; I:=I+RANK1; 00397300
DESC.RF:=RANK1; TOP:=SIZE1+I-1; 00397400
FOR N:=I STEP 1 UNTIL TOP DO BEGIN 00397500
IF OPERATION(SP[LOC],RIGHT,L,OP,ANS) THEN 00397600
SP[NOC] := ANS ELSE GO TO DONE; 00397700
L:=L+1; END; 00397800
GO TO DONE; END; 00397900
% BOTH DESC1 AND DESC2 ARE ARRAYS; 00398000
IF NOT MATCHDIM(DESC1,DESC2) THEN GO TO DONE 00398100
ELSE BEGIN 00398200
I := GETSPACE( SIZE := SIZE2 + RANK2 ); 00398300
SPCOPY(M,I,RANK2); DESC.SPF:=I; DESC.DID:=DDPUVW; 00398400
DESC.RF := RANK2; 00398500
M:=M+RANK2; I:=I+RANK2; L:=L+RANK2; 00398600
TOP := I+SIZE2-1; 00398700
FOR N:=I STEP 1 UNTIL TOP DO BEGIN 00398800
IF OPERATION(SP[LOC],SP[MOC],L,OP,ANS) THEN 00398900
SP[NOC] := ANS ELSE GO TO DONE; 00399000
L:=L+1; M:=M+1; END; 00399100
GO TO DONE; END; 00399200
LEFTSCALE: IF SIZE2 = 1 00399300
THEN BEGIN 00399400
IF RANK1 NEQ RANK2 THEN BEGIN 00399500
IF RANK1=0 THEN GO TO SCALVECT; 00399600
IF RANK2=0 THEN BEGIN L:=L-RANK1; GO TO VECTSCAL; END; 00399700
IF CHAR1 AND RANK1=1 THEN GO TO SCALVECT; 00399800
IF CHAR2 AND RANK2=1 THEN GO TO VECTSCAL; 00399900
ERR:=KITEERROR; GO TO DONE; END 00400000
ELSE IF RANK1|RANK2 NEQ 0 THEN GO TO SCALVECT; 00400100
% BOTH OPERANDS ARE SCALAR; 00400200
M := M + RANK2; 00400300
N := GETSPACE(SIZE:=1); RIGHT:=SP[MOC]; 00400400
DESC.SPF := N; DESC.DID := DDPUSW; 00400500
IF OPERATION(LEFT,RIGHT,L,OP,ANS) THEN 00400600
SP[NOC] := ANS ELSE GO TO DONE; 00400700
GO TO DONE; END 00400800
ELSE BEGIN %DESC1 IS SCALAR, DESC2 IS VECTOR; 00400900
00401000
SCALVECT: I := GETSPACE( SIZE := SIZE2 + RANK2); 00401100
DESC.SPF := I; DESC.RF := RANK2; DESC.DID:=DDPUVW; 00401200
SPCOPY(M,I,RANK2); 00401300
M:=M+RANK2; I:=I+RANK2; TOP:=SIZE2+I-1; 00401400
FOR N:=I STEP 1 UNTIL TOP DO BEGIN 00401500
IF OPERATION(LEFT,SP[MOC],L,OP,ANS) 00401600
THEN SP[NOC] := ANS ELSE GO TO DONE; 00401700
M := M+1; END; 00401800
END; 00401900
GO TO DONE; 00402000
DOMAIN: ERR:= DOMAINERROR; 00402100
DONE: RESULTD := DESC; 00402200
IF CHAR1 THEN FORGETSPACE(FORGETL,SIZE1+RANK1); 00402300
IF CHAR2 THEN FORGETSPACE(FORGETM,SIZE2+RANK2); 00402400
IF ERR NEQ 0 THEN FORGETSPACE(DESC.SPF, SIZE); 00402500
END PROCEDURE ARITH; 00402600
PROCEDURE DYADICRNDM; 00402700
BEGIN INTEGER NUM, KIND; REAL DESC; 00402800
REAL DESC1, DESC2; 00402900
INTEGER L,M,N,T,I,TEMP,OUTTOP,TOP,PICK; LABEL QUIT; 00403000
INTEGER START; LABEL INSERT; 00403100
DESC1 := AREG; DESC2 := BREG; 00403200
IF FINDSIZE(DESC1) NEQ 1 OR FINDSIZE(DESC2) NEQ 1 00403300
THEN BEGIN ERR:=RANKERROR; GO TO QUIT; END; 00403400
IF DESC1.SPF=0 OR DESC2.SPF=0 THEN BEGIN 00403500
ERR:=DOMAINERROR; GO TO QUIT; END; 00403600
L:=DESC1.SPF+DESC1.RF; M:=DESC2.SPF+DESC2.RF; 00403700
NUM := SP[LOC]; KIND := SP[MOC]; 00403800
IF KIND LSS ORIGIN 00403900
OR NUM GTR PICK := KIND-ORIGIN+1 00404000
OR DESC1.ARRAYTYPE=1 00404100
OR DESC2.ARRAYTYPE=1 THEN BEGIN ERR:=DOMAINERROR; 00404200
GO TO QUIT; END; 00404300
DESC.DID := DDPUVW; DESC.RF := 1; 00404400
IF NUM LEQ 0 THEN BEGIN DESC := NULLV; GO TO QUIT; END; 00404500
IF NUM GTR MAXWORDSTORE THEN BEGIN ERR:=KITEERROR; GO TO QUIT; END; 00404600
DESC.SPF := L := GETSPACE(NUM+1); 00404700
SP[LOC] := NUM; L := L+1; 00404800
OUTTOP := L+NUM-1; 00404900
TEMP := GETSPACE(NUM); 00405000
START:=ORIGIN; I:=0; 00405100
FOR L:=L STEP 1 UNTIL OUTTOP DO BEGIN 00405200
PICK:=RANDINT(START,KIND,SEED); 00405300
M:=TEMP; 00405400
IF I = 0 OR PICK LSS SP[MOC] THEN N:=TEMP 00405500
ELSE BEGIN TOP:=TEMP+I-1; 00405600
N:=TEMP+T:=I DIV 2; 00405700
WHILE T GTR 0 DO 00405800
IF PICK GEQ SP[NOC] THEN N:=N+T:=T DIV 2 00405900
ELSE N:=N-T:=T DIV 2; 00406000
00406100
FOR N:=MAX(TEMP,N-1) STEP 1 UNTIL TOP DO 00406200
IF SP[NOC] GTR PICK THEN 00406300
GO TO INSERT; 00406400
END; 00406500
INSERT: IF L LSS OUTTOP THEN BEGIN TOP:=N+1; N:=TEMP+I; 00406600
FOR M:=N STEP -1 UNTIL TOP DO BEGIN 00406700
N:=N-1; SP[MOC] := SP[NOC] - 1; END; 00406800
SP[NOC] := PICK; END; 00406900
SP[LOC] := N - TEMP + PICK; 00407000
KIND:=KIND-1; 00407100
I:=I+1; 00407200
END; 00407300
FORGETSPACE(TEMP,NUM); 00407400
QUIT: RESULTD := DESC; 00407500
END PROCEDURE DYADICRNDM; 00407600
PROCEDURE RHOP; 00407700
BEGIN INTEGER RANK,M,POINT; REAL NEWDESC,DESC1,DESC; 00407800
LABEL QUIT, WORK; BOOLEAN CHARACTER; 00407900
DEFINE TOOBIG=BEGIN ERR:=KITEERROR; GO TO QUIT; END#; 00408000
INTEGER N,TOP,NEWRANK,RANK1, POINT1,SIZE1,L,SIZE2; 00408100
DESC1 := AREG; DESC := BREG; 00408200
IF DESC.SPF = 0 THEN BEGIN ERR:=DOMAINERROR; GO TO QUIT; END; 00408300
IF DESC1.DID NEQ 0 THEN BEGIN %--DYADIC RHO--RESTRUCTURING--------- 00408400
IF L:=DESC1.SPF = 0 THEN BEGIN %NULL LEFT OP MEANS SCALAR ANS 00408500
IF DESC.ARRAYTYPE=1 THEN TOOBIG; %NO SCALAR CHARACTERS 00408600
NEWDESC.SPF:=M:=GETSPACE(1); 00408700
NEWDESC.DID:=DDPUSW; 00408800
L:=DESC.SPF+DESC.RF; 00408900
SP[MOC]:=SP[LOC]; GO TO QUIT; END; 00409000
IF DESC1.ARRAYTYPE NEQ 0 THEN BEGIN 00409100
ERR:=DOMAINERROR; GO TO QUIT; END; 00409200
RANK1:=DESC1.RF; 00409300
IF FINDSIZE(DESC1)=1 THEN BEGIN 00409400
N:=L+RANK1; 00409500
IF SIZE1:=ENTIER(SP[NOC]+.5) LSS 0 THEN BEGIN 00409600
ERR:=DOMAINERROR; GO TO QUIT; END; 00409700
NEWRANK:=1; TOP:=N; GO TO WORK; END; 00409800
IF RANK1 NEQ 1 THEN BEGIN ERR:=RANKERROR; GO TO QUIT; END; 00409900
IF NEWRANK:=SP[LOC] GTR 31 THEN TOOBIG; 00410000
SIZE1:=1; TOP := L+NEWRANK+RANK1-1; 00410100
IF NEWRANK LEQ 0 THEN BEGIN ERR:=SYSTEMERROR; GO TO QUIT; END; 00410200
FOR N:=L+RANK1 STEP 1 UNTIL TOP DO 00410300
IF SIZE1:=SIZE1|ENTIER(SP[NOC]+.5) LSS 0 THEN BEGIN 00410400
ERR:=DOMAINERROR; GO TO QUIT; END; 00410500
WORK: IF SIZE1=0 THEN BEGIN NEWDESC := NULLV; GO TO QUIT END; 00410600
IF SIZE1 GTR MAXWORDSTORE THEN TOOBIG; 00410700
NEWDESC.DID:=DDPUVW; NEWDESC.RF:=NEWRANK; 00410800
NEWDESC.SPF := M := GETSPACE(SIZE1+NEWRANK); 00410900
%CANT USE SPCOPY FOR DIM VECTOR AS LEFT OP MAY NOT BE INTEGER 00411000
FOR L:=L+RANK1 STEP 1 UNTIL TOP DO; 00411100
BEGIN SP[MOC]:=ENTIER(SP[LOC]+.5); M:=M+1; END; 00411200
SIZE2:=FINDSIZE(DESC); L:=DESC.SPF; RANK:=DESC.RF; 00411300
IF DESC.ARRAYTYPE=1 THEN BEGIN L:=UNPACK(L,RANK,SIZE2); 00411400
CHARACTER:=TRUE; END; TOP:=SIZE1 DIV SIZE2; POINT:=L+RANK; 00411500
FOR N:=1 STEP 1 UNTIL TOP DO BEGIN SPCOPY(POINT,M,SIZE2); 00411600
M := M+SIZE2; END; 00411700
TOP := SIZE1 MOD SIZE2; SPCOPY(POINT,M,TOP); 00411800
GO TO QUIT; END ELSE 00411900
%--------MONADIC RHO-----DIMENSION VECTOR---------------------- 00412000
RANK := DESC.RF; POINT := DESC.SPF; 00412100
NEWDESC.DID := DDPUVW; NEWDESC.RF := 1; 00412200
IF DESC.DATATYPE = 1 THEN BEGIN 00412300
NEWDESC := NULLV; GO TO QUIT END; 00412400
NEWDESC.SPF := M := GETSPACE(RANK+1); 00412500
SP[MOC] := RANK; 00412600
SPCOPY(POINT,M+1, RANK); 00412700
QUIT: IF CHARACTER THEN BEGIN NEWDESC.ARRAYTYPE:=1; 00412800
FORGETSPACE(L,SIZE2+RANK); 00412900
PACK(NEWDESC.SPF, NEWRANK,SIZE1); END; 00413000
RESULTD := NEWDESC; 00413100
END PROCEDURE RHOP; 00413200
PROCEDURE IOTAP; 00413300
BEGIN INTEGER I,L,M,TOP; REAL DESC; 00413400
REAL LEFTOP, RIGHTOP; 00413500
INTEGER RSIZE,LSIZE,RRANK,LRANK,N,LL,MM,TIP,NIX; 00413600
00413700
LABEL QUIT, DONE; 00413800
LEFTOP:=AREG; RIGHTOP:=BREG; 00413900
IF L:=RIGHTOP.SPF=0 THEN BEGIN ERR:=DOMAINERROR; GO TO QUIT END; 00414000
RSIZE:=FINDSIZE(RIGHTOP); RRANK:=RIGHTOP.RF; 00414100
DESC.DID := DDPUVW; DESC.RF := 1; 00414200
IF LEFTOP.DID NEQ 0 THEN BEGIN %-------DYADIC IOTA------------ 00414300
IF LRANK := LEFTOP.RF GTR 1 THEN BEGIN ERR:=RANKERROR; 00414400
GO TO QUIT; END; 00414500
LSIZE := FINDSIZE(LEFTOP); 00414600
IF M:=LEFTOP.SPF=0 THEN BEGIN %RESULT IS ORIGIN IF IT WAS NULL 00414700
DESC.SPF:=M:=GETSPACE(1); DESC.RF:=0; DESC.SCALAR:=1; 00414800
SP[MOC] := ORIGIN; GO TO QUIT; END; 00414900
IF LEFTOP.ARRAYTYPE=1 THEN M:=UNPACK(M,LRANK,LSIZE); 00415000
IF RIGHTOP.ARRAYTYPE=1 THEN L:=UNPACK(L,RRANK,RSIZE); 00415100
TIP := (NIX:=LSIZE+ORIGIN) - 1; 00415200
DESC.SPF:=N:=GETSPACE(RSIZE+RRANK); 00415300
IF RRANK=0 THEN DESC.SCALAR:=1 ; DESC.RF:=RRANK; 00415400
SPCOPY(L,N,RRANK); 00415500
MM := M+LRANK; LL:=L:=L+RRANK; 00415600
TOP:=N+RRANK+RSIZE-1; 00415700
FOR N:=N+RRANK STEP 1 UNTIL TOP DO BEGIN 00415800
SP[NOC] := NIX; 00415900
M := MM; 00416000
FOR I:=ORIGIN STEP 1 UNTIL TIP DO 00416100
IF OPERATION(SP[MOC],SP[LOC],1,12,LEFTOP) AND LEFTOP=1 00416200
THEN BEGIN SP[NOC]:=I; GO TO DONE; 00416300
END ELSE M:=M+1; 00416400
DONE: L:=L+1; END; 00416500
IF LEFTOP.ARRAYTYPE=1 THEN FORGETSPACE(MM-LRANK,LRANK+LSIZE); 00416600
IF RIGHTOP.ARRAYTYPE=1 THEN FORGETSPACE(LL-RRANK,RRANK+RSIZE); 00416700
END ELSE BEGIN %-------------MONADIC IOTA------------------ 00416800
IF RIGHTOP.ARRAYTYPE=1 THEN 00416900
BEGIN ERR:=DOMAINERROR; GO TO QUIT 00417000
END; 00417100
IF RSIZE NEQ 1 THEN BEGIN ERR:=RANKERROR; GO TO QUIT END; 00417200
00417300
L := L + RRANK; 00417400
IF TOP:=SP[LOC] GTR MAXWORDSTORE THEN 00417500
BEGIN ERR:=KITEERROR; GO TO QUIT 00417600
END; 00417700
00417800
IF TOP LSS ORIGIN THEN BEGIN DESC:=NULLV; GO TO QUIT END; 00417900
DESC.SPF := M := GETSPACE(TOP+1); 00418000
SP[MOC] := TOP; M := M+1; 00418100
TOP := TOP + ORIGIN - 1; 00418200
FOR I := ORIGIN STEP 1 UNTIL TOP DO BEGIN 00418300
SP[MOC] := I; M := M+1; END; 00418400
END; 00418500
QUIT: RESULTD := DESC; 00418600
END PROCEDURE IOTAP; 00418700
PROCEDURE COMMAP; 00418800
BEGIN REAL LDESC, RDESC; 00418900
INTEGER L,M,N,LRANK,RRANK,LSIZE,RSIZE,SIZE; 00419000
REAL DESC; LABEL QUIT; BOOLEAN CHARACTER; 00419100
LDESC := AREG; RDESC := BREG; 00419200
RRANK := RDESC.RF; LRANK := LDESC.RF; 00419300
LSIZE := IF (L := LDESC.SPF) = 0 THEN 0 ELSE FINDSIZE(LDESC); 00419400
RSIZE := IF (M := RDESC.SPF) = 0 THEN 0 ELSE FINDSIZE(RDESC); 00419500
IF RDESC.ARRAYTYPE = 1 THEN BEGIN 00419600
M := UNPACK(M,RRANK,RSIZE); 00419700
CHARACTER := TRUE; END; 00419800
DESC.DID := DDPUVW; DESC.RF := 1; 00419900
IF LDESC.DID = 0 THEN BEGIN %-----MONADIC COMMA--RAVEL-------- 00420000
IF RSIZE=0 THEN BEGIN DESC:=NULLV; GO TO QUIT END; 00420100
DESC.SPF := L := GETSPACE(RSIZE+1); 00420200
SP[LOC] := RSIZE; 00420300
SPCOPY(M+RRANK, L+1, RSIZE); 00420400
N := L; SIZE := RSIZE; 00420500
GO TO QUIT; END 00420600
ELSE BEGIN 00420700
%HERE IS THE CODE FOR DYADIC COMMA, I.E. CATENATION 00420800
IF RRANK NEQ 1 AND RSIZE GTR 1 OR 00420900
LRANK NEQ 1 AND LSIZE GTR 1 THEN BEGIN 00421000
ERR:= RANKERROR; GO TO QUIT; END; 00421100
IF SIZE:=LSIZE+RSIZE GTR MAXWORDSTORE THEN BEGIN 00421200
ERR:=KITEERROR; GO TO QUIT; END; 00421300
COMMENT CANT MIX NUMBER AND CHARACTERS. HAVE TO JUGGLE 00421400
IF LEFT IS NUMBERS AND RIGHT IS CHARACTERS AS RIGHT 00421500
HAS ALREADY BEEN UNPACKED AND WE DONT WANT TO FORGET 00421600
LEFT AND DONT WANT TO PACK THE NON-RESULT; 00421700
IF CHARACTER THEN 00421800
IF LDESC.ARRAYTYPE=1 OR LSIZE=0 THEN L:=UNPACK(L,LRANK,LSIZE) 00421900
ELSE BEGIN SIZE:=0; LSIZE:=-LRANK; ERR:=DOMAINERROR; 00422000
GO TO QUIT END 00422100
ELSE IF LDESC.ARRAYTYPE=1 THEN 00422200
IF RSIZE NEQ 0 THEN 00422300
BEGIN ERR:=DOMAINERROR; GO TO QUIT END 00422400
ELSE BEGIN CHARACTER:=TRUE; 00422500
L:=UNPACK(L,LRANK,LSIZE); END; 00422600
IF SIZE=0 THEN BEGIN DESC:=NULLV; GO TO QUIT END; 00422700
DESC.SPF := N := GETSPACE(SIZE+1); 00422800
SP[NOC] := SIZE; 00422900
SPCOPY(L+LRANK, N+1, LSIZE); 00423000
SPCOPY(M+RRANK, N+LSIZE+1, RSIZE); 00423100
END; 00423200
QUIT: 00423300
IF CHARACTER THEN BEGIN DESC.ARRAYTYPE := 1; 00423400
PACK(N,1,SIZE); 00423500
FORGETSPACE(L,LSIZE+LRANK); 00423600
FORGETSPACE(M,RSIZE+RRANK); 00423700
END; 00423800
RESULTD := DESC; 00423900
END PROCEDURE COMMAP; 00424000
INTEGER STREAM PROCEDURE GETOP(A,N); VALUE N; 00424100
BEGIN SI := A; SI := SI + N; 00424200
DI := LOC GETOP; 00424300
DS := 7 LIT "0"; DS := CHR; 00424400
END PROCEDURE GETOP; 00424500
REAL PROCEDURE IDENTITY(OP); VALUE OP; INTEGER OP; 00424600
BEGIN 00424700
CASE OP OF BEGIN 00424800
IDENTITY := 0; %FOR + 00424900
IDENTITY := 1; %FOR | 00425000
IDENTITY := 0; %FOR - 00425100
IDENTITY := 1; %FOR DIV 00425200
IDENTITY := 1; %FOR * 00425300
; %NO REDUCTION ON RNDM 00425400
IDENTITY := 0; %FOR RESD 00425500
IDENTITY := BIGGEST; %FOR MIN 00425600
IDENTITY := -BIGGEST; %FOR MAX 00425700
; %NOT ISNT DYADIC 00425800
IDENTITY := 1; %FOR COMB 00425900
IDENTITY := 0; %FOR LSS 00426000
IDENTITY := 1; %FOR = 00426100
IDENTITY := 1; %FOR GEQ 00426200
IDENTITY := 0; %FOR GTR 00426300
IDENTITY := 0; %FOR NEQ 00426400
IDENTITY := 1; %FOR LEQ 00426500
IDENTITY := 1; %FOR AND 00426600
IDENTITY := 0; %FOR OR 00426700
END; END PROCEDURE IDENTITY; 00426800
INTEGER PROCEDURE GETT(ALONG,RANK); VALUE ALONG, RANK; 00426900
INTEGER ALONG, RANK; 00427000
GETT:= IF ALONG=1 THEN 0 ELSE 00427100
IF ALONG=RANK THEN 2 ELSE 00427200
IF ALONG=RANK-1 THEN 1 ELSE 0; 00427300
BOOLEAN PROCEDURE CHECKANDADD(SIZE,L,SUM); 00427400
VALUE SIZE,L; INTEGER SIZE,L,SUM; 00427500
BEGIN LABEL QUIT; INTEGER I,TOP,M,S,T; 00427600
CHECKANDADD:=TRUE; 00427700
SUM := 0; 00427800
TOP := SIZE DIV 2 | 2 - 1 + L; 00427900
FOR L:=L STEP 2 UNTIL TOP DO BEGIN M:=L+1; 00428000
IF NOT BOOLTYPE(S:=SP[LOC], T:=SP[MOC]) THEN BEGIN 00428100
CHECKANDADD:=FALSE; GO TO QUIT; END 00428200
ELSE SUM := SUM+S+T; END; 00428300
IF SIZE MOD 2 = 1 THEN BEGIN 00428400
IF NOT BOOLTYPE(T:=SP[LOC],0) THEN 00428500
CHECKANDADD := FALSE ELSE SUM := SUM+T; 00428600
END; 00428700
QUIT: END PROCEDURE CHECKANDADD; 00428800
PROCEDURE COMPRESS(LDESC, RDESC, DIM); VALUE LDESC,RDESC,DIM; 00428900
REAL LDESC, RDESC, DIM; 00429000
BEGIN INTEGER I,J,K,L,M,N,T,RANK,LSIZE,RSIZE,ALONG,TOP, 00429100
FACTOR,SUM,DIMMOD,SIZE,LEFT,RIGHT,S; 00429200
REAL DESC; BOOLEAN CHARACTER; 00429300
LABEL QUIT,RANKE,DOMAIN,IDENT; 00429400
DESC.DID := DDPUVW; 00429500
IF L := LDESC.SPF = 0 THEN GO TO DOMAIN; 00429600
IF M:=RDESC.SPF = 0 THEN BEGIN DESC:=NULLV; GO TO QUIT; END; 00429700
LSIZE := FINDSIZE(LDESC); RSIZE := FINDSIZE(RDESC); 00429800
IF RANK:=LDESC.RF NEQ 1 THEN IF LSIZE NEQ 1 00429900
THEN GO TO DOMAIN; 00430000
LEFT := L := L+RANK; 00430100
RANK := RDESC.RF; 00430200
IF N:=DIM.SPF=0 AND DIM.DID NEQ 0 OR DIM.ARRAYTYPE=1 00430300
OR LDESC.ARRAYTYPE=1 THEN GO TO DOMAIN; 00430400
IF J:=DIM.RF NEQ 0 THEN BEGIN 00430500
IF FINDSIZE(DIM)=1 THEN N:=N+J ELSE GO TO DOMAIN END; 00430600
IF ALONG:=(IF N=J THEN RANK ELSE SP[NOC]-ORIGIN+1) GTR RANK 00430700
OR ALONG LSS 1 AND RANK NEQ 0 00430800
THEN BEGIN ERR:=INDEXERROR; GO TO QUIT; END; 00430900
IF RANK = 0 THEN 00431000
IF LSIZE NEQ 1 THEN GO TO DOMAIN ELSE BEGIN 00431100
IF TOP:=SP[LOC]=0 THEN BEGIN DESC:=NULLV; GO TO QUIT; END; 00431200
IF TOP = 1 THEN BEGIN DESC.SPF := N := GETSPACE(2); 00431300
DESC.RF := SP[NOC] := 1; 00431400
N:=N+1; SP[NOC]:=SP[MOC]; GO TO QUIT; 00431500
END ELSE GO TO DOMAIN; END; 00431600
IF LSIZE = 1 THEN BEGIN 00431700
COMMENT IF LEFT ARG IS SCALAR, ANSWER IS NULL IF 0, 00431800
RIGHT ARG IF 1; 00431900
SUM:=SP[LOC]; 00432000
IF SUM NEQ 0 AND SUM NEQ 1 THEN GO TO DOMAIN 00432100
00432200
ELSE GO TO IDENT; END; 00432300
N := M+ALONG - 1; 00432400
IF LSIZE NEQ (T:=SP[NOC]) THEN BEGIN 00432500
ERR:=LENGTHERROR; GO TO QUIT; END; 00432600
IF NOT CHECKANDADD(LSIZE,LEFT,SUM) THEN GO TO DOMAIN; 00432700
IDENT: IF SUM=0 THEN BEGIN DESC:=NULLV; GO TO QUIT END; 00432800
IF SUM = LSIZE THEN BEGIN 00432900
IF RDESC.ARRAYTYPE=1 THEN BEGIN 00433000
RSIZE:=RSIZE DIV 8 + (IF RSIZE MOD 8 NEQ 0 THEN 1 ELSE 0); 00433100
DESC.CHRMODE:=1; END; 00433200
DESC.SPF:=N:=GETSPACE(TOP:=RSIZE+RANK); 00433300
DESC.RF := RANK; SPCOPY(M,N,TOP); GO TO QUIT; END; 00433400
SIZE := RSIZE DIV T | SUM; 00433500
DESC.RF:=RANK; 00433600
IF RDESC.ARRAYTYPE = 1 THEN BEGIN M:=UNPACK(M,RANK,RSIZE); 00433700
CHARACTER := TRUE; END; 00433800
RIGHT := M; 00433900
DESC.SPF := S := GETSPACE(SIZE+RANK); 00434000
N := S; 00434100
FOR I:=1 STEP 1 UNTIL RANK DO BEGIN 00434200
IF I=ALONG THEN SP[NOC]:=SUM ELSE SP[NOC]:=SP[MOC]; 00434300
N:=N+1; M:=M+1; END; 00434400
T := GETT(ALONG, RANK); 00434500
FACTOR := 1; TOP := RIGHT+ALONG; 00434600
FOR N:=RIGHT+RANK-1 STEP -1 UNTIL TOP DO FACTOR:= 00434700
FACTOR | SP[NOC]; 00434800
N:=RIGHT + RANK - 1; DIM := SP[NOC]; 00434900
N := N+1; M:=S+RANK; I:=0; 00435000
DIMMOD := DIM-1; 00435100
WHILE I LSS RSIZE DO BEGIN 00435200
CASE T OF BEGIN 00435300
L := I DIV FACTOR MOD LSIZE; 00435400
L := I DIV FACTOR MOD DIMMOD; 00435500
L := I MOD DIM; END; 00435600
L := L+LEFT; 00435700
IF SP[LOC] = 1 THEN FOR K:=1 STEP 1 UNTIL FACTOR DO BEGIN 00435800
SP[MOC]:=SP[NOC]; I:=I+1; M:=M+1; N:=N+1; 00435900
END ELSE BEGIN I:=I+FACTOR; N:=N+FACTOR; END; 00436000
END; 00436100
GO TO QUIT; 00436200
RANKE: ERR:=RANKERROR; GO TO QUIT; 00436300
DOMAIN: ERR:=DOMAINERROR; GO TO QUIT; 00436400
QUIT: IF CHARACTER THEN BEGIN PACK(S,RANK,SIZE); 00436500
DESC.ARRAYTYPE:=1; FORGETSPACE(RIGHT,RSIZE+RANK); END; 00436600
RESULTD := DESC; 00436700
POP; 00436800
END PROCEDURE COMPRESS; 00436900
PROCEDURE EXPAND(LDESC,RDESC,DIM); VALUE LDESC,RDESC,DIM; 00437000
REAL LDESC,RDESC, DIM; 00437100
BEGIN INTEGER I,J,K,L,M,N,S,T,RANK,LSIZE,RSIZE,SIZE, 00437200
ALONG,TOP,LADDR,MADDR,FACTOR, SUM; 00437300
REAL DESC, INSERT; 00437400
LABEL QUIT, DOMAIN; 00437500
BOOLEAN CHARACTER; 00437600
LSIZE:=FINDSIZE(LDESC); RSIZE:=FINDSIZE(RDESC); 00437700
RANK := RDESC.RF; 00437800
IF M:=RDESC.SPF=0 00437900
OR L:=LDESC.SPF=0 00438000
OR I:=LDESC.RF GTR 1 00438100
00438200
OR N:=DIM.SPF=0 AND DIM.DID NEQ 0 00438300
OR DIM.ARRAYTYPE=1 00438400
OR FINDSIZE(DIM ) NEQ 1 00438500
OR LDESC.ARRAYTYPE=1 00438600
THEN GO TO DOMAIN; 00438700
N:=N + (T:=DIM.RF); 00438800
IF ALONG :=(IF N=T THEN RANK ELSE SP[NOC]-ORIGIN+1) GTR RANK 00438900
OR ALONG LSS 1 AND RANK NEQ 0 00439000
THEN BEGIN ERR:=INDEXERROR; GO TO QUIT; END; 00439100
IF RANK=0 THEN DIM:=1 00439200
ELSE BEGIN N:=M+ALONG-1; DIM:=SP[NOC]; END; 00439300
IF SIZE:=RSIZE DIV DIM | LSIZE GTR MAXWORDSTORE 00439400
THEN BEGIN ERR:=KITEERROR; GO TO QUIT; END; 00439500
IF NOT CHECKANDADD(LSIZE,LADDR:=L+I, SUM) THEN GO TO DOMAIN; 00439600
IF SUM NEQ DIM THEN BEGIN ERR:=RANKERROR; GO TO QUIT; END; 00439700
IF RANK=0 THEN BEGIN 00439800
DIM:=SP[MOC]; DESC.SPF:=N:=GETSPACE(LSIZE+I); 00439900
DESC.RF:=I; DESC.DID:=(IF I=0 THEN DDPUSW ELSE DDPUVW); 00440000
SPCOPY(L,N,I); L:=L+I; N:=N+I; TOP:=L+LSIZE-1; 00440100
FOR L:=L STEP 1 UNTIL TOP DO BEGIN 00440200
IF SP[LOC]=1 THEN SP[NOC]:=DIM; 00440300
N:=N+1; END; 00440400
GO TO QUIT END; 00440500
IF RDESC.ARRAYTYPE=1 THEN BEGIN CHARACTER:=TRUE; 00440600
M:=UNPACK(M,RANK,RSIZE); 00440700
INSERT := " "; END; 00440800
FACTOR:=1; TOP:=M+ALONG; 00440900
FOR N:=M+RANK-1 STEP -1 UNTIL TOP DO FACTOR:=FACTOR|SP[NOC]; 00441000
T := GETT(ALONG, RANK); 00441100
J:=0; N:=(MADDR:=M) + RANK; 00441200
DESC.SPF:=M:=GETSPACE(SIZE+RANK); 00441300
I:=M+RANK; 00441400
WHILE J LSS SIZE DO BEGIN 00441500
CASE T OF BEGIN 00441600
S := J DIV FACTOR MOD LSIZE; 00441700
S:=J DIV FACTOR MOD LSIZE; 00441800
S:=J MOD LSIZE; END; 00441900
L:=S + LADDR; 00442000
IF SP[LOC]=1 THEN FOR K:=1 STEP 1 UNTIL FACTOR DO 00442100
BEGIN L:=J+I; SP[LOC] := SP[NOC]; 00442200
J:=J+1; N:=N+1; 00442300
END ELSE FOR K:=1 STEP 1 UNTIL FACTOR DO BEGIN 00442400
L:=J+I; SP[LOC]:=INSERT; J:=J+1; END; 00442500
END; 00442600
L := MADDR; 00442700
FOR I:=1 STEP 1 UNTIL RANK DO BEGIN 00442800
IF I = ALONG THEN SP[MOC]:=LSIZE ELSE SP[MOC]:=SP[LOC]; 00442900
M:=M+1; L:=L+1; END; 00443000
DESC.DID:=DDPUVW; DESC.RF:=RANK; 00443100
GO TO QUIT; 00443200
DOMAIN: ERR:=DOMAINERROR; 00443300
QUIT: IF CHARACTER THEN BEGIN DESC.ARRAYTYPE:=1; 00443400
FORGETSPACE(MADDR, RSIZE+RANK); 00443500
PACK(DESC.SPF,RANK,SIZE); END; 00443600
RESULTD:=DESC; 00443700
POP; 00443800
END PROCEDURE EXPAND; 00443900
PROCEDURE MEMBER; 00444000
BEGIN REAL LDESC, RDESC; 00444100
INTEGER L,M,N,I,S,T,LSIZE,RSIZE,LRANK,RRANK,TOP; 00444200
REAL DESC, TEMP, ANS; 00444300
LABEL QUIT; 00444400
LDESC := AREG; RDESC := BREG; 00444500
LSIZE:=FINDSIZE(LDESC); RSIZE:=FINDSIZE(RDESC); 00444600
LRANK:=LDESC.RF; RRANK:=RDESC.RF; 00444700
IF L:=LDESC.SPF=0 OR M:=RDESC.SPF=0 THEN BEGIN 00444800
ERR:=DOMAINERROR; GO TO QUIT END; 00444900
IF LDESC.ARRAYTYPE=1 THEN L:=UNPACK(L,LRANK,LSIZE); 00445000
IF RDESC.ARRAYTYPE=1 THEN M:=UNPACK(M,RRANK,RSIZE); 00445100
DESC:=LDESC; DESC.NAMED:=0; 00445200
DESC.ARRAYTYPE:=0; 00445300
DESC.SPF:=N:=GETSPACE(LSIZE+LRANK); 00445400
SPCOPY(L,N,LRANK); 00445500
N:=N+LRANK; L:=(T:=L)+LRANK; M:=(S:=M)+RRANK; 00445600
T:=M+RSIZE-1; TOP := L+LSIZE-1; 00445700
FOR L:=L STEP 1 UNTIL TOP DO BEGIN 00445800
TEMP:=SP[LOC]; M:=S; 00445900
WHILE M LEQ T DO 00446000
IF OPERATION(TEMP,SP[MOC],0,12,ANS) AND ANS=1 THEN BEGIN 00446100
SP[NOC]:=1; M:=M+T; END ELSE M:=M+1; 00446200
N:=N+1; END; 00446300
00446400
IF RDESC.ARRAYTYPE=1 THEN FORGETSPACE(S,RSIZE+RRANK); 00446500
IF LDESC.ARRAYTYPE=1 THEN FORGETSPACE(I,LSIZE+LRANK); 00446600
QUIT: RESULTD:=DESC; 00446700
END PROCEDURE MEMBER; 00446800
REAL PROCEDURE BASEVALUE; 00446900
BEGIN 00447000
COMMENT THIS RETURNS A DESCRIPTOR FOR A SCALAR RESULT; 00447100
LABEL OUTE,BAD; 00447200
REAL E,L,M,LEFT,RIGHT,T,LARG,RARG; 00447300
LARG := AREG; RARG := BREG; 00447400
IF M:=RARG.SPF=0 OR LARG.CHRMODE=1 OR RARG.CHRMODE=1 00447500
OR L:=LARG.SPF=0 AND LARG.DID NEQ 0 00447600
THEN GO TO BAD; 00447700
RIGHT:=SP[MOC]; 00447800
LEFT:=SP[LOC]; 00447900
IF FINDSIZE(LARG)=1 THEN % A 1 ELEMENT VECTOR 00448000
BEGIN 00448100
L:=L+LARG.RF; 00448200
LARG.SCALAR:=1; 00448300
LEFT:=SP[LOC]; 00448400
END; 00448500
IF FINDSIZE(RARG)=1 THEN % A ONE ELEMENT VECTOR 00448600
BEGIN 00448700
M:=M+RARG.RF; 00448800
RIGHT:=SP[MOC]; 00448900
RARG.SCALAR:=1; 00449000
END; 00449100
IF L=0 THEN 00449200
BEGIN % BASEVAL MONADIC 00449300
LEFT:=2; %IF MONADIC, ITS 2 BASVAL X 00449400
LARG.SCALAR:=1; 00449500
END; 00449600
IF BOOLEAN(LARG.SCALAR )THEN %SCALAR 00449700
IF BOOLEAN(RARG.SCALAR) THEN 00449800
BEGIN 00449900
T:=RIGHT; %SCALAR-SCALAR 00450000
GO OUTE; 00450100
END 00450200
ELSE 00450300
IF RARG.RF=1 THEN 00450400
BEGIN COMMENT SCALAR-VECTOR--LEFT IS VALUE OF SCALAR, RIGHT 00450500
IS # OF ELEMENTS; 00450600
IF LEFT=0 THEN GO OUTE 00450700
ELSE E:=1/LEFT; 00450800
FOR L :=M+RIGHT STEP -1 UNTIL M+1 DO 00450900
T:=T+SP[LOC]|(E:=E|LEFT); 00451000
GO OUTE; 00451100
END 00451200
ELSE BAD: ERR:=DOMAINERROR 00451300
ELSE 00451400
IF RARG.SCALAR=0 THEN 00451500
IF LARG.RF NEQ 1 OR RARG.RF NEQ 1 THEN 00451600
ERR:=DOMAINERROR 00451700
ELSE 00451800
BEGIN 00451900
GT2:=L; % SAVE FOR LATER TEST 00452000
GT1:=M+2; % WANT TO STOP 2 UP IN LOOP 00452100
L:=L+LEFT; % START AT OTHER END 00452200
E:=1; 00452300
M:=M+RIGHT; 00452400
T:=SP[MOC]; % INITIAL VALUE 00452500
FOR M:=M-1 STEP -1 UNTIL GT1 DO 00452600
BEGIN 00452700
IF L:=L-1 LSS GT2 THEN L:=GT2+LEFT; % START OVER 00452800
E:=E|SP[LOC]; 00452900
T:=T+SP[MOC]|E; 00453000
END; 00453100
OUTE: 00453200
L:=GETSPACE(1); 00453300
SP[LOC]:=T; 00453400
T:=0; 00453500
T.DID:=DDPUSW; % BUILD DESCRIPTOR 00453600
T.SPF:=L; 00453700
BASEVALUE:=T; 00453800
END 00453900
ELSE ERR := DOMAINERROR 00454000
END OF BASEVALUE; 00454100
REAL PROCEDURE REPRESENT; 00454200
BEGIN 00454300
COMMENT RETURNS DESCRIPTOR OF VECTOR IF LARG VECTOR AND RARG SCALAR;00454400
REAL L,M,LEFT,RIGHT,T,E,LARG,RARG; 00454500
LABEL AROUND; 00454600
LARG := AREG; RARG := BREG; 00454700
IF (RARG.SCALAR=1 OR FINDSIZE(RARG)=1 AND RARG.CHRMODE=0) 00454800
AND NOT(LARG.SCALAR=1 OR LARG.CHRMODE=1 OR LARG.RF NEQ 1) THEN 00454900
BEGIN 00455000
COMMENT VECTOR-SCALAR; 00455100
IF L:=LARG.SPF=0 OR M:=RARG.SPF=0 THEN GO AROUND; 00455200
IF RARG.SCALAR=0 THEN M:=M+RARG.RF; 00455300
RIGHT:=SP[MOC]; % VALUE OF SCALAR 00455400
LEFT:=SP[LOC]; % LENGTH OF VECTOR 00455500
E:=M:=GETSPACE(LEFT+1); % MAKE ROOM FOR ANSWER 00455600
SP[MOC]:=LEFT; % LENGTH OF ANSWER 00455700
M:=M+LEFT; 00455800
GT1:=L+2; 00455900
FOR L:=L+LEFT STEP -1 UNTIL GT1 DO 00456000
IF T:=SP[LOC] LEQ 0 THEN 00456100
IF T LSS 0 THEN ERR:= DOMAINERROR 00456200
ELSE 00456300
BEGIN 00456400
L:=GT1-1 ; % STOP THE LOOP 00456500
M:=M-1; 00456600
END 00456700
ELSE 00456800
BEGIN 00456900
SP[MOC]:= RIGHT MOD T; 00457000
RIGHT:=RIGHT DIV T; 00457100
M:=M-1; 00457200
IF RIGHT LSS FUZZ THEN L:=GT1-1; % STOP THE LOOP 00457300
END; 00457400
SP[MOC]:=RIGHT; % LEFTOVER GOES HERE 00457500
T.DID:=DDPUVW; 00457600
T.RF:=1; 00457700
T.SPF:=E; 00457800
REPRESENT:=T; 00457900
END 00458000
ELSE AROUND: ERR:=DOMAINERROR; 00458100
END OF REPRESENT; 00458200
PROCEDURE PERIOD(LDESC,RDESC,LOP,ROP); 00458300
VALUE LDESC,RDESC,LOP,ROP; REAL LDESC,RDESC; INTEGER LOP,ROP; 00458400
BEGIN INTEGER L,M,N,J,LRANK,RRANK,RANK,LSIZE,RSIZE,SIZE,LL,MM,I, 00458500
RROW,RCOL,LROW,LCOL,LJUMP,RJUMP,MSAVE,LSAVE,RSTART; 00458600
REAL DESC, TEMP; 00458700
BOOLEAN CHARACTER, FIRST,LSCALAR, RSCALAR; 00458800
LABEL QUIT, DOMAIN, FORGET, OUTERPROD; 00458900
IF L:=LDESC.SPF = 0 OR M:= RDESC.SPF=0 THEN GO TO DOMAIN; 00459000
LSIZE := FINDSIZE(LDESC); RSIZE:=FINDSIZE(RDESC); 00459100
LRANK:=LDESC.RF; RRANK := RDESC.RF; 00459200
IF LOP NEQ 45 THEN 00459300
IF LRANK GTR 2 AND LSIZE NEQ 1 OR RRANK GTR 2 AND RSIZE NEQ 1 THEN 00459400
BEGIN ERR:=KITEERROR; GO TO QUIT; END; 00459500
IF ROP:=GETOP(CORRESPONDENCE,ROP-1) = 9 THEN BEGIN 00459600
ERR:=SYNTAXERROR; GO TO QUIT; END; 00459700
IF LL:=LDESC.ARRAYTYPE=1 OR MM:=RDESC.ARRAYTYPE=1 THEN 00459800
IF LL | MM NEQ 1 THEN GO TO DOMAIN 00459900
ELSE BEGIN 00460000
00460100
IF ROP LSS 11 OR ROP GTR 16 THEN GO TO DOMAIN; 00460200
CHARACTER:=TRUE; 00460300
M:=UNPACK(M,RRANK,RSIZE); 00460400
L:=UNPACK(L,LRANK,LSIZE); END; 00460500
MSAVE := M; LSAVE:=L; IF ROP NEQ 45 THEN 00460600
IF LOP=45 THEN GO TO OUTERPROD ELSE 00460700
IF LOP:=GETOP(CORRESPONDENCE,LOP-1)=9 THEN 00460800
BEGIN ERR:=SYNTAXERROR; GO TO QUIT; END; 00460900
IF LRANK=2 THEN BEGIN 00461000
N:=L+LRANK-1; LCOL := SP[NOC]; 00461100
N:=N-1; LROW:=SP[NOC]; END; 00461200
IF LRANK=1 THEN BEGIN LROW:=1; LCOL:=SP[LOC]; END; 00461300
IF RRANK=2 THEN BEGIN 00461400
N :=M+RRANK-1; RCOL:=SP[NOC]; 00461500
N:=N-1; RROW:=SP[NOC]; END; 00461600
IF RRANK=1 THEN BEGIN RROW:=SP[MOC]; RCOL:=1; END; 00461700
IF LSIZE =1 OR RSIZE=1 THEN BEGIN 00461800
IF LSIZE = 1 AND RSIZE = 1 THEN LROW:=LCOL:=RROW:=RCOL:=1 00461900
ELSE IF LSIZE=1 THEN BEGIN LCOL:=RROW; LROW:=1; 00462000
L:=L+LRANK-1; LRANK:=1; 00462100
LSCALAR:=TRUE; END 00462200
ELSE BEGIN RROW := LCOL; RCOL := 1; 00462300
M:=M+RRANK-1; RRANK:=1; 00462400
RSCALAR:=TRUE; END; 00462500
END; 00462600
IF LCOL NEQ RROW 00462700
THEN BEGIN ERR:=RANKERROR; GO TO QUIT; END; 00462800
DESC.SPF:=N:=GETSPACE((RANK:=MAX(0,LRANK+RRANK-1))+ 00462900
SIZE:=LROW|RCOL); 00463000
SPCOPY(L,N,LRANK-1); 00463100
SPCOPY(M+1,N+LRANK-1,RRANK-1); 00463200
DESC.RF:=RANK; DESC.DID:=(IF RANK=0 THEN DDPUSW ELSE DDPUVW); 00463300
N:=N+RANK; 00463400
LL := L + LRANK - 1; 00463500
MM := M + RRANK - 1; 00463600
LJUMP := LCOL-1; RJUMP := IF RSCALAR THEN 0 ELSE (RROW-1) | RCOL; 00463700
FOR J:=1 STEP LCOL UNTIL LSIZE DO 00463800
FOR RSTART:=1 STEP 1 UNTIL RCOL DO BEGIN 00463900
FIRST:=TRUE; 00464000
M := MM + RSTART + RJUMP; RROW := LL + J; 00464100
FOR I:=LL + LJUMP + J STEP -1 UNTIL RROW DO BEGIN 00464200
IF LSCALAR THEN L:=LL+1 ELSE L:=I; 00464300
IF FIRST THEN BEGIN 00464400
IF NOT OPERATION(SP[LOC],SP[MOC],1,ROP,SP[NOC]) 00464500
THEN GO TO FORGET ELSE FIRST := FALSE; 00464600
END ELSE BEGIN 00464700
IF NOT OPERATION(SP[LOC],SP[MOC],1,ROP,TEMP) 00464800
THEN GO TO FORGET; 00464900
IF NOT OPERATION(TEMP,SP[NOC],-1,LOP,SP[NOC]) 00465000
THEN GO TO FORGET END; 00465100
IF NOT RSCALAR THEN M:=M-RCOL; END; 00465200
N := N+1; 00465300
END; 00465400
GO TO QUIT; 00465500
OUTERPROD: IF SIZE:=LSIZE|RSIZE GTR MAXWORDSTORE 00465600
OR RANK := LRANK+RRANK GTR 31 THEN BEGIN 00465700
ERR:=KITEERROR; GO TO QUIT; END; 00465800
DESC.SPF:=N:=GETSPACE(SIZE+RANK); 00465900
DESC.DID:=IF RANK=0 THEN DDPUSW ELSE DDPUVW; 00466000
DESC.RF:=RANK; 00466100
SPCOPY(L,N,LRANK); 00466200
SPCOPY(M,N+LRANK,RRANK); 00466300
N:=N+RANK; 00466400
I:=L + LRANK + LSIZE - 1; 00466500
MM := M+RRANK + RSIZE - 1; 00466600
FOR L:=L+LRANK STEP 1 UNTIL I DO 00466700
FOR M:=MSAVE+RRANK STEP 1 UNTIL MM DO 00466800
IF NOT OPERATION(SP[LOC],SP[MOC],1,ROP,SP[NOC]) THEN 00466900
GO TO FORGET ELSE N:=N+1; 00467000
GO TO QUIT; 00467100
FORGET: FORGETSPACE(DESC.SPF,RANK+SIZE); 00467200
DOMAIN: ERR:=DOMAINERROR; 00467300
QUIT: IF CHARACTER THEN BEGIN 00467400
FORGETSPACE(MSAVE , RRANK+RSIZE); 00467500
FORGETSPACE(LSAVE , LRANK+LSIZE); END; 00467600
RESULTD := DESC; 00467700
END PROCEDURE PERIOD; 00467800
PROCEDURE REVERSE(SOURCE,LENGTH,DEST,JUMP); VALUE SOURCE,DEST, 00467900
LENGTH,JUMP; INTEGER SOURCE,LENGTH,DEST,JUMP; 00468000
BEGIN INTEGER L,M,TOP; 00468100
M:=SOURCE + TOP:=(LENGTH-1) | JUMP; TOP:=DEST+TOP; 00468200
FOR L:=DEST STEP JUMP UNTIL TOP DO BEGIN 00468300
SP[LOC] := SP[MOC]; M:=M-JUMP; END; 00468400
END PROCEDURE REVERSE; 00468500
PROCEDURE ROTATE(SOURCE,LENGTH,DEST,JUMP,ROT); VALUE SOURCE, 00468600
LENGTH,DEST,JUMP,ROT; INTEGER SOURCE,LENGTH,DEST,JUMP,ROT; 00468700
BEGIN INTEGER L,M,TOP; 00468800
TOP := SOURCE + (LENGTH-1) | JUMP; 00468900
FOR L:=SOURCE STEP JUMP UNTIL TOP DO BEGIN 00469000
M:=DEST+(ROT MOD LENGTH)|JUMP; SP[MOC]:=SP[LOC]; 00469100
ROT := ROT + 1; END; 00469200
END PROCEDURE ROTATE; 00469300
INTEGER PROCEDURE GETNUM(TIM,L,SIZE,DIM); VALUE TIM,L, 00469400
SIZE,DIM; INTEGER TIM,L,SIZE,DIM; 00469500
BEGIN INTEGER NUM; 00469600
IF SIZE NEQ 0 THEN L := L + TIM; 00469700
NUM:=SIGN(NUM:=SP[LOC]) | ENTIER(ABS(NUM)) MOD DIM; 00469800
IF NUM LSS 0 THEN GETNUM := -NUM %FOR RIGHT ROTATION 00469900
ELSE GETNUM:=DIM-NUM; %FOR LEFT ROTATION 00470000
END PROCEDURE GETNUM; 00470100
BOOLEAN PROCEDURE MATCHROT(LDESC,RDESC,ALONG); VALUE LDESC, 00470200
RDESC,ALONG; INTEGER LDESC,RDESC,ALONG; 00470300
BEGIN INTEGER I,L,M,R; LABEL QUIT; 00470400
MATCHROT:=TRUE; L:=LDESC.SPF; M:=RDESC.SPF; 00470500
IF R:=LDESC.RF NEQ RDESC.RF-1 THEN BEGIN 00470600
MATCHROT:=FALSE; GO TO QUIT; END; 00470700
FOR I:=1 STEP 1 UNTIL R DO BEGIN IF I=ALONG THEN M:=M+1; 00470800
IF SP[LOC] NEQ SP[MOC] THEN BEGIN MATCHROT:=FALSE; 00470900
GO TO QUIT; END; M:=M+1; L:=L+1; END; 00471000
QUIT: END PROCEDURE MATCHROT; 00471100
PROCEDURE REDUCESORTSCAN(LOP,RDESC,DIM,KIND); VALUE LOP,RDESC, 00471200
DIM,KIND; REAL LOP,RDESC,DIM; INTEGER KIND; 00471300
BEGIN INTEGER L,M,N,I,J,K,ALONG,FACTOR,T,MSAVE,DIFF,SSIZE, 00471400
JUMP,RANK,SIZE,TOP,LASTDIM,INTERVAL,TEMP,HOP; 00471500
INTEGER REMDIM,LRANK,LSAVE,LSIZE,S; 00471600
BOOLEAN CHARACTER,REDUCE,SORT,SCAN,REVERSAL,ROTATION; 00471700
REAL DESC; 00471800
LABEL QUIT, FORGET, RANKERR; 00471900
COMMENT: KIND=1 FOR REDUCTION 00472000
KIND=2 FOR SORTUP OR SORTDN 00472100
KIND=3 FOR SCAN 00472200
KIND=4 FOR REVERSAL 00472300
KIND=5 FOR ROTATION; 00472400
PROCEDURE SORTIT(L,M,SIZE,JUMP,UP); VALUE L,M,SIZE,JUMP,UP; 00472500
INTEGER L,M,SIZE,JUMP; BOOLEAN UP; 00472600
BEGIN INTEGER N,TIP,TOP,LSAVE; 00472700
REAL COMPARE,OUTOFIT; 00472800
OUTOFIT:=IF UP THEN BIGGEST ELSE -BIGGEST; 00472900
TIP := M + (N:=(SIZE-1) | JUMP); TOP := L + N; 00473000
LSAVE := L; 00473100
FOR M:=M STEP JUMP UNTIL TIP DO BEGIN 00473200
L := LSAVE; COMPARE := SP[LOC]; N:=L; 00473300
FOR L:=L+1 STEP 1 UNTIL TOP DO 00473400
IF UP THEN BEGIN IF SP[LOC] LSS COMPARE THEN BEGIN 00473500
N:=L; COMPARE:=SP[LOC]; END; 00473600
END ELSE IF SP[LOC] GTR COMPARE THEN BEGIN 00473700
N:=L; COMPARE:=SP[LOC]; END; 00473800
SP[NOC] := OUTOFIT; 00473900
SP[MOC] := (N-LSAVE) + ORIGIN; 00474000
END; 00474100
END PROCEDURE SORTIT; 00474200
CASE KIND OF BEGIN ; REDUCE:=TRUE; SORT:=TRUE; SCAN:=TRUE; 00474300
REVERSAL:=TRUE; ROTATION:=TRUE; END; 00474400
IF LOP GTR 64 AND NOT ROTATION THEN BEGIN 00474500
ERR:=SYSTEMERROR; GO TO QUIT; END; 00474600
IF REDUCE OR SCAN THEN IF LOP NEQ 45 THEN 00474700
LOP := GETOP(CORRESPONDENCE,LOP-1); 00474800
IF M:=RDESC.SPF=0 AND NOT REDUCE 00474900
OR DIM.DID NEQ 0 AND N:=DIM.SPF=0 OR DIM.ARRAYTYPE=1 00475000
OR FINDSIZE(DIM) NEQ 1 THEN BEGIN 00475100
ERR:=DOMAINERROR; GO TO QUIT END; 00475200
IF (REDUCE OR SCAN) AND LOP=9 THEN BEGIN %OP NOT DYADIC SCALAR 00475300
ERR:=SYNTAXERROR; GO TO QUIT END; 00475400
IF M=0 THEN BEGIN 00475500
%FOR REDUCTION, RESULT OF A NULL IS CORRESPONDING IDENTITY 00475600
%EXCEPT THAT NAND, NOR, CIRCLE, AND LOG (LOP GTR 18) 00475700
%HAVE NO IDENTITIES, SO THE RESULT IS A NULL 00475800
DESC.DID := DDPUSW; 00475900
IF LOP LEQ 18 THEN BEGIN DESC.SPF:=N:=GETSPACE(1); 00476000
SP[NOC] := IDENTITY(LOP); END ELSE DESC.RF:=1; 00476100
GO TO QUIT; END; 00476200
IF RDESC.ARRAYTYPE=1 AND (REDUCE OR SCAN) THEN 00476300
BEGIN ERR:=DOMAINERROR; GO TO QUIT; END; 00476400
SIZE:=FINDSIZE(RDESC); 00476500
RANK:=RDESC.RF; 00476600
IF SIZE=1 THEN BEGIN 00476700
%UNLESS SORT, RESULT OF SINGLE-VALUED ARGUMENT IS THAT ARGUMENT 00476800
DESC := RDESC; 00476900
DESC.SPF := N := GETSPACE(RANK+1); 00477000
SPCOPY(M,N,RANK);M:=M+RANK;N:=N+RANK; 00477100
IF SORT THEN BEGIN SP[NOC]:=ORIGIN; DESC.ARRAYTYPE:=0; 00477200
END ELSE SP[NOC]:=SP[MOC]; 00477300
GO TO QUIT; END; 00477400
00477500
IF RDESC.ARRAYTYPE=1 THEN BEGIN 00477600
CHARACTER := TRUE; 00477700
M:=UNPACK(M,RANK,SIZE); END; 00477800
MSAVE:=M; 00477900
N:=N+(T:=DIM.RF); 00478000
IF ALONG:=(IF N=T THEN RANK ELSE SP[NOC]-ORIGIN+1) GTR RANK 00478100
OR ALONG LSS 1 00478200
THEN BEGIN ERR:=INDEXERROR; GO TO QUIT; END; 00478300
IF ROTATION THEN BEGIN 00478400
IF LSAVE:=LOP.SPF=0 OR LOP.ARRAYTYPE=1 THEN 00478500
BEGIN ERR:=DOMAINERROR; GO TO QUIT; END; 00478600
IF LSIZE:=FINDSIZE(LOP) NEQ 1 THEN 00478700
IF NOT MATCHROT(LOP,RDESC,ALONG) THEN BEGIN 00478800
ERR:=RANKERROR; GO TO QUIT; END; 00478900
LSAVE := LSAVE + LRANK := LOP.RF; 00479000
IF LSIZE = 1 THEN LRANK := 0; END; 00479100
N:=M+ALONG-1; 00479200
DIM:=SP[NOC]; 00479300
JUMP:=1; I:=M+ALONG; 00479400
FOR L:=M+RANK-1 STEP -1 UNTIL I DO JUMP:=JUMP | SP[LOC]; 00479500
N:=M+RANK-1; LASTDIM:=SP[NOC]; 00479600
IF ALONG = RANK-1 THEN BEGIN N:=N-1; 00479700
FACTOR:=LASTDIM | SP[NOC]; END; 00479800
T := GETT(ALONG, RANK); 00479900
J := M + RANK; 00480000
REMDIM := 1; 00480100
HOP := (DIM-1) | JUMP; 00480200
DESC.DID := DDPUVW; 00480300
IF ALONG GTR 1 AND ALONG LSS RANK-1 THEN BEGIN TOP:=M+ALONG-2; 00480400
FOR L:=M STEP 1 UNTIL TOP DO REMDIM:=REMDIM|SP[LOC]; END; 00480500
IF REDUCE THEN BEGIN DESC.SPF:=N:=GETSPACE(SSIZE:=SSIZE DIV DIM 00480600
+ RANK - 1); 00480700
IF RANK=1 THEN DESC.SCALAR:=1 ELSE DESC.RF:=RANK-1; 00480800
FOR I:=1 STEP 1 UNTIL RANK DO BEGIN 00480900
IF I NEQ ALONG THEN BEGIN SP[NOC]:=SP[MOC]; N:=N+1; END; 00481000
M:=M+1; END; 00481100
JUMP := - JUMP; 00481200
END ELSE BEGIN DESC.SPF:=N:=GETSPACE(SSIZE:=SIZE+RANK); 00481300
INTERVAL := (DIFF := N-M) + HOP; 00481400
SPCOPY(M,N,RANK); DESC.RF:=RANK; END; 00481500
IF SORT THEN TEMP:=GETSPACE(DIM); 00481600
TOP := SIZE DIV (DIM | REMDIM) - 1; 00481700
FOR S:=1 STEP 1 UNTIL REMDIM DO BEGIN 00481800
FOR I:=0 STEP 1 UNTIL TOP DO BEGIN 00481900
CASE T OF BEGIN 00482000
L := I + J; 00482100
L:=I DIV LASTDIM|FACTOR + I MOD LASTDIM + J; 00482200
L:=I|LASTDIM + J; END; 00482300
IF REDUCE THEN BEGIN M:=I+N; L:=HOP + (K:=L); 00482400
SP[MOC] := SP[LOC]; 00482500
FOR L:=L+JUMP STEP JUMP UNTIL K DO 00482600
IF NOT OPERATION(SP[LOC],SP[MOC],-1,LOP,SP[MOC]) 00482700
THEN GO TO FORGET; 00482800
END ELSE 00482900
IF SORT THEN BEGIN K:=L+HOP; N:=TEMP; 00483000
FOR M:=L STEP JUMP UNTIL K DO BEGIN 00483100
SP[NOC] := SP[MOC]; N:=N+1; END; 00483200
IF LOP LSS 0 THEN SORTIT(TEMP,L+DIFF,DIM,JUMP,FALSE) 00483300
ELSE SORTIT(TEMP,L+DIFF,DIM,JUMP,TRUE); 00483400
END ELSE IF SCAN THEN BEGIN 00483500
K:=L+INTERVAL; N:=L+DIFF; SP[NOC] := SP[LOC]; 00483600
FOR N:=N+JUMP STEP JUMP UNTIL K DO BEGIN 00483700
M:=N-JUMP; L:=L+JUMP; 00483800
IF NOT OPERATION(SP[MOC],SP[LOC],-1,LOP,SP[NOC]) 00483900
THEN GO TO FORGET; END; 00484000
END ELSE IF REVERSAL THEN REVERSE(L,DIM,L+DIFF,JUMP) 00484100
ELSE IF ROTATION THEN ROTATE(L,DIM,L+DIFF,JUMP, 00484200
GETNUM(I,LSAVE,LRANK,DIM)); 00484300
END; 00484400
J := J + ABS(JUMP|DIM); 00484500
N := N + TOP + 1; 00484600
DIFF := DIFF + TOP + 1; 00484700
END; 00484800
GO TO QUIT; 00484900
RANKERR: ERR:=RANKERROR; FORGETSPACE(DESC.SPF,SSIZE);GO QUIT; 00485000
FORGET: ERR:=DOMAINERROR; FORGETSPACE(DESC.SPF, SSIZE); 00485100
QUIT: IF CHARACTER THEN BEGIN 00485200
FORGETSPACE(MSAVE,SIZE+RANK); 00485300
IF (REVERSAL OR ROTATION) AND ERR=0 THEN BEGIN 00485400
DESC.ARRAYTYPE:=1; PACK(DESC.SPF,RANK,SIZE); END; END; 00485500
IF SORT THEN FORGETSPACE(TEMP,DIM); 00485600
RESULTD := DESC; 00485700
IF ROTATION THEN POP; 00485800
END PROCEDURE REDUCESORTSCAN; 00485900
PROCEDURE DYADICTRANS; 00486000
BEGIN REAL LDESC,RDESC; 00486100
INTEGER L,M,N,RANK,NEWRANK,SIZE,TEMP,I,J; 00486200
DEFINE SPTOP=RDESC#,MIN=RDESC#,PTR=NEWRANK#,MBASE=LDESC#,TOP=RDESC# 00486300
,RESULT=RESULTD#; 00486400
LABEL QUIT; BOOLEAN CARRY; 00486500
INTEGER ARRAY RVEC,DEL,SUB,OLDEL[0:3]; 00486600
LDESC:=AREG; RDESC:=BREG; 00486700
RESULT:=0; L:=LDESC.SPF; J:=LDESC.RF; RANK:=RDESC.RF; 00486800
IF M:=RDESC.SPF=0 OR L=0 OR LDESC.ARRAYTYPE=1 THEN BEGIN 00486900
ERR:=DOMAINERROR; GO TO QUIT; END; 00487000
IF NUMELEMENTS(LDESC)=1 THEN BEGIN N:=L+J; 00487100
IF SP[NOC] NEQ ORIGIN OR RANK GTR 1 THEN BEGIN 00487200
ERR:=DOMAINERROR; GO TO QUIT END; 00487300
%IF WE GET HERE, THE ANSWER IS ITSELF 00487400
RESULT:=RDESC; I:=NUMELEMENTS(RDESC); 00487500
RESULT.SPF:=N:=GETSPACE(SIZE:=RANK+1); RESULT.NAMED:=0; 00487600
SPCOPY(M,N,SIZE); GO TO QUIT END; 00487700
IF J GTR 1 THEN BEGIN ERR:=RANKERROR; GO TO QUIT END; 00487800
IF SP[LOC] NEQ RANK THEN BEGIN ERR:=LENGTHERROR; GO TO QUIT END; 00487900
% FIND MAX OF LDESC FOR NOW- DO THE REST LATER 00488000
%LDESC W/R/T ORIGIN 0 GETS STORED IN SUB[I] 00488100
SPTOP:=L+RANK; NEWRANK:=0; I:=0; 00488200
FOR N:=L+1 STEP 1 UNTIL SPTOP DO BEGIN 00488300
IF TEMP:=SP[NOC]-ORIGIN+1 GTR NEWRANK THEN NEWRANK:=TEMP; 00488400
SUB[I]:=TEMP-1; I:=I+1 END; 00488500
IF NEWRANK GTR RANK THEN BEGIN ERR:=DOMAINERROR;GO TO QUIT END; 00488600
% CALCULATE THE OLD DEL VECTOR, OLDEL 00488700
OLDEL[RANK-1]:=1; N:=M+RANK-1; 00488800
FOR I:=RANK-2 STEP -1 UNTIL 0 DO BEGIN 00488900
OLDEL[I]:=OLDEL[I+1]|SP[NOC]; N:=N-1 END; 00489000
MBASE:=M; SIZE:=1; 00489100
%FIX UP THE NEW RVAC AND DEL 00489200
FOR I:=NEWRANK-1 STEP -1 UNTIL 0 DO BEGIN 00489300
% FIND SMALLEST EL. OF RHO RDESC [J] S.T. A[J]=I 00489400
% AND SUM OF OLDEL[J] S.T. A[J]=1 00489500
MIN:=31; TEMP:=0; 00489600
FOR J:=RANK-1 STEP -1 UNTIL 0 DO 00489700
IF SUB[J]=1 THEN BEGIN 00489800
M:=MBASE+J; 00489900
IF SP[MOC] LSS MIN THEN MIN:=SP[MOC]; 00490000
TEMP:=TEMP+OLDEL[J] END; 00490100
RVEC[I]:=MIN; DEL[I]:=TEMP; SIZE:=SIZE|RVEC[I]; 00490200
IF TEMP=0 THEN BEGIN %IT DOESN7T EXHAUSE IOTA NEWRANK 00490300
ERR:=DOMAINERROR; GO TO QUIT END; 00490400
END; 00490500
RESULT:=M:=GETSPACE(NEWRANK+SIZE); 00490600
RESULT.RF:=NEWRANK; RESULT.DID:=DDPUVW; 00490700
IF BOOLEAN(BREG.ARRAYTYPE) THEN BEGIN 00490800
RESULT.ARRAYTYPE:=1; N:=MBASE; 00490900
MBASE:=UNPACK(MBASE,RANK,N:=OLDEL[0]|SP[NOC]); 00491000
FORGETSPACE(MBASE,N+RANK) END; 00491100
FOR I:=1 STEP 1 UNTIL NEWRANK DO BEGIN 00491200
SP[MOC]:=RVEC[I-1]; M:=M+1 END; 00491300
%INTIALIZE FOR STEPPING THRU NEW ARRAY 00491400
FOR I:=NEWRANK-1 STEP -1 UNTIL 0 DO BEGIN 00491500
SUB[I]:=0; OLDEL[I]:=RVEC[I]|DEL[I] END; 00491600
L:=MBASE+RANK; 00491700
%STEP THRU THE SUBSCRIPTS OF THE ANSWER TO PICK UP THE ELEMENTS 00491800
% IN ROW ORDER ACCORDING TO THE MAPPING GIVEN BY DEL 00491900
PTR:=TOP:=NEWRANK-1; 00492000
FOR I:=1 STEP 1 UNTIL SIZE DO BEGIN 00492100
SP[MOC] :=SP[LOC]; 00492200
M:=M+1; 00492300
%GET NEXT SUBSCRIPT FOR NEW ARRAY AND SET NEXT L; 00492400
SUB[PTR]:=SUB[PTR]+1; 00492500
L:=L+DEL[TOP]; 00492600
CARRY:=TRUE; 00492700
WHILE CARRY AND I NEQ SIZE DO 00492800
IF SUB[PTR] GEQ RVEC[PTR] THEN BEGIN 00492900
SUB[PTR]:=0; 00493000
L:=L-OLDEL[PTR]+DEL[PTR:=PTR-1]; 00493100
SUB[PTR]:=SUB[PTR]+1 00493200
END ELSE CARRY := FALSE; 00493300
PTR:=TOP; 00493400
END; 00493500
IF BOOLEAN(RESULT.ARRAYTYPE) THEN PACK(RESULT.SPF,TOP+1,SIZE); 00493600
QUIT: END OF DYADICTRANS; 00493700
INTEGER PROCEDURE LOCATE(L,M); VALUE L,M; REAL L,M; 00493800
BEGIN 00493900
COMMENT L IS THE DIMENSION OF THE VECTOR(DESCRIPTOR), 00494000
M IS THE INDEX VECTOR; 00494100
INTEGER P,I,UB; 00494200
L:=I:=L.SPF; M:=I:=M.SPF; 00494300
UB:=SP[MOC]-1; 00494400
M:=M+1; 00494500
FOR I:=1 STEP 1 UNTIL UB DO 00494600
BEGIN 00494700
L:=L+1; 00494800
P:=(P+SP[MOC]-1)|SP[LOC]; 00494900
M:=M+1; 00495000
END; 00495100
P:=P+SP[MOC]; 00495200
LOCATE:=P+L; 00495300
END; 00495400
PROCEDURE DISPLAY(A,B); VALUE A,B; REAL A,B; 00495500
BEGIN 00495600
PROCEDURE PRINTMATRIX(L,ROW,COL);VALUE L,ROW,COL; 00495700
INTEGER L,ROW,COL; 00495800
BEGIN INTEGER I,J,CC,FOLD; DEFINE WIDE=GT2#; 00495900
WIDE:=LINESIZE; 00496000
FOR I:=1 STEP 1 UNTIL ROW DO 00496100
BEGIN CC:=0; %NO BLANKS AT BEGINNING OF LINE 00496200
FOLD:=0; 00496300
FOR J:=1 STEP 1 UNTIL COL DO 00496400
BEGIN NUMBERCON(SP[LOC],ACCUM); 00496500
IF FOLD:=FOLD+ACOUNT+CC GTR WIDE AND ACOUNT+CC 00496600
LEQ WIDE THEN BEGIN TERPRINT; 00496700
FORMROW(0,2,ACCUM,2,ACOUNT); FOLD:=ACOUNT+2; END ELSE 00496800
FORMROW(0,CC,ACCUM,2,ACOUNT); L:=L+1; 00496900
CC:=2; %PUT 2 BLANKS AFTER FIRST ITEM. 00497000
END; 00497100
TERPRINT; 00497200
END 00497300
END; 00497400
INTEGER L,N,M,BOTTOM,ALOC,BLOC; 00497500
INTEGER ROW,COL; 00497600
ALOC:=A.SPF; BLOC:=B.SPF-1; 00497700
L:=(M:=B.RF)+ BLOC; COL:=SP[LOC]; 00497800
L:=L-1; 00497900
ROW:=(IF M GTR 1 THEN SP[LOC] ELSE 1); 00498000
L:=BOTTOM:=M-2; 00498100
PRINTMATRIX(LOCATE(B,A),ROW,COL); 00498200
WHILE L GTR 0 DO 00498300
BEGIN 00498400
M:=ALOC+L; N:=BLOC+L; 00498500
IF SP[MOC]:=SP[MOC]+1 GTR SP[NOC] THEN 00498600
BEGIN SP[MOC]:=1; L:=L-1; END 00498700
ELSE BEGIN FORMWD(3,"1 "); 00498800
PRINTMATRIX(LOCATE(B,A),ROW,COL); 00498900
L:=BOTTOM; 00499000
END; 00499100
END; 00499200
FORMWD(3,"1 "); 00499300
END; 00499400
PROCEDURE MAKEFUNCTIONPRESENT(L); VALUE L ; REAL L; %LOC DESC 00499500
BEGIN 00499600
INTEGER I; 00499700
REAL M,N,SEQ,ORD,D; 00499800
BOOLEAN NUMERIC; 00499900
REAL STREAM PROCEDURE CON(A);VALUE A; 00500000
BEGIN SI:=LOC A; DI:=LOC CON; DS:=8OCT 00500100
END; 00500200
D:=SP[LOC]; %DESCRIPTOR FOR FUNCTION IS IN D 00500300
SEQ:=GETFIELD(D,FSQF-8,FFL); ORD:=GETFIELD(D,FPTF-8,FFL); 00500400
N:=GETSPACE((M:=SIZE(ORD))|2+6); %GET SPACE FOR TABLE 00500500
SP[NOC]:=M|2+5; %SIZE OF THE VECTOR WHICH FOLLOWS 00500600
D:=D&N[CSPF]&1[CRF]&0[BACKPT]; D.PRESENCE:=1; 00500700
SP[LOC]:=D; %THIS SETS UP THE FUNCTION DESCRIPTOR. 00500800
N:=N+1; SP[NOC]:=SEQ; 00500900
COMMENT 00501000
SP[N] = SIZE OF THE VECTOR 00501100
SP[N+1] = SEQUENTIAL STORAGE UNIT FOR THE TEXT 00501200
SP[N+2] = SP LOC OF FIRST NUMERIC POINTER TO TEXT 00501300
00501400
SP[N+3] = REL LOC (TO N+5) OF THE FIRST ARG 00501500
SP[N+4] = REL LOC TO THE SECOND ARG 00501600
SP[N+5] = REL LOC OF RESULT . IF ANY ARE ZERO, THEN 00501700
THEY ARE NOT THERE.; 00501800
D:=M; M:=(N:=N+4)+1; %D IS #ITEMS, M IS LOC 1ST, N=M-1 00501900
FOR I:=1 STEP 1 UNTIL D DO %GET LABELS FROM STORAGE 00502000
BEGIN L:=CONTENTS(ORD,I-1,GTA); 00502100
IF NOT NUMERIC THEN %RESULT, ARGS, OR LOCALS/LABELS 00502200
IF NUMERIC:=GTA[0]=0 THEN %FIRST NUMERIC POINTER 00502300
BEGIN L:=N-3; SP[LOC]:=N+I|2-1; 00502400
END; 00502500
SP[MOC]:=GTA[0]; M:=M+1; 00502600
IF NUMERIC THEN SP[MOC]:=GTA[1] ELSE 00502700
BEGIN 00502800
IF SEQ:=GTA[1] LSS 0 THEN %RESULT OR ARG 00502900
BEGIN L:=N+SEQ+1; SP[LOC]:=I; 00503000
SEQ:=0; 00503100
END ELSE SEQ:=CON(SEQ)/10000; 00503200
SP[MOC]:=SEQ 00503300
END; 00503400
M:=M+1 00503500
END; 00503600
COMMENT WE HAVE TO SET UP THE FUNCTION LABEL TABLE, LET 00503700
SOMEONE ELSE FIGURE OUT HOW TO EXECUTE IT; 00503800
END; 00503900
PROCEDURE PUSHINTOSYMTAB(FPTR);VALUE FPTR;REAL FPTR; 00504000
BEGIN COMMENT ...PUT THE LOCAL VARIABLES FROM THIS SUSPENDED 00504100
FUNCTION INTO THE SYMBOL TABLE TO BE TREATED AS GLOBAL VARIABLES 00504200
WHILE THE FUNCTION IS SUSPENDED. FPTR IS THE ENTRY FROM THE 00504300
STATE INDICATOR VECTOR FOR THE FUNCTION.; 00504400
00504500
REAL T,U; 00504600
LABEL COPY; 00504700
INTEGER K,L,M,N; 00504800
M:=FPTR.LOCFIELD+1;%LOCATE FMKS TO FIND LOCAL VALUES IN STACK 00504900
N:=FPTR.SPF+2;T:=SP[NOC]-2;%FIND LOCAL NAMES 00505000
FOR N:=N+4 STEP 2 UNTIL T DO %ONCE FOR EACH LOCAL 00505100
BEGIN GT1:=SP[NOC].[6:42];%PICK UP THE LOCAL NAME 00505200
L:=SYMBASE;K:=L+SP[LOC];% LOOK IN SYMBOL TABLE 00505300
FOR L:=L+1 STEP 2 UNTIL K DO % CHECK EACH NAME 00505400
IF GT1=SP[LOC].[6:42] THEN % WE FOUND A MATCH 00505500
BEGIN GT1:=M;K:=M:=GETSPACE(1);L:=L+1; 00505600
SP[MOC]:=SP[LOC]; %PUSH CURRENT DESCRIPTOR DOWN 00505700
M:=GT1; GO TO COPY; 00505800
END; 00505900
COMMENT GET HERE IF NO MATCH...MUST MAKE A NEW ENTRY IN 00506000
SYMBOL TABLE; 00506100
IF K LSS MAXSYMBOL|2 THEN % THERE IS ROOM IN SYMBOL TABLE 00506200
BEGIN L:=SYMBASE;SP[LOC]:=SP[LOC]+2; L:=K+1; 00506300
SP[LOC]:=GT1&OPERAND[CTYPEF]&1[CSUSVAR];L:=L+1;K:=0; 00506400
COPY: COMMENT L IS LOC IN SYMBOL TABLE FOR DESC. K WILL BE 00506500
CONTENTS OF BACKF. NOW SET UP THE NEW DESCRIPTOR AND 00506600
SAVE ITS LOCATION IN THE STACK. M IS THE STACK LOCATION 00506700
OF THE LOCAL; 00506800
00506900
SP[LOC]:=SP[MOC]&K[CLOCF]&1[CNAMED]; 00507000
SP[MOC]:=L&DDNUVW[CDID];M:=M+1; 00507100
END ELSE % THERE IS NO ROOM IN THE SYMBEOL TABLE 00507200
BEGIN N:=T;ERR:=SPERROR;END; 00507300
END;% OF FOR LOOP STEPPING THROGH THE LOCALS 00507400
END; % OF PUSHINTOSYMTAB PROCEDURE 00507500
PROCEDURE FORGETPROGRAM(U);VALUE U; REAL U; 00507600
BEGIN REAL L,M; 00507700
COMMENT U IS A PROGRAMMKS...THE SP STORAGE FOR THIS LINE 00507800
SHOULD BE RELEASED; 00507900
M:=U.SPF;SCRATCHAIN(SP[MOC].LOCFIELD);%CONSTANT CHAIN 00508000
L:=SP[MOC].SPF;FORGETSPACE(M,1);%FORGET PROGRAM DESC. 00508100
M:=L+1;SCRATCHDATA(SP[MOC]);%FORGET BUFFER 00508200
FORGETSPACE(L,SP[LOC]+1);%FORGET THE POLISH 00508300
END; 00508400
EXPOVR:=EXPOVRL; 00508500
INTOVR:=INTOVRL; 00508600
INDEX:=INDEXL; 00508700
FLAG:=FLAGL; 00508800
ZERO:=ZEROL; 00508900
CASE MODE OF 00509000
BEGIN ;%-------------------------------------------------------- 00509100
%---------------- CASE 1....MODE=XEQUTE------------------------ 00509200
CASE CURRENTMODE OF 00509300
BEGIN%----------------------------------------------------- 00509400
%------------- SUB-CASE 0....CURRENTMODE=CALCMODE---------- 00509500
IF T:=ANALYZE(TRUE) NEQ 0 THEN % WE HAVE A PROGRAM DESC 00509600
BEGIN COMMENT SET-UP THE STACK; 00509700
IF STACKBASE=0 THEN BEGIN 00509800
STACKBASE:=L:=GETSPACE(STACKSIZE+1); 00509900
IF ERR NEQ 0 THEN BEGIN STACKBASE:=0; 00510000
ERRORMESS(ERR,0,0); GO TO PROCESSEXIT;END; 00510100
SP[LOC]:=2; 00510200
L:=L+1; 00510300
M:=GETSPACE(STATEVECTORSIZE+1); 00510400
SP[LOC]:=M&1[CRF]&DDPNVW[CDID]; 00510500
SP[MOC]:=STATEVECTORSIZE; 00510600
M:=M+1; SP[MOC]:=0; % THE STATE VECTOR IS INITIALIZED NOW 00510700
FUNCLOC:=M; 00510800
N:=0; 00510900
L:=L+1; COMMENT READY FOR A PROG MKS; 00511000
END ELSE % THERE IS ALREADY A STACK...USE IT 00511100
BEGIN L:=STACKBASE; 00511200
ST:=SP[LOC]+L; 00511300
WHILE M:=AREG.DID NEQ IMKS AND M NEQ PROGMKS AND 00511400
ERR=0 DO POP;%STRIP BACK TO LASTMARKSTACK 00511500
IF M=IMKS THEN BEGIN N:=ST-STACKBASE;PUSH; 00511600
END ELSE N:=AREG.BACKF; 00511700
SP[LOC]:=ST-STACKBASE;L:=ST; 00511800
END; 00511900
CURLINE:=0; 00512000
M:=GETSPACE(1); SP[MOC]:=T; %STORE PROG DESCRIPTOR 00512100
SP[LOC]:=M&PROGMKS[CDID]&N[BACKPT]&1[CI]; 00512200
COMMENT JUST BUILT A PROGRAM MARKSTACK; 00512300
GO TO EXECUTION; 00512400
END; 00512500
%------------SUB-CASE 1....CURRENTMODE=XEQMODE--------------- 00512600
COMMENT RECOVERY FROM A TIME-OUT; 00512700
GO TO EXECUTION; 00512800
%----------- SUB-CASE 2....CURRENTMODE=FUNCMODE-------------- 00512900
COMMENT SYNTAX CHECK ONLY; 00513000
IF ANALYZE(TRUE)=0 THEN; 00513100
%------- END OF SUB CASES----------------------------------- 00513200
END; 00513300
%------------------ CASE 2.....MODE=ALLOC------------------------ 00513400
COMMENT NOTHING TO DO; 00513500
; 00513600
%----------------- CASE 3.... MODE=WRITEBACK------------------- 00513700
COMMENT HAVE TO WRITE BACK ALL THE CHANGED VARIABLES; 00513800
IF SYMBASE NEQ 0 THEN 00513900
WRITEBACK; 00514000
00514100
%----------------- CASE 4.... MODE=DEALLOC--------------------- 00514200
; 00514300
00514400
00514500
%----------------- CASE 5 .... MODE=INTERROGATE---------------- 00514600
COMMENT PRINT OUT THE PROGRAM STATUS VECTOR HERE; 00514700
IF L:=STACKBASE+1 NEQ 1 THEN 00514800
BEGIN COMMENT GT1=1 FOR SIV...=0 FOR SI; 00514900
U:=GT1; 00515000
L:=SP[LOC].SPF+1;M:=SP[LOC].SPF+L; 00515100
WHILE M GTR L DO 00515200
BEGIN N:=SP[MOC].LOCFIELD;N:=SP[NOC].SPF-1; 00515300
% N IS LOCATION OF THE FUNCTION NAME 00515400
ACCUM[0]:=SP[NOC]; 00515500
FORMROW(2,6,ACCUM,1,7); 00515600
IF BOOLEAN(SP[MOC].SUSPENDED) THEN FORMWD(0,"3 S ") 00515700
ELSE FORMWD(0,"3 "); 00515800
IF BOOLEAN(U) THEN % PRINT LOCAL VARIABLE NAMES 00515900
BEGIN 00516000
N:=SP[MOC].SPF+2;T:=SP[NOC]-2; 00516100
FOR N:=N+4 STEP 2 UNTIL T DO 00516200
BEGIN ACCUM[0]:=SP[NOC]; 00516300
FORMROW(0,1,ACCUM,1,7); 00516400
END; 00516500
END; 00516600
TERPRINT; M:=M-1; 00516700
END; 00516800
END; 00516900
END;% OF THE CASE STATMENT 00517000
%--------------END OF CASES--------------------------------------- 00517100
IF FALSE THEN EXECUTION: 00517200
BEGIN COMMENT EXECUTION LOOP; 00517300
INTEGER LOOP; 00517400
INTEGER INPUTIMS; 00517500
LABEL BREAKKEY; 00517600
LABEL SKIPPOP,XEQEPS; 00517700
BOOLEAN XIT, JUMP; 00517800
REAL POLWORD; 00517900
DEFINE RESULT=RESULTD#; 00518000
LABEL EXECEXIT, EVALQ, EVALQQ; 00518100
%%% 00518200
COMMENT THERE IS A PROGRAM DESCRIPTOR AT THE TOP OF THE STACK; 00518300
ERR:=0; 00518400
L:=STACKBASE; ST:=L+SP[LOC]; 00518500
L:=L+1;FUNCLOC:=SP[LOC].SPF+1; 00518600
T:=AREG; 00518700
IF CURRENTMODE=XEQMODE THEN %AREG IS INTERRUPT MARK STACK 00518800
BEGIN LASTMKS:=STACKBASE+T.BACKF; 00518900
OLDDATA:=T.SPF; INPUTIMS:=T.QUADIN; POP; 00519000
COMMENT MAY BE CURRENTLY EXECUTING A FUNCTION; 00519100
L:=STACKBASE+1; L:=SP[LOC].SPF+1; 00519200
IF (M:=SP[LOC].SPF) NEQ 0 THEN 00519300
BEGIN M:=M+L; L:=SP[MOC].LOCFIELD; 00519400
CURLINE:=SP[LOC].CIF; 00519500
00519600
END; 00519700
END 00519800
ELSE LASTMKS:=ST;%AREG IS PROGRAM MARK STACK 00519900
CURRENTMODE:=XEQMODE; 00520000
L:=LASTMKS; T:=SP[LOC]; % T IS PROGRAM MARK STACK 00520100
CINDEX:=T.CIF; % CONTROL INDEX IN POLISH 00520200
IF L:=T.SPF =0 THEN %PHONEY PROG DESC FROM FUNCTION CALL 00520300
N:=POLTOP:=POLLOC:=0 ELSE 00520400
BEGIN 00520500
N:=POLLOC:=SP[LOC].SPF; 00520600
POLTOP:=SP[NOC] 00520700
END; 00520800
IF ERR = 0 THEN % POP WORKED 00520900
IF INPUTIMS=2 THEN BEGIN JUMP:=TRUE; GO TO EVALQ END ELSE 00521000
IF INPUTIMS = 1 THEN BEGIN JUMP:=TRUE; GO TO EVALQQ; END ELSE 00521100
DO BEGIN COMMENT EXECUTE UNTIL DONE OR TIME-OUT; 00521200
IF CINDEX LSS POLTOP THEN %MORE TO EXECUTE IN POLISH 00521300
BEGIN COMMENT GET NEXT POLISH TO EXECUTE; 00521400
M:=(CINDEX:=CINDEX+1)+POLLOC; 00521500
POLWORD:=T:=SP[MOC]; 00521600
CASE T.TYPEFIELD OF 00521700
BEGIN %-------TF=0 (REPLACEMENT)-------------- 00521800
BEGIN %MAY BE A LOCAL OR A GLOBAL VARIABLE 00521900
DEFINE STARTSEGMENT=#; %///////////////////// 00522000
PUSH; IF ERR NEQ 0 THEN GO TO SKIPPOP; 00522100
N:=T.LOCFIELD; 00522200
IF BOOLEAN(T.OPTYPE) THEN %A LOCAL VARIABLE 00522300
BEGIN M:=FUNCLOC;%FIND LAST MKS 00522400
M:=SP[MOC].SPF+M; 00522500
N:=SP[MOC].LOCFIELD+N; END; 00522600
U:=SP[NOC]; U.LOCFIELD:=N; AREG:=U; 00522700
IF U.DATADESC=0 THEN ERR:=NONCEERROR; 00522800
COMMENT PROBABLY MIXUP WITH FUNCTION NAMES 00522900
AND NAMES OF LOCAL SUSPENDED VARIABLES; 00523000
END; 00523100
%-------------FUNCTION CALL----------------- 00523200
%&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 00523300
BEGIN COMMENT SET UP STACK FOR A FUNCTION CALL; 00523400
REAL U,V,NARGS,D; 00523500
INTEGER I,FLOC; 00523600
LABEL TERMINATE; 00523700
COMMENT 00523800
MONITOR PRINT(D,L,M,N,FLOC,SP,LASTMKS);%:::::::::::::::::::: 00523900
FLOC:=N:=T.LOCFIELD; 00524000
IF BOOLEAN(SP[NOC].DATADESC) THEN BEGIN ERR:=NONCEERROR; 00524100
GO TO TERMINATE;END;%SUSPENDED VAR CONFUSED WITH FUNCTION 00524200
IF NOT BOOLEAN(SP[NOC].PRESENCE) THEN MAKEFUNCTIONPRESENT(N); 00524300
D:=SP[NOC]; L:=LASTMKS; %D IS TEH DESC, L IS THE PROG MKS 00524400
SP[LOC].CIF:=CINDEX; %SAVE CURRENT POLISH LOCATION 00524500
L:=STACKBASE+1; L:=SP[LOC].SPF+1; 00524600
M:=SP[LOC].SPF; 00524700
IF N:=M+L NEQ L THEN %THERE IS A NESTED CALL 00524800
IF NOT BOOLEAN(SP[NOC].SUSPENDED) THEN 00524900
BEGIN N:=SP[NOC].LOCFIELD;SP[NOC].CIF:=CURLINE;END; 00525000
00525100
00525200
SETFIELD(GTA,0,8,0); SETFIELD(GTA,8,8,0); %INITIALIZE GTA 00525300
NARGS:=D.NUMBERARGS; 00525400
FOR I:=1 STEP 1 UNTIL NARGS DO 00525500
IF BOOLEAN((T:=AREG).DATADESC) THEN 00525600
BEGIN 00525700
IF BOOLEAN(T.NAMED) THEN %MAKE A COPY 00525800
COMMENT YOU COULD MAKE A CALL BY NAME HERE; 00525900
BEGIN U:=GETSPACE(V:=(NUMELEMENTS(T)+T.RF)); 00526000
SPCOPY(T.SPF,U,V); T.NAMED:=0; T.SPF:=U; 00526100
T.BACKP:=0; 00526200
END ELSE %NO NEED TO MAKE A COPY 00526300
AREG.PRESENCE:=0; 00526400
POP; GTA[I-1]:=T; %SAVE THE DESCRIPTOR FOR LATER USE 00526500
END ELSE ERR:=SYSTEMERROR; 00526600
IF (N:=M+1) GEQ STATEVECTORSIZE THEN ERR:=DEPTHERROR; 00526700
IF ERR NEQ 0 THEN GO TO TERMINATE; 00526800
SP[LOC].SPF:=N; 00526900
PUSH;AREG:=OLDDATA&(LASTMKS-STACKBASE)[BACKPT]&IMKS[CDID]; 00527000
OLDDATA:=0; %REINITIALIZE OLDDATA CHAIN FOR THIS FUNCTION 00527100
%NOW SET UP THE FUNCTION MARK STACK. 00527200
00527300
M:=N+L;PUSH;SP[MOC]:=D.SPF&ST[CLOCF]; 00527400
M:=D.SPF; M:=M+2; % M IS LOC OF LOC OF FIRST LINE 00527500
AREG:=0&FLOC[CSPF]&((LASTMKS:=ST)-STACKBASE-1)[BACKPT]& 00527600
(U:=SP[MOC]-D.SPF)[CCIF]&FMKS[CDID]; % FUNCTION MKS 00527700
CURLINE:=U; 00527800
00527900
U:=(U-6)/2; % U IS THE NUMBER OF LOCALS, LABELS, AND ARGS 00528000
M:=M+5; % M IS ON THE FIRST DESC OF THE FIRST LAB, LOC,... 00528100
FOR I:=1 STEP 1 UNTIL U DO % GET DESCRIPTORS INTO THE STACK 00528200
BEGIN IF SP[MOC] NEQ 0 THEN %MAKE UP THE DESC 00528300
BEGIN L:=GETSPACE(1); SP[LOC]:=SP[MOC]; 00528400
T:=L&DDPUSW[CDID]&0[CCIF] 00528500
END ELSE 00528600
T:=NULLV; 00528700
PUSH; M:=M+2; 00528800
AREG:=T; %A SINGLE LOCAL 00528900
END; 00529000
%COPY OVER THE ARGUMENTS 00529100
FOR I:=1 STEP 1 UNTIL NARGS DO %COPY OVER 00529200
BEGIN M:=D.SPF; %M IS THE LOCATION OF THE LABEL TABLE. 00529300
M:=M+2+I; %M IS LOCATION OF REL LOCATION OF VARIABLE 00529400
M:=SP[MOC]; 00529500
N:=LASTMKS+M; 00529600
SP[NOC]:=GTA[I-1]; 00529700
END; 00529800
%PUT IN A PHONEY PROG DESC TO START THINGS OFF 00529900
PUSH; IF ERR NEQ 0 THEN GO TO TERMINATE; 00530000
AREG:=0&4094[CCIF]&(LASTMKS-STACKBASE)[BACKPT]; 00530100
LASTMKS:=ST; POLTOP:=POLLOC:=0; 00530200
TERMINATE: 00530300
END; 00530400
%&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 00530500
%-------END OF LOAD FUNCTION FOR CALL----- 00530600
%-------------TF=2 (CONSTANT)--------------------- 00530700
BEGIN PUSH; IF ERR=0 THEN BEGIN 00530800
N:=POLWORD.LOCFIELD;AREG:=SP[NOC];END; 00530900
END; 00531000
%-------------TF=3 (OPERATOR)----------------- 00531100
COMMENT SEQUENCE NUMBERS CORRESPOND TO OPERATOR 00531200
ASSIGNMENT NUMBER; 00531300
BEGIN IF T.OPTYPE=MONADIC THEN 00531400
BEGIN PUSH;IF ERR=0 THEN AREG:=0; END; 00531500
CASE T.LOCFIELD OF 00531600
BEGIN %--------------- OPERATE ON STACK --------------------- 00531700
COMMENT EACH EXECUTION PROCEDURE SETS RESULT TO THE 00531800
DESCRIPTOR OF THE RESULT OF THE OPERATION. 00531900
AREG AND BREG ARE THE LEFT AND RIGHT-HAND OPERANDS AND 00532000
ARE ACTUALLY THE TOP TWO DESCRIPTORS ON THE STACK. 00532100
IF AREG IS ZERO, THE OPERATOR IS TAKEN TO BE MONADIC.; 00532200
; 00532300
; 00532400
; 00532500
; 00532600
%---------------------REPLACEMENT OPERATOR--------------- 00532700
BEGIN DEFINE STARTSEGMENT=#; %/////////////////////////////// 00532800
IF NOT BOOLEAN(L:=AREG.NAMED) THEN % SHOULD BE LOCAL VARIABLE 00532900
AREG.NAMED:=1; % DONT LET IT BE FORGOTTEN. 00533000
00533100
IF BOOLEAN((T:=AREG).PRESENCE) AND T.SPF NEQ 0 THEN 00533200
OLDDATA:=CHAIN(T,OLDDATA); 00533300
M:=T.LOCFIELD; 00533400
00533500
IF(RESULT:=BREG).SPF = 0 THEN U:=T:=0 ELSE 00533600
U:=GETSPACE(T:=NUMELEMENTS(RESULT)+RESULT.RF); 00533700
SPCOPY(RESULT.SPF,U,T); 00533800
RESULT.SPF:=U; RESULT.NAMED:=L; %L IS 0 FOR LOCALS 00533900
GT1:=IF BOOLEAN((U:=SP[MOC]).PRESENCE) THEN U.BACKP ELSE 0; 00534000
SP[MOC]:=RESULT&GT1[CLOCF]; 00534100
IF BOOLEAN(L) AND GT1=0 THEN %CHECK FOR GLOBAL 00534200
BEGIN M:=M-1;IF(SP[MOC].SUSPENDVAR=0)THEN SP[MOC].CHANGE:=1; 00534300
00534400
END; 00534500
RESULT.NAMED:=1; %KEEP "PUSH" FROM TOSSING THE DATA 00534600
END; 00534700
%-------TRANSFER OPERATOR----------------------------- 00534800
BEGIN DEFINE STARTSEGMENT=#; %//////////////////////////////// 00534900
SCRATCHAIN(OLDDATA);OLDDATA:=0; 00535000
IF BOOLEAN(T.OPTYPE) THEN ST:=ST-1; %GET RID OF PHONEY TOP 00535100
L:=FUNCLOC; 00535200
IF SP[LOC] NEQ 0 THEN STEPLINE(TRUE) ELSE 00535300
ERR:=SYNTAXERROR; 00535400
GO TO SKIPPOP; 00535500
END; 00535600
BEGIN %--------------COMPRESSION------------------------------------00535700
DEFINE STARTSEGMENT=#; %///////////////////////////////////// 00535800
L:=ST-2; IF T.OPTYPE=MONADIC THEN COMPRESS(BREG,SP[LOC],AREG) 00535900
ELSE COMPRESS(AREG,SP[LOC],BREG); COMMENT A/B HAS BEEN 00536000
STACKED AS B,A,NULL...A/[I] B HAS BEEN STACKED AS B,I,A; 00536100
END; 00536200
ARITH(3); %OPERATION IS DIVIDE 00536300
; 00536400
; 00536500
%-------------QUAD INPUT------------------------------- 00536600
EVALQ: BEGIN LABEL EVALQUAD; 00536700
IF JUMP THEN BEGIN JUMP:=FALSE; GO TO EVALQUAD END; 00536800
CURRENTMODE:=INPUTMODE; 00536900
FORMWD(3,"3[]: "); INDENT(0); 00537000
00537100
IMS(2); % SETUP MARKSTACK FOR QUAD EXIT 00537200
IF ERR NEQ 0 THEN GO TO SKIPPOP; 00537300
GO TO EXECEXIT; % EXIT TO MONITOR TILL INPUT IS COMPLETE 00537400
EVALQUAD: %LOOK AT BUFFER TO SEE WHAT CAME IN 00537500
BEGIN 00537600
IF NOT SCAN THEN BEGIN CINDEX:=CINDEX-1;GO TO SKIPPOP;END; 00537700
IF NOT SETUPLINE THEN CINDEX:=CINDEX-1;%MAKE THEM REDO IT 00537800
GO TO SKIPPOP; 00537900
END; 00538000
END; 00538100
BEGIN % -----EVALUATE SUBSCRIPTS--------------- 00538200
DEFINE STARTSEGMENT=#; %///////////////////////////////////// 00538300
T:=AREG; L:=BREG.SPF; 00538400
IF BOOLEAN(T.SCALAR) THEN BEGIN ERR:=DOMAINERROR; GO TO SKIPPOP;END;00538500
U:=SP[LOC]; % GET # OF SUBSCRIPTS 00538600
IF U GTR 32 THEN ERR:=INDEXERROR ELSE 00538700
BEGIN 00538800
IF U GTR 0 THEN BEGIN 00538900
IF T.PRESENCE NEQ 1 THEN % GET ARRAY INTO SP 00539000
BEGIN N:=T.LOCFIELD; 00539100
IF (T:=SP[NOC]).PRESENCE NEQ 1 THEN 00539200
BEGIN T:=GETARRAY(T); SP[NOC]:=T END; 00539300
T.LOCFIELD:= N; 00539400
END; 00539500
IF ERR=0 THEN % NOW EVALUATE 00539600
00539700
RESULT:=SUBSCRIPTS(L:=(IF T.LOCFIELD=0 THEN OUTOF 00539800
ELSE INTO),T,U); 00539900
IF L=INTO THEN BEGIN 00540000
00540100
CINDEX:=CINDEX+1;END; % SKIP OVER REPLACE OP 00540200
END ELSE % NO SUBSCRIPTS 00540300
BEGIN BREG:=T; ST:=ST-1; GO TO SKIPPOP; 00540400
END; % DON{T LET THE DESC. IN T BE POPPED. 00540500
U:=U+2; % # OF THINGS TO POP 00540600
FOR N:=1 STEP 1 UNTIL U DO POP; 00540700
IF L=OUTOF THEN PUSH; AREG:=RESULT; 00540800
00540900
GO TO SKIPPOP; 00541000
END; 00541100
END; 00541200
; 00541300
; 00541400
%-------------QQUAD INPUT------------------------------- 00541500
EVALQQ: BEGIN LABEL EVALQQUAD; 00541600
IF JUMP THEN BEGIN JUMP:=FALSE; GO TO EVALQQUAD END; 00541700
CURRENTMODE:=INPUTMODE; 00541800
IMS(1); %SET UP MARKSTACKS FOR QQUAD EXIT 00541900
IF ERR NEQ 0 THEN GO TO SKIPPOP; 00542000
GO TO EXECEXIT; 00542100
EVALQQUAD: % BUFFER CONTAINS THE INPUT STRING 00542200
IF (L:=LENGTH(BUFFER,TRUE))NEQ 0 THEN BEGIN %L IS # CHAR INPUT 00542300
N:=ENTIER((L+7) DIV 8); % FIND NUMBER OF WORDS 00542400
M:=GETSPACE(N+1); % GET SPACE FOR THE VECTOR IN SP 00542500
TRANSFERSP(INTO,SP,M+1,BUFFER,0,N); 00542600
SP[MOC]:=L; % STORE LENGTH OF VECTOR 00542700
RESULT:=M&1[CRF]&DDPUVC[CDID]; % SET UP DESCRIPTOR 00542800
END ELSE RESULT:=NULLV;% NOTHING WAS INPUT 00542900
PUSH; IF ERR=0 THEN AREG:=RESULT; 00543000
GO TO SKIPPOP; 00543100
END; 00543200
RESULTD := SEMICOL; %CONVERSIEON CONCATENATION 00543300
COMMAP; %CATENATE 00543400
BEGIN%----------INNER PRODUCT (PERIOD)--------------------- 00543500
M:=(CINDEX:=CINDEX+2) + POLLOC; T:=SP[MOC];M:=M-1;U:=SP[MOC]; 00543600
PERIOD(AREG,BREG,U.LOCFIELD,T.LOCFIELD); 00543700
END; 00543800
ARITH(4); %* 00543900
; 00544000
; 00544100
ARITH(17); %AND 00544200
ARITH(18); %OR 00544300
ARITH(9); %NOT 00544400
ARITH(11); %LESS:THAN 00544500
ARITH(16); %LEQ 00544600
ARITH(12); %= 00544700
ARITH(13); %GEQ 00544800
ARITH(14); %GREATER-THAN 00544900
ARITH(15); %NEQ 00545000
ARITH(8); %MAX/CEIL 00545100
ARITH(7); %MIN/FLOOR 00545200
ARITH(6); %RESD/ABS 00545300
IF T.OPTYPE=MONADIC THEN GO TO XEQEPS ELSE MEMBER; %MEMBERSHIP 00545400
RHOP; %RHO 00545500
IOTAP; %IOTA 00545600
; 00545700
REDUCESORTSCAN(0,BREG,AREG,4); %REVERSAL; 00545800
BEGIN %-----------EXPANSION------------------------- 00545900
DEFINE STARTSEGMENT=#; %//////////////////////////////////// 00546000
L:=ST-2; IF T.OPTYPE=MONADIC THEN EXPAND(BREG,SP[LOC],AREG) 00546100
ELSE EXPAND(AREG,SP[LOC],BREG); COMMENT A EXPN B HAS BEEN 00546200
STACKED AS B,A,NULL WHILE A EXPN [I] B IS STACKED AS B,I,A; 00546300
END; 00546400
RESULTD:=BASEVALUE; %BASE VALUE 00546500
ARITH(10); %COMB/FACT 00546600
; 00546700
IF T.OPTYPE=MONADIC THEN ARITH(5) ELSE 00546800
DYADICRNDM; %RNDM 00546900
IF T.OPTYPE=MONADIC THEN TRANSPOSE ELSE DYADICTRANS;%GUESS WHAT 00547000
RESULTD := REPRESENT; %REPRESENTATION 00547100
ARITH(45); %CIRCLE--TRIGONOMETRIC FUNCTIONS 00547200
; 00547300
; 00547400
ARITH(0); %ADD 00547500
ARITH(2); %SUBTRACT 00547600
ARITH(1); %MULTIPLY 00547700
%-------------------DISPLAY--------------------------------------- 00547800
00547900
BEGIN DEFINE STARTSEGMENT=#; %///////////////////////////////// 00548000
IF BREG.SPF=0 THEN FORMROW(3,0,ACCUM,2,0) ELSE %FOR A NULL 00548100
IF BOOLEAN((RESULT:=BREG).DATADESC)THEN %THIS IS A DATA DESC 00548200
IF BOOLEAN(RESULT.PRESENCE) AND M:=RESULT.SPF NEQ 0 THEN 00548300
IF BOOLEAN(RESULT.SCALAR) THEN 00548400
BEGIN NUMBERCON(SP[MOC],ACCUM); 00548500
FORMROW(3,0,ACCUM,2,ACOUNT) 00548600
END 00548700
ELSE %A VECTOR 00548800
IF L:=RESULT.RF NEQ 0 THEN % SOMETHING TO PRINT 00548900
IF BOOLEAN(RESULT.CHRMODE) THEN DISPLAYCHARV(RESULT) 00549000
ELSE 00549100
BEGIN RESULT:=M:=GETSPACE(L+1); 00549200
SP[MOC]:=L; RESULT.RF:=1; RESULT.DID:=DDPUVW; 00549300
AREG:=RESULT; 00549400
FOR T:=1 STEP 1 UNTIL L DO 00549500
BEGIN M:=M+1; SP[MOC]:=1 00549600
END; 00549700
DISPLAY(AREG,BREG); 00549800
RESULT:=BREG; 00549900
END ELSE TERPRINT 00550000
ELSE TERPRINT 00550100
ELSE ; %PROBABLY A FUNCTION....DONT DO ANYTHING 00550200
IF BREAKFLAG THEN %USER HIT BREAK DURING OUTPUT 00550300
GO TO BREAKKEY; 00550400
POP; GO TO SKIPPOP; 00550500
END; 00550600
BEGIN % ---------------REDUCTION------------------------------------00550700
M:=(CINDEX:= CINDEX+1) + POLLOC; % FIND OPERATION IN POLISH 00550800
IF (T:=SP[MOC]).TYPEFIELD NEQ 3 THEN ERR:=SYSTEMERROR 00550900
ELSE REDUCESORTSCAN(T.LOCFIELD,BREG,AREG,1); 00551000
END; 00551100
BEGIN %--------ROTATION---------------------------- 00551200
DEFINE STARTSEGMENT=#; %//////////////////////////////////// 00551300
L:=ST-2; IF T.OPTYPE=MONADIC THEN 00551400
REDUCESORTSCAN(BREG,SP[LOC],AREG,5) ELSE 00551500
REDUCESORTSCAN(AREG,SP[LOC],BREG,5); COMMENT A ROT B IS 00551600
STACKED AS B,A,NULL WHILE A ROT [I] B IS STACKED AS B,I,A; 00551700
END; 00551800
ARITH(21); %LOG 00551900
REDUCESORTSCAN(0,BREG,AREG,2); % SORTUP 00552000
REDUCESORTSCAN(-1,BREG,AREG,2); %SORTDN 00552100
BEGIN%--------------SCAN-------LIKE REDUCTION---------------- 00552200
DEFINE STARTSEGMENT=#; %////////////////////////////////////// 00552300
M:=(CINDEX:=CINDEX+1) + POLLOC; %FIND OPERATOR IN POLISH 00552400
IF (T:=SP[MOC]).TYPEFIELD NEQ 3 THEN ERR:=SYSTEMERROR 00552500
ELSE REDUCESORTSCAN(T.LOCFIELD,BREG,AREG,3); 00552600
END; 00552700
ARITH(19); %NAND 00552800
ARITH(20); %NOR 00552900
IF (T:=BREG).RF NEQ 0 THEN RESULT:=SUBSCRIPTS(3,T,T.RF) 00553000
ELSE ERR:=RANKERROR; % OPERATION IS TAKE 00553100
IF (T:=BREG).RF NEQ 0 THEN RESULT:=SUBSCRIPTS(3,T,T.RF) 00553200
ELSE ERR:=RANKERROR; % OPERATION IS DROP 00553300
%------------------------XEQ--------------------------------- 00553400
XEQEPS: BEGIN DEFINE STARTSEGMENT=#; %//////////////// 00553500
IF AREG NEQ 0 THEN ERR:=SYNTAXERROR %MUST BE MONADIC ONLY 00553600
ELSE IF (T:=BREG).RF NEQ 1 OR %MUST BE A VECTOR 00553700
NOT BOOLEAN(T.CHRMODE) THEN ERR:=DOMAINERROR %MUST BE CHAR STRING 00553800
ELSE IF U:=NUMELEMENTS(T) GTR MAXBUFFSIZE THEN ERR:=LENGTHERROR 00553900
ELSE BEGIN 00554000
M:=GT1; % # OF CHARACTERS SET BY NUMELEMENTS 00554100
INITBUFF(BUFFER,MAXBUFFSIZE);RESCANLINE; 00554200
TRANSFERSP(OUTOF,SP,T.SPF+1,BUFFER,0,U); 00554300
IF(U:=U|8-M) GTR 0 THEN SETFIELD(BUFFER,M,U," "); 00554400
IF T.SPF=0 OR NOT SCAN THEN RESULT:=0&1[CRF]&DDPUVW[CDID]% NULL 00554500
ELSE BEGIN POP;IF SETUPLINE THEN; GO TO SKIPPOP;END 00554600
END; END; 00554700
END; %--------------END OF OPERATION ON STACK--------------------- 00554800
POP;POP;PUSH;IF ERR=0 THEN AREG:=RESULT; 00554900
SKIPPOP: END OF TYPEFIELD EQUALS OPERATOR; 00555000
%-------TF=4 (LOCAL VARIABLE)------------ 00555100
BEGIN COMMENT MOVE DESCRIPTOR UP TO TOP; 00555200
DEFINE STARTSEGMENT=#; %///////////////// 00555300
N:=T.LOCFIELD;M:=FUNCLOC;M:=SP[MOC]+M; 00555400
00555500
N:=SP[MOC].LOCFIELD+N; 00555600
T:=SP[NOC]; T.NAMED:=1; %KEEP FROM THROWING AWAY 00555700
PUSH; AREG:=T; 00555800
END; 00555900
%-------TF=5 (OPERAND)----------------------- 00556000
BEGIN PUSH; IF ERR=0 THEN BEGIN 00556100
N:=POLWORD.LOCFIELD; U:=SP[NOC]; 00556200
IF U.DATADESC=0 THEN ERR:=NONCEERROR ELSE 00556300
IF U.PRESENCE NEQ 1 THEN BEGIN 00556400
U:=GETARRAY(U); SP[NOC]:=U END; 00556500
U.LOCFIELD:=0; 00556600
AREG:=U; END; 00556700
END; 00556800
END; % OF CASE STATEMENT TESTING TYPEFIELD 00556900
END % OF TEST FOR CINDEX LEQ POLTOP 00557000
ELSE % WE ARE AT THE END OF THE POLISH 00557100
BEGIN COMMENT LASKMKS CONTAINS THE LOCATION 00557200
OF THE LAST MARK STACK. GET MARK STACK AND CONTINUE; 00557300
00557400
SCRATCHAIN(OLDDATA); OLDDATA:=0; 00557500
L:=LASTMKS;M:=(U:=SP[LOC]).BACKF+STACKBASE;T:=SP[MOC]; 00557600
IF T.DID=IMKS AND T.QUADIN=3 THEN %SINGLE LINE DONE 00557700
IF (RESULT:=AREG)=T THEN ERR:=SYNTAXERROR%NO RESULT 00557800
ELSE BEGIN RESULT.NAMED:=0;%MAKE NEW COPY 00557900
IF BOOLEAN(RESULT.SCALAR) THEN 00558000
BEGIN M:=GETSPACE(2);L:=RESULT.SPF; 00558100
RESULT.SPF:=M+1;SP[MOC]:=RESULT; 00558200
M:=M+1;SP[MOC]:=SP[LOC]; 00558300
END ELSE % MAKE COPY OF A VECTOR 00558400
BEGIN M:=GETSPACE(1+(N:=RESULT.RF+NUMELEMENTS( 00558500
RESULT))); 00558600
L:=RESULT.SPF;RESULT.SPF:=M+1; 00558700
SP[MOC]:=RESULT; SPCOPY(L,M+1,N); END; 00558800
00558900
00559000
FORGETPROGRAM(U); 00559100
00559200
DO POP UNTIL ST LSS LASTMKS;%CUT BACK STACK TO IMS 00559300
OLDDATA:=T.SPF;L:=LASTMKS:=T.BACKF+STACKBASE; 00559400
AREG:=RESULT; % STORE EXECUTION RESULT OVER IMS 00559500
CINDEX:=SP[LOC].CIF; M:= SP[LOC].SPF; 00559600
POLLOC:=M:=SP[MOC].SPF; POLTOP:=SP[MOC]; 00559700
END ELSE 00559800
BEGIN L:=FUNCLOC;M:=SP[LOC].SPF+L; 00559900
IF M NEQ L AND NOT BOOLEAN(SP[MOC].SUSPENDED)THEN 00560000
BEGIN 00560100
IF 0=(LOOP:=(LOOP+1) MOD 5) THEN 00560200
WRITE(TWXOUT,1,JIGGLE[*])[BREAKKEY:BREAKKEY]; 00560300
%THAT WAS TO CHECK FOR A BREAK TO INTERRUPT A PROG 00560400
STEPLINE(FALSE) 00560500
END 00560600
ELSE BEGIN XIT:=TRUE;CURRENTMODE:=CALCMODE; 00560700
WHILE POPPROGRAM(OLDDATA,LASTMKS) DO; 00560800
END; 00560900
END; 00561000
END; %COMPLETION OF ONE POLISH EVALUATION (1 CELL) 00561100
IF ERR NEQ 0 THEN % PUT OUT ERROR MESSAGE 00561200
BEGIN 00561300
DEFINE STARTSEGMENT=#; %///////////////////////////// 00561400
COMMENT 00561500
MONITOR PRINT(ST,L,M,SP,GTA,T);%:::::::::::::::::::::: 00561600
XIT:=TRUE;CURRENTMODE:=ERRORMODE; 00561700
00561800
L:=POLLOC+1; 00561900
TRANSFERSP(OUTOF,SP,(L:=SP[LOC].SPF)+1,BUFFER, 00562000
0,MIN(MAXBUFFSIZE,ENTIER((SP[LOC]+7)DIV 8))); 00562100
L:=FUNCLOC;M:=SP[LOC].SPF+L; 00562200
GT1:=1;N:=SP[MOC].LOCFIELD;%LOCATION OF FMKS 00562300
WHILE LASTMKS GTR N AND BOOLEAN (GT1) DO GT1:=IF 00562400
POPPROGRAM(OLDDATA,LASTMKS)THEN 1 ELSE 0; 00562500
IF M NEQ L AND NOT BOOLEAN(SP[MOC].SUSPENDED)THEN%GET LINE# 00562600
BEGIN SP[LOC].RF:=SP[LOC].RF+1;%UP SUSPENDED COUNT 00562700
L:=SP[NOC].SPF-1;%LOCATION OF FUNCTION NAME 00562800
SETFIELD(GTA,0,1,0); 00562900
GTA[0]:=SP[LOC]; 00563000
FORMROW(3,0,GTA,1,7); 00563100
L:=SP[MOC].SPF; %BASE OF LABEL TABLE 00563200
L:=L+CURLINE; 00563300
T:=SP[LOC]; 00563400
00563500
%ALSO PUT THE FUNCTION INTO SUSPENSION 00563600
IMS(4);SP[MOC].SUSPENDED:=1;SUSPENSION:=1; 00563700
PUSHINTOSYMTAB(SP[MOC]); 00563800
END ELSE T:=0; 00563900
ERRORMESS(ERR,POLWORD.SPF,T); 00564000
END; 00564100
END UNTIL XIT; 00564200
BREAKKEY: BEGIN BREAKFLAG:=FALSE; 00564300
XIT:=TRUE;CURRENTMODE:=CALCMODE; 00564400
L:=FUNCLOC;M:=SP[LOC].SPF+L; 00564500
IF M NEQ L AND NOT BOOLEAN(SP[MOC].SUSPENDED) THEN 00564600
BEGIN SP[MOC].SUSPENDED:=1;SUSPENSION:=1; 00564700
PUSHINTOSYMTAB(SP[MOC]);SP[LOC].RF:=SP[LOC].RF+1; 00564800
M:=SP[MOC].LOCFIELD;%LOCATION OF FMKS IN STACK 00564900
WHILE LASTMKS GTR M DO IF POPPROGRAM(OLDDATA,LASTMKS) 00565000
THEN; LASTMKS:=M;IMS(4); 00565100
END 00565200
IF FALSE THEN 00565300
END; 00565400
EXECEXIT: 00565500
IF STACKBASE NEQ 0 THEN BEGIN 00565600
L:=STACKBASE; SP[LOC]:=ST-L; %UPDATE SIZE OF STACK 00565700
00565800
END; 00565900
END OF EXECUTION LOOP; 00566000
PROCESSEXIT: 00566100
IF BOOLEAN(POLBUG) THEN % DUMP SP 00566200
IF MODE=XEQUTE OR MODE=3 OR MODE=6 THEN GO TO DEBUGSP; 00566300
IF FALSE THEN 00566400
BEGIN CASE 0 OF BEGIN 00566500
EXPOVRL: SPOUT(3951200); 00566600
INTOVRL: SPOUT(3591300); 00566700
INDEXL: SPOUT(3951400); 00566800
FLAGL: SPOUT(3951500); 00566900
ZEROL: SPOUT(3951600); 00567000
END; 00567100
REALLYERROR:=1; 00567200
DEBUGSP: 00567300
WRITE(PRINT,MIN(15,PSRSIZE),PSR); 00567400
BEGIN 00567500
STREAM PROCEDURE FORM(A,B,N); VALUE N; 00567600
BEGIN 00567700
DI:=B; 15(DS:=8LIT" "); 00567800
SI:=LOC N; DI:=B; DS:=8DEC; DI:=DI+3; 00567900
SI:=A; 10(DS:=8CHR; DI:=DI+1); 00568000
END; 00568100
M:=MIN(NROWS+1|SPRSIZE-1,MAXMEMACCESSES); 00568200
FOR N:=0 STEP 10 UNTIL M DO 00568300
BEGIN TRANSFERSP(OUTOF,SP,N,ACCUM,0,MIN(M-N,10)); 00568400
FORM(ACCUM,BUFFER,N); 00568500
WRITE(PRINT,15,BUFFER[*]); 00568600
END; 00568700
END; 00568800
IF POLBUG=0 OR BOOLEAN(REALLYERROR) THEN 00568900
BEGIN 00569000
ERRORMESS(IF ERR NEQ SPERROR THEN SYSTEMERROR ELSE ERR,0,0); 00569100
SUSPENSION:=0; 00569200
CURRENTMODE:=CALCMODE; 00569300
REALLYERROR:=ERR:=0; 00569400
END; 00569500
END; 00569600
END OF PROCESS PROCEDURE; 00569700
PROCEDURE ERRORMESS(N,ADDR,R); VALUE N,ADDR,R; REAL R; 00569800
INTEGER N; REAL ADDR; 00569900
BEGIN 00570000
INTEGER STREAM PROCEDURE FORM(A,B); VALUE A; 00570100
BEGIN LOCAL T,U; 00570200
LABEL L,M; 00570300
SI:=A; 00570400
L: IF SC=" " THEN 00570500
BEGIN SI:=SI+1; GO TO L; 00570600
END; 00570700
DI:=LOC T; DS:=2RESET; DS:=2SET; 00570800
DI:=B; MESSIZE(U:=DI; DI:=LOC T; IF SC=DC THEN JUMP OUT TO M; 00570900
SI:=SI-1; DI:=U; DS:=CHR; TALLY:=TALLY+1); M: 00571000
FORM:=TALLY; 00571100
END; 00571200
ARRAY ERMES[0:13],B[0:MESSIZE/8]; 00571300
FILL ERMES[*] WITH 00571400
"1 ", 00571500
"5DEPTH ", 00571600
"6DOMAIN ", 00571700
"7EDITING", 00571800
"5INDEX ", 00571900
"5LABEL ", 00572000
"6LENGTH ", 00572100
"5NONCE ", 00572200
"4RANK ", 00572300
"6SYNTAX ", 00572400
"6SYSTEM ", 00572500
"5VALUE ", 00572600
"7SP FULL", 00572700
"7FLYKITE"; 00572800
IF R NEQ 0 THEN 00572900
BEGIN INDENT(R);CHRCOUNT:=CHRCOUNT-1; 00573000
END; 00573100
FORMROW((IF R=0 THEN 2 ELSE 0),0,ERMES,N|8+1, 00573200
ERMES[N].[1:5]); 00573300
FORMWD(0,"6 ERROR"); 00573400
IF ADDR.[33:15] GEQ 512 THEN 00573500
BEGIN 00573600
FORMWD(0,"4 AT "); 00573700
FORMROW(1,1,B,0,FORM(ADDR,B)) 00573800
END; 00573900
FORMWD(3,"1 "); 00574000
END; 00574100
PROCEDURE LOADWORKSPACE(JOBNUM,NAME,IDENT); VALUE JOBNUM,NAME; 00574200
REAL JOBNUM,NAME; ARRAY IDENT[0]; FORWARD; 00574300
PROCEDURE LOGINAPLUSER; 00574400
BEGIN 00574500
COMMENT LOG:IN THE CURRENT USER; 00574600
COMMENT INPUT LINE IS IS THE BUFFER; 00574700
LABEL EXEC, GUESS; 00574800
DEFINE T=GT1#, J=GT2#,I=GT3#; 00574900
PROCEDURE INITIALIZEPSR; 00575000
BEGIN FOR I:=0 STEP 1 UNTIL PSRSIZE-1 DO 00575100
PSRM[I] := 0; 00575200
SEED:=STREAMBASE; ORIGIN:=1; 00575300
FUZZ:=1@-11; 00575400
LINESIZE:=72; DIGITS:=9; 00575500
END; 00575600
LADDRESS := ADDRESS := ABSOLUTEADDRESS; 00575700
WORKSPACE:=WORKSPACEUNIT; 00575800
ITEMCOUNT := EOB := 0; 00575900
IF NEXTUNIT=WORKSPACEUNIT THEN % ESTABLISH A WORKSPACE 00576000
BEGIN 00576100
WORKSPACE:=NEXTUNIT; 00576200
SEQUENTIAL(WORKSPACE); 00576300
INITIALIZEPSR; 00576400
I:=STORESEQ(WORKSPACE,PSR,PSRSIZE|8); 00576500
INITBUFF(OLDBUFFER,BUFFSIZE); 00576600
00576700
END ELSE % WORKSPACE ASSIGNED 00576800
I:=CONTENTS(WORKSPACE,0,PSR); 00576900
FILL ACCUM[*] WITH "LOGGED 1", "N "; 00577000
FORMROW(0,1,ACCUM,0,9); 00577100
I:=DAYTIME(ACCUM); 00577200
FORMROW(1,1,ACCUM,0,I); 00577300
SYMBASE:=STACKBASE:=0; 00577400
CSTATION.APLOGGED:=1; 00577500
CASE CURRENTMODE OF 00577600
BEGIN %--------CALCMODE-------------- 00577700
;COMMENT NOTHING TO DO ANYMORE; 00577800
%--------------XEQUTEMODE---------------------- 00577900
EXEC: 00578000
BEGIN FILL ACCUM[*] WITH "LAST RUN"," STOPPED"; 00578100
FORMROW(3,0,ACCUM,0,16); 00578200
CURRENTMODE:=CALCMODE; 00578300
END; 00578400
%-------------FUNCMODE----------------- 00578500
BEGIN FILL ACCUM[*]WITH "CONTINUE"," DEFINIT", 00578600
"ION OF "; 00578700
FORMROW(2,0,ACCUM,0,23); FORMROW(1,0,PSR, 00578800
FSTART|8,7); 00578900
CURLINE:=GT3:=TOPLINE(GT1:=FUNCPOINTER); 00579000
CHECKSEQ(CURLINE,GT3,INCREMENT); %GET INCREMENT 00579100
CURLINE:=CURLINE+INCREMENT; INDENT(-CURLINE); 00579200
FUNCSIZE:=SIZE(GT1); 00579300
END; 00579400
%------------INPUTMODE--------------ERRORMODE---- 00579500
GO TO EXEC; GO TO EXEC; 00579600
END; 00579700
GUESS: %SHOULD BE BETTER PLACE BUT HERE IS WHERE OTHERS COME OUT 00579800
STOREPSR; 00579900
IF CURRENTMODE NEQ FUNCMODE THEN 00580000
INDENT(0); TERPRINT; 00580100
VARSIZE:=IF VARIABLES=0 THEN 0 ELSE SIZE(VARIABLES); 00580200
END; 00580300
PROCEDURE APLMONITOR; 00580400
BEGIN 00580500
REAL T; 00580600
INTEGER I; 00580700
BOOLEAN WORK; 00580800
LABEL AROUND, NEWUSER; 00580900
LABEL CALCULATE,EXECUTEIT,FUNCTIONSTART,BACKAGAIN; 00581000
LABEL CALCULATEDIT; 00581100
I := CUSER := 1; 00581200
T := STATION; 00581300
BEGIN FILL ACCUM[*] WITH "APL/B550","0 UW COM" 00581400
,"PUTER SC","IENCE # ",VERSIONDATE; 00581500
WORK:=TRUE; 00581600
FORMROW(3,MARGINSIZE,ACCUM,0,40); 00581700
INDENT(0); TERPRINT; CSTATION.APLHEADING:=1 00581800
; LOGINAPLUSER; 00581900
END; 00582000
AROUND: 00582100
00582200
BEGIN 00582300
IF MAINTENANCE THEN; 00582400
CASE CURRENTMODE OF 00582500
BEGIN %-------CALCMODE-------------------------------- 00582600
COMMENT HE MUST BE READ READY FOR THE CALCMODE STUFF; 00582700
00582800
GO CALCULATE; 00582900
%--------XEQUTE MODE-------------------------------- 00583000
GO TO EXECUTEIT; 00583100
%----------FUNCMODE----------------------------------- 00583200
GO TO FUNCTIONSTART; 00583300
%-----------INPUTMODE--------------------------------- 00583400
COMMENT REQUIRES INPUT; 00583500
00583600
BEGIN COMMENT GET THE LINE AND GO BACK; 00583700
STARTSCAN; 00583800
CURRENTMODE:=XEQMODE; 00583900
GO TO EXECUTEIT; 00584000
END; 00584100
%----------ERRORMODE--------------------------------- 00584200
GO TO BACKAGAIN; 00584300
00584400
END; %OF CASES 00584500
END; 00584600
COMMENT GET HERE IF NOTHING TO DO; 00584700
00584800
GO TO AROUND; 00584900
CALCULATE: 00585000
STARTSCAN; 00585100
CALCULATEDIT: 00585200
ERR:=0; %AND DON"T RESET IT IN SCAN OR IN ANALYZE 00585300
IF SCAN THEN 00585400
IF RGTPAREN THEN MESSAGEHANDLER ELSE 00585500
IF DELV THEN FUNCTIONHANDLER ELSE 00585600
BEGIN COMMENT PROCESS CALCULATOR MODE REQUEST; 00585700
MOVE(BUFFER,BUFFERSIZE,OLDBUFFER); 00585800
IF NOT BOOLEAN(SUSPENSION) THEN BEGIN %INITIALIZE USER 00585900
%%% 00586000
%%% 00586100
SYMBASE:=STACKBASE:=0; 00586200
END; 00586300
PROCESS(XEQUTE); 00586400
IF CURRENTMODE=CALCMODE THEN 00586500
BACKAGAIN: BEGIN INDENT(0); TERPRINT; 00586600
IF NOT BOOLEAN(SUSPENSION) THEN 00586700
BEGIN IF CURRENTMODE NEQ ERRORMODE THEN 00586800
PROCESS(WRITEBACK); 00586900
SP[0,0]:=0;NROWS:=-1; 00587000
%%% 00587100
END; 00587200
CURRENTMODE:=CALCMODE; 00587300
END; 00587400
END; 00587500
IF EDITOG=1 THEN 00587600
BEGIN MOVE(OLDBUFFER,BUFFERSIZE,BUFFER); 00587700
RESCANLINE; EDITOG:=0; GO TO CALCULATEDIT; 00587800
END; 00587900
I:=0; 00588000
GO AROUND; 00588100
EXECUTEIT: 00588200
PROCESS(XEQUTE); %GO BACK TO PROCESS FOR AWHILE 00588300
IF CURRENTMODE=CALCMODE THEN GO TO BACKAGAIN; 00588400
I:=0; 00588500
GO AROUND; 00588600
FUNCTIONSTART: 00588700
IF SPECMODE = 0 THEN 00588800
BEGIN %SEE IF A SPECIAL FUNCTION. 00588900
STARTSCAN; 00589000
IF SCAN AND RGTPAREN THEN MESSAGEHANDLER ELSE 00589100
FUNCTIONHANDLER 00589200
END ELSE 00589300
FUNCTIONHANDLER; 00589400
I:=0; 00589500
GO AROUND 00589600
END; 00589700
INTEGER PROCEDURE LENGTH(A,M);VALUE M; BOOLEAN M; ARRAY A[0]; 00589800
BEGIN 00589900
INTEGER STREAM PROCEDURE LENGT(A,M,L); VALUE M,L; 00590000
BEGIN LOCAL T; 00590100
LOCAL C,CC,TSI; LABEL LAB; 00590200
LOCAL AR; LABEL LAB2; 00590300
SI:=LOC M; SI:=SI+7; 00590400
IF SC="1" THEN 00590500
BEGIN COMMENT LOOK FOR LEFT ARROW.; 00590600
DI:=LOC AR; DS:=RESET; DS:=5SET; 00590700
SI:=LOC L; DI:=LOC T; DI:=DI+1; DS:=7CHR; 00590800
SI:=A; 00590900
T(2(32(DI:=LOC AR; IF SC=DC THEN JUMP OUT 3 TO LAB; 00591000
TALLY:=TALLY+1; 00591100
C:=TALLY; TSI:=SI; SI:=LOC C; 00591200
SI:=SI+7; IF SC="0" THEN 00591300
BEGIN TALLY:=CC; TALLY:=TALLY+1; CC:=TALLY; 00591400
TALLY:=0; 00591500
END; SI:=TSI))); 00591600
L(DI:=LOC AR; IF SC=DC THEN JUMP OUT TO LAB; 00591700
TALLY:=TALLY+1; C:=TALLY; TSI:=SI; SI:=LOC C; SI:=SI+7; 00591800
IF SC="0" THEN 00591900
BEGIN TALLY:=CC; TALLY:=TALLY+1; CC:=TALLY; TALLY:=0; 00592000
END; SI:=TSI); 00592100
LAB: SI:=LOC CC; DI:=LOC LENGT; DI:=DI+6; SI:=SI+7; 00592200
DS:=CHR; SI:=LOC C; SI:=SI+7; DS:=CHR; 00592300
END ELSE 00592400
BEGIN 00592500
SI:=LOC L; DI:=LOC T; DI:=DI+1; DS:=7CHR; 00592600
SI:=A; T(2(SI:=SI+32)); SI:=SI+L; 00592700
T(2(32(SI:=SI-1; IF SC NEQ " " THEN JUMP OUT 3 TO LAB2; 00592800
TALLY:=TALLY+1; C:=TALLY; TSI:=SI; SI:=LOC C; SI:=SI+7; 00592900
IF SC="0" THEN 00593000
BEGIN TALLY:=CC; TALLY:=TALLY+1; CC:=TALLY; TALLY:=0 00593100
END; SI:=TSI))); 00593200
L(SI:=SI-1; IF SC NEQ" " THEN JUMP OUT TO LAB2; 00593300
TALLY:=TALLY+1; C:=TALLY; TSI:=SI; SI:=LOC C; SI:=SI+7; 00593400
IF SC="0" THEN 00593500
BEGIN TALLY:=CC; TALLY:=TALLY+1; CC:=TALLY; TALLY:=0 00593600
END; SI:=TSI); 00593700
LAB2: GO TO LAB 00593800
END 00593900
END; 00594000
INTEGER I; 00594100
I:=LENGT(A,M,BUFFSIZE|8); 00594200
LENGTH:=IF M THEN I ELSE BUFFSIZE|8-I 00594300
END; 00594400
BOOLEAN PROCEDURE LABELSCAN(L,K); VALUE K; INTEGER K; ARRAY L[0]; 00594500
BEGIN REAL T; 00594600
T:=ADDRESS; 00594700
IF SCAN AND IDENT THEN 00594800
BEGIN SETFIELD(ACCUM,1,1,0); TRANSFER(ACCUM,1,L,K|8,8); 00594900
IF NOT(LABELSCAN:=(SCAN AND COLON)) THEN 00595000
BEGIN ADDRESS:=T; EOB:=0; IF SCAN THEN; 00595100
END; 00595200
END 00595300
END; 00595400
STREAM PROCEDURE MOVEWDS(A,N,B); VALUE N; 00595500
BEGIN SI:=A; DI:=B; DS:=N WDS END; 00595600
INTEGER PROCEDURE DAYTIME(B); ARRAY B[0]; 00595700
BEGIN 00595800
00595900
INTEGER D,H,M,MIN,Q,P,Y,TIME1; 00596000
LABEL OWT; 00596100
STREAM PROCEDURE FORM(A,DAY,MO,DA,YR,HR,MIN,AP); 00596200
VALUE DAY,MO,DA,YR,HR,MIN,AP; 00596300
BEGIN DI:=A; 00596400
SI:=LOC DAY; SI:=SI+7; 00596500
IF SC="0" THEN DS:=3LIT"SUN" ELSE 00596600
IF SC="1" THEN DS:=3LIT"MON" ELSE 00596700
IF SC="2" THEN DS:=4LIT"TUES" ELSE 00596800
IF SC="3" THEN DS:=6LIT"WEDNES" ELSE 00596900
IF SC="4" THEN DS:=5LIT"THURS" ELSE 00597000
IF SC="5" THEN DS:=3LIT"FRI" ELSE DS:=5LIT"SATUR"; 00597100
DS:=4LIT"DAY "; SI:=LOC MO; DS:=2DEC; 00597200
DS:=LIT"-"; SI:=LOC DA; DS:=2DEC; DS:=LIT"-"; 00597300
SI:=LOC YR; DS:=2DEC; DS:=2LIT" "; 00597400
SI:=LOC HR; DS:=2DEC; DS:=LIT":"; SI:=LOC MIN; 00597500
SI:=SI+6; DS:=2CHR; SI:=LOC AP; SI:=SI+7; DS:=LIT" "; 00597600
DS:=CHR; DS:=LIT"M" 00597700
END; 00597800
TIME1:=TIME(1); 00597900
Y:=TIME(0); 00598000
D:=Y.[30:1]|100+Y.[36:6]|10+Y.[42:6]; 00598100
Y:=Y.[18:6]|10+Y.[24:6]; 00598200
FOR H:=31,IF Y MOD 4=0 THEN 29 ELSE 28,31,30, 00598300
31,30,31,31,30,31,30 DO 00598400
IF D LEQ H THEN GO OWT ELSE 00598500
BEGIN D:=D-H; M:=M+1; 00598600
END; 00598700
OWT: 00598800
H:=TIME1 DIV 216000; 00598900
MIN:=(TIME1 DIV 3600) MOD 60; 00599000
IF M LSS 2 THEN 00599100
BEGIN Q:=M+11; P:=Y-1; 00599200
END ELSE 00599300
BEGIN Q:=M-1; P:=Y 00599400
END; 00599500
M:=M+1; 00599600
FORM(B,TIME1:=((Q|26-2)DIV 10+D+P+P.[36:10]+1)MOD 7, 00599700
M,D,Y,Q:= H MOD 12, Q:=MIN MOD 10+(MIN DIV 10)|64, 00599800
IF H GEQ 12 THEN "P" ELSE 17); 00599900
DAYTIME:=(IF TIME1=6 THEN 5 ELSE 00600000
IF TIME1=5 THEN 3 ELSE 00600100
IF TIME1=2 THEN 4 ELSE 3)+22; 00600200
00600300
00600400
END; 00600500
PROCEDURE LOADWORKSPACE(NAME1,NAME2,IDENT); VALUE NAME1,NAME2; 00600600
REAL NAME1,NAME2; ARRAY IDENT[0]; 00600700
BEGIN 00600800
FILE DISK DISK(2,WDSPERREC,WDSPERBLK); 00600900
INTEGER PROCEDURE RD(D,N,A); 00601000
VALUE N; INTEGER N; FILE D; ARRAY A[0]; 00601100
BEGIN READ(D[N],WDSPERREC,A[*]); 00601200
RD:=N+1; 00601300
END; 00601400
PROCEDURE LOADITEM(RD,D,ITEM); 00601500
INTEGER PROCEDURE RD; FILE D; 00601600
ARRAY ITEM[0]; 00601700
BEGIN 00601800
DEFINE T=ITEM#; 00601900
PROCEDURE GETALINE(C,S,L,B,RD,D,LEN); 00602000
VALUE LEN; INTEGER C,S,L,LEN; 00602100
ARRAY B[0]; INTEGER PROCEDURE RD; FILE D; 00602200
BEGIN % GET 2 CHRS GIVING ENSUING CHAR COUNT 00602300
INTEGER P; 00602400
IF C GTR LEN-2 THEN 00602500
IF C GTR LEN-1 THEN % READ A NEW RECORD AND TAKE 2 CHRS 00602600
BEGIN 00602700
S:=RD(D,S,B); 00602800
C:=2; 00602900
TRANSFER(B,0,L,6,2); 00603000
END 00603100
ELSE % 1 CHR LEFT ON LINE 00603200
BEGIN 00603300
TRANSFER(B,C,L,6,1); 00603400
S:=RD(D,S,B); 00603500
TRANSFER(B,0,L,7,1); 00603600
C:=1; 00603700
END 00603800
ELSE % AT LEAST 2 CHARS REMAINING ON LINE 00603900
BEGIN 00604000
TRANSFER(B,C,L,6,2); 00604100
C:=C+2; 00604200
END; 00604300
P:=0; 00604400
IF L NEQ 0 THEN % SOMETHING LEFT IN FUNCTION 00604500
BEGIN 00604600
WHILE P LSS L DO 00604700
IF (L-P) GTR (LEN-C) THEN % # OF CHARS IN LINE 00604800
% EXTENDS INTO NEXT RECORD 00604900
BEGIN 00605000
TRANSFER(B,C,BUFFER,P,LEN-C); % FINISH OUT RECORD 00605100
S:=RD(D,S,B); 00605200
P:=P+(LEN-C); % AMOUNT READ SO FAR 00605300
C:=0; 00605400
END 00605500
ELSE % ALL ON ONE RECORD 00605600
BEGIN 00605700
TRANSFER(B,C,BUFFER,P,L-P); 00605800
C:=C+L-P; 00605900
P:=L; % FINISHED 00606000
END; 00606100
END; 00606200
END OF GETALINE; 00606300
INTEGER S,K,L,M,C,LEN,SQ,PT,G,I,SIZE; 00606400
INTEGER HOLD; 00606500
LABEL SCALARL; 00606600
ARRAY U[0:1],B[0:WDSPERREC-1]; 00606700
BOOLEAN TOG; 00606800
TRANSFER(T,0,U,0,7); 00606900
G:=GETFIELD(T,7,1); 00607000
IF VARSIZE GTR 0 THEN 00607100
IF K:=SEARCHORD(VARIABLES,U,HOLD,7)=0 THEN 00607200
IF K:=GETFIELD(U,7,1)=FUNCTION THEN TOG:=TRUE 00607300
ELSE % NOT A FUNCTION IN THE SYMBOL TABLE 00607400
IF G=FUNCTION THEN 00607500
BEGIN 00607600
DELETE1(VARIABLES,HOLD); 00607700
IF K=ARRAYDATA THEN RELEASEARRAY(U[1]); 00607800
END 00607900
ELSE TOG:=TRUE % DON-T CHANGE 00608000
ELSE % NOT IN VARIABLES 00608100
BEGIN 00608200
VARSIZE:=VARSIZE+1; 00608300
HOLD:=HOLD+K-1; 00608400
END 00608500
ELSE VARSIZE:=1; 00608600
LEN:=(WDSPERREC-1)|8; 00608700
IF NOT TOG THEN % OK TO PUT INTO VARIABLES 00608800
IF G=FUNCTION THEN % READ A FUNCTION INTO VARIABLES 00608900
BEGIN 00609000
TRANSFER(T,0,U,0,9); % U HOLDS FUNCTION NAME, 00609100
%NUMBER OF ARGUMENTS, AND WHETHER FN RETURNS A VALUE 00609200
S:=T[1].LIBF1; % RECORD NUMBER 00609300
M:=T[1].LIBF2; % WORD WITHIN RECORD 00609400
SIZE:=T[1].LIBF3; % SIZE OF POINTERS TABLE 00609500
PT:=NEXTUNIT; 00609600
S:=RD(D,S,B); 00609700
FOR I:=0 STEP 1 UNTIL SIZE-1 DO 00609800
BEGIN 00609900
TRANSFER(M,M|8,T,0,16); 00610000
M:=M+2; 00610100
IF M GEQ WDSPERREC-1 THEN 00610200
BEGIN 00610300
S:=RD(D,S,B); 00610400
IF M GEQ WDSPERREC THEN 00610500
BEGIN 00610600
TRANSFER(B,0,T,8,8); 00610700
M:=1; 00610800
END 00610900
ELSE M:=0; 00611000
END; 00611100
STOREORD(PT,T,I); 00611200
END; % HAVE FINISHED FILLIN G POINTERS TABLE 00611300
IF VARIABLES=0 THEN BEGIN 00611400
VARIABLES:=NEXTUNIT; TOG:=TRUE; %KEEP THE UNIT OPEN 00611500
STOREORD(VARIABLES,U,HOLD); END; 00611600
SEQUENTIAL (SQ:=NEXTUNIT); 00611700
SETFIELD(U,FPTF,FFL,PT); 00611800
SETFIELD(U,FSQF,FFL,SQ); 00611900
STOREORD(VARIABLES,U,HOLD); 00612000
IF TOG THEN DELETE1(VARIABLES,HOLD+1);%REMOVE 1 EXTRA 00612100
COMMENT NOW FILL IN SEQ STORAGE; 00612200
IF M NEQ 0 THEN BEGIN 00612300
M:=C:=0; 00612400
S:=RD(D,S,B); % TEXT STARTS AT BEG. OF NEW RECORD 00612500
END; 00612600
L:=1; 00612700
00612800
WHILE L NEQ 0 DO 00612900
BEGIN 00613000
GETALINE(C,S,L,B,RD,D,LEN); 00613100
GT1:=STORESEQ(SQ,BUFFER,L); 00613200
END 00613300
END 00613400
ELSE 00613500
IF G=ARRAYDATA THEN 00613600
IF T[1].INPTR=0 THEN % NULL VECTOR 00613700
GO TO SCALARL 00613800
ELSE 00613900
BEGIN 00614000
ARRAY DIMVECT[0:MAXBUFFSIZE]; 00614100
S:=T[1].INPTR; % RECORD NUMBER 00614200
M:=T[1].DIMPTR; % LOC WITHIN RECORD 00614300
C:=M|8; 00614400
SIZE:=T[1].RF; % RANK 00614500
S:=RD(D,S,B); 00614600
GETALINE(C,S,L,B,RD,D,LEN); 00614700
T[1].DIMPTR:=STORESEQ(WS,BUFFER,L); 00614800
% PUTS DIMVECT INTO WORKSPACE 00614900
GETALINE(C,S,L,B,RD,D,LEN); % # BLOCKS 00615000
SIZE:=L-1; 00615100
FOR K:=0 STEP 2 UNTIL SIZE DO 00615200
BEGIN 00615300
GETALINE(C,S,L,B,RD,D,LEN); 00615400
SETFIELD(DIMVECT,K,2,STORESEQ(WS,BUFFER,L)); 00615500
END; COMMENT THIS STORES THE VALUES OF THE 00615600
ARRAY INTO THE WORKSPACE, AND ALSO RECORDS 00615700
THE LOCATION WITHIN WS IN DIMVECT,TO BE STORED;00615800
T[1].INPTR:=STORESEQ(WS,DIMVECT,SIZE+1); 00615900
IF VARIABLES=0 THEN VARIABLES:=NEXTUNIT; 00616000
STOREORD(VARIABLES,T,HOLD); 00616100
END 00616200
ELSE % MUST BE A SCALAR 00616300
SCALARL: 00616400
BEGIN 00616500
IF VARIABLES=0 THEN VARIABLES:=NEXTUNIT; 00616600
STOREORD(VARIABLES,T,HOLD); 00616700
END 00616800
ELSE % WILL NOT REPLACE IN SYMBOL TABLE 00616900
BEGIN 00617000
FILL BUFFER[*] WITH " ","NOT REPL","ACED "; 00617100
TRANSFER(T,0,BUFFER,0,7); 00617200
FORMROW(3,0,BUFFER,0,20); 00617300
END; 00617400
END LOADITEM; 00617500
BOOLEAN STREAM PROCEDURE EQUAL(A,B); 00617600
BEGIN SI:=A; DI:=B; SI:=SI+2; IF 7SC=DC THEN TALLY:=1; 00617700
EQUAL:=TALLY 00617800
END; 00617900
INTEGER I,J,L,NDIR,N; 00618000
LABEL MOVEVAR,SKIP; 00618100
ARRAY T,U[0:1],D[0:WDSPERREC-1]; 00618200
FILL DISK WITH NAME1,NAME2; L:=RD(DISK,L,D); 00618300
IF D[1] NEQ JOBNUM AND D[1] NEQ 0 THEN GO SKIP; % FILE LOCKED 00618400
FOR I:=2 STEP 1 UNTIL 9 DO IF GETFIELD(D[I],1,7) NEQ 0 THEN GO SKIP;00618500
IF NDIR:=D[0] NEQ 0 THEN 00618600
BEGIN N:=LIBSPACES+ENTIER(NDIR|2/(J:=WDSPERREC-1)); 00618700
IF(NDIR|2) MOD J NEQ 0 THEN N:=N+1; 00618800
FOR I:=1 STEP 1 UNTIL NDIR DO 00618900
BEGIN COMMENT GET FUNCTION OR VARIABLE NAME FROM LIB; 00619000
IF WDSPERREC-J LSS 3 THEN 00619100
IF WDSPERREC-J=1 THEN 00619200
BEGIN L:=RD(DISK,L,D); J:=0; GO MOVEVAR 00619300
END ELSE 00619400
BEGIN TRANSFER(D,J|8,T,0,8); L:=RD(DISK,L,D); 00619500
TRANSFER(D,0,T,8,8); J:=1 00619600
END ELSE MOVEVAR: 00619700
BEGIN TRANSFER(D,J|8,T,0,16); J:=J+2 00619800
END; 00619900
IF(IF IDENT[0]=0 THEN TRUE ELSE EQUAL(IDENT,T)) THEN 00620000
BEGIN IF IDENT[0] NEQ 0 THEN I:=NDIR+1; 00620100
LOADITEM(RD,DISK,T); 00620200
END 00620300
END; 00620400
STOREPSR; % UPDATE SINCE HAVE ADDED TO VARIABLES 00620500
END; 00620600
IF FALSE THEN SKIP: FORMWD(1,"6BADFIL"); 00620700
EOB:=1; 00620800
END OF LIBRARY LOAD; 00620900
PROCEDURE PURGEWORKSPACE(WS); VALUE WS; INTEGER WS; 00621000
IF WORKSPACE NEQ 0 THEN 00621100
BEGIN 00621200
INTEGER I,J,K,V,L,G; 00621300
ARRAY T[0:1]; 00621400
J:=SIZE(V:=VARIABLES)-1; 00621500
FOR I:=0 STEP 1 UNTIL J DO 00621600
BEGIN K:=CONTENTS(V,I,T); 00621700
IF GETFIELD(T,7,1)=FUNCTION THEN 00621800
FOR L:=FPTF,FSQF DO % GET RID OF STORAGE 00621900
IF G:=GETFIELD(T,L,FFL) NEQ 0 THEN RELEASEUNIT(G); 00622000
END; 00622100
RELEASEUNIT(V); 00622200
VARIABLES:=0; VARSIZE:=0; 00622300
CURRENTMODE:=0; J:=SIZE(WS)-1; 00622400
FOR I:=1 STEP 1 UNTIL J DO DELETE1(WS,I); 00622500
STOREPSR; 00622600
END; 00622700
PROCEDURE ELIMWORKSPACE(WS); VALUE WS; INTEGER WS; 00622800
BEGIN LABEL QQQ; QQQ: 00622900
IF WORKSPACE NEQ 0 THEN 00623000
BEGIN 00623100
PURGEWORKSPACE(WS); RELEASEUNIT(WS); 00623200
% 00623300
END ELSE SPOUT(8015222); 00623400
END; 00623500
PROCEDURE SAVEWORKSPACE(NAME1,NAME2,LOCKFILE); 00623600
VALUE NAME1,NAME2,LOCKFILE; 00623700
REAL NAME1,NAME2,LOCKFILE; 00623800
BEGIN 00623900
SAVE FILE DISK DISK [NAREAS:SIZEAREAS] 00624000
(2,WDSPERREC,WDSPERBLK,SAVE 100); 00624100
INTEGER PROCEDURE WR(D,N,A); VALUE N; INTEGER N; 00624200
FILE D; ARRAY A[0]; 00624300
BEGIN REAL STREAM PROCEDURE CON(A); VALUE A; 00624400
BEGIN SI:=LOC A; DI:=LOC CON; DS:=8DEC END; 00624500
STREAM PROCEDURE CLEANER(A); 00624600
BEGIN DI:=A; WDSPERREC(DS:=8LIT".") END; 00624700
A[WDSPERREC-1]:=CON(N); 00624800
WRITE(D[N],WDSPERREC,A[*]); 00624900
WR:=N+1; CLEANER(A); 00625000
END; 00625100
PROCEDURE PUTAWAY(C,J,WR,D,N,M,B,L); VALUE L,J; 00625200
INTEGER L,C,J,N,M; 00625300
ARRAY B[0]; INTEGER PROCEDURE WR; FILE D; 00625400
BEGIN INTEGER P,K; 00625500
IF C+2 GTR L THEN 00625600
BEGIN TRANSFER(J,6,B,C,1); N:=WR(D,N,B); C:=1; 00625700
TRANSFER(J,7,B,0,1); 00625800
END ELSE 00625900
BEGIN TRANSFER(J,6,B,C,2); C:=C+2; 00626000
END; 00626100
WHILE J NEQ 0 DO 00626200
IF J GTR K:=(L-C) THEN 00626300
BEGIN TRANSFER(BUFFER,P,B,C,K); 00626400
N:=WR(D,N,B); J:=J-K; C:=0; P:=P+K 00626500
END ELSE 00626600
BEGIN TRANSFER(BUFFER,P,B,C,J); C:=C+J; J:=0 00626700
END; 00626800
IF C=L THEN 00626900
BEGIN N:=WR(D,N,B); C:=0 00627000
END; 00627100
END; 00627200
00627300
PROCEDURE MOVETWO(U,B,M,WR,L,D); 00627400
ARRAY U,B[0]; INTEGER M,L; INTEGER PROCEDURE WR; FILE D; 00627500
BEGIN 00627600
COMMENT PUTS 2 WORDS OF U IN B AND WRITES ON D IF A FULLRECORD;00627700
TRANSFER(U,0,B,M|8,16); % CONTENTS OF U INTO B 00627800
M:=M+2; 00627900
IF M GEQ WDSPERREC-1 THEN % FULL RECORD 00628000
BEGIN 00628100
L:=WR(D,L,B); 00628200
IF M GEQ WDSPERREC THEN % 1 OVER FULL RECORD 00628300
00628400
BEGIN 00628500
TRANSFER(U,8,B,0,8); 00628600
M:=1; 00628700
END 00628800
ELSE M:=0; 00628900
END; 00629000
END OF MOVETWO; 00629100
INTEGER H,Q,M,N,I,L,S,J,K,LINE,MAX,PT,SQ,C,LEN,W; 00629200
REAL LSD,STP; 00629300
LABEL SKIP; 00629400
ARRAY T,U[0:1],DIR,B,SEX[0:WDSPERREC]; 00629500
N:=LIBSPACES+ENTIER((S:=SIZE(VARIABLES))|2/(WDSPERREC-1)); 00629600
IF (S|2) MOD (WDSPERREC-1) NEQ 0 THEN N:=N+1; % ADJUST 00629700
LEN:=(WDSPERREC-1)|8; 00629800
FILL DISK WITH NAME1,NAME2; 00629900
DIR[0]:=S; % SIZE OF SYMBOL TABLE 00630000
IF BOOLEAN (LOCKFILE) THEN DIR[1]:=JOBNUM; 00630100
S:=S-1; 00630200
L:=WR(DISK,L,DIR); % FIRST LINE CONTAINS # OF ENTRIES IN 00630300
COMMENT SYMBOL TABLE AND LOCK INFORMATION; 00630400
FOR I:=0 STEP 1 UNTIL S DO 00630500
BEGIN 00630600
J:=CONTENTS(VARIABLES,I,T); % RETURNS VALUE OF I-TH LOC 00630700
% IN VARIABLES INTO T 00630800
IF GT2:=GETFIELD(T,7,1)=FUNCTION THEN 00630900
BEGIN 00631000
PT:=GETFIELD(T,FPTF,FFL); % FUNCTION POINTER FIELD 00631100
SQ:=GETFIELD(T,FSQF,FFL); % FUNCTION SEQUENTIAL FIELD 00631200
%PT=# OF ORDERED STORAGE UNIT CONTAINING HEADER&POINTE 00631300
%SQ=# OF SEQ STORAGE UNIT CPONTAINING TEXT 00631400
MAX:=SIZE(PT); 00631500
T[1].LIBF1:=N; % RECORD # 00631600
T[1].LIBF2:=M; % LOC WITHIN RECORD 00631700
T[1].LIBF3:=MAX; % SIZE OF POINTERS TABLE; 00631800
% SAVE ENOUGH ROOM FOR THE ENTIRE POINTERS TABLE 00631900
H:=ENTIER(GT1:=(M+MAX|2)/(WDSPERREC-1)); 00632000
H:=IF GT1 NEQ H THEN H+N+1 ELSE H+N; 00632100
U[0]:=0; 00632200
J:=SEARCHORD(PT,U,LINE,8); % LOOK FOR ALL ZEROS 00632300
IF J=2 THEN GO SKIP; 00632400
FOR W:=0 STEP 1 UNTIL LINE-1 DO 00632500
%MOVE LOCALS AND LABELS INTO THE SAVE FILE 00632600
BEGIN 00632700
J:=CONTENTS(PT,W,U); 00632800
MOVETWO(U,B,M,WR,N,DISK); 00632900
END; 00633000
FOR LINE:=LINE STEP 1 UNTIL MAX-1 DO 00633100
BEGIN 00633200
00633300
J:=CONTENTS(PT,LINE,U); 00633400
GT1:=U[1]; 00633500
U[1]:=LINE-W; 00633600
MOVETWO(U,B,M,WR,N,DISK); % POINTERS TABLE 00633700
J:=CONTENTS(SQ,GT1,BUFFER); 00633800
PUTAWAY(C,J,WR,DISK,H,Q,SEX,LEN); % TEXT 00633900
END; 00634000
PUTAWAY(C,0,WR,DISK,H,Q,SEX,LEN); 00634100
SKIP: 00634200
Q:=C DIV 8; 00634300
IF C MOD 8 NEQ 0 THEN Q:=Q+1; 00634400
IF Q=WDSPERREC-1 THEN 00634500
BEGIN 00634600
H:=WR(DISK,H,SEX); 00634700
Q:=0; 00634800
END; 00634900
IF M GTR 0 THEN N:=WR(DISK,N,B); 00635000
M:=Q; N:=H; 00635100
TRANSFER(SEX,0,B,0,C); % MOVE BACK TO B 00635200
C:=0; 00635300
END 00635400
ELSE 00635500
IF GT2=ARRAYDATA THEN 00635600
BEGIN 00635700
ARRAY DIMVECT[0:MAXBUFFSIZE]; 00635800
LSD:=T[1]; 00635900
IF H:=LSD.SPF=0 THEN % NULL VECTOR 00636000
ELSE 00636100
BEGIN 00636200
T[1].INPTR:=N; T[1].DIMPTR:=M; 00636300
C:=M|8; 00636400
J:=CONTENTS(WS,LSD.DIMPTR,BUFFER); % DIM VECT 00636500
PUTAWAY(C,J,WR,DISK,N,M,B,LEN); % STD DIM VECT 00636600
J:=CONTENTS(WS,LSD.INPTR,DIMVECT); 00636700
TRANSFER(DIMVECT,0,BUFFER,0,J); 00636800
PUTAWAY(C,J,WR,DISK,N,M,B,LEN); 00636900
J:=J-1; 00637000
FOR LINE:=0 STEP 2 UNTIL J DO 00637100
BEGIN 00637200
PT:=GETFIELD(DIMVECT,LINE,2); 00637300
STP:=CONTENTS(WS,PT,BUFFER); 00637400
PUTAWAY(C,STP,WR,DISK,N,M,B,LEN); 00637500
END; 00637600
M:=C DIV 8; IF C MOD 8 NEQ 0 THEN M:=M+1; C:=0; 00637700
IF M=WDSPERREC-1 THEN BEGIN N:=WR(DISK,N,B); 00637800
M:=0; END; 00637900
END; 00638000
END; 00638100
MOVETWO(T,DIR,K,WR,L,DISK); 00638200
END; 00638300
00638400
EOB:=1; 00638500
IF M GTR 0 THEN N:=WR(DISK,N,B); 00638600
IF K GTR 0 THEN L:=WR(DISK,L,DIR); 00638700
LOCK(DISK); 00638800
END; 00638900
BOOLEAN PROCEDURE LIBNAMES(A,B); REAL A,B; 00639000
BEGIN REAL T; 00639100
A:=B:=GT1:=0; 00639200
% 00639300
% 00639400
IF SCAN AND IDENT THEN 00639500
BEGIN T~ACCUM[0]; T.[6:6]~"/"; 00639600
IF SCAN AND LOCKIT THEN GT1~1 ELSE IF IDENT THEN LIBNAMES~TRUE; 00639700
A~T; B~ JOBNUM; 00639800
END 00639900
ELSE LIBNAMES~ TRUE; 00640000
END; 00640100
PROCEDURE MESSAGEHANDLER; 00640200
BEGIN 00640300
LABEL ERR1; 00640400
% 00640500
IF SCAN THEN IF IDENT THEN 00640600
BEGIN INTEGER I; REAL R,S; 00640700
PROCEDURE NOFILEPRESENT; 00640800
BEGIN 00640900
FILL BUFFER[*] WITH "FILE NOT"," ON DISK"; 00641000
FORMROW(3,0,BUFFER,0,16); 00641100
END OF NOFILEPRESENT; 00641200
PROCEDURE PRINTID(VARS); VALUE VARS; BOOLEAN VARS; 00641300
BEGIN INTEGER I,J,K,L,M; ARRAY T[0:1]; BOOLEAN TOG; 00641400
INTEGER NUM; 00641500
J:=VARSIZE-1; M:=VARIABLES; 00641600
FOR I:=0 STEP 1 UNTIL J DO 00641700
BEGIN L:=CONTENTS(M,I,T); TOG:=GETFIELD(T,7,1) 00641800
=FUNCTION; 00641900
IF NUM:=3|REAL(TOG AND VARS)+8+NUM GTR LINESIZE 00642000
THEN BEGIN TERPRINT; NUM:=3|REAL(TOG AND VARS)+8 END; 00642100
IF VARS THEN 00642200
BEGIN FORMROW(0,1,T,0,7); L:=L+1; 00642300
IF TOG THEN FORMWD(0,"3(F) "); 00642400
END ELSE 00642500
IF TOG THEN BEGIN L:=L+1; FORMROW(0,1,T,0,7) END; 00642600
END; 00642700
IF L=0 THEN FORMWD(3,"6 NULL.") ELSE TERPRINT 00642800
END; 00642900
R:=ACCUM[0]; 00643000
FOR I:=0 STEP 1 UNTIL MAXMESS DO 00643100
IF R=MESSTAB[I] THEN 00643200
BEGIN R:=I; I:=MAXMESS+1 00643300
END; 00643400
IF I=MAXMESS+2 THEN 00643500
CASE R OF 00643600
BEGIN 00643700
% ------- SAVE ------- 00643800
IF NOT LIBNAMES(R,S) THEN 00643900
IF NOT LIBRARIAN(R,S) THEN BEGIN 00644000
SAVEWORKSPACE(R,S,GT1); %GT1 SET IN LIBNAMES 00644100
GTA[0]~GTA[1]~0;TRANSFER(R,1,GTA,1,7); 00644200
IF(GT1~SEARCHORD(LIBRARY,GTA, I, 7)) NEQ 0 THEN 00644300
BEGIN GTA[0]~GTA[1]~0;TRANSFER(R,1,GTA,1,7); 00644400
STOREORD(LIBRARY,GTA,I+(IF GT1=1 THEN -1 ELSE 1));00644500
END; LIBSIZE~LIBSIZE+1; 00644600
END 00644700
ELSE 00644800
BEGIN 00644900
FILL BUFFER[*] WITH "FILE ALR","EADY ON ", 00645000
"DISK "; 00645100
FORMROW(3,0,BUFFER,0,20); 00645200
END 00645300
ELSE GO ERR1; 00645400
% ------- LOAD ------- 00645500
IF NOT LIBNAMES(R,S) AND R NEQ 0 THEN 00645600
IF LIBRARIAN(R,S) THEN 00645700
BEGIN ARRAY A[0:1]; 00645800
LOADWORKSPACE(R,S,A); 00645900
END 00646000
ELSE NOFILEPRESENT 00646100
ELSE GO ERR1; 00646200
% ------- DROP ------- 00646300
IF CURRENTMODE=CALCMODE THEN 00646400
IF NOT LIBNAMES(R,S) THEN 00646500
IF LIBRARIAN(R,S) THEN 00646600
BEGIN FILE ELIF DISK (1,1); 00646700
FILL ELIF WITH R,S; WRITE(ELIF[0]); 00646800
CLOSE(ELIF,PURGE) 00646900
;GTA[0]~GTA[1]~0;TRANSFER(R,1,GTA,1,7); 00647000
IF SEARCHORD(LIBRARY,GTA,I,7)=0 THEN DELETE1(LIBRARY,I); 00647100
LIBSIZE~LIBSIZE-1; 00647200
END 00647300
ELSE NOFILEPRESENT 00647400
ELSE 00647500
IF NOT BOOLEAN(SUSPENSION)THEN PURGEWORKSPACE(WORKSPACE) 00647600
ELSE GO ERR1 ELSE GO ERR1; 00647700
% ------- COPY ------- 00647800
IF LIBNAMES(R,S) THEN 00647900
IF LIBRARIAN(R,S) THEN 00648000
LOADWORKSPACE(R,S,ACCUM) 00648100
ELSE NOFILEPRESENT 00648200
ELSE GO ERR1; 00648300
00648400
% -------- VARS ------- 00648500
PRINTID(TRUE); 00648600
00648700
%------- FNS ------- 00648800
PRINTID(FALSE); 00648900
%-------- LOGGED ---------------- 00649000
; 00649100
%-------- MSG -------- 00649200
ERRORMESS(SYNTAXERROR,LADDRESS,0); 00649300
%-----WIDTH (INTEGER) --------------------------- 00649400
IF NOT SCAN THEN BEGIN NUMBERCON(LINESIZE, ACCUM); 00649500
FORMROW(3,0,ACCUM,2,ACOUNT); END 00649600
ELSE IF NUMERIC AND I:=ACCUM[0] GTR 9 AND I LEQ 72 00649700
THEN BEGIN TERPRINT; LINESIZE:=I; STOREPSR; 00649800
END 00649900
%IF A NUMBER CONVERSION ERROR, RESULT WILL BE ZERO 00650000
%AND WE"LL GET AN ERROR ANYWAY 00650100
ELSE GO TO ERR1; 00650200
%-------- OPR -------- 00650300
; 00650400
%------DIGITS (INTEGER) ------------------------ 00650500
IF NOT SCAN THEN BEGIN NUMBERCON(DIGITS,ACCUM); 00650600
FORMROW(3,0,ACCUM,2,ACOUNT); END 00650700
ELSE IF NUMERIC AND I:=ACCUM[0] GEQ 0 AND I LEQ 12 00650800
AND ERR=0 THEN BEGIN DIGITS:=I; STOREPSR END 00650900
ELSE GO TO ERR1; 00651000
%-------- OFF -------- 00651100
BEGIN 00651200
IF SCAN THEN IF ACCUM[0]="7DISCAR" THEN 00651300
ELIMWORKSPACE(WORKSPACE) ELSE 00651400
GO TO ERR1; 00651500
FILL ACCUM[*] WITH "END OF R","UN "; 00651600
FORMROW(3,MARGINSIZE,ACCUM,0,10); 00651700
CURRENTMODE:=CALCMODE; 00651800
GT1:=CSTATION; 00651900
CSTATION:=GT1&0[CAPLOGGED] 00652000
;GO TO FINIS; 00652100
END; 00652200
%--------ORIGIN---------------------------------- 00652300
IF NOT SCAN THEN BEGIN NUMBERCON(ORIGIN,ACCUM); 00652400
FORMROW(3,0,ACCUM,2,ACOUNT) END 00652500
ELSE IF NUMERIC AND ERR=0 THEN BEGIN ORIGIN:= 00652600
I:=ACCUM[0]; STOREPSR END ELSE GO TO ERR1; 00652700
%--------SEED--------------------------------- 00652800
IF NOT SCAN THEN BEGIN NUMBERCON(SEED,ACCUM); 00652900
FORMROW(3,0,ACCUM,2,ACOUNT) END 00653000
ELSE IF NUMERIC AND ERR=0 THEN BEGIN 00653100
SEED:=ABS(I:=ACCUM[0]); 00653200
STOREPSR END ELSE GO TO ERR1; 00653300
%--------FUZZ------------------------------------ 00653400
IF NOT SCAN THEN BEGIN 00653500
NUMBERCON(FUZZ,ACCUM); 00653600
FORMROW(3,0,ACCUM,2,ACOUNT) END 00653700
ELSE IF NUMERIC AND ERR=0 THEN BEGIN FUZZ:=ABS(ACCUM[0]); 00653800
STOREPSR END ELSE GO TO ERR1; 00653900
%------- SYN, NOSYN------------------------------------- 00654000
NOSYNTAX:=0; NOSYNTAX:=1; 00654100
%-----------------STORE------------------------- 00654200
IF SYMBASE NEQ 0 THEN PROCESS(WRITEBACK); 00654300
00654400
00654500
%-----------------ABORT------------------------- 00654600
BEGIN IF BOOLEAN(SUSPENSION) THEN 00654700
SP[0,0]:=0; NROWS:=-1; 00654800
%%% 00654900
SUSPENSION:=0; 00655000
STOREPSR; 00655100
END; 00655200
%-----------------SI--------------------------------- 00655300
IF BOOLEAN(SUSPENSION) THEN 00655400
BEGIN GT1:=0; 00655500
PROCESS(LOOKATSTACK); 00655600
END ELSE FORMWD(3,"6 NULL."); 00655700
%------------------SIV------------------------------ 00655800
IF BOOLEAN(SUSPENSION) THEN 00655900
BEGIN GT1:=1; 00656000
PROCESS(LOOKATSTACK); 00656100
END ELSE FORMWD(3,"6 NULL."); 00656200
%------------------ERASE------------------------------ 00656300
IF CURRENTMODE=FUNCMODE OR BOOLEAN(SUSPENSION) THEN GO TO ERR1 00656400
ELSE WHILE SCAN AND IDENT DO 00656500
BEGIN % LOOK FOR THE INDENTIFIER NAME IN ACCUM 00656600
TRANSFER(ACCUM,2,GTA,0,7); 00656700
IF (IF VARIABLES=0 THEN FALSE ELSE 00656800
SEARCHORD(VARIABLES,GTA,GT1,7)=0) THEN 00656900
BEGIN % FOUND A SYMBOL TABLE ENTRY MATCHING NAME 00657000
DELETE1(VARIABLES,GT1); % REMOVE FROM SYMBOLTABLE 00657100
IF VARSIZE:=VARSIZE-1=0 THEN VARIABLES:=0; 00657200
COMMENT IF NOTHING IS IN THE UNIT IT IS DELETED; 00657300
00657400
% CHECK IF THERE IS MORE TO DELETE 00657500
IF GT1:=GETFIELD(GTA,7,1)=FUNCTION THEN 00657600
BEGIN 00657700
RELEASEUNIT(GETFIELD(GTA,FPTF,FFL)); 00657800
RELEASEUNIT(GETFIELD(GTA,FSQF,FFL)); 00657900
END 00658000
ELSE IF GT1 GTR 0 THEN % MUST BE AN ARRAY 00658100
RELEASEARRAY(GTA[1]); 00658200
END ELSE % THERE IS NO SUCH VARIABLE 00658300
ERRORMESS(LABELERROR,LADDRESS,0); 00658400
END; % OF TAKING CARE OF ERASE 00658500
%------------ ASSIGN -------------------------------- 00658600
; 00658700
%------------ DELETE --------------------------------- 00658800
; 00658900
%------------- LIST ------------------------------------ 00659000
; 00659100
% -------------DEBUG -------------------------------- 00659200
IF SCAN AND IDENT THEN 00659300
IF ACCUM[0]="6POLISH" THEN POLBUG:=ABS(POLBUG-1); 00659400
00659500
%----------------------------- FILES ---------------------- 00659600
IF LIBSIZE>1 THEN 00659700
BEGIN FOR I~1 STEP 1 UNTIL LIBSIZE-1 DO 00659800
BEGIN R~CONTENTS(LIBRARY,I ,ACCUM); 00659900
FORMROW(0,1,ACCUM,2,6); 00660000
END; TERPRINT; 00660100
END ELSE FORMWD(3,"6 NULL."); 00660200
%------------------------ END OF CASES ----------------------- 00660300
END ELSE GO TO ERR1; 00660400
IF CURRENTMODE=FUNCMODE THEN INDENT(-CURLINE); 00660500
END ELSE 00660600
IF QUOTE THEN EDITLINE ELSE 00660700
ERR1: ERRORMESS(SYNTAXERROR,0,0); 00660800
INDENT(0); 00660900
TERPRINT; 00661000
END; 00661100
REAL PROCEDURE LINENUMBER(R); VALUE R; REAL R; 00661200
BEGIN 00661300
REAL STREAM PROCEDURE CON(R); VALUE R; 00661400
BEGIN SI:=LOC R; DI:=LOC CON; DS:=8DEC 00661500
END; 00661600
LINENUMBER:=CON( ENTIER( (R+.00005)|10000)) 00661700
END; 00661800
DEFINE DELIM="""#, ENDCHR="$"#; 00661900
BOOLEAN PROCEDURE WITHINALINE(COMMAND,OLD,NEW,CHAR,WORD); 00662000
VALUE COMMAND,CHAR,WORD; INTEGER COMMAND,CHAR,WORD; 00662100
ARRAY OLD, NEW[0]; BEGIN 00662200
BOOLEAN STREAM PROCEDURE WITHINLINE(COMMAND,OLD,NEW,CHAR,WORD); 00662300
VALUE COMMAND,CHAR,WORD; 00662400
BEGIN 00662500
LOCAL OLDLINE,NEWLINE,F,BCHR; 00662600
LOCAL N,M,T; 00662700
LOCAL X,Y,Z; 00662800
LABEL LOOKING,FOUND,BETWEEN,TAIL,FINISH, 00662900
OVER; 00663000
DI:=NEW; WORD(DS:=8LIT" "); 00663100
SI:=LOC CHAR; DI:=LOC T; DI:=DI+1; DS:=7CHR; 00663200
SI:=COMMAND; 00663300
TALLY:=T; X:=TALLY; TALLY:=2; Y:=TALLY; TALLY:=32; Z:=TALLY; 00663400
TALLY:=0; 00663500
IF SC!"~" THEN 00663600
BEGIN BCHR:=SI; SI:=OLD; OLDLINE:=SI; 00663700
DI:=NEW; NEWLINE:=DI; SI:=BCHR; 00663800
63(IF SC=DELIM THEN JUMP OUT ELSE SI:=SI+1; TALLY 00663900
:=TALLY+1); N:=TALLY; 00664000
IF TOGGLE THEN 00664100
BEGIN 00664200
SI:=SI+1; TALLY:=0; 00664300
63(IF SC=DELIM THEN TALLY:=0 ELSE 00664400
IF SC="~" THEN JUMP OUT ELSE TALLY:=TALLY+1; SI:=SI+1); 00664500
IF TOGGLE THEN M:=TALLY;; 00664600
DI:=OLDLINE; SI:=BCHR; 00664700
2( X( Y( Z( CI:=CI+F; 00664800
GO LOOKING; GO FOUND; GO BETWEEN; GO TAIL; GO FINISH; 00664900
LOOKING: %************ LOOKING FOR THE FIRST UNIQUE STRING**************00665000
IF SC=DELIM THEN BEGIN SI:=SI+1; TALLY:=2; F:= TALLY ; 00665100
DI:=NEWLINE; GO BETWEEN END ELSE 00665200
IF N SC=DC THEN BEGIN SI:=OLDLINE; SI:=SI+N; OLDLINE:=SI; 00665300
DI:=NEWLINE; SI:=BCHR; TALLY:=1; F:=TALLY; 00665400
GO FOUND END ELSE 00665500
BEGIN SI:=OLDLINE; DI:=NEWLINE; DS:=CHR; NEWLINE:=DI; 00665600
OLDLINE:=SI; SI:=BCHR; DI:=OLDLINE; 00665700
END; GO OVER; 00665800
FOUND: %**************FOUND THE FIRST UNIQUE STRING ******************00665900
IF SC=DELIM THEN BEGIN SI:=SI+1; TALLY:=2; 00666000
F:=TALLY; GO BETWEEN END ELSE 00666100
DS:=CHR; GO OVER; 00666200
BETWEEN: % ********** BETWEEN THEN // *********************************00666300
IF SC=DELIM THEN BEGIN SI:=SI+1; NEWLINE:=DI; DI:=OLDLINE; 00666400
TALLY:=3; F:=TALLY; GO TAIL END ELSE 00666500
IF SC="~" THEN BEGIN TALLY:=4; F:=TALLY; 00666600
SI:=OLDLINE; GO FINISH END ELSE 00666700
DS:=CHR; GO OVER; 00666800
TAIL: % ******* THE TAIL END OF THE COMMAND ***************************00666900
IF M SC=DC THEN BEGIN DI:=NEWLINE; SI:=OLDLINE; TALLY:=4; 00667000
F:=TALLY; GO FINISH END ELSE 00667100
BEGIN SI:=SI-M; DI:=DI-M; DI:=DI+1; OLDLINE:=DI; END; 00667200
GO OVER; 00667300
FINISH: % ********FINISH UP THE CHAR MOVE FROM OLD TO NEW*************00667400
DS:=CHR; OVER:))); 00667500
TALLY:=CHAR; X:=TALLY; TALLY:=1; Y:=TALLY; 00667600
Z:=TALLY); 00667700
SI:=NEW; DI:=OLD; DS:=WORD WDS; TALLY:=1; 00667800
WITHINLINE:=TALLY; 00667900
END 00668000
END 00668100
END OF WITHINALINE; 00668200
WITHINALINE := WITHINLINE(COMMAND,OLD,NEW,CHAR,WORD); 00668300
END OF PHONY WITHINALINE; 00668400
PROCEDURE EDITLINE; 00668500
BEGIN ARRAY T[0:MAXBUFFSIZE]; 00668600
INITBUFF(T,BUFFSIZE); 00668700
TRANSFER(OLDBUFFER,0,T,0,LENGTH(OLDBUFFER,TRUE)); 00668800
IF WITHINALINE(ADDRESS,T,OLDBUFFER,BUFFSIZE|8,BUFFSIZE) THEN 00668900
BEGIN MOVEWDS(OLDBUFFER,BUFFSIZE,BUFFER); 00669000
00669100
IF SCAN AND RGTPAREN THEN 00669200
ERRORMESS(SYNTAXERROR,LADDRESS,0) ELSE EDITOG:=1; 00669300
END; 00669400
00669500
00669600
FORMROW(3,0,BUFFER,0,LENGTH(BUFFER,FALSE)); 00669700
END; 00669800
PROCEDURE CHECKSEQ(SEQ,L,INC); REAL SEQ,L,INC; 00669900
BEGIN 00670000
INTEGER I,J; 00670100
I:=L|10000 MOD 10000; 00670200
FOR J:=-4 STEP 1 WHILE J LSS 0 AND I MOD 10=0 DO 00670300
I:=I/10; 00670400
INC:=10*J; 00670500
SEQ:=L; 00670600
END; 00670700
PROCEDURE FUNCTIONHANDLER; 00670800
BEGIN 00670900
LABEL ENDHANDLER; 00671000
OWN BOOLEAN EDITMODE; 00671100
DEFINE FPT=FUNCPOINTER#, 00671200
FSQ=FUNCSEQ#, 00671300
SEQ=CURLINE#, 00671400
INC=INCREMENT#, 00671500
MODE=SPECMODE#, 00671600
ENDDEFINES=#; 00671700
INTEGER STREAM PROCEDURE DELPRESENT(ADDR); VALUE ADDR; 00671800
BEGIN LABEL L,FINIS; 00671900
LOCAL Q; 00672000
DI:=LOC Q; DS:=RESET; DS:=5SET; DS:=2RESET; DS:=2SET; 00672100
% LEFT-ARROW / QUESTION MARK 00672200
SI:=ADDR; 00672300
L: DI:=LOC Q; 00672400
IF SC=DELCHR THEN 00672500
BEGIN ADDR:=SI; SI:=LOC Q; DI:=ADDR; DS:=LIT" "; 00672600
TALLY:=1; DELPRESENT:=TALLY; GO TO FINIS; 00672700
END; 00672800
IF SC=DC THEN GO TO FINIS; SI:=SI-1; 00672900
IF SC=DC THEN GO TO FINIS; 00673000
GO TO L; 00673100
FINIS: 00673200
END; 00673300
INTEGER PROCEDURE OLDLABCONFLICT(PT,S); VALUE PT,S; 00673400
INTEGER PT; REAL S; 00673500
IF PT NEQ 0 THEN 00673600
BEGIN INTEGER K; ARRAY L[0:1]; 00673700
ADDRESS:=ABSOLUTEADDRESS; 00673800
WHILE LABELSCAN(L,0) AND ERR EQL 0 DO 00673900
IF SEARCHORD(PT,L,K,8)=0 THEN 00674000
IF L[1] NEQ S THEN ERR:=24; 00674100
OLDLABCONFLICT:=ERR 00674200
END; 00674300
INTEGER PROCEDURE ELIMOLDLINE(PT,SQ,L); VALUE PT,SQ,L; INTEGER PT, 00674400
SQ,L; FORWARD; 00674500
INTEGER PROCEDURE STOREAWAY(PT,SQ,B,SEQ); VALUE SEQ; 00674600
INTEGER PT,SQ; REAL SEQ; ARRAY B[0]; FORWARD; 00674700
PROCEDURE BUFFERCLEAN(BUFFER,BUFFSIZE,ADDR); VALUE BUFFSIZE, 00674800
ADDR; REAL ADDR; INTEGER BUFFSIZE; ARRAY BUFFER[0]; 00674900
FORWARD; COMMENT THIS IS A PHONEY DEAL, BUT I CAN"T 00675000
DECLARE CLEANBUFFER FORWARD (MOVE IT UP HERE LATER); 00675100
PROCEDURE EDITDRIVER(PT,SQ,I,K); VALUE PT,SQ,I,K; 00675200
INTEGER PT,SQ,I,K; 00675300
BEGIN ARRAY C,LAB[0:1],OLD,NEW[0:MAXBUFFSIZE]; 00675400
STREAM PROCEDURE BL(A); 00675500
BEGIN DI:=A; MAXBUFFSIZE(DS:=8LIT" ") END; 00675600
DEFINE MOVE=MOVEWDS#; 00675700
REAL T,SEQ; INTEGER A,B,L,M; 00675800
T:=ADDRESS; 00675900
FOR A:=I STEP 1 WHILE A LEQ K AND EDITMODE DO 00676000
BEGIN B:=CONTENTS(PT,A,C); BL(OLD); 00676100
SEQ:=C[0]; 00676200
B:=CONTENTS(SQ,C[1],OLD); 00676300
IF EDITMODE:=WITHINALINE(T,OLD,NEW,BUFFSIZE|8,BUFFSIZE) 00676400
THEN BEGIN MOVE(BUFFER,MAXBUFFSIZE+1,NEW); 00676500
MOVE(OLD,MAXBUFFSIZE,BUFFER); 00676600
IF EDITMODE:=ERR:=OLDLABCONFLICT(PT,C[0])=0 THEN 00676700
BEGIN B:=ELIMOLDLINE(PT,SQ,C[1]); 00676800
DELTOG:=DELPRESENT(ADDRESS); 00676900
DELETE1(SQ,C[1]); DELETE1(PT,A+B); C[1]:= 00677000
STORESEQ(SQ,BUFFER,LENGTH(BUFFER,FALSE)); 00677100
STOREORD(PT,C,A+B); 00677200
RESCANLINE; L:=0; M:=1; LAB[1]:=C[0]; 00677300
WHILE LABELSCAN(C,0) DO 00677400
BEGIN MOVEWDS(C,1,LAB); 00677500
IF(IF FUNCSIZE=0 THEN TRUE ELSE L:= 00677600
SEARCHORD(PT,C,M,8)NEQ 0) THEN 00677700
BEGIN B:=B+1; FUNCSIZE:=FUNCSIZE+1; 00677800
STOREORD(PT,LAB,L+M-1) 00677900
END END; 00678000
A:=A+B; K:=K+B; 00678100
COMMENT THE NEXT LINE CAUSE A SYSTEM CRASH AFTER THE EDIT; 00678200
IF NOSYNTAX=0 THEN PROCESS(XEQUTE); 00678300
END END; 00678400
MOVE(NEW,MAXBUFFSIZE+1,BUFFER) 00678500
END END; 00678600
PROCEDURE LISTLINE(PT,SQ,I); VALUE PT,SQ,I; INTEGER PT,SQ,I; 00678700
BEGIN 00678800
GT1:=CONTENTS(PT,I,GTA); 00678900
INDENT(GTA[0]); 00679000
GT1:=CONTENTS(SQ,GTA[1],BUFFER); 00679100
CHRCOUNT:=CHRCOUNT-1; 00679200
FORMROW(1,0,BUFFER,0,GT1); 00679300
END; 00679400
INTEGER PROCEDURE DISPLAY(A,B,PT,SQ); VALUE A,B,PT,SQ; 00679500
INTEGER PT,SQ; REAL A,B; 00679600
IF A LEQ B AND FUNCSIZE NEQ 0 THEN 00679700
BEGIN 00679800
ARRAY C[0:1]; 00679900
INTEGER I,J,K; 00680000
DEFINE CLEANBUFFER=BUFFERCLEAN#; 00680100
A:=LINENUMBER(A); B:=LINENUMBER(B); 00680200
C[0]:=A; 00680300
I:=SEARCHORD(PT,C,K,8); 00680400
I:=( IF I=2 THEN IF K LSS FUNCSIZE-1 THEN K:=K+1 ELSE 00680500
K ELSE K); 00680600
IF A NEQ B THEN 00680700
BEGIN 00680800
C[0]:=B; B:=SEARCHORD(PT,C,K,8); 00680900
END; 00681000
IF EDITMODE THEN % MAY HAVE ONLY ONE LINE TO EDIT 00681100
IF I=K THEN 00681200
IF A NEQ 0 THEN %NOT EDITING THE HEADER 00681300
EDITDRIVER(PT,SQ,I,K) 00681400
ELSE %EDITING THE FUNCTION HEADER, FIX LATER. 00681500
ERR:=31 00681600
ELSE %EDITING MORE THAN ONE LINE 00681700
BEGIN MODE:=EDITING; 00681800
IF A=0 THEN I:=I+1; 00681900
CLEANBUFFER(BUFFER,BUFFSIZE,ADDRESS); 00682000
MOVE(BUFFER,BUFFSIZE,OLDBUFFER); 00682100
LOWER:=I; UPPER:=K 00682200
END 00682300
ELSE %NOT EDITING, MUST BE A LIST 00682400
BEGIN 00682500
FORMWD(3,"1 "); 00682600
IF K=I THEN % LISTING A SINGLE LINE 00682700
BEGIN LISTLINE(PT,SQ,I); 00682800
FORMWD(3,"1 "); 00682900
END ELSE % LISTING A SET OF LINES 00683000
BEGIN MODE:=DISPLAYING; 00683100
LOWER:=I; UPPER:=K; 00683200
END; 00683300
END; 00683400
EOB:=1; 00683500
END ELSE DISPLAY:=20; 00683600
INTEGER PROCEDURE DELETE(A,B,PT,SQ); VALUE A,B; 00683700
INTEGER PT,SQ; REAL A,B; 00683800
IF A LEQ B AND FUNCSIZE NEQ 0 AND A NEQ 0 THEN 00683900
BEGIN 00684000
INTEGER I,J,K,L; 00684100
ARRAY C[0:1]; 00684200
A:=LINENUMBER(B); 00684300
B:=LINENUMBER(B); 00684400
C[0]:=A; 00684500
IF SEARCHORD(PT,C,K,8)=2 THEN K:=K+1; 00684600
C[0]:=B; 00684700
IF SEARCHORD(PT,C,I,8)=1 THEN I:=I-1; 00684800
IF K GTR I OR I GEQ FUNCSIZE THEN DELETE:=21 ELSE 00684900
BEGIN 00685000
FOR J:=K STEP 1 UNTIL I DO 00685100
BEGIN A:=CONTENTS(PT,J,C); 00685200
L:=ELIMOLDLINE(PT,SQ,C[1]); 00685300
FUNCSIZE:=FUNCSIZE+L; I:=I+L; K:=K+L; J:=J+L; 00685400
DELETE1(SQ,C[1]) 00685500
END; 00685600
FUNCSIZE:=FUNCSIZE-(I-K+1) 00685700
; EOB:=1; 00685800
DELETEN(PT,K,I); 00685900
IF FUNCSIZE=0 THEN 00686000
BEGIN 00686100
PT:=0; RELEASEUNIT(SQ); SQ:=0; 00686200
STOREPSR; 00686300
END; 00686400
END; 00686500
END ELSE DELETE:=22; 00686600
INTEGER PROCEDURE ELIMOLDLINE(PT,SQ,L); VALUE PT,SQ,L; 00686700
INTEGER PT,SQ,L; 00686800
BEGIN INTEGER K,J; 00686900
REAL AD; 00687000
ARRAY T[0:MAXBUFFSIZE],LAB[0:1]; 00687100
AD:=ADDRESS; 00687200
MOVEWDS(BUFFER,MAXBUFFSIZE+1,T); 00687300
INITBUFF(BUFFER,BUFFSIZE); 00687400
K:=CONTENTS(SQ,L,BUFFER); 00687500
RESCANLINE; 00687600
WHILE LABELSCAN(LAB,0) DO 00687700
IF SEARCHORD(PT,LAB,K,8)=0 THEN 00687800
BEGIN DELETE1(PT,K); J:=J-1 END; 00687900
ADDRESS:=AD; 00688000
MOVEWDS(T,MAXBUFFSIZE+1,BUFFER); 00688100
ELIMOLDLINE:=J 00688200
END; 00688300
INTEGER PROCEDURE STOREAWAY(PT,SQ,B,SEQ); VALUE SEQ; 00688400
INTEGER PT,SQ; REAL SEQ; ARRAY B[0]; 00688500
BEGIN DEFINE BUFFER=B#; 00688600
ARRAY C,LAB[0:1]; 00688700
INTEGER I,J,K,L; 00688800
BOOLEAN TOG; 00688900
SEQ:=LINENUMBER(SEQ); 00689000
C[0]:=SEQ; 00689100
IF TOG:=(PT=0 OR FUNCSIZE=0) THEN 00689200
BEGIN SEQUENTIAL(SQ:=NEXTUNIT); I:=0 00689300
END ELSE 00689400
IF J:=SEARCHORD(PT,C,I,8)=0 THEN 00689500
BEGIN 00689600
K:=ELIMOLDLINE(PT,SQ,C[1]); 00689700
I:=I+K; FUNCSIZE:=FUNCSIZE+K; 00689800
DELETE1(PT,I); 00689900
FUNCSIZE:=FUNCSIZE-1; 00690000
DELETE1(SQ,C[1]); 00690100
END ELSE 00690200
I:=I+J-1; 00690300
RESCANLINE; 00690400
DELTOG:=DELPRESENT(ADDRESS); 00690500
K:=STORESEQ(SQ,BUFFER,LENGTH(BUFFER,TRUE)); 00690600
LAB[1]:=SEQ; L:=0; J:=1; 00690700
IF TOG THEN PT:=NEXTUNIT; 00690800
WHILE LABELSCAN(C,0) DO 00690900
BEGIN 00691000
MOVEWDS(C,1,LAB); 00691100
IF (IF FUNCSIZE=0 THEN TRUE ELSE L:= 00691200
SEARCHORD(PT,C,J,8)NEQ 0 ) THEN 00691300
BEGIN I:=I+1; FUNCSIZE:=FUNCSIZE+1; 00691400
STOREORD(PT,LAB,L+J-1); 00691500
END; 00691600
END; 00691700
C[1]:=K; 00691800
C[0]:=SEQ; 00691900
FUNCSIZE:=FUNCSIZE+1; 00692000
STOREORD(PT,C,I); 00692100
IF TOG THEN STOREPSR; 00692200
EOB:=1; 00692300
END; 00692400
BOOLEAN PROCEDURE BOUND(PT); VALUE PT; INTEGER PT; 00692500
IF NOT(BOUND:=NUMERIC) THEN 00692600
IF IDENT AND FUNCSIZE GTR 0 THEN 00692700
BEGIN ARRAY L[0:1]; INTEGER K; 00692800
REAL T,U; 00692900
REAL STREAM PROCEDURE CON(A); 00693000
VALUE A; 00693100
BEGIN SI:=LOC A; DI:=LOC CON; DS:=8OCT 00693200
END; 00693300
TRANSFER(ACCUM,2,L,1,7); 00693400
IF BOUND:=SEARCHORD(PT,L,K,8)=0 THEN 00693500
BEGIN T:=ADDRESS; 00693600
U:=CON(MAX(L[1],0))/10000; %ARGS AND RESULT ARE NEG 00693700
IF SCAN AND PLUS OR MINUS THEN 00693800
BEGIN K:=(IF PLUS THEN 1 ELSE -1); 00693900
IF SCAN AND NUMERIC THEN 00694000
ACCUM[0]:=MAX(U+K|ACCUM[0],0) ELSE 00694100
BEGIN ACCUM[0]:=U; 00694200
ADDRESS:=T; 00694300
END; 00694400
END ELSE BEGIN ACCUM[0]:=U; ADDRESS:=T; 00694500
END; 00694600
EOB:=0; 00694700
END 00694800
END; 00694900
00695000
00695100
PROCEDURE FINISHUP; 00695200
BEGIN COMMENT GET HIM BACK TO CALCULATOR MODE; 00695300
IF FUNCPOINTER=0 THEN % HE DELETED EVERY THING 00695400
BEGIN TRANSFER(PSR,FSTART|8,GTA,0,8); 00695500
IF SEARCHORD(VARIABLES,GTA,GT1,7)=0 THEN 00695600
BEGIN DELETE1(VARIABLES,GT1); 00695700
IF VARSIZE:=VARSIZE-1=0 THEN VARIABLES:=0; 00695800
END ELSE SPOUT(9198260); 00695900
END; 00696000
DELTOG:=CURRENTMODE:=CURLINE:=INCREMENT:=0; 00696100
STOREPSR; 00696200
END; 00696300
00696400
LABEL SHORTCUT; 00696500
REAL L,U,TADD; 00696600
STREAM PROCEDURE CLEANBUFFER(BUFFER,BUFFSIZE,ADDR); 00696700
VALUE BUFFSIZE,ADDR; 00696800
BEGIN LABEL L; LOCAL T,U,TSI,TDI; 00696900
SI:=ADDR; SI:=SI-1; L: 00697000
IF SC NEQ "]" THEN 00697100
BEGIN SI:=SI-1; GO TO L END; 00697200
SI:=SI+1; DI:=LOC T; SKIP 2 DB; DS:=2SET; 00697300
DI:=BUFFER; TDI:=DI; DI:=LOC T; TSI:=SI; 00697400
BUFFSIZE(8(IF TOGGLE THEN DS:=LIT" " ELSE 00697500
IF SC=DC THEN 00697600
BEGIN SI:=LOC U; DI:=TDI; DS:=LIT" " 00697700
END ELSE 00697800
BEGIN TSI:=SI; SI:=SI-1; DI:=LOC U; DS:=CHR; 00697900
DI:=TDI; SI:=LOC U; DS:=CHR; TDI:=DI; DI:=LOC T; 00698000
SI:=TSI; 00698100
END)) 00698200
END; 00698300
PROCEDURE BUFFERCLEAN(BUFFER,BUFFSIZE,ADDR); VALUE BUFFSIZE, 00698400
ADDR; REAL ADDR; INTEGER BUFFSIZE; ARRAY BUFFER[0]; 00698500
CLEANBUFFER(BUFFER,BUFFSIZE,ADDR); 00698600
COMMENT DETERMINE WHETHER OR NOT WE CAME FROM CALCULATOR MODE; 00698700
ERR:=0; 00698800
IF BOOLEAN(SUSPENSION) THEN GO TO ENDHANDLER; 00698900
BEGIN DEFINE STARTSEGMENT=#; %/////////////////////////////// 00699000
IF GT1:=CURRENTMODE=CALCMODE THEN % TAKE CARE OF HEADER. 00699100
BEGIN ARRAY A[0:MAXHEADERARGS]; 00699200
LABEL HEADERSTORE,FORGETITFELLA; 00699300
IF FUNCTIONHEADER(A,TADD) THEN %HEADER OK 00699400
IF VARIABLES NEQ 0 THEN % MAY BE A RE-DEFINITION 00699500
BEGIN COMMENT GET THE FUNCTION NAME; 00699600
TRANSFER(A,1,GTA,0,7); 00699700
IF GT2:=SEARCHORD(VARIABLES,GTA,GT3,7)=0 THEN 00699800
COMMENT RE-DEFINING A FUNCTION. MAKE SURE NULL ; 00699900
IF GETFIELD(GTA,7,1)=FUNCTION AND 00700000
(A[1]+A[2]+A[3])=0 THEN %NULL HEADER--OK 00700100
%--------------------SET UP FOR CONTINUATION OF DEFINITION------ 00700200
BEGIN 00700300
FUNCPOINTER:=GETFIELD(GTA,FPTF,FFL); 00700400
FUNCSEQ:=GETFIELD(GTA,FSQF,FFL); 00700500
GT3:=CURLINE:=TOPLINE(FPT); 00700600
CHECKSEQ(CURLINE,GT3,INC); %SET THE INCREMENT 00700700
COMMENT THE CURRENT LINE IS SET TO THE LAST LINE OF THE 00700800
FUNCTION; 00700900
FUNCSIZE:=SIZE(FPT); 00701000
CURLINE:=CURLINE+INC; 00701100
DELTOG:=DELPRESENT(ADDRESS); 00701200
END ELSE 00701300
%------------------REDEFINING THE HEADER OF A DEFINED FUNCTION---- 00701400
GO TO FORGETITFELLA 00701500
ELSE 00701600
%--------------------NAME NOT FOUND IN DIRECTORY, SET UP 00701700
HEADERSTORE: 00701800
BEGIN COMMENT GET THE HEADER TO INSERT AT LINE 0; 00701900
ARRAY OLDBUFFER[0:MAXBUFFSIZE]; 00702000
INTEGER L,U,F,K,J; 00702100
INTEGER A1,A2; 00702200
COMMENT FUNCTIONHEADER RETURN AN ARRAY WITH THE 00702300
FOLLOWING VALUES: 00702400
A[0] = FUNCTION NAME , I.E., 0AAAAAAA 00702500
A[1] = 0 IF NO RESULT, 1 IF A RESULT IS RETURNED BY THE 00702600
FUNCTION. 00702700
A[2] = NUMBER OF ARGUMENTS TO THE FUNCTION. 00702800
A[3] = NUMBER OF LOCALS + RESULT +ARGUMENTS. 00702900
A[4]....A[N] ARE ALL OF THE LOCALS, RESULT, AND ARGUMENTS. 00703000
THE RESULT IS FIRST, THEN THE SECOND ARGUMENT, THEN 00703100
THE FIRST ARGUMENT, FOLLOWED BY THE LOCALS. ALL 00703200
ARE OF THE FORM 0XXXXXXX; 00703300
U:=(A1:=A[1])+(A2:=A[2])+3; 00703400
FOR L:=4 STEP 1 UNTIL U DO %LOOK FOR DUPLICATES AMONG 00703500
FOR K:=L+1 STEP 1 UNTIL U DO %THE RESULT/ARGUMENT SET 00703600
IF A[L]=A[K] THEN GO TO FORGETITFELLA; 00703700
SEQUENTIAL(FUNCSEQ:=NEXTUNIT); 00703800
SETFIELD(GTA,8,8,STORESEQ(FUNCSEQ,OLDBUFFER, 00703900
HEADER(TADD.[1:23],TADD.[24:24],OLDBUFFER))); 00704000
SETFIELD(GTA,0,8,0); 00704100
STOREORD(F:=FUNCPOINTER:=NEXTUNIT,GTA,0); 00704200
SETFIELD(GTA,0,8,0); SETFIELD(GTA,8,8,0); 00704300
FOR L:=4 STEP 1 UNTIL U DO 00704400
BEGIN GTA[0]:=A[L]; IF A1 GTR 0 THEN 00704500
BEGIN A1:=0; GTA[1]:=-1; %"RESULT" SET TO -1 00704600
STOREORD(F,GTA,0); 00704700
END ELSE %LOOKING AT THE ARGUMENTS 00704800
BEGIN K:=SEARCHORD(F,GTA,J,8); 00704900
GTA[1]:=A2-4; A2:=A2-1; GTA[0]:=A[L]; 00705000
STOREORD(F,GTA,J+K-1); 00705100
END END; 00705200
FUNCSIZE:=U:=U-2; U:=A[3]-U+L; 00705300
FOR L:=L STEP 1 UNTIL U DO %GET LOCALS INTO THE LABEL TABLE 00705400
BEGIN GTA[0]:=A[L]; 00705500
IF K:=SEARCHORD(F,GTA,J,8) NEQ 0 THEN %NOT YET IN TABLE. 00705600
BEGIN GTA[0]:=A[L]; GTA[1]:=0; 00705700
STOREORD(F,GTA,J+K-1); 00705800
FUNCSIZE:=FUNCSIZE+1 00705900
END; 00706000
END; 00706100
GTA[1]:=0&ENTIER(A[1])[CRETURN]&ENTIER(A[2])[CNUMBERARGS]; 00706200
CURLINE:=INCREMENT:=1; 00706300
DELTOG:=0; 00706400
COMMENT GET THE "TYPE" OF THE FUNCTION LATER WHEN THERE 00706500
IS A PLACE FOR IT. THE TYPE IS EITHER 1 (FUNCTION CALL), OR 00706600
0 (SUBROUTINE CALL); 00706700
END; 00706800
%-------------------------------------------------------- 00706900
END ELSE % VARAIBLES=0, MAKE UP A DIRECTORY 00707000
BEGIN GT3:=0; GT2:=1; GO TO HEADERSTORE 00707100
END 00707200
ELSE % HEADER SYNTAX IS BAD 00707300
GO TO ENDHANDLER; 00707400
COMMENT WE MAKE IT TO HERE IF ALL IS WELL ABOVE; 00707500
IF GT2 NEQ 0 THEN %NAME NOT FOUND IN DIRECTORY; 00707600
BEGIN 00707700
TRANSFER(A,1,GTA,0,7); %GET FUNCTION NAME 00707800
SETFIELD(GTA,7,1,FUNCTION); 00707900
SETFIELD(GTA,FPTF,FFL,FUNCPOINTER); 00708000
SETFIELD(GTA,FSQF,FFL,FUNCSEQ); 00708100
IF VARIABLES=0 THEN 00708200
VARIABLES:=NEXTUNIT; 00708300
STOREORD(VARIABLES,GTA,GT3+GT2-1); 00708400
VARSIZE:=VARSIZE+1; 00708500
END; 00708600
CURRENTMODE:=FUNCMODE; 00708700
TRANSFER(GTA,0,PSR,FSTART|8,8); 00708800
STOREPSR; 00708900
IF SCAN THEN GO TO SHORTCUT; 00709000
IF FALSE THEN 00709100
FORGETITFELLA: ERRORMESS(ERR:=LABELERROR,TADD.[1:23],0); 00709200
END ELSE % WE ARE IN FUNCTION DEFINITION MODE 00709300
IF GT1:=MODE NEQ 0 THEN % A SPECIAL FUNCTION SUCH AS DISPLAY OR EDIT00709400
BEGIN L:=LOWER; 00709500
IF GT1=DISPLAYING THEN 00709600
LISTLINE(FPT,FSQ,L) ELSE 00709700
IF GT1=EDITING THEN 00709800
BEGIN INITBUFF(BUFFER,BUFFSIZE); 00709900
MOVE(OLDBUFFER,BUFFSIZE,BUFFER); 00710000
EDITMODE:=TRUE; ADDRESS:=ABSOLUTEADDRESS; 00710100
EDITDRIVER(FPT,FSQ,L,L) 00710200
;IF NOT EDITMODE THEN 00710300
BEGIN MODE:=0; ERR:=30 00710400
END; 00710500
END ELSE 00710600
IF GT1=RESEQUENCING THEN 00710700
IF GT1:=L LEQ UPPER THEN 00710800
BEGIN GT2:=CONTENTS(FPT,L,GTA); 00710900
GT3:=GTA[0]:=LINENUMBER(CURLINE); 00711000
DELETE1(FPT,L); 00711100
STOREORD(FPT,GTA,L); 00711200
CURLINE:=CURLINE+INCREMENT; 00711300
GT2:=CONTENTS(FSQ,GTA[1],BUFFER); RESCANLINE; 00711400
WHILE (IF ERR NEQ 0 THEN FALSE ELSE 00711500
LABELSCAN(GTA,0)) DO 00711600
IF GT1:=SEARCHORD(FPT,GTA,GT2,8)=0 THEN 00711700
BEGIN GTA[1]:=GT3; DELETE1(FPT,GT2); 00711800
STOREORD(FPT,GTA,GT2) 00711900
END ELSE ERR:=16 00712000
END 00712100
ELSE MODE:=0; 00712200
LOWER:=L+1; 00712300
IF LOWER GTR UPPER THEN 00712400
BEGIN IF MODE=DISPLAYING THEN 00712500
FORMWD(3,"1 "); 00712600
MODE:=0; 00712700
END; 00712800
GO TO ENDHANDLER 00712900
END; 00713000
END ; % OF BLOCK STARTED ON LINE 9225115 ////////////////// 00713100
00713200
00713300
00713400
IF ERR=0 AND EOB=0 THEN 00713500
00713600
SHORTCUT: BEGIN LABEL RGTBRACK,DELOPTION; %////////////////////////// 00713700
IF DELV THEN FINISHUP ELSE 00713800
IF LFTBRACKET THEN 00713900
BEGIN 00714000
IF SCAN THEN 00714100
IF BOUND(FPT) THEN 00714200
BEGIN L:=ACCUM[0]; 00714300
IF SCAN THEN 00714400
IF QUADV OR EDITMODE:=(QUOTEQUAD) THEN 00714500
IF SCAN THEN 00714600
IF BOUND(FPT) THEN 00714700
BEGIN U:=ACCUM[0]; 00714800
RGTBRACK: 00714900
IF SCAN AND RGTBRACKET THEN 00715000
IF(IF EDITMODE THEN FALSE ELSE SCAN) THEN 00715100
IF DELV THEN 00715200
BEGIN ERR:=DISPLAY(L,U,FPT,FSQ); 00715300
DELTOG:=1; 00715400
END 00715500
ELSE ERR:=1 00715600
ELSE ERR:=DISPLAY(L,U,FPT,FSQ) 00715700
ELSE ERR:=2 00715800
END 00715900
ELSE 00716000
IF RGTBRACKET THEN 00716100
IF(IF EDITMODE THEN FALSE ELSE SCAN) THEN 00716200
IF DELV THEN 00716300
BEGIN ERR:=DISPLAY(L,L,FPT,FSQ); 00716400
DELTOG:=1; 00716500
END 00716600
ELSE ERR:=3 00716700
ELSE ERR:=DISPLAY(L,L,FPT,FSQ) 00716800
ELSE ERR:=4 00716900
ELSE ERR:=5 00717000
ELSE 00717100
IF RGTBRACKET THEN 00717200
BEGIN TADD:=ADDRESS; 00717300
IF SCAN THEN 00717400
IF IDENT AND ACCUM[0]="6DELETE" THEN 00717500
IF SCAN THEN 00717600
IF LFTBRACKET THEN 00717700
DELOPTION: 00717800
IF SCAN AND BOUND(FPT) THEN 00717900
BEGIN U:=ACCUM[0]; 00718000
IF SCAN AND RGTBRACKET THEN 00718100
IF SCAN THEN 00718200
IF DELV THEN 00718300
BEGIN ERR:=DELETE(L,U,FPT,FSQ); 00718400
FINISHUP 00718500
END 00718600
ELSE ERR:=6 00718700
ELSE ERR:=DELETE(L,U,FPT,FSQ) 00718800
ELSE ERR:=7 00718900
END 00719000
ELSE ERR:=8 00719100
ELSE 00719200
IF DELV THEN 00719300
BEGIN ERR:=DELETE(L,L,FPT,FSQ); 00719400
FINISHUP 00719500
END 00719600
ELSE ERR:=9 00719700
ELSE ERR:=DELETE(L,L,FPT,FSQ) 00719800
ELSE 00719900
IF LFTBRACKET THEN GO TO DELOPTION ELSE 00720000
BEGIN CHECKSEQ(SEQ,L,INC); 00720100
CLEANBUFFER(BUFFER,BUFFSIZE,TADD); 00720200
ADDRESS:=ABSADDR(BUFFER); ITEMCOUNT:=0; 00720300
IF SCAN THEN GO TO SHORTCUT 00720400
END 00720500
ELSE ERR:=DELETE(L,L,FPT,FSQ) 00720600
END 00720700
ELSE ERR:=10 00720800
ELSE ERR:=11 00720900
END ELSE 00721000
IF QUADV OR EDITMODE:=(QUOTEQUAD) THEN 00721100
BEGIN L:=0; U:=9999.9999; GO TO RGTBRACK 00721200
END ELSE 00721300
IF IOTA THEN 00721400
IF SCAN AND RGTBRACKET AND FPT NEQ 0 THEN 00721500
BEGIN IF SCAN THEN 00721600
IF DELV THEN DELTOG:=1 ELSE ERR:=15; 00721700
IF ERR = 0 THEN 00721800
BEGIN MODE:=RESEQUENCING; CURLINE:=INCREMENT:=1; 00721900
SETFIELD(GTA,0,8,0); 00722000
GT1:=SEARCHORD(FPT,GTA,GT2,8); 00722100
LOWER:=GT2+1; UPPER:=FUNCSIZE-1; 00722200
END 00722300
END 00722400
ELSE ERR:=14 00722500
ELSE ERR:=12 00722600
ELSE ERR:=13 00722700
END 00722800
ELSE 00722900
IF CURLINE=0 THEN %CHANGING HEADER 00723000
ERR:=26 ELSE 00723100
IF ERR:=OLDLABCONFLICT(FPT,LINENUMBER(SEQ))=0 THEN 00723200
BEGIN 00723300
IF NOSYNTAX=0 THEN PROCESS(XEQUTE); 00723400
IF ERR:=STOREAWAY(FPT,FSQ,BUFFER,SEQ)=0 THEN SEQ:=SEQ+INC; 00723500
END; 00723600
IF ERR NEQ 0 THEN 00723700
BEGIN FORMWD(2,"5ERROR "); 00723800
NUMBERCON(ERR,ACCUM); ERR:=0; 00723900
EOB:=1; 00724000
FORMROW(1,1,ACCUM,2,ACCUM[0].[1:11]); 00724100
END; 00724200
END; %OF BLOCK STARTED ON LINE 9238000 ////////////////////// 00724300
ENDHANDLER: 00724400
IF BOOLEAN(SUSPENSION) THEN BEGIN 00724500
FILL ACCUM[*] WITH "ABORT SU", "SP. FNS."; 00724600
FORMROW(3,0,ACCUM,0,16); INDENT(0); TERPRINT; 00724700
END ELSE 00724800
IF MODE=0 THEN 00724900
BEGIN 00725000
IF BOOLEAN(DELTOG) THEN FINISHUP; 00725100
INDENT(-CURLINE); TERPRINT; 00725200
END; 00725300
00725400
END; 00725500
EXPOVR:=FAULTL; INTOVR:=FAULTL; INDEXF:=FAULTL; 00725600
FLAG:=FAULTL; ZERO:=FAULTL; 00725700
INITIALIZETABLE; 00725800
TRYAGAIN: 00725900
IF FALSE THEN %ENTERS WITH A FAULT. 00726000
FAULTL: 00726100
BEGIN SPOUT(09334300); %SEND MESSAGE TO SPO 00726200
00726300
BEGIN CSTATION.APLOGGED:=0; CSTATION.APLHEADING:=0 00726400
END 00726500
END; 00726600
APLMONITOR; 00726700
ENDOFJOB: 00726800
00726900
FINIS: 00727000
WRAPUP; 00727100
00727200
END. 00727300
Reference in New Issue View Git Blame Copy Permalink