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.