diff --git a/source/APL/IMAGE.alg_m b/source/APL/IMAGE.alg_m index 97d20e2..8299300 100644 --- a/source/APL/IMAGE.alg_m +++ b/source/APL/IMAGE.alg_m @@ -1,7273 +1,7278 @@ -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 GIA[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,F,I); 00016200 - IF I GTR 0 THEN 00016300 - BEGIN 00016400 - INTEGER GT1,GT2,GT3; 00016500 - MEMORY(10,GT1,GIA,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 MOVEALOG= 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;DT:=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 T,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) LESS 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 SEARCH(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 LESS 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 - B: 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 - DISPLAYIMG=1#, 00132600 - EDITING=2#, 00132700 - DELETING=3#, 00132800 - RESEQUECING=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,EDB,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 TOOGLE 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,RL,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 - MANLEN:=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 TOOGLE 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 -OK: 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 OTHEN 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 RGTPRENV 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 DTOP=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=RGTBRACKTV 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,RGTPARVN,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 - ERRMESS(ERR:=SYNTAXERROR,OPERATORS[TOTP].ADDRFIELD 00263000 - ,0); 00263100 - IF J NEQ 0 THEN 00263200 - BEGIN L:=L+1; 00263300 - SP[LOC]:=OPERAORS[OTOP] 00263400 - END; OPTOP:=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 QUADLFTARRW 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:=PCD; 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 - SEARCHWORD(VARIABLES,GTA,GT1,7)=0) THEN 00268300 - BEGIN 00268400 - SP[LOC].TYPEFILED:=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 MAXPROGS 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:=(IOLDROW+1)|SPRSIZE; 00273900 - L:=(OLDROW+1)|SPRSIZE; 00274000 - END; 00274100 - SP[LOC].LEN:=K; SP[JLOC].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:=LWOCATE; 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&DPNSW[CDID]&LASTCUONSTANT[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 - LASTCONTANT:=L; 00281200 - END 00281300 - 00281400 - END; 00281500 - OWN INTEGER OLDATA,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);VALUUEL,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 DESCRIPTOT.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 DUO 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; 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:=T 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:=FINDIZE(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 FORGETSPZE(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|S,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 - BEGINVARIABLES:=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,OLDDES); K:=1; 00297800 - IF (IF VARSIZE=0 THEN FALSE ELSE 00297900 - K:=SEARCHORD(VARIABLES,NEWDESC,J,7)=0) 00298000 - THEN BEGIN 00298100 - K:=CONTENTS(VARAIBLES,J,OLDDESC); 00298200 - DELETE1(VARAIBLES,J); 00298300 - IF GETFILED(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[MROC]:=D; 00301800 - END; 00301900 - PROCEDURE SCRATCHAIN(L); VALUE L; INTEGER L; 00302000 - BEGIN 00302100 - REAL R; 00302200 - WHILE L NEW 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 - DL:=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 - OWNINTEGER FUNCLOC,POLLOC,LASTMKS,POLTOP,CINDEX; 00304900 - PROCEDURE STEPLINE(LABELED); VALUE LABELED; 00305000 - BOOLEAN LABELED; 00305100 - 00305200 - BEGIN 00305300 - LABEL ENDFUNC,TERMINATE,DONE; 00305400 - LABEL BUMBLINE; 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 (FUNCLUOC,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 - ROSTORELOCALS(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 BOOLEN((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:=I-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) DIO; %CLEAR LABELS 00311500 - IF BOOLEAN(EOB) THEN % AN EMPTY LINE--BUMP POINTER 00311600 - BEGIN M:=BASE;LABELED:=FALSE;GT 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;NN:=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 GQO 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+SYTACKBASE; %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,T+OP,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 - BOOLEN 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],PRIOGRESS[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,VALUW,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:=SIZEL|(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[NQOC],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 - SEND 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].BACLP; 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 ESLSE %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 BOQOLEAN(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 TEHN 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(S.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 - LASKMKS:=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-INESIZE 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)|T)+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 I 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 TRANSFERR(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 N; 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+SACKBASE); CINDEX:=1; 00354000 - END; 00354100 - SETUPLINE:=TRUE; 00354200 - END ELSE SETUPLINE:=FALSE; 00354300 - END; 00354400 -BOOLEAN PROCEDURE POPPROGRAM(OLDATA,LASTMKS); 00354500 - REAL OLDDATA,LASTMKS; 00354600 - BEGIN LABEL EXIT;REAL L,M,N; 00354700 - WHILE TRUE DO 00354800 - BEGIN 00354900 - WHILE(L:=AREG).DATADEAC NEQ 0 AND ERR=0 DO POP; 00355000 - IF L.DTD=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[MOX].SPF+1;N:=SP[MOC].SPF+M; 00356300 - IF BOOLEAN(SP[NOC].SUSPENDED) THEN BEGIN SP[MOX].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,R,N); VALUE N; 00364700 - BEGIN LOCAL T; 00364800 - SI:=LOC N; D:=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:=MAXBUUFFSIZE 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 := (R-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 ND OP LSS 21 THEN IF NOT BOOLTYPE(REFT,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 - ELS 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:=DOMAINERR; 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+RANK; 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 MAXWORDSIZE 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]:=SM[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:=DOMAINERRPOR; 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 BEGIN 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 FORGETSPZE(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 DP; 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.ID := 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 := GESTAPCES(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 INDENT; 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 := GESPACE(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 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 BOOLEN(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:=DESC.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 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.DIF := 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 REDUC 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 - DEX.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 FO 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[CTYPE]&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 NEW 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)+1.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] NNEQ 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 - ARFG:=0&4094[CCIF]&(LASKMKS-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 BOOLAN(T:=AREG).PRESENCE) AND T.SPF NEQ 0 THEN 00533200 - OLDDATA:=CHAIN(T,OLDATA); 00533300 - M:=T.LOCFIELD; 00533400 - 00533500 - IF(RESUT:=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(D.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 GOTO 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 - BEFIN 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.DF:=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 AN 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 - EFLSE 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 - SCRATCHCHAIN(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 O=(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 O 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:=BLIT(" "); 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 I; 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(D,"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 - GOTOEXEC; 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 CALULATE,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,EOLDBUFFER); 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 - POECESS(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,TST; 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 SI="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:=ADDRSS; 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:=8; 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,MD,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 TIME2=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,R,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,R); 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 VARSRSIZE 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 - PR:=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].INTPTR=0 THEN % NULL VECTOR 00613700 - GOTO 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 - STORESPR; 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|READL(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 LIBNAME(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 - LOADWORKSPCE(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(LINSIZE, 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 - ELTMWORKSPACE(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 - NUMBERCRON(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 GIT1:=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 - SEARCHWORD(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 RCHR:=SI; SI:=OLD; OLDLINE:=SI; 00663700 - DI:=NEW; NEWLINE:=DI; SI:=RCHR; 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:=OLDLABELCONFICT(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 Q 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:MAXBUFFERSIZE],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 INDENT 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 RGTBRACKT 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:=RFSEQUENCING; CURLINE:=INCREMENT:=1; 00721900 - SETFIELD(GTA,0,8,0); 00722000 - GT1:=SEARCHORD(FPT,GTA,GT2,8); 00722100 - LOWER:=GTT2+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 +?COMPILE APL/NEW ALGOL LIBRARY +?ALGOL STACK=1000 +?DATA CARD +$ CARD LIST SINGLE +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,F,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,RDTL,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, RDTL, 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 +RDTL: 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 OUT 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 FIRST ROW 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:=T 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 OUT 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 (FUNCLUOC,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,VALUW,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)|T)+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 I 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 AN 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 LASTMKS 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 +? END