github.com/retro-software.B5500-software
1
0
Fork 0
mirror of https://github.com/retro-software/B5500-software.git synced 2026-01-11 23:42:42 +00:00
Code Issues Releases Wiki Activity
retro-software.B5500-software/APL-UW-Kildall/APL-IMAGE.alg_m
Paul Kimpel 9278e4b11c Correct directory name APL-WU-Kildall to APL-UW-Kildall. 
Thanks to Robert Henry for catching this.
2021-04-19 20:30:26 -07:00

7275 lines
646 KiB
Plaintext
Raw Permalink Blame History

BEGIN 00000490
% THIS APL/B5500 PROGRAM WAS DEVELOPED BY THE COMPUTER SCIENCE GROUP 00000500
% AT THE UNIVERSITY OF WASHINGTON UNDER THE SPONSORSHIP OF PROFESSOR 00000510
% HELLMUT GOLDE. THE PROGRAM MAY NOT BE OFFERED FOR SALE OR LEASE 00000520
% IN ITS ORIGINAL OR ANY MODIFIED FORM. ANY PUBLICATION RELATING TO 00000530
% THIS PROGRAM OR ANY MODIFICATION OF THE PROGRAM MUST EXPLICITLY CREDIT00000540
% THE COMPUTER SCIENCE GROUP OF THE UNIVERSITY OF WASHINGTON AND THE 00000550
% PRINCIPAL IMPLEMENTORS, GARY KILDALL, LEROY SMITH, SALLY SWEDINE, 00000560
% AND MARY ZOSEL. COMPUTER RESOURCES FOR THE DEVELOPMENT OF THE 00000570
% PROGRAM WERE MADE AVAILABLE BY THE UNIVERSITY OF WASHINGTON COMPUTER 00000580
% CENTER. 00000590
DEFINE VERSIONDATE="1-11-71"# ; 00000600
%MODIFICATIONS FOR B-5500 TIME-SHARING MCP MADE BY: 00000601
% JOSE HERNANDEZ, BURROUGHS CORPORATION. 00000602
BOOLEAN BREAKFLAG; 00000609
ARRAY GTA[0:1]; 00000610
LABEL FINIS; %GO THERE WHEN YOU ARE IN TROUBLE (SPOUT A MESSAGE) 00000630
BOOLEAN PROCEDURE LIBRARIAN(A,B); VALUE A,B; REAL A,B; FORWARD; 00000700
LABEL FAULTL; %FAULT LABEL 00000800
MONITOR EXPOVR,INTOVR,INDEX:=INDEXF,FLAG,ZERO; 00000810
REAL BIGGEST, NULLV; 00000900
INTEGER STACKSIZE,LIBSIZE; 00001000
REAL STATUSWORD,CORELOC; 00001100
BOOLEAN RETURN; 00001110
BOOLEAN MEMBUG,DEBUG; 00001120
COMMENT MEMBUG SWITCHES ---------------------- 00001130
BIT FUNCTION BIT FUNCTION 00001140
----------------------------------------------------------------- 00001150
1 25 00001160
2 26 00001170
3 27 00001180
4 28 00001190
5 DUMP TYPES @ INSERT 30 00001200
6 DUMP TYPES @ DELETE 30 00001210
7 31 00001220
8 32 00001230
9 33 00001240
10 34 00001250
11 35 00001260
12 36 00001270
13 37 00001280
14 38 00001290
15 39 00001300
16 40 00001310
17 41 00001320
18 42 00001330
19 43 00001340
20 DUMP INDEX 44 00001350
21 45 00001360
22 DUMP TYPES 46 00001370
23 CHECK TYPES 47 00001380
24 DUMP BUFFER #S 00001390
; 00001400
FILE PRINT 4 "SYSTEMS" " BOX " (1,15); 00001410
FILE TWXIN 19(2,30),TWXOUT 19(2,10); 00001415
% 00001416
DEFINE 00001420
PAGESIZE=120#, 00001430
AREASIZE=40#, 00001440
CF=[26:13]#, COMMENT COUNT FIELD -- NUMBER OF ITEMS ON PAGE; 00001450
TF=[39:9] #, COMMENT T-FIELD (TYPE FIELD); 00001460
FF=[9:1]#, COMMENT FULL FIELD FOR SEQUENTIAL STORAGE; 00001465
AF=[1:23] #, COMMENT A-FIELD; 00001470
BF=[24:23]#, COMMENT B-FIELD; 00001480
MF=[1:1]#, COMMENT METHOD OF STORAGE FIELD; 00001490
SF=[13:13]#, COMMENT SEQUENTIAL STORAGE SIZE FIELD (#CHRS); 00001500
BOOL=[47:1]#, 00001510
SKIP=1#, COMMENT --AMOUNT OF SPACE RESERVED AT THE 00001520
START OF EACH PAGE; 00001530
ALLOWANCE=10#, COMMENT --DEVIATION FROM THE AVERAGE PAGE SIZE 00001540
ALLOWED BEFORE CORRECTION; 00001550
RECSIZE=2#, 00001560
MAXPAGES=20#, 00001570
PAGESPACE=20#, 00001580
NEXTP=[42:6]#, 00001590
LASTP=[36:6]#, 00001600
PAGEF=[19:11]#, 00001610
BUFF=[12:6]#, 00001620
CHANGEDBIT=[1:1]#, 00001630
MBUFF=8#, 00001640
SBUFF=4#, 00001650
FLAGB=[18:1]#, COMMENT FLAG BIT FOR BUFFER MAINTENANCE; 00001660
EXTRAROOM=1#, 00001670
LIBJOB="/APLIBE"#,%MFID FOR APL SYSTEM FILE 00001675
ENDOFDEFINES=#; 00001680
REAL PROCEDURE CDR(X); VALUE X; REAL X; CDR:=X.NEXTP; 00001690
PROCEDURE RPLACD(X,Y); VALUE Y;REAL X,Y; X.NEXTP:=Y; 00001710
BOOLEAN PROCEDURE NULL(X); VALUE X; REAL X; NULL:=X.NEXTP=0; 00001730
BOOLEAN STREAM PROCEDURE EOFMARK(SK,RS,A); VALUE SK,RS; 00001740
BEGIN LABEL NO; SI:=A; SK(SI:=SI+8); 00001750
RS(8( 2(IF SB THEN JUMP OUT 3 TO NO; SKIP SB); 00001760
3(IF SB THEN SKIP SB ELSE JUMP OUT 3 TO NO); IF SB THEN 00001770
JUMP OUT 2 TO NO; SKIP SB));TALLY:=1;EOFMARK:=TALLY; 00001780
NO: 00001790
END; 00001800
STREAM PROCEDURE MARKEOF(SK,RS,A); VALUE SK,RS; 00001810
BEGIN DI:=A; 00001820
SK(DI:=DI+8); 00001830
RS(8(DS:=2RESET; DS:=3SET; DS:=RESET)); 00001840
END; 00001850
SAVE FILE ESTABLISH DISK [MAXPAGES:AREASIZE] 00001860
(1,PAGESIZE,SAVE 100); 00001870
FILE NEWDISK DISK (1,PAGESIZE); 00001880
FILE DISK1 DISK (1,PAGESIZE), 00001890
DISK2 DISK (1,PAGESIZE), 00001900
DISK3 DISK (1,PAGESIZE), 00001910
DISK4 DISK (1,PAGESIZE), 00001920
DISK5 DISK (1,PAGESIZE), 00001930
DISK6 DISK (1,PAGESIZE), 00001940
DISK7 DISK (1,PAGESIZE), 00001950
DISK8 DISK (1,PAGESIZE); 00001960
SWITCH FILE POINTERS:=DISK1,DISK1,DISK2,DISK3,DISK4,DISK5,DISK6,DISK7, 00001970
DISK8; 00001980
PROCEDURE SETPOINTERNAMES; 00002600
BEGIN 00002610
IF NOT LIBRARIAN(LIBJOB,TIME(-1)) THEN 00002650
BEGIN 00002660
WRITE(ESTABLISH); 00002670
MARKEOF(SKIP,RECSIZE,ESTABLISH(0)); 00002680
WRITE(ESTABLISH[1]); 00002690
WRITE(ESTABLISH[MAXPAGES|AREASIZE-1]); 00002700
LOCK(ESTABLISH); 00002710
CLOSE(ESTABLISH) 00002720
;LIBSIZE~-1; 00002721
END 00002730
END; 00002740
DEFINE 00002750
LIBMAINTENANCE=0#, 00002760
MESSDUM=#; 00002770
PROCEDURE MEMORY(MODE,TYPE,A,N,M);VALUE MODE,TYPE; 00002780
INTEGER MODE,TYPE,N,M; ARRAY A[0]; FORWARD; 00002790
STREAM PROCEDURE MOVE(A,N,B); VALUE N; 00002792
BEGIN SI:=A; DI:=B; DS:=N WDS; 00002794
END; 00002796
PROCEDURE MESSAGE(I); VALUE I; INTEGER I; 00002800
BEGIN 00002810
FORMAT F("MEMORY ERROR",I5); 00002820
COMMENT CHANGE LINE 3050 TO WRITE(PRINT,SF[I]) FOR MEMORY ERROR PROBS. 00002825
THIS FORMAT IS NOW EXCLUDED SINCE MEMORY IS SEEMINGLY WELL DEBUGED 00002826
SWITCH FORMAT SF:= 00002830
("LIBRARY MAINTENANCE IN PROGRESS."), 00002840
("SYSTEM ERROR--MEMORY ACCESS WITH EXPRESSION FOR N OR M."), 00002850
("SYSTEM ERROR--IMPROPER ARGUMENTS TO FREEPAGE."), 00002860
("SYSTEM ERROR--TOO LARGE A SUBSCRIPT FOR TYPE SPECIFIED."), 00002870
("SYSTEM ERROR--TYPE CANNOT BE ZERO WHEN INSERTING OR DELETING."), 00002880
("SYSTEM ERROR--CHARACTER STRING TOO LONG TO STORE."), 00002890
("SYSTEM ERROR--ATTEMPT TO INSERT NON-SEQUENTIAL ELEMENT", 00002900
"IN TYPE A STORAGE."), 00002910
("SYSTEM ERROR--NO BLANKS IN PAGES."), 00002920
("SYSTEM ERROR--ATTEMPTED BINARY SEARCH OF UNORDERED DATA."), 00002930
("SYSTEM ERROR--BINARY SEARCH OF UNALLOCATED DATA ATTEMPTED."), 00002940
("SYSTEM ERROR--BINARY SEARCH FOUND A BLANK PAGE."), 00002950
("SYSTEM ERROR--DELETION OF TYPE B STORAGE NOT IMPLEMENTED."), 00002960
("SYSTEM ERROR--ATTEMPT TO DELETE FROM NON-EXISTENT STORAGE."), 00002970
("SYSTEM ERROR--ATTEMPT TO DELETE RECORD FROM OUTSIDE", 00002980
" ALLOCATED STORAGE."), 00002990
("SYSTEM ERROR--ATTEMPTED MEMORY SEARCH WITH -N- TOO LARGE."), 00003000
("SYSTEM ERROR--ATTEMPT TO CHANGE PREVIOUSLY DESIGNATED STORAGE", 00003010
" KIND"), 00003020
("SYSTEM ERROR--POINTERS TO DATA TYPES OVERLAP."), 00003030
(" "); 00003040
WRITE(PRINT,F,I); 00003050
IF I GTR 0 THEN 00003060
BEGIN 00003070
INTEGER GT1,GT2,GT3; 00003075
MEMORY(10,GT1,GTA,GT2,GT3); 00003082
GO TO FINIS; 00003084
END; 00003090
END; 00003100
PROCEDURE MEMORY(MODE,TYPE,A,N,M); VALUE MODE,TYPE; 00003102
INTEGER MODE,TYPE,N,M; ARRAY A[0]; 00003104
BEGIN 00003106
DEFINE T64= DI:=LOC T; DI:=DI+1; DS:=7 CHR#; 00003110
STREAM PROCEDURE WRITERECS(PAGE,A,SKP,NB,NR,NS,RL); 00003120
VALUE SKP,NB,NR,NS,RL; 00003130
BEGIN 00003140
COMMENT -- NS IS THE NUMBER OF WORDS TO SAVE (ON THE 00003150
TAIL OF THE PAGE); 00003160
LOCAL T,T1,T2,TT; 00003170
COMMENT -- MOVE TO POSITION FOR WRITE; 00003180
SI:=LOC NB; T64; SI:=PAGE; SKP(SI:=SI+8); 00003190
T(2(32(RL(SI:=SI+8)))); NB(RL(SI:=SI+8)); 00003200
T1:=SI; COMMENT -- RECORDS WILL BE WRITTEN HERE; 00003210
COMMENT -- SKIP OVER TO END OF RECORDS TO BE SAVED; 00003220
DI:=LOC TT; SI:=LOC NS; DI:=DI+1; DS:=7CHR; 00003230
SI:=T1; COMMENT MOVE TO THE END OF THE FIELD TO BE SAVED; 00003240
TT(2(32(RL(SI:=SI+8)))); NS(RL(SI:=SI+8)); 00003250
T2:=SI; COMMENT -- END OF FIELD TO BE SAVED; 00003260
SI:=LOC NR; T64; DI:=T2; 00003270
T(2(32(RL(DI:=DI+8)))); NR(RL(DI:=DI+8)); 00003280
SI:=T2; SI:=SI-8; DI:=DI-8; 00003290
TT(2(32(RL(DS:=WDS; SI:=SI-16; DI:=DI-16)))); 00003300
NS(RL(DS:=WDS; SI:=SI-16; DI:=DI-16)); 00003310
COMMENT -- HAVE ACCOMPLISHED THE "SAVE", NOW DO THE WRITE; 00003320
SI:=A; DI:=T1; 00003330
T(2(32(DS:=RL WDS))); NR(DS:=RL WDS) 00003340
END; 00003350
STREAM PROCEDURE READRECS(PAGE,A,SKP,NB,NR,NM,RL); 00003360
VALUE SKP,NB,NR,NM,RL; 00003370
BEGIN 00003380
COMMENT 00003390
SKP = "SKIP" - - THE NUMBER OF WORDS TO JUMP OVER 00003400
NB = "NUMBER BEFORE" -- " " RECORDS TO SKIP BEFORE 00003410
READING THE RECORD, 00003420
NR = "NUMBER OF RECORDS" " " " " READ FROM THE 00003430
BUFFER, 00003440
NM ="NUMBER TO MOVE" - - " " " " MOVE OVER TO 00003450
THE PREVIOUSLY READ AREA, 00003460
RL ="RECORD LENGTH" - - THE LENGTH OF EACH ITEM 00003470
; 00003480
LOCAL T,T1,T2; 00003490
SI:=LOC NB; T64; SI:=PAGE; SKP(SI:=SI+8); 00003500
T(2(32(RL(SI:=SI+8)))); NB(RL(SI:=SI+8)); 00003510
T1:=SI; 00003520
COMMENT - - T1 NOW HAS THE STARTING POSITION FOR THE READ; 00003530
SI:=LOC NR; T64; SI:=T1; DI:=A; 00003540
T(2(32(DS:=RL WDS))); NR(DS:=RL WDS); 00003550
T2:=SI; COMMENT T2 CONTAINS THE END OF THE READ; 00003560
SI:=LOC NM; T64; SI:=T2; DI:=T1; 00003570
T(2(32(DS:=RL WDS))); NM(DS:=RL WDS) 00003580
END READRECS; 00003590
DEFINE MOVEALONG= 00003600
DI:=LOC C; DI:=DI+6; DS:=2CHR; DI:=LOC Z; 00003610
TSI:=SI; TALLY:=TALLY+1; 00003620
IF TOGGLE THEN 00003630
BEGIN SI:=LOC C; SI:=SI+6; 00003640
IF 2 SC NEQ DC THEN 00003650
BEGIN TAL:=TALLY; SI:=LOC TAL; SI:=SI+7; 00003660
IF SC="0" THEN 00003670
BEGIN TALLY:=TMP; TALLY:=TALLY+1; TMP:=TALLY; 00003680
TALLY:=0; 00003690
END ELSE 00003700
BEGIN SI:=LOC Z; IF SC LEQ"9" THEN ; 00003710
END 00003720
END ELSE 00003730
BEGIN DI:=TDI; SI:=LOC SIZE; SI:=SI+6; DS:=2CHR; 00003740
TDI:=DI; SI:=SI-2; DI:=LOC C64; DI:=DI+7 ; DS:=CHR; 00003750
SI:=NEW; DI:=TDI; C64(2(DS:=32CHR)); DS:=SIZE CHR; 00003760
TDI:=DI; SI:=TSI; DI:=LOC C; DI:=DI+6; 00003770
DS:=2CHR; TSI:=SI; 00003780
TALLY:=TAL;CHRSTORE:=TALLY; SI:=LOC TMP; SI:=SI+7; 00003790
DI:=LOC CHRSTORE; DI:=DI+6; DS:=CHR END 00003800
END; 00003810
SI:=LOC C; DI:=LOC C64; DI:=DI+1; DS:=7CHR; DI:=TDI; SI:=SI-1; 00003820
DS:=2CHR; SI:=TSI; 00003830
C64(2(DS:=32CHR)); DS:=C CHR; TDI:=DI; TSI:=SI#; 00003840
INTEGER STREAM PROCEDURE CHRSTORE(A,SKP,B,NEW,NB,SIZE,NA,MODE, 00003850
PAGESIZE); VALUE SKP,NB,SIZE,NA,MODE,PAGESIZE; 00003860
BEGIN LOCAL T,C,TSI,TDI, 00003870
Z,C64,TMP,TAL; 00003880
LABEL DONE; 00003890
SI:=LOC NB; T64; 00003900
SI:=LOC MODE; SI:=SI+7; 00003910
IF SC="0" THEN ; COMMENT SET TOGGLE; 00003920
SI:=A; DI:=B; SKP(DS:=8CHR); 00003930
TSI:=SI; TDI:=DI; 00003940
T(2(32(MOVEALONG))); NB(MOVEALONG); 00003950
COMMENT NOW HAVE MOVED UP TO NB; 00003960
IF TOGGLE THEN 00003970
BEGIN TALLY:=TAL; CHRSTORE:=TALLY; SI:=LOC TMP; SI:=SI+7; 00003980
DI:=LOC CHRSTORE; DI:=DI+6; DS:=CHR; 00003990
SI:=LOC SIZE; SI:=SI+6; DI:=TDI; DS:=2CHR; TDI:=DI; 00004000
SI:=LOC SIZE; DI:=LOC C64; DI:=DI+1; DS:=7CHR; SI:=NEW; 00004010
DI:=TDI; C64(2(DS:=32CHR)); DS:=SIZE CHR; 00004020
END ELSE 00004030
BEGIN TSI:=SI; TDI:=DI; 00004040
SI:=LOC MODE; SI:=SI+7; 00004050
IF SC="1" THEN 00004060
COMMENT REMOVE AN ENTRY HERE; 00004070
BEGIN DI:=LOC C; DI:=DI+6; SI:=TSI; DS:=2CHR; 00004080
TSI:=SI; DI:=LOC C64; DI:=DI+1; SI:=LOC C; 00004090
DS:=7CHR; SI:=TSI; C64(2(SI:=SI+32)); SI:=SI+C; 00004100
TSI:=SI; DI:=LOC CHRSTORE; SI:=LOC C; DS:=WDS; 00004110
DI:=TDI; DS:=2LIT"0"; TDI:=DI; 00004120
END ELSE 00004130
IF SC="2" THEN 00004140
COMMENT READ OUT AN ENTRY; 00004150
BEGIN DI:=LOC C; DI:=DI+6; SI:=TSI; DS:=2CHR; 00004160
TSI:=SI; DI:=LOC C64; DI:=DI+1; SI:=LOC C; 00004170
DS:=7CHR; SI:=TSI; DI:=NEW; 00004180
C64(2(DS:=32CHR)); DS:=C CHR; 00004190
SI:=LOC C; DI:=LOC CHRSTORE; DS:=WDS; GO DONE END; 00004200
SI:=LOC NA; T64; SI:=TSI; DI:=TDI; 00004210
T(2(32(TDI:=DI; DI:=LOC C; DI:=DI+6; DS:=2CHR; 00004220
TSI:=SI; SI:=LOC C; DI:=LOC C64; DI:=DI+1; DS:=7CHR; 00004230
SI:=SI-1;DI:=TDI;DS:=2CHR;SI:=TSI;C64(2(DS:=32CHR));DS:=C CHR))); 00004240
NA( TDI:=DI; DI:=LOC C; DI:=DI+6; DS:=2CHR; TSI:=SI; 00004250
SI:=LOC C;DI:=LOC C64;DI:=DI+1;DS:=7CHR;SI:=SI-1; 00004260
DI:=TDI;DS:=2CHR;SI:=TSI;C64(2(DS:=32CHR));DS:=C CHR); 00004270
END; 00004280
SI:=LOC PAGESIZE; T64; SI:=B; DI:=A; 00004290
%CARD LIST UNSAFE 00004300
COMMENT $CARD LIST UNSAFE; 00004310
T(2(DS:=32WDS)); DS:=PAGESIZE WDS; 00004320
%CARD LIST SAFE 00004330
COMMENT $CARD LIST SAFE; 00004340
DONE: 00004350
END; 00004360
STREAM PROCEDURE SETNTH(P,K,N); VALUE K,N; 00004390
BEGIN DI:=P; SI:=LOC K; N(DI:=DI+8); DS:=WDS END; 00004400
BOOLEAN STREAM PROCEDURE LESS(A,AN,B,BN,K); VALUE K,AN,BN; 00004410
BEGIN 00004420
SI:=A; DI:=B; SI:=SI+AN; DI:=DI+BN; 00004430
IF K SC LSS DC THEN TALLY:=1; 00004440
LESS:=TALLY 00004450
END; 00004460
REAL STREAM PROCEDURE ADDD(A,B); VALUE A,B; 00004470
BEGIN SI:=LOC A; DI:=LOC B; DS:=8ADD; SI:=LOC B; 00004480
DI:=LOC ADDD; DS:=WDS 00004490
END; 00004500
INTEGER PROCEDURE FREEPAGE(INDEX,TYPEZERO,START,FINISH); 00004600
VALUE TYPEZERO,START,FINISH; INTEGER TYPEZERO,START,FINISH; 00004610
ARRAY INDEX[0,0]; 00004620
IF START GTR FINISH THEN MESSAGE(2) ELSE 00004630
BEGIN ARRAY T[0:RECSIZE+EXTRAROOM+SKIP-1],P[0:FINISH-START]; 00004640
INTEGER I,J,K,R; 00004650
R:=RECSIZE+EXTRAROOM+SKIP; 00004660
J:=START-(FINISH+1); 00004670
FOR I:=FINISH STEP -1 UNTIL TYPEZERO DO 00004680
IF K:=(I+J) LSS TYPEZERO THEN 00004690
BEGIN T[R-1]:=P[TYPEZERO-K-1]; 00004700
MOVE(T,R,INDEX[I,0]) 00004710
END ELSE 00004720
BEGIN IF I GEQ START THEN P[FINISH-I]:=INDEX[I,R-1]; 00004730
MOVE(INDEX[K,0],R,INDEX[I,0]); 00004740
END; 00004750
FREEPAGE:=TYPEZERO-J; 00004760
END; 00004770
INTEGER PROCEDURE SEARCHL(A,B,N,MIN,MAX,NP); VALUE N,MIN,MAX; 00004780
INTEGER N,MIN,MAX,NP; 00004790
ARRAY A[0,0]; REAL B; 00004800
BEGIN 00004810
INTEGER I,T; 00004820
FOR I:=MIN STEP 1 WHILE T:=T+A[I,0].CF LEQ B AND I LSS MAX-1 DO; 00004830
IF T LSS B THEN 00004840
BEGIN MESSAGE(3); SEARCHL:=NP:=0; 00004850
END ELSE 00004860
BEGIN SEARCHL:=I; NP:=B-T+A[I,0].CF 00004870
END 00004880
END; 00004890
PROCEDURE SORT(A,P,N,C); VALUE P,N,C; INTEGER P,N,C; 00004900
ARRAY A[0,0]; 00004910
BEGIN INTEGER R; 00004920
BEGIN 00004930
ARRAY T[0:R:=RECSIZE+EXTRAROOM+SKIP-1]; 00004940
LABEL ENDJ; 00004950
INTEGER I,J,L,K,M,SK; R:=R+1; 00004960
SK:=SKIP TIMES 8; 00004970
K:=N-P+1; I:=1; DO UNTIL (I:=I TIMES 2) GTR K; 00004980
M:=I-1; 00004990
WHILE (M:=M DIV 2) NEQ 0 DO 00005000
BEGIN K:=N-M; J:=P; 00005010
DO BEGIN 00005020
L:=(I:=J)+M; 00005030
DO BEGIN 00005040
IF A[L,0].TF GTR A[I,0].TF THEN GO ENDJ; 00005050
IF A[L,0].TF EQL A[I,0].TF THEN 00005060
IF NOT(LESS(A[L,0],SK,A[I,0],SK,C)) THEN 00005070
GO ENDJ; 00005080
MOVE(A[L,0],R,T); MOVE(A[I,0],R,A[L,0]); 00005090
MOVE(T,R,A[I,0]) 00005100
END UNTIL (I:=(L:=I)-M) LSS P; 00005110
ENDJ: 00005120
END UNTIL (J:=J+1) GTR K; 00005130
END 00005140
END 00005150
END SORT; 00005160
COMMENT - - - - - - - - - - - - - - - - - - - - - - - - - - 00005280
MODE MEANING 00005290
---- ------- 00005300
1 = INTERROGATE TYPE 00005310
2 = INSERT RECORD REL ADDRS N 00005320
(RELATIVE TO START OF LAST PAGE) 00005330
3 = RETURN THE NUMBER OF RECORDS (M) 00005340
4 = " ITEM AT RECORD # N 00005350
5 = INSERT " " " " " 00005360
6 = DELETE " " " " " 00005370
7 = SEARCH FOR THE RECORD -A- 00005380
8 = FILE OVERFLOW, INCREASE BY N 00005390
9 = FILE MAINTENANCE 00005400
10 = EMERGENCY FILE MAINTENANCE 00005410
11 SET STORAGE KIND 00005420
12= ALTER STORAGE ALLOCATION RESOURCES 00005430
13= RELEASE "TYPE" STORAGE TO SYSTEM 00005440
14= CLOSE ALL PAGES FOR AREA TRANSITION 00005450
NOTE THAT WHEN SEQUENTIAL STORAGE MAINTENANCE IS DONE, N 00005460
WILL ALWAYS INDICATE THE ADDRESS OF THE STRING RELATIVE TO 00005470
THE TYPE SPECIFIED, AND M WILL ALWAYS BE THE LENGTH OF THE 00005480
STRING IN -A- (EITHER AS INPUT OR OUTPUT) 00005490
; 00005500
PROCEDURE UPDATE(T,L,U,D); VALUE L,U,D; INTEGER L,U,D; 00005510
ARRAY T[0]; 00005520
BEGIN INTEGER I,J,K; 00005530
FOR I:=L STEP 1 UNTIL U DO 00005540
BEGIN J:=T[I].AF+D; T[I].AF:=J; 00005550
J:=T[I].BF+D; T[I].BF:=J 00005560
END 00005570
END; 00005580
OWN INTEGER CURPAGE,NPAGES,NTYPES,P,PS,U,L; 00005590
OWN INTEGER FIRST,AVAIL,MAXBUFF,CURBUFF; 00005600
REAL GT1; 00005605
LABEL MOREPAGES; 00005610
COMMENT 00005615
IF MEMBUG.[21:1] THEN DUMPMEMORY(MODE,TYPE,N,M); 00005620
IF MODE=8 THEN NPAGES:=NPAGES+N; 00005630
MOREPAGES: 00005670
BEGIN 00005680
OWN BOOLEAN POINTERSET, TYPESET; 00005690
INTEGER I, T, NR; 00005693
OWN ARRAY BUF[0:MBUFF], TYPS[0:511]; 00005697
OWN ARRAY INDX[0:NPAGES,0:RECSIZE+EXTRAROOM+SKIP-1]; 00005700
PROCEDURE SETTYPES; 00005702
BEGIN INTEGER I, T; 00005704
FOR I := 0 STEP 1 UNTIL NPAGES DO 00005706
IF INDX[I,0].TF NEQ T THEN 00005708
BEGIN 00005710
TYPS[T].BF := I; TYPS[T:=INDX[I,0].TF].AF := I; 00005712
TYPS[T].BOOL := INDX[I,0].MF; 00005714
END; 00005716
TYPS[T].BF := I; 00005718
END SETTYPES; 00005720
REAL PROCEDURE BUFFNUMBER(I); VALUE I; INTEGER I; 00005730
BEGIN INTEGER K,L,M; 00005740
LABEL D; 00005750
DEFINE B=BUF#; 00005760
IF( IF K:=INDX[I,P].BUFF=0 THEN TRUE ELSE BUF[K].PAGEF 00005770
NEQ INDX[I,P].PAGEF+1) THEN 00005780
BEGIN IF NULL(K:=CDR(AVAIL)) THEN 00005790
BEGIN K:=CDR(FIRST); 00005800
WHILE M:=CDR(B[K]) NEQ 0 DO 00005810
BEGIN L:=K; K:=M; END; 00005820
RPLACD(B[L],0); 00005830
IF BOOLEAN(B[K].CHANGEDBIT) THEN 00005840
WRITE(POINTERS[K][B[K].PAGEF-1]); 00005850
B[K].CHANGEDBIT:=0; 00005860
END ELSE RPLACD(AVAIL,CDR(B[K])); 00005870
B[K].PAGEF:=INDX[I,P].PAGEF+1; 00005880
INDX[I,P].BUFF:=K; 00005890
READ(POINTERS[K][INDX[I,P].PAGEF]); 00005900
END ELSE 00005910
IF CDR(FIRST)=K THEN GO TO D ELSE 00005920
BEGIN L:=CDR(FIRST); 00005930
WHILE M:=CDR(B[L]) NEQ K DO L:=M; 00005940
RPLACD(B[L],CDR(B[M])); 00005950
END; 00005960
RPLACD(B[K],CDR(FIRST)); RPLACD(FIRST,K); 00005970
D: BUFFNUMBER:=K 00005980
END; 00005990
PROCEDURE MARK(I); VALUE I; INTEGER I; 00006000
BUF[INDX[I,P].BUFF].CHANGEDBIT:=1; 00006010
BOOLEAN PROCEDURE WRITEBUFFER; 00006020
BEGIN INTEGER I; 00006030
I:=CDR(FIRST); 00006040
WHILE NOT NULL(I) DO 00006050
IF BOOLEAN(BUF[I].CHANGEDBIT) THEN 00006060
BEGIN WRITEBUFFER:=TRUE; 00006070
BUF[I].CHANGEDBIT:=0; 00006080
WRITE(POINTERS[I][BUF[I].PAGEF-1]); 00006090
RPLACD(I,0); 00006100
END ELSE I:=CDR(BUF[I]); 00006110
END; 00006120
IF NOT POINTERSET THEN 00006130
BEGIN LABEL EOF; 00006140
READ(POINTERS[1][NPAGES])[EOF]; 00006150
IF EOFMARK(SKIP,RECSIZE,POINTERS[1](0))THEN GO TO EOF; 00006160
MOVE(POINTERS[1](0),1,T); 00006170
COMMENT -- USE T TO DETERMIN THE VARIABLE REC SIZE LATER; 00006180
MOVE(POINTERS[1](0),RECSIZE+SKIP,INDX[NPAGES,0]); 00006190
INDX[NPAGES,RECSIZE+1].PAGEF:=NPAGES; 00006200
NPAGES:=NPAGES+1; 00006210
GO TO MOREPAGES; 00006220
COMMENT - - INTIALIZE VARIABLES; 00006230
EOF: POINTERSET:=TRUE; 00006240
U:=PAGESIZE-SKIP-PAGESPACE; 00006250
L:=(U-ALLOWANCE)/RECSIZE; 00006260
U:=(U+ALLOWANCE+RECSIZE/2)/RECSIZE; 00006270
PS:=(U+L)/2; 00006280
CURPAGE:=NPAGES:=NPAGES-1; 00006290
CURBUFF:=1; 00006300
P:=RECSIZE+SKIP; 00006310
FOR T:=1 STEP 1 UNTIL SBUFF DO RPLACD(BUF[T],T+1); 00006320
RPLACD(BUF[SBUFF],0); RPLACD(AVAIL,1); 00006330
MAXBUFF:=SBUFF; 00006340
T:=0; 00006350
SORT(INDX,0,NPAGES,RECSIZE TIMES 8); 00006360
FOR I:=0 STEP 1 UNTIL NPAGES DO 00006370
IF INDX[I,0].TF GTR T THEN T:=INDX[I,0].TF; 00006380
NTYPES:=T; 00006390
END; 00006400
IF TYPE GTR NTYPES THEN NTYPES:=TYPE; 00006410
IF NOT TYPESET THEN 00006550
BEGIN TYPESET:=TRUE; SETTYPES; 00006560
COMMENT 00006565
IF MEMBUG THEN DUMPINDEX(TYPS,NTYPES,INDX,RECSIZE, 00006570
P); 00006580
END; 00006590
COMMENT --- DECIDE WHETHER TO SAVE CURRENT PAGE BEFORE GOING ON; 00006600
IF MODE=2 THEN 00006610
BEGIN MODE:=5; NR:=N 00006620
END ELSE 00006630
IF MODE GEQ 4 THEN %MAY BE FILE MAINTENANCE 00006640
IF MODE GEQ 8 THEN %IS FILE MAINTENANCE 00006650
ELSE %WE MAY BE GOING TO 00006660
IF MODE NEQ 7 THEN %ANOTHER PAGE 00006670
BEGIN 00006680
IF TYPE=0 THEN BEGIN MESSAGE(4); MODE:=0 END ELSE 00006690
IF TYPS[TYPE].AF=TYPS[TYPE].BF THEN 00006700
IF TYPS[0].BF GTR 0 THEN 00006710
BEGIN INTEGER J,K; REAL PG; 00006720
K:=TYPS[0].BF-1; TYPS[0].BF:=K; PG:=INDX[K,P]; 00006730
FOR I:=1 STEP 1 UNTIL TYPE-1 DO 00006740
IF (T:=TYPS[I]).AF NEQ T.BF THEN 00006750
BEGIN FOR K:=T.AF STEP 1 UNTIL T.BF -1 DO 00006760
MOVE(INDX[K,0],P+EXTRAROOM,INDX[K-1,0]); 00006770
TYPS[I].AF:=T.AF-1; TYPS[I].BF:=K:=T.BF-1 00006780
END; 00006790
IF CURPAGE GTR TYPS[0].BF THEN 00006800
IF CURPAGE LEQ K THEN CURPAGE:=CURPAGE-1; 00006810
TYPS[TYPE].BF:=K+1; TYPS[TYPE].AF:=K; 00006820
INDX[K,P]:=PG; INDX[K,0]:=0; INDX[K,0].TF:=TYPE; 00006830
IF TYPS[TYPE].BOOL=1 THEN 00006840
BEGIN SETNTH(INDX[K,0],0,1); INDX[K,0].MF:=1 00006850
END; 00006860
COMMENT 00006865
IF MEMBUG.[22:1] THEN DUMPTYPES(MODE,TYPS,NTYPES); 00006870
MEMORY(MODE,TYPE,A,N,M); MODE:=0 00006880
END ELSE 00006890
BEGIN T:=1; MEMORY(8,TYPE,A,T,M); MEMORY(MODE,TYPE,A,N,M); 00006900
MODE:=0 00006910
END ELSE 00006920
IF NOT( BOOLEAN(TYPS[TYPE].BOOL) AND MODE=5) THEN 00006930
CURBUFF:=BUFFNUMBER(CURPAGE:= 00006940
SEARCHL(INDX,N,NPAGES,TYPS[TYPE].AF,TYPS[TYPE].BF, 00006950
NR) ); 00006960
COMMENT 00006965
IF MEMBUG.[23:1] THEN CHECKTYPES(TYPS,NTYPES); 00006970
END; 00006980
COMMENT 00006985
IF MEMBUG.[20:1] THEN DUMPINDEX(TYPS,NTYPES,INDX,RECSIZE,P); 00006990
COMMENT 00006995
IF MEMBUG.[24:1] THEN DUMPBUFF(BUF,FIRST,AVAIL); 00007000
CASE MODE OF 00007010
BEGIN 00007020
%------- MODE=0 ------- RESERVED --------------- 00007030
; 00007040
%------- MODE=1 ----------------------------------------------------00007050
IF M=0 THEN N:=TYPS[TYPE].BOOL ELSE 00007060
IF M=1 THEN 00007070
BEGIN FOR I:=1 STEP 1 UNTIL NTYPES DO 00007080
IF (T:=TYPS[I]).AF=T.BF THEN 00007090
BEGIN N:=I; I:=NTYPES+1 00007100
END; 00007110
IF I=NTYPES+1 THEN N:=NTYPES+1 00007120
END; 00007130
%------- MODE=2 ------- RESERVED --------------- 00007140
; 00007150
%------- MODE=3 ------- RETURN THE NUMBER OF RECORDS---- 00007160
BEGIN COMMENT IF TYPE LSS 0 THEN THE TOTAL NUMBER 00007170
OF PAGES IS GIVEN, OTHERWISE THE NUMBER OF "TYPE" PAGES IS 00007180
GIVEN; 00007190
FOR I:=0 STEP 1 UNTIL NPAGES DO 00007200
IF INDX[I,0].TF=TYPE OR TYPE LSS 0 THEN 00007210
NR:=NR+INDX[I,0].CF; 00007220
M:=NR 00007230
END; 00007240
%------- MODE=4 ------- RETURN ITEM AT SUBSCRIPT N ----- 00007250
IF NR GEQ INDX[CURPAGE,0].CF THEN MESSAGE(3) ELSE 00007252
IF BOOLEAN(TYPS[TYPE].BOOL) THEN COMMENT SEQUENTIAL STORAGE; 00007260
BEGIN ARRAY B[0:PAGESIZE]; 00007270
M:=CHRSTORE(POINTERS[CURBUFF](0),2,B,A,NR,0,0,2,0); 00007280
END ELSE 00007290
BEGIN 00007300
M:=RECSIZE|8; 00007310
READRECS(POINTERS[CURBUFF](0),A,SKIP,NR,1,0,RECSIZE); 00007320
END; 00007330
%------- MODE=5 ------- INSERT ITEM AT SUBSCRIPT N; 00007340
BEGIN INTEGER K,J,S; REAL PG; 00007350
IF BOOLEAN(TYPS[TYPE].BOOL) THEN 00007360
COMMENT FIND A PLACE FOR THE CHARACTER STRING OF LENGTH 00007370
M; 00007380
IF M GTR (PAGESIZE-SKIP-1)|8-2 THEN MESSAGE(5) COMMENT 00007390
THIS CHARACTER STRING IS TOO LONG ; ELSE 00007400
BEGIN ARRAY C[0:PAGESIZE]; 00007410
STREAM PROCEDURE ADDZERO(CHARS,POINTER); VALUE CHARS; 00007411
BEGIN LOCAL T; 00007412
SI:=LOC CHARS; DI:=LOC T; DI:=DI+1; DS:=7CHR; 00007413
DI:=POINTER; T(2(DI:=DI+32)); CHARS(DI:=DI+1); 00007415
DS:=2LIT"0"; 00007417
END; 00007419
BOOLEAN B,NOTLASTPAGE; 00007420
LABEL TRYITAGAIN; 00007425
TRYITAGAIN: 00007426
FOR I:=(T:=TYPS[TYPE]).AF STEP 1 WHILE I LSS T.BF AND 00007430
NOT B DO 00007440
IF NOT(B:=((PAGESIZE-SKIP-1)|8-(GT1:=INDX[I,0]).SF)GEQ M+2 00007450
AND NOT BOOLEAN(GT1.FF)) THEN S:=S+GT1.CF ELSE I:=I-1; 00007460
NOTLASTPAGE:=B AND I NEQ T.BF-1; 00007465
COMMENT IF B IS TRUE, THEN A PAGE HAS BEEN FOUND; 00007470
IF NOT B THEN COMMENT GET A PAGE THAT IS FREE; 00007480
BEGIN 00007490
COMMENT 00007495
IF MEMBUG.[5:1] THEN DUMPTYPES(5.1,TYPS,NTYPES); 00007500
IF TYPS[0].BF=0 THEN BEGIN K:=CURPAGE; T:=1; 00007510
MEMORY(8,TYPE,A,T,M); CURPAGE:=K+1 00007520
END 00007524
ELSE 00007526
IF (PAGESIZE-SKIP-1)|8-INDX[(I:=I-1)-1,0].SF GTR 2 THEN 00007528
BEGIN 00007529
CURBUFF:=BUFFNUMBER(CURPAGE:=I-1); 00007530
ADDZERO((GT1:=INDX[CURPAGE,0].SF)+8|(SKIP+1),POINTERS 00007531
[CURBUFF](0)); 00007532
INDX[CURPAGE,0].SF:=GT1+2; 00007533
INDX[CURPAGE,0].CF:=INDX[CURPAGE,0].CF+1; 00007534
COMMENT SINCE ALLOCATING A NEW PAGE, SET COUNT TO 00007535
ONE MORE AND FREEZE THE COUNT; 00007536
S:=S+1; % SINCE THE COUNT INCREASED 00007538
MOVE(INDX[CURPAGE,0],SKIP+1,POINTERS[CURBUFF](0)); 00007540
MARK(CURPAGE); 00007542
END; 00007544
T:=TYPS[0].BF; TYPS[0].BF:=T:=T-1; 00007546
COMMENT T IS THE SUBSCRIPT INTO THE NEW PAGE; 00007550
PG:=INDX[T,P]; COMMENT PG HOLDS THE NEW PAGE #; 00007560
FOR K:=T+1 STEP 1 UNTIL I DO 00007570
MOVE(INDX[K,0],RECSIZE+SKIP+EXTRAROOM,INDX[K-1,0]); 00007580
T:=TYPS[TYPE].AF; TYPS[TYPE].AF:=T-1; 00007590
INDX[I,P]:=PG; UPDATE(TYPS,1,TYPE-1,-1); 00007600
IF CURPAGE GTR TYPS[0].BF THEN IF CURPAGE LEQ 00007610
I THEN CURPAGE:=CURPAGE-1; 00007620
INDX[I,0]:=0; INDX[I,0].MF:=1; INDX[I,0].TF:=TYPE; 00007630
COMMENT MUST ALSO ASSIGN A NUMBER TO THIS PAGE 00007640
(TO BE STORED IN THE PAGE) TO KEEP IT IN SEQUENCE 00007650
WITHIN THIS TYPE; 00007660
IF (T:=TYPS[TYPE]).AF LSS T.BF-1 THEN 00007670
T:=INDX[T.BF-1,1] ELSE T:=0; 00007680
SETNTH(INDX[I,0],ADDD(1,T),1); 00007690
COMMENT END OF THE INITIALIZATION OF THE INDEX ARRAY, 00007700
WE STILL HAVE TO MAKE SOME ENTRIES INTO THE PAGE 00007710
WHICH WE WILL DO BELOW; 00007720
END OF TEST FOR NEW PAGE; 00007730
COMMENT I IS SET TO THE PROPER SUBSCRIPT FOR THE CHR STORE; 00007740
CURBUFF:=BUFFNUMBER(CURPAGE:=I); 00007750
COMMENT NOW THE CORRECT PAGE IS IN CORE. 00007760
------------------------------ 00007770
M= NUMBER OF CHARACTERS IN A (ON INPUT) 00007780
N= ADDRESS OF A WITHIN THIS TYPE (ON OUTPUT 00007790
------------------------------; 00007800
K:=INDX[I,0]; 00007810
T:=CHRSTORE(POINTERS[CURBUFF](0),SKIP+1,C,A,K.CF,M,0,0, 00007820
PAGESIZE); 00007830
COMMENT K.CF IS THE NUMBER OF ITEMS ALREADY IN THIS 00007840
PAGE. IF THERE IS A SEGMENT WHICH IS NULL, IT WILL 00007850
BE FOUND AND ASSIGNED AS THE SEG NUMBER FOR 00007860
THIS CHARACTER STRING (T). IF NOT, IT WILL STICK THE 00007870
STRING ON THE END (WE KNOW THERE IS ENOUGH ROOM 00007880
SINCE WE CHECKED INDX[I,0].SF -- THE NUMBER OF CHRS USED 00007890
IN THIS PAGE, OR WE CREATED A NEW PAGE); 00007900
N:=S+T; S:=K.SF; COMMENT S CONTAINS THE # OF CHRS USED UP; 00007910
IF T:=T+1 GTR K.CF THEN COMMENT ADDED THE STRING ON THE END; 00007920
IF NOTLASTPAGE THEN % PAGE ALREADY FULL 00007922
BEGIN S:=0; B:=FALSE; INDX[I,0].FF:=1; 00007925
MOVE(INDX[I,0],SKIP+1,POINTERS[CURBUFF](0)); 00007926
MARK(CURPAGE); GO TRYITAGAIN; END ELSE 00007927
BEGIN K.CF:=T; S:=S+2; 00007930
END 00007940
ELSE IF T=K.CF AND NOTLASTPAGE THEN INDX[I,0].FF:=1; 00007945
00007947
INDX[I,0].CF:=K.CF; INDX[I,0].SF:=S+M; 00007950
MOVE(INDX[I,0],SKIP+1,POINTERS[CURBUFF](0)); 00007960
MARK(CURPAGE); 00007970
COMMENT THE PAGE DESCRIPTOR HAS BEEN UPDATED; 00007980
COMMENT 00007985
IF MEMBUG.[5:1] THEN DUMPTYPES(5.2,TYPS,NTYPES); 00007990
END ELSE COMMENT KIND OF STORAGE IS SORTED; 00008000
IF NR GTR (T:=INDX[CURPAGE,0].CF) THEN 00008010
COMMENT SUBSCRIPT IS NOT IN THE MIDDLE OF THE PAGE; 00008020
MESSAGE(6) ELSE 00008030
BEGIN 00008040
IF T GEQ U THEN COMMENT WILL EXCEED UPPER PAGE BOUND; 00008050
BEGIN ARRAY B[0:RECSIZE TIMES 00008060
(T-PS+(I:=(IF NR GEQ PS THEN 0 ELSE 1)))-1]; 00008070
COMMENT B IS JUST BIG ENOUGH TO CARRY THE 00008080
EXCESS FROM THE OLD PAGE; 00008090
READRECS(POINTERS[CURBUFF](0),B,SKIP,PS-I, 00008100
J:=(T-PS+I),0,RECSIZE); 00008110
COMMENT -- B NOW HAS THE EXCESS; 00008120
INDX[CURPAGE,0].CF:=T-J; SETNTH(POINTERS[CURBUFF](0), 00008130
INDX[CURPAGE,0],0); 00008140
MARK(CURPAGE); 00008150
IF TYPS[0].BF=0 THEN 00008160
BEGIN K:=CURPAGE; T:=1; 00008170
MEMORY(8,TYPE,A,T,M); CURPAGE:=K+1; 00008180
END; 00008190
COMMENT -- ASSIGN A FREE PAGE (SUBS T); 00008200
T:=TYPS[0].BF; TYPS[0].BF:=T:=T-1; 00008210
00008220
PG:=INDX[T,P]; 00008230
FOR K:=T+1 STEP 1 UNTIL CURPAGE DO 00008240
MOVE(INDX[K,0],RECSIZE+SKIP+EXTRAROOM,INDX[K-1,0]); 00008250
INDX[CURPAGE,P]:=PG; 00008260
T:=0;T.CF:=J;T.TF:=TYPE; 00008262
CURBUFF:=BUFFNUMBER(CURPAGE); 00008270
WRITERECS(POINTERS[CURBUFF](0),B,SKIP,0,J,0,RECSIZE); 00008280
SETNTH(POINTERS[CURBUFF](0),T,0); 00008290
MOVE(POINTERS[CURBUFF](0),RECSIZE+SKIP,INDX[CURPAGE,0]); 00008300
MARK(CURPAGE); 00008310
T:=TYPS[TYPE].AF; TYPS[TYPE].AF:=T-1; 00008320
UPDATE(TYPS,1,TYPE-1,-1); 00008330
IF J=0 THEN MESSAGE(7); 00008340
IF BOOLEAN (I) THEN 00008350
COMMENT I=0 IMPLIES THE RECORD GOES TO NEW PAGE, 00008360
I=1 IMPLIES THE RECORD GOES TO NOOLD PAGE; 00008370
BEGIN 00008380
T:=INDX[CURPAGE:=CURPAGE-1,0].CF; 00008390
CURBUFF:=BUFFNUMBER(CURPAGE); 00008400
; COMMENT OLD PAGE IS NOW BACK; 00008410
END ELSE 00008420
BEGIN T:=J; NR:=NR-PS 00008430
END 00008440
END; 00008450
WRITERECS(POINTERS[CURBUFF](0),A,SKIP,NR,1,T-NR,RECSIZE); 00008460
T:=INDX[CURPAGE,0].CF; INDX[CURPAGE,0].CF:=T+1; 00008470
SETNTH(POINTERS[CURBUFF](0),INDX[CURPAGE,0],0); 00008480
IF NR=0 THEN MOVE(POINTERS[CURBUFF](0),RECSIZE+SKIP,INDX 00008490
[CURPAGE,0]); MARK(CURPAGE); 00008500
END; 00008510
END; 00008520
%------- MODE=6 ------- DELETE A RECORD FROM THE FILE ---- 00008530
IF (T:=TYPS[TYPE]).AF=T.BF THEN MESSAGE(12) COMMENT 00008540
ATTEMPT TO DELETE NON-EXISTENT STORAGE; 00008550
ELSE 00008560
IF NR GEQ(I:=INDX[CURPAGE,0].CF) THEN MESSAGE(13) COMMENT 00008570
ATTEMPT TO DELETE OUTSIDE STORAGE RANGE; ELSE 00008580
IF BOOLEAN(T.BOOL) THEN COMMENT SEQUENTIAL STORAGE; 00008590
BEGIN COMMENT NR IS THE RECORD TO DELETE; 00008600
ARRAY B[0:PAGESIZE-1]; 00008610
COMMENT PAGESIZE -1 SHOULD BE COMPUTED TO THE EXACT 00008620
NUMBER OF WORDS TO MOVE -- IT WOULD SPEED THINGS UP; 00008630
INTEGER L; 00008640
T:=INDX[CURPAGE,0]; COMMENT T.CF IS THE NUMBER OF 00008650
RECORDS ON THIS PAGE, T.SF IS THE NUMBER OF CHRS; 00008660
L:=CHRSTORE(POINTERS[CURBUFF](0),SKIP+1,B,A,NR,0,T.CF 00008670
-NR-1,1,PAGESIZE); 00008680
COMMENT WE WILL BRING BACK THE NUMBER OF CHRS IN M; 00008690
M:=L; 00008700
MARK(CURPAGE); 00008710
COMMENT MAKE CHANGES TO THE CHARACTER COUNT; 00008720
INDX[CURPAGE,0].SF:=T.SF-L; 00008730
INDX[CURPAGE,0].FF:=0; % PAGE IS CERTAINLY NOT FULL NOW 00008737
COMMENT AND WE ARE DONE WITH THE DELETION; 00008740
MOVE(INDX[CURPAGE,0],SKIP+1,POINTERS[CURBUFF](0)); 00008745
END 00008750
ELSE 00008760
BEGIN ARRAY A[0:RECSIZE-1]; 00008770
INDX[CURPAGE,0].CF:=I-1; 00008780
SETNTH(POINTERS[CURBUFF](0),INDX[CURPAGE,0],0); 00008790
IF I GTR 1 THEN 00008800
BEGIN 00008810
READRECS(POINTERS[CURBUFF](0),A,SKIP,NR,1,I-NR-1,RECSIZE); 00008820
MARK(CURPAGE); 00008830
IF NR=0 THEN 00008840
MOVE(POINTERS[CURBUFF](0),RECSIZE+SKIP,INDX[CURPAGE,0]) 00008850
END ELSE COMMENT FREE THE EMPTY PAGE; 00008860
BEGIN MARK(CURPAGE); 00008870
;TYPS[0].BF:=FREEPAGE(INDX,TYPS[0].BF,CURPAGE,CURPAGE); 00008880
UPDATE(TYPS,1,TYPE-1,1); TYPS[TYPE].AF:=T.AF+1; 00008890
COMMENT 00008895
IF MEMBUG.[6:1] THEN DUMPTYPES(MODE,TYPS,NTYPES); 00008900
END 00008910
END; 00008920
%------- MODE=7 ------- SEARCH FOR A RECORD FROM THE FILE --- 00008930
IF N GTR 3 THEN MESSAGE(14) ELSE 00008940
COMMENT RETURN RECORD CLOSEST (BUT LESS THAN OR EQUAL TO) TO 00008950
THE CONTENTS OF -A-. A WILL BE REPLACED BY THE RECORD FOUND; 00008960
IF BOOLEAN((I:=TYPS[TYPE]).BOOL) THEN 00008970
MESSAGE(8) COMMENT BINARY SEARCH OF NON-SEQUENTIAL DATA; 00008980
ELSE 00008990
IF I.AF=I.BF THEN MESSAGE(9) COMMENT --NO STORAGE OF 00009000
THIS TYPE ALLOCATED AS YET; 00009010
ELSE BEGIN 00009020
INTEGER F,U,L; 00009030
ARRAY B[0:RECSIZE-1]; 00009040
U:=TYPS[TYPE].BF; L:=TYPS[TYPE].AF; 00009050
WHILE U-L GTR 1 DO 00009060
IF LESS(A,0,INDX[F:=(U+L) DIV 2,0],8,M) THEN U:=F ELSE L:=F; 00009070
CURBUFF:=BUFFNUMBER(CURPAGE:=L); 00009080
L:=0; U:=INDX[CURPAGE,0].CF; 00009090
IF L-U=0 THEN MESSAGE(10) COMMENT BINARY SEARCH FOUND 00009100
A PAGE WITH NO RECORDS; 00009110
ELSE BEGIN 00009120
WHILE U-L GTR 1 DO 00009130
BEGIN READRECS(POINTERS[CURBUFF](0),B,SKIP, 00009140
F:=(U+L) DIV 2,1,0,RECSIZE); 00009150
IF LESS(A,0,B,0,M) THEN U:=F ELSE L:=F 00009160
END; 00009170
COMMENT ----------------------------------- 00009180
ON INPUT: 00009190
N=0 IMPLIES DO NOT PLACE RECORD INTO FILE 00009200
IF RECORD IS FOUND. RETURN RELA- 00009210
TIVE POSITION OF THE CLOSEST RECORD 00009220
IN THIS PAGE. 00009230
N=1 " DO NOT PLACE IN FILE. RETURN ABSO- 00009240
LUTE SUBSCRIPT OF CLOSSEST RECORD. 00009250
N=2 " PLACE RECORD INTO FILE IF NOT FOUND. 00009260
RETURN RELATIVE POSITION OF RECORD. 00009270
N=3 " PLACE RECORD INTO FILE, IF NOT 00009280
FOUND, RETURN ABS SUBSCRIPT OF 00009290
THE RECORD. 00009300
ON OUTPUT: 00009310
M=0 " RECORD FOUND WAS EQUAL TO RECORD 00009320
SOUGHT. 00009330
M=1 " RECORD FOUND WAS GREATER THAN THE 00009340
SOUGHT. 00009350
M=2 " RECORD FOUND WAS LESS THAN THE 00009360
RECORD SOUGHT. 00009370
; 00009380
READRECS(POINTERS[CURBUFF](0),B,SKIP,L,1,0,RECSIZE); 00009390
IF LESS(A,0,B,0,M) THEN M:=1 ELSE 00009400
IF LESS(B,0,A,0,M) THEN M:=2 ELSE 00009410
M:=0; 00009420
T:=0; IF BOOLEAN(N) THEN 00009430
FOR I:=TYPS[TYPE].AF STEP 1 UNTIL CURPAGE-1 DO 00009440
T:=T+INDX[I,0].CF; 00009450
IF N GTR 1 THEN IF M GEQ 1 THEN 00009460
MEMORY(2,TYPE,A,L+M-1,NR); 00009470
MOVE(B,RECSIZE,A); 00009480
N:=T+L; 00009490
END 00009500
END; 00009510
%------- MODE=8 ------- FILE OVERFLOW, FIX ARRAYS AND PAGES 00009520
BEGIN BOOLEAN TOG; 00009530
ARRAY A[0:PAGESIZE-1]; T:=NPAGES-N+1; 00009540
IF TOG:=(T DIV AREASIZE) LSS (NPAGES DIV AREASIZE ) OR 00009550
(T=NPAGES AND T MOD AREASIZE =0) THEN 00009560
MEMORY(14,TYPE,A,N,M); 00009570
FOR I:=T STEP 1 UNTIL NPAGES DO 00009580
BEGIN WRITE(NEWDISK[I],PAGESIZE,A[*]);INDX[I,P].PAGEF:=I END; 00009590
MARKEOF(SKIP,RECSIZE,NEWDISK(0)); 00009600
WRITE(NEWDISK[I]); 00009610
TYPS[0].BF:=FREEPAGE(INDX,TYPS[0].BF,T,NPAGES); 00009620
UPDATE(TYPS,1,NTYPES,NPAGES-T+1); 00009630
IF TOG THEN CLOSE(NEWDISK); 00009640
END; 00009650
%------- MODE=9 ------- FILE MAINTENANCE ------------------ 00009660
BEGIN BOOLEAN ITHPAGEIN; 00009670
INTEGER I,J,K,T1,T2,T3,M,W,Q; 00009680
ARRAY A,B[0:PAGESIZE-1]; 00009690
COMMENT 00009700
MONITOR PRINT(Q,W,N, I,J,K,T1,T2,T3,M,A,B); 00009710
IF I:=TYPS[0].BF LEQ NPAGES THEN 00009720
DO 00009730
BEGIN COMMENT OUTER "DO-LOOP" TO FIND TROUBLE WITH 00009740
THE FILE; 00009750
IF T1:=(Q:=INDX[I,0]).CF LSS L THEN COMMENT MAY BE CORRECTABLE; 00009760
IF NOT BOOLEAN((Q:=TYPS[Q.TF]).BOOL) THEN 00009770
COMMENT -- THIS PAGE IS CORRECTABLE; 00009780
IF I NEQ NPAGES THEN 00009790
COMMENT -- THIS IS NOT THE LAST PAGE OF THE FILE; 00009800
IF (J:=I+1) LSS Q.BF THEN 00009810
COMMENT -- THIS IS NOT THE LAST PAGE OF THIS TYPE; 00009820
BEGIN COMMENT -- FIND RECORDS TO MOVE INTO 00009830
THIS PAGE; 00009840
DO IF T2:=INDX[J,0].CF GTR 0 THEN 00009850
COMMENT THIS PAGE HAS RECS TO MOVE; 00009860
BEGIN COMMENT HOW MANY; 00009870
IF T2 LSS K:=PS-T1 THEN K:=T2; 00009880
IF NOT ITHPAGEIN THEN 00009890
BEGIN COMMENT BRING IN PAGE I; 00009900
MOVE(POINTERS[BUFFNUMBER(I)](0), 00009910
PAGESIZE,B); ITHPAGEIN:=TRUE 00009920
END; 00009930
COMMENT -- BRING IN PAGE J; 00009940
CURBUFF:=BUFFNUMBER(CURPAGE:=J); 00009950
COMMENT -- MOVE SOME INTO A; 00009960
READRECS(POINTERS[CURBUFF](0),A,SKIP,0,K, 00009970
T2:=T2-K,RECSIZE); INDX[J,0].CF:=T2; 00009980
IF T2=0 THEN 00009990
COMMENT SET THIS PAGE FREE; 00010000
INDX[J,0]:=0; 00010010
SETNTH(POINTERS[CURBUFF](0),INDX[J,0],0); 00010020
MOVE(POINTERS[CURBUFF](0),RECSIZE+SKIP,INDX[J 00010030
,0]); MARK(CURPAGE); 00010040
COMMENT -- PUT THE RECORDS INTO PAGE I; 00010050
WRITERECS(B,A,SKIP,T1,K,0,RECSIZE); 00010060
END 00010070
ELSE K:=0 COMMENT SINCE NO CONTRI- 00010080
BUTION; 00010090
UNTIL T1:=T1+K GEQ PS OR J:=J+1 GEQ Q.BF; 00010100
INDX[I,0].CF:=T1; B[0]:=INDX[I,0]; 00010110
COMMENT -- PUT THE PAGE BACK OUT ON DISK; 00010120
MOVE(B,RECSIZE+SKIP,INDX[I,0]); 00010130
MOVE(B,PAGESIZE,POINTERS[CURBUFF:=BUFFNUMBER 00010140
(I)](0)); SORT(INDX,0,NPAGES,RECSIZE|8); 00010150
MARK(CURPAGE:=I); SETTYPES; 00010160
N:=1; 00010170
END 00010180
ELSE N:=0 COMMENT LAST PAGE OF THIS TYPE; 00010190
ELSE N:=0 COMMENT LAST PAGE OF FILE; 00010200
ELSE N:=0 COMMENT PAGE CANNOT BE CHANGED; 00010210
ELSE N:=0 COMMENT THIS PAGE IS NOT TOO SMALL; 00010220
END UNTIL I:=I+1 GTR NPAGES OR N NEQ 0 ELSE N:=0; 00010230
IF I GTR NPAGES THEN N:=REAL(WRITEBUFFER); 00010240
END OF FILE UPDATE; 00010250
%------- MODE=10 ------ EMERGENCY FILE MAINTENANCE -------- 00010260
DO MEMORY(9,TYPE,A,N,M) UNTIL N NEQ 1 00010270
%------- MODE=11 ------- SET THE KIND OF STORAGE FOR TYPE ----------00010280
;COMMENT TYPE "TYPE" STORAGE IS BEING SET TO SEQUENTIAL; 00010290
IF TYPE=0 THEN MESSAGE(4) ELSE 00010300
IF (T:=TYPS[TYPE]).AF= T.BF THEN TYPS[TYPE].BOOL:=1 ELSE 00010310
MESSAGE(15); COMMENT ATTEMPT TO CHANGE KINDS IN MIDSTREAM; 00010320
%------- MODE=12 ----------- ALTER STORAGE ALLOCATION RESOURCES--- 00010330
COMMENT N IS THE "FACTOR" (PERCENT OF RESOURCES | 100), 00010340
AND M IS THE STORAGE "LEVEL" (0 IS THE ONLY ONE THAT 00010350
DOES ANYTHING ON THE B5500); 00010360
BEGIN INTEGER J,K; 00010370
BOOLEAN TOG; 00010380
IF T:=N|(MBUFF-1)/100+1 GTR MAXBUFF THEN 00010390
BEGIN COMMENT ADD TO AVAILABLE LIST; 00010400
FOR I:=CDR(FIRST),CDR(AVAIL) DO 00010410
WHILE NOT NULL(I) DO 00010420
BEGIN BUF[I].FLAGB:=1; I:=CDR(BUF[I]); 00010430
END; 00010440
FOR I:=MAXBUFF+1 STEP 1 UNTIL T DO 00010450
BEGIN WHILE BUF[K:=K+1].FLAGB=1 DO; 00010460
BUF[K]:=0; RPLACD(BUF[K],CDR(AVAIL)); 00010470
RPLACD(AVAIL,K) 00010480
END; 00010490
MAXBUFF:=T; 00010500
FOR I:=1 STEP 1 UNTIL MBUFF DO BUF[I].FLAGB:=0; 00010510
END ELSE 00010520
IF T LSS MAXBUFF THEN 00010530
BEGIN COMMENT CUT DOWN ON THE NUMBER OF BUFFERS; 00010540
I:=CDR(FIRST); 00010550
FOR J:=1 STEP 1 UNTIL MAXBUFF DO 00010560
IF TOG THEN 00010570
IF NOT NULL(I) THEN 00010580
IF J GEQ T THEN 00010590
BEGIN K:=CDR(BUF[I]); BUF[I]:=0 00010600
; I:=K END 00010610
ELSE I:=CDR(BUF[I]) 00010620
ELSE 00010630
ELSE 00010640
IF TOG:=NULL(I) THEN 00010650
BEGIN J:=J-1; I:=CDR(AVAIL) 00010660
END 00010670
ELSE 00010680
IF J EQL T THEN 00010690
BEGIN K:=CDR(BUF[I]); RPLACD(BUF[I],0); 00010700
I:=K END ELSE 00010710
IF J GTR T THEN 00010720
BEGIN 00010730
IF BOOLEAN(BUF[I].CHANGEDBIT) THEN 00010740
WRITE(POINTERS[I][BUF[I].PAGEF-1]); 00010750
K:=CDR(BUF[I]); 00010760
CLOSE(POINTERS[I]); 00010770
BUF[I]:=0; I:=K 00010780
END ELSE I:=CDR(BUF[I]) 00010790
; 00010800
MAXBUFF:=T 00010810
END; 00010820
END; 00010830
%------- MODE=13 ------- RELEASE "TYPE" STORAGE TO SYSTEM ----------00010840
IF (T:=TYPS[TYPE]).BF GTR T.AF THEN 00010850
BEGIN INTEGER J; 00010860
J:=T.BF-1; 00010870
FOR I:=T.AF STEP 1 UNTIL J DO 00010880
BEGIN CURBUFF:=BUFFNUMBER(I); 00010890
SETNTH(POINTERS[CURBUFF](0),0,0); MARK(CURPAGE:=I); 00010900
END; 00010910
TYPS[0].BF:=FREEPAGE(INDX,TYPS[0].BF,T.AF,J); 00010920
UPDATE(TYPS,1,TYPE-1,J-T.AF+1); 00010930
TYPS[TYPE].BF:=T.AF; TYPS[TYPE].BOOL:=0; 00010940
END; 00010990
%------- MODE=14 ------ RELEASE ALL PAGES FOR TRANSITION -----------00011000
BEGIN INTEGER K; 00011010
I:=CDR(FIRST); 00011020
WHILE NOT NULL(I) DO 00011030
BEGIN IF BOOLEAN(BUF[I].CHANGEDBIT ) THEN WRITE(POINTERS[I] 00011040
[BUF[I].PAGEF-1]); CLOSE(POINTERS[I]); 00011050
K:=CDR(BUF[I]); BUF[I]:=0; 00011060
RPLACD(BUF[I],CDR(AVAIL)); RPLACD(AVAIL,I); I:=K 00011070
END ; CURPAGE:=CURBUFF:=-1; RPLACD(FIRST,0); 00011080
END; 00011090
END OF CASE STMT; 00011100
00011110
END OF INNER BLOCK; 00011120
END OF PROCEDURE; 00011130
INTEGER QM,QN; 00011330
ARRAY QA[0:0]; 00011340
PROCEDURE NAME(MFID,FID); VALUE MFID,FID; REAL MFID,FID; 00011350
BEGIN INTEGER I; FILL NEWDISK WITH MFID,FID; 00011360
FOR I:=0 STEP 1 UNTIL MBUFF DO 00011370
FILL POINTERS[I] WITH MFID,FID; 00011380
FILL ESTABLISH WITH MFID,FID; 00011390
SETPOINTERNAMES 00011400
END; 00011410
PROCEDURE SEQUENTIAL(UNIT); VALUE UNIT; INTEGER UNIT; 00011420
MEMORY(11,UNIT,QA,QN,QM); 00011430
INTEGER PROCEDURE CONTENTS(UNIT,N,AR); VALUE UNIT,N; 00011440
INTEGER UNIT,N; ARRAY AR[0]; 00011450
BEGIN 00011460
MEMORY(4,UNIT,AR,N,QM); CONTENTS:=QM; 00011510
END; 00011560
PROCEDURE DELETE1(UNIT,N); VALUE UNIT,N; INTEGER UNIT,N; 00011570
MEMORY(6,UNIT,QA,N,QM); 00011630
INTEGER PROCEDURE SEARCHORD(UNIT,REC,LOC,M); VALUE UNIT,M; 00011650
INTEGER UNIT,LOC,M; ARRAY REC[0]; 00011660
BEGIN LOC:=1; 00011670
MEMORY(7,UNIT,REC,LOC,M); 00011730
SEARCHORD:=M; 00011800
END; 00011810
PROCEDURE STOREORD(UNIT,REC,N); VALUE UNIT,N; INTEGER UNIT,N; 00011820
ARRAY REC[0]; 00011830
MEMORY(5,UNIT,REC,N,QM); 00011900
PROCEDURE STOREORDR(UNIT,REC,N); VALUE UNIT,N; INTEGER UNIT,N; 00011920
ARRAY REC[0]; 00011930
MEMORY(2,UNIT,REC,N,QM); 00011940
BOOLEAN PROCEDURE MAINTENANCE; 00011950
BEGIN MEMORY(9,0,QA,QN,QM); MAINTENANCE:=QN=1 00011960
END; 00011970
PROCEDURE WRAPUP; MEMORY(10,0,QA,QN,QM); 00011980
INTEGER PROCEDURE STORESEQ(UNIT,REC,N); VALUE UNIT,N; INTEGER UNIT, N; 00011990
ARRAY REC[0]; 00012000
BEGIN 00012010
MEMORY(5,UNIT,REC,QN,N); STORESEQ:=QN; 00012070
END; 00012100
PROCEDURE DELETEN(UNIT,N,M); VALUE UNIT,N,M; INTEGER UNIT,N,M; 00012110
BEGIN M:=M-N; 00012120
DO MEMORY(6,UNIT,QA,N,QM) UNTIL M:=M-1 LSS 0; 00012130
END; 00012140
INTEGER PROCEDURE NEXTUNIT; 00012420
BEGIN MEMORY(1,0,QA,QN,1); NEXTUNIT:=QN 00012430
END; 00012440
INTEGER PROCEDURE SIZE(UNIT); VALUE UNIT; INTEGER UNIT; 00012450
BEGIN MEMORY(3,UNIT,QA,QN,QM); SIZE:=QM 00012460
END; 00012470
PROCEDURE ALLOCATE(J,FACTOR); VALUE J,FACTOR; INTEGER J; 00012570
REAL FACTOR; 00012580
BEGIN 00012590
QN:=ENTIER( ABS( (FACTOR | 100) MOD 101)); 00012600
MEMORY(12,0,QA,QN,J) 00012610
END; 00012620
PROCEDURE RELEASEUNIT(UNIT); VALUE UNIT; INTEGER UNIT; 00012630
MEMORY(13,UNIT,QA,QN,QM); 00012640
DEFINE 00013000
ALLOWQUESIZE=4#, 00013010
ACOUNT=ACCUM[0].[1:11]#, 00013020
DATADESC=[1:1]#, 00013022
SCALAR=[4:1]#, 00013030
NAMED=[3:1]#, 00013040
CHRMODE=[5:1]#, 00013042
CHECKT=5#, % NUMBER OF TIMES THRU EXECUTE BEFORE CHECK 00013050
CCIF=18:36:12#, 00013060
CDID=1:43:5#, 00013070
CSPF=30:30:18#, 00013080
CRF=24:42:6#, 00013090
CLOCF=6:30:18#, 00013092
PF=[1:17]#, 00013100
XEQMODE=1#, 00013110
FUNCMODE=2#, 00013112
CALCMODE=0#, 00013114
INPUTMODE=3#, 00013116
ERRORMODE=4#, 00013118
FUNCTION=1#, 00013120
CURRENTMODE = PSRM[0]#, 00013130
VARIABLES = PSRM[1]#, 00013140
VARSIZE = PSRM[2]#, 00013150
FUNCPOINTER = PSRM[3]#, 00013160
FUNCSEQ = PSRM[4]#, 00013170
CURLINE = PSRM[5]#, 00013180
STACKBASE = PSRM[6]#, 00013182
INCREMENT=STACKBASE#, %FUNCMODE/CALCMODE 00013183
SYMBASE = PSRM[7]#, 00013184
FUNCSIZE=SYMBASE#, %FUNCMODE/CALCMODE 00013185
USERMASK = PSRM[8]#, 00013186
SEED = PSRM[10]#, 00013187
ORIGIN = PSRM[11]#, 00013188
FUZZ = PSRM[12]#, 00013189
FSTART=9#, %PSR[9] IS WHERE NAME OF CURRENTLY EDITED FCN GOES 00013190
PSRSIZE = 13#, 00013200
PSR = PSRM[*]#, 00013202
WF=[18:8]#, 00013210
WDSPERREC=10#, 00013220
WDSPERBLK=30#, 00013230
NAREAS=10#, 00013240
SIZEAREAS=210#, 00013250
LIBF1=[6:15]#, 00013260
LIBF2=[22:16]#, 00013270
LIBF3=[38:10]#, 00013275
LIBSPACES=1#, 00013280
IDENT=RESULT=1#, 00014000
SPECIAL=RESULT=3#, 00015000
NUMERIC=RESULT=2#, 00016000
REPLACELOC=0#, 00016050
REPLACEV=4#, 00017000
SPF=[30:18]#, 00017100
RF=[24:6]#, 00017110
DID=[1:5]#, 00017120
XRF=[12:18]#, 00017130
DDPNSW=30#, % DATA DESC PRESENT NAMED SCALAR WORD 00017132
DDNNVW=20#, %DATA DESC NON-PRES NAMED VECTOR WORD 00017134
DDNUVW=16#, %DATA DESC NONPRES..(POINTS INTO SYM TAB FOR LOCALS) 00017136
DDPUVW=24#, % DATA DESC PRESENT UNNAMED VECTOR WORD 00017140
DDNNSW=22#, % DATA DESC NON-PRES NAMED SCALAR WORD 00017142
PDC=10#, % PROG DESC CALC MODE 00017144
INTO=0#, 00017150
DDPUSW=26#, % DATA DESC PRESENT UNNAMED SCALAR WORD (MODE) 00017152
DDPUSC=27#, % DATA DESC PRESENT UNNAMED SCALAR CHR 00017154
DDPUVC=25#, % DATA DESC PRESENT UNNAMED VECTOR CHR 00017156
DDPNVC=29#, %DATA DESC PRES PERMANENT VECTOR CHAR MODE 00017157
DDPNVW=28#, %DATA DESC PRES NAMED VEC WORD (NAMED=PERMANENT) 00017158
OUTOF=1#, 00017160
NAMEDNULLV=0&7[1:45:3]#, %KLUDGE...NAMED VERSION OF NULLV 00017161
BACKP=[6:18]#, 00017170
SCALARDATA=0#, 00017200
ARRAYDATA=2#, 00017202
DATATYPE=[4:1]#, 00017204
ARRAYTYPE=[5:1]#, 00017206
CHARARRAY=1#, 00017208
NUMERICARRAY=0#, 00017210
BLOCKSIZE=30#, %#WORDS OF CONTIGUOUS DATA IN SEQUENTIAL STORE 00017220
VARTYPE=[42:6]#, 00017222
WS=WORKSPACE#, 00017224
DIMPTR=SPF#, 00017226
INPTR=BACKP#, 00017228
QUADIN=[18:3]#, 00017230
QUADINV=18:45:3#, 00017234
STATEVECTORSIZE=16#, 00017240
SUSPENDED=[5:1]#, 00017250
SUSPENDVAR=[2:1]#, 00017252
CTYPEF=3:45:3#, 00017254
CSUSVAR=2:47:1#, 00017256
CNAMED=3:47:1#, 00017258
MAXWORDSTORE=3960#, %APL PREVENTS CREATION OF ARRAYS BIGGER THAN 00017260
%3960 ELEMENTS. THIS NUMBER IS THE PRODUCT OF 00017262
%4,(NUMBER OF POINTERS TO SEQUENTIAL STORE 00017264
%BLOCKS THAT ARE STORED IN ONE WORD) 00017266
%30, (BLOCKSIZE), 00017268
%AND 33, (SIZE OF ARRAY USED TO STORE THESE 00017270
%POINTERS IN GETARRAY, MOVEARRAY, AND 00017272
%RELEASEARRAY). SUBSCRIPTS ALLOWS 8|3960 00017274
%ELEMENTS IF THEY ARE CHARACTERS. 00017276
%HOWEVER, SP WILL GET FULL BEFORE THAT SINCE 00017278
%BIGGEST SP SIZE IS CURRENTLY 3584 00017280
MAXBUFFSIZE=30#, 00018000
MAXHEADERARGS=30#, 00018100
BUFFERSIZE=BUFFSIZE#, 00019000
LINEBUFFER=LINEBUFF#, 00020000
LINEBUFF = OUTBUFF[*]#, 00020100
APPENDTOBUFFER=APPENDTOBUFF#, 00021000
FOUND=TARRAY[0]#, 00022000
EOB=TARRAY[1]#, 00023000
MANT=TARRAY[2]#, 00024000
MANTLEN=TARRAY[3]#, 00025000
FRAC=TARRAY[4]#, 00026000
FRACLEN=TARRAY[5]#, 00027000
POWER=TARRAY[6]#, 00028000
POWERLEN=TARRAY[7]#, 00029000
MANTSIGN=TARRAY[8]#, 00029100
TABSIZE = 43#, 00030000
LOGINCODES=1#, 00030100
LOGINPHRASE=2#, 00030200
LIBRARY=1#, 00030210
WORKSPACEUNIT=2#, 00030220
RTPAREN=9#, 00030300
MASTERMODE=USERMASK.[1:1]#, 00030400
EDITOG=USERMASK.[2:1]#, 00030401
POLBUG=USERMASK.[3:1]#, 00030402
FPTF=9#, % FUNCTION POINTER FIELD (STARTS AT CHR POS 9) 00030403
FSQF=11#, % FUNCTION SEQNTL FIELD 00030404
FFL=2#, % FUNCTION FIELD LENGTH (2 CHR POSITIONS) 00030406
CRETURN=3:47:1#, 00030407
RETURNVALUE=[3:1]#, 00030408
CNUMBERARGS=4:46:2#, 00030409
NUMBERARGS=[4:2]#, 00030410
RETURNVAL=1#, 00030411
NOSYNTAX=USERMASK.[4:1]#, 00030412
LINESIZE=USERMASK.[41:7]#, 00030414
DIGITS=USERMASK.[37:4]#, 00030416
SUSPENSION=USERMASK.SUSPENDED#, 00030418
SAVEDWS=USERMASK.[7:1]#, 00030419
DELTOG=USERMASK.[6:1]#, 00030420
DELCHR="$"#, %USED IN DELPRESENT (IN FUNCTIONHANDLER) 00030422
MAXMESS=27#, 00030500
USERTOP=21#, 00030510
MARGINSIZE=6#, 00030600
LFTBRACKET=SPECIAL AND ACCUM[0]=11#, 00030610
QUADV=SPECIAL AND ACCUM[0]=10#, 00030620
QUOTEV=ACCUM[0]=20#, 00030622
EXPANDV=38#, 00030623
SLASHV=6#, 00030624
GOTOV=5#, 00030626
DOTV=17#, 00030627
ROTV=37#, 00030628
RGTBRACKET=SPECIAL AND ACCUM[0]=12#, 00030630
DELV=SPECIAL AND ACCUM[0]=13#, 00030640
PLUS = SPECIAL AND ACCUM[0] = 48#, 00030650
MINUS = SPECIAL AND ACCUM[0] = 49#, 00030660
NEGATIVE = SPECIAL AND ACCUM[0] = 51#, 00030665
TIMES = SPECIAL AND ACCUM[0] = 50#, 00030670
LOGS = SPECIAL AND ACCUM[0] = 54#, 00030672
SORTUP = SPECIAL AND ACCUM[0] = 55#, 00030674
SORTDN = SPECIAL AND ACCUM[0] = 56#, 00030675
NAND = SPECIAL AND ACCUM[0] = 58#, 00030676
NOR = SPECIAL AND ACCUM[0] = 59#, 00030677
TAKE = SPECIAL AND ACCUM[0] = 60#, 00030678
DROPIT = SPECIAL AND ACCUM[0] = 61#, 00030679
LFTARROW = SPECIAL AND ACCUM[0] = 04#, 00030680
TRANS = SPECIAL AND ACCUM[0] = 05#, 00030690
SLASH = SPECIAL AND ACCUM[0] = 06#, 00030700
INTDIVIDE = SPECIAL AND ACCUM[0] = 07#, 00030710
LFTPAREN = SPECIAL AND ACCUM[0] = 08#, 00030720
RGTPAREN = SPECIAL AND ACCUM[0] = 09#, 00030730
QUOTEQUAD = SPECIAL AND ACCUM[0] = 14#, 00030740
SEMICOLON = SPECIAL AND ACCUM[0] = 15#, 00030750
COMMA = SPECIAL AND ACCUM[0] = 16#, 00030760
DOT = SPECIAL AND ACCUM[0] = 17#, 00030770
STAR = SPECIAL AND ACCUM[0] = 18#, 00030780
AT = SPECIAL AND ACCUM[0] = 19#, 00030790
QUOTE = SPECIAL AND ACCUM[0] = 20#, 00030800
BOOLAND = SPECIAL AND ACCUM[0] = 21#, 00030810
BOOLOR = SPECIAL AND ACCUM[0] = 22#, 00030820
BOOLNOT = SPECIAL AND ACCUM[0] = 23#, 00030830
LESSTHAN = SPECIAL AND ACCUM[0] = 24#, 00030840
LESSEQ = SPECIAL AND ACCUM[0] = 25#, 00030860
EQUAL = SPECIAL AND ACCUM[0] = 26#, 00030870
GRTEQ = SPECIAL AND ACCUM[0] = 27#, 00030880
GREATER = SPECIAL AND ACCUM[0] = 28#, 00030890
NOTEQ = SPECIAL AND ACCUM[0] = 29#, 00030900
CEILING = SPECIAL AND ACCUM[0] = 30#, 00030910
FLOOR = SPECIAL AND ACCUM[0] = 31#, 00030920
STICK = SPECIAL AND ACCUM[0] = 32#, 00030930
EPSILON = SPECIAL AND ACCUM[0] = 33#, 00030940
RHO = SPECIAL AND ACCUM[0] = 34#, 00030950
IOTA = SPECIAL AND ACCUM[0] = 35#, 00030960
TRACE = SPECIAL AND ACCUM[0] = 36#, 00030970
PHI = SPECIAL AND ACCUM[0] = 37#, 00030980
EXPAND = SPECIAL AND ACCUM[0] = 38#, 00030981
BASVAL = SPECIAL AND ACCUM[0] = 39#, 00030982
EXCLAMATION = SPECIAL AND ACCUM[0] = 40#, 00030983
MINUSLASH = SPECIAL AND ACCUM[0] = 41#, 00030984
QUESTION = SPECIAL AND ACCUM[0] = 42#, 00030985
OSLASH = SPECIAL AND ACCUM[0] = 43#, 00030986
TAU = SPECIAL AND ACCUM[0] = 44#, 00030987
CIRCLE = SPECIAL AND ACCUM[0] = 45#, 00030988
LOCKIT =IDENT AND ACCUM[0]="4LOCK "#, 00030989
COLON = SPECIAL AND ACCUM[0] = 47#, 00030990
QUADLFTARROW=51#, 00030992
REDUCT=52#, 00030993
ROTATE=53#, 00030994
SCANV=57#, 00030995
LINEBUFFSIZE=17#, 00031000
MAXPOLISH=100#, MESSIZE=10#, 00031002
MAXCONSTANT=30#, 00031004
MAXMEMACCESSES=3584#, %MAXSPROWS | SPRSIZE 00031005
MAXSYMBOL=30#, 00031006
MAXSPROWS=28#, 00031007
TYPEFIELD=[3:3]#, 00031008
OPTYPE=[1:2]#, 00031009
LOCFIELD=BACKP#, 00031010
ADDRFIELD=SPF#, 00031012
SYMTYPE=[3:3]#, 00031013
OPERAND=5#, 00031014
CONSTANT=2#, 00031016
OPERATOR=3#, 00031018
LOCALVAR=4#, 00031019
SYMTABSIZE=1#, 00031020
LFTPARENV=8#, 00031022
RGTPARENV=9#, 00031024
LFTBRACKETV=11#, 00031026
RGTBRACKETV=12#, 00031028
SEMICOLONV=15#, 00031030
QUAD=10#, 00031032
QQUAD=14#, 00031033
LFTARROWV=4#, 00031034
SORTUPV=55#, 00031035
SORTDNV=56#, 00031036
ALPHALABEL=1#, 00031040
NUMERICLABEL=2#, 00031050
NEXTLINE=0#, 00031060
ERRORCOND=3#, 00031062
PRESENCE=[2:1]#, 00031070
CHANGE=[1:1]#, 00031080
XEQ=1#, 00031090
CLEARCORE=2#, 00031092
WRITECORE=3#, 00031094
%%% 00031096
%%% 00031098
XEQUTE=1#, 00031100
SLICE=120#, %TIME SLICE IN 60THS OF A SECOND 00031102
ALLOC=2#, 00031104
WRITEBACK=3#, 00031106
LOOKATSTACK=5#, 00031108
00031110
LEN=[1:23]#, 00032000
NEXT=[24:24]#, 00032002
LOC=L.[30:11],L.[41:7]#, 00032004
NOC=N.[30:11],N.[41:7]#, 00032008
MOC=M.[30:11],M.[41:7]#, 00032010
SPRSIZE=128#, % SP ROW SIZE 00032015
NILADIC=0#, 00032020
MONADIC=1#, 00032030
DYADIC=2#, 00032040
TRIADIC=3#, 00032050
DEPTHERROR=1#, 00032100
DOMAINERROR=2#, 00032110
INDEXERROR=4#, 00032120
LABELERROR=5#, 00032130
LENGTHERROR=6#, 00032140
NONCEERROR=7#, 00032150
RANKERROR=8#, 00032160
SYNTAXERROR=9#, 00032170
SYSTEMERROR=10#, 00032180
VALUEERROR=11#, 00032190
SPERROR=12#, 00032200
KITEERROR=13#, 00032201
STREAMBASE=59823125#, 00032204
APLOGGED=[10:1]#, 00032230
APLHEADING=[11:1]#, 00032231
CSTATION = STATION#, 00032232
CAPLOGGED=10:47:1#, 00032234
CAPLHEADING=11:47:1#, 00032236
APLCODE = STATIONPARAMS#, 00032238
00032240
00032250
SPECMODE = BOUNDARY.[1:3]#, 00032260
DISPLAYING=1#, 00032270
EDITING=2#, 00032280
DELETING=3#, 00032290
RESEQUENCING=4#, 00032291
LOWER = BOUNDARY.[4:22]#, 00032292
UPPER = BOUNDARY.[26:22]#, 00032294
OLDBUFFER = OLDINPBUFFER[*]#, 00032800
00032850
ENDEFINES=#; 00032900
REAL ADDRESS, ABSOLUTEADDRESS, 00033000
LADDRESS; 00033100
BOOLEAN LINETOG; %GO TO NEXT LINE IF TRUE WHEN WRITING OUT 00034000
INTEGER BUFFSIZE,ITEMCOUNT,RESULT, 00035000
LOGINSIZE, 00035100
%%% 00035200
ERR, 00035300
NROWS, 00036000
%%% 00036010
CUSER; 00036020
LABEL ENDOFJOB,TRYAGAIN; 00036100
REAL GT1,GT2,GT3; 00036110
DEFINE LINE=PRINT#; 00037000
SAVE ARRAY BUFFER[0:MAXBUFFSIZE]; 00038000
ARRAY TARRAY[0:8], 00039000
COMMENT PROGRAM STATE REGISTER; 00039100
PSRM[0:PSRSIZE], 00039110
OLDINPBUFFER[0:MAXBUFFSIZE], 00039120
SP[0:27, 0:SPRSIZE-1], 00039200
IDTABLE[0:TABSIZE], 00040000
MESSTAB[0:MAXMESS], 00040100
JIGGLE[0:0], 00040200
SCR[0:2], 00041000
CORRESPONDENCE[0:7], 00041120
ACCUM[0:MAXBUFFSIZE]; 00042000
DEFINE OUTBUFFSIZE=29#,CLOGGED=7:47:1#,STU=15:9:9#; 00042715
ARRAY OUTBUFF[0:OUTBUFFSIZE]; 00042720
ALPHA STATION, JOBNUM, STATIONPARAMS, BOUNDARY; 00042730
INTEGER CHRCOUNT, WORKSPACE; 00042740
00042910
STREAM PROCEDURE INITBUFF(B,BUFFSIZE); VALUE BUFFSIZE; 00043000
BEGIN 00044000
DI~B; BUFFSIZE(DS~8LIT" "); DS~LIT"~"; 00045000
END; 00046000
STREAM PROCEDURE TRANSFER(A,AS,B,BS,L); VALUE AS,BS,L; 00046200
BEGIN LOCAL T,U,V; 00046210
SI:=LOC AS; DI:=LOC T; DI:=DI+1; DS:=7CHR; 00046220
SI:=LOC BS; DI:=LOC U; DI:=DI+1; DS:=7CHR; 00046230
SI:=LOC L; DI:=LOC V; DI:=DI+1; DS:=7CHR; 00046232
SI:=A; T(2(SI:=SI+32)); SI:=SI+AS; 00046240
DI:=B; U(2(DI:=DI+32)); DI:=DI+BS; 00046250
V(2(DS:=32CHR)); DS:=L CHR; 00046260
END; 00046270
REAL PROCEDURE NUMBER; FORWARD; %LINE 111500 00046275
BOOLEAN PROCEDURE SCAN; 00046280
BEGIN 00046284
REAL STREAM PROCEDURE GNC(ADDR,ACC); VALUE ADDR; 00046290
BEGIN SI:=ADDR; DI:=ACC; DI:=DI+7; DS:=CHR; GNC:=SI; 00046300
DI:=ACC; SKIP DB; DS:=SET; END OF GNC; 00046310
REAL STREAM PROCEDURE RESWD(TAB,BUF,ADDR,EOB,FOUND,K); 00047000
VALUE ADDR,K; 00048000
BEGIN 00049000
LOCAL T,TSI,TDI; 00050000
LABEL TRY,L,KEEPGOING,FINIS,RESTORE; 00051000
LABEL NUMBERFOUND; 00051100
DI:=EOB; DS:=8LIT"0"; DI:=FOUND; DS:=8LIT"0"; 00052000
SI:=ADDR; 00053000
L: IF SC NEQ " " THEN GO TO KEEPGOING; 00054000
SI:=SI+1; 00055000
GO TO L; 00056000
KEEPGOING: 00057000
RESWD:=SI; 00058000
ADDR:=SI; 00059000
IF SC GEQ "0" THEN IF SC LEQ "9" THEN GO TO NUMBERFOUND; 00059050
IF SC="#" THEN GO TO NUMBERFOUND; 00059100
IF SC="@" THEN GO TO NUMBERFOUND; 00059800
IF SC="." THEN 00059810
BEGIN SI:=SI+1; 00059820
IF SC GEQ "0" THEN IF SC LEQ "9" THEN 00059830
GO TO NUMBERFOUND; SI:=SI-1; 00059840
END; 00059900
DI:=LOC T; DS:=2RESET; DS:=2SET; DS:=2RESET; 00060000
DI:=LOC T; 00061000
IF SC=DC THEN 00062000
BEGIN DI:=EOB; DI:=DI+7; DS:=LIT"1"; 00063000
GO TO FINIS 00064000
END; 00065000
SI:=TAB; TSI:=SI; 00066000
TRY: 00067000
IF SC="0" THEN 00068000
BEGIN SI:=ADDR; 00069000
IF SC=ALPHA THEN 00070000
IF SC GEQ"0" THEN 00071000
IF SC LEQ "9" THEN 00072000
NUMBERFOUND: 00072100
TALLY:=2 ELSE TALLY := 0 00072200
ELSE TALLY:=1 00073000
ELSE TALLY:=3; 00074000
T:=TALLY; SI:=LOC T; SI:=SI+7; DI:=FOUND; DI:=DI+7; 00075000
DS:=CHR; GO FINIS; 00076000
END; 00077000
DI:=LOC T; DI:=DI+7; DS:=CHR; 00078000
DI:=ADDR; 00079000
IF T SC=DC THEN 00080000
BEGIN 00081000
TSI:=SI; TDI:=DI; SI:=SI-1; 00082000
IF SC=ALPHA THEN 00083000
BEGIN DI:=DI+16; SI:=TDI; 00084000
IF SC NEQ " " THEN IF SC =ALPHA THEN ; 00085000
END; 00086000
SI:=TSI; 00087000
END ELSE GO TO RESTORE; 00088000
IF TOGGLE THEN 00089000
RESTORE: 00090000
BEGIN SI:=SI+K; DI:=ADDR; GO TO TRY 00091000
END; 00092000
DI:=FOUND; DS:=K OCT; 00093000
DI:=TDI; RESWD:=DI; 00094000
FINIS: 00095000
END; 00095100
REAL STREAM PROCEDURE ACCUMULATE(ACC,EOB,ADDR); VALUE ADDR; 00095110
BEGIN LOCAL T; LABEL EOBL,E,ON,L; 00095120
DI:=ACC; 9(DS:=8LIT" "); 00095130
DI:=EOB; DS:=8LIT"0"; SI:=ADDR; DI:=LOC T; SKIP 2 DB; 00095140
DS:=2SET; DI:=LOC T; 00095150
63(IF SC=ALPHA THEN TALLY:=TALLY+1 ELSE JUMP OUT TO E; 00095160
SI:=SI+1); 00095170
L: IF SC=ALPHA THEN BEGIN SI:=SI+1; GO L END ELSE GO ON; 00095180
IF SC=" " THEN GO ON; 00095190
E: IF SC = DC THEN ; 00095200
SI:=SI-1; IF TOGGLE THEN GO TO EOBL ELSE GO ON; 00095210
EOBL: DI:=EOB; DI:=DI+7; DS:=LIT"1"; 00095220
ON: ACCUMULATE:=SI; DI:=ACC; T:=TALLY; SI:=LOC T; SI:=SI+6; 00095230
DS:=2CHR; SI:=ADDR; DS:=T CHR; 00095240
END OF ACCUMULATE; 00095250
BOOLEAN STREAM PROCEDURE ARROW(ADDR,I); VALUE ADDR,I; 00095260
BEGIN SI:=ADDR; SI:=SI-1; DI:=LOC I; DI:=DI+7; 00095270
IF SC=DC THEN TALLY:=1; ARROW :=TALLY 00095280
END OF ARROW; 00095290
IF NOT BOOLEAN(EOB) THEN BEGIN 00095300
LADDRESS:=ADDRESS; 00095310
ADDRESS:=RESWD(IDTABLE,BUFFER,ADDRESS,EOB,FOUND,2); 00095330
IF RESULT:=FOUND NEQ 0 THEN BEGIN 00095340
IF RESULT=1 THEN ADDRESS:=ACCUMULATE(ACCUM,EOB,ADDRESS) 00095350
ELSE IF RESULT=2 THEN ACCUM[0]:=NUMBER 00095360
ELSE IF RESULT=3 THEN ADDRESS:=GNC(ADDRESS,ACCUM) 00095370
ELSE BEGIN ACCUM[0]:=RESULT; RESULT:=3 END; 00095380
ITEMCOUNT:=ITEMCOUNT+1; 00095390
SCAN:=TRUE; 00095400
IF ARROW(ADDRESS,31) THEN 00095410
BEGIN EOB:=1; SCAN:=FALSE END; 00095420
END ELSE EOB:=1; 00095430
END; 00095440
END OF THE SCAN PROCEDURE; 00095450
PROCEDURE FORMROW(CC,BL,A,S,N); VALUE CC,BL,S,N; 00096000
INTEGER CC,BL,S,N; ARRAY A[0]; FORWARD 00096100
; 00096200
PROCEDURE INDENT(R); VALUE R; REAL R; FORWARD; 00096300
PROCEDURE TERPRINT; FORWARD; 00096400
PROCEDURE PROCESS(MODE);VALUE MODE;INTEGER MODE; FORWARD; 00096500
REAL STREAM PROCEDURE ABSADDR(A); 00097000
BEGIN SI:=A; ABSADDR:=SI 00098000
END; 00099000
BOOLEAN PROCEDURE LIBRARIAN(MFID,FID); VALUE MFID,FID; 00099100
REAL MFID,FID; 00099110
BEGIN 00099120
REAL ARRAY A[0:6]; FILE DF DISK(1,1); 00099125
REAL T; 00099130
COMMENT LIBRARIAN IS TRUE IF MFID/FID IS PRESENT ON DISK; 00099137
FILL DF WITH MFID,FID; 00099140
SEARCH(DF,A[*]); 00099145
LIBRARIAN:= 00099150
A[0]!-1; 00099160
END; 00099170
FILE SPO 11(1,3); 00099300
PROCEDURE SPOUT(K); VALUE K; INTEGER K; 00099310
BEGIN FORMAT ERRF("APL ERROR:",I8,A1); 00099320
WRITE(SPO,ERRF,K,31); 00099330
END; 00099340
PROCEDURE INITIALIZETABLE; 00100000
BEGIN DEFINE STARTSEGMENT= #; 00101000
INTEGER I; 00101005
LADDRESS:= 00101010
ABSOLUTEADDRESS:=ABSADDR(BUFFER); 00101100
BIGGEST := REAL(NOT FALSE) & 0[1:46:2]; 00101200
NULLV := 0 & 3[1:46:2]; 00101300
STATUSWORD~REAL(BOOLEAN(STATUSWORD) OR BOOLEAN(1)); 00101400
JOBNUM~TIME(-1); 00101410
STATION~0&1[CLOGGED]&STATUSWORD[STU]; 00101420
FILL JIGGLE[*] WITH OCT5757575757575737;%CARRIAGE RETURNS LEFT ARROW00101430
FILL IDTABLE[*] WITH 00102000
"1+481-49", "1&501%07", "1.171@19", "1#411(08", 00103000
"1)091/06", "3XEQ623L", "OG541;15", OCT0333777601040177, 00103100
%LAST IN ABOVE LINE IS REALLY 3["]141" 00103200
"202:=042", "[]101[11", "1]123AND", "212OR223", 00103300
"NOT233LS", "S243LEQ2", "53GEQ273", "GTR283NE", "Q292=:05", 00103350
"2GO051=2", "63MAX304", "CEIL303F", "LR313MIN", 00103400
"314RESD3","23ABS323","RHO341*1","84IOTA35", 00103500
"1|384RND", "M425TRAN", "S431$133", "PHI374FA", 00103600
"CT404COM", "B406CIRC", "LE456SOR", "TUP556SO", 00103700
"RTDN561:", "474NAND5", "83NOR594", "TAKE604D", 00103800
"ROP613RE", "P446BASV", "AL393EPS", "331,1600"; 00103900
COMMENT IDTABLE IS TABLE OF RESERVED WORDS AND SPECIAL SYMBOLS. 00103910
FORMAT IS NUMBER OF CHARACTERS IN SYMBOL, FOLLOWED BY SYMBOL 00103913
ITSELF, FOLLOWED BY A TWO-DIGIT DECIMAL CODE WHICH APL USES 00103916
FOR THE RESERVED WORD--LIKE IN THE EXECUTION CASE STATEMENT AND 00103919
IN SYNTAX CHECKING. FOR SCAN TO WORK, THE TW0-DIGIT CODE MUST 00103922
BE GREATER THAN 3 AND IDTABLE MUST HAVE AT LEAST ONE "0" AT THE 00103925
END TO MARK THE END. TABSIZE IS THE DEFINE (LINE 30000) GIVING 00103928
THE SIZE OF IDTABLE; 00103931
IF STACKSIZE=0 THEN STACKSIZE:=100 ELSE 00103940
IF STACKSIZE GTR 1022 THEN STACKSIZE:=1022; 00103950
BUFFSIZE:=MAXBUFFSIZE; 00104000
LINETOG := TRUE; %USUALLY GO TO NEXT LINE WHEN WRITING OUT 00104010
00104100
INITBUFF(OUTBUFF, 10); 00104500
INITBUFF(BUFFER,BUFFSIZE); 00105000
NROWS:=-1; 00105010
NAME(LIBJOB,TIME(-1)); 00105100
FILL MESSTAB[*] WITH 00105200
"4SAVE ", 00105210
"4LOAD ", 00105220
"5CLEAR ", 00105230
"4COPY ", 00105240
"4VARS ", 00105250
"3FNS ", 00105260
"6LOGGED", 00105270
"3MSG ", 00105280
"5WIDTH ", 00105290
"3OPR ", 00105300
"6DIGITS", 00105310
"3OFF ", 00105320
"6ORIGIN", 00105322
"4SEED ", 00105324
"4FUZZ ", 00105326
"3SYN ", 00105328
"5NOSYN ", 00105330
"5STORE ", 00105332
"5ABORT ", 00105340
"2SI ", 00105350
"3SIV ", 00105360
"5ERASE ", 00105370
%--------------MASTERMODE BELOW HERE...(SEE USERTOP)-------- 00105380
"6ASSIGN", 00105390
"6DELETE", 00105400
"4LIST ", 00105410
"5DEBUG ", 00105420
"5FILES "; 00105440
00106000
IF LIBSIZE=-1 THEN 00106090
BEGIN LIBSIZE~1;GTA[0]~" ";STOREORD(LIBRARY,GTA,0);WRAPUP; 00106091
END ELSE BEGIN LIBSIZE~SIZE(LIBRARY); 00106093
FOR I~1 STEP 1 UNTIL LIBSIZE-1 DO 00106094
BEGIN GT1~CONTENTS(LIBRARY,I,ACCUM); 00106095
IF NOT LIBRARIAN(ACCUM[0],TIME(-1)) THEN 00106096
BEGIN DELETE1(LIBRARY,I);LIBSIZE~LIBSIZE-1;END; 00106099
IF (LOGINSIZE:=SIZE(LOGINCODES)=0) THEN 00106100
END; 00106102
END; 00106104
FILL CORRESPONDENCE[*] WITH 00106500
OCT1111111111110311, 00106510
OCT1111111111111111, 00106520
OCT1104111121221113, 00106530
OCT2014151617100706, 00106540
OCT1111111111111112, 00106550
OCT1111111111111100, 00106560
OCT0201111111251111, 00106570
OCT2324111111111111; 00106571
COMMENT CORRESPONDENCE GIVES THE CORRESPONDENCE BETWEEN THE 00106573
APL CODES FOR DYADIC SCALAR OPERATORS (EXCEPT CIRCLE) AND 00106575
THEIR POSITIONS IN THE "CASE STATEMENT" IN "OPERATION". 00106577
E.G. APL CODE 7 IS "OPERATION" CODE 3 IN OCTAL (FOR DIVIDE). 00106579
IF N-TH CHARACTER IN CORRESPONDENCE IS OCTAL 11, THEN N 00106581
IS NOT AN APL CODE FOR A DYADIC SCALAR OPERATOR. CHARACTER 00106583
COUNT STARTS AT 1 FOR FIRST CHARACTER. TO MAKE IT COME OUT 00106584
RIGHT, STREAM PROCEDURE GETOP IS ACTUALLY CALLED WITH APL 00106586
OPERATION CODE MINUS 1; 00106588
END; 00107000
REAL STREAM PROCEDURE CONV(ADDR,N); 00108000
VALUE N,ADDR; 00108500
BEGIN SI:=ADDR; 00109000
DI:=LOC CONV; 00109500
DS:=N OCT; END; 00110000
REAL STREAM PROCEDURE BUMP(ADDR,N); VALUE ADDR,N; 00110500
BEGIN SI:=ADDR; SI:=SI+N; BUMP:=SI; END; 00111000
REAL PROCEDURE NUMBER; 00111500
BEGIN REAL NCHR; 00112000
LABEL GETFRAC,GETPOWER,QUIT,KITE; 00112500
MONITOR EXPOVR; 00113000
REAL PROCEDURE INTCON(COUNT); VALUE COUNT; 00113500
REAL COUNT; 00114000
BEGIN REAL TLO,THI,T; INTEGER N; 00114500
BOOLEAN DPTOG; DEFINE ADDR=ADDRESS#; 00115000
COMMENT: VALUE OF INTCON IS THE CONVERSION OF AN INTEGER 00115500
CONSISTING OF COUNT NUMERICAL CHARACTERS STARTING 00116000
AT THE CHARACTER ADDRESS. ADDRESS IS SET TO POINT 00116500
TO THE NEXT CHARACTER DURING INTCON; 00117000
DPTOG:=COUNT GTR 8; 00117500
THI:=T:=CONV(ADDR,N:=COUNT MOD 8); 00118000
ADDR:=BUMP(ADDR,N); 00118500
COUNT:=COUNT DIV 8; 00119000
FOR N:=1 STEP 1 UNTIL COUNT DO BEGIN 00119500
IF DPTOG THEN BEGIN 00120000
DOUBLE(THI,TLO,100000000.0,0,|,CONV(ADDR,8), 00120500
0,+,:=,THI,TLO); 00121000
T:=THI 00121500
END ELSE T:=T|100000000 + CONV(ADDR,8); 00122000
ADDR:=BUMP(ADDR,8); END; 00122500
INTCON:=T; 00123000
END OF INTCON; 00123500
INTEGER STREAM PROCEDURE SUBSCAN(ADDR,NEXT); VALUE ADDR; 00124000
BEGIN SI:=ADDR; 00124500
63(IF SC GEQ "0" THEN 00125000
IF SC LEQ "9" THEN BEGIN SI:=SI+1; TALLY:=TALLY+1; 00125500
END ELSE JUMP OUT); 00126000
DI:=NEXT; DI:=DI+7; DS:=1 CHR; SUBSCAN:=TALLY; 00126500
END; 00127000
COMMENT--VALUE OF SUBSCAN IS NUMBER OF NUMERIC CHARACTERS 00127500
FOUND. NEXT CONTAINS THE FIRST NON-NUMERIC CHARACTER; 00128000
EXPOVR:=KITE; 00128500
MANTSIGN:=1; 00129000
MANT:=MANTLEN:=POWER:=POWERLEN:=FRAC:=FRACLEN:=0; 00129500
MANTLEN:=SUBSCAN(ADDRESS,NCHR); 00130000
IF MANTLEN=0 AND NCHR="#" THEN BEGIN 00130500
MANTSIGN:=-1; 00131000
ADDRESS:=BUMP(ADDRESS,1); 00131500
MANTLEN:=SUBSCAN(ADDRESS,NCHR); END; 00132000
IF MANTLEN=0 THEN BEGIN ADDRESS:=BUMP(ADDRESS,1); 00132500
IF NCHR="." THEN GO TO GETFRAC 00133000
ELSE IF NCHR="@" OR NCHR="E" THEN GO TO GETPOWER 00133500
ELSE BEGIN ERR:=SYNTAXERROR; 00134000
GO TO QUIT; END; END; 00134500
MANT:=INTCON(MANTLEN); 00135000
IF NCHR="." THEN BEGIN ADDRESS:=BUMP(ADDRESS,1); GO GETFRAC END; 00135500
IF NCHR="@" OR NCHR="E" THEN BEGIN 00136000
ADDRESS:=BUMP(ADDRESS,1); GO TO GETPOWER END; 00136500
IF NCHR=12 THEN EOB:=1; 00137000
GO TO QUIT; 00137500
GETFRAC: FRACLEN:=SUBSCAN(ADDRESS,NCHR); 00138000
IF FRACLEN=0 THEN BEGIN ERR:=SYNTAXERROR; GO TO QUIT; END; 00138500
FRAC:=INTCON(FRACLEN); 00139000
IF NCHR="@" OR NCHR="E" THEN BEGIN 00139500
ADDRESS:=BUMP(ADDRESS,1); GO TO GETPOWER; END; 00140000
IF NCHR=12 THEN EOB:=1 ELSE 00140500
IF NCHR="." OR NCHR="#" THEN ERR:=SYNTAXERROR; 00141000
GO TO QUIT; 00141500
GETPOWER: 00142000
POWERLEN:=SUBSCAN(ADDRESS,NCHR); 00142500
IF POWERLEN=0 THEN BEGIN 00143000
IF NCHR="-" OR NCHR="#" THEN POWER:=-1 00143500
ELSE IF NCHR="+" THEN POWER:=1 00144000
ELSE BEGIN ERR:=SYNTAXERROR; GO TO QUIT; END; 00144500
POWERLEN:=SUBSCAN(ADDRESS:=BUMP(ADDRESS,1), NCHR); 00145000
END ELSE POWER:=1; 00145500
IF POWERLEN=0 THEN ERR:=SYNTAXERROR 00146000
ELSE BEGIN 00146500
POWER:=INTCON(POWERLEN)|POWER; 00147000
IF NCHR="#" OR NCHR="@" OR NCHR="." 00147500
THEN ERR:=SYNTAXERROR; END; 00148000
GO TO QUIT; 00148500
KITE: ERR:=KITEERROR; 00149000
QUIT: IF ERR=0 THEN 00149500
NUMBER:=IF MANTLEN+FRACLEN=0 THEN 00150000
IF POWERLEN=0 THEN 0 00150500
ELSE MANTSIGN|10*ENTIER(POWER) 00151000
ELSE MANTSIGN|(MANT|10*ENTIER(POWER) 00151500
+ FRAC|10*ENTIER(POWER-FRACLEN)) ELSE EOB:=1; 00152000
END OF NUMBER; 00152500
STREAM PROCEDURE APPENDTOBUFF(BUF,NBUF,NBLANK,A,SA,NA); 00220000
VALUE NBUF,NBLANK,SA,NA; 00221000
BEGIN LOCAL T; 00222000
LOCAL TSI,TDI; 00223000
SI:=LOC NBUF; DI:=LOC T; DI:=DI+1; DS:=7CHR; 00224000
DI:=BUF; T(2(DI:=DI+32)); DI:=DI+NBUF; 00225000
NBLANK(DS:=LIT" "); TDI:=DI; 00226000
SI:=LOC SA; DI:=LOC T; DI:=DI+1; DS:=7CHR; 00227000
SI:=A; T(2(SI:=SI+32)); SI:=SI+SA; 00228000
TSI:=SI; SI:=LOC NA; DI:=LOC T; DI:=DI+1; DS:=7CHR; 00229000
SI:=TSI; DI:=TDI; T(2(DS:=32CHR)); DS:=NA CHR 00230000
END; 00231000
PROCEDURE TERPRINT; 00231030
BEGIN LABEL BK; 00231040
STREAM PROCEDURE FINISHBUFF(BUF,N,TER);VALUE N,TER; 00232000
BEGIN LOCAL T; 00232100
SI:=LOC TER;SI:=SI+7;IF SC="1" THEN; 00232200
SI:=LOC N; DI:=LOC T; DI:=DI+1; DS:=7 CHR; 00232300
DI:=BUF; T(2(DI:=DI+32));DI:=DI+N; 00232400
IF TOGGLE THEN DS:=2 LIT"{!"; %CARRIAGE RETURN/LINE FEED 00232500
DS:=RESET;DS:=5 SET; %END OF MESSAGE LEFT ARROW 00232600
END OF FINISHBUFF; 00232700
IF CHRCOUNT NEQ 0 THEN BEGIN 00240000
FINISHBUFF(OUTBUFF,CHRCOUNT,LINETOG); 00241000
CHRCOUNT:=0; 00242000
IF LINETOG THEN 00242500
WRITE(TWXOUT,9,OUTBUFF[*])[BK:BK] ELSE 00243000
WRITE(TWXOUT[STOP],9,OUTBUFF[*])[BK:BK]; 00243500
INITBUFF(OUTBUFF, 10); 00243600
END; 00243610
IF FALSE THEN 00244000
BK: IF CURRENTMODE=XEQMODE THEN BREAKFLAG:=TRUE; 00244100
END OF TERPRINT; 00245000
PROCEDURE FORMWD(CC,WD); VALUE CC,WD; REAL WD; INTEGER CC; 00253000
BEGIN 00254000
INTEGER I,K,L; 00255000
COMMENT CC=-1 STAY ON LINE, OUTPUT, DON"T GO TO NEXT LINE 00255090
COMMENT CC=0 STAY ON THIS LINE, MORE TO COME. 00256000
CC=1 STAY ON THIS LINE BUT TERMINATE PRINT. 00257000
CC=2 SKIP TO NEXT LINE - MORE TO COME. 00258000
CC=3 SKIP TO NEXT LINE - TERMINATE PRINT.; 00259000
REAL STREAM PROCEDURE OCTAL(I); VALUE I; 00260000
BEGIN SI:=LOC I; DI:=LOC OCTAL; DS:=8OCT 00261000
END; 00262000
IF L:=LINESIZE LEQ 9 OR L GTR 72 THEN L:=72; K:=2; 00263000
IF CC GTR 1 AND CHRCOUNT GTR 0THEN TERPRINT; 00264000
IF CHRCOUNT+(I:=OCTAL(WD.[1:11])) GTR L THEN 00265000
00266000
BEGIN APPENDTOBUFF(LINEBUFFER,CHRCOUNT, 00267000
0,WD,2,K:=L-CHRCOUNT); 00268000
CHRCOUNT:=L; TERPRINT; 00269000
00270000
I:=I-K; 00271000
00272000
END; 00273000
APPENDTOBUFF(LINEBUFFER,CHRCOUNT,0,WD,K,I); 00274000
00274900
CHRCOUNT:=CHRCOUNT+I; 00275000
IF BOOLEAN(CC) THEN 00276000
IF CC=-1 THEN BEGIN LINETOG:=FALSE; 00276010
TERPRINT; LINETOG:=TRUE 00276020
END ELSE TERPRINT; 00276030
END; 00277000
BOOLEAN PROCEDURE FUNCTIONHEADER(SPECS,HADDR); 00277500
ARRAY SPECS[0]; REAL HADDR; FORWARD; 00277600
00278000
00279000
00280000
REAL PROCEDURE LINENUMBER(R); VALUE R; REAL R; 00280100
COMMENT STARTS ON 8030000; 00280110
FORWARD; 00280120
00280130
PROCEDURE INDENT(R); VALUE R; REAL R; 00281000
BEGIN 00281100
INTEGER STREAM PROCEDURE FORM(A,I,K);VALUE K,I; 00281200
BEGIN 00281300
LOCAL T1,T2; 00281400
LABEL SHORT,L,M,FINIS; 00281500
TALLY:=K; FORM:=TALLY; 00281600
SI:=LOC I; DI:=LOC T1; IF 8SC=DC THEN 00281700
BEGIN DI:=A; K(DS:=LIT" "); GO FINIS 00281800
END; 00281900
SI:=LOC I; DI:=A; TALLY:=3; DS:=LIT"["; 00282000
IF SC GTR "0" THEN IF SC LSS "0" THEN ; 00282100
3(TALLY:=TALLY+1; IF TOGGLE THEN DS:=CHR ELSE 00282200
IF SC NEQ "0" THEN DS:=CHR ELSE 00282300
BEGIN TALLY:=TALLY+63; SI:=SI+1 00282400
END ); 00282500
DS:=CHR; T1:=TALLY; TALLY:=4; SI:=SI+3; 00282600
4(IF SC NEQ "0" THEN JUMP OUT TO M; 00282700
TALLY:=TALLY+63; SI:=SI-1); GO TO L; 00282800
M: 00282900
T2:=TALLY; SI:=LOC I; SI:=SI+4; DS:=LIT"."; DS:=T2 CHR; 00283000
TALLY:=T1; TALLY:=TALLY+T2; TALLY:=TALLY+1; T1:=TALLY; 00283100
L: 00283200
DS:=LIT"]"; TALLY:=K; 00283300
T1(TALLY:=TALLY+63; T2:=TALLY; SI:=LOC T2; SI:=SI+7; 00283400
IF SC="0" THEN JUMP OUT TO SHORT); 00283500
T2(DS:=LIT" "); GO FINIS; 00283600
SHORT: 00283700
TALLY:=T1; TALLY:=TALLY+1; FORM:=TALLY; DS:=LIT" "; 00283800
FINIS: 00283900
DS:=RESET; DS:=5SET; 00284000
END; 00284100
IF R LSS 0 THEN R:=LINENUMBER(-R) ELSE R:=ABS(R); % -0 00285000
CHRCOUNT:=FORM(LINEBUFF,R,MARGINSIZE)+1 00286000
00286100
END; 00287000
INTEGER PROCEDURE HEADER(ADDR1,ADDR2,BUF); VALUE ADDR1,ADDR2; 00287010
INTEGER ADDR1, ADDR2; ARRAY BUF[0]; 00287020
BEGIN 00287030
INTEGER STREAM PROCEDURE HEADRR(ADDR1,ADDR2,BUF); VALUE ADDR1, 00287100
ADDR2; 00287110
BEGIN 00287120
LOCAL C,T,TDI; 00287130
LOCAL QM,AR; 00287132
LABEL L,ENDSCAN,M,N; 00287140
DI:=LOC QM; DS:=2RESET; DS:=2SET; 00287142
DI:=LOC AR; DS:=RESET; DS:=5SET; 00287144
DI:=BUF; 00287180
SI:=ADDR1; 00287200
L: T:=SI; TDI:=DI; 00287210
DI:=LOC QM; IF SC=DC THEN GO TO ENDSCAN; 00287212
DI:=LOC AR; SI:=SI-1; IF SC=DC THEN GO TO ENDSCAN; 00287214
SI:=LOC T; DI:=LOC ADDR2; 00287220
IF 8SC=DC THEN COMMENT END OF SCAN; 00287230
GO TO ENDSCAN; 00287240
SI:=T; DI:=TDI; DS:=CHR; 00287250
GO TO L; 00287260
ENDSCAN: 00287300
SI:=TDI; 00287310
M: SI:=SI-1; 00287320
IF SC=" " THEN GO TO M; 00287330
SI:=SI+1; 00287332
ADDR2:=SI; 00287340
SI:=BUF; 00287350
N: T:=SI; DI:=LOC ADDR2; 00287360
SI:=LOC T; 00287370
IF 8SC NEQ DC THEN 00287380
BEGIN 00287390
TALLY:=TALLY+1; TDI:=TALLY; 00287400
SI:=LOC TDI; SI:=SI+7; 00287410
IF SC="0" THEN 00287420
BEGIN TALLY:=C; TALLY:=TALLY+1; C:=TALLY; 00287430
TALLY:=0; 00287440
END; 00287450
SI:=T; SI:=SI+1; GO TO N; 00287460
END; 00287470
HEADRR:=TALLY; SI:=LOC C; DI:=LOC HEADRR; SI:=SI+1; DS:=6 CHR; 00287480
END; 00287490
HEADER:=HEADRR(ADDR1,ADDR2,BUF); 00287492
END OF PHONY HEADER; 00287494
PROCEDURE STARTSCAN; 00299000
BEGIN 00300000
00300100
00300600
00300700
LADDRESS:= 00301000
ADDRESS:=ABSOLUTEADDRESS; 00302000
BEGIN TERPRINT; 00304000
END; 00305000
READ(TWXIN[STOP],29,BUFFER[*]); 00306000
BUFFER[30]:=0&31[1:43:5]; 00307000
ITEMCOUNT:=0; 00312000
EOB:=0 00313000
END; 00314000
PROCEDURE FORMROW(CC,BL,A,S,N); VALUE CC,BL,S,N; INTEGER CC,BL, 00315000
S,N; ARRAY A[0]; 00316000
COMMENT: CC--SAME CODE AS IN FORMWD, LINE 253000 00316010
BL--#BLANKS TO PUT IN FRONT OF IT 00316020
A--ARRAY WHERE THE STUFF TO PUT ON LINE IS STORED 00316030
S--#CHARACTERS TO SKIP AT START OF A 00316040
N--#CHARACTERS TO TAKE FROM A TO PUT ON OUTPUT LINE; 00316050
BEGIN INTEGER K; 00317000
INTEGER T; 00317100
IF CC GTR 1 AND CHRCOUNT GTR 0 THEN TERPRINT; 00318000
IF K:=LINESIZE LEQ 9 OR K GTR 72 THEN K:=72; 00319000
WHILE CHRCOUNT+N+BL GTR K DO 00320000
BEGIN 00321000
APPENDTOBUFFER(LINEBUFFER,CHRCOUNT,BL,A,S,T:=K-CHRCOUNT-BL); 00322000
CHRCOUNT:=K; TERPRINT; 00323000
S:=S+T; N:=N-T; 00324000
BL:=0; 00325000
END; 00326000
APPENDTOBUFFER(LINEBUFFER,CHRCOUNT,BL,A,S,N); 00327000
00327900
CHRCOUNT:=CHRCOUNT+N+BL; 00328000
IF BOOLEAN(CC) THEN 00329000
IF CC=-1 THEN BEGIN LINETOG:=FALSE; 00329010
TERPRINT; LINETOG:=TRUE; 00329020
END ELSE TERPRINT; 00329030
END; 00330000
PROCEDURE NUMBERCON(R,A); VALUE R; REAL R; ARRAY A[0]; 00331000
BEGIN FORMAT F(F24.*), G(E24.*); 00332000
REAL S; DEFINE MAXIM = 10@9#; 00332010
00333000
STREAM PROCEDURE ADJUST(A,B); 00334000
BEGIN LOCAL T,FRAC,MANT,T1,TSI,TDI; 00335000
DI:=LOC T; DI:=DI+1; T1:=DI; 00336000
SI:=B; DI:=A; DI:=DI+2; 00337000
24(IF SC=" " THEN SI:=SI+1 ELSE 00338000
BEGIN TSI:=SI; SI:=LOC T; 00339000
IF SC="1" THEN; SI:=TSI; 00340000
IF TOGGLE THEN 00341000
IF SC NEQ "0" THEN 00342000
IF SC="@" THEN BEGIN 00343000
TSI:=SI; DI:=T1; DS:=LIT"1"; JUMP OUT; 00343010
END ELSE FRAC:=TALLY 00344000
ELSE TALLY := TALLY+0 00345000
ELSE 00346000
IF SC="." THEN 00347000
BEGIN MANT:=TALLY; TDI:=DI; DI:=LOC T; DS:= 00348000
LIT"1"; TALLY:=0;DI:=TDI; 00349000
END; 00350000
TALLY:=TALLY+1; DS:=CHR 00351000
END); 00352000
SI:=LOC MANT; SI:=SI+7; IF SC="0" THEN MANT:=TALLY; 00353000
00354000
TALLY:=MANT; SI:=LOC FRAC; SI:=SI+7; IF SC GTR "0" 00355000
THEN TALLY:=TALLY+1; TALLY:=TALLY+FRAC; MANT:=TALLY; 00356000
SI:=T1; IF SC="1" THEN BEGIN 00356010
DI:=A; DI:=DI+MANT; DI:=DI+2; 00356020
SI:=TSI; DS:=4CHR; 00356030
TALLY:=TALLY+4; MANT:=TALLY; END; 00356040
SI:=LOC MANT; SI:=SI+6; DI:=A; DS:=2CHR; 00357000
END; 00358000
IF S:=ABS(R) GEQ MAXIM OR S LEQ 10*(-DIGITS) AND S NEQ 0 THEN 00358010
WRITE(SCR[*],G,DIGITS,R) ELSE 00358020
WRITE(SCR[*],F,DIGITS,R); 00359000
ADJUST(A,SCR) 00360000
END; 00361000
PROCEDURE STOREPSR; 00361010
BEGIN INTEGER I; 00361020
DELETE1(WORKSPACE,0); 00361030
I:=STORESEQ(WORKSPACE,PSR,PSRSIZE|8); 00361040
COMMENT USED TO CALL WRAPUP; 00361050
END; 00361060
PROCEDURE RESCANLINE; 00361070
BEGIN ADDRESS:=ABSOLUTEADDRESS; EOB:=0; END; 00361072
PROCEDURE PROCESS(MODE);VALUE MODE; INTEGER MODE; FORWARD; 00361100
PROCEDURE MESSAGEHANDLER; FORWARD; 00362000
PROCEDURE FUNCTIONHANDLER; FORWARD; 00362100
PROCEDURE ERRORMESS(N,ADDR,R); VALUE N,ADDR,R; REAL R; 00362105
INTEGER N;REAL ADDR;FORWARD; COMMENT LINE 5000000; 00362107
STREAM PROCEDURE SETFIELD(A,S,L,R); VALUE S,L,R; 00362110
BEGIN DI:=A; DI:=DI+S; SI:=LOC R; SI:=SI+8; L(SI:=SI-1); 00362120
DS:=L CHR; 00362130
END; 00362140
COMMENT: VALUE OF GETFIELD IS L CHARACTERS, STARTING AT J-TH 00362145
CHARACTER OF A, RIGHT-ADJUSTED. L MUST BE LEQ 8 AND 00362146
J MUST BE LESS THAT 64; 00362147
REAL STREAM PROCEDURE GETFIELD(A,S,L); VALUE S,L; 00362150
BEGIN SI:=A; SI:=SI+S; DI:=LOC GETFIELD; DI:=DI+8; L(DI:=DI-1); 00362160
DS:=L CHR; 00362170
END; 00362180
REAL PROCEDURE TOPLINE(ORD); VALUE ORD; INTEGER ORD; 00362200
BEGIN 00362210
INTEGER STREAM PROCEDURE CON(A); VALUE A; 00362220
BEGIN SI:=LOC A; DI:=LOC CON; DS:=8OCT END; 00362230
ARRAY A[0:1]; INTEGER I; 00362240
I:=CONTENTS(ORD,SIZE(ORD)-1,A); 00362250
TOPLINE:=CON(A[0])/10000 00362260
END; 00362270
BOOLEAN PROCEDURE FUNCTIONHEADER(SPECS,HADDR); 00500000
ARRAY SPECS[0]; REAL HADDR; 00500100
BEGIN 00500150
LABEL A,B,C; 00500200
INTEGER P; 00500300
DEFINE NOTE=HADDR.[24:24]:=ADDRESS#,P8=8|P+1#; 00500325
ERR:=0; 00500350
SPECS[0]:=SPECS[1]:=SPECS[2]:=SPECS[3]:=0; 00500400
NOTE; HADDR.[1:23]:=GT1:=ADDRESS; 00500450
IF SCAN AND IDENT THEN 00500500
BEGIN 00500600
TRANSFER(ACCUM,2,SPECS,1,7); 00500700
NOTE; 00500750
IF SCAN THEN 00500800
IF LFTARROW THEN 00500900
BEGIN 00501000
SPECS[1]:=1; 00501100
SPECS[3]:=1; 00501150
TRANSFER(SPECS,1,SPECS,33,7); 00501200
GT2:=ADDRESS; 00501250
IF SCAN AND IDENT THEN 00501300
BEGIN 00501400
TRANSFER(ACCUM,2,SPECS,1,7); 00501500
NOTE; 00501550
IF SCAN THEN 00501600
C: IF IDENT THEN 00501700
BEGIN 00501800
P:=(SPECS[3]:=SPECS[3]+1)+3; 00501850
TRANSFER(ACCUM,2,SPECS,P8,7); 00501900
SPECS[2]:=1; 00502000
NOTE; 00502050
IF SCAN THEN IF IDENT THEN 00502100
BEGIN SPECS[2]:=2; 00502200
P:=(SPECS[3]:=SPECS[3]+1)+2; 00502250
TRANSFER(SPECS,1,SPECS,P8+8,7); 00502300
TRANSFER(SPECS,P8,SPECS,1,7); 00502400
TRANSFER(ACCUM,2,SPECS,P8,7); 00502500
00502550
B: NOTE; IF SCAN THEN 00502600
A: IF SEMICOLON THEN IF SCAN THEN 00502610
IF IDENT THEN 00502620
BEGIN 00502630
P:=(SPECS[3]:=SPECS[3]+1)+3; 00502640
TRANSFER(ACCUM,2,SPECS,P8,7); 00502650
GO TO B; 00502660
END ELSE GO TO A 00502670
ELSE ELSE ELSE 00502680
END ELSE GO TO A 00502690
ELSE END 00502700
ELSE GO TO A ELSE 00502800
END ELSE ERRORMESS(ERR:=1,GT2,0) 00502900
END ELSE GO TO C 00503000
ELSE 00503100
END ELSE ERRORMESS(ERR:=SYNTAXERROR,GT1,0); 00503200
FUNCTIONHEADER:=ERR=0; 00504500
ADDRESS:=HADDR.[24:24]; 00504550
END FUNCTIONHEADER; 00504600
00801810
INTEGER PROCEDURE DAYTIME(B); ARRAY B[0]; FORWARD; 02080000
COMMENT ON LINE 8014000, ARRAY B MUST HAVE LENGTH 02080010
AT LEAST 3 WDS; 02080020
PROCEDURE EDITLINE; FORWARD; 02080030
INTEGER PROCEDURE LENGTH(A,M);VALUE M; BOOLEAN M; ARRAY A[0]; 02080040
FORWARD; COMMENT LINE 8007900; 02080050
BOOLEAN PROCEDURE LABELSCAN(L,K); VALUE K; INTEGER K; 02080060
ARRAY L[0]; FORWARD; COMMENT LINE 8013910; 02080070
02080080
02080090
PROCEDURE CHECKSEQ(SEQ,L,INC); REAL SEQ,L,INC; FORWARD; 02080100
COMMENT ON LINE 8040000; 02080200
PROCEDURE RELEASEARRAY(D);VALUE D; REAL D; 03000500
BEGIN COMMENT RELEASE PERMANENT STORAGE FOR THE ARRAY DESC D; 03000510
INTEGER K,J,PT; 03000520
ARRAY BLOCK[0:32]; %SEE MAXWORDSTORE, LINE 17260 03000530
ARRAY TEMP[0:1]; 03000535
IF D.RF NEQ 0 THEN 03000540
BEGIN DELETE1(WS,D.DIMPTR); 03000550
K:=CONTENTS(WS,D.INPTR,BLOCK)-1; 03000560
DELETE1(WS,D.INPTR); 03000570
FOR J:=0 STEP 2 UNTIL K DO 03000580
BEGIN TRANSFER(BLOCK,J,TEMP,6,2); 03000585
PT:=TEMP[0]; DELETE1(WS,PT); END; 03000590
END; 03000600
END; 03000610
PROCEDURE TRANSFERSP(DIR,SP,L,B,M,N); VALUE DIR,N,M,L; 03001000
INTEGER DIR,N,M,L; 03001100
ARRAY SP[0,0],B[0]; 03001200
BEGIN COMMENT 03001300
DIR= INTO: TRANSFER N WORDS FROM B[L] INTO SP[M] 03001400
(ACTUALLY SP[*,M] SINCE ARRAY ROW IS USUALLY THE ARG) 03001450
DIR= OUTOF (OPPOSITE); 03001500
STREAM PROCEDURE MOVER(DIR,SP,M,B,L,N); VALUE DIR, 03001600
L,M,N; 03001700
BEGIN LOCAL T; 03001800
SI:=LOC L; DI:=LOC T; DI:=DI+1; DS:=7CHR; 03001900
SI:=SP; T(16(SI:=SI+32)); L(SI:=SI+8); L:=SI; 03002000
SI:=LOC M; DI:=LOC T; DI:=DI+1; DS:=7CHR; 03002100
SI:=B; T(16(SI:=SI+32)); M(SI:=SI+8); M:=SI; 03002110
SI:=LOC N; DI:=LOC T; DI:=DI+1; DS:=7CHR; 03002120
SI:=LOC DIR; SI:=SI+7; 03002130
IF SC="0" THEN 03002140
BEGIN SI:=M; DI:=L 03002150
END ELSE 03002160
BEGIN SI:=L ; DI:=M 03002170
END; 03002180
T(2(DS:=32WDS)); DS:=N WDS; 03002190
END; 03002200
INTEGER K; 03002210
WHILE N:=N-K GTR 0 DO 03002300
MOVER(DIR,SP[(L:=L+K)DIV SPRSIZE,*], 03002400
M:=M+K,B,K:=L MOD SPRSIZE, 03002500
K:=MIN(SPRSIZE-K,N)) 03002600
END; 03002700
03002800
PROCEDURE DUMPOLISH(SP,PD); VALUE PD; REAL PD; ARRAY SP[0,0]; 03008000
BEGIN INTEGER L; 03008100
LABEL SKIPREST; 03008150
INTEGER I,N,M,U; REAL T; 03008200
L:=PD.SPF; 03008300
I:=SP[LOC]+L; 03008400
FOR L:=L+2 STEP 1 UNTIL I DO 03008500
IF (T:=SP[LOC]).TYPEFIELD=FUNCTION THEN 03008510
BEGIN % OUTPUT MESSAGE AND NAME 03008520
FORMWD(2,"5FUNC: "); 03008530
N:=T.LOCFIELD; % N HAS LOCATION OF DESCRIPTOR 03008540
N:=N-1; % BACK UP ONE TO GET NAME 03008550
GTA[0]:=SP[NOC]; 03008560
FORMROW(1,1,GTA,1,7); 03008570
END 03008580
ELSE % MIGHT BE AN OPERATOR 03008590
IF T.TYPEFIELD=OPERATOR THEN 03008600
BEGIN COMMENT OUTPUT MESSAGE AND OP CODE; 03008610
FORMWD(2,"5ATOR: "); 03008620
NUMBERCON(T.OPTYPE,ACCUM); 03008623
FORMROW(0,1,ACCUM,2,ACOUNT); 03008626
NUMBERCON(T.LOCFIELD,ACCUM); 03008630
FORMROW(1,1,ACCUM,2,ACOUNT); 03008640
END ELSE %MAY BE A CONSTANT 03008650
IF T.TYPEFIELD=CONSTANT THEN 03008660
BEGIN COMMENT GET DATA DESCRIPTOR; 03008670
N:=T.LOCFIELD; 03008680
FORMWD(2,"5CONS: "); 03008690
T:=SP[NOC]; %T HAS THE DATA DESCRIPTOR 03008700
IF T.SPF=0 THEN BEGIN % A NULL VECTOR 03008702
FORMWD(1,"4NULL "); 03008704
GO TO SKIPREST; END; 03008706
N:=T.SPF; %N HAS THE SCALAR OR TOP OF VECTOR LOC. 03008710
IF BOOLEAN(T.SCALAR) THEN M:=U:=N ELSE 03008720
BEGIN U:=SP[NOC]+N; M:=N+1; %UPPER AND LOWER BOUNDS 03008730
END; 03008740
IF BOOLEAN(T.CHRMODE) THEN %CHARACTER FORMAT 03008741
BEGIN COMMENT SP[NOC] IS NUMBER OF CHRS; 03008742
TRANSFERSP(OUTOF,SP,M,BUFFER,0,ENTIER(((T:= 03008743
SP[NOC])-1)DIV 8+1)); 03008744
FORMROW(1,1,BUFFER,0,T); 03008745
END ELSE % SHOULD TEST FOR NULL...DO IT LATER. 03008746
FOR N:=M STEP 1 UNTIL U DO 03008750
BEGIN NUMBERCON(SP[NOC],ACCUM); 03008760
FORMROW(0,1,ACCUM,2,ACOUNT); 03008770
END; 03008780
TERPRINT; 03008790
SKIPREST: 03008795
END ELSE COMMENT MUST BE AN OPERAND; 03008800
IF T.TYPEFIELD=LOCALVAR THEN 03008810
BEGIN FORMWD(2,"5LOCL: "); 03008820
N:=T.SPF; % N HAS LOCATION OF NAME; 03008830
GTA[0]:=SP[NOC]; % PUT NAME IN GTA 03008840
FORMROW(1,1,GTA,1,7); 03008850
END ELSE 03008860
BEGIN COMMENT TREAT IT AS VARIABLE; 03008870
N:=T.LOCFIELD; COMMENT N HAS LOC OF DESCRIPTOR; 03008880
N:=N-1; COMMENT BACK UP OVER THE DESCRIPTOR; 03008890
GTA[0]:=SP[NOC]; 03008900
FORMWD(2,"5AND : "); 03008910
FORMROW(1,1,GTA,1,7); 03008920
END; 03008930
END; 03009000
03023400
PROCEDURE PROCESS(MODE); VALUE MODE; INTEGER MODE; 03100000
BEGIN 03100100
OWN INTEGER J; 03100105
OWN REAL RESULTD; 03100110
LABEL EXPOVRL,INTOVRL,INDEXL,FLAGL,ZEROL; 03100120
MONITOR EXPOVR,INTOVR,INDEX,FLAG,ZERO; 03100130
LABEL DEBUGSP; %DEBUGGING PURPOSES ONLY. 03100140
INTEGER PROCEDURE BUILDCONSTANT(LASTCONSTANT); 03100410
INTEGER LASTCONSTANT; FORWARD; 03100415
INTEGER PROCEDURE GETSPACE(LENGTH); VALUE LENGTH; 03100420
INTEGER LENGTH; FORWARD; 03100430
PROCEDURE OPERANDTOSYMTAB(L);VALUE L;INTEGER L;FORWARD; 03100432
REAL PROCEDURE BUILDALPHA(LASTCONSTANT); 03100440
INTEGER LASTCONSTANT; FORWARD; 03100445
INTEGER PROCEDURE BUILDNULL(LASTCONSTANT); 03100450
INTEGER LASTCONSTANT; FORWARD; 03100452
PROCEDURE SCRATCHDATA(D);VALUE D;REAL D; FORWARD; 03100460
COMMENT LINE 3121400; 03100462
PROCEDURE FORGETPROGRAM(U);VALUE U;REAL U; FORWARD; 03100470
COMMENT ANALYZE IS IN PROCESS BECAUSE OWN ARRAY SP 03100805
IS ADDRESSED INCORRECTLY OTHERWISE; 03100807
REAL PROCEDURE ANALYZE(DISPLAYOP); VALUE DISPLAYOP;BOOLEAN DISPLAYOP; 03100810
BEGIN COMMENT 03100840
BC= BUILDCONSTANT, 03100850
GS= GET SPACE PROCEDURE ; 03100860
ARRAY INFIX[0:MAXPOLISH]; 03100870
03100880
INTEGER LASTCONSTANT; 03100890
DEFINE GS=GETSPACE#; 03100900
BOOLEAN STREAM PROCEDURE EQUAL(A,B); 03100910
BEGIN SI:=A; SI:=SI+1; DI:=B; DI:=DI+2; 03100920
IF 7SC=DC THEN TALLY:=1; 03100930
EQUAL:=TALLY; 03100940
END; 03100950
PROCEDURE UNSTACK(DEST,L,ORIG,OTOP,N,CHR1,CHR2); 03100960
VALUE N,CHR1,CHR2; 03100962
INTEGER N,CHR1,CHR2,L,OTOP; 03100970
ARRAY DEST[0,0],ORIG[0]; 03100980
BEGIN 03100990
REAL T,U; 03100992
WHILE OTOP GTR 0 AND N GTR 0 AND ERR=0 DO 03101000
IF(IF (T:=ORIG[OTOP]).TYPEFIELD=FUNCTION THEN FALSE ELSE 03101010
U:=T.LOCFIELD=CHR1 OR U=CHR2) THEN %UNSTACK 03101012
BEGIN 03101014
IF N GTR 1 THEN 03101020
IF U=CHR2 THEN ERR:=SYNTAXERROR ELSE 03101030
OTOP:=OTOP-1; 03101032
N:=N-1; 03101040
END ELSE 03101050
COMMENT WE ARE LOOKING AT AN OPERATOR OR A FUNCTION; 03101060
03101070
03101080
BEGIN 03101090
IF J NEQ 0 THEN 03101100
BEGIN L:=L+1; 03101110
DEST[LOC]:=ORIG[OTOP] 03101120
END; 03101130
OTOP:=OTOP-1 03101140
END; 03101150
IF N GTR 1 THEN ERR:=SYNTAXERROR; 03101160
END; 03101170
INTEGER ITOP,K,L,I; 03101180
INTEGER M,N,FLOC; REAL T; 03101182
LABEL SKIPSCAN,FILLER; 03101184
LABEL SPFULLAB; 03101190
03101200
03101202
PROCEDURE FORGETSPACE(L,LENGTH,SP); VALUE L,LENGTH; 03101210
INTEGER L,LENGTH; ARRAY SP[0,0]; 03101220
BEGIN IF LENGTH GTR 0 THEN 03101222
BEGIN SP[LOC]:=SP[0,0]; 03101230
SP[LOC].LEN:=LENGTH; SP[0,0]:=L 03101240
END; 03101242
END; 03101250
03101251
IF CURRENTMODE=FUNCMODE OR STACKBASE=0 THEN FLOC:=0 ELSE 03101252
03101253
BEGIN L:=STACKBASE+1;L:=SP[LOC].SPF+1;M:=SP[LOC].SPF+L; 03101254
FLOC:= IF M=L OR BOOLEAN(T:=SP[MOC]).SUSPENDED THEN 0 ELSE T.SPF03101256
03101257
END; 03101258
03101260
T:=ADDRESS; 03101270
ITOP:=0; 03101280
DO 03101290
SKIPSCAN: 03101300
IF ITOP LSS MAXPOLISH THEN 03101350
BEGIN 03101400
INFIX[ITOP:=ITOP+1].ADDRFIELD:=T; 03101450
IF SPECIAL THEN 03101500
IF QUOTEV THEN % CONSTANT VECTOR 03101510
BEGIN INFIX[ITOP].TYPEFIELD:=CONSTANT; 03101515
IF T:=BUILDALPHA(LASTCONSTANT) NEQ 0 THEN 03101520
INFIX[ITOP].LOCFIELD:=T ELSE ERR:=SYNTAXERROR 03101525
END ELSE % ORDINARY OPERATOR 03101530
BEGIN INFIX[ITOP].TYPEFIELD:=OPERATOR; 03101550
INFIX[ITOP].LOCFIELD:=ENTIER(ACCUM[0]); 03101600
END ELSE 03101650
IF NUMERIC THEN 03101700
IF ERR NEQ 0 THEN COMMENT NOTHING; ELSE 03101710
BEGIN INFIX[ITOP].TYPEFIELD:=CONSTANT; 03101750
IF CURRENTMODE=FUNCMODE THEN 03101760
COMMENT DO NOT STORE NUMERIC IN SCRATCH PAD; 03101765
DO UNTIL NOT SCAN OR NOT NUMERIC %THE NULL STATEMENT 03101770
ELSE 03101780
BEGIN 03101790
T:=BUILDCONSTANT(LASTCONSTANT); 03101800
IF T=0 THEN ERR:=IF ERR=0 THEN VALUEERROR ELSE ERR ELSE 03101850
INFIX[ITOP].LOCFIELD:=T; 03101860
END; 03101870
IF EOB=0 AND ERR=0 THEN GO TO SKIPSCAN; 03101900
END ELSE 03101950
IF IDENT THEN 03102000
BEGIN INFIX[ITOP].DID:=OPERAND; %SET OPTYPE=NILADIC 03102050
IF NOT(FUNCMODE EQL CURRENTMODE) THEN 03102100
BEGIN J:=0; 03102150
IF FLOC GTR 0 THEN %CHECK LOCAL NAMES 03102200
BEGIN L:=FLOC+2; 03102250
K:=SP[LOC]-2;%LAST ALPHA POINTER IN TABLE 03102350
%SHOULD CONVERT TO BINARY SEARCH 03102390
T:=L+4; 03102392
FOR L:=T STEP 2 UNTIL K DO 03102400
IF EQUAL(SP[LOC],ACCUM) THEN 03102420
BEGIN J:=L;L:=K;I:=0; 03102430
INFIX[ITOP].SPF:=J; 03102440
INFIX[ITOP].RF:=M-FLOC; 03102442
J:=(J-T+2)/2; 03102450
END; 03102460
END; 03102500
03102510
03102550
IF J EQL 0 THEN 03102600
BEGIN COMMENT LOOK IN SP SYMBOL TABLE; 03102650
IF L:=SYMBASE NEQ 0 THEN COMMENT OK TO LOOK; 03102700
BEGIN T:=SP[LOC];K:=L+T; 03102750
COMMENT T=N VARS TIMES 2. K IS TOP LIMIT; 03102800
FOR L:=L +1 STEP 2 UNTIL K DO 03102850
IF EQUAL(SP[LOC],ACCUM) THEN 03102900
BEGIN 03102925
INFIX[ITOP].TYPEFIELD:=I:=SP[LOC].TYPEFIELD; 03102950
L:=J:=L+1; 03102960
IF I=FUNCTION THEN BEGIN 03102961
INFIX[ITOP].RF:=SP[LOC].RETURNVALUE; 03102962
INFIX[ITOP].OPTYPE:=SP[LOC].NUMBERARGS;END; 03102965
L:=K; 03102970
END; 03102980
IF J EQL 0 THEN 03103000
IF T LSS MAXSYMBOL|2 THEN %INSERT ID 03103050
BEGIN L:=K+1; %NEXT AVAILABLE. 03103100
FILLER: SETFIELD(GTA,0,1,0); 03103180
TRANSFER(ACCUM,2,GTA,1,7); 03103200
SP[LOC]:=GTA[0];%STORE VARIABLE NAME 03103225
OPERANDTOSYMTAB(L);%SET TYPEFIELD AND DESC. 03103250
IF GT1=FUNCTION THEN%FUNCTION-FIX INFIX 03103300
BEGIN 03103325
INFIX[ITOP].OPTYPE:=GTA[1].NUMBERARGS; 03103326
INFIX[ITOP].TYPEFIELD:=FUNCTION; 03103330
INFIX[ITOP].RF:=GTA[1].RETURNVALUE; 03103350
END; 03103400
J:=L+1; 03103425
L:=SYMBASE;SP[LOC]:=T+2;%UPDATE SYM TAB # 03103430
END ELSE SPFULLAB: ERR:=SPERROR;%TAB FULL 03103450
END ELSE %CREATE SYMBOL TABLE 03103500
BEGIN 03103550
SYMBASE:=L:=GS(MAXSYMBOL|2+1); 03103600
IF ERR NEQ 0 THEN 03103610
BEGIN SYMBASE:=0; 03103620
GO TO SPFULLAB; 03103630
END; 03103640
T:=0; L:=L+1; 03103650
GO TO FILLER; 03103700
END 03103750
END ELSE INFIX[ITOP].DID:=LOCALVAR&1[44:47:1]; 03103800
INFIX[ITOP].LOCFIELD:=J 03103850
END 03103900
END ELSE ERR:=SYSTEMERROR; 03103950
IF ERR EQL 0 THEN T:=ADDRESS 03104000
END ELSE ERR:=SPERROR 03104050
UNTIL NOT(SCAN AND ERR=0); %DROP THRU WHEN INPUT FIN OR ERR 03104060
COMMENT NOW LOOK FOR THE POLISH; 03104100
IF ERR NEQ 0 THEN 03104150
BEGIN ERRORMESS(ERR,INFIX[ITOP].ADDRFIELD,0); 03104200
END ELSE 03104250
BEGIN COMMENT MAKE UP THE POLISH; 03104300
ARRAY OPERATORS[0:ITOP]; 03104350
BOOLEAN PROCEDURE ANDORATOR (VAR,TYPE); 03104356
VALUE VAR, TYPE; 03104358
REAL VAR,TYPE; 03104360
BEGIN 03104362
REAL T; 03104363
LABEL OPERAN, ATOR; 03104364
COMMENT PROCEDURE TRUE IF VAR IS OF TYPE SPECIFIED; 03104366
IF T:=VAR.TYPEFIELD=OPERATOR THEN 03104368
IF T:=VAR.LOCFIELD NEQ RGTPARENV AND T NEQ 03104370
QQUAD AND T NEQ QUAD AND T NEQ 03104371
RGTBRACKETV THEN GO ATOR 03104372
ELSE GO OPERAN 03104374
ELSE 03104376
IF T=FUNCTION THEN 03104378
IF VAR.OPTYPE GTR NILADIC THEN 03104380
ATOR: ANDORATOR:=TYPE=OPERATOR 03104382
ELSE GO OPERAN 03104384
ELSE 03104386
OPERAN: ANDORATOR:=TYPE=OPERAND; 03104388
END OF ANDORATOR; 03104390
BOOLEAN PROCEDURE RGTOPERAND(VAR); VALUE VAR; REAL VAR; 03104391
BEGIN REAL T; DEFINE RT=RGTOPERAND:=TRUE#; 03104392
IF T:=VAR.TYPEFIELD=OPERAND OR T=CONSTANT OR T=LOCALVAR THEN RT 03104393
ELSE IF T=OPERATOR AND VAR.LOCFIELD=LFTPARENV THEN RT 03104394
ELSE IF T=FUNCTION AND VAR.OPTYPE LEQ MONADIC THEN RT; 03104395
END OF RGTOPERAND; 03104396
BOOLEAN VALID; 03104398
INTEGER OTOP; 03104400
INTEGER BCT,N; REAL COLONCTR; 03104402
LABEL STACKOPERAND, STACKFUNCTION; 03104425
DEFINE PTOP=L#; 03104450
LABEL AROUND, NOK, OK, LFTARROWL, LFTPARENL, RGTPARENL, 03104455
SLASHL,EXPL,ROTL,MONADICL,DYADICL,ERRL,SORTL, 03104456
SEMICOLONL, QUADL, DOTL, RELATIONL, 03104457
LFTBRACKETL, RGTBRACKETL, QUOTEQUADL; 03104458
SWITCH OPERATORSWITCH:= % IN GROUPS OF 5, STARTING AT 1 03104459
NOK, NOK, NOK, LFTARROWL, % 1-4 03104461
MONADICL, SLASHL, OK, LFTPARENL,RGTPARENL, %5-9 03104463
QUADL,LFTBRACKETL,RGTBRACKETL,ERRL,QUOTEQUADL, %10-14 03104465
SEMICOLONL, OK, DOTL, OK, OK, % 15-19 03104467
OK,DYADICL,DYADICL,MONADICL,RELATIONL, % 20-24 03104469
RELATIONL, RELATIONL, RELATIONL, RELATIONL, 03104471
RELATIONL, % 25-29 03104472
OK, OK, OK, OK, OK, % 30-34 03104473
OK, OK, ROTL, EXPL, OK, % 35-39 03104475
OK,OK,OK,OK,DYADICL, % 40-44 03104477
OK, OK, ERRL, OK, OK, % 45-49 03104479
OK, NOK, NOK, NOK, OK, % 50-54 03104481
SORTL,SORTL,OK,OK,OK, % 55-59 03104483
DYADICL, DYADICL, MONADICL; % 60-62 03104484
%----------------------------------------------- 03104500
COMMENT GET AN AREA OF SCRATCH PAD IF WE ARE NOT IN 03104550
THE SYNTAX CHECKING MODE; 03104600
J:=(IF CURRENTMODE=FUNCMODE THEN 0 ELSE 03104650
GS(ITOP+3)); 03104700
I:=ITOP+1; 03104750
COMMENT A QUICK SYNTAX CHECK; 03104774
IF ANDORATOR(INFIX[ITOP],OPERATOR) THEN ERR:=SYNTAXERROR; 03104775
L:=J+1; COMMENT POLISH WILL START TWO UP IN ARRAY; 03104800
WHILE ERR=0 AND I GTR 1 DO 03104815
IF T:=INFIX[I:=I-1].TYPEFIELD=OPERATOR THEN 03104817
BEGIN 03104818
GO OPERATORSWITCH[INFIX[I].LOCFIELD]; 03104821
ROTL: 03104823
IF I=1 OR NOT ANDORATOR(INFIX[I-1],OPERAND) THEN GO OK; 03104825
T:=INFIX[I]; 03104826
T.LOCFIELD:=ROTATE; 03104827
T.OPTYPE:=IF INFIX[I].OPTYPE NEQ DYADIC THEN MONADIC ELSE DYADIC; 03104828
INFIX[I]:=T; GO TO STACKFUNCTION; 03104829
EXPL: 03104830
SLASHL: BEGIN DEFINE STARTSEGMENT= #; %///////////////////// 03104831
IF INFIX[I-1].TYPEFIELD=FUNCTION THEN GO ERRL ELSE 03104832
IF ANDORATOR(INFIX[I-1],OPERATOR) THEN 03104833
BEGIN 03104835
INFIX[I].LOCFIELD:=IF INFIX[I].LOCFIELD=SLASHV THEN 03104837
REDUCT ELSE SCANV; 03104838
03104839
IF INFIX[I].OPTYPE NEQ DYADIC THEN INFIX[I].OPTYPE:=MONADIC; 03104840
GO OK; 03104843
END 03104845
ELSE 03104847
03104849
IF INFIX[I].OPTYPE NEQ DYADIC THEN INFIX[I].OPTYPE:=MONADIC; 03104851
IF I=1 THEN 03104857
03104859
BEGIN 03104861
ERR:=SYNTAXERROR; 03104863
GO AROUND; 03104865
END; 03104867
GO OK; END; 03104869
SORTL: 03104870
IF I=1 OR ANDORATOR(INFIX[I-1],OPERATOR) THEN GO OK ELSE GO ERRL; 03104871
LFTPARENL: 03104873
K:=I; 03104874
UNSTACK(SP,PTOP,OPERATORS,OTOP,2,RGTPARENV,RGTBRACKETV); 03104875
GO AROUND; 03104876
RELATIONL: 03104878
DYADICL: 03104880
IF I GTR 1 THEN 03104881
IF ANDORATOR(INFIX[I-1],OPERAND) THEN 03104882
BEGIN 03104884
INFIX[I].OPTYPE:=DYADIC; 03104885
GO STACKFUNCTION; 03104886
END; 03104887
IF (GT3:=(T:=INFIX[I+1]).LOCFIELD=REDUCT OR GT3=SCANV) 03104888
AND T.TYPEFIELD=OPERATOR THEN GO OK; 03104889
IF(T:=INFIX[I-1]).LOCFIELD=DOTV AND T.TYPEFIELD=OPERATOR THEN GO OK;03104890
GO TO ERRL; 03104891
MONADICL: 03104892
IF I=1 OR ANDORATOR(INFIX[I-1],OPERATOR) 03104894
THEN BEGIN 03104896
INFIX[I].OPTYPE:=MONADIC; 03104897
GO TO STACKFUNCTION; 03104900
END 03104902
ELSE 03104904
GO ERRL; 03104906
LFTBRACKETL: 03104910
IF BCT:=BCT-1 LSS 0 THEN ERR:=SYNTAXERROR; 03104935
UNSTACK(SP,PTOP,OPERATORS,OTOP,1,RGTBRACKETV,RGTPARENV); 03104950
IF OTOP=1 THEN BEGIN 03104981
ERR:=SYNTAXERROR; GO AROUND; END 03104984
ELSE IF J NEQ 0 THEN 03104987
BEGIN 03104990
IF T:=INFIX[I-1].TYPEFIELD=OPERAND OR T=LOCALVAR THEN 03104995
BEGIN DEFINE STARTSEGMENT= #; %////////////////////////// 03105000
%LFTBRACKET PART OF SUBSCRIPTED VARIABLE 03105001
IF OPERATORS[OTOP].OPTYPE=0 THEN GO TO ERRL; 03105002
COMMENT IF ABOVE TRUE THEN THERE WAS AN OPERAND TO THE RITE;03105003
L:=L+1; 03105004
N:=GT1:=GETSPACE(1); 03105006
SP[NOC]:=COLONCTR+1; % STORE NUMBER OF DIMENSIONS 03105009
N:=GETSPACE(1); % BUILD A DESCRIPTOR FOR # OF DIMENSIONS 03105012
T.SPF:=GT1; 03105015
T.DID:=DDPNSW; 03105018
T.BACKP:=LASTCONSTANT; 03105021
SP[NOC]:=T; 03105024
T:=INFIX[I]; 03105027
T.LOCFIELD:=LASTCONSTANT:=N; % LINK TO CONSTANT CHAIN 03105030
T.TYPEFIELD:=CONSTANT; 03105033
SP[LOC]:=T; % PUT ON POLISH 03105036
L:=L+1; 03105039
IF OPERATORS[OTOP].OPTYPE=3 THEN % LEFT SIDE OF REPLACEOP 03105040
INFIX[I-1].TYPEFIELD:=REPLACELOC; 03105041
SP[LOC]:=INFIX[I-1]; % PLACE OPERAND ON POLISH 03105042
L:=L+1; 03105043
SP[LOC]:=INFIX[I]; % COLLAPSE OPERATOR TO POLISH 03105044
I:=I-1; 03105045
END 03105046
ELSE IF T:=INFIX[I-1].LOCFIELD=SLASHV OR 03105047
T=EXPANDV OR T=ROTV OR T=SORTUPV OR T=SORTDNV THEN 03105048
IF INFIX[I-1].TYPEFIELD=OPERATOR AND OPERATORS[OTOP] 03105049
.OPTYPE=0 THEN INFIX[I-1].OPTYPE:=DYADIC 03105050
ELSE ERR:=SYNTAXERROR 03105051
ELSE ERR:=SYNTAXERROR; 03105053
END; 03105054
COLONCTR:=OPERATORS[OTOP:=OTOP-1]; 03105056
IF OTOP:=OTOP-1 LSS 0 THEN ERR:=SYNTAXERROR; 03105059
GO AROUND; 03105070
RGTPARENL: 03105085
IF OTOP LSS ITOP DIV 2 THEN ELSE ERR:=SYNTAXERROR; 03105087
OPERATORS[OTOP:=OTOP+1]:=INFIX[I]; 03105090
GO AROUND; 03105100
RGTBRACKETL: BEGIN DEFINE STARTSEGMENT= #; %/////////////////// 03105115
BCT:=BCT+1; 03105130
IF OTOP+2 GEQ ITOP THEN 03105132
BEGIN 03105134
ERR:=SYNTAXERROR; 03105136
GO AROUND; 03105138
END; 03105140
OPERATORS[OTOP:=OTOP+1]:=COLONCTR; 03105145
GT1:=OPERATORS[OTOP:=OTOP+1]:=INFIX[I]; COLONCTR:=0; 03105150
IF I NEQ ITOP THEN 03105152
IF GT1.OPTYPE NEQ 3 THEN 03105154
OPERATORS[OTOP].OPTYPE:=IF RGTOPERAND(INFIX[I+1]) THEN 03105156
0 ELSE 2 03105158
ELSE 03105159
ELSE OPERATORS[OTOP].OPTYPE:=2; 03105160
IF J NEQ 0 AND INFIX[I-1].LOCFIELD=SEMICOLONV THEN 03105161
BEGIN 03105163
T.LOCFIELD:=BUILDNULL(LASTCONSTANT); 03105165
T.TYPEFIELD:=CONSTANT; 03105167
L:=L+1; K:=I; 03105169
SP[LOC]:=T; 03105171
END; 03105173
GO AROUND; END; 03105175
LFTARROWL: 03105178
IF I=1 THEN ERR:=SYNTAXERROR 03105180
ELSE 03105182
IF T:=INFIX[I-1].TYPEFIELD=OPERAND OR T=LOCALVAR THEN 03105184
INFIX[I-1].TYPEFIELD:=REPLACELOC 03105186
ELSE 03105188
IF T=OPERATOR THEN 03105190
IF T:=INFIX[I-1].LOCFIELD=QUAD OR T=QUADLFTARROW THEN 03105192
INFIX[I:=I-1].LOCFIELD:=QUADLFTARROW 03105194
ELSE IF T=RGTBRACKETV THEN INFIX[I-1].OPTYPE:=3 03105195
%WILL TEST LATER TO INDICATE REPLACEMENT IN MATRIX 3105154 03105196
ELSE ERR:=SYNTAXERROR 03105197
ELSE ERR:=SYNTAXERROR; 03105198
IF ERR=0 THEN GO OK ELSE GO AROUND; 03105200
QUOTEQUADL: 03105202
QUADL: 03105204
COMMENT INPUT IS BEING REQUESTED; 03105205
GO TO STACKOPERAND; 03105206
DOTL: BEGIN DEFINE STARTSEGMENT=#; %/////////////////////////////// 03105207
IF I GTR 2 THEN 03105208
IF (T:=INFIX[I-1]).TYPEFIELD=OPERATOR AND 03105209
ANDORATOR(T,OPERATOR) THEN 03105211
IF (T:=INFIX[I+1]).TYPEFIELD=OPERATOR AND 03105213
ANDORATOR(T,OPERATOR) THEN 03105215
IF ANDORATOR(INFIX[I-2],OPERAND) THEN 03105216
COMMENT THEN SYNTAX OK; 03105217
BEGIN 03105223
COMMENT STACK OPERATORS SO THAT IF GIVEN A+.XB 03105225
POLISH IS BA.+X; 03105227
OPERATORS[OTOP].OPTYPE:=TRIADIC; 03105228
OPERATORS[OTOP:=OTOP+1]:=INFIX[I-1]; 03105229
INFIX[I].OPTYPE:=TRIADIC; 03105231
OPERATORS[OTOP:=OTOP+1]:=INFIX[I]; 03105232
I:=I-1; 03105233
VALID:=TRUE; 03105234
END; 03105235
IF NOT VALID THEN ERR:=SYNTAXERROR; 03105237
VALID:=FALSE; 03105239
GO AROUND; END; 03105241
SEMICOLONL: BEGIN DEFINE STARTSEGMENT=#; %///////////////////// 03105242
IF BCT NEQ 0 THEN 03105244
BEGIN 03105246
COLONCTR:=COLONCTR+1; 03105248
IF I-1=0 THEN ERR:=SYNTAXERROR 03105250
ELSE 03105260
BEGIN 03105263
UNSTACK(SP,PTOP,OPERATORS,OTOP,1,RGTBRACKETV,RGTPARENV); 03105265
IF J NEQ 0 AND (T:=INFIX[I-1].LOCFIELD=SEMICOLONV 03105270
OR T =LFTBRACKETV) THEN BEGIN 03105280
T.LOCFIELD:=BUILDNULL(LASTCONSTANT); 03105290
T.TYPEFIELD:=CONSTANT; 03105300
L:=L+1; K:=I; 03105310
SP[LOC]:=T; 03105320
END; 03105330
END 03105340
END 03105350
ELSE COMMENT MUST BE MIXED MODE EXPRESSION; 03105370
BEGIN 03105383
IF ANDORATOR(T:=INFIX[I-1],OPERATOR) THEN 03105385
IF T.LOCFIELD NEQ SEMICOLONV THEN GO ERRL; 03105390
UNSTACK(SP,PTOP,OPERATORS,OTOP,1,RGTPARENV,RGTBRACKETV); 03105395
OPERATORS[OTOP:=OTOP+1]:=INFIX[I]; 03105400
END; 03105403
GO AROUND; 03105405
END; 03105407
NOK: 03105655
ERR:=SYSTEMERROR; 03105660
GO AROUND; 03105661
ERRL: 03105662
ERR:=SYNTAXERROR; 03105663
GO AROUND; 03105665
OK: 03105668
IF INFIX[I].OPTYPE NEQ 0 THEN GO TO STACKFUNCTION ELSE 03105669
IF I LSS 2 THEN INFIX[I].OPTYPE:=MONADIC ELSE 03105670
INFIX[I].OPTYPE:=IF ANDORATOR(INFIX[I-1],OPERATOR) THEN 03105671
MONADIC ELSE DYADIC; 03105672
03105673
03105674
STACKFUNCTION: 03105675
IF I=K-1 THEN OPERATORS[OTOP:=OTOP+1]:=INFIX[I] 03105677
ELSE 03105680
BEGIN 03105682
UNSTACK(SP,PTOP,OPERATORS,OTOP,1,RGTPARENV,RGTBRACKETV); 03105685
OPERATORS[OTOP:=OTOP+1]:=INFIX[I]; 03105700
END; 03105710
GO AROUND; 03105715
AROUND: 03105717
END % OF PROCESSING AN OPERATOR---- 03105720
ELSE % COULD BE A FUNCTION 03105722
IF INFIX[I].TYPEFIELD=FUNCTION THEN 03105724
IF (T:=INFIX[I]).OPTYPE GEQ MONADIC THEN 03105726
GO TO STACKFUNCTION 03105728
ELSE 03105730
IF T.RF=RETURNVAL THEN GO TO STACKOPERAND 03105732
ELSE % MUST NOT RETURN A VALUE 03105734
IF I=1 THEN GO TO STACKOPERAND 03105736
ELSE ERR:=SYNTAXERROR 03105738
ELSE % MUST BE AN OPERAND, CONSTANT OR LOCAL 03105740
STACKOPERAND: 03105742
BEGIN DEFINE STARTSEGMENT=#; %////////////////////////// 03105744
IF ITOP=1 THEN ELSE 03105746
IF I=ITOP AND I NEQ 1 THEN 03105748
IF ANDORATOR(INFIX[I-1],OPERAND) THEN 03105750
IF INFIX[I-1].LOCFIELD=RGTBRACKETV THEN 03105751
ELSE GO ERRL 03105752
ELSE 03105754
ELSE 03105758
IF I=1 AND I NEQ ITOP THEN 03105760
IF RGTOPERAND(INFIX[I+1]) THEN GO ERRL 03105762
ELSE 03105764
ELSE 03105766
IF ANDORATOR(INFIX[I-1],OPERAND) OR RGTOPERAND(INFIX[I+1]) 03105768
THEN 03105770
IF INFIX[I-1].LOCFIELD=RGTBRACKETV THEN 03105772
ELSE GO ERRL; 03105773
IF J NEQ 0 THEN 03105774
BEGIN L:=L+1; 03105775
SP[LOC]:=INFIX[I]; 03105790
END; K:=I; 03105800
UNSTACK(SP,PTOP,OPERATORS,OTOP,1,RGTPARENV,RGTBRACKETV); 03105820
END; % OF GOING THROUGH INFIX 03105835
IF ERR NEQ 0 THEN ERRORMESS(ERR,INFIX[I].ADDRFIELD,0) ELSE 03105850
WHILE OTOP GTR 0 AND ERR=0 DO 03105900
BEGIN IF T:=OPERATORS[OTOP].LOCFIELD=RGTPARENV OR 03105950
T=RGTBRACKETV THEN 03105952
IF OPERATORS[OTOP].TYPEFIELD=OPERATOR THEN 03105960
ERRORMESS(ERR:=SYNTAXERROR,OPERATORS[OTOP].ADDRFIELD 03106000
,0); 03106001
IF J NEQ 0 THEN 03106050
BEGIN L:=L+1; 03106100
SP[LOC]:=OPERATORS[OTOP] 03106150
END; OTOP:=OTOP-1; 03106200
END; 03106250
IF J NEQ 0 AND DISPLAYOP THEN 03106252
IF SP[LOC].TYPEFIELD NEQ OPERATOR OR 03106254
T:=SP[LOC].LOCFIELD NEQ LFTARROWV 03106255
AND T NEQ QUADLFTARROW AND T NEQ GOTOV THEN 03106256
BEGIN COMMENT ADD DISPLAY OPERATOR TO POLISH; 03106258
L:=L+1; 03106260
T.TYPEFIELD:=OPERATOR; 03106262
T.OPTYPE:=MONADIC; 03106263
T.LOCFIELD:=QUADLFTARROW; 03106264
SP[LOC]:=T; 03106266
END; 03106272
IF J NEQ 0 THEN 03106300
IF ERR NEQ 0 THEN FORGETSPACE (J,ITOP+3,SP) ELSE 03106350
COMMENT STORE POLISH AND BUFFER; 03106400
BEGIN COMMENT SAVE LENGTH OF POLISH; 03106450
DEFINE STARTSEGMENT=#; %//////////////////////////////////// 03106452
T:=L-J; % DELETE ANY EXTRA SPACE ALLOCATED FOR POLISH 03106500
IF T LSS ITOP+2 THEN FORGETSPACE(L+1,2+ITOP-T,SP); 03106525
COMMENT THEN GETSPACE FOR BUFFER; 03106535
L:=GS(((K:=LENGTH(BUFFER, CURRENTMODE= 03106550
CALCMODE))-1) DIV 8 +2); 03106600
COMMENT L IS THE ADDRESS OF THE BUFFER; 03106650
SP[LOC]:=K; %NUMBER OF CHARACTERS IN THE BUFFER 03106700
TRANSFERSP(INTO,SP,L+1,BUFFER,0,ENTIER((K+7)DIV 8)); 03106750
COMMENT WE HAVE MOVED IN THE BUFFER; 03106800
K:=L; %SAVE THE ADDRESS OF THE BUFFER; 03106850
L:=J+1; % ONE WORD UP INTO THE POLISH 03106900
SP[LOC].SPF:=K; %STORE ADDRESS OF BUFFER 03106950
SP[LOC].RF:=1; % SET THE RANK TO 1 03107000
SP[LOC].DID:=DDPNVC; 03107050
L:=L-1; %SET THE LENGTH OF POLISH 03107100
SP[LOC]:=T; %STORE THE LENGTH OF THE POLISH 03107150
T:=0; T.SPF:=J; T.RF:=1; %SET UP PROG DESC IN T 03107200
T.BACKP:=LASTCONSTANT; 03107225
T.DID:=PDC; ANALYZE:=T; 03107250
COMMENT DEBUG THE POLISH IF NECESSARY; 03107300
IF POLBUG=1 THEN DUMPOLISH(SP,T); 03107350
END; 03107400
%-------------------------------------------------- 03107450
END; 03107500
END; 03107550
PROCEDURE OPERANDTOSYMTAB(L);VALUE L;INTEGER L; 03108000
BEGIN 03108020
INTEGER N; 03108030
TRANSFER(ACCUM,2,GTA,0,7); 03108040
IF(IF VARIABLES=0 THEN FALSE ELSE 03108060
SEARCHORD(VARIABLES,GTA,GT1,7)=0) THEN 03108080
BEGIN 03108100
SP[LOC].TYPEFIELD:=GT1:=GETFIELD(GTA,7,1); 03108120
IF GT1=FUNCTION THEN 03108140
BEGIN 03108160
L:=L+1;SP[LOC]:=GTA[1]; 03108200
END ELSE %MUST BE AN OPERAND 03108220
BEGIN 03108240
SP[LOC].TYPEFIELD:=OPERAND; 03108260
L:=L+1; 03108280
IF GT1=0 THEN % THIS IS THE SCALAR CASE 03108300
BEGIN N:=GETSPACE(1); 03108320
SP[LOC]:=N&DDPNSW[CDID]; 03108340
SP[NOC]:=GTA[1]; 03108360
END ELSE %IT MUST BE A VECTOR 03108380
SP[LOC]:=GTA[1]; 03108400
END; 03108420
END ELSE % NOT IN THE SYMBOL TABLE 03108440
BEGIN 03108460
SP[LOC].TYPEFIELD:=GT1:=OPERAND; 03108480
L:=L+1; SP[LOC]:=NAMEDNULLV; 03108500
% THE UNDEFINED SYMBOL IS A NULL 03108520
03108540
END; 03108560
END; %OF PROCEDURE OPERANDTOSYMTAB 03108600
INTEGER PROCEDURE GETSPACE(LENGTH); VALUE LENGTH; 03110000
INTEGER LENGTH; 03110100
BEGIN 03110200
LABEL ENDGETSPACE,SPOVERFLOW; 03110210
MONITOR INDEX; 03110220
INTEGER L,NEXTAREA,LASTAREA,OLDROW,K; 03110300
INTEGER MEMCHECK; 03110310
REAL LINK; 03110400
INDEX:=SPOVERFLOW; 03110410
NEXTAREA:=SP[0,0]; 03110500
LASTAREA:=0; 03110600
DO BEGIN COMMENT FIND A LARGE ENOUGH AREA; 03110700
IF MEMCHECK:=MEMCHECK+1 GTR MAXMEMACCESSES THEN %ERR 03110710
BEGIN GETSPACE:=-1@10; ERR:=SPERROR; 03110720
GO TO ENDGETSPACE END; 03110730
IF NEXTAREA =0 THEN COMMENT END OF STORAGE; 03110800
BEGIN 03110900
IF NROWS:=(OLDROW:=NROWS)+K:=ENTIER(LENGTH/ 03110910
SPRSIZE+1) 03110915
GTR MAXSPROWS THEN %OFF THE END OF SP 03110920
BEGIN COMMENT TAKE EASY WAY OUT FOR NOW; 03110930
GETSPACE:=-1@10; %CAUSES INVALID INDEX 03110940
NROWS:=OLDROW; ERR:=SPERROR; 03110945
GO TO ENDGETSPACE 03110950
END; 03110960
K:=K|SPRSIZE; 03111000
03111100
L:=LASTAREA; 03111200
IF OLDROW = -1 THEN COMMENT FIRST ROW OF SP; 03111300
BEGIN SP[0,0].NEXT:=L:=1; K:=K-1 03111400
END ELSE 03111500
BEGIN SP[LOC].NEXT:=(OLDROW+1)|SPRSIZE; 03111600
L:=(OLDROW+1)|SPRSIZE; 03111700
END; 03111800
SP[LOC].LEN:=K; SP[LOC].NEXT:=0; 03111900
NEXTAREA:=L 03112000
END ELSE L:=NEXTAREA; 03112100
LINK:=SP[LOC]; 03112200
K:=LINK.LEN-LENGTH; 03112300
IF K LSS 0 THEN COMMENT NOT ENOUGH ROOM; 03112400
BEGIN L:=LASTAREA:=NEXTAREA; 03112500
NEXTAREA:=LINK.NEXT 03112600
END 03112700
END UNTIL K GEQ 0; 03112800
IF K GTR 0 THEN 03112900
BEGIN L:=L+LENGTH; 03113000
SP[LOC]:=0; 03113010
SP[LOC].LEN:=K; SP[LOC].NEXT:=LINK.NEXT; 03113100
END ELSE L:=LINK.NEXT; 03113200
K:=L; L:=LASTAREA; 03113300
COMMENT ZERO OUT THE STORAGE BEFORE ALLOCATION; 03113400
SP[LOC].NEXT:=K; K:=NEXTAREA+LENGTH-1; 03113500
FOR L:=GETSPACE:=NEXTAREA STEP 1 UNTIL K DO SP[LOC]:=0; 03113600
IF FALSE THEN SPOVERFLOW: BEGIN 03113603
GETSPACE:=-1@10;ERR:=SPERROR END; 03113605
ENDGETSPACE: 03113610
END OF GETSPACE; 03113700
PROCEDURE FORGETSPACE(LOCATE,LENGTH); VALUE LOCATE,LENGTH; 03113800
INTEGER LOCATE,LENGTH; 03113900
BEGIN INTEGER L; 03114000
IF LENGTH GTR 0 THEN BEGIN 03114010
L:=LOCATE; 03114100
SP[LOC]:=SP[0,0]; 03114200
SP[LOC].LEN:=LENGTH; 03114300
SP[0,0]:=L; 03114310
END; 03114400
END; 03114500
INTEGER PROCEDURE BUILDNULL(LASTCONSTANT); 03114510
INTEGER LASTCONSTANT; 03114520
BEGIN REAL T, N; 03114530
IF NOT CURRENTMODE=FUNCMODE THEN 03114535
BEGIN 03114536
T:=0; 03114540
T.DID:=DDPNVW; 03114550
T.BACKP:=LASTCONSTANT; 03114560
LASTCONSTANT:=BUILDNULL:=N:=GETSPACE(1); 03114570
SP[NOC]:=T; 03114580
END; 03114585
END OF BUILDNULL; 03114590
03114600
INTEGER PROCEDURE BUILDCONSTANT(LASTCONSTANT); 03114610
INTEGER LASTCONSTANT; 03114620
BEGIN ARRAY A[0:MAXCONSTANT]; 03114630
INTEGER ATOP,L,K; 03114640
REAL AP; 03114642
DEFINE GS=GETSPACE#; 03114650
DO 03114660
A[ATOP:=ATOP+1]:=ACCUM[0] 03114670
UNTIL NOT SCAN OR NOT NUMERIC OR ATOP = MAXCONSTANT; 03114680
IF MAXCONSTANT=ATOP OR ERR NEQ 0 THEN COMMENT AN ERROR; 03114690
ELSE 03114700
03114705
IF ATOP=1 THEN COMMENT SCALAR FOUND; 03114710
BEGIN L:=K:=GS(1); 03114720
SP[LOC]:=A[1]; 03114730
BUILDCONSTANT:=L:=GETSPACE(1); 03114740
SP[LOC]:=K&DDPNSW[CDID]&LASTCONSTANT[CLOCF]; 03114750
LASTCONSTANT:=L; 03114766
END ELSE COMMENT VECTOR; 03114770
BEGIN L:=K:=GS(ATOP+1); 03114780
TRANSFERSP(INTO,SP,L+1,A,1,ATOP); 03114790
SP[LOC]:=ATOP; 03114800
BUILDCONSTANT:=L:=GS(1); %VECTOR DESCRIPTOR 03114810
SP[LOC]:=K&1[CRF]&DDPNVW[CDID]&LASTCONSTANT[CLOCF]; 03114820
LASTCONSTANT:=L; 03114846
END 03114850
03114855
END; 03114860
OWN INTEGER OLDDATA, REALLYERROR; 03114900
INTEGER L,N,M; 03115000
OWN REAL ST,T,U; 03115100
LABEL EXECUTION,PROCESSEXIT; 03115200
DEFINE STLOC=ST.[30:11],ST.[41:7]#, 03115300
STMINUS=(ST-1).[30:11],(ST-1).[41:7]#, 03115400
AREG=SP[STLOC]#, 03115500
BREG=SP[STMINUS]#, 03115600
BACKPT=6:36:12#, 03115700
CI=18:36:12#, 03115800
SPTSP=30:30:18#, 03115900
PROGMKS=0#, 03115910
IMKS=2#, 03115920
FMKS=1#, 03115930
03115940
BACKF=[6:12]#, 03115950
CIF=[18:12]#, 03115960
ENDEF=#; 03116000
PROCEDURE PACK(L,OFFSET,N);VALUE L,OFFSET,N;INTEGER L,OFFSET,N; 03116100
FORWARD; 03116110
INTEGER PROCEDURE UNPACK(S,OFFSET,N);VALUE S,OFFSET,N; 03116200
INTEGER S,OFFSET,N; FORWARD; 03116210
PROCEDURE PUSH; 03117000
IF ST LSS STACKSIZE+STACKBASE THEN ST:=ST+1 ELSE 03117100
ERR:=DEPTHERROR; 03117200
PROCEDURE POP; 03117300
BEGIN REAL U; 03117310
IF ST GTR STACKBASE THEN 03117400
IF BOOLEAN((U:=AREG).NAMED)OR NOT BOOLEAN(U.PRESENCE) 03117500
THEN ST:=ST-1 ELSE 03117510
BEGIN COMMENT GET RID OF SP STORAGE FOR THIS VARIABLE; 03117600
IF U.SPF NEQ 0 AND BOOLEAN(U.DATADESC) THEN 03117640
SCRATCHDATA(U); 03117650
03117660
ST:=ST-1; 03117700
END 03117800
ELSE ERR:=SYSTEMERROR; 03117900
END; 03117910
REAL PROCEDURE GETARRAY(DESCRIPTOR); VALUE DESCRIPTOR; 03118000
REAL DESCRIPTOR; 03118100
BEGIN 03118200
INTEGER R,I,J,K,L,LL,TOTAL,PT; 03118300
REAL T; 03118400
ARRAY BLOCK[0:BLOCKSIZE],DIMVECTOR[0:32]; 03118600
%SEE MAXWORDSTORE, LINE 17260 03118605
03118700
T:=DESCRIPTOR; 03118750
IF (R:=DESCRIPTOR.RF=0) THEN T.DIMPTR:=0 03118800
ELSE BEGIN 03118900
I:=CONTENTS(WS,DESCRIPTOR.DIMPTR,DIMVECTOR); 03119000
TOTAL:=1; 03119010
FOR I:=0 STEP 1 UNTIL R-1 DO 03119100
TOTAL:=TOTAL|DIMVECTOR[I]; 03119200
IF DESCRIPTOR.ARRAYTYPE=CHARARRAY THEN 03119300
TOTAL:=ENTIER((TOTAL+7) DIV 8); 03119400
TOTAL:=TOTAL+R; 03119500
LL:=GETSPACE(TOTAL); 03119600
TRANSFERSP(INTO,SP,LL,DIMVECTOR,0,R); 03119700
L:=LL+R; 03119800
J:=CONTENTS(WS,DESCRIPTOR.INPTR,DIMVECTOR)-1; 03119900
GTA[0]:=0; 03119910
FOR I:=0 STEP 2 UNTIL J DO 03120000
BEGIN 03120100
TRANSFER(DIMVECTOR,I,GTA,6,2); 03120200
PT:=GTA[0]; 03120210
K:=CONTENTS(WS,PT,BLOCK); 03120300
TRANSFERSP(INTO,SP,L,BLOCK,0, 03120400
(K:=ENTIER((K+7)DIV 8))); 03120500
L:=L+K; 03120600
END; 03120700
T.DIMPTR:=LL; 03120800
END; 03120900
T.INPTR:=0; 03121000
T.PRESENCE:=1; 03121100
GETARRAY:=T; 03121150
END; 03121200
INTEGER PROCEDURE FINDSIZE(D);VALUE D; REAL D; 03121250
BEGIN 03121255
INTEGER I,J,M,R; 03121260
J:=1; I:=D.SPF; R:=D.RF+I-1; 03121265
IF I NEQ 0 THEN 03121268
FOR M:=I STEP 1 UNTIL R DO J:=J|SP[MOC]; 03121270
FINDSIZE:=J; 03121275
END PROCEDURE FINDSIZE; 03121280
03121285
INTEGER PROCEDURE NUMELEMENTS(D); VALUE D; REAL D; 03121300
BEGIN 03121310
INTEGER I; 03121320
GT1:=I:=FINDSIZE(D); 03121322
IF D.ARRAYTYPE=CHARARRAY THEN 03121330
I:=ENTIER((I+7) DIV 8); 03121335
NUMELEMENTS:=I; 03121337
END; 03121340
PROCEDURE SCRATCHDATA(D); VALUE D; REAL D; 03121400
BEGIN 03121410
INTEGER T,R; 03121420
IF BOOLEAN(D.SCALAR) THEN T:=1 ELSE 03121430
IF R:=D.RF = 0 THEN T:=0 ELSE %BONAFIDE VECTOR 03121440
BEGIN T:=NUMELEMENTS(D)+R; 03121450
03121452
END; 03121454
IF T NEQ 0 THEN FORGETSPACE(D.SPF,T); 03121460
END; 03121470
COMMENT RELEASEARRAY HAS BEEN MOVED OUT OF PROCESS SO THAT IT 03121490
CAN BE CALLED ELSEWHERE; 03121491
REAL PROCEDURE MOVEARRAY(SPDESC); VALUE SPDESC; 03122500
REAL SPDESC; 03122550
COMMENT MOVE THE ARRAY FROM SCRATCHPAD TO PERMANENT 03122560
STORAGE AND CONSTRUCT NEW DESCRIPTOR; 03122570
BEGIN 03122600
INTEGER TOTAL,R,J,M,K; 03122650
REAL T; 03122660
ARRAY BLOCK[0:BLOCKSIZE],BUFFER[0:32]; %SEE MAXWORDSTORE, LINE 1726003122700
T:=SPDESC; 03122710
TRANSFERSP(OUTOF,SP,SPDESC.SPF,BUFFER,0,R:=SPDESC.RF); 03122750
T.DIMPTR:=STORESEQ(WS,BUFFER,8|R); 03122800
TOTAL:=NUMELEMENTS(SPDESC); 03122850
M:=SPDESC.SPF+R; 03123100
K:=ENTIER(TOTAL DIV BLOCKSIZE)-1; 03123150
FOR J:=0 STEP 1 UNTIL K DO BEGIN 03123200
TRANSFERSP(OUTOF,SP,M,BLOCK,0,BLOCKSIZE); 03123250
R:=STORESEQ(WS,BLOCK,BLOCKSIZE|8); 03123300
TRANSFER(R,6,BUFFER,J|2,2); 03123350
M:=M+BLOCKSIZE; 03123400
END; 03123450
IF J:=TOTAL-(K:=K+1)|BLOCKSIZE GTR 0 THEN 03123500
BEGIN 03123550
TRANSFERSP(OUTOF,SP,M,BLOCK,0,J); %GET REMAINDER OF MATRIX 03123600
R:=STORESEQ(WS,BLOCK,J|8); 03123640
TRANSFER(R,6,BUFFER,K|2,2); 03123650
K:=K+1; 03123660
END; 03123700
T.INPTR:=STORESEQ(WS,BUFFER,K|2); 03123750
MOVEARRAY:=T; 03123810
END; 03123850
PROCEDURE WRITEBACK; 03124000
COMMENT COPY CHANGED VARIABLES INTO PERMANENT STORAGE; 03124010
BEGIN 03124050
INTEGER I,J,K,L,M,NUM; 03124100
REAL T; 03124110
ARRAY NEWDESC[0:1],OLDDESC [0:1]; 03124150
L:=SYMBASE; 03124200
NUM:=SP[LOC]-1; 03124250
L:=L-1; 03124300
FOR I:=1 STEP 2 UNTIL NUM DO BEGIN 03124350
L:=L+2; 03124400
IF ((T:=SP[LOC]).TYPEFIELD) NEQ FUNCTION THEN 03124410
IF BOOLEAN(T.CHANGE) THEN BEGIN 03124450
IF VARIABLES=0 THEN 03124500
03124510
BEGIN VARIABLES:=NEXTUNIT; 03124520
T:=CURRENTMODE; 03124525
VARSIZE:=1; STOREPSR; 03124530
CURRENTMODE:=T; VARSIZE:=0; 03124535
END; 03124540
M:=L+1;WHILE(T:=SP[MOC]).BACKP NEQ 0 AND T.PRESENCE=1 03124550
AND(GT1:=GT1+1)LSS MAXMEMACCESSES DO M:=T.BACKP;GT1:=0; 03124560
GTA[0]:=SP[LOC];GTA[1]:=T; 03124570
TRANSFER(GTA,1,NEWDESC,0,7); 03124600
03124610
SETFIELD(NEWDESC,7,1, IF BOOLEAN(T.SCALAR) 03124650
THEN SCALARDATA ELSE ARRAYDATA); 03124700
MOVE(NEWDESC,1,OLDDESC); K:=1; 03124710
IF (IF VARSIZE=0 THEN FALSE ELSE 03124800
K:=SEARCHORD(VARIABLES,NEWDESC,J,7)=0) 03124850
THEN BEGIN 03124900
K:=CONTENTS(VARIABLES,J,OLDDESC); 03124950
DELETE1(VARIABLES,J); 03125000
IF GETFIELD(OLDDESC,7,1)=ARRAYDATA THEN 03125050
RELEASEARRAY(OLDDESC[1]); 03125100
END ELSE 03125150
BEGIN VARSIZE:=VARSIZE+1; J:=J+K-1; 03125160
MOVE(OLDDESC,1,NEWDESC); 03125170
END; 03125180
SETFIELD(NEWDESC,7,1,IF BOOLEAN(T.SCALAR) 03125200
THEN SCALARDATA ELSE ARRAYDATA); 03125210
IF BOOLEAN(T.SCALAR) THEN 03125250
BEGIN M:=T.SPF; 03125300
NEWDESC[1]:=SP[MOC]; 03125350
END ELSE %A VECTOR 03125360
BEGIN T.PRESENCE:=0; 03125370
NEWDESC[1]:=(IF T.RF NEQ 0 THEN 03125372
MOVEARRAY(T) ELSE T) 03125374
END; 03125378
STOREORD(VARIABLES,NEWDESC,J); 03125400
03125405
END; 03125450
END; 03125500
END; 03125550
PROCEDURE SPCOPY(S,D,N);VALUE S,D,N;INTEGER S,D,N; 03130000
BEGIN 03130100
INTEGER K; 03130200
WHILE (N:=N-K) GTR 0 DO 03130300
TRANSFERSP(INTO,SP,(D:=D+K),SP[(S:=S+K)DIV SPRSIZE,*], 03130400
K:=S MOD SPRSIZE,K:=MIN(N,SPRSIZE-K)); 03130500
END; 03130600
INTEGER PROCEDURE CHAIN(D,CHAINLOC); VALUE D,CHAINLOC; 03131000
INTEGER CHAINLOC; REAL D; 03131100
BEGIN 03131200
INTEGER M; 03131300
CHAIN:=M:=GETSPACE(1); 03131400
D.LOCFIELD:=CHAINLOC; 03131500
SP[MOC]:=D; 03131600
END; 03131700
PROCEDURE SCRATCHAIN(L); VALUE L; INTEGER L; 03132000
BEGIN 03132100
REAL R; 03132200
WHILE L NEQ 0 DO BEGIN 03132300
SCRATCHDATA(R:=SP[LOC]); 03132400
FORGETSPACE(L,1); 03132500
IF L=R.LOCFIELD THEN L:=0 ELSE 03132590
L:=R.LOCFIELD; 03132600
END; 03132700
END; 03132800
PROCEDURE RESTORELOCALS(FPTR);VALUE FPTR;REAL FPTR; 03133000
BEGIN 03133050
INTEGER L,M,N,I,K,FLOC; 03133100
REAL T; 03133150
M:=FPTR.LOCFIELD; 03133200
L:=FPTR.SPF+2;K:=SP[LOC]-2;%LAST ALPHA POINTER 03133300
T:=L+4; 03133350
FOR I:=T STEP 2 UNTIL K DO % ONCE FOR EACH LOCAL 03133400
BEGIN 03133450
M:=M+1;N:=SP[MOC].SPF; %LOCATION IN SYMBOL TABLE 03133500
T:=SP[NOC];L:=T.BACKP;T.BACKP:=0;T.NAMED:=0; 03133550
SP[MOC]:=T;%COPY OF DESCRIPTOR TO STACK 03133600
IF L=0 THEN 03133650
BEGIN N:=N-1; GTA[0]:=SP[NOC]; 03133660
TRANSFER(GTA,1,ACCUM,2,7); OPERANDTOSYMTAB(N); 03133670
END 03133680
ELSE BEGIN SP[NOC]:=SP[LOC];FORGETSPACE(L,1);END; 03133700
END; 03133750
END; % OF PROCEDURE RESTORELOCALS 03133800
OWN INTEGER FUNCLOC,POLLOC,LASTMKS,POLTOP,CINDEX; 03135000
PROCEDURE STEPLINE(LABELED); VALUE LABELED; 03140000
BOOLEAN LABELED; 03140020
03140030
BEGIN 03140040
LABEL ENDFUNC,TERMINATE,DONE; 03140050
LABEL BUMPLINE; 03140052
LABEL TRYNEXT; 03140054
REAL STREAM PROCEDURE CON(A); VALUE A; 03140060
BEGIN SI:= LOC A; DI:=LOC CON; DS:=8DEC; 03140070
END; 03140080
INTEGER C; 03140081
REAL N,T,L,TLAST,M,BASE; 03140090
COMMENT 03140091
MONITOR PRINT (FUNCLOC,POLLOC,LASTMKS,POLTOP,CINDEX,N,T,L, 03140092
TLAST,M,BASE); 03140094
L:=FUNCLOC;M:=SP[LOC].SPF+L; 03140100
IF BOOLEAN(SP[MOC].SUSPENDED) THEN 03140105
BEGIN %RESUME A SUSPENDED FUNCTION 03140110
SP[MOC].SUSPENDED:=0;%REMOVE SUSPENDED BIT 03140115
RESTORELOCALS(SP[MOC]); 03140118
SP[LOC].RF:=N:=SP[LOC].RF-1; 03140120
IF N LEQ 0 THEN SUSPENSION:=0;% NO MORE SUSPENDED FNS 03140124
END; 03140126
IF LABELED THEN %MAKE INTIAL CHECKS AND CHANGES; 03140130
BEGIN 03140140
IF NOT BOOLEAN((T:=AREG).PRESENCE) OR L:=T.SPF=0 03140150
THEN 03140160
BEGIN LABELED:=FALSE; GO TO BUMPLINE; 03140161
END; 03140162
IF BOOLEAN (T.CHRMODE) THEN GO TO TERMINATE; 03140170
L:=L+T.RF; %PICK UP THE FIRST ELEMENT OF THE ARRAY 03140180
IF T:=SP[LOC] GTR 9999.99994 OR T LSS 0 THEN 03140190
T:=0; 03140200
T:=CON(ENTIER(T|10000+.5)) 03140210
END; BUMPLINE: 03140212
L:=LASTMKS; TLAST:=SP[LOC].BACKF; 03140214
C:=(LASTMKS:=SP[MOC].LOCFIELD)-STACKBASE;%LOC OF FMKS 03140216
WHILE TLAST GTR C DO %STRIP OFF CURRENT LINE 03140218
BEGIN L:=TLAST+STACKBASE;TLAST:=(N:=SP[LOC]).BACKF; 03140219
IF N.DID=IMKS THEN SCRATCHAIN(N.SPF); 03140220
END; 03140221
WHILE ST GEQ L AND ERR=0 DO POP; 03140222
IF ERR NEQ 0 THEN GO TO DONE; 03140224
M:=BASE:=SP[MOC].SPF;%LOC OF LABEL TABLE 03140230
TRYNEXT: 03140238
N:=SP[MOC]+M+1; % N IS ONE BIGGER THAN TOP 03140240
M:=M+2; M:=SP[MOC]+2; % M IS ON THE FIRST POINTER 03140250
IF LABELED THEN %BINARY SEARCH FOR THE DESIRED LINE 03140260
BEGIN 03140270
IF N-M LSS 2 THEN GO TO ENDFUNC; 03140280
WHILE N-M GTR 2 AND C LSS 1@8 DO 03140290
03140300
BEGIN L:=M+ENTIER((N-M)DIV 4)|2; C:=C+1; 03140320
IF T LSS SP[LOC] THEN N:=L ELSE M:=L 03140330
END; 03140340
IF C=1@8 THEN GO TERMINATE; 03140342
IF SP[MOC] NEQ T THEN GO ENDFUNC; T:=M; 03140350
%T HAS THE SP LOCATION OF THE CORRECT LABEL 03140360
END ELSE %BUMP THE POINTER 03140370
IF T:=CURLINE+2+BASE GEQ N OR T LSS M THEN GO ENDFUNC; 03140380
M:=T+1; CURLINE:=T-BASE; %M IS SET TO PROG DESC 03140390
IF NOT BOOLEAN((T:=SP[MOC]).PRESENCE) THEN %MAKE POLISH 03140400
BEGIN N:=BASE+1;N:=SP[NOC].SPF;%SEQ STORAGE UNIT 03140410
INITBUFF(BUFFER,BUFFSIZE); 03140420
N:=CONTENTS(N,T,BUFFER); %GET TEXT 03140430
RESCANLINE; WHILE LABELSCAN(GTA,0) DO; %CLEAR LABELS 03140432
IF BOOLEAN(EOB) THEN % AN EMPTY LINE--BUMP POINTER 03140434
BEGIN M:=BASE;LABELED:=FALSE;GO TO TRYNEXT;END ELSE 03140436
IF T:=ANALYZE(TRUE)=0 THEN % NO GOOD 03140440
GO TO DONE; 03140450
SP[MOC]:=T; %SAVE THE POLISH DESCRIPTOR AT M 03140460
END ; 03140470
PUSH; IF ERR NEQ 0 THEN GO TO DONE; 03140480
AREG:=(L:=ENTIER(M))&1[CCIF]&TLAST[BACKPT]; 03140490
LASTMKS:=ST; 03140491
POLLOC:=SP[LOC].SPF; 03140492
L:=T.SPF; POLTOP:=SP[LOC]; CINDEX:=1; 03140500
GO TO DONE; 03140510
ENDFUNC: 03140520
%ARRIVE HERE WHEN FUNCTION IS COMPLETED. 03140530
%GET RESULT OF FUNCTION 03140540
M:=FUNCLOC;M:=SP[MOC].SPF+M;N:=TLAST:=SP[MOC].LOCFIELD; 03140550
M:=SP[NOC].SPF;M:=SP[MOC]; 03140551
COMMENT I CANNOT CONJURE UP A CASE WHERE A USER RETURNS TO A 03140555
FUNCTION WHOSE DESCRIPTOR HAS BEEN PUSHED DOWN BY A SUSPENDED 03140556
VARIABLE.IF THIS HAPPENS-HOPE FOR A GRACEFUL CRASH; 03140557
%M IS THE DESCRIPTOR FOR THE FUNCTION, TLAST IS BASE ADDRESS 03140560
03140562
IF BOOLEAN(M.RETURNVALUE) THEN %GET THE RESULT 03140570
BEGIN 03140580
N:=M.SPF+5;%RELATIVE LOCATION OF RESULT 03140590
N:=SP[NOC]+TLAST; %LOCATION IN STACK OF RESLULT 03140600
T:=SP[NOC]; SP[NOC].NAMED:=1; N:=T; 03140610
END; 03140620
WHILE ST GEQ TLAST AND ERR=0 DO POP; %GET RID OF TEMPS 03140630
OLDDATA:=(T:=AREG).SPF; POP;% GET RID OF INTERRUPT MKS 03140635
IF ERR NEQ 0 THEN GO TO DONE; 03140640
IF BOOLEAN(M.RETURNVALUE) THEN %REPLACE RESULT 03140650
BEGIN PUSH; IF ERR NEQ 0 THEN GO TO DONE; 03140660
AREG:=N; %RESULT OF CALL 03140670
END; 03140680
L:=STACKBASE+1;L:=SP[LOC].SPF+1;M:=SP[LOC].SPF+L; 03140682
03140684
SP[MOC]:=0;SP[LOC].SPF:=(M:=M-1)-L; 03140686
COMMENT NOW INITIATE ANY OLD FUNCTIONS, AND GET POLISH 03140690
GOING; 03140700
LASTMKS:=N:=T.BACKF+STACKBASE; %LOCATION OF PROGRAM DESC. 03140710
T:=SP[NOC]; % PICK UP PROGRAM DESCRIPTOR 03140720
N:=T.SPF; %LOCATION OF POLISH DESCRIPTOR 03140730
POLLOC:=(N:=SP[NOC].SPF); 03140740
POLTOP:=SP[NOC]; 03140750
CINDEX:=T.CIF; 03140760
IF M NEQ L THEN % GET LAST FUNCTION STARTED 03140770
BEGIN N:=SP[MOC].LOCFIELD; 03140780
T:=SP[NOC]; 03140790
CURLINE:=T.CIF 03140800
END ELSE CURLINE:=0; 03140810
GO TO DONE; 03140820
TERMINATE: 03140830
ERR:=LABELERROR; 03140840
DONE: 03140850
END; 03142000
03148200
PROCEDURE FIXTAKEORDROP(LDESC,RDESC,OPT,MAP,SIZEMAP,SIZE); 03148300
VALUE LDESC,RDESC,OPT; REAL LDESC,RDESC; 03148310
INTEGER OPT, SIZE; ARRAY MAP, SIZEMAP [1]; 03148320
BEGIN INTEGER LRANK,LSIZE,L,M,RRANK,N,I,TOP,PUT; 03148330
DEFINE TAKE = OPT = 2#; 03148340
INTEGER LNUM, RNUM; LABEL QUIT; 03148350
IF LSIZE := FINDSIZE(LDESC) NEQ RRANK := RDESC.RF AND LSIZE NEQ 1 03148360
OR LRANK:=LDESC.RF GTR 1 AND LSIZE NEQ 1 03148365
OR L := LDESC.SPF=0 03148370
OR M := RDESC.SPF = 0 THEN BEGIN 03148380
ERR:=DOMAINERROR; GO TO QUIT; END; 03148390
L := L + LRANK; 03148400
03148410
SIZE := 1; 03148420
FOR I := 1 STEP 1 UNTIL RRANK DO BEGIN 03148430
RNUM:=SP[MOC]; 03148440
LNUM:=IF TAKE THEN SP[LOC] ELSE (PUT:=SP[LOC])-SIGN(PUT)|RNUM; 03148450
IF ABS(LNUM) GTR RNUM THEN BEGIN 03148460
ERR:=DOMAINERROR; GO TO QUIT; END; 03148470
IF LNUM = 0 THEN BEGIN 03148480
SIZE := 0; GO TO QUIT; END; 03148490
IF LNUM GTR 0 THEN BEGIN 03148500
SIZEMAP[I] := LNUM; 03148510
MAP[I] . SPF := 0; 03148520
MAP[I] . RF := 1; 03148530
END ELSE BEGIN 03148540
LNUM:=ABS(LNUM); 03148550
PUT := RNUM - LNUM + ORIGIN; 03148560
MAP[I].SPF := N := GETSPACE(LNUM+1); 03148570
SIZEMAP[I] := SP[NOC] := LNUM; 03148580
TOP := N + LNUM; 03148590
FOR N:=N+1 STEP 1 UNTIL TOP DO BEGIN 03148600
SP[NOC]:=PUT; PUT:=PUT+1; END; 03148610
MAP[I].RF := 1; 03148620
MAP[I] := - MAP[I]; 03148630
END; 03148640
IF LSIZE NEQ 1 THEN L:=L+1; 03148650
M:=M+1; 03148660
SIZE:=SIZE | LNUM; 03148670
END; 03148680
QUIT: END PROCEDURE FIXTAKEORDROP; 03148690
REAL PROCEDURE SUBSCRIPTS(DIRECTION,D,RANK); 03150000
VALUE DIRECTION,D,RANK; REAL D,RANK; INTEGER DIRECTION; 03150010
BEGIN COMMENT THIS PROCEDURE EVALUATES A SET OF SUBSCRIPTS 03150020
,POPS THEM OFF OF THE STACK, AND RETURNS WITH A DESC. 03150030
FOR THE ITEM REFERENCED; 03150040
LABEL GOHOME,DONE; 03150050
INTEGER SIZE,I,L,M,N,VALUW; 03150060
INTEGER ADDRESS,NOTSCAL,DIM,LEVEL,TEMP,K,J; 03150070
REAL SUBDESC,T; 03150080
BOOLEAN DCHARS; 03150081
STREAM PROCEDURE TCHAR(A,B,C,D);VALUE B,D; 03150083
BEGIN SI:=A;SI:=SI+B;DI:=C;DI:=DI+D;DS:=CHR;END; 03150085
ARRAY MAP[1:RANK],SIZEMAP[1:RANK]; 03150100
ARRAY BLOCKSIZE[1:RANK],POINTER[0:RANK],PROGRESS[1:RANK]; 03150102
INTEGER PROCEDURE SUBINDEX(M,S,P);VALUE M,S,P;REAL M,S,P; 03150104
IF M LSS 0 THEN BEGIN M:=-M; 03150106
M:=P+M.SPF+M.RF-1;SUBINDEX:=SP[MOC]-ORIGIN;END 03150107
ELSE SUBINDEX:=(IF S=1 THEN M.SPF ELSE M.SPF+P-1); 03150108
COMMENT 03150109
MONITOR PRINT(I,L,M,N,VALUW,ADDRESS,T,ERR,MAP,SIZEMAP, 03150110
SIZE,D,RANK,DIRECTION); 03150111
DCHARS:=BOOLEAN(D.CHRMODE); 03150112
IF DIRECTION GTR 1 THEN % THIS IS TAKE OR DROP 03150116
BEGIN 03150118
NOTSCAL:=1; 03150120
FIXTAKEORDROP(AREG,BREG,DIRECTION,MAP,SIZEMAP,SIZE); 03150124
IF ERR NEQ 0 THEN GO TO GOHOME; 03150125
IF SIZE=0 THEN BEGIN D.DID:=DDPUVW; D.RF:=1; 03150126
D.SPF:=0; SUBSCRIPTS:=D; GO TO GOHOME; END; 03150127
%IF SIZE=0 AND TAKE OR DROP, RESULT IS A NULL 03150128
END ELSE BEGIN 03150129
IF RANK NEQ D.RF THEN BEGIN ERR:=RANKERROR;GO TO GOHOME;END; 03150130
SIZE:=1; 03150140
N:=D.SPF-1; 03150150
L:=ST-1; % LOCATE THE EXECUTION STACK 03150152
FOR I:=1 STEP 1 UNTIL RANK DO 03150160
BEGIN 03150170
L:=L-1; SUBDESC:=SP[LOC]; % WANDER INTO EXEC STACK 03150180
IF ERR NEQ 0 THEN GO TO GOHOME; 03150190
N:=N+1; 03150200
IF BOOLEAN(SUBDESC.SCALAR) THEN 03150210
BEGIN M:=SUBDESC.SPF; 03150220
IF (VALUW:=SP[MOC]-ORIGIN) GEQ SP[NOC] 03150230
OR VALUW LSS 0 THEN BEGIN ERR:=INDEXERROR;GO TO 03150240
GOHOME; END; 03150242
MAP[I]:=VALUW; SIZEMAP[I]:=1; 03150250
END ELSE % CHECK FOR A NULL 03150260
IF SUBDESC.SPF=0 THEN % THIS IS A NULL 03150270
BEGIN 03150280
NOTSCAL:=1; 03150282
SIZE:=SIZE|(M:=SP[NOC]); 03150290
MAP[I].RF:=1;SIZEMAP[I]:=M; 03150300
END ELSE % IT MUST BE A VECTOR 03150310
BEGIN DEFINE STARTSEGMENT=#; %////////////////////////// 03150320
03150330
03150340
NOTSCAL:= 1; 03150342
MAP[I]:=-((M:=SUBDESC.SPF)&SUBDESC.RF[CRF]); 03150350
SIZE:=SIZE|(SIZEMAP[I]:=FINDSIZE(SUBDESC)); 03150360
J:=SP[NOC]+ORIGIN;M:=M+SUBDESC.RF;T:=SIZEMAP[I]+M 03150362
-1; 03150363
FOR M:=M STEP 1 UNTIL T DO 03150364
IF SP[MOC] GEQ J OR SP[MOC] LSS ORIGIN THEN 03150366
BEGIN ERR:=INDEXERROR; GO TO GOHOME; END; 03150368
END; 03150370
END; % OF THE FOR STATEMENT 03150380
END; 03150390
IF SIZE LEQ 0 THEN BEGIN ERR:=INDEXERROR;GO TO GOHOME;END; 03150400
IF SIZE=1 AND NOT BOOLEAN(NOTSCAL) THEN %SCALAR REFERENCED 03150410
BEGIN 03150420
DEFINE STARTSEGMENT=#; %//////////////////////////////// 03150430
N:=D.SPF; M:=RANK-1; 03150440
FOR I:=1 STEP 1 UNTIL M DO 03150450
BEGIN N:= N+1; 03150460
ADDRESS:=SP[NOC]|(ADDRESS+MAP[I]); 03150470
END; 03150480
ADDRESS:=ADDRESS+MAP[RANK] +1; 03150490
IF DIRECTION=OUTOF THEN 03150500
IF DCHARS THEN BEGIN 03150502
N:=(ADDRESS+7)DIV 8+N;J:=(ADDRESS-1)MOD 8; 03150503
T:=M:=GETSPACE(2);SP[MOC]:=1;M:=M+1; 03150504
SP[MOC]:=0; TCHAR(SP[NOC],J,SP[MOC],0); 03150506
SUBSCRIPTS:=T&1[CRF]&DDPUVC[CDID]; 03150508
END ELSE 03150509
BEGIN N:= ADDRESS+N; 03150510
M:=GETSPACE(1);SP[MOC]:=SP[NOC]; 03150520
T:=M; T.DID:=DDPUSW; 03150550
SUBSCRIPTS:=T; 03150560
END ELSE % DIRECTION IS INTO 03150600
BEGIN 03150610
L:=L-1;SUBSCRIPTS:=SUBDESC:=SP[LOC]; 03150620
IF DCHARS AND FINDSIZE(SUBDESC)=1 OR 03150630
BOOLEAN(SUBDESC.SCALAR) THEN 03150631
BEGIN 03150640
L:=GETSPACE(N:=(NUMELEMENTS(D)+D.RF)); 03150650
SPCOPY(D.SPF,L,N); % MAKE A NEW COPY 03150660
IF DCHARS THEN BEGIN 03150662
N:=(ADDRESS+7)DIV 8+L;J:=(ADDRESS-1)MOD 8; 03150663
M:=SUBDESC.SPF;IF SP[MOC] GTR 1 OR SUBDESC.RF 03150664
NEQ 1 THEN BEGIN ERR:=DOMAINERROR;GO TO 03150665
GOHOME;END; 03150666
M:=M+1;TCHAR(SP[MOC],0,SP[NOC],J); 03150667
END ELSE BEGIN 03150669
M:=L+ADDRESS+D.RF-1; 03150670
N:=SUBDESC.SPF; 03150680
SP[MOC]:=SP[NOC]; %PERFORM THE REPLACEMENT 03150690
END; 03150700
N:=D.LOCFIELD;I:=SP[NOC].BACKP; 03150710
SP[NOC]:=D&L[CSPF]&I[CLOCF];%STORE NEW DESC 03150712
OLDDATA:=CHAIN(D,OLDDATA); 03150714
IF BOOLEAN(D.NAMED) THEN BEGIN 03150720
N:=N-1;IF I=0 AND SP[NOC].SUSPENDVAR=0 03150730
THEN SP[NOC].CHANGE:=1%MUST BE A REAL GLOBAL 03150740
END ELSE %MUST BE A LOCAL VARIABLE 03150750
AREG.NAMED:=1; %DONT LET IT BE FORGOTTEN 03150760
END ELSE ERR:=RANKERROR; 03150770
END; 03150780
END ELSE % A VECTOR IS REFERENCED 03150800
BEGIN % START WITH INITIALIZATION 03150805
N:=D.SPF+D.RF;BLOCKSIZE[RANK]:=PROGRESS[RANK]:=J:=1; 03150810
FOR I:=RANK-1 STEP -1 UNTIL 1 DO 03150815
BEGIN N:=N-1; 03150820
J:=BLOCKSIZE[I]:=J|SP[NOC]; 03150825
PROGRESS[I]:=1; 03150830
END; 03150835
K:=POINTER[1]:=SUBINDEX(MAP[1],SIZEMAP[1],PROGRESS[1]) 03150840
|BLOCKSIZE[1]; 03150845
FOR I:=2 STEP 1 UNTIL RANK DO 03150850
K:=POINTER[I]:=K+SUBINDEX(MAP[I],SIZEMAP[I], 03150855
PROGRESS[I])|BLOCKSIZE[I]; 03150860
DIM:=0; 03150865
FOR I:=1 STEP 1 UNTIL RANK DO 03150870
IF SIZEMAP[I] GTR 1 THEN DIM:=DIM+MAP[I].RF; 03150875
IF DCHARS THEN BEGIN TEMP:=D; D.SPF:=UNPACK(D.SPF, 03150876
RANK,FINDSIZE(D)); IF DIM=0 THEN DIM:=1; END; 03150878
IF DIRECTION GTR 0 THEN % OUTOF..TAKE.. OR DROP 03150880
BEGIN DEFINE STARTSEGMENT=#; %////////////////////////// 03150885
IF SIZE+DIM GTR MAXWORDSTORE THEN BEGIN ERR:=KITEERROR; GO TO 03150886
GOHOME END ELSE TEMP:=L:=GETSPACE(SIZE+DIM); %ROOM FOR RESULT 03150887
IF DIM GTR 0 THEN 03150888
IF DIM=1 THEN BEGIN SP[LOC]:=SIZE; L:=L+1;END 03150890
ELSE FOR I:=1 STEP 1 UNTIL RANK DO 03150895
IF SIZEMAP[I] GTR 1 THEN 03150900
IF (M:=MAP[I].SPF)=0 THEN BEGIN SP[LOC]:= 03150901
SIZEMAP[I];L:=L+1;END ELSE 03150902
BEGIN N:=M+MAP[I].RF-1; 03150904
03150905
FOR M:=M STEP 1 UNTIL N DO BEGIN 03150906
SP[LOC]:=SP[MOC];L:=L+1;END; 03150908
END; 03150909
COMMENT THIS INITIALIZES RESULT DIM VECTOR; 03150910
ADDRESS:= D.SPF+D.RF; 03150912
END ELSE % DIRECTION IS INTO 03150915
BEGIN DEFINE STARTSEGMENT=#; %///////////////// 03150920
L:=L-1; SUBSCRIPTS:=SUBDESC:=SP[LOC]; 03150925
IF FINDSIZE(SUBDESC) NEQ SIZE THEN 03150930
BEGIN ERR:=RANKERROR; GO TO GOHOME;END; 03150932
N:=SUBDESC.RF; 03150940
IF BOOLEAN(SUBDESC.CHRMODE) THEN SUBDESC.SPF:= 03150942
UNPACK(SUBDESC.SPF,N,FINDSIZE(SUBDESC)); 03150944
IF DCHARS THEN L:= D.SPF ELSE BEGIN 03150946
L:=GETSPACE(N:=(NUMELEMENTS(D)+D.RF)); 03150950
SPCOPY(D.SPF,L,N); % MAKE FRESH COPY TO PATCH INTO 03150960
END; 03150962
ADDRESS:=L+D.RF; % SP LOCATION TO STORE INTO 03150970
N:=D.LOCFIELD;I:=SP[NOC].BACKP; 03150971
SP[NOC]:=D&L[CSPF]&I[CLOCF];%STORE NEW DESC. 03150972
OLDDATA:=CHAIN(IF DCHARS THEN TEMP ELSE D,OLDDATA); 03150974
IF BOOLEAN(D.NAMED ) THEN BEGIN 03150980
N:=N-1;IF I=0 AND SP[NOC].SUSPENDVAR=0 03150990
THEN SP[NOC].CHANGE:=1%MUST BE A REAL GLOBAL 03151000
END ELSE %IT MUST BE A LOCAL VARIABLE 03151010
AREG.NAMED:=1;%DONT LET IT BE FORGOTTEN ON POP 03151020
L:=SUBDESC.SPF+SUBDESC.RF;%POINT TO SOURCE 03151030
END; 03151040
03151300
03151305
WHILE TRUE DO % RECURSIVE EVALUATION LOOP 03151310
BEGIN N:=POINTER[RANK]+ADDRESS; 03151320
LEVEL:=RANK; 03151322
IF DIRECTION GTR 0 THEN %OUTOF..TAKE..DROP 03151330
BEGIN SP[LOC]:=SP[NOC]; L:=L+1; 03151340
END ELSE BEGIN % INTO 03151350
SP[NOC]:= SP[LOC];L:=L+1; END; 03151360
WHILE PROGRESS[LEVEL]GEQ SIZEMAP[LEVEL] DO 03151420
BEGIN PROGRESS[LEVEL]:=1 ; %LOOK FOR MORE WORK 03151430
IF LEVEL:=LEVEL-1 LEQ 0 THEN GO TO DONE; 03151440
END; 03151450
COMMENT THERE IS MORE ON THIS LEVEL; 03151460
PROGRESS[LEVEL]:=PROGRESS[LEVEL]+1; 03151470
K:=POINTER[LEVEL]:=POINTER[LEVEL-1] +SUBINDEX( 03151480
MAP[LEVEL],SIZEMAP[LEVEL],PROGRESS[LEVEL])| 03151482
BLOCKSIZE[LEVEL];%POINTER[0] IS 0 03151484
FOR I:=LEVEL+1 STEP 1 UNTIL RANK DO 03151490
K:=POINTER[I]:=K+SUBINDEX(MAP[I],SIZEMAP[I], 03151500
PROGRESS[I])|BLOCKSIZE[I]; 03151510
END; % OF RECURSIVE EVALUATION LOOP 03151520
DONE: IF DIRECTION GTR 0 THEN % OUTOF TAKE OR DROP 03151550
IF DCHARS THEN BEGIN PACK(TEMP,DIM,SIZE); 03151552
FORGETSPACE(D.SPF,RANK+FINDSIZE(D)); 03151554
SUBSCRIPTS:=TEMP&DIM[CRF]&DDPUVC[CDID]; 03151556
END ELSE % THIS IS A NUMERIC VECTOR 03151557
IF DIM=0 THEN SUBSCRIPTS:=TEMP&DDPUSW[CDID] ELSE 03151558
SUBSCRIPTS:=TEMP&DIM[CRF]&DDPUVW[CDID] 03151560
ELSE % THE DIRECTION IS INTO 03151562
BEGIN IF BOOLEAN(SUBDESC.CHRMODE) THEN 03151564
FORGETSPACE(SUBDESC.SPF,FINDSIZE(SUBDESC)+1); 03151566
IF DCHARS THEN PACK(D.SPF,RANK,FINDSIZE(D)); 03151568
END; 03151570
03151580
END; 03151800
GOHOME: IF DIRECTION GTR 1 THEN 03152000
FOR I:=1 STEP 1 UNTIL RANK DO 03152003
IF MAP[I] LSS 0 THEN FORGETSPACE(MAP[I].SPF,SIZEMAP[I]+1); 03152006
END; % OF SUBSCRIPTS PROCEDURE 03152010
PROCEDURE IMS(N); VALUE N; INTEGER N; 03152100
BEGIN COMMENT N=0 FOR REGULAR INTERRUPT MKS 03152110
N=1 FOR QQUAD INTERRUPT MKS 03152120
N=2 FOR QUAD INTERRUPT MKS 03152130
N=3 FOR EXECUTION LINE FOLLOWING 03152132
N=4 FOR SUSPENDED FUNCTION; 03152134
INTEGER L,M; 03152150
03152155
PUSH;AREG:=OLDDATA&(LASTMKS-STACKBASE) 03152160
[BACKPT]&N[QUADINV]&IMKS[CDID]; 03152170
IF N NEQ 4 THEN BEGIN L:=LASTMKS;SP[LOC].CIF:=CINDEX;END; 03152180
L:=STACKBASE+1;L:=SP[LOC].SPF +1; 03152190
IF (M:=SP[LOC].SPF) NEQ 0 THEN % SAVE CURLINE 03152195
BEGIN L:=L+M; L:=SP[LOC].LOCFIELD; 03152200
SP[LOC].CIF:=CURLINE; 03152210
END; 03152220
LASTMKS:=ST; 03152225
END; 03152230
PROCEDURE DISPLAYCHARV(D); VALUE D; REAL D; 03152500
BEGIN INTEGER I,J,K,L,M,NWORDS,NJ,T,NMAT,II,JJ,WDLINE,F,CC; 03152510
COMMENT WDLINE=#WORDS NEEDED TO FILL A TELETYPE LINE 03152512
NWORDS=#WORDS NEEDED TO GET F CHARACTERS FOR LAST 03152514
TELETYPE LINE OF A ROW 03152515
F=#CHARACTERS IN LAST TELETYPE LINE OF A ROW 03152516
T=#TELETYPE LINES NEEDED PER ROW BEYOND FIRST LINE 03152517
NMAT=#MATRICES TO BE PRINTED OUT (1 IF RANK=2); 03152518
L := (T:=D.SPF) + (NJ:=D.RF) - 1; 03152520
J := SP[LOC]; %J IS NUMBER OF CHARACTERS PER ROW 03152530
IF NJ GTR 1 THEN BEGIN 03152540
L:=L-1; K:=SP[LOC] 03152550
END ELSE K := 1; %K IS NUMBER OF ROWS PER MATRIX 03152560
03152570
L := T + NJ; 03152580
NMAT := FINDSIZE(D) DIV (J|K); 03152590
WDLINE := (LINESIZE+6) DIV 8 + 1; 03152595
IF II:=J-LINESIZE GTR 0 THEN BEGIN 03152600
T:=II DIV (I:=LINESIZE-2)+(IF II MOD I=0 THEN 0 ELSE 1); 03152605
NWORDS:=((F:=II-(T-1)|I)+6) DIV 8 + 1; 03152610
END ELSE BEGIN NWORDS:=((F:=J)+6)DIV 8 + 1; T:=0; END; 03152615
FOR II:=1 STEP 1 UNTIL NMAT DO BEGIN 03152620
FOR I:=1 STEP 1 UNTIL K DO BEGIN 03152625
CC:=0; 03152630
FOR JJ:=1 STEP 1 UNTIL T DO BEGIN 03152635
TRANSFERSP(OUTOF,SP,L+M DIV 8,BUFFER,0,WDLINE); 03152640
FORMROW(3,CC,BUFFER,ENTIER(M MOD 8),NJ:=LINESIZE-CC); 03152644
M := M + NJ; CC := 2; END; 03152646
IF I=K AND II=NMAT THEN IF L+M DIV 8 + NWORDS GTR 03152648
(1+NROWS)|SPRSIZE THEN NWORDS:=NWORDS-1; 03152650
%TO TAKE CARE OF BEING AT END OF SP 03152655
TRANSFERSP(OUTOF,SP,L+M DIV 8, BUFFER,0,NWORDS); 03152660
FORMROW(3,CC,BUFFER,ENTIER(M MOD 8), F); 03152670
M := M + F; 03152680
END; 03152690
FORMWD(3,"1 "); 03152700
END; 03152710
END OF CHARACTER DISPLAY PROCEDURE; 03152720
REAL PROCEDURE SEMICOL; 03153000
BEGIN COMMENT FORM CHAR STRING FROM TWO DESCRIPTORS; 03153010
INTEGER J,K,L; 03153020
REAL LD, RD; 03153025
STREAM PROCEDURE BLANKS(B,J,K);VALUE J,K; 03153030
BEGIN LOCAL T,U; 03153032
SI:=LOC K; DI:=LOC U; DI:=DI+1; DS:=7 CHR; 03153034
SI:=LOC J; DI:=LOC T; DI:=DI+1; DS:=7 CHR; 03153036
DI:=B; U(2(DI:=DI+32));; DI:= DI+K; 03153038
T(2(DS:=32 LIT " "));J(DS:=1 LIT " "); 03153040
END; 03153042
PROCEDURE MOVEC(J,L,K);VALUE J,L,K; INTEGER J,L,K; 03153050
BEGIN INTEGER I; 03153060
IF(J+K+8) GTR MAXBUFFSIZE|8 THEN ERR:=LENGTHERROR ELSE 03153070
BEGIN TRANSFERSP(OUTOF,SP,L,BUFFER,ENTIER((J+7)DIV 8), 03153080
ENTIER((K+7) DIV 8)); 03153082
IF I:=(J MOD 8) NEQ 0 THEN TRANSFER(BUFFER,J+8-I, 03153090
BUFFER,J,K); END; 03153100
END; 03153110
INTEGER PROCEDURE MOVEN(J,L,K);VALUE J,L,K;INTEGER J,L,K; 03153150
BEGIN INTEGER I;K:=K+L-1; I:=MAXBUFFSIZE|8; 03153160
BLANKS(BUFFER,I-J,J); 03153161
FOR L:= L STEP 1 UNTIL K DO 03153162
BEGIN NUMBERCON(SP[LOC],ACCUM); 03153170
TRANSFER(ACCUM,2,BUFFER,J:=J+1,ACOUNT); 03153180
IF (J:=J+ACOUNT)GTR I THEN BEGIN L:=K;ERR:=LENGTHERROR; 03153190
END;END; 03153200
MOVEN:=J; 03153210
END; 03153220
LD := AREG; RD := BREG; 03153225
IF L:=LD.RF GTR 1 THEN ERR:= RANKERROR ELSE 03153300
IF LD.SPF NEQ 0 THEN 03153310
IF BOOLEAN(LD.CHRMODE) THEN MOVEC(0,L+LD.SPF,J:=FINDSIZE 03153320
(LD))ELSE J:=MOVEN(0,L+LD.SPF,FINDSIZE(LD)); 03153330
IF L:=RD.RF GTR 1 OR ERR NEQ 0 THEN ERR:=RANKERROR ELSE 03153340
IF RD.SPF NEQ 0 THEN IF BOOLEAN(RD.CHRMODE) THEN 03153350
BEGIN MOVEC(J,L+RD.SPF,K:=FINDSIZE(RD));J:=J+K; 03153360
END ELSE J:=MOVEN(J,L+RD.SPF,FINDSIZE(RD)); 03153370
IF ERR=0 THEN 03153380
IF J=0 THEN SEMICOL:=NULLV ELSE 03153381
BEGIN L:=GETSPACE((K:=ENTIER((J+7)DIV 8))+1); 03153382
TRANSFERSP(INTO,SP,L+1,BUFFER,0,K); 03153390
SP[LOC]:=J; SEMICOL:=L&1[CRF]&DDPUVC[CDID]; 03153400
END; 03153410
03153420
END; 03153430
BOOLEAN PROCEDURE SETUPLINE; 03153500
BEGIN REAL T;INTEGER M; 03153510
IF T:=ANALYZE(FALSE) NEQ 0 THEN % WE HAVE A PROGRAM DESC 03153520
BEGIN IMS(3); 03153530
M:=GETSPACE(1); SP[MOC]:=T; 03153540
LASTMKS:=ST-STACKBASE; 03153550
PUSH; IF ERR=0 THEN 03153560
BEGIN AREG:=PROGMKS&LASTMKS[BACKPT]&1[CI]&M[SPTSP]; 03153570
POLLOC:=M:=T.SPF; POLTOP:=SP[MOC]; 03153580
LASTMKS:=LASTMKS+1+STACKBASE; CINDEX:=1; 03153590
END; 03153600
SETUPLINE:=TRUE; 03153610
END ELSE SETUPLINE:=FALSE; 03153620
END; 03153630
BOOLEAN PROCEDURE POPPROGRAM(OLDDATA,LASTMKS); 03154000
REAL OLDDATA,LASTMKS; 03154100
BEGIN LABEL EXIT;REAL L,M,N; 03154200
WHILE TRUE DO 03154300
BEGIN 03154400
WHILE(L:=AREG).DATADESC NEQ 0 AND ERR=0 DO POP; 03154500
IF L.DID=PROGMKS THEN 03154600
IF L=0 THEN %SOMETHING IS FUNNY...CONTINUE POPPING 03154700
POP 03154710
ELSE BEGIN 03154800
LASTMKS:=M:=L.BACKF+STACKBASE; 03154850
IF L.BACKF NEQ 0 AND NOT ((N:=SP[MOC]).DID=IMKS 03154900
AND N.QUADIN=4) THEN POPPROGRAM:=TRUE; 03155000
IF N.DID NEQ FMKS THEN 03155090
FORGETPROGRAM(L);POP;GO TO EXIT; 03155100
END ELSE %NOT A PROGRAM MKS 03155200
IF L.DID=FMKS THEN 03155300
BEGIN % MUST CUT BACK STATE VECTOR 03155400
M:=STACKBASE+1;M:=SP[MOC].SPF+1;N:=SP[MOC].SPF+M; 03155500
IF BOOLEAN(SP[NOC].SUSPENDED) THEN BEGIN SP[MOC].RF:=L:=03155600
SP[MOC].RF-1;IF L=0 THEN SUSPENSION:=0;END; 03155700
SP[NOC]:=0;SP[MOC].SPF:=N-M-1;POP; 03155800
END ELSE % NOT A FMKS EITHER 03155900
IF L.DID=IMKS THEN 03156000
BEGIN SCRATCHAIN(OLDDATA);OLDDATA:=L.SPF;POP;END; 03156100
IF ERR NEQ 0 THEN GO TO EXIT; 03156200
END; % OF THE DO 03156300
EXIT: END;%OF PROCEDURE POPPROGRAM 03156400
REAL PROCEDURE BUILDALPHA(LASTCONSTANT); 03210000
INTEGER LASTCONSTANT; 03210005
BEGIN 03210010
ARRAY B[0:BUFFSIZE]; 03210020
REAL R; 03210030
INTEGER L,N; 03210040
REAL STREAM PROCEDURE GETCHRS(ADDR,B); VALUE ADDR; 03210050
BEGIN LOCAL C1,C2,TDI,TSI,QM; 03210060
LOCAL ARROW; 03210065
LABEL L,DSONE,FINIS,ERR; 03210070
DI:=LOC QM; DS:=2RESET; DS:=2SET; 03210080
DI:=LOC ARROW; DS:=RESET; DS:=7SET; 03210085
DI:=B; DS:=8LIT"0"; 03210090
SI:=ADDR; 03210100
L: 03210110
IF SC=""" THEN % MAY BE A DOUBLE QUOTE 03210120
BEGIN 03210130
SI:=SI+1; 03210140
IF SC=""" THEN % GET RID OF A QUOTE 03210150
GO TO DSONE; 03210160
COMMENT ELSE WE ARE LOOKING PAST THE RH QUOTE; 03210170
GO TO FINIS; 03210180
END ELSE % LOOK FOR THE QUESTION MARK 03210190
BEGIN TDI:=DI; DI:=LOC QM; 03210200
IF SC=DC THEN % END OF BUFFER ENCOUNTERED 03210210
GO TO ERR; 03210220
SI:=SI-1; DI:=LOC ARROW; 03210224
IF SC=DC THEN %FOUND LEFT ARROW 03210226
GO TO ERR; 03210228
SI:=SI-1; DI:=TDI; GO TO DSONE 03210230
END; 03210240
DSONE: DS:=CHR; TALLY:=TALLY+1; 03210250
C2:=TALLY; TSI:=SI; SI:=LOC C2; SI:=SI+7; 03210260
IF SC="0" THEN 03210270
BEGIN TALLY:=C1; TALLY:=TALLY+1; C1:=TALLY; 03210280
TALLY:=0; 03210290
END; 03210300
SI:=TSI; 03210310
GO TO L; 03210320
FINIS: GETCHRS:=SI; 03210330
DI:=B; SI:=LOC C1; SI:=SI+1; DS:=7CHR; SI:=LOC C2; 03210340
SI:=SI+7; DS:=CHR; 03210350
ERR: 03210360
END; 03210370
IF R:=GETCHRS(ADDRESS,B) NEQ 0 THEN % GOT A VECTOR 03210380
IF NOT CURRENTMODE=FUNCMODE THEN 03210385
BEGIN ADDRESS:=R; 03210390
COMMENT B[0] HAS THE LENGTH OF THE STRING; 03210400
IF R:=B[0] GEQ 1 THEN COMMENT A VECTOR; 03210410
BEGIN 03210420
L:=GETSPACE(N:=(R-1)DIV 8+2); 03210430
TRANSFERSP(INTO,SP,L,B,0,N); 03210432
SP[LOC]:=R; 03210440
END; 03210450
N:=GETSPACE(1); 03210460
R:= L; 03210470
R.DID:=DDPNVC; 03210480
R.BACKP:=LASTCONSTANT; 03210482
LASTCONSTANT:=N; 03210484
IF B[0]=0 THEN R.DID:=DDPNVW %NULL BECAUSE .SPF=.RF=0 03210490
%DON"T WANT CHARACTER NULL TO LOOK LIKE CHARS 03210492
ELSE R.RF:=1; 03210495
SP[NOC]:=R; 03210497
COMMENT WE HAVE BUILT THE VECTOR AND DESCRIPTOR; 03210500
BUILDALPHA:=N 03210510
END 03210520
ELSE BEGIN BUILDALPHA:=1;ADDRESS:=R END; 03210521
%ELSE WE HAVE AN ERROR (MISSING " ETC.) 03210525
END; % OF THE BUILD ALPHA PROCEDURE 03210530
PROCEDURE PACK(L,OFFSET,N); VALUE L,OFFSET,N; 03210600
INTEGER L,OFFSET,N; 03210610
BEGIN 03210620
LABEL QUIT; 03210625
INTEGER M,T,MB,S; 03210630
STREAM PROCEDURE PACKEM(A,B,N); VALUE N; 03210640
BEGIN LOCAL T; 03210650
SI:=LOC N; DI:=LOC T; DI:=DI+1; DS:=7CHR; 03210660
SI:=A; DI:=B; 03210670
T(2(32(SI:=SI+7; DS:=CHR))); N(SI:=SI+7; DS:=CHR); 03210680
END; 03210690
IF N = 0 THEN GO TO QUIT; 03210695
T:=(M:=L:=L+OFFSET)+N; 03210700
MB:=MAXBUFFSIZE DIV 8 | 8; 03210710
WHILE M LSS T DO 03210720
BEGIN 03210730
TRANSFERSP(OUTOF,SP,M,BUFFER,0,MB:=MIN(MB,T-M)); 03210740
PACKEM(BUFFER,ACCUM,MB); 03210750
TRANSFERSP(INTO,SP,L,ACCUM,0,S:=(MB+7)DIV 8); 03210760
L:=L+S; M:=M+MB 03210770
END; 03210780
FORGETSPACE(L,T-L); 03210790
QUIT: END PROCEDURE PACK; 03210800
INTEGER PROCEDURE UNPACK(S,OFFSET,N); VALUE N,S,OFFSET; 03210810
INTEGER N,S,OFFSET; 03210820
BEGIN 03210830
INTEGER L,M,K,MB,T; 03210840
LABEL QUIT; 03210845
STREAM PROCEDURE UNPACKEM(A,B,N); VALUE N; 03210850
BEGIN 03210860
LOCAL T; 03210870
SI:=LOC N; DI:=LOC T; DI:=DI+1; DS:=7CHR; 03210880
SI:=A; DI:=B; 03210890
T(2(32(DS:=7LIT"0"; DS:=CHR))); 03210900
N(DS:=7LIT"0"; DS:=CHR); 03210910
END; 03210920
IF N = 0 THEN BEGIN UNPACK := S; GO TO QUIT; END; 03210925
UNPACK:=L:=GETSPACE(OFFSET+N); K:=S+OFFSET-1; 03210930
FOR M:=S STEP 1 UNTIL K DO 03210940
BEGIN SP[LOC]:=SP[MOC]; L:=L+1 03210950
END; 03210960
K:=L+N; S:=S+OFFSET; 03210970
MB:=MAXBUFFSIZE DIV 8; 03210980
N := MB | 8; 03210985
WHILE L LSS K DO 03210990
BEGIN 03211000
TRANSFERSP(OUTOF,SP,S,BUFFER,0,M:=MIN(MB,(K-L+7)DIV 8)); 03211010
UNPACKEM(BUFFER,ACCUM, M := MIN(K-L, M|8)); 03211020
TRANSFERSP(INTO,SP,L,ACCUM,0,M); 03211030
L := L+N; S := S+MB 03211040
END; 03211050
QUIT: END PROCEDURE UNPACK; 03211060
PROCEDURE TRANSPOSE; 03220000
BEGIN INTEGER M,N,L,I,ROW,COL,RANK,OUTER,INNER; REAL NEWDESC; 03220100
INTEGER SIZE,J,MAT,TOP,START; BOOLEAN CHARACTER; 03220105
LABEL QUIT; DEFINE GIVEUP=GO TO QUIT#; 03220110
REAL NULL, DESC; 03220111
DEFINE RESULT=RESULTD#; 03220112
NULL := AREG; DESC := BREG; 03220115
IF L:=DESC.SPF=0 THEN BEGIN ERR:=DOMAINERROR; GIVEUP; END; 03220200
RANK := DESC.RF; 03220300
SIZE := FINDSIZE(DESC); 03220325
IF RANK LSS 2 THEN BEGIN NEWDESC:=DESC; 03220330
%THEN THE TRANSPOSE IS THE THING ITSELF 03220332
NEWDESC.NAMED:=0; 03220333
NEWDESC.SPF := N:=GETSPACE(RANK+SIZE); 03220335
SPCOPY(L,N,RANK+SIZE); 03220340
GO TO QUIT; END; 03220345
IF DESC.ARRAYTYPE=1 THEN BEGIN 03220350
L:=UNPACK(L,RANK,SIZE); 03220360
CHARACTER := TRUE; END; 03220370
N:=L+RANK-1; COL := SP[NOC]; 03220500
N:=N-1; ROW := SP[NOC]; 03220600
TOP := SIZE DIV (MAT:=ROW|COL); 03220650
NEWDESC := DESC; 03220660
NEWDESC.SPF := M := GETSPACE(SIZE+RANK); 03220700
SPCOPY (L,M,RANK-2); 03220800
N:=M+RANK-1; SP[NOC]:=ROW; 03220900
N:=N-1; SP[NOC] := COL; 03220950
J:=0; M:=M+RANK; 03221000
WHILE J LSS TOP DO BEGIN 03221010
OUTER:=(START:=L+RANK+J|MAT) + COL - 1; 03221020
FOR I:=START STEP 1 UNTIL OUTER DO BEGIN INNER:=I+MAT-1; 03221100
FOR N:=I STEP COL UNTIL INNER DO 03221200
BEGIN SP[MOC] := SP[NOC]; M:=M+1; END; END; 03221300
J:=J+1; END; 03221350
QUIT: IF CHARACTER THEN BEGIN NEWDESC.ARRAYTYPE:=1; 03221400
FORGETSPACE(L,SIZE+RANK); 03221405
PACK(NEWDESC.SPF, RANK,SIZE); END; 03221410
RESULTD := NEWDESC; 03221420
END PROCEDURE TRANSPOSE; 03221500
BOOLEAN PROCEDURE MATCHDIM(DESC1,DESC2); REAL DESC1,DESC2; 03224000
BEGIN INTEGER I,L,M,TOP; LABEL DONE; 03225000
MATCHDIM:= TRUE; 03225100
IF DESC1.RF NEQ DESC2.RF THEN BEGIN MATCHDIM:=FALSE; 03225200
ERR:=RANKERROR; GO TO DONE; END; 03225300
I:=DESC1.SPF; M:=DESC2.SPF; TOP:=I+DESC1.RF-1; 03225400
FOR L:=I STEP 1 UNTIL TOP DO BEGIN 03225500
IF SP[LOC] NEQ SP[MOC] THEN BEGIN MATCHDIM:=FALSE; 03225600
ERR:=LENGTHERROR; GO TO DONE; END; 03225700
M:=M+1; END; 03225800
DONE: END PROCEDURE MATCHDIM; 03225900
INTEGER PROCEDURE RANDINT(A,B,U); VALUE A,B; 03226000
REAL A,B,U; 03226100
BEGIN DEFINE QQMODUL = 67108864#, QQMULT = 8189#, 03226200
QQRANDOM=(U:=U|QQMULT MOD QQMODUL)/QQMODUL#; 03226300
RANDINT := (B-A+1)|QQRANDOM+A-.5; 03226400
END PROCEDURE RANDINT; 03226600
BOOLEAN PROCEDURE BOOLTYPE(A,B); REAL A,B; 03226700
BEGIN IF ABS(A-1) LEQ FUZZ THEN A:=1; 03226800
IF ABS(A) LEQ FUZZ THEN A:=0; 03226900
IF ABS(B-1) LEQ FUZZ THEN B:=1; 03227000
IF ABS(B) LEQ FUZZ THEN B:=0; 03227100
BOOLTYPE := (IF A=1 OR A=0 AND B=1 OR B=0 THEN TRUE 03227200
ELSE FALSE); END PROCEDURE BOOLTYPE; 03227300
REAL PROCEDURE GAMMA(X); REAL X; 03227305
COMMENT THIS PROCEDURE WAS TAKEN FROM ACM ALGORITHM 31. 03227310
THE ONLY DIFFERENCE IS THAT THERE IS NO PROVISION FOR 03227315
X LEQ 0 SINCE IT WILL NOT BE CALLED IN THAT CASE. IT 03227320
IS SUPPOSED TO GIVE ACCURACY TO 7 DIGITS; 03227321
BEGIN REAL H,Y; LABEL A1, A2; 03227325
H := 1; Y := X; 03227330
A1: IF Y = 2 THEN GO TO A2 ELSE IF Y LSS 2 THEN BEGIN 03227335
H:=H/Y; Y:=Y+1; GO TO A1 END 03227340
ELSE IF Y GEQ 3 THEN BEGIN 03227345
Y:=Y-1; H:=H|Y; GO TO A1 END 03227350
ELSE BEGIN Y := Y - 2; 03227355
H := (((((((.0016063118 | Y + .0051589951) | Y 03227360
+ .0044511400) | Y + .0721101567) | Y 03227365
+ .0821117404) | Y + .4117741955) | Y 03227367
+ .4227874605) | Y + .9999999758) | H END; 03227370
A2: GAMMA := H; 03227375
END OF PROCEDURE GAMMA; 03227380
BOOLEAN PROCEDURE EXCLAM(MARG,NARG,M,ANS); VALUE MARG,NARG,M; 03227800
REAL MARG,NARG,ANS; INTEGER M; 03227810
BEGIN INTEGER N,I; REAL DENOM; LABEL PUT; 03227900
EXCLAM := TRUE; 03228550
IF I:=NARG.[1:8] NEQ 0 OR DENOM:=MARG.[1:8] NEQ 0 THEN BEGIN 03228600
IF MARG LSS 0 OR NARG LSS 0 THEN BEGIN EXCLAM:=FALSE; 03228605
GO TO PUT; END; 03228607
IF M=0 THEN ANS:=GAMMA(NARG) ELSE BEGIN 03228610
IF (NARG-MARG) LEQ 0 THEN BEGIN EXCLAM:=FALSE; GO TO PUT END; 03228615
ANS := 1; 03228620
IF I=0 THEN FOR I:=2 STEP 1 UNTIL NARG DO ANS:=ANS|I 03228625
ELSE ANS:=GAMMA(NARG); 03228630
IF DENOM=0 THEN BEGIN DENOM:=1; FOR I:=2 STEP 1 UNTIL MARG DO 03228635
DENOM:=DENOM|I END ELSE DENOM:=GAMMA(MARG); 03228640
ANS := ANS / (DENOM | GAMMA(NARG-MARG)); 03228645
END; 03228650
GO TO PUT; END; 03228655
IF M=0 THEN BEGIN ANS := 1; 03228700
FOR I:=1 STEP 1 UNTIL NARG DO ANS:=ANS|I; 03228800
GO TO PUT; END 03228900
ELSE BEGIN IF MARG GTR NARG THEN 03229000
BEGIN ANS:=0; GO TO PUT; END; 03229100
IF MARG=0 THEN BEGIN ANS:=1; GO TO PUT; END; 03229200
ANS := NARG - MARG + 1; 03229400
FOR I:=NARG-MARG+2 STEP 1 UNTIL NARG DO ANS:=ANS|I; 03229500
DENOM := 1; 03229600
FOR I:=2 STEP 1 UNTIL MARG DO DENOM:=DENOM|I; 03229700
ANS := ANS / DENOM; END; 03229800
PUT: END PROCEDURE EXCLAM; 03229900
BOOLEAN PROCEDURE OPERATION(LEFT,RIGHT,LPTR,OP,ANS); 03230000
COMMENT: OP DEFINES THE APL OPERATORS AS FOLLOWS: 03230010
OP APL OPERATOR OP APL OPERATOR 03230015
0 + 10 FACT-COMB 03230020
1 TIMES 11 LSS 03230025
2 - 12 = 03230030
3 DIV 13 GEQ 03230035
4 * 14 GTR 03230040
5 RNDM 15 NEQ 03230045
6 RESD-ABS 16 LEQ 03230050
7 MIN-FLR 17 AND 03230055
8 MAX-CEIL 18 OR 03230060
9 NOT 19 NAND 03230061
20 NOR 03230062
21 LN-LOG 03230063
THE "CIRCLE" OPERATORS FOLLOW. 03230064
22 PI | 30 SQRT(1-B*2) 03230065
23 ARCTANH 31 SIN 03230066
24 ARCCOSH 32 COS 03230067
25 ARCSINH 33 TAN 03230068
26 SQRT(B*2-1) 34 SQRT(1+B*2) 03230069
27 ARCTAN 35 SINH 03230070
28 ARCCOS 36 COSH 03230071
29 ARCSIN 37 TANH; 03230072
03230073
COMMENT: LPTR IS LSS 0 IF THE CALL COMES FROM A 03230074
REDUCTION TYPE PROCEDURE. 03230075
LPTR = 0 IF OPERATOR IS MONADIC. 03230080
LPTR GTR 0 IF OPERATOR IS DYADIC. 03230085
LPTR LSS 0 IF COMES FROM REDUCTION TYPE OPERATION; 03230090
VALUE LEFT,RIGHT,LPTR,OP; 03230100
REAL LEFT,RIGHT,LPTR,OP; 03230200
REAL ANS; 03230210
BEGIN LABEL PUT,DOMAIN,KITE; DEFINE GIVEUP=GO TO PUT#; 03230300
DEFINE MAXEXP=158.037557167#, 03230302
MINEXP=-103.7216898#; 03230303
MONITOR INTOVR, ZERO, EXPOVR; 03230305
OPERATION := TRUE; 03230310
IF LPTR LSS 0 THEN IF OP GTR 10 AND OP LSS 21 THEN 03230320
IF NOT BOOLTYPE(LEFT,RIGHT) THEN GO TO DOMAIN; 03230330
IF OP = 45 THEN IF LPTR=0 THEN OP:=22 03230340
ELSE IF ABS(LEFT) GTR 7 THEN GO TO DOMAIN 03230345
ELSE OP := LEFT + 30; 03230350
IF OP GTR 16 AND OP LSS 21 THEN IF NOT BOOLTYPE(LEFT,RIGHT) 03230355
THEN GO TO DOMAIN; 03230357
ZERO:=DOMAIN; INTOVR:=KITE; EXPOVR:=KITE; 03230360
CASE OP OP BEGIN 03230400
ANS := LEFT + RIGHT; 03230500
ANS := IF LPTR=0 THEN SIGN(RIGHT) ELSE LEFT | RIGHT; 03230600
ANS := LEFT - RIGHT; 03230700
ANS := LEFT / RIGHT; 03230800
IF LPTR=0 THEN IF RIGHT GTR MINEXP AND RIGHT LSS MAXEXP 03230900
THEN ANS:=EXP(RIGHT) ELSE GO TO KITE 03230905
ELSE IF RIGHT.[3:6]=0 THEN ANS:=LEFT*ENTIER(RIGHT) 03230910
ELSE IF LEFT GTR 0 THEN IF ANS:=RIGHT|LN(LEFT) GTR MINEXP 03230920
AND ANS LSS MAXEXP THEN 03230923
ANS:=EXP(ANS) ELSE GO TO KITE 03230925
ELSE IF LEFT=0 AND RIGHT GTR 0 THEN ANS:=0 03230930
ELSE GO TO DOMAIN; 03230935
IF LPTR NEQ 0 THEN BEGIN ERR:=SYSTEMERROR; GIVEUP; END ELSE 03231000
IF RIGHT LSS ORIGIN THEN GO TO DOMAIN ELSE 03231010
ANS := RANDINT(ORIGIN,RIGHT,SEED); 03231100
IF LPTR=0 THEN ANS := ABS(RIGHT) ELSE 03231200
BEGIN IF LEFT=0 THEN IF RIGHT GEQ 0 THEN 03231300
ANS := RIGHT ELSE GO TO DOMAIN 03231400
ELSE IF (ANS:=RIGHT MOD LEFT) LSS 0 03231500
THEN ANS:=ANS + ABS(LEFT); END; 03231600
ANS := (IF LPTR=0 THEN ENTIER(RIGHT+FUZZ) 03231700
ELSE IF LEFT LEQ RIGHT THEN LEFT ELSE RIGHT); 03231800
ANS := (IF LPTR=0 THEN -ENTIER(-RIGHT+FUZZ) 03231900
ELSE IF LEFT GTR RIGHT THEN LEFT ELSE RIGHT); 03232000
IF LPTR NEQ 0 THEN BEGIN ERR:=SYNTAXERROR; GIVEUP; END 03232100
ELSE IF NOT BOOLTYPE(0,RIGHT) THEN 03232200
BEGIN ERR:=DOMAINERROR; GIVEUP; END 03232300
ELSE ANS := (IF RIGHT=1 THEN 0 ELSE 1); 03232400
IF NOT EXCLAM(LEFT,RIGHT,LPTR,ANS) THEN GO TO DOMAIN; 03232500
03232510
ANS := (IF RIGHT-LEFT GTR FUZZ|ABS(RIGHT) THEN 1 ELSE 0); 03232600
ANS:=(IF ABS(LEFT-RIGHT) LEQ FUZZ|ABS(RIGHT) THEN 1 ELSE 0); 03232700
ANS:=(IF RIGHT-LEFT LEQ FUZZ|ABS(RIGHT) THEN 1 ELSE 0); 03232800
ANS:=(IF LEFT-RIGHT GTR FUZZ|ABS(RIGHT) THEN 1 ELSE 0); 03232900
ANS:=(IF ABS(LEFT-RIGHT) GTR FUZZ|ABS(RIGHT) THEN 1 ELSE 0); 03233000
ANS:=(IF LEFT-RIGHT LEQ FUZZ|ABS(RIGHT) THEN 1 ELSE 0); 03233100
ANS := RIGHT | LEFT; %AND 03233200
ANS := IF RIGHT + LEFT = 0 THEN 0 ELSE 1; %OR 03233300
ANS := IF RIGHT | LEFT = 1 THEN 0 ELSE 1; %NAND 03233400
ANS := IF RIGHT + LEFT = 0 THEN 1 ELSE 0; %NOR 03233500
IF RIGHT LEQ 0 THEN GO TO DOMAIN ELSE IF LPTR=0 THEN 03233550
ANS:=LN(RIGHT) ELSE 03233560
IF LEFT LEQ 1 THEN GO TO DOMAIN ELSE 03233570
ANS := LN(RIGHT) / LN(LEFT); %LOGARITHMS 03233600
ANS := 3.1415926536 | RIGHT; 03233603
IF ABS(RIGHT) GEQ 1 THEN GO TO DOMAIN ELSE 03233606
ANS:= .5|LN((1+RIGHT)/(1-RIGHT)); %ARCTANH 03233609
03233610
IF RIGHT LSS 1 THEN GO TO DOMAIN ELSE 03233612
ANS:=LN(RIGHT+SQRT(RIGHT|RIGHT-1)); %ARCCOSH 03233615
ANS := LN(RIGHT + SQRT(RIGHT|RIGHT+1)); %ARCSINH 03233618
03233620
IF ABS(RIGHT) LSS 1 THEN GO TO DOMAIN ELSE 03233621
ANS:=SQRT(RIGHT|RIGHT-1); 03233624
ANS := ARCTAN(RIGHT); 03233627
IF ABS(RIGHT) GTR 1 THEN GO TO DOMAIN ELSE 03233630
IF RIGHT=0 THEN ANS:=1.5707963268 ELSE 03233631
ANS:=ARCTAN(SQRT(1-RIGHT*2)/RIGHT); %ARCCOS 03233633
IF ABS(RIGHT) GEQ 1 THEN GO TO DOMAIN ELSE 03233636
ANS:=ARCTAN(RIGHT/ SQRT(1-RIGHT*2)); %ARCSIN 03233639
IF ABS(RIGHT) GTR 1 THEN GO TO DOMAIN ELSE 03233642
ANS := SQRT(1-RIGHT*2); 03233645
ANS := SIN(RIGHT); 03233648
ANS := COS(RIGHT); 03233651
ANS := SIN(RIGHT) / COS(RIGHT); %TAN 03233654
ANS := SQRT(1+RIGHT|RIGHT); 03233657
ANS := (EXP(RIGHT) - EXP(-RIGHT))/2; %SINH 03233660
ANS := (EXP(RIGHT) + EXP(-RIGHT))/2; %COSH 03233663
ANS := ((OP:=EXP(RIGHT))-(ANS:=EXP(-RIGHT)))/(OP+ANS); %TANH 03233666
END; 03233669
GO TO PUT; 03233675
KITE: ERR:=KITEERROR; GO TO PUT; 03233678
DOMAIN: ERR:=DOMAINERROR; 03233680
PUT: IF ERR NEQ 0 THEN OPERATION := FALSE; 03233700
END PROCEDURE OPERATION; 03233705
PROCEDURE ARITH(OP); VALUE OP; 03233710
INTEGER OP; 03233715
COMMENT: ARITH HANDLES ALL APL OPERATORS THAT EMPLOY THE 03233720
VECTOR-VECTOR, SCALAR-VECTOR, SCALAR-SCALAR, VECTOR-SCALAR 03233725
FEATURE. DESC1 AND DESC2 ARE THE DESCRIPTORS FOR THE 03233730
LEFTHAND AND RIGHTHAND OPERANDS, RESPECTIVELY. IF 03233735
IF DESC1 = 0, THE OPERATOR IS TAKEN TO BE MONADIC. 03233740
IF DESC.SPF = 0, THE OPERAND IS NULL AND A DOMAIN ERROR 03233745
RESULTS EXCEPT IN THE CASE OF MULTIPLICATION. 03233750
OP IS AN INTERNAL OPERATION CODE FOR THE OPERATOR, WHICH 03233755
DEPENDS ON THE CASE STATEMENT IN THE OPERATION PROCEDURE.; 03233760
BEGIN INTEGER L,M,I,N,SIZE,RANK1,RANK2,TOP, 03233765
FORGETL, FORGETM; 03233770
REAL DESC,LEFT,RIGHT,ANS,SIZE1,SIZE2,DESC1,DESC2; 03233775
LABEL DONE, LEFTSCALE, SCALVECT, DOMAIN, VECTSCAL; 03233780
BOOLEAN CHAR1, CHAR2; 03233785
DESC1 := AREG; DESC2 := BREG; 03233790
L:=DESC1.SPF; M:=DESC2.SPF; 03233800
RANK1:=DESC1.RF; RANK2:=DESC2.RF; 03233850
SIZE1:=FINDSIZE(DESC1); SIZE2:=FINDSIZE(DESC2); 03233860
IF(CHAR1:=DESC1.ARRAYTYPE=1) OR (CHAR2:=DESC2.ARRAYTYPE=1) 03233900
THEN BEGIN IF OP LSS 11 OR OP GTR 16 03233902
OR NOT(CHAR1 AND CHAR2) AND NOT(OP=12 OR OP=15) 03233903
THEN BEGIN CHAR1:=CHAR2:=FALSE; GO TO DOMAIN; END; 03233904
IF CHAR1 THEN 03233906
FORGETL := L := UNPACK(L,RANK1,SIZE1); 03233908
IF CHAR2 THEN 03233910
FORGETM := M := UNPACK(M,RANK2,SIZE2); END; 03234000
03234100
03234110
IF M=0 THEN BEGIN IF OP NEQ 1 THEN GO TO DOMAIN 03234200
ELSE BEGIN DESC := NULLV; 03234230
GO TO DONE; END; END; 03234240
IF L=0 THEN BEGIN 03234400
IF DESC1.DID NEQ 0 THEN 03234410
IF OP=1 THEN BEGIN DESC:=NULLV; GO TO DONE; END 03234420
ELSE GO TO DOMAIN; 03234425
IF OP GTR 10 AND OP LSS 21 THEN GO TO DOMAIN; 03234430
LEFT := OP MOD 2; GO TO LEFTSCALE; END; 03234440
IF SIZE1=1 03234500
THEN BEGIN L:=L+RANK1; LEFT:=SP[LOC]; 03234510
GO TO LEFTSCALE; END; 03234600
IF SIZE2=1 THEN BEGIN 03234700
% DESC1 IS A VECTOR, DESC2 IS A SCALAR; 03234800
VECTSCAL: M:=M+RANK2; RIGHT:=SP[MOC]; 03234900
I := GETSPACE( SIZE:=SIZE1+RANK1); 03235000
DESC.SPF:=I; DESC.DID:=DDPUVW; SPCOPY(L,I,RANK1); 03235100
L:=L+RANK1; I:=I+RANK1; 03235200
DESC.RF:=RANK1; TOP:=SIZE1+I-1; 03235300
FOR N:=I STEP 1 UNTIL TOP DO BEGIN 03235400
IF OPERATION(SP[LOC],RIGHT,L,OP,ANS) THEN 03235500
SP[NOC] := ANS ELSE GO TO DONE; 03235510
L:=L+1; END; 03235600
GO TO DONE; END; 03235700
% BOTH DESC1 AND DESC2 ARE ARRAYS; 03235800
IF NOT MATCHDIM(DESC1,DESC2) THEN GO TO DONE 03235900
ELSE BEGIN 03236000
I := GETSPACE( SIZE := SIZE2 + RANK2 ); 03236100
SPCOPY(M,I,RANK2); DESC.SPF:=I; DESC.DID:=DDPUVW; 03236200
DESC.RF := RANK2; 03236300
M:=M+RANK2; I:=I+RANK2; L:=L+RANK2; 03236400
TOP := I+SIZE2-1; 03236500
FOR N:=I STEP 1 UNTIL TOP DO BEGIN 03236600
IF OPERATION(SP[LOC],SP[MOC],L,OP,ANS) THEN 03236700
SP[NOC] := ANS ELSE GO TO DONE; 03236710
L:=L+1; M:=M+1; END; 03236800
GO TO DONE; END; 03236900
LEFTSCALE: IF SIZE2 = 1 03237000
THEN BEGIN 03237050
IF RANK1 NEQ RANK2 THEN BEGIN 03237060
IF RANK1=0 THEN GO TO SCALVECT; 03237065
IF RANK2=0 THEN BEGIN L:=L-RANK1; GO TO VECTSCAL; END; 03237068
IF CHAR1 AND RANK1=1 THEN GO TO SCALVECT; 03237070
IF CHAR2 AND RANK2=1 THEN GO TO VECTSCAL; 03237075
ERR:=KITEERROR; GO TO DONE; END 03237080
ELSE IF RANK1|RANK2 NEQ 0 THEN GO TO SCALVECT; 03237090
% BOTH OPERANDS ARE SCALAR; 03237100
M := M + RANK2; 03237150
N := GETSPACE(SIZE:=1); RIGHT:=SP[MOC]; 03237200
DESC.SPF := N; DESC.DID := DDPUSW; 03237300
IF OPERATION(LEFT,RIGHT,L,OP,ANS) THEN 03237400
SP[NOC] := ANS ELSE GO TO DONE; 03237410
GO TO DONE; END 03237500
ELSE BEGIN %DESC1 IS SCALAR, DESC2 IS VECTOR; 03237600
03237700
SCALVECT: I := GETSPACE( SIZE := SIZE2 + RANK2); 03237800
DESC.SPF := I; DESC.RF := RANK2; DESC.DID:=DDPUVW; 03237900
SPCOPY(M,I,RANK2); 03238000
M:=M+RANK2; I:=I+RANK2; TOP:=SIZE2+I-1; 03238100
FOR N:=I STEP 1 UNTIL TOP DO BEGIN 03238200
IF OPERATION(LEFT,SP[MOC],L,OP,ANS) 03238290
THEN SP[NOC] := ANS ELSE GO TO DONE; 03238300
M := M+1; END; 03238400
END; 03238450
GO TO DONE; 03238500
DOMAIN: ERR := DOMAINERROR; 03238550
DONE: RESULTD := DESC; 03238560
IF CHAR1 THEN FORGETSPACE(FORGETL,SIZE1+RANK1); 03238570
IF CHAR2 THEN FORGETSPACE(FORGETM,SIZE2+RANK2); 03238580
IF ERR NEQ 0 THEN FORGETSPACE(DESC.SPF, SIZE); 03238590
END PROCEDURE ARITH; 03238600
PROCEDURE DYADICRNDM; 03238700
BEGIN INTEGER NUM, KIND; REAL DESC; 03238800
REAL DESC1, DESC2; 03238805
INTEGER L,M,N,T,I,TEMP,OUTTOP,TOP,PICK; LABEL QUIT; 03238810
INTEGER START; LABEL INSERT; 03238815
DESC1 := AREG; DESC2 := BREG; 03238820
IF FINDSIZE(DESC1) NEQ 1 OR FINDSIZE(DESC2) NEQ 1 03238850
THEN BEGIN ERR:=RANKERROR; GO TO QUIT; END; 03238900
IF DESC1.SPF=0 OR DESC2.SPF=0 THEN BEGIN 03238910
ERR:=DOMAINERROR; GO TO QUIT; END; 03238915
L:=DESC1.SPF+DESC1.RF; M:=DESC2.SPF+DESC2.RF; 03238950
NUM := SP[LOC]; KIND := SP[MOC]; 03239000
IF KIND LSS ORIGIN 03239050
OR NUM GTR PICK := KIND-ORIGIN+1 03239055
OR DESC1.ARRAYTYPE=1 03239060
OR DESC2.ARRAYTYPE=1 THEN BEGIN ERR:=DOMAINERROR; 03239070
GO TO QUIT; END; 03239100
DESC.DID := DDPUVW; DESC.RF := 1; 03239150
IF NUM LEQ 0 THEN BEGIN DESC := NULLV; GO TO QUIT; END; 03239200
IF NUM GTR MAXWORDSTORE THEN BEGIN ERR:=KITEERROR; GO TO QUIT END; 03239210
DESC.SPF := L := GETSPACE(NUM+1); 03239250
SP[LOC] := NUM; L := L+1; 03239300
OUTTOP := L+NUM-1; 03239350
TEMP := GETSPACE(NUM); 03239355
START:=ORIGIN; I:=0; 03239360
FOR L:=L STEP 1 UNTIL OUTTOP DO BEGIN 03239365
PICK:=RANDINT(START,KIND,SEED); 03239370
M:=TEMP; 03239375
IF I = 0 OR PICK LSS SP[MOC] THEN N:=TEMP 03239380
ELSE BEGIN TOP:=TEMP+I-1; 03239385
N:=TEMP+T:=I DIV 2; 03239390
WHILE T GTR 0 DO 03239395
IF PICK GEQ SP[NOC] THEN N:=N+T:=T DIV 2 03239400
ELSE N:=N-T:=T DIV 2; 03239405
03239410
FOR N:=MAX(TEMP,N-3) STEP 1 UNTIL TOP DO 03239415
IF SP[NOC] GTR PICK THEN 03239420
GO TO INSERT; 03239425
END; 03239430
INSERT: IF L LSS OUTTOP THEN BEGIN TOP:=N+1; N:=TEMP+I; 03239435
FOR M:=N STEP -1 UNTIL TOP DO BEGIN 03239440
N:=N-1; SP[MOC] := SP[NOC] - 1; END; 03239445
SP[NOC] := PICK; END; 03239450
SP[LOC] := N - TEMP + PICK; 03239455
KIND:=KIND-1; 03239460
I:=I+1; 03239465
END; 03239470
FORGETSPACE(TEMP,NUM); 03239475
QUIT: RESULTD := DESC; 03239500
END PROCEDURE DYADICRNDM; 03239550
PROCEDURE RHOP; 03239600
BEGIN INTEGER RANK,M,POINT; REAL NEWDESC,DESC1,DESC; 03239605
LABEL QUIT, WORK; BOOLEAN CHARACTER; 03239610
DEFINE TOOBIG=BEGIN ERR:=KITEERROR; GO TO QUIT; END#; 03239615
INTEGER N,TOP,NEWRANK,RANK1, POINT1,SIZE1,L,SIZE2; 03239620
DESC1 := AREG; DESC := BREG; 03239625
IF DESC.SPF = 0 THEN BEGIN ERR:=DOMAINERROR; GO TO QUIT; END; 03239630
IF DESC1.DID NEQ 0 THEN BEGIN %--DYADIC RHO--RESTRUCTURING--------- 03239632
IF L:=DESC1.SPF = 0 THEN BEGIN %NULL LEFT OP MEANS SCALAR ANS 03239635
IF DESC.ARRAYTYPE=1 THEN TOOBIG; %NO SCALAR CHARACTERS 03239638
NEWDESC.SPF:=M:=GETSPACE(1); 03239641
NEWDESC.DID:=DDPUSW; 03239644
L:=DESC.SPF+DESC.RF; 03239647
SP[MOC]:=SP[LOC]; GO TO QUIT; END; 03239650
IF DESC1.ARRAYTYPE NEQ 0 THEN BEGIN 03239653
ERR:=DOMAINERROR; GO TO QUIT; END; 03239656
RANK1:=DESC1.RF; 03239659
IF FINDSIZE(DESC1)=1 THEN BEGIN 03239662
N:=L+RANK1; 03239665
IF SIZE1:=ENTIER(SP[NOC]+.5) LSS 0 THEN BEGIN 03239668
ERR:=DOMAINERROR; GO TO QUIT; END; 03239671
NEWRANK:=1; TOP:=N; GO TO WORK; END; 03239674
IF RANK1 NEQ 1 THEN BEGIN ERR:=RANKERROR; GO TO QUIT; END; 03239677
IF NEWRANK:=SP[LOC] GTR 31 THEN TOOBIG; 03239725
SIZE1:=1; TOP := L+NEWRANK+RANK1-1; 03239726
IF NEWRANK LEQ 0 THEN BEGIN ERR:=SYSTEMERROR; GO TO QUIT; END; 03239727
FOR N:=L+RANK1 STEP 1 UNTIL TOP DO 03239728
IF SIZE1:=SIZE1|ENTIER(SP[NOC]+.5) LSS 0 THEN BEGIN 03239730
ERR:=DOMAINERROR; GO TO QUIT; END; 03239732
WORK: IF SIZE1=0 THEN BEGIN NEWDESC := NULLV; GO TO QUIT END; 03239734
IF SIZE1 GTR MAXWORDSTORE THEN TOOBIG; 03239736
NEWDESC.DID:=DDPUVW; NEWDESC.RF:=NEWRANK; 03239737
NEWDESC.SPF := M := GETSPACE(SIZE1+NEWRANK); 03239738
%CANT USE SPCOPY FOR DIM VECTOR AS LEFT OP MAY NOT BE INTEGER 03239739
FOR L:=L+RANK1 STEP 1 UNTIL TOP DO 03239740
BEGIN SP[MOC]:=ENTIER(SP[LOC]+.5); M:=M+1; END; 03239742
SIZE2:=FINDSIZE(DESC); L:=DESC.SPF; RANK:=DESC.RF; 03239743
IF DESC.ARRAYTYPE=1 THEN BEGIN L:=UNPACK(L,RANK,SIZE2); 03239744
CHARACTER:=TRUE; END; TOP:=SIZE1 DIV SIZE2; POINT:=L+RANK; 03239745
FOR N:=1 STEP 1 UNTIL TOP DO BEGIN SPCOPY(POINT,M,SIZE2); 03239746
M := M+SIZE2; END; 03239748
TOP := SIZE1 MOD SIZE2; SPCOPY(POINT,M,TOP); 03239750
GO TO QUIT; END ELSE 03239752
%--------MONADIC RHO-----DIMENSION VECTOR---------------------- 03239760
RANK := DESC.RF; POINT := DESC.SPF; 03239800
NEWDESC.DID := DDPUVW; NEWDESC.RF := 1; 03239850
IF DESC.DATATYPE = 1 THEN BEGIN 03239900
NEWDESC := NULLV; GO TO QUIT END; 03239950
NEWDESC.SPF := M := GETSPACE(RANK+1); 03240000
SP[MOC] := RANK; 03240050
SPCOPY(POINT,M+1, RANK); 03240100
QUIT: IF CHARACTER THEN BEGIN NEWDESC.ARRAYTYPE:=1; 03240150
FORGETSPACE(L,SIZE2+RANK); 03240152
PACK(NEWDESC.SPF, NEWRANK,SIZE1); END; 03240155
RESULTD := NEWDESC; 03240160
END PROCEDURE RHOP; 03240200
PROCEDURE IOTAP; 03240750
BEGIN INTEGER I,L,M,TOP; REAL DESC; 03240800
REAL LEFTOP, RIGHTOP; 03240802
INTEGER RSIZE,LSIZE,RRANK,LRANK,N,LL,MM,TIP,NIX; 03240805
03240807
LABEL QUIT, DONE; 03240810
LEFTOP:=AREG; RIGHTOP:=BREG; 03240812
IF L:=RIGHTOP.SPF=0 THEN BEGIN ERR:=DOMAINERROR; GO TO QUIT END; 03240813
RSIZE:=FINDSIZE(RIGHTOP); RRANK:=RIGHTOP.RF; 03240815
DESC.DID := DDPUVW; DESC.RF := 1; 03240817
IF LEFTOP.DID NEQ 0 THEN BEGIN %-------DYADIC IOTA------------ 03240820
IF LRANK := LEFTOP.RF GTR 1 THEN BEGIN ERR:=RANKERROR; 03240825
GO TO QUIT; END; 03240830
LSIZE := FINDSIZE(LEFTOP); 03240835
IF M:=LEFTOP.SPF=0 THEN BEGIN %RESULT IS ORIGIN IF IT WAS NULL 03240840
DESC.SPF:=M:=GETSPACE(1); DESC.RF:=0; DESC.SCALAR:=1; 03240842
SP[MOC] := ORIGIN; GO TO QUIT; END; 03240845
IF LEFTOP.ARRAYTYPE=1 THEN M:=UNPACK(M,LRANK,LSIZE); 03240850
IF RIGHTOP.ARRAYTYPE=1 THEN L:=UNPACK(L,RRANK,RSIZE); 03240855
TIP := (NIX:=LSIZE+ORIGIN) - 1; 03240875
DESC.SPF:=N:=GETSPACE(RSIZE+RRANK); 03240880
IF RRANK=0 THEN DESC.SCALAR:=1 ; DESC.RF:=RRANK; 03240890
SPCOPY(L,N,RRANK); 03240895
MM := M+LRANK; LL:=L:=L+RRANK; 03240900
TOP:=N+RRANK+RSIZE-1; 03240905
FOR N:=N+RRANK STEP 1 UNTIL TOP DO BEGIN 03240910
SP[NOC] := NIX; 03240915
M := MM; 03240920
FOR I:=ORIGIN STEP 1 UNTIL TIP DO 03240925
IF OPERATION(SP[MOC],SP[LOC],1,12,LEFTOP) AND LEFTOP=1 03240930
THEN BEGIN SP[NOC]:=I; GO TO DONE; 03240935
END ELSE M:=M+1; 03240940
DONE: L:=L+1; END; 03240945
IF LEFTOP.ARRAYTYPE=1 THEN FORGETSPACE(MM-LRANK,LRANK+LSIZE); 03240950
IF RIGHTOP.ARRAYTYPE=1 THEN FORGETSPACE(LL-RRANK,RRANK+RSIZE); 03240955
END ELSE BEGIN %-------------MONADIC IOTA------------------- 03240960
IF RIGHTOP.ARRAYTYPE=1 THEN 03241000
BEGIN ERR:=DOMAINERROR; GO TO QUIT 03241002
END; 03241004
IF RSIZE NEQ 1 THEN BEGIN ERR:=RANKERROR; GO TO QUIT END; 03241025
03241030
L := L + RRANK; 03241040
IF TOP:=SP[LOC] GTR MAXWORDSTORE THEN 03241050
BEGIN ERR:=KITEERROR; GO TO QUIT 03241054
END; 03241056
03241075
IF TOP LSS ORIGIN THEN BEGIN DESC:=NULLV; GO TO QUIT END; 03241080
DESC.SPF := M := GETSPACE(TOP+1); 03241100
SP[MOC] := TOP; M := M+1; 03241125
TOP := TOP + ORIGIN - 1; 03241130
FOR I := ORIGIN STEP 1 UNTIL TOP DO BEGIN 03241150
SP[MOC] := I; M := M+1; END; 03241175
END; 03241180
QUIT: RESULTD := DESC; 03241200
END PROCEDURE IOTAP; 03241225
PROCEDURE COMMAP; 03241300
BEGIN REAL LDESC, RDESC; 03241400
INTEGER L,M,N,LRANK,RRANK,LSIZE,RSIZE,SIZE; 03241500
REAL DESC; LABEL QUIT; BOOLEAN CHARACTER; 03241600
LDESC := AREG; RDESC := BREG; 03241650
RRANK := RDESC.RF; LRANK := LDESC.RF; 03241700
LSIZE := IF (L := LDESC.SPF) = 0 THEN 0 ELSE FINDSIZE(LDESC); 03241800
RSIZE := IF (M := RDESC.SPF) = 0 THEN 0 ELSE FINDSIZE(RDESC); 03241900
IF RDESC.ARRAYTYPE = 1 THEN BEGIN 03242000
M := UNPACK(M,RRANK,RSIZE); 03242100
CHARACTER := TRUE; END; 03242200
DESC.DID := DDPUVW; DESC.RF := 1; 03242250
IF LDESC.DID = 0 THEN BEGIN %-----MONADIC COMMA--RAVEL-------- 03242300
IF RSIZE=0 THEN BEGIN DESC:=NULLV; GO TO QUIT END; 03242400
DESC.SPF := L := GETSPACE(RSIZE+1); 03242500
SP[LOC] := RSIZE; 03242700
SPCOPY(M+RRANK, L+1, RSIZE); 03242800
N := L; SIZE := RSIZE; 03242850
GO TO QUIT; END 03242900
ELSE BEGIN 03243000
%HERE IS THE CODE FOR DYADIC COMMA, I.E. CATENATION 03243100
IF RRANK NEQ 1 AND RSIZE GTR 1 OR 03243200
LRANK NEQ 1 AND LSIZE GTR 1 THEN BEGIN 03243250
ERR:= RANKERROR; GO TO QUIT; END; 03243300
IF SIZE:=LSIZE+RSIZE GTR MAXWORDSTORE THEN BEGIN 03243400
ERR:=KITEERROR; GO TO QUIT; END; 03243500
COMMENT CANT MIX NUMBERS AND CHARACTERS. HAVE TO JUGGLE 03243540
IF LEFT IS NUMBERS AND RIGHT IS CHARACTERS AS RIGHT 03243541
HAS ALREADY BEEN UNPACKED AND WE DONT WANT TO FORGET 03243542
LEFT AND WE DONT WANT TO PACK THE NON-RESULT; 03243543
IF CHARACTER THEN 03243550
IF LDESC.ARRAYTYPE=1 OR LSIZE=0 THEN L:=UNPACK(L,LRANK,LSIZE) 03243600
ELSE BEGIN SIZE:=0; LSIZE:=-LRANK; ERR:=DOMAINERROR; 03243700
GO TO QUIT END 03243705
ELSE IF LDESC.ARRAYTYPE=1 THEN 03243710
IF RSIZE NEQ 0 THEN 03243715
BEGIN ERR:=DOMAINERROR; GO TO QUIT END 03243720
ELSE BEGIN CHARACTER:=TRUE; 03243725
L:=UNPACK(L,LRANK,LSIZE); END; 03243730
IF SIZE=0 THEN BEGIN DESC:=NULLV; GO TO QUIT END; 03243800
DESC.SPF := N := GETSPACE(SIZE+1); 03243900
SP[NOC] := SIZE; 03244000
SPCOPY(L+LRANK, N+1, LSIZE); 03244100
SPCOPY(M+RRANK, N+LSIZE+1, RSIZE); 03244200
END; 03244300
QUIT: 03244400
IF CHARACTER THEN BEGIN DESC.ARRAYTYPE := 1; 03244500
PACK(N,1,SIZE); 03244600
FORGETSPACE(L,LSIZE+LRANK); 03244700
FORGETSPACE(M,RSIZE+RRANK); 03244800
END; 03244900
RESULTD := DESC; 03245000
END PROCEDURE COMMAP; 03245100
INTEGER STREAM PROCEDURE GETOP(A,N); VALUE N; 03245120
BEGIN SI := A; SI := SI + N; 03245130
DI := LOC GETOP; 03245140
DS := 7 LIT "0"; DS := CHR; 03245150
END PROCEDURE GETOP; 03245160
REAL PROCEDURE IDENTITY(OP); VALUE OP; INTEGER OP; 03246200
BEGIN 03246300
CASE OP OF BEGIN 03246350
IDENTITY := 0; %FOR + 03246400
IDENTITY := 1; %FOR | 03246500
IDENTITY := 0; %FOR - 03246600
IDENTITY := 1; %FOR DIV 03246700
IDENTITY := 1; %FOR * 03246800
; %NO REDUCTION ON RNDM 03246900
IDENTITY := 0; %FOR RESD 03247000
IDENTITY := BIGGEST; %FOR MIN 03247100
IDENTITY := -BIGGEST; %FOR MAX 03247200
; %NOT ISNT DYADIC 03247300
IDENTITY := 1; %FOR COMB 03247400
IDENTITY := 0; %FOR LSS 03247500
IDENTITY := 1; %FOR = 03247505
IDENTITY := 1; %FOR GEQ 03247510
IDENTITY := 0; %FOR GTR 03247515
IDENTITY := 0; %FOR NEQ 03247520
IDENTITY := 1; %FOR LEQ 03247525
IDENTITY := 1; %FOR AND 03247600
IDENTITY := 0; %FOR OR 03247700
END; END PROCEDURE IDENTITY; 03247800
INTEGER PROCEDURE GETT(ALONG,RANK); VALUE ALONG, RANK; 03247810
INTEGER ALONG, RANK; 03247820
GETT := IF ALONG=1 THEN 0 ELSE 03247822
IF ALONG=RANK THEN 2 ELSE 03247825
IF ALONG=RANK-1 THEN 1 ELSE 0; 03247830
BOOLEAN PROCEDURE CHECKANDADD(SIZE,L,SUM); 03253305
VALUE SIZE,L; INTEGER SIZE,L,SUM; 03253310
BEGIN LABEL QUIT; INTEGER I,TOP,M,S,T; 03253315
CHECKANDADD:=TRUE; 03253320
SUM := 0; 03253325
TOP := SIZE DIV 2 | 2 - 1 + L; 03253330
FOR L:=L STEP 2 UNTIL TOP DO BEGIN M:=L+1; 03253335
IF NOT BOOLTYPE(S:=SP[LOC], T:=SP[MOC]) THEN BEGIN 03253340
CHECKANDADD:=FALSE; GO TO QUIT; END 03253345
ELSE SUM := SUM+S+T; END; 03253350
IF SIZE MOD 2 = 1 THEN BEGIN 03253355
IF NOT BOOLTYPE(T:=SP[LOC],0) THEN 03253360
CHECKANDADD := FALSE ELSE SUM := SUM+T; 03253365
END; 03253367
QUIT: END PROCEDURE CHECKANDADD; 03253370
PROCEDURE COMPRESS(LDESC, RDESC, DIM); VALUE LDESC,RDESC,DIM; 03253400
REAL LDESC, RDESC, DIM; 03253500
BEGIN INTEGER I,J,K,L,M,N,T,RANK,LSIZE,RSIZE,ALONG,TOP, 03253600
FACTOR,SUM,DIMMOD,SIZE,LEFT,RIGHT,S; 03253700
REAL DESC; BOOLEAN CHARACTER; 03253800
LABEL QUIT,RANKE,DOMAIN,IDENT; 03253900
DESC.DID := DDPUVW; 03254000
IF L := LDESC.SPF = 0 THEN GO TO DOMAIN; 03254100
IF M:=RDESC.SPF=0 THEN BEGIN DESC:=NULLV; GO TO QUIT; END; 03254200
LSIZE := FINDSIZE(LDESC); RSIZE := FINDSIZE(RDESC); 03254300
IF RANK:=LDESC.RF NEQ 1 THEN IF LSIZE NEQ 1 03254350
THEN GO TO DOMAIN; 03254360
LEFT := L := L+RANK; 03254370
RANK := RDESC.RF; 03254400
IF N:=DIM.SPF=0 AND DIM.DID NEQ 0 OR DIM.ARRAYTYPE=1 03254500
OR LDESC.ARRAYTYPE=1 THEN GO TO DOMAIN; 03254510
IF J:=DIM.RF NEQ 0 THEN BEGIN 03254600
IF FINDSIZE(DIM)=1 THEN N:=N+J ELSE GO TO DOMAIN END; 03254700
IF ALONG:=(IF N=J THEN RANK ELSE SP[NOC]-ORIGIN+1) GTR RANK 03254800
OR ALONG LSS 1 AND RANK NEQ 0 03254810
THEN BEGIN ERR:=INDEXERROR; GO TO QUIT; END; 03254900
IF RANK = 0 THEN 03255200
IF LSIZE NEQ 1 THEN GO TO DOMAIN ELSE BEGIN 03255300
IF TOP:=SP[LOC]=0 THEN BEGIN DESC:=NULLV; GO TO QUIT; END; 03255400
IF TOP = 1 THEN BEGIN DESC.SPF := N := GETSPACE(2); 03255500
DESC.RF := SP[NOC] := 1; 03255600
N:=N+1; SP[NOC]:=SP[MOC]; GO TO QUIT; 03255700
END ELSE GO TO DOMAIN; END; 03255800
IF LSIZE = 1 THEN BEGIN 03255805
COMMENT IF LEFT ARG IS SCALAR, ANSWER IS NULL IF 0, 03255810
RIGHT ARG IF 1; 03255815
SUM:=SP[LOC]; 03255820
IF SUM NEQ 0 AND SUM NEQ 1 THEN GO TO DOMAIN 03255825
03255830
ELSE GO TO IDENT; END; 03255835
N := M+ALONG - 1; 03255850
IF LSIZE NEQ (T:=SP[NOC]) THEN BEGIN 03255855
ERR:=LENGTHERROR; GO TO QUIT; END; 03255860
IF NOT CHECKANDADD(LSIZE,LEFT,SUM) THEN GO TO DOMAIN; 03255900
IDENT: IF SUM=0 THEN BEGIN DESC:=NULLV; GO TO QUIT END; 03256800
IF SUM = LSIZE THEN BEGIN 03256900
IF RDESC.ARRAYTYPE=1 THEN BEGIN 03256910
RSIZE:=RSIZE DIV 8 + (IF RSIZE MOD 8 NEQ 0 THEN 1 ELSE 0); 03256920
DESC.CHRMODE:=1; END; 03256930
DESC.SPF:=N:=GETSPACE(TOP:=RSIZE+RANK); 03257000
DESC.RF := RANK; SPCOPY(M,N,TOP); GO TO QUIT; END; 03257100
SIZE := RSIZE DIV T | SUM; 03257120
DESC.RF:=RANK; 03257130
IF RDESC.ARRAYTYPE = 1 THEN BEGIN M:=UNPACK(M,RANK,RSIZE); 03257132
CHARACTER := TRUE; END; 03257133
RIGHT := M; 03257134
DESC.SPF := S := GETSPACE(SIZE+RANK); 03257135
N := S; 03257140
FOR I:=1 STEP 1 UNTIL RANK DO BEGIN 03257150
IF I=ALONG THEN SP[NOC]:=SUM ELSE SP[NOC]:=SP[MOC]; 03257160
N:=N+1; M:=M+1; END; 03257170
T := GETT(ALONG, RANK); 03257200
FACTOR := 1; TOP := RIGHT+ALONG; 03257300
FOR N:=RIGHT+RANK-1 STEP -1 UNTIL TOP DO FACTOR:= 03257400
FACTOR | SP[NOC]; 03257410
N:=RIGHT + RANK - 1; DIM := SP[NOC]; 03257500
N := N+1; M:=S+RANK; I:=0; 03257600
DIMMOD := DIM-1; 03257650
WHILE I LSS RSIZE DO BEGIN 03257700
CASE T OF BEGIN 03257800
L := I DIV FACTOR MOD LSIZE; 03257900
L := I DIV FACTOR MOD DIMMOD; 03258000
L := I MOD DIM; END; 03258100
L := L+LEFT; 03258150
IF SP[LOC] = 1 THEN FOR K:=1 STEP 1 UNTIL FACTOR DO BEGIN 03258200
SP[MOC]:=SP[NOC]; I:=I+1; M:=M+1; N:=N+1; 03258300
END ELSE BEGIN I:=I+FACTOR; N:=N+FACTOR; END; 03258400
END; 03258500
GO TO QUIT; 03259300
RANKE: ERR:=RANKERROR; GO TO QUIT; 03259500
DOMAIN: ERR:=DOMAINERROR; GO TO QUIT; 03259600
QUIT: IF CHARACTER THEN BEGIN PACK(S,RANK,SIZE); 03259900
DESC.ARRAYTYPE:=1; FORGETSPACE(RIGHT,RSIZE+RANK); END; 03260000
RESULTD := DESC; 03260100
POP; 03260150
END PROCEDURE COMPRESS; 03260200
PROCEDURE EXPAND(LDESC,RDESC,DIM); VALUE LDESC,RDESC,DIM; 03268020
REAL LDESC, RDESC, DIM; 03268040
BEGIN INTEGER I,J,K,L,M,N,S,T,RANK,LSIZE,RSIZE,SIZE, 03268060
ALONG,TOP,LADDR,MADDR,FACTOR, SUM; 03268080
REAL DESC, INSERT; 03268100
LABEL QUIT, DOMAIN; 03268120
BOOLEAN CHARACTER; 03268140
LSIZE:=FINDSIZE(LDESC); RSIZE:=FINDSIZE(RDESC); 03268160
RANK := RDESC.RF; 03268180
IF M:=RDESC.SPF=0 03268200
OR L:=LDESC.SPF=0 03268220
OR I:=LDESC.RF GTR 1 03268224
03268226
OR N:=DIM.SPF=0 AND DIM.DID NEQ 0 03268240
OR DIM.ARRAYTYPE=1 03268250
OR FINDSIZE(DIM ) NEQ 1 03268260
OR LDESC.ARRAYTYPE=1 03268270
THEN GO TO DOMAIN; 03268280
N:=N + (T:=DIM.RF); 03268300
IF ALONG :=(IF N=T THEN RANK ELSE SP[NOC]-ORIGIN+1) GTR RANK 03268320
OR ALONG LSS 1 AND RANK NEQ 0 03268330
THEN BEGIN ERR:=INDEXERROR; GO TO QUIT; END; 03268340
IF RANK=0 THEN DIM:=1 03268350
ELSE BEGIN N:=M+ALONG-1; DIM:=SP[NOC]; END; 03268360
IF SIZE:=RSIZE DIV DIM | LSIZE GTR MAXWORDSTORE 03268380
THEN BEGIN ERR:=KITEERROR; GO TO QUIT; END; 03268400
IF NOT CHECKANDADD(LSIZE,LADDR:=L+I, SUM) THEN GO TO DOMAIN; 03268420
IF SUM NEQ DIM THEN BEGIN ERR:=RANKERROR; GO TO QUIT; END; 03268440
IF RANK=0 THEN BEGIN 03268443
DIM:=SP[MOC]; DESC.SPF:=N:=GETSPACE(LSIZE+I); 03268445
DESC.RF:=I; DESC.DID:=(IF I=0 THEN DDPUSW ELSE DDPUVW); 03268447
SPCOPY(L,N,I); L:=L+I; N:=N+I; TOP:=L+LSIZE-1; 03268449
FOR L:=L STEP 1 UNTIL TOP DO BEGIN 03268451
IF SP[LOC]=1 THEN SP[NOC]:=DIM; 03268453
N:=N+1; END; 03268456
GO TO QUIT END; 03268458
IF RDESC.ARRAYTYPE=1 THEN BEGIN CHARACTER:=TRUE; 03268460
M:=UNPACK(M,RANK,RSIZE); 03268480
INSERT := " "; END; 03268500
FACTOR:=1; TOP:=M+ALONG; 03268520
FOR N:=M+RANK-1 STEP -1 UNTIL TOP DO FACTOR:=FACTOR|SP[NOC]; 03268540
T := GETT(ALONG, RANK); 03268580
J:=0; N:=(MADDR:=M) + RANK; 03268600
DESC.SPF:=M:=GETSPACE(SIZE+RANK); 03268620
I:=M+RANK; 03268640
WHILE J LSS SIZE DO BEGIN 03268660
CASE T OF BEGIN 03268680
S := J DIV FACTOR MOD LSIZE; 03268700
S:=J DIV FACTOR MOD LSIZE; 03268720
S:=J MOD LSIZE; END; 03268740
L:=S + LADDR; 03268760
IF SP[LOC]=1 THEN FOR K:=1 STEP 1 UNTIL FACTOR DO 03268780
BEGIN L:=J+I; SP[LOC] := SP[NOC]; 03268800
J:=J+1; N:=N+1; 03268820
END ELSE FOR K:=1 STEP 1 UNTIL FACTOR DO BEGIN 03268840
L:=J+I; SP[LOC]:=INSERT; J:=J+1; END; 03268860
END; 03268880
L := MADDR; 03268900
FOR I:=1 STEP 1 UNTIL RANK DO BEGIN 03268903
IF I = ALONG THEN SP[MOC]:=LSIZE ELSE SP[MOC]:=SP[LOC]; 03268906
M:=M+1; L:=L+1; END; 03268910
DESC.DID:=DDPUVW; DESC.RF:=RANK; 03268920
GO TO QUIT; 03268940
DOMAIN: ERR:=DOMAINERROR; 03268960
QUIT: IF CHARACTER THEN BEGIN DESC.ARRAYTYPE:=1; 03268980
FORGETSPACE(MADDR, RSIZE+RANK); 03269000
PACK(DESC.SPF,RANK,SIZE); END; 03269020
RESULTD:=DESC; 03269040
POP; 03269060
END PROCEDURE EXPAND; 03269080
PROCEDURE MEMBER; 03269100
BEGIN REAL LDESC, RDESC; 03269120
INTEGER L,M,N,I,S,T,LSIZE,RSIZE,LRANK,RRANK,TOP; 03269140
REAL DESC, TEMP, ANS; 03269160
LABEL QUIT; 03269180
LDESC := AREG; RDESC := BREG; 03269190
LSIZE:=FINDSIZE(LDESC); RSIZE:=FINDSIZE(RDESC); 03269200
LRANK:=LDESC.RF; RRANK:=RDESC.RF; 03269220
IF L:=LDESC.SPF=0 OR M:=RDESC.SPF=0 THEN BEGIN 03269240
ERR:=DOMAINERROR; GO TO QUIT END; 03269250
IF LDESC.ARRAYTYPE=1 THEN L:=UNPACK(L,LRANK,LSIZE); 03269260
IF RDESC.ARRAYTYPE=1 THEN M:=UNPACK(M,RRANK,RSIZE); 03269280
DESC:=LDESC; DESC.NAMED:=0; 03269360
DESC.ARRAYTYPE:=0; 03269370
DESC.SPF:=N:=GETSPACE(LSIZE+LRANK); 03269380
SPCOPY(L,N,LRANK); 03269400
N:=N+LRANK; L:=(I:=L)+LRANK; M:=(S:=M)+RRANK; 03269420
T:=M+RSIZE-1; TOP := L+LSIZE-1; 03269440
FOR L:=L STEP 1 UNTIL TOP DO BEGIN 03269460
TEMP:=SP[LOC]; M:=S; 03269480
WHILE M LEQ T DO 03269500
IF OPERATION(TEMP,SP[MOC],0,12,ANS) AND ANS=1 THEN BEGIN 03269520
SP[NOC]:=1; M:=M+T; END ELSE M:=M+1; 03269540
N:=N+1; END; 03269560
03269580
IF RDESC.ARRAYTYPE=1 THEN FORGETSPACE(S,RSIZE+RRANK); 03269600
IF LDESC.ARRAYTYPE=1 THEN FORGETSPACE(I,LSIZE+LRANK); 03269620
QUIT: RESULTD:=DESC; 03269640
END PROCEDURE MEMBER; 03269660
REAL PROCEDURE BASEVALUE; 03269800
BEGIN 03269860
COMMENT THIS RETURNS A DESCRIPTOR FOR A SCALAR RESULT; 03269870
LABEL OUTE,BAD; 03269880
REAL E,L,M,LEFT,RIGHT,T,LARG,RARG; 03269900
LARG := AREG; RARG := BREG; 03269910
IF M:=RARG.SPF=0 OR LARG.CHRMODE=1 OR RARG.CHRMODE=1 03269920
OR L:=LARG.SPF=0 AND LARG.DID NEQ 0 03269930
THEN GO TO BAD; 03269940
RIGHT:=SP[MOC]; 03269960
LEFT:=SP[LOC]; 03269980
IF FINDSIZE(LARG)=1 THEN % A 1 ELEMENT VECTOR 03269982
BEGIN 03269984
L:=L+LARG.RF; 03269986
LARG.SCALAR:=1; 03269987
LEFT:=SP[LOC]; 03269988
END; 03269990
IF FINDSIZE(RARG)=1 THEN % A ONE ELEMENT VECTOR 03269992
BEGIN 03269994
M:=M+RARG.RF; 03269996
RIGHT:=SP[MOC]; 03269998
RARG.SCALAR:=1; 03269999
END; 03270000
IF L=0 THEN 03270002
BEGIN % BASEVAL MONADIC 03270004
LEFT:=2; %IF MONADIC, ITS 2 BASVAL X 03270006
LARG.SCALAR:=1; 03270008
END; 03270010
IF BOOLEAN(LARG.SCALAR )THEN %SCALAR 03270018
IF BOOLEAN(RARG.SCALAR) THEN 03270020
BEGIN 03270025
T:=RIGHT; %SCALAR-SCALAR 03270030
GO OUTE; 03270035
END 03270037
ELSE 03270040
IF RARG.RF=1 THEN 03270060
BEGIN COMMENT SCALAR-VECTOR--LEFT IS VALUE OF SCALAR, RIGHT 03270080
IS # OF ELEMENTS; 03270100
IF LEFT=0 THEN GO OUTE 03270120
ELSE E:=1/LEFT; 03270140
FOR L :=M+RIGHT STEP -1 UNTIL M+1 DO 03270160
T:=T+SP[LOC]|(E:=E|LEFT); 03270180
GO OUTE; 03270200
END 03270300
ELSE BAD: ERR:=DOMAINERROR 03270320
ELSE 03270340
IF RARG.SCALAR=0 THEN 03270380
IF LARG.RF NEQ 1 OR RARG.RF NEQ 1 THEN 03270400
ERR:=DOMAINERROR 03270420
ELSE 03270440
BEGIN 03270460
GT2:=L; % SAVE FOR LATER TEST 03270480
GT1:=M+2; % WANT TO STOP 2 UP IN LOOP 03270500
L:=L+LEFT; % START AT OTHER END 03270520
E:=1; 03270540
M:=M+RIGHT; 03270560
T:=SP[MOC]; % INITIAL VALUE 03270580
FOR M:=M-1 STEP -1 UNTIL GT1 DO 03270600
BEGIN 03270620
IF L:=L-1 LSS GT2 THEN L:=GT2+LEFT; % START OVER 03270640
E:=E|SP[LOC]; 03270660
T:=T+SP[MOC]|E; 03270680
END; 03270700
OUTE: 03270702
L:=GETSPACE(1); 03270704
SP[LOC]:=T; 03270708
T:=0; 03270710
T.DID:=DDPUSW; % BUILD DESCRIPTOR 03270712
T.SPF:=L; 03270716
BASEVALUE:=T; 03270720
END 03270740
ELSE ERR := DOMAINERROR 03270760
END OF BASEVALUE; 03270800
REAL PROCEDURE REPRESENT; 03270820
BEGIN 03270880
COMMENT RETURNS DESCRIPTOR OF VECTOR IF LARG VECTOR AND RARG SCALAR;03270900
REAL L,M,LEFT,RIGHT,T,E,LARG,RARG; 03270920
LABEL AROUND; 03270925
LARG := AREG; RARG := BREG; 03270930
IF (RARG.SCALAR=1 OR FINDSIZE(RARG)=1 AND RARG.CHRMODE=0) 03270940
AND NOT(LARG.SCALAR=1 OR LARG.CHRMODE=1 OR LARG.RF NEQ 1) THEN 03270950
BEGIN 03270960
COMMENT VECTOR-SCALAR; 03270980
IF L:=LARG.SPF=0 OR M:=RARG.SPF=0 THEN GO AROUND; 03271000
IF RARG.SCALAR=0 THEN M:=M+RARG.RF; 03271020
RIGHT:=SP[MOC]; % VALUE OF SCALAR 03271040
LEFT:=SP[LOC]; % LENGTH OF VECTOR 03271060
E:=M:=GETSPACE(LEFT+1); % MAKE ROOM FOR ANSWER 03271080
SP[MOC]:=LEFT; % LENGTH OF ANSWER 03271100
M:=M+LEFT; 03271120
GT1:=L+2; 03271140
FOR L:=L+LEFT STEP -1 UNTIL GT1 DO 03271160
IF T:=SP[LOC] LEQ 0 THEN 03271180
IF T LSS 0 THEN ERR := DOMAINERROR 03271200
ELSE 03271220
BEGIN 03271240
L:=GT1-1 ; % STOP THE LOOP 03271260
M:=M-1; 03271280
END 03271300
ELSE 03271320
BEGIN 03271340
SP[MOC]:= RIGHT MOD T; 03271360
RIGHT:=RIGHT DIV T; 03271380
M:=M-1; 03271400
IF RIGHT LSS FUZZ THEN L:=GT1-1; % STOP THE LOOP 03271420
END; 03271440
SP[MOC]:=RIGHT; % LEFTOVER GOES HERE 03271460
T.DID:=DDPUVW; 03271480
T.RF:=1; 03271500
T.SPF:=E; 03271520
REPRESENT:=T; 03271540
END 03271560
ELSE AROUND: ERR:=DOMAINERROR; 03271580
END OF REPRESENT; 03271600
PROCEDURE PERIOD(LDESC,RDESC,LOP,ROP); 03271800
VALUE LDESC,RDESC,LOP,ROP; REAL LDESC,RDESC; INTEGER LOP,ROP; 03271820
BEGIN INTEGER L,M,N,J,LRANK,RRANK,RANK,LSIZE,RSIZE,SIZE,LL,MM,I, 03271840
RROW,RCOL,LROW,LCOL,LJUMP,RJUMP,MSAVE,LSAVE,RSTART; 03271860
REAL DESC, TEMP; 03271880
BOOLEAN CHARACTER, FIRST,LSCALAR, RSCALAR; 03271900
LABEL QUIT, DOMAIN, FORGET, OUTERPROD; 03271920
IF L:=LDESC.SPF = 0 OR M := RDESC.SPF=0 THEN GO TO DOMAIN; 03271940
LSIZE := FINDSIZE(LDESC); RSIZE:=FINDSIZE(RDESC); 03271960
LRANK:=LDESC.RF; RRANK := RDESC.RF; 03271965
IF LOP NEQ 45 THEN 03271970
IF LRANK GTR 2 AND LSIZE NEQ 1 OR RRANK GTR 2 AND RSIZE NEQ 1 THEN 03271975
BEGIN ERR:=KITEERROR; GO TO QUIT; END; 03271980
IF ROP:=GETOP(CORRESPONDENCE,ROP-1) = 9 THEN BEGIN 03271982
ERR:=SYNTAXERROR; GO TO QUIT; END; 03271985
IF LL:=LDESC.ARRAYTYPE=1 OR MM:=RDESC.ARRAYTYPE=1 THEN 03271990
IF LL | MM NEQ 1 THEN GO TO DOMAIN 03271992
ELSE BEGIN 03272000
03272001
IF ROP LSS 11 OR ROP GTR 16 THEN GO TO DOMAIN; 03272002
CHARACTER:=TRUE; 03272003
M:=UNPACK(M,RRANK,RSIZE); 03272004
L:=UNPACK(L,LRANK,LSIZE); END; 03272005
MSAVE := M; LSAVE:=L; IF ROP NEQ 45 THEN 03272006
IF LOP=45 THEN GO TO OUTERPROD ELSE 03272009
IF LOP:=GETOP(CORRESPONDENCE,LOP-1)=9 THEN 03272040
BEGIN ERR:=SYNTAXERROR; GO TO QUIT; END; 03272045
IF LRANK=2 THEN BEGIN 03272050
N:=L+LRANK-1; LCOL := SP[NOC]; 03272060
N:=N-1; LROW:=SP[NOC]; END; 03272070
IF LRANK=1 THEN BEGIN LROW:=1; LCOL:=SP[LOC]; END; 03272080
IF RRANK=2 THEN BEGIN 03272100
N :=M+RRANK-1; RCOL:=SP[NOC]; 03272110
N:=N-1; RROW:=SP[NOC]; END; 03272120
IF RRANK=1 THEN BEGIN RROW:=SP[MOC]; RCOL:=1; END; 03272140
IF LSIZE =1 OR RSIZE=1 THEN BEGIN 03272142
IF LSIZE = 1 AND RSIZE = 1 THEN LROW:=LCOL:=RROW:=RCOL:=1 03272145
ELSE IF LSIZE=1 THEN BEGIN LCOL:=RROW; LROW:=1; 03272150
L:=L+LRANK-1; LRANK:=1; 03272155
LSCALAR:=TRUE; END 03272160
ELSE BEGIN RROW := LCOL; RCOL := 1; 03272170
M:=M+RRANK-1; RRANK:=1; 03272175
RSCALAR:=TRUE; END; 03272180
END; 03272185
IF LCOL NEQ RROW 03272240
THEN BEGIN ERR:=RANKERROR; GO TO QUIT; END; 03272245
DESC.SPF:=N:=GETSPACE((RANK:=MAX(0,LRANK+RRANK-2))+ 03272360
SIZE:=LROW|RCOL); 03272380
SPCOPY(L,N,LRANK-1); 03272400
SPCOPY(M+1,N+LRANK-1,RRANK-1); 03272420
DESC.RF:=RANK; DESC.DID:=(IF RANK=0 THEN DDPUSW ELSE DDPUVW); 03272440
N:=N+RANK; 03272460
LL := L + LRANK - 1; 03272480
MM := M + RRANK - 1; 03272500
LJUMP := LCOL-1; RJUMP := IF RSCALAR THEN 0 ELSE (RROW-1) | RCOL; 03272520
FOR J:=1 STEP LCOL UNTIL LSIZE DO 03272540
FOR RSTART:=1 STEP 1 UNTIL RCOL DO BEGIN 03272560
FIRST:=TRUE; 03272580
M := MM + RSTART + RJUMP; RROW := LL+J; 03272600
FOR I:=LL + LJUMP + J STEP -1 UNTIL RROW DO BEGIN 03272620
IF LSCALAR THEN L:=LL+1 ELSE L:=I; 03272630
IF FIRST THEN BEGIN 03272640
IF NOT OPERATION(SP[LOC],SP[MOC],1,ROP,SP[NOC]) 03272660
THEN GO TO FORGET ELSE FIRST := FALSE; 03272680
END ELSE BEGIN 03272700
IF NOT OPERATION(SP[LOC],SP[MOC],1,ROP,TEMP) 03272720
THEN GO TO FORGET; 03272740
IF NOT OPERATION(TEMP,SP[NOC],-1,LOP,SP[NOC]) 03272760
THEN GO TO FORGET; END; 03272780
IF NOT RSCALAR THEN M:=M-RCOL; END; 03272800
N := N+1; 03272820
END; 03272840
GO TO QUIT; 03272860
OUTERPROD: IF SIZE:=LSIZE|RSIZE GTR MAXWORDSTORE 03272880
OR RANK := LRANK+RRANK GTR 31 THEN BEGIN 03272900
ERR:=KITEERROR; GO TO QUIT; END; 03272920
DESC.SPF:=N:=GETSPACE(SIZE+RANK); 03273060
DESC.DID:=IF RANK=0 THEN DDPUSW ELSE DDPUVW; 03273080
DESC.RF:=RANK; 03273100
SPCOPY(L,N,LRANK); 03273120
SPCOPY(M,N+LRANK,RRANK); 03273140
N:=N+RANK; 03273160
I:=L + LRANK + LSIZE - 1; 03273180
MM := M+RRANK + RSIZE - 1; 03273200
FOR L:=L+LRANK STEP 1 UNTIL I DO 03273220
FOR M:=MSAVE+RRANK STEP 1 UNTIL MM DO 03273240
IF NOT OPERATION(SP[LOC],SP[MOC],1,ROP,SP[NOC]) THEN 03273260
GO TO FORGET ELSE N:=N+1; 03273280
GO TO QUIT; 03273285
FORGET: FORGETSPACE(DESC.SPF,RANK+SIZE); 03273300
DOMAIN: ERR:=DOMAINERROR; 03273320
QUIT: IF CHARACTER THEN BEGIN 03273340
FORGETSPACE(MSAVE , RRANK+RSIZE); 03273380
FORGETSPACE(LSAVE , LRANK+LSIZE); END; 03273400
RESULTD := DESC; 03273420
END PROCEDURE PERIOD; 03273440
PROCEDURE REVERSE(SOURCE,LENGTH,DEST,JUMP); VALUE SOURCE,DEST, 03273442
LENGTH,JUMP; INTEGER SOURCE,LENGTH,DEST,JUMP; 03273444
BEGIN INTEGER L,M,TOP; 03273446
M:=SOURCE + TOP:=(LENGTH-1) | JUMP; TOP:=DEST+TOP; 03273448
FOR L:=DEST STEP JUMP UNTIL TOP DO BEGIN 03273450
SP[LOC] := SP[MOC]; M:=M-JUMP; END; 03273452
END PROCEDURE REVERSE; 03273454
PROCEDURE ROTATE(SOURCE,LENGTH,DEST,JUMP,ROT); VALUE SOURCE, 03273456
LENGTH,DEST,JUMP,ROT; INTEGER SOURCE,LENGTH,DEST,JUMP,ROT; 03273458
BEGIN INTEGER L,M,TOP; 03273460
TOP := SOURCE + (LENGTH-1) | JUMP; 03273462
FOR L:=SOURCE STEP JUMP UNTIL TOP DO BEGIN 03273464
M:=DEST+(ROT MOD LENGTH)|JUMP; SP[MOC]:=SP[LOC]; 03273466
ROT := ROT + 1; END; 03273468
END PROCEDURE ROTATE; 03273470
INTEGER PROCEDURE GETNUM(TIM,L,SIZE,DIM); VALUE TIM,L, 03273472
SIZE,DIM; INTEGER TIM,L,SIZE,DIM; 03273474
BEGIN INTEGER NUM; 03273476
IF SIZE NEQ 0 THEN L := L + TIM; 03273478
NUM:=SIGN(NUM:=SP[LOC]) | ENTIER(ABS(NUM)) MOD DIM; 03273482
IF NUM LSS 0 THEN GETNUM := -NUM %FOR RIGHT ROTATION 03273484
ELSE GETNUM:=DIM-NUM; %FOR LEFT ROTATION 03273486
END PROCEDURE GETNUM; 03273489
BOOLEAN PROCEDURE MATCHROT(LDESC,RDESC,ALONG); VALUE LDESC, 03273490
RDESC,ALONG; INTEGER LDESC,RDESC,ALONG; 03273491
BEGIN INTEGER I,L,M,R; LABEL QUIT; 03273492
MATCHROT:=TRUE; L:=LDESC.SPF; M:=RDESC.SPF; 03273493
IF R:=LDESC.RF NEQ RDESC.RF-1 THEN BEGIN 03273494
MATCHROT:=FALSE; GO TO QUIT; END; 03273495
FOR I:=1 STEP 1 UNTIL R DO BEGIN IF I=ALONG THEN M:=M+1; 03273496
IF SP[LOC] NEQ SP[MOC] THEN BEGIN MATCHROT:=FALSE; 03273497
GO TO QUIT; END; M:=M+1; L:=L+1; END; 03273498
QUIT: END PROCEDURE MATCHROT; 03273499
PROCEDURE REDUCESORTSCAN(LOP,RDESC,DIM,KIND); VALUE LOP,RDESC, 03273500
DIM,KIND; REAL LOP,RDESC,DIM; INTEGER KIND; 03273520
BEGIN INTEGER L,M,N,I,J,K,ALONG,FACTOR,T,MSAVE,DIFF,SSIZE, 03273540
JUMP,RANK,SIZE,TOP,LASTDIM,INTERVAL,TEMP,HOP; 03273560
INTEGER REMDIM,LRANK,LSAVE,LSIZE,S; 03273565
BOOLEAN CHARACTER,REDUCE,SORT,SCAN,REVERSAL,ROTATION; 03273580
REAL DESC; 03273600
LABEL QUIT, FORGET, RANKERR; 03273620
COMMENT: KIND=1 FOR REDUCTION 03273622
KIND=2 FOR SORTUP OR SORTDN 03273624
KIND=3 FOR SCAN 03273626
KIND=4 FOR REVERSAL 03273628
KIND=5 FOR ROTATION; 03273630
PROCEDURE SORTIT(L,M,SIZE,JUMP,UP); VALUE L,M,SIZE,JUMP,UP; 03273640
INTEGER L,M,SIZE,JUMP; BOOLEAN UP; 03273660
BEGIN INTEGER N,TIP,TOP,LSAVE; 03273680
REAL COMPARE,OUTOFIT; 03273700
OUTOFIT:=IF UP THEN BIGGEST ELSE -BIGGEST; 03273720
TIP := M + (N:=(SIZE-1)) | JUMP; TOP := L + N; 03273740
LSAVE := L; 03273760
FOR M:=M STEP JUMP UNTIL TIP DO BEGIN 03273800
L := LSAVE; COMPARE := SP[LOC]; N:=L; 03273820
FOR L:=L+1 STEP 1 UNTIL TOP DO 03273830
IF UP THEN BEGIN IF SP[LOC] LSS COMPARE THEN BEGIN 03273840
N:=L; COMPARE:=SP[LOC]; END; 03273860
END ELSE IF SP[LOC] GTR COMPARE THEN BEGIN 03273880
N:=L; COMPARE:=SP[LOC]; END; 03273900
SP[NOC] := OUTOFIT; 03273920
SP[MOC] := (N-LSAVE) + ORIGIN; 03273940
END; 03273960
END PROCEDURE SORTIT; 03273980
CASE KIND OF BEGIN ; REDUCE:=TRUE; SORT:=TRUE; SCAN:=TRUE; 03273990
REVERSAL:=TRUE; ROTATION:=TRUE; END; 03273995
IF LOP GTR 64 AND NOT ROTATION THEN BEGIN 03274000
ERR:=SYSTEMERROR; GO TO QUIT; END; 03274010
IF REDUCE OR SCAN THEN IF LOP NEQ 45 THEN 03274020
LOP := GETOP(CORRESPONDENCE,LOP-1); 03274030
IF M:=RDESC.SPF=0 AND NOT REDUCE 03274040
OR DIM.DID NEQ 0 AND N:=DIM.SPF=0 OR DIM.ARRAYTYPE=1 03274060
OR FINDSIZE(DIM) NEQ 1 THEN BEGIN 03274065
ERR:=DOMAINERROR; GO TO QUIT END; 03274070
IF (REDUCE OR SCAN) AND LOP=9 THEN BEGIN %OP NOT DYADIC SCALAR 03274080
ERR:=SYNTAXERROR; GO TO QUIT END; 03274100
IF M=0 THEN BEGIN 03274102
%FOR REDUCTION, RESULT OF A NULL IS CORRESPONDING IDENTITY 03274105
%EXCEPT THAT NAND, NOR, CIRCLE, AND LOG (LOP GTR 18) 03274106
%HAVE NO IDENTITIES, SO THE RESULT IS A NULL 03274107
DESC.DID := DDPUSW; 03274108
IF LOP LEQ 18 THEN BEGIN DESC.SPF:=N:=GETSPACE(1); 03274110
SP[NOC] := IDENTITY(LOP); END ELSE DESC.RF:=1; 03274111
GO TO QUIT; END; 03274113
IF RDESC.ARRAYTYPE=1 AND (REDUCE OR SCAN) THEN 03274115
BEGIN ERR:=DOMAINERROR; GO TO QUIT; END; 03274117
SIZE:=FINDSIZE(RDESC); 03274120
RANK:=RDESC.RF; 03274140
IF SIZE=1 THEN BEGIN 03274160
%UNLESS SORT, RESULT OF SINGLE-VALUED ARGUMENT IS THAT ARGUMENT 03274165
DESC := RDESC; 03274180
DESC.SPF := N := GETSPACE(RANK+1); 03274200
SPCOPY(M,N,RANK);M:=M+RANK;N:=N+RANK; 03274220
IF SORT THEN BEGIN SP[NOC]:=ORIGIN; DESC.ARRAYTYPE:=0; 03274240
END ELSE SP[NOC]:=SP[MOC]; 03274260
GO TO QUIT; END; 03274280
03274300
IF RDESC.ARRAYTYPE=1 THEN BEGIN 03274320
CHARACTER := TRUE; 03274360
M:=UNPACK(M,RANK,SIZE); END; 03274380
MSAVE:=M; 03274400
N:=N+(T:=DIM.RF); 03274420
IF ALONG:=(IF N=T THEN RANK ELSE SP[NOC]-ORIGIN+1) GTR RANK 03274440
OR ALONG LSS 1 03274450
THEN BEGIN ERR:=INDEXERROR; GO TO QUIT; END; 03274460
IF ROTATION THEN BEGIN 03274462
IF LSAVE:=LOP.SPF=0 OR LOP.ARRAYTYPE=1 THEN 03274464
BEGIN ERR:=DOMAINERROR; GO TO QUIT; END; 03274466
IF LSIZE:=FINDSIZE(LOP) NEQ 1 THEN 03274468
IF NOT MATCHROT(LOP,RDESC,ALONG) THEN BEGIN 03274470
ERR:=RANKERROR; GO TO QUIT; END; 03274472
LSAVE := LSAVE + LRANK := LOP.RF; 03274474
IF LSIZE = 1 THEN LRANK := 0; END; 03274476
N:=M+ALONG-1; 03274480
DIM:=SP[NOC]; 03274500
JUMP:=1; I:=M+ALONG; 03274520
FOR L:=M+RANK-1 STEP -1 UNTIL I DO JUMP:=JUMP | SP[LOC]; 03274540
N:=M+RANK-1; LASTDIM:=SP[NOC]; 03274560
IF ALONG = RANK-1 THEN BEGIN N:=N-1; 03274580
FACTOR:=LASTDIM | SP[NOC]; END; 03274600
T := GETT(ALONG, RANK); 03274620
J := M + RANK; 03274622
REMDIM := 1; 03274623
HOP := (DIM-1) | JUMP; 03274624
DESC.DID := DDPUVW; 03274625
IF ALONG GTR 1 AND ALONG LSS RANK-1 THEN BEGIN TOP:=M+ALONG-2; 03274626
FOR L:=M STEP 1 UNTIL TOP DO REMDIM:=REMDIM|SP[LOC]; END; 03274627
IF REDUCE THEN BEGIN DESC.SPF:=N:=GETSPACE(SSIZE:=SIZE DIV DIM 03274628
+ RANK - 1); 03274629
IF RANK=1 THEN DESC.SCALAR:=1 ELSE DESC.RF:=RANK-1; 03274631
FOR I:=1 STEP 1 UNTIL RANK DO BEGIN 03274634
IF I NEQ ALONG THEN BEGIN SP[NOC]:=SP[MOC]; N:=N+1; END; 03274637
M:=M+1; END; 03274640
JUMP := - JUMP; 03274643
END ELSE BEGIN DESC.SPF:=N:=GETSPACE(SSIZE:=SIZE+RANK); 03274646
INTERVAL := (DIFF := N-M) + HOP; 03274648
SPCOPY(M,N,RANK); DESC.RF:=RANK; END; 03274649
IF SORT THEN TEMP:= GETSPACE(DIM); 03274720
TOP := SIZE DIV (DIM | REMDIM) - 1; 03274732
FOR S:=1 STEP 1 UNTIL REMDIM DO BEGIN 03274735
FOR I:=0 STEP 1 UNTIL TOP DO BEGIN 03274740
CASE T OF BEGIN 03274760
L := I + J; 03274780
L:=I DIV LASTDIM|FACTOR + I MOD LASTDIM + J; 03274800
L:=I|LASTDIM + J; END; 03274820
IF REDUCE THEN BEGIN M:=I+N; L:=HOP + (K:=L); 03274822
SP[MOC] := SP[LOC]; 03274825
FOR L:=L+JUMP STEP JUMP UNTIL K DO 03274828
IF NOT OPERATION(SP[LOC],SP[MOC],-1,LOP,SP[MOC]) 03274831
THEN GO TO FORGET; 03274834
END ELSE 03274837
IF SORT THEN BEGIN K:=L+HOP; N:=TEMP; 03274840
FOR M:=L STEP JUMP UNTIL K DO BEGIN 03274845
SP[NOC] := SP[MOC]; N:=N+1; END; 03274850
IF LOP LSS 0 THEN SORTIT(TEMP,L+DIFF,DIM,JUMP,FALSE) 03274860
ELSE SORTIT(TEMP,L+DIFF,DIM,JUMP,TRUE); 03274880
END ELSE IF SCAN THEN BEGIN 03274900
K:=L+INTERVAL; N:=L+DIFF; SP[NOC] := SP[LOC]; 03274920
FOR N:=N+JUMP STEP JUMP UNTIL K DO BEGIN 03274940
M:=N-JUMP; L:=L+JUMP; 03274980
IF NOT OPERATION(SP[MOC],SP[LOC],-1,LOP,SP[NOC]) 03275000
THEN GO TO FORGET; END; 03275020
END ELSE IF REVERSAL THEN REVERSE(L,DIM,L+DIFF,JUMP) 03275040
ELSE IF ROTATION THEN ROTATE(L,DIM,L+DIFF,JUMP, 03275050
GETNUM(I,LSAVE,LRANK,DIM)); 03275060
END; 03275080
J := J + ABS(JUMP|DIM); 03275085
N := N + TOP + 1; 03275088
DIFF := DIFF + TOP + 1; 03275089
END; 03275090
GO TO QUIT; 03275100
RANKERR: ERR:=RANKERROR; FORGETSPACE(DESC.SPF,SSIZE);GO QUIT; 03275110
FORGET: ERR:=DOMAINERROR; FORGETSPACE(DESC.SPF, SSIZE); 03275120
QUIT: IF CHARACTER THEN BEGIN 03275140
FORGETSPACE(MSAVE,SIZE+RANK); 03275142
IF (REVERSAL OR ROTATION) AND ERR=0 THEN BEGIN 03275144
DESC.ARRAYTYPE:=1; PACK(DESC.SPF,RANK,SIZE); END; END; 03275146
IF SORT THEN FORGETSPACE(TEMP,DIM); 03275150
RESULTD := DESC; 03275160
IF ROTATION THEN POP; 03275165
END PROCEDURE REDUCESORTSCAN; 03275180
PROCEDURE DYADICTRANS; 03275200
BEGIN REAL LDESC,RDESC; 03275300
INTEGER L,M,N,RANK,NEWRANK,SIZE,TEMP,I,J; 03275400
DEFINE SPTOP=RDESC#,MIN=RDESC#,PTR=NEWRANK#,MBASE=LDESC#,TOP=RDESC# 03275500
,RESULT=RESULTD#; 03275510
LABEL QUIT; BOOLEAN CARRY; 03275600
INTEGER ARRAY RVEC,DEL,SUB,OLDEL[0:31]; 03275700
LDESC:=AREG; RDESC:=BREG; 03275800
RESULT:=0; L:=LDESC.SPF; J:=LDESC.RF; RANK:=RDESC.RF; 03275900
IF M:=RDESC.SPF=0 OR L=0 OR LDESC.ARRAYTYPE=1 THEN BEGIN 03276000
ERR:=DOMAINERROR; GO TO QUIT END; 03276010
IF NUMELEMENTS(LDESC)=1 THEN BEGIN N:=L+J; 03276100
IF SP[NOC] NEQ ORIGIN OR RANK GTR 1 THEN BEGIN 03276200
ERR:=DOMAINERROR; GO TO QUIT END; 03276300
%IF WE GET HERE, THE ANSWER IS ITSELF 03276310
RESULT:=RDESC; I:=NUMELEMENTS(RDESC); 03276400
RESULT.SPF:=N:=GETSPACE(SIZE:=RANK+I); RESULT.NAMED:=0; 03276410
SPCOPY(M,N,SIZE); GO TO QUIT; END; 03276420
IF J GTR 1 THEN BEGIN ERR:=RANKERROR; GO TO QUIT END; 03276430
IF SP[LOC] NEQ RANK THEN BEGIN ERR:=LENGTHERROR; GO TO QUIT END; 03276440
% FIND MAX OF LDESC FOR NOW- DO THE REST LATER 03276500
%LDESC W/R/T/ ORIGIN 0 GETS STORED IN SUB[I] 03276600
SPTOP:=L+RANK; NEWRANK:=0; I:=0; 03276700
FOR N:=L+1 STEP 1 UNTIL SPTOP DO BEGIN 03276800
IF TEMP:=SP[NOC]-ORIGIN+1 GTR NEWRANK THEN NEWRANK:=TEMP; 03276900
SUB[I]:=TEMP-1; I:=I+1 END; 03277000
IF NEWRANK GTR RANK THEN BEGIN ERR:=DOMAINERROR;GO TO QUIT END; 03277010
% CALCULATE THE OLD DEL VECTOR, OLDEL 03277100
OLDEL[RANK-1]:=1; N:=M+RANK-1; 03277200
FOR I:=RANK-2 STEP -1 UNTIL 0 DO BEGIN 03277300
OLDEL[I]:=OLDEL[I+1]|SP[NOC]; N:=N-1 END; 03277400
MBASE:=M; SIZE:=1; 03277500
%FIX UP THE NEW RVEC AND DEL 03277700
FOR I:=NEWRANK-1 STEP -1 UNTIL 0 DO BEGIN 03277800
% FIND SMALLEST EL. OF RHO RDESC [J] S.T. A[J]=I 03277900
% AND SUM OF OLDEL[J] S.T. A[J]=I 03278000
MIN:=31; TEMP:=0; 03278100
FOR J:=RANK-1 STEP -1 UNTIL 0 DO 03278200
IF SUB[J]=I THEN BEGIN 03278300
M:=MBASE+J; 03278400
IF SP[MOC] LSS MIN THEN MIN:=SP[MOC]; 03278500
TEMP:=TEMP+OLDEL[J] END; 03278600
RVEC[I]:=MIN; DEL[I]:=TEMP; SIZE:=SIZE|RVEC[I]; 03278700
IF TEMP=0 THEN BEGIN %IT DOESN7T EXHAUSE IOTA NEWRANK 03278710
ERR:=DOMAINERROR; GO TO QUIT END; 03278720
END; 03278800
RESULT:=M:=GETSPACE(NEWRANK+SIZE); 03279200
RESULT.RF:=NEWRANK; RESULT.DID:=DDPUVW; 03279300
IF BOOLEAN(BREG.ARRAYTYPE) THEN BEGIN 03279310
RESULT.ARRAYTYPE:=1; N:=MBASE; 03279320
MBASE:=UNPACK(MBASE,RANK,N:=OLDEL[0]|SP[NOC]); 03279330
FORGETSPACE(MBASE,N+RANK) END; 03279340
FOR I:=1 STEP 1 UNTIL NEWRANK DO BEGIN 03279400
SP[MOC]:=RVEC[I-1]; M:=M+1 END; 03279500
%INITIALIZE FOR STEPPING THRU NEW ARRAY 03279590
FOR I:=NEWRANK-1 STEP -1 UNTIL 0 DO BEGIN 03279600
SUB[I]:=0; OLDEL[I]:=RVEC[I]|DEL[I] END; 03279610
L:=MBASE+RANK; 03279700
%STEP THRU THE SUBSCRIPTS OF THE ANSWER TO PICK UP THE ELEMENTS 03279800
% IN ROW ORDER ACCORDING TO THE MAPPING GIVEN BY DEL 03279900
PTR:=TOP:=NEWRANK-1; 03280000
FOR I:=1 STEP 1 UNTIL SIZE DO BEGIN 03280100
SP[MOC] :=SP[LOC]; 03280200
M:=M+1; 03280300
%GET NEXT SUBSCRIPT FOR NEW ARRAY AND SET NEXT L; 03280400
SUB[PTR]:=SUB[PTR]+1; 03280500
L:=L+DEL[TOP]; 03280600
CARRY:=TRUE; 03280700
WHILE CARRY AND I NEQ SIZE DO 03280800
IF SUB[PTR] GEQ RVEC[PTR] THEN BEGIN 03280900
SUB[PTR]:=0; 03280990
L:=L-OLDEL[PTR]+DEL[PTR:=PTR-1]; 03281000
SUB[PTR]:=SUB[PTR]+1 03281100
END ELSE CARRY := FALSE; 03281200
PTR:=TOP; 03281210
END; 03281600
IF BOOLEAN(RESULT.ARRAYTYPE) THEN PACK(RESULT.SPF,TOP+1,SIZE); 03281700
QUIT: END OF DYADICTRANS; 03281710
INTEGER PROCEDURE LOCATE(L,M); VALUE L,M; REAL L,M; 03490000
BEGIN 03490100
COMMENT L IS THE DIMENSION VECTOR(DESCRIPTOR), 03490200
M IS THE INDEX VECTOR; 03490300
INTEGER P,I,UB; 03490400
L:=I:=L.SPF; M:=I:=M.SPF; 03490500
UB:=SP[MOC]-1; 03490600
M:=M+1; 03490700
FOR I:=1 STEP 1 UNTIL UB DO 03490800
BEGIN 03490900
L:=L+1; 03491000
P:=(P+SP[MOC]-1)|SP[LOC]; 03491100
M:=M+1 03491200
END; 03491300
P:=P+SP[MOC]; 03491400
LOCATE:=P+L; 03491450
END; 03491500
PROCEDURE DISPLAY(A,B); VALUE A,B; REAL A,B; 03500000
BEGIN 03500100
PROCEDURE PRINTMATRIX(L,ROW,COL);VALUE L,ROW,COL; 03500110
INTEGER L,ROW,COL; 03500120
BEGIN INTEGER I,J,CC,FOLD; DEFINE WIDE=GT2#; 03500130
WIDE:=LINESIZE; 03500132
FOR I:=1 STEP 1 UNTIL ROW DO 03500134
BEGIN CC:=0; %NO BLANKS AT BEGINNING OF LINE 03500138
FOLD:=0; 03500139
FOR J:=1 STEP 1 UNTIL COL DO 03500140
BEGIN NUMBERCON(SP[LOC],ACCUM); 03500142
IF FOLD:=FOLD+ACOUNT+CC GTR WIDE AND ACOUNT+CC 03500143
LEQ WIDE THEN BEGIN TERPRINT; 03500144
FORMROW(0,2,ACCUM,2,ACOUNT); FOLD:=ACOUNT+2; END ELSE 03500145
FORMROW(0,CC,ACCUM,2,ACOUNT); L:=L+1; 03500146
CC:=2; %PUT 2 BLANKS AFTER THE FIRST ITEM. 03500148
END; 03500150
TERPRINT; 03500154
END 03500158
END; 03500162
INTEGER L,N,M,BOTTOM,ALOC,BLOC; 03500200
INTEGER ROW,COL; 03500210
ALOC:=A.SPF; BLOC:= B.SPF-1; 03500300
L:=(M:=B.RF)+ BLOC; COL:=SP[LOC]; 03500310
L:=L-1; 03500320
ROW:=(IF M GTR 1 THEN SP[LOC] ELSE 1); 03500330
L:=BOTTOM:=M-2; 03500350
PRINTMATRIX(LOCATE(B,A),ROW,COL); 03500400
WHILE L GTR 0 DO 03500450
BEGIN 03500500
M:=ALOC+L; N:=BLOC+L; 03500550
IF SP[MOC]:=SP[MOC]+1 GTR SP[NOC] THEN 03500600
BEGIN SP[MOC]:=1; L:=L-1; END 03500650
ELSE BEGIN FORMWD(3,"1 "); 03500700
PRINTMATRIX(LOCATE(B,A),ROW,COL); 03500710
L:=BOTTOM; 03500750
END; 03500800
END; 03500850
FORMWD(3,"1 "); 03500855
END; 03500900
PROCEDURE MAKEFUNCTIONPRESENT(L); VALUE L ; REAL L; %LOC DESC 03501100
BEGIN 03501200
INTEGER I; 03501300
REAL M,N,SEQ,ORD,D; 03501400
BOOLEAN NUMERIC; 03501600
REAL STREAM PROCEDURE CON(A); VALUE A; 03501610
BEGIN SI:=LOC A; DI:=LOC CON; DS:=8OCT 03501620
END; 03501630
D:=SP[LOC]; %DESCRIPTOR FOR FUNCTION IS IN D 03501700
SEQ:=GETFIELD(D,FSQF-8,FFL); ORD:=GETFIELD(D,FPTF-8,FFL); 03501800
N:=GETSPACE((M:=SIZE(ORD))|2+6); %GET SPACE FOR TABLE 03501900
SP[NOC]:=M|2+5; %SIZE OF THE VECTOR WHICH FOLLOWS 03502000
D:=D&N[CSPF]&1[CRF]&0[BACKPT]; D.PRESENCE:=1; 03502100
SP[LOC]:=D; %THIS SETS UP THE FUNCTION DESCRIPTOR. 03502200
N:=N+1; SP[NOC]:=SEQ; 03502300
COMMENT 03502400
SP[N] = SIZE OF THE VECTOR 03502500
SP[N+1] = SEQUENTIAL STORAGE UNIT FOR THE TEXT 03502600
SP[N+2] = SP LOC OF FIRST NUMERIC POINTER TO TEXT 03502700
03502710
SP[N+3] = REL LOC (TO N+5) OF THE FIRST ARG 03502800
SP[N+4] = REL LOC OF THE SECOND ARG 03502900
SP[N+5] = REL LOC OF RESULT . IF ANY ARE ZERO, THEN 03503000
THEY ARE NOT THERE.; 03503100
D:=M; M:=(N:=N+4)+1; %D IS #ITEMS, M IS LOC 1ST, N=M-1 03503200
FOR I:=1 STEP 1 UNTIL D DO %GET LABELS FROM STORAGE 03503300
BEGIN L:=CONTENTS(ORD,I-1,GTA); 03503400
IF NOT NUMERIC THEN %RESULT, ARGS, OR LOCALS/LABELS 03503500
IF NUMERIC:=GTA[0]=0 THEN %FIRST NUMERIC POINTER 03503600
BEGIN L:=N-3; SP[LOC]:=N+I|2-1; 03503700
END; 03503800
SP[MOC]:=GTA[0]; M:=M+1; 03503900
IF NUMERIC THEN SP[MOC]:=GTA[1] ELSE 03504000
BEGIN 03504100
IF SEQ:=GTA[1] LSS 0 THEN %RESULT OR ARG 03504200
BEGIN L:=N+SEQ+1; SP[LOC]:=I; 03504300
SEQ:=0; 03504310
END ELSE SEQ:=CON(SEQ)/10000; 03504400
SP[MOC]:=SEQ 03504500
END; 03504600
M:=M+1 03504700
END; 03504800
COMMENT WE HAVE SET UP THE FUNCTION LABEL TABLE, LET 03504900
SOMEONE ELSE FIGURE OUT HOW TO EXECUTE IT; 03505000
END; 03505100
PROCEDURE PUSHINTOSYMTAB(FPTR);VALUE FPTR;REAL FPTR; 03506000
BEGIN COMMENT ...PUT THE LOCAL VARIABLES FROM THIS SUSPENDED 03506100
FUNCTION INTO THE SYMBOL TABLE TO BE TREATED AS GLOBAL VARIABLES 03506200
WHILE THE FUNCTION IS SUSPENDED. FPTR IS THE ENTRY FROM THE 03506300
STATE INDICATOR VECTOR FOR THE FUNCTION.; 03506400
03506500
REAL T,U; 03506600
LABEL COPY; 03506700
INTEGER K,L,M,N; 03506800
M:=FPTR.LOCFIELD+1;%LOCATE FMKS TO FIND LOCAL VALUES IN STACK 03506900
N:=FPTR.SPF+2;T:=SP[NOC]-2;%FIND LOCAL NAMES 03507000
FOR N:=N+4 STEP 2 UNTIL T DO %ONCE FOR EACH LOCAL 03507100
BEGIN GT1:=SP[NOC].[6:42];%PICK UP THE LOCAL NAME 03507200
L:=SYMBASE;K:=L+SP[LOC];% LOOK IN SYMBOL TABLE 03507300
FOR L:=L+1 STEP 2 UNTIL K DO % CHECK EACH NAME 03507400
IF GT1=SP[LOC].[6:42] THEN % WE FOUND A MATCH 03507500
BEGIN GT1:=M;K:=M:=GETSPACE(1);L:=L+1; 03507600
SP[MOC]:=SP[LOC]; %PUSH CURRENT DESCRIPTOR DOWN 03507700
M:=GT1; GO TO COPY; 03507800
END; 03507900
COMMENT GET HERE IF NO MATCH...MUST MAKE A NEW ENTRY IN 03508000
SYMBOL TABLE; 03508100
IF K LSS MAXSYMBOL|2 THEN % THERE IS ROOM IN SYMBOL TABLE 03508200
BEGIN L:=SYMBASE;SP[LOC]:=SP[LOC]+2; L:=K+1; 03508300
SP[LOC]:=GT1&OPERAND[CTYPEF]&1[CSUSVAR];L:=L+1;K:=0; 03508400
COPY: COMMENT L IS LOC IN SYMBOL TABLE FOR DESC. K WILL BE 03508500
CONTENTS OF BACKF. NOW SET UP THE NEW DESCRIPTOR AND 03508600
SAVE ITS LOCATION IN THE STACK. M IS THE STACK LOCATION 03508700
OF THE LOCAL; 03508800
03508900
SP[LOC]:=SP[MOC]&K[CLOCF]&1[CNAMED]; 03509000
SP[MOC]:=L&DDNUVW[CDID];M:=M+1; 03509100
END ELSE % THERE IS NO ROOM IN THE SYMBOL TABLE 03509200
BEGIN N:=T;ERR:=SPERROR;END; 03509300
END;% OF FOR LOOP STEPPING THRU THE LOCALS 03509400
END; % OF PUSHINTOSYMTAB PROCEDURE 03509500
PROCEDURE FORGETPROGRAM(U);VALUE U; REAL U; 03510000
BEGIN REAL L,M; 03510100
COMMENT U IS A PROGRAMMKS...THE SP STORAGE FOR THIS LINE 03510150
SHOULD BE RELEASED; 03510151
M:=U.SPF;SCRATCHAIN(SP[MOC].LOCFIELD);%CONSTANT CHAIN 03510200
L:=SP[MOC].SPF;FORGETSPACE(M,1);%FORGET PROGRAM DESC. 03510300
M:=L+1;SCRATCHDATA(SP[MOC]);%FORGET BUFFER 03510400
FORGETSPACE(L,SP[LOC]+1);%FORGET THE POLISH 03510500
END; 03510600
EXPOVR:=EXPOVRL; 03609000
INTOVR:=INTOVRL; 03609100
INDEX:=INDEXL; 03609200
FLAG:=FLAGL; 03609300
ZERO:=ZEROL; 03609400
CASE MODE OF 03700000
BEGIN ;%-------------------------------------------------------- 03700100
%---------------- CASE 1....MODE=XEQUTE------------------------ 03700200
CASE CURRENTMODE OF 03700300
BEGIN%----------------------------------------------------- 03700400
%------------ SUB-CASE 0....CURRENTMODE=CALCMODE----------- 03700500
IF T:=ANALYZE(TRUE) NEQ 0 THEN % WE HAVE A PROGRAM DESC 03700600
BEGIN COMMENT SET-UP THE STACK; 03700700
IF STACKBASE=0 THEN BEGIN 03700710
STACKBASE:=L:=GETSPACE(STACKSIZE+1); 03700800
IF ERR NEQ 0 THEN BEGIN STACKBASE:=0; 03700810
ERRORMESS(ERR,0,0); GO TO PROCESSEXIT;END; 03700820
SP[LOC]:=2; 03700900
L:=L+1; 03700910
M:=GETSPACE(STATEVECTORSIZE+1); 03700912
SP[LOC]:=M&1[CRF]&DDPNVW[CDID]; 03700920
SP[MOC]:=STATEVECTORSIZE; 03700930
M:=M+1; SP[MOC]:=0; % THE STATE VECTOR IS INITIALIZED NOW 03700940
FUNCLOC:=M; 03700950
N:=0; 03700960
L:=L+1; COMMENT READY FOR A PROG MKS; 03701000
END ELSE % THERE IS ALREADY A STACK...USE IT 03701010
BEGIN L:=STACKBASE; 03701012
ST:=SP[LOC]+L; 03701020
WHILE M:=AREG.DID NEQ IMKS AND M NEQ PROGMKS AND 03701022
ERR=0 DO POP;%STRIP BACK TO LASTMARKSTACK 03701024
IF M=IMKS THEN BEGIN N:=ST-STACKBASE;PUSH; 03701026
END ELSE N:=AREG.BACKF; 03701028
SP[LOC]:=ST-STACKBASE;L:=ST; 03701030
END; 03701040
CURLINE:=0; 03701050
M:=GETSPACE(1); SP[MOC]:=T; %STORE PROG DESCRIPTOR 03701060
SP[LOC]:=M&PROGMKS[CDID]&N[BACKPT]&1[CI]; 03701100
COMMENT JUST BUILT A PROGRAM MARKSTACK; 03701200
GO TO EXECUTION; 03701300
END; 03701400
%------------SUB-CASE 1....CURRENTMODE=XEQMODE--------------- 03701500
COMMENT RECOVERY FROM A TIME-OUT; 03701600
GO TO EXECUTION; 03701700
%----------- SUB-CASE 2....CURRENTMODE=FUNCMODE-------------- 03701800
COMMENT SYNTAX CHECK ONLY; 03701900
IF ANALYZE(TRUE)=0 THEN; 03702000
%----------- END OF SUB CASES------------------------------- 03702100
END; 03702200
%----------------- CASE 2.....MODE=ALLOC-------------------------- 03702300
COMMENT NOTHING TO DO; 03702400
; 03702500
%---------------- CASE 3.... MODE=WRITEBACK--------------------- 03702600
COMMENT HAVE TO WRITE BACK ALL THE CHANGED VARIABLES; 03702700
IF SYMBASE NEQ 0 THEN 03702800
WRITEBACK; 03702900
03709000
%---------------- CASE 4.... MODE=DEALLOC----------------------- 03709100
; 03709200
03709300
03709400
%---------------- CASE 5 .... MODE=INTERROGATE------------------ 03709500
COMMENT PRINT OUT THE PROGRAM STATUS VECTOR HERE; 03709600
IF L:=STACKBASE+1 NEQ 1 THEN 03709700
BEGIN COMMENT GT1=1 FOR SIV...=0 FOR SI; 03709710
U:=GT1; 03709715
L:=SP[LOC].SPF+1;M:=SP[LOC].SPF+L; 03709720
WHILE M GTR L DO 03709730
BEGIN N:=SP[MOC].LOCFIELD;N:=SP[NOC].SPF-1; 03709740
% N IS LOCATION OF THE FUNCTION NAME 03709742
ACCUM[0]:=SP[NOC]; 03709750
FORMROW(2,6,ACCUM,1,7); 03709760
IF BOOLEAN(SP[MOC].SUSPENDED) THEN FORMWD(0,"3 S ") 03709770
ELSE FORMWD(0,"3 "); 03709772
IF BOOLEAN(U) THEN % PRINT LOCAL VARIABLE NAMES 03709780
BEGIN 03709790
N:=SP[MOC].SPF+2;T:=SP[NOC]-2; 03709800
FOR N:=N+4 STEP 2 UNTIL T DO 03709810
BEGIN ACCUM[0]:=SP[NOC]; 03709820
FORMROW(0,1,ACCUM,1,7); 03709830
END; 03709840
END; 03709850
TERPRINT; M:=M-1; 03709860
END; 03709870
END; 03709880
END;% OF THE CASE STATEMENT 03711000
%--------------END OF CASES--------------------------------------- 03711100
IF FALSE THEN EXECUTION: 03750000
BEGIN COMMENT EXECUTION LOOP; 03750100
INTEGER LOOP; 03750200
INTEGER INPUTIMS; 03750202
LABEL BREAKKEY; 03750204
LABEL SKIPPOP,XEQEPS; 03750210
BOOLEAN XIT, JUMP; 03750300
REAL POLWORD; 03750400
DEFINE RESULT=RESULTD#; 03750410
LABEL EXECEXIT, EVALQ, EVALQQ; 03750500
%%% 03751000
COMMENT THERE IS A PROGRAM DESCRIPTOR AT THE TOP OF STACK; 03751100
ERR:=0; 03751200
L:=STACKBASE; ST:=L+SP[LOC]; 03751300
L:=L+1;FUNCLOC:=SP[LOC].SPF+1; 03751310
T:=AREG; 03751350
IF CURRENTMODE=XEQMODE THEN %AREG IS INTERRUPT MARK STACK 03751400
BEGIN LASTMKS:=STACKBASE+T.BACKF; 03751500
OLDDATA:=T.SPF; INPUTIMS:=T.QUADIN; POP; 03751600
COMMENT MAY BE CURRENTLY EXECUTING A FUNCTION; 03751610
L:=STACKBASE+1; L:=SP[LOC].SPF+1; 03751620
IF (M:=SP[LOC].SPF) NEQ 0 THEN 03751630
BEGIN M:=M+L; L:=SP[MOC].LOCFIELD; 03751640
CURLINE:=SP[LOC].CIF; 03751650
03751660
END; 03751670
END 03751680
ELSE LASTMKS:=ST;%AREG IS PROGRAM MARK STACK 03751700
CURRENTMODE:=XEQMODE; 03751750
L:=LASTMKS; T:=SP[LOC]; % T IS PROGRAM MARK STACK 03751800
CINDEX:=T.CIF; % CONTROL INDEX IN POLISH 03751900
IF L:=T.SPF =0 THEN %PHONEY PROG DESC FROM FUNCTION CALL 03752000
N:=POLTOP:=POLLOC:=0 ELSE 03752010
BEGIN 03752020
N:=POLLOC:=SP[LOC].SPF; 03752030
POLTOP:=SP[NOC] 03752040
END; 03752050
IF ERR = 0 THEN % POP WORKED 03752100
IF INPUTIMS=2 THEN BEGIN JUMP:=TRUE; GO TO EVALQ END ELSE 03752110
IF INPUTIMS=1 THEN BEGIN JUMP:=TRUE; GO TO EVALQQ; END ELSE 03752120
DO BEGIN COMMENT EXECUTE UNTIL DONE OR TIME-OUT; 03752200
IF CINDEX LSS POLTOP THEN %MORE TO EXECUTE IN POLISH 03752300
BEGIN COMMENT GET NEXT POLISH TO EXECUTE; 03752400
M:=(CINDEX:=CINDEX+1)+POLLOC; 03752500
POLWORD:=T:=SP[MOC]; 03752600
CASE T.TYPEFIELD OF 03752700
BEGIN %-------TF=0 (REPLACEMENT)-------------- 03752800
BEGIN %MAY BE A LOCAL OR A GLOBAL VARIABLE 03752900
DEFINE STARTSEGMENT=#; %///////////////////// 03752905
PUSH; IF ERR NEQ 0 THEN GO TO SKIPPOP; 03752910
N:=T.LOCFIELD; 03752912
IF BOOLEAN(T.OPTYPE) THEN %A LOCAL VARIABLE 03752915
BEGIN M:=FUNCLOC;%FIND LAST FMKS 03752916
M:=SP[MOC].SPF+M; 03752917
N:=SP[MOC].LOCFIELD+N; END; 03752918
U:=SP[NOC]; U.LOCFIELD:=N; AREG:=U; 03752920
IF U.DATADESC=0 THEN ERR:=NONCEERROR; 03752922
COMMENT PROBABLY MIXUP WITH FUNCTION NAMES 03752924
AND NAMES OF LOCAL SUSPENDED VARIABLES; 03752926
END; 03752930
%-------------FUNCTION CALL---------------- 03752950
%&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 03752960
BEGIN COMMENT SET UP STACK FOR A FUNCTION CALL; 03752970
REAL U,V,NARGS,D; 03752980
INTEGER I,FLOC; 03752982
LABEL TERMINATE; 03752990
COMMENT 03752991
MONITOR PRINT(D,L,M,N,FLOC,SP,LASTMKS);%::::::::::::::::::: 03752992
FLOC:=N:=T.LOCFIELD; 03753000
IF BOOLEAN(SP[NOC].DATADESC) THEN BEGIN ERR:=NONCEERROR; 03753005
GO TO TERMINATE;END;%SUSPENDED VAR CONFUSED WITH FUNCTION 03753007
IF NOT BOOLEAN(SP[NOC].PRESENCE) THEN MAKEFUNCTIONPRESENT(N); 03753010
D:=SP[NOC]; L:=LASTMKS; %D IS THE DESC, L IS THE PROG MKS 03753020
SP[LOC].CIF:=CINDEX; %SAVE CURRENT POLISH LOCATION 03753022
L:=STACKBASE+1; L:=SP[LOC].SPF+1; 03753030
M:=SP[LOC].SPF; 03753035
IF N:=M+L NEQ L THEN %THERE IS A NESTED CALL 03753040
IF NOT BOOLEAN(SP[NOC].SUSPENDED) THEN 03753045
BEGIN N:=SP[NOC].LOCFIELD;SP[NOC].CIF:=CURLINE;END; 03753050
03753060
03753070
SETFIELD(GTA,0,8,0); SETFIELD(GTA,8,8,0); %INITIALIZE GTA 03753080
NARGS:=D.NUMBERARGS; 03753090
FOR I:=1 STEP 1 UNTIL NARGS DO 03753100
IF BOOLEAN((T:=AREG).DATADESC) THEN 03753110
BEGIN 03753120
IF BOOLEAN(T.NAMED) THEN %MAKE A COPY 03753130
COMMENT YOU COULD MAKE A CALL BY NAME HERE; 03753140
BEGIN U:=GETSPACE(V:=(NUMELEMENTS(T)+T.RF)); 03753150
SPCOPY(T.SPF,U,V); T.NAMED:=0; T.SPF:=U; 03753160
T.BACKP:=0; 03753165
END ELSE %NO NEED TO MAKE A COPY 03753170
AREG.PRESENCE:=0; 03753180
POP; GTA[I-1]:=T; %SAVE THE DESCRIPTOR FOR LATER USE 03753190
END ELSE ERR:=SYSTEMERROR; 03753200
IF (N:=M+1) GEQ STATEVECTORSIZE THEN ERR:=DEPTHERROR; 03753205
IF ERR NEQ 0 THEN GO TO TERMINATE; 03753210
SP[LOC].SPF:=N; 03753211
PUSH;AREG:=OLDDATA&(LASTMKS-STACKBASE)[BACKPT]&IMKS[CDID]; 03753212
OLDDATA:=0; %REINITIALIZE OLDDATA CHAIN FOR THIS FUNCTION 03753214
%NOW SET UP THE FUNCTION MARK STACK. 03753220
03753221
M:=N+L;PUSH;SP[MOC]:=D.SPF&ST[CLOCF]; 03753222
M:=D.SPF; M:=M+2; % M IS LOC OF LOC OF FIRST LINE 03753230
AREG:=0&FLOC[CSPF]&((LASTMKS:=ST)-STACKBASE-1)[BACKPT]& 03753240
(U:=SP[MOC]-D.SPF)[CCIF]&FMKS[CDID]; % FUNCTION MKS 03753242
CURLINE:=U; 03753244
03753250
U:=(U-6)/2; % U IS THE NUMBER OF LOCALS, LABELS, AND ARGS 03753260
M:=M+5; % M IS ON THE FIRST DESC OF THE FIRST LAB, LOC,... 03753270
FOR I:=1 STEP 1 UNTIL U DO % GET DESCRIPTORS INTO THE STACK 03753280
BEGIN IF SP[MOC] NEQ 0 THEN %MAKE UP THE DESC 03753290
BEGIN L:=GETSPACE(1); SP[LOC]:=SP[MOC]; 03753300
T:=L&DDPUSW[CDID]&0[CCIF] 03753310
END ELSE 03753320
T:=NULLV; 03753330
PUSH; M:=M+2; 03753340
AREG:=T; %A SINGLE LOCAL 03753350
END; 03753360
%COPY OVER THE ARGUMENTS 03753370
FOR I:=1 STEP 1 UNTIL NARGS DO %COPY OVER 03753390
BEGIN M:=D.SPF; %M IS THE LOCATION OF THE LABEL TABLE. 03753400
M:=M+2+I; %M IS LOCATION OF REL LOCATION OF VARIABLE 03753410
M:=SP[MOC]; 03753420
N:=LASTMKS+M; 03753430
SP[NOC]:=GTA[I-1] 03753440
END; 03753450
%PUT IN A PHONEY PROG DESC TO START THINGS OFF 03753460
PUSH; IF ERR NEQ 0 THEN GO TO TERMINATE; 03753470
AREG:=0&4094[CCIF]&(LASTMKS-STACKBASE)[BACKPT]; 03753480
LASTMKS:=ST; POLTOP:=POLLOC:=0; 03753490
TERMINATE: 03753500
END; 03753510
%&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 03753520
%-------END OF LOAD FUNCTION FOR CALL----- 03753900
%-------------TF=2 (CONSTANT)--------------------- 03754000
BEGIN PUSH; IF ERR=0 THEN BEGIN 03754100
N:=POLWORD.LOCFIELD;AREG:=SP[NOC];END; 03754110
END; 03754120
%-------------TF=3 (OPERATOR)----------------- 03755000
COMMENT SEQUENCE NUMBERS CORRESPOND TO OPERATOR 03755100
ASSIGNMENT NUMBER; 03755200
BEGIN IF T.OPTYPE=MONADIC THEN 03755210
BEGIN PUSH;IF ERR=0 THEN AREG:=0; END; 03755220
CASE T.LOCFIELD OF 03755300
BEGIN %--------------- OPERATE ON STACK---------------------- 03755400
COMMENT EACH EXECUTION PROCEDURE SETS RESULT TO THE 03755500
DESCRIPTOR OF THE RESULT OF THE OPERATION. 03755510
AREG AND BREG ARE THE LEFT AND RIGHT-HAND OPERANDS AND 03755520
ARE ACTUALLY THE TOP TWO DESCRIPTORS ON THE STACK. 03755530
IF AREG IS ZERO, THE OPERATOR IS TAKEN TO BE MONADIC.; 03755540
; 03800000
; 03801000
; 03802000
; 03803000
%-------------------- REPLACEMENT OPERATOR--------------- 03804000
BEGIN DEFINE STARTSEGMENT=#; %/////////////////////////////// 03804100
IF NOT BOOLEAN(L:=AREG.NAMED) THEN % SHOULD BE LOCAL VARIABLE 03804110
AREG.NAMED:=1; % DONT LET IT BE FORGOTTEN. 03804120
03804130
IF BOOLEAN((T:=AREG).PRESENCE) AND T.SPF NEQ 0 THEN 03804200
OLDDATA:=CHAIN(T,OLDDATA); 03804210
M:=T.LOCFIELD; 03804300
03804310
IF(RESULT:=BREG).SPF = 0 THEN U:=T:=0 ELSE 03804320
U:=GETSPACE(T:=NUMELEMENTS(RESULT)+RESULT.RF); 03804400
SPCOPY(RESULT.SPF,U,T); 03804500
RESULT.SPF:=U; RESULT.NAMED:=L; %L IS 0 FOR LOCALS 03804510
GT1:=IF BOOLEAN((U:=SP[MOC]).PRESENCE) THEN U.BACKP ELSE 0; 03804515
SP[MOC]:=RESULT&GT1[CLOCF]; 03804520
IF BOOLEAN(L) AND GT1=0 THEN %CHECK FOR GLOBAL 03804600
BEGIN M:=M-1;IF(SP[MOC].SUSPENDVAR=0)THEN SP[MOC].CHANGE:=1; 03804610
03804620
END; 03804630
RESULT.NAMED:=1; %KEEP "PUSH" FROM TOSSING THE DATA 03804640
END; 03804700
%-------TRANSFER OPERATOR----------------------------- 03805000
BEGIN DEFINE STARTSEGMENT=#; %/////////////////////////////// 03805100
SCRATCHAIN(OLDDATA);OLDDATA:=0; 03805110
IF BOOLEAN(T.OPTYPE) THEN ST:=ST-1; %GET RID OF PHONEY TOP 03805200
L:=FUNCLOC; 03805210
IF SP[LOC] NEQ 0 THEN STEPLINE(TRUE) ELSE 03805300
ERR:=SYNTAXERROR; 03805400
GO TO SKIPPOP; 03805500
END; 03805600
BEGIN %--------------COMPRESSION------------------------------------03806000
DEFINE STARTSEGMENT=#; %///////////////////////////////////// 03806005
L:=ST-2; IF T.OPTYPE=MONADIC THEN COMPRESS(BREG,SP[LOC],AREG) 03806010
ELSE COMPRESS(AREG,SP[LOC],BREG); COMMENT A/B HAS BEEN 03806020
STACKED AS B,A,NULL...A/[I] B HAS BEEN STACKED AS B,I,A; 03806030
END; 03806040
ARITH(3); %OPERATION IS DIVIDE 03807000
; 03807999
; 03809000
%-------------QUAD INPUT------------------------------- 03810000
EVALQ: BEGIN LABEL EVALQUAD; 03810010
IF JUMP THEN BEGIN JUMP:=FALSE; GO TO EVALQUAD END; 03810015
CURRENTMODE:=INPUTMODE; 03810018
FORMWD(3,"3[]: "); INDENT(0); 03810020
03810030
IMS(2); % SETUP MARKSTACK FOR QUAD EXIT 03810040
IF ERR NEQ 0 THEN GO TO SKIPPOP; 03810050
GO TO EXECEXIT; % EXIT TO MONITOR TILL INPUT IS COMPLETE 03810080
EVALQUAD: %LOOK AT BUFFER TO SEE WHAT CAME IN 03810100
BEGIN 03810110
IF NOT SCAN THEN BEGIN CINDEX:=CINDEX-1;GO TO SKIPPOP;END; 03810112
IF NOT SETUPLINE THEN CINDEX:=CINDEX-1;%MAKE THEM REDO IT 03810120
GO TO SKIPPOP; 03810200
END; 03810210
END; 03810500
BEGIN % -----EVALUATE SUBSCRIPTS--------------- 03811000
DEFINE STARTSEGMENT=#; %///////////////////////////////////// 03811002
T:=AREG; L:=BREG.SPF; 03811010
IF BOOLEAN(T.SCALAR) THEN BEGIN ERR:=DOMAINERROR;GO TO SKIPPOP;END; 03811011
U:=SP[LOC]; % GET # OF SUBSCRIPTS 03811012
IF U GTR 32 THEN ERR:=INDEXERROR ELSE 03811014
BEGIN 03811015
IF U GTR 0 THEN BEGIN 03811017
IF T.PRESENCE NEQ 1 THEN % GET ARRAY INTO SP 03811020
BEGIN N:=T.LOCFIELD; 03811030
IF (T:=SP[NOC]).PRESENCE NEQ 1 THEN 03811040
BEGIN T:=GETARRAY(T); SP[NOC]:=T END; 03811050
T.LOCFIELD:= N; 03811052
END; 03811060
IF ERR=0 THEN % NOW EVALUATE 03811070
03811080
RESULT:=SUBSCRIPTS(L:=(IF T.LOCFIELD=0 THEN OUTOF 03811090
ELSE INTO),T,U); 03811100
IF L=INTO THEN BEGIN 03811101
03811102
CINDEX:=CINDEX+1;END; % SKIP OVER REPLACE OP 03811103
END ELSE % NO SUBSCRIPTS 03811104
BEGIN BREG:=T; ST:= ST-1; GO TO SKIPPOP; 03811106
END; % DON{T LET THE DESC. IN T BE POPPED. 03811108
U:=U+2; % # OF THINGS TO POP 03811110
FOR N:=1 STEP 1 UNTIL U DO POP; 03811114
IF L=OUTOF THEN PUSH; AREG:=RESULT; 03811116
03811120
GO TO SKIPPOP; 03811130
END; 03811140
END; 03811200
; 03812000
; 03813000
%-------------QQUAD INPUT------------------------------ 03814000
EVALQQ: BEGIN LABEL EVALQQUAD; 03814010
IF JUMP THEN BEGIN JUMP:=FALSE; GO TO EVALQQUAD END; 03814015
CURRENTMODE:=INPUTMODE; 03814020
IMS(1); % SETUP MARKSTACKS FOR QQUAD EXIT 03814030
IF ERR NEQ 0 THEN GO TO SKIPPOP; 03814040
GO TO EXECEXIT; 03814080
EVALQQUAD: % BUFFER CONTAINS THE INPUT STRING 03814100
IF (L:=LENGTH(BUFFER,TRUE))NEQ 0 THEN BEGIN %L IS # CHAR INPUT 03814110
N:=ENTIER((L+7) DIV 8); % FIND NUMBER OF WORDS 03814120
M:=GETSPACE(N+1); % GET SPACE FOR THE VECTOR IN SP 03814130
TRANSFERSP(INTO,SP,M+1,BUFFER,0,N); 03814140
SP[MOC]:=L; % STORE LENGTH OF VECTOR 03814150
RESULT:=M&1[CRF]&DDPUVC[CDID]; % SET UP DESCRIPTOR 03814160
END ELSE RESULT:=NULLV;% NOTHING WAS INPUT 03814162
PUSH; IF ERR=0 THEN AREG:=RESULT; 03814170
GO TO SKIPPOP; 03814180
END; 03814500
RESULTD := SEMICOL; %CONVERSION CONCATENATION 03815000
COMMAP; %CATENATE 03816000
BEGIN%----------INNER PRODUCT (PERIOD)--------------------- 03817000
M:=(CINDEX:=CINDEX+2) + POLLOC; T:=SP[MOC];M:=M-1;U:=SP[MOC]; 03817100
PERIOD(AREG,BREG,U.LOCFIELD,T.LOCFIELD); 03817200
END; 03817300
ARITH(4); %* 03818000
; 03819000
; 03820000
ARITH(17); %AND 03821000
ARITH(18); %OR 03822000
ARITH(9); %NOT 03823000
ARITH(11); %LESS:THAN 03824000
ARITH(16); %LEQ 03825000
ARITH(12); %= 03826000
ARITH(13); %GEQ 03827000
ARITH(14); %GREATER-THAN 03828000
ARITH(15); %NEQ 03829000
ARITH(8); %MAX/CEIL 03830000
ARITH(7); %MIN/FLOOR 03831000
ARITH(6); %RESD/ABS 03832000
IF T.OPTYPE=MONADIC THEN GO TO XEQEPS ELSE MEMBER; %MEMBERSHIP 03833000
RHOP; %RHO 03834000
IOTAP; %IOTA 03835000
; 03836000
REDUCESORTSCAN(0,BREG,AREG,4); %REVERSAL; 03837000
BEGIN %-----------EXPANSION-------------------------- 03838000
DEFINE STARTSEGMENT=#; %//////////////////////////////////// 03838005
L:=ST-2; IF T.OPTYPE=MONADIC THEN EXPAND(BREG,SP[LOC],AREG) 03838010
ELSE EXPAND(AREG,SP[LOC],BREG); COMMENT A EXPN B HAS BEEN 03838020
STACKED AS B,A,NULL WHILE A EXPN [I] B IS STACKED AS B,I,A; 03838030
END; 03838040
RESULTD:=BASEVALUE; %BASE VALUE 03839000
ARITH(10); %COMB/FACT 03840000
; 03841000
IF T.OPTYPE=MONADIC THEN ARITH(5) ELSE 03842000
DYADICRNDM; %RNDM 03842100
IF T.OPTYPE=MONADIC THEN TRANSPOSE ELSE DYADICTRANS;%GUESS WHAT 03843000
RESULTD := REPRESENT; %REPRESENTATION 03844000
ARITH(45); %CIRCLE--TRIGONOMETRIC FUNCTIONS 03845000
; 03846000
; 03847000
ARITH(0); %ADD 03848000
ARITH(2); %SUBTRACT 03849000
ARITH(1); %MULTIPLY 03850000
%-------------------DISPLAY------------------------------------- 03851000
03851100
BEGIN DEFINE STARTSEGMENT=#; %/////////////////////////////// 03851110
IF BREG.SPF=0 THEN FORMROW(3,0,ACCUM,2,0) ELSE %FOR A NULL 03851115
IF BOOLEAN((RESULT:=BREG).DATADESC)THEN %THIS IS A DATA DESC 03851120
IF BOOLEAN(RESULT.PRESENCE) AND M:=RESULT.SPF NEQ 0 THEN 03851140
IF BOOLEAN(RESULT.SCALAR) THEN 03851160
BEGIN NUMBERCON(SP[MOC],ACCUM); 03851180
FORMROW(3,0,ACCUM,2,ACOUNT) 03851200
END 03851220
ELSE %A VECTOR 03851240
IF L:=RESULT.RF NEQ 0 THEN % SOMETHING TO PRINT 03851260
IF BOOLEAN(RESULT.CHRMODE) THEN DISPLAYCHARV(RESULT) 03851300
ELSE 03851310
BEGIN RESULT:=M:=GETSPACE(L+1); 03851400
SP[MOC]:=L; RESULT.RF:=1; RESULT.DID:=DDPUVW; 03851500
AREG:=RESULT; 03851600
FOR T:=1 STEP 1 UNTIL L DO 03851610
BEGIN M:=M+1; SP[MOC]:=1 03851620
END; 03851630
DISPLAY(AREG,BREG); 03851700
RESULT:=BREG; 03851720
END ELSE TERPRINT 03851760
ELSE TERPRINT 03851780
ELSE ; %PROBABLY A FUNCTION....DONT DO ANYTHING 03851880
IF BREAKFLAG THEN %USER HIT BREAK DURING OUTPUT 03851890
GO TO BREAKKEY; 03851892
POP; GO TO SKIPPOP; 03851894
END; 03851896
BEGIN % ---------------REDUCTION------------------------------------03852000
M:=(CINDEX:= CINDEX+1) + POLLOC; % FIND OPERATION IN POLISH 03852020
IF (T:=SP[MOC]).TYPEFIELD NEQ 3 THEN ERR:=SYSTEMERROR 03852040
ELSE REDUCESORTSCAN(T.LOCFIELD,BREG,AREG,1); 03852060
END; 03852080
BEGIN %--------ROTATION---------------------------- 03853000
DEFINE STARTSEGMENT=#; %//////////////////////////////////// 03853005
L:=ST-2; IF T.OPTYPE=MONADIC THEN 03853010
REDUCESORTSCAN(BREG,SP[LOC],AREG,5) ELSE 03853015
REDUCESORTSCAN(AREG,SP[LOC],BREG,5); COMMENT A ROT B IS 03853020
STACKED AS B,A,NULL WHILE A ROT [I] B IS STACKED AS B,I,A; 03853030
END; 03853040
ARITH(21); %LOG 03854000
REDUCESORTSCAN(0,BREG,AREG,2); % SORTUP 03855000
REDUCESORTSCAN(-1,BREG,AREG,2); %SORTDN 03856000
BEGIN %-------------SCAN-------LIKE REDUCTION--------------- 03857000
DEFINE STARTSEGMENT=#; %///////////////////////////////////// 03857010
M:=(CINDEX:=CINDEX+1) + POLLOC; %FIND OPERATOR IN POLISH 03857020
IF (T:=SP[MOC]).TYPEFIELD NEQ 3 THEN ERR:=SYSTEMERROR 03857040
ELSE REDUCESORTSCAN(T.LOCFIELD,BREG,AREG,3); 03857060
END; 03857080
ARITH(19); %NAND 03858000
ARITH(20); %NOR 03859000
IF (T:=BREG).RF NEQ 0 THEN RESULT:=SUBSCRIPTS(2,T,T.RF) 03860000
ELSE ERR:=RANKERROR; % OPERATION IS TAKE 03860010
IF (T:=BREG).RF NEQ 0 THEN RESULT:=SUBSCRIPTS(3,T,T.RF) 03861000
ELSE ERR:=RANKERROR; % OPERATION IS DROP 03861010
%-----------------------XEQ----------------------------------- 03862000
XEQEPS: BEGIN DEFINE STARTSEGMENT=#; %///////////////// 03862005
IF AREG NEQ 0 THEN ERR:=SYNTAXERROR %MUST BE MONADIC ONLY 03862010
ELSE IF (T:=BREG).RF NEQ 1 OR %MUST BE A VECTOR 03862020
NOT BOOLEAN(T.CHRMODE) THEN ERR:=DOMAINERROR %MUST BE CHAR STRING 03862030
ELSE IF U:=NUMELEMENTS(T) GTR MAXBUFFSIZE THEN ERR:=LENGTHERROR 03862032
ELSE BEGIN 03862040
M:=GT1; % # OF CHARACTERS SET BY NUMELEMENTS 03862042
INITBUFF(BUFFER,MAXBUFFSIZE);RESCANLINE; 03862048
TRANSFERSP(OUTOF,SP,T.SPF+1,BUFFER,0,U); 03862050
IF(U:=U|8-M) GTR 0 THEN SETFIELD(BUFFER,M,U," "); 03862052
IF T.SPF=0 OR NOT SCAN THEN RESULT:=0&1[CRF]&DDPUVW[CDID]% NULL 03862060
ELSE BEGIN POP;IF SETUPLINE THEN; GO TO SKIPPOP;END 03862070
END; END; 03862080
END; %--------------END OF OPERATION ON STACK-------------------- 03869960
POP;POP;PUSH;IF ERR=0 THEN AREG:=RESULT; 03869970
SKIPPOP: END OF TYPEFIELD EQUALS OPERATOR; 03869980
%-------TF=4 (LOCAL VARIABLE)------------ 03870000
BEGIN COMMENT MOVE DESCRIPTOR UP TO TOP; 03870100
DEFINE STARTSEGMENT=#; %///////////////// 03870110
N:=T.LOCFIELD;M:=FUNCLOC;M:=SP[MOC]+M; 03870200
03870210
N:=SP[MOC].LOCFIELD+N; 03870220
T:=SP[NOC]; T.NAMED:=1; %KEEP FROM THROWING AWAY 03870300
PUSH; AREG:=T; 03870400
END; 03870500
%-------TF=5 (OPERAND)----------------------- 03872000
BEGIN PUSH; IF ERR=0 THEN BEGIN 03872100
N:=POLWORD.LOCFIELD; U:=SP[NOC]; 03872200
IF U.DATADESC=0 THEN ERR:=NONCEERROR ELSE 03872210
IF U.PRESENCE NEQ 1 THEN BEGIN 03872300
U:=GETARRAY(U); SP[NOC]:=U END; 03872400
U.LOCFIELD:=0; 03872410
AREG:=U; END; 03872500
END; 03872600
END; % OF CASE STMT TESTING TYPEFIELD 03900000
END % OF TEST FOR CINDEX LEQ POLTOP 03901000
ELSE % WE ARE AT THE END OF THE POLISH 03902000
BEGIN COMMENT LASTMKS CONTAINS THE LOCATION 03903000
OF THE LAST MARK STACK. GET MARK STACK AND CONTINUE; 03904000
03905000
SCRATCHAIN(OLDDATA); OLDDATA:=0; 03905010
L:=LASTMKS;M:=(U:=SP[LOC]).BACKF+STACKBASE;T:=SP[MOC]; 03905020
IF T.DID=IMKS AND T.QUADIN=3 THEN %SINGLE LINE DONE 03905030
IF(RESULT:=AREG)=T THEN ERR:=SYNTAXERROR%NO RESULT 03905035
ELSE BEGIN RESULT.NAMED:=0;%MAKE NEW COPY 03905040
IF BOOLEAN(RESULT.SCALAR) THEN 03905042
BEGIN M:=GETSPACE(2);L:=RESULT.SPF; 03905044
RESULT.SPF:=M+1;SP[MOC]:=RESULT; 03905046
M:=M+1;SP[MOC]:=SP[LOC]; 03905048
END ELSE % MAKE COPY OF A VECTOR 03905050
BEGIN M:=GETSPACE(1+(N:=RESULT.RF+NUMELEMENTS( 03905052
RESULT))); 03905053
L:=RESULT.SPF;RESULT.SPF:=M+1; 03905054
SP[MOC]:=RESULT; SPCOPY(L,M+1,N);END; 03905056
03905058
03905060
FORGETPROGRAM(U); 03905070
03905080
DO POP UNTIL ST LSS LASTMKS;%CUT BACK STACK TO IMS 03905082
OLDDATA:=T.SPF;L:=LASTMKS:=T.BACKF+STACKBASE; 03905084
AREG:=RESULT; % STORE EXECUTION RESULT OVER IMS 03905086
CINDEX:=SP[LOC].CIF; M:= SP[LOC].SPF; 03905088
POLLOC:=M:=SP[MOC].SPF; POLTOP:=SP[MOC]; 03905090
END ELSE 03905095
BEGIN L:=FUNCLOC;M:=SP[LOC].SPF+L; 03905100
IF M NEQ L AND NOT BOOLEAN(SP[MOC].SUSPENDED)THEN 03905200
BEGIN 03905203
IF 0=(LOOP:=(LOOP+1) MOD 5) THEN 03905205
WRITE(TWXOUT,1,JIGGLE[*])[BREAKKEY:BREAKKEY]; 03905206
%THAT WAS TO CHECK FOR BREAK TO INTERRUPT A PROG 03905207
STEPLINE(FALSE) 03905210
END 03905215
ELSE BEGIN XIT:=TRUE;CURRENTMODE:=CALCMODE; 03905300
WHILE POPPROGRAM(OLDDATA,LASTMKS) DO; 03905310
END; 03905400
END; 03905600
END; %COMPLETION OF ONE POLISH EVALUATION (1 CELL) 03910000
IF ERR NEQ 0 THEN % PUT OUT ERROR MESSAGE 03918100
BEGIN 03918200
DEFINE STARTSEGMENT=#; %///////////////////////////// 03918201
COMMENT 03918209
MONITOR PRINT(ST,L,M,SP,GTA,T);%:::::::::::::::::::::: 03918210
XIT:=TRUE;CURRENTMODE:=ERRORMODE; 03918220
03918250
L:=POLLOC+1; 03918300
TRANSFERSP(OUTOF,SP,(L:=SP[LOC].SPF)+1,BUFFER, 03918400
0,MIN(MAXBUFFSIZE,ENTIER((SP[LOC]+7)DIV 8))); 03918450
L:=FUNCLOC;M:=SP[LOC].SPF+L; 03918455
GT1:=1;N:=SP[MOC].LOCFIELD;%LOCATION OF FMKS 03918456
WHILE LASTMKS GTR N AND BOOLEAN (GT1) DO GT1:=IF 03918458
POPPROGRAM(OLDDATA,LASTMKS)THEN 1 ELSE 0; 03918459
IF M NEQ L AND NOT BOOLEAN(SP[MOC].SUSPENDED)THEN%GET LINE# 03918460
BEGIN SP[LOC].RF:=SP[LOC].RF+1;%UP SUSPENDED COUNT 03918462
L:=SP[NOC].SPF-1;%LOCATION OF FUNCTION NAME 03918464
SETFIELD(GTA,0,1,0); 03918465
GTA[0]:=SP[LOC]; 03918467
FORMROW(3,0,GTA,1,7); 03918470
L:=SP[MOC].SPF; %BASE OF LABEL TABLE 03918475
L:=L+CURLINE; 03918480
T:=SP[LOC]; 03918485
03918486
%ALSO PUT THE FUNCTION INTO SUSPENSION 03918487
IMS(4);SP[MOC].SUSPENDED:=1;SUSPENSION:=1; 03918488
PUSHINTOSYMTAB(SP[MOC]); 03918489
END ELSE T:=0; 03918490
ERRORMESS(ERR,POLWORD.SPF,T); 03918500
END; 03918600
END UNTIL XIT; 03919000
BREAKKEY: BEGIN BREAKFLAG:=FALSE; 03919800
XIT:=TRUE;CURRENTMODE:=CALCMODE; 03919810
L:=FUNCLOC;M:=SP[LOC].SPF+L; 03919820
IF M NEQ L AND NOT BOOLEAN(SP[MOC].SUSPENDED) THEN 03919830
BEGIN SP[MOC].SUSPENDED:=1;SUSPENSION:=1; 03919840
PUSHINTOSYMTAB(SP[MOC]);SP[LOC].RF:=SP[LOC].RF+1; 03919850
M:=SP[MOC].LOCFIELD;%LOCATION OF FMKS IN STACK 03919860
WHILE LASTMKS GTR M DO IF POPPROGRAM(OLDDATA,LASTMKS) 03919870
THEN; LASTMKS:=M;IMS(4); 03919880
END 03919890
IF FALSE THEN 03919899
END; 03919900
EXECEXIT: 03919990
IF STACKBASE NEQ 0 THEN BEGIN 03919992
L:=STACKBASE; SP[LOC]:=ST-L; %UPDATE SIZE OF STACK 03920000
03920100
END; 03920200
END OF EXECUTION LOOP; 03950000
PROCESSEXIT: 03950090
IF BOOLEAN(POLBUG) THEN % DUMP SP 03950100
IF MODE=XEQUTE OR MODE=3 OR MODE=6 THEN GO TO DEBUGSP; 03950200
IF FALSE THEN 03951000
BEGIN CASE 0 OF BEGIN 03951100
EXPOVRL: SPOUT(3951200); 03951200
INTOVRL: SPOUT(3951300); 03951300
INDEXL: SPOUT(3951400); 03951400
FLAGL: SPOUT(3951500); 03951500
ZEROL: SPOUT(3951600); 03951600
END; 03951700
REALLYERROR:=1; 03951702
DEBUGSP: 03951710
WRITE(PRINT,MIN(15,PSRSIZE),PSR); 03951720
BEGIN 03951800
STREAM PROCEDURE FORM(A,B,N); VALUE N; 03951900
BEGIN 03952000
DI:=B; 15(DS:=8LIT" "); 03952100
SI:=LOC N; DI:=B; DS:=8DEC; DI:=DI+3; 03952200
SI:=A; 10(DS:=8CHR; DI:=DI+1); 03952300
END; 03952400
M:=MIN((NROWS+1)|SPRSIZE-1,MAXMEMACCESSES); 03952500
FOR N:=0 STEP 10 UNTIL M DO 03952650
BEGIN TRANSFERSP(OUTOF,SP,N,ACCUM,0,MIN(M-N,10)); 03952700
FORM(ACCUM,BUFFER,N); 03952800
WRITE(PRINT,15,BUFFER[*]); 03952900
END; 03953000
END; 03953100
IF POLBUG=0 OR BOOLEAN(REALLYERROR) THEN 03953110
BEGIN 03953120
ERRORMESS(IF ERR NEQ SPERROR THEN SYSTEMERROR ELSE ERR,0,0); 03953200
SUSPENSION:=0; 03953210
CURRENTMODE:=CALCMODE; 03953300
REALLYERROR:=ERR:=0; 03953301
END; 03953310
END; 03953400
END OF PROCESS PROCEDURE; 03960000
PROCEDURE ERRORMESS(N,ADDR,R); VALUE N,ADDR,R; REAL R; 05000000
INTEGER N; REAL ADDR; 05000100
BEGIN 05000200
INTEGER STREAM PROCEDURE FORM(A,B); VALUE A; 05000300
BEGIN LOCAL T,U; 05000400
LABEL L,M; 05000500
SI:=A; 05000600
L: IF SC=" " THEN 05000700
BEGIN SI:=SI+1; GO TO L; 05000800
END; 05000900
DI:=LOC T; DS:=2RESET; DS:=2SET; 05001000
DI:=B; MESSIZE(U:=DI; DI:=LOC T; IF SC=DC THEN JUMP OUT TO M; 05001100
SI:=SI-1; DI:=U; DS:=CHR; TALLY:=TALLY+1); M: 05001200
FORM:=TALLY; 05001300
END; 05001400
ARRAY ERMES[0:13],B[0:MESSIZE/8]; 05001410
FILL ERMES[*] WITH 05001500
"1 ", 05001510
"5DEPTH ", 05001520
"6DOMAIN ", 05001530
"7EDITING", 05001540
"5INDEX ", 05001600
"5LABEL ", 05001610
"6LENGTH ", 05001620
"5NONCE ", 05001700
"4RANK ", 05001710
"6SYNTAX ", 05001720
"6SYSTEM ", 05001800
"5VALUE ", 05001810
"7SP FULL", 05001820
"7FLYKITE"; 05001830
IF R NEQ 0 THEN 05001900
BEGIN INDENT(R);CHRCOUNT:=CHRCOUNT-1 05001910
END; 05002000
FORMROW((IF R=0 THEN 2 ELSE 0),0,ERMES,N|8+1, 05002010
ERMES[N].[1:5]); 05002100
FORMWD(0,"6 ERROR"); 05002110
IF ADDR.[33:15] GEQ 512 THEN 05002120
BEGIN 05002130
FORMWD(0,"4 AT "); 05002200
FORMROW(1,1,B,0,FORM(ADDR,B)) 05002210
END; 05002220
FORMWD(3,"1 "); 05002300
END; 05002310
PROCEDURE LOADWORKSPACE(JOBNUM,NAME,IDENT); VALUE JOBNUM,NAME; 05002400
REAL JOBNUM,NAME; ARRAY IDENT[0]; FORWARD; 05002410
PROCEDURE LOGINAPLUSER; 07001000
BEGIN 07002000
COMMENT LOG:IN THE CURRENT USER; 07003000
COMMENT INPUT LINE IS IS THE BUFFER; 07004000
LABEL EXEC, GUESS; 07004100
DEFINE T=GT1#, J=GT2#,I=GT3#; 07005000
PROCEDURE INITIALIZEPSR; 07005010
BEGIN FOR I:=0 STEP 1 UNTIL PSRSIZE-1 DO 07005015
PSRM[I] := 0; 07005020
SEED:=STREAMBASE; ORIGIN:=1; 07005025
FUZZ:=1@-11; 07005030
LINESIZE:=72; DIGITS:=9; 07005035
END; 07005040
LADDRESS := ADDRESS := ABSOLUTEADDRESS; 07006000
WORKSPACE:=WORKSPACEUNIT; 07007000
ITEMCOUNT := EOB := 0; 07008000
IF NEXTUNIT=WORKSPACEUNIT THEN % ESTABLISH A WORKSPACE 07019000
BEGIN 07020000
WORKSPACE:=NEXTUNIT; 07021000
SEQUENTIAL(WORKSPACE); 07022000
INITIALIZEPSR; 07023000
I:=STORESEQ(WORKSPACE,PSR,PSRSIZE|8); 07025000
INITBUFF(OLDBUFFER,BUFFSIZE); 07028000
07029000
END ELSE % WORKSPACE ASSIGNED 07030000
I:=CONTENTS(WORKSPACE,0,PSR); 07031000
FILL ACCUM[*] WITH "LOGGED I","N "; 07032000
FORMROW(0,1,ACCUM,0,9); 07033000
I:=DAYTIME(ACCUM); 07034000
FORMROW(1,1,ACCUM,0,I); 07035000
SYMBASE:=STACKBASE:=0; 07035900
CSTATION.APLOGGED:=1; 07036000
CASE CURRENTMODE OF 07036010
BEGIN %--------CALCMODE-------------- 07036020
;COMMENT NOTHING TO DO ANYMORE; 07036030
%--------------XEQUTEMODE------------ 07036040
EXEC: 07036042
BEGIN FILL ACCUM[*] WITH "LAST RUN"," STOPPED"; 07036050
FORMROW(3,0,ACCUM,0,16); 07036060
CURRENTMODE:=CALCMODE; 07036070
END; 07036080
%-------------FUNCMODE----------------- 07036090
BEGIN FILL ACCUM[*]WITH "CONTINUE"," DEFINIT", 07036100
"ION OF "; 07036110
FORMROW(2,0,ACCUM,0,23); FORMROW(1,0,PSR, 07036120
FSTART|8,7); 07036130
CURLINE:=GT3:=TOPLINE(GT1:=FUNCPOINTER); 07036131
CHECKSEQ(CURLINE,GT3,INCREMENT); %GET INCREMENT 07036132
CURLINE:=CURLINE+INCREMENT; INDENT(-CURLINE); 07036133
FUNCSIZE:=SIZE(GT1); 07036134
END; 07036136
%------------INPUTMODE--------------ERRORMODE---- 07036140
GO TO EXEC; GO TO EXEC; 07036150
END; 07036160
GUESS: %SHOULD BE BETTER PLACE BUT HERE IS WHERE OTHERS COME OUT 07044001
STOREPSR; 07044005
IF CURRENTMODE NEQ FUNCMODE THEN 07044010
INDENT(0); TERPRINT; 07044100
VARSIZE:=IF VARIABLES=0 THEN 0 ELSE SIZE(VARIABLES); 07044200
END; 07045000
PROCEDURE APLMONITOR; 07100000
BEGIN 07101000
REAL T; 07102000
INTEGER I; 07103000
BOOLEAN WORK; 07104000
LABEL AROUND, NEWUSER; 07105000
LABEL CALCULATE,EXECUTEIT,FUNCTIONSTART,BACKAGAIN; 07106000
LABEL CALCULATEDIT; 07107000
I := CUSER := 1; 07107100
T := STATION; 07115000
BEGIN FILL ACCUM[*] WITH "APL/B550","0 UW COM" 07115533
,"PUTER SC","IENCE # ",VERSIONDATE; 07115534
WORK:=TRUE; 07115535
FORMROW(3,MARGINSIZE,ACCUM,0,40); 07115536
INDENT(0); TERPRINT; CSTATION.APLHEADING:=1 07115538
; LOGINAPLUSER; 07115539
END; 07115540
AROUND: 07115542
07115550
BEGIN 07115560
IF MAINTENANCE THEN; 07115570
CASE CURRENTMODE OF 07115600
BEGIN %-------CALCMODE-------------------------------- 07115700
COMMENT HE MUST BE READ READY FOR THE CALCMODE STUFF; 07115800
07115900
GO CALCULATE; 07116000
%--------XEQUTE MODE-------------------------------- 07116100
GO TO EXECUTEIT; 07117000
%----------FUNCMODE----------------------------------- 07117100
GO TO FUNCTIONSTART; 07117400
%----------INPUTMODE---------------------------------- 07117500
COMMENT REQUIRES INPUT; 07117600
07117700
BEGIN COMMENT GET THE LINE AND GO BACK; 07117800
STARTSCAN; 07117900
CURRENTMODE:=XEQMODE; 07118000
GO TO EXECUTEIT; 07118100
END; 07118200
%----------ERRORMODE--------------------------------- 07118300
GO TO BACKAGAIN; 07118400
07118410
END; %OF CASES 07118500
END; 07118510
COMMENT GET HERE IF NOTHING TO DO; 07118600
07118610
GO TO AROUND; 07119000
CALCULATE: 07125000
STARTSCAN; 07126000
CALCULATEDIT: 07126010
ERR:=0; %AND DON"T RESET IT IN SCAN OR IN ANALYZE 07126020
IF SCAN THEN 07126100
IF RGTPAREN THEN MESSAGEHANDLER ELSE 07126200
IF DELV THEN FUNCTIONHANDLER ELSE 07126300
BEGIN COMMENT PROCESS CALCULATOR MODE REQUEST; 07126310
MOVE(BUFFER,BUFFSIZE,OLDBUFFER); 07126320
IF NOT BOOLEAN(SUSPENSION) THEN BEGIN %INITIALIZE USER 07126321
%%% 07126322
%%% 07126323
SYMBASE:=STACKBASE:=0; 07126324
END; 07126326
PROCESS(XEQUTE); 07126330
IF CURRENTMODE=CALCMODE THEN 07126332
BACKAGAIN: BEGIN INDENT(0); TERPRINT; 07126333
IF NOT BOOLEAN(SUSPENSION) THEN 07126334
BEGIN IF CURRENTMODE NEQ ERRORMODE THEN 07126335
PROCESS(WRITEBACK); 07126336
SP[0,0]:=0;NROWS:=-1; 07126337
%%% 07126338
END; 07126340
CURRENTMODE:=CALCMODE; 07126341
END; 07126342
END; 07126350
IF EDITOG=1 THEN 07126360
BEGIN MOVE(OLDBUFFER,BUFFSIZE,BUFFER); 07126370
RESCANLINE; EDITOG:=0; GO TO CALCULATEDIT; 07126380
END; 07126390
I:=0; 07126400
GO AROUND; 07127000
EXECUTEIT: 07128000
PROCESS(XEQUTE); %GO BACK TO PROCESS FOR AWHILE 07129000
IF CURRENTMODE=CALCMODE THEN GO TO BACKAGAIN; 07129010
I:=0; 07129100
GO AROUND; 07130000
FUNCTIONSTART: 07131000
IF SPECMODE = 0 THEN 07131010
BEGIN %SEE IF A SPECIAL FUNCTION. 07131020
STARTSCAN; 07131024
IF SCAN AND RGTPAREN THEN MESSAGEHANDLER ELSE 07131030
FUNCTIONHANDLER 07131040
END ELSE 07131050
FUNCTIONHANDLER; 07131100
I:=0; 07132000
GO AROUND 07133000
END; 07134000
INTEGER PROCEDURE LENGTH(A,M);VALUE M; BOOLEAN M; ARRAY A[0]; 08007900
BEGIN 08007910
INTEGER STREAM PROCEDURE LENGT(A,M,L); VALUE M,L; 08008000
BEGIN LOCAL T; 08008010
LOCAL C,CC,TSI; LABEL LAB; 08008020
LOCAL AR; LABEL LAB2; 08008022
SI:=LOC M; SI:=SI+7; 08008030
IF SC="1" THEN 08008040
BEGIN COMMENT LOOK FOR LEFT ARROW.; 08008050
DI:=LOC AR; DS:=RESET; DS:=5SET; 08008060
SI:=LOC L; DI:=LOC T; DI:=DI+1; DS:=7CHR; 08008070
SI:=A; 08008080
T(2(32(DI:=LOC AR; IF SC=DC THEN JUMP OUT 3 TO LAB; 08008090
TALLY:=TALLY+1; 08008100
C:=TALLY; TSI:=SI; SI:=LOC C; 08008110
SI:=SI+7; IF SC="0" THEN 08008120
BEGIN TALLY:=CC; TALLY:=TALLY+1; CC:=TALLY; 08008130
TALLY:=0; 08008140
END; SI:=TSI))); 08008150
L(DI:=LOC AR; IF SC=DC THEN JUMP OUT TO LAB; 08008160
TALLY:=TALLY+1; C:=TALLY; TSI:=SI; SI:=LOC C; SI:=SI+7; 08008170
IF SC="0" THEN 08008180
BEGIN TALLY:=CC; TALLY:=TALLY+1; CC:=TALLY; TALLY:=0 08008190
END; SI:=TSI); 08008200
LAB: SI:=LOC CC; DI:=LOC LENGT; DI:=DI+6; SI:=SI+7; 08008210
DS:=CHR; SI:=LOC C; SI:=SI+7; DS:=CHR; 08008220
END ELSE 08008230
BEGIN 08008240
SI:=LOC L; DI:=LOC T; DI:=DI+1; DS:=7CHR; 08008250
SI:=A; T(2(SI:=SI+32)); SI:=SI+L; 08008260
T(2(32(SI:=SI-1; IF SC NEQ " " THEN JUMP OUT 3 TO LAB2; 08008270
TALLY:=TALLY+1; C:=TALLY; TSI:=SI; SI:=LOC C; SI:=SI+7; 08008280
IF SC="0" THEN 08008290
BEGIN TALLY:=CC; TALLY:=TALLY+1; CC:=TALLY; TALLY:=0 08008300
END; SI:=TSI))); 08008310
L(SI:=SI-1; IF SC NEQ" " THEN JUMP OUT TO LAB2; 08008320
TALLY:=TALLY+1; C:=TALLY; TSI:=SI; SI:=LOC C; SI:=SI+7; 08008330
IF SC="0" THEN 08008340
BEGIN TALLY:=CC; TALLY:=TALLY+1; CC:=TALLY; TALLY:=0 08008350
END; SI:=TSI); 08008360
LAB2: GO TO LAB 08008370
END 08008380
END; 08008390
INTEGER I; 08008400
I:=LENGT(A,M,BUFFSIZE|8); 08008410
LENGTH:=IF M THEN I ELSE BUFFSIZE|8-I 08008420
END; 08008430
BOOLEAN PROCEDURE LABELSCAN(L,K); VALUE K; INTEGER K; ARRAY L[0]; 08013910
BEGIN REAL T; 08013912
T:=ADDRESS; 08013914
IF SCAN AND IDENT THEN 08013916
BEGIN SETFIELD(ACCUM,1,1,0); TRANSFER(ACCUM,1,L,K|8,8); 08013918
IF NOT(LABELSCAN:=(SCAN AND COLON)) THEN 08013920
BEGIN ADDRESS:=T; EOB:=0; IF SCAN THEN; 08013922
END; 08013923
END 08013924
END; 08013926
STREAM PROCEDURE MOVEWDS(A,N,B); VALUE N; 08013940
BEGIN SI:=A; DI:=B; DS:=N WDS END; 08013942
INTEGER PROCEDURE DAYTIME(B); ARRAY B[0]; 08014000
BEGIN 08014010
08014020
INTEGER D,H,M,MIN,Q,P,Y,TIME1; 08014040
LABEL OWT; 08014050
STREAM PROCEDURE FORM(A,DAY,MO,DA,YR,HR,MIN,AP); 08014060
VALUE DAY,MO,DA,YR,HR,MIN,AP; 08014062
BEGIN DI:=A; 08014064
SI:=LOC DAY; SI:=SI+7; 08014066
IF SC="0" THEN DS:=3LIT"SUN" ELSE 08014068
IF SC="1" THEN DS:=3LIT"MON" ELSE 08014070
IF SC="2" THEN DS:=4LIT"TUES" ELSE 08014072
IF SC="3" THEN DS:=6LIT"WEDNES" ELSE 08014074
IF SC="4" THEN DS:=5LIT"THURS" ELSE 08014076
IF SC="5" THEN DS:=3LIT"FRI" ELSE DS:=5LIT"SATUR"; 08014078
DS:=4LIT"DAY "; SI:=LOC MO; DS:=2DEC; 08014080
DS:=LIT"-"; SI:=LOC DA; DS:=2DEC; DS:=LIT"-"; 08014082
SI:=LOC YR; DS:=2DEC; DS:=2LIT" "; 08014084
SI:=LOC HR; DS:=2DEC; DS:=LIT":"; SI:=LOC MIN; 08014086
SI:=SI+6; DS:=2CHR; SI:=LOC AP; SI:=SI+7; DS:=LIT" "; 08014088
DS:=CHR; DS:=LIT"M" 08014090
END; 08014092
TIME1:=TIME(1); 08014100
Y:=TIME(0); 08014110
D:=Y.[30:6]|100+Y.[36:6]|10+Y.[42:6]; 08014120
Y:=Y.[18:6]|10+Y.[24:6]; 08014130
FOR H:=31,IF Y MOD 4=0 THEN 29 ELSE 28,31,30, 08014140
31,30,31,31,30,31,30 DO 08014150
IF D LEQ H THEN GO OWT ELSE 08014160
BEGIN D:=D-H; M:=M+1 08014170
END; 08014180
OWT: 08014190
H:=TIME1 DIV 216000; 08014200
MIN:=(TIME1 DIV 3600) MOD 60; 08014210
IF M LSS 2 THEN 08014220
BEGIN Q:=M+11; P:=Y-1 08014230
END ELSE 08014240
BEGIN Q:=M-1; P:=Y 08014250
END; 08014260
M:=M+1; 08014270
FORM(B,TIME1:=((Q|26-2)DIV 10+D+P+P.[36:10]+1)MOD 7, 08014280
M,D,Y,Q:= H MOD 12, Q:=MIN MOD 10+(MIN DIV 10)|64, 08014282
IF H GEQ 12 THEN "P" ELSE 17); 08014284
DAYTIME:=(IF TIME1=6 THEN 5 ELSE 08014286
IF TIME1=5 THEN 3 ELSE 08014288
IF TIME1=2 THEN 4 ELSE 3)+22; 08014290
08014300
08014310
END; 08014320
PROCEDURE LOADWORKSPACE(NAME1,NAME2,IDENT); VALUE NAME1,NAME2; 08014325
REAL NAME1,NAME2; ARRAY IDENT[0]; 08014327
BEGIN 08014329
FILE DISK DISK(2,WDSPERREC,WDSPERBLK); 08014331
INTEGER PROCEDURE RD(D,N,A); 08014333
VALUE N; INTEGER N; FILE D; ARRAY A[0]; 08014335
BEGIN READ(D[N],WDSPERREC,A[*]); 08014337
RD:=N+1; 08014339
END; 08014341
PROCEDURE LOADITEM(RD,D,ITEM); 08014343
INTEGER PROCEDURE RD; FILE D; 08014345
ARRAY ITEM[0]; 08014347
BEGIN 08014349
DEFINE T=ITEM#; 08014351
PROCEDURE GETALINE(C,S,L,B,RD,D,LEN); 08014355
VALUE LEN; INTEGER C,S,L,LEN; 08014359
ARRAY B[0]; INTEGER PROCEDURE RD; FILE D; 08014363
BEGIN % GET 2 CHRS GIVING ENSUING CHAR COUNT 08014367
INTEGER P; 08014369
IF C GTR LEN-2 THEN 08014371
IF C GTR LEN-1 THEN % READ A NEW RECORD AND TAKE 2 CHRS 08014375
BEGIN 08014379
S:=RD(D,S,B); 08014383
C:=2; 08014387
TRANSFER(B,0,L,6,2); 08014391
END 08014395
ELSE % 1 CHR LEFT ON LINE 08014399
BEGIN 08014403
TRANSFER(B,C,L,6,1); 08014407
S:=RD(D,S,B); 08014411
TRANSFER(B,0,L,7,1); 08014415
C:=1; 08014419
END 08014423
ELSE % AT LEAST 2 CHARS REMAINING ON LINE 08014427
BEGIN 08014431
TRANSFER(B,C,L,6,2); 08014435
C:=C+2; 08014439
END; 08014443
P:=0; 08014447
IF L NEQ 0 THEN % SOMETHING LEFT IN FUNCTION 08014451
BEGIN 08014455
WHILE P LSS L DO 08014459
IF (L-P) GTR (LEN-C) THEN % # OF CHARS IN LINE 08014463
% EXTENDS INTO NEXT RECORD 08014467
BEGIN 08014471
TRANSFER(B,C,BUFFER,P,LEN-C); % FINISH OUT RECORD 08014475
S:=RD(D,S,B); 08014479
P:=P+(LEN-C); % AMOUNT READ SO FAR 08014483
C:=0; 08014487
END 08014491
ELSE % ALL ON ONE RECORD 08014495
BEGIN 08014499
TRANSFER(B,C,BUFFER,P,L-P); 08014503
C:=C+L-P; 08014507
P:=L; % FINISHED 08014511
END; 08014515
END; 08014519
END OF GETALINE; 08014523
INTEGER S,K,L,M,C,LEN,SQ,PT,G,I,SIZE; 08014527
INTEGER HOLD; 08014529
LABEL SCALARL; 08014530
ARRAY U[0:1],B[0:WDSPERREC-1]; 08014531
BOOLEAN TOG; 08014535
TRANSFER(T,0,U,0,7); 08014539
G:=GETFIELD(T,7,1); 08014540
IF VARSIZE GTR 0 THEN 08014543
IF K:=SEARCHORD(VARIABLES,U,HOLD,7)=0 THEN 08014547
IF K:=GETFIELD(U,7,1)=FUNCTION THEN TOG:=TRUE 08014551
ELSE % NOT A FUNCTION IN THE SYMBOL TABLE 08014555
IF G=FUNCTION THEN 08014559
BEGIN 08014565
DELETE1(VARIABLES,HOLD); 08014567
IF K=ARRAYDATA THEN RELEASEARRAY(U[1]); 08014569
END 08014570
ELSE TOG:=TRUE % DON-T CHANGE 08014571
ELSE % NOT IN VARIABLES 08014575
BEGIN 08014579
VARSIZE:=VARSIZE+1; 08014583
HOLD:=HOLD+K-1; 08014587
END 08014591
ELSE VARSIZE:=1; 08014595
LEN:=(WDSPERREC-1)|8; 08014597
IF NOT TOG THEN % OK TO PUT INTO VARIABLES 08014599
IF G=FUNCTION THEN % READ A FUNCTION INTO VARIABLES 08014603
BEGIN 08014607
TRANSFER(T,0,U,0,9); % U HOLDS FUNCTION NAME, 08014619
%NUMBER OF ARGUMENTS, AND WHETHER FN RETURNS A VALUE 08014620
S:=T[1].LIBF1; % RECORD NUMBER 08014639
M:=T[1].LIBF2; % WORD WITHIN RECORD 08014643
SIZE:=T[1].LIBF3; % SIZE OF POINTERS TABLE 08014647
PT:=NEXTUNIT; 08014649
S:=RD(D,S,B); 08014650
FOR I:=0 STEP 1 UNTIL SIZE-1 DO 08014651
BEGIN 08014655
TRANSFER(B,M|8,T,0,16); 08014659
M:=M+2; 08014663
IF M GEQ WDSPERREC-1 THEN 08014667
BEGIN 08014671
S:=RD(D,S,B); 08014675
IF M GEQ WDSPERREC THEN 08014679
BEGIN 08014683
TRANSFER(B,0,T,8,8); 08014687
M:=1; 08014691
END 08014695
ELSE M:=0; 08014699
END; 08014703
STOREORD(PT,T,I); 08014707
END; % HAVE FINISHED FILLIN G POINTERS TABLE 08014711
IF VARIABLES=0 THEN BEGIN 08014712
VARIABLES:=NEXTUNIT; TOG:=TRUE; %KEEP THE UNIT OPEN 08014713
STOREORD(VARIABLES,U,HOLD); END; 08014714
SEQUENTIAL (SQ:=NEXTUNIT); 08014715
SETFIELD(U,FPTF,FFL,PT); 08014716
SETFIELD(U,FSQF,FFL,SQ); 08014717
STOREORD(VARIABLES,U,HOLD); 08014718
IF TOG THEN DELETE1(VARIABLES,HOLD+1);%REMOVE 1 EXTRA 08014719
COMMENT NOW FILL IN SEQ STORAGE; 08014720
IF M NEQ 0 THEN BEGIN 08014721
M:=C:=0; 08014723
S:=RD(D,S,B); % TEXT STARTS AT BEG. OF NEW RECORD 08014727
END; 08014731
L:=1; 08014735
08014739
WHILE L NEQ 0 DO 08014743
BEGIN 08014747
GETALINE(C,S,L,B,RD,D,LEN); 08014751
GT1:=STORESEQ(SQ,BUFFER,L); 08014755
END 08014759
END 08014763
ELSE 08014767
IF G=ARRAYDATA THEN 08014771
IF T[1].INPTR=0 THEN % NULL VECTOR 08014772
GO SCALARL 08014773
ELSE 08014774
BEGIN 08014775
ARRAY DIMVECT[0:MAXBUFFSIZE]; 08014779
S:=T[1].INPTR; % RECORD NUMBER 08014783
M:=T[1].DIMPTR; % LOC WITHIN RECORD 08014787
C:=M|8; 08014791
SIZE:=T[1].RF; % RANK 08014795
S:=RD(D,S,B); 08014799
GETALINE(C,S,L,B,RD,D,LEN); 08014803
T[1].DIMPTR:=STORESEQ(WS,BUFFER,L); 08014807
% PUTS DIMVECT INTO WORKSPACE 08014811
GETALINE(C,S,L,B,RD,D,LEN); % # BLOCKS 08014815
SIZE:=L-1; 08014819
FOR K:=0 STEP 2 UNTIL SIZE DO 08014823
BEGIN 08014827
GETALINE(C,S,L,B,RD,D,LEN); 08014831
SETFIELD(DIMVECT,K,2,STORESEQ(WS,BUFFER,L)); 08014835
END; COMMENT THIS STORES THE VALUES OF THE 08014839
ARRAY INTO THE WORKSPACE, AND ALSO RECORDS 08014843
THE LOCATION WITHIN WS IN DIMVECT,TO BE STORED;08014847
T[1].INPTR:=STORESEQ(WS,DIMVECT,SIZE+1); 08014851
IF VARIABLES=0 THEN VARIABLES:=NEXTUNIT; 08014853
STOREORD(VARIABLES,T,HOLD); 08014855
END 08014859
ELSE % MUST BE A SCALAR 08014863
SCALARL: 08014864
BEGIN 08014865
IF VARIABLES=0 THEN VARIABLES:=NEXTUNIT; 08014866
STOREORD(VARIABLES,T,HOLD); 08014867
END 08014869
ELSE % WILL NOT REPLACE IN SYMBOL TABLE 08014871
BEGIN 08014875
FILL BUFFER[*] WITH " ","NOT REPL","ACED "; 08014879
TRANSFER(T,0,BUFFER,0,7); 08014883
FORMROW(3,0,BUFFER,0,20); 08014887
END; 08014891
END LOADITEM; 08014906
BOOLEAN STREAM PROCEDURE EQUAL(A,B); 08014910
BEGIN SI:=A; DI:=B; SI:=SI+2; IF 7SC=DC THEN TALLY:=1; 08014914
EQUAL:=TALLY 08014918
END; 08014922
INTEGER I,J,L,NDIR,N; 08014926
LABEL MOVEVAR,SKIP; 08014928
ARRAY T,U[0:1],D[0:WDSPERREC-1]; 08014930
FILL DISK WITH NAME1,NAME2; L:=RD(DISK,L,D); 08014933
IF D[1] NEQ JOBNUM AND D[1] NEQ 0 THEN GO SKIP; % FILE LOCKED 08014940
FOR I:=2 STEP 1 UNTIL 9 DO IF GETFIELD(D[I],1,7) NEQ 0 THEN GO SKIP;08014941
IF NDIR:=D[0] NEQ 0 THEN 08014942
BEGIN N:=LIBSPACES+ENTIER(NDIR|2/(J:=WDSPERREC-1)); 08014944
IF(NDIR|2) MOD J NEQ 0 THEN N:=N+1; 08014945
FOR I:=1 STEP 1 UNTIL NDIR DO 08014946
BEGIN COMMENT GET FUNCTION OR VARIABLE NAME FROM LIB; 08014948
IF WDSPERREC-J LSS 3 THEN 08014950
IF WDSPERREC-J=1 THEN 08014952
BEGIN L:=RD(DISK,L,D); J:=0; GO MOVEVAR 08014954
END ELSE 08014956
BEGIN TRANSFER(D,J|8,T,0,8); L:=RD(DISK,L,D); 08014958
TRANSFER(D,0,T,8,8); J:=1 08014960
END ELSE MOVEVAR: 08014962
BEGIN TRANSFER(D,J|8,T,0,16); J:=J+2 08014964
END; 08014966
IF(IF IDENT[0]=0 THEN TRUE ELSE EQUAL(IDENT,T)) THEN 08014968
BEGIN IF IDENT[0] NEQ 0 THEN I:=NDIR+1; 08014970
LOADITEM(RD,DISK,T); 08014972
END 08014974
END; 08014976
STOREPSR; % UPDATE SINCE HAVE ADDED TO VARIABLES 08014977
END; 08014978
IF FALSE THEN SKIP: FORMWD(1,"6BADFIL"); 08014979
EOB:=1; 08014980
END OF LIBRARY LOAD; 08014990
PROCEDURE PURGEWORKSPACE(WS); VALUE WS; INTEGER WS; 08015000
IF WORKSPACE NEQ 0 THEN 08015005
BEGIN 08015010
INTEGER I,J,K,V,L,G; 08015020
ARRAY T[0:1]; 08015030
J:=SIZE(V:=VARIABLES)-1; 08015040
FOR I:=0 STEP 1 UNTIL J DO 08015050
BEGIN K:=CONTENTS(V,I,T); 08015060
IF GETFIELD(T,7,1)=FUNCTION THEN 08015070
FOR L:=FPTF,FSQF DO % GET RID OF STORAGE 08015080
IF G:=GETFIELD(T,L,FFL) NEQ 0 THEN RELEASEUNIT(G); 08015090
END; 08015100
RELEASEUNIT(V); 08015110
VARIABLES:=0; VARSIZE:=0; 08015120
CURRENTMODE:=0; J:=SIZE(WS)-1; 08015122
FOR I:=1 STEP 1 UNTIL J DO DELETE1(WS,I); 08015124
STOREPSR; 08015130
END; 08015140
PROCEDURE ELIMWORKSPACE(WS); VALUE WS; INTEGER WS; 08015150
BEGIN LABEL QQQ; QQQ: 08015152
IF WORKSPACE NEQ 0 THEN 08015155
BEGIN 08015205
PURGEWORKSPACE(WS); RELEASEUNIT(WS); 08015210
% 08015220
END ELSE SPOUT(8015222); 08015222
END; 08015223
PROCEDURE SAVEWORKSPACE(NAME1,NAME2,LOCKFILE); 08015300
VALUE NAME1,NAME2,LOCKFILE; 08015305
REAL NAME1,NAME2,LOCKFILE; 08015310
BEGIN 08015320
SAVE FILE DISK DISK [NAREAS:SIZEAREAS] 08015330
(2,WDSPERREC,WDSPERBLK,SAVE 100); 08015340
INTEGER PROCEDURE WR(D,N,A); VALUE N; INTEGER N; 08015350
FILE D; ARRAY A[0]; 08015360
BEGIN REAL STREAM PROCEDURE CON(A); VALUE A; 08015370
BEGIN SI:=LOC A; DI:=LOC CON; DS:=8DEC END; 08015380
STREAM PROCEDURE CLEANER(A); 08015382
BEGIN DI:=A; WDSPERREC(DS:=8LIT".") END; 08015384
A[WDSPERREC-1]:=CON(N); 08015390
WRITE(D[N],WDSPERREC,A[*]); 08015400
WR:=N+1; CLEANER(A); 08015410
END; 08015420
PROCEDURE PUTAWAY(C,J,WR,D,N,M,B,L); VALUE L,J; 08015430
INTEGER L,C,J,N,M; 08015435
ARRAY B[0]; INTEGER PROCEDURE WR; FILE D; 08015440
BEGIN INTEGER P,K; 08015450
IF C+2 GTR L THEN 08015460
BEGIN TRANSFER(J,6,B,C,1); N:=WR(D,N,B); C:=1; 08015470
TRANSFER(J,7,B,0,1); 08015480
END ELSE 08015490
BEGIN TRANSFER(J,6,B,C,2); C:=C+2 08015500
END; 08015510
WHILE J NEQ 0 DO 08015520
IF J GTR K:=(L-C) THEN 08015530
BEGIN TRANSFER(BUFFER,P,B,C,K); 08015540
N:=WR(D,N,B); J:=J-K; C:=0; P:=P+K 08015550
END ELSE 08015560
BEGIN TRANSFER(BUFFER,P,B,C,J); C:=C+J; J:=0 08015570
END; 08015580
IF C=L THEN 08015590
BEGIN N:=WR(D,N,B); C:=0 08015600
END; 08015606
END; 08015609
08015610
PROCEDURE MOVETWO(U,B,M,WR,L,D); 08015612
ARRAY U,B[0]; INTEGER M,L; INTEGER PROCEDURE WR; FILE D; 08015615
BEGIN 08015618
COMMENT PUTS 2 WORDS OF U IN B AND WRITES ON D IF A FULLRECORD;08015621
TRANSFER(U,0,B,M|8,16); % CONTENTS OF U INTO B 08015624
M:=M+2; 08015627
IF M GEQ WDSPERREC-1 THEN % FULL RECORD 08015630
BEGIN 08015633
L:=WR(D,L,B); 08015636
IF M GEQ WDSPERREC THEN % 1 OVER FULL RECORD 08015639
08015640
BEGIN 08015642
TRANSFER(U,8,B,0,8); 08015645
M:=1; 08015648
END 08015651
ELSE M:=0; 08015654
END; 08015657
END OF MOVETWO; 08015660
INTEGER H,Q,M,N,I,L,S,J,K,LINE,MAX,PT,SQ,C,LEN,W; 08015663
REAL LSD,STP; 08015666
LABEL SKIP; 08015669
ARRAY T,U[0:1],DIR,B,SEX[0:WDSPERREC]; 08015672
N:=LIBSPACES+ENTIER((S:=SIZE(VARIABLES))|2/(WDSPERREC-1)); 08015675
IF (S|2) MOD (WDSPERREC-1) NEQ 0 THEN N:=N+1; % ADJUST 08015678
LEN:=(WDSPERREC-1)|8; 08015681
FILL DISK WITH NAME1,NAME2; 08015684
DIR[0]:=S; % SIZE OF SYMBOL TABLE 08015687
IF BOOLEAN (LOCKFILE) THEN DIR[1]:=JOBNUM; 08015688
S:=S-1; 08015690
L:=WR(DISK,L,DIR); % FIRST LINE CONTAINS # OF ENTRIES IN 08015693
COMMENT SYMBOL TABLE AND LOCK INFORMATION; 08015696
FOR I:=0 STEP 1 UNTIL S DO 08015699
BEGIN 08015702
J:=CONTENTS(VARIABLES,I,T); % RETURNS VALUE OF I-TH LOC 08015705
% IN VARIABLES INTO T 08015708
IF GT2:=GETFIELD(T,7,1)=FUNCTION THEN 08015711
BEGIN 08015714
PT:=GETFIELD(T,FPTF,FFL); % FUNCTION POINTER FIELD 08015717
SQ:=GETFIELD(T,FSQF,FFL); % FUNCTION SEQUENTIAL FIELD 08015720
%PT=# OF ORDERED STORAGE UNIT CONTAINING HEADER&POINTE 08015723
%SQ=# OF SEQ STORAGE UNIT CONTAINING TEXT 08015726
MAX:=SIZE(PT); 08015729
T[1].LIBF1:=N; % RECORD # 08015732
T[1].LIBF2:=M; % LOC WITHIN RECORD 08015735
T[1].LIBF3:=MAX; % SIZE OF POINTERS TABLE; 08015738
% SAVE ENOUGH ROOM FOR THE ENTIRE POINTERS TABLE 08015740
H:=ENTIER(GT1:=(M+MAX|2)/(WDSPERREC-1)); 08015741
H:=IF GT1 NEQ H THEN H+N+1 ELSE H+N; 08015744
U[0]:=0; 08015747
J:=SEARCHORD(PT,U,LINE,8); % LOOK FOR ALL ZEROS 08015750
IF J=2 THEN GO SKIP; 08015753
FOR W:=0 STEP 1 UNTIL LINE-1 DO 08015756
%MOVE LOCALS AND LABELS INTO THE SAVE FILE 08015757
BEGIN 08015759
J:=CONTENTS(PT,W,U); 08015762
MOVETWO(U,B,M,WR,N,DISK); 08015765
END; 08015768
FOR LINE:=LINE STEP 1 UNTIL MAX-1 DO 08015771
BEGIN 08015774
08015776
J:=CONTENTS(PT,LINE,U); 08015777
GT1:=U[1]; 08015778
U[1]:=LINE-W; 08015779
MOVETWO(U,B,M,WR,N,DISK); % POINTERS TABLE 08015780
J:=CONTENTS(SQ,GT1,BUFFER); 08015783
PUTAWAY(C,J,WR,DISK,H,Q,SEX,LEN); % TEXT 08015786
END; 08015789
PUTAWAY(C,0,WR,DISK,H,Q,SEX,LEN); 08015792
SKIP: 08015795
Q:=C DIV 8; 08015798
IF C MOD 8 NEQ 0 THEN Q:=Q+1; 08015801
IF Q=WDSPERREC-1 THEN 08015807
BEGIN 08015810
H:=WR(DISK,H,SEX); 08015813
Q:=0; 08015816
END; 08015819
IF M GTR 0 THEN N:=WR(DISK,N,B); 08015822
M:=Q; N:=H; 08015825
TRANSFER(SEX,0,B,0,C); % MOVE BACK TO B 08015828
C:=0; 08015830
END 08015831
ELSE 08015834
IF GT2=ARRAYDATA THEN 08015837
BEGIN 08015840
ARRAY DIMVECT[0:MAXBUFFSIZE]; 08015843
LSD:=T[1]; 08015846
IF H:=LSD.SPF=0 THEN % NULL VECTOR 08015849
ELSE 08015855
BEGIN 08015858
T[1].INPTR:=N; T[1].DIMPTR:=M; 08015859
C:=M|8; 08015860
J:=CONTENTS(WS,LSD.DIMPTR,BUFFER); % DIM VECT 08015861
PUTAWAY(C,J,WR,DISK,N,M,B,LEN); % STO DIM VECT 08015864
J:=CONTENTS(WS,LSD.INPTR,DIMVECT); 08015867
TRANSFER(DIMVECT,0,BUFFER,0,J); 08015868
PUTAWAY(C,J,WR,DISK,N,M,B,LEN); 08015869
J:=J-1; 08015870
FOR LINE:=0 STEP 2 UNTIL J DO 08015871
BEGIN 08015873
PT:=GETFIELD(DIMVECT,LINE,2); 08015876
STP:=CONTENTS(WS,PT,BUFFER); 08015879
PUTAWAY(C,STP,WR,DISK,N,M,B,LEN); 08015882
END; 08015885
M:=C DIV 8; IF C MOD 8 NEQ 0 THEN M:=M+1; C:=0; 08015886
IF M=WDSPERREC-1 THEN BEGIN N:=WR(DISK,N,B); 08015887
M:=0; END; 08015888
END; 08015889
END; 08015891
MOVETWO(T,DIR,K,WR,L,DISK); 08015892
END; 08015894
08015900
EOB:=1; 08015920
IF M GTR 0 THEN N:=WR(DISK,N,B); 08015922
IF K GTR 0 THEN L:=WR(DISK,L,DIR); 08015930
LOCK(DISK); 08015940
END; 08015950
BOOLEAN PROCEDURE LIBNAMES(A,B); REAL A,B; 08015952
BEGIN REAL T; 08015954
A:=B:=GT1:=0; 08015956
% 08015958
% 08015959
IF SCAN AND IDENT THEN 08015960
BEGIN T~ACCUM[0]; T.[6:6]~"/"; 08015961
IF SCAN AND LOCKIT THEN GT1~1 ELSE IF IDENT THEN LIBNAMES~TRUE; 08015962
A~T; B~ JOBNUM; 08015963
END 08015964
ELSE LIBNAMES~ TRUE; 08015966
END; 08015992
PROCEDURE MESSAGEHANDLER; 08016000
BEGIN 08016005
LABEL ERR1; 08016008
% 08016009
IF SCAN THEN IF IDENT THEN 08016010
BEGIN INTEGER I; REAL R,S; 08016011
PROCEDURE NOFILEPRESENT; 08016012
BEGIN 08016014
FILL BUFFER[*] WITH "FILE NOT"," ON DISK"; 08016016
FORMROW(3,0,BUFFER,0,16); 08016018
END OF NOFILEPRESENT; 08016020
PROCEDURE PRINTID(VARS); VALUE VARS; BOOLEAN VARS; 08016022
BEGIN INTEGER I,J,K,L,M; ARRAY T[0:1]; BOOLEAN TOG; 08016024
INTEGER NUM; 08016025
J:=VARSIZE-1; M:=VARIABLES; 08016026
FOR I:=0 STEP 1 UNTIL J DO 08016028
BEGIN L:=CONTENTS(M,I,T); TOG:=GETFIELD(T,7,1) 08016030
=FUNCTION; 08016032
IF NUM:=3|REAL(TOG AND VARS)+8+NUM GTR LINESIZE 08016033
THEN BEGIN TERPRINT; NUM:=3|REAL(TOG AND VARS)+8 END; 08016034
IF VARS THEN 08016035
BEGIN FORMROW(0,1,T,0,7); L:=L+1; 08016036
IF TOG THEN FORMWD(0,"3(F) "); 08016038
END ELSE 08016040
IF TOG THEN BEGIN L:=L+1; FORMROW(0,1,T,0,7) END; 08016042
END; 08016044
IF L=0 THEN FORMWD(3,"6 NULL.") ELSE TERPRINT 08016046
END; 08016048
R:=ACCUM[0]; 08016050
FOR I:=0 STEP 1 UNTIL MAXMESS DO 08016052
IF R=MESSTAB[I] THEN 08016054
BEGIN R:=I; I:=MAXMESS+1 08016060
END; 08016070
IF I=MAXMESS+2 THEN 08016080
CASE R OF 08016090
BEGIN 08016100
% ------- SAVE ------- 08016110
IF NOT LIBNAMES(R,S) THEN 08016120
IF NOT LIBRARIAN(R,S) THEN BEGIN 08016125
SAVEWORKSPACE(R,S,GT1); %GT1 SET IN LIBNAMES 08016130
GTA[0]~GTA[1]~0;TRANSFER(R,1,GTA,1,7); 08016131
IF(GT1~SEARCHORD(LIBRARY,GTA, I ,7)) NEQ 0 THEN 08016132
BEGIN GTA[0]~GTA[1]~0;TRANSFER(R,1,GTA,1,7); 08016133
STOREORD(LIBRARY,GTA,I+(IF GT1=1 THEN -1 ELSE 1));08016134
END; LIBSIZE~LIBSIZE+1; 08016135
END 08016138
ELSE 08016140
BEGIN 08016150
FILL BUFFER[*] WITH "FILE ALR","EADY ON ", 08016160
"DISK "; 08016165
FORMROW(3,0,BUFFER,0,20); 08016170
END 08016180
ELSE GO ERR1; 08016190
% ------- LOAD ------- 08016200
IF NOT LIBNAMES(R,S) AND R NEQ 0 THEN 08016205
IF LIBRARIAN(R,S) THEN 08016210
BEGIN ARRAY A[0:1]; 08016220
LOADWORKSPACE(R,S,A); 08016230
END 08016240
ELSE NOFILEPRESENT 08016250
ELSE GO ERR1; 08016260
% ------- DROP ------- 08016300
IF CURRENTMODE=CALCMODE THEN 08016305
IF NOT LIBNAMES(R,S) THEN 08016310
IF LIBRARIAN(R,S) THEN 08016315
BEGIN FILE ELIF DISK (1,1); 08016320
FILL ELIF WITH R,S; WRITE(ELIF[0]); 08016325
CLOSE(ELIF,PURGE) 08016330
;GTA[0]~GTA[1]~0;TRANSFER(R,1,GTA,1,7); 08016331
IF SEARCHORD(LIBRARY,GTA,I,7)=0 THEN DELETE1(LIBRARY,I); 08016332
LIBSIZE~LIBSIZE-1; 08016333
END 08016335
ELSE NOFILEPRESENT 08016340
ELSE 08016360
IF NOT BOOLEAN(SUSPENSION)THEN PURGEWORKSPACE(WORKSPACE) 08016365
ELSE GO ERR1 ELSE GO ERR1; 08016370
% ------- COPY ------- 08016400
IF LIBNAMES(R,S) THEN 08016410
IF LIBRARIAN(R,S) THEN 08016415
LOADWORKSPACE(R,S,ACCUM) 08016420
ELSE NOFILEPRESENT 08016422
ELSE GO ERR1; 08016425
08016430
% -------- VARS ------- 08016500
PRINTID(TRUE); 08016510
08016520
%------- FNS ------- 08016600
PRINTID(FALSE); 08016610
%-------- LOGGED ---------------- 08016700
; 08016746
%-------- MSG -------- 08016800
ERRORMESS(SYNTAXERROR,LADDRESS,0); 08016870
%-----WIDTH (INTEGER) ---------------------------- 08016900
IF NOT SCAN THEN BEGIN NUMBERCON(LINESIZE, ACCUM); 08016910
FORMROW(3,0,ACCUM,2,ACOUNT); END 08016915
ELSE IF NUMERIC AND I:=ACCUM[0] GTR 9 AND I LEQ 72 08016920
THEN BEGIN TERPRINT; LINESIZE:=I; STOREPSR; 08016925
END 08016940
%IF A NUMBER CONVERSION ERROR, RESULT WILL BE ZERO 08016945
%AND WE"LL GET AN ERROR ANYWAY 08016946
ELSE GO TO ERR1; 08016950
%-------- OPR -------- 08017000
; 08017010
%------DIGITS (INTEGER) ------------------------ 08017100
IF NOT SCAN THEN BEGIN NUMBERCON(DIGITS,ACCUM); 08017110
FORMROW(3,0,ACCUM,2,ACOUNT); END 08017115
ELSE IF NUMERIC AND I:=ACCUM[0] GEQ 0 AND I LEQ 12 08017120
AND ERR=0 THEN BEGIN DIGITS:=I; STOREPSR END 08017125
ELSE GO TO ERR1; 08017130
%-------- OFF -------- 08017200
BEGIN 08017210
IF SCAN THEN IF ACCUM[0]="7DISCAR" THEN 08017220
ELIMWORKSPACE(WORKSPACE) ELSE 08017230
GO TO ERR1; 08017232
FILL ACCUM[*] WITH "END OF R","UN "; 08017240
FORMROW(3,MARGINSIZE,ACCUM,0,10); 08017242
CURRENTMODE:=CALCMODE; 08017243
GT1:=CSTATION; 08017244
CSTATION:=GT1&0[CAPLOGGED] 08017245
;GO TO FINIS; 08017246
END; 08017250
%--------ORIGIN----------------------------------- 08017255
IF NOT SCAN THEN BEGIN NUMBERCON(ORIGIN,ACCUM); 08017256
FORMROW(3,0,ACCUM,2,ACOUNT) END 08017257
ELSE IF NUMERIC AND ERR=0 THEN BEGIN ORIGIN:= 08017258
I:=ACCUM[0]; STOREPSR END ELSE GO TO ERR1; 08017259
%--------SEED--------------------------------- 08017260
IF NOT SCAN THEN BEGIN NUMBERCON(SEED,ACCUM); 08017262
FORMROW(3,0,ACCUM,2,ACOUNT) END 08017263
ELSE IF NUMERIC AND ERR=0 THEN BEGIN 08017265
SEED:=ABS(I:=ACCUM[0]); 08017266
STOREPSR END ELSE GO TO ERR1; 08017267
%--------FUZZ----------------------------------- 08017270
IF NOT SCAN THEN BEGIN 08017272
NUMBERCON(FUZZ,ACCUM); 08017273
FORMROW(3,0,ACCUM,2,ACOUNT) END 08017274
ELSE IF NUMERIC AND ERR=0 THEN BEGIN FUZZ:=ABS(ACCUM[0]); 08017275
STOREPSR END ELSE GO TO ERR1; 08017277
%------- SYN, NOSYN------------------------------------- 08017290
NOSYNTAX:=0; NOSYNTAX:=1; 08017292
%-----------------STORE------------------------- 08017950
IF SYMBASE NEQ 0 THEN PROCESS(WRITEBACK); 08017960
08017962
08017970
%-----------------ABORT------------------------ 08018000
BEGIN IF BOOLEAN(SUSPENSION) THEN 08018010
SP[0,0]:=0; NROWS:=-1; 08018012
%%% 08018020
SUSPENSION:=0; 08018022
STOREPSR 08018023
END; 08018030
%-----------------SI-------------------------------- 08018100
IF BOOLEAN(SUSPENSION) THEN 08018110
BEGIN GT1:=0; 08018120
PROCESS(LOOKATSTACK); 08018130
END ELSE FORMWD(3,"6 NULL."); 08018140
%------------------SIV------------------------------- 08018150
IF BOOLEAN(SUSPENSION) THEN 08018160
BEGIN GT1:=1; 08018170
PROCESS(LOOKATSTACK); 08018180
END ELSE FORMWD(3,"6 NULL."); 08018190
%------------------ERASE------------------------------ 08018200
IF CURRENTMODE=FUNCMODE OR BOOLEAN(SUSPENSION) THEN GO TO ERR1 08018210
ELSE WHILE SCAN AND IDENT DO 08018215
BEGIN % LOOK FOR THE IDENTIFIER NAME IN ACCUM 08018220
TRANSFER(ACCUM,2,GTA,0,7); 08018225
IF (IF VARIABLES=0 THEN FALSE ELSE 08018230
SEARCHORD(VARIABLES,GTA,GT1,7)=0) THEN 08018235
BEGIN % FOUND A SYMBOL TABLE ENTRY MATCHING NAME 08018240
DELETE1(VARIABLES,GT1); % REMOVE FROM SYMBOLTABLE 08018241
IF VARSIZE:=VARSIZE-1=0 THEN VARIABLES:=0; 08018242
COMMENT IF NOTHING IS IN THE UNIT IT IS DELETED; 08018243
08018245
% CHECK IF THERE IS MORE TO DELETE 08018250
IF GT1:=GETFIELD(GTA,7,1)=FUNCTION THEN 08018255
BEGIN 08018260
RELEASEUNIT(GETFIELD(GTA,FPTF,FFL)); 08018265
RELEASEUNIT(GETFIELD(GTA,FSQF,FFL)); 08018270
END 08018275
ELSE IF GT1 GTR 0 THEN % MUST BE AN ARRAY 08018300
RELEASEARRAY(GTA[1]); 08018305
END ELSE % THERE IS NO SUCH VARIABLE 08018310
ERRORMESS(LABELERROR,LADDRESS,0); 08018315
END; % OF TAKING CARE OF ERASE 08018320
%------------ ASSIGN -------------------------------- 08018330
; 08018462
%------------ DELETE --------------------------------- 08018470
; 08018577
%------------- LIST ------------------------------------ 08018580
; 08018767
% -------------DEBUG -------------------------------- 08018770
IF SCAN AND IDENT THEN 08018780
IF ACCUM[0]="6POLISH" THEN POLBUG:=ABS(POLBUG-1); 08018930
08018942
%----------------------------- FILES ---------------------- 08018965
IF LIBSIZE>1 THEN 08018970
BEGIN FOR I~1 STEP 1 UNTIL LIBSIZE-1 DO 08018975
BEGIN R~CONTENTS(LIBRARY,I ,ACCUM); 08018980
FORMROW(0,1,ACCUM,2,6); 08018985
END; TERPRINT; 08018990
END ELSE FORMWD(3,"6 NULL."); 08018995
%------------------------ END OF CASES ---------------------------- 08018999
END ELSE GO TO ERR1; 08019000
IF CURRENTMODE=FUNCMODE THEN INDENT(-CURLINE); 08019010
END ELSE 08019020
IF QUOTE THEN EDITLINE ELSE 08019100
ERR1: ERRORMESS(SYNTAXERROR,0,0); 08019200
INDENT(0); 08019210
TERPRINT; 08019300
END; 08019400
REAL PROCEDURE LINENUMBER(R); VALUE R; REAL R; 08030000
BEGIN 08030010
REAL STREAM PROCEDURE CON(R); VALUE R; 08030020
BEGIN SI:=LOC R; DI:=LOC CON; DS:=8DEC 08030030
END; 08030040
LINENUMBER:=CON( ENTIER( (R+.00005)|10000)) 08030050
END; 08030060
DEFINE DELIM="""#, ENDCHR="$"#; 08030080
BOOLEAN PROCEDURE WITHINALINE(COMMAND,OLD,NEW,CHAR,WORD); 08030082
VALUE COMMAND,CHAR,WORD; INTEGER COMMAND,CHAR,WORD; 08030084
ARRAY OLD, NEW[0]; BEGIN 08030086
BOOLEAN STREAM PROCEDURE WITHINLINE(COMMAND,OLD,NEW,CHAR,WORD); 08030100
VALUE COMMAND,CHAR,WORD; 08030102
BEGIN 08030110
LOCAL OLDLINE,NEWLINE,F,BCHR; 08030120
LOCAL N,M,T; 08030130
LOCAL X,Y,Z; 08030132
LABEL LOOKING,FOUND,BETWEEN,TAIL,FINISH, 08030140
OVER; 08030150
DI:=NEW; WORD(DS:=8LIT" "); 08030160
SI:=LOC CHAR; DI:=LOC T; DI:=DI+1; DS:=7CHR; 08030162
SI:=COMMAND; 08030170
TALLY:=T; X:=TALLY; TALLY:=2; Y:=TALLY; TALLY:=32; Z:=TALLY; 08030180
TALLY:=0; 08030190
IF SC!"~" THEN 08030200
BEGIN BCHR:=SI; SI:=OLD; OLDLINE:=SI; 08030210
DI:=NEW; NEWLINE:=DI; SI:=BCHR; 08030220
63(IF SC=DELIM THEN JUMP OUT ELSE SI:=SI+1; TALLY 08030230
:=TALLY+1); N:=TALLY; 08030240
IF TOGGLE THEN 08030250
BEGIN 08030260
SI:=SI+1; TALLY:=0; 08030270
63(IF SC=DELIM THEN TALLY:=0 ELSE 08030280
IF SC="~" THEN JUMP OUT ELSE TALLY:=TALLY+1; SI:=SI+1); 08030290
IF TOGGLE THEN M:=TALLY; 08030300
DI:=OLDLINE; SI:=BCHR; 08030310
2( X( Y( Z( CI:=CI+F; 08030320
GO LOOKING; GO FOUND; GO BETWEEN; GO TAIL; GO FINISH; 08030330
LOOKING: %************ LOOKING FOR THE FIRST UNIQUE STRING**************08030340
IF SC=DELIM THEN BEGIN SI:=SI+1; TALLY:=2; F:=TALLY ; 08030350
DI:=NEWLINE; GO BETWEEN END ELSE 08030360
IF N SC=DC THEN BEGIN SI:=OLDLINE; SI:=SI+N; OLDLINE:=SI; 08030370
DI:=NEWLINE; SI:=BCHR; TALLY:=1; F:=TALLY; 08030380
GO FOUND END ELSE 08030382
BEGIN SI:=OLDLINE; DI:=NEWLINE; DS:=CHR; NEWLINE:=DI; 08030390
OLDLINE:=SI; SI:=BCHR; DI:=OLDLINE 08030400
END; GO OVER; 08030410
FOUND: %**************FOUND THE FIRST UNIQUE STRING ******************08030420
IF SC=DELIM THEN BEGIN SI:=SI+1; TALLY:=2; 08030430
F:=TALLY; GO BETWEEN END ELSE 08030432
DS:=CHR; GO OVER; 08030440
BETWEEN: % ********** BETWEEN THE // **********************************08030450
IF SC=DELIM THEN BEGIN SI:=SI+1; NEWLINE:=DI; DI:=OLDLINE; 08030460
TALLY:=3; F:=TALLY; GO TAIL END ELSE 08030470
IF SC="~" THEN BEGIN TALLY:=4; F:=TALLY; 08030480
SI:=OLDLINE; GO FINISH END ELSE 08030482
DS:=CHR; GO OVER; 08030490
TAIL: % ******* THE TAIL END OF THE COMMAND ***************************08030500
IF M SC=DC THEN BEGIN DI:=NEWLINE; SI:=OLDLINE; TALLY:=4; 08030510
F:=TALLY; GO FINISH END ELSE 08030520
BEGIN SI:=SI-M; DI:=DI-M; DI:=DI+1; OLDLINE:=DI; END; 08030530
GO OVER; 08030540
FINISH: % ********FINISH UP THE CHR MOVE FROM THE OLD TO NEW**********08030550
DS:=CHR; OVER:))); 08030560
TALLY:=CHAR; X:=TALLY; TALLY:=1; Y:=TALLY; 08030562
Z:=TALLY); 08030564
SI:=NEW; DI:=OLD; DS:=WORD WDS; TALLY:=1; 08030570
WITHINLINE:=TALLY 08030580
END 08030590
END 08030600
END OF WITHINALINE; 08030610
WITHINALINE := WITHINLINE(COMMAND,OLD,NEW,CHAR,WORD); 08030612
END OF PHONY WITHINALINE; 08030614
PROCEDURE EDITLINE; 08030621
BEGIN ARRAY T[0:MAXBUFFSIZE]; 08030622
INITBUFF(T,BUFFSIZE); 08030624
TRANSFER(OLDBUFFER,0,T,0,LENGTH(OLDBUFFER,TRUE)); 08030626
IF WITHINALINE(ADDRESS,T,OLDBUFFER,BUFFSIZE|8,BUFFSIZE) THEN 08030628
BEGIN MOVEWDS(OLDBUFFER,BUFFSIZE,BUFFER); 08030630
08030631
IF SCAN AND RGTPAREN THEN 08030632
ERRORMESS(SYNTAXERROR,LADDRESS,0) ELSE EDITOG:=1; 08030633
END; 08030634
08030636
08030638
FORMROW(3,0,BUFFER,0,LENGTH(BUFFER,FALSE)); 08030640
END; 08030642
PROCEDURE CHECKSEQ(SEQ,L,INC); REAL SEQ,L,INC; 08040000
BEGIN 08040100
INTEGER I,J; 08040200
I:=L|10000 MOD 10000; 08040300
FOR J:=-4 STEP 1 WHILE J LSS 0 AND I MOD 10=0 DO 08040400
I:=I/10; 08040500
INC:=10*J; 08040600
SEQ:=L; 08040700
END; 08040800
PROCEDURE FUNCTIONHANDLER; 09000000
BEGIN 09001000
LABEL ENDHANDLER; 09002000
OWN BOOLEAN EDITMODE; 09003000
DEFINE FPT=FUNCPOINTER#, 09004000
FSQ=FUNCSEQ#, 09004100
SEQ=CURLINE#, 09004200
INC=INCREMENT#, 09004300
MODE=SPECMODE#, 09004310
ENDDEFINES=#; 09004400
INTEGER STREAM PROCEDURE DELPRESENT(ADDR); VALUE ADDR; 09005000
BEGIN LABEL L,FINIS; 09005100
LOCAL Q; 09005110
DI:=LOC Q; DS:=RESET; DS:=5SET; DS:=2RESET; DS:=2SET; 09005120
% LEFT-ARROW / QUESTION MARK 09005130
SI:=ADDR; 09005140
L: DI:=LOC Q; 09005150
IF SC=DELCHR THEN 09005160
BEGIN ADDR:=SI; SI:=LOC Q; DI:=ADDR; DS:=LIT" "; 09005170
TALLY:=1; DELPRESENT:=TALLY; GO TO FINIS; 09005180
END; 09005200
IF SC=DC THEN GO TO FINIS; SI:=SI-1; 09005300
IF SC=DC THEN GO TO FINIS; 09005400
GO TO L; 09005500
FINIS: 09005600
END; 09005700
INTEGER PROCEDURE OLDLABCONFLICT(PT,S); VALUE PT,S; 09006000
INTEGER PT; REAL S; 09007000
IF PT NEQ 0 THEN 09008000
BEGIN INTEGER K; ARRAY L[0:1]; 09009000
ADDRESS:=ABSOLUTEADDRESS; 09010000
WHILE LABELSCAN(L,0) AND ERR EQL 0 DO 09011000
IF SEARCHORD(PT,L,K,8)=0 THEN 09012000
IF L[1] NEQ S THEN ERR:=24; 09013000
OLDLABCONFLICT:=ERR 09014000
END; 09015000
INTEGER PROCEDURE ELIMOLDLINE(PT,SQ,L); VALUE PT,SQ,L; INTEGER PT, 09016000
SQ,L; FORWARD; 09017000
INTEGER PROCEDURE STOREAWAY(PT,SQ,B,SEQ); VALUE SEQ; 09018000
INTEGER PT,SQ; REAL SEQ; ARRAY B[0]; FORWARD; 09019000
PROCEDURE BUFFERCLEAN(BUFFER,BUFFSIZE,ADDR); VALUE BUFFSIZE, 09019100
ADDR; REAL ADDR; INTEGER BUFFSIZE; ARRAY BUFFER[0]; 09019200
FORWARD; COMMENT THIS IS A PHONEY DEAL, BUT I CAN"T 09019300
DECLARE CLEANBUFFER FORWARD (MOVE IT UP HERE LATER); 09019400
PROCEDURE EDITDRIVER(PT,SQ,I,K); VALUE PT,SQ,I,K; 09020000
INTEGER PT,SQ,I,K; 09021000
BEGIN ARRAY C,LAB[0:1],OLD,NEW[0:MAXBUFFSIZE]; 09022000
STREAM PROCEDURE BL(A); 09023000
BEGIN DI:=A; MAXBUFFSIZE(DS:=8LIT" ") END; 09024000
DEFINE MOVE=MOVEWDS#; 09025000
REAL T,SEQ; INTEGER A,B,L,M; 09026000
T:=ADDRESS; 09027000
FOR A:=I STEP 1 WHILE A LEQ K AND EDITMODE DO 09028000
BEGIN B:=CONTENTS(PT,A,C); BL(OLD); 09029000
SEQ:=C[0]; 09030000
B:=CONTENTS(SQ,C[1],OLD); 09031000
IF EDITMODE:=WITHINALINE(T,OLD,NEW,BUFFSIZE|8,BUFFSIZE) 09032000
THEN BEGIN MOVE(BUFFER,MAXBUFFSIZE+1,NEW); 09033000
MOVE(OLD,MAXBUFFSIZE,BUFFER); 09034000
IF EDITMODE:=ERR:=OLDLABCONFLICT(PT,C[0])=0 THEN 09035000
BEGIN B:=ELIMOLDLINE(PT,SQ,C[1]); 09036000
DELTOG:=DELPRESENT(ADDRESS); 09036100
DELETE1(SQ,C[1]); DELETE1(PT,A+B); C[1]:= 09037000
STORESEQ(SQ,BUFFER,LENGTH(BUFFER,FALSE)); 09038000
STOREORD(PT,C,A+B); 09039000
RESCANLINE; L:=0; M:=1; LAB[1]:=C[0]; 09040000
WHILE LABELSCAN(C,0) DO 09041000
BEGIN MOVEWDS(C,1,LAB); 09042000
IF(IF FUNCSIZE=0 THEN TRUE ELSE L:= 09043000
SEARCHORD(PT,C,M,8)NEQ 0) THEN 09044000
BEGIN B:=B+1; FUNCSIZE:=FUNCSIZE+1; 09045000
STOREORD(PT,LAB,L+M-1) 09046000
END END; 09047000
A:=A+B; K:=K+B; 09048000
COMMENT THE NEXT LINE CAUSED A SYSTEM CRASH AFTER THE EDIT 09048500
IF NOSYNTAX=0 THEN PROCESS(XEQUTE); 09049000
END END; 09050000
MOVE(NEW,MAXBUFFSIZE+1,BUFFER) 09051000
END END; 09052000
PROCEDURE LISTLINE(PT,SQ,I); VALUE PT,SQ,I; INTEGER PT,SQ,I; 09052100
BEGIN 09052200
GT1:=CONTENTS(PT,I,GTA); 09052300
INDENT(GTA[0]); 09052400
GT1:=CONTENTS(SQ,GTA[1],BUFFER); 09052500
CHRCOUNT:=CHRCOUNT-1; 09052600
FORMROW(1,0,BUFFER,0,GT1); 09052700
END; 09052800
INTEGER PROCEDURE DISPLAY(A,B,PT,SQ); VALUE A,B,PT,SQ; 09053000
INTEGER PT,SQ; REAL A,B; 09054000
IF A LEQ B AND FUNCSIZE NEQ 0 THEN 09055000
BEGIN 09056000
ARRAY C[0:1]; 09057000
INTEGER I,J,K; 09058000
DEFINE CLEANBUFFER=BUFFERCLEAN#; 09058100
A:=LINENUMBER(A); B:=LINENUMBER(B); 09059000
C[0]:=A; 09060000
I:=SEARCHORD(PT,C,K,8); 09061000
I:=(IF I=2 THEN IF K LSS FUNCSIZE-1 THEN K:=K+1 ELSE 09062000
K ELSE K); 09063000
IF A NEQ B THEN 09064000
BEGIN 09065000
C[0]:=B; B:=SEARCHORD(PT,C,K,8); 09066000
END; 09067000
IF EDITMODE THEN % MAY HAVE ONLY ONE LINE TO EDIT 09068000
IF I=K THEN 09068100
IF A NEQ 0 THEN %NOT EDITING THE HEADER 09068200
EDITDRIVER(PT,SQ,I,K) 09068300
ELSE %EDITING THE FUNCTION HEADER, FIX LATER. 09068400
ERR:=31 09068500
ELSE %EDITING MORE THAN ONE LINE 09069000
BEGIN MODE:=EDITING; 09069100
IF A=0 THEN I:=I+1; 09069110
CLEANBUFFER(BUFFER,BUFFSIZE,ADDRESS); 09069112
MOVE(BUFFER,BUFFSIZE,OLDBUFFER); 09069120
LOWER:=I; UPPER:=K 09069200
END 09069300
ELSE %NOT EDITING, MUST BE A LIST 09069400
BEGIN 09070000
FORMWD(3,"1 "); 09071000
IF K=I THEN % LISTING A SINGLE LINE 09072000
BEGIN LISTLINE(PT,SQ,I); 09072100
FORMWD(3,"1 "); 09072200
END ELSE % LISTING A SET OF LINES 09072300
BEGIN MODE:=DISPLAYING; 09072400
LOWER:=I; UPPER:=K 09072500
END; 09072600
END; 09081000
EOB:=1; 09082000
END ELSE DISPLAY:=20; 09083000
INTEGER PROCEDURE DELETE(A,B,PT,SQ); VALUE A,B; 09084000
INTEGER PT,SQ; REAL A,B; 09085000
IF A LEQ B AND FUNCSIZE NEQ 0 AND A NEQ 0 THEN 09086000
BEGIN 09087000
INTEGER I,J,K,L; 09088000
ARRAY C[0:1]; 09089000
A:=LINENUMBER(A); 09090000
B:=LINENUMBER(B); 09091000
C[0]:=A; 09092000
IF SEARCHORD(PT,C,K,8)=2 THEN K:=K+1; 09093000
C[0]:=B; 09094000
IF SEARCHORD(PT,C,I,8)=1 THEN I:=I-1; 09095000
IF K GTR I OR I GEQ FUNCSIZE THEN DELETE:=21 ELSE 09096000
BEGIN 09097000
FOR J:=K STEP 1 UNTIL I DO 09098000
BEGIN A:=CONTENTS(PT,J,C); 09099000
L:=ELIMOLDLINE(PT,SQ,C[1]); 09100000
FUNCSIZE:=FUNCSIZE+L; I:=I+L; K:=K+L; J:=J+L; 09101000
DELETE1(SQ,C[1]) 09102000
END; 09103000
FUNCSIZE:=FUNCSIZE-(I-K+1) 09104000
; EOB:=1; 09105000
DELETEN(PT,K,I); 09106000
IF FUNCSIZE=0 THEN 09107000
BEGIN 09108000
PT:=0; RELEASEUNIT(SQ); SQ:=0; 09109000
STOREPSR; 09110000
END; 09111000
END; 09112000
END ELSE DELETE:=22; 09113000
INTEGER PROCEDURE ELIMOLDLINE(PT,SQ,L); VALUE PT,SQ,L; 09114000
INTEGER PT,SQ,L; 09115000
BEGIN INTEGER K,J; 09116000
REAL AD; 09117000
ARRAY T[0:MAXBUFFSIZE],LAB[0:1]; 09118000
AD:=ADDRESS; 09119000
MOVEWDS(BUFFER,MAXBUFFSIZE+1,T); 09120000
INITBUFF(BUFFER,BUFFSIZE); 09121000
K:=CONTENTS(SQ,L,BUFFER); 09122000
RESCANLINE; 09123000
WHILE LABELSCAN(LAB,0) DO 09124000
IF SEARCHORD(PT,LAB,K,8)=0 THEN 09125000
BEGIN DELETE1(PT,K); J:=J-1 END; 09126000
ADDRESS:=AD; 09127000
MOVEWDS(T,MAXBUFFSIZE+1,BUFFER); 09128000
ELIMOLDLINE:=J 09129000
END; 09130000
INTEGER PROCEDURE STOREAWAY(PT,SQ,B,SEQ); VALUE SEQ; 09131000
INTEGER PT,SQ; REAL SEQ; ARRAY B[0]; 09132000
BEGIN DEFINE BUFFER=B#; 09133000
ARRAY C,LAB[0:1]; 09134000
INTEGER I,J,K,L; 09135000
BOOLEAN TOG; 09136000
SEQ:=LINENUMBER(SEQ); 09137000
C[0]:=SEQ; 09138000
IF TOG:=(PT=0 OR FUNCSIZE=0) THEN 09139000
BEGIN SEQUENTIAL(SQ:=NEXTUNIT); I:=0 09140000
END ELSE 09141000
IF J:=SEARCHORD(PT,C,I,8)=0 THEN 09142000
BEGIN 09143000
K:=ELIMOLDLINE(PT,SQ,C[1]); 09144000
I:=I+K; FUNCSIZE:=FUNCSIZE+K; 09145000
DELETE1(PT,I); 09146000
FUNCSIZE:=FUNCSIZE-1; 09147000
DELETE1(SQ,C[1]); 09148000
END ELSE 09149000
I:=I+J-1; 09150000
RESCANLINE; 09151000
DELTOG:=DELPRESENT(ADDRESS); 09151100
K:=STORESEQ(SQ,BUFFER,LENGTH(BUFFER,TRUE)); 09152000
LAB[1]:=SEQ; L:=0; J:=1; 09153000
IF TOG THEN PT:=NEXTUNIT; 09154000
WHILE LABELSCAN(C,0) DO 09155000
BEGIN 09156000
MOVEWDS(C,1,LAB); 09157000
IF (IF FUNCSIZE=0 THEN TRUE ELSE L:= 09158000
SEARCHORD(PT,C,J,8)NEQ 0 ) THEN 09159000
BEGIN I:=I+1; FUNCSIZE:=FUNCSIZE+1; 09160000
STOREORD(PT,LAB,L+J-1); 09161000
END 09162000
END; 09163000
C[1]:=K; 09164000
C[0]:=SEQ; 09165000
FUNCSIZE:=FUNCSIZE+1; 09166000
STOREORD(PT,C,I); 09167000
IF TOG THEN STOREPSR; 09168000
EOB:=1; 09169000
END; 09170000
BOOLEAN PROCEDURE BOUND(PT); VALUE PT; INTEGER PT; 09171000
IF NOT(BOUND:=NUMERIC) THEN 09172000
IF IDENT AND FUNCSIZE GTR 0 THEN 09173000
BEGIN ARRAY L[0:1]; INTEGER K; 09174000
REAL T,U; 09175000
REAL STREAM PROCEDURE CON(A); 09176000
VALUE A; 09177000
BEGIN SI:=LOC A; DI:=LOC CON; DS:=8OCT 09178000
END; 09179000
TRANSFER(ACCUM,2,L,1,7); 09180000
IF BOUND:=SEARCHORD(PT,L,K,8)=0 THEN 09181000
BEGIN T:=ADDRESS; 09182000
U:=CON(MAX(L[1],0))/10000; %ARGS AND RESULT ARE NEG 09183000
IF SCAN AND PLUS OR MINUS THEN 09184000
BEGIN K:=(IF PLUS THEN 1 ELSE -1); 09185000
IF SCAN AND NUMERIC THEN 09186000
ACCUM[0]:=MAX(U+K|ACCUM[0],0) ELSE 09187000
BEGIN ACCUM[0]:=U; 09188000
ADDRESS:=T; 09189000
END; 09190000
END ELSE BEGIN ACCUM[0]:=U; ADDRESS:=T 09191000
END; 09192000
EOB:=0; 09193000
END 09194000
END; 09195000
09196000
09197000
PROCEDURE FINISHUP; 09198000
BEGIN COMMENT GET HIM BACK TO CALCULATOR MODE; 09198100
IF FUNCPOINTER=0 THEN % HE DELETED EVERY THING 09198200
BEGIN TRANSFER(PSR,FSTART|8,GTA,0,8); 09198210
IF SEARCHORD(VARIABLES,GTA,GT1,7)=0 THEN 09198220
BEGIN DELETE1(VARIABLES,GT1); 09198230
IF VARSIZE:=VARSIZE-1=0 THEN VARIABLES:=0; 09198240
END ELSE SPOUT(9198260); 09198260
END; 09198270
DELTOG:=CURRENTMODE:=CURLINE:=INCREMENT:=0; 09198280
STOREPSR; 09198282
END; 09198290
09199000
LABEL SHORTCUT; 09200000
REAL L,U,TADD; 09201000
STREAM PROCEDURE CLEANBUFFER(BUFFER,BUFFSIZE,ADDR); 09208000
VALUE BUFFSIZE,ADDR; 09209000
BEGIN LABEL L; LOCAL T,U,TSI,TDI; 09210000
SI:=ADDR; SI:=SI-1; L: 09211000
IF SC NEQ "]" THEN 09212000
BEGIN SI:=SI-1; GO TO L END; 09213000
SI:=SI+1; DI:=LOC T; SKIP 2 DB; DS:=2SET; 09214000
DI:=BUFFER; TDI:=DI; DI:=LOC T; TSI:=SI; 09215000
BUFFSIZE(8(IF TOGGLE THEN DS:=LIT" " ELSE 09216000
IF SC=DC THEN 09217000
BEGIN SI:=LOC U; DI:=TDI; DS:=LIT" " 09218000
END ELSE 09219000
BEGIN TSI:=SI; SI:=SI-1; DI:=LOC U; DS:=CHR; 09220000
DI:=TDI; SI:=LOC U; DS:=CHR; TDI:=DI; DI:=LOC T; 09221000
SI:=TSI 09222000
END)) 09223000
END; 09224000
PROCEDURE BUFFERCLEAN(BUFFER,BUFFSIZE,ADDR); VALUE BUFFSIZE, 09224100
ADDR; REAL ADDR; INTEGER BUFFSIZE; ARRAY BUFFER[0]; 09224200
CLEANBUFFER(BUFFER,BUFFSIZE,ADDR); 09224300
COMMENT DETERMINE WHETHER OR NOT WE CAME FROM CALCULATOR MODE; 09225000
ERR:=0; 09225100
IF BOOLEAN(SUSPENSION) THEN GO TO ENDHANDLER; 09225110
BEGIN DEFINE STARTSEGMENT=#; %/////////////////////////////// 09225115
IF GT1:=CURRENTMODE=CALCMODE THEN % TAKE CARE OF HEADER. 09225200
BEGIN ARRAY A[0:MAXHEADERARGS]; 09225300
LABEL HEADERSTORE,FORGETITFELLA; 09225310
IF FUNCTIONHEADER(A,TADD) THEN %HEADER OK 09225400
IF VARIABLES NEQ 0 THEN % MAY BE A RE-DEFINITION 09225500
BEGIN COMMENT GET THE FUNCTION NAME; 09225600
TRANSFER(A,1,GTA,0,7); 09225700
IF GT2:=SEARCHORD(VARIABLES,GTA,GT3,7)=0 THEN 09225800
COMMENT RE-DEFINING A FUNCTION. MAKE SURE NULL ; 09225900
IF GETFIELD(GTA,7,1)=FUNCTION AND 09226000
(A[1]+A[2]+A[3])=0 THEN %NULL HEADER--OK 09226100
%--------------------SET UP FOR CONTINUATION OF DEFINITION------ 09226200
BEGIN 09226300
FUNCPOINTER:=GETFIELD(GTA,FPTF,FFL); 09226400
FUNCSEQ:=GETFIELD(GTA,FSQF,FFL); 09226500
GT3:=CURLINE:=TOPLINE(FPT); 09226600
CHECKSEQ(CURLINE,GT3,INC); %SET THE INCREMENT 09226700
COMMENT THE CURRENTLINE IS SET TO THE LAST LINE OF THE 09226800
FUNCTION; 09226900
FUNCSIZE:=SIZE(FPT); 09226910
CURLINE:=CURLINE+INC; 09226920
DELTOG:=DELPRESENT(ADDRESS); 09226930
END ELSE 09227000
%------------------REDEFINING THE HEADER OF A DEFINED FUNCTION---- 09227100
GO TO FORGETITFELLA 09227200
ELSE 09227300
%--------------------NAME NOT FOUND IN THE DIRECTORY, SET UP 09227400
HEADERSTORE: 09227410
BEGIN COMMENT GET THE HEADER TO INSERT AT LINE 0; 09227500
ARRAY OLDBUFFER[0:MAXBUFFSIZE]; 09227510
INTEGER L,U,F,K,J; 09227520
INTEGER A1,A2; 09227522
COMMENT FUNCTIONHEADER RETURN AN ARRAY WITH THE 09227530
FOLLOWING VALUES: 09227534
A[0] = FUNCTION NAME , I.E., 0AAAAAAA 09227538
A[1] = 0 IF NO RESULT, 1 IF A RESULT IS RETURNED BY THE 09227542
FUNCTION. 09227546
A[2] = NUMBER OF ARGUMENTS TO THE FUNCTION. 09227550
A[3] = NUMBER OF LOCALS + RESULT +ARGUMENTS. 09227554
A[4],...A[N] ARE ALL OF THE LOCALS, RESULT, AND ARGUMENTS. 09227558
THE RESULT IS FIRST, THEN THE SECOND ARGUMENT, THEN 09227562
THE FIRST ARGUMENT, FOLLOWED BY THE LOCALS. ALL 09227566
ARE OF THE FORM 0XXXXXXX; 09227570
U:=(A1:=A[1])+(A2:=A[2])+3; 09227580
FOR L:=4 STEP 1 UNTIL U DO %LOOK FOR DUPLICATES AMONG 09227584
FOR K:=L+1 STEP 1 UNTIL U DO %THE RESULT/ARGUMENT SET 09227588
IF A[L]=A[K] THEN GO TO FORGETITFELLA; 09227592
SEQUENTIAL(FUNCSEQ:=NEXTUNIT); 09227600
SETFIELD(GTA,8,8,STORESEQ(FUNCSEQ,OLDBUFFER, 09227700
HEADER(TADD.[1:23],TADD.[24:24],OLDBUFFER))); 09227800
SETFIELD(GTA,0,8,0); 09227900
STOREORD(F:=FUNCPOINTER:=NEXTUNIT,GTA,0); 09228000
SETFIELD(GTA,0,8,0); SETFIELD(GTA,8,8,0); 09228004
FOR L:=4 STEP 1 UNTIL U DO 09228006
BEGIN GTA[0]:=A[L]; IF A1 GTR 0 THEN 09228008
BEGIN A1:=0; GTA[1]:=-1; %"RESULT" SET TO -1 09228010
STOREORD(F,GTA,0); 09228012
END ELSE %LOOKING AT THE ARGUMENTS 09228014
BEGIN K:=SEARCHORD(F,GTA,J,8); 09228016
GTA[1]:=A2-4; A2:=A2-1; GTA[0]:=A[L]; 09228018
STOREORD(F,GTA,J+K-1); 09228019
END END; 09228020
FUNCSIZE:=U:=U-2; U:=A[3]-U+L; 09228022
FOR L:=L STEP 1 UNTIL U DO %GET LOCALS INTO THE LABEL TABLE 09228024
BEGIN GTA[0]:=A[L]; 09228030
IF K:=SEARCHORD(F,GTA,J,8) NEQ 0 THEN %NOT YET IN TABLE. 09228040
BEGIN GTA[0]:=A[L]; GTA[1]:=0; 09228050
STOREORD(F,GTA,J+K-1); 09228052
FUNCSIZE:=FUNCSIZE+1 09228060
END; 09228070
END; 09228080
GTA[1]:=0&ENTIER(A[1])[CRETURN]&ENTIER(A[2])[CNUMBERARGS]; 09228100
CURLINE:=INCREMENT:=1; 09228200
DELTOG:=0; 09228202
COMMENT GET THE "TYPE" OF THE FUNCTION LATER WHEN THERE 09228210
IS A PLACE FOR IT. THE TYPE IS EITHER 1 (FUNCTION CALL), OR 09228220
0 (SUBROUTINE CALL); 09228230
END 09228300
%-------------------------------------------------------- 09228400
END ELSE % VARAIBLES=0, MAKE UP A DIRECTORY 09228500
BEGIN GT3:=0; GT2:=1; GO TO HEADERSTORE 09228600
END 09228700
ELSE % HEADER SYNTAX IS BAD 09228800
GO TO ENDHANDLER; 09228900
COMMENT WE MAKE IT TO HERE IF ALL IS WELL ABOVE; 09229000
IF GT2 NEQ 0 THEN %NAME NOT FOUND IN DIRECTORY; 09229100
BEGIN 09229200
TRANSFER(A,1,GTA,0,7); %GET FUNCTION NAME 09229300
SETFIELD(GTA,7,1,FUNCTION); 09229400
SETFIELD(GTA,FPTF,FFL,FUNCPOINTER); 09229500
SETFIELD(GTA,FSQF,FFL,FUNCSEQ); 09229600
IF VARIABLES=0 THEN 09229700
VARIABLES:=NEXTUNIT; 09229800
STOREORD(VARIABLES,GTA,GT3+GT2-1); 09229900
VARSIZE:=VARSIZE+1; 09230000
END; 09230010
CURRENTMODE:=FUNCMODE; 09230100
TRANSFER(GTA,0,PSR,FSTART|8,8); 09230200
STOREPSR; 09230300
IF SCAN THEN GO TO SHORTCUT; 09230305
IF FALSE THEN 09230310
FORGETITFELLA: ERRORMESS(ERR:=LABELERROR,TADD.[1:23],0); 09230400
END ELSE % WE ARE IN FUNCTION DEFINITION MODE 09230500
IF GT1:=MODE NEQ 0 THEN % A SPECIAL FUNCTION SUCH AS DISPLAY OR EDIT09230600
BEGIN L:=LOWER; 09230700
IF GT1=DISPLAYING THEN 09230800
LISTLINE(FPT,FSQ,L) ELSE 09230900
IF GT1=EDITING THEN 09231000
BEGIN INITBUFF(BUFFER,BUFFSIZE); 09231010
MOVE(OLDBUFFER,BUFFSIZE,BUFFER); 09231020
EDITMODE:=TRUE; ADDRESS:=ABSOLUTEADDRESS; 09231030
EDITDRIVER(FPT,FSQ,L,L) 09231100
;IF NOT EDITMODE THEN 09231102
BEGIN MODE:=0; ERR:=30 09231104
END; 09231106
END ELSE 09231108
IF GT1=RESEQUENCING THEN 09231110
IF GT1:=L LEQ UPPER THEN 09231114
BEGIN GT2:=CONTENTS(FPT,L,GTA); 09231118
GT3:=GTA[0]:=LINENUMBER(CURLINE); 09231122
DELETE1(FPT,L); 09231124
STOREORD(FPT,GTA,L); 09231126
CURLINE:=CURLINE+INCREMENT; 09231130
GT2:=CONTENTS(FSQ,GTA[1],BUFFER); RESCANLINE; 09231134
WHILE (IF ERR NEQ 0 THEN FALSE ELSE 09231138
LABELSCAN(GTA,0)) DO 09231142
IF GT1:=SEARCHORD(FPT,GTA,GT2,8)=0 THEN 09231146
BEGIN GTA[1]:=GT3; DELETE1(FPT,GT2); 09231150
STOREORD(FPT,GTA,GT2) 09231154
END ELSE ERR:=16 09231158
END 09231162
ELSE MODE:=0; 09231166
LOWER:=L+1; 09231170
IF LOWER GTR UPPER THEN 09231200
BEGIN IF MODE=DISPLAYING THEN 09231300
FORMWD(3,"1 "); 09231400
MODE:=0; 09231500
END; 09231600
GO TO ENDHANDLER 09231700
END; 09231800
END ; %OF BLOCK STARTED ON LINE 9225115 /////////////////// 09232000
09233000
09234000
09235000
IF ERR=0 AND EOB=0 THEN 09236000
09237000
SHORTCUT: BEGIN LABEL RGTBRACK,DELOPTION; %/////////////////////// 09238000
IF DELV THEN FINISHUP ELSE 09239000
IF LFTBRACKET THEN 09240000
BEGIN 09241000
IF SCAN THEN 09242000
IF BOUND(FPT) THEN 09243000
BEGIN L:=ACCUM[0]; 09244000
IF SCAN THEN 09245000
IF QUADV OR EDITMODE:=(QUOTEQUAD) THEN 09246000
IF SCAN THEN 09247000
IF BOUND(FPT) THEN 09248000
BEGIN U:=ACCUM[0]; 09249000
RGTBRACK: 09250000
IF SCAN AND RGTBRACKET THEN 09251000
IF(IF EDITMODE THEN FALSE ELSE SCAN) THEN 09252000
IF DELV THEN 09253000
BEGIN ERR:=DISPLAY(L,U,FPT,FSQ); 09254000
DELTOG:=1; 09255000
END 09256000
ELSE ERR:=1 09257000
ELSE ERR:=DISPLAY(L,U,FPT,FSQ) 09258000
ELSE ERR:=2 09259000
END 09260000
ELSE 09261000
IF RGTBRACKET THEN 09262000
IF(IF EDITMODE THEN FALSE ELSE SCAN) THEN 09263000
IF DELV THEN 09264000
BEGIN ERR:=DISPLAY(L,L,FPT,FSQ); 09265000
DELTOG:=1; 09266000
END 09267000
ELSE ERR:=3 09268000
ELSE ERR:=DISPLAY(L,L,FPT,FSQ) 09269000
ELSE ERR:=4 09270000
ELSE ERR:=5 09271000
ELSE 09272000
IF RGTBRACKET THEN 09273000
BEGIN TADD:=ADDRESS; 09274000
IF SCAN THEN 09275000
IF IDENT AND ACCUM[0]="6DELETE" THEN 09276000
IF SCAN THEN 09277000
IF LFTBRACKET THEN 09278000
DELOPTION: 09279000
IF SCAN AND BOUND(FPT) THEN 09280000
BEGIN U:=ACCUM[0]; 09281000
IF SCAN AND RGTBRACKET THEN 09282000
IF SCAN THEN 09283000
IF DELV THEN 09284000
BEGIN ERR:=DELETE(L,U,FPT,FSQ); 09285000
FINISHUP 09286000
END 09287000
ELSE ERR:=6 09288000
ELSE ERR:=DELETE(L,U,FPT,FSQ) 09289000
ELSE ERR:=7 09290000
END 09291000
ELSE ERR:=8 09292000
ELSE 09293000
IF DELV THEN 09294000
BEGIN ERR:=DELETE(L,L,FPT,FSQ); 09295000
FINISHUP 09296000
END 09297000
ELSE ERR:=9 09298000
ELSE ERR:=DELETE(L,L,FPT,FSQ) 09299000
ELSE 09300000
IF LFTBRACKET THEN GO TO DELOPTION ELSE 09301000
BEGIN CHECKSEQ(SEQ,L,INC); 09302000
CLEANBUFFER(BUFFER,BUFFSIZE,TADD); 09303000
ADDRESS:=ABSADDR(BUFFER); ITEMCOUNT:=0; 09304000
IF SCAN THEN GO TO SHORTCUT 09305000
END 09306000
ELSE ERR:=DELETE(L,L,FPT,FSQ) 09307000
END 09308000
ELSE ERR:=10 09309000
ELSE ERR:=11 09310000
END ELSE 09311000
IF QUADV OR EDITMODE:=(QUOTEQUAD) THEN 09312000
BEGIN L:=0; U:=9999.9999; GO TO RGTBRACK 09313000
END ELSE 09314000
IF IOTA THEN 09314200
IF SCAN AND RGTBRACKET AND FPT NEQ 0 THEN 09314300
BEGIN IF SCAN THEN 09314310
IF DELV THEN DELTOG:=1 ELSE ERR:=15; 09314330
IF ERR = 0 THEN 09314340
BEGIN MODE:=RESEQUENCING; CURLINE:=INCREMENT:=1; 09314350
SETFIELD(GTA,0,8,0); 09314400
GT1:=SEARCHORD(FPT,GTA,GT2,8); 09314410
LOWER:=GT2+1; UPPER:=FUNCSIZE-1 09314420
END 09314500
END 09314600
ELSE ERR:=14 09314700
ELSE ERR:=12 09315000
ELSE ERR:=13 09316000
END 09317000
ELSE 09318000
IF CURLINE=0 THEN %CHANGING HEADER 09318100
ERR:=26 ELSE 09318110
IF ERR:=OLDLABCONFLICT(FPT,LINENUMBER(SEQ))=0 THEN 09319000
BEGIN 09320000
IF NOSYNTAX=0 THEN PROCESS(XEQUTE); 09321000
IF ERR:=STOREAWAY(FPT,FSQ,BUFFER,SEQ)=0 THEN SEQ:=SEQ+INC; 09322000
END; 09323000
IF ERR NEQ 0 THEN 09324000
BEGIN FORMWD(2,"5ERROR "); 09325000
NUMBERCON(ERR,ACCUM); ERR:=0; 09326000
EOB:=1; 09327000
FORMROW(1,1,ACCUM,2,ACCUM[0].[1:11]); 09328000
END; 09329000
END; %OF BLOCK STARTED ON LINE 9238000 ////////////////////// 09330000
ENDHANDLER: 09330100
IF BOOLEAN(SUSPENSION) THEN BEGIN 09330102
FILL ACCUM[*] WITH "ABORT SU", "SP. FNS."; 09330104
FORMROW(3,0,ACCUM,0,16); INDENT(0); TERPRINT; 09330106
END ELSE 09330108
IF MODE=0 THEN 09330110
BEGIN 09330112
IF BOOLEAN(DELTOG) THEN FINISHUP; 09330120
INDENT(-CURLINE); TERPRINT; 09330200
END; 09330210
09331000
END; 09332000
EXPOVR:=FAULTL; INTOVR:=FAULTL; INDEXF:=FAULTL; 09332100
FLAG:=FAULTL; ZERO:=FAULTL; 09332200
INITIALIZETABLE; 09333000
TRYAGAIN: 09334000
IF FALSE THEN %ENTERS WITH A FAULT. 09334100
FAULTL: 09334200
BEGIN SPOUT(09334300); %SEND A MESSAGE TO SPO 09334300
09334400
BEGIN CSTATION.APLOGGED:=0; CSTATION.APLHEADING:=0 09334500
END 09334600
END; 09334700
APLMONITOR; 09335000
ENDOFJOB: 09336000
09337000
FINIS: 09338000
WRAPUP; 09339000
09340000
END. 09341000
END;END. LAST CARD ON 0CRDING TAPE 99999999
Reference in New Issue View Git Blame Copy Permalink