BEGIN 00000490 % THIS APL/B5500 PROGRAM WAS DEVELOPED BY THE COMPUTER SCIENCE GROUP 00000500 % AT THE UNIVERSITY OF WASHINGTON UNDER THE SPONSORSHIP OF PROFESSOR 00000510 % HELLMUT GOLDE. THE PROGRAM MAY NOT BE OFFERED FOR SALE OR LEASE 00000520 % IN ITS ORIGINAL OR ANY MODIFIED FORM. ANY PUBLICATION RELATING TO 00000530 % THIS PROGRAM OR ANY MODIFICATION OF THE PROGRAM MUST EXPLICITLY CREDIT00000540 % THE COMPUTER SCIENCE GROUP OF THE UNIVERSITY OF WASHINGTON AND THE 00000550 % PRINCIPAL IMPLEMENTORS, GARY KILDALL, LEROY SMITH, SALLY SWEDINE, 00000560 % AND MARY ZOSEL. COMPUTER RESOURCES FOR THE DEVELOPMENT OF THE 00000570 % PROGRAM WERE MADE AVAILABLE BY THE UNIVERSITY OF WASHINGTON COMPUTER 00000580 % CENTER. 00000590 DEFINE VERSIONDATE="3-05-71 "#; 00000600 %MODIFICATIONS FOR B-5500 TIME-SHARING MCP MADE BY: 00000601 % JOSE HERNANDEZ, BURROUGHS CORPORATION. 00000602 BOOLEAN BREAKFLAG; 00000609 ARRAY GTA[0:1]; 00000610 LABEL FINIS; %GO THERE WHEN YOU ARE IN TROUBLE (SPOUT A MESSAGE) 00000630 BOOLEAN PROCEDURE LIBRARIAN(A,B); VALUE A,B; REAL A,B; FORWARD; 00000700 LABEL FAULTL; %FAULT LABEL 00000800 MONITOR EXPOVR,INTOVR,INDEX:=INDEXF,FLAG,ZERO; 00000810 REAL BIGGEST, NULLV; 00000900 INTEGER STACKSIZE,LIBSIZE; 00001000 REAL STATUSWORD,CORELOC; 00001100 BOOLEAN RETURN; 00001110 BOOLEAN MEMBUG,DEBUG; 00001120 COMMENT MEMBUG SWITCHES ---------------------- 00001130 BIT FUNCTION BIT FUNCTION 00001140 ----------------------------------------------------------------- 00001150 1 25 00001160 2 26 00001170 3 27 00001180 4 28 00001190 5 DUMP TYPES @ INSERT 30 00001200 6 DUMP TYPES @ DELETE 30 00001210 7 31 00001220 8 32 00001230 9 33 00001240 10 34 00001250 11 35 00001260 12 36 00001270 13 37 00001280 14 38 00001290 15 39 00001300 16 40 00001310 17 41 00001320 18 42 00001330 19 43 00001340 20 DUMP INDEX 44 00001350 21 45 00001360 22 DUMP TYPES 46 00001370 23 CHECK TYPES 47 00001380 24 DUMP BUFFER #S 00001390 ; 00001400 FILE PRINT 4 "SYSTEMS" " BOX " (1,15); 00001410 FILE TWXIN 19(2,30),TWXOUT 19(2,9); 00001415 % 00001416 DEFINE 00001420 PAGESIZE=120#, 00001430 AREASIZE=40#, 00001440 CF=[26:13]#, COMMENT COUNT FIELD -- NUMBER OF ITEMS ON PAGE; 00001450 TF=[39:9] #, COMMENT T-FIELD (TYPE FIELD); 00001460 FF=[9:1]#, COMMENT FULL FIELD FOR SEQUENTIAL STORAGE; 00001465 AF=[1:23] #, COMMENT A-FIELD; 00001470 BF=[24:23]#, COMMENT B-FIELD; 00001480 MF=[1:1]#, COMMENT METHOD OF STORAGE FIELD; 00001490 SF=[13:13]#, COMMENT SEQUENTIAL STORAGE SIZE FIELD (#CHRS); 00001500 BOOL=[47:1]#, 00001510 SKIP=1#, COMMENT --AMOUNT OF SPACE RESERVED AT THE 00001520 START OF EACH PAGE; 00001530 ALLOWANCE=10#, COMMENT --DEVIATION FROM THE AVERAGE PAGE SIZE 00001540 ALLOWED BEFORE CORRECTION; 00001550 RECSIZE=2#, 00001560 MAXPAGES=20#, 00001570 PAGESPACE=20#, 00001580 NEXTP=[42:6]#, 00001590 LASTP=[36:6]#, 00001600 PAGEF=[19:11]#, 00001610 BUFF=[12:6]#, 00001620 CHANGEDBIT=[1:1]#, 00001630 MBUFF=8#, 00001640 SBUFF=4#, 00001650 FLAGB=[18:1]#, COMMENT FLAG BIT FOR BUFFER MAINTENANCE; 00001660 EXTRAROOM=1#, 00001670 LIBJOB="/APLIBE"#,%MFID FOR APL SYSTEM FILE 00001675 ENDOFDEFINES=#; 00001680 REAL PROCEDURE CDR(X); VALUE X; REAL X; CDR:=X.NEXTP; 00001690 PROCEDURE RPLACD(X,Y); VALUE Y;REAL X,Y; X.NEXTP:=Y; 00001710 BOOLEAN PROCEDURE NULL(X); VALUE X; REAL X; NULL:=X.NEXTP=0; 00001730 BOOLEAN STREAM PROCEDURE EOFMARK(SK,RS,A); VALUE SK,RS; 00001740 BEGIN LABEL NO; SI:=A; SK(SI:=SI+8); 00001750 RS(8( 2(IF SB THEN JUMP OUT 3 TO NO; SKIP SB); 00001760 3(IF SB THEN SKIP SB ELSE JUMP OUT 3 TO NO); IF SB THEN 00001770 JUMP OUT 2 TO NO; SKIP SB));TALLY:=1;EOFMARK:=TALLY; 00001780 NO: 00001790 END; 00001800 STREAM PROCEDURE MARKEOF(SK,RS,A); VALUE SK,RS; 00001810 BEGIN DI:=A; 00001820 SK(DI:=DI+8); 00001830 RS(8(DS:=2RESET; DS:=3SET; DS:=RESET)); 00001840 END; 00001850 SAVE FILE ESTABLISH DISK [MAXPAGES:AREASIZE] 00001860 (1,PAGESIZE,SAVE 100); 00001870 FILE NEWDISK DISK (1,PAGESIZE); 00001880 FILE DISK1 DISK (1,PAGESIZE), 00001890 DISK2 DISK (1,PAGESIZE), 00001900 DISK3 DISK (1,PAGESIZE), 00001910 DISK4 DISK (1,PAGESIZE), 00001920 DISK5 DISK (1,PAGESIZE), 00001930 DISK6 DISK (1,PAGESIZE), 00001940 DISK7 DISK (1,PAGESIZE), 00001950 DISK8 DISK (1,PAGESIZE); 00001960 SWITCH FILE POINTERS:=DISK1,DISK1,DISK2,DISK3,DISK4,DISK5,DISK6,DISK7, 00001970 DISK8; 00001980 PROCEDURE SETPOINTERNAMES; 00002600 BEGIN 00002610 IF NOT LIBRARIAN(LIBJOB,TIME(-1)) THEN 00002650 BEGIN 00002660 WRITE(ESTABLISH); 00002670 MARKEOF(SKIP,RECSIZE,ESTABLISH(0)); 00002680 WRITE(ESTABLISH[1]); 00002690 WRITE(ESTABLISH[MAXPAGES|AREASIZE-1]); 00002700 LOCK(ESTABLISH); 00002710 CLOSE(ESTABLISH) 00002720 ;LIBSIZE~-1; 00002721 END 00002730 END; 00002740 DEFINE 00002750 LIBMAINTENANCE=0#, 00002760 MESSDUM=#; 00002770 PROCEDURE MEMORY(MODE,TYPE,A,N,M);VALUE MODE,TYPE; 00002780 INTEGER MODE,TYPE,N,M; ARRAY A[0]; FORWARD; 00002790 STREAM PROCEDURE MOVE(A,N,B); VALUE N; 00002792 BEGIN SI:=A; DI:=B; DS:=N WDS; 00002794 END; 00002796 PROCEDURE MESSAGE(I); VALUE I; INTEGER I; 00002800 BEGIN 00002810 FORMAT F("MEMORY ERROR",I5); 00002820 COMMENT CHANGE LINE 3050 TO WRITE(PRINT,SF[I]) FOR MEMORY ERROR PROBS. 00002825 THIS FORMAT IS NOW EXCLUDED SINCE MEMORY IS SEEMINGLY WELL DEBUGED 00002826 SWITCH FORMAT SF:= 00002830 ("LIBRARY MAINTENANCE IN PROGRESS."), 00002840 ("SYSTEM ERROR--MEMORY ACCESS WITH EXPRESSION FOR N OR M."), 00002850 ("SYSTEM ERROR--IMPROPER ARGUMENTS TO FREEPAGE."), 00002860 ("SYSTEM ERROR--TOO LARGE A SUBSCRIPT FOR TYPE SPECIFIED."), 00002870 ("SYSTEM ERROR--TYPE CANNOT BE ZERO WHEN INSERTING OR DELETING."), 00002880 ("SYSTEM ERROR--CHARACTER STRING TOO LONG TO STORE."), 00002890 ("SYSTEM ERROR--ATTEMPT TO INSERT NON-SEQUENTIAL ELEMENT", 00002900 "IN TYPE A STORAGE."), 00002910 ("SYSTEM ERROR--NO BLANKS IN PAGES."), 00002920 ("SYSTEM ERROR--ATTEMPTED BINARY SEARCH OF UNORDERED DATA."), 00002930 ("SYSTEM ERROR--BINARY SEARCH OF UNALLOCATED DATA ATTEMPTED."), 00002940 ("SYSTEM ERROR--BINARY SEARCH FOUND A BLANK PAGE."), 00002950 ("SYSTEM ERROR--DELETION OF TYPE B STORAGE NOT IMPLEMENTED."), 00002960 ("SYSTEM ERROR--ATTEMPT TO DELETE FROM NON-EXISTENT STORAGE."), 00002970 ("SYSTEM ERROR--ATTEMPT TO DELETE RECORD FROM OUTSIDE", 00002980 " ALLOCATED STORAGE."), 00002990 ("SYSTEM ERROR--ATTEMPTED MEMORY SEARCH WITH -N- TOO LARGE."), 00003000 ("SYSTEM ERROR--ATTEMPT TO CHANGE PREVIOUSLY DESIGNATED STORAGE", 00003010 " KIND"), 00003020 ("SYSTEM ERROR--POINTERS TO DATA TYPES OVERLAP."), 00003030 (" "); 00003040 WRITE(PRINT,F,I); 00003050 IF I GTR 0 THEN 00003060 BEGIN 00003070 INTEGER GT1,GT2,GT3; 00003075 MEMORY(10,GT1,GTA,GT2,GT3); 00003082 GO TO FINIS; 00003084 END; 00003090 END; 00003100 PROCEDURE MEMORY(MODE,TYPE,A,N,M); VALUE MODE,TYPE; 00003102 INTEGER MODE,TYPE,N,M; ARRAY A[0]; 00003104 BEGIN 00003106 DEFINE T64= DI:=LOC T; DI:=DI+1; DS:=7 CHR#; 00003110 STREAM PROCEDURE WRITERECS(PAGE,A,SKP,NB,NR,NS,RL); 00003120 VALUE SKP,NB,NR,NS,RL; 00003130 BEGIN 00003140 COMMENT -- NS IS THE NUMBER OF WORDS TO SAVE (ON THE 00003150 TAIL OF THE PAGE); 00003160 LOCAL T,T1,T2,TT; 00003170 COMMENT -- MOVE TO POSITION FOR WRITE; 00003180 SI:=LOC NB; T64; SI:=PAGE; SKP(SI:=SI+8); 00003190 T(2(32(RL(SI:=SI+8)))); NB(RL(SI:=SI+8)); 00003200 T1:=SI; COMMENT -- RECORDS WILL BE WRITTEN HERE; 00003210 COMMENT -- SKIP OVER TO END OF RECORDS TO BE SAVED; 00003220 DI:=LOC TT; SI:=LOC NS; DI:=DI+1; DS:=7CHR; 00003230 SI:=T1; COMMENT MOVE TO THE END OF THE FIELD TO BE SAVED; 00003240 TT(2(32(RL(SI:=SI+8)))); NS(RL(SI:=SI+8)); 00003250 T2:=SI; COMMENT -- END OF FIELD TO BE SAVED; 00003260 SI:=LOC NR; T64; DI:=T2; 00003270 T(2(32(RL(DI:=DI+8)))); NR(RL(DI:=DI+8)); 00003280 SI:=T2; SI:=SI-8; DI:=DI-8; 00003290 TT(2(32(RL(DS:=WDS; SI:=SI-16; DI:=DI-16)))); 00003300 NS(RL(DS:=WDS; SI:=SI-16; DI:=DI-16)); 00003310 COMMENT -- HAVE ACCOMPLISHED THE "SAVE", NOW DO THE WRITE; 00003320 SI:=A; DI:=T1; 00003330 T(2(32(DS:=RL WDS))); NR(DS:=RL WDS) 00003340 END; 00003350 STREAM PROCEDURE READRECS(PAGE,A,SKP,NB,NR,NM,RL); 00003360 VALUE SKP,NB,NR,NM,RL; 00003370 BEGIN 00003380 COMMENT 00003390 SKP = "SKIP" - - THE NUMBER OF WORDS TO JUMP OVER 00003400 NB = "NUMBER BEFORE" -- " " RECORDS TO SKIP BEFORE 00003410 READING THE RECORD, 00003420 NR = "NUMBER OF RECORDS" " " " " READ FROM THE 00003430 BUFFER, 00003440 NM ="NUMBER TO MOVE" - - " " " " MOVE OVER TO 00003450 THE PREVIOUSLY READ AREA, 00003460 RL ="RECORD LENGTH" - - THE LENGTH OF EACH ITEM 00003470 ; 00003480 LOCAL T,T1,T2; 00003490 SI:=LOC NB; T64; SI:=PAGE; SKP(SI:=SI+8); 00003500 T(2(32(RL(SI:=SI+8)))); NB(RL(SI:=SI+8)); 00003510 T1:=SI; 00003520 COMMENT - - T1 NOW HAS THE STARTING POSITION FOR THE READ; 00003530 SI:=LOC NR; T64; SI:=T1; DI:=A; 00003540 T(2(32(DS:=RL WDS))); NR(DS:=RL WDS); 00003550 T2:=SI; COMMENT T2 CONTAINS THE END OF THE READ; 00003560 SI:=LOC NM; T64; SI:=T2; DI:=T1; 00003570 T(2(32(DS:=RL WDS))); NM(DS:=RL WDS) 00003580 END READRECS; 00003590 DEFINE MOVEALONG= 00003600 DI:=LOC C; DI:=DI+6; DS:=2CHR; DI:=LOC Z; 00003610 TSI:=SI; TALLY:=TALLY+1; 00003620 IF TOGGLE THEN 00003630 BEGIN SI:=LOC C; SI:=SI+6; 00003640 IF 2 SC NEQ DC THEN 00003650 BEGIN TAL:=TALLY; SI:=LOC TAL; SI:=SI+7; 00003660 IF SC="0" THEN 00003670 BEGIN TALLY:=TMP; TALLY:=TALLY+1; TMP:=TALLY; 00003680 TALLY:=0; 00003690 END ELSE 00003700 BEGIN SI:=LOC Z; IF SC LEQ"9" THEN ; 00003710 END 00003720 END ELSE 00003730 BEGIN DI:=TDI; SI:=LOC SIZE; SI:=SI+6; DS:=2CHR; 00003740 TDI:=DI; SI:=SI-2; DI:=LOC C64; DI:=DI+7 ; DS:=CHR; 00003750 SI:=NEW; DI:=TDI; C64(2(DS:=32CHR)); DS:=SIZE CHR; 00003760 TDI:=DI; SI:=TSI; DI:=LOC C; DI:=DI+6; 00003770 DS:=2CHR; TSI:=SI; 00003780 TALLY:=TAL;CHRSTORE:=TALLY; SI:=LOC TMP; SI:=SI+7; 00003790 DI:=LOC CHRSTORE; DI:=DI+6; DS:=CHR END 00003800 END; 00003810 SI:=LOC C; DI:=LOC C64; DI:=DI+1; DS:=7CHR; DI:=TDI; SI:=SI-1; 00003820 DS:=2CHR; SI:=TSI; 00003830 C64(2(DS:=32CHR)); DS:=C CHR; TDI:=DI; TSI:=SI#; 00003840 INTEGER STREAM PROCEDURE CHRSTORE(A,SKP,B,NEW,NB,SIZE,NA,MODE, 00003850 PAGESIZE); VALUE SKP,NB,SIZE,NA,MODE,PAGESIZE; 00003860 BEGIN LOCAL T,C,TSI,TDI, 00003870 Z,C64,TMP,TAL; 00003880 LABEL DONE; 00003890 SI:=LOC NB; T64; 00003900 SI:=LOC MODE; SI:=SI+7; 00003910 IF SC="0" THEN ; COMMENT SET TOGGLE; 00003920 SI:=A; DI:=B; SKP(DS:=8CHR); 00003930 TSI:=SI; TDI:=DI; 00003940 T(2(32(MOVEALONG))); NB(MOVEALONG); 00003950 COMMENT NOW HAVE MOVED UP TO NB; 00003960 IF TOGGLE THEN 00003970 BEGIN TALLY:=TAL; CHRSTORE:=TALLY; SI:=LOC TMP; SI:=SI+7; 00003980 DI:=LOC CHRSTORE; DI:=DI+6; DS:=CHR; 00003990 SI:=LOC SIZE; SI:=SI+6; DI:=TDI; DS:=2CHR; TDI:=DI; 00004000 SI:=LOC SIZE; DI:=LOC C64; DI:=DI+1; DS:=7CHR; SI:=NEW; 00004010 DI:=TDI; C64(2(DS:=32CHR)); DS:=SIZE CHR; 00004020 END ELSE 00004030 BEGIN TSI:=SI; TDI:=DI; 00004040 SI:=LOC MODE; SI:=SI+7; 00004050 IF SC="1" THEN 00004060 COMMENT REMOVE AN ENTRY HERE; 00004070 BEGIN DI:=LOC C; DI:=DI+6; SI:=TSI; DS:=2CHR; 00004080 TSI:=SI; DI:=LOC C64; DI:=DI+1; SI:=LOC C; 00004090 DS:=7CHR; SI:=TSI; C64(2(SI:=SI+32)); SI:=SI+C; 00004100 TSI:=SI; DI:=LOC CHRSTORE; SI:=LOC C; DS:=WDS; 00004110 DI:=TDI; DS:=2LIT"0"; TDI:=DI; 00004120 END ELSE 00004130 IF SC="2" THEN 00004140 COMMENT READ OUT AN ENTRY; 00004150 BEGIN DI:=LOC C; DI:=DI+6; SI:=TSI; DS:=2CHR; 00004160 TSI:=SI; DI:=LOC C64; DI:=DI+1; SI:=LOC C; 00004170 DS:=7CHR; SI:=TSI; DI:=NEW; 00004180 C64(2(DS:=32CHR)); DS:=C CHR; 00004190 SI:=LOC C; DI:=LOC CHRSTORE; DS:=WDS; GO DONE END; 00004200 SI:=LOC NA; T64; SI:=TSI; DI:=TDI; 00004210 T(2(32(TDI:=DI; DI:=LOC C; DI:=DI+6; DS:=2CHR; 00004220 TSI:=SI; SI:=LOC C; DI:=LOC C64; DI:=DI+1; DS:=7CHR; 00004230 SI:=SI-1;DI:=TDI;DS:=2CHR;SI:=TSI;C64(2(DS:=32CHR));DS:=C CHR))); 00004240 NA( TDI:=DI; DI:=LOC C; DI:=DI+6; DS:=2CHR; TSI:=SI; 00004250 SI:=LOC C;DI:=LOC C64;DI:=DI+1;DS:=7CHR;SI:=SI-1; 00004260 DI:=TDI;DS:=2CHR;SI:=TSI;C64(2(DS:=32CHR));DS:=C CHR); 00004270 END; 00004280 SI:=LOC PAGESIZE; T64; SI:=B; DI:=A; 00004290 %CARD LIST UNSAFE 00004300 COMMENT $CARD LIST UNSAFE; 00004310 T(2(DS:=32WDS)); DS:=PAGESIZE WDS; 00004320 %CARD LIST SAFE 00004330 COMMENT $CARD LIST SAFE; 00004340 DONE: 00004350 END; 00004360 STREAM PROCEDURE SETNTH(P,K,N); VALUE K,N; 00004390 BEGIN DI:=P; SI:=LOC K; N(DI:=DI+8); DS:=WDS END; 00004400 BOOLEAN STREAM PROCEDURE LESS(A,AN,B,BN,K); VALUE K,AN,BN; 00004410 BEGIN 00004420 SI:=A; DI:=B; SI:=SI+AN; DI:=DI+BN; 00004430 IF K SC LSS DC THEN TALLY:=1; 00004440 LESS:=TALLY 00004450 END; 00004460 REAL STREAM PROCEDURE ADDD(A,B); VALUE A,B; 00004470 BEGIN SI:=LOC A; DI:=LOC B; DS:=8ADD; SI:=LOC B; 00004480 DI:=LOC ADDD; DS:=WDS 00004490 END; 00004500 INTEGER PROCEDURE FREEPAGE(INDEX,TYPEZERO,START,FINISH); 00004600 VALUE TYPEZERO,START,FINISH; INTEGER TYPEZERO,START,FINISH; 00004610 ARRAY INDEX[0,0]; 00004620 IF START GTR FINISH THEN MESSAGE(2) ELSE 00004630 BEGIN ARRAY T[0:RECSIZE+EXTRAROOM+SKIP-1],P[0:FINISH-START]; 00004640 INTEGER I,J,K,R; 00004650 R:=RECSIZE+EXTRAROOM+SKIP; 00004660 J:=START-(FINISH+1); 00004670 FOR I:=FINISH STEP -1 UNTIL TYPEZERO DO 00004680 IF K:=(I+J) LSS TYPEZERO THEN 00004690 BEGIN T[R-1]:=P[TYPEZERO-K-1]; 00004700 MOVE(T,R,INDEX[I,0]) 00004710 END ELSE 00004720 BEGIN IF I GEQ START THEN P[FINISH-I]:=INDEX[I,R-1]; 00004730 MOVE(INDEX[K,0],R,INDEX[I,0]); 00004740 END; 00004750 FREEPAGE:=TYPEZERO-J; 00004760 END; 00004770 INTEGER PROCEDURE SEARCHL(A,B,N,MIN,MAX,NP); VALUE N,MIN,MAX; 00004780 INTEGER N,MIN,MAX,NP; 00004790 ARRAY A[0,0]; REAL B; 00004800 BEGIN 00004810 INTEGER I,T; 00004820 FOR I:=MIN STEP 1 WHILE T:=T+A[I,0].CF LEQ B AND I LSS MAX-1 DO; 00004830 IF T LSS B THEN 00004840 BEGIN MESSAGE(3); SEARCHL:=NP:=0; 00004850 END ELSE 00004860 BEGIN SEARCHL:=I; NP:=B-T+A[I,0].CF 00004870 END 00004880 END; 00004890 PROCEDURE SORT(A,P,N,C); VALUE P,N,C; INTEGER P,N,C; 00004900 ARRAY A[0,0]; 00004910 BEGIN INTEGER R; 00004920 BEGIN 00004930 ARRAY T[0:R:=RECSIZE+EXTRAROOM+SKIP-1]; 00004940 LABEL ENDJ; 00004950 INTEGER I,J,L,K,M,SK; R:=R+1; 00004960 SK:=SKIP TIMES 8; 00004970 K:=N-P+1; I:=1; DO UNTIL (I:=I TIMES 2) GTR K; 00004980 M:=I-1; 00004990 WHILE (M:=M DIV 2) NEQ 0 DO 00005000 BEGIN K:=N-M; J:=P; 00005010 DO BEGIN 00005020 L:=(I:=J)+M; 00005030 DO BEGIN 00005040 IF A[L,0].TF GTR A[I,0].TF THEN GO ENDJ; 00005050 IF A[L,0].TF EQL A[I,0].TF THEN 00005060 IF NOT(LESS(A[L,0],SK,A[I,0],SK,C)) THEN 00005070 GO ENDJ; 00005080 MOVE(A[L,0],R,T); MOVE(A[I,0],R,A[L,0]); 00005090 MOVE(T,R,A[I,0]) 00005100 END UNTIL (I:=(L:=I)-M) LSS P; 00005110 ENDJ: 00005120 END UNTIL (J:=J+1) GTR K; 00005130 END 00005140 END 00005150 END SORT; 00005160 COMMENT - - - - - - - - - - - - - - - - - - - - - - - - - - 00005280 MODE MEANING 00005290 ---- ------- 00005300 1 = INTERROGATE TYPE 00005310 2 = INSERT RECORD REL ADDRS N 00005320 (RELATIVE TO START OF LAST PAGE) 00005330 3 = RETURN THE NUMBER OF RECORDS (M) 00005340 4 = " ITEM AT RECORD # N 00005350 5 = INSERT " " " " " 00005360 6 = DELETE " " " " " 00005370 7 = SEARCH FOR THE RECORD -A- 00005380 8 = FILE OVERFLOW, INCREASE BY N 00005390 9 = FILE MAINTENANCE 00005400 10 = EMERGENCY FILE MAINTENANCE 00005410 11 SET STORAGE KIND 00005420 12= ALTER STORAGE ALLOCATION RESOURCES 00005430 13= RELEASE "TYPE" STORAGE TO SYSTEM 00005440 14= CLOSE ALL PAGES FOR AREA TRANSITION 00005450 NOTE THAT WHEN SEQUENTIAL STORAGE MAINTENANCE IS DONE, N 00005460 WILL ALWAYS INDICATE THE ADDRESS OF THE STRING RELATIVE TO 00005470 THE TYPE SPECIFIED, AND M WILL ALWAYS BE THE LENGTH OF THE 00005480 STRING IN -A- (EITHER AS INPUT OR OUTPUT) 00005490 ; 00005500 PROCEDURE UPDATE(T,L,U,D); VALUE L,U,D; INTEGER L,U,D; 00005510 ARRAY T[0]; 00005520 BEGIN INTEGER I,J,K; 00005530 FOR I:=L STEP 1 UNTIL U DO 00005540 BEGIN J:=T[I].AF+D; T[I].AF:=J; 00005550 J:=T[I].BF+D; T[I].BF:=J 00005560 END 00005570 END; 00005580 OWN INTEGER CURPAGE,NPAGES,NTYPES,P,PS,U,L; 00005590 OWN INTEGER FIRST,AVAIL,MAXBUFF,CURBUFF; 00005600 REAL GT1; 00005605 LABEL MOREPAGES; 00005610 COMMENT 00005615 IF MEMBUG.[21:1] THEN DUMPMEMORY(MODE,TYPE,N,M); 00005620 IF MODE=8 THEN NPAGES:=NPAGES+N; 00005630 MOREPAGES: 00005670 BEGIN 00005680 OWN BOOLEAN POINTERSET, TYPESET; 00005690 INTEGER I, T, NR; 00005693 OWN ARRAY BUF[0:MBUFF], TYPS[0:511]; 00005697 OWN ARRAY INDX[0:NPAGES,0:RECSIZE+EXTRAROOM+SKIP-1]; 00005700 PROCEDURE SETTYPES; 00005702 BEGIN INTEGER I, T; 00005704 FOR I := 0 STEP 1 UNTIL NPAGES DO 00005706 IF INDX[I,0].TF NEQ T THEN 00005708 BEGIN 00005710 TYPS[T].BF := I; TYPS[T:=INDX[I,0].TF].AF := I; 00005712 TYPS[T].BOOL := INDX[I,0].MF; 00005714 END; 00005716 TYPS[T].BF := I; 00005718 END SETTYPES; 00005720 REAL PROCEDURE BUFFNUMBER(I); VALUE I; INTEGER I; 00005730 BEGIN INTEGER K,L,M; 00005740 LABEL D; 00005750 DEFINE B=BUF#; 00005760 IF( IF K:=INDX[I,P].BUFF=0 THEN TRUE ELSE BUF[K].PAGEF 00005770 NEQ INDX[I,P].PAGEF+1) THEN 00005780 BEGIN IF NULL(K:=CDR(AVAIL)) THEN 00005790 BEGIN K:=CDR(FIRST); 00005800 WHILE M:=CDR(B[K]) NEQ 0 DO 00005810 BEGIN L:=K; K:=M; END; 00005820 RPLACD(B[L],0); 00005830 IF BOOLEAN(B[K].CHANGEDBIT) THEN 00005840 WRITE(POINTERS[K][B[K].PAGEF-1]); 00005850 B[K].CHANGEDBIT:=0; 00005860 END ELSE RPLACD(AVAIL,CDR(B[K])); 00005870 B[K].PAGEF:=INDX[I,P].PAGEF+1; 00005880 INDX[I,P].BUFF:=K; 00005890 READ(POINTERS[K][INDX[I,P].PAGEF]); 00005900 END ELSE 00005910 IF CDR(FIRST)=K THEN GO TO D ELSE 00005920 BEGIN L:=CDR(FIRST); 00005930 WHILE M:=CDR(B[L]) NEQ K DO L:=M; 00005940 RPLACD(B[L],CDR(B[M])); 00005950 END; 00005960 RPLACD(B[K],CDR(FIRST)); RPLACD(FIRST,K); 00005970 D: BUFFNUMBER:=K 00005980 END; 00005990 PROCEDURE MARK(I); VALUE I; INTEGER I; 00006000 BUF[INDX[I,P].BUFF].CHANGEDBIT:=1; 00006010 BOOLEAN PROCEDURE WRITEBUFFER; 00006020 BEGIN INTEGER I; 00006030 I:=CDR(FIRST); 00006040 WHILE NOT NULL(I) DO 00006050 IF BOOLEAN(BUF[I].CHANGEDBIT) THEN 00006060 BEGIN WRITEBUFFER:=TRUE; 00006070 BUF[I].CHANGEDBIT:=0; 00006080 WRITE(POINTERS[I][BUF[I].PAGEF-1]); 00006090 RPLACD(I,0); 00006100 END ELSE I:=CDR(BUF[I]); 00006110 END; 00006120 IF NOT POINTERSET THEN 00006130 BEGIN LABEL EOF; 00006140 READ(POINTERS[1][NPAGES])[EOF]; 00006150 IF EOFMARK(SKIP,RECSIZE,POINTERS[1](0))THEN GO TO EOF; 00006160 MOVE(POINTERS[1](0),1,T); 00006170 COMMENT -- USE T TO DETERMIN THE VARIABLE REC SIZE LATER; 00006180 MOVE(POINTERS[1](0),RECSIZE+SKIP,INDX[NPAGES,0]); 00006190 INDX[NPAGES,RECSIZE+1].PAGEF:=NPAGES; 00006200 NPAGES:=NPAGES+1; 00006210 GO TO MOREPAGES; 00006220 COMMENT - - INTIALIZE VARIABLES; 00006230 EOF: POINTERSET:=TRUE; 00006240 U:=PAGESIZE-SKIP-PAGESPACE; 00006250 L:=(U-ALLOWANCE)/RECSIZE; 00006260 U:=(U+ALLOWANCE+RECSIZE/2)/RECSIZE; 00006270 PS:=(U+L)/2; 00006280 CURPAGE:=NPAGES:=NPAGES-1; 00006290 CURBUFF:=1; 00006300 P:=RECSIZE+SKIP; 00006310 FOR T:=1 STEP 1 UNTIL SBUFF DO RPLACD(BUF[T],T+1); 00006320 RPLACD(BUF[SBUFF],0); RPLACD(AVAIL,1); 00006330 MAXBUFF:=SBUFF; 00006340 T:=0; 00006350 SORT(INDX,0,NPAGES,RECSIZE TIMES 8); 00006360 FOR I:=0 STEP 1 UNTIL NPAGES DO 00006370 IF INDX[I,0].TF GTR T THEN T:=INDX[I,0].TF; 00006380 NTYPES:=T; 00006390 END; 00006400 IF TYPE GTR NTYPES THEN NTYPES:=TYPE; 00006410 IF NOT TYPESET THEN 00006550 BEGIN TYPESET:=TRUE; SETTYPES; 00006560 COMMENT 00006565 IF MEMBUG THEN DUMPINDEX(TYPS,NTYPES,INDX,RECSIZE, 00006570 P); 00006580 END; 00006590 COMMENT --- DECIDE WHETHER TO SAVE CURRENT PAGE BEFORE GOING ON; 00006600 IF MODE=2 THEN 00006610 BEGIN MODE:=5; NR:=N 00006620 END ELSE 00006630 IF MODE GEQ 4 THEN %MAY BE FILE MAINTENANCE 00006640 IF MODE GEQ 8 THEN %IS FILE MAINTENANCE 00006650 ELSE %WE MAY BE GOING TO 00006660 IF MODE NEQ 7 THEN %ANOTHER PAGE 00006670 BEGIN 00006680 IF TYPE=0 THEN BEGIN MESSAGE(4); MODE:=0 END ELSE 00006690 IF TYPS[TYPE].AF=TYPS[TYPE].BF THEN 00006700 IF TYPS[0].BF GTR 0 THEN 00006710 BEGIN INTEGER J,K; REAL PG; 00006720 K:=TYPS[0].BF-1; TYPS[0].BF:=K; PG:=INDX[K,P]; 00006730 FOR I:=1 STEP 1 UNTIL TYPE-1 DO 00006740 IF (T:=TYPS[I]).AF NEQ T.BF THEN 00006750 BEGIN FOR K:=T.AF STEP 1 UNTIL T.BF -1 DO 00006760 MOVE(INDX[K,0],P+EXTRAROOM,INDX[K-1,0]); 00006770 TYPS[I].AF:=T.AF-1; TYPS[I].BF:=K:=T.BF-1 00006780 END; 00006790 IF CURPAGE GTR TYPS[0].BF THEN 00006800 IF CURPAGE LEQ K THEN CURPAGE:=CURPAGE-1; 00006810 TYPS[TYPE].BF:=K+1; TYPS[TYPE].AF:=K; 00006820 INDX[K,P]:=PG; INDX[K,0]:=0; INDX[K,0].TF:=TYPE; 00006830 IF TYPS[TYPE].BOOL=1 THEN 00006840 BEGIN SETNTH(INDX[K,0],0,1); INDX[K,0].MF:=1 00006850 END; 00006860 COMMENT 00006865 IF MEMBUG.[22:1] THEN DUMPTYPES(MODE,TYPS,NTYPES); 00006870 MEMORY(MODE,TYPE,A,N,M); MODE:=0 00006880 END ELSE 00006890 BEGIN T:=1; MEMORY(8,TYPE,A,T,M); MEMORY(MODE,TYPE,A,N,M); 00006900 MODE:=0 00006910 END ELSE 00006920 IF NOT( BOOLEAN(TYPS[TYPE].BOOL) AND MODE=5) THEN 00006930 CURBUFF:=BUFFNUMBER(CURPAGE:= 00006940 SEARCHL(INDX,N,NPAGES,TYPS[TYPE].AF,TYPS[TYPE].BF, 00006950 NR) ); 00006960 COMMENT 00006965 IF MEMBUG.[23:1] THEN CHECKTYPES(TYPS,NTYPES); 00006970 END; 00006980 COMMENT 00006985 IF MEMBUG.[20:1] THEN DUMPINDEX(TYPS,NTYPES,INDX,RECSIZE,P); 00006990 COMMENT 00006995 IF MEMBUG.[24:1] THEN DUMPBUFF(BUF,FIRST,AVAIL); 00007000 CASE MODE OF 00007010 BEGIN 00007020 %------- MODE=0 ------- RESERVED --------------- 00007030 ; 00007040 %------- MODE=1 ----------------------------------------------------00007050 IF M=0 THEN N:=TYPS[TYPE].BOOL ELSE 00007060 IF M=1 THEN 00007070 BEGIN FOR I:=1 STEP 1 UNTIL NTYPES DO 00007080 IF (T:=TYPS[I]).AF=T.BF THEN 00007090 BEGIN N:=I; I:=NTYPES+1 00007100 END; 00007110 IF I=NTYPES+1 THEN N:=NTYPES+1 00007120 END; 00007130 %------- MODE=2 ------- RESERVED --------------- 00007140 ; 00007150 %------- MODE=3 ------- RETURN THE NUMBER OF RECORDS---- 00007160 BEGIN COMMENT IF TYPE LSS 0 THEN THE TOTAL NUMBER 00007170 OF PAGES IS GIVEN, OTHERWISE THE NUMBER OF "TYPE" PAGES IS 00007180 GIVEN; 00007190 FOR I:=0 STEP 1 UNTIL NPAGES DO 00007200 IF INDX[I,0].TF=TYPE OR TYPE LSS 0 THEN 00007210 NR:=NR+INDX[I,0].CF; 00007220 M:=NR 00007230 END; 00007240 %------- MODE=4 ------- RETURN ITEM AT SUBSCRIPT N ----- 00007250 IF NR GEQ INDX[CURPAGE,0].CF THEN MESSAGE(3) ELSE 00007252 IF BOOLEAN(TYPS[TYPE].BOOL) THEN COMMENT SEQUENTIAL STORAGE; 00007260 BEGIN ARRAY B[0:PAGESIZE]; 00007270 M:=CHRSTORE(POINTERS[CURBUFF](0),2,B,A,NR,0,0,2,0); 00007280 END ELSE 00007290 BEGIN 00007300 M:=RECSIZE|8; 00007310 READRECS(POINTERS[CURBUFF](0),A,SKIP,NR,1,0,RECSIZE); 00007320 END; 00007330 %------- MODE=5 ------- INSERT ITEM AT SUBSCRIPT N; 00007340 BEGIN INTEGER K,J,S; REAL PG; 00007350 IF BOOLEAN(TYPS[TYPE].BOOL) THEN 00007360 COMMENT FIND A PLACE FOR THE CHARACTER STRING OF LENGTH 00007370 M; 00007380 IF M GTR (PAGESIZE-SKIP-1)|8-2 THEN MESSAGE(5) COMMENT 00007390 THIS CHARACTER STRING IS TOO LONG ; ELSE 00007400 BEGIN ARRAY C[0:PAGESIZE]; 00007410 STREAM PROCEDURE ADDZERO(CHARS,POINTER); VALUE CHARS; 00007411 BEGIN LOCAL T; 00007412 SI:=LOC CHARS; DI:=LOC T; DI:=DI+1; DS:=7CHR; 00007413 DI:=POINTER; T(2(DI:=DI+32)); CHARS(DI:=DI+1); 00007415 DS:=2LIT"0"; 00007417 END; 00007419 BOOLEAN B,NOTLASTPAGE; 00007420 LABEL TRYITAGAIN; 00007425 TRYITAGAIN: 00007426 FOR I:=(T:=TYPS[TYPE]).AF STEP 1 WHILE I LSS T.BF AND 00007430 NOT B DO 00007440 IF NOT(B:=((PAGESIZE-SKIP-1)|8-(GT1:=INDX[I,0]).SF)GEQ M+2 00007450 AND NOT BOOLEAN(GT1.FF)) THEN S:=S+GT1.CF ELSE I:=I-1; 00007460 NOTLASTPAGE:=B AND I NEQ T.BF-1; 00007465 COMMENT IF B IS TRUE, THEN A PAGE HAS BEEN FOUND; 00007470 IF NOT B THEN COMMENT GET A PAGE THAT IS FREE; 00007480 BEGIN 00007490 COMMENT 00007495 IF MEMBUG.[5:1] THEN DUMPTYPES(5.1,TYPS,NTYPES); 00007500 IF TYPS[0].BF=0 THEN BEGIN K:=CURPAGE; T:=1; 00007510 MEMORY(8,TYPE,A,T,M); CURPAGE:=K+1 00007520 END 00007524 ELSE 00007526 IF (PAGESIZE-SKIP-1)|8-INDX[(I:=I-1)-1,0].SF GTR 2 THEN 00007528 BEGIN 00007529 CURBUFF:=BUFFNUMBER(CURPAGE:=I-1); 00007530 ADDZERO((GT1:=INDX[CURPAGE,0].SF)+8|(SKIP+1),POINTERS 00007531 [CURBUFF](0)); 00007532 INDX[CURPAGE,0].SF:=GT1+2; 00007533 INDX[CURPAGE,0].CF:=INDX[CURPAGE,0].CF+1; 00007534 COMMENT SINCE ALLOCATING A NEW PAGE, SET COUNT TO 00007535 ONE MORE AND FREEZE THE COUNT; 00007536 S:=S+1; % SINCE THE COUNT INCREASED 00007538 MOVE(INDX[CURPAGE,0],SKIP+1,POINTERS[CURBUFF](0)); 00007540 MARK(CURPAGE); 00007542 END; 00007544 T:=TYPS[0].BF; TYPS[0].BF:=T:=T-1; 00007546 COMMENT T IS THE SUBSCRIPT INTO THE NEW PAGE; 00007550 PG:=INDX[T,P]; COMMENT PG HOLDS THE NEW PAGE #; 00007560 FOR K:=T+1 STEP 1 UNTIL I DO 00007570 MOVE(INDX[K,0],RECSIZE+SKIP+EXTRAROOM,INDX[K-1,0]); 00007580 T:=TYPS[TYPE].AF; TYPS[TYPE].AF:=T-1; 00007590 INDX[I,P]:=PG; UPDATE(TYPS,1,TYPE-1,-1); 00007600 IF CURPAGE GTR TYPS[0].BF THEN IF CURPAGE LEQ 00007610 I THEN CURPAGE:=CURPAGE-1; 00007620 INDX[I,0]:=0; INDX[I,0].MF:=1; INDX[I,0].TF:=TYPE; 00007630 COMMENT MUST ALSO ASSIGN A NUMBER TO THIS PAGE 00007640 (TO BE STORED IN THE PAGE) TO KEEP IT IN SEQUENCE 00007650 WITHIN THIS TYPE; 00007660 IF (T:=TYPS[TYPE]).AF LSS T.BF-1 THEN 00007670 T:=INDX[T.BF-1,1] ELSE T:=0; 00007680 SETNTH(INDX[I,0],ADDD(1,T),1); 00007690 COMMENT END OF THE INITIALIZATION OF THE INDEX ARRAY, 00007700 WE STILL HAVE TO MAKE SOME ENTRIES INTO THE PAGE 00007710 WHICH WE WILL DO BELOW; 00007720 END OF TEST FOR NEW PAGE; 00007730 COMMENT I IS SET TO THE PROPER SUBSCRIPT FOR THE CHR STORE; 00007740 CURBUFF:=BUFFNUMBER(CURPAGE:=I); 00007750 COMMENT NOW THE CORRECT PAGE IS IN CORE. 00007760 ------------------------------ 00007770 M= NUMBER OF CHARACTERS IN A (ON INPUT) 00007780 N= ADDRESS OF A WITHIN THIS TYPE (ON OUTPUT 00007790 ------------------------------; 00007800 K:=INDX[I,0]; 00007810 T:=CHRSTORE(POINTERS[CURBUFF](0),SKIP+1,C,A,K.CF,M,0,0, 00007820 PAGESIZE); 00007830 COMMENT K.CF IS THE NUMBER OF ITEMS ALREADY IN THIS 00007840 PAGE. IF THERE IS A SEGMENT WHICH IS NULL, IT WILL 00007850 BE FOUND AND ASSIGNED AS THE SEG NUMBER FOR 00007860 THIS CHARACTER STRING (T). IF NOT, IT WILL STICK THE 00007870 STRING ON THE END (WE KNOW THERE IS ENOUGH ROOM 00007880 SINCE WE CHECKED INDX[I,0].SF -- THE NUMBER OF CHRS USED 00007890 IN THIS PAGE, OR WE CREATED A NEW PAGE); 00007900 N:=S+T; S:=K.SF; COMMENT S CONTAINS THE # OF CHRS USED UP; 00007910 IF T:=T+1 GTR K.CF THEN COMMENT ADDED THE STRING ON THE END; 00007920 IF NOTLASTPAGE THEN % PAGE ALREADY FULL 00007922 BEGIN S:=0; B:=FALSE; INDX[I,0].FF:=1; 00007925 MOVE(INDX[I,0],SKIP+1,POINTERS[CURBUFF](0)); 00007926 MARK(CURPAGE); GO TRYITAGAIN; END ELSE 00007927 BEGIN K.CF:=T; S:=S+2; 00007930 END 00007940 ELSE IF T=K.CF AND NOTLASTPAGE THEN INDX[I,0].FF:=1; 00007945 00007947 INDX[I,0].CF:=K.CF; INDX[I,0].SF:=S+M; 00007950 MOVE(INDX[I,0],SKIP+1,POINTERS[CURBUFF](0)); 00007960 MARK(CURPAGE); 00007970 COMMENT THE PAGE DESCRIPTOR HAS BEEN UPDATED; 00007980 COMMENT 00007985 IF MEMBUG.[5:1] THEN DUMPTYPES(5.2,TYPS,NTYPES); 00007990 END ELSE COMMENT KIND OF STORAGE IS SORTED; 00008000 IF NR GTR (T:=INDX[CURPAGE,0].CF) THEN 00008010 COMMENT SUBSCRIPT IS NOT IN THE MIDDLE OF THE PAGE; 00008020 MESSAGE(6) ELSE 00008030 BEGIN 00008040 IF T GEQ U THEN COMMENT WILL EXCEED UPPER PAGE BOUND; 00008050 BEGIN ARRAY B[0:RECSIZE TIMES 00008060 (T-PS+(I:=(IF NR GEQ PS THEN 0 ELSE 1)))-1]; 00008070 COMMENT B IS JUST BIG ENOUGH TO CARRY THE 00008080 EXCESS FROM THE OLD PAGE; 00008090 READRECS(POINTERS[CURBUFF](0),B,SKIP,PS-I, 00008100 J:=(T-PS+I),0,RECSIZE); 00008110 COMMENT -- B NOW HAS THE EXCESS; 00008120 INDX[CURPAGE,0].CF:=T-J; SETNTH(POINTERS[CURBUFF](0), 00008130 INDX[CURPAGE,0],0); 00008140 MARK(CURPAGE); 00008150 IF TYPS[0].BF=0 THEN 00008160 BEGIN K:=CURPAGE; T:=1; 00008170 MEMORY(8,TYPE,A,T,M); CURPAGE:=K+1; 00008180 END; 00008190 COMMENT -- ASSIGN A FREE PAGE (SUBS T); 00008200 T:=TYPS[0].BF; TYPS[0].BF:=T:=T-1; 00008210 00008220 PG:=INDX[T,P]; 00008230 FOR K:=T+1 STEP 1 UNTIL CURPAGE DO 00008240 MOVE(INDX[K,0],RECSIZE+SKIP+EXTRAROOM,INDX[K-1,0]); 00008250 INDX[CURPAGE,P]:=PG; 00008260 T:=0;T.CF:=J;T.TF:=TYPE; 00008262 CURBUFF:=BUFFNUMBER(CURPAGE); 00008270 WRITERECS(POINTERS[CURBUFF](0),B,SKIP,0,J,0,RECSIZE); 00008280 SETNTH(POINTERS[CURBUFF](0),T,0); 00008290 MOVE(POINTERS[CURBUFF](0),RECSIZE+SKIP,INDX[CURPAGE,0]); 00008300 MARK(CURPAGE); 00008310 T:=TYPS[TYPE].AF; TYPS[TYPE].AF:=T-1; 00008320 UPDATE(TYPS,1,TYPE-1,-1); 00008330 IF J=0 THEN MESSAGE(7); 00008340 IF BOOLEAN (I) THEN 00008350 COMMENT I=0 IMPLIES THE RECORD GOES TO NEW PAGE, 00008360 I=1 IMPLIES THE RECORD GOES TO NOOLD PAGE; 00008370 BEGIN 00008380 T:=INDX[CURPAGE:=CURPAGE-1,0].CF; 00008390 CURBUFF:=BUFFNUMBER(CURPAGE); 00008400 ; COMMENT OLD PAGE IS NOW BACK; 00008410 END ELSE 00008420 BEGIN T:=J; NR:=NR-PS 00008430 END 00008440 END; 00008450 WRITERECS(POINTERS[CURBUFF](0),A,SKIP,NR,1,T-NR,RECSIZE); 00008460 T:=INDX[CURPAGE,0].CF; INDX[CURPAGE,0].CF:=T+1; 00008470 SETNTH(POINTERS[CURBUFF](0),INDX[CURPAGE,0],0); 00008480 IF NR=0 THEN MOVE(POINTERS[CURBUFF](0),RECSIZE+SKIP,INDX 00008490 [CURPAGE,0]); MARK(CURPAGE); 00008500 END; 00008510 END; 00008520 %------- MODE=6 ------- DELETE A RECORD FROM THE FILE ---- 00008530 IF (T:=TYPS[TYPE]).AF=T.BF THEN MESSAGE(12) COMMENT 00008540 ATTEMPT TO DELETE NON-EXISTENT STORAGE; 00008550 ELSE 00008560 IF NR GEQ(I:=INDX[CURPAGE,0].CF) THEN MESSAGE(13) COMMENT 00008570 ATTEMPT TO DELETE OUTSIDE STORAGE RANGE; ELSE 00008580 IF BOOLEAN(T.BOOL) THEN COMMENT SEQUENTIAL STORAGE; 00008590 BEGIN COMMENT NR IS THE RECORD TO DELETE; 00008600 ARRAY B[0:PAGESIZE-1]; 00008610 COMMENT PAGESIZE -1 SHOULD BE COMPUTED TO THE EXACT 00008620 NUMBER OF WORDS TO MOVE -- IT WOULD SPEED THINGS UP; 00008630 INTEGER L; 00008640 T:=INDX[CURPAGE,0]; COMMENT T.CF IS THE NUMBER OF 00008650 RECORDS ON THIS PAGE, T.SF IS THE NUMBER OF CHRS; 00008660 L:=CHRSTORE(POINTERS[CURBUFF](0),SKIP+1,B,A,NR,0,T.CF 00008670 -NR-1,1,PAGESIZE); 00008680 COMMENT WE WILL BRING BACK THE NUMBER OF CHRS IN M; 00008690 M:=L; 00008700 MARK(CURPAGE); 00008710 COMMENT MAKE CHANGES TO THE CHARACTER COUNT; 00008720 INDX[CURPAGE,0].SF:=T.SF-L; 00008730 INDX[CURPAGE,0].FF:=0; % PAGE IS CERTAINLY NOT FULL NOW 00008737 COMMENT AND WE ARE DONE WITH THE DELETION; 00008740 MOVE(INDX[CURPAGE,0],SKIP+1,POINTERS[CURBUFF](0)); 00008745 END 00008750 ELSE 00008760 BEGIN ARRAY A[0:RECSIZE-1]; 00008770 INDX[CURPAGE,0].CF:=I-1; 00008780 SETNTH(POINTERS[CURBUFF](0),INDX[CURPAGE,0],0); 00008790 IF I GTR 1 THEN 00008800 BEGIN 00008810 READRECS(POINTERS[CURBUFF](0),A,SKIP,NR,1,I-NR-1,RECSIZE); 00008820 MARK(CURPAGE); 00008830 IF NR=0 THEN 00008840 MOVE(POINTERS[CURBUFF](0),RECSIZE+SKIP,INDX[CURPAGE,0]) 00008850 END ELSE COMMENT FREE THE EMPTY PAGE; 00008860 BEGIN MARK(CURPAGE); 00008870 ;TYPS[0].BF:=FREEPAGE(INDX,TYPS[0].BF,CURPAGE,CURPAGE); 00008880 UPDATE(TYPS,1,TYPE-1,1); TYPS[TYPE].AF:=T.AF+1; 00008890 COMMENT 00008895 IF MEMBUG.[6:1] THEN DUMPTYPES(MODE,TYPS,NTYPES); 00008900 END 00008910 END; 00008920 %------- MODE=7 ------- SEARCH FOR A RECORD FROM THE FILE --- 00008930 IF N GTR 3 THEN MESSAGE(14) ELSE 00008940 COMMENT RETURN RECORD CLOSEST (BUT LESS THAN OR EQUAL TO) TO 00008950 THE CONTENTS OF -A-. A WILL BE REPLACED BY THE RECORD FOUND; 00008960 IF BOOLEAN((I:=TYPS[TYPE]).BOOL) THEN 00008970 MESSAGE(8) COMMENT BINARY SEARCH OF NON-SEQUENTIAL DATA; 00008980 ELSE 00008990 IF I.AF=I.BF THEN MESSAGE(9) COMMENT --NO STORAGE OF 00009000 THIS TYPE ALLOCATED AS YET; 00009010 ELSE BEGIN 00009020 INTEGER F,U,L; 00009030 ARRAY B[0:RECSIZE-1]; 00009040 U:=TYPS[TYPE].BF; L:=TYPS[TYPE].AF; 00009050 WHILE U-L GTR 1 DO 00009060 IF LESS(A,0,INDX[F:=(U+L) DIV 2,0],8,M) THEN U:=F ELSE L:=F; 00009070 CURBUFF:=BUFFNUMBER(CURPAGE:=L); 00009080 L:=0; U:=INDX[CURPAGE,0].CF; 00009090 IF L-U=0 THEN MESSAGE(10) COMMENT BINARY SEARCH FOUND 00009100 A PAGE WITH NO RECORDS; 00009110 ELSE BEGIN 00009120 WHILE U-L GTR 1 DO 00009130 BEGIN READRECS(POINTERS[CURBUFF](0),B,SKIP, 00009140 F:=(U+L) DIV 2,1,0,RECSIZE); 00009150 IF LESS(A,0,B,0,M) THEN U:=F ELSE L:=F 00009160 END; 00009170 COMMENT ----------------------------------- 00009180 ON INPUT: 00009190 N=0 IMPLIES DO NOT PLACE RECORD INTO FILE 00009200 IF RECORD IS FOUND. RETURN RELA- 00009210 TIVE POSITION OF THE CLOSEST RECORD 00009220 IN THIS PAGE. 00009230 N=1 " DO NOT PLACE IN FILE. RETURN ABSO- 00009240 LUTE SUBSCRIPT OF CLOSSEST RECORD. 00009250 N=2 " PLACE RECORD INTO FILE IF NOT FOUND. 00009260 RETURN RELATIVE POSITION OF RECORD. 00009270 N=3 " PLACE RECORD INTO FILE, IF NOT 00009280 FOUND, RETURN ABS SUBSCRIPT OF 00009290 THE RECORD. 00009300 ON OUTPUT: 00009310 M=0 " RECORD FOUND WAS EQUAL TO RECORD 00009320 SOUGHT. 00009330 M=1 " RECORD FOUND WAS GREATER THAN THE 00009340 SOUGHT. 00009350 M=2 " RECORD FOUND WAS LESS THAN THE 00009360 RECORD SOUGHT. 00009370 ; 00009380 READRECS(POINTERS[CURBUFF](0),B,SKIP,L,1,0,RECSIZE); 00009390 IF LESS(A,0,B,0,M) THEN M:=1 ELSE 00009400 IF LESS(B,0,A,0,M) THEN M:=2 ELSE 00009410 M:=0; 00009420 T:=0; IF BOOLEAN(N) THEN 00009430 FOR I:=TYPS[TYPE].AF STEP 1 UNTIL CURPAGE-1 DO 00009440 T:=T+INDX[I,0].CF; 00009450 IF N GTR 1 THEN IF M GEQ 1 THEN 00009460 MEMORY(2,TYPE,A,L+M-1,NR); 00009470 MOVE(B,RECSIZE,A); 00009480 N:=T+L; 00009490 END 00009500 END; 00009510 %------- MODE=8 ------- FILE OVERFLOW, FIX ARRAYS AND PAGES 00009520 BEGIN BOOLEAN TOG; 00009530 ARRAY A[0:PAGESIZE-1]; T:=NPAGES-N+1; 00009540 IF TOG:=(T DIV AREASIZE) LSS (NPAGES DIV AREASIZE ) OR 00009550 (T=NPAGES AND T MOD AREASIZE =0) THEN 00009560 MEMORY(14,TYPE,A,N,M); 00009570 FOR I:=T STEP 1 UNTIL NPAGES DO 00009580 BEGIN WRITE(NEWDISK[I],PAGESIZE,A[*]);INDX[I,P].PAGEF:=I END; 00009590 MARKEOF(SKIP,RECSIZE,NEWDISK(0)); 00009600 WRITE(NEWDISK[I]); 00009610 TYPS[0].BF:=FREEPAGE(INDX,TYPS[0].BF,T,NPAGES); 00009620 UPDATE(TYPS,1,NTYPES,NPAGES-T+1); 00009630 IF TOG THEN CLOSE(NEWDISK); 00009640 END; 00009650 %------- MODE=9 ------- FILE MAINTENANCE ------------------ 00009660 BEGIN BOOLEAN ITHPAGEIN; 00009670 INTEGER I,J,K,T1,T2,T3,M,W,Q; 00009680 ARRAY A,B[0:PAGESIZE-1]; 00009690 COMMENT 00009700 MONITOR PRINT(Q,W,N, I,J,K,T1,T2,T3,M,A,B); 00009710 IF I:=TYPS[0].BF LEQ NPAGES THEN 00009720 DO 00009730 BEGIN COMMENT OUTER "DO-LOOP" TO FIND TROUBLE WITH 00009740 THE FILE; 00009750 IF T1:=(Q:=INDX[I,0]).CF LSS L THEN COMMENT MAY BE CORRECTABLE; 00009760 IF NOT BOOLEAN((Q:=TYPS[Q.TF]).BOOL) THEN 00009770 COMMENT -- THIS PAGE IS CORRECTABLE; 00009780 IF I NEQ NPAGES THEN 00009790 COMMENT -- THIS IS NOT THE LAST PAGE OF THE FILE; 00009800 IF (J:=I+1) LSS Q.BF THEN 00009810 COMMENT -- THIS IS NOT THE LAST PAGE OF THIS TYPE; 00009820 BEGIN COMMENT -- FIND RECORDS TO MOVE INTO 00009830 THIS PAGE; 00009840 DO IF T2:=INDX[J,0].CF GTR 0 THEN 00009850 COMMENT THIS PAGE HAS RECS TO MOVE; 00009860 BEGIN COMMENT HOW MANY; 00009870 IF T2 LSS K:=PS-T1 THEN K:=T2; 00009880 IF NOT ITHPAGEIN THEN 00009890 BEGIN COMMENT BRING IN PAGE I; 00009900 MOVE(POINTERS[BUFFNUMBER(I)](0), 00009910 PAGESIZE,B); ITHPAGEIN:=TRUE 00009920 END; 00009930 COMMENT -- BRING IN PAGE J; 00009940 CURBUFF:=BUFFNUMBER(CURPAGE:=J); 00009950 COMMENT -- MOVE SOME INTO A; 00009960 READRECS(POINTERS[CURBUFF](0),A,SKIP,0,K, 00009970 T2:=T2-K,RECSIZE); INDX[J,0].CF:=T2; 00009980 IF T2=0 THEN 00009990 COMMENT SET THIS PAGE FREE; 00010000 INDX[J,0]:=0; 00010010 SETNTH(POINTERS[CURBUFF](0),INDX[J,0],0); 00010020 MOVE(POINTERS[CURBUFF](0),RECSIZE+SKIP,INDX[J 00010030 ,0]); MARK(CURPAGE); 00010040 COMMENT -- PUT THE RECORDS INTO PAGE I; 00010050 WRITERECS(B,A,SKIP,T1,K,0,RECSIZE); 00010060 END 00010070 ELSE K:=0 COMMENT SINCE NO CONTRI- 00010080 BUTION; 00010090 UNTIL T1:=T1+K GEQ PS OR J:=J+1 GEQ Q.BF; 00010100 INDX[I,0].CF:=T1; B[0]:=INDX[I,0]; 00010110 COMMENT -- PUT THE PAGE BACK OUT ON DISK; 00010120 MOVE(B,RECSIZE+SKIP,INDX[I,0]); 00010130 MOVE(B,PAGESIZE,POINTERS[CURBUFF:=BUFFNUMBER 00010140 (I)](0)); SORT(INDX,0,NPAGES,RECSIZE|8); 00010150 MARK(CURPAGE:=I); SETTYPES; 00010160 N:=1; 00010170 END 00010180 ELSE N:=0 COMMENT LAST PAGE OF THIS TYPE; 00010190 ELSE N:=0 COMMENT LAST PAGE OF FILE; 00010200 ELSE N:=0 COMMENT PAGE CANNOT BE CHANGED; 00010210 ELSE N:=0 COMMENT THIS PAGE IS NOT TOO SMALL; 00010220 END UNTIL I:=I+1 GTR NPAGES OR N NEQ 0 ELSE N:=0; 00010230 IF I GTR NPAGES THEN N:=REAL(WRITEBUFFER); 00010240 END OF FILE UPDATE; 00010250 %------- MODE=10 ------ EMERGENCY FILE MAINTENANCE -------- 00010260 DO MEMORY(9,TYPE,A,N,M) UNTIL N NEQ 1 00010270 %------- MODE=11 ------- SET THE KIND OF STORAGE FOR TYPE ----------00010280 ;COMMENT TYPE "TYPE" STORAGE IS BEING SET TO SEQUENTIAL; 00010290 IF TYPE=0 THEN MESSAGE(4) ELSE 00010300 IF (T:=TYPS[TYPE]).AF= T.BF THEN TYPS[TYPE].BOOL:=1 ELSE 00010310 MESSAGE(15); COMMENT ATTEMPT TO CHANGE KINDS IN MIDSTREAM; 00010320 %------- MODE=12 ----------- ALTER STORAGE ALLOCATION RESOURCES--- 00010330 COMMENT N IS THE "FACTOR" (PERCENT OF RESOURCES | 100), 00010340 AND M IS THE STORAGE "LEVEL" (0 IS THE ONLY ONE THAT 00010350 DOES ANYTHING ON THE B5500); 00010360 BEGIN INTEGER J,K; 00010370 BOOLEAN TOG; 00010380 IF T:=N|(MBUFF-1)/100+1 GTR MAXBUFF THEN 00010390 BEGIN COMMENT ADD TO AVAILABLE LIST; 00010400 FOR I:=CDR(FIRST),CDR(AVAIL) DO 00010410 WHILE NOT NULL(I) DO 00010420 BEGIN BUF[I].FLAGB:=1; I:=CDR(BUF[I]); 00010430 END; 00010440 FOR I:=MAXBUFF+1 STEP 1 UNTIL T DO 00010450 BEGIN WHILE BUF[K:=K+1].FLAGB=1 DO; 00010460 BUF[K]:=0; RPLACD(BUF[K],CDR(AVAIL)); 00010470 RPLACD(AVAIL,K) 00010480 END; 00010490 MAXBUFF:=T; 00010500 FOR I:=1 STEP 1 UNTIL MBUFF DO BUF[I].FLAGB:=0; 00010510 END ELSE 00010520 IF T LSS MAXBUFF THEN 00010530 BEGIN COMMENT CUT DOWN ON THE NUMBER OF BUFFERS; 00010540 I:=CDR(FIRST); 00010550 FOR J:=1 STEP 1 UNTIL MAXBUFF DO 00010560 IF TOG THEN 00010570 IF NOT NULL(I) THEN 00010580 IF J GEQ T THEN 00010590 BEGIN K:=CDR(BUF[I]); BUF[I]:=0 00010600 ; I:=K END 00010610 ELSE I:=CDR(BUF[I]) 00010620 ELSE 00010630 ELSE 00010640 IF TOG:=NULL(I) THEN 00010650 BEGIN J:=J-1; I:=CDR(AVAIL) 00010660 END 00010670 ELSE 00010680 IF J EQL T THEN 00010690 BEGIN K:=CDR(BUF[I]); RPLACD(BUF[I],0); 00010700 I:=K END ELSE 00010710 IF J GTR T THEN 00010720 BEGIN 00010730 IF BOOLEAN(BUF[I].CHANGEDBIT) THEN 00010740 WRITE(POINTERS[I][BUF[I].PAGEF-1]); 00010750 K:=CDR(BUF[I]); 00010760 CLOSE(POINTERS[I]); 00010770 BUF[I]:=0; I:=K 00010780 END ELSE I:=CDR(BUF[I]) 00010790 ; 00010800 MAXBUFF:=T 00010810 END; 00010820 END; 00010830 %------- MODE=13 ------- RELEASE "TYPE" STORAGE TO SYSTEM ----------00010840 IF (T:=TYPS[TYPE]).BF GTR T.AF THEN 00010850 BEGIN INTEGER J; 00010860 J:=T.BF-1; 00010870 FOR I:=T.AF STEP 1 UNTIL J DO 00010880 BEGIN CURBUFF:=BUFFNUMBER(I); 00010890 SETNTH(POINTERS[CURBUFF](0),0,0); MARK(CURPAGE:=I); 00010900 END; 00010910 TYPS[0].BF:=FREEPAGE(INDX,TYPS[0].BF,T.AF,J); 00010920 UPDATE(TYPS,1,TYPE-1,J-T.AF+1); 00010930 TYPS[TYPE].BF:=T.AF; TYPS[TYPE].BOOL:=0; 00010940 END; 00010990 %------- MODE=14 ------ RELEASE ALL PAGES FOR TRANSITION -----------00011000 BEGIN INTEGER K; 00011010 I:=CDR(FIRST); 00011020 WHILE NOT NULL(I) DO 00011030 BEGIN IF BOOLEAN(BUF[I].CHANGEDBIT ) THEN WRITE(POINTERS[I] 00011040 [BUF[I].PAGEF-1]); CLOSE(POINTERS[I]); 00011050 K:=CDR(BUF[I]); BUF[I]:=0; 00011060 RPLACD(BUF[I],CDR(AVAIL)); RPLACD(AVAIL,I); I:=K 00011070 END ; CURPAGE:=CURBUFF:=-1; RPLACD(FIRST,0); 00011080 END; 00011090 END OF CASE STMT; 00011100 00011110 END OF INNER BLOCK; 00011120 END OF PROCEDURE; 00011130 INTEGER QM,QN; 00011330 ARRAY QA[0:0]; 00011340 PROCEDURE NAME(MFID,FID); VALUE MFID,FID; REAL MFID,FID; 00011350 BEGIN INTEGER I; FILL NEWDISK WITH MFID,FID; 00011360 FOR I:=0 STEP 1 UNTIL MBUFF DO 00011370 FILL POINTERS[I] WITH MFID,FID; 00011380 FILL ESTABLISH WITH MFID,FID; 00011390 SETPOINTERNAMES 00011400 END; 00011410 PROCEDURE SEQUENTIAL(UNIT); VALUE UNIT; INTEGER UNIT; 00011420 MEMORY(11,UNIT,QA,QN,QM); 00011430 INTEGER PROCEDURE CONTENTS(UNIT,N,AR); VALUE UNIT,N; 00011440 INTEGER UNIT,N; ARRAY AR[0]; 00011450 BEGIN 00011460 MEMORY(4,UNIT,AR,N,QM); CONTENTS:=QM; 00011510 END; 00011560 PROCEDURE DELETE1(UNIT,N); VALUE UNIT,N; INTEGER UNIT,N; 00011570 MEMORY(6,UNIT,QA,N,QM); 00011630 INTEGER PROCEDURE SEARCHORD(UNIT,REC,LOC,M); VALUE UNIT,M; 00011650 INTEGER UNIT,LOC,M; ARRAY REC[0]; 00011660 BEGIN LOC:=1; 00011670 MEMORY(7,UNIT,REC,LOC,M); 00011730 SEARCHORD:=M; 00011800 END; 00011810 PROCEDURE STOREORD(UNIT,REC,N); VALUE UNIT,N; INTEGER UNIT,N; 00011820 ARRAY REC[0]; 00011830 MEMORY(5,UNIT,REC,N,QM); 00011900 PROCEDURE STOREORDR(UNIT,REC,N); VALUE UNIT,N; INTEGER UNIT,N; 00011920 ARRAY REC[0]; 00011930 MEMORY(2,UNIT,REC,N,QM); 00011940 BOOLEAN PROCEDURE MAINTENANCE; 00011950 BEGIN MEMORY(9,0,QA,QN,QM); MAINTENANCE:=QN=1 00011960 END; 00011970 PROCEDURE WRAPUP; MEMORY(10,0,QA,QN,QM); 00011980 INTEGER PROCEDURE STORESEQ(UNIT,REC,N); VALUE UNIT,N; INTEGER UNIT, N; 00011990 ARRAY REC[0]; 00012000 BEGIN 00012010 MEMORY(5,UNIT,REC,QN,N); STORESEQ:=QN; 00012070 END; 00012100 PROCEDURE DELETEN(UNIT,N,M); VALUE UNIT,N,M; INTEGER UNIT,N,M; 00012110 BEGIN M:=M-N; 00012120 DO MEMORY(6,UNIT,QA,N,QM) UNTIL M:=M-1 LSS 0; 00012130 END; 00012140 INTEGER PROCEDURE NEXTUNIT; 00012420 BEGIN MEMORY(1,0,QA,QN,1); NEXTUNIT:=QN 00012430 END; 00012440 INTEGER PROCEDURE SIZE(UNIT); VALUE UNIT; INTEGER UNIT; 00012450 BEGIN MEMORY(3,UNIT,QA,QN,QM); SIZE:=QM 00012460 END; 00012470 PROCEDURE ALLOCATE(J,FACTOR); VALUE J,FACTOR; INTEGER J; 00012570 REAL FACTOR; 00012580 BEGIN 00012590 QN:=ENTIER( ABS( (FACTOR | 100) MOD 101)); 00012600 MEMORY(12,0,QA,QN,J) 00012610 END; 00012620 PROCEDURE RELEASEUNIT(UNIT); VALUE UNIT; INTEGER UNIT; 00012630 MEMORY(13,UNIT,QA,QN,QM); 00012640 DEFINE 00013000 ALLOWQUESIZE=4#, 00013010 ACOUNT=ACCUM[0].[1:11]#, 00013020 DATADESC=[1:1]#, 00013022 SCALAR=[4:1]#, 00013030 NAMED=[3:1]#, 00013040 CHRMODE=[5:1]#, 00013042 CHECKT=5#, % NUMBER OF TIMES THRU EXECUTE BEFORE CHECK 00013050 CCIF=18:36:12#, 00013060 CDID=1:43:5#, 00013070 CSPF=30:30:18#, 00013080 CRF=24:42:6#, 00013090 CLOCF=6:30:18#, 00013092 PF=[1:17]#, 00013100 XEQMODE=1#, 00013110 FUNCMODE=2#, 00013112 CALCMODE=0#, 00013114 INPUTMODE=3#, 00013116 ERRORMODE=4#, 00013118 FUNCTION=1#, 00013120 CURRENTMODE = PSRM[0]#, 00013130 VARIABLES = PSRM[1]#, 00013140 VARSIZE = PSRM[2]#, 00013150 FUNCPOINTER = PSRM[3]#, 00013160 FUNCSEQ = PSRM[4]#, 00013170 CURLINE = PSRM[5]#, 00013180 STACKBASE = PSRM[6]#, 00013182 INCREMENT=STACKBASE#, %FUNCMODE/CALCMODE 00013183 SYMBASE = PSRM[7]#, 00013184 FUNCSIZE=SYMBASE#, %FUNCMODE/CALCMODE 00013185 USERMASK = PSRM[8]#, 00013186 SEED = PSRM[10]#, 00013187 ORIGIN = PSRM[11]#, 00013188 FUZZ = PSRM[12]#, 00013189 FSTART=9#, %PSR[9] IS WHERE NAME OF CURRENTLY EDITED FCN GOES 00013190 PSRSIZE = 13#, 00013200 PSR = PSRM[*]#, 00013202 WF=[18:8]#, 00013210 WDSPERREC=10#, 00013220 WDSPERBLK=30#, 00013230 NAREAS=10#, 00013240 SIZEAREAS=210#, 00013250 LIBF1=[6:15]#, 00013260 LIBF2=[22:16]#, 00013270 LIBF3=[38:10]#, 00013275 LIBSPACES=1#, 00013280 IDENT=RESULT=1#, 00014000 SPECIAL=RESULT=3#, 00015000 NUMERIC=RESULT=2#, 00016000 REPLACELOC=0#, 00016050 REPLACEV=4#, 00017000 SPF=[30:18]#, 00017100 RF=[24:6]#, 00017110 DID=[1:5]#, 00017120 XRF=[12:18]#, 00017130 DDPNSW=30#, % DATA DESC PRESENT NAMED SCALAR WORD 00017132 DDNNVW=20#, %DATA DESC NON-PRES NAMED VECTOR WORD 00017134 DDNUVW=16#, %DATA DESC NONPRES..(POINTS INTO SYM TAB FOR LOCALS) 00017136 DDPUVW=24#, % DATA DESC PRESENT UNNAMED VECTOR WORD 00017140 DDNNSW=22#, % DATA DESC NON-PRES NAMED SCALAR WORD 00017142 PDC=10#, % PROG DESC CALC MODE 00017144 INTO=0#, 00017150 DDPUSW=26#, % DATA DESC PRESENT UNNAMED SCALAR WORD (MODE) 00017152 DDPUSC=27#, % DATA DESC PRESENT UNNAMED SCALAR CHR 00017154 DDPUVC=25#, % DATA DESC PRESENT UNNAMED VECTOR CHR 00017156 DDPNVC=29#, %DATA DESC PRES PERMANENT VECTOR CHAR MODE 00017157 DDPNVW=28#, %DATA DESC PRES NAMED VEC WORD (NAMED=PERMANENT) 00017158 OUTOF=1#, 00017160 NAMEDNULLV=0&7[1:45:3]#, %KLUDGE...NAMED VERSION OF NULLV 00017161 BACKP=[6:18]#, 00017170 SCALARDATA=0#, 00017200 ARRAYDATA=2#, 00017202 DATATYPE=[4:1]#, 00017204 ARRAYTYPE=[5:1]#, 00017206 CHARARRAY=1#, 00017208 NUMERICARRAY=0#, 00017210 BLOCKSIZE=30#, %#WORDS OF CONTIGUOUS DATA IN SEQUENTIAL STORE 00017220 VARTYPE=[42:6]#, 00017222 WS=WORKSPACE#, 00017224 DIMPTR=SPF#, 00017226 INPTR=BACKP#, 00017228 QUADIN=[18:3]#, 00017230 QUADINV=18:45:3#, 00017234 STATEVECTORSIZE=16#, 00017240 SUSPENDED=[5:1]#, 00017250 SUSPENDVAR=[2:1]#, 00017252 CTYPEF=3:45:3#, 00017254 CSUSVAR=2:47:1#, 00017256 CNAMED=3:47:1#, 00017258 MAXWORDSTORE=3960#, %APL PREVENTS CREATION OF ARRAYS BIGGER THAN 00017260 %3960 ELEMENTS. THIS NUMBER IS THE PRODUCT OF 00017262 %4,(NUMBER OF POINTERS TO SEQUENTIAL STORE 00017264 %BLOCKS THAT ARE STORED IN ONE WORD) 00017266 %30, (BLOCKSIZE), 00017268 %AND 33, (SIZE OF ARRAY USED TO STORE THESE 00017270 %POINTERS IN GETARRAY, MOVEARRAY, AND 00017272 %RELEASEARRAY). SUBSCRIPTS ALLOWS 8|3960 00017274 %ELEMENTS IF THEY ARE CHARACTERS. 00017276 %HOWEVER, SP WILL GET FULL BEFORE THAT SINCE 00017278 %BIGGEST SP SIZE IS CURRENTLY 3584 00017280 MAXBUFFSIZE=30#, 00018000 MAXHEADERARGS=30#, 00018100 BUFFERSIZE=BUFFSIZE#, 00019000 LINEBUFFER=LINEBUFF#, 00020000 LINEBUFF = OUTBUFF[*]#, 00020100 APPENDTOBUFFER=APPENDTOBUFF#, 00021000 FOUND=TARRAY[0]#, 00022000 EOB=TARRAY[1]#, 00023000 MANT=TARRAY[2]#, 00024000 MANTLEN=TARRAY[3]#, 00025000 FRAC=TARRAY[4]#, 00026000 FRACLEN=TARRAY[5]#, 00027000 POWER=TARRAY[6]#, 00028000 POWERLEN=TARRAY[7]#, 00029000 MANTSIGN=TARRAY[8]#, 00029100 TABSIZE = 43#, 00030000 LOGINCODES=1#, 00030100 LOGINPHRASE=2#, 00030200 LIBRARY=1#, 00030210 WORKSPACEUNIT=2#, 00030220 RTPAREN=9#, 00030300 MASTERMODE=USERMASK.[1:1]#, 00030400 EDITOG=USERMASK.[2:1]#, 00030401 POLBUG=USERMASK.[3:1]#, 00030402 FPTF=9#, % FUNCTION POINTER FIELD (STARTS AT CHR POS 9) 00030403 FSQF=11#, % FUNCTION SEQNTL FIELD 00030404 FFL=2#, % FUNCTION FIELD LENGTH (2 CHR POSITIONS) 00030406 CRETURN=3:47:1#, 00030407 RETURNVALUE=[3:1]#, 00030408 CNUMBERARGS=4:46:2#, 00030409 NUMBERARGS=[4:2]#, 00030410 RETURNVAL=1#, 00030411 NOSYNTAX=USERMASK.[4:1]#, 00030412 LINESIZE=USERMASK.[41:7]#, 00030414 DIGITS=USERMASK.[37:4]#, 00030416 SUSPENSION=USERMASK.SUSPENDED#, 00030418 SAVEDWS=USERMASK.[7:1]#, 00030419 DELTOG=USERMASK.[6:1]#, 00030420 DELCHR="$"#, %USED IN DELPRESENT (IN FUNCTIONHANDLER) 00030422 MAXMESS=27#, 00030500 USERTOP=21#, 00030510 MARGINSIZE=6#, 00030600 LFTBRACKET=SPECIAL AND ACCUM[0]=11#, 00030610 QUADV=SPECIAL AND ACCUM[0]=10#, 00030620 QUOTEV=ACCUM[0]=20#, 00030622 EXPANDV=38#, 00030623 SLASHV=6#, 00030624 GOTOV=5#, 00030626 DOTV=17#, 00030627 ROTV=37#, 00030628 RGTBRACKET=SPECIAL AND ACCUM[0]=12#, 00030630 DELV=SPECIAL AND ACCUM[0]=13#, 00030640 PLUS = SPECIAL AND ACCUM[0] = 48#, 00030650 MINUS = SPECIAL AND ACCUM[0] = 49#, 00030660 NEGATIVE = SPECIAL AND ACCUM[0] = 51#, 00030665 TIMES = SPECIAL AND ACCUM[0] = 50#, 00030670 LOGS = SPECIAL AND ACCUM[0] = 54#, 00030672 SORTUP = SPECIAL AND ACCUM[0] = 55#, 00030674 SORTDN = SPECIAL AND ACCUM[0] = 56#, 00030675 NAND = SPECIAL AND ACCUM[0] = 58#, 00030676 NOR = SPECIAL AND ACCUM[0] = 59#, 00030677 TAKE = SPECIAL AND ACCUM[0] = 60#, 00030678 DROPIT = SPECIAL AND ACCUM[0] = 61#, 00030679 LFTARROW = SPECIAL AND ACCUM[0] = 04#, 00030680 TRANS = SPECIAL AND ACCUM[0] = 05#, 00030690 SLASH = SPECIAL AND ACCUM[0] = 06#, 00030700 INTDIVIDE = SPECIAL AND ACCUM[0] = 07#, 00030710 LFTPAREN = SPECIAL AND ACCUM[0] = 08#, 00030720 RGTPAREN = SPECIAL AND ACCUM[0] = 09#, 00030730 QUOTEQUAD = SPECIAL AND ACCUM[0] = 14#, 00030740 SEMICOLON = SPECIAL AND ACCUM[0] = 15#, 00030750 COMMA = SPECIAL AND ACCUM[0] = 16#, 00030760 DOT = SPECIAL AND ACCUM[0] = 17#, 00030770 STAR = SPECIAL AND ACCUM[0] = 18#, 00030780 AT = SPECIAL AND ACCUM[0] = 19#, 00030790 QUOTE = SPECIAL AND ACCUM[0] = 20#, 00030800 BOOLAND = SPECIAL AND ACCUM[0] = 21#, 00030810 BOOLOR = SPECIAL AND ACCUM[0] = 22#, 00030820 BOOLNOT = SPECIAL AND ACCUM[0] = 23#, 00030830 LESSTHAN = SPECIAL AND ACCUM[0] = 24#, 00030840 LESSEQ = SPECIAL AND ACCUM[0] = 25#, 00030860 EQUAL = SPECIAL AND ACCUM[0] = 26#, 00030870 GRTEQ = SPECIAL AND ACCUM[0] = 27#, 00030880 GREATER = SPECIAL AND ACCUM[0] = 28#, 00030890 NOTEQ = SPECIAL AND ACCUM[0] = 29#, 00030900 CEILING = SPECIAL AND ACCUM[0] = 30#, 00030910 FLOOR = SPECIAL AND ACCUM[0] = 31#, 00030920 STICK = SPECIAL AND ACCUM[0] = 32#, 00030930 EPSILON = SPECIAL AND ACCUM[0] = 33#, 00030940 RHO = SPECIAL AND ACCUM[0] = 34#, 00030950 IOTA = SPECIAL AND ACCUM[0] = 35#, 00030960 TRACE = SPECIAL AND ACCUM[0] = 36#, 00030970 PHI = SPECIAL AND ACCUM[0] = 37#, 00030980 EXPAND = SPECIAL AND ACCUM[0] = 38#, 00030981 BASVAL = SPECIAL AND ACCUM[0] = 39#, 00030982 EXCLAMATION = SPECIAL AND ACCUM[0] = 40#, 00030983 MINUSLASH = SPECIAL AND ACCUM[0] = 41#, 00030984 QUESTION = SPECIAL AND ACCUM[0] = 42#, 00030985 OSLASH = SPECIAL AND ACCUM[0] = 43#, 00030986 TAU = SPECIAL AND ACCUM[0] = 44#, 00030987 CIRCLE = SPECIAL AND ACCUM[0] = 45#, 00030988 LOCKIT =IDENT AND ACCUM[0]="4LOCK "#, 00030989 COLON = SPECIAL AND ACCUM[0] = 47#, 00030990 QUADLFTARROW=51#, 00030992 REDUCT=52#, 00030993 ROTATE=53#, 00030994 SCANV=57#, 00030995 LINEBUFFSIZE=17#, 00031000 MAXPOLISH=100#, MESSIZE=10#, 00031002 MAXCONSTANT=30#, 00031004 MAXMEMACCESSES=3584#, %MAXSPROWS | SPRSIZE 00031005 MAXSYMBOL=30#, 00031006 MAXSPROWS=28#, 00031007 TYPEFIELD=[3:3]#, 00031008 OPTYPE=[1:2]#, 00031009 LOCFIELD=BACKP#, 00031010 ADDRFIELD=SPF#, 00031012 SYMTYPE=[3:3]#, 00031013 OPERAND=5#, 00031014 CONSTANT=2#, 00031016 OPERATOR=3#, 00031018 LOCALVAR=4#, 00031019 SYMTABSIZE=1#, 00031020 LFTPARENV=8#, 00031022 RGTPARENV=9#, 00031024 LFTBRACKETV=11#, 00031026 RGTBRACKETV=12#, 00031028 SEMICOLONV=15#, 00031030 QUAD=10#, 00031032 QQUAD=14#, 00031033 LFTARROWV=4#, 00031034 SORTUPV=55#, 00031035 SORTDNV=56#, 00031036 ALPHALABEL=1#, 00031040 NUMERICLABEL=2#, 00031050 NEXTLINE=0#, 00031060 ERRORCOND=3#, 00031062 PRESENCE=[2:1]#, 00031070 CHANGE=[1:1]#, 00031080 XEQ=1#, 00031090 CLEARCORE=2#, 00031092 WRITECORE=3#, 00031094 %%% 00031096 %%% 00031098 XEQUTE=1#, 00031100 SLICE=120#, %TIME SLICE IN 60THS OF A SECOND 00031102 ALLOC=2#, 00031104 WRITEBACK=3#, 00031106 LOOKATSTACK=5#, 00031108 00031110 LEN=[1:23]#, 00032000 NEXT=[24:24]#, 00032002 LOC=L.[30:11],L.[41:7]#, 00032004 NOC=N.[30:11],N.[41:7]#, 00032008 MOC=M.[30:11],M.[41:7]#, 00032010 SPRSIZE=128#, % SP ROW SIZE 00032015 NILADIC=0#, 00032020 MONADIC=1#, 00032030 DYADIC=2#, 00032040 TRIADIC=3#, 00032050 DEPTHERROR=1#, 00032100 DOMAINERROR=2#, 00032110 INDEXERROR=4#, 00032120 LABELERROR=5#, 00032130 LENGTHERROR=6#, 00032140 NONCEERROR=7#, 00032150 RANKERROR=8#, 00032160 SYNTAXERROR=9#, 00032170 SYSTEMERROR=10#, 00032180 VALUEERROR=11#, 00032190 SPERROR=12#, 00032200 KITEERROR=13#, 00032201 STREAMBASE=59823125#, 00032204 APLOGGED=[10:1]#, 00032230 APLHEADING=[11:1]#, 00032231 CSTATION = STATION#, 00032232 CAPLOGGED=10:47:1#, 00032234 CAPLHEADING=11:47:1#, 00032236 APLCODE = STATIONPARAMS#, 00032238 00032240 00032250 SPECMODE = BOUNDARY.[1:3]#, 00032260 DISPLAYING=1#, 00032270 EDITING=2#, 00032280 DELETING=3#, 00032290 RESEQUENCING=4#, 00032291 LOWER = BOUNDARY.[4:22]#, 00032292 UPPER = BOUNDARY.[26:22]#, 00032294 OLDBUFFER = OLDINPBUFFER[*]#, 00032800 00032850 ENDEFINES=#; 00032900 REAL ADDRESS, ABSOLUTEADDRESS, 00033000 LADDRESS; 00033100 BOOLEAN LINETOG; %GO TO NEXT LINE IF TRUE WHEN WRITING OUT 00034000 INTEGER BUFFSIZE,ITEMCOUNT,RESULT, 00035000 LOGINSIZE, 00035100 %%% 00035200 ERR, 00035300 NROWS, 00036000 %%% 00036010 CUSER; 00036020 LABEL ENDOFJOB,TRYAGAIN; 00036100 REAL GT1,GT2,GT3; 00036110 DEFINE LINE=PRINT#; 00037000 SAVE ARRAY BUFFER[0:MAXBUFFSIZE]; 00038000 ARRAY TARRAY[0:8], 00039000 COMMENT PROGRAM STATE REGISTER; 00039100 PSRM[0:PSRSIZE], 00039110 OLDINPBUFFER[0:MAXBUFFSIZE], 00039120 SP[0:27, 0:SPRSIZE-1], 00039200 IDTABLE[0:TABSIZE], 00040000 MESSTAB[0:MAXMESS], 00040100 JIGGLE[0:0], 00040200 SCR[0:2], 00041000 CORRESPONDENCE[0:7], 00041120 ACCUM[0:MAXBUFFSIZE]; 00042000 DEFINE OUTBUFFSIZE=29#,CLOGGED=7:47:1#,STU=15:9:9#; 00042715 ARRAY OUTBUFF[0:OUTBUFFSIZE]; 00042720 ALPHA STATION, JOBNUM, STATIONPARAMS, BOUNDARY; 00042730 INTEGER CHRCOUNT, WORKSPACE; 00042740 00042910 STREAM PROCEDURE INITBUFF(B,BUFFSIZE); VALUE BUFFSIZE; 00043000 BEGIN 00044000 DI~B; BUFFSIZE(DS~8LIT" "); DS~LIT"~"; 00045000 END; 00046000 STREAM PROCEDURE TRANSFER(A,AS,B,BS,L); VALUE AS,BS,L; 00046200 BEGIN LOCAL T,U,V; 00046210 SI:=LOC AS; DI:=LOC T; DI:=DI+1; DS:=7CHR; 00046220 SI:=LOC BS; DI:=LOC U; DI:=DI+1; DS:=7CHR; 00046230 SI:=LOC L; DI:=LOC V; DI:=DI+1; DS:=7CHR; 00046232 SI:=A; T(2(SI:=SI+32)); SI:=SI+AS; 00046240 DI:=B; U(2(DI:=DI+32)); DI:=DI+BS; 00046250 V(2(DS:=32CHR)); DS:=L CHR; 00046260 END; 00046270 REAL PROCEDURE NUMBER; FORWARD; %LINE 111500 00046275 BOOLEAN PROCEDURE SCAN; 00046280 BEGIN 00046284 REAL STREAM PROCEDURE GNC(ADDR,ACC); VALUE ADDR; 00046290 BEGIN SI:=ADDR; DI:=ACC; DI:=DI+7; DS:=CHR; GNC:=SI; 00046300 DI:=ACC; SKIP DB; DS:=SET; END OF GNC; 00046310 REAL STREAM PROCEDURE RESWD(TAB,BUF,ADDR,EOB,FOUND,K); 00047000 VALUE ADDR,K; 00048000 BEGIN 00049000 LOCAL T,TSI,TDI; 00050000 LABEL TRY,L,KEEPGOING,FINIS,RESTORE; 00051000 LABEL NUMBERFOUND; 00051100 DI:=EOB; DS:=8LIT"0"; DI:=FOUND; DS:=8LIT"0"; 00052000 SI:=ADDR; 00053000 L: IF SC NEQ " " THEN GO TO KEEPGOING; 00054000 SI:=SI+1; 00055000 GO TO L; 00056000 KEEPGOING: 00057000 RESWD:=SI; 00058000 ADDR:=SI; 00059000 IF SC GEQ "0" THEN IF SC LEQ "9" THEN GO TO NUMBERFOUND; 00059050 IF SC="#" THEN GO TO NUMBERFOUND; 00059100 IF SC="@" THEN GO TO NUMBERFOUND; 00059800 IF SC="." THEN 00059810 BEGIN SI:=SI+1; 00059820 IF SC GEQ "0" THEN IF SC LEQ "9" THEN 00059830 GO TO NUMBERFOUND; SI:=SI-1; 00059840 END; 00059900 DI:=LOC T; DS:=2RESET; DS:=2SET; DS:=2RESET; 00060000 DI:=LOC T; 00061000 IF SC=DC THEN 00062000 BEGIN DI:=EOB; DI:=DI+7; DS:=LIT"1"; 00063000 GO TO FINIS 00064000 END; 00065000 SI:=TAB; TSI:=SI; 00066000 TRY: 00067000 IF SC="0" THEN 00068000 BEGIN SI:=ADDR; 00069000 IF SC=ALPHA THEN 00070000 IF SC GEQ"0" THEN 00071000 IF SC LEQ "9" THEN 00072000 NUMBERFOUND: 00072100 TALLY:=2 ELSE TALLY := 0 00072200 ELSE TALLY:=1 00073000 ELSE TALLY:=3; 00074000 T:=TALLY; SI:=LOC T; SI:=SI+7; DI:=FOUND; DI:=DI+7; 00075000 DS:=CHR; GO FINIS; 00076000 END; 00077000 DI:=LOC T; DI:=DI+7; DS:=CHR; 00078000 DI:=ADDR; 00079000 IF T SC=DC THEN 00080000 BEGIN 00081000 TSI:=SI; TDI:=DI; SI:=SI-1; 00082000 IF SC=ALPHA THEN 00083000 BEGIN DI:=DI+16; SI:=TDI; 00084000 IF SC NEQ " " THEN IF SC =ALPHA THEN ; 00085000 END; 00086000 SI:=TSI; 00087000 END ELSE GO TO RESTORE; 00088000 IF TOGGLE THEN 00089000 RESTORE: 00090000 BEGIN SI:=SI+K; DI:=ADDR; GO TO TRY 00091000 END; 00092000 DI:=FOUND; DS:=K OCT; 00093000 DI:=TDI; RESWD:=DI; 00094000 FINIS: 00095000 END; 00095100 REAL STREAM PROCEDURE ACCUMULATE(ACC,EOB,ADDR); VALUE ADDR; 00095110 BEGIN LOCAL T; LABEL EOBL,E,ON,L; 00095120 DI:=ACC; 9(DS:=8LIT" "); 00095130 DI:=EOB; DS:=8LIT"0"; SI:=ADDR; DI:=LOC T; SKIP 2 DB; 00095140 DS:=2SET; DI:=LOC T; 00095150 63(IF SC=ALPHA THEN TALLY:=TALLY+1 ELSE JUMP OUT TO E; 00095160 SI:=SI+1); 00095170 L: IF SC=ALPHA THEN BEGIN SI:=SI+1; GO L END ELSE GO ON; 00095180 IF SC=" " THEN GO ON; 00095190 E: IF SC = DC THEN ; 00095200 SI:=SI-1; IF TOGGLE THEN GO TO EOBL ELSE GO ON; 00095210 EOBL: DI:=EOB; DI:=DI+7; DS:=LIT"1"; 00095220 ON: ACCUMULATE:=SI; DI:=ACC; T:=TALLY; SI:=LOC T; SI:=SI+6; 00095230 DS:=2CHR; SI:=ADDR; DS:=T CHR; 00095240 END OF ACCUMULATE; 00095250 BOOLEAN STREAM PROCEDURE ARROW(ADDR,I); VALUE ADDR,I; 00095260 BEGIN SI:=ADDR; SI:=SI-1; DI:=LOC I; DI:=DI+7; 00095270 IF SC=DC THEN TALLY:=1; ARROW :=TALLY 00095280 END OF ARROW; 00095290 IF NOT BOOLEAN(EOB) THEN BEGIN 00095300 LADDRESS:=ADDRESS; 00095310 ADDRESS:=RESWD(IDTABLE,BUFFER,ADDRESS,EOB,FOUND,2); 00095330 IF RESULT:=FOUND NEQ 0 THEN BEGIN 00095340 IF RESULT=1 THEN ADDRESS:=ACCUMULATE(ACCUM,EOB,ADDRESS) 00095350 ELSE IF RESULT=2 THEN ACCUM[0]:=NUMBER 00095360 ELSE IF RESULT=3 THEN ADDRESS:=GNC(ADDRESS,ACCUM) 00095370 ELSE BEGIN ACCUM[0]:=RESULT; RESULT:=3 END; 00095380 ITEMCOUNT:=ITEMCOUNT+1; 00095390 SCAN:=TRUE; 00095400 IF ARROW(ADDRESS,31) THEN 00095410 BEGIN EOB:=1; SCAN:=FALSE END; 00095420 END ELSE EOB:=1; 00095430 END; 00095440 END OF THE SCAN PROCEDURE; 00095450 PROCEDURE FORMROW(CC,BL,A,S,N); VALUE CC,BL,S,N; 00096000 INTEGER CC,BL,S,N; ARRAY A[0]; FORWARD 00096100 ; 00096200 PROCEDURE INDENT(R); VALUE R; REAL R; FORWARD; 00096300 PROCEDURE TERPRINT; FORWARD; 00096400 PROCEDURE PROCESS(MODE);VALUE MODE;INTEGER MODE; FORWARD; 00096500 REAL STREAM PROCEDURE ABSADDR(A); 00097000 BEGIN SI:=A; ABSADDR:=SI 00098000 END; 00099000 BOOLEAN PROCEDURE LIBRARIAN(MFID,FID); VALUE MFID,FID; 00099100 REAL MFID,FID; 00099110 BEGIN 00099120 REAL ARRAY A[0:6]; FILE DF DISK(1,1); 00099125 REAL T; 00099130 COMMENT LIBRARIAN IS TRUE IF MFID/FID IS PRESENT ON DISK; 00099137 FILL DF WITH MFID,FID; 00099140 SEARCH(DF,A[*]); 00099145 LIBRARIAN:= 00099150 A[0]!-1; 00099160 END; 00099170 FILE SPO 11(1,3); 00099300 PROCEDURE SPOUT(K); VALUE K; INTEGER K; 00099310 BEGIN FORMAT ERRF("APL ERROR:",I8,A1); 00099320 WRITE(SPO,ERRF,K,31); 00099330 END; 00099340 PROCEDURE INITIALIZETABLE; 00100000 BEGIN DEFINE STARTSEGMENT= #; 00101000 INTEGER I; 00101005 LADDRESS:= 00101010 ABSOLUTEADDRESS:=ABSADDR(BUFFER); 00101100 BIGGEST := REAL(NOT FALSE) & 0[1:46:2]; 00101200 NULLV := 0 & 3[1:46:2]; 00101300 STATUSWORD~REAL(BOOLEAN(STATUSWORD) OR BOOLEAN(1)); 00101400 JOBNUM~TIME(-1); 00101410 STATION~0&1[CLOGGED]&STATUSWORD[STU]; 00101420 FILL JIGGLE[*] WITH OCT3636363636363636; %RUB OUTS 00101430 FILL IDTABLE[*] WITH 00102000 "1+481-49", "1&501%07", "1.171@19", "1#411(08", 00103000 "1)091/06", "3XEQ623L", "OG541;15", OCT0333777601040177, 00103100 %LAST IN ABOVE LINE IS REALLY 3["]141" 00103200 "202:=042", "[]101[11", "1]123AND", "212OR223", 00103300 "NOT233LS", "S243LEQ2", "53GEQ273", "GTR283NE", "Q292=:05", 00103350 "2GO051=2", "63MAX304", "CEIL303F", "LR313MIN", 00103400 "314RESD3","23ABS323","RHO341*1","84IOTA35", 00103500 "1|384RND", "M425TRAN", "S431$133", "PHI374FA", 00103600 "CT404COM", "B406CIRC", "LE456SOR", "TUP556SO", 00103700 "RTDN561:", "474NAND5", "83NOR594", "TAKE604D", 00103800 "ROP613RE", "P446BASV", "AL393EPS", "331,1600"; 00103900 COMMENT IDTABLE IS TABLE OF RESERVED WORDS AND SPECIAL SYMBOLS. 00103910 FORMAT IS NUMBER OF CHARACTERS IN SYMBOL, FOLLOWED BY SYMBOL 00103913 ITSELF, FOLLOWED BY A TWO-DIGIT DECIMAL CODE WHICH APL USES 00103916 FOR THE RESERVED WORD--LIKE IN THE EXECUTION CASE STATEMENT AND 00103919 IN SYNTAX CHECKING. FOR SCAN TO WORK, THE TW0-DIGIT CODE MUST 00103922 BE GREATER THAN 3 AND IDTABLE MUST HAVE AT LEAST ONE "0" AT THE 00103925 END TO MARK THE END. TABSIZE IS THE DEFINE (LINE 30000) GIVING 00103928 THE SIZE OF IDTABLE; 00103931 IF STACKSIZE=0 THEN STACKSIZE:=100 ELSE 00103940 IF STACKSIZE GTR 1022 THEN STACKSIZE:=1022; 00103950 BUFFSIZE:=MAXBUFFSIZE; 00104000 LINETOG := TRUE; %USUALLY GO TO NEXT LINE WHEN WRITING OUT 00104010 00104100 INITBUFF(OUTBUFF, 10); 00104500 INITBUFF(BUFFER,BUFFSIZE); 00105000 NROWS:=-1; 00105010 NAME(LIBJOB,TIME(-1)); 00105100 FILL MESSTAB[*] WITH 00105200 "4SAVE ", 00105210 "4LOAD ", 00105220 "5CLEAR ", 00105230 "4COPY ", 00105240 "4VARS ", 00105250 "3FNS ", 00105260 "6LOGGED", 00105270 "3MSG ", 00105280 "5WIDTH ", 00105290 "3OPR ", 00105300 "6DIGITS", 00105310 "3OFF ", 00105320 "6ORIGIN", 00105322 "4SEED ", 00105324 "4FUZZ ", 00105326 "3SYN ", 00105328 "5NOSYN ", 00105330 "5STORE ", 00105332 "5ABORT ", 00105340 "2SI ", 00105350 "3SIV ", 00105360 "5ERASE ", 00105370 %--------------MASTERMODE BELOW HERE...(SEE USERTOP)-------- 00105380 "6ASSIGN", 00105390 "6DELETE", 00105400 "4LIST ", 00105410 "5DEBUG ", 00105420 "5FILES "; 00105440 00106000 IF LIBSIZE=-1 THEN 00106090 BEGIN LIBSIZE~1;GTA[0]~" ";STOREORD(LIBRARY,GTA,0);WRAPUP; 00106091 END ELSE BEGIN LIBSIZE~SIZE(LIBRARY); 00106093 FOR I~1 STEP 1 UNTIL LIBSIZE-1 DO 00106094 BEGIN GT1~CONTENTS(LIBRARY,I,ACCUM); 00106095 IF NOT LIBRARIAN(ACCUM[0],TIME(-1)) THEN 00106096 BEGIN DELETE1(LIBRARY,I);LIBSIZE~LIBSIZE-1;END; 00106099 END; 00106102 END; 00106104 FILL CORRESPONDENCE[*] WITH 00106500 OCT1111111111110311, 00106510 OCT1111111111111111, 00106520 OCT1104111121221113, 00106530 OCT2014151617100706, 00106540 OCT1111111111111112, 00106550 OCT1111111111111100, 00106560 OCT0201111111251111, 00106570 OCT2324111111111111; 00106571 COMMENT CORRESPONDENCE GIVES THE CORRESPONDENCE BETWEEN THE 00106573 APL CODES FOR DYADIC SCALAR OPERATORS (EXCEPT CIRCLE) AND 00106575 THEIR POSITIONS IN THE "CASE STATEMENT" IN "OPERATION". 00106577 E.G. APL CODE 7 IS "OPERATION" CODE 3 IN OCTAL (FOR DIVIDE). 00106579 IF N-TH CHARACTER IN CORRESPONDENCE IS OCTAL 11, THEN N 00106581 IS NOT AN APL CODE FOR A DYADIC SCALAR OPERATOR. CHARACTER 00106583 COUNT STARTS AT 1 FOR FIRST CHARACTER. TO MAKE IT COME OUT 00106584 RIGHT, STREAM PROCEDURE GETOP IS ACTUALLY CALLED WITH APL 00106586 OPERATION CODE MINUS 1; 00106588 END; 00107000 REAL STREAM PROCEDURE CONV(ADDR,N); 00108000 VALUE N,ADDR; 00108500 BEGIN SI:=ADDR; 00109000 DI:=LOC CONV; 00109500 DS:=N OCT; END; 00110000 REAL STREAM PROCEDURE BUMP(ADDR,N); VALUE ADDR,N; 00110500 BEGIN SI:=ADDR; SI:=SI+N; BUMP:=SI; END; 00111000 REAL PROCEDURE NUMBER; 00111500 BEGIN REAL NCHR; 00112000 LABEL GETFRAC,GETPOWER,QUIT,KITE; 00112500 MONITOR EXPOVR; 00113000 REAL PROCEDURE INTCON(COUNT); VALUE COUNT; 00113500 REAL COUNT; 00114000 BEGIN REAL TLO,THI,T; INTEGER N; 00114500 BOOLEAN DPTOG; DEFINE ADDR=ADDRESS#; 00115000 COMMENT: VALUE OF INTCON IS THE CONVERSION OF AN INTEGER 00115500 CONSISTING OF COUNT NUMERICAL CHARACTERS STARTING 00116000 AT THE CHARACTER ADDRESS. ADDRESS IS SET TO POINT 00116500 TO THE NEXT CHARACTER DURING INTCON; 00117000 DPTOG:=COUNT GTR 8; 00117500 THI:=T:=CONV(ADDR,N:=COUNT MOD 8); 00118000 ADDR:=BUMP(ADDR,N); 00118500 COUNT:=COUNT DIV 8; 00119000 FOR N:=1 STEP 1 UNTIL COUNT DO BEGIN 00119500 IF DPTOG THEN BEGIN 00120000 DOUBLE(THI,TLO,100000000.0,0,|,CONV(ADDR,8), 00120500 0,+,:=,THI,TLO); 00121000 T:=THI 00121500 END ELSE T:=T|100000000 + CONV(ADDR,8); 00122000 ADDR:=BUMP(ADDR,8); END; 00122500 INTCON:=T; 00123000 END OF INTCON; 00123500 INTEGER STREAM PROCEDURE SUBSCAN(ADDR,NEXT); VALUE ADDR; 00124000 BEGIN SI:=ADDR; 00124500 63(IF SC GEQ "0" THEN 00125000 IF SC LEQ "9" THEN BEGIN SI:=SI+1; TALLY:=TALLY+1; 00125500 END ELSE JUMP OUT); 00126000 DI:=NEXT; DI:=DI+7; DS:=1 CHR; SUBSCAN:=TALLY; 00126500 END; 00127000 COMMENT--VALUE OF SUBSCAN IS NUMBER OF NUMERIC CHARACTERS 00127500 FOUND. NEXT CONTAINS THE FIRST NON-NUMERIC CHARACTER; 00128000 EXPOVR:=KITE; 00128500 MANTSIGN:=1; 00129000 MANT:=MANTLEN:=POWER:=POWERLEN:=FRAC:=FRACLEN:=0; 00129500 MANTLEN:=SUBSCAN(ADDRESS,NCHR); 00130000 IF MANTLEN=0 AND NCHR="#" THEN BEGIN 00130500 MANTSIGN:=-1; 00131000 ADDRESS:=BUMP(ADDRESS,1); 00131500 MANTLEN:=SUBSCAN(ADDRESS,NCHR); END; 00132000 IF MANTLEN=0 THEN BEGIN ADDRESS:=BUMP(ADDRESS,1); 00132500 IF NCHR="." THEN GO TO GETFRAC 00133000 ELSE IF NCHR="@" OR NCHR="E" THEN GO TO GETPOWER 00133500 ELSE BEGIN ERR:=SYNTAXERROR; 00134000 GO TO QUIT; END; END; 00134500 MANT:=INTCON(MANTLEN); 00135000 IF NCHR="." THEN BEGIN ADDRESS:=BUMP(ADDRESS,1); GO GETFRAC END; 00135500 IF NCHR="@" OR NCHR="E" THEN BEGIN 00136000 ADDRESS:=BUMP(ADDRESS,1); GO TO GETPOWER END; 00136500 IF NCHR=12 THEN EOB:=1; 00137000 GO TO QUIT; 00137500 GETFRAC: FRACLEN:=SUBSCAN(ADDRESS,NCHR); 00138000 IF FRACLEN=0 THEN BEGIN ERR:=SYNTAXERROR; GO TO QUIT; END; 00138500 FRAC:=INTCON(FRACLEN); 00139000 IF NCHR="@" OR NCHR="E" THEN BEGIN 00139500 ADDRESS:=BUMP(ADDRESS,1); GO TO GETPOWER; END; 00140000 IF NCHR=12 THEN EOB:=1 ELSE 00140500 IF NCHR="." OR NCHR="#" THEN ERR:=SYNTAXERROR; 00141000 GO TO QUIT; 00141500 GETPOWER: 00142000 POWERLEN:=SUBSCAN(ADDRESS,NCHR); 00142500 IF POWERLEN=0 THEN BEGIN 00143000 IF NCHR="-" OR NCHR="#" THEN POWER:=-1 00143500 ELSE IF NCHR="+" THEN POWER:=1 00144000 ELSE BEGIN ERR:=SYNTAXERROR; GO TO QUIT; END; 00144500 POWERLEN:=SUBSCAN(ADDRESS:=BUMP(ADDRESS,1), NCHR); 00145000 END ELSE POWER:=1; 00145500 IF POWERLEN=0 THEN ERR:=SYNTAXERROR 00146000 ELSE BEGIN 00146500 POWER:=INTCON(POWERLEN)|POWER; 00147000 IF NCHR="#" OR NCHR="@" OR NCHR="." 00147500 THEN ERR:=SYNTAXERROR; END; 00148000 GO TO QUIT; 00148500 KITE: ERR:=KITEERROR; 00149000 QUIT: IF ERR=0 THEN 00149500 NUMBER:=IF MANTLEN+FRACLEN=0 THEN 00150000 IF POWERLEN=0 THEN 0 00150500 ELSE MANTSIGN|10*ENTIER(POWER) 00151000 ELSE MANTSIGN|(MANT|10*ENTIER(POWER) 00151500 + FRAC|10*ENTIER(POWER-FRACLEN)) ELSE EOB:=1; 00152000 END OF NUMBER; 00152500 STREAM PROCEDURE APPENDTOBUFF(BUF,NBUF,NBLANK,A,SA,NA); 00220000 VALUE NBUF,NBLANK,SA,NA; 00221000 BEGIN LOCAL T; 00222000 LOCAL TSI,TDI; 00223000 SI:=LOC NBUF; DI:=LOC T; DI:=DI+1; DS:=7CHR; 00224000 DI:=BUF; T(2(DI:=DI+32)); DI:=DI+NBUF; 00225000 NBLANK(DS:=LIT" "); TDI:=DI; 00226000 SI:=LOC SA; DI:=LOC T; DI:=DI+1; DS:=7CHR; 00227000 SI:=A; T(2(SI:=SI+32)); SI:=SI+SA; 00228000 TSI:=SI; SI:=LOC NA; DI:=LOC T; DI:=DI+1; DS:=7CHR; 00229000 SI:=TSI; DI:=TDI; T(2(DS:=32CHR)); DS:=NA CHR 00230000 END; 00231000 PROCEDURE TERPRINT; 00231030 BEGIN LABEL BK; 00231040 STREAM PROCEDURE FINISHBUFF(BUF,N,TER);VALUE N,TER; 00232000 BEGIN LOCAL T; 00232100 SI:=LOC TER;SI:=SI+7;IF SC="1" THEN; 00232200 SI:=LOC N; DI:=LOC T; DI:=DI+1; DS:=7 CHR; 00232300 DI:=BUF; T(2(DI:=DI+32));DI:=DI+N; 00232400 IF TOGGLE THEN DS:=2 LIT"{!"; %CARRIAGE RETURN/LINE FEED 00232500 DS:=RESET;DS:=5 SET; %END OF MESSAGE LEFT ARROW 00232600 END OF FINISHBUFF; 00232700 IF CHRCOUNT NEQ 0 THEN BEGIN 00240000 FINISHBUFF(OUTBUFF,CHRCOUNT,LINETOG); 00241000 CHRCOUNT:=0; 00242000 IF LINETOG THEN 00242500 WRITE(TWXOUT,9,OUTBUFF[*])[BK:BK] ELSE 00243000 WRITE(TWXOUT[STOP],9,OUTBUFF[*])[BK:BK]; 00243500 INITBUFF(OUTBUFF, 10); 00243600 END; 00243610 IF FALSE THEN 00244000 BK: IF CURRENTMODE=XEQMODE THEN BREAKFLAG:=TRUE; 00244100 END OF TERPRINT; 00245000 PROCEDURE FORMWD(CC,WD); VALUE CC,WD; REAL WD; INTEGER CC; 00253000 BEGIN 00254000 INTEGER I,K,L; 00255000 COMMENT CC=-1 STAY ON LINE, OUTPUT, DON"T GO TO NEXT LINE 00255090 COMMENT CC=0 STAY ON THIS LINE, MORE TO COME. 00256000 CC=1 STAY ON THIS LINE BUT TERMINATE PRINT. 00257000 CC=2 SKIP TO NEXT LINE - MORE TO COME. 00258000 CC=3 SKIP TO NEXT LINE - TERMINATE PRINT.; 00259000 REAL STREAM PROCEDURE OCTAL(I); VALUE I; 00260000 BEGIN SI:=LOC I; DI:=LOC OCTAL; DS:=8OCT 00261000 END; 00262000 IF L:=LINESIZE LEQ 9 OR L GTR 72 THEN L:=72; K:=2; 00263000 IF CC GTR 1 AND CHRCOUNT GTR 0THEN TERPRINT; 00264000 IF CHRCOUNT+(I:=OCTAL(WD.[1:11])) GTR L THEN 00265000 00266000 BEGIN APPENDTOBUFF(LINEBUFFER,CHRCOUNT, 00267000 0,WD,2,K:=L-CHRCOUNT); 00268000 CHRCOUNT:=L; TERPRINT; 00269000 00270000 I:=I-K; 00271000 00272000 END; 00273000 APPENDTOBUFF(LINEBUFFER,CHRCOUNT,0,WD,K,I); 00274000 00274900 CHRCOUNT:=CHRCOUNT+I; 00275000 IF BOOLEAN(CC) THEN 00276000 IF CC=-1 THEN BEGIN LINETOG:=FALSE; 00276010 TERPRINT; LINETOG:=TRUE 00276020 END ELSE TERPRINT; 00276030 END; 00277000 BOOLEAN PROCEDURE FUNCTIONHEADER(SPECS,HADDR); 00277500 ARRAY SPECS[0]; REAL HADDR; FORWARD; 00277600 00278000 00279000 00280000 REAL PROCEDURE LINENUMBER(R); VALUE R; REAL R; 00280100 COMMENT STARTS ON 8030000; 00280110 FORWARD; 00280120 00280130 PROCEDURE INDENT(R); VALUE R; REAL R; 00281000 BEGIN 00281100 INTEGER STREAM PROCEDURE FORM(A,I,K);VALUE K,I; 00281200 BEGIN 00281300 LOCAL T1,T2; 00281400 LABEL SHORT,L,M,FINIS; 00281500 TALLY:=K; FORM:=TALLY; 00281600 SI:=LOC I; DI:=LOC T1; IF 8SC=DC THEN 00281700 BEGIN DI:=A; K(DS:=LIT" "); GO FINIS 00281800 END; 00281900 SI:=LOC I; DI:=A; TALLY:=3; DS:=LIT"["; 00282000 IF SC GTR "0" THEN IF SC LSS "0" THEN ; 00282100 3(TALLY:=TALLY+1; IF TOGGLE THEN DS:=CHR ELSE 00282200 IF SC NEQ "0" THEN DS:=CHR ELSE 00282300 BEGIN TALLY:=TALLY+63; SI:=SI+1 00282400 END ); 00282500 DS:=CHR; T1:=TALLY; TALLY:=4; SI:=SI+3; 00282600 4(IF SC NEQ "0" THEN JUMP OUT TO M; 00282700 TALLY:=TALLY+63; SI:=SI-1); GO TO L; 00282800 M: 00282900 T2:=TALLY; SI:=LOC I; SI:=SI+4; DS:=LIT"."; DS:=T2 CHR; 00283000 TALLY:=T1; TALLY:=TALLY+T2; TALLY:=TALLY+1; T1:=TALLY; 00283100 L: 00283200 DS:=LIT"]"; TALLY:=K; 00283300 T1(TALLY:=TALLY+63; T2:=TALLY; SI:=LOC T2; SI:=SI+7; 00283400 IF SC="0" THEN JUMP OUT TO SHORT); 00283500 T2(DS:=LIT" "); GO FINIS; 00283600 SHORT: 00283700 TALLY:=T1; TALLY:=TALLY+1; FORM:=TALLY; DS:=LIT" "; 00283800 FINIS: 00283900 DS:=RESET; DS:=5SET; 00284000 END; 00284100 IF R LSS 0 THEN R:=LINENUMBER(-R) ELSE R:=ABS(R); % -0 00285000 CHRCOUNT:=FORM(LINEBUFF,R,MARGINSIZE)+1 00286000 00286100 END; 00287000 INTEGER PROCEDURE HEADER(ADDR1,ADDR2,BUF); VALUE ADDR1,ADDR2; 00287010 INTEGER ADDR1, ADDR2; ARRAY BUF[0]; 00287020 BEGIN 00287030 INTEGER STREAM PROCEDURE HEADRR(ADDR1,ADDR2,BUF); VALUE ADDR1, 00287100 ADDR2; 00287110 BEGIN 00287120 LOCAL C,T,TDI; 00287130 LOCAL QM,AR; 00287132 LABEL L,ENDSCAN,M,N; 00287140 DI:=LOC QM; DS:=2RESET; DS:=2SET; 00287142 DI:=LOC AR; DS:=RESET; DS:=5SET; 00287144 DI:=BUF; 00287180 SI:=ADDR1; 00287200 L: T:=SI; TDI:=DI; 00287210 DI:=LOC QM; IF SC=DC THEN GO TO ENDSCAN; 00287212 DI:=LOC AR; SI:=SI-1; IF SC=DC THEN GO TO ENDSCAN; 00287214 SI:=LOC T; DI:=LOC ADDR2; 00287220 IF 8SC=DC THEN COMMENT END OF SCAN; 00287230 GO TO ENDSCAN; 00287240 SI:=T; DI:=TDI; DS:=CHR; 00287250 GO TO L; 00287260 ENDSCAN: 00287300 SI:=TDI; 00287310 M: SI:=SI-1; 00287320 IF SC=" " THEN GO TO M; 00287330 SI:=SI+1; 00287332 ADDR2:=SI; 00287340 SI:=BUF; 00287350 N: T:=SI; DI:=LOC ADDR2; 00287360 SI:=LOC T; 00287370 IF 8SC NEQ DC THEN 00287380 BEGIN 00287390 TALLY:=TALLY+1; TDI:=TALLY; 00287400 SI:=LOC TDI; SI:=SI+7; 00287410 IF SC="0" THEN 00287420 BEGIN TALLY:=C; TALLY:=TALLY+1; C:=TALLY; 00287430 TALLY:=0; 00287440 END; 00287450 SI:=T; SI:=SI+1; GO TO N; 00287460 END; 00287470 HEADRR:=TALLY; SI:=LOC C; DI:=LOC HEADRR; SI:=SI+1; DS:=6 CHR; 00287480 END; 00287490 HEADER:=HEADRR(ADDR1,ADDR2,BUF); 00287492 END OF PHONY HEADER; 00287494 PROCEDURE STARTSCAN; 00299000 BEGIN 00300000 00300100 00300600 00300700 LADDRESS:= 00301000 ADDRESS:=ABSOLUTEADDRESS; 00302000 BEGIN TERPRINT; 00304000 END; 00305000 READ(TWXIN[STOP],29,BUFFER[*]); 00306000 BUFFER[30]:=0&31[1:43:5]; 00307000 ITEMCOUNT:=0; 00312000 EOB:=0 00313000 END; 00314000 PROCEDURE FORMROW(CC,BL,A,S,N); VALUE CC,BL,S,N; INTEGER CC,BL, 00315000 S,N; ARRAY A[0]; 00316000 COMMENT: CC--SAME CODE AS IN FORMWD, LINE 253000 00316010 BL--#BLANKS TO PUT IN FRONT OF IT 00316020 A--ARRAY WHERE THE STUFF TO PUT ON LINE IS STORED 00316030 S--#CHARACTERS TO SKIP AT START OF A 00316040 N--#CHARACTERS TO TAKE FROM A TO PUT ON OUTPUT LINE; 00316050 BEGIN INTEGER K; 00317000 INTEGER T; 00317100 IF CC GTR 1 AND CHRCOUNT GTR 0 THEN TERPRINT; 00318000 IF K:=LINESIZE LEQ 9 OR K GTR 72 THEN K:=72; 00319000 WHILE CHRCOUNT+N+BL GTR K DO 00320000 BEGIN 00321000 APPENDTOBUFFER(LINEBUFFER,CHRCOUNT,BL,A,S,T:=K-CHRCOUNT-BL); 00322000 CHRCOUNT:=K; TERPRINT; 00323000 S:=S+T; N:=N-T; 00324000 BL:=0; 00325000 END; 00326000 APPENDTOBUFFER(LINEBUFFER,CHRCOUNT,BL,A,S,N); 00327000 00327900 CHRCOUNT:=CHRCOUNT+N+BL; 00328000 IF BOOLEAN(CC) THEN 00329000 IF CC=-1 THEN BEGIN LINETOG:=FALSE; 00329010 TERPRINT; LINETOG:=TRUE; 00329020 END ELSE TERPRINT; 00329030 END; 00330000 PROCEDURE NUMBERCON(R,A); VALUE R; REAL R; ARRAY A[0]; 00331000 BEGIN FORMAT F(F24.*), G(E24.*); 00332000 REAL S; DEFINE MAXIM = 10@9#; 00332010 00333000 STREAM PROCEDURE ADJUST(A,B); 00334000 BEGIN LOCAL T,FRAC,MANT,T1,TSI,TDI; 00335000 DI:=LOC T; DI:=DI+1; T1:=DI; 00336000 SI:=B; DI:=A; DI:=DI+2; 00337000 24(IF SC=" " THEN SI:=SI+1 ELSE 00338000 BEGIN TSI:=SI; SI:=LOC T; 00339000 IF SC="1" THEN; SI:=TSI; 00340000 IF TOGGLE THEN 00341000 IF SC NEQ "0" THEN 00342000 IF SC="@" THEN BEGIN 00343000 TSI:=SI; DI:=T1; DS:=LIT"1"; JUMP OUT; 00343010 END ELSE FRAC:=TALLY 00344000 ELSE TALLY := TALLY+0 00345000 ELSE 00346000 IF SC="." THEN 00347000 BEGIN MANT:=TALLY; TDI:=DI; DI:=LOC T; DS:= 00348000 LIT"1"; TALLY:=0;DI:=TDI; 00349000 END; 00350000 TALLY:=TALLY+1; DS:=CHR 00351000 END); 00352000 SI:=LOC MANT; SI:=SI+7; IF SC="0" THEN MANT:=TALLY; 00353000 00354000 TALLY:=MANT; SI:=LOC FRAC; SI:=SI+7; IF SC GTR "0" 00355000 THEN TALLY:=TALLY+1; TALLY:=TALLY+FRAC; MANT:=TALLY; 00356000 SI:=T1; IF SC="1" THEN BEGIN 00356010 DI:=A; DI:=DI+MANT; DI:=DI+2; 00356020 SI:=TSI; DS:=4CHR; 00356030 TALLY:=TALLY+4; MANT:=TALLY; END; 00356040 SI:=LOC MANT; SI:=SI+6; DI:=A; DS:=2CHR; 00357000 END; 00358000 IF S:=ABS(R) GEQ MAXIM OR S LEQ 10*(-DIGITS) AND S NEQ 0 THEN 00358010 WRITE(SCR[*],G,DIGITS,R) ELSE 00358020 WRITE(SCR[*],F,DIGITS,R); 00359000 ADJUST(A,SCR) 00360000 END; 00361000 PROCEDURE STOREPSR; 00361010 BEGIN INTEGER I; 00361020 DELETE1(WORKSPACE,0); 00361030 I:=STORESEQ(WORKSPACE,PSR,PSRSIZE|8); 00361040 COMMENT USED TO CALL WRAPUP; 00361050 END; 00361060 PROCEDURE RESCANLINE; 00361070 BEGIN ADDRESS:=ABSOLUTEADDRESS; EOB:=0; END; 00361072 PROCEDURE PROCESS(MODE);VALUE MODE; INTEGER MODE; FORWARD; 00361100 PROCEDURE MESSAGEHANDLER; FORWARD; 00362000 PROCEDURE FUNCTIONHANDLER; FORWARD; 00362100 PROCEDURE ERRORMESS(N,ADDR,R); VALUE N,ADDR,R; REAL R; 00362105 INTEGER N;REAL ADDR;FORWARD; COMMENT LINE 5000000; 00362107 STREAM PROCEDURE SETFIELD(A,S,L,R); VALUE S,L,R; 00362110 BEGIN DI:=A; DI:=DI+S; SI:=LOC R; SI:=SI+8; L(SI:=SI-1); 00362120 DS:=L CHR; 00362130 END; 00362140 COMMENT: VALUE OF GETFIELD IS L CHARACTERS, STARTING AT J-TH 00362145 CHARACTER OF A, RIGHT-ADJUSTED. L MUST BE LEQ 8 AND 00362146 J MUST BE LESS THAT 64; 00362147 REAL STREAM PROCEDURE GETFIELD(A,S,L); VALUE S,L; 00362150 BEGIN SI:=A; SI:=SI+S; DI:=LOC GETFIELD; DI:=DI+8; L(DI:=DI-1); 00362160 DS:=L CHR; 00362170 END; 00362180 REAL PROCEDURE TOPLINE(ORD); VALUE ORD; INTEGER ORD; 00362200 BEGIN 00362210 INTEGER STREAM PROCEDURE CON(A); VALUE A; 00362220 BEGIN SI:=LOC A; DI:=LOC CON; DS:=8OCT END; 00362230 ARRAY A[0:1]; INTEGER I; 00362240 I:=CONTENTS(ORD,SIZE(ORD)-1,A); 00362250 TOPLINE:=CON(A[0])/10000 00362260 END; 00362270 BOOLEAN PROCEDURE FUNCTIONHEADER(SPECS,HADDR); 00500000 ARRAY SPECS[0]; REAL HADDR; 00500100 BEGIN 00500150 LABEL A,B,C; 00500200 INTEGER P; 00500300 DEFINE NOTE=HADDR.[24:24]:=ADDRESS#,P8=8|P+1#; 00500325 ERR:=0; 00500350 SPECS[0]:=SPECS[1]:=SPECS[2]:=SPECS[3]:=0; 00500400 NOTE; HADDR.[1:23]:=GT1:=ADDRESS; 00500450 IF SCAN AND IDENT THEN 00500500 BEGIN 00500600 TRANSFER(ACCUM,2,SPECS,1,7); 00500700 NOTE; 00500750 IF SCAN THEN 00500800 IF LFTARROW THEN 00500900 BEGIN 00501000 SPECS[1]:=1; 00501100 SPECS[3]:=1; 00501150 TRANSFER(SPECS,1,SPECS,33,7); 00501200 GT2:=ADDRESS; 00501250 IF SCAN AND IDENT THEN 00501300 BEGIN 00501400 TRANSFER(ACCUM,2,SPECS,1,7); 00501500 NOTE; 00501550 IF SCAN THEN 00501600 C: IF IDENT THEN 00501700 BEGIN 00501800 P:=(SPECS[3]:=SPECS[3]+1)+3; 00501850 TRANSFER(ACCUM,2,SPECS,P8,7); 00501900 SPECS[2]:=1; 00502000 NOTE; 00502050 IF SCAN THEN IF IDENT THEN 00502100 BEGIN SPECS[2]:=2; 00502200 P:=(SPECS[3]:=SPECS[3]+1)+2; 00502250 TRANSFER(SPECS,1,SPECS,P8+8,7); 00502300 TRANSFER(SPECS,P8,SPECS,1,7); 00502400 TRANSFER(ACCUM,2,SPECS,P8,7); 00502500 00502550 B: NOTE; IF SCAN THEN 00502600 A: IF SEMICOLON THEN IF SCAN THEN 00502610 IF IDENT THEN 00502620 BEGIN 00502630 P:=(SPECS[3]:=SPECS[3]+1)+3; 00502640 TRANSFER(ACCUM,2,SPECS,P8,7); 00502650 GO TO B; 00502660 END ELSE GO TO A 00502670 ELSE ELSE ELSE 00502680 END ELSE GO TO A 00502690 ELSE END 00502700 ELSE GO TO A ELSE 00502800 END ELSE ERRORMESS(ERR:=1,GT2,0) 00502900 END ELSE GO TO C 00503000 ELSE 00503100 END ELSE ERRORMESS(ERR:=SYNTAXERROR,GT1,0); 00503200 FUNCTIONHEADER:=ERR=0; 00504500 ADDRESS:=HADDR.[24:24]; 00504550 END FUNCTIONHEADER; 00504600 00801810 INTEGER PROCEDURE DAYTIME(B); ARRAY B[0]; FORWARD; 02080000 COMMENT ON LINE 8014000, ARRAY B MUST HAVE LENGTH 02080010 AT LEAST 3 WDS; 02080020 PROCEDURE EDITLINE; FORWARD; 02080030 INTEGER PROCEDURE LENGTH(A,M);VALUE M; BOOLEAN M; ARRAY A[0]; 02080040 FORWARD; COMMENT LINE 8007900; 02080050 BOOLEAN PROCEDURE LABELSCAN(L,K); VALUE K; INTEGER K; 02080060 ARRAY L[0]; FORWARD; COMMENT LINE 8013910; 02080070 02080080 02080090 PROCEDURE CHECKSEQ(SEQ,L,INC); REAL SEQ,L,INC; FORWARD; 02080100 COMMENT ON LINE 8040000; 02080200 PROCEDURE RELEASEARRAY(D);VALUE D; REAL D; 03000500 BEGIN COMMENT RELEASE PERMANENT STORAGE FOR THE ARRAY DESC D; 03000510 INTEGER K,J,PT; 03000520 ARRAY BLOCK[0:32]; %SEE MAXWORDSTORE, LINE 17260 03000530 ARRAY TEMP[0:1]; 03000535 IF D.RF NEQ 0 THEN 03000540 BEGIN DELETE1(WS,D.DIMPTR); 03000550 K:=CONTENTS(WS,D.INPTR,BLOCK)-1; 03000560 DELETE1(WS,D.INPTR); 03000570 FOR J:=0 STEP 2 UNTIL K DO 03000580 BEGIN TRANSFER(BLOCK,J,TEMP,6,2); 03000585 PT:=TEMP[0]; DELETE1(WS,PT); END; 03000590 END; 03000600 END; 03000610 PROCEDURE TRANSFERSP(DIR,SP,L,B,M,N); VALUE DIR,N,M,L; 03001000 INTEGER DIR,N,M,L; 03001100 ARRAY SP[0,0],B[0]; 03001200 BEGIN COMMENT 03001300 DIR= INTO: TRANSFER N WORDS FROM B[L] INTO SP[M] 03001400 (ACTUALLY SP[*,M] SINCE ARRAY ROW IS USUALLY THE ARG) 03001450 DIR= OUTOF (OPPOSITE); 03001500 STREAM PROCEDURE MOVER(DIR,SP,M,B,L,N); VALUE DIR, 03001600 L,M,N; 03001700 BEGIN LOCAL T; 03001800 SI:=LOC L; DI:=LOC T; DI:=DI+1; DS:=7CHR; 03001900 SI:=SP; T(16(SI:=SI+32)); L(SI:=SI+8); L:=SI; 03002000 SI:=LOC M; DI:=LOC T; DI:=DI+1; DS:=7CHR; 03002100 SI:=B; T(16(SI:=SI+32)); M(SI:=SI+8); M:=SI; 03002110 SI:=LOC N; DI:=LOC T; DI:=DI+1; DS:=7CHR; 03002120 SI:=LOC DIR; SI:=SI+7; 03002130 IF SC="0" THEN 03002140 BEGIN SI:=M; DI:=L 03002150 END ELSE 03002160 BEGIN SI:=L ; DI:=M 03002170 END; 03002180 T(2(DS:=32WDS)); DS:=N WDS; 03002190 END; 03002200 INTEGER K; 03002210 WHILE N:=N-K GTR 0 DO 03002300 MOVER(DIR,SP[(L:=L+K)DIV SPRSIZE,*], 03002400 M:=M+K,B,K:=L MOD SPRSIZE, 03002500 K:=MIN(SPRSIZE-K,N)) 03002600 END; 03002700 03002800 PROCEDURE DUMPOLISH(SP,PD); VALUE PD; REAL PD; ARRAY SP[0,0]; 03008000 BEGIN INTEGER L; 03008100 LABEL SKIPREST; 03008150 INTEGER I,N,M,U; REAL T; 03008200 L:=PD.SPF; 03008300 I:=SP[LOC]+L; 03008400 FOR L:=L+2 STEP 1 UNTIL I DO 03008500 IF (T:=SP[LOC]).TYPEFIELD=FUNCTION THEN 03008510 BEGIN % OUTPUT MESSAGE AND NAME 03008520 FORMWD(2,"5FUNC: "); 03008530 N:=T.LOCFIELD; % N HAS LOCATION OF DESCRIPTOR 03008540 N:=N-1; % BACK UP ONE TO GET NAME 03008550 GTA[0]:=SP[NOC]; 03008560 FORMROW(1,1,GTA,1,7); 03008570 END 03008580 ELSE % MIGHT BE AN OPERATOR 03008590 IF T.TYPEFIELD=OPERATOR THEN 03008600 BEGIN COMMENT OUTPUT MESSAGE AND OP CODE; 03008610 FORMWD(2,"5ATOR: "); 03008620 NUMBERCON(T.OPTYPE,ACCUM); 03008623 FORMROW(0,1,ACCUM,2,ACOUNT); 03008626 NUMBERCON(T.LOCFIELD,ACCUM); 03008630 FORMROW(1,1,ACCUM,2,ACOUNT); 03008640 END ELSE %MAY BE A CONSTANT 03008650 IF T.TYPEFIELD=CONSTANT THEN 03008660 BEGIN COMMENT GET DATA DESCRIPTOR; 03008670 N:=T.LOCFIELD; 03008680 FORMWD(2,"5CONS: "); 03008690 T:=SP[NOC]; %T HAS THE DATA DESCRIPTOR 03008700 IF T.SPF=0 THEN BEGIN % A NULL VECTOR 03008702 FORMWD(1,"4NULL "); 03008704 GO TO SKIPREST; END; 03008706 N:=T.SPF; %N HAS THE SCALAR OR TOP OF VECTOR LOC. 03008710 IF BOOLEAN(T.SCALAR) THEN M:=U:=N ELSE 03008720 BEGIN U:=SP[NOC]+N; M:=N+1; %UPPER AND LOWER BOUNDS 03008730 END; 03008740 IF BOOLEAN(T.CHRMODE) THEN %CHARACTER FORMAT 03008741 BEGIN COMMENT SP[NOC] IS NUMBER OF CHRS; 03008742 TRANSFERSP(OUTOF,SP,M,BUFFER,0,ENTIER(((T:= 03008743 SP[NOC])-1)DIV 8+1)); 03008744 FORMROW(1,1,BUFFER,0,T); 03008745 END ELSE % SHOULD TEST FOR NULL...DO IT LATER. 03008746 FOR N:=M STEP 1 UNTIL U DO 03008750 BEGIN NUMBERCON(SP[NOC],ACCUM); 03008760 FORMROW(0,1,ACCUM,2,ACOUNT); 03008770 END; 03008780 TERPRINT; 03008790 SKIPREST: 03008795 END ELSE COMMENT MUST BE AN OPERAND; 03008800 IF T.TYPEFIELD=LOCALVAR THEN 03008810 BEGIN FORMWD(2,"5LOCL: "); 03008820 N:=T.SPF; % N HAS LOCATION OF NAME; 03008830 GTA[0]:=SP[NOC]; % PUT NAME IN GTA 03008840 FORMROW(1,1,GTA,1,7); 03008850 END ELSE 03008860 BEGIN COMMENT TREAT IT AS VARIABLE; 03008870 N:=T.LOCFIELD; COMMENT N HAS LOC OF DESCRIPTOR; 03008880 N:=N-1; COMMENT BACK UP OVER THE DESCRIPTOR; 03008890 GTA[0]:=SP[NOC]; 03008900 FORMWD(2,"5AND : "); 03008910 FORMROW(1,1,GTA,1,7); 03008920 END; 03008930 END; 03009000 03023400 PROCEDURE PROCESS(MODE); VALUE MODE; INTEGER MODE; 03100000 BEGIN 03100100 OWN INTEGER J; 03100105 OWN REAL RESULTD; 03100110 LABEL EXPOVRL,INTOVRL,INDEXL,FLAGL,ZEROL; 03100120 MONITOR EXPOVR,INTOVR,INDEX,FLAG,ZERO; 03100130 LABEL DEBUGSP; %DEBUGGING PURPOSES ONLY. 03100140 INTEGER PROCEDURE BUILDCONSTANT(LASTCONSTANT); 03100410 INTEGER LASTCONSTANT; FORWARD; 03100415 INTEGER PROCEDURE GETSPACE(LENGTH); VALUE LENGTH; 03100420 INTEGER LENGTH; FORWARD; 03100430 PROCEDURE OPERANDTOSYMTAB(L);VALUE L;INTEGER L;FORWARD; 03100432 REAL PROCEDURE BUILDALPHA(LASTCONSTANT); 03100440 INTEGER LASTCONSTANT; FORWARD; 03100445 INTEGER PROCEDURE BUILDNULL(LASTCONSTANT); 03100450 INTEGER LASTCONSTANT; FORWARD; 03100452 PROCEDURE SCRATCHDATA(D);VALUE D;REAL D; FORWARD; 03100460 COMMENT LINE 3121400; 03100462 PROCEDURE FORGETPROGRAM(U);VALUE U;REAL U; FORWARD; 03100470 COMMENT ANALYZE IS IN PROCESS BECAUSE OWN ARRAY SP 03100805 IS ADDRESSED INCORRECTLY OTHERWISE; 03100807 REAL PROCEDURE ANALYZE(DISPLAYOP); VALUE DISPLAYOP;BOOLEAN DISPLAYOP; 03100810 BEGIN COMMENT 03100840 BC= BUILDCONSTANT, 03100850 GS= GET SPACE PROCEDURE ; 03100860 ARRAY INFIX[0:MAXPOLISH]; 03100870 03100880 INTEGER LASTCONSTANT; 03100890 DEFINE GS=GETSPACE#; 03100900 BOOLEAN STREAM PROCEDURE EQUAL(A,B); 03100910 BEGIN SI:=A; SI:=SI+1; DI:=B; DI:=DI+2; 03100920 IF 7SC=DC THEN TALLY:=1; 03100930 EQUAL:=TALLY; 03100940 END; 03100950 PROCEDURE UNSTACK(DEST,L,ORIG,OTOP,N,CHR1,CHR2); 03100960 VALUE N,CHR1,CHR2; 03100962 INTEGER N,CHR1,CHR2,L,OTOP; 03100970 ARRAY DEST[0,0],ORIG[0]; 03100980 BEGIN 03100990 REAL T,U; 03100992 WHILE OTOP GTR 0 AND N GTR 0 AND ERR=0 DO 03101000 IF(IF (T:=ORIG[OTOP]).TYPEFIELD=FUNCTION THEN FALSE ELSE 03101010 U:=T.LOCFIELD=CHR1 OR U=CHR2) THEN %UNSTACK 03101012 BEGIN 03101014 IF N GTR 1 THEN 03101020 IF U=CHR2 THEN ERR:=SYNTAXERROR ELSE 03101030 OTOP:=OTOP-1; 03101032 N:=N-1; 03101040 END ELSE 03101050 COMMENT WE ARE LOOKING AT AN OPERATOR OR A FUNCTION; 03101060 03101070 03101080 BEGIN 03101090 IF J NEQ 0 THEN 03101100 BEGIN L:=L+1; 03101110 DEST[LOC]:=ORIG[OTOP] 03101120 END; 03101130 OTOP:=OTOP-1 03101140 END; 03101150 IF N GTR 1 THEN ERR:=SYNTAXERROR; 03101160 END; 03101170 INTEGER ITOP,K,L,I; 03101180 INTEGER M,N,FLOC; REAL T; 03101182 LABEL SKIPSCAN,FILLER; 03101184 LABEL SPFULLAB; 03101190 03101200 03101202 PROCEDURE FORGETSPACE(L,LENGTH,SP); VALUE L,LENGTH; 03101210 INTEGER L,LENGTH; ARRAY SP[0,0]; 03101220 BEGIN IF LENGTH GTR 0 THEN 03101222 BEGIN SP[LOC]:=SP[0,0]; 03101230 SP[LOC].LEN:=LENGTH; SP[0,0]:=L 03101240 END; 03101242 END; 03101250 03101251 IF CURRENTMODE=FUNCMODE OR STACKBASE=0 THEN FLOC:=0 ELSE 03101252 03101253 BEGIN L:=STACKBASE+1;L:=SP[LOC].SPF+1;M:=SP[LOC].SPF+L; 03101254 FLOC:= IF M=L OR BOOLEAN(T:=SP[MOC]).SUSPENDED THEN 0 ELSE T.SPF03101256 03101257 END; 03101258 03101260 T:=ADDRESS; 03101270 ITOP:=0; 03101280 DO 03101290 SKIPSCAN: 03101300 IF ITOP LSS MAXPOLISH THEN 03101350 BEGIN 03101400 INFIX[ITOP:=ITOP+1].ADDRFIELD:=T; 03101450 IF SPECIAL THEN 03101500 IF QUOTEV THEN % CONSTANT VECTOR 03101510 BEGIN INFIX[ITOP].TYPEFIELD:=CONSTANT; 03101515 IF T:=BUILDALPHA(LASTCONSTANT) NEQ 0 THEN 03101520 INFIX[ITOP].LOCFIELD:=T ELSE ERR:=SYNTAXERROR 03101525 END ELSE % ORDINARY OPERATOR 03101530 BEGIN INFIX[ITOP].TYPEFIELD:=OPERATOR; 03101550 INFIX[ITOP].LOCFIELD:=ENTIER(ACCUM[0]); 03101600 END ELSE 03101650 IF NUMERIC THEN 03101700 IF ERR NEQ 0 THEN COMMENT NOTHING; ELSE 03101710 BEGIN INFIX[ITOP].TYPEFIELD:=CONSTANT; 03101750 IF CURRENTMODE=FUNCMODE THEN 03101760 COMMENT DO NOT STORE NUMERIC IN SCRATCH PAD; 03101765 DO UNTIL NOT SCAN OR NOT NUMERIC %THE NULL STATEMENT 03101770 ELSE 03101780 BEGIN 03101790 T:=BUILDCONSTANT(LASTCONSTANT); 03101800 IF T=0 THEN ERR:=IF ERR=0 THEN VALUEERROR ELSE ERR ELSE 03101850 INFIX[ITOP].LOCFIELD:=T; 03101860 END; 03101870 IF EOB=0 AND ERR=0 THEN GO TO SKIPSCAN; 03101900 END ELSE 03101950 IF IDENT THEN 03102000 BEGIN INFIX[ITOP].DID:=OPERAND; %SET OPTYPE=NILADIC 03102050 IF NOT(FUNCMODE EQL CURRENTMODE) THEN 03102100 BEGIN J:=0; 03102150 IF FLOC GTR 0 THEN %CHECK LOCAL NAMES 03102200 BEGIN L:=FLOC+2; 03102250 K:=SP[LOC]-2;%LAST ALPHA POINTER IN TABLE 03102350 %SHOULD CONVERT TO BINARY SEARCH 03102390 T:=L+4; 03102392 FOR L:=T STEP 2 UNTIL K DO 03102400 IF EQUAL(SP[LOC],ACCUM) THEN 03102420 BEGIN J:=L;L:=K;I:=0; 03102430 INFIX[ITOP].SPF:=J; 03102440 INFIX[ITOP].RF:=M-FLOC; 03102442 J:=(J-T+2)/2; 03102450 END; 03102460 END; 03102500 03102510 03102550 IF J EQL 0 THEN 03102600 BEGIN COMMENT LOOK IN SP SYMBOL TABLE; 03102650 IF L:=SYMBASE NEQ 0 THEN COMMENT OK TO LOOK; 03102700 BEGIN T:=SP[LOC];K:=L+T; 03102750 COMMENT T=N VARS TIMES 2. K IS TOP LIMIT; 03102800 FOR L:=L +1 STEP 2 UNTIL K DO 03102850 IF EQUAL(SP[LOC],ACCUM) THEN 03102900 BEGIN 03102925 INFIX[ITOP].TYPEFIELD:=I:=SP[LOC].TYPEFIELD; 03102950 L:=J:=L+1; 03102960 IF I=FUNCTION THEN BEGIN 03102961 INFIX[ITOP].RF:=SP[LOC].RETURNVALUE; 03102962 INFIX[ITOP].OPTYPE:=SP[LOC].NUMBERARGS;END; 03102965 L:=K; 03102970 END; 03102980 IF J EQL 0 THEN 03103000 IF T LSS MAXSYMBOL|2 THEN %INSERT ID 03103050 BEGIN L:=K+1; %NEXT AVAILABLE. 03103100 FILLER: SETFIELD(GTA,0,1,0); 03103180 TRANSFER(ACCUM,2,GTA,1,7); 03103200 SP[LOC]:=GTA[0];%STORE VARIABLE NAME 03103225 OPERANDTOSYMTAB(L);%SET TYPEFIELD AND DESC. 03103250 IF GT1=FUNCTION THEN%FUNCTION-FIX INFIX 03103300 BEGIN 03103325 INFIX[ITOP].OPTYPE:=GTA[1].NUMBERARGS; 03103326 INFIX[ITOP].TYPEFIELD:=FUNCTION; 03103330 INFIX[ITOP].RF:=GTA[1].RETURNVALUE; 03103350 END; 03103400 J:=L+1; 03103425 L:=SYMBASE;SP[LOC]:=T+2;%UPDATE SYM TAB # 03103430 END ELSE SPFULLAB: ERR:=SPERROR;%TAB FULL 03103450 END ELSE %CREATE SYMBOL TABLE 03103500 BEGIN 03103550 SYMBASE:=L:=GS(MAXSYMBOL|2+1); 03103600 IF ERR NEQ 0 THEN 03103610 BEGIN SYMBASE:=0; 03103620 GO TO SPFULLAB; 03103630 END; 03103640 T:=0; L:=L+1; 03103650 GO TO FILLER; 03103700 END 03103750 END ELSE INFIX[ITOP].DID:=LOCALVAR&1[44:47:1]; 03103800 INFIX[ITOP].LOCFIELD:=J 03103850 END 03103900 END ELSE ERR:=SYSTEMERROR; 03103950 IF ERR EQL 0 THEN T:=ADDRESS 03104000 END ELSE ERR:=SPERROR 03104050 UNTIL NOT(SCAN AND ERR=0); %DROP THRU WHEN INPUT FIN OR ERR 03104060 COMMENT NOW LOOK FOR THE POLISH; 03104100 IF ERR NEQ 0 THEN 03104150 BEGIN ERRORMESS(ERR,INFIX[ITOP].ADDRFIELD,0); 03104200 END ELSE 03104250 BEGIN COMMENT MAKE UP THE POLISH; 03104300 ARRAY OPERATORS[0:ITOP]; 03104350 BOOLEAN PROCEDURE ANDORATOR (VAR,TYPE); 03104356 VALUE VAR, TYPE; 03104358 REAL VAR,TYPE; 03104360 BEGIN 03104362 REAL T; 03104363 LABEL OPERAN, ATOR; 03104364 COMMENT PROCEDURE TRUE IF VAR IS OF TYPE SPECIFIED; 03104366 IF T:=VAR.TYPEFIELD=OPERATOR THEN 03104368 IF T:=VAR.LOCFIELD NEQ RGTPARENV AND T NEQ 03104370 QQUAD AND T NEQ QUAD AND T NEQ 03104371 RGTBRACKETV THEN GO ATOR 03104372 ELSE GO OPERAN 03104374 ELSE 03104376 IF T=FUNCTION THEN 03104378 IF VAR.OPTYPE GTR NILADIC THEN 03104380 ATOR: ANDORATOR:=TYPE=OPERATOR 03104382 ELSE GO OPERAN 03104384 ELSE 03104386 OPERAN: ANDORATOR:=TYPE=OPERAND; 03104388 END OF ANDORATOR; 03104390 BOOLEAN PROCEDURE RGTOPERAND(VAR); VALUE VAR; REAL VAR; 03104391 BEGIN REAL T; DEFINE RT=RGTOPERAND:=TRUE#; 03104392 IF T:=VAR.TYPEFIELD=OPERAND OR T=CONSTANT OR T=LOCALVAR THEN RT 03104393 ELSE IF T=OPERATOR AND VAR.LOCFIELD=LFTPARENV THEN RT 03104394 ELSE IF T=FUNCTION AND VAR.OPTYPE LEQ MONADIC THEN RT; 03104395 END OF RGTOPERAND; 03104396 BOOLEAN VALID; 03104398 INTEGER OTOP; 03104400 INTEGER BCT,N; REAL COLONCTR; 03104402 LABEL STACKOPERAND, STACKFUNCTION; 03104425 DEFINE PTOP=L#; 03104450 LABEL AROUND, NOK, OK, LFTARROWL, LFTPARENL, RGTPARENL, 03104455 SLASHL,EXPL,ROTL,MONADICL,DYADICL,ERRL,SORTL, 03104456 SEMICOLONL, QUADL, DOTL, RELATIONL, 03104457 LFTBRACKETL, RGTBRACKETL, QUOTEQUADL; 03104458 SWITCH OPERATORSWITCH:= % IN GROUPS OF 5, STARTING AT 1 03104459 NOK, NOK, NOK, LFTARROWL, % 1-4 03104461 MONADICL, SLASHL, OK, LFTPARENL,RGTPARENL, %5-9 03104463 QUADL,LFTBRACKETL,RGTBRACKETL,ERRL,QUOTEQUADL, %10-14 03104465 SEMICOLONL, OK, DOTL, OK, OK, % 15-19 03104467 OK,DYADICL,DYADICL,MONADICL,RELATIONL, % 20-24 03104469 RELATIONL, RELATIONL, RELATIONL, RELATIONL, 03104471 RELATIONL, % 25-29 03104472 OK, OK, OK, OK, OK, % 30-34 03104473 OK, OK, ROTL, EXPL, OK, % 35-39 03104475 OK,OK,OK,OK,DYADICL, % 40-44 03104477 OK, OK, ERRL, OK, OK, % 45-49 03104479 OK, NOK, NOK, NOK, OK, % 50-54 03104481 SORTL,SORTL,OK,OK,OK, % 55-59 03104483 DYADICL, DYADICL, MONADICL; % 60-62 03104484 %----------------------------------------------- 03104500 COMMENT GET AN AREA OF SCRATCH PAD IF WE ARE NOT IN 03104550 THE SYNTAX CHECKING MODE; 03104600 J:=(IF CURRENTMODE=FUNCMODE THEN 0 ELSE 03104650 GS(ITOP+3)); 03104700 I:=ITOP+1; 03104750 COMMENT A QUICK SYNTAX CHECK; 03104774 IF ANDORATOR(INFIX[ITOP],OPERATOR) THEN ERR:=SYNTAXERROR; 03104775 L:=J+1; COMMENT POLISH WILL START TWO UP IN ARRAY; 03104800 WHILE ERR=0 AND I GTR 1 DO 03104815 IF T:=INFIX[I:=I-1].TYPEFIELD=OPERATOR THEN 03104817 BEGIN 03104818 GO OPERATORSWITCH[INFIX[I].LOCFIELD]; 03104821 ROTL: 03104823 IF I=1 OR NOT ANDORATOR(INFIX[I-1],OPERAND) THEN GO OK; 03104825 T:=INFIX[I]; 03104826 T.LOCFIELD:=ROTATE; 03104827 T.OPTYPE:=IF INFIX[I].OPTYPE NEQ DYADIC THEN MONADIC ELSE DYADIC; 03104828 INFIX[I]:=T; GO TO STACKFUNCTION; 03104829 EXPL: 03104830 SLASHL: BEGIN DEFINE STARTSEGMENT= #; %///////////////////// 03104831 IF INFIX[I-1].TYPEFIELD=FUNCTION THEN GO ERRL ELSE 03104832 IF ANDORATOR(INFIX[I-1],OPERATOR) THEN 03104833 BEGIN 03104835 INFIX[I].LOCFIELD:=IF INFIX[I].LOCFIELD=SLASHV THEN 03104837 REDUCT ELSE SCANV; 03104838 03104839 IF INFIX[I].OPTYPE NEQ DYADIC THEN INFIX[I].OPTYPE:=MONADIC; 03104840 GO OK; 03104843 END 03104845 ELSE 03104847 03104849 IF INFIX[I].OPTYPE NEQ DYADIC THEN INFIX[I].OPTYPE:=MONADIC; 03104851 IF I=1 THEN 03104857 03104859 BEGIN 03104861 ERR:=SYNTAXERROR; 03104863 GO AROUND; 03104865 END; 03104867 GO OK; END; 03104869 SORTL: 03104870 IF I=1 OR ANDORATOR(INFIX[I-1],OPERATOR) THEN GO OK ELSE GO ERRL; 03104871 LFTPARENL: 03104873 K:=I; 03104874 UNSTACK(SP,PTOP,OPERATORS,OTOP,2,RGTPARENV,RGTBRACKETV); 03104875 GO AROUND; 03104876 RELATIONL: 03104878 DYADICL: 03104880 IF I GTR 1 THEN 03104881 IF ANDORATOR(INFIX[I-1],OPERAND) THEN 03104882 BEGIN 03104884 INFIX[I].OPTYPE:=DYADIC; 03104885 GO STACKFUNCTION; 03104886 END; 03104887 IF (GT3:=(T:=INFIX[I+1]).LOCFIELD=REDUCT OR GT3=SCANV) 03104888 AND T.TYPEFIELD=OPERATOR THEN GO OK; 03104889 IF(T:=INFIX[I-1]).LOCFIELD=DOTV AND T.TYPEFIELD=OPERATOR THEN GO OK;03104890 GO TO ERRL; 03104891 MONADICL: 03104892 IF I=1 OR ANDORATOR(INFIX[I-1],OPERATOR) 03104894 THEN BEGIN 03104896 INFIX[I].OPTYPE:=MONADIC; 03104897 GO TO STACKFUNCTION; 03104900 END 03104902 ELSE 03104904 GO ERRL; 03104906 LFTBRACKETL: 03104910 IF BCT:=BCT-1 LSS 0 THEN ERR:=SYNTAXERROR; 03104935 UNSTACK(SP,PTOP,OPERATORS,OTOP,1,RGTBRACKETV,RGTPARENV); 03104950 IF OTOP=1 THEN BEGIN 03104981 ERR:=SYNTAXERROR; GO AROUND; END 03104984 ELSE IF J NEQ 0 THEN 03104987 BEGIN 03104990 IF T:=INFIX[I-1].TYPEFIELD=OPERAND OR T=LOCALVAR THEN 03104995 BEGIN DEFINE STARTSEGMENT= #; %////////////////////////// 03105000 %LFTBRACKET PART OF SUBSCRIPTED VARIABLE 03105001 IF OPERATORS[OTOP].OPTYPE=0 THEN GO TO ERRL; 03105002 COMMENT IF ABOVE TRUE THEN THERE WAS AN OPERAND TO THE RITE;03105003 L:=L+1; 03105004 N:=GT1:=GETSPACE(1); 03105006 SP[NOC]:=COLONCTR+1; % STORE NUMBER OF DIMENSIONS 03105009 N:=GETSPACE(1); % BUILD A DESCRIPTOR FOR # OF DIMENSIONS 03105012 T.SPF:=GT1; 03105015 T.DID:=DDPNSW; 03105018 T.BACKP:=LASTCONSTANT; 03105021 SP[NOC]:=T; 03105024 T:=INFIX[I]; 03105027 T.LOCFIELD:=LASTCONSTANT:=N; % LINK TO CONSTANT CHAIN 03105030 T.TYPEFIELD:=CONSTANT; 03105033 SP[LOC]:=T; % PUT ON POLISH 03105036 L:=L+1; 03105039 IF OPERATORS[OTOP].OPTYPE=3 THEN % LEFT SIDE OF REPLACEOP 03105040 INFIX[I-1].TYPEFIELD:=REPLACELOC; 03105041 SP[LOC]:=INFIX[I-1]; % PLACE OPERAND ON POLISH 03105042 L:=L+1; 03105043 SP[LOC]:=INFIX[I]; % COLLAPSE OPERATOR TO POLISH 03105044 I:=I-1; 03105045 END 03105046 ELSE IF T:=INFIX[I-1].LOCFIELD=SLASHV OR 03105047 T=EXPANDV OR T=ROTV OR T=SORTUPV OR T=SORTDNV THEN 03105048 IF INFIX[I-1].TYPEFIELD=OPERATOR AND OPERATORS[OTOP] 03105049 .OPTYPE=0 THEN INFIX[I-1].OPTYPE:=DYADIC 03105050 ELSE ERR:=SYNTAXERROR 03105051 ELSE ERR:=SYNTAXERROR; 03105053 END; 03105054 COLONCTR:=OPERATORS[OTOP:=OTOP-1]; 03105056 IF OTOP:=OTOP-1 LSS 0 THEN ERR:=SYNTAXERROR; 03105059 GO AROUND; 03105070 RGTPARENL: 03105085 IF OTOP LSS ITOP DIV 2 THEN ELSE ERR:=SYNTAXERROR; 03105087 OPERATORS[OTOP:=OTOP+1]:=INFIX[I]; 03105090 GO AROUND; 03105100 RGTBRACKETL: BEGIN DEFINE STARTSEGMENT= #; %/////////////////// 03105115 BCT:=BCT+1; 03105130 IF OTOP+2 GEQ ITOP THEN 03105132 BEGIN 03105134 ERR:=SYNTAXERROR; 03105136 GO AROUND; 03105138 END; 03105140 OPERATORS[OTOP:=OTOP+1]:=COLONCTR; 03105145 GT1:=OPERATORS[OTOP:=OTOP+1]:=INFIX[I]; COLONCTR:=0; 03105150 IF I NEQ ITOP THEN 03105152 IF GT1.OPTYPE NEQ 3 THEN 03105154 OPERATORS[OTOP].OPTYPE:=IF RGTOPERAND(INFIX[I+1]) THEN 03105156 0 ELSE 2 03105158 ELSE 03105159 ELSE OPERATORS[OTOP].OPTYPE:=2; 03105160 IF J NEQ 0 AND INFIX[I-1].LOCFIELD=SEMICOLONV THEN 03105161 BEGIN 03105163 T.LOCFIELD:=BUILDNULL(LASTCONSTANT); 03105165 T.TYPEFIELD:=CONSTANT; 03105167 L:=L+1; K:=I; 03105169 SP[LOC]:=T; 03105171 END; 03105173 GO AROUND; END; 03105175 LFTARROWL: 03105178 IF I=1 THEN ERR:=SYNTAXERROR 03105180 ELSE 03105182 IF T:=INFIX[I-1].TYPEFIELD=OPERAND OR T=LOCALVAR THEN 03105184 INFIX[I-1].TYPEFIELD:=REPLACELOC 03105186 ELSE 03105188 IF T=OPERATOR THEN 03105190 IF T:=INFIX[I-1].LOCFIELD=QUAD OR T=QUADLFTARROW THEN 03105192 INFIX[I:=I-1].LOCFIELD:=QUADLFTARROW 03105194 ELSE IF T=RGTBRACKETV THEN INFIX[I-1].OPTYPE:=3 03105195 %WILL TEST LATER TO INDICATE REPLACEMENT IN MATRIX 3105154 03105196 ELSE ERR:=SYNTAXERROR 03105197 ELSE ERR:=SYNTAXERROR; 03105198 IF ERR=0 THEN GO OK ELSE GO AROUND; 03105200 QUOTEQUADL: 03105202 QUADL: 03105204 COMMENT INPUT IS BEING REQUESTED; 03105205 GO TO STACKOPERAND; 03105206 DOTL: BEGIN DEFINE STARTSEGMENT=#; %/////////////////////////////// 03105207 IF I GTR 2 THEN 03105208 IF (T:=INFIX[I-1]).TYPEFIELD=OPERATOR AND 03105209 ANDORATOR(T,OPERATOR) THEN 03105211 IF (T:=INFIX[I+1]).TYPEFIELD=OPERATOR AND 03105213 ANDORATOR(T,OPERATOR) THEN 03105215 IF ANDORATOR(INFIX[I-2],OPERAND) THEN 03105216 COMMENT THEN SYNTAX OK; 03105217 BEGIN 03105223 COMMENT STACK OPERATORS SO THAT IF GIVEN A+.XB 03105225 POLISH IS BA.+X; 03105227 OPERATORS[OTOP].OPTYPE:=TRIADIC; 03105228 OPERATORS[OTOP:=OTOP+1]:=INFIX[I-1]; 03105229 INFIX[I].OPTYPE:=TRIADIC; 03105231 OPERATORS[OTOP:=OTOP+1]:=INFIX[I]; 03105232 I:=I-1; 03105233 VALID:=TRUE; 03105234 END; 03105235 IF NOT VALID THEN ERR:=SYNTAXERROR; 03105237 VALID:=FALSE; 03105239 GO AROUND; END; 03105241 SEMICOLONL: BEGIN DEFINE STARTSEGMENT=#; %///////////////////// 03105242 IF BCT NEQ 0 THEN 03105244 BEGIN 03105246 COLONCTR:=COLONCTR+1; 03105248 IF I-1=0 THEN ERR:=SYNTAXERROR 03105250 ELSE 03105260 BEGIN 03105263 UNSTACK(SP,PTOP,OPERATORS,OTOP,1,RGTBRACKETV,RGTPARENV); 03105265 IF J NEQ 0 AND (T:=INFIX[I-1].LOCFIELD=SEMICOLONV 03105270 OR T =LFTBRACKETV) THEN BEGIN 03105280 T.LOCFIELD:=BUILDNULL(LASTCONSTANT); 03105290 T.TYPEFIELD:=CONSTANT; 03105300 L:=L+1; K:=I; 03105310 SP[LOC]:=T; 03105320 END; 03105330 END 03105340 END 03105350 ELSE COMMENT MUST BE MIXED MODE EXPRESSION; 03105370 BEGIN 03105383 IF ANDORATOR(T:=INFIX[I-1],OPERATOR) THEN 03105385 IF T.LOCFIELD NEQ SEMICOLONV THEN GO ERRL; 03105390 UNSTACK(SP,PTOP,OPERATORS,OTOP,1,RGTPARENV,RGTBRACKETV); 03105395 OPERATORS[OTOP:=OTOP+1]:=INFIX[I]; 03105400 END; 03105403 GO AROUND; 03105405 END; 03105407 NOK: 03105655 ERR:=SYSTEMERROR; 03105660 GO AROUND; 03105661 ERRL: 03105662 ERR:=SYNTAXERROR; 03105663 GO AROUND; 03105665 OK: 03105668 IF INFIX[I].OPTYPE NEQ 0 THEN GO TO STACKFUNCTION ELSE 03105669 IF I LSS 2 THEN INFIX[I].OPTYPE:=MONADIC ELSE 03105670 INFIX[I].OPTYPE:=IF ANDORATOR(INFIX[I-1],OPERATOR) THEN 03105671 MONADIC ELSE DYADIC; 03105672 03105673 03105674 STACKFUNCTION: 03105675 IF I=K-1 THEN OPERATORS[OTOP:=OTOP+1]:=INFIX[I] 03105677 ELSE 03105680 BEGIN 03105682 UNSTACK(SP,PTOP,OPERATORS,OTOP,1,RGTPARENV,RGTBRACKETV); 03105685 OPERATORS[OTOP:=OTOP+1]:=INFIX[I]; 03105700 END; 03105710 GO AROUND; 03105715 AROUND: 03105717 END % OF PROCESSING AN OPERATOR---- 03105720 ELSE % COULD BE A FUNCTION 03105722 IF INFIX[I].TYPEFIELD=FUNCTION THEN 03105724 IF (T:=INFIX[I]).OPTYPE GEQ MONADIC THEN 03105726 GO TO STACKFUNCTION 03105728 ELSE 03105730 IF T.RF=RETURNVAL THEN GO TO STACKOPERAND 03105732 ELSE % MUST NOT RETURN A VALUE 03105734 IF I=1 THEN GO TO STACKOPERAND 03105736 ELSE ERR:=SYNTAXERROR 03105738 ELSE % MUST BE AN OPERAND, CONSTANT OR LOCAL 03105740 STACKOPERAND: 03105742 BEGIN DEFINE STARTSEGMENT=#; %////////////////////////// 03105744 IF ITOP=1 THEN ELSE 03105746 IF I=ITOP AND I NEQ 1 THEN 03105748 IF ANDORATOR(INFIX[I-1],OPERAND) THEN 03105750 IF INFIX[I-1].LOCFIELD=RGTBRACKETV THEN 03105751 ELSE GO ERRL 03105752 ELSE 03105754 ELSE 03105758 IF I=1 AND I NEQ ITOP THEN 03105760 IF RGTOPERAND(INFIX[I+1]) THEN GO ERRL 03105762 ELSE 03105764 ELSE 03105766 IF ANDORATOR(INFIX[I-1],OPERAND) OR RGTOPERAND(INFIX[I+1]) 03105768 THEN 03105770 IF INFIX[I-1].LOCFIELD=RGTBRACKETV THEN 03105772 ELSE GO ERRL; 03105773 IF J NEQ 0 THEN 03105774 BEGIN L:=L+1; 03105775 SP[LOC]:=INFIX[I]; 03105790 END; K:=I; 03105800 UNSTACK(SP,PTOP,OPERATORS,OTOP,1,RGTPARENV,RGTBRACKETV); 03105820 END; % OF GOING THROUGH INFIX 03105835 IF ERR NEQ 0 THEN ERRORMESS(ERR,INFIX[I].ADDRFIELD,0) ELSE 03105850 WHILE OTOP GTR 0 AND ERR=0 DO 03105900 BEGIN IF T:=OPERATORS[OTOP].LOCFIELD=RGTPARENV OR 03105950 T=RGTBRACKETV THEN 03105952 IF OPERATORS[OTOP].TYPEFIELD=OPERATOR THEN 03105960 ERRORMESS(ERR:=SYNTAXERROR,OPERATORS[OTOP].ADDRFIELD 03106000 ,0); 03106001 IF J NEQ 0 THEN 03106050 BEGIN L:=L+1; 03106100 SP[LOC]:=OPERATORS[OTOP] 03106150 END; OTOP:=OTOP-1; 03106200 END; 03106250 IF J NEQ 0 AND DISPLAYOP THEN 03106252 IF SP[LOC].TYPEFIELD NEQ OPERATOR OR 03106254 T:=SP[LOC].LOCFIELD NEQ LFTARROWV 03106255 AND T NEQ QUADLFTARROW AND T NEQ GOTOV THEN 03106256 BEGIN COMMENT ADD DISPLAY OPERATOR TO POLISH; 03106258 L:=L+1; 03106260 T.TYPEFIELD:=OPERATOR; 03106262 T.OPTYPE:=MONADIC; 03106263 T.LOCFIELD:=QUADLFTARROW; 03106264 SP[LOC]:=T; 03106266 END; 03106272 IF J NEQ 0 THEN 03106300 IF ERR NEQ 0 THEN FORGETSPACE (J,ITOP+3,SP) ELSE 03106350 COMMENT STORE POLISH AND BUFFER; 03106400 BEGIN COMMENT SAVE LENGTH OF POLISH; 03106450 DEFINE STARTSEGMENT=#; %//////////////////////////////////// 03106452 T:=L-J; % DELETE ANY EXTRA SPACE ALLOCATED FOR POLISH 03106500 IF T LSS ITOP+2 THEN FORGETSPACE(L+1,2+ITOP-T,SP); 03106525 COMMENT THEN GETSPACE FOR BUFFER; 03106535 L:=GS(((K:=LENGTH(BUFFER, CURRENTMODE= 03106550 CALCMODE))-1) DIV 8 +2); 03106600 COMMENT L IS THE ADDRESS OF THE BUFFER; 03106650 SP[LOC]:=K; %NUMBER OF CHARACTERS IN THE BUFFER 03106700 TRANSFERSP(INTO,SP,L+1,BUFFER,0,ENTIER((K+7)DIV 8)); 03106750 COMMENT WE HAVE MOVED IN THE BUFFER; 03106800 K:=L; %SAVE THE ADDRESS OF THE BUFFER; 03106850 L:=J+1; % ONE WORD UP INTO THE POLISH 03106900 SP[LOC].SPF:=K; %STORE ADDRESS OF BUFFER 03106950 SP[LOC].RF:=1; % SET THE RANK TO 1 03107000 SP[LOC].DID:=DDPNVC; 03107050 L:=L-1; %SET THE LENGTH OF POLISH 03107100 SP[LOC]:=T; %STORE THE LENGTH OF THE POLISH 03107150 T:=0; T.SPF:=J; T.RF:=1; %SET UP PROG DESC IN T 03107200 T.BACKP:=LASTCONSTANT; 03107225 T.DID:=PDC; ANALYZE:=T; 03107250 COMMENT DEBUG THE POLISH IF NECESSARY; 03107300 IF POLBUG=1 THEN DUMPOLISH(SP,T); 03107350 END; 03107400 %-------------------------------------------------- 03107450 END; 03107500 END; 03107550 PROCEDURE OPERANDTOSYMTAB(L);VALUE L;INTEGER L; 03108000 BEGIN 03108020 INTEGER N; 03108030 TRANSFER(ACCUM,2,GTA,0,7); 03108040 IF(IF VARIABLES=0 THEN FALSE ELSE 03108060 SEARCHORD(VARIABLES,GTA,GT1,7)=0) THEN 03108080 BEGIN 03108100 SP[LOC].TYPEFIELD:=GT1:=GETFIELD(GTA,7,1); 03108120 IF GT1=FUNCTION THEN 03108140 BEGIN 03108160 L:=L+1;SP[LOC]:=GTA[1]; 03108200 END ELSE %MUST BE AN OPERAND 03108220 BEGIN 03108240 SP[LOC].TYPEFIELD:=OPERAND; 03108260 L:=L+1; 03108280 IF GT1=0 THEN % THIS IS THE SCALAR CASE 03108300 BEGIN N:=GETSPACE(1); 03108320 SP[LOC]:=N&DDPNSW[CDID]; 03108340 SP[NOC]:=GTA[1]; 03108360 END ELSE %IT MUST BE A VECTOR 03108380 SP[LOC]:=GTA[1]; 03108400 END; 03108420 END ELSE % NOT IN THE SYMBOL TABLE 03108440 BEGIN 03108460 SP[LOC].TYPEFIELD:=GT1:=OPERAND; 03108480 L:=L+1; SP[LOC]:=NAMEDNULLV; 03108500 % THE UNDEFINED SYMBOL IS A NULL 03108520 03108540 END; 03108560 END; %OF PROCEDURE OPERANDTOSYMTAB 03108600 INTEGER PROCEDURE GETSPACE(LENGTH); VALUE LENGTH; 03110000 INTEGER LENGTH; 03110100 BEGIN 03110200 LABEL ENDGETSPACE,SPOVERFLOW; 03110210 MONITOR INDEX; 03110220 INTEGER L,NEXTAREA,LASTAREA,OLDROW,K; 03110300 INTEGER MEMCHECK; 03110310 REAL LINK; 03110400 INDEX:=SPOVERFLOW; 03110410 NEXTAREA:=SP[0,0]; 03110500 LASTAREA:=0; 03110600 DO BEGIN COMMENT FIND A LARGE ENOUGH AREA; 03110700 IF MEMCHECK:=MEMCHECK+1 GTR MAXMEMACCESSES THEN %ERR 03110710 BEGIN GETSPACE:=-1@10; ERR:=SPERROR; 03110720 GO TO ENDGETSPACE END; 03110730 IF NEXTAREA =0 THEN COMMENT END OF STORAGE; 03110800 BEGIN 03110900 IF NROWS:=(OLDROW:=NROWS)+K:=ENTIER(LENGTH/ 03110910 SPRSIZE+1) 03110915 GTR MAXSPROWS THEN %OFF THE END OF SP 03110920 BEGIN COMMENT TAKE EASY WAY OUT FOR NOW; 03110930 GETSPACE:=-1@10; %CAUSES INVALID INDEX 03110940 NROWS:=OLDROW; ERR:=SPERROR; 03110945 GO TO ENDGETSPACE 03110950 END; 03110960 K:=K|SPRSIZE; 03111000 03111100 L:=LASTAREA; 03111200 IF OLDROW = -1 THEN COMMENT FIRST ROW OF SP; 03111300 BEGIN SP[0,0].NEXT:=L:=1; K:=K-1 03111400 END ELSE 03111500 BEGIN SP[LOC].NEXT:=(OLDROW+1)|SPRSIZE; 03111600 L:=(OLDROW+1)|SPRSIZE; 03111700 END; 03111800 SP[LOC].LEN:=K; SP[LOC].NEXT:=0; 03111900 NEXTAREA:=L 03112000 END ELSE L:=NEXTAREA; 03112100 LINK:=SP[LOC]; 03112200 K:=LINK.LEN-LENGTH; 03112300 IF K LSS 0 THEN COMMENT NOT ENOUGH ROOM; 03112400 BEGIN L:=LASTAREA:=NEXTAREA; 03112500 NEXTAREA:=LINK.NEXT 03112600 END 03112700 END UNTIL K GEQ 0; 03112800 IF K GTR 0 THEN 03112900 BEGIN L:=L+LENGTH; 03113000 SP[LOC]:=0; 03113010 SP[LOC].LEN:=K; SP[LOC].NEXT:=LINK.NEXT; 03113100 END ELSE L:=LINK.NEXT; 03113200 K:=L; L:=LASTAREA; 03113300 COMMENT ZERO OUT THE STORAGE BEFORE ALLOCATION; 03113400 SP[LOC].NEXT:=K; K:=NEXTAREA+LENGTH-1; 03113500 FOR L:=GETSPACE:=NEXTAREA STEP 1 UNTIL K DO SP[LOC]:=0; 03113600 IF FALSE THEN SPOVERFLOW: BEGIN 03113603 GETSPACE:=-1@10;ERR:=SPERROR END; 03113605 ENDGETSPACE: 03113610 END OF GETSPACE; 03113700 PROCEDURE FORGETSPACE(LOCATE,LENGTH); VALUE LOCATE,LENGTH; 03113800 INTEGER LOCATE,LENGTH; 03113900 BEGIN INTEGER L; 03114000 IF LENGTH GTR 0 THEN BEGIN 03114010 L:=LOCATE; 03114100 SP[LOC]:=SP[0,0]; 03114200 SP[LOC].LEN:=LENGTH; 03114300 SP[0,0]:=L; 03114310 END; 03114400 END; 03114500 INTEGER PROCEDURE BUILDNULL(LASTCONSTANT); 03114510 INTEGER LASTCONSTANT; 03114520 BEGIN REAL T, N; 03114530 IF NOT CURRENTMODE=FUNCMODE THEN 03114535 BEGIN 03114536 T:=0; 03114540 T.DID:=DDPNVW; 03114550 T.BACKP:=LASTCONSTANT; 03114560 LASTCONSTANT:=BUILDNULL:=N:=GETSPACE(1); 03114570 SP[NOC]:=T; 03114580 END; 03114585 END OF BUILDNULL; 03114590 03114600 INTEGER PROCEDURE BUILDCONSTANT(LASTCONSTANT); 03114610 INTEGER LASTCONSTANT; 03114620 BEGIN ARRAY A[0:MAXCONSTANT]; 03114630 INTEGER ATOP,L,K; 03114640 REAL AP; 03114642 DEFINE GS=GETSPACE#; 03114650 DO 03114660 A[ATOP:=ATOP+1]:=ACCUM[0] 03114670 UNTIL NOT SCAN OR NOT NUMERIC OR ATOP = MAXCONSTANT; 03114680 IF MAXCONSTANT=ATOP OR ERR NEQ 0 THEN COMMENT AN ERROR; 03114690 ELSE 03114700 03114705 IF ATOP=1 THEN COMMENT SCALAR FOUND; 03114710 BEGIN L:=K:=GS(1); 03114720 SP[LOC]:=A[1]; 03114730 BUILDCONSTANT:=L:=GETSPACE(1); 03114740 SP[LOC]:=K&DDPNSW[CDID]&LASTCONSTANT[CLOCF]; 03114750 LASTCONSTANT:=L; 03114766 END ELSE COMMENT VECTOR; 03114770 BEGIN L:=K:=GS(ATOP+1); 03114780 TRANSFERSP(INTO,SP,L+1,A,1,ATOP); 03114790 SP[LOC]:=ATOP; 03114800 BUILDCONSTANT:=L:=GS(1); %VECTOR DESCRIPTOR 03114810 SP[LOC]:=K&1[CRF]&DDPNVW[CDID]&LASTCONSTANT[CLOCF]; 03114820 LASTCONSTANT:=L; 03114846 END 03114850 03114855 END; 03114860 OWN INTEGER OLDDATA, REALLYERROR; 03114900 INTEGER L,N,M; 03115000 OWN REAL ST,T,U; 03115100 LABEL EXECUTION,PROCESSEXIT; 03115200 DEFINE STLOC=ST.[30:11],ST.[41:7]#, 03115300 STMINUS=(ST-1).[30:11],(ST-1).[41:7]#, 03115400 AREG=SP[STLOC]#, 03115500 BREG=SP[STMINUS]#, 03115600 BACKPT=6:36:12#, 03115700 CI=18:36:12#, 03115800 SPTSP=30:30:18#, 03115900 PROGMKS=0#, 03115910 IMKS=2#, 03115920 FMKS=1#, 03115930 03115940 BACKF=[6:12]#, 03115950 CIF=[18:12]#, 03115960 ENDEF=#; 03116000 PROCEDURE PACK(L,OFFSET,N);VALUE L,OFFSET,N;INTEGER L,OFFSET,N; 03116100 FORWARD; 03116110 INTEGER PROCEDURE UNPACK(S,OFFSET,N);VALUE S,OFFSET,N; 03116200 INTEGER S,OFFSET,N; FORWARD; 03116210 PROCEDURE PUSH; 03117000 IF ST LSS STACKSIZE+STACKBASE THEN ST:=ST+1 ELSE 03117100 ERR:=DEPTHERROR; 03117200 PROCEDURE POP; 03117300 BEGIN REAL U; 03117310 IF ST GTR STACKBASE THEN 03117400 IF BOOLEAN((U:=AREG).NAMED)OR NOT BOOLEAN(U.PRESENCE) 03117500 THEN ST:=ST-1 ELSE 03117510 BEGIN COMMENT GET RID OF SP STORAGE FOR THIS VARIABLE; 03117600 IF U.SPF NEQ 0 AND BOOLEAN(U.DATADESC) THEN 03117640 SCRATCHDATA(U); 03117650 03117660 ST:=ST-1; 03117700 END 03117800 ELSE ERR:=SYSTEMERROR; 03117900 END; 03117910 REAL PROCEDURE GETARRAY(DESCRIPTOR); VALUE DESCRIPTOR; 03118000 REAL DESCRIPTOR; 03118100 BEGIN 03118200 INTEGER R,I,J,K,L,LL,TOTAL,PT; 03118300 REAL T; 03118400 ARRAY BLOCK[0:BLOCKSIZE],DIMVECTOR[0:32]; 03118600 %SEE MAXWORDSTORE, LINE 17260 03118605 03118700 T:=DESCRIPTOR; 03118750 IF (R:=DESCRIPTOR.RF=0) THEN T.DIMPTR:=0 03118800 ELSE BEGIN 03118900 I:=CONTENTS(WS,DESCRIPTOR.DIMPTR,DIMVECTOR); 03119000 TOTAL:=1; 03119010 FOR I:=0 STEP 1 UNTIL R-1 DO 03119100 TOTAL:=TOTAL|DIMVECTOR[I]; 03119200 IF DESCRIPTOR.ARRAYTYPE=CHARARRAY THEN 03119300 TOTAL:=ENTIER((TOTAL+7) DIV 8); 03119400 TOTAL:=TOTAL+R; 03119500 LL:=GETSPACE(TOTAL); 03119600 TRANSFERSP(INTO,SP,LL,DIMVECTOR,0,R); 03119700 L:=LL+R; 03119800 J:=CONTENTS(WS,DESCRIPTOR.INPTR,DIMVECTOR)-1; 03119900 GTA[0]:=0; 03119910 FOR I:=0 STEP 2 UNTIL J DO 03120000 BEGIN 03120100 TRANSFER(DIMVECTOR,I,GTA,6,2); 03120200 PT:=GTA[0]; 03120210 K:=CONTENTS(WS,PT,BLOCK); 03120300 TRANSFERSP(INTO,SP,L,BLOCK,0, 03120400 (K:=ENTIER((K+7)DIV 8))); 03120500 L:=L+K; 03120600 END; 03120700 T.DIMPTR:=LL; 03120800 END; 03120900 T.INPTR:=0; 03121000 T.PRESENCE:=1; 03121100 GETARRAY:=T; 03121150 END; 03121200 INTEGER PROCEDURE FINDSIZE(D);VALUE D; REAL D; 03121250 BEGIN 03121255 INTEGER I,J,M,R; 03121260 J:=1; I:=D.SPF; R:=D.RF+I-1; 03121265 IF I NEQ 0 THEN 03121268 FOR M:=I STEP 1 UNTIL R DO J:=J|SP[MOC]; 03121270 FINDSIZE:=J; 03121275 END PROCEDURE FINDSIZE; 03121280 03121285 INTEGER PROCEDURE NUMELEMENTS(D); VALUE D; REAL D; 03121300 BEGIN 03121310 INTEGER I; 03121320 GT1:=I:=FINDSIZE(D); 03121322 IF D.ARRAYTYPE=CHARARRAY THEN 03121330 I:=ENTIER((I+7) DIV 8); 03121335 NUMELEMENTS:=I; 03121337 END; 03121340 PROCEDURE SCRATCHDATA(D); VALUE D; REAL D; 03121400 BEGIN 03121410 INTEGER T,R; 03121420 IF BOOLEAN(D.SCALAR) THEN T:=1 ELSE 03121430 IF R:=D.RF = 0 THEN T:=0 ELSE %BONAFIDE VECTOR 03121440 BEGIN T:=NUMELEMENTS(D)+R; 03121450 03121452 END; 03121454 IF T NEQ 0 THEN FORGETSPACE(D.SPF,T); 03121460 END; 03121470 COMMENT RELEASEARRAY HAS BEEN MOVED OUT OF PROCESS SO THAT IT 03121490 CAN BE CALLED ELSEWHERE; 03121491 REAL PROCEDURE MOVEARRAY(SPDESC); VALUE SPDESC; 03122500 REAL SPDESC; 03122550 COMMENT MOVE THE ARRAY FROM SCRATCHPAD TO PERMANENT 03122560 STORAGE AND CONSTRUCT NEW DESCRIPTOR; 03122570 BEGIN 03122600 INTEGER TOTAL,R,J,M,K; 03122650 REAL T; 03122660 ARRAY BLOCK[0:BLOCKSIZE],BUFFER[0:32]; %SEE MAXWORDSTORE, LINE 1726003122700 T:=SPDESC; 03122710 TRANSFERSP(OUTOF,SP,SPDESC.SPF,BUFFER,0,R:=SPDESC.RF); 03122750 T.DIMPTR:=STORESEQ(WS,BUFFER,8|R); 03122800 TOTAL:=NUMELEMENTS(SPDESC); 03122850 M:=SPDESC.SPF+R; 03123100 K:=ENTIER(TOTAL DIV BLOCKSIZE)-1; 03123150 FOR J:=0 STEP 1 UNTIL K DO BEGIN 03123200 TRANSFERSP(OUTOF,SP,M,BLOCK,0,BLOCKSIZE); 03123250 R:=STORESEQ(WS,BLOCK,BLOCKSIZE|8); 03123300 TRANSFER(R,6,BUFFER,J|2,2); 03123350 M:=M+BLOCKSIZE; 03123400 END; 03123450 IF J:=TOTAL-(K:=K+1)|BLOCKSIZE GTR 0 THEN 03123500 BEGIN 03123550 TRANSFERSP(OUTOF,SP,M,BLOCK,0,J); %GET REMAINDER OF MATRIX 03123600 R:=STORESEQ(WS,BLOCK,J|8); 03123640 TRANSFER(R,6,BUFFER,K|2,2); 03123650 K:=K+1; 03123660 END; 03123700 T.INPTR:=STORESEQ(WS,BUFFER,K|2); 03123750 MOVEARRAY:=T; 03123810 END; 03123850 PROCEDURE WRITEBACK; 03124000 COMMENT COPY CHANGED VARIABLES INTO PERMANENT STORAGE; 03124010 BEGIN 03124050 INTEGER I,J,K,L,M,NUM; 03124100 REAL T; 03124110 ARRAY NEWDESC[0:1],OLDDESC [0:1]; 03124150 L:=SYMBASE; 03124200 NUM:=SP[LOC]-1; 03124250 L:=L-1; 03124300 FOR I:=1 STEP 2 UNTIL NUM DO BEGIN 03124350 L:=L+2; 03124400 IF ((T:=SP[LOC]).TYPEFIELD) NEQ FUNCTION THEN 03124410 IF BOOLEAN(T.CHANGE) THEN BEGIN 03124450 IF VARIABLES=0 THEN 03124500 03124510 BEGIN VARIABLES:=NEXTUNIT; 03124520 T:=CURRENTMODE; 03124525 VARSIZE:=1; STOREPSR; 03124530 CURRENTMODE:=T; VARSIZE:=0; 03124535 END; 03124540 M:=L+1;WHILE(T:=SP[MOC]).BACKP NEQ 0 AND T.PRESENCE=1 03124550 AND(GT1:=GT1+1)LSS MAXMEMACCESSES DO M:=T.BACKP;GT1:=0; 03124560 GTA[0]:=SP[LOC];GTA[1]:=T; 03124570 TRANSFER(GTA,1,NEWDESC,0,7); 03124600 03124610 SETFIELD(NEWDESC,7,1, IF BOOLEAN(T.SCALAR) 03124650 THEN SCALARDATA ELSE ARRAYDATA); 03124700 MOVE(NEWDESC,1,OLDDESC); K:=1; 03124710 IF (IF VARSIZE=0 THEN FALSE ELSE 03124800 K:=SEARCHORD(VARIABLES,NEWDESC,J,7)=0) 03124850 THEN BEGIN 03124900 K:=CONTENTS(VARIABLES,J,OLDDESC); 03124950 DELETE1(VARIABLES,J); 03125000 IF GETFIELD(OLDDESC,7,1)=ARRAYDATA THEN 03125050 RELEASEARRAY(OLDDESC[1]); 03125100 END ELSE 03125150 BEGIN VARSIZE:=VARSIZE+1; J:=J+K-1; 03125160 MOVE(OLDDESC,1,NEWDESC); 03125170 END; 03125180 SETFIELD(NEWDESC,7,1,IF BOOLEAN(T.SCALAR) 03125200 THEN SCALARDATA ELSE ARRAYDATA); 03125210 IF BOOLEAN(T.SCALAR) THEN 03125250 BEGIN M:=T.SPF; 03125300 NEWDESC[1]:=SP[MOC]; 03125350 END ELSE %A VECTOR 03125360 BEGIN T.PRESENCE:=0; 03125370 NEWDESC[1]:=(IF T.RF NEQ 0 THEN 03125372 MOVEARRAY(T) ELSE T) 03125374 END; 03125378 STOREORD(VARIABLES,NEWDESC,J); 03125400 03125405 END; 03125450 END; 03125500 END; 03125550 PROCEDURE SPCOPY(S,D,N);VALUE S,D,N;INTEGER S,D,N; 03130000 BEGIN 03130100 INTEGER K; 03130200 WHILE (N:=N-K) GTR 0 DO 03130300 TRANSFERSP(INTO,SP,(D:=D+K),SP[(S:=S+K)DIV SPRSIZE,*], 03130400 K:=S MOD SPRSIZE,K:=MIN(N,SPRSIZE-K)); 03130500 END; 03130600 INTEGER PROCEDURE CHAIN(D,CHAINLOC); VALUE D,CHAINLOC; 03131000 INTEGER CHAINLOC; REAL D; 03131100 BEGIN 03131200 INTEGER M; 03131300 CHAIN:=M:=GETSPACE(1); 03131400 D.LOCFIELD:=CHAINLOC; 03131500 SP[MOC]:=D; 03131600 END; 03131700 PROCEDURE SCRATCHAIN(L); VALUE L; INTEGER L; 03132000 BEGIN 03132100 REAL R; 03132200 WHILE L NEQ 0 DO BEGIN 03132300 SCRATCHDATA(R:=SP[LOC]); 03132400 FORGETSPACE(L,1); 03132500 IF L=R.LOCFIELD THEN L:=0 ELSE 03132590 L:=R.LOCFIELD; 03132600 END; 03132700 END; 03132800 PROCEDURE RESTORELOCALS(FPTR);VALUE FPTR;REAL FPTR; 03133000 BEGIN 03133050 INTEGER L,M,N,I,K,FLOC; 03133100 REAL T; 03133150 M:=FPTR.LOCFIELD; 03133200 L:=FPTR.SPF+2;K:=SP[LOC]-2;%LAST ALPHA POINTER 03133300 T:=L+4; 03133350 FOR I:=T STEP 2 UNTIL K DO % ONCE FOR EACH LOCAL 03133400 BEGIN 03133450 M:=M+1;N:=SP[MOC].SPF; %LOCATION IN SYMBOL TABLE 03133500 T:=SP[NOC];L:=T.BACKP;T.BACKP:=0;T.NAMED:=0; 03133550 SP[MOC]:=T;%COPY OF DESCRIPTOR TO STACK 03133600 IF L=0 THEN 03133650 BEGIN N:=N-1; GTA[0]:=SP[NOC]; 03133660 TRANSFER(GTA,1,ACCUM,2,7); OPERANDTOSYMTAB(N); 03133670 END 03133680 ELSE BEGIN SP[NOC]:=SP[LOC];FORGETSPACE(L,1);END; 03133700 END; 03133750 END; % OF PROCEDURE RESTORELOCALS 03133800 OWN INTEGER FUNCLOC,POLLOC,LASTMKS,POLTOP,CINDEX; 03135000 PROCEDURE STEPLINE(LABELED); VALUE LABELED; 03140000 BOOLEAN LABELED; 03140020 03140030 BEGIN 03140040 LABEL ENDFUNC,TERMINATE,DONE; 03140050 LABEL BUMPLINE; 03140052 LABEL TRYNEXT; 03140054 REAL STREAM PROCEDURE CON(A); VALUE A; 03140060 BEGIN SI:= LOC A; DI:=LOC CON; DS:=8DEC; 03140070 END; 03140080 INTEGER C; 03140081 REAL N,T,L,TLAST,M,BASE; 03140090 COMMENT 03140091 MONITOR PRINT (FUNCLOC,POLLOC,LASTMKS,POLTOP,CINDEX,N,T,L, 03140092 TLAST,M,BASE); 03140094 L:=FUNCLOC;M:=SP[LOC].SPF+L; 03140100 IF BOOLEAN(SP[MOC].SUSPENDED) THEN 03140105 BEGIN %RESUME A SUSPENDED FUNCTION 03140110 SP[MOC].SUSPENDED:=0;%REMOVE SUSPENDED BIT 03140115 RESTORELOCALS(SP[MOC]); 03140118 SP[LOC].RF:=N:=SP[LOC].RF-1; 03140120 IF N LEQ 0 THEN SUSPENSION:=0;% NO MORE SUSPENDED FNS 03140124 END; 03140126 IF LABELED THEN %MAKE INTIAL CHECKS AND CHANGES; 03140130 BEGIN 03140140 IF NOT BOOLEAN((T:=AREG).PRESENCE) OR L:=T.SPF=0 03140150 THEN 03140160 BEGIN LABELED:=FALSE; GO TO BUMPLINE; 03140161 END; 03140162 IF BOOLEAN (T.CHRMODE) THEN GO TO TERMINATE; 03140170 L:=L+T.RF; %PICK UP THE FIRST ELEMENT OF THE ARRAY 03140180 IF T:=SP[LOC] GTR 9999.99994 OR T LSS 0 THEN 03140190 T:=0; 03140200 T:=CON(ENTIER(T|10000+.5)) 03140210 END; BUMPLINE: 03140212 L:=LASTMKS; TLAST:=SP[LOC].BACKF; 03140214 C:=(LASTMKS:=SP[MOC].LOCFIELD)-STACKBASE;%LOC OF FMKS 03140216 WHILE TLAST GTR C DO %STRIP OFF CURRENT LINE 03140218 BEGIN L:=TLAST+STACKBASE;TLAST:=(N:=SP[LOC]).BACKF; 03140219 IF N.DID=IMKS THEN SCRATCHAIN(N.SPF); 03140220 END; 03140221 WHILE ST GEQ L AND ERR=0 DO POP; 03140222 IF ERR NEQ 0 THEN GO TO DONE; 03140224 M:=BASE:=SP[MOC].SPF;%LOC OF LABEL TABLE 03140230 TRYNEXT: 03140238 N:=SP[MOC]+M+1; % N IS ONE BIGGER THAN TOP 03140240 M:=M+2; M:=SP[MOC]+2; % M IS ON THE FIRST POINTER 03140250 IF LABELED THEN %BINARY SEARCH FOR THE DESIRED LINE 03140260 BEGIN 03140270 IF N-M LSS 2 THEN GO TO ENDFUNC; 03140280 WHILE N-M GTR 2 AND C LSS 1@8 DO 03140290 03140300 BEGIN L:=M+ENTIER((N-M)DIV 4)|2; C:=C+1; 03140320 IF T LSS SP[LOC] THEN N:=L ELSE M:=L 03140330 END; 03140340 IF C=1@8 THEN GO TERMINATE; 03140342 IF SP[MOC] NEQ T THEN GO ENDFUNC; T:=M; 03140350 %T HAS THE SP LOCATION OF THE CORRECT LABEL 03140360 END ELSE %BUMP THE POINTER 03140370 IF T:=CURLINE+2+BASE GEQ N OR T LSS M THEN GO ENDFUNC; 03140380 M:=T+1; CURLINE:=T-BASE; %M IS SET TO PROG DESC 03140390 IF NOT BOOLEAN((T:=SP[MOC]).PRESENCE) THEN %MAKE POLISH 03140400 BEGIN N:=BASE+1;N:=SP[NOC].SPF;%SEQ STORAGE UNIT 03140410 INITBUFF(BUFFER,BUFFSIZE); 03140420 N:=CONTENTS(N,T,BUFFER); %GET TEXT 03140430 RESCANLINE; WHILE LABELSCAN(GTA,0) DO; %CLEAR LABELS 03140432 IF BOOLEAN(EOB) THEN % AN EMPTY LINE--BUMP POINTER 03140434 BEGIN M:=BASE;LABELED:=FALSE;GO TO TRYNEXT;END ELSE 03140436 IF T:=ANALYZE(TRUE)=0 THEN % NO GOOD 03140440 GO TO DONE; 03140450 SP[MOC]:=T; %SAVE THE POLISH DESCRIPTOR AT M 03140460 END ; 03140470 PUSH; IF ERR NEQ 0 THEN GO TO DONE; 03140480 AREG:=(L:=ENTIER(M))&1[CCIF]&TLAST[BACKPT]; 03140490 LASTMKS:=ST; 03140491 POLLOC:=SP[LOC].SPF; 03140492 L:=T.SPF; POLTOP:=SP[LOC]; CINDEX:=1; 03140500 GO TO DONE; 03140510 ENDFUNC: 03140520 %ARRIVE HERE WHEN FUNCTION IS COMPLETED. 03140530 %GET RESULT OF FUNCTION 03140540 M:=FUNCLOC;M:=SP[MOC].SPF+M;N:=TLAST:=SP[MOC].LOCFIELD; 03140550 M:=SP[NOC].SPF;M:=SP[MOC]; 03140551 COMMENT I CANNOT CONJURE UP A CASE WHERE A USER RETURNS TO A 03140555 FUNCTION WHOSE DESCRIPTOR HAS BEEN PUSHED DOWN BY A SUSPENDED 03140556 VARIABLE.IF THIS HAPPENS-HOPE FOR A GRACEFUL CRASH; 03140557 %M IS THE DESCRIPTOR FOR THE FUNCTION, TLAST IS BASE ADDRESS 03140560 03140562 IF BOOLEAN(M.RETURNVALUE) THEN %GET THE RESULT 03140570 BEGIN 03140580 N:=M.SPF+5;%RELATIVE LOCATION OF RESULT 03140590 N:=SP[NOC]+TLAST; %LOCATION IN STACK OF RESLULT 03140600 T:=SP[NOC]; SP[NOC].NAMED:=1; N:=T; 03140610 END; 03140620 WHILE ST GEQ TLAST AND ERR=0 DO POP; %GET RID OF TEMPS 03140630 OLDDATA:=(T:=AREG).SPF; POP;% GET RID OF INTERRUPT MKS 03140635 IF ERR NEQ 0 THEN GO TO DONE; 03140640 IF BOOLEAN(M.RETURNVALUE) THEN %REPLACE RESULT 03140650 BEGIN PUSH; IF ERR NEQ 0 THEN GO TO DONE; 03140660 AREG:=N; %RESULT OF CALL 03140670 END; 03140680 L:=STACKBASE+1;L:=SP[LOC].SPF+1;M:=SP[LOC].SPF+L; 03140682 03140684 SP[MOC]:=0;SP[LOC].SPF:=(M:=M-1)-L; 03140686 COMMENT NOW INITIATE ANY OLD FUNCTIONS, AND GET POLISH 03140690 GOING; 03140700 LASTMKS:=N:=T.BACKF+STACKBASE; %LOCATION OF PROGRAM DESC. 03140710 T:=SP[NOC]; % PICK UP PROGRAM DESCRIPTOR 03140720 N:=T.SPF; %LOCATION OF POLISH DESCRIPTOR 03140730 POLLOC:=(N:=SP[NOC].SPF); 03140740 POLTOP:=SP[NOC]; 03140750 CINDEX:=T.CIF; 03140760 IF M NEQ L THEN % GET LAST FUNCTION STARTED 03140770 BEGIN N:=SP[MOC].LOCFIELD; 03140780 T:=SP[NOC]; 03140790 CURLINE:=T.CIF 03140800 END ELSE CURLINE:=0; 03140810 GO TO DONE; 03140820 TERMINATE: 03140830 ERR:=LABELERROR; 03140840 DONE: 03140850 END; 03142000 03148200 PROCEDURE FIXTAKEORDROP(LDESC,RDESC,OPT,MAP,SIZEMAP,SIZE); 03148300 VALUE LDESC,RDESC,OPT; REAL LDESC,RDESC; 03148310 INTEGER OPT, SIZE; ARRAY MAP, SIZEMAP [1]; 03148320 BEGIN INTEGER LRANK,LSIZE,L,M,RRANK,N,I,TOP,PUT; 03148330 DEFINE TAKE = OPT = 2#; 03148340 INTEGER LNUM, RNUM; LABEL QUIT; 03148350 IF LSIZE := FINDSIZE(LDESC) NEQ RRANK := RDESC.RF AND LSIZE NEQ 1 03148360 OR LRANK:=LDESC.RF GTR 1 AND LSIZE NEQ 1 03148365 OR L := LDESC.SPF=0 03148370 OR M := RDESC.SPF = 0 THEN BEGIN 03148380 ERR:=DOMAINERROR; GO TO QUIT; END; 03148390 L := L + LRANK; 03148400 03148410 SIZE := 1; 03148420 FOR I := 1 STEP 1 UNTIL RRANK DO BEGIN 03148430 RNUM:=SP[MOC]; 03148440 LNUM:=IF TAKE THEN SP[LOC] ELSE (PUT:=SP[LOC])-SIGN(PUT)|RNUM; 03148450 IF ABS(LNUM) GTR RNUM THEN BEGIN 03148460 ERR:=DOMAINERROR; GO TO QUIT; END; 03148470 IF LNUM = 0 THEN BEGIN 03148480 SIZE := 0; GO TO QUIT; END; 03148490 IF LNUM GTR 0 THEN BEGIN 03148500 SIZEMAP[I] := LNUM; 03148510 MAP[I] . SPF := 0; 03148520 MAP[I] . RF := 1; 03148530 END ELSE BEGIN 03148540 LNUM:=ABS(LNUM); 03148550 PUT := RNUM - LNUM + ORIGIN; 03148560 MAP[I].SPF := N := GETSPACE(LNUM+1); 03148570 SIZEMAP[I] := SP[NOC] := LNUM; 03148580 TOP := N + LNUM; 03148590 FOR N:=N+1 STEP 1 UNTIL TOP DO BEGIN 03148600 SP[NOC]:=PUT; PUT:=PUT+1; END; 03148610 MAP[I].RF := 1; 03148620 MAP[I] := - MAP[I]; 03148630 END; 03148640 IF LSIZE NEQ 1 THEN L:=L+1; 03148650 M:=M+1; 03148660 SIZE:=SIZE | LNUM; 03148670 END; 03148680 QUIT: END PROCEDURE FIXTAKEORDROP; 03148690 REAL PROCEDURE SUBSCRIPTS(DIRECTION,D,RANK); 03150000 VALUE DIRECTION,D,RANK; REAL D,RANK; INTEGER DIRECTION; 03150010 BEGIN COMMENT THIS PROCEDURE EVALUATES A SET OF SUBSCRIPTS 03150020 ,POPS THEM OFF OF THE STACK, AND RETURNS WITH A DESC. 03150030 FOR THE ITEM REFERENCED; 03150040 LABEL GOHOME,DONE; 03150050 INTEGER SIZE,I,L,M,N,VALUW; 03150060 INTEGER ADDRESS,NOTSCAL,DIM,LEVEL,TEMP,K,J; 03150070 REAL SUBDESC,T; 03150080 BOOLEAN DCHARS; 03150081 STREAM PROCEDURE TCHAR(A,B,C,D);VALUE B,D; 03150083 BEGIN SI:=A;SI:=SI+B;DI:=C;DI:=DI+D;DS:=CHR;END; 03150085 ARRAY MAP[1:RANK],SIZEMAP[1:RANK]; 03150100 ARRAY BLOCKSIZE[1:RANK],POINTER[0:RANK],PROGRESS[1:RANK]; 03150102 INTEGER PROCEDURE SUBINDEX(M,S,P);VALUE M,S,P;REAL M,S,P; 03150104 IF M LSS 0 THEN BEGIN M:=-M; 03150106 M:=P+M.SPF+M.RF-1;SUBINDEX:=SP[MOC]-ORIGIN;END 03150107 ELSE SUBINDEX:=(IF S=1 THEN M.SPF ELSE M.SPF+P-1); 03150108 COMMENT 03150109 MONITOR PRINT(I,L,M,N,VALUW,ADDRESS,T,ERR,MAP,SIZEMAP, 03150110 SIZE,D,RANK,DIRECTION); 03150111 DCHARS:=BOOLEAN(D.CHRMODE); 03150112 IF DIRECTION GTR 1 THEN % THIS IS TAKE OR DROP 03150116 BEGIN 03150118 NOTSCAL:=1; 03150120 FIXTAKEORDROP(AREG,BREG,DIRECTION,MAP,SIZEMAP,SIZE); 03150124 IF ERR NEQ 0 THEN GO TO GOHOME; 03150125 IF SIZE=0 THEN BEGIN D.DID:=DDPUVW; D.RF:=1; 03150126 D.SPF:=0; SUBSCRIPTS:=D; GO TO GOHOME; END; 03150127 %IF SIZE=0 AND TAKE OR DROP, RESULT IS A NULL 03150128 END ELSE BEGIN 03150129 IF RANK NEQ D.RF THEN BEGIN ERR:=RANKERROR;GO TO GOHOME;END; 03150130 SIZE:=1; 03150140 N:=D.SPF-1; 03150150 L:=ST-1; % LOCATE THE EXECUTION STACK 03150152 FOR I:=1 STEP 1 UNTIL RANK DO 03150160 BEGIN 03150170 L:=L-1; SUBDESC:=SP[LOC]; % WANDER INTO EXEC STACK 03150180 IF ERR NEQ 0 THEN GO TO GOHOME; 03150190 N:=N+1; 03150200 IF BOOLEAN(SUBDESC.SCALAR) THEN 03150210 BEGIN M:=SUBDESC.SPF; 03150220 IF (VALUW:=SP[MOC]-ORIGIN) GEQ SP[NOC] 03150230 OR VALUW LSS 0 THEN BEGIN ERR:=INDEXERROR;GO TO 03150240 GOHOME; END; 03150242 MAP[I]:=VALUW; SIZEMAP[I]:=1; 03150250 END ELSE % CHECK FOR A NULL 03150260 IF SUBDESC.SPF=0 THEN % THIS IS A NULL 03150270 BEGIN 03150280 NOTSCAL:=1; 03150282 SIZE:=SIZE|(M:=SP[NOC]); 03150290 MAP[I].RF:=1;SIZEMAP[I]:=M; 03150300 END ELSE % IT MUST BE A VECTOR 03150310 BEGIN DEFINE STARTSEGMENT=#; %////////////////////////// 03150320 03150330 03150340 NOTSCAL:= 1; 03150342 MAP[I]:=-((M:=SUBDESC.SPF)&SUBDESC.RF[CRF]); 03150350 SIZE:=SIZE|(SIZEMAP[I]:=FINDSIZE(SUBDESC)); 03150360 J:=SP[NOC]+ORIGIN;M:=M+SUBDESC.RF;T:=SIZEMAP[I]+M 03150362 -1; 03150363 FOR M:=M STEP 1 UNTIL T DO 03150364 IF SP[MOC] GEQ J OR SP[MOC] LSS ORIGIN THEN 03150366 BEGIN ERR:=INDEXERROR; GO TO GOHOME; END; 03150368 END; 03150370 END; % OF THE FOR STATEMENT 03150380 END; 03150390 IF SIZE LEQ 0 THEN BEGIN ERR:=INDEXERROR;GO TO GOHOME;END; 03150400 IF SIZE=1 AND NOT BOOLEAN(NOTSCAL) THEN %SCALAR REFERENCED 03150410 BEGIN 03150420 DEFINE STARTSEGMENT=#; %//////////////////////////////// 03150430 N:=D.SPF; M:=RANK-1; 03150440 FOR I:=1 STEP 1 UNTIL M DO 03150450 BEGIN N:= N+1; 03150460 ADDRESS:=SP[NOC]|(ADDRESS+MAP[I]); 03150470 END; 03150480 ADDRESS:=ADDRESS+MAP[RANK] +1; 03150490 IF DIRECTION=OUTOF THEN 03150500 IF DCHARS THEN BEGIN 03150502 N:=(ADDRESS+7)DIV 8+N;J:=(ADDRESS-1)MOD 8; 03150503 T:=M:=GETSPACE(2);SP[MOC]:=1;M:=M+1; 03150504 SP[MOC]:=0; TCHAR(SP[NOC],J,SP[MOC],0); 03150506 SUBSCRIPTS:=T&1[CRF]&DDPUVC[CDID]; 03150508 END ELSE 03150509 BEGIN N:= ADDRESS+N; 03150510 M:=GETSPACE(1);SP[MOC]:=SP[NOC]; 03150520 T:=M; T.DID:=DDPUSW; 03150550 SUBSCRIPTS:=T; 03150560 END ELSE % DIRECTION IS INTO 03150600 BEGIN 03150610 L:=L-1;SUBSCRIPTS:=SUBDESC:=SP[LOC]; 03150620 IF DCHARS AND FINDSIZE(SUBDESC)=1 OR 03150630 BOOLEAN(SUBDESC.SCALAR) THEN 03150631 BEGIN 03150640 L:=GETSPACE(N:=(NUMELEMENTS(D)+D.RF)); 03150650 SPCOPY(D.SPF,L,N); % MAKE A NEW COPY 03150660 IF DCHARS THEN BEGIN 03150662 N:=(ADDRESS+7)DIV 8+L;J:=(ADDRESS-1)MOD 8; 03150663 M:=SUBDESC.SPF;IF SP[MOC] GTR 1 OR SUBDESC.RF 03150664 NEQ 1 THEN BEGIN ERR:=DOMAINERROR;GO TO 03150665 GOHOME;END; 03150666 M:=M+1;TCHAR(SP[MOC],0,SP[NOC],J); 03150667 END ELSE BEGIN 03150669 M:=L+ADDRESS+D.RF-1; 03150670 N:=SUBDESC.SPF; 03150680 SP[MOC]:=SP[NOC]; %PERFORM THE REPLACEMENT 03150690 END; 03150700 N:=D.LOCFIELD;I:=SP[NOC].BACKP; 03150710 SP[NOC]:=D&L[CSPF]&I[CLOCF];%STORE NEW DESC 03150712 OLDDATA:=CHAIN(D,OLDDATA); 03150714 IF BOOLEAN(D.NAMED) THEN BEGIN 03150720 N:=N-1;IF I=0 AND SP[NOC].SUSPENDVAR=0 03150730 THEN SP[NOC].CHANGE:=1%MUST BE A REAL GLOBAL 03150740 END ELSE %MUST BE A LOCAL VARIABLE 03150750 AREG.NAMED:=1; %DONT LET IT BE FORGOTTEN 03150760 END ELSE ERR:=RANKERROR; 03150770 END; 03150780 END ELSE % A VECTOR IS REFERENCED 03150800 BEGIN % START WITH INITIALIZATION 03150805 N:=D.SPF+D.RF;BLOCKSIZE[RANK]:=PROGRESS[RANK]:=J:=1; 03150810 FOR I:=RANK-1 STEP -1 UNTIL 1 DO 03150815 BEGIN N:=N-1; 03150820 J:=BLOCKSIZE[I]:=J|SP[NOC]; 03150825 PROGRESS[I]:=1; 03150830 END; 03150835 K:=POINTER[1]:=SUBINDEX(MAP[1],SIZEMAP[1],PROGRESS[1]) 03150840 |BLOCKSIZE[1]; 03150845 FOR I:=2 STEP 1 UNTIL RANK DO 03150850 K:=POINTER[I]:=K+SUBINDEX(MAP[I],SIZEMAP[I], 03150855 PROGRESS[I])|BLOCKSIZE[I]; 03150860 DIM:=0; 03150865 FOR I:=1 STEP 1 UNTIL RANK DO 03150870 IF SIZEMAP[I] GTR 1 THEN DIM:=DIM+MAP[I].RF; 03150875 IF DCHARS THEN BEGIN TEMP:=D; D.SPF:=UNPACK(D.SPF, 03150876 RANK,FINDSIZE(D)); IF DIM=0 THEN DIM:=1; END; 03150878 IF DIRECTION GTR 0 THEN % OUTOF..TAKE.. OR DROP 03150880 BEGIN DEFINE STARTSEGMENT=#; %////////////////////////// 03150885 IF SIZE+DIM GTR MAXWORDSTORE THEN BEGIN ERR:=KITEERROR; GO TO 03150886 GOHOME END ELSE TEMP:=L:=GETSPACE(SIZE+DIM); %ROOM FOR RESULT 03150887 IF DIM GTR 0 THEN 03150888 IF DIM=1 THEN BEGIN SP[LOC]:=SIZE; L:=L+1;END 03150890 ELSE FOR I:=1 STEP 1 UNTIL RANK DO 03150895 IF SIZEMAP[I] GTR 1 THEN 03150900 IF (M:=MAP[I].SPF)=0 THEN BEGIN SP[LOC]:= 03150901 SIZEMAP[I];L:=L+1;END ELSE 03150902 BEGIN N:=M+MAP[I].RF-1; 03150904 03150905 FOR M:=M STEP 1 UNTIL N DO BEGIN 03150906 SP[LOC]:=SP[MOC];L:=L+1;END; 03150908 END; 03150909 COMMENT THIS INITIALIZES RESULT DIM VECTOR; 03150910 ADDRESS:= D.SPF+D.RF; 03150912 END ELSE % DIRECTION IS INTO 03150915 BEGIN DEFINE STARTSEGMENT=#; %///////////////// 03150920 L:=L-1; SUBSCRIPTS:=SUBDESC:=SP[LOC]; 03150925 IF FINDSIZE(SUBDESC) NEQ SIZE THEN 03150930 BEGIN ERR:=RANKERROR; GO TO GOHOME;END; 03150932 N:=SUBDESC.RF; 03150940 IF BOOLEAN(SUBDESC.CHRMODE) THEN SUBDESC.SPF:= 03150942 UNPACK(SUBDESC.SPF,N,FINDSIZE(SUBDESC)); 03150944 IF DCHARS THEN L:= D.SPF ELSE BEGIN 03150946 L:=GETSPACE(N:=(NUMELEMENTS(D)+D.RF)); 03150950 SPCOPY(D.SPF,L,N); % MAKE FRESH COPY TO PATCH INTO 03150960 END; 03150962 ADDRESS:=L+D.RF; % SP LOCATION TO STORE INTO 03150970 N:=D.LOCFIELD;I:=SP[NOC].BACKP; 03150971 SP[NOC]:=D&L[CSPF]&I[CLOCF];%STORE NEW DESC. 03150972 OLDDATA:=CHAIN(IF DCHARS THEN TEMP ELSE D,OLDDATA); 03150974 IF BOOLEAN(D.NAMED ) THEN BEGIN 03150980 N:=N-1;IF I=0 AND SP[NOC].SUSPENDVAR=0 03150990 THEN SP[NOC].CHANGE:=1%MUST BE A REAL GLOBAL 03151000 END ELSE %IT MUST BE A LOCAL VARIABLE 03151010 AREG.NAMED:=1;%DONT LET IT BE FORGOTTEN ON POP 03151020 L:=SUBDESC.SPF+SUBDESC.RF;%POINT TO SOURCE 03151030 END; 03151040 03151300 03151305 WHILE TRUE DO % RECURSIVE EVALUATION LOOP 03151310 BEGIN N:=POINTER[RANK]+ADDRESS; 03151320 LEVEL:=RANK; 03151322 IF DIRECTION GTR 0 THEN %OUTOF..TAKE..DROP 03151330 BEGIN SP[LOC]:=SP[NOC]; L:=L+1; 03151340 END ELSE BEGIN % INTO 03151350 SP[NOC]:= SP[LOC];L:=L+1; END; 03151360 WHILE PROGRESS[LEVEL]GEQ SIZEMAP[LEVEL] DO 03151420 BEGIN PROGRESS[LEVEL]:=1 ; %LOOK FOR MORE WORK 03151430 IF LEVEL:=LEVEL-1 LEQ 0 THEN GO TO DONE; 03151440 END; 03151450 COMMENT THERE IS MORE ON THIS LEVEL; 03151460 PROGRESS[LEVEL]:=PROGRESS[LEVEL]+1; 03151470 K:=POINTER[LEVEL]:=POINTER[LEVEL-1] +SUBINDEX( 03151480 MAP[LEVEL],SIZEMAP[LEVEL],PROGRESS[LEVEL])| 03151482 BLOCKSIZE[LEVEL];%POINTER[0] IS 0 03151484 FOR I:=LEVEL+1 STEP 1 UNTIL RANK DO 03151490 K:=POINTER[I]:=K+SUBINDEX(MAP[I],SIZEMAP[I], 03151500 PROGRESS[I])|BLOCKSIZE[I]; 03151510 END; % OF RECURSIVE EVALUATION LOOP 03151520 DONE: IF DIRECTION GTR 0 THEN % OUTOF TAKE OR DROP 03151550 IF DCHARS THEN BEGIN PACK(TEMP,DIM,SIZE); 03151552 FORGETSPACE(D.SPF,RANK+FINDSIZE(D)); 03151554 SUBSCRIPTS:=TEMP&DIM[CRF]&DDPUVC[CDID]; 03151556 END ELSE % THIS IS A NUMERIC VECTOR 03151557 IF DIM=0 THEN SUBSCRIPTS:=TEMP&DDPUSW[CDID] ELSE 03151558 SUBSCRIPTS:=TEMP&DIM[CRF]&DDPUVW[CDID] 03151560 ELSE % THE DIRECTION IS INTO 03151562 BEGIN IF BOOLEAN(SUBDESC.CHRMODE) THEN 03151564 FORGETSPACE(SUBDESC.SPF,FINDSIZE(SUBDESC)+1); 03151566 IF DCHARS THEN PACK(D.SPF,RANK,FINDSIZE(D)); 03151568 END; 03151570 03151580 END; 03151800 GOHOME: IF DIRECTION GTR 1 THEN 03152000 FOR I:=1 STEP 1 UNTIL RANK DO 03152003 IF MAP[I] LSS 0 THEN FORGETSPACE(MAP[I].SPF,SIZEMAP[I]+1); 03152006 END; % OF SUBSCRIPTS PROCEDURE 03152010 PROCEDURE IMS(N); VALUE N; INTEGER N; 03152100 BEGIN COMMENT N=0 FOR REGULAR INTERRUPT MKS 03152110 N=1 FOR QQUAD INTERRUPT MKS 03152120 N=2 FOR QUAD INTERRUPT MKS 03152130 N=3 FOR EXECUTION LINE FOLLOWING 03152132 N=4 FOR SUSPENDED FUNCTION; 03152134 INTEGER L,M; 03152150 03152155 PUSH;AREG:=OLDDATA&(LASTMKS-STACKBASE) 03152160 [BACKPT]&N[QUADINV]&IMKS[CDID]; 03152170 IF N NEQ 4 THEN BEGIN L:=LASTMKS;SP[LOC].CIF:=CINDEX;END; 03152180 L:=STACKBASE+1;L:=SP[LOC].SPF +1; 03152190 IF (M:=SP[LOC].SPF) NEQ 0 THEN % SAVE CURLINE 03152195 BEGIN L:=L+M; L:=SP[LOC].LOCFIELD; 03152200 SP[LOC].CIF:=CURLINE; 03152210 END; 03152220 LASTMKS:=ST; 03152225 END; 03152230 PROCEDURE DISPLAYCHARV(D); VALUE D; REAL D; 03152500 BEGIN INTEGER I,J,K,L,M,NWORDS,NJ,T,NMAT,II,JJ,WDLINE,F,CC; 03152510 COMMENT WDLINE=#WORDS NEEDED TO FILL A TELETYPE LINE 03152512 NWORDS=#WORDS NEEDED TO GET F CHARACTERS FOR LAST 03152514 TELETYPE LINE OF A ROW 03152515 F=#CHARACTERS IN LAST TELETYPE LINE OF A ROW 03152516 T=#TELETYPE LINES NEEDED PER ROW BEYOND FIRST LINE 03152517 NMAT=#MATRICES TO BE PRINTED OUT (1 IF RANK=2); 03152518 L := (T:=D.SPF) + (NJ:=D.RF) - 1; 03152520 J := SP[LOC]; %J IS NUMBER OF CHARACTERS PER ROW 03152530 IF NJ GTR 1 THEN BEGIN 03152540 L:=L-1; K:=SP[LOC] 03152550 END ELSE K := 1; %K IS NUMBER OF ROWS PER MATRIX 03152560 03152570 L := T + NJ; 03152580 NMAT := FINDSIZE(D) DIV (J|K); 03152590 WDLINE := (LINESIZE+6) DIV 8 + 1; 03152595 IF II:=J-LINESIZE GTR 0 THEN BEGIN 03152600 T:=II DIV (I:=LINESIZE-2)+(IF II MOD I=0 THEN 0 ELSE 1); 03152605 NWORDS:=((F:=II-(T-1)|I)+6) DIV 8 + 1; 03152610 END ELSE BEGIN NWORDS:=((F:=J)+6)DIV 8 + 1; T:=0; END; 03152615 FOR II:=1 STEP 1 UNTIL NMAT DO BEGIN 03152620 FOR I:=1 STEP 1 UNTIL K DO BEGIN 03152625 CC:=0; 03152630 FOR JJ:=1 STEP 1 UNTIL T DO BEGIN 03152635 TRANSFERSP(OUTOF,SP,L+M DIV 8,BUFFER,0,WDLINE); 03152640 FORMROW(3,CC,BUFFER,ENTIER(M MOD 8),NJ:=LINESIZE-CC); 03152644 M := M + NJ; CC := 2; END; 03152646 IF I=K AND II=NMAT THEN IF L+M DIV 8 + NWORDS GTR 03152648 (1+NROWS)|SPRSIZE THEN NWORDS:=NWORDS-1; 03152650 %TO TAKE CARE OF BEING AT END OF SP 03152655 TRANSFERSP(OUTOF,SP,L+M DIV 8, BUFFER,0,NWORDS); 03152660 FORMROW(3,CC,BUFFER,ENTIER(M MOD 8), F); 03152670 M := M + F; 03152680 END; 03152690 FORMWD(3,"1 "); 03152700 END; 03152710 END OF CHARACTER DISPLAY PROCEDURE; 03152720 REAL PROCEDURE SEMICOL; 03153000 BEGIN COMMENT FORM CHAR STRING FROM TWO DESCRIPTORS; 03153010 INTEGER J,K,L; 03153020 REAL LD, RD; 03153025 STREAM PROCEDURE BLANKS(B,J,K);VALUE J,K; 03153030 BEGIN LOCAL T,U; 03153032 SI:=LOC K; DI:=LOC U; DI:=DI+1; DS:=7 CHR; 03153034 SI:=LOC J; DI:=LOC T; DI:=DI+1; DS:=7 CHR; 03153036 DI:=B; U(2(DI:=DI+32));; DI:= DI+K; 03153038 T(2(DS:=32 LIT " "));J(DS:=1 LIT " "); 03153040 END; 03153042 PROCEDURE MOVEC(J,L,K);VALUE J,L,K; INTEGER J,L,K; 03153050 BEGIN INTEGER I; 03153060 IF(J+K+8) GTR MAXBUFFSIZE|8 THEN ERR:=LENGTHERROR ELSE 03153070 BEGIN TRANSFERSP(OUTOF,SP,L,BUFFER,ENTIER((J+7)DIV 8), 03153080 ENTIER((K+7) DIV 8)); 03153082 IF I:=(J MOD 8) NEQ 0 THEN TRANSFER(BUFFER,J+8-I, 03153090 BUFFER,J,K); END; 03153100 END; 03153110 INTEGER PROCEDURE MOVEN(J,L,K);VALUE J,L,K;INTEGER J,L,K; 03153150 BEGIN INTEGER I;K:=K+L-1; I:=MAXBUFFSIZE|8; 03153160 BLANKS(BUFFER,I-J,J); 03153161 FOR L:= L STEP 1 UNTIL K DO 03153162 BEGIN NUMBERCON(SP[LOC],ACCUM); 03153170 TRANSFER(ACCUM,2,BUFFER,J:=J+1,ACOUNT); 03153180 IF (J:=J+ACOUNT)GTR I THEN BEGIN L:=K;ERR:=LENGTHERROR; 03153190 END;END; 03153200 MOVEN:=J; 03153210 END; 03153220 LD := AREG; RD := BREG; 03153225 IF L:=LD.RF GTR 1 THEN ERR:= RANKERROR ELSE 03153300 IF LD.SPF NEQ 0 THEN 03153310 IF BOOLEAN(LD.CHRMODE) THEN MOVEC(0,L+LD.SPF,J:=FINDSIZE 03153320 (LD))ELSE J:=MOVEN(0,L+LD.SPF,FINDSIZE(LD)); 03153330 IF L:=RD.RF GTR 1 OR ERR NEQ 0 THEN ERR:=RANKERROR ELSE 03153340 IF RD.SPF NEQ 0 THEN IF BOOLEAN(RD.CHRMODE) THEN 03153350 BEGIN MOVEC(J,L+RD.SPF,K:=FINDSIZE(RD));J:=J+K; 03153360 END ELSE J:=MOVEN(J,L+RD.SPF,FINDSIZE(RD)); 03153370 IF ERR=0 THEN 03153380 IF J=0 THEN SEMICOL:=NULLV ELSE 03153381 BEGIN L:=GETSPACE((K:=ENTIER((J+7)DIV 8))+1); 03153382 TRANSFERSP(INTO,SP,L+1,BUFFER,0,K); 03153390 SP[LOC]:=J; SEMICOL:=L&1[CRF]&DDPUVC[CDID]; 03153400 END; 03153410 03153420 END; 03153430 BOOLEAN PROCEDURE SETUPLINE; 03153500 BEGIN REAL T;INTEGER M; 03153510 IF T:=ANALYZE(FALSE) NEQ 0 THEN % WE HAVE A PROGRAM DESC 03153520 BEGIN IMS(3); 03153530 M:=GETSPACE(1); SP[MOC]:=T; 03153540 LASTMKS:=ST-STACKBASE; 03153550 PUSH; IF ERR=0 THEN 03153560 BEGIN AREG:=PROGMKS&LASTMKS[BACKPT]&1[CI]&M[SPTSP]; 03153570 POLLOC:=M:=T.SPF; POLTOP:=SP[MOC]; 03153580 LASTMKS:=LASTMKS+1+STACKBASE; CINDEX:=1; 03153590 END; 03153600 SETUPLINE:=TRUE; 03153610 END ELSE SETUPLINE:=FALSE; 03153620 END; 03153630 BOOLEAN PROCEDURE POPPROGRAM(OLDDATA,LASTMKS); 03154000 REAL OLDDATA,LASTMKS; 03154100 BEGIN LABEL EXIT;REAL L,M,N; 03154200 WHILE TRUE DO 03154300 BEGIN 03154400 WHILE(L:=AREG).DATADESC NEQ 0 AND ERR=0 DO POP; 03154500 IF L.DID=PROGMKS THEN 03154600 IF L=0 THEN %SOMETHING IS FUNNY...CONTINUE POPPING 03154700 POP 03154710 ELSE BEGIN 03154800 LASTMKS:=M:=L.BACKF+STACKBASE; 03154850 IF L.BACKF NEQ 0 AND NOT ((N:=SP[MOC]).DID=IMKS 03154900 AND N.QUADIN=4) THEN POPPROGRAM:=TRUE; 03155000 IF N.DID NEQ FMKS THEN 03155090 FORGETPROGRAM(L);POP;GO TO EXIT; 03155100 END ELSE %NOT A PROGRAM MKS 03155200 IF L.DID=FMKS THEN 03155300 BEGIN % MUST CUT BACK STATE VECTOR 03155400 M:=STACKBASE+1;M:=SP[MOC].SPF+1;N:=SP[MOC].SPF+M; 03155500 IF BOOLEAN(SP[NOC].SUSPENDED) THEN BEGIN SP[MOC].RF:=L:=03155600 SP[MOC].RF-1;IF L=0 THEN SUSPENSION:=0;END; 03155700 SP[NOC]:=0;SP[MOC].SPF:=N-M-1;POP; 03155800 END ELSE % NOT A FMKS EITHER 03155900 IF L.DID=IMKS THEN 03156000 BEGIN SCRATCHAIN(OLDDATA);OLDDATA:=L.SPF;POP;END; 03156100 IF ERR NEQ 0 THEN GO TO EXIT; 03156200 END; % OF THE DO 03156300 EXIT: END;%OF PROCEDURE POPPROGRAM 03156400 REAL PROCEDURE BUILDALPHA(LASTCONSTANT); 03210000 INTEGER LASTCONSTANT; 03210005 BEGIN 03210010 ARRAY B[0:BUFFSIZE]; 03210020 REAL R; 03210030 INTEGER L,N; 03210040 REAL STREAM PROCEDURE GETCHRS(ADDR,B); VALUE ADDR; 03210050 BEGIN LOCAL C1,C2,TDI,TSI,QM; 03210060 LOCAL ARROW; 03210065 LABEL L,DSONE,FINIS,ERR; 03210070 DI:=LOC QM; DS:=2RESET; DS:=2SET; 03210080 DI:=LOC ARROW; DS:=RESET; DS:=7SET; 03210085 DI:=B; DS:=8LIT"0"; 03210090 SI:=ADDR; 03210100 L: 03210110 IF SC=""" THEN % MAY BE A DOUBLE QUOTE 03210120 BEGIN 03210130 SI:=SI+1; 03210140 IF SC=""" THEN % GET RID OF A QUOTE 03210150 GO TO DSONE; 03210160 COMMENT ELSE WE ARE LOOKING PAST THE RH QUOTE; 03210170 GO TO FINIS; 03210180 END ELSE % LOOK FOR THE QUESTION MARK 03210190 BEGIN TDI:=DI; DI:=LOC QM; 03210200 IF SC=DC THEN % END OF BUFFER ENCOUNTERED 03210210 GO TO ERR; 03210220 SI:=SI-1; DI:=LOC ARROW; 03210224 IF SC=DC THEN %FOUND LEFT ARROW 03210226 GO TO ERR; 03210228 SI:=SI-1; DI:=TDI; GO TO DSONE 03210230 END; 03210240 DSONE: DS:=CHR; TALLY:=TALLY+1; 03210250 C2:=TALLY; TSI:=SI; SI:=LOC C2; SI:=SI+7; 03210260 IF SC="0" THEN 03210270 BEGIN TALLY:=C1; TALLY:=TALLY+1; C1:=TALLY; 03210280 TALLY:=0; 03210290 END; 03210300 SI:=TSI; 03210310 GO TO L; 03210320 FINIS: GETCHRS:=SI; 03210330 DI:=B; SI:=LOC C1; SI:=SI+1; DS:=7CHR; SI:=LOC C2; 03210340 SI:=SI+7; DS:=CHR; 03210350 ERR: 03210360 END; 03210370 IF R:=GETCHRS(ADDRESS,B) NEQ 0 THEN % GOT A VECTOR 03210380 IF NOT CURRENTMODE=FUNCMODE THEN 03210385 BEGIN ADDRESS:=R; 03210390 COMMENT B[0] HAS THE LENGTH OF THE STRING; 03210400 IF R:=B[0] GEQ 1 THEN COMMENT A VECTOR; 03210410 BEGIN 03210420 L:=GETSPACE(N:=(R-1)DIV 8+2); 03210430 TRANSFERSP(INTO,SP,L,B,0,N); 03210432 SP[LOC]:=R; 03210440 END; 03210450 N:=GETSPACE(1); 03210460 R:= L; 03210470 R.DID:=DDPNVC; 03210480 R.BACKP:=LASTCONSTANT; 03210482 LASTCONSTANT:=N; 03210484 IF B[0]=0 THEN R.DID:=DDPNVW %NULL BECAUSE .SPF=.RF=0 03210490 %DON"T WANT CHARACTER NULL TO LOOK LIKE CHARS 03210492 ELSE R.RF:=1; 03210495 SP[NOC]:=R; 03210497 COMMENT WE HAVE BUILT THE VECTOR AND DESCRIPTOR; 03210500 BUILDALPHA:=N 03210510 END 03210520 ELSE BEGIN BUILDALPHA:=1;ADDRESS:=R END; 03210521 %ELSE WE HAVE AN ERROR (MISSING " ETC.) 03210525 END; % OF THE BUILD ALPHA PROCEDURE 03210530 PROCEDURE PACK(L,OFFSET,N); VALUE L,OFFSET,N; 03210600 INTEGER L,OFFSET,N; 03210610 BEGIN 03210620 LABEL QUIT; 03210625 INTEGER M,T,MB,S; 03210630 STREAM PROCEDURE PACKEM(A,B,N); VALUE N; 03210640 BEGIN LOCAL T; 03210650 SI:=LOC N; DI:=LOC T; DI:=DI+1; DS:=7CHR; 03210660 SI:=A; DI:=B; 03210670 T(2(32(SI:=SI+7; DS:=CHR))); N(SI:=SI+7; DS:=CHR); 03210680 END; 03210690 IF N = 0 THEN GO TO QUIT; 03210695 T:=(M:=L:=L+OFFSET)+N; 03210700 MB:=MAXBUFFSIZE DIV 8 | 8; 03210710 WHILE M LSS T DO 03210720 BEGIN 03210730 TRANSFERSP(OUTOF,SP,M,BUFFER,0,MB:=MIN(MB,T-M)); 03210740 PACKEM(BUFFER,ACCUM,MB); 03210750 TRANSFERSP(INTO,SP,L,ACCUM,0,S:=(MB+7)DIV 8); 03210760 L:=L+S; M:=M+MB 03210770 END; 03210780 FORGETSPACE(L,T-L); 03210790 QUIT: END PROCEDURE PACK; 03210800 INTEGER PROCEDURE UNPACK(S,OFFSET,N); VALUE N,S,OFFSET; 03210810 INTEGER N,S,OFFSET; 03210820 BEGIN 03210830 INTEGER L,M,K,MB,T; 03210840 LABEL QUIT; 03210845 STREAM PROCEDURE UNPACKEM(A,B,N); VALUE N; 03210850 BEGIN 03210860 LOCAL T; 03210870 SI:=LOC N; DI:=LOC T; DI:=DI+1; DS:=7CHR; 03210880 SI:=A; DI:=B; 03210890 T(2(32(DS:=7LIT"0"; DS:=CHR))); 03210900 N(DS:=7LIT"0"; DS:=CHR); 03210910 END; 03210920 IF N = 0 THEN BEGIN UNPACK := S; GO TO QUIT; END; 03210925 UNPACK:=L:=GETSPACE(OFFSET+N); K:=S+OFFSET-1; 03210930 FOR M:=S STEP 1 UNTIL K DO 03210940 BEGIN SP[LOC]:=SP[MOC]; L:=L+1 03210950 END; 03210960 K:=L+N; S:=S+OFFSET; 03210970 MB:=MAXBUFFSIZE DIV 8; 03210980 N := MB | 8; 03210985 WHILE L LSS K DO 03210990 BEGIN 03211000 TRANSFERSP(OUTOF,SP,S,BUFFER,0,M:=MIN(MB,(K-L+7)DIV 8)); 03211010 UNPACKEM(BUFFER,ACCUM, M := MIN(K-L, M|8)); 03211020 TRANSFERSP(INTO,SP,L,ACCUM,0,M); 03211030 L := L+N; S := S+MB 03211040 END; 03211050 QUIT: END PROCEDURE UNPACK; 03211060 PROCEDURE TRANSPOSE; 03220000 BEGIN INTEGER M,N,L,I,ROW,COL,RANK,OUTER,INNER; REAL NEWDESC; 03220100 INTEGER SIZE,J,MAT,TOP,START; BOOLEAN CHARACTER; 03220105 LABEL QUIT; DEFINE GIVEUP=GO TO QUIT#; 03220110 REAL NULL, DESC; 03220111 DEFINE RESULT=RESULTD#; 03220112 NULL := AREG; DESC := BREG; 03220115 IF L:=DESC.SPF=0 THEN BEGIN ERR:=DOMAINERROR; GIVEUP; END; 03220200 RANK := DESC.RF; 03220300 SIZE := FINDSIZE(DESC); 03220325 IF RANK LSS 2 THEN BEGIN NEWDESC:=DESC; 03220330 %THEN THE TRANSPOSE IS THE THING ITSELF 03220332 NEWDESC.NAMED:=0; 03220333 NEWDESC.SPF := N:=GETSPACE(RANK+SIZE); 03220335 SPCOPY(L,N,RANK+SIZE); 03220340 GO TO QUIT; END; 03220345 IF DESC.ARRAYTYPE=1 THEN BEGIN 03220350 L:=UNPACK(L,RANK,SIZE); 03220360 CHARACTER := TRUE; END; 03220370 N:=L+RANK-1; COL := SP[NOC]; 03220500 N:=N-1; ROW := SP[NOC]; 03220600 TOP := SIZE DIV (MAT:=ROW|COL); 03220650 NEWDESC := DESC; 03220660 NEWDESC.SPF := M := GETSPACE(SIZE+RANK); 03220700 SPCOPY (L,M,RANK-2); 03220800 N:=M+RANK-1; SP[NOC]:=ROW; 03220900 N:=N-1; SP[NOC] := COL; 03220950 J:=0; M:=M+RANK; 03221000 WHILE J LSS TOP DO BEGIN 03221010 OUTER:=(START:=L+RANK+J|MAT) + COL - 1; 03221020 FOR I:=START STEP 1 UNTIL OUTER DO BEGIN INNER:=I+MAT-1; 03221100 FOR N:=I STEP COL UNTIL INNER DO 03221200 BEGIN SP[MOC] := SP[NOC]; M:=M+1; END; END; 03221300 J:=J+1; END; 03221350 QUIT: IF CHARACTER THEN BEGIN NEWDESC.ARRAYTYPE:=1; 03221400 FORGETSPACE(L,SIZE+RANK); 03221405 PACK(NEWDESC.SPF, RANK,SIZE); END; 03221410 RESULTD := NEWDESC; 03221420 END PROCEDURE TRANSPOSE; 03221500 BOOLEAN PROCEDURE MATCHDIM(DESC1,DESC2); REAL DESC1,DESC2; 03224000 BEGIN INTEGER I,L,M,TOP; LABEL DONE; 03225000 MATCHDIM:= TRUE; 03225100 IF DESC1.RF NEQ DESC2.RF THEN BEGIN MATCHDIM:=FALSE; 03225200 ERR:=RANKERROR; GO TO DONE; END; 03225300 I:=DESC1.SPF; M:=DESC2.SPF; TOP:=I+DESC1.RF-1; 03225400 FOR L:=I STEP 1 UNTIL TOP DO BEGIN 03225500 IF SP[LOC] NEQ SP[MOC] THEN BEGIN MATCHDIM:=FALSE; 03225600 ERR:=LENGTHERROR; GO TO DONE; END; 03225700 M:=M+1; END; 03225800 DONE: END PROCEDURE MATCHDIM; 03225900 INTEGER PROCEDURE RANDINT(A,B,U); VALUE A,B; 03226000 REAL A,B,U; 03226100 BEGIN DEFINE QQMODUL = 67108864#, QQMULT = 8189#, 03226200 QQRANDOM=(U:=U|QQMULT MOD QQMODUL)/QQMODUL#; 03226300 RANDINT := (B-A+1)|QQRANDOM+A-.5; 03226400 END PROCEDURE RANDINT; 03226600 BOOLEAN PROCEDURE BOOLTYPE(A,B); REAL A,B; 03226700 BEGIN IF ABS(A-1) LEQ FUZZ THEN A:=1; 03226800 IF ABS(A) LEQ FUZZ THEN A:=0; 03226900 IF ABS(B-1) LEQ FUZZ THEN B:=1; 03227000 IF ABS(B) LEQ FUZZ THEN B:=0; 03227100 BOOLTYPE := (IF A=1 OR A=0 AND B=1 OR B=0 THEN TRUE 03227200 ELSE FALSE); END PROCEDURE BOOLTYPE; 03227300 REAL PROCEDURE GAMMA(X); REAL X; 03227305 COMMENT THIS PROCEDURE WAS TAKEN FROM ACM ALGORITHM 31. 03227310 THE ONLY DIFFERENCE IS THAT THERE IS NO PROVISION FOR 03227315 X LEQ 0 SINCE IT WILL NOT BE CALLED IN THAT CASE. IT 03227320 IS SUPPOSED TO GIVE ACCURACY TO 7 DIGITS; 03227321 BEGIN REAL H,Y; LABEL A1, A2; 03227325 H := 1; Y := X; 03227330 A1: IF Y = 2 THEN GO TO A2 ELSE IF Y LSS 2 THEN BEGIN 03227335 H:=H/Y; Y:=Y+1; GO TO A1 END 03227340 ELSE IF Y GEQ 3 THEN BEGIN 03227345 Y:=Y-1; H:=H|Y; GO TO A1 END 03227350 ELSE BEGIN Y := Y - 2; 03227355 H := (((((((.0016063118 | Y + .0051589951) | Y 03227360 + .0044511400) | Y + .0721101567) | Y 03227365 + .0821117404) | Y + .4117741955) | Y 03227367 + .4227874605) | Y + .9999999758) | H END; 03227370 A2: GAMMA := H; 03227375 END OF PROCEDURE GAMMA; 03227380 BOOLEAN PROCEDURE EXCLAM(MARG,NARG,M,ANS); VALUE MARG,NARG,M; 03227800 REAL MARG,NARG,ANS; INTEGER M; 03227810 BEGIN INTEGER N,I; REAL DENOM; LABEL PUT; 03227900 EXCLAM := TRUE; 03228550 IF I:=NARG.[1:8] NEQ 0 OR DENOM:=MARG.[1:8] NEQ 0 THEN BEGIN 03228600 IF MARG LSS 0 OR NARG LSS 0 THEN BEGIN EXCLAM:=FALSE; 03228605 GO TO PUT; END; 03228607 IF M=0 THEN ANS:=GAMMA(NARG) ELSE BEGIN 03228610 IF (NARG-MARG) LEQ 0 THEN BEGIN EXCLAM:=FALSE; GO TO PUT END; 03228615 ANS := 1; 03228620 IF I=0 THEN FOR I:=2 STEP 1 UNTIL NARG DO ANS:=ANS|I 03228625 ELSE ANS:=GAMMA(NARG); 03228630 IF DENOM=0 THEN BEGIN DENOM:=1; FOR I:=2 STEP 1 UNTIL MARG DO 03228635 DENOM:=DENOM|I END ELSE DENOM:=GAMMA(MARG); 03228640 ANS := ANS / (DENOM | GAMMA(NARG-MARG)); 03228645 END; 03228650 GO TO PUT; END; 03228655 IF M=0 THEN BEGIN ANS := 1; 03228700 FOR I:=1 STEP 1 UNTIL NARG DO ANS:=ANS|I; 03228800 GO TO PUT; END 03228900 ELSE BEGIN IF MARG GTR NARG THEN 03229000 BEGIN ANS:=0; GO TO PUT; END; 03229100 IF MARG=0 THEN BEGIN ANS:=1; GO TO PUT; END; 03229200 ANS := NARG - MARG + 1; 03229400 FOR I:=NARG-MARG+2 STEP 1 UNTIL NARG DO ANS:=ANS|I; 03229500 DENOM := 1; 03229600 FOR I:=2 STEP 1 UNTIL MARG DO DENOM:=DENOM|I; 03229700 ANS := ANS / DENOM; END; 03229800 PUT: END PROCEDURE EXCLAM; 03229900 BOOLEAN PROCEDURE OPERATION(LEFT,RIGHT,LPTR,OP,ANS); 03230000 COMMENT: OP DEFINES THE APL OPERATORS AS FOLLOWS: 03230010 OP APL OPERATOR OP APL OPERATOR 03230015 0 + 10 FACT-COMB 03230020 1 TIMES 11 LSS 03230025 2 - 12 = 03230030 3 DIV 13 GEQ 03230035 4 * 14 GTR 03230040 5 RNDM 15 NEQ 03230045 6 RESD-ABS 16 LEQ 03230050 7 MIN-FLR 17 AND 03230055 8 MAX-CEIL 18 OR 03230060 9 NOT 19 NAND 03230061 20 NOR 03230062 21 LN-LOG 03230063 THE "CIRCLE" OPERATORS FOLLOW. 03230064 22 PI | 30 SQRT(1-B*2) 03230065 23 ARCTANH 31 SIN 03230066 24 ARCCOSH 32 COS 03230067 25 ARCSINH 33 TAN 03230068 26 SQRT(B*2-1) 34 SQRT(1+B*2) 03230069 27 ARCTAN 35 SINH 03230070 28 ARCCOS 36 COSH 03230071 29 ARCSIN 37 TANH; 03230072 03230073 COMMENT: LPTR IS LSS 0 IF THE CALL COMES FROM A 03230074 REDUCTION TYPE PROCEDURE. 03230075 LPTR = 0 IF OPERATOR IS MONADIC. 03230080 LPTR GTR 0 IF OPERATOR IS DYADIC. 03230085 LPTR LSS 0 IF COMES FROM REDUCTION TYPE OPERATION; 03230090 VALUE LEFT,RIGHT,LPTR,OP; 03230100 REAL LEFT,RIGHT,LPTR,OP; 03230200 REAL ANS; 03230210 BEGIN LABEL PUT,DOMAIN,KITE; DEFINE GIVEUP=GO TO PUT#; 03230300 DEFINE MAXEXP=158.037557167#, 03230302 MINEXP=-103.7216898#; 03230303 MONITOR INTOVR, ZERO, EXPOVR; 03230305 OPERATION := TRUE; 03230310 IF LPTR LSS 0 THEN IF OP GTR 10 AND OP LSS 21 THEN 03230320 IF NOT BOOLTYPE(LEFT,RIGHT) THEN GO TO DOMAIN; 03230330 IF OP = 45 THEN IF LPTR=0 THEN OP:=22 03230340 ELSE IF ABS(LEFT) GTR 7 THEN GO TO DOMAIN 03230345 ELSE OP := LEFT + 30; 03230350 IF OP GTR 16 AND OP LSS 21 THEN IF NOT BOOLTYPE(LEFT,RIGHT) 03230355 THEN GO TO DOMAIN; 03230357 ZERO:=DOMAIN; INTOVR:=KITE; EXPOVR:=KITE; 03230360 CASE OP OP BEGIN 03230400 ANS := LEFT + RIGHT; 03230500 ANS := IF LPTR=0 THEN SIGN(RIGHT) ELSE LEFT | RIGHT; 03230600 ANS := LEFT - RIGHT; 03230700 ANS := LEFT / RIGHT; 03230800 IF LPTR=0 THEN IF RIGHT GTR MINEXP AND RIGHT LSS MAXEXP 03230900 THEN ANS:=EXP(RIGHT) ELSE GO TO KITE 03230905 ELSE IF RIGHT.[3:6]=0 THEN ANS:=LEFT*ENTIER(RIGHT) 03230910 ELSE IF LEFT GTR 0 THEN IF ANS:=RIGHT|LN(LEFT) GTR MINEXP 03230920 AND ANS LSS MAXEXP THEN 03230923 ANS:=EXP(ANS) ELSE GO TO KITE 03230925 ELSE IF LEFT=0 AND RIGHT GTR 0 THEN ANS:=0 03230930 ELSE GO TO DOMAIN; 03230935 IF LPTR NEQ 0 THEN BEGIN ERR:=SYSTEMERROR; GIVEUP; END ELSE 03231000 IF RIGHT LSS ORIGIN THEN GO TO DOMAIN ELSE 03231010 ANS := RANDINT(ORIGIN,RIGHT,SEED); 03231100 IF LPTR=0 THEN ANS := ABS(RIGHT) ELSE 03231200 BEGIN IF LEFT=0 THEN IF RIGHT GEQ 0 THEN 03231300 ANS := RIGHT ELSE GO TO DOMAIN 03231400 ELSE IF (ANS:=RIGHT MOD LEFT) LSS 0 03231500 THEN ANS:=ANS + ABS(LEFT); END; 03231600 ANS := (IF LPTR=0 THEN ENTIER(RIGHT+FUZZ) 03231700 ELSE IF LEFT LEQ RIGHT THEN LEFT ELSE RIGHT); 03231800 ANS := (IF LPTR=0 THEN -ENTIER(-RIGHT+FUZZ) 03231900 ELSE IF LEFT GTR RIGHT THEN LEFT ELSE RIGHT); 03232000 IF LPTR NEQ 0 THEN BEGIN ERR:=SYNTAXERROR; GIVEUP; END 03232100 ELSE IF NOT BOOLTYPE(0,RIGHT) THEN 03232200 BEGIN ERR:=DOMAINERROR; GIVEUP; END 03232300 ELSE ANS := (IF RIGHT=1 THEN 0 ELSE 1); 03232400 IF NOT EXCLAM(LEFT,RIGHT,LPTR,ANS) THEN GO TO DOMAIN; 03232500 03232510 ANS := (IF RIGHT-LEFT GTR FUZZ|ABS(RIGHT) THEN 1 ELSE 0); 03232600 ANS:=(IF ABS(LEFT-RIGHT) LEQ FUZZ|ABS(RIGHT) THEN 1 ELSE 0); 03232700 ANS:=(IF RIGHT-LEFT LEQ FUZZ|ABS(RIGHT) THEN 1 ELSE 0); 03232800 ANS:=(IF LEFT-RIGHT GTR FUZZ|ABS(RIGHT) THEN 1 ELSE 0); 03232900 ANS:=(IF ABS(LEFT-RIGHT) GTR FUZZ|ABS(RIGHT) THEN 1 ELSE 0); 03233000 ANS:=(IF LEFT-RIGHT LEQ FUZZ|ABS(RIGHT) THEN 1 ELSE 0); 03233100 ANS := RIGHT | LEFT; %AND 03233200 ANS := IF RIGHT + LEFT = 0 THEN 0 ELSE 1; %OR 03233300 ANS := IF RIGHT | LEFT = 1 THEN 0 ELSE 1; %NAND 03233400 ANS := IF RIGHT + LEFT = 0 THEN 1 ELSE 0; %NOR 03233500 IF RIGHT LEQ 0 THEN GO TO DOMAIN ELSE IF LPTR=0 THEN 03233550 ANS:=LN(RIGHT) ELSE 03233560 IF LEFT LEQ 1 THEN GO TO DOMAIN ELSE 03233570 ANS := LN(RIGHT) / LN(LEFT); %LOGARITHMS 03233600 ANS := 3.1415926536 | RIGHT; 03233603 IF ABS(RIGHT) GEQ 1 THEN GO TO DOMAIN ELSE 03233606 ANS:= .5|LN((1+RIGHT)/(1-RIGHT)); %ARCTANH 03233609 03233610 IF RIGHT LSS 1 THEN GO TO DOMAIN ELSE 03233612 ANS:=LN(RIGHT+SQRT(RIGHT|RIGHT-1)); %ARCCOSH 03233615 ANS := LN(RIGHT + SQRT(RIGHT|RIGHT+1)); %ARCSINH 03233618 03233620 IF ABS(RIGHT) LSS 1 THEN GO TO DOMAIN ELSE 03233621 ANS:=SQRT(RIGHT|RIGHT-1); 03233624 ANS := ARCTAN(RIGHT); 03233627 IF ABS(RIGHT) GTR 1 THEN GO TO DOMAIN ELSE 03233630 IF RIGHT=0 THEN ANS:=1.5707963268 ELSE 03233631 ANS:=ARCTAN(SQRT(1-RIGHT*2)/RIGHT); %ARCCOS 03233633 IF ABS(RIGHT) GEQ 1 THEN GO TO DOMAIN ELSE 03233636 ANS:=ARCTAN(RIGHT/ SQRT(1-RIGHT*2)); %ARCSIN 03233639 IF ABS(RIGHT) GTR 1 THEN GO TO DOMAIN ELSE 03233642 ANS := SQRT(1-RIGHT*2); 03233645 ANS := SIN(RIGHT); 03233648 ANS := COS(RIGHT); 03233651 ANS := SIN(RIGHT) / COS(RIGHT); %TAN 03233654 ANS := SQRT(1+RIGHT|RIGHT); 03233657 ANS := (EXP(RIGHT) - EXP(-RIGHT))/2; %SINH 03233660 ANS := (EXP(RIGHT) + EXP(-RIGHT))/2; %COSH 03233663 ANS := ((OP:=EXP(RIGHT))-(ANS:=EXP(-RIGHT)))/(OP+ANS); %TANH 03233666 END; 03233669 GO TO PUT; 03233675 KITE: ERR:=KITEERROR; GO TO PUT; 03233678 DOMAIN: ERR:=DOMAINERROR; 03233680 PUT: IF ERR NEQ 0 THEN OPERATION := FALSE; 03233700 END PROCEDURE OPERATION; 03233705 PROCEDURE ARITH(OP); VALUE OP; 03233710 INTEGER OP; 03233715 COMMENT: ARITH HANDLES ALL APL OPERATORS THAT EMPLOY THE 03233720 VECTOR-VECTOR, SCALAR-VECTOR, SCALAR-SCALAR, VECTOR-SCALAR 03233725 FEATURE. DESC1 AND DESC2 ARE THE DESCRIPTORS FOR THE 03233730 LEFTHAND AND RIGHTHAND OPERANDS, RESPECTIVELY. IF 03233735 IF DESC1 = 0, THE OPERATOR IS TAKEN TO BE MONADIC. 03233740 IF DESC.SPF = 0, THE OPERAND IS NULL AND A DOMAIN ERROR 03233745 RESULTS EXCEPT IN THE CASE OF MULTIPLICATION. 03233750 OP IS AN INTERNAL OPERATION CODE FOR THE OPERATOR, WHICH 03233755 DEPENDS ON THE CASE STATEMENT IN THE OPERATION PROCEDURE.; 03233760 BEGIN INTEGER L,M,I,N,SIZE,RANK1,RANK2,TOP, 03233765 FORGETL, FORGETM; 03233770 REAL DESC,LEFT,RIGHT,ANS,SIZE1,SIZE2,DESC1,DESC2; 03233775 LABEL DONE, LEFTSCALE, SCALVECT, DOMAIN, VECTSCAL; 03233780 BOOLEAN CHAR1, CHAR2; 03233785 DESC1 := AREG; DESC2 := BREG; 03233790 L:=DESC1.SPF; M:=DESC2.SPF; 03233800 RANK1:=DESC1.RF; RANK2:=DESC2.RF; 03233850 SIZE1:=FINDSIZE(DESC1); SIZE2:=FINDSIZE(DESC2); 03233860 IF(CHAR1:=DESC1.ARRAYTYPE=1) OR (CHAR2:=DESC2.ARRAYTYPE=1) 03233900 THEN BEGIN IF OP LSS 11 OR OP GTR 16 03233902 OR NOT(CHAR1 AND CHAR2) AND NOT(OP=12 OR OP=15) 03233903 THEN BEGIN CHAR1:=CHAR2:=FALSE; GO TO DOMAIN; END; 03233904 IF CHAR1 THEN 03233906 FORGETL := L := UNPACK(L,RANK1,SIZE1); 03233908 IF CHAR2 THEN 03233910 FORGETM := M := UNPACK(M,RANK2,SIZE2); END; 03234000 03234100 03234110 IF M=0 THEN BEGIN IF OP NEQ 1 THEN GO TO DOMAIN 03234200 ELSE BEGIN DESC := NULLV; 03234230 GO TO DONE; END; END; 03234240 IF L=0 THEN BEGIN 03234400 IF DESC1.DID NEQ 0 THEN 03234410 IF OP=1 THEN BEGIN DESC:=NULLV; GO TO DONE; END 03234420 ELSE GO TO DOMAIN; 03234425 IF OP GTR 10 AND OP LSS 21 THEN GO TO DOMAIN; 03234430 LEFT := OP MOD 2; GO TO LEFTSCALE; END; 03234440 IF SIZE1=1 03234500 THEN BEGIN L:=L+RANK1; LEFT:=SP[LOC]; 03234510 GO TO LEFTSCALE; END; 03234600 IF SIZE2=1 THEN BEGIN 03234700 % DESC1 IS A VECTOR, DESC2 IS A SCALAR; 03234800 VECTSCAL: M:=M+RANK2; RIGHT:=SP[MOC]; 03234900 I := GETSPACE( SIZE:=SIZE1+RANK1); 03235000 DESC.SPF:=I; DESC.DID:=DDPUVW; SPCOPY(L,I,RANK1); 03235100 L:=L+RANK1; I:=I+RANK1; 03235200 DESC.RF:=RANK1; TOP:=SIZE1+I-1; 03235300 FOR N:=I STEP 1 UNTIL TOP DO BEGIN 03235400 IF OPERATION(SP[LOC],RIGHT,L,OP,ANS) THEN 03235500 SP[NOC] := ANS ELSE GO TO DONE; 03235510 L:=L+1; END; 03235600 GO TO DONE; END; 03235700 % BOTH DESC1 AND DESC2 ARE ARRAYS; 03235800 IF NOT MATCHDIM(DESC1,DESC2) THEN GO TO DONE 03235900 ELSE BEGIN 03236000 I := GETSPACE( SIZE := SIZE2 + RANK2 ); 03236100 SPCOPY(M,I,RANK2); DESC.SPF:=I; DESC.DID:=DDPUVW; 03236200 DESC.RF := RANK2; 03236300 M:=M+RANK2; I:=I+RANK2; L:=L+RANK2; 03236400 TOP := I+SIZE2-1; 03236500 FOR N:=I STEP 1 UNTIL TOP DO BEGIN 03236600 IF OPERATION(SP[LOC],SP[MOC],L,OP,ANS) THEN 03236700 SP[NOC] := ANS ELSE GO TO DONE; 03236710 L:=L+1; M:=M+1; END; 03236800 GO TO DONE; END; 03236900 LEFTSCALE: IF SIZE2 = 1 03237000 THEN BEGIN 03237050 IF RANK1 NEQ RANK2 THEN BEGIN 03237060 IF RANK1=0 THEN GO TO SCALVECT; 03237065 IF RANK2=0 THEN BEGIN L:=L-RANK1; GO TO VECTSCAL; END; 03237068 IF CHAR1 AND RANK1=1 THEN GO TO SCALVECT; 03237070 IF CHAR2 AND RANK2=1 THEN GO TO VECTSCAL; 03237075 ERR:=KITEERROR; GO TO DONE; END 03237080 ELSE IF RANK1|RANK2 NEQ 0 THEN GO TO SCALVECT; 03237090 % BOTH OPERANDS ARE SCALAR; 03237100 M := M + RANK2; 03237150 N := GETSPACE(SIZE:=1); RIGHT:=SP[MOC]; 03237200 DESC.SPF := N; DESC.DID := DDPUSW; 03237300 IF OPERATION(LEFT,RIGHT,L,OP,ANS) THEN 03237400 SP[NOC] := ANS ELSE GO TO DONE; 03237410 GO TO DONE; END 03237500 ELSE BEGIN %DESC1 IS SCALAR, DESC2 IS VECTOR; 03237600 03237700 SCALVECT: I := GETSPACE( SIZE := SIZE2 + RANK2); 03237800 DESC.SPF := I; DESC.RF := RANK2; DESC.DID:=DDPUVW; 03237900 SPCOPY(M,I,RANK2); 03238000 M:=M+RANK2; I:=I+RANK2; TOP:=SIZE2+I-1; 03238100 FOR N:=I STEP 1 UNTIL TOP DO BEGIN 03238200 IF OPERATION(LEFT,SP[MOC],L,OP,ANS) 03238290 THEN SP[NOC] := ANS ELSE GO TO DONE; 03238300 M := M+1; END; 03238400 END; 03238450 GO TO DONE; 03238500 DOMAIN: ERR := DOMAINERROR; 03238550 DONE: RESULTD := DESC; 03238560 IF CHAR1 THEN FORGETSPACE(FORGETL,SIZE1+RANK1); 03238570 IF CHAR2 THEN FORGETSPACE(FORGETM,SIZE2+RANK2); 03238580 IF ERR NEQ 0 THEN FORGETSPACE(DESC.SPF, SIZE); 03238590 END PROCEDURE ARITH; 03238600 PROCEDURE DYADICRNDM; 03238700 BEGIN INTEGER NUM, KIND; REAL DESC; 03238800 REAL DESC1, DESC2; 03238805 INTEGER L,M,N,T,I,TEMP,OUTTOP,TOP,PICK; LABEL QUIT; 03238810 INTEGER START; LABEL INSERT; 03238815 DESC1 := AREG; DESC2 := BREG; 03238820 IF FINDSIZE(DESC1) NEQ 1 OR FINDSIZE(DESC2) NEQ 1 03238850 THEN BEGIN ERR:=RANKERROR; GO TO QUIT; END; 03238900 IF DESC1.SPF=0 OR DESC2.SPF=0 THEN BEGIN 03238910 ERR:=DOMAINERROR; GO TO QUIT; END; 03238915 L:=DESC1.SPF+DESC1.RF; M:=DESC2.SPF+DESC2.RF; 03238950 NUM := SP[LOC]; KIND := SP[MOC]; 03239000 IF KIND LSS ORIGIN 03239050 OR NUM GTR PICK := KIND-ORIGIN+1 03239055 OR DESC1.ARRAYTYPE=1 03239060 OR DESC2.ARRAYTYPE=1 THEN BEGIN ERR:=DOMAINERROR; 03239070 GO TO QUIT; END; 03239100 DESC.DID := DDPUVW; DESC.RF := 1; 03239150 IF NUM LEQ 0 THEN BEGIN DESC := NULLV; GO TO QUIT; END; 03239200 IF NUM GTR MAXWORDSTORE THEN BEGIN ERR:=KITEERROR; GO TO QUIT END; 03239210 DESC.SPF := L := GETSPACE(NUM+1); 03239250 SP[LOC] := NUM; L := L+1; 03239300 OUTTOP := L+NUM-1; 03239350 TEMP := GETSPACE(NUM); 03239355 START:=ORIGIN; I:=0; 03239360 FOR L:=L STEP 1 UNTIL OUTTOP DO BEGIN 03239365 PICK:=RANDINT(START,KIND,SEED); 03239370 M:=TEMP; 03239375 IF I = 0 OR PICK LSS SP[MOC] THEN N:=TEMP 03239380 ELSE BEGIN TOP:=TEMP+I-1; 03239385 N:=TEMP+T:=I DIV 2; 03239390 WHILE T GTR 0 DO 03239395 IF PICK GEQ SP[NOC] THEN N:=N+T:=T DIV 2 03239400 ELSE N:=N-T:=T DIV 2; 03239405 03239410 FOR N:=MAX(TEMP,N-3) STEP 1 UNTIL TOP DO 03239415 IF SP[NOC] GTR PICK THEN 03239420 GO TO INSERT; 03239425 END; 03239430 INSERT: IF L LSS OUTTOP THEN BEGIN TOP:=N+1; N:=TEMP+I; 03239435 FOR M:=N STEP -1 UNTIL TOP DO BEGIN 03239440 N:=N-1; SP[MOC] := SP[NOC] - 1; END; 03239445 SP[NOC] := PICK; END; 03239450 SP[LOC] := N - TEMP + PICK; 03239455 KIND:=KIND-1; 03239460 I:=I+1; 03239465 END; 03239470 FORGETSPACE(TEMP,NUM); 03239475 QUIT: RESULTD := DESC; 03239500 END PROCEDURE DYADICRNDM; 03239550 PROCEDURE RHOP; 03239600 BEGIN INTEGER RANK,M,POINT; REAL NEWDESC,DESC1,DESC; 03239605 LABEL QUIT, WORK; BOOLEAN CHARACTER; 03239610 DEFINE TOOBIG=BEGIN ERR:=KITEERROR; GO TO QUIT; END#; 03239615 INTEGER N,TOP,NEWRANK,RANK1, POINT1,SIZE1,L,SIZE2; 03239620 DESC1 := AREG; DESC := BREG; 03239625 IF DESC.SPF = 0 THEN BEGIN ERR:=DOMAINERROR; GO TO QUIT; END; 03239630 IF DESC1.DID NEQ 0 THEN BEGIN %--DYADIC RHO--RESTRUCTURING--------- 03239632 IF L:=DESC1.SPF = 0 THEN BEGIN %NULL LEFT OP MEANS SCALAR ANS 03239635 IF DESC.ARRAYTYPE=1 THEN TOOBIG; %NO SCALAR CHARACTERS 03239638 NEWDESC.SPF:=M:=GETSPACE(1); 03239641 NEWDESC.DID:=DDPUSW; 03239644 L:=DESC.SPF+DESC.RF; 03239647 SP[MOC]:=SP[LOC]; GO TO QUIT; END; 03239650 IF DESC1.ARRAYTYPE NEQ 0 THEN BEGIN 03239653 ERR:=DOMAINERROR; GO TO QUIT; END; 03239656 RANK1:=DESC1.RF; 03239659 IF FINDSIZE(DESC1)=1 THEN BEGIN 03239662 N:=L+RANK1; 03239665 IF SIZE1:=ENTIER(SP[NOC]+.5) LSS 0 THEN BEGIN 03239668 ERR:=DOMAINERROR; GO TO QUIT; END; 03239671 NEWRANK:=1; TOP:=N; GO TO WORK; END; 03239674 IF RANK1 NEQ 1 THEN BEGIN ERR:=RANKERROR; GO TO QUIT; END; 03239677 IF NEWRANK:=SP[LOC] GTR 31 THEN TOOBIG; 03239725 SIZE1:=1; TOP := L+NEWRANK+RANK1-1; 03239726 IF NEWRANK LEQ 0 THEN BEGIN ERR:=SYSTEMERROR; GO TO QUIT; END; 03239727 FOR N:=L+RANK1 STEP 1 UNTIL TOP DO 03239728 IF SIZE1:=SIZE1|ENTIER(SP[NOC]+.5) LSS 0 THEN BEGIN 03239730 ERR:=DOMAINERROR; GO TO QUIT; END; 03239732 WORK: IF SIZE1=0 THEN BEGIN NEWDESC := NULLV; GO TO QUIT END; 03239734 IF SIZE1 GTR MAXWORDSTORE THEN TOOBIG; 03239736 NEWDESC.DID:=DDPUVW; NEWDESC.RF:=NEWRANK; 03239737 NEWDESC.SPF := M := GETSPACE(SIZE1+NEWRANK); 03239738 %CANT USE SPCOPY FOR DIM VECTOR AS LEFT OP MAY NOT BE INTEGER 03239739 FOR L:=L+RANK1 STEP 1 UNTIL TOP DO 03239740 BEGIN SP[MOC]:=ENTIER(SP[LOC]+.5); M:=M+1; END; 03239742 SIZE2:=FINDSIZE(DESC); L:=DESC.SPF; RANK:=DESC.RF; 03239743 IF DESC.ARRAYTYPE=1 THEN BEGIN L:=UNPACK(L,RANK,SIZE2); 03239744 CHARACTER:=TRUE; END; TOP:=SIZE1 DIV SIZE2; POINT:=L+RANK; 03239745 FOR N:=1 STEP 1 UNTIL TOP DO BEGIN SPCOPY(POINT,M,SIZE2); 03239746 M := M+SIZE2; END; 03239748 TOP := SIZE1 MOD SIZE2; SPCOPY(POINT,M,TOP); 03239750 GO TO QUIT; END ELSE 03239752 %--------MONADIC RHO-----DIMENSION VECTOR---------------------- 03239760 RANK := DESC.RF; POINT := DESC.SPF; 03239800 NEWDESC.DID := DDPUVW; NEWDESC.RF := 1; 03239850 IF DESC.DATATYPE = 1 THEN BEGIN 03239900 NEWDESC := NULLV; GO TO QUIT END; 03239950 NEWDESC.SPF := M := GETSPACE(RANK+1); 03240000 SP[MOC] := RANK; 03240050 SPCOPY(POINT,M+1, RANK); 03240100 QUIT: IF CHARACTER THEN BEGIN NEWDESC.ARRAYTYPE:=1; 03240150 FORGETSPACE(L,SIZE2+RANK); 03240152 PACK(NEWDESC.SPF, NEWRANK,SIZE1); END; 03240155 RESULTD := NEWDESC; 03240160 END PROCEDURE RHOP; 03240200 PROCEDURE IOTAP; 03240750 BEGIN INTEGER I,L,M,TOP; REAL DESC; 03240800 REAL LEFTOP, RIGHTOP; 03240802 INTEGER RSIZE,LSIZE,RRANK,LRANK,N,LL,MM,TIP,NIX; 03240805 03240807 LABEL QUIT, DONE; 03240810 LEFTOP:=AREG; RIGHTOP:=BREG; 03240812 IF L:=RIGHTOP.SPF=0 THEN BEGIN ERR:=DOMAINERROR; GO TO QUIT END; 03240813 RSIZE:=FINDSIZE(RIGHTOP); RRANK:=RIGHTOP.RF; 03240815 DESC.DID := DDPUVW; DESC.RF := 1; 03240817 IF LEFTOP.DID NEQ 0 THEN BEGIN %-------DYADIC IOTA------------ 03240820 IF LRANK := LEFTOP.RF GTR 1 THEN BEGIN ERR:=RANKERROR; 03240825 GO TO QUIT; END; 03240830 LSIZE := FINDSIZE(LEFTOP); 03240835 IF M:=LEFTOP.SPF=0 THEN BEGIN %RESULT IS ORIGIN IF IT WAS NULL 03240840 DESC.SPF:=M:=GETSPACE(1); DESC.RF:=0; DESC.SCALAR:=1; 03240842 SP[MOC] := ORIGIN; GO TO QUIT; END; 03240845 IF LEFTOP.ARRAYTYPE=1 THEN M:=UNPACK(M,LRANK,LSIZE); 03240850 IF RIGHTOP.ARRAYTYPE=1 THEN L:=UNPACK(L,RRANK,RSIZE); 03240855 TIP := (NIX:=LSIZE+ORIGIN) - 1; 03240875 DESC.SPF:=N:=GETSPACE(RSIZE+RRANK); 03240880 IF RRANK=0 THEN DESC.SCALAR:=1 ; DESC.RF:=RRANK; 03240890 SPCOPY(L,N,RRANK); 03240895 MM := M+LRANK; LL:=L:=L+RRANK; 03240900 TOP:=N+RRANK+RSIZE-1; 03240905 FOR N:=N+RRANK STEP 1 UNTIL TOP DO BEGIN 03240910 SP[NOC] := NIX; 03240915 M := MM; 03240920 FOR I:=ORIGIN STEP 1 UNTIL TIP DO 03240925 IF OPERATION(SP[MOC],SP[LOC],1,12,LEFTOP) AND LEFTOP=1 03240930 THEN BEGIN SP[NOC]:=I; GO TO DONE; 03240935 END ELSE M:=M+1; 03240940 DONE: L:=L+1; END; 03240945 IF LEFTOP.ARRAYTYPE=1 THEN FORGETSPACE(MM-LRANK,LRANK+LSIZE); 03240950 IF RIGHTOP.ARRAYTYPE=1 THEN FORGETSPACE(LL-RRANK,RRANK+RSIZE); 03240955 END ELSE BEGIN %-------------MONADIC IOTA------------------- 03240960 IF RIGHTOP.ARRAYTYPE=1 THEN 03241000 BEGIN ERR:=DOMAINERROR; GO TO QUIT 03241002 END; 03241004 IF RSIZE NEQ 1 THEN BEGIN ERR:=RANKERROR; GO TO QUIT END; 03241025 03241030 L := L + RRANK; 03241040 IF TOP:=SP[LOC] GTR MAXWORDSTORE THEN 03241050 BEGIN ERR:=KITEERROR; GO TO QUIT 03241054 END; 03241056 03241075 IF TOP LSS ORIGIN THEN BEGIN DESC:=NULLV; GO TO QUIT END; 03241080 DESC.SPF := M := GETSPACE(TOP+1); 03241100 SP[MOC] := TOP; M := M+1; 03241125 TOP := TOP + ORIGIN - 1; 03241130 FOR I := ORIGIN STEP 1 UNTIL TOP DO BEGIN 03241150 SP[MOC] := I; M := M+1; END; 03241175 END; 03241180 QUIT: RESULTD := DESC; 03241200 END PROCEDURE IOTAP; 03241225 PROCEDURE COMMAP; 03241300 BEGIN REAL LDESC, RDESC; 03241400 INTEGER L,M,N,LRANK,RRANK,LSIZE,RSIZE,SIZE; 03241500 REAL DESC; LABEL QUIT; BOOLEAN CHARACTER; 03241600 LDESC := AREG; RDESC := BREG; 03241650 RRANK := RDESC.RF; LRANK := LDESC.RF; 03241700 LSIZE := IF (L := LDESC.SPF) = 0 THEN 0 ELSE FINDSIZE(LDESC); 03241800 RSIZE := IF (M := RDESC.SPF) = 0 THEN 0 ELSE FINDSIZE(RDESC); 03241900 IF RDESC.ARRAYTYPE = 1 THEN BEGIN 03242000 M := UNPACK(M,RRANK,RSIZE); 03242100 CHARACTER := TRUE; END; 03242200 DESC.DID := DDPUVW; DESC.RF := 1; 03242250 IF LDESC.DID = 0 THEN BEGIN %-----MONADIC COMMA--RAVEL-------- 03242300 IF RSIZE=0 THEN BEGIN DESC:=NULLV; GO TO QUIT END; 03242400 DESC.SPF := L := GETSPACE(RSIZE+1); 03242500 SP[LOC] := RSIZE; 03242700 SPCOPY(M+RRANK, L+1, RSIZE); 03242800 N := L; SIZE := RSIZE; 03242850 GO TO QUIT; END 03242900 ELSE BEGIN 03243000 %HERE IS THE CODE FOR DYADIC COMMA, I.E. CATENATION 03243100 IF RRANK NEQ 1 AND RSIZE GTR 1 OR 03243200 LRANK NEQ 1 AND LSIZE GTR 1 THEN BEGIN 03243250 ERR:= RANKERROR; GO TO QUIT; END; 03243300 IF SIZE:=LSIZE+RSIZE GTR MAXWORDSTORE THEN BEGIN 03243400 ERR:=KITEERROR; GO TO QUIT; END; 03243500 COMMENT CANT MIX NUMBERS AND CHARACTERS. HAVE TO JUGGLE 03243540 IF LEFT IS NUMBERS AND RIGHT IS CHARACTERS AS RIGHT 03243541 HAS ALREADY BEEN UNPACKED AND WE DONT WANT TO FORGET 03243542 LEFT AND WE DONT WANT TO PACK THE NON-RESULT; 03243543 IF CHARACTER THEN 03243550 IF LDESC.ARRAYTYPE=1 OR LSIZE=0 THEN L:=UNPACK(L,LRANK,LSIZE) 03243600 ELSE BEGIN SIZE:=0; LSIZE:=-LRANK; ERR:=DOMAINERROR; 03243700 GO TO QUIT END 03243705 ELSE IF LDESC.ARRAYTYPE=1 THEN 03243710 IF RSIZE NEQ 0 THEN 03243715 BEGIN ERR:=DOMAINERROR; GO TO QUIT END 03243720 ELSE BEGIN CHARACTER:=TRUE; 03243725 L:=UNPACK(L,LRANK,LSIZE); END; 03243730 IF SIZE=0 THEN BEGIN DESC:=NULLV; GO TO QUIT END; 03243800 DESC.SPF := N := GETSPACE(SIZE+1); 03243900 SP[NOC] := SIZE; 03244000 SPCOPY(L+LRANK, N+1, LSIZE); 03244100 SPCOPY(M+RRANK, N+LSIZE+1, RSIZE); 03244200 END; 03244300 QUIT: 03244400 IF CHARACTER THEN BEGIN DESC.ARRAYTYPE := 1; 03244500 PACK(N,1,SIZE); 03244600 FORGETSPACE(L,LSIZE+LRANK); 03244700 FORGETSPACE(M,RSIZE+RRANK); 03244800 END; 03244900 RESULTD := DESC; 03245000 END PROCEDURE COMMAP; 03245100 INTEGER STREAM PROCEDURE GETOP(A,N); VALUE N; 03245120 BEGIN SI := A; SI := SI + N; 03245130 DI := LOC GETOP; 03245140 DS := 7 LIT "0"; DS := CHR; 03245150 END PROCEDURE GETOP; 03245160 REAL PROCEDURE IDENTITY(OP); VALUE OP; INTEGER OP; 03246200 BEGIN 03246300 CASE OP OF BEGIN 03246350 IDENTITY := 0; %FOR + 03246400 IDENTITY := 1; %FOR | 03246500 IDENTITY := 0; %FOR - 03246600 IDENTITY := 1; %FOR DIV 03246700 IDENTITY := 1; %FOR * 03246800 ; %NO REDUCTION ON RNDM 03246900 IDENTITY := 0; %FOR RESD 03247000 IDENTITY := BIGGEST; %FOR MIN 03247100 IDENTITY := -BIGGEST; %FOR MAX 03247200 ; %NOT ISNT DYADIC 03247300 IDENTITY := 1; %FOR COMB 03247400 IDENTITY := 0; %FOR LSS 03247500 IDENTITY := 1; %FOR = 03247505 IDENTITY := 1; %FOR GEQ 03247510 IDENTITY := 0; %FOR GTR 03247515 IDENTITY := 0; %FOR NEQ 03247520 IDENTITY := 1; %FOR LEQ 03247525 IDENTITY := 1; %FOR AND 03247600 IDENTITY := 0; %FOR OR 03247700 END; END PROCEDURE IDENTITY; 03247800 INTEGER PROCEDURE GETT(ALONG,RANK); VALUE ALONG, RANK; 03247810 INTEGER ALONG, RANK; 03247820 GETT := IF ALONG=1 THEN 0 ELSE 03247822 IF ALONG=RANK THEN 2 ELSE 03247825 IF ALONG=RANK-1 THEN 1 ELSE 0; 03247830 BOOLEAN PROCEDURE CHECKANDADD(SIZE,L,SUM); 03253305 VALUE SIZE,L; INTEGER SIZE,L,SUM; 03253310 BEGIN LABEL QUIT; INTEGER I,TOP,M,S,T; 03253315 CHECKANDADD:=TRUE; 03253320 SUM := 0; 03253325 TOP := SIZE DIV 2 | 2 - 1 + L; 03253330 FOR L:=L STEP 2 UNTIL TOP DO BEGIN M:=L+1; 03253335 IF NOT BOOLTYPE(S:=SP[LOC], T:=SP[MOC]) THEN BEGIN 03253340 CHECKANDADD:=FALSE; GO TO QUIT; END 03253345 ELSE SUM := SUM+S+T; END; 03253350 IF SIZE MOD 2 = 1 THEN BEGIN 03253355 IF NOT BOOLTYPE(T:=SP[LOC],0) THEN 03253360 CHECKANDADD := FALSE ELSE SUM := SUM+T; 03253365 END; 03253367 QUIT: END PROCEDURE CHECKANDADD; 03253370 PROCEDURE COMPRESS(LDESC, RDESC, DIM); VALUE LDESC,RDESC,DIM; 03253400 REAL LDESC, RDESC, DIM; 03253500 BEGIN INTEGER I,J,K,L,M,N,T,RANK,LSIZE,RSIZE,ALONG,TOP, 03253600 FACTOR,SUM,DIMMOD,SIZE,LEFT,RIGHT,S; 03253700 REAL DESC; BOOLEAN CHARACTER; 03253800 LABEL QUIT,RANKE,DOMAIN,IDENT; 03253900 DESC.DID := DDPUVW; 03254000 IF L := LDESC.SPF = 0 THEN GO TO DOMAIN; 03254100 IF M:=RDESC.SPF=0 THEN BEGIN DESC:=NULLV; GO TO QUIT; END; 03254200 LSIZE := FINDSIZE(LDESC); RSIZE := FINDSIZE(RDESC); 03254300 IF RANK:=LDESC.RF NEQ 1 THEN IF LSIZE NEQ 1 03254350 THEN GO TO DOMAIN; 03254360 LEFT := L := L+RANK; 03254370 RANK := RDESC.RF; 03254400 IF N:=DIM.SPF=0 AND DIM.DID NEQ 0 OR DIM.ARRAYTYPE=1 03254500 OR LDESC.ARRAYTYPE=1 THEN GO TO DOMAIN; 03254510 IF J:=DIM.RF NEQ 0 THEN BEGIN 03254600 IF FINDSIZE(DIM)=1 THEN N:=N+J ELSE GO TO DOMAIN END; 03254700 IF ALONG:=(IF N=J THEN RANK ELSE SP[NOC]-ORIGIN+1) GTR RANK 03254800 OR ALONG LSS 1 AND RANK NEQ 0 03254810 THEN BEGIN ERR:=INDEXERROR; GO TO QUIT; END; 03254900 IF RANK = 0 THEN 03255200 IF LSIZE NEQ 1 THEN GO TO DOMAIN ELSE BEGIN 03255300 IF TOP:=SP[LOC]=0 THEN BEGIN DESC:=NULLV; GO TO QUIT; END; 03255400 IF TOP = 1 THEN BEGIN DESC.SPF := N := GETSPACE(2); 03255500 DESC.RF := SP[NOC] := 1; 03255600 N:=N+1; SP[NOC]:=SP[MOC]; GO TO QUIT; 03255700 END ELSE GO TO DOMAIN; END; 03255800 IF LSIZE = 1 THEN BEGIN 03255805 COMMENT IF LEFT ARG IS SCALAR, ANSWER IS NULL IF 0, 03255810 RIGHT ARG IF 1; 03255815 SUM:=SP[LOC]; 03255820 IF SUM NEQ 0 AND SUM NEQ 1 THEN GO TO DOMAIN 03255825 03255830 ELSE GO TO IDENT; END; 03255835 N := M+ALONG - 1; 03255850 IF LSIZE NEQ (T:=SP[NOC]) THEN BEGIN 03255855 ERR:=LENGTHERROR; GO TO QUIT; END; 03255860 IF NOT CHECKANDADD(LSIZE,LEFT,SUM) THEN GO TO DOMAIN; 03255900 IDENT: IF SUM=0 THEN BEGIN DESC:=NULLV; GO TO QUIT END; 03256800 IF SUM = LSIZE THEN BEGIN 03256900 IF RDESC.ARRAYTYPE=1 THEN BEGIN 03256910 RSIZE:=RSIZE DIV 8 + (IF RSIZE MOD 8 NEQ 0 THEN 1 ELSE 0); 03256920 DESC.CHRMODE:=1; END; 03256930 DESC.SPF:=N:=GETSPACE(TOP:=RSIZE+RANK); 03257000 DESC.RF := RANK; SPCOPY(M,N,TOP); GO TO QUIT; END; 03257100 SIZE := RSIZE DIV T | SUM; 03257120 DESC.RF:=RANK; 03257130 IF RDESC.ARRAYTYPE = 1 THEN BEGIN M:=UNPACK(M,RANK,RSIZE); 03257132 CHARACTER := TRUE; END; 03257133 RIGHT := M; 03257134 DESC.SPF := S := GETSPACE(SIZE+RANK); 03257135 N := S; 03257140 FOR I:=1 STEP 1 UNTIL RANK DO BEGIN 03257150 IF I=ALONG THEN SP[NOC]:=SUM ELSE SP[NOC]:=SP[MOC]; 03257160 N:=N+1; M:=M+1; END; 03257170 T := GETT(ALONG, RANK); 03257200 FACTOR := 1; TOP := RIGHT+ALONG; 03257300 FOR N:=RIGHT+RANK-1 STEP -1 UNTIL TOP DO FACTOR:= 03257400 FACTOR | SP[NOC]; 03257410 N:=RIGHT + RANK - 1; DIM := SP[NOC]; 03257500 N := N+1; M:=S+RANK; I:=0; 03257600 DIMMOD := DIM-1; 03257650 WHILE I LSS RSIZE DO BEGIN 03257700 CASE T OF BEGIN 03257800 L := I DIV FACTOR MOD LSIZE; 03257900 L := I DIV FACTOR MOD DIMMOD; 03258000 L := I MOD DIM; END; 03258100 L := L+LEFT; 03258150 IF SP[LOC] = 1 THEN FOR K:=1 STEP 1 UNTIL FACTOR DO BEGIN 03258200 SP[MOC]:=SP[NOC]; I:=I+1; M:=M+1; N:=N+1; 03258300 END ELSE BEGIN I:=I+FACTOR; N:=N+FACTOR; END; 03258400 END; 03258500 GO TO QUIT; 03259300 RANKE: ERR:=RANKERROR; GO TO QUIT; 03259500 DOMAIN: ERR:=DOMAINERROR; GO TO QUIT; 03259600 QUIT: IF CHARACTER THEN BEGIN PACK(S,RANK,SIZE); 03259900 DESC.ARRAYTYPE:=1; FORGETSPACE(RIGHT,RSIZE+RANK); END; 03260000 RESULTD := DESC; 03260100 POP; 03260150 END PROCEDURE COMPRESS; 03260200 PROCEDURE EXPAND(LDESC,RDESC,DIM); VALUE LDESC,RDESC,DIM; 03268020 REAL LDESC, RDESC, DIM; 03268040 BEGIN INTEGER I,J,K,L,M,N,S,T,RANK,LSIZE,RSIZE,SIZE, 03268060 ALONG,TOP,LADDR,MADDR,FACTOR, SUM; 03268080 REAL DESC, INSERT; 03268100 LABEL QUIT, DOMAIN; 03268120 BOOLEAN CHARACTER; 03268140 LSIZE:=FINDSIZE(LDESC); RSIZE:=FINDSIZE(RDESC); 03268160 RANK := RDESC.RF; 03268180 IF M:=RDESC.SPF=0 03268200 OR L:=LDESC.SPF=0 03268220 OR I:=LDESC.RF GTR 1 03268224 03268226 OR N:=DIM.SPF=0 AND DIM.DID NEQ 0 03268240 OR DIM.ARRAYTYPE=1 03268250 OR FINDSIZE(DIM ) NEQ 1 03268260 OR LDESC.ARRAYTYPE=1 03268270 THEN GO TO DOMAIN; 03268280 N:=N + (T:=DIM.RF); 03268300 IF ALONG :=(IF N=T THEN RANK ELSE SP[NOC]-ORIGIN+1) GTR RANK 03268320 OR ALONG LSS 1 AND RANK NEQ 0 03268330 THEN BEGIN ERR:=INDEXERROR; GO TO QUIT; END; 03268340 IF RANK=0 THEN DIM:=1 03268350 ELSE BEGIN N:=M+ALONG-1; DIM:=SP[NOC]; END; 03268360 IF SIZE:=RSIZE DIV DIM | LSIZE GTR MAXWORDSTORE 03268380 THEN BEGIN ERR:=KITEERROR; GO TO QUIT; END; 03268400 IF NOT CHECKANDADD(LSIZE,LADDR:=L+I, SUM) THEN GO TO DOMAIN; 03268420 IF SUM NEQ DIM THEN BEGIN ERR:=RANKERROR; GO TO QUIT; END; 03268440 IF RANK=0 THEN BEGIN 03268443 DIM:=SP[MOC]; DESC.SPF:=N:=GETSPACE(LSIZE+I); 03268445 DESC.RF:=I; DESC.DID:=(IF I=0 THEN DDPUSW ELSE DDPUVW); 03268447 SPCOPY(L,N,I); L:=L+I; N:=N+I; TOP:=L+LSIZE-1; 03268449 FOR L:=L STEP 1 UNTIL TOP DO BEGIN 03268451 IF SP[LOC]=1 THEN SP[NOC]:=DIM; 03268453 N:=N+1; END; 03268456 GO TO QUIT END; 03268458 IF RDESC.ARRAYTYPE=1 THEN BEGIN CHARACTER:=TRUE; 03268460 M:=UNPACK(M,RANK,RSIZE); 03268480 INSERT := " "; END; 03268500 FACTOR:=1; TOP:=M+ALONG; 03268520 FOR N:=M+RANK-1 STEP -1 UNTIL TOP DO FACTOR:=FACTOR|SP[NOC]; 03268540 T := GETT(ALONG, RANK); 03268580 J:=0; N:=(MADDR:=M) + RANK; 03268600 DESC.SPF:=M:=GETSPACE(SIZE+RANK); 03268620 I:=M+RANK; 03268640 WHILE J LSS SIZE DO BEGIN 03268660 CASE T OF BEGIN 03268680 S := J DIV FACTOR MOD LSIZE; 03268700 S:=J DIV FACTOR MOD LSIZE; 03268720 S:=J MOD LSIZE; END; 03268740 L:=S + LADDR; 03268760 IF SP[LOC]=1 THEN FOR K:=1 STEP 1 UNTIL FACTOR DO 03268780 BEGIN L:=J+I; SP[LOC] := SP[NOC]; 03268800 J:=J+1; N:=N+1; 03268820 END ELSE FOR K:=1 STEP 1 UNTIL FACTOR DO BEGIN 03268840 L:=J+I; SP[LOC]:=INSERT; J:=J+1; END; 03268860 END; 03268880 L := MADDR; 03268900 FOR I:=1 STEP 1 UNTIL RANK DO BEGIN 03268903 IF I = ALONG THEN SP[MOC]:=LSIZE ELSE SP[MOC]:=SP[LOC]; 03268906 M:=M+1; L:=L+1; END; 03268910 DESC.DID:=DDPUVW; DESC.RF:=RANK; 03268920 GO TO QUIT; 03268940 DOMAIN: ERR:=DOMAINERROR; 03268960 QUIT: IF CHARACTER THEN BEGIN DESC.ARRAYTYPE:=1; 03268980 FORGETSPACE(MADDR, RSIZE+RANK); 03269000 PACK(DESC.SPF,RANK,SIZE); END; 03269020 RESULTD:=DESC; 03269040 POP; 03269060 END PROCEDURE EXPAND; 03269080 PROCEDURE MEMBER; 03269100 BEGIN REAL LDESC, RDESC; 03269120 INTEGER L,M,N,I,S,T,LSIZE,RSIZE,LRANK,RRANK,TOP; 03269140 REAL DESC, TEMP, ANS; 03269160 LABEL QUIT; 03269180 LDESC := AREG; RDESC := BREG; 03269190 LSIZE:=FINDSIZE(LDESC); RSIZE:=FINDSIZE(RDESC); 03269200 LRANK:=LDESC.RF; RRANK:=RDESC.RF; 03269220 IF L:=LDESC.SPF=0 OR M:=RDESC.SPF=0 THEN BEGIN 03269240 ERR:=DOMAINERROR; GO TO QUIT END; 03269250 IF LDESC.ARRAYTYPE=1 THEN L:=UNPACK(L,LRANK,LSIZE); 03269260 IF RDESC.ARRAYTYPE=1 THEN M:=UNPACK(M,RRANK,RSIZE); 03269280 DESC:=LDESC; DESC.NAMED:=0; 03269360 DESC.ARRAYTYPE:=0; 03269370 DESC.SPF:=N:=GETSPACE(LSIZE+LRANK); 03269380 SPCOPY(L,N,LRANK); 03269400 N:=N+LRANK; L:=(I:=L)+LRANK; M:=(S:=M)+RRANK; 03269420 T:=M+RSIZE-1; TOP := L+LSIZE-1; 03269440 FOR L:=L STEP 1 UNTIL TOP DO BEGIN 03269460 TEMP:=SP[LOC]; M:=S; 03269480 WHILE M LEQ T DO 03269500 IF OPERATION(TEMP,SP[MOC],0,12,ANS) AND ANS=1 THEN BEGIN 03269520 SP[NOC]:=1; M:=M+T; END ELSE M:=M+1; 03269540 N:=N+1; END; 03269560 03269580 IF RDESC.ARRAYTYPE=1 THEN FORGETSPACE(S,RSIZE+RRANK); 03269600 IF LDESC.ARRAYTYPE=1 THEN FORGETSPACE(I,LSIZE+LRANK); 03269620 QUIT: RESULTD:=DESC; 03269640 END PROCEDURE MEMBER; 03269660 REAL PROCEDURE BASEVALUE; 03269800 BEGIN 03269860 COMMENT THIS RETURNS A DESCRIPTOR FOR A SCALAR RESULT; 03269870 LABEL OUTE,BAD; 03269880 REAL E,L,M,LEFT,RIGHT,T,LARG,RARG; 03269900 LARG := AREG; RARG := BREG; 03269910 IF M:=RARG.SPF=0 OR LARG.CHRMODE=1 OR RARG.CHRMODE=1 03269920 OR L:=LARG.SPF=0 AND LARG.DID NEQ 0 03269930 THEN GO TO BAD; 03269940 RIGHT:=SP[MOC]; 03269960 LEFT:=SP[LOC]; 03269980 IF FINDSIZE(LARG)=1 THEN % A 1 ELEMENT VECTOR 03269982 BEGIN 03269984 L:=L+LARG.RF; 03269986 LARG.SCALAR:=1; 03269987 LEFT:=SP[LOC]; 03269988 END; 03269990 IF FINDSIZE(RARG)=1 THEN % A ONE ELEMENT VECTOR 03269992 BEGIN 03269994 M:=M+RARG.RF; 03269996 RIGHT:=SP[MOC]; 03269998 RARG.SCALAR:=1; 03269999 END; 03270000 IF L=0 THEN 03270002 BEGIN % BASEVAL MONADIC 03270004 LEFT:=2; %IF MONADIC, ITS 2 BASVAL X 03270006 LARG.SCALAR:=1; 03270008 END; 03270010 IF BOOLEAN(LARG.SCALAR )THEN %SCALAR 03270018 IF BOOLEAN(RARG.SCALAR) THEN 03270020 BEGIN 03270025 T:=RIGHT; %SCALAR-SCALAR 03270030 GO OUTE; 03270035 END 03270037 ELSE 03270040 IF RARG.RF=1 THEN 03270060 BEGIN COMMENT SCALAR-VECTOR--LEFT IS VALUE OF SCALAR, RIGHT 03270080 IS # OF ELEMENTS; 03270100 IF LEFT=0 THEN GO OUTE 03270120 ELSE E:=1/LEFT; 03270140 FOR L :=M+RIGHT STEP -1 UNTIL M+1 DO 03270160 T:=T+SP[LOC]|(E:=E|LEFT); 03270180 GO OUTE; 03270200 END 03270300 ELSE BAD: ERR:=DOMAINERROR 03270320 ELSE 03270340 IF RARG.SCALAR=0 THEN 03270380 IF LARG.RF NEQ 1 OR RARG.RF NEQ 1 THEN 03270400 ERR:=DOMAINERROR 03270420 ELSE 03270440 BEGIN 03270460 GT2:=L; % SAVE FOR LATER TEST 03270480 GT1:=M+2; % WANT TO STOP 2 UP IN LOOP 03270500 L:=L+LEFT; % START AT OTHER END 03270520 E:=1; 03270540 M:=M+RIGHT; 03270560 T:=SP[MOC]; % INITIAL VALUE 03270580 FOR M:=M-1 STEP -1 UNTIL GT1 DO 03270600 BEGIN 03270620 IF L:=L-1 LSS GT2 THEN L:=GT2+LEFT; % START OVER 03270640 E:=E|SP[LOC]; 03270660 T:=T+SP[MOC]|E; 03270680 END; 03270700 OUTE: 03270702 L:=GETSPACE(1); 03270704 SP[LOC]:=T; 03270708 T:=0; 03270710 T.DID:=DDPUSW; % BUILD DESCRIPTOR 03270712 T.SPF:=L; 03270716 BASEVALUE:=T; 03270720 END 03270740 ELSE ERR := DOMAINERROR 03270760 END OF BASEVALUE; 03270800 REAL PROCEDURE REPRESENT; 03270820 BEGIN 03270880 COMMENT RETURNS DESCRIPTOR OF VECTOR IF LARG VECTOR AND RARG SCALAR;03270900 REAL L,M,LEFT,RIGHT,T,E,LARG,RARG; 03270920 LABEL AROUND; 03270925 LARG := AREG; RARG := BREG; 03270930 IF (RARG.SCALAR=1 OR FINDSIZE(RARG)=1 AND RARG.CHRMODE=0) 03270940 AND NOT(LARG.SCALAR=1 OR LARG.CHRMODE=1 OR LARG.RF NEQ 1) THEN 03270950 BEGIN 03270960 COMMENT VECTOR-SCALAR; 03270980 IF L:=LARG.SPF=0 OR M:=RARG.SPF=0 THEN GO AROUND; 03271000 IF RARG.SCALAR=0 THEN M:=M+RARG.RF; 03271020 RIGHT:=SP[MOC]; % VALUE OF SCALAR 03271040 LEFT:=SP[LOC]; % LENGTH OF VECTOR 03271060 E:=M:=GETSPACE(LEFT+1); % MAKE ROOM FOR ANSWER 03271080 SP[MOC]:=LEFT; % LENGTH OF ANSWER 03271100 M:=M+LEFT; 03271120 GT1:=L+2; 03271140 FOR L:=L+LEFT STEP -1 UNTIL GT1 DO 03271160 IF T:=SP[LOC] LEQ 0 THEN 03271180 IF T LSS 0 THEN ERR := DOMAINERROR 03271200 ELSE 03271220 BEGIN 03271240 L:=GT1-1 ; % STOP THE LOOP 03271260 M:=M-1; 03271280 END 03271300 ELSE 03271320 BEGIN 03271340 SP[MOC]:= RIGHT MOD T; 03271360 RIGHT:=RIGHT DIV T; 03271380 M:=M-1; 03271400 IF RIGHT LSS FUZZ THEN L:=GT1-1; % STOP THE LOOP 03271420 END; 03271440 SP[MOC]:=RIGHT; % LEFTOVER GOES HERE 03271460 T.DID:=DDPUVW; 03271480 T.RF:=1; 03271500 T.SPF:=E; 03271520 REPRESENT:=T; 03271540 END 03271560 ELSE AROUND: ERR:=DOMAINERROR; 03271580 END OF REPRESENT; 03271600 PROCEDURE PERIOD(LDESC,RDESC,LOP,ROP); 03271800 VALUE LDESC,RDESC,LOP,ROP; REAL LDESC,RDESC; INTEGER LOP,ROP; 03271820 BEGIN INTEGER L,M,N,J,LRANK,RRANK,RANK,LSIZE,RSIZE,SIZE,LL,MM,I, 03271840 RROW,RCOL,LROW,LCOL,LJUMP,RJUMP,MSAVE,LSAVE,RSTART; 03271860 REAL DESC, TEMP; 03271880 BOOLEAN CHARACTER, FIRST,LSCALAR, RSCALAR; 03271900 LABEL QUIT, DOMAIN, FORGET, OUTERPROD; 03271920 IF L:=LDESC.SPF = 0 OR M := RDESC.SPF=0 THEN GO TO DOMAIN; 03271940 LSIZE := FINDSIZE(LDESC); RSIZE:=FINDSIZE(RDESC); 03271960 LRANK:=LDESC.RF; RRANK := RDESC.RF; 03271965 IF LOP NEQ 45 THEN 03271970 IF LRANK GTR 2 AND LSIZE NEQ 1 OR RRANK GTR 2 AND RSIZE NEQ 1 THEN 03271975 BEGIN ERR:=KITEERROR; GO TO QUIT; END; 03271980 IF ROP:=GETOP(CORRESPONDENCE,ROP-1) = 9 THEN BEGIN 03271982 ERR:=SYNTAXERROR; GO TO QUIT; END; 03271985 IF LL:=LDESC.ARRAYTYPE=1 OR MM:=RDESC.ARRAYTYPE=1 THEN 03271990 IF LL | MM NEQ 1 THEN GO TO DOMAIN 03271992 ELSE BEGIN 03272000 03272001 IF ROP LSS 11 OR ROP GTR 16 THEN GO TO DOMAIN; 03272002 CHARACTER:=TRUE; 03272003 M:=UNPACK(M,RRANK,RSIZE); 03272004 L:=UNPACK(L,LRANK,LSIZE); END; 03272005 MSAVE := M; LSAVE:=L; IF ROP NEQ 45 THEN 03272006 IF LOP=45 THEN GO TO OUTERPROD ELSE 03272009 IF LOP:=GETOP(CORRESPONDENCE,LOP-1)=9 THEN 03272040 BEGIN ERR:=SYNTAXERROR; GO TO QUIT; END; 03272045 IF LRANK=2 THEN BEGIN 03272050 N:=L+LRANK-1; LCOL := SP[NOC]; 03272060 N:=N-1; LROW:=SP[NOC]; END; 03272070 IF LRANK=1 THEN BEGIN LROW:=1; LCOL:=SP[LOC]; END; 03272080 IF RRANK=2 THEN BEGIN 03272100 N :=M+RRANK-1; RCOL:=SP[NOC]; 03272110 N:=N-1; RROW:=SP[NOC]; END; 03272120 IF RRANK=1 THEN BEGIN RROW:=SP[MOC]; RCOL:=1; END; 03272140 IF LSIZE =1 OR RSIZE=1 THEN BEGIN 03272142 IF LSIZE = 1 AND RSIZE = 1 THEN LROW:=LCOL:=RROW:=RCOL:=1 03272145 ELSE IF LSIZE=1 THEN BEGIN LCOL:=RROW; LROW:=1; 03272150 L:=L+LRANK-1; LRANK:=1; 03272155 LSCALAR:=TRUE; END 03272160 ELSE BEGIN RROW := LCOL; RCOL := 1; 03272170 M:=M+RRANK-1; RRANK:=1; 03272175 RSCALAR:=TRUE; END; 03272180 END; 03272185 IF LCOL NEQ RROW 03272240 THEN BEGIN ERR:=RANKERROR; GO TO QUIT; END; 03272245 DESC.SPF:=N:=GETSPACE((RANK:=MAX(0,LRANK+RRANK-2))+ 03272360 SIZE:=LROW|RCOL); 03272380 SPCOPY(L,N,LRANK-1); 03272400 SPCOPY(M+1,N+LRANK-1,RRANK-1); 03272420 DESC.RF:=RANK; DESC.DID:=(IF RANK=0 THEN DDPUSW ELSE DDPUVW); 03272440 N:=N+RANK; 03272460 LL := L + LRANK - 1; 03272480 MM := M + RRANK - 1; 03272500 LJUMP := LCOL-1; RJUMP := IF RSCALAR THEN 0 ELSE (RROW-1) | RCOL; 03272520 FOR J:=1 STEP LCOL UNTIL LSIZE DO 03272540 FOR RSTART:=1 STEP 1 UNTIL RCOL DO BEGIN 03272560 FIRST:=TRUE; 03272580 M := MM + RSTART + RJUMP; RROW := LL+J; 03272600 FOR I:=LL + LJUMP + J STEP -1 UNTIL RROW DO BEGIN 03272620 IF LSCALAR THEN L:=LL+1 ELSE L:=I; 03272630 IF FIRST THEN BEGIN 03272640 IF NOT OPERATION(SP[LOC],SP[MOC],1,ROP,SP[NOC]) 03272660 THEN GO TO FORGET ELSE FIRST := FALSE; 03272680 END ELSE BEGIN 03272700 IF NOT OPERATION(SP[LOC],SP[MOC],1,ROP,TEMP) 03272720 THEN GO TO FORGET; 03272740 IF NOT OPERATION(TEMP,SP[NOC],-1,LOP,SP[NOC]) 03272760 THEN GO TO FORGET; END; 03272780 IF NOT RSCALAR THEN M:=M-RCOL; END; 03272800 N := N+1; 03272820 END; 03272840 GO TO QUIT; 03272860 OUTERPROD: IF SIZE:=LSIZE|RSIZE GTR MAXWORDSTORE 03272880 OR RANK := LRANK+RRANK GTR 31 THEN BEGIN 03272900 ERR:=KITEERROR; GO TO QUIT; END; 03272920 DESC.SPF:=N:=GETSPACE(SIZE+RANK); 03273060 DESC.DID:=IF RANK=0 THEN DDPUSW ELSE DDPUVW; 03273080 DESC.RF:=RANK; 03273100 SPCOPY(L,N,LRANK); 03273120 SPCOPY(M,N+LRANK,RRANK); 03273140 N:=N+RANK; 03273160 I:=L + LRANK + LSIZE - 1; 03273180 MM := M+RRANK + RSIZE - 1; 03273200 FOR L:=L+LRANK STEP 1 UNTIL I DO 03273220 FOR M:=MSAVE+RRANK STEP 1 UNTIL MM DO 03273240 IF NOT OPERATION(SP[LOC],SP[MOC],1,ROP,SP[NOC]) THEN 03273260 GO TO FORGET ELSE N:=N+1; 03273280 GO TO QUIT; 03273285 FORGET: FORGETSPACE(DESC.SPF,RANK+SIZE); 03273300 DOMAIN: ERR:=DOMAINERROR; 03273320 QUIT: IF CHARACTER THEN BEGIN 03273340 FORGETSPACE(MSAVE , RRANK+RSIZE); 03273380 FORGETSPACE(LSAVE , LRANK+LSIZE); END; 03273400 RESULTD := DESC; 03273420 END PROCEDURE PERIOD; 03273440 PROCEDURE REVERSE(SOURCE,LENGTH,DEST,JUMP); VALUE SOURCE,DEST, 03273442 LENGTH,JUMP; INTEGER SOURCE,LENGTH,DEST,JUMP; 03273444 BEGIN INTEGER L,M,TOP; 03273446 M:=SOURCE + TOP:=(LENGTH-1) | JUMP; TOP:=DEST+TOP; 03273448 FOR L:=DEST STEP JUMP UNTIL TOP DO BEGIN 03273450 SP[LOC] := SP[MOC]; M:=M-JUMP; END; 03273452 END PROCEDURE REVERSE; 03273454 PROCEDURE ROTATE(SOURCE,LENGTH,DEST,JUMP,ROT); VALUE SOURCE, 03273456 LENGTH,DEST,JUMP,ROT; INTEGER SOURCE,LENGTH,DEST,JUMP,ROT; 03273458 BEGIN INTEGER L,M,TOP; 03273460 TOP := SOURCE + (LENGTH-1) | JUMP; 03273462 FOR L:=SOURCE STEP JUMP UNTIL TOP DO BEGIN 03273464 M:=DEST+(ROT MOD LENGTH)|JUMP; SP[MOC]:=SP[LOC]; 03273466 ROT := ROT + 1; END; 03273468 END PROCEDURE ROTATE; 03273470 INTEGER PROCEDURE GETNUM(TIM,L,SIZE,DIM); VALUE TIM,L, 03273472 SIZE,DIM; INTEGER TIM,L,SIZE,DIM; 03273474 BEGIN INTEGER NUM; 03273476 IF SIZE NEQ 0 THEN L := L + TIM; 03273478 NUM:=SIGN(NUM:=SP[LOC]) | ENTIER(ABS(NUM)) MOD DIM; 03273482 IF NUM LSS 0 THEN GETNUM := -NUM %FOR RIGHT ROTATION 03273484 ELSE GETNUM:=DIM-NUM; %FOR LEFT ROTATION 03273486 END PROCEDURE GETNUM; 03273489 BOOLEAN PROCEDURE MATCHROT(LDESC,RDESC,ALONG); VALUE LDESC, 03273490 RDESC,ALONG; INTEGER LDESC,RDESC,ALONG; 03273491 BEGIN INTEGER I,L,M,R; LABEL QUIT; 03273492 MATCHROT:=TRUE; L:=LDESC.SPF; M:=RDESC.SPF; 03273493 IF R:=LDESC.RF NEQ RDESC.RF-1 THEN BEGIN 03273494 MATCHROT:=FALSE; GO TO QUIT; END; 03273495 FOR I:=1 STEP 1 UNTIL R DO BEGIN IF I=ALONG THEN M:=M+1; 03273496 IF SP[LOC] NEQ SP[MOC] THEN BEGIN MATCHROT:=FALSE; 03273497 GO TO QUIT; END; M:=M+1; L:=L+1; END; 03273498 QUIT: END PROCEDURE MATCHROT; 03273499 PROCEDURE REDUCESORTSCAN(LOP,RDESC,DIM,KIND); VALUE LOP,RDESC, 03273500 DIM,KIND; REAL LOP,RDESC,DIM; INTEGER KIND; 03273520 BEGIN INTEGER L,M,N,I,J,K,ALONG,FACTOR,T,MSAVE,DIFF,SSIZE, 03273540 JUMP,RANK,SIZE,TOP,LASTDIM,INTERVAL,TEMP,HOP; 03273560 INTEGER REMDIM,LRANK,LSAVE,LSIZE,S; 03273565 BOOLEAN CHARACTER,REDUCE,SORT,SCAN,REVERSAL,ROTATION; 03273580 REAL DESC; 03273600 LABEL QUIT, FORGET, RANKERR; 03273620 COMMENT: KIND=1 FOR REDUCTION 03273622 KIND=2 FOR SORTUP OR SORTDN 03273624 KIND=3 FOR SCAN 03273626 KIND=4 FOR REVERSAL 03273628 KIND=5 FOR ROTATION; 03273630 PROCEDURE SORTIT(L,M,SIZE,JUMP,UP); VALUE L,M,SIZE,JUMP,UP; 03273640 INTEGER L,M,SIZE,JUMP; BOOLEAN UP; 03273660 BEGIN INTEGER N,TIP,TOP,LSAVE; 03273680 REAL COMPARE,OUTOFIT; 03273700 OUTOFIT:=IF UP THEN BIGGEST ELSE -BIGGEST; 03273720 TIP := M + (N:=(SIZE-1)) | JUMP; TOP := L + N; 03273740 LSAVE := L; 03273760 FOR M:=M STEP JUMP UNTIL TIP DO BEGIN 03273800 L := LSAVE; COMPARE := SP[LOC]; N:=L; 03273820 FOR L:=L+1 STEP 1 UNTIL TOP DO 03273830 IF UP THEN BEGIN IF SP[LOC] LSS COMPARE THEN BEGIN 03273840 N:=L; COMPARE:=SP[LOC]; END; 03273860 END ELSE IF SP[LOC] GTR COMPARE THEN BEGIN 03273880 N:=L; COMPARE:=SP[LOC]; END; 03273900 SP[NOC] := OUTOFIT; 03273920 SP[MOC] := (N-LSAVE) + ORIGIN; 03273940 END; 03273960 END PROCEDURE SORTIT; 03273980 CASE KIND OF BEGIN ; REDUCE:=TRUE; SORT:=TRUE; SCAN:=TRUE; 03273990 REVERSAL:=TRUE; ROTATION:=TRUE; END; 03273995 IF LOP GTR 64 AND NOT ROTATION THEN BEGIN 03274000 ERR:=SYSTEMERROR; GO TO QUIT; END; 03274010 IF REDUCE OR SCAN THEN IF LOP NEQ 45 THEN 03274020 LOP := GETOP(CORRESPONDENCE,LOP-1); 03274030 IF M:=RDESC.SPF=0 AND NOT REDUCE 03274040 OR DIM.DID NEQ 0 AND N:=DIM.SPF=0 OR DIM.ARRAYTYPE=1 03274060 OR FINDSIZE(DIM) NEQ 1 THEN BEGIN 03274065 ERR:=DOMAINERROR; GO TO QUIT END; 03274070 IF (REDUCE OR SCAN) AND LOP=9 THEN BEGIN %OP NOT DYADIC SCALAR 03274080 ERR:=SYNTAXERROR; GO TO QUIT END; 03274100 IF M=0 THEN BEGIN 03274102 %FOR REDUCTION, RESULT OF A NULL IS CORRESPONDING IDENTITY 03274105 %EXCEPT THAT NAND, NOR, CIRCLE, AND LOG (LOP GTR 18) 03274106 %HAVE NO IDENTITIES, SO THE RESULT IS A NULL 03274107 DESC.DID := DDPUSW; 03274108 IF LOP LEQ 18 THEN BEGIN DESC.SPF:=N:=GETSPACE(1); 03274110 SP[NOC] := IDENTITY(LOP); END ELSE DESC.RF:=1; 03274111 GO TO QUIT; END; 03274113 IF RDESC.ARRAYTYPE=1 AND (REDUCE OR SCAN) THEN 03274115 BEGIN ERR:=DOMAINERROR; GO TO QUIT; END; 03274117 SIZE:=FINDSIZE(RDESC); 03274120 RANK:=RDESC.RF; 03274140 IF SIZE=1 THEN BEGIN 03274160 %UNLESS SORT, RESULT OF SINGLE-VALUED ARGUMENT IS THAT ARGUMENT 03274165 DESC := RDESC; 03274180 DESC.SPF := N := GETSPACE(RANK+1); 03274200 SPCOPY(M,N,RANK);M:=M+RANK;N:=N+RANK; 03274220 IF SORT THEN BEGIN SP[NOC]:=ORIGIN; DESC.ARRAYTYPE:=0; 03274240 END ELSE SP[NOC]:=SP[MOC]; 03274260 GO TO QUIT; END; 03274280 03274300 IF RDESC.ARRAYTYPE=1 THEN BEGIN 03274320 CHARACTER := TRUE; 03274360 M:=UNPACK(M,RANK,SIZE); END; 03274380 MSAVE:=M; 03274400 N:=N+(T:=DIM.RF); 03274420 IF ALONG:=(IF N=T THEN RANK ELSE SP[NOC]-ORIGIN+1) GTR RANK 03274440 OR ALONG LSS 1 03274450 THEN BEGIN ERR:=INDEXERROR; GO TO QUIT; END; 03274460 IF ROTATION THEN BEGIN 03274462 IF LSAVE:=LOP.SPF=0 OR LOP.ARRAYTYPE=1 THEN 03274464 BEGIN ERR:=DOMAINERROR; GO TO QUIT; END; 03274466 IF LSIZE:=FINDSIZE(LOP) NEQ 1 THEN 03274468 IF NOT MATCHROT(LOP,RDESC,ALONG) THEN BEGIN 03274470 ERR:=RANKERROR; GO TO QUIT; END; 03274472 LSAVE := LSAVE + LRANK := LOP.RF; 03274474 IF LSIZE = 1 THEN LRANK := 0; END; 03274476 N:=M+ALONG-1; 03274480 DIM:=SP[NOC]; 03274500 JUMP:=1; I:=M+ALONG; 03274520 FOR L:=M+RANK-1 STEP -1 UNTIL I DO JUMP:=JUMP | SP[LOC]; 03274540 N:=M+RANK-1; LASTDIM:=SP[NOC]; 03274560 IF ALONG = RANK-1 THEN BEGIN N:=N-1; 03274580 FACTOR:=LASTDIM | SP[NOC]; END; 03274600 T := GETT(ALONG, RANK); 03274620 J := M + RANK; 03274622 REMDIM := 1; 03274623 HOP := (DIM-1) | JUMP; 03274624 DESC.DID := DDPUVW; 03274625 IF ALONG GTR 1 AND ALONG LSS RANK-1 THEN BEGIN TOP:=M+ALONG-2; 03274626 FOR L:=M STEP 1 UNTIL TOP DO REMDIM:=REMDIM|SP[LOC]; END; 03274627 IF REDUCE THEN BEGIN DESC.SPF:=N:=GETSPACE(SSIZE:=SIZE DIV DIM 03274628 + RANK - 1); 03274629 IF RANK=1 THEN DESC.SCALAR:=1 ELSE DESC.RF:=RANK-1; 03274631 FOR I:=1 STEP 1 UNTIL RANK DO BEGIN 03274634 IF I NEQ ALONG THEN BEGIN SP[NOC]:=SP[MOC]; N:=N+1; END; 03274637 M:=M+1; END; 03274640 JUMP := - JUMP; 03274643 END ELSE BEGIN DESC.SPF:=N:=GETSPACE(SSIZE:=SIZE+RANK); 03274646 INTERVAL := (DIFF := N-M) + HOP; 03274648 SPCOPY(M,N,RANK); DESC.RF:=RANK; END; 03274649 IF SORT THEN TEMP:= GETSPACE(DIM); 03274720 TOP := SIZE DIV (DIM | REMDIM) - 1; 03274732 FOR S:=1 STEP 1 UNTIL REMDIM DO BEGIN 03274735 FOR I:=0 STEP 1 UNTIL TOP DO BEGIN 03274740 CASE T OF BEGIN 03274760 L := I + J; 03274780 L:=I DIV LASTDIM|FACTOR + I MOD LASTDIM + J; 03274800 L:=I|LASTDIM + J; END; 03274820 IF REDUCE THEN BEGIN M:=I+N; L:=HOP + (K:=L); 03274822 SP[MOC] := SP[LOC]; 03274825 FOR L:=L+JUMP STEP JUMP UNTIL K DO 03274828 IF NOT OPERATION(SP[LOC],SP[MOC],-1,LOP,SP[MOC]) 03274831 THEN GO TO FORGET; 03274834 END ELSE 03274837 IF SORT THEN BEGIN K:=L+HOP; N:=TEMP; 03274840 FOR M:=L STEP JUMP UNTIL K DO BEGIN 03274845 SP[NOC] := SP[MOC]; N:=N+1; END; 03274850 IF LOP LSS 0 THEN SORTIT(TEMP,L+DIFF,DIM,JUMP,FALSE) 03274860 ELSE SORTIT(TEMP,L+DIFF,DIM,JUMP,TRUE); 03274880 END ELSE IF SCAN THEN BEGIN 03274900 K:=L+INTERVAL; N:=L+DIFF; SP[NOC] := SP[LOC]; 03274920 FOR N:=N+JUMP STEP JUMP UNTIL K DO BEGIN 03274940 M:=N-JUMP; L:=L+JUMP; 03274980 IF NOT OPERATION(SP[MOC],SP[LOC],-1,LOP,SP[NOC]) 03275000 THEN GO TO FORGET; END; 03275020 END ELSE IF REVERSAL THEN REVERSE(L,DIM,L+DIFF,JUMP) 03275040 ELSE IF ROTATION THEN ROTATE(L,DIM,L+DIFF,JUMP, 03275050 GETNUM(I,LSAVE,LRANK,DIM)); 03275060 END; 03275080 J := J + ABS(JUMP|DIM); 03275085 N := N + TOP + 1; 03275088 DIFF := DIFF + TOP + 1; 03275089 END; 03275090 GO TO QUIT; 03275100 RANKERR: ERR:=RANKERROR; FORGETSPACE(DESC.SPF,SSIZE);GO QUIT; 03275110 FORGET: ERR:=DOMAINERROR; FORGETSPACE(DESC.SPF, SSIZE); 03275120 QUIT: IF CHARACTER THEN BEGIN 03275140 FORGETSPACE(MSAVE,SIZE+RANK); 03275142 IF (REVERSAL OR ROTATION) AND ERR=0 THEN BEGIN 03275144 DESC.ARRAYTYPE:=1; PACK(DESC.SPF,RANK,SIZE); END; END; 03275146 IF SORT THEN FORGETSPACE(TEMP,DIM); 03275150 RESULTD := DESC; 03275160 IF ROTATION THEN POP; 03275165 END PROCEDURE REDUCESORTSCAN; 03275180 PROCEDURE DYADICTRANS; 03275200 BEGIN REAL LDESC,RDESC; 03275300 INTEGER L,M,N,RANK,NEWRANK,SIZE,TEMP,I,J; 03275400 DEFINE SPTOP=RDESC#,MIN=RDESC#,PTR=NEWRANK#,MBASE=LDESC#,TOP=RDESC# 03275500 ,RESULT=RESULTD#; 03275510 LABEL QUIT; BOOLEAN CARRY; 03275600 INTEGER ARRAY RVEC,DEL,SUB,OLDEL[0:31]; 03275700 LDESC:=AREG; RDESC:=BREG; 03275800 RESULT:=0; L:=LDESC.SPF; J:=LDESC.RF; RANK:=RDESC.RF; 03275900 IF M:=RDESC.SPF=0 OR L=0 OR LDESC.ARRAYTYPE=1 THEN BEGIN 03276000 ERR:=DOMAINERROR; GO TO QUIT END; 03276010 IF NUMELEMENTS(LDESC)=1 THEN BEGIN N:=L+J; 03276100 IF SP[NOC] NEQ ORIGIN OR RANK GTR 1 THEN BEGIN 03276200 ERR:=DOMAINERROR; GO TO QUIT END; 03276300 %IF WE GET HERE, THE ANSWER IS ITSELF 03276310 RESULT:=RDESC; I:=NUMELEMENTS(RDESC); 03276400 RESULT.SPF:=N:=GETSPACE(SIZE:=RANK+I); RESULT.NAMED:=0; 03276410 SPCOPY(M,N,SIZE); GO TO QUIT; END; 03276420 IF J GTR 1 THEN BEGIN ERR:=RANKERROR; GO TO QUIT END; 03276430 IF SP[LOC] NEQ RANK THEN BEGIN ERR:=LENGTHERROR; GO TO QUIT END; 03276440 % FIND MAX OF LDESC FOR NOW- DO THE REST LATER 03276500 %LDESC W/R/T/ ORIGIN 0 GETS STORED IN SUB[I] 03276600 SPTOP:=L+RANK; NEWRANK:=0; I:=0; 03276700 FOR N:=L+1 STEP 1 UNTIL SPTOP DO BEGIN 03276800 IF TEMP:=SP[NOC]-ORIGIN+1 GTR NEWRANK THEN NEWRANK:=TEMP; 03276900 SUB[I]:=TEMP-1; I:=I+1 END; 03277000 IF NEWRANK GTR RANK THEN BEGIN ERR:=DOMAINERROR;GO TO QUIT END; 03277010 % CALCULATE THE OLD DEL VECTOR, OLDEL 03277100 OLDEL[RANK-1]:=1; N:=M+RANK-1; 03277200 FOR I:=RANK-2 STEP -1 UNTIL 0 DO BEGIN 03277300 OLDEL[I]:=OLDEL[I+1]|SP[NOC]; N:=N-1 END; 03277400 MBASE:=M; SIZE:=1; 03277500 %FIX UP THE NEW RVEC AND DEL 03277700 FOR I:=NEWRANK-1 STEP -1 UNTIL 0 DO BEGIN 03277800 % FIND SMALLEST EL. OF RHO RDESC [J] S.T. A[J]=I 03277900 % AND SUM OF OLDEL[J] S.T. A[J]=I 03278000 MIN:=31; TEMP:=0; 03278100 FOR J:=RANK-1 STEP -1 UNTIL 0 DO 03278200 IF SUB[J]=I THEN BEGIN 03278300 M:=MBASE+J; 03278400 IF SP[MOC] LSS MIN THEN MIN:=SP[MOC]; 03278500 TEMP:=TEMP+OLDEL[J] END; 03278600 RVEC[I]:=MIN; DEL[I]:=TEMP; SIZE:=SIZE|RVEC[I]; 03278700 IF TEMP=0 THEN BEGIN %IT DOESN7T EXHAUSE IOTA NEWRANK 03278710 ERR:=DOMAINERROR; GO TO QUIT END; 03278720 END; 03278800 RESULT:=M:=GETSPACE(NEWRANK+SIZE); 03279200 RESULT.RF:=NEWRANK; RESULT.DID:=DDPUVW; 03279300 IF BOOLEAN(BREG.ARRAYTYPE) THEN BEGIN 03279310 RESULT.ARRAYTYPE:=1; N:=MBASE; 03279320 MBASE:=UNPACK(MBASE,RANK,N:=OLDEL[0]|SP[NOC]); 03279330 FORGETSPACE(MBASE,N+RANK) END; 03279340 FOR I:=1 STEP 1 UNTIL NEWRANK DO BEGIN 03279400 SP[MOC]:=RVEC[I-1]; M:=M+1 END; 03279500 %INITIALIZE FOR STEPPING THRU NEW ARRAY 03279590 FOR I:=NEWRANK-1 STEP -1 UNTIL 0 DO BEGIN 03279600 SUB[I]:=0; OLDEL[I]:=RVEC[I]|DEL[I] END; 03279610 L:=MBASE+RANK; 03279700 %STEP THRU THE SUBSCRIPTS OF THE ANSWER TO PICK UP THE ELEMENTS 03279800 % IN ROW ORDER ACCORDING TO THE MAPPING GIVEN BY DEL 03279900 PTR:=TOP:=NEWRANK-1; 03280000 FOR I:=1 STEP 1 UNTIL SIZE DO BEGIN 03280100 SP[MOC] :=SP[LOC]; 03280200 M:=M+1; 03280300 %GET NEXT SUBSCRIPT FOR NEW ARRAY AND SET NEXT L; 03280400 SUB[PTR]:=SUB[PTR]+1; 03280500 L:=L+DEL[TOP]; 03280600 CARRY:=TRUE; 03280700 WHILE CARRY AND I NEQ SIZE DO 03280800 IF SUB[PTR] GEQ RVEC[PTR] THEN BEGIN 03280900 SUB[PTR]:=0; 03280990 L:=L-OLDEL[PTR]+DEL[PTR:=PTR-1]; 03281000 SUB[PTR]:=SUB[PTR]+1 03281100 END ELSE CARRY := FALSE; 03281200 PTR:=TOP; 03281210 END; 03281600 IF BOOLEAN(RESULT.ARRAYTYPE) THEN PACK(RESULT.SPF,TOP+1,SIZE); 03281700 QUIT: END OF DYADICTRANS; 03281710 INTEGER PROCEDURE LOCATE(L,M); VALUE L,M; REAL L,M; 03490000 BEGIN 03490100 COMMENT L IS THE DIMENSION VECTOR(DESCRIPTOR), 03490200 M IS THE INDEX VECTOR; 03490300 INTEGER P,I,UB; 03490400 L:=I:=L.SPF; M:=I:=M.SPF; 03490500 UB:=SP[MOC]-1; 03490600 M:=M+1; 03490700 FOR I:=1 STEP 1 UNTIL UB DO 03490800 BEGIN 03490900 L:=L+1; 03491000 P:=(P+SP[MOC]-1)|SP[LOC]; 03491100 M:=M+1 03491200 END; 03491300 P:=P+SP[MOC]; 03491400 LOCATE:=P+L; 03491450 END; 03491500 PROCEDURE DISPLAY(A,B); VALUE A,B; REAL A,B; 03500000 BEGIN 03500100 PROCEDURE PRINTMATRIX(L,ROW,COL);VALUE L,ROW,COL; 03500110 INTEGER L,ROW,COL; 03500120 BEGIN INTEGER I,J,CC,FOLD; DEFINE WIDE=GT2#; 03500130 WIDE:=LINESIZE; 03500132 FOR I:=1 STEP 1 UNTIL ROW DO 03500134 BEGIN CC:=0; %NO BLANKS AT BEGINNING OF LINE 03500138 FOLD:=0; 03500139 FOR J:=1 STEP 1 UNTIL COL DO 03500140 BEGIN NUMBERCON(SP[LOC],ACCUM); 03500142 IF FOLD:=FOLD+ACOUNT+CC GTR WIDE AND ACOUNT+CC 03500143 LEQ WIDE THEN BEGIN TERPRINT; 03500144 FORMROW(0,2,ACCUM,2,ACOUNT); FOLD:=ACOUNT+2; END ELSE 03500145 FORMROW(0,CC,ACCUM,2,ACOUNT); L:=L+1; 03500146 CC:=2; %PUT 2 BLANKS AFTER THE FIRST ITEM. 03500148 END; 03500150 TERPRINT; 03500154 END 03500158 END; 03500162 INTEGER L,N,M,BOTTOM,ALOC,BLOC; 03500200 INTEGER ROW,COL; 03500210 ALOC:=A.SPF; BLOC:= B.SPF-1; 03500300 L:=(M:=B.RF)+ BLOC; COL:=SP[LOC]; 03500310 L:=L-1; 03500320 ROW:=(IF M GTR 1 THEN SP[LOC] ELSE 1); 03500330 L:=BOTTOM:=M-2; 03500350 PRINTMATRIX(LOCATE(B,A),ROW,COL); 03500400 WHILE L GTR 0 DO 03500450 BEGIN 03500500 M:=ALOC+L; N:=BLOC+L; 03500550 IF SP[MOC]:=SP[MOC]+1 GTR SP[NOC] THEN 03500600 BEGIN SP[MOC]:=1; L:=L-1; END 03500650 ELSE BEGIN FORMWD(3,"1 "); 03500700 PRINTMATRIX(LOCATE(B,A),ROW,COL); 03500710 L:=BOTTOM; 03500750 END; 03500800 END; 03500850 FORMWD(3,"1 "); 03500855 END; 03500900 PROCEDURE MAKEFUNCTIONPRESENT(L); VALUE L ; REAL L; %LOC DESC 03501100 BEGIN 03501200 INTEGER I; 03501300 REAL M,N,SEQ,ORD,D; 03501400 BOOLEAN NUMERIC; 03501600 REAL STREAM PROCEDURE CON(A); VALUE A; 03501610 BEGIN SI:=LOC A; DI:=LOC CON; DS:=8OCT 03501620 END; 03501630 D:=SP[LOC]; %DESCRIPTOR FOR FUNCTION IS IN D 03501700 SEQ:=GETFIELD(D,FSQF-8,FFL); ORD:=GETFIELD(D,FPTF-8,FFL); 03501800 N:=GETSPACE((M:=SIZE(ORD))|2+6); %GET SPACE FOR TABLE 03501900 SP[NOC]:=M|2+5; %SIZE OF THE VECTOR WHICH FOLLOWS 03502000 D:=D&N[CSPF]&1[CRF]&0[BACKPT]; D.PRESENCE:=1; 03502100 SP[LOC]:=D; %THIS SETS UP THE FUNCTION DESCRIPTOR. 03502200 N:=N+1; SP[NOC]:=SEQ; 03502300 COMMENT 03502400 SP[N] = SIZE OF THE VECTOR 03502500 SP[N+1] = SEQUENTIAL STORAGE UNIT FOR THE TEXT 03502600 SP[N+2] = SP LOC OF FIRST NUMERIC POINTER TO TEXT 03502700 03502710 SP[N+3] = REL LOC (TO N+5) OF THE FIRST ARG 03502800 SP[N+4] = REL LOC OF THE SECOND ARG 03502900 SP[N+5] = REL LOC OF RESULT . IF ANY ARE ZERO, THEN 03503000 THEY ARE NOT THERE.; 03503100 D:=M; M:=(N:=N+4)+1; %D IS #ITEMS, M IS LOC 1ST, N=M-1 03503200 FOR I:=1 STEP 1 UNTIL D DO %GET LABELS FROM STORAGE 03503300 BEGIN L:=CONTENTS(ORD,I-1,GTA); 03503400 IF NOT NUMERIC THEN %RESULT, ARGS, OR LOCALS/LABELS 03503500 IF NUMERIC:=GTA[0]=0 THEN %FIRST NUMERIC POINTER 03503600 BEGIN L:=N-3; SP[LOC]:=N+I|2-1; 03503700 END; 03503800 SP[MOC]:=GTA[0]; M:=M+1; 03503900 IF NUMERIC THEN SP[MOC]:=GTA[1] ELSE 03504000 BEGIN 03504100 IF SEQ:=GTA[1] LSS 0 THEN %RESULT OR ARG 03504200 BEGIN L:=N+SEQ+1; SP[LOC]:=I; 03504300 SEQ:=0; 03504310 END ELSE SEQ:=CON(SEQ)/10000; 03504400 SP[MOC]:=SEQ 03504500 END; 03504600 M:=M+1 03504700 END; 03504800 COMMENT WE HAVE SET UP THE FUNCTION LABEL TABLE, LET 03504900 SOMEONE ELSE FIGURE OUT HOW TO EXECUTE IT; 03505000 END; 03505100 PROCEDURE PUSHINTOSYMTAB(FPTR);VALUE FPTR;REAL FPTR; 03506000 BEGIN COMMENT ...PUT THE LOCAL VARIABLES FROM THIS SUSPENDED 03506100 FUNCTION INTO THE SYMBOL TABLE TO BE TREATED AS GLOBAL VARIABLES 03506200 WHILE THE FUNCTION IS SUSPENDED. FPTR IS THE ENTRY FROM THE 03506300 STATE INDICATOR VECTOR FOR THE FUNCTION.; 03506400 03506500 REAL T,U; 03506600 LABEL COPY; 03506700 INTEGER K,L,M,N; 03506800 M:=FPTR.LOCFIELD+1;%LOCATE FMKS TO FIND LOCAL VALUES IN STACK 03506900 N:=FPTR.SPF+2;T:=SP[NOC]-2;%FIND LOCAL NAMES 03507000 FOR N:=N+4 STEP 2 UNTIL T DO %ONCE FOR EACH LOCAL 03507100 BEGIN GT1:=SP[NOC].[6:42];%PICK UP THE LOCAL NAME 03507200 L:=SYMBASE;K:=L+SP[LOC];% LOOK IN SYMBOL TABLE 03507300 FOR L:=L+1 STEP 2 UNTIL K DO % CHECK EACH NAME 03507400 IF GT1=SP[LOC].[6:42] THEN % WE FOUND A MATCH 03507500 BEGIN GT1:=M;K:=M:=GETSPACE(1);L:=L+1; 03507600 SP[MOC]:=SP[LOC]; %PUSH CURRENT DESCRIPTOR DOWN 03507700 M:=GT1; GO TO COPY; 03507800 END; 03507900 COMMENT GET HERE IF NO MATCH...MUST MAKE A NEW ENTRY IN 03508000 SYMBOL TABLE; 03508100 IF K LSS MAXSYMBOL|2 THEN % THERE IS ROOM IN SYMBOL TABLE 03508200 BEGIN L:=SYMBASE;SP[LOC]:=SP[LOC]+2; L:=K+1; 03508300 SP[LOC]:=GT1&OPERAND[CTYPEF]&1[CSUSVAR];L:=L+1;K:=0; 03508400 COPY: COMMENT L IS LOC IN SYMBOL TABLE FOR DESC. K WILL BE 03508500 CONTENTS OF BACKF. NOW SET UP THE NEW DESCRIPTOR AND 03508600 SAVE ITS LOCATION IN THE STACK. M IS THE STACK LOCATION 03508700 OF THE LOCAL; 03508800 03508900 SP[LOC]:=SP[MOC]&K[CLOCF]&1[CNAMED]; 03509000 SP[MOC]:=L&DDNUVW[CDID];M:=M+1; 03509100 END ELSE % THERE IS NO ROOM IN THE SYMBOL TABLE 03509200 BEGIN N:=T;ERR:=SPERROR;END; 03509300 END;% OF FOR LOOP STEPPING THRU THE LOCALS 03509400 END; % OF PUSHINTOSYMTAB PROCEDURE 03509500 PROCEDURE FORGETPROGRAM(U);VALUE U; REAL U; 03510000 BEGIN REAL L,M; 03510100 COMMENT U IS A PROGRAMMKS...THE SP STORAGE FOR THIS LINE 03510150 SHOULD BE RELEASED; 03510151 M:=U.SPF;SCRATCHAIN(SP[MOC].LOCFIELD);%CONSTANT CHAIN 03510200 L:=SP[MOC].SPF;FORGETSPACE(M,1);%FORGET PROGRAM DESC. 03510300 M:=L+1;SCRATCHDATA(SP[MOC]);%FORGET BUFFER 03510400 FORGETSPACE(L,SP[LOC]+1);%FORGET THE POLISH 03510500 END; 03510600 EXPOVR:=EXPOVRL; 03609000 INTOVR:=INTOVRL; 03609100 INDEX:=INDEXL; 03609200 FLAG:=FLAGL; 03609300 ZERO:=ZEROL; 03609400 CASE MODE OF 03700000 BEGIN ;%-------------------------------------------------------- 03700100 %---------------- CASE 1....MODE=XEQUTE------------------------ 03700200 CASE CURRENTMODE OF 03700300 BEGIN%----------------------------------------------------- 03700400 %------------ SUB-CASE 0....CURRENTMODE=CALCMODE----------- 03700500 IF T:=ANALYZE(TRUE) NEQ 0 THEN % WE HAVE A PROGRAM DESC 03700600 BEGIN COMMENT SET-UP THE STACK; 03700700 IF STACKBASE=0 THEN BEGIN 03700710 STACKBASE:=L:=GETSPACE(STACKSIZE+1); 03700800 IF ERR NEQ 0 THEN BEGIN STACKBASE:=0; 03700810 ERRORMESS(ERR,0,0); GO TO PROCESSEXIT;END; 03700820 SP[LOC]:=2; 03700900 L:=L+1; 03700910 M:=GETSPACE(STATEVECTORSIZE+1); 03700912 SP[LOC]:=M&1[CRF]&DDPNVW[CDID]; 03700920 SP[MOC]:=STATEVECTORSIZE; 03700930 M:=M+1; SP[MOC]:=0; % THE STATE VECTOR IS INITIALIZED NOW 03700940 FUNCLOC:=M; 03700950 N:=0; 03700960 L:=L+1; COMMENT READY FOR A PROG MKS; 03701000 END ELSE % THERE IS ALREADY A STACK...USE IT 03701010 BEGIN L:=STACKBASE; 03701012 ST:=SP[LOC]+L; 03701020 WHILE M:=AREG.DID NEQ IMKS AND M NEQ PROGMKS AND 03701022 ERR=0 DO POP;%STRIP BACK TO LASTMARKSTACK 03701024 IF M=IMKS THEN BEGIN N:=ST-STACKBASE;PUSH; 03701026 END ELSE N:=AREG.BACKF; 03701028 SP[LOC]:=ST-STACKBASE;L:=ST; 03701030 END; 03701040 CURLINE:=0; 03701050 M:=GETSPACE(1); SP[MOC]:=T; %STORE PROG DESCRIPTOR 03701060 SP[LOC]:=M&PROGMKS[CDID]&N[BACKPT]&1[CI]; 03701100 COMMENT JUST BUILT A PROGRAM MARKSTACK; 03701200 GO TO EXECUTION; 03701300 END; 03701400 %------------SUB-CASE 1....CURRENTMODE=XEQMODE--------------- 03701500 COMMENT RECOVERY FROM A TIME-OUT; 03701600 GO TO EXECUTION; 03701700 %----------- SUB-CASE 2....CURRENTMODE=FUNCMODE-------------- 03701800 COMMENT SYNTAX CHECK ONLY; 03701900 IF ANALYZE(TRUE)=0 THEN; 03702000 %----------- END OF SUB CASES------------------------------- 03702100 END; 03702200 %----------------- CASE 2.....MODE=ALLOC-------------------------- 03702300 COMMENT NOTHING TO DO; 03702400 ; 03702500 %---------------- CASE 3.... MODE=WRITEBACK--------------------- 03702600 COMMENT HAVE TO WRITE BACK ALL THE CHANGED VARIABLES; 03702700 IF SYMBASE NEQ 0 THEN 03702800 WRITEBACK; 03702900 03709000 %---------------- CASE 4.... MODE=DEALLOC----------------------- 03709100 ; 03709200 03709300 03709400 %---------------- CASE 5 .... MODE=INTERROGATE------------------ 03709500 COMMENT PRINT OUT THE PROGRAM STATUS VECTOR HERE; 03709600 IF L:=STACKBASE+1 NEQ 1 THEN 03709700 BEGIN COMMENT GT1=1 FOR SIV...=0 FOR SI; 03709710 U:=GT1; 03709715 L:=SP[LOC].SPF+1;M:=SP[LOC].SPF+L; 03709720 WHILE M GTR L DO 03709730 BEGIN N:=SP[MOC].LOCFIELD;N:=SP[NOC].SPF-1; 03709740 % N IS LOCATION OF THE FUNCTION NAME 03709742 ACCUM[0]:=SP[NOC]; 03709750 FORMROW(2,6,ACCUM,1,7); 03709760 IF BOOLEAN(SP[MOC].SUSPENDED) THEN FORMWD(0,"3 S ") 03709770 ELSE FORMWD(0,"3 "); 03709772 IF BOOLEAN(U) THEN % PRINT LOCAL VARIABLE NAMES 03709780 BEGIN 03709790 N:=SP[MOC].SPF+2;T:=SP[NOC]-2; 03709800 FOR N:=N+4 STEP 2 UNTIL T DO 03709810 BEGIN ACCUM[0]:=SP[NOC]; 03709820 FORMROW(0,1,ACCUM,1,7); 03709830 END; 03709840 END; 03709850 TERPRINT; M:=M-1; 03709860 END; 03709870 END; 03709880 END;% OF THE CASE STATEMENT 03711000 %--------------END OF CASES--------------------------------------- 03711100 IF FALSE THEN EXECUTION: 03750000 BEGIN COMMENT EXECUTION LOOP; 03750100 INTEGER LOOP; 03750200 INTEGER INPUTIMS; 03750202 LABEL BREAKKEY; 03750204 LABEL SKIPPOP,XEQEPS; 03750210 BOOLEAN XIT, JUMP; 03750300 REAL POLWORD; 03750400 DEFINE RESULT=RESULTD#; 03750410 LABEL EXECEXIT, EVALQ, EVALQQ; 03750500 %%% 03751000 COMMENT THERE IS A PROGRAM DESCRIPTOR AT THE TOP OF STACK; 03751100 ERR:=0; 03751200 L:=STACKBASE; ST:=L+SP[LOC]; 03751300 L:=L+1;FUNCLOC:=SP[LOC].SPF+1; 03751310 T:=AREG; 03751350 IF CURRENTMODE=XEQMODE THEN %AREG IS INTERRUPT MARK STACK 03751400 BEGIN LASTMKS:=STACKBASE+T.BACKF; 03751500 OLDDATA:=T.SPF; INPUTIMS:=T.QUADIN; POP; 03751600 COMMENT MAY BE CURRENTLY EXECUTING A FUNCTION; 03751610 L:=STACKBASE+1; L:=SP[LOC].SPF+1; 03751620 IF (M:=SP[LOC].SPF) NEQ 0 THEN 03751630 BEGIN M:=M+L; L:=SP[MOC].LOCFIELD; 03751640 CURLINE:=SP[LOC].CIF; 03751650 03751660 END; 03751670 END 03751680 ELSE LASTMKS:=ST;%AREG IS PROGRAM MARK STACK 03751700 CURRENTMODE:=XEQMODE; 03751750 L:=LASTMKS; T:=SP[LOC]; % T IS PROGRAM MARK STACK 03751800 CINDEX:=T.CIF; % CONTROL INDEX IN POLISH 03751900 IF L:=T.SPF =0 THEN %PHONEY PROG DESC FROM FUNCTION CALL 03752000 N:=POLTOP:=POLLOC:=0 ELSE 03752010 BEGIN 03752020 N:=POLLOC:=SP[LOC].SPF; 03752030 POLTOP:=SP[NOC] 03752040 END; 03752050 IF ERR = 0 THEN % POP WORKED 03752100 IF INPUTIMS=2 THEN BEGIN JUMP:=TRUE; GO TO EVALQ END ELSE 03752110 IF INPUTIMS=1 THEN BEGIN JUMP:=TRUE; GO TO EVALQQ; END ELSE 03752120 DO BEGIN COMMENT EXECUTE UNTIL DONE OR TIME-OUT; 03752200 IF CINDEX LSS POLTOP THEN %MORE TO EXECUTE IN POLISH 03752300 BEGIN COMMENT GET NEXT POLISH TO EXECUTE; 03752400 M:=(CINDEX:=CINDEX+1)+POLLOC; 03752500 POLWORD:=T:=SP[MOC]; 03752600 CASE T.TYPEFIELD OF 03752700 BEGIN %-------TF=0 (REPLACEMENT)-------------- 03752800 BEGIN %MAY BE A LOCAL OR A GLOBAL VARIABLE 03752900 DEFINE STARTSEGMENT=#; %///////////////////// 03752905 PUSH; IF ERR NEQ 0 THEN GO TO SKIPPOP; 03752910 N:=T.LOCFIELD; 03752912 IF BOOLEAN(T.OPTYPE) THEN %A LOCAL VARIABLE 03752915 BEGIN M:=FUNCLOC;%FIND LAST FMKS 03752916 M:=SP[MOC].SPF+M; 03752917 N:=SP[MOC].LOCFIELD+N; END; 03752918 U:=SP[NOC]; U.LOCFIELD:=N; AREG:=U; 03752920 IF U.DATADESC=0 THEN ERR:=NONCEERROR; 03752922 COMMENT PROBABLY MIXUP WITH FUNCTION NAMES 03752924 AND NAMES OF LOCAL SUSPENDED VARIABLES; 03752926 END; 03752930 %-------------FUNCTION CALL---------------- 03752950 %&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 03752960 BEGIN COMMENT SET UP STACK FOR A FUNCTION CALL; 03752970 REAL U,V,NARGS,D; 03752980 INTEGER I,FLOC; 03752982 LABEL TERMINATE; 03752990 COMMENT 03752991 MONITOR PRINT(D,L,M,N,FLOC,SP,LASTMKS);%::::::::::::::::::: 03752992 FLOC:=N:=T.LOCFIELD; 03753000 IF BOOLEAN(SP[NOC].DATADESC) THEN BEGIN ERR:=NONCEERROR; 03753005 GO TO TERMINATE;END;%SUSPENDED VAR CONFUSED WITH FUNCTION 03753007 IF NOT BOOLEAN(SP[NOC].PRESENCE) THEN MAKEFUNCTIONPRESENT(N); 03753010 D:=SP[NOC]; L:=LASTMKS; %D IS THE DESC, L IS THE PROG MKS 03753020 SP[LOC].CIF:=CINDEX; %SAVE CURRENT POLISH LOCATION 03753022 L:=STACKBASE+1; L:=SP[LOC].SPF+1; 03753030 M:=SP[LOC].SPF; 03753035 IF N:=M+L NEQ L THEN %THERE IS A NESTED CALL 03753040 IF NOT BOOLEAN(SP[NOC].SUSPENDED) THEN 03753045 BEGIN N:=SP[NOC].LOCFIELD;SP[NOC].CIF:=CURLINE;END; 03753050 03753060 03753070 SETFIELD(GTA,0,8,0); SETFIELD(GTA,8,8,0); %INITIALIZE GTA 03753080 NARGS:=D.NUMBERARGS; 03753090 FOR I:=1 STEP 1 UNTIL NARGS DO 03753100 IF BOOLEAN((T:=AREG).DATADESC) THEN 03753110 BEGIN 03753120 IF BOOLEAN(T.NAMED) THEN %MAKE A COPY 03753130 COMMENT YOU COULD MAKE A CALL BY NAME HERE; 03753140 BEGIN U:=GETSPACE(V:=(NUMELEMENTS(T)+T.RF)); 03753150 SPCOPY(T.SPF,U,V); T.NAMED:=0; T.SPF:=U; 03753160 T.BACKP:=0; 03753165 END ELSE %NO NEED TO MAKE A COPY 03753170 AREG.PRESENCE:=0; 03753180 POP; GTA[I-1]:=T; %SAVE THE DESCRIPTOR FOR LATER USE 03753190 END ELSE ERR:=SYSTEMERROR; 03753200 IF (N:=M+1) GEQ STATEVECTORSIZE THEN ERR:=DEPTHERROR; 03753205 IF ERR NEQ 0 THEN GO TO TERMINATE; 03753210 SP[LOC].SPF:=N; 03753211 PUSH;AREG:=OLDDATA&(LASTMKS-STACKBASE)[BACKPT]&IMKS[CDID]; 03753212 OLDDATA:=0; %REINITIALIZE OLDDATA CHAIN FOR THIS FUNCTION 03753214 %NOW SET UP THE FUNCTION MARK STACK. 03753220 03753221 M:=N+L;PUSH;SP[MOC]:=D.SPF&ST[CLOCF]; 03753222 M:=D.SPF; M:=M+2; % M IS LOC OF LOC OF FIRST LINE 03753230 AREG:=0&FLOC[CSPF]&((LASTMKS:=ST)-STACKBASE-1)[BACKPT]& 03753240 (U:=SP[MOC]-D.SPF)[CCIF]&FMKS[CDID]; % FUNCTION MKS 03753242 CURLINE:=U; 03753244 03753250 U:=(U-6)/2; % U IS THE NUMBER OF LOCALS, LABELS, AND ARGS 03753260 M:=M+5; % M IS ON THE FIRST DESC OF THE FIRST LAB, LOC,... 03753270 FOR I:=1 STEP 1 UNTIL U DO % GET DESCRIPTORS INTO THE STACK 03753280 BEGIN IF SP[MOC] NEQ 0 THEN %MAKE UP THE DESC 03753290 BEGIN L:=GETSPACE(1); SP[LOC]:=SP[MOC]; 03753300 T:=L&DDPUSW[CDID]&0[CCIF] 03753310 END ELSE 03753320 T:=NULLV; 03753330 PUSH; M:=M+2; 03753340 AREG:=T; %A SINGLE LOCAL 03753350 END; 03753360 %COPY OVER THE ARGUMENTS 03753370 FOR I:=1 STEP 1 UNTIL NARGS DO %COPY OVER 03753390 BEGIN M:=D.SPF; %M IS THE LOCATION OF THE LABEL TABLE. 03753400 M:=M+2+I; %M IS LOCATION OF REL LOCATION OF VARIABLE 03753410 M:=SP[MOC]; 03753420 N:=LASTMKS+M; 03753430 SP[NOC]:=GTA[I-1] 03753440 END; 03753450 %PUT IN A PHONEY PROG DESC TO START THINGS OFF 03753460 PUSH; IF ERR NEQ 0 THEN GO TO TERMINATE; 03753470 AREG:=0&4094[CCIF]&(LASTMKS-STACKBASE)[BACKPT]; 03753480 LASTMKS:=ST; POLTOP:=POLLOC:=0; 03753490 TERMINATE: 03753500 END; 03753510 %&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 03753520 %-------END OF LOAD FUNCTION FOR CALL----- 03753900 %-------------TF=2 (CONSTANT)--------------------- 03754000 BEGIN PUSH; IF ERR=0 THEN BEGIN 03754100 N:=POLWORD.LOCFIELD;AREG:=SP[NOC];END; 03754110 END; 03754120 %-------------TF=3 (OPERATOR)----------------- 03755000 COMMENT SEQUENCE NUMBERS CORRESPOND TO OPERATOR 03755100 ASSIGNMENT NUMBER; 03755200 BEGIN IF T.OPTYPE=MONADIC THEN 03755210 BEGIN PUSH;IF ERR=0 THEN AREG:=0; END; 03755220 CASE T.LOCFIELD OF 03755300 BEGIN %--------------- OPERATE ON STACK---------------------- 03755400 COMMENT EACH EXECUTION PROCEDURE SETS RESULT TO THE 03755500 DESCRIPTOR OF THE RESULT OF THE OPERATION. 03755510 AREG AND BREG ARE THE LEFT AND RIGHT-HAND OPERANDS AND 03755520 ARE ACTUALLY THE TOP TWO DESCRIPTORS ON THE STACK. 03755530 IF AREG IS ZERO, THE OPERATOR IS TAKEN TO BE MONADIC.; 03755540 ; 03800000 ; 03801000 ; 03802000 ; 03803000 %-------------------- REPLACEMENT OPERATOR--------------- 03804000 BEGIN DEFINE STARTSEGMENT=#; %/////////////////////////////// 03804100 IF NOT BOOLEAN(L:=AREG.NAMED) THEN % SHOULD BE LOCAL VARIABLE 03804110 AREG.NAMED:=1; % DONT LET IT BE FORGOTTEN. 03804120 03804130 IF BOOLEAN((T:=AREG).PRESENCE) AND T.SPF NEQ 0 THEN 03804200 OLDDATA:=CHAIN(T,OLDDATA); 03804210 M:=T.LOCFIELD; 03804300 03804310 IF(RESULT:=BREG).SPF = 0 THEN U:=T:=0 ELSE 03804320 U:=GETSPACE(T:=NUMELEMENTS(RESULT)+RESULT.RF); 03804400 SPCOPY(RESULT.SPF,U,T); 03804500 RESULT.SPF:=U; RESULT.NAMED:=L; %L IS 0 FOR LOCALS 03804510 GT1:=IF BOOLEAN((U:=SP[MOC]).PRESENCE) THEN U.BACKP ELSE 0; 03804515 SP[MOC]:=RESULT>1[CLOCF]; 03804520 IF BOOLEAN(L) AND GT1=0 THEN %CHECK FOR GLOBAL 03804600 BEGIN M:=M-1;IF(SP[MOC].SUSPENDVAR=0)THEN SP[MOC].CHANGE:=1; 03804610 03804620 END; 03804630 RESULT.NAMED:=1; %KEEP "PUSH" FROM TOSSING THE DATA 03804640 END; 03804700 %-------TRANSFER OPERATOR----------------------------- 03805000 BEGIN DEFINE STARTSEGMENT=#; %/////////////////////////////// 03805100 SCRATCHAIN(OLDDATA);OLDDATA:=0; 03805110 IF BOOLEAN(T.OPTYPE) THEN ST:=ST-1; %GET RID OF PHONEY TOP 03805200 L:=FUNCLOC; 03805210 IF SP[LOC] NEQ 0 THEN STEPLINE(TRUE) ELSE 03805300 ERR:=SYNTAXERROR; 03805400 GO TO SKIPPOP; 03805500 END; 03805600 BEGIN %--------------COMPRESSION------------------------------------03806000 DEFINE STARTSEGMENT=#; %///////////////////////////////////// 03806005 L:=ST-2; IF T.OPTYPE=MONADIC THEN COMPRESS(BREG,SP[LOC],AREG) 03806010 ELSE COMPRESS(AREG,SP[LOC],BREG); COMMENT A/B HAS BEEN 03806020 STACKED AS B,A,NULL...A/[I] B HAS BEEN STACKED AS B,I,A; 03806030 END; 03806040 ARITH(3); %OPERATION IS DIVIDE 03807000 ; 03807999 ; 03809000 %-------------QUAD INPUT------------------------------- 03810000 EVALQ: BEGIN LABEL EVALQUAD; 03810010 IF JUMP THEN BEGIN JUMP:=FALSE; GO TO EVALQUAD END; 03810015 CURRENTMODE:=INPUTMODE; 03810018 FORMWD(3,"3[]: "); INDENT(0); 03810020 03810030 IMS(2); % SETUP MARKSTACK FOR QUAD EXIT 03810040 IF ERR NEQ 0 THEN GO TO SKIPPOP; 03810050 GO TO EXECEXIT; % EXIT TO MONITOR TILL INPUT IS COMPLETE 03810080 EVALQUAD: %LOOK AT BUFFER TO SEE WHAT CAME IN 03810100 BEGIN 03810110 IF NOT SCAN THEN BEGIN CINDEX:=CINDEX-1;GO TO SKIPPOP;END; 03810112 IF NOT SETUPLINE THEN CINDEX:=CINDEX-1;%MAKE THEM REDO IT 03810120 GO TO SKIPPOP; 03810200 END; 03810210 END; 03810500 BEGIN % -----EVALUATE SUBSCRIPTS--------------- 03811000 DEFINE STARTSEGMENT=#; %///////////////////////////////////// 03811002 T:=AREG; L:=BREG.SPF; 03811010 IF BOOLEAN(T.SCALAR) THEN BEGIN ERR:=DOMAINERROR;GO TO SKIPPOP;END; 03811011 U:=SP[LOC]; % GET # OF SUBSCRIPTS 03811012 IF U GTR 32 THEN ERR:=INDEXERROR ELSE 03811014 BEGIN 03811015 IF U GTR 0 THEN BEGIN 03811017 IF T.PRESENCE NEQ 1 THEN % GET ARRAY INTO SP 03811020 BEGIN N:=T.LOCFIELD; 03811030 IF (T:=SP[NOC]).PRESENCE NEQ 1 THEN 03811040 BEGIN T:=GETARRAY(T); SP[NOC]:=T END; 03811050 T.LOCFIELD:= N; 03811052 END; 03811060 IF ERR=0 THEN % NOW EVALUATE 03811070 03811080 RESULT:=SUBSCRIPTS(L:=(IF T.LOCFIELD=0 THEN OUTOF 03811090 ELSE INTO),T,U); 03811100 IF L=INTO THEN BEGIN 03811101 03811102 CINDEX:=CINDEX+1;END; % SKIP OVER REPLACE OP 03811103 END ELSE % NO SUBSCRIPTS 03811104 BEGIN BREG:=T; ST:= ST-1; GO TO SKIPPOP; 03811106 END; % DON{T LET THE DESC. IN T BE POPPED. 03811108 U:=U+2; % # OF THINGS TO POP 03811110 FOR N:=1 STEP 1 UNTIL U DO POP; 03811114 IF L=OUTOF THEN PUSH; AREG:=RESULT; 03811116 03811120 GO TO SKIPPOP; 03811130 END; 03811140 END; 03811200 ; 03812000 ; 03813000 %-------------QQUAD INPUT------------------------------ 03814000 EVALQQ: BEGIN LABEL EVALQQUAD; 03814010 IF JUMP THEN BEGIN JUMP:=FALSE; GO TO EVALQQUAD END; 03814015 CURRENTMODE:=INPUTMODE; 03814020 IMS(1); % SETUP MARKSTACKS FOR QQUAD EXIT 03814030 IF ERR NEQ 0 THEN GO TO SKIPPOP; 03814040 GO TO EXECEXIT; 03814080 EVALQQUAD: % BUFFER CONTAINS THE INPUT STRING 03814100 IF (L:=LENGTH(BUFFER,TRUE))NEQ 0 THEN BEGIN %L IS # CHAR INPUT 03814110 N:=ENTIER((L+7) DIV 8); % FIND NUMBER OF WORDS 03814120 M:=GETSPACE(N+1); % GET SPACE FOR THE VECTOR IN SP 03814130 TRANSFERSP(INTO,SP,M+1,BUFFER,0,N); 03814140 SP[MOC]:=L; % STORE LENGTH OF VECTOR 03814150 RESULT:=M&1[CRF]&DDPUVC[CDID]; % SET UP DESCRIPTOR 03814160 END ELSE RESULT:=NULLV;% NOTHING WAS INPUT 03814162 PUSH; IF ERR=0 THEN AREG:=RESULT; 03814170 GO TO SKIPPOP; 03814180 END; 03814500 RESULTD := SEMICOL; %CONVERSION CONCATENATION 03815000 COMMAP; %CATENATE 03816000 BEGIN%----------INNER PRODUCT (PERIOD)--------------------- 03817000 M:=(CINDEX:=CINDEX+2) + POLLOC; T:=SP[MOC];M:=M-1;U:=SP[MOC]; 03817100 PERIOD(AREG,BREG,U.LOCFIELD,T.LOCFIELD); 03817200 END; 03817300 ARITH(4); %* 03818000 ; 03819000 ; 03820000 ARITH(17); %AND 03821000 ARITH(18); %OR 03822000 ARITH(9); %NOT 03823000 ARITH(11); %LESS:THAN 03824000 ARITH(16); %LEQ 03825000 ARITH(12); %= 03826000 ARITH(13); %GEQ 03827000 ARITH(14); %GREATER-THAN 03828000 ARITH(15); %NEQ 03829000 ARITH(8); %MAX/CEIL 03830000 ARITH(7); %MIN/FLOOR 03831000 ARITH(6); %RESD/ABS 03832000 IF T.OPTYPE=MONADIC THEN GO TO XEQEPS ELSE MEMBER; %MEMBERSHIP 03833000 RHOP; %RHO 03834000 IOTAP; %IOTA 03835000 ; 03836000 REDUCESORTSCAN(0,BREG,AREG,4); %REVERSAL; 03837000 BEGIN %-----------EXPANSION-------------------------- 03838000 DEFINE STARTSEGMENT=#; %//////////////////////////////////// 03838005 L:=ST-2; IF T.OPTYPE=MONADIC THEN EXPAND(BREG,SP[LOC],AREG) 03838010 ELSE EXPAND(AREG,SP[LOC],BREG); COMMENT A EXPN B HAS BEEN 03838020 STACKED AS B,A,NULL WHILE A EXPN [I] B IS STACKED AS B,I,A; 03838030 END; 03838040 RESULTD:=BASEVALUE; %BASE VALUE 03839000 ARITH(10); %COMB/FACT 03840000 ; 03841000 IF T.OPTYPE=MONADIC THEN ARITH(5) ELSE 03842000 DYADICRNDM; %RNDM 03842100 IF T.OPTYPE=MONADIC THEN TRANSPOSE ELSE DYADICTRANS;%GUESS WHAT 03843000 RESULTD := REPRESENT; %REPRESENTATION 03844000 ARITH(45); %CIRCLE--TRIGONOMETRIC FUNCTIONS 03845000 ; 03846000 ; 03847000 ARITH(0); %ADD 03848000 ARITH(2); %SUBTRACT 03849000 ARITH(1); %MULTIPLY 03850000 %-------------------DISPLAY------------------------------------- 03851000 03851100 BEGIN DEFINE STARTSEGMENT=#; %/////////////////////////////// 03851110 IF BREG.SPF=0 THEN FORMROW(3,0,ACCUM,2,0) ELSE %FOR A NULL 03851115 IF BOOLEAN((RESULT:=BREG).DATADESC)THEN %THIS IS A DATA DESC 03851120 IF BOOLEAN(RESULT.PRESENCE) AND M:=RESULT.SPF NEQ 0 THEN 03851140 IF BOOLEAN(RESULT.SCALAR) THEN 03851160 BEGIN NUMBERCON(SP[MOC],ACCUM); 03851180 FORMROW(3,0,ACCUM,2,ACOUNT) 03851200 END 03851220 ELSE %A VECTOR 03851240 IF L:=RESULT.RF NEQ 0 THEN % SOMETHING TO PRINT 03851260 IF BOOLEAN(RESULT.CHRMODE) THEN DISPLAYCHARV(RESULT) 03851300 ELSE 03851310 BEGIN RESULT:=M:=GETSPACE(L+1); 03851400 SP[MOC]:=L; RESULT.RF:=1; RESULT.DID:=DDPUVW; 03851500 AREG:=RESULT; 03851600 FOR T:=1 STEP 1 UNTIL L DO 03851610 BEGIN M:=M+1; SP[MOC]:=1 03851620 END; 03851630 DISPLAY(AREG,BREG); 03851700 RESULT:=BREG; 03851720 END ELSE TERPRINT 03851760 ELSE TERPRINT 03851780 ELSE ; %PROBABLY A FUNCTION....DONT DO ANYTHING 03851880 IF BREAKFLAG THEN %USER HIT BREAK DURING OUTPUT 03851890 GO TO BREAKKEY; 03851892 POP; GO TO SKIPPOP; 03851894 END; 03851896 BEGIN % ---------------REDUCTION------------------------------------03852000 M:=(CINDEX:= CINDEX+1) + POLLOC; % FIND OPERATION IN POLISH 03852020 IF (T:=SP[MOC]).TYPEFIELD NEQ 3 THEN ERR:=SYSTEMERROR 03852040 ELSE REDUCESORTSCAN(T.LOCFIELD,BREG,AREG,1); 03852060 END; 03852080 BEGIN %--------ROTATION---------------------------- 03853000 DEFINE STARTSEGMENT=#; %//////////////////////////////////// 03853005 L:=ST-2; IF T.OPTYPE=MONADIC THEN 03853010 REDUCESORTSCAN(BREG,SP[LOC],AREG,5) ELSE 03853015 REDUCESORTSCAN(AREG,SP[LOC],BREG,5); COMMENT A ROT B IS 03853020 STACKED AS B,A,NULL WHILE A ROT [I] B IS STACKED AS B,I,A; 03853030 END; 03853040 ARITH(21); %LOG 03854000 REDUCESORTSCAN(0,BREG,AREG,2); % SORTUP 03855000 REDUCESORTSCAN(-1,BREG,AREG,2); %SORTDN 03856000 BEGIN %-------------SCAN-------LIKE REDUCTION--------------- 03857000 DEFINE STARTSEGMENT=#; %///////////////////////////////////// 03857010 M:=(CINDEX:=CINDEX+1) + POLLOC; %FIND OPERATOR IN POLISH 03857020 IF (T:=SP[MOC]).TYPEFIELD NEQ 3 THEN ERR:=SYSTEMERROR 03857040 ELSE REDUCESORTSCAN(T.LOCFIELD,BREG,AREG,3); 03857060 END; 03857080 ARITH(19); %NAND 03858000 ARITH(20); %NOR 03859000 IF (T:=BREG).RF NEQ 0 THEN RESULT:=SUBSCRIPTS(2,T,T.RF) 03860000 ELSE ERR:=RANKERROR; % OPERATION IS TAKE 03860010 IF (T:=BREG).RF NEQ 0 THEN RESULT:=SUBSCRIPTS(3,T,T.RF) 03861000 ELSE ERR:=RANKERROR; % OPERATION IS DROP 03861010 %-----------------------XEQ----------------------------------- 03862000 XEQEPS: BEGIN DEFINE STARTSEGMENT=#; %///////////////// 03862005 IF AREG NEQ 0 THEN ERR:=SYNTAXERROR %MUST BE MONADIC ONLY 03862010 ELSE IF (T:=BREG).RF NEQ 1 OR %MUST BE A VECTOR 03862020 NOT BOOLEAN(T.CHRMODE) THEN ERR:=DOMAINERROR %MUST BE CHAR STRING 03862030 ELSE IF U:=NUMELEMENTS(T) GTR MAXBUFFSIZE THEN ERR:=LENGTHERROR 03862032 ELSE BEGIN 03862040 M:=GT1; % # OF CHARACTERS SET BY NUMELEMENTS 03862042 INITBUFF(BUFFER,MAXBUFFSIZE);RESCANLINE; 03862048 TRANSFERSP(OUTOF,SP,T.SPF+1,BUFFER,0,U); 03862050 IF(U:=U|8-M) GTR 0 THEN SETFIELD(BUFFER,M,U," "); 03862052 IF T.SPF=0 OR NOT SCAN THEN RESULT:=0&1[CRF]&DDPUVW[CDID]% NULL 03862060 ELSE BEGIN POP;IF SETUPLINE THEN; GO TO SKIPPOP;END 03862070 END; END; 03862080 END; %--------------END OF OPERATION ON STACK-------------------- 03869960 POP;POP;PUSH;IF ERR=0 THEN AREG:=RESULT; 03869970 SKIPPOP: END OF TYPEFIELD EQUALS OPERATOR; 03869980 %-------TF=4 (LOCAL VARIABLE)------------ 03870000 BEGIN COMMENT MOVE DESCRIPTOR UP TO TOP; 03870100 DEFINE STARTSEGMENT=#; %///////////////// 03870110 N:=T.LOCFIELD;M:=FUNCLOC;M:=SP[MOC]+M; 03870200 03870210 N:=SP[MOC].LOCFIELD+N; 03870220 T:=SP[NOC]; T.NAMED:=1; %KEEP FROM THROWING AWAY 03870300 PUSH; AREG:=T; 03870400 END; 03870500 %-------TF=5 (OPERAND)----------------------- 03872000 BEGIN PUSH; IF ERR=0 THEN BEGIN 03872100 N:=POLWORD.LOCFIELD; U:=SP[NOC]; 03872200 IF U.DATADESC=0 THEN ERR:=NONCEERROR ELSE 03872210 IF U.PRESENCE NEQ 1 THEN BEGIN 03872300 U:=GETARRAY(U); SP[NOC]:=U END; 03872400 U.LOCFIELD:=0; 03872410 AREG:=U; END; 03872500 END; 03872600 END; % OF CASE STMT TESTING TYPEFIELD 03900000 END % OF TEST FOR CINDEX LEQ POLTOP 03901000 ELSE % WE ARE AT THE END OF THE POLISH 03902000 BEGIN COMMENT LASTMKS CONTAINS THE LOCATION 03903000 OF THE LAST MARK STACK. GET MARK STACK AND CONTINUE; 03904000 03905000 SCRATCHAIN(OLDDATA); OLDDATA:=0; 03905010 L:=LASTMKS;M:=(U:=SP[LOC]).BACKF+STACKBASE;T:=SP[MOC]; 03905020 IF T.DID=IMKS AND T.QUADIN=3 THEN %SINGLE LINE DONE 03905030 IF(RESULT:=AREG)=T THEN ERR:=SYNTAXERROR%NO RESULT 03905035 ELSE BEGIN RESULT.NAMED:=0;%MAKE NEW COPY 03905040 IF BOOLEAN(RESULT.SCALAR) THEN 03905042 BEGIN M:=GETSPACE(2);L:=RESULT.SPF; 03905044 RESULT.SPF:=M+1;SP[MOC]:=RESULT; 03905046 M:=M+1;SP[MOC]:=SP[LOC]; 03905048 END ELSE % MAKE COPY OF A VECTOR 03905050 BEGIN M:=GETSPACE(1+(N:=RESULT.RF+NUMELEMENTS( 03905052 RESULT))); 03905053 L:=RESULT.SPF;RESULT.SPF:=M+1; 03905054 SP[MOC]:=RESULT; SPCOPY(L,M+1,N);END; 03905056 03905058 03905060 FORGETPROGRAM(U); 03905070 03905080 DO POP UNTIL ST LSS LASTMKS;%CUT BACK STACK TO IMS 03905082 OLDDATA:=T.SPF;L:=LASTMKS:=T.BACKF+STACKBASE; 03905084 AREG:=RESULT; % STORE EXECUTION RESULT OVER IMS 03905086 CINDEX:=SP[LOC].CIF; M:= SP[LOC].SPF; 03905088 POLLOC:=M:=SP[MOC].SPF; POLTOP:=SP[MOC]; 03905090 END ELSE 03905095 BEGIN L:=FUNCLOC;M:=SP[LOC].SPF+L; 03905100 IF M NEQ L AND NOT BOOLEAN(SP[MOC].SUSPENDED)THEN 03905200 BEGIN 03905203 IF 0=(LOOP:=(LOOP+1) MOD 5) THEN 03905205 WRITE(TWXOUT[STOP],1,JIGGLE[*])[BREAKKEY:BREAKKEY]; 03905206 %THAT WAS TO CHECK FOR BREAK TO INTERRUPT A PROG 03905207 STEPLINE(FALSE) 03905210 END 03905215 ELSE BEGIN XIT:=TRUE;CURRENTMODE:=CALCMODE; 03905300 WHILE POPPROGRAM(OLDDATA,LASTMKS) DO; 03905310 END; 03905400 END; 03905600 END; %COMPLETION OF ONE POLISH EVALUATION (1 CELL) 03910000 IF ERR NEQ 0 THEN % PUT OUT ERROR MESSAGE 03918100 BEGIN 03918200 DEFINE STARTSEGMENT=#; %///////////////////////////// 03918201 COMMENT 03918209 MONITOR PRINT(ST,L,M,SP,GTA,T);%:::::::::::::::::::::: 03918210 XIT:=TRUE;CURRENTMODE:=ERRORMODE; 03918220 03918250 L:=POLLOC+1; 03918300 TRANSFERSP(OUTOF,SP,(L:=SP[LOC].SPF)+1,BUFFER, 03918400 0,MIN(MAXBUFFSIZE,ENTIER((SP[LOC]+7)DIV 8))); 03918450 L:=FUNCLOC;M:=SP[LOC].SPF+L; 03918455 GT1:=1;N:=SP[MOC].LOCFIELD;%LOCATION OF FMKS 03918456 WHILE LASTMKS GTR N AND BOOLEAN (GT1) DO GT1:=IF 03918458 POPPROGRAM(OLDDATA,LASTMKS)THEN 1 ELSE 0; 03918459 IF M NEQ L AND NOT BOOLEAN(SP[MOC].SUSPENDED)THEN%GET LINE# 03918460 BEGIN SP[LOC].RF:=SP[LOC].RF+1;%UP SUSPENDED COUNT 03918462 L:=SP[NOC].SPF-1;%LOCATION OF FUNCTION NAME 03918464 SETFIELD(GTA,0,1,0); 03918465 GTA[0]:=SP[LOC]; 03918467 FORMROW(3,0,GTA,1,7); 03918470 L:=SP[MOC].SPF; %BASE OF LABEL TABLE 03918475 L:=L+CURLINE; 03918480 T:=SP[LOC]; 03918485 03918486 %ALSO PUT THE FUNCTION INTO SUSPENSION 03918487 IMS(4);SP[MOC].SUSPENDED:=1;SUSPENSION:=1; 03918488 PUSHINTOSYMTAB(SP[MOC]); 03918489 END ELSE T:=0; 03918490 ERRORMESS(ERR,POLWORD.SPF,T); 03918500 END; 03918600 END UNTIL XIT; 03919000 BREAKKEY: BEGIN BREAKFLAG:=FALSE; 03919800 XIT:=TRUE;CURRENTMODE:=CALCMODE; 03919810 L:=FUNCLOC;M:=SP[LOC].SPF+L; 03919820 IF M NEQ L AND NOT BOOLEAN(SP[MOC].SUSPENDED) THEN 03919830 BEGIN SP[MOC].SUSPENDED:=1;SUSPENSION:=1; 03919840 PUSHINTOSYMTAB(SP[MOC]);SP[LOC].RF:=SP[LOC].RF+1; 03919850 M:=SP[MOC].LOCFIELD;%LOCATION OF FMKS IN STACK 03919860 WHILE LASTMKS GTR M DO IF POPPROGRAM(OLDDATA,LASTMKS) 03919870 THEN; LASTMKS:=M;IMS(4); 03919880 END 03919890 IF FALSE THEN 03919899 END; 03919900 EXECEXIT: 03919990 IF STACKBASE NEQ 0 THEN BEGIN 03919992 L:=STACKBASE; SP[LOC]:=ST-L; %UPDATE SIZE OF STACK 03920000 03920100 END; 03920200 END OF EXECUTION LOOP; 03950000 PROCESSEXIT: 03950090 IF BOOLEAN(POLBUG) THEN % DUMP SP 03950100 IF MODE=XEQUTE OR MODE=3 OR MODE=6 THEN GO TO DEBUGSP; 03950200 IF FALSE THEN 03951000 BEGIN CASE 0 OF BEGIN 03951100 EXPOVRL: SPOUT(3951200); 03951200 INTOVRL: SPOUT(3951300); 03951300 INDEXL: SPOUT(3951400); 03951400 FLAGL: SPOUT(3951500); 03951500 ZEROL: SPOUT(3951600); 03951600 END; 03951700 REALLYERROR:=1; 03951702 DEBUGSP: 03951710 WRITE(PRINT,MIN(15,PSRSIZE),PSR); 03951720 BEGIN 03951800 STREAM PROCEDURE FORM(A,B,N); VALUE N; 03951900 BEGIN 03952000 DI:=B; 15(DS:=8LIT" "); 03952100 SI:=LOC N; DI:=B; DS:=8DEC; DI:=DI+3; 03952200 SI:=A; 10(DS:=8CHR; DI:=DI+1); 03952300 END; 03952400 M:=MIN((NROWS+1)|SPRSIZE-1,MAXMEMACCESSES); 03952500 FOR N:=0 STEP 10 UNTIL M DO 03952650 BEGIN TRANSFERSP(OUTOF,SP,N,ACCUM,0,MIN(M-N,10)); 03952700 FORM(ACCUM,BUFFER,N); 03952800 WRITE(PRINT,15,BUFFER[*]); 03952900 END; 03953000 END; 03953100 IF POLBUG=0 OR BOOLEAN(REALLYERROR) THEN 03953110 BEGIN 03953120 ERRORMESS(IF ERR NEQ SPERROR THEN SYSTEMERROR ELSE ERR,0,0); 03953200 SUSPENSION:=0; 03953210 CURRENTMODE:=CALCMODE; 03953300 REALLYERROR:=ERR:=0; 03953301 END; 03953310 END; 03953400 END OF PROCESS PROCEDURE; 03960000 PROCEDURE ERRORMESS(N,ADDR,R); VALUE N,ADDR,R; REAL R; 05000000 INTEGER N; REAL ADDR; 05000100 BEGIN 05000200 INTEGER STREAM PROCEDURE FORM(A,B); VALUE A; 05000300 BEGIN LOCAL T,U; 05000400 LABEL L,M; 05000500 SI:=A; 05000600 L: IF SC=" " THEN 05000700 BEGIN SI:=SI+1; GO TO L; 05000800 END; 05000900 DI:=LOC T; DS:=2RESET; DS:=2SET; 05001000 DI:=B; MESSIZE(U:=DI; DI:=LOC T; IF SC=DC THEN JUMP OUT TO M; 05001100 SI:=SI-1; DI:=U; DS:=CHR; TALLY:=TALLY+1); M: 05001200 FORM:=TALLY; 05001300 END; 05001400 ARRAY ERMES[0:13],B[0:MESSIZE/8]; 05001410 FILL ERMES[*] WITH 05001500 "1 ", 05001510 "5DEPTH ", 05001520 "6DOMAIN ", 05001530 "7EDITING", 05001540 "5INDEX ", 05001600 "5LABEL ", 05001610 "6LENGTH ", 05001620 "5NONCE ", 05001700 "4RANK ", 05001710 "6SYNTAX ", 05001720 "6SYSTEM ", 05001800 "5VALUE ", 05001810 "7SP FULL", 05001820 "7FLYKITE"; 05001830 IF R NEQ 0 THEN 05001900 BEGIN INDENT(R);CHRCOUNT:=CHRCOUNT-1 05001910 END; 05002000 FORMROW((IF R=0 THEN 2 ELSE 0),0,ERMES,N|8+1, 05002010 ERMES[N].[1:5]); 05002100 FORMWD(0,"6 ERROR"); 05002110 IF ADDR.[33:15] GEQ 512 THEN 05002120 BEGIN 05002130 FORMWD(0,"4 AT "); 05002200 FORMROW(1,1,B,0,FORM(ADDR,B)) 05002210 END; 05002220 FORMWD(3,"1 "); 05002300 END; 05002310 PROCEDURE LOADWORKSPACE(JOBNUM,NAME,IDENT); VALUE JOBNUM,NAME; 05002400 REAL JOBNUM,NAME; ARRAY IDENT[0]; FORWARD; 05002410 PROCEDURE LOGINAPLUSER; 07001000 BEGIN 07002000 COMMENT LOG:IN THE CURRENT USER; 07003000 COMMENT INPUT LINE IS IS THE BUFFER; 07004000 LABEL EXEC, GUESS; 07004100 DEFINE T=GT1#, J=GT2#,I=GT3#; 07005000 PROCEDURE INITIALIZEPSR; 07005010 BEGIN FOR I:=0 STEP 1 UNTIL PSRSIZE-1 DO 07005015 PSRM[I] := 0; 07005020 SEED:=STREAMBASE; ORIGIN:=1; 07005025 FUZZ:=1@-11; 07005030 LINESIZE:=72; DIGITS:=9; 07005035 END; 07005040 LADDRESS := ADDRESS := ABSOLUTEADDRESS; 07006000 WORKSPACE:=WORKSPACEUNIT; 07007000 ITEMCOUNT := EOB := 0; 07008000 IF NEXTUNIT=WORKSPACEUNIT THEN % ESTABLISH A WORKSPACE 07019000 BEGIN 07020000 WORKSPACE:=NEXTUNIT; 07021000 SEQUENTIAL(WORKSPACE); 07022000 INITIALIZEPSR; 07023000 I:=STORESEQ(WORKSPACE,PSR,PSRSIZE|8); 07025000 INITBUFF(OLDBUFFER,BUFFSIZE); 07028000 07029000 END ELSE % WORKSPACE ASSIGNED 07030000 I:=CONTENTS(WORKSPACE,0,PSR); 07031000 FILL ACCUM[*] WITH "LOGGED I","N "; 07032000 FORMROW(0,1,ACCUM,0,9); 07033000 I:=DAYTIME(ACCUM); 07034000 FORMROW(1,1,ACCUM,0,I); 07035000 SYMBASE:=STACKBASE:=0; 07035900 CSTATION.APLOGGED:=1; 07036000 CASE CURRENTMODE OF 07036010 BEGIN %--------CALCMODE-------------- 07036020 ;COMMENT NOTHING TO DO ANYMORE; 07036030 %--------------XEQUTEMODE------------ 07036040 EXEC: 07036042 BEGIN FILL ACCUM[*] WITH "LAST RUN"," STOPPED"; 07036050 FORMROW(3,0,ACCUM,0,16); 07036060 CURRENTMODE:=CALCMODE; 07036070 END; 07036080 %-------------FUNCMODE----------------- 07036090 BEGIN FILL ACCUM[*]WITH "CONTINUE"," DEFINIT", 07036100 "ION OF "; 07036110 FORMROW(2,0,ACCUM,0,23); FORMROW(1,0,PSR, 07036120 FSTART|8,7); 07036130 CURLINE:=GT3:=TOPLINE(GT1:=FUNCPOINTER); 07036131 CHECKSEQ(CURLINE,GT3,INCREMENT); %GET INCREMENT 07036132 CURLINE:=CURLINE+INCREMENT; INDENT(-CURLINE); 07036133 FUNCSIZE:=SIZE(GT1); 07036134 END; 07036136 %------------INPUTMODE--------------ERRORMODE---- 07036140 GO TO EXEC; GO TO EXEC; 07036150 END; 07036160 GUESS: %SHOULD BE BETTER PLACE BUT HERE IS WHERE OTHERS COME OUT 07044001 STOREPSR; 07044005 IF CURRENTMODE NEQ FUNCMODE THEN 07044010 INDENT(0); TERPRINT; 07044100 VARSIZE:=IF VARIABLES=0 THEN 0 ELSE SIZE(VARIABLES); 07044200 END; 07045000 PROCEDURE APLMONITOR; 07100000 BEGIN 07101000 REAL T; 07102000 INTEGER I; 07103000 BOOLEAN WORK; 07104000 LABEL AROUND, NEWUSER; 07105000 LABEL CALCULATE,EXECUTEIT,FUNCTIONSTART,BACKAGAIN; 07106000 LABEL CALCULATEDIT; 07107000 I := CUSER := 1; 07107100 T := STATION; 07115000 BEGIN FILL ACCUM[*] WITH "APL/B550","0 UW COM" 07115533 ,"PUTER SC","IENCE # ",VERSIONDATE; 07115534 WORK:=TRUE; 07115535 FORMROW(3,MARGINSIZE,ACCUM,0,40); 07115536 INDENT(0); TERPRINT; CSTATION.APLHEADING:=1 07115538 ; LOGINAPLUSER; 07115539 END; 07115540 AROUND: 07115542 07115550 BEGIN 07115560 IF MAINTENANCE THEN; 07115570 CASE CURRENTMODE OF 07115600 BEGIN %-------CALCMODE-------------------------------- 07115700 COMMENT HE MUST BE READ READY FOR THE CALCMODE STUFF; 07115800 07115900 GO CALCULATE; 07116000 %--------XEQUTE MODE-------------------------------- 07116100 GO TO EXECUTEIT; 07117000 %----------FUNCMODE----------------------------------- 07117100 GO TO FUNCTIONSTART; 07117400 %----------INPUTMODE---------------------------------- 07117500 COMMENT REQUIRES INPUT; 07117600 07117700 BEGIN COMMENT GET THE LINE AND GO BACK; 07117800 STARTSCAN; 07117900 CURRENTMODE:=XEQMODE; 07118000 GO TO EXECUTEIT; 07118100 END; 07118200 %----------ERRORMODE--------------------------------- 07118300 GO TO BACKAGAIN; 07118400 07118410 END; %OF CASES 07118500 END; 07118510 COMMENT GET HERE IF NOTHING TO DO; 07118600 07118610 GO TO AROUND; 07119000 CALCULATE: 07125000 STARTSCAN; 07126000 CALCULATEDIT: 07126010 ERR:=0; %AND DON"T RESET IT IN SCAN OR IN ANALYZE 07126020 IF SCAN THEN 07126100 IF RGTPAREN THEN MESSAGEHANDLER ELSE 07126200 IF DELV THEN FUNCTIONHANDLER ELSE 07126300 BEGIN COMMENT PROCESS CALCULATOR MODE REQUEST; 07126310 MOVE(BUFFER,BUFFSIZE,OLDBUFFER); 07126320 IF NOT BOOLEAN(SUSPENSION) THEN BEGIN %INITIALIZE USER 07126321 %%% 07126322 %%% 07126323 SYMBASE:=STACKBASE:=0; 07126324 END; 07126326 PROCESS(XEQUTE); 07126330 IF CURRENTMODE=CALCMODE THEN 07126332 BACKAGAIN: BEGIN INDENT(0); TERPRINT; 07126333 IF NOT BOOLEAN(SUSPENSION) THEN 07126334 BEGIN IF CURRENTMODE NEQ ERRORMODE THEN 07126335 PROCESS(WRITEBACK); 07126336 SP[0,0]:=0;NROWS:=-1; 07126337 %%% 07126338 END; 07126340 CURRENTMODE:=CALCMODE; 07126341 END; 07126342 END; 07126350 IF EDITOG=1 THEN 07126360 BEGIN MOVE(OLDBUFFER,BUFFSIZE,BUFFER); 07126370 RESCANLINE; EDITOG:=0; GO TO CALCULATEDIT; 07126380 END; 07126390 I:=0; 07126400 GO AROUND; 07127000 EXECUTEIT: 07128000 PROCESS(XEQUTE); %GO BACK TO PROCESS FOR AWHILE 07129000 IF CURRENTMODE=CALCMODE THEN GO TO BACKAGAIN; 07129010 I:=0; 07129100 GO AROUND; 07130000 FUNCTIONSTART: 07131000 IF SPECMODE = 0 THEN 07131010 BEGIN %SEE IF A SPECIAL FUNCTION. 07131020 STARTSCAN; 07131024 IF SCAN AND RGTPAREN THEN MESSAGEHANDLER ELSE 07131030 FUNCTIONHANDLER 07131040 END ELSE 07131050 FUNCTIONHANDLER; 07131100 I:=0; 07132000 GO AROUND 07133000 END; 07134000 INTEGER PROCEDURE LENGTH(A,M);VALUE M; BOOLEAN M; ARRAY A[0]; 08007900 BEGIN 08007910 INTEGER STREAM PROCEDURE LENGT(A,M,L); VALUE M,L; 08008000 BEGIN LOCAL T; 08008010 LOCAL C,CC,TSI; LABEL LAB; 08008020 LOCAL AR; LABEL LAB2; 08008022 SI:=LOC M; SI:=SI+7; 08008030 IF SC="1" THEN 08008040 BEGIN COMMENT LOOK FOR LEFT ARROW.; 08008050 DI:=LOC AR; DS:=RESET; DS:=5SET; 08008060 SI:=LOC L; DI:=LOC T; DI:=DI+1; DS:=7CHR; 08008070 SI:=A; 08008080 T(2(32(DI:=LOC AR; IF SC=DC THEN JUMP OUT 3 TO LAB; 08008090 TALLY:=TALLY+1; 08008100 C:=TALLY; TSI:=SI; SI:=LOC C; 08008110 SI:=SI+7; IF SC="0" THEN 08008120 BEGIN TALLY:=CC; TALLY:=TALLY+1; CC:=TALLY; 08008130 TALLY:=0; 08008140 END; SI:=TSI))); 08008150 L(DI:=LOC AR; IF SC=DC THEN JUMP OUT TO LAB; 08008160 TALLY:=TALLY+1; C:=TALLY; TSI:=SI; SI:=LOC C; SI:=SI+7; 08008170 IF SC="0" THEN 08008180 BEGIN TALLY:=CC; TALLY:=TALLY+1; CC:=TALLY; TALLY:=0 08008190 END; SI:=TSI); 08008200 LAB: SI:=LOC CC; DI:=LOC LENGT; DI:=DI+6; SI:=SI+7; 08008210 DS:=CHR; SI:=LOC C; SI:=SI+7; DS:=CHR; 08008220 END ELSE 08008230 BEGIN 08008240 SI:=LOC L; DI:=LOC T; DI:=DI+1; DS:=7CHR; 08008250 SI:=A; T(2(SI:=SI+32)); SI:=SI+L; 08008260 T(2(32(SI:=SI-1; IF SC NEQ " " THEN JUMP OUT 3 TO LAB2; 08008270 TALLY:=TALLY+1; C:=TALLY; TSI:=SI; SI:=LOC C; SI:=SI+7; 08008280 IF SC="0" THEN 08008290 BEGIN TALLY:=CC; TALLY:=TALLY+1; CC:=TALLY; TALLY:=0 08008300 END; SI:=TSI))); 08008310 L(SI:=SI-1; IF SC NEQ" " THEN JUMP OUT TO LAB2; 08008320 TALLY:=TALLY+1; C:=TALLY; TSI:=SI; SI:=LOC C; SI:=SI+7; 08008330 IF SC="0" THEN 08008340 BEGIN TALLY:=CC; TALLY:=TALLY+1; CC:=TALLY; TALLY:=0 08008350 END; SI:=TSI); 08008360 LAB2: GO TO LAB 08008370 END 08008380 END; 08008390 INTEGER I; 08008400 I:=LENGT(A,M,BUFFSIZE|8); 08008410 LENGTH:=IF M THEN I ELSE BUFFSIZE|8-I 08008420 END; 08008430 BOOLEAN PROCEDURE LABELSCAN(L,K); VALUE K; INTEGER K; ARRAY L[0]; 08013910 BEGIN REAL T; 08013912 T:=ADDRESS; 08013914 IF SCAN AND IDENT THEN 08013916 BEGIN SETFIELD(ACCUM,1,1,0); TRANSFER(ACCUM,1,L,K|8,8); 08013918 IF NOT(LABELSCAN:=(SCAN AND COLON)) THEN 08013920 BEGIN ADDRESS:=T; EOB:=0; IF SCAN THEN; 08013922 END; 08013923 END 08013924 END; 08013926 STREAM PROCEDURE MOVEWDS(A,N,B); VALUE N; 08013940 BEGIN SI:=A; DI:=B; DS:=N WDS END; 08013942 INTEGER PROCEDURE DAYTIME(B); ARRAY B[0]; 08014000 BEGIN 08014010 08014020 INTEGER D,H,M,MIN,Q,P,Y,TIME1; 08014040 LABEL OWT; 08014050 STREAM PROCEDURE FORM(A,DAY,MO,DA,YR,HR,MIN,AP); 08014060 VALUE DAY,MO,DA,YR,HR,MIN,AP; 08014062 BEGIN DI:=A; 08014064 SI:=LOC DAY; SI:=SI+7; 08014066 IF SC="0" THEN DS:=3LIT"SUN" ELSE 08014068 IF SC="1" THEN DS:=3LIT"MON" ELSE 08014070 IF SC="2" THEN DS:=4LIT"TUES" ELSE 08014072 IF SC="3" THEN DS:=6LIT"WEDNES" ELSE 08014074 IF SC="4" THEN DS:=5LIT"THURS" ELSE 08014076 IF SC="5" THEN DS:=3LIT"FRI" ELSE DS:=5LIT"SATUR"; 08014078 DS:=4LIT"DAY "; SI:=LOC MO; DS:=2DEC; 08014080 DS:=LIT"-"; SI:=LOC DA; DS:=2DEC; DS:=LIT"-"; 08014082 SI:=LOC YR; DS:=2DEC; DS:=2LIT" "; 08014084 SI:=LOC HR; DS:=2DEC; DS:=LIT":"; SI:=LOC MIN; 08014086 SI:=SI+6; DS:=2CHR; SI:=LOC AP; SI:=SI+7; DS:=LIT" "; 08014088 DS:=CHR; DS:=LIT"M" 08014090 END; 08014092 TIME1:=TIME(1); 08014100 Y:=TIME(0); 08014110 D:=Y.[30:6]|100+Y.[36:6]|10+Y.[42:6]; 08014120 Y:=Y.[18:6]|10+Y.[24:6]; 08014130 FOR H:=31,IF Y MOD 4=0 THEN 29 ELSE 28,31,30, 08014140 31,30,31,31,30,31,30 DO 08014150 IF D LEQ H THEN GO OWT ELSE 08014160 BEGIN D:=D-H; M:=M+1 08014170 END; 08014180 OWT: 08014190 H:=TIME1 DIV 216000; 08014200 MIN:=(TIME1 DIV 3600) MOD 60; 08014210 IF M LSS 2 THEN 08014220 BEGIN Q:=M+11; P:=Y-1 08014230 END ELSE 08014240 BEGIN Q:=M-1; P:=Y 08014250 END; 08014260 M:=M+1; 08014270 FORM(B,TIME1:=((Q|26-2)DIV 10+D+P+P.[36:10]+1)MOD 7, 08014280 M,D,Y,Q:= H MOD 12, Q:=MIN MOD 10+(MIN DIV 10)|64, 08014282 IF H GEQ 12 THEN "P" ELSE 17); 08014284 DAYTIME:=(IF TIME1=6 THEN 5 ELSE 08014286 IF TIME1=5 THEN 3 ELSE 08014288 IF TIME1=2 THEN 4 ELSE 3)+22; 08014290 08014300 08014310 END; 08014320 PROCEDURE LOADWORKSPACE(NAME1,NAME2,IDENT); VALUE NAME1,NAME2; 08014325 REAL NAME1,NAME2; ARRAY IDENT[0]; 08014327 BEGIN 08014329 FILE DISK DISK(2,WDSPERREC,WDSPERBLK); 08014331 INTEGER PROCEDURE RD(D,N,A); 08014333 VALUE N; INTEGER N; FILE D; ARRAY A[0]; 08014335 BEGIN READ(D[N],WDSPERREC,A[*]); 08014337 RD:=N+1; 08014339 END; 08014341 PROCEDURE LOADITEM(RD,D,ITEM); 08014343 INTEGER PROCEDURE RD; FILE D; 08014345 ARRAY ITEM[0]; 08014347 BEGIN 08014349 DEFINE T=ITEM#; 08014351 PROCEDURE GETALINE(C,S,L,B,RD,D,LEN); 08014355 VALUE LEN; INTEGER C,S,L,LEN; 08014359 ARRAY B[0]; INTEGER PROCEDURE RD; FILE D; 08014363 BEGIN % GET 2 CHRS GIVING ENSUING CHAR COUNT 08014367 INTEGER P; 08014369 IF C GTR LEN-2 THEN 08014371 IF C GTR LEN-1 THEN % READ A NEW RECORD AND TAKE 2 CHRS 08014375 BEGIN 08014379 S:=RD(D,S,B); 08014383 C:=2; 08014387 TRANSFER(B,0,L,6,2); 08014391 END 08014395 ELSE % 1 CHR LEFT ON LINE 08014399 BEGIN 08014403 TRANSFER(B,C,L,6,1); 08014407 S:=RD(D,S,B); 08014411 TRANSFER(B,0,L,7,1); 08014415 C:=1; 08014419 END 08014423 ELSE % AT LEAST 2 CHARS REMAINING ON LINE 08014427 BEGIN 08014431 TRANSFER(B,C,L,6,2); 08014435 C:=C+2; 08014439 END; 08014443 P:=0; 08014447 IF L NEQ 0 THEN % SOMETHING LEFT IN FUNCTION 08014451 BEGIN 08014455 WHILE P LSS L DO 08014459 IF (L-P) GTR (LEN-C) THEN % # OF CHARS IN LINE 08014463 % EXTENDS INTO NEXT RECORD 08014467 BEGIN 08014471 TRANSFER(B,C,BUFFER,P,LEN-C); % FINISH OUT RECORD 08014475 S:=RD(D,S,B); 08014479 P:=P+(LEN-C); % AMOUNT READ SO FAR 08014483 C:=0; 08014487 END 08014491 ELSE % ALL ON ONE RECORD 08014495 BEGIN 08014499 TRANSFER(B,C,BUFFER,P,L-P); 08014503 C:=C+L-P; 08014507 P:=L; % FINISHED 08014511 END; 08014515 END; 08014519 END OF GETALINE; 08014523 INTEGER S,K,L,M,C,LEN,SQ,PT,G,I,SIZE; 08014527 INTEGER HOLD; 08014529 LABEL SCALARL; 08014530 ARRAY U[0:1],B[0:WDSPERREC-1]; 08014531 BOOLEAN TOG; 08014535 TRANSFER(T,0,U,0,7); 08014539 G:=GETFIELD(T,7,1); 08014540 IF VARSIZE GTR 0 THEN 08014543 IF K:=SEARCHORD(VARIABLES,U,HOLD,7)=0 THEN 08014547 IF K:=GETFIELD(U,7,1)=FUNCTION THEN TOG:=TRUE 08014551 ELSE % NOT A FUNCTION IN THE SYMBOL TABLE 08014555 IF G=FUNCTION THEN 08014559 BEGIN 08014565 DELETE1(VARIABLES,HOLD); 08014567 IF K=ARRAYDATA THEN RELEASEARRAY(U[1]); 08014569 END 08014570 ELSE TOG:=TRUE % DON-T CHANGE 08014571 ELSE % NOT IN VARIABLES 08014575 BEGIN 08014579 VARSIZE:=VARSIZE+1; 08014583 HOLD:=HOLD+K-1; 08014587 END 08014591 ELSE VARSIZE:=1; 08014595 LEN:=(WDSPERREC-1)|8; 08014597 IF NOT TOG THEN % OK TO PUT INTO VARIABLES 08014599 IF G=FUNCTION THEN % READ A FUNCTION INTO VARIABLES 08014603 BEGIN 08014607 TRANSFER(T,0,U,0,9); % U HOLDS FUNCTION NAME, 08014619 %NUMBER OF ARGUMENTS, AND WHETHER FN RETURNS A VALUE 08014620 S:=T[1].LIBF1; % RECORD NUMBER 08014639 M:=T[1].LIBF2; % WORD WITHIN RECORD 08014643 SIZE:=T[1].LIBF3; % SIZE OF POINTERS TABLE 08014647 PT:=NEXTUNIT; 08014649 S:=RD(D,S,B); 08014650 FOR I:=0 STEP 1 UNTIL SIZE-1 DO 08014651 BEGIN 08014655 TRANSFER(B,M|8,T,0,16); 08014659 M:=M+2; 08014663 IF M GEQ WDSPERREC-1 THEN 08014667 BEGIN 08014671 S:=RD(D,S,B); 08014675 IF M GEQ WDSPERREC THEN 08014679 BEGIN 08014683 TRANSFER(B,0,T,8,8); 08014687 M:=1; 08014691 END 08014695 ELSE M:=0; 08014699 END; 08014703 STOREORD(PT,T,I); 08014707 END; % HAVE FINISHED FILLIN G POINTERS TABLE 08014711 IF VARIABLES=0 THEN BEGIN 08014712 VARIABLES:=NEXTUNIT; TOG:=TRUE; %KEEP THE UNIT OPEN 08014713 STOREORD(VARIABLES,U,HOLD); END; 08014714 SEQUENTIAL (SQ:=NEXTUNIT); 08014715 SETFIELD(U,FPTF,FFL,PT); 08014716 SETFIELD(U,FSQF,FFL,SQ); 08014717 STOREORD(VARIABLES,U,HOLD); 08014718 IF TOG THEN DELETE1(VARIABLES,HOLD+1);%REMOVE 1 EXTRA 08014719 COMMENT NOW FILL IN SEQ STORAGE; 08014720 IF M NEQ 0 THEN BEGIN 08014721 M:=C:=0; 08014723 S:=RD(D,S,B); % TEXT STARTS AT BEG. OF NEW RECORD 08014727 END; 08014731 L:=1; 08014735 08014739 WHILE L NEQ 0 DO 08014743 BEGIN 08014747 GETALINE(C,S,L,B,RD,D,LEN); 08014751 GT1:=STORESEQ(SQ,BUFFER,L); 08014755 END 08014759 END 08014763 ELSE 08014767 IF G=ARRAYDATA THEN 08014771 IF T[1].INPTR=0 THEN % NULL VECTOR 08014772 GO SCALARL 08014773 ELSE 08014774 BEGIN 08014775 ARRAY DIMVECT[0:MAXBUFFSIZE]; 08014779 S:=T[1].INPTR; % RECORD NUMBER 08014783 M:=T[1].DIMPTR; % LOC WITHIN RECORD 08014787 C:=M|8; 08014791 SIZE:=T[1].RF; % RANK 08014795 S:=RD(D,S,B); 08014799 GETALINE(C,S,L,B,RD,D,LEN); 08014803 T[1].DIMPTR:=STORESEQ(WS,BUFFER,L); 08014807 % PUTS DIMVECT INTO WORKSPACE 08014811 GETALINE(C,S,L,B,RD,D,LEN); % # BLOCKS 08014815 SIZE:=L-1; 08014819 FOR K:=0 STEP 2 UNTIL SIZE DO 08014823 BEGIN 08014827 GETALINE(C,S,L,B,RD,D,LEN); 08014831 SETFIELD(DIMVECT,K,2,STORESEQ(WS,BUFFER,L)); 08014835 END; COMMENT THIS STORES THE VALUES OF THE 08014839 ARRAY INTO THE WORKSPACE, AND ALSO RECORDS 08014843 THE LOCATION WITHIN WS IN DIMVECT,TO BE STORED;08014847 T[1].INPTR:=STORESEQ(WS,DIMVECT,SIZE+1); 08014851 IF VARIABLES=0 THEN VARIABLES:=NEXTUNIT; 08014853 STOREORD(VARIABLES,T,HOLD); 08014855 END 08014859 ELSE % MUST BE A SCALAR 08014863 SCALARL: 08014864 BEGIN 08014865 IF VARIABLES=0 THEN VARIABLES:=NEXTUNIT; 08014866 STOREORD(VARIABLES,T,HOLD); 08014867 END 08014869 ELSE % WILL NOT REPLACE IN SYMBOL TABLE 08014871 BEGIN 08014875 FILL BUFFER[*] WITH " ","NOT REPL","ACED "; 08014879 TRANSFER(T,0,BUFFER,0,7); 08014883 FORMROW(3,0,BUFFER,0,20); 08014887 END; 08014891 END LOADITEM; 08014906 BOOLEAN STREAM PROCEDURE EQUAL(A,B); 08014910 BEGIN SI:=A; DI:=B; SI:=SI+2; IF 7SC=DC THEN TALLY:=1; 08014914 EQUAL:=TALLY 08014918 END; 08014922 INTEGER I,J,L,NDIR,N; 08014926 LABEL MOVEVAR,SKIP; 08014928 ARRAY T,U[0:1],D[0:WDSPERREC-1]; 08014930 FILL DISK WITH NAME1,NAME2; L:=RD(DISK,L,D); 08014933 IF D[1] NEQ JOBNUM AND D[1] NEQ 0 THEN GO SKIP; % FILE LOCKED 08014940 FOR I:=2 STEP 1 UNTIL 9 DO IF GETFIELD(D[I],1,7) NEQ 0 THEN GO SKIP;08014941 IF NDIR:=D[0] NEQ 0 THEN 08014942 BEGIN N:=LIBSPACES+ENTIER(NDIR|2/(J:=WDSPERREC-1)); 08014944 IF(NDIR|2) MOD J NEQ 0 THEN N:=N+1; 08014945 FOR I:=1 STEP 1 UNTIL NDIR DO 08014946 BEGIN COMMENT GET FUNCTION OR VARIABLE NAME FROM LIB; 08014948 IF WDSPERREC-J LSS 3 THEN 08014950 IF WDSPERREC-J=1 THEN 08014952 BEGIN L:=RD(DISK,L,D); J:=0; GO MOVEVAR 08014954 END ELSE 08014956 BEGIN TRANSFER(D,J|8,T,0,8); L:=RD(DISK,L,D); 08014958 TRANSFER(D,0,T,8,8); J:=1 08014960 END ELSE MOVEVAR: 08014962 BEGIN TRANSFER(D,J|8,T,0,16); J:=J+2 08014964 END; 08014966 IF(IF IDENT[0]=0 THEN TRUE ELSE EQUAL(IDENT,T)) THEN 08014968 BEGIN IF IDENT[0] NEQ 0 THEN I:=NDIR+1; 08014970 LOADITEM(RD,DISK,T); 08014972 END 08014974 END; 08014976 STOREPSR; % UPDATE SINCE HAVE ADDED TO VARIABLES 08014977 END; 08014978 IF FALSE THEN SKIP: FORMWD(1,"6BADFIL"); 08014979 EOB:=1; 08014980 END OF LIBRARY LOAD; 08014990 PROCEDURE PURGEWORKSPACE(WS); VALUE WS; INTEGER WS; 08015000 IF WORKSPACE NEQ 0 THEN 08015005 BEGIN 08015010 INTEGER I,J,K,V,L,G; 08015020 ARRAY T[0:1]; 08015030 J:=SIZE(V:=VARIABLES)-1; 08015040 FOR I:=0 STEP 1 UNTIL J DO 08015050 BEGIN K:=CONTENTS(V,I,T); 08015060 IF GETFIELD(T,7,1)=FUNCTION THEN 08015070 FOR L:=FPTF,FSQF DO % GET RID OF STORAGE 08015080 IF G:=GETFIELD(T,L,FFL) NEQ 0 THEN RELEASEUNIT(G); 08015090 END; 08015100 RELEASEUNIT(V); 08015110 VARIABLES:=0; VARSIZE:=0; 08015120 CURRENTMODE:=0; J:=SIZE(WS)-1; 08015122 FOR I:=1 STEP 1 UNTIL J DO DELETE1(WS,I); 08015124 STOREPSR; 08015130 END; 08015140 PROCEDURE ELIMWORKSPACE(WS); VALUE WS; INTEGER WS; 08015150 BEGIN LABEL QQQ; QQQ: 08015152 IF WORKSPACE NEQ 0 THEN 08015155 BEGIN 08015205 PURGEWORKSPACE(WS); RELEASEUNIT(WS); 08015210 % 08015220 END ELSE SPOUT(8015222); 08015222 END; 08015223 PROCEDURE SAVEWORKSPACE(NAME1,NAME2,LOCKFILE); 08015300 VALUE NAME1,NAME2,LOCKFILE; 08015305 REAL NAME1,NAME2,LOCKFILE; 08015310 BEGIN 08015320 SAVE FILE DISK DISK [NAREAS:SIZEAREAS] 08015330 (2,WDSPERREC,WDSPERBLK,SAVE 100); 08015340 INTEGER PROCEDURE WR(D,N,A); VALUE N; INTEGER N; 08015350 FILE D; ARRAY A[0]; 08015360 BEGIN REAL STREAM PROCEDURE CON(A); VALUE A; 08015370 BEGIN SI:=LOC A; DI:=LOC CON; DS:=8DEC END; 08015380 STREAM PROCEDURE CLEANER(A); 08015382 BEGIN DI:=A; WDSPERREC(DS:=8LIT".") END; 08015384 A[WDSPERREC-1]:=CON(N); 08015390 WRITE(D[N],WDSPERREC,A[*]); 08015400 WR:=N+1; CLEANER(A); 08015410 END; 08015420 PROCEDURE PUTAWAY(C,J,WR,D,N,M,B,L); VALUE L,J; 08015430 INTEGER L,C,J,N,M; 08015435 ARRAY B[0]; INTEGER PROCEDURE WR; FILE D; 08015440 BEGIN INTEGER P,K; 08015450 IF C+2 GTR L THEN 08015460 BEGIN TRANSFER(J,6,B,C,1); N:=WR(D,N,B); C:=1; 08015470 TRANSFER(J,7,B,0,1); 08015480 END ELSE 08015490 BEGIN TRANSFER(J,6,B,C,2); C:=C+2 08015500 END; 08015510 WHILE J NEQ 0 DO 08015520 IF J GTR K:=(L-C) THEN 08015530 BEGIN TRANSFER(BUFFER,P,B,C,K); 08015540 N:=WR(D,N,B); J:=J-K; C:=0; P:=P+K 08015550 END ELSE 08015560 BEGIN TRANSFER(BUFFER,P,B,C,J); C:=C+J; J:=0 08015570 END; 08015580 IF C=L THEN 08015590 BEGIN N:=WR(D,N,B); C:=0 08015600 END; 08015606 END; 08015609 08015610 PROCEDURE MOVETWO(U,B,M,WR,L,D); 08015612 ARRAY U,B[0]; INTEGER M,L; INTEGER PROCEDURE WR; FILE D; 08015615 BEGIN 08015618 COMMENT PUTS 2 WORDS OF U IN B AND WRITES ON D IF A FULLRECORD;08015621 TRANSFER(U,0,B,M|8,16); % CONTENTS OF U INTO B 08015624 M:=M+2; 08015627 IF M GEQ WDSPERREC-1 THEN % FULL RECORD 08015630 BEGIN 08015633 L:=WR(D,L,B); 08015636 IF M GEQ WDSPERREC THEN % 1 OVER FULL RECORD 08015639 08015640 BEGIN 08015642 TRANSFER(U,8,B,0,8); 08015645 M:=1; 08015648 END 08015651 ELSE M:=0; 08015654 END; 08015657 END OF MOVETWO; 08015660 INTEGER H,Q,M,N,I,L,S,J,K,LINE,MAX,PT,SQ,C,LEN,W; 08015663 REAL LSD,STP; 08015666 LABEL SKIP; 08015669 ARRAY T,U[0:1],DIR,B,SEX[0:WDSPERREC]; 08015672 N:=LIBSPACES+ENTIER((S:=SIZE(VARIABLES))|2/(WDSPERREC-1)); 08015675 IF (S|2) MOD (WDSPERREC-1) NEQ 0 THEN N:=N+1; % ADJUST 08015678 LEN:=(WDSPERREC-1)|8; 08015681 FILL DISK WITH NAME1,NAME2; 08015684 DIR[0]:=S; % SIZE OF SYMBOL TABLE 08015687 IF BOOLEAN (LOCKFILE) THEN DIR[1]:=JOBNUM; 08015688 S:=S-1; 08015690 L:=WR(DISK,L,DIR); % FIRST LINE CONTAINS # OF ENTRIES IN 08015693 COMMENT SYMBOL TABLE AND LOCK INFORMATION; 08015696 FOR I:=0 STEP 1 UNTIL S DO 08015699 BEGIN 08015702 J:=CONTENTS(VARIABLES,I,T); % RETURNS VALUE OF I-TH LOC 08015705 % IN VARIABLES INTO T 08015708 IF GT2:=GETFIELD(T,7,1)=FUNCTION THEN 08015711 BEGIN 08015714 PT:=GETFIELD(T,FPTF,FFL); % FUNCTION POINTER FIELD 08015717 SQ:=GETFIELD(T,FSQF,FFL); % FUNCTION SEQUENTIAL FIELD 08015720 %PT=# OF ORDERED STORAGE UNIT CONTAINING HEADER&POINTE 08015723 %SQ=# OF SEQ STORAGE UNIT CONTAINING TEXT 08015726 MAX:=SIZE(PT); 08015729 T[1].LIBF1:=N; % RECORD # 08015732 T[1].LIBF2:=M; % LOC WITHIN RECORD 08015735 T[1].LIBF3:=MAX; % SIZE OF POINTERS TABLE; 08015738 % SAVE ENOUGH ROOM FOR THE ENTIRE POINTERS TABLE 08015740 H:=ENTIER(GT1:=(M+MAX|2)/(WDSPERREC-1)); 08015741 H:=IF GT1 NEQ H THEN H+N+1 ELSE H+N; 08015744 U[0]:=0; 08015747 J:=SEARCHORD(PT,U,LINE,8); % LOOK FOR ALL ZEROS 08015750 IF J=2 THEN GO SKIP; 08015753 FOR W:=0 STEP 1 UNTIL LINE-1 DO 08015756 %MOVE LOCALS AND LABELS INTO THE SAVE FILE 08015757 BEGIN 08015759 J:=CONTENTS(PT,W,U); 08015762 MOVETWO(U,B,M,WR,N,DISK); 08015765 END; 08015768 FOR LINE:=LINE STEP 1 UNTIL MAX-1 DO 08015771 BEGIN 08015774 08015776 J:=CONTENTS(PT,LINE,U); 08015777 GT1:=U[1]; 08015778 U[1]:=LINE-W; 08015779 MOVETWO(U,B,M,WR,N,DISK); % POINTERS TABLE 08015780 J:=CONTENTS(SQ,GT1,BUFFER); 08015783 PUTAWAY(C,J,WR,DISK,H,Q,SEX,LEN); % TEXT 08015786 END; 08015789 PUTAWAY(C,0,WR,DISK,H,Q,SEX,LEN); 08015792 SKIP: 08015795 Q:=C DIV 8; 08015798 IF C MOD 8 NEQ 0 THEN Q:=Q+1; 08015801 IF Q=WDSPERREC-1 THEN 08015807 BEGIN 08015810 H:=WR(DISK,H,SEX); 08015813 Q:=0; 08015816 END; 08015819 IF M GTR 0 THEN N:=WR(DISK,N,B); 08015822 M:=Q; N:=H; 08015825 TRANSFER(SEX,0,B,0,C); % MOVE BACK TO B 08015828 C:=0; 08015830 END 08015831 ELSE 08015834 IF GT2=ARRAYDATA THEN 08015837 BEGIN 08015840 ARRAY DIMVECT[0:MAXBUFFSIZE]; 08015843 LSD:=T[1]; 08015846 IF H:=LSD.SPF=0 THEN % NULL VECTOR 08015849 ELSE 08015855 BEGIN 08015858 T[1].INPTR:=N; T[1].DIMPTR:=M; 08015859 C:=M|8; 08015860 J:=CONTENTS(WS,LSD.DIMPTR,BUFFER); % DIM VECT 08015861 PUTAWAY(C,J,WR,DISK,N,M,B,LEN); % STO DIM VECT 08015864 J:=CONTENTS(WS,LSD.INPTR,DIMVECT); 08015867 TRANSFER(DIMVECT,0,BUFFER,0,J); 08015868 PUTAWAY(C,J,WR,DISK,N,M,B,LEN); 08015869 J:=J-1; 08015870 FOR LINE:=0 STEP 2 UNTIL J DO 08015871 BEGIN 08015873 PT:=GETFIELD(DIMVECT,LINE,2); 08015876 STP:=CONTENTS(WS,PT,BUFFER); 08015879 PUTAWAY(C,STP,WR,DISK,N,M,B,LEN); 08015882 END; 08015885 M:=C DIV 8; IF C MOD 8 NEQ 0 THEN M:=M+1; C:=0; 08015886 IF M=WDSPERREC-1 THEN BEGIN N:=WR(DISK,N,B); 08015887 M:=0; END; 08015888 END; 08015889 END; 08015891 MOVETWO(T,DIR,K,WR,L,DISK); 08015892 END; 08015894 08015900 EOB:=1; 08015920 IF M GTR 0 THEN N:=WR(DISK,N,B); 08015922 IF K GTR 0 THEN L:=WR(DISK,L,DIR); 08015930 LOCK(DISK); 08015940 END; 08015950 BOOLEAN PROCEDURE LIBNAMES(A,B); REAL A,B; 08015952 BEGIN REAL T; 08015954 A:=B:=GT1:=0; 08015956 % 08015958 % 08015959 IF SCAN AND IDENT THEN 08015960 BEGIN T~ACCUM[0]; T.[6:6]~"/"; 08015961 IF SCAN AND LOCKIT THEN GT1~1 ELSE IF IDENT THEN LIBNAMES~TRUE; 08015962 A~T; B~ JOBNUM; 08015963 END 08015964 ELSE LIBNAMES~ TRUE; 08015966 END; 08015992 PROCEDURE MESSAGEHANDLER; 08016000 BEGIN 08016005 LABEL ERR1; 08016008 % 08016009 IF SCAN THEN IF IDENT THEN 08016010 BEGIN INTEGER I; REAL R,S; 08016011 PROCEDURE NOFILEPRESENT; 08016012 BEGIN 08016014 FILL BUFFER[*] WITH "FILE NOT"," ON DISK"; 08016016 FORMROW(3,0,BUFFER,0,16); 08016018 END OF NOFILEPRESENT; 08016020 PROCEDURE PRINTID(VARS); VALUE VARS; BOOLEAN VARS; 08016022 BEGIN INTEGER I,J,K,L,M; ARRAY T[0:1]; BOOLEAN TOG; 08016024 INTEGER NUM; 08016025 J:=VARSIZE-1; M:=VARIABLES; 08016026 FOR I:=0 STEP 1 UNTIL J DO 08016028 BEGIN L:=CONTENTS(M,I,T); TOG:=GETFIELD(T,7,1) 08016030 =FUNCTION; 08016032 IF NUM:=3|REAL(TOG AND VARS)+8+NUM GTR LINESIZE 08016033 THEN BEGIN TERPRINT; NUM:=3|REAL(TOG AND VARS)+8 END; 08016034 IF VARS THEN 08016035 BEGIN FORMROW(0,1,T,0,7); L:=L+1; 08016036 IF TOG THEN FORMWD(0,"3(F) "); 08016038 END ELSE 08016040 IF TOG THEN BEGIN L:=L+1; FORMROW(0,1,T,0,7) END; 08016042 END; 08016044 IF L=0 THEN FORMWD(3,"6 NULL.") ELSE TERPRINT 08016046 END; 08016048 R:=ACCUM[0]; 08016050 FOR I:=0 STEP 1 UNTIL MAXMESS DO 08016052 IF R=MESSTAB[I] THEN 08016054 BEGIN R:=I; I:=MAXMESS+1 08016060 END; 08016070 IF I=MAXMESS+2 THEN 08016080 CASE R OF 08016090 BEGIN 08016100 % ------- SAVE ------- 08016110 IF NOT LIBNAMES(R,S) THEN 08016120 IF NOT LIBRARIAN(R,S) THEN BEGIN 08016125 SAVEWORKSPACE(R,S,GT1); %GT1 SET IN LIBNAMES 08016130 GTA[0]~GTA[1]~0;TRANSFER(R,1,GTA,1,7); 08016131 IF(GT1~SEARCHORD(LIBRARY,GTA, I ,7)) NEQ 0 THEN 08016132 BEGIN GTA[0]~GTA[1]~0;TRANSFER(R,1,GTA,1,7); 08016133 STOREORD(LIBRARY,GTA,I+(IF GT1=1 THEN -1 ELSE 1));08016134 END; LIBSIZE~LIBSIZE+1; 08016135 END 08016138 ELSE 08016140 BEGIN 08016150 FILL BUFFER[*] WITH "FILE ALR","EADY ON ", 08016160 "DISK "; 08016165 FORMROW(3,0,BUFFER,0,20); 08016170 END 08016180 ELSE GO ERR1; 08016190 % ------- LOAD ------- 08016200 IF NOT LIBNAMES(R,S) AND R NEQ 0 THEN 08016205 IF LIBRARIAN(R,S) THEN 08016210 BEGIN ARRAY A[0:1]; 08016220 LOADWORKSPACE(R,S,A); 08016230 END 08016240 ELSE NOFILEPRESENT 08016250 ELSE GO ERR1; 08016260 % ------- DROP ------- 08016300 IF CURRENTMODE=CALCMODE THEN 08016305 IF NOT LIBNAMES(R,S) THEN 08016310 IF LIBRARIAN(R,S) THEN 08016315 BEGIN FILE ELIF DISK (1,1); 08016320 FILL ELIF WITH R,S; WRITE(ELIF[0]); 08016325 CLOSE(ELIF,PURGE) 08016330 ;GTA[0]~GTA[1]~0;TRANSFER(R,1,GTA,1,7); 08016331 IF SEARCHORD(LIBRARY,GTA,I,7)=0 THEN DELETE1(LIBRARY,I); 08016332 LIBSIZE~LIBSIZE-1; 08016333 END 08016335 ELSE NOFILEPRESENT 08016340 ELSE 08016360 IF NOT BOOLEAN(SUSPENSION)THEN PURGEWORKSPACE(WORKSPACE) 08016365 ELSE GO ERR1 ELSE GO ERR1; 08016370 % ------- COPY ------- 08016400 IF LIBNAMES(R,S) THEN 08016410 IF LIBRARIAN(R,S) THEN 08016415 LOADWORKSPACE(R,S,ACCUM) 08016420 ELSE NOFILEPRESENT 08016422 ELSE GO ERR1; 08016425 08016430 % -------- VARS ------- 08016500 PRINTID(TRUE); 08016510 08016520 %------- FNS ------- 08016600 PRINTID(FALSE); 08016610 %-------- LOGGED ---------------- 08016700 ; 08016746 %-------- MSG -------- 08016800 ERRORMESS(SYNTAXERROR,LADDRESS,0); 08016870 %-----WIDTH (INTEGER) ---------------------------- 08016900 IF NOT SCAN THEN BEGIN NUMBERCON(LINESIZE, ACCUM); 08016910 FORMROW(3,0,ACCUM,2,ACOUNT); END 08016915 ELSE IF NUMERIC AND I:=ACCUM[0] GTR 9 AND I LEQ 72 08016920 THEN BEGIN TERPRINT; LINESIZE:=I; STOREPSR; 08016925 END 08016940 %IF A NUMBER CONVERSION ERROR, RESULT WILL BE ZERO 08016945 %AND WE"LL GET AN ERROR ANYWAY 08016946 ELSE GO TO ERR1; 08016950 %-------- OPR -------- 08017000 ; 08017010 %------DIGITS (INTEGER) ------------------------ 08017100 IF NOT SCAN THEN BEGIN NUMBERCON(DIGITS,ACCUM); 08017110 FORMROW(3,0,ACCUM,2,ACOUNT); END 08017115 ELSE IF NUMERIC AND I:=ACCUM[0] GEQ 0 AND I LEQ 12 08017120 AND ERR=0 THEN BEGIN DIGITS:=I; STOREPSR END 08017125 ELSE GO TO ERR1; 08017130 %-------- OFF -------- 08017200 BEGIN 08017210 IF SCAN THEN IF ACCUM[0]="7DISCAR" THEN 08017220 ELIMWORKSPACE(WORKSPACE) ELSE 08017230 GO TO ERR1 ELSE; 08017232 FILL ACCUM[*] WITH "END OF R","UN "; 08017240 FORMROW(3,MARGINSIZE,ACCUM,0,10); 08017242 CURRENTMODE:=CALCMODE; 08017243 GT1:=CSTATION; 08017244 CSTATION:=GT1&0[CAPLOGGED] 08017245 ;GO TO FINIS; 08017246 END; 08017250 %--------ORIGIN----------------------------------- 08017255 IF NOT SCAN THEN BEGIN NUMBERCON(ORIGIN,ACCUM); 08017256 FORMROW(3,0,ACCUM,2,ACOUNT) END 08017257 ELSE IF NUMERIC AND ERR=0 THEN BEGIN ORIGIN:= 08017258 I:=ACCUM[0]; STOREPSR END ELSE GO TO ERR1; 08017259 %--------SEED--------------------------------- 08017260 IF NOT SCAN THEN BEGIN NUMBERCON(SEED,ACCUM); 08017262 FORMROW(3,0,ACCUM,2,ACOUNT) END 08017263 ELSE IF NUMERIC AND ERR=0 THEN BEGIN 08017265 SEED:=ABS(I:=ACCUM[0]); 08017266 STOREPSR END ELSE GO TO ERR1; 08017267 %--------FUZZ----------------------------------- 08017270 IF NOT SCAN THEN BEGIN 08017272 NUMBERCON(FUZZ,ACCUM); 08017273 FORMROW(3,0,ACCUM,2,ACOUNT) END 08017274 ELSE IF NUMERIC AND ERR=0 THEN BEGIN FUZZ:=ABS(ACCUM[0]); 08017275 STOREPSR END ELSE GO TO ERR1; 08017277 %------- SYN, NOSYN------------------------------------- 08017290 NOSYNTAX:=0; NOSYNTAX:=1; 08017292 %-----------------STORE------------------------- 08017950 IF SYMBASE NEQ 0 THEN PROCESS(WRITEBACK); 08017960 08017962 08017970 %-----------------ABORT------------------------ 08018000 BEGIN IF BOOLEAN(SUSPENSION) THEN 08018010 SP[0,0]:=0; NROWS:=-1; 08018012 %%% 08018020 SUSPENSION:=0; 08018022 STOREPSR 08018023 END; 08018030 %-----------------SI-------------------------------- 08018100 IF BOOLEAN(SUSPENSION) THEN 08018110 BEGIN GT1:=0; 08018120 PROCESS(LOOKATSTACK); 08018130 END ELSE FORMWD(3,"6 NULL."); 08018140 %------------------SIV------------------------------- 08018150 IF BOOLEAN(SUSPENSION) THEN 08018160 BEGIN GT1:=1; 08018170 PROCESS(LOOKATSTACK); 08018180 END ELSE FORMWD(3,"6 NULL."); 08018190 %------------------ERASE------------------------------ 08018200 IF CURRENTMODE=FUNCMODE OR BOOLEAN(SUSPENSION) THEN GO TO ERR1 08018210 ELSE WHILE SCAN AND IDENT DO 08018215 BEGIN % LOOK FOR THE IDENTIFIER NAME IN ACCUM 08018220 TRANSFER(ACCUM,2,GTA,0,7); 08018225 IF (IF VARIABLES=0 THEN FALSE ELSE 08018230 SEARCHORD(VARIABLES,GTA,GT1,7)=0) THEN 08018235 BEGIN % FOUND A SYMBOL TABLE ENTRY MATCHING NAME 08018240 DELETE1(VARIABLES,GT1); % REMOVE FROM SYMBOLTABLE 08018241 IF VARSIZE:=VARSIZE-1=0 THEN VARIABLES:=0; 08018242 COMMENT IF NOTHING IS IN THE UNIT IT IS DELETED; 08018243 08018245 % CHECK IF THERE IS MORE TO DELETE 08018250 IF GT1:=GETFIELD(GTA,7,1)=FUNCTION THEN 08018255 BEGIN 08018260 RELEASEUNIT(GETFIELD(GTA,FPTF,FFL)); 08018265 RELEASEUNIT(GETFIELD(GTA,FSQF,FFL)); 08018270 END 08018275 ELSE IF GT1 GTR 0 THEN % MUST BE AN ARRAY 08018300 RELEASEARRAY(GTA[1]); 08018305 END ELSE % THERE IS NO SUCH VARIABLE 08018310 ERRORMESS(LABELERROR,LADDRESS,0); 08018315 END; % OF TAKING CARE OF ERASE 08018320 %------------ ASSIGN -------------------------------- 08018330 ; 08018462 %------------ DELETE --------------------------------- 08018470 ; 08018577 %------------- LIST ------------------------------------ 08018580 ; 08018767 % -------------DEBUG -------------------------------- 08018770 IF SCAN AND IDENT THEN 08018780 IF ACCUM[0]="6POLISH" THEN POLBUG:=ABS(POLBUG-1); 08018930 08018942 %----------------------------- FILES ---------------------- 08018965 IF LIBSIZE>1 THEN 08018970 BEGIN FOR I~1 STEP 1 UNTIL LIBSIZE-1 DO 08018975 BEGIN R~CONTENTS(LIBRARY,I ,ACCUM); 08018980 FORMROW(0,1,ACCUM,2,6); 08018985 END; TERPRINT; 08018990 END ELSE FORMWD(3,"6 NULL."); 08018995 %------------------------ END OF CASES ---------------------------- 08018999 END ELSE GO TO ERR1; 08019000 IF CURRENTMODE=FUNCMODE THEN INDENT(-CURLINE); 08019010 END ELSE 08019020 IF QUOTE THEN EDITLINE ELSE 08019100 ERR1: ERRORMESS(SYNTAXERROR,0,0); 08019200 INDENT(0); 08019210 TERPRINT; 08019300 END; 08019400 REAL PROCEDURE LINENUMBER(R); VALUE R; REAL R; 08030000 BEGIN 08030010 REAL STREAM PROCEDURE CON(R); VALUE R; 08030020 BEGIN SI:=LOC R; DI:=LOC CON; DS:=8DEC 08030030 END; 08030040 LINENUMBER:=CON( ENTIER( (R+.00005)|10000)) 08030050 END; 08030060 DEFINE DELIM="""#, ENDCHR="$"#; 08030080 BOOLEAN PROCEDURE WITHINALINE(COMMAND,OLD,NEW,CHAR,WORD); 08030082 VALUE COMMAND,CHAR,WORD; INTEGER COMMAND,CHAR,WORD; 08030084 ARRAY OLD, NEW[0]; BEGIN 08030086 BOOLEAN STREAM PROCEDURE WITHINLINE(COMMAND,OLD,NEW,CHAR,WORD); 08030100 VALUE COMMAND,CHAR,WORD; 08030102 BEGIN 08030110 LOCAL OLDLINE,NEWLINE,F,BCHR; 08030120 LOCAL N,M,T; 08030130 LOCAL X,Y,Z; 08030132 LABEL LOOKING,FOUND,BETWEEN,TAIL,FINISH, 08030140 OVER; 08030150 DI:=NEW; WORD(DS:=8LIT" "); 08030160 SI:=LOC CHAR; DI:=LOC T; DI:=DI+1; DS:=7CHR; 08030162 SI:=COMMAND; 08030170 TALLY:=T; X:=TALLY; TALLY:=2; Y:=TALLY; TALLY:=32; Z:=TALLY; 08030180 TALLY:=0; 08030190 IF SC!"~" THEN 08030200 BEGIN BCHR:=SI; SI:=OLD; OLDLINE:=SI; 08030210 DI:=NEW; NEWLINE:=DI; SI:=BCHR; 08030220 63(IF SC=DELIM THEN JUMP OUT ELSE SI:=SI+1; TALLY 08030230 :=TALLY+1); N:=TALLY; 08030240 IF TOGGLE THEN 08030250 BEGIN 08030260 SI:=SI+1; TALLY:=0; 08030270 63(IF SC=DELIM THEN TALLY:=0 ELSE 08030280 IF SC="~" THEN JUMP OUT ELSE TALLY:=TALLY+1; SI:=SI+1); 08030290 IF TOGGLE THEN M:=TALLY; 08030300 DI:=OLDLINE; SI:=BCHR; 08030310 2( X( Y( Z( CI:=CI+F; 08030320 GO LOOKING; GO FOUND; GO BETWEEN; GO TAIL; GO FINISH; 08030330 LOOKING: %************ LOOKING FOR THE FIRST UNIQUE STRING**************08030340 IF SC=DELIM THEN BEGIN SI:=SI+1; TALLY:=2; F:=TALLY ; 08030350 DI:=NEWLINE; GO BETWEEN END ELSE 08030360 IF N SC=DC THEN BEGIN SI:=OLDLINE; SI:=SI+N; OLDLINE:=SI; 08030370 DI:=NEWLINE; SI:=BCHR; TALLY:=1; F:=TALLY; 08030380 GO FOUND END ELSE 08030382 BEGIN SI:=OLDLINE; DI:=NEWLINE; DS:=CHR; NEWLINE:=DI; 08030390 OLDLINE:=SI; SI:=BCHR; DI:=OLDLINE 08030400 END; GO OVER; 08030410 FOUND: %**************FOUND THE FIRST UNIQUE STRING ******************08030420 IF SC=DELIM THEN BEGIN SI:=SI+1; TALLY:=2; 08030430 F:=TALLY; GO BETWEEN END ELSE 08030432 DS:=CHR; GO OVER; 08030440 BETWEEN: % ********** BETWEEN THE // **********************************08030450 IF SC=DELIM THEN BEGIN SI:=SI+1; NEWLINE:=DI; DI:=OLDLINE; 08030460 TALLY:=3; F:=TALLY; GO TAIL END ELSE 08030470 IF SC="~" THEN BEGIN TALLY:=4; F:=TALLY; 08030480 SI:=OLDLINE; GO FINISH END ELSE 08030482 DS:=CHR; GO OVER; 08030490 TAIL: % ******* THE TAIL END OF THE COMMAND ***************************08030500 IF M SC=DC THEN BEGIN DI:=NEWLINE; SI:=OLDLINE; TALLY:=4; 08030510 F:=TALLY; GO FINISH END ELSE 08030520 BEGIN SI:=SI-M; DI:=DI-M; DI:=DI+1; OLDLINE:=DI; END; 08030530 GO OVER; 08030540 FINISH: % ********FINISH UP THE CHR MOVE FROM THE OLD TO NEW**********08030550 DS:=CHR; OVER:))); 08030560 TALLY:=CHAR; X:=TALLY; TALLY:=1; Y:=TALLY; 08030562 Z:=TALLY); 08030564 SI:=NEW; DI:=OLD; DS:=WORD WDS; TALLY:=1; 08030570 WITHINLINE:=TALLY 08030580 END 08030590 END 08030600 END OF WITHINALINE; 08030610 WITHINALINE := WITHINLINE(COMMAND,OLD,NEW,CHAR,WORD); 08030612 END OF PHONY WITHINALINE; 08030614 PROCEDURE EDITLINE; 08030621 BEGIN ARRAY T[0:MAXBUFFSIZE]; 08030622 INITBUFF(T,BUFFSIZE); 08030624 TRANSFER(OLDBUFFER,0,T,0,LENGTH(OLDBUFFER,TRUE)); 08030626 IF WITHINALINE(ADDRESS,T,OLDBUFFER,BUFFSIZE|8,BUFFSIZE) THEN 08030628 BEGIN MOVEWDS(OLDBUFFER,BUFFSIZE,BUFFER); 08030630 08030631 IF SCAN AND RGTPAREN THEN 08030632 ERRORMESS(SYNTAXERROR,LADDRESS,0) ELSE EDITOG:=1; 08030633 END; 08030634 08030636 08030638 FORMROW(3,0,BUFFER,0,LENGTH(BUFFER,FALSE)); 08030640 END; 08030642 PROCEDURE CHECKSEQ(SEQ,L,INC); REAL SEQ,L,INC; 08040000 BEGIN 08040100 INTEGER I,J; 08040200 I:=L|10000 MOD 10000; 08040300 FOR J:=-4 STEP 1 WHILE J LSS 0 AND I MOD 10=0 DO 08040400 I:=I/10; 08040500 INC:=10*J; 08040600 SEQ:=L; 08040700 END; 08040800 PROCEDURE FUNCTIONHANDLER; 09000000 BEGIN 09001000 LABEL ENDHANDLER; 09002000 OWN BOOLEAN EDITMODE; 09003000 DEFINE FPT=FUNCPOINTER#, 09004000 FSQ=FUNCSEQ#, 09004100 SEQ=CURLINE#, 09004200 INC=INCREMENT#, 09004300 MODE=SPECMODE#, 09004310 ENDDEFINES=#; 09004400 INTEGER STREAM PROCEDURE DELPRESENT(ADDR); VALUE ADDR; 09005000 BEGIN LABEL L,FINIS; 09005100 LOCAL Q; 09005110 DI:=LOC Q; DS:=RESET; DS:=5SET; DS:=2RESET; DS:=2SET; 09005120 % LEFT-ARROW / QUESTION MARK 09005130 SI:=ADDR; 09005140 L: DI:=LOC Q; 09005150 IF SC=DELCHR THEN 09005160 BEGIN ADDR:=SI; SI:=LOC Q; DI:=ADDR; DS:=LIT" "; 09005170 TALLY:=1; DELPRESENT:=TALLY; GO TO FINIS; 09005180 END; 09005200 IF SC=DC THEN GO TO FINIS; SI:=SI-1; 09005300 IF SC=DC THEN GO TO FINIS; 09005400 GO TO L; 09005500 FINIS: 09005600 END; 09005700 INTEGER PROCEDURE OLDLABCONFLICT(PT,S); VALUE PT,S; 09006000 INTEGER PT; REAL S; 09007000 IF PT NEQ 0 THEN 09008000 BEGIN INTEGER K; ARRAY L[0:1]; 09009000 ADDRESS:=ABSOLUTEADDRESS; 09010000 WHILE LABELSCAN(L,0) AND ERR EQL 0 DO 09011000 IF SEARCHORD(PT,L,K,8)=0 THEN 09012000 IF L[1] NEQ S THEN ERR:=24; 09013000 OLDLABCONFLICT:=ERR 09014000 END; 09015000 INTEGER PROCEDURE ELIMOLDLINE(PT,SQ,L); VALUE PT,SQ,L; INTEGER PT, 09016000 SQ,L; FORWARD; 09017000 INTEGER PROCEDURE STOREAWAY(PT,SQ,B,SEQ); VALUE SEQ; 09018000 INTEGER PT,SQ; REAL SEQ; ARRAY B[0]; FORWARD; 09019000 PROCEDURE BUFFERCLEAN(BUFFER,BUFFSIZE,ADDR); VALUE BUFFSIZE, 09019100 ADDR; REAL ADDR; INTEGER BUFFSIZE; ARRAY BUFFER[0]; 09019200 FORWARD; COMMENT THIS IS A PHONEY DEAL, BUT I CAN"T 09019300 DECLARE CLEANBUFFER FORWARD (MOVE IT UP HERE LATER); 09019400 PROCEDURE EDITDRIVER(PT,SQ,I,K); VALUE PT,SQ,I,K; 09020000 INTEGER PT,SQ,I,K; 09021000 BEGIN ARRAY C,LAB[0:1],OLD,NEW[0:MAXBUFFSIZE]; 09022000 STREAM PROCEDURE BL(A); 09023000 BEGIN DI:=A; MAXBUFFSIZE(DS:=8LIT" ") END; 09024000 DEFINE MOVE=MOVEWDS#; 09025000 REAL T,SEQ; INTEGER A,B,L,M; 09026000 T:=ADDRESS; 09027000 FOR A:=I STEP 1 WHILE A LEQ K AND EDITMODE DO 09028000 BEGIN B:=CONTENTS(PT,A,C); BL(OLD); 09029000 SEQ:=C[0]; 09030000 B:=CONTENTS(SQ,C[1],OLD); 09031000 IF EDITMODE:=WITHINALINE(T,OLD,NEW,BUFFSIZE|8,BUFFSIZE) 09032000 THEN BEGIN MOVE(BUFFER,MAXBUFFSIZE+1,NEW); 09033000 MOVE(OLD,MAXBUFFSIZE,BUFFER); 09034000 IF EDITMODE:=ERR:=OLDLABCONFLICT(PT,C[0])=0 THEN 09035000 BEGIN B:=ELIMOLDLINE(PT,SQ,C[1]); 09036000 DELTOG:=DELPRESENT(ADDRESS); 09036100 DELETE1(SQ,C[1]); DELETE1(PT,A+B); C[1]:= 09037000 STORESEQ(SQ,BUFFER,LENGTH(BUFFER,FALSE)); 09038000 STOREORD(PT,C,A+B); 09039000 RESCANLINE; L:=0; M:=1; LAB[1]:=C[0]; 09040000 WHILE LABELSCAN(C,0) DO 09041000 BEGIN MOVEWDS(C,1,LAB); 09042000 IF(IF FUNCSIZE=0 THEN TRUE ELSE L:= 09043000 SEARCHORD(PT,C,M,8)NEQ 0) THEN 09044000 BEGIN B:=B+1; FUNCSIZE:=FUNCSIZE+1; 09045000 STOREORD(PT,LAB,L+M-1) 09046000 END END; 09047000 A:=A+B; K:=K+B; 09048000 COMMENT THE NEXT LINE CAUSED A SYSTEM CRASH AFTER THE EDIT 09048500 IF NOSYNTAX=0 THEN PROCESS(XEQUTE); 09049000 END END; 09050000 MOVE(NEW,MAXBUFFSIZE+1,BUFFER) 09051000 END END; 09052000 PROCEDURE LISTLINE(PT,SQ,I); VALUE PT,SQ,I; INTEGER PT,SQ,I; 09052100 BEGIN 09052200 GT1:=CONTENTS(PT,I,GTA); 09052300 INDENT(GTA[0]); 09052400 GT1:=CONTENTS(SQ,GTA[1],BUFFER); 09052500 CHRCOUNT:=CHRCOUNT-1; 09052600 FORMROW(1,0,BUFFER,0,GT1); 09052700 END; 09052800 INTEGER PROCEDURE DISPLAY(A,B,PT,SQ); VALUE A,B,PT,SQ; 09053000 INTEGER PT,SQ; REAL A,B; 09054000 IF A LEQ B AND FUNCSIZE NEQ 0 THEN 09055000 BEGIN 09056000 ARRAY C[0:1]; 09057000 INTEGER I,J,K; 09058000 DEFINE CLEANBUFFER=BUFFERCLEAN#; 09058100 A:=LINENUMBER(A); B:=LINENUMBER(B); 09059000 C[0]:=A; 09060000 I:=SEARCHORD(PT,C,K,8); 09061000 I:=(IF I=2 THEN IF K LSS FUNCSIZE-1 THEN K:=K+1 ELSE 09062000 K ELSE K); 09063000 IF A NEQ B THEN 09064000 BEGIN 09065000 C[0]:=B; B:=SEARCHORD(PT,C,K,8); 09066000 END; 09067000 IF EDITMODE THEN % MAY HAVE ONLY ONE LINE TO EDIT 09068000 IF I=K THEN 09068100 IF A NEQ 0 THEN %NOT EDITING THE HEADER 09068200 EDITDRIVER(PT,SQ,I,K) 09068300 ELSE %EDITING THE FUNCTION HEADER, FIX LATER. 09068400 ERR:=31 09068500 ELSE %EDITING MORE THAN ONE LINE 09069000 BEGIN MODE:=EDITING; 09069100 IF A=0 THEN I:=I+1; 09069110 CLEANBUFFER(BUFFER,BUFFSIZE,ADDRESS); 09069112 MOVE(BUFFER,BUFFSIZE,OLDBUFFER); 09069120 LOWER:=I; UPPER:=K 09069200 END 09069300 ELSE %NOT EDITING, MUST BE A LIST 09069400 BEGIN 09070000 FORMWD(3,"1 "); 09071000 IF K=I THEN % LISTING A SINGLE LINE 09072000 BEGIN LISTLINE(PT,SQ,I); 09072100 FORMWD(3,"1 "); 09072200 END ELSE % LISTING A SET OF LINES 09072300 BEGIN MODE:=DISPLAYING; 09072400 LOWER:=I; UPPER:=K 09072500 END; 09072600 END; 09081000 EOB:=1; 09082000 END ELSE DISPLAY:=20; 09083000 INTEGER PROCEDURE DELETE(A,B,PT,SQ); VALUE A,B; 09084000 INTEGER PT,SQ; REAL A,B; 09085000 IF A LEQ B AND FUNCSIZE NEQ 0 AND A NEQ 0 THEN 09086000 BEGIN 09087000 INTEGER I,J,K,L; 09088000 ARRAY C[0:1]; 09089000 A:=LINENUMBER(A); 09090000 B:=LINENUMBER(B); 09091000 C[0]:=A; 09092000 IF SEARCHORD(PT,C,K,8)=2 THEN K:=K+1; 09093000 C[0]:=B; 09094000 IF SEARCHORD(PT,C,I,8)=1 THEN I:=I-1; 09095000 IF K GTR I OR I GEQ FUNCSIZE THEN DELETE:=21 ELSE 09096000 BEGIN 09097000 FOR J:=K STEP 1 UNTIL I DO 09098000 BEGIN A:=CONTENTS(PT,J,C); 09099000 L:=ELIMOLDLINE(PT,SQ,C[1]); 09100000 FUNCSIZE:=FUNCSIZE+L; I:=I+L; K:=K+L; J:=J+L; 09101000 DELETE1(SQ,C[1]) 09102000 END; 09103000 FUNCSIZE:=FUNCSIZE-(I-K+1) 09104000 ; EOB:=1; 09105000 DELETEN(PT,K,I); 09106000 IF FUNCSIZE=0 THEN 09107000 BEGIN 09108000 PT:=0; RELEASEUNIT(SQ); SQ:=0; 09109000 STOREPSR; 09110000 END; 09111000 END; 09112000 END ELSE DELETE:=22; 09113000 INTEGER PROCEDURE ELIMOLDLINE(PT,SQ,L); VALUE PT,SQ,L; 09114000 INTEGER PT,SQ,L; 09115000 BEGIN INTEGER K,J; 09116000 REAL AD; 09117000 ARRAY T[0:MAXBUFFSIZE],LAB[0:1]; 09118000 AD:=ADDRESS; 09119000 MOVEWDS(BUFFER,MAXBUFFSIZE+1,T); 09120000 INITBUFF(BUFFER,BUFFSIZE); 09121000 K:=CONTENTS(SQ,L,BUFFER); 09122000 RESCANLINE; 09123000 WHILE LABELSCAN(LAB,0) DO 09124000 IF SEARCHORD(PT,LAB,K,8)=0 THEN 09125000 BEGIN DELETE1(PT,K); J:=J-1 END; 09126000 ADDRESS:=AD; 09127000 MOVEWDS(T,MAXBUFFSIZE+1,BUFFER); 09128000 ELIMOLDLINE:=J 09129000 END; 09130000 INTEGER PROCEDURE STOREAWAY(PT,SQ,B,SEQ); VALUE SEQ; 09131000 INTEGER PT,SQ; REAL SEQ; ARRAY B[0]; 09132000 BEGIN DEFINE BUFFER=B#; 09133000 ARRAY C,LAB[0:1]; 09134000 INTEGER I,J,K,L; 09135000 BOOLEAN TOG; 09136000 SEQ:=LINENUMBER(SEQ); 09137000 C[0]:=SEQ; 09138000 IF TOG:=(PT=0 OR FUNCSIZE=0) THEN 09139000 BEGIN SEQUENTIAL(SQ:=NEXTUNIT); I:=0 09140000 END ELSE 09141000 IF J:=SEARCHORD(PT,C,I,8)=0 THEN 09142000 BEGIN 09143000 K:=ELIMOLDLINE(PT,SQ,C[1]); 09144000 I:=I+K; FUNCSIZE:=FUNCSIZE+K; 09145000 DELETE1(PT,I); 09146000 FUNCSIZE:=FUNCSIZE-1; 09147000 DELETE1(SQ,C[1]); 09148000 END ELSE 09149000 I:=I+J-1; 09150000 RESCANLINE; 09151000 DELTOG:=DELPRESENT(ADDRESS); 09151100 K:=STORESEQ(SQ,BUFFER,LENGTH(BUFFER,TRUE)); 09152000 LAB[1]:=SEQ; L:=0; J:=1; 09153000 IF TOG THEN PT:=NEXTUNIT; 09154000 WHILE LABELSCAN(C,0) DO 09155000 BEGIN 09156000 MOVEWDS(C,1,LAB); 09157000 IF (IF FUNCSIZE=0 THEN TRUE ELSE L:= 09158000 SEARCHORD(PT,C,J,8)NEQ 0 ) THEN 09159000 BEGIN I:=I+1; FUNCSIZE:=FUNCSIZE+1; 09160000 STOREORD(PT,LAB,L+J-1); 09161000 END 09162000 END; 09163000 C[1]:=K; 09164000 C[0]:=SEQ; 09165000 FUNCSIZE:=FUNCSIZE+1; 09166000 STOREORD(PT,C,I); 09167000 IF TOG THEN STOREPSR; 09168000 EOB:=1; 09169000 END; 09170000 BOOLEAN PROCEDURE BOUND(PT); VALUE PT; INTEGER PT; 09171000 IF NOT(BOUND:=NUMERIC) THEN 09172000 IF IDENT AND FUNCSIZE GTR 0 THEN 09173000 BEGIN ARRAY L[0:1]; INTEGER K; 09174000 REAL T,U; 09175000 REAL STREAM PROCEDURE CON(A); 09176000 VALUE A; 09177000 BEGIN SI:=LOC A; DI:=LOC CON; DS:=8OCT 09178000 END; 09179000 TRANSFER(ACCUM,2,L,1,7); 09180000 IF BOUND:=SEARCHORD(PT,L,K,8)=0 THEN 09181000 BEGIN T:=ADDRESS; 09182000 U:=CON(MAX(L[1],0))/10000; %ARGS AND RESULT ARE NEG 09183000 IF SCAN AND PLUS OR MINUS THEN 09184000 BEGIN K:=(IF PLUS THEN 1 ELSE -1); 09185000 IF SCAN AND NUMERIC THEN 09186000 ACCUM[0]:=MAX(U+K|ACCUM[0],0) ELSE 09187000 BEGIN ACCUM[0]:=U; 09188000 ADDRESS:=T; 09189000 END; 09190000 END ELSE BEGIN ACCUM[0]:=U; ADDRESS:=T 09191000 END; 09192000 EOB:=0; 09193000 END 09194000 END; 09195000 09196000 09197000 PROCEDURE FINISHUP; 09198000 BEGIN COMMENT GET HIM BACK TO CALCULATOR MODE; 09198100 IF FUNCPOINTER=0 THEN % HE DELETED EVERY THING 09198200 BEGIN TRANSFER(PSR,FSTART|8,GTA,0,8); 09198210 IF SEARCHORD(VARIABLES,GTA,GT1,7)=0 THEN 09198220 BEGIN DELETE1(VARIABLES,GT1); 09198230 IF VARSIZE:=VARSIZE-1=0 THEN VARIABLES:=0; 09198240 END ELSE SPOUT(9198260); 09198260 END; 09198270 DELTOG:=CURRENTMODE:=CURLINE:=INCREMENT:=0; 09198280 STOREPSR; 09198282 END; 09198290 09199000 LABEL SHORTCUT; 09200000 REAL L,U,TADD; 09201000 STREAM PROCEDURE CLEANBUFFER(BUFFER,BUFFSIZE,ADDR); 09208000 VALUE BUFFSIZE,ADDR; 09209000 BEGIN LABEL L; LOCAL T,U,TSI,TDI; 09210000 SI:=ADDR; SI:=SI-1; L: 09211000 IF SC NEQ "]" THEN 09212000 BEGIN SI:=SI-1; GO TO L END; 09213000 SI:=SI+1; DI:=LOC T; SKIP 2 DB; DS:=2SET; 09214000 DI:=BUFFER; TDI:=DI; DI:=LOC T; TSI:=SI; 09215000 BUFFSIZE(8(IF TOGGLE THEN DS:=LIT" " ELSE 09216000 IF SC=DC THEN 09217000 BEGIN SI:=LOC U; DI:=TDI; DS:=LIT" " 09218000 END ELSE 09219000 BEGIN TSI:=SI; SI:=SI-1; DI:=LOC U; DS:=CHR; 09220000 DI:=TDI; SI:=LOC U; DS:=CHR; TDI:=DI; DI:=LOC T; 09221000 SI:=TSI 09222000 END)) 09223000 END; 09224000 PROCEDURE BUFFERCLEAN(BUFFER,BUFFSIZE,ADDR); VALUE BUFFSIZE, 09224100 ADDR; REAL ADDR; INTEGER BUFFSIZE; ARRAY BUFFER[0]; 09224200 CLEANBUFFER(BUFFER,BUFFSIZE,ADDR); 09224300 COMMENT DETERMINE WHETHER OR NOT WE CAME FROM CALCULATOR MODE; 09225000 ERR:=0; 09225100 IF BOOLEAN(SUSPENSION) THEN GO TO ENDHANDLER; 09225110 BEGIN DEFINE STARTSEGMENT=#; %/////////////////////////////// 09225115 IF GT1:=CURRENTMODE=CALCMODE THEN % TAKE CARE OF HEADER. 09225200 BEGIN ARRAY A[0:MAXHEADERARGS]; 09225300 LABEL HEADERSTORE,FORGETITFELLA; 09225310 IF FUNCTIONHEADER(A,TADD) THEN %HEADER OK 09225400 IF VARIABLES NEQ 0 THEN % MAY BE A RE-DEFINITION 09225500 BEGIN COMMENT GET THE FUNCTION NAME; 09225600 TRANSFER(A,1,GTA,0,7); 09225700 IF GT2:=SEARCHORD(VARIABLES,GTA,GT3,7)=0 THEN 09225800 COMMENT RE-DEFINING A FUNCTION. MAKE SURE NULL ; 09225900 IF GETFIELD(GTA,7,1)=FUNCTION AND 09226000 (A[1]+A[2]+A[3])=0 THEN %NULL HEADER--OK 09226100 %--------------------SET UP FOR CONTINUATION OF DEFINITION------ 09226200 BEGIN 09226300 FUNCPOINTER:=GETFIELD(GTA,FPTF,FFL); 09226400 FUNCSEQ:=GETFIELD(GTA,FSQF,FFL); 09226500 GT3:=CURLINE:=TOPLINE(FPT); 09226600 CHECKSEQ(CURLINE,GT3,INC); %SET THE INCREMENT 09226700 COMMENT THE CURRENTLINE IS SET TO THE LAST LINE OF THE 09226800 FUNCTION; 09226900 FUNCSIZE:=SIZE(FPT); 09226910 CURLINE:=CURLINE+INC; 09226920 DELTOG:=DELPRESENT(ADDRESS); 09226930 END ELSE 09227000 %------------------REDEFINING THE HEADER OF A DEFINED FUNCTION---- 09227100 GO TO FORGETITFELLA 09227200 ELSE 09227300 %--------------------NAME NOT FOUND IN THE DIRECTORY, SET UP 09227400 HEADERSTORE: 09227410 BEGIN COMMENT GET THE HEADER TO INSERT AT LINE 0; 09227500 ARRAY OLDBUFFER[0:MAXBUFFSIZE]; 09227510 INTEGER L,U,F,K,J; 09227520 INTEGER A1,A2; 09227522 COMMENT FUNCTIONHEADER RETURN AN ARRAY WITH THE 09227530 FOLLOWING VALUES: 09227534 A[0] = FUNCTION NAME , I.E., 0AAAAAAA 09227538 A[1] = 0 IF NO RESULT, 1 IF A RESULT IS RETURNED BY THE 09227542 FUNCTION. 09227546 A[2] = NUMBER OF ARGUMENTS TO THE FUNCTION. 09227550 A[3] = NUMBER OF LOCALS + RESULT +ARGUMENTS. 09227554 A[4],...A[N] ARE ALL OF THE LOCALS, RESULT, AND ARGUMENTS. 09227558 THE RESULT IS FIRST, THEN THE SECOND ARGUMENT, THEN 09227562 THE FIRST ARGUMENT, FOLLOWED BY THE LOCALS. ALL 09227566 ARE OF THE FORM 0XXXXXXX; 09227570 U:=(A1:=A[1])+(A2:=A[2])+3; 09227580 FOR L:=4 STEP 1 UNTIL U DO %LOOK FOR DUPLICATES AMONG 09227584 FOR K:=L+1 STEP 1 UNTIL U DO %THE RESULT/ARGUMENT SET 09227588 IF A[L]=A[K] THEN GO TO FORGETITFELLA; 09227592 SEQUENTIAL(FUNCSEQ:=NEXTUNIT); 09227600 SETFIELD(GTA,8,8,STORESEQ(FUNCSEQ,OLDBUFFER, 09227700 HEADER(TADD.[1:23],TADD.[24:24],OLDBUFFER))); 09227800 SETFIELD(GTA,0,8,0); 09227900 STOREORD(F:=FUNCPOINTER:=NEXTUNIT,GTA,0); 09228000 SETFIELD(GTA,0,8,0); SETFIELD(GTA,8,8,0); 09228004 FOR L:=4 STEP 1 UNTIL U DO 09228006 BEGIN GTA[0]:=A[L]; IF A1 GTR 0 THEN 09228008 BEGIN A1:=0; GTA[1]:=-1; %"RESULT" SET TO -1 09228010 STOREORD(F,GTA,0); 09228012 END ELSE %LOOKING AT THE ARGUMENTS 09228014 BEGIN K:=SEARCHORD(F,GTA,J,8); 09228016 GTA[1]:=A2-4; A2:=A2-1; GTA[0]:=A[L]; 09228018 STOREORD(F,GTA,J+K-1); 09228019 END END; 09228020 FUNCSIZE:=U:=U-2; U:=A[3]-U+L; 09228022 FOR L:=L STEP 1 UNTIL U DO %GET LOCALS INTO THE LABEL TABLE 09228024 BEGIN GTA[0]:=A[L]; 09228030 IF K:=SEARCHORD(F,GTA,J,8) NEQ 0 THEN %NOT YET IN TABLE. 09228040 BEGIN GTA[0]:=A[L]; GTA[1]:=0; 09228050 STOREORD(F,GTA,J+K-1); 09228052 FUNCSIZE:=FUNCSIZE+1 09228060 END; 09228070 END; 09228080 GTA[1]:=0&ENTIER(A[1])[CRETURN]&ENTIER(A[2])[CNUMBERARGS]; 09228100 CURLINE:=INCREMENT:=1; 09228200 DELTOG:=0; 09228202 COMMENT GET THE "TYPE" OF THE FUNCTION LATER WHEN THERE 09228210 IS A PLACE FOR IT. THE TYPE IS EITHER 1 (FUNCTION CALL), OR 09228220 0 (SUBROUTINE CALL); 09228230 END 09228300 %-------------------------------------------------------- 09228400 END ELSE % VARAIBLES=0, MAKE UP A DIRECTORY 09228500 BEGIN GT3:=0; GT2:=1; GO TO HEADERSTORE 09228600 END 09228700 ELSE % HEADER SYNTAX IS BAD 09228800 GO TO ENDHANDLER; 09228900 COMMENT WE MAKE IT TO HERE IF ALL IS WELL ABOVE; 09229000 IF GT2 NEQ 0 THEN %NAME NOT FOUND IN DIRECTORY; 09229100 BEGIN 09229200 TRANSFER(A,1,GTA,0,7); %GET FUNCTION NAME 09229300 SETFIELD(GTA,7,1,FUNCTION); 09229400 SETFIELD(GTA,FPTF,FFL,FUNCPOINTER); 09229500 SETFIELD(GTA,FSQF,FFL,FUNCSEQ); 09229600 IF VARIABLES=0 THEN 09229700 VARIABLES:=NEXTUNIT; 09229800 STOREORD(VARIABLES,GTA,GT3+GT2-1); 09229900 VARSIZE:=VARSIZE+1; 09230000 END; 09230010 CURRENTMODE:=FUNCMODE; 09230100 TRANSFER(GTA,0,PSR,FSTART|8,8); 09230200 STOREPSR; 09230300 IF SCAN THEN GO TO SHORTCUT; 09230305 IF FALSE THEN 09230310 FORGETITFELLA: ERRORMESS(ERR:=LABELERROR,TADD.[1:23],0); 09230400 END ELSE % WE ARE IN FUNCTION DEFINITION MODE 09230500 IF GT1:=MODE NEQ 0 THEN % A SPECIAL FUNCTION SUCH AS DISPLAY OR EDIT09230600 BEGIN L:=LOWER; 09230700 IF GT1=DISPLAYING THEN 09230800 LISTLINE(FPT,FSQ,L) ELSE 09230900 IF GT1=EDITING THEN 09231000 BEGIN INITBUFF(BUFFER,BUFFSIZE); 09231010 MOVE(OLDBUFFER,BUFFSIZE,BUFFER); 09231020 EDITMODE:=TRUE; ADDRESS:=ABSOLUTEADDRESS; 09231030 EDITDRIVER(FPT,FSQ,L,L) 09231100 ;IF NOT EDITMODE THEN 09231102 BEGIN MODE:=0; ERR:=30 09231104 END; 09231106 END ELSE 09231108 IF GT1=RESEQUENCING THEN 09231110 IF GT1:=L LEQ UPPER THEN 09231114 BEGIN GT2:=CONTENTS(FPT,L,GTA); 09231118 GT3:=GTA[0]:=LINENUMBER(CURLINE); 09231122 DELETE1(FPT,L); 09231124 STOREORD(FPT,GTA,L); 09231126 CURLINE:=CURLINE+INCREMENT; 09231130 GT2:=CONTENTS(FSQ,GTA[1],BUFFER); RESCANLINE; 09231134 WHILE (IF ERR NEQ 0 THEN FALSE ELSE 09231138 LABELSCAN(GTA,0)) DO 09231142 IF GT1:=SEARCHORD(FPT,GTA,GT2,8)=0 THEN 09231146 BEGIN GTA[1]:=GT3; DELETE1(FPT,GT2); 09231150 STOREORD(FPT,GTA,GT2) 09231154 END ELSE ERR:=16 09231158 END 09231162 ELSE MODE:=0; 09231166 LOWER:=L+1; 09231170 IF LOWER GTR UPPER THEN 09231200 BEGIN IF MODE=DISPLAYING THEN 09231300 FORMWD(3,"1 "); 09231400 MODE:=0; 09231500 END; 09231600 GO TO ENDHANDLER 09231700 END; 09231800 END ; %OF BLOCK STARTED ON LINE 9225115 /////////////////// 09232000 09233000 09234000 09235000 IF ERR=0 AND EOB=0 THEN 09236000 09237000 SHORTCUT: BEGIN LABEL RGTBRACK,DELOPTION; %/////////////////////// 09238000 IF DELV THEN FINISHUP ELSE 09239000 IF LFTBRACKET THEN 09240000 BEGIN 09241000 IF SCAN THEN 09242000 IF BOUND(FPT) THEN 09243000 BEGIN L:=ACCUM[0]; 09244000 IF SCAN THEN 09245000 IF QUADV OR EDITMODE:=(QUOTEQUAD) THEN 09246000 IF SCAN THEN 09247000 IF BOUND(FPT) THEN 09248000 BEGIN U:=ACCUM[0]; 09249000 RGTBRACK: 09250000 IF SCAN AND RGTBRACKET THEN 09251000 IF(IF EDITMODE THEN FALSE ELSE SCAN) THEN 09252000 IF DELV THEN 09253000 BEGIN ERR:=DISPLAY(L,U,FPT,FSQ); 09254000 DELTOG:=1; 09255000 END 09256000 ELSE ERR:=1 09257000 ELSE ERR:=DISPLAY(L,U,FPT,FSQ) 09258000 ELSE ERR:=2 09259000 END 09260000 ELSE 09261000 IF RGTBRACKET THEN 09262000 IF(IF EDITMODE THEN FALSE ELSE SCAN) THEN 09263000 IF DELV THEN 09264000 BEGIN ERR:=DISPLAY(L,L,FPT,FSQ); 09265000 DELTOG:=1; 09266000 END 09267000 ELSE ERR:=3 09268000 ELSE ERR:=DISPLAY(L,L,FPT,FSQ) 09269000 ELSE ERR:=4 09270000 ELSE ERR:=5 09271000 ELSE 09272000 IF RGTBRACKET THEN 09273000 BEGIN TADD:=ADDRESS; 09274000 IF SCAN THEN 09275000 IF IDENT AND ACCUM[0]="6DELETE" THEN 09276000 IF SCAN THEN 09277000 IF LFTBRACKET THEN 09278000 DELOPTION: 09279000 IF SCAN AND BOUND(FPT) THEN 09280000 BEGIN U:=ACCUM[0]; 09281000 IF SCAN AND RGTBRACKET THEN 09282000 IF SCAN THEN 09283000 IF DELV THEN 09284000 BEGIN ERR:=DELETE(L,U,FPT,FSQ); 09285000 FINISHUP 09286000 END 09287000 ELSE ERR:=6 09288000 ELSE ERR:=DELETE(L,U,FPT,FSQ) 09289000 ELSE ERR:=7 09290000 END 09291000 ELSE ERR:=8 09292000 ELSE 09293000 IF DELV THEN 09294000 BEGIN ERR:=DELETE(L,L,FPT,FSQ); 09295000 FINISHUP 09296000 END 09297000 ELSE ERR:=9 09298000 ELSE ERR:=DELETE(L,L,FPT,FSQ) 09299000 ELSE 09300000 IF LFTBRACKET THEN GO TO DELOPTION ELSE 09301000 BEGIN CHECKSEQ(SEQ,L,INC); 09302000 CLEANBUFFER(BUFFER,BUFFSIZE,TADD); 09303000 ADDRESS:=ABSADDR(BUFFER); ITEMCOUNT:=0; 09304000 IF SCAN THEN GO TO SHORTCUT 09305000 END 09306000 ELSE ERR:=DELETE(L,L,FPT,FSQ) 09307000 END 09308000 ELSE ERR:=10 09309000 ELSE ERR:=11 09310000 END ELSE 09311000 IF QUADV OR EDITMODE:=(QUOTEQUAD) THEN 09312000 BEGIN L:=0; U:=9999.9999; GO TO RGTBRACK 09313000 END ELSE 09314000 IF IOTA THEN 09314200 IF SCAN AND RGTBRACKET AND FPT NEQ 0 THEN 09314300 BEGIN IF SCAN THEN 09314310 IF DELV THEN DELTOG:=1 ELSE ERR:=15; 09314330 IF ERR = 0 THEN 09314340 BEGIN MODE:=RESEQUENCING; CURLINE:=INCREMENT:=1; 09314350 SETFIELD(GTA,0,8,0); 09314400 GT1:=SEARCHORD(FPT,GTA,GT2,8); 09314410 LOWER:=GT2+1; UPPER:=FUNCSIZE-1 09314420 END 09314500 END 09314600 ELSE ERR:=14 09314700 ELSE ERR:=12 09315000 ELSE ERR:=13 09316000 END 09317000 ELSE 09318000 IF CURLINE=0 THEN %CHANGING HEADER 09318100 ERR:=26 ELSE 09318110 IF ERR:=OLDLABCONFLICT(FPT,LINENUMBER(SEQ))=0 THEN 09319000 BEGIN 09320000 IF NOSYNTAX=0 THEN PROCESS(XEQUTE); 09321000 IF ERR:=STOREAWAY(FPT,FSQ,BUFFER,SEQ)=0 THEN SEQ:=SEQ+INC; 09322000 END; 09323000 IF ERR NEQ 0 THEN 09324000 BEGIN FORMWD(2,"5ERROR "); 09325000 NUMBERCON(ERR,ACCUM); ERR:=0; 09326000 EOB:=1; 09327000 FORMROW(1,1,ACCUM,2,ACCUM[0].[1:11]); 09328000 END; 09329000 END; %OF BLOCK STARTED ON LINE 9238000 ////////////////////// 09330000 ENDHANDLER: 09330100 IF BOOLEAN(SUSPENSION) THEN BEGIN 09330102 FILL ACCUM[*] WITH "ABORT SU", "SP. FNS."; 09330104 FORMROW(3,0,ACCUM,0,16); INDENT(0); TERPRINT; 09330106 END ELSE 09330108 IF MODE=0 THEN 09330110 BEGIN 09330112 IF BOOLEAN(DELTOG) THEN FINISHUP; 09330120 INDENT(-CURLINE); TERPRINT; 09330200 END; 09330210 09331000 END; 09332000 EXPOVR:=FAULTL; INTOVR:=FAULTL; INDEXF:=FAULTL; 09332100 FLAG:=FAULTL; ZERO:=FAULTL; 09332200 INITIALIZETABLE; 09333000 TRYAGAIN: 09334000 IF FALSE THEN %ENTERS WITH A FAULT. 09334100 FAULTL: 09334200 BEGIN SPOUT(09334300); %SEND A MESSAGE TO SPO 09334300 09334400 BEGIN CSTATION.APLOGGED:=0; CSTATION.APLHEADING:=0 09334500 END 09334600 END; 09334700 APLMONITOR; 09335000 ENDOFJOB: 09336000 09337000 FINIS: 09338000 WRAPUP; 09339000 09340000 END. 09341000 END;END. LAST CARD ON 0CRDING TAPE 99999999