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