diff --git a/Mark-XVI/SYMBOL/TSSINT.esp_m b/Mark-XVI/SYMBOL/TSSINT.esp_m index 76e81c1..64b04ba 100644 --- a/Mark-XVI/SYMBOL/TSSINT.esp_m +++ b/Mark-XVI/SYMBOL/TSSINT.esp_m @@ -1,690 +1,16145 @@ -% I N T R I N S I C S M A R K XVI.0.00 10/01/74 - COMMENT: * TITLE: B5500/B5700 MARK XVI SYSTEM RELEASE * - * FILE ID: SYMBOL/INTRINS TAPE ID: SYMBOL1/FILE000 * - * THIS MATERIAL IS PROPRIETARY TO BURROUGHS CORPORATION * - * AND IS NOT TO BE REPRODUCED, USED, OR DISCLOSED * - * EXCEPT IN ACCORDANCE WITH PROGRAM LICENSE OR UPON * - * WRITTEN AUTHORIZATION OF THE PATENT DIVISION OF * - * BURROUGHS CORPORATION, DETROIT, MICHIGAN 48232 * - * * - * COPYRIGHT (C) 1971, 1972, 1974 * - * BURROUGHS CORPORATION * - * AA320206 AA393180 AA332366 *; - BEGIN - DEFINE ETRLNG = 5#, - INTDESC(INTDESC1) = FLAG(INTDESC1 & 85[1:41:7]) #, - INTCALL(INTCALL1,INTCALL2) = P(INTCALL2 & 85[1:41:7], - INTCALL1,COC) #, - CALLINT(CALLINT1) = P(CALLINT1 & 85[1:41:7],XCH,COC) #, - COBOLDCI= @167 #, - FORTERRI= @134 #, - EXPI = @20 #, - LNI = @17 #, - DEXPI = @77 #, - DLOGI = @101 #, - CABSI = @53 #, - SINI = @14 #, - SQRTI = @13 #, - ATAN2I = @114 #, - DMODI = @65 #, - DSINI = @105 #, - DSQRTI = @123 #, - XTOII = @6 #, - CXTOII = @56 #, - COSI = @15 #, - TANI = @111 #, - ARCTANI = @16 #, - DATANI = @113 #, - ARSINI = @116 #, - GAMMAI = @126 #, - EDITIT(EDITIT1,EDITIT2,EDITIT3,EDITIT4,EDITIT5) = P(MKS, - EDITIT1,EDITIT2,EDITIT3,(-1),(EDITIT4),(EDITIT5), - @153&85[1:41:7],XCH,COC) #, - % EDITIT(BUFFADDRESS,FIELDWIDTH(W),TYPE,LOWPART,HIGHPART) - % WILL EDIT THE VALUE (LOWPART,HIGHPART) INTO A FIELD - % STARTING AT BUFFADDRESS. EDITIT RETURNS THE ENDING - % ADDRESS. THE WIDTH OF THE EDITED FIELD IS CONSTRAINED - % TO W CHARACTERS (EDITED VALUE IS RIGHT JUSTIFIED WITH - % LEADING BLANKS IF W IS LARGER THAN NEEDED) -- BUT IF - % W=0, THEN EDITIT WILL ADJUST THE FIELD WIDTH TO - % ACCOMODATE FULL NUMERICAL SIGNIFICANCE. TYPE=2 => EDITIT - % WILL CHOOSE BETWEEN REAL, INTEGER, AND DOUBLEPRECISION - % EDITING (DOUBLEPRECISION IS USED IF LOWPART!0). - % TYPE=1 => USE ONLY INTEGER, TYPE=3 => USE ONLY REAL, - % TYPE=4 => USE ONLY LOGICAL, TYPE=5 => USE ONLY DOUBLE- - % PRECISION. - CTC = 33:33:15#, - CTF = 18:33:15#, - FTC = 33:18:15#, - FTF = 18:18:15#, - CF = 33:15#, - FF = 18:15#; - REAL JUNK = 5; - NAME MEM=2, M=2, MEMORY=2 ; - REAL BLKCNTRL = 5; - DEFINE DUMPNOW(DUMPNOW1)=P(DUMPNOW1,0,48,COM,DEL,DEL)#, - TRACENOW(TRACENOW1,TRACENOW2)= - P(TRACENOW1,1,TRACENOW2 ,+ ,48,COM,DEL,DEL)#; - PROCEDURE OUTPUTINT(TEN, FILX, CHSKP, LNSKP, FI, FRMT, LISX);% %WF - VALUE CHSKP, LNSKP, FI, LISX;% %WF - NAME FILX;% %WF - ARRAY TEN[*], FRMT[*];% %WF - REAL LISX;% %WF - INTEGER CHSKP, LNSKP, FI;% %WF - FORWARD;% CODE=00200000, INTRINSIC NUMBER=@ 1 %WF - PROCEDURE INTRINSIC(DUPE, D, NUMDIM, SIZE, TYPE);% %WF - VALUE DUPE, D, NUMDIM, SIZE, TYPE;% %WF - NAME D;% %WF - ARRAY DUPE[*];% %WF - INTEGER NUMDIM, SIZE, TYPE;% %WF - FORWARD;% CODE=00400000, INTRINSIC NUMBER=@ 2 %WF - PROCEDURE INPUTINT(TEN, FILX, DKADR, ACT,% %WF - FI, FRMT, LISX, EOFL, PARL);% %WF - VALUE ACT, FI;% %WF - NAME FILX, LISX;% %WF - ARRAY TEN[*], FRMT[*];% %WF - REAL EOFL, PARL;% %WF - INTEGER DKADR, ACT, FI;% %WF - FORWARD;% CODE=00600000, INTRINSIC NUMBER=@ 3 %WF - PROCEDURE DISKSORT(T1, T2, RELA, ENDQ, BINGO, IPFIDX,% %WF - OUTPRO, INPRO, OUTF, INF, OPTOG, IPTOG, DKO, DKI,% %WF - TP1, TP2, TP3, TP4, TP5, NT, HIVALU, EQUALS,% %WF - R, ALFA, CORESIZE, DISKSIZE);% %WF - VALUE OPTOG, IPTOG, NT, HIVALU, EQUALS, R, ALFA,% %WF - CORESIZE, DISKSIZE;% %WF - NAME TP1, TP2, TP3, TP4, TP5;% %WF - REAL T1, T2, RELA, ENDQ, BINGO, IPFIDX, OUTPRO, INPRO,% %WF - OUTF, INF, DKO, DKI, NT, HIVALU, EQUALS, CORESIZE;% %WF - BOOLEAN OPTOG, IPTOG, ALFA;% %WF - INTEGER R, DISKSIZE;% %WF - FORWARD;% CODE=00700000, INTRINSIC NUMBER=@ 4 %WF - REAL PROCEDURE DUMPINT(SN, CV, BV, TIPE,% %WF - TENS, ALFA, CHAR, FIEL, FORMT);% %WF - VALUE SN, CV, BV, TIPE, TENS, ALFA, CHAR, FORMT;% %WF - NAME FIEL;% %WF - REAL SN, CV, BV, TIPE, TENS, ALFA, CHAR, FORMT;% %WF - FORWARD;% CODE=42000000, INTRINSIC NUMBER=@ 5 %WF - PROCEDURE XTOTHEIINT(BASE, EXPON, M, LOG, EXP);% %WF - VALUE BASE, EXPON, M, LOG, EXP;% %WF - REAL BASE, EXPON, M, LOG, EXP;% - FORWARD;% CODE=42254000, INTRINSIC NUMBER=@ 6 - REAL PROCEDURE ABSINT(X);% - VALUE X;% - REAL X;% - FORWARD;% CODE= INTRINSIC NUMBER=@ 7 - REAL PROCEDURE SIGNINT(X);% - VALUE X;% - REAL X;% - FORWARD;% CODE= INTRINSIC NUMBER=@10 - INTEGER PROCEDURE ENTIERINT(X);% - VALUE X;% - REAL X;% - FORWARD;% CODE= INTRINSIC NUMBER=@11 - REAL PROCEDURE TIMEINT(X);% - VALUE X;% - REAL X;% - FORWARD;% CODE= INTRINSIC NUMBER=@12 - PROCEDURE SQRTINT(X);% - VALUE X;% - REAL X;% - FORWARD;% CODE= INTRINSIC NUMBER=@13 - PROCEDURE SININT(X);% - VALUE X;% - REAL X;% - FORWARD;% CODE= INTRINSIC NUMBER=@14 - PROCEDURE COSINT(X);% - VALUE X;% - REAL X;% - FORWARD;% CODE= INTRINSIC NUMBER=@15 - REAL PROCEDURE ARCTANINT(X);% - VALUE X;% - REAL X;% - FORWARD;% CODE= INTRINSIC NUMBER=@16 - PROCEDURE LNINT(X);% - VALUE X;% - REAL X;% - FORWARD;% CODE= INTRINSIC NUMBER=@17 - REAL PROCEDURE EXPINT(X);% - VALUE X;% - REAL X;% - FORWARD;% CODE= INTRINSIC NUMBER=@20 - REAL PROCEDURE GOTOSOLVERINT(L, X, F, B);% - VALUE L, X, F, B;% - ARRAY F[*];% - REAL L, X, B;% - FORWARD;% CODE= INTRINSIC NUMBER=@21 - PROCEDURE ALGOLWRITE(TEN, FILX, CHSKP, LNSKP, FI, AEXP,% - ARRY, LINESKIP, CHANSKIP, SUPRS, NUMWDS, TANK);% - VALUE CHSKP, LNSKP, FI, AEXP, LINESKIP,% - CHANSKIP, SUPRS, NUMWDS, TANK;% - NAME FILX, TANK;% - ARRAY TEN[*], ARRY[*];% - INTEGER CHSKP, LNSKP, FI, AEXP, LINESKIP,% - CHANSKIP, SUPRS, NUMWDS;% - FORWARD;% CODE=00100100, INTRINSIC NUMBER=@22 - PROCEDURE ALGOLREAD(TEN, FILX, DKADD, ACT, FI, AEXP,% - ARRY, EOFL, PARL, DKADR, CODE, TANK);% - VALUE ACT, FI, AEXP, DKADR, CODE, TANK;% - NAME FILX, TANK;% - ARRAY TEN[*], ARRY[*];% - REAL DKADD, EOFL, PARL, DKADR, CODE;% - INTEGER ACT, FI, AEXP;% - FORWARD;% CODE=00500000, INTRINSIC NUMBER=@23 - PROCEDURE ALGOLSELECT(ACT1, ACT2, TANK, I);% - VALUE ACT1, ACT2, TANK, I;% - NAME TANK;% - INTEGER ACT1, ACT2, I;% - FORWARD;% CODE= INTRINSIC NUMBER=@24 - PROCEDURE COBOLFCR;% - FORWARD;% CODE=43000000, INTRINSIC NUMBER=@25 -PROCEDURE COBOLID;% % GO TO 02700000 - FORWARD;% CODE=43230000, INTRINSIC NUMBER=@26 - PROCEDURE POLYMERGE(T1, T2, T3, ENDQ, BINGO, IPFIDX,% - OUTPRO, INPRO, OUTF, INF, OPTOG, IPTOG, DKO, DKI,% - TP1, TP2, TP3, TP4, TP5, NT, HIVALU, EQUALS,% - R, ALFA, CORESIZE, DISKSIZE);% - VALUE OPTOG, IPTOG, NT, HIVALU, EQUALS, R, ALFA,% - CORESIZE, DISKSIZE;% - NAME TP1, TP2, TP3, TP4, TP5;% - REAL T1, T2, T3, ENDQ, BINGO, IPFIDX, OUTPRO, INPRO,% - OUTF, INF, DKO, DKI, NT, HIVALU, EQUALS, R, CORESIZE; - BOOLEAN OPTOG, IPTOG, ALFA;% - INTEGER DISKSIZE;% - FORWARD;% CODE=40140000, INTRINSIC NUMBER=@27 - PROCEDURE STATUSINT(T, C);% - VALUE T, C;% - REAL T;% - INTEGER C;% - FORWARD;% CODE= INTRINSIC NUMBER=@30 - REAL PROCEDURE MAXINT(X);% - VALUE X;% - REAL X;% - FORWARD;% CODE= INTRINSIC NUMBER=@31 - REAL PROCEDURE MININT(X);% - VALUE X;% - REAL X;% - FORWARD;% CODE= INTRINSIC NUMBER=@32 - PROCEDURE DELAYINT(ARRY, MASK, TIME);% - VALUE ARRY, MASK, TIME;% - ARRAY ARRY[*];% - REAL MASK;% - INTEGER TIME;% - FORWARD;% CODE= INTRINSIC NUMBER=@33 - PROCEDURE SUPERMOVERINT(SORCE, DEST, AEXP);% - VALUE AEXP;% - ARRAY SORCE[*], DEST[*];% - INTEGER AEXP;% - FORWARD;% CODE= INTRINSIC NUMBER=@34 - PROCEDURE SISO; FORWARD; %INT#35,SEQ#08400000 - INTEGER PROCEDURE DELTA(P1,P2);%INT#36,SEQ#00022300 - VALUE P1,P2; INTEGER P1,P2; FORWARD; - PROCEDURE ICVD; FORWARD; %INT#37,SEQ#00022500 -PROCEDURE DYNAMICDIALER(B, A, X, F); -VALUE B, A, X, F; -INTEGER B, A, X; BOOLEAN F; - FORWARD;% CODE=00022700, INTRINSIC NUMBER=@40 - PROCEDURE SCAN(UPDPDD,PRT,UPDCDD,HISCOUNT,CASECODE,CHAR); - VALUE PTR, HISCOUNT, CASECODE, CHAR; - NAME UPDPDD, UPDCDD; - INTEGER PTR, HISCOUNT, CASECODE, CHAR; - FORWARD; - PROCEDURE REPL; FORWARD; %INT#42,SEQ#08420000 - PROCEDURE COMPARE;FORWARD; %INT#43,SEQ#08430000 - PROCEDURE BASICPRINT(TYPE); - VALUE TYPE; - REAL TYPE; - FORWARD; CODE=08500000, INTRINSIC NUMBER=@44 - PROCEDURE SWAP; FORWARD; %INT#45,SEQ#00023700 - PROCEDURE BASICINPUT(TYPES); - VALUE TYPES; - REAL TYPES; - FORWARD;% CODE=08700000, INTRINSIC NUMBER=@46 - PROCEDURE READATA(TYPE); - VALUE TYPE; - REAL TYPE; - FORWARD;% CODE=08600000, INTRINSIC NUMBER=@47 - PROCEDURE FTINT ; FORWARD; % 050 - PROCEDURE FTOUT ; FORWARD; % 051 - PROCEDURE DABS ; FORWARD; % 052 - PROCEDURE CABS ; FORWARD; % 053 - PROCEDURE AINT ; FORWARD; % 054 - PROCEDURE MATH ; FORWARD; % 055 - PROCEDURE XTOI ; FORWARD; % 056 - PROCEDURE IDINT ; FORWARD; % 057 - PROCEDURE FLOAT ; FORWARD; % 060 - PROCEDURE SNGL ; FORWARD; % 061 - PROCEDURE DBLE ; FORWARD; % 062 - PROCEDURE AMOD ; FORWARD; % 063 - PROCEDURE TIME ; FORWARD; % 064 - PROCEDURE DMOD ; FORWARD; % 065 - PROCEDURE DMAX1 ; FORWARD; % 066 - PROCEDURE DMIN1 ; FORWARD; % 067 - PROCEDURE SIGNV ; FORWARD; % 070 - PROCEDURE DSIGN ; FORWARD; % 071 - PROCEDURE DIIM ; FORWARD; % 072 - PROCEDURE REALP ; FORWARD; % 073 - PROCEDURE AIMAG ; FORWARD; % 074 - PROCEDURE CMPLX ; FORWARD; % 075 - PROCEDURE CONJG ; FORWARD; % 076 - PROCEDURE DEXP ; FORWARD; % 077 - PROCEDURE CEXP ; FORWARD; % 100 - PROCEDURE DLOG ; FORWARD; % 101 - PROCEDURE CLOG ; FORWARD; % 102 - PROCEDURE ALOG10; FORWARD; % 103 - PROCEDURE DLOG10; FORWARD; % 104 - PROCEDURE DSIN ; FORWARD; % 105 - PROCEDURE CSIN ; FORWARD; % 106 - PROCEDURE DCOS ; FORWARD; % 107 - PROCEDURE CCOS ; FORWARD; % 110 - PROCEDURE TANF ; FORWARD; % 111 - PROCEDURE COTAN ; FORWARD; % 112 - PROCEDURE DATAN ; FORWARD; % 113 - PROCEDURE ATAN2 ; FORWARD; % 114 - PROCEDURE DATAN2; FORWARD; % 115 - PROCEDURE ARSIN ; FORWARD; % 116 - PROCEDURE ARCOS ; FORWARD; % 117 - PROCEDURE SINH ; FORWARD; % 120 - PROCEDURE COSH ; FORWARD; % 121 - PROCEDURE TANH ; FORWARD; % 122 - PROCEDURE DSQRT ; FORWARD; % 123 - PROCEDURE CSQRT ; FORWARD; % 124 - PROCEDURE ERF ; FORWARD; % 125 - PROCEDURE GAMMA ; FORWARD; % 126 - PROCEDURE ALGAMA; FORWARD; % 127 - PROCEDURE ANDI ; FORWARD; % 130 - PROCEDURE ORI ; FORWARD; % 131 - PROCEDURE CMPL ; FORWARD; % 132 - PROCEDURE EQUIVP; FORWARD; % 133 - PROCEDURE FORTERR;FORWARD; % 134 - PROCEDURE MAX; FORWARD; % 135 - PROCEDURE MIN; FORWARD; % 136 - PROCEDURE IMOD; FORWARD; % 137 - PROCEDURE CONCAT; FORWARD; % 140 - PROCEDURE CONCAT; - FORWARD;% CODE=08400000, INTRINSIC NUMBER=@140 - PROCEDURE MATRIXDIDDLER(A, B, C, TYPE); - VALUE A, B, C, TYPE; - ARRAY A[*], B[*], C[*]; - INTEGER TYPE; - FORWARD;% CODE=08800000, INTRINSIC NUMBER=@~4~ - PROCEDURE INVERT(A, B); - VALUE A, B; - ARRAY A[*], B[*]; - FORWARD;% CODE=09100000, INTRINSIC NUMBER=@142 - PROCEDURE TRANSPOSE(A, B); - VALUE A, B; - ARRAY A[*], B[*]; - FORWARD;% CODE=08900000, INTRINSIC NUMBER=@143 - PROCEDURE MATRIXMULTIPLY(A, B, C); - VALUE A, B, C; - ARRAY A[*], B[*], C[*]; - FOWARD;% CODE=09000000, INTRINSIC NUMBER=@144 - PROCEDURE RANDOM(NUMBER, BASE); - VALUE NUMBER; - REAL NUMBER; - INTEGER BASE; - FORWARD;% CODE=00022900, INTRINSIC NUMBER=@145 - PROCEDURE FORTRANFREEREAD; - FORWARD;% CODE=09200000, INTRINSIC NUMBER=@146 - PROCEDURE BASICLOSE(FILX); - VALUE FILX; NAME FILX; - BEGIN REAL SELECT=14, ALGOLWRITE=12; ARRAY AIT=6[*]; - REAL T,I; ARRAY FIB[*]; NAME M=2; - SUBROUTINE MAYBEPRINT; - BEGIN FIB:=FILX[NOT 2]; - IF FIB[5].[41:3]=0 THEN %NOT CLOSED-NOT INPUT - IF FIB[4].[8:4] NEQ 10 THEN %NOT DATA COM - IF FIB[20].[3:15]!0 THEN % DATA LEFT - P(MKS,1,0,0,(FIB[20].[18:10]+1),FILX,ALGOLWRITE); - END; - IF P(.FILX,LOD)=0 THEN %EOJ FILE CLOSE - BEGIN I:=AIT[0]+1; WHILE (T:=AIT[I:=I-1]).[8:10] NEQ 0 - DO IF T.[1:1] THEN - BEGIN FILX:=M[M[T.[18:15]] INX 4]; MAYBEPRINT END; - END ELSE %FILE RESTORE - BEGIN MAYBEPRINT; - P(MKS,2,0,[FILX[NOT 2]],4,SELECT); - FIB[0]:=FIB[8]:=FIB[20]:=FIB[21]:=0; - END; - END BASIC FILE RESTORE; -PROCEDURE FILEATTRIBUTES(T,E,D,V,G,I,TN); VALUE T,I,V,D,G; REAL D,G,I,E; -INTEGER V; ARRAY TN[*]; NAME T; FORWARD; % CODE @ 0043000, INT # @150 -PROCEDURE COBOLDECIMALTOOCTALCONVERT(A); % INT #=@151, CODE=09300000 -VALUE A; NAME A; FORWARD ; -PROCEDURE COBOLOCTOLTODECIMALCONVERT(A,L,H,R,N,S,T); % INT #=@152 -VALUE L,H,R,N,S,T; REAL L,H,R,N,S,T; NAME A; FORWARD; % CODE=09400000 -PROCEDURE FORTRANFREEWRITE(F,D,R,W,L,I,N,S); VALUE I,D,R,W,L; INTEGER R, -W; REAL I,D,L; NAME F; ARRAY S[*],N[*]; FORWARD ;%COD @02976019.INT@153 -PROCEDURE FINNAME; FORWARD; -PROCEDURE FOUTNAME; FORWARD; -PROCEDURE FTINTFIX(F1,D2,F2,F3,L1,E1,E2,P1); VALUE D1,F2,L1,E1,E2,P1 ; -REAL D1,F2,L1,E1,E2,P1; ARRAY F3[*]; NAME F1; FORWARD; % INTRINSIC @156 -PROCEDURE FTOUTFIX(F,D,R,Q,L,E,EL,PL); VALUE D,R,L,E,EL,PL; REAL D,R,L,E -,EL,PL; NAME F; ARRAY Q[*]; FORWARD ; % CODE AT SEQ # 02886040, INT@157 -PROCEDURE FBINBACKBLOCK(F1,D,F2,F3,L,E1,E2,P1); VALUE D,F2,L,E1,E2,P1 ; -REAL D,F2,L,E1,E2,P1; ARRAY F3[*]; NAME F1; FORWARD; % INT # @160. -PROCEDURE COBOLVARSZ; FORWARD;% CODE=09500000 INT #=@161 -PROCEDURE COBOLIONONDSK; FORWARD;% CODE=096000000 INT #=@162 -PROCEDURE COBOLIODSK; FORWARD;% CODE=09700000 INT #=@163 -PROCEDURE FORTRANMEMHANDLER(A,H);VALUE H;REAL H;ARRAY A[*];FORWARD;%164 -PROCEDURE COBOLATT; FORWARD; % CODE = 02650000 INT # = @165 %CJC 103I -PROCEDURE INTERRUPTER; FORWARD; % CODE=09800000; INT #=@166 -PROCEDURE COBOLDC; FORWARD; % CODE = 02690000 INT #=@167 -INTEGER PROCEDURE DELTA(P1,P2); VALUE P1,P2; REAL P1,P2; %@036 -BEGIN - DEFINE - DOT=[18:13]#, AMPER=[18:35:13]#; - COMMENT @4000000=2|20, WHICH IS 1 LARGER THAN ANY 6500 COUNT.; - COMMENT DELTA=2|20 IF DESC(P1)!DESC(P2) OR CSIZE-S ARE !; - IF (P2-P1).[31:17]!0 THEN DELTA~@4000000 ELSE - DELTA~P2.DOT-P1.DOT; -END DELTA; - -PROCEDURE ICVD; %37 -BEGIN - DEFINE DOT=[18:13]#, AMPER=[18:35:13]#, CSIZE=[31:02]#,SIX=0#; - ARRAY STRING[*]; - NAME M = 2; - REAL PTR=-3; INTEGER N=-1; - IF PTR.CSIZE!SIX THEN POLISH(M&1[17:47:01],9999,CDC,DEL); - STRING ~ M[PTR]; - N~N; COMMENT MAKE SURE N IS INTEGERIZED; - IF N>8 THEN POLISH(M&1[14:47:01],N,CDC,DEL); - POLISH([STRING[(PTR.DOT+N-1).[35:10]]], DEL); - STREAM(RESULT~0:S~[STRING[PTR.[18:10]]], N, - SKS~PTR.[28:03]); - BEGIN - DI ~ LOC RESULT; - SI ~ S; SI ~ SI+SKS - DS ~ N OCT; - END; - PTR ~ P; -END ICVD; -PROCEDURE DYNAMICDIALER(A,B,X,F) ; -VALUE B, A, X, F; -INTEGER B, A, X; BOOLEAN F; - BEGIN % A,B,X,Y,Z ARE AS IN Y&Z[A:B:X]. - % F=TRUE => X WAS LITERAL, AND TRB WILL BE DONE AFTER XITING. - REAL Y=-7, Z=-6, C=+1 ; - DEFINE Q= @3403007777777777 #, % MASK FOR ZERO-ING OUT THE G,H,K&V- - % REGISTER PARTS OF THE ROW. - R= @0055005500610065 #, % NOP,DIA,DIB,TRB. - S= @0055703404210435 #; % NOP,LITC Y,STD,XIT. - IF (A~A)<1 OR (B~B)<1 OR (X~X)<1 OR X+A>48 OR X+B>48 - THEN P((-63),26,COM) ; - IF F THEN P(Q,AND,0&(B MOD 6)[4:9:3],A MOD 6,DIB 7,TRB 3, - P&(B DIV 6)[12:45:3],A DIV 6,DIB 15,TRB 3,OR,0,0,XIT) ; - GO P(P(R)&(B DIV 6)[12:45:3],A DIV 6,DIB 24,TRB 3,P&(B MOD 6) - [15:9:3],A MOD 6,DIB 27,TRB 3,P&X[36:42:6],.A,~,S,.B,~,Y,Z,[A]); -END DYNAMICDIALER; - - -PROCEDURE RANDOM(NUMBER, BASE); - VALUE NUMBER; - REAL NUMBER; - INTEGER BASE; - BEGIN INTEGER N; - REAL T; - IF (T := NUMBER MOD 1.0)>0 THEN - BEGIN BASE := T.[9:38]; P(RTN); END; - IF NUMBER!0 THEN - BEGIN T := POLISH(1, 1, COM); - N := 0 & T[10:36:6] & T[16:42:6] & T[22:30:6] - & ((T.[30:18])|P(DUP))[28:22:20]; - END ELSE IF (N := BASE)=0 THEN N := @2631353020000; - T := 3 & (N.[10:26]|6137 + 2197513)[10:12:36]; - POLISH((((BASE := T) OR 0.5) - 0.5) + P(DUP), RTN); -END RANDOM; - - -PROCEDURE SWAP; % 045 -BEGIN - ARRAY A = -2 [*,*], B = -1 [*,*]; - STREAM(A, B, CA~0, CB~0, FA~A.[18:15], FB~B.[18:15]); - BEGIN - SI ~ A; CA ~ SI; - SI ~ B; CB ~ SI; - DI ~ LOC B; DI ~ DI+5; SKIP 3 DB; - SI ~ LOC CA; SI ~ SI+5; SKIP 3 SB; - 3(IF SB THEN DS ~ SET ELSE DS ~ RESET; SKIP SB); DS ~ 2 CHR; - DI ~ DB; SI ~ LOC B; DS ~ WDS; - DI ~ LOC A; DI ~ DI+5; SKIP 3 DB; - SI ~ LOC CB; SI ~ SI+5; SKIP 2 SB; - 3(IF SB THEN DS ~ SET ELSE DS ~ RESET; SKIP SB); DS ~ 2 CHR; - DI ~ FA; SI ~ LOC A; DS ~ WDS; - END; -END SWAP; - - - - -COMMENT ALGOL WRITE INTRINSIC;% -PROCEDURE ALGOLWRITE(TEN, FILX, CHSKP, LNSKP, FI, AEXP, - ARRY, LINESKIP, CHANSKIP, SUPRS, NUMWDS, TANK); - VALUE LINESKIP, CHANSKIP, SUPRS, NUMWDS, TANK, - CHSKP, LNSKP, FI, ARRY; - INTEGER CHSKP, LNSKP, FI, AEXP, - LINESKIP, CHANSKIP, NUMWDS, SUPRS; - NAME FILX, TANK; - ARRAY ARRY[*], TEN[*]; -BEGIN REAL SELECT=14,REED=13,ADDRESS;% - NAME MEM=2;% - LABEL AB,ACTION; - LABEL DS,WINDUP1; - ARRAY FPB=3[*],FIB[*],HEADER[*];% - INTEGER I,RSIZE;% - INTEGER SPOUT; - ARRAY TINK=TANK[*]; - REAL CHNSKP=CHANSKIP; - REAL ALGOLWRITE=12; - DEFINE FNUM = FIB[4].[11:31] #; - $ SET OMIT = NOT(TIMESHARING) -SUBROUTINE WAIT; POLISH(TANK, @2000000000, 36, COM, DEL DEL); - $ POP OMIT - $ SET OMIT = TIMESHARING - LABEL ERR,LP1,MT1,CLOSED,DK1,SP1,CP1,DC1,PP1;% - LABEL DCN1,DCN2,SPIN; - $ SET OMIT = NOT SHAREDISK - SWITCH SW1~ ERR,LP1,MT1,CLOSED,DK1,SP1,CP1,LP1,PP1,ERR,DC1, - ERR,LP1,DCN1; - LABEL LP2,MT2,DK2,SP2,CP2,DC2,PP2;% - SWITCH SW2~ ERR,LP2,MT2,ERR,DK2,SP2,CP2,LP2,PP2,ERR,DC2,ERR, - LP2,DCN2; - LABEL DS1,DR1,DU1;% - SWITCH DSW1~DS1,DR1,DU1,CLOSED; - LABEL UT,PBIT,DWT,D19,RELEASE,STA,EXIT,L1,WINDUP,DBIT;% - LABEL TYPEU,TYPEA,TYPEC;% - SWITCH TYPE~TYPEU,TYPEA,ERR,TYPEC;% - LABEL DS2,DR2,DU2;% - SWITCH DSW2~DS2,DR2,DU2;% - SUBROUTINE BLOCK;% - BEGIN GO TO TYPE[I~FIB[5].[46:2]];% -TYPEC: STREAM(D1~IOD,S~(NUMWDS~NUMWDS+1)|8,% - D2~(TANK[0]~NUMWDS INX IOD));% - BEGIN SI~LOC S; DI~DI-8; DS~4 DEC; DI~D1;% - SI~D2; SI~SI-8; DI~DI-4; DS~4 CHR;% - END;% - IF (FIB[17]~FIB[17]-NUMWDS)>RSIZE+1 THEN BEGIN% -OWT: FIB[7]~FIB[7]+1; P(XIT);% -TYPEA: IF (FIB[17]~FIB[17]-RSIZE)}RSIZE THEN% - BEGIN TANK[0]~RSIZE INX IOD; GO OWT END END;% - NUMWDS~FIB[18].[18:5]-FIB[17]+(I=3);% -TYPEU: END BLOCK;% - REAL SUBROUTINE DISKADDRESS;% - BEGIN% - ADDRESS~(CHANSKIP DIV HEADER[0].[30:12])|HEADER[0].[42:6];% - IF (SUPRS~ADDRESS DIV HEADER[1]+10)}30 THEN - BEGIN P(0); GO TO EXIT END; - IF HEADER[SUPRS]=0 THEN - IF HEADER[9]>(SUPRS-10) THEN% - P(FPB[FNUM+3],FPB[FNUM],FPB[FNUM+1],SUPRS,HEADER, - 4,11,COM,DEL,DEL,DEL,DEL,DEL,DEL) ELSE - BEGIN P(0); GO TO EXIT END;% - ADDRESS~HEADER[SUPRS]+SUPRS+ADDRESS MOD HEADER[1];% - STREAM(D~[ADDRESS]); BEGIN SI~D; DS~8 DEC END; P(1);% - EXIT: DISKADDRESS~P;% - END DISKADDRESS;% - IF TINK=0 THEN %WF - BEGIN FIB ~ FILX[NOT 2]; %WF - IF FIB[5].[11:2]<2 THEN P(MKS,"WRITING",FILX,7,SELECT) ; - IF FIB[5].[43:1] THEN - P(MKS, CHSKP, 0, FILX, 1, SELECT); - IF LNSKP>1 AND ARRY{0 AND (I~FIB[4].[8:4])!1 - $ SET OMIT = NOT(TIMESHARING) - AND I!7 AND I!12 AND I!10 THEN - $ SET OMIT = TIMESHARING - P(XIT);%CARRIAGE CONTROL ON NON-PRINTER FILE - - - RSIZE ~ P(MKS, LNSKP, CHSKP, SUPRS, %WF - (-1), FILX, ALGOLWRITE); %WF - IF ARRY{0 THEN SUPRS ~ 1 ELSE %WF - BEGIN % 11/24/72 - CORRECTED 10/3/73 - IF ARRY.[8:10]=P(DUP,0) THEN % INDEXED WRITE - P(DEL,AEXP) % WRITE MIN(AEXP,RSIZE) WORDS - ELSE % WRITE MIN(ARRY, SIZE,AEXP,RSIZE) WORDS - IF P GTR P(DUP,AEXP) % - THEN P(DEL,AEXP); %WF - IF P(DUP)}RSIZE THEN P(DEL) ELSE RSIZE ~ P; %WF - STREAM(P4 ~ [ARRY[0]], P3 ~ RSIZE, %WF - P2 ~ P(DUP).[36:6], P1 ~ *FILX); %WF - END; %WF - END; %WF - IF RSIZE>0 THEN P(MKS, LNSKP, %WF - CHSKP, SUPRS, RSIZE, FILX, ALGOLWRITE); %WF - FILX[NOT 4] ~ FILX[NOT 3] ~ 0; %WF - P(XIT); %WF - END; %WF - FIB~TANK[NOT 2];% -UT: I~FIB[4].[8:4]; RSIZE~FIB[18].[33:15];% - SPOUT:=(I=5); - $ SET OMIT = TIMESHARING - IF CHNSKP.[4:1] THEN - BEGIN CHNSKP.[4:1]~0; - $ SET OMIT = NOT SHAREDISK - END; - IF NUMWDS<0 THEN GO TO SW1[I]; GO TO SW2[I];% - LP1: MT1: SP1: CP1: PP1: -% -D19: IF IOD.[19:1] THEN% -PBIT: IF IOD.[2:1] THEN P(RSIZE,RTN) ELSE% - IF IOD.[25:1] THEN% -CLOSED: BEGIN - FIB[13].[27:1]~0; - IF (I~(FPB[FNUM+3] AND 31)!10 AND I!12 - AND I!13 AND I!26 THEN FIB[5].[45:1]~0 ELSE - FIB[5].[45:1]~P(TANK[NOT 3],DUP)!0 AND P(XCH)!15; - P(TANK,0,11,COM,DEL,DEL) ; - IF NOT FIB[5].[45:1] THEN GO UT ; - P(TANK[NOT 3]); TANK[NOT 3]~TANK[NOT 4]~0 ; - P(MKS,9,BLKCNTRL,DEL) ;% TAKE PARITY ACTION LBL BRNCH. - P(1); GO TO DS; - END ELSE - IF IOD.[27:1] AND (I=2 OR I=7 OR I=8) THEN% - BEGIN IF NOT FIB[4].[2:1] THEN% - BEGIN HEADER~TANK[NOT 1];HEADER[4].[42:6]~1 END; - IF I=7 THEN FIB[9].[1:1]~1; % MULTI-REEL PBT FILE - I~FIB[13].[28:10]+1;% - P(MKS,6,0,(NOT 2) INX TANK,4,SELECT);% - FIB[13].[28:10]~I; GO TO CLOSED;% - END ELSE% - BEGIN -ERR: P(3); -DS: P(TANK,XCH,11,COM); - END; - WAIT; GO TO PBIT;% -DK1: HEADER~*[FIB[14]]; GO TO DSW1[FIB[4].[27:3]];% -DK2: HEADER~*[FIB[14]]; GO TO DSW2[FIB[4].[27:3]];% -CP2: BLOCK; TANK[0]~FLAG(FIB[16])&CHANSKIP[32:47:1]; GO TO RELEASE;% -LP2: IF SUPRS THEN STREAM(RSIZE,D~IOD); BEGIN RSIZE(DS~8 LIT " ") END; - CHANSKIP~CHANSKIP+LINESKIP.[45:1]; - IF CHANSKIP!0 THEN% - BEGIN IF (I~FIB[17]-RSIZE)>0 THEN% - STREAM(I,D~RSIZE INX IOD); BEGIN I(DS~8 LIT " ") END;% - END ELSE BLOCK;% - TANK[0]~FLAG(FIB[16])&LINESKIP[27:47:1]&LINESKIP[28:46:1]% - &CHANSKIP[29:44:4]&NUMWDS[8:38:10];% - GO TO RELEASE;% -SP2: PP2:% -MT2: BLOCK;% - P(TANK[0]~FLAG(FIB[16])&NUMWDS[8:38:10],NUMWDS,XCH,INX,% - @3700000000000000,XCH,~);% - IF SPOUT THEN % SPO OUTPUT - IF FPB[FNUM+3].[42:6]=43 THEN P(XIT) ELSE %DUMMY - P(0,0,NOT,IOD,INX,15,COM,XIT) - ELSE -RELEASE: P(FLAG(FIB[19])&IOD[3:3:5],TANK,PRL,DEL);% -WINDUP: I~FIB[19].[33:15]-FIB[16].[33:15];% - FIB[16].[33:15]~SUPRS~MEM[P(DUP) INX NOT 1].[18:15];% - FIB[19].[33:15]~SUPRS+I;% - WINDUP1: - FIB[6]~FIB[6]+1; FIB[7]~FIB[7]+1; FIB[17]~FIB[18].[18:15];% - P(XIT);% -DU1:% -DS1: IF LINESKIP!0 THEN% - BEGIN IF IOD.[27:1] AND IOD.[19:1] THEN GO AB; - IF FIB[17]=FIB[18].[18:15] THEN - BEGIN CHANSKIP~FIB[7];% -L1: IF DISKADDRESS THEN% - IF IOD.[19:1] THEN DBIT: IF IOD.[2:1] THEN% - BEGIN - $ SET OMIT = NOT SHAREDISK - MEM[FIB[16]]~ADDRESS; - P(RSIZE,RTN); - END ELSE - IF IOD.[25:1] THEN GO TO CLOSED ELSE - $ SET OMIT = NOT SHAREDISK - BEGIN - $ SET OMIT = NOT SHAREDISK - GO TO AB; - END ELSE - BEGIN WAIT; GO TO DBIT; END ELSE - BEGIN - $ SET OMIT = NOT SHAREDISK - GO TO AB; - END; - END; P(RSIZE,RTN);% - END;% - P(MKS,CHANSKIP,4,TANK,1,SELECT); GO TO L1; -DS2: IF FIB[7]>HEADER[7] THEN HEADER[7]~FIB[7];% - BLOCK; TANK[0]~FLAG(FIB[16]); GO RELEASE;% -DR1: IF LINESKIP!0 THEN CHANSKIP~FIB[7] ELSE FIB[7]~CHANSKIP;% - IF HEADER[7]HEADER[7] THEN HEADER[7]~FIB[7];% - BLOCK;% - CHANSKIP~FIB[7]+FIB[13].[10:9]|HEADER[0].[30:12];% - IF DISKADDRESS THEN% - BEGIN P(TANK[0]~FLAG(FIB[16])&0[24:24:1],(NOT 0),XCH,INX,% - ADDRESS,XCH,~);% - P(FLAG(FIB[19])&1[24:47:1],TANK,PRL,DEL);% - END ELSE% - BEGIN TANK[0]~FLAG(FIB[16])&0[24:24:1];% - P(FLAG(FIB[19]&1[24:44:4],TANK,PRL,DEL);% - END;% - GO TO WINDUP;% - $ SET OMIT = NOT(TIMESHARING) - DC1:: P(RSIZE, RTN); - $ SET OMIT = TIMESHARING - AB:: BEGIN IF(ADDRESS~TANK[NOT 4])=0 THEN GO ERR; - ACTION:: TANK[NOT 3]~TANK[NOT 4] ~0; - TANK[0] := IOD OR MEM; - P(ADDRESS,MKS,9,JUNK); GO TO ERR; - \ No newline at end of file +% I N T R I N S I C S M A R K XVI 0 00 10/01/74 00000000 + COMMENT: * TITLE: B5500/B5700 MARK XVI SYSTEM RELEASE * 00000010 + * FILE ID: SYMBOL/INTRINS TAPE ID: SYMBOL1/FILE000 * 00000011 + * THIS MATERIAL IS PROPRIETARY TO BURROUGHS CORPORATION * 00000012 + * AND IS NOT TO BE REPRODUCED, USED OR DISCLOSED * 00000013 + * EXCEPT IN ACCORDANCE WITH PROGRAM LICENSE OR UPON * 00000014 + * WRITTEN AUTHORIZATION OF THE PATENT DIVISION OF * 00000015 + * BURROUGHS CORPORATION, DETROIT, MICHIGAN 48232 * 00000016 + * * 00000017 + * COPYRIGHT (C) 1971, 1972, 1974 * 00000018 + * BURROUGHS CORPORATION * 00000019 + * AA320206 AA393180 AA332366 *; 00000021 + BEGIN 00000100 + DEFINE ETRLNG = 5#, 00000200 + INTDESC(INTDESC1) = FLAG(INTDESC1 & 85[1:41:7]) #, 00000210 + INTCALL(INTCALL1,INTCALL2) = P(INTCALL2 & 85[1:41:7], 00000215 + INTCALL1,COC) #, 00000216 + CALLINT(CALLINT1) = P(CALLINT1 & 85[1:41:7],XCH,COC) #, 00000218 + COBOLDCI= @167 #, 00000219 + FORTERRI= @134 #, 00000220 + EXPI = @20 #, 00000221 + LNI = @17 #, 00000222 + DEXPI = @77 #, 00000223 + DLOGI = @101 #, 00000224 + CABSI = @53 #, 00000225 + SINI = @14 #, 00000226 + SQRTI = @13 #, 00000227 + ATAN2I = @114 #, 00000228 + DMODI = @65 #, 00000229 + DSINI = @105 #, 00000230 + DSQRTI = @123 #, 00000231 + XTOII = @6 #, 00000232 + CXTOII = @56 #, 00000233 + COSI = @15 #, 00000234 + TANI = @111 #, 00000235 + ARCTANI = @16 #, 00000236 + DATANI = @113 #, 00000237 + ARSINI = @116 #, 00000238 + GAMMAI = @126 #, 00000239 + EDITIT(EDITIT1,EDITIT2,EDITIT3,EDITIT4,EDITIT5) = P(MKS, 00000240 + EDITIT1,EDITIT2,EDITIT3,(-1),(EDITIT4),(EDITIT5),00000241 + @153&85[1:41:7],XCH,COC) #, 00000242 + % EDITIT(BUFFADDRESS,FIELDWIDTH(W).TYPE LOWPART HIGHPART) 00000243 + % WILL EDIT THE VALUE (LOWPART,HIGHPART) INTO A.FIELD 00000244 + % STARTING AT BUFFADDRESS EDITIT RETURNS THE ENDING 00000245 + % ADDRESS. THE WIDTH OF THE EDITED FIELD IS CONSTRAINED 00000246 + % TO W CHARACTERS (EDITED VALUE IS RIGHT JUSTIFIED WITH 00000247 + % LEADING BLANKS IF W IS LARGER THAN NEEDED) -- BUT IF 00000248 + % W=0, THEN EDITIT WILL ADJUST THE FIELD WIDTH TO 00000249 + % ACCOMODATE FULL NUMERICAL SIGNIFICANCE. TYPE=2 => EDITIT00000250 + % WILL CHOOSE BETWEEN REAL, INTEGER, AND DOUBLEPRECISION 00000251 + % EDITING (DOUBLEPRECISION IS USED IF LOWPART!0). 00000252 + % TYPE=1 => USE ONLY INTEGER, TYPE=3 => USE ONLY REAL, 00000253 + % TYPE=4 => USE ONLY LOGICAL, TYPE=5 => USE ONLY DOUBLE- 00000254 + % PRECISION. 00000255 + CTC = 33:33:15#, 00000300 + CTF = 18:33:15#, 00000400 + FTC = 33:18:15#, 00000410 + FTF = 18:18:15#, 00000420 + CF = 33:15#, 00000500 + FF = 18:15#; 00000600 + REAL JUNK = 5; 00000700 + NAME MEM=2, M=2, MEMORY=2 ; 00000710 + REAL BLKCNTRL = 5; 00000750 + DEFINE DUMPNOW(DUMPNOW1)=P(DUMPNOW1,0,48,COM,DEL,DEL)#, 00000775 + TRACENOW(TRACENOW1,TRACENOW2)= 00000780 + P(TRACENOW1,1,TRACENOW2 ,+ ,48,COM,DEL,DEL)#; 00000785 + PROCEDURE OUTPUTINT(TEN, FILX, CHSKP, LNSKP, FI, FRMT, LISX);% %WF 00000800 + VALUE CHSKP, LNSKP, FI, LISX;% %WF 00000900 + NAME FILX;% %WF 00001000 + ARRAY TEN[*], FRMT[*];% %WF 00001100 + REAL LISX;% %WF 00001200 + INTEGER CHSKP, LNSKP, FI;% %WF 00001300 + FORWARD;% CODE=B@@@0BB0, INTRINSIC NUMBER=@ 1 %WF 00001400 + PROCEDURE INTRINSIC(DUPE, D, NUMDIM, SIZE, TYPE);% %WF 00001500 + VALUE DUPE, D, NUMDIM, SIZE, TYPE;% %WF 00001600 + NAME D;% %WF 00001700 + ARRAY DUPE[*];% %WF 00001800 + INTEGER NUMDIM, SIZE, TYPE;% %WF 00001900 + FORWARD;% CODE=32000Q00, INTRINSIC NUMBER=@ 2 %WF 00002000 + PROCEDURE INPUTINT(TEN, FILX, DKADR, ACT,% %WF 00002100 + FI, FRMT, LISX, EOFL, PARL);% %WF 00002200 + VALUE ACT, FI;% %WF 00002300 + NAME FILX, LISX;% %WF 00002400 + ARRAY TEN[*], FRMT[*];% %WF 00002500 + REAL EOFL, PARL;% %WF 00002600 + INTEGER DKADR, ACT, FI;% %WF 00002700 + FORWARD;% CODE=S60G0000, INTRINSIC NUMBER=@ 3 %WF 00002800 + PROCEDURE DISKSORT(T1, T2, RELA, ENDQ, BINGO, IPFIDX,% %WF 00002900 + OUTPRO, INPRO, OUTF, INF, OPTOG, IPTOG, DKO, DKI,% %WF 00003000 + TP1, TP2, TP3, TP4, TP5, NT, HIVALU, EQUALS,% %WF 00003100 + R, ALFA, CORESIZE, DISKSIZE);% %WF 00003200 + VALUE OPTOG, IPTOG, NT, HIVALU, EQUALS, R, ALFA,% %WF 00003300 + CORESIZE, DISKSIZE;% %WF 00003400 + NAME TP1, TP2, TP3, TP4, TP5;% %WF 00003500 + REAL T1, T2, RELA, ENDQ, BINGO, IPFIDX, OUTPRO, INPRO,% %WF 00003600 + OUTF, INF, DKO, DKI, NT, HIVALU, EQUALS, CORESIZE;% %WF 00003700 + BOOLEAN OPTOG, IPTOG, ALFA;% %WF 00003800 + INTEGER R, DISKSIZE;% %WF 00003900 + FORWARD;% CODE=39400000, INTRINSIC NUMBER=@ 4 %WF 00004000 + REAL PROCEDURE DUMPINT(SN, CV, BV, TIPE,% $WF 00004100 + TENS, ALFA, CHAR, FIEL, FORMT);% %WF 00004200 + VALUE SN, CV, BV, TIPE, TENS, ALFA, CHAR, FORMT;% %WF 00004300 + NAME FIEL;% %WF 00004400 + REAL SN, CV, BV, TIPE, TENS, ALFA, CHAR, FORMT;% %WF 00004500 + FORWARD;% CODE=42000000, INTRINSIC NUMBER=@ 5 %WF 00004600 + PROCEDURE XTOTHEIINT(BASE, EXPON, M, LOG, EXP);% %WF 00004700 + VALUE BASE, EXPON, M, LOG, EXP;% %WF 00004800 + REAL BASE, EXPON, M, LOG, EXP;% %WF 00004900 + FORWARD;% CODE=42254000, INTRINSIC NUMBER=@ 6 %WF 00005000 + REAL PROCEDURE ABSINT(X);% %WF 00005100 + VALUE X;% %WF 00005200 + REAL X;% %WF 00005300 + FORWARD;% CODE= INTRINSIC NUMBER=@ 7 %WF 00005400 + REAL PROCEDURE SIGNINT(X);% %WF 00005500 + VALUE X;% %WF 00005600 + REAL X;% %WF 00005700 + FORWARD;% CODE= INTRINSIC NUMBER=@10 %WF 00005800 + INTEGER PROCEDURE ENTIERINT(X);% %WF 00005900 + VALUE X;% %WF 00006000 + REAL X;% %WF 00006100 + FORWARD;% CODE= INTRINSIC NUMBER=@11 %WF 00006200 + REAL PROCEDURE TIMEINT(X);% %WF 00006300 + VALUE X;% %WF 00006400 + REAL X;% %WF 00006500 + FORWARD;% CODE= INTRINSIC NUMBER=@12 %WF 00006600 + PROCEDURE SQRTINT(X);% %WF 00006700 + VALUE X;% %WF 00006800 + REAL X;% %WF 00006900 + FORWARD;% CODE= INTRINSIC NUMBER=@13 %WF 00007000 + PROCEDURE SININT(X);% %WF 00007100 + VALUE X;% %WF 00007200 + REAL X;% %WF 00007300 + FORWARD;% CODE= INTRINSIC NUMBER=@14 %WF 00007400 + PROCEDURE COSINT(X);% %WF 00007500 + VALUE X;% %WF 00007600 + REAL X;% %WF 00007700 + FORWARD;% CODE= INTRINSIC NUMBER=@15 %WF 00007800 + REAL PROCEDURE ARCTANINT(X);% %WF 00007900 + VALUE X;% %WF 00008000 + REAL X;% %WF 00008100 + FORWARD;% CODE= INTRINSIC NUMBER=@16 %WF 00008200 + PROCEDURE LNINT(X);% %WF 00008300 + VALUE X;% %WF 00008400 + REAL X;% %WF 00008500 + FORWARD;% CODE= INTRINSIC NUMBER=@17 %WF 00008600 + REAL PROCEDURE EXPINT(X);% %WF 00008700 + VALUE X;% %WF 00008800 + REAL X;% %WF 00008900 + FORWARD;% CODE= INTRINSIC NUMBER=@20 %WF 00009000 + REAL PROCEDURE GOTOSOLVERINT(L, X, F, B);% %WF 00009100 + VALUE L, X, F, B;% %WF 00009200 + ARRAY F[*];% %WF 00009300 + REAL L, X, B;% %WF 00009400 + FORWARD;% CODE= INTRINSIC NUMBER=@21 %WF 00009500 + PROCEDURE ALGOLWRITE(TEN, FILX, CHSKP, LNSKP, FI, AEXP,% %WF 00009600 + ARRY, LINESKIP, CHANSKIP, SUPRS, NUMWDS, TANK);% %WF 00009700 + VALUE CHSKP, LNSKP, FI, AEXP, LINESKIP,% %WF 00009800 + CHANSKIP, SUPRS, NUMWDS, TANK;% %WF 00009900 + NAME FILX, TANK;% %WF 00010000 + ARRAY TEN[*], ARRY[*];% %WF 00010100 + INTEGER CHSKP, LNSKP, FI, AEXP, LINESKIP,% %WF 00010200 + CHANSKIP, SUPRS, NUMWDS;%:">(}8 THEN POLISH(M&1[14:47:01],N,CDC,DEL); 00022580 + POLISH([STRING[(PTR.DOT+N-1).[35:10]]], DEL); 00022590 + STREAM(RESULT~0:S~[STRING[PTR.[18:10]]], N, 00022600 + SKS~PTR.[28:03]); 00022610 + BEGIN 00022620 + DI ~ LOC RESULT; 00022630 + SI ~ S; SI ~ SI+SKS; 00022640 + DS ~ N OCT; 00022650 + END; 00022660 + PTR ~ P; 00022670 +END ICVD; 00022680 +PROCEDURE DYNAMICDIALER(A,B,X,F) ; 00022700 +VALUE B, A, X, F; 00022705 +INTEGER B, A, X; BOOLEAN F; 00022710 + BEGIN % A,B,X,Y,Z ARE AS IN Y&Z[A:B:X]. 00022715 + % F=TRUE => X WAS LITERAL, AND TRB WILL BE DONE AFTER XITING.00022720 + REAL Y=-7, Z=-6, C=+1 ; 00022725 + DEFINE Q= @3403007777777777 #, % MASK FOR ZERO-ING OUT THE G,H,K&V- 00022730 + % REGISTER PARTS OF THE RCW. 00022735 + R= @0055005500610065 #, % NOP,DIA,DIB,TRB. 00022740 + S= @0055703404210435 #; % NOP,LITC Y,STD,XIT. 00022745 + IF (A~A)<1 OR (B~B)<1 OR (X~X)<1 OR X+A>48 OR X+B>48 00022750 + THEN P((-63),26,COM) ; 00022755 + IF F THEN P(Q,AND,0&(B MOD 6)[4:9:3],A MOD 6,DIB 7,TRB 3, 00022760 + P&(B DIV 6)[12:45:3],A DIV 6,DIB 15,TRB 3,OR,0,0,XIT) ; 00022765 + GO P(P(R)&(B DIV 6)[12:45:3],A DIV 6,DIB 24,TRB 3,P&(B MOD 6) 00022770 + [15:9:3],A MOD 6,DIB 27,TRB 3,P&X[36:42:6],.A,~,S,.B,~,Y,Z,[A]);00022775 +END DYNAMICDIALER; 00022830 + 00022840 + 00022850 + PROCEDURE RANDOM(NUMBER, BASE); 00022900 + VALUE NUMBER; 00022925 + REAL NUMBER; 00022950 + INTEGER BASE; 00022975 + BEGIN INTEGER N; 00023000 + REAL T; 00023025 + IF (T := NUMBER MOD 1.0)>0 THEN 00023100 + BEGIN BASE := T.[9:38]; P(RTN); END; 00023150 + IF NUMBER!0 THEN 00023200 + BEGIN T := POLISH(1, 1, COM); 00023250 + N := 0 & T[10:36:6] & T[16:42:6] & T[22:30:6] 00023300 + & ((T.[30:18])|P(DUP))[28:22:20]; 00023350 + END ELSE IF (N := BASE)=0 THEN N := @2631353020000; 00023400 + T := 3 & (N.[10:26]|6137 + 2197513)[10:12:36]; 00023450 + POLISH((((BASE := T) OR 0.5) - 0.5) + P(DUP), RTN); 00023500 + END RANDOM; 00023550 + 00023600 +PROCEDURE SWAP; % 045 00023700 +BEGIN 00023710 + ARRAY A = -2 [*,*], B = -1 [*,*]; 00023720 + STREAM(A, B, CA~0, CB~0, FA~A.[18:15], FB~B.[18:15]); 00023730 + BEGIN 00023740 + SI ~ A; CA ~ SI; 00023750 + SI ~ B; CB ~ SI; 00023760 + DI ~ LOC B; DI ~ DI+5; SKIP 3 DB; 00023770 + SI ~ LOC CA; SI ~ SI+5; SKIP 3 SB; 00023780 + 3(IF SB THEN DS ~ SET ELSE DS ~ RESET; SKIP SB); DS ~ 2 CHR; 00023790 + DI ~ FB; SI ~ LOC B; DS ~ WDS; 00023800 + DI ~ LOC A; DI ~ DI+5; SKIP 3 DB; 00023810 + SI ~ LOC CB; SI ~ SI+5; SKIP 3 SB; 00023820 + 3(IF SB THEN DS ~ SET ELSE DS ~ RESET; SKIP SB); DS ~ 2 CHR; 00023830 + DI ~ FA; SI ~ LOC A; DS ~ WDS; 00023840 + END; 00023850 +END SWAP; 00023860 + 00023900 + 00024000 + 00024100 + 00024200 +COMMENT ALGOL WRITE INTRINSIC;% 00100000 +PROCEDURE ALGOLWRITE(TEN, FILX, CHSKP, LNSKP, FI, AEXP, %WF 00100100 + ARRY, LINESKIP, CHANSKIP, SUPRS, NUMWDS, TANK); %WF 00100200 + VALUE LINESKIP, CHANSKIP, SUPRS, NUMWDS, TANK, %WF 00100300 + CHSKP, LNSKP, FI, ARRY; %WF 00100400 + INTEGER CHSKP, LNSKP, FI, AEXP, %WF 00100500 + LINESKIP, CHANSKIP, NUMWDS, SUPRS; %WF 00100600 + NAME FILX, TANK; %WF 00100700 + ARRAY ARRY[*], TEN[*]; %WF 00100800 +BEGIN REAL SELECT=14,REED=13,ADDRESS;% 00100900 + NAME MEM=2;% 00101000 + LABEL AB,ACTION; 00101100 + LABEL DS,WINDUP1; 00101200 + ARRAY FPB=3[*],FIB[*],HEADER[*];% 00101300 + INTEGER I,RSIZE;% 00101400 + INTEGER SPOUT; 00101450 + ARRAY TINK=TANK[*]; %WF 00101500 + REAL CHNSKP=CHANSKIP; 00101550 + REAL ALGOLWRITE=12; %WF 00101600 + DEFINE FNUM = FIB[4].[13:11] #; 00101650 + DEFINE IOD=(*TANK)#;% 00101700 + $ SET OMIT = NOT(TIMESHARING) 00101750 +SUBROUTINE WAIT; POLISH(TANK, @2000000000, 36, COM, DEL, DEL); 00101752 + $ POP OMIT 00101753 + $ SET OMIT = TIMESHARING 00101799 + LABEL ERR,LP1,MT1,CLOSED,DK1,SP1,CP1,DC1,PP1;% 00101900 + LABEL DCN1,DCN2,SPIN; 00101910 + $ SET OMIT = NOT SHAREDISK 00101919 + SWITCH SW1~ ERR,LP1,MT1,CLOSED,DK1,SP1,CP1,LP1,PP1,ERR,DC1, 00102000 + ERR,LP1,DCN1; 00102010 + LABEL LP2,MT2,DK2,SP2,CP2,DC2,PP2;% 00102100 + SWITCH SW2~ ERR,LP2,MT2,ERR,DK2,SP2,CP2,LP2,PP2,ERR,DC2,ERR, 00102200 + LP2,DCN2; 00102210 + LABEL DS1,DR1,DU1;% 00102300 + SWITCH DSW1~DS1,DR1,DU1,CLOSED; 00102400 + LABEL UT,PBIT,OWT,D19,RELEASE,STA,EXIT,L1,WINDUP,DBIT;% 00102500 + LABEL TYPEU,TYPEA,TYPEC;% 00102600 + SWITCH TYPE~TYPEU,TYPEA,ERR,TYPEC;% 00102700 + LABEL DS2,DR2,DU2;% 00102800 + SWITCH DSW2~DS2,DR2,DU2;% 00102900 + SUBROUTINE BLOCK;% 00103000 + BEGIN GO TO TYPE[I~FIB[5].[46:2]];% 00103100 +TYPEC: STREAM(D1~IOD,S~(NUMWDS~NUMWDS+1)|8,% 00103200 + D2~(TANK[0]~NUMWDS INX IOD));% 00103300 + BEGIN SI~LOC S; DI~DI-8; DS~4 DEC; DI~D1;% 00103400 + SI~D2; SI~SI-8; DI~DI-4; DS~4 CHR;% 00103500 + END;% 00103600 + IF (FIB[17]~FIB[17]-NUMWDS)>RSIZE+1 THEN BEGIN% 00103700 +OWT: FIB[7]~FIB[7]+1; P(XIT);% 00103800 +TYPEA: IF (FIB[17]~FIB[17]-RSIZE)}RSIZE THEN% 00103900 + BEGIN TANK[0]~RSIZE INX IOD; GO OWT END END;% 00104000 + NUMWDS~FIB[18].[18:15]-FIB[17]+(I=3);% 00104100 +TYPEU: END BLOCK;% 00104200 + REAL SUBROUTINE DISKADDRESS;% 00104300 + BEGIN% 00104400 + ADDRESS~(CHANSKIP DIV HEADER[0].[30:12])|HEADER[0].[42:6];% 00104500 + IF (SUPRS~ADDRESS DIV HEADER[1]+10)}30 THEN 00104600 + BEGIN P(0); GO TO EXIT END; 00104700 + IF HEADER[SUPRS]=0 THEN 00104800 + IF HEADER[9]>(SUPRS-10) THEN% 00104900 + P(FPB[FNUM+3],FPB[FNUM],FPB[FNUM+1],SUPRS,HEADER, 00105000 + 4,11,COM,DEL,DEL,DEL,DEL,DEL,DEL) ELSE 00105050 + BEGIN P(0); GO TO EXIT END;% 00105100 + ADDRESS~HEADER[SUPRS]+SUPRS~ADDRESS MOD HEADER[1];% 00105200 + STREAM(D~[ADDRESS]); BEGIN SI~D; DS~8 DEC END; P(1);% 00105300 + EXIT: DISKADDRESS~P;% 00105400 + END DISKADDRESS;% 00105500 + IF TINK=0 THEN %WF 00105600 + BEGIN FIB ~ FILX[NOT 2]; %WF 00105700 + IF FIB[5].[11:2]<2 THEN P(MKS,"WRITNG",FILX,7,SELECT) ; 00105703 + IF FIB[5].[43:1] THEN 00105710 + P(MKS, CHSKP, 0, FILX, 1, SELECT); 00105720 + IF LNSKP>1 AND ARRY<0 AND (I~FIB[4].[8:4])!1 00105750 + $ SET OMIT = NOT(TIMESHARING) 00105752 + AND I!7 AND I!12 AND I!10 THEN 00105753 + $ SET OMIT = TIMESHARING 00105754 + P(XIT);%CARRIAGE CONTROL ON NON-PRINTER FILE 00105760 + 00105800 + 00105900 + RSIZE ~ P(MKS, LNSKP, CHSKP, SUPRS, %WF 00106000 + (-1), FILX, ALGOLWRITE); %WF 00106100 + IF ARRY{0 THEN SUPRS ~ 1 ELSE %WF 00106200 + BEGIN % 11/24/72 - CORRECTED 10/3/73 00106300 + IF ARRY.[8:10]=P(DUP,0) THEN % INDEXED WRITE 00106320 + P(DEL,AEXP) % WRITE MIN(AEXP,RSIZE) WORDS 00106340 + ELSE % WRITE MIN(ARRY SIZE,AEXP,RSIZE) WORDS 00106360 + IF P GTR P(DUP,AEXP) % 00106380 + THEN P(DEL,AEXP); %WF 00106400 + IF P(DUP)}RSIZE THEN P(DEL) ELSE RSIZE ~ P; %WF 00106500 + STREAM(P4 ~ [ARRY[0]], P3 ~ RSIZE, %WF 00106600 + P2 ~ P(DUP).[36:6], P1 ~ *FILX); %WF 00106700 + BEGIN SI ~ P4; DS ~ P3 WDS; %WF 00106800 + P2(DS ~ 32 WDS; DS ~ 32 WDS); %WF 00106900 + END; %WF 00107000 + END; %WF 00107100 + IF RSIZE>0 THEN P(MKS, LNSKP, %WF 00107200 + CHSKP, SUPRS, RSIZE, FILX, ALGOLWRITE); %WF 00107300 + FILX[NOT 4] ~ FILX[NOT 3] ~ 0; %WF 00107400 + P(XIT); %WF 00107500 + END; %WF 00107600 + FIB~TANK[NOT 2];% 00107700 +UT: I~FIB[4].[8:4]; RSIZE~FIB[18].[33:15];% 00107800 + SPOUT:=(I=5); 00107820 + $ SET OMIT = TIMESHARING 00107840 + IF CHNSKP.[4:1] THEN 00107860 + BEGIN CHNSKP.[4:1]~0; 00107870 + $ SET OMIT = NOT SHAREDISK 00107879 + END; 00107890 + IF NUMWDS<0 THEN GO TO SW1[I]; GO TO SW2[I];% 00107900 + LP1: MT1: SP1: CP1: PP1: 00108000 +% 00108100 +D19: IF IOD.[19:1] THEN% 00108200 +PBIT: IF IOD.[2:1] THEN P(RSIZE,RTN) ELSE% 00108300 + IF IOD.[25:1] THEN% 00108400 +CLOSED: BEGIN 00108410 + FIB[13].[27:1]~0; 00108420 + IF (I~(FPB[FNUM+3] AND 31))!10 AND I!12 00108430 + AND I!13 AND I!26 THEN FIB[5].[45:1]~0 ELSE 00108440 + FIB[5].[45:1]~P(TANK[NOT 3],DUP)!0 AND P(XCH)!15; 00108450 + P(TANK,0,11,COM,DEL,DEL) ; 00108510 + IF NOT FIB[5].[45:1] THEN GO UT ; 00108515 + P(TANK[NOT 3]); TANK[NOT 3]~TANK[NOT 4]~0 ; 00108520 + P(MKS,9,BLKCNTRL,DEL) ;% TAKE PARITY ACTION LBL BRNCH. 00108525 + P(1); GO TO DS; 00108530 + END ELSE 00108535 + IF IOD.[27:1] AND (I=2 OR I=7 OR I=8) THEN% 00108600 + BEGIN IF NOT FIB[4].[2:1] THEN% 00108700 + BEGIN HEADER~TANK[NOT 1];HEADER[4].[42:6]~1 END;00108800 + IF I=7 THEN FIB[9].[1:1]~1; % MULTI-REEL PBT FILE 00108850 + I~FIB[13].[28:10]+1;% 00108900 + P(MKS,6,0,(NOT 2) INX TANK,4,SELECT);% 00109000 + FIB[13].[28:10]~I; GO TO CLOSED;% 00109100 + END ELSE% 00109200 + BEGIN 00109300 +ERR: P(3); 00109310 +DS: P(TANK,XCH,11,COM); 00109320 + END; 00109330 + WAIT; GO TO PBIT;% 00109400 +DK1: HEADER~*[FIB[14]]; GO TO DSW1[FIB[4].[27:3]];% 00109500 +DK2: HEADER~*[FIB[14]]; GO TO DSW2[FIB[4].[27:3]];% 00109600 +CP2: BLOCK; TANK[0]~FLAG(FIB[16])&CHANSKIP[32:47:1]; GO TO RELEASE;% 00109700 +LP2: IF SUPRS THEN STREAM(RSIZE,D~IOD); BEGIN RSIZE(DS~8 LIT " ") END; 00109800 + CHANSKIP~CHANSKIP+LINESKIP.[45:1]; 00109850 + IF CHANSKIP!0 THEN% 00109900 + BEGIN IF (I~FIB[17]-RSIZE)>0 THEN% 00110000 + STREAM(I,D~RSIZE INX IOD); BEGIN I(DS~8 LIT " ") END;% 00110100 + END ELSE BLOCK;% 00110200 + TANK[0]~FLAG(FIB[16])&LINESKIP[27:47:1]&LINESKIP[28:46:1]% 00110300 + &CHANSKIP[29:44:4]&NUMWDS[8:38:10];% 00110400 + GO TO RELEASE;% 00110500 +SP2: PP2:% 00110600 +MT2: BLOCK;% 00110700 + P(TANK[0]~FLAG(FIB[16])&NUMWDS[8:38:10],NUMWDS,XCH,INX,% 00110800 + @3700000000000000,XCH,~);% 00110900 + IF SPOUT THEN % SPO OUTPUT 00110910 + IF FPB[FNUM+3].[42:6]=43 THEN P(XIT) ELSE %DUMMY 00110920 + P(0,0,NOT,IOD,INX,15,COM,XIT) 00110940 + ELSE 00110990 +RELEASE: P(FLAG(FIB[19])&IOD[3:3:5],TANK,PRL,DEL);% 00111000 +WINDUP: I~FIB[19].[33:15]-FIB[16].[33:15];% 00111100 + FIB[16].[33:15]~SUPRS~MEM[P(DUP) INX NOT 1].[18:15];% 00111200 + FIB[19].[33:15]~SUPRS+I;% 00111300 + WINDUP1: 00111400 + FIB[6]~FIB[6]+1; FIB[7]~FIB[7]+1; FIB[17]~FIB[18].[18:15];% 00111500 + P(XIT);% 00111600 +DU1:% 00111700 +DS1: IF LINESKIP!0 THEN% 00111800 + BEGIN IF IOD.[27:1] AND IOD.[19:1] THEN GO AB; 00111900 + IF FIB[17]=FIB[18].[18:15] THEN 00111950 + BEGIN CHANSKIP~FIB[7];% 00112000 +L1: IF DISKADDRESS THEN% 00112100 + IF IOD.[19:1] THEN DBIT: IF IOD.[2:1] THEN% 00112200 + BEGIN 00112300 + $ SET OMIT = NOT SHAREDISK 00112309 + MEM[FIB[16]]~ADDRESS; 00112340 + P(RSIZE,RTN); 00112350 + END ELSE 00112360 + IF IOD.[25:1] THEN GO TO CLOSED ELSE 00112400 + $ SET OMIT = NOT SHAREDISK 00112409 + BEGIN 00112420 + $ SET OMIT = NOT SHAREDISK 00112429 + GO TO AB; 00112440 + END ELSE 00112450 + BEGIN WAIT; GO TO DBIT; END ELSE 00112460 + BEGIN 00112470 + $ SET OMIT = NOT SHAREDISK 00112479 + GO TO AB; 00112490 + END; 00112500 + END; P(RSIZE,RTN);% 00112600 + END;% 00112700 + P(MKS,CHANSKIP,4,TANK,1,SELECT); GO TO L1; 00112800 +DS2: IF FIB[7]>HEADER[7] THEN HEADER[7]~FIB[7];% 00112900 + BLOCK; TANK[0]~FLAG(FIB[16]); GO RELEASE;% 00113000 +DR1: IF LINESKIP!0 THEN CHANSKIP~FIB[7] ELSE FIB[7]~CHANSKIP;% 00113100 + IF HEADER[7]HEADER[7] THEN HEADER[7]~FIB[7];% 00114400 + BLOCK;% 00114500 + CHANSKIP~FIB[7]+FIB[13].[10:9]|HEADER[0].[30:12];% 00114600 + IF DISKADDRESS THEN% 00114700 + BEGIN P(TANK[0]~FLAG(FIB[16])&0[24:24:1],(NOT 0),XCH,INX,% 00114800 + ADDRESS,XCH,~);% 00114900 + P(FLAG(FIB[19])&1[24:47:1],TANK,PRL,DEL);% 00115000 + END ELSE% 00115100 + BEGIN TANK[0]~FLAG(FIB[16])&0[24:24:1];% 00115200 + P(FLAG(FIB[19])&1[24:44:4],TANK,PRL,DEL);% 00115300 + END;% 00115400 + GO TO WINDUP;% 00115500 + $ SET OMIT = NOT(TIMESHARING) 00115501 + DC1:: P(RSIZE, RTN); 00115510 + $ SET OMIT = TIMESHARING 00115590 + AB:: BEGIN IF(ADDRESS~TANK[NOT 4])=0 THEN GO ERR; 00115800 + ACTION:: TANK[NOT 3]~TANK[NOT 4] ~0; 00115900 + TANK[0] := IOD OR MEM; 00116000 + P(ADDRESS,MKS,9,JUNK); GO TO ERR; 00116100 + END; 00116200 + IF TANK[NOT 4]=0 THEN BEGIN WAIT; GO TO DC1 END; 00116300 + IF P(CHANSKIP.[CF]|60,CHANSKIP,TANK,18,11,COM,DEL,DEL,DEL) 00116400 + THEN P(RSIZE,RTN); 00116500 + GO TO AB; 00116600 + $ SET OMIT = NOT(TIMESHARING) 00116601 +DC2: IF CHANSKIP.[CF] NEQ 0 THEN CHANSKIP:=ABS(CHANSKIP&1[CTF]) 00116610 + ELSE CHANSKIP ~ (8|(LINESKIP=4)+LINESKIP.[45:3]) 00116620 + &LINESKIP[32:43:1]; 00116630 + NUMWDS ~ IF SUPRS THEN 0 ELSE 8|NUMWDS; 00116635 + POLISH(IOD, NUMWDS, CHANSKIP, 0, (-11), COM, DEL); 00116640 + I:=POLISH+1; 00116644 + ADDRESS:=TANK[NOT(4-(I=2))]; 00116646 + TANK[NOT 4]:=TANK[NOT 3]:=0; 00116648 + IF I THEN P(XIT); 00116650 + IF ADDRESS NEQ 0 THEN 00116652 + P(ADDRESS,MKS,9,BLKCNTRL); 00116654 + ADDRESS:=1+((I=0)|2); 00116656 + P(TANK,ADDRESS,11,COM); 00116658 +DCN1:DCN2:SPIN: P(XIT); 00116660 + $ SET OMIT = TIMESHARING 00116690 +END ALGOLWRITE; 00118800 +PROCEDURE OUTPUTINT(TEN,FILX,CHSKP,LNSKP,FI,FRMT,LISX);% 00200000 + COMMENT ESPOL VERSION OF ALGOL WRITE INTRINSIC% 00200100 + BY L.R. GUCK 12/1/64;% 00200200 + VALUE CHSKP,LNSKP,FI,LISX;% 00200300 + NAME FILX;% 00200400 + ARRAY TEN[*],% 00200500 + FRMT[*];% 00200600 + REAL LISX;% 00200700 + INTEGER CHSKP,LNSKP,FI;% 00200800 + BEGIN% 00200900 + REAL ALGOLWRITE=12;% 00201000 + ARRAY REALROW=TEN-1[*];% 00201100 + REAL SELECT=14;% 00201200 + REAL JUNK2=9;% 00201300 + INTEGER V2=1 ; 00201310 + INTEGER TEMPD=7 ; 00201320 + INTEGER JUNK1=17;% 00201400 + INTEGER LSTRN=19;% 00201500 + INTEGER AEXP =FRMT;% 00201600 + ARRAY ARRY =LISX[*];% 00201700 + INTEGER TLSTRN=+1 ;% 00201800 + REAL UTYP = TLSTRN+1; 00201900 + DEFINE UTIP =UTYP.[47:1] #, %%%% USED FOR NON-BOOLEAN USE OF UTYP00201905 + FFTYP=UTYP.[46:1] #, %%%% FLAG TO SHOW USING FREE FIELD. 00201906 + STORW=UTYP.[40:6] #, %%%% USED TO STORE ORIG VALUE OF W. 00201907 + UES =UTYP.[39:1] #, %%%% FLAG TO INCLUDE EXPONENT SIGN. 00201908 + UDC =UTYP.[38:1] #, %%%% FLAG TO INCLUDE DECIMAL POINI. 00201909 + UED =UTYP.[36:2] #, %%%% NUMBER OF EXPONENT DIGITS. 00201910 + UMD =UTYP.[35:1] #, %%%% FLAG TO INCLUDE MANTISSA. 00201911 + STORD=UTYP.[29:6] #, %%%% USED TO STORE ORIG VALUE OF D 00201912 + UBUFF=UTYP.[16:13]#, %%%% ADJUSIED BUFFER SIZE. . 00201913 + UTOP =UTYP.[15:1] #, %%%% FLAG TO INCLUDE TRAILING BLANK. 00201914 + USKIP=UTYP.[09:6] #, %%%% # XTRA LEADING BLANKS FOR I OR F00201915 + FFCHR=UTYP.[03:6] #; %%%% FREE FIELD DELIMITER (, OR BLNK)00201917 + INTEGER SUPRS = UTYP+1; 00201920 + REAL BUFF=SUPRS+1;% 00202000 + INTEGER BSIZE=BUFF+1;% 00202100 + ARRAY FIB=BSIZE+1[*];% 00202200 + REAL WH2=FIB+1;% 00202300 + REAL WH1=WH2+1;% 00202400 + REAL DH1=WH1+1;% 00202500 + INTEGER DH2=DH1+1;% 00202600 + REAL W=DH2+1;% 00202700 + REAL W1=W+1;% 00202800 + REAL W2=W1+1;% 00202900 + REAL WT=W2+1;% 00203000 + REAL D=WT+1;% 00203100 + REAL D1=D+1;% 00203200 + REAL D2=D1+1;% 00203300 + REAL DA=D2+1;% 00203400 + REAL SKIP=DA+1;% 00203500 + REAL CHR=SKIP+1;% 00203600 + INTEGER E=CHR+1;% 00203700 + REAL ZEROS=E+1;% 00203800 + REAL CODE=ZEROS+1;% 00203900 + REAL FAW=CODE+1;% 00204000 + REAL SGN=FAW+1;% 00204100 + INTEGER SCFTR=SGN+1;% 00204200 + REAL TPHRASE=SCFTR+1; 00204210 + INTEGER LZ = TPHRASE + 1; 00204220 + LABEL RTNPRNT,EFA,EFC,EERTN,RNA,RNB,% 00204300 + START,ISFRM,AEXL,ISA,ISB,ASLST,BS,BR,BB,ERROR,% 00204400 + FMOUT,S1,S,LFPAR,RTPAR,SLASH,SCALE,STRNG,% 00204500 + PHRAS,INLOOP,ASTB,ASTA,AST,FLDW,JMP,% 00204600 + LOGI,ALFA,DOTYPE,XTYPE,ITYPE,% 00204700 + FTYPE,RFIN,FA,FB,FC,FD,UTYPE,UI,UF,ESUBTYPE,ETYPE1,COMMM, 00204800 + FORMATERR,TTYPE,BACK, 00204810 + ETYPE,REIN,EA,ERTN,REOT,EB,MAXN,TEN8,% 00204900 + RTYPE,RC,TRYE,RRTN,MAXM,COMM;% 00205000 + COMMENT LABELS ARE LISTED IN SAME ORDER THEY APPEAR;% 00205100 + DEFINE LOG8 = @1157163034761674#,% 00205200 + MAX =@0007777777777777#,% 00205300 + SAVEBUFF=TPHRASE.[30:18]#, 00205305 + MAXCHR =TPHRASE.[18:12]#, 00205310 + P = POLISH#;% 00205400 + SUBROUTINE CKPB;% 00205500 + BEGIN% 00205600 + IF FILX.[18:15] { 1 THEN% 00205700 + BEGIN IF NOT FILX.[18:15] THEN% 00205800 + BEGIN;STREAM(A~[REALROW[0]]:B~0);% 00205900 + BEGIN SI~A; DI~A; SI~SI-16; 00206000 + SKIP 2 SB;% 00206100 + IF SB THEN TALLY ~ 1;% 00206200 + A ~ TALLY;% 00206300 + END;% 00206400 + IF NOT P THEN% 00206500 + BEGIN P(FILX,14,COM,DEL);% 00206600 + FILX.[18:15] ~ 1;% 00206700 + END;% 00206800 + END;% 00206900 + BSIZE ~ REALROW.[8:10];% 00207000 + END ELSE% 00207100 + BSIZE~POLISH(MKS,LNSKP,CHSKP,SUPRS,(-1),FILX,ALGOLWRITE); 00207200 + BUFF~(*FILX)&BSIZE[8:38:10] ; 00207300 + END;% 00207400 + SUBROUTINE PRNT;% 00207500 + BEGIN COMMENT RELEASE BUFFER;% 00207600 + COMMENT S= RETURN LITERAL.% 00207700 + S-1 = IF TRUE THEN RETURN AFTER RELEASE.% 00207800 + IF FALSE THEN EXIT;% 00207900 + P(XCH);% 00208000 + IF FILX.[18:15] > 1 THEN% 00208100 + IF BSIZE>0 THEN 00208200 + POLISH(MKS,LNSKP,CHSKP,SUPRS,BSIZE,FILX,ALGOLWRITE); 00208300 + COMMENT WRITE RELEASE;% 00208400 + IF P THEN CKPB% 00208500 + ELSE BEGIN LSTRN ~ TLSTRN;% 00208600 + IF FILX.[18:15]>1 THEN 00208700 + FILX[NOT 4]~FILX[NOT 3]~0 ELSE 00208800 + IF FILX.[18:15] = 1 THEN% 00208900 + P(FILX,14,COM);% 00209000 + P(XIT);% 00209100 + END;% 00209200 + RTNPRNT:END;% 00209300 + SUBROUTINE DEBLANK; IF CHR<132 THEN 00209310 + STREAM(P3~P(BSIZE-CHR,DUP),P2~P DIV 64,P1~BUFF) ; 00209320 + BEGIN P2(2(DS~32LIT" ")); P3(DS~LIT" ") END ; 00209330 + SUBROUTINE PRNTA;% 00209400 + BEGIN COMMENT BLANK TO END OF BUFFER OR TO 132 TH CHARACIER,% 00209500 + WHICH EVER IS LESS;% 00209600 + P(XCH); COMMENT S= XIT KEY IF TRUE THEN RETURN.% 00209700 + IF FALSE THEN EXIT ;% 00209800 + IF TPHRASE>0 THEN DEBLANK ELSE CHR~MAXCHR ; 00209900 +%VOID 00210000 +%VOID 00210100 +%VOID 00210200 +%VOID 00210300 +%VOID 00210400 +%VOID 00210500 +%VOID 00210600 + BSIZE~(IF CHR=0 THEN BSIZE ELSE CHR+7) DIV 8; 00210700 + PRNT; COMMENT RELEASE BUFFER;% 00210800 + CHR ~ 0;% 00210900 + BSIZE ~ BSIZE | 8;% 00211000 + TPHRASE~BUFF~P(.BUFF,LOD,0,INX) ; 00211100 + END;% 00211200 + SUBROUTINE FINDE;% 00211300 + BEGIN COMMENT DETERMINE THE EXPONENT OF A REAL NUMBER;% 00211400 + IF WH1 = (LZ~ZEROS~0) THEN GO TO EFC; 00211500 + E ~ (( 0&WH1[42:3:6]&WH1[1:2:1] + 12) | LOG8) + .5 ;% 00211600 + EFA: IF ABS(WH1) } ( IF E} 0 THEN TEN[E]% 00211700 + ELSE 1/TEN[-E])% 00211800 + THEN GO TO EERTN;% 00211900 + E ~ E - 1;% 00212000 + GO TO EFA;% 00212100 + EFC: E ~ 0;% 00212200 + EERTN:END;% 00212300 + SUBROUTINE RNDOFF;% 00212400 + COMMENT ADJUST NUMBER TO 12 SIGNIFICAT DIGITS PLUS% 00212500 + TRAILING ZEROS. NOTE DA = ADJUSTED ;% 00212600 + RNA: BEGIN IF ABS(P((JUNK2 ~ TEN[DA]) | WH1,DUP)) { MAX% 00212700 + THEN GO TO RNB; COMMENT DA = ADJUSTED DEC1MAL PLACES; 00212800 + P(DEL);% 00212900 + ZEROS ~ ZEROS +1; COMMENT TRAILING ZEROS +1;% 00213000 + DA ~ DA-1; COMMENT SUBTRACI 1 FROM DECIMAL PLACES;% 00213100 + GO TO RNA;% 00213200 + RNB: DH2 ~ P; COMMENT ROUND OFF NUMBER;% 00213300 + END;% 00213400 + REAL SUBROUTINE LISTELEMENT; 00213500 + BEGIN IF LSTRN<0 THEN GO TO ERROR; 00213600 + P(WH1,.WH1,ISN); WH1~LISX; 00213700 + LISTELEMENT~P; 00213800 + END LISTELEMENT; 00213900 + SUBROUTINE SETMAXCHR; IF MAXCHR 1 THEN% 00214300 + BEGIN P(FILX[NOT 2]);% 00214400 + IF FIB[5].[11:2]<2 THEN P(MKS,"WRITNG",FILX,7,SELECT) ; 00214420 + IF FIB[5].[43:1] THEN POLISH(MKS,CHSKP,0,FILX,1,SELECT);% 00214500 + COMMENT CALL SELECT IF FILE NOT IN WRITE STATUS;% 00214600 + END ELSE P(0);% 00214700 + CKPB; COMMENT CHECK FOR PRESENCE BIT;% 00214800 + COMMENT CHECK FOR TYPE OF WRITE;% 00214900 + IF FRMT ! 0 THEN GO TO ISFRM;% 00215000 + IF ARRY ! 0 THEN% 00215100 + IF ARRY < 0 THEN GO TO ASLST% 00215200 + ELSE GO TO AEXL;% 00215300 + COMMENT CASE = FORMAT = LIST = EMPTY;% 00215400 + SUPRS~1;% 00215500 + GO TO BB;% 00215600 + ISFRM: IF NOT P(FRMT,TOP,XCH,DEL) THEN GO TO FMOUT;% 00215700 + IF FI!0 THEN %%% FREE FIELD: [FI]/[TEMPD=AEXP-1] 00215710 + BEGIN TEMPD~AEXP-1; FRMT~0; GO TO FMOUT END ; 00215720 + COMMENT CASE = AEXP,ARRAY ROW;% 00215800 + AEXL: IF P(ARRY.[8:10],DUP) { AEXP THEN GO TO ISA;% 00215900 + IF AEXP<0 THEN P(ARRY[AEXP]) ; 00216000 + P(DEL,AEXP);% 00216100 + COMMENT STACK ~ SMALLER OF ARRAY SIZE OR AEXP;% 00216200 + ISA: IF P(DUP) { BSIZE THEN GO TO ISB;% 00216300 + P(DEL,BSIZE);% 00216400 + COMMENT STACK ~ SMALLEST OF BUFFER SIZE, ARRAY SIZE% 00216500 + OR AEXP;% 00216600 + ISB: BSIZE ~ P;% 00216700 + COMMENT BSIZE~# OF WORDS TO TRANSFER;% 00216800 + COMMENT TRANSFER ARRAY TO BUFFFR;% 00216900 + STREAM(P4 ~ [ARRY[0]], P3 ~ BSIZE,% 00217000 + P2 ~ BSIZE DIV 64, P1 ~ * FILX);% 00217100 + BEGIN% 00217200 + SI ~ P4;% 00217300 + P2 (DS ~ 32 WDS;% 00217400 + DS ~ 32 WDS);% 00217500 + DS ~ P3 WDS;% 00217600 + END;% 00217700 + GO TO BB;% 00217800 + COMMENT CASE = *,LIST;% 00217900 + ASLST: P(0,.LSTRN,SND); COMMENT S=I=0;% 00218000 + BS: P(DUP,LISX); COMMENT S=VALUE,S-1=I,S-2=I;% 00218100 + IF LSTRN } 0 THEN GO TO BR;% 00218200 + BSIZE ~ P(DEL,DEL); COMMENT BSIZE ~ I =% 00218300 + # OF WORDS IN BUFFER;% 00218400 + GO TO BB;% 00218500 + BR: P(XCH); COMMENT S=I,S-1=VALUE,S-2=I;% 00218600 + P([BUFF],STD); COMMENT VALUE TO BUFFER[I];% 00218700 + IF P(1,+,DUP) < BSIZE% 00218800 + THEN GO TO BS;% 00218900 + BSIZE ~ P;% 00219000 + BB: P(0); COMMENT FLAG TO EXIT ON CALLING PRNT;% 00219100 + PRNT;% 00219200 + ERROR: P(0);% 00219300 + PRNTA; COMMENT CALL PRNTA AND EXIT;% 00219400 + COMMENT CASE OF FORMAT,LIST OR FORMAT EMPTY;% 00219500 + FMOUT: LSTRN ~ -( ARRY = 0);% 00219600 + COMMENT LSTRN ~ -1 IF NO LIST;% 00219700 + P(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);% 00219800 + P(0) ; 00219810 + DH1 ~ TEMPD ; 00219900 + WH1 ~ LISX; COMMENT GET FIRST LISI ITEM;% 00220000 + TPHRASE~BUFF~P(0,[BUFF]).[33:15] ; 00220100 + COMMENT BUFF ~ ABSOLUTE CORE ADDRESS;% 00220200 + BSIZE ~ BSIZE | 8;% 00220300 + COMMENT BSIZE NOW # OF CHARACTERS IN BUFFER;% 00220400 + IF FRMT=0 THEN %%% FREE FIELD WRITE, WHICH IS EQUIVALENT 00220405 + BEGIN %%% TO U OR UX.X 00220410 + CODE~11; JUNK1~BSIZE; IF(TEMPD~DH1)>63 THEN TEMPD~63;00220415 + FFCHR~IF FI<0 THEN " " ELSE "," ; 00220416 + IF (FI~ABS(FI)-1)!0 THEN %%% WE HAVE AT LEAST [FI]/ 00220418 + BEGIN IF TEMPD=0 THEN %%% WE HAVE [FI]/[0]. 00220420 + BEGIN IF (TEMPD~BSIZE/FI-2.4999999999){0 00220422 + THEN TEMPD~1 ELSE IF TEMPD>21 THEN 00220424 + JUNK1~((TEMPD~21)+2)|FI END 00220426 + ELSE IF (V2~FI|(TEMPD+2)) 0 THEN GO TO PHRAS;% 00220900 + COMMENT IF S=0 THEN GO TO PHRASE;% 00221000 + GO TO P(CODE); COMMENT SWITCH ON CODE;% 00221100 + GO TO RTPAR;% 00221200 + GO TO STRNG;% 00221300 + GO TO LFPAR;% 00221400 + GO TO SLASH;% 00221500 + GO TO SCALE;% 00221600 + COMMENT LEFT PARENTHESIS;% 00221700 + LFPAR: IF FAW.[12:1] THEN 00221800 + BEGIN IF P(LISTELEMENT,DUP)<0 THEN 00221900 + BEGIN P(DEL); FI~FAW.[28:10]+FI; END; 00222000 + END ELSE P(FAW.[38:10]); 00222100 + COMMENT MASK OUT REPFAT AND LEAVE IN STACK;% 00222200 + GO TO S1;% 00222300 + COMMENT RIGHT PARENTHESIS;% 00222400 + RTPAR: P(1,SUB); COMMENT SUBTRACT ONE FROM LFPAR REPEAT;% 00222500 + IF P(DUP) = 0 THEN BEGIN% 00222600 + P(DEL); COMMENT DELETE 0 REPEAT;% 00222700 + GO TO S1; COMMENT PICK UP NEXT PHRASE;00222800 + END;% 00222900 + FI ~ FI -(FAW AND 1023); COMMENT SET FI BACK TO LFPAR;00223000 + GO TO S1;% 00223100 + COMMENT SLASH;% 00223200 + SLASH: POLISH((LSTRN}0) OR NOT FAW);% 00223300 + PRNTA;COMMENT RELEASE BUFFER;% 00223400 + COMMENT EXIT IF FORMAT & LIST EXAUSTED;% 00223500 + GO TO S1; COMMENT S1 IF LIST OR FORMAT NOT EXAUSTED;% 00223600 + COMMENT SCALE FACTOR;% 00223700 + SCALE: SCFTR~IF FAW.[12:1] THEN LISTELEMENT 00223800 + ELSE 0&FAW[38:38:10]&FAW[1:11:1]; 00223900 + GO TO S1;% 00224000 + COMMENT STRINGS;% 00224100 + STRNG: IF P(CHR + (W~FAW.[6:6]),DUP) > BSIZE% 00224200 + THEN GO TO ERROR; COMMENT BUFFER OVERFLOW;% 00224300 + CHR ~ P ; COMMENT CHR ~ W+CHR;% 00224400 + SETMAXCHR ; 00224410 + STREAM(P4 ~ 0: P3 ~ FAW,P2 ~ W,P1 ~ BUFF);% 00224500 + BEGIN% 00224600 + SI ~ LOC P2;% 00224700 + SI ~ SI-P2;% 00224800 + DS ~ P2 CHR;% 00224900 + P4 ~ DI;% 00225000 + END;% 00225100 + BUFF ~ P;% 00225200 + GO TO S1;% 00225300 + COMMENT BRLAK APART FORMAT WORD;% 00225400 + PHRAS: IF FAW.[12:1] THEN P(LISTELEMENT) ELSE P(FAW.[38:10]); 00225500 + IF CODE=13 THEN CODE~IF (CODE~LISTELEMENT)="D" THEN 0 ELSE00225600 + IF CODE="I" THEN 1 ELSE 00225650 + IF CODE="X" THEN 2 ELSE 00225700 + IF CODE="A" THEN 4 ELSE 00225800 + IF CODE="I" THEN 6 ELSE 00225900 + IF CODE="F" THEN 8 ELSE 00226000 + IF CODE="E" THEN 10 ELSE 00226100 + IF CODE="U" THEN 11 ELSE 00226110 + IF CODE="B" THEN 110 ELSE 00226120 + IF CODE="O" THEN 12 ELSE 00226200 + IF CODE="L" THEN 14 ELSE 00226300 + IF CODE="R" THEN 15 ELSE 16; 00226400 + IF CODE=110 THEN BEGIN CODE~11; FAW.[31:1]~1 END ; 00226410 + W~IF FAW.[13:1] THEN LISTELEMENT-(CODE=1) ELSE FAW.[6:6] ;00226500 + D~IF FAW.[14:1] THEN LISTELEMENT 00226600 + ELSE IF CODE=11 THEN FAW.[32:6] 00226610 + ELSE (D1~FAW.[20:4])+(D2~FAW.[16:4]); 00226700 + IF P(DUP){0 THEN GO BACK; 00226800 + IF W<0 THEN 00226810 + IF CODE=1 AND W=(-1) THEN GO BACK 00226815 + ELSE IF NOT(CODE=0 OR CODE=12) THEN GO FORMATERR; 00226820 + IF D<0 THEN IF NOT(CODE!15 AND CODE!8 AND CODE!10) 00226830 + THEN GO TO FORMATERR ; 00226840 + IF W=0 THEN IF CODE!2 AND CODE!1 THEN 00226850 + BACK: BEGIN P(DEL); GO S1 END ; 00226852 + IF CODE=11 THEN BEGIN UTOP~DH1~FAW.[31:1]=0 ; 00226860 + IF (WH2~UBUFF-DH1-FFTYP)WH2 THEN 00226865 + GO TO ERROR; UTYP~UTYP&W[40:42:6]&D[29:42:6] OR 1 ; 00226870 + GO TO INLOOP END ; 00226875 + IF FAW.[13:2]!0 OR FAW.[2:4]=13 THEN 00226900 + BEGIN 00227000 + GO P(IF CODE=15 THEN 8 ELSE IF CODE=1 THEN 2 ELSE 00227060 + CODE) ; 00227065 + GO C; GO X; GO A; GO I; GO R; GO G; GO O; GO L; 00227100 + GO TO FORMATERR ; 00227200 + L: W1~IF W{5 THEN W ELSE 5; GO TO Z; 00227300 + X: W1~W DIV 64; W~SKIP~W.[42:6]; 00227400 + GO TO ZW2; 00227500 + A: W1~IF W{6 THEN W ELSE 6; 00227600 + Z: SKIP~W-W1; GO TO ZW2; 00227700 + I: W1~IF W{8 THEN W ELSE 8; 00227800 + SKIP~IF W{16 THEN 0 ELSE W-16; CODE~6 ; 00227900 + W2~W-SKIP-W1; GO TO ZD; 00228000 + G: D~D+(UTIP OR FAW.[2:4]=13 OR FAW.[14:1]); 00228100 + D2~D-D1~IF D{8 THEN D ELSE 8; 00228200 + SKIP~IF (W-D){5 THEN 0 ELSE W-D-5; 00228300 + W1~W2~0; CODE~10; GO TO SWT ; 00228400 + R: D2~D-D1~IF D{8 THEN D ELSE 8; 00228500 + SKIP~IF (W-D){17 THEN 0 ELSE W-D-17; 00228600 + W1~IF (W-D){8 THEN W-D-1 ELSE 8; 00228700 + W2~IF (W-D-SKIP){9 THEN 0 ELSE W-D-SKIP-9; 00228800 + CODE~8; GO TO SWT ; 00228900 + C: O: W~8; W1~SKIP~0; 00229000 + ZW2: W2~0; 00229100 + ZD: D~D1~D2~0; 00229200 + SWT: WT~W1+W2; 00229300 + IF UTYP THEN BEGIN IF NOT((DH1~TEMPD-W){0 OR CODE!10) THEN00229310 + W~TEMPD ELSE DH1~0; IF (WH2~W+UTOP+FFTYP+ 00229320 + USKIP)+CHR>UBUFF THEN BEGIN P(1); PRNTA END;00229330 + CHR~CHR+WH2; SETMAXCHR; IF CODE=10 THEN BEGIN00229340 + SKIP~SGN+DH1; GO ETYPE1 END ELSE GO JMP END ;00229350 + END ELSE 00229400 + BEGIN WT~(W1~FAW.[28:4])+(W2~FAW.[24:4]); 00229500 + SKIP~FAW.[32:6]; 00229600 + END; 00229700 + INLOOP: IF CODE { 2 THEN GO TO FLDW;% 00229800 + UTYP.[35:5]~27 ; %%% SETS UMD=UDC=UES=TRUE, SETS UED=2. 00229810 + USKIP~0 ; 00229820 + IF LSTRN}0 THEN IF UTYP THEN GO TO UTYPE 00229900 + ELSE GO TO FLDW ; 00229910 + P(0); COMMENT SET KEY = EXIT;% 00230000 + PRNTA; COMMENT LIST EXAUSTED. RELEASE BUFFLR AND EXIT; 00230100 + COMMENT FILL FIELD WITH *;% 00230200 + ASTB: P(DEL); ASTA: P(DEL);% 00230300 + AST: STREAM(P3~0: P2~W,PU~UTIP,PUU~UTOP,PS~USKIP, 00230400 + PFF~FFTYP, 00230410 + PCH~FFCHR, 00230415 + P1~BUFF) ; 00230420 + BEGIN 00230500 + PS(DS~LIT" ") ; 00230510 + P2(DS~LIT"*"; PU(DI~DI-1; DS~LIT"|")) ; 00230600 + PFF(SI~LOC P1; SI~SI-1; DS~CHR) ; 00230605 + PUU(DS~LIT" ") ; 00230610 + P3 ~ DI;% 00230700 + END;% 00230800 + 00230900 + GO TO COMMM ; 00231000 + FORMATERR: IF FILX.[18:15]>1 THEN 00231020 + BEGIN %%% NOT ARRAYROWBUFF, SO TRY PAR LBL BRANCH. 00231025 + P(FILX[NOT 3]) ; 00231027 + FILX[NOT 3] ~ FILX[NOT 4] ~ 0 ; 00231030 + P(MKS,9,JUNK) ; 00231040 + END ; 00231045 + TEN~0; TEN~P([TEN[1]],CFX,SFB) & 10[8:38:10] ; 00231050 + STREAM(TEN); DS~17LIT"-FMT ERR NO LBL:~" ; 00231060 + P([TEN[0]].[33:15],34,COM) ; 00231070 + FLDW: IF CODE=1 THEN GO TTYPE; IF P(W+CHR,DUP)>BSIZE 00231100 + THEN GO TO ERROR; COMMENT BUFFER OVERFLOW;% 00231200 + CHR ~ P; COMMENT CHR ~ CHR + W;% 00231300 + SETMAXCHR ; 00231350 + COMMENT SELECT EDITING PHRASE;% 00231400 + JMP: IF CODE = 15 THEN GO TO RTYPE;% 00231500 + IF CODE THEN GO ERROR ; 00231510 + GO TO P(CODE);% 00231600 + GO TO DOTYPE; COMMENT CODE = 0;% 00231700 + GO TO XTYPE; COMMENT CODE = 2;% 00231800 + GO TO ALFA ; COMMENT CODE = 4;% 00231900 + GO TO ITYPE; COMMENT CODE = 6;% 00232000 + GO TO FTYPE; COMMENT CODE = 8;% 00232100 + GO TO ETYPE; COMMENT CODE = 10;% 00232200 + GO TO DOTYPE; COMMENT CODE = 12;% 00232300 + GO TO LOGI ; COMMENT CODE = 14;% 00232400 + COMMENT L PHRASE;% 00232500 + LOGI: STREAM(P5 ~ 0:P4 ~ IF WH1 THEN "TRUE "% 00232600 + ELSE "FALSE" ,% 00232700 + P3 ~ W1, P2 ~ SKIP,P1 ~ BUFF);% 00232800 + BEGIN% 00232900 + P2(DS ~ LIT " ");% 00233000 + SI ~ LOC P4;% 00233100 + SI ~ SI+3;% 00233200 + DS ~ P3 CHR;% 00233300 + P5 ~ DI;% 00233400 + END;% 00233500 + 00233600 + GO TO COMMM ; 00233700 +UTYPE: COMMENT THL U (U, UW OR UW M) SELECTS THE00233703 + ::= I / F / (SPECIAL) E, 00233706 + AND FOR THE CHOSEN PHRASE TYPE IT SELECTS A SUITABLE 00233709 + ::= FP, 00233712 + AND A SUITABLE 00233715 + ::= D, 00233718 + SUCH THAT THE FOLLOWING CONDITIONS ARE SATISFIED: 00233721 + 1. FP MUST SATISFY THE INEQUALITIES, M { FP { W. 00233727 + IF M > W THEN INITIALLY FP { W AND LAIER FP IS 00233730 + ADJUSTED SUCH THAT M-W LEADING BLANKS ARE SUPPLIED00233733 + 2. SUBJECT TO CONDITION #1, THE SELECTED PHRASE 00233739 + SHALL OUTPUT, IN A HIGHLY READABLE FORMAT, THE 00233742 + MAXIMUM AMOUNT OF MEANINGFUL NUMERIC SIGNIFICANCE 00233745 + IN THE LEAST POSSIBLE FIELD WIDTH. A BLANK SPACE 00233746 + IS POSTFIXED TO THE EDITED LIST ELEMENT. 00233747 + NOTE: WH1 = VALUE OF LIST ELEMENT TO BE EDITED, AND 00233748 + IN THE FOLLOWING COMMENTS, "FULL WORD" IS USED IN THE 00233751 + CONTEXT OF CONDITION #2 UNRESTRICTED BY CONDITION #1. 00233754 + END OF COMMENT ; 00233757 + WH1~TEN[0]|ABS(WH2~WH1); %%% RETAIN ORIG WH1,NORM WH1 FOR FINDE00233760 + IF (W~STORW){1 THEN GO UI; %%% RESTORE W, U1 IS SENT TO I-TYPE.00233765 + FINDE ; %%% FINDE SETS E = ENTIER[LOG10(ABS(WH1))],@E{WH1<@E+1.00233775 + TEMPD~STORD ; %%% DECREASES USF OF PARTIAL WORDS. 00233778 + IF ((WH1~ABS(WH2))=0 %%% ZERO IS INTEGRAL, REGARDLESS OF EXPONT00233781 + OR (WH1.[3:6]=0 AND E<10)) %%% WH1 IS INTEGRAL AND NOT BIG00233784 + AND (V2~(SGN~WH2<0)+1+E){W %%% V2 = MINIMUM WIDTH REQUIRED00233787 + THEN %%% FOR FULL WORD I-TYPE. 00233788 + BEGIN W~V2 ; %%% WE NOW USE FULL WORD I-TYPE. 00233790 + UI: IF W5.49755813885)) MAX INTEGER, ELSE DH1 = FALSE. 00233813 + %%% DH2 = TRUE IF WH1 < 1, ELSE DH2 = FALSE. 00233815 + %%% SKIP = TRUE IF WH1 WOULD ROUND UP, ELSE SKIP = FALSE. 00233816 + IF DH1 OR DH2 THEN IF (D1~JUNK1 MOD 10)<3%%% HERE WE HANDLE ANY00233818 + THEN JUNK1~JUNK1-D1 ELSE IF D1>7 THEN %%% CONVERSION TRUNCA-00233821 + JUNK1~JUNK1-D1+10 ; %%% TION PROBLEMS. 00233824 + IF JUNK1=TEN[11] THEN IF D!11 THEN 00233825 + BEGIN WH1~(IF E}(-1) THEN TEN[E+1] ELSE 1/TEN[-(E+1)]) 00233826 + &SGN[1:47:1]; GO TO UTYPE ; 00233827 + END ; 00233828 + D1~1 ; 00233829 + WHILE JUNK1 MOD TEN[D1]=0 DO D1~D1+1;%%%D1=1+#TRAILN 0 IN JUNK100233830 + UES~DH2; IF NOT JUNK1~ABS(E)>9 THEN UED~1; UDC~DA~D1-D!1 ; 00233831 + WT~(W2~2+SGN+DH2)+1+DA+JUNK1 ; %%% WT IS MAIN FIELD WIDTH FOR E00233832 + IF DH1 %%% WH1 BEYOND MAXIMUM F-TYPE RANGE00233833 + OR ((2+DA<(-E) %%% OR WH1 HAS LESS WIDTH IN THE 00233836 + OR (D~D+1-D1)+DAN@,GO TO E.00233867 + UMD~0 ; %%% NO ROOM FOR MANTISSA, SO WE RESET FLAG. 00233868 + W1~NOT(W2+JUNK1!W OR (JUNK1~W1)!1) ; 00233869 + IF DH2 THEN BEGIN IF (DH2~(-E>10)+W2){W AND SKIP THEN 00233870 + BEGIN %%% WH1<1, ROUND UP TO @,GO TO ETYPE00233871 + W~W-(DH21@,GO E00233873 + END ELSE IF (E>8)+W2=W AND SKIP THEN BEGIN E~E+1; GO TO G00233874 + END %%% WH1>1, ROUND UP TO @, GO TO E-TYPE; 00233875 + ELSE IF W1 THEN GO G ; %%% DEL 1 IN 1@, GO TO E00233876 + D~W-1-(W+E+SKIP=1)|SGN; GO TO UF ; %%% GO TO F-TYPE FOR 00233877 + END %%% **...*/(0).00...0 00233878 + ELSE IF W}D1~(D~D2)+D2~2+SGN+D1 THEN %%% HANDLE VARIOUS F-TYPES00233879 + %%% D = # DECIMAL PLACES FOR FULL WORD F-TYPE. 00233883 + %%% D1 = MINIMUM WIDTH REQUIRED FOR FULL WORD F-TYPE. 00233886 + %%% D2 = 1 + #DIGITS TO THE LEFT OF THE DEC1MAL PLACE. 00233889 + BEGIN W ~ D1 ; %%% FULL WORD F-TYPE. 00233892 + UF: IF W BSIZE% 00236300 + THEN GO TO ERROR; COMMENT BUFFER OVERFLOW;% 00236400 + CHR~P; SETMAXCHR ; 00236500 + STREAM(P4 ~ 0: P3 ~ W1, P2 ~ SKIP, P1 ~ BUFF);% 00236600 + BEGIN% 00236700 + P2(DS ~ LIT " ");% 00236800 + P3(32(DS ~ 2 LIT " "));% 00236900 + P4 ~ DI;% 00237000 + END;% 00237100 + 00237200 + GO TO COMMM ; 00237300 + COMMENT T PHRASE ; 00237305 + TTYPE: IF TPHRASE>0 THEN BEGIN DEBLANK; TPHRASE~-TPHRASE END ; 00237308 + IF (CHR~W+W1|64)}BSIZE THEN GO ERROR ; 00237310 + STREAM(P3~SAVEBUFF:P2~W,P1~W1); 00237315 + BEGIN SI~P3; SI~SI+P2; P1(2(SI~SI+32)); P3~SI END ; 00237320 + GO COMMM ; 00237325 + COMMENT I PHRASE;% 00237400 + ITYPE: IF ABS(P(WH1,DUP)) > P(MAXN)% 00237500 + THEN GO TO ASTA; COMMENT FILL FIELD WITH *;% 00237600 + P(.WH1,ISN,DUP); COMMENT ROUND NUMBER;% 00237700 + SGN ~ P < 0;% 00237800 + WH2 ~(WH1 ~ ABS(P)) DIV P(TEN8);% 00237900 + IF WH1 } TEN[WT-SGN]% 00238000 + THEN GO TO AST; COMMENT NUMBER > FIELD WIDTH;% 00238100 + STREAM(P8 ~ 0: P7 ~ WT-1, P6 ~ [WH2],P5 ~ SGN,% 00238200 + P4 ~ W2,P3 ~ W1,P2 ~ SKIP+USKIP,PU~UTOP, 00238300 + PFF~FFTYP, 00238305 + PCH~FFCHR, 00238307 + P1 ~ BUFF) ; 00238310 + BEGIN% 00238400 + P2(DS ~ LIT " ");% 00238500 + P1 ~ DI; COMMENT SAVE STARTING ADDRESS;% 00238600 + SI ~ P6;% 00238700 + DS ~ P4 DEC; COMMENT CONVERT HIGH HALF;% 00238800 + SI ~ P6;% 00238900 + SI ~ SI+8;% 00239000 + DS ~ P3 DEC; COMMENT CONVERT LOW HALF;% 00239100 + PFF(SI~LOC P1; SI~SI-1; DS~CHR) ; 00239105 + PU(DS ~ LIT" ") ; 00239110 + P8 ~ DI;% 00239200 + DI ~ P1;% 00239300 + DS ~ P7 FILL; COMMENT LEADING ZEROS~BLANKS;% 00239400 + P5(DI ~ DI-1; DS ~ LIT"-") ; 00239500 + 00239600 + 00239700 + 00239800 + 00239900 + 00240000 + 00240100 + 00240200 + END;% 00240300 + 00240400 + GO TO COMMM ; 00240500 + COMMENT F PHRASE;% 00240600 + FTYPE: IF ABS(WH1 ~ WH1 | 1.0) > P(MAXN)% 00240700 + THEN GO TO AST; COMMENT INSURE NUMBER IS REAL AND NOI% 00240800 + TO BIG;% 00240900 + IF NOT UTYP THEN FINDE ;%FINDE SETS F=[LOG10(ABS(WH1))]. 00241000 + RFIN: IF (E + (DA ~ D)) > 10 THEN GO TO FD;% 00241100 + COMMENT DA ~ DECIMAL PLACES. IF D+E>10, MORE THEN% 00241200 + 11 DECIMAL PLACES SO MUST DO SPECIAL ROUND;% 00241300 + DH2 ~ WH1 | (JUNK2 ~ TEN[D]);% 00241400 + COMMENT SHIFT NUMBER LEFT D PLACES THEN ROUND IT% 00241500 + OFF BY DOING INTEGER STORE IN DH2;% 00241600 + FA: SGN ~ DH2 < 0;% 00241700 + DH1 ~ (DH2 ~ ABS(DH2)) DIV P(TEN8);% 00241800 + IF DH2 } JUNK2 THEN GO TO FB;% 00241900 + COMMENT NUMBER IS LESS THEN ONE, WILL SIGN FIT;% 00242000 + IF P(WT-SGN, DUP) < 0 THEN GO TO ASTA;% 00242100 + COMMENT ASTA IF SIGN DONT FIT;% 00242200 + LZ ~ P ! (JUNK1~0); 00242300 + COMMENT JUNK1 = # OF INTEGER DIGITS TO PRINT.% 00242400 + IF WT-SIGN = 0 THEN JUNK1=0= DONT PRINT LEADING 00242500 + ZERO.% 00242600 + IF WT-SIGN > 0 THEN JUNK1=1= DO PRINT LEADING% 00242700 + ZERO;% 00242800 + GO FC ; 00242895 + MAXN::: @0007777777777777 ; 00242900 + COMMENT NUMBER } 1. CHECK IF ON ROUND WE OVERFLOWED% 00243000 + INTO NEXT POWER OF TEN;% 00243100 + FB: IF ((JUNK1 ~ E + (IF DH2 } TEN[E+1+DA] THEN 2% 00243200 + ELSE 1))% 00243300 + + SGN ) > WT THEN GO TO AST;% 00243400 + COMMENT FOR NUMBERS } 1, E = ONE LESS THAN THE% 00243500 + NUMBER OF DIGITS LEFT OF THE DECIMAL% 00243600 + POINT. IN JUNK1 WE SAVE EITHER E+1 OR% 00243700 + E+2,DEPENDING ON IF ROUND OVERFLOW% 00243800 + OCCURED. ALSO WE COMPARE JUNK1 + SIGN% 00243900 + WITH WT. THIS TELLS US IF THE NUMBER% 00244000 + WILL FIT THE FIELD. WT = TOTAL NUMBER% 00244100 + OF POSITIONS AVAILABLE FOR INTEGER DIGITS% 00244200 + + SIGN;% 00244300 + FC: COMMENT NOW WE CONVERT. NOTE THAT NUMBER% 00244400 + IS NOW AN INTEGER IN THE FORM N--N*N--N.% 00244500 + , DENOTES TRUE DECIMAL POINT% 00244600 + . DENOTES MACHINE POINT% 00244700 + ZEROS CONTAINS # OF TRAILING ZEROS% 00244800 + JUNK1 CONTAINS # DF DIGITS LEFT OF *% 00244900 + DA CONTAINS # OF DIGITS BETWEEN * &.% 00245000 + NOTE THAT WH2 + ZEROS ALWAYS = D.% 00245100 + THE STREAM PROCEDURE WILL CONVERT THE% 00245200 + NUMBER IN TWO PARTS (ALREADY SET UP IN% 00245300 + DH1 AND DH2). IT WILL THEN MOVE JUNK1 #% 00245400 + OF DIGITS LEFT AND INSERT THE DECIMAL% 00245500 + POINT. ALSO THE SIGN AND TRAILING ZEROS% 00245600 + ARE INSERTED;% 00245700 + D1~DA+JUNK1-(D2~IF P(JUNK1 +DA,DUP) > 8 THEN P(8,SUB)% 00245800 + ELSE P(DEL,0));% 00245900 + STREAM(P9~0:P8~JUNK1+LZ,P7~ZEROS,P6~[DH1],P5~SGN, 00246000 + P4~D1,P3~D2,P2~SKIP+WT-JUNK1-LZ+USKIP,PU~UTOP, 00246100 + PFF~FFTYP, 00246105 + PCH~FFCHR, 00246107 + LZ, 00246108 + P1 ~ BUFF) ; 00246110 + BEGIN% 00246200 + P2(DS~LIT " "); COMMENT INSERT LEADING BLANKS;% 00246300 + P1~DI; COMMENT SAVE ADDRESS OF MSD;% 00246400 + DI~DI+1; COMMENT LEAVE ROOM FOR INTEGER% 00246500 + PART;% 00246600 + LZ(DS~LIT"0"); 00246650 + SI ~P6;% 00246700 + DS~P3 DEC; COMMENT CONVERT HIGH PART;% 00246800 + SI~P6;% 00246900 + SI~SI+8;% 00247000 + DS~P4 DEC; COMMENT CONVERT LOW HALF;% 00247100 + P7(DS~LIT"0"); COMMENT INSERT TRAILING ZEROS;% 00247200 + PFF(SI~LOC P1; SI~SI-1; DS~CHR) ; 00247205 + PU(DS ~ LIT" ") ; 00247210 + P9~DI; COMMENT ADDRESS OF NEXT FIELD;% 00247300 + SI~P1;% 00247400 + SI~SI+1;% 00247500 + DI~P1; COMMENT MOVE INTEGER PART LEFT;% 00247600 + DS~P8 CHR;% 00247700 + DS~LIT".";% 00247800 + P5(DI ~ P1; DI ~ DI-1; DS ~ LIT"-") ; 00247900 + 00248000 + 00248100 + 00248200 + 00248300 + 00248400 + 00248500 + END;% 00248600 + 00248700 + GO TO COMMM ; 00248800 + FD: COMMENT MORE THEN 11 SIGNIFICANT DIGITS SO WE HAVE% 00248900 + TO DO SPECIAL ROUND;% 00249000 + DA ~ D -(ZEROS ~ E+D-11);% 00249100 + COMMENT FIRST GUESS AT TRAILING ZEROS;% 00249200 + RNDOFF;% 00249300 + GO TO FA;% 00249400 + COMMENT E PHRASES;% 00249500 +ETYPE: IF D + 6 > W THEN GO TO AST; 00249600 + SGN ~ (WH1 ~ WH1 | 1.0) < 0; 00249650 + FINDE; COMMENT E ~ EXPONENI;% 00249700 + ETYPE1: P(1) ; %%% RETURN LITERAL USED AT REDT. 00249800 + REIN: IF (DA~D-1) > 10 THEN GO TO EB; COMMENT SPECIAL ROUND OFF 00249900 + IF MORE THEN 11 SIGNIFICANT DIGITS;% 00250000 + P(0); COMMENT SET LITERAL TO NOT ADJUST D2 AT ERTN;% 00250100 + DH2 ~ (IF (E-D) } 0% 00250200 + THEN WH1 / TEN[E-D+1]% 00250300 + ELSE WH1 | TEN[D-1-E]);% 00250400 + EA: COMMENT NUMBER NOW IN FORM OF N*N----N.% 00250500 + WHERE * = TRUE DECIMAL POINT% 00250600 + E = EXPONENT% 00250700 + . = MACHINE POINT% 00250800 + DA = # OF DIGITS BEIWEEN * S .% 00250900 + DA + ZEROS = % 00251000 + STORING IN DH2 ROUNDS NUMBER;% 00251100 + IF ( DH2 ~ ABS(DH2)) } TEN[DA+1]% 00251200 + THEN BEGIN% 00251300 + DH2 ~ TEN[DA];% 00251400 + E ~ E + 1;% 00251500 + END;% 00251600 + COMMENT IF ROUND OVERFLOWED THE LEADING DIGIT FROM 9 TO% 00251700 + 10 WE SET OUR NUMBER TO 1.0 AND INCREASE% 00251800 + EXPONENT BY ONE;% 00251900 + DH1 ~ DH2 DIV P(TEN8);COMMENT SINCE HARDWARE 0AN CONVERT% 00252000 + ONLY 8 DIGITS WE SPLIT NUMBER IN IWO% 00252100 + PARTS AT 8 TH DIGIT;% 00252200 + IF FALSE THEN 00252210 +TEN8::: @1045753604000000 ; 00252220 + STREAM(P10~0:P9 ~ ABS(E),P8 ~ ( E<0),P7 ~ SGN,% 00252300 + P6 ~ ZEROS,P5 ~ [DH1],P4 ~ D2,P3 ~ D1,% 00252400 + P2 ~ SKIP, PU ~ UTOP ,PES ~ UES, 00252500 + PFF ~ FFTYP, 00252505 + PCH~FFCHR, 00252507 + PED ~ UED,PDC ~ UDC,PMD ~ UMD, P1 ~ BUFF) ; 00252510 + BEGIN% 00252600 + P2(DS~LIT" "); COMMENT INSERT LEADING BLANKS;% 00252700 + P1~DI; COMMENT SAVE ADDRESS OF INIEGER% 00252800 + DIGIT;% 00252900 + P7(DI ~ DI-1; DS~LIT"-"); 00253000 + 00253100 + 00253200 + 00253300 + 00253400 + 00253500 + 00253600 + PDC(DI~DI+1 ; COMMENT SAVE ROOM FOR INTEGER 00253700 + DIGIT;% 00253800 + SI~P5;% 00253900 + DS~P4 DEC) ; COMMENT CONVERT HIGH HALF ; 00254000 + PMD(SI~P5 ; 00254100 + SI~SI+8;% 00254200 + DS~P3 DEC; COMMENT CONVERT LOW HALF;% 00254300 + P6(DS~LIT"0")) ;COMMENT INSERT TRAILING ZEROS ; 00254400 + DS~LIT "@";% 00254500 + PES(DS~LIT"+"; P8(DI~DI-1; DS~LIT"-")) ; 00254600 + 00254700 + 00254800 + 00254900 + 00255000 + SI~LOC P9; COMMENT CONVFRT EXPONENT;% 00255100 + DS ~ PED DEC; 00255200 + PFF(SI~LOC PED; SI~SI-1; DS~CHR) ; 00255205 + PU(DS ~ LIT" ") ; 00255210 + P10~DI; COMMENT ADDRESS OF NEXT FIELD;% 00255300 + PDC(SI~P1 ; 00255400 + SI~SI+1;% 00255500 + DI~P1; COMMENT MOVE INTEGER DIGIT LEFT; 00255600 + DS~CHR;% 00255700 + DS~LIT".") ; 00255800 + END;% 00255900 + BUFF ~ P;% 00256000 + ERTN: IF P THEN D2 ~ D-8;% 00256100 + REOT: IF NOT P THEN GO TO RRTN; COMMENT OUT IF FROM RTYPE;% 00256200 + GO TO COMM;% 00256300 + EB: COMMENT MORL THEN 11 SIGNIFICANT DIGITS% 00256600 + REQUESTED SO DO SPECIAL ROUND;% 00256700 + DA ~ D-1-(ZEROS~ D-12);% 00256800 + WH1 ~ (IF E>0 THEN WH1 / TEN[E]% 00256900 + ELSE WH1 | TEN[-E]);% 00257000 + COMMENT NUMBER NOW IN FORM N.NNN WITH EXPONENI IN E; 00257100 + RNDOFF; COMMENT ROUND OFF NUMBER;% 00257200 + D2 ~ DA - 7;% 00257300 + P(1); COMMENT SET KEY TO ADJUST D2 AT ERTN;% 00257400 + GO TO EA;% 00257500 + COMMENT R PHRASE;% 00257600 + RTYPE: WH1 ~ IF SCFTR } 0 THEN WH1 | TEN[SCFTR]% 00257700 + ELSE WH1 / TEN[-SCFTR];% 00257800 + FINDE;% 00257900 + SGN ~ WH1 < 0;% 00258000 + IF ABS(WH1) > P(MAXM) THEN GO TO TRYE;% 00258100 + IF E } 0 THEN% 00258200 + BEGIN COMMENT CHECK IF IT WILL GO AS F FIELD;% 00258300 + IF (E+2+D+SGN) { W THEN% 00258400 + BEGIN COMMENT YES- IT WILL;% 00258500 + RC: SKIP ~ W-(D+1+WT);% 00258600 + GO TO RFIN% 00258700 + END ELSE GO TO TRYE; COMMENT TO BIG FOR F;% 00258800 + END% 00258900 + ELSE% 00259000 + BEGIN COMMENT NUMBER IS LSS THEN 1. SEE IF IT WILL% 00259100 + GO AS F FIELD WITHOUT LOSS IN REQUESTLD% 00259200 + ACCURACY;% 00259300 + IF ABS(E) { D THEN GO TO RC;% 00259400 + COMMENT TO RC IF IT WILL GO AS F FIELD;% 00259500 + END;% 00259600 + COMMENT SEE IF NUMBER WILL FIT IN E FIELD;% 00259700 + TRYE: IF W < (D+6+SGN) THEN% 00259800 + BEGIN COMMENT FIELD TO SMALL FOR E. IF% 00259900 + NUMBER < 1 PRINT AS F FIELD EVEN THOUGH% 00260000 + ACCURACY IS LOST. FILL FIELD WITH * IF% 00260100 + NUMBER } 1;% 00260200 + IF E < 0 THEN GO TO RC% 00260300 + ELSE GO TO AST;% 00260400 + END;% 00260500 + COMMENT NUMBER WILL FIT AS E FIELD,ADJUST PARAMETERS SO% 00260600 + ETYPE CAN HANDLE;% 00260700 + SKIP ~ W-(D+6);% 00260800 + IF (D ~ D+1) > 8 THEN BEGIN D1~8; D2 ~ D-8 END% 00260900 + ELSE BEGIN D1~D; D2 ~ 0 END;% 00261000 + P(0); COMMENT FLAG USED AT REOT TO RETURN CONTROL TO% 00261100 + RRTN;% 00261200 + GO TO REIN;% 00261300 + RRTN: IF (D ~ D-1) > 8 THEN BEGIN D1~8; D2 ~ D-8 END% 00261400 + ELSE BEGIN D1~D; D2 ~ 0 END;% 00261500 + GO TO COMM;% 00261600 + MAXM::: @0007777777777777;% 00261700 + COMMENT AFTER FORMATING A PHRASE WE COME HERE;% 00261800 + COMMM: BUFF~P ; 00261810 + COMM: IF CODE > 2 THEN WH1 ~ LISX;% 00261900 + IF P((FFTYP=0),SUB,DUP) > 0 THEN GO TO INLOOP ; 00262000 + P(DEL);% 00262100 + GO TO S1;% 00262200 + COMMENT THE OF PHRASE IS IN TOP OF SIACK.% 00262300 + IF REPEAT-1 > 0 THEN GO TO INLOOP TO USE SAME PHRASE 00262400 + AGAIN ELSE DELETE THE "0" REPEAT AND GO TO S1 TO% 00262500 + PICK UP NEXT PHRASE;% 00262600 + END OUTPUTINT;% 00262700 +COMMENT ALGOL SELECT INTRINSIC;% 00300000 +PROCEDURE ALGOLSELECT(ACT1,ACT2,TANK,I); VALUE ACT1,ACT2,TANK,I;% 00300100 + INTEGER ACT1,ACT2,I; NAME TANK;% 00300200 +BEGIN ARRAY FIB[*]; NAME MEM=2; ARRAY FPB=3[*];% 00300300 + ARRAY HEADER[*];% 00300400 + LABEL REW,L6,MYUSERR ; 00300500 + REAL RITE=12,REED=13,SELECT=14;% 00300600 + INTEGER STATUS,NBUFFS,BSIZE,T1,INOUT,DIREC,UTYPE;% 00300700 + LABEL OWT,EASY,EXIT,FILL;% 00300800 + DEFINE IOD=(*TANK)#;% 00300900 + LABEL WR,ERR,RF,RR;% 00301000 + LABEL DC19; 00301010 + SWITCH CURRENT~WR,ERR,RF,RR;% 00301100 + LABEL CR,LP,MT,DK,SP,CP,PP,PR,DC;% 00301200 + SWITCH USW~ CR,LP,MT,EASY,DK,SP,CP,LP,PP,PR,DC,CR,LP,DC19; 00301300 + REAL SUBROUTINE COUNT;% 00301400 + BEGIN FOR I~0 STEP 1 UNTIL NBUFFS-1 DO% 00301500 + BEGIN IF NOT TANK[I].[19:1] THEN% 00301600 + P([TANK[I]],@2000000000,2,COM,DEL,DEL);% 00301700 + IF TANK[I].[27:1] THEN 00301800 + BEGIN 00301805 + I ~ I+1-(FIB[4].[2:1] AND FIB[5].[44:1]); 00301810 + P(1); GO OWT; 00301820 + END; 00301830 + END; P(0);% 00301900 + OWT: COUNT~P;% 00302000 + END COUNT;% 00302100 + SUBROUTINE SPACE; P(XCH,TANK,9,11,COM,DEL,DEL,DEL);% 00302200 + SUBROUTINE MOVEUP;% 00302300 + IF (I~MEM[FIB[16] INX 1])!BSIZE THEN% 00302400 + BEGIN TANK[0]~IOD&(P(DUP).[33:15]-BSIZE+I)[33:33:15];% 00302500 + T1~FIB[16].[33:15];% 00302600 + STREAM(N~I+1,L~0,S~T1-I,D~T1-BSIZE);% 00302700 + BEGIN SI~LOC N; SI~SI+6; DI~LOC L; DI~DI+7; DS~CHR;% 00302800 + SI~S; DI~D; DS~N WDS; L(DS~32 WDS; DS~32 WDS);% 00302900 + END END;% 00303000 + SUBROUTINE REFILL;% 00303100 + BEGIN FOR I~0 STEP 1 UNTIL NBUFFS-1 DO% 00303200 + TANK[I]~TANK[I]&1[19:47:1]&DIREC[22:47:1] OR MEM;% 00303300 + IF NBUFFS >1 THEN% 00303400 + BEGIN;STREAM(T~IOD,N~NBUFFS-1,D~TANK);% 00303500 + BEGIN SI~D; SI~SI+8; DS~N WDS; SI~LOC T; DS~WDS END;% 00303600 + P(2&(NOT DIREC)[1:47:1],TANK,10,11,COM,DEL,DEL,DEL);% 00303700 + END END REFILL;% 00303800 + SUBROUTINE EMPTY;% 00303900 + BEGIN FIB[17]~BSIZE-(IOD.[33:15]-(STATUS=3)-ACT2~FIB[16].[33:15]);00304000 + FIB[16]~FIB[16]&0[22:22:1]&0[24:24:1];% 00304100 + FIB[19]~FIB[19]&0[22:22:1]&0[24:24:2];% 00304200 + FIB[13]~FIB[13]&0[25:25:1]&0[27:27:1];% 00304300 + FIB[5].[43:2]~0;% 00304400 + TANK[NOT 1]~P(DUP,LOD)&0[22:22:1]&0[24:24:1];% 00304500 + BSIZE~IF STATUS=0 THEN MEM[ACT2-1] ELSE IOD.[8:10];% 00304600 + FOR I~0 STEP 1 UNTIL NBUFFS-1 DO% 00304700 + BEGIN TANK[I]~TANK[I]&1[19:47:1]&0[22:22:1]&0[24:24:1]% 00304800 + &FIB[18][8:38:10] OR MEM;% 00304900 + IF I>0 THEN% 00305000 + TANK[I]~TANK[I]&((STATUS=3)+ACT2)[33:33:15];% 00305100 + ACT2~MEM[ACT2-2].[18:15];% 00305200 + END END EMPTY;% 00305300 + IF I = 6 THEN GO TO L6; 00305400 + IF I=7 THEN GO TO MYUSERR ; 00305410 + TANK~((I-1) INX *P(.TANK))&0[8:8:25];% 00305500 + FIB~TANK[NOT 2]; STATUS~FIB[5]; UTYPE~FIB[4].[8:4];% 00305600 + IF I=4 THEN IF STATUS.[42:1]=0 THEN% 00305700 + BEGIN;STREAM(S~[FPB[FIB[4].[13:11]+2]],D~[NBUFFS]);% 00305800 + BEGIN SI~S; DS~3 OCT END;% 00305900 + IF FIB[1]=0 THEN FIB[1]:=NBUFFS; 00305950 + BSIZE~FIB[13].[28:10];% 00306000 + IF (ACT1 OR 4)=6 THEN T1~@12 ELSE% 00306100 + IF ACT1=4 THEN T1~@22 ELSE% 00306200 + IF ACT1=8 THEN T1:=@52 ELSE 00306250 + IF ACT1=0 THEN% 00306300 + IF FIB[15].[24:6] LSS 16 AND NBUFFS GTR FIB[1] 00306350 + THEN T1:=@12 ELSE T1:=IF NBUFFS EQL BSIZE 00306400 + THEN 6 ELSE @12 ELSE 00306500 + IF ACT1 = 1 THEN 00306600 + BEGIN NBUFFS:=BSIZE; T1:=7; IF UTYPE = 4 THEN 00306610 + BEGIN HEADER:=*[FIB[14]]; 00306620 + IF(DIREC:=FIB[7]-1) GTR (INOUT:=HEADER[7]) THEN 00306630 + DIREC:=INOUT;INOUT:=(DIREC DIV HEADER[0].[30:12])+1; 00306640 + END END ELSE T1:=0; 00306650 + P(TANK&T1[18:33:15],6,11,COM,DEL,DEL);% 00306700 + FIB[13].[28:10]:=IF FIB[15].[24:6] LSS 16 AND NOT ACT1 00306800 + THEN FIB[1] ELSE NBUFFS; IF ACT1 AND UTYPE =4 THEN 00306805 + BEGIN FIB[6]:=INOUT; FIB[7]:=DIREC; END; GO TO EXIT; 00306810 + END ELSE GO TO EXIT ELSE% 00306900 + IF STATUS.[41:2]!0 THEN% 00307000 +EASY: BEGIN FIB[13]~FIB[13]&(ACT2=3)[25:47:1]&(ACT2!0)[27:47:1];% 00307100 + GO TO EXIT;% 00307200 + END;% 00307300 + GO TO USW[UTYPE];% 00307400 +MT: NBUFFS~FIB[13].[10:9]; BSIZE~FIB[18].[18:15];% 00307500 + INOUT~ACT2!0; DIREC~ACT2=3; STATUS~STATUS.[46:2];% 00307600 + GO TO CURRENT[FIB[5].[43:2]];% 00307700 +CR: LP: CP: PP: PR: GO TO ERR; 00307800 + $ SET OMIT = NOT(TIMESHARING) 00307801 +DC: 00307805 + $ POP OMIT 00307808 +DC19: POLISH(IOD, [TANK[1]], *P(DUP), TANK, ~, ~); 00307810 + FIB[5] ~ (*P(DUP))&P(DUP, LNG)[43:43:1]; GO TO EASY; 00307820 + $ SET OMIT = TIMESHARING 00307825 +WR: IF NOT DIREC THEN 00307900 +ERR:: P(TANK,8,11,COM);% 00308000 +SP: P(MKS,1,0,(NOT 2) INX TANK,4,SELECT); GO TO EASY;% 00308100 +RF: IF INOUT THEN% 00308200 + BEGIN T1~COUNT; P((-I)); SPACE;% 00308300 + IF (I~MEM[FIB[16] INX NOT 0])!BSIZE THEN% 00308400 + BEGIN;STREAM(N~I+1,NDIV64~(I+1) DIV 64,% 00308500 + S~FIB[16] INX (NOT 0) INX I,% 00308600 + D~FIB[16] INX (NOT 0) INX BSIZE);% 00308700 + BEGIN SI~S; N(DS~WDS; SI~SI-16; DI~DI-16);% 00308800 + NDIV64(2(32(DS~WDS; SI~SI-16; DI~DI-16)));% 00308900 + END;% 00309000 + TANK[0]~(BSIZE-I) INX IOD;% 00309100 + END;% 00309200 + FIB[17]~I-(IF FIB[17]=0 THEN I ELSE FIB[17])% 00309300 + +(STATUS!0)|IOD.[8:10]+(STATUS=3);% 00309400 + FIB[16]~(BSIZE-1) INX FIB[16]&1[22:47:1];% 00309500 + FIB[19]~FIB[19]&(FIB[16] INX (STATUS!3)% 00309600 + -(STATUS=1)|FIB[18].[33:15])[33:33:15]% 00309700 + &(IF STATUS=0 THEN FIB[19].[3:5]+2 ELSE% 00309800 + IF STATUS=1 THEN 5 ELSE 7)[3:43:5]&1[22:47:1];% 00309900 + FIB[5].[43:2]~3; FIB[13].[25:1]~1;% 00310000 + TANK[NOT 1]~P(DUP,LOD)&1[22:47:1];% 00310100 + MEM[FIB[16] INX 1]~I;% 00310200 + MEM[FIB[16] INX NOT(I-1)]~I;% 00310300 +FILL: REFILL;% 00310400 + P(MKS,0,1,TANK,REED,MKS,0,0,TANK,REED);% 00310500 + END ELSE% 00310600 + BEGIN IF COUNT THEN IF I=1 THEN% 00310700 + BEGIN P(MKS,1,0,(NOT 2) INX TANK,4,SELECT);% 00310800 + FIB[13].[25:1]~1;% 00310900 + P(TANK,0,11,COM,DEL,DEL);% 00311000 + P(MKS,ACT1,0,TANK,1,SELECT);% 00311100 + GO TO EXIT;% 00311200 + END;% 00311300 + P((-I)); SPACE; EMPTY;% 00311400 + END;% 00311500 + GO TO EXIT;% 00311600 +RR: IF INOUT THEN% 00311700 + BEGIN T1~COUNT; P(I); SPACE; MOVEUP;% 00311800 + FIB[17]~I-(IF FIB[17]=0 THEN I ELSE FIB[17])+(STATUS=3)% 00311900 + +(STATUS!0)|IOD.[8:10];% 00312000 + FIB[16]~FIB[16]&P(DUP,1,INX,BSIZE,-)[33:33:15]&0[22:22:1];% 00312100 + FIB[19]~FIB[19]&(FIB[16] INX (STATUS=3))[33:33:15]&0[22:22:1]% 00312200 + &(P(DUP).[3:5]-STATUS&(NOT STATUS)[46:46:1])[3:43:5];% 00312300 + TANK[NOT 1]~P(DUP,LOD)&0[22:22:1];% 00312400 + FIB[5].[43:2]~2; FIB[13].[25:1]~0; GO FILL;% 00312500 + END;% 00312600 + IF COUNT THEN IF I=1 THEN% 00312700 + BEGIN P(MKS,0,0,(NOT 2) INX TANK,4,SELECT); GO TO EASY END;% 00312800 + P(I-1); SPACE; MOVEUP;% 00312900 + FIB[16]~FIB[16]&P(DUP,1,INX,BSIZE,-)[33:33:15];% 00313000 + FIB[19]~(STATUS=3) INX FIB[16]&FIB[18] [8:38:10];% 00313100 + EMPTY;% 00313200 + P(MKS,0,0,0,(-1),TANK, RITE,MKS,0,0,0,BSIZE,TANK, RITE);% 00313300 + GO TO EXIT;% 00313400 +% 00313500 +DK:: IF FIB[4].[27:3]=1 THEN% 00313600 + BEGIN FIB[5].[43:2]~ACT2;% 00313700 + FIB[16].[24:1]~ACT2~ACT2!0;% 00313800 + FIB[19]~FIB[19]&ACT2[24:47:1]&0[25:47:1]; 00313900 + END ELSE% 00314000 + IF FIB[4].[27:3]=0 THEN% 00314100 +REW:% 00314200 + BEGIN IF ACT2=1 THEN ACT2~FIB[5].[43:2]ELSE% 00314300 + IF ACT2=4 THEN ACT2~0 ELSE% 00314400 + IF ACT2=3 THEN ACT1~FIB[7]-1 ELSE% 00314500 + IF FIB[5].[43:2]=3 THEN ACT1~FIB[7]+1 ELSE% 00314600 + ACT1~FIB[7];% 00314700 + P(MKS,0,0,(NOT 2)INX TANK,4,SELECT);% 00314800 + FIB[13]~FIB[13]&(ACT2=3)[25:47:1]&(ACT2!0)[27:47:1];% 00314900 + FIB[7]~ACT1;% 00315000 + P(TANK,0,11,COM,DEL,DEL);% 00315100 + END ELSE% 00315200 + BEGIN IF ACT2=3 THEN GO TO ERR;% 00315300 + IF ACT2=1 OR ACT2=4 THEN GO TO REW;% 00315400 + IF ACT2=0 THEN BEGIN HEADER~*[FIB[14]];% 00315500 + IF FIB[7]>HEADER[7] THEN% 00315600 + HEADER[7]~FIB[7];% 00315700 + P(MKS,0,1,TANK,REED,MKS,0,0,TANK,REED);00315800 + END ELSE% 00315900 + P(MKS,1,0,0,(-1),TANK,RITE,% 00316000 + MKS,1,0,0,FIB[18].[33:15],TANK,RITE);% 00316100 + GO TO EXIT; 00316200 + END; GO EXIT; 00316300 +L6: FIB ~ *TANK; TANK ~[TANK[3]]; % SORT REEL SWITCHING 00316400 + IF ACT1 = 1 THEN 00316500 + BEGIN % I/O COMPLETE BUT NOT PRESENT 00316600 + IF NOT (*TANK).[27:1] THEN % PARITY 00316700 + P(1,[TANK[NOT 2]],19,17,COM) % TERMNATE ON PARITY 00316800 + ELSE 00316900 + BEGIN % EOF OR EOR 00317000 + P(TANK,11,11,COM,DEL,DEL); % READ ENDING LABEL 00317100 + IF MEM[TANK[NOT 1] INX 4].[42:6] =0 THEN P(1,RTN); %EOF 00317200 + T1~ FIB[13].[28:10] + 1; % REEL # + 1 00317300 + P(MKS,4,0,[TANK[NOT 2]],4,SELECT); % CLOSE PURGE 00317400 + FIB[13].[28:10] ~ T1; 00317500 + P([TANK],0,11,COM); P(0,RTN); 00317600 + END; 00317700 + END; 00317800 + IF ACT1 = 0 THEN % REEL SWITCH ON OUTPUT 00317900 + BEGIN 00318000 + HEADER ~ TANK[NOT 1]; HEADER[4].[42:6] ~ 1; % EOR FLAG 00318100 + T1 ~ FIB[13].[28:10] + 1; 00318200 + P(MKS,7,0,[TANK[NOT 2]],4,SELECT); 00318300 + FIB[13].[28:10] ~ T1; 00318400 + P( TANK,0,11,COM); P(XIT); 00318500 + END; 00318600 + IF ACT1 = 2 THEN % REWIND OUTPUT 00318700 + BEGIN 00318800 + T1 ~ IF FIB[13].[28:10] = 1 THEN 0 ELSE 7; 00318900 + P(MKS,T1,0,[TANK[NOT 2]],4,SELECT); P(XIT); 00319000 + END; P(XIT); 00319100 +MYUSERR: %%% BRANCH TO HERE IF I=7; 00319110 + P(TANK[NOT 3]); TANK[NOT 3]~TANK[NOT 4]~0; P(MKS,9,JUNK,DEL) ; 00319120 + FIB~TANK[NOT 2]; HEADER~P([HEADER[1]],CFX,SFB) & 10[8:38:10] ; 00319130 + STREAM(P1~ACT2,P2~[FPB[FIB[4].[13:11]]],P3~FIB[5].[11:2],HEADER) ; 00319140 + BEGIN DS~5LIT"-FAE("; SI~P2; SI~SI+1; DS~7CHR; SI~SI+1; 00319150 + DS~LIT"/"; TALLY~0; 7(IF SC=" " THEN JUMP OUT; SI~SI+1; 00319152 + TALLY~TALLY+1); SI~P2; SI~SI+9; P2~TALLY; DS~P2 CHR ; 00319154 + DS~7LIT".MYUSE="; SI~LOC P3; DS~DEC; DS~8LIT") TRIED " ; 00319160 + SI~LOC P1; SI~SI+2; DS~6CHR; DS~2LIT":~" ; 00319170 + END OF STREAM ; 00319180 + P([HEADER[0]].[33:15],34,COM) ; 00319190 +EXIT::% 00319200 +END SELECT;% 00319300 + PROCEDURE INTRINSIC(DUPE,D,NUMDIM,SIZE,TYPE);% 00400000 + VALUE DUPE,D,NUMDIM,SIZE,TYPE;% 00400100 + ARRAY DUPE[*];NAME D;% 00400200 + INTEGER NUMDIM,SIZE,TYPE;% 00400300 + BEGIN% 00400400 + NAME DUM=TYPE,A;% 00400500 + ARRAY DOPE=-8[*];% 00400600 + ARRAY PRTPOINTER=10[*];% 00400700 + REAL NUMBUFF=-7,IOT=-2,MODE=-6,FILENO=-9,BUFFSIZE=-5;% 00400800 + REAL DISPOSITION=-10,ROWSIZE=-11,NUMROWS=-12,RECSIZE=D;% 00400900 + NAME E;% 00401000 + INTEGER I,J,K;% 00401100 + REAL C;% 00401200 + BOOLEAN B;% 00401300 + ARRAY AIT=6[*];% 00401400 + REAL RECURSE=5; INTEGER BLOCKCTR=16;% 00401500 + NAME M=2; 00401600 + ARRAY FIB[*]; 00401700 +ARRAY FPB=3[*],SEGDICT=4[*]; 00401800 + INTEGER TIPE=-2,CYCLE=-3,DATE=-4,REEL=-5,FID=-6,MFID=-7; 00401900 + NAME FLE=-8; 00402000 + LABEL EXIT,AOK,UPDATEFPB; 00402100 + REAL PTR=-11,APTR=-10,LBO=-7,DIMO=-6,LBN=-5,DIMN=-4,MAXLB,MINUB, 00402200 + UBO,UBN,N,TP,H; 00402300 + ARRAY ARRY = MINUB[*]; 00402310 + INTEGER DIM1 = UBO, DIM2 = UBN; 00402320 + ARRAY OAT=11[*],NEW=-8[*],OLD=-9[*]; 00402400 + NAME MAT=-2,NAT; 00402500 + BOOLEAN OWNTOG,REDECLTOG,TASKARRAYTOG,AUXTOG; 00402600 + LABEL FOUND,ARROUNDFOUND,TY12; 00402700 + NAME PHILE=-10; 00402800 + LABEL TY0,TY1,TY2,TY3,TY4,TY5,TY6,TY7,TY8,TY9,TY10;% 00402900 + LABEL TY11,TY13,TY14,TY15,TY16,TY17,TY18,TY19; 00403000 + SWITCH SW~TY0,TY1,TY2,TY3,TY4,TY5,TY6,TY7,TY8,TY9,TY10,TY11, 00403100 + TY12,TY13,TY14,TY15,TY16,TY17,TY18,TY19; 00403200 + TASKARRAYTOG~TYPE.[1:1];AUXTOG~TYPE.[41:1];TYPE~TYPE AND @77; 00403250 + GO TO SW[TYPE];% 00403300 + TY0::TY1:TY2:TY3:% 00403400 + OWNTOG~TYPE.[46:1]; 00403500 + I~AIT[J~0];TYPE~TYPE+4;% 00403600 + E~P(NUMDIM-1+OWNTOG|(NUMDIM-1),NOT,[NUMDIM],INX); 00403700 + A~P(SIZE-1+OWNTOG,NOT,[E],INX);IF P([E[0]],DUP,LOD,XCH,ISN){0 OR 00403800 + E[0]>1023 THEN 00403900 + P(E[0],TRUE,1,29,COM); 00404000 + IF OWNTOG THEN BEGIN 00404100 + H~OAT[0];NAT~P(0,NOT,[E],INX); 00404200 + FOR K~1 STEP 1 UNTIL H DO 00404300 + IF A[J].[CF]=OAT[K].[1:15] THEN GO TO FOUND; 00404400 + FOR C~1 STEP 1 UNTIL SIZE DO 00404500 + OAT[H~H+1]~0&A[C-1] [1:33:15]; 00404600 + FOR C~1 STEP 1 UNTIL 2|NUMDIM DO 00404700 + P(NAT[C-1],[OAT[H~H+1]],ISD); 00404800 + OAT[0]~H;GO AOK; 00404900 + FOUND:REDECLTOG~TRUE; 00405000 + STREAM(R~0:NUMDIM,A~[OAT[TP~K+SIZE ]],B~[NAT] ); 00405100 + BEGIN SI~A;TALLY~1; 00405200 + NUMDIM(IF 16 SC!DC THEN TALLY~0); R~TALLY ; 00405300 + END; 00405400 + IF P(NOP) THEN GO TO EXIT; 00405500 + ARROUNDFOUND: A[J]~[PRTPOINTER[17]]; 00405600 + END; 00405700 +AOK:DO 00405800 + BEGIN% 00405900 + B~NUMDIM!1;C~((IF AUXTOG THEN 3 ELSE (TYPE.[47:1] OR B)) 00406000 + &A[J][CTF] & E[0][8:38:10]);% 00406100 + IF NOT OWNTOG THEN 00406200 + AIT[I~I+1]~C & TYPE[2:46:1]&BLOCKCTR[8:38:10]% 00406300 + &NUMDIM[3:43:5]; P(FLAG(C),A[J],STD);% 00406400 + IF TASKARRAYTOG THEN AIT[I].[1:2] ~ 3; 00406450 + IF B THEN% 00406500 + P(MKS,FLAG(C),[E[1+OWNTOG]],NUMDIM-1,E[0], 00406600 + TYPE&AUXTOG[41:47:1],RECURSE) % 00406700 + END% 00406800 + UNTIL ((J~J+1)=SIZE) OR REDECLTOG; 00406900 + IF REDECLTOG THEN 00407000 + BEGIN %REMAP 00407100 +P(MKS,TP+2,2,M[OAT[K].[1:15]],[PRTPOINTER[17]],LOD, 00407200 + OAT[TP],OAT[TP+1],NAT[0],NAT[1],NUMDIM,[NAT],12 00407300 + , RECURSE,[M[OAT[K].[1:15]]],LOD,NUMDIM,25,COM,DEL, 00407400 + DEL);K~K+1; 00407500 + IF J1023 THEN P(D[0],1,1,29,COM00408300 + ); DO 00408400 + BEGIN% 00408500 + B~NUMDIM!1; 00408510 + DUPE[K]~FLAG(C~((IF AUXTOG THEN 3 ELSE 00408600 + (TYPE.[47:1] OR B))% 00408700 + &[DUPE[K]][CTF]&D[0][8:38:10]));% 00408800 + IF B THEN% 00408900 + P(MKS,FLAG(C),[D[1+OWNTOG]],NUMDIM-1,D[0], 00409000 + TYPE&AUXTOG[41:47:1],RECURSE) % 00409100 + END% 00409200 + UNTIL(K~K+1)=SIZE% 00409300 +; GO TO EXIT;% 00409400 + TY12: 00409500 + IF LBO20 THEN 00412000 + P(NUMROWS,TRUE,2,29,COM); 00412100 + P(MKS,*P(.DOPE),(NUMBUFF=1)+NUMBUFF+27, 00412200 + 1,1,1,RECURSE); 00412210 + AIT[AIT[0]]~-AIT[AIT[0]];% 00412300 + DOPE~*[DOPE];% 00412400 + DOPE[2]~[DOPE[(NUMBUFF=1)+NUMBUFF+5]]&22[8:38:10]; 00412500 + DOPE[4]~[DOPE[5]];% 00412600 + DOPE[3]~0&10[8:38:10];% 00412700 + I~0;C~ @20002020000000 &(IOT!10)[24:47:1]&MODE% 00412800 + [27:47:1]&([DOPE[6]])[CTC];% 00412900 + WHILE(I~I+1){NUMBUFF DO% 00413000 + DOPE[I+4]~FLAG(C);% 00413100 + DOPE~*[DOPE[2]];% 00413200 + STREAM(T~[NUMDIM]); BEGIN SI~T; DS ~ 8 DEC END;% 00413300 + FILENO~(FILENO-1)|ETRLNG;% 00413400 + DOPE[4]~NUMDIM&FILENO[13:37:11]&1[12:47:1]&3[8:44:4]% 00413500 + &(IOT=11)[6:47:1]&DISPOSITION[25:46:2];% 00413600 + IF RECSIZE=0 THEN% 00413700 + BEGIN RECSIZE~BUFFSIZE; I~0 END ELSE% 00413800 + IF BUFFSIZE{RECSIZE THEN% 00413900 + BEGIN I~BUFFSIZE; BUFFSIZE~RECSIZE; RECSIZE~I; I~1 END% 00414000 + ELSE I~3;% 00414100 + DUPE[5]~I & (IOT!10)[43:47:1] & 1[42:47:1] & (IF TYPE~( 00414200 + TYPE~FPB[FILENO+3].[43:5])=1 OR TYPE=4 OR TYPE=6 00414205 + OR (TYPE>14 AND TYPE<19) THEN 2 ELSE 3)[11:46:2] 00414210 + & (IF TYPE THEN 0 ELSE 3)[9:46:2] & (IF TYPE THEN 00414215 + 4 ELSE 0)[13:45:3] ; 00414220 + STREAM(FB~[FPB[FILENO]],R~[I]);% 00414300 + BEGIN SI~FB; SI~SI+16; DS~3 OCT END;% 00414400 + DOPE[13]~0&NUMBUFF[1:39:9]&MODE[24:47:1]% 00414500 + &I[28:38:10]&NUMBUFF [10:39:9]% 00414600 + &(IOT!10)[27:47:1];% 00414700 + DOPE[18]~RECSIZE&BUFFSIZE[3:33:15]&BUFFSIZE[18:33:15];% 00414800 + DOPE[8]~ROWSIZE&NUMROWS[15:38:10];% 00414900 + $ SET OMIT = NOT SHAREDISK 00414949 + GO TO EXIT;% 00415000 + TY9::% 00415100 + BEGIN IF NUMDIM ! 0 THEN 00415200 + IF NUMDIM ! 15 THEN BEGIN 00415300 + IF (J ~ (C ~ NUMDIM).[8:10]) ! BLOCKCTR THEN% 00415400 + BEGIN BLOCKCTR ~ J+1;% 00415500 + P(10,COM);% 00415600 + END;% 00415700 + P(SIZE,.NUMDIM,~);% 00415800 + IF (J ~ C.[18:15]) = 0 THEN% 00415900 + J ~ PRTPOINTER.[18:15]+2;% 00416000 + DO UNTIL (*(PRTPOINTER&(J~HUNT(J+1) INX 0)[33:33:15])).% 00416100 + [1:3]=4 AND M[J].[6:12] !0; 00416200 + P((*[PRTPOINTER[C.[33:15]]])&J[18:33:15],BRT);% 00416300 + END END;% 00416400 + NUMDIM~0; 00416500 + GO TO EXIT;% 00416600 + TY10::% 00416700 + AIT[AIT[0]~AIT[0]+1] ~-2&1[8:38:10]&[SIZE][18:33:15];% 00416800 + GO TO EXIT;% 00416900 +TY11:: FIB~FLE[NOT 2]; 00417000 + IF FIB[5].[41:2] = 0 THEN GO TO EXIT; % FILE OPENED 00417100 + IF FIB[5].[42:1] THEN GO TO UPDATEFPB; % CLOSED,RELEASED 00417110 + IF FIB[4].[24:2] ! 1 THEN GO TO EXIT; % REWOUND 00417120 + IF FIB[4].[8:4] ! 2 THEN GO TO EXIT; % MUST BE TAPE 00417125 + MFID ~ TIPE ~ -0; % PREVENT CHANGE IN MFID OR TYPE 00417130 +UPDATEFPB: 00417140 + BEGIN 00417150 + STREAM(A~0:MFID,FID,REEL~REEL~REEL,DATE~DATE~DATE, 00417200 + CYCLE~CYCLE~CYCLE,TIPE~TIPE~TIPE, 00417300 + F~ I~ [FPB[FIB[4].[13:11]]]); 00417400 + BEGIN SI~LOC MFID; 00417500 + 2(IF SC="+" THEN BEGIN SI~SI+8; DI~DI+8 END ELSE 00417600 + IF SC="0" THEN DS~WDS ELSE BEGIN TALLY~1; A~TALLY; 00417610 + JUMP OUT TO ERR END); 00417620 + IF SC="+" THEN BEGIN SI~SI+8; DI~DI+3 END ELSE DS~3 DEC; 00417700 + IF SC="+" THEN BEGIN SI~SI+8; DI~DI+5 END ELSE DS~5 DEC; 00417800 + IF SC="+" THEN BEGIN SI:=SI+8;DI:=DI+2 END ELSE 00417900 + BEGIN DS~ DEC; DI~DI+1; END; 00417910 + IF SC!"+" THEN BEGIN SI~SI+7; DI~DI+5; DS~CHR END; 00418000 + ERR: END; 00418100 + IF P THEN P((-75),34,COM); % DS - INVALD FILE NAME 00418110 + IF REEL}0 THEN FIB[13].[28:10]~REEL END; 00418200 + I~ P(.I,LOD) INX 0; % MARK MFID OF REMOTE FILE 00418210 + IF M[I INX 3].[43:5]=19 THEN % WHICH HAS BEEN FILLED 00418220 + M[I]~ P(DUP,LOD,SSN); % SO FILE OPEN WILL KNOW 00418230 + GO TO EXIT; 00418300 + TY13:: C~1; I~AIT[J~0]; 00418400 + DO AIT[I~I+1]~(M[[TYPE]INX NOT C])&BLOCKCTR[8:38:10] 00418500 + &1[1:46:2] UNTIL(C~C+1)> SIZE; 00418600 + AIT[0]~I; GO EXIT; 00418700 + TY14:: IF TIPE<3 THEN TIPE~0 ELSE IF TIPE>5 THEN TIPE~5; %AS00418800 + IF TIPE!0 THEN DO % DECLARE SORT FILES %AS00418900 + BEGIN P(MKS,0,0,3,CYCLE+I,[D[I]],2,1,10,0,3,11,8,RECURSE 00419000 + ,D[I],5,CDC,@1612-I,~); %AS00419100 + END UNTIL (I~I+1)}TIPE; %AS00419200 + P(TIPE,RTN); %AS00419300 + COMMENT TY14 DECLARES SORT TAPE FILES FOR ALGOL; %AS00419400 + GO EXIT; 00419500 + TY15:: PHILE[NOT 3] ~ IOT; PHILE[NOT 4] ~ NUMDIM; GO TO EXIT; 00419600 + TY16:: TY17: TY18: 00419700 + E ~ M OR (*(P(.NUMDIM)+SIZE)).[18:15]; 00419705 + IF SIZE = 0 THEN COMMENT FISH OUT OLD SIZES TO USE; 00419710 + BEGIN;STREAM(A~0:S~*E); 00419715 + BEGIN TALLY~1; SI~S; SI~SI-16; SKIP 2 SB; 00419720 + IF SB THEN TALLY~2; A~TALLY; 00419725 + END STREAM; 00419730 + IF(SIZE:=P) THEN DIM2:=(*E).[8:10] ELSE 00419735 + DIM2:=P(*E,P(DUP).[8:10],.DIM1,STD,0,CDC,LOD).[8:10]; 00419740 + END ELSE BEGIN DIM2 ~ NUMDIM; 00419745 + IF NOT SIZE THEN DIM1 ~ RECSIZE; 00419750 + END; 00419755 + IF TYPE = 18 COMMENT "IDN" FUNCTION; 00419760 + THEN IF SIZE OR (DIM1 NEQ DIM2) THEN P((-54), 26, COM); 00419770 + POLISH(SIZE,E,39,COM,DEL,DEL); % RETURN OLD ARRAY : 00419780 + POLISH(MKS, E); IF NOT SIZE THEN P(DIM1); 00419790 + POLISH(DIM2, SIZE, 1, 0, RECURSE); 00419800 + ARRY ~ *E; DIM1 ~ DIM1-1; 00419810 + IF TYPE = 17 THEN COMMENT "CON" FUNCTIDN; 00419820 + BEGIN IF SIZE THEN P(*E, 2, CCX, E, ~) ELSE 00419830 + FOR I~1 STEP 1 UNTIL DIM1 DO 00419840 + POLISH([ARRY[I]], DUP, LOD, 2, CCX, XCH, ~); 00419850 + END; 00419860 + IF TYPE = 18 THEN COMMENT "IDN" FUNCTION AGAIN; 00419870 + FOR I~1 STEP 1 UNTIL DIM1 DO 00419880 + P(*[ARRY[I]], I, CDC, 1, XCH, ~); 00419890 + GO TO EXIT; 00419900 + TY19:: % IMPLEMENTED FOR COBOL 68 ARRAY DECLARATION 1 OR 2 DIM 00420000 + ARRY ~ *[PRTPOINTER[17]]; 00420100 + M[[ARRY[0]] INX NOT 1].[2:1] := 1; % MARK IT SAVE 00420105 + FOR I ~ 1 STEP 1 UNTIL ARRY[0] DO 00420110 + BEGIN 00420120 + C ~ ARRY[I]; 00420130 + P(MKS,[PRTPOINTER[C.[FF]]], 00420140 + P(DUP,LOD,P(DUP).[FF],P(XCH).[CF]), 00420150 + IF C.[17:1] THEN P(XCH,DEL) ELSE P, 00420160 + C.[16:2],1,C.[CF],RECURSE); 00420170 + END; 00420180 + SEGDICT[0] ~ *P(DUP)-1; % DELETE TEMP AIT 00420185 + P([PRTPOINTER[17]] INX M,3,COM,DEL); 00420190 + EXIT:: 00429900 +END INTRINSIC INTRINSIC; 00430000 +PROCEDURE FILEATTRIBUTES(TANK,ERRL,DUM1,VAL,NAM,INFO,TEN) ; 00430050 +VALUE TANK,DUM1,VAL,NAM,INFO,ERRL ; 00430100 +INTEGER VAL ; 00430150 +REAL ERRL,DUM1,NAM,INFO ; 00430200 +NAME TANK ; 00430250 +ARRAY TEN[*] ; 00430300 + BEGIN 00430350 + % THIS PROC HANDLES FILE ATTRIBUTES (FOR MORE INFO, REFER TO THE 00430400 + % ALGOL COMPILER, PROCEDURE FILEATTRIBUTEHANDLER, FOR A DESCRIPIION 00430450 + % OF THE VARIOUS KINDS OF FILE ATTRIBUTE CALLS). DUM1 IS A DUMMY 00430500 + % PARAMETER RESERVED FOR POSSIBLE FUTURE USE. 00430525 + % TO ADD A NEW ATTRIBUTE, FIRST MAKE THE APPROPIATE CHANGES IN 00430550 + % THE COMPILER(S). THEN, DECLARE TWO NEW LABELS, XN & XVN -- "X" IS 00430600 + % THE FILE ATTRIBUTE, E.G., ACCESS, AND "N" IS THE CORRESPONDING 00430650 + % SWITCH LABEL NUMBER, E.G., THE 4 IN MFID4 -- AND ATTACH XN ONTO 00430675 + % GETFILATT, AND ATTACH XVN ONTO THE SWITCH SETFILATT. THEN INSERT 00430700 + % XN: AND ITS CODE BELOW THE LAST XN-TYPE CODE, AND INSERT XVN: AND 00430750 + % ITS CODE BELOW THE LAST XVN-TYPE CODE. THE XN-TYPE CODE SETS THE 00430800 + % FILE ATTRIBUTE (AFTER MUCH CHECKING TO ASSURE THAT THE FILE IS OF 00430850 + % THE PROPER TYPE AND IN THE PROPER STATUS, AND THAT THE VALUE OF 00430900 + % VAL IS WITHIN THE PROPER BOUNDS), AND THE XVN-TYPE CODE RETRIEVES 00430950 + % AND STACKS THL FILE ATTRIBUTE. 00431000 + 00431050 + ARRAY FIB=+1[*],FPB=3[*] ; 00431100 + REAL FIB5=17,TYPE=9,FI=ERRL,SELECT=14,INTRINSIC=5, 00431110 + OPEN=FIB+1, 00431111 + NOTCLOSREL=OPEN+1, 00431112 + NOTDISK=NOTCLOSREL+1, 00431113 + RTNVAL=NOTDISK+1, 00431114 + TEMP=RTNVAL+1, 00431115 + PMET=TEMP+1, 00431116 + FPB3=DUM1,VALSIGN=FIB, 00431135 + MFIDX=OPEN,FIDX=NOTCLOSREL,REELX=NOTDISK,DATEX=FPB3, 00431140 + CYCLEX=FIB5,TYPEX=TYPE ; 00431155 + 00431175 + LABEL QUIT,EXIT,SETUSE,VALER,TOIT,BIG,CHK1,CHK2,CHK3L,CHK3T,MYUSERR,00431200 + OPENERR,CLOSRELERR 00431225 + ,ACCESS0,ACCESSV0 00431250 + ,MYUSE1,MYUSEV1 00431260 + ,SAVE2,SAVEV2 00431270 + ,OTHERUSE3,OTHERUSEV3 00431280 + ,MFID4,MFIDV4 00431290 + ,FID5,FIDV5 00431300 + ,REEL6,REELV6 00431310 + ,DATE7,DATEV7 00431320 + ,CYCLE8,CYCLEV8 00431330 + ,TYPE9,TYPEV9 00431340 + ,AREAS10,AREASV10 00431350 + ,AREASIZE11,AREASIZEV11 00431360 + ,EUNUM12,EUNUMV12 % EU NUMBER FOR DISK 00431370 + ,DSKSPEED13,DSKSPEEDV13 % FAST/SLOW DISK (1-FAST) 00431380 + ,TIMELIMIT14,TIMELIMITV14 % WAIT TIME FOR LOCKED ADDRESS (RLL)00431390 + ,IOSTATUS15,IOSTATUSV15 % LAST IO RESULT STATUS (RLL) 00431400 + ,SENSITIVE14,SENSITIVEV14 % SENSITIVE 00431410 + ; %%%% ADD NEW ATTRIBUTE LABELS ON A NEW LINE ABOVE ****************00431490 + %%%% AND BE SURE TO POST-FIX THE SWITCH NUMBER FOR DOCUMENTATION. 00431500 + SWITCH SETFILATT := 00431550 + ACCESS0 00431551 + ,MYUSE1 00431552 + ,SAVE2 00431553 + ,OTHERUSE3 00431554 + ,MFID4 00431555 + ,FID5 00431556 + ,REEL6 00431557 + ,DATE7 00431558 + ,CYCLE8 00431559 + ,TYPE9 00431560 + ,AREAS10 00431561 + ,AREASIZE11 00431562 + ,EUNUM12 00431563 + ,DSKSPEED13 00431564 + ,TIMELIMIT14 00431565 + ,IOSTATUS15 00431566 + ,SENSITIVE14 00431567 + ; %%%% ATTACH THE NEW XN-TYPE ATTRIBUTE LABEL ONTO SWITCH ABOVE ****00431850 + SWITCH GETFILATT := 00431900 + ACCESSV0 00431901 + ,MYUSEV1 00431902 + ,SAVEV2 00431903 + ,OTHERUSEV3 00431904 + ,MFIDV4 00431905 + ,FIDV5 00431906 + ,REELV6 00431907 + ,DATEV7 00431908 + ,CYCLEV8 00431909 + ,TYPEV9 00431910 + ,AREASV10 00431911 + ,AREASIZEV11 00431912 + ,EUNUMV12 00431913 + ,DSKSPEEDV13 00431914 + ,TIMELIMITV14 00431915 + ,IOSTATUSV15 00431916 + ,SENSITIVEV14 00431917 + ; %%%% ATTACH THE .EW XVN-TYPE ATTRIBUTE LABEL ONTO SWITCH ABOVE ***00432200 + DEFINE CANTUSE = 0 #, 00432250 + IO = 3 #, 00432259 + SERIAL = 0 #, 00432262 + RANDOM = 1 #, 00432265 + UPDATE = 2 #, 00432268 + PROTECT = 3 #, 00432269 + DISK = (NOT NOTDISK) #, 00432271 + HEADER[HEADER1] = P(HEADER1,14,.FIB,LOD,INX,LOD,INX,LOD) #, 00432274 + FRM(ERM1) = BEGIN 00432276 + INITERR; STREAM(FI); DS~13LIT ERM1; GO QUIT ; 00432277 + END #, 00432278 + CHKOPEN = BEGIN IF OPEN THEN GO OPENERR END #, 00432280 + CHKCLOSREL = BEGIN IF NOTCLOSREL THEN GO CLOSRELERR END #, 00432285 + CHKMYUSE = BEGIN IF FIB5.[11:2]=0 THEN GO MYUSERR END #, 00432290 + P = POLISH #; 00432475 + 00432480 + SUBROUTINE INITERR ; 00432500 + BEGIN 00432550 + PMET~P; FOR TEMP~P STEP -1 UNTIL 1 DO P(~); P(PMET) ; 00432560 + P(TANK[NOT 4]); TANK[NOT 4]~0; P(MKS,9,INTRINSIC,DEL) ; 00432600 + TEN~0; TEN~P([TEN[1]],CFX,SFB)&10[8:38:10] ; 00432700 + STREAM(TEMP~NAM:A~[FPB[FPB3-3]],N~NAM.[6:6],TEN) ; 00432750 + BEGIN DS~5LIT"-FAE,"; SI~A ; 00432800 + 2(SI~SI+1; A~SI; TALLY~0; 7(IF SC=" " THEN 00432850 + JUMP OUT; SI~SI+1; TALLY~TALLY+1); SI~A; A~TALLY ; 00432900 + DS~A CHR; DS~0DEC; DS~LIT"/"); DI~DI-1; DS~LIT" " ; 00432950 + SI~LOC TEMP; SI~SI+2; DS~N CHR; DS~2LIT", "; TEMP~DI ;00432975 + DI~DI+13; DS~2LIT":~" ; 00432980 + END STREAM ; 00433100 + FI~P ; 00433150 + END OF INITERR ; 00433200 + 00433220 + REAL SUBROUTINE OCTTODEC ; 00433230 + BEGIN 00433240 + STREAM(Q~0:VAL); BEGIN SI~LOC VAL; DI~LOC Q; DS~8DEC END ; 00433250 + OCTTODEC~P ; 00433260 + END OF OCTTODEC ; 00433270 + 00433275 + REAL SUBROUTINE DECTOOCT ; 00433280 + BEGIN PMET~P(XCH) ; 00433290 + STREAM(Q~0:PMET); BEGIN SI~LOC PMET; DI~LOC Q; DS~8OCT END ; 00433295 + DECTOOCT~P ; 00433300 + END OF DECTOOCT ; 00433310 + 00433325 + SUBROUTINE INITIALIZE ; 00433650 + BEGIN % INITIALIZES A FEW USEFUL VARIABLES. 00433660 + NOTDISK~NOT((NOTDISK~(TYPE~FPB[FPB3~FIB[4].[13:11]+3] AND 63) 00433670 + AND 31)=10 OR NOTDISK=12 OR NOTDISK=13 OR 00433675 + NOTDISK=26) ; 00433677 + NOTCLOSREL~NOT(OPEN~(FIB5~FIB[5]).[41:2]) ; 00433680 + OPEN~OPEN=0 ; 00433685 + END OF INITIALIZE ; 00433690 + 00433725 + SUBROUTINE SCATTERFPB ; 00433750 + STREAM(F~[FPB[FPB3-3]],D~[DATEX],C~[CYCLEX],M~[MFIDX]) ; 00433760 + BEGIN 00433775 + SI~F; 2(DS~LIT"0"; SI~SI+1; DS~7CHR); DS~3OCT ; 00433780 + DI~D; DS~5OCT; DI~C; DS~2OCT ; 00433785 + END OF SCATTERFPB ; 00433790 + 00435445 + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%00435446 + %%% 00435447 + %%% ******* F I R S T E X E C U T A B L E C O D E ********00435448 + %%% 00435449 + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%00435450 + 00435460 + P(TANK[NOT 2],0,0,0,0,0,0); TANK[NOT 4]~ERRL; INITIALIZE ; 00435480 + IF (FI~INFO AND 255)>3 AND FI<10 THEN SCATTERFPB ; 00435550 + IF NAM}0 THEN IF ABS(VAL)>@7777777777777 THEN GO VALER ELSE VAL~VAL;00435600 + IF INFO.[39:1] THEN IF INFO~INFO.[38:1] THEN RTNVAL~VAL 00435750 + ELSE BEGIN TANK[NOT 4]~0; GO GETFILATT[FI] END 00435800 + ELSE INFO~FALSE ; 00435825 + GO SETFILATT[FI] ; 00435850 + MYUSERR:: ERM("MYUSE=CANTUSE") ; 00435855 + CLOSRELERR:: ERM("NOT CLOSRELES") ; 00435860 + OPENERR:: INITERR; STREAM(FI); DS~13LIT"NOT RWND/CLSD" ; 00435870 + QUIT:: P([TEN[0]].[33:15],34,COM) ; 00435900 + 00435980 +ACCESS0: IF ((FI~TYPE AND 31)=12 AND VAL=SERIAL) 00436000 + OR (FI=10 AND VAL=RANDOM) OR (FI=13 AND VAL=UPDATE) 00436025 + $ SET OMIT = NOT SHAREDISK 00436049 + THEN GO EXIT; 00436075 + P(FPB[FPB3],[FPB[FPB3]],FIB[4],[FIB[4]],FIB[13],[FIB[13]],00436080 + 3) ; 00436085 + FPB[FPB3].[43:5]~FI~IF VAL=0 THEN 12 ELSE IF VAL=1 THEN 1000436180 + $ SET OMIT = NOT SHAREDISK 00436184 + ELSE 13 ; 00436190 + $ SET OMIT = SHAREDISK 00436194 + IF FIB[4].[27:3]!3 THEN FIB[4].[27:3]~VAL ; 00436195 + FIB[13].[39:5]~FI; P(UPDATE); GO CHK3T ; 00436200 + $ POP OMIT 00436201 + $ SET OMIT = NOT SHAREDISK 00436209 + 00436225 +MYUSE1: IF FIB5.[11:2]=VAL THEN GO EXIT ; 00436250 + IF P([FIB[14]],LOD).[FF]=2 THEN P(MKS,"CHNGNG",TANK,7, 00436260 + SELECT); 00436270 + FIB[5].[11:2]~FI~VAL; TEMP~FIB5.[9:2]; P(1); GO SETUSE;00436330 + 00436350 +SAVE2: IF FIB[4].[30:18]=PMET~OCTTODEC THEN GO EXIT ; 00436400 + P(FIB[4],[FIB[4]],1) ; 00436410 + FIB[4].[30:18]~PMET; P(999); GO CHK2 ; 00436520 + 00436550 +OTHERUSE3: IF FIB5.[9:2]=VAL THEN GO EXIT ; 00436600 + FI~FIB5.[11:2]; FIB[5].[9:2]~TEMP~VAL; P(0) ; 00436660 + SETUSE: PMET~P; P(FIB5,[FIB[5]],1) ; 00436670 + IF DISK THEN IF HEADER[4] THEN CHKCLOSREL ELSE CHKOPEN ; 00436675 + FIB[5].[13:3]~IF FI=0 THEN 7 ELSE IF TEMP=0 THEN 4 ELSE 00436680 + IF TEMP=1 THEN IF FI=1 THEN 3 ELSE 2 ELSE IF00436685 + FI=1 THEN 1 ELSE 0 ; 00436690 + P(IO); IF NOT PMET THEN GO CHK2; GO CHK1 ; 00436710 + 00436725 +MFID4: P(.MFIDX,0,MFIDX); GO TOIT ; 00436750 + 00436775 +FID5: P(.FIDX,0,FIDX); GO TOIT ; 00436800 + 00436825 +REEL6: P(.REELX,VAL>999,REELX); GO TOIT ; 00436850 + 00436875 +DATE7: P(.DATEX,VAL DIV 1000>99 OR VAL MOD 1000>366,DATEX) ; 00436900 + GO TOIT ; 00436905 + 00436925 +CYCLE8: P(.CYCLEX,VAL>99,CYCLEX); GO TOIT ; 00436950 + 00436975 +TYPE9: P(.TYPEX,VAL>63 OR(VAL AND 31)=3 OR(VAL AND 31)>26,TYPEX);00437010 + TOIT: IF P=VAL THEN BEGIN P(DEL,DEL); GO EXIT END ; 00437030 + INITIALIZE; P(0); CHKMYUSE; CHKOPEN ; 00437040 + IF FIB[4].[24:2]!1 OR FIB[4].[8:4]!2 THEN CHKCLOSREL 00437070 + ELSE IF FI=4 OR FI=9 THEN ERM("CLS*,NOT ALTR") ; 00437090 + IF P(XCH) OR VAL.[1:5]!0 THEN GO VALER; SCATTERFPB ; 00437105 + P(DEL,VAL,XCH,~,MKS,TANK,MFIDX,FIDX,REELX,DATEX,CYCLEX, 00437110 + TYPEX,11,INTRINSIC) ; 00437125 + GO EXIT ; 00437130 + 00437150 +AREAS10: IF NOTDISK OR VAL=FIB[8].[20:5] THEN GO EXIT ; 00437200 + P(FIB[8],[FIB[8]],1) ; 00437210 + FIB[8].[20:5]~VAL; P(20); GO CHK3L ; 00437240 + 00437275 +AREASIZE11: IF NOTDISK OR VAL=FIB[8].[25:23] THEN GO EXIT ; 00437300 + P(FIB[8],[FIB[8]],1) ; 00437310 + FIB[8].[25:23]~VAL; P(BIG) ; 00437340 + CHK3L:: PMET~P; CHKCLOSREL; P(PMET); GO CHK2 ; 00437350 + CHK3T:: PMET~P; CHKOPEN; P(PMET) ; 00437360 + CHK2:: PMET~P; CHKMYUSE; P(PMET) ; 00437370 + CHK1:: IF P}VAL AND NOT VAL.[1:1] THEN GO EXIT ; 00437380 + VALER:: NOTDISK~ABS(VAL) ; 00437400 + OPEN~0; WHILE TEN[OPEN~OPEN+1]{NOTDISK DO; INITERR ; 00437410 + STREAM(N~OPEN,V~NOTDISK,T~TYPE,L~VALSIGN~VAL.[1:1],Q~NAM<000437440 + ,R~(OPEN+VALSIGN)>8,E~1+(TYPE>9),W~VAL,FI) ; 00437450 + BEGIN 00437470 + DI~DI-2; DS~2LIT":=" ; 00437480 + Q(SI~LOC W; DS~8CHR; JUMP OUT TO J); L(DS~LIT"-") ; 00437490 + R(DS~7LIT"*"; JUMP OUT TO J); SI~LOC V; DS~N DEC ; 00437500 + J: SI~LOC T; DS~3LIT",T="; DS~E DEC; DS~2LIT":~" ; 00437510 + END OF STREAM ; 00437520 + GO QUIT ; 00437530 + 00437550 +EUNUM12: IF NOTDISK OR OPEN OR FPB[FPB3].[18:5]=VAL+1 THEN GO EXIT;00437560 + P(FPB[FPB3],[FPB[FPB3]],1); % STORE FOR RECOVERY 00437570 + FPB[FPB3].[18:5]:=VAL+1; % EU NO.+1 00437580 + IF VAL=(-1) THEN VAL:=1; P(19); GO TO CHK2; 00437590 + 00437600 +DSKSPEED13: IF NOTDISK OR OPEN OR FPB[FPB3].[16:2]=VAL THEN GO EXIT; 00437610 + P(FPB[FPB3],[FPB[FPB3]],1); % STORE VALUES FOR RECOVERY 00437620 + FPB[FPB3].[16:2]:=VAL; % 1=FAST,2=SLOW 00437630 + P(2); GO CHK2; 00437640 + 00437650 +TIMELIMIT14: 00437700 + $ SET OMIT = NOT SHAREDISK 00437710 + 00437760 +IOSTATUS15: GO EXIT; 00437770 + 00437780 +SENSITIVE14: IF NOTDISK OR FPB[FPB3].[15:1]=VAL THEN GO EXIT; 00437800 + P(FPB[FPB3],[FPB[FPB3]],1); % STORE FOR RECOVERY 00437810 + FPB[FPB3].[15:1]:=VAL; %SENSITIVE=1 00437820 + P(1); GO CHK1; 00437830 + BIG::: @37777777 ; 00440000 + 00449999 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%00450000 +%%%%% INSERT NEW XN-TYPE ATTRIBUTE CODE ON NEW LINES ABOVE HERE %%%%00450050 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%00450100 + 00450150 + 00450200 +ACCESSV0: P(IF (FI~TYPE AND 31)=10 THEN 1 ELSE IF FI=13 THEN 2 00450250 + $ SET OMIT = NOT SHAREDISK 00450254 + ELSE 0,RTN); 00450260 + 00450300 +MYUSEV1: P(FIB5.[11:2],RTN) ; 00450400 + 00450450 +SAVEV2: P(FIB[4].[30:18],DECTOOCT,RTN) ; 00450500 + 00450550 +OTHERUSEV3: P(FIB5.[9:2],RTN) ; 00450600 + 00450625 +MFIDV4: P(MFIDX,RTN) ; 00450650 + 00450675 +FIDV5: P(FIDX,RTN) ; 00450700 + 00450725 +REELV6: P(REELX,RTN) ; 00450750 + 00450775 +DATEV7: P(DATEX,RTN) ; 00450800 + 00450825 +CYCLEV8: P(CYCLEX,RTN) ; 00450850 + 00450875 +TYPEV9: P(TYPEX,RTN) ; 00450900 + 00450925 +AREASV10: IF FIB[8].[20:28] = 0 AND FIB[4].[8:4] = 4 AND OPEN 00450950 +THEN P(HEADER[9].[43:5],RTN) 00450951 +ELSE P(FIB[8].[20:5],RTN); 00450952 + 00450975 +AREASIZEV11: 00451000 +IF FIB[8].[20:28] = 0 AND FIB[4].[8:4] = 4 AND OPEN 00451001 +THEN P(HEADER[8].[25:23],RTN) 00451002 +ELSE P(FIB[8].[25:23],RTN); 00451003 +EUNUMV12: P(FPB[FPB3].[18:5]-1,RTN); 00451025 +DSKSPEEDV13: P((IF (TEMP:=FPB[FPB3].[16:2])=1 THEN 1 ELSE 00451050 + IF TEMP=2 THEN 2 ELSE 0),RTN); 00451055 +TIMELIMITV14: 00451075 + $ SET OMIT = NOT SHAREDISK 00451099 + P(0); P(RTN); 00451150 +IOSTATUSV15: 00451175 + $ SET OMIT = NOT SHAREDISK 00451199 + P(0); P(RTN); 00451250 +SENSITIVEV14: P(FPB[FPB3].[15:1],RTN); 00451300 + 00469999 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%00470000 + %%%% INSERT NEW XVN-TYPE ATTRIBUTE CODE ON NEW LINES ABOVE HERE %%%%00470050 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%00470100 + 00470150 + 00470200 + EXIT: TANK[NOT 4]~0; IF INFO THEN P(RTNVAL,RTN) ; 00470250 + END OF FILEATTRIBUTES ; 00470350 +PROCEDURE ALGOLREAD(TEN, FILX, DKADD, ACT, FI, AEXP, %WF 00500000 + ARRY, EOFL, PARL, DKADR, CODE, TANK); %WF 00500100 + VALUE FI, DKADR, TANK, CODE, ACT, AEXP; %WF 00500200 + ARRAY ARRY[*], TEN[*]; %WF 00500300 + INTEGER ACT, FI, AEXP; %WF 00500400 + REAL DKADD, PARL, EOFL, CODE, DKADR; %WF 00500500 + NAME FILX, TANK; %WF 00500600 +BEGIN REAL RCW=+0,BLKCNTL=5,SELECT=14;% 00500700 + NAME MEM=2;% 00500800 + ARRAY FPB=3[*];% 00500900 + REAL ALGOLREAD=13; %WF 00501000 + ARRAY TINK=TANK[*]; %WF 00501100 + INTEGER RSIZE=FI; %WF 00501200 + DEFINE FNUM = FIB[4].[13:11] #; 00501250 + DEFINE IOD=(*TANK)#;% 00501300 + $ SET OMIT = NOT SHAREDISK 00501309 + LABEL DC1,DC2; 00501400 + LABEL DCN1,DCN2,SPIN; 00501410 + LABEL CR1,MT1,CLOSED,DK1,SP1,PR1,ERR;% 00501500 + SWITCH SW1~ CR1,ERR,MT1,CLOSED,DK1,SP1,ERR,ERR,ERR,PR1,DC1,CR1, 00501600 + ERR,DCN1; 00501610 + LABEL CR2,MT2,DK2,SP2,PR2;% 00501700 + SWITCH SW2~ CR2,ERR,MT2,ERR,DK2,SP2,ERR,ERR,ERR,PR2,DC2,CR2, 00501800 + ERR,DCN2; 00501810 + LABEL SW,PBIT,DS,FIB7,DSPBIT,PAR,DSRTN,DS19,RA1,EOF,D28;% 00501900 + LABEL EMPTY,FULL,SEMPTY,SFULL; 00501950 + REAL UNITYPE,REV,ADDRESS,BLKODE;% 00502000 + $ SET OMIT = NOT SHAREDISK 00502049 + LABEL DKS,DKR,DKR1,DKU; 00502100 + SWITCH ASW~DKS,DKR,DKU,CLOSED; 00502200 + $ SET OMIT = NOT(TIMESHARING) 00502250 +SUBROUTINE WAIT; POLISH(TANK, @2000000000, 36, COM, DEL, DEL); 00502252 + $ POP OMIT 00502253 + $ SET OMIT = TIMESHARING 00502299 + LABEL RU,RA,RC;% 00502400 + SWITCH RTYPE~RU,RA,ERR,RC;% 00502500 + LABEL DKSR,DKRR,DKUR;% 00502600 + SWITCH ASWR~DKSR,DKRR,DKUR;% 00502700 + ARRAY FIB[*],HEADER[*];% 00502800 + $ SET OMIT = NOT SHAREDISK 00502809 + INTEGER I;% 00502900 + REAL SUBROUTINE DISKADDRESS;% 00503000 + BEGIN IF DKADR}0 THEN% 00503100 + BEGIN ADDRESS~(DKADR DIV HEADER[0].[30:12])|HEADER[0].[42:6];% 00503200 + IF (I~ADDRESS DIV HEADER[1]+10)}30 THEN P(0) ELSE 00503300 + IF HEADER[I]=0 THEN P(0) ELSE 00503400 + BEGIN ADDRESS~HEADER[I]+I~ADDRESS MOD HEADER[1];% 00503500 + STREAM(D~[ADDRESS]); BEGIN SI~D; DS~8 DEC END;% 00503600 + P(1);% 00503700 + END END ELSE P(0);% 00503800 + DISKADDRESS~P;% 00503900 + END DISKADDRESS;% 00504000 + $ SET OMIT = NOT SHAREDISK 00504009 + IF TINK=0 THEN %WF 00504200 + BEGIN FIB ~ FILX[NOT 2]; %WF 00504300 + FILX[NOT 4] ~ EOFL; FILX[NOT 3] ~ PARL; %WF 00504400 + IF NOT FIB[5].[12:1] THEN P(MKS,"READNG",FILX,7,SELECT) ; 00504450 + IF FIB[5].[43:2]!((ACT<0)+2) THEN %WF 00504500 + P(MKS, DKADD, (ACT<0)+2, FILX, 1, SELECT); %WF 00504600 + RSIZE~P(MKS,(ABS(ACT)=3),DKADD,1,FILX,ALGOLREAD); 00504700 + IF ARRY!0 THEN %WF 00504800 + BEGIN IF ARRY.[8:10]>P(DUP, AEXP) %WF 00504900 + THEN P(DEL, AEXP); %WF 00505000 + IF P(DUP)}RSIZE THEN P(DEL) ELSE RSIZE ~ P; %WF 00505100 + STREAM(P4 ~ *FILX, P3 ~ RSIZE, %WF 00505200 + P2 ~ P(DUP).[36:6], P1 ~ [ARRY[0]]); %WF 00505300 + BEGIN SI ~ P4; DS ~ P3 WDS; %WF 00505400 + P2(DS ~ 32 WDS; DS ~ 32 WDS); %WF 00505500 + END; %WF 00505600 + END; %WF 00505700 + IF ABS(ACT)}2 THEN% 00505800 + P(MKS, DKADD, 0, FILX, ALGOLREAD); %WF 00505900 + FILX[NOT 4] ~ FILX[NOT 3] ~ 0; %WF 00506000 + P(XIT); %WF 00506100 + END; %WF 00506200 + FIB~TANK[NOT 2];% 00506300 +SW: UNITYPE~FIB[4].[8:4]; REV~FIB[5].[44:1]; BLKODE~FIB[5].[46:2];% 00506400 + $ SET OMIT = TIMESHARING 00506440 + IF DKADR.[4:1] THEN 00506460 + BEGIN 00506465 + $ SET OMIT = NOT SHAREDISK 00506469 + DKADR.[3:2]~0; 00506475 + END; 00506480 + IF CODE THEN GO TO SW1[UNITYPE]; GO TO SW2[UNITYPE];% 00506500 +MT1:% 00506600 +CR1:% 00506700 + PR1: IF IOD.[19:1] THEN% 00506800 +PBIT: BEGIN IF IOD.[2:1] THEN% 00506900 + BEGIN IF FIB[17]=0 THEN FIB[17]~*((IF REV THEN 1 ELSE NOT 0)00507000 + INX FLAG(FIB[16]));% 00507100 + P((IF BLKODE THEN IOD.[8:10] ELSE FIB[17]),RTN);% 00507200 + END;% 00507300 + IF IOD.[25:1] THEN% 00507400 +CLOSED: BEGIN 00507410 + FIB[13].[27:1]~1; 00507420 + IF (REV~(FPB[FNUM+3] AND 31))!10 AND REV!12 00507430 + AND REV!13 AND REV!26 THEN FIB[5].[45:1]~0 ELSE 00507440 + FIB[5].[45:1]~P(TANK[NOT 3],DUP)!0 AND P(XCH)!15; 00507450 + P(TANK,0,11,COM,DEL,DEL) ; 00507510 + IF NOT FIB[5].[45:1] THEN GO SW ; 00507515 + P(TANK[NOT 3]); TANK[NOT 3]~TANK[NOT 4]~0 ; 00507520 + P(MKS,9,BLKCNTRL,DEL) ;% TAKE PARITY ACTION LBL BRNCH. 00507525 + CODE~1; GO TO DS; 00507530 + END ; 00507535 + IF IOD.[27:1] THEN% 00507600 + BEGIN IF UNITYPE=2 THEN% 00507700 + IF FIB[4].[2:1] THEN% 00507800 + P(MKS,1,0,(NOT 2)INX TANK,4,SELECT) ELSE% 00507900 + BEGIN P(TANK,11,11,COM,DEL,DEL);% 00508000 + IF MEM[TANK[NOT 1] INX 4].[42:6]=1 THEN% 00508100 + BEGIN UNITYPE~FIB[13].[28:10];% 00508200 + P(MKS,6,0,(NOT 2)INX TANK,4,SELECT);% 00508300 + FIB[13].[28:10]~UNITYPE+1;% 00508400 + GO TO CLOSED;% 00508500 + END END;% 00508600 +EOF: IF CODE = 3 THEN P(1,SSN,RTN); CODE ~ 2; 00508700 + END ELSE PAR: TANK[0]~IOD OR MEM;% 00508800 + IF CODE =-3 THEN BEGIN P(0,[TANK[NOT 2]],19,17,COM); 00508900 + P(0,RTN); END; 00509000 + P(TANK[NOT(CODE+2)]); 00509400 + TANK[NOT 4]~TANK[NOT 3]~0; 00509500 + P(MKS,9,BLKCNTL); 00509600 +DS: P(TANK,CODE,11,COM);% 00509700 + END;% 00509800 + P(TANK); WAIT; GO TO PBIT;% 00509900 +ERR: CODE~3; GO DS;% 00510000 +DK1: HEADER~*[FIB[14]]; GO TO ASW[FIB[4].[27:3]];% 00510100 +DK2: HEADER~*[FIB[14]]; GO TO ASWR[FIB[4].[27:3]];% 00510200 +CR2:% 00510300 +MT2:% 00510400 +PR2: GO TO RTYPE[BLKODE];% 00510500 +RU: TANK[0]~FLAG(FIB[16]); P(FLAG(FIB[19]),TANK,PRL,DEL);% 00510600 + BLKODE~FIB[19].[33:15]-FIB[16].[33:15];% 00510700 + FIB[16].[33:15]~ CODE~(*((IF REV THEN 2 ELSE NOT 1) INX% 00510800 + FLAG(FIB[16]))).[18:15];% 00510900 + FIB[19].[33:15]~CODE+BLKODE;% 00511000 + FIB[6]~(REV~1&REV[1:47:1])+FIB[6];% 00511100 + FIB[7]~FIB[7]+REV; FIB[17]~0; P(XIT);% 00511200 +RA: IF (FIB[17]~FIB[17]-CODE~FIB[18].[33:15])HEADER[7] THEN% 00513300 + BEGIN TANK[0]~IOD&0[2:2:1]&1[27:47:1];% 00513400 + GO TO EOF;% 00513500 + END ELSE% 00513600 +DSRTN: BEGIN IF FIB[17]=0 THEN FIB[17]~FIB[18].[18:15];% 00513700 + P(FIB[18].[33:15],RTN);% 00513800 + END ELSE% 00513900 + IF IOD.[25:1] THEN GO TO CLOSED ELSE% 00514000 + IF IOD.[27:1] THEN GO TO EOF ELSE GO TO PAR ELSE% 00514100 + BEGIN P(TANK); WAIT; GO TO DSPBIT END;% 00514200 +% READ OR SEEK ON A SERIAL FILE WITH ADDRESS SPECIFIED.% 00514300 + P(MKS,ABS(DKADR)-1,1,TANK,1,SELECT);% 00514400 + IF DKADR<0 THEN GO TO DSRTN; GO TO DS19;% 00514500 +DKSR: IF DKADR>0 THEN GO TO D28 ELSE IF DKADR=0 THEN% 00514600 + BEGIN IF (FIB[17]~FIB[17]-CODE~FIB[18].[33:15])}CODE THEN GO RA1; 00514700 + FIB[6]~(REV~1&REV[1:47:1])+FIB[6];% 00514800 + FIB[17]~0;% 00514900 + DKADR~FIB[7]% 00515000 + +FIB[13].[10:9]|HEADER[0].[30:12]|REV;% 00515100 + FIB[7]~FIB[7]+REV;% 00515200 + IF DISKADDRESS THEN% 00515300 + BEGIN P(TANK[0]~FLAG(FIB[16]),ADDRESS,XCH,~);% 00515400 + P(FLAG(FIB[19]),TANK,PRL,DEL);% 00515500 + END ELSE% 00515600 + BEGIN TANK[0]~FLAG(FIB[16])&2[27:46:2]&0[2:47:1];% 00515700 + P(FIB[13].[10:9],TANK,13,11,COM,DEL,DEL,DEL);% 00515800 + END;% 00515900 + BLKODE~FIB[19].[33:15]-FIB[16].[33:15];% 00516000 + FIB[16].[33:15]~CODE~MEM[P(DUP) INX NOT 1].[18:15];% 00516100 + FIB[19].[33:15]~CODE+BLKODE;% 00516200 + END;% 00516300 +DKRR: P(XIT);% 00516400 +DKR: 00516410 + $ SET OMIT = NOT SHAREDISK 00516419 +DKR1: IF DKADR GEQ 0 THEN 00516500 + BEGIN IF DKADR=0 THEN DKADR~FIB[7] ELSE FIB[7]~DKADR~DKADR-1;% 00516600 + IF HEADER[7]}DKADR THEN% 00516700 + IF DISKADDRESS THEN% 00516800 + BEGIN CODE~FIB[16].[33:15]; UNITYPE~FIB[13].[10:9];% 00516900 + FOR I~0 STEP 1 UNTIL UNITYPE DO% 00517000 + $ SET OMIT = SHAREDISK 00517099 + BEGIN IF NOT IOD.[19:1] THEN BEGIN P(TANK); WAIT END; 00517100 + $ POP OMIT 00517101 + $ SET OMIT = NOT SHAREDISK 00517109 + IF IOD.[27:1] THEN GO TO EMPTY;% 00517200 + $ SET OMIT = SHAREDISK 00517299 + IF (MEM[CODE] EQV ADDRESS)=NOT 0 THEN GO FULL; 00517300 + $ POP OMIT 00517301 + $ SET OMIT = NOT SHAREDISK 00517309 + TANK[0]~IOD&1[27:47:1];% 00517400 + P(UNITYPE,TANK,13,11,COM,DEL,DEL,DEL);% 00517500 + FIB[16].[33:15]~CODE~MEM[CODE-2].[18:15];% 00517600 + FIB[19].[33:15]~CODE+1;% 00517700 + END; GO TO ERR;% 00517800 +EMPTY: 00517900 + $ SET OMIT = NOT SHAREDISK 00517909 + FIB[13].[10:9]~1; 00517980 + P(TANK[0]~FLAG(FIB[16]),ADDRESS,XCH,~);% 00518000 + P(FLAG(FIB[19]),TANK,PRL,DEL);% 00518100 + FIB[13].[10:9]~UNITYPE; P(TANK); 00518200 + $ SET OMIT = NOT SHAREDISK 00518299 + WAIT; 00518350 +FULL: IF NOT IOD.[2:1] OR FIB[5].[1:1] THEN 00518400 + BEGIN 00518500 + $ SET OMIT = NOT SHAREDISK 00518509 + CODE~1; GO TO PAR; 00518550 + END; 00518560 + $ SET OMIT = NOT SHAREDISK 00518569 + IF BLKODE=0 THEN SFULL:P(FIB[18].[33:15],RTN); 00518600 + TANK[0]~IOD&((I~DKADR MOD HEADER[0].[30:12])% 00518700 + |(I~FIB[18].[33:15])+FIB[19].[33:15])[33:33:15];% 00518800 + P(I,RTN);% 00518900 + END;% 00519000 + IF NOT FIB[5].[1:1] THEN 00519100 + BEGIN 00519110 + $ SET OMIT = NOT SHAREDISK 00519119 + GO TO EOF; 00519130 + END; 00519140 + $ SET OMIT = NOT SHAREDISK 00519149 + CODE~1; GO TO PAR; 00519160 + END;% 00519200 + DKADR~ABS(DKADR)-1;% 00519300 + IF HEADER[7]1 THEN 00609600 + FILX[NOT 4]~FILX[NOT 3]~0 ELSE 00609700 + IF FILX.[18:15] = 1 THEN% 00609800 + P(FILX,14,COM);% 00609900 + P(XIT);% 00610000 + END;% 00610100 + CKPB;% 00610200 + IF SGN.[45:1] THEN %%% UTYP=SGN.[45:1]; SEE U-PHRASE DECLR00610210 + BEGIN CSIZE~8|BSIZE; BUFF~P(0,[BUFF],0,INX) END ; 00610220 + END RLADS;% 00610300 + COMMENT SUBROUTINE USED BY FREE FIELD;% 00610400 + SUBROUTINE GNCR;% 00610500 + BEGIN COMMENT THIS SUB-ROUTINE GETS CHARACTERS FOR% 00610600 + FREE FIELD.INCLUDING READING OF RECORDS 00610700 + WHEN REQUIRED;% 00610800 + GA: IF WT > 0 THEN GO TO GAC;% 00610900 + COMMENT BUFFER IS EMPTY-FILL IT;% 00611000 + P(0);% 00611100 + READS;% 00611200 + WT ~ BSIZE | 8; COMMENT WT = # OF CHARACTERS IN BUFFER;% 00611400 + BUFF ~ P(0,0,[BUFF],CCX);% 00611500 + COMMENT GFT CHR FROM BUFFER;% 00611600 + GAC: STREAM(% 00611700 + P5 ~ 0,% 00611800 + P4 ~ BUFF,% 00611900 + P3 ~ IF WT < 63 THEN WT ELSE 63:% 00612000 + P1 ~ TYP);% 00612100 + BEGIN% 00612200 + SI ~ P4;% 00612300 + CI ~ CI + P1;% 00612400 + GO TO FGNC; COMMENT DEBLANK-THEN GET NCR;% 00612500 + GO TO GNCHC; COMMENT GET NCR;% 00612600 + FGNC: P3(IF SC ! " " THEN JUMP OUT TO GNCHC;% 00612700 + SI~SI+1;% 00612800 + TALLY ~ TALLY +1);% 00612900 + COMMENT RETURN A -1 IF ALL WERE BLANK;% 00613000 + DI ~ LOC P5;% 00613100 + DS ~ 8 LIT "+0000001";% 00613200 + GO TO CRTN;% 00613300 + GNCHC: TALLY ~ TALLY + 1;% 00613400 + DI ~ LOC P4;% 00613500 + DI ~ DI - 1;% 00613600 + DS ~ CHR;% 00613700 + CRTN: P3 ~ TALLY;% 00613800 + P4 ~ SI;% 00613900 + END;% 00614000 + P(WT,XCH,SUB,.WT,STD); COMMENT WT ~ WT-TALLY;% 00614100 + BUFF ~ P;% 00614200 + IF P(DUP) < 0 THEN BEGIN P(DEL); GO TO GA END;% 00614300 + P(XCH); COMMENT RETURN LITERAL TO TOP;% 00614400 + END GNCR;% 00614500 + REAL SUBROUTINE LISTELEMENT ; 00614505 + BEGIN 00614510 + IF LSTRN<0 THEN GO TO ERROR ; 00614515 + P(ADDRS,.ADDRS,ISN) ; 00614520 + ADDRS~LISX ; 00614525 + LISTELEMENT~P ; 00614530 + END OF LISTELEMENT ; 00614535 + 00614600 + % * * * D E C L A R A T I O N S F O R U - P H R A S E * * * 00614605 + % NOTE THAT CST REFERS TO THE CONSTRUCT BEGIN SCANNED. THE CST IS 00614610 + % EITHER A NUMBER, AN UNQUOTED STRING, OR A QUOTED STRING 00614615 + LABEL UERR , %%% BRNCHTO FOR DATA ERROR 00614620 + UTYPE , %%% BRNCHTO FOR U-PHRASE EDITING. 00614625 + UENDNUM , %%% BRNCHTO FOR END OF NUMBER SCAN. 00614630 + UL1 , %%% BRNCHTO FOR EFFICIENCY IN UCH. 00614635 + UL2 , %%% BRNCHTO FOR EFFICIENCY IN UCHECKT00614640 + UL3 , %%% BRNCHTO FOR EFFICIENCY IN STRINGS00614645 + UL4 , %%% BRNCHTO FOR STRING-HANDLING LOOP.00614650 + UL5 , %%% BRNCHTO FOR UCHECKIT(@END-OF-CST)00614655 + UL6 , %%% BRNCHTO FOR NO STRING STORE. 00614660 + FMTERR ; %%% BRNCHTO FOR ILLEGAL FORMAI. 00614665 + DEFINE UEXP = WT #, %%% IS VALUE OF EXPNT(OF CST AS NUM),00614670 + %%% OR IT IS THE SHIP-IT-ANYHOW TOGGL00614675 + %%% FOR THE 1-ST CHR OF QUOTED STRING00614680 + %%% OR IS USED AS TEMPORY BY UGETSGN.00614685 + UBUILD = W1 #, %%% IS > 0 IF HAVE NOT YET IDENIIFIED00614690 + %%% CST & SO MUST BUILD UH INTO UBUFF00614695 + %%% IS > 0 IF SHALL BRANCH TO ENDNUM 00614700 + %%% IF HAVE HIT END OF FIELD WIDTH, 00614705 + %%% IS ALSO USED AS TEMPORARY COUNTER00614710 + %%% OF OCT D1GITS IN OCTAL NUM PART. 00614715 + UVAL = W2 #, %%% IS VALUE OF CST IF CST IS A NUM. 00614720 + %%% AND IS USED AS TEMPORARY STORAGE.00614725 + UNUM = D1 #, %%% IS TRUE IFF CST IS NUMBER. 00614730 + UADDRS =UDECLR #, %%% STORES LIST ADDRESS REFERRED TO 00614735 + %%% BY THE ULIST DEFINE (BELOW). 00614740 + UH = D2 #, %%% IS CURRENT CHARACTER OF CSY. 00614745 + UBUFF = FLG #, %%% IS SIX OR LESS CHARACTERS OF CST,00614750 + %%% ALSO IS USED AS TEMPORARY BY 00614755 + %%% SUBROUTINE UCHECKIT. 00614760 + UCHCNT = SKIP #, %%% IS CHARACTER COUNTER FOR CSI. 00614765 + USCHCNT = FAW #, %%% IS STRING CHR. COUNTER FOR UBUFF.00614770 + UDEC = D #, %%% IS VALUE OF DECIMAL PART OF CST 00614775 + %%% (IF CST IS NUMBER), AND IS ALSO 00614780 + %%% USED AS TEMPORARY STORAGE. 00614785 + USGN = SGN.[47:1] #, %%% IS TRUE IFF CST(AS NUM) IS NEGTIV00614790 + UEXPSGN = SGN.[46:1] #, %%% IS TRUE IFF UEXP IS NEGATIVE. 00614795 + UTYP = SGN.[45:1] #, %%% IS TRUE IFF IN OR JUST USED UPHRS00614800 + UNLOCATED = SGN.[44:1] #, %%% IS TRUE IFF HAVE NOT LOCATED CST.00614805 + UQSTRNG = SGN.[43:1] #, %%% IS TRUE IFF CST IS QUOIED STRING.00614810 + ULIST = SGN.[42:1] #, %%% IS TRUE IFF UCH HAS TRIED TO GET 00614815 + %%% AND/OR HAS GOTTEN A NEW LISI ADRS00614820 + UD = SGN.[36:6] #, %%% STORES ORIGINAL VALUE OF D 00614825 + UW = SGN.[30:6] #, %%% STORES ORIGINAL VALUE OF W. 00614830 + UFREEFIELD= SGN.[29:1] #, %%% IS TRUE IFF IN SPECL // FREEFIELD00614835 + UGETRECORD = BEGIN P(CHR~0); READS END #, 00614840 + UGOOFED(UGOOFED1) = BEGIN UEXP~UGOOFED1; GO TO UERR END #,00614845 + UEOW = W{UCHCNT #, 00614850 + UALLDONE = GO TO BR # ; 00614855 + SUBROUTINE UGNCH; %%% UGNCH GETS THE NEXT CHARACTER FROM THE 00614860 + BEGIN %%% BUFFER, GETS A NEW BUFFER WHEN NECCESSARY, 00614865 + IF CHR}CSIZE %%% ADJUSTS BUFF, AND BUMPS CHR BY 1. 00614870 + THEN BEGIN %%% WE NEED A NEW BUFFER, CALL READS TO GET ONE.00614875 + UGETRECORD ; %%% GET A NEW RECORD. 00614880 + IF UNLOCATED %%% IF HAVE NOT YET LOCATED CST, THEN 00614885 + THEN UCHCNT~0 ; %%% ZERO CHAR. CNTER. FOR NEW BUFFER SCAN.00614890 + END ; 00614895 + CHR~CHR+1 ; %%% INCREMENT CHARACTER COUNTER. 00614900 + STREAM(P1~0,P2~BUFF:P0~0) ; %%% NOW GET CHARACTER AND BUMP BUFF00614905 + BEGIN DI~LOC P2; DI~DI-1; SI~P2; DS~CHR; P2~SI END ; 00614910 + BUFF~P ; %%% BUFF IS SET TO NEW ABS ADDRS (BUFF+1). 00614915 + UH~P ; %%% CHARACTER IS STORED IN UH. 00614920 + END OF UGNCH ; 00614925 + SUBROUTINE UBUFFIT ; %%% STUFFS UH INTO UBUFF FROM THE RIGHT 00614930 + BEGIN %%% AND BUMPS THE STRING CHARACTER COUNTER. 00614935 + UBUFF~UH & UBUFF[12:18:30] ; 00614940 + USCHCNT~USCHCNT+1 ; 00614945 + END OF UBUFFIT ; 00614950 + SUBROUTINE UCH ; %%% UCH IS THE CONTROL FOR UGNCH. UCH WATCHES OUT 00614955 + BEGIN %%% FOR END-OF-W AND, IF NOT IN "STRING", SCANS 00614960 + %%% OVER IN-LINE COMMENTS (/...=) AND STORES NON- 00614965 + %%% BLANK PORIION OF CST IN UBUFF FOR FUTURE USE 00614970 + %%% IF CST TURNS OUT NOT TO BE A NUMBER. UCH ALSO 00614975 + %%% HANDLES END-OF-RECORD SITUATIONS (/... OR ~). 00614980 + IF UEOW THEN %%% IF HAVE HIT END-OF-W (W=FIELD WIDTH), THEN00614985 + BEGIN 00614990 + IF UBUILD!0 %%% IF WE ARE NOT IN THE STRING SECTION, WE 00614995 + THEN BEGIN P(DEL); GO UENDNUM END %%% BRNCHTO END-OF-NUM.00615000 + END 00615005 + ELSE %%% ELSE WE ARE STILL INSIDE FIELD-WIDTH W... 00615010 + BEGIN %%% STILL SOME FIELD WIDTH LEFT. 00615015 + UGNCH; UCHCNT~UCHCNT+1 ; %%% GET CHRTER, BUMP CHR. CNTER.00615020 + IF NOT UQSTRNG THEN %%% NOI IN A QUOTED STRING. 00615025 + BEGIN 00615030 + WHILE UH="/" DO %%% WE"VE HIT AN END-OF-RECORD MARK 00615035 + BEGIN %%% ("/") OR AN INLINE CMMNT("/...=")00615040 + DO UGNCH UNTIL CHR=1 OR UH="=" OR UH="~" ; 00615045 + IF CHR!1 THEN 00615050 + BEGIN 00615055 + IF UH="=" THEN GO TO UL1 ; 00615060 + IF UH="~" THEN 00615065 + BEGIN CHR~CSIZE; UL1: UGNCH END ; 00615070 + END ; 00615075 + END ; 00615080 + IF UH="~" THEN %%% WE SET UH=DELIMETER, AND IF THERES00615085 + BEGIN %%% MORE LIST, WE GET A NEW RECORD. 00615090 + UH~" "; IF LSTRN}0 THEN UADDRS~LISX ; 00615095 + SGN~SGN OR 32 ; %%% SETS ULIST = TRUE. 00615100 + IF LSTRN}0 THEN UGETRECORD ; 00615105 + END ; 00615110 + IF UBUILD!0 %%% WE HAVE NOT YET IDENTIFIED CST, 00615115 + THEN UBUFFIT ; %%% SO MUST SAVE UH IN UBUFF. 00615120 + END ; 00615125 + END ; 00615130 + END OF UCH ; 00615135 + BOOLEAN SUBROUTINE UDELIMCHK ; %%% IS TRUE IFF HAVE ENCOUNTERED A 00615140 + BEGIN %%% DELIMITER NOT IN A QUOTED SIRING.00615145 + UDELIMCHK~UH="," OR UH=" " OR UH="*" OR UEOW ; 00615150 + END OF UDELIMCHK ; 00615155 + DEFINE UCHECKIT = %%% UCHECKIT IS USED WHENEVER IHE SCAN HAS 00615160 + %%% TERMINATED. UCHECKIT CHECKS FOR THE PROPER00615165 + %%% DELIMITER AND TAKES THE ASSOCIATED BRANCH.00615170 + %%% UCHECKIT WILL POSITION UH APPROPIAIELY 00615175 + %%% (PRIOR TO DELIMITER CHECKING) IF THE 00615180 + %%% MINIMUM FIELD WIDTH (UD) HAS NOT BEEN 00615185 + %%% EXHAUSTED. 00615190 + IF UH="*" THEN UALLDONE ; %%% THE * TERMINATES THE READ STMT. 00615195 + IF NOT((UBUFF~UH!",") AND UH!" ") THEN 00615200 + BEGIN 00615205 + UQSTRNG~UBUILD~0; W~123; D~UD ; 00615210 + WHILE UCHCNT{D DO %%% SCAN OFF UNTIL AT LEAST 00615215 + BEGIN %%% D CHARACIERS HAVE BEEN PASSED ; 00615220 + UCH ; 00615225 + IF ULIST THEN GO TO UL2 ; %%% HAVE ENCOUNTERED AN ~. 00615230 + IF UH="*" THEN UALLDONE ; %%% THE * TRMNIS THE READ. 00615235 + IF (UBUFF OR UVAL~UH!",") AND (UH=" " OR NOT UVAL) 00615240 + THEN UBUFF~UBUFF AND UVAL ELSE UGOOFED(1) ; 00615245 + END ; 00615250 + UL2: W~UW ; %%% RESTORE W TO ITS ORIGINAL VALUE, 00615255 + GO TO COMM ; %%% AND MAKE NORMAL EXIT. 00615260 + END ; 00615265 + UGOOFED(2) #; %%% WAS NOT "*", ",", OR " " SO WE ERROR EXIT. 00615270 + %%% END OF UCHECKIT. 00615275 + BOOLEAN SUBROUTINE UGETSGN ; %%% IS TRUE IF SIGN="-"; IF SIGN(+,-,&)00615280 + BEGIN %%% EXISTS, UGETSGN FETCHES A NEW CHAR.00615285 + IF P(UH="-",DUP) OR UH="+" OR UH="&" THEN UCH ; 00615290 + UGETSGN~POLISH ; 00615295 + END OF UGETSGN ; 00615300 + BOOLEAN SUBROUTINE USDELIMCHK ; %%% IS IRUE IF CURRENT CHARACIER(UH)00615305 + BEGIN %%% IS A DELIMITER(* OR , OR BLANK);00615310 + IF NOT UQSTRNG THEN P(UDELIMCHK) ELSE %%% IF UH=RIGHT HAND 00615315 + BEGIN %%% 0UOTE OF QUOTED SIRING, 00615320 + IF UEOW THEN UGOOFED(3) ; %%% THEN ONE AND POSSIBLY TWO 00615325 + IF NOT(UH!""" OR UEXP) THEN %%% CHAR ARE SCANNED UNTIL UH 00615330 + BEGIN %%% IS EITHER A DELIMITER OR 00615335 + UQSTRNG~0; UCH ; %%% THE FIRSI CHARACTER OF THE00615340 + IF NOT P(UDELIMCHK,DUP)%%% NEXT CONCATENATED STRING. 00615345 + THEN BEGIN 00615350 + IF UH!""" THEN UGOOFED(4) ; 00615355 + SGN~SGN OR 16 ; %%% SETS UQSTRNG = TRUE 00615360 + UCH; 00615365 + END ; %%% DO ERROR-EXIT IF WE ARE IN00615370 + END %%% QUOIED STRING AND: EXCEED 00615375 + ELSE P(UEXP~0) ; %%% W OR ENCOUNTER 00615380 + END ; %%% A NON-QUOTE, NON-DELIMITER00615385 + USDELIMCHK~POLISH ; 00615390 + END OF USDELIMCHK ; 00615395 + % * * * E N D O F U - P H R A S E D E C L A R A T I O N S * 00615400 + 00615405 + LABEL C,X,A,I,R,E,O,L,Z,ZW2,ZD,SWT ; 00615410 + GO TO START; COMMENT GO AROUND FREE FIELD CODE; 00615415 + COMMENT FREE FIELD FORMAT ; 00615420 + FREFLD:: P(0,0,0,0,0,0); COMMENT PUSH UP STACK;% 00615500 + LSTRN ~ 0;% 00615600 + WT ~ BSIZE | 8; COMMENT WT = # OF CHR IN BUFFER;% 00615700 + BUFF ~ P(0,0,[BUFF],CCX);% 00615800 + STRT: ADDRS ~ LISX; COMMENT ADDRESS OF LIST ITEM;% 00615900 + IF LSTRN < 0 THEN BEGIN COMMENT CALL READ AND EXIT;% 00616000 + P(1);% 00616100 + READS;% 00616200 + END;% 00616300 + GNCR; COMMENT GET A CHARACTER TO TOP OF SIACK;% 00616400 + NMRCL: ESIG ~ DIVR ~ 0; COMMENT SET EXPONENT AND FRACTION PART% 00616500 + TO ZERO;% 00616600 + IF (SGN ~ P(DUP) = "-") THEN GO TO HERE;% 00616700 + IF P(DUP) = "+" THEN GO TO HERE;% 00616800 + IF P(DUP) ! "&" THEN GO TO NOSIG;% 00616900 + HERE: P(DEL);% 00617000 + GNCR;% 00617100 + NOSIG: IF P(DUP) > 9 THEN GO TO NOTNUM;% 00617200 + GNCR;% 00617300 + LPTWO: IF P(DUP) > 9 THEN GO TO NOTNUM2;% 00617400 + P(XCH,10,MUL,+);% 00617500 + GNCR; GO TO LPTWO;% 00617600 + NOTNUM2: IF P(DUP) ! "." THEN GO TO NFRAC1;% 00617700 + P(DEL);% 00617800 + L1: GNCR;% 00617900 + L1P2: IF P(DUP) > 9 THEN GO TO NFRAC1;% 00618000 + P(XCH,10,MUL,+);% 00618100 + DIVR ~ DIVR +1;% 00618200 + GNCR; GO TO L1P2;% 00618300 + NFRAC1: IF P(DUP) ! "@" THEN GO TO NOTAT;% 00618400 + P(DEL);% 00618500 + GNCR;% 00618600 + ATS: IF (ESIG ~ P(DUP) = "-") THEN GO TO HR1;% 00618700 + IF P(DUP) = "+" THEN GO TO HR1;% 00618800 + IF P(DUP) ! "&" THEN GO TO NSG;% 00618900 + HR1: P(DEL);% 00619000 + GNCR; COMMENT 1ST DIGIT;% 00619100 + NSG: GNCR; COMMENT 2ND DIGIT;% 00619200 + L2P1: IF P(DUP) > 9 THEN GO TO FINXP;% 00619300 + P(XCH,10,MUL,+);% 00619400 + GNCR; GO TO L2P1;% 00619500 + FINXP: IF P = "," THEN GO TO NCA1;% 00619600 + GNCR; GO TO FINXP;% 00619700 + NCA1: IF ESIG THEN P(CHS);% 00619800 + NMINUS: ESIG ~ P;% 00619900 + P(",");% 00620000 + NOTAT: IF P = "," THEN GO TO NCA2;% 00620100 + GNCR; GO TO NOTAT;% 00620200 + NCA2: IF SGN THEN P(CHS);% 00620300 + IF P(ESIG-DIVR,DUP) = 0 THEN% 00620400 + BEGIN% 00620500 + P(DEL);% 00620600 + P([ADDRS],ISD);% 00620700 + GO TO STRT% 00620800 + END;% 00620900 + IF P(DUP) } 0 THEN% 00621000 + P(TEN[P],MUL)% 00621100 + ELSE% 00621200 + P(TEN[-P],/);% 00621300 + NNMB: P([ADDRS],STD);% 00621400 + GO TO STRT;% 00621500 + NOTNUM: IF P(DUP) ! " " THEN GO TO RNOTNUM;% 00621600 + P(DEL);% 00621700 + P(0);% 00621800 + GNCR; GO TO L1P2;% 00621900 + RNOTNUM: IF P(DUP) ! "@" THEN GO TO INSERT;% 00622000 + P(DEL);% 00622100 + P(1);% 00622200 + GNCR; GO TO ATS;% 00622300 + INSERT: IF P(DUP) = "," THEN% 00622400 + BEGIN% 00622500 + P(DEL);% 00622600 + GO TO STRT;% 00622700 + END;% 00622800 + NAST: IF P(DUP) ! """ THEN GO TO NQUOT;% 00622900 + P(DEL);% 00623000 + TYP ~ CCR ~ 1;% 00623100 + GNCR;% 00623200 + QRT: GNCR;% 00623300 + QRTN: IF P(DUP) = """ THEN GO TO EQUT;% 00623400 + P(XCH,64,MUL,+);% 00623500 + IF (CCR ~ CCR+1) ! 6 THEN% 00623600 + BEGIN% 00623700 + GNCR; GO TO QRTN;% 00623800 + END;% 00623900 + P([ADDRS],STD);% 00624000 + ADDRS ~ LISX;% 00624100 + IF LSTRN < 0 THEN% 00624200 + BEGIN% 00624300 + DO GNCR UNTIL P= """;% 00624400 + DO GNCR UNTIL P=",";% 00624500 + P(1);% 00624600 + READS;% 00624700 + END;% 00624800 + CCR ~ 0;% 00624900 + GNCR;% 00625000 + IF P(DUP) = """ THEN GO TO EQUT;% 00625100 + CCR ~ 1;% 00625200 + GO TO QRT;% 00625300 + EQUT: P(DEL);% 00625400 + TYP ~ 0;% 00625500 + IF CCR = 0 THEN% 00625600 + BEGIN% 00625700 + GNCR;% 00625800 + GO TO EATUP;% 00625900 + END;% 00626000 + P([ADDRS],STD);% 00626100 + GNCR;% 00626200 + EAT1: IF P(DUP) = "," THEN GO TO STRT;% 00626300 + GNCR; GO TO EAT1;% 00626400 + EATUP: IF P ! "," THEN BEGIN GNCR; GO TO EATUP END;% 00626500 + GNCR;% 00626600 + GO TO NMRCL;% 00626700 + NQUOT: IF P(DUP) ! "%" THEN GO TO ASTRX;% 00626800 + P(DEL,0);% 00626900 + GNCR;% 00627000 + GETO: IF P(DUP) > 7 THEN GO TO GTRT7;% 00627100 + P(XCH,DIA 4,DIB 1,TRB 44);% 00627200 + GNCR; GO TO GETO;% 00627300 + GTRT7: IF P ! "," THEN BEGIN GNCR; GO TO GTRT7 END;% 00627400 + P([ADDRS],STD);% 00627500 + GO TO STRT;% 00627600 + ASTRX: IF P(DUP) = "*" THEN% 00627700 + BEGIN% 00627800 + P(1);% 00627900 + READS;% 00628000 + END;% 00628100 + CHKOCT: IF P(DUP) ! "/" THEN GO TO GETCOMA;% 00628200 + P(DEL);% 00628300 + WT ~ 0;% 00628400 + GNCR;% 00628500 + GO TO NMRCL;% 00628600 + $ SET OMIT = NOT(TIMESHARING) 00628650 +GETCOMA: ESIG ~ (FIB[4].[8:4]=10); % TRUE IF REMOTE INPUT 00628700 + $ SET OMIT = TIMESHARING 00628701 +GETC1: IF P = "," OR (ESIG AND WT=0) THEN GO STRT ELSE 00628750 + GNCR; GO GETC1; 00628800 + COMMENT START OF INPUTINT;% 00628900 + START:: P(LSTRN,0,0);% 00629000 + IF FILX.[18:15] > 1 THEN% 00629100 + BEGIN P(FILX[NOT 2]);% 00629200 + FILX[NOT 4]~EOFL; FILX[NOT 3]~PARL; 00629300 + IF NOT FIB[5].[12:1] THEN P(MKS,"READNG",FILX,7,SELECT) ; 00629330 + IF FIB[4].[27:3] ! 2 THEN 00629340 + IF FIB[5].[43:2]!((ACT<0)+2) THEN% 00629400 + POLISH(MKS,DKADR,(ACT<0) +2,FILX,1,SELECT);% 00629500 + COMMENT CALL SELECT IF NOT READ STATUS OR% 00629600 + WRONG DIRECTION ;% 00629700 + END ELSE P(0);% 00629800 + CKPB;% 00629900 + COMMENT CHECK FOR TYPE OF READ STATMENT;% 00630000 + CT: ACT~ABS(JUNK1~ACT);% 00630100 + IF ARRY ! 0 THEN GO TO CTB; COMMENTNOT EMPTY; 00630200 + IF FRMT ! 0 THEN GO TO CTA; COMMENT =EMPIY,% 00630300 + IS NOT;% 00630400 + COMMENT BOTH & WAS EMPTY;% 00630500 + P(1); COMMENT SET FLAG = EXIT;% 00630600 + READS; COMMENT RELEASE BUFFER;% 00630700 + CTA: LSTRN ~ -1; COMMENT = EMPTY;% 00630800 + GO TO FMOUT; COMMENT READ IS ,;% 00630900 + CTB: IF NOT P(ARRY ,TOP,XCH,DEL) THEN GO TO CTC;% 00631000 + COMMENT IF LIST IS NOT A DESCRIPTOR WE HAVE% 00631100 + A SPACE STATEMENT AND ACT = # OF% 00631200 + RECORDS TO SPACE;% 00631300 + IF FIB[4].[8:4]=4 THEN% 00631400 + BEGIN IF FIB[4].[27:3]!1 THEN% 00631500 + P(MKS,FIB[7]+JUNK1,1,FILX,1,SELECT);% 00631600 + END ELSE% 00631700 + WHILE (ACT~ACT-1)}0 DO% 00631800 + BEGIN CKPB; POLISH(MKS,DKADR,0,FILX,ALGOLREAD); END; 00631900 + LSTRN ~ TLSTRN;% 00632000 + POLISH(XIT);% 00632100 + CTC: IF NOT P( FRMT,TOP) THEN GO TO FMOUTA; COMMENT WE HAVE% 00632200 + ,;% 00632300 + IF P ! 0 THEN GO TO AEXPL; COMMENT WE HAVE AEXP,A[*];% 00632400 + IF FI=1 THEN GO TO FREFLD ELSE %%% / TYPE FREE-FIELD READ 00632500 + IF FI=2 THEN GO FMOUTM1 ELSE %%% // TYPE FREE-FIELD READ 00632510 + IF ARRY } 0 THEN GO TO AEXPL;% 00632600 + COMMENT WE HAVE *,LIST;% 00632700 + ASLST: P(0,.LSTRN,SND); COMMENT LSTRN ~ 0 S ~ I ~ 0;% 00632800 + BS: P(DUP,[LISX]); COMMENT S = ADDRESS OF LIST ITEM 00632900 + S-1 = INDEX FOR BUFF; 00633000 + IF LSTRN < 0 THEN GO TO BR; COMMENT LIST IS EXAUSTED;% 00633200 + IF P(XCH,BUFF,XCH,STD,1,ADD,DUP) < BSIZE 00633300 + THEN GO TO BS; COMMENT BUFFER ITEM TO LIST IF I+1% 00633400 + IS { BUFFER SIZE THEN GET NEXT WORD;% 00633500 + BR: P(1); COMMENT SET FLAG = EXIT;% 00633600 + READS; COMMENT RELEASE BUFFER;% 00633700 + COMMENT AEXP,A[*];% 00633800 + AEXPL: IF P(ARRY.[8:10],DUP) { AEXP THEN GO TO ISA;% 00633900 + IF AEXP < 0 THEN ARRY[-1]~0; 00634000 + P(DEL,AEXP);% 00634100 + COMMENT STACK IS SMALLEST OF ARRAY SIZE OR AEXP;% 00634200 + ISA: IF P(DUP) { BSIZE THEN GO TO ISB;% 00634300 + P(DEL,BSIZE);% 00634400 + COMMENT STACK NOW HAS SMALLEST OF BUFFER SIZE AEXP 00634500 + ARRAY SIZE;% 00634600 + ISB: BSIZE ~ P;% 00634700 + COMMENT BSIZE = # OF WORDS TO TRANSFER;% 00634800 + STREAM(P4 ~ *FILX,P3 ~ BSIZE,P2 ~ BSIZE DIV 64,% 00634900 + P1 ~ [ARRY[0]]);% 00635000 + BEGIN% 00635100 + SI~P4;% 00635200 + P2(DS~32 WDS;% 00635300 + DS~32 WDS);% 00635400 + DS~ P3 WDS;% 00635500 + END;% 00635600 + ERROR: P(1); COMMENT ON ERROR, RELEASE BUFFER AND EXIT;% 00635700 + READS;% 00635800 + COMMENT WE HAVE FORMAT,LIST OR FORMAT,;% 00635900 + FMOUTA: P(DEL) ; 00636000 + FMOUTM1: LSTRN~0 ; 00636100 + FMOUT: P(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0) ; 00636200 + COMMENT 19 GOOSE EGGS FOR YE OLDE STACK ; 00636300 + ADDRS ~ LISX;% 00636400 + SAVEBUFF~BUFF~P(0,[BUFF],0,INX) ; 00636500 + CSIZE ~ BSIZE | 8;% 00636600 + IF FRMT=0 THEN %%% SPLCIAL // TYPE OF FREE-FIELD READ. 00636610 + BEGIN CODE~11; UFREEFIELD~1; FAW~1&1[27:47:1] ; 00636620 + GO TO PHRAS END ELSE 00636630 + GO TO S ;% 00636700 + S2: P(DEL) ; 00636710 + S1: FI~FI+1; COMMENT LOOK AT NEXI EDITING PHRASE;% 00636800 + S: CODE ~ 0&(FAW ~ FRMT[FI])[44:2:4];% 00636900 + IF FAW > 0 THEN GO TO PHRAS; COMMENT PHRAS IF S=0;% 00637000 + GO TO P(CODE);% 00637100 + GO TO RTPAR;% 00637200 + GO TO STRNG;% 00637300 + GO TO LFPAR;% 00637400 + GO TO SLASH;% 00637500 + GO TO SCALE;% 00637600 + COMMENT LEFT PARENTHESIS;% 00637700 + LFPAR: IF FAW.[12:1] THEN 00637800 + BEGIN IF P(LISTELEMENT,DUP)<0 THEN 00637900 + BEGIN P(DEL); FI~FAW.[28:10]+FI END; 00638000 + END ELSE P(FAW.[38:10]); 00638100 + GO TO S1;% 00638200 + COMMENT RIGHT PARENTHESIS;% 00638300 + RTPAR: IF P(1,SUB,DUP) =0% 00638400 + THEN BEGIN COMMENT LFPAR REPEAT -1;% 00638500 + P(DEL); COMMENT DELETE 0 REPEAT;% 00638600 + GO TO S1; COMMENT PICK UP NEXT PHRASE;% 00638700 + END;% 00638800 + FI ~ FI - (FAW AND 1023); COMMENT SET FI BACK TO LFPAR;% 00638900 + GO TO S1;% 00639000 + COMMENT SCALE FACTOR;% 00639100 + SCALE: SCFTR~IF FAW.[12:1] THEN LISTELEMENT 00639200 + ELSE 0&FAW[38:38:10]&FAW[1:11:1]; 00639300 + GO TO S1;% 00639400 + COMMENT STRINGS;% 00639500 + STRNG: IF (CHR ~ (W ~ FAW.[6:6]) + CHR)>CSIZE% 00639600 + THEN GO TO ERROR; COMMENT BUFFER OVERFLOW;% 00639700 + COMMENT CHR ~ CHR + W;% 00639800 + STREAM(P2 ~ W,P1 ~ 0:P0 ~ BUFF);% 00639900 + BEGIN% 00640000 + SI~P0;% 00640100 + DI~LOC P1;% 00640200 + DI~DI-P2;% 00640300 + DS~P2 CHR;% 00640400 + P1~SI;% 00640500 + END;% 00640600 + BUFF ~ P;% 00640700 + FRMT[FI] ~ P(XCH)&FAW[1:1:11]; COMMENT DIAL S,CODE & W TO 00640800 + STRING OBTAINED FROM BUFFER AND PUI RESULI% 00640900 + BACK INTO FORMAT ARRAY;% 00641000 + GO TO S1;% 00641100 + COMMENT SLASH;% 00641200 + SLASH: POLISH((LSTRN<0) AND FAW);% 00641300 + READS; COMMENT RELEASE BUFFER;% 00641400 + CHR ~0;% 00641500 + BUFF ~ P(0,[BUFF],0,INX);% 00641600 + CSIZE ~ BSIZE | 8;% 00641700 + GO TO S1;% 00641800 + COMMENT BREAK APART FORMAT WORD;% 00641900 + PHRAS: IF FAW.[12:1] THEN P(LISTELEMENT) ELSE P(FAW.[38:10]); 00642000 + IF CODE=13 THEN CODE~IF (CODE~LISTELEMENT)="D" THEN 0 ELSE00642100 + IF CODE="T" THEN 1 ELSE 00642150 + IF CODE="X" THEN 2 ELSE 00642200 + IF CODE="A" THEN 4 ELSE 00642300 + IF CODE="I" THEN 6 ELSE 00642400 + IF CODE="F" THEN 8 ELSE 00642500 + IF CODE="E"THEN 10 ELSE 00642600 + IF CODE="U" THEN 11 ELSE 00642610 + IF CODE="O" THEN 12 ELSE 00642700 + IF CODE="L" THEN 14 ELSE 00642800 + IF CODE="R" THEN 15 ELSE 16; 00642900 + CODE1~CODE=1 ; 00642905 + IF (TYP~CODE=11) AND FAW.[31:1] THEN GO TO FMTERR ELSE 00642910 + W~IF FAW.[13:1] THEN LISTELEMENT-CODE1 ELSE 00643000 + IF TYP AND FAW.[27:1] THEN 64 00643010 + ELSE FAW.[6:6] ; 00643020 + D~IF FAW.[14:1] THEN LISTELEMENT 00643100 + ELSE IF TYP THEN FAW.[32:6] 00643110 + ELSE (D1~FAW.[20:4])+(D2~FAW.[16:4]); 00643200 + IF P(DUP){0 THEN GO TO S2 ; 00643300 + IF W<0 THEN IF CODE1 AND W=(-1) THEN GO S2 00643320 + ELSE IF NOT(CODE=0 OR CODE=12) THEN GO TO FMTERR; 00643330 + IF D<0 THEN IF NOT(CODE!15 AND CODE!8 AND CODE!10) 00643340 + THEN GO TO FMTERR ; 00643350 + IF W=0 THEN IF CODE!2 AND NOT CODE1 THEN GO S2 ; 00643360 + IF TYP THEN BEGIN IF D>63 THEN D~63 ; 00643370 + IF NOT(FAW.[27:1] OR W<64) THEN GO TO FMTERR 00643372 + ELSE W~W.[42:6] ; GO TO INLOOP END ELSE 00643376 + IF FAW.[13:2]!0 OR FAW.[2:4]=13 THEN 00643400 + BEGIN GO TO P(IF CODE=15 THEN 8 ELSE IF CODE1 THEN 2 00643500 + ELSE CODE) ; 00643590 + GO C; GO X; GO A; GO I; GO R; GO E; GO O; GO L; 00643600 + GO TO FMTERR ; 00643700 + L: W1~IF W{5 THEN W ELSE 5; GO TO Z; 00643800 + X: W1~W DIV 64; W~SKIP~W.[42:6]; 00643900 + GO TO ZW2; 00644000 + A: W1~IF W{6 THEN W ELSE 6; 00644100 + Z: SKIP~W-W1; GO TO ZW2; 00644200 + I: W1~IF W{8 THEN W ELSE 8; 00644300 + SKIP~IF W{16 THEN 0 ELSE W-16; 00644400 + W2~W-SKIP-W1; GO TO ZD; 00644500 + E: D~(FAW.[2:4]=13 OR FAW.[14:1])+D; 00644600 + D2~D-D1~IF D{8 THEN D ELSE 8; 00644700 + SKIP~IF (W-D){5 THEN 0 ELSE W-D-5; 00644800 + W1~W2~0; GO TO SWT; 00644900 + R: D2~D-D1~IF D{8 THEN D ELSE 8; 00645000 + SKIP~IF (W-D){17 THEN 0 ELSE W-D-17; 00645100 + W1~IF (W-D){8 THEN W-D-1 ELSE 8; 00645200 + W2~IF (W-D-SKIP){9 THEN 0 ELSE W-D-SKIP-9; 00645300 + GO TO SWT; 00645400 + C: O: W~8; W1~SKIP~0; 00645500 + ZW2: W2~0; 00645600 + ZD: D~D1~D2~0; 00645700 + SWT: WT~W1+W2; 00645800 + END ELSE 00645900 + BEGIN WT~(W1~FAW.[28:4])+(W2~FAW.[24:4]); 00646000 + SKIP~FAW.[32:6]; 00646100 + END; 00646200 + INLOOP: IF CODE { 2 THEN GO TO FLDW;% 00646300 + IF LSTRN}0 THEN IF CODE=11 THEN GO TO UTYPE ELSE GO FLDW 00646400 + ELSE UALLDONE ; 00646500 + FLDW: IF CODE1 THEN BEGIN BUFF~SAVEBUFF; CHR~W; GO XTYPE END ; 00646600 + IF (CHR~W+CHR)>CSIZE 00646700 + THEN GO TO ERROR; COMMENT BUFFER EXAUSTED;% 00646800 + COMMENT SELECT EDITING PHRASE;% 00646900 + JMP: IF CODE = 15 THEN GO TO RTYPE;% 00647000 + IF CODE THEN GO TO FMTERR ; 00647020 + GO TO P(CODE);% 00647100 + GO TO DTYPE; COMMENT CODE = 0 =D;% 00647200 + GO TO XTYPE; COMMENT CODE = 2 =X;% 00647300 + GO TO ALFA; COMMENT CODE = 4 =A;% 00647400 + GO TO ITYPE; COMMENT CODE = 6 =I;% 00647500 + GO TO FTYPE; COMMENT CODE = 8 =F;% 00647600 + GO TO ETYPE; COMMENT CODE = 10=E;% 00647700 + GO TO OTYPE; COMMENT CODE = 12=O;% 00647800 + GO TO LOGI ; COMMENT CODE = 14=L;% 00647900 + FMTERR: 00647903 + UERR: IF FILX.[18:15]>1 THEN 00647906 + BEGIN %%% NOT ARRAYROWBUFF, SO TRY PAR LBL BRANCH. 00647909 + P(FILX[NOT 3]); FILX[NOT 3]~FILX[NOT 4]~0 ; 00647912 + P(MKS,9,JUNK) ; 00647915 + END ; 00647918 + TEN~0; TEN~P([TEN[1]],CFX,SFB)&10[8:38:10] ; 00647921 + W2~((W1~FIB[7]+1)>9)+(W1>99)+(W1>999)+1 ; 00647924 + IF NOT UTYP THEN 00647927 + BEGIN ; 00647930 + STREAM(P2~W2,P1~W1,TEN) ; 00647933 + BEGIN DS~14LIT"-FMT ERR, REC="; SI~LOC P1 ; 00647936 + DS~P2 DEC; DS~10LIT", NO LBL:~" ; 00647939 + END ; 00647942 + END 00647945 + ELSE 00647948 + BEGIN ; 00647951 + STREAM(P9~W2,P8~(CHR>9)+(CHR>99)+1,P7~UEXP,UH,CHR, 00647954 + W1,P6~D~UD,P5~D!0,P4~(D>9)+1,P3~W~UW,P2~W!0, 00647957 + P1~(W>9)+1,P0~CHR~UFREEFIELD,TEN) ; 00647960 + BEGIN DS~2LIT"-U"; P2(SI~LOC P3; DS~P1 DEC) ; 00647963 + P5(DS~LIT"."; SI~LOC P6; DS~P4 DEC);P0(DI~DI+5);00647966 + DS~5LIT" ERR#"; SI~LOC P7; DS~DEC ; 00647969 + DS~5LIT",CHR="; SI~SI+7; DS~CHR ; 00647972 + DS~5LIT",COL="; DS~P8 DEC; DS~3LIT",R=" ; 00647975 + DS~P9 DEC; DS~9LIT",NO LBL:~" ; 00647978 + END ; 00647981 + IF CHR THEN STREAM(TEN); DS~7LIT"-FREFLD" ; 00647984 + END ; 00647987 + P([TEN[0]].[33:15],34,COM) ; 00647990 + COMMENT L PHRASE;% 00648000 + LOGI: STREAM(P3 ~ W1, P2 ~ BUFF:P1 ~ SKIP);% 00648100 + BEGIN% 00648200 + SI~P2;% 00648300 + SI~SI+P1; COMMENT SKIP ANY LEAOING BLANKS; 00648400 + DI~LOC P1;% 00648500 + DS~6 LIT "TRUE "; COMMENT PUT COMPARE IN P1;% 00648600 + DI~DI-6;% 00648700 + IF P3 SC ! DC% 00648800 + THEN GO TO BL ; 00648900 + LA: TALLY ~ 1 ; COMMENT IF SAME,P3~1;% 00649000 + GO TO LC;% 00649100 + BL: DI~LOC P1 ; 00649200 + DS~ 6 LIT " TRUE "; COMMENT PUT COMPARE IN P1;% 00649300 + DI~DI-6;% 00649400 + SI~SI-P3;% 00649500 + IF P3 SC=DC% 00649600 + THEN TALLY~1; COMMENT IF SAME, P3-1;% 00649700 + LC: P3 ~ TALLY;% 00649800 + P2 ~ SI;% 00649900 + END;% 00650000 + GO TO COMA;% 00650100 + COMMENT D PHRASE;% 00650200 + DTYPE: STREAM(P2 ~ 0:P1 ~ BUFF);% 00650300 + BEGIN% 00650400 + SI~P1;% 00650500 + SI~SI+8;% 00650600 + P2~SI;% 00650700 + END;% 00650800 + BUFF ~ P;% 00650900 + GO TO COMM;% 00651000 + COMMENT O PHRASE;% 00651100 + OTYPE: 00651200 + STREAM(P2~0: P1~BUFF); % CHECK FOR FLAG BIT 00651210 + BEGIN 00651220 + SI ~ P1; 00651230 + IF SB THEN TALLY ~ 1; 00651240 + P2 ~ TALLY; 00651250 + END; 00651300 + IF P THEN 00651310 + BEGIN % DATA HAS FLAG BIT 00651320 + COMMENT IF F-FIELD = 0 OR R THEN LIST ITEM IS 00651330 + SIMPLE VARIABLE IN STACK OR PRT; 00651340 + IF (JUNK1 ~ [ADDRS].[18:15]) = 0 THEN GO FLAGBIT; 00651350 + IF P(10,LOD).[18:15] = JUNK1 THEN GO FLAGBIT; 00651400 + END; 00651410 + COMMENT EITHER NO FLAG BIT OR DATA GOES TO ARRAY; 00651420 + STREAM(P3~0: P2~BUFF, P1~[ADDRS]); 00651430 + BEGIN 00651440 + SI ~ P2; % DI SET FROM LAST PARAMEIER 00651450 + DS ~ 8 CHR; 00651500 + P3 ~ SI; 00651510 + END; 00651520 + BUFF ~ P; 00651530 + GO TO COMM; 00651540 + FLAGBIT: 00651550 + COMMENT FLAGGED DATA GOING TO STACK OR PRT CAN CAUSE 00651600 + BAD PROBLEMS. FORCE FLAG BIT INTERRUPT HERE; 00651610 + JUNK1 ~ [JUNK1]; 00651620 + P(JUNK1); 00651630 + COMMENT CONTROL CANNOT REACH THIS POINT; 00651640 + COMMENT U PHRASE;% 00651715 + UTYPE: IF D}CSIZE THEN UALLDONE ; %%% EXIT IF MIN FLD-WDTH}BUFFSZ00651720 + SGN~SGN&12[42:42:6]&D[36:42:6]&W[30:42:6] ; 00651725 + W~IF W=0 THEN TEN[60] ELSE IF W>CSIZE THEN CSIZE ELSE W+1;00651730 + UBUILD~UCHCNT~0 ; 00651735 + DO UCH UNTIL UEOW OR UH!" " ; %%% SCAN UNTIL CST OR E-O-W.00651740 + USCHCNT~UBUILD~1 ; 00651745 + IF UDELIMCHK THEN GO TO UL5 ; UBUFF~UH ; 00651750 + UNLOCATED~UNUM~UVAL~UDEC~UEXP~0; USGN~UGETSGN ; 00651755 + IF UH="%" THEN %%% WE MAY HAVE AN OCTAL NUM; ERROR EXIT IF00651760 + BEGIN %%% GTR 3777777777777777 OR HAS DIGIT GTR 700651765 + UCH; SGN~SGN EQV (NOT UGETSGN) ; %%%USGN~USGN+UGETSGN00651770 + UNUM~UH<8 ; 00651775 + WHILE (UBUILD~UBUILD+1)<17 AND UH<8 DO 00651780 + BEGIN UVAL~UH&UVAL[3:6:42]; UCH END ; 00651785 + IF UBUILD=17 AND UH<8 AND (NOT UVAL.[3:1]) THEN 00651790 + BEGIN %%% WE NOW BUILD 16-TH OCTAL DIGIT. 00651795 + UVAL~UH&UVAL[1:4:44]; UCH ; 00651800 + END ; 00651805 + GO TO UENDNUM ; 00651810 + END ; 00651815 + UNUM~UH<10 ; 00651820 + WHILE UH<10 DO BEGIN UVAL~10|UVAL+UH; UCH END ; 00651825 + IF UH="." THEN 00651830 + BEGIN 00651835 + UCH; UNUM~UNUM OR UH<10 ; 00651840 + WHILE UH<10 DO 00651845 + BEGIN UBUILD~UBUILD+1; UDEC~10|UDEC+UH; UCH END;00651850 + END ; 00651855 + IF UH="@" OR UH="E" THEN 00651860 + BEGIN UBUILD~-UBUILD; UCH; UEXPSGN~UGETSGN ; 00651865 + IF NOT UNUM THEN UVAL~1 ; 00651870 + IF UH<10 THEN 00651875 + BEGIN UNUM~1; UBUILD~-UBUILD ; 00651880 + DO BEGIN UEXP~10|UEXP+UH; UCH END UNTIL UH>9 ; 00651885 + END ; 00651890 + END ; 00651895 + UENDNUM: IF UNUM THEN %%% THE CST HAS ENOUGH CHARACTERS IO UNAMBIG-00651900 + BEGIN %%% UOUSLY APPEAR AS A NUMBER. 00651905 + IF UBUILD{0 THEN UGOOFED(5) ; 00651910 + UVAL~UVAL+UDEC/TEN[UBUILD-1] ; 00651915 + IF UEXP!0 THEN UVAL~P(UVAL,TEN[UEXP],IF UEXPSGN THEN 00651920 + P(/) ELSE P(|)) ; 00651925 + P(IF SGN THEN -UVAL ELSE UVAL,[ADDRS],STD) ; 00651930 + UL5: UCHECKIT ; 00651935 + END ; 00651940 + UBUILD~0 ; 00651945 + IF UH!""" THEN 00651950 + IF UDELIMCHK THEN UBUFF~UBUFF.[12:30] ELSE GO TO UL3 00651955 + ELSE BEGIN UBUFF~USCHCNT~0; UQSTRNG~UEXP~1; UL3: UCH END ;00651960 + IF NOT(UDEC~USDELIMCHK) AND USCHCNT<6 THEN 00651965 + BEGIN UL4: UBUFFIT; GO TO UL3 END ; 00651970 + IF (UVAL~0)=USCHCNT THEN GO TO UL6 ; 00651975 + DO IF (UVAL~"|"&UVAL[24:30:18])=UBUFF THEN GO TO UL6 00651980 + UNTIL UVAL.[24:1] ; 00651985 + P(UBUFF,[ADDRS],STD) ; 00651990 + UL6: IF UDEC THEN GO TO UL5; IF LSTRN}0 THEN ADDRS~LISX;00651995 + IF LSTRN<0 THEN 00652000 + BEGIN DO UCH UNTIL USDELIMCHK; GO TO UL5 END ; 00652005 + USCHCNT~UBUFF~0; GO TO UL4 ; 00652010 + COMMENT A PHRASE ; 00652015 + ALFA: STREAM(P3~W1,P2~BUFF:P1~SKIP);% 00652100 + BEGIN% 00652200 + SI~P2;% 00652300 + SI~SI+P1; COMMENT SKIP EVERYTHING BUT LAST 6;% 00652400 + DI~LOC P2;% 00652500 + DI~DI-P3;% 00652600 + DS~P3 CHR;% 00652700 + P2~SI;% 00652800 + END;% 00652900 + GO TO COMA;% 00653000 + COMMENT X PHRASE AND T PHRASE ; 00653100 + XTYPE: IF (CHR~CHR+W1|64)>CSIZE-CODE1 00653200 + THEN GO TO ERROR; COMMENT BUFFER EXAUSTED;% 00653300 + STREAM(P3~BUFF:P2~W1,P1~W);% 00653400 + BEGIN% 00653500 + SI~P3;% 00653600 + SI~SI+P1;% 00653700 + P2(SI~SI+32;% 00653800 + SI~SI+32);% 00653900 + P3~SI;% 00654000 + END;% 00654100 + BUFF ~ P;% 00654200 + GO TO COMM;% 00654300 + COMMENT I PHRASE;% 00654400 + ITYPE: P(0); COMMENT RLIT = FROM I (SEE FOUT);% 00654500 + FIN: COMMENT FIRST WE GET SIGN AND COUNT LEADING BLANKS;% 00654600 + STREAM(% 00654700 + P4~WT, COMMENT IN=FIELD WIDTH,OUT=LEADING% 00654800 + BLANKS;% 00654900 + P3~0 , COMMENT PLACE TO RETURN SIGN;% 00655000 + P2~BUFF: COMMENT IN AND OUT=BUFFER ADDRESS;% 00655100 + P1~SKIP);COMMENT # OF LEADING CHARACTERS TO% 00655200 + IGNORE;% 00655300 + BEGIN% 00655400 + SI~P2;% 00655500 + SI~SI+P1;% 00655600 + P4(IF SC!" " THEN% 00655700 + JUMP REAL TO NTBLK;% 00655800 + SI~SI+1;% 00655900 + TALLY~TALLY+1);% 00656000 + COMMENT IF WE FALL THROUGH LOOP THEN% 00656100 + WHOLE FIELD WAS BLANK;% 00656200 + P4~TALLY;% 00656300 + GO TO IEXIT;% 00656400 + NTBLK: IF SC<"0" THEN% 00656500 + BEGIN COMMENT SIGN IS PRESENT;% 00656600 + IF SC="-" THEN; COMMENT TOGGLE~ TRUE;% 00656700 + SI~SI+1; COMMENT SKIP SIGN;% 00656800 + TALLY~TALLY+1;% 00656900 + END;% 00657000 + IMPLS: P4~TALLY; COMMENT LEADING BLANKS+"SIGN";% 00657100 + TALLY~0; COMMENT INDICATE + SIGN;% 00657200 + IF TOGGLE% 00657300 + THEN TALLY~1; COMMENT TOGGLE = TRUE IF "-";% 00657400 + P3~TALLY; COMMENT PASS BACK SIGN;% 00657500 + IEXIT: P2~SI; COMMENT ADDRESS OF FIRST DIGIT;% 00657600 + END;% 00657700 + BUFF ~ P;% 00657800 + SGN ~ P;% 00657900 + COMMENT NOW TO CONVERT INTEGER;% 00658000 + STREAM(% 00658100 + P5 ~(P(SSN,WT,+,DUP)),% 00658200 + P4 ~ (IF P { 8 THEN 0% 00658300 + ELSE P(8, - ,8,XCH)),% 00658400 + COMMENT IF WT-"LEADING BLANKS" > 8% 00658500 + THEN P5~WT-LEADING BLANKS,P4~ 0% 00658600 + ELSE P5~8,P4~WT-LEADING BLANKS-8;% 00658700 + P3~0, COMMENT PLACE TO RETURN LOW HALF;% 00658800 + P2~0,COMMENT PLACE TO RETURN HIGH HALF;% 00658900 + P1~0: P0 ~ BUFF);% 00659000 + BEGIN% 00659100 + SI~P0;% 00659200 + DI~LOC P2;% 00659300 + DS~P4 OCT; COMMENT CONVERT HIGH HALF;% 00659400 + DI~LOC P3;% 00659500 + DS~P5 OCT; COMMENT CONVERT LOW HALF;% 00659600 + P1~SI;% 00659700 + END;% 00659800 + BUFF ~ P; COMMENT SAVE NEXT FIELD ADDRESS; 00659900 + P(TEN8,MUL,+); COMMENT HIGH HALF | 10*8% 00660000 + - LOW HALF;% 00660100 + IF SGN THEN P(CHS);% 00660200 + IF P(XCH,DEL,XCH,DEL,XCH,DUP) THEN P(XCH,[ADDRS],~) 00660290 + ELSE IF P(XCH,DUP){ P(MAXI) THEN P([ADDRS],ISD) 00660300 + ELSE P([ADDRS],~); 00660310 +% VOID 00660400 + FOUT: IF P THEN GO TO FA;% 00660500 + GO TO COMM;% 00660600 + COMMENT F PHRASE;% 00660700 + FTYPE: P(1);% 00660800 + GO TO FIN; COMMENT USE ITYPE TO CONVERT INTEGER PART; 00660900 + FA: STREAM(P5~ D2,% 00661000 + P4~ D1,% 00661100 + P3~ 0 , COMMENT PLACE TO RETURN LOW HALF;00661200 + P2~ 0 , COMMENT PLACE TO RETURN HIGH HALF;% 00661300 + P1 ~ 0:P0 ~ BUFF);% 00661400 + BEGIN% 00661500 + SI~P0 ;% 00661600 + SI~SI+1; COMMENT SKIP DECIMAL POINT;% 00661700 + DI~LOC P2;% 00661800 + DS~P4 OCT; COMMENT CONVERT HIGH HALF;% 00661900 + DI~LOC P3;% 00662000 + DS~P5 OCT; COMMENT CONVERT LOW HALF;% 00662100 + P1~SI;% 00662200 + END;% 00662300 + BUFF ~ P;% 00662400 + P(TEN[D2] | P + P); COMMENT HIGH HALF | 10*D2 + LOW HALF; 00662500 + P((ABS(ADDRS)| TEN[D]) + P); COMMENT INSERT INTEGER PART;00662600 + P(TEN[D],/); COMMENT SCALE TO PROPER DECIMAL PLACE;00662700 + IF SGN THEN P(CHS);% 00662800 + P([ADDRS],STD);% 00662900 + P(DEL,DEL) ;% 00663000 + GO TO COMM;% 00663100 + COMMENT E PHRASE;% 00663200 + ETYPE: STREAM(P6~ 0, COMMENT PLACE TO RETURN EXPONENT;% 00663300 + P5 ~ P(D-1, DUP), COMMENT D2 IN,MANTISSA SIGN OUT; 00663400 + P4 ~ (IF P { 8 THEN P(0,.D2,SND,XCH)% 00663500 + ELSE P(8,-,.D2,SND,8)),% 00663600 + COMMENT IF (D-1) > 8 THEN P5= D-1-8,P4= 8% 00663700 + ELSE P5= 0, P4=D-1,% 00663800 + D1 ~ P4. ON RETURN P4=INTEGER% 00663900 + DIGIT;% 00664000 + P3 ~ P(0), COMMENT PLACE TO RETURN LOW HALF;% 00664100 + P2 ~ 0, COMMENT PLACE TO RETURN HIGH HALF;% 00664200 + P1 ~ BUFF:% 00664300 + P0 ~ SKIP);% 00664400 + BEGIN% 00664500 + SI~P1;% 00664600 + SI~SI+P0;% 00664700 + P0~SI; COMMENT ADDRESS OF INTEGER;% 00664800 + SI~SI+2; COMMENT SKIP INTEGER DIGIT & ".";% 00664900 + DI~ LOC P2;% 00665000 + DS~ P4 OCT; COMMENT CONVERT HIGH HALF;% 00665100 + DI~ LOC P3;% 00665200 + DS~ P5 OCT; COMMENT CONVERT LOW HALF;% 00665300 + SI~SI+1; COMMENT SKIP "@";% 00665400 + IF SC="-" THEN; COMMENT IF EXPONENT < 0% 00665500 + THEN TOGGLE ~ TRUE;% 00665600 + SI~SI+1; COMMENT SKIP EXPONENT SIGN;% 00665700 + DI~ LOC P6;% 00665800 + DS~ 2 OCT; COMMENT CONVERT EXPONENT;% 00665900 + P1~ SI; COMMENT RETURN ADDRESS OF NEXT% 00666000 + FIELD;% 00666100 + IF TOGGLE THEN% 00666200 + BEGIN DI~DI-8;% 00666300 + DS~ LIT "+";% 00666400 + END; COMMENT IF TOGGLE SET EXPONENT% 00666500 + NEGATIVE;% 00666600 + SI~P0;% 00666700 + DI~LOC P4; COMMENT CONVERT INTEGER DIGII;% 00666800 + DS ~ OCT;% 00666900 + SI~SI-2; COMMENT LOOK AT SIGN;% 00667000 + IF SC="-" THEN TALLY ~1;% 00667100 + P5~TALLY;% 00667200 + END;% 00667300 + COMMENT ON RETURN STACK CONTAINS% 00667400 + BUFF% 00667500 + HIGH HALF% 00667600 + LOW HALF% 00667700 + INTEGER DIGIT% 00667800 + MANTISSA SIGN% 00667900 + EXPONENT;% 00668000 + BUFF ~ P;% 00668100 + P(TEN[D2] | P + P); COMMENT HIGH HALF|10*D2+LOW HALF;% 00668200 + P(XCH,TEN[D-1]|P+P);COMMENT SCALE INTEGER DIGIT D PLACES% 00668300 + AND ADD FRACTION PART;% 00668400 + IF P(XCH) THEN P(CHS); COMMENT INSERT SIGN;% 00668500 + P(XCH); COMMENT EXPONENT TO TOP;% 00668600 + IF (JUNK1 ~ P-(D-1)) } 0% 00668700 + THEN P(TEN[JUNK1],MUL)% 00668800 + ELSE P(TEN[-JUNK1],/); COMMENT INSERT EXPONENT;% 00668900 + GO TO COMB;% 00669000 + COMA: BUFF ~ P;% 00669100 + COMB: P([ADDRS],STD); COMMENT RESULT TO LIST;% 00669200 + COMM: IF CODE { 2 THEN GO TO COMC; COMMENT PHRASE DIDNT USE% 00669300 + ANYTHING FROM LIST;% 00669400 + IF LSTRN}0 THEN ADDRS~IF NOT ULIST THEN LISX 00669500 + ELSE P(.UADDRS,LOD) ; 00669505 + ULIST~0 ; 00669510 + COMC: IF P((UFREEFIELD=0),-,DUP)>0 THEN GO TO INLOOP ; 00669600 + P(DEL);% 00669700 + GO TO S1;% 00669800 + COMMENT THE OF PHRASE IS IN TOP OF STACK% 00669900 + NOW(I HOPE). IF REPEAT-1 > 0 THEN GO TO INLOOP TO00670000 + USE SAME PHRASE OVER. IF REPETE = 0 THEN DELETE% 00670100 + THE 0 AND GO TO S1 TO PICK UP NEXT PHRASE;% 00670200 + COMMENT R EDITING PHRASE;% 00670300 + RTYPE:: STREAM(P6 ~(FLG~0), COMMENT RETURNS FLAG AS TO WHAT IS% 00670400 + IN BUFFER;% 00670500 + P5 ~ 0, COMMENT SIGN;% 00670600 + P4 ~ W, COMMENT FIELD WIDTH;% 00670700 + P3 ~ BUFF: COMMENT BUFFER CHARACTER ADDRESS;% 00670800 + P1 ~ 0);% 00670900 + BEGIN% 00671000 + SI ~ P3;% 00671100 + TALLY ~ P4;% 00671200 + COMMENT SKIP LEADING BLANKS;% 00671300 + P4(IF SC ! " " THEN JUMP OUT TO RSIGN;% 00671400 + SI~SI+1;% 00671500 + TALLY ~ TALLY +63);COMMENT TALLY-1;% 00671600 + COMMENT FALL THRU LOOP MEANS FIELD WAS BLANK;% 00671700 + TALLY~4; COMMENT SET FLAG TO 4;% 00671800 + GO TO RXITA;% 00671900 + NOI: TALLY ~ TALLY + 63;% 00672000 + SI ~ SI+1;% 00672100 + P4 ~ TALLY; COMMENT A "," WAS FOUND FIRST. SKIP% 00672200 + THE "." AND SET FLAG TO 6;% 00672300 + TALLY ~ 6;% 00672400 + GO TO RXITA;% 00672500 + COMMENT EXPONENT FOUND FIRST;% 00672600 + EXPFRST: TALLY ~ TALLY +63;% 00672700 + SI ~ SI+1;% 00672800 + P4 ~ TALLY;% 00672900 + TALLY ~ 8; COMMENT SET FLAG TO 8;% 00673000 + GO TO RXITA;% 00673100 + COMMENT LOOK AT FIRST NON-BLANK CHARACTER;% 00673200 + RSIGN: IF SC="-" THEN GO TO RMINUS;% 00673300 + IF SC="+" THEN GO TO RPLUS;% 00673400 + IF SC="&" THEN GO TO RPLUS;% 00673500 + RXITB: IF SC}"0" THEN GO TO RIMPLUS;% 00673600 + IF SC="." THEN GO TO NOI;% 00673700 + IF SC="E" THEN GO TO EXPFRST;% 00673800 + IF SC="@" THEN GO TO EXPFRST;% 00673900 + COMMENT IF NONE OF THE ABOVE THEN ERROR;% 00674000 + RERR: TALLY ~ 2;% 00674100 + GO TO RXITA;% 00674200 + RMINUS: DI ~ LOC P4;% 00674300 + DI ~ DI-1; COMMENT PASS BACK A "1" FOR A"-";% 00674400 + DS ~ LIT "1";% 00674500 + RPLUS: TALLY ~ TALLY+63;% 00674600 + SI~SI+1;% 00674700 + P4~TALLY;% 00674800 + COMMENT SKIP BLANKS PAST SIGN (IF ANY) THEN LOOK AT% 00674900 + NEXT NON-BLANK;% 00675000 + P4(IF SC!" " THEN JUMP OUT TO RXITB;% 00675100 + SI~SI+1;% 00675200 + TALLY ~ TALLY + 63);% 00675300 + GO TO RERR;% 00675400 + RIMPLUS: P4 ~ TALLY;% 00675500 + TALLY ~ 0;% 00675600 + RXITA: P3 ~ SI;% 00675700 + P6 ~ TALLY;% 00675800 + END;% 00675900 + BUFF ~ P; COMMENT ADDRESS OF NEXT CHARACTER;% 00676000 + WT ~ P; COMMENT REMAINING FIELD;% 00676100 + SGN ~ P; COMMENT SAVE SIGN;% 00676200 + GO TO P; COMMENT SWITCH ON KEY;% 00676300 + GO TO RIPART; COMMENT KEY = 0 = OR ;00676400 + GO TO RERRA; COMMENT KEY = 2 = ERROR;% 00676500 + GO TO RBLF; COMMENT KEY = 4 = BLANK FIELD;% 00676600 + GO TO RFA; COMMENT KEY = 6 = "." OR ".";% 00676700 + COMMENT FALL THRU FOR KEY = 8 = OR% 00676800 + ~ ;% 00676900 + JUNK1 1; COMMENT MANTISSA ~ 1;% 00677000 + W1 ~ 0; COMMENT 0 DECIMAL PLACES;% 00677100 + GO TO REXP; COMMENT OUT TO DEVELOP EXPONENT;% 00677200 + COMMENT BLANK FIELD;% 00677300 + RBLF: P(0,SSN); COMMENT SET RESULT TO -0;% 00677400 + GO TO COMB;% 00677500 + COMMENT "." FOUND FIRST;% 00677600 + RFA: JUNK1 ~ 0; COMMENT MANTISSA ~ 0;% 00677700 + FLG ~ 1 ; COMMENT SET FLG TO REMEMBER NO INTEGER% 00677800 + PART;% 00677900 + GO TO RFPART;% 00678000 + COMMENT DIGIT FOUND FIRST;% 00678100 + RIPART: P(1); COMMENT CALL GETNUM TO BUILD OCTAL% 00678200 + INTEGER PART;% 00678300 + GO TO GETNUM;% 00678400 + RIPRTN: IF NOT P THEN GO TO RFC; COMMENT BRANCH ON KEY GETNUM% 00678500 + RETURNS. IF NO BRANCH THEN WE HAVE FIELD EXAUSIED.% 00678600 + I.E. IMPLIED DECIMAL;% 00678700 + W1 ~ D; COMMENT DECIMAL PLACES IN FRACIION;% 00678800 + RDONA: W2 ~ 0; COMMENT NO EXPONENT;% 00678900 + COMMENT BUILD RESULT;% 00679000 + RDONE: P(JUNK1); COMMENT GET NUMBER;% 00679100 + IF SGN THEN P(SSN); COMMENT INSERT SIGN;% 00679200 + COMMENT SCALE NUMBER;% 00679300 + IF P(W2 + SCFTR-W1,DUP) } 0% 00679400 + THEN P(TEN[P],MUL)% 00679500 + ELSE P(TEN[-P],/);% 00679600 + GO TO COMB;% 00679700 + MAXI::: @7777777777777; 00679750 + COMMENT THE FIELD IS NOT EXAUSTED;% 00679800 + RFC: WT ~ WT -1; COMMENT WT-1 TO ACCOUNT FOR CHARACTER% 00679900 + ENDING INTEGER FIELD;% 00680000 + IF W2 = "." THEN GO TO RFPART;% 00680100 + COMMENT OUT FOR VISABLE DECIMAL POINT;% 00680200 + IF WT } D THEN GO TO RERRA;% 00680300 + COMMENT ERROR IF IMPLIED POINT TO RIGHT% 00680400 + OF MANIISSA FIELD;% 00680500 + W1 ~ D-WT-1; COMMENT CALCULAIE DECIMAL POSITION FROM% 00680600 + DECIMAL PLACES AND POSITION OF RIGT MOST% 00680700 + O DIGIT IN MANTISSA;% 00680800 + COMMENT L-OK FOR AND CONVERT ANY EXPONENT FOUND;% 00680900 + REXP: STREAM(% 00681000 + P6 ~ 0, COMMENT PLACE TO RETURN EXPONENT;% 00681100 + P5~WT+1, COMMENT REMAINING FIELD WIDTH;% 00681200 + P4~ BUFF,% 00681300 + P3~1: COMMENT FLAG;% 00681400 + P1~0);% 00681500 + BEGIN COMMENT LOOK FOR E OR @;% 00681600 + SI ~ P4; SI ~ SI -1;% 00681700 + TALLY ~ P5;% 00681800 + P5( IF SC! " " THEN JUMP OUT TO RAA;% 00681900 + SI ~ SI + 1;% 00682000 + TALLY ~ TALLY + 63);COMMENT TALLY - 1 ;% 00682100 + GO TO REXTA; COMMENT OUT IF NO EXPONENT;% 00682200 + RAA: IF SC="E" THEN GO TO RAB;% 00682300 + IF SC="@" THEN GO TO RAB;% 00682400 + RAER:TALLY ~ 0; COMMENT IMPROPER EXPONENT,% 00682500 + P3 ~ TALLY;% 00682600 + GO TO REXTA;% 00682700 + COMMENT LOOK FOR EXPONENT SIGN;% 00682800 + RAB: TALLY ~ TALLY + 63;% 00682900 + SI ~ SI + 1;% 00683000 + IF SC="-" THEN% 00683100 + BEGIN% 00683200 + P5 ~ TALLY;% 00683300 + TALLY ~ 1;% 00683400 + P1 ~ TALLY; COMMENT REMEMBER "-" SIGN;% 00683500 + TALLY ~ P5;% 00683600 + GO TO REP;% 00683700 + END;% 00683800 + IF SC="+" THEN% 00683900 + BEGIN% 00684000 + REP: TALLY ~ TALLY + 63;% 00684100 + P5~TALLY; 00684200 + SI ~ SI + 1; COMMENT SKIP OVER SIGN;% 00684300 + P5(JUMP OUT TO RADC); COMMENT OUT IF FIELD NOT% 00684400 + EXAUSTED (P5!0);% 00684500 + GO TO RAER; COMMENT OUT ON ERROR;% 00684600 + REXTA: GO TO REXT;% 00684700 + RAERA: GO TO RAER;% 00684800 + END;% 00684900 + IF SC="&" THEN GO TO REP;% 00685000 + COMMENT LOOK FOR DIGITS IN EXPONENT;% 00685100 + RADC: IF SC < "0" THEN GO TO RAER;% 00685200 + COMMENT OUT IF NOT DIGIT-ERROR;% 00685300 + TALLY ~ TALLY +63;% 00685400 + P5 ~ TALLY;% 00685500 + COMMENT LOOK FOR 2ND DIGIT;% 00685600 + P5(SI~SI+1;% 00685700 + IF SC}"0" THEN% 00685800 + BEGIN% 00685900 + SI~SI-1;% 00686000 + DI ~ LOC P6;% 00686100 + DS ~ 2 OCT;% 00686200 + TALLY ~ TALLY + 63;% 00686300 + P5 ~ TALLY;% 00686400 + JUMP OUT TO RAIS;% 00686500 + END;% 00686600 + IF SC!" " THEN JUMP OUT TO RAER;% 00686700 + SI ~ SI - 1; JUMP OUT TO RAC);% 00686800 + RAC: DI ~ LOC P6;% 00686900 + DS ~ OCT;% 00687000 + COMMENT PUT IN EXPONENT SIGN SAVED IN P1;% 00687100 + RAIS: P1(DI ~ LOC P6;% 00687200 + DS ~ LIT "+");% 00687300 + P5( IF SC ! " " THEN JUMP OUT TO RAERA;% 00687400 + SI ~ SI + 1);% 00687500 + REXT: P4 ~ SI;% 00687600 + END;% 00687700 + IF NOT P THEN GO TO RERRA; COMMENT OUT ON ERROR;% 00687800 + BUFF ~ P;% 00687900 + P(DEL);% 00688000 + W2 ~P; COMMENT EXPONENT;% 00688100 + GO TO RDONE;% 00688200 + COMMENT WE COME HERE IF A "." IS FOUND IN FIELD;% 00688300 + RFPART: P(JUNK1,[ADDRS],STD);% 00688400 + COMMENT SAVE INTEGER PART IN ADDRS;% 00688500 + IF (JUNK2 ~ WT) { 0 THEN% 00688600 + BEGIN COMMENT "." WAS LAST IN FIELD;% 00688700 + IF FLG THEN GO TO RERRA;% 00688800 + COMMENT ERROR IF ONLY A "." WAS FOUND;% 00688900 + W1 ~ 0; COMMENT INDICATE NO FRACTION PART;% 00689000 + GO TO RDONA;% 00689100 + END;% 00689200 + P(0);% 00689300 + GO TO GETNUM; COMMENT CALL GETNUM TO BUILD FRACTION;% 00689400 + RFPRTN: IF (W1 ~ JUNK2 - WT) = 0 THEN% 00689500 + BEGIN COMMENT FRACTION PART IS BLANK;% 00689600 + IF FLG THEN GO TO RERRA;% 00689700 + COMMENT ERROR IF ONLY "." IN FIELD;% 00689800 + END;% 00689900 + COMMENT DEVELOP NUMBER;% 00690000 + JUNK1 ~ JUNK1 + ADDRS | TEN[W1];% 00690100 + COMMENT INTEGER PART | 10@ 00690200 + + FRACTION PART;% 00690300 + IF P THEN GO TO RDONA;% 00690400 + COMMENT BRANCH ON KEY GETNUM RETURNED.% 00690500 + IF TRUE THEN FIELD EXAUSTED;% 00690600 + WT ~ WT -1; COMMENT WT-1 TO ACCOUNT FOR CHARACTER% 00690700 + ENDING FRACTION PART;% 00690800 + GO TO REXP; COMMENT CHECK FOR EXPONENT;% 00690900 + COMMENT SUB-PROGRAM USED BY R-TYPE;% 00691000 + COMMENT GETNUM BUILDS AN OCTAL INTEGER FROM THE BCL% 00691100 + FOUND IN THE BUFFER;% 00691200 + GETNUM:: P(1); COMMENT FLAG USED AI GRTN;% 00691300 + GRTY: STREAM(% 00691400 + P6~0, COMMENT RETURN CHR ENDING INTEGER;% 00691500 + P5~[D1], COMMENT POINTER TO BCL INTEGER;% 00691600 + P4~(IF WT > 16 THEN 16 ELSE WT),% 00691700 + COMMENT WT = FIELD WIDTH;% 00691800 + P3~BUFF:% 00691900 + P1~ 0);% 00692000 + BEGIN% 00692100 + SI ~ P3;% 00692200 + DI ~ P5;% 00692300 + P4(IF SC < "0" THEN JUMP OUT TO RENDM;% 00692400 + DS ~ CHR;% 00692500 + TALLY ~ TALLY +1);% 00692600 + GO TO RCXIT;% 00692700 + RENDM: DI ~ LOC P5;% 00692800 + DI ~ DI-1;% 00692900 + DS ~ CHR; COMMENT RETURN CHARACIER ENDING% 00693000 + INIEGER FIELD;% 00693100 + RCXIT: P3 ~ SI; COMMENT NEXT BUFF ADDRESS;% 00693200 + P4 ~ TALLY; COMMENT RETURN NUMBER OF DIGITS% 00693300 + IN INTEGER;% 00693400 + END;% 00693500 + BUFF ~ P; COMMENT BUFF ~ P3;% 00693600 + W1 ~ P; COMMENT W1 ~ P4;% 00693700 + P(DEL); COMMENT DELETE P5;% 00693800 + W2 ~ P; COMMENT W2 ~ P6;% 00693900 + GRTN: IF NOT P THEN GO TO GTD; COMMENT BRANCH ON FLAG PUT% 00694000 + IN AT GRIY OR GIC;% 00694100 + STREAM(% 00694200 + P7 ~ P(W1,DUP),% 00694300 + P6 ~ (IF P { 8 THEN 0 ELSE P(8,SUB,8,XCH)),% 00694400 + COMMENT THE ABOVE IS "IF WT { 8 THEN P7~WT,P6~0 00694500 + ELSE P7~8,P6~WT-8";% 00694600 + P5 ~0, COMMENT OCTAL OF RIGHT 8 DIGITS;% 00694700 + P4 ~ 0, COMMENT OCTAL OF WHATS LEFT;% 00694800 + P3 ~ [D1]: COMMENT ADDRESS OF BCL INTEGER;% 00694900 + P1 ~ 0);% 00695000 + BEGIN% 00695100 + SI~ P3;% 00695200 + DI~ LOC P4;% 00695300 + DS~ P6 OCT;% 00695400 + DI~ LOC P5;% 00695500 + DS ~ P7 OCT;% 00695600 + END;% 00695700 + P(DEL); COMMENT DELETE P3;% 00695800 + P(TEN8,MUL,ADD,.JUNK1,STD);% 00695900 + COMMENT JUNK1 ~ P4 | 10*8 + P5;% 00696000 + P(DEL,DEL); COMMENT DELETE P6 & P7;% 00696100 + GTB: IF (WT ~ WT-W1) { 0 THEN% 00696200 + BEGIN COMMENT PASS BACK A KEY OF 1 TO% 00696300 + FLAG FIELD EXAUSTED;% 00696400 + P(1,XCH);% 00696500 + GO TO NUMXIT% 00696600 + END;% 00696700 + COMMENT FIELD NOT EXAUSTED SO LOOK AT WHAT ENDED IT; 00696800 + IF W2 > 9 THEN% 00696900 + BEGIN COMMENT MANTISSA EXAUSTED BUT NOT FIELD% 00697000 + SO RETURN A FLAG OF 0;% 00697100 + P(0,XCH);% 00697200 + GO TO NUMXIT;% 00697300 + END;% 00697400 + GTC: P(0); GO TO GRTY; COMMENT MANTISSA NOT EXAUSTED,% 00697500 + SCALE NUMBER LEFT UNTIL IT IS;% 00697600 + GTD: JUNK1 ~ JUNK1 | TEN[W1];% 00697700 + GO TO GTB;% 00697800 + NUMXIT: IF P THEN GO TO RIPRTN ELSE GO TO RFPRTN;% 00697900 + COMMENT DATA ERROR READING R FORMAT;% 00698000 +RERRA: IF FILX.[18:15]>1 THEN 00698100 + BEGIN PARL~FILX[NOT 3]; FILX[NOT 3]~FILX[NOT 4]~0 END 00698150 + ELSE BEGIN 00698200 + IF FILX.[18:15]=1 THEN P(FILX,14,COM); PARL~0; FILX~*2 ;00698300 + END ; 00698400 + IF PARL = 0 THEN P(FILX.[33:15],7,11,COM) 00698500 + ELSE P(PARL,MKS,9,BLKCNTL);% 00698600 + COMMENT IF NO PARITY ACTION LABEL PRINT "RER"% 00698700 + ERROR AND TERMINATE ELSE GO TO PARITY% 00698800 + LABEL;% 00698900 + END INPUTINT;% 00699000 + PROCEDURE DISKSORT( 00700000 + T1,T2,RELA, 00700100 + ENDQ,BINGO,IPFIDX,OUTPRO,INPRO,OUTF,INF, 00700200 + OPTOG,IPTOG,DKO,DKI,TP1,TP2,TP3,TP4,TP5,NT, 00700300 + HIVALU,EQUALS,R,ALFA,CORESIZE,DISKSIZE); 00700400 + COMMENT DISK-SORT BY L.R. GUCK DATE 9/19/1965 ; 00700500 + VALUE OPTOG,IPTOG,NT,HIVALU,EQUALS,R,ALFA, 00700600 + CORESIZE,DISKSIZE; 00700700 + REAL ENDQ, 00700800 + BINGO, 00700900 + IPFIDX, 00701000 + OUTPRO, 00701100 + INPRO, 00701200 + OUTF, % POINTER TO DESC WHICH DESCRIBES OUT AREA 00701300 + T1, 00701400 + T2, 00701500 + RELA, 00701600 + INF; % POINTER TO DESC WHICH DESCRIBES INPUT AREA 00701700 + BOOLEAN OPTOG, % TRUE IF OUTPUT PROCEDURE 00701800 + IPTOG; % TRUE IF INPUT PROCEDURE 00701900 + REAL DKO, % DISK OUTPUT FILE 00702000 + DKI; % DISK INPUT FILE 00702100 + NAME TP1,TP2,TP3,TP4,TP5; % SCRATCH TAPES 00702200 + REAL NT, % FOR FURTURE USE 00702300 + HIVALU, 00702400 + EQUALS; % KEY COMPARE ROUTINE 00702500 + INTEGER R; % RECORD: <0 FOR ALGOL 00702600 + BOOLEAN ALFA; % TRUE FOR ALPHA KEYS 00702700 + REAL CORESIZE; % CORE STORAGE AVAILABLE 00702800 + INTEGER DISKSIZE; % DISK STORAGE AVAILABLE 00702900 + BEGIN 00703000 + LABEL GRA,RTNRD,WRTBLOC,RTNDW,SA,RTNDR, 00703100 + IPB,IPBA,IPC,IPD,IPE,IPG, 00703200 + MIC,MID,MIE,RTA, 00703300 + START,LY,LZ,LX,CALLSORT,ENDSORTPASS, 00703400 + DKC,DKD,DKE,DKF, 00703500 + TPA,TPB,TPC,WRAPUP,SORTDONE; 00703600 + COMMENT GENERAL PARAMETERS; 00703700 + REAL S, % MATRIX SIZE FOR SORT PASS 00703800 + M, % MATRIX SIZE FOR MERGE PASS 00703900 + MS, % CURRENT MATRIX SIZE 00704000 + STPP, % INDEX OF LAST ADDRESS IN VECTOR (V) ARRAY 00704100 + D, % SEGMENTS PER DISK INPUT BLOCK 00704200 + OD, % SEGMENTS PER DISK OUTPUT BLOCK 00704300 + BF, % RECORDS PER DISK INPUT BLOCK 00704400 + TBO, % RECORDS PER DISK OUTPUT BLOCK & TAPE BLOCKING 00704500 + I,X,Y; % TEMPORARY STORAGE 00704600 + ARRAY DATA[*,*]; ARRAY DATX = DATA[*]; NAME DATN = DATA; 00704700 + ARRAY V[*]; NAME VN = V; 00704800 + DEFINE VX1=FLAG(V[X+1])#, VX=FLAG(V[X])#, VL=FLAG(V[VLOW])#; 00704900 + DEFINE VA1 = FLAG(V[X+1 ]&P(0,RDS)[CTF])#, 00704910 + VA = FLAG(V[X ]&P(0,RDS)[CTF])#, 00704920 + XAL= *[INFIL],0,RDS,CFX#, 00704925 + VAL = FLAG(V[VLOW]&P(0,RDS)[CTF])#; 00704930 + REAL VLOW; % INDEX OF NEXT RECORD IN SEQUENCE 00705000 + ARRAY MHK[*]; % HIGH KEY FOR MERGE PHASE 00705100 + NAME MHN=MHK; 00705200 + BOOLEAN MOREDATA, % GOES FALSE WHEN NO MORE INPUT DATA 00705300 + FM, % TRUE ON LAST MERGE PASS 00705400 + EOF, % TRUE WHEN INPUT FILE EXAUSTED 00705500 + TM, % TRUE FOR SORT WITH BACK-UP TAPES 00705600 + MF=T1, % TRUE IF MERGE ONLY 00705700 + DF=IPTOG, % TRUE IF OUTPUT FILE IS A DISK 00705800 + DISKFULL; % TRUE WHEN ASSIGNED DISK SPACE IS FULL 00705900 + REAL TR; % # OF RECORDS OF DATA SAVED ON DISK 00706000 + DEFINE IOC = @2000000000#, 00706100 + POLYMERGE = PRTBASE[RELA] ~ P(DUP,LOD)&1[6:47:1]#; 00706200 + COMMENT PARAMETERS RELATED TO PROGRAMMERS FILES; 00706300 + NAME INFIL = INF; % POINTER TO TOP I/O DESC. 00706400 + NAME WAIN = IPFIDX; % COBOL68 INFILE WORK AREA 00706420 + NAME OUTFIL = OUTF; 00706500 + NAME WAOUT = T2; % COBOL68 OUTFILE WORK AREA 00706520 + ARRAY PRFIB[*]; % CONTAINS TAPE FILES FIB 00706600 + REAL AC; % TRUE FOR COBOL INPUT FILE 00706700 + REAL INCOUNT, % COUNTS # OF RECORDS FROM INPUT FILE 00706800 + OUTCOUNT; % COUNTS # OF RECORDS WRITTEN ON OUTPUT FILE 00706900 + COMMENT POINTERS FOR STANDARD PROCEDURES; 00707000 + NAME MEM = 2; 00707100 + ARRAY FPB = 3[*]; 00707110 + REAL BLOCK = 5, 00707200 + ALWR = 12, 00707300 + ALRD = 13, 00707400 + COFCR = 12, 00707500 + PERFORMGEN = 13, % COBOL68 IN-OUT PROCEDURES 00707510 + CORW = 14, 00707600 + ALFCR = 14, 00707700 + BLKCTR = 16; 00707800 + ARRAY PRTBASE = 10[*]; 00707900 + COMMENT PARAMETERS RELATED TO DISK OUTPUT FILE; 00708000 + NAME DOTOP = DKO; % POINTER TO DISK OUTPUT I/O DESC. 00708100 + ARRAY OUTFIB[*]; % POINTER TO FIB 00708200 + ARRAY OUTHEAD[*]; % POINTER TO FILE HEADER BLOCK 00708300 + REAL LOSA, % DISK ADDRESS OF CURRENT STRING TAG WORD 00708400 + ONS, % RUNNING COUNT OF STRINGS IN OUTPUT AREA 00708500 + ORC, % RUNNING COUNT OF RECORDS IN STRING 00708600 + OCDA, % DISK ADDRESS OF NEXT AVAILABLE OUTPUT AREA 00708700 + ORL, % RUNNING COUNT OF NUMBER OF SEGMENTS LEFY IN 00708800 + % CURRENT ROW 00708900 + ORI, % CURRENT ROW BEING USED 00709000 + SRI, % ROW WHERE STRING STARTED 00709100 + SRS, % NUMBER OF SEGMENTS OF STRING IN ROW SRI 00709200 + OBC; % CURRENT # OF RECORDS IN OUTPUT BUFFER 00709300 + DEFINE ORS= OUTHEAD[8]#; 00709400 + DEFINE FNUM = OUTFIB[4].[13:11]#; 00709410 + COMMENT PARAMETFRS FOR DISK INPUT FILE; 00709500 + ARRAY ITNK = DKI[*]; % POINTER TO INPUT TANK 00709600 + ARRAY INFIB[*], % POINTER TO FIB 00709700 + INHEAD[*]; % POINTER TO FILE HEADER BLOCK 00709800 + ARRAY BASE[*], % POINTER TO CONTROL INFO IN DATA 00709900 + ITOP[*], % POINTER TO TOP I/O DESC 00710000 + BUFF[*] ; % I/O DESCRIPTOR 00710100 + REAL LISA; % HOLDS TAG ADDRESS FOR NEXT MERGE PASS 00710200 + DEFINE IBC = BASE[0]#, % RECORDS LEFT IN BLOCK 00710300 + IRL = BASE[1]#, % RECORDS LEFT IN STRING 00710400 + ISL = BASE[2]#, % BLOCKS LEFT IN ROW 00710500 + IDA = BASE[3]#, % DISK ADDRESS OF NEXT BLOCK 00710600 + IRC = BASE[4]#, % CURRENT ROW OF THIS STRING 00710700 + FCR = IF AC THEN COFCR ELSE ALFCR#; 00710800 + COMMENT PARAMFTERS RELATED TO MERGE TAPES; 00710900 + INTEGER CTRL; % CURRENT CONTROL TAPE 00711000 + INTEGER COT; % CURRENT OUTPUT TAPE 00711100 + NAME COIOD; % LOC OF I/O D OF CURRENT OUTPUT TAPE 00711200 + NAME TP; % BASE POINTER OF MERGE TAPES 00711300 + ARRAY TS[*]; % ARRAYS FOR CONTROLLING DISTRIBUTION 00711400 + ARRAY TC[*]; % PATTERNS ON MERGE TAPES 00711500 + ARRAY TN[*]; 00711600 + NAME TSN=TS; NAME TCN=TC; NAME TNN=TN; 00711700 + REAL TM1=CORESIZE; % TAPES - 1 00711800 + NAME CIIOD; % LOC OF I/O D FOR CURRENT INPUT TAPE 00711900 + %**********************************% 00712000 + SUBROUTINE WAIT; COMMENT WAIT FOR I/O COMPLETE USING ADRRESS 00712100 + ON TOP OF STACK; 00712200 + $ SET OMIT = NOT(TIMESHARING) 00712250 + BEGIN IF NOT (P(XCH,DUP,LOD)).[19:1] THEN P(IOC,36,COM,DEL); 00712252 + $ POP OMIT 00712253 + $ SET OMIT = TIMESHARING 00712299 + IF NOT P(LOD,DUP).[2:1] THEN % CHECK FOR ERRORS 00712340 + IF NOT (P(DUP,DUP).[27:1] AND P(XCH).[7:1]) THEN 00712350 + P(1,XCH, MEM[P INX NOT 1] INX P(2,LNG,XCH), 72, 17, COM); 00712360 + P(DEL); END WAIT; 00712400 + %***************MM*****************% 00712500 + SUBROUTINE RELEASETAPE; % CALLS MCP TO WRITE OUT BUFFERS 00712600 + BEGIN 00712700 + PRFIB[11] ~ TBO; 00712800 + P(COIOD[0] ~ FLAG(PRFIB[16]),COIOD,PRL,DEL); 00712900 + RTA: P(COIOD); WAIT; 00713000 + IF (*COIOD).[27:1] THEN % REEL SWITCH 00713100 + BEGIN 00713200 + P(MKS,0,0,[COIOD[NOT 2]],6,FCR); 00713300 + GO TO RTA; 00713400 + END; 00713500 + COIOD[0] ~ 1 INX FLAG(PRFIB[16] ~ NFLAG(*COIOD)); 00713600 + END RELEASETAPE; 00713700 + SUBROUTINE TAPEWRITE; % BLOCKS OUTPUT TAPES 00713800 + BEGIN 00713900 + PRFIB ~ *[COIOD[NOT 2]]; 00714000 + PRFIB[9] ~ PRFIB[9] + 1; % RECORD COUNTER + 1 00714100 + IF (PRFIB[11] ~ PRFIB[11] - 1) > 0 THEN % BLOCK COUNTER 00714200 + COIOD[0] ~ R INX *COIOD 00714300 + ELSE 00714400 + BEGIN % TIME FOR RELEASE 00714500 + P(0,PRFIB[16] INX MEM,STD); % ZERO CONTROL WORD IN BUFF[2] 00714600 + RELEASETAPE; 00714700 + END; 00714800 + END TAPEWRITE; 00714900 + SUBROUTINE WRITESTOPPER; 00715000 + BEGIN % WRITES END OF STRING OR DUMMY STRINGS 00715100 + PRFIB ~ *[COIOD[NOT 2]]; 00715200 + X ~ PRFIB[9]&(TBO-PRFIB[11])[18:33:15]&("DS")[3:33:15]; 00715300 + P(X,PRFIB[16] INX MEM,STD); 00715400 + TN[COT] ~ TN[COT] + 1; % COUNT UP STRINGS FOR THIS IAPE 00715500 + RELEASETAPE; 00715600 + PRFIB [9] ~ 0 ; % ZERO OUT STRING CTR 00715610 + END WRITESTOPPER; 00715700 + %**********************************% 00715800 + SUBROUTINE OPENOUT; % OPENS PROGRAMMERS OUTPUT TAPE 00715900 + BEGIN 00716000 + IF OPTOG THEN 00716100 + BEGIN P(MKS,[OUTFIL],R,1,1,1,BLOCK); 00716200 + IF AC THEN 00716300 + BEGIN BINGO ~ OUTPRO; ENDQ ~ 0; 00716400 + IF AC.[46:1] THEN % COBOL68 00716430 + BEGIN P(MKS,BINGO,0,PERFORMGEN); 00716440 + COIOD ~ [WAOUT]; 00716445 + WAOUT ~ P(*[OUTFIL],0,CDC); 00716450 + END ELSE 00716460 + P(MKS,BINGO,[PRTBASE[P(DUP)]],LOD,IPFIDX,CDC); 00716500 + END END ELSE 00716600 + BEGIN DF ~ FALSE; PRFIB ~ OUTFIL[NOT 2]; 00716700 + PRFIB[13].[27:1] ~ 0; 00716800 + IF AC THEN 00716900 + BEGIN 00717000 + P(MKS,[OUTFIL[NOT 2]],3,COFCR); 00717100 + DF ~ PRFIB[4].[8:4] = 4; 00717200 + IF AC.[46:1] THEN % COBOL68 00717240 + BEGIN COIOD ~ [WAOUT]; 00717250 + WAOUT ~ P(PRFIB[20].[FF],DUP,DIB 0,LOD,0, 00717260 + CDC,DEL,DIB 0,LOD); 00717270 + END; 00717280 + END 00717300 + ELSE BEGIN P([OUTFIL],0,11,COM,DEL,DEL); 00717400 + P(MKS,1,0,0,(-R),[OUTFIL],ALWR,DEL); END; 00717500 + END 00717600 + END OPENOUT; 00717700 + %**********************************% 00717800 + SUBROUTINE SETUPTAPES; % INITIALIZES TAPES FOR DISTRIBUTION PASS 00717900 + BEGIN 00718000 + FOR I ~ 0 STEP 1 UNTIL NT DO TS[I] ~ TC[I] ~ TN[I] ~ 0; 00718100 + CTRL ~ 0; TC[1] ~ COT ~ 1; TM1 ~ NT-1; 00718200 + TP ~ ((NOT 5) INX [NT]); X ~ TBO|R+1; 00718300 + FOR I ~ 1 STEP 1 UNTIL NT DO 00718400 + BEGIN 00718500 + COIOD ~ TP[I]; PRFIB ~ *[COIOD[NOT 2]]; 00718600 + PRFIB[18] ~ X&X[3:33:15]&X[18:33:15]&(I!1)[1:47:1]; 00718700 + PRFIB[13].[27:1] ~ 0; % SEI TO OUTPUT 00718800 + PRFIB[4].[7:1] ~ ((AC AND 3) = 1); %COBOL61 TAPE SORT FLG 00718900 + PRFIB[9] ~ 0; PRFIB[11] ~ TBO; 00719000 + IF (Y~PRFIB[4].[12:12]) < 1023 THEN 00719100 + PRFIB[4] ~ PRFIB[4]&((Y-1)|ETRLNG)[13:37:11]&1[12:47:1]; 00719200 + IF I ! NT THEN P([COIOD],0,11,COM,DEL,DEL) % OPEN TAPES 00719300 + ELSE PRFIB[18] ~ ABS(PRFIB[18]); 00719400 + IF I ! NT THEN BEGIN P(COIOD); WAIT; END; 00719500 + IF I = 1 THEN COIOD[0] ~ 1 INX *COIOD; 00719600 + END; 00719700 + COIOD ~ TP[COT] ; 00719800 + END SETUPTAPES; 00719900 + %**********************************% 00720000 + SUBROUTINE GETROW; % GETS DISK SPACE FOR NEXT ROW IN OUTPUT AREA 00720100 + BEGIN ORL ~ ORS; 00720200 + IF (ORI ~ ORI + 1) } 30 THEN % DISK SCRATCH FILE IS FULL 00720300 + BEGIN 00720400 + GRA: IF NT < 3 THEN P(1,[DOTOP[NOT 2]],84,17,COM); 00720500 + IF NOT TM THEN SETUPTAPES; 00720600 + TM ~ DISKFULL ~ TRUE; 00720700 + END 00720800 + ELSE 00720900 + IF (OCDA ~ OUTHEAD[ORI]) = 0 THEN % GET DISK SPACE 00721000 + BEGIN 00721100 + P(FPB[FNUM+3],FPB[FNUM],FPB[FNUM+1],ORI, 00721110 + .OUTHEAD,LOD,4,11,COM,DEL,DEL,DEL,DEL,DEL,DEL); 00721120 + IF (OCDA ~ OUTHEAD[ORI]) = 0 THEN GO TO GRA; % NO DISK 00721200 + END 00721300 + END GETROW; 00721400 + SUBROUTINE FORGETDISK; % RETURNS DISK NO LONGER NEEDED 00721500 + BEGIN 00721600 + PRFIB ~ P(XCH); I ~ 9; 00721700 + WHILE (I~I+1) { 29 DO IF PRFIB[I] ! 0 00721800 + THEN P(I ,.PRFIB,LOD,24,COM,DEL,DEL); 00721900 + END FORGETDISK; 00722000 + %XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX% 00722100 + SUBROUTINE INROWCHK; 00722200 + BEGIN 00722300 + IF (ISL ~ ISL - 1) { 0 THEN 00722400 + BEGIN 00722500 + ISL ~ (ORS DIV OD ) | (OD DIV D); % BLOCKS IN ROW 00722600 + IF INHEAD[(IRC ~ IRC + (IRC < 29))] ! 0 00722700 + THEN IDA ~ INHEAD[IRC]; 00722800 + END 00722900 + ELSE IDA ~ IDA + D; 00723000 + END; 00723100 + %**********************************% 00723200 + SUBROUTINE INREAD; COMMENT POINT INPUT BUFFER AT NEXT RECORD; 00723300 + BEGIN 00723400 + IF EOF THEN GO TO RTNRD; 00723500 + INCOUNT ~ INCOUNT + 1; 00723600 + IF IPTOG THEN 00723700 + BEGIN IF AC THEN 00723800 + BEGIN COMMENT CALL INPUT PROCEDURE; 00723900 + IF AC.[46:1] THEN P(MKS,BINGO,0,PERFORMGEN) ELSE 00723980 + P(MKS,BINGO,[PRTBASE[P(DUP)]],LOD,IPFIDX,COC); 00724000 + EOF ~ ENDQ; 00724100 + END ELSE EOF ~ P(MKS,*[INFIL],0,INPRO); 00724200 + END 00724300 + ELSE 00724400 + BEGIN 00724500 + IF AC THEN EOF ~ P(MKS,R,[INFIL],0,CORW) % COBOL 00724600 + ELSE 00724700 + BEGIN COMMENT ALGOL READ; 00724800 + P(MKS,0,0,[INFIL],ALRD); % READ FILE 00724900 + EOF ~ P(MKS,0,3,[INFIL],ALRD) < 0; % WAIT FOR I/O 00725000 + END; 00725100 + END; 00725200 + RTNRD: IF EOF THEN V[VLOW] ~ NFLAG(*[DATX[S]])& 00725300 + S[18:33:15]&1[5:47:1]; 00725400 + END INREAD; 00725500 + %**********************************% 00725600 + SUBROUTINE DISKWRITE; COMMENT BLOCKS OUTPUT BUFFER AND WRITES IT; 00725700 + BEGIN 00725800 + IF NOT P(XCH) THEN GO TO WRTBLOC; % WRITE BLOCK IF TOS = FALSE00725900 + ORC ~ ORC+1; % RECORD COUNT +1; 00726000 + IF (OBC ~ OBC-1) = 0 THEN % IF BUFFER EXAUSTED 00726100 + BEGIN COMMENT BUFFER IS FULL SO WRITE IT OUT; 00726200 + WRTBLOC: OBC ~ TBO; 00726300 + STREAM(P1~OCDA, 00726400 + P2~FLAG(OUTFIB[16])); % DISK ADDRESS TO BUFFER 00726500 + BEGIN SI~LOC P1; DS ~ 8 DEC END; 00726600 + P(1 INX FLAG(OUTFIB[16]),[DOTOP],DUP,OUTFIB[16],SFB,XCH, 00726700 + STD,PRL,DEL); % CALL MCP TO REFILL BUFFER 00726800 + IF (ORL~ORL-OD) } OD THEN 00726900 + OCDA ~OCDA+OD 00727000 + ELSE 00727100 + GETROW; % GET SPACE AND ADDRESS OF NEXT ROW 00727200 + P([DOTOP]); WAIT; % WAIT FOR I/O COMPLETE 00727300 + COMMENT ON I/O COMPLETE SAVE ORGINIAL I/O DESC. IN FIB; 00727400 + OUTFIB[16].[33:15] ~ (NOT 0) INX NFLAG(*[DOTOP]); 00727500 + END 00727600 + ELSE 00727700 + DOTOP[0] ~ R INX *[DOTOP]; % POINT AT NEXT RECORD 00727800 + RTNDW: 00727900 + END DISKWRITE; 00728000 + %**********************************% 00728100 + SUBROUTINE DIST; % CALCULATES DISTRIBUTION PATTERNS FOR 00728200 + BEGIN % MERGE TAPES 00728300 + CTRL ~ (CTRL MOD TM1) + 1; 00728400 + FOR I ~ 1 STEP 1 UNTIL TM1 DO 00728500 + BEGIN TS[I] ~ TC[I]; 00728600 + IF I ! CTRL THEN TC[I] ~ TC[I] + TC[CTRL]; 00728700 + END; 00728800 + END DIST; 00728900 + SUBROUTINE SELECT; % SELECTS A MERGE TAPE TO WRITE A STRING ON00729000 + BEGIN 00729100 + X ~ COT; % SAVE INDEX OF PRIOR TAPE 00729200 + SA: COT ~ COT + 1; 00729300 + IF COT = NT THEN 00729400 + BEGIN COT ~ 1; DIST; END; 00729500 + IF COT = CTRL THEN GO TO SA; 00729600 + PRFIB ~ COIOD[NOT 2]; 00729700 + COIOD[0] ~ FLAG(PRFIB[16]); 00729800 + IF COT ! X THEN P( ((NOT 2) INX TP[COT]) ,[COIOD[NOT 2]], 00729900 + 20,COM,DEL,DEL); 00730000 + COIOD ~ TP[COT] ; 00730100 + COIOD[0] ~ 1 INX *COIOD; 00730200 + END SELECT; 00730300 + %**********************************% 00730400 + SUBROUTINE WRITETAG; % WRITE FRONT OF STRING TAG,00730500 + BEGIN % DEVELOP ADDRESS OF NEXT 00730600 + IF OBC ! TBO THEN % STRING 00730700 + BEGIN P(0); DISKWRITE; END; % WRITE OUT BUFFER 00730800 + BUFF ~ FLAG(OUTFIB[16]) 00730900 + &30[8:38:10] % SET TOP I/O DESCRIPTOR TO 00731000 + &1[27:42:6]; % 30 WORD, 1 SEGMENT WRITE. 00731100 + STREAM(P1~LOSA,P2~ [BUFF[0]]); % DISK ADDRESS OF TAG TO 00731200 + BEGIN SI ~LOC P1; DS ~ 8 DEC END; % BUFFER[0]. 00731300 + IF NOT DISKFULL THEN 00731400 + IF ORL < OD + 1 THEN GETROW; % GET SPACE FOR NEXT ROW 00731500 + BUFF[1] ~ SRI; % ROW WHERE STRING STSRIED 00731600 + BUFF[2] ~ ORC; % RECORDS/STRING. 00731700 + BUFF[3] ~ SRS; % AMOUNT OF STRING IN 00731800 + % ROW WHERE STRING STARTED. 00731900 + BUFF[4] ~ LOSA ~ IF MOREDATA % ADDRESS OF NEXT TAG. 00732000 + AND NOT DISKFULL THEN OCDA ELSE 0; % OR EOF FLAG 00732100 + OCDA ~ OCDA + 1; % SKIP OVER TAG ADDRESS. 00732200 + DOTOP[0] ~ P(.BUFF,LOD); % WRITE TAG ON DISK 00732300 + P(1 INX FLAG(OUTFIB[16]),[DOTOP],PRL,DEL); 00732400 + ONS ~ ONS+1; % STRING COUNTER + 1. 00732500 + SRI ~ ORI; % SAVE WHERE NEXT ROW STARTS00732600 + SRS ~ (ORL~ORL-1); % AMOUNT OF ROW LEFT 00732700 + ORC ~ 0; % RECORDS/STRING ~ 0. 00732800 + P([DOTOP]); WAIT; % WAIT FOR I/O COMPLETE 00732900 + OUTFIB[16] ~ (NOT 0) INX NFLAG(*[DOTOP]); % SAVE IOD IN FIB 00733000 + END WRITETAG; 00733100 + %**********************************% 00733200 + SUBROUTINE DISKREAD; % READS DISK ON DISK-TO- 00733300 + BEGIN % DISK MERGE PASSES. 00733400 + BASE ~ *[DATX[VLOW]]; % POINT AT CURRENT STRING 00733500 + IF IRL { 0 THEN % IF IRL { 0,ALL RECORDS 00733600 + BEGIN V[VLOW] ~ NFLAG(MHK)&MS % IN THIS STRING HAVE BEEN 00733700 + [18:33:15]; 00733800 + GO TO RTNDR; % READ SO POINT CORRESPON- 00733900 + END; % ING V AT HK1. 00734000 + IRL~IRL-1; % RECORDS LEFT - 1. 00734100 + IF (IBC~IBC-1)!0 THEN BEGIN % IF BUFFER NOT EXAUSTED 00734200 + V[VLOW] ~ R INX V[VLOW]; % THEN INDEX TO NEXT RECORD 00734300 + GO TO RTNDR END; 00734400 + IBC ~ BF; % BLOCK COUNTER ~ BLOCKING 00734500 + Y ~ P(VLOW,DUP,ADD); % FACTOR. 00734600 + STREAM(P1~IDA,P2~*[ITOP[Y]]); % CONVERI DISK ADDRESS 00734700 + BEGIN SI ~ LOC P1;DS~8 DEC END; % INTO BUFFER. 00734800 + P([ITOP[Y]],DUP,LOD,XCH,PRL,DEL); % READ NEXT BLOCK 00734900 + INROWCHK; % GET ADDRESS OF NEXT BLOCK 00735000 + P([ITOP[Y]]); WAIT; % WAIT FOR I/O COMPLEIE. 00735100 + COMMENT POINT I/O D PAST DISK ADDRESS; 00735400 + V[VLOW] ~ V[VLOW]&(1 INX (*[ITOP[Y]]))[33:33:15]; 00735500 + RTNDR: END DISK READ; 00735600 + %**********************************% 00735700 + SUBROUTINE WRITEOUT; 00735800 + BEGIN % SELECTS FILE TO BE WRITTEN DURING MERGE 00735900 + IF NOT FM THEN 00736000 + IF TM THEN TAPEWRITE ELSE BEGIN P(1); DISKWRITE END 00736100 + ELSE 00736200 + BEGIN COMMENT CALL OUTPUT PROCEDURE OR WRITE INTRINSIC; 00736300 + OUTCOUNT ~ OUTCOUNT +1; 00736400 + IF OPTOG THEN 00736500 + BEGIN 00736600 + IF AC THEN 00736700 + BEGIN ENDQ ~ 0; IF AC.[46:1] THEN 00736800 + P(MKS,BINGO,0,PERFORMGEN) % COBOL68 00736850 + ELSE P(MKS,BINGO,[PRTBASE[P(DUP)]],LOD,IPFIDX,COC) 00736900 + END ELSE P(MKS,0,*[OUTFIL],0,OUTPRO); 00737000 + END 00737100 + ELSE 00737200 + BEGIN COMMENT OUTPUT FILE RATHER THAN OUTPUT PROCEDURE; 00737300 + IF AC THEN P(MKS,0,1,1,0,R,[OUTFIL],1,CORW) 00737400 + ELSE BEGIN 00737500 + P(MKS,1,0,0,R,[OUTFIL],ALWR); 00737600 + P(MKS,1,0,0,(-R),[OUTFIL],ALWR,DEL); END; 00737700 + IF DF THEN IF P THEN P(1,[OUTFIL[NOT 2]],83,17,COM); 00737800 + END; 00737900 + END; 00738000 + END WRITEOUT; 00738100 + %**********************************% 00738200 + SUBROUTINE SUBMERGE; % SETS UP DISK INPUT TO START A MERGE PASS 00738300 + BEGIN 00738400 + FOR I ~ 0 STEP 1 UNTIL (MS-1) DO 00738500 + BEGIN 00738600 + IF EOF THEN BEGIN 00738700 + V[I] ~ NFLAG(MHK)&MS[18:33:15]; 00738800 + P(0,*[DATX[I]],1,CDC,STD); % IRL ~ 0 00738900 + END 00739000 + ELSE 00739100 + BEGIN 00739200 + BASE ~ *[DATX[I]]; % POINT AT CONTROL INFO 00739300 + Y ~ P(I,DUP,ADD); % Y ~ 2|I 00739400 + BUFF ~ *[ITOP[Y]]; 00739500 + COMMENT SET I/O D = 30 WORD, 1 SEGMENT READ; 00739600 + ITOP[Y] ~ (*[ITOP[Y]])&30[8:38:10]&1[27:42:6]; 00739700 + COMMENT PUT ADDRESS OF STRING TAG WORD IN BUFFER(0); 00739800 + STREAM(P1~( IDA~LISA),P2~*[ITOP[Y]]); 00739900 + BEGIN SI ~ LOC P1; DS ~ 8 DEC END; 00740000 + P(.BUFF,LOD, [ITOP[Y]],PRL,DEL); % READ IAG TO BUFFER 2 00740100 + COMMENT READ 1ST DATA RECORD TO BUFFER #2, TAG GETS 00740200 + ROTATED TO BUFFER #1; 00740300 + P([ITOP[Y]]); WAIT; % WAIT FOR I/O COMPLLTE 00740400 + STREAM(P1~( IDA~IDA +1),P2~*[ITOP[Y]]); % BLOCK #1 ADDRESS00740500 + BEGIN SI ~ LOC P1; DS ~ 8 DEC END; 00740600 + P(*[ITOP[Y]],[ITOP[Y]],PRL,DEL); % READ BLOCK #1 00740700 + P([ITOP[Y]]); WAIT; % WAII FOR I/O ON READING TAG 00740800 + BUFF ~ *[ITOP[Y]]; 00740900 + IBC ~ BF; 00741000 + IRC ~ BUFF[1]; 00741100 + IRL ~ BUFF[2] - 1; 00741200 + ISL ~ (BUFF[3] DIV OD) | (OD DIV D); 00741300 + IF (LISA ~ BUFF[4]) { 0 THEN EOF ~ TRUE; 00741400 + INROWCHK; % GET ADDRESS OF BLOCK #2 00741500 + STREAM(P1~IDA ,P2~[BUFF[0]]); 00741600 + BEGIN SI~LOC P1; DS ~ 8 DEC END; 00741700 + P(.BUFF,LOD,[ITOP[Y]],PRL,DEL); % READ BLOCK #2 00741800 + INROWCHK; % GET ADDRESS OF BLOCK #3 00741900 + P([ITOP[Y]]); WAIT; % WAIT FOR I/O COMPLETE ON BLOCK #1 00742000 + V[I] ~ NFLAG((1 INX *[ITOP[Y]])&I[18:33:15]); 00742100 + END; 00742200 + END; 00742300 + END SUBMERGE; 00742400 + %**********************************% 00742500 + SUBROUTINE FIRSTSELECT; % INITIAL SELECTION OF LOW RECORD 00742600 + BEGIN 00742700 + X ~ 0; I~MS-1; 00742800 + DO BEGIN 00742900 + I~I+1; 00743000 + V[I] ~ V[X+((IF ALFA THEN P(0,MKS,0,VX1,VX,EQUALS) 00743100 + ELSE IF AC THEN P(0,MKS,VX1,VX,EQUALS) 00743200 + ELSE P(MKS,VA1,0,VA,0,EQUALS)) AND TRUE)]; 00743300 + END UNTIL (X~X+2) = STPP; VLOW ~ V[I].[18:15]; 00743400 + END FIRSTSELECT; 00743500 + SUBROUTINE LOWSELECT; 00743600 + BEGIN 00743700 + X ~ VLOW AND 1022; 00743800 + DO BEGIN 00743900 + I ~ MS + X.[38:9]; % I ] MS + (X/2) 00744000 + V[I] ~ V[X+((IF ALFA THEN P(0,MKS,0,VX1,VX,EQUALS) 00744100 + ELSE IF AC THEN P(0,MKS,VX1,VX,EQUALS) 00744200 + ELSE P(MKS,VA1,0,VA,0,EQUALS)) AND TRUE)]; 00744300 + X ~ I AND 1022; 00744400 + END UNTIL I = STPP; VLOW ~ V[I].[18:15]; 00744500 + END LOWSELECT; 00744600 + %*********************************% 00744700 + SUBROUTINE SORTIT; % DEVELOPS STRINGS FROM INPUT TAPE 00744800 + BEGIN 00744900 + COMMENT USE SPECIAL SORT COMMUNICATE TO GET STORAGE FOR 00745000 + DATA AND VECTOR ARRAYS; 00745100 + P(R,S+1,[DATN],21,COM,DEL,DEL,DEL); 00745200 + P(MKS,[VN],(2|S)-1,1,1,1,BLOCK); 00745300 + STPP ~ P(MS~S,DUP,ADD,2,SUB); 00745400 + COMMENT CALL HIVALU TO SET UP HK1 ROW OF DATA; 00745500 + STREAM(A~*[DATX[S]],B~R-1,C~P(DUP).[36:6]); 00745600 + BEGIN DI~A;SI~LOC C;DS~WDS; 00745700 + SI~A;C(DS~32 WDS;DS~32 WDS);DS~B WDS; 00745800 + END; 00745900 + P(MKS,*[DATX[S]]); IF NOT AC THEN P(0,RDS,CFX,0); P(HIVALU); 00746000 + COMMENT INITIAL FILL OF DATA ARRAY FROM INPUT SOURCE; 00746100 + IF TR } 0 THEN 00746200 + BEGIN COMMENT NOT 1 ST CALL ON SORT SO FILL DATA FROM DISK; 00746300 + OUTFIB[13].[27:1] ~ 1; % SET FILE TO READ 00746400 + P([DOTOP],0,11,COM,DEL,DEL); % OPEN DISK FILE 00746500 + P([DOTOP]); WAIT; % SLEEP UNTIL FILE IS OPENED 00746600 + OCDA ~ OUTHEAD[10] + P(OD,DUP,ADD); 00746700 + I ~ 0; ORL ~ ORS; OBC ~ TBO; 00746800 + WHILE I < S DO 00746900 + BEGIN 00747000 + IF I < TR THEN 00747100 + BEGIN;COMMENT MOVE RECORD TO DATA; 00747200 + STREAM(P1~*[DOTOP],P2~R,P3~(P(DUP)).[36:6], 00747300 + P4~*[DATX[I]]); 00747400 + BEGIN SI~P1;P3(DS~32 WDS;DS~32 WDS); DS~P2 WDS END; 00747500 + P(1); DISKWRITE; 00747600 + V[I] ~ NFLAG((*[DATX[I]])&I[18:33:15]); 00747700 + END 00747800 + ELSE V[I] ~ NFLAG((*[DATX[S]])&S[18:33:15]&1[5:47:1]); 00747900 + I ~ I+1; 00748000 + END; 00748100 + P(MKS,0,0,[DOTOP[NOT 2]],4,FCR); % REWIND 00748200 + OUTFIB[13].[27:1] ~ 0; % SET TO OUTPUT 00748300 + P([DOTOP],0,11,COM,DEL,DEL); % OPEN FILE OUTPUT 00748400 + P([DOTOP[1]]); WAIT; 00748500 + GO TO IPB; 00748600 + END FILL OF DATA FROM DISK; 00748700 + IF IPTOG OR AC THEN BEGIN INREAD; INCOUNT ~ 0 END; 00748800 + FOR VLOW ~ 0 STEP 1 UNTIL S-1 DO 00748900 + BEGIN COMMENT FILL DATA FROM INPUT FILE; 00749000 + IF VLOW ! 0 THEN INREAD; % POINT AT NEXT RECORD 00749100 + IF NOT EOF THEN 00749200 + BEGIN; COMMENT MOVE RECORD FROM FROM BUFFER TO DATA[VLOW,0]; 00749300 + STREAM(P1~*[CIIOD],P2~R,P3~P(DUP).[36:6], 00749400 + P4~ *[DATX[VLOW]]); 00749500 + BEGIN SI ~ P1; P3(DS~32WDS;DS~32WDS);DS~P2 WDS END; 00749600 + V[VLOW] ~ NFLAG((*[DATX[VLOW]])&VLOW[18:33:15]); 00749700 + END; 00749800 + END INITIAL FILL LOOP; 00749900 + IPB: ORI ~ 10; GETROW; 00750000 + IF DISKFULL THEN P(1,[DOTOP[NOT 2]],81,17,COM); 00750100 + OCDA ~ (LOSA ~ OUTHEAD[ORI]) + 1; 00750200 + SRS~ORL~ORS-1; SRI~ORI; ONS~ORC~0;OBC~TBO; 00750300 + IPBA: FIRSTSELECT; % INITIAL COMPARE 00750400 + GO TO IPD; 00750500 + IPC: LOWSELECT; % INTERM COMPARE 00750600 + IPD: IF VLOW < MS THEN 00750700 + BEGIN;COMMENT MOVE NEXT RECORD TO OUTPUT AREA; 00750800 + STREAM(P1~VL,P2~R,P3~(P(DUP)).[36:6],P4~*[DOTOP]); 00750900 + BEGIN SI~P1;P3(DS~32WDS;DS~32WDS);DS~P2 WDS END; 00751000 + P(1); DISKWRITE; % WRITE ON DISK THE RECORD FROM DATA[VLOW,0] 00751100 + INREAD; % POINT AT NEXT RECORD 00751200 + IF NOT EOF THEN 00751300 + BEGIN COMMENT CHECK IF NEXT RECORD IS SMALLER; 00751400 + IF ( IF ALFA THEN P(0,MKS,0,*[INFIL],VL,EQUALS) 00751500 + ELSE IF AC THEN P(0,MKS,*[CIIOD],VL,EQUALS) 00751600 + ELSE P(MKS,XAL,0,VAL,0,EQUALS)) 00751700 + THEN V[VLOW] ~ NFLAG((*[DATX[MS]])&MS[18:33:15]); 00751800 + STREAM(P1~*[CIIOD],P2~R,P3~P(DUP).[36:6],P4~*[DATX[VLOW]]); 00751900 + BEGIN SI~P1;P3(DS~32WDS;DS~32WDS);DS~P2 WDS END; 00752000 + % MOVE NEXT RECORD TO DATA 00752100 + END; 00752200 + IF NOT DISKFULL THEN GO TO IPC; 00752300 + END; 00752400 + COMMENT END OF STRINGING PASS OR NO MORE DATA; 00752500 + IF NOT DISKFULL THEN % CHECK FOR RECORD = HIGH KEY 00752600 + FOR I ~ 0 STEP 1 UNTIL MS-1 DO 00752700 + IF (VLOW ~ V[I].[18:15]) < MS THEN GO TO IPD; 00752800 + MOREDATA ~ FALSE; 00752900 + FOR I~ 0 STEP 1 UNTIL MS-1 DO 00753000 + IF NOT V[I].[5:1] THEN 00753100 + BEGIN V[I] ~ NFLAG((*[DATX[I]])&I[18:33:15]); 00753200 + MOREDATA ~ TRUE END; 00753300 + DISKFULL ~ TM AND ONS } M-1 OR DISKFULL; 00753400 + IPE: WRITETAG; % WRITE STRING TAG WORD IN FRONT OF STRING 00753500 + IF DISKFULL THEN GO TO IPG; 00753600 + IF MOREDATA THEN 00753700 + IF NOT TM OR ONS < M THEN GO TO IPBA 00753800 + ELSE GO TO IPG; 00753900 + FM ~ NOT TM AND ONS { M; 00754000 + IPG::END SORTIT; 00754100 + %*********************************% 00754200 + SUBROUTINE MERGEIT; % MERGES M STRINGS TO 1 STRING 00754300 + BEGIN 00754400 + MIC: FIRSTSELECT; 00754500 + GO TO MIE; 00754600 + MID: LOWSELECT; 00754700 + MIE: IF VLOW < MS THEN 00754800 + BEGIN; % MOVE LOW RECORD TO OUTPUT FILE 00754900 + STREAM(P1~VL,P2~R,P3~(P(DUP)).[36:6],P4~*[COIOD]); 00755000 + BEGIN SI~P1;P3(DS~32WDS;DS~32WDS);DS~ P2 WDS END; 00755100 + WRITEOUT; DISKREAD; 00755200 + GO TO MID; 00755300 + END; 00755400 + FOR I ~ 0 STEP 1 UNTIL MS-1 DO % CHECK FOR RECORD = HIGH KEY 00755500 + IF (VLOW ~ V[I].[18:15]) < MS THEN GO TO MIE; 00755600 + IF NOT TM AND NOT EOF THEN 00755700 + BEGIN COMMENT HAVE MERGED M STRINGS FROM INPUT;00755800 + WRITETAG; % TO ONE STRING IN OUTPUT, SELECT 00755900 + SUBMERGE; % M MORE STRINGS IO MERGE 00756000 + GO TO MIC; 00756100 + END; 00756200 + END MERGEIT; 00756300 + %**********************************% 00756400 + START: % INITIALIZE SORT PASS 00756500 + BLKCTR ~ BLKCTR + ((AC ~ R>0) OR MF); R ~ ABS(R); 00756600 + IF AC THEN IF CORESIZE.[1:1] THEN % IDENTIFY COBOL68 00756610 + BEGIN AC~3; CORESIZE~ABS(CORESIZE); 00756620 + BLKCTR ~ BLKCTR - 1; 00756630 + END; 00756650 + IF NOT OPTOG THEN 00756700 + BEGIN 00756710 + PRFIB ~ OUTFIL[NOT 2]; 00756720 + IF R > (PRFIB[18].[33:15]) THEN 00756730 + P(1,[OUTFIL[NOT 2]],87,17,COM); 00756740 + END; 00756750 + P(MKS,[TSN],[TCN],[TNN], 8 ,1,3,1,BLOCK); 00756800 + IF MF THEN GO TO P(POLYMERGE); 00756900 + LISA ~ IF IPTOG THEN 0 ELSE % SIZE OF INPUT BUFFER 00757000 + 2|P(*[INFIL[NOT 2]],18,COC).[3:15]; 00757100 + CORESIZE ~ (IF CORESIZE = 0 THEN 12000 ELSE CORESIZE) 00757200 + - 2000 - LISA; 00757300 + IF CORESIZE < 2500 THEN CORESIZE ~ 2500; 00757310 + ONS ~ R ~ ABS(R); S ~ M ~ 512; 00757400 + WHILE ONS < 30 DO ONS ~ ONS + R; 00757500 + LY: IF ONS > 1023 THEN BEGIN ONS ~ ONS - R; GO TO LZ END; 00757600 + IF ONS MOD 30 ! 0 THEN BEGIN ONS ~ ONS + R; GO TO LY END; 00757700 + COMMENT ONS NOW MINIMUM BUFFER SIZE; 00757800 + LZ: ORC ~ ONS; 00757900 + WHILE (ORC + ONS) { 150 DO ORC ~ ORC + ONS ; %DSK INPT BUFF SZ 00758000 + ORL ~ ORC; 00758100 + WHILE (ORC + ORL) { 450 DO ORL ~ ORL + ORC ; %DSK OTPT BUFF SZ 00758200 + OCDA ~ CORESIZE - 2|ORL; 00758300 + LOSA ~ (OCDA-R) DIV (2|ORC); 00758400 + IF LOSA { 2 THEN M ~ 2 ELSE WHILE M > LOSA DO M~M DIV 2; 00758500 + LOSA ~ (OCDA-R) DIV (R+3); 00758600 + IF LOSA { 2 THEN S ~ 2 ELSE WHILE S > LOSA DO S~S DIV 2; 00758700 + SRS ~ ORL; SRI ~ ORC; 00758800 + LX: ORI ~ 2|ORL + 2|M|ORC; 00758900 + IF ORI < 1.1|CORESIZE AND ORC { 1023 THEN 00759000 + BEGIN 00759100 + SRS ~ ORL; SRI ~ ORC; 00759200 + ORC ~ ORC + ONS; 00759300 + ORL ~ ORC; WHILE ORL < 300 DO ORL ~ ORL + ORC; 00759400 + GO TO LX ; 00759500 + END; 00759600 + D ~ SRI DIV 30; IF SRI MOD 30 ! 0 THEN D ~ D + 1; 00759700 + BF ~ SRI DIV R; TBO ~ SRS DIV R; 00759800 + COMMENT COMPUTE DISK ROW SIZE, # ROWS ALWAYS = 20; 00759900 + DISKSIZE ~ ( IF DISKSIZE = 0 THEN 1000|600 ELSE DISKSIZE) 00760000 + / (BF|19|R); 00760100 + IF DISKSIZE { (Y ~ TBO DIV BF) THEN 00760200 + DISKSIZE ~ Y + Y ELSE 00760300 + WHILE (DISKSIZE MOD Y)!0 DO DISKSIZE~DISKSIZE + 1; 00760400 + OD ~ D | Y ; 00760500 + COMMENT SET UP DISK OUTPUT FILE AS ALGOL FILE; 00760600 + OUTFIB ~ *[DOTOP[NOT 2]]; % GET FIB DESCRIPIOR 00760700 + OUTFIB[ 8] ~ (DISKSIZE DIV Y)&20[15:38:10]; % # ROWS, ROW SIZE.00760800 + OUTFIB[13].[10:9] ~ OUTFIB[13].[1:9]; 00760900 + OUTFIB[4].[7:1] ~ ((AC AND 3) = 1); %COBOL61 DISK SORT FLG 00761000 + OUTFIB[18] ~ (X~TBO|R)&X[3:33:15]&X[18:33:15]; % DISK BLOCK 00761100 + IF (Y~OUTFIB[4].[12:12]) < 1023 THEN % FILE # TO FILE INDEX 00761200 + OUTFIB[4] ~ OUTFIB[4]&((Y-1)|ETRLNG)[13:37:11]&1[12:47:1]; 00761300 + IF FPB[FNUM+3].[16:7] = 0 THEN % NOT LABEL EQUATED 00761310 + FPB[FNUM+3].[16:2] := 1; % USE FAST DISK 00761320 + COMMENT OPEN DISK OUTPUT FILE, WILL SET UP FIB[16] AND 00761400 + WILL PDINT TOP I/O DESC. PAST DISK ADDRESS; 00761500 + P([DOTOP],0,11,COM,DEL,DEL); 00761600 + OUTHEAD ~ *[OUTFIB[14]]; 00761700 + IF NT > 2 THEN 00761800 + OUTHEAD[8]~OUTHEAD[8] OR MEM; 00761900 + COMMENT GET DISK SPACE FOR 1 ROW; 00762000 + P([DOTOP[1]]); WAIT; % WAIT FOR FILE TO BE OPENED 00762100 + ORI ~ 9; GETROW; MOREDATA ~ TR ~ -1; 00762200 + IF DISKFULL THEN 00762300 + P(1,[DOTOP[NOT 2]],81,17,COM); % IOR 81 00762400 + COMMENT IF INPUT FILE THEN OPEN IT, IF PROCEDURE THEN 00762500 + INITILIZE LINKAGE TO CALL IT; 00762600 + IF IPTOG THEN BEGIN IF AC THEN 00762700 + BEGIN ENDQ ~ 0; BINGO ~ INPRO; END; 00762800 + P(MKS,[INFIL],R,1,1,1,BLOCK); 00763000 + IF(AC AND 3)=3 THEN % COBOL68 00763050 + BEGIN CIIOD ~ [WAIN]; 00763100 + WAIN ~ P([INFIL],DUP,LOD,0,CDC,DEL,LOD); 00763150 + END END ELSE 00763200 + BEGIN COMMENT CHECK FOR ALGOL OR COBOL; 00763300 + IF AC THEN BEGIN P(MKS,(NOT 2) INX [INFIL],1,COFCR); 00763400 + IF AC.[46:1] THEN % COBOL68 00763440 + BEGIN CIIOD ~ [WAIN]; 00763450 + WAIN ~ P(*[INFIL[NOT 2]],20,COC,0,XCH,FCX,00763460 + DUP,DIB 0,LOD,0,CDC,DEL,DIB 0,LOD); 00763470 + END END ELSE BEGIN % OPEN ALGOL INPUT FILE 00763500 + PRFIB ~ *[INFIL[NOT 2]]; 00763600 + PRFIB[13].[27:1] ~ 1; 00763700 + P(MKS,0,3,[INFIL],ALRD,DEL); 00763800 + END; 00764200 + END; 00764300 + IF(AC AND 3)!3 THEN CIIOD ~ [INFIL]; 00764350 + CALLSORT: 00764400 + SORTIT; % SORT INPUT FILE INTO STRINGS 00764500 + %**********************************% 00764600 + ENDSORTPASS: COMMENT TURN BACK WHATS NO LONGER NEEDED AND 00764700 + INITILIZE MERGE PASS; 00764800 + IF EOF THEN COMMENT CLOSE INPUT TAPE; 00764900 + IF NOT MOREDATA THEN 00764950 + BEGIN 00765000 + IF IPTOG THEN P([INFIL],3,COM,DEL) 00765100 + ELSE P(MKS,2,0,[INFIL[NOT 2]], 00765200 + IF (INFIL=OUTFIL) AND AC THEN 18 ELSE 4,FCR); 00765210 + IF INCOUNT = 0 THEN P(1,[DOTOP[NOT 2]],86,17,COM); 00765300 + END; 00765400 + IF MOREDATA THEN 00765500 + BEGIN COMMENT SAVE CONTENTS OF DATA ON DISK; 00765600 + TR ~ 0; OCDA ~ OUTHEAD[ORI ~ 10]; I ~ 0; 00765700 + OBC ~ TBO; ORL ~ ORS; 00765800 + WHILE I < S DO 00765900 + BEGIN 00766000 + IF NOT V[I].[5:1] THEN 00766100 + BEGIN 00766200 + TR ~ TR +1; 00766300 + STREAM(P1~*[DATX[I]],P2~R,P3~(P(DUP)).[36:6], 00766400 + P4~*[DOTOP]); 00766500 + BEGIN SI~P1;P3(DS~32WDS;DS~32WDS);DS~P2 WDS END; 00766600 + P(1); DISKWRITE; 00766700 + END; 00766800 + I ~ I + 1; 00766900 + END; 00767000 + P(0); DISKWRITE; % WRITE BLOCK 00767100 + END; 00767200 + AC ~ AC&EOF[2:47:1]&MOREDATA[1:47:1]; 00767300 + COMMENT TURN BACK DATA & VECTOR ARRAYS; 00767400 + P(.DATA,LOD,RFB,.DATA,STD,[DATN],22,COM,DEL); 00767500 + P(.V,LOD,RFB,.V,STD,[VN],3,COM,DEL); 00767600 + STPP ~ P(MS ~ M,DUP,ADD,2,SUB); 00767700 + BLKCTR ~ BLKCTR + 1; 00767800 + COMMENT DECLARE DISK OUTPUT FILE; 00767900 + ITNK ~ 0; 00768000 + P(MKS,20,DISKSIZE,3,OUTFIB[4].[13:11]DIV ETRLNG +2,[DKI], 00768100 + (Y~2|M),1,BF|R,0,0,10,8,BLOCK); 00768200 + INFIB ~ *[ITNK[2]]; 00768300 + ITOP ~ [ITNK[5]]&Y[8:38:10] ; % POINT ITOP AT TOP I/O D 00768400 + COMMENT OPEN FILE; 00768500 + P([ITNK[5]],0,11,COM,DEL,DEL); 00768600 + INHEAD ~ *[INFIB[14]]; 00768700 + IF NT > 2 THEN 00768800 + INHEAD[8] ~ INHEAD[8]&1[2:47:1]; % FLAG SORT DISK 00768900 + P([ITOP[Y~Y-1]]); WAIT; % WAIT FOR FILE TO BE OPENED 00769000 + IF INHEAD[10] !0 THEN 00769100 + P(10,.INHEAD,LOD, 24,COM,DEL,DEL); % RETURN 1 ST ROW 00769200 + COMMENT SET FILE TO READ & PERMUTE 2 BUFFERS; 00769300 + INFIB[13] ~ INFIB[13]&2[10:39:9]&1[27:47:1]; 00769400 + INFIB[16] ~ (*[INFIB[16]])&1[24:47:1]; 00769500 + COMMENT GET DATA AND VECTDR ARRAYS; 00769600 + P(MKS,[VN],(2|M)-1,1,1,1,BLOCK); 00769700 + P(5,M+1,[DATN],21,COM,DEL,DEL,DEL); 00769800 + COMMENT GENERATE HIGH KEY RECORD; 00769900 + MHN ~ 0; P(MKS,[MHN],R,1,1,1,BLOCK); 00770000 + P(MKS,MHK); IF NOT AC THEN P(0,CDC,MHK,XCH,RDS,CFX,0); 00770100 + P(HIVALU); 00770120 + FOR I ~ 0 STEP 1 UNTIL Y DO 00770200 + ITOP[I] ~ (NOT 0) INX (*[ITOP[I]])&1[24:47:1]&D[27:42:6]; 00770300 + DKC: IF NOT TM THEN 00770400 + BEGIN % DISK ONLY SORT COMPLETED 00770500 + IF FM THEN GO TO DKF; 00770600 + P(10,.OUTHEAD,LOD,24,COM,DEL,DEL); % RETURN OVERLAY SPACE 00770700 + P(.INHEAD,LOD,.OUTHEAD,LOD,.INHEAD,STD,.OUTHEAD,STD); 00770800 + SRI ~ ORI; ORI ~ 10; % SRI= AMOUNT OF DISK USED TO NOW 00770900 + WHILE ORI < SRI DO % GET ANOTHER AREA OF DISK = SRI 00771000 + BEGIN 00771100 + GETROW; 00771200 + IF DISKFULL THEN 00771300 + BEGIN P(.OUTHEAD,LOD); FORGETDISK; GO TO TPA; END; 00771400 + END; 00771500 + COIOD ~ DOTOP; 00771600 + DKD: OCDA ~ (LOSA ~ OUTHEAD[(SRI ~ ORI ~ 11)]) + 1; 00771700 + SRS ~ ORL ~ ORS - 1; 00771800 + DKE: LISA ~ INHEAD[11]; % LOCATION OF FIRST TAG 00771900 + MOREDATA ~ NOT(EOF ~ DISKFULL ~ ONS ~ 0); 00772000 + SUBMERGE; MERGEIT; 00772100 + IF FM THEN BEGIN P(*[INFIB[14]]); FORGETDISK; GO TO TPC END; 00772200 + MOREDATA ~ FALSE; WRITETAG; 00772300 + DKF: P(.INHEAD,LOD,.OUTHEAD,LOD,.INHEAD,STD,.OUTHEAD,STD); 00772400 + IF ONS > M THEN GO TO DKD; 00772500 + FM ~ TRUE; MS ~ 2; WHILE ONS > MS DO MS~MS|2; 00772600 + STPP ~ 2|MS-2; 00772700 + COMMENT REPLACE DISK OUTPUT BY PROGRAMMERS OUTPUT; 00772800 + P(MKS,0,0,[DOTOP[NOT 2]],4,FCR); % RETURN BUFFERS 00772900 + OPENOUT; IF(AC AND 3)!3 THEN COIOD ~ [OUTFIL]; 00773000 + GO TO DKE; 00773100 + END; 00773200 + COMMENT DISK-TAPE MERGE; 00773300 + P(.INHEAD,LOD,.OUTHEAD,LOD,.INHEAD,STD,.OUTHEAD,STD); 00773400 + TPA: P(MKS,0,0,[DOTOP[NOT 2]],4,FCR); % RETURN BUFFERS 00773500 + LISA ~ INHEAD[11]; MOREDATA ~ NOT(EOF~DISKFULL~ONS~0); 00773600 + TPB: IF TN[COT] } TC[COT] THEN BEGIN SELECT; GO TO TPB END; 00773700 + SUBMERGE; MERGEIT; WRITESTOPPER; 00773800 + IF NOT EOF THEN GO TO TPB; 00773900 + P(.INHEAD,LOD,.OUTHEAD,LOD,.INHEAD,STD,.OUTHEAD,STD); 00774000 + TPC: P(.DATA,LOD,RFB,.DATA,STD,[DATN],22,COM,DEL); % RTN DATA 00774100 + INHEAD ~ INFIB ~ BASE ~ ITOP ~ BUFF ~ 0; 00774300 + IF FM OR AC.[1:2] =1 THEN GO TO WRAPUP; 00774500 + P (10,COM); %RETURN MERGE MATRIX %TR-11700774550 + MOREDATA ~ AC.[1:1]; EOF ~ AC.[2:1]; 00774600 + GO TO CALLSORT; 00774700 + WRAPUP: 00774800 + P(*[OUTFIB[14]]); FORGETDISK; 00774900 + OUTFIB ~ OUTHEAD ~ 0; 00775000 + IF TM THEN %ITD SORT MERGE %TR-11700775100 + BEGIN P (10,COM); %RETURN MERGE MATRIX %TR-11700775120 + GO TO P(POLYMERGE);% GO TO ITD MERGL %TR-11700775130 + END; %TR-11700775140 + SORTDONE: 00775200 + COMMENT JUST DID FINAL PASS; 00775300 + COMMENT RETURN EVERYTHING; 00775400 + P([DOTOP]&0[18:18:15],6,11,COM,DEL,DEL); 00775500 + IF NOT OPTOG THEN BEGIN 00775600 + P(MKS,2,0,[OUTFIL[NOT 2]],4,FCR) 00775700 + ; IF NOT AC THEN P(0,OUTFIL[NOT 2],8,CDC,STD); 00775800 + END ELSE 00775900 + BEGIN COMMENT CALL OUTPUT PROCEDURE PASSING END-OF-SORT FLAG; 00776000 + IF AC THEN 00776100 + BEGIN ENDQ ~ 1; IF AC.[46:1] THEN 00776200 + P(MKS,BINGO,0,PERFORMGEN) % COBOL68 00776250 + ELSE P(MKS,BINGO,[PRTBASE[P(DUP)]],LOD,IPFIDX,COC) 00776300 + END ELSE P(MKS,1,MEM,0,OUTPRO); 00776400 + END; 00776500 + P( 10,COM); % RETURN MERGE MATRIX %TR-11700776550 + IF OUTCOUNT!INCOUNT THEN P(INCOUNT,OUTCOUNT,0, 00776600 + [DOTOP[NOT 2]],82,17,COM); 00776700 + P(10,COM); % FALL OUT OF BLOCK COM WILL REIURN EVERYTHING 00776800 + END DISKSORT; 00776900 + PROCEDURE POLYMERGE( 00800000 + T1,T2,T3, 00800100 + ENDQ,BINGO,IPFIDX,OUTPRO,INPRO,OUTF,INF, 00800200 + OPTOG,IPTOG,DKO,DKI,TP1,TP2,TP3,TP4,TP5,NT, 00800300 + HIVALU,EQUALS,R,ALFA,CORESIZE,DISKSIZE); 00800400 + COMMENT DISK-SORT BY L.R. GUCK DATE 9/19/1965 ; 00800500 + VALUE OPTOG,IPTOG,NT,HIVALU,EQUALS,R,ALFA, 00800600 + CORESIZE,DISKSIZE; 00800700 + REAL ENDQ,BINGO,IPFIDX,OUTPRO,INPRO,OUTF,T1,T2,T3,INF; 00800800 + BOOLEAN OPTOG,IPTOG; 00800900 + REAL DKO,DKI; 00801000 + NAME TP1,TP2,TP3,TP4,TP5; % SCRATCH TAPES 00801100 + REAL NT,HIVALU,EQUALS,R; 00801200 + BOOLEAN ALFA; % TRUE FOR ALPHA KEYS 00801300 + REAL CORESIZE; % CORE STORAGE AVAILABLE 00801400 + INTEGER DISKSIZE; % DISK STORAGE AVAILABLE 00801500 + BEGIN 00801600 + LABEL MIC,MID,MIE,START,TPD,TPE,TPF,RTNTR,TRA,SORTDONE,RTA,TRX; 00801700 + REAL S,M,MS,STPP,D,OD,BF,TBO,I,X,Y,DN; 00801800 + ARRAY V[*]; NAME VN = V; 00801900 + DEFINE VX1=FLAG(V[X+1])#, VX=FLAG(V[X])#, VL=FLAG(V[VLOW])#; 00802000 + DEFINE VA1 = FLAG(V[X+1 ]&P(0,RDS)[CTF])#, 00802010 + VA = FLAG(V[X ]&P(0,RDS)[CTF])#, 00802020 + VAL = FLAG(V[VLOW]&P(0,RDS)[CTF])#; 00802030 + REAL VLOW; % INDEX OF NEXT RECORD IN SEQUENCE 00802100 + ARRAY MHK[*]; % HIGH KEY FOR MERGE PHASE 00802200 + NAME MHN=MHK; 00802300 + NAME DOTOP = DKO; 00802400 + BOOLEAN MOREDATA,FM,EOF,TM,DF,TR; 00802500 + BOOLEAN MF= T1; 00802600 + DEFINE IOC = @2000000000#, 00802700 + P = POLISH#; 00802800 + COMMENT PARAMETERS RELATED TO PROGRAMMERS FILES; 00802900 + NAME INFIL = INF; % POINTER TO TOP I/O DESC. 00803000 + NAME OUTFIL = OUTF; 00803100 + NAME WAOUT = T2; % COBOL68 OUTFILE WORK AREA 00803120 + ARRAY PRFIB[*]; % CONTAINS TAPE FILES FIB 00803200 + REAL AC; % TRUE FOR COBOL INPUT FILE 00803300 + REAL INCOUNT,OUTCOUNT; 00803400 + NAME MEM = 2; 00803500 + REAL BLOCK = 5,ALWR=12,ALRD=13,COFCR=12,CORW=14,ALFCR=14, 00803600 + PERFORMGEN = 13, % COBOL68 IN-OUT PROCEDURES 00803610 + BLKCTR = 16; 00803700 + ARRAY PRTBASE = 10[*]; 00803800 + REAL OF,OH,LO,ONS,ORC,OCDA,ORL,ORI,SRI,SRS,OBC,IFB,IFH; 00803900 + ARRAY BASE[*]; % POINTER TO CONTROL INFO IN DATA 00804000 +REAL ITP,DONTDONOTHINIEOPEN,LISA; 00804100 + DEFINE FCR = IF AC THEN COFCR ELSE ALFCR#; 00804200 + COMMENT PARAMETERS RELATED TO MERGE TAPES; 00804300 + INTEGER CTRL; % CURRENT CONTROL TAPE 00804400 + INTEGER COT; % CURRENT OUTPUT TAPE 00804500 + NAME COIOD; % LOC OF I/O D OF CURRENT OUTPUT TAPE 00804600 + NAME TP; % BASE POINTER OF MERGE TAPES 00804700 + ARRAY TS[*]; % ARRAYS FOR CONTROLLING DISTRIBUTION 00804800 + ARRAY TC[*]; % PATTERNS ON MERGE TAPES 00804900 + ARRAY TN[*]; 00805000 + REAL TM1=CORESIZE; % TAPES - 1 00805100 + NAME CIIOD; % LOC OF I/O D FOR CURRENT INPUT TAPE 00805200 + %**********************************% 00805300 + SUBROUTINE WAIT; COMMENT WAIT FOR I/O COMPLETE USING ADRRESS 00805400 + ON TOP OF STACK; 00805500 + $ SET OMIT = NOT(TIMESHARING) 00805550 + BEGIN IF NOT (P(XCH,DUP,LOD)).[19:1] THEN P(IOC,36,COM,DEL); 00805552 + $ POP OMIT 00805553 + $ SET OMIT = TIMESHARING 00805599 + P(DEL); END WAIT; 00805700 + %***************MM*****************% 00805800 + SUBROUTINE RELEASETAPE; % CALLS MCP TO WRITE OUT BUFFERS 00805900 + BEGIN 00806000 + PRFIB[11] ~ TBO; 00806100 + P(COIOD[0] ~ FLAG(PRFIB[16]),COIOD,PRL,DEL); 00806200 + RTA: P(COIOD); WAIT; 00806300 + IF (*COIOD).[27:1] THEN % REEL SWITCH 00806400 + BEGIN 00806500 + P(MKS,0,0,[COIOD[NOT 2]],6,FCR); 00806600 + GO TO RTA; 00806700 + END; 00806800 + IF NOT(*COIOD).[2:1] THEN P(1,[COIOD[NOT 2]],74,17,COM); 00806850 + COIOD[0] ~ 1 INX FLAG(PRFIB[16] ~ NFLAG(*COIOD)); 00806900 + END RELEASETAPE; 00807000 + SUBROUTINE TAPEWRITE; % BLOCKS OUTPUT TAPES 00807100 + BEGIN 00807200 + PRFIB ~ *[COIOD[NOT 2]]; 00807300 + PRFIB[9] ~ PRFIB[9] + 1; % RECORD COUNTER + 1 00807400 + IF (PRFIB[11] ~ PRFIB[11] - 1) > 0 THEN % BLOCK COUNTER 00807500 + COIOD[0] ~ R INX *COIOD 00807600 + ELSE 00807700 + BEGIN % TIME FOR RELEASE 00807800 + P(0,PRFIB[16] INX MEM,STD); % ZERO CONTROL WORD IN BUFF[2] 00807900 + RELEASETAPE; 00808000 + END; 00808100 + END TAPEWRITE; 00808200 + SUBROUTINE WRITESTOPPER; 00808300 + BEGIN % WRITES END OF STRING OR DUMMY STRINGS 00808400 + PRFIB ~ *[COIOD[NOT 2]]; 00808500 + X ~ PRFIB[9]&(TBO-PRFIB[11])[18:33:15]&("DS")[3:33:15]; 00808600 + P(X,PRFIB[16] INX MEM,STD); 00808700 + TN[COT] ~ TN[COT] + 1; % COUNT UP STRINGS ON OUTPUI TAPE 00808800 + RELEASETAPE; 00808900 + PRFIB [9] ~ 0 ; % ZERO OUT STRING CTR 00808910 + END WRITESTOPPER; 00809000 + %**********************************% 00809100 + SUBROUTINE OPENOUT; % OPENS PROGRAMMERS OUTPUT TAPE 00809200 + BEGIN 00809300 + IF OPTOG THEN 00809400 + BEGIN P(MKS,[OUTFIL],R,1,1,1,BLOCK); 00809500 + IF AC THEN 00809600 + BEGIN BINGO ~ OUTPRO; ENDQ ~ 0; 00809700 + IF AC.[46:1] THEN % COBOL68 00809730 + BEGIN P(MKS,BINGO,0,PERFORMGEN); 00809740 + COIOD ~ [WAOUT]; 00809745 + WAOUT ~ P(*[OUTFIL],0,CDC); 00809750 + END ELSE 00809760 + P(MKS,BINGO,[PRTBASE[P(DUP)]],LOD,IPFIDX,COC); 00809800 + END END ELSE 00809900 + BEGIN TR ~ FALSE; PRFIB ~ OUTFIL[NOT 2]; 00810000 + PRFIB[13].[27:1] ~0; 00810100 + IF AC THEN 00810200 + BEGIN 00810300 + P(MKS,[OUTFIL[NOT 2]],3,COFCR); 00810400 + IF AC.[46:1] THEN % COBOL68 00810440 + BEGIN COIOD ~ [WAOUT]; 00810450 + WAOUT ~ P(PRFIB[20].[FF],DUP,DIB 0,LOD,0, 00810460 + CDC,DEL,DIB 0,LOD); 00810470 + END; 00810480 + TR ~ PRFIB[4].[8:4] = 4; 00810600 + END 00810700 + ELSE BEGIN P([OUTFIL],0,11,COM,DEL,DEL); 00810800 + P(MKS,1,0,0,(-R),[OUTFIL],ALWR,DEL); END; 00810900 + END 00811000 + END OPENOUT; 00811100 + %**********************************% 00811200 + SUBROUTINE TAPEREAD; % READS TAPES ON POLYPHASE MERGE 00811300 + BEGIN 00811400 + CIIOD ~ TP[VLOW + 1 ]; PRFIB ~ CIIOD[NOT 2]; 00811500 + PRFIB[9] ~ PRFIB[9] + 1; % RECORD COUNTER + 1 00811600 + IF (PRFIB[11] ~ PRFIB[11] -1) > 0 THEN % BLOCK COUNTER - 1 00811700 + V[VLOW] ~ R INX V[VLOW] 00811800 + ELSE 00811900 + BEGIN % TIME FOR RELEASE 00812000 + IF (Y ~ P(FLAG(PRFIB[16]),LOD)) ! 0 THEN 00812100 + BEGIN % CONTROL WORD ! 0 SO END OF STRING 00812200 + TRA: DF ~ TRUE; 00812300 + IF Y.[33:15] ! PRFIB[9].[33:15] THEN 00812400 + P(0,[CIIOD[NOT 2]],85,17,COM,DEL,DEL,DEL); 00812500 + END; 00812600 + P(CIIOD[0] ~ FLAG(PRFIB[16]),CIIOD,PRL,DEL); 00812700 + TRX: P(CIIOD); WAIT; 00812800 + IF NOT (*CIIOD).[2:1] THEN % ERROR OR EOF OR EOR 00812900 + BEGIN 00813000 + EOF ~ P(MKS,1,0,[CIIOD[NOT 2]],6,FCR); 00813100 + IF NOT EOF THEN GO TO TRX; 00813200 + END; 00813300 + IF EOF THEN GO TO RTNTR; 00813400 + PRFIB[11] ~ IF P(Y~ P(*CIIOD,LOD)) = 0 THEN TBO 00813500 + ELSE Y.[18:15]; 00813600 + CIIOD[0] ~ 1 INX FLAG(PRFIB[16] ~ NFLAG(*CIIOD)); 00813700 + IF DF THEN GO TO RTNTR; 00813800 + IF PRFIB[11] ! 0 THEN V[VLOW] ~ V[VLOW]&(*CIIOD)[33:33:15] 00813900 + ELSE GO TO TRA; 00814000 + END; 00814100 + RTNTR: IF EOF OR DF THEN BEGIN 00814200 + V[VLOW] ~ NFLAG(MHK)&MS[18:33:15]; 00814300 + IF FM AND NOT MF THEN % REL TAPE LST PASS 00814340 + P(MKS,4,0,[CIIOD[NOT 2]],4,FCR); % FOR SRT 00814350 + EOF~DF~FALSE; 00814400 + END; 00814500 + END TAPEREAD; 00814600 + %**********************************% 00814700 + SUBROUTINE INREAD; % READS PROGRAMMERS MERGE FILES 00814800 + BEGIN 00814900 + CIIOD ~ TP[VLOW+1]; PRFIB ~ CIIOD[NOT 2]; 00815000 + BEGIN 00815100 + IF AC THEN TC[VLOW] ~ P(MKS,R,CIIOD,0,CORW) 00815200 + ELSE 00815300 + BEGIN 00815400 + P(MKS,0,0,CIIOD,ALRD); 00815500 + TC[VLOW] ~ P(MKS,0,3,CIIOD,ALRD) < 0; 00815600 + END; 00815700 + IF TC[VLOW] THEN V[VLOW] ~ NFLAG(MHK)&MS[18:33:15] 00815800 + ELSE IF (AC AND 3) ! 3 THEN % NOT COBDL68 00815900 + V[VLOW] ~ (*P(DUP)) & (*[CIIOD])[CTC]; 00815910 + END; 00816000 + END INREAD; 00816100 + %*********************************% 00816200 + SUBROUTINE WRITEOUT; 00816300 + BEGIN % SELECTS FILE TO BE WRITTEN DURING MERGE 00816400 + IF NOT FM THEN TAPEWRITE 00816500 + ELSE 00816600 + BEGIN COMMENT CALL OUTPUT PROCEDURE OR WRITE INTRINSIC; 00816700 + OUTCOUNT ~ OUTCOUNT +1; 00816800 + IF OPTOG THEN 00816900 + BEGIN 00817000 + IF AC THEN BEGIN ENDQ ~ 0; 00817100 + IF AC.[46:1] THEN P(MKS,BINGO,0,PERFORMGEN) 00817120 + ELSE P(MKS,BINGO,[PRTBASE[P(DUP)]],LOD,IPFIDX,COC) 00817150 + END ELSE P(MKS,0,*[OUTFIL],0,OUTPRO); 00817200 + END 00817300 + ELSE 00817400 + BEGIN COMMENT OUTPUT FILE RATHER THAN OUTPUT PROCEDURE; 00817500 + IF AC THEN P(MKS,0,1,1,0,R,[OUTFIL],1,CORW) 00817600 + ELSE BEGIN 00817700 + P(MKS,1,0,0,R,[OUTFIL],ALWR); 00817800 + P(MKS,1,0,0,(-R),[OUTFIL],ALWR,DEL); END; 00817900 + IF TR THEN IF P THEN P(1,[OUTFIL[NOT 2]],83,17,COM); 00818000 + END; 00818100 + END; 00818200 + END WRITEOUT; 00818300 + SUBROUTINE FIRSTSELECT; % INITIAL SELECTION OF LOW RECORD 00818400 + BEGIN 00818500 + X ~ 0; I~MS-1; 00818600 + DO BEGIN 00818700 + I~I+1; 00818800 + V[I] ~ V[X+((IF ALFA THEN P(0,MKS,0,VX1,VX,EQUALS) 00818900 + ELSE IF AC THEN P(0,MKS,VX1,VX,EQUALS) 00819000 + ELSE P(MKS,VA1,0,VA,0,EQUALS)) AND TRUE)]; 00819100 + END UNTIL (X~X+2) = STPP; VLOW ~ V[I].[18:15]; 00819200 + END FIRSTSELECT; 00819300 + SUBROUTINE LOWSELECT; 00819400 + BEGIN 00819500 + X ~ VLOW AND 1022; 00819600 + DO BEGIN 00819700 + I ~ MS + X.[38:9]; % I ] MS + (X/2) 00819800 + V[I] ~ V[X+((IF ALFA THEN P(0,MKS,0,VX1,VX,EQUALS) 00819900 + ELSE IF AC THEN P(0,MKS,VX1,VX,EQUALS) 00820000 + ELSE P(MKS,VA1,0,VA,0,EQUALS)) AND TRUE)]; 00820100 + X ~ I AND 1022; 00820200 + END UNTIL I = STPP; VLOW ~ V[I].[18:15]; 00820300 + END LOWSELECT; 00820400 + %*********************************% 00820500 + SUBROUTINE MERGEIT; % MERGES M STRINGS TO 1 STRING 00820600 + BEGIN 00820700 + MIC: FIRSTSELECT; 00820800 + GO TO MIE; 00820900 + MID: LOWSELECT; 00821000 + MIE: IF VLOW < MS THEN 00821100 + BEGIN; % MOVE LOW RECORD TO OUTPUT FILE 00821200 + STREAM(P1~VL,P2~R,P3~(P(DUP)).[36:6],P4~*[COIOD]); 00821300 + BEGIN SI~P1;P3(DS~32WDS;DS~32WDS);DS~ P2 WDS END; 00821400 + WRITEOUT; IF MF THEN INREAD ELSE TAPEREAD; 00821500 + GO TO MID; 00821600 + END; 00821700 + FOR I ~ 0 STEP 1 UNTIL MS-1 DO % CHECK FOR RECORD = HIGH KEY 00821800 + IF (VLOW ~ V[I].[18:15]) < MS THEN GO TO MIE; 00821900 + END MERGEIT; 00822000 + START: 00822100 + CIIOD ~ 0; P(([CIIOD].[33:15]+2),STS); 00822200 + MS ~ 2; TM1~NT-1; WHILE MS<(TM1+MF) DO MS~MS|2; 00822300 + IF MF THEN 00822400 + BEGIN % MERGE ONLY 00822500 + TP ~ ((NOT 7) INX [NT]); FM ~ TRUE; 00822600 + P(MKS,[VN],(2|MS)-1,1,1,1,BLOCK); P(MKS,[MHN],R,1,1,1,BLOCK);00822700 + P(M|S,MHK); IF NOT AC THEN P(0,CDC,MHK,XCH,RDS,CFX,0); 00822800 + P(HIVALU); 00822820 + FOR VLOW ~ 0 STEP 1 UNTIL TM1 DO 00822900 + BEGIN % OPEN TAPES 00823000 + CIIOD ~ TP[VLOW+1]; PRFIB ~ CIIOD[NOT 2]; 00823100 + PRFIB[13].[27:1] ~ 1; % SET TO OPEN INPUT 00823200 + IF AC THEN P(MKS,[CIIOD[NOT 2]],1,COFCR) 00823300 + ELSE TC[VLOW]~P(MKS,0,3,CIIOD,ALRD)<0; 00823400 + IF PRFIB[5].[39:1] THEN TC[VLOW] ~ 1 ELSE %OPTIONAL 00823500 + BEGIN 00823600 + P(CIIOD); WAIT; IF AC THEN INREAD; 00823700 + END; 00823800 + END; 00823900 + FOR I ~ 0 STEP 1 UNTIL MS-1 DO 00824000 + BEGIN 00824100 + IF I > TM1 OR TC[I] THEN V[I] ~ NFLAG(MHK)&MS[18:33:15] 00824200 + ELSE V[I]~NFLAG(P(TP[I+1])&(IF(AC AND 3)=3 THEN 00824300 + P(2,NOT,XCH,INX,LOD,20,COC,0,XCH,FCX,DIB 0,LOD,I) 00824310 + ELSE P(LOD,I))[CTF]); 00824320 + END; 00824400 + OPENOUT; IF(AC AND 3)!3 THEN COIOD ~ OUTFIL; 00824500 + STPP ~ 2 | MS - 2; 00824550 + MERGEIT; 00824600 + FOR I ~1 STEP 1 UNTIL TM1 + 1 DO %CLOSE LOCK ALL IAPES 00824610 + BEGIN CIIOD ~TP [I] ; % PG 00824630 + P (MKS,2,0,[CIIOD[NOT 2 ]],4,FCR); % PG 00824660 + END; % % PG 00824670 + GO TO SORTDONE; 00824700 + END; 00824800 + FOR I ~ COT STEP 1 UNTIL TM1 DO % WRITE OUT DUMMY STRINGS 00824900 + IF TN[I] < TC[I] THEN % PERFECT DISTRIBUIION 00825000 + BEGIN 00825100 + IF COT ! I THEN 00825200 + BEGIN 00825300 + PRFIB ~ COIOD[NOT 2]; COIOD[0] ~ FLAG(PRFIB[16]); 00825400 + P(((NOT 2) INX TP[I]),((NOT 2) INX TP[COT]), 00825500 + 20,COM,DEL,DEL); 00825600 + COIOD ~ TP[I]; COIOD[0] ~ 1 INX *COIOD; 00825700 + COT ~ I; 00825800 + END; 00825900 + WHILE TN[I] < TC[I] DO % PERFECT DISTRIBUTION PATTERN 00826000 + BEGIN COIOD ~ TP[I] ; PRFIB ~ COIOD[NOT 2]; 00826100 + PRFIB[11] ~ TBO; PRFIB[9] ~ 0; WRITESTOPPER; 00826200 + END; 00826300 + END; 00826400 + FOR I ~ 1 STEP 1 UNTIL TM1 DO 00826500 + BEGIN % SET UP TO DO POLYPHASE MERGE 00826600 + CIIOD ~ TP[I] ; 00826700 + P(MKS, 2 ,0,[CIIOD[NOT 2]],6,FCR); % REWIND OR RELEASE 00826800 + END; 00826900 + P(MKS,[VN],(2|MS)-1,1,1,1,BLOCK); STPP ~ 2|MS-2; MHN~0; 00827000 + P(MKS,[MHN],R,1,1,1,BLOCK); % HI-KEY 00827100 + P(MKS,MHK); IF NOT AC THEN P(0,CDC,MHK,XCH,RDS,CFX,0); 00827200 + P(HIVALU); 00827220 + FOR I ~ 1 STEP 1 UNTIL TM1 DO 00827300 + BEGIN % OPEN INPUT TAPES 00827400 + CIIOD ~ TP[I] ; PRFIB ~ CIIOD[NOT 2]; 00827500 + PRFIB[13].[27:1] ~ 1; P(CIIOD,0,11,COM,DEL,DEL); 00827600 + P(CIIOD); WAIT; PRFIB[11] ~ TBO; PRFIB[9] ~ 0; 00827700 + CIIOD[0] ~ 1 INX *CIIOD; 00827800 + END; 00827900 + TPD: FM ~ TRUE; 00828000 + FOR I ~ 1 STEP 1 UNTIL TM1 DO IF TN[I] > 1 THEN FM ~ FALSE; 00828100 + IF FM THEN 00828200 + BEGIN OPENOUT; IF(AC AND 3)!3 THEN COIOD ~ OUTFIL END 00828250 + ELSE % OPEN SCRATCH OUTPUT TAPE 00828300 + BEGIN COIOD ~ TP[NT]; PRFIB ~ *[COIOD[NOT 2]]; 00828400 + PRFIB[13].[27:1] ~ 0; % SET TO OUTPUT 00828500 + P(COIOD,0,11,COM,DEL,DEL); 00828600 + PRFIB[11] ~ TBO; PRFIB[9] ~ 0; COT ~ NT; 00828700 + P(COIOD); WAIT; COIOD[0] ~ 1 INX FLAG(PRFIB[16]); 00828800 + END; 00828900 + COMMENT SET UP VECTOR ROW 0; 00829000 + TPE: FOR I ~ 0 STEP 1 UNTIL MS - 1 DO 00829100 + BEGIN 00829200 + IF I } TM1 THEN BEGIN EOF ~ TRUE; GO TO TPF END; 00829300 + CIIOD ~ TP[I+1] ; PRFIB ~ CIIOD[NOT 2]; 00829400 + IF (EOF ~ (*CIIOD).[27:1]) THEN GO TO TPF; 00829500 + IF ( X ~ (*(FLAG(PRFIB[16])))) !0 THEN %TR-142 00829600 + IF NOT ( EOF ~X.[33:15] = 0 ) THEN PRFIB[11] ~X.[18:15] %IR-14200829610 + ELSE ELSE PRFIB[11] ~ TBO ; PRFIB[9] ~0; %IR-14200829620 + TPF: IF TN[I+1] = 0 OR EOF 00829700 + THEN BEGIN % PG 00829800 + V[I] ~NFLAG(MHK)&MS[18:33:15]; % PG 00829825 + IF FM AND I LSS TM1 THEN P(MKS,4,0,[CIIOD[NOT 2]],4,FCR);00829850 + END % PG 00829875 + ELSE V[I] ~ NFLAG(P(*TP[I+1])&I[18:33:15]); 00829900 + EOF ~ FALSE; 00830000 + END; 00830100 + MERGEIT; 00830200 + IF FM THEN GO TO SORTDONE ELSE WRITESTOPPER; 00830300 + COMMENT HAVE MERGED A STRING OFF EACH TAPE; 00830400 + COMMENT CHECK IF REWIND NEEDED; 00830500 + FOR I ~ 1 STEP 1 UNTIL TM1 DO TN[I] ~ TN[I] - 1; 00830600 + FOR I ~ 1 STEP 1 UNTIL TM1 DO IF TN[I] { 0 THEN 00830700 + BEGIN % REWIND IS NEEDED 00830800 + PRFIB ~ COIOD[NOT 2]; 00830900 + P(MKS, 2 ,0,[COIOD[NOT 2]],6,FCR); % REWIND OR RELEASE 00831000 + CIIOD~TP[I]; 00831100 + P(MKS,4,0,[CIIOD[NOT 2]],4,FCR); % CLOSE PURGE 00831200 + TN[I] ~ TN[NT]; TN[NT]~ 0; 00831300 + PRFIB[13].[27:1] ~ 1; % SET FORMER OUTPUT TO INPUT 00831400 + % %IR-14200831500 + P(COIOD,0,11,COM,DEL,DEL); % OPEN FOR INPUT 00831600 + P(COIOD); WAIT; COIOD[0] ~ 1 INX FLAG(PRFIB[16]); 00831700 + P((TP[NT])); TP[NT] ~ TP[I]; TP[I] ~ P(XCH); 00831800 + GO TO TPD; 00831900 + END; 00832000 + GO TO TPE; 00832100 + SORTDONE: 00832200 + COMMENT JUST DID FINAL PASS; 00832300 + COMMENT RETURN EVERYTHING; 00832400 + IF NOT MF THEN 00833000 + P([DOTOP]&0[18:18:15],6,11,COM,DEL,DEL); 00833100 + IF NOT OPTOG THEN BEGIN 00833200 + P(MKS,2,0,[OUTFIL[NOT 2]],4,FCR) 00833300 + ; IF NOT AC THEN P(0,OUTFIL[NOT 2],8,CDC,STD); 00833400 + END ELSE 00833500 + BEGIN COMMENT CALL OUTPUT PROCEDURE PASSING END-OF-SORT FLAG; 00833600 + IF AC THEN 00833700 + BEGIN ENDQ ~ 1; IF AC.[46:1] THEN 00833800 + P(MKS,BINGO,0,PERFORMGEN) % COBOL68 00833850 + ELSE P(MKS,BINGO,[PRTBASE[P(DUP)]],LOD,IPFIDX,COC) 00833900 + END ELSE P(MKS,1,MEM,0,OUTPRO); 00834000 + END; 00834100 + IF NOT MF THEN 00834200 + IF OUTCOUNT!INCOUNT THEN P(INCOUNT,OUTCOUNT,0, 00834300 + [DOTOP[NOT 2]],82,17,COM); 00834400 + P(10,COM); % FALL OUT OF BLOCK COM WILL RETURN EVERYTHING 00834500 + END POLYMERGE; 00834600 +REAL PROCEDURE OUMPINT(SN,CV,BV, TIPE,TENS,ALFA,CHAR,FIEL,FORMT);% 00900000 + VALUE SN,CV,BV, TIPE,TENS,ALFA,CHAR,FORMT;% 00900100 + REAL SN,CV,BV, TIPE,TENS,ALFA,CHAR,FORMT;% 00900200 + NAME FIEL;% 00900300 + BEGIN% 00900400 +REAL E=+1,% 00900500 + VALUEE=+2,% 00900600 + DH1=+3,% 00900700 + DH2=+4,% 00900800 + LNGTH=+5,% 00900900 + CSIZE=+6,% 00901000 + BCTR=+7% 00901100 +, TEMP=+8,% 00901200 + NL =+9% 00901300 +, J =+10,% 00901400 + TROW=+11,% 00901500 + COUNT=+12,% 00901600 + TARRY=+13,% 00901700 +N=BV,% 00901800 + SINN=9;% 00901900 +LABEL% 00902000 +PRINT,% 00902100 +PR3,% 00902200 +BRTN,% 00902300 +TA,% 00902400 +TCP,% 00902500 +TC,% 00902600 +IRTN,% 00902700 +P2,% 00902800 +P1,% 00902900 +TB,% 00903000 +TD,% 00903100 +P3E,% 00903200 +TF,% 00903300 +TP2,% 00903400 +TP3,% 00903500 +TP22,% 00903600 +TP1,% 00903700 +TP8,% 00903800 +TP5,% 00903900 +TP11,% 00904000 +TD1,% 00904100 +TD2,% 00904200 +TD3,% 00904300 +TP10,% 00904400 +TP9,% 00904500 +TP6,% 00904600 +TP7,% 00904700 +TP71,% 00904800 +P3,% 00904900 +P3A,% 00905000 +P3L,% 00905100 +P3I,% 00905200 +EA,% 00905300 +EB,% 00905400 +EC,% 00905500 +ED,% 00905600 +P5,% 00905700 +EE,% 00905800 +EFAA,% 00905900 +EFA,% 00906000 +ERTN,% 00906100 +EFB,% 00906200 +EFC;% 00906300 +SWITCH OCSWITCH~TA,TB,TC,TCP,TD;% 00906400 +SWITCH TIPESW~P3L,P3E,P3A,P3I;% 00906500 +REAL RITEINT=12;% 00906600 +REAL SELECT=14;% 00906700 +NAME M=2;% 00906800 +DEFINE I=ALFA#;% 00906900 + SUBROUTINE RITE;% 00907000 + BEGIN% 00907100 + P(MKS,1,0,0,LNGTH,FIEL,RITEINT, 00907200 + MKS,1,0,0,(-1),FIEL,RITEINT,DEL); 00907300 + END;% 00907400 + SUBROUTINE FINDE ;% 00907500 + BEGIN IF P(VALUEE|@1141000000000000,DUP)!0 THEN% 00907600 + BEGIN% 00907700 + SINN~P(DUP,0,<); P(SSP,.VALUEE,SND);% 00907800 + IF P(0,XCH,DIA 3,DIB 42,TRB 6,VALUEE,DIA 2% 00907900 + , DIB 1,TRB 1,12,+,@1157163034761674,|,% 00908000 + @1154000000000000,+,.E,ISN,DUP)<0 THEN GO TO EFB;% 00908100 + P(TENS);% 00908200 + EFAA:IF P { VALUEE THEN GO TO ERTN;GO TO EFC;% 00908300 + END;% 00908400 + P(DEL);% 00908500 + E~SINN~0;GO TO ERTN;% 00908600 + EFB: P(CHS,TENS,1,XCH,/); GO TO EFAA; 00908700 + EFC: E~E-1;% 00908800 + ERTN:% 00908900 + END;% 00909000 + SUBROUTINE OUTI;% 00909100 + BEGIN FINDE;% 00909200 + P(VALUEE,.DH1,ISD);% 00909300 + STREAM(P8~0:P7~SINN,P6~[VALUEE],P5~SINN,P4~0,P3~% 00909400 + E+1+SINN,P2~0,P1~BCTR);% 00909500 + BEGIN% 00909600 + P2(DS~LIT" ");% 00909700 + P1~DI;SI~P6;DS~P4 DEC; SI~P6;SI~SI+8;% 00909800 + DS~P3 DEC; P8~DI;SI~P1;DI~P1;% 00909900 + P7(IF SC!"0" THEN JUMP REAL TO IA;% 00910000 + DS~LIT " ";SI~SI+1);% 00910100 + IA:SI~LOC P4;SI~SI-1;IF SC="1" THEN% 00910200 + BEGIN% 00910300 + DI~DI-1;% 00910400 + DS~LIT"-";% 00910500 + END;% 00910600 + END;BCTR~P;% 00910700 + END;% 00910800 + SUBROUTINE BLNK;% 00910900 + BEGIN;% 00911000 + STREAM(P3~CSIZE,P2~CSIZE DIV 64,P1~(BCTR~*FIEL INX 0)00911100 + );% 00911200 + BEGIN% 00911300 + P2(32(DS~2 LIT" "));% 00911400 + P3(DS~LIT" ");% 00911500 + END;% 00911600 + END;% 00911700 + IF FORMT=5 THEN DUMPINT~FIEL ELSE% 00911800 + BEGIN P(0,0,0 );% 00911900 + IF M[M[FIEL INX NOT 2] INX 5].[43:1] THEN% 00912000 + P(MKS,0,0,FIEL,1,SELECT);% 00912100 + IF P(MKS,1,0,0,(-1),FIEL,RITEINT,DUP)>16 THEN P(DEL,16) ; 00912200 + IF P(DUP) <4 THEN P(XIT);% 00912300 + P(DUP,8,|,0,0 );BLNK;% 00912400 + BRTN: GO TO OCSWITCH[FORMT];% 00912500 + TA: STREAM(BCTR:A~ALFA ); BEGIN DI~BCTR;% 00912600 + SI~LOC A;SI~SI+1; DS~7 CHR END;% 00912700 + RITE;P(XIT);% 00912800 + TCP: IF (TEMP~TEMP+1){N THEN% 00912900 +IF P(TEMP-1,NOT,[CV],INX,LOD)!P(TEMP+N-1,NOT,[CV],% 00913000 + INX,LOD) THEN P(XIT) ELSE GO TO TCP;% 00913100 + TC: STREAM(BCTR:A~ALFA ); BEGIN DI~BCTR;% 00913200 + SI~LOC A;SI~SI+1; DS~6 CHR;DS~% 00913300 + 1 LIT"["; BCTR~DI;% 00913400 + END; BCTR~P;% 00913500 +VALUEE~P(N-1,NOT,[CV],INX,LOD);% 00913600 + OUTI;% 00913700 + IRTN: I~0;% 00913800 + P2: IF (I~I+1)P(MAXI) %WF 01806000 + THEN P(LITERAL, 26, COM); %WF 01807000 + IF I ~ POLISH THEN P(CHS); %WF 01808000 + X ~ X MOD P(PI);% 01809000 + END;% 01810000 + IF X } P(PIHAF) THEN% 01811000 + BEGIN P(CHS);% 01812000 + X ~ X-P(PI);% 01813000 + END;% 01814000 + IF ABS(X) < .000001 THEN P(Z|X,RTN);% 01815000 + P(X,DUP,% 01816000 + |,DUP,K1,NOP,|,K2,-,T,|,K3,+,T,|,K4,-,T,|,K5,+,T,|,K6,-,T,01817000 + |,1.0,+,X,|,Z,XCH,|,RTN);% 01818000 + PI :::@ 1143110375524210;% 01819000 + PIHAF:::@ 1141444176652104;% 01820000 + HALF :::@ 1154000000000000;% 01821000 + K1 :::@ 1271245234431113;% 01822000 + K2 :::@ 1253270005320624;% 01823000 + K3 :::@ 1235616716201177;% 01824000 + K4 :::@ 1216400637634150;% 01825000 + K5 :::@ 1174210421041102;% 01826000 + K6 :::@ 1151252525252524;% 01827000 + MAXI :::@ 0007777777777777;% %WF 01828000 + #;% 01829000 + PROCEDURE SININT(X); VALUE X; REAL X;% 01830000 + BEGIN REAL T=+2,Z=+1;% 01831000 + INTEGER I=T;% 01832000 + LABEL PI,PIHAF,HALF;% 01833000 + LABEL K1,K2,K3,K4,K5,K6;% 01834000 + LABEL MAXI;% %WF 01835000 + DEFINE LITERAL = 4#; %WF 01836000 + ;SINCOSBODY;% 01837000 + END;% 01838000 + PROCEDURE COSINT(X); VALUE X; REAL X;% 01839000 + BEGIN REAL T=+2,Z=+1;% 01840000 + INTEGER I=T;% 01841000 + LABEL PI,PIHAF ,HALF;% 01842000 + LABEL K1,K2,K3,K4,K5,K6;% 01843000 + LABEL MAXI; %WF 01844000 + DEFINE LITERAL = 5#; %WF 01845000 + X ~ X+P(PIHAF ,NOP,NOP,NOP);% 01846000 + SINCOSBODY;% 01847000 + END;% 01848000 + COMMENT ARCTAN INTRINSIC FOR ESPOL;% 01900000 + REAL PROCEDURE ARCTANINT(X1);% 01901000 + VALUE X1; REAL X1;% 01902000 + BEGIN REAL T=+1,D,PI2,ARCY;% 01903000 + LABEL L1,ONEL,PIHAF,A,B,ARCA,ARCB,TENM6;% 01904000 + LABEL K1,K2,K3,K4,K5,K6,K7;% 01905000 + DEFINE ONE = P(ONEL)#;% 01906000 + REAL X=X1;% 01907000 + P(DIA 1,DIB 1);% 01908000 + IF (T ~ ABS(X)) > ONE THEN% 01909000 + BEGIN PI2 ~ P(PIHAF,X,TRB 1);% 01910000 + IF T } P(L1) THEN P(X~0)% 01911000 + ELSE P(ABS(X~-(ONE/X)));% 01912000 + T ~ P;% 01913000 + END;% 01914000 + IF T < P(TENM6) THEN P(X+PI2,RTN);% 01915000 + IF T > P(K1) THEN% 01916000 + BEGIN IF T < P(K2) THEN P(A,ARCA) ELSE P(B,ARCB);% 01917000 + D ~ P(X,TRB 1,.ARCY,SND,TRB 1);% 01918000 + X ~ (X-D)/(D|X+ONE);% 01919000 + END;% 01920000 + P(X,DUP,% 01921000 + |,.T,SND,K3,|,K4,+,T,|,K5,-,T,|,K6,+,T,|,K7,-,T,|,ONE,+,% 01922000 + X,|,+,+,RTN);% 01923000 + ONEL :::@ 1141000000000000;% 01924000 + L1 :::@ 0631000000000000;% 01925000 + K1 :::@ 1151210574175662;% 01926000 + K2 :::@ 1154047010241407;% 01927000 + K3 :::@ 3165354424670553;% 01928000 + K4 :::@ 1167063634367006;% 01929000 + K5 :::@ 1151111104736450;% 01930000 + K6 :::@ 1151463146300126;% 01931000 + K7 :::@ 1152525252525235;% 01932000 + PIHAF:::@ 1141444176652104;% 01933000 + A :::@ 1152462675773223;% 01934000 + B :::@ 1155637726073171;% 01935000 + ARCA :::@ 1152406627566472;% 01936000 + ARCB :::@ 1155015457355165;% 01937000 + TENM6:::@ 1232061573640554;% 01938000 + END;% 01939000 + COMMENT LN INTRINSIC FOR ESPOL;% 02000000 + PROCEDURE LNINT(X); VALUE X; REAL X;% 02001000 + BEGIN LABEL L1,L2,L3,K15,K16,K17,K18,K19;% 02002000 + LABEL KON,K1,K2,K3,K4,K5,K6,K7,K8,K10,K11,K12,K13,K14;% 02003000 + LABEL MIN;% 02004000 + DEFINE ONE = P(KON)#;% 02005000 + IF X{0 THEN P(X,0,=,DUP,+,26,COM); % ARGUMENT CHECK %IA02006000 + IF (X ~ ABS(X+P(MIN)))> P(K1) THEN% 02007000 + IF X < P( K2) THEN% 02008000 + BEGIN P(0,0);% 02009000 + L3: P(X);% 02010000 + GO TO L2;% 02011000 + END;% 02012000 + P(X.[3:6]&X[1:2:1]+12,DUP,K3,|,XCH,DUP,+);% 02013000 + IF (X~X&76[2:41:7]) } P(K7) THEN BEGIN% 02014000 + IF X }P(K10) THEN BEGIN P(K14,+,K13); GO TO L1 END;% 02015000 + BEGIN P(K12,+,K11); GO TO L1 END; END;% 02016000 + IF X } P(K4) THEN% 02017000 + BEGIN P(ONE,+,K8); GO TO L1 END;% 02018000 + IF X { P(K2) THEN GO TO L3;% 02019000 + P(K6,+,K5);% 02020000 + L1:: P(X,|);% 02021000 + L2: P(ONE,-,DUP,K14,+,% 02022000 + /,DUP,DUP,NOP,% 02023000 + |,.X,SND,K15,|,K16,+,X,|,K17,+,X,|,K18,+,X,|,K19,+,% 02024000 + X,|,K14,+,XCH,|,+,+,RTN);% 02025000 + MIN:::@1770000000000001;% 02026000 + KON:::@1141000000000000;% 02027000 + K1 :::@1156165757475261;% 02028000 + K2 :::@1141221327436077;% 02029000 + K4 :::@1142073716664320;% 02030000 + K3 :::@1165053107716726;% 02031000 + K5 :::@1154664262770676;% 02032000 + K6 :::@1154000000000000;% 02033000 + K7 :::@1143373034355542;% 02034000 + K8 :::@1152742653066132;% 02035000 + K10:::@1145602266440557;% 02036000 + K11:::@1151621741671113;% 02037000 + K12:::@1141400000000000;% 02038000 + K13:::@1151052252521677;% 02039000 + K14:::@1142000000000000;% 02040000 + K15:::@1151406657727033;% 02041000 + K16:::@1151615542107107;% 02042000 + K17:::@1152222224366610;% 02043000 + K18:::@1153146314625377;% 02044000 + K19:::@1155252525252530;% 02045000 + END;% 02046000 + COMMENT EXP INTRINSIC FOR ESPOL;% 02100000 +REAL PROCEDURE EXPINT(X) ; VALUE X ; REAL X;% 02101000 + BEGIN% 02102000 + REAL Q = +4, Z =+1, EX = +2, B=+3, Y=+5, T = +2;% 02103000 + LABEL K0,K1,K2,K3,K4,K5,K6,HALF;% 02104000 + LABEL MAX; 02105000 + IF X < P(K0) THEN P(RTN);% 02106000 + IF X>P(MAX) THEN P(3, 26, COM); %WF 02107000 + P( X,K1,|,.X,SND, HALF,-,.Z, ISN,CHS,X,+,.X,SND,% 02108000 + DUP,NOP,|,DUP,K2,NOP,|,K3,+,T,|,K4,+,T,K5,+,T,NOP,|,% 02109000 + K6,+,X,|,DUP,B,+,B,Q,-,NOP,/,DUP,0,DEL,P.[3:6]&Y[1:2:1],% 02110000 + Z,3,DIV,+, .EX , SND, P & P[2:1:1]&EX[3:42:6],% 02111000 + Z,3, MOD,DUP,+, .EX, SND,0,! ) ;% 02112000 + IF P THEN% 02113000 + BEGIN IF Z < 0 THEN P( EX,/,CHS,RTN);% 02114000 + P ( EX, | ); END; P (RTN);% 02115000 + K0::: @ 3121520000000000 ;% 02116000 + K1::: @ 1141342521662454 ;% 02117000 + K2::: @ 1135326737175655 ;% 02118000 + K3::: @ 1102360633500106 ;% 02119000 + K4::: @ 1075621717466364 ;% 02120000 + K5::: @ 1111554324131444 ;% 02121000 + K6::: @ 1072002411247315 ;% 02122000 + HALF::: @ 1154000000000000 ;% 02123000 + MAX::: @ 1122360000000000 ; 02124000 + END EXP INT ;% 02125000 + PROCEDURE GOTOSOLVERINT(L,X,F,B);% 02200000 + VALUE L,X,F,B;REAL L,X,B;ARRAY F[*];% 02201000 + BEGIN IF L ! 15 THEN 02202000 + L ~ L&(F)[18:33:15]&B[8:38:10];% 02203000 + END;% 02204000 + REAL PROCEDURE MAXINT(X);% %WF 02300000 + VALUE X; REAL X;% %WF 02301000 + BEGIN REAL RCW=+0, SIZE=+1, JUNK=+2;% %WF 02302000 + POLISH(RCW, FCX, [RCW] INX NOT 1 INX 0, XCH, SUB, 0, X);% %WF 02303000 + WHILE SIZE>0 DO BEGIN P(DUP);% %WF 02304000 + JUNK ~ *(P(.X)+SIZE);% %WF 02305000 + IF POLISH<(JUNK ~ JUNK) THEN P(DEL, DUP);% %WF 02306000 + SIZE ~ SIZE-1;% %WF 02307000 + END;% %WF 02308000 + POLISH(RTN);% %WF 02309000 + END MAXINT;% %WF 02310000 + REAL PROCEDURE MININT(X);% %WF 02400000 + VALUE X; REAL X;% %WF 02401000 + BEGIN REAL RCW=+0, SIZE=+1, JUNK=+2;% %WF 02402000 + POLISH(RCW, FCX, [RCW] INX NOT 1 INX 0, XCH, SUB, 0, X);% %WF 02403000 + WHILE SIZE>0 DO BEGIN P(DUP);% %WF 02404000 + JUNK ~ *(P(.X)+SIZE);% %WF 02405000 + IF POLISH>(JUNK ~ JUNK) THEN P(DEL, DUP);% %WF 02406000 + SIZE ~ SIZE-1;% %WF 02407000 + END;% %WF 02408000 + POLISH(RTN);% %WF 02409000 + END MININT;% %WF 02410000 + PROCEDURE SUPERMOVERINT(SORCE, DEST, AEXP);% %WF 02500000 + VALUE AEXP; INTEGER AEXP; ARRAY SORCE[*], DEST[*];% %WF 02501000 + BEGIN INTEGER T=+1;% %WF 02502000 + POLISH(SORCE.[8:10], DEST.[8:10]);% %WF 02503000 + IF P(DUP)AEXP THEN T ~ AEXP;% %WF 02505000 + IF T>0 THEN %WF 02506000 + STREAM(P4~P, P3~P(DUP).[36:6], P2~[SORCE[0]]:P1~[DEST[0]]);%WF 02507000 + BEGIN SI~P2; P3(DS~32 WDS; DS~32 WDS); DS~P4 WDS; END; %WF 02508000 + END SUPERMOVERINT;% %WF 02509000 +PROCEDURE COBOLFCR; 02600000 + BEGIN 02600100 + REAL CODE =-1; % 0=INVALID,1=OPEN INPUT,2=OPEN REV IN02600110 + % 3=OPEN OUT,4=CLOSE,5=OPEN I-O,6=SORI02600120 + % 7=CLOSE CRUNCH,16=OPEN1,17=CLOSE1 02600200 + NAME FLOC =-2; % POINTER TO FIB DESCRIPTOR 02600300 + REAL MKSCW =-3; % = MKSCW :NO REEL,= 1 FOR REEL CLOSE 02600400 + % = REEL # FOR REEL OPEN. 02600410 + REAL CLOSELOCK =-4; % HOW TO CLOSE THE FILE 02600420 + % 0 = REWIND (RETAIN) 02600430 + % 1 = NO REWIND (RETAIN) 02600450 + % 2 = LOCK (SAVE) 02600470 + % 4 = PURGE LOCK (RELEASE + PURGE) 02600480 + % 6 = RELEASE LOCK (RELEASE + LOCK) 02600500 + % 7 = RELEASE (LOOK AT SAVE FACTOR) 02600510 + % 64 = CRUNCH 02600515 + % PRT DESCRIPTORS 02600600 + REAL COBOLCONTROL =23, % COBOL 61: FOR CALLING USE ROUTINES 02600650 + COBOLINDEX =22, % COBOL 61: FOR CALLING USE ROUTINES 02600700 + COBOLIO =14, % COBOL READ WRITE 02600800 + FCR =12, % COBOL FCR 02600900 + PERFORMGEN =13; % COBOL 68: FOR PERFORMING USE ROUTNS 02600990 + REAL INTINT =5; % ARRAY DEC INTRINSIC 02600994 + NAME MEM =2; % DUMMY DATA DESCRIPTOR 02600995 + ARRAY FPB =3[*], % FILE PARAMEIER BLOCK 02601000 + PGUSE =24[*];% USE ROUTINES ARRAY - COB61:13 WDS 02601100 + % COB68: 6 WDS 02601400 + % LOCALS 02601500 + REAL REEL; % MUST BE HERE FOR MKSCW OIDDLE 02601600 + ARRAY FIB[*]; % FILE INFO BLOCK 02601700 + REAL I; % INDEX + TEMPORARY 02601800 + NAME IOD=I; % IO DESCRIPTORS FOR CLOSE 02601900 + REAL IX; % INDEX TO FPB 02601950 + ARRAY LBL[*]; %LABEL FOR BUILDLABEL+HEADER FOR CLOSE02602000 + REAL NOTSERL; % SET TRUE FOR RANDOM & IO FILES 02602050 + INTEGER PU1,PU2, % USED BY BUILDLABEL + USERS.DONT MOVE02602100 + FU1,FU2; % USED BY BUILDLABEL + USERS DONT MOVE02602150 + REAL RPU1 = PU1, % USED BY BUILDLABEL 02602199 + RPU2 = PU2; % USED BY BUILDLABEL 02602200 + REAL T, % TEMPORARY 02602250 + TEST, % TRUE WHEN CALLING USERS,USERS68 SAYS02602300 + % TEST FOR BEG OR END FILE USE ROUTINE02602350 + SVFIB, % TRUE IF COBOL68 FIB IS TO BE SAVED 02602360 + COB68; % TRUE IF THIS IS COBOL 68 02602400 + DEFINE 02602410 + AF = [12:12]#, % COB68: FILL USL ROUTINE 02602430 + ALGOLIO(ALGOLIO1)=P([IOD],ALGOLIO1,11,COM,DEL,DEL)#, 02602440 + ARR = [36:12]#, % COB68: REEL USE ROUTINE 02602450 + BACKSPACE = P((-I),[FLOC[3]] INX 0,9,11,COM)#, 02602455 + BCOUNT = FIB[6]#, % BLOCK COUNT 02602460 + BF = [1:11]#, % COB68: FILE USE ROUTINE 02602470 + BOUNDED = FIB[9].[2:1]#, % TRUE IF BOUNDED FROM ABOVE 02602480 + BREAKFAIL = P(FIB[15].[25:5],(I=1)|4,12,COM)#,%BR OUT FAIL02602490 + BUFFERSIZE = FIB[18].[3:15]#, % BUFFER SIZE REQUESTED 02602500 + BUFREQ = FIB[13].[1:9]#, % NO. OF BUFFERS REQUESIED 02602510 + BUFTOP = FIB[16]#,% COPY OF TOP IOD:POINTS TO BEG BUFFR02602520 + BRR = [24:12]#, % COB68: REEL USE ROUTINE 02602530 + CALLHASH(CALLHASH1)=P(MKS,FLOC,*FIB[8],CALLHASH1,COC)#, 02602550 + CLOSE = 4#, 02602560 + CLOSED =(FIB[5].[41:2]!0)#,%FILE CLOSED 02602570 + CLOSEDHERE = FIB[8].[1:1]#, % COB68 CLOSE HERE WAS DONE 02602575 + CLOSEDRET = @20#, % CLOSED REIAINED 02602580 + COBOLCLOSE = P(CLOSELOCK&REEL [2:47:1],FLOC,CODE,13,COM, 02602585 + DEL,DEL,DEL)#, 02602586 + COBOLFILE = FIB[13]#, % ON SAYS FILE IS COBOL 02602590 + COBOLFILBIT = FIB[13].[47:1]#, 02602600 + COBOLOPENIN = P(REEL,FLOC,CODE,13,COM,.I,~,DEL,DEL)#, 02602610 + COBOLOPENOUT = P(REEL,FLOC,CODE,13,COM,DEL,DEL,DEL)#, 02602620 + COUNT = FIB[12]#, % NOTSERL : NO. OF CURRENT BLOCK 02602630 + % SERIAL IN(OUT): RECORD COUNT WIIHIN BLOCK 02602640 + CURRENTREEL = FIB[13].[28:10]#,% CURRENT REEL NUMBER 02602650 + DIRECTION = (FIB[13].[25:1])#,% 1=REVERSE,0=FORWARD 02602660 + DISCARDWA = P(MEM OR ((*RCPRT).[FF]),3,COM,DEL)#, 02602670 + DISK = FIB[4].[8:4]=4#, 02602680 + DISKR = 10#, % DISK RANDOM (FPB) 02602690 + DISKS = 12#, % DISK SERIAL (FPB) 02602700 + DISKP = 26#, % DISK PROTECT(FPB) 02602705 + ENDFILE = FIB[5].[40:1]#, % RECOGNIZED END OF FILE 02602710 + EOF = [27:1]#, % EOF BIT IN IOD 02602720 + EORF = [42:6]#, % SENTINEL: 1=EOR 0=EOF 02602730 + EORRERUN = FIB[4].[3:2]#,%EOR RERUN:1=OUTPUI IAPE,2=SCRCH02602740 + FPBXDONE = FIB[4].[12:1]#, % [13:11] IS FPB INDEX 02602770 + FCRCLOSE(FCRCLOSE1)=P(MKS,FCRCLOSE1,0,[FLOC],4,FCR)#, 02602780 + FCROPENOUT = P(MKS,T,[FLOC],3,FCR)#, 02602790 + FILIO = FIB[13].[22:1]#, % FILE OPEN IO 02602795 + FPBTYPE = FPB[IX+3].[43:5]#,% FPB FILE TYPE 02602798 + GETDISKROW = P(FPB[IX+3],FPB[IX],FPB[IX+1],10,LBL, 02602800 + 4,11,COM,DEL,DEL,DEL,DEL,DEL,DEL)#, 02602805 + HASH = (FIB[8]!0)#, % COB61: HASH ROUTINES PRESNI02602810 + HEADERPTR = FIB[14]#, % DESC. FOR DISK FILE HEADER 02602820 + HNMROWS = LBL[9]#, % HEADER: NUMBER OF ROWS 02602830 + % (DO NOT CHANGE) 02602831 + HNMSZRS = NOTSERL#, % HEADER: SIZE OF ROWS 02602840 + INFILE = FIB[13].[27:1]#, % FILE OPEN INPUT 02602850 + IODONE = FLOC[I+2].[19:1]#,% DONE BIT ON IN IOD 02602860 + IOERR(IOERR1) = P(0,FLOC,IOERR1,17,COM)#, % CALL IOERR-DONI DS02602865 + LABELED = NOT UNLABELED#, 02602870 + LABEQ = FIB[5].[17:1]#, % LABEL EQUATED FROM DISK 02602880 + LASTIO = FIB[13].[46:1]#, % 1=LAST WAS PHYSICAL READ 02602885 + LBLPTR = FLOC[1]#, % LABEL DESCRIPTOR 02602890 + LOCK = 2#, 02602900 + LSUBL = FIB[1]#, % DISK: LOWER BOUND RECORD NO02602910 + LSUBU = FIB[3]#, % DISK: UPPER BOUND RECORD NO02602920 + MABUSE = FIB[4].[1:1]#, % USE ROUTINES PRESENT 02602930 + MAXR = FIB[18][8:38:10]#, % MAX REC SZ FOR CONCATS 02602945 + MAXREC = FIB[18].[CF]#, % MAXIMUM RECORD LENGTH 02602950 + MINREC = FIB[18].[FF]#, % MINIMUM RECORD SIZE 02602952 + MT = 2#, % MAGNETIC TAPE 02602955 + NMSZROWS = FIB[8].[20:28]#, % DISK: NM=[20:5],SZ=[25:23] 02602960 + NOAIT = FIB[20].[3:1]#, % AIT FOR WA WAS DESTROYED 02602965 + NOREW = 1#, % NO REWIND 02602970 + NOTCLOSED = FIB[5].[41:2]=0#,% FILE NOT CLOSED 02602980 + NOTFIRSTREEL = FIB[5].[38:1]#, % =1 IFF CURRENTREEL!1ST REEL02602985 + NOTINANDOPEN = FIB[5].[41:3]!1#,% FILE NOT(INPUT & OPEN) 02602990 + NUMBUFF = FIB[13].[10:9]#, % NO.OF BUFFERS ASSIGNED 02603000 + NUMREC = FIB[11]#, % NO.OF RECORDS PER BLOCK 02603010 + OPENIN = 1#, 02603020 + OPENIO = 5#, 02603025 + OPENOUT = 3#, 02603030 + OPTIONAL = FIB[5].[39:1]#, % REEL OPTIONAL AND ABSENT 02603040 + OUTAP = T#, % EOR RERUN ON OUTPUT TAPE 02603050 + PBIT = [2:1]#, % PRESENCE BII 02603051 + PBT = 7#, 02603055 + PERFORMUSE = P(MKS,[FIB],T,0,PERFORMGEN)#, 02603060 + PRINTFILE = FIB[20] #, % CF=1 IS PRINTFILE 02603070 + PURGEREEL = P([FLOC[3]]&@23[CTF],20,11,COM,DEL,DEL,DEL)#, 02603080 + PURGE = 4#, 02603090 + RANDOM = FIB[4].[29:1]#, % RANDOM ACCESS IS THE ORDER 02603100 + RCOUNT = FIB[7]#, % NO.OF RECORDS INTO FILE 02603110 + RCPRT = FIB[20].[FF]#, % PRT OF DESC POINIING IO REC02603115 + RECSPERBLK = LBL[0].[30:12]#, % HEADER: RECORDS PER BLOCK 02603120 + REDECWA = P(MKS,RCPRT,MAXREC,1,1,1,INTINT)#, % DECLARE 02603130 + % SAVE ARRAY FOR WORK AREA02603140 + RELEASE = 7#, 02603200 + RESETPARITY = FLOC[3]~ (*P(DUP))&0[28:28:1]#, % RESEI PARIIY02603202 + RESETREADBIT = 0[24:24:1]#, % USED TO TURN OFF READ BIT 02603205 + REWIND = 0#, 02603210 + SEGSPEROW = LBL[8]#, % HEADER:SEGMENTS PER ROW 02603220 + SEGSPBLK = LBL[0].[42:6]#, % HEADER:SEGMENTS PER BLOCK 02603230 + $ SET OMIT = NOT(TIMESHARING) 02603232 + SLEEPCM = 36,COM#, % SLEEP COMUNICAIE 02603235 + $ POP OMIT 02603236 + $ SET OMIT = TIMESHARING 02603237 + SORT = 6#, 02603240 + SORTFILE = (FIB[4].[7:1] OR FIB[18].[1:1])#, 02603250 + SZF = [8:10]#, 02603260 + TECH = FIB[5].[46:2]#, 02603270 + TECHB = 2#, % TECHNIQUE B 02603280 + TECHC = 3#, % TECHNIQUE C 02603290 + TERM(TERM1) = P(1,FLOC,TERM1,17,COM)#, % TERMINATE ON IO ERR02603300 + TIP = FLOC[3]#, % TOP IOD 02603310 + UNITYPE = (FIB[4].[8:4])#, %ASSND INTERNAL HARDWARE TYPE02603330 + UNLABELED = FIB[4].[2:1]#, % UNLABELED FILE 02603340 + WAITIO = P([FLOC[I+2]],@2000000000,SLEEPCM,DEL,DEL)#, 02603360 + WORDSLEFT = FIB[17]#, % NO OF WORDS LEFT IN BLOCK 02603370 + WRITEPARITY = FIB[5].[3:1]#, % INDICATES FORCED REELSWITCH02603375 + WRITBACK = FIB[13].[23:1]#, % WRITE BLOCK BACK ON IO 02603380 + WRITEAFTEREOF = FIB[13].[44:2]#; 02603385 + LABEL LINVALID,LOPENIN,LOPREVIN,LOPENOUT,LCLOSE,LOPENIO,LSORT, 02603390 + LOPEN1,LCLOSE1,STARTL,EXIT,TSTBRK,BSTP;% 02603395 + SWITCH TYPE ~ LINVALID,LOPENIN,LOPREVIN,LOPENOUT,LCLOSE,LOPENIO, 02603400 + LSORT;% 02603450 +SUBROUTINE BUILDLABEL;% 02603500 + BEGIN% 02603600 + I~IX;% 02603700 + FLOC[1]~FLAG(1&(IF FPB[I+3].[43:5]=1 THEN 19 ELSE FLOC[1].[8:1002603800 + ]+4)[8:38:10]&(FLOC INX 1)[18:33:15]);% 02603900 + P(FLOC[1],0,COC,DEL);% 02604000 + FLOC[1]~(2 INX FLOC[1])&(FLOC[1].[8:10]-4)[8:38:10];% 02604100 + STREAM( A ~ FU2~P(0,1,COM),B~FIB[4],C~[PU1]);% 02604200 + BEGIN SI~ LOC A;SI~SI+3;DS~2OCT;DS~3OCT;% 02604300 + SI~LOC B; SI~SI+5; DS~3OCT; END;% 02604400 + FU1~(PU2~PU2+FU1+3649)MOD 365+(PU2 DIV 365+PU1-10)|1000+1;% 02604500 +% AT THIS POINT FU1 CONTAINS PURGE DATE(BINARY) AN FU2=DATE(DECIMAL)% 02604600 + STREAM(K~0:A~CURRENTREEL,B~FPB[I+2]); BEGIN% 02604700 + DI~LOC K;SI~LOC A;DS~3DEC;SI~LOC B;SI~SI+3;DS~5CHR END;% 02604800 + IF (RPU1~P).[1:17]=0 THEN 02604900 + IF (RPU1~FPB[I+2]).[1:17]=0 THEN RPU1.[17:1]~1; 02605000 + IF RPU1.[18:30]=0 THEN RPU1.[18:30]~FU2; 02605100 + IF (RPU2:=FPB[I+3]).[1:5]=0 THEN RPU2.[5:1]:=1; 02605200 + STREAM(K~0:PU1);BEGIN DI~LOC K;SI~LOC PU1;DS~3OCT END;% 02605300 + REEL~P; CURRENTREEL~REEL; 02605400 + STREAM(A~[FPB[I]],B~PU1,C~PU2,D~FU1,% 02605500 + Q~IF (T~FPB[I+3].[43:5])=10 OR T=12 OR T=26 THEN 02605600 + P([HEADERPTR],LOD,7,COC,1,+) ELSE 0, 02605700 + G~FLOC[1].[8:10]-8,% 02605900 + F~IF REEL!1 THEN FIB[4].[4:1] ELSE 0,E~FLOC[1]); 02606000 + BEGIN DS~8LIT" LABEL ";% 02606100 + SI~A; DS~2 WDS; SI~LOC B; DS~WDS; SI~LOC C;% 02606200 + DI:=DI+1;DS:= CHR; SI:=LOC D; DS:=5 DEC;% 02606300 + DS~LIT"0"; %SENTINAL% 02606400 + DS~5LIT"0";% BLOCK-COUNT% 02606500 + SI~LOC Q;DS~7DEC; %REC-COUNT% 02606600 + SI~LOC F;SI~SI+7;DS~CHR; % MEM-DUNP KEY% 02606700 + DS~5LIT"0"; % PHYSICAL TAPE NO.% 02606800 + DS~6LIT"0";% 02606900 + G(DS~8LIT" ");% 02607000 + END END;% 02607100 + SUBROUTINE GOUSE;% 02607200 + BEGIN% 02607300 + COBOLINDEX ~ T.[26:10];% 02607400 + P( MKS, T.[38:10], [COBOLCONTROL]);% 02607500 + END;% 02607600 + SUBROUTINE CALLGOUSE; 02607700 + BEGIN 02607800 + IF I OR TEST THEN 02607900 + BEGIN IF(T~PGUSE[I].[ 1:23])! 0 THEN GOUSE; 02608000 + IF(T~PGUSE[I].[24:24])! 0 THEN GOUSE; 02608100 + END; 02608200 + END CALLGOUSE; 02608300 + SUBROUTINE CALLGOUSER; 02608310 + BEGIN 02608320 + IF I OR TEST THEN 02608330 + BEGIN IF (T~FIB[I].[ 1:23])! 0 THEN GOUSE; 02608340 + IF (T~FIB[I].[24:24])! 0 THEN GOUSE; 02608350 + END; 02608360 + END CALLGOUSER; 02608370 + SUBROUTINE USERS; 02608400 + BEGIN 02608500 + I ~ PU1; CALLGOUSE; 02608600 + IF (I~PU2)>0 THEN CALLGOUSE; 02608700 + I ~ FU1; CALLGOUSER; 02608800 + IF (I~FU2)>0 THEN CALLGOUSER; 02608900 + END USERS; 02609000 + SUBROUTINE GOUSE68; 02609005 + BEGIN PERFORMUSE; END; 02609006 + SUBROUTINE USERS68; 02609010 + BEGIN 02609020 + IF TEST THEN 02609030 + BEGIN % CHECK FOR FILE USE ROUTINES 02609040 + IF (T~FIB[FU1].BF)!0 THEN GOUSE68; 02609050 + IF (T~FIB[FU1].AF)!0 THEN GOUSE68; 02609060 + IF (T~PGUSE[PU1].BF)!0 THEN GOUSE68; 02609070 + IF (T~PGUSE[PU1].AF)!0 THEN GOUSE68; 02609080 + END; 02609090 + IF PU2>0 THEN 02609100 + BEGIN % NOT DISK: CHECK FOR REEL USE ROUTINES 02609110 + IF (T~FIB[FU1].BRR)!0 THEN GOUSE68; 02609120 + IF (T~FIB[FU1].ARR)!0 THEN GOUSE68; 02609130 + IF (T~PGUSE[PU1].BRR)!0 THEN GOUSE68; 02609140 + IF (T~PGUSE[PU1].ARR)!0 THEN GOUSE68; 02609150 + END; 02609160 + END USERS68; 02609170 +% * * * * * * * * * * * * * * S T A R T H E R E * * * * * * * 02610150 + REEL ~ IF P(MKSCW,TOP,XCH,DEL) THEN MKSCW ELSE 0;% 02610200 + COB68 ~ (FIB~*FLOC).SZF=22;% 02610300 + IF CODE=18 THEN BEGIN CODE:=4; SVFIB:=1; END; 02610310 + IF NOT FPBXDONE THEN FIB[4].[12:12] ~ % 02610400 + ((FIB[4].[12:12]-1)|ETRLNG)&1 [36:47:1];% 02610500 + IF NOT COB68 THEN 02610550 + IF REEL>9 THEN% 02610600 + BEGIN % CONVERT REEL NO TO OCTAL02610700 + STREAM(K~0:L~REEL);% 02610800 + BEGIN SI~LOC L; SI~SI+5;% 02610900 + DI~LOC K; DS~3 OCT;% 02611000 + END;% 02611100 + REEL ~ P;% 02611200 + END;% 02611300 + IX ~ FIB[4].[13:11];% INDEX TO FPB 02611370 + IF CODE!CLOSE THEN% 02611390 + IF (T~FPBTYPE)=DISKR OR T=DISKP OR CODE=OPENIO THEN 02611400 + BEGIN IF (T=DISKR OR T=DISKP) AND NOT COB68 THEN 02611410 + BUFREQ~1; NOTSERL~TRUE; 02611430 + END ELSE 02611440 + IF T<3 OR T=11 OR (T GEQ 7 AND T<10) THEN 02611450 + IF FIB[8].[20:5]>0 THEN % HAS BEEN LABEQ FRM DISK 02611480 + BEGIN NMSZROWS~0; LABEQ ~ TRUE; END;% 02611490 + IF CODE=SORT THEN GO TO LSORT;% 02611495 + IF CODE!CLOSE THEN% 02611500 + BEGIN 02611510 + FIB[13].[19:5] ~0;% 02611610 + IF T=DISKR OR T=DISKS OR T=DISKP THEN% TECH B & C NOT02611620 + IF TECH>1 THEN TERM(30); % VALID ON DISK %CJC 103I02611630 + IF COB68 THEN IF TECH!TECHC THEN MINREC~MAXREC; 02611675 + END;% 02611680 + NUMBUFF ~ BUFREQ;% 02611700 + STARTL:% 02611800 + IF CODE>5 THEN IF CODE=16 THEN GO TO LOPEN1 ELSE% 02611900 + IF CODE=17 THEN GO TO LCLOSE1 ELSE TERM(25);% 02612000 + GO TO TYPE[CODE];% 02612100 + LOPENIO:% 02612200 + CODE ~ OPENIN;% 02612300 + FILIO ~ 1;% 02612400 + GO TO LOPENIN;% 02612500 + LOPREVIN:% 02612600 + IF ((T~TECH)=TECHC) OR (T=TECHB AND NUMREC!1) THEN TERM(5); 02612700 + LOPENIN:% 02612800 + IF NOTCLOSED THEN TERM(2|CODE-1);% 02612900 + IF REEL=0 THEN REEL ~ CURRENTREEL ELSE CURRENTREEL ~ REEL; 02613600 + IF (T~FPBTYPE)=DISKR OR T=DISKS OR T=DISKP THEN 02614200 + BEGIN% 02614300 + NMSZROWS ~ 0; % SINCE ITS INPUT 02614400 + IF LSUBU!0 THEN % UPPER BOUND 02614500 + BEGIN LSUBU ~ *P(DUP)-1; BOUNDED ~ TRUE; END; 02614600 + IF LSUBL!0 THEN LSUBL ~ *P(DUP)-1;% 02614700 + WRITEAFTEREOF ~ 0;% 02614750 + BCOUNT ~ IF (RCOUNT~LSUBL)=0 THEN 0 ELSE % STARTING 02614800 + (RCOUNT-1) DIV NUMREC + 1; % BLOCK 02614900 + END;% 02615000 + COBOLOPENIN; % STORE BOOLEAN RESULT IN I: TRUE FOR 02615100 + % LABELED AND NOT SORT FILE ON OPEN IN 02615105 + IF COB68 THEN% 02615110 + BEGIN% 02615115 + IF NOAIT THEN% 02615120 + BEGIN% 02615125 + REDECWA;% 02615130 + NOAIT ~ 0;% 02615133 + END;% 02615135 + END;% 02615140 + IF DISK THEN% 02615170 + BEGIN% 02615200 + IF NOT COB68 THEN 02615250 + IF RANDOM THEN TIP ~ 1 INX TIP;% DISK ADDR IN WRD 1 02615300 + BUILDLABEL;% 02615400 + IF MABUSE OR NOT COB68 THEN% 02615500 + BEGIN % BEGINNING INPUT/IO FILE 02615600 + FU1~ 0; TEST ~ 1; PU2 ~ FU2 ~ -1; 02615700 + IF COB68 THEN BEGIN PU1 ~ 4|FILIO;% 02615800 + USERS68; END% 02615900 + ELSE BEGIN PU1 ~ 10|FILIO; USERS; END;% 02616000 + END;% 02616100 + IF COB68 THEN 02616140 + BEGIN 02616160 + BCOUNT ~ (IF RANDOM THEN NOT 0 02616180 + ELSE RCOUNT DIV NUMREC); 02616200 + COUNT~BCOUNT + (NUMBUFF-1)&FIB[5][1:44:1]; 02616220 + END ELSE 02616240 + BEGIN IF NOTSERL THEN %TR 1476 02616260 + TIP ~ (BUFFERSIZE + 1) INX TIP & MAXR; %TR 1476 02616300 + COUNT ~ IF NOTSERL THEN -1 ELSE 0; %TR 1476 02616400 + RESETPARITY; %IR 1476 02616450 + END ; %TR 1476 02616470 + GO TO EXIT;% 02616500 + END DISK;% 02616600 + IF HASH THEN IF NOT WRITEPARITY THEN CALLHASH(2); 02616700 + IF NOT OPTIONAL THEN 02616750 + IF (MABUSE OR NOT COB68) AND I THEN % LABELED AND NOT SORT 02616800 + IF NOT WRITEPARITY THEN 02616850 + BEGIN % BEGINNING INPUT FILE/REEL 02616900 + PU1 ~ FU1 ~ 0; TEST ~ CURRENTREEL=1;% 02617000 + PU2 ~ FU2 ~ 1;% 02617100 + IF COB68 THEN USERS68 ELSE USERS;% 02617200 + END;% 02617300 + GO TO TSTBRK;% 02617400 + LOPENOUT:% 02617500 + IF NOTCLOSED THEN TERM(6);% 02617600 + IF CLOSEDHERE THEN BEGIN CLOSEDHERE~0; GO LOPEN1; END;% 02617700 + IF REEL!0 THEN CURRENTREEL~REEL;% FIXES OPEN OUT REEL DATA-NAME02618500 + IF (T~FPBTYPE)=5 OR T=8 OR T=9 % UNLABELED SPEC UNIT, PT, OR MT02618550 + THEN UNLABELED ~ 1;% 02618600 + IF T=DISKR OR T=DISKS OR T=DISKP THEN 02618650 + BEGIN% 02618700 + IF LSUBU!0 THEN BEGIN LSUBU ~ *P(DUP)-1;% 02618750 + BOUNDED ~ TRUE; END;% 02618800 + IF LSUBL!0 THEN LSUBL ~ *P(DUP)-1;% 02618900 + BCOUNT ~ (RCOUNT~LSUBL) DIV NUMREC;% 02619000 + IF COB68 AND NMSZROWS = 0 THEN % DISK DEFAULT IS 02619004 + IF NOT DISK THEN % (LBL EQU ONLY) 02619005 + NMSZROWS ~ 100&20[20:43:5]; % 20 ROWS 100 RECS02619006 + END% 02619010 + ELSE IF LABELED THEN% 02619020 + BEGIN% 02619100 + BUILDLABEL;% 02619200 + IF NOT SORTFILE THEN% 02619300 + BEGIN IF HASH THEN CALLHASH(2);% 02619400 + IF MABUSE OR NOT COB68 THEN%BEG OUT FILE/RL02619410 + BEGIN TEST ~ REEL=1; FU1 ~ 0; PU2 ~ 5;02619420 + IF COB68 THEN% 02619430 + BEGIN PU1~2; USERS68; END% 02619500 + ELSE BEGIN PU1~4;FU2~1;USERS;END;02619600 + END;% 02619700 + END;% 02619800 + END;% 02619900 + COBOLOPENOUT;% 02620000 + IF COB68 THEN % MOVE WA TO BUF.SAVE WA ADDR, POINT PRT TO BUFF02620010 + BEGIN% 02620015 + IF NOAIT THEN% 02620020 + BEGIN% 02620030 + REDECWA;% 02620040 + NOAIT ~ 0;% 02620050 + END;% 02620060 + IF NOT (DISK) THEN 02620065 + BEGIN WORDSLEFT ~ BUFFERSIZE; 02620070 + PRINTFILE ~ P(DUP,LOD,(FIB[4].[8:4]), 02620075 + P(DUP)=1,P(XCH,DUP)=7,P(XCH)=12,OR,OR,CCX);02620080 + END UNDISK; % 1=LP, 7=PBT, 12=PBD 02620085 + END COB68ING; 02620090 + IF DISK THEN% 02620100 + BEGIN% 02620200 + IF RANDOM THEN 02620250 + IF COB68 THEN BCOUNT ~ NOT 0 02620300 + ELSE TIP ~ 1 INX TIP; 02620350 + BUILDLABEL;% 02620400 + LBL ~ *[HEADERPTR];% 02620500 + LBL[7] ~ -1;% 02620600 + IF MABUSE OR NOT COB68 THEN% 02620800 + BEGIN % BEGINNING OUTPUT FILE 02620810 + FU1 ~ 0; TEST ~ 1; PU2 ~ FU2 ~ -1; 02620900 + IF COB68 THEN BEGIN PU1 ~ 2; USERS68; END 02621000 + ELSE BEGIN PU1 ~ 4; USERS; END; 02621100 + END;% 02621200 + IF NOT COB68 THEN 02621220 + BEGIN 02621230 + RESETPARITY;% 02621250 + IF NOTSERL THEN% 02621300 + BEGIN% 02621310 + IF UNITYPE =4 AND NOT UNLABELED AND NOT SORTFILE THEN %IR-9002621320 + TIP ~ (BUFFERSIZE + 1) INX TIP & MAXR; %TR 1476 02621325 + BUFTOP ~ (*P(DUP)) & 1[24:47:1]; %TR 1476 02621330 + END END; 02621335 + END DISK;% 02621340 + IF NOT COB68 THEN COUNT ~ IF NOTSERL THEN -1 ELSE NUMREC; 02621350 + TSTBRK:% 02621360 + IF (T~EORRERUN)!0 AND CURRENTREEL!1 THEN IF BREAKFAIL AND OUTAP02621364 + THEN BEGIN PURGEREEL; GO TO STARTL; END % TRY BREAK AGAIN 02621365 + ELSE P(DEL);% 02621370 + GO TO EXIT;% 02621371 + LCLOSE:% 02621375 + IF OPTIONAL THEN % EOF ON ABSENT OPTIONAL FILE 02621380 + BEGIN FIB[5] ~ (*P(DUP))&4 [39:42:6]; % MARK CLOSED RLSD 02621400 + P(XIT);% 02621500 + END;% 02621600 + IF NOT SORTFILE AND CLOSED THEN BEGIN IOERR(12-FIB[5].[43:1]); 02621700 + GO TO EXIT; END; 02621750 + IF INFILE THEN% 02621800 + IF (COB68 AND MABUSE AND DISK) THEN % END INPUT/IO FILE 02621810 + BEGIN FU1~2; PU2~-1; TEST~1; PU1~1+4|FILIO;% 02621820 + USERS68;% 02621830 + END ELSE% 02621840 + ELSE IF (LABELED AND NOT SORTFILE) THEN% 02621900 + IF DISK THEN% 02622000 + BEGIN % MOVE RECORD COUNT FROM HEADER TO LABEL 02622010 + STREAM(A~P([HEADERPTR],LOD,7,COC,1,+), 02622020 + B~ 5 INX LBLPTR);% 02622030 + BEGIN SI~LOC A; DI~DI+5; DS~7 DEC; END;% 02622040 + IF MABUSE OR NOT COB68 THEN% END OUTPUT FILE 02622050 + BEGIN FU1~2; TEST~1; PU2~FU2~-1; 02622070 + IF COB68 THEN BEGIN PU1~3; USERS68; END02622100 + ELSE BEGIN PU1~6; USERS; END;% 02622200 + END;% 02622300 + END % NOT DISK 02622400 + ELSE BEGIN % MOVE BLK & RECORD COUNTS FROM FIB TO LBL02622500 + IF HASH THEN CALLHASH(1);% 02622600 + STREAM(A~BCOUNT,B~RCOUNT,C~5 INX LBLPTR);% 02622700 + BEGIN SI~LOC A; DS~5 DEC; DS~7 DEC; END;% 02622800 + LBL ~ LBLPTR;% 02622900 + LBL[4].EORF~ REEL!0;% 02623000 + LBL ~ 0; %FILE CLOSE FORGETS LABELS-SO CLEAR PTR02623100 + IF REEL THEN CLOSELOCK ~ LOCK;% 02623200 + IF MABUSE OR NOT COB68 THEN% END OUTPUT FILE/RL 02623300 + BEGIN FU1~2; TEST ~ REEL=0; PU2 ~ 7; 02623400 + IF COB68 THEN BEGIN PU1~3; USERS68; END 02623500 + ELSE BEGIN PU1~6; FU2~3; USERS; END; 02623600 + END;% 02623610 + END; % OF NONDISK 02623620 + IF DISK AND LABELED AND NOT SORTFILE THEN% 02623700 + BEGIN% 02623800 + LSUBL ~ *P(DUP)+1;% 02623900 + IF BOUNDED THEN % IF UPPER BOUND 02624000 + BEGIN LSUBU ~ *P(DUP)+1; BOUNDED~FALSE; END 02624100 + ELSE IF COB68 THEN LSUBU ~ 0; 02624200 + LBL ~ *[HEADERPTR];% 02624300 + HNMSZRS ~-(((SEGSPEROW|RECSPERBLK) DIV SEGSPBLK)02624400 + & HNMROWS [20:43:5]);% NM,SZ ROWS FR HEADER02624500 + NMSZROWS ~ 0; % ZERO FIB NM,SZ ROWS 02624600 + IF NOT COB68 THEN IF RANDOM THEN WORDSLEFT~0; 02624610 + END;% 02624700 + IF UNITYPE=MT AND NOT REEL THEN% 02624800 + BEGIN% 02624900 + IF CLOSELOCK=REWIND AND NOTFIRSTREEL THEN% 02624910 + CLOSELOCK ~ LOCK;% 02624920 + NOTFIRSTREEL ~ FALSE;% 02625000 + END;% 02625100 + T ~ CURRENTREEL;% 02625105 + IF REEL AND UNITYPE=PBT THEN FIB[9].[1:1] ~ 1; 02625110 + COBOLCLOSE;% 02625200 + IF HNMSZRS.[1:1] THEN 02625210 + BEGIN% 02625220 + NMSZROWS ~ ABS(HNMSZRS);% 02625225 + HNMSZRS ~ 0;% 02625230 + WRITBACK ~ FALSE; % RANDOM OUTPUT AND I-O 02625240 + END;% 02625250 + IF REEL THEN% 02625255 + BEGIN % REEL SWITCH 02625260 + REEL ~ T+1;% 02625265 + CODE ~ 3-(2|INFILE)+DIRECTION;% 02625268 + IF CODE=OPENOUT THEN CURRENTREEL ~ REEL;% 02625270 + NOTFIRSTREEL ~ TRUE; 02625280 + GO TO STARTL;% 02625300 + END% 02625400 + ELSE CURRENTREEL ~ 0; 02625500 + IF NOT SVFIB THEN 02625510 + IF COB68 AND CLOSELOCK>1 THEN IF (T~FIB[20])<0 THEN 02625600 + % THROW AWAY FILE TANK, RE-INITIALIZE TYPE-2 SEGMENT DESC 02625650 + P(FLOC,DUP,FCX,3,COM,FLAG(0 & T [23:8:10] & T 02625700 + [8:8:10] & 9 [3:44:4]),SSN,XCH,~); 02625800 + P(XIT); 02625950 + LINVALID:% 02626000 + TERM(25);% 02626050 + LCLOSE1:% 02626100 + IF NOTINANDOPEN THEN TERM(12-FIB[5].[43:1]);% 02626150 + IF ENDFILE THEN BEGIN I ~ 1; GO TO BSTP; END;% 02626200 + FOR I ~ 1 STEP 1 UNTIL NUMBUFF DO% 02626250 + BEGIN % WAIT UNTIL ALL I0-S ARE DONE% 02626300 + IF NOT IODONE THEN WAITIO;% 02626350 + IF FLOC[I+2].EOF THEN GO BSTP;% 02626400 + END;% 02626450 + I ~ NUMBUFF;% 02626500 + BSTP:% 02626550 + BACKSPACE; % BACKSPACL I BLOCKS 02626600 + TIP.EOF ~ ENDFILE;% 02626650 + CLOSEDHERE ~ COB68;% 02626660 + FIB[5].[40:6] ~ CLOSEDRET;% 02626700 + GO TO EXIT;% 02626750 + LOPEN1:% 02626800 + IF FIB[5].[40:6]!CLOSEDRET THEN TERM(6);% 02626850 + FIB[5].[40:6] ~ 0;% 02626900 + BUFTOP ~(*P(DUP))& RESETREADBIT;% 02626950 + INFILE ~ 0; % MAKE IT OUTPUT 02627000 + LBLPTR ~(*P(DUP))& RESETREADBIT;% 02627050 + IF TIP.EOF THEN% 02627100 + BEGIN % HAD READ EOF BEFORE BACKSPACE 02627150 + WORDSLEFT ~ BUFFERSIZE;% 02627200 + TIP.EOF ~ 0; % RESET EOF 02627250 + COUNT ~ NUMREC; % # RECS LEFT IN BUFF = WHOLE BUFF 02627300 + BUFTOP.[CF] ~ TIP.[CF];% 02627340 + END% 02627350 + ELSE BEGIN % NO EOF - OPEN IN PLACE 02627400 + RCOUNT ~ *P(DUP)-1;% BACK UP BECAUSE WE 02627450 + BCOUNT ~ *P(DUP)-1;% WERE READING 02627500 + WORDSLEFT ~ BUFFERSIZE-(TIP.[CF]-BUFTOP.[CF]);% 02627510 + COUNT ~ WORDSLEFT DIV MAXREC; % # RECS LEFI IN BUFF02627600 + END;% 02627650 + FOR T ~ 1 STEP 1 UNTIL NUMBUFF DO% 02627700 + FLOC[T+2] ~ FLAG(BUFTOP&FLOC[T+2][CTC]); % CHANGE TO WRITE02627750 + GO TO EXIT;% 02627800 + LSORT:% 02627850 + IOD ~ [TIP];% 02627860 + IF CLOSELOCK=NOREW THEN % FCR CALLED WITH THESE PARAMS 02627870 + BEGIN %IF IO COMPLETE BUT NOI PRESENT02627880 + IF NOT (*IOD).EOF % NOT EOF:MUST HAVE BEEN PARITY02627890 + THEN TERM(19) % TERMINATE ON PARITY 02627900 + ELSE % MUST HAVE BEEN EOF OR EOR 02627910 + BEGIN ALGOLIO(11);% READLABEL 02627920 + LBL ~ LBLPTR;% 02627930 + IF LBL[4].EORF=0 THEN P(1,RTN);%RETURN EOF02627940 + REEL ~ CURRENTREEL+1;%REEL SWITCH ON INPUT02627950 + T ~ COBOLFILBIT; % REMEMBER IF COBOL FILE 02627960 + FCRCLOSE(PURGE); 02627970 + FIB[13]~(*P(DUP))&REEL[28:38:10]% NXT REEL02628000 + &0 [47:47:1]; % MAKE IT LOOK ALGOL02628050 + ALGOLIO(0);% OPEN INPUT NEXT REEL 02628100 + FIB[13] ~(*P(DUP))OR T;% RESTORE COBOL BIT02628150 + P(0,RTN); % RETURN EOR 02628200 + END;% 02628250 + END NOREW;% 02628300 + IF CLOSELOCK=REWIND THEN% 02628310 + BEGIN % REEL SWITCH ON OUTPUT 02628320 + LBL ~ LBLPTR;% 02628330 + LBL[4].EORF ~ 1; % EOR 02628340 + LBL ~ 0;%FILE CLOSE FOGETS LABEL SO PTR MUST BE CLRD 02628350 + T ~ CURRENTREEL+1;% 02628360 + FCRCLOSE(RELEASE); % CLOSE RELEASE CURRENT REEL 02628370 + CURRENTREEL ~ REEL ~ T;%WIIH NO REEL SWITCH-DONE HERE02628380 + IF COBOLFILE THEN FCROPENOUT ELSE ALGOLIO(0);%NXT RL 02628390 + P(XIT); % OPEN OUT (ALGOL OR COBOL)NXI REEL02628400 + END;% 02628450 + IF CLOSELOCK=LOCK THEN 02628500 + BEGIN% 02628510 + T ~ IF CURRENTREEL=1 THEN REWIND ELSE RELEASE; 02628520 + FCRCLOSE(T); % CLOSE REWIND FIRST REEL. 02628550 + P(XIT); % CLOSE RELEASE ALL OTHERS 02628600 + END;% 02628700 + EXIT::% 02628800 + END COBOLFCR;% 02628900 +PROCEDURE COBOLATT; BEGIN % INT # = @ 165 %CJC 103I02650000 + COMMENT INTRINSIC FOR COBOL ATTRIBUTES %CJC 103I02650100 + CALLING SEQUENCE IS %CJC 103I02650110 + MKS %CJC 103I02650120 + LITC OPERATION %CJC 103I02650130 + LITC FILEFIB %CJC 103I02650140 + DESC 10 %CJC 103I02650145 + LITC ATTRIBUTENUM %CJC 103I02650150 + LITC WORD-OFSET %CJC 103I02650160 + DESC DATAWORD %CJC 103I02650170 + %CJC 103I02650180 + OBERATIONS ARE: %CJC 103I02650190 + 1 = MOVE %CJC 103I02650200 + 0 = SET (OR CHANGE ATTRIBUTE VALUE) %CJC 103I02650210 + %CJC 103I02650220 + ATTRIBUTENUM HAS THE FOLLOWING VALUES: %CJC 103I02650230 + 0 = EOF %CJC 103I02650240 + 1 = DO NOT USE %CJC 103I02650250 + 2 = DO NOT USE %CJC 103I02650260 + 3 = SAVEFACTOR %CJC 103I02650270 + 4 = AREAS %CJC 103I02650280 + 5 = AREASIZE %CJC 103I02650290 + 6 = MFID %CJC 103I02650300 + 7 = FI0 %CJC 103I02650310 + 8 = REEL %CJC 103I02650320 + 9 = DATE %CJC 103I02650330 + 10 = BUFFERS %CJC 103I02650340 + 11 = TYPE %CJC 103I02650350 + 12 = BLOCKSIZE %CJC 103I02650360 + 13 = MAXRECSIZE %CJC 103I02650370 + 14 = FILE INFORMATION BLOCK %CJC 103I02650371 + 15 = FILE PARAMETER BLOCK %CJC 103I02650372 + 16 = LABEL (8 WORDS ONLY) %CJC 103I02650373 + 17 = EU NUMBER (0 THRU 19) 02650374 + 18 = DISK SPEED (1=FAST,2=SLOW) 02650375 + 19 = TIMELIMIT (PROTECT FILES) 02650376 + 20 = IOSTATUS (PROTECT FILES) 02650377 + 21 = SENSITIVE 02650378 + END-OF-COMMENTS; %CJC 103I02650380 + %CJC 103I02650390 + NAME ITEM = -1; % COMP AREA FOR VALUE %CJC 103I02650400 + REAL ATTNUM = -2; % ATTRIBUTE NUMBER %CJC 103I02650500 + NAME FLOC = -3; % POINTER TO FIB %CJC 103I02650600 + REAL OPCODE = -4; % OPERATION 0=SET 1=MOVE %CJC 103I02650700 + %CJC 103I02650800 + ARRAY FPB = 3[*]; % FILE PARAMETER BLOCK %CJC 103I02650900 + %CJC 103I02651000 + ARRAY FIB[*]; %CJC 103I02651100 + ARRAY LBL[*]; %CJC 103I02651110 + LABEL EOF,IOERR, SAVEFACTOR,AREAS, %CJC 103I02651300 + AREASIZE,MFID,FID,REEL,DATE,BUFFERS, %CJC 103I02651400 + TYPE,BLOCKSIZE,MAXRECSIZE,ATTEXIT, %CJC 103I02651410 + FIBWORDS,FPBWORDS,LABELWORDS, 02651500 + EUNUM,DSKSPEED, 02651510 + TIMELIMIT,IOSTATUS, 02651520 + SENSITIVE, 02651530 + DUMMY; 02651590 + 02651595 + SWITCH ROUTINE ~ EOF,IOERR,IOERR ,SAVEFACTOR,AREAS, %CJC 103I02651600 + AREASIZE,MFID,FID,REEL,DATE,BUFFERS, %CJC 103I02651610 + TYPE,BLOCKSIZE,MAXRECSIZE, %CJC 103I02651700 + FIBWORDS,FPBWORDS,LABELWORDS, 02651710 + EUNUM,DSKSPEED, 02651720 + TIMELIMIT,IOSTATUS, 02651730 + SENSITIVE, 02651740 + IOERR; 02651799 + %CJC 103I02651800 + REAL XI,TEMP,UNITYPE; %CJC 103I02651900 + DEFINE GETFROMITEM = P(*[ITEM])#, %CJC 103I02652000 + STOREINTOITEM(STOREINTOITEM1) = %CJC 103I02652100 + P(STOREINTOITEM1,[ITEM],~)#, %CJC 103I02652150 + IOERROR(IOERROR1) = %CJC 103I02652200 + P(1,FLOC,IOERROR1,17,COM)#; %CJC 103I02652250 + %CJC 103I02652251 + COMMENT I/O ERRORS ARE AS FOLLOWS: %CJC 103I02652252 + 40 = FILE WAS OPEN WHEN SETTING THE ATTRIBUTE %CJC 103I02652253 + 41 = SETTING A READ ONLY ATTRIBUTE %CJC 103I02652254 + 42 = SETTING AN ATTRIBUTE TO AN ILLEGAL VALUE %CJC 103I02652255 + 43 = CHANGING # OF BUFFERS OF A NON-SERIAL FILE %CJC 103I02652256 + 44 = INCREASING # OF BUFFERS %CJC 103I02652257 + 45 = CHANGING BLOCKSIZE TO A VALUE WHICH IS NOT %CJC 103I02652258 + A MULTIPLE OF RECDRD SIZE %CJC 103I02652259 + 46 = CHANGE TO BLOCKSIZE WHEN FILE IS OTHER THAN %CJC 103I02652260 + TAPE, PAPER TAPE OR SERIAL DISK %CJC 103I02652261 + 47 = ACCESSING "LABEL" WHEN FILE IS NOT OPEN %CJC 103I02652262 + 48 = THIS FILE MAY NOT HAVE "TYPE" CHANGED %CJC 103I02652263 + 49 = ILLEGAL ATTNUM VALUE %CJC 103I02652264 + END OF I/O ERRORS; %CJC 103I02652290 + %CJC 103I02652300 +% S T A R T H E R E %CJC 103I02652400 + FIB ~ *FLOC; %CJC 103I02652500 + IF FIB[5].[41:2] = 0 THEN LBL ~ FLOC[1]; %CJC 103I02652550 + IF NOT FIB[4].[12:1] THEN FIB[4].[12:12] ~ %CJC 103I02652600 + ((FIB[4].[12:12] -1) | ETRLNG) & 1[36:47:1];%CJC 103I02652700 + XI ~ FIB[4].[13:11]; %CJC 103I02652800 + IF OPCODE = 0 AND FIB[5].[41:2] = 0 THEN %CJC 103I02652900 + IOERROR(40); % SET AN ATTRIBUTE ON A FILE %CJC 103I02653000 + % WHICH IS OPEN. %CJC 103I02653100 + GO TO ROUTINE[ATTNUM]; %CJC 103I02653200 +IOERR:: IOERROR(49); % ILLEGAL ATTNUM %CJC 103I02653250 + %CJC 103I02653300 +EOF:: %CJC 103I02653400 + IF OPCODE = 0 THEN IOERROR(41); %CJC 103I02653500 + % EOF IS READ ONLY %CJC 103I02653600 + STOREINTOITEM(FIB[5].[40:1]); %CJC 103I02653700 + GO TO ATTEXIT; %CJC 103I02653800 + %CJC 103I02655500 +AREAS:: %CJC 103I02655600 + IF OPCODE = 0 THEN %CJC 103I02655700 + IF (TEMP ~ GETFROMITEM) < 1 OR TEMP > 20 THEN %CJC 103I02655800 + IOERROR(42) ELSE % OK VALUES 1-20 %CJC 103I02655900 + FIB[8].[20:5] ~ TEMP ELSE %CJC 103I02656000 + STOREINTOITEM(FIB[8].[20:5]); %CJC 103I02656100 + GO TO ATTEXIT; %CJC 103I02656200 + %CJC 103I02656300 +AREASIZE:: %CJC 103I02656400 + IF OPCODE = 0 THEN %CJC 103I02656500 + IF (TEMP ~ GETFROMITEM) < 1 THEN %CJC 103I02656600 + IOERROR(42) ELSE % MUST HAVE 1 OR MORE %CJC 103I02656700 + FIB[8].[25:23] ~ TEMP ELSE %CJC 103I02656800 + STOREINTOITEM(FIB[8].[25:23]); %CJC 103I02656900 + GO TO ATTEXIT; %CJC 103I02657000 + %CJC 103I02657100 +MFID:: %CJC 103I02657200 +FID:: %CJC 103I02657300 + IF OPCODE = 0 AND FIB [5].[42:1] = 0 THEN 02657310 + IF ((UNITYPE~FPB[XI+3].[43:5])= 10 OR UNITYPE = 12 02657320 + OR UNITYPE = 13) THEN % DISK FILE IS NOT CLOSED WITH RELEASE 02657330 + IOERROR(40); % CANT CHANGE MFID/FID 02657340 + ATTNUM ~ ATTNUM - 6; %CJC 103I02657400 + IF FIB[4].[2:1] = 0 THEN % IF LABELED %CJC 103I02657405 + IF OPCODE = 1 AND FIB[5].[41:3] = 1 THEN %CJC 103I02657410 + BEGIN % IF "MOVE" AND FILE OPEN INPUT PICKUP %CJC 103I02657420 + % MFID AND ID FROM LABEL IN CASE OF "IL". %CJC 103I02657430 + STOREINTOITEM(LBL[ATTNUM + 1].[6:42]); %CJC 103I02657440 + GO TO ATTEXIT; %CJC 103I02657450 + END; %CJC 103I02657460 + IF OPCODE = 0 THEN %CJC 103I02657500 + FPB[XI + ATTNUM].[6:42] ~ GETFROMITEM ELSE %CJC 103I02657600 + STOREINTOITEM(FPB[XI + ATTNUM].[6:42]); %CJC 103I02657700 + GO TO ATTEXIT; %CJC 103I02657800 + % NOTE THAT MFID MUST BE ATTRIBUTE 6 AND FID MUST %CJC 103I02657900 + % BE ATTRIBUTE 7 TO MAKE THE ABOVE WORK. %CJC 103I02658000 + %CJC 103I02658100 +BUFFERS:: %CJC 103I02658200 + IF OPCODE = 0 THEN %CJC 103I02658300 + IF FIB[4].[27:3] ! 0 THEN IOERROR(43) ELSE %CJC 103I02658400 + % CHANGING # OF BUFFERS ON NON-SERIAL %CJC 103I02658500 + IF (TEMP ~ GETFROMITEM) > FIB[13].[1:9] THEN %CJC 103I02658600 + IOERROR(44) ELSE % INCREASING # OF BUFFERS %CJC 103I02658700 + IF TEMP < 1 THEN IOERROR(42) ELSE %CJC 103I02658800 + FIB[13].[1:9] ~ TEMP ELSE %CJC 103I02658900 + STOREINTOITEM(FIB[13].[1:9]); %CJC 103I02659000 + GO TO ATTEXIT; %CJC 103I02659100 + %CJC 103I02659200 +BLOCKSIZE:: %CJC 103I02659300 + IF OPCODE = 1 THEN %CJC 103I02659400 + BEGIN STOREINTOITEM(FIB[18].[3:15]); %CJC 103I02659500 + GO TO ATTEXIT; %CJC 103I02659600 + END; %CJC 103I02659700 + % THE FOLLOWING WILL "SET" BLOCKSIZE: %CJC 103I02659800 + IF (TEMP ~ GETFROMITEM) MOD FIB[18].[33:15] ! 0 %CJC 103I02659900 + THEN IOERROR(45); %CJC 103I02660000 + % I/O ERROR 45 IF NOT MULTIPLE OF RECORD LENGTH %CJC 103I02660100 + IF NOT ((UNITYPE ~ FPB[XI + 3].[43:5]) = 2 %CJC 103I02660200 + OR UNITYPE = 7 OR UNITYPE = 8 %CJC 103I02660300 + OR UNITYPE = 9 OR UNITYPE = 12) THEN %CJC 103I02660400 + IOERROR(46); %CJC 103I02660500 + % I/O ERROR 46 UNLESS FILETYPE IS MAGTAPE, PAPERTAPE %CJC 103I02660600 + % OR SERIAL DISK. %CJC 103I02660700 + % AT THIS POINT THE CHANGE TO BLOCKSIZE IS VALID %CJC 103I02660800 + % A CHANGE TO TECHNIQUE (FIB[5].[46:2]) AND RECORDS %CJC 103I02660900 + % PER BLOCK (FIB[11]) IS TAKEN INTO CONSIDERATION. %CJC 103I02661000 + FIB[18].[3:15] ~ TEMP; %CJC 103I02661050 + FIB[11] ~ TEMP DIV FIB[18].[33:15]; %CJC 103I02661100 + FIB[5].[46:2] ~ (IF FIB[11] = 1 THEN 0 ELSE 1); %CJC 103I02661200 + GO TO ATTEXIT; %CJC 103I02661300 + %CJC 103I02661400 +MAXRECSIZE:: %CJC 103I02661500 + IF OPCODE = 0 THEN IOERROR(41); %CJC 103I02661600 + % MAXRECSIZE IS READ ONLY %CJC 103I02661700 + STOREINTOITEM(FIB[18].[33:15]); %CJC 103I02661800 + GO TO ATTEXIT; %CJC 103I02661850 + %CJC 103I02661900 +TYPE:: %CJC 103I02661990 + IF OPCODE = 1 THEN %CJC 103I02662000 + BEGIN STOREINTOITEM(FPB[XI + 3].[43:5]); %CJC 103I02662010 + GO TO ATTEXIT; %CJC 103I02662020 + END; 02662030 + IF (TEMP ~ FPB[XI+3].[43:5]) > 9 AND TEMP < 15 02662040 + OR TEMP = 19 OR TEMP = 26 02662050 + THEN IOERROR(48); 02662060 + % I/O FRROR 48 = FILE TYPE NOT ALTERABLE 02662080 + FPB[XI + 3].[43:5] ~ TEMP ~ GETFROMITEM; %CJC 103I02662100 + IF TEMP = 0 % CARD %CJC 103I02662200 + OR TEMP > 19 AND TEMP < 26 THEN %PUNCH BACKUP %CJC 103I02662300 + IF FIB[18].[3:15] < 11 THEN GO TO ATTEXIT %CJC 103I02662400 + ELSE IOERROR(42); % AND BLOCK < 11 WORDS %CJC 103I02662500 + IF TEMP = 1 OR TEMP = 4 OR TEMP = 6 %CJC 103I02662600 + OR TEMP > 14 AND TEMP < 19 THEN % PRINTERS %CJC 103I02662700 + IF FIB[18].[3:15] < 18 THEN GO TO ATTEXIT %CJC 103I02662800 + ELSE IOERROR(42); % BLOCK < 18 WORDS %CJC 103I02662900 + IF TEMP = 2 % MAG TAPE %CJC 103I02663000 + OR TEMP = 7 % PAPER TAPE %CJC 103I02663100 + OR TEMP = 8 % PT UNLABELED %CJC 103I02663200 + OR TEMP = 9 THEN % MT UNLABELED %CJC 103I02663300 + GO TO ATTEXIT; %CJC 103I02663500 + IOERROR(42); %CJC 103I02663600 +SAVEFACTOR: REEL:: DATE : %%CJC1103I02663800 + IF OPCODE = 0 THEN % "SET" ATTRIBUTE %CJC 103I02663900 + BEGIN STREAM(K~[TEMP], L~[ITEM]); %CJC 103I02664000 + BEGIN SI ~ L; DI ~ K; DS ~ 8 DEC; %CJC 103I02664100 + END; %CJC 103I02664200 + IF ATTNUM = 9 THEN % "DATE" %CJC 103I02664300 + FPB[XI + 2].[18:30] ~ TEMP ELSE %CJC 103I02664400 + IF ATTNUM = 8 THEN % "REEL" %CJC 103I02664500 + FPB[XI + 2].[1:17] ~ TEMP ELSE %CJC 103I02664600 + FIB[4].[30:18] ~ TEMP; %CJC 103I02664800 + GO TO ATTEXIT; %CJC 103I02664900 + END; %CJC 103I02665000 + IF FIB[4].[2:1] = 1 THEN IOERROR(47); %CJC 103I02665050 + STREAM(K ~ IF FIB[5].[41:2] ! 0 THEN %CJC 103I02665100 + IF ATTNUM = 9 THEN FPB[XI+2].[18:30] ELSE %CJC 103I02665200 + IF ATTNUM = 8 THEN FPB[XI+2].[1:17] ELSE %CJC 103I02665300 + FIB[4].[30:18] ELSE %CJC 103I02665350 + IF ATTNUM = 9 THEN LBL[3].[18:30] ELSE %CJC 103I02665360 + IF ATTNUM = 8 THEN LBL[3].[1:17] ELSE %CJC 103I02665370 + FIB[4].[30:18], L ~ [ITEM]); %CJC 103I02665400 + BEGIN SI~LOC K; DI~L; DS~8 OCT; %CJC 103I02665500 + END; %CJC 103I02665600 + GO TO ATTEXIT; %CJC 103I02665700 +FIBWORDS:: %CJC 103I02665900 + IF OPCODE = 0 THEN IOERROR(41); %CJC 103I02666000 + % FIB IS READ ONLY %CJC 103I02666100 + STREAM(A~[FIB[0]], B~[ITEM]); %CJC 103I02666200 + BEGIN SI ~ A; DI ~ B; DS ~ 20 WDS; %CJC 103I02666300 + END; %CJC 103I02666400 + GO TO ATTEXIT; %CJC 103I02666500 + :: %CJC 103I02666600 +FPBWORDS %CJC 103I02666700 + IF OPCODE = 0 THEN IOERROR(41); %CJC 103I02666800 + % FPB IS READ ONLY %CJC 103I02666900 + STREAM(A~[FPB[XI]], B~[ITEM]); %CJC 103I02667000 + BEGIN SI ~ A; DI ~ B; DS ~ 5 WDS; %CJC 103I02667100 + END; %CJC 103I02667200 + GO TO ATTEXIT; %CJC 103I02667300 + %CJC 103I02667400 +LABELWORDS:: %CJC 103I02667500 + IF OPCODE = 0 THEN IOERROR(41); %CJC 103I02667600 + % LABEL IS READ ONLY %CJC 103I02667700 + IF FIB[5].[41:2] ! 0 THEN IOERROR(47); %CJC 103I02667710 + % I/O ERROR 47 = ACCESS TO LABEL WHEN FILE NOT OPEN %CJC 103I02667720 + IF FIB[4].[2:1] = 1 THEN IOERROR(47); %CJC 103I02667730 + STREAM(A~[LBL[0]], B~[ITEM]); %CJC 103I02667800 + BEGIN SI ~ A; DI ~ B; DS ~ 8 WDS; %CJC 103I02667900 + END; %CJC 103I02668000 + GO TO ATTEXIT; %CJC 103I02668100 +EUNUM:: IF FIB[5].[41:2] = 0 AND OPCODE=0 THEN GO TO ATTEXIT; 02668200 + IF OPCODE = 0 THEN 02668300 + FPB[XI+3].[18:5]:=GETFROMITEM+1 ELSE 02668400 + STOREINTOITEM(FPB[XI+3].[18:5]-1); 02668500 + GO TO ATTEXIT; 02668600 +DSKSPEED:: IF FIB[5].[41:2] = 0 AND OPCODE=0 THEN GO TO ATTEXIT; 02668700 + IF OPCODE = 0 THEN 02668800 + FPB[XI+3].[16:2]:=GETFROMITEM ELSE 02668900 + BEGIN 02669000 + TEMP := IF (TEMP:=FPB[XI+3].[16:2])=1 THEN 02669100 + 1 ELSE IF TEMP=2 THEN 2 ELSE 0; 02669200 + STOREINTOITEM(TEMP); 02669400 + END; 02669500 + GO TO ATTEXIT; 02669600 + :: 02680000 +TIMELIMIT 02680100 + IF OPCODE = 0 THEN 02680200 + $ SET OMIT = NOT SHAREDISK 02680299 + ELSE 02680500 + BEGIN 02680600 + $ SET OMIT = NOT SHAREDISK 02680699 + STOREINTOITEM(TEMP); 02680900 + END; 02681000 + GO TO ATTEXIT; 02681100 + 02681200 +IOSTATUS:: 02681300 + IF OPCODE = 0 THEN IOERROR(41); 02681400 + % IOSTATUS IS READ ONLY 02681500 + $ SET OMIT = NOT SHAREDISK 02681599 + STOREINTOITEM(TEMP); 02681800 + GO TO ATTEXIT; 02681900 +SENSITIVE: 02683000 + IF OPCODE=0 THEN 02683100 + FPB[XI+3].[15:1]:=GETFROMITEM ELSE 02683200 + BEGIN 02683300 + TEMP:=FPB[XI+3].[15:1]; 02683400 + STOREINTOITEM(TEMP); 02683500 + END; 02683600 + GO ATTEXIT; 02683700 +ATTEXIT:: 02685000 + P(XIT); 02686000 + END OF COBOLATT; 02687000 +PROCEDURE COBOLDC; % INTRINSIC NUMBER 167 02690000 + BEGIN 02690020 + REAL CODE = -1; % 0=READ,1=WRITE,2=SEEK,6=WRTBLK, 02690040 + NAME DLOC = -2; % POINTS TO BUFFER I/O DESC 02690060 + REAL NUMWDS = -3, % # WDS TO BE WRITTEN 02690080 + KEY = -4, % RANDOM RECORD ADDRESS OR CARRAGE RTN02690100 + EXPSTATAR = -4, % AREA TO EXPAND STATUS INTO 02690120 + CHNNL = -4, % LP CHANNEL SKIP 02690140 + LINES = -5, % # LINES TO BE SPACED 02690160 + TIMEOUT = -5, % UNTIL PORIION OF DATA COM 02690180 + SKIPAFT = -6 % 1=SPACE AFTER PRINT 02690200 +;INTEGER 02690220 + STATN = -6, % DATA COMM STATION (BUFFER) 02690240 + TUNR = -7; % DATA COMM TERMINAL UNIT 02690260 +%LOCALS 02690280 + REAL COBOLCONTROL=23; % FOR LINKAGE BY USE ROUTINES 02690300 + REAL COBOLINDEX =22; % FOR LINKAGE BY USE ROUTINES 02690320 + REAL DEST ; % DESTINATION IN RANDOM MOVE 02690340 + ARRAY FIB [*]; % FIB ARRAY 02690360 + REAL FILECTRL =12 ; % USED TO CALL COBOLFCR 02690380 + NAME FLOC; % POINTER TO FIB 02690400 + ARRAY FPB = 3[*]; % FILE PARAMETER BLOCK 02690420 + ARRAY H[*]; % DISK FILE HEADER 02690440 + NAME MEM = 2; % DUMMY DATA DESC 02690460 + ARRAY PGUSE=24[*]; % PROGRAM USE ROUTINES 02690480 + REAL RTOG; % 1=I/O DONE THIS ROUND 02690500 + REAL T; % TEMPORARY 02690520 + REAL TECHCOFLO; % USED FOR TECH-C OVER FLOWS 02690540 + REAL UNITYPE; % STORE UNIT TYPE FOR MANY TESTS 02690560 + REAL X1; % *DO*NOT*SEPARATE X1 & X2 THEY ARE 02690580 + REAL X2; % USED IN CONJUNCTION FOR TECHC OFLOWS02690600 + INTEGER BS = X1; % USED IN COMPUTING DISK ADDR 02690620 + INTEGER RT = X2; % USED IN COMPUTING DISK ADDR 02690640 +DEFINE 02690660 + ARROW = P(0,NOT,NUMWDS,TIP,INX,~)#, 02690680 + % THIS INSERTS THE GROUP MARK 02690700 + BADKEY = FIB[13].[19:1]#, % BAD KEY RANDOM DISK 02690720 + BCOUNT = FIB[6]#, % BLOCK COUNT 02690740 + BINARY = FIB[13].[24:1]#, % 1=BINARY,0=ALPHA 02690760 + BOUNDED = FIB[9].[2:1]#, % TRUE IF BOUNED FROM ABOVE 02690780 + BREAK = FIB[9] ! 0 # , % BREAKOUT RESTART POINT 02690800 + BREAKOUT = IF(RCOUNT MOD FIB[9])=0 THEN 02690820 + P(0,0,12,COM,DEL,DEL)#,% CALL BREAKOUT 02690840 + BUFFNUM = FIB[13].[1:9] #, % # OF BUFFS REQUSTED 02690860 + BUFFSIZE = FIB[18].[3:15]#, % BUFFER SIZE (REQUESTED) 02690880 + BUFFSZ = FIB[18][8:8:10]#, % SIZE FOR CONCATINATES 02690900 + BUFSTATUS = FIB[14] #, % STATUS AFTER SEEKDC 02690920 + BUFTOP = FIB [16]#, % USED ON I-O AND RANDOM 02690940 + BUILDSTATNWD =P((STATN~SKIPAFT)& % BUILD STATION WORD FOR DC 02690960 + P(DUP)[14:44:4]&(TUNR~TUNR)[9:44:4])#, 02690980 + CHECK(CHECK1) = IF P(DUP)!(CHECK1) THEN P(CHECK1,0,FLOC,#, 02691000 + ONERR(ONERR1) = ONERR1,17,COM,DEL,DEL,DEL,DEL); P(DEL)#, 02691020 + % THE ABOVE ARE USED ON BLOCK+REC CHKS02691040 + CLEARSTATUS =P(0,TIP,~)#, % CLEAR BUFF[0] FOR WRITE 02691060 + CLOSFANDOPEN =P(MKS,1,0,FLOC,4,FILECTRL, %CLOSE NO RWD 02691080 + MKS,FLOC,1,FILECTRL)#, % OPEN INPUT 02691100 + COUNT = FIB[12] #, % USED FOR BLOCKING TECH-A,B02691120 + DCBUFRLS = P(NUMBUF,DLOC,16, % DATA COMM BUFFER RELEASE 02691140 + 11,COM,DEL,DEL,DEL)#, 02691160 + DELAY = TIP.[20:1] #, % THIS ALLOWS ONE CYCLE DELY02691180 + DONE = TIP.[19:1] #, % 1= IO COMPLETED 02691200 + DISK = (UNITYPE=4) #, % DISK IS UNIT TYPE OF 4 02691220 + FNAM = FIB[4].[13:11]#, % FILE NAME INDEX IN FPB 02691240 + ENDFILE = FIB[5].[40:1] #, % ALREADY PASSED EOF 02691260 + ENDPROCESS = FIB[5].[39:2]#, % SEE OPTIONAL AND ENDFILE 02691280 + ENDREEL = X2 #, % USED ONLY ON READ 02691300 + EOF =((*DLOC).[27:1])#, % FIRST EOF OR EOT 02691320 + FOREVER =(NOT 0).[9:39] #, % UNTIL END TIME 02691340 + EXPAND = *P(.EXPSTATAR) #, % EXPAND CELL CHECK 02691360 + EXPANDSTATUS = P(TIP,0,0,EXPAND, % EXPAND SIATUS WORD 02691380 + 27,COM,DEL,DEL,DEL,DEL)#, 02691400 + GETSEG = P(FPB[(BS~FNAM)+3],FPB[BS],FPB[BS+1], 02691420 + T,H,4,11,COM,DEL,DEL,DEL,DEL,DEL,DEL)#, 02691440 + HASH =IF NOT DISK THEN IF FIB[8]>0 THEN 02691460 + P(MKS,FLOC,*FIB[8],3,COC)#, 02691480 + % ABOVE CALLS ROUTINES FOR HASH ACCUMULATON02691500 + HASHTOT =IF FIB[8] >0 THEN IF P(MKS,FLO0,*FIB[8],0,COC) 02691520 + THEN IOERR(18)#,% CHECKS HASH TOTALS 02691540 + HOWOPEN = FIB[5].[41:3]#, % 1=OPEN INPUT,0= OPEN OUTPT02691560 + % 1 > CLOSED 02691580 + INVALIDUSER = FIB[5]<0#, % INVALID USER NOT PARITY 02691600 + IOERR(IOERR1) = P(0,FLOC,IOERR1,17,COM,DEL,DEL,DEL)#, 02691620 + % ABOVE CALLS IOERROR ROUTINE 02691640 + IOMASK = DEST #, % HAS IOMASK TO SAVE C-REL 02691660 + LABEQ = FIB[5].[17:1] #, % LABEL EQUATED FROM DISK 02691680 + LASTDONE = FIB[13].[21:1] #, % NOT OF LAST OPERAIION DONE02691700 + LASTIO = FIB[13].[46:1]#, %LAST WAS PHYSICAL READ 02691720 + LBLPTR = FLOC[1] #, % LABEL POINTER 02691740 + LINEPRINT = UNITYPE=1 OR UNITYPE=7 OR UNITYPE=12 #, 02691760 + % 1= LP , 7 = PBT , 12 = PBD 02691780 + LSUBL = FIB [1] #, % LOWER BOUND FOR RANDOM 02691800 + LSUBU = FIB [3] #, % UPPER BOUND FOR DISK REC 02691820 + MAXR = FIB[18][8:38:10]#,% MAX REC SZ FOR CONCATS 02691840 + MAXREC = FIB[18].[33:15]#, % MAX REC SZ 02691860 + NONSTD = FIB [5].[16: 1]#, % NON-STANDARD LABELS 02691880 + NUMBUF = FIB[13].[10: 9]#, % NUMBER OF BUFFERS ASSIGNED02691900 + NUMBSPC = H[9].[43:5]#, % ROWS SPECIFIED %CJC 020 02691920 + NUMREC = FIB[11] #, % RECORDS PER BLOCK 02691940 + NXTREEL = P(MKS,2,1,FLOC,4, % THIS DOES REEL SWITCHING 02691960 + FILECTRL)#, % 02691980 + OPENIO = FIB[13].[22:1]#, % 1= OPEN INPUT-OUPUT (DISK)02692000 + OPTIONAL = FIB[ 5].[39:1]#, % OPTIONAL FILE NOT PRESENT 02692020 + PARITY = TIP.[28:1]#, % PARITY BIT ON DESC 02692040 + PRESENT =((*DLOC).[2:1])#, % CHECKS PRESENTSBIT 02692060 + PROPER =21+CODE+CODE+REVERSE#,% GENERATES PROPER IOERR 02692080 + PUNCH = UNITYPE=6#, % UNIT IS CARD PUNCH %TR 830 I02692100 + PURGE = TIMEOUT.[FF]!0#, % TRUE IF LINE TO BE PURGED 02692120 + RANDOM = TECHCOFLO#, % 1 = RANDOM DISK 02692140 + RCOUNT = FIB[7] #, % RECORD COUNT 02692160 + READER =(UNITYPE MOD 11=0)#,% 0=READER 11=PSUDOREADER 02692180 + READLBL =P(DLOC INX 0,11,11 % THIS READS THE LABEL. 02692200 + ,COM,DEL,DEL)#, % 02692220 + RECPERBLK = H[0].[30:12] #, % RECORDS PER BLOCK 02692240 + REMOTEIO =P(BUFFSIZE,DLOC, % READ & WRITE BATCH SYSTEM 02692260 + FOREVER,(IF CODE THEN LINES ELSE 1), %FOR 02692280 + KEY=0,CFX,TIP,CODE,36,COM, %REMOTE OR 02692300 + DEL,DEL,DEL,DEL,DEL,1,SUB,RTN)#,%TYPE 19 FILES 02692320 + REMOTEREAD =P(BUFFSIZE,TIP,0, % READ FOR ISS 02692340 + (-13),COM,0,RTN)#, % 02692360 + REMOTEWRIT =P(TIP,NUMWDS |8, % WRITE FOR TSS 02692380 + LINES,KEY,CFX,0,(-11),COM,DEL,RTN)#, 02692400 + RESETPARITY = DLOC[0]~TIP&0[28:28:1]#,%RESET PARIIY BII DISK02692420 + RESETREADBIT = 0[24:24:1]#, % USED TO TURN OFF READ BIT 02692440 + REVERSE = FIB[5].[44:1] #, % 1=REVERSE 02692460 + ROTATEBUF =P(NUMBUF,DLOC,13,11 % ROTATES BUFFERS WIIH 02692480 + ,COM,DEL,DEL,DEL)#,% NO I/O 02692500 + ROWLGTH = H[1]#, % ROW LGTH FROM HEADER 02692520 + SANDBKEY = FIB[13].[19:2] #, % SEEK AND BADKEY 02692540 + SEEKDC =P(0&NUMWDS[14:44:4] % DATA COM SEEK AND XIT 02692560 + &CHNNL [9:44:4],DLOC,5,11,COM,XIT)#, 02692580 + SEEKEY = FIB[13].[20:1]#, % SEEK WAS DONE 02692600 + SERIAL = FIB[4].[27:3]=0 #, % FILE ACCESS = SERIAL 02692620 + SEGPERBLK = H[0].[42:6] #, % SEGMENTS PER BLOCK 02692640 + SETPRESENTSBIT =P(TIP OR MEM ,DLOC,~)#,% SET PRESENCE BIT 02692660 + $ SET OMIT = NOT(TIMESHARING) 02692680 + SLEEP = 36 #, 02692700 + $ POP OMIT 02692720 + $ SET OMIT = TIMESHARING 02692740 + TAPEE = TIP.[7:1] #, % 1= TAPES 0=ALL ELSE 02692800 + TECH = FIB[5].[46:2] #, %TECHNIQUE 02692820 + TECHA =(FIB[5].[46:2]=1) #,% TECHNIQUL-A 02692840 + TECHC =(FIB[5].[46:2]=3) #,% TECHNIQUL-C 02692860 + TERM(TERM1) = P(1,FLOC,TERM1,17,COM)#,%TERMINATE I/O ERROR 02692880 + TIP = (*DLOC) #, % LOAD I/O DESC 02692900 + TOTREC = H[7] #, % TOTAL RECORDS ON FILE 02692920 + UNLABELED = (FIB[4].[2:1])#, % UNLABELED FILE 02692940 + UT = (FIB[4].[8:4])#, % HARDWARE TYPE 02692960 + WAITDC = P(DLOC,IOMASK, % THIS SLEEPS ON I/O COMPLE02692980 + SLEEP,COM,=)#, % AND LEAVES A FALSE ON STK02693000 + WAITIO = P(DLOC,IOMASK, % THIS SLEEPS ON I/O 02693020 + SLEEP,COM,DEL,DEL)#,% WAITING FOR A COMPLETE 02693040 + WORDSLEFT = FIB[17]#, % WORDS LEFT IN BUFFER 02693060 + WRITEAFTEREOF = FIB[13].[44:2]#, % 02693080 + WRITBACK = FIB[13].[23:1]#; % FLAG TO SAY WRITE BACK 02693100 +LABEL LPRETURN,IOUT,START,IODONE,RANDOMLBL,SEEKRTN,SETUP; 02693120 +LABEL IMPROPER,DCPRL,FIXSTATNWD,DIDDLE,DIDDLEWRT,SERIALIO,EOFSEICK; 02693140 +LABEL DATACOM,RANDOMIO; %CUBE XIX I 02693160 + START : 02693180 + FIB ~ *(FLOC ~ (NOT 2) INX DLOC); 02693200 + IOMASK ~ @2000000000; 02693220 + IF CODE THEN % DC WRITE 02693240 + BEGIN RTOG ~ (-4); % SET ALGOLIO FOR COBOLDCWR 02693260 + CLEARSTATUS; 02693280 + GO TO FIXSTATNWD; 02693300 + END; 02693320 + IF BUFSTATUS=0 THEN 02693340 + BEGIN RTOG ~ 1; % SET ALGOLIO FOR READC 02693360 + FIXSTATNWD: BUILDSTATNWD; 02693380 + GO TO DCPRL; 02693400 + END; 02693420 + IF DELAY THEN % THIS IS USED TO INHIBIT BUFFER 02693440 + DCBUFRLS; % ROTATION ON 1ST READ 02693460 + IF TIMEOUT < 0 THEN % UNTIL END READ 02693480 + BEGIN WAITDC; % THIS LEAVES 0 ON STACK 02693500 + DLOC[0]~ TIP&1[20:47:1]; % SET DELAY 02693520 + END ELSE BEGIN 02693540 + P(BUFSTATUS); % SET ALGOLIO FOR READSOUGHT 02693560 + DCPRL: P(IF TIMEOUT < 0 THEN FOREVER ELSE TIMEOUT.[CF] 02693580 + |60&(PURGE)[1:47:1],XCH,DLOC,15-RTOG,11,COM, 02693600 + DEL,DEL,DEL,1,!); %THIS LEAVES 1 OR 0 ON STACK02693620 + END; %DEPENDING ON HOW IO WAS. 02693640 + IF EXPAND ! 0 THEN EXPANDSTATUS; 02693660 + P(PRESENT,NOT,OR); %THIS ORS RESULTS OF ABOVE WITH 02693680 + SETPRESENTSBIT; % PRESENTS BIT AND IS RETURNED TO 02693700 + % PROGRAM. 02693720 + P(RTN); 02693740 + END COBOLDC; 02693760 +PROCEDURE COBOLIO; 02700000 + BEGIN 02700100 + REAL CODE = -1; % 0=READ,1=WRITE,2=SELK,6=WRTBLK, 02700200 + NAME DLOC = -2; % POINTS TO BUFFER I/O DESC 02700300 + REAL NUMWDS = -3, % # WDS TO BE WRITTEN 02700400 + KEY = -4, % RANDOM RECORD ADDRESS OR CARRAGE RTN02700500 + EXPSTATAR = -4, % AREA TO EXPAND STATUS INTO 02700600 + CHNNL = -4, % LP CHANNEL SKIP 02700700 + LINES = -5, % # LINES TO BE SPACED 02700800 + TIMEOUT = -5, % UNTIL PORTION OF DATA COM 02700900 + SKIPAFT = -6 % 1=SPACE AFTER PRINT 02701000 +;INTEGER 02701100 + STATN = -6, % DATA COMM STATION (BUFFER) 02701200 + TUNR = -7; % DATA COMM TERMINAL UNIT 02701300 + ARRAY MKSCW=-4[*]; 02701310 +%LOCALS 02701400 + REAL COBOLCONTROL=23; % FOR LINKAGE BY USE ROUTINES 02701500 + REAL COBOLINDEX =22; % FOR LINKAGE BY USE ROUTINES 02701600 + REAL DEST ; % DESTINATION IN RANDOM MOVE 02701700 + ARRAY FIB [*]; % FIB ARRAY 02701800 + REAL FILECTRL =12 ; % USED TO CALL COBOLFCR 02701900 + NAME FLOC; % POINTER TO FIB 02702000 + ARRAY FPB = 3[*]; % FILE PARAMETER BLOCK 02702100 + ARRAY H[*]; % DISK FILE HEADER 02702200 + REAL IOMASK; % TO SAVE C-REL CALL 02702250 + NAME MEM = 2; % DUMMY DAIA DESC 02702300 + ARRAY PGUSE=24[*]; % PROGRAM USE ROUTINES 02702400 + REAL RTOG; % 1=I/O DONE THIS ROUND 02702500 + REAL T; % TEMPORARY 02702600 + REAL TECHCOFLO; % USED FOR TECH-C OVER FLOWS 02702700 + REAL UNITYPE; % STORE UNIT TYPE FOR MANY TESTS 02702800 + REAL X1; % *DO*NOT*SEPARATE X1 & X2 THEY ARE 02702900 + REAL X2; % USED IN CONJUNCTION FOR TECHC OFLOWS02703000 + INTEGER BS = X1; % USED IN COMPUTING D1SK ADDR 02703100 + INTEGER RT = X2; % USED IN COMPUTING DISK ADDR 02703200 + $ SET OMIT = NOT SHAREDISK 02703204 +DEFINE 02703300 + ARROW = P(0,NOT,NUMWDS,TIP,INX,~)#, 02703400 + % THIS INSERTS THE GROUP MARK 02703500 + BADKEY = FIB[13].[19:1]#, % BAD KEY RANDOM DISK 02703600 + BCOUNT = FIB[6]#, % BLOCK COUNT 02703700 + BINARY = FIB[13].[24:1]#, % 1=BINARY,0=ALPHA 02703800 + BOUNDED = FIB[9].[2:1]#, % TRUE IF BOUNED FROM ABOVE 02703900 + BREAK = FIB[9] ! 0 # , % BREAKOUT RESTART POINT 02704000 + BREAKOUT = IF(RCOUNT MOD FIB[9])=0 THEN 02704100 + P(0,0,12,COM,DEL,DEL)#,% CALL BREAKOUT 02704200 + BUFFNUM = FIB[13].[1:9] #, % # OF BUFFS REQUSTED 02704300 + BUFFSIZE = FIB[18].[3:15]#, % BUFFER SIZE (REQUESTED) 02704400 + BUFFSZ = FIB[18][8:8:10]#, % SIZE FOR 0ONCATINATES 02704500 + BUFSTATUS = FIB[14] #, % STATUS AFTER SEEKDC 02704600 + BUFTOP = FIB [16]#, % USED ON I-O AND RANDOM 02704700 + BUILDSTATNWD =P((STATN~SKIPAFT)& % BUILD STATION WORD FOR DC 02704800 + P(DUP)[14:44:4]&(TUNR~TUNR)[9:44:4])#, 02704900 + CHECK(CHECK1) = IF P(DUP)!(CHECK1) THEN P(CHECK1,0,FLOC,#, 02705000 + ONERR(ONERR1) = ONERR1,17,COM,DEL,DEL,DEL,DEL); P(DEL)#, 02705100 + % THE ABOVE ARE USED ON BLOCK+REC CHKS02705200 + CLEARSTATUS =P(0,TIP,~)#, % CLEAR BUFF[0] FOR WRITE 02705300 + CLOSEANDOPEN =P(MKS,1,0,FLOC,4,FILECTRL, %CLOSE NO RWD 02705350 + MKS,FLOC,1,FILECTRL)#, % OPEN INPUT 02705351 + COUNT = FIB[12] #, % USED FOR BLOCKING TECH-A,B02705400 + DCBUFRLS = P(NUMBUF,DLOC,16, % DATA COMM BUFFER RELEASE 02705500 + 11,COM,DEL,DEL,DEL)#, 02705600 + DELAY = TIP.[20:1] #, % THIS ALLOWS ONE CYCLE DELY02705700 + DONE = TIP.[19:1] #, % 1= IO COMPLETED 02705800 + DISK = (UNITYPE=4) #, % DISK IS UNIT TYPE OF 4 02705900 + FNAM = FIB[4].[13:11]#, % FILE NAME INDEX IN FPB 02706000 + ENDFILE = FIB[5].[40:1] #, % ALREADY PASSED EOF 02706100 + ENDPROCESS = FIB[5].[39:2]#, % SEE OPTIONAL AND ENDFILE 02706200 + ENDREEL = X2 #, % USED ONLY ON READ 02706300 + EOF =((*DLOC).[27:1])#, % FIRST EOF OR EOT 02706400 + FOREVER =(NOT 0).[9:39] #, % UNTIL END TIME 02706500 + EXPAND = *P(.EXPSTATAR) #, % EXPAND CELL CHECK 02706600 + EXPANDSTATUS = P(TIP.0,0,EXPAND, % EXPAND STATUS WORD 02706700 + 27,COM,DEL,DEL,DEL,DEL)#, 02706800 + GETSEG = P(FPB[(BS:=FNAM)+3],FPB[BS],FPB[BS+1], 02706900 + T,H,4,11,COM,DEL,DEL,DEL,DEL,DEL,DEL)#, 02707000 + HASH =IF NOT DISK THEN IF FIB[8]>0 THEN 02707100 + P(MKS,FLOC,*FIB[8],3,COC)#, 02707200 + % ABOVE CALLS ROUTINES FOR HASH ACCUMULATON02707300 + HASHTOT =IF FIB[8] >0 THEN IF P(MKS,FLOC,*FIB[8],0,COC) 02707400 + THEN IOERR(18)#,% CHECKS HASH TOTALS 02707500 + HOWOPEN = FIB[5].[41:3]#, % 1=OPEN INPUT,0= OPEN OUTPI02707600 + % 1 > CLOSED 02707700 + INVALIDUSER = FIB[5]<0#, % INVALID USER NOI PARITY 02707800 + IOERR(IOERR1) = P(0,FLOC,IOERR1,17,COM,DEL,DEL,DEL)#, 02707900 + % ABOVE CALLS IOERROR ROUTINE 02708000 + LABEQ = FIB[5].[17:1] #, % LABEL EQUATED FROM DISK 02708200 + LASTDONE = FIB[13].[21:1] #, % NOT OF LAST OPERATION DONE02708300 + LASTIO = FIB[13].[46:1]#, %LAST WAS PHYSICAL READ 02708350 + LBLPTR = FLOC[1] #, % LABEL POINTER 02708400 + LINEPRINT = UNITYPE=1 OR UNITYPE=7 OR UNITYPE=12 #, 02708500 + % 1= LP , 7 = PBT , 12 = PBD 02708600 + LSUBL = FIB [1] #, % LOWER BOUND FOR RANDOM 02708700 + LSUBU = FIB [3] #, % UPPER BOUND FOR DISK REC 02708800 + MAXR = FIB[18][8:38:10]#,% MAX RFC SZ FOR CONCAIS 02708900 + MAXREC = FIB[18].[33:15]#, % MAX REC SZ 02709000 + NONSTD = FIB [5].[16: 1]#, % NON-STANDARD LABELS 02709100 + NUMBUF = FIB[13].[10: 9]#, % NUMBER OF BUFFERS ASSIGNED02709200 + NUMBSPC = H[9].[43:5]#, % ROWS SPECIFIED %CJC 020 02709300 + NUMREC = FIB[11] #, % RECORDS PER BLOCK 02709400 + NXTREEL = P(MKS,2,1,FLOC,4, % THIS DOES REEL SWITCHING 02709500 + FILECTRL)#, % 02709600 + OPENIO = FIB[13].[22:1]#, % 1= OPEN INPUT-OUPUT (DISK)02709700 + OPTIONAL = FIB[ 5].[39:1]#, % OPTIONAL FILE NOT PRESENT 02709800 + PARITY = TIP.[28:1]#, % PARITY BIT ON DESC 02709900 + PRESENT =((*DLOC).[2:1])#, % CHECKS PRESENTSBIT 02710000 + PROPER =21+CODE+CODE+REVERSE#,% GENERAIES PROPER IOERR 02710100 + PUNCH = UNITYPE=6#, % UNIT IS CARD PUNCH %IR 830 I02710150 + PURGE = TIMEOUT.[FF]!0#, % TRUE IF LINE TO BE PURGED 02710200 + RANDOM = TECHCOFLO#, % 1 = RANDOM DISK 02710300 + RCOUNT = FIB[7] #, % RECORD COUNT 02710400 + READER =(UNITYPE MOD 11=0)#,% 0=READER 11=PSUDOREADER 02710500 + READLBL =P(DLOC INX 0,11,11 % IHIS READS THE LABEL. 02710600 + ,COM,DEL,DEL)#, % 02710700 + RECPERBLK = H[0].[30:12] #, % RECORDS PER BLOCK 02710800 + REMOTEIO =P(BUFFSIZE,DLOC, % READ & WRITE BATCH SYSTEM 02710900 + FOREVER,(IF CODE THEN LINES ELSE 1), %FOR 02710950 + KEY=0,CFX,TIP,CODE,36,COM, %REMOTE OR 02711000 + :DEL,DEL,DEL,DEL,DEL,1,SUB,RTN)#,%TYPE 19 FILES 02711100 + REMOTEREAD =P(BUFFSIZE,TIP,1, % READ FROM TSS 02711200 + (-13),COM,1,SUB,RTN)#, % 02711300 + REMOTEWRIT =P(TIP,NUMWDS |8, % WRITE FOR TSS 02711400 + LINES,KEY,CFX,0,(-11),COM,DEL,RTN)#, 02711500 + RESETPARITY = DLOC[0]~TIP&0[28:28:1]#,%RESET PARITY BII DISK02711550 + RESETREADBIT = 0[24:24:1]#, % USED TO TURN OFF READ BIT 02711600 + REVERSE = FIB[5].[44:1] #, % 1=REVERSE 02711700 + ROTATEBUF =P(NUMBUF,DLOC,13,11 % ROTATES BUFFERS WITH 02711800 + ,COM,DEL,DEL,DEL)#,% NO I/O 02711900 + ROWLGTH = H[1]#, % ROW LGTH FROM HEADER 02712000 + SANDBKEY = FIB[13].[19:2] #, % SEEK AND BADKEY 02712100 + SEEKDC =P(0&NUMWDS[14:44:4] % DATA COM SEEK AND XIT 02712200 + &CHNNL [9:44:4],DLOC,5,11,COM,XIT)#, 02712300 + SEEKEY = FIB[13].[20:1]#, % SEEK WAS DONE 02712400 + SERIAL = FIB[4].[27:3]=0 #, % FILE ACCESS = SERIAL 02712500 + SEGPERBLK = H[0].[42:6] #, % SEGMENTS PER BLOCK 02712600 + SETPRESENTSBIT =P(TIP OR MEM ,DLOC,~)#,% SET PRESENCE BIT 02712700 + $ SET OMIT = NOT(TIMESHARING) 02712800 + SLEEP = 36 #, 02712900 + $ POP OMIT 02712950 + $ SET OMIT = TIMESHARING 02713000 + TAPEE = TIP.[7:1] #, % 1= TAPES 0=ALL ELSE 02713200 + TECH = FIB[5].[46:2] #, %TECHNIQUE 02713250 + TECHA =(FIB[5].[46:2]=1) #,% TECHNIQUL-A 02713300 + TECHC =(FIB[5].[46:2]=3) #,% TECHNIQUE-C 02713400 + TERM(TERM1) = P(1,FLOC,TERM1,17,COM)#,%TERMINATE I/O ERROR 02713500 + TIP = (*DLOC) #, % LOAD I/O DESC 02713600 + TOTREC = H[7] #, % TOTAL RECORDS ON FILE 02713700 + UNLABELED = (FIB[4].[2:1])#, % UNLABELED FILE 02713800 + UT = (FIB[4].[8:4])#, % HARDWARE TYPE 02713900 + WAITDC = P(DLOC,IOMASK, % THIS SLEEPS ON I/O COMPLE02714000 + SLEEP,COM,=)#, % AND LEAVES A FALSE ON STK02714100 + WAITIO = P(DLOC,IOMASK, % THIS SLEEPS ON I/O 02714200 + SLEEP,COM,DEL,DEL)#,% WAITING FOR A COMPLETE 02714300 + WORDSLEFT = FIB[17]#, % WORDS LEFT IN BUFFER 02714400 + WRITEPARITY = FIB[5].[3:1]#, % INDICATES FORCED REELSWITCH02714410 + WRITEAFTEREOF = FIB[13].[44:2]#, % 02714450 + WRITBACK = FIB[13].[23:1]#; % FLAG TO SAY WRITE BACK 02714500 +LABEL LPRETURN,IOUT,START,IODONE,RANDOMLBL,SEEKRTN,SETUP; 02714600 +LABEL IMPROPER,DCPRL,FIXSTATNWD,DIDDLE,DIDDLEWRT,SERIALIO,EOFSETCK; 02714700 +LABEL DATACOM,RANDOMIO,REREAD; 02714800 +SUBROUTINE GOUSE; % THIS CALLS USE ROUTINES 02714900 + BEGIN COBOLINDEX ~ T.[26:10]; 02715000 + P(MKS,T.[38:10],[COBOLCONTROL]); %THIS EXECUTES IHE 02715100 + END GOUSE; % CODE SEGMENT 02715200 +SUBROUTINE MAYBEPARITY; 02715300 + BEGIN 02715400 + SETPRESENTSBIT; 02715450 + IF (T ~RT ~PGUSE[(DISK AND OPENIO)|3+9].[1:23])!0 02715500 + THEN GOUSE ; 02715600 + IF (T~FIB [15].[1:23]) !0 THEN GOUSE; 02715700 + $ SET OMIT = NOT SHAREDISK 02715709 + IF RTOG THEN 02715800 + IF (T OR RT) = 0 THEN IOERR(19); 02715900 + END MAYBEPARITY; 02716000 +SUBROUTINE MOVREC; %THIS MOVES RECORDS TO&FROM WORK AREA 02716100 + BEGIN IF CODE ! 4 THEN 02716200 + P(BUFTOP INX(BS~(NUMWDS | (RCOUNT MOD NUMREC))+1)) 02716300 + ELSE 02716400 + P(XCH); %PICK UP VALUE LEFT FROM SERIALIO 02716500 + P(BUFTOP INX (BUFFSIZE + 2)); %FIND END OF BUFFER 02716600 + DEST := IF CODE THEN P (XCH) ELSE P; 02716700 + STREAM (FROM:=P:NUMWDS,E:=NUMWDS.[36:6], XX:=DEST); 02716800 + BEGIN 02716900 + SI~FROM; E(DS~32WDS;DS~32WDS); DS~NUMWDS WDS; 02717000 + END; 02717100 + IF CODE THEN DEST := P 02717200 + ELSE BEGIN 02717300 + P(DEL); 02717400 + IF CODE=0 AND PARITY THEN 02717500 + BEGIN 02717510 + $ SET OMIT = NOT SHAREDISK 02717519 + MAYBEPARITY; 02717530 + END; 02717540 + END; 02717600 + DLOC[0] ~ TIP& DEST[33:33:15] 02717700 + END MOVREC; 02717800 +SUBROUTINE DIDDLEREC; % THIS ROUTINE GETS THE NEXI RECORD 02717900 + BEGIN % FOR ALL SERIAL FILES (READ & WRITE)02718000 + WORDSLEFT ~ T ; 02718100 + DLOC[0] ~ NUMWDS INX TIP; 02718200 + RCOUNT ~ *P(DUP) + 1; 02718300 + IF BREAK THEN BREAKOUT; 02718400 + IF PARITY THEN MAYBEPARITY; 02718500 + END DIDDLE; 02718600 + $ SET OMIT = NOT SHARFDISK 02718604 +SUBROUTINE PREL; % THIS DOES ACTUAL I/O 02718700 + BEGIN 02718800 + IF NOT (RT LSS 0) THEN 02718900 + BEGIN 02719000 + P( TIP,DLOC); 02719100 + IF WRITBACK THEN % DO SPECIAL WRITE-IO 02719200 + BEGIN WRITBACK ~ FALSE; % TURN OFF REAO BIT 02719300 + DLOC[0]~ TIP&RESETREADBIT;% TO MAKE WRITE 02719400 + END; 02719500 + P(PRL,DEL); % DO I-O 02719600 + END; 02719700 + BCOUNT ~ *P(DUP) + (RTOG~1); %COUNT BLOCK&SET IOTOG02719900 + IF CODE = 2 THEN GO TO SEEKRTN; 02719950 + RCOUNT ~ *P(DUP) + 1; % COUNT RECS 02720000 + IF NOT DONE THEN 02720100 + $ SET OMIT = NOT SHAREDISK 02720109 + WAITIO; 02720150 + IF BREAK THEN BREAKOUT; 02720200 + END PREL; % ON NEW DESC 02720300 +SUBROUTINE REFLECTCHECKER ; % WRITE PARITY ROUTINE 02720400 + BEGIN 02720500 + IF NOT EOF THEN %TAPE WRITE PARITY OR BLANK TAPE 02720550 + BEGIN 02720570 + IF OPENIO AND DISK THEN IF(T~PGUSE[12].[1:23])!002720600 + THEN GOUSE ELSE ELSE 02720605 + IF (T~PGUSE[9].[24:24])!0 THEN GOUSE; 02720610 + IF (T~FIB[15].[1:23]) ! 0 THEN GOUSE; 02720620 + TERM(20); 02720650 + END; 02720670 + SETPRESENTSBIT; % MAKE DESC PRESENT 02720700 + IF NOT DISK THEN NXTREEL;% REEL SWITCH 02720800 + END RELECTCHECKER; 02720900 +SUBROUTINE SKIPPER; % THIS DOES SKIPPING ON LINE PRINTER 02721000 + BEGIN NUMBUF ~ 1; % INHIBIT BUFFER ROTATION 02721100 + IF CHNNL ! 0 THEN LINES := 1; 02721200 + DLOC[0] ~ TIP & 1 [18:47:1] 02721300 + &(16+CHNNL) [27:42:6]; 02721400 + FOR T~2 STEP 2 UNTIL LINES DO 02721500 + BEGIN 02721600 + PREL; 02721700 + IF NOT PRESENT THEN IF EOF THEN SETPRESENTSBIT 02721800 + ELSE REFLECTCHECKER; 02721810 + END; 02721900 + IF LINES THEN 02722000 + BEGIN 02722100 + DLOC[0]~ TIP & (2-(2|(CHNNL!0)))[27:46:2]; 02722200 + PREL; 02722300 + IF NOT PRESENT THEN IF EOF THEN SETPRESENTSBIT 02722400 + ELSE REFLECTCHECKER; 02722410 + END; 02722500 + NUMBUF ~ BUFFNUM; % RESTORE BUFFER FOR ROTATION 02722600 + END SKIPPER; 02722700 +SUBROUTINE REVREAD; % THIS DOES A READ REVERSE 02722800 + BEGIN DLOC[0] ~ FLAG (FIB [16]); 02722900 + PREL; 02723000 + FIB[16].[33:15]~ TIP; 02723100 + WORDSLEFT ~ MEM [1 INX TIP]; 02723200 + END; 02723300 +SUBROUTINE READREV; % THIS HANDLES A READ REVERSE 02723400 + BEGIN IF NOT TECHA THEN 02723500 + BEGIN 02723600 + REVREAD; 02723700 + DLOC [0] ~ NOT(WORDSLEFT-2) INX TIP; 02723800 + END 02723900 + ELSE 02724000 + IF (WORDSLEFT := T) LEQ 0 THEN 02724100 + BEGIN 02724200 + REVREAD; 02724300 + DLOC[0] ~ (NOT(MAXREC - 2 )INX TIP)&MAXR; 02724400 + END 02724500 + ELSE BEGIN 02724600 + DLOC[0]~ NOT(NUMWDS-1)INX (TIP 02724700 + &(NOT TIP) [2:28:1]); 02724800 + RCOUNT ~ *P(DUP) + 1; 02724900 + END ; 02725000 + IF NOT PRESENT THEN 02725100 + BEGIN 02725200 + SETPRESENTSBIT; 02725300 + IF EOF THEN 02725400 + BEGIN 02725500 + ENDFILE ~ TRUE; 02725600 + HASHTOT; 02725700 + P (1,RTN); 02725800 + END; 02725900 + IF (T ~PGUSE[9]&FIB[15] [25:1:23])!0 THEN GOUSE;02726000 + IF RTOG THEN IOERR (29); 02726100 + END; 02726200 + END READREV; 02726300 +SUBROUTINE ERROR; 02726400 + BEGIN IF EOF THEN 02726500 + BEGIN 02726600 + BCOUNT ~ *P(DUP) - 1; 02726700 + RCOUNT ~ *P(DUP) - 1; 02726800 + ENDFILE ~ TRUE; 02726900 + SETPRESENTSBIT; 02727000 + IF READER THEN P(1,RTN); 02727100 + IF NOT UNLABELED THEN 02727200 + BEGIN 02727300 + ENDREEL := FALSE; 02727400 + IF NOT DISK THEN 02727500 + BEGIN 02727600 + READLBL; 02727700 + STREAM(SENT~0,BC~0,RC~0,WP~0:L~LBLPTR);02727800 + BEGIN % THIS RETRIVES END02727900 + DI ~ LOC SENT;% OF REEL SENTINAL,02728000 + DI ~ DI +7; % BLOCK & REC COUNT02728100 + SI ~ L ; SI ~SI+39; 02728200 + DS ~ CHR;DS~5 OCT;DS~7 OCT; 02728300 + DI ~ DI+7; DS ~ CHR; 02728310 + END; 02728400 + IF P=1 THEN WRITEPARITY ~ TRUE; 02728410 + CHECK(RCOUNT) ONERR(16); 02728500 + CHECK(BCOUNT) ONERR(17); 02728600 + ENDREEL ~ P ; % THIS STORES SENTINAL 02728700 + IF NOT WRITEPARITY THEN 02728710 + BEGIN 02728720 + HASHTOT; 02728800 + IF (T~PGUSE[3].[ 1:23])! 0 THEN GOUSE;02728900 + IF (T~PGUSE[3].[24:24])! 0 THEN GOUSE;02729000 + END; 02729010 + END 02729100 + ELSE STREAM (RECTOT~ TOTREC + 1, 02729200 + LABL ~ LBLPTR); 02729300 + BEGIN 02729400 + SI ~ LOC RECTOT ; 02729500 + DI ~ DI + 45; 02729600 + DS ~ 7 DEC; 02729700 + END; 02729800 + IF NOT ENDREEL THEN 02729900 + IF PGUSE[BS~(DISK AND OPENIO)|9+2]!0 02730000 + THEN BEGIN 02730100 + IF (T~PGUSE[BS].[ 1:23])!0 THEN GOUSE;02730200 + IF (T~PGUSE[BS].[24:24])!0 THEN GOUSE;02730300 + END; 02730400 + IF NOT DISK THEN % END OF REEL USE ROUTINES02730500 + IF NOT WRITEPARITY THEN 02730510 + BEGIN 02730600 + IF (T~FIB [3].[ 1:23])!0 THEN GOUSE; 02730700 + IF (T~FIB [3].[24:24])!0 THEN GOUSE; 02730800 + END ; 02730900 + IF NOT ENDREEL THEN 02731000 + BEGIN 02731100 + IF (T~ FIB [2].[ 1:23])!0 THEN GOUSE; 02731200 + IF (T~ FIB [2].[24:24])!0 THEN GOUSE; 02731300 + P(1,RTN); 02731400 + END; 02731500 + END; 02731600 + IF NONSTD THEN 02731700 + BEGIN 02731800 + ENDFILE := FALSE; 02731900 + CLOSEANDOPEN; 02731950 + P(1,RTN); 02732000 + END; 02732100 + NXTREEL; 02732200 + P(DEL,DEL); %DELETE BRANCH RETURNS 02732300 + WRITEPARITY ~ FALSE; 02732310 + GO TO START; 02732400 + END; 02732500 + MAYBEPARITY; 02732600 + END ERROR; 02732700 +SUBROUTINE DISKADDRESS; %THIS COMPUTES THE DISK ADDRESS READ & WRIT02732705 + BEGIN 02732710 + IF CODE THEN RT ~ SEGPERBLK | BCOUNT; 02732715 + IF P(RT DIV ROWLGTH,DUP) GEQ NUMBSPC THEN 02732716 + BEGIN 02732717 + $ SET OMIT = NOT SHAREDISK 02732718 + P(1,RTN); 02732721 + END; 02732722 + IF (T~ P + 10) LSS 10 THEN T~10; 02732723 + IF (BS ~ H[T]) = 0 THEN 02732725 + BEGIN 02732730 + GETSEG; 02732740 + IF INVALIDUSER THEN 02732742 + BEGIN 02732744 + MAYBEPARITY; 02732746 + END; 02732748 + IF HOWOPEN!0 THEN IF NOT OPENIO THEN IOERR(22); 02732750 + BS ~ H[T]; 02732760 + END; 02732765 + STREAM( A ~ BS ~ BS + RT MOD ROWLGTH, 02732770 + B~T~BUFTOP.[CF]-(IF CODE THEN 0 ELSE WRITBACK)); 02732775 + BEGIN SI~LOC A; DS~8 DEC; END; 02732780 + $ SET OMIT = NOT SHAREDISK 02732784 + END DISKADDRESS; 02732795 +SUBROUTINE WRIT; % THIS WRITES A RECORD 02732800 + BEGIN IF TECHC THEN 02732900 + BEGIN 02733000 + ; STREAM (A ~ TIP, B ~ [X1] ); 02733100 + BEGIN 02733200 + SI ~ A; DI ~ DI +4; DS ~ 4 CHR; 02733300 + DI ~ DI +4; DS ~ 4 CHR; 02733400 + END; 02733500 + TECHCOFLO ~1&TIP[18:33:15]&NUMWDS[3:33:15]; 02733600 + NUMWDS ~ -WORDSLEFT +(WORDSLEFT ~ BUFFSIZE); 02733700 + DLOC[0]~ FLAG(FIB[16] & NUMWDS[8:38:10]);%TR840 02733750 + END 02733800 + ELSE BEGIN 02733900 + COUNT ~ NUMREC; 02734000 + NUMWDS~ (WORDSLEFT ~ BUFFSIZE) - T ; 02734100 + IF PUNCH THEN FIB[16].[32:1] ~ CHNNL; %TR 830 I02734150 + IF DISK THEN 02734200 + BEGIN 02734300 + LASTIO ~ 0; 02734350 + %THIS COMPUTES THE AMT OF DISK USED IN ROWS02734400 + IF (RCOUNT+1) DIV RECPERBLK|SEGPERBLK DIV 02734500 + ROWLGTH GEQ NUMBSPC THEN 02734600 + IF (RCOUNT + OPENIO) DIV 02734700 + RECPERBLK | SEGPERBLK DIV ROWLGTH 02734800 + GEQ NUMBSPC THEN 02734810 + BEGIN 02734820 + IF OPENIO THEN RCOUNT ~ *P(DUP) + (SERIAL);02734830 + COUNT ~ 0; 02734835 + P(1,RTN) 02734840 + END ELSE 02734900 + IF SERIAL THEN COUNT~0 ELSE BADKEY~TRUE; 02735000 + DLOC[0] ~ FLAG(BUFTOP & RESETREADBIT); 02735100 + P(CODE); 02735200 + CODE ~ 1; 02735300 + DISKADDRESS; 02735400 + CODE ~ P; 02735450 + $ SET OMIT = NOT SHAREDISK 02735599 + END 02736100 + ELSE IF LINEPRINT THEN 02736200 + BEGIN 02736300 + IF NOT SKIPAFT THEN 02736400 + BEGIN 02736500 + SKIPPER; 02736600 + LINES ~ CHNNL~ 0; 02736700 + GO TO SETUP; 02736800 + END; 02736900 + IF (CHNNL !0) OR (LINES { 2) THEN 02737000 +SETUP: DLOC[0]~ FLAG(FIB[16]&LINES [27:47:1] 02737100 + &LINES [28:46:1] 02737200 + &CHNNL [29:44:4]) 02737300 + ELSE BEGIN 02737400 + DLOC[0] ~ FLAG(FIB[16]&@20 [27:42:6]);02737500 + PREL; 02737600 + IF NOT PRESENT THEN REFLECTCHECKER; 02737650 + LINES ~ LINES - 2; 02737700 + SKIPPER; 02737800 + GO TO LPRETURN; 02737900 + END; 02738000 + END LINEPRINTER 02738100 + ELSE DLOC[0] ~ FLAG(FIB[16]&NUMWDS[8:38:10]); 02738200 + END; 02738300 + IF TAPEE THEN IF NOT BINARY THEN ARROW; 02738400 + IF DISK AND BS < 100 THEN TERM(69); 02738500 + PREL; 02738600 +LPRETURN: FIB[16].[33:15] ~ TIP; 02738700 + DLOC[0] ~ (DISK) INX TIP & MAXR; 02738800 + IF TECHCOFLO THEN 02738900 + BEGIN 02739000 + ;STREAM (I ~ [X1],A~NUMWDS~TECHCOFLO.[3:15], 02739100 + B ~ TECHCOFLO.[18:15], K ~NUMWDS.[36:6],02739200 + X ~ TIP OR MEM ); 02739300 + BEGIN 02739400 + SI ~ B; 02739500 + K(DS ~ 32 WDS;DS~ 32 WDS); 02739600 + DS ~ A WDS; 02739700 + SI ~ I; DI ~ X; SI ~SI+4; 02739800 + DS~4 CHR; SI~SI+4; DS ~ 4 CHR; 02739900 + END; 02740000 + TECHCOFLO ~ 0; 02740100 + DLOC[0] ~ NUMWDS INX TIP; 02740200 + WORDSLEFT ~ WORDSLEFT - NUMWDS; 02740300 + END; 02740400 + IF NOT PRESENT THEN %CJC 021 02740500 + BEGIN 02740510 + $ SET OMIT = NOT SHAREDISK 02740519 + REFLECTCHECKER; 02740530 + END ELSE 02740540 + RESETPARITY; 02740550 + END WRIT; 02740600 +SUBROUTINE WRITEADJUST; % THIS ADJUSTS BLOCK+REC PTRS 02740700 + BEGIN 02740800 + T := 0; 02740900 + P(NUMWDS); %SAVE OFF NUMWDS 02741000 + BCOUNT := *P(DUP) - 1; %BACK UP BECAUSE WE 02741100 + RCOUNT := *P(DUP) - 1; %WERE READING 02741200 + WRIT; 02741300 + BCOUNT := *P(DUP) + 1; %UP GRADE SO IT CAN STILL 02741400 + RCOUNT := *P(DUP) + 1; %THINK THAT WERE READING 02741500 + NUMWDS:= P; 02741600 + WORDSLEFT := *P(DUP)-NUMWDS;%DONT LOSE LAST REC 02741700 + END OF WRITEADJUST; 02741800 +SUBROUTINE REED; % THIS READS A RECORD 02741900 + BEGIN IF DISK THEN 02742000 + BEGIN LASTIO ~ 1; 02742100 + IF RCOUNT > TOTREC OR BADKEY THEN 02742200 + BEGIN 02742300 + DLOC[0]~ TIP &1[27:47:1]; 02742400 + WRITEAFTEREOF ~ 3; 02742420 + IF OPENIO AND SERIAL THEN 02742450 + RCOUNT ~ *P(DUP) +1; 02742460 + ERROR; 02742500 + END; 02742600 + DLOC[0]~ FLAG(FIB[16]); 02742700 + RT ~(BCOUNT+(T~(NUMBUF-1)))|SEGPERBLK; 02742800 + %RT = SEGMENTS READ ,T=BUFFERS 02742900 + IF (T~(T|RECPERBLK)+RCOUNT) GTR TOTREC OR 02743000 + (T >LSUBU AND BOUNDED) THEN 02743100 + BEGIN 02743200 + IF WRITBACK THEN 02743300 + BEGIN 02743400 + WRITEADJUST; 02743500 + GO TO IOUT; 02743600 + END; 02743700 + DLOC[0]~TIP&1[27:47:1]&0[2:47:1]; 02743800 + ROTATEBUF; %THIS FLAGS ERROR DESC 02743900 + RT ~ -1; % THIS INHIBITS PRL 02744000 + END 02744100 + ELSE BEGIN ; 02744200 + P(CODE); CODE ~ 0; 02744300 + DISKADDRESS; 02744400 + CODE ~ P; 02744500 + $ SET OMIT = NOT SHAREDISK 02744599 + END END 02744800 + ELSE BEGIN 02744900 + IF NUMWDS<1 AND RCOUNT >0 THEN TERM(26); 02745000 + DLOC [0] ~ FLAG (FIB[16]); 02745100 + END; 02745200 + IF CODE=2 THEN NUMBUF ~2; 02745300 + PREL; 02745400 +IODONE: WORDSLEFT ~ IF DISK THEN % DISK HAS NO SHORT BLOCKS 02745500 + IF (BS~TOTREC-RCOUNT+2)}RECPERBLK THEN 02745600 + BUFFSIZE ELSE (BS|MAXREC) ELSE 02745700 + MEM [(NOT 0 ) INX TIP]; 02745800 + IF NOT PRESENT THEN 02745900 + BEGIN 02745905 + $ SET OMIT = NOT SHAREDISK 02745909 + ERROR; 02745975 + END ELSE 02745980 + BEGIN RESETPARITY; 02745985 + $ SET OMIT = NOT SHAREDISK 02745989 + END; 02745995 + IF RANDOM THEN GO TO RANDOMLBL; 02746000 + FIB[16].[33:15] ~ TIP; 02746100 + DLOC[0]~ (DISK) INX TIP & MAXR; 02746200 + $ SET OMIT = NOT SHAREDISK 02746249 +IOUT: END REED ; 02746300 +SUBROUTINE SEEK; % THIS CHECKS FOR PRESENTS OF BLOCKS IF NOT IT READS 02746400 + BEGIN 02746500 + IF ((KEY ~ KEY-1)LSUBU AND BOUNDED)02746600 + THEN BADKEY ~ TRUE 02746700 + ELSE BEGIN 02746800 + BCOUNT ~ (RCOUNT~KEY) DIV NUMREC; 02746900 + IF BCOUNT ! COUNT THEN 02747100 + BEGIN 02747200 +REREAD: 02747250 + IF NUMBUF=2 THEN 02747300 + BEGIN 02747400 + ROTATEBUF; 02747500 + IF NOT DONE THEN 02747600 + $ SET OMIT = NOT SHAREDISK 02747609 + WAITIO; 02747650 + NUMBUF ~1; 02747700 + DLOC[0] ~ DLOC[1]; %CJC 018 02747800 + END; 02747900 + IF CODE=2 THEN DLOC[1]~ TIP; 02748000 + IF RCOUNT { TOTREC THEN REED 02748100 + ELSE IF BCOUNT =(TOTREC DIV NUMREC) THEN 02748200 + BEGIN %ABOVE CHECKS FOR LAST BLOCK02748300 + RCOUNT ~ TOTREC; 02748400 + REED; 02748500 + END; 02748600 +SEEKRTN: RCOUNT ~ KEY; 02748700 + IF RTOG THEN 02748750 + COUNT ~ BCOUNT ~ *P(DUP) - 1; 02748800 + $ SET OMIT = SHAREDISK 02748899 + END; 02748900 + $ POP OMIT 02748901 + $ SET OMIT = NOT SHAREDISK 02748909 + BADKEY ~ FALSE; 02749000 + END; 02749100 + SEEKEY ~ (CODE=2); 02749200 + IF CODE = 2 THEN P(XIT); 02749300 + END SEEK; 02749400 +%%%%%%%%%%%%%START HERE%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 02749500 + START : 02749600 + FIB ~ * (FLOC ~ (NOT 2) INX DLOC); %SET UP IDS 02749700 + IF FPB[FNAM+3].[42:6]=43 THEN % DUMMY 02749710 + IF CODE=0 THEN GO EOFSETCK ELSE 02749720 + IF P(MKSCW,TOP,XCH,DEL) THEN P(XIT) 02749730 + ELSE P(0,RTN); 02749740 + IOMASK := @2000000000; 02749800 + IF (UNITYPE~UT)=4 THEN % DISK 02749900 + BEGIN 02750000 + H ~ * [FIB[14]]; % LOAD HEADER 02750100 + IF RCOUNT > LSUBU AND BOUNDED THEN 02750200 + IF CODE THEN 02750300 + IF (RCOUNT-(OPENIO AND (SERIAL))) > LSUBU THEN 02750305 + P(1,RTN) ELSE ELSE BADKEY ~ TRUE; 02750310 + $ SET OMIT = NOT SHAREDISK 02750314 + IF CODE.[1:1] THEN 02750325 + BEGIN CODE~ABS(CODE); 02750330 + $ SET OMIT = NOT SHAREDISK 02750334 + END; 02750400 + END; 02750450 + IF NOT(ENDPROCESS=0 OR CODE) THEN GO TO EOFSETCK; 02750500 + IF CODE>1 THEN % OTHER THAN READ OR WRIT 02750600 + BEGIN 02750700 + IF CODE=2 THEN % SEEK 02750800 + BEGIN 02750900 + IF HOWOPEN>1 THEN GO TO IMPROPER; 02751000 + IF DISK THEN SEEK; 02751100 + $ SET OMIT = TIMESHARING 02751200 + TERM(28); %IMPROPER SEEK 02751400 + END; 02751500 + IF CODE=6 THEN % WRITE BLOCK 02751600 + IF DISK THEN %CUBE XIX I 02751610 + $ SET OMIT = NOT SHAREDISK 02751614 + IF OPENIO AND %CUBE XIX I 02751620 + FIB[4].[27:3] = 1 THEN %CUBE XIX I 02751630 + GO TO RANDOMIO %CUBE XIX I 02751640 + ELSE TERM(35) %CUBE XIX I 02751650 + ELSE % THEN IT IS TAPE %CUBE XIX I 02751660 + IF FIB[5].[41:4] ! 0 THEN %CUBE XIX I 02751670 + % TERM(34) WHEN WRITE BLOCK ON INPUT OR ON %CUBE XIX I 02751680 + % REVERSED OR ON UNOPENED FILE. %CUBE XIX I 02751690 + TERM(34) ELSE %CUBE XIX I 02751700 + BEGIN T := WORDSLEFT; %WRITE BLOCK 02751800 + IF T=BUFFSIZE THEN %TR 857 02751830 + P(XIT);%NULL BLOCK%TR 857 02751850 + WRIT; 02751900 + RCOUNT ~ *P(DUP) - 1; 02752000 + P(XIT); 02752100 + END WRITE BLOCK; 02752200 + TERM(25); % UN RECOGNISED CODE 02752300 + END; 02752400 + IF (1-CODE) !HOWOPEN THEN % CHECK USE VS HOW OPEN 02752500 +IMPROPER: IF HOWOPEN>1 THEN TERM (31+CODE) ELSE %CLOSED 02752600 + IF NOT OPENIO THEN TERM(PROPER); %USAGE 02752700 + IF UNITYPE =10 OR UNITYPE =13 THEN GO TO DATACOM; 02752800 + IF SERIAL THEN 02752900 + BEGIN 02753000 + T ~ WORDSLEFT -(NUMWDS~NUMWDS); %COUNT WORDLEFT02753100 + IF OPENIO THEN GO TO SERIALIO; 02753200 + IF CODE THEN % CODE=1 ON WRITE 02753300 + BEGIN 02753400 + IF NUMWDS<1 THEN TERM(36); 02753450 + HASH; 02753500 + IF TECHC THEN 02753600 + BEGIN 02753700 + IF NUMWDS > MAXREC THEN 02753800 + T ~ WORDSLEFT-(NUMWDS~MAXREC);02753900 + IF T> MAXREC THEN DIDDLEREC ELSE WRIT;02754000 + END 02754100 + ELSE IF(COUNT ~ *P(DUP) - 1)>0 THEN 02754200 + DIDDLEREC ELSE WRIT; 02754300 + IF NOT DISK THEN 02754400 + P(XIT); 02754500 + IF (T~RCOUNT-1) > TOTREC THEN TOTREC ~ T; 02754600 + P(0,RTN); 02754700 + END; 02754800 + %CODE=0 ON READ 02754900 + IF REVERSE THEN READREV ELSE 02755000 + IF TECH = 0 THEN REED ELSE %TR 899 02755050 + IF T < 1 OR BADKEY THEN REED ELSE 02755100 + IF NUMWDS<1 THEN GO TO EOFSETCK ELSE 02755200 + DIDDLEREC; 02755300 + HASH; 02755400 + P (0,RTN) 02755500 + END; 02755600 +%RANDOM AND RANDOM I-O HERE ON 02755700 +RANDOMIO: FIB[13].[44:1] ~ 0; %CUBE XIX I 02755710 + IF SEEKEY THEN KEY ~RCOUNT ELSE SEEK; 02755800 + IF BADKEY OR (KEY > TOTREC AND CODE=0) THEN 02755900 + BEGIN 02756000 + SANDBKEY ~ 0; %RESET SEEKEY&BADKEY 02756100 + IF WRITBACK THEN %RESTORE THE ADDRESS 02756110 + RCOUNT ~ ((BCOUNT ~ COUNT) | NUMREC); 02756120 + $ SET OMIT = NOT SHAREDISK 02756129 + P(1,RTN); 02756200 + END; 02756300 + IF SEEKEY THEN 02756400 + BEGIN IF NUMBUF = 2 THEN 02756500 + BEGIN ROTATEBUF; 02756600 + IF NOT DONE THEN 02756700 + $ SET OMIT = NOT SHAREDISK 02756709 + WAITIO; 02756795 + NUMBUF ~1; 02756800 + END; 02756900 + SEEKEY~FALSE; 02756910 + $ SET OMIT = NOT SHAREDISK 02756919 + RTOG~RANDOM~TRUE; 02757000 + GO TO IODONE; 02757200 + END; 02757300 +RANDOMLBL: IF INVALIDUSER THEN 02757400 + BEGIN 02757410 + MAYBEPARITY; 02757430 + END; 02757440 + T ~RANDOM ~ FALSE; 02757500 + IF CODE = 6 THEN IF WRITBACK THEN %CUBE XIX I 02757510 + BEGIN P(BCOUNT); %CUBE XIX I 02757520 + WRIT; %CUBE XIX I 02757530 + P([BCOUNT],~); %CUBE XIX I 02757540 + RCOUNT ~ KEY; %CUBE XIX I 02757550 + P(XIT); %CUBE XIX I 02757560 + END ELSE P(XIT); %CUBE XIX I 02757570 + IF WRITBACK AND CODE THEN 02757600 + IF COUNT ! BCOUNT THEN 02757700 + BEGIN 02757800 + P(NUMWDS,BCOUNT); %LEAVE BLOCK COUNT ON SIK02757900 + RCOUNT~ (BCOUNT~COUNT) | NUMREC; 02758000 + WRIT; 02758100 + P([BCOUNT],~);%PICK UP BLOCK COUNT 02758200 + NUMWDS ~ P; 02758300 + RCOUNT ~ KEY; 02758400 + END; 02758500 + MOVREC; 02758600 + IF CODE THEN % IF RANDOM WRITE THEN WRITE 02758700 + BEGIN 02758800 + IF LASTIO THEN FIB[13].[44:1] ~ 1; 02758850 + IF NOT (COUNT = BCOUNT AND WRITBACK) THEN 02758900 + BEGIN 02758960 + DISKADDRESS;%COMPUTE NEW ADDRESS 02759000 + COUNT ~ BCOUNT; 02759010 + END; 02759050 + IF KEY > TOTREC THEN TOTREC ~ KEY; 02759100 + $ SET OMIT = NOT SHAREDISK 02759104 + WRITBACK ~ TRUE; 02759165 + END; 02759200 + P(0,RTN); 02759300 +%END OF MAIN LOGIC NEXT IS SPECIAL ROUTINES 02759400 +SERIALIO: %THIS HANDLES SERIAL I-O 02759500 + IF BADKEY THEN REED; %CJC 022 02759550 + IF NOT (LASTDONE AND CODE) THEN 02759600 + IF (COUNT ~ *P(DUP) -1) > 0 THEN 02759620 + BEGIN WORDSLEFT ~ T; 02759640 + GO TO DIDDLE; 02759660 + END ELSE 02759680 + BEGIN IF BOUNDED THEN 02759700 + IF RCOUNT = LSUBL THEN 02759720 + BEGIN COUNT ~ NUMREC - (BS ~ RCOUNT MOD NUMREC); 02759740 + BCOUNT ~ *P(DUP) - (BS ! 0); 02759760 + END ELSE 02759780 + COUNT ~ NUMREC ELSE 02759800 + COUNT ~ NUMREC; 02759900 + IF CODE THEN % TWO WRITES IN A ROW 02759920 + BEGIN P(TIP INX 0); % LEAVES POINTER FOR MOVEREC 02759940 + IF RCOUNT GEQ TOTREC THEN 02759960 + BEGIN IF TECH = 0 AND WRITEAFTEREOF = 2 THEN 02759980 + BEGIN WRITEAFTEREOF ~ 1; 02760000 + RCOUNT ~ *P(DUP) +2; 02760020 + BCOUNT ~ *P(DUP) +2; 02760040 + END; 02760100 + IF RCOUNT = 0 THEN 02760200 + BEGIN P(DEL); 02760300 + RCOUNT ~ *P(DUP) +1; 02760400 + BCOUNT ~ *P(DUP) +1; 02760500 + WORDSLEFT ~ BUFFSIZE - NUMWDS; 02760600 + GO TO DIDDLEWRT; 02760700 + END ELSE 02760800 + WRITEADJUST; 02760900 + END ELSE REED; 02761000 + CODE ~ 4; MOVREC; CODE ~ 1; 02761100 + END ELSE REED; 02761200 +DIDDLEWRT: IF CODE THEN WRITBACK ~ TRUE; 02761300 + IF WRITEAFTEREOF = 3 THEN WRITEAFTEREOF ~ 2; 02761400 + RCOUNT ~ *P(DUP) -1; 02761500 +DIDDLE: MOVREC; 02761600 + RCOUNT ~ *P(DUP) +1; 02761700 + END ELSE GO TO DIDDLEWRT; 02761800 + LASTDONE ~ NOT CODE; 02761900 + IF (T ~ RCOUNT -1) > TOTREC THEN 02762000 + IF CODE THEN TOTREC ~ T % UPDATE EOF POINTER 02762100 + ELSE GO TO EOFSETCK; % PASSED EOF ON READ 02762200 + P(0,RTN); 02762300 +%END SERIAL I-O 02762400 + DATACOM: % ALL DATA COMM GOES THRU HERE 02762500 + $ SET OMIT = NOT(TIMESHARING) 02762600 + IF NOT CODE THEN REMOTEREAD; REMOTEWRIT; 02762700 + $ POP OMIT 02762750 + $ SET OMIT = TIMESHARING 02762800 +EOFSETCK: IF ENDFILE THEN TERM (15); 02765800 + ENDFILE ~ TRUE ; 02765900 + P(1,RTN); 02766000 +% END OF EOF SET CHECK 02766100 + END OF COBOL I O INTRINSICS; 02766200 +PROCEDURE FBINBACKBLOCK(FILX,DKADDR,FI,FMT,LISX,EDITCODE,EOFL,PARL) ; 02767050 +VALUE DKADDR,FI,LISX,EDITCODE,EOFL,PARL ; % INT # @160. 02767100 +REAL DKADDR,FI,LISX,EDITCODE,EOFL,PARL; ARRAY FMT[*]; NAME FILX ; 02767150 + BEGIN 02767200 + 02767250 + INTEGER BSIZE, LSTRN=19 ; 02767300 + 02767350 + REAL LISTYPE=20, ARRAYSTUFF=18, ALGOLWRITE=12, ALGOLREAD=13, T6, T7,02767400 + SELECT=14, FORTERR=24, ARY, TYPE, DBLPREC=20, INDX=EOFL, B6700,02767450 + OUT, FLG, IOINT, T1, T2, T3, T4, T5, TWDT, WH1=18, WH2=17, 02767500 + SIZE=PARL, INTINT=5, PRNTR, CKPBI, FMTWRD=CKPBI, FLB=FILX ; 02767550 + 02767600 + NAME LISTADDR, ADDR ; 02767650 + 02767700 + ARRAY AR1=LISTADDR[*], FIB[*], IOBUFF[*], TPAR=23[*], FPB=3[*] ; 02767750 + 02767800 + LABEL ALIST, BLKDTA, SEVENS, ENDALL, AWAY, SPCL1, SPCL2, DSZ, 02767850 + CMPXL, DUBEL, LOGCL, STRNL, INTREL, BDERR, ENDIT, ERROR, 02767900 + BO, BI, BO1, BI1, BDERR1, BDERR2, BI2, MAX, LOOP, STRNL1, 02767950 + PRINTER, OUTL, BKSPC, BO2, BO3, BO4, BI0, BI3, BI4, BI5, ENDG,02767975 + B6 ; 02767980 + 02768000 + SWITCH TYPL~INTREL, STRNL, INTREL, LOGCL, DUBEL, CMPXL ; 02768050 + 02768100 + DEFINE DONE = LSTRN=(-1) #, 02768150 + NOTDONE = LSTRN!(-1) #, 02768200 + KIND = FIB[4].[8:4] #, 02768250 + TAPEF = 2 #, 02768300 + REMOTEF = 13 #, 02768325 + DATACOMF = 10 #, 02768330 + INTEGR = 1 #, 02768350 + STRING = 2 #, 02768400 + REEL = 3 #, 02768450 + LOGICAL = 4 #, 02768500 + DBLPRECSN = 5 #, 02768550 + COMPLEX = 6 #, 02768600 + TYPEF = [44:4] #, 02768650 + INDXF = [18:15] #, 02768700 + SIZEF = [33:15] # ; 02768750 + 02768800 + SUBROUTINE BLANKIT ; 02768805 + BEGIN 02768810 + STREAM(C~P(XCH),A~BSIZE-1,B~P(DUP).[36:6]:D~IOBUFF) ; 02768815 + BEGIN 02768820 + SI~LOC A; 8(SI~SI-1; DS~CHR); SI~D; DS~A WDS ; 02768825 + B(DS~32WDS; DS~32WDS) ; 02768830 + END ; 02768835 + P(DEL,DEL,DEL) ; 02768840 + END OF BLANKIT ; 02768845 + 02768846 + SUBROUTINE CKPB ; 02768850 + BEGIN 02768900 + P(MKS,FLG); IF OUT THEN P(DKADDR,0,(-1)) ELSE P(CKPBI) ; 02768950 + IF (BSIZE~P(FILX,IOINT))<0 THEN GO ENDIT ; 02769000 + END OF CKPB ; 02769050 + 02769100 + SUBROUTINE IO ; 02769700 + BEGIN P(0) ; 02769750 +ENDALL: P(MKS,FLG,DKADDR); IF OUT THEN P(0,BSIZE); P(FILX,IOINT) ; 02769800 + IF P THEN 02769850 +ENDIT: BEGIN FILX[NOT 3]~FILX[NOT 4]~0; P(XIT) END ; 02769900 + CKPB ; 02769950 + END OF IO ; 02770000 + 02770050 + REAL SUBROUTINE NXTITM ; 02770100 + BEGIN 02770150 + P(IF TWDT THEN P(*[AR1[INDX.[33:7]]],INDX AND 255,CDC) 02770200 + ELSE [AR1[INDX]]) ; 02770250 + INDX~INDX+1; NXTITM~P ; 02770300 + END OF NXTITM ; 02770350 + 02770400 + SUBROUTINE GETNEXTLISTITEM ; 02770450 + BEGIN 02770500 + IF ARY THEN 02770550 + BEGIN 02770600 +ALIST: P(NXTITM) ; 02770650 + IF DBLPREC THEN IF OUT THEN WH2~*NXTITM ELSE INDX~INDX+1 ;02770700 + ARY~SIZE>INDX ; 02770750 + END 02770800 + ELSE IF TYPE=COMPLEX THEN 02770850 + BEGIN TYPE~-COMPLEX; P([LISTADDR[1]]) END 02770900 + ELSE BEGIN 02770950 + P(ARRAYSTUFF~LISTYPE~0); LISTADDR~[LISX] ; 02771000 + DBLPREC~(TYPE~LISTYPE.TYPEF)=DBLPRECSN ; 02771050 + IF ARY~ARRAYSTUFF!0 THEN 02771100 + BEGIN 02771150 + IF TYPE=COMPLEX THEN TYPE~-COMPLEX ; 02771200 + SIZE~(INDX~ARRAYSTUFF.INDXF)+ARRAYSTUFF.SIZEF ; 02771250 + P(LISTADDR~MEM[LISTADDR.[18:15]]) ; 02771300 + TWDT~NOT P(LOD,TOP); P(DEL) ; 02771350 + IF EDITCODE=2 THEN GO ENDG ELSE GO ALIST ; 02771400 + END ; 02771500 + P(DEL,[LISTADDR[0]]) ; 02771550 + IF DBLPREC THEN IF OUT THEN WH2~LISTADDR[1] ; 02771600 + END ; 02771650 + IF OUT THEN WH1~*P ELSE ADDR~P ; 02771700 +ENDG: END OF GETNEXTLISTITEM ; 02771750 + 02771800 + SUBROUTINE GETANDCHECK ; 02772050 + BEGIN 02772100 + GETNEXTLISTITEM; T1~T1-1 ; 02772150 + IF DONE THEN 02772200 +BDERR1: BEGIN P(1) ; 02772250 +BDERR: T1~P; P(MKS,T1,TYPE,T2,FLG,BSIZE,(-2),FORTERR) ; 02772425 + END ; 02772950 + FLG~FLG+1 ; 02772975 + END OF GETANDCHECK ; 02773000 + 02773050 +%*************************::CODE STARTS HERE ::************************%02773100 + 02773150 + LSTRN~CKPBI~1 ; 02773200 + IF EDITCODE=6 THEN 02773250 + BEGIN % BLOCKDATA. 02773300 +BLKDTA: GETNEXTLISTITEM; P((FMTWRD~FMT[FI~P+FI])=0) ; 02773400 + T2~FMTWRD.[18:15]; BSIZE~(FMTWRD!0)+BSIZE ; 02773425 + IF DONE THEN BEGIN IF NOT P THEN GO BDERR1; P(XIT) END ; 02773450 + FLG~FLG+1 ; 02773475 + IF P THEN BEGIN P(2); GO BDERR END; T1~FMTWRD.[33:15]-1 ; 02773500 + T3~FMT[FI~FI+1]; T4~FMT[FI+1] ; 02773550 + GO TYPL[T2-1] ; 02773600 +CMPXL: IF ABS(TYPE)!COMPLEX THEN GO BDERR2; ADDR[0]~T3 ; 02773650 + GETNEXTLISTITEM; ADDR[0]~T4; IF T1{0 THEN GO SPCL1 ; 02773700 + GETANDCHECK ; 02773725 + GO CMPXL ; 02773750 +DUBEL: IF NOT DBLPREC THEN GO BDERR2; ADDR[0]~T3; ADDR[1]~T4 ; 02773800 + IF T1 LEQ 0 THEN 02773850 +SPCL1: BEGIN P(2); GO BLKDTA END ; 02773900 + GETANDCHECK ; 02773950 + GO DUBEL ; 02774000 +LOGCL: IF TYPE!LOGICAL THEN 02774050 +BDERR2: BEGIN P(3); GO BDERR END ; 02774100 + ADDR[0]~T3; IF T1 LEQ 0 THEN GO SPCL2; GETANDCHECK ; 02774150 + GO LOGCL ; 02774200 +STRNL: T4~FI; T3~T1+1; FMTWRD~FMTWRD.[3:15] ; 02774220 +STRNL1: IF ABS(TYPL)=COMPLEX OR DBLPREC THEN GO BDERR2 ; 02774225 + ADDR[0]~FMT[FI] ; 02774230 + IF T1>0 THEN FI~FI+1 02774250 + ELSE BEGIN 02774275 + IF (FMTWRD~FMTWRD-1){0 THEN GO SPCL2; FI~T4; T1~T3 ; 02774300 + END ; 02774325 + GETANDCHECK ; 02774350 + GO STRNL1 ; 02774375 +INTREL: IF ABS(TYPE)=COMPLEX THEN GO BDERR2; P(T3,[ADDR[0]]) ; 02774400 + IF TYPE=INTEGR OR TYPE=LOGICAL THEN 02774410 + BEGIN 02774420 + IF T3>P(MAX) THEN BEGIN P(4); GO BDERR END ; 02774430 + P(ISD) ; 02774440 + END 02774450 + ELSE P(~) ; 02774460 + IF DBLPREC THEN ADDR[1]~0 ; 02774470 + IF T1 LEQ 0 THEN 02774480 +SPCL2: BEGIN P(1); GO BLKDTA END ; 02774500 + GETANDCHECK ; 02774550 + GO INTREL ; 02774600 + END OF BLOCKDATA ; 02774650 + FIB~FILX[NOT 2]; FILX[NOT 3]~PARL; FILX[NOT 4]~EOFL ; 02774700 + P(FIB[5]) ; 02774750 + IF FI<0 THEN GO OUTL; P(P.[43:2]!T1~(EDITCODE=5)+2,*P(.ALGOLREAD));02774800 + FLG~DKADDR; GO DSZ ; 02774850 +MAX::: @7777777777777 ; 02774900 +OUTL: 02774950 + OUT~1; P(P.[43:1],*P( ALGOLWRITE)) ; 02775000 + IF FLG~DKADDR<0 THEN 02775050 +DSZ: DKADDR~0 ; 02775100 + IOINT~P; IF P THEN P(MKS,0,T1,FILX,1,SELECT) ; 02775250 + IF EDITCODE=5 THEN 02775300 + BEGIN % BACKSPACE. 02775350 + IF FIB[5].[41:2]!0 THEN GO ENDIT; CKPBI~3; CKPB; IO ; 02775400 + IF NOT (FIB[FLG~0]!1 AND KIND=TAPEF) THEN GO ENDIT ; 02775450 +BKSPC: IF (*(*[FILX])).[3:15]!P(SEVENS) THEN BEGIN IO; GO BKSPC END ; 02775500 + IF (*(*[FILX])).[18:15]!P(SEVENS) THEN GO AWAY; GO ENDIT ; 02775550 + END ; 02775650 + T2~(FIB[5] AND 96)!0; CKPB; T4~(T1~KIND)=TAPEF; CKPBI~3 ; 02775675 + IF PRNTR~(T1=1 OR T1=7 OR T1=12) AND FPB[FIB[4].[13:11]+3].[43:5]<2002775700 + THEN BEGIN 02775725 + IF BSIZE>17 THEN BSIZE~17 ; 02775727 + IF T2 THEN BEGIN IOBUFF~TPAR; P(" "); BLANKIT END ; 02775730 + END 02775735 + ELSE IF T2 AND T4 THEN FIB[8].[3:15]~0 ; 02775737 + IF FIB[0]=0 THEN FIB[0]~2; T5~T1=REMOTEF OR T1=DATACOMF ; 02775740 + IF FIB[0]!2 AND T4 THEN 02775750 + BEGIN T1~4 ; 02775800 +ERROR: P(MKS,FIB[6],FILX.[33:15],T1,FORTERR) ; 02775850 + END ; 02775900 + IF T4 AND NOT FIB[13].[24:1] THEN P(MKS,(-1),FORTERR) ; 02775925 + T3~P(SEVENS) ; 02775950 + IF EDITCODE=0 THEN 02776000 + BEGIN %FNO FORMAT, NO LIST.J 02776050 + IOBUFF~*FILX ; 02776100 + IF OUT THEN 02776150 + BEGIN 02776200 + IF PRNTR THEN 02776205 + BEGIN 02776210 +PRINTER: IF NOT T2 THEN FIB[17]~*P(DUP)+BSIZE ; 02776220 + P(MKS,1,0,T2,BSIZE,FILX,ALGOLWRITE); CKPB ; 02776225 + FIB[17]~*P(DUP)-BSIZE ; 02776230 + STREAM(TPAR,BSIZE,S~*FILX) ; 02776235 + BEGIN 02776240 + SI~TPAR; DS~BSIZE WDS; DI~TPAR; 18(DS~8LIT" ") ;02776245 + END ; 02776250 + GO ENDIT ; 02776255 + END ; 02776280 + IF T5 THEN P(" ") ELSE P("0"); BLANKIT ; 02776320 + IF T4 THEN IOBUFF[0]~(NOT 0)&(BSIZE-1)[33:33:15] ; 02776550 + END 02776600 + ELSE IF T4 THEN GO BI0 ; 02776650 +AWAY: P(1); GO ENDALL ; 02776700 + END ; 02776750 + IF T4 THEN IF (*FILX).[8:10]<3 THEN P(MKS,(-4),FORTERR) ; 02776775 + GETNEXTLISTITEM; IF NOT OUT THEN GO BI0 ; 02776800 +BO: T1~T4; IOBUFF~IF PRNTR THEN TPAR ELSE *FILX ; 02776850 + IF T5 THEN BEGIN P(" "); BLANKIT END ; 02776875 +BO1:IF ARY THEN 02776880 +BO2: BEGIN WH1~1 ; 02776885 + IF P((BSIZE-T1) AND NOT DBLPREC,DUP)>SIZE-INDX THEN 02776890 + P(DEL,SIZE-INDX) ; 02776895 + IF TWDT THEN 02776900 + BEGIN 02776905 + IF P(DUP)>(WH2~256-INDX.[40:8]) THEN 02776910 + BEGIN P(DEL,WH2); WH1~0 END ; 02776915 + P(*[AR1[INDX.[33:7]]],INDX.[40:8],CDC) ; 02776920 + END 02776925 + ELSE P([AR1[INDX]]) ; 02776930 + WH2~P(XCH) ; 02776935 + STREAM(S~P:WH2,N~P(DUP).[38:4],D~[IOBUFF[T1]]) ; 02776940 + BEGIN SI~S; DS~WH2 WDS; N(DS~32WDS; DS~32WDS) END ; 02776945 + P(DEL); T1~T1+WH2 ; 02776950 + IF ARY~(INDX~INDX+WH2)SIZE-INDX THEN 02777315 + P(DEL,SIZE-INDX) ; 02777320 + IF TWDT THEN 02777325 + BEGIN 02777330 + IF P(DUP)>(WH2~256-INDX.[40:8]) THEN 02777335 + BEGIN P(DEL,WH2); WH1~0 END ; 02777340 + P(*[AR1[INDX.[33:7]]],INDX.[40:8],CDC) ; 02777345 + END 02777350 + ELSE P([AR1[INDX]]) ; 02777355 + IF (WH2~P(XCH))+(TYPE~P(IOBUFF INX T1))>HUNT(TYPE) THEN P(FLB);02777360 + STREAM(S~P:WH2,N~P(DUP).[38:4],TYPE) ; 02777365 + BEGIN SI~TYPE; DI~S; DS~WH2 WDS; N(DS~32WDS; DS~32WDS)END;02777370 + P(DEL); T1~T1+WH2 ; 02777375 + IF ARY~(INDX~INDX+WH2)" THEN GO H1 ELSE GO H2 02781950 + ELSE GO H3 ELSE GO H4 ; 02782000 + SI~SI+1 ; 02782050 + END #, 02782100 + TWOD = LISTYPE.[38:1] #, 02782150 + INDXF = [18:15] #, 02782200 + TYPEF = [44:4] #, 02782250 + SIZEF = [33:15] # ; 02782300 + 02782350 + REAL SUBROUTINE NEXTCHR ; 02782400 + BEGIN 02782450 + STREAM(C~0,BUFF:T~T1~T1-1) ; 02782500 + BEGIN DI~LOC BUFF; DI~DI-1; SI~BUFF; DS~CHR; BUFF~SI END ;02782550 + BUFF~P; NEXTCHR~C~P ; 02782600 + END OF NEXTCHR ; 02782650 + 02782700 + SUBROUTINE RNDADJ ; 02782705 + BEGIN 02782710 + E~(T4~P(XCH)+T2)+E; T2~T2-T4; T3~T3-T4; VL~1 ; 02782715 + P(XCH,TEN[T4],/,.T4,ISN,XCH) ; 02782720 + END OF RNDADJ ; 02782725 + 02782730 + SUBROUTINE CONVERT ; 02782750 + BEGIN 02782800 + STREAM(V~0,Q~0,R~0,C~0,DECPT,N~0,W~IF T1}8 THEN 8 ELSE T1:BUFF,02782850 + T~0,J~CODE!9,Z~T1<9) ; 02782900 + BEGIN 02782950 + SI~BUFF; DI~LOC T ; 02783000 + W(L3: IF SC}"0" THEN BEGIN TALLY~TALLY+1; DS~CHR END 02783050 + ELSE IF SC="." THEN 02783100 + BEGIN 02783150 + CI~CI+DECPT; GO L1; GO L2; L1: Q~TALLY; TALLY~1;02783200 + R~TALLY; DECPT~TALLY; TALLY~Q; SI~SI+1 ; 02783250 + CI~CI+Z; GO L3 ; 02783275 + END 02783300 + ELSE IF SC=" " THEN 02783350 + BEGIN 02783400 + CI~CI+J; GO L2; TALLY~TALLY+1; DS~CHR ; 02783450 + END 02783500 + ELSE IF SC="O" THEN 02783550 + BEGIN 02783600 + CI~CI+J; GO L2; DI~DI+1; SI~SI+1 ; 02783650 + TALLY~TALLY+1 ; 02783700 + END 02783750 + ELSE BEGIN 02783800 +L2: DI~LOC DECPT; DI~DI-1; DS~CHR ; 02783850 + JUMP OUT TO CV ; 02783900 + END) ; 02783950 +CV: W~SI; SI~LOC T; DI~LOC V; N~TALLY; DS~N OCT ; 02784000 + END ; 02784050 + BUFF~P; T3~P; DC10~(DECPT~P) AND CODE>10 ; 02784100 + T1~T1-((C~P(XCH))!0)-P(XCH)-T3; T4~P; P(XCH) ; 02784125 + IF COMMAS THEN IF C="," AND NOT DC10 THEN C~0 ; 02784150 + END OF CONVERT ; 02784200 + 02784250 + REAL SUBROUTINE DEBLANKDEZEROGETSGN ; 02784300 + BEGIN 02784350 + STREAM(C~0,BUFF,VL~1,SGN~0,T2~C,T1:T~T1.[36:6],HADSGN~SGN) ; 02784400 + BEGIN SI~BUFF; DI~T2 ; 02784450 + T1(IF SC!" " THEN 02784500 + IF SC>"0" THEN GO ENDS 02784550 + ELSE IF SC="-" THEN 02784600 + BEGIN 02784650 + BUFF~TALLY; TALLY~1; SGN~TALLY; TALLY~BUFF;02784700 +L1: CI~CI+HADSGN; GO L2; HADSGN~DI; VL~DI ; 02784750 + END 02784850 + ELSE IF SC!"0" THEN 02784900 + BEGIN 02784950 + IF SC!"+" THEN IF SC!"&" THEN 02785000 + BEGIN 02785050 +L2: TALLY~TALLY+1; DI~LOC BUFF; DI~DI-1 ; 02785100 + DS~CHR; ENDS: T2~TALLY ; 02785150 + JUMP OUT TO ENDS1 ; 02785200 + END ; 02785250 + GO L1 ; 02785300 + END ELSE VL~DI ; 02785350 + SI~SI+1; TALLY~TALLY+1) ; 02785400 + DI~T1; T2~TALLY ; 02785450 + T(2(32(IF SC!" " THEN 02785500 + IF SC>"0" THEN BEGIN T1~DI; JUMP OUT 3 TO ENDS1 END 02785550 + ELSE IF SC="-" THEN 02785600 + BEGIN TALLY~1; SGN~TALLY ; ; 02785650 +L3: CI~CI+HADSGN; GO L4; TALLY~0; HADSGN~TALLY;02785700 + VL~TALLY ; 02785725 + END 02785750 + ELSE IF SC!"0" THEN 02785800 + BEGIN 02785850 + IF SC!"+" THEN IF SC!"&" THEN 02785900 + BEGIN 02785950 +L4: DI~DI-8; T1~DI; DI~LOC BUFF; DI~DI-1 ;02786000 + DS~CHR; JUMP OUT 3 TO ENDS1 ; 02786050 + END ; 02786100 + GO L3 ; 02786150 + END ELSE BEGIN TALLY~0; VL~TALLY END ; 02786200 + SI~SI+1; DI~DI-8))) ; 02786250 +ENDS1: BUFF~SI ; 02786300 + END ; 02786350 + T1~P(SUB,SSP); SGN~P; VL~P; BUFF~P ; 02786400 + DEBLANKDEZEROGETSGN~(C~P)>9 ; 02786425 + END OF DEBLANKDEZEROGETSGN ; 02786450 + 02786500 + SUBROUTINE CKPB ; 02786550 + BEGIN 02786600 + MAXCHR~P(MKS,DKADDR,1,FILX,ALGOLREAD)|8 ; 02786650 + BUFF~(P(*FILX)).[33:15] ; 02786700 + END OF CKPB ; 02786750 + 02786800 + SUBROUTINE INPUT ; 02786850 + BEGIN P(0) ; 02786900 +ENDALL: P(MKS,DKADDR,CHR~0,FILX,ALGOLREAD) ; 02786950 + IF P THEN BEGIN FILX[NOT 3]~FILX[NOT 4]~0; P(XIT) END ; 02787000 + CKPB ; 02787300 + END OF INPUT ; 02787350 + 02787400 + SUBROUTINE GETNEXTLISTADDRESS ; 02787450 + BEGIN 02787500 + IF NEEDNEWLISTADDRESS THEN 02787550 + BEGIN 02787600 + IF ARY THEN 02787650 + BEGIN 02787700 +ALIST: IF TWDT THEN P(*[AR1[INDX.[33:7]]],INDX AND 255,CDC) 02787750 + ELSE P([AR1[INDX]]) ; 02787800 + ARY~(INDX~INDX+1+DBLPREC) LSS SIZE ; 02787850 + END 02787900 + ELSE IF TYPE=COMPLEX THEN 02787950 + BEGIN TYPE~-COMPLEX; P([LISTADDR[1]]) END 02788000 + ELSE BEGIN 02788050 + P(ARRAYSTUFF~0); LISTADDR~[LISX] ; 02788100 + DBLPREC~(TYPE~LISTYPE.TYPEF)=DBLPRECSN ; 02788150 + IF ARY~ARRAYSTUFF!0 THEN 02788200 + BEGIN 02788250 + IF TYPE=COMPLEX THEN TYPE~-COMPLEX ; 02788300 + SIZE~(INDX~ARRAYSTUFF.INDXF)+ 02788350 + ARRAYSTUFF.SIZEF ; 02788400 + P(LISTADDR~MEM[LISTADDR.[18:15]]) ; 02788450 + TWDT~NOT P(LOD,TOP); P(DEL) ; 02788500 + GO ALIST ; 02788550 + END ; 02788650 + P(DEL,[LISTADDR[0]]) ; 02788700 + END ; 02788750 + NEEDNEWLISTADDRESS~0; ADDR~P ; 02788800 + END ; 02788850 + IF DONE OR EDITCODE=1 THEN 02788900 +AWAY: BEGIN P(1); GO ENDALL END ; 02788950 + END OF GETNEXTLISTADDRESS ; 02788955 + 02788960 + SUBROUTINE NLE ; 02788965 + BEGIN P(XCH); GETNEXTLISTADDRESS; NEEDNEWLISTADDRESS~1 ; 02788970 + IF WH2~DBLPREC THEN WH2~ADDR[1] ; 02788975 + IF (WH1~ADDR[0])+4>P(FO94) THEN 02788980 + BEGIN IF T1 THEN VERR(P+10); P(DEL,FO94) END 02788985 + ELSE IF P(DEL,(-P(FO94)),DUP)0; DLRSGN.[18:15]~R ; 02789025 + IF CODE=29 THEN 02789030 + BEGIN P(FI+W) ; 02789035 + IF R}0 THEN P([FMT[P]],DUP,LOD,P&R[6:36:12],XCH) 02789040 + ELSE P(.FI) ; 02789045 + P(STN) ; 02789050 +OUTSUB: P(DEL,DEL); GO GETNEXTPHRASE ; 02789055 + END ; 02789060 + END ; 02789065 + IF T4~CODE=30 THEN 02789070 + BEGIN P(2); NLE; P(.T2,ISN) ; 02789075 + STREAM(P1~P:P2~P(CD),P3~P(CD1)) ; 02789080 + BEGIN SI~LOC P1; SI~SI+7; DI~LOC P2; DI~DI+1 ; 02789085 + 32(IF SC=DC THEN JUMP OUT; TALLY~TALLY+1; SI~SI-1) ; 02789090 + P1~TALLY ; 02789095 + END ; 02789100 + IF (T2 AND 63)!T2 THEN P(DEL,32) ; 02789105 + IF (CODE~P+3)>MAXCODE AND T1 THEN VERR(2) ; 02789110 + T1~CODE>4 AND T1 ; 02789115 + END ; 02789120 + T2~T1 ; 02789125 + IF P(CODE}11 AND CODE{14,FO95)=W THEN 02789130 + BEGIN P(.W,4) ; 02789135 +NLEL: NLE; P(XCH,ISD); T1~P(DUP) AND T2~T2 AND W>0 ; 02789140 + END ; 02789145 + IF D=P(FO95) THEN BEGIN P(.D,6); GO NLEL END ; 02789150 + IF CODE{4 THEN 02789155 + BEGIN IF T4 THEN W~R; 02789160 + FMTW~FMTW&(P(DUP).[41:1]+(W<0))[41:47:1]; GO HV ; 02789165 + END ; 02789170 + IF NOT T2 THEN GO OUTSUB; IF CODE=5 THEN HV: R~1 ; 02789175 + IF P(DUP) AND D<0 THEN VERR(16) ; 02789180 + IF T4 THEN IF W=P(FO94) THEN 02789185 + BEGIN IF CODE!9 THEN VERR(6); W~0 END 02789187 + ELSE IF P(DUP) AND D=P(FO94) THEN 02789190 + BEGIN P(7) ; 02789195 +VERROR: T4~P; P(MKS,CODE,R,W,D,T4,WH1,WH2,FMTW, 02789200 + (-5),FORTERR) ; 02789205 +FO94::: 4094 ; 02789210 +FO95::: 4095 ; 02789215 +CD::: @0047676321464341 ; % 0PXTAOLJ 02789220 +CD1::: @3127262524230000 ; % IGFEDC00 02789225 + END ; 02789230 + IF NOT P THEN SAVD:=D:=0 ELSE SAVD:=D; 02789235 + END OF HANDLEVARIABLES ; 02789240 + 02789250 + SUBROUTINE ADJUSTBUFF ; 02789300 + BUFF~(P(*FILX) INX T2.[33:12])&T2[30:45:3] ; 02789350 + 02789400 + SUBROUTINE SKIP ; 02789450 + IF (T1~P(XCH)) GEQ W THEN T1~W 02789500 + ELSE BEGIN T2~CHR-T1; ADJUSTBUFF END ; 02789550 + 02789600 +%************************:: CODE STARTS HERE ::************************%02789650 + 02789700 + FIB~FILX[NOT 2]; FILX[NOT 3]~PARL; FILX[NOT 4]~EOFL ; 02789750 + IF FIB[5].[43:2]!2 THEN P(MKS,0,2,FILX,1,SELECT); CKPB ; 02789800 + IF NOT(NOT(NEEDNEWLISTADDRESS~EDITCODE=3) OR FMT[FI])THEN GO FERROR;02789850 + IF FIB[0]=0 THEN FIB[0]~1 ; 02789900 + IF (LSTRN~1)!FIB[0] AND FIB[4].[8:4]=2 THEN 02789950 + BEGIN T3~4 ; 02790000 +FERROR: P(MKS,FIB[7],FILX.[33:15],T3,FORTERR) ; 02790050 + END ; 02790100 + P(0) ; 02790150 +GETNEXTPHRASE: 02790200 + R~P(FMT[FI~FI+1],DUP).[6:12]; IF (CODE~P(DUP).[1:5])=2 THEN GO HH ;02790250 + W:=P(DUP).[18:12]; SAVD:=D:=(FMTW:=P(DUP)).[30:12]; 02790255 + IF (XTRA~P(DUP) AND 63).[44:2]=0 THEN P(0,0) 02790260 + ELSE P(P((T4~P(DUP) AND 15)=12,DUP) OR T4=8,P(XCH) OR T4=4) ; 02790265 + DLRSGN~P; COMMAS~P ; 02790270 + IF P.[42:1] THEN IF (FMTW AND 3)=0 THEN HANDLEVARIABLES ; 02790275 + IF CODE=0 THEN 02790300 + BEGIN 02790350 + IF D!0 THEN BEGIN GETNEXTLISTADDRESS; INPUT END ; 02790400 + IF P(DUP).[18:15]!FI THEN P(R&FI[18:33:15]) ; 02790450 + IF P((NOT 0),XCH,INX,DUP).[33:15]=0 THEN P(DEL) ELSE FI~FI-W ; 02790500 + GO GETNEXTPHRASE ; 02790550 + END ; 02790600 + IF CODE=5 THEN CHR~0 ; 02790650 +REPEAT: 02790750 + IF CODE>5 THEN BEGIN GETNEXTLISTADDRESS; NEEDNEWLISTADDRESS~1 END ; 02790800 + IF CODE!3 AND CODE!9 THEN 02790850 + IF (CHR~CHR+W)>MAXCHR THEN GO AWAY ; 02790900 + T1~W; SGN~1; E~EXP~DECPT~T2~WH1~WH2~0 ; 02790950 + GO PHRASE[CODE-1] ; 02791000 +TT: CHR~W-1 ; 02791050 +XX: T2~CHR; ADJUSTBUFF; GO TEST1 ; 02791100 +SS: INPUT; GO TEST1 ; 02791150 +LL: IF NOT (NEXTCHR!" " OR T1=0) THEN GO LL ; 02791200 + IF NOT ((ADDR[0]~C!"F" AND C!" ") AND C!"T") THEN GO XX ; 02791250 + P("G"); IF CODE!11 THEN P(12,+); ERR(1) ; 02791300 +PP: SCALE~W&FMTW[1:41:1]; GO TEST1 ; 02791350 +OO: P(16); SKIP; P(DEBLANKDEZEROGETSGN); IF T1=0 THEN SGN~SGN OR VL ;02791400 +O1: IF (T2~C<8 OR C=" ") AND T1>0 THEN 02791450 + BEGIN 02791500 + P(NEXTCHR&P(XCH)[1:4:44]) ; 02791550 + IF T2~T1=15 AND C>3 THEN BEGIN P(DEL); GO O2 END ELSE GO O1 ; 02791600 + END ; 02791650 + IF SGN THEN P(CHS); ADDR[0]~P; IF T2 THEN GO TEST1 ; 02791700 +O2: P("O"); ERR(1+T2+T2) ; 02791750 +GG: IF TYPE=LOGICAL THEN GO LL; IF TYPE=INTEGR THEN D:=0; 02791800 + P("G"); GO EDIT ; 02791825 +EE: P("E"); GO EDIT ; 02791850 +FF: P("F"); GO EDIT ; 02791900 +DD: P("D"); GO EDIT ; 02791950 +II: P("I"); GO EDIT ; 02792000 +JJ: P("J") ; 02792050 +EDIT: 02792100 + IF DEBLANKDEZEROGETSGN THEN 02792150 + BEGIN 02792200 + IF DLRSGN THEN 02792250 + IF C="$" THEN IF NOT DEBLANKDEZEROGETSGN THEN GO E2 ; 02792300 + IF CODE=9 THEN GO GOTNUMBER ; 02792350 + IF DECPT~C="." THEN 02792355 + BEGIN IF CODE=10 THEN ERR(2); P((-T1)) ; 02792360 + STREAM(BUFF,C~0,T2~0,T1:T~T1.[36:6]) ; 02792365 + BEGIN SI~BUFF ; 02792370 + T1(IF SC!"0" THEN IF SC!" " THEN IF SC!"O" THEN 02792375 + BEGIN 02792380 + IF SC<"0" THEN 02792385 + BEGIN 02792390 + DI~LOC T2; DI~DI-1; DS~CHR; TALLY~TALLY+1 ;02792395 + END ; 02792400 + JUMP OUT TO L ; 02792405 + END ; 02792410 + TALLY~TALLY+1; SI~SI+1) ; 02792415 + DI~T1 ; 02792420 + T(2(32(IF SC!"0" THEN IF SC!" " THEN IF SC!"O" THEN 02792425 + BEGIN T1~DI ; 02792430 + IF SC<"0" THEN 02792435 + BEGIN DI~DI-8 ; 02792440 + T1~DI; DI~LOC T2; DI~DI-1; DS~CHR ; 02792445 + END ; 02792450 + JUMP OUT 3 TO L ; 02792455 + END ; 02792460 + DI~DI-8; SI~SI+1))) ; 02792465 + T1~DI ; 02792470 + L: BUFF~SI; T2~TALLY ; 02792475 + END ; 02792480 + T1~P(SUB,SSP); C~P; BUFF~P; E~P+T1 ; 02792485 + IF C<10 THEN IF T1=0 THEN GO GOTNUMBER ELSE GO E2 ; 02792490 + END ; 02792495 + IF C="*" THEN GO ASK; WH1~1-DECPT; GO EX1 ; 02792500 + END 02792505 + ELSE IF T1=0 THEN BEGIN SGN~VL OR SGN; GO GOTNUMBER END ; 02792510 +E2: IF CODE{10 THEN DECPT~1; VL~0 ; 02792550 +BACK: 02792600 + CONVERT ; 02792650 + IF T3=0 THEN IF COMMAS THEN GO CHKC ELSE P(DEL) 02792700 + ELSE BEGIN 02792750 + IF VL THEN 02792900 + BEGIN 02792905 + IF DC10 THEN P(T4) 02792910 + ELSE 02792915 +ADJT: P(T3) ; 02792920 + E~E+P; P(DEL) ; 02792925 + END 02792930 + ELSE BEGIN 02792950 + IF DC10 THEN E~E+T4-T3 ; 02793000 + IF (T2~T2+T3)>T3 THEN 02793050 + BEGIN 02793075 + IF T2<12 THEN GO STNRD ; 02793100 + IF DBLPREC THEN 02793125 + BEGIN 02793130 + IF P(DUP)=0 THEN IF T2>23 OR T1=0 OR C!0 THEN 02793135 + BEGIN VL~1; T2~T2-T3; GO ADJT END ; 02793140 + IF T2>23 THEN 02793160 + BEGIN 02793165 + P((TEN[T2-T3-12]|P(MAX)P(MAX))-12); RNDADJ ; 02793195 +STNRD: P(TEN[T3]|WH1,+) ; 02793200 + END ; 02793205 + END ; 02793245 + WH1~P ; 02793250 + END ; 02793300 +CHKC: IF NOT (C!0 OR T1{0) THEN GO BACK ; 02793350 + END ; 02793400 + IF C>9 AND CODE!9 THEN ELSE GO GOTNUMBER ; 02793450 +EX1:IF NOT (C!"E" AND C!"D") THEN GO EX ; 02793500 + IF C="+" OR C="-" THEN BEGIN P(T2,T1+1); SKIP; T2~P END 02793510 + ELSE IF C!"@" OR HOLTOG THEN GO ERR1 ; 02793515 +EX: IF CODE=10 THEN ERR(2); P(SGN); SGN~EXP~1 ; 02793550 + IF DEBLANKDEZEROGETSGN THEN 02793600 + BEGIN P(DEL) ; 02793650 +ERR1: IF C="*" THEN GO GOTNUMBER; ERR(1+(CODE=10 AND C=".")) ; 02793700 + END ; 02793750 + P(DECPT); DECPT~1; CONVERT; IF SGN THEN P(SSN); E~(T4~P)+E ; 02793800 + DECPT~P; SGN~P; IF C>9 THEN GO ERR1 ; 02793850 +E1: IF T1>0 THEN IF NEXTCHR>9 AND C!" " THEN GO ERR1 ELSE GO E1 ; 02793900 +GOTNUMBER: 02793950 + IF CODE>10 THEN 02794000 + BEGIN IF NOT DECPT THEN E~E-D; IF NOT EXP THEN E~E-SCALE END 02794050 + ELSE IF CODE=9 THEN 02794100 + IF (CHR~CHR+W-T1-(C>9)+(C=C~"*"))>MAXCHR THEN GO AWAY ; 02794150 + IF ABS(E)>44 THEN 02794200 + BEGIN IF E+T2>68 THEN GO ERR3; IF E<(-68) THEN E~-68 END ; 02794250 + IF DBLPREC THEN 02794300 + BEGIN 02794350 + P(WH2,WH1) ; 02794400 + IF E!0 THEN P(TEN[ABS(E)+69],TEN[ABS(E)],IF E>0 THEN P(DLM) 02794450 + ELSE P(DLD)) ; 02794500 + END 02794550 + ELSE BEGIN 02794600 + P(WH1); IF E!0 THEN P(TEN[ABS(E)],IF E>0 THEN P(|) ELSE P(/));02794650 + END ; 02794700 + IF SGN THEN P(SSN) ; 02794750 + IF TYPE=INTEGR OR TYPE=LOGICAL THEN 02794800 + BEGIN 02794850 + IF P(DUP)>P(MAX) THEN BEGIN P(DEL); ERR3: ERR(3) END ; 02794900 + P([ADDR[0]],ISD); GO ASK ; 02794950 + END ; 02795000 + P([ADDR[0]],~); IF DBLPREC THEN P([ADDR[1]],~) ; 02795350 +ASK:P(DEL); IF C!"*" THEN GO TEST1; GO XX ; 02795400 +MAX::: @0007777777777777 ; 02795410 +HH: P(DEL); IF (CHR~CHR+R)>MAXCHR THEN GO AWAY ; 02795450 + STREAM(BUFF:R,S~R.[36:6],HOLTOG,Q~[FMT[FI]]) ; 02795460 + BEGIN 02795500 + DI~DI+3; SI~BUFF; CI~CI+HOLTOG; GO L1; R(H(A,B,C,D)) ; 02795550 + GO L2; L1: GO L3; L2: S(2(32(H(W,X,Y,Z)))); GO L4; L3: 02795600 + DS~R CHR; S(DS~32 CHR; DS~32 CHR); L4: BUFF~SI ; 02795650 + END ; 02795700 + FI~FI+(R+2).[36:9]; BUFF~P; GO GETNEXTPHRASE ; 02795750 +CC: 02795800 +AA: P(6); SKIP; ADDR[0]~IF P(CODE=6,DUP) THEN P(BLANKS) ELSE 0 ; 02795850 + STREAM(T~IF P THEN 2 ELSE 8-T1:BUFF,T1,HOLTOG,ADDR) ; 02795900 + BEGIN 02795950 + DI~DI+T; SI~BUFF; CI~CI+HOLTOG; GO L1; T1(H(A,B,C,D)) ; 02796000 + GO L2; L1: DS~T1 CHR; L2: T~SI ; 02796050 + END ; 02796100 + BUFF~P ; 02796150 +TEST1: 02796200 + IF (R~R-1)>0 THEN GO REPEAT ; 02796250 + IF (XTRA AND 3)=0 THEN GO GETNEXTPHRASE ; 02796300 + P(XTRA); XTRA~W~0 ; 02796350 + IF P(DUP) THEN BEGIN W~P.[42:5]; CODE~4; GO REPEAT END ; 02796400 + CODE~1; R~P.[42:4]; GO SS ; 02796450 +BLANKS:::" " ; 02796500 +ERROR: 02796700 + P(FILX[NOT 3]); FILX[NOT 3]~FILX[NOT 4]~0; P(MKS,9,INTINT) ; 02796750 + T3~P(DEL); T2~P ; 02796800 +P(MKS,T2,T3,W,SAVD,CODE,TYPE,CHR-T1,FIB[7],BUFF,FMT[FI],DLRSGN,(-3), 02796850 + FORTERR) ; 02796900 + END OF FTINTFIX ; 02797450 +PROCEDURE FTINT ; % 050 02800000 + BEGIN 02800100 +COMMENT FILX FILE TOP IO DESCRIPTOR 02800200 + FMTA FORMAT OR NAMELIST OR 0 02800300 + LISX ACCIDENTAL ENTRY DESC. OR 0 02800400 + EDITCODE 0 NO FORMAT, NO LIST 02800500 + 1 FORMAT, NO LIST 02800600 + 2 NO FORMAT, LIST 02800700 + 3 FORMAT, LIST 02800800 + 4 NAMELIST 02800900 + 5 BACKSPACE 02801000 + 6 BLOCKDATA; 02801100 +REAL PARL = -1, 02801200 + EOFL = -2, 02801300 + FORTERR = 24, 02801301 + EDITCODE = -3, 02801400 + LISX = -4, 02801500 + FI = -6, 02801600 + DKADR = -7, 02801700 + READINT = 13, 02801900 + SELECT = 14; 02802000 +ARRAY FMTA = -5[*]; 02802100 +NAME FILX = -8, 02802160 + MEM = 2; 02802190 +INTEGER LSTRN = 19; 02802300 +REAL LISTYPE = 20, 02802400 + ARRAYSTUFF = 18, 02802500 + HOLTOG = 21; 02802600 +ARRAY TEN = 22[*], 02802900 + FIB[*]; 02803000 +NAME LISTADR; 02803100 +REAL BUFF , % FIRST BUFFER POSITION 02803200 + BSIZE , % ARGUMENTS 02803300 + NBC, 02803400 + NFCI, 02803600 + DH1, 02803700 + WH1 , % 02803800 + WH2; 02803900 +NAME W1; 02804100 +ARRAY IOBUFF = BUFF[*]; 02804200 +INTEGER RPT, 02804300 + W , % FIELD 02804400 + BDTYP = W, 02804500 + WT , % WIDTH 02804600 + T1 , % 02804700 + D , % DEC- 02804800 + DT , % IMAL P- 02804900 + D1 , % LA- 02805000 + D2 , % CE- 02805100 + CNT, 02805200 + EXP , % EXPONENT 02805300 + EXPSGN, 02805400 + CODE , % EDITING FUNCTION 02805500 + SKP , % REDUNDANT POSITIONS 02805600 + NCR , % CURRENT BUFFER POSITION 02805700 + LCR , % BUFFER SIZE IN CHARACTERS 02805800 + CHR , % CURRENT CHAR FROM FORMAT 02805900 + PRCW , % PAREN CONTROL WORD 02805910 + PCT, % PAREN COUNTER 02805920 + PS ; % SCALE FACTOR 02806000 +BOOLEAN DONETOG , % RETURN AFTER WRITE 02806100 + SGN , % SIGN 02806200 + FRTOG, % TRUE IF NUM HAS FRACTION PART 02806210 + LGTG, 02806300 + DTAERR, 02806400 + FMERRTOG , % FORMAT ERROR 02806500 + GTOG, 02806700 + CTOG; 02806800 +DEFINE LOGV = 4#, 02806900 + INTEGV =1#, 02807000 + STRGV =2#, 02807100 + DBLV = 5#, 02807300 + CMPLXV = 6#, 02807400 + NUM = 2#, 02807600 + GTYPE = 1#, 02807800 + FTYPE = 2#, 02807900 + ETYPE = 3#, 02808000 + DTYPE = 4#, 02808100 + ITYPE = 5#, 02808200 + LTYPE = 6#, 02808300 + ATYPE = 7#, 02808400 + OTYPE = 8#, 02808500 + KIND = (FIB[4].[8:4])#, 02808600 + TAPEF =2#, 02808800 + MAX = @7777777777777#, 02809000 + ELMTYP = LISTYPE . [44:4]#, 02809100 + DLN = (LISTYPE.[44:4] = DBLV)#, 02809200 + CMPLX = (LISTYPE.[44:4] = CMPLXV)#, 02809300 + TWOD = LISTYPE.[38:1]#, 02809400 + LPPS = 15:30:18#, 02809500 + LPPR = [15:18]#, 02809600 + RPTF = [33:15]#, 02809700 + NORF = (P(XCH,DUP) < 0)#, 02809800 + PCF = [9:6]#, 02809810 + ENDLIST = (LSTRN = (-1))#, 02809900 + SIZEF = [33:15]#, 02810000 + BASEF = [18:15]#; 02810100 +LABEL TYPERR, FMCYC, FMERR, MON, FNOL, FMTLST, FRMTCD, NFPH, 02810300 + STRT,REPEAT,LPAR,RTPAR,SLASH,STRING,TFMT,FMTERR, 02810400 + CL1,CL2,CL3,CL4,SCAL,HOL,SKIP,CL3A,STRA,TFMA,TIX, 02810500 + G,F,E,DC,I,L,A,O,COMM, 02810600 + LL,LL1; 02810900 +COMMENT * * * * * START OF SUBROUTINE DECLARATIONS * * * * * * * * ; 02811000 +SUBROUTINE CKPB; 02811100 +BEGIN COMMENT INITIALIZE FILE AND ACQUIRE RECORD SIZE; 02811200 +LCR ~ 8|(BSIZE ~ P(MKS,DKADR,1,FILX,READINT)); 02811300 +BUFF ~ (*FILX).[33:15]; NCR ~ 0; 02811400 +END CKPB; 02811500 +SUBROUTINE READS; 02811600 +BEGIN 02811700 +P(MKS,DKADR,0,FILX,READINT); 02811800 +IF DONETOG THEN P(XIT); 02811900 + $ SET OMIT = NOT(TIMESHARING) 02811909 +IF KIND!10 THEN %%% THEN NOT FROM DATA COM. 02811910 + IF NOT ((*FILX).[19:1]) THEN P(FILX,@2000000000,36,COM,DEL,DEL); 02811920 + $ SET OMIT = TIMESHARING 02811950 +CKPB; 02812200 +END READS; 02812300 +LABEL NFCL; 02812400 +REAL SUBROUTINE NFC; 02812500 +BEGIN 02812600 +NFCL: 02812700 +WHILE NFCI.[45:3] < 2 DO NFCI ~ NFCI + 1; 02812800 +STREAM(P1 ~ 0:P2 ~FMTA[NFCI.[30:15]],P3 ~ NFCI.[45:3]); 02812900 + BEGIN DI ~ LOC P1; DS ~ 7 LIT "0"; 02813000 + SI ~ LOC P2; SI ~SI + P3;DS ~ CHR; 02813100 + SI ~ SI - 1; DI ~ DI - 1; 02813200 + IF SC < "A" THEN 02813300 + BEGIN 02813400 + IF SC = "@" THEN DS ~ LIT """ ELSE 02813500 + IF SC = "[" THEN DS ~ LIT ")" ELSE 02813600 + IF SC = "%" THEN DS ~LIT "("; 02813700 + END; 02813800 + END; 02813900 +NFCI ~ NFCI + 1; IF (CHR ~ P) = " " THEN IF NOT LGTG THEN GO NFCL; 02814000 +NFC ~ CHR; 02814100 +END NFC; 02814200 +SUBROUTINE PUT; 02814300 +BEGIN ; 02814400 + WHILE NFCI.[45:3] <2 DO NFCI ~ NFCI + 1; 02814500 + STREAM(P2~[FMTA[NFCI.[30:15]]],P3~NFCI.[45:3],P4~NBC); 02814600 + BEGIN 02814700 + SI ~ LOC P4; SI~SI+1; 02814800 + DI ~ P2; DI~DI+P3; DS~CHR; 02814900 + END; 02815000 + NFCI ~ NFCI +1; 02815100 +END PUT; 02815200 +SUBROUTINE GET; 02815300 + BEGIN; 02815400 + STREAM(P1 ~[NBC]:P2 ~ BUFF); 02815500 + BEGIN 02815600 + SI ~ P2; DI ~ P1; 02815700 + DI ~ DI+1; DS ~ CHR; 02815800 + P1 ~ SI; 02815900 + END; 02816000 + BUFF ~ P; 02816100 + IF HOLTOG THEN 02816200 + BEGIN 02816300 + IF (NBC ~ NBC.[6:6]) = "#" THEN NBC ~ "=" ELSE 02816400 + IF NBC = "&" THEN NBC ~ "+" ELSE 02816500 + IF NBC = "%" THEN NBC ~ "(" ELSE 02816600 + IF NBC = "[" THEN NBC ~ ")" ELSE 02816700 + IF NBC = "@" THEN NBC ~ """; 02816800 + NBC ~ 0&NBC[6:42:6]; 02816900 + END; 02817000 + END GET; 02817100 + % PARAMETERS FOR LIST CONTROL 02817200 +BOOLEAN ATOG,TWDT; 02817300 +ARRAY AR1 = LISTADR[*]; 02817400 + INTEGER INDX, SIZE; 02817600 +LABEL RTNLST,SRT; 02817700 +DEFINE NXTELM = IF TWDT THEN P(*[AR1[INDX.[33:7]]],INDX.[40:8],CDC) 02817800 + ELSE [AR1[INDX]]#; 02817900 +SUBROUTINE GETLIST; 02818000 + BEGIN 02818100 + SRT: IF ATOG THEN 02818200 + BEGIN 02818300 + W1 ~ NXTELM; 02818400 + INDX ~ INDX + DLN; 02818500 + IF (INDX ~INDX + 1) } SIZE THEN 02818600 + BEGIN 02818700 + ARRAYSTUFF ~ 0; 02818800 + ATOG ~ FALSE; 02818900 + END; 02819000 + GO TO RTNLST; 02819100 + END; 02819200 + IF CTOG THEN 02819300 + BEGIN % IMAGINARY PART OF COMPLEX 02819400 + W1 ~ [LISTADR[1]]; 02819500 + CTOG ~ FALSE; 02819600 + GO TO RTNLST; 02819700 + END; 02819800 + P(0); 02819900 + LISTADR ~ [LISX]; 02820000 + IF ARRAYSTUFF ! 0 THEN 02820100 + BEGIN 02820200 + ATOG ~ TRUE; 02820300 + TWDT~NOT P(*(LISTADR~MEM[LISTADR.[18:15]]),TOP); P(DEL) ; 02820400 + SIZE~(INDX~ARRAYSTUFF.BASEF)+ARRAYSTUFF.SIZEF ; 02820700 + GO TO SRT; 02820800 + END; 02820900 + W1 ~ [LISTADR[0]]; 02821000 + P(DEL); 02821100 + CTOG ~ CMPLX; 02821200 + RTNLST: 02821300 + END GETLIST; 02821400 +SUBROUTINE FORMATCONTROL; 02821500 +BEGIN 02821600 + STRT: 02821700 + W~D~CODE~SKP~RPT~0; 02821800 + SGN~DONETOG~FMERRTOG~FALSE; 02821900 + CL1: COMMENT CHECK FOR SINGLE CHARACTER EDITING TYPES; 02822000 + IF NFC{9 THEN GO TO REPEAT; % MUST BE REPEAT FIELD 02822100 + IF CHR="(" THEN GO LPAR; 02822200 + IF CHR=")" THEN GO RTPAR; 02822300 + IF CHR="/" THEN GO SLASH; 02822400 + IF CHR=""" THEN GO STRING; 02822500 + IF CHR="T" THEN GO TO TFMT; 02822600 + SGN~(CHR="-") & (CHR="+")[2:47:1]; 02822690 + IF SGN THEN 02822700 + BEGIN 02822800 + IF NFC{9 THEN GO TO REPEAT 02822900 + ELSE GO TO FMTERR; 02823000 + END; 02823100 + IF CHR="," THEN GO TO STRT; 02823200 + RPT~1; 02823300 + CL2: COMMENT TYPES WHICH MAY HAVE REPEAT FIELDS; 02823400 + IF SGN THEN RPT~-RPT; 02823500 + IF CHR="P" THEN GO TO SCAL; 02823600 + IF RPT<0 OR SGN.[2:1] THEN GO TO FMTERR; 02823700 + IF CHR="(" THEN GO TO LPAR; 02823800 + IF CHR="H" THEN GO TO HOL; 02823900 + IF RPT=0 THEN RPT~1; 02824000 + IF CHR = "X" THEN GO TO SKIP; 02824100 + CL3: COMMENT TYPES WHICH HAVE W FIELDS; 02824200 + IF CHR="I" THEN CODE ~ ITYPE ELSE 02824300 + IF CHR="A" THEN CODE ~ ATYPE ELSE 02824400 + IF CHR="L" THEN CODE ~ LTYPE ELSE 02824500 + IF CHR="O" THEN CODE ~ OTYPE; 02824600 + IF CODE } ITYPE THEN GO TO CL3A; 02824700 + CL4: COMMENT TYPES WITH W AND D FIELDS; 02824800 + IF CHR="D" THEN CODE ~ DTYPE ELSE 02824900 + IF CHR="E" THEN CODE ~ ETYPE ELSE 02825000 + IF CHR="F" THEN CODE ~ FTYPE ELSE 02825100 + IF CHR="G" THEN CODE ~ GTYPE ELSE 02825200 + GO TO FMTERR; 02825300 + CL3A: COMMENT DEVELOP VALUE OF W FIELD; 02825400 + IF NFC>9 THEN GO TO FMTERR; 02825500 + W~CHR; 02825600 + WHILE NFC{9 DO W~10|W+CHR; % CONVERT TO OCTAL 02825700 + NFCI~NFCI-1; 02825800 + IF W>63 THEN GO TO FMTERR; 02825900 + IF CODE}ITYPE THEN GO TIX; 02826000 + COMMENT DEVELOP D FIELD; 02826100 + IF NFC!"." THEN GO TO FMTERR; 02826200 + IF NFC>9 THEN GO TO FMTERR; 02826300 + D~CHR; 02826400 + WHILE NFC{9 DO D~10|D+CHR; % CONVERT TO OCTAL 02826500 + NFCI~NFCI-1; 02826600 + GO TO TIX; 02826700 + LPAR: COMMENT GENER1TE PAREN CONTROL WORD; 02826800 + IF PCT!0 AND RPT=0 THEN RPT~1 ; 02826810 + T1 ~ RPT&NFCI[LPPS]&(RPT{0)[1:47:1]; 02826900 + IF PCT { 1 THEN PRCW ~ T1 & PCT[9:42:6]; 02826910 + P(T1,XCH); PCT ~ PCT + 1; 02826920 + GO TO STRT; 02827000 + RTPAR: COMMENT POINT AT LEFT PAR IF REPEAT NOT EXAUSTED; 02827100 + IF NORF THEN 02827200 + BEGIN % NO REPEAT FIELD 02827300 + DONETOG ~ ENDLIST ; 02827400 + READS; 02827500 + IF (PCT ~ PCT - 1) { 0 THEN IF PRCW.PCF !0 02827510 + THEN BEGIN P(XCH,PRCW); PCT ~ 2 END ELSE PCT ~ 1; 02827520 + END ELSE 02827600 + BEGIN 02827700 + IF (RPT~P(DUP).RPTF) { 1 02827800 + THEN BEGIN P(DEL);PCT ~ PCT - 1; GO TO STRT END 02827900 + ELSE P(RPT - 1,CCX); 02828000 + END; 02828100 + NFCI~P(DUP).LPPR; % RESET TO LEFT PAREN 02828200 + P(XCH); 02828300 + GO TO STRT; 02828400 + REPEAT: COMMENT CONVERT REPEAT FIELD TO OCTAL IN RPT; 02828500 + RPT~CHR; 02828600 + WHILE NFC{9 DO RPT~ 10|RPT+CHR; 02828700 + GO TO CL2; 02828800 + SLASH: % READ NEXT RECORD 02828900 + READS; 02829000 + GO TO STRT; 02829100 + STRING: % MOVE STRING FROM BUFFER TO FORMAT 02829200 + LGTG ~ TRUE; 02829300 + GET; PUT; NCR ~ NCR + 1; 02829400 + STRA: IF NFC = """ THEN BEGIN LGTG ~ FALSE; GO TO STRT END; 02829500 + IF (NCR ~ NCR + 1) > LCR THEN GO TO FMTERR; 02829600 + GET; NFCI ~ NFCI-1; 02829700 + PUT; 02829800 + GO TO STRA; 02829900 + TFMT: COMMENT SET BUFFER TO CHARACTER POSITION INDICATED BY FIELD 02830000 + FOLLOWING "T"; 02830100 + IF (RPT~NFC)>9 THEN GO TO FMTERR; 02830200 + WHILE NFC{9 DO RPT~10|RPT+CHR; 02830300 + IF RPT>LCR THEN GO TO FMTERR; 02830400 + NCR~RPT-1; 02830500 + TFMA: BUFF ~ ((*FILX) INX NCR.[33:12])&NCR[30:45:3]; 02830600 + GO TO STRT; 02830700 + SCAL: COMMENT SCALE FACTOR OF P PHRASE; 02830800 + PS~RPT; 02830900 + GO TO STRT; 02831000 + HOL: COMMENT HOLLERITH STRING; 02831100 + WHILE RPT > 0 DO 02831200 + BEGIN 02831300 + IF (NCR ~ NCR + 1) > LCR THEN GO TO FMTERR; 02831400 + GET; PUT; 02831500 + RPT~RPT-1; 02831600 + END; 02831700 + GO TO STRT; 02831800 + SKIP: COMMENT X PHRASE; 02831900 + IF (NCR ~ NCR+RPT) > LCR THEN GO TO FMTERR; 02832000 + GO TO TFMA; 02832100 + FMTERR: FMERRTOG~TRUE; 02832200 +TIX: 02832300 +END FORMATCONTROL; 02832400 +SUBROUTINE SKPC; % SKIPS CURRENT CHARACTERS. PUTS NEXT CHARACTERS 02832500 + BEGIN; % IN NBC 02832600 + STREAM(P1~BUFF,P2~0:P3~0); 02832700 + BEGIN 02832800 + SI ~ P1; SI ~ SI +1; P1 ~ SI; 02832900 + DI ~ LOC P2; DI ~ DI+7; DS ~ CHR; 02833000 + END; 02833100 + NBC ~ P; BUFF ~ P; 02833200 + WT ~ WT -1; 02833300 + END SKPC; 02833400 +SUBROUTINE SCALE; 02833500 + BEGIN 02833600 + IF (D1 ~ D1 + CNT) > 11 02833700 + THEN DOUBLE(WH1,WH2,TEN[CNT],TEN[69+CNT],|, 02833800 + DH1,0,+,~,WH1,WH2) 02833900 + ELSE WH1~ WH1|TEN[CNT]+DH1; 02834000 + DH1 ~ 0; 02834100 + END SCALE; 02834200 +SUBROUTINE GETNUM; 02834300 + BEGIN; 02834400 + STREAM(P1~BUFF,P2~IF WT { 8 THEN WT ELSE 8,P3~0,P4~0:P5~0); 02834500 + BEGIN 02834600 + SI~P1; DI~LOC P5 ; 02834700 + P2(IF SC<"0" THEN 02834800 + IF SC!" " THEN 02834900 + IF SC="O" THEN BEGIN DS~LIT"0"; SI~SI+1;GO L END02835000 + ELSE JUMP OUT ; 02835100 + DS~CHR ; 02835200 +L: TALLY~TALLY+1) ; 02835300 + P2~TALLY; P1~SI ; 02835400 + SI~LOC P5; DI~LOC P3; DS~P2 OCT ; 02835500 + SI~P1 ; 02835600 + DI ~ LOC P4; DI ~ DI + 7; DS ~ CHR; 02835700 + END; 02835800 + NBC ~ P; DH1 ~ P; CNT ~ P; BUFF ~ P; 02835900 + END GETNUM; 02836000 +SUBROUTINE GETSIGN; 02836100 + BEGIN; 02836200 + STREAM(P1~BUFF,P2~(IF WT > 63 THEN 63 ELSE WT),P3~0,P4~(-1): 02836300 + P5~0); 02836310 + BEGIN 02836400 + SI~P1; DI~P2 ; 02836500 + P2(DI~DI-8; IF SC!" " THEN JUMP OUT TO L1; 02836600 + SI ~ SI + 1; TALLY ~ TALLY + 1); 02836700 + P1 ~ SI; 02836800 + GO TO RTNSGN; 02836900 + L1: IF SC } "0" THEN 02837000 + BEGIN 02837100 + L3: P2 ~ TALLY; 02837200 + L2: P5(P1~DI; TALLY~P2; P1(IF SC!" " THEN 02837300 + JUMP OUT; TALLY~TALLY+1; SI~SI+1); P2~TALLY); P1~SI ; 02837310 + DI ~ LOC P4; DS ~ 7 LIT "0"; DS ~ CHR; 02837400 + GO TO RTNSGN; 02837500 + END; 02837600 + IF SC ="." THEN GO TO L3; 02837700 + TALLY ~ TALLY+1; 02837800 + P2 ~ TALLY; 02837900 + TALLY~1; P5~TALLY ; 02838000 + IF SC="-" THEN TALLY~1 ELSE IF SC="+" THEN TALLY~0 ELSE 02838010 + IF SC="&" THEN TALLY~0 ELSE 02838020 + BEGIN TALLY~0; P1~TALLY; GO TO RTNSGN END; 02838025 + P3 ~ TALLY; 02838100 + SI ~ SI + 1; 02838200 + GO TO L2; 02838300 + RTNSGN: 02838400 + END; 02838500 + NBC~P; SGN~P; CNT~P; DTAERR~((BUFF~P)=0) ; 02838600 + END GETSIGN; 02838700 + LABEL NCRTN,BLSGN; 02838800 +SUBROUTINE NUMCONVERT; 02838900 + BEGIN 02839000 + DH1 ~ D1 ~ D2 ~ EXP ~ EXPSGN ~ FRTOG ~0; 02839100 + WH1 ~ WH2 ~ -0; 02839200 + WT ~ W; 02839300 + BLSGN: 02839310 + GETSIGN; 02839400 + IF DTAERR THEN GO TO NCRTN ; 02839405 + WT ~ WT - CNT; IF NBC <0 % BLANK FIELD 02839500 + THEN IF WT { 0 THEN GO TO NCRTN ELSE GO TO BLSGN; 02839510 + IF NBC { 9 THEN 02839600 + BEGIN 02839700 + GETNUM; WH1 ~ DH1; 02839800 + IF (WT ~ WT - (D1 ~ CNT)) { 0 THEN GO TO NCRTN; 02839900 + WHILE NBC{9 OR NBC=" " OR NBC="O" DO 02840000 + BEGIN 02840100 + GETNUM; SCALE; 02840200 + IF (WT ~ WT-CNT) { 0 THEN GO TO NCRTN; 02840300 + END; 02840400 + END; 02840500 + IF NBC = "." THEN 02840600 + BEGIN 02840700 + FRTOG ~ TRUE; 02840800 + SKPC; 02840900 + IF WT{0 THEN GO TO NCRTN ; 02840910 + WHILE NBC{9 OR NBC=" " OR NBC="O" DO 02841000 + BEGIN 02841100 + GETNUM; SCALE; 02841200 + D2 ~ D2 + CNT; 02841300 + IF ( WT ~ WT - CNT) { 0 THEN GO TO NCRTN; 02841400 + END; 02841500 + END; 02841600 + IF NBC = "D" OR NBC = "E" THEN SKPC; 02841700 + IF WT{0 THEN BEGIN DTAERR~TRUE; GO TO NCRTN END ; 02841710 + IF (NBC="+") OR (NBC="&") OR (NBC=" ") OR (EXPSGN~(NBC="-")) 02841800 + THEN SKPC; 02841900 + IF WT{0 THEN BEGIN DTAERR~TRUE; GO TO NCRTN END ; 02841910 + IF NBC > "9" THEN DTAERR ~ TRUE 02842000 + ELSE 02842100 + BEGIN 02842200 + GETNUM; 02842300 + EXP ~ IF EXPSGN THEN (-DH1) ELSE DH1; 02842400 + IF (WT~WT-CNT) { 0 THEN GO TO NCRTN; 02842500 + WHILE WT > 0 DO SKPC; 02842600 + END; 02842700 + NCRTN: 02842800 + IF WH1 = 0 THEN IF SGN THEN WH1 ~ -0; 02842900 + END NUMCONVERT; 02843000 +SUBROUTINE CONVERT; 02843100 + BEGIN 02843200 + WH1 ~ WH2 ~ 0; WT ~W; 02843300 + GO TO P(CODE,DUP,ADD); 02843400 + GO TO FMERR; 02843500 + GO TO G; GO TO F; GO TO E; GO TO DC; GO TO I; 02843600 + GO TO L; GO TO A; GO TO O; 02843700 + O: % OCTAL CONVERSION 02843800 + IF W>16 THEN SKP~W-WT~16 ELSE SKP~0 ; 02843900 + STREAM(P1~BUFF,P2~0:P3~[WH1],P4~SKP,P5~WT,P6~16-WT,P7~0, 02843950 + P8~(WT=16)) ; 02844000 + BEGIN 02844050 + SI~P1; P1~TALLY; TALLY~1 ; 02844100 + P4(IF SC=" " THEN SI~SI+1 ELSE IF SC="0" THEN SI~SI+1 02844150 + ELSE BEGIN P7(JUMP OUT 2 TO MAST); IF SC="-" THEN 02844200 + P2~TALLY ELSE IF SC!"+" THEN IF SC!"&" THEN JUMP OUT 02844250 + TO MAST; P7~TALLY; SI~SI+1 END) ; 02844300 + P8(IF SC>"3" THEN JUMP OUT TO MAST) ; 02844350 + DI~P3; P6(SKIP 3 DB) ; 02844400 + GO TO FAST; MAST: GO TO LAST; FAST: 02844410 + P5(IF SC>"0" THEN IF SC<"8" THEN BEGIN SKIP 3 SB; P7~ 02844450 + TALLY; 3(IF SB THEN DS~SET ELSE DS~RESET; SKIP SB) END02844500 + ELSE JUMP OUT TO LAST ELSE BEGIN IF SC!" " THEN 02844550 + IF SC!"0" THEN BEGIN P7(JUMP OUT 2 TO LAST); 02844600 + IF SC="-" THEN P2~TALLY ELSE IF SC!"+" THEN 02844650 + IF SC!"&" THEN JUMP OUT TO LAST; P7~TALLY END ; 02844700 + SI~SI+1; SKIP 3 DB END) ; 02844750 + P1~SI ; 02844800 + LAST: 02844850 + END ; 02844900 + SGN~P; IF (DTAERR~((BUFF~P)=0)) THEN GO TO COMM ; 02844950 + W1[0]~IF SGN THEN -WH1 ELSE WH1 ; 02844975 + GO TO COMM; 02845000 + A: % ALPHA CONVERSION 02845100 + IF W > 6 THEN SKP ~ W - (WT ~ 6); 02845200 + WH1 ~ " "; 02845300 + STREAM(P1~ BUFF:P2~[WH1],P3~SKP,P4~WT,P5~HOLTOG); 02845400 + BEGIN 02845500 + SI ~ P1; SI ~ SI + P3; 02845600 + DI ~ P2; DI ~ DI + 2; 02845700 + P5(P4( 02845800 + IF SC } "A" THEN DS ~ CHR ELSE 02845900 + IF SC = "#" THEN BEGIN SI ~ SI +1; DS ~ LIT "=" END ELSE 02846000 + IF SC = "&" THEN BEGIN SI ~ SI +1; DS ~ LIT "+" END ELSE 02846100 + IF SC = "%" THEN BEGIN SI ~ SI +1; DS ~ LIT "(" END ELSE 02846200 + IF SC = "[" THEN BEGIN SI ~ SI +1; DS ~ LIT ")" END ELSE 02846300 + IF SC = "@" THEN BEGIN SI ~ SI +1; DS ~ LIT """ END ELSE 02846400 + DS ~ CHR;); 02846500 + JUMP OUT TO X;); 02846600 + DS ~ P4 CHR; 02846700 + X: 02846800 + P1 ~ SI; 02846900 + END; 02847000 + BUFF ~ P; 02847100 + W1[0] ~ WH1; 02847200 + GO TO COMM; 02847300 + L: % LOGICAL CONVERSION 02847400 + STREAM(P1~BUFF,P2~0:P3~0,P4~W); 02847500 + BEGIN 02847600 + SI ~ P1; P3~SI; 02847700 + P4(IF SC!" " THEN JUMP OUT 1 TO LL ELSE SI ~ SI + 1); 02847800 + TALLY ~ 0; GO TO LL1; 02847900 + LL: IF SC = "T" THEN TALLY ~ 1; 02848000 + LL1: P2 ~ TALLY; SI ~ P3; SI ~ SI +P4; P1 ~ SI; 02848100 + END; 02848200 + W1[0] ~ P; 02848300 + BUFF ~ P; 02848400 + DTAERR ~ ELMTYP ! LOGV; 02848600 + GO TO COMM; 02848700 + I: % INTEGER CONVLRSION 02848800 + NUMCONVERT; 02848900 + IF (DTAERR ~ DTAERR OR D2!0 OR EXP ! 0 02849000 + OR ELMTYP = DBLV OR WH1 > MAX) 02849100 + THEN GO TO COMM; 02849200 + W1[0] ~ IF SGN THEN -WH1 ELSE WH1; 02849300 + GO TO COMM; 02849400 + % SINGLE PRECISION 02849500 + E: % E FORMAT 02849600 + F: % F FORMAT 02849700 + G: % G FORMAT 02849800 + NUMCONVERT; 02849900 + IF (W1[0] ~ WH1) = 0 THEN GO TO COMM; 02850000 + IF (DTAERR ~ DTAERR OR ELMTYP = LOGV 02850100 + OR ELMTYP = INTEGV OR ELMTYP= DBLV) 02850200 + THEN GO TO COMM; 02850300 + T1 ~ (IF EXP ! 0 THEN EXP ELSE -PS) 02850400 + -(IF FRTOG THEN D2 ELSE D); 02850500 + IF T1<(-68) THEN T1~-68 ELSE IF DTAERR~T1>68 THEN GO TO COMM ; 02850510 + IF D1 GTR 11 THEN IF T1 GTR 0 THEN 02850530 + DOUBLE(WH1,WH2,TEN[ T1],TEN[69+T1],TIMES,:=,WH1,WH2) 02850535 + ELSE 02850540 + BEGIN 02850545 + DOUBLE(WH1,WH2,TEN[-T1],TEN[69-T1],/,:=,WH1,WH2); 02850550 + IF WH2 > @0007777777777700 THEN 02850553 + IF WH1.[3:6] LSS 14 THEN WH1 := WH1 + 1 & WH1[2:2:7]; 02850555 + END 02850560 + ELSE 02850565 + WH1 ~ IF T1} 0 THEN WH1|TEN[T1] 02850600 + ELSE WH1/TEN[-T1]; 02850700 + W1[0] ~ IF SGN THEN -WH1 ELSE WH1; 02850800 + GO TO COMM; 02850900 + DC: % DOUBLE PRECISION CONVERSION 02851000 + NUMCONVERT; 02851100 + IF WH1 = 0 THEN BEGIN W1[0] ~ W1[1] ~WH1; GO TO COMM END; 02851200 + IF (DTAERR ~ DTAERR OR ELMTYP ! DBLV ) 02851300 + THEN GO TO COMM; 02851400 + T1 ~ (IF EXP ! 0 THEN EXP ELSE -PS) 02851500 + -(IF FRTOG THEN D2 ELSE D); 02851600 + IF T1<(-68) THEN T1~-68 ELSE IF DTAERR~T1>68 THEN GO TO COMM ; 02851610 + IF SGN THEN WH1 ~ - WH1; 02851700 + IF T1 > 0 THEN 02851800 + DOUBLE(WH1,WH2,TEN[ T1],TEN[69+T1],|,~,W1[0],W1[1]) 02851900 + ELSE 02852000 + DOUBLE(WH1,WH2,TEN[-T1],TEN[69-T1],/,~,W1[0],W1[1]); 02852100 + COMM: 02852200 +END CONVERT; 02852300 +COMMENT * * * * * * * * * * END OF DECLARATIONS * * * * * * * * * * * ; 02862200 +IF EDITCODE!1 AND EDITCODE!3 THEN 02862210 + BEGIN P(MKS) ; 02862220 + IF EDITCODE!6 THEN P(FILX,DKADR); P(FI,FMTA,*P(.LISX)) ; 02862230 + IF EDITCODE=4 THEN P(EOFL,INTCALL(PARL,@154)) 02862250 + ELSE P(EDITCODE,EOFL,INTCALL(PARL,@160)) ; 02862260 + P(XIT) ; 02862270 + END ; 02862300 + FILX[NOT 4] ~ EOFL; FILX[NOT 3] ~ PARL; 02862310 +FIB ~ FILX[NOT 2]; % OPEN FILE IF NOT OPEN 02862400 +IF FIB[5].[43:2] ! (T1 ~ 2 + (EDITCODE=5)) THEN 02862500 + P(MKS,0,T1,FILX,1,SELECT); 02862600 + CKPB; ARRAYSTUFF~0; 02862705 + IF FIB[0] = 0 THEN 02862706 + FIB[0] ~ 1 + (EDITCODE =0 OR EDITCODE =2) 02862708 + ELSE 02862710 + IF FIB[0] !1 + (EDITCODE =0 OR EDITCODE = 2) 02862712 + THEN P(MKS,FIB[6],FILX.[33:15],4,FORTERR); 02862714 +IF EDITCODE=1 THEN GO FNOL; GO FMTLST ; 02862800 + FNOL: 02863900 + LSTRN~-1; 02864000 + GO TO FRMTCD; 02864100 + FMTLST: 02882900 + LSTRN ~ 1; 02883000 + CTOG ~ DONETOG ~ FALSE; 02883100 + GETLIST; 02883200 + GO TO FRMTCD; 02883300 + MON: 02883400 + FRMTCD: 02883500 + PS ~ 0; 02883600 + NFCI ~ (FI|8) + 2; % FIRST FORMAT CHARACTER 02883700 + IF NFC ! "(" THEN GO TO FMERR; 02883800 + NFCI ~ (FI|8) + 2; % FIRST FORMAT CHARACTER 02883900 + NFPH: FORMATCONTROL; % ANAYLSIS OF FORMAT STATEMENT 02884000 + IF FMERRTOG THEN GO TO FMERR; 02884100 + FMCYC: IF (DONETOG ~ ENDLIST) THEN READS; 02884200 + IF W + NCR > LCR THEN GO TO FMERR; 02884300 + NCR ~ W + NCR; 02884500 + CONVERT; 02884600 + IF DTAERR THEN GO TO TYPERR; 02884700 + GETLIST; 02884800 + IF (RPT~RPT-1) > 0 THEN GO TO FMCYC; 02884900 + GO TO NFPH; 02885000 + FMERR: 02885100 + P(MKS,FIB[6],FILX.[33:15],0,FORTERR); 02885110 + TYPERR: 02885400 + P(MKS,FIB[6],FILX.[33:15],2,FORTERR); 02885500 + END FTINT; 02885800 +PROCEDURE FTOUTFIX(FILX,DKADDR,FI,FMT,LISX,EDITCODE,EOFL,PARL); %INT@15702886000 +VALUE DKADDR,FI,LISX,EDITCODE,EOFL,PARL ; 02886040 +ARRAY FMT[*]; NAME FILX; REAL DKADDR,FI,LISX,EDITCODE,PARL,EOFL ; 02886080 + BEGIN 02886120 + 02886160 + INTEGER LSTRN=19, E=17 ; 02886200 + 02886240 + REAL LISTYPE=20, ARRAYSTUFF=18, ALGOLWRITE=12, SELECT=14, 02886280 + FORTERR=24, CHR, MAXCHR, BSIZE, PRNTR, TYPE, INDX, SIZE, TWDT, 02886320 + SGN, BUFF, T1, T2, T3, WH1, WH2, WH3, ARY, W, D, R, SAVW=EOFL, 02886360 + E1=9, XTRA, C, FMTW, SAVBUFF, DBLPREC, CODE, T4, T5, SKP=PARL, 02886400 + NEEDNEWLISTELEMENT, FLG, SCALE, T8, T6=18, SAVD, DECPT=20, ND, 02886440 + COMMAS, DLRSGN, T21 ; 02886480 + 02886520 + NAME LISTADDR ; 02886560 + 02886600 + ARRAY TEN=22[*], AR1=LISTADDR[*], TPAR=23[*], FPB=3[*], FIB[*] ; 02886640 + 02886680 + LABEL ALIST, GETNEXTPHRASE, REPEAT, TT, XX, SS, PP, AA, A1, OO, HH, 02886720 + CC, ERROR, GG, LL, FF, EE, II, DD, TEST, TEST1, AWAY, OVRFLW, 02886760 + BUMPWH3, MAXI, LOG8, THREH, THREL, HLF, CONVERT, D1, OVRFLW1, 02886800 + FIVPT, JJ, RAPUP, X1, OVRFLW2, ONE, OUTSUB, CD, NLEL, FO94, 02886840 + FO95, VERROR, HV, CD1, CMSK, REPEAT1, IEDIT, TEN11, ONDG, CKH,02886845 + STNRD, SE, TWHLF, DREST, DREST1, HLF1, FIVPT1, SQN, OVRFLW3, 02886850 + TEST2, REPEAT2, STNRD1, XPIV, GOTE, NK ; 02886855 + 02886880 + SWITCH PHRASE~SS,HH,PP,XX,TT,AA,OO,LL,JJ,II,GG,FF,EE,DD,CC ; 02886920 + 02886960 + DEFINE DONE = LSTRN=(-1) #, 02887000 + REEL = 3 #, 02887040 + LOGICAL = 4 #, 02887080 + INTEGR = 1 #, 02887120 + DBLPRECSN = 5 #, 02887160 + COMPLEX = 6 #, 02887200 + MAXCODE = 15 #, 02887210 + VERR(VERR1) = BEGIN P(VERR1); GO VERROR END #, 02887215 + MAYBE(MAYBE1,MAYBE2,MAYBE3) = CI~CI+MAYBE1; GO TO MAYBE2 ; 02887240 + DS~LIT MAYBE3; MAYBE2: #, 02887280 + TWOD = LISTYPE.[38:1] #, 02887320 + INDXF = [18:15] #, 02887360 + TYPEF = [44:4] #, 02887400 + SIZEF = [33:15] # ; 02887440 + 02887480 + SUBROUTINE BLANKIT ; 02887482 + BEGIN 02887484 + STREAM(A~BSIZE-1,B~P(DUP).[36:6],T21,BUFF) ; 02887486 + BEGIN 02887488 + SI~T21; DS~WDS; SI~BUFF; DS~A WDS; B(DS~32WDS; DS~32WDS) ;02887490 + END ; 02887492 + END OF BLANKIT ; 02887496 + SUBROUTINE OUTPUT ; 02887520 + BEGIN 02887560 + IF PRNTR THEN 02887600 + BEGIN 02887640 + STREAM(Q~0:SAVBUFF) ; 02887680 + BEGIN DI~LOC Q; SI~SAVBUFF; DI~DI+7; DS~CHR END ; 02887720 + T1~IF (T1~P)="+" THEN 0 ELSE IF T1>9 THEN 16 02887760 + ELSE IF T1=0 THEN 32 ELSE T1;02887800 + IF NOT C THEN FIB[17]~*P(DUP)+BSIZE ; 02887840 + P(MKS,T1.[42:2],T1 AND 15,C,BSIZE,FILX,ALGOLWRITE) ; 02887880 + FIB[6]~*P(DUP)-((C~0)=T1) ; 02887920 + P(MKS,FLG,DKADDR,0,(-1),FILX,ALGOLWRITE,DEL) ; 02888160 + STREAM(Q~BUFF~SAVBUFF,BSIZE,BSZ~P(DUP)-1,T21,S~*FILX) ; 02888200 + BEGIN 02888240 + SI~Q; SI~SI+1; DS~BSIZE WDS; DI~Q; SI~T21; DS~9CHR ; 02888280 + SI~Q; SI~SI+1; DS~BSZ WDS ; 02888320 + END ; 02888360 + FIB[17]~*P(DUP)-BSIZE ; 02888400 + END 02888440 + ELSE BEGIN 02888480 + P(MKS,FLG,DKADDR,0,BSIZE,FILX,ALGOLWRITE) ; 02888520 + IF LSTRN!(-1) THEN 02888560 + BEGIN 02888600 + P(MKS,FLG,DKADDR,0,(-1),FILX,ALGOLWRITE,DEL) ; 02888640 + BUFF~SAVBUFF~(*FILX).[33:15]; BLANKIT ; 02888680 + END ; 02888720 + END ; 02888760 + CHR~0 ; 02888800 + END OF OUTPUT ; 02888840 + 02888880 + SUBROUTINE SKIP ; 02888920 + IF (T1~P(XCH)) GEQ W THEN T1~W 02888960 + ELSE BEGIN 02889000 + STREAM(T21:Q~W-T1,T~P(DUP).[36:6],BUFF) ; 02889040 + BEGIN 02889080 + SI~T21; DS~Q CHR; T(SI~T21; DS~32CHR; DS~32CHR) ; 02889120 + T21~DI ; 02889140 + END ; 02889160 + BUFF~P ; 02889200 + END OF SKIP ; 02889240 + 02889280 + REAL SUBROUTINE NXTELM ; 02889320 + BEGIN 02889360 + P(IF TWDT THEN P(*[AR1[INDX.[33:7]]],INDX AND 255,COC) 02889400 + ELSE AR1[INDX]) ; 02889440 + INDX~INDX+1; NXTELM~P ; 02889480 + END OF NXTELM ; 02889520 + 02889560 + SUBROUTINE GETNEXTLISTELEMENT ; 02889600 + BEGIN 02889640 + IF NEEDNEWLISTELEMENT THEN 02889680 + BEGIN 02889720 + IF ARY THEN 02889760 + BEGIN 02889800 +ALIST: P(NXTELM); IF DBLPREC THEN WH2~NXTELM; ARY~INDXP(FO94) THEN 02890750 + BEGIN IF T1 THEN VERR(P+10); P(DEL,FO94) END 02890755 + ELSE IF P(DEL,(-P(FO94)),DUP)0 ; 02890795 + IF CODE=29 THEN 02890800 + BEGIN P(FI+SAVW) ; 02890805 + IF R}0 THEN P([FMT[P]],DUP,LOD,P&R[6:36:12],XCH) 02890810 + ELSE P(.FI) ; 02890815 + P(STN) ; 02890820 +OUTSUB: P(DEL,DEL); GO GETNEXTPHRASE ; 02890825 + END ; 02890830 + END ; 02890835 + IF T4~CODE=30 THEN 02890840 + BEGIN P(2); NLE; P(.ND,ISN) ; 02890845 + STREAM(P1~P:P2~P(CD),P3~P(CD1)) ; 02890850 + BEGIN SI~LOC P1; SI~SI+7; DI~LOC P2; DI~DI+1 ; 02890855 + 32(IF SC=DC THEN JUMP OUT; TALLY~TALLY+1; SI~SI-1) ; 02890860 + P1~TALLY ; 02890865 + END ; 02890870 + IF (ND AND 63)!ND THEN P(DEL,32) ; 02890875 + IF (CODE~P+3)>MAXCODE AND T1 THEN VERR(2) ; 02890880 + T1~CODE>4 AND T1 ; 02890885 + END ; 02890890 + T2~T1 ; 02890895 + IF P(CODE}11 AND CODE{14,FO95)=SAVW THEN 02890900 + BEGIN P(.SAVW,4) ; 02890905 +NLEL: NLE; P(XCH,ISD); T1~P(DUP) AND T2~T2 AND SAVW>0 ; 02890910 + END ; 02890915 + IF SAVD=P(FO95) THEN BEGIN P(.SAVD,6); GO NLEL END ; 02890920 + IF CODE{4 THEN 02890925 + BEGIN IF T4 THEN SAVW~R; 02890930 + FMTW~FMTW&(P(DUP).[41:1]+(SAVW<0))[41:47:1]; GO HV ; 02890935 + END ; 02890940 + IF NOT T2 THEN GO OUTSUB; IF CODE=5 THEN HV: R~1 ; 02890945 + IF P(DUP) AND SAVD<0 THEN VERR(16) ; 02890950 + IF T4 THEN IF SAVW=P(FO94) THEN BEGIN IF CODE!9 THEN VERR(6)END02890955 + ELSE IF P(DUP) AND SAVD=P(FO94) THEN 02890960 + BEGIN P(7) ; 02890965 +VERROR: T4~P; P(MKS,CODE,R,SAVW,SAVD,T4,WH1,WH2,FMTW, 02890970 + (-5),FORTERR) ; 02890975 +FO94::: 4094 ; 02890980 +FO95::: 4095 ; 02890985 +CD::: @0047676321464341 ; % 0PXTAOLJ 02890990 +CD1::: @3127262524230000 ; % IGFEDC00 02890995 + END ; 02891000 + IF NOT P THEN SAVD~0 ; 02891005 + END OF HANDLEVARIABLES ; 02891010 + 02891015 + REAL SUBROUTINE SETUP ; 02891020 + BEGIN 02891025 + P(XCH,DUP) ; 02891030 + IF DBLPREC THEN 02891035 + BEGIN 02891040 + IF P>ND THEN BEGIN T6~P-ND; P(ND) END ; 02891080 + IF (T5~(T4~P)-T3~ND-16)<0 THEN 02891120 + BEGIN P(WH3/TEN[-T5],.WH3,ISD); T3~T4 END 02891160 + ELSE IF T5 LSS 8 THEN 02891200 + BEGIN 02891240 + IF P(WH2/TEN[8-T2~T5],.WH2,ISN)=TEN[T2] THEN 02891280 +BUMPWH3: WH3~WH3+1 ; 02891320 + END 02891360 + ELSE IF P(WH1/TEN[16-T5],.WH1,ISN)=TEN[T1~T5-T2~8] 02891400 + THEN IF (WH2~WH2+1)=T8 THEN GO BUMPWH3 ; 02891440 + END 02891480 + ELSE BEGIN 02891520 + IF (T3~P)>11 THEN T6~T3-T3~(P(WH1,TEN[ABS(E)],IF E>0 02891560 + THEN P(/) ELSE P(|)){P(FIVPT))+11 ; 02891600 + IF CODE=12 THEN P(SCALE,+) ; 02891640 + P(P-E1-T6,WH3,XCH,TEN[ABS(P(DUP))],IF P(XCH)<0 THEN P(/) 02891680 + ELSE P(|),.WH3,ISD) ; 02891720 + END ; 02891760 + E1~P(TEN[T3]=WH3,DUP)+E1; SETUP~P ; 02891800 + END OF SETUP ; 02891840 + 02891880 +%************************:: CODE STARTS HERE ::************************%02891920 + 02891960 + FIB~FILX[NOT 2]; P(TEN[8],.T8,ISD) ; 02892000 + IF FLG~DKADDR<0 THEN DKADDR~0 ; 02892040 + IF P(FIB[5],DUP).[43:1] THEN P(MKS,0,0,FILX,1,SELECT) ; 02892080 + C~(P AND 96)!0 ; 02892120 + MAXCHR~(BSIZE~P(MKS,FLG,DKADDR,0,(-1),FILX,ALGOLWRITE))|8+ 02892160 + PRNTR~((T1~FIB[4].[8:4])=1 OR T1=12 OR T1=7) AND 02892200 + FPB[FIB[4].[13:11]+3].[43:5]<20 ; 02892205 + IF NOT(NOT(NEEDNEWLISTELEMENT~EDITCODE=3) OR FMT[FI]) THEN GO ERROR;02892240 + IF NOT TPAR.[14:1] THEN 02892250 + BEGIN 02892255 + E~P(1,[E],CFX,SFB)&29[8:38:10] ; 02892260 + STREAM(A~P(21,[E])); BEGIN DS~8LIT" "; SI~A; DS~7WDS END ; 02892265 + P(TPAR,1,25,COM,DEL,DEL); E~0 ; 02892270 + END ; 02892275 + T21~P([TPAR[21]]) INX 0 ; 02892276 + IF PRNTR THEN 02892280 + BEGIN 02892320 + IF BSIZE>16 THEN BEGIN BSIZE~17; MAXCHR~133 END ; 02892360 + IF C THEN BEGIN BUFF~TPAR INX 1; TPAR[0]~" "; BLANKIT END ; 02892440 + P(P(CMSK) OR TPAR) ; 02892445 + END 02892480 + ELSE P(P(*FILX).[33:15]) ; 02892520 + BUFF~SAVBUFF~P ; 02892560 + IF NOT PRNTR THEN BLANKIT ; 02892565 + IF FIB[0]=0 THEN FIB[0]~1 ; 02892600 + IF (LSTRN~1)!FIB[0] AND T1=2 THEN 02892640 + BEGIN T3~4 ; 02892680 +ERROR: P(MKS,FIB[7],FILX.[33:15],T3,FORTERR) ; 02892720 + END ; 02892760 + P(0) ; 02892800 +GETNEXTPHRASE: 02892840 + R~P(FMT[FI~FI+1],DUP).[6:12]; IF (CODE~P(DUP).[1:5])=2 THEN GO HH ;02892880 + SAVW~P(DUP).[18:12]; SAVD~(FMTW~P(DUP)).[30:12] ; 02892885 + IF (XTRA~P(DUP) AND 63).[44:2]=0 THEN P(0,0) 02892890 + ELSE P(P((D~P(DUP) AND 15)=12,DUP) OR D=8,P(XCH) OR D=4) ; 02892895 + DLRSGN~P; COMMAS~P ; 02892900 + IF P.[42:1] THEN IF (FMTW AND 3)=0 THEN HANDLEVARIABLES ; 02892905 + IF CODE=0 THEN 02892920 + BEGIN 02892960 + IF SAVD!0 THEN 02893000 + BEGIN GETNEXTLISTELEMENT; OUTPUT; NEEDNEWLISTELEMENT~0END;02893005 + IF P(DUP).[18:15]!FI THEN P(R&FI[18:33:15]) ; 02893040 + IF P((NOT 0),XCH,INX,DUP).[33:15]=0 THEN P(DEL)ELSE FI~FI-SAVW;02893080 + GO GETNEXTPHRASE ; 02893120 +FIVPT::: 5.49755813885 ; 02893160 + END ; 02893200 + IF CODE=5 THEN CHR~R~0 ; 02893240 +REPEAT: 02893320 + IF CODE>5 THEN 02893360 +REPEAT1: GETNEXTLISTELEMENT ; 02893365 +REPEAT2: 02893370 + IF (CHR~(W~SAVW)+CHR)>MAXCHR THEN IF CODE!3 AND CODE!9 THEN GO AWAY;02893375 + IF CODE}9 THEN IF CODE{14 THEN 02893380 + BEGIN 02893385 + SGN~WH1.[1:1]; DECPT~CODE>10 ; 02893390 + IF CODE<13 THEN 02893395 + IF ABS(WH1)9 02893425 + THEN GO IEDIT ; 02893430 + IF P(SGN+1,-,DUP)}0 THEN GO ONDG ; 02893435 + GO OVRFLW1 ; 02893440 + END ; 02893445 + IF (T1~11-D~SAVD)<0 THEN GO STNRD1 ; 02893450 + IF (E1~W-D-1)<0 THEN GO OVRFLW ; 02893455 + P(T6~0); IF WH1=0 THEN BEGIN WH2~0; GO CKH END;02893460 + P(TEN[D],DUP,ABS(WH1)) ; 02893465 + IF SCALE!0 THEN 02893470 + BEGIN 02893475 + IF P(TEN[ABS(SCALE)],IF SCALE>0 THEN P(|) 02893480 + ELSE P(/),DUP)}P(TEN11) THEN GO STNRD ; 02893485 + P(.WH1,STN) ; 02893490 + END ; 02893495 + IF P(DUP,HLF1,-,.WH2,ISN,-,|,.T5,ISN)=P THEN 02893500 + BEGIN T5~0; WH2~WH2+1 END ; 02893505 + IF T5!0 THEN 02893510 + BEGIN P(DEL,10) ; 02893515 + IF D>8 THEN 02893520 + BEGIN P(DEL,5) ; 02893525 + T2~T5 DIV T8; D~D-8 ; 02893530 + END ; 02893535 + END ; 02893540 + IF WH2<10 THEN 02893545 + BEGIN 02893550 +CKH: IF P(E1-SGN-1,DUP)<0 THEN 02893555 + BEGIN 02893560 + IF WH2!0 THEN GO OVRFLW2 ; 02893565 + P(DEL) ; 02893570 + IF E1=0 THEN 02893575 + BEGIN 02893580 + IF SGN THEN GO OVRFLW1 02893585 + ELSE GO DREST1 ; 02893590 +CMSK::: @700000 ; 02893595 +HLF1::: 0.5 ; 02893600 +TEN11::: 99999999999.0 ; 02893605 + END ; 02893610 + P(SGN~0); WH2~"-" ; 02893615 + END ; 02893620 +ONDG: STREAM(S~P:T21,WH2,SGN,BUFF) ; 02893625 + BEGIN 02893630 + SI~I21; DS~S CHR; MAYBE(SGN,L1,"-") ; 02893635 + SI~LOC SGN; SI~SI-1; DS~CHR; S~DI ; 02893640 + END ; 02893645 + IF NOT DECPT THEN GO TEST ; 02893650 + BUFF~P; P(WH2!0) ; 02893655 +DREST: IF (E~P)>T1 THEN 02893660 + T6~E-T1-(ABS(WH1){TEN[E-1]|P(FIVPT1)) ; 02893665 +DREST1: STREAM(Q~P:D,T2,T5,T6,BUFF) ; 02893670 + BEGIN 02893675 + DS~LIT"."; CI~CI+Q; SI~LOC I5;SI~SI+2;02893680 + DS~D CHR; GO L2; SI~LOC T2; DS~D DEC ;02893685 + DS~8DEC; GO L2; SI~LOC T5; DS~D DEC ; 02893690 + L2: Q~DI ; 02893695 + T6(DI~DI-T6;T6(DS~LIT"0"); JUMP OUT); 02893700 + END ; 02893705 + GO TEST ; 02893710 + END ; 02893715 +IEDIT: IF P(E1-SGN,DUP)<9 THEN 02893720 + BEGIN 02893725 + STREAM(E1~P,WH2,SGN:BUFF) ; 02893730 + BEGIN SI~LOC WH2; CI~CI+SGN; GO L1 ; 02893735 + DS~LIT"0"; DS~E1 DEC; E1~DI; DI~BUFF ;02893740 + IF TOGGLE THEN TALLY~1; DS~8 FILL ; 02893745 + DI~DI-1; DS~LIT"-"; GO L2; L1: 02893750 + DS~E1 DEC; IF TOGGLE THEN TALLY~1 ; 02893755 + E1~DI; DI~BUFF; DS~8FILL; L2: WH2~DI ;02893760 + SGN~TALLY ; 02893765 + END ; 02893770 + IF P THEN GO SQN ELSE GO OVRFLW3 ; 02893775 + END ; 02893780 + IF WH216 THEN P(02893850 + E1-16,8) ELSE P(0,E1-8),E1~P,SGN,BUFF) ; 02893855 + BEGIN 02893860 + SI~T21; DS~S CHR; DS~SGN CHR; S~DI ; 02893865 + SI~LOC WH1; DS~E1 DEC; IF TOGGLE THEN 02893870 + TALLY~1; DS~8DEC; WH1~DI; T21~TALLY; DI~S ;02893875 + DS~8FILL; WH2~DI; CI~CI+SGN; GO L1 ; 02893880 + DI~DI-1; DS~LIT"-"; L1: 02893885 + END ; 02893890 + IF NOT P THEN GO OVRFLW3 ; 02893895 +SQN: IF NOT DECPT THEN 02893900 + BEGIN P(DEL,XCH,DEL); GO TEST END ; 02893905 + E1~P; BUFF~P ; 02893910 + IF W<13 THEN GO DREST1 ; 02893915 + P(0&P((1+BUFF) INX (NOT E1))[43:46:2] 02893920 + +BUFF.[30:3]-E1.[30:3]) ; 02893925 + GO DREST ; 02893930 +FIVPT1:::5.49755813885 ; 02893935 +STNRD: P(DEL,DEL,DEL,DEL) ; 02893940 + END ; 02893945 + D~SAVD ; 02893950 +STNRD1: P(XPIV,WH1=0) ; 02893955 + IF NOT DBLPREC THEN 02893960 + BEGIN 02893965 + IF P THEN GO GOTE ; 02893970 + P(TEN[ABS(E~(P&(WH1~ABS(WH1) MOD P(MAXI))[9:3:6]& 02893975 + WH1[1:2:1]+P(TWHLF))|P(LOG8))],WH1) ; 02893980 + IF E<0 THEN P(|,ONE,XCH) ; 02893985 + IF P(>) THEN 02893990 + BEGIN P(E-1) ; 02893995 +GOTE: E~P ; 02894000 + END ; 02894005 + IF CODE=13 THEN 02894010 + IF NOT (WH1!0 AND (DLRSGN OR D>16 OR D+SCALE>11)) 02894015 + THEN GO SE ; 02894020 + ND~12; WH3~WH1 ; 02894025 + END 02894030 + ELSE IF P AND WH2=0 THEN BEGIN WH3~E~P; ND~24 END ELSE 02894035 + BEGIN 02894040 + P(WH1~ABS(WH1)) ; 02894045 + IF (P AND P(NK))=0 THEN WH2~P(0,ONE,WH2,WH1,DLM,.WH1,~) ; 02894050 + IF (E~(P&(WH3~WH1)[9:3:6]&WH1[1:2:1]+P(TWHLF))|P(LOG8))<0 02894055 + THEN P(0,ONE,TEN[69-E],TEN[-E],DLD) 02894080 + ELSE P(TEN[E+69],TEN[E]) ; 02894120 + T1~P; IF (P>WH2 AND T1=WH1) OR T1>WH1 THEN E~E-1 ; 02894160 + P(WH2,WH1,TEN[69+ABS(E)],TEN[ABS(E)],IF 0>E THEN 02894200 + P(DLM) ELSE P(DLD)) ; 02894240 + T1~P; T3~P; P(24) ; 02894280 + IF T1}P(THREH) THEN P(T1>P(THREH) OR T3>P(THREL),-) ; 02894320 + ND~P ; 02894360 + IF ND}70+E THEN P(WH2,WH1,TEN[ND+69],TEN[ND],DLM, 02894400 + TEN[68-E],TEN[-E-1],DLM) 02894410 + ELSE P(WH2,WH1,TEN[(T1~ABS(ND-E-1))+69],TEN[T1],IF ND{E 02894425 + THEN P(DLD) ELSE P(DLM)) ; 02894440 + WH1~P ; 02894480 + P(T3~P,WH1,T6~TEN[85],T4~TEN[16],DLD,HLF,-,.WH3,ISD,DEL, 02894520 + T3,WH1,0,WH3,T6,T4,DLM,DLS) ; 02894560 + WH1~P ; 02894600 + P(T3~P,WH1,0,T8,DLD,HLF,-,.WH2,ISD,DEL,T3,WH1, 02894640 + 0,WH2,0,T8,DLM,DLS,.WH1,ISD,DEL) ; 02894680 + END ; 02894720 + IF T4~(T1~T2~T3~T6~0)=WH3 THEN P((-ND)) 02894760 + ELSE BEGIN P(E+1); IF CODE=12 THEN P(SCALE,+) END ; 02894800 + E1~P ; 02894840 + END ; 02894880 + GO PHRASE[CODE-1] ; 02894960 +HLF::: 0.5 ; 02894965 +MAXI::: @0777777777777777 ; 02894967 +ONE::: 1.0 ; 02895000 +XPIV::: @1130000000000000 ; 02895040 +TWHLF::: 12.5 ; 02895045 +NK::: @0007000000000000 ; 02895050 +THREH::: @1153013331500045 ; 02895055 +THREL::: @0003112121167260 ; 02895060 +LOG8::: 0.90308998709 ; 02895065 +SE: IF P(W-D-5-SGN,DUP)<0 THEN GO OVRFLW1 ; 02895070 + IF P(DUP)>63 THEN BEGIN P(W,XCH,SUB,63,+); SKIP; P(63) END ; 02895075 + IF WH1=0 THEN 02895080 + BEGIN 02895085 + STREAM(SKP~P:T21,SGN,D~D+3,D1~P(DUP).[36:6],BUFF) ; 02895090 + BEGIN 02895095 + SI~T21; DS~SKP CHR; MAYBE(SGN,L1,"-"); DS~2LIT" 0" ; 02895100 + SI~T21; DS~D CHR; D1(SI~T21; DS~32CHR; DS~32CHR); SKP~DI ;02895105 + END ; 02895110 + GO TEST ; 02895115 + END ; 02895120 + ND~E ; 02895125 + IF SCALE!0 THEN 02895130 + IF SCALE<0 THEN 02895135 + BEGIN IF P(1-SCALE,DUP)>D THEN GO OVRFLW2 END 02895140 + ELSE BEGIN 02895145 + IF P(SCALE,-,DUP)<0 THEN GO OVRFLW1 ; 02895150 + P(SKP~P); D~D+SCALE; E~E-SCALE; P(1) ; 02895155 + END 02895160 + ELSE BEGIN IF D=0 THEN GO OVRFLW1; P(1) END ; 02895165 + T3~P ; 02895170 + IF P(WH1,TEN[ABS(P((E1~D-T3)-ND,DUP))],IF P(XCH)>0 THEN 02895175 + P(|) ELSE P(/),.T4,ISN)=TEN[E1+1] THEN 02895180 + BEGIN P(TEN[E1],.T4,ISD); E~E+1 END ; 02895185 + P(5); IF D>8 THEN BEGIN E1~T4 DIV T8; D~D-8; P(DEL,0) END ; 02895190 + STREAM(SKP~P,Q~P:D,E1,T4,E~ABS(E+T3),ES~E<(-T3),SGN,T21,BUFF) ; 02895195 + BEGIN 02895200 + SI~T21; DS~SKP CHR; MAYBE(SGN,L1,"-"); DS~LIT"."; CI~CI+Q; 02895205 + SI~LOC E1; DS~D DEC; DS~8DEC; GO L2; SI~LOC T4; DS~D DEC ; 02895210 + L2: DS~2LIT"E "; CI~CI+ES; GO L3; DI~DI-1; DS~LIT"-" ; 02895215 + L3: DS~2DEC; SKP~DI ; 02895220 + END ; 02895225 + P(DEL) ; 02895230 + IF SCALE>0 THEN STREAM(SCALE,SKP~SKP+SGN,BUFF) ; 02895235 + BEGIN 02895240 + DI~DI+SKP; SKP~DI; SI~SKP; SI~SI+1; DS~SCALL CHR ; 02895245 + DS~LIT"." ; 02895250 + END ; 02895255 + GO TEST ; 02895260 +TT: P(CHR~W-1); IF PRNTR THEN P(DEL,W+6) ; 02895265 + P((P(DUP).[33:12] INX SAVBUFF)&P(XCH)[30:45:3]); GO TEST ; 02895280 +XX: P(0) ; 02895320 +X1: SKIP; GO TEST1 ; 02895360 +SS: OUTPUT; IF (R~R-1)>0 THEN GO SS ELSE GO TEST2 ; 02895400 +CC: 02895440 +AA: P(WH1,6) ; 02895480 +A1: SKIP ; 02895520 + STREAM(Q~P:T~IF CODE=6 THEN 2 ELSE 8-T1,T1,BUFF) ; 02895560 + BEGIN SI~LOC Q; SI~SI+T; DS~T1 CHR; Q~DI END ; 02895600 + GO TEST ; 02895640 +LL: P("F"); IF T5 THEN P(29,+); P(1); GO A1 ; 02895680 +PP: SCALE~W&FMTW[1:41:1]; CHR~CHR-W; GO TEST1 ; 02895720 +OO: P(16); SKIP ; 02895760 + STREAM(Q~3|(16-T1):T1,WH1,BUFF) ; 02895800 + BEGIN 02895840 + SI~LOC WH1; SKIP Q SB ; 02895880 + I1(DS~3RESET; 3(IF SB THEN DS~SET ELSE DS~RESET; SKIP SB)) ; 02895920 + Q~DI ; 02895960 + END ; 02896000 + GO TEST ; 02896040 +HH: P(DEL); IF (CHR~CHR+R)>MAXCHR THEN GO AWAY ; 02896080 + STREAM(Q~[FMT[FI]]:R,S~R.[36:6],BUFF) ; 02896100 + BEGIN SI~Q; SI~SI+3; DS~R CHR; S(DS~32CHR; DS~32CHR); Q~DI END ;02896120 + BUFF~P; FI~(R+2).[36:9]+FI; GO GETNEXTPHRASE ; 02896160 +GG: IF TYPE=INTEGR THEN BEGIN DECPT~D~0; GO II END ; 02896200 + IF TYPE=LOGICAL THEN GO LL ; 02896240 + IF E1}0 AND E1{D THEN 02896280 + BEGIN 02896320 + W~W-4; D~D-E1 ; 02896360 +II: 02896400 +JJ: 02896440 +FF: IF P(0,E1+D,DUP)<0 THEN P(DEL,WH3~0) ; 02896480 + IF T4 AND DECPT THEN T6~P ELSE T3~SETUP+T3 ; 02896520 + P(CODE=9) ; 02896600 + E~(T4~IF (ND~0)MAXCHR THEN GO AWAY; P(WH3=0) END 02896725 + ELSE IF P(W-D-DECPT-E,DUP)<0 THEN GO OVRFLW2 ; 02896760 + SKP~P+T5 ; 02896800 + IF E1 LSS 1 THEN 02896840 + BEGIN IF (ND~(T4~SKP!0)-E1)>D THEN ND~D+T4;SKP~SKP-T4 END;02896880 + GO CONVERT ; 02896920 + END ; 02896960 +EE: P("E"); GO D1 ; 02897000 +DD: P("D") ; 02897040 +D1: IF T4 THEN BEGIN P(DEL); GO SE END; IF P(SCALE,DUP)<0 THEN P(DEL,0);02897080 + IF (SKP~-P(D+P,DUP)+W-5-SGN-DLRSGN)<0 THEN GO OVRFLW2 ; 02897100 + IF D~SCALE{0 THEN IF -SCALE}SAVD THEN GO OVRFLW2 ELSE P(SCALE,+) ; 02897120 + IF SETUP THEN P(TEN[T3-1],.WH3,ISD) ; 02897360 + IF (T4~ND~0)!SCALE THEN 02897400 + BEGIN 02897440 + IF ABS(E1~E1-SCALE)>99 THEN GO OVRFLW1 ; 02897480 + IF D THEN ND~-SCALE ELSE T4~SCALE ; 02897520 + END ; 02897560 +CONVERT: 02897600 + IF NOT DBLPREC AND T3>8 THEN 02897640 + BEGIN WH3~(WH2~WH3) DIV T8; T3~T3-T2~8 END ; 02897680 + STREAM(ND,SKP:T6,SGN,E~DECPT,S~SKP.[36:6],T~T6.[36:6],DLRSGN,T4, 02897720 + T21,WH3,T3,WH2,T2,WH1,T1,BUFF) ; 02897760 + BEGIN SI~T21; DS~SKP CHR ; 02897800 + S(SI~T21; DS~32CHR; DS~32CHR); SKP~DI; MAYBE(DLRSGN,L3,"$") ; 02897840 + MAYBE(SGN,L1,"-"); SGN~DI; DI~DI+E; ND(DS~LIT"0") ; 02897880 + SI~LOC WH3; DS~T3 DEC; SI~LOC WH2; DS~T2 DEC; SI~LOC WH1 ; 02897920 + DS~T1 DEC;T6(DS~LIT"0");T(32(DS~2LIT"0"));ND~DI;CI~CI+E; 02897960 + GO L2; SI~SGN; DI~SGN; SI~SI+1; DS~I4 CHR; DS~LIT"."; L2: 02898000 + END ; 02898040 + T6~P ; 02898080 + IF (T4~P(XCH))!0 THEN 02898120 + STREAM(BUFF~P:T4,SGN~IF E1 LSS 0 THEN "-" ELSE " ",S~ABS(E1)) ;02898160 + BEGIN 02898200 + DI~BUFF; SI~LOC T4; SI~SI+7; DS~CHR; SI~SI+7; DS~CHR ; 02898240 + DS~2 DEC; BUFF~DI ; 02898280 + END 02898320 + ELSE IF T5>0 THEN 02898360 + STREAM(T~T5-1,Q~E-T5|4,T5,T6) ; 02898400 + BEGIN 02898440 + SI~T6; DI~DI-T5; DS~Q CHR; DS~LIT"," ; 02898480 + T(DS~3CHR; DS~LIT",") ; 02898520 + END ; 02898560 + IF W!SAVW THEN BEGIN BUFF~P; P(W+W-SAVW); GO X1 END ; 02898600 + GO TEST ; 02898640 +OVRFLW3: 02898660 + P(DEL) ; 02898665 +OVRFLW2: 02898680 + P(DEL) ; 02898720 +OVRFLW1: 02898760 + P(DEL) ; 02898800 +OVRFLW: 02898840 + STREAM(W~SAVW:W1~SAVW.[36:6],BUFF) ; 02898880 + BEGIN W(DS~LIT"*"); W1(32(DS~2LIT"*")); W~DI END ; 02898920 +TEST: 02898960 + BUFF~P ; 02899000 +TEST1: 02899040 + IF (R~R-1)>0 THEN GO REPEAT1 ; 02899080 +TEST2: 02899085 + IF (XTRA AND 3)=0 THEN GO GETNEXTPHRASE ; 02899120 + P(XTRA); XTRA~SAVW~0 ; 02899160 + IF P(DUP) THEN BEGIN SAVW~P.[42:5]; CODE~4; GO REPEAT2 END ; 02899200 + CODE~1; R~P.[42:4]; GO SS ; 02899240 + END OF FTOUTFIX ; 02899280 + % FORTRAN OUTPUT INTRINSIC 02900000 +PROCEDURE FTOUT; % 051 02900100 + BEGIN 02900200 +COMMENT FILX FILE TOP IO DESCRIPTOR 02900300 + FMTA FORMAT OR NAMELIST OR 0 02900400 + LISX ACCIDENTAL ENTRY DESC. OR 0 02900500 + EDITCODE 0 NO FORMAT, NO LIST 02900600 + 1 FORMAT, NO LIST 02900700 + 2 NO FORMAT, LIST 02900800 + 3 FORMAT, LIST 02900900 + 4 NAMELIST 02901000 + ; 02901100 +REAL EDITCODE = -1, 02901200 + FORTERR = 24, 02901210 + LISX = -2, 02901300 + FI = -4, 02901400 + DKADR = -5; 02901500 +ARRAY FMTA = -3[*], FPB = 3[*] ; 02901600 +NAME FILX = -6, 02901700 + MEM = 2; 02901800 +REAL ALGOLWRITE = 12, 02901900 + SELECT = 14; 02902000 +INTEGER LSTRN = 19; 02902300 +REAL LISTYPE = 20, 02902400 + ARRAYSTUFF = 18; 02902500 +ARRAY TEN = 22[*], 02902900 + TPAR = 23[*], 02903000 + FIB[*]; 02903100 +NAME LISTADR; 02903200 +REAL BUFF , % FIRST BUFFER POSITION 02903300 + BSIZE , % ARGUMENTS 02903400 + FLG , % TRUE FOR SERIAL I/O 02903410 + WH1, 02903500 + WH2 , % 02903600 + W1 , % 02903700 + W2 , % 02903800 + NFCI ; % NEXT FORMAT CHAR LOCATION 02903900 +ARRAY IOBUFF = BUFF[*]; 02904000 +INTEGER DH1 , % CONV- 02904100 + DH2 , % ERTED NU- 02904200 + DH3 , % MBER 02904300 + RPT , % REPEAT INDICATOR 02904400 + W , % FIELD 02904500 + WT , % WIDTH 02904600 + T1 , % 02904700 + D , % DEC- 02904800 + DT , % IMAL P- 02904900 + D1 , % LA- 02905000 + D2 , % CE- 02905100 + D3 , % S 02905200 + ZEROS , % TRAILING ZEROES 02905300 + EXP , % EXPONENT 02905400 + SHFT , % INTEGER PART OF SHIFT 02905500 + CODE , % EDITING FUNCTION 02905600 + SKP , % REDUNDANT POSITIONS 02905700 + NCR , % 0URRENT BUFFER POSITION 02905800 + LCR , % BUFFER SIZL IN CHARACIERS 02905900 + QUOTE , % STRING DELIMITER (" OR @) 02905910 + CHR , % CURRENT CHAR FROM FORMAT 02906000 + PRCW , % PAREN CONTROL WORD 02906010 + PCT, % PAREN COUNTER 02906020 + PS ; % SCALE FACTOR 02906100 +BOOLEAN DONETOG , % RETURN AFTER WRITE 02906200 + SGN , % SIGN 02906300 + PRNTR , % TRUE IF PRINTER OUT PUT 02906400 + FMERRTOG , % FORMAT ERROR 02906500 + LGTG , 02906600 + DTOG , % DOUBLE PRECISION TOG 02906700 + CTOG , % COMPLEX NUMBER TOG 02906800 + GTOGA , % G EDITING TOG W-D - SGN > 4 02906810 + GTOG ; % G EDITING TOG 02906900 +DEFINE DBLV = 5#, 02907300 + CMPLXV = 6#, 02907400 + GTYPE = 1#, 02907500 + FTYPE = 2#, 02907600 + ETYPE = 3#, 02907700 + DTYPE = 4#, 02907800 + ITYPE = 5#, 02907900 + LTYPE = 6#, 02908000 + ATYPE = 7#, 02908100 + OTYPE = 8#, 02908200 + KIND = (FIB[4].[8:4])#, 02908300 + TAPEF =2#, 02908500 + MAX = @7777777777777#, 02908700 + DLN = (LISTYPE.[44:4] =DBLV)#, 02908900 + CMPLX = (LISTYPE.[44:4] = CMPLXV)#, 02909000 + TWOD = LISTYPE.[38:1]#, 02909100 + LPPS = 15:30:18#, 02909200 + LPPR = [15:18]#, 02909300 + RPTF = [33:15]#, 02909400 + NORF = (P(XCH,DUP) < 0)#, 02909500 + PCF = [9:6]#, 02909510 + ENDLIST = (LSTRN = (-1))#, 02909600 + SIZEF = [33:15]#, 02909700 + BASEF = [18:15]#; 02909800 +LABEL TYPERR,NMLST, 02910000 + STRT,REPEAT,LPAR,RTPAR,SLASH,STRING,TFMT,FMTERR, 02910100 + CL1,CL2,CL3,CL4,SCAL,HOL,SKIP,CL3A,STRA,TFMA,TIX, 02910200 + ERTN,G,F,E,DC,I,L,A,AA,O,FA,GA,AST,COMM, 02910300 + NOFL,FNOL,BINARY,FMTLST, 02910400 + FRMTCD,NFPH,FMCYC,FMERR,ZAP,ZIPIT; 02910500 +COMMENT * * * * * START OF SUBROUTINE DECLARATIONS * * * * * * * * ; 02910600 +SUBROUTINE CKPB; 02910700 +BEGIN COMMENT INITIALIZE FILE AND ACQUIRE RECORD SIZE; 02910800 +LCR ~ 8|(BSIZE ~ P(MKS,FLG,DKADR,0,(-1),FILX,ALGOLWRITE)); 02910900 +IF PRNTR~PRNTR&(((T1~FIB[4].[8:4])=1 OR T1=7 OR T1=12) AND FPB[FIB[4] 02911000 + .[13:11]+3].[43:5]<20)[47:47:1] THEN 02911005 + IF BSIZE } 17 THEN BEGIN LCR ~ 132; BSIZE ~ 17 END; 02911010 +BUFF~(IF T1~PRNTR AND (EDITCODE=1 OR EDITCODE>2) THEN TPAR ELSE *FILX) 02911100 +.[33:15] ; 02911200 +IF ((NOT T1) OR PRNTR.[46:1]) AND EDITCODE!2 THEN 02911400 +STREAM(P2 ~ (BSIZE-1).[36:6], 02911500 + P3~BSIZE+T1-1,P4~BUFF) ; 02911600 + BEGIN DI ~ P4; DS ~ 8 LIT " "; 02911700 + SI ~ P4; 02911800 + P2(DS ~ 32 WDS; DS ~ 32 WDS); 02911900 + DS ~ P3 WDS; 02912000 + END; 02912100 +NCR ~ 0; 02912300 +END CKPB; 02912400 +SUBROUTINE PRNT; 02912500 +BEGIN COMMENT GENERATE A CALL FOR CAR. CONT. AND FOR OUTPUT; 02912600 +IF PRNTR AND (EDITCODE = 1 OR EDITCODE } 3) THEN 02912700 +BEGIN; 02912800 + NCR ~ 0; 02912900 + STREAM(P1~0:P2~TPAR); 02913000 + BEGIN SI ~P2; DI ~ LOC P1; DI ~DI + 7; DS ~CHR; 02913100 + DI ~ P2; DS ~ LIT " ";END; 02913200 + NCR ~ P; 02913300 + IF NCR = " " THEN D2 ~ 16 ELSE 02913400 + IF NCR = "0" THEN D2 ~ 32 ELSE 02913500 + IF NCR = "+" THEN D2 ~ 0 ELSE 02913600 + IF (D2 ~ NCR) > 9 THEN D2 ~ 16; 02913700 + IF NOT PRNTR.[46:1] THEN FIB[17]~FIB[17]+BSIZE ; 02913900 + P(MKS,D2.[42:2],D2.[44:4],PRNTR.[46:1],BSIZE,FILX,ALGOLWRITE) ;02914000 + FIB[6]~FIB[6]-(D2=0) ; 02914010 + IF NOT (*FILX).[19:1] THEN P(FILX,@2000000000,2,COM,DEL,DEL); 02914100 + PRNTR~1; CKPB ; 02914200 + STREAM(P1~TPAR,P2~*FILX,P3~BSIZE.[36:6],P4~BSIZE); 02914300 + BEGIN 02914400 + SI ~ P1; DI ~ P2; DS ~ P4 WDS; 02914500 + P3(DS ~32 WDS; DS ~ 32 WDS); 02914600 + DI~P1; P4(DS~8LIT" ") ; 02914610 + END; 02914700 + FIB[17]~FIB[17]-BSIZE; IF DONETOG THEN P(XIT) ; 02914800 + END ELSE BEGIN P(MKS,FLG,DKADR,0,BSIZE,FILX,ALGOLWRITE); 02914900 + IF DONETOG THEN P(XIT); 02915000 + CKPB END ; 02915100 +END PRNT; 02915200 +LABEL NFCL; 02915300 +REAL SUBROUTINE NFC; 02915400 +BEGIN 02915500 +NFCL: 02915600 +WHILE NFCI.[45:3] < 2 DO NFCI ~ NFCI + 1; 02915700 +STREAM(P1 ~ 0:P2 ~FMTA[NFCI.[30:15]],P3 ~ NFCI.[45:3]); 02915800 + BEGIN DI ~ LOC P1; DS ~ 7 LIT "0"; 02915900 + SI ~ LOC P2; SI ~SI + P3;DS ~ CHR; 02916000 + SI ~ SI - 1; DI ~ DI - 1; 02916100 + END; 02916800 +NFCI ~ NFCI + 1; IF (CHR ~ P) = " " THEN IF NOT LGTG THEN GO NFCL; 02916900 +NFC ~ CHR; 02917000 +END NFC; 02917100 +SUBROUTINE IST; 02917200 +BEGIN ; 02917300 +STREAM(P1 ~ 0:P2 ~ BUFF,P3 ~ CHR); 02917400 + BEGIN SI ~ LOC P3; SI ~ SI + 7; 02917500 + DI ~ P2; DS ~ CHR; P1 ~ DI; 02917600 + END; 02917700 +BUFF ~ P; 02917800 + END IST; 02917900 + % PARAMETERS FOR LIST CONTROL 02918000 +BOOLEAN ATOG,TWDT; 02918100 +ARRAY AR1 = LISTADR[*]; 02918200 +REAL INDX,SIZE,NLI,NLE; 02918400 +LABEL RTNLST,SRT; 02918500 +DEFINE NXTELM = IF TWDT THEN P(*[AR1[INDX.[33:7]]],INDX.[40:8],COC) 02918600 + ELSE AR1[INDX]#; 02918700 +SUBROUTINE GETLIST; 02920200 + BEGIN 02920300 + SRT: IF ATOG THEN 02920400 + BEGIN 02920500 + IF DLN THEN 02920600 + BEGIN 02920700 + WH1 ~ NXTELM; 02920800 + INDX ~ INDX + 1; 02920900 + WH2 ~ NXTELM; 02921000 + END ELSE 02921100 + BEGIN 02921200 + WH1 ~ NXTELM; 02921300 + WH2 ~ 0; 02921400 + END; 02921500 + IF (INDX ~INDX + 1) } SIZE THEN 02921600 + BEGIN 02921700 + ARRAYSTUFF ~ 0; 02921800 + ATOG ~ FALSE; 02921900 + END; 02922000 + GO TO RTNLST; 02922100 + END; 02922200 + IF CTOG THEN 02922300 + BEGIN % IMAGINARY PART OF COMPLEX 02922400 + WH1 ~ LISTADR[1]; 02922500 + WH2 ~ 0; 02922600 + CTOG ~ FALSE; 02922700 + GO TO RTNLST; 02922800 + END; 02922900 + P(0); LISTADR ~ [LISX]; 02923600 + IF ARRAYSTUFF ! 0 THEN 02923800 + BEGIN 02923900 + ATOG ~ TRUE; 02924000 + SIZE~(INDX~ARRAYSTUFF.BASEF)+ARRAYSTUFF.SIZEF ; 02924400 + TWDT~NOT P(*(LISTADR~MEM[LISTADR.[18:15]]),TOP); P(DEL) ; 02924500 + GO TO SRT; 02924600 + END; 02924700 + P(DEL); 02924800 + WH1 ~ LISTADR[0]; 02924900 + WH2 ~ IF DLN THEN LISTADR[1] ELSE 0; 02925000 + CTOG ~ CMPLX; 02925100 + RTNLST: 02925200 + END GETLIST; 02925300 +SUBROUTINE FORMATCONTROL; 02927400 +BEGIN 02927500 + STRT: 02927600 + W~D~CODE~SKP~RPT~0; 02927700 + SGN~DONETOG~FMERRTOG~FALSE; 02927800 + CL1: COMMENT CHECK FOR SINGLE CHARACTER EDITING TYPES; 02927900 + IF NFC{9 THEN GO TO REPEAT; % MUST BE REPEAT FIELD 02928000 + IF CHR = "(" OR CHR = "%" THEN GO TO LPAR; 02928100 + IF CHR = ")" OR CHR = "[" THEN GO TO RTPAR; 02928200 + IF CHR="/" THEN GO SLASH; 02928300 + IF CHR = """ OR CHR = "@" THEN GO TO STRING; 02928400 + IF CHR="T" THEN GO TO TFMT; 02928500 + SGN~(CHR="-") & (CHR="+")[2:47:1]; 02928590 + IF SGN THEN 02928600 + BEGIN 02928700 + IF NFC{9 THEN GO TO REPEAT 02928800 + ELSE GO TO FMTERR; 02928900 + END; 02929000 + IF CHR="," THEN GO TO STRT; 02929100 + RPT~1; 02929200 + CL2: COMMENT TYPES WHICH MAY HAVE REPEAT FIELDS; 02929300 + IF SGN THEN RPT~-RPT; 02929400 + IF CHR="P" THEN GO TO SCAL; 02929500 + IF RPT<0 OR SGN.[2:1] THEN GO TO FMTERR; 02929600 + IF CHR = "(" OR CHR = "%" THEN GO TO LPAR; 02929700 + IF CHR="H" THEN GO TO HOL; 02929800 + IF RPT=0 THEN RPT~1; 02929900 + IF CHR = "X" THEN GO TO SKIP; 02930000 + CL3: COMMENT TYPES WHICH HAVE W FIELDS; 02930100 + IF CHR="I" THEN CODE ~ ITYPE ELSE 02930200 + IF CHR="A" THEN CODE ~ ATYPE ELSE 02930300 + IF CHR="L" THEN CODE ~ LTYPE ELSE 02930400 + IF CHR="O" THEN CODE ~ OTYPE; 02930500 + IF CODE } ITYPE THEN GO TO CL3A; 02930600 + CL4: COMMENT TYPES WITH W AND D FIELDS; 02930700 + IF CHR="D" THEN CODE ~ DTYPE ELSE 02930800 + IF CHR="E" THEN CODE ~ ETYPE ELSE 02930900 + IF CHR="F" THEN CODE ~ FTYPE ELSE 02931000 + IF CHR="G" THEN CODE ~ GTYPE ELSE 02931100 + GO TO FMTERR; 02931200 + CL3A: COMMENT DEVELOP VALUE OF W FIELD; 02931300 + IF NFC>9 THEN GO TO FMTERR; 02931400 + W~CHR; 02931500 + WHILE NFC{9 DO W~10|W+CHR; % CONVERT TO OCTAL 02931600 + NFCI~NFCI-1; 02931700 + IF W>63 THEN GO TO FMTERR; 02931800 + IF CODE}ITYPE THEN GO TIX; 02931900 + COMMENT DEVELOP D FIELD; 02932000 + IF NFC!"." THEN GO TO FMTERR; 02932100 + IF NFC >9 THEN GO TO FMTERR; 02932200 + D~CHR; 02932300 + WHILE NFC{9 DO D~10|D+CHR; % 0ONVERT TO OCTAL 02932400 + NFCI~NFCI-1; 02932500 + GO TO TIX; 02932600 + LPAR: COMMENT GENER1TE PAREN CONTROL WORD. 02932700 + IF PCT!0 AND RPT=0 THEN RPT~1 ; 02932710 + T1 ~ RPT&NFCI[LPPS]&(RPT{0)[1:47:1]; 02932800 + IF PCT { 1 THEN PRCW ~ T1 & PCT[9:42:6]; 02932810 + P (T1, XCH); PCT~PCT+1; 02932820 + GO TO STRT; 02932900 + RTPAR: COMMENT POINT AT LEFT PAR IF REPEAT NOT EXAUSTED; 02933000 + IF NORF THEN 02933100 + BEGIN % NO REPEAT FIELD 02933200 + DONETOG ~ ENDLIST; 02933300 + PRNT;% WRITE OUT RECORD 02933400 + IF (PCT ~ PCT - 1) { 0 THEN IF PRCW.PCF !0 02933410 + THEN BEGIN P(XCH,PRCW); PCT ~ 2 END ELSE PCT ~ 1; 02933420 + END ELSE 02933500 + BEGIN 02933600 + IF (RPT~P(DUP).RPTF) { 1 02933700 + THEN BEGIN P(DEL);PCT ~ PCT - 1; GO TO STRT END 02933800 + ELSE P(RPT - 1,CCX); 02933900 + END; 02934000 + NFCI~P(DUP).LPPR; % RESET TO LEFT PAREN 02934100 + P(XCH); 02934200 + GO TO STRT; 02934300 + REPEAT: COMMENT CONVERT REPEAT FIELD TO OCTAL IN RPT; 02934400 + RPT~CHR; 02934500 + WHILE NFC{9 DO RPT~ 10|RPT+CHR; 02934600 + GO TO CL2; 02934700 + SLASH: COMMENT WRITE OUT BUFFER; 02934800 + PRNT; 02934900 + GO TO STRT; 02935000 + STRING: COMMENT MOVE STRING FROM FORMAT ARRAY TO BUFFER; 02935100 + QUOTE ~ CHR; % SAVE STRING DELIMITER 02935110 + LGTG ~ TRUE; CHR ~ NFC; 02935200 + STRA: IF (NCR ~ NCR + 1) > LCR THEN GO TO FMTERR; 02935300 + IST; 02935400 + IF NFC ! QUOTE THEN GO TO STRA; % " OR @ 02935500 + LGTG ~ FALSE ; GO TO STRT; 02935600 + TFMT: COMMENT SET BUFFER TO CHARACTER POSITION INDICATED BY FIELD 02935700 + FOLLOWING "T"; 02935800 + IF (RPT~NFC)>9 THEN GO TO FMTERR; 02935900 + WHILE NFC{9 DO RPT~10|RPT+CHR; 02936000 + IF RPT>LCR THEN GO TO FMTERR; 02936100 + NCR~RPT-1; 02936200 + TFMA: BUFF ~((IF PRNTR THEN TPAR ELSE (*FILX)) INX 02936300 + NCR.[33:12])&NCR[30:45:3]; 02936400 + GO TO STRT; 02936500 + SCAL: COMMENT SCALE FACTOR OF P PHRASE; 02936600 + PS~RPT; 02936700 + GO TO STRT; 02936800 + HOL: COMMENT HOLLERITH STRING; 02936900 + LGTG ~ TRUE; 02937000 + WHILE RPT > 0 DO 02937100 + BEGIN 02937200 + IF (NCR ~ NCR + 1) > LCR THEN GO TO FMTERR; 02937300 + CHR ~ NFC; IST; 02937400 + RPT~RPT-1; 02937500 + END; 02937600 + LGTG ~ FALSE; GO TO STRT; 02937700 + SKIP: COMMENT X PHRASE; 02937800 + IF (NCR ~ NCR+RPT) > LCR THEN GO TO FMTERR; 02937900 + GO TO TFMA; 02938000 + FMTERR: FMERRTOG~TRUE; 02938100 +TIX: 02938200 +END FORMATCONTROL; 02938300 +SUBROUTINE FUNNYZERO; 02938400 + BEGIN 02938500 + SKP ~ W - (D+6+SGN); 02938600 + STREAM(P1~ BUFF:P2~SKP,P3~SGN,P4~(D+4)); 02938700 + BEGIN 02938800 + DI ~P1; DI ~ DI + P2; 02938900 + P3(DS ~ LIT "-"; JUMP OUT TO L); 02939000 + L: DS ~ 2 LIT "0."; 02939100 + P4(DS ~ LIT " "); 02939200 + P1 ~ DI; 02939300 + END; 02939400 + BUFF ~ P; 02939500 + END FUNNYZERO; 02939600 +SUBROUTINE FINDE; 02939700 +BEGIN IF DTOG THEN 02939800 + DOUBLE(TEN[0],0,WH1,WH2,|,~,WH1,WH2) 02939900 + ELSE WH1 ~ TEN[0] | WH1; 02940000 + EXP~(0&WH1[42:3:6]&WH1[1:2:1]+12.5)|.90308998709 ; 02940100 + W2 ~ 0; 02940150 + IF DTOG THEN 02940200 + IF EXP } 0 THEN DOUBLE(TEN[EXP],TEN[69+EXP],~,W1,W2) 02940300 + ELSE DOUBLE(1,0,TEN[-EXP],TEN[69-EXP],/,~,W1,W2) 02940400 + ELSE W1 ~ IF EXP } 0 THEN TEN[EXP] ELSE 1/TEN[-EXP]; 02940500 + IF WH1 > W1 THEN GO TO ERTN; 02940600 + IF WH1 = W1 THEN 02940700 + IF WH2 } W2 THEN GO TO ERTN; 02940800 + EXP ~ EXP-1; 02940900 + ERTN: 02941000 +END FINDE; 02941100 +SUBROUTINE NUMCONVERT; 02941200 +BEGIN 02941300 + IF D1 > 0 THEN 02941400 + BEGIN 02941500 + DOUBLE(WH1,WH2,TEN[16],TEN[85],/,~,W1,W2); 02941600 + DH1 ~ W1 DIV 1.0; 02941700 + END; 02941800 + IF D2 > 0 THEN 02941900 + BEGIN IF DTOG THEN 02942000 + BEGIN 02942100 + DOUBLE(WH1,WH2,DH1,0,TEN[16],TEN[85],|,-, 02942200 + TEN[ 8],TEN[77],/,~,W1,W2); 02942300 + DH2 ~ W1 DIV 1; 02942400 + END 02942500 + ELSE DH2 ~ WH1 DIV TEN[8]; 02942600 + END; 02942700 + IF DTOG THEN 02942800 + BEGIN 02942900 + DOUBLE(WH1,WH2,DH1,0,TEN[16],TEN[85],|, 02943000 + DH2,0,TEN[ 8],TEN[77],|,+,-,~,W1,W2); 02943100 + DH3 ~ W1 DIV 1; 02943200 + END 02943300 + ELSE DH3 ~ WH1 DIV 1; 02943400 + EXP ~ EXP+1; 02943500 +END NUMCONVERT; 02943600 +SUBROUTINE SETD; 02943700 +BEGIN 02943800 + IF DLN AND DT > 23 THEN 02943900 + BEGIN 02944000 + ZEROS~DT-23; DT ~ 23; D1 ~ 7; D2 ~ D3 ~ 8; 02944100 + END ELSE IF DT>12 AND NOT DLN THEN 02944200 + BEGIN 02944300 + ZEROS~DT-12; DT ~ 12; D1~0; D2 ~ 4; D3 ~ 8; 02944400 + END ELSE IF DT>16 THEN 02944500 + BEGIN 02944600 + D1~DT-16; D2~D3~8; 02944700 + END ELSE IF DT > 8 THEN 02944800 + BEGIN 02944900 + D1~0;D2~DT-8; D3~8; 02945000 + END ELSE 02945100 + BEGIN 02945200 + D1~D2~0;D3~DT; 02945300 + END; 02945400 +END SETD; 02945500 +SUBROUTINE RNDOFF; 02945600 +BEGIN IF DTOG THEN 02945700 + IF T1 } 0 THEN 02945800 + DOUBLE(WH1,WH2,,5,TEN[T1],TEN[T1+69],|,+,~,WH1,WH2) ELSE 02945900 + DOUBLE(WH1,WH2,,5,TEN[-T1],TEN[69-T1],/,+,~,WH1,WH2) 02946000 + ELSE WH1 ~ WH1 + (IF T1}0 THEN 5|TEN[T1] ELSE 5/TEN[-T1]);02946100 +END RNDOFF; 02946200 +SUBROUTINE SCALE; 02946300 +BEGIN IF DTOG THEN 02946400 + BEGIN IF T1 } 0 02946500 + THEN DOUBLE(WH1,WH2,TEN[T1],TEN[T1+69],|,~,WH1,WH2) 02946600 + ELSE DOUBLE(WH1,WH2,TEN[-T1],TEN[69-T1],/,~,WH1,WH2); 02946700 + IF WH1 } TEN[DT] THEN 02946800 + BEGIN 02946900 + EXP ~ EXP + 1; 02947000 + DOUBLE(WH1,WH2,TEN[1],0,/,~,WH1,WH2); 02947100 + END 02947200 + END ELSE WH1 ~ IF T1 } 0 THEN WH1|TEN[T1] ELSE WH1/TEN[-T1]; 02947300 +END SCALE; 02947400 + %************** S T A R T O F EDIT-CONTROL*****************%02947500 +SUBROUTINE CONVERT; 02947600 +BEGIN 02947700 +DTOG ~ GTOG ~ FALSE; 02947800 +SGN ~WH1.[1:1]; IF CODE < LTYPE THEN WH1 ~ ABS(WH1); WT ~ W; DT ~ D; 02947900 +DH1 ~ DH2 ~ DH3 ~ ZEROS ~EXP ~ SKP ~ SHFT ~ D1 ~ D2 ~ D3 ~ 0; 02948000 +GO TO P(CODE,DUP,ADD); 02948100 +GO TO FMERR; 02948200 +GO TO G; 02948300 +GO TO F; 02948400 +GO TO E; 02948500 +GO TO DC; 02948600 +GO TO I; 02948700 +GO TO L; 02948800 +GO TO A; 02948900 +GO TO O; 02949000 +O: COMMENT OCTAL CONVERSION * * * * * * * * * ; 02949100 + IF W > 16 THEN SKP ~ W - (WT ~ 16); 02949200 +STREAM(P1 ~ BUFF:P2 ~ WH1,P3 ~ SKP,P4 ~ WT,P5 ~ 16-WT); 02949300 + BEGIN SI ~ LOC P2; DI ~ P1; 02949400 + DI ~ DI + P3; P5(SKIP 3 SB); 02949500 + P4(DS ~ 3 RESET; 3(IF SB THEN DS ~ SET 02949600 + ELSE DS ~ RESET; SKIP SB)); 02949700 + P1 ~ DI; 02949800 + END; 02949900 +BUFF ~ P; 02950000 +GO TO COMM; 02950100 +A: COMMENT ALPHA CONVERSION * * * * * * * * * ; 02950200 +IF W > 6 THEN SKP ~ W - (WT ~ 6); 02950300 +AA: STREAM(P1 ~ BUFF:P2 ~ WH1,P3 ~ SKP, P4 ~ WT); 02950400 + BEGIN DI ~ P1; DI ~ DI + P3; 02950500 + SI ~ LOC P2; SI ~ SI + 2; 02950600 + DS ~ P4 CHR; P1 ~ DI; 02950700 + END; 02950800 +BUFF ~ P; 02950900 +GO TO COMM; 02951000 + L: COMMENT LOGICIAL CONVERSION; 02951100 + IF W >1 THEN SKP~W-(WT~1); 02951200 + WH1~ 0&(IF WH1 THEN "T" ELSE "F")[12:42:6]; 02951300 + GO TO AA; 02951400 + I: COMMENT INTEGER CONVERSION; 02951500 + IF WH1=0 AND WH2=0 THEN DT ~ D3 ~ 1 ELSE 02951600 + BEGIN IF DTOG THEN 02951700 + DOUBLE(WH1,WH2,,.5,+,~,WH1,WH2) % ROUND OFF 02951800 + ELSE WH1 ~ T1 ~ WH1; 02951900 + IF WH1=0 AND WH2=0 THEN EXP~-1 ELSE FINDE ; 02952000 + IF EXP < 0 THEN DT ~ D3 ~ 1 ELSE 02952100 + BEGIN 02952200 + IF (DLN AND EXP}24) OR (NOT DLN AND EXP}12) THEN GO AST; 02952300 + DT ~ EXP+1; SETD; NUMCONVERT; 02952400 + END; 02952500 + END; 02952600 + IF DT + SGN > W THEN GO TO AST; 02952700 + IF W > DT + SGN THEN SKP ~ W - DT - SGN; 02952800 +STREAM(P1~0:P2 ~ D1,P3 ~ DH1,P4 ~ D2,P5 ~ DH2, 02952900 + P6 ~ D3,P7 ~ DH3,P8 ~ SGN,P9 ~ SKP,P10 ~ BUFF); 02953000 + BEGIN DI ~ P10; P9(DI ~ DI + 1); 02953100 + P8(DS ~ LIT "-"); 02953200 + SI ~LOC P3; DS ~ P2 DEC; 02953210 + SI ~ LOC P5; DS ~ P4 DEC; 02953300 + SI ~ LOC P7; DS ~ P6 DEC; 02953400 + P1 ~ DI; 02953500 + END; 02953600 +BUFF ~ P; 02953700 +GO TO COMM; 02953800 + DC: COMMENT DOUBLE PRECISION CONVERT,SAME AS E CONVERT; 02953900 + E: COMMENT E CONVERSION; 02954000 + DTOG ~ TRUE; 02954100 + SETD; 02954200 + IF WH1=0 AND WH2 = 0 THEN 02954300 + BEGIN 02954400 + IF W < (D+6+ SGN) THEN GO TO AST; 02954500 + FUNNYZERO; GO TO COMM; 02954600 + END ELSE 02954700 + BEGIN 02954800 + FINDE; 02954900 + IF PS { 0 THEN 02955000 + BEGIN 02955100 + IF (SKP ~ W - D - 5 - SGN) < 0 THEN GO TO AST; SETD; 02955200 + IF (DT ~ DT + PS) < 0 THEN DT ~ 0; 02955300 + T1 ~ EXP - DT; RNDOFF; 02955400 + END ELSE 02955500 + BEGIN 02955600 + DT ~ DT + (SHFT ~ PS); SETD; 02955700 + T1 ~ EXP - DT; RNDOFF; 02955800 + IF W<(T1~DT+5+ SGN + ZEROS) THEN GO TO AST; 02955900 + SKP~W-T1; 02956000 + END; 02956100 + T1~DT-1-EXP; SCALE; 02956200 + NUMCONVERT; 02956300 + EXP~EXP-PS; 02956400 + END; 02956500 +STREAM(P1 ~ 0:P2 ~ SKP,P3 ~ SGN,P4 ~ D1,P5 ~ DH1, 02956600 + P6 ~ D2,P7 ~ DH2,P8 ~ D3,P9 ~ DH3,P10 ~ (DLN), 02956700 + P11 ~ (EXP < 0),P12 ~ ABS(EXP),P13 ~ SHFT,P14 ~ ZEROS,P15 ~BUFF);02956800 + BEGIN DI ~ P15; DI ~ DI + P2; P3(DS ~ LIT "-"); 02956900 + P2 ~ DI; DS ~ LIT "."; 02957000 + SI ~ LOC P5; DS ~ P4 DEC; 02957100 + SI ~ LOC P7; DS ~ P6 DEC; 02957200 + SI ~ LOC P9; DS ~ P8 DEC; 02957300 + P14(DS ~ LIT " "); DS ~ LIT "E"; 02957400 + P10(DI ~ DI - 1; DS ~ LIT "D"); 02957500 + DS ~ LIT " " ; 02957600 + P11(DI ~ DI - 1; DS ~ LIT "-"); 02957700 + SI ~ LOC P12; DS ~ 2 DEC; 02957800 + P1 ~ DI; 02957900 + P13(DI ~ P2; SI ~ P2; SI ~ SI + 1; 02958000 + DS ~ P13 CHR; DS ~ LIT "."; JUMP OUT TO X); X: 02958100 + END; 02958200 +BUFF ~ P; 02958300 + GO TO COMM; 02958400 + F: COMMENT F CONVERSION; 02958500 + IF DTOG THEN 02958600 + IF PS>0 02958700 + THEN DOUBLE(WH1,WH2,TEN[PS],TEN[69+PS],|,~,WH1,WH2) 02958800 + ELSE DOUBLE(WH1,WH2,TEN[-PS],TEN[69-PS],/,~,WH1,WH2) 02958900 + ELSE WH1 ~ IF PS > 0 THEN WH1|TEN[PS] ELSE WH1/TEN[-PS]; 02959000 + FA: IF WH1=0 AND WH2=0 THEN EXP~0 ELSE 02959100 + BEGIN 02959200 + T1 ~ -(DT+1); RNDOFF; 02959300 + FINDE; 02959400 + IF EXP<0 THEN EXP~0; 02959500 + IF (T1~DT+EXP+1)> 12 THEN DT~DT-(ZEROS~T1-12); 02959600 + T1 ~ DT; SCALE; 02959700 + IF ABS(WH1) > MAX THEN 02959800 + BEGIN 02959900 + DT ~ DT - 1; ZEROS ~ ZEROS + 1; 02960000 + T1 ~ -1; SCALE; 02960100 + END; 02960200 + END; 02960300 + DT~DT + EXP +1; SETD; 02960400 + IF W<(T1~D+2+ SGN + EXP) THEN GO TO AST; 02960500 + SKP~W-T1; 02960600 + NUMCONVERT; 02960700 +STREAM(P1 ~ 0:P2 ~ SKP,P3 ~ SGN,P4 ~ D1,P5 ~ DH1, 02960800 + P6 ~ D2,P7 ~ DH2,P8 ~ D3,P9 ~ DH3,P10 ~ ZEROS, 02960900 + P11 ~ EXP,P12 ~ BUFF); 02961000 + BEGIN DI ~ P12; DI ~ DI + P2; P3(DS ~ LIT "-"); 02961100 + P2 ~ DI; DS ~ LIT "."; 02961200 + SI ~ LOC P5; DS ~ P4 DEC; 02961300 + SI ~ LOC P7; DS ~ P6 DEC; 02961400 + SI ~ LOC P9; DS ~ P8 DEC; 02961500 + P10(DS ~ LIT "0"); 02961600 + P1 ~ DI; 02961700 + P11(DI ~ P2; SI ~ P2; SI ~ SI + 1; DS ~ P11 CHR; 02961800 + DS ~ LIT "."; JUMP OUT TO X); X: 02961900 + END; 02962000 +BUFF ~ P; 02962100 + IF GTOG THEN GO TO GA; 02962200 + GO TO COMM; 02962300 + G: COMMENT G CONVERSION; 02962400 + GTOG ~ TRUE; 02962500 + IF WH1=0 AND WH2=0 THEN EXP~0 ELSE FINDE; 02962600 + IF (GTOGA~W-D-SGN>4) THEN 02962610 + IF EXP< (-1) THEN GO TO E; 02962700 + IF (T1~D-EXP-1)<0 AND GTOGA THEN GO TO E; 02962800 + WT ~ D; W ~ W-4; 02962900 + D ~ DT ~ T1; 02963000 + GO TO FA; 02963100 +GA: 02963200 +STREAM(P1 ~ 0:P2 ~ BUFF); 02963300 + BEGIN DI ~ P2; DI ~ DI + 4; P1 ~ DI; END; 02963400 +BUFF ~ P; 02963500 +W ~ W + 4; D ~ WT; 02963600 +GO TO COMM; 02963700 +AST: 02963800 +STREAM(P1 ~ 0:P2 ~ BUFF,P3 ~ W); 02963900 + BEGIN DI ~ P2; P3(DS ~ LIT "*"); P1 ~ DI; END; 02964000 +BUFF ~ P; 02964100 +IF GTOG THEN GO TO GA; 02964150 +COMM: 02964200 +END CONVERT; 02964300 +COMMENT * * * * * * * * * * END OF DECLARATIONS * * * * * * * * * * * ; 02964400 +IF EDITCODE=0 OR EDITCODE=2 OR EDITCODE=4 THEN 02964405 + BEGIN 02964410 + P(MKS,FILX,DKADR) ; 02964415 + IF EDITCODE=4 THEN P(FI,FMTA,INTCALL(*P(.LISX),@155)) 02964420 + ELSE P((-1),FMTA,*P(.LISX),EDITCODE,0,INTCALL(0,@160)) ; 02964425 + P(XIT) ; 02964430 + END ; 02964435 +IF EDITCODE=6 THEN GO ZAP; 02964450 +FIB ~ FILX[NOT 2]; % OPEN FILE IF NOT OPEN 02964500 +IF DKADR < 0 THEN BEGIN FLG ~ 1; DKADR ~0 END; 02964510 +IF FIB[5].[43:1] THEN P(MKS,0,0,FILX,1,SELECT); 02964600 +PRNTR~2|(FIB[5].[41:2]!0) ; %%% IFF FILE IS CLOSED, SETS PRNTR.[46:1]=1.02964610 +CKPB; ARRAYSTUFF ~ 0; 02964700 + IF FIB[0] = 0 THEN 02964710 + FIB[0] ~ 1 + (EDITCODE =0 OR EDITCODE =2) 02964720 + ELSE 02964730 + IF FIB [0] !1 + (EDITCODE =0 OR EDITCODE = 2) 02964740 + THEN P(MKS,FIB[6],FILX.[33:15],4,FORTERR); 02964750 +IF PRNTR THEN STREAM(TPAR); DS~8LIT" " ; 02964765 +GO TO P(EDITCODE,DUP,ADD); 02964800 +GO TO NOFL; % NO FORMAT, NO LIST 02964900 +GO TO FNOL; % FORMAT, NO LIST 02965000 +GO TO BINARY; % NO FORMAT, LIST 02965100 +GO TO FMTLST; % FORMAT, LIST 02965200 + NOFL: 02965400 +P(XIT) ; 02965500 + FNOL: 02965700 + LSTRN~-1; 02965800 + GO TO FRMTCD; 02965900 + NMLST: 02966000 + P(XIT); 02966100 + BINARY: 02971000 +P(XIT) ; 02971100 + FMTLST: 02973100 + LSTRN ~ 1; 02973200 + CTOG ~ DONETOG ~ FALSE; 02973300 + GETLIST; 02973400 + FRMTCD: 02973500 + PS ~ 0; 02973600 + NFCI ~ (FI|8) + 2; % FIRST FORMAT CHARACTER 02973700 + IF NOT(NFC="(" OR CHR="%") THEN GO TO FMERR ; 02973800 + NFCI ~ (FI|8) + 2; 02973900 + NFPH: FORMATCONTROL; % ANAYLSIS OF FORMAT STATEMENT 02974000 + IF FMERRTOG THEN GO TO FMERR; 02974100 + FMCYC: IF(DONETOG ~ ENDLIST) THEN 02974200 + IF EDITCODE=6 THEN GO ZIPIT ELSE PRNT; 02974250 + IF W + NCR > LCR THEN GO TO FMERR; 02974300 + NCR ~ W + NCR; 02974500 + CONVERT; 02974600 + GETLIST; 02974700 + IF (RPT~RPT-1) > 0 THEN GO TO FMCYC; 02974800 + IF EDITCODE=6 THEN GO ZIPIT ELSE 02974850 + GO TO NFPH; 02974900 + ZAP:RPT~27;CODE~ATYPE;W~WT~6;D~0;BUFF~TPAR.[33:15];GETLIST; 02974950 + LCR~168; GO FMCYC; 02974953 + ZIPIT: STREAM(P1~BUFF); BEGIN DI~P1; DS~ 5 LIT ";END."; END; 02974954 + P(.TPAR,LOD,4,COM,DEL); 02974956 + BUFF ~ TPAR.[33:15]; 02974958 + STREAM(P1~BUFF);BEGIN DI~P1; 17(DS ~ 8 LIT " ");END; 02974960 + P(XIT); 02974962 +FMERR: 02975000 + P(MKS,FIB[6],FILX.[33:15],0,FORTERR); 02975100 + TYPERR: 02975200 + P(MKS,FIB[6],FILX.[33:15],2,FORTERR); 02975210 + END FTOUT; 02975300 +PROCEDURE FORTRANFREEWRITE(FILX,DKADDR,R,W,LISX,NI,NAMS,SUBS) ;%INT @15302976020 +VALUE DKADDR,R,LISX,W,NI; INTEGER R,W; REAL DKADDR,LISX,NI ; 02976035 +ARRAY SUBS[*], NAMS[*]; NAME FILX ; 02976050 + BEGIN 02976065 + 02976080 + INTEGER LSTRN=19, E, CHR, MAXCHR, PRNTR, TYPE, INDX, SIZE, 02976095 + WDTH, MAXWDTH, SGN, CC ; 02976110 + 02976125 + REAL LISTYPE=20, ARRAYSTUFF=18, ALGOLWRITE=12, SELECT=14, T1, NID, 02976140 + T2, FORTERR=24, BUFF, BSIZE, FLG, WH1=R, D, WH2, ARY, T3, WH1S,02976155 + RNDUP=9, MNTSSA=17, FNR, FNL, ENR, MS3, DECPT, LSS1, SVMAXWDTH,02976170 + GTRMI, WH3, HALF, TRZ, NN1, TWDT, VH=-1, VL=-2, TIPE=-4 ; 02976185 + 02976200 + NAME LISTADDR ; 02976215 + 02976230 + ARRAY TEN=22[*], AR1=LISTADDR[*], TPAR=23[*], FPB=3[*], FIB[*] ; 02976245 + 02976260 + LABEL BACK, START, ITYPE, ALIST, TRU, FALS, TWOPT5, MAXI, SETUP, 02976275 + LOG8, FTYPE, ETYPE, FUNNYE, CHOOSEI, OVRFLW, FIVEPT, GET3, 02976290 + HUNT, ZERO, HLF, NOFIT, GOTOQ, ZEROES, FITYPE, ETYPE2, Q, 02976305 + ETYPE1, DFTYPE, DTYPE, BUMPWH3, THREL, THREH, MAXWDTHOF1, Q1, 02976320 + MAXI1 ; 02976321 + 02976335 + DEFINE DONE = (LSTRN=(-1)) #, 02976350 + REEL = 3 #, 02976365 + LOGICAL = 4 #, 02976380 + INTEGR = 1 #, 02976395 + DBLPREC = 5 #, 02976410 + COMPLEXR = 6 #, 02976425 + COMPLEXI = 7 #, 02976440 + MAYBE(MAYBE1,MAYBE2,MAYBE3) = CI~CI+MAYBE1; GO TO MAYBE2 ; 02976455 + DS~LIT MAYBE3; MAYBE2: #, 02976470 + TWOD = LISTYPE.[38:1] #, 02976485 + INDXF = [18:15] #, 02976500 + TYPEF = [44:4] #, 02976515 + SIZEF = [33:15] # ; 02976530 + 02976545 + SUBROUTINE GETWDTH ; 02976560 + WDTH~((FNR~E+RNDUP)9) ; 02976575 + 02976590 + REAL SUBROUTINE FTEST ; 02976605 + FTEST~P(XCH)+(FNR~T2-FNL~FNL-LSS1)<(-E) OR FNR<0 ; 02976620 + 02976635 + REAL SUBROUTINE NXTELM ; 02976650 + BEGIN 02976665 + P(IF TWDT THEN P(*[AR1[INDX.[33:7]]],INDX.[40:8],COC) 02976680 + ELSE AR1[INDX]) ; 02976695 + INDX~INDX+1; NXTELM~P ; 02976710 + END OF NXTLLM ; 02976725 + 02976740 + SUBROUTINE COUNTZ ; 02976755 + BEGIN 02976770 + T3~0 ; 02976785 +HUNT: IF LISTYPE MOD TEN[T3~T3+3]=0 THEN GO HUNT ; 02976800 + IF LISTYPE MOD TEN[T1~T3-1]!0 02976815 + THEN T1~T1-1-(LISTYPE MOD TEN[T1-1]!0) ; 02976830 + END OF COUNTZ ; 02976845 + 02976860 + REAL SUBROUTINE USEXPNOTATION ; 02976875 + BEGIN 02976890 + FNL~IF LSS1 THEN P((-E),1) ELSE P(0,E+1) ; 02976905 + IF (FNR~P+ENR-FNL-T1){0 THEN FNR~1 ; 02976920 + USEXPNOTATION~(FNR+FNL>1+(ENR~ENR-T1)+((DECPT~1)+T3~(-1>E)+ 02976935 + (ABS(E+1)>9))+(TRZ OR LSS1) AND (ABS(E)}4 OR 02976950 + FNL+FNR>MS3+2)) OR (ENR+T3{MS3 AND ABS(E)}5) ; 02976965 + END OF USEXPNOTATION ; 02976980 + 02976995 + SUBROUTINE ROUNDANDSPLIT ; 02977010 + BEGIN 02977025 + T1~T2~LISTYPE~0; T3~RNDUP+7 ; 02977040 + IF (MNTSSA~GTRMI-7-RNDUP) LSS 0 THEN 02977055 + BEGIN 02977070 + P(WH3/TEN[-MNTSSA]-1,.WH3,ISD); T3~GTRMI ; 02977085 +BUMPWH3: IF (WH3~WH3+1)=TEN[T3] THEN E~(LISTYPE~1)+E ; 02977100 + END 02977115 + ELSE IF MNTSSA LSS 8 THEN 02977130 + BEGIN 02977145 + IF P(WH2/TEN[8-T2~MNTSSA],.WH2,ISN)=TEN[MNTSSA] 02977160 + THEN GO BUMPWH3 ; 02977175 + END 02977190 + ELSE IF P(WH1/TEN[16-MNTSSA],.WH1,ISN)=TEN[T1~MNTSSA-T2~8] 02977205 + THEN IF (WH2~WH2+1)=TEN[8] THEN GO BUMPWH3 ; 02977220 + END OF ROUNDANDSPLIT ; 02977235 + 02977250 + SUBROUTINE OUTPUT ; 02977265 + BEGIN 02977280 + IF PRNTR THEN 02977295 + BEGIN 02977310 + FIB[17]~FIB[17]+BSIZE ; 02977325 + P(MKS,2,0,CC,BSIZE,FILX,ALGOLWRITE) ; 02977340 + IF NOT(*FILX).[1:19] 02977355 + $ SET OMIT = TIMESHARING 02977370 + $ SET OMIT = NOT(TIMESHARING ) 02977400 + THEN IF FIB[4].[8:4]!10 02977415 + THEN P(FILX,@2000000000,36,COM,DEL,DEL) ; 02977430 + $ POP OMIT 02977431 + END 02977445 + ELSE IF NOT CC THEN P(MKS,FLG,DKADDR,0,BSIZE,FILX,ALGOLWRITE) ;02977460 + P(MKS,FLG,DKADDR,CHR~0,(-1),FILX,ALGOLWRITE,DEL) ; 02977475 + IF PRNTR THEN FIB[17]~FIB[17]-BSIZE ; 02977490 + STREAM(BS~BSIZE-1,B~P(DUP).[36:6],BUF~BUFF~(*FILX).[33:15]) ; 02977505 + BEGIN 02977520 + DS~8LIT" "; SI~BUF; DS~BS WDS; B(DS~32WDS; DS~32WDS) ; 02977535 + END ; 02977550 + END OF OUTPUT ; 02977565 + 02977580 + SUBROUTINE CHECKBUMPANDSKIP ; 02977595 + BEGIN 02977610 + IF P(W+MAXWDTH-WDTH,DUP){0 THEN P(DEL,0) ; 02977625 + IF P(P(DUP)+WDTH+2+SVMAXWDTH-MAXWDTH,DUP)+CHR>MAXCHR 02977640 + THEN OUTPUT ; 02977655 + CHR~P+CHR ; 02977670 + STREAM(SKP~LSS1~P:L~LSS1.[36:6],BUFF) ; 02977685 + BEGIN DI~DI+SKP; L(DI~DI+32; DI~DI+32); SKP~DI END ; 02977690 + BUFF~P ; 02977695 + IF NID!NI THEN 02977700 + BEGIN 02977715 + STREAM(N~(LSS1~NAMS[NID]).[9:3]:LSS1,T~(NN1}0),BUFF) ; 02977730 + BEGIN 02977745 + SI~LOC LSS1; SI~SI+2; DS~N CHR; MAYBE(T,L,"("); N~DI;02977760 + END ; 02977775 + BUFF~P ; 02977790 + FOR MS3~0 STEP 1 UNTIL NN1 DO 02977805 + BEGIN 02977820 + STREAM(N~SUBS[MS3].[15:3]:Q~SUBS[MS3].[33:15],BUFF) ;02977835 + BEGIN SI~LOC Q; DS~N DEC; DS~LIT","; N~DI END ; 02977850 + BUFF~P ; 02977865 + END ; 02977880 + STREAM(T~(NN1}0):R~TYPE=COMPLEXR,I~TYPE=COMPLEXI,BUFF) ; 02977895 + BEGIN 02977910 + CI~CI+T; GO TO L; DI~DI-1; DS~LIT")"; L: 02977925 + CI~CI+R; GO TO L1; DS~2LIT"-R"; L1: 02977940 + CI~CI+I; GO TO L2; DS~2LIT"-I"; L2: DS~LIT"="; T~DI ;02977955 + END ; 02977970 + BUFF~P ; 02977985 + END ; 02978000 + END OF CHECKPUMPANDSKIP ; 02978030 + 02978045 + SUBROUTINE BASICONVERT ; 02978060 + BEGIN 02978075 + IF TYPE!DBLPREC THEN 02978090 + BEGIN T3~0 ; 02978105 + IF E>8 THEN BEGIN WH2~WH1 DIV TEN[8]; T2~E-T1~8 END 02978120 + ELSE BEGIN T2~0; T1~E END ; 02978135 + END ; 02978150 + WDTH~WDTH+T1+T2+T3+SGN+DECPT ; 02978165 + CHECKBUMPANDSKIP ; 02978180 + STREAM(WH3:WH2,WH1,T3,T2,T1,FNL,DECPT,ENR,SGN,TRZ,BUFF) ; 02978195 + BEGIN 02978210 + MAYBE(SGN,L1,"-"); SGN~DI ; 02978215 + DI~DI+DECPT; ENR(DS~LIT"0"); SI~LOC WH3; DS~T3 DEC ; 02978225 + SI~LOC WH2; DS~T2 DEC; SI~LOC WH1; DS~T1 DEC ; 02978240 + TRZ(DS~LIT"0"); WH3~DI; CI~CI+DECPT; GO TO L ; 02978255 + SI~SGN; SI~SI+1; DI~SGN; DS~FNL CHR; DS~LIT"."; L: 02978270 + END ; 02978285 + P(XCH) ; 02978300 + END OF BASICONVERT ; 02978315 + 02978330 + SUBROUTINE FINDE ; 02978345 + E~(0&T1[42:3:6]&T1[1:2:1]+12+P(HLF))|P(LOG8) ; 02978360 + 02978375 + SUBROUTINE GETW ; 02978390 + IF (T1~P(XCH))}W~MAXCHR/R-P(TWOPT5) THEN W~T1 02978405 + ELSE IF (T1~IF NAMS=0 THEN 30 ELSE P(NAMS[NI],DUP)|6+(P(XCH)>0)02978420 + +37)5 THEN DO UNTIL FALSE ; 02978497 + W~(W~ABS(W))-SVMAXWDTH~MAXWDTH~IF W!0 THEN W ELSE 62 ; 02978499 + MAXCHR~64; GO Q1 ; 02978501 + END ; 02978503 + FIB~FILX[NOT 2]; IF DKADDR<0 THEN BEGIN FLG~1; DKADDR~0 END ; 02978510 + D~IF R.[1:1] THEN "," ELSE " "; R~ABS(R) ; 02978525 + IF FIB[5].[43:1] THEN P(MKS,0,0,FILX,1,SELECT) ; 02978540 + CC~(FIB[5] AND 96)!0 ; 02978555 + P(MKS,FLG,DKADDR,0,(-1),FILX,ALGOLWRITE) ; 02978560 + IF P(*[FIB[14]],TOP) THEN P(DEL) 02978565 + ELSE P((T1~(*(4 INX P(XCH))).[36:6])!0 AND T1!8 AND T1!9,SUB) ; 02978570 + MAXCHR~P(BSIZE~P)|8 ; 02978575 + IF PRNTR~((T1~FIB[4].[8:4])=1 OR T1=7 OR T1=12) AND FPB[FIB[4] 02978585 + .[13:11]+3].[43:5]<20 THEN 02978590 + BEGIN IF BSIZE>16 THEN BEGIN MAXCHR~132; BSIZE~17 END; END 02978600 + ELSE CC~1 ; 02978615 + OUTPUT ; 02978630 + IF (CC~0)=FIB[0] THEN FIB[0]~1 ; 02978645 + IF (LSTRN~1)!FIB[0] AND T1=2 02978660 + THEN P(MKS,FIB[7],FILX.[33:15],4,FORTERR) ; 02978661 + MAXWDTH~MAXCHR-2 ; 02978675 + IF (W~ABS(W))!0 THEN 02978690 + BEGIN 02978705 + IF W>MAXWDTH THEN W~MAXWDTH ELSE MAXWDTH~W ; 02978720 + IF R!0 THEN BEGIN P(MAXWDTH); GETW END ; 02978735 + END 02978750 + ELSE IF R!0 THEN BEGIN P(1); GETW; MAXWDTH~W END ; 02978765 + W~W-SVMAXWDTH~MAXWDTH ; 02978780 + GO START ; 02978795 +HLF::: 0.5 ; 02978810 +LOG8::: 0.90308998709 ; 02978825 +TWOPT5:::2.4999999999 ; 02978840 +MAXI1::: @0007777777777777 ; 02978842 +BACK:: 02978855 + BUFF~P; IF NI<0 THEN P(BUFF,RTN); TYPE~ABS(TYPE) ; 02978870 + STREAM(D:BUFF); BEGIN SI~LOC D; SI~SI+7; DS~CHR; DI~DI+1; D~DI END ;02978885 + BUFF~P ; 02978900 +START: 02978915 + IF ARY THEN 02978930 + BEGIN 02978945 +ALIST: WH1~NXTELM ; 02978960 + IF NID!NI THEN 02978975 + BEGIN 02978990 + P(INDX-ARRAYSTUFF.INDXF) ; 02979005 + IF TYPE}DBLPREC THEN P((P+1) DIV 2); T2~P ; 02979020 + IF TYPE}COMPLEXR THEN TYPE~COMPLEXR+(TYPE=COMPLEXR) ; 02979035 + FOR T1~NN1 STEP -1 UNTIL 0 DO 02979050 + BEGIN 02979065 + SUBS[T1].[33:15]~1+(T2-1) DIV (MS3~SUBS[T1].[18:15]);02979080 + IF (T2~T2 MOD MS3)=0 THEN T2~MS3 ; 02979095 + END ; 02979110 + END ; 02979125 + IF TYPE=DBLPREC THEN WH2~NXTELM; ARY~INDXMAXWDTH THEN WDTH~MAXWDTH ; 02979785 + CHECKBUMPANDSKIP ; 02979800 + STREAM(S~IF WH1 THEN P(TRU) ELSE P(FALS):Z~T1~WDTH>1, 02979815 + Q~T2~WDTH>2,WDTH~WDTH-T1-T2,F~3+WH1,BUFF) ; 02979830 + BEGIN 02979845 + SI~LOC S; SI~SI+F; MAYBE(Z,L1,".") ; 02979860 + DS~WDTH CHR; MAYBE(Q,L2,"."); S~DI ; 02979875 + END ; 02979890 + GO BACK ; 02979905 + END OF LOGICAL ; 02979920 + SGN~WH1.[1:1] ; 02979935 +Q: IF T3~NOT (GTRMI~ABS(WH1)>P(MAXI)) AND TYPE=INTEGR 02979950 + THEN P(WH1,.WH1,ISD) ; 02979965 + T2~(MS3~MAXWDTH-3-SGN)+2; WH1~ABS(WH1) ; 02979980 + IF TYPE=DBLPREC THEN 02979995 + BEGIN 02980010 + WH1~T1~P(WH2,WH1,0,TEN[0],DLM); WH2~P ; 02980025 + IF WH1=0 THEN BEGIN TYPE~-DBLPREC; GO ZERO END; FINDE ; 02980040 + IF MAXWDTH<7 02980055 + THEN P(WH2,WH1,HALF,(NOT P(MAXI)) AND WH1,DLA,.WH1S,~,DEL) ; 02980070 + IF LSS1~E LSS 0 THEN P(0,TEN[0],TEN[69-E],TEN[-E],DLD) 02980085 + ELSE P(TEN[69+E],TEN[E]) ; 02980100 + T1~P; T3~P ; 02980115 + IF T1 GEQ WH1 THEN IF T1>WH1 OR T3>WH2 THEN E~E-1 ; 02980130 + ENR~24 ; 02980145 + P(WH2,WH1,TEN[69+ABS(E)],TEN[ABS(E)],IF LSS1~E LSS 0 THEN 02980160 + P(DLM) ELSE P(DLD)) ; 02980175 + T1~P; T3~P ; 02980190 + IF T1}P(THREH) THEN IF T1>P(THREH) OR T3>P(THREL) THEN ENR~23 ;02980205 + P(WH2,WH1,TEN[(T1~ABS(ENR-E-1))+69],TEN[T1],IF ENR{E THEN 02980220 + P(DLD) ELSE P(DLM)) ; 02980235 + WH1~P; RNDUP~ENR=24 ; 02980250 + P(T3~P,WH1,TEN[85],TEN[16],DLD,HALF,-,.WH3,ISD,DEL,T3,WH1,0,WH302980265 + ,TEN[85],TEN[16],DLM,DLS) ; 02980280 + WH1~P ; 02980295 + P(T3~P,WH1,0,TEN[8],DLD,HALF,-,.WH2,ISD,DEL,T3,WH1,0,WH2,0,TEN[02980310 + 8],DLM,DLS,.WH1,ISD,DEL) ; 02980325 + IF P(0,0)=LISTYPE~WH1 THEN 02980340 + BEGIN P(DEL,8) ; 02980355 + IF (LISTYPE~WH2)=0 THEN BEGIN P(DEL,16); LISTYPE~WH3 END ;02980370 + END ; 02980385 + COUNTZ; T1~P+T1 ; 02980400 + IF USEXPNOTATION THEN 02980415 + BEGIN 02980430 +DTYPE: IF ENR+T3>MS3 THEN 02980445 + IF E=T2 THEN BEGIN DECPT~FNR~0; GO DFTYPE END 02980460 + ELSE IF (ENR~MS3-T3){0 THEN 02980475 +GOTOQ: BEGIN WH1~WH1S; TYPE~-DBLPREC; GO Q END ; 02980490 + GTRMI~ENR; ROUNDANDSPLIT ; 02980505 + IF NOT (9!E OR T3!1) THEN GO GOTOQ ; 02980520 + IF LISTYPE THEN P(TEN[(T3~T3+(IF LSS1 THEN -10=E ELSE -(9=02980535 + E)))-1],.WH3,ISD) ; 02980550 + RNDUP~1; GO ETYPE1 ; 02980565 +MAXI::: @0007777777777777 ; 02980580 +THREH::: @1143013331500045 ; 02980595 +THREL::: @0003112121167260 ; 02980610 +TRU::: "TRUE" ; 02980625 +FALS::: "FALSE" ; 02980640 + END ; 02980655 + IF FNL+FNR{T2 THEN 02980670 + BEGIN 02980685 +DFTYPE: ENR~TRZ~0; T1~FNL ; 02980700 + IF LSS1 THEN ENR~FNL-E-1 02980715 + ELSE IF 23+RNDUP{FNL THEN 02980730 + BEGIN TRZ~FNL+FNR-T1~23+RNDUP; FNR~0 END ; 02980745 + GTRMI~T1+FNR-ENR; ROUNDANDSPLIT ; 02980760 + IF LISTYPE THEN 02980775 + BEGIN 02980790 + IF DECPT THEN DECPT~FNR+TRZ}1 02980805 + ELSE BEGIN 02980820 + T1~T2~0; DECPT~WH3~T3~RNDUP~1; GETWDTH ; 02980835 + IF (TRZ~-WDTH+WDTH~MS3+1){0 THEN GO GOTOQ ; 02980850 + GO ETYPE2 ; 02980865 + END ; 02980880 + FNL~FNL+(E}0) ; 02980895 + IF LSS1 THEN IF NOT (TRZ~(ENR~ENR-1)}0) THEN ENR~0 ; 02980910 + IF T35); IF NOT FTEST THEN GO DFTYPE ; 02981000 + GO DTYPE ; 02981015 + END OF DBLPREC ; 02981030 + IF MAXWDTH=1 THEN GO TO MAXWDTHOF1 ; 02981045 + T1~TEN[0]|WH1 ; 02981060 + IF E~WH1!0 THEN 02981075 + BEGIN FINDE; E~E-((IF E>0 THEN TEN[E] ELSE 1/TEN[-E])>T1) END ;02981090 + IF T3 AND E{T2 THEN 02981105 + BEGIN E~E+1 ; 02981120 +ITYPE: DECPT~0; GO SETUP ; 02981135 + END ; 02981150 + IF WH1=0 THEN 02981165 +ZERO: BEGIN FNR~0; FNL~1; GO FTYPE END ; 02981180 + RNDUP~(MNTSSA~P(WH1~T1,TEN[ABS(E)],IF LSS1~0>E THEN 02981195 + P(|) ELSE P(/))) GEQ 5 ; 02981210 + LISTYPE~P(WH1,TEN[ABS((ENR~12-(MNTSSA>P(FIVEPT)))-E-1)], 02981225 + IF GTRMI THEN P(/) ELSE P(|)) ; 02981240 + COUNTZ ; 02981255 + IF GTRMI OR USEXPNOTATION THEN 02981270 + BEGIN 02981285 + IF ENR+T3 LEQ MS3 THEN 02981300 +ETYPE: BEGIN 02981315 + P(WH1) ; 02981330 + IF NOT RNDUP~TYPE!INTEGR OR DECPT=0 THEN 02981345 + BEGIN 02981360 + ENR~P(E}10 AND (E~E-ENR){10,DUP)+1+ENR ; 02981375 + DECPT~0; P(TEN[E~-P+E],/) ; 02981390 + END 02981405 + ELSE P(TEN[ABS(E+1-ENR)],IF E0)-1],.WH1,ISD) END;02981915 +SETUP: ENR~TRZ~0; GO FITYPE ; 02981930 + END ; 02981945 + IF FNR+FNL LEQ T2 THEN GO FTYPE ; 02981960 + IF LSS1 AND SGN THEN IF MAXWDTH=2 THEN GO MAXWDTHOF1 ; 02981975 + P(RNDUP); IF NOT FTEST THEN GO FTYPE ; 02981990 + GO FUNNYE ; 02982005 +MAXWDTHOF1: 02982020 + E~0 ; 02982035 +CHOOSEI: 02982050 + IF NOT GTRMI THEN P(WH1,.WH1,ISD) ; 02982065 + IF TEN[E~E+1]=WH1 THEN GO GET3 ; 02982080 + IF P(MAXWDTH=1,DUP) THEN SGN~SGN AND WH1!0 ; 02982095 + IF NOT (P AND (SGN OR WH1>9)) THEN GO ITYPE ; 02982110 +OVRFLW: 02982125 + WDTH~MAXWDTH; P(NID); NID~NI; CHECKBUMPANDSKIP; NID~P ; 02982140 + STREAM(SVMAXWDTH:S~SVMAXWDTH.[36:6],BUFF) ; 02982155 + BEGIN SVMAXWDTH(DS~LIT"|"); S(32(DS~2LIT"|"));SVMAXWDTH~DI END;02982160 + GO BACK ; 02982170 + END OF FORTRANFREEWRITE ; 02982185 +PROCEDURE FINNAME; %154 02982500 + BEGIN 02982520 +COMMENT FILX FILE TOP IO DESCRIPTOR 02982540 + FMTA FORMAT OR NAMELIST OR 0 02982560 + LISX ACCIDENTAL ENTRY DESC. OR 0 02982580 + ; 02982600 +REAL PARL = -1, 02982740 + EOFL = -2, 02982760 + FORTERR = 24, 02982780 + LISX = -3, 02982820 + FI = -5, 02982840 + DKADR = -6, 02982860 + READINT = 13, 02982880 + SELECT = 14; 02982900 +ARRAY FMTA = -4[*]; 02982920 +NAME FILX = -7, 02982940 + MEM = 2; 02982960 +INTEGER JUNK1 = 17; 02982980 +REAL LISTYPE = 20; 02983000 +ARRAY PRTBASE = 10[*], 02983020 + TEN = 22[*], 02983040 + FIB[*]; 02983060 +NAME LISTADR; 02983080 +REAL BUFF , % FIRST BUFFER POSITION 02983100 + BSIZE , % ARGUMENTS 02983120 + NBC, 02983140 + NLI,NLE,SBS, 02983160 + NFCI, 02983180 + DH1, 02983200 + WH1 , % 02983220 + WH2; 02983240 +REAL NAMEV; 02983260 +NAME W1; 02983280 +INTEGER RPT, 02983300 + W , % FIELD 02983320 + WT , % WIDTH 02983340 + T1 , % 02983360 + D1 , % LA- 02983380 + D2 , % CE- 02983400 + CNT, 02983420 + EXP , % EXPONENT 02983440 + EXPSGN, 02983460 + NCR , % CURRENT BUFFER POSITION 02983480 + LCR , % BUFFER SIZE IN CHARACTERS 02983500 + CHR ; 02983520 +BOOLEAN DONETOG , % RETURN AFTER WRITE 02983540 + SGN , % SIGN 02983560 + LGTG, 02983580 + DTAERR, 02983600 + NLT, 02983620 + NFL, 02983625 + CTOG; 02983640 +DEFINE LOGV = 4#, 02983660 + INTEGV =1#, 02983680 + DBLV = 5#, 02983700 + CMPLXV = 6#, 02983720 + SPC = 3#, 02983740 + NUM = 2#, 02983760 + ID = 1#, 02983780 + KIND = (FIB[4].[8:4])#, 02983800 + MAX = @7777777777777#, 02983820 + ELMTYP = LISTYPE . [44:4]#, 02983840 + DLN = (LISTYPE.[44:4] = DBLV)#, 02983860 + CMPLX = (LISTYPE.[44:4] = CMPLXV)#, 02983880 + TWOD = LISTYPE.[38:1]#, 02983900 + SIZEF = [33:15]#, 02983920 + BASEF = [18:15]#; 02983940 +LABEL NMLST,NLERR,NLP,NLPA,NRP,NLISRT,NLL,NLPB,NRPL; 02983960 +COMMENT * * * * * START OF SUBROUTINE DECLARATIONS * * * * * * * * ; 02983980 +SUBROUTINE CKPB; 02984000 +BEGIN COMMENT INITIALIZE FILE AND ACQUIRE RECORD SIZE; 02984020 +LCR ~ 8|(BSIZE ~ P(MKS,DKADR,1,FILX,READINT)); 02984040 +BUFF ~ (*FILX).[33:15]; NCR ~ 0; 02984060 +END CKPB; 02984080 +SUBROUTINE READS; 02984100 +BEGIN 02984120 +P(MKS,DKADR,0,FILX,READINT); 02984140 +IF DONETOG THEN P(XIT); 02984160 +IF ((*FILX).[27:1]) THEN P(XIT); 02984280 +CKPB; 02984300 +END READS; 02984320 + % PARAMETERS FOR LIST CONTROL 02984340 +BOOLEAN ATOG,TWDT; 02984360 +ARRAY AR1 = LISTADR[*]; 02984380 + INTEGER INDX, SIZE; 02984400 +DEFINE NXTELM = IF TWDT THEN P(*[AR1[INDX.[33:7]]],INDX.[40:8],CDC) 02984420 + ELSE [AR1[INDX]]#; 02984440 +SUBROUTINE SKPC; % SKIPS CURRENT CHARACTERS. PUTS NEXT CHARACTERS 02984460 + BEGIN; % IN NBC 02984480 + STREAM(P1~BUFF,P2~0:P3~0); 02984500 + BEGIN 02984520 + SI ~ P1; SI ~ SI +1; P1 ~ SI; 02984540 + DI ~ LOC P2; DI ~ DI+7; DS ~ CHR; 02984560 + END; 02984580 + NBC ~ P; BUFF ~ P; 02984600 + WT ~ WT -1; 02984620 + END SKPC; 02984640 +SUBROUTINE SCALE; 02984660 + BEGIN 02984680 + IF (D1 ~ D1 + CNT) > 11 02984700 + THEN DOUBLE(WH1,WH2,TEN[CNT],TEN[69+CNT],|, 02984720 + DH1,0,+,~,WH1,WH2) 02984740 + ELSE WH1~ WH1|TEN[CNT]+DH1; 02984760 + DH1 ~ 0; 02984780 + END SCALE; 02984800 +SUBROUTINE GETNUM; 02984820 + BEGIN; 02984840 + STREAM(P1~BUFF,P2~IF WT { 8 THEN WT ELSE 8,P3~0,P4~0:P5~0); 02984860 + BEGIN 02984880 + SI ~ P1; 02984900 + P2(IF SC = " " THEN TALLY ~ TALLY +1 02984920 + ELSE 02984940 + BEGIN IF SC } "0" THEN TALLY ~ TALLY + 1 02984960 + ELSE JUMP OUT; 02984980 + END; 02985000 + SI ~ SI + 1); 02985020 + P2 ~ TALLY; 02985040 + SI ~ P1; DI ~ LOC P3; DS ~ P2 OCT; 02985060 + P1 ~ SI; 02985080 + DI ~ LOC P4; DI ~ DI + 7; DS ~ CHR; 02985100 + END; 02985120 + NBC ~ P; DH1 ~ P; CNT ~ P; BUFF ~ P; 02985140 + END GETNUM; 02985160 +SUBROUTINE GETSIGN; 02985180 + BEGIN; 02985200 + STREAM(P1~BUFF,P2~(IF WT > 63 THEN 63 ELSE WT),P3~0,P4~(-1): 02985220 + P5~0); 02985240 + BEGIN 02985260 + SI~P1; DI~P2 ; 02985280 + P2(DI~DI-8; IF SC!" " THEN JUMP OUT TO L1; 02985300 + SI ~ SI + 1; TALLY ~ TALLY + 1); 02985320 + P1 ~ SI; 02985340 + GO TO RTNSGN; 02985360 + L1: IF SC } "0" THEN 02985380 + BEGIN 02985400 + L3: P2 ~ TALLY; 02985420 + L2: P5(P1~DI; TALLY~P2; P1(IF SC!" " THEN 02985440 + JUMP OUT; TALLY~TALLY+1; SI~SI+1); P2~TALLY); P1~SI ; 02985460 + DI ~ LOC P4; DS ~ 7 LIT "0"; DS ~ CHR; 02985480 + GO TO RTNSGN; 02985500 + END; 02985520 + IF SC ="." THEN GO TO L3; 02985540 + TALLY ~ TALLY+1; 02985560 + P2 ~ TALLY; 02985580 + TALLY~1; P5~TALLY ; 02985600 + IF SC="-" THEN TALLY~1 ELSE IF SC="+" THEN TALLY~0 ELSE 02985620 + IF SC="&" THEN TALLY~0 ELSE 02985640 + BEGIN TALLY~0; P1~TALLY; GO TO RTNSGN END; 02985660 + P3 ~ TALLY; 02985680 + SI ~ SI + 1; 02985700 + GO TO L2; 02985720 + RTNSGN: 02985740 + END; 02985760 + NBC~P; SGN~P; CNT~P; DTAERR~((BUFF~P)=0) ; 02985780 + END GETSIGN; 02985800 + LABEL NCRTN,BLSGN; 02985820 +SUBROUTINE NUMCONVERT; 02985840 + BEGIN 02985860 + DH1 := D1 := D2 := EXP := EXPSGN := 0; 02985880 + WH1 ~ WH2 ~ -0; 02985900 + WT ~ W; 02985920 + BLSGN: 02985940 + GETSIGN; 02985960 + IF DTAERR THEN GO TO NCRTN ; 02985980 + WT ~ WT - CNT; IF NBC <0 % BLANK FIELD 02986000 + THEN IF WT { 0 THEN GO TO NCRTN ELSE GO TO BLSGN; 02986020 + IF NBC { 9 THEN 02986040 + BEGIN 02986060 + GETNUM; WH1 ~ DH1; 02986080 + IF (WT ~ WT - (D1 ~ CNT)) { 0 THEN GO TO NCRTN; 02986100 + WHILE NBC { "9" OR NBC = " " DO 02986120 + BEGIN 02986140 + GETNUM; SCALE; 02986160 + IF (WT ~ WT-CNT) { 0 THEN GO TO NCRTN; 02986180 + END; 02986200 + END; 02986220 + IF NBC = "." THEN 02986240 + BEGIN 02986260 + SKPC; 02986280 + IF WT{0 THEN GO TO NCRTN ; 02986300 + WHILE (NBC { "9") OR (NBC = " ") DO 02986320 + BEGIN 02986340 + GETNUM; SCALE; 02986360 + D2 ~ D2 + CNT; 02986380 + IF ( WT ~ WT - CNT) { 0 THEN GO TO NCRTN; 02986400 + END; 02986420 + END; 02986440 + IF NBC = "D" OR NBC = "E" THEN SKPC; 02986460 + IF WT{0 THEN BEGIN DTAERR~TRUE; GO TO NCRTN END ; 02986480 + IF (NBC="+") OR (NBC="&") OR (NBC=" ") OR (EXPSGN~(NBC="-")) 02986500 + THEN SKPC; 02986520 + IF WT{0 THEN BEGIN DTAERR~TRUE; GO TO NCRTN END ; 02986540 + IF NBC > "9" THEN DTAERR ~ TRUE 02986560 + ELSE 02986580 + BEGIN 02986600 + GETNUM; 02986620 + EXP ~ IF EXPSGN THEN (-DH1) ELSE DH1; 02986640 + IF (WT~WT-CNT) { 0 THEN GO TO NCRTN; 02986660 + IF NOT NLT THEN WHILE WT > 0 DO SKPC; 02986680 + END; 02986700 + NCRTN: 02986720 + IF WH1 = 0 THEN IF SGN THEN WH1 ~ -0; 02986740 + END NUMCONVERT; 02986760 +LABEL NMBLNK; 02986780 +REAL SUBROUTINE NMSCN; 02986800 + BEGIN; 02986820 + NMBLNK: 02986840 + IF NCR } LCR THEN READS; 02986860 + STREAM(P1~BUFF,P2~(IF(T1~LCR-NCR)>63 THEN 63 ELSE T1), 02986880 + P3 ~0:P4~0); 02986900 + BEGIN 02986920 + SI ~P1; 02986940 + P2(IF SC !" " THEN JUMP OUT TO L1; 02986960 + SI ~ SI + 1; TALLY ~ TALLY + 1;); 02986980 + P2 ~ TALLY; TALLY ~ 1; 02987000 + GO TO L2; 02987020 + L1: P2 ~ TALLY; TALLY ~ 0; 02987040 + L2: P1 ~ TALLY; P3 ~ SI; 02987060 + END; 02987080 + BUFF ~ P; NCR ~ NCR+P; IF P THEN GO TO NMBLNK; 02987100 + STREAM(P1~BUFF,P2~0,P3~0,P4~" ",P5~0:NFL) ; 02987120 + BEGIN 02987140 + SI ~ P1; 02987160 + NFL(IF SC}"0" THEN JUMP OUT TO NU) ; 02987180 + IF SC = ALPHA THEN 02987200 + BEGIN 02987220 + DI ~ LOC P4; DI ~ DI + 2; 02987240 + 6(IF SC < "A" THEN JUMP OUT; 02987260 + DS ~ CHR; TALLY ~ TALLY + 1); 02987280 + P1 ~ SI; P3 ~ TALLY; 02987300 + TALLY ~ 1; GO TO EXIT; 02987320 + END; 02987340 + NFL(IF SC!"-" THEN IF SC!"+" THEN IF SC!"&" THEN JUMP OUT;02987360 + JUMP OUT TO NU) ; 02987380 + 02987400 + 02987420 + 02987440 + TALLY ~ 1; P3 ~ TALLY; 02987460 + DI ~ LOC P2; DI ~ DI + 7; 02987480 + IF SC ="#" THEN BEGIN DS~LIT"="; SI~SI+1 END ELSE 02987500 + 02987520 + IF SC ="[" THEN BEGIN DS~LIT ")"; SI ~ SI+1 END ELSE 02987540 + IF SC ="%" THEN BEGIN DS~LIT "("; SI ~ SI+1 END ELSE 02987560 + DS ~CHR; 02987580 + P1 ~ SI; 02987600 + TALLY ~ 3; GO TO EXIT; 02987620 + 02987640 + NU: 02987660 + P1 ~ SI; TALLY ~ 2; 02987680 + EXIT: 02987700 + P5 ~ TALLY; 02987720 + END; 02987740 + T1 ~ P; NAMEV ~ P; NCR ~ NCR + P; NBC ~ P; BUFF ~ P; 02987760 + IF T1 = ID THEN NBC ~ NAMEV; 02987780 + NMSCN ~ T1; 02987800 + END NMSCN; 02987820 +SUBROUTINE NLCONV; 02987840 + BEGIN 02987860 + IF NBC = "." THEN 02987880 + BEGIN; 02987900 + STREAM(P1~BUFF:P2~0); 02987920 + BEGIN DI ~ P1; DI ~ DI - 1; P1 ~ DI; END; 02987940 + BUFF ~ P; NCR ~ NCR - 1; 02987960 + END; 02987980 + W ~ LCR-NCR; 02988000 + NUMCONVERT; 02988020 + IF (NCR ~ NCR + (W-WT)) } LCR THEN READS; 02988040 + T1 ~ EXP - D2; 02988060 + IF WH1 > MAX 02988080 + THEN 02988100 + IF T1 } 0 THEN DOUBLE(WH1,WH2,TEN[T1],TEN[69+T1],|, 02988120 + ~,WH1,WH2) 02988140 + ELSE DOUBLE(WH1,WH2,TEN[-T1],TEN[69-T1],/, 02988160 + ~,WH1,WH2) 02988180 + ELSE 02988200 + IF T1 } 0 THEN WH1 ~ WH1 | TEN[T1] 02988220 + ELSE WH1 ~ WH1 / TEN[-T1]; 02988240 + IF SGN THEN WH1 ~ - WH1; 02988260 + END NLCONV; 02988280 +LABEL NLR,SUBD; 02988300 +SUBROUTINE SUBEVUL; 02988320 + BEGIN 02988340 + IF NMSCN !NUM THEN GO TO NLERR; 02988360 + CHR ~ FMTA[NLI~NLI+1].[1:6]; % # DIM 02988380 + NFCI ~ 1; NLCONV; 02988400 + IF (D2!0) OR (EXP ! 0) THEN GO TO NLERR; 02988420 + SBS ~ WH1-1; 02988440 + NLR: IF NMSCN ! SPC THEN GO TO NLERR; 02988460 + IF NBC = ")" THEN GO TO SUBD; 02988480 + IF NFCI = CHR THEN GO TO NLERR; 02988500 + NLCONV; 02988520 + IF (D2!0) OR (EXP!0) THEN GO TO NLERR; 02988540 + WH1 ~ WH1 - 1; D2 ~ 0; 02988560 + WHILE D20 DO 02989240 + BEGIN 02989260 + IF NBC = FMTA[NLI].[12:36] THEN GO TO NLPB; 02989280 + T1 ~ T1 - 1; 02989300 + NLI ~ NLI + 2 + FMTA[NLI+1].[1:6]; 02989320 + END; 02989340 + % NOT FOUND 02989360 + WHILE (T1~ NMSCN) ! SPC OR(NBC ! "," AND NBC ! "$") DO 02989380 + IF T1 = NUM THEN NLCONV; 02989400 + IF NBC = "$" THEN BEGIN DONETOG ~ TRUE; READS END; 02989420 + GO TO NLP; 02989440 + NLPB: 02989460 + ATOG ~ CTOG ~ FALSE; 02989480 + LISTYPE ~ FMTA[NLI].[2:10]; 02989500 + IF (T1~FMTA[NLI+1].[18:30]) !0 THEN 02989520 + BEGIN 02989540 + SIZE~(INDX~T1.BASEF)+T1.SIZEF ; 02989560 + ATOG ~ TRUE; 02989620 + END; 02989640 + IF (T1 ~ FMTA[NLI+1].[7:11]) < 1024 THEN 02989660 + LISTADR ~ [PRTBASE[T1]] 02989680 + ELSE LISTADR ~ IF T1.[39:1] THEN [MEM[LISX-T1.[41:7]]] 02989700 + ELSE [MEM[LISX+T1.[40:8]]]; 02989720 + IF ATOG THEN TWDT~NOT P(*(LISTADR~MEM[(*[LISTADR]).[18:15]]), 02989740 + TOP,XCH,DEL) 02989745 + ELSE W1~LISTADR ; 02989750 + IF LGTG=0 THEN T1~NMSCN ELSE BEGIN NBC~LGTG; LGTG~0 END; 02989760 + IF NBC ="(" THEN 02989780 + BEGIN 02989800 + IF NOT ATOG THEN GO TO NLERR; 02989820 + SUBEVUL; 02989840 + END; 02989860 + IF NBC ! "=" THEN GO TO NLERR; 02989880 + T1 ~ NMSCN; 02989900 + NRP: IF T1 =NUM THEN 02989920 + BEGIN 02989940 + NLCONV; 02989960 + IF NMSCN !SPC THEN GO TO NLERR; 02989980 + IF NBC ! "*" THEN GO TO NLISRT; 02990000 + RPT ~ WH1; 02990020 + IF (D2!0) OR (EXP!0)THEN GO TO NLERR; 02990040 + IF NMSCN = NUM THEN GO TO NRP; 02990060 + END; 02990080 + NRPL: 02990100 + IF NBC = "." THEN 02990120 + BEGIN 02990140 + IF ELMTYP ! LOGV THEN 02990160 + BEGIN 02990180 + NLCONV; T1 ~ NMSCN; GO TO NLISRT; 02990200 + END; 02990220 + T1 ~ NMSCN; 02990240 + NLL: WH1 ~ (NBC.[12:6]= "T"); 02990260 + WHILE (T1~NMSCN) ! SPC OR (NBC!"$" AND NBC ! ",") 02990280 + DO IF T1= NUM THEN GO TO NLERR; 02990300 + GO TO NLISRT; 02990320 + END; 02990340 + IF NBC ="(" THEN 02990360 + BEGIN 02990380 + IF NMSCN ! NUM THEN GO TO NLERR; 02990400 + NLCONV; JUNK1 ~WH1; 02990420 + CTOG ~ TRUE; 02990440 + IF NMSCN ! SPC OR NBC ! "," THEN GO TO NLERR; 02990460 + IF NMSCN !NUM THEN GO TO NLERR; 02990480 + NLCONV; 02990500 + WH2 ~ WH1; WH1 ~ JUNK1; 02990520 + IF NMSCN ! SPC OR NBC ! ")" THEN GO TO NLERR; 02990540 + GO TO NLISRT; 02990560 + END; 02990580 + IF ELMTYP !LOGV THEN GO TO NLERR; 02990600 + GO TO NLL; 02990620 + NLISRT: 02990640 + IF ATOG THEN 02990660 + BEGIN 02990680 + IF INDX } SIZE THEN GO TO NLERR; 02990700 + W1 ~ NXTELM; 02990720 + INDX ~ INDX+ (DLN OR CMPLX); 02990740 + INDX ~ INDX + 1; 02990760 + END; 02990780 + IF ELMTYP = INTEGV THEN W1[0]~WH1 DIV 1 ELSE 02990800 + W1[0] ~ WH1; 02990820 + IF (DLN OR CMPLX) THEN W1[1] ~WH2; 02990840 + IF NOT (CTOG EQV CMPLX) THEN GO TO NLERR; 02990860 + IF ATOG THEN IF (RPT ~ RPT-1) > 0 THEN GO TO NLISRT; 02990880 + NFL~0; WHILE NBC!"," AND NBC!"$" DO P(NMSCN,DEL); NFL~1 ; 02990900 + IF NBC = "$" THEN BEGIN DONETOG ~ TRUE; READS; END; 02990920 + IF NOT ATOG THEN GO TO NLP; 02990940 + IF ELMTYP ! LOGV THEN IF (NMSCN =ID ) 02990960 + THEN GO TO NLPA ELSE IF NBC!"," THEN GO TO NRP 02990980 + ELSE BEGIN WH1~WH2~0; GO TO NLISRT END; 02991000 + IF (T1 ~ NMSCN) = NUM THEN GO TO NRP; 02991020 + IF NBC = "." THEN GO TO NRPL; 02991040 + WH1 ~ NBC; T1 ~ NMSCN; 02991060 + IF NBC ! "," THEN 02991080 + BEGIN 02991100 + LGTG ~ NBC; NBC ~ WH1; GO TO NLPA; 02991120 + END; 02991140 + WH1 ~ (WH1.[12:6] = "T"); 02991160 + GO TO NLISRT; 02991180 + NLERR: 02991200 + P(MKS,FIB[6],FILX.[33:15],1,FORTERR); 02991220 + END FINNAME; 02991240 +PROCEDURE FOUTNAME; %155 02991260 + BEGIN 02991280 +COMMENT FILX FILE TOP IO DESCRIPTOR 02991300 + FMTA FORMAT OR NAMELIST OR 0 02991320 + LISX ACCIDENTAL ENTRY DESC. OR 0 02991340 + ; 02991460 +REAL FORTERR = 24, 02991500 + LISX = -1, 02991520 + FI = -3, 02991540 + DKADR = -4; 02991560 +ARRAY FMTA = -2[*], FPB = 3[*] ; 02991580 +NAME FILX = -5, 02991600 + MEM = 2; 02991620 +REAL ALGOLWRITE = 12, 02991640 + SELECT = 14; 02991660 +INTEGER LSTRN = 19; 02991680 +REAL LISTYPE = 20, 02991700 + ARRAYSTUFF = 18, 02991720 + NAMEV = 21; 02991740 +ARRAY PRTBASE = 10[*], 02991760 + TEN = 22[*], 02991780 + TPAR = 23[*], 02991800 + FIB[*]; 02991820 +NAME LISTADR; 02991840 +REAL BUFF , % FIRST BUFFER POSITION 02991860 + BSIZE , % ARGUMENIS 02991880 + FLG , % TRUE FOR SERIAL I/O 02991900 + WH1, 02991920 + WH2 , % 02991940 + W1 , % 02991960 + W2 , % 02991980 + NFCI ; % NEXT FORMAT CHAR LOCATION 02992000 +INTEGER DH1 , % CONV- 02992020 + DH2 , % ERTED NU- 02992040 + DH3 , % MBER 02992060 + W , % FIELD 02992080 + WT , % WIDTH 02992100 + T1 , % 02992120 + D , % DEC- 02992140 + DT , % IMAL P- 02992160 + D1 , % LA- 02992180 + D2 , % CE- 02992200 + D3 , % S 02992220 + ZEROS , % TRAILING ZEROES 02992240 + EXP , % EXPONENT 02992260 + SHFT , % INTEGER PART OF SHIFT 02992280 + CODE , % EDITING FUNCTION 02992300 + SKP , % REDUNDANT POSITIONS 02992320 + NCR , % CURRENT BUFFER POSITION 02992340 + LCR , % BUFFER SIZE IN CHARACTERS 02992360 + CHR ; % CURRENT CHAR FROM FORMAT 02992380 +BOOLEAN DONETOG , % RETURN AFTER WRITE 02992400 + SGN , % SIGN 02992420 + PRNTR , % TRUE IF PRINTER OUT PUT 02992440 + DTOG , % DOUBLE PRECISION TOG 02992460 + CTOG ; % COMPLEX NUMBER TOG 02992480 +DEFINE LOGV = 4#, 02992500 + INTEGV =1#, 02992520 + DBLV = 5#, 02992540 + CMPLXV = 6#, 02992560 + ETYPE = 3#, 02992580 + DTYPE = 4#, 02992600 + ITYPE = 5#, 02992620 + LTYPE = 6#, 02992640 + ELMTYP = LISTYPE . [44:4]#, 02992660 + DLN = (LISTYPE.[44:4] =DBLV)#, 02992680 + CMPLX = (LISTYPE.[44:4] = CMPLXV)#, 02992700 + TWOD = LISTYPE.[38:1]#, 02992720 + ENDLIST = (LSTRN = (-1))#, 02992740 + SIZEF = [33:15]#; 02992760 +LABEL ERTN,E,DC,I,L,AST,COMM,NM1,NM2,FMERR; 02992780 +COMMENT * * * * * START OF SUBROUTINE DECLARATIONS * * * * * * * * ; 02992800 +SUBROUTINE CKPB; 02992820 +BEGIN COMMENT INITIALIZE FILE AND ACQUIRE RECORD SIZE; 02992840 +LCR ~ 8|(BSIZE ~ P(MKS,FLG,DKADR,0,(-1),FILX,ALGOLWRITE)); 02992860 +IF PRNTR~PRNTR&(((T1~FIB[4].[8:4])=1 OR T1=7 OR T1=12) AND FPB[FIB[4] 02992880 + .[13:11]+3].[43:5]<20)[47:47:1] THEN 02992885 + IF BSIZE GEQ 17 THEN BEGIN LCR := 132; BSIZE := 17 END; 02992900 +IF PRNTR AND BSIZE=17 THEN LCR~120 ; 02992920 +BUFF :=(IF T1 := PRNTR THEN TPAR ELSE *FILX).[33:15]; 02992960 +IF ((NOT T1) OR PRNTR.[46:1]) THEN 02993020 +STREAM(P2 ~ (BSIZE-1).[36:6], 02993040 + P3~T1.[47:1]+BSIZE-1,P4~BUFF) ; 02993060 + BEGIN DI ~ P4; DS ~ 8 LIT " "; 02993080 + SI ~ P4; 02993100 + P2(DS ~ 32 WDS; DS ~ 32 WDS); 02993120 + DS ~ P3 WDS; 02993140 + END; 02993160 +NCR ~ 0; 02993200 +END CKPB; 02993220 +SUBROUTINE PRNT; 02993240 +BEGIN COMMENT GLNERATE A CALL FOR CAR. CONT. AND FOR OUTPUT; 02993260 +IF PRNTR THEN 02993280 +BEGIN; 02993300 + NCR ~ 0; 02993320 + STREAM(P1~0:P2~TPAR); 02993340 + BEGIN SI ~P2; DI ~ LOC P1; DI ~DI + 7; DS ~CHR; 02993360 + DI ~ P2; DS ~ LIT " ";END; 02993380 + NCR ~ P; 02993400 + IF NCR = " " THEN D2 ~ 16 ELSE 02993420 + IF NCR = "0" THEN D2 ~ 32 ELSE 02993440 + IF NCR = "+" THEN D2 ~ 0 ELSE 02993460 + IF (D2 ~ NCR) > 9 THEN D2 ~ 16; 02993480 + IF NOT PRNTR.[46:1] THEN FIB[17]~FIB[17]+BSIZE ; 02993520 + P(MKS,D2.[42:2],D2.[44:4],PRNTR.[46:1],BSIZE,FILX,ALGOLWRITE) ;02993540 + FIB[6]~FIB[6]-(D2=0) ; 02993560 + IF NOT (*FILX).[19:1] THEN P(FILX,@2000000000,2,COM,DEL,DEL); 02993580 + PRNTR~1; CKPB ; 02993600 + STREAM(P1~TPAR,P2~*FILX,P3~BSIZE.[36:6],P4~BSIZE); 02993620 + BEGIN 02993640 + SI ~ P1; DI ~ P2; DS ~ P4 WDS; 02993660 + P3(DS ~32 WDS; DS ~ 32 WDS); 02993680 + DI~P1; P4(DS~8LIT" ") ; 02993700 + END; 02993720 + FIB[17]~FIB[17]-BSIZE; IF DONETOG THEN P(XIT) ; 02993740 + END ELSE BEGIN P(MKS,FLG,DKADR,0,BSIZE,FILX,ALGOLWRITE); 02993760 + IF DONETOG THEN P(XIT); 02993780 + CKPB END ; 02993800 +END PRNT; 02993820 + % PARAMETERS FOR LIST CONTROL 02993840 +BOOLEAN ATOG,TWDT; 02993860 +ARRAY AR1 = LISTADR[*]; 02993880 +REAL INDX,SIZE,NLI,NLE; 02993900 +LABEL RTNLST,SRT; 02993920 +DEFINE NXTELM = IF TWDT THEN P(*[AR1[INDX.[33:7]]],INDX.[40:8],COC) 02993940 + ELSE AR1[INDX]#; 02993960 +SUBROUTINE GETNMLST; 02993980 + BEGIN 02994000 + IF (NLE ~ NLE - 1) <0 THEN LSTRN ~ - 1 ELSE 02994020 + BEGIN 02994040 + NAMEV ~ FMTA[NLI~ NLI+1].[12:36]; 02994060 + LISTYPE ~ FMTA [NLI].[2:10]; 02994080 + ARRAYSTUFF ~ FMTA[NLI~NLI+1].[18:30]; 02994100 + IF (T1 ~ FMTA[NLI].[7:11] ) < 1024 02994120 + THEN LISTADR~ [PRTBASE[T1]] ELSE 02994140 + IF T1.[39:1] THEN LISTADR ~ [MEM[LISX-(T1.[41:7])]] 02994160 + ELSE LISTADR ~ [MEM[LISX+(T1.[40:8])]]; 02994180 + NLI ~ NLI + FMTA[NLI].[1:6]; 02994200 + END; 02994220 + END GETNMLST; 02994240 +SUBROUTINE GETLIST; 02994260 + BEGIN 02994280 + SRT: IF ATOG THEN 02994300 + BEGIN 02994320 + IF DLN THEN 02994340 + BEGIN 02994360 + WH1 ~ NXTELM; 02994380 + INDX ~ INDX + 1; 02994400 + WH2 ~ NXTELM; 02994420 + END ELSE 02994440 + BEGIN 02994460 + WH1 ~ NXTELM; 02994480 + WH2 ~ 0; 02994500 + END; 02994520 + IF (INDX ~INDX + 1) } SIZE THEN 02994540 + BEGIN 02994560 + ARRAYSTUFF ~ 0; 02994580 + ATOG ~ FALSE; 02994600 + END; 02994620 + GO TO RTNLST; 02994640 + END; 02994660 + IF CTOG THEN 02994680 + BEGIN % IMAGINARY PART OF COMPLEX 02994700 + WH1 ~ LISTADR[1]; 02994720 + WH2 ~ 0; 02994740 + CTOG ~ FALSE; 02994760 + GO TO RTNLST; 02994780 + END; 02994800 + GETNMLST; 02994820 + IF ENDLIST THEN GO TO RTNLST; 02994840 + IF ARRAYSTUFF ! 0 THEN 02994860 + BEGIN 02994880 + ATOG ~ TRUE; 02994900 + SIZE~(INDX~ARRAYSTUFF.[18:15])+ARRAYSTUFF.SIZEF ; 02994910 + TWDT~NOT P(*(LISTADR~MEM[(*[LISTADR]).[18:15]]),TOP); P(DEL) ;02994920 + GO TO SRT; 02994970 + END; 02994980 + IF NOT P(*LISTADR,TOP,XCH,DEL) THEN LISTADR~P(*LISTADR) ; 02994985 + WH1 ~ LISTADR[0]; 02995000 + WH2 ~ IF DLN THEN LISTADR[1] ELSE 0; 02995020 + CTOG ~ CMPLX; 02995040 + RTNLST: 02995060 + END GETLIST; 02995080 +SUBROUTINE NMSZ; 02995100 + BEGIN; 02995120 + STREAM(P1~[NAMEV]:P2~0); 02995140 + BEGIN 02995160 + SI ~P1; SI ~ SI + 2; 02995180 + 6(IF SC = " " THEN JUMP OUT; 02995200 + SI ~SI + 1; TALLY ~ TALLY + 1); 02995220 + P1 ~TALLY; 02995240 + END; 02995260 + NFCI ~ P; 02995280 + END NMSZ; 02995300 +SUBROUTINE PUT; 02995320 + BEGIN; 02995340 + STREAM(P1~[NAMEV]:P2~NFCI,P3~BUFF); 02995360 + BEGIN 02995380 + SI ~ P1; SI ~SI + 2; DS ~P2 CHR; 02995400 + P1 ~ DI; 02995420 + END; 02995440 + BUFF ~ P; 02995460 + END PUT; 02995480 +SUBROUTINE FUNNYZERO; 02995500 + BEGIN 02995520 + SKP ~ W - (D+6+SGN); 02995540 + STREAM(P1~ BUFF:P2~SKP,P3~SGN,P4~(D+4)); 02995560 + BEGIN 02995580 + DI ~P1; DI ~ DI + P2; 02995600 + P3(DS ~ LIT "-"; JUMP OUT TO L); 02995620 + L: DS ~ 2 LIT "0."; 02995640 + P4(DS ~ LIT " "); 02995660 + P1 ~ DI; 02995680 + END; 02995700 + BUFF ~ P; 02995720 + END FUNNYZERO; 02995740 +SUBROUTINE FINDE; 02995760 + BEGIN IF DTOG THEN 02995780 + DOUBLE(TEN[0],0,WH1,WH2,|,~,WH1,WH2) 02995800 + ELSE WH1 ~ TEN[0] | WH1; 02995820 + EXP ~ ((0&WH1[42:3:6]&WH1[1:2:1]+12)|.9039) +.5; 02995840 + W2 ~ 0; 02995860 + IF DTOG THEN 02995880 + IF EXP } 0 THEN DOUBLE(TEN[EXP],TEN[69+EXP],~,W1,W2) 02995900 + ELSE DOUBLE(1,0,TEN[-EXP],TEN[69-EXP],/,~,W1,W2) 02995920 + ELSE W1 ~ IF EXP } 0 THEN TEN[EXP] ELSE 1/TEN[-EXP]; 02995940 + IF WH1 > W1 THEN GO TO ERTN; 02995960 + IF WH1 = W1 THEN 02995980 + IF WH2 } W2 THEN GO TO ERTN; 02996000 + EXP ~ EXP-1; 02996020 + ERTN: 02996040 +END FINDE; 02996060 +SUBROUTINE NUMCONVERT; 02996080 +BEGIN 02996100 + IF D1 > 0 THEN 02996120 + BEGIN 02996140 + DOUBLE(WH1,WH2,TEN[16],TEN[85],/,~,W1,W2); 02996160 + DH1 ~ W1 DIV 1.0; 02996180 + END; 02996200 + IF D2 > 0 THEN 02996220 + BEGIN IF DTOG THEN 02996240 + BEGIN 02996260 + DOUBLE(WH1,WH2,DH1,0,TEN[16],TEN[85],|,-, 02996280 + TEN[ 8],TEN[77],/,~,W1,W2); 02996300 + DH2 ~ W1 DIV 1; 02996320 + END 02996340 + ELSE DH2 ~ WH1 DIV TEN[8]; 02996360 + END; 02996380 + IF DTOG THEN 02996400 + BEGIN 02996420 + DOUBLE(WH1,WH2,DH1,0,TEN[16],TEN[85],|, 02996440 + DH2,0,TEN[ 8],TEN[77],|,+,-,~,W1,W2); 02996460 + DH3 ~ W1 DIV 1; 02996480 + END 02996500 + ELSE DH3 ~ WH1 DIV 1; 02996520 + EXP ~ EXP+1; 02996540 +END NUMCONVERT; 02996560 + SUBROUTINE SETD; 02996580 +BEGIN 02996600 + IF DLN AND DT > 23 THEN 02996620 + BEGIN 02996640 + ZEROS~DT-23; DT ~ 23; D1 ~ 7; D2 ~ D3 ~ 8; 02996660 + END ELSE IF DT>12 AND NOT DLN THEN 02996680 + BEGIN 02996700 + ZEROS~DT-12; DT ~ 12; D1~0; D2 ~ 4; D3 ~ 8; 02996720 + END ELSE IF DT>16 THEN 02996740 + BEGIN 02996760 + D1~DT-16; D2~D3~8; 02996780 + END ELSE IF DT > 8 THEN 02996800 + BEGIN 02996820 + D1~0;D2~DT-8; D3~8; 02996840 + END ELSE 02996860 + BEGIN 02996880 + D1~D2~0;D3~DT; 02996900 + END; 02996920 +END SETO; 02996940 +SUBROUTINE RNDOFF; 02996960 +BEGIN IF DTOG THEN 02996980 + IF T1 } 0 THEN 02997000 + DOUBLE(WH1,WH2,,5,TEN[T1],TEN[T1+69],|,+,~,WH1,WH2) ELSE 02997020 + DOUBLE(WH1,WH2,,5,TEN[-T1],TEN[69-T1],/,+,~,WH1,WH2) 02997040 + ELSE WH1 ~ WH1 + (IF T1}0 THEN 5|TEN[T1] ELSE 5/TEN[-T1]);02997060 +END RNDOFF; 02997080 +SUBROUTINE SCALE; 02997100 +BEGIN IF DTOG THEN 02997120 + BEGIN IF T1 } 0 02997140 + THEN DOUBLE(WH1,WH2,TEN[T1],TEN[T1+69],|,~,WH1,WH2) 02997160 + ELSE DOUBLE(WH1,WH2,TEN[-T1],TEN[69-T1],/,~,WH1,WH2); 02997180 + IF WH1 } TEN[DT] THEN 02997200 + BEGIN 02997220 + EXP ~ EXP + 1; 02997240 + DOUBLE(WH1,WH2,TEN[1],0,/,~,WH1,WH2); 02997260 + END 02997280 + END ELSE WH1 ~ IF T1 } 0 THEN WH1|TEN[T1] ELSE WH1/TEN[-T1]; 02997300 +END SCALE; 02997320 + %************** S T A R T O F EDIT-CONTROL*****************%02997340 +SUBROUTINE CONVERT; 02997360 +BEGIN 02997380 +DTOG := FALSE; 02997400 +SGN ~WH1.[1:1]; IF CODE < LTYPE THEN WH1 ~ ABS(WH1); WT ~ W; DT ~ D; 02997420 +DH1 ~ DH2 ~ DH3 ~ ZEROS ~EXP ~ SKP ~ SHFT ~ D1 ~ D2 ~ D3 ~ 0; 02997440 +GO TO P(CODE,DUP,ADD); 02997460 +GO TO FMERR; 02997480 +GO TO FMERR; 02997500 +GO TO FMERR; 02997520 +GO TO E; 02997540 +GO TO DC; 02997560 +GO TO I; 02997580 +GO TO L; 02997600 + L: COMMENT LOGICIAL CONVERSION; 02997620 + IF W >1 THEN SKP~W-(WT~1); 02997640 + WH1~ 0&(IF WH1 THEN "T" ELSE "F")[12:42:6]; 02997660 + STREAM(P1 := BUFF:P2 := WH1,P3 := SKP, P4 := WT); 02997680 + BEGIN DI := P1; DI := DI + P3; 02997700 + SI := LOC P2; SI := SI + 2; 02997720 + DS := P4 CHR; P1 := DI; 02997740 + END; 02997760 + BUFF := P; 02997780 + GO TO COMM; 02997800 + I: COMMENT INTEGER CONVERSION; 02997820 + IF WH1=0 AND WH2=0 THEN DT ~ D3 ~ 1 ELSE 02997840 + BEGIN IF DTOG THEN 02997860 + DOUBLE(WH1,WH2,,.5,+,~,WH1,WH2) % ROUND OFF 02997880 + ELSE WH1 ~ T1 ~ WH1; 02997900 + FINDE; 02997920 + IF EXP < 0 THEN DT ~ 03 ~ 1 ELSE 02997940 + BEGIN 02997960 + IF (DLN AND EXP}24) OR (NOT DLN AND EXP}12) THEN GO AST; 02997980 + DT ~ EXP+1; SETD; NUMCONVERT; 02998000 + END; 02998020 + END; 02998040 + IF DT + SGN > W THEN GO TO AST; 02998060 + IF W > DT + SGN THEN SKP ~ W - DT - SGN; 02998080 +STREAM(P1~0:P2 ~ D1,P3 ~ DH1,P4 ~ D2,P5 ~ DH2, 02998100 + P6 ~ D3,P7 ~ DH3,P8 ~ SGN,P9 ~ SKP,P10 ~ BUFF); 02998120 + BEGIN DI ~ P10; P9(DI ~ DI + 1); 02998140 + P8(DS ~ LIT "-"); 02998160 + SI ~LOC P3; DS ~ P2 DEC; 02998180 + SI ~ LOC P5; DS ~ P4 DEC; 02998200 + SI ~ LOC P7; DS ~ P6 DEC; 02998220 + P1 ~ DI; 02998240 + END; 02998260 +BUFF ~ P; 02998280 +GO TO COMM; 02998300 + DC: COMMENT DOUBLE PRECISION CONVERT,SAME AS E CONVERT; 02998320 + E: COMMENT E CONVERSION; 02998340 + DTOG ~ TRUE; 02998360 + SETD; 02998380 + IF WH1=0 AND WH2 = 0 THEN 02998400 + BEGIN 02998420 + IF W < (D+6+ SGN) THEN GO TO AST; 02998460 + FUNNYZERO; GO TO COMM; 02998480 + END ELSE 02998500 + BEGIN 02998520 + FINDE; 02998540 + IF (SKP ~ W - D - 5 - SGN) < 0 THEN GO TO AST; SETD; 02998560 + IF DT LSS 0 THEN DT := 0; 02998580 + T1 ~ EXP - DT; RNDOFF; 02998600 + SETD; 02998620 + T1~DT-1-EXP; SCALE; 02998640 + NUMCONVERT; 02998660 + END; 02998680 +STREAM(P1 ~ 0:P2 ~ SKP,P3 ~ SGN,P4 ~ D1,P5 ~ DH1, 02998700 + P6 ~ D2,P7 ~ DH2,P8 ~ D3,P9 ~ DH3,P10 ~ (DLN), 02998720 + P11 ~ (EXP < 0),P12 ~ ABS(EXP),P13 ~ SHFT,P14 ~ ZEROS,P15 ~BUFF);02998740 + BEGIN DI ~ P15; DI ~ DI + P2; P3(DS ~ LIT "-"); 02998760 + P2 ~ DI; DS ~ LIT "."; 02998780 + SI ~ LOC P5; DS ~ P4 DEC; 02998800 + SI ~ LOC P7; DS ~ P6 DEC; 02998820 + SI ~ LOC P9; DS ~ P8 DEC; 02998840 + P14(DS ~ LIT " "); DS ~ LIT "E"; 02998860 + P10(DI ~ DI - 1; DS ~ LIT "D"); 02998880 + DS ~ LIT " " ; 02998900 + P11(DI ~ DI - 1; DS ~ LIT "-"); 02998920 + SI ~ LOC P12; DS ~ 2 DEC; 02998940 + P1 ~ DI; 02998960 + P13(DI ~ P2; SI ~ P2; SI ~ SI + 1; 02998980 + DS ~ P13 CHR; DS ~ LIT "."; JUMP OUT TO X); X: 02999000 + END; 02999020 +BUFF ~ P; 02999040 + GO TO COMM; 02999060 +AST: 02999080 +STREAM(P1 ~ 0:P2 ~ BUFF,P3 ~ W); 02999100 + BEGIN DI ~ P2; P3(DS ~ LIT "*"); P1 ~ DI; END; 02999120 +BUFF ~ P; 02999140 +COMM: 02999160 +END CONVERT; 02999180 +COMMENT * * * * * * * * * * END OF DECLARATIONS * * * * * * * * * * * ; 02999200 +FIB ~ FILX[NOT 2]; % OPEN FILE IF NOT OPEN 02999220 +IF DKADR < 0 THEN BEGIN FLG ~ 1; DKADR ~0 END; 02999240 +IF FIB[5].[43:1] THEN P(MKS,0,0,FILX,1,SELECT); 02999260 +PRNTR~2|(FIB[5].[41:2]!0) ; %%% IFF FILE IS CLOSED, SETS PRNTR.[46:1]=1.02999280 +IF PRNTR THEN STREAM(TPAR); DS~8LIT" " ; 02999290 +CKPB; ARRAYSTUFF ~ 0; 02999300 + IF FIB[0] = 0 THEN FIB[0] := 1 ELSE 02999320 + IF FIB[0] NEQ 1 THEN P(MKS,FIB[6],FILX.[33:15],4,FORTERR); 02999340 + LSTRN ~0; CHR ~ " "; NLI ~ FI; 02999420 + NAMEV ~ CHR&"$"[18:42:6]; 02999430 + NCR ~NCR + (NFCI ~ 2); PUT; 02999440 + NAMEV ~ FMTA[NLI].[12:36]; 02999450 + NLE ~ FMTA[NLI].[2:10]; 02999460 + NMSZ; PUT; NCR ~ NCR + NFCI; 02999470 + NAMEV ~ CHR; NCR ~ NCR + (NFCI ~ 1); PUT; 02999480 + 02999490 + NM1: GETLIST; IF ENDLIST THEN 02999500 + BEGIN; 02999510 + STREAM(P1~BUFF); 02999520 + BEGIN 02999530 + DI ~ P1; DI ~ DI - 3; DS ~ LIT "$"; 02999540 + END; 02999550 + DONETOG ~ TRUE; PRNT; 02999560 + END; 02999570 + IF PRNTR THEN PRNT; 02999580 + CODE~NAMEV; NAMEV~CHR; NCR~NCR+(NFCI~2); PUT; NAMEV~CODE; 02999590 + NMSZ; 02999600 + IF ELMTYP = INTEGV THEN 02999610 + BEGIN W ~12; D ~0; CODE ~ ITYPE END ELSE 02999620 + IF ELMTYP = LOGV THEN 02999630 + BEGIN W ~1; CODE ~ LTYPE END ELSE 02999640 + IF ELMTYP = DBLV THEN 02999650 + BEGIN W ~29; D ~23; CODE ~ DTYPE END ELSE 02999660 + BEGIN W ~18; D ~ 12; CODE ~ ETYPE END; 02999670 + IF (6 + W + NFCI + ( IF CMPLX THEN (W+3) ELSE 0) + NCR) 02999680 + } LCR THEN PRNT; 02999690 + PUT; % NAME 02999700 + NCR ~ NCR + NFCI + 3; 02999710 + NAMEV ~ CHR&" ="[12:36:12]; NFCI ~3; PUT; 02999720 + NM2: IF ELMTYP = CMPLXV THEN 02999740 + BEGIN 02999750 + IF (NCR+W+W+6) } LCR THEN PRNT; 02999760 + NCR ~ NCR + (NFCI ~1); NAMEV ~ CHR&"("[12:42:6]; PUT; 02999770 + NCR ~ NCR + W; CONVERT; 02999780 + NCR ~ NCR + (NFCI~1); NAMEV ~ CHR&","[12:42:6]; PUT; 02999790 + CTOG ~ TRUE; 02999800 + GETLIST; 02999810 + NCR ~ NCR + W; CONVERT; 02999820 + NCR ~ NCR + (NFCI ~4); 02999830 + NAMEV ~ CHR&"),"[12:36:12]; PUT; 02999840 + END 02999850 + ELSE 02999860 + BEGIN 02999870 + IF (NCR + W + 3) } LCR THEN PRNT; 02999880 + NCR ~ NCR + W; CONVERT; 02999890 + NCR ~ NCR + (NFCI ~ 3); 02999900 + NAMEV ~ CHR&","[12:42:6]; PUT; 02999910 + END; 02999920 + IF NOT ATOG THEN GO TO NM1; 02999930 + GETLIST; GO TO NM2; 02999940 +FMERR: 02999950 + P(MKS,FIB[6],FILX.[33:15],0,FORTERR); 02999960 + END FOUTNAME; 02999970 +PROCEDURE DABS ; % 052 03000000 +COMMENT ABSOLUTE VALUE OF A DOUBLE PRECISION NUMBER; % PF JUNE 67 03000100 +BEGIN REAL X = -1, 03000200 + XL = -2, 03000300 + JUNK = 17; 03000400 +P(X,SSP,.JUNK,STD,XL,RTN); 03000500 +END DABS; 03000600 +PROCEDURE CABS ; % 053 03100000 +COMMENT COMPLEX ABSOLUTE INTRINSIC; % PF JUNE 67 03100100 +BEGIN REAL X = -1, 03100200 + Y = -2, 03100300 + SQRT=+1 ; 03100400 +P(INTDESC(SQRTI)) ; 03100410 +IF (X ~ ABS(X)) = 0 OR (Y ~ ABS(Y)) = 0 THEN P(X,Y,ADD,RTN) 03100500 +ELSE IF X > Y THEN P(MKS,1,Y,X,/,DUP,MUL,ADD,SQRT,X,MUL) 03100600 + ELSE P(MKS,1,X,Y,/,DUP,MUL,ADD,SQRT,Y,MUL); 03100700 +P(RTN); 03100800 +END CABS; 03100900 +PROCEDURE AINT ; % 054 03200000 +BEGIN REAL X = -1; 03200100 +P(X,1,DIV,RTN); 03200200 +END AINT; 03200300 +PROCEDURE MATH; % 055 03300000 +COMMENT MATHEMATIC MANIPULATION INTRINSIC % PF JUNE 67 03300100 + CODE = 3|TYPE(OP 1) + 9|0PERATOR + TYPE(OP 2) 03300200 + TYPE VALUE OPERAIOR VALUE 03300300 + REAL 0 + 0 03300400 + DOUBLE 1 - 1 03300500 + COMPLEX 2 * 2 03300600 + / 3; 03300700 +BEGIN REAL CODE = -1, 03300800 + A = -3, 03300900 + B = -4, 03301000 + C = -5, 03301100 + D = -6, 03301200 + ERR = 24, 03301250 + T; 03301300 + LABEL RPLUSD,RPLUSC,DPLUSC,CPLUSD,CPLUSC,RLESSD,RLESSC,DLESSC, 03301400 + CLESSD,CLESSC,RTIMED,RTIMEC,DTIMEC,CTIMED,CTIMEC,RDIVDD, 03301500 + RDIVDC,DDIVDC,CDIVDD,CDIVDC,CTIMER,CDIVDR,INLINE; 03301600 +GO TO P(CODE,DUP,ADD); 03301700 +GO TO INLINE; % REAL + REAL 0 03301800 +GO TO RPLUSD; % REAL + DOUBLE 1 03301900 +GO TO RPLUSC; % REAL + COMPLEX 2 03302000 +GO TO INLINE; % DOUBLE + REAL 3 03302100 +GO TO INLINE; % DOUBLE + DOUBLE 4 03302200 +GO TO DPLUSC; % DOUBLE + COMPLEX 5 03302300 +GO TO INLINE; % COMPLEX + REAL 6 03302400 +GO TO CPLUSD; % COMPLEX + DOUBLE 7 03302500 +GO TO CPLUSC; % COMPLEX + COMPLEX 8 03302600 +GO TO INLINE; % REAL - REAL 9 03302700 +GO TO RLESSD; % REAL - DOUBLE 10 03302800 +GO TO RLESSC; % REAL - COMPLEX 11 03302900 +GO TO INLINE; % DOUBLE - REAL 12 03303000 +GO TO INLINE; % DOUBLE - DOUBLE 13 03303100 +GO TO DLESSC; % DOUBLE - COMPLEX 14 03303200 +GO TO INLINE; % COMPLEX - REAL 15 03303300 +GO TO CLESSD; % COMPLEX - DOUBLE 16 03303400 +GO TO CLESSC; % COMPLEX - COMPLEX 17 03303500 +GO TO INLINE; % REAL * REAL 18 03303600 +GO TO RTIMED; % REAL * DOUBLE 19 03303700 +GO TO RTIMEC; % REAL * COMPLEX 20 03303800 +GO TO INLINE; % DOUBLE * REAL 21 03303900 +GO TO INLINE; % DOUBLE * DOUBLE 22 03304000 +GO TO DTIMEC; % DOUBLE | COMPLEX 23 03304100 +GO TO CTIMER; % COMPLEX | REAL 24 03304200 +GO TO CTIMED; % COMPLEX | DOUBLE 25 03304300 +GO TO CTIMEC; % COMPLEX | COMPLEX 26 03304400 +GO TO INLINE; % REAL / REAL 27 03304500 +GO TO RDIVDD; % REAL / DOUBLE 28 03304600 +GO TO RDIVDC; % REAL / COMPLEX 29 03304700 +GO TO INLINE; % DOUBLE / REAL 30 03304800 +GO TO INLINE; % DOUBLE / DOUBLE 31 03304900 +GO TO DDIVDC; % DOUBLE / COMPLEX 32 03305000 +GO TO CDIVDR; % COMPLEX / REAL 33 03305100 +GO TO CDIVDD; % COMPLEX / DOUBLE 34 03305200 +GO TO CDIVDC; % COMPLEX / COMPLEX 35 03305300 +RPLUSD: P(0,C,B,A,DLA,.B,STD,.C,STD,XIT); 03305400 +RPLUSC: P(A,C,ADD,B,.C,STD,.B,STD,XIT); 03305500 +DPLUSC: P(A,C,ADD,.C,STD,B,.D,STD,XIT); 03305600 +CPLUSD: P(A,C,ADD,.C,STD,XIT); 03305700 +CPLUSC: P(A,C,ADD,.C,STD,B,D,ADD,.D,STD,XIT); 03305800 +RLESSD: P(0,C,B,A,DLS,.B,STD,.C,STD,XIT); 03305900 +RLESSC: P(C,A,SUB,B,CHS,.C,STD,.B,STD,XIT); 03306000 +DLESSC: P(C,A,SUB,.C,STD,B,CHS,.D,STD,XIT); 03306100 +CLESSD: P(C,A,SUB,.C,STD,XIT); 03306200 +CLESSC: P(D,B,SUB,.D,STD,C,A,SUB,.C,STD,XIT); 03306300 +RTIMED: P(0,C,B,A,DLM,.B,STD,.C,STD,XIT); 03306400 +RTIMEC: P(C,DUP,B,MUL,.C,STD,A,MUL,.B,STD,XIT); 03306500 +DTIMEC: P(C,DUP,A,MUL,.C,STD,B,MUL,.D,STD,XIT); 03306600 +CTIMER: P(A,DUP,B,MUL,.B,STD,C,MUL,.C,STD,XIT); 03306700 +CTIMED: P(A,DUP,C,MUL,.C,STD,D,MUL,.D,STD,XIT); 03306800 +CTIMEC: P(A,C,MUL,D,B,MUL,SUB,C,B,MUL,A,D,MUL,ADD,.D,STD,.C,STD,XIT); 03306900 +RDIVDD: P(0,C,B,A,DLD,.B,STD,.C,STD,XIT); 03307000 +RDIVDC: P(C,A,DUP,MUL,B,DUP,MUL,ADD,/,DUP,B,MUL,CHS, 03307100 + C,STD,A,MUL,.B,STD,XIT); 03307200 +DDIVDC: P(C,A,DUP,MUL,B,DUP,MUL,ADD,/,DUP,B,MUL,CHS, 03307300 + D,STD,A,MUL,.C,STD,XIT); 03307400 +CDIVDR: P(B,A,/,.B,STD,C,A,/,.C,STD,XIT); 03307500 +CDIVDD: P(C,A,/,.C,STD,D,A,/,.D,STD,XIT); 03307600 +CDIVDC: P(A,C,MUL,B,D,MUL,ADD,A,DUP,MUL,B,DUP,MUL,ADD,.T,STN,/, 03307700 + A,D,MUL,B,C,MUL,SUB,T,/,.D,STD,.C,STD,XIT); 03307800 +INLINE: P(MKS,10,ERR); % COMPILER WRITERS ERROR 03307900 +END MATH; 03308000 +PROCEDURE XTOI; % 056 03400000 +COMMENT VARIOUS COMBINATIONS OF X TO THE I % PF JUNE 67 03400100 + CODE = 3|TYPE(OP 1) + TYPE(OP 2) 03400200 + TYPE VALUE 03400300 + REAL 0 03400400 + DOUBLE 1 03400500 + COMPLEX 2; 03400600 +BEGIN REAL CODE = -1, 03400700 + A = -3, 03400800 + B = -4, 03400900 + C = -5, 03401000 + D = -6, 03401100 + JUNK = 17, 03401200 + T=+1,V=+2,ERR=+3,BOOL=+4,CDTOG=+5 ; 03401300 + REAL EXPINT=27, LNINT=29 ; 03401350 + INTEGER J=+6,I=J,R=CDTOG ; 03401400 + REAL EXP=+7,LN=+8,DEXP=EXP,DLOG=LN,CABS=+9,ATAN2=+10,SQRT=+11, 03401500 + COS=+12,SIN=+13 ; 03401510 + DEFINE DF(DF1)=FLAG(DF1 OR T) # ; 03401520 + LABEL REXPOR,DEXPOR,REXPOD,DEXPOD,CEXPOD,CEXPOR,REXPOC,DEXPOC,L1, 03401600 + L2,L3,L4,CEXPOC,CDENT,RDENT,TOPI,TOPIL,PI2,TPI2,HAF,PI,MAX, 03401700 + F096,L5,PIT,CREL,PICK,RX1,RX2,REXPOR1,CEXPOD2 ; 03401710 +P(0&85[1:41:7],0,DF(FORTERRI),0,0,0); IF CODE=0 THEN GO REXPOR ; 03401800 +IF CODE<5 THEN IF CODE!2 THEN BEGIN P(DF(DEXPI),DF(DLOGI)); GO PICK END;03401900 +P(DF(EXPI),DF(LNI),DF(CABSI),DF(ATAN2I),DF(SQRTI),DF(COSI),DF(SINI)) ; 03401910 +PICK: T~0 ; 03401920 +GO TO P(CODE,DUP,ADD); 03402000 +GO TO REXPOR; % REAL ** REAL 0 03402100 +GO TO REXPOD; % REAL ** DOUBLE 1 03402200 +GO TO REXPOC; % RLAL ** COMPLEX 2 03402300 +GO TO DEXPOR; % DOUBLE ** REAL 3 03402400 +GO TO DEXPOD; % DOUBLE ** DOUBLE 4 03402500 +GO TO DEXPOC; % DOUBLE ** COMPLEX 5 03402600 +GO TO CEXPOR; % COMPLEX ** REAL 6 03402700 +GO TO CEXPOD; % COMPLEX ** DOUBLE 7 03402800 +GO TO CEXPOC; % COMPLEX ** COMPLEX 8 03402810 +DEXPOC: R~P(.C); I~P(.D); C~C+0&C[1:1:8]&D[47:9:1]; GO L3 ; 03402815 +REXPOC: R~P(.B); I~P(.C) ; 03402820 +L3: IF C=0 THEN BEGIN P(0); GO L1 END ; 03402825 + IF B=0 THEN 03402830 + BEGIN 03402835 + IF A=0 THEN BEGIN P(1); GO L1 END ; 03402837 + IF C>0 THEN GO L5 ; 03402840 + IF ABS(A) LEQ P(MAX) THEN IF P(A,.BOOL,ISN)=A THEN 03402845 +L4: BEGIN A~BOOL ; 03402850 +L5: P(ABS(C),A,MKS,.EXP,LOD,INTCALL(*P(.LN),XTOII),DEL) ;03402855 + IF B!0 THEN GO L2; IF BOOL THEN P(CHS) ; 03402860 +L1: P(R,STD,0,I,STD,XIT) ; 03402865 + END ; 03402870 + T~P(PI)|A; P(MKS,MKS,ABS(C),LN,A,|,EXP); GO L2 ; 03402875 + END ; 03402880 + T~(V~P(MKS,ABS(C),LN))|B ; 03402885 + IF A=0 THEN 03402890 + BEGIN 03402895 + IF C>0 THEN P(MKS,T,COS,R,STD,MKS,T,SIN,I,STD,XIT) ; 03402900 + P(MKS,(-P(PI))|B,EXP) ; 03402905 +L2: P(V~P,MKS,T,COS,|,R,STD,MKS,T,SIN,V,|,I,STD,XIT) ; 03402910 + END ; 03402915 + IF C<0 THEN 03402920 + BEGIN P(MKS,V|A-B|P(PI),EXP); T~T+P(PI)|A; GO L2 END ; 03402925 + IF ABS(A) LEQ 1023 THEN IF P(A,.BOOL,ISN)=A THEN GO L4 ; 03402930 + P(MKS,A|V,EXP); GO L2 ; 03402950 +CEXPOC: IF B=0 THEN GO CEXPOD2 ; 03402965 + R~P(.C); I~P(.D); IF D=0 THEN GO L3 ; 03402970 + IF C=0 THEN BEGIN T~ABS(D); P(PIT); IF D<0 THEN P(SSN); V~P END03402975 + ELSE BEGIN T~P(MKS,D,C,CABS); V~P(MKS,D,C,ATAN2) END ; 03402980 + T~(BOOL~P(MKS,T,LN))|B+V|A; P(MKS,BOOL|A-V|B,EXP); GO L2 ; 03402985 +PI::: 3.14159265359 ; 03402990 +MAX::: @0007777777777777 ; 03402991 +PIT::: @1141444176652104 ; 03402992 +REXPOR: IF B = 0 OR B = 1 THEN P(XIT); 03403000 + IF A = 0 THEN P(1,.B,STD,XIT); 03403100 + IF ABS(A)<4096 THEN IF (J~A)=A THEN 03403200 +REXPOR1: BEGIN IF BOOL~J<0 THEN J~-J ; 03403300 + P(J,.T,STD,B); 03403400 + WHILE (T ~ (J ~ T).[36:11]) ! 0 DO 03403500 + BEGIN P(DUP); 03403600 + IF J THEN 03403700 + BEGIN V ~ V + 1; 03403800 + P(DUP); 03403900 + END; 03404000 + P(MUL); 03404100 + END; 03404200 + WHILE (V ~ V - 1) } 0 DO P(MUL); 03404300 + IF BOOL THEN P(1,XCH,/); 03404400 + IF CDTOG!0 THEN 03404410 + BEGIN 03404415 + IF CDTOG>2 THEN P(.C,.D) ELSE P(.B,.C) ; 03404420 + J~(J~A) AND 3; 03404422 + IF BOOL AND J THEN J~(J+2) AND 3; 03404424 + IF C=0 THEN RX1: P(0,XCH,STD,STD,XIT) ; 03404425 + IF J = 0 THEN GO RX1; 03404430 + IF J=1 THEN BEGIN P(XCH); GO RX1 END ; 03404435 + IF J=2 THEN RX2: P(0,XCH,STD,XCH,CHS,XCH,STD,XIT) ; 03404440 + P(XCH); GO RX2 ; 03404445 + END ; 03404450 + P(.B,STD,XIT); 03404500 + END; 03404600 + IF B>0 03404700 + THEN P(MKS,MKS,B,LNINT,A,|,EXPINT,.B,STD,XIT); %FORTRAN ONLY 03404710 + P(MKS,11,ERR); 03404800 +REXPOD: P(0,.B,.C); GO RDENT ; 03404900 +DEXPOR: P(C,.B,.C); C~B; B~0; GO RDENT ; 03405000 +DEXPOD: P(D,.C,.D) ; 03405100 +RDENT: CODE~P; R~P; JUNK~P; IF C=0 THEN P(0,CODE,STD,XIT) ; 03405200 + IF A=0 THEN P(1,R,STD,0,CODE,STD,XIT) ; 03408100 + IF B = 0 THEN 03408200 + IF ABS(A)0 THEN P(MKS,MKS,JUNK,C,DLOG,JUNK,B,A,DLM,DEXP,CODE,STD, 03409800 + JUNK,R,STD,XIT) ; 03409900 + P(MKS,11,ERR); 03410000 +CEXPOR: IF B =0 THEN IF C = 0 THEN P(XIT); 03410100 + IF A = 0 THEN P(1,.B,STD,0,.C,STD,XIT); 03410200 +CDENT: IF ABS(A) P(PI2) THEN IF T < P(TPI2) THEN P(CHS); 03412500 + P(V,MUL,.B,STD); 03412600 + IF CDTOG THEN P(C,.D,STD,B,.C,STD); 03412700 + P(XIT); 03412800 +CEXPOD: A~A+0&A[1:1:8]&B[47:9:1] ; 03412900 +CEXPOD2: IF C=0 THEN IF D=0 THEN P(XIT) ; 03413000 + IF A=0 THEN P(1,.C,STD,0,.D,STD,XIT) ; 03413050 + B ~ C; 03413100 + C ~ D; 03413200 + CDTOG ~ TRUE; 03413300 + GO TO CDENT; 03413400 +TOPI ::: @1146220773250420; TOPIL ::: @0005506043230461; 03413500 +HAF ::: @1154000000000000; 03413600 +PI2 ::: @1141444176652104; 03413700 +TPI2 ::: @1144554574376314; 03413800 + 03413900 +END XTOI; 03414000 +PROCEDURE IDINT ; % 057 03500000 +COMMENT DOUBLE TO INTEGER CONVERT; % PF JULY 67 03501000 +BEGIN REAL X = -1, 03501001 + XL = -2; 03501002 +P(X + 0&X[1:1:8]&XL[47:9:1],1,DIV,RTN); 03501004 +END IDINT; 03501005 +PROCEDURE FLOAT ; % 060 03600000 +BEGIN REAL X = -1; 03600100 + P(X, RTN); 03600200 +END FLOAT; 03600300 +PROCEDURE SNGL ; % 061 03700000 +COMMENT SNGL INTRINSIC (DOUBLE TO SINGLE CONVERT); % PF JUNE 67 03700100 +BEGIN REAL X = -1, 03700200 + XL= -2; 03700300 +P(X + 0&X[1:1:8]&XL[47:9:1],RTN); 03700400 + 03700500 +END SNGL; 03700600 +PROCEDURE DBLE ; % 062 03800000 +COMMENT DBLE INTRINSIC (SINGLE TO DOUBLE); % PF JUNE 67 03800100 +BEGIN REAL X = -1, 03800200 + JUNK = 17; 03800300 +P(X,.JUNK,STD,0,RTN); 03800400 +END DBLE; 03800500 +PROCEDURE AMOD ; % 063 03900000 +BEGIN REAL X = -2, Y = -1; 03900100 + P(X MOD Y, RTN); 03900200 +END AMOD; 03900300 +PROCEDURE TIME ; % 064 04000000 +COMMENT FORTRAN TIME INTRINSIC (LIKE ALGOL); % PF JULY 67 04001000 +BEGIN REAL X =-1; 04001002 +P(X,1,COM,RTN); 04001003 +END TIME; 04001004 +PROCEDURE DMOD ; % DOUBLE PRECISION MOD INTRINSIC # @065. 04100000 + BEGIN 04100100 + REAL H=+2, B=-1, BL=-2, A=-3, AL=-4, E=17; LABEL G,Q ; 04100200 + IF B=0 THEN IF BL=0 THEN P(MKS,INTCALL(13,FORTERRI)) ; 04100300 + IF P(AL,ABS(A),BL,NABS(B),DLA,DUP)=0 THEN GO Q ; 04100400 + IF P<0 THEN P(AL,A,.E,~,RTN) ; 04100500 + IF (E~P(AL,A,BL,8,DLD,DUP).[3:6])>13 THEN P(.E,ISD) ; 04100550 + P(XCH) ; 04100600 + IF E=0 OR H.[2:1] THEN BEGIN P(DEL,0,XCH,E);::P(.G,+,LOD,LND,XCH)END04100700 + ELSE BEGIN P(13-E); :: P(.G,+,LOD,LND) END ; 04100750 + IF P(DUP,ABS(H),0,1,DLA,BL,NABS(B),DLM,AL,ABS(A),DLA)}0 THEN 04100800 +Q: P(E~0,RTN) ; 04100850 + P(DEL,XCH,BL,B,DLM,CHS,AL,A,DLA,.E,~,RTN) ; 04100900 +G:::@3777777777777777, % DYNAMIC MASK CONSTANTS. 04101000 +@3777777777777770,@3777777777777700,@3777777777777000,@3777777777770000,04101050 +@3777777777700000,@3777777777000000,@3777777770000000,@3777777700000000,04101100 +@3777777000000000,@3777770000000000,@3777700000000000,@3777000000000000;04101200 + END OF DMOD ; 04101300 +PROCEDURE DMAX1 ; % 066 04200000 +COMMENT DOUBLE PRCISION MAX ROUTINE; % PF JUNE 67 04200100 +BEGIN REAL X = -1, 04200200 + XL = -2, 04200300 + JUNK = 17, 04200400 + RCW = +0, SIZE = +1, NEW = +2, NEWL = +3, JUNKL = +4; 04200500 +P([RCW] INX 0,0,RCW,FCX,1,INX,SUB,0,0,XL,X,.JUNK,STD); 04200600 +WHILE (SIZE ~ SIZE - 2) > 0 DO 04200700 +IF P(NEWL ~ *P(.X,SIZE,ADD,.NEW,STN,1,ADD),NEW ~ *P(NEW), 04200800 + JUNKL,JUNK,DLS,XCH,DEL) > 0 THEN 04200900 + BEGIN JUNKL ~ NEWL; 04201000 + JUNK ~ NEW; 04201100 + END; 04201200 +P(JUNKL,RTN); 04201300 +END DMAX1; 04201400 +PROCEDURE DMIN1 ; % 067 04300000 +COMMENT DOUBLE PRCISION MIN ROUTINE; % PF JUNE 67 04300100 +BEGIN REAL X = -1, 04300200 + XL = -2, 04300300 + JUNK = 17, 04300400 + RCW = +0, SIZE = +1, NEW = +2, NEWL = +3, JUNKL = +4; 04300500 +P([RCW] INX 0,0,RCW,FCX,1,INX,SUB,0,0,XL,X,.JUNK,STD); 04300600 +WHILE (SIZE ~ SIZE - 2) > 0 DO 04300700 +IF P(NEWL ~ *P(.X,SIZE,ADD,.NEW,STN,1,ADD),NEW ~ *P(NEW), 04300800 + JUNKL,JUNK,DLS,XCH,DEL) < 0 THEN 04300900 + BEGIN JUNKL ~ NEWL; 04301000 + JUNK ~ NEW; 04301100 + END; 04301200 +P(JUNKL,RTN); 04301300 +END DMIN1; 04301400 +PROCEDURE SIGNV ; % 070 04400000 +COMMENT SIGN INTRINSIC; % PF JUNE 67 04400100 +BEGIN REAL S = -1, 04400200 + X = -2; 04400300 +P(X); 04400400 +IF S.[1:1] THEN P(SSN,RTN) ELSE P(SSP,RTN); 04400500 +END SIGN; 04400600 +PROCEDURE DSIGN ; % 071 04500000 +COMMENT COMPLEX DOUBLE SIGN INTRINSIC; % PF JUNE 67 04500100 +BEGIN REAL S = -1, 04500200 + X = -3, 04500300 + XL = -4, 04500400 + JUNK = 17; 04500500 +P(X); 04500600 +IF S.[1:1] THEN P(SSN) ELSE P(SSP); 04500700 +P(.JUNK,STD,XL,RTN); 04500750 +END DSIGN; 04500800 +PROCEDURE DIIM ; % 072 04600000 +BEGIN REAL X = -2, Y = -1; 04600100 + P(X -(IF X { Y THEN X ELSE Y),RTN); 04600200 +END DIIM; 04600300 +PROCEDURE REALP ; % 073 04700000 +COMMENT COMPLEX TO REAL INTRINSIC; % PF JUNE 67 04700100 +BEGIN REAL X = -1; 04700200 +P(X,RTN); 04700300 +END REALP; 04700400 +PROCEDURE AIMAG ; % 074 04800000 +COMMENT IMAGINARY PART OF COMPLEX NUMBER; % PF JULY 67 04801000 +BEGIN REAL Y = -2; 04801010 +P(Y,RTN); 04801020 +END AIMAG; 04801030 +PROCEDURE CMPLX ; % 075 04900000 +COMMENT TWO REALS TO A COMPLEX; % PF JULY 67 04900100 +BEGIN REAL Y = -1, 04900200 + X = -2, 04900250 + JUNK = 17; 04900300 +P(X,.JUNK,STD,Y,RTN); 04900400 +END CMPLX; 04900500 +PROCEDURE CONJG ; % 076 05000000 +COMMENT CONJUGATF INTRINSIC; % PF JUNE 67 05000100 +BEGIN REAL X = -1, 05000200 + XL = -2, 05000300 + JUNK = 17; 05000400 +P(X,.JUNK,STD,XL,CHS,RTN); 05000500 +END CONJG; 05000600 +PROCEDURE DEXP ; % 077 05100000 +COMMENT DOUBLE PRECISION EXPONENTIAL INTRINSIC; % PF JUNE 67 05100100 +BEGIN REAL X = -1, 05100200 + XL = -2, 05100300 + JUNK = 17, 05100400 + T,TL; 05100500 + BOOLEAN SIG,HUGE; 05100600 + INTEGER N; 05100700 + LABEL AT13,LG2,LG2L,EMAX,HAF,A,AL,B,BL,C,CL,D,DL,E,EL,F,FL,G,GL, 05100800 + CLGL,H,HL,I,IL,J,JL,K,KL,L,LL,M,ML; 05100900 + DEFINE TIMES = NOP,DLA,XL,X,NOP,DLM#; 05101000 +IF SIG ~ X.[1:1] THEN X ~ ABS(X); 05101100 +IF HUGE~X>27 THEN IF X>P(EMAX) THEN P(MKS,INTCALL(14,FORTERRI)) ; 05101150 + 05101250 +P(XL,X,LG2L,LG2,DLD,.X,STD,DUP,X,XCH,X,0,AT13,DLA,0,AT13,DLS, 05101300 + .JUNK,STN,DLS,.X,STD,.XL,STD); 05101400 +T ~ 1; IF HUGE THEN WHILE (N ~ N + 1) { JUNK DO P(TL,DUP,T,XCH,T,DLA, 05101500 + T,STD,.TL,STD) 05101501 + ELSE WHILE (N ~ N + 1) { JUNK DO T ~ P(T,DUP,ADD); 05101502 +P(ML,M,XL,X,DLM); 05101600 +:: P(LL,L,TIMES,KL,K,TIMES,JL,J,TIMES,IL,I,TIMES,HL,H,TIMES,GL,G,TIMES, 05101700 + FL,F,TIMES,EL,F,TIMES,DL,D,TIMES,CL,C,TIMES,BL,B,TIMES,AL,A,TIMES, 05101800 + CLGL,LG2,TIMES,0,1,DLA,TL,T,DLM,.JUNK,STD); 05101900 +IF SIG THEN P(0,XCH,1,XCH,JUNK,DLD,.JUNK,STD); 05102000 +P(RTN); 05102100 +AT13 ::: @0151000000000000; 05102200 +HAF ::: @1154000000000000; 05102300 +EMAX ::: @1122360000000000; CLGL ::: @0007173632567030; 05102400 +LG2 ::: @1155427102775750; LG2L ::: @0007173632571165; 05102500 +M ::: @1333302330351773; ML ::: @0005405676153645; 05102600 +L ::: @1325447251503330; LL ::: @0003745760641244; 05102700 +K ::: @1301616647307714; KL ::: @0002676025700645; 05102800 +J ::: @1273641733265077; JL ::: @0006664462403121; 05102900 +I ::: @1267446477210572; IL ::: @0003454166117342; 05103000 +H ::: @1241552224137002; HL ::: @0007263626741044; 05103100 +G ::: @1232613001073174; GL ::: @0002061610334651; 05103200 +F ::: @1223777137704414 FL ::: @0000407415212622; 05103300 +E ::: @1215030221137052; EL ::: @0005757400272176; 05103400 +D ::: @1205354177717051; DL ::: @0002237577766326; 05103500 +C ::: @1174731253337351; CL ::: @0001657523134265; 05103600 +B ::: @1163432604327011; BL ::: @0002027630376772; 05103700 +A ::: @1151727757377602; AL ::: @0006130725275347; 05103800 +END DEXP; 05103900 +PROCEDURE CEXP ; % 100 05200000 +COMMENT COMPLEX EXPONENTIAL INTRINSIC; % PF JUNE 67 05200100 +BEGIN REAL X = -1, 05200200 + Y = -2, 05200300 + JUNK = 17 ; 05200400 + LABEL EMAX,TOPI,PI2,TPI2; 05200800 +IF ABS(X)>P(EMAX) THEN P(MKS,INTCALL(15,FORTERRI)) ; 05200900 +P(MKS,INTCALL(X,EXPI),.X,STN,MKS,1,MKS,Y,TOPI,MOD,DUP,SSP,.Y,STD, 05201000 + CALLINT(SINI),DUP,X,MUL,.JUNK,STD,DUP,MUL,SUB,CALLINT(SQRTI),MUL) ; 05201100 +IF Y > P(PI2) THEN IF Y < P(TPI2) THEN P(CHS); 05201200 +P(JUNK,XCH,.JUNK,STD,RTN); 05201300 +EMAX ::: @1122360000000000; 05201400 +TOPI ::: @1146220773250421; 05201500 +PI2 ::: @1141444176652104; 05201600 +TPI2 ::: @1144554574376314; 05201700 +END CEXP; 05201800 +PROCEDURE DLOG ; % 101 05300000 +COMMENT DOUBLE PRECISION NATURAL LOG INTRINSIC; % PF JUNE 67 05300100 +BEGIN REAL X = -1, 05300200 + XL = -2, 05300300 + JUNK = 17, 05300400 + T,TL; 05300500 + INTEGER N; 05300600 + BOOLEAN LESS1; 05300700 + LABEL HAF,LG2,LG2L,SQ2,SQ2L,A,AL,B,BL,C,CL,D,DL,E,EL,F,FL,G,GL, 05300800 + H,HL,I,IL,J,JL; 05300900 +DEFINE TIMES = NOP,DLA,XL,X,NOP,DLM#; 05301000 +IF X LEQ 0 THEN P(MKS,INTCALL(16+(X!0),FORTERRI)) ; 05301100 +IF LESS1 ~ X < 1 THEN P(0,1,XL,X,DLD,.X,STD,.XL,STD); 05301200 +P(1,.N,STN,.JUNK,STD); 05301300 +WHILE (JUNK ~ P(JUNK,DUP,ADD)) { X DO N ~ N + 1; 05301400 +IF P(XL,X,0,JUNK,DLD,.JUNK,STD,.T,STN,JUNK,SQ2L,SQ2,DLS,XCH,DEL) < 0 05301500 +THEN 05301550 + BEGIN N ~ N - 1; 05301600 + P(HAF,.IL,STD); 05301700 + END ELSE TL ~ 1; 05301800 +P(T,JUNK,0,TL,DLS,T,JUNK,0,TL,DLA,DLD,.JUNK,STD,.T,STN,DUP,JUNK,XCH, 05301900 + JUNK,DLM,.X,STD,.XL,STN,X,JL,J,DLM); 05301950 +:: P(IL,I,TIMES,HL,H,TIMES,GL,G,TIMES,FL,F,TIMES,EL,E,TIMES, 05302000 + DL,D,TIMES,CL,C,TIMES,BL,B,TIMES,AL,A,TIMES, 05302100 + 0,2,DLA,T,JUNK,DLM,0,N,LG2L,LG2,DLM,DLA,.JUNK,STD); 05302200 +IF LESS1 THEN P(JUNK,CHS,.JUNK,STD); 05302300 +P(RTN); 05302400 +HAF ::: @1154000000000000; 05302500 +LG2 ::: @1155427102775750; LG2L ::: @0007173632571165; 05302600 +SQ2 ::: @1155520236314774; SQ2L ::: @0007363110213136; 05302700 +J ::: @1167100510467432; JL ::: @0002164460474016; 05302800 +I ::: @1166521204435224; IL ::: @0007651024467003; 05302900 +H ::: @1167420605757260; HL ::: @0002135500773125; 05303000 +G ::: @1151042101275720; GL ::: @0000102676565544; 05303100 +F ::: @1151166116643351; FL ::: @0001161621531011; 05303200 +E ::: @1151350564271710; EL ::: @0007071635510300; 05303300 +D ::: @1151616161616162; DL ::: @0006643172311051; 05303400 +C ::: @1152222222222222; CL ::: @0002176633022026; 05303500 +B ::: @1153146314631463; BL ::: @0001463176726243; 05303600 +A ::: @1155252525252525; AL ::: @0002525252507053; 05303700 +END DLDC; 05303800 +PROCEDURE CLOG ; % 102 05400000 +COMMENT COMPLEX LOG INTRINSIC; % PF JUNE 67 05400100 +BEGIN REAL X = -1, 05400200 + Y = -2, 05400300 + JUNK = 17 ; 05400400 +IF Y=0 THEN 05400900 + IF X=0 THEN P(MKS,INTCALL(18,FORTERRI)) 05400950 + ELSE IF X>0 THEN P(MKS,INTCALL(X,LNI),.JUNK,STD,0,RTN) ; 05400975 +JUNK~P(MKS,INTCALL(P(MKS,X,INTCALL(Y,CABSI)),LNI)) ; 05401000 +P(MKS,Y,INTCALL(X,ATAN2I),RTN) ; 05401100 +END CLOG; 05401200 +PROCEDURE ALOG10; % 103 05500000 +COMMENT LOG BASE 10 INTRINSIC; % PF JUNE 67 05500100 +BEGIN REAL X=-1 ; 05500200 + LABEL LGI; 05500400 +IF X LEQ 0 THEN P(MKS,INTCALL(19+(X!0),FORTERRI)) ; 05500500 +P(MKS,INTCALL(X,LNI),LGI,MUL,RTN) ; 05500600 +LGI ::: @1153362675425116; 05500700 +END ALOC10; 05500800 +PROCEDURE DLOG10; % 104 05600000 +COMMENT DOUBLE PRECISION COMMON LOG INTRINSIC; % PF JUNE 67 05600100 +BEGIN REAL X = -1, 05600200 + XL = -2, 05600300 + JUNK = 17 ; 05600400 + LABEL LGI,LGIL; 05600600 +IF X LEQ 0 THEN P(MKS,INTCALL(21+(X!0),FORTERRI)) ; 05600700 +P(MKS,XL,INTCALL(X,DLOGI),JUNK,LGIL,LGI,DLM,.JUNK,STD,RTN) ; 05600800 +LGI ::: @1153362675425115; LGIL ::: @0006241614523261; 05600900 +END DLOG10; 05601000 +PROCEDURE DSIN ; % 105 05700000 +COMMENT DOUBLE PRECISION SINE INTRINSIC; % PF JUNE 67 05700100 +BEGIN REAL X = -1, 05700200 + XL = -2, 05700300 + JUNK = 17, 05700400 + T; 05700600 + BOOLEAN SIG; 05700700 + LABEL TOPI,TOPIL,PI,PIL,PI2,PI2L,TPI2,TPI2L, 05700800 + A,AL,B,BL,C,CL,D,DL,E,EL,F,FL,G,GL,H,HL,I,IL,J,JL; 05700900 +DEFINE ADDER = NOP,DLA,T,JUNK,NOP,DLM#, 05701000 + SUBER = NOP,DLS,T,JUNK,NOP,DLM#; 05701050 +IF SIG ~ X.[1:1] THEN X ~ P(X,SSP); 05701100 +IF P(MKS,XL,X,TOPIL,INTCALL(TOPI,DMODI),JUNK,.X,STD,.XL,STN,X,PI2L,PI2, 05701200 + DLS,XCH,DEL)>0 05701250 + THEN IF P(XL,X,PIL,PI,DLS,XCH,DEL) { 0 05701300 + THEN P(PIL,PI,XL,X,DLS) 05701400 + ELSE BEGIN SIG ~ NOT SIG; 05701500 + IF P(XL,X,TPI2L,TPI2,DLS,XCH,DEL) { 0 05701600 + THEN P(XL,X,PIL,PI,DLS) 05701700 + ELSE P(TOPIL,TOPI,XL,X,DLS); 05701800 + END 05701900 + ELSE P(XL,X); 05702000 +P(.X,STD,.XL,STN,DUP,X,XCH,X,DLM,.JUNK,STD,.T,STN,JUNK,JL,J,DLM); 05702100 +:: P(IL,I,SUBER,HL,H,ADDER,GL,G,SUBER,FL,F,ADDER,EL,E,SUBER,DL,D,ADDER, 05702200 + CL,C,SUBER,BL,B,ADDER,AL,A,SUBER,0,1,DLA,XL,X,DLM,.JUNK,STD); 05702300 +IF SIG THEN P(JUNK,CHS,.JUNK,STD); 05702400 +P(RTN); 05702500 +PI2 ::: @1141444176652104; PI2L ::: @0001321410646113; 05702600 +PI ::: @1143110375524210; PIL ::: @0002643021514230; 05702700 +TPI2 ::: @1144554574376314; TPI2L ::: @0004164432362343; 05702800 +TOPI ::: @1146220773250420; TOPIL ::: @0005506043230461; 05702900 +J ::: @1421317506616043; JL ::: @0004106341505647; 05703000 +I ::: @1371136261610121; IL ::: @0001561406721354; 05703100 +G ::: @1323271771732327; GL ::: @0001122361440352; 05703200 +F ::: @1271302221411627; FL ::: @0002101305056316; 05703300 +E ::: @1253271442547752; EL ::: @0002347333135765; 05703400 +D ::: @1235616743512533; DL ::: @0000704703144000; 05703500 +C ::: @1216400640064006; CL ::: @0004006354436671; 05703600 +B ::: @1174210421042104; BL ::: @0002104210366543; 05703700 +A ::: @1151252525252525; AL ::: @0002525252525234; 05703800 +H ::: @1356251301236324;; HL ::: @0007344376112457; 05703900 +END DSIN; 05704000 +PROCEDURE CSIN ; % 106 05800000 +COMMENT COMPLEX SINE INTRINSIC; % PF JUNE 67 05800100 +BEGIN REAL X = -1, 05800200 + Y = -2, 05800300 + JUNK = 17, 05800400 + T; 05800800 + LABEL EMAX,HAF,TOPI,PI2,TPI2; 05800900 +IF ABS(Y)>P(EMAX) THEN P(MKS,INTCALL(23,FORTERRI)) ; 05801000 +P(MKS,INTCALL(Y,EXPI),DUP,DUP,1,XCH,/,.Y,STN,SUB,HAF,MUL,.T,STD, 05801100 + Y,ADD,HAF,MUL,MKS,X,TOPI,MOD,DUP,SSP,.X,STD,CALLINT(SINI),.Y,STN,MUL, 05801200 + MKS,1,Y,DUP,MUL,SUB,CALLINT(SQRTI),T,MUL) ; 05801300 +IF X > P(PI2) THEN IF X < P(TPI2) THEN P(CHS); 05801400 +P(XCH,.JUNK,STD,RTN); 05801500 +EMAX ::: @1122360000000000; 05801600 +HAF ::: @1154000000000000; 05801700 +TOPI ::: @1146220773250421; 05801800 +PI2 ::: @1141444176652104; 05801900 +TPI2 ::: @1144554574376314; 05802000 +END CSINE; 05802100 +PROCEDURE DCOS ; % 107 05900000 +COMMENT DOUBLE PRECISION COSINE INTRINSIC; % PF JUNE 67 05900100 +BEGIN REAL X = -1, 05900200 + XL = -2, 05900300 + LOW = -4 ; 05900400 + LABEL PI2,PI2L; 05900600 +P(MKS,XL,X,PI2L,PI2,DLA,CALLINT(DSINI),RTN) ; 05900700 +PI2 ::: @1141444176652104; PI2L ::: @0001321410646113; 05900800 +END DCOS; 05900900 +PROCEDURE CCOS ; % 110 06000000 +COMMENT COMPLEX COSINE INTRINSIC; % PF JUN 67 06000100 +BEGIN REAL X = -1, 06000200 + Y = -2, 06000300 + JUNK = 17, 06000400 + T; 06000800 + LABEL EMAX,HAF,TOPI,TPI2,PI2,MHAF; 06000900 +IF ABS(Y)>P(EMAX) THEN P(MKS,INTCALL(24,FORTERRI)) ; 06001000 +P(MKS,INTCALL(Y,EXPI),DUP,DUP,1,XCH,/,.Y,STN,SUB,MHAF,MUL,MKS,X,TOPI, 06001100 + MOD,DUP,SSP,.X,STD,CALLINT(SINI),.T,STN,MUL,.JUNK,STD,Y,ADD,HAF,MUL, 06001200 + MKS,1,T,DUP,MUL,SUB,CALLINT(SQRTI),MUL) ; 06001300 +IF X > P(PI2) THEN IF X < P(TPI2) THEN P(CHS); 06001400 +P(JUNK,XCH,.JUNK,STD,RTN); 06001500 +EMAX ::: @1122360000000000; 06001600 +HAF ::: @1154000000000000; 06001700 +TOPI ::: @1146220773250421; 06001800 +TPI2 ::: @1144554574376314; 06001900 +PI2 ::: @1141444176652104; 06002000 +MHAF ::: @3154000000000000; 06002100 +END CCOS; 06002200 +PROCEDURE TANF ; % 111 06100000 +COMMENT TANGENT INTRINSIC; % PF MAY 67 06100100 +BEGIN REAL RSQ; 06100200 + REAL X = -1; 06100300 + INTEGER Q; BOOLEAN S; 06100400 + LABEL L1,L2,PMAX,MMAX,PI,PI2,PI4; 06100500 +IF S ~ X.[1:1] THEN X ~ P(X,SSP); 06100600 +IF (Q ~ P(X,PI,MOD,.X,STN,PI4,DIV)) ! 0 THEN X ~ 06100700 +IF Q=1 THEN P(PI2,X,SUB) ELSE IF Q=2 THEN P(X,PI2,SUB) ELSE P(PI,X,SUB);06100800 +IF X = 0 THEN BEGIN IF Q = 1 THEN P(PMAX) ELSE IF Q = 2 THEN P(MMAX) 06100900 + ELSE P(0); GO TO L1; 06101000 + END; 06101100 +P(1,X,DUP,MUL,.RSQ,STN,DUP,.0097433825958,MUL,CHS,1,ADD,MUL, 06101200 + 16.248537744,SUB, 06101300 + 48.7456132319,RSQ,/,6.2497075488,SUB,RSQ,DUP, 06101400 + .000361003565256,MUL,CHS,.136381360679,ADD,MUL,ADD, 06101500 + /,ADD); 06101600 +IF Q = 0 THEN P(X,XCH,/) 06101700 + ELSE IF Q = 1 THEN P(X,/) 06101800 + ELSE IF Q = 2 THEN P(X,/,CHS) 06101900 + ELSE P(X,XCH,/,CHS); 06102000 +L1: 06102100 +IF S THEN P(CHS); 06102200 +P(RTN); 06102300 +PMAX ::: @0777777777777777; 06102400 +MMAX ::: @2777777777777777; 06102500 +PI ::: @1143110375524210; 06102600 +PI2 ::: @1141444176652104; 06102700 +PI4 ::: @1156220773250421; 06102800 +END TAN; 06102900 +PROCEDURE COTAN ; % 112 06200000 +COMMENT COTANGENT INTRINSIC; % PF MAY 67 06200100 +BEGIN REAL T ; 06200200 + REAL X = -1; 06200300 + LABEL PMAX; 06200400 + IF (T~P(MKS,INTCALL(X,TANI)))=0 THEN P(PMAX) 06200500 + ELSE P(1,T,/); 06200600 +P(RTN); 06200700 +PMAX ::: @0777777777777777; 06200800 +END COTAN; 06200900 +PROCEDURE DATAN ; % 113 06300000 +COMMENT DOUBLE PRECISION ARC TANGENT INTRINSIC; % PF JUNE 67 06300100 +BEGIN REAL X = -1, 06300200 + XL = -2, 06300300 + JUNK = 17, 06300400 + T; 06300500 + BOOLEAN S,U,Y; 06300600 + LABEL SR3,SR3L,PI6,PI6L,PI2,PI2L,A,AL,B,BL,C,CL,D,DL,E,EL,F,FL, 06300700 + G,GL,H,HL,I,IL,J,JL,K,KL,L,LL,M,ML; 06300800 +DEFINE AM = NOP,DLA,T,JUNK,NOP,DLM#, SM = NOP,DLS,T,JUNK,NOP,DLM#; 06300900 +IF S ~ X.[1:1] THEN X ~ P(X,SSP); 06301000 +IF Y ~ X > 1 THEN P(0,1,XL,X,DLD,.X,STD,.XL,STD); 06301100 +IF U ~ X > .2679491924311 THEN P(SR3L,SR3,0,4,SR3L,SR3,XL,X,DLA, 06301200 + DLD,DLS,.X,STD,.XL,STD); 06301300 +P(XL,DUP,X,XCH,X,DLM,.JUNK,STD,.T,STN,JUNK,ML,M,DLM); 06301400 +:: P(LL,L,AM,KL,K,SM,JL,J,AM,IL,I,SM,HL,H,AM,GL,G,SM,FL,F,AM,EL,E,SM, 06301500 + DL,D,AM,CL,C,SM,BL,B,AM,AL,A,SM,0,1,DLA,XL,X,DLM,.JUNK,STD); 06301600 +IF U THEN P(JUNK,PI6L,PI6,DLA,.JUNK,STD); 06301700 +IF Y THEN P(JUNK,PI2L,PI2,DLS,CHS,.JUNK,STD); 06301800 +IF S THEN P(JUNK,CHS,.JUNK,STD); 06301900 +P(RTN); 06302000 +SR3 ::: @1141566636564130; SR3L ::: @0002312516354455; 06302100 +PI6 ::: @1154140522160265; PI6L ::: @0006331302145566; 06302200 +PI2 ::: @1141444176652104; PI2L ::: @0001321410646113; 06302300 +M ::: @3161401124046414; ML ::: @0004072764260344; 06302400 +L ::: @1162303273323564; LL ::: @0001630262103372; 06302500 +K ::: @1162605113035023; KL ::: @0004301553367304; 06302600 +J ::: @1163027321345406; JL ::: @0003326323362544; 06302700 +I ::: @1163274446267506; IL ::: @0001464411354576; 06302800 +H ::: @1163607415673413; HL ::: @0001424256207512; 06302900 +G ::: @1164210421020314; GL ::: @0001737716236562; 06303000 +F ::: @1164730473047014; FL ::: @0006266260505571; 06303100 +E ::: @1165642721350561; EL ::: @0006467443753240; 06303200 +D ::: @1167070707070707; DL ::: @0000552165603175; 06303300 +C ::: @1151111111111111; CL ::: @0001111051232710; 06303400 +B ::: @1151463146314631; BL ::: @0004631463070633; 06303500 +A ::: @1152525252525252; AL ::: @0005252525252470; 06303600 +END DATAN; 06303700 +PROCEDURE ATAN2 ; % 114 06400000 +COMMENT ARC TANGENT OF A/B INTRINSIC; % PF MAY 67 06400100 +BEGIN 06400200 + REAL A = -2, B = -1; 06400300 + LABEL PI,PI2,MPI2; 06400400 +IF B > 0 THEN 06400500 + IF A!0 THEN P(MKS,INTCALL(A/B,ARCTANI)) 06400550 + ELSE P(0) 06400600 +ELSE 06400650 + IF B < 0 THEN 06400700 + IF A>0 THEN P(MKS,INTCALL(A/B,ARCTANI),PI,ADD) 06400750 + ELSE 06400800 + IF A<0 THEN P(MKS,INTCALL(A/B,ARCTANI),PI,SUB) 06400850 + ELSE P(PI) 06400900 + ELSE 06400950 + IF A < 0 THEN P(MPI2) 06401000 + ELSE P(PI2); 06401050 +P(RTN); 06401100 +PI ::: @1143110375524210; 06401200 +PI2 ::: @1141444176652104; 06401300 +MPI2 ::: @3141444176652104; 06401400 +END ATAN2; 06401500 +PROCEDURE DATAN2; % 115 06500000 +COMMENT DOUBLE PRECISION ARC TANGENT OF A/B INTRINSIC; % PF JUNE 67 06500100 +BEGIN REAL B = -1, 06500200 + BL = -2, 06500300 + A = -3, 06500400 + AL = -4, 06500500 + JUNK = 17 ; 06500600 + LABEL PI,PIL,PI2,MPI2,PI2L; 06500800 +IF A ! 0 AND B ! 0 THEN 06500900 + BEGIN P(MKS,AL,A,BL,B,DLD,CALLINT(DATANI)) ; 06501000 + IF B.[1:1] THEN IF A > 0 THEN P(JUNK,PIL,PI,DLA,.JUNK,STD,RTN) 06501100 + ELSE P(JUNK,PIL,PI,DLS,.JUNK,STD,RTN); 06501300 + END ELSE 06501500 +IF B = 0 THEN IF A.[1:1] THEN P(MPI2,.JUNK,STD,PI2L,RTN) 06501600 + ELSE P( PI2,.JUNK,STD,PI2L,RTN) 06501700 + ELSE IF B.[1:1] THEN P(PI,.JUNK,STD,PIL,RTN) 06501800 + ELSE P(0,.JUNK,STN,RTN); 06501900 +P(RTN); 06502000 +PI ::: @1143110375524210; PIL ::: @0002643021514230; 06502100 +PI2 ::: @1141444176652104; PI2L ::: @0001321410646113; 06502200 +MPI2 ::: @3141444176652104; 06502300 +END DATAN2; 06502400 +PROCEDURE ARSIN ; % 116 06600000 +COMMENT ARC SINE INTRINSIC; % PF MAY 67 06600100 +BEGIN REAL X =-1, 06600200 + XSQ; 06600300 + BOOLEAN S,U; 06600400 + LABEL PI2,HAF,A,B,C,D,E,F,G,H,I,J,K,L,M,N; 06600500 + DEFINE TIMES = ADD,XSQ,MUL#; 06600600 +IF S ~ X.[1:1] THEN X ~ P(X,SSP); 06600700 +IF X>1 THEN P(MKS,INTCALL(26,FORTERRI)) ; 06600800 +IF U~X>P(HAF) THEN X~P(MKS,1,X,SUB,HAF,MUL,.XSQ,STN,CALLINT(SQRTI)) 06600900 +ELSE XSQ ~ X|X; 06601000 +:: P(NOP,A,XSQ,MUL,B,TIMES,C,TIMES,D,TIMES,E,TIMES,F,TIMES,G,TIMES, 06601100 + H,TIMES,I,TIMES,J,TIMES,K,TIMES,L,TIMES,M,TIMES,N,TIMES, 06601200 + 1,ADD,X,MUL); 06601300 +IF U THEN P(DUP,ADD,CHS,PI2,ADD); 06601400 +IF S THEN P(CHS); 06601500 +P(RTN); 06601600 +PI2 ::: @1141444176652104; HAF ::: @1154000000000000; 06601700 + A ::: @1172506721410650; B ::: @1172740556641135; 06601800 + C ::: @1173232061727030; D ::: @1173574736467510; 06601900 + E ::: @1174227363636371; F ::: @1174776745032742; 06602000 + G ::: @1175724170360740; H ::: @1177114631463146; 06602100 + I ::: @1161070473047305; J ::: @1161335056427214; 06602200 + K ::: @1161743434343434; L ::: @1162666666666667; 06602300 + M ::: @1164631463146315; N ::: @1151252525252526; 06602400 +END ARSIN; 06602500 +PROCEDURE ARCOS ; % 117 06700000 +COMMENT ARC COSINE INTRINSIC; % PF MAY 67 06700100 +BEGIN REAL X = -1 ; 06700200 + LABEL PI2; 06700400 +IF ABS(X)>1 THEN P(MKS,INTCALL(25,FORTERRI)) ; 06700500 + P(PI2,MKS,INTCALL(X,ARSINI),SUB) ; 06700600 + P(RTN); 06700700 +PI2 ::: @1141444176652104; 06700800 +END ARCOS; 06700900 +PROCEDURE SINH ; % 120 06800000 +COMMENT HYPERBOLIC SINE INTRINSIC; % PF MAY 67 06800100 +BEGIN REAL X = -1 ; 06800200 + BOOLEAN S; 06800400 + LABEL EMAX; 06800500 +DEFINE S1AM = /,1,ADD,MUL#; 06800600 +IF S ~ X.[1:1] THEN X ~ P(X,SSP); 06800700 +IF X>P(EMAX) THEN P(MKS,INTCALL(29,FORTERRI)) ; 06800800 +IF X { .5 THEN 06800900 + P(X,DUP,DUP,MUL,DUP,DUP,DUP,72,S1AM,42,S1AM,20,S1AM,6,S1AM) ELSE 06801000 + P(MKS,INTCALL(X,EXPI),DUP,1,XCH,/,SUB,.5,MUL) ; 06801100 +IF S THEN P(CHS); 06801200 +P(RTN); 06801300 +EMAX ::: @1122360000000000; 06801400 +END SINH; 06801500 +PROCEDURE COSH ; % 121 06900000 +COMMENT HYPFRBOL1C COSINE INTRINSIC; % PF MAY 67 06900100 +BEGIN REAL X = -1, 06900200 + T; 06900300 + LABEL EMAX; 06900400 +DEFINE S1AM = /,1,ADD,MUL#; 06900500 +IF (T~ABS(X))>P(EMAX) THEN P(MKS,INTCALL(30,FORTERRI)) ; 06900600 +IF T { .75 THEN 06900700 + P(X,DUP,MUL,DUP,DUP,DUP,DUP,90,S1AM,56,S1AM,30,S1AM,12,S1AM, 06900800 + .5,MUL,1,ADD) ELSE P(MKS,INTCALL(X,EXPI),DUP,1,XCH,/,ADD,.5,MUL) ; 06900900 +P(RTN); 06901000 +EMAX ::: @1122360000000000; 06901100 +END COSH; 06901200 +PROCEDURE TANH ; % 122 07000000 +COMMENT HYPERBOLIC TANGENT INTRINSIC; % PF MAY 67 07000100 +BEGIN REAL T ; 07000200 + REAL X = -1; 07000300 + BOOLEAN S; 07000400 +IF S ~ X.[1:1] THEN X ~ P(X,SSP); 07000600 +IF X > 27 THEN IF S THEN P(1,CHS,RTN) ELSE P(1,RTN); 07000700 +IF X { .14 THEN 07000800 + P(X,DUP,DUP,MUL,DUP,DUP,DUP,6.8888888889,MUL,17,SUB, 07000900 + MUL,21,/,2,ADD,MUL,5,/,1,SUB,MUL,3,/,1,ADD,MUL)07001000 +ELSE P(MKS,INTCALL(X,EXPI),DUP,.T,STN,1,XCH,/,DUP,T,ADD,.T,STD,SUB,T,/);07001100 +IF S THEN P(CHS); 07001200 +P(RTN); 07001300 +END TANH; 07001500 +PROCEDURE DSQRT ; % 123 07100000 +COMMENT DOUBLE PRECISION SQUARE ROOT INTRINSIC; % PF JUNE 67 07100100 +BEGIN REAL X = -1, 07100200 + XL = -2, 07100300 + JUNK = 17 ; 07100400 + LABEL HAF; 07100600 +IF X LEQ 0 THEN IF X=0 THEN P(0,.JUNK,STN,RTN) 07100700 + ELSE P(MKS,INTCALL(27,FORTERRI)) ; 07100710 +P(XL,X,0,MKS,INTCALL(X,SQRTI),.JUNK,STN,DLD,0,JUNK,DLA,0,HAF,DLM,.JUNK, 07100800 + STD,RTN) ; 07100810 +HAF ::: @1154000000000000; 07100900 +END DSQRT; 07101000 +PROCEDURE CSQRT ; % 124 07200000 +COMMENT COMPLEX SQUARE ROOT INTRINSIC; % PF JUNE 67 07200100 +BEGIN REAL X = -1, 07200200 + Y = -2, 07200300 + JUNK = 17 ; 07200400 + LABEL HAF; 07200700 +IF X = 0 THEN IF Y = 0 THEN P(0,.JUNK,STN,RTN); 07200800 +P(MKS,INTCALL(P(MKS,X,INTCALL(Y,CABSI),X,SSP,ADD,HAF,MUL),SQRTI)) ; 07200900 +IF X } 0 THEN P(.JUNK,STN,DUP,ADD,Y,XCH,/,RTN) 07201000 + ELSE BEGIN IF Y.[1:1] THEN P(CHS); 07201100 + P(DUP,DUP,ADD,Y,XCH,/,.JUNK,STD,RTN); 07201200 + END; 07201300 +HAF ::: @1154000000000000; 07201400 +END CSQRT; 07201500 +PROCEDURE ERF ; % 125 07300000 +COMMENT THE ERROR FUNCTION INTRINSIC; % PF MAY 67 07300100 +BEGIN REAL X = -1, 07300200 + XSQ,T,W; 07300400 + LABEL A,B,C,D,E,F,G,H,I,J,K,L,M,N,OVER,MSRTPI; 07300500 +DEFINE MORE = ADD,XSQ,MUL#, LESS = SUB,XSQ,MUL#; 07300600 +IF (XSQ ~ X|X) < 2.22 THEN 07300700 + :: P(NOP,A,XSQ,MUL,B,LESS,C,MORE,D,LESS,E,MORE,F,LESS,G,MORE,H,LESS, 07300800 + I,MORE,J,LESS,K,MORE,L,LESS,M,MORE,N,LESS,OVER,ADD,X,MUL,RTN); 07300900 +IF XSQ < 24 THEN 07301000 +BEGIN W ~ (XSQ + 14.5)|(T ~ XSQ + 6.6267867473) - 39.1779586414; 07301100 + T ~ (XSQ + 12.5)|W - 45.5|T; 07301200 + W ~ (XSQ + 10.5)|T - 33|W; 07301300 + T ~ (XSQ + 8.5)|W - 22.5|T; 07301400 + W ~ (XSQ + 6.5)|T - 14|W; 07301500 + T ~ (XSQ + 4.5)|W - 7.5|T; 07301600 + W ~ (XSQ + 2.5)|T - 3|W; 07301700 + T ~ (XSQ + .5)|W - .5|T; 07301800 + P(ABS(X),W,MUL,MKS,INTCALL(XSQ,EXPI),MSRTPI,MUL,T,MUL,/,1,ADD) ; 07301850 +END ELSE P(1); 07301900 +IF X.[1:1] THEN P(CHS); 07302000 +P(RTN); 07302100 +A ::: @1321164756260433; B ::: @1313314675626043; 07302200 +C ::: @1306316666647563; D ::: @1261242725431173; 07302300 +E ::: @1251771347130371; F ::: @1242575635313531; 07302400 +G ::: @1233347466027367; H ::: @1223723222675344; 07302500 +I ::: @1213746431157302; J ::: @1203400555500006; 07302600 +K ::: @1172531336320715; L ::: @1161560263430450; 07302700 +M ::: @1167161362064016; N ::: @1153004472153007; 07302800 +OVER ::: @1141101565650103; MSRTPI:::@3141613376110665; 07302900 +END ERF; 07303000 +PROCEDURE GAMMA ; % 126 07400000 +COMMENT GAMMA INTRINSIC; % PF MAY 67 07400100 +BEGIN REAL X = -1, 07400200 + E,V,Y; 07400400 + BOOLEAN S; INTEGER K; 07400500 + LABEL L1,PMAX,MMAX,PI,MPI; 07400600 +DEFINE SUBMUL = SUB,E,MUL#, ADDMUL = ADD,E,MUL#; 07400700 +IF S ~ X { 0 THEN X ~ P(X,SSP); 07400800 +IF X>52 THEN P(MKS,INTCALL(28,FORTERRI)) ; 07400900 +IF (E ~ P(X,DUP,.Y,SND,.5,SUB,.K,ISN,SUB)) = 0 THEN 07401000 + BEGIN IF S THEN IF K.[47:1] THEN P(MMAX)ELSE P(PMAX) 07401100 + ELSE IF K { 2 THEN P(1) 07401200 + ELSE GO TO L1; 07401300 + P(RTN); 07401400 + END; 07401500 +IF K < 2 THEN V ~ (IF K = 0 THEN P(1,X,DUP,1,ADD,MUL,/) ELSE 07401600 + IF K = 1 THEN 1/X ELSE 1) 07401700 + ELSE L1: BEGIN X ~ X - (V ~ 1); 07401800 + DO V ~ X|V UNTIL (X ~ X - 1) < 2; 07401900 + IF E = 0 THEN P(V,RTN); 07402000 + END; 07402100 +:: P(NOP,E,.00006771057117,MUL, 07402200 + 00034423420456,SUBMUL, 07402300 + .00153976810472,ADDMUL, 07402400 + 00246674798054,SUBMUL, 07402500 + 0109736958417,ADDMUL, 07402600 + 00021090746731,SUBMUL, 07402700 + .074237907606,ADDMUL, 07402800 + 081578218785,ADDMUL, 07402900 + 411840251796,ADDMUL, 07403000 + 422784336962,ADDMUL, 07403100 + 99999999999,ADD,V,MUL,.V,STN); 07403200 +IF S THEN P(DEL,MPI,MKS,INTCALL(P(PI)|Y,SINI),V,MUL,Y,MUL,/) ; 07403300 +P(RTN); 07403400 +PI ::: @1143110375524210; 07403500 +MPI ::: @3143110375524210; 07403600 +PMAX ::: @0777777777777777; 07403700 +MMAX ::: @2777777777777777; 07403800 +END GAMMA; 07403900 +PROCEDURE ALGAMA; % 127 07500000 +COMMENT LOG GAMMA INTRINSIC; % PF MAY 67 07500100 +BEGIN REAL X = -1, 07500200 + T; 07500400 +DEFINE SUBMUL = SUB,T,MUL#, ADDMUL = ADD,T,MUL#; 07500500 +IF X LEQ 0 THEN P(MKS,INTCALL(31+(X!0),FORTERRI)) ; 07500600 +IF X<3.28 THEN P(MKS,INTCALL(P(MKS,INTCALL(X,GAMMAI)),LNI),RTN) ; 07500700 + P(1,X,DUP,MUL,/,.T,SND); 07500800 + :: P(NOP,1.392432216906,CHS,MUL, 07500900 + .179644372369,ADDMUL, 07501000 + 0295506535948,SUBMUL, 07501100 + 0064102564103,ADDMUL, 07501200 + 00191752691753,SUBMUL, 07501300 + 00084175084175,ADDMUL, 07501400 + 00059523809524,SUBMUL, 07501500 + 00079365079365,ADDMUL, 07501600 + .00277777777778,SUBMUL, 07501700 + 083333333333,ADD,X,/,.91893853321,ADD, 07501800 + X,DUP,.5,SUB,MKS,INTCALL(X,LNI),MUL,XCH,SUB,ADD) ; 07501900 +P(RTN); 07502000 +END ALGAMA; 07502100 +PROCEDURE ANDI ; % 130 07600000 + BEGIN 07600100 + REAL A = - 1,B = -2; 07600200 + P(A AND B,RTN); 07600300 + END ANDI; 07600400 +PROCEDURE ORI ; % 131 07700000 + BEGIN 07700100 + REAL A =-1,B = -2; 07700200 + P(A OR B,RTN); 07700300 + END ORI; 07700400 +PROCEDURE CMPL ; % 132 07800000 + BEGIN 07800100 + REAL A = - 1; 07800200 + P( (NOT A),RTN); 07800300 + END CMPL; 07800400 +PROCEDURE EQUIVP; % 133 07900000 + BEGIN 07900100 + REAL A=-1,B = -2; 07900200 + P(A EQV B,RTN); 07900300 + END EQUIVP; 07900400 +PROCEDURE FORTERR; % 134 RUN-TIME ERRORS 07900410 + BEGIN 07900500 +COMMENT PROGRAM GENERATING VARIOUS ERROR MESSAGES WITH A DS. 07900600 + CODES 0 THRU 3 ARE USED BY THE FORMATING INTRINSICS. CODES 07900700 + 10 THRU 32 ARE USED BY VARIOUS MATH INTRINSICS; 07900800 + REAL CODE = -1,FID,MFID,IND,BUFF,A=-2,B=-3,C=-4,D=-5; 07900900 + ARRAY TPAR[*],FIB[*],FPB=3[*] ; 07901000 + NAME MEM = 2; 07901100 +LABEL CD, FO95, CD1, CD2, DC, DC1, DC2, GO95 ; 07901110 +LABEL CPLR,XTOI,CSSC,DMOD,DEXP,CEXP,DLGZ,DLGM,CLOG,ALTZ,ALTM,DLTZ,DLTM, 07901200 + CSIN,CCOS,ACOS,ASIN,DSQR,GAMA,SINH,COSH,ALGZ,ALGM,MAXN,ZERO,NGTV, 07901300 + L0,L1,L2,L3,LX,WRAPUP,FIGER; 07901400 +LABEL L4, L5, L6; 07901410 +SWITCH SW1 ~ L0, L1, L2, L3, L4, L5, L6; 07901500 +SWITCH SW2 ~ CPLR,XTOI,CSSC,DMOD,DEXP,CEXP,DLGZ,DLGM,CLOG,ALTZ,ALTM, 07901600 + DLTZ,DLTM,CSIN,CCOS,ACOS,ASIN,DSQR,GAMA,SINH,COSH,ALGZ,ALGM; 07901700 +DEFINE STREM = STREAM(D ~ [TPAR[#, ST0 = STREM 0]])#, ST2 = STREM 2]])#;07901800 +DEFINE CC55(CC551) = CC551(DS~LIT"<"; SI~A1; DS~A13 CHR; DS~LIT">") #, 07901810 + NAS(NAS1,NAS2,NAS3) = SI~LOC NAS1; DS~NAS2 DEC; NAS3(DI~DI-4 ; 07901820 + DS~LIT"*") #, 07901825 + CD5(CD51,CD52,CD53,CD54,CD55) = CC55(CD51); CD52(NAS(CD53,CD54, 07901830 + CD55)) #, 07901835 + SAVW=F #, SAVD=E #, WH2=B #, WH1=C #, R=G #; 07901850 +SUBROUTINE GETFILE; 07901900 + BEGIN 07902000 + FIB ~ MEM[(NOT 2) INX A]; 07902100 + MFID ~ FPB[IND ~ FIB[4].[13:11]]; 07902200 + FID ~ FPB[IND+1]; 07902300 + B ~ B + 1; 07902400 + END GETFILE ; 07902405 + REAL T1,T2,T3,T4,T5,E=-6,F=-7,G=-8,H=-9,I=-10,J=-11,K=-12 ; 07902410 + INTEGER IT2=T2 ; 07902415 + ARRAY TEN=22[*] ; 07902417 + LABEL LOOP, ALFA ; 07902420 + REAL SUBROUTINE SIZ ; 07902425 + BEGIN 07902430 + TEN[T3]~TEN[68]; T1~0 ; 07902435 +LOOP: IF TEN[T1~T1+1]{T2 THEN GO LOOP; SIZ~T1 ; 07902440 + END OF SIZ ; 07902445 +% * * * * * * * * * * * * * * PROGRAM STARTS * * * * * * * * * * * 07902447 + TPAR~P([TPAR[1]],CFX,SFB)&17[8:38:10] ; 07902448 + IF CODE=(-2) THEN 07902450 + BEGIN T3~5; T2~B ; 07902455 + STREAM(E,D,C,B,A,N3~P(ALFA),N1~SIZ,T2~T2~A,N2~SIZ,TPAR) ; 07902460 + BEGIN 07902465 + DS~15LIT"-DATA STMT ERR#"; SI~LOC E; DS~DEC ; 07902470 + DS~4LIT",LT="; SI~LOC N3; SI~SI+D; DS~CHR ; 07902475 + DS~4LIT",DT="; SI~LOC N3; SI~SI+C; DS~CHR ; 07902480 + DS~3LIT",L="; SI~LOC B; DS~N1 DEC ; 07902485 + DS~3LIT",D="; DS~N2 DEC; DS~2LIT":~" ; 07902490 + END ; 07902495 + GO WRAPUP ; 07902500 + END ; 07902505 + IF CODE=(-1) THEN 07902510 + BEGIN 07902515 + STREAM(TPAR); DS~33LIT"-MIXD UNFMT/ALPHA-MODE TAPE I/O:~" ; 07902520 + GO WRAPUP ; 07902523 + END ; 07902525 + IF CODE=(-3) THEN 07902530 + BEGIN T3~4; T2~I; FID~(MFID~P(GO95))-1 ; 07902535 + STREAM(J,K,I,F1~SIZ,D~T2~H,F2~SIZ,F3~G>10 AND 15>G,F, 07902540 + N3~P(ALFA),C1~IT2~E,C~SIZ,R1~IT2~D+1,R~SIZ, 07902545 + BUFF~C,V~B.[42:1] AND B.[46:2]=0,A4~T2~B.[6:12],A5~SIZ 07902548 + |I~T2!1,A55~J~(K~T2)=MFID,A2~(T5~B AND 15)=12 OR T5=8, 07902551 + A3~T5=12 OR T5=4,CD~P(DC),CD1~P(DC1),Z~0,CD2~P(DC2), 07902554 + A6~(T4~B.[1:5])-2,A7~T2~B.[18:12],A8~SIZ|((T4!30 OR 07902557 + T2!FID) AND (T4!9 OR T2!0)),A85~MFID=T2,A9~T4}11 AND 07902560 + T4{14 OR (T4=30 AND (T2~B.[30:12])!FID),A10~T2,A11~SIZ, 07902563 + A115~T2=MFID,A12~T2~IF J THEN A.[18:15] ELSE K, 07902566 + A13~SIZ|I,TPAR) ; 07902568 + BEGIN DS~11LIT"-DATA ERR #"; SI~LOC J; SI~SI+7; DS~CHR ; 07902569 + DS~2LIT"= "; V(NAS(A4,A5,A55); A2(DS~LIT"K"); A3(DS~LIT 07902572 + "$"); SI~LOC CD; SI~SI+A6; DS~CHR; NAS(A7,A8,A85) ; 07902575 + A9(DS~LIT"."; NAS(A10,A11,A115)); DS~4LIT" => "; JUMP OUT 07902578 + TO L1); DS~7LIT"FMT IS "; L1: SI~LOC A12; DS~A13 DEC ; 07902581 + A2(DS~LIT"K"); A3(DS~LIT"$"); SI~LOC K; SI~SI+7; DS~CHR ; 07902584 + DS~F1 DEC; F3(DS~LIT"."; SI~LOC D; DS~F2 DEC); DS~6LIT 07902587 + " TYP="; SI~LOC N3; SI~SI+F; DS~CHR; DS~6LIT", COL#" ; 07902590 + DS~C DEC; DS~6LIT", CHR="; SI~BUFF; SI~SI-1; DS~CHR ; 07902593 + DS~6LIT", REC#"; SI~LOC R1; DS~R DEC; DS~3LIT" :~" ; 07902596 + END OF STREAM ; 07902599 + GO WRAPUP ; 07902602 +ALFA::: @2531625143242300 ; 07902605 +DC::: "PXTAOLJ"; DC1::: @3127262524230000; DC2::: "(V000" ; 07902606 +GO95::: 4095 ; 07902607 + END ; 07902608 + IF CODE=(-4) THEN 07902610 + BEGIN 07902614 + IF CODE.[2:1] THEN 07902615 + BEGIN 07902616 + STREAM(TPAR); DS~24LIT"-UNINITIALIZED POINTER:~" ; 07902617 + GO WRAPUP ; 07902618 + END ; 07902619 + STREAM(TPAR); DS~32LIT"-BINARY TAPE REC HAS < 3 WORDS:~" ; 07902620 + GO WRAPUP ; 07902625 + END ; 07902630 + IF CODE=(-5) THEN 07902631 + BEGIN T3~8; CODE~H ; 07902632 + IF D=2 THEN BEGIN CODE~30; IF WH1>63 OR WH1<10 THEN D~12 END ; 07902633 + IF A.[1:5]<5 THEN BEGIN A.[6:12]~A.[18:12]; R~SAVW; D~10 END ; 07902634 + IF D>9 THEN 07902635 + BEGIN FIB~P([FIB[1]],CFX,SFB)&5[8:38:10]; FIB[0]~0 ; 07902636 + BUFF~((BUFF~EDITIT(FID~FIB.[33:15],0,2,WH2,WH1)).[33:15]- 07902637 + FID)|8+BUFF.[30:3] ; 07902638 + END ; 07902639 + FID~(MFID~P(FO95))-1 ; 07902640 + IND~CODE>14 AND (CODE!30 OR A.[30:12]=FID) ; 07902641 + STREAM(A1~FIB,A2~(T5~A AND 15)=12 OR T5=8,A3~T5=12 OR T5=4, 07902642 + A4~T2~A.[6:12],A5~SIZ|T5~T2!1,A55~T2=MFID,A6~(T4~A.[1:5]07902643 + )-2,A7~T2~A.[18:12],A8~SIZ| (T4!29 AND T4!3 AND T4!4 07902645 + AND (T4!30 OR T2! FID) AND (T4!9 OR T2!0)),A85~(T2= 07902647 + MFID) ,A9~T4}11 AND T4{14 OR (T4=30 AND (T2~A.[30:12])07902650 + ! FID),A10~T2,A11~SIZ,A115~T2=MFID,A12~T4=3 AND A.[41:1]07902655 + ,R10~D=10,R~D!10,R1~T2~R,R2~SIZ|T5, 07902660 + V12~D=12,VV~D=2 AND WH1!31,V~D>2 AND D!12, 07902665 + V1~CODE-2,SKPWD~CODE=3 OR CODE=29 OR (CODE=30 AND 07902670 + SAVW= FID) OR CODE=4 OR (CODE=9 AND SAVW=0),W14~D=14, 07902672 + W~D!14,WW~SAVW=FID,W5~SAVW=MFID,SKPD~CODE 07902675 + <11 OR IND,D16~D=16,D~D!16,DD~ 07902680 + SAVD=FID,D5~SAVD=MFID,D1~T2~SAVD,D2~SIZ,W1~T2~SAVW, 07902685 + W2~SIZ,WH1,A13~BUFF,CD~P(CD),CD1~P(CD1),R5~0, 07902690 + CD2~P(CD2),TPAR) ; 07902692 + BEGIN DS~16LIT"-VARBL FMT ERR= "; A12(DS~LIT"-") ; 07902695 + NAS(A4,A5,A55); A2(DS~LIT"K"); A3(DS~LIT"$") ; 07902700 + SI~LOC CD; SI~SI+A6; DS~CHR; NAS(A7,A8,A85) ; 07902705 + A9(DS~LIT"."; NAS(A10,A11,A115)); DS~4LIT" => " ; 07902710 + A12(DS~LIT"-"); CD5(R10,R,R1,R2,R5); A2(DS~LIT"K"); A3(DS~07902720 + LIT"$"); CC55(V12); V(SI~LOC CD; SI~SI+V1; DS~CHR); VV(DS~07902725 + LIT"<"; SI~LOC WH1; SI~SI+7; DS~CHR; DS~LIT">");SKPWD(JUMP07902730 + OUT TO XX);WW(DS~11LIT""; SKPD(JUMP OUT 2 TO XX07902735 + ); DI~DI-1; DS~7LIT" AND D>";JUMP OUT TO XX); CD5(W14,W,W107902740 + ,W2,W5); GO XV; XX: GO XT; XV: SKPD(JUMP OUT 1 TO XI); DS~07902745 + LIT"."; DD(DS~11LIT""; JUMP OUT 1 TO XT) ; 07902750 + CD5(D16,D,D1,D2,D5); XT: DS~3LIT" :~" ; 07902755 + END OF STREAM ; 07902760 + GO WRAPUP ; 07902765 +FO95::: 4095 ; 07902770 +CD::: "PXTAOLJ"; CD1::: @3127262524230000; CD2::: "(V000" ; 07902771 + END ; 07902775 + IF CODE<10 THEN GO SW1[CODE] ; 07902780 + GO TO SW2[CODE - 10]; 07902800 + L0: % 0 07902900 + STREAM(P1~0:P2 ~ [TPAR[0]]); 07903000 + BEGIN 07903100 + DS ~ 14 LIT "-FORMAT ERROR "; 07903200 + P1 ~ DI; 07903300 + END; 07903400 + BUFF ~ P; 07903500 + GO TO LX; 07903600 + L1: % 1 07903700 + STREAM(P1~0:D ~ [TPAR[0]]); 07903800 + BEGIN 07903900 + DS ~ 16 LIT "-NAMELIST ERROR "; 07904000 + P1 ~ DI; 07904100 + END; 07904200 + BUFF ~ P; 07904300 + GO TO LX; 07904400 + L2: % 2 07904500 + STREAM(P1~0:D ~ [TPAR[0]]); 07904600 + BEGIN 07904700 + DS ~ 12 LIT "-TYPE ERROR "; 07904800 + P1 ~ DI; 07904900 + END; 07905000 + BUFF ~ P; 07905100 + LX: 07905200 + GETFILE; 07905300 + STREAM(MFID,FID,B,BUFF); 07905400 + BEGIN 07905500 + DI~BUFF; DS~8LIT"ON FILE " ; 07905600 + SI ~ LOC MFID; SI ~ SI + 1; DS ~ 7 CHR; DS ~ LIT "/"; 07905700 + SI~LOC FID; SI~SI+1; DS~7CHR; DS~7LIT", REC #" ; 07905800 + SI ~ LOC B; DS ~ 8 DEC; DS ~ 2 LIT ":~"; 07905900 + END; 07906000 + GO TO WRAPUP; 07906100 + L3: % 3 07906200 + ST0; 07906300 + DS ~ 18 LIT "-DATA STMT ERROR:~"; 07906500 + GO TO WRAPUP; 07906700 + L4: % 4 07906710 + STREAM(P1~0:D~[TPAR[0]]); 07906720 + BEGIN 07906730 + DS~26LIT"-MIXED FMT/UNFMT TAPE I/O " ; 07906740 +% VOID 07906750 + P1 ~ DI; 07906760 + END; 07906770 + BUFF ~ P; 07906780 + GO TO LX; 07906790 + L5: % 5 07906800 + STREAM(P1~0:D~[TPAR[0]]); 07906810 + BEGIN 07906820 + DS:=18 LIT "-LIST SIZE ERROR "; 07906830 + P1 ~ DI; 07906840 + END; 07906850 + BUFF ~ P; GO TO LX; 07906860 + L6: ST0; % 6 07906861 + DS ~ 21 LIT "-INVALID ARG CONCAT:~"; 07906862 + GO TO WRAPUP; 07906863 +CPLR: ST0; % 10 07906890 + DS ~ 31 LIT "-EXPRESSION COMPILATION ERROR:~"; 07906900 + GO TO FIGER; 07907000 +XTOI: ST0; % 11 07907100 + DS ~ 21 LIT "-NEGATIVE BASE XTOI:~"; 07907200 + GO TO FIGER; 07907300 +CSSC: ST0; % 12 07907400 + DS ~ 24 LIT "-COMPLEX EXPONENT XTOI:~"; 07907500 + GO TO FIGER; 07907600 +DMOD: ST0; % 13 07907700 + DS ~ 20 LIT "-ZERO MODULUS DMOD:~"; 07907800 + GO TO FIGER; 07907900 +DEXP: ST2; % 14 07908000 + DS ~ 6 LIT "DEXP:~"; 07908100 + GO TO MAXN; 07908200 +CEXP: ST2; % 15 07908300 + DS ~ 6 LIT "CEXP:~"; 07908400 + GO TO MAXN; 07908500 +DLGZ: BUFF ~ TRUE; % 16 07908600 +DLGM: ST2; % 17 07908700 + DS ~ 6 LIT "DLOG:~"; 07908800 + IF BUFF THEN GO TO ZERO ELSE GO TO NGTV; 07908900 +CLOG: ST2; % 18 07909000 + DS ~ 6 LIT "CLOG:~"; 07909100 + GO TO ZERO; 07909200 +ALTZ: BUFF ~ TRUE; % 19 07909300 +ALTM: ST2; % 20 07909400 + DS ~ 8 LIT "ALOG10:~"; 07909500 + IF BUFF THEN GO TO ZERO ELSE GO TO NGTV; 07909600 +DLTZ: BUFF ~ TRUE; % 21 07909700 +DLTM: ST2; % 22 07909800 + DS ~ 8 LIT "DLOG10:~"; 07909900 + IF BUFF THEN GO TO ZERO ELSE GO TO NGTV; 07910000 +CSIN: ST2; % 23 07910100 + DS ~ 6 LIT "CSIN:~"; 07910200 + GO TO MAXN; 07910300 +CCOS: ST2; % 24 07910400 + DS ~ 6 LIT "CCOS:~"; 07910500 + GO TO MAXN; 07910600 +ACOS: BUFF ~ TRUE; % 25 07910700 +ASIN: STREAM(B ~ BUFF,D ~ [TPAR[0]]); % 26 07910800 + BEGIN DS ~ 19 LIT "-ABS(ARG) .GT. 1 AR"; 07910900 + SI ~ LOC B; SI ~ SI + 7; 07911000 + IF SC = "1" THEN DS ~ 5 LIT "COS:~" 07911100 + ELSE DS ~ 5 LIT "SIN:~"; 07911200 + END; 07911400 + GO TO FIGER; 07911500 +DSQR: ST2; % 27 07911600 + DS ~ 7 LIT "DSQRT:~"; 07911700 +NGTV: ST0; 07911800 + DS ~ 16 LIT "-NEGATVE ARGMNT "; 07911900 + GO TO FIGER; 07912000 +GAMA: ST2; % 28 07912100 + DS ~ 7 LIT "GAMMA:~"; 07912200 + GO TO MAXN; 07912300 +SINH: ST2; % 29 07912400 + DS ~ 6 LIT "SINH:~"; 07912500 + GO TO MAXN; 07912600 +COSH: ST2; % 30 07912700 + DS ~ 6 LIT "COSH:~"; 07912800 +MAXN: ST0; 07912900 + DS ~ 16 LIT "-ARGMT .GT. MAX "; 07913000 + GO TO FIGER; 07913100 +ALGZ: BUFF ~ TRUE; % 31 07913200 +ALGM: ST2; % 32 07913300 + DS ~ 8 LIT "ALGAMA:~"; 07913400 + IF NOT BUFF THEN GO TO NGTV; 07913500 +ZERO: ST0; 07913600 + DS ~ 16 LIT "-ZERO ARGUMENT "; 07913700 + WRAPUP: FIGER: 07913800 + P([TPAR[0]].[33:15],34,COM); 07913900 + END FORTERR; 07914000 +PROCEDURE MAX; % 135 08000000 +COMMENT MAX INTRINSIC RETURNING INTEGERS; % PF JULY 67 08000100 +BEGIN REAL X = -1, RCW = +0, SIZE = +1, JUNK = +2; 08000200 +P(0,RCW,FCX,[RCW] INX NOT 0 INX 0,XCH,SUB,0,X); 08000300 +WHILE (SIZE ~ SIZE - 1) > 0 DO 08000400 +BEGIN P(DUP); 08000500 + JUNK ~ *(P(.X) + SIZE); 08000600 + IF P < JUNK THEN P(DEL,DUP); 08000700 +END; 08000800 +P(1,DIV,RTN); 08000900 +END IMAX; 08001000 +PROCEDURE MIN; % 136 08100000 +COMMENT MIN INTRINSIC RETURNING INTEGERS; % PF JULY 67 08100100 +BEGIN REAL X = -1, RCW = +0, SIZE = +1, JUNK = +2; 08100200 +P(0,RCW,FCX,[RCW] INX NOT 0 INX 0,XCH,SUB,0,X); 08100300 +WHILE (SIZE ~ SIZE - 1) > 0 DO 08100400 +BEGIN P(DUP); 08100500 + JUNK ~ *(P(.X) + SIZE); 08100600 + IF P > JUNK THEN P(DEL,DUP); 08100700 +END; 08100800 +P(1,DIV,RTN); 08100900 +END IMIN; 08101000 +PROCEDURE IMOD; % 137 08200000 +COMMENT INTEGER MOD INTRINSIC; % PF JULY 67 08200100 +BEGIN INTEGER X = -2, 08200200 + Y = -1; 08200300 +P(X MOD Y,1,DIV,RTN); 08200400 +END IMOD; 08200500 +PROCEDURE CONCAT ; % INTRINSIC NUMBER @140. 08300000 + BEGIN % FORTRAN CONCATENATE INTRINSIC: CONCAT=Y&Z[A:B:X]. 08300100 + REAL Y=-5, Z=-4, ERR=24 ; 08300200 + INTEGER A=-3, B=-2, X=-1 ; 08300250 + DEFINE R= @0055005570267022 #, % NOP,DIA,OPDC Y,OPDC,Z. 08300260 + S= @0055006100650235 #; % NOP,DIB,TRB,RTN. 08300270 + IF (A~A)<1 OR (B~B)<1 OR (X~X)<1 OR (P(48-X,DUP) VARYING, H=6 => FIXED, H=-1 => RELEASE. 08301100 + REAL I ; 08301200 + P(*A,TOP) ; 08301300 + IF H}0 THEN 08301400 + IF P THEN P(A&H[3:45:3],(*2)&(A)[33:18:15],~) 08301500 + ELSE FOR I~A.[8:10]-1 STEP -1 UNTIL 0 DO P([A[I]],DUP,LOD, 08301600 + P&H[3:45:3],XCH,~) 08301700 + ELSE IF P THEN P(A,38,COM,DEL) 08301800 + ELSE FOR I~A.[8:10]-1 STEP -1 UNTIL 0 DO P(*[A[I]],38,COM,DEL);08301900 + END OF FORTRANMEMHANDLER ; 08301950 +PROCEDURE SISO; % 35 08400000 + BEGIN 08400200 + COMMENT STRING ISOLATE. INVOKED AS REAL(PTR,N). N COUNTS CHARS.; 08400400 + DEFINE CSIZE=[31:02]#, COMMENT CHAR-SIZE FIELD OF PTR; 08400600 + EIGHT=01#; COMMENT VALUE OF CSIZE FOR 8 BITS-CHAR; 08400800 + INTEGER 08401000 + SOFF; %BIT OFFSET TO BIT 1 OF S FOR 8-BIT CHAR 08401200 + INTEGER 08401400 + PTR =-3, 08401600 + RCW =-2, %SISO IS REALLY A REAL PROC:VALUE IN PTR 08401800 + N =-1; 08402000 + REAL RESULT =PTR; 08402010 + ARRAY 08402200 + STRING[*]; %UNINDEXED DD FOR SOURCE CHARS 08402400 + NAME 08402600 + M=2; 08402800 + IF PTR=0 THEN P(MKS,INTCALL((-4)&1[2:47:1],FORTERRI)) ; 08402900 + IF PTR.[01:01] THEN 08402925 + P(M&1[14:47:01],PTR.[09:22]+(PTR.[33:15]!0),CHS,CDC,DEL); 08402950 + STRING~M[PTR]; 08403000 + N~ABS(N); 08403100 + IF PTR.CSIZE=EIGHT THEN 08403200 + BEGIN 08403400 + IF N>6 THEN POLISH((STRING)&6[08:38:10],N,CDC,DEL); 08403600 + SOFF~0&PTR[32:18:13]; N~0&N[09:12:36]; COMMENT BIT INDICES; 08403800 + POLISH([STRING[(SOFF+N-8) DIV 48]],DEL); 08404000 + STREAM(RESULT~0:S~[STRING[SOFF DIV 48]],SKS~(SOFF~SOFF MOD 48), 08404200 + SKD~48-N,N); 08404400 + BEGIN 08404600 + SI~S; SKIP SKS SB; 08404800 + DI~LOC RESULT; SKIP SKD DB; 08405000 + N(IF SB THEN DS~1 SET ELSE DS~1 RESET; SKIP 1 SB); 08405200 + END; 08405400 + RESULT := P(DUP); % SAVE IT 08405600 + END ELSE 08405800 + BEGIN 08406000 + COMMENT SOURCE HAS 6 BITS/CHAR; 08406200 + IF N>8 THEN POLISH((STRING)&8[08:38:10],N,CDC,DEL); 08406400 + POLISH([STRING[(PTR.[18:13]+N-1).[35:10]]],DEL); 08406600 + STREAM(RESULT~0:S~[STRING[PTR.[18:10]]],SKS~PTR.[28:03], 08406800 + N,SKD~8-N); 08407000 + BEGIN 08407200 + SI~S; SI~SI+SKS; 08407400 + DI~LOC RESULT; DI~DI+SKD; 08407600 + DS~N CHR; 08407800 + END; 08408000 + RESULT := P(DUP); % SAVE IT 08408200 + END; 08408400 + IF NOT (P(TOP)) THEN % IT IS BAD 08408500 + P([RCW]&1[8:38:10],0,COC);% FLAG II 08408510 + END SISO; 08408600 + PROCEDURE SCAN(UPDPDD,PTR,UPDCDD,HISCOUNT,CASECODE,CHAR); 08410000 + VALUE PTR, HISCOUNT, CASECODE, CHAR; 08410050 + NAME UPDPDD, UPDCDD; 08410100 + INTEGER PTR, HISCOUNT, CASECODE, CHAR; 08410150 + 08410200 + BEGIN 08410250 + COMMENT RELATION WHILE UNTIL 08410300 + { 0 20 08410350 + } 4 16 08410400 + ! 8 12 08410450 + = 12 8 08410500 + < 16 4 08410550 + > 20 0 08410600 + IN ALPHA 24 29 08410650 + IN NUMERIC 25 30 08410660 + IN TRUTHSET 26 31 08410670 + NOTE: THE TRUTH SET IS THE 64 BITS BEGINNING AT BIT 1 08410680 + DF THE WORD POINTED TO BY THE DESCRIPTOR IN CHAR. 08410690 + ; 08410700 + 08410750 + NAME M=2; 08410800 + ARRAY STRINGDESC[*]; 08410850 + INTEGER OURCOUNT, WOFSET, CHOFSET, N, N1, JUNK=17; 08410900 + INTEGER AWHILE; % "IN" SCAN IS FOR WHILE. 08410925 + BOOLEAN MORE; 08410950 + DEFINE PW=[18:10]#, PC=[28:03]#, CSIZE=[31:02]#, 08411000 + SIX=00#, ALONE=@777777#,POFSET=[18:13]#; 08411050 + 08411100 + SUBROUTINE CHARSCAN; 08411150 + BEGIN; 08411200 + COMMENT SCAN FOR CONDITIONS OTHER THAN ALPHA MEMBERSHIP.; 08411250 + STREAM(N, CHOFSET, CHAR : DD1~[STRINGDESC[0]], CASECODE, 08411300 + DD~[STRINGDESC[WOFSET]]); 08411350 + BEGIN 08411400 + SI~DD; SI~SI+CHOFSET; 08411450 + DI~LOC CHAR; DI~DI+6; 08411500 + CI~CI+CASECODE; 08411550 + GO TO LE; %00 08411600 + GO TO GE; %01 08411650 + GO TO NE; %02 08411700 + GO TO EQ; %03 08411750 + GO TO LS; %04 08411800 + %GO TO GR; %05 08411850 + GR:N(IF SC{DC THEN JUMP OUT TO XX; DI~DI-1); GO TO XY; 08411900 + LS:N(IF SC}DC THEN JUMP OUT TO XX; DI~DI-1); GO TO XY; 08411950 + EQ:N(IF SC!DC THEN JUMP OUT TO XX; DI~DI-1); GO TO XY; 08412000 + NE:N(IF SC=DC THEN JUMP OUT TO XX; DI~DI-1); GO TO XY; 08412050 + GE:N(IF SCDC THEN JUMP OUT TO XX; DI~DI-1); GO TO XY; 08412150 + XY:TALLY~1; SI~SI+1; 08412200 + XX:N~TALLY; SI~SI-1; CHAR~SI; 08412250 + SI~DD1; CHOFSET~SI; 08412300 + END; 08412350 + CHOFSET~POLISH(SUB,DUP).[18:15]; 08412400 + %WE ONLY NEED [30:03], BUT REST OF FIELD IS 0 AND ESPOL KNOWS TO 08412450 + %OPTIMIZE [18:15] TO AN "FTC" OPERATOR. 08412500 + WOFSET~POLISH.[33:15]; 08412550 + MORE~POLISH; 08412600 + END CHARSCAN; 08412650 + 08412700 + SUBROUTINE ALFSCAN; 08412750 + BEGIN; 08412800 + COMMENT SCAN . . . WHILE/UNTIL IN ALPHA, NUMERIC, TRUTHSETID; 08412850 +STREAM (CHOFSET, SWITCHER:=CASECODE, N : TSET:=[CHAR], AWHILE, 08412900 + DD1:=[STRINGDESC[0]], DD:=[STRINGDESC[WOFSET]]); 08412950 +BEGIN 08413000 + SI:=DD; SI:=SI+CHOFSET; 08413010 + CI:=CI+AWHILE; GO UCASE; % GO WCASE; 08413020 +WCASE: 08413030 + CI:=CI+SWITCHER; GO ATESTW; GO NTESTW; % GO TTESTW; 08413040 +TTESTW: DI:=LOC SWITCHER; 08413050 + N ( DD:=SI; DI:=DI-1; DS:=CHR; 08413060 + SI:=TSET; SKIP CHOFSET SB; SKIP SB; 08413070 + IF SB THEN; SI:=DD; 08413080 + IF TOGGLE THEN SI:=SI+1 ELSE JUMP OUT TO TSTOPW; 08413090 + ); 08413100 + GO AWAYW; 08413110 +NTESTW: 08413120 + N ( IF SC GEQ "0" THEN IF SC LEQ "9" THEN; 08413130 + IF TOGGLE THEN SI:=SI+1 ELSE JUMP OUT TO TSTOPW; 08413140 + ); 08413150 + GO AWAYW; 08413160 +ATESTW: 08413170 + N ( IF SC=ALPHA THEN SI:=SI+1 ELSE JUMP OUT TO TSTOPW ); 08413180 +AWAYW: 08413190 + TALLY:=1; 08413200 +TSTOPW: GO TO DONE; 08413210 +UCASE: 08413220 + CI:=CI+SWITCHER; GO ATESTU; GO NTESTU; % GO TTESTU; 08413230 +TTESTU: DI:=LOC SWITCHER; 08413240 + N ( DD:=SI; DI:=DI-1; DS:=CHR; 08413250 + SI:=TSET; SKIP CHOFSET SB; SKIP SB; 08413260 + IF SB THEN; SI:=DD; 08413270 + IF TOGGLE THEN JUMP OUT TO TSTOPU; SI:=SI+1; 08413280 + ); 08413290 + GO AWAYU; 08413300 +NTESTU: 08413310 + N ( IF SC GEQ "0" THEN IF SC LEQ "9" THEN JUMP OUT TO TSTOPU; 08413320 + SI:=SI+1; 08413330 + ); 08413340 + GO AWAYU; 08413350 +ATESTU: 08413360 + N ( IF SC=ALPHA THEN JUMP OUT TO TSTOPU; SI:=SI+1 ); 08413370 +AWAYU: 08413380 + TALLY:=1; 08413390 +TSTOPU: DONE: 08413400 + N:=TALLY; SWITCHER:=SI; SI:=DD1; CHOFSET:=SI; 08413410 + END; 08413500 + MORE~POLISH; 08413550 + CHOFSET~POLISH(SUB,DUP).[18:15];%OPTIMIZED [30:03] ISOLATE. 08413600 + WOFSET~POLISH.[33:15]; 08413650 + END ALFSCAN; 08413700 + 08413750 + IF PTR=0 THEN P(MKS,INTCALL((-4)&1[2:47:1],FORTERRI)) ; 08413755 + IF PTR.[01:01] THEN 08413760 + P(M&1[14:47:01],PTR.[09:22]+(PTR.[33:15]!0),CHS,CDC,DEL); 08413770 + IF PTR.CSIZE!SIX THEN POLISH(M&1[14:47:01],8686,CDC,DEL); 08413800 + STRINGDESC~M[PTR]; 08413850 + IF (OURCOUNT~0&(STRINGDESC)[35:08:10]-PTR.POFSET) <0 THEN 08413900 + POLISH([STRINGDESC[PTR.POFSET]]); 08413950 + IF HISCOUNT { 0 THEN 08413960 + BEGIN UPDCDD[0]~0;UPDPDD[0]~PTR+0&WOFSET[18:35:13];P(XIT);END; 08413970 + IF (HISCOUNT~(JUNK~HISCOUNT).[33:15])63 THEN 08414400 + BEGIN 08414450 + N~63; 08414500 + DO ALFSCAN UNTIL (N1~N1-63){63 OR NOT MORE; 08414550 + N~N1; 08414600 + END; 08414650 + IF N>0 AND MORE THEN ALFSCAN; 08414700 + END ELSE 08414750 + BEGIN 08414800 + CASECODE:=CASECODE.[43:3]; CHAR:=0&CHAR[36:42:6]; 08414825 + IF N1>63 THEN 08414850 + BEGIN 08414900 + N~63; 08414950 + DO CHARSCAN UNTIL (N1~N1-63){63 OR NOT MORE; 08415000 + N~N1; 08415050 + END; 08415100 + IF N>0 AND MORE THEN CHARSCAN; 08415150 + END; 08415200 + IF HISCOUNT>OURCOUNT AND MORE THEN 08415250 + POLISH([STRINGDESC[CHOFSET&WOFSET[30:33:15]]]); 08415300 + IF POLISH(.UPDPDD,LOD,RFB,.UPDCDD,LOD,RFB,OR)!0 THEN 08415350 + BEGIN 08415400 + WOFSET~CHOFSET&WOFSET[30:33:15]-PTR.[18:13]; 08415450 + UPDCDD[0] ~HISCOUNT-WOFSET; 08415500 + UPDPDD[0]~PTR+0&WOFSET[18:35:13]; 08415550 + END; 08415600 + END SCAN; 08415650 + PROCEDURE REPL; 08420000 + BEGIN 08420020 + COMMENT STRING REPLACE INTRINSIC FOR B5500 TS ALGOL 08420040 + MARCH 1968. RATCHFORD 08420060 + 8-BIT CHARS, WORD XFERS & UNCONDITIONAL XFER ADDED APRIL 1968 HJR; 08420080 + DEFINE 08420100 + CSIZE=[31:02]#, EIGHT=01#, TCOND=45#, DOT=[18:13]#, 08420120 + DECNVRT=(-32)#, 08420130 + AMPER=[18:35:13]#, 08420140 + POTZ=IF SB THEN DS~1 SET ELSE DS~1 RESET; SKIP 1 SB;#; 08420160 + ARRAY 08420180 + SORC[*] , COMMENT DESC FOR SOURCE STRING; 08420200 + DEST[*] ; COMMENT DATA DESC FOR DESTINATION STRING; 08420220 + NAME 08420240 + UPDPDD =-08, COMMENT DESC FOR UPDATE DESI POINTER; 08420260 + UPSPDD =-06, COMMENT DESC FOR UPDATE SOURCE POINTER; 08420280 + UPCTDD =-04, COMMENT DESC FOR UPDATE COUNT VARIABLE; 08420300 + M = 02; 08420320 + INTEGER 08420340 + DPTR =-07, COMMENT DESTINATION POINTER; 08420360 + SPTR =-05, COMMENT SOURCE POINIER OR 1 TO 8 LIIERAL CHRS. 08420380 + 8 ONLY IF LITERAL IS ARITHMETIC; 08420400 + HISCNT =-03, COMMENT CALLER"S IDEA OF HOW BIG MAXCOUNT IS; 08420420 + RELATION =-02, COMMENT SWITCH INDEX FOR SCAN CODE. THE INDEX 08420440 + VALUES ARE SUPPOSED TO BE THE SAME FOR REPL 08420460 + AND SCAN. RELATION IS <0 IF THE SOURCE IS 08420480 + A LITERAL AND IS }0 IF SOURCE IS A POINIER; 08420500 + COMMENT COMPARE USES THE SAME VALUES OF RELAT; 08420520 + CHAR =-01, COMMENT THE WHILE/UNTIL COMPARISON CHAR; 08420540 + CHAR1 , COMMENT SDA-FORMAT ADDR OF 1ST XFERRED CHAR; 08420560 + CHARN , COMMENT SDA FORMAT ADDR OF LAST XFERRED CHAR; 08420580 + SORCL =CHAR1,COMMENT LENGTH OF SOURCE CALCULATED BY US; 08420600 + DESTL =CHARN,COMMENT REMAINING CHARS IN DEST STRING; 08420620 + SWI=CHAR1, DWI=CHARN, ITERC, 08420630 + OURCNT , COMMENT SAFE MAX LENGTH FOR REPLACE. 08420640 + FOR POINTER-SOURCE, MIN(HISCNT,SORCL,DESTL), 08420660 + FOR LITERAL SOURCE, MIN(DESTL,HISCNT); 08420680 + SOFF , COMMENT CHARACTER OFFSET IN SOURCE; 08420700 + SSIZE =SOFF,COMMENT SOURCE CHAR SIZE (6 OR 8 BITS/CHAR); 08420720 + DOFF , COMMENT CHARACTER OFFSET IN DESTINATION; 08420740 + DSIZE =DOFF,COMMENT DEST CHAR SIZE; 08420760 + UPDTOG , COMMENT TRUE IF ANY UPDATE(S) REQUESTED; 08420780 + JUNK =17, COMMENT USED FOR BUILDING CONCATENATED LITRL; 08420800 + TOGL , COMMENT "TOGGLE" FOR REPLACE WHILE/UNTIL; 08420820 + REFETCH =TOGL,COMMENT THE "INVALIDATOR" FOR REPL UNTIL; 08420840 + INITIAL =TOGL;COMMENT LOCAL 4 USE BY REPL FROM LITERAL; 08420860 + INTEGER AWHILE; % CONDITION IS "WHILE IN" 08420865 + BOOLEAN MORE; %CONDITIONAL REPLACE ISN"T DONE YET. 08420870 + ARRAY NAME 08420880 + SORCI =SORC,COMMENT INDEXED DESC FOR POINTER-SOURCE; 08420900 + DESTI =DEST;COMMENT INDEXED DATA DESC FOR DEST STRING; 08420920 + SUBROUTINE CREPL; 08420921 + BEGIN; 08420922 + STREAM(DOFF,CHAR,SOFF,ITERC,MORE~0: 08420923 + D1~[DEST[0]],S1~[SORC[0]],RELATION,T~0,S2~[SORC[SWI]], 08420924 + D2~[DEST[DWI]]); 08420925 + BEGIN 08420926 + DI~DI+DOFF; D2~DI; DI~LOC CHAR; 08420927 + DI~DI+6; T~DI; SI~S2; 08420928 + SI~SI+SOFF; 08420929 + ITERC(CI~CI+RELATION; 08420930 + GO TO LE; 08420931 + GO TO GE; 08420932 + GO TO NE; 08420933 + GO TO EQ; 08420934 + GO TO LS; 08420935 + %GO TO GR; 08420936 + GR:IF SC{DC THEN; GO TO XX; 08420937 + LS:IF SC}DC THEN; GO TO XX; 08420938 + EQ:IF SC!DC THEN; GO TO XX; 08420939 + NE:IF SC=DC THEN; GO TO XX; 08420940 + GE:IF SCDC THEN; %GO TO XX; 08420942 + XX:IF TOGGLE THEN JUMP OUT TO XY; 08420943 + SI~SI-1; DI~D2; DS~CHR; 08420944 + D2~DI; DI~T; 08420945 + ); 08420946 + TALLY~1; SI~SI+1; 08420947 + XY:MORE~TALLY; SI~SI-1; CHAR~SI; 08420948 + SI~S1; DOFF~SI; DI~D2; 08420949 + ITERC~DI; DI~D1; SOFF~DI; 08420950 + END; 08420951 + MORE~POLISH; 08420952 + DOFF~POLISH(SUB,DUP).[18:15]; %OPTIMIZED [30:03] ISOLATE. 08420953 + DWI~POLISH.[33:15]; 08420954 + SOFF~POLISH(SUB,DUP).[18:15]; 08420955 + SWI~POLISH.[33:15]; 08420956 + END CONDITIONAL REPLACE; 08420957 + SUBROUTINE CRA; 08420958 + BEGIN; COMMENT REPLACE . WHILE/UNTIL IN ALPHA, NUMERIC, TRUTHSET;08420959 +STREAM(DOFF, T1:=0, SOFF, N:=ITERC, MORE:=0 : TSET:=[CHAR], AWHILE, 08420960 + D1:=[DEST[0]], S1:=[SORC[0]], RELATION, 08420961 + S2:=[SORC[SWI]], D2:=[DEST[DWI]]); 08420962 +BEGIN 08420963 + DI:=DI+DOFF; SI:=S2; SI:=SI+SOFF; 08420964 + CI:=CI+AWHILE; GO UCASE; % GO WCASE; 08420965 +WCASE: 08420966 + CI:=CI+RELATION; GO ATESTW; GO NTESTW; % GO TTESTW; 08420967 +TTESTW: D2:=DI; DI:=LOC T1; DI:=DI-1; T1:=DI; DI:=D2; 08420968 + N ( D2:=DI; S2:=SI; DI:=T1; DS:=CHR; 08420969 + SI:=TSET; SKIP DOFF SB; SKIP SB; 08420970 + IF SB THEN; SI:=S2; DI:=D2; 08420971 + IF TOGGLE THEN DS:=CHR ELSE JUMP OUT TO TSTOPW; 08420972 + ); 08420973 + GO AWAYW; 08420974 +NTESTW: 08420975 + N ( IF SC GEQ "0" THEN IF SC LEQ "9" THEN; 08420976 + IF TOGGLE THEN DS:=CHR ELSE JUMP OUT TO TSTOPW; 08420977 + ); 08420978 + GO AWAYW; 08420979 +ATESTW: 08420980 + N ( IF SC=ALPHA THEN DS:=CHR ELSE JUMP OUT TO TSTOPW ); 08420981 +AWAYW: 08420982 + TALLY:=1; 08420983 +TSTOPW: GO TO DONE; 08420984 +UCASE: 08420985 + CI:=CI+RELATION; GO ATESTU; GO NTESTU; % GO TTESTU; 08420986 +TTESTU: D2:=DI; DI:=LOC T1; DI:=DI-1; T1:=DI; DI:=D2; 08420987 + N ( D2:=DI; S2:=SI; DI:=T1; DS:=CHR; 08420988 + SI:=TSET; SKIP DOFF SB; SKIP SB; 08420989 + IF SB THEN; SI:=S2; DI:=D2;; 08420990 + IF TOGGLE THEN JUMP OUT TO TSTOPU; DS:=CHR; 08420991 + ); 08420992 + GO AWAYU; 08420993 +NTESTU: 08420994 + N ( IF SC GEQ "0" THEN IF SC LEQ "9" THEN JUMP OUT TO TSTOPU; 08420995 + DS:=CHR; 08420996 + ); 08420997 + GO AWAYU; 08420998 +ATESTU: 08420999 + N ( IF SC=ALPHA THEN JUMP OUT TO TSTOPU; DS:=CHR ); 08421000 +AWAYU: 08421001 + TALLY:=1; 08421002 +TSTOPU: DONE: 08421003 + MORE:=TALLY; N:=SI; T1:=DI; SI:=S1; SOFF:=SI; DI:=D1; DOFF:=DI; 08421004 +END; 08421005 + MORE:=P; SOFF:=P(SUB,DUP).[18:15]; SWI:=P.[33:15]; 08421006 + DOFF:=P(SUB,DUP).[18:15]; DWI:=P.[33:15]; 08421007 + END CBNDITIONAL ALPHA REPLACE; 08421008 + IF DPTR.[01:01] THEN 08421009 + P(M&1[14:47:01],DPTR.[09:22]+(DPTR.[33:15]!0),CHS,CDC,DEL); 08421010 + IF (SPTR=0 AND RELATION.[1:1]=0) OR DPTR=0 08421011 + THEN P(MKS,INTCALL((-4)&1[2:47:1],FORTERRI)) ; 08421012 + DEST:=M[DPTR]; 08421013 + DSIZE:=IF DPTR.CSIZE=EIGHT THEN 8 ELSE 6; 08421014 + IF (TOGL:=RELATION.[01:01]=0) THEN 08421015 + SSIZE:=IF SPTR.CSIZE=EIGHT THEN 8 ELSE 6 08421016 + ELSE SSIZE~6; COMMENT LITERAL OR AEXP SOURCE; 08421020 + IF TOGL AND DSIZE!SSIZE THEN 08421040 + POLISH(DEST&1[08:38:10],8686,CDC,DEL); 08421060 + UPDTOG~ 08421080 + POLISH(.UPDPDD,LOD,RFB,.UPSPDD,LOD,RFB,OR,.UPCTDD,LOD,RFB,OR)!0; 08421100 + IF (HISCNT~HISCNT) { 0 THEN 08421120 + BEGIN UPCTDD[0]~0;UPDPDD[0]~DPTR;UPSPDD[0]~SPTR;P(XIT);END; 08421130 + IF DSIZE=8 THEN 08421140 + BEGIN 08421160 + $ SET OMIT = NOT EIGHTBIT 08421170 +COMMENT CAUSE INVALID INDEX, 9898 GEQ ASZ IF 8 BIT REPLACE IS DONE; 08423273 + POLISH(DEST&1[8:38:10],9898,CDC,DEL); 08423275 + $ RESET OMIT 08423276 + END ELSE %8-BIT DEST FINISHED 08423280 + COMMENT IF WE GET THIS FAR, DSIZE!EIGHT & SSIZE=DSIZE, SO 08423300 + SPTR CAN"T BE 8 BITS/CHAR; 08423320 + IF RELATION.[42:06]=TCOND THEN 08423340 + BEGIN 08423360 + COMMENT UNCONDITIONAL XFER OF 6-BIT CHARS OR WORDS; 08423380 + IF RELATION.[40:01]=1 THEN 08423400 + BEGIN 08423420 + COMMENT WORD TRANSFER; 08423440 + DPTR.DOT~0&(DOFF~(0&DPTR[35:18:13]+7).[35:10])[35:38:10]; 08423460 + OURCNT~HISCNT.[38:10]; 08423480 + IF (DOFF+OURCNT)>(DEST).[08:10] THEN 08423500 + POLISH([DEST[(DEST.[8:10])]]); 08423520 + IF TOGL THEN 08423540 + BEGIN 08423560 + IF SPTR.[01:01] THEN 08423570 + P(M&1[14:47:01],SPTR.[09:22]+(SPTR.[33:15]!0),CHS, 08423571 + CDC,DEL); 08423572 + COMMENT POINTER SOURCE; 08423580 + SORC~M[SPTR]; 08423600 + SPTR.DOT~0&(SOFF~(0&SPTR[35:18:13]+7).[35:10])[35:38:10]; 08423620 + IF (SOFF+OURCNT)>(SORC).[08:10] THEN 08423640 + POLISH([SORC[(SORC.[8:10])]]); 08423660 + IF OURCNT>0 THEN 08423670 + STREAM(SOURCE~[SORC[SOFF]], 08423680 + N1~OURCNT,N2~OURCNT.[38:04], 08423700 + DESTAD~[DEST[DOFF]]); 08423720 + BEGIN 08423740 + SI~SOURCE; 08423760 + DS~N1 WDS; N2(2(DS~32 WDS)); 08423780 + END; 08423800 + END ELSE %6-BIT POINTER SOURCE FINISHED FOR WD XFER 08423820 + BEGIN 08423840 + COMMENT LITERAL/AEXP SOURCE; 08423860 + SORCL~HISCNT.[18:15]; 08423880 + IF SORCL=0 THEN SORCL~HISCNT; 08423900 + INITIAL~IF OURCNT>0 THEN 1 ELSE 0; 08423920 + OURCNT~OURCNT-INITIAL; 08423940 + STREAM(START~SPTR,SORCL,INITIAL, 08423960 + SOFSET~8-SORCL,IN1~(JUNK~8 DIV SORCL), 08423980 + IN2~8-JUNK|SORCL,N1~OURCNT,N2~OURCNT.[38:04], 08424000 + DESTAD~[DEST[DOFF]], 08424020 + SETDI~[JUNK]); 08424040 + BEGIN 08424060 + SI~LOC START; SI~SI+SOFSET; 08424080 + SOFSET~SI; 08424100 + IN1(DS~SORCL CHR; SI~SOFSET); 08424120 + DS~IN2 CHR; SI~SETDI; DI~DESTAD; 08424140 + START~DI; 08424160 + DS~INITIAL WDS; SI~START; 08424180 + DS~N1 WDS; N2(2(DS~32 WDS)); 08424200 + END; 08424220 + OURCNT~OURCNT+INITIAL; 08424240 + END;%OF WORD-XFER FROM LIT-AEXP SOURCE 08424260 + IF UPDTOG THEN CHAR~0&OURCNT[32:35:13]; 08424280 + END ELSE %WORD TRANSFER DONE 08424300 + BEGIN 08424320 + COMMENT CHAR XFER FROM 6-BIT SOURCES; 08424340 + DOFF~DPTR.DOT; OURCNT~HISCNT.[35:13]; 08424360 + IF (DOFF+OURCNT)>0&(DEST)[35:08:10] THEN 08424380 + POLISH([DEST[(DEST.[8:10])]]); 08424400 + IF TOGL THEN 08424420 + BEGIN 08424440 + COMMENT SOURCE IS A POINTER; 08424460 + IF SPTR.[01:01] THEN 08424470 + P(M&1[14:47:01],SPTR.[09:22]+(SPTR.[33:15]!0),CHS, 08424471 + CDC,DEL); 08424472 + SORC~M[SPTR]; 08424480 + SOFF~0&SPTR[35:18:13]; 08424500 + IF (SOFF + OURCNT) > 0 & (SORC)[35:8:10] THEN 08424503 + BEGIN 08424504 + INITIAL := HISCNT.[35:13] - HISCNT.[20:13]; 08424506 + STREAM(START:=SPTR.[28:3], FINISH:=DPTR.[28:3], 08424508 + N1:=INITIAL, N2:=INITIAL.[37:5], 08424510 + N3:=INITIAL.[35:2], INITIAL:= HISCNT.[20:13], 08424511 + IN1:= HISCNT.[22:5], IN2:= HISCNT.[20:2], 08424512 + SOURCE:= [SORC[SPTR.[18:10]]], 08424513 + DESTAD:= [DEST[DPTR.[18:10]]]); 08424514 + BEGIN 08424516 + SI:=SOURCE; SI:=SI+START; DI:=DI+FINISH; 08424518 + SOURCE:= DI; 08424520 + DS:= INITIAL CHR; IN1(2(DS:=32 CHR )); 08424522 + IN2(2(32(DS:= 32 CHR ))); 08424524 + SI := SOURCE; 08424526 + DS:= N1 CHR; N2(2(DS:= 32 CHR )); 08424530 + N3(2(32(DS:= 32 CHR ))); 08424540 + END; 08424544 + END ELSE 08424546 + IF OURCNT>0 THEN 08424550 + STREAM(START~SPTR.[28:03],FINISH~DPTR.[28:03], 08424560 + N1~OURCNT,N2~OURCNT.[37:05],N3~OURCNT.[35:02], 08424580 + SOURCE~[SORC[SPTR.[18:10]]], 08424600 + DESTAD~[DEST[DPTR.[18:10]]]); 08424620 + BEGIN 08424640 + SI~SOURCE; SI~SI+START; 08424660 + DI~DI+FINISH; 08424680 + DS~N1 CHR; N2(2(DS~32 CHR)); 08424700 + N3(2(32(DS~32 CHR))); 08424720 + END; 08424740 + END ELSE %POINTER SOURCE FINISHED 08424760 + BEGIN 08424780 + COMMENT LITERAL/AEXP SOURCE, UNCOND XFER, 6-BIT DEST; 08424800 + SORCL~HISCNT.[18:15]; 08424820 + IF SORCL=0 THEN SORCL~HISCNT; 08424840 + INITIAL~IF OURCNT>7 THEN 8 ELSE OURCNT; 08424860 + OURCNT~OURCNT-INITIAL; 08424880 + IF INITIAL>0 THEN 08424885 + IF INITIAL{SORCL THEN 08424890 + STREAM(INITIAL,SPTR,SSKP~ 8-SORCL, 08424891 + DOFSET~DPTR.[28:03],D~[DEST[DPTR.[18:10]]]); 08424892 + BEGIN 08424893 + DI~DI+DOFSET; SI~LOC SPTR; 08424894 + SI~SI+SSKP; DS~INITIAL CHR; 08424895 + END ELSE 08424896 + STREAM(START~SPTR,SORCL,INITIAL, 08424900 + SOFSET~8-SORCL,IN1~(JUNK~8 DIV SORCL), 08424920 + IN2~8-JUNK|SORCL,N1~OURCNT,N2~OURCNT.[37:05], 08424940 + N3~OURCNT.[35:02],DOFSET~DPTR.[28:03], 08424960 + DESTAD~[DEST[DPTR.[18:10]]],SETDI~[JUNK]); 08424980 + BEGIN 08425000 + SI~LOC START; SI~SI+SOFSET; 08425020 + SOFSET~SI; IN1(DS~SORCL CHR; SI~SOFSET); 08425040 + DS~IN2 CHR; SI~SETDI; DI~DESTAD; 08425060 + DI~DI+DOFSET; START~DI; 08425080 + DS~INITIAL CHR; SI~START; 08425100 + DS~N1 CHR; N2(2(DS~32 CHR)); 08425120 + N3(2(32(DS~32 CHR))); 08425140 + END; 08425160 + OURCNT~OURCNT+INITIAL; 08425180 + END;%OF LITERAL/AEXP 6-BIT SOURCE 08425200 + CHAR~OURCNT; 08425220 + END % OF 6-BIT UNCONDITIONAL XFER 08425240 + END ELSE% UNCONDITIONAL XFER FINISHED 08425260 + IF RELATION=DECNVRT THEN 08425264 + BEGIN 08425265 + DOFF~DPTR.[28:03]; DWI~DPTR.[18:10]; 08425266 + IF (HISCNT~ (JUNK~ HISCNT).[33:15])>8 THEN 08425267 + POLISH(M&8[08:38:10],HISCNT,CDC,DEL); 08425268 + IF (0&(DEST) [35:08:10]-DPTR.DOT)-HISCNT<0 THEN 08425269 + POLISH([DEST[DPTR.DOT+HISCNT]],DEL); 08425270 + SPTR~SPTR; STREAM(SPTR,DOFF,HISCNT,D~[DEST[DWI]]); 08425271 + BEGIN 08425272 + DI~ DI + DOFF; SI~ LOC SPTR; 08425273 + DS~HISCNT DEC; 08425274 + END; 08425275 + CHAR~HISCNT; 08425276 + END ELSE 08425277 + BEGIN 08425280 + COMMENT CONDITIONAL XFER W/ SOURCE & DEST BOTH 6-BIT POINTERS; 08425300 + IF SPTR.[01:01] THEN 08425312 + P(M&1[14:47:01],SPTR.[09:22]+(SPTR.[33:15]!0),CHS,CDC,DEL); 08425314 + SORC~M[SPTR]; 08425320 + SORCL~0&(SORC)[35:08:10]-SPTR.DOT; 08425340 + DESTL~0&(DEST)[35:08:10]-DPTR.DOT; 08425360 + OURCNT~IF SORCL>DESTL THEN 08425380 + (IF HISCNT>DESTL THEN DESTL ELSE HISCNT) ELSE 08425400 + IF HISCNT>SORCL THEN SORCL ELSE HISCNT; 08425420 + SOFF~SPTR.[28:03]; DOFF~DPTR.[28:03]; 08425440 + SWI~SPTR.[18:10]; DWI~DPTR.[18:10]; 08425460 + MORE~TRUE; 08425480 + IF RELATION GEQ 24 THEN % IN ALPHA, NUMERIC, TRUTHSEI 08425500 + BEGIN 08425520 + IF AWHILE:=(RELATION LEQ 26) THEN % "WHILE IN" 08425540 + ELSE RELATION:=31-RELATION; % "UNTIL IN" (MUST INVERT) 08425545 + RELATION:=RELATION.[46:2]; % 0,1,2 08425550 + IF (ITERC~OURCNT)>63 THEN 08425560 + BEGIN 08425580 + TOGL~OURCNT; ITERC~63; 08425600 + DO CRA UNTIL (TOGL~TOGL-63){63 OR NOT MORE; 08425620 + ITERC~TOGL; 08425640 + END; 08425660 + IF MORE AND ITERC>0 THEN CRA; 08425680 + END ELSE 08425700 + BEGIN 08425720 + CHAR:=0&CHAR[36:42:6]; RELATION:=RELATION.[43:3]; 08425740 + IF (ITERC~OURCNT)>63 THEN 08425760 + BEGIN 08425780 + TOGL~OURCNT; ITERC~63; 08425800 + DO CREPL UNTIL (TOGL~TOGL-63){63 OR NOT MORE; 08425820 + ITERC~TOGL; 08425840 + END; 08425860 + IF MORE AND ITERC>0 THEN CREPL; 08425880 + END; 08425900 + IF MORE AND HISCNT>OURCNT THEN 08425920 + POLISH([DEST[DOFF&DWI[30:33:15]]],DEL, 08425940 + [SORC[SOFF&SWI[30:33:15]]],DEL); 08425960 + IF UPDTOG THEN CHAR~DOFF&DWI[30:33:15]-DPTR.DOT; 08425980 + END;% CONDITIONAL XFER OF 6-BIT CHARS DONE 08427840 + IF UPDTOG THEN 08427860 + BEGIN 08427880 + UPCTDD[0]~HISCNT.[35:13]-CHAR; 08427900 + UPDPDD[0]~DPTR&( DPTR.DOT+CHAR )AMPER; 08427920 + UPSPDD[0]~SPTR&( SPTR.DOT+CHAR )AMPER; 08427940 + END; 08427960 + END REPL; 08427980 + PROCEDURE COMPARE; %043 08430000 + BEGIN 08430020 + COMMENT STRING/POINTER COMPARISON INTRINSIC FOR B5500 IS ALGOL. 08430040 + MARCH 1968. POINTER UPDATES ADDED FOR STRING CMPR JUNE 1968. 08430060 + MAJOR REWRITE TO CORRECT BAD ALGORITHM--OCT 69. 08430062 + RATCHFORD; 08430080 + COMMENT THERE ARE FOUR FLAVORS OF STRING/POINTER COMPARE: 08430100 + 1. IN ALPHA. AEXP IS IN [42:06] OF F-7. RELATION=29. 08430120 + 2. = OR ! . 08430140 + RELATION=65 FOR = & 66 FOR ! 08430160 + 3. : : FOR . 08430180 + 4. FOR . 08430200 + VALUES OF ARE SAME AS FOR SCAN & REPLACE. FOR #4, 08430220 + F-FIELD OF F-2 IS LENGTH OF LITERAL STRING & C-FIELD IS VALUE 08430240 + OF IN SOURCE STMT (8192 IF OMITTED). 08430260 + RELATION HAS SIGN-BIT=1 FOR CASE #4. 08430280 + ; 08430300 + DEFINE 08430320 + DOT=[18:13]#, 08430340 + AMPER=[18:35:13]#, 08430360 + CSIZE=[31:02]#, SIX=00#; 08430380 + INTEGER 08430400 + RELATION =-01, %SAME CODES AS FOR SCAN/REPLACE. 08430420 + HISCNT =-02, %LENGTH OF LITERAL IN F-FIELD, 08430440 + %LENGTH OF COMPARE IN C-FIELD. 08430460 + P2 =-03, %SOURCE STMT IS "P1 RELATION P2 FOR 08430480 + %HISCNT" 08430500 + LITERAL =P2 , %P2 MAY BE A LITERAL OF 1->8 CHARS. 08430520 + P1 =-07, 08430540 + CHAR =P1 , %LOC"N OF CHAR FOR "CHAR IN ALPH A" 08430560 + R1C, R1W, %CHAR & WORD OFFSET FOR P1 08430580 + R2C, R2W, 08430600 + N, %LENGTH OF COMPARE FOR CURRENT CALL OF 08430620 + %FINDIT. 08430640 + LOOPCOUNT =P2, %USED FOR LITERAL COMPARISONS. 08430660 + JUNK = 17; 08430680 + REAL RJUNK=JUNK; 08430690 + BOOLEAN 08430700 + RESULT =P1, %THIS IS ALSO ONE OF THE POINTER ARGS. 08430720 + DONE; %SOMETIMES MEANS WE FOUND SOME ! CHARS. 08430740 + NAME 08430760 + UPP2DD =-04, %DD FOR UPDATE OF P2 POINTER. 08430780 + UPP1DD =-05, 08430800 + M = 02; 08430820 + ARRAY 08430840 + ROW1[*], ROW2[*]; %ARRAY ROWS REFERENCED BY P1/P2. 08430860 + SUBROUTINE FINDIT; %FIND BLOCK OF 64 CONTAINING 1ST ! CHARS. 08430880 + BEGIN; 08430890 + STREAM(N:R1C,R2C,R1~[ROW1[R1W]],R2~[ROW2[R2W]]); 08430900 + BEGIN 08430910 + SI~R1; SI~SI+R1C; 08430920 + DI~DI+R2C; 08430930 + IF N SC!DC THEN TALLY~1; 08430940 + N~TALLY; 08430950 + END; 08430960 + IF NOT (DONE~POLISH) THEN 08430970 + BEGIN %SET UP WORD & CHAR OFFSET FOR NEXT CALL. 08430980 + R1C~POLISH(R1C&R1W[35:38:10]+N,DUP).[45:03]; 08430990 + R1W~POLISH.[35:10]; 08431000 + R2C~POLISH(R2C&R2W[35:38:10]+N,DUP).[45:03]; 08431010 + R2W~POLISH.[35:10]; 08431020 + END UPDATE OF CHAR AND WORD INDICES; 08431030 + END FINDIT; 08431040 + SUBROUTINE COMP; %COMPARE 2 ! CHARS FOR < OR >. 08431050 + BEGIN; 08431060 + STREAM(RELATION:R1C,R2C,R1~[ROW1[R1W]],R2~[ROW2[R2W]]); 08431070 + BEGIN 08431080 + SI~R1; SI~SI+R1C; 08431090 + DI~DI+R2C; 08431100 + COMMENT COMP SHOULD ONLY BE CALLED IF FINDIT FINDS 2 ! CHARS.;08431110 + 63(IF SC!DC THEN JUMP OUT); 08431120 + SI~SI-1; DI~DI-1; 08431130 + CI~CI+RELATION; 08431140 + GO GR; 08431150 + %GO LS; 08431160 + LS:IF SCDC THEN ; % GO XX; 08431180 + XX:IF TOGGLE THEN TALLY~1; 08431190 + RELATION~TALLY; 08431200 + END COLLATING SEQ COMPARE; 08431210 + DONE~POLISH; 08431220 + END COMP; 08431230 + HISCNT ~ (HISCNT} 0) | HISCNT; 08431520 + IF RELATION.[43:5] GEQ 29 THEN % IN ALPHA, NUMERIC, TRUTHSET 08431540 + BEGIN; 08431560 + COMMENT CHAR IN ALPHA TEST; 08431580 + STREAM(TALLIE:=0 : CHAR, ITS:=RELATION.[46:2]-1, TSET:=[HISCNT]);08431600 + BEGIN 08431620 + SI~LOC CHAR; SI~SI+7; 08431640 + CI:=CI+ITS; GO TO ALP; GO TO NMR; % GO TO TSET; 08431660 + TST: SI:=TSET; SKIP CHAR SB; SKIP SB; 08431665 + IF SB THEN BEGIN TALLY:=1; TALLIE:=TALLY END; GO DUN; 08431670 + NMR: IF SC GEQ "0" THEN IF SC LEQ "9" THEN % 08431675 + BEGIN TALLY:=1; TALLIE:=TALLY END; GO DUN; 08431680 + ALP: IF SC=ALPHA THEN BEGIN TALLY:=1; TALLIE:=TALLY END; 08431685 + DUN: 08431690 + END; 08431695 + RESULT~POLISH; 08431700 + END ELSE 08431720 + IF RELATION>64 THEN 08431740 + COMMENT P1=P2 OR P1!P2:COMPARE THE ABSOLUTE ADDRESSES THAT THE 08431760 + 2 POINTERS REFERENCE WITHOUT LOOKING AT THE CONTENTS OF THESE 08431780 + LOCATIONS. NOTE THAT UNINITIALIZED POINTERS COMPARE EQUAL.; 08431800 + RESULT~(RELATION=65) EQV (P1.[18:30]=P2.[18:30]) ELSE 08431820 + BEGIN 08431840 + COMMENT A RELATIONAL COMPARISON OF TWO STRINGS.; 08431860 + COMMENT NOTE THAT THE 5500 SIMULATIONS USE THE BCL COLLATING 08431880 + SEQUENCE FOR RELATIONAL COMPARISONS, WHEREAS THE 6500 WILL 08431900 + COMPARE THE MAGNITUDES OF THE TWO CHARACTERS AS 4- 6- OR 8-BIT 08431920 + INTEGERS. THE 5500 SIMULATION ALSO ONLY ALLOWS 6-BIT BCL CHARS; 08431940 + IF (P2=0 AND RELATION.[1:1]=0) OR P1=0 08431945 + THEN P(MKS,INTCALL((-4)&1[2:47:1],FORTERRI)) ; 08431946 + IF P1.[01:01] THEN 08431950 + P(M&1[14:47:01],P1.[09:22]+(P1.[33:15]!0),CHS,CDC,DEL); 08431951 + IF P1.CSIZE!SIX THEN POLISH(M&1[14:47:01],8686,CDC,DEL); 08431960 + ROW1~M[P1]; R1C~P1.[28:03]; 08431980 + R1W~P1.[18:10]; HISCNT~ABS(HISCNT); 08432000 + IF (JUNK~HISCNT.[35:13]+P1.DOT)>0&(ROW1)[35:08:10] THEN 08432020 + POLISH([ROW1[JUNK]],DEL); 08432040 + IF RELATION.[01:01]=0 THEN 08432060 + BEGIN 08432080 + COMMENT BOTH P1&P2 ARE POINTERS; 08432100 + IF P2.[01:01] THEN 08432110 + P(M&1[14:47:01],P2.[09:22]+(P2.[33:15]!0),CHS,CDC,DEL); 08432111 + IF P2.CSIZE!SIX THEN 08432120 + POLISH(M&1[14:47:01], 8686,CDC,DEL); 08432140 + ROW2~M[P2]; R2C~P2.[28:03]; 08432160 + R2W~P2.[18:10]; 08432180 + IF (HISCNT+P2.DOT)>0&(ROW2)[35:08:10] THEN 08432200 + POLISH([ROW2[HISCNT+P2.DOT]],DEL); 08432220 + IF (JUNK~HISCNT)>63 THEN 08432240 + BEGIN 08432260 + N~63; 08432280 + DO FINDIT UNTIL ((JUNK~JUNK-63){63) OR DONE; 08432300 + END; 08432320 + IF (NOT DONE) AND (N~JUNK)!0 THEN FINDIT; 08432340 + END ELSE 08432380 + BEGIN 08432400 + COMMENT P2 IS A LITERAL STRING; 08432420 + IF (N~HISCNT.[18:15])=0 THEN N~HISCNT; 08432440 + RJUNK~P2; ROW2~[RJUNK]&1[17:47:01]; 08432460 + R2W~0; 08432480 + COMMENT IF HISCNT.[18:15]!0 THEN [18:15]=STRING LENGTH & 08432481 + [33:15]=EXPLICIT LENGTH OF COMPARE. OTHERWISE, [33:15] IS 08432482 + BOTH LENGTH OF COMPARE AND LENGTH OF LITERAL.; 08432483 + IF (HISCNT~HISCNT.[33:15]){N THEN 08432500 + BEGIN 08432520 + COMMENT LENGTH OF COMPARE IS { LENGTH OF LITERAL: WE DON"T 08432540 + HAVE TO REPEAT THE LITERAL; 08432560 + R2C~8-N; FINDIT; 08432580 + END ELSE 08432600 + BEGIN; 08432620 + COMMENT LITERAL MUST BE DUPLICATED TO FILL 8 CHARS ; 08432640 + STREAM(P2,N,SOFF~8-N,N1~8 DIV N,N2~(JUNK~8 MOD N), 08432660 + D~[JUNK]); 08432680 + BEGIN 08432700 + SI~LOC P2; SI~SI+SOFF; D~SI; 08432720 + N1(DS~N CHR; SI~D); 08432740 + DS~N2 CHR; 08432760 + END; 08432780 + N~IF HISCNT{8 THEN HISCNT ELSE 8; 08432800 + LOOPCOUNT~HISCNT-N; R2C~0; 08432820 + FINDIT; 08432840 + IF NOT DONE THEN 08432860 + BEGIN 08432880 + R2C~P1.[28:03]; R2W~P1.[18:10]; 08432900 + ROW2~ROW1; 08432920 + IF LOOPCOUNT>63 THEN 08432940 + BEGIN 08432960 + N~63; 08432980 + DO FINDIT UNTIL DONE OR (LOOPCOUNT~LOOPCOUNT-63){63; 08433000 + END; 08433020 + IF (NOT DONE) AND (N~LOOPCOUNT)!0 THEN FINDIT; 08433040 + END; 08433060 + END 08433120 + END; 08433140 + BEGIN 08433141 + UPP1DD[0] ~ P1 +0&HISCNT[18:35:13]; 08433142 + UPP2DD[0] ~ P2 +0&HISCNT[18:35:13]; END; 08433143 + IF (RELATION~ABS(RELATION))=8 THEN RESULT~(NOT DONE).[47:01] ELSE08433145 + IF RELATION=12 THEN RESULT~DONE ELSE 08433147 + IF DONE THEN 08433149 + BEGIN %FINDIT DISCOVERED A ! CHAR IN THE TWO STRINGS 08433151 + RELATION~RELATION.[45:01]; %0 & 16 TEST >, 4 & 20 TEST < 08433153 + COMP; RESULT~DONE; 08433155 + END ELSE 08433157 + COMMENT STRINGS WERE = AND RELATION IS NOT = OR !. PLUCK THE 08433159 + "=" HALF OF "{" OR "}" OUT OF RELATION.; 08433161 + RESULT~RELATION.[43:01]; 08433163 + END COLLATING SEQUENCE COMPARES; 08433320 + END COMPARE; 08433340 + PROCEDURE BASICPRINT(TYPE); 08500000 + VALUE TYPE; 08500100 + REAL TYPE; 08500200 + 08500300 + BEGIN REAL ALGOLWRITE = 12, 08500400 + ALGOLSELECT = 14; 08500450 + REAL RCW = +0; 08500500 + ARRAY POT = 25[*]; 08500600 + NAME M = 2; 08500700 + REAL T, 08500800 + WH1, 08500900 + WH2; 08501000 + BOOLEAN THISTYPE; 08501100 + INTEGER BSIZE, 08501200 + BUFF, 08501300 + BUFFLOAD, 08501400 + COL, 08501500 + COUNTER, 08501600 + E, 08501700 + ESIGN, 08501800 + EXPCHR, 08501900 + I, 08502000 + ITEMS, 08502100 + NUMCHR, 08502200 + NUMROWS, 08502300 + ROW, 08502400 + ROWLENGTH, 08502500 + SIGN, 08502600 + SKIP, 08502700 + TAB, 08502800 + WRITESTMT; 08502810 + NAME POINTER; 08502900 + NAME FILX; 08502950 + NAME STRING = T; 08503000 + ARRAY FIB[*], 08503100 + MATRIX[*], 08503200 + MATRIXROW[*]; 08503300 + BOOLEAN DATACOM, FIRSTIME; 08503325 + LABEL COMMON, 08503400 + LOGEIGHT, 08503500 + MAXINT, 08503600 + MINVALUE, 08503700 + TENSEVEN, 08503800 + TENSIX, 08503900 + CONVERTED, 08504000 + NORMAL, 08504100 + DUMMYLABEL; 08504200 + DEFINE LOG8 = P(LOGEIGHT)#, 08504300 + MAX = P(MAXINT) #, 08504400 + DELTA= P(MINVALUE)#, 08504500 + TEN6 = P(TENSIX) #, 08504600 + TEN7 = P(TENSEVEN)#; 08504700 + DEFINE COMMA = 1#, 08504800 + SEMICOLON = 2#, 08504900 + ENDLINE = 3#; 08505000 + 08505100 + 08505200 + REAL SUBROUTINE GETNEXT; 08505300 + BEGIN THISTYPE ~ (TYPE ~ 0&TYPE[6:7:40]).[6:1]; 08505400 + ITEMS ~ ITEMS-1; TAB ~ *(1 INX POINTER); 08505500 + P(*POINTER); POINTER ~ 2 INX POINTER; 08505600 + GETNEXT ~ POLISH 08505700 + END GETNEXT; 08505800 + BOOLEAN SUBROUTINE DIMENSION; 08505900 + BEGIN COMMENT TRUE FOR SINGLE DIMENSIONED (INCLUDES STRINGS);; 08506000 + STREAM(T~POLISH(XCH, 0, CDC):A~0); 08506100 + BEGIN SI~T; DI~T; SI~SI-16; SKIP 2 SB; 08506200 + IF SB THEN ELSE TALLY~1; T ~ TALLY; 08506300 + END STREAM; 08506400 + DIMENSION ~ THISTYPE OR POLISH; 08506500 + END DIMENSION; 08506600 + SUBROUTINE SETUPANDEXIT; 08506700 + BEGIN IF DATACOM THEN 08506800 + IF COUNTER NEQ 0 THEN 08506810 + BEGIN;STREAM(BUFF); DS:=LIT "~"; 08506820 + POLISH(MKS, 16, 0, 0, BSIZE, FILX, ALGOLWRITE); 08506830 + BUFF := -(*FILX).[CF]; 08506850 + END; 08506860 + FIB[20]:=BUFF&COUNTER[3:33:15]&BSIZE[18:38:10]&1[29:47:1]; 08506900 + POLISH(XIT); 08507000 + END SETUPANDEXIT; 08507100 + SUBROUTINE PRINT; 08507200 + BEGIN P(MKS,1,0,0,BSIZE+((NOT DATACOM).[47:1]),FILX,ALGOLWRITE); 08507300 + IF NOT DATACOM THEN 08507310 + STREAM(A:="10",B:=[FIB[0]]); 08507320 + BEGIN SI:=LOC A; DS:=8 ADD; END STREAM; 08507330 + END PRINT ROUTINF; 08507340 + SUBROUTINE CLEAR; 08507400 + BEGIN;STREAM(A~BSIZE-1+DATACOM:D~*FILX); 08507450 + BEGIN DS:=8 LIT " "; SI:=D; DS:=A WDS; DI:=D; A:=DI; END;08507500 + BUFF:=POLISH; BUFFLOAD:=BSIZE|8; 08507550 + END CLEAR ROUTINE; 08507600 + SUBROUTINE CHECKPRESENCE; 08507700 + BEGIN FIB[20]~(*P(DUP))&(COUNTER~0)[3:33:15]; 08507800 + BSIZE~P(MKS,1,0,0,(-1),FILX,ALGOLWRITE); 08507825 + IF DATACOM~FIB[4].[8:4]=10 OR FIB[4].[8:4]=13 THEN 08507850 + BSIZE ~ 9 ELSE 08507855 + BEGIN BSIZE~BSIZE-1; 08507860 + STREAM(A~FIB[0],B~BSIZE INX (*FILX)); 08507870 + BEGIN SI~LOC A; DS~WDS; END; 08507880 + END; 08507890 + CLEAR; 08507895 + END CHECKPRESENCE; 08507900 + SUBROUTINE PRINTEXIT; 08508000 + BEGIN PRINT; 08508100 + COUNTER ~ 0; 08508200 + SETUPANDEXIT; 08508300 + END PRINTEXIT; 08508400 + SUBROUTINE PRINTRETURN; 08508500 + BEGIN PRINT; 08508600 + CHECKPRESENCE; 08508700 + END PRINTRETURN; 08508800 + SUBROUTINE FINDE; 08508900 + BEGIN COMMENT DETFRMINE THE EXPONENT OF A REAL NUMBER. THE NUMBER 08509000 + IS POSITIVE AND PASSED IN T. WHEN DONE, STORE THE 08509100 + EXPONENT IN E, AND ROUND T TO 10*6 { T < 10*7; 08509200 + E ~ ((0&T[42:3:6]&T[1:2:1]+12)|LOG8)+0.5; 08509300 + WHILE T<(IF E}0 THEN POT[E] ELSE 1/POT[-E]) DO E ~ E-1; 08509400 + T ~ IF (6-E)}0 THEN T|POT[6-E] ELSE T/POT[E-6]; 08509500 + END FIND EXPONENT AND ROUND NUMBER; 08509600 + SUBROUTINE CONVERT; 08509700 + BEGIN 08509800 + IF THISTYPE THEN 08509900 + BEGIN; STREAM(A~0:S~STRING); 08510000 + BEGIN SI~S; SI~SI+15; DI~LOC A; DI~DI+7; DS~CHR; END; 08510100 + IF (I ~ POLISH+6)>15 THEN I ~ I-20; 08510200 + NUMCHR := I + 3 | WRITESTMT; 08510250 + IF(COUNTER + NUMCHR) GTR BUFFLOAD THEN PRINTRETURN; 08510300 + STREAM(I:STRING,WRITESTMT,BUFF); 08510400 + BEGIN SI:=STRING; WRITESTMT(DS~LIT """); DS~I CHR; 08510500 + WRITESTMT(DS~LIT """; DS~LIT ","); I~DI; 08510550 + END STREAM; 08510575 + BUFF := POLISH; COUNTER := COUNTER + NUMCHR; 08510600 + 08510650 + GO TO CONVERTED; 08510700 + LOGEIGHT::: @1157163034761674; 08510750 + END STRING HANDLING; 08510800 + COMMENT THAT WAS EASY -- NOW FOR THE NUMERICAL STUFF; 08510900 + ESIGN ~ EXPCHR ~ SIGN ~ SKIP ~ NUMCHR ~ 0; 08511000 + SIGN ~ T!(T ~ ABS(T)); 08511100 + IF T9); ESIGN ~ E<0; NUMCHR ~ 8-P(XCH); 08514500 + COMMON:: T ~ 1+NUMCHR+EXPCHR+((EXPCHR!0)+P(DUP))+WRITESTMT; 08514600 + IF (COUNTER+T)>BUFFLOAD THEN PRINTRETURN; 08514700 + STREAM(P1~SKIP:NUMCHR,SIGN,EXPCHR,P2~P(DUP)!0, 08514800 + LSIGN,P3~[WH1],P4~[E],WRITESTMT,BUFF); 08514900 + BEGIN DS~LIT " "; SIGN(DI~DI-1; DS~LIT "-"); 08515000 + SI~P3; SI~SI+P1; DS~NUMCHR CHR; 08515100 + P2(DS~2 LIT "E+"; ESIGN(DI~DI-1; DS~LIT "-"); 08515200 + SI~P4; SI~SI+8; SI~SI-EXPCHR; DS~EXPCHR CHR); 08515300 + WRITESTMT(DS~LIT ","); P1~DI; 08515400 + END STREAM; 08515500 + BUFF ~ POLISH; COUNTER ~ COUNTER+T; 08515600 + GO TO CONVERTED; 08515700 + 08515800 + MAXINT ::: @1045753603774000; 08515900 + MINVALUE::: @1256553762465363; 08516000 + TENSEVEN::: @1054611320000000; 08516100 + TENSIX ::: @1063641100000000; 08516200 + CONVERTED: 08516300 + END CONVERT; 08516400 + SUBROUTINE TABCONTROL; 08516500 + BEGIN COMMENT DOES ROUTINE TABBING OPERATIONS; 08516600 + IF TAB<0 THEN COMMENT TAB CONTROL GIVEN EXPLICITLY; 08516700 + BEGIN TAB:= (ABS(TAB)-1) MOD BUFFLOAD; 08516800 + IF FIRSTIME THEN BEGIN FIRSTIME:= FALSE; 08516900 + IF TAB LSS COUNTER THEN PRINTRETURN; END; 08516910 + BEGIN COMMENT SPACE FWD;% 08517000 + STREAM(A:=BUFF:TAB:=TAB-COUNTER, 08517050 + T:=P(DUP).[36:6]);% 08517060 + BEGIN 08517100 + SI:= LOC TAB; SKIP SB; 08517110 + IF SB THEN 08517120 + BEGIN COMMENT SPACE BACKWARD; 08517130 + SI:= A; T(SI:= SI- 32; SI:= SI - 32); 08517140 + SI:= SI - TAB; 08517150 + END ELSE 08517160 + BEGIN COMMENT SPACE FORWARD; 08517170 + SI:= A; T(SI:= SI + 32; SI:= SI + 32); 08517180 + SI := SI + TAB; 08517190 + END; 08517200 + A:= SI; 08517210 + END STREAM;% 08517300 + BUFF:=POLISH; COUNTER:=TAB;% 08517400 + END SPACE FWD THRU BUFFER;% 08517410 + END ELSE BEGIN COMMENT NORMAL TAB CONTROL FUNCTION; 08517500 + IF TAB=ENDLINE THEN PRINTEXIT; 08517600 + IF WRITESTMT = 0 THEN BEGIN 08517650 + IF TAB=COMMA THEN 08517700 + T ~ COUNTER-(COUNTER ~ ((COUNTER+14) DIV 15)|15) 08517800 + ELSE IF TAB=SEMICOLON THEN 08517900 + T := COUNTER-(COUNTER :=((COUNTER+5) DIV 3) | 3); 08518000 + IF COUNTER>BUFFLOAD THEN PRINTRETURN ELSE 08518100 + IF TAB!0 THEN BEGIN; 08518200 + STREAM(BUFF:T); 08518300 + BEGIN SI~BUFF; SI~SI+T; BUFF~SI; END; 08518400 + BUFF ~ POLISH; 08518500 + END END END END TABCONTROL; 08518600 + COMMENT*********START OF CODE******; 08518700 + ITEMS ~ TYPE.[1:6]; WRITESTMT ~ TYPE.[46:1]; 08518800 + POINTER ~ 1 INX ([RCW]&RCW[FTC]); 08518900 + FILX ~ *POINTER; FILX[NOT 4] ~ *(1 INX POINTER); 08518910 + POINTER ~ 2 INX POINTER; 08518920 + FIB ~ FILX[NOT 2]; 08519000 + IF FIB[5].[43:1] THEN P(MKS, 0, 0, FILX, 1, ALGOLSELECT); 08519100 + IF FIB[0]=0 THEN BEGIN FIB[0]:="1000"; THISTYPE:=TRUE; END; 08519150 + DATACOM ~ FIB[4].[8:4] = 10 OR FIB[4].[8:4] = 13; 08519175 + IF (COUNTER ~ (T ~ FIB[20]).[3:15])=0 THEN CHECKPRESENCE ELSE 08519200 + BEGIN BUFF ~ T.[30:18]; BUFFLOAD ~ 8|(BSIZE ~ T.[18:10]) END; 08519300 + IF THISTYPE AND FIB[4].[8:4]=4 THEN 08519320 + P(*[FIB[14]],7,CDC,1,SSN,XCH,STD); 08519330 + IF DATACOM THEN CLEAR 08519350 + ELSE IF FIB[21] NEQ 0 THEN P(FILX,8,11,COM); 08519360 + TAB:= *POINTER; POINTER:= 1 INX POINTER; 08519400 + FIRSTIME := TRUE; TABCONTROL; 08519410 + IF ITEMS=0 THEN SETUPANDEXIT; 08519500 + IF NOT TYPE THEN GO TO NORMAL; 08519600 + DO BEGIN COMMENT MATRIX PRINI ROUTINE; 08519700 + POLISH(MATRIX ~ GETNEXT); 08519800 + IF P(TAB, DUP)=ENDLINE THEN TAB ~ COMMA; P(XCH); 08519900 + IF DIMENSION THEN 08520000 + BEGIN COL ~ THISTYPE+1; ROWLENGTH ~ MATRIX.[8:10]; 08520100 + DO BEGIN 08520200 + T ~ [MATRIX[COL]]; 08520300 + CONVERT; TABCONTROL; 08520400 + END UNTIL (COL ~ COL+THISTYPE+1)=ROWLENGTH; 08520500 + IF (TAB ~ POLISH)=ENDLINE THEN PRINTEXIT; 08520550 + END ELSE BEGIN 08520600 + NUMROWS ~ MATRIX.[8:10]; 08520700 + ROWLENGTH ~ (*[MATRIX[ROW ~ 1]]).[8:10]; 08520800 + DO BEGIN 08520900 + MATRIXROW ~ *[MATRIX[ROW]]; COL ~ 1; 08521000 + DO BEGIN 08521100 + T ~ [MATRIXROW[COL]]; 08521200 + CONVERT; TABCONTROL; 08521300 + END UNTIL (COL ~ COL+1)=ROWLENGTH; 08521400 + IF COUNTER!0 THEN PRINTRETURN; 08521450 + END UNTIL (ROW ~ ROW+1)=NUMROWS; 08521500 + IF (TAB ~ POLISH)=ENDLINE THEN SETUPANDEXIT; 08521600 + END; 08521700 + END UNTIL (POINTER INX 0)=[TYPE].[CF]; 08521800 + SETUPANDEXIT; 08521900 + NORMAL: DO BEGIN T ~ GETNEXT; 08522000 + CONVERT; TABCONTROL; 08522100 + END UNTIL (POINTER INX 0)=[TYPE].[CF]; 08522200 + SETUPANDEXIT; 08522300 + END BASIC PRINT ROUTINE; 08522400 + PROCEDURE READATA(TYPE); 08600000 + VALUE TYPE; 08600100 + REAL TYPE; 08600200 + BEGIN 08600300 + ARRAY DATA = 21[*], 08600400 + COMPANION = 22[*]; 08600500 + INTEGER PTR = 23, 08600600 + ENDATA = 24; 08600700 + INTEGER COL, 08600800 + COUNT, 08600900 + D, 08601000 + NUMROWS, 08601100 + R, 08601200 + ROW, 08601300 + ROWLENGTH, 08601400 + T; 08601500 + BOOLEAN THISTYPE; 08601600 + ARRAY MATRIX[*], 08601700 + MATRIXROW[*], 08601800 + DATAROW[*], 08601900 + COMPROW[*]; 08602000 + NAME N; 08602100 + LABEL NORMAL; 08602200 + REAL SUBROUTINE GETNEXT; 08602300 + BEGIN COMMENT GET NEXT ITEM FROM STACK, AND DO 08602400 + SOME ROUTINE HOUSEKEEPING OPERATIONS; 08602500 + P(*(P(.TYPE)+COUNT)); 08602600 + THISTYPE ~ (TYPE ~ 0&TYPE[6:7:40]).[6:1]; 08602700 + GETNEXT ~ POLISH 08602800 + END GETNEXT; 08602900 + BOOLEAN SUBROUTINE DIMENSION; 08603000 + BEGIN COMMENT TRUE FOR SINGLE DIMENSIONED (INCLUDES STRINGS);; 08603100 + STREAM(T~POLISH(XCH, 0, CDC):A~0); 08603200 + BEGIN SI~T; DI~T; SI~SI-16; SKIP 2 SB; 08603300 + IF SB THEN ELSE TALLY~1; T ~ TALLY; 08603400 + END STREAM; 08603500 + DIMENSION ~ THISTYPE OR POLISH; 08603600 + END DIMENSION; 08603700 + SUBROUTINE PUT; 08603800 + BEGIN COMMENT GETS AND STORES NEXT DATUM; 08603900 + IF (R|256+D)=ENDATA THEN POLISH((-48), 26, COM); 08604000 + IF DATAROW=0 THEN 08604100 + BEGIN DATAROW ~ *[DATA[R]]; 08604200 + COMPROW ~ *[COMPANION[R]]; 08604300 + END; 08604400 + STREAM(A~T.[43:5]:B~[COMPROW[T.[40:3]]]); 08604500 + BEGIN SI~B; SI~SI+2; SKIP 4 SB; SKIP A SB; 08604600 + IF SB THEN TALLY~1; A~TALLY; 08604700 + END STREAM; 08604800 + IF POLISH+THISTYPE THEN P((-44), 26, COM); 08604900 + IF THISTYPE THEN 08605000 + BEGIN COMMENT STRING;; 08605100 + STREAM(S~[DATAROW[D]],N); 08605200 + BEGIN SI~S; DS~2 WDS; END; 08605300 + END ELSE COMMENT NUMERICAL STUFF (OR WE ARE IN TROUBLE); 08605400 + P(DATAROW[D],[N],~); 08605500 + IF (D ~ D+THISTYPE+1)}256 THEN 08605600 + BEGIN COMMENT ROW OVERFLOW; 08605700 + R := R+1; T := D := DATAROW := 0; 08605800 + END ELSE T ~ T+1; 08605900 + END PUT; 08606000 + SUBROUTINE EXIT; 08606100 + BEGIN COMMENT FUTZ UP PTR AND GO BACK TO THE REAL WDRLD; 08606200 + PTR ~ R&D[CTF]&T[9:39:9]; 08606300 + POLISH(XIT); 08606400 + END EXIT; 08606500 + COMMENT**********START OF CODE**********; 08606600 + COUNT ~ TYPE.[1:6]; 08606700 + R ~ PTR.[CF]; D ~ PTR.[FF]; T ~ PTR.[9:9]; 08606800 + IF NOT TYPE THEN GO TO NORMAL; 08606900 + DO BEGIN 08607000 + POLISH(MATRIX ~ GETNEXT); 08607100 + IF DIMENSION THEN 08607200 + BEGIN COL ~ THISTYPE+1; ROWLENGTH ~ MATRIX.[8:10]; 08607300 + DO BEGIN 08607400 + N ~ [MATRIX[COL]]; 08607500 + PUT; 08607600 + END UNTIL (COL ~ COL+THISTYPE+1)=ROWLENGTH; 08607700 + END ELSE BEGIN 08607800 + NUMROWS ~ MATRIX.[8:10]; 08607900 + ROWLENGTH ~ (*[MATRIX[ROW ~ 1]]).[8:10]; 08608000 + DO BEGIN 08608100 + MATRIXROW ~ *[MATRIX[ROW]]; COL ~ 1; 08608200 + DO BEGIN 08608300 + N ~ [MATRIXROW[COL]]; 08608400 + PUT; 08608500 + END UNTIL (COL ~ COL+1)=ROWLENGTH; 08608600 + END UNTIL (ROW ~ ROW+1)=NUMROWS; 08608700 + END; 08608800 + END UNTIL (COUNT ~ COUNT-1)=0; 08608900 + EXIT; 08609000 + NORMAL: 08609100 + DO BEGIN 08609200 + N ~ GETNEXT; PUT; 08609300 + END UNTIL (COUNT ~ COUNT-1)=0; 08609400 + EXIT; 08609500 + END READATA; 08609600 + PROCEDURE BASICINPUT(TYPES); 08700000 + VALUE TYPES; 08700100 + REAL TYPES; 08700200 + 08700300 + BEGIN REAL RCW = +0, 08700400 + ALGOLREAD = 13, 08700500 + ALGOLSELECT = 14; 08700600 + ARRAY POT = 25[*]; 08700700 + INTEGER BSIZE, 08700800 + BUFF, 08700900 + CHAR, 08701000 + COL, 08701100 + COUNT, 08701200 + COUNTER, 08701300 + DECADES, 08701400 + E, 08701500 + ESIGN, 08701600 + NUMBER, 08701700 + NUMROWS, 08701800 + ROW, 08701900 + ROWLENGTH, 08702000 + SIGN; 08702100 + BOOLEAN GOTDIGIT, 08702200 + READSTMT, 08702250 + STOG, 08702300 + THISTYPE; 08702400 + ARRAY FIB[*], 08702500 + MATRIX[*], 08702600 + MATRIXROW[*]; 08702700 + NAME ADDRESS, 08702800 + FILX, 08702850 + POINTER, 08702900 + STRING = ADDRESS; 08703000 + LABEL LOOK, 08703100 + SIGNED, 08703200 + PASTPOINT, 08703300 + AT, 08703400 + EXPSIGNED, 08703500 + DECIMAL, 08703600 + ERROR, 08703700 + STRUNG, 08703800 + QUOTEDSTRING, 08703810 + SETCOUNT, 08703820 + NORMAL, 08703900 + EXIT, 08704000 + DUMMYLABEL; 08704100 + REAL SUBROUTINE GETNEXT; 08704200 + BEGIN COUNT ~ COUNT-1; 08704300 + P(*POINTER); POINTER ~ 1 INX POINTER; 08704400 + THISTYPE ~ (TYPES ~ 0&TYPES[6:7:39]).[6:1]; 08704500 + GETNEXT ~ POLISH 08704600 + END GETNEXT; 08704700 + BOOLEAN SUBROUTINE DIMENSION; 08704800 + BEGIN COMMENT TRUE FOR SINGLE DIMENSIONED (INCLUDES STRINGS);; 08704900 + STREAM(T~POLISH(XCH, 0, CDC):A~0); 08705000 + BEGIN SI~T; DI~T; SI~SI-16; SKIP 2 SB; 08705100 + IF SB THEN ELSE TALLY~1; T ~ TALLY; 08705200 + END STREAM; 08705300 + DIMENSION ~ THISTYPE OR POLISH; 08705400 + END DIMENSION; 08705500 + SUBROUTINE CHECKPRESENCE; 08705600 + BEGIN COMMENT CALL ALGOL READ INTRINSIC TO 08705700 + AWAIT TOP BUFFER BEING PRESENT; 08705800 + BSIZE ~ POLISH(MKS, 0, 1, FILX, ALGOLREAD); 08705900 + IF FIB[4].[8:4]=10 THEN BSIZE ~ 9 ELSE BSIZE ~ BSIZE-1; 08705950 + BSIZE ~ BSIZE|8; BUFF ~ (*FILX).[CF]; 08706000 + END CHECK PRESENCE BIT; 08706100 + SUBROUTINE READIT; 08706200 + POLISH(MKS, 0, 0, FILX, ALGOLREAD); 08706300 + SUBROUTINE SETUPANDEXIT; 08706310 + BEGIN FIB[21]:=BUFF&BSIZE[18:38:10]&1[29:47:1]; P(XIT); END; 08706320 + SUBROUTINE SCAN; 08706400 + BEGIN COMMENT GENERAL-PURPOSE SCANNER -- CHARACTER AT A TIME; 08706500 + LOOK: IF BSIZE=0 THEN BEGIN READIT; CHECKPRESENCE; END; 08706600 + STREAM(I~-1,BUFF,N~IF BSIZE<63 THEN BSIZE ELSE 63:STOG); 08706700 + BEGIN SI~BUFF; CI~CI+STOG; GO TO DEBLANK; 08706800 + COMMENT SWITCH ON WHETHER WITHIN STRING OR NOT; 08706900 + GNC: TALLY~TALLY+1; DI~LOC I; DS~LIT "0"; 08707000 + DI~DI+6; DS~CHR; GO TO EXIT; 08707100 + DEBLANK: N(IF SC!" " THEN JUMP OUT TO GNC; 08707200 + TALLY~TALLY+1; SI~SI+1); 08707300 + EXIT: N~TALLY; BUFF~SI; 08707400 + END STREAM; 08707500 + BSIZE ~ BSIZE-P(XCH); COMMENT UPDATE COUNT; 08707600 + BUFF ~ POLISH; COMMENT UPDATE POINTER; 08707700 + IF P(DUP)<0 THEN COMMENT ONLY FOUND BLANKS; 08707800 + BEGIN P(DEL); 08707900 + IF (BSIZE=0) AND GOTDIGIT THEN P(",") ELSE GO TO LOOK; 08707920 + END; 08707940 + CHAR ~ POLISH; 08708000 + END SCAN ROUTINE; 08708100 + BOOLEAN SUBROUTINE TESTCOLLECT; COMMENT PUTS CURRENT CHAR 08708110 + INTO STRING AND UPDATES CHAR COUNTER,ALSO DETECTS OVERFLOW; 08708115 + BEGIN 08708120 + STREAM(CHAR, N:=COUNTER:=COUNTER+1, STRING);% 08708125 + BEGIN SI := LOC N; SI := SI-1;% 08708130 + DI := DI+N; DS := CHR;% 08708135 + END STREAM;% 08708140 + TESTCOLLECT:=COUNTER=15;% 08708145 + END TESTCOLLECT;% 08708150 + SUBROUTINE FREEREAD; 08708200 + BEGIN COMMENT READS AND STORES NEXT DATUM, DOING APPROPRIATF 08708300 + CONVERSIONS. HANDLES STRINGS AND NUMBERS, AND 08708400 + ACCEPTS A VARIETY OF FORMATS; 08708500 + DECADES ~ E ~ ESIGN ~ GOTDIGIT ~ NUMBER ~ STOG ~ 0; SCAN; 08708600 + IF CHAR="," THEN GO TO EXIT; 08708700 + IF THISTYPE THEN GO TO STRUNG; 08708800 + GOTDIGIT ~ 1; 08708850 + IF (SIGN ~ CHAR="-") OR CHAR="+" OR CHAR="&" THEN SCAN; 08708900 + IF CHAR>9 THEN GO TO DECIMAL; 08709000 + DO BEGIN NUMBER ~ 10|NUMBER+CHAR; SCAN; 08709100 + END UNTIL CHAR>9; 08709200 + IF CHAR="." THEN 08709300 + BEGIN SCAN; 08709400 + PASTPOINT:: WHILE CHAR{9 DO 08709500 + BEGIN NUMBER ~ 10|NUMBER+CHAR; 08709600 + DECADES ~ DECADES+1; SCAN; 08709700 + END END; 08709800 + IF CHAR="@" OR CHAR="E" THEN 08709900 + AT:: BEGIN SCAN; 08710000 + IF (ESIGN ~ CHAR="-") OR CHAR="+" OR CHAR="&" THEN SCAN; 08710100 + IF (E ~ CHAR)>9 THEN GO TO ERROR; SCAN; 08710200 + WHILE CHAR{9 DO BEGIN E ~ 10|E+CHAR; SCAN; END; 08710300 + IF ESIGN THEN E ~ -E; 08710400 + END; 08710500 + WHILE CHAR!"," DO SCAN; 08710600 + P(NUMBER, E-DECADES, POT[ABS(P(DUP))], XCH); 08710700 + IF P(DUP)=0 THEN P(DEL, DEL) 08710800 + ELSE IF P<0 THEN P(/) ELSE P(|); 08710900 + IF SIGN THEN P(CHS); P([ADDRESS], ~); 08711000 + GO TO EXIT; 08711100 + DECIMAL:: IF CHAR="." THEN BEGIN SCAN; 08711200 + IF CHAR{9 THEN GO TO PASTPOINT ELSE GO TO ERROR; END; 08711300 + NUMBER ~ 1; 08711400 + IF CHAR="@" OR CHAR="E" THEN GO TO AT; 08711500 + ERROR: COMMENT ERROR TERMINATE - INVALID INPUT DATUM;% 08711600 + POLISH((-41), 26, COM);% 08711610 + STRUNG:: COMMENT COLLECT STRING ITEM;% 08711700 + COUNTER:=-(STOG:=1);% 08711800 + STREAM(STRING); DS:=16 LIT" "; % BLANK STRING 08711900 + IF CHAR =""" THEN GO QUOTEDSTRING;% 08712000 + WHILE (CHAR NEQ " " AND CHAR NEQ ",") 08712100 + DO IF TESTCOLLECT THEN GO ERROR ELSE SCAN;% 08712200 + GO TO SETCOUNT;% 08712210 + QUOTEDSTRING:: 08712300 + SCAN; IF CHAR=""" THEN GO SETCOUNT;% 08712400 + IF TESTCOLLECT THEN GO ERROR ELSE GO QUOTEDSTRING;% 08712500 + COMMENT CONVERT COUNTER TO COLLATING SEQUENCE;% 08712600 + SETCOUNT: 08712700 + IF COUNTER LSS 0 THEN GO ERROR % NULL STRING 08712800 + ELSE IF (COUNTER:=COUNTER-5) LSS 0 THEN COUNTER:=COUNTER+20;% 08712810 + COMMENT PUT IN CHAR COUNT REQUIRED BY BASIC STRINGVARB;% 08712900 + STREAM(COUNTER,STRING);% 08712920 + BEGIN SI:=LOC STRING; SI:=SI-1; 08713000 + DI:=DI+15; DS:=CHR;% 08713010 + END STREAM;% 08713020 + GOTDIGIT:=1; STOG:=0;% 08713100 + IF CHAR NEQ "," THEN DO SCAN UNTIL CHAR=",";% 08713110 + EXIT:: 08713200 + END FREE FIELD READ ROUTINE; 08713300 + COUNT ~ TYPES.[1:6]; READSTMT ~ TYPES.[46:1]; 08713400 + FILX ~ *(POINTER ~ 1 INX ([RCW]&RCW[FTC])); 08713500 + FILX[NOT 4] ~ *(1 INX POINTER); FIB ~ FILX[NOT 2]; 08713510 + POINTER ~ 2 INX POINTER; 08713520 + IF FIB[5].[43:2]!2 THEN P(MKS, 0, 2, FILX, 1, ALGOLSELECT); 08713600 + IF (E:=FIB[4].[8:4])=10 OR E=13 THEN FIB[20]:=0 08713610 + ELSE IF FIB[20] NEQ 0 THEN P(FILX,8,11,COM); 08713620 + IF (BUFF ~ (E ~ FIB[21]).[30:18]) = 0 08713700 + THEN CHECKPRESENCE ELSE BSIZE ~ E.[18:10]; 08713710 + IF NOT TYPES THEN GO TO NORMAL; 08713800 + DO BEGIN 08713900 + POLISH(MATRIX ~ GETNEXT); 08714000 + IF DIMENSION THEN 08714100 + BEGIN COL ~ THISTYPE+1; ROWLENGTH ~ MATRIX.[8:10]; 08714200 + DO BEGIN 08714300 + ADDRESS ~ [MATRIX[COL]]; 08714400 + FREEREAD; 08714500 + END UNTIL (COL ~ COL+THISTYPE+1)=ROWLENGTH; 08714600 + END ELSE BEGIN 08714700 + NUMROWS ~ MATRIX.[8:10]; 08714800 + ROWLENGTH ~ (*[MATRIX[ROW ~ 1]]).[8:10]; 08714900 + DO BEGIN 08715000 + MATRIXROW ~ *[MATRIX[ROW]]; COL ~ 1; 08715100 + DO BEGIN 08715200 + ADDRESS ~ [MATRIXROW[COL]]; 08715300 + FREEREAD; 08715400 + END UNTIL (COL ~ COL+1)=ROWLENGTH; 08715500 + END UNTIL (ROW ~ ROW+1)=NUMROWS; 08715600 + END; 08715700 + END UNTIL COUNT=0; 08715800 + SETUPANDEXIT; 08715900 + NORMAL: 08716000 + DO BEGIN 08716100 + ADDRESS ~ GETNEXT; 08716200 + FREEREAD; 08716300 + END UNTIL COUNT=0; 08716400 + SETUPANDEXIT; 08716490 + END BASIC INPUT ROUTINE; 08716500 +%***********************************************************************08800000 +PROCEDURE MATRIXDIDDLER(A, B, C, TYPE);% MAT ARITH INTRINSIC 08800050 +VALUE A, % RESULTANT MOM 08800100 + B, % ARG 1 MOM OR SCALAR VALUE 08800110 + C; % ARG 2 MOM 08800120 + ARRAY A[*], B[*], C[*]; 08800200 + INTEGER TYPE; 08800300 +%***********************************************************************08800310 + BEGIN REAL SCALE = B; 08800400 + INTEGER I, 08800500 + J, 08800600 + LASTI, 08800700 + LASTJ; 08800800 + ARRAY AROW[*], 08800900 + BROW[*], 08801000 + CROW[*]; 08801100 + BOOLEAN SINGLE; 08801200 + LABEL ERROR, 08801300 + DIMERR, %% 08801350 + CHKSI, 08801355 + CHKSIZE, 08801360 + NORMAL, 08801400 + SCALEFACTOR; 08801500 +DEFINE SF = [8:10]#;% 08801600 +BOOLEAN SUBROUTINE DIMENSION; % 08801700 + BEGIN COMMENT TRUE FOR SINGLY-DIMENSIONED MATRIX;; 08801800 + STREAM(T:=P(XCH, 0, CDC):A:=0); 08801900 + BEGIN SI:=T; DI:=T; SI:=SI-16; SKIP 2 SB;%% 08802000 + IF SB THEN ELSE TALLY:=1; T:=TALLY; 08802100 + END STREAM; 08802200 + DIMENSION := POLISH; 08802300 + END DIMENSION; 08802400 +COMMENT * * * * * * * * * * * START OF CODE * * * * * * * * * * *; 08802500 + I := J:= 1; POLISH(CROW := C);% 08802600 + IF (SINGLE := DIMENSION) THEN 08802700 + BEGIN COMMENT ROW VECTOR CASE;% 08802800 + LASTI := 2; LASTJ := C.SF;% 08802850 + IF NOT POLISH(AROW :=A, DIMENSION) THEN GO ERROR; % 08802900 + IF TYPE = 2 THEN GO CHKSI; % 08803000 + IF POLISH(BROW := B, DIMENSION) THEN 08803050 + IF LASTJ = BROW.SF THEN GO CHKSI;% 08803100 + ERROR: COMMENT NON CONFORMAL ARGUMENTS; 08803200 + POLISH((-50), 26, COM); % 08803300 + CHKSI: COMMENT CHECK DIMESION BOUNDS; 08803310 + IF LASTJ GTR A.SF THEN 08803400 + DIMERR: COMMENT DIMESION SIZE ERROR; 08803500 + POLISH((-72), 26, COM);% 08803510 + END ROW VECTOR CASE ELSE 08803600 + BEGIN COMMENT MATRIX CASE;% 08803610 + LASTI := C.SF; LASTJ := (*[C[1]]).SF;% 08803700 + IF POLISH(A, DIMENSION) THEN GO ERROR;% 08803800 + IF TYPE = 2 THEN GO CHKSIZE;% 08803900 + IF NOT POLISH(B,DIMENSION) THEN 08804000 + IF LASTI = B.SF THEN 08804100 + IF LASTJ = (*[B[1]]).SF THEN GO CHKSIZE;% 08804200 + GO TO ERROR;% 08804300 + CHKSIZE: COMMENT CHEK DIMENSION BOUNDS;% 08804310 + IF LASTI GTR A.SF OR 08804400 + LASTJ GTR (*[A[1]]).[8:10] THEN %% 08804500 + GO TO DIMERR; %% 08804600 + END MATRIX CASE;% 08804700 + IF TYPE = 2 THEN GO TO SCALEFACTOR; %% 08804800 + NORMAL:: 08804900 + DO BEGIN 08805000 + IF NOT SINGLE THEN 08805100 + BEGIN AROW := *[A[I]]; BROW := *[B[I]]; 08805200 + CROW := *[C[I]]; J := 1; 08805300 + END; 08805400 + IF TYPE=0 THEN 08805500 + :: DO AROW[J] := BROW[J]+P(CROW[J], XCH) 08805600 + UNTIL (J := J+1)=LASTJ 08805700 + ELSE 08805800 + :: DO AROW[J] := CROW[J]-P(BROW[J], XCH) 08805900 + UNTIL (J := J+1)=LASTJ; 08806000 + COMMENT NOTE FANCY WAY OF SAYING A=B-C; 08806100 + END UNTIL (I := I+1)=LASTI; 08806200 + P(XIT); 08806300 + SCALEFACTOR:: 08806400 + DO BEGIN 08806500 + IF NOT SINGLE THEN 08806600 + BEGIN AROW := *[A[I]]; CROW := *[C[I]]; END; %% 08806700 + IF SCALE = 1 THEN %% 08806800 + BEGIN; STREAM(F:=[CROW[1]],N:=LASTJ-1, 08806900 + T:=P(DUP).[36:6],DES := [AROW[1]]); %% 08807000 + BEGIN SI:=F; T(DS:=32 WDS; DS:=32 WDS); %% 08807100 + DS := N WDS; %% 08807200 + END STREAM; %% 08807300 + END ELSE %% 08807400 + BEGIN J := 1; %% 08807500 + :: DO AROW[J] := CROW[J]|P(SCALE, NOP, XCH) %% 08807600 + UNTIL (J := J+1)=LASTJ; %% 08807700 + END; %% 08807800 + END UNTIL (I := I+1)=LASTI; %% 08807900 + END MATRIX DIDDLER; %% 08808000 +%********************************************************* 08900000 +PROCEDURE TRANSPOSE(A,B); %%%% MATRIX TRANSPOSE %%%% 08900010 +VALUE A,B; %%%% INTRINSIC %%%% 08900100 +ARRAY A[*], % MOM DLSC FOR RESULTANT MATRIX OR ROW VECTOR 08900200 + B[*]; % MOM DESC FOR ARGUMENT " " 08900210 +%********************************************************* 08900220 +BEGIN LABEL ERR50,ERR72,NORMAL,PLACE,TRANSPOSEIT;% 08900300 + INTEGER I,J,LASTI,LASTJ;% 08900320 + ARRAY ROW[*];% 08900400 + DEFINE SF=[8:10]#;% 08900405 + COMMENT THERE ARE THREE SPECIES OF MATRIX TRANSPOSITION; 08900420 + % 1. ROW INTO COLUMN 08900430 + % 2. COLUMN INTO ROW 08900440 + % 3. MATRIX INTO MATRIX 08900450 + % IN THIS CASE TRANSPOSITION MAY BE DONE IN PLACE 08900500 + COMMENT TRANPOSITION WILL BE PERFORMED WHEN THE RESULTANT 08900501 + MATRIX DIMENSIONS ARE LARGE ENOUGH TO ACCOMMODATE 08900502 + THE DIMENSIONS OF THE ARGUMENT MATRIX,EVEN THO THE MATRICES 08900503 + MAY NOT BE MATHEMATICALLY CONFORMABLE;% 08900504 + 08900505 + BOOLEAN SUBROUTINE DIMENSION; 08900510 + BEGIN COMMENT TRUE IF SINGLY DIMENSIONED;; 08900515 + STREAM(T:=POLISH(XCH, 0, CDC):A:=0); 08900520 + BEGIN SI:=T; DI:=T; SI:=SI-16; SKIP 2 SB; 08900525 + IF SB THEN ELSE TALLY:=1; T:=TALLY; 08900530 + END STREAM; 08900535 + DIMENSION := POLISH; 08900540 + END; 08900545 +%*********** START OF CODE ************* 08900549 + POLISH(A); IF DIMENSION THEN% 08900550 + BEGIN COMMENT 1-DIM RESULTANT,ALLOW 2. ONLY; 08900555 + POLISH(B); IF DIMENSION THEN % ERROR - ROW TO ROW 08900560 + BEGIN ERR50:P((-50),26,COM);% 08900600 + ERR72: P((-72),26,COM);% 08900605 + END ERRORS;% 08900607 + IF (LASTI:=(*[B[1]]).SF) NEQ 2 THEN GO ERR50;% 08900610 + IF (LASTJ:=B.SF) GTR A.SF THEN GO ERR72;% 08900630 + I:=1; ROW:=A;% 08900650 + GO TRANSPOSEIT;% 08900700 + END 1 DIM RESULTANT ELSE 08900710 + BEGIN COMMENT 2-DIM RESULTANT, ALLOW 1. OR 3.; 08900750 + POLISH(B); IF NOT DIMENSION THEN GO NORMAL;% 08900800 + IF (*[A[1]]).SF NEQ 2 THEN GO ERR50;% 08900810 + IF (LASTJ:=B.SF) GTR A.SF THEN GO ERR72;% 08900830 + :: DO POLISH(B[J],*[A[J]],1,CDC,STD) UNTIL (J:=J+1)=LASTJ;% 08900850 + POLISH(XIT);% 08900870 + END 2 DIM RESULTANT;% 08900890 + NORMAL: 08900900 + IF (LASTI:=(*[B[1]]).SF) GTR A.SF 08901000 + OR (LASTJ:=B.SF) GTR(*[A[1]]).SF THEN GO ERR72;% 08901010 + I:=1; IF A.[FF]=B.[FF] THEN GO PLACE; % TRN IN PLACE 08901020 + :: DO BEGIN ROW:=*[A[I]];% 08901100 + TRANSPOSEIT: J:=1;% 08901110 + :: DO P(*[B[J]], I, COC, [ROW[J]], ~) UNTIL (J ~ J+1)=LASTJ; 08901200 + END UNTIL (I ~ I+1)=LASTI; 08901300 + POLISH(XIT); 08901400 + PLACE:: IF LASTI=2 THEN POLISH(XIT); 08901500 + :: DO BEGIN ROW ~ *[A[I]]; J ~ I+1; 08901600 + :: DO P(ROW[J], *[A[J]], I, CDC, DUP, LOD, [ROW[J]], ~, ~) 08901700 + UNTIL (J ~ J+1)=LASTJ; 08901800 + END UNTIL (I ~ I+1)=LASTI-1; 08901900 + END TRANSPOSE ROUTINE; 08902000 +%***********************************************************************09000000 +PROCEDURE MATRIXMULTIPLY(A,B,C); %%% MATRIX MULTIPLICATION %%% 09000100 +VALUE A,B,C; %%% INTRINSIC %%% 09000200 +ARRAY A[*], % RESULTANT MAT OR ROW VECTOR MOM 09000300 + B[*], % ARG-1 " 09000400 + C[*]; % ARG-2 " 09000500 +%***********************************************************************09000600 +BEGIN 09000700 + LABEL ERR50,ERR72,DOTPRODUCT,CROSSPRODUCT;% 09000800 + ARRAY AROW[*], % 09000900 + BROW[*], % 09001000 + CROW[*];% 09001100 + INTEGER I,J,K,LASTI,LASTJ,LASTK;% 09001200 + DEFINE SF = [8:10]#, X = BROW#;% 09001300 + DEFINE SETTOSAVEBIT(SETTOSAVEBIT1)=SI:=SETTOSAVEBIT1; 09001400 + SI:=SI-16; SKIP 2 SB; IF SB THEN DS:=SET ELSE DS:=RESET#; 09001500 + LABEL RRM,MRM,MMR,MMM; % 09001600 + SWITCH SWL :=ERR50,RRM,ERR72,ERR72,ERR50, 09001700 + MRM,MMR,MMM;% 09001800 +REAL SUBROUTINE DIMENSIONS; 09001900 +BEGIN COMMENT SETS BIT IN SWVAL TO INDICATE MAT;% 09002000 + STREAM(SWVAL:=0:A1:=[A[0]],B1:=[B[0]],C1:=[C[0]]);% 09002100 + BEGIN DI:=LOC SWVAL; SKIP 45 DB;% 09002200 + SETTOSAVEBIT(A1); SETTOSAVEBIT(B1); SETTOSAVEBIT(C1); 09002300 + END STREAM;% 09002400 + DIMENSIONS:=POLISH;% 09002500 +END DIMENSIONS;% 09002600 +BOOLEAN SUBROUTINE DIMERR;% 09002610 + DIMERR:=(LASTI GTR A.SF) OR (LASTJ GTR AROW.SF);% 09002620 +COMMENT ********** START OF CODE *************; 09002700 + LASTI:=B.SF; LASTJ:=(CROW:=*[C[1]]).SF; % 09002710 + LASTK:=C.SF; AROW:=*[A[I:=1]]; BROW:=*[B[1]];% 09002800 + GO TO SWL[DIMENSIONS];% 09002900 +MMM: COMMENT A(A1,A2)=B(B1,B2)*C(C1,C2);% 09003000 + IF LASTK NEQ BROW.SF THEN 09003100 +ERR50: COMMENT NON-CONFORMAL ARGUMENT MATRICES;% 09003200 + POLISH((-50),26,COM);% 09003300 + IF DIMERR THEN 09003400 +ERR72: COMMENT RESULTANT BOUNDS TOO SMALL - DIM ERR;% 09003600 + POLISH((-72),26,COM);% 09003700 + IF LASTK=2 THEN GO CROSSPRODUCT ELSE GO DOTPRODUCT;% 09003800 +:: DO BEGIN 09004000 + BROW:=*[B[I]]; AROW:=*[A[I]];% 09004100 + DOTPRODUCT: J:=1;% 09004200 + :: DO BEGIN 09004300 + K:=1; POLISH(0);% 09004400 + :: DO P(*[C[K]],J,COC,BROW[K],MUL,ADD) 09004500 + UNTIL (K:=K+1)=LASTK;% 09004600 + POLISH( [AROW[J]], STD);% 09004700 + END UNTIL (J:=J+1)=LASTJ;% 09004800 + END UNTIL (I:=I+1)=LASTI;% 09004900 + POLISH(XIT);% 09005000 +RRM: COMMENT A(A1)=B(B1)*C(C1,C2);% 09005100 + AROW:=A; % 09005200 +MRM: COMMENT A(A1,A2)=B(B1)*C(C1,C2);% 09005400 + IF LASTK NEQ (BROW:=B).SF THEN GO ERR50; % 09005700 + LASTI:=2; IF DIMERR THEN GO TO ERR72;% 09005800 + GO TO DOTPRODUCT;% 09005900 +MMR: COMMENT A(A1,A2)=B(B1,1)*C(C1);% 09006100 + IF BROW.SF NEQ 2 THEN GO TO ERR50;% 09006200 + LASTJ:=LASTK; IF DIMERR THEN GO TO ERR72;% 09006300 + CROW:=C;% 09006600 +CROSSPRODUCT:: 09006700 + DO BEGIN 09006800 + AROW:=*[A[I]]; J:=1; % 09006900 + X:=POLISH(*[B[I]],1,COC);% 09007000 + :: DO P(X,CROW[J],MUL,[AROW[J]],STD) 09007100 + UNTIL(J:=J+1)=LASTJ;% 09007200 + END UNTIL(I:=I+1)=LASTI;% 09007300 +END MATRIXMULTIPLY;% 09007400 + PROCEDURE INVERT(A, B); 09100000 + VALUE A, B; 09100100 + ARRAY A[*], B[*]; 09100200 + BEGIN REAL BIG, 09100300 + DIAG = BIG; 09100400 + DEFINE EPS = COMMENT 10@-13; 0.0000000000001#; 09100500 + INTEGER I, 09100600 + II, 09100700 + J, 09100800 + K, 09100900 + K2, 09101000 + L, 09101100 + N, 09101200 + N1; 09101300 + REAL BLOCKCOUNTER = 16, 09101400 + BLOCKROUTINE = 5; 09101500 + ARRAY AROW[*], 09101600 + COPY[*], 09101700 + PLACEHOLDER[*]; 09101800 + DEFINE MOVEWORDS = N1(DS~32 WDS; DS~32WDS); DS~N WDS#; 09101900 + SUBROUTINE SWAPROWS; 09102000 + BEGIN;STREAM(A~*[A[I]],B~*[A[K2]],N~N+1,N1~P(DUP).[36:6],COPY); 09102100 + BEGIN SI~A; MOVEWORDS; 09102200 + SI~B; DI~A; MOVEWORDS; 09102300 + SI~COPY; DI~B; MOVEWORDS; 09102400 + END END SWAPROWS; 09102500 + ;STREAM(T:=[A[0]]:T1:=[B[0]]); 09102505 + BEGIN SI:=T; DI:=T; SI:=SI-16; SKIP 2 SB; 09102510 + IF SB THEN 09102515 + BEGIN SI:=T1; DI:=T1; SI:=SI-16; SKIP 2 SB; 09102520 + IF SB THEN ELSE TALLY:=1; 09102525 + END ELSE TALLY:=1; 09102530 + T:=TALLY; 09102535 + END STREAM; 09102540 + IF POLISH THEN POLISH((-50), 26, COM); 09102545 + IF (N ~ A.[8:10])!(*[A[1]]).[8:10] THEN P((-54), 26, COM); 09102600 + N1 ~ (N ~ N-1)-1; 09102700 + IF A.[FF]!B.[FF] THEN 09102800 + BEGIN IF B.[8:10]!N+1 OR (*[B[1]]).[8:10]!N+1 09102900 + THEN POLISH((-50), 26, COM); 09103000 + IF N1=0 THEN P(*[B[1]], 1, COC, *[A[1]], 1, CDC, ~) ELSE 09103100 + FOR I~1 STEP 1 UNTIL N DO 09103200 + STREAM(N, N1~P(DUP).[36:6], S~*[B[I]], D~*[A[I]]); 09103300 + BEGIN SI~S; SI~SI+8; DI~D; DI~DI+8; MOVEWORDS; END; 09103400 + END; 09103500 + IF N=0 THEN 09103600 + POLISH(*[A[1]], 1, CDC, DUP, LOD, 1, XCH, /, XCH, ~, XIT); 09103700 + BLOCKCOUNTER ~ BLOCKCOUNTER+1; 09103800 + POLISH(MKS, [PLACEHOLDER[P]], N+1, 1, 1, 0, BLOCKROUTINE); 09103900 + BLOCKCOUNTER ~ BLOCKCOUNTER+1; 09104000 + POLISH(MKS, [COPY[P]], N+1,1,1,1,BLOCKROUTINE); 09104100 + COMMENT REDUCE THE MATRIX BY ROW PIVOTS TO TRI-DIAGONAL FORM; 09104200 + FOR I~1 STEP 1 UNTIL N DO 09104300 + BEGIN II ~ (K2 ~ I)-1; BIG ~ 0; 09104400 + FOR J~I STEP 1 UNTIL N DO 09104500 + BEGIN AROW ~ *[A[J]]; POLISH(0); 09104600 + FOR K~1 STEP 1 UNTIL II DO 09104700 + POLISH(*[A[K]], I, COC, AROW[K], |, -); 09104800 + POLISH(AROW[I], +); 09104900 + IF POLISH([AROW[I]], SND, SSP, DUP)>BIG THEN 09105000 + POLISH(.BIG, ~, J, .K2, ~) ELSE P(DEL); 09105100 + END; 09105200 + IF BIG{EPS THEN POLISH((-57), 26, COM);% NEARLY SINGULAR 09105300 + IF (PLACEHOLDER[I] ~ K2)!I THEN SWAPROWS; 09105400 + DIAG ~ POLISH((AROW ~ *[A[I]]), I, COC); 09105500 + FOR J~I+1 STEP 1 UNTIL N DO 09105600 + BEGIN POLISH(0); 09105700 + FOR K~1 STEP 1 UNTIL II DO 09105800 + POLISH(*[A[K]], J, COC, AROW[K], |, -); 09105900 + POLISH(AROW[J], +, DIAG, /, [AROW[J]], ~); 09106000 + END END; 09106100 + POLISH(10, COM); COMMENT RETURN COPY ARRAY; 09106200 + COMMENT INVERT LOWER TRIANGULAR MATRIX; 09106300 + FOR I~1 STEP 1 UNTIL N DO 09106400 + BEGIN II ~ I-1; DIAG ~ POLISH((AROW ~ *[A[I]]), I, COC); 09106500 + FOR J~1 STEP 1 UNTIL II DO 09106600 + BEGIN POLISH(0); 09106700 + FOR K~J STEP 1 UNTIL II DO 09106800 + POLISH(*[A[K]], J, COC, AROW[K], |, -); 09106900 + POLISH(DIAG, /, [AROW[J]], ~); 09107000 + END; 09107100 + AROW[I] ~ 1.0/DIAG; 09107200 + END; 09107300 + COMMENT INVERT UPPER TRIANGULAR MATRIX; 09107400 + FOR I~N1 STEP -1 UNTIL 1 DO 09107500 + BEGIN II ~ I+1; AROW ~ *[A[I]]; 09107600 + FOR J~N STEP -1 UNTIL II DO 09107700 + BEGIN L ~ J-1; POLISH(0); 09107800 + FOR K~II STEP 1 UNTIL L DO 09107900 + POLISH(*[A[K]], J, COC, AROW[K], |, -); 09108000 + POLISH(AROW[J], CHS, +, [AROW[J]], ~); 09108100 + END END; 09108200 + COMMENT MULTIPLY UPPER AND LOWER HALVES TO PRODUCE INVERSE; 09108300 + FOR I~1 STEP 1 UNTIL N1 DO 09108400 + BEGIN AROW ~ *[A[I]]; 09108500 + FOR J~1 STEP 1 UNTIL N DO 09108600 + BEGIN IF (K2 ~ J){I THEN K2 ~ I+1; POLISH(0); 09108700 + FOR K~K2 STEP 1 UNTIL N DO 09108800 + POLISH(*[A[K]], J, COC, AROW[K], |, +); 09108900 + IF I}J THEN POLISH(AROW[J], +); 09109000 + POLISH([AROW[J]], ~); 09109100 + END END; 09109200 + COMMENT EXCHANGE COLUMN ELEMENTS TO ABSOLVE ROW PIVOTING; 09109300 + FOR J~N STEP -1 UNTIL 1 DO 09109400 + IF (I ~ PLACEHOLDER[J])!J THEN 09109500 + FOR K~1 STEP 1 UNTIL N DO 09109600 + BEGIN AROW ~ *[A[K]]; 09109700 + POLISH(AROW[I], [AROW[J]], DUP, LOD, [AROW[I]], ~, ~); 09109800 + END; 09109900 + POLISH(10, COM); COMMENT RETURN PLACEHOLDER ARRAY; 09110000 + END INVERT; 09110100 + PROCEDURE FORTRANFREEREAD; 09200000 + BEGIN REAL PARL = -1, % PARITY LABEL WORD 09200100 + EOFL = -2, % END-OF-FILE "LABEL WORD" 09200200 + LISX = -3, % ACCIDENTAL ENTRY FOR LIST 09200300 + DKADR = -4; % DISK ADDRESS 09200400 + NAME FILX = -5; % FILE TANK DESCRIPTOR 09200500 + REAL BLOCK = 5, % INTRINSIC INTRINSIC DESCRIPTOR 09200600 + ALGOLREAD = 13, % NORMAL-STATE I/O INTRINSIC 09200700 + SELECT = 14, % FILE STATUS INTRINSIC 09200800 + JUNK = 17, % ANOTHER TEMPORARY 09200900 + ARRAYSTUFF = 18, % USED BY LIST FOR ARRAYS 09201000 + LSTRN = 19, % INTERNAL LIST POINTER 09201100 + LISTYPE = 20, % TELLS TYPE OF LIST ITEM 09201200 + HOLTOG = 21; % FOR CHARACTER TRANSLATION 09201300 + ARRAY POT = 22[*]; % POWERS-OF-TEN TABLE 09201400 + REAL FORTERR = 24; % FORTRAN ERROR MESSAGE ROUTINE 09201450 + ARRAY ARRY[*], % GLOBAL TEMPORARY ARRAY 09201600 + FIB[*]; % FILE INFORMATION BLOCK 09201700 + 09201800 + BOOLEAN ARRAYTOG, % LIST ELEMENT WAS ARRAY NAME 09201900 + COMPLEXTOG, % FIRST HALF OF COMPLEX NUMBER 09202000 + DBLTOG, % LIST ELEMENT DOUBLE TYPE 09202100 + DONE, % FLAG FOR LIST EXHAUSTED 09202200 + ESIGN, % EXPONENT NEGATIVE FLAG 09202300 + GOTDIGIT, % TELLS IF CHARACTER SEEN 09202400 + SEQ, % TRUE IFF FILE HAS SEQ NUMBERS. 09202450 + READREC, % TRUE IFF SCANNER MAY READ A RECORD 09202460 + SIGN, % MANTISSA NEGATIVE FLAG 09202500 + STRINGTOG, % CONTROLS SCANNER ACTION 09202600 + TWODIMTOG; % ON IF ARRAY IS TWO-DIMENSIONAL 09202700 + 09202800 + INTEGER BSIZE, % NUMBER OF CHARACTERS LEFT IN BUFFER09202900 + BUFF, % CURRENT BUFFER POSITION 09203000 + CHAR, % CONTAINS LAST CHARACTER SCANNED 09203100 + COUNTER, % NUMBER CHARACTERS IN STRING 09203200 + DECADES, % NUMBER OF DECIMAL PLACES 09203300 + E, % CONTAINS EXPONENT 09203400 + INDEX, % INDEX INTO ARRAY IF ARRAYTOG 09203500 + SIZE, % ARRAY SIZE IF ARRAYTOG 09203600 + TYPE; % TYPE OF LAST LIST ELEMENT 09203700 + NAME ADDRESS, % HOLDS ADDRESS TO STORE NEXT DATUM 09203900 + LISTADR = ARRY; % HOLDS RESULT OF [LISX] 09204000 + 09204100 + REAL NUMBER, % TEMPORARY NUMBER HOLDER 09204200 + NUMBERL, NUMBERH ; % DBLPREC NUMBER BUILT BY FREEREAD 09204205 + 09204300 + LABEL LISTSTART, 09204400 + LISTEXIT, 09204500 + LOOK, 09204600 + NUMERICAL, 09204700 + PASTPOINT, 09204800 + BYE, 09204850 + SCNR, 09204860 + AT, 09204900 + DECIMAL, 09205000 + ERROR, 09205100 + STRING, 09205200 + STRUNG, 09205300 + GETCOMMA, 09205400 + LOGICAL, 09205500 + EXIT; 09205600 + 09205700 + SWITCH SWISH := EXIT, NUMERICAL, STRING, NUMERICAL, 09205800 + LOGICAL, NUMERICAL, NUMERICAL; 09205900 + 09206000 + DEFINE INTEGERV = 1#, 09206100 + STRINGV = 2#, 09206200 + REALV = 3#, 09206300 + LOGICALV = 4#, 09206400 + DOUBLEV = 5#, 09206500 + COMPLEXV = 6#; 09206600 + 09206700 + DEFINE KIND = (FIB[4].[8:4])#, 09206800 + DATATYPE = (LISTYPE.[44:4])#, 09206900 + TWOD = (LISTYPE.[38:1])#, 09207000 + SIZEF = [33:15]#, 09207100 + BASEF = [18:15]#, 09207200 + IOD = (*FILX)#; 09207300 + 09207400 + SUBROUTINE CHECKPRESENCE; 09207500 + BEGIN COMMENT GETS NEXT BUFFER FROM ALGOLREAD; 09207600 + BSIZE~(P(MKS,DKADR,1,FILX,ALGOLREAD)-SEQ)|8 ; 09207700 + BUFF := IOD.[33:15]; 09207800 + END CHECKPRESENCE; 09207900 + 09208000 + SUBROUTINE READIT; 09208100 + BEGIN COMMENT ORDER NEXT RECORD READ FROM MEDIUM; 09208200 + P(MKS, DKADR, 0, FILX, ALGOLREAD); 09208300 + IF DONE THEN P(XIT); 09208400 + IF IOD.[27:1] THEN P(XIT); 09208700 + CHECKPRESENCE; 09208800 + END READIT; 09208900 + 09209000 + REAL SUBROUTINE NEXT; 09209100 + BEGIN COMMENT GET DESCRIPTOR POINTING INTO AN ARRAY; 09209200 + IF TWODIMTOG THEN 09209300 + P(*[ARRY[INDEX.[33:7]]], INDEX.[40:8], CDC) 09209400 + ELSE P([ARRY[INDEX]]); 09209500 + NEXT := POLISH; 09209600 + END NEXT ITEM INSIDE AN ARRAY; 09209700 + 09209800 + SUBROUTINE LISTELEMENT; 09209900 + BEGIN COMMENT GETS ADDRESS TO STORE NEXT DATUM, AND 09210000 + DIDDLES CERTAIN TOGGLES AS REQUIRED; 09210100 + LISTSTART: 09210200 + IF ARRAYTOG THEN 09210300 + BEGIN ADDRESS := NEXT; 09210400 + IF (INDEX := INDEX+DBLTOG+1)}SIZE THEN 09210500 + ARRAYSTUFF~ARRAYTOG~COMPLEXTOG~0 ; 09210600 + GO TO LISTEXIT; 09210700 + END; 09210800 + IF COMPLEXTOG THEN 09210900 + BEGIN ADDRESS := [LISTADR[1]]; COMPLEXTOG := 0; 09211000 + GO TO LISTEXIT; 09211100 + END; 09211200 + P(0); LISTADR := [LISX]; 09211300 + COMPLEXTOG~(TYPE~DATATYPE)=COMPLEXV; DBLTOG~TYPE=DOUBLEV ; 09211310 + IF ARRAYSTUFF!0 THEN 09211400 + BEGIN 09211500 + ARRAYTOG~1; P(LISTADR~MEM[LISTADR.[18:15]]) ; 09211600 + SIZE~(INDEX~ARRAYSTUFF.BASEF)+ARRAYSTUFF.SIZEF ; 09211700 + TWODIMTOG~NOT P(LOD,TOP); P(DEL) ; 09211800 + GO TO LISTSTART; 09211900 + END; 09212000 + ADDRESS ~ [LISTADR[0]]; P(DEL); 09212100 + LISTEXIT: 09212150 + 09212300 + END GET NEXT LIST ELEMENT; 09212400 + 09212500 + SUBROUTINE SCANNER ; 09212600 + BEGIN COMMENT GENERAL PURPOSE SCANNER -- CHARACTER AT A TIME. 09212700 + PURLOINED FROM BASICINPUT ROUTINE BY WWF4; 09212800 + LOOK: IF BSIZE=0 THEN READIT; 09212900 + STREAM(I:=-1, BUFF, 09213000 + N:=IF BSIZE<63 THEN BSIZE ELSE 63: STRINGTOG); 09213100 + BEGIN SI:=BUFF; CI:=CI+STRINGTOG; GO TO DEBLANK; 09213200 + COMMENT BLANKS SIGNIFICANT WITHIN STRINGS; 09213300 + GNC: TALLY:=TALLY+1; DI:=LOC I; DS:=LIT "0"; 09213400 + DI:=DI+6; DS:=CHR; GO TO EXIT; 09213500 + DEBLANK: N(IF SC!" " THEN JUMP OUT TO GNC; 09213600 + TALLY:=TALLY+1; SI:=SI+1); 09213700 + EXIT: N:=TALLY; BUFF:=SI; 09213800 + END STREAM; 09213900 + BSIZE := BSIZE-P(XCH); % UPDATE CHARACTER COUNT 09214000 + BUFF := POLISH; % UPDATE BUFFER POINTER 09214100 + IF (CHAR~POLISH)<0 THEN 09214200 + IF BSIZE=0 THEN 09214250 + BEGIN 09214275 + IF GOTDIGIT THEN CHAR~"," 09214300 + ELSE IF READREC THEN GO LOOK 09214350 + END 09214355 + ELSE GO LOOK ; 09214360 + END SCANNER; 09214400 + 09214405 + SUBROUTINE LOGICALCOMPARE ; 09214410 + BEGIN COMMENT COMPARES LOGICAL TO .TRUE.,.TRU.,.TR.,.T., OR 09214415 + .FALSE.,.FALS.,.FAL.,.FA.,.F. ; 09214416 + STREAM(C~P(XCH):C2~COUNTER-1,C1~8-COUNTER,E,NUMBER) ; 09214425 + BEGIN 09214430 + SI~LOC NUMBER; SI~SI+C1; DI~LOC C; DI~DI+E ; 09214435 + IF C2 SC=DC THEN IF SC="." THEN TALLY~1; C~TALLY ; 09214440 + END ; 09214445 + E~P ; 09214450 + END OF LOGICALCOMPARE ; 09214455 + 09214460 + SUBROUTINE SCAN ; 09214465 +SCNR: BEGIN SCANNER ; 09214470 + IF CHAR="/" THEN 09214475 + BEGIN READREC~0 ; 09214480 + WHILE CHAR!"=" AND BSIZE>0 DO SCANNER; READREC~1 ; 09214485 + IF BSIZE=0 AND GOTDIGIT THEN CHAR~"," ELSE GO SCNR ; 09214487 + END ; 09214490 + END OF SCAN ; 09214495 + 09214500 + SUBROUTINE BUILDNUMBER ; 09214505 + BEGIN COMMENT BUILDS DBLPREC NUMBER NUMBERL,NUMBERH ; 09214510 + P(NUMBERL,NUMBERH) ; 09214515 + WHILE CHAR<10 DO 09214520 + BEGIN 09214525 + COUNTER~NUMBER~0 ; 09214530 + DO BEGIN COUNTER~COUNTER+1; NUMBER~NUMBER|10+CHAR;SCAN END09214540 + UNTIL CHAR>9 OR COUNTER=11 ; 09214545 + DECADES~DECADES+COUNTER ; 09214546 + IF DBLTOG THEN P(0,POT[COUNTER],DLM,0,NUMBER,DLA) 09214547 + ELSE P(POT[COUNTER],|,NUMBER,+) ; 09214550 + END ; 09214555 + NUMBERL~P(.NUMBERH,~) ; 09214560 + END OF BUILDNUMBER ; 09214565 + 09214570 + REAL SUBROUTINE ALFA ; 09214575 + BEGIN 09214577 + STREAM(CHAR:Q~0) ; 09214579 + BEGIN 09214581 + SI~LOC CHAR; SI~SI+7; IF SC=ALPHA THEN TALLY~1; CHAR~TALLY09214583 + END ; 09214585 + ALFA~P ; 09214587 + END OF ALFA ; 09214589 + 09214591 + SUBROUTINE FREEREAD; 09214600 + BEGIN COMMENT READS AND STORES NEXT DATUM, DOING APPROPRIATE 09214700 + CONVERSIONS. TYPE OF SCAN IS DEPENDENT ON TYPE OF 09214800 + LIST ITEM. OPERATES INDIFFERENTLY ON A VARIETY OF 09214900 + NUMERICAL FORMATS; 09215000 + GOTDIGIT := STRINGTOG := FALSE; 09215100 + COUNTER~E~ESIGN~NUMBERL~NUMBERH~NUMBER~DECADES~0 ; 09215200 + SCAN; IF CHAR="," THEN GO TO EXIT; 09215300 + IF CHAR>9 THEN 09215310 + IF ALFA THEN 09215315 + BEGIN 09215320 + DO SCAN UNTIL NOT ALFA ; 09215325 + IF CHAR="(" THEN 09215330 + BEGIN 09215335 + DO BEGIN DO SCAN UNTIL CHAR>9 END UNTIL CHAR!58;09215340 + IF CHAR!")" THEN GO ERROR; SCAN ; 09215345 + END ; 09215350 + IF CHAR="-" THEN 09215355 + BEGIN 09215360 + SCAN; IF NOT(CHAR="R" OR CHAR="I")THEN GO ERROR;09215365 + SCAN ; 09215370 + END ; 09215375 + IF CHAR!"=" THEN GO ERROR; SCAN ; 09215380 + END ; 09215385 +BYE: IF (DONE~CHAR="*") THEN READIT ; 09215400 + IF CHAR = """ THEN GO TO STRING; 09215405 + IF CHAR="|" THEN GO GETCOMMA ; 09215410 + GOTDIGIT := TRUE; 09215500 + GO TO SWISH[TYPE]; 09215600 + NUMERICAL:: 09215700 + IF (SIGN := CHAR="-") OR CHAR="+" OR CHAR="&" THEN SCAN; 09215800 + IF CHAR>9 THEN GO TO DECIMAL; 09215900 + BUILDNUMBER ; 09216000 + DECADES~0 ; 09216100 + IF CHAR="." THEN 09216200 + BEGIN SCAN; 09216300 + PASTPOINT:: 09216400 + BUILDNUMBER ; 09216500 + END ; 09216800 + IF CHAR="@" OR CHAR="E" OR CHAR="D" THEN 09216900 + AT:: BEGIN SCAN; 09217000 + IF (ESIGN := CHAR="-") OR CHAR="+" OR CHAR="&" THEN SCAN; 09217100 + IF (E := CHAR)>9 THEN GO TO ERROR; SCAN; 09217200 + WHILE CHAR{9 DO 09217300 + BEGIN E := 10|E+CHAR; SCAN; END; 09217400 + IF ESIGN THEN E := -E; 09217500 + END; 09217600 + 09217700 + IF ABS(NUMBER~E-DECADES)>69 THEN GO ERROR ; 09217800 + P(NUMBERL,NUMBERH) ; 09217900 + IF NUMBER!0 THEN 09218000 + IF DBLTOG THEN P(POT[69+ABS(NUMBER)],POT[ABS(NUMBER)], 09218025 + IF NUMBER<0 THEN P(DLD) ELSE P(DLM)) 09218050 + ELSE P(POT[ABS(NUMBER)],IF NUMBER<0 THEN P(/) ELSE P(|)) ;09218100 + IF SIGN THEN P(CHS) ; 09218400 + IF DBLTOG THEN P([ADDRESS],STD,[ADDRESS[1]],STD) 09218500 + ELSE BEGIN 09218600 + P(XCH,DEL,[ADDRESS]) ; 09218615 + IF TYPE=INTEGERV THEN 09218620 + BEGIN 09218625 + IF P(DUP)>@7777777777777 THEN GO ERROR ; 09218630 + P(ISD) ; 09218635 + END 09218640 + ELSE P(STD) ; 09218645 + END ; 09218650 + GO TO GETCOMMA; 09218700 + DECIMAL:: 09218800 + IF CHAR="." THEN 09218900 + BEGIN SCAN; 09219000 + IF CHAR{9 THEN GO TO PASTPOINT ELSE GO TO ERROR; 09219100 + END; 09219200 + NUMBERH~1 ; 09219300 + IF CHAR="@" OR CHAR="E" OR CHAR="D" THEN GO TO AT; 09219400 + ERROR:: 09219500 + IF PARL!0 THEN 09219600 + P(PARL, MKS, 9, BLOCK); 09219700 + P(MKS, FIB[6], FILX.[33:15], 2, FORTERR); 09219800 + STRING:: 09219900 + IF CHAR!""" THEN GO TO ERROR; 09220000 + COUNTER := 0; STRINGTOG := 1; NUMBER := " "; 09220100 + DO BEGIN SCANNER ; 09220200 + STRUNG:: 09220300 + IF CHAR!""" THEN 09220400 + BEGIN COUNTER:=COUNTER+1; 09220500 + STREAM(CHAR,N:=COUNTER,T:=[NUMBER]); 09220600 + BEGIN SI:=LOC N; SI:=SI-1; 09220700 + DI:=DI+1; DI:=DI+N; DS:=CHR; 09220800 + END STREAM; 09220900 + END; 09221000 + END UNTIL (COUNTER=6) OR CHAR="""; 09221100 + IF COUNTER=0 THEN GO TO ERROR; 09221200 + P(NUMBER, [ADDRESS], STD); 09221300 + IF CHAR!""" THEN 09221400 + BEGIN SCANNER; IF CHAR=""" THEN GO GETCOMMA ; 09221500 + IF LSTRN=(-1) THEN GO TO ERROR; 09221600 + LISTELEMENT; 09221700 + IF LSTRN=(-1) THEN GO ERROR ; 09221750 + NUMBER := " "; COUNTER := 0; GO TO STRUNG; 09221800 + END; 09221900 + GETCOMMA:: 09222000 + WHILE CHAR!"," AND CHAR!"*" DO SCAN; IF CHAR="*" THEN GO BYE ;09222100 + GO TO EXIT; 09222200 + LOGICAL:: 09222300 + IF CHAR="." THEN 09222400 + BEGIN COMMENT SHOULD BE ".TRUE.", ".FALSE.", OR ABBREVIAIIONS; 09222500 + NUMBER := COUNTER := E := 0; 09222600 + DO BEGIN 09222700 + SCAN; NUMBER := CHAR & NUMBER[12:18:30]; 09222800 + END UNTIL (COUNTER := COUNTER+1)=6 OR 09222900 + CHAR="," OR CHAR="."; 09223000 + IF NOT (E~COUNTER=2 AND NUMBER="T,") THEN 09223100 + BEGIN E~4; P("TRUE"); LOGICALCOMPARE ; 09223110 + IF NOT E THEN 09223115 + BEGIN 09223120 + IF COUNTER!2 OR NUMBER!"F," THEN 09223125 + BEGIN E~3; P("FALSE"); LOGICALCOMPARE ; 09223130 + IF NOT E THEN GO ERROR ; 09223135 + END ; 09223140 + E~0 ; 09223145 + END ; 09223200 + END ; 09223300 + END ELSE IF (E~CHAR="T") OR CHAR="F" THEN 09223400 + BEGIN SCAN ; 09223405 + IF NOT (CHAR="." OR CHAR=",") THEN GO ERROR ; 09223410 + END 09223420 + ELSE IF NOT ((E~CHAR=1) OR CHAR=0) THEN GO ERROR ; 09223425 + P(E, [ADDRESS], STD); GO TO GETCOMMA; 09223500 + EXIT:: 09223600 + END FREEREAD; 09223700 + 09223800 + COMMENT ***** ***** START OF CODE ***** ***** *****; 09223900 + FILX[NOT 3]~PARL; FILX[NOT 4]~EOFL; 09224000 + FIB := FILX[NOT 2]; 09224100 + IF FIB[5].[43:2]!2 THEN 09224200 + POLISH(MKS, 0, 2, FILX, 1, SELECT); 09224300 + CHECKPRESENCE; ARRAYSTUFF := 0; 09224400 + IF FIB[0]=0 THEN FIB[0] := 1; 09224500 + IF FIB[0]!1 AND KIND=2 THEN 09224600 + POLISH(MKS, FIB[6], FILX.[33:15], 4, FORTERR); 09224700 + IF P(*[FIB[14]],TOP) THEN P(DEL) 09224710 + ELSE BSIZE~-(SEQ~(SEQ~(*(4 INX P(XCH))).[36:6])!0 AND SEQ!8 09224720 + AND SEQ!9)|8 09224730 + +BSIZE ; 09224740 + LSTRN~READREC~1 ; 09224800 + DO BEGIN IF DONE~LSTRN=(-1) THEN READIT; LISTELEMENT ; 09224900 + IF (DONE := (LSTRN=(-1))) THEN READIT; 09225000 + FREEREAD; 09225050 + END UNTIL FALSE; 09225100 + END FORTRAN FREE FIELD READ; 09225300 +PROCEDURE COBOLDECIMALTOOCTALCONVERT(A) ; %% INTRINSIC # @151 09300000 +VALUE A; NAME A ; 09300100 + % THIS PROCEDURE CONVERTS A STRING OF N BCD DIGITS, STARTING AT WORD09300200 + % ADDRESS A, CHARACTER OFFSET S, INTO A DOUBLE-LENGTH VALUE. THE LOW09300300 + % PART OF THIS IS STORED IN S, THE HIGH PART IN N. IF N.[1:1]=1,THEN09300400 + % THE SIGN OF THE VALUE IS OBTAINED FROM THE ZONE BITS OF THE 1-SY 09300500 + % CHARACTER (BCD DIGIT), OTHERWISE FROM THE LAST. 0{S{7, 0{ABS(N){2309300600 + BEGIN 09300700 + REAL N=A-2, S=N-1, Q=9, C ; 09300800 + REAL HOLD1,HOLD2,HOLD3 ; NAME A1; 09300850 + LABEL B,D,E,T8,G ; 09300900 + C:=N}0; A1:=[HOLD1]; 09301000 + STREAM(A,S,JSIGN:=IF Q THEN 0 ELSE 1,NUMD:=ABS(N)-1, 09301005 + SAVSI:=0,HOLD:=[HOLD1]); 09301010 + BEGIN 09301012 + SI:=A; SI:=SI+S; SAVSI:=SI; 09301015 + SI:=SI+JSIGN; 09301020 + DI:=DI+JSIGN; 09301025 + DS:=NUMD NUM; 09301030 + JSIGN(SI:=SAVSI; DI:=HOLD;); 09301050 + DS:=CHR; 09301065 + END; 09301070 + A:=A1; S:=0; 09301075 + P(DIB 1); 09301080 + IF (N~ABS(N)){8 THEN 09301100 + BEGIN 09301200 + STREAM(C:S,A,N); BEGIN SI~A; SI~SI+S; DI~LOC C; DS~N OCT END ; 09301300 + IF NOT Q THEN GO D; N~P ; 09301400 + END 09301500 + ELSE BEGIN P(0) ; 09301600 + IF N>16 THEN 09301700 + BEGIN 09301800 + STREAM(S,Z~0,A:N~N-16,CA~[C]) ; 09301900 + BEGIN 09302000 + SI~A; SI~SI+S; DI~LOC A; DS~N OCT; DI~LOC S ; 09302100 + DS~8 OCT; DI~CA; DS~8 OCT ; 09302200 + END ; 09302300 + P(0,T8,DLM,DLA) ; 09302400 + B: P(0,T8,DLM,0,ABS(C),DLA) ; 09302500 + END 09302600 + ELSE BEGIN 09302700 + STREAM(S:A,N~N-8,CA~[C]) ; 09302800 + BEGIN 09302900 + SI~A; SI~SI+S; DI~LOC S; DS~N OCT; DI~CA; DS~8 OCT ; 09303000 + END ; 09303100 + IF P(DUP)>P(G) THEN GO B; P(T8,|,ABS(C),+) ; 09303200 + END ; 09303300 + IF C!0 AND Q THEN 09303400 + BEGIN 09303500 + P(C,DIA 1); GO E ; 09303600 + T8::: 100000000.0 ; 09303700 + G::: 5496.0 ; 09303800 + END ; 09303900 + IF Q THEN S~S+N-1 ; 09304000 + D: STREAM(S:A); BEGIN SI~A; SI~SI+S; S~TALLY; DI~LOC S; DI~DI+7; 09304100 + DS~ZON; END; 09304200 + P(P=@40,DIA 47) ; 09304300 + E: N~P(TRB 1) ; 09304400 + END ; 09304500 + S~P ; 09304600 + END OF COBOLDECIMALTOOCTALCONVERT ; 09304700 +PROCEDURE COBOLOCTOLTODECIMALCONVERT(A,L,H,S,N,R,T); % INTRINSIC # @152.09400000 +VALUE L,H,R,N,S,T; REAL L,H,R,N,S,T; NAME A ; 09400100 + % THIS PROCEDURL CONVERTS THE DOUBLE-LENGTH WORD (L,H) INTO A STRING09400200 + % OF N BCD DIGITS. THE STRING STARTS AT WORD ADDRESS A, 0HARACTER 09400300 + % OFFSET S. PRIOR TO THE CONVERSION, (L,H) IS SCALED-TO-THE-LEFT/RHT09400400 + % BY R DIGITS, I.E. (L,H) IS DIVIDED/MULTED BY 10*R. T IS A COMBINED09400500 + % TRUNCATION/J-SIGN TOGGLE: T.[2:1]=1 => PUT THE SIGN OF (L,H) IN 09400600 + % 1-ST CHR OF THE STRING; T.[1:1]=1 => PUT SIGN IN THE LAST CHR; 09400700 + % ABS(T).[47:1]=1 => TRUNCATE (L,H) BEFORE CONVERSION (AND AFTER 09400800 + % SCALING); ABS(T).[46:1]=1 => ROUND (L,H) BEFORE CONVERSION (AND 09400900 + % AFTER SCALING). NOTE THAT 0{S{7, 0{N{23. 09401000 + BEGIN 09401100 + INTEGER IR=R, IH=H, IL=L ; 09401200 + REAL B=17, SERR=19, WH=11, DMOD=21, Q=9 ; 09401300 + ARRAY TEN=23[*] ; 09401400 + LABEL HLF,T8,T16 ; 09401500 + IF R<0 THEN 09401600 + BEGIN 09401700 + STREAM(S,N,A); BEGIN DI~DI+S; N(DS~LIT"0") END ; 09401800 + N~N+R; R~0 ; 09401900 + END ; 09402000 + IF T.[1:2]=0 THEN H ~ ABS(H); 09402100 + IF H.[2:1] THEN P(0,H/TEN[R]) ELSE P(L,H,TEN[R+27],TEN[R],DLD) ; 09402200 + L~0 ; 09402300 + IF P(ABS(Q~P),DUP)TEN[23] THEN P(TEN[27+N],TEN[N],DMOD,B,XCH) ; 09402600 + IF P(DUP).[2:1] THEN 09402700 + BEGIN IF T THEN P(HLF,-); H~(IR~P) DIV P(T8) END 09402800 + ELSE BEGIN 09402900 + IF NOT T THEN P(0,HLF,DLA); H~P ; 09403000 + H~P(L~P,H,0,IL~P(L,H,0,T16,DLD,HLF,-),XCH,DEL,0,T16,DLM, 09403100 + DLS) ; 09403200 + IR~P(R~P,H,0,IH~P(R,H,0,T8,DLD,HLF,-),XCH,DEL,0,T8,DLM, 09403300 + DLS,HLF,-) ; 09403400 + END ; 09403500 + END ; 09403600 + IF N{8 THEN 09403700 + BEGIN P(L!0 OR H!0 OR R}TEN[N] OR N=0) ; 09403800 + STREAM(R,N,S,A); BEGIN DI~DI+S; SI~LOC R; DS~N DEC END ; 09403900 + END 09404000 + ELSE IF N{16 THEN 09404100 + BEGIN P(L!0 OR H}TEN[N-8]) ; 09404200 + STREAM(H,R,N~N-8,S,A) ; 09404300 + BEGIN DI~DI+S; SI~LOC H; DS~N DEC; DS~8 DEC END ; 09404400 + END 09404500 + ELSE BEGIN P(L}TEN[N-16]) ; 09404600 + STREAM(L,H,R,N~N-16,S,A) ; 09404700 + BEGIN DI~DI+S; SI~LOC L; DS~N DEC; DS~8DEC; DS~8DEC END09404800 + END ; 09404900 + IF P OR SERR THEN IF P(1,WH.[18:15],DUP)!0 THEN P(DIB 0,~) ; 09405000 + IF Q<0 THEN 09405100 + BEGIN 09405200 + IF T>0 THEN 09405300 + BEGIN 09405400 + STREAM(N~N-2,S,A) ; 09405500 + BEGIN 09405600 + DI~DI+S; DS~SET; DS~RESET; DI~DI+N; DS~RESET;DS~RESET09405700 + END ; 09405800 + P(XIT) ; 09405900 + HLF::: 0.499999999999 ; 09406000 + T16::: 10000000000000000.0 ; 09406100 + T8::: 100000000.0 ; 09406200 + END ; 09406300 + STREAM(S~S+N-1,A); BEGIN DI~DI+S; DS~SET; DS~RESET END ; 09406400 + END ; 09406500 + END OF COBOLOCTALTODECIMALCONVERT ; 09406600 +PROCEDURE COBOLVARSZ; 09500000 + BEGIN 09500100 + REAL 09500200 + TYPE = -1; % 0-2: EXAMINE 09500300 + % 0=REPLACING FIRST 09500400 + % 1=RFP/TALLY ALL, 09500500 + % 2=LEADING/UNTIL FIRST 09500600 + % 3: VARIABLE SIZE SMEAR 09500700 + % 4-9: VARIABLE SIZE RELATE 09500800 + % 4=<, 5=}, 6=>, 7={,8==,9=!09500900 + % 10: VARIABLE SIZE MOVE 09501000 + % 11: NEG ALPHA TEST 09501100 + % 12: POSITIVE ALPHA TEST 09501200 + ARRAY DESC = -2[*]; % RELATE: JUNKA DESCRIPIOR 09501300 + % MOVE,SMEAR: =0 09501400 + REAL CODE = -2, % EXAMINE:[47:1]=1 IF REP 09501500 + % [46:1]=1 IF TALLYING 09501600 + % [45:1]=1 IF REPLACING OR 09501700 + % TALLYING UNTIL FIRST 09501800 + DLENGTH = -3, % MOVE & RELATE: DEST LENGTH09501900 + % SMEAR: LENGTH TO SMEAR 09502000 + LNGTH = -3, % EXAMINE: LENGTH 09502100 + SLENGTH = -4, % SOURCE LENGTH (SMEAR: =0) 09502200 + RCHR = -4, % EXAMINE: 0HAR TO REPLACE 09502300 + DOFSET = -5, % MOVE,RELATE,SMEAR:DEST OFF09502400 + SCHR = -5, % EXAMINE: CHAR SOUGHT 09502500 + SMCHR = -6, % SMEAR: CHAR TO SMEAR 09502600 + % EXAMINE: MKS 09502700 + SOFSET = -6, % MOVE&RELATE: SOURCE OFFSET09502800 + OFFSET = -7; % EXAMINE: OFFSET 09502900 + ARRAY 09503000 + DEST = -7[*], % MOVE,RELATE,SMEAR:DESI 09503100 + SOURCE = -8[*]; % MOVE,RELATE,EXAMINE:SOURCE09503200 + REAL 09503300 + RELATE, 09503400 + DIFFER, 09503500 + NMOD64, 09503600 + SAVOFF, 09503700 + NDIV64, 09503800 + N, 09503900 + NWDS; 09504000 + ARRAY D[*]; 09504100 + DEFINE 09504200 + REPLACECHR = DI~DI-1; SI~LOC P6; SI~SI-1; DS~1 CHR#, 09504300 + LISTP1TOP6 = P1~NMOD64,P2~NDIV64,P3~(NDIV64 DIV 64), 09504400 + P4~SCHR,P5~RCHR,P6~OFFSET#; 09504500 + LABEL VARIEXAM,CMD,SMEAR;% 09504600 +%****************************** START HERE *****************************09504700 + IF TYPE{2 THEN GO TO VARIEXAM;% 09504800 + D ~ [DEST];% 09504900 + IF TYPE=3 THEN GO TO SMEAR;% 09505000 + IF (DIFFER ~ DLENGTH-SLENGTH)<0 THEN % VARIABLE MOVE ONLY 09505100 + IF TYPE=10 THEN% 09505200 + BEGIN% 09505300 + SLENGTH ~ DLENGTH; 09505400 + NMOD64 ~ SLENGTH.[42:6];% 09505500 + END; 09505600 + IF DIFFER!0 AND TYPE}4 AND TYPE{9 THEN % IF THERE IS A DIFFER-09505700 + BEGIN % THEN MOVE SHORTER TO JUNKA&FILL OUT WITH BLANKS 09505800 + IF DIFFER<0 THEN % INTERCHANGE TO MAKE OEST THE 09505900 + BEGIN % LONGER, SOURCE THE SHORTER 09506000 + D ~ [DEST]; DEST ~ [SOURCE]; SOURCE ~ [D]; 09506100 + SAVOFF ~ SOFSET; SOFSET ~ DOFSET; DOFSET~0;09506200 + NWDS~DLENGTH;DLENGTH~SLENGTH;SLENGTH~NWDS; 09506300 + DIFFER ~ ABS(DIFFER);% 09506350 + END ELSE% 09506400 + BEGIN% 09506500 + IF TYPE<8 THEN TYPE~TYPE-TYPE.[47:1]% 09506600 + +(TYPE.[47:1]=0);% 09506700 + SAVOFF ~ DOFSET;% 09506800 + DOFSET ~ 0;% 09506900 + END;% 09507000 + RELATE ~ TYPE; 09507100 + TYPE ~ 10; 09507200 + D ~ [DESC[0]];% 09507300 + END;% 09507400 + CMD: % TRANSFER OR COMPARE FIELDS 09507500 + IF TYPE!10 OR DIFFER}0 OR RELATE>0 THEN NMOD64~SLENGTH.[42:6]; 09507600 + NDIV64 ~ SLENGTH DIV 64;% 09507700 + IF TYPE<8 THEN% 09507800 + BEGIN% 09507900 + STREAM(P0~0:P1~NMOD64,P2~NDIV64,P2A~NDIV64!0,P3~(NDIV64 DIV 64)09508000 + ,P4~SOURCE,P5~SOFSET,P6~DOFSET,P7~TYPE}6,% 09508100 + P8~TYPE.[47:1],P9~D);% 09508200 + BEGIN 09508300 + SI ~ P4; SI ~ SI+P5; DI ~ DI+P6; 09508400 + CI ~ CI+P7; GO TO GREQ; GO TO GOLSQ;% 09508500 + GREQ: 09508600 + P3(63(P0~SI;P9~DI;IF 63SC=DC THEN ELSE% 09508700 + BEGIN SI~P0;DI~P9;IF 63 SC>DC THEN;% 09508800 + JUMP OUT 2 TO XYT1;% 09508900 + END);% 09509000 + 2(P0~SI;P9~DI;IF 63SC=DC THEN ELSE% 09509100 + BEGIN SI~P0;DI~P9;IF 63 SC>DC THEN;% 09509200 + JUMP OUT 2 TO XYT1;% 09509300 + END);% 09509400 + IF SC=DC THEN ELSE% 09509500 + BEGIN SI~SI-1;DI~DI-1;IF SC>DC THEN;% 09509600 + JUMP OUT 1 XYT1;% 09509700 + END); GO TO L1;% 09509800 + XYT1: GO TO XYT2;% 09509900 + GOLSQ:GO TO LSEQ;% 09510000 + L1: P2 (P0~SI;P9~DI;IF 63SC=DC THEN ELSE% 09510100 + BEGIN SI~P0;DI~P9;IF 63 SC>DC THEN; 09510200 + JUMP OUT 1 TO XYT2;% 09510300 + END);% 09510400 + P2A (P0~SI;P9~DI;IF P2 SC=DC THEN ELSE% 09510500 + BEGIN SI~P0;DI~P9;IF P2 SC>DC THEN;% 09510600 + JUMP OUT 1 TO XYT2;% 09510700 + END);% 09510800 + IF P1 SC}DC THEN;% 09510900 + XYT2: GO TO XYT3;% 09511000 + LSEQ: 09511100 + P3(63(P0~SI;P9~DI;IF 63SC=DC THEN ELSE% 09511200 + BEGIN SI~P0;DI~P9;IF 63 SC10),% 09514100 + P8~TYPE.[47:1],P9~D);% 09514200 + BEGIN% 09514300 + SI ~ P4; SI ~ SI+P5; DI ~ DI+P6; 09514400 + CI ~ CI+P7; GO TO EQUL; GO TO TRFR; GO TO GOTAN;% 09514500 + EQUL:% 09514600 + P3( 63(IF 63 SC=DC THEN ELSE JUMP OUT 2 TO XYT1);% 09514700 + 2(IF 63 SC=DC THEN ELSE JUMP OUT 2 TO XYT1);% 09514800 + IF 1 SC=DC THEN ELSE JUMP OUT 1 TO XYT1); GO TO L;% 09514900 + GOTAN: GO TO TANL;% 09515000 + L: P2(IF 63 SC=DC THEN ELSE JUMP OUT 1 TO XYT1);% 09515100 + P2A(IF P2 SC=DC THEN ELSE JUMP OUT 1 TO XYT1);% 09515200 + IF P1 SC=DC THEN; GO TO XYT1;% 09515300 + TRFR:% 09515400 + P3(63(DS~63 CHR); 2(DS~63 CHR); DS~CHR);% MOVE 64|64 09515500 + P2(DS ~ 63 CHR); DS ~ P2 CHR; DS ~ P1 CHR; GO TO DONE1;% 09515600 + XYT1: GO TO XYT2;% 09515700 + TANL:% 09515800 + P3(63(63(IF SC=ALPHA THEN IF SC{"Z" THEN SI~SI+1 ELSE% 09515900 + JUMP OUT 3 TO XYT2 ELSE JUMP OUT 3 TO XYT2));% 09516000 + 2(63(IF SC=ALPHA THEN IF SC{"Z" THEN SI~SI+1 ELSE% 09516100 + JUMP OUT 3 TO XYI2 ELSE JUMP OUT 3 TO XYI2));% 09516200 + IF SC=ALPHA THEN IF SC{"Z" THEN SI~SI+1 ELSE% 09516300 + JUMP OUT 1 TO XYT2 ELSE JUMP OUT 1 TO XYT2);% 09516400 + GO TO L1; 09516500 + XYT2: GO TO XYT; 09516600 + DONE1: GO TO DONE; 09516700 + L1: P2(63(IF SC=ALPHA THEN IF SC{"Z" THEN SI~SI+1 ELSE% 09516800 + JUMP OUT 2 TO XYT ELSE JUMP OUT 2 TO XYT));% 09516900 + P2(IF SC=ALPHA THEN IF SC{"Z" THEN SI~SI+1 ELSE% 09517000 + JUMP OUT 1 TO XYT ELSE JUMP OUT 1 TO XYT);% 09517100 + P1(IF SC=ALPHA THEN IF SC{"Z" THEN SI~SI+1 ELSE% 09517200 + JUMP OUT 1 TO XYT ELSE JUMP OUT 1 TO XYT);% 09517300 + XYT: P8(IF TOGGLE THEN ELSE TALLY~1; JUMP OUT 1 TO STOR);% 09517400 + IF TOGGLE THEN TALLY~1;% 09517500 + STOR: P0~TALLY;% 09517600 + DONE:% 09517700 + END STREAM;% 09517800 + END;% 09517900 + IF TYPE!10 THEN P(RTN);% 09518000 + IF DIFFER>0 THEN 09518100 + BEGIN % FILL OUT DEST WITH BLANKS TO MAKE UP DIFF09518200 + P(SLENGTH+DOFSET,DUP,8,IDV,*P(.D),INX,.D,~,7,LND,.DOFSET,~); 09518300 + SMEAR::NDIV64 ~(NWDS~(((DIFFER~(DLENGTH-SLENGTH)-% 09518500 + (N~(8-DOFSET).[45:3])) DIV 8) - (DIFFER}8))) DIV 64;% 09518600 + STREAM(P1~DIFFER.[45:3],P2~DOFSET,P3~8|(DIFFER}8)+N,P4~NWDS, 09518700 + P4A~NWDS!0,P5~NDIV64,P5A~NDIV64!0,P6~SMCHR,P7~(TYPE=3 09518800 + AND SMCHR!" "),P8~D);% 09518850 + BEGIN 09518900 + DI ~ DI+P2; P8~DI; P7(SI~LOC P7; SI~SI-1);% 09519000 + CI~CI+P7; GO TO BLNK; GO TO SMR;% 09519100 + BLNK:P3(DS ~ LIT " "); GO TO CONT;% 09519200 + SMR: P3(DS ~ 1 CHR; SI~SI-1);% 09519300 + CONT:SI ~ P8; P5(DS ~ 63 WDS); P5A(DS ~ P5 WDS);% 09519400 + P4A(DS ~ P4 WDS);% 09519450 + CI~CI+P7; GO TO FINB; GO TO FINS;% 09519500 + FINB:P1(DS ~ LIT " "); GO TO XYT;% 09519600 + FINS:P1(DS ~ 1 CHR; SI~SI-1);% 09519700 + XYT:% 09519800 + END STREAM; 09519900 + END;% 09520000 + IF RELATE>0 THEN % BLANK FILL DONE 09520100 + BEGIN % GO BACK AND DO COMPARE 09520200 + SOFSET ~ SAVOFF;% 09520300 + SOURCE ~ [DEST];% 09520400 + SLENGTH ~ DLENGTH;% 09520500 + TYPE ~ RELATE;% 09520600 + DOFSET ~ 0;% 09520650 + D ~ [DESC];% 09520660 + GO TO CMD;% 09520700 + END;% 09520800 + P(XIT); 09520900 + VARIEXAM::% 09521000 + NMOD64 ~ LNGTH.[42:6];% 09521100 + NDIV64 ~ LNGTH DIV 64;% 09521200 + IF TYPE=0 THEN 09521300 + BEGIN % REPLACING FIRST 09521400 + STREAM(LISTP1TOP6,P7~SOURCE);% 09521500 + BEGIN 09521600 + DI~DI+P6; SI~LOC P5; SI~SI-1; 09521700 + P3(63(63(IF SC=DC THEN JUMP OUT 3 TO REP; SI~SI-1));% 09521800 + 2(63(IF SC=DC THEN JUMP OUT 3 TO REP; SI~SI-1));% 09521900 + IF SC=DC THEN JUMP OUT 1 TO REP; SI~SI-1; );% 09522000 + P2(63(IF SC=DC THEN JUMP OUT 2 TO REP; SI~SI-1));% 09522100 + P2(IF SC=DC THEN JUMP OUT 1 TO REP; SI~SI-1);% 09522200 + P1(IF SC=DC THEN JUMP OUT 1 TO REP; SI~SI-1);% 09522300 + GO TO XYT; 09522400 + REP: REPLACECHR; 09522500 + XYT: 09522600 + END STREAM; 09522700 + END ELSE IF TYPE=1 THEN 09522800 + BEGIN % REP AND/OR TALLYING ALL 09522900 + STREAM(P0~0:LISTP1TOP6,P7~3-CODE)"0=REP&TALLY,1=TALLY ONLY, 09523000 + 2=REP ONLY"(P8~SOURCE);% 09523100 + BEGIN 09523200 + DI~DI+P6; SI~LOC P5; SI~SI-1;% 09523300 + P3(63(63(IF 1 SC=DC THEN% 09523400 + BEGIN CI~CI+P7; GO TO TALL1; GO TO TALL1; GO TO REP1;09523500 + TALL1: SI~P0; SI~SI+8; P0~SI; SI~LOC P5;% 09523600 + CI~CI+P7; GO TO REP1; GO TO NXT1;% 09523700 + REP1: REPLACECHR; SI~LOC P5;% 09523800 + END;% 09523900 + NXT1: SI~SI-1;)));% 09524000 + P3( 2(63(IF 1 SC=DC THEN% 09524100 + BEGIN CI~CI+P7; GO TO TALL2; GO TO TALL2; GO TO REP2;09524200 + TALL2: SI~P0; SI~SI+8; P0~SI; SI~LOC P5;% 09524300 + CI~CI+P7; GO TO REP2; GO TO NXT2;% 09524400 + REP2: REPLACECHR; SI~LOC P5;% 09524500 + END;% 09524600 + NXT2: SI~SI-1;)));% 09524700 + P3( IF 1 SC=DC THEN% 09524800 + BEGIN CI~CI+P7; GO TO TALL3; GO TO TALL3; GO TO REP3;09524900 + TALL3: SI~P0; SI~SI+8; P0~SI; SI~LOC P5;% 09525000 + CI~CI+P7; GO TO REP3; GO TO NXT3;% 09525100 + REP3: REPLACECHR; SI~LOC P5;% 09525200 + END;% 09525300 + NXT3: SI~SI-1;);% 09525400 + P2(63(IF 1 SC=DC THEN% 09525500 + BEGIN CI~CI+P7; GO TO TALL4; GO TO TALL4; GO TO REP4;09525600 + TALL4: SI~P0; SI~SI+8; P0~SI; SI~LOC P5;% 09525700 + CI~CI+P7; GO TO REP4; GO TO NXT4;% 09525800 + REP4: REPLACECHR; SI~LOC P5;% 09525900 + END;% 09526000 + NXT4: SI~SI-1;));% 09526100 + P2(IF 1 SC=DC THEN% 09526200 + BEGIN CI~CI+P7; GO TO TALL5; GO TO TALL5; GO TO REP5;09526300 + TALL5: SI~P0; SI~SI+8; P0~SI; SI~LOC P5;% 09526400 + CI~CI+P7; GO TO REP5; GO TO NXT5;% 09526500 + REP5: REPLACECHR; SI~LOC P5;% 09526600 + END;% 09526700 + NXT5: SI~SI-1;);% 09526800 + P1(IF 1 SC=DC THEN% 09526900 + BEGIN CI~CI+P7; GO TO TALL6; GO TO IALL6; GO TO REP6;09527000 + TALL6: SI~P0; SI~SI+8; P0~SI; SI~LOC P5;% 09527100 + CI~CI+P7; GO TO REP6; GO TO NXT6;% 09527200 + REP6: REPLACECHR; SI~LOC P5;% 09527300 + END;% 09527400 + NXT6: SI~SI-1;);% 09527500 + END STREAM; 09527600 + END ELSE 09527700 + BEGIN %REP/TALLY UNTIL 1ST/LEADING09527800 + STREAM(P0~0:LISTP1TOP6,P7~3-CODE.[46:2],P8~CODE.[45:1],% 09527900 + P9~SOURCE);% 09528000 + BEGIN 09528100 + DI~DI+P6; SI~LOC P5; SI~SI-1;% 09528200 + P3(63(63(CI~CI+P8; GO TO REPL1; GO TO REPUF1;% 09528300 + REPL1: IF 1SC!DC THEN JUMP OUT 3 TO XYT1;GO TO DOIT1;09528400 + REPUF1: IF 1SC=DC THEN JUMP OUT 3 TO XYT1;% 09528500 + DOIT1: CI~CI+P7; GO TO TALL1; GO TO TALL1;GO TO REP1;09528600 + TALL1: SI~P0; SI~SI+8; P0~SI; SI~LOC P5;% 09528700 + CI~CI+P7; GO TO REP1; GO TO NXT1;% 09528800 + REP1: REPLACECHR; SI~LOC P5;% 09528900 + NXT1: SI~SI-1 ))); GO TO L2; XYT1: GO TO XYT2; 09529000 + L2: P3( 2(63(CI~CI+P8; GO TO REPL2; GO TO REPUF2;% 09529100 + REPL2: IF 1SC!DC THEN JUMP OUT 3 TO XYT2;GO TO DOIT2;09529200 + REPUF2:IF 1SC=DC THEN JUMP OUT 3 TO XYT2;% 09529300 + DOIT2: CI~CI+P7; GO TO TALL2; GO TO TALL2;GO TO REP2;09529400 + TALL2: SI~P0; SI~SI+8; P0~SI; SI~LOC P5;% 09529500 + CI~CI+P7; GO TO REP2; GO TO NXT2;% 09529600 + REP2: REPLACECHR; SI~LOC P5;% 09529700 + NXT2: SI~SI-1 ))); GO TO L3; XYT2: GO TO XYI3; 09529800 + L3: P3( CI~CI+P8; GO TO REPL3; GO TO REPUF3;% 09529900 + REPL3: IF 1SC!DC THEN JUMP OUT 1 TO XYT3;GO TO DOIT3;09530000 + REPUF3:IF 1SC=DC THEN JUMP OUT 1 TO XYT3;% 09530100 + DOIT3: CI~CI+P7; GO TO TALL3; GO TO TALL3;GO TO REP3;09530200 + TALL3: SI~P0; SI~SI+8; P0~SI; SI~LOC P5;% 09530300 + CI~CI+P7; GO TO REP3; GO TO NXT3;% 09530400 + REP3: REPLACECHR; SI~LOC P5;% 09530500 + NXT3: SI~SI-1 ); GO TO L4; XYT3: GO TO XYT4; 09530600 + L4: P2(63(CI~CI+P8; GO TO REPL4; GO TO REPUF4;% 09530700 + REPL4: IF 1SC!DC THEN JUMP OUT 2 TO XYT4;GO TO DOIT4;09530800 + REPUF4:IF 1SC=DC THEN JUMP OUT 2 TO XYT4;% 09530900 + DOIT4: CI~CI+P7; GO TO TALL4; GO TO IALL4;GO TO REP4;09531000 + TALL4: SI~P0; SI~SI+8; P0~SI; SI~LOC P5;% 09531100 + CI~CI+P7; GO TO REP4; GO TO NXT4;% 09531200 + REP4: REPLACECHR; SI~LOC P5;% 09531300 + NXT4: SI~SI-1 )); GO TO L5; XYT4: GO TO XYT5; 09531400 + L5: P2(CI~CI+P8; GO TO REPL5; GO TO REPUF5;% 09531500 + REPL5: IF 1SC!DC THEN JUMP OUT 1 TO XYT5;GO TO DOIT5;09531600 + REPUF5:IF 1SC=DC THEN JUMP OUT 1 TO XYT5;% 09531700 + DOIT5: CI~CI+P7; GO TO TALL5; GO TO TALL5;GO TO REP5;09531800 + TALL5: SI~P0; SI~SI+8; P0~SI; SI~LOC P5;% 09531900 + CI~CI+P7; GO TO REP5; GO TO NXT5;% 09532000 + REP5: REPLACECHR; SI~LOC P5;% 09532100 + NXT5: SI~SI-1 ); GO TO L6; XYT5: GO TO XYT; 09532200 + L6: P1(CI~CI+P8; GO TO REPL6; GO TO REPUF6;% 09532300 + REPL6: IF 1SC!DC THEN JUMP OUT 1 TO XYT; GO TO DOIT6;09532400 + REPUF6:IF 1SC=DC THEN JUMP OUT 1 TO XYT;% 09532500 + DOIT6: CI~CI+P7; GO TO TALL6; GO TO TALL6;GO TO REP6;09532600 + TALL6: SI~P0; SI~SI+8; P0~SI; SI~LOC P5;% 09532700 + CI~CI+P7; GO TO REP6; GO TO NXT6;% 09532800 + REP6: REPLACECHR; SI~LOC P5;% 09532900 + NXT6: SI~SI-1 );% 09533000 + XYT:% 09533100 + END STREAM;% 09533200 + END;% 09533300 + IF CODE.[46:1] THEN P(RTN);% 09533400 + END COBOLVARSZ;% 09533500 +PROCEDURE COBOLIONONDSK; % PRONOUNCED COBOL-IO-NON-DISK 09600000 + BEGIN 09600100 + REAL CODE = -1; % 0=READ,1=WRITE,6=WRTBLK 09600200 + NAME DLOC = -2; % POINTS TO BUFFER IO DESCRIPTOR 09600300 + REAL NUMWDS = -3, % # WDS TO BE WRITTEN 09600400 + KEY = -4, % CARRIAGE RETURN 09600500 + CHNNL = -4, % LP CHANNEL SKIP 09600600 + LINES = -5, % # LINES TO BE SPACED 09600700 + SKIPBFR = -6; % 1=SPACE BEFORE PRINT 09600800 +INTEGER 09600900 + LINAGE = -7; % LINE PRINTER: [1:1]=1 IF LINAGE 09601000 + % CLAUSE PRESENT,[33:15]= LINAGE LIMIT09601100 + % ON NEXT END-OF-PAGE 09601200 +%LOCALS 09601300 + REAL IOMASK; 09601400 + ARRAY FIB [*]; % FIB ARRAY 09601500 + REAL FILECTRL = 12, % USED TO CALL COBOLFCR 09601600 + PERFORMGEN= 13, % USED FOR PERFORMING USE ROUTINES 09601700 + COBOLIODSK= 15; 09601800 + NAME FLOC; % POINTER TO FIB 09601900 + ARRAY FPB = 3[*]; % FILE PARAMETER BLOCK 09602000 + NAME MEM = 2; % DUMMY DATA DESC 09602100 + ARRAY PGUSE = 24[*]; % PROGRAM USE ROUTINES 09602200 + REAL 09602300 + T,RT, % TEMPORARY 09602400 + TCW, % TECH C: NUMBER WORDS TO BE READ 09602500 + TCDIF, % TECH C: (ACTUAL RECORD - MIN REC) 09602600 + UNITYPE, % STORE UNIT TYPE FOR MANY TESTS 09602700 + ENDREEL; % USED ONLY ON READ 09602800 + ARRAY DEST[*]; % DESTINATION IN MOVEREC 09602900 +DEFINE 09603000 + AF = [12:12]#, % FILE USE ROUTINE 09603100 + ARR = [36:12]#, % REEL USE ROUTINE 09603200 + ARROW = P(0,NOT,(BUFFSIZE-WORDSLEFT),TIP,INX,STD)#, 09603300 + % THIS INSERTS THE GROUP MARK 09603400 + BCOUNT = FIB[6]#, % BLOCK COUNT 09603500 + BINARY = FIB[13].[24:1]#, % 1=BINARY,0=ALPHA 09603600 + BF = [1:11]#, % FILE USE ROUTINE 09603700 + BREAK = FIB[9] ! 0 # , % BREAKOUT RESTART POINT 09603800 + BREAKOUT = IF(RCOUNT MOD FIB[9])=0 THEN 09603900 + P(0,0,12,COM,DEL,DEL)#,% CALL BREAKOUT 09604000 + BRR = [24:12]#, % REEL USE ROUTINE 09604100 + BUFFNUM = FIB[13].[1:9] #, % # OF BUFFS REQUSTED 09604200 + BUFFSIZE = FIB[18].[3:15]#, % BUFFER SIZE (REQUESTED) 09604300 + BUFFSZ = FIB[18][8:8:10]#, % SIZE FOR CONCATINATES 09604400 + BUFTOP = FIB[16]#,% COPY OF TOP IOD: POINTS TO BEG BUFF09604500 + CHECK(CHECK1) = IF P(DUP)!(CHECK1) THEN P(CHECK1,0,FLOC,#, 09604600 + ONERR(ONERR1) = ONERR1,17,COM,DEL,DEL,DEL,DEL); P(DEL)#, 09604700 + % THE ABOVE ARE USED ON BLOCK+REC CHKS09604800 + CLOSEANDOPEN =P(MKS,1,0,FLOC,4,FILECTRL, %CLOSE NO RWD 09604900 + MKS,FLOC,1,FILECTRL)#, % OPEN INPUT 09605000 + COUNT = FIB[12] #, % USED FOR BLOCKING TECH-A,B09605100 + DELAY = TIP.[20:1] #, % THIS ALLOWS ONE CYCLE DELY09605200 + DISK = (UNITYPE~(FIB[4].[8:4]))=4#, 09605300 + DONE = TIP.[19:1] #, % 1= IO COMPLETED 09605400 + ENDFILE = FIB[5].[40:1] #, % ALREADY PASSED EOF 09605500 + ENDPROCESS = FIB[5].[39:2]#, % SEE OPTIONAL AND ENDFILE 09605600 + EOF =((*DLOC).[27:1])#, % FIRST EOF OR EOT 09605700 + FNAM = FIB[4].[13:11]#, % FILE NAME INDEX IN FPB 09605800 + FOREVER =(NOT 0).[9:39] #, % UNTIL END TIME 09605900 + HOWOPEN = FIB[5].[41:3]#, % 1=OPEN INPUT,0= OPEN OUTPT09606000 + % 1 > CLOSED 09606100 + INFILE = FIB[13].[27:1]#, % FILE OPEN INPUT 09606200 + INVALIDUSER = FIB[5]<0#, % INVALID USER NOT PARITY 09606300 + INXLINAGE = P(LOCOFCTR,DUP,LOD,LINES,ADD,XCH,~)#, 09606400 + IOERR(IOERR1) = P(0,FLOC,IOERR1,17,COM,DEL,DEL,DEL)#, 09606500 + % ABOVE CALLS IOERROR ROUTINE 09606600 + LABELED = NOT FIB[4].[2:1]#, 09606700 + LABE0 = FIB[5].[17:1] #, % LABEL EQUATED FROM DISK 09606800 + LBLPTR = FLOC[1] #, % LABEL POINTER 09606900 + LINAGELIM = FIB[1]#, % LOGICAL LENGTH OF PRINTED PAGE 09607000 + LINEPRINT = FIB[20] #, % CF=1 IS PRINTFILE 09607100 + LINTOG = LINAGE.[1:1]#, % TRUE IF LINAGE PRESENT 09607300 + LOCOFCTR = FIB[3]#, % PRT LOC OF LINAGE COUNTER09607400 + MABUSE = FIB[4].[1:1]#, % MAY BE USE RTNS PRESENT 09607500 + MAXR = FIB[18][8:38:10]#,% MAX REC SZ FOR CONCATS 09607600 + MAXREC = FIB[18].[33:15]#, % MAX REC SZ 09607700 + MINREC = FIB[18].[FF] #, % MINIMUM RECORD SIZE 09607800 + NONSTD = FIB [5].[16: 1]#, % NON-STANDARD LABELS 09607900 + NUMBUF = FIB[13].[10: 9]#, % NUMBER OF BUFFERS ASSIGNED09608000 + NUMREC = FIB[11] #, % RECORDS PER BLOCK 09608100 + NXTLINAGE = LINAGE.[33:15]#, % PRINTER: LINAGE LIMIT 09608200 + NXTREEL = P(MKS,2,1,FLOC,4, % THIS DOES REEL SWITCHING 09608300 + FILECTRL)#, % 09608400 + OPTIONAL = FIB[ 5].[39:1]#, % OPTIONAL FILE NOT PRESENT 09608500 + PARITY = TIP.[28:1]#, % PARITY BIT ON DESC 09608600 + PBIT = [2:1]#, % PRESENCE BIT 09608700 + PRESENT =((*DLOC).[2:1])#, % CHECKS PRESENTSBIT 09608800 + PROPER =P(CODE,P(DUP),+,P(DUP)=12,+,REVERSE,+,21,+) #, 09608900 + % GENERATES PROPER IOERROR 09608910 + PUNCH = UNITYPE=6#, % UNIT IS CARD PUNCH 09609000 + RCOUNT = FIB[7] #, % RECORD COUNT 09609100 + RCPRT = (FIB[20].[FF])#, %PRT OF DESC POINTING TO REC09609200 + READER =(UNITYPE MOD 11=0)#,% 0=READER 11=PSUDOREADER 09609300 + READLBL =P(DLOC INX 0,11,11 % THIS READS THE LABEL. 09609400 + ,COM,DEL,DEL)#, % 09609500 + RECPERBLK = H[0].[30:12] #, % RECORDS PER BLOCK 09609600 + $ SET OMIT = TIMESHARING 09609690 + REMOTEUNIT =10#, % DATACOM IS TYPE 14 ON TSS 09610100 + REMOTEREAD =BEGIN P(BUFFSIZE,TIP,1,(-13),COM); 09610200 + P(TIP); MOVEREC; 09610220 + P([DLOC[0]],:=,1,SUB,RTN); 09610240 + END#, 09610260 + REMOTEWRIT =BEGIN P(TIP); MOVEREC; 09610300 + P([DLOC[0]],STN); % RESTORE TIP 09610320 + P(NUMWDS|8,LINES&KEY[CTF],0,(-11),COM, 09610340 + DEL,RTN); 09610360 + END#, 09610380 + $ POP OMIT OMIT 09610390 + REVERSE = FIB[5].[44:1] #, % 1=REVERSE 09610400 + SETPRESENCEBIT =P(TIP OR MEM ,DLOC,~)#,% SET PRESENCE BIT 09610500 + $ SET OMIT = NOT(TIMESHARING) 09610600 + SLEEP = 36 #, 09610700 + $ POP OMIT 09610701 + $ SET OMIT = TIMESHARING 09610800 + TAPEE = TIP.[7:1] #, % 1= TAPES 0=ALL ELSE 09611000 + TECHA =(FIB[5].[46:2]=1) #,% TECHNIQUL-A 09611100 + TECHC =(FIB[5].[46:2]=3) #,% TECHNIQUE-C 09611200 + TERM(TERM1) = P(1,FLOC,TERM1,17,COM)#,%TERMINATE I/O ERROR 09611300 + TIP = (*DLOC) #, % LOAD I/O DESC 09611400 + TOSZF = [8:38:10]#, 09611500 + UNBLKD = (FIB[5].[46:2]=0)#, % 1 RECORD PER BLOCK 09611600 + WAITIO = P(DLOC,IOMASK, % THIS SLEEPS ON I/O 09611700 + SLEEP,COM,DEL,DEL)#,% WAITING FOR A COMPLETE 09611800 + WRITEPARITY = FIB[5].[3:1]#, % INDICATES FORCED REELSWITCH09611810 + WORDSLEFT = FIB[17]#; % WORDS LEFT IN BUFFER 09611900 +LABEL LPRETURN,START,IMPROPER,ROVER,EOFSETCK; 09612000 +SUBROUTINE GOUSE; % CALLS USE ROUTINES 09612100 + BEGIN P(MKS,[FIB],T,0,PERFORMGEN); END;% 09612200 +SUBROUTINE INPUTPARITY;% 09612300 + BEGIN% 09612400 + IF (T ~ RT ~ PGUSE[4].BRR)!0 THEN GOUSE; % INPUT ERROR USE RTN 09612600 + IF (T ~ FIB[15].BF) ! 0 THEN GOUSE; 09612700 + IF NOT PRESENT THEN IF NOT (T OR RT) THEN 09612800 + IOERR(19 + 10 | REVERSE); 09612850 + SETPRESENCEBIT; 09612900 + END INPUTPARITY;% 09613000 +SUBROUTINE OUTPUTERROR;% 09613100 + BEGIN% 09613200 + IF NOT EOF THEN % TAPE WRITE PARITY OR BLANK TAPE 09613300 + BEGIN % OUTPUT ERROR USE ROUTINES 09613400 + IF (T ~ PGUSE[5].BRR)!0 THEN GOUSE;% 09613500 + IF (T ~ FIB[15].BF) ! 0 THEN GOUSE; 09613600 + TERM(20);% 09613700 + END;% 09613800 + SETPRESENCEBIT;% 09613900 + NXTREEL; % REEL SWITCH 09614000 + END OUTPUTERROR;% 09614100 +SUBROUTINE INPUTEOFEOR; 09614200 + BEGIN % EOF OR EOR 09614300 + ENDFILE ~ TRUE;% 09614400 + SETPRESENCEBIT;% 09614500 + IF READER OR REVERSE THEN P(1,RTN);% 09614600 + IF LABELED THEN% 09614700 + BEGIN% 09614800 + READLBL;% 09614900 + STREAM(SENT~0,BC~0,RC~0,WP~0:L~5 INX LBLPTR);09615000 + BEGIN % THIS RETREIVES END OF REEL09615100 + DI~LOC SENT; % SENTINEL,BLOCK & REC COUNT09615200 + DI~DI+7; SI~L; SI~SI-1;% 09615300 + DS~CHR; DS~5 OCT; DS~7 OCT;% 09615400 + DI~DI+7; DS~ CHR; 09615410 + END;% 09615500 + IF P=1 THEN WRITEPARITY ~ TRUE; 09615510 + CHECK(RCOUNT) ONERR(16); 09615600 + CHECK(BCOUNT) ONERR(17); 09615700 + ENDREEL ~ P; % STORE SENTINEL 09615800 + IF MABUSE THEN% 09615900 + IF NOT WRITEPARITY THEN 09615950 + BEGIN % END INPUT REEL USE RTNS 09616000 + IF (T~PGUSE[1].BRR)!0 THEN GOUSE;% 09616100 + IF (T~PGUSE[1].ARR)!0 THEN GOUSE;% 09616200 + IF NOT ENDREEL THEN% 09616300 + BEGIN % END INPUT FILE USE RINS 09616400 + IF (T~PGUSE[1].BF)!0 THEN GOUSE; 09616500 + IF (T~PGUSE[1].AF)!0 THEN GOUSE; 09616600 + END;% 09616700 + IF (T~FIB[2].BRR)!0 THEN GOUSE; % END 09616800 + IF (T~FIB[2].ARR)!0 THEN GOUSE; % REEL09616900 + IF NOT ENDREEL THEN% 09617000 + BEGIN % END FILE USE ROUTINES% 09617100 + IF (T~FIB[2].BF)!0 THEN GOUSE;% 09617200 + IF (T~FIB[2].AF)!0 THEN GOUSE;% 09617300 + END;% 09617400 + END USE;% 09617500 + END LABELED;% 09617600 + IF LABELED AND NOT ENDREEL THEN P(1,RTN);% 09617700 + IF NONSTD THEN% 09617800 + BEGIN% 09617900 + ENDFILE ~ FALSE;% 09618000 + CLOSEANDOPEN;% 09618100 + P(1,RTN);% 09618200 + END;% 09618300 + NXTREEL;% 09618600 + P(DEL,DEL); % DELETE BRANCH RETURNS 09618700 + WRITEPARITY ~ FALSE; 09618710 + IF TECHC THEN P(.TCW,LOD,.NUMWDS,STD); 09618750 + GO TO START;% 09618800 + END INPUTEOFEOR; 09618900 +SUBROUTINE MOVEREC; % MOVES RECORD BETWEEN WORK AREA AND BUFFER 09619000 + BEGIN% 09619100 + IF NOT DONE THEN WAITIO;% 09619200 + P(*RCPRT,TIP INX 0); 09619300 + IF NOT PRESENT THEN % MAY BE ERROR OR EOF 09619400 + IF CODE THEN 09619500 + IF EOF THEN BEGIN OUTPUTERROR; P(DEL,TIP INX 0); END 09619600 + ELSE P(XCH,P(DUP).[8:10],.NUMWDS,ISD) 09619700 + ELSE IF EOF THEN INPUTEOFEOR; 09619800 + DEST ~ IF CODE THEN P ELSE P(XCH);% 09619900 + STREAM(FROM~P:NUMWDS,E~P(DUP).[36:6],X~DEST);% 09620000 + BEGIN% 09620100 + SI~FROM;E(DS~32 WDS;DS~32 WDS); DS~NUMWDS WDS;% 09620200 + END;% 09620300 + P(DEL);% 09620400 + WORDSLEFT ~ *P(DUP) - NUMWDS; 09620500 + DLOC[0] ~ (IF REVERSE THEN NOT(NUMWDS-1) ELSE NUMWDS) INX TIP; 09620600 + RCOUNT ~ *P(DUP) + 1; 09620700 + IF CODE THEN % CHECK FOR 09620800 + IF NOT PRESENT THEN OUTPUTERROR % OUTPUT PARITY ERROR 09620900 + ELSE ELSE 09621000 + IF NOT PRESENT THEN INPUTPARITY; % INPUT PARITY 09621100 + IF BREAK THEN BREAKOUT; 09621200 + END MOVERECORDTOANDFROMWORKAREA; 09621300 +SUBROUTINE PREL; % DOES ACTUAL I/O 09621700 + BEGIN% 09621800 + P(TIP,DLOC,PRL,DEL); % DO IO 09621900 + BCOUNT ~ *P(DUP) + 1; % UP BLOCK COUNT 09622100 + END PREL;% 09622300 +SUBROUTINE SKIPPER; % DOES SPACING ON PRINTER 09622400 + BEGIN 09622500 + WHILE LINES > 0 DO 09622600 + BEGIN 09622700 + IF NOT DONE THEN WAITIO; 09622800 + IF NOT PRESENT THEN OUTPUTERROR; 09622900 + DLOC[0] ~ TIP & 1[18:47:1] & 16[27:42:6]; 09623000 + IF LINES = 1 THEN 09623100 + DLOC[0] ~ TIP & 2[27:46:2]; 09623200 + PREL; 09623300 + LINES ~ LINES - 2; 09623400 + END; 09623500 + END SKIPPINGALLTHOSELINES; 09623600 +SUBROUTINE GOLP; % MAKES THY PRYNTER GO 09624600 + BEGIN 09624700 + IF LINTOG THEN INXLINAGE; 09624800 + IF NUMWDS > 17 THEN NUMWDS ~ 17; 09624810 + IF MAXREC > 17 THEN MAXREC ~ 17; 09624820 + RT ~ BUFFSIZE - WORDSLEFT; % !0 MEANS DATA PRESENT 09624900 + IF NOT UNBLKD THEN 09625000 + BEGIN 09625100 + IF TECHC THEN 09625200 + BEGIN 09625300 + IF NUMWDS > MAXREC THEN NUMWDS ~ MAXREC; 09625400 + IF NUMWDS { 0 THEN TERM(36); 09625500 + END; 09625600 + IF NUMWDS > WORDSLEFT THEN SKIPBFR ~ TRUE 09625700 + ELSE BEGIN MOVEREC; GO LPRETURN; END; 09625800 + END; 09625900 + IF CHNNL ! 0 THEN LINES ~ 0; 09626000 + IF SKIPBFR THEN 09626100 + BEGIN 09626200 + IF NOT DONE THEN WAITIO; 09626300 + IF NOT PRESENT THEN OUTPUTERROR; 09626400 + DLOC[0] ~ FLAG(BUFTOP & (RT = 0) [18:47:1] 09626500 + &RT TOSZF 09626550 + &(LINES>0)[27:46:2] & CHNNL[29:44:4]);09626600 + IF LINES = 1 THEN DLOC[0]~TIP & 2[27:46:2]; 09626700 + PREL; 09626800 + WORDSLEFT ~ BUFFSIZE; 09626850 + IF (LINES ~ LINES - 2) > 0 THEN SKIPPER; 09626900 + IF UNITYPE=12 THEN IF NOT DONE THEN WAITIO; 09627000 + BUFTOP.[CF] ~ TIP; 09627100 + MOVEREC; 09627200 + END ELSE 09627300 + BEGIN 09627400 + IF RT ! 0 THEN 09627500 + BEGIN 09627600 + DLOC[0] ~ FLAG(BUFTOP & 0[27:42:6] 09627700 + & RT TOSZF); 09627750 + PREL; 09627800 + WORDSLEFT ~ BUFFSIZE; 09627850 + IF UNITYPE=12 THEN IF NOT DONE THEN WAITIO; 09627900 + BUFTOP.[CF] ~ TIP; 09628000 + END; 09628100 + MOVEREC; 09628200 + DLOC[0] ~ FLAG(BUFTOP & (LINES>0)[27:46:2] 09628300 + & (BUFFSIZE-WORDSLEFT) TOSZF 09628350 + & CHNNL [29:44:4]); 09628400 + IF LINES = 1 THEN DLOC[0]~TIP & 2[27:46:2]; 09628500 + PREL; 09628600 + WORDSLEFT ~ BUFFSIZE; 09628650 + IF (LINES ~ LINES - 2) > 0 THEN SKIPPER; 09628700 + IF UNITYPE=12 THEN IF NOT DONE THEN WAITIO; 09628800 + BUFTOP.[CF] ~ TIP; 09628900 + END; 09629100 +LPRETURN: 09629200 + IF LINTOG THEN IF (*P(LOCOFCTR))}LINAGELIM THEN 09629300 + BEGIN 09629400 + P(0,LOCOFCTR,STD); 09629500 + LINAGELIM ~ NXTLINAGE; 09629600 + P(1,RTN); 09629700 + END; 09629800 + P(0,RTN); 09629900 + END GOINTOPRINTER; 09630000 +SUBROUTINE WRIT; % WRITES A BLOCK 09630900 + BEGIN 09631000 + DLOC[0] ~ FLAG(BUFTOP & (BUFFSIZE-WORDSLEFT) TOSZF); 09631100 + IF TAPEE THEN IF NOT BINARY THEN ARROW ELSE 09631200 + ELSE IF PUNCH THEN DLOC[0] ~ TIP & CHNNL[32:47:1]; 09631300 + PREL; 09631400 + WORDSLEFT ~ BUFFSIZE; 09631500 + BUFTOP.[CF] ~ TIP; 09631600 + END WRIT;% 09631700 +SUBROUTINE REED; % READS A BLOCK 09631800 + BEGIN% 09631900 + DLOC[0] ~ FLAG(FIB[16]);% 09632100 + PREL;% 09632200 + BUFTOP.[CF] ~ TIP;% 09632300 + WORDSLEFT ~ 0; 09632500 + END REED;% 09632700 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% START HERE %%%%%%%%%%%%%%%%%%%%%%%%%%%%%09632800 + FIB ~ *(FLOC ~ (NOT 2) INX DLOC);% 09632900 + IF FPB[FNAM+3].[42:6]=43 THEN % DUMMY 09632910 + IF CODE=0 THEN GO EOFSETCK ELSE P(0,RTN); 09632920 + IF DISK THEN GO TO P(COBOLIODSK);% 09633000 + IOMASK ~ @2000000000;% 09633100 + START:IF NOT(ENDPROCESS=0 OR CODE) THEN GO TO EOFSETCK; 09633200 + IF CODE > 1 THEN % SHOULD BE WRITE BLOCK 09633300 + BEGIN 09633400 + IF CODE ! 6 THEN TERM(25); % UNRECOGNIZED CODE 09633500 + IF HOWOPEN ! 0 THEN GO IMPROPER; % IO ERROR 09633600 + IF WORDSLEFT < BUFFSIZE THEN 09633700 + IF LINEPRINT THEN GOLP ELSE WRIT; 09633800 + P(0,RTN); 09633900 + END WRITEBLOCK; 09634000 +IMPROPER:IF (1-CODE)!HOWOPEN THEN % CHECK USE VS HOW OPEN 09634200 + IF HOWOPEN>1 THEN TERM(31+CODE) % CLOSED 09634300 + ELSE TERM(PROPER);% % USAGE 09634400 + IF UNITYPE=10 OR UNITYPE=13 THEN 09634500 + BEGIN 09634600 + IF CODE THEN REMOTEWRIT; 09634700 + REMOTEREAD; 09634800 + END; 09634900 + IF CODE THEN % WRITE A RECORD 09635000 + IF LINEPRINT THEN GOLP ELSE 09635100 + BEGIN 09635200 + IF TECHC THEN 09635300 + BEGIN 09635400 + IF NUMWDS > MAXREC THEN NUMWDS ~ MAXREC; 09635500 + IF NUMWDS > WORDSLEFT THEN WRIT; 09635600 + IF NUMWDS < MINREC THEN TERM(36); 09635700 + END; 09635800 + MOVEREC; 09635900 + IF WORDSLEFT < MINREC THEN WRIT; 09636000 + P(0,RTN); 09636100 + END; 09636200 + % READ A RECORD 09636300 +ROVER: IF WORDSLEFT { 0 THEN 09636400 + BEGIN % A NEW BLOCK WAS READ 09636500 + IF NOT DONE THEN WAITIO; 09636600 + WORDSLEFT ~ 09636800 + MEM[(IF REVERSE THEN 1 ELSE NOT 0) INX TIP]; 09636900 + IF REVERSE THEN DLOC[0] ~ NOT(MAXREC-2) INX TIP; 09637000 + END; 09637100 + IF TECHC THEN 09637200 + BEGIN 09637300 + NUMWDS ~ P(.NUMWDS,LOD,.TCW,STD,MINREC); 09637400 + MOVEREC; 09637500 + IF (TCW~TCW) > MAXREC THEN TCW ~ MAXREC; 09637600 + IF TCW < NUMWDS THEN 09637700 + IF (TCW=0) AND (WORDSLEFT+NUMWDS=1) THEN 09637800 + BEGIN 09637900 + REED; 09638000 + RCOUNT ~ *P(DUP) - 1; 09638100 + GO ROVER; 09638200 + END ELSE TERM(26 + (TCW!0)); 09638300 + IF (TCDIF ~ TCW - NUMWDS) > 0 THEN 09638400 + BEGIN 09638500 + STREAM(TCDIF,E~P(DUP).[36:6], 09638600 + FROM~ TIP INX 0, 09638700 + DEST ~ NUMWDS INX (*RCPRT)); 09638800 + BEGIN SI ~ FROM; 09638900 + E(DS~32 WDS; DS~32 WDS); 09639000 + DS ~ TCDIF WDS; 09639100 + END STREAM; 09639200 + DLOC[0] ~ TCDIF INX TIP; 09639300 + WORDSLEFT ~ *P(DUP) - TCDIF; 09639400 + NUMWDS ~ TCW; 09639450 + END; 09639500 + P(RCPRT,DUP,LOD,NUMWDS,DIA 38,DIB 8,TRB 10,XCH,STD); 09639550 + END % TECH C FILE READING 09639600 + ELSE MOVEREC; 09639700 + IF WORDSLEFT { 0 OR UNBLKD THEN REED; 09639800 + P(0,RTN); 09639900 +EOFSETCK: 09640000 + IF ENDFILE THEN TERM(15); 09640100 + ENDFILE ~ TRUE; 09640200 + P(1,RTN); 09640300 +END COBOLIONONDISK; 09640500 +PROCEDURE COBOLIODSK; 09700000 + BEGIN 09700100 + REAL RCW = +0; %USED TO CALL COBOLIONONDSK 09700200 + REAL CODE = -1; % 0=READ,1=WRITE,2=SEEK,6=WRTBLK, 09700300 + NAME DLOC = -2; % POINTS TO BUFFER I/O DESC 09700400 + REAL NUMWDS = -3; % # WDS TO BE WRITTEN 09700500 +%LOCALS 09700600 + INTEGER BS ; % USED IN COMPUTING DISK ADDR 09700700 + REAL COBOLIONONDSK= 14; 09700800 + REAL DEST ; % DESTINATION IN RANDDM MOVE 09700900 + ARRAY FIB [*]; % FIB ARRAY 09701000 + NAME FLOC; % POINTER TO FIB 09701100 + ARRAY FPB = 3[*]; % FILE PARAMETER BLOCK 09701200 + ARRAY H[*]; % DISK FILE HEADER 09701300 + REAL INTINT = 5; % INTRINSIC INTRINSIC 09701400 + NAME MEM = 2; % DUMMY DATA DESC 09701500 + NAME PERFORMER = 13; % USED FOR PERFORMING USE ROUTINES 09701600 + ARRAY PGUSE=24[*]; % PROGRAM USE ROUTINES 09701700 + INTEGER RT ; % USED IN COMPUTING DISK ADDR 09701800 + REAL T; % TEMPORARY 09701900 + INTEGER DAS; % USED TO COMPUTE DISK ADDRESS 09702000 + $ SET OMIT = NOT SHAREDISK 09702004 +DEFINE 09702100 + AF = [12:12]#, % FILE USE ROUTINE 09702200 + ARR = [36:12]#, % REEL USE ROUTINE 09702300 + BCOUNT = FIB[6]#, % BLOCK COUNT 09702400 + BF = [1:11]#, % FILE USE ROUTINE 09702500 + BOUNDED = FIB[9].[2:1]#, % TRUE IF BOUNED FROM ABOVE 09702600 + BREAK = FIB[9] ! 0 # , % BREAKOUT RESTART POINT 09702700 + BREAKOUT = IF(RCOUNT MOD FIB[9])=0 THEN 09702800 + P(0,0,12,COM,DEL,DEL)#,% CALL BREAKOUT 09702900 + BRR = [24:12]#, % REEL USE ROUTINE 09703000 + BUFFNUM = FIB[13].[1:9] #, % # OF BUFFS REQUSTED 09703100 + BUFFSIZE = FIB[18].[3:15]#, % BUFFER SIZE (REQUESTED) 09703200 + BUFFSZ = FIB[18][8:8:10]#, % SIZE FOR CONCATINATES 09703300 + BUFTOP = FIB [16]#, % USED ON I-O AND RANDOM 09703400 + COUNT = FIB[12] #, % USED FOR BLOCKING TECH-A,B09703500 + DINXPRT = P(*RCPRT & TIP [CTC],RCPRT,~)#,%UPDATE POINTER09703600 + DONE = TIP.[19:1] #, % 1= IO COMPLETED 09703700 + DISK = (UT =4)#, % DISK IS UNIT TYPE OF 4 09703800 + ERBIT = FIB[13].[19:1] #, % IOERR 19 NOT YET SPOUTED 09703900 + FLAGINWA = 0[1:1:1]#, % SAYS WE ARE IN WORK AREA 09704000 + FNAM = FIB[4].[13:11]#, % FILE NAME INOEX IN FPB 09704100 + ENDFILE = FIB[5].[40:1] #, % ALREADY PASSED EOF 09704200 + ENDPROCESS = FIB[5].[39:2]#, % SEE OPTIONAL AND ENDFILE 09704300 + EOF =((*DLOC).[27:1])#, % FIRST EOF OR EOT 09704400 + GETSEG = P(FPB[(BS:=FNAM)+3],FPB[BS],FPB[BS+1], 09704500 + T,H,4,11,COM,DEL,DEL,DEL,DEL,DEL,DEL)#, 09704600 + KEY = FIB[15].[12:10]#, % REL PRT LOC OF ACIUAL KEY 09704700 + HAVEWA =(INWA OR FIB[20].[CF]>1)#,% TRUE IF WE ARE NOW 09704800 + %IN WORK AREA OR HAVE MADE IT PRESENT PREVIOUSLY09704900 + HOWOPEN = FIB[5].[41:3]#, % 1=OPEN INPUT,0= OPEN OUTPT09705000 + % 1 > CLOSED 09705100 + INVALIDUSER = FIB[5]<0#, % INVALID USER NOT PARIIY 09705200 + INWA = FIB[20]}0#, % SAYS WE ARE IN WORK AREA 09705300 + INXPRT = P(NUMWDS INX *RCPRT,RCPRT,~)#,% UPDATE POINTER09705400 + IOERR(IOERR1) = P(0,FLOC,IOERR1,17,COM,DEL,DEL,DEL)#, 09705500 + % ABOVE CALLS IOERROR ROUTINE 09705600 + IOMASK = 0&1[19:47:1] #, % USED TO WAIT FOR IOFINISH 09705700 + LASTDONE = FIB[13].[21:1] #, % NOT OF LAST OPERATION DONE09705800 + LBLPTR = FLOC[1] #, % LABEL POINTER 09705900 + LSUBL = FIB [1] #, % LOWER BOUND FOR RANDOM 09706000 + LSUBU = FIB [3] #, % UPPER BOUND FOR DISK REC 09706100 + MABUSE = FIB[4].[1:1]#, % MAY BE USE RTNS PRESENT 09706200 + MAKEPRFSENTWA = P(*RCPRT & 1 [CTC],0,CDC)#, 09706300 + MAXR = FIB[18][8:38:10]#,% MAX REC SZ FOR CONCATS 09706400 + MAXREC = FIB[18].[33:15]#, % MAX REC SZ 09706500 + MINREC = FIB[18].[CF]#, % MINIMUM RECORD SIZE 09706600 + NOAIT = FIB[20].[3:1]#, % AIT FOR WA WAS DESIROYED 09706700 + NUMBUF = FIB[13].[10: 9]#, % NUMBER OF BUFFERS ASSIGNED09706800 + NUMBSPC = H[9].[43:5] #, % NUMBER OF ROWS SPECIFIED 09706900 + NUMREC = FIB[11] #, % RECORDS PER BLOCK 09707000 + OPENIO = FIB[13].[22:1]#, % 1= OPEN INPUT-OUPUT (DISK)09707100 + PARITY = FIB[13].[20:1] #, % IO ERROR OCCURED IN BLOCK 09707200 + PBIT = [2:1]#, % PRESENCE BIT 09707300 + POINTPRTTOBUF = P((*RCPRT OR MEM) & TIP [CTC],RCPRT,~)#, 09707400 + POINTPRTTOWA = P(*RCPRT & FIB[20] [CTC],RCPRI,~)#, 09707500 + PRESENT =((*DLOC).[2:1])#, % CHECKS PRESENTSBIT 09707600 + PROPER =REVERSE+CODE+CODE+21#,%GENERATES PROPER IOERR 09707700 + RCOUNT = FIB[7] #, % RECORD COUNT 09707800 + RCPRT = (FIB[20].[FF])#, %PRT OF DESC POINTING TO REC09707900 + RECPERBLK = H[0].[30:12] #, % RECORDS PER BLOCK 09708000 + REDECWA = P(MKS,RCPRT,MAXREC,1,1,1,INTINT)#, 09708100 + % DECLARE SAVE ARRAY FOR WORK AREA 09708200 + REEDING = ((*DLOC).[24:1])#,%LASI IO WAS READ 09708300 + RESETPANDERBIT = FIB[13]:=*P(DUP)&0[19:19:2]#,%RESET ERR BIIS 09708400 + RESETREADBIT = 0[24:24:1]#, % USED IO TURN OFF READ BIT 09708500 + REVERSE = FIB[5].[44:1] #, % 1=REVERSE INPUT 09708600 + ROWLGTH = H[1]#, % ROW LGTH FROM HEADER 09708700 + SAVEWADDR = FIB[20]~*P(DUP)&*P(RCPRT)[CTC]#,% SAVE ADDRESS09708800 + SERIAL = FIB[4].[27:3]=0 #,% FILE ACCESS = SERIAL 09708900 + SEGPERBLK = H[0].[42:6] #, % SEGMENTS PER BLOCK 09709000 + SETPANDERBIT = FIB[13]:=*P(DUP)&3[19:46:2]#, 09709100 + % SET PARITY AND IOERR 19 BITS 09709200 + SETPRESENTSBIT =P(TIP OR MEM ,DLOC,~)#,% SET PRESENCE BIT 09709300 + SETREADBIT = 1[24:47:1]#, %USED TO TURN READ BII ON 09709400 + $ SET OMIT = NOT(TIMESHARING) 09709500 + SLEEP = 36 #, 09709600 + $ POP OMIT 09709601 + $ SET OMIT = TIMESHARING 09709700 + TECHA =(FIB[5].[46:2]=1)#,% TECHNIQUE-A 09709900 + TERM(TERM1) = P(1,FLOC,TERM1,17,COM)#,%TERMINATE I/O ERROR 09710000 + TIP = (*DLOC) #, % LOAD I/O DESC 09710100 + TOSZF = [8:38:10]#, % TO SIZE FIELD 09710200 + TOTREC = H[7] #, % TOTAL RECORDS ON FILE 09710300 + UT = (FIB[4].[8:4])#, % HARDWARE TYPE 09710400 + WA = P(RCPRT,DIB 0,LOD)#,% LOAD WORK AREA PTR 09710500 + WAITIO = P(DLOC,IOMASK, % THIS SLEEPS ON I/O 09710600 + SLEEP,COM,DEL,DEL)#,% WAITING FOR A COMPLETE 09710700 + WORDSLEFT = FIB[17]#, % WORDS LEFT IN BUFFER 09710800 + WRITBACK = FIB[13].[23:1]#; % FLAG TO SAY WRITE BACK 09710900 +LABEL MOOVE,FLOTE,SEEKRTN,START,READREV; 09711000 +LABEL SERIALIO,SIOEOD,RNDEOD,EOFSETCK; 09711100 +LABEL ERREND,MOOVERR,REREAD,LCKHANDLER; 09711150 +SUBROUTINE GOUSE; % THIS CALLS USE ROUTINES 09711200 + BEGIN 09711300 + P(MKS,T,0,PERFORMER); 09711400 + END GOUSE; 09711500 +SUBROUTINE ERROR; %THIS PROCESSES ALL ERRORS 09711600 + BEGIN 09711700 + IF REEDING AND CODE AND (NUMREC=1) 09711800 + $ SET OMIT = NOT SHAREDISK 09711809 + THEN % SKIP ERROR CODE 09711820 + ELSE BEGIN 09711900 + IF OPENIO THEN IF (T:=RT:=PGUSE[4].ARR) ! 0 THEN 09712000 + GOUSE ELSE ELSE %WAS ERROR ON IO 09712100 + IF REEDING AND (NOT CODE) THEN %READ ERROR 09712200 + IF (T:=RT:=PGUSE[4].BRR) ! 0 THEN 09712300 + GOUSE ELSE ELSE 09712400 + IF (T:=PGUSE[5].BRR) ! 0 THEN GOUSE; %WRITE ERROR 09712500 + IF (T~FIB[15].BF) ! 0 THEN GOUSE; % ERROR ON FILE-N 09712600 + $ SET OMIT = NOT SHAREDISK 09712609 + IF REEDING AND (NOT CODE) THEN 09712700 + BEGIN %CHECK USE PROC FOR 09712800 + IF ERBIT THEN %INPUT ERRORS 09712900 + IF (T OR RT) = 0 THEN IOERR(19); 09713000 + ERBIT := FALSE; 09713100 + END ELSE TERM(20); %WRITE ERR TERM 09713200 + END; 09713300 +ERREND: 09713350 + END ERROR; 09713400 +SUBROUTINE MOVEREC; %MOVES DAIA TO AND FROM WORKAREA 09713500 + BEGIN 09713600 + IF NOT DONE THEN % DONT MOVE TILL IO DONE 09713700 + $ SET OMIT = NOT SHAREDISK 09713709 + WAITIO; 09713750 + IF NOT PRESENT THEN 09713800 + BEGIN %GOT AN ERROR 09713900 + SETPRESENTSBIT; 09714000 + SETPANDERBIT; %SET ERROR FLAGS 09714100 + $ SET OMIT = NOT SHAREDISK 09714104 + IF NOT REEDING THEN 09714200 + BEGIN %ERROR ON OUTPUT 09714300 + DEST := WA; %MOVE FIRST RECORD 09714400 + P(TIP INX 1); %TO WORK AREA 09714500 + GO MOOVE; 09714600 + END; 09714700 + $ SET OMIT = SHAREDISK 09714799 + END; 09714800 + $ POP OMIT 09714801 + $ SET OMIT = NOT SHAREDISK 09714809 + P(BUFTOP INX(BS~NUMWDS|(RCOUNT MOD NUMREC)+ 1)); 09714900 + WA; %MOVE TO/FROM WA 09715000 + DEST ~ IF CODE THEN P(XCH) ELSE P; %FOR READ OR WRITE 09715100 +MOOVE: STREAM(FROM~P:NUMWDS,E~P(DUP).[37:5],DEST~P(*P(.DEST))); 09715200 + BEGIN 09715300 + SI:=FROM; E(DS:=32 WDS; DS:=32 WDS); DS:=NUMWDS WDS;09715400 + END STREAM; 09715500 + P(DEL); 09715600 + IF PARITY THEN 09715700 + BEGIN 09715710 +MOOVERR: ERROR; 09715730 + $ SET OMIT = NOT SHAREDISK 09715739 + END; 09715760 + END MOVEREC; 09715800 + $ SET OMIT = NOT SHAREDISK 09715809 +SUBROUTINE DISKADDRESS; %THIS COMPUIES THE DISK ADDRESS READ & WRIT09715900 + BEGIN 09716000 + RT ~ SEGPERBLK | DAS; % REL SEGMENT NO 09716100 + IF P(RT DIV ROWLGTH,DUP) GEQ NUMBSPC THEN 09716200 + BEGIN 09716210 + $ SET OMIT = NOT SHAREDISK 09716219 + P(1,RTN); 09716240 + END; 09716250 + IF (BS~H[(T~ P + 10)]) = 0 THEN 09716300 + BEGIN 09716400 + GETSEG; 09716500 + IF HOWOPEN!0 THEN IF NOT OPENIO THEN IOERR(22); 09716600 + BS ~ H[T]; 09716700 + END; 09716800 + STREAM( A ~ BS ~ BS + RT MOD ROWLGTH, 09716900 + B~T~BUFTOP.[CF]-(IF CODE THEN 0 ELSE WRITBACK)); 09717000 + BEGIN SI~LOC A; DS~8 DEC; END; 09717100 + $ SET OMIT = NOT SHAREDISK 09717109 + END DISKADDRESS; 09717200 +SUBROUTINE ROTATEBUF; %THIS ROTATES BUFFERS 09717300 + BEGIN 09717400 + IF NUMBUF > 1 THEN 09717500 + P(NUMBUF,DLOC,13,11,COM,DEL,DEL,DEL); 09717600 + WORDSLEFT := BUFFSIZE; 09717700 + RESETPANDERBIT; 09717800 + FIB[16].[CF] := TIP; 09717900 + END ROTATEBUF; 09718000 +SUBROUTINE PREL; % THIS DOES ACTUAL I/D 09718100 + BEGIN 09718200 + P( TIP,DLOC); 09718300 + IF WRITBACK THEN % DO SPECIAL WRITE-IO 09718400 + BEGIN 09718500 + WRITBACK ~ FALSE; % TURN OFF READ BIT 09718600 + DLOC[0]~ TIP&RESETREADBIT;% TO MAKE WRITE 09718700 + END; 09718800 + P(PRL,DEL); % DO I-O 09718900 + IF BREAK THEN BREAKOUT; 09719000 + END PREL; 09719100 +SUBROUTINE REED; %THIS READS BLOCKS 09719200 + BEGIN 09719300 + WORDSLEFT := BUFFSIZE; 09719400 + DLOC[0] := FLAG(BUFTOP & SETREADBIT); %TO RESET IOD 09719500 + CODE ~ P(CODE,0); 09719600 + DISKADDRESS; 09719700 + CODE ~ P; 09719800 + $ SET OMIT = NOT SHAREDISK 09719804 + MEM[BUFTOP INX NOT 2] ~ DAS; % SAVE BLOCK NUMBER 09719900 + PREL; 09720000 + FIB[16].[CF] := TIP; %SAVE BUFF ADDRESS 09720100 + END REED; 09720200 +SUBROUTINE WRIT; %THIS WRITES BLOCKS 09720300 + BEGIN 09720400 + WORDSLEFT := BUFFSIZE; 09720500 + WRITBACK ~ FALSE; 09720600 + DAS := BCOUNT; %BLOCK ADDRESS 09720700 + DLOC[0] := FLAG(BUFTOP & RESETREADBIT); %RESET IOD 09720800 + DISKADDRESS; 09720900 + $ SET OMIT = NOT SHAREDISK 09720904 + PREL; 09721000 + FIB[16].[CF] := TIP; %SAVE BUFF ADDRESS 09721100 + IF NOT(SERIAL) THEN BCOUNT := MEM[BUFTOP INX NOT 2]; 09721120 + END WRIT; 09721200 +SUBROUTINE SEEK; %THIS FINDS AND/OR READS BLOCKS 09721300 + BEGIN 09721400 + IF (DAS ~ RCOUNT DIV NUMREC) = BCOUNT THEN 09721500 + BEGIN 09721510 + $ SET OMIT = NOT SHAREDISK 09721519 + GO SEEKRTN; 09721570 + END; 09721580 + IF SERIAL THEN 09721600 + BEGIN 09721700 + IF NOT HOWOPEN THEN 09721800 + BEGIN %NOT INPUT 09721900 + IF RCOUNT < TOTREC THEN TOTREC := RCOUNT; 09722000 + IF NUMREC > 1 THEN 09722100 + BEGIN %BLOCKED OUTPUI 09722200 + NUMBUF := 1; %FILL ONLY ONE 09722300 + IF (WORDSLEFTBCOUNT) THEN %BLOCK IS PRESENT 09722800 + IF MEM[DLOC[NUMBUF-1] INX NOT 2] = COUNT THEN 09722900 + DAS := COUNT + 1; 09723000 + COUNT := (RCOUNT DIV NUMREC) + NUMBUF - 1; 09723100 + DO BEGIN 09723200 + IF NOT DONE THEN WAITIO; 09723300 + IF NOT PRESENT THEN 09723400 + IF NOT REEDING 09723500 + THEN MOVEREC ELSE SETPRESENTSBIT; 09723600 + IF DAS | NUMREC { LSUBU 09723700 + THEN REED ELSE ROTATEBUF; 09723800 + END UNTIL (DAS := DAS + 1) > COUNT; 09723900 + IF NOT HOWOPEN THEN WAITIO; 09724000 + BCOUNT := DAS ~ DAS - NUMBUF; 09724100 + NUMBUF := BUFFNUM; 09724200 + END ELSE %MUST BE RANDOM 09724300 + IF HOWOPEN OR (NUMREC > 1) 09724400 + $ SET OMIT = NOT SHAREDISK 09724409 + THEN BEGIN % INPUT OR BLOCKED OR LOCK 09724500 +REREAD: 09724550 + IF NUMBUF = 1 THEN % JUST READ DONT TRY TO FIND 09724600 + BEGIN IF NOT DONE THEN 09724700 + $ SET OMIT = NOT SHAREDISK 09724709 + WAITIO; 09724750 + REED; 09724760 + BCOUNT~DAS; 09724770 + END 09724780 + ELSE BEGIN 09724800 + FOR T := 1 STEP 1 UNTIL NUMBUF -1 09724900 + DO %FIND BLOCK IN CORE 09725000 + IF MEM[DLOC[T] INX NOT 2] = DAS THEN 09725100 + $ SET OMIT = SHAREDISK 09725109 + GO FLOTE; 09725110 + $ POP OMIT 09725111 + $ SET OMIT = NOT SHAREDISK 09725119 + IF NOT DONE THEN 09725300 + $ SET OMIT = NOT SHAREDISK 09725309 + WAITIO; 09725390 + REED; %MAKE PRESENT IN CORE 09725400 +FLOTE: IF CODE < 2 09725500 + $ SET OMIT = NOT SHAREDISK 09725549 + THEN BEGIN 09725600 + IF WRITBACK THEN %READ OR 09725700 + BEGIN %WRITE 09725800 + WRIT; 09725900 + DAS := RCOUNT DIV NUMREC; 09726000 + END ELSE ROTATEBUF; 09726100 + WHILE MEM[TIP INX NOT 2] ! DAS 09726200 + DO ROTATEBUF; 09726300 + BCOUNT := DAS; 09726400 + END; 09726500 + END; 09726600 + END; 09726700 +SEEKRTN: 09726800 + ENDFILE := FALSE; 09726900 + WORDSLEFT := BUFFSIZE - ((RCOUNT MOD NUMREC) | NUMWDS); 09727000 + LASTDONE ~ FALSE; % PREVENT SERIALIO OVERWRITE 09727100 + IF CODE = 2 THEN P(XIT); 09727200 + END SEEK; 09727300 +%***% S T A R T Y E E H E R E Y E E D I S K E R S %***% 09727400 +START: 09727500 + FIB := *(FLOC := (NOT 2) INX DLOC); 09727600 + IF NOT DISK THEN 09727700 + BEGIN 09727800 + FLOC := P(.RCW,LOD); 09727900 + FIB ~ ABS(CODE); 09728000 + DEST := P(.DLOC,LOD); 09728100 + BS := NUMWDS; 09728200 + CODE := 1; 09728300 + RCW := DLOC := NUMWDS := 0; 09728400 + P([FLOC],DUP,0,XCH,CFX,STF,1,INX,STS); 09728500 + GO TO P(COBOLIONONDSK); 09728600 + END; 09728700 + H := *[FIB[14]]; 09728800 + $ SET OMIT = NOT SHAREDISK 09728804 + IF CODE.[1:1] THEN 09728815 + BEGIN CODE~ABS(CODE); 09728820 + $ SET OMIT = NOT SHAREDISK 09728824 + END; 09728890 + IF CODE > 2 THEN IF CODE ! 6 THEN TERM(25) ELSE %WRITE BLOCK 09728900 + BEGIN IF HOWOPEN > 1 THEN TERM(37); 09728930 + IF NOT OPENIO THEN IF HOWOPEN THEN TERM(34+REVERSE); 09728960 + $ SET OMIT = NOT SHAREDISK 09728979 + GO EOFSETCK; %WRITES BLOCK:IMMEDIATE-NO ROTATION 09729000 + END; 09729050 + IF HOWOPEN > 1 THEN TERM(31 + CODE); 09729100 + IF CODE = 2 THEN 09729200 + BEGIN RCOUNT~(IF KEY=0 THEN 0 ELSE P(KEY,DIB 0,LOD)) - 1; 09729300 + IF (RCOUNTLSUBU) THEN 09729400 + GO EOFSETCK % INVALID KEY 09729500 + ELSE IF INVALIDUSER THEN TERM(0)% DS WITH INVALID USER 09729510 + ELSE SEEK; %ONLY SEEK VALID RECORDS 09729520 + END; 09729600 + IF NOT OPENIO THEN 09729700 + IF (1 - CODE) ! HOWOPEN THEN TERM(PROPER); 09729800 + IF SERIAL THEN % PROCESS SERIAL FILE 09729900 + BEGIN 09730000 + IF OPENIO THEN GO SERIALIO; 09730100 + IF (RCOUNTLSUBU) THEN GO EOFSETCK; 09730200 + IF CODE = 0 OR CODE = 2 THEN% READ OR SEEK (SERIAL) 09730210 + IF INVALIDUSER THEN TERM(0); % DS WITH INVALID USER 09730220 + MOVEREC; 09730300 + IF REVERSE THEN GO READREV; 09730400 + IF CODE THEN IF RCOUNT > TOTREC THEN TOTREC := RCOUNT; 09730500 + IF (WORDSLEFT := *P(DUP) - NUMWDS) { 0 THEN 09730600 + BEGIN %BLOCK IS EXHAUSTED 09730700 + IF CODE THEN WRIT ELSE 09730800 + IF (DAS := BCOUNT + NUMBUF) | NUMREC { LSUBU THEN 09730900 + BEGIN %READ AHEAD TO KEEP 09731000 + REED; %BUFFERS READY 09731100 + COUNT := DAS; 09731200 + END ELSE ROTATEBUF; 09731300 + BCOUNT := * P(DUP) + 1; 09731400 + END; 09731500 + RCOUNT := *P(DUP) + 1; 09731600 + IF FALSE THEN % THIS CODE EXECUTED ONLY FOR TAPE 09731700 +READREV: BEGIN % OPEN-REVERSE EQUATED TO DISK 09731800 + IF (WORDSLEFT ~ *P(DUP) - NUMWDS) { 0 THEN 09731900 + BEGIN % BLOCK IS EXHAUSTED 09732000 + IF (DAS ~ BCOUNT - NUMBUF) | NUMREC } LSUBL THEN 09732100 + BEGIN REED; COUNT ~ DAS; 09732200 + END ELSE ROTATEBUF; 09732300 + BCOUNT ~ *P(DUP) - 1; 09732400 + END; 09732500 + RCOUNT ~ *P(DUP) - 1; 09732600 + END REVINPUT; 09732700 + IF KEY ! 0 THEN P(RCOUNT,KEY,DIB 0,ISD); 09732800 + P(0,RTN); 09732900 + % % E N D O F S E R I A L ---- I O N E X T % % 09733000 +SERIALIO: 09733100 + RCOUNT ~ *P(DUP) - (T ~ (CODE AND LASTDONE)); 09733200 + IF (RCOUNTLSUBU) THEN GO EOFSETCK; 09733300 + IF CODE = 0 OR CODE = 2 THEN %READ OR SEEK (SERIAL I/O) 09733310 + IF INVALIDUSER THEN TERM(0);% DS WITH INVALID USER 09733320 + IF T THEN WORDSLEFT ~ *P(DUP) + NUMWDS ELSE 09733400 + IF WORDSLEFT { 0 THEN 09733500 + BEGIN %BLOCK IS EXHAUSTED 09733600 + IF (DAS := BCOUNT + NUMBUF) | NUMREC { TOTREC THEN 09733700 + BEGIN %ANOTHER BLOCK 09733800 + REED; % IN SIGHT 09733900 + COUNT := DAS; 09734000 + END ELSE 09734100 + IF WRITBACK THEN % WRITE CURRENT BLOCK 09734200 + WRIT % LESS WE FORGIT 09734300 + ELSE % OR USE NEXT BUFFER 09734400 + ROTATEBUF; % BECAUSE ITS THERE 09734500 + BCOUNT := *P(DUP) + 1; 09734600 + END; 09734700 + IF RCOUNT > TOTREC THEN 09734800 + IF CODE THEN TOTREC ~ RCOUNT ELSE 09734900 + BEGIN CODE~32; GO SIOEOD; END; 09735000 + MOVEREC; 09735100 +SIOEOD: IF (WORDSLEFT := *P(DUP) - NUMWDS) { 0 THEN 09735200 + IF CODE THEN %WROTE LAST RECORD 09735300 + BEGIN % OF YEE BLOCK 09735400 + IF (DAS:=BCOUNT+NUMBUF)|NUMREC { TOTREC THEN 09735500 + BEGIN %READ AHEAD TOO 09735600 + WRITBACK := TRUE; %KEEP BUFFERS FULL 09735700 + REED; 09735800 + COUNT := DAS; 09735900 + END ELSE % WRITE BLOCK NOW 09736000 + WRIT; % ...A WRITE IN TIME... 09736100 + BCOUNT := *P(DUP) + 1; 09736200 + END ELSE 09736300 + ELSE IF CODE THEN WRITBACK := TRUE; %NOT FULL BLK 09736400 + LASTDONE := NOT CODE; 09736500 + IF KEY ! 0 THEN P(RCOUNT,1,+,KEY,DIB 0,ISD); 09736600 + RCOUNT := *P(DUP) + 1; 09736700 + IF CODE=32 THEN GO EOFSETCK ELSE P(0,RTN); 09736800 + END SERIAL; % END OF ALL SERIAL PROCESSING 09736900 + %%% RANDOM AND RANDOM IO START HERE %%% 09737000 + RCOUNT := (IF KEY = 0 THEN 0 ELSE P(KEY,DIB 0,LOD)) - 1; 09737100 + IF (RCOUNTLSUBU) THEN GO EOFSETCK; 09737200 + IF CODE = 0 OR CODE = 2 THEN %READ OR SEEK (RDM OR RDM I/O) 09737210 + IF INVALIDUSER THEN TERM(0);% DS WITH INVALID USER 09737220 + IF RCOUNT > TOTREC THEN 09737300 + IF CODE THEN TOTREC ~ RCOUNT ELSE 09737400 + BEGIN CODE ~ 32; GO RNDEOD; END; 09737500 + $ SET OMIT = NOT SHAREDISK 09737549 + IF (DAS ~ RCOUNT DIV NUMREC) ! BCOUNT THEN 09737600 + IF (NUMREC!CODE) 09737700 + THEN SEEK % READ OR BLOCKED WRITE 09737710 + ELSE MEM[BUFTOP INX NOT 2]:=BCOUNT:=DAS; 09737720 + MOVEREC; 09737800 +RNDEOD: WORDSLEFT := *P(DUP) - NUMWDS; 09737900 + IF CODE THEN 09738000 + IF NUMREC = 1 %UNBLOCKED OUTPUT 09738100 + $ SET OMIT = NOT SHAREDISK 09738109 + THEN BEGIN 09738120 + WRIT; 09738140 + $ SET OMIT = NOT SHAREDISK 09738149 + END ELSE 09738200 + WRITBACK ~ TRUE; 09738300 + IF CODE!32 THEN P(0,RTN); 09738400 +EOFSETCK: 09738500 + IF (WORDSLEFT < BUFFSIZE) AND 09738600 + (NOT(HOWOPEN) OR (OPENIO AND WRITBACK)) 09738700 + THEN BEGIN 09738800 + NUMBUF := 1; %WRITE LAST BUFFER 09738900 + WRIT; %AND CHECK FOR 09739000 + WAITIO; %ERRORS 09739100 + NUMBUF := BUFFNUM; 09739200 + IF NOT PRESENT THEN 09739300 + BEGIN 09739400 + SETPRESENTSBIT; 09739500 + $ SET OMIT = NOT SHAREDISK 09739549 + ERROR; 09739600 + END END; 09739700 + IF CODE = 6 THEN P(0,RTN); 09739750 + IF SERIAL AND CODE ! 2 THEN % ONLY 1 EOF ALLOWED 09739800 + IF ENDFILE THEN TERM(15) ELSE ENDFILE ~ TRUE; 09739900 + IF CODE = 32 THEN % CLEAR WORK AREA 09740000 + BEGIN H ~ WA; % IF READ BEYOND EOF 09740100 + FOR RT ~ 0 STEP 1 UNTIL (NUMWDS-1) DO H[RT] ~ 0; 09740200 + END; 09740300 + IF CODE ! 2 THEN % LET PROGRAM KNOW ITS EOF 09740400 + BEGIN 09740410 + $ SET OMIT = NOT SHAREDISK 09740419 + P(1,RTN); 09740430 + END ELSE 09740440 + LASTDONE ~ FALSE; % PREVENT SERIALIO OVERWRITE 09740500 + %%% END OF EOF CHECKING 09740600 +END OF COBOL DISK INTRINSICS; 09740700 +PROCEDURE INTERRUPTER; % EXECUTION FORCED BY SOFTWARE INTERRUPT CODE AT09800000 +BEGIN % INITIATE. INTERRUPTER PROCESSES ENABLED 09800100 + REAL ADDR=+1, % INTERRUPTS IN SFINTQ. AN IP1 HAS JUST BEEN 09800200 + I =+2, % EXECUTED, POINTING REG-F AND REG-S IO THE 09800300 + NOTDONE=+3, % STACK COPY OF THE OLD INCW. 09800400 + DONE=+4; 09800500 + REAL PERFORMGEN=13; 09800700 + ARRAY TSKA =22[*], % TASK ARRAY 09800750 + % CONTENTS OF TSKA[8]: 09800755 + % [1:1]=1 IFF INTERRUPTER HAS JUSI RUN AND 09800760 + % SFINTQ IS NON-EMPTY 09800765 + % [2:1]=1 IFF SFINTQ IS NON-EMPTY 09800770 + % [3:1]=1 IFF INTERRUPTER IS RUNNING 09800775 + % [4:1]: SFINTQ INIERLOCK BIT 09800780 + % [FF] = ADDRESS OF OLD IRCW 09800785 + % [CF] = RELATIVE PRT ADDRESS OF FIRST IN LINKED 09800790 + % LIST OF DECLARLD INTERRUPTS 09800795 + SFINTQ =27[*], % SOFTWARE INTERRUPT QUEUE 09800800 + PRTBASE =10[*]; 09800900 + LABEL AGAIN; 09800920 + DEFINE IMASK = @200000000000000#; 09800940 +% * * * * * * * * * * * S T A R T H E R E * * * * * * * * * * * * * * 09800950 + TSKA[8] ~ ABS(*P(DUP)) & 1 [3:47:1]; 09800955 + IF NOT TSKA[8].[4:1] THEN P([TSKA[8]],IMASK,2,COM,DEL,DEL); 09800970 + TSKA[8].[4:1] ~ 0; 09800980 + P(0,0,0,0); 09801000 +AGAIN: WHILE I1 THEN 00659700 - BEGIN FOR I~1 STEP 1 UNTIL LIBSIZE-1 DO 00659800 - BEGIN R~CONTENTS(LIBRARY,I ,ACCUM); 00659900 - FORMROW(0,1,ACCUM,2,6); 00660000 - END; TERPRINT; 00660100 - END ELSE FORMWD(3,"6 NULL."); 00660200 - %------------------------ END OF CASES ----------------------- 00660300 - END ELSE GO TO ERR1; 00660400 - IF CURRENTMODE=FUNCMODE THEN INDENT(-CURLINE); 00660500 - END ELSE 00660600 - IF QUOTE THEN EDITLINE ELSE 00660700 - ERR1: ERRORMESS(SYNTAXERROR,0,0); 00660800 - INDENT(0); 00660900 - TERPRINT; 00661000 - END; 00661100 -REAL PROCEDURE LINENUMBER(R); VALUE R; REAL R; 00661200 - BEGIN 00661300 - REAL STREAM PROCEDURE CON(R); VALUE R; 00661400 - BEGIN SI:=LOC R; DI:=LOC CON; DS:=8DEC 00661500 - END; 00661600 - LINENUMBER:=CON( ENTIER( (R+.00005)|10000)) 00661700 - END; 00661800 -DEFINE DELIM="""#, ENDCHR="$"#; 00661900 -BOOLEAN PROCEDURE WITHINALINE(COMMAND,OLD,NEW,CHAR,WORD); 00662000 - VALUE COMMAND,CHAR,WORD; INTEGER COMMAND,CHAR,WORD; 00662100 - ARRAY OLD, NEW[0]; BEGIN 00662200 -BOOLEAN STREAM PROCEDURE WITHINLINE(COMMAND,OLD,NEW,CHAR,WORD); 00662300 - VALUE COMMAND,CHAR,WORD; 00662400 - BEGIN 00662500 - LOCAL OLDLINE,NEWLINE,F,BCHR; 00662600 - LOCAL N,M,T; 00662700 - LOCAL X,Y,Z; 00662800 - LABEL LOOKING,FOUND,BETWEEN,TAIL,FINISH, 00662900 - OVER; 00663000 - DI:=NEW; WORD(DS:=8LIT" "); 00663100 - SI:=LOC CHAR; DI:=LOC T; DI:=DI+1; DS:=7CHR; 00663200 - SI:=COMMAND; 00663300 - TALLY:=T; X:=TALLY; TALLY:=2; Y:=TALLY; TALLY:=32; Z:=TALLY; 00663400 - TALLY:=0; 00663500 - IF SC!"~" THEN 00663600 - BEGIN BCHR:=SI; SI:=OLD; OLDLINE:=SI; 00663700 - DI:=NEW; NEWLINE:=DI; SI:=BCHR; 00663800 - 63(IF SC=DELIM THEN JUMP OUT ELSE SI:=SI+1; TALLY 00663900 - :=TALLY+1); N:=TALLY; 00664000 - IF TOGGLE THEN 00664100 - BEGIN 00664200 - SI:=SI+1; TALLY:=0; 00664300 - 63(IF SC=DELIM THEN TALLY:=0 ELSE 00664400 - IF SC="~" THEN JUMP OUT ELSE TALLY:=TALLY+1; SI:=SI+1); 00664500 - IF TOGGLE THEN M:=TALLY;; 00664600 - DI:=OLDLINE; SI:=BCHR; 00664700 - 2( X( Y( Z( CI:=CI+F; 00664800 - GO LOOKING; GO FOUND; GO BETWEEN; GO TAIL; GO FINISH; 00664900 -LOOKING: %************ LOOKING FOR THE FIRST UNIQUE STRING**************00665000 - IF SC=DELIM THEN BEGIN SI:=SI+1; TALLY:=2; F:= TALLY ; 00665100 - DI:=NEWLINE; GO BETWEEN END ELSE 00665200 - IF N SC=DC THEN BEGIN SI:=OLDLINE; SI:=SI+N; OLDLINE:=SI; 00665300 - DI:=NEWLINE; SI:=BCHR; TALLY:=1; F:=TALLY; 00665400 - GO FOUND END ELSE 00665500 - BEGIN SI:=OLDLINE; DI:=NEWLINE; DS:=CHR; NEWLINE:=DI; 00665600 - OLDLINE:=SI; SI:=BCHR; DI:=OLDLINE; 00665700 - END; GO OVER; 00665800 -FOUND: %**************FOUND THE FIRST UNIQUE STRING ******************00665900 - IF SC=DELIM THEN BEGIN SI:=SI+1; TALLY:=2; 00666000 - F:=TALLY; GO BETWEEN END ELSE 00666100 - DS:=CHR; GO OVER; 00666200 -BETWEEN: % ********** BETWEEN THEN // *********************************00666300 - IF SC=DELIM THEN BEGIN SI:=SI+1; NEWLINE:=DI; DI:=OLDLINE; 00666400 - TALLY:=3; F:=TALLY; GO TAIL END ELSE 00666500 - IF SC="~" THEN BEGIN TALLY:=4; F:=TALLY; 00666600 - SI:=OLDLINE; GO FINISH END ELSE 00666700 - DS:=CHR; GO OVER; 00666800 -TAIL: % ******* THE TAIL END OF THE COMMAND ***************************00666900 - IF M SC=DC THEN BEGIN DI:=NEWLINE; SI:=OLDLINE; TALLY:=4; 00667000 - F:=TALLY; GO FINISH END ELSE 00667100 - BEGIN SI:=SI-M; DI:=DI-M; DI:=DI+1; OLDLINE:=DI; END; 00667200 - GO OVER; 00667300 -FINISH: % ********FINISH UP THE CHAR MOVE FROM OLD TO NEW*************00667400 - DS:=CHR; OVER:))); 00667500 - TALLY:=CHAR; X:=TALLY; TALLY:=1; Y:=TALLY; 00667600 - Z:=TALLY); 00667700 - SI:=NEW; DI:=OLD; DS:=WORD WDS; TALLY:=1; 00667800 - WITHINLINE:=TALLY; 00667900 - END 00668000 - END 00668100 - END OF WITHINALINE; 00668200 - WITHINALINE := WITHINLINE(COMMAND,OLD,NEW,CHAR,WORD); 00668300 - END OF PHONY WITHINALINE; 00668400 -PROCEDURE EDITLINE; 00668500 - BEGIN ARRAY T[0:MAXBUFFSIZE]; 00668600 - INITBUFF(T,BUFFSIZE); 00668700 - TRANSFER(OLDBUFFER,0,T,0,LENGTH(OLDBUFFER,TRUE)); 00668800 - IF WITHINALINE(ADDRESS,T,OLDBUFFER,BUFFSIZE|8,BUFFSIZE) THEN 00668900 - BEGIN MOVEWDS(OLDBUFFER,BUFFSIZE,BUFFER); 00669000 - 00669100 - IF SCAN AND RGTPAREN THEN 00669200 - ERRORMESS(SYNTAXERROR,LADDRESS,0) ELSE EDITOG:=1; 00669300 - END; 00669400 - 00669500 - 00669600 - FORMROW(3,0,BUFFER,0,LENGTH(BUFFER,FALSE)); 00669700 - END; 00669800 -PROCEDURE CHECKSEQ(SEQ,L,INC); REAL SEQ,L,INC; 00669900 - BEGIN 00670000 - INTEGER I,J; 00670100 - I:=L|10000 MOD 10000; 00670200 - FOR J:=-4 STEP 1 WHILE J LSS 0 AND I MOD 10=0 DO 00670300 - I:=I/10; 00670400 - INC:=10*J; 00670500 - SEQ:=L; 00670600 - END; 00670700 -PROCEDURE FUNCTIONHANDLER; 00670800 - BEGIN 00670900 - LABEL ENDHANDLER; 00671000 - OWN BOOLEAN EDITMODE; 00671100 - DEFINE FPT=FUNCPOINTER#, 00671200 - FSQ=FUNCSEQ#, 00671300 - SEQ=CURLINE#, 00671400 - INC=INCREMENT#, 00671500 - MODE=SPECMODE#, 00671600 - ENDDEFINES=#; 00671700 - INTEGER STREAM PROCEDURE DELPRESENT(ADDR); VALUE ADDR; 00671800 - BEGIN LABEL L,FINIS; 00671900 - LOCAL Q; 00672000 - DI:=LOC Q; DS:=RESET; DS:=5SET; DS:=2RESET; DS:=2SET; 00672100 - % LEFT-ARROW / QUESTION MARK 00672200 - SI:=ADDR; 00672300 - L: DI:=LOC Q; 00672400 - IF SC=DELCHR THEN 00672500 - BEGIN ADDR:=SI; SI:=LOC Q; DI:=ADDR; DS:=LIT" "; 00672600 - TALLY:=1; DELPRESENT:=TALLY; GO TO FINIS; 00672700 - END; 00672800 - IF SC=DC THEN GO TO FINIS; SI:=SI-1; 00672900 - IF SC=DC THEN GO TO FINIS; 00673000 - GO TO L; 00673100 - FINIS: 00673200 - END; 00673300 -INTEGER PROCEDURE OLDLABCONFLICT(PT,S); VALUE PT,S; 00673400 - INTEGER PT; REAL S; 00673500 - IF PT NEQ 0 THEN 00673600 - BEGIN INTEGER K; ARRAY L[0:1]; 00673700 - ADDRESS:=ABSOLUTEADDRESS; 00673800 - WHILE LABELSCAN(L,0) AND ERR EQL 0 DO 00673900 - IF SEARCHORD(PT,L,K,8)=0 THEN 00674000 - IF L[1] NEQ S THEN ERR:=24; 00674100 - OLDLABCONFLICT:=ERR 00674200 - END; 00674300 -INTEGER PROCEDURE ELIMOLDLINE(PT,SQ,L); VALUE PT,SQ,L; INTEGER PT, 00674400 - SQ,L; FORWARD; 00674500 -INTEGER PROCEDURE STOREAWAY(PT,SQ,B,SEQ); VALUE SEQ; 00674600 - INTEGER PT,SQ; REAL SEQ; ARRAY B[0]; FORWARD; 00674700 - PROCEDURE BUFFERCLEAN(BUFFER,BUFFSIZE,ADDR); VALUE BUFFSIZE, 00674800 - ADDR; REAL ADDR; INTEGER BUFFSIZE; ARRAY BUFFER[0]; 00674900 - FORWARD; COMMENT THIS IS A PHONEY DEAL, BUT I CAN"T 00675000 - DECLARE CLEANBUFFER FORWARD (MOVE IT UP HERE LATER); 00675100 -PROCEDURE EDITDRIVER(PT,SQ,I,K); VALUE PT,SQ,I,K; 00675200 - INTEGER PT,SQ,I,K; 00675300 - BEGIN ARRAY C,LAB[0:1],OLD,NEW[0:MAXBUFFSIZE]; 00675400 - STREAM PROCEDURE BL(A); 00675500 - BEGIN DI:=A; MAXBUFFSIZE(DS:=8LIT" ") END; 00675600 - DEFINE MOVE=MOVEWDS#; 00675700 - REAL T,SEQ; INTEGER A,B,L,M; 00675800 - T:=ADDRESS; 00675900 - FOR A:=I STEP 1 WHILE A LEQ K AND EDITMODE DO 00676000 - BEGIN B:=CONTENTS(PT,A,C); BL(OLD); 00676100 - SEQ:=C[0]; 00676200 - B:=CONTENTS(SQ,C[1],OLD); 00676300 - IF EDITMODE:=WITHINALINE(T,OLD,NEW,BUFFSIZE|8,BUFFSIZE) 00676400 - THEN BEGIN MOVE(BUFFER,MAXBUFFSIZE+1,NEW); 00676500 - MOVE(OLD,MAXBUFFSIZE,BUFFER); 00676600 - IF EDITMODE:=ERR:=OLDLABCONFLICT(PT,C[0])=0 THEN 00676700 - BEGIN B:=ELIMOLDLINE(PT,SQ,C[1]); 00676800 - DELTOG:=DELPRESENT(ADDRESS); 00676900 - DELETE1(SQ,C[1]); DELETE1(PT,A+B); C[1]:= 00677000 - STORESEQ(SQ,BUFFER,LENGTH(BUFFER,FALSE)); 00677100 - STOREORD(PT,C,A+B); 00677200 - RESCANLINE; L:=0; M:=1; LAB[1]:=C[0]; 00677300 - WHILE LABELSCAN(C,0) DO 00677400 - BEGIN MOVEWDS(C,1,LAB); 00677500 - IF(IF FUNCSIZE=0 THEN TRUE ELSE L:= 00677600 - SEARCHORD(PT,C,M,8)NEQ 0) THEN 00677700 - BEGIN B:=B+1; FUNCSIZE:=FUNCSIZE+1; 00677800 - STOREORD(PT,LAB,L+M-1) 00677900 - END END; 00678000 - A:=A+B; K:=K+B; 00678100 - COMMENT THE NEXT LINE CAUSE A SYSTEM CRASH AFTER THE EDIT; 00678200 - IF NOSYNTAX=0 THEN PROCESS(XEQUTE); 00678300 - END END; 00678400 - MOVE(NEW,MAXBUFFSIZE+1,BUFFER) 00678500 - END END; 00678600 - PROCEDURE LISTLINE(PT,SQ,I); VALUE PT,SQ,I; INTEGER PT,SQ,I; 00678700 - BEGIN 00678800 - GT1:=CONTENTS(PT,I,GTA); 00678900 - INDENT(GTA[0]); 00679000 - GT1:=CONTENTS(SQ,GTA[1],BUFFER); 00679100 - CHRCOUNT:=CHRCOUNT-1; 00679200 - FORMROW(1,0,BUFFER,0,GT1); 00679300 - END; 00679400 -INTEGER PROCEDURE DISPLAY(A,B,PT,SQ); VALUE A,B,PT,SQ; 00679500 - INTEGER PT,SQ; REAL A,B; 00679600 - IF A LEQ B AND FUNCSIZE NEQ 0 THEN 00679700 - BEGIN 00679800 - ARRAY C[0:1]; 00679900 - INTEGER I,J,K; 00680000 - DEFINE CLEANBUFFER=BUFFERCLEAN#; 00680100 - A:=LINENUMBER(A); B:=LINENUMBER(B); 00680200 - C[0]:=A; 00680300 - I:=SEARCHORD(PT,C,K,8); 00680400 - I:=( IF I=2 THEN IF K LSS FUNCSIZE-1 THEN K:=K+1 ELSE 00680500 - K ELSE K); 00680600 - IF A NEQ B THEN 00680700 - BEGIN 00680800 - C[0]:=B; B:=SEARCHORD(PT,C,K,8); 00680900 - END; 00681000 - IF EDITMODE THEN % MAY HAVE ONLY ONE LINE TO EDIT 00681100 - IF I=K THEN 00681200 - IF A NEQ 0 THEN %NOT EDITING THE HEADER 00681300 - EDITDRIVER(PT,SQ,I,K) 00681400 - ELSE %EDITING THE FUNCTION HEADER, FIX LATER. 00681500 - ERR:=31 00681600 - ELSE %EDITING MORE THAN ONE LINE 00681700 - BEGIN MODE:=EDITING; 00681800 - IF A=0 THEN I:=I+1; 00681900 - CLEANBUFFER(BUFFER,BUFFSIZE,ADDRESS); 00682000 - MOVE(BUFFER,BUFFSIZE,OLDBUFFER); 00682100 - LOWER:=I; UPPER:=K 00682200 - END 00682300 - ELSE %NOT EDITING, MUST BE A LIST 00682400 - BEGIN 00682500 - FORMWD(3,"1 "); 00682600 - IF K=I THEN % LISTING A SINGLE LINE 00682700 - BEGIN LISTLINE(PT,SQ,I); 00682800 - FORMWD(3,"1 "); 00682900 - END ELSE % LISTING A SET OF LINES 00683000 - BEGIN MODE:=DISPLAYING; 00683100 - LOWER:=I; UPPER:=K; 00683200 - END; 00683300 - END; 00683400 - EOB:=1; 00683500 - END ELSE DISPLAY:=20; 00683600 -INTEGER PROCEDURE DELETE(A,B,PT,SQ); VALUE A,B; 00683700 - INTEGER PT,SQ; REAL A,B; 00683800 - IF A LEQ B AND FUNCSIZE NEQ 0 AND A NEQ 0 THEN 00683900 - BEGIN 00684000 - INTEGER I,J,K,L; 00684100 - ARRAY C[0:1]; 00684200 - A:=LINENUMBER(B); 00684300 - B:=LINENUMBER(B); 00684400 - C[0]:=A; 00684500 - IF SEARCHORD(PT,C,K,8)=2 THEN K:=K+1; 00684600 - C[0]:=B; 00684700 - IF SEARCHORD(PT,C,I,8)=1 THEN I:=I-1; 00684800 - IF K GTR I OR I GEQ FUNCSIZE THEN DELETE:=21 ELSE 00684900 - BEGIN 00685000 - FOR J:=K STEP 1 UNTIL I DO 00685100 - BEGIN A:=CONTENTS(PT,J,C); 00685200 - L:=ELIMOLDLINE(PT,SQ,C[1]); 00685300 - FUNCSIZE:=FUNCSIZE+L; I:=I+L; K:=K+L; J:=J+L; 00685400 - DELETE1(SQ,C[1]) 00685500 - END; 00685600 - FUNCSIZE:=FUNCSIZE-(I-K+1) 00685700 - ; EOB:=1; 00685800 - DELETEN(PT,K,I); 00685900 - IF FUNCSIZE=0 THEN 00686000 - BEGIN 00686100 - PT:=0; RELEASEUNIT(SQ); SQ:=0; 00686200 - STOREPSR; 00686300 - END; 00686400 - END; 00686500 - END ELSE DELETE:=22; 00686600 - INTEGER PROCEDURE ELIMOLDLINE(PT,SQ,L); VALUE PT,SQ,L; 00686700 - INTEGER PT,SQ,L; 00686800 - BEGIN INTEGER K,J; 00686900 - REAL AD; 00687000 - ARRAY T[0:MAXBUFFSIZE],LAB[0:1]; 00687100 - AD:=ADDRESS; 00687200 - MOVEWDS(BUFFER,MAXBUFFSIZE+1,T); 00687300 - INITBUFF(BUFFER,BUFFSIZE); 00687400 - K:=CONTENTS(SQ,L,BUFFER); 00687500 - RESCANLINE; 00687600 - WHILE LABELSCAN(LAB,0) DO 00687700 - IF SEARCHORD(PT,LAB,K,8)=0 THEN 00687800 - BEGIN DELETE1(PT,K); J:=J-1 END; 00687900 - ADDRESS:=AD; 00688000 - MOVEWDS(T,MAXBUFFSIZE+1,BUFFER); 00688100 - ELIMOLDLINE:=J 00688200 - END; 00688300 -INTEGER PROCEDURE STOREAWAY(PT,SQ,B,SEQ); VALUE SEQ; 00688400 - INTEGER PT,SQ; REAL SEQ; ARRAY B[0]; 00688500 - BEGIN DEFINE BUFFER=B#; 00688600 - ARRAY C,LAB[0:1]; 00688700 - INTEGER I,J,K,L; 00688800 - BOOLEAN TOG; 00688900 - SEQ:=LINENUMBER(SEQ); 00689000 - C[0]:=SEQ; 00689100 - IF TOG:=(PT=0 OR FUNCSIZE=0) THEN 00689200 - BEGIN SEQUENTIAL(SQ:=NEXTUNIT); I:=0 00689300 - END ELSE 00689400 - IF J:=SEARCHORD(PT,C,I,8)=0 THEN 00689500 - BEGIN 00689600 - K:=ELIMOLDLINE(PT,SQ,C[1]); 00689700 - I:=I+K; FUNCSIZE:=FUNCSIZE+K; 00689800 - DELETE1(PT,I); 00689900 - FUNCSIZE:=FUNCSIZE-1; 00690000 - DELETE1(SQ,C[1]); 00690100 - END ELSE 00690200 - I:=I+J-1; 00690300 - RESCANLINE; 00690400 - DELTOG:=DELPRESENT(ADDRESS); 00690500 - K:=STORESEQ(SQ,BUFFER,LENGTH(BUFFER,TRUE)); 00690600 - LAB[1]:=SEQ; L:=0; J:=1; 00690700 - IF TOG THEN PT:=NEXTUNIT; 00690800 - WHILE LABELSCAN(C,0) DO 00690900 - BEGIN 00691000 - MOVEWDS(C,1,LAB); 00691100 - IF (IF FUNCSIZE=0 THEN TRUE ELSE L:= 00691200 - SEARCHORD(PT,C,J,8)NEQ 0 ) THEN 00691300 - BEGIN I:=I+1; FUNCSIZE:=FUNCSIZE+1; 00691400 - STOREORD(PT,LAB,L+J-1); 00691500 - END; 00691600 - END; 00691700 - C[1]:=K; 00691800 - C[0]:=SEQ; 00691900 - FUNCSIZE:=FUNCSIZE+1; 00692000 - STOREORD(PT,C,I); 00692100 - IF TOG THEN STOREPSR; 00692200 - EOB:=1; 00692300 - END; 00692400 - BOOLEAN PROCEDURE BOUND(PT); VALUE PT; INTEGER PT; 00692500 - IF NOT(BOUND:=NUMERIC) THEN 00692600 - IF IDENT AND FUNCSIZE GTR 0 THEN 00692700 - BEGIN ARRAY L[0:1]; INTEGER K; 00692800 - REAL T,U; 00692900 - REAL STREAM PROCEDURE CON(A); 00693000 - VALUE A; 00693100 - BEGIN SI:=LOC A; DI:=LOC CON; DS:=8OCT 00693200 - END; 00693300 - TRANSFER(ACCUM,2,L,1,7); 00693400 - IF BOUND:=SEARCHORD(PT,L,K,8)=0 THEN 00693500 - BEGIN T:=ADDRESS; 00693600 - U:=CON(MAX(L[1],0))/10000; %ARGS AND RESULT ARE NEG 00693700 - IF SCAN AND PLUS OR MINUS THEN 00693800 - BEGIN K:=(IF PLUS THEN 1 ELSE -1); 00693900 - IF SCAN AND NUMERIC THEN 00694000 - ACCUM[0]:=MAX(U+K|ACCUM[0],0) ELSE 00694100 - BEGIN ACCUM[0]:=U; 00694200 - ADDRESS:=T; 00694300 - END; 00694400 - END ELSE BEGIN ACCUM[0]:=U; ADDRESS:=T; 00694500 - END; 00694600 - EOB:=0; 00694700 - END 00694800 - END; 00694900 - 00695000 - 00695100 - PROCEDURE FINISHUP; 00695200 - BEGIN COMMENT GET HIM BACK TO CALCULATOR MODE; 00695300 - IF FUNCPOINTER=0 THEN % HE DELETED EVERY THING 00695400 - BEGIN TRANSFER(PSR,FSTART|8,GTA,0,8); 00695500 - IF SEARCHORD(VARIABLES,GTA,GT1,7)=0 THEN 00695600 - BEGIN DELETE1(VARIABLES,GT1); 00695700 - IF VARSIZE:=VARSIZE-1=0 THEN VARIABLES:=0; 00695800 - END ELSE SPOUT(9198260); 00695900 - END; 00696000 - DELTOG:=CURRENTMODE:=CURLINE:=INCREMENT:=0; 00696100 - STOREPSR; 00696200 - END; 00696300 - 00696400 - LABEL SHORTCUT; 00696500 - REAL L,U,TADD; 00696600 - STREAM PROCEDURE CLEANBUFFER(BUFFER,BUFFSIZE,ADDR); 00696700 - VALUE BUFFSIZE,ADDR; 00696800 - BEGIN LABEL L; LOCAL T,U,TSI,TDI; 00696900 - SI:=ADDR; SI:=SI-1; L: 00697000 - IF SC NEQ "]" THEN 00697100 - BEGIN SI:=SI-1; GO TO L END; 00697200 - SI:=SI+1; DI:=LOC T; SKIP 2 DB; DS:=2SET; 00697300 - DI:=BUFFER; TDI:=DI; DI:=LOC T; TSI:=SI; 00697400 - BUFFSIZE(8(IF TOGGLE THEN DS:=LIT" " ELSE 00697500 - IF SC=DC THEN 00697600 - BEGIN SI:=LOC U; DI:=TDI; DS:=LIT" " 00697700 - END ELSE 00697800 - BEGIN TSI:=SI; SI:=SI-1; DI:=LOC U; DS:=CHR; 00697900 - DI:=TDI; SI:=LOC U; DS:=CHR; TDI:=DI; DI:=LOC T; 00698000 - SI:=TSI; 00698100 - END)) 00698200 - END; 00698300 - PROCEDURE BUFFERCLEAN(BUFFER,BUFFSIZE,ADDR); VALUE BUFFSIZE, 00698400 - ADDR; REAL ADDR; INTEGER BUFFSIZE; ARRAY BUFFER[0]; 00698500 - CLEANBUFFER(BUFFER,BUFFSIZE,ADDR); 00698600 -COMMENT DETERMINE WHETHER OR NOT WE CAME FROM CALCULATOR MODE; 00698700 - ERR:=0; 00698800 - IF BOOLEAN(SUSPENSION) THEN GO TO ENDHANDLER; 00698900 - BEGIN DEFINE STARTSEGMENT=#; %/////////////////////////////// 00699000 - IF GT1:=CURRENTMODE=CALCMODE THEN % TAKE CARE OF HEADER. 00699100 - BEGIN ARRAY A[0:MAXHEADERARGS]; 00699200 - LABEL HEADERSTORE,FORGETITFELLA; 00699300 - IF FUNCTIONHEADER(A,TADD) THEN %HEADER OK 00699400 - IF VARIABLES NEQ 0 THEN % MAY BE A RE-DEFINITION 00699500 - BEGIN COMMENT GET THE FUNCTION NAME; 00699600 - TRANSFER(A,1,GTA,0,7); 00699700 - IF GT2:=SEARCHORD(VARIABLES,GTA,GT3,7)=0 THEN 00699800 - COMMENT RE-DEFINING A FUNCTION. MAKE SURE NULL ; 00699900 - IF GETFIELD(GTA,7,1)=FUNCTION AND 00700000 - (A[1]+A[2]+A[3])=0 THEN %NULL HEADER--OK 00700100 -%--------------------SET UP FOR CONTINUATION OF DEFINITION------ 00700200 - BEGIN 00700300 - FUNCPOINTER:=GETFIELD(GTA,FPTF,FFL); 00700400 - FUNCSEQ:=GETFIELD(GTA,FSQF,FFL); 00700500 - GT3:=CURLINE:=TOPLINE(FPT); 00700600 - CHECKSEQ(CURLINE,GT3,INC); %SET THE INCREMENT 00700700 - COMMENT THE CURRENT LINE IS SET TO THE LAST LINE OF THE 00700800 - FUNCTION; 00700900 - FUNCSIZE:=SIZE(FPT); 00701000 - CURLINE:=CURLINE+INC; 00701100 - DELTOG:=DELPRESENT(ADDRESS); 00701200 - END ELSE 00701300 -%------------------REDEFINING THE HEADER OF A DEFINED FUNCTION---- 00701400 - GO TO FORGETITFELLA 00701500 - ELSE 00701600 -%--------------------NAME NOT FOUND IN DIRECTORY, SET UP 00701700 -HEADERSTORE: 00701800 - BEGIN COMMENT GET THE HEADER TO INSERT AT LINE 0; 00701900 - ARRAY OLDBUFFER[0:MAXBUFFSIZE]; 00702000 - INTEGER L,U,F,K,J; 00702100 - INTEGER A1,A2; 00702200 - COMMENT FUNCTIONHEADER RETURN AN ARRAY WITH THE 00702300 - FOLLOWING VALUES: 00702400 - A[0] = FUNCTION NAME , I.E., 0AAAAAAA 00702500 - A[1] = 0 IF NO RESULT, 1 IF A RESULT IS RETURNED BY THE 00702600 - FUNCTION. 00702700 - A[2] = NUMBER OF ARGUMENTS TO THE FUNCTION. 00702800 - A[3] = NUMBER OF LOCALS + RESULT +ARGUMENTS. 00702900 - A[4]....A[N] ARE ALL OF THE LOCALS, RESULT, AND ARGUMENTS. 00703000 - THE RESULT IS FIRST, THEN THE SECOND ARGUMENT, THEN 00703100 - THE FIRST ARGUMENT, FOLLOWED BY THE LOCALS. ALL 00703200 - ARE OF THE FORM 0XXXXXXX; 00703300 - U:=(A1:=A[1])+(A2:=A[2])+3; 00703400 - FOR L:=4 STEP 1 UNTIL U DO %LOOK FOR DUPLICATES AMONG 00703500 - FOR K:=L+1 STEP 1 UNTIL U DO %THE RESULT/ARGUMENT SET 00703600 - IF A[L]=A[K] THEN GO TO FORGETITFELLA; 00703700 - SEQUENTIAL(FUNCSEQ:=NEXTUNIT); 00703800 - SETFIELD(GTA,8,8,STORESEQ(FUNCSEQ,OLDBUFFER, 00703900 - HEADER(TADD.[1:23],TADD.[24:24],OLDBUFFER))); 00704000 - SETFIELD(GTA,0,8,0); 00704100 - STOREORD(F:=FUNCPOINTER:=NEXTUNIT,GTA,0); 00704200 - SETFIELD(GTA,0,8,0); SETFIELD(GTA,8,8,0); 00704300 - FOR L:=4 STEP 1 UNTIL U DO 00704400 - BEGIN GTA[0]:=A[L]; IF A1 GTR 0 THEN 00704500 - BEGIN A1:=0; GTA[1]:=-1; %"RESULT" SET TO -1 00704600 - STOREORD(F,GTA,0); 00704700 - END ELSE %LOOKING AT THE ARGUMENTS 00704800 - BEGIN K:=SEARCHORD(F,GTA,J,8); 00704900 - GTA[1]:=A2-4; A2:=A2-1; GTA[0]:=A[L]; 00705000 - STOREORD(F,GTA,J+K-1); 00705100 - END END; 00705200 - FUNCSIZE:=U:=U-2; U:=A[3]-U+L; 00705300 - FOR L:=L STEP 1 UNTIL U DO %GET LOCALS INTO THE LABEL TABLE 00705400 - BEGIN GTA[0]:=A[L]; 00705500 - IF K:=SEARCHORD(F,GTA,J,8) NEQ 0 THEN %NOT YET IN TABLE. 00705600 - BEGIN GTA[0]:=A[L]; GTA[1]:=0; 00705700 - STOREORD(F,GTA,J+K-1); 00705800 - FUNCSIZE:=FUNCSIZE+1 00705900 - END; 00706000 - END; 00706100 - GTA[1]:=0&ENTIER(A[1])[CRETURN]&ENTIER(A[2])[CNUMBERARGS]; 00706200 - CURLINE:=INCREMENT:=1; 00706300 - DELTOG:=0; 00706400 - COMMENT GET THE "TYPE" OF THE FUNCTION LATER WHEN THERE 00706500 - IS A PLACE FOR IT. THE TYPE IS EITHER 1 (FUNCTION CALL), OR 00706600 - 0 (SUBROUTINE CALL); 00706700 - END; 00706800 -%-------------------------------------------------------- 00706900 - END ELSE % VARAIBLES=0, MAKE UP A DIRECTORY 00707000 - BEGIN GT3:=0; GT2:=1; GO TO HEADERSTORE 00707100 - END 00707200 - ELSE % HEADER SYNTAX IS BAD 00707300 - GO TO ENDHANDLER; 00707400 - COMMENT WE MAKE IT TO HERE IF ALL IS WELL ABOVE; 00707500 - IF GT2 NEQ 0 THEN %NAME NOT FOUND IN DIRECTORY; 00707600 - BEGIN 00707700 - TRANSFER(A,1,GTA,0,7); %GET FUNCTION NAME 00707800 - SETFIELD(GTA,7,1,FUNCTION); 00707900 - SETFIELD(GTA,FPTF,FFL,FUNCPOINTER); 00708000 - SETFIELD(GTA,FSQF,FFL,FUNCSEQ); 00708100 - IF VARIABLES=0 THEN 00708200 - VARIABLES:=NEXTUNIT; 00708300 - STOREORD(VARIABLES,GTA,GT3+GT2-1); 00708400 - VARSIZE:=VARSIZE+1; 00708500 - END; 00708600 - CURRENTMODE:=FUNCMODE; 00708700 - TRANSFER(GTA,0,PSR,FSTART|8,8); 00708800 - STOREPSR; 00708900 - IF SCAN THEN GO TO SHORTCUT; 00709000 - IF FALSE THEN 00709100 - FORGETITFELLA: ERRORMESS(ERR:=LABELERROR,TADD.[1:23],0); 00709200 - END ELSE % WE ARE IN FUNCTION DEFINITION MODE 00709300 - IF GT1:=MODE NEQ 0 THEN % A SPECIAL FUNCTION SUCH AS DISPLAY OR EDIT00709400 - BEGIN L:=LOWER; 00709500 - IF GT1=DISPLAYING THEN 00709600 - LISTLINE(FPT,FSQ,L) ELSE 00709700 - IF GT1=EDITING THEN 00709800 - BEGIN INITBUFF(BUFFER,BUFFSIZE); 00709900 - MOVE(OLDBUFFER,BUFFSIZE,BUFFER); 00710000 - EDITMODE:=TRUE; ADDRESS:=ABSOLUTEADDRESS; 00710100 - EDITDRIVER(FPT,FSQ,L,L) 00710200 - ;IF NOT EDITMODE THEN 00710300 - BEGIN MODE:=0; ERR:=30 00710400 - END; 00710500 - END ELSE 00710600 - IF GT1=RESEQUENCING THEN 00710700 - IF GT1:=L LEQ UPPER THEN 00710800 - BEGIN GT2:=CONTENTS(FPT,L,GTA); 00710900 - GT3:=GTA[0]:=LINENUMBER(CURLINE); 00711000 - DELETE1(FPT,L); 00711100 - STOREORD(FPT,GTA,L); 00711200 - CURLINE:=CURLINE+INCREMENT; 00711300 - GT2:=CONTENTS(FSQ,GTA[1],BUFFER); RESCANLINE; 00711400 - WHILE (IF ERR NEQ 0 THEN FALSE ELSE 00711500 - LABELSCAN(GTA,0)) DO 00711600 - IF GT1:=SEARCHORD(FPT,GTA,GT2,8)=0 THEN 00711700 - BEGIN GTA[1]:=GT3; DELETE1(FPT,GT2); 00711800 - STOREORD(FPT,GTA,GT2) 00711900 - END ELSE ERR:=16 00712000 - END 00712100 - ELSE MODE:=0; 00712200 - LOWER:=L+1; 00712300 - IF LOWER GTR UPPER THEN 00712400 - BEGIN IF MODE=DISPLAYING THEN 00712500 - FORMWD(3,"1 "); 00712600 - MODE:=0; 00712700 - END; 00712800 - GO TO ENDHANDLER 00712900 - END; 00713000 - END ; % OF BLOCK STARTED ON LINE 9225115 ////////////////// 00713100 - 00713200 - 00713300 - 00713400 - IF ERR=0 AND EOB=0 THEN 00713500 - 00713600 -SHORTCUT: BEGIN LABEL RGTBRACK,DELOPTION; %////////////////////////// 00713700 - IF DELV THEN FINISHUP ELSE 00713800 - IF LFTBRACKET THEN 00713900 - BEGIN 00714000 - IF SCAN THEN 00714100 - IF BOUND(FPT) THEN 00714200 - BEGIN L:=ACCUM[0]; 00714300 - IF SCAN THEN 00714400 - IF QUADV OR EDITMODE:=(QUOTEQUAD) THEN 00714500 - IF SCAN THEN 00714600 - IF BOUND(FPT) THEN 00714700 - BEGIN U:=ACCUM[0]; 00714800 -RGTBRACK: 00714900 - IF SCAN AND RGTBRACKET THEN 00715000 - IF(IF EDITMODE THEN FALSE ELSE SCAN) THEN 00715100 - IF DELV THEN 00715200 - BEGIN ERR:=DISPLAY(L,U,FPT,FSQ); 00715300 - DELTOG:=1; 00715400 - END 00715500 - ELSE ERR:=1 00715600 - ELSE ERR:=DISPLAY(L,U,FPT,FSQ) 00715700 - ELSE ERR:=2 00715800 - END 00715900 - ELSE 00716000 - IF RGTBRACKET THEN 00716100 - IF(IF EDITMODE THEN FALSE ELSE SCAN) THEN 00716200 - IF DELV THEN 00716300 - BEGIN ERR:=DISPLAY(L,L,FPT,FSQ); 00716400 - DELTOG:=1; 00716500 - END 00716600 - ELSE ERR:=3 00716700 - ELSE ERR:=DISPLAY(L,L,FPT,FSQ) 00716800 - ELSE ERR:=4 00716900 - ELSE ERR:=5 00717000 - ELSE 00717100 - IF RGTBRACKET THEN 00717200 - BEGIN TADD:=ADDRESS; 00717300 - IF SCAN THEN 00717400 - IF IDENT AND ACCUM[0]="6DELETE" THEN 00717500 - IF SCAN THEN 00717600 - IF LFTBRACKET THEN 00717700 -DELOPTION: 00717800 - IF SCAN AND BOUND(FPT) THEN 00717900 - BEGIN U:=ACCUM[0]; 00718000 - IF SCAN AND RGTBRACKET THEN 00718100 - IF SCAN THEN 00718200 - IF DELV THEN 00718300 - BEGIN ERR:=DELETE(L,U,FPT,FSQ); 00718400 - FINISHUP 00718500 - END 00718600 - ELSE ERR:=6 00718700 - ELSE ERR:=DELETE(L,U,FPT,FSQ) 00718800 - ELSE ERR:=7 00718900 - END 00719000 - ELSE ERR:=8 00719100 - ELSE 00719200 - IF DELV THEN 00719300 - BEGIN ERR:=DELETE(L,L,FPT,FSQ); 00719400 - FINISHUP 00719500 - END 00719600 - ELSE ERR:=9 00719700 - ELSE ERR:=DELETE(L,L,FPT,FSQ) 00719800 - ELSE 00719900 - IF LFTBRACKET THEN GO TO DELOPTION ELSE 00720000 - BEGIN CHECKSEQ(SEQ,L,INC); 00720100 - CLEANBUFFER(BUFFER,BUFFSIZE,TADD); 00720200 - ADDRESS:=ABSADDR(BUFFER); ITEMCOUNT:=0; 00720300 - IF SCAN THEN GO TO SHORTCUT 00720400 - END 00720500 - ELSE ERR:=DELETE(L,L,FPT,FSQ) 00720600 - END 00720700 - ELSE ERR:=10 00720800 - ELSE ERR:=11 00720900 - END ELSE 00721000 - IF QUADV OR EDITMODE:=(QUOTEQUAD) THEN 00721100 - BEGIN L:=0; U:=9999.9999; GO TO RGTBRACK 00721200 - END ELSE 00721300 - IF IOTA THEN 00721400 - IF SCAN AND RGTBRACKET AND FPT NEQ 0 THEN 00721500 - BEGIN IF SCAN THEN 00721600 - IF DELV THEN DELTOG:=1 ELSE ERR:=15; 00721700 - IF ERR = 0 THEN 00721800 - BEGIN MODE:=RESEQUENCING; CURLINE:=INCREMENT:=1; 00721900 - SETFIELD(GTA,0,8,0); 00722000 - GT1:=SEARCHORD(FPT,GTA,GT2,8); 00722100 - LOWER:=GT2+1; UPPER:=FUNCSIZE-1; 00722200 - END 00722300 - END 00722400 - ELSE ERR:=14 00722500 - ELSE ERR:=12 00722600 - ELSE ERR:=13 00722700 - END 00722800 - ELSE 00722900 - IF CURLINE=0 THEN %CHANGING HEADER 00723000 - ERR:=26 ELSE 00723100 - IF ERR:=OLDLABCONFLICT(FPT,LINENUMBER(SEQ))=0 THEN 00723200 - BEGIN 00723300 - IF NOSYNTAX=0 THEN PROCESS(XEQUTE); 00723400 - IF ERR:=STOREAWAY(FPT,FSQ,BUFFER,SEQ)=0 THEN SEQ:=SEQ+INC; 00723500 - END; 00723600 - IF ERR NEQ 0 THEN 00723700 - BEGIN FORMWD(2,"5ERROR "); 00723800 - NUMBERCON(ERR,ACCUM); ERR:=0; 00723900 - EOB:=1; 00724000 - FORMROW(1,1,ACCUM,2,ACCUM[0].[1:11]); 00724100 - END; 00724200 - END; %OF BLOCK STARTED ON LINE 9238000 ////////////////////// 00724300 - ENDHANDLER: 00724400 - IF BOOLEAN(SUSPENSION) THEN BEGIN 00724500 - FILL ACCUM[*] WITH "ABORT SU", "SP. FNS."; 00724600 - FORMROW(3,0,ACCUM,0,16); INDENT(0); TERPRINT; 00724700 - END ELSE 00724800 - IF MODE=0 THEN 00724900 - BEGIN 00725000 - IF BOOLEAN(DELTOG) THEN FINISHUP; 00725100 - INDENT(-CURLINE); TERPRINT; 00725200 - END; 00725300 - 00725400 - END; 00725500 - EXPOVR:=FAULTL; INTOVR:=FAULTL; INDEXF:=FAULTL; 00725600 - FLAG:=FAULTL; ZERO:=FAULTL; 00725700 -INITIALIZETABLE; 00725800 -TRYAGAIN: 00725900 - IF FALSE THEN %ENTERS WITH A FAULT. 00726000 - FAULTL: 00726100 - BEGIN SPOUT(09334300); %SEND MESSAGE TO SPO 00726200 - 00726300 - BEGIN CSTATION.APLOGGED:=0; CSTATION.APLHEADING:=0 00726400 - END 00726500 - END; 00726600 - APLMONITOR; 00726700 -ENDOFJOB: 00726800 - 00726900 - FINIS: 00727000 - WRAPUP; 00727100 - 00727200 -END. 00727300 +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="1-11-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,10); 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 OCT5757575757575737;%CARRIAGE RETURNS LEFT ARROW00101430 + 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 + IF (LOGINSIZE:=SIZE(LOGINCODES)=0) THEN 00106100 + 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,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; 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