github.com/retro-software.B5500-software
1
0
Fork 0
mirror of https://github.com/retro-software/B5500-software.git synced 2026-01-19 17:17:48 +00:00
Code Issues Releases Wiki Activity
retro-software.B5500-software/source/APL/IMAGE.alg_m

5487 lines
395 KiB
Plaintext
Raw Blame History

BEGIN 00000490P01
% THIS APL/B5500 PROGRAM WAS DEVELOPED BY THE COMPUTER SCIENCE GROUP
% AT THE UNIVERSITY OF WASHINGTON UNDER THE SPONSORSHIP OF PROFESSOR
% HELLMUT GOLDE. THE PROGRAM MAY BE NOT BE OFFERED FOR SALE OR LEASE
% IN ITS ORIGINAL OR ANY MODIFIED FORM. ANY PUBLICATION RELATING TO
% THIS PROGRAM OR ANY MODIFICATION OF THE PROGRAM MUST EXPLICITLY CREDIT
% THE COMPUTER SCIENCE GROUP OF THE UNIVERSITY OF WASHINGTON AND THE
% PRINCIPAL IMPLEMENTORS, GARY KILDALL, LEROY SMITH, SALLY SWEDINE,
% AND MARY ZOSEL. COMPUTER RESOURCES FOR THE DEVELOPMENT OF THE
% PROGRAM WERE MADE AVAILABLE BY THE UNIVERSITY OF WASHINGTON COMPUTER
% CENTER.
DEFINE VERSIONDATE="1-11-71"# ;
%MODIFICATIONS FOR B-5500 TIME-SHARING MCP MADE BY:
% JOSE HERNANDEZ, BURROUGHS CORPORATION.
BOOLEAN BREAKFLAG;
ARRAY GIA[0:1];
LABEL FINIS; %GO THERE WHEN YOU ARE IN TROUBLE (SPOUT A MESSAGE)
BOOLEAN PROCEDURE LIBRARIAN(A,B); VALUE A,B: REAL A,B; FORWARD;
LABEL FAULTL; % FAULT LABEL
MONITOR EXPOVR,INTOVR,INDEX:=INDEXF,FLAG,ZERO;
REAL BIGGEST, NULLV;
INTEGER STACKSIZE,LIBSIZE;
REAL STATUSWORD,CORELOC;
BOOLEAN RETURN;
BOOLEAN MEMBUG,DEBUG;
COMMENT MEMBUG SWITCHES ----------------------
BIT FUNCTION BIT FUNCTION
-----------------------------------------------------------------
1 25
2 26
3 27
4 28
5 DUMP TYPES @ INSERT 30
6 DUMP TYPES @ DELETE 30
7 31
8 32
9 33
10 34
11 35
12 36
13 37
14 38
15 39
16 40
17 41
18 42
19 43
20 DUMP INDEX 44
21 45
22 DUMP TYPES 46
23 CHECK TYPES 47
24 DUMP BUFFER #S
;
FILE PRINT 4 "SYSTEMS" " BOX " (1,15);
FILE TWXIN 19(2,30),TWXOUT 19(2,10);
%
DEFINE
PAGESIZE=120#,
AREASIZE=40#,
CF=[26:13]#, COMMENT COUNT FIELD -- NUMBER OF ITEMS ON PAGE;
TF=[39:9] #, COMMENT T-FIELD (TYPE FIELD);
FF=[9:1]#, COMMENT FULL FIELD FOR SEQUENTIAL STORAGE;
AF=[1:23] #, COMMENT A-FIELD;
BF=[24:23]#, COMMENT B-FIELD;
MF=[1:1]#, COMMENT METHOD OF STORAGE FIELD;
SF=[13:13]#, COMMENT SEQUENTIAL STORAGE SIZE FIELD (#CHRS);
BOOL=[47:1]#,
SKIP=1#, COMMENT --AMOUNT OF SPACE RESERVED AT THE
START OF EACH PAGE;
ALLOWANCE=10#, COMMENT --DEVIATION FROM THE AVERAGE PAGE SIZE
ALLOWED BEFORE CORRECTION; 00001550P02
RECSIZE=2#,
MAXPAGES=20#,
PAGESPACE=20#,
NEXTP=[42:6]#,
LASTP=[36:6]#,
PAGEF=[19:11]#,
BUFF=[12:6]#,
CHANGEDBIT=[1:1]#,
MBUFF=8#,
SBUFF=4#,
FLAGB=[18:1]#, COMMENT FLAG BIT FOR BUFFER MAINTENANCE;
EXTRAROOM=1#,
LIBJOB="/APLIBE"#,%MFID FOR APL SYSTEM FILE
ENDOFDEFINES=#;
REAL PROCEDURE CDR(X); VALUE X; REAL X; CDR:=X.NEXTP;
PROCEDURE RPLACD(X,Y); VALUE Y;REAL X,Y; X.NEXTP:=Y;
BOOLEAN PROCEDURE NULL(X); VALUE X; REAL X; NULL:=X.NEXTP=0;
BOOLEAN STREAM PROCEDURE EOFMARK(SK,RS,A); VALUE SK,RS;
BEGIN LABEL NO; SI:=A; SK(SI:=SI+8);
RS(8( 2(IF SB THEN JUMP OUT 3 TO NO; SKIP SB);
3(IF SB THEN SKIP SB ELSE JUMP OUT 3 TO NO); IF SB THEN
JUMP OUT 2 TO NO; SKIP SB));TALLY:=1;EOFMARK:=TALLY;
NO:
END;
STREAM PROCEDURE MARKEOF(SK,RS,A); VALUE SK,RS;
BEGIN DI:=A;
SK(DI:=DI+8);
RS(8(DS:=2RESET; DS:=3SET; DS:=RESET));
END;
SAVE FILE ESTABLISH DISK [MAXPAGES:AREASIZE]
(1,PAGESIZE,SAVE 100);
FILE NEWDISK DISK (1,PAGESIZE);
FILE DISK1 DISK (1,PAGESIZE),
DISK2 DISK (1,PAGESIZE),
DISK3 DISK (1,PAGESIZE),
DISK4 DISK (1,PAGESIZE),
DISK5 DISK (1,PAGESIZE),
DISK6 DISK (1,PAGESIZE),
DISK7 DISK (1,PAGESIZE),
DISK8 DISK (1,PAGESIZE);
SWITCH FILE POINTERS:=DISK1,DISK1,DISK2,DISK3,DISK4,DISK5,DISK6,DISK7,
DISK8;
PROCEDURE SETPOINTERNAMES;
BEGIN
IF NOT LIBRARIAN(LIBJOB,TIME(-1)) THEN
BEGIN
WRITE(ESTABLISH);
MARKEOF(SKIP,RECSIZE,ESTABLISH(0));
WRITE(ESTABLISH[1]);
WRITE(ESTABLISH[MAXPAGES|AREASIZE-1]);
LOCK(ESTABLISH);
CLOSE(ESTABLISH)
;LIBSIZE~-1;
END
END;
DEFINE
LIBMAINTENANCE=0#,
MESSDUM=#;
PROCEDURE MEMORY(MODE,TYPE,A,N,M);VALUE MODE,TYPE;
INTEGER MODE,TYPE,N,M; ARRAY A[0]; FORWARD;
STREAM PROCEDURE MOVE(A,N,B); VALUE N;
BEGIN SI:=A; DI:=B; DS:=N WDS;
END;
PROCEDURE MESSAGE(I); VALUE I; INTEGER I;
BEGIN
FORMAT F("MEMORY ERROR",I5);
COMMENT CHANGE LINE 3050 TO WRITE(PRINT,SF[I]) FOR MEMORY ERROR PROBS.
THIS FORMAT IS NOW EXCLUDED SINCE MEMORY IS SEEMINGLY WELL DEBUGED
SWITCH FORMAT SF:=
("LIBRARY MAINTENANCE IN PROGRESS."),
("SYSTEM ERROR--MEMORY ACCESS WITH EXPRESSION FOR N OR M."),
("SYSTEM ERROR--IMPROPER ARGUMENTS TO FREEPAGE."),
("SYSTEM ERROR--TOO LARGE A SUBSCRIPT FOR TYPE SPECIFIED."),
("SYSTEM ERROR--TYPE CANNOT BE ZERO WHEN INSERTING OR DELETING."),
("SYSTEM ERROR--CHARACTER STTRING TOO LONG TO STORE."),
("SYSTEM ERROR--ATTEMPT TO INSERT NON-SEQUENTIAL ELEMENT",
"IN TYPE A STORAGE."),
("SYSTEM ERROR--NO BLANKS IN PAGES."),
("SYSTEM ERROR--ATTEMPTED BINARY SEARCH OF UNORDERED DATA."),
("SYSTEM ERROR--BINARY SEARCH OF UNALLOCATED DATA ATTEMPTED."),
("SYSTEM ERROR--BINARY SEARCH FOUND A BLANK PAGE."),
("SYSTEM ERROR--DELETION OF TYPE B STORAGE NOT IMPLEMENTED."),
("SYSTEM ERROR--ATTEMPT TO DELETE FROM NON-EXISTENT STORAGE."), 00002970P03
("SYSTEM ERROR--ATTEMPT TO DELETE RECORD FROM OUTSIDE",
" ALLOCATED STORAGE."),
("SYSTEM ERROR--ATTEMPTED MEMORY SEARCH WITH -N- TOO LARGE."),
("SYSTEM ERROR--ATTEMPT TO CHANGE PREVIOUSLY DESIGNATED STORAGE",
" KIND"),
("SYSTEM ERROR--POINTERS TO DATA TYPES OVERLAP."),
(" ");
WRITE(PRINT,F,I);
IF I GTR 0 THEN
BEGIN
INTEGER GT1,GT2,GT3;
MEMORY(10,GT1,GIA,GT2,GT3);
GO TO FINIS;
END;
END;
PROCEDURE MEMORY(MODE,TYPE,A,N,M); VALUE MODE,TYPE;
INTEGER MODE,TYPE,N,M; ARRAY A[0];
BEGIN
DEFINE T64= DI:=LOC T; DI:=DI+1; DS:=7 CHR#;
STREAM PROCEDURE WRITERECS(PAGE,A,SKP,NB,NR,NS,RL);
VALUE SKP,NB,NR,NS,RL;
BEGIN
COMMENT -- NS IS THE NUMBER OF WORDS TO SAVE (ON THE
TAIL OF THE PAGE);
LOCAL T,T1,T2,TT;
COMMENT -- MOVE TO POSITION FOR WRITE;
SI:=LOC NB; T64; SI:=PAGE; SKP(SI:=SI+8);
T(2(32(RL(SI:=SI+8)))); NB(RL(SI:=SI+8));
T1:=SI; COMMENT -- RECORDS WILL BE WRITTEN HERE;
DI:=LOC TT; SI:=LOC NS; DI:=DI+1; DS:=7CHR;
SI:=T1; COMMENT MOVE TO THE END OF THE FIELD TO BE SAVED;
TT(2(32(RL(SI:=SI+8)))); NS(RL(SI:=SI+8));
T2:=SI; COMMENT -- END OF FIELD TO BE SAVED;
SI:=LOC NR; T64; DI:=T2;
T(2(32(RL(DI:=DI+8)))); NR(RL(DI:=DI+8));
SI:=T2; SI:=SI-8; DI:=DI-8;
TT(2(32(RL(DS:=WDS; SI:=SI-16); DI:=DI-16))));
NS(RL(DS:=WDS; SI:=SI-16; DI:=DI-16));
COMMENT -- HAVE ACCOMPLISHED THE "SAVE", NOW DO THE WRITE;
SI:=A; DI:=T1;
T(2(32(DS:=RL WDS))); NR(DS:=RL WDS)
END;
STREAM PROCEDURE READRECS(PAGE,A,SKP,NB,NR,NM,RL);
VALUE SKP,NB,NR,NM,RL;
BEGIN
COMMENT
SKP = "SKIP" - - THE NUMBER OF WORDS TO JUMP OVER
NB = "NUMBER BEFORE" -- " " RECORDS TO SKIP BEFORE
READING THE RECORD,
NR = "NUMBER OF RECORDS" " " " " READ FROM THE
BUFFER,
NM ="NUMBER TO MOVE" - - " " " " MOVE OVER TO
THE PREVIOUSLY READ AREA,
RL ="RECORD LENGTH" - - THE LENGTH OF EACH ITEM
;
LOCAL T,T1,T2;
SI:=LOC NB; T64; SI:=PAGE; SKP(SI:=SI+8);
T(2(32(RL(SI:=SI+8)))); NB(RL(SI:=SI+8));
T1:=SI;
COMMENT - - T1 NOW HAS THE STARTING POSITION FOR THE READ;
SI:=LOC NR; T64; SI:=T1; DI:=A;
T(2(32(DS:=RL WDS))); NR(DS:=RL WDS);
T2:=SI; COMMENT T2 CONTAINS THE END OF THE READ;
SI:=LOC NM; T64; SI:=T2; DI:=T1;
T(2(32(DS:=RL WDS))); NM(DS:=RL WDS)
END READRECS;
DEFINE MOVEALOG=
DI:=LOC C; DI:=DI+6; DS:=2CHR; DI:=LOC Z;
TSI:=SI; TALLY:=TALLY+1;
IF TOGGLE THEN
BEGIN SI:=LOC C; SI:=SI+6;
IF 2 SC NEQ DC THEN
BEGIN TAL:=TALLY; SI:=LOC TAL; SI:=SI+7;
IF SC="0" THEN
BEGIN TALLY:=TMP; TALLY:=TALLY+1; TMP:=TALLY;
TALLY:=0;
END ELSE
BEGIN SI:=LOC Z; IF SC LEQ"9" THEN ;
END
END ELSE
BEGIN DI:=TDI; SI:=LOC SIZE; SI:=SI+6; DS:=2CHR;
TDI:=DI; SI:=SI-2; DI:=LOC C64; DI:=DI+7 ; DS:=CHR; 00003750P04
SI:=NEW; DI:=TDI; C64(2(DS:=32CHR)); DS:=SIZE CHR;
TDI:=DI; SI:=TSI; DI:=LOC C; DI:=DI+6;
DS:=2CHR; TSI:=SI;
TALLY:=TAL;CHRSTORE:=TALLY; SI:=LOC TMP; SI:=SI+7;
DI:=LOC CHRSTORE; DI:=DI+6; DS:=CHR END
END;
SI:=LOC C; DI:=LOC C64; DI:=DI+1; DS:=7CHR; DI:=TDI; SI:=SI-1;
DS:=2CHR; SI:=TSI;
C64(2(DS:=32CHR)); DS:=C CHR; TDI:=DI; TSI:=SI#;
INTEGER STREAM PROCEDURE CHRSTORE(A,SKP,B,NEW,NB,SIZE,NA,MODE,
PAGESIZE); VALUE SKP,NB,SIZE,NA,MODE,PAGESIZE;
BEGIN LOCAL T,C,TSI,TDI,
Z,C64,TMP,TAL;
LABEL DONE;
SI:=LOC NB; T64;
SI:=LOC MODE; SI:=SI+7;
IF SC="0" THEN ; COMMENT SET TOGGLE;
SI:=A; DI:=B; SKP(DS:=8CHR);
TSI:=SI; TDI:=DI;
T(2(32(MOVEALONG))); NB(MOVEALONG);
COMMENT NOW HAVE MOVED UP TO NB;
IF TOGGLE THEN
BEGIN TALLY:=TAL; CHRSTORE:=TALLY; SI:=LOC TMP; SI:=SI+7;
DI:=LOC CHRSTORE; DI:=DI+6; DS:=CHR;
SI:=LOC SIZE; SI:=SI+6; DI:=TDI; DS:=2CHR; TDI:=DI;
SI:=LOC SIZE; DI:=LOC C64; DI:=DI+1; DS:=7CHR; SI:=NEW;
DI:=TDI; C64(2(DS:=32CHR)); DS:=SIZE CHR;
END ELSE
BEGIN TSI:=SI; TDI:=DI;
SI:=LOC MODE; SI:=SI+7;
IF SC="1" THEN
COMMENT REMOVE AN ENTRY HERE;
BEGIN DI:=LOC C; DI:=DI+6; SI:=TSI; DS:=2CHR;
TSI:=SI; DI:=LOC C64; DI:=DI+1; SI:=LOC C;
DS:=7CHR; SI:=TSI; C64(2(SI:=SI+32)); SI:=SI+C;
TSI:=SI; DI:=LOC CHRSTORE; SI:=LOC C; DS:=WDS;
DI:=TDI; DS:=2LIT"0"; TDI:=DI;
END ELSE
IF SC="2" THEN
COMMENT READ OUT AND ENTRY
BEGIN DI:=LOC C; DI:=DI+6; SI:=TSI; DS:=2CHR;
TSI:=SI; DI:=LOC C64; DI:=DI+1; SI:=LOC C;
DS:=7CHR; SI:=TSI; DI:=NEW;
C64(2(DS:=32CHR)); DS:=C CHR;
SI:=LOC C; DI:=LOC CHRSTORE; DS:=WDS; GO DONE END;
SI:=LOC NA; T64; SI:=TSI; DI:=TDI;
T(2(32(TDI:=DI; DI:=LOC C; DI:=DI+6; DS:=2CHR;
TSI:=SI; SI:=LOC C; DI:=LOC C64; DI:=DI+1; DS:=7CHR;
SI:=SI-1;DT:=TDI;DS:=2CHR;SI:=TSI;C64(2(DS:=32CHR));DS:=C CHR)));
NA( TDI:=DI; DI:=LOC C; DI:=DI+6; DS:=2CHR; TSI:=SI;
SI:=LOC C;DI:=LOC C64;DI:=DI+1;DS:=7CHR;SI:=SI-1;
DI:=TDI;DS:=2CHR;SI:=TSI;C64(2(DS:=32CHR));DS:=C CHR);
END;
SI:=LOC PAGESIZE; T64; SI:=B; DI:=A;
%CARD LIST UNSAFE
COMMENT $CARD LIST UNSAFE;
T(2(DS:=32WDS)); DS:=PAGESIZE WDS;
%CARD LIST SAFE
COMMENT $CARD LIST SAFE;
DONE:
END;
STREAM PROCEDURE SETNTH(P,K,N); VALUE K,N;
BEGIN DI:=P; SI:=LOC K; N(DI:=DI+8); DS:=WDS END;
BOOLEAN STREAM PROCEDURE LESS(A,AN,B,BN,K); VALUE K,AN,BN;
BEGIN
SI:=A; DI:=B; SI:=SI+AN; DI:=DI+BN;
IF K SC LSS DC THEN TALLY:=1;
LESS:=TALLY;
END;
REAL STREAM PROCEDURE ADDD(A,B); VALUE A,B;
BEGIN SI:=LOC A; DI:=LOC B; DS:=8ADD; SI:=LOC B;
DI:=LOC ADDD; DS:=WDS
END;
INTEGER PROCEDURE FREEPAGE(INDEX,TYPEZERO,START,FINISH);
VALUE TYPEZERO,START,FINISH; INTEGER TYPEZERO,START,FINISH;
ARRAY INDEX[0,0];
IF START GTR FINISH THEN MESSAGE(2) ELSE
BEGIN ARRAY T[0:RECSIZE+EXTRAROOM+SKIP-1],P[0:FINISH-START];
INTEGER T,J,K,R;
R:=RECSIZE+EXTRAROOM+SKIP;
J:=START-(FINISH+1);
FOR I:=FINISH STEP -1 UNTIL TYPEZERO DO
IF K:=(I+J) LESS TYPEZERO THEN 00004690P05
BEGIN T[R-1]:=P[TYPEZERO-K-1];
MOVE(T,R,INDEX[I,0])
END ELSE
BEGIN IF I GEQ START THEN P[FINISH-I]:=INDEX[I,R-1];
MOVE(INDEX[K,0],R,INDEX[I,0]);
END;
FREEPAGE:=TYPEZERO-J;
END;
INTEGER PROCEDURE SEARCH(A,B,N,MIN,MAX,NP); VALUE N,MIN,MAX;
INTEGER N,MIN,MAX,NP;
ARRAY A[0,0]; REAL B;
BEGIN
INTEGER I,T;
FOR I:=MIN STEP 1 WHILE T:=T+A[I,0].CF LEQ B AND I LESS MAX-1 DO;
IF T LSS B THEN
BEGIN MESSAGE(3); SEARCHL:=NP:=0;
END ELSE
BEGIN SEARCHL:=I; NP:=B-T+A[I,0].CF
END
END;
PROCEDURE SORT(A,P,N,C); VALUE P,N,C; INTEGER P,N,C;
ARRAY A[0,0];
BEGIN INTEGER R;
BEGIN
ARRAY T[0:R:=RECSIZE+EXTRAROOM+SKIP-1];
LABEL ENDJ;
INTEGER I,J,L,K,M,SK; R:=R+1;
SK:=SKIP TIMES 8;
K:=N-P+1; I:=1; DO UNTIL (I:=I TIMES 2) GTR K;
M:=I-1;
WHILE (M:=M DIV 2) NEQ 0 DO
BEGIN K:=N-M; J:=P;
DO BEGIN
L:=(I:=J)+M;
DO BEGIN
IF A[L,0].TF GTR A[I,0].TF THEN GO ENDJ;
IF A[L,0].TF EQL A[I,0].TF THEN
IF NOT(LESS(A[L,0],SK,A[I,0],SK,C)) THEN
GO ENDJ;
MOVE(A[L,0],R,T); MOVE(A[I,0],R,A[L,0]);
MOVE(T,R,A[I,0])
END UNTIL (I:=(L:=I)-M) LSS P;
ENDJ:
END UNTIL (J:=J+1) GTR K;
END
END
END SORT;
COMMENT - - - - - - - - - - - - - - - - - - - - - - - - - -
MODE MEANING
---- -------
1 = INTERROGATE TYPE
2 = INSERT RECORD REL ADDRS N
(RELATIVE TO START OF LAST PAGE)
3 = RETURN THE NUMBER OF RECORDS (M)
4 = " ITEM AT RECORD # N
5 = INSERT " " " " "
6 = DELETE " " " " "
7 = SEARCH FOR THE RECORD -A-
8 = FILE OVERFLOW, INCREASE BY N
9 = FILE MAINTENANCE
10 = EMERGENCY FILE MAINTENANCE
11 SET STORAGE KIND
12= ALTER STORAGE ALLOCATION RESOURCES
13= RELEASE "TYPE" STORAGE TO SYSTEM
14= CLOSE ALL PAGES FOR AREA TRANSITION
NOTE THAT WHEN SEQUENTIAL STORAGE MAINTENANCE IS DONE, N
WILL ALWAYS INDICATE THE ADDRESS OF THE STRING RELATIVE TO
THE TYPE SPECIFIED, AND M WILL ALWAYS BE THE LENGTH OF THE
STRING IN -A- (EITHER AS INPUT OR OUTPUT)
;
PROCEDURE UPDATE(T,L,U,D); VALUE L,U,D; INTEGER L,U,D;
ARRAY T[0];
BEGIN INTEGER I,J,K;
FOR I:=L STEP 1 UNTIL U DO
BEGIN J:=T[I].AF+D; T[I].AF:=J;
J:=T[I].BF+D; T[I].BF:=J
END
END;
OWN INTEGER CURPAGE,NPAGES,NTYPES,P,PS,U,L;
OWN INTEGER FIRST,AVAIL,MAXBUFF,CURBUFF;
REAL GT1;
LABEL MOREPAGES;
COMMENT 00005615P06
IF MEMBUG.[21:1] THEN DUMPMEMORY(MODE,TYPE,N,M);
IF MODE=8 THEN NPAGES:=NPAGES+N;
MOREPAGES:
BEGIN
OWN BOOLEAN POINTERSET, TYPESET;
INTEGER I, T, NR;
OWN ARRAY BUF[0:MBUFF], TYPS[0:511];
OWN ARRAY INDX[0:NPAGES,0:RECSIZE+EXTRAROOM+SKIP-1];
PROCEDURE SETTYPES;
BEGIN INTEGER I, T;
FOR I := 0 STEP 1 UNTIL NPAGES DO
IF INDX[I,0].TF NEQ T THEN
BEGIN
TYPS[T].BF := I; TYPS[T:=INDX[I,0].TF].AF := I;
TYPS[T].BOOL := INDX[I,0].MF;
END;
TYPS[T].BF := I;
END SETTYPES;
REAL PROCEDURE BUFFNUMBER(I); VALUE I; INTEGER I;
BEGIN INTEGER K,L,M;
LABEL D;
DEFINE B=BUF#;
IF( IF K:=INDX[I,P].BUFF=0 THEN TRUE ELSE BUF[K].PAGEF
NEQ INDX[I,P].PAGEF+1) THEN
BEGIN IF NULL(K:=CDR(AVAIL)) THEN
BEGIN K:=CDR(FIRST);
WHILE M:=CDR(B[K]) NEQ 0 DO
BEGIN L:=K; K:=M; END;
RPLACD(B[L],0);
IF BOOLEAN(B[K].CHANGEDBIT) THEN
WRITE(POINTERS[K][B[K].PAGEF-1]);
B[K].CHANGEDBIT:=0;
END ELSE RPLACD(AVAIL,CDR(B[K]));
B[K].PAGEF:=INDX[I,P].PAGEF+1;
INDX[I,P].BUFF:=K;
READ(POINTERS[K][INDX[I,P].PAGEF]);
END ELSE
IF CDR(FIRST)=K THEN GO TO D ELSE
BEGIN L:=CDR(FIRST);
WHILE M:=CDR(B[L]) NEQ K DO L:=M;
RPLACD(B[L],CDR(B[M]));
END;
RPLACD(B[K],CDR(FIRST)); RPLACD(FIRST,K);
B: BUFFNUMBER:=K
END;
PROCEDURE MARK(I); VALUE I; INTEGER I;
BUF[INDX[I,P].BUFF].CHANGEDBIT:=1;
BOOLEAN PROCEDURE WRITEBUFFER;
BEGIN INTEGER I;
I:=CDR(FIRST);
WHILE NOT NULL(I) DO
IF BOOLEAN(BUF[I].CHANGEDBIT) THEN
BEGIN WRITEBUFFER:=TRUE;
BUF[I].CHANGEDBIT:=0;
WRITE(POINTERS[I][BUF[I].PAGEF-1]);
RPLACD(I,0);
END ELSE I:=CDR(BUF[I]);
END;
IF NOT POINTERSET THEN
BEGIN LABEL EOF;
READ(POINTERS[1][NPAGES])[EOF];
IF EOFMARK(SKIP,RECSIZE,POINTERS[1](0))THEN GO TO EOF;
MOVE(POINTERS[1](0),1,T);
COMMENT -- USE T TO DETERMIN THE VARIABLE REC SIZE LATER;
MOVE(POINTERS[1](0),RECSIZE+SKIP,INDX[NPAGES,0]);
INDX[NPAGES,RECSIZE+1].PAGEF:=NPAGES;
NPAGES:=NPAGES+1;
GO TO MOREPAGES;
COMMENT - - INITIALIZE VARIABLES;
EOF: POINTERSET:=TRUE;
U:=PAGESIZE-SKIP-PAGESPACE;
L:=(U-ALLOWANCE)/RECSIZE;
U:=(U+ALLOWANCE+RECSIZE/2)/RECSIZE;
PS:=(U+L)/2;
CURPAGE:=NPAGES:=NPAGES-1;
CURBUFF:=1;
P:=RECSIZE+SKIP;
FOR T:=1 STEP 1 UNTIL SBUFF DO RPLACD(BUF[T],T+1);
RPLACD(BUF[SBUFF],0); RPLACD(AVAIL,1);
MAXBUFF:=SBUFF;
T:=0;
SORT(INDX,0,NPAGES,RECSIZE TIMES 8);
FOR I:=0 STEP 1 UNTIL NPAGES DO 00006370P07
IF INDX[I,0].TF GTR T THEN T:=INDX[I,0].TF;
NTYPES:=T;
END;
IF TYPE GTR NTYPES THEN NTYPES:=TYPE;
IF NOT TYPESET THEN
BEGIN TYPESET:=TRUE; SETTYPES;
COMMENT
IF MEMBUG THEN DUMPINDEX(TYPS,NTYPES,INDX,RECSIZE,
P);
END;
COMMENT --- DECIDE WHETHER TO SAVE CURRENT PAGE BEFORE GOING ON;
IF MODE=2 THEN
BEGIN MODE:=5; NR:=N
END ELSE
IF MODE GEQ 4 THEN %MAY BE FILE MAINTENANCE
IF MODE GEQ 8 THEN %IS FILE MAINTENANCE
ELSE %WE MAY BE GOING TO
IF MODE NEQ 7 THEN %ANOTHER PAGE
BEGIN
IF TYPE=0 THEN BEGIN MESSAGE(4); MODE:=0 END ELSE
IF TYPS[TYPE].AF=TYPS[TYPE].BF THEN
IF TYPS[0].BF GTR 0 THEN
BEGIN INTEGER J,K; REAL PG;
K:=TYPS[0].BF-1; TYPS[0].BF:=K; PG:=INDX[K,P];
FOR I:=1 STEP 1 UNTIL TYPE-1 DO
IF (T:=TYPS[I]).AF NEQ T.BF THEN
BEGIN FOR K:=T.AF STEP 1 UNTIL T.BF -1 DO
MOVE(INDX[K,0]),P+EXTRAROOM,INDX[K-1,0]);
TYPS[I].AF:=T.AF-1; TYPS[I].BF:=K:=T.BF-1
END;
IF CURPAGE GTR TYPS[0].BF THEN
IF CURPAGE LEQ K THEN CURPAGE:=CURPAGE-1;
TYPS[TYPE].BF:=K+1; TYPS[TYPE].AF:=K;
INDX[K,P]:=PG; INDX[K,0]:=0; INDX[K,0].TF:=TYPE;
IF TYPS[TYPE].BOOL=1 THEN
BEGIN SETNTH(INDX[K,0],0,1); INDX[K,0].MF:=1
END;
COMMENT
IF MEMBUG.[22:1] THEN DUMPTYPES(MODE,TYPS,NTYPES);
MEMORY(MODE,TYPE,A,N,M); MODE:=0
END ELSE
BEGIN T:=1; MEMORY(8,TYPE,A,T,M); MEMORY(MODE,TYPE,A,N,M);
MODE:=0
END ELSE
IF NOT( BOOLEAN(TYPS[TYPE].BOOL) AND MODE=5) THEN
CURBUFF:=BUFFNUMBER(CURPAGE:=
SEARCHL(INDX,N,NPAGES,TYPS[TYPE].AF,TYPS[TYPE].BF,
NR) );
COMMENT
IF MEMBUG.[23:1] THEN CHECKTYPES(TYPS,NTYPES);
END;
COMMENT
IF MEMBUG.[20:1] THEN DUMPINDEX(TYPS,NTYPES,INDX,RECSIZE,P);
COMMENT
IF MEMBUG.[24:1] THEN DUMPBUFF(BUF,FIRST,AVAIL);
CASE MODE OF
BEGIN
%------- MODE=0 ------- RESERVED ---------------
;
%------- MODE=1 --------------------------------------------------
IF M=0 THEN N:=TYPS[TYPE].BOOL ELSE
IF M=1 THEN
BEGIN FOR I:=1 STEP 1 UNTIL NTYPES DO
IF (T:=TYPS[I].AF=T.BF THEN
BEGIN N:=I; I:=NTYPES+1
END;
IF I=NTYPES+1 THEN N:=NTYPES+1
END;
%------- MODE=2 ------- RESERVED ---------------
;
%------- MODE=3 ------- RETURN THE NUMBER OF RECORDS----
BEGIN COMMENT IF TYPE LSS 0 THEN THE TOTAL NUMBER
OF PAGES IS GIVEN, OTHERWISE THE NUMBER OF "TYPE" PAGES IS
GIVEN;
FOR I:=0 STEP 1 UNTIL NPAGES DO
IF INDX[I,0].TF=TYPE OR TYPE LSS 0 THEN
NR:=NR+INDX[I,0].CF;
M:=NR
END;
%------- MODE=4 ------- RETURN ITEM AT SUBSCRIPT N -----
IF NR GEQ INDX[CURPAGE,0].CF THEN MESSAGE(3) ELSE
IF BOOLEAN (TYPS[TYPE].BOOL) THEN COMMENT SEQUENTIAL STORAGE;
BEGIN ARRAY B[0:PAGESIZE]; 00007270P08
M:=CHRSTORE(POINTERS[CURBUFF](0),2,B,A,NR,0,0,2,0);
END ELSE
BEGIN
M:=RECSIZE|8;
READRECS(POINTERS[CURBUFF](0),A,SKIP,NR,1,0,RECSIZE);
END;
%------- MODE=5 ------- INSERT ITEM AT SUBSCRIPT N;
BEGIN INTEGER K,J,S; REAL PG;
IF BOOLEAN(TYPS[TYPE].BOOL) THEN
COMMENT FIND A PLACE FOR THE CHARACTER STRING OF LENGTH
M;
IF M GTR (PAGESIZE-SKIP-1)|8-2 THEN MESSAGE(5) COMMENT
THIS CHARACTER STRING IS TOO LONG ; ELSE
BEGIN ARRAY C[0:PAGESIZE];
STREAM PROCEDURE ADDZERO(CHARS,POINTER); VALUE CHARS;
BEGIN LOCAL T;
SI:=LOC CHARS; DI:=LOC T; DI:=DI+1; DS:=7CHR;
DI:=POINTER; T(2(DI:=DI+32)); CHARS(DI:=DI+1);
DS:=2LIT"0";
END;
BOOLEAN B,NOTLASTPAGE;
LABEL TRYITAGAIN;
TRYITAGAIN:
FOR I:=(T:=TYPS[TYPE]).AF STEP 1 WHILE I LSS T.BF AND
NOT B DO
IF NOT(B:=((PAGESIZE-SKIP-1)|8-(GT1:=INDX[I,0]).SF)GEQ M+2
AND NOT BOOLEAN(GT1.FF)) THEN S:=S+GT1.CF ELSE I:=I-1;
NOTLASTPAGE:=B AND I NEQ T.BF-1;
COMMENT IF B IS TRUE, THEN A PAGE HAS BEEN FOUND;
IF NOT B THEN COMMENT GET A PAGE THAT IS FREE;
BEGIN
COMMENT
IF MEMBUG.[5:1] THEN DUMPTYPES(5,1,TYPS,NTYPES);
IF TYPS[0].BF=0 THEN BEGIN K:=CURPAGE; T:=1;
MEMORY(8,TYPE,A,T,M); CURPAGE:=K+1
END
ELSE
IF (PAGESIZE-SKIP-1)|8-INDX[(I:=I-1)-1,0].SF GTR 2 THEN
BEGIN
CURBUFF:=BUFFNUMBER(CURPAGE:=I-1);
ADDZERO((GT1:INDX[CURPAGE,0].SF)+8|(SKIP+1),POINTERS
[CURBUFF](0));
INDX[CURPAGE,0].SF:=GT1+2;
INDX[CURPAGE,0].CF:=INDX[CURPAGE,0].CF+1;
COMMENT SINCE ALLOCATING A NEW PAGE, SET COUNT TO
ONE MORE AND FREEZE THE COUNT;
S:=S+1; % SINCE THE COUNT INCREASED
MOVE(INDX[CURPAGE,0],SKIP+1,POINTERS[CURBUFF](0));
MARK(CURPAGE);
END;
T:=TYPS[0].BF; TYPS[0].BF:=T:=T-1;
COMMENT T IS THE SUBSCRIPT INTO THE NEW PAGE;
PG:=INDX[T,P]; COMMENT PG HOLDS THE NEW PAGE #;
FOR K:=T+1 STEP 1 UNTIL I DO
MOVE(INDX[K,0],RECSIZE+SKIP+EXTRAROOM,INDX[K-1,0]);
T:=TYPS[TYPE].AF; UPDATE(TYPS,1,TYPE-1,-1);
IF CURPAGE GTR TYPS[0].BF THEN IF CURPAGE LEQ
I THEN CURPAGE:=CURPAGE-1;
INDX[I,0]:=0; INDX[I,0].MF:=1; INDX[I,0].TF:=TYPE;
COMMENT MUST ALSO ASSIGN A NUMBER TO THIS PAGE
(TO BE STORED IN THE PAGE) TO KEEP IT IN SEQUENCE
WITHIN THIS TYPE;
IF (T:=TYPS[TYPE]).AF LSS T.BF-1 THEN
T:=INDX[T.BF-1,1] ELSE T:=0;
SETNTH(INDX[I,0],ADDD(1,T),1);
COMMENT END OF THE INITIALIZATION OF THE INDEX ARRAY,
WE STILL HAVE TO MAKE SOME ENTRIES INTO THE PAGE
WHICH WE WILL DO BELOW;
END OF TEST FOR NEW PAGE;
COMMENT I IS SET TO THE PROPER SUBSCRIPT FOR THE CHR STORE;
CURBUFF:=BUFFNUMBER(CURPAGE:=I);
COMMENT NOW THE CORRECT PAGE IS IN CORE.
------------------------------
M= NUMBER OF CHARACTERS IN A (ON INPUT)
N= ADDRESS OF A WITHIN IN THIS TYPE (ON OUTPUT
------------------------------;
K:=INDX[I,0];
T:=CHRSTORE(POINTERS[CURBUFF](0),SKIP+1,C,A,K,CF,M,0,0,
PAGESIZE);
COMMENT K.CF IS THE NUMBER OF ITEMS ALREADY IN THIS
PAGE. IF THERE IS A SEGMENT WHICH IS NULL, IT WILL
BE FOUND AND ASSIGNED AS THE SEG NUMBER FOR 00007860P09
THIS CHARACTER STRING (T). IF NOT, IT WILL STICK THE
STRING ON THE END (WE KNOW THERE IS ENOUGH ROOM
SINCE WE CHECKED INDX[I,0].SF -- THE NUMBER OF CHRS USED
IN THIS PAGE, OR WE CREATED A NEW PAGE);
N:=S+T; S:=K.SF; COMMENT S CONTAINS THE # OF CHRS USED UP;
IF T:=T+1 GTR K.CF THEN COMMENT ADDED THE STRING ON THE END;
IF NOTLASTPAGE THEN % PAGE ALREADY FULL
BEGIN S:=0; B:=FALSE; INDX[I,0].FF:=1;
MOVE(INDX[I,0],SKIP+1,POINTERS[CURBUFF](0));
MARK(CURPAGE); GO TRYITAGAIN; END ELSE
BEGIN K.CF:=T; S:=S+2;
END
ELSE IF T=K.CF AND NOTLASTPAGE THEN INDX[I,0].FF:=1;
INDX[I,0].CF:=K.CF; INDX[I,0].SF:=S+M;
MOVE(INDX[I,0],SKIP+1,POINTERS[CURBUFF](0));
MARK(CURPAGE);
COMMENT THE PAGE DESCRIPTOR HAS BEEN UPDATED;
COMMENT
IF MEMBUG.[5:1] THEN DUMPTYPES(5,2,TYPS,NTYPES);
END ELSE COMMENT KIND OF STORAGE IS SORTED;
IF NR GTR (T:=INDX[CURPAGE,0].CF) THEN
COMMENT SUBSCRIPT IS NOT IN THE MIDDLE OF THE PAGE;
MESSAGE(6) ELSE
BEGIN
IF T GEQ U THEN COMMENT WILL EXCEED UPPER PAGE BOUND;
BEGIN ARRAY B[0:RECSIZE TIMES
(T-PS+(I:=(IF NR GEQ PS THEN 0 ELSE 1)))-1];
COMMENT B IS JUST BIG ENOUGH TO CARRY THE
EXCESS FROM THE OLD PAGE;
READRECS(POINTERS[CURBUFF](0),B,SKIP,PS-I,
J:=(T-PS+I),0,RECSIZE);
COMMENT -- B NOW HAS THE EXCESS;
INDX[CURPAGE,0].CF:=T-J; SETNTH(POINTERS[CURBUFF](0),
INDX[CURPAGE,0],0);
MARK(CURPAGE);
IF TYPS[0].BF=0 THEN
BEGIN K:=CURPAGE; T:=1;
MEMORY(8,TYPE,A,T,M); CURPAGE:=K+1;
END;
COMMENT -- ASSIGN A FREE PAGE (SUBS T);
T:=TYPS[0].BF; TYPS[0].BF:=T:=T-1;
PG:=INDX[T,P];
FOR K:=T+1 STEP 1 UNTIL CURPAGE DO
MOVE(INDX[K,0],RECSIZE+SKIP+EXTRAROOM,INDX[K-1,0]);
INDX[CURPAGE,P]:=PG;
T:=0;T.CF:=J;T.TF:=TYPE;
CURBUFF:=BUFFNUMBER(CURPAGE);
WRITERECS(POINTERS[CURBUFF](0),B,SKIP,0,J,0,RECSIZE);
SETNTH(POINTERS[CURBUFF](0),T,0);
MOVE(POINTERS[CURBUFF](0),RECSIZE+SKIP,INDX[CURPAGE,0]);
MARK(CURPAGE);
T:=TYPS[TYPE].AF; TYPS[TYPE].AF:=T-1;
UPDATE(TYPS,1,TYPE-1,-1);
IF J=0 THEN MESSAGE(7);
IF BOOLEAN (I) THEN
COMMENT I=0 IMPLIES THE RECORD GOES TO NEW PAGE,
I=1 IMPLIES THE RECORD GOES TO NOOLD PAGE;
BEGIN
T:=INDX[CURPAGE:=CURPAGE-1,0].CF;
CURBUFF:=BUFFNUMBER(CURPAGE);
; COMMENT OLD PAGE IS NOW BACK;
END ELSE
BEGIN T:=J; NR:=NR-PS
END
END;
WRITERECS(POINTERS[CURBUFF](0),A,SKIP,NR,1,T-NR,RECSIZE);
T:=INDX[CURPAGE,0].CF; INDX[CURPAGE,0].CF:=T+1;
SETNTH(POINTERS[CURBUFF](0),INDX[CURPAGE,0],0);
IF NR=0 THEN MOVE(POINTERS[CURBUFF](0),RECSIZE+SKIP,INDX
[CURPAGE,0]); MARK(CURPAGE);
END;
END;
%------- MODE=6 ------- DELETE A RECORD FROM THE FILE ----
IF (T:=TYPS[TYPE].AF=T.BF THEN MESSAGE(12) COMMENT
ATTEMPT TO DELETE NON-EXISTENT STORAGE;
ELSE
IF NR GEQ(T:=INDX[CURPAGE,0].CF) THEN MESSAGE(13) COMMENT
ATTEMPT TO DELETE OUTSIDE STORAGE RANGE; ELSE
IF BOOLEAN(T.BOOL) THEN COMMENT SEQUENTIAL STORAGE;
BEGIN COMMENT NR IS THE RECORD TO DELETE;
ARRAY B[0:PAGESIZE-1]; 00008610P10
COMMENT PAGESIZE -1 SHOULD BE COMPUTED TO THE EXACT
NUMBER OF WORDS TO MOVE -- IT WOULD SPEED THINGS UP;
INTEGER L;
T:=INDX[CURPAGE,0]; COMMENT T.CF IS THE NUMBER OF
RECORDS ON THIS PAGE, T.SF IS THE NUMBER OF CHRS;
L:=CHRSTORE(POINTERS[CURBUFF](0),SKIP+1,B,A,NR,0,T.CF
-NR-1,1,PAGESIZE);
COMMENT WE WILL BRING BACK THE NUMBER OF CHRS IN M;
M:=L;
MARK(CURPAGE);
COMMENT MAKE CHANGES TO THE CHARACTER COUNT;
INDX[CURPAGE,0].SF:=T.SF-L;
INDX[CURPAGE,0].FF:=0; % PAGE IS CERTAINLY NOT FULL NOW
COMMENT AND WE ARE DONE WITH THE DELETION;
MOVE(INDX[CURPAGE,0],SKIP+1,POINTERS[CURBUFF](0));
END
ELSE
BEGIN ARRAY A[0:RECSIZE-1];
INDX[CURPAGE,0].CF:=I-1;
SETNTH(POINTERS[CURBUFF](0),INDX[CURPAGE,0],0);
IF I GTR 1 THEN
BEGIN
READRECS(POINTERS[CURBUFF](0),A,SKIP,NR,1,I-NR-1,RECSIZE);
MARK(CURPAGE);
IF NR=0 THEN
MOVE(POINTERS[CURBUFF](0),RECSIZE+SKIP,INDX[CURPAGE,0])
END ELSE COMMENT FREE THE EMPTY PAGE;
BEGIN MARK(CURPAGE);
;TYPS[0].BF:=FREEPAGE(INDX,TYPS[0].BF,CURPAGE,CURPAGE);
UPDATE(TYPS,1,TYPE-1,1); TYPS[TYPE].AF:=T.AF+1;
COMMENT
IF MEMBUG.[6:1] THEN DUMPTYPES(MODE,TYPS,NTYPES);
END
END;
%------- MODE=7 ------- SEARCH FOR A RECORD FROM THE FILE ---
IF N GTR 3 THEN MESSAGE(14) ELSE
COMMENT RETURN RECORD CLOSEST (BUT LESS THAN OR EQUAL TO) TO
THE CONTENT OF -A-. A WILL BE REPLACED BY THE RECORD FOUND;
IF BOOLEAN((I:=TYPS[TYPE].BOOL) THEN
MESSAGE(8) COMMENT BINARY SEARCH OF NON-SEQUENTIAL DATA;
ELSE
IF I.AF=I.BF THEN MESSAGE(9) COMMENT --NO STORAGE OF
THIS TYPE ALLOCATED AS YET;
ELSE BEGIN
INTEGER F,U,L;
ARRAY B[0:RECSIZE-1];
U:=TYPS[TYPE].BF; L:=TYPS[TYPE].AF;
WHILE U-L GTR 1 DO
IF LESS(A,0,INDX[F:=(U+L) DIV 2,0],8,M) THEN U:=F ELSE L:=F;
CURBUFF:=BUFFNUMBER(CURPAGE:=L);
L:=0; U:=INDX[CURPAGE,0].CF;
IF L-U=0 THEN MESSAGE(10) COMMENT BINARY SEARCH FOUND
A PAGE WITH NO RECORDS;
ELSE BEGIN
WHILE U-L GTR 1 DO
BEGIN READRECS(POINTERS[CURBUFF](0),B,SKIP,
F:=(U+L) DIV 2,1,0,RECSIZE);
IF LESS(A,0,B,0,M) THEN U:=F ELSE L:=F
END;
COMMENT -----------------------------------
ON INPUT:
N=0 IMPLIES DO NOT PLACE RECORD INTO FILE
IF RECORD IS FOUND. RETURN RELA-
TIVE POSITION OF THE CLOSEST RECORD
IN THIS PAGE.
N=1 " DO NO PLACE IN FILE. RETURN ABSO-
LUTE SUBSCRIPT OF CLOSSEST RECORD.
N=2 " PLACE RECORD INTO FILE IF NOT FOUND.
RETURN RELATIVE POSITION OF RECORD.
N=3 " PLACE RECORD INTO FILE, IF NOT
FOUND, RETURN ABS SUBSCRIPT OF
THE RECORD.
ON OUTPUT:
M=0 " RECORD FOUND WAS EQUAL TO RECORD
SOUGHT.
M=1 " RECORD FOUND WAS GREATER THAN THE
SOUGHT.
M=2 " RECORD FOUND WAS LESS THAN THE
RECORD SOUGHT.
;
READRECS(POINTERS[CURBUFF](0),B,SKIP,L,1,0,RECSIZE);
IF LESS(A,0,B,0,M) THEN M:=1 ELSE
IF LESS(B,0,A,0,M) THEN M:=2 ELSE 00009410P11
M:=0;
T:=0; IF BOOLEAN(N) THEN
FOR I:=TYPS[TYPE].AF STEP 1 UNTIL CURPAGE-1 DO
T:=T+INDX[I,0].CF;
IF N GTR 1 THEN IF M GEQ 1 THEN
MEMORY(2,TYPE,A,L+M-1,NR);
MOVE(B,RECSIZE,A);
N:=T+L;
END
END;
%------- MODE=8 ------- FILE OVERFLOW, FIX ARRAYS AND PAGES
BEGIN BOOLEAN TOG;
ARRAY A[0:PAGESIZE-1]; T:=NPAGES-N+1;
IF TOG:=(T DIV AREASIZE) LSS (NPAGES DIV AREASIZE ) OR
(T=NPAGES AND T MOD AREASIZE =0) THEN
MEMORY(14,TYPE,A,N,M);
FOR I:=T STEP 1 UNTIL NPAGES DO
BEGIN WRITE(NEWDISK[I],PAGESIZE,A[*]);INDX[I,P].PAGEF:=I END;
MARKEOF(SKIP,RECSIZE,NEWDISK(0));
WRITE(NEWDISK[I]);
TYPS[0].BF:=FREEPAGE(INDX,TYPS[0]).BF,T,NPAGES);
UPDATE(TYPS,1,NTYPES,NPAGES-T+1);
IF TOG THEN CLOSE(NEWDISK);
END;
%------- MODE=9 ------- FILE MAINTENANCE ------------------
BEGIN BOOLEAN ITHPAGEIN;
INTEGER I,J,K,T1,T2,T3,M,W,Q;
ARRAY A,B[0:PAGESIZE-1];
COMMENT
MONITOR PRINT(Q,W,N, I,J,K,T1,T2,T3,M,A,B);
IF I:=TYPS[0].BF LEQ NPAGES THEN
DO
BEGIN COMMENT OUTER "DO-LOOP" TO FIND TROUBLE WITH
THE FILE;
IF T1:=(Q:=INDX[I,0]).CF LSS L THEN COMMENT MAY BE CORRECTABLE;
IF NOT BOOLEAN((Q:=TYPS[Q.TF]).BOOL) THEN
COMMENT -- THIS PAGE IS CORRECTABLE;
IF I NEQ NPAGES THEN
COMMENT -- THIS IS NOT THE LAST PAGE OF THE FILE;
IF (J:=I+1) LSS Q.BF THEN
COMMENT -- THIS IS NOT THE LAST PAGE OF THIS TYPE;
BEGIN COMMENT -- FIND RECORDS TO MOVE INTO
THIS PAGE;
DO IF T2:=INDX[J,0].CF GTR 0 THEN
COMMENT THIS PAGE HAS RECS TO MOVE;
BEGIN COMMENT HOW MANY;
IF T2 LSS K:=PS-T1 THEN K:=T2;
IF NOT ITHPAGEIN THEN
BEGIN COMMENT BRING IN PAGE I;
MOVE(POINTERS[BUFFNUMBER(I)](0),
PAGESIZE,B); ITHPAGEIN:=TRUE
END;
COMMENT -- BRING IN PAGE J;
CURBUFF:=BUFFNUMBER(CURPAGE:=J);
COMMENT -- MOVE SOME INTO A;
READRECS(POINTERS[CURBUFF](0),A,SKIP,0,K,
T2:=T2-K,RECSIZE); INDX[J,0].CF:=T2;
IF T2=0 THEN
COMMENT SET THIS PAGE FREE;
INDX[J,0]:=0;
SETNTH(POINTERS[CURBUFF](0),INDX[J,0],0);
MOVE(POINTERS[CURBUFF](0),RECSIZE+SKIP,INDX[J
,0]); MARK(CURPAGE);
COMMENT -- PUT THE RECORDS INTO PAGE I;
WRITERECS(B,A,SKIP,T1,K,0,RECSIZE);
END
ELSE K:=0 COMMENT SINCE NO CONTRI-
BUTION;
UNTIL T1:=T1+K GEQ PS OR J:=J+1 GEQ Q.BF;
INDX[I,0].CF:=T1; B[0]:=INDX[I,0];
COMMENT -- PUT THE PAGE BACK OUT ON DISK;
MOVE(B,RECSIZE+SKIP,INDX[I,0]);
MOVE(B,PAGESIZE,POINTERS[CURBUFF:=BUFFNUMBER
(I)](0)); SORT(INDX,0,NPAGES,RECSIZE|8);
MARK(CURPAGE:=I); SETTYPES;
N:=1;
END
ELSE N:=0 COMMENT LAST PAGE OF THIS TYPE;
ELSE N:=0 COMMENT LAST PAGE OF FILE;
ELSE N:=0 COMMENT PAGE CANNOT BE CHANGED;
ELSE N:=0 COMMENT THIS PAGE IS NOT TOO SMALL;
END UNTIL I:=I+1 GTR NPAGES OR N NEQ 0 ELSE N:=0;
IF I GTR NPAGES THEN N:=REAL(WRITEBUFFER); 00010240P12
END OF FILE UPDATE;
%------- MODE=10 ------EEMERGENCY FILE MAINTENANCE -------
DO MEMORY(9,TYPE,A,N,M) UNTIL N NEQ 1
%------- MODE=11 ------- SET THE KIND OF STORAGE FOR TYPE ----------
;COMMENT TYPE "TYPE" STORAGE IS BEING SET TO SEQUENTIAL;
IF TYPE=0 THEN MESSAGE(4) ELSE
IF (T:=TYPS[TYPE]).AF= T.BF THEN TYPS[TYPE].BOOL:=1 ELSE
MESSAGE(15); COMMENT ATTEMPT TO CHANGE KINDS IN MIDSTREAM;
%------- MODE=12 ----------- ALTER STORAGE ALLOCATION RESOURCES---
COMMENT N IS THE "FACTOR" (PERCENT OF RESOURCES | 100),
AND M IS THE STORAGE "LEVEL" (0 IS THE ONLY ONE THAT
DOES ANYTHING ON THE B5500);
BEGIN INTEGER J,K;
BOOLEAN TOG;
IF T:=N|(MBUFF-1)/100+1 GTR MAXBUFF THEN
BEGIN COMMENT ADD TO AVAILABLE LIST;
FOR I:=CDR(FIRST),CDR(AVAIL) DO
WHILE NOT NULL(I) DO
BEGIN BUF[I].FLAGB:=1; I:=CDR(BUF[I]);
END;
FOR I:=MAXBUFF+1 STEP 1 UNTIL T DO
BEGIN WHILE BUF[K:=K+1].FLAGB=1 DO;
BUF[K]:=0; RPLACD(BUF[K],CDR(AVAIL));
RPLACD(AVAIL,K)
END;
MAXBUFF:=T;
FOR I:=1 STEP 1 UNTIL MBUFF DO BUF[I].FLAGB:=0;
END ELSE
IF T LSS MAXBUFF THEN
BEGIN COMMENT CUT DOWN ON THE NUMBER OF BUFFERS;
I:=CDR(FIRST);
FOR J:=1 STEP 1 UNTIL MAXBUFF DO
IF TOG THEN
IF NOT NULL(I) THEN
IF J GEQ T THEN
BEGIN K:=CDR(BUF[I]); BUF[I]:=0
; I:=K END
ELSE I:=CDR(BUF[I])
ELSE
ELSE
IF TOG:=NULL(I) THEN
BEGIN J:=J-1; I:=CDR(AVAIL)
END
ELSE
IF J EQL T THEN
BEGIN K:=CDR(BUF[I]); RPLACD(BUF[I],0);
I:=K END ELSE
IF J GTR T THEN
BEGIN
IF BOOLEAN(BUF[I].CHANGEDBIT) THEN
WRITE(POINTERS[I][BUF[I].PAGEF-1);
K:=CDR(BUF[I]);
CLOSE(POINTERS[I]);
BUF[I]:=0; I:=K
END ELSE I:=CDR(BUF[I])
;
MAXBUFF:=T
END;
END;
%------- MODE=13 ------- RELEASE "TYPE" STORAGE TO SYSTEM ----------
IF (T:=TYPS[TYPE]).BF GTR T.AF THEN
BEGIN INTEGER J;
J:=T.BF-1;
FOR I:=T.AF STEP 1 UNTIL J DO
BEGIN CURBUFF:=BUFFNUMBER(I);
SETNTH(POINTERS[CURBUFF](0),0,0); MARK(CURPAGE:=I);
END;
TYPS[0].BF:=FREEPAGE(INDX,TYPS[0].BF,T,AF,J);
UPDATE(TYPS,1,TYPE-1,J-T.AF+1);
TYPS[TYPE].BF:=T.AF; TYPS[TYPE].BOOL:=0;
END;
%------- MODE=14 ------ RELEASE ALL PAGES FOR TRANSITION -----------
BEGIN INTEGER K;
I:=CDR(FIRST);
WHILE NOT NULL(I) DO
BEGIN IF BOOLEAN(BUF[I].CHANGEDBIT ) THEN WRITE(POINTERS[I]
[BUF[I].PAGEF-1]); CLOSE(POINTERS[I]);
K:=CDR(BUF[I]); BUF[I]:=0;
RPLACD(BUF[I],CDR(AVAIL)); RPLACD(AVAIL,I); I:=K
END ; CURPAGE:=CURBUFF:=-1; RPLACD(FIRST,0);
END;
END OF CASE STMT;
END OF INNER BLOCK; 00011110P13
END OF PROCEDURE;
INTEGER QM,QN;
ARRAY QA[0:0];
PROCEDURE NAME(MFID,FID); VALUE MFID,FID; REAL MFID,FID;
BEGIN INTEGER I; FILL NEWDISK WITH MFID,FID;
FOR I:=0 STEP 1 UNTIL MBUFF DO
FILL POINTERS[I] WITH MFID,FID;
FILL ESTABLISH WITH MFID,FID;
SETPOINTERNAMES
END;
PROCEDURE SEQUENTIAL(UNIT); VALUE UNIT; INTEGER UNIT;
MEMORY(11,UNIT,QA,QN,QM);
INTEGER PROCEDURE CONTENTS(UNIT,N,AR); VALUE UNIT,N;
INTEGER UNIT,N; ARRAY AR[0];
BEGIN
MEMORY(4,UNIT,AR,N,QM); CONTENTS:=QM;
END;
PROCEDURE DELETE1(UNIT,N); VALUE UNIT,N; INTEGER UNIT,N;
MEMORY(6,UNIT,QA,N,QM);
INTEGER PROCEDURE SEARCHORD(UNIT,REC,LOC,M); VALUE UNIT,M;
INTEGER UNIT,LOC,M; ARRAY REC[0];
BEGIN LOC:=1;
MEMORY(7,UNIT,REC,LOC,M);
SEARCHORD:=M;
END;
PROCEDURE STOREORD(UNIT,REC,N); VALUE UNIT,N; INTEGER UNIT,N;
ARRAY REC[0];
MEMORY(5,UNIT,REC,N,QM);
PROCEDURE STOREORDR(UNIT,REC,N); VALUE UNIT,N; INTEGER UNIT,N;
ARRAY REC[0];
MEMORY(2,UNIT,REC,N,QM);
BOOLEAN PROCEDURE MAINTENANCE;
BEGIN MEMORY(9,0,QA,QN,QM); MAINTENANCE:=QN:=1
END;
PROCEDURE WRAPUP; MEMORY(10,0,QA,QN,QM);
INTEGER PROCEDURE STORESEQ(UNIT,REC,N); VALUE UNIT,N; INTEGER UNIT, N;
ARRAY REC[0];
BEGIN
MEMORY(5,UNIT,REC,QN,N); STORESEQ:=QN;
END;
PROCEDURE DELETEN(UNIT,N,M); VALUE UNIT,N,M; INTEGER UNIT,N,M;
BEGIN M:=M-N;
DO MEMORY(6,UNIT,QA,N,QM) UNTIL M:=M-1 LSS 0;
END;
INTEGER PROCEDURE NEXTUNIT;
BEGIN MEMORY(1,0,QA,QN,1); NEXTUNIT:=QN
END;
INTEGER PROCEDURE SIZE(UNIT); VALUE UNIT; INTEGER UNIT;
BEGIN MEMORY(3,UNIT,QA,QN,QM); SIZE:=QM
END;
PROCEDURE ALLOCATE(J,FACTOR); VALUE J,FACTOR; INTEGER J;
REAL FACTOR;
BEGIN
QN:=ENTIER( ABS( (FACTOR | 100) MOD 101));
MEMORY(12,0,QA,QN,J)
END;
PROCEDURE RELEASEUNIT(UNIT); VALUE UNIT; INTEGER UNIT;
MEMORY(13,UNIT,QA,QN,QM);
DEFINE
ALLOWQUESIZE=4#,
ACOUNT=ACCUM[0].[1:11]#,
DATADESC=[1:1]#,
SCALAR=[4:1]#,
NAMED=[3:1]#,
CHRMODE=[5:1]#,
CHECKT=5#, % NUMBER OF TIMES THRU EXECUTE BEFORE CHECK
CCIF=18:36:12#,
CDID=1:43:5#,
CSPF=30:30:18#,
CRF=24:42:6#,
CLOCF=6:30:18#,
PF=[1:17]#,
XEQMODE=1#,
FUNCMODE=2#,
CALCMODE=0#,
INPUTMODE=3#,
ERRORMODE=4#,
FUNCTION=1#,
CURRENTMODE = PSRM[0]#,
VARIABLES = PSRM[1]#,
VARSIZE = PSRM[2]#,
FUNCPOINTER = PSRM[3]#, 00013160P14
FUNCSEQ = PSRM[4]#,
CURLINE = PSRM[5]#,
STACKBASE = PSRM[6]#,
INCREMENT = STACKBASE#, %FUNCMODE/CALCMODE
SYMBASE = PSRM[7]#,
FUNCSIZE = SYMBASE#, %FUNCMODE/CALCMODE
USERMASK = PSRM[8]#,
SEED = PSRM[10]#,
ORIGIN = PSRM[11]#,
FUZZ = PSRM[12]#,
FSTART = 9#, %PSR[9] IS WHERE NAME OF CURRENTLY EDITED FCN GOES
PSRSIZE = 13#,
PSR = PSRM[*]#,
WF=[18:8]#,
WDSPERREC=10#,
WDSPERBLK=30#,
NAREAS=10#,
SIZEAREAS=210#,
LIBF1=[6:15]#,
LIBF2=[22:16]#,
LIBF3=[38:10]#,
LIBSPACES=1#,
IDENT=RESULT=1#,
SPECIAL=RESULT=3#,
NUMERIC=RESULT=2#,
REPLACELOC=0#,
REPLACEV=4#,
SPF=[30:18]#,
RF=[24:6]#,
DID=[1:5]#,
XRF=[12:18]#,
DDPNSW=30#, % DATA DESC PRESENT NAMED SCALAR WORD
DDNNVW=20#, %DATA DESC NON-PRES NAMED VECTOR WORD
DDNUVW=16#, %DATA DESC NONPRES..(POINTS INTO SYM TAB FOR LOCALS)
DDPUVW=24#, % DATA DESC PRESENT UNNAMED VECTOR WORD
DDNNSW=22#, % DATA DESC NON-PRES NAMED SCALAR WORD
PDC=10#, % DROG DESC CALC MODE
INTO=0#,
DDPUSW=26#, % DATA DESC PRESENT UNNAMED SCALAR WORK (MODE)
DDPUSC=27#, % DATA DESC PRESENT UNNAMED SCALAR CHR
DDPUVC=25#, % DATA DESC PRESENT UNNAMED VECTOR CHR
DDPNVC=29#, %DATA DESC PRES PERMANENT VECTOR CHAR MODE
DDPNVW=28#, %DATA DESC PRES NAMED VEC WORD (NAMED=PERMANENT)
OUTOF=1#,
NAMEDNULLV=0&7[1:45:3]#, %DLUDGE...NAMED VERSION OF NULLV
BACKP=[6:18]#,
SCALARDATA=0#,
ARRAYDATA=2#,
DATATYPE=[4:1]#,
ARRAYTYPE=[5:1]#,
CHARARRAY=1#,
NUMERICARRAY=0#,
BLOCKSIZE=30#, %#WORDS OF CONTIGUOUS DATA IN SEQUENTIAL STORE
VARTYPE=[42:6]#,
WS=WORKSPACE#,
DIMPTR=SPF#,
INPTR=BACKP#,
QUADIN=[18:3]#,
QUADINV=18:45:3#,
STATEVECTORSIZE=16#,
SUSPENDED=[5:1]#,
SUSPENDVAR=[2:1]#,
CTYPEF=3:45:3#,
CSUSVAR=2:47:1#,
CNAMED=3:47:1#,
MAXWORDSTORE=3960#, %APL PREVENTS CREATION OF ARRAYS BIGGER THAN
%3960 ELEMENTS. THIS NUMBER IS THE PRODUCT OF
%4,(NUMBER OF POINTERS TO SEQUENTIAL STORE
%BLOCKS THAT ARE STORED IN ONE WORD)
%30, (BLOCKSIZE),
%AND 33, (SIZE OF ARRAY USED TO STORE THESE
%POINTERS IN GETARRAY, MOVEARRAY, AND
%RELEASEARRAY). SUBSCRIPTS ALLOWS 8|3960
%ELEMENTS IF THEY ARE CHARACTERS.
%HOWEVER, SP WILL GET FULL BEFORE THAT SINCE
%BIGGEST SP SIZE IS CURRENTLY 3584
MAXBUFFSIZE=30#,
MAXHEADERARGS=30#,
BUFFERSIZE=BUFFSIZE#,
LINEBUFFER=LINEBUFF#,
LINEBUFF = OUTBUFF[*]#,
APPENDTOBUFFER=APPENDTOBUFF#,
FOUND=TARRAY[0]#, 00022000P15
EOB=TARRAY[1]#,
MANT=TARRAY[2]#,
MANTLEN=TARRAY[3]#,
FRAC=TARRAY[4]#,
FRACLEN=TARRAY[5]#,
POWER=TARRAY[6]#,
POWERLEN=TARRAY[7]#,
MANTSIGN=TARRAY[8]#,
TABSIZE = 43#,
LOGINCODES=1#,
LOGINPHRASE=2#,
LIBRARY=1#,
WORKSPACEUNIT=2#,
RTPAREN=9#,
MASTERMODE=USERMASK.[1:1]#,
EDITOG=USERMASK.[2:1]#,
POLBUG=USERMASK.[3:1]#,
FPTF=9#, % FUNCTION POINTER FIELD (STARTS AT CHR POS 9)
FSQF=11#, % FUNCTION SEQNTL FIELD
FFL=2#, % FUNCTION FIELD LENGTH (2 CHR POSITIONS)
CRETURN=3:47:1#,
RETURNVALUE=[3:1]#,
CNUMBERARGS=4:46:2#,
NUMBERARGS=[4:2]#,
RETURNVAL=1#,
NOSYNTAX=USERMASK.[4:1]#,
LINESIZE=USERMASK.[41:7]#,
DIGITS=USERMASK.[37:4]#,
SUSPENSION=USERMASK.SUSPENDED#,
SAVEDWS=USERMASK.[7:1]#,
DELTOG=USERMASK.[6:1]#,
DELCHR="$"#, %USED IN DELPRESENT (IN FUNCTIONHANDLER)
MAXMESS=27#,
USERTOP=21#,
MARGINSIZE=6#,
LFTBRACKET=SPECIAL AND ACCUM[0]=11#,
QUADV=SPECIAL AND ACCUM[0]=10#,
QUOTEV=ACCUM[0]=20#,
EXPANDV=38#,
SLASHV=6#,
GOTOV=5#,
DOTV=17#,
ROTV=37#,
RGTBRACKET=SPECIAL AND ACCUM[0]=12#,
DELV=SPECIAL AND ACCUM[0]=13#,
PLUS = SPECIAL AND ACCUM[0] = 48#,
MINUS = SPECIAL AND ACCUM[0] = 49#,
NEGATIVE = SPECIAL AND ACCUM[0] = 51#,
TIMES = SPECIAL AND ACCUM[0] = 50#,
LOGS = SPECIAL AND ACCUM[0] = 54#,
SORTUP = SPECIAL AND ACCUM[0] = 55#,
SORTDN = SPECIAL AND ACCUM[0] = 56#,
NAND = SPECIAL AND ACCUM[0] = 58#,
NOR = SPECIAL AND ACCUM[0] = 59#,
TAKE = SPECIAL AND ACCUM[0] = 60#,
DROPIT = SPECIAL AND ACCUM[0] = 61#,
LFTARROW = SPECIAL AND ACCUM[0] = 04#,
TRANS = SPECIAL AND ACCUM[0] = 05#,
SLASH = SPECIAL AND ACCUM[0] = 06#,
INTDIVIDE = SPECIAL AND ACCUM[0] = 07#,
LFTPAREN = SPECIAL AND ACCUM[0] = 08#,
RGTPAREN = SPECIAL AND ACCUM[0] = 09#,
QUOTEQUAD = SPECIAL AND ACCUM[0] = 14#,
SEMICOLON = SPECIAL AND ACCUM[0] = 15#,
COMMA = SPECIAL AND ACCUM[0] = 16#,
DOT = SPECIAL AND ACCUM[0] = 17#,
STAR = SPECIAL AND ACCUM[0] = 18#,
AT = SPECIAL AND ACCUM[0] = 19#,
QUOTE = SPECIAL AND ACCUM[0] = 20#,
BOOLAND = SPECIAL AND ACCUM[0] = 21#,
BOOLOR = SPECIAL AND ACCUM[0] = 22#,
BOOLNOT = SPECIAL AND ACCUM[0] = 23#,
LESSTHAN = SPECIAL AND ACCUM[0] = 24#,
LESSEQ = SPECIAL AND ACCUM[0] = 25#,
EQUAL = SPECIAL AND ACCUM[0] = 26#,
GRTEQ = SPECIAL AND ACCUM[0] = 27#,
GREATER = SPECIAL AND ACCUM[0] = 28#,
NOTEQ = SPECIAL AND ACCUM[0] = 29#,
CEILING = SPECIAL AND ACCUM[0] = 30#,
FLOOR = SPECIAL AND ACCUM[0] = 31#,
STICK = SPECIAL AND ACCUM[0] = 32#,
EPSILON = SPECIAL AND ACCUM[0] = 33#,
RHO = SPECIAL AND ACCUM[0] = 34#, 00030950P16
IOTA = SPECIAL AND ACCUM[0] = 35#,
TRACE = SPECIAL AND ACCUM[0] = 36#,
PHI = SPECIAL AND ACCUM[0] = 37#,
EXPAND = SPECIAL AND ACCUM[0] = 38#,
BASVAL = SPECIAL AND ACCUM[0] = 39#,
EXCLAMATION = SPECIAL AND ACCUM[0] = 40#,
MINUSLASH = SPECIAL AND ACCUM[0] = 41#,
QUESTION = SPECIAL AND ACCUM[0] = 42#,
OSLASH = SPECIAL AND ACCUM[0] = 43#,
TAU = SPECIAL AND ACCUM[0] = 44#,
CIRCLE = SPECIAL AND ACCUM[0] = 45#,
LOCKIT =IDENT AND ACCUM[0]="4LOCK "#,
COLON = SPECIAL AND ACCUM[0] = 47#,
QUADLFTARROW=51#,
REDUCT=52#,
ROTATE=53#,
SCANV=57#,
LINEBUFFSIZE=17#,
MAXPOLISH=100#, MESSIZE=10#,
MAXCONSTANT=30#,
MAXMEMACCESSES=3584#, %MAXSPROWS | SPRSIZE
MAXSYMBOL=30#,
MAXSPROWS=28#,
TYPEFIELD=[3:3]#,
OPTYPE=[1:2]#,
LOCFIELD=BACKP#,
ADDRFIELD=SPF#,
SYMTYPE=[3:3]#,
OPERAND=5#,
CONSTANT=2#,
OPERATOR=3#,
LOCALVAR=4#,
SYMTABSIZE=1#,
LFTPARENV=8#,
RGTPARENV=9#,
LFTBRACKETV=11#,
RGTBRACKETV=12#,
SEMICOLONV=15#,
QUAD=10#,
QQUAD=14#,
LFTARROWV=4#,
SORTUPV=55#,
SORTDNV=56#,
ALPHALABEL=1#,
NUMERICLABEL=2#,
NEXTLINE=0#,
ERRORCOND=3#,
PRESENCE=[2:1]#,
CHANGE=[1:1]#,
XEQ=1#,
CLEARCORE=2#,
WRITECORE=3#,
%%%
%%%
XEQUTE=1#,
SLICE=120#, %TIME SLICE IN 60THS OF A SECOND
ALLOC=2#,
WRITEBACK=3#,
LOOKATSTACK=5#,
LEN=[1:23]#,
NEXT=[24:24]#,
LOC=L.[30:11],L.[41:7]#,
NOC=N.[30:11],N.[41:7]#,
MOC=M.[30:11],M.[41:7]#,
SPRSIZE=128#, % SP ROW SIZE
NILADIC=0#,
MONADIC=1#,
DYADIC=2#,
TRIADIC=3#,
DEPTHERROR=1#,
DOMAINERROR=2#,
INDEXERROR=4#,
LABELERROR=5#,
LENGTHERROR=6#,
NONCEERROR=7#,
RANKERROR=8#,
SYNTAXERROR=9#,
SYSTEMERROR=10#,
VALUEERROR=11#,
SPERROR=12#,
KITEERROR=13#,
STREAMBASE=59823125#, 00032200P17
APLOGGED=[10:1]#,
APLHEADING=[11:1]#,
CSTATION = STATION#,
CAPLOGGED=10:47:1#,
CAPHEADING=11:47:1#,
APLCODE = STATIONPARAMS#,
SPECMODE = BOUNDARY.[1:3]#,
DISPLAYIMG=1#,
EDITING=2#,
DELETING=3#,
RESEQUECING=4#,
LOWER = BOUNDARY.[4:22]#,
UPPER = BOUNDARY.[26:22]#,
OLDBUFFER = OLDINPBUFFER[*]#,
ENDEFINES=#;
REAL ADDRESS, ABSOLUTEADDRESS,
LADDRESS;
BOOLEAN LINETOG; %GO TO NEXT LINE IF TRUE WHEN WRITING OUT
INTEGER BUFFSIZE,ITEMCOUNT,RESULT,
LOGINSIZE,
%%%
ERR,
NROWS,
%%%
CUSER;
LABEL ENDOFJOB,TRYAGAIN;
REAL GT1,GT2,GT3;
DEFINE LINE=PRINT#;
SAVE ARRAY BUFFER[0:MAXBUFFSIZE];
ARRAY TARRAY[0:8],
COMMENT PROGRAM STATE REGISTER;
PSRM[0:PSRSIZE],
OLDINPBUFFER[0:MAXBUFFSIZE],
SP[0:27, 0:SPRSIZE-1],
IDTABLE[0:TABSIZE],
MESSTAB[0:MAXMESS],
JIGGLE[0:0],
SCR[0:2],
CORRESPONDENCE[0:7],
ACCUM[0:MAXBUFFSIZE];
DEFINE OUTBUFFSIZE=29#,CLOGGED=7:47:1#,STU=15:9:9#;
ARRAY OUTBUFF[0:OUTBUFFSIZE];
ALPHA STATION, JOBNUM, STATIONPARAMS, BOUNDARY;
INTEGER CHRCOUNT, WORKSPACE;
STREAM PROCEDURE INITBUFF(B,BUFFSIZE); VALUE BUFFSIZE;
BEGIN
DI~B; BUFFSIZE(DS~8LIT" "); DS~LIT"~";
END;
STREAM PROCEDURE TRANSFER(A,AS,B,BS,L); VALUE AS,BS,L;
BEGIN LOCAL T,U,V;
SI:=LOC AS; DI:=LOC T; DI:=DI+1; DS:=7CHR;
SI:=LOC BS; DI:=LOC U; DI:=DI+1; DS:=7CHR;
SI:=LOC L; DI:=LOC V; DI:=DI+1; DS:=7CHR;
SI:=A; T(2(SI:=SI+32)); SI:=SI+AS;
DI:=B; U(2(DI:=DI+32)); DI:=DI+BS;
V(2(DS:=32CHR)); DS:=L CHR;
END;
REAL PROCEDURE NUMBER; FORWARD; %LINE 111500
BOOLEAN PROCEDURE SCAN;
BEGIN
REAL STREAM PROCEDURE GNC(ADDR,ACC); VALUE ADDR;
BEGIN SI:=ADDR; DI:=ACC; DI:=DI+7; DS:=CHR; GNC:=SI;
DI:=ACC; SKIP DB; DS:=SET; END OF GNC;
REAL STREAM PROCEDURE RESWD(TAB,BUF,ADDR,EOB,FOUND,K);
VALUE ADDR,K;
BEGIN
LOCAL T,TSI,TDI;
LABEL TRY,L,KEEPGOING,FINIS,RESTORE;
LABEL NUMBERFOUND;
DI:=EOB; DS:=8LIT"0"; DI:=FOUND; DS:=8LIT"0";
SI:=ADDR;
L: IF SC NEQ " " THEN GO TO KEEPGOING;
SI:=SI+1;
GO TO L;
KEEPGOING:
RESWD:=SI;
ADDR:=SI;
IF SC GEQ "0" THEN IF SC LEQ "9" THEN GO TO NUMBERFOUND;
IF SC="#" THEN GO TO NUMBERFOUND; 00059100P18
IF SC="@" THEN GO TO NUMBERFOUND;
IF SC="." THEN
BEGIN SI:=SI+1;
IF SC GEQ "0" THEN IF SC LEQ "9" THEN
GO TO NUMBERFOUND; SI:=SI-1;
END;
DI:=LOC T; DS:=2RESET; DS:=2SET; DS:=2RESET;
DI:=LOC T;
IF SC=DC THEN
BEGIN DI:=EOB; DI:=DI+7; DS:=LIT"1";
GO TO FINIS
END;
SI:=TAB; TSI:=SI;
TRY:
IF SC="0" THEN
BEGIN SI:=ADDR;
IF SC=ALPHA THEN
IF SC GEQ"0" THEN
IF SC LEQ "9" THEN
NUMBERFOUND:
TALLY:=2 ELSE TALLY := 0
ELSE TALLY:=1
ELSE TALLY:=3;
T:=TALLY; SI:=LOC T; SI:=SI+7; DI:=FOUND; DI:=DI+7;
DS:=CHR; GO FINIS;
END;
DI:=LOC T; DI:=DI+7; DS:=CHR;
DI:=ADDR;
IF T SC=DC THEN
BEGIN
TSI:=SI; TDI:=DI; SI:=SI-1;
IF SC=ALPHA THEN
BEGIN DI:=DI+16; SI:=TDI;
IF SC NEQ " " THEN IF SC =ALPHA THEN ;
END;
SI:=TSI;
END ELSE GO TO RESTORE;
IF TOGGLE THEN
RESTORE:
BEGIN SI:=SI+K; DI:=ADDR; GO TO TRY
END;
DI:=FOUND; DS:=K OCT;
DI:=TDI; RESWD:=DI;
FINIS:
END;
REAL STREAM PROCEDURE ACCUMULATE(ACC,EDB,ADDR); VALUE ADDR;
BEGIN LOCAL T; LABEL EOBL,E,ON,L;
DI:=ACC; 9(DS:=8LIT" ");
DI:=EOB; DS:=8LIT"0"; SI:=ADDR; DI:=LOC T; SKIP 2 DB;
DS:=2SET; DI:=LOC T;
63(IF SC=ALPHA THEN TALLY:=TALLY+1 ELSE JUMP OUT TO E;
SI:=SI+1);
L: IF SC=ALPHA THEN BEGIN SI:=SI+1; GO L END ELSE GO ON;
IF SC=" " THEN GO ON;
E: IF SC = DC THEN ;
SI:=SI-1; IF TOOGLE THEN GO TO EOBL ELSE GO ON;
EOBL: DI:=EOB; DI:=DI+7; DS:=LIT"1";
ON: ACCUMULATE:=SI; DI:=ACC; T:=TALLY; SI:=LOC T; SI:=SI+6;
DS:=2CHR; SI:=ADDR; DS:=T CHR;
END OF ACCUMULATE;
BOOLEAN STREAM PROCEDURE ARROW(ADDR,I); VALUE ADDR,I;
BEGIN SI:=ADDR; SI:=SI-1; DI:=LOC I; DI:=DI+7;
IF SC=DC THEN TALLY:=1; ARROW :=TALLY
END OF ARROW;
IF NOT BOOLEAN(EOB) THEN BEGIN
LADDRESS:=ADDRESS;
ADDRESS:=RESWD(IDTABLE,BUFFER,ADDRESS,EOB,FOUND,2);
IF RESULT:=FOUND NEQ 0 THEN BEGIN
IF RESULT=1 THEN ADDRESS:=ACCUMULATE(ACCUM,EOB,ADDRESS)
ELSE IF RESULT=2 THEN ACCUM[0]:=NUMBER
ELSE IF RESULT=3 THEN ADDRESS:=GNC(ADDRESS,ACCUM)
ELSE BEGIN ACCUM[0]:=RESULT; RESULT:=3 END;
ITEMCOUNT:=ITEMCOUNT+1;
SCAN:=TRUE;
IF ARROW(ADDRESS,31) THEN
BEGIN EOB:=1; SCAN:=FALSE END;
END ELSE EOB:=1;
END;
END OF THE SCAN PROCEDURE;
PROCEDURE FORMROW(CC,BL,A,S,N); VALUE CC,RL,S,N;
INTEGER CC,BL,S,N; ARRAY A[0]; FORWARD
;
PROCEDURE INDENT(R); VALUE R; REAL R; FORWARD; 00096300P19
PROCEDURE TERPRINT; FORWARD;
PROCEDURE PROCESS(MODE);VALUE MODE;INTEGER MODE; FORWARD;
REAL STREAM PROCEDURE ABSADDR(A);
BEGIN SI:=A; ABSADDR:=SI
END;
BOOLEAN PROCEDURE LIBRARIAN(MFID,FID); VALUE MFID,FID;
REAL MFID,FID;
BEGIN
REAL ARRAY A[0:6]; FILE DF DISK(1,1);
REAL T;
COMMENT LIBRARIAN IS TRUE IF MFID/FID IS PRESENT ON DISK;
FILL DF WITH MFID,FID;
SEARCH(DF,A[*]);
LIBRARIAN:=
A[0]!-1;
END;
FILE SPO 11(1,3);
PROCEDURE SPOUT(K); VALUE K; INTEGER K;
BEGIN FORMAT ERRF("APL ERROR:",I8,A1);
WRITE(SPO,ERRF,K,31);
END;
PROCEDURE INITIALIZETABLE;
BEGIN DEFINE STARTSEGMENT= #;
INTEGER I;
LADDRESS:=
ABSOLUTEADDRESS:=ABSADDR(BUFFER);
BIGGEST := REAL(NOT FALSE) & 0[1:46:2];
NULLV := 0 & 3[1:46:2];
STATUSWORD~REAL(BOOLEAN(STATUSWORD) OR BOOLEAN(1));
JOBNUM~TIME(-1);
STATION~0&1[CLOGGED]&STATUSWORD[STU];
FILL JIGGLE[*] WITH OCT5757575757575737;%CARRIAGE RETURNS LEFT ARROW
FILL IDTABLE[*] WITH
"1+481-49", "1&501%07", "1.171@19", "1#411(08",
"1)091/06", "3XEQ623L", "OG541;15", OCT0333777601040177,
%LAST IN ABOVE LINE IS REALLY 3["]141"
"202:=042", "[]101[11", "1]123AND", "212OR223",
"NOT233LS", "S243LEQ2", "53GEQ273", "GTR283NE", "Q292=:05",
"2GO051=2", "63MAX304", "CEIL303F", "LR313MIN",
"314RESD3","23ABS323","RHO341*1","84IOTA35",
"1|384RND", "M425TRAN", "S431$133", "PHI374FA",
"CT404COM", "B406CIRC", "LE456SOR", "TUP556SO",
"RTDN561:", "474NAND5", "83NOR594", "TAKE604D",
"ROP613RE", "P446BASV", "AL393EPS", "331,1600";
COMMENT IDTABLE IS TABLE OF RESERVED WORDS AND SPECIAL SYMBOLS.
FORMAT IS NUMBER OF CHARACTERS IN SYMBOL, FOLLOWED BY SYMBOL
ITSELF, FOLLOWED BY A TWO-DIGIT DECIMAL CODE WHICH APL USES
FOR THE RESERVED WORD--LIKE IN THE EXECUTION CASE STATEMENT AND
IN SYNTAX CHECKING. FOR SCAN TO WORK, THE TWO-DIGIT CODE MUST
BE GREATER THAN 3 AND IDTABLE MUST HAVE AT LEAST ONE "0" AT THE
END TO MARK THE END. TABSIZE IS THE DEFINE (LINE 30000) GIVING
THE SIZE OF IDTABLE;
IF STACKSIZE=0 THEN STACKSIZE:=100 ELSE
IF STACKSIZE GTR 1022 THEN STACKSIZE:=1022;
BUFFSIZE:=MAXBUFFSIZE;
LINETOG := TRUE; %USUALLY GO TO NEXT LINE WHEN WRITING OUT
INITBUFF(OUTBUFF, 10);
INITBUFF(BUFFER,BUFFSIZE);
NROWS:=-1;
NAME(LIBJOB,TIME(-1));
FILL MESSTAB[*] WITH
"4SAVE ",
"4LOAD ",
"5CLEAR ",
"4COPY ",
"4VARS ",
"3FNS ",
"6LOGGED",
"3MSG ",
"5WIDTH ",
"3OPR ",
"6DIGITS",
"3OFF ",
"6ORIGIN",
"4SEED ",
"4FUZZ ",
"3SYN ",
"5NOSYN ",
"5STORE ",
"5ABORT ",
"2SI ",
"3SIV ", 00105360P20
"5ERASE ",
%--------------MASTERMODE BELOW HERE...(SEE USERTOP)--------
"6ASSIGN",
"6DELETE",
"4LIST ",
"5DEBUG ",
"5FILES ";
IF LIBSIZE=-1 THEN
BEGIN LIBSIZE~1;GTA[0]~" ";STOREORD(LIBRARY,GTA,0);WRAPUP;
END ELSE BEGIN LIBSIZE~SIZE(LIBRARY);
FOR I~1 STEP 1 UNTIL LIBSIZE-1 DO
BEGIN GT1~CONTENTS(LIBRARY,I,ACCUM);
IF NOT LIBRARIAN(ACCUM[0],TIME(-1)) THEN
BEGIN DELETE1(LIBRARY,I);LIBSIZE~LIBSIZE-1;END;
IF (LOGINSIZE:=SIZE(LOGINCODES)=0) THEN
END;
END;
FILL CORRESPONDENCE[*] WITH
OCT1111111111110311,
OCT1111111111111111,
OCT1104111121221113,
OCT2014151617100706,
OCT1111111111111112,
OCT1111111111111100,
OCT0201111111251111,
OCT2324111111111111;
COMMENT CORRESPONDENCE GIVES THE CORRESPONDENCE BETWEEN THE
APL CODES FOR DYADIC SCALAR OPERATORS (EXCEPT CIRCLE) AND
THEIR POSITIONS IN THE "CASE STATEMENT" IN "OPERATION".
E.G. APL CODE 7 IS "OPERATION" CODE 3 IN OCTAL (FOR DIVIDE).
IF N-TH CHARACTER IN CORRESPONDECE IS OCTAL 11, THEN N
IS NOT AN APL CODE FOR A DYADIC SCALAR OPERATOR. CHARACTER
COUNT STARTS AT 1 FOR FIRST CHARACTER. TO MAKE IT COME OUT
RIGHT, STREAM PROCEDURE GETOP IS ACTUALLY CALLED WITH APL
OPERATION CODE MINUS 1;
END;
REAL STREAM PROCEDURE CONV(ADDR,N);
VALUE N,ADDR;
BEGIN SI:=ADDR;
DI:=LOC CONV;
DS:=N OCT; END;
REAL STREAM PROCEDURE BUMP(ADDR,N); VALUE ADDR,N;
BEGIN SI:=ADDR; SI:=SI+N; BUMP:=SI; END;
REAL PROCEDURE NUMBER;
BEGIN REAL NCHR;
LABEL GETFRAC,GETPOWER,QUIT,KITE;
MONITOR EXPOVR;
REAL PROCEDURE INTCON(COUNT); VALUE COUNT;
REAL COUNT;
BEGIN REAL TLO,THI,T; INTEGER N;
BOOLEAN DPTOG; DEFINE ADDR=ADDRESS#;
COMMENT: VALUE OF INTCON IS THE CONVERSION OF AN INTEGER
CONSISTING OF COUNT NUMERICAL CHARACTERS STARTING
AT THE CHARACTER ADDRESS. ADDRESS IS SET TO POINT
TO THE NEXT CHARACTER DURING INTCON;
DPTOG:=COUNT GTR 8;
THI:=T:=CONV(ADDR,N:=COUNT MOD 8);
ADDR:=BUMP(ADDR,N);
COUNT:=COUNT DIV 8;
FOR N:=1 STEP 1 UNTIL COUNT DO BEGIN
IF DPTOG THEN BEGIN
DOUBLE(THI,TLO,100000000.0,0,|,CONV(ADDR,8),
0,+,:=,THI,TLO);
T:=THI
END ELSE T:=T|100000000 + CONV(ADDR,8);
ADDR:=BUMP(ADDR,8); END;
INTCON:=T;
END OF INTCON;
INTEGER STREAM PROCEDURE SUBSCAN(ADDR,NEXT); VALUE ADDR;
BEGIN SI:=ADDR;
63(IF SC GEQ "0" THEN
IF SC LEQ "9" THEN BEGIN SI:=SI+1; TALLY:=TALLY+1;
END ELSE JUMP OUT);
DI:=NEXT; DI:=DI+7; DS:=1 CHR; SUBSCAN:=TALLY;
END;
COMMENT--VALUE OF SUBSCAN IS NUMBER OF NUMERIC CHARACTERS
FOUND. NEXT CONTAINS THE FIRST NON-NUMERIC CHARACTER;
EXPOVR:=KITE;
MANTSIGN:=1;
MANT:=MANTLEN:=POWER:=POWERLEN:=FRAC:=FRACLEN:=0;
MANLEN:=SUBSCAN(ADDRESS,NCHR);
IF MANTLEN=0 AND NCHR="#" THEN BEGIN 00130500P21
MANTSIGN:=-1;
ADDRESS:=BUMP(ADDRESS,1);
MANTLEN:=SUBSCAN(ADDRESS,NCHR); END;
IF MANTLEN=0 THEN BEGIN ADDRESS:=BUMP(ADDRESS,1);
IF NCHR="." THEN GO TO GETFRAC
ELSE IF NCHR="@" OR NCHR="E" THEN GO TO GETPOWER
ELSE BEGIN ERR:=SYNTAXERROR;
GO TO QUIT; END; END;
MANT:=INTCON(MANTLEN);
IF NCHR="." THEN BEGIN ADDRESS:=BUMP(ADDRESS,1); GO GETFRAC END;
IF NCHR="@" OR NCHR="E" THEN BEGIN
ADDRESS:=BUMP(ADDRESS,1); GO TO GETPOWER END;
IF NCHR=12 THEN EOB:=1;
GO TO QUIT;
GETFRAC: FRACLEN:=SUBSCAN(ADDRESS,NCHR);
IF FRACLEN=0 THEN BEGIN ERR:=SYNTAXERROR; GO TO QUIT; END;
FRAC:=INTCON(FRACLEN);
IF NCHR="@" OR NCHR="E" THEN BEGIN
ADDRESS:=BUMP(ADDRESS,1); GO TO GETPOWER; END;
IF NCHR=12 THEN EOB:=1 ELSE
IF NCHR="." OR NCHR="#" THEN ERR:=SYNTAXERROR;
GO TO QUIT;
GETPOWER:
POWERLEN:=SUBSCAN(ADDRESS,NCHR);
IF POWERLEN=0 THEN BEGIN
IF NCHR="-" OR NCHR="#" THEN POWER:=-1
ELSE IF NCHR="+" THEN POWER:=1
ELSE BEGIN ERR:=SYNTAXERROR; GO TO QUIT; END;
POWERLEN:=SUBSCAN(ADDRESS:=BUMP(ADDRESS,1), NCHR);
END ELSE POWER:=1;
IF POWERLEN=0 THEN ERR:=SYNTAXERROR
ELSE BEGIN
POWER:=INTCON(POWERLEN)|POWER;
IF NCHR="#" OR NCHR="@" OR NCHR="."
THEN ERR:=SYNTAXERROR; END;
GO TO QUIT;
KITE: ERR:=KITEERROR;
QUIT: IF ERR=0 THEN
NUMBER:=IF MANTLEN+FRACLEN=0 THEN
IF POWERLEN=0 THEN 0
ELSE MANTSIGN|10*ENTIER(POWER)
ELSE MANTSIGN|(MANT|10*ENTIER(POWER)
+ FRAC|10*ENTIER(POWER-FRACLEN)) ELSE EOB:=1;
END OF NUMBER;
STREAM PROCEDURE APPENDTOBUFF(BUF,NBUF,NBLANK,A,SA,NA);
VALUE NBUF,NBLANK,SA,NA;
BEGIN LOCAL T;
LOCAL TSI,TDI;
SI:=LOC NBUF; DI:=LOC T; DI:=DI+1; DS:=7CHR;
DI:=BUF; T(2(DI:=DI+32)); DI:=DI+NBUF;
NBLANK(DS:=LIT" "); TDI:=DI;
SI:=LOC SA; DI:=LOC T; DI:=DI+1; DS:=7CHR;
SI:=A; T(2(SI:=SI+32)); SI:=SI+SA;
TSI:=SI; SI:=LOC NA; DI:=LOC T; DI:=DI+1; DS:=7CHR;
SI:=TSI; DI:=TDI; T(2(DS:=32CHR)); DS:=NA CHR
END;
PROCEDURE TERPRINT;
BEGIN LABEL BK;
STREAM PROCEDURE FINISHBUFF(BUF,N,TER);VALUE N,TER;
BEGIN LOCAL T;
SI:=LOC TER;SI:=SI+7;IF SC="1" THEN;
SI:=LOC N; DI:=LOC T; DI:=DI+1; DS:=7 CHR;
DI:=BUF; T(2(DI:=DI+32));DI:=DI+N;
IF TOOGLE THEN DS:=2 LIT"{!"; %CARRIAGE RETURN/LINE FEED
DS:=RESET;DS:=5 SET; %END OF MESSAGE LEFT ARROW
END OF FINISHBUFF;
IF CHRCOUNT NEQ 0 THEN BEGIN
FINISHBUFF(OUTBUFF,CHRCOUNT,LINETOG);
CHRCOUNT:=0;
IF LINETOG THEN
WRITE(TWXOUT,9,OUTBUFF[*])[BK:BK] ELSE
WRITE(TWXOUT[STOP],9,OUTBUFF[*])[BK:BK];
INITBUFF(OUTBUFF, 10);
END;
IF FALSE THEN
OK: IF CURRENTMODE=XEQMODE THEN BREAKFLAG:=TRUE;
END OF TERPRINT;
PROCEDURE FORMWD(CC,WD); VALUE CC,WD; REAL WD; INTEGER CC;
BEGIN
INTEGER I,K,L;
COMMENT CC=-1 STAY ON LINE, OUTPUT, DON"T GO TO NEXT LINE
COMMENT CC=0 STAY ON THIS LINE, MORE TO COME.
CC=1 STAY ON THIS LINE BUT TERMINATE PRINT. 00257000P22
CC=2 SKIP TO NEXT LINE - MORE TO COME.
CC=3 SKIP TO NEXT LINE - TERMINATE PRINT.;
REAL STREAM PROCEDURE OCTAL(I); VALUE I;
BEGIN SI:=LOC I; DI:=LOC OCTAL; DS:=8OCT
END;
IF L:=LINESIZE LEQ 9 OR L GTR 72 THEN L:=72; K:=2;
IF CC GTR 1 AND CHRCOUNT GTR OTHEN TERPRINT;
IF CHRCOUNT+(I:=OCTAL(WD.[1:11])) GTR L THEN
BEGIN APPENDTOBUFF(LINEBUFFER,CHRCOUNT,
0,WD,2,K:=L-CHRCOUNT);
CHRCOUNT:=L; TERPRINT;
I:=I-K;
END;
APPENDTOBUFF(LINEBUFFER,CHRCOUNT,0,WD,K,I);
CHRCOUNT:=CHRCOUNT+I;
IF BOOLEAN(CC) THEN
IF CC=-1 THEN BEGIN LINETOG:=FALSE;
TERPRINT; LINETOG:=TRUE
END ELSE TERPRINT;
END;
BOOLEAN PROCEDURE FUNCTIONHEADER(SPECS,HADDR);
ARRAY SPECS[0]; REAL HADDR; FORWARD;
REAL PROCEDURE LINENUMBER(R); VALUE R; REAL R;
COMMENT STARTS ON 8030000;
FORWARD;
PROCEDURE INDENT(R); VALUE R; REAL R;
BEGIN
INTEGER STREAM PROCEDURE FORM(A,I,K);VALUE K,I;
BEGIN
LOCAL T1,T2;
LABEL SHORT,L,M,FINIS;
TALLY:=K; FORM:=TALLY;
SI:=LOC I; DI:=LOC T1; IF 8SC=DC THEN
BEGIN DI:=A; K(DS:=LIT" "); GO FINIS
END;
SI:=LOC I; DI:=A; TALLY:=3; DS:=LIT"[";
IF SC GTR "0" THEN IF SC LSS "0" THEN ;
3(TALLY:=TALLY+1; IF TOGGLE THEN DS:=CHR ELSE
IF SC NEQ "0" THEN DS:=CHR ELSE
BEGIN TALLY:=TALLY+63; SI:=SI+1
END );
DS:=CHR; T1:=TALLY; TALLY:=4; SI:=SI+3;
4(IF SC NEQ "0" THEN JUMP OUT TO M;
TALLY:=TALLY+63; SI:=SI-1); GO TO L;
M:
T2:=TALLY; SI:=LOC I; SI:=SI+4; DS:=LIT"."; DS:=T2 CHR;
TALLY:=T1; TALLY:=TALLY+T2; TALLY:=TALLY+1; T1:=TALLY;
L:
DS:=LIT"]"; TALLY:=K;
T1(TALLY:=TALLY+63; T2:=TALLY; SI:=LOC T2; SI:=SI+7;
IF SC="0" THEN JUMP OUT TO SHORT);
T2(DS:=LIT" "); GO FINIS;
SHORT:
TALLY:=T1; TALLY:=TALLY+1; FORM:=TALLY; DS:=LIT" ";
FINIS:
DS:=RESET; DS:=5SET;
END;
IF R LSS 0 THEN R:=LINENUMBER(-R) ELSE R:=ABS(R); % -0
CHRCOUNT:=FORM(LINEBUFF,R,MARGINSIZE)+1
END;
INTEGER PROCEDURE HEADER(ADDR1,ADDR2,BUF); VALUE ADDR1,ADDR2;
INTEGER ADDR1, ADDR2; ARRAY BUF[0];
BEGIN
INTEGER STREAM PROCEDURE HEADRR(ADDR1,ADDR2,BUF); VALUE ADDR1,
ADDR2;
BEGIN
LOCAL C,T,TDI;
LOCAL QM,AR;
LABEL L,ENDSCAN,M,N;
DI:=LOC QM; DS:=2RESET; DS:=2SET;
DI:=LOC AR; DS:=RESET; DS:=5SET;
DI:=BUF;
SI:=ADDR1;
L: T:=SI; TDI:=DI 00287210P23
DI:=LOC QM; IF SC=DC THEN GO TO ENDSCAN;
DI:=LOC AR; SI:=SI-1; IF SC=DC THEN GO TO ENDSCAN;
SI:=LOC T; DI:=LOC ADDR2;
IF 8SC=DC THEN COMMENT END OF SCAN;
GO TO ENDSCAN;
SI:=T; DI:=TDI; DS:=CHR;
GO TO L;
ENDSCAN:
SI:=TDI;
M: SI:=SI-1;
IF SC=" " THEN GO TO M;
SI:=SI+1;
ADDR2:=SI;
SI:=BUF;
N: T:=SI; DI:=LOC ADDR2;
SI:=LOC T;
IF 8SC NEQ DC THEN
BEGIN
TALLY:=TALLY+1; TDI:=TALLY;
SI:=LOC TDI; SI:=SI+7;
IF SC="0" THEN
BEGIN TALLY:=C; TALLY:=TALLY+1; C:=TALLY;
TALLY:=0;
END;
SI:=T; SI:=SI+1; GO TO N;
END;
HEADRR:=TALLY; SI:=LOC C; DI:=LOC HEADRR; SI:=SI+1; DS:=6 CHR;
END;
HEADER:=HEADRR(ADDR1,ADDR2,BUF);
END OF PHONY HEADER;
PROCEDURE STARTSCAN;
BEGIN
LADDRESS:=
ADDRESS:=ABSOLUTEADDRESS;
BEGIN TERPRINT;
END;
READ(TWXIN[STOP],29,BUFFER[*]);
BUFFER[30]:=0&31[1:43:5];
ITEMCOUNT:=0;
EOB:=0
END;
PROCEDURE FORMROW(CC,BL,A,S,N); VALUE CC,BL,S,N; INTEGER CC,BL,
S,N; ARRAY A[0];
COMMENT: CC--SAME CODE AS IN FORMWD, LINE 253000
BL--#BLANKS TO PUT IN FRONT OF IT
A--ARRAY WHERE THE STUFF TO PUT ON LINE IS STORED
S--#CHARACTERS TO SKIP AT START OF A
N--#CHARACTERS TO TAKE FROM A TO PUT ON OUTPUT LINE;
BEGIN INTEGER K;
INTEGER T;
IF CC GTR 1 AND CHRCOUNT GTR 0 THEN TERPRINT;
IF K:=LINESIZE LEQ 9 OR K GTR 72 THEN K:=72;
WHILE CHRCOUNT+N+BL GTR K DO
BEGIN
APPENDTOBUFFER(LINEBUFFER,CHRCOUNT,BL,A,S,T:=K-CHRCOUNT-BL);
CHRCOUNT:=K; TERPRINT;
S:=S+T; N:=N-T;
BL:=0;
END;
APPENDTOBUFFER(LINEBUFFER,CHRCOUNT,BL,A,S,N);
CHRCOUNT:=CHRCOUNT+N+BL;
IF BOOLEAN(CC) THEN
IF CC=-1 THEN BEGIN LINETOG:=FALSE;
TERPRINT; LINETOG:=TRUE;
END ELSE TERPRINT;
END;
PROCEDURE NUMBERCON(R,A); VALUE R; REAL R; ARRAY A[0];
BEGIN FORMAT F(F24.*), G(E24.*);
REAL S; DEFINE MAXIM = 10@9#;
STREAM PROCEDURE ADJUST(A,B);
BEGIN LOCAL T,FRAC,MANT,T1,TSI,TDI;
DI:=LOC T; DI:=DI+1; T1:=DI;
SI:=B; DI:=A; DI:=DI+2;
24(IF SC=" " THEN SI:=SI+1 ELSE
BEGIN TSI:=SI; SI:=LOC T;
IF SC="1" THEN; SI:=TSI;
IF TOGGLE THEN
IF SC NEQ "0" THEN 00342000P24
IF SC="@" THEN BEGIN
TSI:=SI; DI:=T1; DS:=LIT"1"; JUMP OUT;
END ELSE FRAC:=TALLY
ELSE TALLY := TALLY+0
ELSE
IF SC="." THEN
BEGIN MANT:=TALLY; TDI:=DI; DI:=LOC T; DS:=
LIT"1"; TALLY:=0;DI:=TDI;
END;
TALLY:=TALLY+1; DS:=CHR
END);
SI:=LOC MANT; SI:=SI+7; IF SC="0" THEN MANT:=TALLY;
TALLY:=MANT; SI:=LOC FRAC; SI:=SI+7; IF SC GTR "0"
THEN TALLY:=TALLY+1; TALLY:=TALLY+FRAC; MANT:=TALLY;
SI:=T1; IF SC="1" THEN BEGIN
DI:=A; DI:=DI+MANT; DI:=DI+2;
SI:=TSI; DS:=4CHR;
TALLY:=TALLY+4; MANT:=TALLY; END;
SI:=LOC MANT; SI:=SI+6; DI:=A; DS:=2CHR;
END;
IF S:=ABS(R) GEQ MAXIM OR S LEQ 10*(-DIGITS) AND S NEQ 0 THEN
WRITE(SCR[*],G,DIGITS,R) ELSE
WRITE(SCR[*],F,DIGITS,R);
ADJUST(A,SCR)
END;
PROCEDURE STOREPSR;
BEGIN INTEGER I;
DELETE1(WORKSPACE,0);
I:=STORESEQ(WORKSPACE,PSR,PSRSIZE|8);
COMMENT USED TO CALL WRAPUP;
END;
PROCEDURE RESCANLINE;
BEGIN ADDRESS:=ABSOLUTEADDRESS; EOB:=0; END;
PROCEDURE PROCESS(MODE);VALUE MODE; INTEGER MODE; FORWARD;
PROCEDURE MESSAGEHANDLER; FORWARD;
PROCEDURE FUNCTIONHANDLER; FORWARD;
PROCEDURE ERRORMESS(N,ADDR,R); VALUE N,ADDR,R; REAL R;
INTEGER N;REAL ADDR;FORWARD; COMMENT LINE 5000000;
STREAM PROCEDURE SETFIELD(A,S,L,R); VALUE S,L,R;
BEGIN DI:=A; DI:=DI+S; SI:=LOC R; SI:=SI+8; L(SI:=SI-1);
DS:=L CHR;
END;
COMMENT: VALUE OF GETFIELD IS L CHARACTERS, STARTING AT J-TH
CHARACTER OF A, RIGHT-ADJUSTED. L MUST BE LEQ 8 AND
J MUST BE LESS THAT 64;
REAL STREAM PROCEDURE GETFIELD(A,S,L); VALUE S,L;
BEGIN SI:=A; SI:=SI+S; DI:=LOC GETFIELD; DI:=DI+8; L(DI:=DI-1);
DS:=L CHR;
END;
REAL PROCEDURE TOPLINE(ORD); VALUE ORD; INTEGER ORD;
BEGIN
INTEGER STREAM PROCEDURE CON(A); VALUE A;
BEGIN SI:=LOC A; DI:=LOC CON; DS:=8OCT END;
ARRAY A[0:1]; INTEGER I;
I:=CONTENTS(ORD,SIZE(ORD)-1,A);
TOPLINE:=CON(A[0])/10000
END;
BOOLEAN PROCEDURE FUNCTIONHEADER(SPECS,HADDR);
ARRAY SPECS[0]; REAL HADDR;
BEGIN
LABEL A,B,C;
INTEGER P;
DEFINE NOTE=HADDR.[24:24]:=ADDRESS#,P8=8|P+1#;
ERR:=0;
SPECS[0]:=SPECS[1]:=SPECS[2]:=SPECS[3]:=0;
NOTE; HADDR.[1:23]:=GT1:=ADDRESS;
IF SCAN AND IDENT THEN
BEGIN
TRANSFER(ACCUM,2,SPECS,1,7);
NOTE;
IF SCAN THEN
IF LFTARROW THEN
BEGIN
SPECS[1]:=1;
SPECS[3]:=1;
TRANSFER(SPECS,1,SPECS,33,7);
GT2:=ADDRESS;
IF SCAN AND IDENT THEN
BEGIN
TRANSFER(ACCUM,2,SPECS,1,7);
NOTE;
IF SCAN THEN 00501600P25
C: IF IDENT THEN
BEGIN
P:=(SPECS[3]:=SPECS[3]+1)+3;
TRANSFER(ACCUM,2,SPECS,P8,7);
SPECS[2]:=1;
NOTE;
IF SCAN THEN IF IDENT THEN
BEGIN SPECS[2]:=2;
P:=(SPECS[3]:=SPECS[3]+1)+2;
TRANSFER(SPECS,1,SPECS,P8+8,7);
TRANSFER(SPECS,P8,SPECS,1,7);
TRANSFER(ACCUM,2,SPECS,P8,7);
B: NOTE; IF SCAN THEN
A: IF SEMICOLON THEN IF SCAN THEN
IF IDENT THEN
BEGIN
P:=(SPECS[3]:=SPECS[3]+1)+3;
TRANSFER(ACCUM,2,SPECS,P8,7);
GO TO B;
END ELSE GO TO A
ELSE ELSE ELSE
END ELSE GO TO A
ELSE END
ELSE GO TO A ELSE
END ELSE ERRORMESS(ERR:=1,GT2,0)
END ELSE GO TO C
ELSE
END ELSE ERRORMESS(ERR:=SYNTAXERROR,GT1,0);
FUNCTIONHEADER:=ERR=0;
ADDRESS:=HADDR.[24:24];
END FUNCTIONHEADER;
INTEGER PROCEDURE DAYTIME(B); ARRAY B[0]; FORWARD;
COMMENT ON LINE 8014000, ARRAY B MUST HAVE LENGTH
AT LEAST 3 WDS;
PROCEDURE EDITLINE; FORWARD;
INTEGER PROCEDURE LENGTH(A,M);VALUE M; BOOLEAN M; ARRAY A[0];
FORWARD; COMMENT LINE 8007900;
BOOLEAN PROCEDURE LABELSCAN(L,K); VALUE K; INTEGER K;
ARRAY L[0]; FORWARD; COMMENT LINE 8013910;
PROCEDURE CHECKSEQ(SEQ,L,INC); REAL SEQ,L,INC; FORWARD;
COMMENT ON LINE 8040000;
PROCEDURE RELEASEARRAY(D);VALUE D; REAL D;
BEGIN COMMENT RELEASE PERMANENT STORAGE FOR THE ARRAY DESC D;
INTEGER K,J,PT;
ARRAY BLOCK[0:32]; %SEE MAXWORDSTORE, LINE 17260
ARRAY TEMP[0:1];
IF D.RF NEQ 0 THEN
BEGIN DELETE1(WS,D.DIMPTR);
K:=CONTENTS(WS,D.INPTR,BLOCK)-1;
DELETE1(WS,D,INPTR);
FOR J:=0 STEP 2 UNTIL K DO
BEGIN TRANSFER(BLOCK,J,TEMP,6,2);
PT:=TEMP[0]; DELETE1(WS,PT); END;
END;
END;
PROCEDURE TRANSFERSP(DIR,SP,L,B,M,N); VALUE DIR,N,M,L;
INTEGER DIR,N,M,L;
ARRAY SP[0,0],B[0];
BEGIN COMMENT
DIR= INTO: TRANSFER N WORDS FROM B[L] INTO SP[M]
(ACTUALLY SP[*,M] SINCE ARRAY ROW IS USUALLY THE ARG)
DIR= OUTOF (OPPOSITE);
STREAM PROCEDURE MOVER(DIR,SP,M,B,L,N); VALUE DIR,
L,M,N;
BEGIN LOCAL T;
SI:=LOC L; DI:=LOC T; DI:=DI+1; DS:=7CHR;
SI:=SP; T(16(SI:=SI+32)); L(SI:=SI+8); L:=SI;
SI:=LOC M; DI:=LOC T; DI:=DI+1; DS:=7CHR;
SI:=B; T(16(SI:=SI+32)); M(SI:=SI+8); M:=SI;
SI:=LOC N; DI:=LOC T; DI:=DI+1; DS:=7CHR;
SI:=LOC DIR; SI:=SI+7;
IF SC="0" THEN
BEGIN SI:=M; DI:=L
END ELSE
BEGIN SI:=L ; DI:=M
END;
T(2(DS:=32WDS)); DS:=N WDS;
END;
INTEGER K; 03002210P26
WHILE N:=N-K GTR 0 DO
MOVER(DIR,SP[(L:=L+K)DIV SPRSIZE,*],
M:=M+K,B,K:=L MOD SPRSIZE,
K:=MIN(SPRSIZE-K,N))
END;
PROCEDURE DUMPOLISH(SP,PD); VALUE PD; REAL PD; ARRAY SP[0,0];
BEGIN INTEGER L;
LABEL SKIPREST;
INTEGER I,N,M,U; REAL T;
L:=PD.SPF;
I:=SP[LOC]+L;
FOR L:=L+2 STEP 1 UNTIL I DO
IF (T:=SP[LOC]).TYPEFIELD=FUNCTION THEN
BEGIN % OUTPUT MESSAGE AND NAME
FORMWD(2,"5FUNC: ");
N:=T.LOCFIELD; % N HAS LOCATION OF DESCRIPTOR
N:=N-1; % BACK UP ONE TO GET NAME
GTA[0]:=SP[NOC];
FORMROW(1,1,GTA,1,7);
END
ELSE % MIGHT BE AN OPERATOR
IF T.TYPEFIELD=OPERATOR THEN
BEGIN COMMENT OUTPUT MESSAGE AND OP CODE;
FORMWD(2,"5ATOR: ");
NUMBERCON(T.OPTYPE,ACCUM);
FORMROW(0,1,ACCUM,2,ACOUNT);
NUMBERCON(T.LOCFIELD,ACCUM);
FORMROW(1,1,ACCUM,2,ACOUNT);
END ELSE %MAY BE A CONSTANT
IF T.TYPEFIELD=CONSTANT THEN
BEGIN COMMENT GET DATA DESCRIPTOR;
N:=T.LOCFIELD;
FORMWD(2,"5CONS: ");
T:=SP[NOC]; %T HAS THE DATA DESCRIPTOR
IF T.SPF=0 THEN BEGIN % A NULL VECTOR
FORMWD(1,"4NULL ");
GO TO SKIPREST; END;
N:=T.SPF; %N HAS THE SCALAR OR TOP OF VECTOR LOC.
IF BOOLEAN(T.SCALAR) THEN M:=U:=N ELSE
BEGIN U:=SP[NOC]+N; M:=N+1; %UPPER AND LOWER BOUNDS
END;
IF BOOLEAN(T.CHRMODE) THEN %CHARACTER FORMAT
BEGIN COMMENT SP[NOC] IS NUMBER OF CHRS;
TRANSFERSP(OUTOF,SP,M,BUFFER,0,ENTIER(((T:=
SP[NOC])-1)DIV 8+1));
FORMROW(1,1,BUFFER,0,T);
END ELSE % SHOULD TEST FOR NULL...DO IT LATER.
FOR N:=M STEP 1 UNTIL U DO
BEGIN NUMBERCON(SP[NOC],ACCUM);
FORMROW(0,1,ACCUM,2,ACOUNT);
END;
TERPRINT;
SKIPREST:
END ELSE COMMENT MUST BE AN OPERAND;
IF T.TYPEFIELD=LOCALVAR THEN
BEGIN FORMWD(2,"5LOCL: ");
N:=T.SPF; % N HAS LOCATION OF NAME;
GTA[0]:=SP[NOC]; % PUT NAME IN GTA
FORMROW(1,1,GTA,1,7);
END ELSE
BEGIN COMMENT TREAT IT AS VARIABLE;
N:=T.LOCFIELD; COMMENT N HAS LOC OF DESCRIPTOR;
N:=N-1; COMMENT BACKUP OVER THE DESCRIPTOR;
GTA[0]:=SP[NOC];
FORMWD(2,"5AND : ");
FORMROW(1,1,GTA,1,7);
END;
END;
PROCEDURE PROCESS(MODE); VALUE MODE; INTEGER MODE;
BEGIN
OWN INTEGER J;
OWN REAL RESULTD;
LABEL EXPOVRL,INTOVRL,INDEXL,FLAGL,ZEROL;
MONITOR EXPOVR,INTOVR,INDEX,FLAG,ZERO;
LABEL DEBUGSP; %DEBUGGING PURPOSES ONLY.
INTEGER PROCEDURE BUILDCONSTANT(LASTCONSTANT);
INTEGER LASTCONSTANT; FORWARD;
INTEGER PROCEDURE GETSPACE(LENGTH); VALUE LENGTH;
INTEGER LENGTH; FORWARD;
PROCEDURE OPERANDTOSYMTAB(L);VALUE L;INTEGER L;FORWARD;
REAL PROCEDURE BUILDALPHA(LASTCONSTANT); 03100440P27
INTEGER LASTCONSTANT; FORWARD;
INTEGER PROCEDURE BUILDNULL(LASTCONSTANT);
INTEGER LASTCONSTANT; FORWARD;
PROCEDURE SCRATCHDATA(D);VALUE D;REAL D; FORWARD;
COMMENT LINE 3121400;
PROCEDURE FORGETPROGRAM(U);VALUE U;REAL U; FORWARD;
COMMENT ANALYZE IS IN PROCESS BECAUSE OWN ARRAY SP
IS ADDRESSED INCORRECTLY OTHERWISE;
REAL PROCEDURE ANALYZE(DISPLAYOP); VALUE DISPLAYOP;BOOLEAN DISPLAYOP;
BEGIN COMMENT
BC= BUILDCONSTANT,
GS= GET SPACE PROCEDURE ;
ARRAY INFIX[0:MAXPOLISH];
INTEGER LASTCONSTANT;
DEFINE GS=GETSPACE#;
BOOLEAN STREAM PROCEDURE EQUAL(A,B);
BEGIN SI:=A; SI:=SI+1; DI:=B; DI:=DI+2;
IF 7SC=DC THEN TALLY:=1;
EQUAL:=TALLY;
END;
PROCEDURE UNSTACK(DEST,L,ORIG,OTOP,N,CHR1,CHR2);
VALUE N,CHR1,CHR2;
INTEGER N,CHR1,CHR2,L,OTOP;
ARRAY DEST[0,0],ORIG[0];
BEGIN
REAL T,U;
WHILE OTOP GTR 0 AND N GTR 0 AND ERR=0 DO
IF(IF (T:=ORIG[OTOP]).TYPEFIELD=FUNCTION THEN FALSE ELSE
U:=T.LOCFIELD=CHR1 OR U=CHR2) THEN %UNSTACK
BEGIN
IF N GTR 1 THEN
IF U=CHR2 THEN ERR:=SYNTAXERROR ELSE
OTOP:=OTOP-1;
N:=N-1;
END ELSE
COMMENT WE ARE LOOKING AT AN OPERATOR OR A FUNCTION;
BEGIN
IF J NEQ 0 THEN
BEGIN L:=L+1;
DEST[LOC]:=ORIG[OTOP]
END;
OTOP:OTOP-1
END;
IF N GTR 1 THEN ERR:=SYNTAXERROR;
END;
INTEGER ITOP,K,L,I;
INTEGER M,N,FLOC; REAL T;
LABEL SKIPSCAN,FILLER;
LABEL SPFULLAB;
PROCEDURE FORGETSPACE(L,LENGTH,SP); VALUE L,LENGTH;
INTEGER L,LENGTH; ARRAY SP[0,0];
BEGIN IF LENGTH GTR 0 THEN
BEGIN SP[LOC]:=SP[0,0];
SP[LOC].LEN:=LENGTH; SP[0,0]:=L
END;
END;
IF CURRENTMODE=FUNCMODE OR STACKBASE=0 THEN FLOC:=0 ELSE
BEGIN L:=STACKBASE+1;L:=SP[LOC].SPF+1;M:=SP[LOC].SPF+L;
FLOC:= IF M=L OR BOOLEAN(T:=SP[MOC]).SUSPENDED THEN 0 ELSE T.SPF
END;
T:=ADDRESS;
ITOP:=0;
DO
SKIPSCAN:
IF ITOP LSS MAXPOLISH THEN
BEGIN
INFIX[ITOP:=ITOP+1].ADDRFIELD:=T;
IF SPECIAL THEN
IF QUOTEV THEN % CONSTANT VECTOR
BEGIN INFIX[ITOP].TYPEFIELD:=CONSTANT;
IF T:=BUILDALPHA(LASTCONSTANT) NEQ 0 THEN
INFIX[ITOP].LOCFIELD:=T ELSE ERR:=SYNTAXERROR
END ELSE % ORDINARY OPERATOR
BEGIN INFIX[ITOP].TYPEFIELD:=OPERATOR; 03101550P28
...
UNTIL NOT(SCAN AND ERR=0); %DROP THRU WHEN INPUT FIN OR ERR 03104040P29
...
IF INFIX[I].OPTPE NEQ DYADIC THEN SINFIX[I].OPTYPE:=MONADIC; 03104840P30
...
IF OTOP LSS ITOP DIV 2 THEN ELSE ERR:=SYNTAXERROR; 03105087P31
...
BEGIN 03105383P32
...
T.OPTYPE:=MONADIC; 03106260P33
...
GTR MAXPROGS THEN %OFF THE END OF SP 03110920P34
...
BUILDCONSTANT:=L:=GS(1); %VECTOR DESCRIPTOR 03114800P35
...
BEGIN 03121255P36
...
SETFIELD(NEWDESC,7,1, IF BOOLEAN(T.SCALAR) 03124650P37
...
END; 03140080P38
INTEGER C;
...
T:=SP[NOC]; SP[NOC.NAMED:=1; N:=T; 03140600P39
...
BEGIN SI:=A;SI:=SI+B;DI:=C;DI:=DI+D;DS:=CHR;END; 03150085P40
...
L:=GETSPACE(N:=(NUMELEMENTS(D)+D,RF)); 03150650P41
...
WHILE TRUE DO % RECURSIVE EVALUATION LOOP 03151310P42
...
M := M + NJ; CC := 2; END; 03152646P43
...
AND N.QUADIN=4) THEN POPPROGRAM:=TRUE; 03155000P44
...
%ELSE WE HAVE AN ERROR (MISSING " ETC) 03210520P45
...
OUTER:=(START:=L+RANK+J|MAT) + COL - 1; 03221020P46
...
OP APL OPERATOR OP APL OPERATOR 03230015P47
...
ANS := IF RIGHT | LEFT = 1 THEN 0 ELSE 1; %NAND 03233400P48
...
DESC.SPF:=I; DESC.DID:=DDPUVW; SPCOPY(L,I,RANK1); 03235100P49
...
PROCEDURE DYADICRNDM;
BEGIN INTEGER NUM, KIND; REAL DESC;
REAL DESC1, DESC2;
INTEGER START; LABEL INSERT;
DESC1 := AREG; DESC2 := BREG;
IF FINDSIZE(DESC1) NEQ 1 OR FINDSIZE(DESC2) NEQ 1;
THEN BEGIN ERR:=RANKERROR; GO TO QUIT; END;
IF DESC1.SPF=0 OR DESC2.SPF=0 THEN BEGIN
ERR:=DOMAINERROR; GO TO QUIT; END;
L:=DESC1.SPF+DESC1.RF; M:=DESC2.SPF+DESC2.RF;
NUM := SP[LOC]; KIND := SP[MOC];
IF KIND LSS ORIGIN
OR NUM GTR PICK := KIND-ORIGIN+1
OR DESC1.ARRAYTYPE=1
OR DESC2.ARRAYTYPE=1 THEN BEGIN ERR:=DOMAINERROR;
GO TO QUIT; END;
IF NUM LEQ 0 THEN BEGIN DESC := NULLV; GO TO QUIT; END;
IF NUM GTR MAXWORDSIZE THEN BEGIN ERR:=KITEERROR; GO TO QUIT; END;
DESC.SPF := L := GETSPACE(NUM+1);
SP[LOC] := NUM; L := L+1;
OUTTOP := L+NUM-1;
TEMP := GETSPACE(NUM);
START:=ORIGIN; I:=0;
FOR L:=L STEP 1 UNTIL OUTTOP DO BEGIN
PICK:=RANDINT(START,KIND,SEED);
M:=TEMP;
IF I = 0 OR PICK LSS SP[MOC] THEN N:=TEMP 03239380P50
ELSE BEGIN TOP:=TEMP+I-1;
N:=TEMP+T:=I DIV 2;
WHILE T GTR 0 DO
IF PICK GEQ SP[NOC] THEN N:=N+T:=T DIV 2
ELSE N:=N-T:=T DIV 2;
FOR N:=MAX(TEMP,N-1) STEP 1 UNTIL TOP DO
IF SP[NOC] GTR PICK THEN
GO TO INSERT;
END;
INSERT: IF L LSS OUTTOP THEN BEGIN TOP:=N+1; N:=TEMP+I;
FOR M:=N STEP -1 UNTIL TOP DO BEGIN
N:=N-1; SP[MOC] := SP[NOC] - 1; END;
SP[NOC] := PICK; END;
SP[LOC] := N - TEMP + PICK;
KIND:=KIND-1;
I:=I+1;
END;
FORGETSPACE(TEMP,NUM);
QUIT: RESULTD := DESC;
END PROCEDURE DYADICRNDM;
PROCEDURE RHOP;
BEGIN INTEGER RANK,M,POINT; REAL NEWDESC,DESC1,DESC;
LABEL QUIT,WORK; BOOLEAN CHARACTER;
DEFINE TOOBIG=BEGIN ERR:=KITEERROR; GO TO QUIT; END#;
INTEGER N,TOP,NEWRANK,RANK1, POINT1,SIZE1,L,SIZE2;
DESC1 := AREG; DESC := BREG;
IF DESC.SPF = 0 THEN BEGIN ERR:=DOMAINERROR; GO TO QUIT; END;
IF DESC1.DIF NEQ 0 THEN BEGIN %--DYADIC RHO--RESTRUCTURING---------
IF L:=DESC1.SPF = 0 THEN BEGIN %NULL LEFT OP MEANS SCA;LAR ANS
IF DESC.ARRAYTYPE=1 THEN TOOBIG; %NO SCALAR CHARACTERS
NEWDESC.SPF:=M:=GETSPACE(1);
NEWDESC.DID:=DDPUSW;
L:=DESC.SPF+DESC.RF;
SP[MOC]:=SM[LOC]; GO TO QUIT; END;
IF DESC1.ARRAYTYPE NEQ 0 THEN BEGIN
ERR:=DOMAINERROR; GO TO QUIT; END;
RANK1:=DESC1.RF;
IF FINDSIZE(DESC1)=1 THEN BEGIN
N:=L+RANK1;
IF SIZE1:=ENTIER(SP[NOC]+.5) LSS 0 THEN BEGIN
ERR:=DOMAINERROR; GO TO QUIT; END;
NEWRANK:=1; TOP:=N; GO TO WORK; END;
IF RANK1 NEQ 1 THEN BEGIN ERR:=RANKERROR; GO TO QUIT; END;
FOR N:=L+RANK1 STEP 1 UNTIL TOP DO
IF SIZE1:=SIZE1?ENTIER(SP[NOC]+.5) LSS 0 THEN BEGIN
ERR:=DOMAINERRPOR; GO TO QUIT; END;
WORK: IF SIZE1=0 THEN BEGIN NEWDESC := NULLV; GO TO QUIT END;
IF SIZE1 GTR MAXWORDSTORE THEN TOOBIG;
NEWDESC.SPF := M := GETSPACE(SIZE1+NEWRANK);
%CANT USE SPCOPY FOR DIM VECTOR AS LEFT OP MAY NOT BE INTEGER
FOR L:=L+RANK1 STEP 1 UNTIL TOP DO;
BEGIN SP[NOC]:=ENTIER(SP[LOC]+.5); M:=M+1; END;
SIZE2:=FINDSIZE(DESC); L:=DESC.SPF; RANK:=DESC.RF;
IF DESC.ARRAYTYPE=1 THEN BEGIN L:=UNPACK(L,RANK,SIZE2);
CHARACTER:=TRUE; END; TOP:=SIZE1 DIV SIZE2; POINT:=L+RANK;
FOR N:=1 STEP 1 UNTIL TOP DO BEGIN SPCOPY(POINT,M,SIZE2);
M := M+SIZE2; END;
TOP := SRIZE1 MOD SIZE2; SPCOPY(POINT,M,TOP);
GO TO QUIT; END ELSE
%--------MONADIC RHO-----DIMENSION VECTOR----------------------
RANK := DESC.RG; POINT := DESC.SPF;
NEWDESC.DID := DDPUVW; NEWDESC.RF := 1;
IF DESC.DATATYPE = 1 THEN BEGIN
NEWDESC := NULLV; GO TO QUIT END;
NEWDESC.SPF := M := GETSPACE(RANK+1);
SP[MOC] := RANK;
SPCOPY(POINT,M+1, RANK);
QUIT: IF CHARACTER THEN BEGIN NEWDESC.ARRAYTYPE:=1;
FORGETSPACE(L,SIZE2+RANK);
PACK(NEWDESC.SPF, NEWRANK,SIZE1); END;
RESULTD := NEWDESC;
END PROCEDURE RHOP;
PROCEDURE IOTAP;
BEGIN INTEGER I,L,M,TOP; REAL DESC;
REAL LEFTOP, RIGHTOP;
INTEGER RSIZE,LSIZE,RRANK,LRANK,N,LL,MM,TIP,NIX;
LABEL QUIT, DONE; 03240800P51
LEFTOP:=AREG; RIGHTOP:=BREG
IF L:=RIGHTOP.SPF=0 THEN BEGIN ERR:=DOMAINERROR; GO TO QUIT END;
RSIZE:=FINDSIZE(RIGHTOP); RRANK:=RIGHTOP.RF;
DESC.DEIC := DDPUVW; DESC.RF := 1;
IF LEFTOP.DID NEQ 0 THEN BEGIN %-------DYADIC IOTA------------
IF LRANK := LEFTOP.RF GTR 1 THEN BEGIN ERR:=RANKERROR;
GO TO QUIT; END;
LSIZE := FINDSIZE(LEFTOP);
IF M:=ALEFTOP.SPF=0 THEN BEGIN %RESULT IS ORIGIN IF IT WAS NULL
DESC.SPF:=M:=GETSPACE(1); DESC.RF:=0; DESC.SCALAR:=1;
SP[MOC] := ORIGIN; GO TO QUIT; END;
IF LEFTOP.ARRAYTYPE=1 THEN M:=UNPACK(M,LRANK,LSIZE);
IF RIGHTOP.ARRAYTYPE=1 THEN L:=UNPACK(L,RRANK,RSIZE);
TIP := (NTX:=LSIZE+ORIGIN) - 1;
DESC.SPF:=N:=GETSPACE(RSIZE+RRANK);
IF RRANK=0 THEN DESC.SCALAR:=1 ; DESC.RF:=RRANK;
SPCOPY(L,N,RRANK);
MM := M+LRANK; LL:=L:=L+RRANK;
TOP:=N+RRANK+RSIZE-1;
FOR N:=N+RRANK STEP 1 UNTIAL TOP DO BEGIN
SP[NOC] := NIX;
M := MM;
FOR I:=ORIGIN STEP 1 UNTIL TOP DO BEGIN
IF OPERATION(SP[MOC],SP[LOC],1,12,LEFTOP) AND LEFTOP=1
THEN BEGIN SP[NOC]:=I; GO TO DONE;
END ELSE M:=M+1;
DONE: L:=L+1; END;
IF LEFTOP.ARRAYTYPE=1 THEN FORGETSPAZE(MM-LRANK,LRANK+LSIZE);
IF RIGHTOP.ARRAYTYPE=1 THEN FORGETSPZE(LL-RRANK,RRANK+RSIZE);
END ELSE BEGIN %-------------MONADIC IOTA------------------
IF RIGHTOP.ARRAYTYPE=1 THEN
BEGIN ERR:=DOMAINERROR; GO TO QUIT
END;
IF RSIZE NEQ 1 THEN BEGIN ERR:=RANKERROR; GO TO QUIT END;
L := L + RRANK;
IF TOP:=SP[LOC] GTR MAXWORDTORE THEN
BEGIN ERR:=KITEERROR; GO TO QUIT
END;
IF TOP LSS ORIGIN THEN BEGIN DESC:=NULLV; GO TO QUIT END;
DESC.SPF := M := GETSPACE(TOP+1);
SP[MOC] := TOP; M := M+1;
TOP := TOP _ ORIGIN - 1;
FOR I := ORIGIN STEP 1 UNTIL TOP DO BEGIN
SP[MOC] := I; M := M+1; END;
END;
QUIT: RESULTD := DESC;
END PROCEDURE IOTAP;
PROCEDURE COMMAP;
BEGIN REAL LDESC, RDESC;
INTEGER L,M,N,LRANK,RRANK,LSIZE,RSIZE,SIZE;
REAL DESC; LABEL QUIT; BOOLEAN CHARACTER;
LDESC := AREG; RDESC := BREAG;
RRANK := RDESC.RF; LRANK := LDESC.RF;
LSIZE := IF (L := LDESC.SPF) = 0 THEN 0 ELSE FINDSIZE(LDESC);
RSIZE := IF (M := RDESC.SPF) = 0 THEN 0 ELSE FINDSIZE(RDESC);
IF RDESC.ARRAYTYPE = 1 THEN BEGIN
M := UNPACK(M,RRANK,RSIZE);
CHARACTER := TRUE; END;
DESC.DID := DDPUVW; DESC.RF := 1;
IF LDESC.DID = 0 THEN BEGIN %-----MONADIC COMMA--RAVEL--------
IF RSIZE=0 THEN BEGIN DESC:=NULLV; GO TO QUIT END;
DESC.SPF := L := GETSPACE(RSIZE+1);
SP[LOC] := RSIZE;
SPCOPY(M+RRANK, L+1, RSIZE);
N := L; SIZE := RSIZE;
GO TO QUIT; END
ELSE BEGIN
%HERE IS THE CODE FOR DYADIC COMMA, I.E. CATNETATION
IF RRANK NEQ 1 AND RSIZE GTR 1 OR
LRANK NEQ 1 AND LSIZE GTR 1 THEN BEGIN
ERR:= RANKERROR; GO TO QUIT; END;
IF SIZE:=LSIZE+RSIZE GTR MAXWORDSTORE THEN BEGIN
ERR:=KITEERROR; GO TO QUIT; END;
COMMENT CANT MIX NUMBER AND CHARACTERS, HAVE TO JUGGLE
IF LEFT IS NUMBERS AND RIGHT IS CHARACTERS AS RIGHT
HAS ALREADY BEEN UNPACKED AND WE DONT WANT TO FORGET
LEFT AND DONT WANT TO PACK THE NON-RESULT;
IF CHARACTER THEN
IF LDESC.ARRAYTYPE=1 OR LSIZE=0 THEN L:=UNPACK(L,LRANK,LSIZE)
ELSE BEGIN SIZE:=0; LSIZE:=-LRANK; ERR:=DOMAINERROR;
GO TO QUIT END 03243705P52
ELSE IF LDESC.ARRAYTYPE=1 THEN
IF RSIZE NEQ 0 THEN
BEGIN ERR:=DOMAINERROR; GO TO QUIT END
ELSE BEGIN CHARACTER:=TRUE;
L:=UNPACK(L,LRANK,LSIZE); END;
IF SIZE=0 THEN BEGIN DESC:=NULLV; GO TO QUIT END;
DESC.SPF := N := GETSPACE(SIZE=1);
SP[NOC] := SIZE;
SPCOPY(L+LRANK, N+1, LSIZE);
SPCOPY(M+RRANK, N+LSIZE+1, RSIZE);
END;
QUIT:
IF CHARACTER THEN BEGIN DESC.ARRAYTYPE := 1;
PACK(N,1,SIZE);
FORGETSPACE(L,LSIZE+LRANK);
FORGETSPACE(M,RSIZE+RRANK);
END;
RESULTD := DESC;
END PROCEDURE COMMAP;
INTEGER STREAM PROCEDURE GETOP(A,N); VALUE N;
BEGIN SI := A; SI := SI + N;
DI := LOC GETOP;
DS := 7 LIT "0"; DS := CHR;
END PROCEDURE GETOP;
REAL PROCEDURE IDENTITY(OP); VALUE OP; INNTEGER DP;
BEGIN
CASE OP OF BEGIN
IDENTITY := 0; %FOR +
IDENTITY := 1; %FOR |
IDENTITY := 0; %FOR -
IDENTITY := 1; %FOR DIV
IDENTITY := 1; %FOR *
; %NO REDUCTION ON RNDM
IDENTITY := 0; %FOR RESQ
IDENTITY := BIGGEST; %FOR MIN
IDENTITY := -BIGGEST; %FOR MAX
; %NOT ISNT DYADIC
IDENTITY := 1; %FOR COMB
IDENTITY := 0; %FOR LSS
IDENTITY := 1; %FOR =
IDENTITY := 1; %FOR GEQ
IDENTITY := 0; %FOR GTR
IDENTITY := 0; %FOR NEQ
IDENTITY := 1; %FOR LEQ
IDENTITY := 1; %FOR AND
IDENTITY := 0; %FOR OR
END; END PROCEDURE IDENTITY;
INTEGER PROCEDURE GETT(ALLONG,RANK); VALUE ALONG, RANK;
INTEGER ALONG, RANK;
GETT:= IF ALONG=1 THEN 0 ELSE
IF ALONG=RANK THEN 2 ELSE
IF ALONG=RANK-1 THEN 1 ELSE 0;
BOOLEAN PROCEDURE CHECKANDADD(SIZE,L,SUM);
VALUE SIZE,L; INTEGER SIZE,L,SUM;
BEGIN LABEL QUIT; INTEGER I,TOP,M,S,T;
CHECKANDADD:=TRUE;
SUM := 0;
TOP := SIZE DIV 2 ? 2 - 1 + L;
FOR L:=L STEP 2 UNTIL TOP DO BEGIN M:=L+1;
IF NOT BOOLTYPE(S:=SP[LOC], T:=SP[MOC]) THEN BEGIN
CHECKANDADD:=FALSE; GO TRO QUIT; END
ELSE SUM := SUM+S+T; END;
IF SIZE MOD 2 = 1 THEN BEGIN
IF NOT BOOLTYPE(T:=SP[LOC],0) THEN
CHECKANDADD := FALSE ELSE SUM := SUM+T;
END;
QUIT: END PROCEDURE CHECKANDADD;
PROCEDURE COMPRESS(LDESC, RDESC, DIM); VALUE LDESC,RDESC,DIM;
REAL LDESC, RDESC, DIM;
BEGIN INTEGER I,J,K,L,M,N,T,RANK,LSIZE,RSIZE,ALONG,TOP,
FACTOR,SUM,DIMMOD,SIZE,LEFT,RIGHT,S;
REAL DESC; BOOLEAN CHARACTER;
LABEL QUIT,RANKE,DOMAIN,IDENT;
DESC.ID := DDPUVW;
IF L := LDESC.SPF = 0 THEN GO TO DOMAIN;
IF M:=RDESC.SPF = 0 THEN BEGIN DESC:=NULLV; GO TO QUIT; END;
LSIZE := FINDSIZE(LDESC) RSIZE := FINDSIZE(RDESC);
IF RANK:=LDESC.RF NEQ 1 THEN IF LSIZE NEQ 1
THEN GO TO DOMAIN;
LEFT := L := L+RANK;
RANK := RDESC.RF;
IF N:=DIM.SPF=0 AND DIM.DID NEQ 0 OR DIM.ARRAYTYPE=1
OR LDESC.ARRAYTYPE=1 THEN GO TO DOMAIN; 03254510P53
IF J:=DIM.RF NEQ 0 THEN BEGIN
IF DINDSIZE(DIM)=1 THEN N:=N+J ELSE GO TO DOMAIN END;
IF ALONG:=(IF N=J THEN RANK ELSE SP[NOC]-ORIGIN+1) GTR RANK
OR ALONG LSS 1 AND RANK NEQ 0
THEN BEGIN ERR:=INDEXERROR; GO TO QUIT; END;
IF RANK = 0 THEN
IF LSIZE NEQ 1 THEN GO TO DOAMIN ELSE BEGIN
IF TOP:=SP[LOC]=0 THEN BEGIN DESC:=NULLV; GO TO QUIT; END;
IF TOP = 1 THEN BEGIN DESC.SPF := N := GESTAPCES(2);
DESC.RF := SP[NOC] := 1;
N:=N+1; SP[NOC]:=SP[MOC]; GO TO QUIT;
END ELSE GO TO DOMAIN; END;
IF LSIZE = 1 THEN BEGIN
COMMENT IF LEFT ARG IS SCALAR, ANSWER IS NULL IF 0,
RIGHT ARG IF 1;
SUN:=SP[LOC];
IF SUM NEQ 0 AND SUM NEQ 1 THEN GO TO DOMAIN
ELSE GO TO INDENT; END;
N := M+ALONG - 1;
IF LSIZE NEQ (T:=SP[NOC]) THEN BEGIN
ERR:=LENGTHERROR; GO TO QUIT; END;
IF NOT CHECKAND ADD(LSIZE,LEFT,SUM) THEN GRO TO DOMAIN;
IDENT: IF SUM=0 THEN BEGIN DESC:=NULLV; GO TO QUIT END;
IF SUM = LSIZE THEN BEGIN
RSIZE:=RSIZE DIV 8 + (IF RSIZE MOD 8 NEQ 0 THEN 1 ELSE 0);
DESC.CHRMODE:=1; END;
DESC.SPF:=N:=GETSPACE(TOP:=RSIZE+RANK);
DESC.RF := RANK; SPCOPY(M,N,TOP); GO TO QUIT; END;
SIZE := RSIZE DIV T ? SUM;
DESC.RF:=RANK;
IF RDESC.ARRAYTYPE = 1 THEN BEGIN M:=UNPACK(M,RANK,RSIZE);
CHARACTER := TRUE; END;
RIGHT := M;
DESC.SPF := S := GESTAPE(SIZE+RANK);
N := S;
FOR I:=1 STEP 1 UNTIL RANK DO BEGIN
IF I=ALONG THEN SP[NOC]:=SUM ELSE SP[NOC]:=SP[MOC];
N:=N+1; M:=M+1; END;
T := GETT(ALONG, RANK);
FACTOR := 1; TOP := RIGHT+ALONG;
FOR N:=RIGHT+RANK-1 STEP -1 UNTIL TOP DO FACTOR:=
FACTOR ? SP[NOC];
N:=RIGHT + RANK - 1; DIM := SP[NOC];
N := N+1; M:=S+RANK; I:=0;
DIMMOD := DIM-1;
WHILE I LSS RSIZE DO BEGIN
CASE T OF BEGIN
L := I DIV FACTOR MOD LSIZE;
L := I DIV FACTOR MOD DIMMOD;
L := I MODE DIM; END;
L := L+LEFT;
IF SP[LOC] = 1 THEN FOR K:=1 STEP 1 UNTIL FACTOR DO BEGIN
SP[MOC]:=SP[NOC]; I:=I+1; M:=M=1; N:=N+1;
END ELSE BEGIN I:=I+FACTOR; N:=N+FACTOR; END;
END;
GO TO QUIT;
RANKE: ERR:=RANKERROR; GO TO QUIT;
DOMAIN: ERR:=DOMAINERROR; GO TO QUIT;
QUIT: IF CHARACTER THEN BEGIN PACK(S,RANK,SIZE);
DESC.ARRAYTYPE:=1; FORGETSPACE(RIGHT,RSIZE+RANK); END;
RESULTD := DESC;
POP;
END PROCEDURE COMPRESS;
PROCEDURE EXPAND(LDESC,RDESC,DIM); VALUE LDESC,RDESC,DIM;
REAL LDESC,RDESC, DIM;
BEGIN INTEGER I,J,K,L,M,N,S,T,RANK,LSIZE,RSIZE,SIZE,
ALONG,TOP,LADDR,MADDR,FACTOR, SUM;
REAL DESC, INSERT;
LABEL QUIT, DOMAIN;
BOOLEAN CHARACTER;
LSIZE:=FINDSIZE(LDESC); RSIZE:=FINDSIZE(RDESC);
RANK := RDESC.RF;
IF M:=RDESC.SPF=0
OR L:=LDESC.SPF=0
OR I:=LDESC.RF GTR 1
OR N:=DIM.SPF=0 AND DIM.DID NEQ 0
OR DIM.ARRAYTYPE=1
OR FINDSIZE(DIM ) NEQ 1
OR LDESC.ARRAYTYPE=1
THEN GO TO DOMAIN; 03268280P54
N:=N + (T:=DIM.RF);
IF ALONG :=(IF N=T THEN RANK ELSE SP[NOC]-ORIGIN+1) GTR RANK
OR ALOG LSS 1 AND RANK NEQ 0
THEN BEGIN ERR:=INDEXERROR; GO TO QUIT; END;
IF RANK=0 THEN DIM:=1
ELSE BEGIN N:=M+ALONG-1; DIM:=SP[NOC]; END;
IF SIZE:=RSIZE DIV DIM ? LSIZE GTR MAXWORDSTORE
THEN BEGIN ERR:=KITEERROR; GO TO QUIT; END;
IF NOT CHECKANDADD(LSIZE,LADDR:=L+I, SUM) THEN GO TO DOMAIN;
IF SUM NEQ DIM THEN BEGIN ERR:=RANKERROR; GO TO QUIT; END;
IF RANK=0 THEN BEGIN
DIM:=SP[MOC]; DESC.SPF:=N:=GETSPACE(LSIZE+1);
DESC.RF:=I; DESC.DIS:=(IF I=0 THEN DDPUSW ELSE DDPUVW);
SPCOPY(L,N,I); L:=L+I; N:=N+I; TOP:=L+LSIZE-1;
FOR L:=L STEP 1 UNTIL TOP DO BEGIN
IF SP[LOC]=1 THEN SP[NOC]:=DIM;
N:=N+1; END;
GO TO QUIT END;
IF RDESC.ARRAYTYPE=1 THEN BEGIN CHARACTER:=TRUE;
M:=UNPACK(M,RANK,RSIZE);
INSERT := " "; END;
FACTOR:=1; TOP:=M+ALONG;
FOR N:=M+RANK-1 STEP -1 UNTIL TOP DO FACTOR:=FACTOR?SP[NOC];
T := GETT(ALONG, RANK);
J:=0; N:=(MADDR:=M) + RANK;
DESC.SPF:=M:=GETSAPCE(SIZE+RANK);
I:=M+RANK;
WHILE J LSS SIZE DO BEGIN
CASE T OF BEGIN
S := J DIV FACTOR MOD LSIZE;
S:=J DIV FACTOR MOD LSIZE;
S:=J MODE LSIZE; END;
L:=S + LADDR;
IF SP[LOC]=1 THEN FOR K:=1 STEP 1 UNTIL FACTOR DO
BEGIN L:=K+I; SP[LOC] := SP[NOC];
J:=J+1; N:=N+1;
END ELSE FOR K:=1 STEP 1 UNTIL FACTOR DO BEGIN
L:=J+I; SP[LOC]:=INSERT; J:=J+I; END;
END;
L := MADDR;
FOR I:=1 STEP 1 UNTIL RANK DO BEGIN
IF I = ALONG THEN SP[MOC]:=LSIZE ELSE SP[MOC]:=SP[LOC];
M:=M+1; L:=L+1; END;
DESC.DID:=DDPUVW; DESC.RF:=RANK;
GO TO QUIT;
DOMAIN: ERR:=DOMAINERROR;
QUIT: IF CHARACTER THEN BEGIN DESC.ARRAYTYPE:=1;
FORGETSPACE(MADDR, RSIZE+RANK);
PACK(DESC.SPF,RANK,SIZE); END;
RESULTD:=DESC;
POP;
END PROCEDURE EXPAND;
PROCEDURE MEMBER;
BEGIN REALLDESC, RDESC;
INTEGER L,M,N,I,S,T,LSIZE,RSIZE,LRANK,RRANK,TOP;
REAL DESC, TEMP, ANS;
LABEL QUIT;
LDESC := AREG; RDESC := BREG;
LSIZE:=FINDSIZE(LDESC); RSIZE:=FINDSIZE(RDESC);
LRANK:=LDESC.FR; RRANK:=RDESC.RF;
IF L:=LDESC.SPF=0 OR M:=RDESC.SPF=0 THEN BEGIN
ERR:=DOMAINERROR; GO TO QUIT END;
IF LDESC.ARRAYTYPE=1 THEN L:=UNPACK(L,LRANK,LSIZE);
IF RDESC.ARRAYTYPE=1 THEN M:=UNPACK(M,RRANK,RSIZE);
DESC:=LDESC; DESC.NAMED:=0;
DESC.ARRAYTYPE:=0;
DESC.SPF:=N:=GETSAPCE(LSIZE+LRANK);
SPCOPY(L,N,LRANK);
N:=N+LRANK; L:=(T:=L)+LRANK; M:=(S:=M)+RRANK;
T:=M+RSIZE-1; TOP := L+LSIZE-1;
FOR L:=L STEP 1 UNTIL TOP DO BEGIN
TEMP:=SP[LOC]; M:=S;
WHILE M LEQ T DO
IF OPERATION(TEMP,SP[MOC],0,12,ANS) AND ANS=1 THEN BEGIN
SP[NOC]:=1; M:=M+T; END ELSE M:=M+1;
N:=N+1; END;
IF RDESC.ARRAYTYPE=1 THEN FORGETSPACE(S,RSIZE+RRANK);
IF LDESC.ARRAYTYPE=1 THEN FORGETSPACE(I,LSIZE+LRANK);
QUIT: RESULTD:=DESC;
END PROCEDURE MEMBER;
REAL PROCEDURE BASEVALUE;
BEGIN 03269860P55
COMMENT THIS RETURNS A DESCRIPTOR FOR A SCALAR RESULT;
LABEL OUTE,BAD;
REAL E,L,M,LEFT,RIGHT,T,LARG,RARG;
LARG := AREG; RARG := BREG;
IF M:=RARG.SPF=0 LARG.CHRMODE=1 OR RARG.CHRMODE=1
OR L:=LARG.SPF=0 AND LARG.DID NEQ 0
THEN GO TO BAD;
RIGHT:=SP[MOC];
LEFT:=SP[LOC];
IF FINDSIZE(LARG)=1 THEN % A 1 ELEMENT VECTOR
BEGIN
L:=L+LARG.RF;
LARG.SCALAR:=1;
LEFT:=SP[LOC];
END;
IF FINDSIZE(RARG)=1 THEN % A ONE ELEMENT VECTOR
BEGIN
M:=M+RARG.RF;
RIGHT:=SP[MOC];
RARG.SCALAR:=1;
END;
IF L=0 THEN
BEGIN % BASEVAL MONADIC
LEFT:=2; %IF MONADIC, ITS 2 BASVAL X
LARG.SCALAR:=1;
END;
IF BOOLEAN(LARG.SCALAR )THEN %SCALAR
IF BOOLEN(RARG.SCALAR) THEN
BEGIN
T:=RIGHT; %SCALAR-SCALAR
GO OUTE;
END
ELSE
IF RARG.RF=1 THEN
BEGIN COMMENT SCALAR-VECTIOR--LEFT IS VALUE OF SCALAR, RIGHT
IS # OF ELEMENTS;
IF LEFT=0 THEN GO OUTE
ELSE E:=1/LEFT;
FOR L :=M+RIGHT STEP -1 UNTIL M+1 DO
T:=T+SP[LOC]\(E:=E\LEFT);
GO OUTE;
END
ELSE BAD: ERR:=BOMAINERROR
ELSE
IF RARG.SCALAR=0 THEN
IF LARG.RF NQ 1 OR RARG.RF NEQ 1 THEN
ERR:=DOMAINERROR
ELSE
BEGIN
GT2:=L; % SAVE FOR LATER TEST
GT1:=M+2; % WANT TO STOP 2 UP IN LOOP
L:=L+LEFT; % START AT OTHER END
E:=1;
M:=M+RIGHT;
T:=SP[MOC]; % INITIAL VALUE
FOR M:=M-1 STEP -1 UNTIL GT1 DO
BEGIN
IF L:=L-1 LSS GT2 THEN L:=GT2+LEFT; % START OVER
E:=E?SP[LOC];
T:=T+SP[MOC]?E;
END;
OUTE:
L:=GETSPACE(1);
SP[LOC]:=T;
T:=0;
T.DID:=DDPUSW; % BUILD DESCRIPTOR
T.SPF:=L;
BASEVALUE:=T;
END
ELSE ERR := DOMAINERROR
END OF BASEVALUE;
REAL PROCEDURE REPRESENT;
BEGIN
COMMENT RETURNS DESCRIPTOR OF VECTOR IF LARG VECTOR AND RARG SCALAR;
REAL L,M,LEFT,RIGHT,T,E,LARG,RARG;
LABEL AROUND
LARG := AREG; RARG := BREG;
IF (RARG.SCALAR=1 OR FINDSIZE(RARG)=1 AND RARG.CHRMODE=0)
AND NOT(LARG.SCALAR=1 OR LARG.CHRMODE=1 OR LARG.RF NEQ 1) THEN
BEGIN
COMMENT VECTOR-SCALAR;
IF L:=LARG.SPF=0 OR M:=RARG.SPF=0 THEN GO AROUND;
IF RARG.SCALAR=0 THEN M:=M+RARG.RF; 03271020P56
RIGHT:=SP[MOC]; % VALUE OF SCALAR
LEFT:=SP[LOC]; % LENGTH OF VECTOR
E:=M:=GETSPACE(LEFT+1); % MAKE ROOM FOR ANSWER
SP[MOC]:=LEFT; % LENGTH OF ANSWER
M:=M+LEFT;
GT1:=L+2;
FOR L:=L+LEFT STEP -1 UNTIL GT1 DO
IF T:=SP[LOC] LEQ 0 THEN
IF T LSS 0 THEN ERR:= DOMAINERROR
ELSE
BEGIN
L:=GT1-1 ; % STOP THE LOOP
M:=M-1;
END
ELSE
BEGIN
SP[MOC]:= RIGHT MOD T;
RIGHT:=RIGHT DIV T;
M:=M-1;
IF RIGHT LSS FUZZ THEN L:=GT1-1; % STOP THE LOOP
END;
SP[MOC]:=RIGHT; % LEFTOVER GOES HERE
T.DID:=DDPUVW;
T.RF:=1;
T.SPF:=E;
REPRESENT:=T;
END;
ELSE AROUND: ERR:=DOMAINERROR;
END OF REPRESENT;
PROCEDURE PERIOD(LDESC,RDESC,LOP,ROP);
VALUE LDESC,RDESC,LOP,ROP; REAL LDESC,RDESC; INTEGER LOP,ROP;
BEGIN INTEGER L,M,N,J,LRANK,RRANK,RANK,LSIZE,RSIZE,SIZE,LL,MM,I,
RROW,RCOL,LROW,LCOL,LJUMP,RJUMP,MSAVE,LSAVE,RSTART;
REAL DESC, TEMP;
BOOLEAN CHARACTER, FIRST,LSCALAR, RSCALAR;
LABEL QUIT, DOMAIN, FORGET, OUTERPROD;
IF L:=LDESC.SPF = 0 OR M:= RDESC.SPF=0 THEN GO TO DOMAIN;
LSIZE := FINDSIZE(LDESC); RSIZE:=FINDSIZE(RDESC);
LRANK:=LDESC.RF; RRANK := RDESC.RF;
IF LOP NEQ 45 THEN
IF LRANK GTR 2 AND LSIZE NEQ 1 OR RRANK GTR 2 AND RSIZE NEQ 1 THEN
BEGIN ERR:=KITEERROR; GO TO QUIT; END;
IF ROP:=GETOP(CORRESPONDENCE,ROP-1) = 9 THEN BEGIN
ERR:=SYNTAXERROR; GO TO QUIT; END;
IF LL:=LDESC.ARRAYTYPE=1 OR MM:=RDESC.ARRAYTYPE=1 THEN
IF LL ? MM NEQ 1 THEN GO TO DOMAIN
ELSE BEGIN
IF ROP LSS 11 OR ROP GTR 16 THEN GO TO DOMAIN;
CHARACTER:=TRUE;
M:=UNPACK(M.RRANK,RSIZE);
L:=UNPACK(L,LRANK,LSIZE); END;
MSAVE := M; LSAVE:=L; IF ROP NEQ 45 THEN
IF LOP=45 THEN GO TO OUTERPROD ELSE
IF LOP:=GETOP(CORRESPONDENCE,LOP-1)=9 THEN
BEGIN ERR:=SYNTAXERROR; GO TO QUIT; END;
IF LRANK=2 THEN BEGIN
N:=L+LRANK-1; LCOL := SP[NOC];
N:=N-1; RROW:=SP[NOC]; END;
IF LRANK=1 THEN BEGIN LROW:=1; LCOL:=SP[LOC]; END;
IF RRANK=2 THEN BEGIN
N :=M+RRANK-1; RCOL:=SP[NOC];
N:=N-1; RROW:=SP[NOC]; END;
IF RRANK=1 THEN BEGIN RROW:=SP[MOC]; RCOL:=1; END;
IF LSIZE =1 OR RSIZE=1 THEN BEGIN
IF LSIZE = 1 AND RSIZE = 1 THEN LROW:=LCOL:=RROW:=RCOL:=1
ELSE IF LSIZE=1 THEN BEGIN LCOL:=RROW; LRUOW:=1;
L:=L+LRANK-1; LRANK:=1;
LSCALAR:=TRUE; END;
ELSE BEGIN RRROW := LCOL; RCOL := 1;
M:=M+RRANK-1; RRANK:=1;
RSCALAR:=TRUE; END;
END;
IF LCOL NEQ RROW
THEN BEGIN ERR:=RANKERROR; GO TO QUIT; END;
DESC.SPF:=N:=GETSPACE((RANK:=MAX(0,LRANK+RRANK-1))+
SIZE:=LROW?RCOL);
SPCOPY(L,N,LRANK-1);
SPCOPY(M+1,N+LRANK-1,RRANK-1);
DESC.RF:=RANK; DESC.DID:=(IF RANK=0 THEN DDPUSW ELSE DDPUVW);
N:=N+RANK;
LL := L + LRANK - 1;
MM := M + RRANK - 1; 03272500P57
LJUMP := LCOL-1; RJUMP := IF RSCALAR THEN 0 ELSE (RROW-1) ? RCO
FOR J:=1 STEP LCOL UNTIL LSIZE DO
FOR RSTART:=1 STEP 1 UNTIL RCOL DO BEGIN
FIRST:=TRUE;
M := MM + RSTART + RJUMP; RROW := LL + J;
FOR I:=LL +LJUMP + J STEP -1 UNTIL RROW DO BEGIN
IF LSCALR THEN L:=LL+1 ELSE L:=I;
IF FIRST THEN BEGIN
IF NOT OPERATION(SP[LOC],SP[MOC],1ROP,SP[NOC])
THEN GO TO FORGET ELSE FIRST := FALSE;
END ELSE BEGIN
IF NOT OPERATION(SP[LOC],SP[MOC],1,ROP,TEMP)
THEN GO TO FORGET;
IF NOT OPERATION(TEMP,SP[NOC],-1,LOP,SP[NOC])
THEN GO TO FORGET END;
IF NOT RSCALAR THEN M:=M-RCOL; END;
N := N+1;
END;
GO TO QUIT;
OUTERPROD: IF SIZE:=LSIZE?RSIZE GTR MAXWORDSTORE
OR RANK := LRANK+RRANK GTR 31 THEN BEGIN
ERR:=KITEERROR; GO TO QUIT; END;
DESC.SPF:=N:=GETSPACE(SIZE+RANK);
DESC.DID:=IF RANK=0 THEN DDPUSW ELSE DDPUVW;
DESC.RF:=RANK;
SPCOPY(L,N,LRANK);
SPCOPY(M,N+LRANK,RRANK);
N:=N+RANK;
I:=L + LRANK + RSIZE - 1;
MM := M+RRANK + RSIZE - 1;
FOR L:=L+LRANK STEP 1 UNTIL I DO
FOR M:=MSAVE+RRANK STEP 1 UNTIL MM DO
IF NOT OPERATION(SP[LOC],SP[MOC],1,ROP,SP[NOC]) THEN
GO TO FORGET ELSE N:=N+1;
GO TO QUIT;
FORGET: FORGETSPACE(DESC,SPF,RANK+SIZE);
DOMAIN: ERR:=DOMAINERROR;
QUIT: IF CHARACTER THEN BEGIN
FORGETSPACE(MSAVE , RRANK+RSIZE);
FORGETSPACE(LSAVE , LRANK+LSIZE); END;
RESULTD := DESC;
END PROCEDURE PERIOD;
PROCEDURE REVERSE(SOURCE,LENGTH,DEST,JUMP); VALUE SOURCE,DEST,
LENGTH,JUMP; INTEGER SOURCE,LENGTH,DEST,JUMP;
BEGIN INTEGER L,M,TOP;
M:=SOURCE + TOP:=(LENGTH-1) ? JUMP; TOP:=DEST+TOP;
FOR L:=DEST STEP JUMP UNTIL TOP DO BEGIN
SP[LOC] := SP[MOC]; M:=M-JUMP; END;
END PROCEDURE REVERSE;
PROCEDURE ROTATE(SOURCE,LENGTH,DEST,JUMP,ROT); VALUE SOURCE,
LENGTH,DEST,JUMP,ROT; INTEGER SOURCE,LENGTH,DEST,JUMP,ROT;
BEGIN INTEGER L,M,TOP;
TOP := SOURCE + (LENGTH-1) ? JUMP;
FOR L:=SOURCE STEP JUMP UNTIL TOP DO BEGIN
M:=DEST+(ROT MOD LENGTH)?JUMP; SP[MOC]:=SP[LOC];
ROT := ROT + 1; END;
END PROCEDURE ROTATE;
INTEGER PROCEDURE GETNUM(TIM,L,SIZE,DIM); VALUE TIM,L,
SIZE,DIM; INTEGER TIM,L,SIZE,DIM;
BEGIN INTEGER NUM;
IF SIZE NEQ 0 THEN L := L + TIM;
NUM:=SIGN(NUM:=SP[LOC]) ? ENTIER(ABS(NUM)) MOD DIM;
IF NUM LSS 0 THEN GETNUM := -NUM %FOR RIGHT ROTATION
ELSE GETNUM:=DIM-NUM; %FOR LEFT ROTATION
END PROCEDURE GETNUM;
BOOLEAN PROCEDURE MATCHROT(LDESC,RDESC,ALONG); VALUE LDESC,
RDESC,ALONG; INTEGER LDESC,RDESC,ALONG;
BEGIN INTEGER I,L,M,R; LABEL QUIT;
MATCHROT:=TRUE; L:=DESC.SPF; M:=RDESC.SPF;
IF R:=LDESC.RF NEQ RDESC.RF-1 THEN BEGIN
MATCHROT:=FALSE; GO TO QUIT; END;
FOR I:=1 STEP 1 UNTIL R DO BEGIN IF I=ALONG THNE M:=M+1;
IF SP[LOC] NEQ SP[MOC] THEN BEGIN MATCHROT:=FALSE;
GO TO QUIT; END; M:=M+1; L:=L+1; END;
QUIT: END PROCEDURE MATCHROT;
PROCEDURE REDUCESORTSCAN(LOP,REDESC,DIM,KIND); VALUE LOP,RDESC,
DIM,KIND; REAL LOP,RDESC,DIM; INTEGER KIND;
BEGIN INTEGER L,M,N,I,J,K,ALONG,FACTOR,T,MSAVE,DIFF,SSIZE,
JUMP,RANK,SIZE,TOP,LASTDIM,INTERVAL,TEMP,HOP;
INTEGER REMDIM,LRANK,LSAVE,LSIZE,S;
BOOLEAN CHARACTER,REDUCE,SORT,SCAN,REVERSAL,ROTATION;
REAL DESC;
LABEL QUIT, FORGET, RANKERR; 03273620P58
COMMENT: KIND=1 FOR REDUCTION
KIND=2 FOR SORTUP OR SORTDN
KIND=3 FOR SCAN
KIND=4 FOR REVERSAL
KIND=5 FOR ROTATION;
PROCEDURE SORTIT(L,M,SIZE,JUMP,UP); VALUE L,M,SIZE,JUMP,UP;
INTEGER L,M,SIZE,JUMP; BOOLEAN UP;
BEGIN INTEGER N.TIP,TOP,LSAVE;
REAL COMPARE,OUTOFIT;
OUTOFIT:=IF UP THEN BIGGEST ELSE -BIGGEST;
TIP := M + (N:=(SIZE-1) ? JUMP); TOP := L + N;
LSAVE := L;
FOR M:=M STEP JUMP UNTIL TIP FO BEGIN
L := LSAVE; COMPARE := SP[LOC]; N:=L;
FOR L:=L+1 STEP 1 UNTIL TOP DO
IF UP THEN BEGIN IF SP[LOC] LSS COMPARE THEN BEGIN
N:=L; COMPARE:=SP[LOC]; END;
END ELSE IF SP[LOC] GTR COMPARE THEN
N:=L; COMPARE:=SP[LOC]; END;
SP[NOC] := OUTOFIT;
SP[MOC] := (N-LSAVE) + ORIGIN;
END;
END PROCEDURE SORTIT;
CASE KIND OF BEGIN ; REDUCE:=TRUE; SORT:=TRUE; SCAN:=TRUE;
REVERSAL:=TRUE; ROTATION:=TRUE; END;
IF LOP GTR 64 AND NOT ROTATION THEN BEGIN
ERR:=SYSTEMERROR; GO TO QUIT; END;
IF REDUCE OR SCAN THEN IF LOP NEQ 45 THEN
LOP := GETOP(CORRESPONDENCE,LOP-1);
IF M:=RDESC.SPF=0 AND NOT REDUCE
OR DIM.DID NEQ 0 AND N:=DIM.SPF=0 OR DIM.ARRAYTYPE=1
OR FINDSIZE(DIM) NEQ 1 THEN BEGIN
ERR:=DOMAINERROR; GO TO QUIT END;
IF (REDUCE OR SCAN) AND LOP=9 THEN BEGIN %OP NOT DYADIC SCALAR
ERR:=SYNTAXERROR; GO TO QUIT END;
IF M=0 THEN BEGIN
%FOR REDUCTION, RESULT OF A NULL IS CORRESPONDING IDENTITY
%EXCEPT THAT NAND, NOR, CIRCLE, AND LOG (LOP GTR 18)
%HAVE NO IDENTITIES, SO THE RESULT IS A NULL
DESC.DID := DDPUSW;
IF LOP LEQ 18 THEN BEGIN DESC.SPF:=N:=GETSPACE(1);
SP[NOC] := IDENTITY(LOP); END ELSE DESC.RF:=1;
GO TO QUIT; END;
IF RDESC.ARRAYTYPE=1 AND (REDUCE OR SCAN) THEN
BEGIN ARR:=DOMAINERROR; GO TO QUIT; END;
SIZE:=FINDSIZE(RDESC);
RANK:=RDESC.RF;
IF SIZE=1 THEN BEGIN
%UNLESS SORT, RESULT OF SINGLE-VALUED ARGUMENT IS THAT ARGUMENT
DESC := RDESC;
DESC.SPF := N := GETSPACE(RANK+1);
SPCOPY(M,N,RANK);M:=M+RANK;N:=N+RANK;
IF SORT THEN BEGIN SP[NOC]:=ORIGIN; DESC.ARRAYTYPE:=0;
END ELSE SP[NOC]:=SP[MOC];
GO TO QUIT; END;
IF RDESC.ARRAYTYPE=1 THEN BEGIN
CHARACTER := TRUE;
M:=UNPACK(M,RANK,SIZE); END;
MSAVE:=M;
N:=N+(T:=DIM.RF);
IF ALONG:=(IF N=T THEN RANK ELSE SP[NOC]-ORIGIN+1) GTR RANK
OR ALONG LSS 1
THEN BEGINERR:=INDEXERROR; GO TO QUIT; END;
IF ROTATION THEN BEGIN
IF LSAVE:=LOP.SPF=0 OR LOP.ARRAYTYPE=1 THEN
BEGIN ERR:=DOMAINERROR; GO TO QUIT; END;
IF LSIZE:=FINDSIZE(LOP) NEQ 1 THEN
IF NOT MATCHROT(LOP,RDESC,ALONG) THEN BEGIN
ERR:=RANKERROR; GO TO QUIT; END;
LSAVE := LSAVE + LRANK := LOP.RF;
IF LSIZE = 1 THEN LRANK := 0; END;
N:=M+ALONG-1;
DIM:=SP[NOC];
JUMP:=1; I:=M+ALONG;
FOR L:=M+RANK-1 STEP -1 UNTIL I DO JUMP:=JUMP ? SP[LOC];
N:=M+RANK-1; LASTDIM:=SP[NOC];
IF ALONG = RANK-1 THEN BEGIN N:=N-1;
FACTOR:=LASTDIM ? SP[NOC]; END;
T := GETT(ALONG, RANK);
J := M + RANK;
REMDIM := 1;
HOP := (DIM-1) | JUMP; 03274600P59
DESC.DIF := DDPUVW;
IF ALONG GTR 1 AND ALONG LSS RANK-1 THEN BEGIN TOP:=M+ALONG-2;
FOR L:=M STEP 1 UNTIL TOP DO REMDIM:=REMDIM?SP[LOC]; END;
IF REDUCE THEN BEGIN DESC.SPF:=N:=GETSPACE(SSIZE:=SSIZE DIV DIM
+ RANK - 1);
IF RANK=1 THEN DESC.SCALER:=1 ELSE DESC.RF:=RANK-1;
FOR I:=1 STEP 1 UNTIL RANK DO BEGIN
IF I NEQ ALONG THEN BEGIN SP[NOC]:=SP[MOC]; N:=N+1; END;
M:=M+1; END;
JUMP := -JUMP;
END ELSE BEGIN DESC.SPF:=N:=GETSPACE(SSIZE:=SIZE+RANK);
INTERVAL := (DIFF := N-M) + HOP;
SPCOPY(M,N,RANK); DESC.RF:=RANK; END
IF SORT THEN TEMP:=GETSPACE(DIM);
TOP := SIZE DIV (DIM ? REMDIM) - 1;
FOR S:=1 STEP 1 UNTIL REMDIM DO BEGIN
FOR T:=0 STEP 1 UNTIL TOP DO BEGIN
CASE T OF BEGIN
L := I + J;
L:=I DIV LASTDIM?FACTOR + I MOD LASTDIM + J;
L:=I?LASTDIM + J; END;
IF REDUC THEN BEGIN M:=I+N; L:=HOP + (K:=L);
SP[MOC] := SP[LOC];
FOR L:=L+JUMP SETP JUMP UNTIL K DO
IF NOT OPERATION(SP[LOC],SP[MOC],-1,LOP,SP[MOC])
THEN GO TO FORGET;
END ELSE
IF SORT THEN BEGIN K:=L+HOP; N:=TEMP;
FOR M:=L STEP JUMP UNTIL K DO BEGIN
SP[NOC] := SP[MOC]; N:=N+1; END;
IF LOP LSS 0 THEN SORTIT(TEMP,L+DIFF,DIM,JUMP,FALSE)
ELSE SORTIT(TEMP,L+DIFF,DIM,JUMP,TRUE);
END ELSE IF SCAN THEN BEGIN
K:=L+INTERVAL; N:=L+DIFF; SP[NOC] := SP[LOC];
FOR N:=N+JUMP STEP JUMP UNTIL K DO BEGIN
M:=N-JUMP; L:=L+JUMP;
IF NOT OPERATION(SP[MOC],SP[;QOC],-1,LOP,SP[NOC])
THEN GO TO FORGET; END;
END ELSE IF REVERSAL THEN REVERSE(L,DIM,L+DIFF,JUMP)
ELSE IF ROTATION THEN ROTATE(L,DIM,L+DIFF,JUMP,
GETNUM(I,LSAVE,LRANK,DIM));
END;
J := J + ABS(JUMP?DIM);
N := N + TOP + 1;
DIFF := DIFF + TOP + 1;
END;
GO TO QUIT;
RANKERR: ERR:=RANKERROR; FORGETSPACE(DESC.SPF,SSIZE);GO QUIT;
FORGET: ERR:=DOMAINERROR; FORGETSPACE(DESC.SPF, SSIZE);
QUIT: IF CHARACTER THEN BEGIN
FORGETSPACE(MSAVE,SIZE+RANK);
IF (REVERSAL OR ROTATION) AND ERR=0 THEN BEGIN
DEX.ARRAYTYPE:=1; PACK(DESC.SPF,RANK,SIZE); END; END;
IF SORT THEN FORGETSPACE(TEMP,DIM);
RESULTD := DESC;
IF ROTATION THEN POP;
END PROCEDURE REDUCESORTSCAN;
PROCEDURE DYADICTRANS;
BEGIN REAL LDESC,RDESC;
INTEGER L,M,N,RANK,NEWRANK,SIZE,TEMP,I,J;
DEFINE SPTOP=RDESC#,MIN=RDESC#,PTR=REWRANK#,MBASE=LDESC#,TOP=RDESC#
,RESULT=RESULTD#;
LABEL QUIT; BOOLEAN CARRY;
INTEGER ARRAY RVEC,DEL,SUB,OLDEL[0:3];
LDESC:=AREG; RDESC:=BREG;
RESULT:=0; L:=LDESC.SPF; J:=LDESC.RF; RANK:=RDESC.RF;
IF M:=RDESC.SPF=0 OR L=0 OR LDESC.ARRAYTYPE=1 THEN BEGIN
ERR:=DOMAINERROR; GO TO QUIT; END;
IF NUMELEMENTS(LDESC)=1 THEN BEGIN N:=L+J;
IF SP[NOC] NEQ ORIGIN OR RANK GTR 1 THEN BEGIN
ERR:=DOMAINERROR; GO TO QUIT END;
%IF WE GET HERE, THE ANSWER IS ITSELF
RESULT:=RDESC; I:=NUMELEMENTS(RDESC);
RESULT..SPF:=N:=GETSPACE(SIZE:=RANK+1); RESULT.NAMED:=0;
SPCOPY(M,N,SIZE); GO TO QUIT END;
IF J GTR 1 THEN BEGIN ERR:=RANKERROR; GO TO QUIT END;
IF SP[LOC] NEQ RANK THEN BEGIN ERR:=LENGTHERROR; GO TO QUIT END;
% FIND MAX OF LDESC FOR NOW- DO THE REST LATER
%LDESC W/R/T ORIGIN 0 GETS STORED IN SUB[I]
SPTOP:=L+RANK; NEWRANK:=0; I:=0;
FOR N:=1 STEP 1 UNTIL SPTOP DO BEGIN
IF TEMP:=SP[NOC]-ORIGIN+1 GTR NEWRANK THEN NEWRANK:=TEMP;
SUB[I]:=TEMP-1; I:=I+1 END; 03277000P60
IF NEWRANK GTR TANK THEN BEGIN ERR:=DOMAINERROR;GO TO QUIT END;
% CALCULATE THE OLD DEL VECTOR, OLDEL
PLDEL[RANK-1]:=1; N:=M+RANK-1;
FOR I:=RANK-2 STEP -1 UNTIL 0 DO BEGIN
OLDEL[I]:=OLDEL[I+1]?SP[NOC]; N:=N-1 END;
MBASE:=M; SIZE:=1;
%FIX UP THE NEW RVAC AND DEL
FOR I:=NEWRANK-1 STEP -1 UNTIL 0 FO BEGIN
% FIND SMALLEST EL. OF RHO RDESC [J] S.T. A[J]=I
% AND SUM OF OLDEL[J] S.T. A[J]=1
MIN:=31; TEMP:=0;
FOR J:=RANK-1 STEP -1 UNTIL 0 DO
IF SUB[J]=1 THEN BEGIN
M:=MBASE+J;
IF SP[MOC] LSS MIN THEN MIN:=SP[MOC];
TEMP:=TEMP+OLDEAL[J] END;
RVEC[I]:=MIN; DEL[I]:=TEMP; SIZE:=SIZE?RVEC[I];
IF TEMP=0 THEN BEGIN %IT DOESN7T EXHAUSE IOTA NEWRANK
ERR:=DOMAINERROR; GO TO QUIT END;
END;
RESULT:=M:=GETSPACE(NEWRANK+SIZE);
RESULT.RF:=NEWRANK; RESULT.DID:=DDPUVW;
IF BOOLEAN(BREG.ARRAY) THEN BEGIN
RESULT.ARRAYTYPE:=1; N:=MBASE;
MBASE:=UNPACK(MBASE,RANK,N:=OLDEL[0]?SP[NOC]);
FORGETSPACE(MBASE,N+RANK) END;
FOR I:=1 STEP 1 UNTILNEWRANK DO BEGIN
SUB[I]:=0; OLDEL[I]:=RVEC[I]?DEL[I] END;
%INTIALIZE FOR STEPPING THRU NEW ARRAY
FOR I:=NEWRANK-1 STEP -1 UNTIL 0 DO BEGIN
SUB[I]:=0; OLDEL[I]:=RVEC[I]?DEL[I] ENND;
L:=MBASE+RANK;
%STEP THRU THE SUBSCRIPTS OF THE ANSWER TO PICK UP THE ELEMENTS
% IN ROW ORDER ACCORDING TO THE MAPPING GIVEN BY DEL
PTR:=TOP:=NEWRANK-1;
FOR I:=1 STEP 1 UNTIL SIZE DO BEGIN
SP[MOC] :=SP[LOC];
M:=M+1;
%GET NEXT SUBSCRIPT FOR NEW ARRAY AND SET NEXT L;
SUB[PTR]:=SUB[PTR]+1;
L:=L+DEL[TOP];
CARRY:=TRUE;
WHILE CARRY AND I NEQ SIZE DO
IF SUB[PTR] GEQ RVEC[PTR] THEN BEGIN
SUB[PTR]:=0;
L:=L-OLDEL[PTR]+DEL[PTR:=PTR-1];
SUB[PTR]:=SUB[PTR]+1
END ELSE CARRY:=FALSE;
PTR:=TUOP;
END;
IF BOOLEAN(RESULT.ARRAYTYPE) THEN PACK(RESULT.SPF,TOP+1,SIZE);
QUIT: END OF DYADICTRANS;
INTEGER PROCEDURE LOCATE(L,M); VALUE L,M; REAL L,M;
BEGIN
COMMENT L IS THE DIMENSION OF THE VECTOR(DESCRIPTOR),
M IS THE INDEX VECTOR;
INTEGER P,I,UB;
L:=I:=L.SPF; M:=I:=M.SPF;
UB:=SP[MOC]-1;
M:=M+1;
FOR I:=1 STEP 1 UNTIL UB DO
BEGIN
L:=L+1;
P:=(P+SP[MOC]-1)?SP[LOC];
M:=M+1;
END;
P:=P+SP[MOC];
LOCATE:=P+L;
END;
PROCEDURE DISPLAY(A,B); VALUE A,B; REAL A,B;
BEGIN
PROCEDURE PRINTMATRIX(L,ROW,COL);VALUE L,ROW,COL;
INTEGER L,ROW,COL;
BEGIN INTEGER I,J,CC,FOLD; DEFINE WIDE=GT2#;
WIDE:=LINESIZE;
FOR I:=1 STEP 1 UNTIL ROW DO
BEGIN CC:=0; %NO BLANKS AT BEGINNING OF LINE
FOLD:=0;
FOR J:=1 STEP 1 UNTIL COL DO
BEGIN NUMBERCON(SP[LOC],ACCUM);
IF FOLD:=FOL+ACOUNT+CC GTR WIDE AND ACOUNT+CC
LEQ WIDE THEN BEGIN TERPRINT;
FORMROW(0,2,ACCUM,2,ACOUNT); FOLD:=ACOUNT+2; END ELSE 03500140P61
FORMROW(0,CC,ACCUM,2,ACOUNT); L:=L+1;
CC:=2; %PUT 2 BLANKS AFTER FIRST ITEM.
END;
TERPRINT;
END;
END;
INTEGER L,M,N,BOTTOM,ALOC,BLOC;
INTEGER ROW,COL;
ALOC:=A.SPF; BLOC:=B.SPF-1;
L:=(M:=B.RF)+ BLIOC; COL:=SP[LOC];
L:=L-1;
ROW:=(IF M GTR 1 THEN SP[LOC] ELSE 1);
L:=BOTTOM:=M-2;
PRINTMATRIX(LOCATE(B,A),ROW,COL);
WHILE L GTR 0 DO
BEGIN
M:=ALOC+L; N:=BLOC+1;
IF SP[MOC]:=SP[MOC]+1 GTR SP[NOC] THEN
BEGIN SP[MOC]:=1; L:=L-1; END
ELSE BEGIN FORMWD(3,"1 ");
PRINTMATRIX(LOCATE(B,A),ROW,COL);
L:=BOTTOM;
END;
END;
FORMWD(3,"1 ");
END;
PROCEDURE MAKEFUNCTIONPRESENT(L); VALUE L ; REAL L; %LOC DESC
BEGIN
INTEGER I;
REAL M,N,SEQ,ORD,D;
BOOLEAN NUMERIC;
REAL STREAM PROCEDURE CON(A);VALUE A;
BEGIN SI:=LOC A; DI:=LOC CON; DS:=8OCT
END;
D:=SP[LOC]; %DESCRIPTOR FOR FUNCTION IS IN D
SEQ:=GETFIELD(D,FSQF-8,FFL); ORD:=GETFIELD(D,FPTF-8,FFL);
N:=GETSPACE(M:=SIZE(ORD)?2+6); %GET SPACE FOR TABLE
SP[NOC]:=M?2+5; %SIZE OF THE VECTOR WHICH FQOLLOWS
D:=D&N[CSPF]&1[CRF]&0[BACKUP]; S.PRESENCE:=1;
SP[LOC]:=D; %THIS SETS UP THE FUNCTION DESCRIPTOR.
N:=N+1; SP[NOC]:=SEQ;
COMMENT
SP[N] = SIZE OF THE VECTOR
SP[N+1] = SEQUENTIAL STORAGE UNIT FOR THE TEXT
SP[N+2] = SP LOC OF FIRST NUMERIC POINTER TO TEXT
SP[N+3] = REL LOC (TO N+5) OF THE FIRST ARG
SP[N+4] = REL LOC TO THE SECOND ARG
SP[N+5] = REL LOC OF RESULT . IF ANY ARE ZERO, THEN
THEY ARE NOT THERE.;
D:=M; M:=N:=N+4)+1; %D IS #ITEMS, M IS LOC 1ST., N=M-1
FOR I:=1 STEP 1 UNTIL D DO %GET LABELS FORM STORAGE
BEGIN L:=CONTENTS(ORD,I-1,GTA);
IF NOT NUMERIC THEN %RESULT, ARGS, OR LOCALS/LABELS
IF NUMERIC:=GTA[0]=0 THEN %FIRST NUMERIC POINTER
BEGIN L:=N-3; SP[LOC]:=N+I?2-1;
END;
SP[MOC]:=GTA[0]; M:=M+1;
IF NUMERIC THEN SP[MOC]:=GTA[1] ELSE
BEGIN
IF SEQ:=GTA[1] LSS 0 THEN %RESULT OR OARG
BEGIN DL:=N+SEQ+1; SP[LOC]:=I;
SEQ:=0;
END ELSE SEQ:=CDN(SEQ)/10000;
SP[MOC]:=SEQ
END
M:=M+1;
END;
COMMENT WE HAVE TO SET UP THE FUNCTION LABEL TABLE, LET
SOMEONE ELSE FIGURE OUT HOW TO EXECUTE IT;
END;
PROCEDURE PUSHINTOSYMTAB(FPTR);VALUE FPTR;REAL FPTR;
BEGIN COMMENT ...PUT THE LOCAL VARIABLES FORM THIS SUSPENDED
FUNCTION INTO THE SYMBOL TABLE TO BE TREATED AS GLOBAL VARIABLES
WHILE THE FUNCTION IS SUSPENDED. FPTR IS THE ENTRY FROM THE
STATE INDICATOR VECTOR FOR TEH FUNCTION.;
REAL T,U;
LABEL COPY;
INTEGER K,L,M,N;
M:=FPTR.LOCFIELD+1;%LOCATE FMKS TO FIND LOCAL VALUES IN STACK
N:=FPTR.SPF+2;T:=SP[NOC]-2;%FIND LOCAL NAMES
FOR N:=N+4 STEP 2 UNTIL T DO %ONCE FOR EACH LOCAL 03507100P62
BEGIN GT1:=SP[NOC] .[6:42];%PICK UP THE LOCAL NAME
L:=SYMBASE;K:=L+SP[LOC];% LOOK IN SYMBOL TABLE
FOR L:=L+1 STEP 2 UNTIL K DO % CHECK EACH NAME
IF GT1=SP[LOC].[6:42] THEN % WE FOUND A MATCH
BEGIN GT1:=M;K:=M:=GETSPACE(1);L:=L+1;
SP[MOC]:=SP[ALOC]; %PUSH CURRENT DESCRIPTOR DOWN
M:=GT1; GO TO COPY;
END;
COMMENT GET HERE IF NO MATCH...MUST MAKE A NEW ENTRY IN
SYMBOL TABLE;
IF K LSS MAXSYMBOL?2 THEN % THERE IS ROOM IN SYMBOL TABLE
BEGIN L:=SYMBASE;SP[LOC]:=SP[LOC]+2; L:=K+1;
SP[LOC]:=GT1&OPERAND[CTYPE]&1[CSUSVAR];L:=L+1;K:=0;
COPY: COMMENT L IS LOC IN SYMBOL TABLE FOR DESC. K WILL BE
CONTENTS OF BACKF. NOW SET UP THE NEW DESCRIPTOR AND
SAVE ITS LOCATION IN THE STACK. M IS THE STACK LOCATION
OF THE LOCAL;
SP[LOC]:=SP[MOC]&K[CLOCP]&1[CNAMED];
SP[MOC]:=L&DDNUVW[CDID];M:=M+1;
END ELSE % THERE IS NO ROOM IN THE SYMBEOL TABLE
BEGIN N:=T;ERR:=SPERROR;END;
END;% OF FOR LOOP STEPPING THROGH THE LOCALS
END; % OF PUSHINTOSYMTAB PROCEDURE
PROCEDURE FORGETPROGRAM(U);VALUE U; REAL U;
BEGIN REAL L,M;
COMMENT U IS A PROGRAMMKS...THE SP STORAGE FPOR THIS LINE
SHOULD BE RELEASED;
M:=U.SPF;SCRATCHAIN(SP[MROC].LOCFIELD);%CONSTANT CHAIN
L:=SP[MOC].SPF;FORGETSPACE(M,1);%FORGET PROGRAM DESC.
M:=FL+1;SCRATCHDATA(SP[MOC]);%FORGET BUFFER
FORGETSPACE(L,SP[LOC]+1);%FORGET THE POLISH
END;
EXPOVR:=EXPOVRL;
UINTOVR:=INTOVRL;
INDEX:=INDEXL;
FLAG:=FLAGL;
ZERO:=ZEROL;
CASE MODE OF
BEGIN ;%--------------------------------------------------------
%---------------- CASE 1....MODE=XEQUTE------------------------
CASE CURRENTMODE OF
BEGIN%-----------------------------------------------------
%------------- SUB-CASE 0....CURRENTMODE=CALCMODE----------
IF T:=ANALYZE(TRUE) NEQ 0 THEN % WE HAVE A PROGRAM DESC
BEGIN COMMENT SET-UP THE STACK;
IF STACKBASE=0 THEN BEGIN
STACKBASE:=L:=GETSPACE(STACKSIZE+1);
IF ERR NEQ 0 THEN BEGIN STACKBASE:=0;
ERRORMESS(ERR,0,0); GO TO PROCESSEXIT;END;
SP[LOC]:=2;
L:=L+1;
M:=GETSPACE(STATEVECTORSIZE+1);
SP[LOC]:=M&1[CRF]&DDPNVW[CDID];
SP[MOC]:=STATEVECTORSIZE;
M:=M+1; SP[MOC]:=0; % THE STATE VECTOR IS INITIALIZED NOW
FUNCLOC:=M;
N:=0;
L:=L+1; COMMENT READY FOR A PROG MKS;
END ELSE % THERE IS ALREADY A STACK...USE IT
BEGIN L:=STACKBASE;
ST:=SP[LOC]+L;
WHILE M:=AREG.DID NEQ IMKS AND M NEQ PROGMKS AND
ERR=0 DO POP;%STRIP BACK TO LASTMARKSTACK
IF M=IMKS THEN BEGIN N:=ST-STACKBASE;PUSH;
END ELSE N:=AREG.BACKF;
SP[LOC]:=ST-STACKBASE;L:=ST;
END;
CURLINE:=0;
M:=GETSPACE(1); SP[MOC]:=T; %STORE PROG DESCRIPTOR
SP[LOC]:=M&PROGMKS[CDID]&N[BACKPT]&1[CI];
COMMENT JUST BUILT A PROGRAM MARKSTACK;
GO TO EXECUTION;
END;
%------------SUB-CASE 1....CURRENTMODE=XEQMODE---------------
COMMENT RECOVERY FORM A TIME-OUT;
GO TO EXECUTION;
%----------- SUB-CASE 2....CURRENTMODE=FUNCMODE--------------
COMMENT SYNTAX CHECK ONLY;
IF ANALYZE(TRUE)=0 THEN;
%------- END OF SUB CASES-----------------------------------
END;
%------------------ CASE 2.....MODE=ALLOC------------------------ 03702300P63
COMMENT NOTHING TO DO;
;
%----------------- CASE 3.... MODE=WRITEBACK-------------------
COMMENT HAVE TO WRITE BACK ALL THE NAMED VARIABLES;
IF SYMBASE NEW 0 THEN
WRITEBACK;
%----------------- CASE 4.... MODE=DEALLOC---------------------
;
%----------------- CASE 5 .... MODE=INTERROGATE----------------
COMMENT PRINT OUT THE PROGRAM STATUS VECTOR HERE;
IF L:=STACKBASE+1 NEW 1 THEN
BEGIN COMMENT GT1=1 FOR SIV...=0 FOR SI;
U:=GT1;
L:=SP[LOC].SPF+1;M:=SP[LOC].SPF+L;
WHILE M GTR L DO
BEGIN N:=SP[MOC].LOCFIELD;N:=SP[NOC].SPF-1;
% N IS LOCATION OF THE FUNCTION NAME
ACCUM[0]:=SP[NOC];
FORMRIOW(2,6,ACCUM,1,7);
IF BOOLEAN(SP[MOC].SUSPENDED) THEN FORMWD(0,"3 S ")
ELSE FORMWD(0,"3 ");
IF BOOLEAN(U) THEN % PRINT LOCAL VARIABLE NAMES
BEGIN
N:=SP[MOC].SPF+2;T:=SP[NOC]-2;
FOR N:=N+4 STEP 2 UNTIL T DO
BEGIN ACUM[0]:=SP[NOC];
FORMROW(0,1,ACCUM,1,7);
END;
END;
TERPRINT; M:=M-1;
END;
END;
END;% OF THE CASE STATMENT
%--------------END OF CASES---------------------------------------
IF FALSE THEN EXECUTION:
BEGIN COMMENT EXECUTION LOOP;
INTEGER LO+OP;
INTEGER INPUTIMS;
LABEL BREAKKEY;
LABEL SKIPPOP,XEQPS;
BOOLEAN XIT, JUMP;
REAL POLWORD;
DEFINE RESULT=RESULTD#;
LABEL EXECEXIT, EVALQ, EVALQQ;
%%%
COMMENT THERE IS A PROGRAM DESCRIPTOR AT THE TOP OF THE STACK;
ERR:=0;
L:=STACKBASE; ST:=L+SP[LOC];
L:=L+1;FUNCLOC:=SP[LOC]SPF+1;
T:=AREG;
IF CURRENTMODE=XEQMODE THEN %AREG IS INTERRUPT MARK STACK
BEGIN LASKMKS:=STACKBASE+T.BACKF;
OLDDATA:=T.SPF; INPUTIMS:=T.QUADIN; POP;
COMMENT MAY BE CURRENTLY EXECUTING A FUNCTION;
L:=STACKBASE+1; L:=SP[LOC].SPF+1;
IF (M:=SP[LOC].SPF) NEQ 0 THEN
BEGIN ML=M+L; L:=SP[MOC].LOCFIELD;
CURLINE:=SP[LOC].CIF;
END;
END
EDLSE LASTMKS:=ST;%AREG IS PROGRAM MARK STACK
CURRENTMODE:=XEQMODE;
L:=LASTMKS; T:=SP[LOC]; % T IS PROGRAM MARK STACK
CINDEX:=T.CIF; % CONTROL INDEX IN POLISH
IF L:=T.SPF =0 THEN %PHONEY PROG DESC FROM FUNCTION CALL
N:=POLTOP:=POLLOC:=0 ELSE
BEGIN
N:=POLLOC:=SP[LOC].SPF;
POLTOP:=SP[NOC]
END;
IF ERR = 0 THEN % POP WORKED
IF INPUTIMS=2 THEN BEGIN JUMP:=TRUE; GO TO EVALQ END ELSE
IF INPUTIMS = 1 THEN BEGIN JUMP:=TRUE; GO TO EVALQQ; END ELSE
DO BEGIN COMMENT EXECUTE UNTIL DONE OR TIME-OUT;
BEGIN COMMENT GET NEXT POLISH TO EXECUTE;
M:=(CINDEX:=CINDEX+1)+POLLOC;
POLWORD:=T:=SP[MOC];
CASE T.TYPEFIELD OF 03752700P64
BEGIN %-------TF=0 (REPLACEMENT)--------------
BEGIN %MAY BE A LOCAL OR A GLOBAL VARIABLE
DEFINE STARTSEGMENT=#; %/////////////////////
PUSH; IF ERR NEQ 0 THEN GO TO SKIPPOP;
N:=T.LOCFIELD;
IF BOOLEAN(T.OPTYPE) THEN %A LOCAL VARIABLE
BEGIN M:=FUNCLOC;%FIND LAST MKS
M:=SP[MOC].SPF+M;
N:=SP[MOC].LOCFIELD+N; END;
U:=SP[NOC]; U.LOCFIELD:=N; AREG:=U;
IF U.DATADES=0 THEN ERR:=NONCEERROR;
COMMENT PROBABLY MIXUP WITH FUNCTION NAMES
AND NAMES OF LOCAL SUSPENDED VARIABLES;
END;
%-------------FUNCTION CALL-----------------
%&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
BEGIN COMMENT SET UP STACK FOR A FUNCTION CALLL;
EAL U,V,NARGS,D;
INTEGER I,FLOC;
LABEL TERMINATE;
COMMENT
MONITOR PRINT(D,L,M,N,FLOC,SP,LASTMKS);%::::::::::::::::::::
FLOC:=N:=T.LOCFIELD;
IF BOOLEAN(SP[NOC].DATADESC) THEN BEGIN ERR:=NONCEERROR;
FO TO TERMINATE;END;%SUSPENDED VAR CONFUSED WITH FUNCTION
IF NOT BOOLEAN(SP[NOC].PRESENCE) THEN MAKEFUNCTIONPRESENT(N);
D:=SP[NOC]; L:=LASTMKS; %D IS TEH DESC, L IS THE PROG MKS
SP[LUOC].CIF:=CINDEX; %SAVE CURRENT POLISH LOCATION
L:=STACKBASE+1; L:=SP[LOC].SPF+1;
M:=SP[LOC].SPF;
IF N:=M+L NEQ L THEN %THERE IS A NESTED CALL
IF NOT BOOLEAN(SP[NOC].SUSPENDED) THEN
BEGIN N:=SP[NOC].LOCFIELD;SP[NOC].CIF:=CURLINE;END;
SETFIELD(GTA,0,8,0); SETFIELD(GTA,8,8,0); %INITIALIZE GTA
NARGS:=D.NUMBERARGS;
FOR I:=1 STEP 1 UNTIL NARGS DO
IF BOOLEAN((T:=AREG).DATADESC) THEN
BEGIN
IF BOOLEAN(T.NAMED) THEN %MAKE A COPY
COMMENT YOU COULD MAKE A CALL BY NAME HERE;
BEGIN U:=GETSPACE(V:=(NUMELEMENTS(T)+1,RF));
SPCOPY(T,SPF,U,V); T.NAMED:=0; T.SPF:=U;
T.BACKP:=0;
END ELSE %NO NEED TO MAKE A COPY
AREG.PRESENCE:=0;
POP; GTA[I-1]:=T; %SAVE THE DESCRIPTOR FOR LATER USE
END ELSE ERR:=SYSTEMERROR;
IF (N:=M+1) GEQ STATEVECTORSIZE THEN ERR:=DEPTHERROR;
IF ERR NEQ 0 THEN GO TO TERMINATE;
SP[LOC].SPF:=N;
PUSH;AREG:=OLDDATA&(LASTMKS-STACKBASE)[BACKPT]&IMKS[CDID];
OLDDATA:=0; %REINITIALIZE OLDDATA CHAIN FOR THIS FUNCTION
%NOW SET UP THE FUNCTION MARK STACK.
M:=N+L;PUSH;SP[MOC]:=D.SPF&ST[CLOCF];
M:=D.SPF; M:=M+2; % M IS LOC OF LOC OF FIRST LINE
AREG:=0&FLOC[CSPF]&((LASTMKS:=ST)-STACKBASE-1)[BACKPT]&
(U:=SP[MOC]-D.SPF)[CCIF]&FMKS[CDID]; % FUNCTION MKS
CURLINE:=U;
U:=(U-6)/2; % U IS THE NUMBER OF LOCALS, LABELS, AND ARGS
M:=M+5; % M IS ON TEH FIRST DESC IOF THE FIRST LAB, LOC,...
FOR I:=1 STEP 1 UNTIL U DO % GET DESCRIPTORS INTO THE STACK
BEGIN IF SP[MOC] NNEQ 0 THEN %MAKE UP THE DESC
BEGIN L:=GETSPACE(1); SP[LOC]:=SP[MOC];
T:=L&DDPUSW[CDID]&0[CCIF]
END ELSE
T:=NULLV;
PUSH; M:=M+2;
AREG:=T; %A SINGLE LOCAL
END;
%COPY OVER THE ARGUMENTS
FOR I:=1 STEP 1 UNTIL NARGS DO %COPY OVER
BEGIN M:=D.SPF; %M IS THE LOACTION OF THE LABEL TABLE.
M:=M+2+I; %M IS LOCATION OF REL LOCATION OF VARIABLE
M:=SP[MOC];
N:=LASTMKS+MM;
SP[NOC]:=GTA[I-1];
END;
%PUT IN A PHONEY PROG DESC TO START THINGS OFF
PUSH; IF ERR NEQ 0 THEN GO TO TERMINATE; 03753400P65
ARFG:=0&4094[CCIF]&(LASKMKS-STACKBASE)[BACKU[];
LASTMKS:=ST; POLTOP:=POLLOC:=0;
TERMINATE:
END;
%&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
%-------END OF LOAD FUNCTION FOR CALL-----
%-------------TF=2 (CONSTANT)---------------------
BEGIN PUSH; IF ERR=0 THEN BEGIN
N:=POLWORD.LOCFIELD;AREG:=SP[NOC];END;
END;
%-------------TF=3 (OPERATOR)-----------------
COMMENT SEQUENCE NUMBERS CORRESPOND TO OPERATOR
ASSIGNMENT NUMBER;
BEGIN IF T.OPTYPE=MONADIC THEN
BEGIN PUSH;IF ERR=0 THEN AREG:=0; END;
CASE T.LOCFIELD OF
BEGIN %--------------- OPERATE ON STACK ---------------------
COMMENT EACH EXECUTION PROCEDURE SETS RESULT TO THE
DESCRIPTOR OF THE RESULT OF THE OPERATION.
AREG AND BREG ARE THE LEFT AND RIGHT-HAND OPERANDS AND
ARE ACTUALLY THE TOP TWO DESCRIPTORS ON THE STACK.
IF AREG IS ZERO, THE OPERATOR IS TAKEN TO BE MONADIC.;
;
;
;
;
%---------------------REPLACEMENT OPERATOR---------------
BEGIN DEFINE STARTSEGMENT=#; %///////////////////////////////
IF NOT BOOLEAN(L:=AREG.NAMED) THEN % SHOULD BE LOCAL VARIABLE
AREG.NAMED:=1; % DONT LET IT BE FORGOTTEN.
IF BOOLAN(T:=AREG).PRESENCE) AND T.SPF NEQ 0 THEN
OLDDATA:=CHAIN(T,OLDATA);
M:=T.LOCFIELD;
IF(RESUT:=BREG).SPF = 0 THEN U:=T:=0 ELSE
U:=GETSPACE(T:=NUMELEMENTS(RESULT)+RESULT.RF);
SPCOPY(RESULT,SPF,U,T);
RESULT.SPF:=U; RESULT.NAMED:=L; %L IS 0 FOR LOCJLS
GT1:=IF BOOLEAN(U:=SP[MOC]).PRESENCE) THEN U.BACKP ELSE 0;
SP[MOC]:=RESULT>1[CLOCF];
IF BOOLEAN(L) AND GT1=0 THEN %CHECK FOR GLOBAL
BEGIN M:=M-1;IF(SP[MOC].SUSPENDVAR=0)THEN SP[MOC].CHANGE:=1;
END;
RESULT.NAMED:=1; %KEEP "PUSH" FROM TOSSING THE DATA
END
%-------TRANSFER OPERATOR---------------------------------
BEGIN DEFINE STARTSEGMENT=#; %////////////////////////////////
SCRATCHAIN(OLDDATA);ODDATA:=0;
IF BOOLEAN(D.DPTYPE) THEN ST:=ST-1; %GET RID OF PH7ONEY TOP
L:=FUNCLOC;
IF SP[LOC] NEQ 0 THEN STEPLINE(TRUE) ELSE
ERR:=SYNTAXERROR;
GO TO SKIPPOP;
END;
BEGIN %--------------COMPRESSION------------------------------------
DEFINE STARTSEGMENT=#; %/////////////////////////////////////
L:=ST-2; IF T.OPTYPE=MONADIC THEN COMPRESS(BREG,SP[LOC],AREG)
ELSE COMPRESS(AREG,S[]LOC],BREG); COMMENT A/B HAS BEEN
STACKAED AS B,A,NULL...A/[I] B HAS BEEN STACKED AS B,I,A;
END;
ARITH(3); %OPERATION IS DIVIDE
;
;
%-------------QUAD INPUT--------------------------------
EVALQ: BEGIN LABEL EVALQUAD;
IF JUMP THEN BEGIN JUMP:=FALSE; GO TO EVALQQUAD END;
CURRENTMODE:=INPUTMODE;
FORMWD(3,"3[]: "); INDENT(0);
IMS(2); % SETUP MARKSTACK FOR QUAD EXIT
IF ERR NEQ 0 THEN GOTO SKIPPOP;
GO TO EXECEXIT; % EXIT TO MONITOR TILL INPUT IS COMPLETE
EVALQUAD: %LO7OK AT BUFFER TO SEE WHAT CAME IN
BEGIN
IF NOT SCAN THEN BEGIN CINDEX:=CINDEX-1;GO TO SKIPPOP;END;
IF NOT SETUPLINE THEN CINDEX:=CINDEX-1;%MAKE THEM REDO IT
GO TO SKIPPOP;
END;
END;
BEGIN % -----EVALUATE SUBSCRIPTS---------------
DEFINE STARTSEGMENT=#; %///////////////////////////////////// 03811002P66
T:=AREG; L:=BREG.SPPF;
IF BOOLEAN(T.SCALAR) THEN BEGIN ERR:=DOMAINERROR; GO TO SKIPPOP;END;
U:=SP[LOC]; % GET # OF SUBSCRIPTS
IF U GTR 32 THEN ERR:=INDEXERROR ELSE
BEGIN
IF U GTR 0 THEN BEGIN
IF T.PRESENCE NQ 1 THEN % GET ARRAY INTO SP
BEGIN N:=T.LOCFIELD;
IF (T:=SP[NOC]).PRESENCE NEQ 1 THEN
BEGIN T:=GETARRAY(T); SP[NOC]:=T END;
T.LOCFIELD:= N;
END;
IF ERR=0 THEN % NOW EVAVLUATE
RESULT:=SUBSCRIPTS(L:=(IF T.LOCFIELD=0 THEN OUTOF
ELSE INTO),T,U);
IF L=INTO THEN BEGIN
CINDEX:=CINDEX+1;END; % SKIP OVER REPLACE OP
END ELSE % NO SUBSCRIPTS
BEGIN BREG:=T; ST:=ST-1; GO TO SKIPPOP;
END; % DON{T LET TEH DESC. IN T BE POPPED.
U:=U+2; % # OF THINGS TO POP
FOR N:=1 STEP 1 UNTIKL U DO POP;
IF L=OUTOF THEN PUSH; AREG:=RESULT;
GO TO SKIPPOP;
END;
END;
;
;
%-------------QQUAD INPUT-------------------------------
EVALQQ: BEGIN LABEL EVALQQUAD;
IF JUMP THEN BEGIN JUMP:=FALSE; GO TO EVALQQUAD END;
CURRENTMODE:=INPUTMODE;
IMS(1); %SET UP MARKSTACKS FOR QQUAD EXIT
IF ERR NEQ 0 THEN GO TO SKIPPOP;
GO TO EXECEXIT;
EVALQQUAD: % BUFFER CONTAINS THE INPUT STRING
IF (L:=LENGTH(BUFFER,TRUE))NEQ 0 THEN BEGIN %L IS # CHAR INPUT
N:=ENTIER((3L+7) DIV 8); % FIND NUMBER OF WORDS
M:=GETSPACE(N+1); % GET SPACE FOR EACH VECTOR IN SP
TRANSFERSP(INTO,SP,M+1,BUFFER,0,N);
SP[MOC]:=L; % STORE LENGTH OF VECTOR
RESULT:=M&1[CRF]&DDPUVC[CDID]; % SET UP DESCRIPTOR
END ELSE RESULT:=NULLV;% NOTHING WAS INPUT
PUSH; IF ERR=0 THEN AREG:=RESULT;
GO TO SKIPPOP;
END;
RESULTD := SEMICOL; %CONVERSIEON CONCATENATION
COMMAP; %CATENATE
BEGIN%----------INNER PRODUCR (PERIOD)---------------------
M:=(CINDEX:=CINDEX+2) + POLLOC; T:=SP[MOC];M:=M-1;U:=SP[MOC];
PERIOD(AREG,BREG,U.LOCFIELD,T.LOCFIELD);
END;
ARITH(4); %*
;
;
ARITH(17); %AND
ARITH(18); %OR
ARITH(9); %NOT
ARITH(11); %LESS:THAN
ARITH(16); %LEQ
ARITH(13); %=
ARITH(14); %GREATER-THAN
ARITH(15); %NEQ
ARITH(8); %MAX/CEIL
ARITH(7); %MIN/FLOOR
ARITH(6); %RESD/AAAABS
IF T.OPTYPE=MONADIC THEN GO TO XEQEPS ELSE MEMBER; %MEMBERSHIP
RHOP; %RHO
IOTAP; %IOTA
;
REDUCESORTSCAN(0,BREG,AREG,4); %REVERSAL;
BEGIN %-----------EXPANSION-------------------------
DEFINE STARTSEGMENT=#; %///////////////////////////////////
L:=ST-2; IF T.OPTYPE=MONADIC THEN EXPAND(BREG,SP[LOC],AREG)
ELSE EXPAND(REG,SP[LOC],BREG); COMMENTS A EXPN B HAS BEEN
STACKED AS B,A,NULL WHILE A EXPN [I] B IS STACKED AS B,I,A;
END;
RESULTD:=BASEVALUE; %BASE VALUE
ARITH(10); %COMB/FACT 03840000P67
;
IF T.EOPTYPE=MONADIC THEN ARITH(5) ELSE
DYADICRNDM; %RNDM
IF T.OPTYPE=MONADIC THEN TRANSPOSE ELSE DYADICTRANS;%GUESS WHAT
RESULTID := REPRESENT; %REPRESENTATION
ARITH(45); %CIRCLE--TRIGONOMETRIC FUNCTIONS
;
;
ARITH(0); %ADD
ARITH(2); %SUBTRACT
ARITH(1); %MULTIPLY
%-------------------DISPLAY---------------------------------------
BEFIN DEFINE STRATSEGMENT=#; %/////////////////////////////////
IF BREG.SPF=0 THEN FORMROW(3,0,ACCUM,2,0) ELSE %FOR A NULL
IF BOOLEAN((RESULT:=BREG).DATADESC)THEN %THIS IS A DATA DESC
IF BOOLEAN(RESULT,PRESENCE) AND M:=RESULT.SPF NEQ 0 THEN
IF BOOLEAN(RESULT.SCALAR) THEN
BEGIN NUMBERCON(SP[MOC],ACCUM);
FORMROW(3,0,ACCUM,2,ACOUNT)
END
ELSE %A VECTOR
IF L:=RESULT.RF NEQ 0 THEN % SOMETHING TO PRINT
IF BOOLEAN(RESULT.CHRMEODE) THEN DISPLAYCHARV(RESULT)
ELSE
BEGIN RESULT:=M:=GETSPACE(L+1);
SP[MOC]:=L; RESULT.DF:=1; RESULT.DIS:=DDPUVW;
AREG:=RESULT;
FOR T:=1 STEP 1 UNTIL 1L DO
BEGIN M:=M+1; SP[MEOC]:=1
END;
DISPLAY(AREG,BREG);
RESULT:=BREG;
END ELSE TERPRQINT
ENS TERPRINT
ELSE ; %PROBABLY AN FUNCTION....DONT DO ANYTHING
IF BREAKFLAG THEN %USER HIT BREAK DURING OUTPUT
GO TO BREAKKEY;
POP; GO TO SKIPPOP;
END;
BEGIN % ---------------REDUCTION------------------------------------
M:=(CINDEX:= CINDEX+1) + POLLOC; % FIND OPERATION IN POLISH
IF (T:=SP[MOC]).TYPEFIELD NEQ 3 THEN ERR:=SYSTEMERROR
ELSE REDUCESORTSCAN(T.LOCFIELD,BREG,AREG,1);
END;
BEGIN %--------ROTATION----------------------------
DEFINE STARTSEGMENT=#; %////////////////////////////////////
L:=ST-2; IF T.OPTYPE=MONADIC THEN
REDUCESORTSCAN(BREG,SP[LOC],AREG,5) ELSE
REDUCESORTSCAN(AREG,SP[LOC],BREG,5); COMMENT A ROT B IS
STACKED AS R,A,NULL WHILE A ROT [I] B IS STACKED AS B,I,A;
END;
ARITH(21); %LOG
REDUCESORTSCAN(0,BREG,AREG,2); % SORTUP
REDUCESORTSCAN(-1,BREG,AREG,2); %SORTDN
BEGIN%--------------SCAN-------LIKE REDUCTION----------------
DEFINE STARTSEGMENT=#; %//////////////////////////////////////
M:=(CINDEX:=CINDEX+1) + POLLOC; %FIND OPERATOR IN POLISH
IF (T:=SP[MOC]).TYPEFIELD NEW 3 THEN ERR:=SYSTEMERROR
ELSE REDUCESORTSCAN(T.LOCFIELD,BREG,AREG,3);
END;
ARITH(19); %NAND
RITH(20) %NOR
IF (T:=BREG).RF NEQ 0 THEN RESULT:=SUBSCRIPTS(3,T,T,RF)
ELSE ERR:=RANKERROR; % OPERATION IS TAKE
IF (T:=BREG).RF NEQ 0 THEN RESULT:=SUBSCRIPTS(3,T,T,RF)
ELSE ERR:=RANKERROR; % OPERATION IS DROP
%------------------------XEQ---------------------------------
XEQEPS: BEGIN DEFINE STARTSEGMENT=#; %////////////////
IF AREG NEQ 0 THEN ERR:=SYNTAXERROR %MUST BE MONADIC ONLY
EFLSE IF (T:=BREG).RF NEQ 1 OR %MUST BE A VECTOR
NOT BOOLEAN(T.CHRMODE) THEN ERR:=DOMAINERROR %MUST BE CHAR STRING
ELSE IF U:=NUMELEMENTS(T) GTR MAXBUFFSIZE THEN ERR:=LENGTHERROR
ELSE BEGIN
M:=GT1; % # OF CHARACTERS SET BY NUMELEMENTS
INITBUFF(BUFFER.MAXBUFFSIZE);RESCANLINE;
TRANSFERSP(QUTOF,SP,T,SPF+1,BUFFER,0,U);
IF(U:=U|8-M) GTR 0 THEN SETFIELD(BUFFER,M,U," ");
IF T.SPF=0 OR NOT SCAN THEN RESULT:=0&1[CRF]&DDPUVW[CDID]% NULL
ELSE BEGIN POP;IF SETUPLINE THEN; GO TO SKIPPOP;END
END; END;
END; %--------------EN OF OPERATION ON STACK---------------------
POP;POP;PUSH;IF ERR=0 THEN AREG:=RESULT; 03869970P68
SKIPPOP: END OF TYPEFIELD EQUALS OPERATOR;
%-------TF=4 (LOCAL VARIABLE)------------
BEGIN COMMENT MOVE DESCRIPTOR UP TO TOP;
DEFINE STARTSEGMENT=#; %/////////////////
N:=T.LOCFIELD;M:=FUNCLOC;M:=SP[MOC]+M;
N:=SP[MOC].LOCFIELD+N;
T:=SP[NOC]; T.NAMED:=1; %KEEP FROM THROWING AWAY
PUSH; AREG:=T;
END;
%-------TF=5 (OPERAND)-----------------------
BEGIN PUSH; IF ERR=0 THEN BEGIN
N:=POLWORD.LOCFIELD; U:=SP[NOC];
IF U.DATADESC=0 THEN ERR:=NONCEERROR ELSE
IF U.PRESENCE NEQ 1 THEN BEGIN
U:=GETARRAY(U); SP[NOC]:=U END;
U.LOCFIELD:=0;
AREG:=U; END;
END;
END; % OF CASE STATEMENT TESTING TYPEFILED
END % OF TEST FOR CINDEX LEQ POLTOP
ELSE % WE ARE AT THE END OF THE POLISH
BEGIN COMMENT LASKMKS CONTAINS THE LOCATION
OF THE LAST WARK STACK. GET MARK STACK AND CONTINUE;
SCRATCHCHAIN(OLDDDATA); OLDDATE:=0;
L:=LASTMKS;M:=(U:=SP[LOC]).BACKF+STACKBASE;T:=SP[MOC];
IF T.DIF=IMKS AND T.QUADIN=3 THEN %SINGLE LINE DONE
IF (RESULT:=AREG)=T THEN ERR:=SYNTAXERROR%NIO RESULT
ELSE BEGIN RESULT.NAMED:=0;%MAKE NEW COPY
IF BOOLEAN(RESULT.SCALAR) THEN
BEGIN M:=GETSPACE(2);L:=RESULT.SPF;
RESULT.SPF:=M+1;SP[MOC]:=RESULT;
M:=M+1;SP[MOC]:=SP[LOC];
END ELSE % MAKE COPY OF A VECTOR
BEGIN M:=GETSPACE(1+(N:=RESULT.RF+NUMELEMENTS(
RESULT)));
L:=RESULT.SPF;RESULT.SPF:=M+1;
SP[MOC]:=RESULT; SPCOPY(L,M+1,N); END;
FORGETPROGRAM(U);
DO POP UNTIL ST LSS 2LASTMKS;%CUT BACK STACK TO IMS
OLDDATA:=T.SPF;L:=LASTMKS:=T.BACKF+STACKBASE;
AREG:=RESULT; % STORE EXECUTION RESULT OVER IMS
CINDEX:=SP[LOC].CIF; M:= SP[LOC].SPF;
POLLOC:=M:=SP[MOC].SPF; POLTOP:=SP[MOC];
END ELSE
BEGIN L:=FUNCLOC;M:=SP[LOC.SPF+L;
IF M NEQ L AND NOT BOOLEAN(SP[MOC].SUSPENDED)THEN
BEGIN
IF O=(LOOP:=LOOP+1) MOD 5) THEN
WRITE(TWXOUT,1,JIGG1LE[*])[BREAKKEY:BREAKKEY];
%THAT WAS TO CHECK FOR A BREAK TO INTERRUT A PROG
STEPLINE(FALSE);
END;
ELSE BEGIN XIT:=TRUE;CURRENTMODE:=CALCMODE;
WHILE POPROGRAM(OLDDATA,LASTMKS) DO;
END;
END;
END; %COMPLETION OF ONE POLISH EVALUATION (1 CELL)
IF ERR NEQ 0 THEN % PUT OUT ERROR MESSAGE
BEGIN
DEFINE STARTSEGMENT=#; %/////////////////////////////
COMMENT
MONITOR PRINT(ST,L,M,SP,GTA,T);%::::::::::::::::::::::
XIT:=TRUE;CURRENTMODE:=ERRORMODE;
L:=POLLOC+1;
TRANSFERSP(OUTOF,SP,(L:=SP[LOC],SPF)+1,BUFFER,
0,MIN(MAXBUFFSIZE,ENTIER((SP[LOC]+7)DIV 8)));
L:=FUNCLWOC;M:=SP[LOC].SPF+1;
GT1:=1;N:=SP[MOC].LOCFIELD;%LOCATION OF FMKS
WHILE LASTMKS GTR N AND BOOLEAN (GT1) DO GT1:=IF
POPPROGRAM(OLDDATA.LASTMKS)THEN 1 ELSE 0;
IF M NEQ L AND NOT BOOLEAN(SP[MOC]).SUSPENDED)THEN%GET LINE#
BEGIN SP[LOC].RF:=SP[LOC].RF+1;%UP SUSPENDED COUNT
L:=SP[NOC].SPF-1;%LOCATION WOF FUNCTION NAME
SETFIELD(GTA,0,1,0);
GTA(0):=SP(LOC);
FORMROW(3,0,GTA,1,7);
L:=SP[MOC].SPF; %BASE OF LABEL TABLE 03918475P69
L:=L+CURLINE;
T:=SP[LOC];
%ALSO PUT THE FUNCTION INTO SUSPENSION
IMS(4);SP[MOC].SUSPENDED:=1;SUSPENSION:=1;
PUSHINTOSYMTAB(SP[MOC]);
END ELSE T:=0;
ERRORMESS(ERR,POLWORD,SPF,T);
END;
END UNTIL XIT;
BREAKKEY: BEGIN BREAKFLAG:=FALSE;
XIT:=TRUE;CURRENTMODE:=CASLCMODE;
L:=FUNCJLOC;M:=SP[LOC].SPF+L;
IF M NEW L AND NOT BOOLEAN(SP[MOC].SUSPENDED) THEN
BEGIN SP[MOC].SUSPENDED:=1;SUSPENSION:=1;
PUSHINTOSYMTAB(SP[MOC]);SP[KLOC].RG:=SP[LOC].RF+1;
M:=SP[MOC].LOCFIELD;%LOCATION OF FMKS IN STACK
WHILE LASTMKS GTR M DO IF POPPROGRAM(OLDDATA,LASTMKS)
THEN; LASTMKS:=M;IMS(4);
END
IF FALSE THEN
END;
EXECEXIT:
IF STACKBASE NEQ 0 THEN BEGIN
L:=STACKBASE; SP[LOC]:=ST-L; %UPDATE SIZE OF STACK
END;
END OF EXECUTION LOOP;
PROCESSEXIT:
IF BOOLEAN(POLBUG) THEN % DUMP SP
IF MODE=EQUTE OR MODE=3 OR MODE=6 THEN GO TO DEBUGSP;
IF FALSE THEN
BEGIN CASE O OF BEGIN
EXPOVRL: SPOUT(3951200);
INTOVRL: SPOUT(3591300);
INDEXL: SPOUT(3951500);
ZEROL: SPOUT(3951600);
END;
REALLYERROR:=1;
DEBUGSP:
WRITE(PRINT,MIN(15,PSRSIZE),PSR);
BEGIN
STREAM PROCEDURE FORM(A,B,N); VALUE N;
BEGIN
DI:=B; 15(DS:=BLIT(" ");
SI:=LOC N; DI:=B; DS:=8DEC; DI:=DI+3;
SI:=A; 10(DS:=8CHR; DI:=DI+1);
END;
M:=MIN(NROWS+1|SPRSIZE-1,MAXMEMACCESSES);
FOR N:=0 STEP 10 UNTIL M DO
BEGIN TRANSFERSP(OUTOF,SP,N,ACCUM,0,MIN(M*N,10));
FORM(ACCUM,BUFFER,N);
WRITE(PRINT,15,BUFFER[*]);
END;
END;
IF POLBUG=0 OR BOOLEAN(REALLYERROR) THEN
BEGIN
ERRORMESS(IF ERR NEQ SPERROR THEN SYSTEMERROR ELSE ERR,0,0);
SUSPENSION:=0;
CURRENTMODE:=CALCMODE;
REALLYERROR:=ERR:=0;
END;
END;
END OF PROCESS PROCEDURE;
PROCEDURE ERRORMESS(N,ADDR,R); VALUE N,ADDR,R; REAL R;
INTEGER N; REAL ADDR;
BEGIN
INTEGER STREAM PROCEDURE FORM(A,B); VALUE A;
BEGIN LOCAL T,U;
LABEL L,M;
SI:=A;
L: IF SC=" " THEN
BEGIN SI:=SI+1; GO TO L;
END;
DI:=LOC I; DS:=2RESET; DS:=2SET;
DI:=8; MESSIZEU:=DI; DI:=LOC T; IF SC=DC THEN JUMP OUT TO M;
SI:=SI-1; DI:=U; DS:=CHR; TALLY:=TALLY+1); M:
FORM:=TALLY;
END;
ARRAY ERMES[0:13],B[0:MESSIZE/8];
FILL ERMES[*] WITH
"1 ", 05001510P70
"5DEPTH ",
"6DOMAIN ",
"7EDITING",
"5INDEX ",
"5LABEL ",
"6LENGTH ",
"5NONCE ",
"4RANK ",
"6SYNTAX ",
"6SYSTEM ",
"5VALUE ",
"7SP FULL",
"7FLYKITE";
IF R NEQ 0 THEN
BEGIN INDENT(R);CHRCOUNT:=CHRCOUNT-1;
END;
FORMROW((IF R=0 THEN 2 ELSE 0),0,ERMES,N|8+1,
ERMES[N].[1:5]);
FORMWORD(0,"6 ERROR");
IF ADDR.[33:15] GEQ 512 THEN
BEGIN
FORMD(D,"4 AT ");
FORMROW(1,1,B,0,FORM(ADDR,B))
END;
FORMWD(3,"1 ");
END;
PROCEDURE LOADWORKSPACE(JOBNUM,NAME,IDENT); VALUE JOBNUM,NAME;
REAL JOBNUM,NAME; ARRAY IDENT[0]; FORWARD;
PROCEDURE LOGINAPLUSER;
BEGIN
COMMENT LOG:IN THE CURRENT USER;
COMMENT INPUT LINE IS THE BUFFER;
LABEL EXEC, GUESS;
DEFINE T=GT1#, J=GT2#,I=GT3#;
PROCEDURE INITIALIZEPSR;
BEGIN FOR I:=0 STEP 1 UNTIL PSRSIZE-1 DO
PSRM[I] := 0;
SEED:=STREAMBASE; ORIGIN:=1;
FUZZ:-1@-11;
LINESIZE:=72; DIGITS:=9;
END;
LADDRESS := ADDRESS := ABSOLUTEADDRESS;
WORKSPACE:=WORKSPACEUNIT;
ITEMCOUNT := EOB := 0;
IF NEXTUNIT=WORKSPACEUNIT THEN % ESTABLISH A WORKSPACE
BEGIN
WORKSPACE:=NEXTUNIT;
SEQUENTIAL(WORKSPACE);
INITIALIZEPSR;
I=STORESEQ(WORKSPACE,PSR,PSRSIZE|8);
INITBUFF(OLDBUFFER,BUFFSIZE);
END ELSE % WORKSPACE ASSIGNED
I:=CONTENTS(WORKSPACE,0,PSR);
FILL ACCUM[*] WITH "LOGGED 1", "N ";
FORMROW(0,1,ACCUM,0,RI);
SYMBASE:=STAKCBASE:=0;
CSTATION.APLOGGED:=1;
CASE CURRENTMODE OF
BEGIN %--------CALCMODE--------------
;COMMENT NOTHING TO DO ANYMORE;
%--------------XEQUTEMODE----------------------
EXEC:
BEGIN F9ILL ACCUM[*] WITH "LAST RUN"," STOPPED";
FORMROW(3,0,ACCUM,0,16);
CURRENTMODE:=CALCMODE;
END;
%-------------FUNCMODE-----------------
BEGIN FILL ACCUM[*]WITH "CONTINUE"," DEFINIT",
"ION OF ";
FORMROW(2,0,ACCUM,0,23); FORMROW(1,0,PSR,
FSTART|8,7);
CURLINE:=GT3:=TOPLINE(GT1:=FUNCPOINTER);
CHECKSEQ(CURLINE,GT3,INCREMENT); %GET INCREMENT
CURLINE:=CURLINE+INCRMENT; INDENT(-CURLINE);
FUNCSIZE:=SIZE(GT1);
END;
%------------INPUTMODE-------------ERRORMODE----
GOTOEXEC; GO TO EXEC;
END;
GUESS: %SHOULD BE BETTER PLACE BUT HERE IS WHERE OTHERS COME OUT 07044001P71
STOREPSR;
IF CURRENTMODE NEQ FUNCMODE THEN
INDENT(0); TERPRINT;
VARSIE:=IF VARPIABLES=0 THEN 0 ELSE SIZE(VARIABLES);
END;
PROCEDURE APLMONITOR;
BEGIN
REAL T;
INTEGER I;
BOOLEAN WORK;
LABEL AROUND, NEWUSER;
LABEL CALULATE,EXECITEIT,FUNCTIONSTART,BACKAGAIN;
LABEL CALCULATEDIT;
I := CUSER := 1;
T := STATION;
BEGIN FILL ACCUM[*] WITH "APL/B550","0 UW COM"
,"PUTER SC","IENCE #",VERSIONDATE;
WORK:=TRUE;
FORMROW(3,MARGINSIZE,ACCUM,0,40);
INDENT(0); TERPRINT; CSTATION.APLHEADING:=1
; LOGINAPLUSER;
END;
AROUND:
BEGIN
IF MAINTENANCE THEN;
CASE CURRENTMODE OF
BEGIN %-------CALCMODE--------------------------------
COMMENT HE MUST BE READ READY FOR THE CALCMODE STUFF;
GO CALCULATE;
%--------XEQUTE MODE--------------------------------
GO TO EXECUTEIT;
%----------FUNCMODE-----------------------------------
GO TO FUNCTIONSTART;
%-----------INPUTMODE---------------------------------
COMMENT REQUIRES INPUT;
BEGIN COMMENT GET HT ELINE AND GO BACK;
STARTSCAN;
CURRENTMODE:=XEQM+ODE;
GO TO EXECUTEIT;
END;
%----------ERRORMODE---------------------------------
GO TO BACKAGAIN;
END; %OF CASES
END;
COMMENT GET HERE IF NOTHING TO DO;
GO TO AROUND;
CALCULATE:
STARTSCAN;
CALCULATEDIT:
ERR:=0; %AND DON"T RESET IT IN SCAN OR IN ANALYZE
IF SCAN THEN
IF RGTPAREN THEN MESSAGEHANDLER EALSE
IF DELV THEN FUNCTIONHANDLER ELSE
BEGIN COMMENT PROCESS CAJLCULATOR MODE REQUEST;
MOVE(OLDBUFFER,BUFFERSIZE,BUFFER);
IF NOT BOOLEAN(SUSPENSION) THEN BEGIN %INITIALIZE USER
%%%
%%%
SYMBASE:=STACKBASE:=0;
END;
PROCESS(XEQUTE);
IF CURRENTMODE=CALCMODE THEN
BACKAGAIN: BEGIN INDENT(0); TERPRINT;
IF NOT BOOLEAN(SUSPENSION) THEN
BEGIN IF CURRENTMODE NEQ ERRORMODE THEN
PROCESS(WRITEBACK);
SP[0,0]:=0;NROWS:=-1;
%%%
END;
CURRENTMODE:=CALCMODE;
END;
IF EDITOG=1 THEN
BEGIN MOVE(OLDBUFFER,BUFFERSIZE,BUFFER);
RESCANLINE; EDITOG:=0; GO TO CALCULATEDIT;
END;
I:=0;
GO AROUND; 07127000P72
EXECUTEIT:
POECESS(XEQUTE); %GO BACK TO PROCESS FOR AWHILE
IF CURRENTMODE=CALCMODE THEN GO TO BACKAGAIN;
I:=0;
GO AROUND;
FUNCTIONSTART:
IF SPECMODE = 0 THEN
BEGIN %SEE IF A SPECIAL FUNCTION.
STARTSCAN;
IF SCAN AND RGTPAREN THEN MESSAGEHANDLER ELSE
FUNCTIONHANDLER
END ELSE
FUNCTIONHANDLER;
I:=0;
GO AROUND
END;
INTEGER PROCEDURE LENGTH(A,M);VLUE M; BOOLEAN M; ARRAY A[0];
BEGIN
INTEGER STREAM PROCEDURE LENGT(A,M,L); VALUE M,L;
BEGIN LOCAL T;
LOCAL C,CC,TST; LABEL LAB;
LOCAL AR; LABEL LAB2;
SI:=LOC M; SI:=SI+7;
IF SC'"1" THEN
BEGIN COMMENT LOOK FOR LEFT ARROW.;
DI:=LOC AR; DS:=RESET; DS:=5SET;
SI:=LOCL; DI:=LOC T; DI:=DI+1; DS:=7CHR;
SI:=A;
T(2(32(DI:=LOC AR; IF SC=DC THEN JUMP OUT 3 TO LAB;
TALLY:=TALLY+1;
C:=TALLY; TSI:=SI; SI:=L9OC C;
SI:=SI+7; IF SI="0" THEN
BEGIN TALLY:=CC; TALLY:=TALLY+1; CC:=TALLY;
TALLY:=0;
END; SI:=TSI)));
L(DI:=LOC AR; IF SC=DC THEN JUMP OUT TO LAB;
TALLY:=TALLY+1; C:=TALLY; TSI:=SI; SI:=LOC C; SI:=SI+7;
IF SC="0" THEN
BEGIN TALLY:=CC; TALLY:=TALLY+1; CC:=TALLY; TALLY:=0;
END; SI:=TSI);
LAB: SI:=LOC CC; DI:=LOC LENGT; DI:=DI+6; SI:=SI+7;
DS:=CHR; SI:=LOC C; SI:=SI+7; DS:=CHR;
END ELSE
BEGIN
SI:=LOC L; DI:=LOC T; DI:=DI+1; DS:=7CHR;
SI:=A; T(2(SI:=SI+32)); SI:=SI+L;
T(2(32(SI:=SI-1; IF SC NEQ " " THEN JUMP OUT 3 TO LAB2;
TALLY:=TALLY+1; C:=TALLY; SI:=SI; SI:=LOC C; SI:=SI+7;
IF SC="0" THEN
BEGIN TALLY:=CC; TALLY:=TALLY+1; CC:=TALLY; TALLY:=0
END; SI:=TSI)));
LAB2: GO TO LAB
END
END;
INTEGER I;
I:=LENGT(A,M,BUFFSIZE|8);
LENGTH:=IF M THEN I ELSE BUFFSIZE|8-I
END
BOOLEAN PRUOCEDURE LABELSCAN(L,K); VALUE K; INTEGER K; ARRAY L[0];
BEGIN REAL T;
T:=ADDRSS;
IF SCAN AND IDENT THEN
BEGIN SETFIELD(ACCUM,1,1,0); TRANSFER(ACCUM,1,L,K|8,8);
IF NOT(LABELSCAN:=(SCAN AND COLON)) THEN
BEGIN ADDRESS:=T; EOB:=0; IF SCAN THEN;
END;
END
END;
STREAM PROCEDURE MOVEWDS(A,N,B); VALUE N;
BEGIN SI:=A; DT:=8; DS:=N WDS END;
INTEGER PROCEURE DAYTIME(B); ARRAY B[0];
BEGIN
INTEGER D,H,M,MIN,Q,P,Y,TIME1;
LABEL OWT;
STREAM PROCEDURE FORM(A,DAY,MD,DA,YR,HR,MIN,AP);
VALUE DAY,MD,DA,YR,HR,MIN,AP;
BEGIN DI:=A; 08014064P73
SI:=LOC DAY; SI:=SI+7;
IF SC="0" THEN DS:=3LIT"SUN" ELSE
IF SC="1" THEN DS:=3LIT"MON" ELSE
IF SC="2" THEN DS:=4LIT"TUES" ELSE
IF SC="3" THEN DS:=6LIT"WEDNES" ELSE
IF SC="4" THEN DS:=5LIT"THURS" ELSE
IF SC="5" THEN DS:=3LIT"FRI" ELSE DS:=5LIT"SATUR";
DS:=4LIT"DAY "; SI:=LOC MO; DS:=2DEC;
DS:=LIT"-"; SI:=LOC DA; DS:=2DEC; DS:=LIT"-";
SI:=LOC YR; DS:=2DEC; DS:=2LIT" ";
SI:=LOC HR; DS:=2DEC; DS:=LIT":"; SI:=LOC MIN;
SI:=SI+6; DS:=2CHR; SI:=LOC AP; SI:=SI+7; DS:=LIT" ";
DS:=CHR; DS:=LIT"M"
END;
TIME1:=TIME(1);
Y:=TIME(0);
D:=Y.[30:1]|100+Y.[36:6]|10+Y.[42:6];
Y:=Y.[18:6]|10+Y.[24:6];
FOR H:=31,IF Y MOD 4=0 THEN 29 ELSE 28,31,30,
31,30,31,31,30,31,30 DO
IF D LEQ H THEN GO OWT ELSE
BEGIN D:=D-H; M:=M+1;
END;
OWT:
H:=TIME1 DIV 216000;
MIN:=(TIME1 DIV 3600) MOD 60;
IF M LSS 2 THEN
BEGIN Q:=M+11; P:=Y-1;
END ELSE
BEGIN Q:=M-1; P:=Y
END;
M:=M+1;
FORM(B,TIME1:=((Q|26-2)DIV 10+D+P+P.[36:10]+1)MOD 7,
M,D,Y,Q:= H MOD 12, Q:=MIN MOD 10+(MIN DIV 10)|64,
IF H GEQ 12 THEN "P" ELSE 17);
DAYTIME:=(IF TIME1=6 THEN 5 ELSE
IF TIME1=5 THEN 3 ELSE
IF TIME2=2 THEN 4 ELSE 3)+22;
END;
PROCEDURE LOADWORKSPACE(NAME1,NAME2,IDENT); VALUE NAME1,NAME2;
REAL NAME1,NAME2; ARRAY IDENT[0];
BEGIN
FILE DISK DISK(2,WDSPERREC,WDSPERBLK);
INTEGER PROCEDURE RD(D,N,A);
VALUE N; INTEGER N; FILE D; ARRAY A[0];
BEGIN READ(D[N],WDSPERREC,A[*]);
RD:=N+1;
END;
PROCEDURE LOADITEM(RD,D,ITEM);
INTEGER PR+OCEDURE RD; FILE D;
ARRAY ITEM[0];
BEGIN
DEFINE T=ITEM#;
PROCEDURE GETALINE(C,S,L,R,RD,D,LEN);
VALUE LEN; INTEGER C,S,L,LEN;
ARRAY A[0]; INTEGER PROCEDURE RD; FILE D;
BEGIN % GET 2 CHRS GIVING ENSUING CHAR COUNT
INTEGER P;
IF C GTR LEN-2 THEN
IF C GTR LEN-1 THEN % READ A NEW RECORD AND TAKE 2 CHRS
BEGIN
S:=RD(D,S,R);
C:=2;
TRANSFER(B,0,L,6,2);
END
ELSE % 1 CHR LEFT ON LINE
BEGIN
TRANSFER(B,C,L,6,1);
S:=RD(D,S,B);
TRANSFER(B,0,L,7,1);
C:=1;
END
ELSE % AT LEAST 2 CHARS REMAINING ON LINE
BEGIN
TRANSFER(B,C,L,6,2);
C:=C+2;
END;
P:=0;
+IF L NEQ 0 THEN % SOMETHING LEFT IN FUNCTION
BEGIN
WHILE P LSS L DO 08014459P74
IF (L-P) GTR (LEN-C) THEN % # OF CHARS IN LINE
% EXTENDS INTO NEXT RECORD
BEGIN
TRANSFER(B,C,BUFFER,P,LEN-C); % FINISH OUT RECORD
S:=RD(D,S,R);
P:=P+(LEN-C); % AMOUNT READ SO FAR
C:=0;
END
ELSE % ALL ON ONE RECORD
BEGIN
TRANSFER(B,C,BUFFER,P,L-P);
C:=C_L-P;
P:=L; % FINISHED
END;
END;
END OF GETALINE;
INTEGER S,K,L,M,C,LEN,SQ,PT,G,I,SIZE;
INTEGER HOLD;
LABEL SCALARL;
ARRAY U[0:1],B[0:WDSPERREC-1];
BOOLEAN TOG;
TRANSFER(T,0,U,0,7);
G:=GETFIELD(T,7,1);
IF VARSRSIZE GTR 0 THEN
IF K+;SEARCHORD(VARIABLES,U,HOLD,7)=0 THEN
IF K:=GETFIELD(U,7,1)=FUNCTION THEN TOG:=TRUE
ELSE % NOT A FUNCTION IN THE SYMBOL TABLE
IF G=FUNCTION THEN
BEGIN
DELETE1(VARIABLES,HOLD);
IF K=ARRAYDATA THEN RELEASEARRAY(U[1]);
END;
ELSE TOG:=TRUE % DON-T CHANGE
ELSE % NOT IN VARIABLES
BEGIN
VARSIZE:=VARSIZE+1;
HOLD:=HOLD+K-1;
END;
ELSE VARSIZE:=1;
LEN:=(WDSPERREC-1)|8;
IF NOT TOG THEN % OK TO PUT INTO VARIABLES
IF G=FUNCTION THEN % READ A FUNCTION INTO VARIABLES
BEGIN
TRANSFER(T,0,U,0,9); % U HOLDS FUNCTION NAME,
%NUMBER OF ARGUMENTS, AND WHETHER FN RETURNS A VALUE
S:=T[1].LIBF1; % RECORD NUMBER
M:=T[1].LIBF2; % WORD WITHIN RECORD
SIZE:=T[1].LIBF3; % SIZE OF POINTERS TABLE
PR:=NEXTUNIT;
S:=RD(D,S,B);
FOR I:=0 STEP 1 UNTIL SIZE-1 DO
BEGIN
TRANSFER(M,M|8,T,0,16);
M:=M+2;
IF M GEQ WDSPERREC-1 THEN
BEGIN
S:=RD(D,S,R);
IF M GEQ WDSPERREC THEN
BEGIN
TRANSFER(B,0,T,8,8);
M:=1;
END
ELSE M:=0;
END;
STOREORD(PT,T,I);
END; % HAV FINISHED FILLIN G POINTERS TABLE
IF VARIABLES=0 THEN BEGIN
VARIABLES:=NEXTUNIT; TOG:=TRUE; %KEEP THE UNIT OPEN
STOREORD(VARIABLES,U,HOLD); END;
SEQUENTIAL (SQ:=MEXTUNIT);
SETFIELD(U,FPTF,FFL,PT);
SETFIELD(U,FSQF,FFL,SQ);
STOREORD(VARIABLES,U,HOLD);
IF TOC THEN DELETE1(VARIABLES,HOSLD+1);%REMOVE 1 EXTRA
COMMENT NOW FILL IN SEQ STORAGE;
IF M NEQ 0 THEN BEGIN
M:=C:=0;
S:=RD(D,S,B); % TEXT STARTS AT BEG. OF NEW RECORD
END;
L:=1;
WHILE L NEQ 0 DO
BEGIN 08014747P75
GETALINE(C,S,L,B,RD,D,LEN);
GT1:=STORESEQ(SQ,BUFFER,L);
END
END
ELSE
IF G=ARRAYDATA THEN
IF T[1].INTPTR=0 THEN % NULL VECTOR
GOTO SCALARL
ELSE
BEGIN
ARRAY DIMVECT[0,MAXBUFFSIZE];
S:=T[1].INPTR; % RECORD NUMBER
M:=T[1].DIMPTR; % LOC WITHIN RECORD
C:=M|8;
SIZE:=RD(D,S,B);
GETALINE(C,S,L,B,RD,D,LEN);
T[1].DIMPTR:=STORESEQ(WS,BUFFER,L);
% PUTS DIMVECT INTO WORKSPACE
GETALINE(C,S,L,B,RD,D,LEN); % # BLOCKS
SIZE:=L-1;
FOR K:=0 STEP 2 UNTIL SIZE DO
BEGIN
GETALINE(C,S,L,B,RD,D,LEN);
SETFIELD(DIMVECT,K,S,STORESEQ(WS,BUFFER,L));
END; COMMENT THIS STORES THE VALUES OF THE
ARRAY INTO THE W+ORKSPACE, AND ALSO RECORDS
THE LOCATION WITHIN WS IN DIMVECT,TO BE STORED;
T[1].INPTR:=STORESEQ(WS,DIMVECT,SIZE+1);
IF VARIABLES=0 THEN VARIABLES:=NECTUNIT;
STOREORD(VARIABLES,T,HOLD);
END
ELSE % MUST BE A SCALER
SCALARL:
BEGIN
IF VARIABLES=0 THEN VARIABLES:=NEXTUNIT;
STOREORD(VARIABLES,T,HOLD);
END
ELSE % WILL NOT REPLACE IN SYMBOL TABLE
BEGIN
FILL BUFFER[*] WITH " ","NOT REPL","ACED ";
TRANSFER(T,0,BUFFER,0,7);
FORMROW(3,0,BUFFER,0,20);
END;
END LOADITEM;
BOOLEAN STREAM PROCEDURE EQUAL(A,B);
BEGIN SI:=A; DI:=B; SI:=SI+2; IF 7SC=DC THEN TALLY:=1;
EQUAL:=TALLY
END;
INTEGER I,J,L,NDIR,N;
LABEL MOVEVAR,SKIP;
ARRAY T,U[0:1],D[0:WDSPERREC-1];
FILL DISK WITH NAME1,NAME2; L:=RD(DISK,L,D);
IF D[1] NEQ JOBNUM AND D[1] NEQ 0 THEN GO SKIP; % FILE LOCKED
FOR I:=2 STEP 1 UNTIL 9 DO IF GETFIELD(D[I],1,7) NEQ C THEN GO SKIP;
IF NDIR:=D[0] NEQ 0 THEN
BEGIN N:=LIBSPACES+ENTIER(NDIR|2/(J:=WDSPERREC-1));
IF(NDIR|2) MOD J NEQ 0 THEN N:=N+1;
FOR I:=1 STEP 1 UNTIL NDIR DO
BEGIN COMMENT GET FUNCTION OR VARIABLE NAME FROM LIB;
IF WDSPERREC-J LSS 3 THEN
IF WDSPERREC-J=1 THEN
BEGIN L:=RD(DISK,L,D); J:=0; GO MOVEVAR
END ELSE
BEGIN TRANSFER(D,J|8,T,08); L:=RD(DISK,L,D);
TRANSFER(D,0,T,8,8); J:=1
END ELSE MOVEVAR:
BEGIN TRANSFER(D,J|8,T,0,16); J:=J+2
END;
IF(IF IDENT[0]=0 THEN TRUE ELSE EQUAL(IDENT,T)) THEN
BEGIN IF IDENT[0] NEQ 0 THEN I:=NDIR+1;
LOADITEM(RD,DISK,T);
END
END;
STOREPSR; % UPDATE SINCE HAVE ADDED TO VARIABLES
END;
IF FALS THEN SKIP; FORMWD(1,"6BADFIL");
EOB:=1;
END OF LIBRARY LOAD;
PROCEDURE PURGEWORKSPACE(WS); VALUE WS; INTEGER WS;
IF WORKSPACE NEQ 0 THEN
BEGIN
INTEGER I,J,K,V,L,G; 08015020P76
ARRAY T[0,1];
J:=SIZE(V:=VARIABLES)-1;
FOR I:=0 STEP 1 UNTIL J DO
BEGIN K:=CONTENTS(V,I,T);
IF GETFIELD(T,7,1)=FUNCTION THEN
FOR L:=FPTF,FSQF DO % GET RID OF STORAGE
IF G:=GETFIELD(T,L,FFL) NEQ 0 THEN RELEASEUNIT(G);
END;
RELEASEUNIT(V);
VARIABLES:=0; VARSIZE:=0;
CURRENTMODE:=0; J:=SIZE(WS)-1;
FOR I:=1 STEP 1 UNTIL J DO DELETE1(WS,I);
STORESPR;
END;
PROCEDURE ELIMWORKSPACE(WS); VALUE WS; INTEGER WS;
BEGIN LABEL QQQ; QQQ:
IF WORKSPACE NEQ 0 THEN
BEGIN
PURGEWORKSPACE(WS); RELEASEUNIT(WS);
%
END ELSE SPOUT(8015222);
END;
PROCEDURE SAVEWORKSPACE(NAME1,NAME2,LOCKFILE);
VALUE NAME1,NAME2,LOCKFILE;
REAL NAME1,NAME2,LOCKFILE;
BEGIN
SAVE FILE DISK [NAREAS:SIZEAREAS]
(2,WDSPERREC,WDSPERBLK,SAVE 100);
INTEGER PROCEDURE WR(D,N,A); VALUE N; INTEGER N;
F+ILE D; ARRAY A[0];
BEGIN REAL STREAM PROCEDURE CON(A); VALUE A;
BEGIN SI:=LOCA; DI:=LOC C9ON; DS:=8DEC END;
STREAM PROCEDURE CLEANER(A);
BEGIN DI:=A; WDSPERREC(DS:=BLIT".") END;
A[WDSPERREC-1]:=CON(N);
WRITE(D[N],WDSPERREC,A[*]);
WR:=N+1; CLEANER(A);
END;
PROCEDURE PUTAWAY(C,J,WR,D,N,M,B,L); VALUE L,J;
INTEGER L,C,J,N,M;
ARRAY B[0]; INTEGER PROCEDURE WR; FILE D;
BEGIN INTEGER P,K;
IF C+2 GTR L THEN
BEGIN TRANSFER(J,6,B,C,1); N:=WR(D,N,B); C:=1;
TRANSFER(J,7,B,0,1);
END ELSE
BEGIN TRANSFER(J,6,B,C,2); C:=C+2;
END;
WHILE J NEW 0 DO
IF J GTR K:=(L-C) THEN
BEGIN TRANSFER(BUFFER,P,B,C,K);
N:=WR(D.N.B); J:=J-K; C:=0; P:=P+K
END ELSE
BEGIN TRANSFER(BUFFER,P,B,C,J); C:=C+J; J:=0
END;
IF C=L THEN
BEGIN N:=WR(D,N,B); C:=0
END;
END;
PROCEDURE MOVETWO(U,B,M,WR,L,D);
ARRAY U,B[0]; INTEGER M,L; INTEGER PROCEDURE WR; FILE D;
BEGIN
COMMENT PUTS 2 WORDS OF U IN B AND WRITES ON D IF A FULLRECORD;
TRANSFER(U,0,B,M|8,16); % CONTENTS OF U INTO B
M:=M+2;
IF M GEQ WDSPERREC-1 THEN % FULL RECORD
BEGIN
L:=WR(D,L,B);
IF M GEQ WDSPERREC THEN % 1 OVER FULL RECORD
BEGIN
TRANSFER(U,8,B,0,8);
M:=1;
END
ELSE M:=D;
END;
END OF MOVETWO;
INTEGER H,Q,M,N,I,L,S,J,K,LINE,MAX,PT,SQ,C,LEN,W;
REAL LSD,STP;
LABEL SKIP;
ARRAY T,U[0:1],DIR,B,SEX[0:WDSPERREC];
N:=LIBSPACES+ENTIER((S:=SIZE(VARIABLES))|2/(WDSPERREC-1)); 08015575P77
IF (S|) MOD (WDSPERREC-1) NEQ 0 THEN N:=N+1; % ADJUST
LEN:=(WDSPERREC-1)|8;
FILLS DISK WITH NAME1,NAME2;
DIR[0]:=S; % SIZE OF SYMBOL TABLE
IF BOOLEAN (LOCKFILE) THEN DIR[1]:=JOBNUM;
S:=S-1;
L:=WR(DISK,L,DIR); % FIRST LINE CONTAINS # OF ENTRIES IN
COMMENT SYMBOL TABLE AND LOCK INFORMATION;
FOR I:=0 STEP 1 UNTIL 5 DO
BEGIN
J:=CONTENTS(VARIABLES,T,T); % RETURNS VALUE OF I-TH LOC
% IN VARIABLES INTO T
IF GT2:=GETFIELD(T,7,1)=FUNCTION THEN
BEGIN
PT:=GETFIELD(T,FPTF,FFL); % FUNCTION POINTER FIELD
SQ:=GETFIELD(T,FSQF,FFL); % FUNCTION SEQUENTIAL FIELD
%PT=# OF ORDERED STORAGE UNIT CONTAINING HEADER&POINTE
%SQ=# OF SEQ STORAGE UNIT CPONTAINING TEXT
MAX:=SIZE(PT);
T[1].LIBF1:=N; % RECORD #
T[1].LIBF2:=M; % LOC WITHIN RECORD
T[1].LIBF3:=MAX; % SIZE OF POINTERS TABLE;
% SAVE ENOUGH ROOM FOR THE ENTIRE POINTERS TABLE
H:=ENTIER(GT1:=(M+MAX|2)/(WDSPERREC-1));
H:=IF GT1 NEQ H THEN H+N+1 ELSE H+N;
U[0]:=0;
J:=SEARCHORD(PT,U,LINE,8); % LOOK FOR ALL ZEROS
IF J=2 THEN GO SKIP;
FOR W:=0 STEP 1 UNTIL LINE-1 DO
%MOVE LOCALS AND LABELS INTO THE SAVE FILE
BEGIN
J:=CONTENTS(PT,W,U);
MOVETWO(U,B,M,WR,N,DISK);
END;
FOR LINE:=LINE STEP 1 UNTIL MAX-1 DO
BEGIN
J:=CONTENTS(PT,LINE,U);
GT1:=U[1];
U[1]:=LINE-W;
MOVETWO(U,B,M,WR,N,DISK); % POINTERS TABLE
J:=CONTENTS(SQ,GT1,BUFFER);
PUTAWAY(C,J,WR,DISK,H,Q,SEX,LEN); % TEXT
END;
PUTAWAY(C,0,WR,DISK,H,Q,SEX,LEN);
SKIP:
Q:=C DIV 8;
IF C MOD 8 NEQ 0 THEN Q:=Q+1;
IF Q=WDSPERREC-1 THEN
BEGIN
H:=WR(DISK,H,SEX);
Q:=0;
END;
IF M GTR 0 THEN N:=WR(DISK,N,B);
M:=Q; N:=H;
TRANSFER(SEX,0,B,0,C); % MOVE BACK TO B
C:=0;
END
ELSE
BEGIN
T[1].INPTR:=N; T[1].DIMPTR:=M;
C:=M|8;
J:=CONTENTS(WS,LSD,DIMPTR,BUFFER); % DIM VECT
PUTAWAY(C,J,WR,DISK,N,M,B,LEN); % STD DIM VECT
J:=CONTENTS(WS,LSD,INPTR,DIMVECT);
TRANSFER(DIMVECT,0,BUFFER,0,J);
PUTAWAY(C,J,WR,DISK,N,M,B,LEN);
J:=J-1;
FOR LINE:=0 STEP 2 UNTIL J DO
BEGIN
PT:=GETFIELD(DIMVECT,LINE,2);
STP:=CONTENTS(WS,PT,BUFFER);
PUTAWAY(C,STP,WR,DISK,N,M,B,LEN);
END;
M:=C DIV A; IF C MOD A NEQ 0 THEN M:=M+1; C:=0;
IF M=WDSPERREC-1 THEN BEGIN N:=WR(DISK,N,8);
M:=0; END; 08015888P78
END;
END;
MOVETWO(T,DIR,K,WR,L,DISK);
END;
EOB:=1;
IF M GTR 0 THEN N:=WR(DISK,N,B);
IF K GTR 0 THEN L:=WR(DISK,L,DIR);
LOCK(DISK);
END;
BOOLEAN PROCEDURE LIBNAMES(A,B); REAL A,B;
BEGIN REAL T;
A:=B:=GT1:=0;
%
%
IF SCAN AND IDENT THEN
BEGIN T~ACCUM[0]; T.[6:6]~"/";
IF SCAN AND LOCKIT THEN GT1~1 ELSE IF IDENT THEN LIBNAMES~TRUE;
A~T; B~ JOBNUM;
END
ELSE LIBNAMES~ TRUE;
END;
PROCEDURE MESSAGEHANDLER;
BEGIN
LABEL ERR1;
%
IF SCAN THEN IF IDENT THEN
BEGIN INTEGER I; REAL R,S;
PROCEDURE NOFILEPRESENT;
BEGIN
FILL BUFFER[*] WITH "FILE NOT", " ON DISK";
FORMROW(3,0,BUFFER,0,16);
END OF NOFILEPRESENT;
PROCEDURE PRINTF(VARS); VALUE VARS; BOOLEAN VARS;
BEGIN INTEGER I,J,K,L,M; ARRAY T[0:1]; BOOLEAN TOG;
INTEGER NUM;
J:=VARSIZE-1; M:=VARIABLES;
FOR I:=0 STEP 1 UNTIL N DO
BEGIN L:=CONTENTS(M,I,T); TOG:=GETFIELD(T,7,1)
=FUNCTION;
IF NUM:=3|REAL(TOG AND VARS)+8+NUM GTR LINESIZE
THEN BEGIN TERPRINT; NUM:=8|READL(TOG AND VARS)+8 END;
IF VARS THEN
BEGIN FORMROW(0,1,T,0,7); L:=L+1;
IF TOG THEN FORMWRD(0,"3(F) ");
END ELSE
IF TOG THEN BEGIN L:=L+1; FORMROW(0,1,T,0,7) END;
END;
IF L=0 THEN FORMWD(3,"6 NULL.") ELSE TERPRINT
END;
R:=ACCUM[0];
FOR I:=0 STEP 1 UNTIL MAXMESS DO
IF R=MESSTAB[I] THEN
BEGIN R:=I; I:=MAXMESS+1
END;
IF I=MAXMESS+2 THEN
CASE R OF
BEGIN
% ------- SAVE -------
IF NOT LIBNAMES(R,S) THEN
IF NOT LIBRARIAN(R,S) THEN BEGIN
SAVEWORKSPACE(R,S,GT1); %GT1 SET IN LIBNAMES
GTA[0]~GTA[1]~0;TRANSFER(R,1,GTA,1,7);
IF(GT1~SEARCHORD(LIBRARY,GTA, I, 7)) NEQ 0 THEN
BEGIN GTA[0]~GTA[1]~0;TRANSFER(R,1,GTA,1,7);
STOREORD(LIBRARY,GTA,I+(IF GT1=1 THEN -1 ELSE 1));
END; LIBSIZE~LIBSIZE+1;
END
ELSE
BEGIN
FILL BUFFER[*] WITH "FILE ALR","EADY ON ",
"DISK ";
FORMROW(3,0,BUFFER,0,20);
END
ELSE GO ERR1;
% ------- LOAD -------
IF NOT LIBNAMES(R,S) AND R NEQ 0 THEN
IF LIBRARIAN(R,S) THEN
BEGIN ARRAYA[0:1];
LOADWORKSPACE(R,S,A);
END
ELSE NOFILEPRESENT
ELSE GO ERR1; 0801626?P79
% ------- DROP -------
IF CURRENTMODE=CALCMODE THEN
IF NOT LIBNAME(R,S) THEN
IF LIBRARIAN(R,S) THEN
BEGIN FILE ELIF DISK (1,1);
FILL ELIF WITH R,S; WRITE(ELIF[0]);
CLOSE(ELIF,PURGE)
;GTA[0]~GTA[1]~0;TRANSFER(R,1,GTA,1,7);
IF SEARCHORD(LIBRARY,GTA,I,7)=0 THEN DELETE1(LIBRARY,I);
LIBSIZE~LIBSIZE-1;
END
ELSE NOFILEPRESENT
ELSE
IF NOT BOOLEAN(SUSPENSION)THEN PURGEWORKSPACE(WORKSPACE)
ELSE GO ERR1 ELSE GO ERR1;
% ------- COPY -------
IF LIBNAMES(R,S) THEN
IF LIBRARIAN(R,S) THEN
LOADWORKSPCE(R,S,ACCUM)
ELSE NOFILEPRESENT
ELSE GO ERR1;
% -------- VARS -------
PRINTID(TRUE);
%------- FNS -------
PRINTID(FALSE);
%-------- LOGGED ----------------
;
%-------- MSG --------
ERRORMESS(SYNTAXERROR,LADDRESS,0);
%-----WIDTH (INTEGER) ---------------------------
IF NOT SCAN THEN BEGIN NUMBERCON(LINSIZE, ACCUM);
FORMROW(3,0,ACCUM,2,ACOUNT); END
ELSE IF NUMERIC AND I:=ACCUM[0] GTR 9 AND I LEQ 72
THEN BEGIN TERPRINT; LINESIZE:=I; STOREPSR;
END
%IF A NUMBER CONVERSION ERROR, RESULT WILL BE ZERO
%AND WE"LL GET AN ERROR ANYWAY
ELSE GO TO ERR1;
%-------- OPR --------
;
%------DIGITS (INTEGER) ------------------------
IF NOT SCAN THEN BEGIN NUMBERCON(DIGITS,ACCUM);
FORMROW(3,0,ACCUM,2,ACOUNT); END
ELSE IF NUMERIC AND I:=ACCUM[0] GEQ 0 AND I LEQ 12
AND ERR=0 THEN BEGIN DIGITS:=I; STOREPSR END
ELSE GO TO ERR1;
%-------- OFF --------
BEGIN
IF SCAN THEN IF ACCUM[0]="7DISCAR" THEN
ELTMWORKSPACE(WORKSPACE) ELSE
GO TO ERR1;
FILL ACCUM[*] WITH "END OF R","UN ";
FORMROW(3,MARGINSIZE,ACCUM,0,10);
CURRENTMODE=CALCMODE;
GT1:=CSTATION;
CSTATION:=GT1&0[CAPLOGGED]
;GO TO FINIS;
END;
%--------ORIGIN----------------------------------
IF NO SCAN THEN BEGIN NUMBERCON(ORIGIN,ACCUM);
FORMROW(3,0,ACCUM,2,ACOUNT) END
ELSE IF NUMERIC AND ERR=0 THEN BEGIN ORIGIN:=
I:=ACCUM[0]; STOREPSR END ELSE GO TO ERR1;
%--------SEED---------------------------------
IF NOT SCAN THEN BEGIN NUMBERCON(SEED,ACCUM);
FORMROW(3,0,ACCUM,2,ACOUNT) END
ELSE IF NUMERIC AND ERR=0 THEN BEGIN
SEED:=ABS(I:=ACCUM[0]);
STOREPSR END ELSE GO TO ERR1;
%--------FUZZ------------------------------------
IF NOT SCAN THEN BEGIN
NUMBERCRON(FUZZ,ACCUM);
FORMROW(3,0,ACCUM,2,ACOUNT) END
ELSE IF NUMERIC AND ERR=0 THEN BEGIN FUZZ:=ABS(ACCUM[0]);
SIDREPSR END ELSE GO TO ERR1;
%------- SYN, NOSYN-------------------------------------
NOSYNTAX:=0; NOSYNTAX:=1;
%-----------------STORE-------------------------
IF SYMBASE NEQ 0 THEN PROCESS(WRITEBACK);
08017970P80
%-----------------ABORT-------------------------
BEGIN IF BOOLEAN(SUSPENSION) THEN
SP[0,0]:=0; NROWS:=-1;
%%%
SUSPENSION:=0;
STOREPSR;
END;
%-----------------SI------------------------------
IF BOOLEAN(SUSPENSION) THEN
BEGIN GT1:=0;
PROCESS(LOOKATSTACK);
END ELSE FORMWD(3,"6 NULL.");
%------------------SIV------------------------------
IF BOOLEAN(SUSPENSION) THEN
BEGIN GIT1:=1;
PROCESS(LOOKATSTACK);
END ELSE FORMWD(3,"6 NULL.");
%------------------ERASE------------------------------
IF CURRENTMODE=FUNCMODE OR BOOLEAN(SUSPENSION) THEN GO TO ERR1
ELSE WHILE SCAN AND IDENT DO
BEGIN % LOOK FOR THE INDENTIFIER NAME IN ACCUM
TRANSFER(ACCUM,2,GTA,0,7);
IF (IF VARIABLES=0 THEN FALSE ELSE
SEARCHWORD(VARIABLES,GTA,GT1,7)=0) THEN
BEGIN % FOUND SYMBOL TABLE ENTRY MATCHING NAME
DELETE1(VARIABLES,GT1); % REMOVE FROM SYMBOL TABLE
IF VARSIZE:=VARSIZE-1=0 THEN VARIABLES:=0;
COMMENT IF NOTHING IS IN THE UNIT IT IS DELETED;
% CHECK IF THERE ARE MORE TO DELETE
IF GT1:=GETFIELD(GTA,7,1)=FUNCTION THEN
BEGIN
RELEASEUNIT(GETFIELD(GTA,FPTF,FFL));
RELEASEUNIT(GETFIELD(GTA,FSQF,FFL));
END
ELSE IF GT1 GTR 0 THEN % MUST BE AN ARRAY
RELEASEARRAY(GTA[1]);
END ELSE % THERE IS NO SUCH VARIABLE
ERRORMESS(LABELERROR,LADDRESS,0);
END; % OF TAKING CARE OF ERASE
%------------ ASSIGN --------------------------------
;
%------------ DELETE ---------------------------------
;
%------------- LIST ------------------------------------
;
% -------------DEGUG --------------------------------
IF SCAN AND IDENT THEN
IF ACCUM[0]="6POLISH" THEN POLBUG:=ABS(POLBUG-1);
%----------------------------- FILES ----------------------
IF LIBSIZE>1 THEN
BEGIN FOR I~1 STEP 1 UNTIL LINSIZE-1 DO
BEGIN R~CONTENTS(LIBRARY,I ,ACCUM);
FORMROW(0,1,ACCUM,2,6);
END; TERPRINT;
END ELSE FORMWD(3,"6 NULL.");
%------------------------ END OF CASES -----------------------
END ELSE GO TO ERR1;
IF CURRENTMODE=FUNCMODE THEN INDENT(-CURLINE);
END ELSE
IF QUOTE THEN EDITLINE ELSE
ERR1: ERRORMESS(SYNTAXERROR,0,0);
INDENT(0);
TERPRINT;
END;
REAL PROCEDURE LINENUMBER(R); VALUE R; REAL R;
BEGIN
REAL STREAM PROCEDURE CON(R); VALUE R;
BEGIN SI:=LOC R; DI:=LOC CON; DS:=DEC
END;
LINENUMBER:=CON(ENTIER(R+.00005)|10000))
END;
DEFINE DELIM="""#, ENDCHR="$"#;
BOOLEAN PROCEDURE WITHINALINE(COMMAND,OLD,NEW,CHAR,WORD);
VALUE COMMAND,CHAR,WORD; INTEGER COMMAND,CHAR,WORD;
ARRAY OLD, NEWEDIT; BEGIN
BOOLEAN STREAM PROCEDURE WITHINALINE(COMMAND,OLD,NEW,CHAR,WORD);
VALUE COMMAND,CHAR.WORD;
BEGIN
LOCAL OLDLINE,NEWLINE,F,BCHR;
LOCAL N,M,T;
LOCAL X,Y,Z; 080301??P81
LABEL LOOKING,FOUND,BETWEEN,TAIL,FINISH,
OVER;
DI:=NEW; WORD(DS:=BLIT" ");
SI:=LOC CHAR; DI:=LOC T; DI:=DI+1; DS:=7CHR;
SI:=COMMAND;
TALLY:=T; X:=TALLY; TALLY:=2; Y:=TALLY; TALLY:=32; Z:=TALLY;
TALLY:=0;
IF SC!"~" THEN
BEGIN RCHR:=SI; SI:=OLD; OLDLINE:=SI;
DI:=NEW; NEWLINE:=DI; SI:=RCHR;
63(IF SC=DELIM THEN JUMP OUT ELSE SI:=SI+1; TALLY
:=TALLY+1); N:=TALLY;
IF TOGGLE THEN
BEGIN
SI:=SI+1; TALLY:=0;
63(IF SC=DELIM THEN TALLY:=0 ELSE
IF SC="~" THEN JUMP OUT ELSE TALLY:=TALLY+1; SI:=SI+1);
IF TOGGLE THEN M:=TALLY;;
DI:=OLDLINE; SI:=RCHR;
2( X( Y( Z( CI:=CI+F;
GO LOOKING; GO FOUND; GO BETWEEN; GO TAIL; GO FINISH;
LOOKING: %************ LOOKING FOR THE FIRST UNIQUE STRING**************
IF SC=DELIM THEN BEGIN SI:=SI+1; TALLY:=2; F:= TALLY ;
DI:=NEWLINE; GO BETWEEN END ELSE
IF N SC=DC THEN BEGIN SI:=OLDLINE; SI:=SI+N; OLDLINE:=SI;
DI:=NELINE; SI:=BCHR; TALLY:=1; F:=TALLY;
GO FOUND END ELSE
BEGIN SI:=OLDLINE; DI:=NEWLINE; DS:=CHR; NEWLINE:=DI;
OLDLINE:=SI; SI:=BCHR; DI:=OLDLINE;
END; GO OVER;
FOUND: %**************FOUND THE FIRST UNIQUE STRING ******************
IF SC=DELIM THEN BEGIN SI:=SI+1; TALLY:=2;
F:=TALLY; GO BETWEEN END ELSE
DS:=CHR; GO OVER;
BETWEEN: % ********** BETWEEN THEN // *********************************
IF SC=DELIM THEN BEGIN SI:=SI+1; NEWLINE:=DI; DI:=OLDLINE;
TALLY:=3; F:=TALLY; GO TAIL END ELSE
IF SC="~" THEN BEGIN TALLY:=4; F:=TALLY;
SI:=OLDLINE; GO FINWISH END ELSE
DS:=CHR; GO OVER;
TAIL: % ******* THE TAIL END OF THE COMMAND ***************************
IF M SC=DC THEN BEGIN DI:=NEWLINE; SI:=OLDLINE; TALLY:=4;
F:=TALLY; GO FINISH END ELSE
BEGIN SI:=SI-M; DI:=DI-M; DI:=DI+1; OLDLINE:=DI; END;
GO OVER;
FINISH: % ********FINISH UP THE CHAR MOVE FROM OLD TO NEW*************
DS:=CHR; OVER:)));
TALLY:=CHAR; X:=TALLY; TALLY:=1; Y:=TALLY;
Z:=TALLY);
SI:=NEW; DI:=OLD; DS:=WORD WDS; TALLY:=1;
WITHINLINE:=TALLY;
END
END
END OF WITHINALINE;
WITHINALINE := WITHINALINE(COMMAND,OLD,NEW,CHAR,WORD);
END OF PHONY WITHINALINE;
PROCEDURE EDITLINE;
BEGIN ARRAY T[0:MAXBUFFSIZE];
INITBUFF(T,BUFFSIZE);
TRANSFER(OLDBUFFER,0,T,0,LENGTH(OLDBUFFER,TRUE));
IF WITHINALINE(ADDRESS,T,OLDBUFFER,BUFFSIZE|8,BUFFSIZE) THEN
BEGIN MOVEWDS(OLDBUFFER,BUFFSIZE,BUFFER);
IF SCAN AND RGTPAREN THEN
ERRORMESS(SYNTAXERROR,LADDRESS,0) ELSE EDITOG:=1;
END;
FORMROW(3,0,BUFFER,0,LENGTH(BUFFER,FALSE));
END;
PROCEDURE CHECKSEQ(SEQ,L,INC); REAL SEQ,L,INC;
BEGIN
INTEGER I,J;
I:=L|10000 MOD 10000;
FOR J:=-4 STEP 1 WHILE J LSS 0 AND I MOD 10=0 DO
I:=I/10;
INC:=10*J;
SEQ:=L;
END;
PROCEDURE FUNCTIONHANDLER;
BEGIN
LABEL ENDHANDLER;
OWN BOOLEAN EDITMODE; 09003000P82
DEFINE FPT=FUNCPOINTER@,
FSQ=FUNCSEQ#,
SEQ=CURLINE#,
INC=INCREMENT#,
MODE=SPECMODE#,
ENDDEFINES=#;
INTEGER STREAM PROCEDURE DELPRESENT(ADDR); VALUE ADDR;
BEGIN LABEL L,FINIS;
LOCAL Q;
DI:=LOC Q; DS:=RESET; DS:=5SET; DS:=2RESET; DS:=2SET;
% LEFT-ARROW / QUESTION MARK
SI:=ADDR;
L: DI:=LOCQ;
IF SC=DELCHR THEN
BEGIN ADDR:=SI; SI:=LOC; DS:=ADDR; DS:=LIT" ";
TALLY:=1; DELPRESENT:=TALLY; GO TO FINIS;
END;
IF SC=DC THEN GO TO FINIS; SI:=SI-1;
IF SC=DC THEN GO TO FINIS;
GO TO SL;
FINIS:
END;
INTEGER PROCEDURE OLDLABCONFLICT(PT,S); VALUE PT,S;
INTEGER PT, REAL S;
IF PT NEQ 0 THEN
BEGIN INTEGER K; ARRAY L[0:1];
ADDRESS:=ABSOLUTEADDRESS;
WHILE LABELSCAN(L,0) AND ERR EQL 0 DO
IF SEARCHORD(PT,L,K,8)=0 THEN
IF L[1] NEQ S THEN ERR:=24;
OLDLABELCONFLICT:=ERR
END;
INTEGER PROCEDURE ELIMOLDLINE(PT,SQ,L); VALUE PT,SQ,L; INTEGER PT,
SQ,L; FORWARD;
INTEGER PROCEDURE STOREAWAY(PT,SQ,B,SEQ); VALUE SEQ;
INTEGER PT,SQ; REAL SEQ; ARRAY B[0]; FORWARD;
PROCEDURE BUFFERCLEAN(BUFFER,BUFFSIZE,ADDR); VALUE BUFFSIZE,
ADDR; REAL ADDR; INTEGER BUFFSIZE; ARRAY BUFFER[0];
FORWARD; COMMENT THIS IS A PHONEY DEAL, BUT I CAN"T
DECLARE CLEANBUFFER FORWARD (MOVE IT UP HERE LATER);
PROCEDURE EDITDRIVER(PT,SQ,I,K); VALUE PT,SQ,I,K;
INTEGER PT,SQ,I,K;
BEGIN ARRAY C,LAB[0:1],OLD,NEW[0:MAXBUFFSIZE];
STREAM PROCEDURE BL(A);
BEGIN DI:=A; MAXBUFFSIZE(DS:=8LIT" ") END;
DEFINE MOVE=MOVEWDS#;
REAL T,SEQ; INTEGER A,B,L,H;
T:=ADDRESS;
FOR A:=I STEP 1 WHILE A LEQ K AND EDITMODE DO
BEGIN B:=CONTENTS(PT,A,C); BL(OLD);
SEQ:=C[0];
B:=CONTENTS(SQ,C[1],OLD);
IF EDITMODE:=WITHINALINE(T,OLD,NEW,BUFFSIZE|8,BUFFSIZE)
THEN BEGIN MOVE(BUFFER,MAXBUFFSIZE+1,NEW);
MOVE(OLD,MAXBUFFSIZE,BUFFER);
IF EDITMODE:=ERR:=OLDLABELCONFICT(PT,C[0])=0 THEN
BEGIN B:=ELIMOLDLINE(PT,SQ,C[1]);
DELTOG:=DELPRESENT(ADDRESS);
DELETE1(SQ,C[1]); DELET1(PT,A+B); C[1]:=
STORESEQ(SQ,BUFFER,LENGTH(BUFFER,FALSE));
STOREORD(PT,C,A+B);
RESCANLINE; L:=0; M:=1; LAB[1]L=C[0];
WHILE LABELSCAN(C,0) DO
BEGIN MOVEWDS(C,1,LAB);
IF (IF FUNCSSIZE=0 THEN TRUE ELSE L:=
SEARCHWROD(PT,C,M,B)NEQ 0) THEN
BEGIN B:=B+1; FUNCSIZE:=FUNCSIZE+1;
STOREORD(PT,ALAR,L+M-1);
END END;
A:=A+B; K:=K+B;
COMMENT THE NEXT LINE CAUSE A SYSTEM CRASH AFTER THE EDIT
IF NOSYNTAX=0 THEN PROCESS(XEQUTE);
END END;
MOVE(NEW,MAXBUFFSIZE+1,BUFFER)
END END;
PROCEDURE LISTLINE(PT,SQ,I); VALUE PT,SQ,I; INTEGER PT,SQ,I;
BEGIN
GT1:=CONTENTS(PT,I,GTA);
INDENT(GTA[0]);
GT1:=CONTENTS(SQ,GTA[1],BUFFER);
CHRCOUNT:=CHRCOUNT-1;
FORMROW(1,0,BUFFER,0,GT1);
END; 090528??P83
INTEGER PROCEDURE DISPLAY(A,B,PT,SQ); VALUE A,B,PT,SQ;
INTEGER PT,SQ; REAL A,B;
IF A LEQ B AND FUNCSIZE NEQ 0 THEN
BEGIN
ARRAY C[0:1];
INTEGER I,J,K;
DEFINE CLEANBUFFER=BUFFERCLEAN#;
A:=LINENUMBER(A); B:=LINENUMBER(B);
C[0]:=A;
I:=SEARCHORD(PT,C,K,8);
I:=( IF I=2 THEN IF K LSS FUNCSIZE-1 THEN K:=K+1 ELSE
K ELSE K);
IF A NEQ B THEN
BEGIN
C[0]:=B; B:=SEARCHORD(PT,C,K,8);
END;
IF EDITMODE THEN % MAY HAVE ONLY ONE LINE TO EDIT
IF I=K THEN
IF A NEQ 0 THEN %NOT EDITING THE HEADER
EDITDRIVER(PT,SQ,I,K);
ELSE %EDITING THE FUNCTION HEADER, FIX LATER.
ERR:=3;
ELSE %EDITING MORE THAN ONE LINE
BEGIN MODE:=EDITING;
IF A=0 THEN I:=I+1;
CLEANBUFFER(BUFFER,BUFFSIZE,ADDRESS);
MOVE(BUFFER,BUFFSIZE,OLDBUFFER);
LOWER:=I; UPPER:=K
END
ELSE %NOT EDITING, MUST BE A LIST
BEGIN
FORMWD(3,"1 ");
IF K=I THEN % LISTING A SINGLE LINE
BEGIN LISTLINE(PT,SQ,I);
FORMWD(3,"1 ");
END ELSE % LISTING A SET OF LINES
BEGIN MODE:=DISPLAYING;
LOWER:=I; UPPER:=K;
END;
END;
EOB:=1;
END ELSE DISPLAY:=20;
INTEGER PROCEDURE DELETE(A,B,PT,SQ); VALUE A,B;
INTEGER PT,SQ; REAL A,B;
IF A LEQ B AND FUNCSIZE NEQ 0 AND A NEQ Q THEN
BEGIN
INTEGER I,J,K,L;
ARRAY C[0:1];
A:=LINENUMBER(B);
B:=LINENUMBER(B);
C[0]:=A;
IF SEARCHOR(PT,C,I,8)=1 THEN I:=I-1;
IF K GTR I OR I GEQ FUNCSIZE THEN DELETE:=21 ELSE
BEGIN
FOR J:=K STEP 1 UNTIL I DO
BEGIN A:=CONTENTS(PT,J,C);
L:=ELIMOLDLINE(PT,SQ,C[1]);
FUNCSIZE:=FUNCSIZE+L; I:=I+L; K:=K+L; J:=J+L;
DELETE1(SQ,C[1])
END;
FUNCSIZE:=FUNCSIZE-(I-K+1)
; EOF:=1;
DELETEN(PT,K,I);
IF FUNCSIZE=0 THEN
BEGIN
PT:=0; RESEASEUNIT(SQ); SQ:=0;
STOREPSR;
END;
END;
END ELSE DELETE:=22;
INTEGER PROCEDURE ELIMOLDLINE(PT,SQ,L); VALUE PT,SQ,L;
INTEGER PT,SQ,L;
BEGIN INTEGER K,J;
REAL AD;
ARRAY T[0:MAXBUFFERSIZE],LAB[0:1];
AD:=ADDRESS;
MOVEWDS(BUFFER,MAXBUFFSIZE+1,T);
INITBUFF(BUFFER,BUFFSIZE);
K:=CONTENTS(SQ,L,BUFFER);
RESCANLINE;
WHILE LABELSCAN(LAB,0) DO 091240??P84
IF SEARCHORD(PT,LAB,K,8)=0 THEN
BEGIN DELETE1(PT,K); J:=J-1 END;
ADDRESS:=AD;
MOVEWDS(T,MAXBUFFSIZE+1,BUFFER);
ELIMOLDLINE:=J
END;
INTEGER PROCEDURE STOREAWAY(PT,SQ,B,SEQ); VALUE SEQ;
INTEGER PT,SQ; REAL SEQ; ARRAY B[0]
BEGIN DEFINE BUFFER=B#;
ARRAY C,LAB[0:1];
INTEGER I,J,K,L;
BOOLEAN TOG;
SEQ:=LINENUMBER(SEQ);
C[0]:=SEQ;
IF TOG:=(PT=0 OR FUNCSIZE=0) THEN
BEGIN SEQUENTIAL(SQ:=NEXTUNIT); I:=0
END ELSE
IF J:=SEARCHORD(PT,C,I,8)=0 THEN
BEGIN
K:=ELIMOLDLINE(PT,SQ,C[1]);
I:=J+K; FUNCSIZE:=FUNCSIZE+K;
DELETE1(PT,T);
FUNCSIZE:=FUNCSIZE-1;
DELETE1(SQ,C[1]);
END ELSE
I:=I+J-1;
RESCANLINE;
DELTOG:=DELPRESENT(ADDRESS);
K:=STORESEQ(SQ,BUFFER,LENGTH(BUFFER,TRUE));
LAB[1]:=SEQ; L:=0; J:=1;
IF TOG THEN PT:=NEXTUNIT;
WHILE LABELSCAN(C,0) DO
BEGIN
MOVEWDS(C,1,LAB);
IF (IF FUNCSIZE=0 THEN TRUE ELSE L:=
SEARCHORD(PT,C,J,8)NEQ 0 ) THEN
BEGIN I:=I+1; FUNCSIZE:=FUNCSIZE+1;
STOREORD(PT,LAB,L+J-1);
END;
END;
C[1]:=K;
C[0]:=SEQ;
FUNCSIZE:=FUNCSIZE+1;
STQOREORD(PT,C,I);
IF TOG THEN STOREPSR;
EOD:=1;
END;
BOOLEAN PROCEDURE BOUND(PT); VALUE PT; INTEGER PT;
IF NOT(BOUND:=NUMERIC) THEN
IF INDENT AND FUNCSIZE GTR 0 THEN
BEGIN ARRAY L[0:1]; INTEGER K;
REAL T,U;
REAL STREAM PROCEDURE CON(A);
VALUE A;
BEGIN SI:=LOC A; DI:=LOC CON; DS:=8OCT
END;
TRANSFER(ACCUM,2,L,1,7);
IF BOUND:=SEARCHORD(PT,L,K,8)=0 THEN
BEGIN T:=ADDRESS;
U:=CON(MAX(L[1],0))/10000; %ARGS AND RESULT ARE NEG
IF SCAN AND PLUS OR MINUS THEN
BEGIN K:=(IF PLUS THEN 1 ELSE -1);
IF SCAN AND NUMERIC THEN
ACCUM[0]:=MAX(U+K|ACCUM[0],0) ELSE
BEGIN ACCUM[0]:=U;
ADDRESS:=T;
END;
END ELSE BEGIN ACCUM[0]:=U; ADDRESS:=T;
END;
EOB:=0;
END;
END;
PROCEDURE FINISHUP;
BEGIN COMMENT GET HIM BACK TO CALCULATOR MODE;
IF FUNCPOINTER=0 THEN % HE DELETED EVERYTHING
BEGIN TRANSFER(PSR,FSTART|8,GTA,0,8);
IF SEARCHORD(VARIABLES,GTA,GT1,7)=0 THEN
BEGIN DELETE1(VARIABLES,GT1);
IF VARSIZE:=VARSIZE-1=0 THEN VARIABLES:=0;
END ELSE SPOUT(9198260);
END; 09198270P85
DELTOG:=CURRENTMODE:=CURLINE:=INCREMENT:=0;
STOREPSR;
END;
LABEL SHORTCUT;
REAL L,U,TADD;
STREAM PROCEDURE CLEANBUFFER(BUFFER,BUFFSIZE,ADDR);
VALUE BUFFSIZE,ADDR;
BEGIN LABEL L; LOCAL T,U,TSI,TDI;
SI:=ADDR; SI:=SI-1; L:
IF SC NEQ "]" THEN
BEGIN SI:=SI-1; GO TO L END;
SI:=SI+1; DI:=LOC T; SKIP 2 DB; DS:=2SET;
DI:=BUFFER; TDI:=DI; DI:=LOC T; TSI:=SI;
BUFFSIZE(8(IF TOGGLE THEN DS:=LIT" " ELSE
IF SC=DC THEN
BEGIN SI:=LOC U; DI:=TDI; DS:=LIT" "
END ELSE
BEGIN TSI:=SI; SI:=SI-1; DI:=LOC U; DS:=CHR;
DI:=TDI; SI:=LOC U; DS:=CHR; TDI:=DI; DI:=LOC T;
SI:=TSI;
END))
END;
PROCEDURE BUFFERCLEAN(BUFFER,BUFFSIZE,ADDR); VALUE BUFFSIZE,
ADDR; REAL ADDR; INTEGER BUFFSIZE; ARRAY BUFFER[0];
CLEANBUFFER(BUFFER,BUFFSIZE,ADDR);
COMMENT DETERMINE WHETHER OR NOT WE CAME FROM CALCULATOR MODE;
ERR:=0;
IF BOOLEAN(SUSPENSION) THEN GO TO ENDHANDLER;
BEGIN DEFINE STARTSEGMENT=#; %///////////////////////////////
IF GT1:=CURRENTMODE=CALCMODE THEN % TAKE CARE OF HEADER.
BEGIN ARRAY A[0:MAXHEADERSARGS];
LABEL HEADERSTORE,FORGETITFELLA;
IF FUNCTIONHEADER(A,TADD) THEN %HEADER OK
IF VARIABLES NEQ 0 THEN % MAY BE A RE-DEFINITION
BEGIN COMMENT GET THE FUNCTION NAME;
TRANSFER(A,1,GTA,0,7);
IF GT2:=SEARCHORD(VARIABLES,GTA,GT3,7)=0 THEN
COMMENT RE-DEFINING A FUNCTION. MAKE SURE NULL ;
IF GETFIELD(GTA,7,1)=FUNCTIUON AND
(A[1]+A[2]+A[3])=0 THEN %NULL HEADER--OK
%--------------------SET UP FOR CONTINUATION OF DEFINITION------
BEGIN
FUNCPOINTER:=GETFIELD(GTA,FPTF,FFL);
FUNCSEQ:=GETFIELD(GTA,FSQF,FFL);
GT3:=CURLINE:=TOPLINE(FPT);
CHECKSEQ(CURLINE,GT3,INC); %SET THE INCREMENT
COMMENT THE CURRENT LINE IS SET TO THE LAST LINE OF THE
FUNCTION;
FUNCSIZE:=SIZE(FPT);
CURLINE:=CURLINE+INC;
DELTOG:=DELPRESENT(ADDRESS);
END ELSE
%------------------REDEFINING THE HEADER OF A DEFINED FUNCTION----
GO TO FORGETITFELLA
ELSE
%--------------------NAME NOT FOUND IN DIRECTORY, SET UP
HEADERSTORE:
BEGIN COMMENT GET THE HEADER TO INSERT AT LINE 0;
ARRAY OLDBUFFER[0:MAXBUFFSIZE];
INTEGER L,U,F,K,J;
INTEGER A1,A2;
COMMENT FUNCTIONHEADER RETURN AN ARRAY WITH THE
FOLLOWING VALUES:
A[0] = FUNCTION NAME , I.E., 0AAAAAAA
A[1] = 0 IF NO RESULT, 1 IF A RESULT IS RETURNED BY THE
FUNCTION.
A[2] = NUMBER OF ARGUMENTS TO THE FUNCTION.
A[3] = NUMBER OF LOCALS + RESULT +ARGUMENTS.
A[4]....A[N] ARE ALL OF THE LOCALS, RESULT, AND ARGUMENTS.
THE RESULT IS FIRST, THEN THE SECOND ARGUMENT, THEN
THE FIRST ARGUMENT, FOLLOWED BY THE LOCALS. ALL
ARE OF THE FORM 0XXXXXXX;
U:=(A1:=A[1])+(A2:=A[2])+3;
FOR L:=4 STEP 1 UNTIL 0 DO %LOOK FOR DUPLICATES AMONG
FOR K:=L+1 STEP 1 UNTIL 0 DO %THE RESULT/ARGUMENT SET
IF A[L]=A[K] THEN GO TO FORGETITFELLA;
SEQUENTIAL(FUNCSEQ:=NEXTUNIT);
SETFIELD(GTA,8,8,STORESEQ(FUNCSEQ,OLDBUFFER,
HEADER(TADD.[1:23],TADD.[24:24],OLDBUFFER)));
SETFIELD(GTA,0,8,0);
STOREORD(F:=FUNCPOINTER:=NEXTUNIT,GTA,0);
SETFIELD(GTA,0,8,0); SETFIELD(GTA,8,8,0); 09229004P86
FOR L:=4 STEP 1 UNTIL U DO
BEGIN GTA[0]:=A[L]; IF A1 GTR 0 THEN
BEGIN A1:=0; GTA[1]:=-1; %"RESULT" SET TO -1
STOREORD(F,GTA,0);
END ELSE %LOOKING AT THE ARGUMENTS
BEGIN K:=SEARCHORD(F,GTA,J,8);
GTA[1]:=A2-4; A2:=A2-1; GTA[0]:=A[L];
STOREORD(F,GTA,J+K-1);
END END;
FUNCSIZE:=U:=U-2; U:=A[3]-U+L;
FOR L:=L STEP 1 UNTIL U DO %GET LOCALS INTO THE LABEL TABLE
BEGIN GTA[0]:=A[L];
IF K:=SEARCHORD(F,GTA,J,8) NEQ 0 THEN %NOT YET IN TABLE.
BEGIN GTA[0]:=A[L]; GTA[1]:=0;
STOREORD(F,GTA,J+K-1);
FUNCSIZE:=FUNCSIZE+1
END;
END;
GTA[1]:=0&ENTIER(A[1])[CRETURN]&ENTIER(A[2])[CNUMBERARGS];
CURLINE:=INCREMENT:=1;
DELTOG:=0;
COMMENT GET THE "TYPE" OF THE FUNCTION LATER WHEN THERE
IS A PLACE FOR IT. THE TYPE IS EITHER 1 (FUNCTION CALL), OR
0 (SUBROUTINE CALL);
END;
%--------------------------------------------------------
END ELSE % VARIABLES=0, MAKE UP A DIRECTORY
BEGIN GT3:=0; GT2:=1; GO TO HEADERSTORE
END
ELSE % HEADER SYNTAX IS BAD
GO TO ENDHANDLER;
COMMENT WE MAKE IT TO HERE IF ALL IS WELL ABOVE;
IF GT2 NEQ 0 THEN %NME NOT FOUND IN DIRECTORY;
BEGIN
TRANSFER(A,1,GTA,0,7); %GET FUNCTION NAME
SETFIELD(GTA,7,1,FUNCTION);
SETFIELD(GTA,FPTF,FFL,FUNCPOINTER);
SETFIELD(GTA,FSQF,FFL,FUNCSEQ);
IF VARIABLES=0 THEN
VARIABLE:=NEXTUNIT;
STOREORD(VARIABLES,GTA,GT3+GT2-1);
VARSIZE:=VARSIZE+1;
END;
CURRENTMODE:=FUNCMODE;
TRANSFER(GTA,0,PSR,FSTART|8,8);
STOREPSR;
IF SCAN THEN GO TO SHORTCUT;
IF FALSE THEN
FORGETITFELLA: ERRORMESS(ERR:=LABELERROR,TADD.[1:23],0);
END ELSE % WE ARE IN FUNCTION DEFINITION MODE
IF GT1:=MODE NEQ 0 THEN % A SPECIAL FUNCTION SUCH AS DISPLAY OR EDIT
BEGIN L:=LOWER;
IF GT1=DISPLAYING THEN
LISTLINE(FPT,FSQ,L) ELSE
IF GT1=EDITING THEN
BEGIN INITBUFF(BUFFER,BUFFSIZE);
MOVE(OLDBUFFER,BUFFSIZE,BUFFER);
EDITMODE:=TRUE; ADDRESS:=ABSOLUTEADDRESS;
EDITDRIVER(FP1,FSQ,L,L)
;IF NOT EDITMODE THEN
BEGIN MODE:=0; ERR:=30
END;
END ELSE
IF GT1=RESEQUENCING THEN
IF GT1:=L LEQ UPPER THEN
BEGIN GT2:=CONTENTS(FPT,L,GTA);
GT3:=GTA[0]:=LINENUMBER(CURLINE);
DELETE1(FPT,L);
STOREORD(FPT,GTA,L);
CURLINE:=CURLINE+INCREMENT;
GT2:=CONTENTS(FSQ,GTA[1],BUFFER); RESCANLINE;
WHILE (IF ERR NEQ 0 THEN FALSE ELSE
LABELSCAN(GTA,0)) FO
IF GT1:=SEARCHORD(FPT,GTA,GT2,8)=0 THEN
BEGIN GTA[1]:=GT3; DELETE1(FPT,GT2);
STOREORD(FPT,GTA,GT2)
END ELSE ERR:=16
END
ELSE MODE:=0;
LOWER:=L+1;
IF LOWER GTR UPPER THEN
BEGIN IF MODE=DISPLAYING THEN
FORMWD(3,"1 "); 092314??P87
MODE:=0;
END;
GO TO ENDHANDLER
END;
END ; % OF BLOCK STARTED EON LINE 9225115 //////////////////
IF ERR=0 AND EOB=0 THEN
SHORTCUT: BEGIN LABEL RGTBRACK,DELOPTION; %//////////////////////////
IF DEDLV THEN FINISHUP ELSE
IF LFTBRACKET THEN
BEGIN
IF SCAN THEN
IF DOUND(FPT) THEN
BEGIN L:=ACCUM[0];
IF SCAN THEN
IF QUDV OR EDITMWODE:=(QUOTEQUAD) THEN
IF SCAN THEN
IF BOUND(FPT) THEN
BEGIN U:=ACCUM[0];
RGTBRACK:
IF SCAN AND RGTBRACKET THEN
IF(IF EDITMODE THEN FALSE ELSE SCAN) THEN
IF DELV THEN
BEGIN ERR:=DISPLAY(L,U,FPT,FSQ);
DELTOG:=1;
END
ELSEERR:=1;
ELSE ERR:=DISPLAY(L,U,FPT,FSQ)
ELSE ERR:=2
END
ELSE
IF RGTBRACKT THEN
IF(IF EDITMODE THEN FALSE ELSE SCAN) THEN
IF DELV THEN
BEGIN ERR:=DISPLAY(L,L,FPT,FSQ);
DELTOG:=1;
END
ELSE ERR:=3
ELSE ERR:=DISPLAY(L,L,FPT,FSQ)
ELSE ERR:=4
ELSE ERR:=5
ELSE
IF RGTBRACKET THEN
BEGIN TADD:=ADDRESS;
IF SCAN THEN
IF IDENT AND ACCUM[0]="ADELETE" THEN
IF SCAN THEN
IF LFTBRACKET THEN
DELOPTION:
IF SCAN AND BOUND(FPT) THEN
BEGIN U:=ACCUM[0];
IF SCAN AND RGTBRACKET THEN
IF SCAN THEN
IF DELV THEN
BEGIN ERR:=DELETE(L,U,FPT,FSQ);
FINISHUP
END
ELSE ERR:=6
ELSE ERR:=DELETE(L,U.FPT,FSQ)
ELSE ERR:=7
END
ELSE ERR:=8
ELSE
IF DELV THEN
BEGIN ERR:=DELETE(L,L,FPT,FSQ);
FINISHUP
END
ELSE ERR:=9
ELSE ERR:=DELETE(L,L,FPT,FSQ)
ELSE
IF LFTBRACKET THEN GO TO DESLOPTION ELSE
BEGIN CHECKSEQ(SEQ,L,INC);
CLEANBUFFER(BUFFER,BUFFSIZE,TADD);
ADDRESS:=ABSADDR(BUFFER); ITEMCOUNT:=0;
IF SCAN THEN GO TO SHORTCUT
END
ELSE ERR:=DELETE(L,L,FPT,FSQ)
END
ELSE ERR:=10
ELSE ERR:=11 09310000P88
END ELSE
IF QUADV OR EDITMODE:=(QUOTEQUAD) THEN
BEGIN L:=0; U:=9999.9999; GO TO RGTBRACK
END ELSE
IF IOTA THEN
IF SCAN AND RGTBRACKET AND FPT NEQ 0 THEN
BEGIN IF SCAN THEN
IF DELV THEN DELTOG:=1; ELSE ERR:=15;
IF ERR == 0 THEN
BEGIN MODE:=RFSEQUENCING; CURLINE:=INCREMENT:=1;
SETFIELD(GTA,0,8,0);
GT1:=SEARCHORD(FPT,GTA,GT2,8);
LOWER:=GTT2+1; UPPER:=FUNCSIZE-1;
END
END
ELSE ERR:=14;
ELSE ERR:=12
ELSE ERR:=13
END
ELSE
IF CURLINE=0 THEN %CHANGING HEADER
ERR:=26 ELSE
IF ERR:=OLDLABCONFLICT(FPT,LINENUMBER(SEQ))=0 THEN
BEGIN
IF NOSYNTAX=0 THEN PROCESS(XEQUTE);
IF ERR:=STOREAWAY(FPT,FSQ,BUFFER,SEQ)=0 THEN SEQ:=SEQ+INC;
END;
IF ERR NEQ 0 THEN
BEGIN FORMWD(2,"5ERROR ");
EOD:=1;
FORMROW(1,1,ACCUM,2,ACCUM[0].[1:11]);
END;
END; %OF BLOCK STARTED ON LINE 9238000 //////////////////////
ENDHANDLER:
IF BOOLEAN(SUSPENSION) THEN BEGIN
FILL ACCUM[*] WITH "ABORT SU", "SP. FNS.";
FORMROW(3,0,ACCUM,0,16); INDENT(0); TERPRINT;
END ELSE
IF MODE=0 THEN
BEGIN
IF BOOLEAN(DELTOG) THEN FINISHUP;
INDENT(-CURLINE); TERPRINT;
END;
END;
EXPOVR:=FAULTL; INTOVR:=FAULTL; INDEXF:=FAULTL;
FLAG:=FAULTL; ZERO:=FAULTL;
INITIALIZETABLE;
TRYAGAIN:
IF FALSE THEN %ENTERS WITH A FAULT.
FAULTL:
BEGIN SPOUT(09334300); %SEND MESSAGE TO SPO
BEGIN CSTATION.APLOGGED:=0; CSTATION.APLHEADING:=0
END
END;
APLMONITOR;
ENDOFJOB:
FINIS:
WRAPUP;
END.
END;END. LAST CARD ON OCRDING TAPE
TOTAL LOGICAL RECORDS= 7273
END OF JOB.
Reference in New Issue View Git Blame Copy Permalink