mirror of
https://github.com/retro-software/B5500-software.git
synced 2026-02-09 17:11:18 +00:00
1466 lines
56 KiB
Plaintext
1466 lines
56 KiB
Plaintext
BEGIN 00000490
|
|
% 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 KINDALL, 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; 00001550
|
|
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."), 00002970
|
|
("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 DEIGNATED 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 WRITTER 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; 00003750
|
|
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 00004690
|
|
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
|
|
;
|
|
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;
|
|
IF MEMBUG.[21:1] THEN DUMPMEMORY(MODE,TYPE,N,M); 00005620
|
|
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 00006370
|
|
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]; 00007270
|
|
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;
|
|
M:=0; END; 08015888 P78
|
|
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 MASSAGEHANDLER;
|
|
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);
|
|
08017970 P80
|
|
%-----------------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:=GETFILED(GTA,7,1)=FUNCTION THEN
|
|
BEGIN
|
|
RELEASEUNIT(GETFIELD(GTA,FPTF,FFL));
|
|
RELEASEUNIT(GETFILED(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 COMAMND,CHAR,WORD; INTEGER COMMAND,CHAR,WORD;
|
|
ARRAY OLD, NEWEDIT; BEGIN
|
|
BOOLEAN STREAM PROCEDURE WITHINLINE(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; NEWJLINE:=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; 09003000 P82
|
|
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;
|
|
OLLABELCONFLICT:=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 NOSYTNATX=0 THE 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(VARIABSLES,GTA,GT1,7)=0 THEN
|
|
BEGIN DELETE1(VARIABLES,GT1);
|
|
IF VARSIZE:=VARSIZE-1=0 THEN VARIABLES:=0;
|
|
END ELSE SPOUT(9198260);
|
|
END; 09198270 P85
|
|
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 TOGGKLE 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 DIRECTWORY, 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, FOLL7OWED 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)));
|
|
SETFILED(GTA,0,8,0);
|
|
STOREORD(F:=FUNCPOINTER:=NEXTUNIT,GTA,0);
|
|
SETFIELD(GTA,0,8,0); SETFIELD(GTA,8,8,0); 09229004 P86
|
|
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;
|
|
O 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);
|
|
FINSIHUP
|
|
END
|
|
ELSE ERR:=9
|
|
ELSE ERR:=DELETE(L,L,FPT,FSQ)
|
|
ELSE
|
|
IF LFTBRACKET TEHN 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 09310000 P88
|
|
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 TEHN
|
|
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 LOGIICAL RECORDS= 7273
|
|
END OF JOB.
|