diff --git a/Mark-XVI/SYMBOL/FORTRAN.alg_m b/Mark-XVI/SYMBOL/FORTRAN.alg_m index a21dc35..e53c490 100644 --- a/Mark-XVI/SYMBOL/FORTRAN.alg_m +++ b/Mark-XVI/SYMBOL/FORTRAN.alg_m @@ -1165,7102 +1165,7069 @@ BEGIN LABEL L6; REAL L; 00723470 ELSE 00723595 IF BOOLEAN(L~REAL(REC[0]~REC[0]&REC[2] [1:26:1]=XTA)) THEN 00723610 BEGIN 00723620 - IF IT~IT+1=9 THEN 01855000 - BEGIN LASTLINE~FALSE; WRITE(LINE,15,PRINTBUFF[*]) ; 01856000 -L6: BLANKIT(PRINTBUFF,15,IT~0) ; 01857000 - END; 01858000 - SETPNT(REC[0],REC[1],PRINTBUFF,KLASS[REC[2].CLASS],TYPES[REC[2]01859000 - .SUBCLASS],IF BOOLEAN(REC[2]) THEN "*" ELSE " ",IT,L-1, 01860000 - LASTLINE,6-REC[2].[27:3]) ; 01861000 - END 01862000 - ELSE BEGIN 01863000 - LASTLINE~TRUE; WRITE(RITE,15,PRINTBUFF[*]); XTA~REC[0] ;01864000 - GO L6 ; 01865000 - END ; 01866000 -END OF PT ; 01867000 - 01868000 -PROCEDURE CHECKINFO; 01869000 -BEGIN REAL I, T, A; 01870000 - REAL LASTF; 01871000 - REAL INFB,INFC; 01872000 - LABEL NXT; ALPHA N; 01873000 - FORMAT INFOF( 3(A6, X2), 01874000 - " ADDRESS = ", A2, A4, 01875000 - ", LENGTH = ", I5, 01876000 - ", OFFSET = ", I5), 01877000 - INFOT( / "LOCAL IDENTIFIERS:"), 01878000 - LABF(A6,X10,"LABEL REL-ADR = ",I6,", SEGMNT = ",I5); 01879000 - IF PRTOG THEN 01880000 - WRITALIST(INFOT,0,0,0,0,0,0,0,0,0) ; 01881000 - IF I ~ SEARCH("ERR ") ! 0 THEN 01882000 - IF GET(I).CLASS = UNKNOWN THEN PUT(I+1, "......"); 01883000 - IF I ~ SEARCH("END ") ! 0 THEN 01884000 - IF GET(I).CLASS = UNKNOWN THEN PUT(I+1, "......"); 01885000 - IF NOT DCINPUT THEN IF I~SEARCH("ZIP ") ! 0 THEN 01886000 - IF GET(I).CLASS=UNKNOWN THEN PUT(I+1,"......") ; 01887000 - FOR I ~ 0 STEP 1 UNTIL NEXTCOM DO 01888000 - IF GETC(I).CLASS=HEADER THEN 01889000 - 01890000 - IF GETC(I).CE=1 THEN 01891000 - PUT((T~GETC(I+1).LINK+2),GET(T)&0[TOADINFO]) ; 01892000 - 01893000 - T ~ 2; WHILE T < NEXTINFO DO 01894000 - BEGIN 01895000 - GETALL(T,A,INFB,INFC); 01896000 - IF I ~ A.CLASS > FILEID THEN GO TO NXT; 01897000 - IF N ~ INFB = "......" THEN GO TO NXT; 01898000 - XTA ~ N; 01899000 - IF I = LABELID THEN 01900000 - BEGIN 01901000 - IF A > 0 THEN FLAG(19) ELSE 01902000 - IF PRTOG THEN WRITALIST(LABF,3,N,A.ADDR DIV 4,A.SEGNO,0,0,0,0, 01903000 - 0) ; 01904000 - GO TO NXT; 01905000 - END; 01906000 - IF I = FORMATID THEN 01907000 - IF A > 0 THEN BEGIN FLAG(62); GO TO NXT END ; 01908000 - IF I = NAMELIST THEN 01909000 - IF A > 0 THEN BEGIN FLAG(136); GO TO NXT END; 01910000 - IF I = ARRAYID THEN 01911000 - IF BOOLEAN(A.CE) THEN BEGIN IF A>0 THEN T~GETSPACE(T) END 01912000 - ELSE IF A<0 THEN 01913000 - IF BOOLEAN(A.FORMAL) THEN 01914000 - BEGIN IF SPLINK > 1 AND ELX > 1 THEN 01915000 - BEGIN % THIS IS A FORMAL PARAMETER FOR A SUBROUTINE OR A 01916000 - % FUNCTION THAT HAS ONE OR MORE ENTRY STATEMENT. THIS 01917000 - % PARAMETER WILL BE INITIALIZED TO AN ARRAY DESCRIPTOR01918000 - % TO 0 SO THAT IF THE PARAMETERS ARE NOT SET UP BY THE01919000 - % CALL ANY REFERENCE TO THEM WILL CAUSE AN INVALID 01920000 - % ADDRESS 01921000 - IF LASTF = 0 THEN % FIRST TIME THRU 01922000 - BEGIN LASTF ~ A.ADDR; 01923000 - EMITDESCLIT(2); EMITL(1); 01924000 - EMITD(50,DIA); EMITD(10,DIB); EMITD(10,TRB); 01925000 - END ELSE EMITPAIR(LASTF,LOD); 01926000 - EMITPAIR(A.ADDR,SND); 01927000 - END 01928000 - END 01929000 - ELSE ARRAYDEC(T); 01930000 - IF PRTOG THEN 01931000 - WRITALIST(INFOF,7,INFB, 01932000 - IF BOOLEAN(A.TYPEFIXED) THEN TYPES[A.SUBCLASS] ELSE " ", 01933000 - KLASS[A.CLASS], 01934000 - IF A.ADDR < 1024 AND A < 0 THEN "R+" ELSE " ", 01935000 - IF A < 0 THEN B2D(A.[26:10]) ELSE "NULL", 01936000 - INFC.SIZE, 01937000 - INFC.BASE,0); 01938000 - IF BOOLEAN(A.CE) THEN IF A.SUBCLASS } DOUBTYPE THEN 01939000 - IF BOOLEAN(INFC.BASE) THEN FLAG(146); 01940000 - NXT: 01941000 - T ~ T+3; 01942000 - END; 01943000 -END CHECKINFO; 01944000 - 01945000 -PROCEDURE SEGMENTSTART; 01946000 -BEGIN 01947000 - NSEG ~ NXAVIL ~ NXAVIL + 1; 01948000 - IF LISTOG THEN WRITALIST(SEGSTRT,1,NSEG,0,0,0,0,0,0,0) ; 01949000 - DEBUGADR~ADR~-1; 01950000 - IF NOT SEGOVFLAG THEN 01951000 - BEGIN 01952000 - DATAPRT~DATASTRT~DATALINK~DATASKP~ 01953000 - LABELMOM ~ BRANCHX ~ FUNVAR ~ 01954000 - DT ~ SPLINK ~ NEXTCOM ~ ELX ~ 0; 01955000 - NEXTSS ~ 1022; 01956000 - INITIALSEGNO ~ NSEG; 01957000 - FOR I ~ 0 STEP 1 UNTIL LBRANCH DO BRANCHES[I] ~ I+1; 01958000 - FOR I~0 STEP 1 UNTIL SHX DO STACKHEAD[I] ~ 0; 01959000 - NEXTINFO ~ LOCALS ~ 2; 01960000 - F2TOG ~ FALSE; RETURNFOUND ~ FALSE; 01961000 - END; 01962000 - ENDSEGTOG ~ FALSE; 01963000 - IF SEGSW THEN LINESEG[NOLIN~0,0]~0 & D2B(LASTSEQ)[10:20:28] ; 01964000 -END SEGMENTSTART; 01965000 -PROCEDURE FIXPARAMS(I); VALUE I; INTEGER I; 01966000 -BEGIN 01967000 - REAL FMINUS, NPARMS, ELINK, LABX; 01968000 - REAL PLINKX, PLINK; 01969000 - REAL PTYPEX, PTYPE; 01970000 - REAL CL, INF; 01971000 - LABEL ARRY, LOAD, INDX; 01972000 - REAL EWORD; 01973000 -IF DEBUGTOG THEN FLAGROUTINE(" FIXP","ARMS ",TRUE); 01974000 - EWORD ~ ENTRYLINK[I]; 01975000 - ELINK ~ EWORD.LINK; 01976000 - IF LABX ~ EWORD.CLASS > 0 THEN 01977000 - BEGIN 01978000 - EMITO(MKS); 01979000 - EMITDESCLIT(LABELMOM); 01980000 - EMITL(LABX); 01981000 - EMITL(1); EMITL(1); EMITL(0); 01982000 - EMITOPDCLIT(BLKCNTRLINT); 01983000 - EMITL(1); EMITPAIR(FPLUS2,STD);% F+2~TRUE FOR BLKXIT CALL 01984000 - END; %106-01985000 - FMINUS ~ 1920; 01986000 - NPARMS ~ (J~GET(ELINK+2)).NEXTRA; 01987000 - IF NPARMS > 0 THEN %106-01988000 - BEGIN 01989000 - PLINKX ~ EWORD.ADDR-NPARMS+1; 01990000 - PTYPEX ~ J.ADINFO + NPARMS-1; 01991000 - FOR J ~ 1 STEP 1 UNTIL NPARMS DO 01992000 - BEGIN 01993000 - PLINK ~ EXTRAINFO[PLINKX.IR,PLINKX.IC]; 01994000 - PTYPE ~ EXTRAINFO[PTYPEX.IR,PTYPEX.IC].CLASS; 01995000 - FMINUS ~ FMINUS+1; 01996000 - IF PLINK = 0 THEN 01997000 - BEGIN 01998000 - EMITOPDCLIT(FMINUS); 01999000 - EMITL(LABX ~ LABX-1); 01100000 - EMITDESCLIT(LABELMOM); 01100100 - EMITO(STD); 01100200 - END ELSE 01100300 - BEGIN 01100400 - IF CL ~ (INF ~ GET(PLINK)).CLASS = UNKNOWN THEN CL ~ VARID; 01100500 - XTA ~ GET(PLINK+1); 01100600 - IF PTYPE = 0 THEN EXTRAINFO[PTYPEX.IR,PTYPEX.IC].CLASS 01100700 - ~ PTYPE ~ CL; 01100800 - CASE PTYPE OF 01100900 - BEGIN ; 01101000 - IF CL ! ARRAYID THEN FLAG(79) ELSE 01101100 - ARRY: 01101200 - BEGIN 01101300 - FMINUS ~ FMINUS+1; 01101400 - IF INF < 0 THEN 01101500 - BEGIN 01101600 - EMITPAIR(FMINUS, LOD); 01101700 - EMITPAIR(T~INF.ADDR, STD); 01101800 - EMITOPDCLIT(FMINUS-1); 01101900 - EMITPAIR(T-1, STD); 01102000 - END; 01102100 - END; 01102200 - IF CL ! VARID THEN FLAG(80) ELSE 01102300 - LOAD: 01102400 - BEGIN 01102500 - IF INF.SUBCLASS}DOUBTYPE AND CL=VARID THEN FMINUS~FMINUS+1; 01102600 - IF INF<0 THEN 01102700 - BEGIN 01102800 - EMITPAIR(FMINUS, LOD); 01102900 - EMITPAIR(T~INF.ADDR,STD); 01103000 - IF INF.SUBCLASS}DOUBTYPE AND CL=VARID THEN %105-11103100 - BEGIN EMITOPDCLIT(FMINUS-1); 01103200 - EMITPAIR(T+1,STD); 01103300 - END; 01103400 - END ; 01103500 - END; 01103600 - ; ; ; ; 01103700 - IF CL = FUNID THEN GO TO LOAD ELSE FLAG(81); 01103800 - 01103900 - ; 01104000 - IF CL = FUNID OR CL = SUBRID OR CL = EXTID THEN GO TO LOAD 01104100 - ELSE FLAG(83); 01104200 - IF CL = SUBRID THEN GO TO LOAD ELSE FLAG(82); 01104300 - ; ; 01104400 - BEGIN 01104500 - IF CL = ARRAYID THEN 01104600 - BEGIN 01104700 - EXTRAINFO[PTYPEX.IR,PTYPEX.IC].CLASS ~ CL; 01104800 - GO TO ARRY; 01104900 - END; 01105000 - INDX: 01105100 - IF CL ! VARID THEN FLAG(80); 01105200 - FMINUS ~ FMINUS+1; 01105300 - IF INF < 0 THEN 01105400 - BEGIN 01105500 - EMITOPDCLIT(FMINUS-1); 01105600 - EMITDESCLIT(FMINUS); 01105700 - EMITPAIR(INF.ADDR, STD); 01105800 - END; 01105900 - END; 01106000 - IF CL = VARID THEN GO TO LOAD ELSE FLAG(80); 01106100 - GO TO INDX; 01106200 - END CASE STATEMENT; 01106300 - 01106400 - 01106500 - A ~ INF.SUBCLASS; 01106600 - IF T ~ EXTRAINFO[PTYPEX.IR,PTYPEX.IC].SUBCLASS = 0 OR 01106700 - T = INTYPE AND A = REALTYPE THEN 01106800 - EXTRAINFO[PTYPEX.IR,PTYPEX.IC].SUBCLASS ~ A ELSE 01106900 - IF T ! A THEN 01107000 - BEGIN XTA ~ GET(PLINK+1); FLAG(88) END; 01107100 - END; 01107200 - PLINKX ~ PLINKX+1; 01107300 - PTYPEX ~ PTYPEX-1; 01107400 - END; 01107500 - PLINKX ~ PLINKX-NPARMS; 01107600 - FOR J ~ 1 STEP 1 UNTIL NPARMS DO 01107700 - BEGIN 01107800 - PLINK ~ EXTRAINFO[PLINKX.IR,PLINKX.IC]; 01107900 - IF PLINK ! 0 THEN 01108000 - IF (A~GET(PLINK)).CLASS = ARRAYID THEN 01108100 - IF T~GET(PLINK+2) <0 THEN VARIABLEDIMS(A, T); 01108200 - PLINKX ~ PLINKX+1; 01108300 - END; 01108400 - END; 01108500 - EMITB(GET(ELINK+2).BASE & (GET(ELINK).SEGNO)[TOSEGNO], FALSE); 01108600 -IF DEBUGTOG THEN FLAGROUTINE(" FIXP","ARMS ",FALSE) ; 01108700 -END FIXPARAMS; 01108800 - 01108900 -PROCEDURE XREFCORESORT ; 01109000 - BEGIN 01109100 - REAL F,G,H,J,K,L,T,TT,IJ,M,TN ; 01109200 - SAVE ARRAY A[0:XRI-1], IL,IU[0:8]; 01109300 - ARRAY W2,W3[0:XRI-1] ; 01109400 - LABEL L1,L2,L3,L4,L5,L6,L11,L12,L13,L14 ; 01109500 - DEFINE CMPARGT(A) = A.NAME=TN THEN IF (IF G~W3[H~A.[2:10]].[26:4] 01109600 - =TT~W3[F~T.[2:10]].[26:4] THEN NOT CMPA(W2[H], 01109700 - W2[F]) ELSE G>TT) #, 01109800 - CMPARLS(A) = A.NAME=TN THEN IF (IF G~W3[H~T.[2:10]].[26:4] 01109900 - =TT~W3[F~A.[2:10]].[26:4] THEN NOT CMPA(W2[H], 01110000 - W2[F]) ELSE G>TT) #, 01110100 - NAME = [12:36] # ; 01110200 - J~XRI-1; G~XRI DIV K~XRBUFFDIV3; H~XRBUFF ; 01110300 - FOR L~1 STEP 1 UNTIL G DO 01110400 - BEGIN 01110500 -L11: READ(XREFF,H,XRRY[*]); TRANSFER(W2[T~(L-1)|50],XRRY,K) ; 01110600 - IJ~T+K-1; TN~-3; 01110700 - FOR F~T STEP 1 UNTIL IJ DO 01110800 - BEGIN A[F]~XRRY[TN~TN+3]&F[2:38:10]; W3[F]~XRRY[TN+2] END;01110900 - END; 01111000 - IF H=XRBUFF THEN IF K~XRI MOD K DIV 1!0 THEN BEGIN H~3|K;GO L11 END;01111100 - GO L4 ; 01111200 -L1: IF A[K~I].NAME>TN~(T~A[IJ~((L~J)+I+1).[37:10]]).NAME THEN 01111300 -L12: BEGIN A[IJ]~A[I]; A[I]~T; TN~(T~A[IJ]).NAME END 01111400 - ELSE IF CMPARGT(A[I]) THEN GO L12 ; 01111500 - IF A[J].NAMETN THEN GO L2; IF CMPARGT(A[L]) THEN GO L2; 01112400 -L3: IF A[K~K+1].NAMEJ+I THEN BEGIN IL[M]~I; IU[M]~L; I~K END 01112700 - ELSE BEGIN IL[M]~K; IU[M]~J; J~L END ; 11112800 - M~M+1 ; 01112900 -L4: IF I+10TN~(T~A[I]).NAME THEN 01113300 - BEGIN 01113400 -L5: A[K+1]~A[K]; IF A[K~K-1].NAME>TN THEN GO L5 ; 01113500 - IF CMPARGT(A[K]) THEN GO L5 ; 01113600 - A[K+1]~T ; 01113700 - END 01113800 - ELSE IF CMPARGT(A[K]) THEN GO L5 ; 01113900 - IF (M~M-1) GEQ 0 THEN BEGIN I~IL[M]; J~IU[M]; GO L4 END ; 01114000 - G~XRI-1 ; 01114100 - FOR I~ 0 STEP 1 UNTIL G DO 01114200 - IF BOOLEAN(L~REAL(A[I]~A[I].NAME&(TN~W3[J~A[I].[2:10]])[1:26:1]01114300 - =XTA)) THEN 01114400 - BEGIN 01114500 - IF IT~IT+1=9 THEN 01114600 - BEGIN LASTLINE~FALSE; WRITE(LINE,15,PRINTBUFF[*]) ; 01114700 -L6: BLANKIT(PRINTBUFF,15,IT~0) ; 01114800 - END ; 01114900 - SETPNT(A[I],W2[J],PRINTBUFF,KLASS[TN.CLASS],TYPES[TN. 01115000 - SUBCLASS],IF BOOLEAN(TN) THEN "*" ELSE " ",IT,L-1, 01115100 - LASTLINE,6-TN.[27:3]) ; 01115200 - END 01115300 - ELSE BEGIN 01115400 - LASTLINE~TRUE; WRITE(RITE,15,PRINTBUFF[*]); XTA~A[I]; 01115500 - GO L6; 01115600 - END ; 01115700 - WRITE(LINE,15,PRINTBUFF[*]); XRI~0; 01115800 - END OF XREFCORESORT ; 01115900 - 01116000 -PROCEDURE SETUPSTACK ; 01116100 -BEGIN 01116200 - REAL I; 01116300 - EMITOPDCLIT(16); 01116400 - EMITL(1); 01116500 - EMITO(ADD); 01116600 - EMITL(16); 01116700 - EMITO(SND); 01116800 - FOR I ~ 1 STEP 1 UNTIL LOCALS DO EMITL(0); 01116900 - CHECKINFO; 01117000 - IF DATAPRT ! 0 THEN 01117100 - BEGIN ADJUST; EMITOPDCLIT(DATAPRT); EMITO(LNG); EMITB(-1,TRUE);01117200 - DATASKP~LAX; EMITB(DATASTRT,FALSE); FIXB(DATALINK); 01117300 - EMITL(1); EMITPAIR(DATAPRT,STD); FIXB(DATASKP); 01117400 - END; 01117500 - ADJUST; 01117600 -END SETUPSTACK; 01117700 - 01117800 -PROCEDURE BRANCHLIT(X,Y); VALUE X,Y; REAL X; BOOLEAN Y; 01117900 -BEGIN 01118000 - IF ADR } 4075 THEN 01118100 - BEGIN ADR ~ ADR+1; SEGOVF END; 01118200 - ADJUST; 01118300 - IF X.SEGNO!NSEG THEN BEGIN 01118400 - IF(PRTS+1).[37:2]=1 AND Y THEN 01118500 - EMITOPDCLIT(PRGDESCBLDR(2,0,(ADR+5) DIV 4+1,NSEG)) 01118600 - ELSE EMITOPDCLIT(PRGDESCBLDR(2,0,(ADR+5) DIV 4,NSEG)) END 01118700 - ELSE 01118800 - EMITL((ADR+5) DIV 4 - X.LINK DIV 4) ; 01118900 -END BRANCHLIT; 01119000 -PROCEDURE SEGMENT(SZ,CURSEG,SEGTYP,EDOC); % WRITES OUT EDOC AS SEGMENT 01119100 - VALUE SZ,CURSEG,SEGTYP; % UPDATES PDPRT WITH PSUEDO 01119200 - REAL SZ,CURSEG; % UPDATES PDPRT WITH PSUEDO 01119300 - BOOLEAN SEGTYP; % TRUE TO WRAP UP A SUBROUTINE BLOCK 01119400 - % FALSE TO WRAP UP A SPLIT BLOCK 01119500 - ARRAY EDOC[0,0]; % CONTAINS DATA TO WRITE; 01119600 - BEGIN 01119700 - STREAM PROCEDURE M1(F,T); BEGIN DI ~ T; SI ~ F; DS ~ 2 WDS END;01119800 - REAL T; 01119900 - REAL BEGINSUB, ENDSUB, HERE; 01120000 - LABEL WRITEPGM; 01120100 - INTEGER I, CNTR; 01120200 -IF DEBUGTOG THEN FLAGROUTINE(" SEGM","ENT ",TRUE ); 01120300 - IF NOT SEGTYP THEN GO TO WRITEPGM; 01120400 - IF SPLINK > 1 AND NOT RETURNFOUND THEN 01120500 - BEGIN XTA ~ BLANKS; FLAG(142) END; 01120600 - IF SPLINK < 0 THEN 01120700 - BEGIN 01120800 - ADJUST; 01120900 - BDPRT[BDX~BDX+1] ~ PRGDESCBLDR(1, 0, (ADR+1) DIV 4, NSEG); 01121000 - FOR I ~ 1 STEP 1 UNTIL LOCALS DO EMITL(0); 01121100 - CHECKINFO; 01121200 - 01121300 - EMITB(0&INITIALSEGNO[TOSEGNO], FALSE); 01121400 - END 01121500 - ELSE 01121600 - IF SPLINK = 1 THEN % MAIN PROGRAM 01121700 - BEGIN 01121800 - ADJUST; 01121900 - IF STRTSEG ! 0 THEN FLAG(75); 01122000 - STRTSEG ~ NSEG & 01122100 - PRGDESCBLDR(1, 0, (ADR+1) DIV 4, NSEG)[18:33:15]; 01122200 - SETUPSTACK; 01122300 - 01122400 - EMITB(0&INITIALSEGNO[TOSEGNO], FALSE); 01122500 - END 01122600 - ELSE 01122700 - IF ELX { 1 THEN 01122800 - BEGIN 01122900 - ADJUST; 01123000 - T ~ PRGDESCBLDR(1, GET(SPLINK).ADDR, (ADR+1) DIV 4, NSEG); 01123100 - SETUPSTACK; 01123200 - FIXPARAMS(0); 01123300 - INFO[SPLINK.IR, SPLINK.IC].SEGNO ~ NSEG; 01123400 - END 01123500 - ELSE 01123600 - BEGIN 01123700 - ADJUST; 01123800 - BEGINSUB ~ (ADR+1) & NSEG[TOSEGNO]; 01123900 - EMITL(17); EMITO(STD); 01124000 - SETUPSTACK; 01124100 - EMITOPDCLIT(17); EMITO(GFW); 01124200 - ENDSUB ~ ADR & NSEG[TOSEGNO]; 01124300 - FOR I ~ 0 STEP 1 UNTIL ELX-1 DO 01124400 - BEGIN 01124500 - ADJUST; 01124600 - HERE ~ (ADR+1) DIV 4; 01124700 - T ~ ENTRYLINK[I].LINK; 01124800 -%VOID 01124900 - T ~ PRGDESCBLDR(1, GET(T).ADDR, HERE, NSEG); 01125000 - BRANCHLIT(ENDSUB,FALSE); 01125100 - EMITB(BEGINSUB, FALSE); 01125200 - ADJUST; 01125300 - FIXPARAMS(I); 01125400 - INFO[(ENTRYLINK[I].LINK).IR,(ENTRYLINK[I].LINK).IC].SEGNO~NSEG;01125500 - END; 01125600 - END; 01125700 - SZ ~ (ADR+4) DIV 4; 01125800 - CNTR ~ 0; 01125900 - CURSEG ~ NSEG; 01126000 - WRITEPGM: 01126100 - NSEG ~ ((T ~ SZ) + 29) DIV 30; 01126200 - IF DALOC DIV CHUNK < I ~ (DALOC+NSEG) DIV CHUNK 01126300 - THEN DALOC ~ CHUNK | I; % INSURE SEGMENT DONT BREAK 01126400 - % ACROSS ROW 01126500 - IF LISTOG THEN WRITALIST(SEGEND,2,CURSEG,T,0,0,0,0,0,0) ; 01126600 - PDPRT[PDIR,PDIC] ~ % PDPRT ENTRY FOR SEGMENT 01126700 - SZ&DALOC[DKAC] 01126800 - & GET(SPLINK)[12:41:1] 01126900 - &CURSEG[SGNOC]; 01127000 - IF ERRORCT = 0 THEN 01127100 - DO BEGIN 01127200 - FOR I~0 STEP 2 WHILE I < 30 AND CNTR < SZ DO 01127300 - BEGIN M1(EDOC[CNTR.[38:3],CNTR.[41:7]],CODE(I)); 01127400 - CNTR ~ CNTR + 2; 01127500 - END; 01127600 - WRITE(CODE[DALOC]); 01127700 - DALOC ~ DALOC +1; 01127800 - END UNTIL CNTR } SZ; 01127900 - PDINX ~ PDINX +1; 01128000 - IF NOT SEGOVFLAG THEN 01128100 - IF PXREF THEN 01128200 - IF(EODS~(NEXT=EOF))AND NOT XGLOBALS THEN ELSE 01128300 - BEGIN KLASS[6]~ "LABEL "; 01128400 - WRITE(XREFF,XRBUFF,XRRY[*]) ; 01128500 - IF FIRSTCALL THEN DATIME ELSE WRITE(PTR[PAGE]); 01128600 - IF SPLINK<0 THEN 01128700 - BEGIN WRITE(PTR,XHEDB);REWIND(XREFF);END 01128800 - ELSE 01128900 - IF EODS THEN BEGIN WRITE(PTR,XHEDG); REWIND(XREFG) END 01129000 - ELSE BEGIN REWIND(XREFF); C2~(XR[4].SUBCLASS|2+5); 01129100 - IF IT~XR[4].CLASS=FUNID THEN WRITE(PTR,XHEDF, 01129200 - XR[C2],XR[C2+1],XR[3],XR[C2+12], 01129300 - XR[C2+13],"------") 01129400 - ELSE IF IT=SUBRID THEN WRITE(PTR,XHEDS,XR[3], 01129500 - "------") ELSE WRITE(PTR,XHEDM); 01129600 - END; 01129700 - IT~XTA~0; 01129800 - LASTLINE ~ FALSE; 01129900 - BLANKIT(PRINTBUFF,15,0); 01130000 - IF XRI>1023 OR EODS THEN SORT(PT,INP,0,HV,CMP,3,4000) 01130100 - ELSE XREFCORESORT ; 01130200 - REWIND(XREFF); 01130300 - PXREF~IF XREF THEN TRUE ELSE FALSE; 01130400 - KLASS[6] ~ "ERROR "; 01130500 - IF (NOT SEGTYP AND EODS) OR (SEGTYP AND LISTOG AND 01130600 - NOT SEGPTOG) THEN WRITE (PTR[PAGE]); 01130700 - END; 01130800 - IF LISTOG AND SEGTYP AND SEGPTOG THEN WRITE(PTR[PAGE]); 01130900 - IF SEGTYP THEN 01131000 - BEGIN 01131100 - FOR I~12,17 STEP 1 UNTIL 24,39 STEP 1 UNTIL 41, 01131200 - 50 STEP 1 UNTIL 57 DO TIPE[I]~REALID ; 01131300 - FOR I~25,33 STEP 1 UNTIL 37 DO TIPE[I]~INTID ; 01131400 - LASTNEXT ~ 1000; 01131500 - END; 01131600 - ENDSEGTOG ~ TRUE; 01131700 - TSEGSZ ~ TSEGSZ + SZ; 01131800 - COMMENT IF SEGSW THEN LETS ALSO WRITE OUT THE LINE SEGMENTS 01131900 - THAT WE VE GONE TO SUCH TROUBLE BUILDING. LINESEG 01132000 - CONTAINS A CARD SEQUENCE NUMBER(BINARY) IN [10:28] 01132100 - AND THE WORD BOUNDARY ADDRESS OF THE FIRST CODE 01132200 - SYLLABLE IN [38:10]; 01132300 - IF SEGSW THEN 01132400 - IF NOLIN > 0 THEN 01132500 - BEGIN 01132600 - LINEDICT[CURSEG.IR,CURSEG.IC] ~ % UPDATE LINE DICTIONARY 01132700 - 0 & NOLIN[18:33:15] & DALOC[33:33:15];%FOR THIS SEGMENT 01132800 - CNTR ~ 0; DO BEGIN 01132900 - FOR I ~ 0 STEP 2 WHILE I<30 AND CNTR 30 THEN 30 ELSE (SZ-I)); 01136600 - WRITE(CODE[DALOC]); 01136700 - DALOC ~ DALOC +1; 01136800 - END; 01136900 - IF LISTOG THEN WRITALIST(SEGEND,2,SEG,T,0,0,0,0,0,0) ; 01137000 - TSEGSZ ~ TSEGSZ + SZ; 01137100 - END WRITEDATA; 01137200 - 01137300 -REAL PROCEDURE PRGDESCBLDR(DT,PRT,RELADR,SGNO); 01137400 - VALUE DT,PRT,RELADR,SGNO; 01137500 - REAL DT,PRT,RELADR,SGNO; 01137600 - BEGIN 01137700 - FORMAT FMT("PRT=",A4,", REL-ADR=",A4,", SEG=",I4,", TYPE=",A2); 01137800 - IF PRT=0 THEN BEGIN BUMPPRT; PRT~PRTS END; 01137900 - PDPRT[PDIR,PDIC] ~ 01138000 - 0&DT[DTYPC] 01138100 - &PRT[PRTAC] 01138200 - &RELADR[RELADC] 01138300 - &SGNO[SGNOC]; 01138400 - PDINX ~ PDINX +1; 01138500 - IF CODETOG THEN WRITALIST(FMT,4,B2D(PRT),B2D(RELADR),SGNO, 01138600 - IF DT=0 THEN "AE" ELSE IF DT=1 THEN "PD" ELSE "LD",0,0,0,0) ; 01138700 - PRGDESCBLDR ~ PRT; 01138800 - END PRGDESCBLDR; 01138900 - 01139000 -PROCEDURE EQUIV(R); VALUE R; REAL R; 01139100 -COMMENT THIS PROCEDURE FIXES UP THE INFO TABLE FOR THE EQUIV OR 01139200 - COMMON RING. THE FIRST ELEMENT PAST HAS AN OFFSET (DO NOT 01139300 - ALTER THIS) THE TYPE IS FIXED. THE OFFSET IS DETERMINED 01139400 - FROM THE FIRST. CORRECTINFO ADJUST THE OFFSET IF THERE 01139500 - IS A NEGATIVE OFFSET ON ANY ELEMENT. THE INFA[ADJ] BIT IS 01139600 - SET IF THE ELEMENT HAS A NEGATIVE OFFSET. IF THE ELEMENT 01139700 - APPEARED IN MORE THAN ONE EQUIVALENCE STATEMENT OR AN 01139800 - EQUIVALENCE STATEMENT AND A COMMON STATEMENT THE ELEMENTS 01139900 - ARE LINKED BY COM[LASTC] WHICH POINTS TO THE HEADER 01140000 - OF THAT STATEMENT; 01140100 -BEGIN 01140200 - DEFINE BASS = LOCALS #, % THESE DEFINES ARE USED TO REDUCE THE01140300 - REL = PARMS #, % STACKSIZE OF EQUIV FOR RECURSION 01140400 - I = PRTS #, 01140500 - T = LSTS #, 01140600 - Q = LSTA #, 01140700 - LAST = TV #, 01140800 - B = SAVESUBS #, 01140900 - P = NAMEIND #, 01141000 - PRTX = LSTI #, 01141100 - C = FX1 #, 01141200 - INFA = FX2 #, 01141300 - INFB = FX3 #, 01141400 - INFC = NX1 #; 01141500 - LABEL XIT, CHECK; 01141600 -IF DEBUGTOG THEN FLAGROUTINE(" EQU","IV ",TRUE) ; 01141700 - IF GETC(R) <0 THEN GO TO XIT; 01141800 - PUTC(R,-GETC(R)) ; 01141900 - PRTX ~ GROUPPRT; 01142000 - C~REAL(GETC(R).CE=1) ; 01142100 - LAST~GETC(R).LASTC-1 ; 01142200 - BASS~GETC(R+1); P~0 ; 01142300 - FOR I ~ R+2 STEP 1 UNTIL LAST DO 01142400 - BEGIN IF GETC(I).CLASS=ENDCOM THEN I~GETC(I).LINK ; 01142500 - GETALL(T~GETC(I).LINK,INFA,INFB,INFC) ; 01142600 - IF Q~INFC.SIZE=0 THEN % A SIMPLE VARIABLE 01142700 - INFC.SIZE ~ Q ~ IF INFA.SUBCLASS { LOGTYPE THEN 1 ELSE 2; 01142800 - PUT(T+2,INFC); 01142900 - IF INFA.SUBCLASS>LOGTYPE THEN SEENADOUB~TRUE; 01143000 - IF BOOLEAN(C) THEN 01143100 - BEGIN COM[PWI].RELADD~REL~P ; 01143200 - P ~ P + Q; 01143300 - END ELSE COM[PWI].RELADD~REL~BASS-GETC(I).RELADD ; 01143400 - IF INFA < 0 THEN IF INFA .ADJ = 1 THEN 01143500 - B ~ -INFC.BASE - REL ELSE B ~ INFC.BASE - REL; 01143600 - END; 01143700 - FOR I ~ R+2 STEP 1 UNTIL LAST DO 01143800 - BEGIN IF GETC(I).CLASS=ENDCOM THEN I~GETC(I).LINK ; 01143900 - GETALL(T~GETC(I).LINK,INFA,INFB,INFC) ; 01144000 - IF INFA.CLASS = 1 THEN SWARYCT ~ 1; 01144100 - P~B+GETC(I).RELADD ; 01144200 - Q ~ INFC .SIZE; 01144300 - IF INFA < 0 THEN 01144400 - BEGIN IF INFA .ADJ = 1 THEN BASS ~ -INFC .BASE ELSE 01144500 - BASS ~ INFC.BASE; 01144600 - IF P ! BASS THEN 01144700 - BEGIN XTA ~ INFB ; FLAG(2) END; 01144800 - GO TO CHECK; 01144900 - END; 01145000 - INFA ~ -INFA & PRTX[TOADDR]; 01145100 - IF INFA .CLASS = UNKNOWN THEN INFA .CLASS ~ VARID; 01145200 - INFA .TYPEFIXED ~ 1; 01145300 - INFC.BASE ~ P; 01145400 - PUT(T+2,INFC); 01145500 - IF P < 0 THEN INFA .ADJ ~ 1; 01145600 - PUT(T,INFA); 01145700 - CHECK: 01145800 - IF P+Q > LENGTH THEN LENGTH ~ P+Q; 01145900 - IF P < LOWERBOUND THEN LOWERBOUND ~ P; 01146000 - END; 01146100 - FOR I ~ R+2 STEP 1 UNTIL LAST DO 01146200 - BEGIN 01146300 - IF GETC(I).CLASS=ENDCOM THEN I~GETC(I).LINK ; 01146400 - IF T~GETC(I).LASTC!R THEN 01146500 - IF GETC(T)}0 THEN 01146600 - BEGIN R~R&LAST[3:33:15]&I[18:33:15] ; 01146700 - EQUIV(T); LAST~R.[3:15]; I~R.[18:15]; R~R.[33:15] ; 01146800 - END; 01146900 - END; 01147000 - XIT: 01147100 -IF DEBUGTOG THEN FLAGROUTINE(" EQU","IV ",FALSE) ; 01147200 -END EQUIV; 01147300 -ALPHA PROCEDURE GETSPACE(S); VALUE S; ALPHA S; 01147400 -BEGIN LABEL RPLUS, FMINUS, XIT; 01147500 - LABEL DONE; 01147600 - REAL A; 01147700 - BOOLEAN OWNID; 01147800 - IF OWNID ~ S < 0 THEN S~ -S; % IN DATA STMT, THUS OWN 01147900 - IF A ~ GET(GETSPACE~S) < 0 THEN GO TO DONE; 01148000 - IF A.CLASS GEQ 13 THEN FLAG(34) ELSE %104-01148100 -CASE A.CLASS OF 01148200 -BEGIN 01148300 -BEGIN 01148400 - PUT(S,A~A&VARID[TOCLASS]); 01148500 - PUT(S+2,(GET(S+2) &(IF A.SUBCLASS { LOGTYPE 01148600 - THEN 1 ELSE 2 )[TOSIZE])); 01148700 -END; 01148800 - IF BOOLEAN(A.FORMAL) THEN BUMPLOCALS; 01148900 -; 01149000 -BEGIN A.TYPEFIXED ~ 1; GO TO RPLUS END; 01149100 -GO TO RPLUS; 01149200 -GO TO RPLUS; 01149300 -GO TO DONE; 01149400 -BEGIN A.TYPEFIXED ~ 1; IF BOOLEAN(A.FORMAL) THEN GO TO FMINUS 01149500 - ELSE GO TO RPLUS; 01149600 -END; 01149700 -BEGIN A.TYPEFIXED ~ 1; GO TO RPLUS END; 01149800 -IF BOOLEAN(A.FORMAL) THEN GO TO FMINUS ELSE GO TO RPLUS; 01149900 -IF BOOLEAN(A.FORMAL) THEN GO TO FMINUS ELSE GO TO RPLUS; 01150000 -GO TO RPLUS; 01150100 -GO TO RPLUS; 01150200 -END OF CASE STATEMENT; 01150300 - 01150400 - 01150500 -A.TYPEFIXED ~ 1; 01150600 -IF BOOLEAN(A.FORMAL) THEN 01150700 - GO TO FMINUS; 01150800 -IF BOOLEAN(A.CE) OR BOOLEAN(A.EQ) THEN 01150900 -BEGIN 01151000 - PUT(S,A); 01151100 - CALLEQUIV(A.ADDR,OWNID,GET(S+1)) ; 01151200 - GO TO DONE; 01151300 -END; 01151400 - A.TWOD ~ REAL(GET(S+2).SIZE > 1023); 01151500 -FMINUS: 01151600 - IF OWNID THEN BEGIN BUMPPRT; A.ADDR~PRTS END ELSE 01151700 - BEGIN BUMPLOCALS; A.ADDR ~ LOCALS +1536 END; 01151800 - IF A.CLASS = VARID THEN IF A.SUBCLASS } DOUBTYPE THEN 01151900 - IF OWNID THEN BUMPPRT ELSE 01152000 - BUMPLOCALS; 01152100 - GO TO XIT; 01152200 -RPLUS: 01152300 - BUMPPRT; A.ADDR~PRTS; 01152400 -XIT: 01152500 - PUT(S, -A); 01152600 -DONE: 01152700 -END GETSPACE; 01152800 -INTEGER STREAM PROCEDURE LBLSHFT(S); VALUE S; 01152900 - BEGIN 01153000 - LOCAL T; 01153100 - LABEL L; 01153200 - DI ~ LOC LBLSHFT; DS ~ 8 LIT "00 "; 01153300 - DI ~ DI - 6; SI ~LOC S; SI ~ SI + 2; 01153400 - TALLY ~ 1; T ~ TALLY; 01153500 - 5(T(IF SC="0" THEN BEGIN SI~SI+1; JUMP OUT 1 TO L END 01153600 - ELSE TALLY~0; T~TALLY); 01153700 - IF SC}"0" THEN DS~CHR ELSE IF SC=" " THEN SI~SI+1 01153800 - ELSE JUMP OUT; L: ) ; 01153900 - IF SC ! " " THEN BEGIN DI ~ LOC LBLSHFT; DS ~ LIT "+" END; 01154000 - END LBLSHFT; 01154100 - COMMENT EMITTERS AND CODE CONTROL; 01154200 -ALPHA PROCEDURE B2D(B); VALUE B; REAL B; 01154300 - B2D ~ 0&B[45:45:3]&B[39:42:3]&B[33:39:3]&B[27:36:3]; 01154400 -PROCEDURE DEBUG(S); % PRINTS OUT DEBUG CODE 01154500 - VALUE S; REAL S; % IF S<0 THEN S IS FIELD TYPE OPERATOR 01154600 - BEGIN 01154700 - FORMAT FF(X35,*(33(".")),A4,":",A1,2(X2,A4),X4,A4) ; 01154800 - ALPHA CODE,MNM,SYL; 01154900 - REAL T; 01155000 -PROCEDURE SEARCH(CODE,S); VALUE S; REAL S,CODE; 01155100 - BEGIN % SEARCHS WOP TO FIND CODE FOR S 01155200 - REAL N,I; 01155300 - LABEL L; 01155400 - N ~ 64; 01155500 - FOR I ~ 66 STEP IF WOP[I] < S THEN N ELSE -N 01155600 - WHILE N ~ N DIV 2 } 1 DO 01155700 - IF WOP[I] =S THEN GO TO L; 01155800 - I ~ 0; % NOT FOUND 01155900 - L: CODE ~ WOP[I+1]; 01156000 - END SEARCH; 01156100 - 01156200 - IF S < 0 THEN 01156300 - BEGIN % FIELD TYPE OPERATOR 01156400 - SYL ~ S; 01156500 - MNM ~ B2D(S.[36:6]); 01156600 - IF (S ~ S.[42:6]) = 37 THEN CODE ~ "ISO " ELSE 01156700 - IF S = 45 THEN CODE ~ "DIA " ELSE 01156800 - IF S = 49 THEN CODE ~ "DIB " ELSE 01156900 - IF S = 53 THEN CODE ~ "TRB "; 01157000 - END 01157100 - ELSE 01157200 - BEGIN 01157300 - IF (T ~ S.[46:2]) ! 1 THEN 01157400 - BEGIN 01157500 - SYL ~ S; 01157600 - MNM ~ B2D(S.[36:10]); 01157700 - IF T = 0 THEN CODE ~ "LITC" 01157800 - ELSE IF T =2 THEN CODE ~ "OPDC" 01157900 - ELSE CODE ~ "DESC"; 01158000 - END 01158100 - ELSE 01158200 - BEGIN % SEARCH WOP FOR OPERATOR NAME 01158300 - SYL ~ S; 01158400 - MNM ~ " "; 01158500 - SEARCH(CODE,S.[36:10]); 01158600 - END; 01158700 - END; 01158800 - WRITALIST(FF,6,IF ADR{DEBUGADR THEN 1 ELSE -1,B2D(ADR.[36:10]),01158900 - B2D(ADR.[46:2]),CODE,MNM,B2D(SYL),0,0) ; 01159000 - IF DEBUGADR0 THEN S~GET(GETSPACE(P)); 01164100 - IF S.CLASS = VARID THEN IF BOOLEAN(S.CE) THEN 01164200 - IF BOOLEAN(S.TWOD) THEN 01164300 - BEGIN 01164400 - EMITL( (T~GET(P+2).BASE).[33:7]); 01164500 - EMITDESCLIT(S.ADDR); 01164600 - EMITO(LOD); 01164700 - EMITL(T.[40:8]); 01164800 - EMITO(CDC); 01164900 - GO TO XIT; 01165000 - END ELSE 01165100 - EMITNUM(GET(P+2).BASE) 01165200 - ELSE 01165300 - IF NOT BOOLEAN(S.FORMAL) THEN IF NOT DESCREQ THEN 01165400 - BEGIN 01165500 - EMITL(S~S.ADDR); 01165600 - IF S.[37:2]=1 THEN %REFERENCING 2ND HALF OF PRT; 01165700 - BEGIN 01165800 - IF ADR } 4087 THEN 01165900 - BEGIN ADR ~ ADR+1; SEGOVF END; 01166000 - EMITO(XRT); 01166100 - END; 01166200 - GO TO XIT; 01166300 - END; 01166400 - EMITDESCLIT(S.ADDR); 01166500 - XIT: 01166600 -END EMITN; 01166700 - 01166800 -PROCEDURE EMITV(P); VALUE P; ALPHA P; 01166900 - BEGIN 01167000 - ALPHA S; 01167100 - IF S~ GET(P) > 0 THEN S ~ GET(GETSPACE(P)); 01167200 - IF S.CLASS = VARID THEN 01167300 - IF BOOLEAN(S.CE) THEN 01167400 - IF BOOLEAN(S.TWOD) THEN 01167500 - BEGIN 01167600 - EMITL( (T~GET(P+2).BASE).[33:7]); 01167700 - EMITDESCLIT(S.ADDR); 01167800 - EMITO(LOD); 01167900 - IF S.SUBCLASS } DOUBTYPE THEN 01168000 - BEGIN 01168100 - EMITO(DUP); 01168200 - EMITPAIR(T.[40:8]+1, COC); 01168300 - EMITO(XCH); 01168400 - EMITPAIR(T.[40:8], COC); 01168500 - END ELSE EMITPAIR(T.[40:8], COC); 01168600 - END 01168700 - ELSE 01168800 - IF S.SUBCLASS } DOUBTYPE THEN 01168900 - BEGIN 01169000 - EMITNUM( (T~GET(P+2).BASE)+1); 01169100 - EMITOPDCLIT(S.ADDR); 01169200 - EMITNUM(T); 01169300 - EMITOPDCLIT(S.ADDR); 01169400 - END ELSE 01169500 - BEGIN 01169600 - EMITNUM(GET(P+2).BASE); 01169700 - EMITOPDCLIT(S.ADDR); 01169800 - END 01169900 - ELSE 01170000 - IF S.SUBCLASS } DOUBTYPE THEN 01170100 - IF BOOLEAN(S.FORMAL) THEN 01170200 - BEGIN 01170300 - EMITDESCLIT(S.ADDR); 01170400 - EMITO(DUP); 01170500 - EMITPAIR(1, XCH); 01170600 - EMITO(INX); 01170700 - EMITO(LOD); 01170800 - EMITO(XCH); 01170900 - EMITO(LOD); 01171000 - END ELSE 01171100 - BEGIN 01171200 - EMITOPDCLIT(S.ADDR+1); 01171300 - EMITOPDCLIT(S.ADDR); 01171400 - END 01171500 - ELSE EMITOPDCLIT(S.ADDR) 01171600 - ELSE EMITOPDCLIT(S.ADDR); 01171700 -END EMITV; 01171800 - 01171900 -PROCEDURE EMITL(N); VALUE N; REAL N; 01172000 - BEGIN 01172100 - BUMPADR; 01172200 - PACK(EDOC[EDOCI],(N~0&N[36:38:10]),ADR.[46:2]); 01172300 - IF CODETOG THEN DEBUG(N); 01172400 -END EMITL; 01172500 -PROCEDURE EMITD(R, OP); VALUE R, OP; REAL R, OP; 01172600 -BEGIN 01172700 - BUMPADR; 01172800 - PACK(EDOC[EDOCI], (R ~ OP & R[36:42:6]), ADR.[46:2]); 01172900 - IF CODETOG THEN DEBUG(-R); 01173000 -END EMITD; 01173100 -PROCEDURE EMITDDT(B,A,X); VALUE B,A,X; INTEGER B,A,X ; 01173200 - BEGIN % DOES DIB B, DIA A, TRB X; HANDLES [B:A:X]. 01173300 - EMITD(B~B MOD 6+B DIV 6|8,DIB); EMITD(A~A MOD 6+A DIV 6|8,DIA) ; 01173400 - EMITD(X~X,TRB); 01173500 - END OF EMITDDT ; 01173600 -PROCEDURE EMITPAIR(L, OP); VALUE L, OP; INTEGER L, OP; 01173700 -BEGIN 01173800 - EMITL(L); 01173900 - IF L.[37:2] = 1 THEN 01174000 - BEGIN 01174100 - IF ADR } 4087 THEN 01174200 - BEGIN ADR ~ ADR+1; SEGOVF END; 01174300 - EMITO(XRT); 01174400 - END; 01174500 - EMITO(OP); 01174600 -END EMITPAIR; 01174700 -PROCEDURE ADJUST; 01174800 - WHILE ADR.[46:2] ! 3 DO EMITO(NOP); 01174900 -PROCEDURE EMITNUM(N); VALUE N; REAL N; 01175000 - BEGIN 01175100 - DEFINE CPLUS = 1792#; 01175200 - IF N.[3:6] =0 AND ABS(N) < 1024 THEN 01175300 - BEGIN 01175400 - EMITL(N); 01175500 - IF N < 0 THEN EMITO(SSN); 01175600 - END ELSE 01175700 - BEGIN 01175800 - IF ADR } 4079 THEN 01175900 - BEGIN ADR ~ ADR+1; SEGOVF END; 01176000 - EMITOPDCLIT(CPLUS + (ADR+1).[46:1] + 1); 01176100 - EMITL(2); 01176200 - EMITO(GFW); 01176300 - ADJUST; 01176400 - BUMPADR; 01176500 - PACK(EDOC[EDOCI],N.[1:11],ADR.[46:2]); 01176600 - BUMPADR; 01176700 - PACK(EDOC[EDOCI],N.[12:12],ADR.[46:2]); 01176800 - BUMPADR; 01176900 - PACK(EDOC[EDOCI],N.[24:12],ADR.[46:2]); 01177000 - BUMPADR; 01177100 - PACK(EDOC[EDOCI],N.[36:12],ADR.[46:2]); 01177200 - IF N.[36:12]=49 THEN %%% IF C-REL CONSTANT LOOKS LIKE AN XRT 01177300 - EMITO(NOP); %%% THEN INSURE AGAINST P-BIT INTERRUPT. 01177400 - IF CODETOG THEN DEBUGWORD(N); 01177500 - END; 01177600 -END EMITNUM; 01177700 - 01177800 -PROCEDURE EMITNUM2(HI,LO);VALUE HI,LO; REAL HI,LO; 01177900 - BEGIN 01178000 - BOOLEAN B; REAL I,N; 01178100 - LABEL Z,X; 01178200 - DEFINE CPLUS = 1792#; 01178300 - IF HI=0 OR LO=0 THEN BEGIN EMITNUM(LO); EMITNUM(HI); GO Z END; 01178400 - ADJUST; 01178500 - IF ADR } 4077 THEN 01178600 - BEGIN ADR~ADR+1; SEGOVF; ADR~-1 END; 01178700 - EMITOPDCLIT(CPLUS + 2); EMITOPDCLIT(CPLUS + 1); 01178800 - EMITPAIR(3,GFW); 01178900 - X: FOR I ~ 0 STEP 1 UNTIL 3 DO 01179000 - BEGIN 01179100 - CASE I OF BEGIN 01179200 - N ~ HI.[ 1:11]; 01179300 - N ~ HI.[12:12]; 01179400 - N ~ HI.[24:12]; 01179500 - N ~ HI.[36:12]; 01179600 - END CASE; 01179700 - BUMPADR; PACK(EDOC[EDOCI],N,ADR.[46:2]); 01179800 - END; 01179900 - IF CODETOG THEN DEBUGWORD(HI); 01180000 - IF NOT B THEN BEGIN B~TRUE; HI~LO; GO TO X; END; 01180100 - IF N=49 THEN %%% IF C-REL CONSTANT LOOKS LIKE AN XRT 01180200 - EMITO(NOP) ; %%% THEN INSURE AGAINST P-BIT INTERRUPT. 01180300 -Z: 01180400 - END EMITNUM2; 01180500 - 01180600 -PROCEDURE EMITLINK(N); VALUE N; REAL N; % EMITS LINKS 01180700 - BEGIN 01180800 - FORMAT FF(X35,*(33(".")),A4,":",A1," LINK",X10,A4,"******") ; 01180900 - BUMPADR; 01181000 - PACK(EDOC[EDOCI],N,ADR.[46:2]); 01181100 - IF CODETOG THEN 01181200 - WRITALIST(FF,4,IF ADR{DEBUGADR THEN 1 ELSE -1,B2D(ADR.[36:10]),01181300 - B2D(ADR.[46:2]),B2D(N),0,0,0,0) ; 01181400 - IF DEBUGADRLBRANCH THEN FATAL(123); 00191200 - BRANCHX ~ BRANCHES[LAX~BRANCHX]; 00191300 - BRANCHES[LAX] ~ -(ADR+1); 00191400 - EMITLINK(0); 00191500 - EMITO(IF C THEN BFC ELSE BFW); 00191600 - EMITO(NOP); 00191700 - END ELSE 00191800 - BEGIN 00191900 - SEG ~ A.SEGNO; 00192000 - A ~ A.LINK; 00192100 - BEOREF ~ ADR > A; 00192200 - IF A.[46:2] =0 THEN 00192300 - BEGIN 00192400 - IF SEG > 0 AND SEG ! NSEG THEN 00192500 - EMITOPDCLIT(PRGDESCBLDR(2, 0, A.[36:10], SEG)) 00192600 - ELSE 00192700 - EMITL(ABS((ADR+2).[36:10] - A.[36:10])); 00192800 - IF BEOREF THEN 00192900 - EMITO( IF C THEN GBC ELSE GBW) ELSE 00193000 - EMITO( IF C THEN GFC ELSE GFW); 00193100 - END ELSE 00193200 - BEGIN 00193300 - EMITL(ABS(ADR + 3 - A)); 00193400 - IF BEOREF THEN 00193500 - EMITO(IF C THEN BBC ELSE BBW) ELSE 00193600 - EMITO(IF C THEN BFC ELSE BFW); 00193700 - END; 00193800 - END; 00193900 -END EMITB; 00194000 - 00194100 -PROCEDURE EMITDESCLIT(N); VALUE N; REAL N; 00194200 - BEGIN 00194300 - IF N.[37:2] = 1 THEN 00194400 - BEGIN 00194500 - IF ADR } 4087 THEN 00194600 - BEGIN ADR ~ ADR+1; SEGOVF END; 00194700 - EMITO(XRT); 00194800 - END; 00194900 - BUMPADR; 00195000 - PACK(EDOC[EDOCI],(N~3&N[36:38:10]),ADR.[46:2]); 00195100 - IF CODETOG THEN DEBUG(N); 00195200 -END EMITDESCLIT; 00195300 -PROCEDURE EMITOPDCLIT(N); VALUE N; REAL N; 00195400 - BEGIN 00195500 - IF N.[37:2] = 1 THEN 00195600 - BEGIN 00195700 - IF ADR } 4087 THEN 00195800 - BEGIN ADR ~ ADR+1; SEGOVF END; 00195900 - EMITO(XRT); 00196000 - END; 00196100 - BUMPADR; 00196200 - PACK(EDOC[EDOCI],(N~2&N[36:38:10]),ADR.[46:2]); 00196300 - IF CODETOG THEN DEBUG(N); 00196400 -END EMITOPDCLIT; 00196500 -PROCEDURE EMITLABELDESC(N); VALUE N; ALPHA N; 00196600 -BEGIN 00196700 - LABEL XIT; 00196800 - REAL T,B,C,D ; 00196900 - IF N ~ LBLSHFT(XTA~N) = 0 OR N = BLANKS THEN 00197000 - BEGIN FLAG(135); GO TO XIT END; 00197100 - IF T ~ SEARCH(N) = 0 THEN 00197200 - T ~ ENTER(0 & LABELID[TOCLASS], N) ELSE 00197300 - IF GET(T).CLASS ! LABELID THEN 00197400 - BEGIN FLAG(144); GO TO XIT END; 00197500 - IF XREF THEN ENTERX(N,0&LABELID[TOCLASS]); 00197600 - IF B ~(C~GET(T+2)).BASE =0 THEN 00197700 - IF (D~GET(T)).SEGNO!0 THEN C.BASE~B~PRGDESCBLDR(2,0,D.ADDR DIV 4, 00197800 - D.SEGNO) ELSE 00197900 - BEGIN BUMPPRT; C.BASE~B~PRTS END; PUT(T+2,C); 00198000 - EMITL(B); EMITO(MKS); 00198100 - EMITDESCLIT(1536); % F+0 00198200 - EMITOPDCLIT(1537); % F+1 00198300 - EMITV(NEED(".LABEL", INTRFUNID)); 00198400 - XIT: 00198500 -END EMITLABELDESC; 00198600 - 00198700 -COMMENT TRACEBACK, OFLOWHANGERS, AND PRTSAVER ARE 00198800 -PROCEDURES USED TO ACCUMULATE FORMAT AND NAMELIST ARRAYS; 00198900 -PROCEDURE TRACEBACK(M,DEX,PRT); VALUE M,DEX,PRT; INTEGER M,DEX,PRT; 00199000 -BEGIN INTEGER I,J; REAL C; 00199100 - IF (C~GET(M+2)).BASE ! 0 THEN 00199200 - BEGIN I ~ ADR; ADR ~ C.BASE; 00199300 - DO BEGIN J ~ GIT(ADR); 00199400 - ADR ~ ADR - 1; 00199500 - EMITL(DEX); 00199600 - EMITPAIR(PRT,LOD); 00199700 - END UNTIL ADR ~ J = 0; 00199800 - ADR ~ I; 00199900 - END; 00200000 -INFO[M.IR,M.IC].ADDR ~ PRT; PUT(M+2,0&DEX[TOBASE]); 00200100 -END TRACEBACK; 00200200 - 00200300 -PROCEDURE OFLOWHANGERS(I); VALUE I; INTEGER I; 00200400 -BEGIN INTEGER J; LABEL XIT; 00200500 -FOR J ~ 1 STEP 1 UNTIL MAXNBHANG DO 00200600 -IF FNNHANG[J] = 0 THEN % MAKE AN ENTRY 00200700 -BEGIN FNNHANG[J] ~ I; 00200800 - PUT(I+2,J); 00200900 - GO TO XIT; 00201000 -END; 00201100 -XTA ~ MAXNBHANG; % IF WE REACH HERE WERE HURTIN 00201200 -FLAG(91); 00201300 -XIT: 00201400 -END OFLOWHANGERS; 00201500 - 00201600 -PROCEDURE PRTSAVER(M,SZ,ARY); VALUE M,SZ; 00201700 -INTEGER M,SZ; ARRAY ARY[0]; 00201800 -BEGIN INTEGER I; REAL INFA; 00201900 -LABEL SHOW,XIT; 00202000 -IF (INFA~GET(M)) < 0 THEN % PREVIOUSLY DEFINED 00202100 -BEGIN XTA ~ GET(M+1); 00202200 - FLAG(20); GO TO XIT; 00202300 -END; 00202400 -IF I ~ INFA .ADDR ! 0 THEN % PRT ASSIGNED AT OFLOW TIME 00202500 -SHOW: 00202600 -BEGIN I ~ PRGDESCBLDR(1,I,0,NXAVIL ~ NXAVIL + 1); 00202700 - WRITEDATA(SZ,NXAVIL,ARY); 00202800 - FNNHANG[GET(M+2).SIZE] ~ 0; 00202900 -END ELSE % ADD THIS ARRAY TO HOLD 00203000 -BEGIN IF FNNPRT=0 THEN BEGIN BUMPPRT; FNNPRT~PRTS END; 00203100 - IF FNNINDEX + SZ > DUMPSIZE THEN % ARRAY WONT FIT 00203200 - BEGIN BUMPPRT;FNNHANG[GET(M+2).SIZE]~0; TRACEBACK(M,0,I~PRTS); 00203300 - GO TO SHOW; 00203400 - END ELSE % DUMP OUT CURRENT HOLDINGS 00203500 - BEGIN FNNPRT ~ PRGDESCBLDR(1,FNNPRT,0,NXAVIL ~ NXAVIL + 1); 00203600 - WRITEDATA(FNNINDEX,NXAVIL,FNNHOLD); 00203700 - FNNINDEX ~ 0; BUMPPRT; FNNPRT ~PRTS; 00203800 - END; 00203900 - FNNHANG[GET(M + 2).SIZE] ~0; 00204000 - TRACEBACK(M,FNNINDEX,FNNPRT); 00204100 - MOVEW(ARY,FNNHOLD[FNNINDEX],SZ.[36:6],SZ); 00204200 - FNNINDEX ~ FNNINDEX + SZ; 00204300 -END; 00204400 -PUT(M,-GET(M)); % ID NOW ASSIGNED 00204500 -XIT: 00204600 -END PRTSAVER; 00204700 - 00204800 -PROCEDURE SEGOVF; 00204900 - BEGIN 00205000 - REAL I, T, A, J, SADR, INFC, LABPRT; 00205100 - REAL SAVINS; 00205200 - FOR T ~ 1 STEP 1 UNTIL MAXNBHANG DO 00205300 -IF J~FNNHANG[T]!0 THEN BEGIN BUMPPRT;TRACEBACK(J,FNNHANG[T]~0,PRTS) END;00205400 - SEGOVFLAG ~ TRUE; 00205500 -BUMPPRT; 00205600 - IF PRTS.[37:2]=1 THEN BEGIN 00205700 - PACK(EDOC[EDOCI],(T~1&XRT[36:38:10]),ADR.[46:2]); 00205800 - IF CODETOG THEN DEBUG(T); ADR~ADR+1 END; 00205900 - PACK(EDOC[EDOCI], (T~2&PRTS[36:38:10]), ADR.[46:2]); 00206000 - IF CODETOG THEN DEBUG(T); 00206100 - ADR ~ ADR+1; 00206200 - PACK(EDOC[EDOCI], (T~1&BFW [36:38:10]), ADR.[46:2]); 00206300 - IF CODETOG THEN DEBUG(T); 00206400 - SADR ~ ADR; 00206500 - T ~ PRGDESCBLDR(2, PRTS, 0, NXAVIL+1); 00206600 - FOR I ~ 0 STEP 1 UNTIL SHX DO 00206700 - BEGIN T ~ STACKHEAD[I]; 00206800 - WHILE T ! 0 DO 00206900 - BEGIN IF (A~ GET(T)).CLASS = LABELID THEN 00207000 - IF A > 0 THEN 00207100 - BEGIN 00207200 - ADR ~ A.ADDR; 00207300 - IF LABPRT ~ (INFC~GET(T+2)).BASE = 0 THEN 00207400 - BEGIN 00207500 - BUMPPRT; LABPRT~PRTS; 00207600 - PUT(T+2, INFC & PRTS[TOBASE]); 00207700 - END; 00207800 - WHILE ADR ! 0 DO 00207900 - BEGIN J ~ GIT(ADR); ADR ~ ADR-1; 00208000 - SAVINS~GIT(ADR+2).[36:10]; 00208100 - EMITOPDCLIT(LABPRT); 00208200 - EMITO(SAVINS); 00208300 - ADR ~ J; 00208400 - END; 00208500 - INFO[T.IR,T.IC].ADDR ~ 0; 00208600 - END; 00208700 - T ~ A.LINK; 00208800 - END; 00208900 - END; 00209000 - FOR I ~ 0 STEP 1 UNTIL LBRANCH DO 00209100 - IF T ~ - BRANCHES[I] > 0 AND T < 4096 THEN 00209200 - BEGIN 00209300 - ADR ~ T-1; 00209400 - SAVINS~GIT(ADR+2).[36:10]; 00209500 - BUMPPRT; EMITOPDCLIT(PRTS); 00209600 - EMITO(SAVINS); 00209700 - BRANCHES[I] ~ - (PRTS+4096); 00209800 - END; 00209900 - SEGMENT((SADR+4) DIV 4,NSEG,FALSE,EDOC); 00210000 - SEGMENTSTART; 00210100 - EMITO(NOP); EMITO(NOP); 00210200 - SEGOVFLAG ~ FALSE; 00210300 -END SEGOVF; 00210400 - 00210500 -PROCEDURE ARRAYDEC(I); VALUE I; REAL I; 00210600 - BEGIN % DECLARES ARRAYS WHOSE INFO INDEX IS I 00210700 - REAL PRT,LNK,J; 00210800 - LABEL XIT; 00210900 - BOOLEAN OWNID; REAL X; 00211000 -IF DEBUGTOG THEN FLAGROUTINE(" ARRA","YDEC ",TRUE ); 00211100 - PRT ~ GET(I).ADDR; 00211200 - IF LNK ~ GET(I+2).SIZE = 0 THEN GO TO XIT ; 00211300 - IF (OWNID ~ PRT < 1536 AND DATAPRT ! 0) THEN 00211400 - BEGIN 00211500 - EMITOPDCLIT(DATAPRT); EMITO(LNG); 00211600 - EMITB(-1, TRUE); X ~ LAX; 00211700 - END; 00211800 - EMITO(MKS); 00211900 - EMITDESCLIT(PRT); % STACK OR PRT ADDRESS 00212000 - IF LNK { 1023 THEN 00212100 - BEGIN 00212200 - IF OWNID THEN EMITL(0); % LOWER BOUND 00212300 - EMITL(LNK); % ARRAY SIZE 00212400 - EMITL(1); % ONE DIMENSION 00212500 - END 00212600 - ELSE 00212700 - BEGIN 00212800 - J ~ (LNK + 255) DIV 256; 00212900 - LNK ~ 256; %INCLUDE ENTIRE ARRAY SIZE IN ESTIMATE %512- 00213000 - IF OWNID THEN EMITL(0); % FIRST LOWER BOUND 00213100 - EMITL(J); % NUMBER OF ROWS 00213200 - IF OWNID THEN EMITL(0); % SECOND LOWER BOUND 00213300 - EMITL(256); % SIZE OF EACH ROW 00213400 - EMITL(2); % TWO DIMENSIONS 00213500 - END; 00213600 - EMITL(1); % ONE ARRAY 00213700 - EMITL(IF OWNID THEN 2 ELSE 0); %OWN OR LOCAL 00213800 - EMITOPDCLIT(5); % CALL BLOCK 00213900 - ARYSZ ~ ARYSZ + J + LNK; 00214000 - IF NOT(F2TOG OR OWNID) THEN 00214100 - BEGIN 00214200 - F2TOG ~ TRUE; 00214300 - EMITL(1); 00214400 - EMITPAIR(FPLUS2,STD);% F+2~TRUE 00214500 - END; 00214600 - IF OWNID THEN FIXB(X); 00214700 - XIT: 00214800 -IF DEBUGTOG THEN FLAGROUTINE(" ARRA","YDEC ",FALSE) ; 00214900 - END ARRAYDEC; 00215000 - 00215100 -REAL PROCEDURE SEARCH(E); VALUE E; REAL E; 00215200 -BEGIN REAL T; LABEL XIT; 00215300 - T ~ STACKHEAD[E MOD SHX]; 00215400 - WHILE T ! 0 DO 00215500 - IF INFO[(T+1).IR,(T+1).IC] = E THEN GO TO XIT 00215600 - ELSE T ~ INFO[T.IR,T.IC].LINK; 00215700 - XIT: SEARCH ~ T; 00215800 -END SEARCH; 00215900 - 00216000 -INTEGER PROCEDURE GLOBALSEARCH(E); VALUE E; REAL E; 00216100 -BEGIN REAL T; LABEL XIT; 00216200 - T ~ GLOBALSTACKHEAD[E MOD GHX]; 00216300 - WHILE T ! 0 DO 00216400 - IF INFO[(T+1).IR,(T+1).IC] = E THEN GO TO XIT 00216500 - ELSE T ~ INFO[T.IR,T.IC].LINK; 00216600 - XIT: GLOBALSEARCH ~ T; 00216700 -END GLOBALSEARCH; 00216800 - 00216900 -PROCEDURE PURGEINFO; 00217000 -BEGIN REAL J; 00217100 - FLAG(13); 00217200 - FOR J ~ 0 STEP 1 UNTIL SHX DO STACKHEAD[J] ~ 0; 00217300 - NEXTINFO ~ 2; 00217400 - NEXTCOM ~ 0; 00217500 - END; 00217600 - 00217700 -INTEGER PROCEDURE ENTER(W, E); VALUE W, E; ALPHA W, E; 00217800 -BEGIN REAL J; 00217900 - IF GLOBALNEXTINFO { NEXTINFO THEN PURGEINFO; 00218000 - W.LINK ~ STACKHEAD[J ~ E MOD SHX]; 00218100 - STACKHEAD[J] ~ ENTER ~ J ~ NEXTINFO; 00218200 - INFO[J.IR,J.IC] ~ W; 00218300 - INFO[(J~J+1).IR,J.IC] ~ E; 00218400 - INFO[(J~J+1).IR,J.IC] ~ 0; 00218500 - NEXTINFO ~ NEXTINFO + 3; 00218600 -END ENTER; 00218700 - 00218800 -INTEGER PROCEDURE GLOBALENTER(W, E); VALUE W, E; ALPHA W, E; 00218900 -BEGIN REAL J; 00219000 - IF GLOBALNEXTINFO { NEXTINFO THEN PURGEINFO; 00219100 - W.LINK ~ GLOBALSTACKHEAD[J ~ E MOD GHX]; 00219200 - GLOBALSTACKHEAD[J] ~ GLOBALENTER ~ J ~ GLOBALNEXTINFO; 00219300 - INFO[J.IR,J.IC] ~ W; 00219400 - INFO[(J~J+1).IR,J.IC] ~ E; 00219500 - INFO[(J~J+1).IR,J.IC] ~ 0; 00219600 - GLOBALNEXTINFO ~ GLOBALNEXTINFO - 3; 00219700 -END GLOBALENTER; 00219800 - 00219900 -PROCEDURE LABELBRANCH(K, C); VALUE K, C; REAL K; BOOLEAN C; 00220000 -BEGIN REAL TS,T,I,X; 00220100 -DEFINE LABL = K#; 00220200 -COMMENT LABELBRANCH GENERATES A "LITC ..." AND "BRANCH" FROM THE 00220300 -CURRENT ADDRESS TO LABEL K. IF THE BOOLEAN C IS TRUE 00220400 -THE BRANCH IS CONDITIONAL. IF THE LABEL HAS NOT BEEN ENCOUNTERED 00220500 -THEN THE APPROPRIATE LINKAGE IS MADE; 00220600 - LABEL XIT; 00220700 - IF ADR } 4086 THEN 00220800 - BEGIN ADR ~ ADR+1; SEGOVF END; 00220900 - IF LABL ~ LBLSHFT(XTA~LABL) { 0 OR LABL = BLANKS THEN 00221000 - BEGIN FLAG(135); GO TO XIT END; 00221100 - IF T ~ SEARCH(LABL) ! 0 THEN 00221200 - BEGIN TS ~ (I ~ GET(T)).ADDR; 00221300 - IF I.CLASS ! LABELID THEN BEGIN FLAG(144); GO TO XIT END; 00221400 - IF I > 0 THEN 00221500 - BEGIN EMITLINK(TS); 00221600 - EMITO(IF C THEN BFC ELSE BFW); 00221700 - PUT(T,I&(ADR-1)[TOADDR]); 00221800 - EMITO(NOP); 00221900 - END ELSE 00222000 - IF I.SEGNO = NSEG THEN EMITB(TS, C) ELSE 00222100 - BEGIN IF TS~(X~GET(T+2)).BASE = 0 THEN 00222200 - X.BASE ~ TS ~ PRGDESCBLDR(2,0,(I.ADDR).[36:10],I.SEGNO); 00222300 - PUT(T+2,X); 00222400 - EMITOPDCLIT(TS); 00222500 - EMITO(IF C THEN BFC ELSE BFW); 00222600 - END; 00222700 -END ELSE 00222800 - BEGIN 00222900 - IF ADR < 0 THEN EMITO(NOP); 00223000 - EMITLINK(0); 00223100 - EMITO( IF C THEN BFC ELSE BFW); 00223200 - T ~ ENTER(0 & LABELID[TOCLASS] & (ADR-1)[TOADDR], LABL); 00223300 - EMITO(NOP); 00223400 - END; 00223500 - IF XREF THEN ENTERX(LABL,0&LABELID[TOCLASS]); 00223600 - XIT: 00223700 -END LABELBRANCH; 00223800 - 00223900 -PROCEDURE DATASET; % SCANS CONSTANTS IN BLOCK DATA 00224000 - BEGIN 00224100 - REAL LST,CUR,LTYP,CTYP,SIZ,RPT; 00224200 - REAL CUD; 00224300 - BOOLEAN SGN; 00224400 - DEFINE TYP = GLOBALNEXT#, 00224500 - TYPC = 18:33:15#; 00224600 - LABEL XIT,ERROR,DPP,SPP,CPP,COMM,S; 00224700 -IF DEBUGTOG THEN FLAGROUTINE(" DATA","SET ",TRUE) ; 00224800 - DATATOG ~ TRUE; FILETOG ~ TRUE; 00224900 - SCAN; 00225000 - LSTS ~ -1; LTYP ~77; 00225100 - S: IF TYP = PLUS OR (SGN ~ TYP = MINUS ) THEN SCAN; 00225200 - IF TYP = NUM THEN 00225300 - BEGIN 00225400 - IF NUMTYPE = STRINGTYPE AND STRINGSIZE > 1 THEN 00225500 - BEGIN 00225600 - IF LTYP ! 77 THEN 00225700 - BEGIN % NOT FIRST ENTRY-PUSH DOWN PRIOR NUMBER 00225800 - IF LSTS+2 > LSTMAX THEN 00225900 - BEGIN FLAG(127); GO TO ERROR END; 00226000 - LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; 00226100 - LSTT[LSTS~LSTS+1] ~ LST; 00226200 - LTYP ~ 77; 00226300 - END; 00226400 - 00226500 - IF LSTS + STRINGSIZE > LSTMAX THEN 00226600 - BEGIN FLAG(127); GO TO ERROR END; 00226700 - LSTT[LSTS~LSTS+1] ~ STRINGSIZE & STRINGTYPE[TYPC] 00226800 - & SIZ[3:33:15]; 00226900 - MOVEW(STRINGARRAY,LSTT[LSTS~LSTS+1], 00227000 - STRINGSIZE.[36:6],STRINGSIZE); 00227100 - LSTS ~ LSTS + STRINGSIZE -1; 00227200 - SCAN; 00227300 - GO TO COMM; 00227400 - END; 00227500 - % GOT NUMBER 00227600 - IF NUMTYPE = STRINGTYPE THEN 00227700 - BEGIN 00227800 - FNEXT ~ STRINGARRAY[0]; 00227900 - NUMTYPE ~ INTYPE; 00228000 - IF SIZ = 0 THEN SIZ ~ 1; 00228100 - END; 00228200 - CUR ~ IF SGN THEN -FNEXT ELSE FNEXT; 00228300 - CTYP ~ NUMTYPE; CUD ~ DBLOW; 00228400 - 00228500 - SCAN; 00228600 - IF TYP = COMMA OR TYP = SLASH THEN 00228700 - BEGIN 00228800 - IF SIZ = 0 THEN SIZ ~ 1; 00228900 - IF CTYP = DOUBTYPE THEN 00229000 - BEGIN 00229100 - DPP: IF LTYP ! 77 THEN 00229200 - BEGIN 00229300 - IF LSTS+2 > LSTMAX THEN 00229400 - BEGIN FLAG(127); GO TO ERROR END; 00229500 - LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; 00229600 - LSTT[LSTS~LSTS+1] ~ LST; 00229700 - LTYP ~ 77; 00229800 - END; 00229900 - IF LSTS+3 > LSTMAX THEN BEGIN FLAG(127); GO TO ERROR END; 00230000 - LSTT[LSTS~LSTS+1] ~ SIZ&DOUBTYPE[TYPC]; 00230100 - LSTT[LSTS~LSTS+1] ~ CUR; 00230200 - LSTT[LSTS~LSTS+1] ~ CUD; 00230300 - GO TO COMM; 00230400 - END; 00230500 - % SINGLE PRECISION 00230600 - SPP: 00230700 - IF LTYP = 77 THEN 00230800 - BEGIN 00230900 - LST ~ CUR; 00231000 - LTYP ~ CTYP; 00231100 - RPT ~ SIZ; 00231200 - GO TO COMM; 00231300 - END; 00231400 - IF LTYP = CTYP THEN 00231500 - IF REAL(BOOLEAN(CUR) EQV BOOLEAN(LST)) = REAL(NOT FALSE) THEN 00231600 - BEGIN 00231700 - RPT ~ RPT + SIZ; 00231800 - GO TO COMM; 00231900 - END; 00232000 - IF LSTS+2 > LSTMAX THEN BEGIN FLAG(127); GO TO ERROR END; 00232100 - LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; 00232200 - LSTT[LSTS~LSTS+1] ~ LST; 00232300 - RPT ~ SIZ; 00232400 - LST ~ CUR; LTYP ~ CTYP; 00232500 - GO TO COMM; 00232600 - END; 00232700 - % TYP ! COMMA - CHECK FOR * 00232800 - IF TYP ! STAR THEN BEGIN FLAG(125); GO TO ERROR END; 00232900 - IF CTYP ! INTYPE THEN BEGIN FLAG(113); GO TO ERROR END; 00233000 - IF SIZ ! 0 OR SIZ ~ CUR { 0 THEN 00233100 - BEGIN FLAG(64); GO TO ERROR END; 00233200 - SCAN; GO TO S; 00233300 - END; 00233400 - % TYP ! NUM AT LABEL S 00233500 - IF SIZ = 0 THEN SIZ ~ 1; 00233600 - IF NAME = "T " OR NAME = "F " THEN 00233700 - BEGIN 00233800 - CUR ~ REAL(NAME = "T "); 00233900 - CTYP ~ LOGTYPE; 00234000 - SCAN; GO TO SPP; 00234100 - END; 00234200 - IF TYP ! LPAREN THEN BEGIN FLAG(64); GO TO ERROR END; 00234300 - CPP: % COMPLEX 00234400 - IF LTYP ! 77 THEN 00234500 - BEGIN 00234600 - IF LSTS+2 > LSTMAX THEN 00234700 - BEGIN FLAG(127); GO TO ERROR END; 00234800 - LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; 00234900 - LSTT[LSTS~LSTS+1] ~ LST; 00235000 - LTYP ~ 77; 00235100 - END; 00235200 - SCAN; 00235300 - IF TYP = PLUS OR (SGN~TYP=MINUS) THEN SCAN; 00235400 - IF TYP ! NUM OR NUMTYPE > REALTYPE THEN 00235500 - BEGIN FLAG(64); GO TO ERROR END; 00235600 - IF LSTS+2 > LSTMAX THEN BEGIN FLAG(127); GO TO ERROR END;00235700 - LSTT[LSTS~LSTS+1] ~ SIZ&COMPTYPE[TYPC]; 00235800 - LSTT[LSTS~LSTS+1] ~ IF SGN THEN -FNEXT ELSE FNEXT; 00235900 - SCAN; 00236000 - IF TYP ! COMMA THEN BEGIN FLAG(114); GO TO ERROR END; 00236100 - SCAN; 00236200 - IF TYP = PLUS OR (SGN ~ TYP = MINUS) THEN SCAN; 00236300 - IF TYP ! NUM OR NUMTYPE > REALTYPE THEN 00236400 - BEGIN FLAG(64); GO TO ERROR END; 00236500 - LSTT[LSTS~LSTS+1]~IF SGN THEN - FNEXT ELSE FNEXT ; 00236600 - SCAN; 00236700 - IF TYP ! RPAREN THEN BEGIN FLAG(108); GO TO ERROR END; 00236800 - SCAN; 00236900 - COMM: 00237000 - SIZ ~ 0; 00237100 - IF TYP = COMMA THEN BEGIN SCAN; GO TO S; END; 00237200 - IF TYP = SLASH THEN GO TO XIT; 00237300 - FLAG(126); 00237400 - ERROR: 00237500 - LSTS ~ 0; 00237600 - WHILE TYP ! COMMA AND TYP ! SLASH AND TYP ! SEMI DO SCAN;00237700 - IF TYP = COMMA THEN GO TO COMM; 00237800 - XIT: 00237900 - IF LTYP ! 77 THEN 00238000 - BEGIN 00238100 - IF LSTS+2>LSTMAX THEN BEGIN FLAG(127); LSTS~0 END;00238200 - LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; 00238300 - LSTT[LSTS~LSTS+1] ~ LST; 00238400 - END; 00238500 - IF LSTS+1 > LSTMAX THEN BEGIN FLAG(127); LSTS~0 END; 00238600 - LSTT[LSTS~LSTS+1]~0; 00238700 -IF DEBUGTOG THEN FLAGROUTINE(" DATA","SET ",FALSE); 00238800 - DATATOG ~ FALSE; FILETOG ~ FALSE; 00238900 -END DATASET; 00239000 - 00239100 -ALPHA PROCEDURE CHECKDO; 00239200 -BEGIN ALPHA X, T; INTEGER N; 00239300 -STREAM PROCEDURE CKDO(A, ID, LAB); 00239400 -BEGIN 00239500 - SI ~ A; SI ~ SI+4; DI ~ LAB; DI ~ DI+2; 00239600 - 5(IF SC } "0" THEN DS ~ CHR ELSE JUMP OUT); 00239700 - DI ~ ID; DI ~ DI+2; 00239800 - 6(IF SC = ALPHA THEN DS ~ CHR ELSE JUMP OUT); 00239900 -END CKDO; 00240000 - IF (XTA~HOLDID[0]).[12:24] = "FILE" THEN FLOG(37) ELSE 00240100 - IF XTA.[12:12] ! "DO" THEN FLOG(17) ELSE 00240200 - BEGIN 00240300 - X ~ T ~ BLANKS; 00240400 - CKDO(HOLDID[0], X, T); 00240500 - IF X=BLANKS THEN FLOG(105); 00240600 - IF T ~ LBLSHFT(T) < 0 OR T = BLANKS THEN FLOG(17) ELSE 00240700 - TEST ~ NEED(T, LABELID); 00240800 - DOLAB[DT]~ T; 00240900 - IF XREF THEN ENTERX(T,0&LABELID[TOCLASS]); 00241000 - IF GET(TEST) < 0 THEN % TEST FOR PREV DEFINITION 00241100 - BEGIN 00241200 - XTA ~ GET(TEST+1); 00241300 - FLAG(15); 00241400 - DT ~ DT-1; 00241500 - END; 00241600 - IF N ~ SEARCH(X) = 0 THEN 00241700 - N~ENTER(TIPE[IF T~X.[12:6]!"0" THEN T ELSE 12],X); 00241800 - CHECKDO ~ GETSPACE(N); 00241900 - IF XREF THEN ENTERX(X,1&GET(N) [15:15:9]); 00242000 - IF (X~GET(N)).SUBCLASS > REALTYPE OR X.CLASS ! VARID THEN 00242100 - BEGIN XTA ~ GET(N+1); FLAG(84) END; 00242200 - IF GET(FX1).CLASS = UNKNOWN THEN PUT(FX1+1, "......"); 00242300 - END; 00242400 -END CHECKDO; 00242500 - 00242600 -PROCEDURE FIXB(N); VALUE N; REAL N; 00242700 -BEGIN 00242800 - REAL T, U, FROM; 00242900 - LABEL XIT, BIGJ; 00243000 -IF DEBUGTOG THEN FLAGROUTINE(" FI","XB ",TRUE); 00243100 - IF N } 10000 THEN FROM ~ N-10000 ELSE 00243200 - IF FROM ~ - BRANCHES[N] > 4095 THEN 00243300 - BEGIN 00243400 - ADJUST; 00243500 - T ~ PRGDESCBLDR(2, FROM.LINK, (ADR+1).[36:10], NSEG); 00243600 - GO TO XIT; 00243700 - END; 00243800 -T ~ ADR; ADR ~ FROM - 1; 00243900 -IF (T + 1).[46:2] = 0 THEN GO TO BIGJ; 00244000 -IF (U ~ T - 2 - ADR) { 1023 THEN EMITL(U) ELSE 00244100 -BEGIN ADR ~ T; ADJUST; T ~ ADR; ADR ~ FROM - 1; 00244200 -BIGJ: EMITL((T+1).[36:10] - (ADR+2).[36:10]); 00244300 - EMITO(IF BOOLEAN(GIT(FROM + 1).[36:1]) THEN GFW ELSE GFC); 00244400 -END; 00244500 -ADR ~ T; 00244600 - XIT: 00244700 - IF N < 10000 THEN BEGIN 00244800 - BRANCHES[N] ~ BRANCHX; 00244900 - BRANCHX ~ N; 00245000 - END; 00245100 -IF DEBUGTOG THEN FLAGROUTINE(" FI","XB ",FALSE); 00245200 -END FIXB; 00245300 - 00245400 -PROCEDURE DATIME; % PRODUCES HEADING LINE FOR LISTING. 00245500 - BEGIN 00245600 - INTEGER D; 00245700 - FORMAT T(X9,"B 5 7 0 0 F O R T R A N C O M P I L A T I O N ",00245800 -"XVI.0" 00245900 - ,",",A2,",",A8,"DAY, ",2(A2,"/"),A2,",",A2,":",A2," H,"/); 00246000 - WRITALIST(T,7, 00246100 - "16" %999-00246200 - ,TIME(6),(D~TIME(5)).[12:12],D.[24:12],D.[36:12], 00246300 - D~(D~RTI DIV 216000) MOD 10+D DIV 10|64, 00246400 - D~(D~RTI DIV 3600 MOD 60) MOD 10+D DIV 10|64,0) ; 00246500 - IF D~LINE.TYPE=10 OR D=12 OR D=13 THEN 00246600 - BEGIN 00246700 - LOCK(LINE); LINE.AREAS~0; LINE.AREASIZE~0 ; 00246800 - IF D ! 12 THEN LINE.TYPE~12; SPACE(LINE,2) ; 00246900 - END; 00247000 - FIRSTCALL~FALSE ; 00247100 - END DATIME; 00247200 - 00247300 -PROCEDURE PRINTCARD; 00247400 -BEGIN 00247500 - STREAM PROCEDURE MOVE(P, Q, A); VALUE A, Q; 00247600 - BEGIN 00247700 - SI ~ Q; DI ~ P; 00247800 - DS ~ CHR; 00247900 - DI ~ DI+11; SI ~ LOC A; 00248000 - DS ~ 4 DEC; 00248100 - END MOVE; 00248200 - STREAM PROCEDURE MOVEBACK(P); 00248300 - BEGIN DI ~ P; DS ~ LIT "]" END; 00248400 - MOVE (CRD[9],BUFL,(ADR+1).[36:10]); 00248500 - IF FIRSTCALL THEN DATIME; 00248600 - IF UNPRINTED THEN WRITAROW(15,CRD) ; 00248700 - MOVEBACK(CRD[9]); 00248800 - IF SEQERRORS THEN WRITAROW(14,ERRORBUFF) ; 00248900 -END PRINTCARD; 00249000 - 00249100 -BOOLEAN PROCEDURE READACARD; FORWARD; 00249200 -PROCEDURE FILEOPTION; FORWARD; 00249300 -BOOLEAN PROCEDURE LABELR; 00249400 -BEGIN 00249500 -LABEL XIT, LOOP; 00249600 -BOOLEAN STREAM PROCEDURE CHECK(CD, LAB); 00249700 -BEGIN LABEL XIT; LOCAL T1; 00249800 - SI ~ CD; 00249900 - IF SC ! " " THEN IF SC < "0" THEN 00250000 - BEGIN DI ~ LAB; DI ~ DI + 2; 00250100 - DS ~ 6 CHR; GO TO XIT; 00250200 - END; 00250300 - DI ~LOC T1; DS ~ 6 LIT " "; DI ~ DI -6; 00250400 - 5(IF SC } "0" THEN DS ~ CHR ELSE SI ~ SI+1); 00250500 - DI ~LAB; DI ~DI + 2; SI ~ LOC T1; 00250600 - 5(IF SC ! "0" THEN JUMP OUT; SI ~ SI + 1); 00250700 - 5(IF SC } "0" THEN DS ~ CHR ELSE JUMP OUT); 00250800 - TALLY ~ 1; 00250900 - XIT: CHECK ~ TALLY; 00251000 -END CHECK; 00251100 -BOOLEAN STREAM PROCEDURE BLANKCARD(CD); 00251200 -BEGIN LABEL XIT; 00251300 - SI ~ CD; 00251400 - 2(36( IF SC ! " " THEN JUMP OUT 2 TO XIT ELSE SI ~ SI + 1)); 00251500 - TALLY ~ 1; 00251600 - XIT: BLANKCARD ~ TALLY; 00251700 -END BLANKCARD; 00251800 - LOOP: 00251900 - LABL ~ BLANKS; 00252000 - IF LABELR ~ NOT READACARD THEN GO TO XIT; 00252100 - IF NOT CHECK(CRD[0],LABL) THEN 00252200 - BEGIN IF LABL = "FILE " THEN FILEOPTION ELSE 00252300 - BEGIN IF LISTOG THEN PRINTCARD; 00252400 - IF (XTA ~ LABL).[12:6] ! "C" THEN FLAG(135); 00252500 - END; 00252600 - GO TO LOOP; 00252700 - END; 00252800 - IF ENDSEGTOG THEN IF BLANKCARD(CRD) THEN 00252900 - BEGIN IF LISTOG THEN PRINTCARD; GO TO LOOP END ELSE 00253000 - BEGIN SEGMENTSTART; 00253100 - IF LISTOG THEN PRINTCARD; 00253200 - IF LABL = BLANKS THEN GO TO XIT; 00253300 - END ELSE 00253400 - BEGIN 00253500 - IF LABL = BLANKS THEN 00253600 - BEGIN IF LISTOG THEN PRINTCARD; GO TO XIT END; 00253700 - IF ADR > 0 THEN ADJUST; 00253800 - IF LISTOG THEN PRINTCARD; 00253900 - END; 00254000 - XIT: 00254100 -END LABELR; 00254200 - 00254300 -PROCEDURE FILEOPTION; 00254400 -BEGIN COMMENT THIS PROCEDURE PROCESSES THE OPTIONAL FILE CONTROL CARD. 00254500 -THE WORD "FILE" APPEARS IN COL. 1 - 4. COL. 5 AND 6 ARE BLANK. 00254600 -#1 BELOW IS REQUIRED, OTHER ENTRIES MAY BE AS SPARSE AS DESIRED. 00254700 -1. FILE = / 00254800 - OR 00254900 - FILE = 00255000 - THE FOLLOWING "/" IS A DOCUMMENTARY OR. 00255100 - THE SEQUENCE OF RESERVED WORDS MUST BE MAINTAINED. 00255200 -2. UNIT=PRINT/READER/PUNCH/DISK/TAPE7/TAPE9/REMOTE (UNIT DESIGNATE). 00255300 -3. UNLABELED (FOR UNLABELED TAPES) 00255400 -4. ALPHA (FOR ALPHA RECORDING MODE) 00255500 -5. BCL (IGNORED, FOR 3500 USE) 00255600 -6. FIXED (IGNORED, FOR 3500 USE) 00255700 -7. SAVE = (SAVE FACTOR IN DAYS) 00255800 -8. LOCK (LOCK FILE AT EOJ) 00255900 -9. RANDOM/SERIAL/UPDATE (DISK USE) 00256000 -10. AREA = (DISK RECORDS/ROW) 00256100 -11. BLOCKING = (RECORD PER BLOCK) 00256200 -12. RECORD = (RECORD SIZE) 00256300 -13. BUFFER = (# OF BUFFERS) 00256400 -14. WORKAREA (IGNORED, FOR 3500) ; 00256500 -ALPHA P,KEEP; BOOLEAN TOG,CA,TS; LABEL XIT; 00256600 -COMMENT INXFIL = INFC.ADINFO, MULTI FILE ID = FILEINFO[1,INXFIL], 00256700 - FILE ID = FILEINFO[2,INXFIL], DISK RECORDS = FILEINFO[3,INXFIL],00256800 - FILEINFO[0,INXFIL] FROM RIGHT TO LEFT IS; 00256900 -INTEGER % NAME USE BITS 00257000 - BUFF, % # BUFFERS 6 00257100 - RECORD, % RECORD SIZE 12 00257200 - BLOCK, % BLOCK SIZE 12 00257300 - SAVER, % SAVE FACTOR 12 00257400 - SPIN, % REW & LOCK @ EOJ 2 00257500 - ALPH; % RECORDING MODE 1 00257600 -PROCEDURE FETCH; 00257700 -BEGIN SCAN; XTA ~ SYMBOL; 00257800 - IF NEXT=COMMA OR NEXT=MINUS THEN 00257900 - BEGIN SCAN; XTA ~ SYMBOL; 00258000 - IF NEXT ! ID THEN FLOG(37); 00258100 - END; 00258200 -END FETCH; 00258300 -INTEGER STREAM PROCEDURE MAKEINT(XTA); 00258400 -BEGIN LABEL LOOP; LOCAL T; 00258500 -SI ~ XTA; SI ~ SI + 2; 00258600 -LOOP: IF SC } "0" THEN 00258700 - BEGIN TALLY ~ TALLY + 1; SI ~ SI + 1; GO TO LOOP END; 00258800 -T ~ TALLY; SI ~ XTA; SI ~ SI + 2; DI ~ LOC MAKEINT; DS ~ T OCT; 00258900 -END MAKEINT; 00259000 -INTEGER PROCEDURE REPLACEMENT; 00259100 -BEGIN 00259200 -FETCH; IF NEXT = EQUAL THEN 00259300 -BEGIN FETCH; IF XTA.[12:6] { 11 THEN BEGIN REPLACEMENT ~ MAKEINT(XTA); 00259400 - FETCH END ELSE FLOG(37); 00259500 -END ELSE FLOG(37); 00259600 -END REPLACEMENT; 00259700 -INTEGER STREAM PROCEDURE SRI7(S); 00259800 -BEGIN SI ~ S; DI ~ LOC SRI7; 00259900 - SI ~ SI + 2; DI ~ DI + 1; DS ~ 7 CHR; 00260000 -END SRI7; 00260100 -COMMENT * * * * * START OF CODE * * * * ; 00260200 -IF DEBUGTOG THEN FLAGROUTINE(" FILEO","PTION ", TRUE); 00260300 -ERRORTOG ~ FALSE; 00260400 -IF LISTOG THEN PRINTCARD; 00260500 -XTA ~ "FILE "; 00260600 -IF NSEG ! 0 THEN FLAG(60); 00260700 -IF INXFIL ~ INXFIL + 1 > MAXOPFILES THEN 00260800 -BEGIN FLAG(59); GO TO XIT END; 00260900 -BUMPPRT; 00261000 -MAXFILES ~ MAXFILES + 1; 00261100 -FILETOG ~ TRUE; SCN ~ 1; % START SCAN MAINTAINENCE 00261200 -FETCH; IF XTA.[12:6] > 11 THEN BEGIN FLAG(37); GO TO XIT END; 00261300 - IF XTA.[12:6] = 0 THEN BEGIN FLOG(037); GO TO XIT END; 00261400 -IF T ~ GLOBALSEARCH(P ~ 0&"."[12:42:6]&XTA[18:12:30]) ! 0 THEN FLAG(20) 00261500 -ELSE BEGIN P~ GLOBALENTER(-0&PRTS[TOADDR]&FILEID[TOCLASS],P); 00261600 - PUT(P+2,GET(P+2)&INXFIL[TOADINFO]); 00261700 - IF XREF THEN ENTERX(XTA &1[TOCE],1&FILEID[TOCLASS]); 00261800 - END; 00261900 -INFC ~ GET(P + 2); 00262000 -FETCH; IF NEXT = EQUAL THEN FETCH ELSE 00262100 - BEGIN FLOG(37); GO TO XIT; END; 00262200 -IF NEXT = SEMI THEN 00262300 -BEGIN FLAG(37); GO TO XIT END 00262400 - ELSE FILEINFO[2,INXFIL] ~ SRI7(ACCUM[1]); 00262500 -FETCH; IF NEXT = SLASH THEN 00262600 - BEGIN FILEINFO[1,INXFIL] ~ FILEINFO[2,INXFIL]; % MULTI FILE ID 00262700 - FETCH; 00262800 - IF NEXT = SEMI THEN BEGIN FLAG(37); GO TO XIT; END 00262900 - ELSE FILEINFO[2,INXFIL] ~ SRI7(ACCUM[1]); 00263000 - FETCH; 00263100 - END; 00263200 -IF XTA = "UNIT " THEN 00263300 -BEGIN 00263400 - FETCH; 00263500 - IF NEXT = EQUAL THEN FETCH ELSE FLOG(37); 00263600 - INFC.LINK ~ KEEP ~ (IF TOG ~ XTA = "PRINT " 00263700 - OR XTA = "PRINTE" THEN 18 ELSE 00263800 - IF CA ~ TOG ~ XTA = "READ " 00263900 - OR XTA = "READER" THEN 2 ELSE 00264000 - IF CA ~ TOG ~ XTA = "PUNCH " THEN 0 ELSE 00264100 - IF TOG ~ XTA = "DISK " THEN 12 ELSE 00264200 - IF TOG ~ XTA = "TAPE " 00264300 - OR XTA = "TAPE7 " THEN 2 ELSE 00264400 - IF TOG ~ XTA = "PAPER " THEN 8 ELSE 00264500 - IF CA ~TOG~XTA= "REMOTE" THEN 19 ELSE 00264600 - IF TOG ~ XTA = "TAPE9 " THEN 2 ELSE 2); 00264700 - IF TOG THEN FETCH ELSE FLOG(37) 00264800 -END ELSE INFC.LINK~KEEP~IF DCINPUT THEN 12 ELSE 2 ; 00264900 -TS~KEEP=12 ; 00265000 -IF XTA="BACKUP" THEN 00265100 - BEGIN 00265200 - FETCH; IF KEEP!0 AND KEEP!18 THEN FLAG(37); 00265300 - IF TOG~XTA="DISK " THEN KEEP~IF KEEP=0 THEN 22 ELSE 15 00265400 - ELSE IF TOG~XTA="TAPE " THEN KEEP~IF KEEP=0 THEN 20 ELSE 6 00265500 - ELSE BEGIN 00265600 - TOG~XTA="ALTERN"; KEEP~IF KEEP=0 THEN 25 ELSE 16 ; 00265700 - END; 00265800 - IF TOG THEN FETCH; INFC.LINK~KEEP ; 00265900 - END ; 00266000 -IF XTA = "UNLABE" THEN % FOR UNLABELED TAPES 00266100 - BEGIN IF KEEP = 2 THEN INFC .LINK ~ 9; FETCH; END; 00266200 -IF XTA = "ALPHA " THEN FETCH ELSE IF KEEP = 2 THEN ALPH ~ 1; % MODE 00266300 -IF XTA = "BCL " THEN FETCH; % FOR B3500 00266400 -IF XTA = "FIXED " THEN FETCH; % FOR B3500 00266500 -IF XTA = "SAVE " THEN SAVER ~ REPLACEMENT; 00266600 -IF XTA = "LOCK " THEN BEGIN SPIN ~ 2; FETCH END; % REW & LOCK AT EOJ 00266700 - IF TOG ~ XTA = "RANDOM" THEN T ~ 10 ELSE 00266800 - IF TOG ~ XTA = "SERIAL" THEN T ~ 12 ELSE 00266900 - IF TOG ~ XTA = "UPDATE" THEN T ~ 13; 00267000 -IF TOG THEN 00267100 - BEGIN IF KEEP=12 THEN INFC.LINK~T ELSE FLAG(37); FETCH END; 00267200 -IF XTA="AREA " THEN 00267300 - BEGIN 00267400 - IF KEEP!12 THEN FLAG(37); 00267500 - T~REPLACEMENT; 00267600 - IF XTA="EU " THEN 00267700 - IF I~REPLACEMENT>19 THEN FLAG(37) 00267800 - ELSE T.EUNF~I+1;% 0 MEANS EU NOT SPECIFIED 00267900 - IF XTA="SPEED " THEN 00268000 - BEGIN 00268100 - FETCH; 00268200 - IF NEXT=EQUAL THEN 00268300 - BEGIN 00268400 - FETCH; 00268500 - IF XTA.[12:6]{SLOWV THEN 00268600 - IF I~MAKEINT(XTA)>SLOWV THEN FLAG(37) 00268700 - ELSE 00268800 - ELSE IF XTA="FAST " THEN T.SPDF~FASTV 00268900 - ELSE IF XTA="SLOW " THEN T.SPDF~SLOWV 00269000 - ELSE FLOG(37); 00269100 - FETCH; 00269200 - END 00269300 - ELSE FLOG(37); 00269400 - END; 00269500 - IF XTA="SENSIT" THEN 00269600 - BEGIN 00269700 - T.SENSE~1; 00269800 - FETCH; 00269900 - END; 00270000 - FILEINFO[3,INXFIL]~T; 00270100 - END; 00270200 -IF XTA = "BLOCKI" THEN BLOCK ~ REPLACEMENT & 1[2:47:1]; 00270300 -RECORD ~ IF XTA="RECORD" THEN REPLACEMENT ELSE IF CA THEN 10 ELSE IF TS 00270400 - AND NOT (BOOLEAN(BLOCK.[2:1])) THEN 10 & 1[2:47:1] ELSE 17; 00270500 -BUFF ~ IF XTA = "BUFFER" THEN REPLACEMENT ELSE 2; 00270600 -IF XTA = "WORKAR" THEN FETCH; % IGNORED, FOR 3500 00270700 -IF BUFF<1 OR BUFF>32 THEN BEGIN XTA~"BUFFER"; FLAG(152) END ; 00270800 -IF RECORD<1 THEN BEGIN XTA~"RECORD"; FLAG(152)END ; 00270900 -IF SAVER>999 THEN BEGIN XTA~"SAVE "; FLAG(152) END ; 00271000 -IF T~INFC.LINK=10 OR T=12 OR T=13 THEN %%% ARE IN DISK FILE 00271100 - BEGIN 00271200 - IF BOOLEAN(RECORD.[2:1])THEN BLOCK ~ 300 00271300 - ELSE 00271400 - IF BLOCK~BLOCK|RECORD>1890 OR RECORD>1023 THEN 00271500 - BEGIN XTA~"BK/REC"; FLAG(152) END 00271600 - END 00271700 -ELSE IF BLOCK~BLOCK|RECORD>1023 OR RECORD>1023 THEN IF KEEP ! 2 THEN 00271800 - BEGIN XTA~"BK/REC"; FLAG(58 ) END ELSE BEGIN RECORD~257; BLOCK~0END;00271900 -FILEINFO[0,INXFIL] ~ 0&BUFF[42:42:6]&RECORD[30:36:12]&BLOCK[18:36:12] 00272000 - &SAVER[6:36:12]&SPIN[4:46:2]&ALPH[3:47:1]; 00272100 -XIT: IF NEXT ! SEMI THEN 00272200 - BEGIN FLOG(37); DO SCAN UNTIL NEXT = SEMI; END; 00272300 - FILETOG ~ FALSE; % END SCAN MAINTAINENCE 00272400 - PUT(P+2,INFC); 00272500 -IF DEBUGTOG THEN FLAGROUTINE(" FILEO","PTION ",FALSE) ; 00272600 -END FILEOPTION; 00272700 - 00272800 -PROCEDURE DOLOPT; 00272900 -BEGIN 00273000 -REAL STREAM PROCEDURE SCAN(BUF,ID); VALUE BUF; 00273100 - BEGIN LABEL LP,LA,LE,XIT; 00273200 - SI ~ BUF; DI ~ ID; DS ~ 2 LIT "0"; 00273300 - LP: IF SC = " " THEN BEGIN SI~SI+1; GO TO LP; END; 00273400 - IF SC = "," THEN BEGIN SI~SI+1; GO TO LP; END; 00273500 - IF SC = "+" THEN BEGIN DS~CHR; GO TO XIT; END; 00273600 - IF SC = "-" THEN BEGIN DS~CHR; GO TO XIT; END; 00273700 - IF SC < "A" THEN BEGIN DI ~ ID; DS ~ 8 LIT "+0000001"; 00273800 -LE: SI~SI+1; 00273900 - GO TO XIT; 00274000 - END; 00274100 - IF SC="|" THEN GO TO LE;% THIS IS > "A" 00274200 - IF SC="!" THEN GO TO LE;% THIS IS > "A" 00274300 - 6(IF SC = ALPHA THEN DS ~ CHR ELSE JUMP OUT); 00274400 - LA: IF SC = ALPHA THEN BEGIN SI~SI+1; GO TO LA; END; 00274500 - XIT: 00274600 - SCAN ~ SI; 00274700 - END SCAN; 00274800 -REAL STREAM PROCEDURE GETVOID(BUF,VOIDSEQ,FR); VALUE BUF,FR; 00274900 - BEGIN LABEL L,LC,LD,LE,XIT; LOCAL TA; 00275000 - SI ~ BUF; DI~VOIDSEQ; DS~8LIT" "; DI~VOIDSEQ; 00275100 - L: IF SC = " " THEN BEGIN SI~SI+1; GO TO L; END; 00275200 - TA ~ SI; 00275300 - IF SC = """ THEN 00275400 - BEGIN 9(SI~SI+1; 00275500 - IF SC = """ THEN BEGIN SI~SI+1; JUMP OUT TO LC; END 00275600 - ELSE TALLY ~ TALLY + 1); 00275700 - TALLY~TALLY+63; SI~TA; SI~SI+1; GO TO LE; 00275800 - END; 00275900 - IF SC < "0" THEN GO TO LD; 00276000 - DS:=8LIT"0"; %115-00276100 - 8(SI:=SI+1; DI:=DI-1; TALLY:=TALLY+1; %115-00276200 - IF SC LSS "0" THEN JUMP OUT); %115-00276300 - LC: SI ~ TA; 00276400 - LE: TA~TALLY; DS~TA CHR; GETVOID~SI; GO TO XIT; 00276500 - LD: GETVOID~SI; 00276600 - FR(DS~8LIT"9"); 00276700 - XIT: 00276800 - END GETVOID; 00276900 -REAL STREAM PROCEDURE SEQNUM(BUF,VLU); VALUE BUF; 00277000 - BEGIN LABEL L,LA,LC; LOCAL TA,TB; 00277100 - SI ~ BUF; 00277200 - L: IF SC = " " THEN BEGIN SI~SI+1; GO TO L; END; 00277300 - IF SC = "," THEN BEGIN SI~SI+1; GO TO L; END; 00277400 - TA ~ SI; 00277500 - IF SC = "+" THEN 00277600 - BEGIN SI~SI+1; 00277700 - LA: IF SC = " " THEN BEGIN SI~SI+1; GO TO LA;END; 00277800 - TB ~ SI; 00277900 - IF SC < "0" THEN BEGIN SI~TA; GO TO LC; END; 00278000 - DI~TB;TA~DI; 00278100 - END; 00278200 - 8(IF SC < "0" THEN JUMP OUT TO LC; 00278300 - TALLY~TALLY+1; SI~SI+1;); 00278400 - LC: TB ~ TALLY; SEQNUM ~ SI; 00278500 - SI ~ TA; DI ~ VLU; DS ~ TB OCT; 00278600 - END SEQNUM; 00278700 -REAL STREAM PROCEDURE MKABS(S); 00278800 - BEGIN SI ~ S; SI~SI+1; MKABS ~ SI; 00278900 - DI ~ S; 9(DI ~ DI + 8); DS ~ LIT "["; 00279000 - END MKABS; 00279100 -STREAM PROCEDURE MOVEW(P,Q); VALUE Q; 00279200 -BEGIN SI~P; DI ~ Q; DS~CHR; END ; 00279300 - REAL BUF,ID; 00279400 - BOOLEAN VAL, SAVELISTOG; %511-00279500 - LABEL LP,SET,RESET; 00279600 - FORMAT WARN(X18,A6," ILLEGAL CONSTRUCT ON DALLAR CARD XXXX",X39, 00279700 - "WARNING"); 00279800 - DEFINE GETID = BEGIN ID~ " "; BUF ~ SCAN(BUF,ID) END#; 00279900 - SAVELISTOG ~ LISTOG; %511- 00280000 - MOVEW(CRD[9],BUFL); 00280100 - BUF ~ MKABS(CRD[0]); 00280200 - GETID; 00280300 - IF ID = "VOID " THEN 00280400 - BEGIN BUF ~ GETVOID(BUF, VOIDSEQ,0); VOIDTOG ~ TRUE 00280500 - END ELSE 00280600 - IF ID = "VOIDT " THEN 00280700 - BEGIN BUF ~ GETVOID(BUF, VOIDTSEQ,0); VOIDTTOG ~ TRUE 00280800 - END ELSE 00280900 - BEGIN 00281000 - TAPETOG.[47:1] ~ LASTMODE = 2; %517-00281100 - IF ID = "SET " OR ID = "+ " THEN 00281200 -SET: BEGIN GETID; VAL~ TRUE END 00281300 - ELSE 00281400 - IF ID = "RESET " OR ID = "- " THEN 00281500 -RESET: BEGIN GETID; VAL ~ FALSE END 00281600 - ELSE 00281700 - BEGIN 00281800 - TSSMESTOG ~ VAL; TSSEDITOG ~ VAL; CHECKTOG ~ VAL; %501-00281900 - SINGLETOG~NOT VAL; HOLTOG~VAL; %501-00282000 - LISTOG~VAL; CODETOG ~ DEBUGTOG ~ VAL; NEWTPTOG ~ VAL; 00282100 - PRTOG~VAL; DOLIST~VAL; LIBTAPE~VAL; SEGPTOG~VAL; %501-00282200 - LISTPTOG ~ VAL; FREEFTOG ~ XREF ~ VAL ; 00282300 - VAL ~ TRUE; 00282400 - END; 00282500 -LP: IF ID > 0 THEN 00282600 - BEGIN 00282700 - IF ID = "TRACE " THEN 00282800 - BEGIN PRTOG~VAL; LISTOG~VAL; CODETOG~DEBUGTOG~VAL; 00282900 - END ELSE 00283000 - IF ID = "CARD " THEN 00283100 - BEGIN TAPETOG.[47:1]~NOT VAL; LASTMODE~2-REAL(VAL) END ELSE 00283200 - IF ID = "TAPE " THEN 00283300 - BEGIN TAPETOG.[47:1] ~ VAL; LASTMODE ~ REAL(VAL)+1; END ELSE00283400 - IF ID = "NOSEQ " THEN SEQTOG ~ FALSE ELSE 00283500 - IF ID = "SET " OR ID = "+ " THEN GO TO SET ELSE 00283600 - IF ID = "RESET " OR ID = "- " THEN GO TO RESET ELSE 00283700 - IF ID = "ONSITE" AND NOT REMFIXED THEN REMOTETOG ~ FALSE ELSE 00283800 - IF ID = "REMOTE" AND NOT REMFIXED THEN REMOTETOG ~ VAL ELSE 00283900 - IF ID = "FREEFO" THEN FREEFTOG ~ VAL ELSE 00284000 - IF ID = "SINGLE" OR ID = "SGL " THEN 00284100 - BEGIN SINGLETOG ~ VAL; LISTOG ~ TRUE; END ELSE 00284200 - IF ID = "NEW " OR ID = "NEWTAP" THEN 00284300 - BEGIN LIBTAPE~VAL; NEWTPTOG~VAL; NTAPTOG~TRUE; %501- 00284400 - IF ID = "NEW " THEN %501-00284500 - BEGIN %501-00284600 - GETID; %501-00284700 - IF ID ! "TAPE " THEN %501-00284800 - GO TO LP; %501-00284900 - END; %501-00285000 - END ELSE %501-00285100 - IF ID = "LIST " THEN LISTOG ~ VAL ELSE 00285200 - IF ID = "SEQXEQ" AND NOT SEGSWFIXED THEN SEGSW ~ VAL ELSE 00285300 - IF ID = "PRT " THEN PRTOG ~ VAL ELSE 00285400 - IF ID = "DEBUGN" THEN 00285500 - BEGIN LISTOG~VAL; CODETOG~VAL; PRTOG ~ VAL END ELSE 00285600 - IF ID = "TIME " THEN TIMETOG ~ VAL ELSE 00285700 - IF ID = "ERRMES" THEN TSSMESTOG ~ VAL ELSE 00285800 - IF ID = "TSSEDI" THEN TSSEDITOG ~ VAL ELSE 00285900 - IF ID = "LISTLI" THEN LISTLIBTOG ~ VAL ELSE 00286000 - IF(ID = "SEGMEN" OR ID = "SEG ") AND VAL THEN 00286100 - BEGIN ADR~ADR+1; SEGOVF; END ELSE 00286200 - IF ID = "PAGE " AND VAL THEN WRITE(LINE[PAGE]) ELSE 00286300 - IF ID = "VOID " THEN 00286400 - BEGIN VOIDTOG ~ VAL; 00286500 - IF VAL THEN BUF ~ GETVOID(BUF,VOIDSEQ,1); 00286600 - END ELSE 00286700 - IF ID = "VOIDT " THEN 00286800 - BEGIN VOIDTTOG ~ VAL; 00286900 - IF VAL THEN BUF ~ GETVOID(BUF,VOIDTSEQ,1); 00287000 - END ELSE 00287100 - IF ID = "LIMIT " THEN 00287200 - BEGIN LIMIT ~ IF VAL THEN 0 ELSE @60; 00287300 - BUF ~ SEQNUM(BUF,LIMIT); 00287400 - IF LIMIT LEQ ERRORCT THEN GO TO POSTWRAPUP; 00287500 - END ELSE 00287600 - IF ID = "XREF " THEN 00287700 - BEGIN 00287800 - PXREF ~ TRUE; XREF ~ VAL; 00287900 - END ELSE 00288000 - IF ID = "SEQ " THEN 00288100 - BEGIN SEQTOG ~ VAL; 00288200 - IF VAL THEN 00288300 - BEGIN SEQBASE ~ SEQINCR ~ 0; 00288400 - BUF ~ SEQNUM(BUF,SEQBASE); 00288500 - BUF ~ SEQNUM(BUF,SEQINCR); 00288600 - IF SEQINCR { 0 THEN SEQINCR ~ 1000; 00288700 - END END ELSE 00288800 - IF ID = "LISTDO" THEN DOLIST ~ VAL ELSE 00288900 - IF ID = "HOL " THEN HOLTOG ~ VAL ELSE 00289000 - IF ID = "CHECK " THEN CHECKTOG ~ VAL ELSE 00289100 - IF ID = "NEWPAG" THEN SEGPTOG ~ VAL ELSE %501-00289200 - IF ID = "LISTP " THEN LISTPTOG ~ VAL ELSE 00289300 - BEGIN IF FIRSTCALL THEN DATIME; 00289400 - IF UNPRINTED THEN BEGIN PRINTCARD; UNPRINTED~FALSE END; 00289500 - IF SINGLETOG THEN WRITE(LINE,WARN,ID) 00289600 - ELSE WRITE(RITE,WARN,ID); 00289700 - END 00289800 - ; 00289900 - GETID; 00290000 - GO TO LP; 00290100 - END; 00290200 - END; 00290300 - IF DOLIST OR LISTOG OR SAVELISTOG THEN %511-00290400 - IF UNPRINTED THEN PRINTCARD; %517-00290500 - UNPRINTED ~ TRUE; 00290600 -END DOLOPT; 00290700 - 00290800 -STREAM PROCEDURE NEWSEQ(A,B); VALUE B; 00290900 - BEGIN 00291000 - SI ~ LOC B; DI ~ A; DS ~ 8 DEC; 00291100 - END NEWSEQ; 00291200 -INTEGER STREAM PROCEDURE SEQCHK(T,C); 00291300 - BEGIN 00291400 - SI ~ T; DI ~ C; 00291500 - IF 8 SC < DC THEN TALLY ~ 4 ELSE 00291600 - BEGIN 00291700 - SI ~ SI - 8; DI ~ DI - 8; 00291800 - IF 8 SC =DC THEN TALLY ~ 2 00291900 - ELSE TALLY ~ 3; 00292000 - END; 00292100 - SEQCHK ~ TALLY; 00292200 - END SEQCHK; 00292300 -BOOLEAN PROCEDURE READACARD; 00292400 -BEGIN 00292500 -DEFINE FLAGI(FLAGI1) = BEGIN FLAG(FLAGI1); GO TO E4A;END #; 00292600 -REAL STREAM PROCEDURE SCANINC(BUF,ID,RESULT,N,M); 00292700 - VALUE BUF,M,N; 00292800 - BEGIN 00292900 - LOCAL TA; 00293000 - LABEL LP,LQ,XIT; 00293100 - DI := RESULT; DI := DI +7; 00293200 - SI := BUF; 00293300 - LP: IF SC = " " THEN BEGIN SI := SI + 1; GO TO LP; END; 00293400 - IF SC = ALPHA THEN ELSE BEGIN DS:=LIT "1"; DI:=ID; DS~2LIT"0"; 00293500 - DS := CHR; DS := 5LIT" ";GO TO XIT; END; 00293600 - IF SC LSS "0" THEN DS:=LIT "2" ELSE DS:=LIT "3"; %400-00293700 - N (DI:=ID; DS:=8 LIT "0 "; DI:=DI-7; %400-00293800 - 7(IF SC=ALPHA THEN DS~CHR ELSE JUMP OUT 2 TO XIT); 00293900 - JUMP OUT TO XIT); 00294000 - M ( 8 ( IF SC LSS "0" THEN JUMP OUT 2 TO LQ; %400-00294100 - IF SC GTR "9" THEN JUMP OUT 2 TO LQ; %400-00294200 - SI:=SI+1; TALLY:=TALLY+1)); %400-00294300 - LQ: TA := TALLY; 00294400 - SI := SI - TA; 00294500 - DI := ID; 00294600 - DS := TA OCT; 00294700 - XIT: SCANINC := SI; 00294800 - END SCANINC; 00294900 -REAL STREAM PROCEDURE MKABS(S); 00295000 - BEGIN SI := S; SI := SI + 1; MKABS := SI; END; 00295100 -STREAM PROCEDURE MOVE(P, Q); VALUE Q; 00295200 -BEGIN SI ~ P; DI ~ Q; DS ~ CHR; 00295300 - DI ~ P; DS ~ LIT "]"; 00295400 -END MOVE; 00295500 -STREAM PROCEDURE MOVEC(C,B); VALUE B; 00295600 -BEGIN SI~B; DI~C; DS~CHR; END; 00295700 -BOOLEAN STREAM PROCEDURE GETCOL1(BUF); 00295800 - BEGIN 00295900 - SI ~ BUF; IF SC = "$" THEN TALLY ~ 1; 00296000 - GETCOL1 ~ TALLY; 00296100 - END; 00296200 -STREAM PROCEDURE TSSEDITS(C,P); BEGIN SI~C; DI~P; DS~10WDS; SI~C ; 00296300 -IF SC="C" THEN BEGIN DI~P; DI~DI+1; DS~LIT"-" END ELSE 00296400 -IF SC!"$" THEN BEGIN SI~SI+5; IF SC!" " THEN IF SC!"0" THEN BEGIN DI~P;00296500 -DS~6LIT"- " END END END OF TSSEDITS ; 00296600 -STREAM PROCEDURE MOVEW(F,T,B,R); VALUE B, R; 00296700 - BEGIN 00296800 - LABEL XIT; 00296900 - SI ~ F; DI ~ T; 00297000 - B( 00297100 - 2(40( IF SC = ALPHA THEN DS ~ CHR ELSE 00297200 - IF SC = " " THEN DS ~ CHR ELSE 00297300 - IF SC = "%" THEN BEGIN DS ~ LIT "("; SI ~ SI+1 END ELSE 00297400 - IF SC = "[" THEN BEGIN DS ~ LIT ")"; SI ~ SI+1 END ELSE 00297500 - IF SC = "#" THEN BEGIN DS ~ LIT "="; SI ~ SI+1 END ELSE 00297600 - IF SC = "&" THEN BEGIN DS ~ LIT "+"; SI ~ SI+1 END ELSE 00297700 - IF SC = "@" THEN BEGIN DS ~ LIT """; SI ~ SI+1 END ELSE 00297800 - IF SC = ":" THEN BEGIN DS ~ LIT """; SI ~ SI+1 END ELSE 00297900 - IF SC = "<" THEN BEGIN DS ~ LIT "+"; SI ~ SI+1 END ELSE 00298000 - IF SC = ">" THEN BEGIN DS ~ LIT "="; SI ~ SI+1 END ELSE 00298100 - DS ~ CHR )); JUMP OUT TO XIT); 00298200 - XIT: 00298300 - SI~LOC R; SI~SI+7; DI~DI+1 ; 00298400 - DS~CHR ; 00298500 - END MOVEW; 00298600 -ALPHA STREAM PROCEDURE DCMOVEW(F,T,B,FIL,R); VALUE B,FIL,R; 00298700 - BEGIN LOCAL C; LABEL L1,L2,L3,L4 ; 00298800 - SI~F; DI~T; 2(SI~SI+36; DS~36LIT" "); C~SI; DS~8CHR ; 00298900 - SI~LOC R; SI~SI+6; DS~2CHR; DI~C; DS~8LIT"]";TALLY~33;SI~F; 00299000 - IF SC = " " THEN %%% IT MIGHT BE A FILES CARD. 00299100 - BEGIN SI~SI+1; IF SC="F" THEN 00299200 - BEGIN DI~LOC FIL; DI~DI+2; IF 5SC=DC THEN 00299300 - BEGIN DI~F; SI~LOC FIL; SI~SI+2; DS~6CHR ; GO TO L1; END 00299400 - ELSE SI~F END ELSE SI~F END 00299500 - ELSE IF SC = "F" THEN BEGIN DI~LOC FIL;DI~DI+2;IF 6SC=DC THEN GO L1 00299600 - ELSE SI~F;END 00299700 - ELSE IF SC="-" THEN 00299800 - BEGIN %%% IT IS A CONTINUATION CARD. 00299900 - SI~SI+1; DI~T; DS~6LIT" *" ; 00300000 - 5(IF SC=" " THEN SI~SI+1 ELSE JUMP OUT); GO TO L2 ; 00300100 - END 00300200 - ELSE IF SC="C" THEN 00300300 - BEGIN %%% IT MIGHT BE A COMMENT CARD. 00300400 - SI~SI+1; IF SC="-" THEN GO TO L1 ELSE SI~F ; 00300500 - END ; 00300600 - IF SC!"$" THEN %%% IT IS NOT A COMMENT CARD, NOR IS IT A $ CARD, 00300700 - BEGIN %%% NOR A CONTINUATION CARD, NOR A FILES CARD. 00300800 - 2(33(IF SC=" " THEN SI~SI+1 ELSE JUMP OUT 2 TO L3)); L3: DI~T;00300900 - 5(IF SC=" " THEN SI~SI+1 ELSE IF SC}"0" THEN IF SC{"9" 00301000 - THEN DS~CHR ELSE JUMP OUT ELSE JUMP OUT) ; 00301100 - DI~T; DI~DI+6; IF SC=" " THEN SI~SI+1 ; 00301200 - END 00301300 - ELSE 00301400 - BEGIN 00301500 - L1: SI~F; DI~T; TALLY~36 ; 00301600 - END ; 00301700 - L2: C~TALLY ; 00301800 - B(2(C(IF SC>">" THEN DS~CHR ELSE IF SC<"[" THEN DS~CHR ELSE 00301900 - IF SC="%" THEN BEGIN DS~LIT"("; SI~SI+1 END ELSE 00302000 - IF SC="#" THEN BEGIN DS~LIT"="; SI~SI+1 END ELSE 00302100 - IF SC="&" THEN BEGIN DS~LIT"+"; SI~SI+1 END ELSE 00302200 - IF SC="@" THEN BEGIN DS~LIT"""; SI~SI+1 END ELSE 00302300 - IF SC=":" THEN BEGIN DS~LIT"""; SI~SI+1 END ELSE 00302400 - IF SC="<" THEN BEGIN DS~LIT"+"; SI~SI+1 END ELSE 00302500 - IF SC=">" THEN BEGIN DS~LIT"="; SI~SI+1 END ELSE 00302600 - IF SC="[" THEN BEGIN DS~LIT")"; SI~SI+1 END ELSE 00302700 - IF SC="]" THEN JUMP OUT 3 TO L4 ELSE DS~CHR));JUMP OUT TO L4);00302800 - 2(C(IF SC="]" THEN JUMP OUT 2 TO L4 ELSE DS~CHR)) ; 00302900 - L4: DI~LOC DCMOVEW; DS~8LIT"00 "; DI~DI-6 ; 00303000 - 6(IF SC="]" THEN JUMP OUT ELSE DS~CHR) ; 00303100 - END OF DCMOVEW ; 00303200 -STREAM PROCEDURE SEQERR(BUFF, NEW, OLD); 00303300 -BEGIN 00303400 - DI ~ BUFF; DS ~ 18 LIT "SEQUENCE ERROR "; 00303500 - SI ~ NEW; DS ~ LIT"""; 00303600 - DS ~ 8 CHR; DS ~ LIT """; 00303700 - DS ~ 3 LIT " < "; 00303800 - SI ~ OLD; DS ~ LIT """; 00303900 - DS ~ 8 CHR; DS ~ LIT """; 00304000 - DS ~ 59 LIT " "; 00304100 - DS ~ 8 LIT "X"; DS ~ 4 LIT " "; 00304200 -END SEQERR; 00304300 -STREAM PROCEDURE DCMOVE(E,C,A,N); VALUE A,N; 00304400 -BEGIN SI~C; DI~E; DS~10WDS; DS~4CHR; SI~LOC A; DS~4DEC; 00304500 - N(DS~8LIT" PATCH"); END; 00304600 - REAL BUF,ID; 00304700 - BOOLEAN NOWRI; LABEL ENDPB, E4B; 00304800 - LABEL LIBADD, ENDPA, E4A, E4, STRTA; 00304900 - LABEL E1,E2,E3,STRT,ENDP,XIT; 00305000 - UNPRINTED~TRUE; 00305100 - GO TO STRT; 00305200 -LIBADD: 00305300 - XTA := BLANKS; 00305400 - IF INSERTDEPTH = -1 THEN SAVECARD ~ NEXTCARD; 00305500 - MOVE (CRD[9],BUFL); 00305600 - 00305700 - IF (INSERTDEPTH ~ INSERTDEPTH + 1) GTR INSERTMAX THEN 00305800 - FLAG(158); 00305900 - NEWTPTOG ~ FALSE; 00306000 - INSERTINX ~ -1; 00306100 - INSERTCOP ~ 0; 00306200 - BLANKIT(SSNM[5],1,0); 00306300 - BUF ~ SCANINC(BUF,INSERTMID,RESULT,1,0); 00306400 - IF RESULT = 1 AND INSERTMID = "+ "THEN 00306500 - BEGIN BUF~SCANINC(BUF,ID,RESULT,1,0); 00306600 - IF ID = "COPY " THEN INSERTCOP ~ 1 00306700 - ELSE FLAG(155); 00306800 - BUF~SCANINC(BUF,INSERTMID,RESULT,1,0); 00306900 - END; 00307000 - IF RESULT NEQ 2 THEN FLAGI (155); 00307100 - BUF := SCANINC(BUF,ID,RESULT,0,1); %107-00307200 - IF RESULT = 1 THEN IF ID = "/ " THEN 00307300 - BEGIN BUF := SCANINC(BUF,INSERTFID,RESULT,1,0); 00307400 - IF RESULT NEQ 2 THEN FLAGI(155); 00307500 - BUF := SCANINC(BUF,ID,RESULT,0,1); 00307600 - END ELSE INSERTFID := TIME(-1) ELSE INSERTFID := TIME(-1); 00307700 - IF RESULT = 3 THEN 00307800 - BEGIN NEWSEQ(SSNM[5],ID); 00307900 - BUF := SCANINC(BUF,ID,RESULT,0,1); 00308000 - IF RESULT NEQ 1 THEN FLAGI(156); 00308100 - IF ID = "] " THEN NEWSEQ (INSERTSEQ,99999999) %400-00308200 - ELSE BEGIN %400-00308300 - BUF ~ SCANINC(BUF,ID,RESULT,0,1); 00308400 - IF RESULT NEQ 3 THEN FLAGI(157); 00308500 - NEWSEQ (INSERTSEQ,ID); 00308600 - END %400-00308700 - END ELSE IF ID = "] " THEN NEWSEQ(INSERTSEQ,999999999) 00308800 - ELSE FLAGI(157); 00308900 - IF INSERTDEPTH > 0 THEN CLOSE (LF,RELEASE); 00309000 - FILL LF WITH INSERTMID,INSERTFID; 00309100 - DO BEGIN 00309200 - READ (LF[INSERTINX ~ INSERTINX+1],10,DB[*])[E4]; 00309300 - END UNTIL SEQCHK(SSNM[5],DB[9]) NEQ 3; 00309400 - NEWTPTOG ~ BOOLEAN(INSERTCOP); 00309500 - IF NOT NEWTPTOG THEN 00309600 - BEGIN 00309700 - IF SEQTOG THEN 00309800 - BEGIN NEWSEQ(CRD[9],SEQBASE); MOVE(CRD[9],BUFL); 00309900 - SEQBASE~SEQBASE+SEQINCR; 00310000 - END; MOVEC(CRD[9],BUFL); 00310100 - IF LIBTAPE AND(INSERTDEPTH = 0 ) THEN WRITE(NEWTAPE,10,CRD[*]); 00310200 - END; %511- 00310300 - IF LISTOG OR DOLIST THEN PRINTCARD; %511- 00310400 - NEXTCARD~7; 00310500 - GO TO STRT; 00310600 - E1: IF NEXTCARD=1 THEN IF TAPETOG THEN 00310700 - BEGIN 00310800 - NEXTCARD~5; READ(TP,10,TB[*])[E2]; GO TO STRT ; 00310900 - END 00311000 - ELSE 00311100 - BEGIN 00311200 - NEXTCARD:=6; 00311300 - IF GETCOL1(CRD[0]) THEN BEGIN BUF := MKABS(CRD[0]); 00311400 - BUF:=SCANINC(BUF,ID,RESULT,1,0); IF ID NEQ INCLUDE 00311500 - THEN BLANKIT(CRD,9,1); END; 00311600 - GO TO ENDP ; 00311700 - END ; 00311800 - NEXTCARD ~ 5; GO TO ENDP; 00311900 - E2: IF NEXTCARD = 5 THEN 00312000 - BEGIN 00312100 - NEXTCARD:=6; 00312200 - IF GETCOL1(CRD[0]) THEN BEGIN BUF := MKABS(CRD[0]); 00312300 - BUF:=SCANINC(BUF,ID,RESULT,1,0); IF ID NEQ INCLUDE 00312400 - THEN BLANKIT(CRD,9,1); END; 00312500 - END 00312600 - ELSE IF NEXTCARD!2 THEN NEXTCARD~1 ELSE 00312700 - BEGIN 00312800 - NEXTCARD~1; TAPETOG~BOOLEAN(2); READ(CR,10,CB[*])[E1] ; 00312900 - END ; 00313000 - IF VOIDTTOG THEN IF SEQCHK(CRD[0],VOIDTSEQ) < 4 %114-01313100 - THEN VOIDTTOG~FALSE %114-01313200 - ELSE BEGIN VOIDTTOG~FALSE; GO TO STRT; END; %114-01313300 - GO TO ENDP ; 00313400 - E4B: NOWRI ~TRUE; 00313500 - IF SEQTOG THEN NEWSEQ(CRD[9],SEQBASE); 00313600 - IF NEWTPTOG THEN IF TSSEDITOG THEN 00313700 - BEGIN TSSEDITS(CRD,PRINTBUFF); WRITE(NEWTAPE,10,PRINTBUFF[*]); 00313800 - END ELSE WRITE(NEWTAPE,10,CRD[*]); 00313900 - E4: CLOSE (LF,RELEASE); 00314000 - NEWTPTOG~ SAVETOG; 00314100 - IF (INSERTDEPTH := INSERTDEPTH - 1) = -1 THEN 00314200 - BEGIN NEXTCARD ~ SAVECARD; GO TO ENDPA; END 00314300 - ELSE NEWTPTOG ~ BOOLEAN(INSERTCOP); 00314400 - FILL LF WITH INSERTMID,INSERTFID; 00314500 - READ(LF[INSERTINX := INSERTINX + 1],10,DB[*])[E4]; 00314600 - IF SEQCHK(INSERTSEQ,DB[9]) = 4 THEN GO TO E4; 00314700 - GO TO ENDP; 00314800 - E4A: 00314900 - NEWTPTOG~SAVETOG; 00315000 - IF (INSERTDEPTH ~ INSERTDEPTH-1) = -1 THEN NEXTCARD~SAVECARD 00315100 - ELSE NEWTPTOG ~ BOOLEAN(INSERTCOP); 00315200 - STRT: 00315300 - STRTA: 00315400 - IF NEXTCARD=6 THEN GO XIT ; 00315500 - CARDCOUNT ~ CARDCOUNT+1; 00315600 - IF NEXTCARD = 1 THEN 00315700 - BEGIN % CARD ONLY 00315800 - IF(NOT DCINPUT OR TSSEDITOG)AND NOT FREEFTOG 00315900 - THEN MOVEW(CB,CRD,HOLTOG,IF DCINPUT THEN "D" ELSE "R") 00316000 - ELSE IF SSNM[4]~DCMOVEW(CB,CRD,HOLTOG,"FILE ",IF FREEFTOG 00316100 - THEN " R" ELSE " D") ! " " THEN 00316200 - BEGIN XTA~SSNM[4] ; 00316300 - MOVESEQ(SSNM[4],LASTSEQ); MOVESEQ(LASTSEQ,CRD[9]) ; 00316400 - IF LISTOG THEN 00316500 - BEGIN IF FIRSTCALL THEN DATIME ; 00316600 - DCMOVE(PRINTBUFF,CRD,(ADR+1).[36:10],0); 00316700 - WRITAROW(11,PRINTBUFF); UNPRINTED~FALSE ; 00316800 - END ; 00316900 - FLOG(149); MOVESEQ(LASTSEQ,SSNM[4]) ; 00317000 - END ; 00317100 - IF GETCOL1(CRD[0]) THEN 00317200 - BEGIN 00317300 - BUF := MKABS(CRD[0]); 00317400 - BUF := SCANINC(BUF,ID,RESULT,1,0); 00317500 - IF ID NEQ INCLUDE THEN 00317600 - BEGIN 00317700 - DOLOPT; 00317800 - IF REAL(TAPETOG)=3 THEN READ(TP) ; 00317900 - READ(CR,10,CB[*])[E1]; 00318000 - IF NOT TAPETOG THEN GO TO STRT; 00318100 - READ(TP,10,TB[*])[E2]; 00318200 - NEXTCARD ~ SEQCHK(TB[9], CB[9]); 00318300 - GO TO STRT; 00318400 - END; 00318500 - END; 00318600 - IF LISTPTOG THEN 00318700 - BEGIN IF FIRSTCALL THEN DATIME; 00318800 - IF SEQTOG THEN NEWSEQ(CRD[9],SEQBASE); 00318900 - DCMOVE(PRINTBUFF,CRD,(ADR+1).[36:10],1); 00319000 - WRITAROW (12,PRINTBUFF); UNPRINTED ~ FALSE; 00319100 - END; 00319200 - READ(CR,10,CB[*])[E1]; 00319300 - GO TO ENDP; 00319400 - END; 00319500 - IF NEXTCARD = 5 THEN 00319600 - BEGIN 00319700 - MOVEW(TB,CRD,HOLTOG,"T") ; 00319800 - READ(TP, 10, TB[*])[E2]; 00319900 - IF VOIDTTOG THEN IF SEQCHK(CRD[9],VOIDTSEQ) < 4 THEN 00320000 - VOIDTTOG ~ FALSE ELSE GO TO STRT; 00320100 - GO TO ENDP; 00320200 - END; 00320300 - IF NEXTCARD { 3 THEN 00320400 - BEGIN % CARD OVER TAPE 00320500 - IF(NOT DCINPUT OR TSSEDITOG)AND NOT FREEFTOG 00320600 - THEN MOVEW(CB,CRD,HOLTOG,IF DCINPUT THEN "D" ELSE "R") 00320700 - ELSE IF SSNM[4]~DCMOVEW(CB,CRD,HOLTOG,"FILE ",IF FREEFTOG 00320800 - THEN " R" ELSE " D") ! " " THEN 00320900 - BEGIN XTA~SSNM[4] ; 00321000 - MOVESEQ(SSNM[4],LASTSEQ); MOVESEQ(LASTSEQ,CRD[9] ); 00321100 - IF LISTOG THEN 00321200 - BEGIN IF FIRSTCALL THEN DATIME; 00321300 - DCMOVE(PRINTBUFF,CRD,(ADR+1).[36:10],0); 00321400 - WRITAROW(11,PRINTBUFF); UNPRINTED~FALSE ; 00321500 - END; 00321600 - FLOG(149); MOVESEQ(LASTSEQ,SSNM[4]) ; 00321700 - END; 00321800 - IF NEXTCARD =2 THEN READ(TP,10,TB[*])[E2]; 00321900 - IF GETCOL1(CRD) THEN 00322000 - BEGIN 00322100 - BUF ~ MKABS(CRD[0]); 00322200 - BUF ~ SCANINC(BUF,ID,RESULT,1,0); 00322300 - IF ID NEQ INCLUDE THEN 00322400 - BEGIN 00322500 - DOLOPT; 00322600 - READ(CR,10,CB[*])[E3]; 00322700 - NEXTCARD ~ SEQCHK(TB[9], CB[9]); 00322800 - GO TO STRT; 00322900 - E3: NEXTCARD~5; GO TO STRT; 00323000 - END; 00323100 - END; 00323200 - IF LISTPTOG THEN 00323300 - BEGIN IF FIRSTCALL THEN DATIME; 00323400 - IF SEQTOG THEN NEWSEQ(CRD[9],SEQBASE); 00323500 - DCMOVE(PRINTBUFF,CRD,(ADR+1).[36:10],1); 00323600 - WRITAROW (12,PRINTBUFF); UNPRINTED ~ FALSE; 00323700 - END; 00323800 - READ(CR,10,CB[*])[E1]; 00323900 - NEXTCARD ~ SEQCHK(TB[9], CB[9]); 00324000 - GO TO ENDP; 00324100 - END; 00324200 - % TAPE BEFORE CARD 00324300 - IF NEXTCARD = 7 THEN 00324400 - BEGIN 00324500 - IF(NOT DCINPUT OR TSSEDITOG)AND NOT FREEFTOG 00324600 - THEN MOVEW(DB,CRD,HOLTOG,"L") ELSE IF XTA~DCMOVEW(DB,CRD, 00324700 - HOLTOG,"FILE ",IF FREEFTOG THEN " R" ELSE " D") 00324800 - ! " " THEN FLOG(149); 00324900 - IF GETCOL1(CRD[0]) THEN 00325000 - BEGIN 00325100 - BUF ~ MKABS(CRD[0]); 00325200 - BUF ~ SCANINC(BUF,ID,RESULT,1,0); 00325300 - IF ID = INCLUDE THEN GO TO LIBADD; 00325400 - END; 00325500 - READ(LF[INSERTINX~INSERTINX+1],10,DB[*])[E4B]; 00325600 - IF SEQCHK(INSERTSEQ,DB[9]) = 4 THEN GO TO E4B; 00325700 - IF GETCOL1(CRD[0]) THEN BEGIN DOLOPT; GO TO STRT; END; 00325800 - GO TO ENDP; 00325900 - END; 00326000 - MOVEW(TB,CRD,HOLTOG,"T") ; 00326100 - READ(TP,10,TB[*])[E2]; 00326200 - IF VOIDTTOG THEN IF SEQCHK(CRD[9],VOIDTSEQ) < 4 THEN 00326300 - VOIDTTOG~FALSE ELSE BEGIN NEXTCARD~SEQCHK(TB[9],CB[9]); %114-00326400 - GO TO STRT; END; %114-00326500 - NEXTCARD ~ SEQCHK(TB[9], CB[9]); 00326600 - ENDP: 00326700 - IF NEXTCARD NEQ 7 THEN 00326800 - IF VOIDTOG THEN IF SEQCHK(CRD[9],VOIDSEQ) < 4 THEN 00326900 - VOIDTOG ~ FALSE ELSE GO TO STRT; 00327000 - IF GETCOL1(CRD[0]) THEN 00327100 - BEGIN 00327200 - BUF ~ MKABS(CRD[0]); 00327300 - BUF ~ SCANINC(BUF,ID,RESULT,1,0); 00327400 - IF ID = INCLUDE THEN GO TO LIBADD ELSE GO TO STRT; 00327500 - END; 00327600 - SEQERRORS ~ FALSE; 00327700 - IF NEXTCARD = 7 THEN 00327800 - BEGIN MOVESEQ(LASTSEQ,CRD[9]); GO TO ENDPA; END; 00327900 - IF CHECKTOG AND SEQERRCT=0 THEN SEQERRCT~1 ; 00328000 - IF CHECKTOG THEN IF SEQCHK(LASTSEQ,CRD[9])=3 THEN 00328100 - BEGIN 00328200 - SEQERR(ERRORBUFF,CRD[9],LASTSEQ) ; 00328300 - MOVESEQ(LASTSEQ,CRD[9]) ; 00328400 - IF SEQTOG THEN 00328500 - BEGIN NEWSEQ(CRD[9],SEQBASE);SEQBASE~SEQBASE+SEQINCR END;00328600 - MOVESEQ(LINKLIST,CRD[9]); 00328700 - MOVE(CRD[9],BUFL) ; 00328800 - SEQERRCT~SEQERRCT+1 ; 00328900 - SEQERRORS~TRUE ; 00329000 - IF NOT LISTOG THEN PRINTCARD ; 00329100 - END 00329200 - ELSE MOVESEQ(LASTSEQ,CRD[9]) ELSE MOVESEQ(LASTSEQ,CRD[9]) ; 00329300 - 00329400 - 00329500 - 00329600 - 00329700 - 00329800 - 00329900 - 00330000 - 00330100 -ENDPA: 00330200 - IF SEQTOG THEN 00330300 - BEGIN 00330400 - NEWSEQ(CRD[9],SEQBASE); 00330500 - SEQBASE ~ SEQBASE + SEQINCR; 00330600 - END; 00330700 - IF NOWRI THEN GO TO ENDPB; 00330800 - IF NEWTPTOG THEN IF TSSEDITOG THEN BEGIN TSSEDITS(CRD,PRINTBUFF) ; 00330900 - WRITE(NEWTAPE,10,PRINTBUFF[*]) END ELSE WRITE(NEWTAPE,10,CRD[*]) ; 00331000 -ENDPB: 00331100 - IF NOT SEQERRORS THEN 00331200 - BEGIN 00331300 - MOVESEQ(LINKLIST,CRD[9]) ; 00331400 - MOVE(CRD[9],BUFL) ; 00331500 - END ; 00331600 - NCR ~ INITIALNCR; 00331700 - READACARD ~ TRUE; 00331800 -XIT: 00331900 - SEGSWFIXED ~ TRUE ; 00332000 - REMFIXED~TRUE ; 00332100 - IF TSSEDITOG THEN WARNED~TRUE ; 00332200 - IF LISTOG AND FIRSTCALL THEN DATIME; 00332300 - IF SEGSW THEN %%% ENTER SEQ# AND ADR TO LINESEG ARRAY. 00332400 - BEGIN IF LASTADDR!ADR THEN BEGIN NOLIN~NOLIN+1; LASTADDR~ADR END;00332500 - LINESEG[NOLIN.IR,NOLIN.IC]~0 & D2B(LASTSEQ)[10:20:28] & (ADR+3) 00332600 - [38:36:10] ; 00332700 - END ; 00332800 -END READACARD; 00332900 - 00333000 -INTEGER STREAM PROCEDURE CONVERT(NUB,SIZE,P,CHAR); VALUE P; 00333100 - BEGIN 00333200 - LOCAL T; 00333300 - SI ~ P; 00333400 - 8(IF SC < "0" THEN JUMP OUT; 00333500 - SI ~ SI + 1; TALLY ~ TALLY + 1); 00333600 - CONVERT ~ SI; 00333700 - DI ~ CHAR; DS ~ 7 LIT "0"; DS ~ CHR; 00333800 - T ~ TALLY; 00333900 - SI ~ P; DI ~ NUB; DS ~ T OCT; 00334000 - DI ~ SIZE ; SI ~ LOC T; DS ~ WDS; 00334100 - END CONVERT; 00334200 -PROCEDURE SCAN; 00334300 -BEGIN 00334400 -BOOLEAN STREAM PROCEDURE ADVANCE(NCR, ACR, CHAR, NCRV, ACRV); 00334500 -VALUE NCRV, ACRV, CHAR; 00334600 -BEGIN LABEL LOOP; 00334700 - LABEL DIG, ALPH, BK1, BK2, SPEC; 00334800 - DI ~ ACRV; 00334900 - SI ~ CHAR; SI ~ SI+8; 00335000 - IF SC ! " " THEN 00335100 - IF SC } "0" THEN BEGIN SI ~ NCRV; GO TO BK1 END ELSE 00335200 - BEGIN SI ~ NCRV; GO TO BK2 END; 00335300 - SI ~ NCRV; 00335400 - LOOP: 00335500 - IF SC = " " THEN BEGIN SI~SI+1; GO TO LOOP END; 00335600 - IF SC } "0" THEN 00335700 - BEGIN 00335800 - DIG: DS ~ CHR; 00335900 - BK1: IF SC = " " THEN BEGIN SI ~ SI+1; GO TO BK1 END; 00336000 - IF SC } "0" THEN GO TO DIG; 00336100 - GO TO SPEC; 00336200 - END; 00336300 - IF SC = ALPHA THEN 00336400 - BEGIN 00336500 - ALPH: DS ~ CHR; 00336600 - BK2: IF SC = " " THEN BEGIN SI ~ SI+1; GO TO BK2 END; 00336700 - IF SC = ALPHA THEN GO TO ALPH; 00336800 - END; 00336900 - SPEC: 00337000 - ACRV ~ DI; 00337100 - DS ~ 6 LIT " "; 00337200 - IF SC = "]" THEN 00337300 - BEGIN TALLY ~ 1; SI ~ LOC ACRV; 00337400 - DI ~ ACR; DS ~ WDS; 00337500 - DI ~ CHAR; DS ~ LIT ";"; 00337600 - END ELSE 00337700 - BEGIN DI ~ CHAR; DS ~ CHR; 00337800 - ACRV ~ SI; SI ~ LOC ACRV; 00337900 - DI ~ NCR; DS ~ WDS; 00338000 - END; 00338100 - ADVANCE ~ TALLY; 00338200 -END ADVANCE; 00338300 -BOOLEAN PROCEDURE CONTINUE; 00338400 -BEGIN 00338500 -LABEL LOOP; 00338600 - 00338700 -BOOLEAN STREAM PROCEDURE CONTIN(CD); 00338800 -BEGIN SI~CD; IF SC!"C" THEN IF SC!"$" THEN BEGIN SI~SI+5; IF SC!" " 00338900 -THEN IF SC!"0" THEN BEGIN TALLY~1; CONTIN~TALLY END END END OF CONTIN ;00339000 -BOOLEAN STREAM PROCEDURE COMNT(CD,T); VALUE T; 00339100 -BEGIN LABEL L ; 00339200 - SI ~ CD; IF SC = "C" THEN BEGIN T(SI~SI+1; IF SC="-" THEN TALLY~1 00339300 - ELSE JUMP OUT TO L); TALLY~1; L: END; COMNT~TALLY ; 00339400 -END COMNT; 00339500 -BOOLEAN STREAM PROCEDURE DCCONTIN(CD); 00339600 -BEGIN 00339700 - SI ~ CD; IF SC = "-" THEN TALLY ~ 1; 00339800 - DCCONTIN ~ TALLY; 00339900 -END DCCONTIN; 00340000 -LOOP: IF NOT(CONTINUE ~ 00340100 - IF(DCINPUT AND NOT TSSEDITOG)OR FREEFTOG THEN 00340200 - IF NEXTCARD < 4 THEN DCCONTIN(CB) 00340300 - ELSE IF NEXTCARD = 7 THEN DCCONTIN(DB)ELSE CONTIN(TB) 00340400 - ELSE IF NEXTCARD = 7 THEN CONTIN(DB) 00340500 - ELSE IF NEXTCARD < 4 THEN CONTIN(DB) ELSE 00340600 - CONTIN(TB)) THEN 00340700 - IF(IF NEXTCARD < 4 THEN 00340800 - COMNT(CB,(DCINPUT AND NOT TSSEDITOG) OR FREEFTOG) 00340900 - ELSE IF NEXTCARD = 7 THEN 00341000 - COMNT(CB,(DCINPUT AND NOT TSSEDITOG) OR FREEFTOG) 00341100 - ELSE COMNT(TB,0) AND NEXTCARD ! 6) THEN 00341200 - BEGIN 00341300 - IF READACARD THEN IF LISTOG THEN PRINTCARD; 00341400 - GO TO LOOP; 00341500 - END; 00341600 -END CONTINUE; 00341700 - 00341800 -PROCEDURE SCANX(EOF1, EOF2, EOS1, EOS2, OK1, OK2); 00341900 - VALUE EOF1, EOF2, EOS1, EOS2, OK1, OK2; 00342000 - INTEGER EOF1, EOF2, EOS1, EOS2, OK1, OK2; 00342100 -BEGIN LABEL LOOP, LOOP0 ; 00342200 - LOOP0: 00342300 - EXACCUM[1] ~ BLANKS; 00342400 - ACR ~ ACR1; 00342500 - LOOP: 00342600 - IF ADVANCE(NCR, ACR, CHR1, NCR, ACR) THEN 00342700 - IF CONTINUE THEN 00342800 - IF READACARD THEN 00342900 - BEGIN 00343000 - IF LISTOG THEN PRINTCARD ; 00343100 - IF ACR.[33:15]}EXACCUMSTOP THEN 00343200 - BEGIN XTA~BLANKS; FLOG(175); GO LOOP0 END ; 00343300 - GO LOOP ; 00343400 - END 00343500 - ELSE SCN ~ IF EXACCUM[1] = BLANKS THEN EOF1 ELSE EOF2 00343600 - ELSE SCN ~ IF EXACCUM[1] = BLANKS THEN EOS1 ELSE EOS2 00343700 - ELSE SCN ~ IF EXACCUM[1] = BLANKS THEN OK1 ELSE OK2; 00343800 -END SCANX; 00343900 - 00344000 -DEFINE CHAR = ACCUM[0]#; 00344100 -DEFINE T=SYMBOL#; 00344200 -INTEGER N; 00344300 -BOOLEAN STREAM PROCEDURE CHECKEXP(NCR, NCRV, A); VALUE NCRV; 00344400 -BEGIN 00344500 - SI ~ NCRV; 00344600 - IF SC = "*" THEN 00344700 - BEGIN DI ~ A; DI ~ DI+2; DS ~ 2 LIT "*"; SI ~ SI+1; NCRV ~ SI; 00344800 - TALLY ~ 1; CHECKEXP ~ TALLY; 00344900 - SI ~ LOC NCRV; DI ~ NCR; DS ~ WDS END; 00345000 -END CHECKEXP; 00345100 -PROCEDURE CHECKRESERVED; 00345200 -BEGIN LABEL RESWD, XIT, FOUND1, FOUND2, DONE; 00345300 -BOOLEAN STREAM PROCEDURE COMPLETECHECK(A,B,N); VALUE N ; 00345400 - BEGIN LABEL L ; 00345500 - SI~A; SI~SI-2; DI~B; N(IF SC!DC THEN JUMP OUT TO L); TALLY~1; 00345600 - L: COMPLETECHECK~TALLY ; 00345700 - END OF COMPLETECHECK; 00345800 -STREAM PROCEDURE XFER(FROM, T1, T2, N, M); VALUE FROM, N, M; 00345900 -BEGIN SI ~ FROM; DI ~ T1; DI ~ DI+2; 00346000 - DS ~ M CHR; 00346100 - SI ~ FROM; SI ~ SI+N; 00346200 - DI ~ T2; DI ~ DI+2; 00346300 - DS ~ 6 CHR; 00346400 -END XFER; 00346500 -STREAM PROCEDURE XFERA(FROM, NEXT1, NEXT2); 00346600 - VALUE FROM; 00346700 -BEGIN SI ~ FROM; SI ~ SI+6; 00346800 - DI ~ NEXT1; DI ~ DI+2; 00346900 - 5(IF SC } "0" THEN DS ~ CHR ELSE JUMP OUT); 00347000 - SI ~ SI+2; 00347100 - DI ~ NEXT2; DI ~ DI+2; 00347200 - 6(IF SC = ALPHA THEN DS ~ CHR ELSE JUMP OUT); 00347300 -END XFERA; 00347400 -BOOLEAN STREAM PROCEDURE CHECKFUN(FROM, TOO, N); VALUE FROM, N; 00347500 -BEGIN SI ~ FROM; SI ~ SI +N; 00347600 - IF SC = "O" THEN 00347700 - BEGIN SI ~ SI+1; 00347800 - IF SC = "N" THEN 00347900 - BEGIN SI ~ SI+1; TALLY ~ 1; 00348000 - DI ~ TOO; DI ~ DI+2; 00348100 - DS ~ 6 CHR; 00348200 - END; 00348300 - END; 00348400 - CHECKFUN ~ TALLY; 00348500 -END CHECKFUN; 00348600 -BOOLEAN STREAM PROCEDURE MORETHAN6(P); 00348700 -BEGIN SI ~ P; 00348800 - IF SC ! " " THEN TALLY ~ 1; 00348900 - MORETHAN6 ~ TALLY; 00349000 -END MORETHAN6; 00349100 -INTEGER I; ALPHA ID; 00349200 -INTEGER STOR ; 00349300 - IF ACCUM[1] = " " THEN 00349400 - BEGIN XTA ~ CHAR; FLOG(16); GO TO XIT END; 00349500 - IF CHAR = "= " OR CHAR = "# " THEN GO TO XIT; 00349600 - IF CHAR = "~ " THEN GO TO XIT; 00349700 - IF CHAR ! "( " AND CHAR ! "% " THEN GO TO RESWD; 00349800 - IF MORETHAN6(ACCUM[2]) THEN GO TO RESWD; 00349900 - COMMENT AT THIS POINT WE HAVE ( . 00350000 - THIS MUST BE ONE OF THE FOLLOWING: 00350100 - ASSIGNEMNT STATEMENT WITH SUBSCRIPTED VARIABLE AT THE LEFT. 00350200 - STATEMENT FUNCTION DECLARATION. 00350300 -CALL, REAL, ENTRY, GO TO, READ, WRITE, FORMAT, IF, DATA, CHAIN, PRINT OR00350400 - PUNCH; 00350500 - IF I ~ SEARCH(T) > 0 THEN 00350600 - IF GET(I).CLASS = ARRAYID THEN GO TO XIT; 00350700 - ID ~ T; ID.[36:12] ~ " "; 00350800 - FOR I~0 THRU RSP DO IF RESERVEDWORDSLP[I]=ID THEN IF (IF STOR 00350900 - ~RESLENGTHLP[I]-4<1 THEN TRUE ELSE COMPLETECHECK(ACCUM[2], 00351000 - RESERVEDWORDSLP[I+RSP1],STOR)) THEN GO FOUND1 ; 00351100 - GO TO XIT; 00351200 - FOUND1: 00351300 - NEXT ~ LPGLOBAL[I]; 00351400 - T ~ " "; 00351500 - XFER(ACR0, T, NEXTACC, I~RESLENGTHLP[I], IF I> 6 THEN 6 ELSE I); 00351600 - GO TO DONE; 00351700 - RESWD: 00351800 - COMMENT AT THIS POINT WE KNOW THE MUST BE A SPECIAL WORD 00351900 - TO IDENTIFY THE STATEMENT TYPE; 00352000 - ID ~ T; ID.[36:12] ~ " "; 00352100 - IF T = "ASSIGN" THEN 00352200 - BEGIN 00352300 - NEXTSCN ~ SCN; SCN ~ 14; 00352400 - NEXTACC ~ NEXTACC2 ~ " "; 00352500 - XFERA(ACR0, NEXTACC, NEXTACC2); 00352600 - NEXT ~ 1; 00352700 - GO TO XIT; 00352800 - END; 00352900 - FOR I~1 THRU RSH DO IF RESERVEDWORDS[I]=ID THEN IF (IF STOR~ 00353000 - RESLENGTH[I]-4<1 THEN TRUE ELSE COMPLETECHECK(ACCUM[2],RESERVEDWORDS00353100 - [I+RSH1],IF STOR>8 THEN 8 ELSE STOR)) THEN GO FOUND2 ; 00353200 - XTA ~ T; FLOG(16); GO TO XIT; 00353300 - FOUND2: 00353400 - NEXT ~ I+1; 00353500 - T ~ " "; 00353600 - XFER(ACR0, T, NEXTACC, I~RESLENGTH [I], IF I> 6 THEN 6 ELSE I); 00353700 - DONE: NEXTSCN ~ SCN; 00353800 - SCN ~ 6; 00353900 - IF NEXTACC = "FUNCTI" THEN 00354000 - IF CHECKFUN(ACR0, NEXTACC, I+6) THEN SCN ~ 13; 00354100 - XIT: 00354200 - EOSTOG~FALSE; 00354300 -END CHECKRESERVED; 00354400 - 00354500 -BOOLEAN PROCEDURE CHECKOCTAL; 00354600 -BEGIN 00354700 - INTEGER S, T; LABEL XIT; 00354800 -INTEGER STREAM PROCEDURE COUNT(ACRV,T); VALUE ACRV,T ; 00354900 - BEGIN 00355000 - LOCAL A,B; SI~LOC T; SI~SI+7 ; 00355100 - IF SC="1" THEN BEGIN SI~ACRV;IF SC="O" THEN SI~SI+1 END ELSE SI~ACRV;00355200 - IF SC!" " THEN 00355300 - BEGIN A~SI; 00355400 - 17(IF SC>"7" THEN BEGIN TALLY~17; JUMP OUT END ELSE IF SC < "0" THEN00355500 - BEGIN IF SC!" " THEN TALLY~17; JUMP OUT END; SI~SI+1; 00355600 - TALLY~TALLY+1) ; 00355700 - B~TALLY; SI~LOC B; SI~SI+7 ; 00355800 - IF SC="+" THEN BEGIN SI~A; IF SC>"3" THEN TALLY~17 END; 00355900 - END ; 00356000 - COUNT~TALLY ; 00356100 - END OF COUNT ; 00356200 -ALPHA STREAM PROCEDURE CONV(ACRV, S, T); VALUE ACRV, S, T; 00356300 -BEGIN SI ~ ACRV; IF SC = "O" THEN SI ~ SI+1; 00356400 - DI ~ LOC CONV; SKIP S DB; 00356500 - T(SKIP 3 SB; 3(IF SB THEN DS ~ SET ELSE DS ~ RESET; SKIP 1 SB)); 00356600 -END CONV; 00356700 - IF T~COUNT(ACR0,1) = 0 THEN 00356800 - BEGIN S ~ 1; 00356900 - IF T ~ CHAR ! "+ " AND T ! "& " THEN 00357000 - IF T = "- " THEN S ~ -1 ELSE GO TO XIT; 00357100 - SCANX(4, 4, 3, 3, 10, 10); 00357200 - IF SCN ! 10 THEN GO TO XIT; 00357300 - IF T~COUNT(ACR1,2) = 0 OR T > 16 THEN GO TO XIT ; 00357400 - FNEXT ~ CONV(ACR1, (16-T)|3, T); 00357500 - IF S < 0 THEN FNEXT ~ -FNEXT; 00357600 - END ELSE IF T < 17 THEN FNEXT~CONV(ACR0,(16-T)|3,T) ELSE GO TO XIT ; 00357700 - CHECKOCTAL ~ TRUE; 00357800 - NEXT ~ NUM; 00357900 - NUMTYPE ~ REALTYPE; 00358000 - XIT: 00358100 -END CHECKOCTAL; 00358200 - 00358300 -PROCEDURE HOLLERITH; 00358400 -BEGIN 00358500 - REAL T, COL1, T2, ENDP; 00358600 - LABEL XIT; 00358700 - INTEGER STREAM PROCEDURE STRCNT(S,D,SZ); VALUE S,SZ; 00358800 - BEGIN 00358900 - SI ~ S; DI ~ D;DS ~ 8 LIT "00 "; DI ~ D; 00359000 - DI ~ D; DI ~ DI + 2; DS ~SZ CHR; STRCNT ~ SI; 00359100 - END STRCNT; 00359200 - INTEGER STREAM PROCEDURE RSTORE(S,D,SKP,SZ); 00359300 - VALUE S, SKP, SZ; 00359400 - BEGIN 00359500 - DI ~ D; 00359600 - SI ~ S; DI ~DI + SKP; DS ~ SZ CHR; RSTORE ~ SI; 00359700 - END RSTORE; 00359800 - F1 ~ FNEXT; 00359900 - NUMTYPE ~ STRINGTYPE; 00360000 - T ~ 0 & NCR[30:33:15] & NCR[45:30:3]; 00360100 - COL1 ~ 0 & INITIALNCR[30:33:15]; 00360200 - ENDP ~ COL1 + 72; 00360300 - STRINGSIZE ~ 0; 00360400 - WHILE F1 >0 DO 00360500 - BEGIN 00360600 - T2 ~ IF F1 > 6 THEN 6 ELSE F1; 00360700 - IF STRINGSIZE > MAXSTRING THEN 00360800 - BEGIN FLAG(120); STRINGSIZE ~ 0 END; 00360900 - IF T+T2> ENDP THEN IF DCINPUT OR FREEFTOG THEN 00361000 - BEGIN XTA~BLANKS; FLOG(150); GO TO XIT END 00361100 - ELSE BEGIN 00361200 - IF TSSEDITOG THEN IF NOT DCINPUT THEN TSSED(BLANKS,1) ; 00361300 - NCR ~ STRCNT(NCR, STRINGARRAY[STRINGSIZE], ENDP-T); 00361400 - IF NOT CONTINUE THEN 00361500 - BEGIN FLOG(43); GO TO XIT END; 00361600 - IF READACARD THEN; 00361700 - IF LISTOG THEN PRINTCARD; 00361800 - NCR ~ RSTORE(NCR,STRINGARRAY[STRINGSIZE],ENDP-T+2,T2-(ENDP-T)); 00361900 - STRINGSIZE ~ STRINGSIZE+1; 00362000 - F1 ~ F1 - T2; 00362100 - T ~ COL1 + 6 + T2 - (ENDP - T); 00362200 - END ELSE 00362300 - BEGIN 00362400 - NCR ~ STRCNT(NCR, STRINGARRAY[STRINGSIZE], T2); 00362500 - STRINGSIZE ~ STRINGSIZE +1; 00362600 - T ~ T +T2; 00362700 - F1 ~ F1 - T2; 00362800 - END; 00362900 - END; 00363000 - NUMTYPE ~ STRINGTYPE; 00363100 - SCN ~ 1; 00363200 - XIT: 00363300 -END HOLLERITH; 00363400 -PROCEDURE QUOTESTRING; 00363500 -BEGIN 00363600 - REAL C; 00363700 - LABEL XIT; 00363800 - ALPHA STREAM PROCEDURE STRINGWORD(S,D,SKP,SZ,C); 00363900 - VALUE S,SKP,SZ; 00364000 - BEGIN 00364100 - LABEL QT, XIT; 00364200 - DI ~ D; SI ~ S; 00364300 - DI ~ DI+SKP; DI ~ DI+2; 00364400 - TALLY ~ SKP; 00364500 - SZ( IF SC = """ THEN JUMP OUT TO QT; 00364600 - IF SC = ":" THEN JUMP OUT TO QT; 00364700 - IF SC = "@" THEN JUMP OUT TO QT; 00364800 - IF SC = "]" THEN JUMP OUT TO XIT; 00364900 - DS ~ CHR; TALLY ~ TALLY+1); 00365000 - GO TO XIT; 00365100 - QT: TALLY ~ TALLY+7; SI ~ SI+1; 00365200 - XIT: STRINGWORD ~ SI; S ~ TALLY; 00365300 - SI ~ LOC S; DI ~ C; DS ~ WDS; 00365400 - END STRINGWORD; 00365500 - STRINGSIZE ~ 0; 00365600 - DO 00365700 - BEGIN 00365800 - IF STRINGSIZE > MAXSTRING THEN 00365900 - BEGIN FLAG(120); STRINGSIZE ~ 0 END; 00366000 - STRINGARRAY[STRINGSIZE] ~ BLANKS; 00366100 - NCR ~ STRINGWORD(NCR, STRINGARRAY[STRINGSIZE], 0, 6, C); 00366200 - IF C<6 THEN IF DCINPUT OR FREEFTOG 00366300 - THEN BEGIN XTA~BLANKS; FLOG(150); GO TO XIT END 00366400 - ELSE BEGIN 00366500 - IF TSSEDITOG THEN IF NOT DCINPUT THEN TSSED(BLANKS,1) ; 00366600 - IF NOT CONTINUE THEN 00366700 - BEGIN FLOG(121); GO TO XIT END; 00366800 - IF READACARD THEN; 00366900 - IF LISTOG THEN PRINTCARD; 00367000 - NCR ~ STRINGWORD(NCR, STRINGARRAY[STRINGSIZE ],C,6-C,C); 00367100 - END; 00367200 - STRINGSIZE ~ STRINGSIZE + 1; 00367300 - END UNTIL C } 7; 00367400 - IF C = 7 THEN STRINGSIZE ~ STRINGSIZE-1; 00367500 - FNEXT ~ STRINGSIZE; 00367600 - NEXT ~ NUM; 00367700 - SYMBOL ~ NAME ~ STRINGARRAY[0]; 00367800 - NUMTYPE ~ STRINGTYPE; 00367900 - SCN ~ 1; 00368000 - XIT: 00368100 -END QUOTESTRING; 00368200 - 00368300 -PROCEDURE CHECKPERIOD; 00368400 -BEGIN 00368500 -LABEL FRACTION, XIT, EXPONENT, EXPONENTSIGN; 00368600 -LABEL NUMFINI, FPLP, CHKEXP; 00368700 -ALPHA S, T, I, TS; 00368800 - INTEGER C2; 00368900 -BOOLEAN CON; 00369000 - IF T ~ CHAR ! ". " THEN GO TO CHKEXP; 00369100 -SCANX(4, 9, 3, 8, 10, 11); 00369200 -IF T ~ EXACCUM[1] = " " THEN 00369300 - BEGIN IF NUMTYPE ! DOUBTYPE THEN NUMTYPE ~ REALTYPE; GO TO XIT END; 00369400 -IF T = "E " OR T = "D " THEN GO TO EXPONENTSIGN; 00369500 -IF T.[12:6] { 9 THEN GO TO FRACTION; 00369600 -IF T.[18:6] { 9 THEN 00369700 -BEGIN 00369800 - IF S ~ T.[12:6] ! "E" AND S ! "D" THEN 00369900 - BEGIN XTA ~ T; FLOG(63); GO TO XIT END; 00370000 - EXACCUM[1].[12:6] ~ 0; 00370100 - I ~ 1; GO TO EXPONENT; 00370200 -END; 00370300 -IF EXACCUM[0] ! ". " THEN GO TO XIT; 00370400 -FOR I ~ 0 STEP 1 UNTIL 10 DO 00370500 - IF T = PERIODWORD[I] THEN 00370600 - BEGIN EXACCUM[2] ~ I; SCN ~ 12; GO TO XIT END; 00370700 -GO TO XIT; 00370800 -FRACTION: NEXT ~ NUM; 00370900 -IF NUMTYPE !DOUBTYPE THEN NUMTYPE ~ REALTYPE; XTA ~ ACR1; 00371000 -FPLP: 00371100 -F1 ~ 0; 00371200 -XTA ~ CONVERT(F1,C1,XTA ,TS); 00371300 -C2 ~ C2 + C1; 00371400 -IF (F2 ~ FNEXT|TEN[C1]+F1) { MAX 00371500 - THEN FNEXT ~ F2 00371600 - ELSE BEGIN 00371700 - NUMTYPE ~ DOUBTYPE; 00371800 - CON ~ TRUE; 00371900 - DOUBLE(FNEXT,DBLOW,TEN[C1],TEN[69+C1],|, 00372000 - F1,0,+,~,FNEXT,DBLOW); 00372100 - END; 00372200 -IF TS { 9 THEN GO TO FPLP; 00372300 -F1 ~ 0; 00372400 -IF T ~ EXACCUM[0] ! "E " AND T ! "D " THEN 00372500 -BEGIN IF SCN = 8 THEN SCN ~ 3 ELSE SCN ~ 10; 00372600 - GO TO NUMFINI; 00372700 -END; 00372800 -CHKEXP: FNEXT ~ FNEXT | 1.0; 00372900 -F1 ~ 0; 00373000 -I ~ 1; 00373100 -SCANX(4, 4, 3, 3, 20, 10); 00373200 -IF SCN = 20 THEN 00373300 -EXPONENTSIGN: 00373400 -BEGIN IF S ~ EXACCUM[0] ! "+ " AND S ! "& " THEN 00373500 - IF S = "- " THEN I ~ -1 ELSE 00373600 - BEGIN XTA ~ S; FLOG(63); SCN ~ 10; GO TO XIT END; 00373700 - SCANX(4, 4, 3, 3, 10, 10); 00373800 - END; 00373900 - IF (S ~ EXACCUM[1]).[12:6] > 9 THEN 00374000 - BEGIN XTA ~ IF S ! BLANKS THEN S ELSE T; FLOG(63); GO TO XIT END; 00374100 - EXPONENT: 00374200 - IF NUMTYPE ! DOUBTYPE THEN NUMTYPE ~ REALTYPE; 00374300 -IF T.[12:6] = "D" THEN NUMTYPE ~ DOUBTYPE; 00374400 - IF SCN = 8 THEN SCN ~ 3 ELSE IF SCN = 11 THEN SCN ~ 10; 00374500 - XTA ~ ACR1; 00374600 - XTA ~ CONVERT(F1,C1,XTA ,TS); 00374700 - IF I < 0 THEN F1 ~ -F1; 00374800 - NUMFINI: 00374900 - C1 ~ F1 - C2; 00375000 - IF I ~ (ABS(C1+(FNEXT.[3:6]&FNEXT[1:2:1]))) > 63 OR((ABS(C1) = I OR 00375100 - FNEXT } 5) AND ABS(F1) } 69) 00375200 - THEN BEGIN XTA ~ T; FLOG(87); GO TO XIT; END; 00375300 - IF NUMTYPE ! DOUBTYPE THEN 00375400 - BEGIN 00375500 - IF C1} 0 THEN FNEXT ~ FNEXT | TEN[C1] 00375600 - ELSE FNEXT ~ FNEXT / TEN[-C1]; 00375700 - END ELSE 00375800 - BEGIN 00375900 - IF C1 } 0 00376000 - THEN DOUBLE(FNEXT,DBLOW,TEN[C1],TEN[69+C1],|,~,FNEXT,DBLOW) 00376100 - ELSE DOUBLE(FNEXT,DBLOW,TEN[-C1],TEN[69-C1],/,~,FNEXT,DBLOW); 00376200 - IF CON THEN IF DBLOW.[9:33] = MAX.[9:33] THEN 00376300 - IF FNEXT.[3:6] LSS 14 00376400 - THEN IF BOOLEAN(FNEXT.[2:1]) THEN 00376500 - BEGIN DBLOW ~ 0; FNEXT ~ FNEXT + 1&FNEXT[2:2:7]; END; 00376600 - END; 00376700 - XIT: 00376800 -END CHECKPERIOD; 00376900 - 00377000 -LABEL LOOP0, NUMBER ; 00377100 -LABEL L,XIT; 00377200 -LABEL L1,L2,L3,L4,L5,L6,L7,L8,L9,L10,L11,L12,L13,L14,L15,L16,L17, 00377300 - L18,L19,L20,L21,BK ; 00377400 -SWITCH CASEL~L1,L2,L3,L4,L5,L6,L7,L8,L9,L10,L11,L12,L13,L14,L15, 00377500 - L16,L17,L18,L19,L20,L21 ; 00377600 -LABEL LOOP, CASESTMT; %994-00377700 -LABEL CASE0,CASE1,CASE2,CASE3,CASE4,CASE5,CASE6,CASE7; %994-00377800 -LABEL CASE8,CASE9,CASE10,CASE11,CASE12,CASE13,CASE14; %994-00377900 -PREC~NEXT~FNEXT~REAL(SCANENTER~FALSE) ; 00378000 -CASESTMT: 00378100 -CASE SCN OF 00378200 -BEGIN 00378300 -CASE0: %994-00378400 -GO TO IF LABELR THEN CASE5 ELSE CASE1; 00378500 -CASE1: 00378600 -BEGIN 00378700 - LOOP0: 00378800 - ACR ~ ACR0; 00378900 - ACCUM[1] ~ BLANKS; 00379000 - LOOP: 00379100 - IF ADVANCE(NCR, ACR, CHR0, NCR, ACR) THEN 00379200 - IF CONTINUE THEN 00379300 - IF READACARD THEN 00379400 - BEGIN 00379500 - IF LISTOG THEN PRINTCARD ; 00379600 - IF ACR.[33:15]}ACCUMSTOP THEN 00379700 - BEGIN XTA~BLANKS; FLOG(175); GO LOOP0 END ; 00379800 - GO LOOP ; 00379900 - END 00380000 - ELSE IF T ~ ACCUM[1] = " " THEN GO TO CASE5 ELSE SCN ~ 4 00380100 - ELSE IF T ~ ACCUM[1] = " " THEN 00380200 - GO TO CASE3 ELSE SCN ~ 3 00380300 - ELSE IF T ~ ACCUM[1] = " " THEN GO TO CASE2 ELSE SCN ~ 2; 00380400 -END; 00380500 -CASE2: 00380600 -BEGIN T ~ CHAR; SCN ~ 1 END; 00380700 -CASE3: 00380800 -BEGIN T ~ "; "; NEXT ~ SEMI; SCN ~ 0; 00380900 - IF EOSTOG THEN IF LOGIFTOG THEN BEGIN LOGIFTOG ~ FALSE; XTA ~ T; 00381000 - FLAG(101); END; 00381100 - GO TO XIT; 00381200 -END; 00381300 -CASE4: %994-00381400 -BEGIN T ~ "; "; NEXT ~ SEMI; SCN ~ 5; GO TO XIT END; 00381500 -CASE5: 00381600 -BEGIN T ~ " "; NEXT ~ EOF; EOSTOG ~ FALSE; GO TO XIT END; 00381700 -CASE6: %994-00381800 -BEGIN T ~ ACCUM[1] ~ NEXTACC; SCN ~ NEXTSCN; 00381900 - IF T = " " THEN GO TO CASESTMT; 00382000 -END; 00382100 -CASE7: %994-00382200 -BEGIN EOSTOG ~ TRUE; 00382300 - IF LABELR THEN GO TO CASE5 ELSE GO TO CASE1; 00382400 -END; 00382500 -CASE8: %994-00382600 -BEGIN T ~ EXACCUM[1]; SCN ~ 3 END; 00382700 -CASE9: %994-00382800 -BEGIN T ~ EXACCUM[1]; SCN ~ 4 END; 00382900 -CASE10: %994-00383000 -BEGIN T ~ CHAR ~ EXACCUM[0]; SCN ~ 1 END; 00383100 -CASE11: %994-00383200 -BEGIN T ~ EXACCUM[1]; SCN ~ 10 END; 00383300 -CASE12: %994-00383400 -BEGIN T ~ EXACCUM[1]; SCN ~ 1; 00383500 - IF N ~ EXACCUM[2] { 1 THEN 00383600 - BEGIN NEXT ~ NUM; FNEXT ~ N; GO TO XIT END; 00383700 - NEXT ~ 0; 00383800 - OP ~ N-1; 00383900 - PREC ~ IF N { 4 THEN N-1 ELSE 4; 00384000 - GO TO XIT; 00384100 -END; 00384200 -CASE13: %994-00384300 -BEGIN T ~ "FUNCTI"; NEXT ~ 16; SCN ~ 6; GO TO XIT END; 00384400 -CASE14: %994-00384500 -BEGIN T ~ ACCUM[1] ~ NEXTACC; 00384600 - NEXTACC ~ NEXTACC2; SCN ~ 6; 00384700 -END; 00384800 -END OF CASE STATEMENT; 00384900 -IF NOT FILETOG THEN 00385000 - IF EOSTOG THEN 00385100 - BEGIN 00385200 - NEXT ~ 0; 00385300 - IF T = "; " THEN GO TO CASESTMT; 00385400 - CHECKRESERVED; 00385500 - IF NEXT > 0 THEN GO TO XIT; 00385600 - END; 00385700 -IF (IDINFO~TIPE[T.[12:6]])>0 THEN 00385800 - BEGIN 00385900 -BK: NEXT~ID ; 00386000 - IF NOT FILETOG THEN 00386100 - IF SCANENTER~((FNEXT~SEARCH(T))=0) THEN FNEXT~ENTER(IDINFO,T) 00386200 - ELSE IF GET(FNEXT).CLASS=DUMMY THEN FNEXT~GET(FNEXT+2).BASE ; 00386300 - GO XIT ; 00386400 - END ; 00386500 -GO CASEL[-IDINFO]; % SEE INITIALIZATION OF "TIP". LINE 03433100%993- 00386600 -L1: %DIGITS %993- 00386700 -BEGIN NUMTYPE ~ INTYPE; NEXT ~ NUM; XTA ~ ACR0; 00386800 - FNEXT ~ DBLOW ~ C1 ~ 0; 00386900 - XTA ~ CONVERT(FNEXT,C1,XTA ,TS); 00387000 - WHILE TS { 9 DO 00387100 - BEGIN 00387200 - XTA ~ CONVERT(F1,C1,XTA ,TS); 00387300 - IF (F2 ~ FNEXT|TEN[C1]+F1) { MAX 00387400 - THEN FNEXT ~ F2 00387500 - ELSE BEGIN 00387600 - NUMTYPE ~ DOUBTYPE; 00387700 - DOUBLE(FNEXT,DBLOW,TEN[C1],TEN[69+C1],|, 00387800 - F1,0,+,~,FNEXT,DBLOW); 00387900 - END; 00388000 - END; 00388100 - IF CHAR = ". " OR CHAR = "E " OR CHAR = "D " THEN 00388200 - CHECKPERIOD 00388300 - ELSE IF CHAR = "H " THEN HOLLERITH; 00388400 - GO TO XIT; 00388500 -END; 00388600 -L2: % > %993- 00388700 -BEGIN PREC ~ 4; OP ~ 7; GO TO XIT END; 00388800 -L3: % } %993- 00388900 -BEGIN PREC ~ 4; OP ~ 8; GO TO XIT END; 00389000 -L4: % & OR + %993- 00389100 -BEGIN PREC ~ 5; OP ~ 10; NEXT ~ PLUS; GO TO XIT END; 00389200 -L5: % . %993- 00389300 -BEGIN 00389400 - FNEXT ~ DBLOW ~ C1 ~ 0; NUMTYPE ~ REALTYPE; 00389500 - CHECKPERIOD; 00389600 - T ~ EXACCUM[1]; 00389700 - IF SCN = 12 THEN 00389800 - BEGIN SCN ~ 1; 00389900 - IF N ~ EXACCUM[2] { 1 THEN 00390000 - BEGIN 00390100 - NEXT ~ NUM; FNEXT ~ N; 00390200 - NUMTYPE ~ LOGTYPE; GO TO XIT; 00390300 - END; 00390400 - NEXT ~ 0; 00390500 - OP ~ N-1; 00390600 - PREC ~ IF N { 4 THEN N-1 ELSE 4; 00390700 - GO TO XIT; 00390800 -END; 00390900 - IF NEXT ! NUM THEN BEGIN NEXT ~ NUM; XTA ~ T; FLOG(141) END; 00391000 - GO TO XIT; 00391100 -END; 00391200 -L6: % % OR ( %993-00391300 -BEGIN NEXT ~ LPAREN; GO TO XIT END; 00391400 -L7: % < %993-00391500 -BEGIN PREC ~ OP ~ 4; GO TO XIT END; 00391600 -L8: % LETTER 0 %993-00391700 -BEGIN IF DATATOG THEN IF CHECKOCTAL THEN GO TO XIT; 00391800 - IDINFO~TIPE[12]; GO BK ; 00391900 -END; 00392000 -L9: % $ %993-00392100 -BEGIN NEXT ~ DOLLAR; GO TO XIT END; 00392200 -L10: % * %993-00392300 -IF CHECKEXP(NCR, NCR, T) THEN 00392400 -BEGIN PREC ~ 9; OP ~ 15; NEXT ~ UPARROW; GO TO XIT END ELSE 00392500 -L11: 00392600 -BEGIN PREC ~ 7; OP ~ 13; NEXT ~ STAR; GO TO XIT END; 00392700 -L12: % - %993-00392800 -BEGIN PREC ~ 5; OP ~ 11; NEXT ~ MINUS; GO TO XIT END; 00392900 -L13: % ) OR [ %993-00393000 -BEGIN NEXT ~ RPAREN; GO TO XIT END; 00393100 -L14: % ; %993-00393200 -BEGIN NEXT ~ SEMI; GO TO XIT END; 00393300 -L15: % { %993-00393400 -BEGIN PREC ~ 4; OP ~ 5; GO TO XIT END; 00393500 -L16: % / %993-00393600 -BEGIN PREC ~ 7; OP ~ 14; NEXT ~ SLASH; GO TO XIT END; 00393700 -L17: % , %993-00393800 -BEGIN NEXT ~ COMMA; GO TO XIT END; 00393900 -L18: % ! %993-00394000 -BEGIN PREC ~ 4; OP ~ 9; GO TO XIT END; 00394100 -L19: % = OR ~ OR # %993- 00394200 -BEGIN NEXT ~ EQUAL; GO TO XIT END; 00394300 -L20: % ] %993-00394400 -BEGIN XTA ~ T; FLAG(0); GO TO CASESTMT END; 00394500 -L21: % " OR : OR @ %993-00394600 -BEGIN QUOTESTRING; GO TO XIT END; 00394700 -XIT: 00394800 -IF DEBUGTOG THEN WRITALIST(FD,3,NEXT,T," ",0,0,0,0,0) ; 00394900 - XTA ~ NAME ~ T; 00395000 -END SCAN; 00395100 - 00395200 -PROCEDURE WRAPUP; 00395300 - COMMENT WRAPUP OF COMPILIATION; 00395400 - BEGIN 00395500 -ARRAY PRT[0:7,0:127], 00395600 - SEGDICT[0:7,0:127], 00395700 - SEG0[0:29]; 00395800 -ARRAY FILES[0:BIGGESTFILENB]; 00395900 -INTEGER THEBIGGEST; 00396000 -SAVE ARRAY FPB[0:1022]; % FILE PARAMETER BLOCK 00396100 -REAL FPS,FPE; % START AND END OF FPB 00396200 -REAL GSEG,PRI,FID,MFID,IDNM,FILTYP,FPBI; 00396300 -BOOLEAN ALF; 00396400 -REAL PRTADR, SEGMNT, LNK, TSEGSZ, T1, I, FPBSZ; 00396500 - DEFINE 00396600 - SPDEUN= FPBSZ#, 00396700 - ENDDEF=#; 00396800 -ARRAY INTLOC[0:150]; 00396900 -REAL J; 00397000 -FORMAT SEGUS(A6, " IS SEGMENT ", I4, 00397100 - ", PRT IS ", A4, "."); 00397200 -LIST SEGLS(IDNM,NXAVIL,T1); 00397300 -LABEL LA, ENDWRAPUP; 00397400 - LABEL QQQDISKDEFAULT; %503-00397500 - COMMENT FORMAT OF SEGMENT DICTIONARY -RUN TIME ; 00397600 -DEFINE SGTYPF= [1:2]#, %0 = PROGRAM SEGMENTS 00397700 - SGTYPC= 1:46:2#,%1 = MCP INTRINSIC 00397800 - %2 = DATA SEGMENT 00397900 - PRTLINKF= [8:10]#, % LINK TO FIRT PRT ENTRY 00398000 - PRTLINKC= 8:38:10#, 00398100 - SGLCF = [18:15]#, % SEGMENT SIZE 00398200 - SGLCC = 23:38:10#, 00398300 - DKADRF = [33:15]#, % RELATIVE DISK ADDRESS OF SEGMENT 00398400 - % OR MCP INTRINSIC NUMBER 00398500 - DKADRC = 33:13:15#; 00398600 - COMMENT FORMAT OF FIRST SEGMENT OF CODE FILE- RUN TIME; 00398700 -COMMENT SEGO[0:29] 00398800 - WORD CONTENTS 00398900 - 0 LOCATION OF SEGMENT DICTIONARY 00399000 - 1 SIZE OF SEGMENT DICTIONARY 00399100 - 2 LOCATION OF PRT 00399200 - 3 SIZE OF PRT 00399300 - 4 LOCATION OF FILE PARAMETER BLOCK 00399400 - 5 SIZE OF FILE PARAMETER BLOCK 00399500 - 6 STARTING SEGMENT NUMBER 00399600 - 7-[2:1] IND FORTRAN FAULT DEC 00399700 - 7-[18:15] NUMBER OF FILES 00399800 - 7-[33:15] CORE REQUIRED/64 00399900 - ; 00400000 - COMMENT FORMAT OF PRT; 00400100 - % FLGF = [0:4] = 1101 = SET BY STREAM 00400200 -DEFINE MODEF =[4:2]#, % 0 = THUNK 00400300 - MODEC=4:46:2#, % 1 = WORD MODE PROGRAM DESCRIPTOR 00400400 - % 2 = LABEL DESCRIPTOR 00400500 - % 3 = CHARACTER MODE PROGRAM DESCRIPTOR 00400600 - STOPF =[6:1]#, % STOPPER = 1 FOR LAST DESCRIPTOR IN 00400700 - STOPC=6:47:1#, % CHAIN OF SAME SEGMENT DESCRIPTORS 00400800 - LINKF =[7:11]#, % IF STOP = 0 THEN PRTLINK 00400900 - LINKC=7:37:11#, % ELSE LINK TO SEGDICT 00401000 - FFF =[18:15]#,% INDEX INTO SEGMENT DICTIONARY 00401100 - FFC =18:33:15#, 01401200 - SINX = [33:15]#;% RELATIVE ADDRESS INTO SEGMENT 00401300 -DEFINE PDR = [37:5]#, 00401400 - PDC = [42:6]#; 00401500 -REAL STREAM PROCEDURE MKABS(F); 00401600 - BEGIN 00401700 - SI ~ F; MKABS ~ SI; 00401800 - END MKABS; 00401900 -REAL STREAM PROCEDURE BUILDFPB(DEST,FILNUM,FILTYP,MFID,FID,IDSZ, 00402000 - IDNM,SPDEUN); 00402100 - VALUE DEST,IDSZ,SPDEUN; 00402200 - BEGIN 00402300 - DI ~ DEST; 00402400 - SI ~ FILNUM; SI ~ SI + 6; DS ~ 2 CHR; 00402500 - SI ~ FILTYP; SI ~ SI + 7; DS ~ CHR; 00402600 - SI ~ MFID; SI ~ SI + 1; DS ~ 7 CHR; 00402700 - SI ~ FID; SI ~ SI + 1; DS ~ 7 CHR; 00402800 - SI ~ LOC IDSZ; SI ~ SI + 1; DS ~ IDSZ CHR; 00402900 - SI~LOC SPDEUN;SI~SI+6;DS~2 CHR;% DISK SPEED & EU NUMBER+1 00403000 - BUILDFPB ~ DI; 00403100 - DS ~ 2 LIT "0"; 00403200 - END BUILDFPB; 00403300 -REAL STREAM PROCEDURE GITSZ(F); 00403400 - BEGIN 00403500 - SI ~ F; SI ~SI + 7; TALLY ~ 7; 00403600 - 3(IF SC ! " " THEN JUMP OUT; 00403700 - SI ~SI - 1; TALLY ~ TALLY + 63;); 00403800 - GITSZ ~ TALLY; 00403900 - END GITSZ; 00404000 -STREAM PROCEDURE MOVE(F,T,SZ); VALUE SZ; 00404100 - BEGIN 00404200 - SI ~ F; DI ~T; DS ~ SZ WDS; 00404300 - END MOVE; 00404400 -INTEGER PROCEDURE MOVEANDBLOCK(FROM,SIZE); VALUE SIZE; 00404500 - ARRAY FROM[0,0]; INTEGER SIZE; 00404600 - BEGIN 00404700 - REAL T,NSEGS,J,I; 00404800 - STREAM PROCEDURE M2(F,T); BEGIN SI~F; DI~T; DS ~ 2 WDS; END M2; 00404900 - NSEGS ~ (SIZE+29) DIV 30; 00405000 - IF DALOC DIV CHUNK < T ~ (DALOC + NSEGS) DIV CHUNK 00405100 - THEN DALOC ~ CHUNK | T; 00405200 - MOVEANDBLOCK ~ DALOC; 00405300 - DO BEGIN FOR J ~ 0 STEP 2 WHILE J < 30 AND I 0 THEN 00408700 - BEGIN T1 ~ GET(T ~ GLOBALSEARCH(".SUBAR")+2); 00408800 - PUT(T,T1~T1&SAVESUBS[TOSIZE]); 00408900 - END; 00409000 - T1~PRGDESCBLDR(1,23,0,NSEG~NXAVIL~NXAVIL+1) ; % BUILD TPAR 00409100 - FILL LSTT[*] WITH 21(0),8(" ") ; % R+23 00409200 - WRITEDATA(29,NXAVIL,LSTT) ; 00409300 - PDPRT[(PDINX-1).[37:5],(PDINX-1).[42:6]].[6:1]~1 ; % SAVE BIT 00409400 - T1 ~ PRGDESCBLDR(1,22,0,NSEG ~ NXAVIL ~ NXAVIL + 1); 00409500 - WRITEDATA (138,NXAVIL,TEN); % POWERS OF TEN TABLE 00409600 - IF LSTI > 0 THEN 00409700 - BEGIN 00409800 - WRITEDATA(LSTI, NXAVIL ~ NXAVIL+1, LSTP); 00409900 - LSTA ~ PRGDESCBLDR(1, LSTA, 0, NXAVIL); 00410000 - END; 00410100 - IF TWODPRTX ! 0 THEN 00410200 - BEGIN 00410300 - FILL LSTT[*] WITH 00410400 - OCT0000000421410010, 00410500 - OCT0301001301412025, 00410600 - OCT2021010442215055, 00410700 - OCT2245400320211025, 00410800 - OCT0106177404310415, 00410900 - OCT1025042112350000; 00411000 - T ~ PRGDESCBLDR(0, TWODPRTX, 0, NXAVIL ~ NXAVIL+1); 00411100 - WRITEDATA(-6, NXAVIL, LSTT); 00411200 - END; 00411300 - COMMENT DECLARE GLOBAL FILES AND ARRAYS; 00411400 - FPS ~ FPE ~ MKABS(FPB); 00411500 - SEGMENTSTART; 00411600 - F2TOG ~ TRUE; 00411700 - GSEG ~ NSEG; 00411800 - FPBI ~ 0; 00411900 - EMITL(0); EMITL(2); EMITO(SSF); 00412000 - EMITL(1); % SET BLOCK COUNTER TO 1 00412100 - EMITL(16); EMITO(STD); 00412200 - EMITL(0); EMITOPDCLIT(23); EMITO(DEL); 00412300 - EMITL(REAL(HOLTOG)); EMITPAIR(21,STD); 00412400 - I ~ GLOBALNEXTINFO; WHILE I < 4093 DO 00412500 - BEGIN 00412600 - I ~ I+3; 00412700 - GETALL(I,INFA,INFB,INFC); 00412800 - IF INFA.CLASS = FILEID THEN %SEE COMMENTS ON LINE 02118000 %992-00412900 - BEGIN 00413000 - FPBI ~ FPBI + 1; 00413100 - PRI ~ INFA .ADDR; 00413200 - IF (XTA ~ INFB ).[18:6] < 10 THEN 00413300 - BEGIN 00413400 - IF XTA ~ MAKEINT(XTA) > BIGGESTFILENB THEN FLAG(77) ELSE 00413500 - FILES[XTA] ~ PRI; 00413600 - IF XTA > THEBIGGEST THEN THEBIGGEST ~ XTA; 00413700 - END; 00413800 - EMITO(MKS); 00413900 - IF J ~ INFC .ADINFO ! 0 THEN % OPTION FILE 00414000 - BEGIN FILTYP ~ INFC .LINK; 00414100 - IDNM ~ " "&"FILE"[6:24:24]&INFB[30:18:18]; 00414200 - T1 ~ GITSZ(IDNM); 00414300 - FID ~ FILEINFO[2,J]; 00414400 - MFID ~ FILEINFO[1,J]; 00414500 - IF FILTYP}10 AND (T~FILEINFO[3,J].DKAREASZ)!0 THEN 00414600 - BEGIN %%% SET UP ; 00414700 - SPDEUN~FILEINFO[3,J].SENSPDEUNF; 00414800 - B~IF (B~((J~FILEINFO[0,J]).[18:12])/(IF A~J.[30:12]{0 THEN00414900 - 1 ELSE A)){0 THEN 1 ELSE B ; 00415000 - %%% B=ORIGINAL "BLOCKING" SIZE = # LOGRECS/PHYSREC. 00415100 - A~ENTIER(B|ENTIER(T/(20|B)+.999999999)+.5) ; 00415200 - %%% T="AREA" SIZE = # LOGRECS IN TOTAL FILE. 00415300 - %%% A=# LOGRECS PER ROW. 00415400 - B~ENTIER(T/A+.999999999) ; 00415500 - %%% B = # ROWS IN FILE. 00415600 - %%% EQUIVALENT ALGOL FILE DESCRIPTION = [B:A]. 00415700 - %%% THE ABOVE LOGIC YIELDS: SHORTEST ROW CONTAINING 00415800 - %%% AN INTEGER NUMBER OF PHYSICAL RECORDS AND WHICH 00415900 - %%% REQUIRES 20 OR FEWER ROWS FOR THE TOTAL AREA, T.00416000 - EMITNUM(B); EMITNUM(A) ; 00416100 - END ELSE 00416200 - BEGIN EMITL(0); EMITL(0); 00416300 - J ~ FILEINFO[0,J]; % THIS ONE HAS ALL THE GOODIES 00416400 - END; 00416500 - QQQDISKDEFAULT: %503-00416600 - ESTIMATE~ESTIMATE+(J.[42:6])|(IF A~J.[18:12]=0 THEN J.[30:12] 00416700 - ELSE A) ; 00416800 - EMITL(J.[4:2]); % LOCK 00416900 - EMITL(FPBI); % FILE PARAM INDEX 00417000 - EMITDESCLIT(PRI); % PRT OF FILE 00417100 - EMITL(J.[42:6]); % # BUFFERS 00417200 - EMITL(J.[3:1]); % RECORDING MODE 00417300 - EMITNUM(J.[30:12]) ; % RECORD SIZE 00417400 - EMITNUM(J.[18:12]) ; % BLOCK SIZE 00417500 - EMITNUM(J.[ 6:12]) ; % SAVE FACTOR 00417600 - END ELSE 00417700 - BEGIN 00417800 - ALF ~TRUE; 00417900 - IF(FILTYP~INFC.LINK=2 OR FILTYP=12) AND INFB.[18:6]{9 THEN 00418000 - IDNM ~ 0&"FILE"[6:24:24]&INFB[30:18:18] 00418100 - ELSE 00418200 - BEGIN 00418300 - ALF ~ FALSE; 00418400 - IF (IDNM ~ " "&INFB[6:18:30]) = "READR " THEN 00418500 - IDNM ~ "READER "; 00418600 - END; 00418700 -IF IDNM="READER " OR IDNM="FILE5 " THEN IDNM~"CARD " ELSE %503-00418800 -IF IDNM="FILE6 " THEN BEGIN IDNM~"PRINTER";FILTYP~18;END ELSE %503-00418900 - BEGIN %503-00419000 - EMITL(20); EMITL(600); FILTYP~12; %20 | 600 REC DISK %503-00419100 - J~0&2[42:42:6]&10[30:36:12]&300[18:36:12]; %503-00419200 - FID~IDNM; MFID~"FORTEMP"; T1~GITSZ(IDNM); %503-00419300 - GO TO QQQDISKDEFAULT; %503-00419400 - END; %503-00419500 - T1 ~ GITSZ(IDNM); 00419600 - FID ~ IDNM; 00419700 - MFID ~ 0; 00419800 - IF DCINPUT AND ALF THEN BEGIN 00419900 - EMITL(20); % DISK ROWS 00420000 - EMITL(100); % DISK RECORD PER ROW 00420100 - EMITL(2); % REWIND AND LOCK 00420200 - EMITL(FPBI); % FILE NUMBER 00420300 - EMITDESCLIT(PRI); % PRT OF FILE 00420400 - EMITL(2); % NUMBER OF BUFFERS 00420500 - EMITL(1); % RECORDING MODE 00420600 - EMITL(10); % RECORD SIZE 00420700 - EMITL(30); % BLOCK SIZE 00420800 - EMITL(1); % SAVE FACTOR 00420900 - END ELSE 00421000 - BEGIN 00421100 - EMITL(0); % DISK ROWS 00421200 - EMITL(0); % DISK RECORDS PER ROW 00421300 - EMITL(0); % REWIND & RELEASE 00421400 - EMITL(FPBI); % FILE NUMBER 00421500 - EMITDESCLIT(PRI); % PRT OF FILE 00421600 - EMITL(2); % 2 BUFFERS 00421700 - EMITL(REAL(ALF)); 00421800 - EMITL(IF FILTYP = 0 THEN 10 ELSE 17); 00421900 - EMITL(0); % 15 WORD BUFFERS 00422000 - EMITL(0); % SAVE FACTOR (SCRATCH BY DEFAULT) 00422100 - END; 00422200 - END; 00422300 - EMITL(11); % INPUT OR OUTPUT 00422400 - EMITL(8); % SWITCH CODE FOR BLOCK 00422500 - EMITOPDCLIT(5); % CALL BLOCK 00422600 - FPE~BUILDFPB(FPE,FPBI,FILTYP,MFID,FID,T1,IDNM,SPDEUN); 00422700 - IF PRTOG THEN WRITALIST(FILEF,3,IDNM.[6:6],IDNM,B2D(PRI), 00422800 - 0,0,0,0,0) ; 00422900 - END 00423000 - ELSE 00423100 - IF INFA.CLASS = BLOCKID THEN 00423200 - BEGIN 00423300 - IF PRTOG THEN WRITALIST(BLOKF,3,INFB,B2D(INFA.ADDR), 00423400 - INFC.SIZE,0,0,0,0,0) ; 00423500 - IF INFA < 0 THEN ARRAYDEC(I); 00423600 - END; 00423700 - IF (T1 ~ INFA .CLASS) } FUNID 00423800 - AND T1 { SUBRID THEN 00423900 - BEGIN 00424000 - PRI ~ 0; 00424100 - IF INFA .SEGNO = 0 THEN 00424200 - BEGIN 00424300 - A~0; B~NUMINTM1 ; 00424400 - WHILE A+1 < B DO 00424500 - BEGIN 00424600 - PRI ~ REAL(BOOLEAN(A+B) AND BOOLEAN(1022)); 00424700 - IF IDNM ~ INT[PRI] = INFB THEN GO TO FOUND; 00424800 - IF INFB < IDNM THEN B ~ PRI.[36:11] ELSE A ~ PRI.[36:11]; 00424900 - END; 00425000 - IF IDNM ~ INT[PRI~(A+B)|2-PRI] = INFB THEN GO TO FOUND; 00425100 - XTA ~ INFB; FLAG(30); 00425200 - GO TO LA; 00425300 - FOUND: 00425400 - IF (T1~INT[PRI+1].INTPARMS)!0 00425500 - AND INFC < 0 00425600 - THEN IF T1 ! INFC.NEXTRA THEN 00425700 - BEGIN XTA ~ INFB ; FLAG(28); END; 00425800 - IF (FID~INTLOC[MFID~INT[PRI+1].INTNUM])=0 THEN 00425900 - BEGIN 00426000 - PDPRT[PDIR,PDIC] ~ 00426100 - 0&1[STYPC] 00426200 - &(FID ~ INTLOC[MFID] ~ NXAVIL ~ NXAVIL + 1)[SGNOC] 00426300 - &1[SEGSZC]; 00426400 - PDINX ~ PDINX + 1; 00426500 - END; 00426600 - T1 ~ PRGDESCBLDR(1,INFA .ADDR,0,FID); 00426700 - IF PRTOG THEN WRITALIST(SEGUS,3,IDNM,FID,B2D(T1),0,0,0,0,0) ; 00426800 - IF INT[PRI+1] < 0 THEN 00426900 - BEGIN 00427000 - T1 ~ PRGDESCBLDR(1,INT[PRI+1].INTPRT,0,FID); 00427100 - INT[PRI+1] ~ ABS(INT[PRI + 1]); 00427200 - END; 00427300 - END 00427400 - ELSE IF PRTOG THEN WRITALIST(SEGUS,3,INFB, 00427500 - INFA.SEGNO,B2D(INFA.ADDR),0,0,0,0,0) ; 00427600 - END; 00427700 - LA: 00427800 - END; 00427900 -COMMENT MUST FOLLOW THE FOR STATEMENT; 00428000 -IF FILEARRAYPRT ! 0 THEN 00428100 -BEGIN % BUILDING OBJECT TIME FILE SEARCH ARRAY 00428200 - J ~ PRGDESCBLDR(1,FILEARRAYPRT,0,NXAVIL ~ NXAVIL + 1); 00428300 - WRITEDATA(THEBIGGEST + 1,NXAVIL,FILES); 00428400 -END; 00428500 - XTA ~ BLANKS; 00428600 - IF NXAVIL > 1023 THEN FLAG(45); 00428700 - IF PRTS > 1023 THEN FLAG(46); 00428800 - IF STRTSEG = 0 THEN FLAG(65); 00428900 - PRI ~ 0; 00429000 - WHILE (IDNM ~ INT[PRI]) ! 0 DO 00429100 - IF INT[PRI+1] } 0 THEN PRI ~ PRI + 2 ELSE 00429200 - BEGIN 00429300 - IF (FID~INTLOC[MFID~INT[PRI+1].INTNUM])=0 THEN 00429400 - BEGIN 00429500 - PDPRT[PDIR,PDIC] ~ 00429600 - 0&1[STYPC] 00429700 - &MFID[DKAC] 00429800 - &(FID ~ INTLOC[MFID] ~ NXAVIL ~ NXAVIL + 1)[SGNOC] 00429900 - &1[SEGSZC]; 00430000 - PDINX ~ PDINX + 1; 00430100 - END; 00430200 - T1 ~ PRGDESCBLDR(1,INT[PRI + 1].INTPRT,0,FID); 00430300 - PRI ~ PRI+2; 00430400 - END; 00430500 - FOR I ~ 1 STEP 1 UNTIL BDX DO 00430600 - BEGIN EMITO(MKS); EMITOPDCLIT(BDPRT[I]) END; 00430700 - EMITO(MKS); 00430800 - EMITOPDCLIT(STRTSEG.[18:15]); 00430900 - T ~ PRGDESCBLDR(1,0,0,NSEG); 00431000 - SEGMENT((ADR+4) DIV 4,NSEG,FALSE,EDOC); 00431100 - IF ERRORCT ! 0 THEN GO TO ENDWRAPUP; 00431200 - FILL SEG0[*] WITH 00431300 - OCT020005, % BLOCK 00431400 - OCT220014, % WRITE 00431500 - OCT230015, % READ 00431600 - OCT240016; % FILE CONTROL 00431700 - COMMENT INTRINSIC FUNCTIONS; 00431800 - FOR I ~ 0 STEP 1 UNTIL 3 DO 00431900 - BEGIN 00432000 - T1 ~ PRGDESCBLDR(1,SEG0[I].[36:12],0, 00432100 - NSEG ~ NXAVIL ~ NXAVIL + 1); 00432200 - PDPRT[PDIR,PDIC] ~ 00432300 - 0&1[STYPC] 00432400 - &(SEG0[I].[30:6])[DKAC] 00432500 - &NXAVIL[SGNOC] 00432600 - &1[SEGSZC]; 00432700 - PDINX ~ PDINX + 1; 00432800 - END; 00432900 - COMMENT GENERATE PRT AND SEGMENT DICTIONARY; 00433000 - PRT[0,41] ~ PDPRT[0,0] & 63[10:42:6]; % USED FOR FAULT OPTN 00433100 - FOR I ~ 1 STEP 1 UNTIL PDINX-1 DO 00433200 - IF (T1~PDPRT[I.PDR,I.PDC]).SEGSZF = 0 THEN 00433300 - BEGIN % PRT ENTRY 00433400 - PRTADR ~T1.PRTAF; 00433500 - SEGMNT ~T1.SGNOF; 00433600 - LNK ~ SEGDICT[SEGMNT.[36:5], SEGMNT.[41:7]].PRTAF; 00433700 - MDESC(T1.RELADF&SEGMNT[FFC] 00433800 - &(REAL(LNK=0))[STOPC] 00433900 - &(IF LNK=0 THEN SEGMNT ELSE LNK)[LINKC] 00434000 - &(T1.DTYPF)[MODEC] 00434100 - &5[1:45:3], 00434200 - PRT[PRTADR.[36:5],PRTADR.[41:7]]); 00434300 - SEGDICT[SEGMNT.[36:5],SEGMNT.[41:7]].PRTLINKF ~ PRTADR; 00434400 - END 00434500 - ELSE 00434600 - BEGIN % SEGMENT DICTIONARY ENTRY 00434700 - SEGMNT ~ T1.SGNOF; 00434800 - SEGDICT[SEGMNT.[36:5],SEGMNT.[41:7]]~ 00434900 - SEGDICT[SEGMNT.[36:5],SEGMNT.[41:7]] 00435000 - &T1[SGLCC] 00435100 - &T1[DKADRC] 00435200 - & T1[4:12:1] 00435300 - &T1[6:6:1] 00435400 - &T1[1:1:2]; 00435500 - TSEGSZ ~ TSEGSZ + T1.SEGSZF; 00435600 - END; 00435700 - COMMENT WRITE OUT FILE PARAMETER BLOCK; 00435800 - FPBSZ ~ ((FPE.[33:15] - FPS) | 8 + FPE.[30:3] + 9) DIV 8; 00435900 - I ~ (FPBSZ + 29) DIV 30; 00436000 - IF DALOC DIV CHUNK < T1 ~ (DALOC +I) DIV CHUNK 00436100 - THEN DALOC ~ CHUNK | T1; 00436200 - SEG0[4] ~ DALOC; 00436300 - SEG0[5] ~ FPBSZ; 00436400 - SEG0[5].FPBVERSF~FPBVERSION; 00436500 - FOR I ~ 0 STEP 30 WHILE I < FPBSZ DO 00436600 - BEGIN 00436700 - MOVE(FPB[I],CODE(0),IF (FPBSZ-I) } 30 00436800 - THEN 30 ELSE (FPBSZ-I)); 00436900 - WRITE(CODE[DALOC]); 00437000 - DALOC ~ DALOC + 1; 00437100 - END; 00437200 - SEG0[2] ~ MOVEANDBLOCK(PRT,PRTS+1); % WRITES OUT PRT 00437300 - % SAVES ADDRESS OF PRT 00437400 - SEG0[3] ~ PRTS + 1; % SIZE OF PRT 00437500 - SEG0[0] ~ MOVEANDBLOCK(SEGDICT,NXAVIL + 1); % WRITE SEG DICT 00437600 - SEG0[1] ~ NXAVIL + 1; % SIZE OF SEGMENT DICTIONARY 00437700 - SEG0[6] ~ -GSEG; % FIRST SEGMENT TO EXECUTE 00437800 - SEG0[7].[33:15] ~ FPBI; % NUMBER OF FILES 00437900 - SEG0[7].[18:15] ~ ESTIMATE ~ IF % CORE ESTIMATE 00438000 - ( I ~ 00438100 - ESTIMATE+60+ %%% OPTION FILE BUFF SIZES + DEFAULT BUFF SIZES.00438200 - PRTS + 512 % PRT AND STACK SIZE 00438300 - +TSEGSZ % TOTAL SIZE OF CODE 00438400 - + 1022 % FOR INTRINSICS 00438500 - +ARYSZ % TOTAL ARRAY SIZE 00438600 - + (MAXFILES | 28) % SIZE OF ALL FIBS 00438700 - +FPBSZ % SIZE OF FILE PARAMETER BLOCK 00438800 - + (IF ESTIMATE = 0 THEN 0 ELSE (ESTIMATE + 1000)) 00438900 - + (NXAVIL + 1) % SIZE OF SEGMENT DICTIONARY 00439000 - ) > 32768 THEN 510 ELSE (I DIV 64); 00439100 - COMMENT IF SEGSW THEN UPDATE LINDICT, SEG0[0] & WRITE IT ; 00439200 - SEG0[7].[2:1] ~ 1; % USED FOR FORTRAN FAULT DEC; 00439300 - IF SEGSW THEN 00439400 - BEGIN 00439500 - FOR I ~ NXAVIL + 1 STEP -1 UNTIL 1 DO 00439600 - IF LINEDICT[I.IR,I.IC] = 0 THEN % INDICATE NO LINE SEGMENT 00439700 - LINEDICT[I.IR,I.IC] ~ -1; % FOR THIS SEGMENT 00439800 - SEG0[0] ~ SEG0[0] & (MOVEANDBLOCK(LINEDICT,NXAVIL+1))[TOBASE]; 00439900 - END; 00440000 - WRITE(CODE[0],30,SEG0[*]); 00440100 - IF ERRORCT = 0 AND SAVETIME } 0 THEN LOCK(CODE); 00440200 - ENDWRAPUP: 00440300 - LOCK(TAPE); %RW/L TAPE FILE OR LOCK DISK %502-00440400 - IF NTAPTOG THEN LOCK(NEWTAPE,*); %RW/L TAPE OR CRUNCH DISK%502-00440500 - END WRAPUP; 00440600 -PROCEDURE INITIALIZATION; 00440700 -BEGIN COMMENT INITIALIZATION; 00440800 -ALPHA STREAM PROCEDURE MKABS(P); 00440900 -BEGIN SI ~ P; MKABS ~ SI END; 00441000 -STREAM PROCEDURE BLANKOUT(CRD, N); VALUE N; 00441100 -BEGIN DI ~ CRD; N(DS ~ LIT " ") END; 00441200 -BLANKOUT(CRD[10], 40); 00441300 -BLANKOUT(LASTSEQ, 8); 00441400 -BLANKOUT(LASTERR, 8); 00441500 -INITIALNCR ~ MKABS(CRD[0])&6[30:45:3]; 00441600 -CHR0 ~ MKABS(ACCUM[0])& 2[30:45:3]; 00441700 -ACR0 ~ CHR0+1; 00441800 -ACR1 ~ (CHR1~MKABS(EXACCUM[0]) & 2[30:45:3]) +1; 00441900 -ACCUMSTOP~MKABS(ACCUM[11]); EXACCUMSTOP~MKABS(EXACCUM[11]) ; 00442000 -BUFL ~ MKABS(BUFF) & 2[30:45:3]; 00442100 -NEXTCARD ~ 1; 00442200 -GLOBALNEXTINFO ~ 4093; 00442300 -PDINX ~ 1; 00442400 -LASTNEXT~1000 ; 00442500 -PRTS ~ 41; % CURRENTLY . . . . . LAST USED PRT 00442600 -READ(CR, 10, CB[*]); 00442700 -LISTOG~TRUE; SINGLETOG~TRUE; CHECKTOG ~ FALSE; %DEFAULT %501- 00442800 -FIRSTCALL ~ TRUE; 00442900 -IF BOOLEAN(ERRORCT.[46:1]) THEN LISTOG ~ FALSE; 00443000 -IF BOOLEAN(ERRORCT.[47:1]) THEN DCINPUT ~ TRUE; 00443100 -ERRORCT ~ 0; 00443200 -IF DCINPUT THEN SEGSW ~ TRUE; 00443300 -IF DCINPUT THEN REMOTETOG ~ TRUE; 00443400 -LIMIT~IF DCINPUT THEN 20 ELSE 100 ; 00443500 -IF SEGSW THEN SEGSWFIXED ~ TRUE; 00443600 -EXTRAINFO[0,0] ~ 0 & EXPCLASS[TOCLASS]; 00443700 -NEXTEXTRA ~ 1; 00443800 -LASTMODE ~ 1; 00443900 -DALOC ~ 1; 00444000 -TYPE ~ -1; 00444100 - MAP[0] ~ MAP[2] ~ MAP[4] ~ MAP[7] ~ -10; 00444200 - MAP[5] ~ 1; MAP[6] ~ 2; 00444300 -FILL XR[*] WITH 0,0,0,0,0,0,0, 00444400 - "INTEGE","R R"," "," "," REAL "," ", 00444500 - "LOGICA","L L","DOUBLE"," ","COMPLE","X X", 00444600 - "------","- -"," "," "," ---- "," ", 00444700 - "------","- -","------"," ","------","- -"; 00444800 -FILL TYPES[*] WITH " ","INTGER"," ","REAL ", 00444900 - "LOGCAL", "DOUBLE", "COMPLX"; 00445000 -FILL KLASS[*] WITH 00445100 - "NULL ", "ARRAY ", "VARBLE", "STFUN ", 00445200 - "NAMLST", "FORMAT", "ERROR ", "FUNCTN", 00445300 - "INTRSC", "EXTRNL", "SUBRTN", "COMBLK", 00445400 - "FILE "; 00445500 -FILL RESERVEDWORDSLP[*] WITH 00445600 - "CALL ","ENTR ","FORM ","GOTO ","IF ","READ ", 00445700 - "REAL ","WRIT ","DATA ","CLOS ","LOCK ","PURG ","CHAI ", 00445800 - "PRIN ","PUNC ", 00445900 - 0,"Y ","AT ",0,0,0,0,"E ",0,"E ",0,"E ",00446000 - "N ","T ","H "; 00446100 -FILL RESERVEDWORDS[*] WITH 00446200 - "ASSI ","BACK ","BLOC ","CALL ","COMM ","COMP ","CONT ", 00446300 - "DATA ","DIME ","DOUB ","END ","ENDF ","ENTR ","EQUI ", 00446400 - "EXTE ","FUNC ","GOTO ","INTE ","LOGI ","NAME ","PAUS ", 00446500 - "PRIN ","PROG ","PUNC ","READ ","REAL ","RETU ","REWI ", 00446600 - "STOP ","SUBR ","WRIT ", 00446700 - "CLOS ","LOCK ","PURG ", 00446800 - 0,0,0, 00446900 - "FIXF ","VARY ","AUXM ","RELE ", 00447000 - "IMPL ", 00447100 - "GN ","SPACE ","KDATA ",0,"ON ","LEX ","INUE ", 00447200 - 0,"NSION ","LEPRECIS",0,"ILE ","Y ","VALENCE ","RNAL " 00447300 - ,"TION ",0,"GER ","CAL ","LIST ","E ","T ",00447400 - "RAM ","H ",0,0,"RN ","ND ",0,"OUTINE ", 00447500 - "E ","E ",0,"E ",0,0,0,"D ","ING ", 00447600 - "EM ","ASE " 00447700 - ,"ICIT " 00447800 - ; 00447900 -FILL RESLENGTHLP[*] WITH 00448000 - 4,5,6,4,2,4,4,5,4,5,4,5,5,5,5; 00448100 -FILL LPGLOBAL[*] WITH 00448200 - 4, 13, 36, 17, 35, 25, 00448300 - 26, 31, 8, 32, 33, 34, 37, 22, 24; 00448400 -FILL RESLENGTH[*] WITH 00448500 - 0, 9, 9, 4, 6, 00448600 - 7, 8, 4, 9, 15, 00448700 - 3, 7, 5, 11, 8, 00448800 - 8, 4, 7, 7, 8, 00448900 - 5, 5, 7, 5, 4, 00449000 - 4, 6, 6, 4, 10, 5, 00449100 - 5, 4, 5, 0, 0, 0, 5, 7, 6, 7 00449200 - ,8 00449300 - ; 00449400 - FILL WOP[*] WITH 00449500 - "LITC"," ", 00449600 - "OPDC","DESC", 00449700 - 10,"DEL ", 11,"NOP ", 12,"XRT ", 16,"ADD ", 17,"AD2 ", 18,"PRL ", 00449800 - 19,"LNG ", 21,"GEQ ", 22,"BBC ", 24,"INX ", 35,"LOR ", 37,"GTR ", 00449900 - 38,"BFC ", 39,"RTN ", 40,"COC ", 48,"SUB ", 49,"SB2 ", 64,"MUL ", 00450000 - 65,"ML2 ", 67,"LND ", 68,"STD ", 69,"NEQ ", 70,"SSN ", 71,"XIT ", 00450100 - 72,"MKS ", 00450200 - 128,"DIV ",129,"DV2 ",130,"COM ",131,"LQV ",132,"SND ",133,"XCH ", 00450300 - 134,"CHS ",167,"RTS ",168,"CDC ",197,"FTC ",260,"LOD ",261,"DUP ", 00450400 - 278,"GBC ",280,"SSF ",294,"GFC ",322,"ZP1 ",384,"IDV ",453,"FTF ", 00450500 - 515,"MDS ",532,"ISD ",533,"LEQ ",534,"BBW ",548,"ISN ",549,"LSS ", 00450600 - 550,"BFW ",581,"EQL ",582,"SSP ",584,"ECM ",709,"CTC ",790,"GBW ", 00450700 - 806,"GFW ",896,"RDV ",965,"CTF ", 00450800 - 1023,1023,1023,1023,1023,1023,1023,1023,1023,1023,1023, 1023; 00450900 -FILL TIPE[*] WITH 10(-1),-19,-21,OCT300000000,-21,-2,-3,-4, 00451000 - 8(OCT300000000),OCT100000000,-5,-13,-4,-6,-7,-19,-11, 00451100 - 5(OCT100000000),-8,3(OCT300000000),-9,-10,-12,-13,-14,00451200 - -15,-100,-16,8(OCT300000000),-17,-6,-18,-19,-20,-21 ; 00451300 -FILL PERIODWORD[*] WITH 00451400 - "FALSE ", "TRUE ", "OR ", "AND ", "NOT ", 00451500 - "LT ", "LE ", "EQ ", "GT ", "GE ", "NE "; 00451600 -ACCUM[0] ~ EXACCUM[0] ~ "; "; 00451700 -INCLUDE ~ "NCLUDE" & "I"[6:42:6]; 00451800 -INSERTDEPTH ~ -1; 00451900 -FILL TEN[*] WITH % POWERS OF TEN TO PRT 22 00452000 - OCT1141000000000000, OCT1131200000000000, OCT1121440000000000,00452100 - OCT1111750000000000, OCT1102342000000000, OCT1073032400000000,00452200 - OCT1063641100000000, OCT1054611320000000, OCT1045753604000000,00452300 - OCT1037346545000000, OCT1011124027620000, OCT0001351035564000,00452400 - OCT0011643245121000, OCT0022214116345200, OCT0032657142036440,00452500 - OCT0043432772446150, OCT0054341571157602, OCT0065432127413542,00452600 - OCT0076740555316473, OCT0111053071060221, OCT0121265707274265,00452700 - OCT0131543271153342, OCT0142074147406233, OCT0152513201307702,00452800 - OCT0163236041571663, OCT0174105452130240, OCT0205126764556310,00452900 - OCT0216354561711772, OCT0231004771627437, OCT0241206170175346,00453000 - OCT0251447626234640, OCT0261761573704010, OCT0272356132665012,00453100 - OCT0303051561442215, OCT0313664115752660, OCT0324641141345435,00453200 - OCT0336011371636744, OCT0347413670206535, OCT0361131664625026,00453300 - OCT0371360241772234, OCT0401654312370703, OCT0412227375067064,00453400 - OCT0422675274304701, OCT0433454553366061, OCT0444367706263475,00453500 - OCT0455465667740415, OCT0467003245730520, OCT0501060411731664,00453600 - OCT0511274514320241, OCT0521553637404312, OCT0532106607305374,00453700 - OCT0542530351166673, OCT0553256443424452, OCT0564132154331565,00453800 - OCT0575160607420123, OCT0606414751324147, OCT0621012014361120,00453900 - OCT0631214417455344, OCT0641457523370635, OCT0651773450267004,00454000 - OCT0662372362344605, OCT0673071057035747, OCT0703707272645341,00454100 - OCT0714671151416631, OCT0726047403722377, OCT0737461304707077,00454200 - OCT0751137556607071, OCT0761367512350710, OCT0771665435043072,00454300 - OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,00454400 - OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,00454500 - OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,00454600 - OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,00454700 - OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,00454800 - OCT0000000000000000, OCT0000000000000000, OCT0004000000000000,00454900 - OCT0001000000000000, OCT0001720000000000, OCT0004304000000000,00455000 - OCT0007365000000000, OCT0005262200000000, OCT0004536640000000,00455100 - OCT0001666410000000, OCT0000244112000000, OCT0000315134400000,00455200 - OCT0000400363500000, OCT0000450046042000, OCT0006562057452400,00455300 - OCT0004316473365100, OCT0005402212262320, OCT0006702654737004,00455400 - OCT0004463430126605, OCT0007600336154346, OCT0001540425607437,00455500 - OCT0004070533151347, OCT0005106662003641, OCT0005033043640461,00455600 - OCT0002241654610575, OCT0002712227752734, OCT0001474675745524,00455700 - OCT0002014055337051, OCT0004417070626663, OCT0007522706774440,01455800 - OCT0003447470573550, OCT0006361406732502, OCT0005005571052122,00455900 - OCT0006207127264547, OCT0001650755141700, OCT0006223150372260,00456000 - OCT0007670002470733, OCT0007646003207120, OCT0005617404050743,00456100 - OCT0001163305063137, OCT0007420166277771, OCT0001732422375777,00456200 - OCT0002321127075377, OCT0003005354714677, OCT0005606650100057,00456300 - OCT0007150422120072, OCT0003002526544103, OCT0001603254275130,00456400 - OCT0004144127354356, OCT0007175155247451, OCT0007034410521363,00456500 - OCT0007664351264566, OCT0003641443541723, OCT0004611754472310;00456600 -FILL INLINEINT[*] WITH % FILLS MUST BE IN ASCENDING ORDER FOR 00456700 - % BINARY SEARCH IN FUNCTION AND DOITINLINE. 00456800 - % INLINEINT[I].[1:1] = 1 ONCE CODE FOR INTRINSIC 00456900 - % HAS BEEN EMITTED INLINE.00457000 - % INLINEINT[I].[2:10]=INDEX INTO 2-ND WORD OF THE00457100 - % CORR ENTRY IN INT. 00457200 - % INLINEINT[I].[12:36]=NAME OF INTRINSIC. 00457300 -%********FIRST FILL MUST BE NUMBER OF INTRINSICS ****************** 00457400 -34, 00457500 -"00ABS ", 00457600 -"00AIMAG ", 00457700 -"00AINT ", 00457800 -"00AMAX0 ", 00457900 -"00AMAX1 ", 00458000 -"00AMIN0 ", 00458100 -"00AMIN1 ", 00458200 -"00AMOD ", 00458300 -"00AND ", 00458400 -"00CMPLX ", 00458500 -"00COMPL ", 00458600 -"00CONJG ", 00458700 -"00DABS ", 00458800 -"00DBLE ", 00458900 -"00DIM ", 00459000 -"00DSIGN ", 00459100 -"00EQUIV ", 00459200 -"00FLOAT ", 00459300 -"00IABS ", 00459400 -"00IDIM ", 00459500 -"00IDINT ", 00459600 -"00IFIX ", 00459700 -"00INT ", 00459800 -"00ISIGN ", 00459900 -"00MAX0 ", 00460000 -"00MAX1 ", 00460100 -"00MIN0 ", 00460200 -"00MIN1 ", 00460300 -"00MOD ", 00460400 -"00OR ", 00460500 -"00REAL ", 00460600 -"00SIGN ", 00460700 -"00SNGL ", 00460800 -"00TIME ", 00460900 - 0 ; 00461000 - FILL INT [*] WITH 00461100 -COMMENT THESE NAMES (1-ST WORD OF EACH TWO-WORD ENTRY) MUST BE IN 00461200 - ASCENDING ORDER FOR BINARY LOOKUPS. 00461300 - THE SECOND WORD HAS THE FOLLOWING FORMAT: 00461400 - .[1:1] = 0 IF THE INTRINSIC DOES NOT HAVE A PERMANENT PRT 00461500 - LOCATION, OTHERWISE = 1. MAY BE RESET BY 00461600 - WRAPUP. SEE .[18:6] BELOW. 00461700 - .[2:1] = .INTSEEN = 1 IFF INTRINSICS FUNCTION HAS BEEN SEEN. 00461800 - .[6:3] = .INTCLASS = CLASS OF THE INTRINSIC. 00461900 - .[9:3] = .INTPARMCLASS = CLASS OF PARAMETERS. 00462000 - .[12:6] = .INTINLINE = INDEX FOR DOITINLINE IF !0, OTHERWISE 00462100 - DO IT VIA INTRINSIC CALL. 00462200 - .[24:6] = .INTPRT = FIXED PRT LOCATION. SEE .[1:1] ABOVE. 00462300 - .[30:6] = .INTPARMS = NUMBER OF PARAMETERS REQUIRED BY THE INT.00462400 - .[36:12] = .INTNUM = INTRINSICS NUMBER. 00462500 - THE FIELDS .[3:3] AND .[18:6] ARE SO FAR UNUSED. 00462600 -; 00462700 -% 00462800 -%***********************************************************************00462900 -%********* IF YOU ADD AN INTRINSIC, BE SURE TO CHANGE NUMINTM1 *******00463000 -%********* AT SEQUENCE NUMBER 00155211.......THANK YOU. *******00463100 -%***********************************************************************00463200 -% 00463300 -"ABS ", OCT0033010000010007, 00463400 -"AIMAG ", OCT0036020000010074, 00463500 -"AINT ", OCT0033030000010054, 00463600 -"ALGAMA", OCT0033000000010127, 00463700 -"ALOG10", OCT0033000000010103, 00463800 -"ALOG ", OCT2033000035010017, 00463900 -"AMAX0 ", OCT0031250000000031, 00464000 -"AMAX1 ", OCT0033250000000031, 00464100 -"AMIN0 ", OCT0031250000000032, 00464200 -"AMIN1 ", OCT0033250000000032, 00464300 -"AMOD ", OCT0033040000020063, 00464400 -"AND ", OCT0033050000020130, 00464500 -"ARCOS ", OCT0033000000010117, 00464600 -"ARSIN ", OCT2033000032010116, 00464700 -"ATAN2 ", OCT2033000044020114, 00464800 -"ATAN ", OCT2033000037010016, 00464900 -"CABS ", OCT2036000045010053, 00465000 -"CCOS ", OCT0066000000010110, 00465100 -"CEXP ", OCT0066000000010100, 00465200 -"CLOG ", OCT0066000000010102, 00465300 -"CMPLX ", OCT0063060000020075, 00465400 -"COMPL ", OCT0033070000010132, 00465500 -"CONCAT", OCT0033000000050140, 00465600 -"CONJG ", OCT0066110000010076, 00465700 -"COSH ", OCT0033000000010121, 00465800 -"COS ", OCT0033000000010015, 00465900 -"COTAN ", OCT0033000000010112, 00466000 -"CSIN ", OCT0066000000010106, 00466100 -"CSQRT ", OCT0066000000010124, 00466200 -"DABS ", OCT0055010000010052, 00466300 -"DATAN2", OCT0055000000020115, 00466400 -"DATAN ", OCT2055000041010113, 00466500 -"DBLE ", OCT0053120000010062, 00466600 -"DCOS ", OCT0055000000010107, 00466700 -"DEXP ", OCT2055000047010077, 00466800 -"DIM ", OCT0033100000020072, 00466900 -"DLOG10", OCT0055000000010104, 00467000 -"DLOG ", OCT2055000042010101, 00467100 -"DMAX1 ", OCT0055000000000066, 00467200 -"DMIN1 ", OCT0055000000000067, 00467300 -"DMOD ", OCT2055000046020065, 00467400 -"DSIGN ", OCT0055130000020071, 00467500 -"DSIN ", OCT2055000043010105, 00467600 -"DSQRT ", OCT2055000050010123, 00467700 -"EQUIV ", OCT0033140000020133, 00467800 -"ERF ", OCT0033000000010125, 00467900 -"EXP ", OCT2033000033010020, 00468000 -"FLOAT ", OCT0031150000010060, 00468100 -"GAMMA ", OCT2033000040010126, 00468200 -"IABS ", OCT0011010000010007, 00468300 -"IDIM ", OCT0011100000020072, 00468400 -"IDINT ", OCT0015240000010057, 00468500 -"IFIX ", OCT0013030000010054, 00468600 -"INT ", OCT0013030000010054, 00468700 -"ISIGN ", OCT0011160000020070, 00468800 -".ERR. ", OCT2000000030000134, 00468900 -".FBINB", OCT0000000000000160, 00469000 -".FINAM", OCT0000000000000154, 00469100 -".FONAM", OCT0000000000000155, 00469200 -".FREFR", OCT0000000000000146, 00469300 -".FREWR", OCT0000000000000153, 00469400 -".FTINT", OCT0000000000000050, 00469500 -".FTNIN", OCT0000000000000156, 00469600 -".FTNOU", OCT0000000000000157, 00469700 -".FTOUT", OCT0000000000000051, 00469800 -".LABEL", OCT0000000000000021, 00469900 -".MATH ", OCT0000000000000055, 00470000 -".MEMHR", OCT0000000000000164, 00470100 -".XTOI ", OCT0000000000000056, 00470200 -"MAX0 ", OCT0011250000000135, 00470300 -"MAX1 ", OCT0013250000000135, 00470400 -"MIN0 ", OCT0011250000000136, 00470500 -"MIN1 ", OCT0013250000000136, 00470600 -"MOD ", OCT0011170000020137, 00470700 -"OR ", OCT0033200000020131, 00470800 -"REAL ", OCT0036210000010073, 00470900 -"SIGN ", OCT0033160000020070, 00471000 -"SINH ", OCT0033000000010120, 00471100 -"SIN ", OCT2033000034010014, 00471200 -"SNGL ", OCT0035230000010061, 00471300 -"SQRT ", OCT2033000031010013, 00471400 -"TANH ", OCT0033000000010122, 00471500 -"TAN ", OCT2033000036010111, 00471600 -"TIME ", OCT0031220000010064, 00471700 - 0; 00471800 -BLANKS~INLINEINT[MAX~0] ; 00471900 -FOR SCN~1 STEP 1 UNTIL BLANKS DO 00472000 - BEGIN 00472100 - EQVID~INLINEINT[SCN]; WHILE INT[MAX]!EQVID DO MAX~MAX+2 ; 00472200 - INLINEINT[SCN].INTX~MAX+1 ; 00472300 - END ; 00472400 -INTID.SUBCLASS ~ INTYPE; 00472500 -REALID.SUBCLASS ~ REALTYPE; 00472600 -EQVID ~ ".EQ000"; 00472700 -LISTID ~ ".LI000"; 00472800 -BLANKS ~ " "; 00472900 -ENDSEGTOG ~ TRUE; 00473000 -SCN ~ 7; 00473100 -MAX ~ REAL(NOT FALSE).[9:39]; 00473200 -SUPERMAXCOM~128|(MAXCOM+1) ; 00473300 -SEGPTOG ~ FALSE; %INHIBIT PAGE SKIP AFTER SUBROUTINES %501- 00473400 -END INITIALIZATION; 00473500 - 00473600 -ALPHA PROCEDURE NEED(T, C); VALUE T, C; ALPHA T, C; 00473700 -BEGIN INTEGER N; REAL ELBAT; 00473800 - REAL X; 00473900 - LABEL XIT, CHECK; 00474000 - ALPHA INFA, INFB, INFC; 00474100 -COMMENT NEED RETURNS THE ELBAT WORD FOR THE IDENTIFIER T. 00474200 -IF THIS IS THE FIRST OCCURRENCE OF T THEN AN INFO WORD IS BUILT AND 00474300 -GIVEN THEN CLASS C; 00474400 - ELBAT.CLASS ~ C; 00474500 - XTA ~ T; 00474600 - IF C { LABELID THEN 00474700 - BEGIN 00474800 - IF N ~ SEARCH(T) = 0 THEN N ~ ENTER(ELBAT, T) ELSE 00474900 - IF ELBAT ~ GET(N).CLASS = UNKNOWN 00475000 - THEN PUT(N,GET(N)&C[TOCLASS]) 00475100 - ELSE IF ELBAT ! C THEN FLOG(21); 00475200 - GO TO XIT; 00475300 - END; 00475400 - IF N ~ SEARCH(T) = 0 THEN 00475500 - BEGIN 00475600 - IF N ~ GLOBALSEARCH(T) ! 0 THEN GO TO CHECK; 00475700 - N ~ GLOBALENTER(ELBAT, T); 00475800 - GO TO XIT; 00475900 - END; 00476000 - GETALL(N,INFA,INFB,INFC); 00476100 - IF INFA.CLASS = DUMMY THEN BEGIN N ~ INFC.BASE; GO TO CHECK END; 00476200 - IF BOOLEAN(INFA. FORMAL) THEN GO TO CHECK; 00476300 - IF INFA.CLASS ! UNKNOWN THEN 00476400 - BEGIN 00476500 - IF N ~ GLOBALSEARCH(T) ! 0 THEN GO TO CHECK; 00476600 - ELBAT.SUBCLASS ~ INFA.SUBCLASS; 00476700 - N ~ GLOBALENTER(ELBAT, T); 00476800 - GO TO XIT; 00476900 - END; 00477000 - PUT(N, INFA & DUMMY[TOCLASS]); 00477100 - ELBAT.SUBCLASS ~ INFA .SUBCLASS; 00477200 - IF X ~ GLOBALSEARCH(T) = 0 THEN X ~ GLOBALENTER(ELBAT, T); 00477300 - PUT(N+2, INFC & X[TOBASE]); N ~ X; 00477400 - CHECK: 00477500 - INFA ~ GET(N); 00477600 - IF ELBAT ~ INFA .CLASS = UNKNOWN THEN 00477700 - BEGIN INFO[N.IR,N.IC].CLASS ~ C; GO TO XIT END; 00477800 - IF ELBAT ! C THEN 00477900 - IF ELBAT = EXTID AND 00478000 - (C = SUBRID OR C = FUNID) THEN 00478100 - INFO[N.IR,N.IC].CLASS ~ C 00478200 - ELSE IF (ELBAT=SUBRID OR ELBAT= FUNID) AND C = EXTID THEN 00478300 - ELSE FLOG(21); 00478400 - XIT: NEED ~ GETSPACE(N); 00478500 - XTA ~ NAME; % RESTORE XTA FOR DIAGNOSTIC PURPOSES 00478600 -END NEED; 00478700 - 00478800 -INTEGER PROCEDURE EXPR(B); VALUE B; BOOLEAN B; FORWARD; 00478900 - 00479000 -PROCEDURE SPLIT(A); VALUE A; REAL A; 00479100 -BEGIN 00479200 - EMITPAIR(JUNK, ISN); 00479300 - EMITD(40, DIA); 00479400 - EMITD(18, ISO); 00479500 - EMITDESCLIT(A); 00479600 - EMITO(LOD); 00479700 - EMITOPDCLIT(JUNK); 00479800 - EMITPAIR(255,CHS); 00479900 - EMITO(LND); 00480000 -END SPLIT; 00480100 -BOOLEAN PROCEDURE SUBSCRIPTS(LINK,FROM); VALUE LINK,FROM; 00480200 -INTEGER LINK, FROM; 00480300 -BEGIN INTEGER I, NSUBS, BDLINK; 00480400 - LABEL CONSTRUCT, XIT; 00480500 -REAL SUM, PROD, BOUND; 00480600 -REAL INFA,INFB,INFC; 00480700 -REAL SAVENSEG,SAVEADR ; 00480800 -INTEGER INDX; 00480900 -REAL INFD; 00481000 -BOOLEAN TOG, VARF; 00481100 -REAL SAVIT; 00481200 -DEFINE SS = LSTT#; 00481300 -IF DEBUGTOG THEN FLAGROUTINE(" SUBSC","RIPTS ",TRUE ) ; 00481400 - SAVIT ~ IT; 00481500 - LINK ~ GETSPACE(LINK); 00481600 -GETALL(LINK,INFA,INFB,INFC); 00481700 - IF INFA.CLASS ! ARRAYID THEN 00481800 - BEGIN XTA ~ INFB; FLOG(35); GO TO XIT END; 00481900 - NSUBS ~ INFC.NEXTRA; 00482000 - IF FROM = 4 THEN 00482100 - BEGIN IF NSUBS GTR SAVESUBS THEN SAVESUBS ~ NSUBS; 00482200 - IF NSUBS GTR NAMLIST[0] THEN NAMLIST[0] ~ NSUBS; 00482300 - NAMLIST[NAMEIND].[1:8] ~ NSUBS; 00482400 - INFD ~ GET(NEED(".SUBAR",BLOCKID)).ADDR; 00482500 - END; 00482600 - BDLINK ~ INFC.ADINFO-NSUBS+1; 00482700 - VARF ~ INFC < 0; 00482800 - FOR I ~ 1 STEP 1 UNTIL NSUBS DO 00482900 - BEGIN 00483000 - IT~IT+1; SAVENSEG~NSEG; SAVEADR~ADR ; 00483100 - IF EXPR(TRUE) > REALTYPE THEN FLAG(98); 00483200 - IF ADR=SAVEADR THEN FLAG(36) ; 00483300 - IF VARF THEN 00483400 - IF EXPRESULT=NUMCLASS AND NSEG=SAVENSEG THEN 00483500 - BEGIN 00483600 - ADR~SAVEADR ; 00483700 - EMITNUM(EXPVALUE-1); 00483800 - END ELSE EMITPAIR(1, SUB) 00483900 - ELSE 00484000 - IF EXPRESULT=NUMCLASS AND NSEG = SAVENSEG AND FROM NEQ 4 THEN 00484100 - BEGIN 00484200 - ADR~SAVEADR; IF SS[IT]~EXPVALUE{0 THEN FLAG(154) ; 00484300 - END 00484400 - ELSE SS[IT] ~ @9; 00484500 - IF FROM = 4 THEN 00484600 - BEGIN IF VARF THEN BEGIN EMITO(DUP); EMITPAIR(1,ADD); END; 00484700 - EMITL(INDX); INDX ~ INDX+1; 00484800 - EMITDESCLIT(INFD); 00484900 - EMITO(IF VARF THEN STD ELSE STN); 00485000 - END; 00485100 - IF I < NSUBS THEN 00485200 - BEGIN 00485300 - IF GLOBALNEXT ! COMMA THEN 00485400 - BEGIN XTA ~ INFB; FLOG(23) END; 00485500 - SCAN; 00485600 - END; 00485700 - END; 00485800 - IF GLOBALNEXT ! RPAREN THEN BEGIN XTA ~ INFB; FLOG(24); END 00485900 - ELSE IF FROM < 2 THEN 00486000 - BEGIN SCAN; IF PREC > 0 THEN FROM ~ 1; END; 00486100 - SUM ~ 0; 00486200 - TOG ~ VARF; 00486300 - IF VARF THEN 00486400 - FOR I ~ NSUBS-1 STEP -1 UNTIL 1 DO 00486500 - BEGIN 00486600 - IF BOUND ~ EXTRAINFO[(BDLINK~BDLINK+1).IR,BDLINK.IC] < 0 THEN 00486700 - EMITOPDCLIT(BOUND) ELSE EMITNUM(BOUND); 00486800 - EMITO(MUL); 00486900 - EMITO(ADD); 00487000 - END 00487100 - ELSE 00487200 - FOR I ~ NSUBS STEP -1 UNTIL 1 DO 00487300 - BEGIN 00487400 - IF I = 1 THEN BOUND ~ 1 ELSE 00487500 - BOUND ~ EXTRAINFO[(BDLINK~BDLINK+1).IR,BDLINK.IC]; 00487600 - IF T ~ SS[SAVIT+I] < @9 THEN 00487700 - BEGIN 00487800 - SUM ~ (SUM+T-1)|BOUND; 00487900 - IF TOG THEN PROD ~ PROD|BOUND; 00488000 - END 00488100 - ELSE 00488200 - BEGIN 00488300 - IF TOG THEN BEGIN EMITNUM(PROD); EMITO(MUL); EMITO(ADD) END 00488400 - ELSE TOG ~ TRUE; 00488500 - PROD ~ BOUND; 00488600 - SUM ~ (SUM-1)|BOUND; 00488700 - END; 00488800 - END; 00488900 - IF VARF THEN T ~ @9; 00489000 - IF INFA.SUBCLASS } DOUBTYPE THEN 00489100 - BEGIN 00489200 - IF TOG THEN 00489300 - BEGIN 00489400 - IF T < @9 THEN EMITNUM(2|PROD) ELSE EMITL(2); 00489500 - EMITO(MUL); 00489600 - END; 00489700 - SUM ~ SUM|2; 00489800 - END ELSE 00489900 - IF T < @9 AND TOG THEN BEGIN EMITNUM(PROD); EMITO(MUL) END; 00490000 - IF BOOLEAN(INFA.CE) THEN 00490100 - SUM ~ SUM + INFC.BASE ELSE 00490200 - IF BOOLEAN(INFA.FORMAL) THEN 00490300 - BEGIN EMITOPDCLIT(INFA.ADDR-1); 00490400 - IF TOG THEN EMITO(ADD) ELSE TOG ~ TRUE; 00490500 - END; 00490600 - IF BOOLEAN(INFA.TWOD) AND FROM > 0 THEN 00490700 - BEGIN 00490800 - IF SUM = 0 THEN 00490900 - IF TOG THEN ELSE 00491000 - BEGIN 00491100 - EMITL(0); 00491200 - EMITDESCLIT(INFA.ADDR); 00491300 - EMITO(LOD); 00491400 - EMITL(0); 00491500 - GO TO CONSTRUCT; 00491600 - END 00491700 - ELSE 00491800 - IF TOG THEN 00491900 - BEGIN 00492000 - EMITNUM(ABS(SUM)); 00492100 - IF SUM < 0 THEN EMITO(SUB) ELSE EMITO(ADD); 00492200 - END ELSE 00492300 - BEGIN 00492400 - EMITL(SUM.[33:7]); 00492500 - EMITDESCLIT(INFA.ADDR); 00492600 - EMITO(LOD); 00492700 - EMITL(SUM.[40:8]); 00492800 - GO TO CONSTRUCT; 00492900 - END; 00493000 - SPLIT(INFA.ADDR); 00493100 - CONSTRUCT: 00493200 - IF BOOLEAN(FROM) THEN 00493300 - BEGIN 00493400 - IF INFA.SUBCLASS } DOUBTYPE THEN 00493500 - BEGIN 00493600 - EMITO(CDC); 00493700 - EMITO(DUP); 00493800 - EMITPAIR(1, XCH); 00493900 - EMITO(INX); 00494000 - EMITO(LOD); 00494100 - EMITO(XCH); 00494200 - EMITO(LOD); 00494300 - END ELSE EMITO(COC); 00494400 - END ELSE 00494500 - BEGIN 00494600 - IF SUM = 0 THEN IF NOT TOG THEN EMITL(0) ELSE 00494700 - ELSE 00494800 - BEGIN 00494900 - IF TOG THEN 00495000 - BEGIN 00495100 - EMITNUM(ABS(SUM)); 00495200 - IF SUM < 0 THEN EMITO(SUB) ELSE EMITO(ADD); 00495300 - END 00495400 - ELSE EMITNUM(SUM); 00495500 - END; 00495600 - IF FROM > 0 THEN 00495700 - IF BOOLEAN (FROM) THEN 00495800 - IF INFA.SUBCLASS } DOUBTYPE THEN 00495900 - BEGIN 00496000 - EMITDESCLIT(INFA.ADDR); 00496100 - EMITO(DUP); 00496200 - EMITPAIR(1,XCH); 00496300 - EMITO(INX); 00496400 - EMITO(LOD); 00496500 - EMITO(XCH); 00496600 - EMITO(LOD); 00496700 - END ELSE EMITV(LINK) ELSE 00496800 - BEGIN DESCREQ ~ TRUE; EMITN(LINK); DESCREQ ~ FALSE END; 00496900 - END; 00497000 - XIT: 00497100 - IT ~ SAVIT; 00497200 - SUBSCRIPTS ~ BOOLEAN(FROM); 00497300 - IF DEBUGTOG THEN FLAGROUTINE(" SUBSC","RIPTS ",FALSE) ; 00497400 - END SUBSCRIPTS; 00497500 - 00497600 -BOOLEAN PROCEDURE BOUNDS(LINK); VALUE LINK; REAL LINK; 00497700 -BEGIN 00497800 - COMMENT CALLED TO PROCESS ARRAY BOUNDS; 00497900 - BOOLEAN VARF, SINGLETOG; %109-00498000 - DEFINE FNEW = LINK#; 00498100 - REAL T, NSUBS, INFA, INFB, INFC, FIRSTSS; 00498200 - LABEL LOOP; 00498300 -IF DEBUGTOG THEN FLAGROUTINE(" BOU","NDS ",TRUE ); 00498400 - GETALL(FNEW, INFA, INFB, INFC); 00498500 - FIRSTSS ~ NEXTSS; 00498600 - IF LINK < 0 THEN BEGIN SINGLETOG ~ TRUE; LINK ~ ABS(LINK) END; %109-00498700 - LOOP: 00498800 - IF NEXT = ID THEN 00498900 - BEGIN 00499000 - T ~ GET(FNEXT ~ GETSPACE(FNEXT)); 00499100 - IF T.CLASS ! VARID OR NOT BOOLEAN(T.FORMAL) THEN FLAG(92) ELSE 00499200 - IF T.SUBCLASS > REALTYPE THEN FLAG(93); 00499300 - T ~ -T.ADDR; 00499400 - VARF ~ TRUE; 00499500 - END ELSE 00499600 - IF NEXT = NUM THEN 00499700 - BEGIN 00499800 - IF NUMTYPE!INTYPE THEN FLAG(113); 00499900 - IF T~FNEXT=0 THEN FLAG(122) ; 00500000 - IF NOT VARF THEN IF NSUBS = 0 THEN LENGTH ~ FNEXT ELSE 00500100 - LENGTH ~ LENGTH|FNEXT; 00500200 - END ELSE FLOG(122); 00500300 - EXTRAINFO[NEXTSS.IR,NEXTSS.IC] ~ T; 00500400 - NEXTSS ~ NEXTSS-1; 00500500 - NSUBS ~ NSUBS+1; 00500600 - SCAN; 00500700 - IF NEXT = COMMA THEN BEGIN SCAN; GO TO LOOP END; 00500800 - IF NEXT ! RPAREN THEN FLOG(94); 00500900 - XTA ~ INFB; 00501000 - IF INFA.CLASS = ARRAYID THEN FLAG(95); 00501100 - INFA.CLASS ~ ARRAYID; 00501200 - IF VARF THEN 00501300 - BEGIN 00501400 - IF NOT BOOLEAN(INFA.FORMAL) THEN FLAG(96); 00501500 - IF NSUBS > 1 OR INFA .SUBCLASS } DOUBTYPE THEN 00501600 - BEGIN BUMPLOCALS;LENGTH~LOCALS + 1536;BOUNDS~TRUE END ELSE 00501700 - LENGTH ~-EXTRAINFO[FIRSTSS.IR,FIRSTSS.IC]; 00501800 - END ELSE 00501900 - IF NOT SINGLETOG AND INFA.SUBCLASS > LOGTYPE THEN %109-00502000 - BEGIN LENGTH ~ 2 | LENGTH; BOUNDS ~ TRUE END; %109-00502100 - IF LENGTH > 32767 THEN FLAG(99); 00502200 - INFC ~ LENGTH & NSUBS[TONEXTRA] & FIRSTSS[TOADINFO]; 00502300 - IF VARF THEN INFC ~ -INFC; 00502400 - PUT(FNEW, INFA); PUT(FNEW+2, INFC); 00502500 - SCAN; 00502600 -IF DEBUGTOG THEN FLAGROUTINE(" BOU","NDS ",FALSE) ; 00502700 -END BOUNDS; 00502800 - 00502900 -PROCEDURE PARAMETERS(LINK); VALUE LINK; REAL LINK; 00503000 -BEGIN 00503100 - LABEL LOOP; 00503200 - REAL NPARMS, EX, INFC, PTYPE; 00503300 - ALPHA EXPNAME; 00503400 - BOOLEAN CHECK, INTFID; 00503500 - BOOLEAN NOTZEROP; 00503600 - REAL SAVIT; 00503700 - DEFINE PARMTYPE = LSTT#; 00503800 - SAVIT ~ IT ~ IT+1; 00503900 -IF DEBUGTOG THEN FLAGROUTINE(" PARAM","ETERS ",TRUE ) ; 00504000 - INFC ~ GET(LINK+2); 00504100 - IF CHECK ~ BOOLEAN(INFC.[1:1]) THEN 00504200 - BEGIN 00504300 - EX ~ INFC.ADINFO; 00504400 - NOTZEROP ~ INFC.NEXTRA ! 0; 00504500 - INTFID ~ INFC.[36:12] = 1; 00504600 - END; 00504700 - LOOP: 00504800 - BEGIN SCAN; 00504900 - EXPNAME ~ NAME; 00505000 - IF GLOBALNEXT = 0 AND NAME = "$ " THEN 00505100 - BEGIN EXPRESULT ~ LABELID; SCAN; 00505200 - IF GLOBALNEXT ! NUM THEN FLAG(44); 00505300 - EMITLABELDESC(NAME); 00505400 - PTYPE ~ 0; 00505500 - SCAN; 00505600 - END 00505700 - ELSE PTYPE ~ EXPR(CHECK AND EXTRAINFO[EX.IR,EX.IC].CLASS 00505800 - = EXPCLASS AND INTFID); 00505900 - IF EXPRESULT = NUMCLASS THEN 00506000 - IF PTYPE = STRINGTYPE THEN 00506100 - BEGIN 00506200 - ADR ~ ADR - 1; 00506300 - PTYPE ~ INTYPE; 00506400 - EXPRESULT ~ SUBSVAR; 00506500 - IF STRINGSIZE = 1 AND 00506600 - (T ~ EXTRAINFO[EX.IR,EX.IC].CLASS = VARID OR 00506700 - T = EXPCLASS) THEN 00506800 - BEGIN 00506900 - EXPRESULT ~ EXPCLASS; 00507000 - EMITNUM(STRINGARRAY[0]); 00507100 - END ELSE 00507200 - BEGIN 00507300 - EXPRESULT~ARRAYID; 00507400 - EMITPAIR(PRGDESCBLDR(1,0,0,NXAVIL~NXAVIL+1), LOD); 00507500 - EMITL(0); 00507600 - WRITEDATA(STRINGSIZE, NXAVIL, STRINGARRAY); 00507700 - END; 00507800 - END ELSE EXPRESULT ~ EXPCLASS; 00507900 - PARMTYPE[IT] ~ 0 & EXPRESULT[TOCLASS] & PTYPE[TOSUBCL]; 00508000 - XTA ~ EXPNAME; 00508100 - IF TSSEDITOG THEN IF (EXPRESULT=FUNID OR EXPRESULT=SUBRID OR 00508200 - EXPRESULT=EXTID) AND NOT DCINPUT THEN TSSED(XTA,2); 00508300 - IF DCINPUT THEN IF EXPRESULT=FUNID OR EXPRESULT=SUBRID 00508400 - OR EXPRESULT=EXTID THEN FLAG(151) ; 00508500 - IF CHECK THEN 00508600 - BEGIN 00508700 - IF T ~ EXTRAINFO[EX.IR,EX.IC].CLASS ! EXPRESULT THEN 00508800 - CASE T OF 00508900 - BEGIN 00509000 - EXTRAINFO[EX.IR,EX.IC] ~ 0 & EXPRESULT[TOCLASS] 00509100 - & PTYPE[TOSUBCL]; 00509200 - IF EXPRESULT ! SUBSVAR THEN FLAG(66); 00509300 - IF EXPRESULT = SUBSVAR THEN 00509400 - IF NOT INTFID THEN 509500 - BEGIN EMITO(CDC); 00509600 - IF PTYPE } DOUBTYPE THEN EMITL(0); 00509700 - END ELSE 00509800 - ELSE 00509900 - IF EXPRESULT = EXPCLASS THEN 00510000 - BEGIN IF PTYPE } DOUBTYPE THEN EMITO(XCH); 00510100 - EXTRAINFO[EX.IR,EX.IC].CLASS ~ EXPCLASS 00510200 - END ELSE FLAG(67); 00510300 - ; ; ; 00510400 - FLAG(68); 00510500 - IF EXPRESULT = EXTID THEN 00510600 - PUT(EXPLINK,GET(EXPLINK)&FUNID[TOCLASS]) ELSE 00510700 - FLAG(69); 00510800 - ; 00510900 - IF EXPRESULT = FUNID OR EXPRESULT = SUBRID THEN 00511000 - EXTRAINFO[EX.IR,EX.IC] ~ EXPRESULT ELSE FLAG(70); 00511100 - IF EXPRESULT = EXTID THEN 00511200 - PUT(EXPLINK,GET(EXPLINK)&SUBRID[TOCLASS]) ELSE 00511300 - FLAG(71); 00511400 - ; ; 00511500 - IF EXPRESULT = ARRAYID THEN EXTRAINFO[EX.IR,EX.IC].CLASS 00511600 - ~ ARRAYID ELSE 00511700 - IF EXPRESULT = VARID THEN 00511800 - BEGIN 00511900 - EXTRAINFO[EX.IR,EX.IC].CLASS ~ SBVEXP; 00512000 - EMITL(0) 00512100 - END ELSE 00512200 - IF EXPRESULT = EXPCLASS THEN 00512300 - BEGIN 00512400 - EXTRAINFO[EX.IR,EX.IC].CLASS ~ SBVEXP; 00512500 - IF PTYPE } DOUBTYPE THEN EMITO(XCH) ELSE EMITL(0); 00512600 - END ELSE FLAG(72); 00512700 - IF EXPRESULT = SUBSVAR THEN 00512800 - IF NOT INTFID THEN 00512900 - BEGIN EMITO(CDC); 00513000 - IF PTYPE } DOUBTYPE THEN EMITL(0) 00513100 - END 00513200 - ELSE 00513300 - ELSE IF EXPRESULT = VARID THEN 00513400 - IF NOT INTFID THEN 00513500 - IF PTYPE } DOUBTYPE THEN EMITL(0) ELSE ELSE 00513600 - ELSE FLAG(67); 00513700 - IF EXPRESULT = VARID THEN 00513800 - EMITL(0) ELSE 00513900 - IF EXPRESULT = EXPCLASS THEN 00514000 - IF PTYPE } DOUBTYPE THEN EMITO(XCH) ELSE EMITL(0) 00514100 - ELSE IF EXPRESULT ! SUBSVAR THEN FLAG(67); 00514200 - END OF CASE STATEMENT 00514300 - ELSE IF PTYPE } DOUBTYPE THEN 00514400 - IF EXPRESULT = VARID THEN EMITL(0) 00514500 - ELSE IF EXPRESULT = EXPCLASS AND NOT INTFID 00514600 - THEN EMITO(XCH); 00514700 - IF T ~ EXTRAINFO[EX.IR,EX.IC].SUBCLASS = 0 OR 00514800 - (T = INTYPE AND PTYPE = REALTYPE AND 00514900 - GET(LINK).SEGNO = 0) THEN 00515000 - EXTRAINFO[EX.IR,EX.IC].SUBCLASS ~ PTYPE ELSE 00515100 - IF NOT(T = PTYPE OR T = REALTYPE AND PTYPE = INTYPE ) THEN 00515200 - FLAG(88); 00515300 - END OF CHECK 00515400 - ELSE IF PTYPE } DOUBTYPE THEN 00515500 - IF EXPRESULT = VARID THEN EMITL(0) 00515600 - ELSE IF EXPRESULT = EXPCLASS THEN EMITO(XCH); 00515700 - IF NOTZEROP THEN EX ~ EX+1; 00515800 - IT ~ IT+1; 00515900 - END; 00516000 - IF GLOBALNEXT = COMMA THEN GO TO LOOP; 00516100 - NPARMS ~ IT - SAVIT; 00516200 - IF GLOBALNEXT ! RPAREN THEN FLOG(108); 00516300 - IF NOT CHECK THEN 00516400 - BEGIN 00516500 - INFC ~ GET(LINK+2); 00516600 - INFC ~ -(INFC & NPARMS[TONEXTRA] 00516700 - & NEXTEXTRA[TOADINFO]); 00516800 - PUT(LINK+2,INFC); 00516900 - FOR I ~ SAVIT STEP 1 UNTIL IT-1 DO 00517000 - BEGIN 00517100 - EXTRAINFO[NEXTEXTRA.IR,NEXTEXTRA.IC] ~ PARMTYPE[I]; 00517200 - NEXTEXTRA ~ NEXTEXTRA+1; 00517300 - END; 00517400 - END 00517500 - ELSE 00517600 - IF T ~ GET(LINK+2).NEXTRA > 0 AND T ! NPARMS OR 00517700 - T=0 AND INTFID AND NPARMS < 2 OR 00517800 - T = 0 AND NOT INTFID THEN 00517900 - BEGIN XTA ~ GET(LINK+1); FLAG(28) END; 00518000 -IF DEBUGTOG THEN FLAGROUTINE(" PARAM","ETERS ",FALSE) ; 00518100 - IT ~ SAVIT-1; 00518200 -END PARAMETERS; 00518300 - 00518400 -PROCEDURE STMTFUNREF(LINK); VALUE LINK; REAL LINK; 00518500 -BEGIN 00518600 - REAL I, PARMLINK, NPARMS, SEG; 00518700 -IF DEBUGTOG THEN FLAGROUTINE(" STMTF","UNREF ",TRUE); 00518800 - PARMLINK ~ GET(LINK+2).[36:12]; 00518900 - DO 00519000 - BEGIN 00519100 - SCAN; 00519200 - IF A~EXPR(TRUE) ! B~GET(PARMLINK).SUBCLASS THEN 00519300 - IF A > REALTYPE OR B > REALTYPE THEN %108-00519400 - BEGIN XTA ~ NNEW; FLAG(88) END; 00519500 - PARMLINK ~ PARMLINK-3; 00519600 - NPARMS ~ NPARMS+1; 00519700 - END UNTIL NEXT ! COMMA; 00519800 - IF NEXT ! RPAREN THEN FLAG(108); 00519900 - SCAN; 00520000 - GETALL(LINK, INFA, XTA, INFC); 00520100 - IF NPARMS ! INFC.NEXTRA THEN FLAG(28); 00520200 - SEG ~ INFA.SEGNO; 00520300 - BRANCHLIT(INFC.BASE&SEG[TOSEGNO],FALSE); 00520400 - EMITB(INFA.ADDR & SEG[TOSEGNO], FALSE); 00520500 - ADJUST; 00520600 - IF DEBUTOG THEN FLAGROUTINE(" STMTF","UNREF ",FALSE); 00520700 - END STMTFUNREF; 00520800 - 00520900 - BOOLEAN PROCEDURE DOITINLINE(LNK); VALUE LNK; REAL LNK ; 00521000 - BEGIN 00521100 - REAL C,I,C1,C2,C3,C4,C5 ; 00521200 - LABEL HUNT,FOUND,XIT,AIMAG,AINT,CMPLX,LOOP,DDT111,SNGL ; 00521300 - DEFINE OPTYPE=LSTT#, E0=EMITO#, EP=EMITPAIR#, EOL=EMITOPDCLIT# ;00521400 - IF DEBUGTOG THEN FLAGROUTINE("DOITIN","LINE ",TRUE); 00521500 - C1~1; C2~INLINEINT[0]; C3~GET(ABS(LNK)+1) ; 00521600 - HUNT: 00521700 - IF (C~INLINEINT[I~(C1+C2).[36:11]].INAM)C3 THEN C2~I-1 ELSE GO FOUND ; 00521900 - IF C10 THEN INLINEINT[I]~-C4; I~0 ; 00524600 - IF XREF THEN ENTERX(C3,0&FUNID[TOCLASS]&C[21:6:3]); 00524700 - IF GLOBALNEXT!LPAREN THEN BEGIN FLOG(106); GO XIT END ; 00524800 - LOOP: SCAN; C5~XTA ; 00524900 - IF I=0 THEN 00525000 - IF LNK=10 THEN EMITL(0) ELSE IF LNK=21 THEN EMITDESCLIT(2) ; 00525100 - IF (C4~EXPR(TRUE))!C1 AND (C1!REALTYPE OR C4!INTYPE) THEN 00525200 - BEGIN XTA~C5; FLAG(88); C2~-2 END ; 00525300 - I~I+1; IF GLOBALNEXT=COMMA THEN GO LOOP ; 00525400 - IF GLOBALNEXT!RPAREN THEN BEGIN FLOG(108); C2~-2 END; SCAN ; 00525500 - IF I!C.INTPARMS THEN IF C.INTPARMS!0 OR I<2 THEN 00525600 - BEGIN XTA~C3; FLAG(28); C2~-2 END ; 00525700 - OPTYPE[IT]~C.INTCLASS; IF C2<0 THEN GO XIT ; 00525800 - CASE (LNK-1) OF 00525900 - BEGIN 00526000 - E0(SSP) ; % @1: ABS, DABS, IABS. 00526100 - AIMAG: E0(DEL) ; % @2: AIMAG. 00526200 - AINT: EP(1,IDV) ; % @3: AINT, IFIX, INT. 00526300 - E0(RDV) ; % @4: AMOD. 00526400 - E0(LND) ; % @5: LOGICAL AND. 00526500 - CMPLX: E0(XCH) ; % @6: CMPLX. 00526600 - E0(LNG) ; % @7: LOGICAL COMPLIMENT (NEGATION). 00526700 - BEGIN % @10: DIM, IDIM. 00526800 - E0(SUB); E0(DUP); EP(0,LESS) ; 00526900 - IF ADR>4082 THEN BEGIN ADR~ADR+1; SEGOVF END ; 00527000 - EP(2,BFC); E0(DEL); EMITL(0) ; 00527100 - END ; 00527200 - BEGIN E0(XCH); E0(CHS); GO CMPLX END ; % @11: CONJG. 00527300 - ; % @12: DBLE (SOME CODE ALREADY EMITTED ABOVE). 00527400 - BEGIN E0(XCH); E0(DEL) ; % @13: DSIGN. 00527500 - DDT111: EMITDDT(1,1,1) ; 00527600 - END; 00527700 - E0(LQV) ; % @14: LOGICAL EQUIVALENCE. 00527800 - ; % @15: FLOAT. 00527900 - GO DDT111 ; % @16: ISIGN, SIGN. 00528000 - BEGIN E0(RDV); GO AINT END ; % @17: MOD. 00528100 - E0(LOR) ; % @20: LOGICAL OR. 00528200 - BEGIN E0(XCH); GO AIMAG END ; % @21: REAL. 00528300 - EP(1,KOM) ; % @22: TIME. 00528400 - BEGIN % @23: SNGL. 00528500 - SNGL: EP(9,SND); E0(XCH); EMITDDT(47,9,1); EMITL(0) ; 00528600 - EMITDDT(9,9,38); EOL(9); EMITO(ADD); IF LNK=20 THEN GO AINT ; 00528700 - END ; 00528800 - GO SNGL ; % @24: IDINT. 00528900 - 00529000 - BEGIN % @25: AMAX0,AMAX1,AMIN0,AMIN1,MAX0,MAX1,MIN0,MIN1. 00529100 - % SOME CODE ALREADY EMITTED ABOVE. 00529200 - IF ADR>4068 THEN BEGIN ADR~ADR+1; SEGOVF END ; 00529300 - EP(9,STD); E0(DUP); EOL(9) ; 00529400 - E0(IF C3.[24:6]="A" OR C3.[24:6]="X" THEN LESS ELSE GRTR) ; 00529500 - EP(2,BFC); E0(DEL); EOL(9); E0(XCH); E0(TOP); E0(LNG) ; 00529600 - EP(14,BBC); E0(DEL); IF C3="MIN1 " OR C3="MAX1 " THEN GO AINT00529700 - END ; 00529800 - 00529900 - END OF CASE STATEMENT ; 00530000 - XIT: 00530100 - IF DEBUGTOG THEN FLAGROUTINE("DOITIN","LINE ",FALSE) ; 00530200 - END OF DOITINLINE ; 00530300 - 00530400 -REAL PROCEDURE LOOKFORINTRINSIC(L); VALUE L; REAL L; 00530500 -BEGIN 00530600 - ALPHA ID, I, X, NPARMS; 00530700 - REAL T; 00530800 - LABEL FOUND, XIT; 00530900 -IF DEBUGTOG THEN FLAGROUTINE("LOOKFO","RINTRN",TRUE); 00531000 - LOOKFORINTRINSIC ~ L ~ NEED(ID ~ GET(L+1),FUNID); 00531100 - IF GET(L+2) < 0 THEN GO TO XIT; % PARAMETER INFO KNOWN 00531200 - COMMENT B MUST BE SET TO K/2, WHERE K IS THE INDEX OF THE LAST 00531300 - INTRINSIC NAME IN THE ARRAY INT; 00531400 - A~0; B~NUMINTM1 ; 00531500 - WHILE A+1 < B DO 00531600 - BEGIN 00531700 - I ~ REAL(BOOLEAN(A+B) AND BOOLEAN(1022)); 00531800 - IF Z ~ INT[I] = ID THEN GO TO FOUND; 00531900 - IF ID < Z THEN B ~ I.[36:11] ELSE A ~ I.[36:11]; 00532000 - END; 00532100 - IF ID = INT[I~(A+B)|2-I] THEN GO TO FOUND; 00532200 - GO TO XIT; 00532300 - FOUND: 00532400 - NPARMS~(X~INT[I+1]).INTPARMS; INT[I+1].INTSEEN~1 ; 00532500 - INFO[L.IR,L.IC].SUBCLASS~X.INTCLASS ; 00532600 - PUT(L+2,-(1&NEXTEXTRA[TOADINFO]&NPARMS[TONEXTRA])); 00532700 - IF NPARMS = 0 THEN NPARMS ~ 1; 00532800 - T~X.INTPARMCLASS ; 00532900 - FOR I ~ 1 STEP 1 UNTIL NPARMS DO 00533000 - BEGIN 00533100 - EXTRAINFO[NEXTEXTRA.IR,NEXTEXTRA.IC] ~ 00533200 - 0 & EXPCLASS[TOCLASS] & T[TOSUBCL]; 00533300 - NEXTEXTRA ~ NEXTEXTRA + 1; 00533400 - END; 00533500 - XIT: 00533600 -IF DEBUGTOG THEN FLAGROUTINE("LOOKFO","RINTRN",FALSE ) ; 00533700 -END LOOKFORINTRINSIC; 00533800 -INTEGER PROCEDURE EXPR(VALREQ); VALUE VALREQ; BOOLEAN VALREQ; 00533900 -BEGIN LABEL LOOP, STACK, XIT, NOSCAN; REAL T; 00534000 - 00534100 - LABEL ARRY; 00534200 -LABEL HERE ; 00534300 - REAL SAVIT, SAVIP; 00534400 - BOOLEAN CNSTSEENLAST; %FOR HANDLING CONSTANT %113-00534500 - REAL SAVEADR; %EXPONENTS %113-00534600 - DEFINE OPTYPE = LSTT#; 00534700 -REAL EXPRESLT,EXPLNK; 00534800 - REAL EXPV; 00534900 - REAL TM ; 00535000 - DEFINE E0=EMITO#, EP=EMITPAIR#, EOL=EMITOPDCLIT#, 00535100 - ES1(OP)=BEGIN E0(XCH); EP(9,STD); E0(OP) END #, 00535200 - ES2=BEGIN EP(9,STD); E0(XCH); EP(17,SND); E0(MUL) END # ; 00535300 - LABEL CTYP, DTYP, RLESSC, DLESSC, CLESSD, CLESSC, RPLUSD, DTIMESC, 00535400 - CTIMESR, CDIVBYD, CTIMESR1, CTIMESR2, DLESSC1 ; 00535500 - LABEL SPECCHAR, RELATION; 00535600 - REAL LINK; 00535700 - DEFINE T1 = EXPT1#, T2 = EXPT2#, CODE = EXPT3#; 00535800 -COMMENT THE FOLLOWING TABLE GIVES THE PRECEDENCE (PREC) AND 00535900 -OPERATOR NUMBER (OP) OF THE ARITHMETIC AND LOGICAL OPERATORS. 00536000 - OPERATOR PREC OP 00536100 - ** 9 15 00536200 - UNARY - 8 12 00536300 - / 7 14 00536400 - * 7 13 00536500 - - 5 11 00536600 - + 5 10 00536700 - .NE. 4 9 00536800 - .GE. 4 8 00536900 - .GT. 4 7 00537000 - .EQ. 4 6 00537100 - .LE. 4 5 00537200 - .LT. 4 4 00537300 - .NOT. 3 3 00537400 - .AND. 2 2 00537500 - .OR. 1 1 00537600 - THE UNARY PLUS IS IGNORED; 00537700 -PROCEDURE MATH(D, C, T); VALUE D, C, T; REAL D, C, T; 00537800 -BEGIN 00537900 - EMITO(MKS); 00538000 - EMITL(C); 00538100 - EMITV(NEED(".MATH ", INTRFUNID)); 00538200 - EMITO(DEL); 00538300 - IF D = 2 THEN EMITO(DEL); 00538400 - OPTYPE[IT~IT-1] ~ T; 00538500 -END MATH; 00538600 - NNEW ~ NAME; 00538700 -IF DEBUGTOG THEN FLAGROUTINE(" EXPRE","SSION ",TRUE ) ; 00538800 - OPTYPE[SAVIT ~IT ~ IT+1] ~ 00538900 - PR[SAVIP~IP~IP+1] ~ OPST[IP] ~ 0; 00539000 - IF GLOBALNEXT = PLUS THEN GO TO LOOP; 00539100 - IF GLOBALNEXT = MINUS THEN 00539200 - BEGIN PREC ~ 8; OP ~ 12; GO TO STACK END; 00539300 - IF PREC > 0 THEN GO TO STACK; 00539400 - LINK~(EXPLNK~FNEXT)&REAL(SCANENTER)[2:47:1] ; 00539500 - GO TO NOSCAN; 00539600 - LOOP: SCAN; 00539700 - LINK ~ FNEXT; 00539800 - NOSCAN: 00539900 - CNSTSEENLAST~FALSE; %113- 00540000 - IF GLOBALNEXT = ID THEN 00540100 - BEGIN 00540200 - IF IP ! SAVIP THEN EXPRESLT ~ EXPCLASS; 00540300 - OPTYPE[IT~IT+1] ~ (A~GET(LINK)).SUBCLASS; 00540400 - SCAN; 00540500 - IF NOT RANDOMTOG THEN 00540600 - IF NEXT=EQUAL THEN BEGIN NEXT~0; OP~6; PREC~4 END ; 00540700 - IF GLOBALNEXT = ID OR GLOBALNEXT = NUM THEN 00540800 - BEGIN FLOG(1); GO TO XIT END; 00540900 - IF NOT VALREQ AND PREC > 0 THEN VALREQ ~ TRUE; 00541000 - IF GLOBALNEXT ! LPAREN THEN 00541100 - BEGIN 00541200 - LINK ~ GETSPACE(LINK); 00541300 - T ~ (A~GET(LINK)).CLASS; 00541400 - IF XREF THEN ENTERX(GET(LINK+1),0&A[15:15:9]); 00541500 - IF EXPRESLT = 0 THEN EXPRESLT ~ T; 00541600 - IF VALREQ THEN 00541700 - IF T = VARID THEN EMITV(LINK) ELSE 00541800 - BEGIN XTA ~ GET(LINK+1); FLAG(50) END 00541900 - ELSE 00542000 - BEGIN 00542100 - IF T = VARID THEN 00542200 - IF GLOBALNEXT > SLASH AND EXPRESLT = VARID THEN 00542300 - BEGIN 00542400 - DESCREQ~TRUE; EMITN(LINK); DESCREQ ~ FALSE; 00542500 - GO TO XIT; 00542600 - END ELSE EMITV(LINK) 00542700 - ELSE 00542800 - BEGIN 00542900 - IF T = ARRAYID THEN 00543000 - BEGIN 00543100 - IF BOOLEAN(A.CE) THEN 00543200 - EMITNUM(GET(LINK+2).BASE) ELSE 00543300 - IF BOOLEAN(A.FORMAL) THEN 00543400 - EMITOPDCLIT(A.ADDR-1) ELSE 00543500 - EMITL(0); 00543600 - GO TO ARRY; 00543700 - END ELSE EMITPAIR(A.ADDR,LOD); 00543800 - GO TO XIT; 00543900 - END; 00544000 - END; 00544100 - GO TO SPECCHAR; 00544200 - END; 00544300 - IF A.CLASS ! ARRAYID THEN 00544400 - BEGIN COMMENT FUNCTION REFERENCE; 00544500 - EXPRESLT ~ EXPCLASS; 00544600 - IF A.CLASS = STMTFUNID THEN 00544700 - BEGIN 00544800 - IF XREF THEN ENTERX(GET(LINK+1),0&A[15:15:9]); 00544900 - STMTFUNREF(LINK) ; 00545000 - IF NEXT=EQUAL THEN IF NOT RANDOMTOG THEN 00545100 - BEGIN NEXT~0; OP~6; PREC~4 END ; 00545200 - GO TO SPECCHAR ; 00545300 - END ; 00545400 - IF A.CLASS=EXTID OR GET(TM~GLOBALSEARCH(GET(LINK+1))).CLASS=00545500 - EXTID THEN LINK~REAL(DOITINLINE(-LINK)) ELSE 00545600 - IF A.CLASS SLASH AND EXPRESLT = SUBSVAR THEN 00548100 - BEGIN 00548200 - ARRY: 00548300 - IF BOOLEAN((A~GET(LINK)).TWOD) THEN 00548400 - BEGIN 00548500 - EMITPAIR(TWODPRT, LOD); 00548600 - T ~ A.ADDR; 00548700 - IF T { 1023 THEN 00548800 - BEGIN 00548900 - EMITL(T.[38:10]); 00549000 - EMITDESCLIT(10); 00549100 - END ELSE 00549200 - BEGIN 00549300 - EMITL(T.[40:8]); 00549400 - EMITDESCLIT(1536); 00549500 - EMITO(INX); 00549600 - END; 00549700 - EMITO(CTF); 00549800 - END ELSE EMITPAIR(A.ADDR,LOD); 00549900 - EMITO(XCH); 00550000 - GO TO XIT; 00550100 - END; 00550200 - IF BOOLEAN((A~GET(LINK)).TWOD) THEN 00550300 - BEGIN 00550400 - SPLIT(A.ADDR); 00550500 - IF A.SUBCLASS } DOUBTYPE THEN 00550600 - BEGIN 00550700 - EMITO(CDC); 00550800 - EMITO(DUP); 00550900 - EMITPAIR(1, XCH); 00551000 - EMITO(INX); 00551100 - EMITO(LOD); 00551200 - EMITO(XCH); 00551300 - EMITO(LOD); 00551400 - END ELSE EMITO(COC); 00551500 - END ELSE 00551600 - EMITV(LINK); 00551700 - END; 00551800 - END ARRAY REFERENCE; 00551900 - GO TO SPECCHAR; 00552000 - END; 00552100 - IF GLOBALNEXT = NUM THEN 00552200 - BEGIN 00552300 - IF NUMTYPE = STRINGTYPE THEN 00552400 - IF VALREQ THEN 00552500 - BEGIN 00552600 - NUMTYPE~INTYPE ; 00552700 - IF STRINGSIZE=1 THEN FNEXT~STRINGARRAY[0] 00552800 - ELSE BEGIN 00552900 - IF STRINGSIZE>2 OR STRINGARRAY[1].[18:30]!" " THEN 00553000 - FLAG(162) ; 00553100 - IF (FNEXT~STRINGARRAY[1].[12:6]&STRINGARRAY[0][6:12:36]) 00553200 - .[6:6]>7 THEN NUMTYPE~REALTYPE ; 00553300 - END ; 00553400 - END; 00553500 - SAVEADR~ADR; CNSTSEENLAST~TRUE; %113-00553600 - IF NUMTYPE = DOUBTYPE THEN 00553700 - EMITNUM2(FNEXT,DBLOW) ELSE EMITNUM (FNEXT); 00553800 - OPTYPE[IT~IT+1] ~ NUMTYPE; 00553900 - IF EXPRESLT = 0 THEN 00554000 - BEGIN EXPRESLT ~ NUMCLASS; EXPV ~ FNEXT END; 00554100 - SCAN; 00554200 - IF NOT RANDOMTOG THEN 00554300 - IF NEXT=EQUAL THEN BEGIN NEXT~0; OP~6; PREC~4 END; 00554400 - IF NOT VALREQ AND PREC > 0 THEN VALREQ ~ TRUE; 00554500 - IF GLOBALNEXT = ID OR GLOBALNEXT = NUM THEN 00554600 - BEGIN FLOG(1); GO TO XIT END; 00554700 - END; 00554800 - SPECCHAR: 00554900 - IF GLOBALNEXT = LPAREN THEN 00555000 - BEGIN 00555100 - SCAN; 00555200 - OPTYPE[IT~IT+1] ~ EXPR(TRUE); 00555300 - IF GLOBALNEXT = COMMA AND EXPRESULT = NUMCLASS THEN 00555400 - BEGIN 00555500 - IF OPTYPE[IT] > REALTYPE THEN FLAG(85); 00555600 - SCAN; 00555700 - IF EXPR(TRUE) > REALTYPE 00555800 - OR EXPRESULT ! NUMCLASS THEN FLAG(85); 00555900 - EMITO(XCH); 00556000 - OPTYPE[IT] ~ COMPTYPE; 00556100 - IF EXPRESLT = 0 THEN EXPRESLT ~ NUMCLASS; 00556200 - END ELSE EXPRESLT ~ EXPCLASS; 00556300 - IF GLOBALNEXT ! RPAREN THEN 00556400 - BEGIN FLOG(108); GO TO XIT END; 00556500 - GO TO LOOP; 00556600 - END; 00556700 - WHILE PR[IP] } PREC DO 00556800 - BEGIN 00556900 - IF IT { SAVIT THEN GO TO XIT; 00557000 - CODE ~ MAP[T1~OPTYPE[IT-1]]|3 + MAP[T2~OPTYPE[IT]]; 00557100 - CASE OPST[IP] OF 00557200 - BEGIN 00557300 - GO TO XIT; 00557400 - BEGIN 00557500 - IF T1 = LOGTYPE AND T2 = LOGTYPE THEN EMITO(LOR) 00557600 - ELSE FLAG(51); 00557700 - IT ~ IT-1; 00557800 - END; 00557900 - BEGIN 00558000 - IF T1 = LOGTYPE AND T2 = LOGTYPE THEN EMITO(LND) 00558100 - ELSE FLAG(52); 00558200 - IT ~ IT-1; 00558300 - END; 00558400 - IF T2 = LOGTYPE THEN EMITO(LNG) ELSE FLAG(53); 00558500 - BEGIN T ~ LESS; GO TO RELATION END; 00558600 - BEGIN T ~ LEQL; GO TO RELATION END; 00558700 - BEGIN T ~ EQUL; GO TO RELATION END; 00558800 - BEGIN T ~ GRTR; GO TO RELATION END; 00558900 - BEGIN T ~ GEQL; GO TO RELATION END; 00559000 - BEGIN T ~ NEQL; 00559100 - RELATION: 00559200 - IF CODE < 0 THEN FLAG(54) ELSE 00559300 - CASE CODE OF 00559400 - BEGIN ; 00559500 - BEGIN 00559600 - E0(CHS); EP(9,STD); E0(XCH); EOL(9); E0(XCH); EP(0,XCH) ;00559700 - E0(AD2) ; 00559800 - END; 00559900 - FLAG(90); 00560000 - BEGIN EMITPAIR(0, XCH); EMITO(SB2) END; 00560100 - EMITO(SB2); 00560200 - FLAG(90); 00560300 - FLAG(90); 00560400 - FLAG(90); 05605000 - IF T! EQUL AND T! NEQL THEN FLAG(54) %103-00560600 - ELSE %103-00560700 - BEGIN %103-00560800 - EP(9,STD); E0(XCH); EOL(9); E0(T); %103-00560900 - EP(9,STD ); E0(T); EOL(9); %103-00560910 - T~(IF T=EQUL THEN LND ELSE LOR); CODE~0; %103-00561000 - END; %103-00561100 - END RELATION CASE STATEMENT; 00561200 - IF CODE > 0 THEN 00561300 - BEGIN EMITO(XCH); EMITO(DEL); EMITL(0) END; 00561400 - EMITO(T); 00561500 - OPTYPE[IT~IT-1] ~ LOGTYPE; 00561600 - END; 00561700 - IF CODE < 0 THEN BEGIN FLAG(53); IT ~ IT-1 END ELSE 00561800 - CASE CODE OF 00561900 - BEGIN 00562000 - BEGIN 00562100 - EMITO(ADD); 00562200 - IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE 00562300 - OPTYPE[IT~IT-1] ~ REALTYPE; 00562400 - END; 00562500 - BEGIN TM~AD2 ; 00562600 - RPLUSD: EP(9,STD); E0(XCH); EOL(9); E0(XCH); EP(0,XCH); E0(TM) ; 00562700 - DTYP: OPTYPE[IT~IT-1]~DOUBTYPE ; 00562800 - END ; 00562900 - BEGIN TM~ADD; GO RLESSC END ; 00563000 - BEGIN 00563100 - EMITPAIR(0, XCH); 00563200 - EMITO(AD2); 00563300 - IT ~ IT-1; 00563400 - END; 00563500 - BEGIN EMITO(AD2); IT ~ IT-1 END; 00563600 - BEGIN TM~ADD; GO DLESSC END ; 00563700 - BEGIN EMITO(ADD); IT ~ IT-1 END; 00563800 - BEGIN TM~ADD; GO CLESSD END ; 00563900 - BEGIN TM~ADD; GO CLESSC END ; 00564000 - END ADD CASE STATEMENT; 00564100 - IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE 00564200 - CASE CODE OF 00564300 - BEGIN 00564400 - BEGIN 00564500 - EMITO(SUB); 00564600 - IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE 00564700 - OPTYPE[IT~IT-1] ~ REALTYPE; 00564800 - END; 00564900 - BEGIN E0(CHS); TM~AD2; GO RPLUSD END; 00565000 - BEGIN TM~SUB ; 00565100 - RLESSC: ES1(TM); GO DLESSC1 ; 00565200 - END ; 00565300 - BEGIN 00565400 - EMITPAIR(0, XCH); 00565500 - EMITO(SB2); 00565600 - IT ~ IT-1; 00565700 - END; 00565800 - BEGIN EMITO(SB2); IT ~ IT-1 END; 00565900 - BEGIN TM~SUB ; 00566000 - DLESSC: ES1(TM); E0(XCH); E0(DEL) ; 00566100 - DLESSC1: EOL(9); IF TM=SUB THEN E0(CHS); GO CTIMESR2 ; 00566200 - END ; 00566300 - BEGIN EMITO(SUB); IT ~ IT-1 END; 00566400 - BEGIN TM~SUB ; 00566500 - CLESSD: E0(XCH); E0(DEL); E0(TM) ; 00566600 - CTYP: OPTYPE[IT~IT-1]~COMPTYPE ; 00566700 - END ; 00566800 - BEGIN TM~SUB ; 00566900 - CLESSC: ES1(TM); GO CTIMESR1 ; 00567000 - END ; 00567100 - END SUBTRACT CASE STATEMENT; 00567200 - BEGIN % HANDLE NEGATIVE NUMBERS CASE STATEMENT. 00567300 - EXPV~-EXPV ; 00567400 - IF T2 { REALTYPE THEN EMITO(CHS) ELSE 00567500 - IF T2 = LOGTYPE THEN FLAG(55) ELSE 00567600 - IF T2 = DOUBTYPE THEN EMITO(CHS) ELSE 00567700 - IF T2 = COMPTYPE THEN 00567800 - BEGIN 00567900 - EMITO(CHS); EMITO(XCH); 00568000 - EMITO(CHS); EMITO(XCH); 00568100 - END ELSE FLAG(55); 00568200 - END OF NEG NUMBERS CASE STATEMNT ; 00568300 - IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE 00568400 - CASE CODE OF 00568500 - BEGIN 00568600 - BEGIN 00568700 - EMITO(MUL); 00568800 - IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE 00568900 - OPTYPE[IT~IT-1] ~ REALTYPE; 00569000 - END; 00569100 - BEGIN TM~ML2; GO RPLUSD END ; 00569200 - BEGIN ES2; GO DTIMESC END ; 00569300 - BEGIN 00569400 - EMITPAIR(0, XCH); 00569500 - EMITO(ML2); 00569600 - IT ~ IT-1; 00569700 - END; 00569800 - BEGIN EMITO(ML2); IT ~ IT-1 END; 00569900 - BEGIN ES2; E0(XCH); E0(DEL) ; 00570000 - DTIMESC: EOL(9); EOL(17); E0(MUL); GO CTYP ; 00570100 - END ; 00570200 - BEGIN TM~MUL ; 00570300 - CTIMESR: EP(9,SND); E0(TM) ; 00570400 - CTIMESR1:E0(XCH); EOL(9); E0(TM) ; 00570500 - CTIMESR2:E0(XCH); GO CTYP ; 00570600 - END ; 00570700 - BEGIN TM~MUL; GO CDIVBYD END ; 00570800 - MATH(2, 26, COMPTYPE); 00570900 - END MULTIPLY CASE STATEMENT; 00571000 - 00571100 - IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE 00571200 - CASE CODE OF 00571300 - BEGIN 00571400 - IF T1 = INTYPE AND T2 = INTYPE THEN 00571500 - BEGIN EMITO(IDV); IT ~ IT-1 END ELSE 00571600 - BEGIN EMITO(DIU); OPTYPE[IT~IT-1] ~ REALTYPE END; 00571700 - BEGIN 00571800 - EP(9,STD); EP(17,STD); EP(0,XCH); EOL(17); EOL(9); E0(DV2) ; 00571900 - GO DTYP ; 00572000 - END ; 00572100 - MATH(1, 29, COMPTYPE); 00572200 - BEGIN 00572300 - EMITPAIR(0, XCH); 00572400 - EMITO(DV2); 00572500 - IT ~ IT-1; 00572600 - END; 00572700 - BEGIN EMITO(DV2); IT ~ IT-1 END; 00572800 - MATH(2, 32, COMPTYPE); 00572900 - BEGIN TM~DIU; GO CTIMESR END ; 00573000 - BEGIN TM~DIU ; 00573100 - CDIVBYD: E0(XCH); E0(DEL); GO CTIMESR ; 00573200 - END ; 00573300 - MATH(2, 35, COMPTYPE); 00573400 - END OF DIVIDE CASE STATEMENT; 00573500 - IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE 00573600 - BEGIN 00573700 - IF CODE = 0 AND T2 = INTYPE AND 00573800 - CNSTSEENLAST THEN %113-00573900 - BEGIN 00574000 - IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE 00574100 - OPTYPE[IT~IT-1] ~ REALTYPE; 00574200 - EXPV~LINK; %113- 00574300 - A~1; ADR~SAVEADR; %113- 00574400 - WHILE EXPV DIV 2 ! 0 DO 00574500 - BEGIN 00574600 - EMITO(DUP); 00574700 - IF BOOLEAN(EXPV) THEN BEGIN A~A+1; EMITO(DUP) END; 00574800 - EMITO(MUL); 00574900 - EXPV ~ EXPV DIV 2; 00575000 - END; 00575100 - IF EXPV = 0 THEN BEGIN EMITO(DEL); EMITL(1) END ELSE 00575200 - WHILE A ~ A-1 ! 0 DO EMITO(MUL); 00575300 - END ELSE 00575400 - BEGIN 00575500 - EMITO(MKS); 00575600 - EMITL(CODE); 00575700 - EMITV(NEED(".XTOI ", INTRFUNID)); 00575800 - CASE CODE OF 00575900 - BEGIN 00576000 - BEGIN EMITO(DEL); OPTYPE[IT~IT-1]~IF (T1=INTYPE AND T2=INTYPE)00576100 - THEN INTYPE ELSE REALTYPE END; 00576200 - BEGIN EMITO(DEL); OPTYPE[IT~IT-1] ~ DOUBTYPE END; 00576300 - BEGIN EMITO(DEL); OPTYPE[IT~IT-1]~COMPTYPE END ; 00576400 - BEGIN EMITO(DEL); IT ~ IT-1 END; 00576500 - BEGIN EMITO(DEL); EMITO(DEL); IT ~ IT-1 END; 00576600 - BEGIN EMITO(DEL); EMITO(DEL); OPTYPE[IT~IT-1]~COMPTYPE END ; 00576700 - BEGIN EMITO(DEL); IT ~ IT-1 END; 00576800 - BEGIN EMITO(DEL); EMITO(DEL); IT ~ IT-1 END; 00576900 - BEGIN EMITO(DEL); EMITO(DEL); IT~IT-1 END ; 00577000 - END OF POWER CASE STATEMENT; 00577100 - END; 00577200 - END; 00577300 - END; 00577400 - IP ~ IP-1; 00577500 - END; 00577600 - EXPRESLT ~ EXPCLASS; 00577700 - STACK: 00577800 - PR[IP~IP+1] ~ PREC; 00577900 - OPST[IP] ~ OP; 00578000 - IF PREC > 0 AND PREC { 4 THEN 00578100 - BEGIN 00578200 - SCAN; LINK ~ FNEXT; 00578300 - IF NEXT = PLUS THEN GO TO LOOP; 00578400 - IF NEXT ! MINUS THEN GO TO NOSCAN; 00578500 - PREC ~ 8; OP ~ 12; 00578600 - GO TO STACK; 00578700 - END; 00578800 - GO TO LOOP; 00578900 - XIT: IF IP ! SAVIP THEN FLOG(56); 00579000 - IP ~ SAVIP-1; 00579100 - EXPR ~ OPTYPE[IT]; 00579200 - IF OPTYPE[IT-1] ! 0 THEN FLOG(56); 00579300 - IT ~ SAVIT-1; 00579400 - EXPRESULT ~ EXPRESLT; 00579500 - EXPVALUE ~ EXPV; 00579600 - EXPLINK ~ EXPLNK; 00579700 - IF DEBUGTOG THEN FLAGROUTINE(" EXPRE","SSION ",FALSE) ; 00579800 - END EXPR; 00579900 - 00580000 -PROCEDURE FAULT (X); 00580100 - VALUE X; 00580200 - REAL X; 00580300 - BEGIN REAL LINK; LABEL XIT; 00580400 - SCAN; IF GLOBALNEXT ! LPAREN THEN BEGIN FLAG(106); GO XIT END; 00580500 - SCAN; IF GLOBALNEXT ! ID THEN BEGIN FLAG(66); GO TO XIT END; 00580600 - IF X = 1 THEN PDPRT[0,0] ~ PDPRT[0,0] & 1[44:47:1] ELSE 00580700 - PDPRT[0,0] ~ PDPRT [0,0] & 1[43 :47:1]; 00580800 - EMITOPDCLIT(41); EMITO(DUP); 00580900 - IF X = 1 THEN BEGIN EMITL(2); EMITO(XCH); EMITL(1) END 00581000 - ELSE EMITL(6); 00581100 - EMITO(LND); 00581200 - IF X = 2 THEN EMITL(3); 00581300 - EMITO(SUB); 00581400 - IF X = 2 THEN 00581500 - BEGIN EMITO(DUP); EMITL(3); EMITO(SSN) ;EMITO(EQUL); EMITL(2)00581600 - ;EMITO(BFC) ; EMITO(DEL);EMITL(2); 00581700 - END; 00581800 - LINK ~ GET(GETSPACE(FNEXT)); EMITPAIR(LINK.ADDR,ISD); 00581900 - IF X = 1 THEN EMITL(30) ELSE EMITL(25); 00582000 - EMITO(LND); EMITL(41);EMITO(STD); 00582100 - SCAN; IF GLOBALNEXT ! RPAREN THEN FLAG(108); 00582200 - SCAN; 00582300 - XIT: 00582400 - END FAULT; 00582500 -PROCEDURE SUBREF; 00582600 -BEGIN REAL LINK,INFC; 00582700 - REAL ACCIDENT; 00582800 - LABEL XIT; 00582900 -IF DEBUGTOG THEN FLAGROUTINE(" SUB","REF ",TRUE ) ; 00583000 -IF TSSEDITOG THEN IF NAME="ZIP " AND NOT DCINPUT THEN TSSED(NAME,3) ; 00583100 - IF NAME = "EXIT " THEN 00583200 - BEGIN 00583300 - RETURNFOUND ~ TRUE; 00583400 - EMITL(1); 00583500 - EMITPAIR(16,STD); 00583600 - EMITPAIR(10,KOM); 00583700 - EMITPAIR( 5, KOM); 00583800 - PUT(FNEXT+1, "......"); 00583900 - SCAN; 00584000 - END ELSE IF NAME="ZIP " AND NOT DCINPUT THEN 00584100 - BEGIN 00584200 - EMITO(MKS); 00584300 - EMITL(0); EMITL(0); % DUMMY FILE AND FORMAT 00584400 - EMITPAIR(-1,SSN); 00584500 - EMITB(-1,FALSE); LADR1~LAX; ADJUST; DESCREQ~FALSE; 00584600 - IF ADR } 4085 THEN BEGIN ADR~ADR+1; SEGOVF END; 00584700 - ACCIDENT~PRGDESCBLDR(0,0,ADR.[36:10]+1,NSEG); 00584800 - EMITOPDCLIT(19); 00584900 - EMITO(GFW); 00585000 - LISTART ~ ADR&NSEG[TOSEGNO]; ADJUST;SCAN; 00585100 - IF GLOBALNEXT!LPAREN THEN BEGIN FLAG(106);GO TO XIT END; 00585200 - SCAN; IF GLOBALNEXT!ID THEN BEGIN FLAG(66); GO TO XIT END; 00585300 - LINDX ~ FNEXT; SCAN; XTA ~ GET(LINDX+1); 00585400 - IF GLOBALNEXT!RPAREN THEN BEGIN FLAG(108); GO TO XIT END; 00585500 - LINDX ~ GETSPACE(LINDX); 00585600 - IF T~(LINFA~GET(LINDX)).CLASS!ARRAYID THEN 00585700 - BEGIN FLAG(66); GO TO XIT END; 00585800 - IF XREF THEN ENTERX(XTA,0&LINFA[15:15:9]); 00585900 - EMITPAIR(LADDR~LINFA.ADDR,LOD); 00586000 - IF BOOLEAN(LINFA.FORMAL) THEN 00586100 - BEGIN 00586200 - IF T ~ GET(LINDX+2)<0 THEN EMITOPDCLIT(T.SIZE) 00586300 - ELSE EMITNUM(T.SIZE); EMITOPDCLIT(LADDR-1); EMITO(CTF) END 00586400 - ELSE EMITNUM(GET(LINDX+2).BASENSIZE); EMITL(18); EMITO(STD);; 00586500 - EMITL(LINFA.CLASNSUB&0[44:47:1]); EMITL(19); EMITO(STD); 00586600 - BRANCHLIT(LISTART,TRUE); EMITL(19); EMITO(STD); 00586700 - EMITO(RTS); ADJUST; 00586800 - EMITL(1); EMITO(CHS); EMITL(19); EMITO(STD); 00586900 - EMITDESCLIT(19); EMITO(RTS); FIXB(LADR1); DESCREQ~FALSE; 00587000 - EMITPAIR(ACCIDENT,LOD); EMITOPDCLIT(7); EMITO(FTF); 00587100 - EMITL(6); % EDITCODE 6 FOR ZIP 00587200 - EMITV(NEED(".FTOUT",INTRFUNID)); SCAN 00587300 - END ELSE IF NAME = "OVERFL" THEN FAULT(2) 00587400 - ELSE IF NAME = "DVCHK " THEN FAULT(1) 00587500 - ELSE 00587600 - BEGIN 00587700 - LINK ~ NEED(NAME, SUBRID); 00587800 - IF XREF THEN ENTERX(XTA,0&GET(LINK)[15:15:5]); 00587900 - EMITO(MKS); 00588000 - SCAN; 00588100 - IF GLOBALNEXT = LPAREN THEN 00588200 - BEGIN PARAMETERS(LINK); SCAN END ELSE 00588300 - IF NOT BOOLEAN((INFC~GET(LINK+2)).[1:1]) THEN 00588400 - PUT(LINK+2,-INFC) ELSE 00588500 - IF INFC.NEXTRA ! 0 THEN 00588600 - BEGIN XTA ~ GET(LINK+1); FLAG(28) END; 00588700 - EMITV(LINK); 00588800 - END; 00588900 - XIT: 00589000 -IF DEBUGTOG THEN FLAGROUTINE(" SUB","REF ",FALSE) ; 00589100 -END SUBREF; 00589200 - 00589300 -PROCEDURE DECLAREPARMS(FNEW); VALUE FNEW; REAL FNEW; 00589400 -BEGIN 00589500 - REAL I, T, NLABELS, INFA, INFB, INFC; 00589600 -IF DEBUGTOG THEN FLAGROUTINE("DECLAR","EPARMS",TRUE ) ; 00589700 - INFA ~ GET(FNEW); 00589800 - IF INFA.SEGNO ! 0 THEN BEGIN XTA ~ NNEW; FLAG(25) END; 00589900 - INFA.SEGNO ~ NSEG; PUT(FNEW,INFA); 00590000 - ENTRYLINK[ELX] ~ 0 & FNEW[TOLINK] & NEXTSS[TOADDR]; 00590100 - FOR I ~ 1 STEP 1 UNTIL PARMS DO 00590200 - BEGIN 00590300 - EXTRAINFO[NEXTSS.IR,NEXTSS.IC] ~ PARMLINK[I]; 00590400 - NEXTSS ~ NEXTSS-1; 00590500 - IF T ~ PARMLINK[I] ! 0 THEN 00590600 - BEGIN 00590700 - GETALL(T,INFA,INFB,INFC); 00590800 - IF BOOLEAN(INFA .FORMAL) THEN 00590900 - BEGIN 00591000 - IF INFA.SEGNO = ELX THEN 00591100 - BEGIN XTA ~ INFB ; FLAG(26) END; 00591200 - END ELSE IF (INFA < 0 AND INFA.ADDR < 1024) OR BOOLEAN(INFA.CE)00591300 - THEN BEGIN XTA ~ INFB; FLAG(107) END; 00591400 - INFA ~ INFA & 1[TOFORMAL] & ELX[TOSEGNO]; 00591500 - INFC .BASE ~ I; 00591600 - PUT(T,INFA); PUT(T+2,INFC); 00591700 - END ELSE NLABELS ~ NLABELS+1; 00591800 - END; 00591900 - IF NLABELS > 0 THEN 00592000 - BEGIN ENTRYLINK[ELX ].CLASS ~ NLABELS; 00592100 - IF LABELMOM=0 THEN BEGIN BUMPLOCALS; LABELMOM~LOCALS+1536 END; 00592200 - END; 00592300 - GETALL(FNEW,INFA,INFB,INFC); 00592400 - IF BOOLEAN(INFC.[1:1]) THEN 00592500 - BEGIN 00592600 - IF INFC.NEXTRA ! PARMS THEN 00592700 - BEGIN XTA ~ INFB; FLOG(41); 00592800 - PARMS ~ INFC.NEXTRA; 00592900 - END; 00593000 - T ~ INFC.ADINFO; 00593100 - FOR I ~ 1 STEP 1 UNTIL PARMS DO 00593200 - IF NOT(PARMLINK[I] = 0 EQV 00593300 - EXTRAINFO[(T+I-1).IR,(T+I-1).IC].CLASS = LABELID) THEN 00593400 - BEGIN IF PARMLINK[I] = 0 THEN XTA ~ "* " 00593500 - ELSE XTA ~ GET(PARMLINK[I]+1); 00593600 - FLAG(40); 00593700 - END; 00593800 - END 00593900 - ELSE 00594000 - BEGIN 00594100 - IF PARMS = 0 THEN INFC ~ -INFC ELSE 00594200 - INFC ~ -(INFC & PARMS[TONEXTRA] 00594300 - & NEXTEXTRA[TOADINFO]); 00594400 - PUT(FNEW+2,INFC); 00594500 - FOR I ~ 1 STEP 1 UNTIL PARMS DO 00594600 - BEGIN 00594700 - EXTRAINFO[NEXTEXTRA.IR,NEXTEXTRA.IC] ~ 0 & 00594800 - (IF PARMLINK[I] = 0 THEN LABELID ELSE 0)[TOCLASS]; 00594900 - NEXTEXTRA ~ NEXTEXTRA+1; 00595000 - END; 00595100 - END; 00595200 - IF ELX ~ ELX+1 > MAXEL THEN BEGIN FLAG(128); ELX ~ 0 END; 00595300 -IF DEBUGTOG THEN FLAGROUTINE("DECLAR","EPARMS",FALSE) ; 00595400 -END DECLAREPARMS; 00595500 -PROCEDURE IOLIST(LEVEL); REAL LEVEL; 00595600 -BEGIN ALPHA LADR2,T; 00595700 -BOOLEAN A; 00595800 -INTEGER INDX,I,BDLINK,NSUBS; 00595900 - LABEL ROUND,XIT,ERROR,LOOP,SCRAM; 00596000 -INTEGER STREAM PROCEDURE CNTNAM(IDEN); VALUE IDEN; 00596100 -BEGIN LABEL XIT; 00596200 - SI ~ LOC IDEN; SI ~ SI + 3; TALLY ~ 1; 00596300 - 5(IF SC = " " THEN JUMP OUT TO XIT;SI ~ SI+1;TALLY ~ TALLY+1); 00596400 - XIT: CNTNAM ~ TALLY; 00596500 -END CNTNAM; 00596600 -IF DEBUGTOG THEN FLAGROUTINE(" IOL","IST ",TRUE ) ; 00596700 -ROUND: DESCREQ ~ TRUE; 00596800 - LOCALNAME ~ FALSE; 00596900 -IF GLOBALNEXT = SEMI THEN GO TO XIT; 00597000 -IF GLOBALNEXT = STAR THEN 00597100 - BEGIN IF NOT NAMEDESC THEN 00597200 - TV ~ ENTER(0&LISTSID[TOCLASS],LISTID~LISTID+1); 00597300 - LOCALNAME ~ TRUE; NAMEDESC ~ TRUE; SCAN; 00597400 - END; 00597500 -IF GLOBALNEXT = ID THEN 00597600 -BEGIN LINDX ~ FNEXT; 00597700 - SCAN; XTA ~ GET(LINDX+1); 00597800 - IF GLOBALNEXT = EQUAL THEN %RETURN TO CALLER 00597900 - BEGIN IF (LINFA~GET(GETSPACE(LINDX))).CLASS ! VARID THEN FLAG(50);00598000 - SCRAM: IF (LEVEL ~ LEVEL-1) < 0 THEN FLOG(97); 00598100 - GO TO XIT; 00598200 - END; 00598300 - 00598400 - IF DATASTMTFLAG AND SPLINK } 0 THEN %DECLARE OWN 00598500 - BEGIN 00598600 - IF BOOLEAN(GET(LINDX).FORMAL) THEN FLAG(147); 00598700 - IF SPLINK>1 THEN 00598800 - IF GET(LINDX).ADDR>1023 THEN FLAG(174); 00598900 - LINDX ~ GETSPACE(-LINDX); 00599000 - IF BOOLEAN(GET(LINDX).EQ) THEN FLAG(168); 00599100 - END ELSE LINDX ~ GETSPACE(LINDX); 00599200 - IF T ~ (LINFA~GET(LINDX)).CLASS > VARID THEN FLAG(50); 00599300 - IF XREF THEN ENTERX(XTA,C2&LINFA[15:15:9]); 00599400 - IF GLOBALNAME OR LOCALNAME THEN 00599500 - IF NAMEIND~ NAMEIND+1 GTR LSTMAX THEN FLOG(161) 00599600 - ELSE NAMLIST[NAMEIND] ~ XTA & CNTNAM(XTA)[9:45:3]; 00599700 - IF T = ARRAYID THEN 00599800 - IF GLOBALNEXT ! LPAREN THEN 00599900 - BEGIN IF SPLINK ! 1 THEN 00600000 - BEGIN 00600100 - EMITL(0); 00600200 - EMITPAIR(LADDR ~ LINFA.ADDR,LOD); 00600300 - EMITO(FTC); 00600400 - EMITDESCLIT(2); 00600500 - EMITO(INX); 00600600 - EMITO(LOD); 00600700 - END ELSE EMITPAIR(LADDR-LINFA.ADDR,LOD); 00600800 - NSUBS ~ (T ~ GET (LINDX+2)).NEXTRA; 00600900 - IF GLOBALNAME OR LOCALNAME THEN 00601000 - BEGIN 00601100 - IF NSUBS GTR SAVESUBS THEN SAVESUBS ~ NSUBS; 00601200 - IF NSUBS GTR NAMLIST[0] THEN NAMLIST[0] ~ NSUBS; 00601300 - NAMLIST[NAMEIND].[1:8] ~ NSUBS; 00601400 - INDX ~ -1; 00601500 - INFA ~ GET(NEED(".SUBAR",BLOCKID)).ADDR; 00601600 - BDLINK ~ T.ADINFO+1; 00601700 - END; 00601800 - IF BOOLEAN (LINFA.FORMAL) THEN 00601900 - BEGIN 00602000 - IF T LSS 0 THEN EMITOPDCLIT(T.SIZE) 00602100 - ELSE EMITNUM(T.SIZE); 00602200 - EMITOPDCLIT(LADDR-1); 00602300 - EMITO(CTF); 00602400 - END ELSE EMITNUM(T.BASENSIZE); 00602500 - IF GLOBALNAME OR LOCALNAME THEN 00602600 - FOR I ~ 1 STEP 1 UNTIL NSUBS DO 00602700 - BEGIN IF T ~ EXTRAINFO[(BDLINK~BDLINK-1).IR, 00602800 - BDLINK.IC] LSS 0 THEN EMITOPDCLIT(T) 00602900 - ELSE EMITNUM(T); 00603000 - EMITNUM(INDX ~ INDX+1); 00603100 - EMITDESCLIT(INFA); 00603200 - EMITO(STD); 00603300 - END; 00603400 - EMITL(18); EMITO(STD); 00603500 - END ELSE 00603600 - BEGIN SCAN; 00603700 - A ~(IF GLOBALNAME OR LOCALNAME 00603800 - THEN SUBSCRIPTS(LINDX,4) ELSE SUBSCRIPTS(LINDX,2)); 00603900 - SCAN; 00604000 - END 00604100 - ELSE EMITN(LINDX); 00604200 - IF GLOBALNAME OR LOCALNAME THEN 00604300 - BEGIN EMITOPDCLIT(18); EMITNUM(NAMEIND); 00604400 - EMITD(43,DIA); EMITD(3,DIB); EMITD(15,TRB); 00604500 - EMITL(18); EMITO(STD); 00604600 - END; 00604700 - EMITL(LINFA.CLASNSUB&0[44:47:1]); 00604800 - EMITL(20); EMITO(STD); 00604900 - IF ADR > 4083 THEN 00605000 - BEGIN ADR~ADR+1; SEGOVF END ; 00605100 - BRANCHLIT(LISTART,TRUE); 00605200 - EMITL(19); EMITO(STD); 00605300 - EMITO(RTS); ADJUST; 00605400 - GO TO LOOP; 00605500 -END; 00605600 -IF GLOBALNEXT = LPAREN THEN % RECURSE ON ( 00605700 -BEGIN EMITB(-1,FALSE); 00605800 - ADJUST; 00605900 - LADR2 ~ (ADR + 1)&LAX[TOADDR]&NSEG[TOSEGNO]; 00606000 - SCAN; LEVEL ~ LEVEL + 1; 00606100 - IOLIST(LEVEL); 00606200 - IF GLOBALNEXT ! EQUAL THEN % PHONY IMP DO 00606300 - BEGIN BRANCHES[T ~ LADR2.ADDR] ~ BRANCHX; 00606400 - BRANCHX ~ T; 00606500 - IF GLOBALNEXT ! RPAREN THEN GO TO ERROR; 00606600 - SCAN; GO TO LOOP; 00606700 - END; 00606800 - IF XREF THEN ENTERX(GET(LINDX+1),1&LINFA[15:15:9]); 00606900 - IF LINFA.SUBCLASS > REALTYPE THEN 00607000 - BEGIN XTA ~ GET(LINDX + 1); 00607100 - FLAG(84); 00607200 - END; 00607300 - EMITB(-1,FALSE); 00607400 - LADR3 ~ LAX; 00607500 - FIXB(LADR2.ADDR); 00607600 - DESCREQ ~ FALSE; 00607700 - SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(102); % INITIAL VALUE 00607800 - EMITN(LINDX); EMITO(STD); 00607900 - EMITB(LADR2,FALSE); 00608000 - IF GLOBALNEXT ! COMMA THEN GO TO ERROR; 00608100 - ADJUST; 00608200 - LADR4 ~ (ADR + 1)&NSEG[TOSEGNO]; 00608300 - SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(102) ELSE EMITO(GRTR); 00608400 - EMITB(LADR2,TRUE); 00608500 - EMITB(-1,FALSE); 00608600 - LADR5 ~ LAX; 00608700 - FIXB(LADR3); 00608800 - IF GLOBALNEXT ! COMMA THEN EMITL(1) 00608900 - ELSE BEGIN SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(102); END; 00609000 - EMITV(LINDX); EMITO(ADD); 00609100 - EMITN(LINDX); EMITO(SND); 00609200 - EMITB(LADR4,FALSE); 00609300 - FIXB(LADR5); 00609400 - IF GLOBALNEXT = RPAREN THEN SCAN ELSE GO TO ERROR; 00609500 - LOOP: IF GLOBALNEXT = SEMI OR GLOBALNEXT = SLASH THEN GO TO XIT; 00609600 - IF GLOBALNEXT = RPAREN THEN GO TO SCRAM; 00609700 - IF GLOBALNEXT = COMMA THEN 00609800 - BEGIN SCAN; 00609900 - IF GLOBALNEXT = SEMI THEN GO TO ERROR; 00610000 - GO TO ROUND; 00610100 - END; 00610200 - ERROR: XTA ~ NAME; 00610300 - FLAG(94); 00610400 - IF GLOBALNEXT = SEMI THEN GO TO XIT; 00610500 - SCAN; 00610600 - IF GLOBALNEXT = ID THEN GO TO ROUND; 00610700 - ERRORTOG ~ TRUE; GO TO XIT; 00610800 - END; 00610900 - IF GLOBALNEXT = RPAREN THEN GO TO SCRAM ELSE 00611000 - IF GLOBALNEXT ! SLASH THEN GO TO ERROR; 00611100 - XIT: IF DEBUGTOG THEN FLAGROUTINE(" IOL","IST ",FALSE) ; 00611200 - END IOLIST; 00611300 - INTEGER PROCEDURE FILECHECK(FILENAME,FILETYPE); 00611400 - VALUE FILENAME,FILETYPE; ALPHA FILENAME; INTEGER FILETYPE; 00611500 - BEGIN COMMENT THIS PROCEDURE RETURNS THE PRT CELL ALLOCATED TO 00611600 - THE FILE FILENAME... A CELL IS CREATED IF NONE EXISTS; 00611700 - IF DEBUGTOG THEN FLAGROUTINE(" FILEC","HECK ",TRUE); 00611800 - EMITL(IF NOTOPIO THEN 2 ELSE 5); % FOR IO DESCRIPTOR 00611900 - IF T ~ GLOBALSEARCH(FILENAME) = 0 THEN % FILE UNDECLARED 00612000 - BEGIN MAXFILES ~ MAXFILES + 1; 00612100 - BUMPPRT; 00612200 - I ~ GLOBALENTER(-0&(FILECHECK~PRTS)[TOADDR] 00612300 - &FILEID[TOCLASS],FILENAME)+2; 00612400 - INFO[I.IR,I.IC]. LINK ~ FILETYPE; 00612500 - END ELSE % FILE ALREADY EXISTS 00612600 - FILECHECK ~ GET(T).ADDR; 00612700 - IF DEBUGTOG THEN FLAGROUTINE(" FILEC","HECK ",FALSE) ; 00612800 - END FILECHECK; 00612900 - PROCEDURE INLINEFILE; 00613000 - BEGIN COMMENT THIS PROCEDURE GENERATES THE CODE TO BRING UP THE FILE...00613100 - IF THE FILE IS AN INTEGER THEN FILECHECK IS CALLED, IF THE FILE 00613200 - IS NOT AN INTEGER THEN IN-LINE CODE IS GENERATED FOR OBJECT TIME 00613300 - ANALYSIS; 00613400 - REAL TEST; 00613500 - COMMENT IF LAST INSTRUCTION WAS A LIT CALL THEN WE HAVE SEEN REFERENCE 00613600 - TO AN INTEGER FILE ID; 00613700 - IF DEBUGTOG THEN FLAGROUTINE(" INLIN","EFILE ",TRUE ) ; 00613800 - TEST~ADR ; 00613900 - IF EXPR(TRUE)>REALTYPE THEN FLAG(102) 00614000 - ELSE IF EXPRESULT=NUMCLASS THEN 00614100 - BEGIN XTA~NNEW ; 00614200 - IF EXPVALUE}1.0@5 OR EXPVALUE{0.5 THEN FLAG(33) 00614300 - ELSE BEGIN 00614400 - IF ADR LSTMAX THEN GO TO NUL; 00633400 - WSA[TOTAL] ~ I ~ 0; GO TO ROUND; 00633500 - END ELSE GO TO ROUND ELSE GO TO NUL1; 00633600 - END; 00633700 - IF NOT STRINGF THEN 00633800 - IF SLCNT > 0 THEN 00633900 - IF T = "/" THEN BEGIN SLCNT ~ SLCNT+1; GO TO ROUND; END 00634000 - ELSE 00634100 - BEGIN WSA[TOTAL] ~ 0 & SLCNT[TOREPEAT] & SLASH[TOCODE]; 00634200 - IF NOT STR THEN 00634300 - IF REPEAT < 16 AND WSA[TOTAL-1].[42:6] = 0 THEN 00634400 - WSA[TOTAL~TOTAL-1] ~ WSA[TOTAL] & SLCNT[42:44:4] 00634500 - & 1[46:47:1]; 00634600 - COMMAS~DOLLARS~BOOLEAN(SLCNT~0); NCR~BACKNCR(NCR) ; 00634700 - GO TO NUL1; 00634800 - END; 00634900 - IF NOT QF THEN IF T = """ THEN IF STRINGF ~ NOT STRINGF THEN 00635000 - BEGIN IF CODE > 4 THEN BEGIN STRINGF ~ FALSE; 00635100 - NCR ~ BACKNCR(NCR); GO TO ENDER END; 00635200 - SAVTOTAL ~ TOTAL; J~0; I~3; QF ~ TRUE; 00635300 - WSA[TOTAL] ~ 0 & HPHASE[TOCODE]; 00635400 - GO TO ROUND; 00635500 - END ELSE 00635600 - BEGIN 00635700 - WSA[SAVTOTAL] ~ WSA[SAVTOTAL] & J[TOREPEAT]; 00635800 - IF I = 0 THEN TOTAL ~ TOTAL - 1; 00635900 - CODE ~ HPHASE; 00636000 - GO TO ENDER; 00636100 - END; 00636200 - IF STRINGF THEN 00636300 - BEGIN 00636400 - STORECHAR(WSA[TOTAL],I,T); 00636500 - J ~ J + 1; QF ~ FALSE; 00636600 - IF I ~ I+1 = 8 THEN 00636700 - BEGIN 00636800 - IF TOTAL ~ TOTAL +1> LSTMAX THEN GO TO NUL; 00636900 - I ~ WSA[TOTAL] ~ 0; 00637000 - END; 00637100 - GO TO ROUND; 00637200 - END; 00637300 -CASE T OF 00637400 -BEGIN 00637500 - BEGIN ZF ~ TRUE; % 0 00637600 - NUM: DECIMAL ~ 10 | DECIMAL + T; 00637700 - IF ASK THEN 00637800 - BEGIN FLAG(183); %111-00637900 -FL: DO BEGIN NCR~GETCHAR(NCR,T); XTA~T&XTA[12:18:30] END 00638000 - UNTIL T!"*" AND T>9 AND T!" " ; 00638100 - NCR~BACKNCR(NCR); XTA~BLANKS&XTA[18:12:30] ; 00638200 - END 00638300 - ELSE 00638400 - IF DECIMAL>4090 THEN BEGIN FLAG(172); DECIMAL~1 END ; 00638500 - IF CODE = 0 THEN REPEAT ~ DECIMAL 00638600 - ELSE IF PF THEN BEGIN IF DECIMAL>WIDTH AND WIDTH!0 AND CODE! 00638700 - VPHRASE THEN FLAG(129) END ELSE WIDTH~DECIMAL ; 00638800 - GO TO ROUND; 00638900 - END; 00639000 - GO TO NUM; GO TO NUM; GO TO NUM; % 1 2 3 00639100 - GO TO NUM; GO TO NUM; GO TO NUM; % 4 5 6 00639200 - GO TO NUM; GO TO NUM; GO TO NUM; % 7 8 9 00639300 - ; ; ; ; ; ; % # @ Q : > } 00639400 - BEGIN PLUSP ~ TRUE; GO TO ROUND; END; % + 00639500 - BEGIN CODE ~ APHASE; GO TO NOEND END; % A 00639600 - ; % B 00639700 - BEGIN CODE ~ CPHASE; GO TO NOEND END; % C 00639800 - BEGIN CODE ~ DPHASE; GO TO NOEND END; % D 00639900 - BEGIN CODE ~ EPHASE; GO TO NOEND END; % E 00640000 - BEGIN CODE ~ FPHASE; GO TO NOEND END; % F 00640100 - BEGIN CODE ~ GPHASE; GO TO NOEND END; % G 00640200 - BEGIN IF REPEAT = 0 THEN FLOG(130); % H 00640300 - IF ASK THEN BEGIN FLOG(32 ); GO SEMIC END ; 00640400 - HF ~ TRUE; I ~ 3; CODE ~ HPHASE; 00640500 - WSA[TOTAL] ~ 0 & HPHASE[TOCODE] & REPEAT[TOREPEAT]; 00640600 - GO TO ROUND; 00640700 - END; 00640800 - BEGIN CODE ~ IPHASE; GO TO NOEND END; % I 00640900 - BEGIN IF CODE < 11 OR CODE=15 THEN FLOG(134); % . 00641000 - IF CODE=0 OR PF THEN FLOG(32) ; 00641100 - PF~TRUE; DECIMAL~0; ASK~ZF~FALSE ; 00641200 - GO TO ROUND; 00641300 - END; 00641400 - GO TO RP; % [ 00641500 - ; % & 00641600 - LP: 00641700 - BEGIN IF CODE ! 0 THEN FLOG(32); % ( 00641800 - IF ASK THEN REPEAT~4095; IF REPEAT=0 AND ZF THEN FLAG(173) ;00641900 - NAMLIST[SAVLASTLP ~ PARENCT ~ PARENCT+1] ~ 0 & TOTAL[TOWIDTH]00642000 - &(IF REPEAT{0 AND PARENCT>1 THEN 1 ELSE REPEAT)[TOREPEAT] ; 00642100 - IF ASK THEN 00642200 - BEGIN ASK~VRB~FALSE ; 00642300 - WSA[TOTAL]~32&LPPHRASE[TOCODE]&4095[TOREPEAT] ; 00642400 - IF (TOTAL~TOTAL+1)>LSTMAX THEN GO NUL ; 00642500 - END ; 00642600 - ZF~BOOLEAN(REPEAT~DECIMAL~0) ; 00642700 - STR ~ TRUE; 00642800 - GO TO ROUND1; 00642900 - END; 00643000 - ; ; ; % < ~ | 00643100 - BEGIN CODE~JPHASE; WIDTH~-1; GO NOEND END ; % J 00643200 - BEGIN % K 00643300 - IF COMMAS OR CODE!0 THEN BEGIN FLAG(32); COMMAS~TRUE END 00643400 - ELSE BEGIN COMMAS~TRUE ; 00643500 -KK: DO BEGIN NCR~GETCHAR(NCR,T); XTA~T&XTA[12:18:30] END 00643600 - UNTIL T!" " ; 00643700 - IF (T<17 OR (T>25 AND T<33) OR (T>42 AND T<50) OR T>57) 00643800 - THEN BEGIN FLAG(32) ; 00643900 - IF T="*" OR T<10 THEN BEGIN DECIMAL~1; GO FL END ; 00644000 - END ; 00644100 - NCR~BACKNCR(NCR); XTA~BLANKS&XTA[18:12:30] ; 00644200 - END ; 00644300 - GO ROUND ; 00644400 - END OF K ; 00644500 - BEGIN CODE ~ LPHASE; GO TO NOEND; END; % L 00644600 - ; ; % M N 00644700 - BEGIN CODE ~ OPHASE; GO TO NOEND; END; % O 00644800 - BEGIN WSA[TOTAL] ~ 0 & PPHASE[TOCODE] % P 00644900 - & REAL(VRB)[42:47:1] 00645000 - & REAL(MINUSP)[TOSIGN] & REPEAT[TOWIDTH]&1[TOREPEAT]; 00645100 - MINUSP ~ PLUSP ~ FALSE; 00645200 - IF (DECIMAL = 0 AND NOT ZF) THEN FLOG(131); 00645300 - GO TO NUL1; 00645400 - END; 00645500 - ; ; % Q R 00645600 - BEGIN IF DOLLARS OR CODE!0 THEN FLAG(32) % $ 00645700 - ELSE BEGIN DOLLARS~TRUE; GO KK END ; 00645800 - DOLLARS~TRUE; GO ROUND ; 00645900 - END OF DOLLAR SIGN ; 00646000 - IF NOT ASK THEN % * 00646100 - BEGIN 00646200 - IF ZF OR DECIMAL NEQ 0 THEN FLAG(183); DECIMAL:=4095; %111-00646300 - IF CODE=0 THEN REPEAT~DECIMAL 00646400 - ELSE IF NOT PF THEN WIDTH~DECIMAL ; 00646500 - VRB := ASK := LISTEL := TRUE; GO ROUND; %101-00646600 - END ELSE BEGIN DECIMAL:=4095; FLAG(183); GO FL END ; %111-00646700 - BEGIN MINUSP ~ TRUE; GO TO ROUND; END; % - 00646800 - RP: 00646900 - BEGIN IF FIELD THEN BEGIN NCR ~ BACKNCR(NCR); % ) 00647000 - GO TO ENDER; END; 00647100 - IF DECIMAL ! 0 THEN FLAG(32); 00647200 - I ~ IF PARENCT = 1 THEN IF SAVLASTLP > 1 THEN 2 ELSE 1 00647300 - ELSE PARENCT; 00647400 - WSA[TOTAL]~(J~NAMLIST[I])&(TOTAL+1-J~J.[18:12])[TOLINK] 00647500 - & (IF PARENCT ~ PARENCT-1 = 0 THEN 77 ELSE 0)[TODECIMAL]; 00647600 - IF WSA[J].[1:5]=LPPHRASE AND PARENCT!0 THEN 00647700 - BEGIN WSA[J].[18:12]~TOTAL-J; WSA[TOTAL].[18:12]~TOTAL-J ;00647800 - END ; 00647900 - NAMLIST[I].[6:12] ~ 0; 00648000 - CODE ~ HPHASE; 00648100 - GO TO NUL1; 00648200 - END; 00648300 - ; ; % ; LEQ 00648400 - GO TO ROUND; % BLANKS 00648500 - BEGIN SLCNT ~ 1; % / 00648600 -SL: IF CODE=0 THEN IF ASK OR ZF OR DECIMAL!0 THEN 00648700 - BEGIN FLAG(32); ASK~ZF~BOOLEAN(DECIMAL~0) END ; 00648800 - IF CODE<5 THEN IF T="," THEN GO ROUND1 ELSE GO ROUND ELSE GO 00648900 - ENDER ; 00649000 - END; 00649100 - ; % S 00649200 - BEGIN IF REPEAT ! 0 THEN FLAG(32); % T 00649300 - CODE ~ TPHASE; 00649400 - GO TO NOEND; 00649500 - END; 00649600 - ; % U 00649700 - BEGIN VRB~TRUE; CODE~VPHRASE; WIDTH~-1; GO NOEND END ; % V 00649800 - ; % W 00649900 - BEGIN IF REPEAT = 0 THEN FLOG(130); % X 00650000 - IF STR THEN 00650100 - NEWWD: WSA[TOTAL] ~ 0 & XPHASE[TOCODE] & REPEAT[TOWIDTH] 00650200 - & 1[TOREPEAT] 00650300 - & REAL(VRB)[42:47:1] 00650400 - ELSE 00650500 - BEGIN 00650600 - IF (J~WSA[TOTAL-1]).[42:6]>0 OR (I~J.[1:5])=RTPARN 00650700 - OR (REPEAT}32 AND I!XPHASE) THEN GO NEWWD ; 00650800 - IF I=XPHASE AND (I~J.[18:12]+REPEAT){4090 THEN 00650900 - WSA[TOTAL~TOTAL-1] ~ J & I[TOWIDTH] 00651000 - ELSE IF REPEAT } 32 THEN GO TO NEWWD 00651100 - ELSE WSA[TOTAL~TOTAL-1] ~ J & REPEAT[TONUM] 00651200 - & 1[TOCNTRL]; 00651300 - END; 00651400 - GO TO NUL1; 00651500 - END; 00651600 - ; ; % Y Z 00651700 - GO SL ; % , 00651800 - GO TO LP; % % 00651900 - ; ; ; % ! = ] " 00652000 -END OF CASE STATEMENT; 00652100 -FLOG(132); % ILLEGAL CHARACTER; 00652200 -GO TO FALL; 00652300 -ENDER: IF CODE > 4 THEN 00652400 - BEGIN IF WIDTH=0 THEN FLAG(130) ; 00652500 - IF CODE=VPHRASE THEN 00652600 - BEGIN 00652700 - IF WIDTH=-1 THEN IF PF THEN FLAG(130)ELSE WIDTH~ 00652800 - DECIMAL~4094 ELSE 00652900 - IF NOT PF THEN DECIMAL~4094 ; 00653000 - END 00653100 - ELSE 00653200 - IF CODE > 10 AND CODE ! 15 THEN 00653300 - IF (DECIMAL = 0 AND NOT ZF) OR NOT PF THEN FLAG(133) 00653400 - ELSE ELSE DECIMAL ~ 0; 00653500 - IF REPEAT=0 THEN REPEAT~1 ; 00653600 - IF WIDTH=-1 THEN WIDTH~0 ; 00653700 - WSA[TOTAL] ~ 0 & CODE[TOCODE] & WIDTH[TOWIDTH] 00653800 - & REPEAT[TOREPEAT] & DECIMAL[TODECIMAL] 00653900 - & REAL(COMMAS) [44:47:1] 00654000 - & REAL(VRB)[42:47:1] 00654100 - & REAL(DOLLARS)[45:47:1]; 00654200 - END ELSE IF DECIMAL ! 0 THEN FLAG(32); 00654300 -NUL1: IF PLUSP THEN FLAG(164); 00654400 - IF CODE!VPHRASE THEN 00654500 - BEGIN 00654600 - IF DOLLARS AND(CODE < 9 OR CODE > 14) THEN FLAG(166); 00654700 - IF COMMAS AND NOT(CODE = 10 OR CODE = 12 OR CODE = 9) 00654800 - THEN FLAG(165); 00654900 - END; 00655000 - VRB~ 00655100 - ERRORTOG ~ FIELD ~ PF ~ PLUSP ~ DOLLARS ~ COMMAS ~ STR ~ FALSE; 00655200 - IF CODE = HPHASE THEN STR ~ TRUE; 00655300 - CODE ~ REPEAT ~ WIDTH ~ 0; 00655400 - XTA ~ BLANKS; 00655500 - GO TO FALL; 00655600 -NOEND: IF FIELD THEN FLAG(32); 00655700 - IF CODE ! TPHASE THEN LISTEL ~ TRUE ELSE REPEAT ~ 1; 00655800 - IF REPEAT=0 AND ZF THEN FLAG(173) ; 00655900 - FIELD ~ TRUE; 00656000 -FALL: IF MINUSP THEN BEGIN FLAG(32); MINUSP ~ FALSE END; 00656100 - ASK~ZF~FALSE ; 00656200 -NUL: DECIMAL ~ 0; 00656300 - IF PARENCT = 0 THEN BEGIN SCN ~ 1; GO TO SEMIC END; 00656400 - IF CODE < 5 THEN 00656500 - IF TOTAL ~ TOTAL+1 > LSTMAX THEN 00656600 - BEGIN FLOG(78);TOTAL ~ TOTAL-2; GO TO SEMIC; END; 00656700 -GO TO ROUND; 00656800 -NOPLACE: IF(DCINPUT OR FREEFTOG) AND (STRINGF OR HF) THEN FLOG(150); 00656900 - IF TSSEDITOG THEN IF (STRINGF OR HF) AND NOT DCINPUT 00657000 - THEN TSSED(XTA,1); 00657100 - IF CONTINUE THEN IF READACARD THEN 00657200 - BEGIN IF LISTOG THEN PRINTCARD; GO TO ROUND; END; 00657300 -SCN ~ 0; NEXT ~ SEMI; 00657400 -SEMIC: 00657500 -IF SCN = 1 THEN SCAN; 00657600 -IF STRINGF THEN FLAG(22); 00657700 -IF NOT LISTEL THEN WSA[0] ~ 0; 00657800 -IF PARENCT ! 0 THEN FLAG(IF PARENCT < 0 THEN 9 ELSE 8); 00657900 -IF D ! 0 THEN PRTSAVER(D,TOTAL+1,WSA); 00658000 -IF DEBUGTOG THEN BEGIN 00658100 - WRITE(LINE,FM) ; 00658200 - FOR I~0 STEP 1 UNTIL TOTAL DO BEGIN 00658300 - WRITE(LINE,[13]//,I,(J~WSA[I]).[1:5],J.[6:12],J.[18:12],J.[30:12], 00658400 - J.[41:1],J.[42:4],J.[42:5],J.[44:1],J.[45:1], 00658500 - J.[46:1],J.[46:2],J.[47:1]) ; 00658600 - IF J.[1:5]=2 THEN I~I+(J.[6:12]+2).[36:9] ; 00658700 - END ; 00658800 - WRITE(LINE[DBL]) ; 00658900 - END OF DEBUGSTUFF ; 00659000 -END FORMATER; 00659100 - 00659200 -PROCEDURE EXECUTABLE; 00659300 -BEGIN LABEL XIT; REAL T, J, TS, P; 00659400 - IF SPLINK < 0 THEN FLAG(12); 00659500 - IF LABL = BLANKS THEN GO TO XIT; 00659600 - IF T ~ SEARCH(XTA ~ LABL) = 0 THEN 00659700 - T ~ ENTER(-0 & LABELID[TOCLASS] & (ADR+1)[TOADDR] & 00659800 - NSEG[TOSEGNO], LABL) ELSE 00659900 - BEGIN IF (P ~ GET(T)).CLASS ! LABELID THEN 00660000 - BEGIN FLAG(144); GO TO XIT END; 00660100 - IF P < 0 THEN BEGIN FLAG(20); GO TO XIT END; 00660200 - TS ~ P.ADDR; 00660300 - WHILE TS ! 0 DO 00660400 - BEGIN J ~ GIT(TS); FIXB(TS+10000); TS ~ J END; 00660500 - PUT(T, P~-P & (ADR+1)[TOADDR] & NSEG[TOSEGNO]); 00660600 - IF (T ~ GET(T+2)).BASE ! 0 THEN 00660700 - T ~ PRGDESCBLDR(2, T.BASE, (ADR+1).[36:10], NSEG); 00660800 - END; 00660900 - IF XREF THEN ENTERX(LABL,1&LABELID[TOCLASS]); 00661000 - XIT: 00661100 -END EXECUTABLE; 00661200 - 00661300 -PROCEDURE IOCOMMAND(N); VALUE N; REAL N; 00661400 -COMMENT N COMMAND 00661500 - 0 READ 00661600 - 1 WRITE 00661700 - 2 PRINT 00661800 - 3 PUNCH 00661900 - 4 BACKSPACE 00662000 - 7 DATA; 00662100 -BEGIN LABEL XIT,SUCH,LISTER,NOFORM,FORMER,WRAP,DAAT,NF; 00662200 -LABEL LISTER1; 00662300 - BOOLEAN SUCHTOG, RDTRIN, FREEREAD; 00662400 - BOOLEAN FORMARY, NOFORMT; 00662500 - BOOLEAN NAMETOG; 00662600 -DEFINE DATATOG = DATASTMTFLAG#; 00662700 -REAL T, ACCIDENT, EDITCODE; 00662800 -REAL DATAB; 00662900 -PROCEDURE ACTIONLABELS(UNSEEN); VALUE UNSEEN; BOOLEAN UNSEEN; 00663000 -BEGIN LABEL EOF,ERR,RATA,XIT,ACTION,MULTI; 00663100 - BOOLEAN BACK,GOTERR,GOTEOF; 00663200 -IF UNSEEN THEN SCAN; 00663300 -EOF: IF GOTEOF THEN GO TO MULTI; 00663400 - IF BACK ~ NAME = "END " THEN GO TO ACTION; 00663500 -ERR: IF GOTERR THEN GO TO MULTI; 00663600 - IF NAME ! "ERR " THEN IF GOTEOF THEN 00663700 - BEGIN MULTI: XTA ~ NAME; FLOG(137); 00663800 - GO TO XIT; 00663900 - END ELSE GO TO RATA; 00664000 -ACTION: SCAN; 00664100 - IF NEXT = EQUAL THEN SCAN ELSE GO TO RATA; 00664200 - IF NEXT ! NUM THEN GO TO RATA; 00664300 - IF XREF THEN ENTERX(NAME,0&LABELID[TOCLASS]); 00664400 - IF BACK THEN NX1 ~ NAME ELSE NX2 ~ NAME; 00664500 - SCAN; IF NEXT = RPAREN THEN GO TO XIT; 00664600 - IF NEXT = COMMA THEN SCAN ELSE GO TO RATA; 00664700 - IF BACK THEN 00664800 - BEGIN BACK ~ NOT ( GOTEOF ~ TRUE); 00664900 - GO TO ERR; 00665000 - END; 00665100 - GOTERR ~ TRUE; 00665200 - GO TO EOF; 00665300 -RATA: XTA ~ NAME; FLOG(0); 00665400 -XIT: 00665500 -END ACTIONLABELS; 00665600 -IF DEBUGTOG THEN FLAGROUTINE(" IOCOM","MAND ",TRUE ); 00665700 -EODS~N!7 ; 00665800 -C2 ~ IF N = 0 OR N = 7 THEN 1 ELSE 0; 00665900 -SCAN; IF NEXT = SEMI THEN BEGIN FLOG(0); GO TO XIT END; 00666000 -IF N = 7 THEN 00666100 -BEGIN DATATOG ~ TRUE; 00666200 - IF LOGIFTOG THEN FLAG(101); 00666300 - LABL ~ BLANKS; 00666400 - IF SPLINK } 0 THEN %NOT BLOCK DATA STMT 00666500 - BEGIN 00666600 - IF DATAPRT=0 THEN BEGIN 00666700 - DATAPRT~PRTS~PRTS+1; ADJUST; 00666800 - DATASTRT~(ADR+1)&NSEG[TOSEGNO] END 00666900 - ELSE FIXB(DATALINK); 00667000 - EMITOPDCLIT(DATAPRT); EMITO(LNG); 00667100 - EMITB(-1, TRUE); DATAB ~ LAX; 00667200 - END; 00667300 - GO TO DAAT; 00667400 -END; 00667500 - EXECUTABLE; 00667600 -EMITO(MKS); 00667700 -IF N = 4 THEN 00667800 -BEGIN 00667900 - INLINEFILE; 00668000 - BEGIN EMITL(0); EMITL(0); EMITL(0); EMITL(0); 00668100 - EMITL(5); EMITL(0); EMITL(0); 00668200 - EMITV(NEED(".FBINB",INTRFUNID)); 00668300 - END; 00668400 - GO TO XIT; 00668500 -END; 00668600 -EDITCODE ~ NX1 ~ NX1 ~ 0; 00668700 -IF RDTRIN ~ 00668800 - N = 0 THEN IF NEXT = LPAREN THEN GO TO SUCH 00668900 - ELSE EMITDESCLIT(FILECHECK(".5 ",2+17|REAL %503-00669000 - (REMOTETOG))) 00669100 -ELSE IF N = 1 THEN IF NEXT ! LPAREN THEN FLAG(33) 00669200 - ELSE GO TO SUCH 00669300 - ELSE IF N = 2 THEN %503-00669400 - EMITDESCLIT(FILECHECK(".6 ",2+17|REAL %503-00669500 - (REMOTETOG))) 00669600 - ELSE EMITDESCLIT(FILECHECK(".PUNCH",0)); 00669700 -IF RDTRIN THEN EMITL(0) ELSE EMITPAIR(1,SSN); 00669800 -GO TO FORMER; 00669900 -SUCH: SCAN; RANDOMTOG~SUCHTOG~TRUE; INLINEFILE ; 00670000 - RANDOMTOG~FREEREAD~FALSE ; 00670100 - IF NEXT = EQUAL THEN % RANDOM KEY 00670200 - BEGIN SCAN; 00670300 - IF EXPR(TRUE) > REALTYPE THEN FLAG(102); 00670400 - IF RDTRIN THEN EMITPAIR(1,ADD); 00670500 - END ELSE IF RDTRIN THEN EMITL(0) ELSE EMITPAIR(1,SSN); 00670600 - IF NEXT = RPAREN THEN GO TO NF; 00670700 - IF NEXT ! COMMA THEN BEGIN FLOG(114); GO TO XIT END; 00670800 - SCAN; 00670900 - IF NEXT = ID THEN 00671000 - IF NAME = "ERR " OR NAME = "END " THEN 00671100 - BEGIN ACTIONLABELS(FALSE); 00671200 - NF: IF RDTRIN THEN EMITL(0) ELSE EMITPAIR(1,SSN); 00671300 - EMITL(0); 00671400 - NOFORMT ~ TRUE; 00671500 - SCAN; GO TO NOFORM; 00671600 - END; 00671700 -FORMER: IF ADR } 4085 THEN 00671800 - BEGIN ADR ~ ADR+1; SEGOVF END; 00671900 - IF NEXT = NUM THEN % FORMAT NUMBER 00672000 - BEGIN EDITCODE ~ 1; 00672100 - IF TEST ~ LBLSHFT(NAME) { 0 THEN 00672200 - BEGIN FLAG(135); GO TO LISTER END; 00672300 - IF I ~ SEARCH(TEST) = 0 THEN % NEVER SEEN 00672400 - OFLOWHANGERS(I~ENTER(0&FORMATID[TOCLASS], TEST)) ELSE 00672500 - IF GET(I).CLASS ! FORMATID THEN 00672600 - BEGIN FLAG(143); GO TO LISTER END; 00672700 - IF XREF THEN ENTERX(TEST,0&FORMATID[TOCLASS]); 00672800 - IF GET(I).ADDR = 0 THEN 00672900 - BEGIN EMITLINK((INFC ~ GET(I + 2)).BASE); 00673000 - PUT(I + 2,INFC&ADR[TOBASE]); 00673100 - EMITL(0); EMITL(0); EMITO(NOP); 00673200 - END ELSE 00673300 - BEGIN EMITL(GET(I+ 2).BASE); 00673400 - EMITPAIR(GET(I).ADDR,LOD); 00673500 - END; 00673600 - GO TO LISTER; 00673700 -END ELSE IF RDTRIN THEN IF(FREEREAD := NEXT=SLASH) THEN GO TO LISTER 00673800 -ELSE BEGIN IF NEXT NEQ ID THEN BEGIN FLOG(116);GO TO XIT; END;END 00673900 - ELSE IF NEXT NEQ ID THEN 00674000 - BEGIN IF NEXT = STAR THEN 00674100 - BEGIN NAMEDESC := TRUE; GLOBALNAME := TRUE; 00674200 - TV := ENTER(0&LISTSID[TOCLASS],LISTID:=LISTID+1); 00674300 - SCAN; 00674400 - END; 00674500 - IF NEXT = LPAREN THEN 00674600 - BEGIN SCAN; IF EXPR(TRUE) GTR REALTYPE THEN FLAG(120) ; 00674700 - SCAN; END ELSE EMITL(0); 00674800 - IF GLOBALNAME AND (FREEREAD := NEXT = SLASH) OR FREEREAD THEN 00674900 - GO TO LISTER ELSE BEGIN FLOG(110); GO TO XIT; END; 00675000 - END; 00675100 - GETALL(I ~ FNEXT,INFA,INFB,INFC); 00675200 - IF T ~ INFA.CLASS = ARRAYID THEN % FORMAT ARRAY 00675300 - BEGIN EDITCODE ~ 1; 00675400 - FORMARY ~ TRUE; 00675500 - T ~ EXPR(FALSE); 00675600 - ADR ~ ADR-1; % ELIMINATE XCH EMITTED BY EXPR 00675700 - IF EXPRESULT ! ARRAYID THEN FLOG(116); 00675800 - GO TO LISTER1; % SCAN ALREADY DONE IN EXPR 00675900 - END ELSE 00676000 - IF T = NAMELIST THEN 00676100 - BEGIN NAMETOG := TRUE; 00676200 - IF INFA.ADDR = 0 THEN % REFERENCED, NOT DEF 00676300 - BEGIN EMITLINK(INFC.BASE); 00676400 - PUT(I+ 2,(INFC ~ INFC&ADR[TOBASE])); 00676500 - EMITL(0); EMITL(0); EMITO(NOP); 00676600 - END ELSE 00676700 - BEGIN EMITL(INFC.BASE); 00676800 - EMITPAIR(INFA.ADDR,LOD); 00676900 - END 00677000 - END 00677100 - ELSE IF T = UNKNOWN THEN % ASSUME NAMELIST 00677200 - BEGIN PUT(I,(INFA ~ INFA&NAMELIST[TOCLASS])); 00677300 - NAMETOG := TRUE; 00677400 - OFLOWHANGERS(I); 00677500 - EMITLINK(0); PUT(I + 2,INFC&ADR[TOBASE]); 00677600 - EMITL(0); EMITL(0); EMITO(NOP); 00677700 - END ELSE BEGIN XTA ~ INFB; FLOG(116); GO TO XIT END; 00677800 - SCAN; 00677900 - IF NEXT = COMMA THEN ACTIONLABELS(TRUE); 00678000 - IF SUCHTOG THEN 00678100 - IF NEXT ! RPAREN THEN FLOG(108) ELSE SCAN; 00678200 - IF NEXT ! SEMI THEN BEGIN FLOG(118); GO TO XIT END; 00678300 - EMITL(0); EDITCODE ~ 4; EMITOPDCLIT(7); EMITO(FTC); 00678400 - GO TO WRAP; 00678500 -LISTER: SCAN; 00678600 - IF FREEREAD THEN IF NOT RDTRIN THEN 00678700 - BEGIN IF NEXT ! SLASH THEN EMITO(SSN) ELSE SCAN; 00678800 - IF NEXT = LPAREN THEN 00678900 - BEGIN SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(120);SCAN 00679000 - END ELSE EMITL(0); 00679100 - END; 00679200 -LISTER1: 00679300 - IF SUCHTOG THEN 00679400 - BEGIN IF NEXT = COMMA THEN ACTIONLABELS(TRUE); 00679500 - IF NEXT = RPAREN THEN SCAN ELSE BEGIN FLOG(108); GO TO XIT END; 00679600 - END ELSE IF NEXT=COMMA THEN SCAN ELSE IF RDTRIN THEN 00679700 - IF NEXT!SEMI THEN FLOG(114); 00679800 -NOFORM: IF NEXT=SEMI THEN 00679900 - BEGIN IF FREEREAD THEN FLOG(061) ELSE EMITL(0); GO TO WRAP END; 00680000 - IF (NEXT NEQ LPAREN) AND (NEXT NEQ ID) AND (NEXT NEQ STAR) THEN 00680100 - GO TO XIT; 00680200 - EDITCODE ~ EDITCODE + 2; 00680300 -DAAT: EMITB(-1,FALSE); LADR1 ~ LAX; ADJUST; DESCREQ ~ TRUE; 00680400 - IF ADR } 4085 THEN 00680500 - BEGIN ADR ~ ADR+1; SEGOVF; ADJUST END; 00680600 - ACCIDENT ~ PRGDESCBLDR(0,0,ADR.[36:10] + 1,NSEG); 00680700 - EMITOPDCLIT(19); EMITO(GFW); 00680800 - LISTART ~ ADR&NSEG[TOSEGNO]; ADJUST; 00680900 - LA ~ 0; IOLIST(LA); 00681000 - EMITL(1); EMITO(CHS); EMITL(19); EMITO(STD); 00681100 - EMITDESCLIT(19); EMITO(RTS); 0681200 - FIXB(LADR1); DESCREQ ~ FALSE; 00681300 - IF DATATOG THEN 00681400 - BEGIN DATASET; 00681500 - IF NEXT = SLASH THEN SCAN ELSE 00681600 - BEGIN FLOG(110); GO TO XIT END; 00681700 - IF LSTA = 0 THEN BEGIN BUMPPRT; LSTA~PRTS END; 00681800 - IF (LSTMAX - LSTI) { LSTS THEN 00681900 - BEGIN WRITEDATA(LSTI,NXAVIL ~ NXAVIL + 1,LSTP); 00682000 - LSTA ~ PRGDESCBLDR(1,LSTA,0,NXAVIL); 00682100 - LSTI ~ 0; BUMPPRT; LSTA~PRTS; 00682200 - END; 00682300 - MOVEW(LSTT,LSTP[LSTI],(LSTS ~ LSTS + 1).[36:6],LSTS); 00682400 - EMITO(MKS); EMITL(LSTI); EMITPAIR(LSTA,LOD); 00682500 - LSTI ~ LSTI + LSTS; 00682600 - EMITPAIR(ACCIDENT,LOD); EMITOPDCLIT(7); EMITO(FTF); 00682700 - EMITL(6); EMITL(0); EMITL(0); 00682800 - EMITV(NEED(".FBINB",INTRFUNID)); 00682900 - IF NEXT = COMMA THEN 00683000 - BEGIN SCAN; GO TO DAAT END; 00683100 - IF SPLINK } 0 THEN BEGIN 00683200 - EMITB(-1,FALSE); DATALINK~LAX; 00683300 - FIXB(DATAB) END; 00683400 - GO TO XIT; 00683500 - END; 00683600 - EMITPAIR(ACCIDENT,LOD); EMITOPDCLIT(7); EMITO(FTF); 00683700 -WRAP: IF NOT FREEREAD AND NOT NAMETOG THEN EMITL(EDITCODE); 00683800 -IF RDTRIN THEN 00683900 -BEGIN IF NX1 = 0 THEN EMITL(0) ELSE EMITLABELDESC(NX1); 00684000 - IF NX2 = 0 THEN EMITL(0) ELSE EMITLABELDESC(NX2); 00684100 - IF FREEREAD THEN EMITV(NEED(".FREFR", INTRFUNID)) 00684200 - ELSE IF NAMETOG THEN EMITV(NEED(".FINAM",INTRFUNID)) 00684300 - ELSE IF FORMARY THEN EMITV(NEED(".FTINT",INTRFUNID)) 00684400 - ELSE IF NOFORMT THEN EMITV(NEED(".FBINB",INTRFUNID)) 00684500 - ELSE EMITV(NEED(".FTNIN",INTRFUNID)); 00684600 -END ELSE 00684700 -IF FREEREAD THEN 00684800 - BEGIN 00684900 - IF NAMEDESC THEN 00685000 - BEGIN 00685100 - PRTSAVER(TV,NAMEIND+1,NAMLIST); 00685200 - EMITL(GET(TV+2).BASE); 00685300 - EMITPAIR(GET(TV).ADDR,LOD); 00685400 - IF NAMLIST[0] = 0 THEN EMITL(0) 00685500 - ELSE EMITPAIR(GET(GLOBALSEARCH(".SUBAR")).ADDR,LOD); 00685600 - NAMLIST[0] := NAMEIND := 0; 00685700 - END ELSE BEGIN EMITL(0);EMITL(0);EMITL(0);END; 00685800 - EMITV(NEED(".FREWR",INTRFUNID)) 00685900 - END ELSE IF NAMETOG THEN EMITV(NEED(".FONAM",INTRFUNID)) 00686000 - ELSE IF FORMARY THEN EMITV(NEED(".FTOUT",INTRFUNID)) 00686100 - ELSE BEGIN 00686200 - IF NX1=0 THEN EMITL(0) ELSE EMITLABELDESC(NX1); 00686300 - IF NX2=0 THEN EMITL(0) ELSE EMITLABELDESC(NX2); 00686400 - IF NOFORMT THEN EMITV(NEED(".FBINB",INTRFUNID)) ELSE 00686500 - EMITV(NEED(".FTNOU",INTRFUNID)); 00686600 - END; 00686700 -XIT: 00686800 - IF NAMEDESC THEN IF RDTRIN THEN FLAG(159) 00686900 - ELSE IF NOT FREEREAD THEN FLAG(160); 00687000 - DATATOG := FALSE; NAMEDESC := FALSE; GLOBALNAME := FALSE; 00687100 -IF DEBUGTOG THEN FLAGROUTINE(" IOCOM","MAND ",FALSE); 00687200 -END IOCOMMAND; 00687300 -PROCEDURE STMTFUN(LINK); VALUE LINK; REAL LINK; 00687400 -BEGIN 00687500 - DEFINE PARAM = LSTT#; 00687600 - REAL SAVEBRAD, I; 00687700 - REAL INFA, INFC, NPARMS, TYPE, PARMLINK, BEGINSUB, RETURN; 00687800 - LABEL XIT,TIX ; 00687900 - IF SPLINK < 0 THEN FLAG(12); 00688000 - LABL ~ BLANKS; 00688100 - FILETOG ~ TRUE; % PREVENTS SCANNER FROM ENTERING IDS IN INFO 00688200 - IF XREF THEN ENTERX(GET(LINK+1),0&STMTFUNID[TOCLASS] 00688300 - &(GET(LINK))[21:21:3]); 00688400 - DO 00688500 - BEGIN 00688600 - SCAN; 00688700 - IF NEXT ! ID THEN BEGIN FLOG(107); GO TO XIT END; 00688800 - PARAM[NPARMS~NPARMS+1] ~ NAME; 00688900 - SCAN; 00689000 - END UNTIL NEXT ! COMMA; 00689100 - IF NEXT ! RPAREN THEN FLOG(108) ELSE SCAN; 00689200 - IF NEXT ! EQUAL THEN BEGIN FLOG(104); GO TO XIT END; 00689300 - EMITB(-1,FALSE); SAVEBRAD ~ LAX; % BRANCH AROUND ST FUN 00689400 - ADJUST; 00689500 - BEGINSUB ~ ADR+1; 00689600 - BUMPLOCALS; EMITPAIR(RETURN~LOCALS+1536,STD); 00689700 - FOR I ~ NPARMS STEP -1 UNTIL 1 DO 00689800 - BEGIN 00689900 - IF T ~ SEARCH(PARAM[I]) ! 0 THEN 00690000 - TYPE ~ GET(T).SUBCLASS ELSE 00690100 - IF T~PARAM[I].[12:6] < "I" OR T > "N" THEN 00690200 - TYPE ~ REALTYPE ELSE TYPE ~ INTYPE; 00690300 - EMITSTORE( ENTER(0&VARID[TOCLASS]&1[TOTYPE] 00690400 - &TYPE[TOSUBCL], PARAM[I]), TYPE); 00690500 - IF XREF THEN ENTERX(NAME,0&VARID[TOCLASS]&TYPE[TOSUBCL]); 00690600 - END; 00690700 - PARMLINK ~ NEXTINFO-3; 00690800 - GETALL(LINK, INFA, XTA, INFC); 00690900 - FILETOG ~ FALSE; 00691000 - SCAN; 00691100 - IF (TYPE~(INFA~GET(LINK)).SUBCLASS)=LOGTYPE OR TYPE=COMPTYPE OR00691200 - (I~EXPR(TRUE))=LOGTYPE OR I=COMPTYPE THEN 00691300 - BEGIN IF I!TYPE THEN FLAG(139); GO TIX END ; 00691400 - IF TYPE=REALTYPE OR TYPE=INTYPE THEN 00691500 - BEGIN 00691600 - IF I=DOUBTYPE THEN BEGIN EMITO(XCH); EMITO(DEL) END; 00691700 - IF TYPE=INTYPE THEN IF I!INTYPE THEN EMITPAIR(1,IDV) ; 00691800 - GO TIX ; 00691900 - END ; 00692000 - IF I!DOUBTYPE THEN EMITPAIR(0,XCH) ; 00692100 -TIX: 00692200 - EMITOPDCLIT(RETURN) ; 00692300 - EMITO(GFW); 00692400 - FIXB(SAVEBRAD); 00692500 - IF INFA.CLASS ! UNKNOWN THEN FLAG(140); 00692600 - PUT(LINK, -INFA & 1[TOTYPE] & NSEG[TOSEGNO] 00692700 - & STMTFUNID[TOCLASS] & BEGINSUB[TOADDR]); 00692800 - PUT(LINK+2, -(0 & NPARMS[TONEXTRA] & ADR[TOBASE] 00692900 - & PARMLINK[36:36:12])); 00693000 - PARMLINK ~ PARMLINK+4; 00693100 - FOR I ~ 1 STEP 1 UNTIL NPARMS DO 00693200 - PUT(PARMLINK ~ PARMLINK-3, "......"); 00693300 - XIT: 00693400 - FILETOG ~ FALSE; 00693500 -END STMTFUN; 00693600 -PROCEDURE ASSIGNMENT; 00693700 -BEGIN 00693800 - LABEL XIT; 00693900 -BOOLEAN CHCK; 00694000 -BOOLEAN I; 00694100 -IF DEBUGTOG THEN FLAGROUTINE(" ASSIG","NMENT ",TRUE ) ; 00694200 - FX1 ~ FNEXT; 00694300 - SCAN; 00694400 - IF NEXT = LPAREN THEN 00694500 - BEGIN 00694600 -CHCK~TRUE; 00694700 - IF GET(FX1).CLASS = UNKNOWN THEN 00694800 - IF EODS THEN 00694900 - BEGIN XTA ~ GET(FX1+1); FLOG(035) ; 00695000 - PUT(FX1,GET(FX1) & ARRAYID[TOCLASS]) ; 00695100 - PUT(FX1+2,GET(FX1+2) & 1[TONEXTRA]) ; 00695200 - END 00695300 - ELSE BEGIN STMTFUN(FX1); GO TO XIT END ; 00695400 - IF XREF THEN ENTERX(GET(FX1+1),1&GET(FX1) [15:15:9]); 00695500 - EODS ~ TRUE ; 00695600 - EXECUTABLE; 00695700 - SCAN; 00695800 - I ~ SUBSCRIPTS(FX1,2); 00695900 - SCAN; 00696000 - END ELSE 00696100 - BEGIN 00696200 - EODS~TRUE ; 00696300 - EXECUTABLE; 00696400 - IF T ~ GET(FX1).CLASS = ARRAYID THEN 00696500 - BEGIN XTA ~ GET(FX1+1); FLAG(74) END; 00696600 - MOVEW(ACCUM[1],HOLDID[0],0,3); 00696700 - IF XREF THEN IF HOLDID[0].[12:12] ! "DO" THEN 00696800 - ENTERX(GET(FX1+1),1&GET(FX1)[21:21:3]&VARID[TOCLASS]); 00696900 - END; 00697000 - IF NEXT ! EQUAL THEN BEGIN FLAG(104); GO TO XIT END; 00697100 - SCAN; 00697200 - IF NEXT=SEMI OR NEXT=COMMA THEN BEGIN FLOG(0); GO TO XIT; END; 00697300 - FX2 ~ EXPR(TRUE); 00697400 - IF NEXT NEQ COMMA THEN IF HOLDID[0] = "DO" THEN IF XREF THEN 00697500 - ENTERX(HOLDID[0] ,1&GET(FX1)[21:21:3]&VARID[TOCLASS]); 00697600 - IF NEXT = COMMA THEN IF CHCK THEN FLOG(56) ELSE 00697700 - IF HOLDID[0].[12:12] ! "DO" THEN FLOG(56) ELSE 00697800 - BEGIN 00697900 - IF LOGIFTOG THEN FLAG(101); 00698000 - IF FX2 > REALTYPE THEN FLAG(102); 00698100 - IF DT ~ DT+1 > MAXDOS THEN BEGIN DT ~ 1; FLAG(138) END; 00698200 - EMITN(FX1~ CHECKDO); 00698300 - EMITO(STD); 00698400 - SCAN; 00698500 - IF NEXT=SEMI THEN BEGIN FLAG(36); GO TO XIT END; 00698600 - IF (ACCUM[0] = ", " OR ACCUM[0] = "; ") AND 00698700 - GLOBALNEXT=NUM AND ABS(FNEXT) > 1023 THEN 00698800 - BEGIN 00698900 - IF EXPR(TRUE) > REALTYPE THEN FLAG(102); 00699000 - IDINFO:=REALID;FNEXT:=ENTER(IDINFO,"2FNV00"&DT[36:36:12]);00699100 - EMITN(FNEXT:=GETSPACE(FNEXT)); EMITO(STD); 00699200 - EMITB(-1,FALSE); LADR1:=LAX; ADJUST; 00699300 - LADR2 ~ (ADR+1) & NSEG[TOSEGNO]; EMITV(FNEXT); 00699400 - END 00699500 - ELSE BEGIN 00699600 - EMITB(-1,FALSE); LADR1:=LAX; ADJUST; 00699700 - LADR2:=(ADR+1)&NSEG[TOSEGNO]; 00699800 - IF EXPR(TRUE) > REALTYPE THEN FLAG(102) ; 00699900 - END ; 00700000 - EMITO(GRTR); 00700100 - EMITB(-1, TRUE); 00700200 - LADR3 ~ LAX; 00700300 - EMITB(-1, FALSE); 00700400 - ADJUST; 00700500 - DOTEST[DT] ~ (ADR+1) & LAX[TOADDR] & NSEG[TOSEGNO]; 00700600 - IF NEXT ! COMMA THEN EMITL(1) ELSE 00700700 - BEGIN 00700800 - SCAN; 00700900 - IF NEXT=SEMI THEN BEGIN FLAG(36); GO TO XIT END ; 00701000 - IF EXPR(TRUE) > REALTYPE THEN FLAG(102); 00701100 - END; 00701200 - EMITV(FX1); 00701300 - EMITO(ADD); 00701400 - EMITN(FX1); 00701500 - EMITO(STN); 00701600 - EMITB(LADR2, FALSE); 00701700 - FIXB(LADR1); 00701800 - FIXB(LADR3); 00701900 - END ELSE EMITSTORE(FX1, FX2); 00702000 - XIT: 00702100 -IF DEBUGTOG THEN FLAGROUTINE(" ASSIG","NMENT ",FALSE ) ; 00702200 -END ASSIGNMENT; 00702300 -BOOLEAN PROCEDURE RINGCHECK; 00702400 -COMMENT THIS PROCEDURE PREVENTS THE POSSIBILITY OF DELINKING A 00702500 - HEADER FROM THE HEADER RING; 00702600 - BEGIN 00702700 - INTEGER I; 00702800 - I~A; 00702900 - DO 00703000 - IF I ~ GETC(I).ADDR = ROOT THEN RINGCHECK ~ TRUE 00703100 - UNTIL I = A; 00703200 - END RINGCHECK; 00703300 -PROCEDURE SETLINK(INFADDR); VALUE INFADDR; INTEGER INFADDR; 00703400 -COMMENT THIS PROCEDURE LINKS AN ELEMENT TO ITS PREVIOUS HEADER; 00703500 -BEGIN 00703600 - INTEGER LAST,I; REAL COML; LABEL XIT; 00703700 -XIT: 00703800 - LAST ~(GETC(INFADDR).LASTC)-1; 00703900 - FOR I ~ INFADDR+2 STEP 1 UNTIL LAST 00704000 - DO BEGIN IF GETC(I).CLASS = ENDCOM THEN I~GETC(I).LINK; 00704100 - IF FX1 = (COML~GETC(I)).LINK THEN 00704200 - IF INFADDR~COML.LASTC=A THEN COM[PWI].LASTC~ROOT 00704300 - ELSE GO XIT ; 00704400 - END; 00704500 -END SETLINK; 00704600 -PROCEDURE DIMENSION; 00704700 -BEGIN 00704800 - LABEL L, LOOP, ERROR ; 00704900 - BOOLEAN DOUBLED, SINGLETOG; %109-00705000 -IF DEBUGTOG THEN FLAGROUTINE(" DIMEN","SION ",TRUE ) ; 00705100 - IF LOGIFTOG THEN FLAG(101); 00705200 - LABL ~ BLANKS; 00705300 - IF NEXT=STAR THEN IF TYPE!DOUBTYPE THEN 00705400 - BEGIN 00705500 - SCAN ; 00705600 - IF NEXT=SUM AND NUMTYPE=INTYPE THEN 00705700 - BEGIN 00705800 - IF FNEXT=4 THEN 00705900 - BEGIN 00706000 - SINGLETOG ~ TRUE; %109-00706100 - IF TYPE=COMPTYPE THEN FLAG(176); GO L ; 00706200 - END ; 00706300 - IF FNEXT=8 THEN 00706400 - BEGIN 00706500 - IF TYPE=REALTYPE THEN TYPE~DOUBTYPE 00706600 - ELSE IF TYPE!COMPTYPE THEN FLAG(177) ; 00706700 - GO L ; 00706800 - END ; 00706900 - END ; 00707000 - FLAG(IF TYPE=REALTYPE THEN 178 00707100 - ELSE 177-REAL(TYPE=COMPTYPE)) ; 00707200 -L: NCR~REAL(NCR.[30:3]!0)+3"677777"+NCR; SCN~1; SCAN ; 00707300 - END ; 00707400 - LOOP: DOUBLED~FALSE; 00707500 - IF NEXT ! ID THEN BEGIN FLOG(105); GO TO ERROR END; 00707600 - FX1 ~ IF SINGLETOG THEN -FNEXT ELSE FNEXT; %109-00707700 - IF TYPE } DOUBTYPE THEN % FIX ARRAY TYPE OFR 00707800 - PUT(FX1,GET(FX1)&TYPE[TOSUBCL]); % BOUNDS ROUTINE 00707900 - IF XREF THEN BEGIN INFA ~ 0&GET(FX1)[15:15:9]; 00708000 - IF TYPE>0 THEN INFA.SUBCLASS~TYPE; 00708100 - END; 00708200 - XTA ~ INFB ~ NAME; 00708300 - SCAN; 00708400 - IF XREF THEN 00708500 - BEGIN IF INFA.CLASS = UNKNOWN THEN 00708600 - INFA.CLASS~IF NEXT=LPAREN THEN ARRAYID ELSE VARID; 00708700 - ENTERX(INFB,INFA); 00708800 - END; 00708900 - IF NEXT=LPAREN THEN BEGIN SCAN; DOUBLED~BOUNDS(FX1) END ELSE 00709000 - IF TYPE = -1 THEN FLOG(103); 00709100 - GETALL(FX1, INFA, XTA, INFC); 00709200 - IF TYPE > 0 THEN 00709300 - IF BOOLEAN(INFA.TYPEFIXED) THEN FLAG(31) ELSE 00709400 - BEGIN 00709500 - IF TYPE > LOGTYPE THEN 00709600 - IF GET(FX1+2) <0 THEN 00709700 - BEGIN 00709800 - IF NOT DOUBLED AND INFA.CLASS=1 THEN 00709900 - BEGIN 00710000 - BUMPLOCALS; 00710100 - LENGTH~LOCALS + 1536; 00710200 - PUT(FX1+2,INFC & LENGTH[TOSIZE]); 00710300 - END 00710400 - END ELSE IF NOT DOUBLED THEN 00710500 - BEGIN IF INFC.SIZE > 16383 THEN FLAG(99); 00710600 - PUT(FX1+2,INFC & (2 | INFC.SIZE)[TOSIZE]); 00710700 - END; 00710800 - PUT (FX1,INFA & 1[TOTYPE] & TYPE[TOSUBCL]); 00710900 - END; 00711000 - IF INFA < 0 THEN FLAG(39) ELSE 00711100 - IF TYPE = -2 THEN 00711200 - BEGIN 00711300 - BAPC(INFA&FX1[TOLINK]&1[TOCE]&ROOT[TOLASTC]); 00711400 - IF BOOLEAN(INFA.CE) THEN FLAG(2); 00711500 - IF BOOLEAN(INFA.EQ) THEN 00711600 - BEGIN 00711700 - COM[NEXTCOM.IR,NEXTCOM.IC].LASTC ~ A ~ INFA.ADDR; 00711800 - B~GETC(ROOT).ADDR ; 00711900 - SETLINK(A); 00712000 - IF NOT RINGCHECK THEN 00712100 - BEGIN 00712200 - COM[PWROOT].ADDR~GETC(A).ADDR ; 00712300 - PUTC(A,GETC(A)&B[TOADDR]&7[TOSUBCL]) ; 00712400 - END 00712500 - END ELSE 00712600 - PUT(FX1, INFA & 1[TOCE] & ROOT[TOADDR]); 00712700 - IF BOOLEAN(INFA.FORMAL) THEN FLAG(10); 00712800 - END; 00712900 - IF ERRORTOG THEN 00713000 - ERROR: 00713100 - WHILE NEXT ! COMMA AND NEXT ! SEMI AND NEXT ! SLASH DO SCAN; 00713200 - IF NEXT = COMMA THEN BEGIN SCAN; GO TO LOOP END; 00713300 -IF DEBUGTOG THEN FLAGROUTINE(" DIMEN","SION ",FALSE ); 00713400 -END DIMENSION; 00713500 -PROCEDURE FORMALPP(PARMSREQ, CLASS); VALUE PARMSREQ, CLASS; 00713600 - BOOLEAN PARMSREQ; REAL CLASS; 00713700 -BEGIN 00713800 - LABEL LOOP, XIT; 00713900 -IF DEBUGTOG THEN FLAGROUTINE(" FORM","ALPP ",TRUE ) ; 00714000 - PARMS ~ 0; 00714100 - SCAN; 00714200 - IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; 00714300 - IF CLASS = FUNID THEN 00714400 - IF FUNVAR = 0 THEN 00714500 - BEGIN 00714600 - IF TYPE > 0 THEN 00714700 - IF FUNVAR ~ GLOBALSEARCH(NAME) ! 0 THEN 00714800 - IF BOOLEAN((T ~ GET(FUNVAR)).TYPEFIXED) AND TYPE ! T.SUBCLASS 00714900 - THEN FLAG(31); 00715000 - PUT(FUNVAR ~ FNEXT,GET(FNEXT) & VARID[TOCLASS]); 00715100 - END; 00715200 - FNEW ~ NEED(NNEW ~ NAME, CLASS); 00715300 - ENTERX(NAME,IF CLASS = FUNID THEN 00715400 - 1&GET(FNEW)[15:15:9] ELSE 1&GET(FNEW)[15:15:5]); 00715500 - SCAN; 00715600 - IF NEXT ! LPAREN THEN 00715700 - IF PARMSREQ THEN FLOG(106) ELSE ELSE 00715800 - BEGIN 00715900 - LOOP: 00716000 - SCAN; 00716100 - IF NEXT = ID THEN PARMLINK[PARMS ~ PARMS+1] ~ FNEXT ELSE 00716200 - IF NEXT=STAR AND CLASS!FUNID THEN PARMLINK[PARMS~PARMS+1]~0ELSE00716300 - FLOG(107); 00716400 - IF XREF THEN ENTERX(NAME,IF NEXT = STAR THEN 0 ELSE 00716500 - 0&GET(FNEXT)[15:15:9]); 00716600 - SCAN; 00716700 - IF NEXT = COMMA THEN GO TO LOOP; 00716800 - IF NEXT ! RPAREN THEN FLOG(108); 00716900 - SCAN; 00717000 - END; 00717100 - IF NOT ERRORTOG THEN DECLAREPARMS(FNEW); 00717200 - XIT: 00717300 -IF DEBUGTOG THEN FLAGROUTINE(" FORM","ALPP ",FALSE) ; 00717400 -END FORMALPP; 00717500 - 00717600 -PROCEDURE ENDS; FORWARD; 00717700 - 00717800 -PROCEDURE FUNCTION ; 00717900 -BEGIN 00718000 - REAL A,B,C,I; LABEL FOUND ; 00718100 - IF SPLINK NEQ 0 THEN BEGIN FLAG(5); ENDS; SEGMENTSTART; END; 00718200 - LABL ~ BLANKS; 00718300 - FORMALPP(TRUE, FUNID); 00718400 - GETALL(FNEW, INFA, INFB, INFC); 00718500 - B~NUMINTM1 ; 00718600 - WHILE A+1SUPERMAXCOM THEN 00726500 - BEGIN ROOT~0; FATAL(124) END 00726600 - ELSE ROOT~NEXTCOM ; 00726700 - PUTC(ROOT,0&HEADER[TOCLASS]&1[TOCE]&ROOT[TOADDR]) ; 00726800 - BAPC(Z); 00726900 - END ELSE 00727000 - BEGIN 00727100 - ROOT ~ T.ADINFO; 00727200 - COM[(T~GETC(ROOT).LASTC).IR,T.IC].LINK~NEXTCOM+1 ; 00727300 - IF COM[PWROOT]<0 THEN FLAG(2) ; 00727400 - END; 00727500 - DIMENSION; 00727600 - BAPC(0&ENDCOM[TOCLASS]) ; 00727700 - COM[PWROOT].LASTC~NEXTCOM ; 00727800 - PUT(T~GETC(ROOT+1)+2,GET(T)&ROOT[TOADINFO]) ; 00727900 - IF NEXT ! SEMI THEN GO TO LOOP; 00728000 -END COMMON; 00728100 -PROCEDURE ENDS; 00728200 -BEGIN 00728300 - IF SPLINK=0 THEN FLAG(184) ELSE %112-00728400 - BEGIN %112-00728500 - EODS~FALSE ; 00728600 - IF LOGIFTOG THEN FLAG(101); 00728700 - LABL ~ BLANKS; 00728800 - IF SPLINK < 0 THEN EMITO(XIT) ELSE EMITPAIR(0, KOM); 00728900 - SEGMENT((ADR+4) DIV 4, NSEG, TRUE, EDOC); 00729000 - END; %112-00729100 -END ENDS; 00729200 -PROCEDURE ENTRY; 00729300 -BEGIN 00729400 - REAL SP; 00729500 - IF SPLINK = 0 THEN FLAG(111) ELSE 00729600 - IF SPLINK = 1 THEN BEGIN ELX ~ 0; FLAG(4) END; 00729700 - LABL ~ BLANKS; 00729800 - ADJUST ; 00729900 - SP ~ GET(SPLINK); 00730000 - FORMALPP( (T~SP.CLASS) = FUNID, T); 00730100 - GETALL(FNEW, INFA, INFB, INFC); 00730200 - IF INFA.CLASS = FUNID THEN 00730300 - PUT(FNEW, INFA & 1[TOTYPE] & (SP.SUBCLASS)[TOSUBCL]); 00730400 - PUT(FNEW+2, INFC & (ADR+1)[TOBASE]); 00730500 -END ENTRY; 00730600 -PROCEDURE EQUIVALENCE; 00730700 -COMMENT THIS PROCEDURE MAKES THE COM ENTRY FOR EQUIV ITEMS AND SETS 00730800 - THE EQ BIT IN BOTH THE COM AND INFO TABLES AND LINKS 00730900 - THE HEADS OF CHAINS; 00731000 -BEGIN 00731100 - REAL P, Q, R, S; 00731200 - BOOLEAN FIRST,PCOMM; 00731300 - LABEL XIT; 00731400 - IF LOGIFTOG THEN FLAG(101); 00731500 - LABL ~ BLANKS; 00731600 - DO 00731700 - BEGIN 00731800 - FIRST ~ FALSE; 00731900 - SCAN; 00732000 - IF NEXT ! LPAREN THEN BEGIN FLOG(106); GO TO XIT END; 00732100 - IF NEXTCOM~NEXTCOM+1>SUPERMAXCOM THEN 00732200 - BEGIN ROOT~0; FATAL(124) END 00732300 - ELSE ROOT~NEXTCOM ; 00732400 - PUTC(ROOT,0&HEADER[TOCLASS]&ROOT[TOADDR]) ; 00732500 - BAPC(0); Q~0 ; 00732600 - DO 00732700 - BEGIN 00732800 - SCAN; 00732900 - IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; 00733000 - IF XREF THEN ENTERX(NAME,0&GET(FNEXT)[15:15:9]); 00733100 - FX1 ~ FNEXT; 00733200 - LENGTH ~ 0; 00733300 - SCAN; 00733400 - IF NEXT = LPAREN THEN 00733500 - BEGIN 00733600 - IF GET(FX1).CLASS ! ARRAYID THEN 00733700 - BEGIN XTA ~ GET(FX1+1); FLOG(112) END; 00733800 - R ~ 0; P ~ 1; 00733900 - S ~ GET(FX1+2).ADINFO; 00734000 - DO 00734100 - BEGIN 00734200 - SCAN; 00734300 - IF NEXT ! NUM OR NUMTYPE ! INTYPE THEN FLAG(113); 00734400 - LENGTH ~ LENGTH + P|(FNEXT-1); 00734500 - P ~ P|EXTRAINFO[(S+R).IR,(S+R).IC] ; 00734600 - R ~ R-1; 00734700 - SCAN; 00734800 - END UNTIL NEXT ! COMMA; 00734900 - IF NEXT ! RPAREN THEN BEGIN FLOG(108); GO TO XIT END; 00735000 - IF R!-1 THEN IF R~R+GET(FX1+2).NEXTRA!0 THEN 00735100 - BEGIN XTA~GET(FX1+1); FLAG(IF R>0 THEN 23 ELSE 24) END ; 00735200 - SCAN; 00735300 - END; 00735400 - IF (INFA~GET(FX1)) < 0 THEN 735500 - BEGIN XTA ~ GET(FX1+1); FLAG(39) END ELSE 735600 - BEGIN 735700 - IF INFA.SUBCLASS > LOGTYPE THEN LENGTH ~ 2|LENGTH ; 00735800 - BAPC(INFA&FX1[TOLINK]&LENGTH[TORELADD]&1[TOEQ]&ROOT[TOLASTC]); 00735900 - IF(PCOMM~BOOLEAN(INFA.CE)) OR BOOLEAN(INFA.EQ) THEN 00736000 - BEGIN 00736100 - IF FIRST AND PCOMM THEN BEGIN XTA~GET(FX1+1); FLAG(2) END 00736200 - ELSE IF NOT FIRST THEN FIRST ~ PCOMM; 00736300 - PUT(FX1,INFA & 1[TOEQ]); 00736400 - COM[NEXTCOM.IR,NEXTCOM.IC].LASTC ~ A ~ INFA.ADDR; 00736500 - B~GETC(ROOT).ADDR ; 00736600 - SETLINK(A); 00736700 - IF NOT RINGCHECK THEN 00736800 - BEGIN 00736900 - COM[PWROOT].ADDR~GETC(A).ADDR ; 00737000 - PUTC(A,GETC(A)&B[TOADDR]&7[TOSUBCL]) ; 00737100 - END 00737200 - END ELSE 00737300 - PUT(FX1,INFA & 1[TOEQ] & ROOT[TOADDR]); 00737400 - IF LENGTH > Q THEN Q ~ LENGTH; 00737500 - IF BOOLEAN(INFA.FORMAL) THEN 00737600 - BEGIN XTA ~ GET(FX1+1); FLAG(11) END; 00737700 - END; 00737800 - END UNTIL NEXT ! COMMA; 00737900 - IF NEXT ! RPAREN THEN BEGIN FLOG(108); GO TO XIT END; 00738000 - SCAN; 00738100 - PUTC(ROOT+1,Q); 00738200 - BAPC(0&ENDCOM[TOCLASS]) ; 00738300 - COM[PWROOT].LASTC~NEXTCOM ; 00738400 - END UNTIL NEXT ! COMMA; 00738500 - XIT: 00738600 -END EQUIVALENCE; 00738700 -PROCEDURE EXTERNAL; 00738800 -BEGIN 00738900 - IF SPLINK < 0 THEN FLAG( 12); 00739000 - IF LOGIFTOG THEN FLAG(101); 00739100 - LABL ~ BLANKS; 00739200 - DO 00739300 - BEGIN 00739400 - SCAN; 00739500 - IF NEXT ! ID THEN FLOG(105) ELSE 00739600 - BEGIN T ~ NEED(NAME,EXTID); 00739700 - IF XREF THEN ENTERX(NAME,0&GET(T)[15:15:9]); 00739800 - SCAN; 00739900 - END; 00740000 - END UNTIL NEXT ! COMMA; 00740100 -END EXTERNAL; 00740200 -PROCEDURE CHAIN; 00740300 -BEGIN 00740400 - LABEL AGN, XIT; 00740500 - REAL T1; 00740600 - DEFINE FLG(FLG1) = BEGIN FLOG(FLG1); GO TO XIT END#; 00740700 - EXECUTABLE; 00740800 - SCAN; 00740900 - T1 ~ 2; 00741000 - IF FALSE THEN 00741100 - AGN: IF GLOBALNEXT ! COMMA THEN FLG(28); 00741200 - SCAN; 00741300 - IF EXPR(TRUE) > REALTYPE THEN FLG(102); 00741400 - IF (T1 ~ T1 - 1) ! 0 THEN GO TO AGN; 00741500 - IF GLOBALNEXT ! RPAREN THEN FLG(3); 00741600 - EMITPAIR(37,KOM); 00741700 - SCAN; 00741800 - IF GLOBALNEXT ! SEMI THEN FLOG(117); 00741900 - XIT: WHILE GLOBALNEXT ! SEMI DO SCAN; 00742000 -END CHAIN; 00742100 -PROCEDURE GOTOS; 00742200 -BEGIN LABEL XIT; 00742300 - REAL ASSIGNEDID; 00742400 - EODS~TRUE ; 00742500 - EXECUTABLE; 00742600 - SCAN; 00742700 - IF NEXT = NUM THEN 00742800 - BEGIN 00742900 - LABELBRANCH(NAME, FALSE); 00743000 - SCAN; 00743100 - GO TO XIT; 00743200 - END; 00743300 - IF NEXT = ID THEN 00743400 - BEGIN 00743500 - ASSIGNEDID ~ FNEXT; 00743600 - IF XREF THEN ENTERX(XTA,0&GET(FNEXT)[15:15:9]); 00743700 - SCAN; 00743800 - IF NEXT ! COMMA THEN FLOG(114); 00743900 - SCAN; 00744000 - IF NEXT ! LPAREN THEN FLOG(106); 00744100 - DO 00744200 - BEGIN 00744300 - SCAN; 00744400 - IF NEXT ! NUM THEN FLOG(109); 00744500 - EMITV(ASSIGNEDID); 00744600 - EMITNUM(FNEXT); 00744700 - EMITO(NEQL); 00744800 - LABELBRANCH(NAME, TRUE); 00744900 - SCAN; 00745000 - END UNTIL NEXT ! COMMA; 00745100 - IF NEXT ! RPAREN THEN FLOG(108); 00745200 - SCAN; 00745300 - EMITPAIR(1, SSN); % CAUSE INVALID INDEX TERMINATION 00745400 - EMITDESCLIT(10); 00745500 - GO TO XIT; 00745600 - END; 00745700 - IF NEXT ! LPAREN THEN FLOG(106); 00745800 - P ~ 0; 00745900 - DO 00746000 - BEGIN 00746100 - SCAN; 00746200 - IF NEXT ! NUM THEN BEGIN FLOG(109); GO TO XIT END; 00746300 - LSTT[P~P+1] ~ NAME; 00746400 - SCAN; 00746500 - END UNTIL NEXT ! COMMA; 00746600 - IF NEXT ! RPAREN THEN BEGIN FLOG(108); GO TO XIT END; 00746700 - SCAN; 00746800 - IF NEXT ! COMMA THEN BEGIN FLOG(114); GO TO XIT END; 00746900 - SCAN; 00747000 - IT ~ P+1; % DONT LET EXPR WIPE OUT LSTT 00747100 - IF EXPR(TRUE) > REALTYPE THEN FLOG(102); 00747200 - EMITPAIR(JUNK, ISN); 00747300 - EMITPAIR(1,LESS); 00747400 - EMITOPDCLIT(JUNK); 00747500 - EMITO(LOR); 00747600 - EMITOPDCLIT(JUNK); 00747700 - EMITL(3); 00747800 - EMITO(MUL); 00747900 - IF ADR+3|P > 4085 THEN BEGIN ADR~ADR+1; SEGOVF END; 00748000 - EMITO(BFC); 00748100 - EMITPAIR(1, SSN); 00748200 - EMITDESCLIT(10); 00748300 - FOR I ~ 1 STEP 1 UNTIL P DO 00748400 - BEGIN 00748500 - J ~ ADR; LABELBRANCH(LSTT[I], FALSE); 00748600 - IF ADR-J = 2 THEN EMITO(NOP); 00748700 - END; 00748800 - XIT: 00748900 - IT ~ 0; 00749000 -END GOTOS; 00749100 -PROCEDURE IFS; 00749200 -BEGIN REAL TYPE, LOGIFADR, SAVELABL; 00749300 - EODS~TRUE; 00749400 - EXECUTABLE; 00749500 - SCAN; 00749600 - IF NEXT ! LPAREN THEN FLOG(106); 00749700 - SCAN; 00749800 - IF TYPE ~ EXPR(TRUE) = COMPTYPE THEN FLAG(89); 00749900 - IF NEXT ! RPAREN THEN FLOG(108); 00750000 - IF TYPE = LOGTYPE THEN 00750100 - BEGIN 00750200 - EMITB(-1, TRUE); 00750300 - LOGIFADR ~ LAX; 00750400 - LOGIFTOG ~ TRUE; EOSTOG ~ TRUE; 00750500 - SAVELABL ~ LABL; LABL ~ BLANKS; 00750600 - STATEMENT; 00750700 - LABL ~ SAVELABL; 00750800 - LOGIFTOG ~ FALSE; EOSTOG ~ FALSE; 00750900 - FIXB(LOGIFADR); 00751000 - END ELSE 00751100 - BEGIN 00751200 - IF TYPE = DOUBTYPE THEN 00751300 - BEGIN EMITO(XCH); EMITO(DEL) END; 00751400 - SCAN; 00751500 - IF NEXT ! NUM THEN FLOG(109); 00751600 - FX1 ~ FNEXT; NX1 ~ NAME; 00751700 - SCAN; 00751800 - IF NEXT ! COMMA THEN FLOG(114); 00751900 - SCAN; 00752000 - IF NEXT ! NUM THEN FLOG(109); 00752100 - FX2 ~ FNEXT; NX2 ~ NAME; 00752200 - SCAN; 00752300 - IF NEXT ! COMMA THEN FLOG(114); 00752400 - SCAN; 00752500 - IF NEXT ! NUM THEN FLOG(109); 00752600 - FX3 ~ FNEXT; NX3 ~ NAME; 00752700 - SCAN; 00752800 - IF FX2 = FX3 THEN 00752900 - BEGIN 00753000 - EMITPAIR(0,GEQL); 00753100 - LABELBRANCH(NX1, TRUE); 00753200 - LABELBRANCH(NX3, FALSE); 00753300 - IF XREF THEN ENTERX(NX2,0&LABELID[TOCLASS]); 00753400 - END ELSE 00753500 - IF FX1 = FX3 THEN 00753600 - BEGIN 00753700 - EMITPAIR(0,NEQL); 00753800 - LABELBRANCH(NX2, TRUE); 00753900 - LABELBRANCH(NX1, FALSE); 00754000 - IF XREF THEN ENTERX(NX3,0&LABELID[TOCLASS]); 00754100 - END ELSE 00754200 - IF FX1 = FX2 THEN 00754300 - BEGIN 00754400 - EMITPAIR(0,LEQL); 00754500 - LABELBRANCH(NX3, TRUE); 00754600 - LABELBRANCH(NX1, FALSE); 00754700 - IF XREF THEN ENTERX(NX2,0&LABELID[TOCLASS]); 00754800 - END ELSE 00754900 - BEGIN 00755000 - EMITO(DUP); 00755100 - EMITPAIR(0,NEQL); 00755200 - EMITB(-1,TRUE); 00755300 - EMITPAIR(0,LESS); 00755400 - LABELBRANCH(NX3, TRUE); 00755500 - LABELBRANCH(NX1, FALSE); 00755600 - FIXB(LAX); 00755700 - EMITO(DEL); 00755800 - LABELBRANCH(NX2, FALSE); 00755900 - END; 00756000 - END; 00756100 -END IFS; 00756200 -PROCEDURE NAMEL; 00756300 -BEGIN LABEL NIM,XIT,ELMNT,WRAP; 00756400 - IF SPLINK < 0 THEN FLAG(12); 00756500 - IF LOGIFTOG THEN FLAG(101); 00756600 - LABL ~ BLANKS; 00756700 - SCAN; IF NEXT ! SLASH THEN FLOG(110); 00756800 -NIM: SCAN; IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; 00756900 - IF J ~ (INFA ~ GET(LADR2 ~ FNEXT)).CLASS = UNKNOWN THEN 00757000 - PUT(LADR2,INFA&NAMELIST[TOCLASS]) 00757100 - ELSE IF J ! NAMELIST THEN 00757200 - BEGIN XTA ~ GET(LADR2 + 1); 00757300 - FLAG(20); 00757400 - END; 00757500 - LSTT[LSTS ~ LADR1 ~ 0] ~ NAME; 00757600 - IF XREF THEN ENTERX(NAME,0&NAMELIST[TOCLASS]); 00757700 - SCAN; IF NEXT ! SLASH THEN FLOG(110); 00757800 -ELMNT: SCAN; IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; 00757900 - LADR1 ~ LADR1 + 1; 00758000 - IF (T ~ GET(FNEW ~ GETSPACE(FNEXT)).CLASS) > VARID THEN FLAG(48); 00758100 - GETALL(FNEW,INFA,INFB,INFC); 00758200 - IF XREF THEN ENTERX(INFB,0&INFA[15:15:9]); 00758300 - IF LSTS ~ LSTS+1 = LSTMAX THEN BEGIN FLOG(78); GO TO XIT END ELSE 00758400 - LSTT[LSTS] ~ NAME&INFA.CLASNSUB[2:38:10]&0[8:47:1]; 00758500 - IF T = ARRAYID THEN 00758600 - BEGIN J ~ INFC.ADINFO; 00758700 - I ~ INFC.NEXTRA; 00758800 - IF LSTS + I + 1 > LSTMAX THEN 00758900 - BEGIN FLOG(78); GO TO XIT END; 00759000 - LSTT[LSTS ~ LSTS + 1] ~ 0&I[1:42:6] % # DIMENSIONS 00759100 - &INFA.ADDR[7:37:11] % REL ADR 00759200 - &INFC.BASE[18:33:15] % BASE 00759300 - &INFC.SIZE[33:33:15]; % SIZE 00759400 - FOR T ~ J STEP -1 UNTIL J - I + 1 DO 00759500 - LSTT[LSTS ~ LSTS + 1] ~ EXTRAINFO[T.IR,T.IC]; 00759600 - END ELSE BEGIN LSTT[LSTS~LSTS+1]~0&(INFA.ADDR)[7:37:11]; 00759700 - IF BOOLEAN(INFA.CE) THEN LSTT[LSTS]~LSTT[LSTS]&INFC.BASE[18:33:15]00759800 - &INFC.SIZE[33:33:15] END; 00759900 - SCAN; IF NEXT = COMMA THEN GO TO ELMNT; 00760000 - IF NEXT ! SEMI AND NEXT ! SLASH THEN FLOG(115); 00760100 - LSTT[LSTS + 1] ~ 0; 00760200 - LSTT[0].[2:10] ~ LADR1; 00760300 - PRTSAVER(LADR2,LSTS + 2,LSTT); 00760400 - IF NEXT ! SEMI THEN GO TO NIM; 00760500 -XIT: 00760600 -END NAMEL; 00760700 -PROCEDURE PAUSE; 00760800 -IF DCINPUT THEN BEGIN XTA~"PAUSE "; FLOG(151) END ELSE 00760900 -BEGIN 00761000 - EODS~TRUE ; 00761100 - IF TSSEDITOG THEN TSSED("PAUSE ",2) ; 00761200 - EXECUTABLE; 00761300 - SCAN; 00761400 - IF NEXT = SEMI THEN EMITL(0) ELSE 00761500 - IF NEXT = NUM THEN 00761600 - BEGIN 00761700 - EMITNUM(NAME); 00761800 - SCAN; 00761900 - END; 00762000 - EMITPAIR(33, KOM); 00762100 - EMITO(DEL); 00762200 -END PAUSE; 00762300 -PROCEDURE TYPIT(TYP,TMPNXT); VALUE TYP; REAL TYP,TMPNXT ; 00762400 - BEGIN 00762500 - TYPE~TYP; SCAN ; 00762600 - IF NEXT=16 THEN BEGIN TMPNXT~16; FUNCTION END ELSE DIMENSION ; 00762700 - END OF TYPIT ; 00762800 -DEFINE COMPLEX =TYPIT(COMPTYPE,TEMPNEXT) #, 00762900 - LOGICAL =TYPIT(LOGTYPE ,TEMPNEXT) #, 00763000 - DOUBLEPRECISION =TYPIT(DOUBTYPE,TEMPNEXT) #, 00763100 - INTEGERS =TYPIT(INTYPE ,TEMPNEXT) #, 00763200 - REALS =TYPIT(REALTYPE,TEMPNEXT) #; 00763300 -PROCEDURE STOP; 00763400 -BEGIN 00763500 - RETURNFOUND ~ TRUE; 00763600 - EODS~TRUE; 00763700 - EXECUTABLE; 00763800 - COMMENT INITIAL SCAN ALREADY DONE; 00763900 - EMITL(1); 00764000 - EMITPAIR(16,STD); 00764100 - EMITPAIR(10, KOM); 00764200 - EMITPAIR(5, KOM); 00764300 - WHILE NEXT ! SEMI DO SCAN; 00764400 -END STOP; 00764500 -PROCEDURE RETURN; 00764600 -BEGIN LABEL EXIT; 00764700 - REAL T, XITCODE; 00764800 - RETURNFOUND ~ TRUE; 00764900 - EODS~TRUE ; 00765000 - EXECUTABLE; 00765100 - SCAN; 00765200 - IF SPLINK=0 OR SPLINK=1 THEN 00765300 - BEGIN XTA~"RETURN"; FLOG(153); GO EXIT END ; 00765400 - IF NEXT = SEMI THEN 00765500 - BEGIN 00765600 - IF (T ~ GET(SPLINK)).CLASS = FUNID THEN 00765700 - BEGIN 00765800 - EMITV(FUNVAR); 00765900 - IF T.SUBCLASS > LOGTYPE THEN EMITPAIR(JUNK, STD); 00766000 - XITCODE ~ RTN; 00766100 - END ELSE XITCODE ~ XIT; 00766200 - IF ADR } 4077 THEN 00766300 - BEGIN ADR ~ ADR+1; SEGOVF END; 00766400 - EMITOPDCLIT(1538); % F+2 00766500 - EMITPAIR(3, BFC); 00766600 - EMITPAIR(10, KOM); 00766700 - EMITO(XITCODE); 00766800 - EMITOPDCLIT(16); 00766900 - EMITPAIR(1, SUB); 00767000 - EMITPAIR(16, STD); 00767100 - EMITO(XITCODE); 00767200 - GO TO EXIT; 00767300 - END; 00767400 - IF LABELMOM = 0 THEN FLOG(145); 00767500 - IF EXPR(TRUE) > REALTYPE THEN FLAG(102); 00767600 - IF EXPRESULT = NUMCLASS THEN 00767700 - BEGIN IF XREF THEN ENTERX(EXPVALUE,0&LABELID[TOCLASS]); 00767800 - ADR ~ ADR-1;EMITL(EXPVALUE-1) 00767900 - END ELSE 00768000 - EMITPAIR(1, SUB); 00768100 - EMITOPDCLIT(LABELMOM); 00768200 - EMITO(MKS); 00768300 - EMITL(9); 00768400 - EMITOPDCLIT(5); 00768500 - EXIT: 00768600 -END RETURN; 00768700 -PROCEDURE IMPLICIT ; 00768800 - BEGIN 00768900 - REAL R1,R2,R3,R4 ; 00769000 - LABEL R,A,X,L ; 00769100 - IF NOT(LASTNEXT=42 OR LASTNEXT=1000 OR LASTNEXT=30 %110-00769200 - OR LASTNEXT=16 OR LASTNEXT = 11) %110-00769300 - THEN BEGIN FLOG(181); FILETOG~TRUE; GO X END ; 00769400 -R: EOSTOG~ERRORTOG~TRUE; FILETOG~FALSE ; 00769500 - MOVEW(ACCUM[3],ACCUM[2],0,3); SCAN; ERRORTOG~FALSE; FILETOG~TRUE ; 00769600 - IF R1~IF R2~NEXT=18 THEN INTID ELSE IF R3=26 THEN REALID ELSE 0& 00769700 - (IF R3=10 THEN DOUBTYPE ELSE IF R3=19 THEN LOGTYPE ELSE IF R3=00769800 - 6 THEN COMPTYPE ELSE 0)[TOSUBCL]=0 THEN 00769900 - BEGIN FLOG(182); GO X END ; 00770000 - SCN~2; SCAN ; 00770100 - IF NEXT = STAR THEN IF R3!10 THEN 00770200 - BEGIN SCAN ; 00770300 - IF NEXT=NUM AND NUMTYPE=INTYPE THEN 00770400 - BEGIN 00770500 - IF FNEXT=4 THEN BEGIN IF R3=6 THEN FLAG(176); GO L END ; 00770600 - IF FNEXT=8 THEN 00770700 - BEGIN 00770800 - IF R3=26 THEN R1~0&DOUBTYPE[TOSUBCL] 00770900 - ELSE IF R3!6 THEN FLAG(177) ; 00771000 - GO L; 00771100 - END ; 00771200 - END ; 00771300 - FLAG(IF R3=26 THEN 178 ELSE 177-REAL(R3=6)) ; 00771400 -L: NCR~REAL(NCR.[30:3]!0)+3"677777"+NCR; SCN~1; SCAN ; 00771500 - END ; 00771600 - IF NEXT!LPAREN THEN BEGIN FLOG(106); GO X END ; 00771700 -A: SCAN; R4~ERRORCT ; 00771800 - IF R2~NAME.[12:6]<17 OR (R2>25 AND R2<33) OR (R2>41 AND R2<50) 00771900 - OR R2>57 OR NAME.[18:30]!" " THEN FLAG(179) ; 00772000 - SCAN ; 00772100 - IF NEXT!MINUS THEN 00772200 - BEGIN IF ERRORCT=R4 THEN TIPE[IF R2!"0" THEN R2 ELSE 12]~R1 END00772300 - ELSE BEGIN 00772400 - SCAN ; 00772500 - IF R3~NAME.[12:6]<17 OR (R3>25 AND R3<33) OR (R3>41 AND R3<50) 00772600 - OR R3>57 OR NAME.[18:30]!" " THEN FLAG(179) ; 00772700 - IF R3 LEQ R2 THEN FLAG(180) ; 00772800 - IF ERRORCT=R4 THEN FOR R2~R2 STEP 1 UNTIL R3 DO 00772900 - BEGIN 00773000 - IF R2>25 AND R2<33 THEN R2~33 ELSE IF R2>41 AND R2<50 00773100 - THEN R2~50 ; 00773200 - TIPE[IF R2!"0" THEN R2 ELSE 12]~R1 ; 00773300 - END ; 00773400 - SCAN ; 00773500 - END ; 00773600 - IF NEXT=COMMA THEN GO A ; 00773700 - IF NEXT!RPAREN THEN BEGIN FLOG(108); GO X END ; 00773800 - SCAN; IF NEXT=COMMA THEN GO R ; 00773900 - IF NEXT!SEMI THEN BEGIN FLOG(117); GO X END ; 00774000 - IF SPLINK > 1 THEN 00774100 - BEGIN 00774200 - IF BOOLEAN(TYPE.[2:1]) THEN IF GET(SPLINK).CLASS=FUNID THEN 00774300 - BEGIN 00774400 - INFO[SPLINK.IR,SPLINK.IC].SUBCLASS~R3~TIPE[IF R3~GET( 00774500 - SPLINK+1).[12:6]!"0" THEN R3 ELSE 12].SUBCLASS ; 00774600 - INFO[FUNVAR.IR,FUNVAR.IC].SUBCLASS~R3 ; 00774700 - END ; 00774800 - IF R1~GET(SPLINK+2)<0 THEN 00774900 - FOR R2~R1.NEXTRA-1+R1~R1.ADINFO STEP -1 UNTIL R1 DO 00775000 - IF R3~PARMLINK[R2-R1+1]!0 THEN 00775100 - BEGIN 00775200 - EXTRAINFO[R2.IR,R2.IC].SUBCLASS~R4~TIPE[IF R4~ 00775300 - GET(R3+1).[12:6]!"0" THEN R4 ELSE 12] 00775400 - .SUBCLASS ; 00775500 - INFO[R3.IR,R3.IC].SUBCLASS~R4 ; 00775600 - END ; 00775700 - END ; 00775800 -X: WHILE NEXT!SEMI DO SCAN; FILETOG~FALSE ; 00775900 - END OF IMPLICIT ; 00776000 - 00776100 -PROCEDURE SUBROUTINE; 00776200 -BEGIN 00776300 - IF SPLINK NEQ 0 THEN BEGIN FLAG(5); ENDS; SEGMENTSTART; END; 00776400 - LABL ~ BLANKS; 00776500 - FORMALPP(FALSE, SUBRID); 00776600 - SPLINK ~ FNEW; 00776700 -END SUBROUTINE; 00776800 -PROCEDURE MEMHANDLER(N); VALUE N; REAL N ; 00776900 - BEGIN 00777000 - REAL A ; 00777100 - LABEL L1,L2,L3,XIT ; 00777200 - IF DEBUGTOG THEN FLAGROUTINE(" MEMHA","NDLER ",TRUE) ; 00777300 - IF N LEQ 2 THEN 00777400 - BEGIN % FIXED=1, VARYING=2. 00777500 - N~IF N=1 THEN 6 ELSE 0 ; 00777600 -L1: SCAN; 00777700 - IF NEXT!ID THEN BEGIN FLOG(105); GO XIT END ; 00777800 - IF (A~GET(GETSPACE(FNEXT))).CLASS!ARRAYID THEN 00777900 - BEGIN FLOG(35); GO XIT END ; 00778000 - IF XREF THEN ENTERX(XTA,0&A[15:15:9]) ; 00778100 - IF BOOLEAN(A.EQ) OR BOOLEAN(A.FORMAL) THEN FLAG(169) 00778200 - ELSE BEGIN 00778300 - EMITO(MKS); EMITPAIR(A.ADDR,LOD); EMITL(N) ; 00778400 - EMITV(NEED(".MEMHR",INTRFUNID)) ; 00778500 - END ; 00778600 - SCAN; IF NEXT=COMMA THEN GO L1 ; 00778700 - END 00778800 - ELSE IF N=3 THEN 00778900 - BEGIN % AUXMEMED FUNCTION OR SUBROUTINE. 00779000 - SCAN ; 00779100 - IF NEXT!ID THEN BEGIN FLOG(105); GO XIT END ; 00779200 - IF GET(FNEXT+1)!GET(SPLINK+1) THEN 00779300 - BEGIN FLOG(170); GO XIT END ; 00779400 - PUT(SPLINK,GET(SPLINK)&1[TOADJ]) ; 00779500 - IF XREF THEN ENTERX(XTA,0&GET(FNEXT)[15:15:9]); SCAN ; 00779600 - END 00779700 - ELSE BEGIN % RELEASE. 00779800 -L2: SCAN ; 00779900 - IF NEXT!ID THEN BEGIN FLOG(105); GO XIT END ; 00780000 - IF (A~GET(GETSPACE(FNEXT))).CLASS=ARRAYID THEN 00780100 - BEGIN 00780200 - IF BOOLEAN(A.EQ) OR BOOLEAN(A.FORMAL) THEN FLAG(169) 00780300 - ELSE BEGIN 00780400 - EMITO(MKS); EMITPAIR(A.ADDR,LOD) ; 00780500 - EMITPAIR(1,SSN) ; 00780600 - EMITV(NEED(".MEMHR",INTRFUNID)) ; 00780700 - END ; 00780800 -L3: IF XREF THEN ENTERX(XTA,0&A[15:15:9]) ; 00780900 - END 00781000 - ELSE IF A.CLASS}BLOCKID OR A.CLASS{LABELID THEN 00781100 - BEGIN FLOG(171); GO XIT END 00781200 - ELSE BEGIN 00781300 - EMITPAIR(A.ADDR,LOD); EMITPAIR(38,KOM) ; 00781400 - EMITO(DEL); GO L3 ; 00781500 - END ; 00781600 - SCAN; IF NEXT=COMMA THEN GO L2 ; 00781700 - END ; 00781800 -XIT:IF DEBUGTOG THEN FLAGROUTINE(" MEMHA","NDLER ",FALSE) ; 00781900 - END OF MEMHANDLER ; 00782000 -PROCEDURE STATEMENT; 00782100 -BEGIN LABEL DOL1, XIT; 00782200 - REAL TEMPNEXT ; 00782300 - BOOLEAN ENDTOG; %112-00782400 - DO SCAN UNTIL NEXT ! SEMI; 00782500 - IF NEXT=ID THEN ASSIGNMENT ELSE IF NEXT LEQ RSH1 THEN 00782600 - CASE(TEMPNEXT~NEXT) OF 00782700 - BEGIN 00782800 - FLOG(16); 00782900 - ASSIGN; 00783000 - IOCOMMAND(4); %BACKSPACE 00783100 - BLOCKDATA; 00783200 - CALL; 00783300 - COMMON; 00783400 - COMPLEX; 00783500 - BEGIN EXECUTABLE; SCAN END; % CONTINUE 00783600 - IOCOMMAND(7); % DATA 00783700 - BEGIN SCAN; TYPE ~ -1; DIMENSION END; 00783800 - DOUBLEPRECISION; 00783900 - BEGIN ENDS; ENDTOG:=TRUE; SCAN END; %112-00784000 - FILECONTROL(1); %ENDFILE 00784100 - ENTRY; 00784200 - EQUIVALENCE; 00784300 - EXTERNAL; 00784400 - BEGIN TYPE ~ -1; FUNCTION END; 00784500 - GOTOS; 00784600 - INTEGERS; 00784700 - LOGICAL; 00784800 - NAMEL; 00784900 - PAUSE; 00785000 - IOCOMMAND(2); %PRINT 00785100 - ; 00785200 - IOCOMMAND(3); %PUNCH 00785300 - IOCOMMAND(0); %READ 00785400 - REALS; 00785500 - RETURN; 00785600 - FILECONTROL(0); %REWIND 00785700 - BEGIN SCAN; STOP END; 00785800 - SUBROUTINE; 00785900 - IOCOMMAND(1); %WRITE 00786000 - FILECONTROL(7); %CLOSE 00786100 - FILECONTROL(6); %LOCK 00786200 - FILECONTROL(4); %PURGE 00786300 - IFS; 00786400 - FORMATER; 00786500 - CHAIN; 00786600 - MEMHANDLER(1) ; %FIXED 00786700 - MEMHANDLER(2) ; %VARYING 00786800 - MEMHANDLER(3) ; %AUXMEM FOR SUBPROGRAMS 00786900 - MEMHANDLER(4) ; %RELEASE 00787000 - IMPLICIT ; 00787100 - END ELSE IF NEXT=EOF THEN GO XIT ELSE BEGIN NEXT~0; FLOG(16) END ; 00787200 - LASTNEXT.[33:15]~TEMPNEXT ; 00787300 - IF NOT ENDTOG THEN IF SPLINK=0 THEN SPLINK:=1; %112-00787400 - ENDTOG:=FALSE; %112-00787500 - IF LABL ! BLANKS THEN 00787600 - BEGIN 00787700 - IF DT ! 0 THEN 00787800 - BEGIN 00787900 - DOL1: IF LABL = DOLAB[TEST ~ DT] THEN 00788000 - BEGIN 00788100 - EMITB(DOTEST[DT], FALSE); 00788200 - FIXB(DOTEST[DT].ADDR); 00788300 - IF DT ~ DT-1 > 0 THEN GO TO DOL1; 00788400 - END ELSE 00788500 - WHILE TEST ~ TEST-1 > 0 DO 00788600 - IF DOLAB[TEST] = LABL THEN FLAG(14); 00788700 - END; 00788800 - LABL ~ BLANKS; 00788900 - END; 00789000 - IF NEXT ! SEMI THEN 00789100 - BEGIN 00789200 - FLAG(117); 00789300 - DO SCAN UNTIL NEXT=SEMI OR NEXT=EOF ; 00789400 - END; 00789500 - ERRORTOG ~ FALSE; 00789600 - EOSTOG ~ TRUE; 00789700 - XIT: 00789800 -END STATEMENT; 00789900 - 00790000 -BOOLEAN STREAM PROCEDURE FLAGLAST(BUFF,ERR) ; 00790100 - BEGIN 00790200 - LOCAL A; SI~ERR; 8(IF SC!" " THEN JUMP OUT;SI~SI+1;TALLY~TALLY+1);00790300 - A~TALLY; SI~LOC A; SI~SI+7 ; 00790400 - IF SC<"8" THEN 00790500 - BEGIN TALLY~1; FLAGLAST~TALLY ; 00790600 - DI~BUFF;DS~46 LIT"LAST SYNTAX ERROR OCCURRED AT SEQUENCE NUMBER ";00790700 - DS~LIT"""; SI~ERR; DS~8 CHR; DS~LIT"""; 00790800 - DS~32 LIT " "; %510-00790900 - DS~32 LIT " "; %510-00791000 - END 00791100 - END FLAGLAST ; 00791200 -INTEGER PROCEDURE FIELD(X); VALUE X; INTEGER X; 00791300 -FIELD~IF X<10 THEN 1 ELSE IF X<100 THEN 2 ELSE IF X<1000 THEN 3 ELSE IF 00791400 -X<10000 THEN 4 ELSE IF X<100000 THEN 5 ELSE IF X<1000000 THEN 6 ELSE 7; 00791500 -FORMAT EOC1(/ "NUMBER OF SYNTAX ERRORS DETECTED = ",I*,".",X*, 00791600 - "NUMBER OF SEQUENCE ERRORS DETECTED = ",I*,"."), 00791700 - EOC2("PRT SIZE = ",I*,"; TOTAL SEGMENT SIZE = ",I*, 00791800 - " WORDS; DISK SIZE = ",I*," SEGS; NO. PRGM. SEGS = ",I*, 00791900 - "."), 00792000 - EOC3("ESTIMATED CORE STORAGE REQUIREMENT = ",I*," WORDS;", 00792100 - " COMPILATION TIME = ",I*," MIN, ",I*," SECS;", 00792200 - " NO. CARDS = ",I*,"."), 00792300 - EOC4("ESTIMATED CORE STORAGE REQUIREMENT = ",I*," WORDS;" 00792400 - " COMPILATION TIME = ",I*," SECS; NO. CARDS = ",I*,"."), 00792500 - EOC5("NUMBER OF TSS WARNINGS DETECTED = ",I*,".") ; 00792600 -COMMENT MAIN DRIVER FOR FORTRAN COMPILER BEGINS HERE; 00792700 -RTI ~ TIME(1); 00792800 -INITIALIZATION; 00792900 - DO STATEMENT UNTIL NEXT = EOF; 00793000 - IF NOT ENDSEGTOG THEN IF SPLINK NEQ 0 %112-00793100 - THEN BEGIN XTA:=BLANKS; FLAG(5); ENDS END; %112-00793200 - WRAPUP; 00793300 -POSTWRAPUP: 00793400 -IF TIMETOG THEN IF FIRSTCALL THEN DATIME; 00793500 -IF NOT FIRSTCALL THEN 00793600 - BEGIN 00793700 - WRITE(RITE,EOC1,FIELD(ERRORCT),ERRORCT,IF SEQERRCT=0 THEN 99 ELSE 00793800 - 5,FIELD(SEQERRCT-1),SEQERRCT-1) ; 00793900 - IF WARNED AND NOT DCINPUT THEN WRITE(RITE,EOC5,FIELD(WARNCOUNT), 00794000 - WARNCOUNT) ; 00794100 - WRITE(RITE,EOC2,FIELD(PRTS),PRTS,FIELD(TSEGSZ),TSEGSZ,FIELD(DALOC-1),00794200 - DALOC-1,FIELD(NXAVIL),NXAVIL) ; 00794300 - IF C1~(TIME(1)-RTI)/60 > 59 THEN WRITE(RITE,EOC3,FIELD(64|ESTIMATE), 00794400 - 64|ESTIMATE,FIELD(C1 DIV 60),C1 DIV 60,FIELD(C1 MOD 60),C1 MOD 60, 00794500 - FIELD(CARDCOUNT-1),CARDCOUNT-1) ELSE WRITE(RITE,EOC4,FIELD(ESTIMATE 00794600 - |64),ESTIMATE|64,FIELD(C1),C1,FIELD(CARDCOUNT-1),CARDCOUNT-1) ; 00794700 - IF ERRORCT>0 THEN IF FLAGLAST(ERRORBUFF,LASTERR) THEN WRITE(RITE,15, 00794800 - ERRORBUFF[*]) ; 00794900 - END ; 00795000 -END INNER BLOCK; 00795100 -END. 00795200 + IF IT~IT+1=9 THEN 00723630 + BEGIN LASTLINE~FALSE; WRITE(LINE,15,PRINTBUFF[*]) ; 00723640 +L6: BLANKIT(PRINTBUFF,15,IT~0) ; 00723650 + END; 00723660 + SETPNT(REC[0],REC[1],PRINTBUFF,KLASS[REC[2].CLASS],TYPES[REC[2]00723670 + .SUBCLASS],IF BOOLEAN(REC[2]) THEN "*" ELSE " ",IT,L-1, 00723680 + LASTLINE,6-REC[2].[27:3]) ; 00723690 + END 00723700 + ELSE BEGIN 00723710 + LASTLINE~TRUE; WRITE(RITE,15,PRINTBUFF[*]); XTA~REC[0] ;00723720 + GO L6 ; 00723730 + END ; 00723740 +END OF PT ; 00723800 01868000 +PROCEDURE CHECKINFO; 00724000 +BEGIN REAL I, T, A; 00725000 + REAL LASTF; 00725100 + REAL INFB,INFC; 00726000 + LABEL NXT; ALPHA N; 00727000 + FORMAT INFOF( 3(A6, X2), 00728000 + " ADDRESS = ", A2, A4, 00729000 + ", LENGTH = ", I5, 00730000 + ", OFFSET = ", I5), 00731000 + INFOT( / "LOCAL IDENTIFIERS:"), 00732000 + LABF(A6,X10,"LABEL REL-ADR = ",I6,", SEGMNT = ",I5); 00733000 + IF PRTOG THEN 00734000 + WRITALIST(INFOT,0,0,0,0,0,0,0,0,0) ; 00735000 + IF I ~ SEARCH("ERR ") ! 0 THEN 00736000 + IF GET(I).CLASS = UNKNOWN THEN PUT(I+1, "......"); 00737000 + IF I ~ SEARCH("END ") ! 0 THEN 00738000 + IF GET(I).CLASS = UNKNOWN THEN PUT(I+1, "......"); 00739000 + IF NOT DCINPUT THEN IF I~SEARCH("ZIP ") ! 0 THEN 00739100 + IF GET(I).CLASS=UNKNOWN THEN PUT(I+1,"......") ; 00739200 + FOR I ~ 0 STEP 1 UNTIL NEXTCOM DO 00740000 + IF GETC(I).CLASS=HEADER THEN 00741000 + 00742000 + IF GETC(I).CE=1 THEN 00743000 + PUT((T~GETC(I+1).LINK+2),GET(T)&0[TOADINFO]) ; 00744000 + 00745000 + T ~ 2; WHILE T < NEXTINFO DO 00746000 + BEGIN 00747000 + GETALL(T,A,INFB,INFC); 00748000 + IF I ~ A.CLASS > FILEID THEN GO TO NXT; 00749000 + IF N ~ INFB = "......" THEN GO TO NXT; 00750000 + XTA ~ N; 00751000 + IF I = LABELID THEN 00752000 + BEGIN 00753000 + IF A > 0 THEN FLAG(19) ELSE 00754000 + IF PRTOG THEN WRITALIST(LABF,3,N,A.ADDR DIV 4,A.SEGNO,0,0,0,0, 00755000 + 0) ; 00755010 + GO TO NXT; 00756000 + END; 00757000 + IF I = FORMATID THEN 00758000 + IF A > 0 THEN BEGIN FLAG(62); GO TO NXT END ; 00759000 + IF I = NAMELIST THEN 00760000 + IF A > 0 THEN BEGIN FLAG(136); GO TO NXT END; 00761000 + IF I = ARRAYID THEN 00762000 + IF BOOLEAN(A.CE) THEN BEGIN IF A>0 THEN T~GETSPACE(T) END 00763000 + ELSE IF A<0 THEN 00764000 + IF BOOLEAN(A.FORMAL) THEN 00764020 + BEGIN IF SPLINK > 1 AND ELX > 1 THEN 00764040 + BEGIN % THIS IS A FORMAL PARAMETER FOR A SUBROUTINE OR A 00764060 + % FUNCTION THAT HAS ONE OR MORE ENTRY STATEMENT. THIS 00764070 + % PARAMETER WILL BE INITIALIZED TO AN ARRAY DESCRIPTOR00764080 + % TO 0 SO THAT IF THE PARAMETERS ARE NOT SET UP BY THE00764090 + % CALL ANY REFERENCE TO THEM WILL CAUSE AN INVALID 00764100 + % ADDRESS 00764110 + IF LASTF = 0 THEN % FIRST TIME THRU 00764150 + BEGIN LASTF ~ A.ADDR; 00764200 + EMITDESCLIT(2); EMITL(1); 00764220 + EMITD(50,DIA); EMITD(10,DIB); EMITD(10,TRB); 00764240 + END ELSE EMITPAIR(LASTF,LOD); 00764260 + EMITPAIR(A.ADDR,SND); 00764280 + END 00764300 + END 00764320 + ELSE ARRAYDEC(T); 00765000 + IF PRTOG THEN 00766000 + WRITALIST(INFOF,7,INFB, 00767000 + IF BOOLEAN(A.TYPEFIXED) THEN TYPES[A.SUBCLASS] ELSE " ", 00768000 + KLASS[A.CLASS], 00769000 + IF A.ADDR < 1024 AND A < 0 THEN "R+" ELSE " ", 00770000 + IF A < 0 THEN B2D(A.[26:10]) ELSE "NULL", 00771000 + INFC.SIZE, 00772000 + INFC.BASE,0); 00773000 + IF BOOLEAN(A.CE) THEN IF A.SUBCLASS } DOUBTYPE THEN 00773100 + IF BOOLEAN(INFC.BASE) THEN FLAG(146); 00773200 + NXT: 00774000 + T ~ T+3; 00775000 + END; 00776000 +END CHECKINFO; 00777000 +PROCEDURE SEGMENTSTART; 00778000 +BEGIN 00779000 + NSEG ~ NXAVIL ~ NXAVIL + 1; 00780000 + IF LISTOG THEN WRITALIST(SEGSTRT,1,NSEG,0,0,0,0,0,0,0) ; 00781000 + DEBUGADR~ADR~-1; 00782000 + IF NOT SEGOVFLAG THEN 00783000 + BEGIN 00784000 + DATAPRT~DATASTRT~DATALINK~DATASKP~ 00784100 + LABELMOM ~ BRANCHX ~ FUNVAR ~ 00785000 + DT ~ SPLINK ~ NEXTCOM ~ ELX ~ 0; 00786000 + NEXTSS ~ 1022; 00787000 + INITIALSEGNO ~ NSEG; 00788000 + FOR I ~ 0 STEP 1 UNTIL LBRANCH DO BRANCHES[I] ~ I+1; 00789000 + FOR I~0 STEP 1 UNTIL SHX DO STACKHEAD[I] ~ 0; 00790000 + NEXTINFO ~ LOCALS ~ 2; 00791000 + F2TOG ~ FALSE; RETURNFOUND ~ FALSE; 00792000 + END; 00793000 + ENDSEGTOG ~ FALSE; 00794000 + IF SEGSW THEN LINESEG[NOLIN~0,0]~0 & D2B(LASTSEQ)[10:20:28] ; 00794400 +END SEGMENTSTART; 00795000 +PROCEDURE FIXPARAMS(I); VALUE I; INTEGER I; 00796000 +BEGIN 00797000 + REAL FMINUS, NPARMS, ELINK, LABX; 00798000 + REAL PLINKX, PLINK; 00799000 + REAL PTYPEX, PTYPE; 00800000 + REAL CL, INF; 00801000 + LABEL ARRY, LOAD, INDX; 00802000 + REAL EWORD; 00803000 +IF DEBUGTOG THEN FLAGROUTINE(" FIXP","ARMS ",TRUE); 00803010 + EWORD ~ ENTRYLINK[I]; 00804000 + ELINK ~ EWORD.LINK; 00805000 + IF LABX ~ EWORD.CLASS > 0 THEN 00806000 + BEGIN 00807000 + EMITO(MKS); 00808000 + EMITDESCLIT(LABELMOM); 00809000 + EMITL(LABX); 00810000 + EMITL(1); EMITL(1); EMITL(0); 00811000 + EMITOPDCLIT(BLKCNTRLINT); 00812000 + EMITL(1); EMITPAIR(FPLUS2,STD);% F+2~TRUE FOR BLKXIT CALL 00812400 + END; %106-00813000 + FMINUS ~ 1920; 00814000 + NPARMS ~ (J~GET(ELINK+2)).NEXTRA; 00815000 + IF NPARMS > 0 THEN %106-00816000 + BEGIN 00817000 + PLINKX ~ EWORD.ADDR-NPARMS+1; 00818000 + PTYPEX ~ J.ADINFO + NPARMS-1; 00819000 + FOR J ~ 1 STEP 1 UNTIL NPARMS DO 00820000 + BEGIN 00821000 + PLINK ~ EXTRAINFO[PLINKX.IR,PLINKX.IC]; 00822000 + PTYPE ~ EXTRAINFO[PTYPEX.IR,PTYPEX.IC].CLASS; 00823000 + FMINUS ~ FMINUS+1; 00824000 + IF PLINK = 0 THEN 00825000 + BEGIN 00826000 + EMITOPDCLIT(FMINUS); 00827000 + EMITL(LABX ~ LABX-1); 00828000 + EMITDESCLIT(LABELMOM); 00829000 + EMITO(STD); 00830000 + END ELSE 00831000 + BEGIN 00832000 + IF CL ~ (INF ~ GET(PLINK)).CLASS = UNKNOWN THEN CL ~ VARID; 00833000 + XTA ~ GET(PLINK+1); 00834000 + IF PTYPE = 0 THEN EXTRAINFO[PTYPEX.IR,PTYPEX.IC].CLASS 00835000 + ~ PTYPE ~ CL; 00836000 + CASE PTYPE OF 00837000 + BEGIN ; 00838000 + IF CL ! ARRAYID THEN FLAG(79) ELSE 00839000 + ARRY: 00840000 + BEGIN 00841000 + FMINUS ~ FMINUS+1; 00842000 + IF INF < 0 THEN 00843000 + BEGIN 00844000 + EMITPAIR(FMINUS, LOD); 00845000 + EMITPAIR(T~INF.ADDR, STD); 00846000 + EMITOPDCLIT(FMINUS-1); 00847000 + EMITPAIR(T-1, STD); 00848000 + END; 00849000 + END; 00850000 + IF CL ! VARID THEN FLAG(80) ELSE 00851000 + LOAD: 00852000 + BEGIN 00854000 + IF INF.SUBCLASS}DOUBTYPE AND CL=VARID THEN FMINUS~FMINUS+1; 00854100 + IF INF<0 THEN 00854200 + BEGIN 00854300 + EMITPAIR(FMINUS, LOD); 00855000 + EMITPAIR(T~INF.ADDR,STD); 00856000 + IF INF.SUBCLASS}DOUBTYPE AND CL=VARID THEN %105-10856100 + BEGIN EMITOPDCLIT(FMINUS-1); 00856200 + EMITPAIR(T+1,STD); 00856300 + END; 00856400 + END ; 00856500 + END; 00857000 + ; ; ; ; 00858000 + IF CL = FUNID THEN GO TO LOAD ELSE FLAG(81); 00859000 + 00859100 + 00859200 + 00859300 + 00859400 + 00859500 + ; 00860000 + IF CL = FUNID OR CL = SUBRID OR CL = EXTID THEN GO TO LOAD 00861000 + ELSE FLAG(83); 00861100 + IF CL = SUBRID THEN GO TO LOAD ELSE FLAG(82); 00862000 + ; ; 00863000 + BEGIN 00864000 + IF CL = ARRAYID THEN 00865000 + BEGIN 00866000 + EXTRAINFO[PTYPEX.IR,PTYPEX.IC].CLASS ~ CL; 00867000 + GO TO ARRY; 00868000 + END; 00869000 + INDX: 00870000 + IF CL ! VARID THEN FLAG(80); 00871000 + FMINUS ~ FMINUS+1; 00872000 + IF INF < 0 THEN 00873000 + BEGIN 00874000 + EMITOPDCLIT(FMINUS-1); 00875000 + EMITDESCLIT(FMINUS); 00876000 + EMITPAIR(INF.ADDR, STD); 00877000 + END; 00878000 + END; 00879000 + IF CL = VARID THEN GO TO LOAD ELSE FLAG(80); 00880000 + GO TO INDX; 00892000 + END CASE STATEMENT; 00893000 + A ~ INF.SUBCLASS; 00894000 + IF T ~ EXTRAINFO[PTYPEX.IR,PTYPEX.IC].SUBCLASS = 0 OR 00895000 + T = INTYPE AND A = REALTYPE THEN 00896000 + EXTRAINFO[PTYPEX.IR,PTYPEX.IC].SUBCLASS ~ A ELSE 00897000 + IF T ! A THEN 00898000 + BEGIN XTA ~ GET(PLINK+1); FLAG(88) END; 00899000 + END; 00900000 + PLINKX ~ PLINKX+1; 00901000 + PTYPEX ~ PTYPEX-1; 00902000 + END; 00903000 + PLINKX ~ PLINKX-NPARMS; 00904000 + FOR J ~ 1 STEP 1 UNTIL NPARMS DO 00905000 + BEGIN 00906000 + PLINK ~ EXTRAINFO[PLINKX.IR,PLINKX.IC]; 00907000 + IF PLINK ! 0 THEN 00908000 + IF (A~GET(PLINK)).CLASS = ARRAYID THEN 00909000 + IF T~GET(PLINK+2) <0 THEN VARIABLEDIMS(A, T); 00910000 + PLINKX ~ PLINKX+1; 00911000 + END; 00912000 + END; 00913000 + EMITB(GET(ELINK+2).BASE & (GET(ELINK).SEGNO)[TOSEGNO], FALSE); 00914000 +IF DEBUGTOG THEN FLAGROUTINE(" FIXP","ARMS ",FALSE) ; 00914010 +END FIXPARAMS; 00915000 +PROCEDURE XREFCORESORT ; 00915100 + BEGIN 00915120 + REAL F,G,H,J,K,L,T,TT,IJ,M,TN ; 00915140 + SAVE ARRAY A[0:XRI-1], IL,IU[0:8]; 00915160 + ARRAY W2,W3[0:XRI-1] ; 00915180 + LABEL L1,L2,L3,L4,L5,L6,L11,L12,L13,L14 ; 00915200 + DEFINE CMPARGT(A) = A.NAME=TN THEN IF (IF G~W3[H~A.[2:10]].[26:4] 00915220 + =TT~W3[F~T.[2:10]].[26:4] THEN NOT CMPA(W2[H], 00915240 + W2[F]) ELSE G>TT) #, 00915260 + CMPARLS(A) = A.NAME=TN THEN IF (IF G~W3[H~T.[2:10]].[26:4] 00915280 + =TT~W3[F~A.[2:10]].[26:4] THEN NOT CMPA(W2[H], 00915300 + W2[F]) ELSE G>TT) #, 00915320 + NAME = [12:36] # ; 00915340 + J~XRI-1; G~XRI DIV K~XRBUFFDIV3; H~XRBUFF ; 00915360 + FOR L~1 STEP 1 UNTIL G DO 00915380 + BEGIN 00915400 +L11: READ(XREFF,H,XRRY[*]); TRANSFER(W2[T~(L-1)|50],XRRY,K) ; 00915420 + IJ~T+K-1; TN~-3; 00915440 + FOR F~T STEP 1 UNTIL IJ DO 00915460 + BEGIN A[F]~XRRY[TN~TN+3]&F[2:38:10]; W3[F]~XRRY[TN+2] END;00915480 + END; 00915500 + IF H=XRBUFF THEN IF K~XRI MOD K DIV 1!0 THEN BEGIN H~3|K;GO L11 END;00915520 + GO L4 ; 00915540 +L1: IF A[K~I].NAME>TN~(T~A[IJ~((L~J)+I+1).[37:10]]).NAME THEN 00915560 +L12: BEGIN A[IJ]~A[I]; A[I]~T; TN~(T~A[IJ]).NAME END 00915580 + ELSE IF CMPARGT(A[I]) THEN GO L12 ; 00915600 + IF A[J].NAMETN THEN GO L2; IF CMPARGT(A[L]) THEN GO L2; 00915780 +L3: IF A[K~K+1].NAMEJ+I THEN BEGIN IL[M]~I; IU[M]~L; I~K END 00915840 + ELSE BEGIN IL[M]~K; IU[M]~J; J~L END ; 00915860 + M~M+1 ; 00915880 +L4: IF I+10TN~(T~A[I]).NAME THEN 00915960 + BEGIN 00915980 +L5: A[K+1]~A[K]; IF A[K~K-1].NAME>TN THEN GO L5 ; 00916000 + IF CMPARGT(A[K]) THEN GO L5 ; 00916020 + A[K+1]~T ; 00916040 + END 00916060 + ELSE IF CMPARGT(A[K]) THEN GO L5 ; 00916080 + IF (M~M-1) GEQ 0 THEN BEGIN I~IL[M]; J~IU[M]; GO L4 END ; 00916100 + G~XRI-1 ; 00916120 + FOR I~ 0 STEP 1 UNTIL G DO 00916140 + IF BOOLEAN(L~REAL(A[I]~A[I].NAME&(TN~W3[J~A[I].[2:10]])[1:26:1]00916160 + =XTA)) THEN 00916180 + BEGIN 00916200 + IF IT~IT+1=9 THEN 00916220 + BEGIN LASTLINE~FALSE; WRITE(LINE,15,PRINTBUFF[*]) ; 00916240 +L6: BLANKIT(PRINTBUFF,15,IT~0) ; 00916260 + END ; 00916280 + SETPNT(A[I],W2[J],PRINTBUFF,KLASS[TN.CLASS],TYPES[TN. 00916300 + SUBCLASS],IF BOOLEAN(TN) THEN "*" ELSE " ",IT,L-1, 00916320 + LASTLINE,6-TN.[27:3]) ; 00916340 + END 00916360 + ELSE BEGIN 00916380 + LASTLINE~TRUE; WRITE(RITE,15,PRINTBUFF[*]); XTA~A[I]; 00916400 + GO L6; 00916420 + END ; 00916440 + WRITE(LINE,15,PRINTBUFF[*]); XRI~0; 00916460 + END OF XREFCORESORT ; 00916480 +PROCEDURE SETUPSTACK ; 00916900 +BEGIN 00917000 + REAL I; 00918000 + EMITOPDCLIT(16); 00919000 + EMITL(1); 00920000 + EMITO(ADD); 00921000 + EMITL(16); 00922000 + EMITO(SND); 00923000 + FOR I ~ 1 STEP 1 UNTIL LOCALS DO EMITL(0); 00924000 + CHECKINFO; 00925000 + IF DATAPRT ! 0 THEN 00925010 + BEGIN ADJUST; EMITOPDCLIT(DATAPRT); EMITO(LNG); EMITB(-1,TRUE);00925020 + DATASKP~LAX; EMITB(DATASTRT,FALSE); FIXB(DATALINK); 00925030 + EMITL(1); EMITPAIR(DATAPRT,STD); FIXB(DATASKP); 00925040 + END; 00925050 + ADJUST; 00925060 +END SETUPSTACK; 00926000 +PROCEDURE BRANCHLIT(X,Y); VALUE X,Y; REAL X; BOOLEAN Y; 00927000 +BEGIN 00928000 + IF ADR } 4075 THEN 00929000 + BEGIN ADR ~ ADR+1; SEGOVF END; 00930000 + ADJUST; 00931000 + IF X.SEGNO!NSEG THEN BEGIN 00932000 + IF(PRTS+1).[37:2]=1 AND Y THEN 00932300 + EMITOPDCLIT(PRGDESCBLDR(2,0,(ADR+5) DIV 4+1,NSEG)) 00932700 + ELSE EMITOPDCLIT(PRGDESCBLDR(2,0,(ADR+5) DIV 4,NSEG)) END 00933000 + ELSE 00934000 + EMITL((ADR+5) DIV 4 - X.LINK DIV 4) ; 00935000 +END BRANCHLIT; 00936000 +PROCEDURE SEGMENT(SZ,CURSEG,SEGTYP,EDOC); % WRITES OUT EDOC AS SEGMENT 00937000 + VALUE SZ,CURSEG,SEGTYP; % UPDATES PDPRT WITH PSUEDO 00938000 + REAL SZ,CURSEG; % UPDATES PDPRT WITH PSUEDO 00939000 + BOOLEAN SEGTYP; % TRUE TO WRAP UP A SUBROUTINE BLOCK 00940000 + % FALSE TO WRAP UP A SPLIT BLOCK 00941000 + ARRAY EDOC[0,0]; % CONTAINS DATA TO WRITE; 00942000 + BEGIN 00943000 + STREAM PROCEDURE M1(F,T); BEGIN DI ~ T; SI ~ F; DS ~ 2 WDS END;00944000 + REAL T; 00945000 + REAL BEGINSUB, ENDSUB, HERE; 00946000 + LABEL WRITEPGM; 00947000 + INTEGER I, CNTR; 00948000 +IF DEBUGTOG THEN FLAGROUTINE(" SEGM","ENT ",TRUE ); 00948010 + IF NOT SEGTYP THEN GO TO WRITEPGM; 00949000 + IF SPLINK > 1 AND NOT RETURNFOUND THEN 00949100 + BEGIN XTA ~ BLANKS; FLAG(142) END; 00949200 + IF SPLINK < 0 THEN 00950000 + BEGIN 00951000 + ADJUST; 00952000 + BDPRT[BDX~BDX+1] ~ PRGDESCBLDR(1, 0, (ADR+1) DIV 4, NSEG); 00953000 + FOR I ~ 1 STEP 1 UNTIL LOCALS DO EMITL(0); 00954000 + CHECKINFO; 00955000 + 00955500 + EMITB(0&INITIALSEGNO[TOSEGNO], FALSE); 00956000 + END 00957000 + ELSE 00958000 + IF SPLINK = 1 THEN % MAIN PROGRAM 00959000 + BEGIN 00960000 + ADJUST; 00961000 + IF STRTSEG ! 0 THEN FLAG(75); 00962000 + STRTSEG ~ NSEG & 00963000 + PRGDESCBLDR(1, 0, (ADR+1) DIV 4, NSEG)[18:33:15]; 00964000 + SETUPSTACK; 00965000 + 00965500 + EMITB(0&INITIALSEGNO[TOSEGNO], FALSE); 00966000 + END 00967000 + ELSE 00968000 + IF ELX { 1 THEN 00969000 + BEGIN 00970000 + ADJUST; 00971000 + T ~ PRGDESCBLDR(1, GET(SPLINK).ADDR, (ADR+1) DIV 4, NSEG); 00972000 + SETUPSTACK; 00973000 + FIXPARAMS(0); 00974000 + INFO[SPLINK.IR, SPLINK.IC].SEGNO ~ NSEG; 00975000 + END 00976000 + ELSE 00977000 + BEGIN 00978000 + ADJUST; 00979000 + BEGINSUB ~ (ADR+1) & NSEG[TOSEGNO]; 00980000 + EMITL(17); EMITO(STD); 00981000 + SETUPSTACK; 00982000 + EMITOPDCLIT(17); EMITO(GFW); 00982100 + ENDSUB ~ ADR & NSEG[TOSEGNO]; 00983000 + FOR I ~ 0 STEP 1 UNTIL ELX-1 DO 00984000 + BEGIN 00985000 + ADJUST; 00986000 + HERE ~ (ADR+1) DIV 4; 00988000 + T ~ ENTRYLINK[I].LINK; 00989000 +%VOID 00990000 + T ~ PRGDESCBLDR(1, GET(T).ADDR, HERE, NSEG); 00991000 + BRANCHLIT(ENDSUB,FALSE); 00992000 + EMITB(BEGINSUB, FALSE); 00993000 + ADJUST; 00994000 + FIXPARAMS(I); 00995000 + INFO[(ENTRYLINK[I].LINK).IR,(ENTRYLINK[I].LINK).IC].SEGNO~NSEG;00995500 + END; 00996000 + END; 00997000 + SZ ~ (ADR+4) DIV 4; 00998000 + CNTR ~ 0; 00999000 + CURSEG ~ NSEG; 00999100 + WRITEPGM: 01000000 + NSEG ~ ((T ~ SZ) + 29) DIV 30; 01001000 + IF DALOC DIV CHUNK < I ~ (DALOC+NSEG) DIV CHUNK 01002000 + THEN DALOC ~ CHUNK | I; % INSURE SEGMENT DONT BREAK 01003000 + % ACROSS ROW 01004000 + IF LISTOG THEN WRITALIST(SEGEND,2,CURSEG,T,0,0,0,0,0,0) ; 01005000 + PDPRT[PDIR,PDIC] ~ % PDPRT ENTRY FOR SEGMENT 01006000 + SZ&DALOC[DKAC] 01007000 + & GET(SPLINK)[12:41:1] 01007100 + &CURSEG[SGNOC]; 01008000 + IF ERRORCT = 0 THEN 01009000 + DO BEGIN 01010000 + FOR I~0 STEP 2 WHILE I < 30 AND CNTR < SZ DO 01011000 + BEGIN M1(EDOC[CNTR.[38:3],CNTR.[41:7]],CODE(I)); 01012000 + CNTR ~ CNTR + 2; 01013000 + END; 01014000 + WRITE(CODE[DALOC]); 01015000 + DALOC ~ DALOC +1; 01016000 + END UNTIL CNTR } SZ; 01017000 + PDINX ~ PDINX +1; 01018000 + IF NOT SEGOVFLAG THEN 01018025 + IF PXREF THEN 01018100 + IF(EODS~(NEXT=EOF))AND NOT XGLOBALS THEN ELSE 01018110 + BEGIN KLASS[6]~ "LABEL "; 01018120 + WRITE(XREFF,XRBUFF,XRRY[*]) ; 01018125 + IF FIRSTCALL THEN DATIME ELSE WRITE(PTR[PAGE]); 01018130 + IF SPLINK<0 THEN 01018135 + BEGIN WRITE(PTR,XHEDB);REWIND(XREFF);END 01018140 + ELSE 01018145 + IF EODS THEN BEGIN WRITE(PTR,XHEDG); REWIND(XREFG) END 01018150 + ELSE BEGIN REWIND(XREFF); C2~(XR[4].SUBCLASS|2+5); 01018160 + IF IT~XR[4].CLASS=FUNID THEN WRITE(PTR,XHEDF, 01018170 + XR[C2],XR[C2+1],XR[3],XR[C2+12], 01018180 + XR[C2+13],"------") 01018190 + ELSE IF IT=SUBRID THEN WRITE(PTR,XHEDS,XR[3], 01018200 + "------") ELSE WRITE(PTR,XHEDM); 01018210 + END; 01018220 + IT~XTA~0; 01018260 + LASTLINE ~ FALSE; 01018280 + BLANKIT(PRINTBUFF,15,0); 01018320 + IF XRI>1023 OR EODS THEN SORT(PT,INP,0,HV,CMP,3,4000) 01018330 + ELSE XREFCORESORT ; 01018340 + REWIND(XREFF); 01018350 + PXREF~IF XREF THEN TRUE ELSE FALSE; 01018355 + KLASS[6] ~ "ERROR "; 01018360 + IF (NOT SEGTYP AND EODS) OR (SEGTYP AND LISTOG AND 01018370 + NOT SEGPTOG) THEN WRITE (PTR[PAGE]); 01018375 + END; 01018380 + IF LISTOG AND SEGTYP AND SEGPTOG THEN WRITE(PTR[PAGE]); 01019000 + IF SEGTYP THEN 01019100 + BEGIN 01019110 + FOR I~12,17 STEP 1 UNTIL 24,39 STEP 1 UNTIL 41, 01019150 + 50 STEP 1 UNTIL 57 DO TIPE[I]~REALID ; 01019160 + FOR I~25,33 STEP 1 UNTIL 37 DO TIPE[I]~INTID ; 01019170 + LASTNEXT ~ 1000; 01019190 + END; 01019200 + ENDSEGTOG ~ TRUE; 01020000 + TSEGSZ ~ TSEGSZ + SZ; 01021000 + COMMENT IF SEGSW THEN LETS ALSO WRITE OUT THE LINE SEGMENTS 01021010 + THAT WE VE GONE TO SUCH TROUBLE BUILDING. LINESEG 01021150 + CONTAINS A CARD SEQUENCE NUMBER(BINARY) IN [10:28] 01021200 + AND THE WORD BOUNDARY ADDRESS OF THE FIRST CODE 01021250 + SYLLABLE IN [38:10]; 01021300 + IF SEGSW THEN 01021350 + IF NOLIN > 0 THEN 01021360 + BEGIN 01021400 + LINEDICT[CURSEG.IR,CURSEG.IC] ~ % UPDATE LINE DICTIONARY 01021450 + 0 & NOLIN[18:33:15] & DALOC[33:33:15];%FOR THIS SEGMENT 01021500 + CNTR ~ 0; DO BEGIN 01021550 + FOR I ~ 0 STEP 2 WHILE I<30 AND CNTR 30 THEN 30 ELSE (SZ-I)); 01046000 + WRITE(CODE[DALOC]); 01047000 + DALOC ~ DALOC +1; 01048000 + END; 01049000 + IF LISTOG THEN WRITALIST(SEGEND,2,SEG,T,0,0,0,0,0,0) ; 01050000 + TSEGSZ ~ TSEGSZ + SZ; 01051000 + END WRITEDATA; 01052000 +REAL PROCEDURE PRGDESCBLDR(DT,PRT,RELADR,SGNO); 01053000 + VALUE DT,PRT,RELADR,SGNO; 01054000 + REAL DT,PRT,RELADR,SGNO; 01055000 + BEGIN 01056000 + FORMAT FMT("PRT=",A4,", REL-ADR=",A4,", SEG=",I4,", TYPE=",A2); 01057000 + IF PRT=0 THEN BEGIN BUMPPRT; PRT~PRTS END; 01058000 + PDPRT[PDIR,PDIC] ~ 01059000 + 0&DT[DTYPC] 01060000 + &PRT[PRTAC] 01061000 + &RELADR[RELADC] 01062000 + &SGNO[SGNOC]; 01063000 + PDINX ~ PDINX +1; 01064000 + IF CODETOG THEN WRITALIST(FMT,4,B2D(PRT),B2D(RELADR),SGNO, 01065000 + IF DT=0 THEN "AE" ELSE IF DT=1 THEN "PD" ELSE "LD",0,0,0,0) ; 01066000 + PRGDESCBLDR ~ PRT; 01067000 + END PRGDESCBLDR; 01068000 +PROCEDURE EQUIV(R); VALUE R; REAL R; 01069000 +COMMENT THIS PROCEDURE FIXES UP THE INFO TABLE FOR THE EQUIV OR 01069100 + COMMON RING. THE FIRST ELEMENT PAST HAS AN OFFSET (DO NOT 01069110 + ALTER THIS) THE TYPE IS FIXED. THE OFFSET IS DETERMINED 01069120 + FROM THE FIRST. CORRECTINFO ADJUST THE OFFSET IF THERE 01069130 + IS A NEGATIVE OFFSET ON ANY ELEMENT. THE INFA[ADJ] BIT IS 01069140 + SET IF THE ELEMENT HAS A NEGATIVE OFFSET. IF THE ELEMENT 01069150 + APPEARED IN MORE THAN ONE EQUIVALENCE STATEMENT OR AN 01069160 + EQUIVALENCE STATEMENT AND A COMMON STATEMENT THE ELEMENTS 01069170 + ARE LINKED BY COM[LASTC] WHICH POINTS TO THE HEADER 01069180 + OF THAT STATEMENT; 01069190 +BEGIN 01070000 + DEFINE BASS = LOCALS #, % THESE DEFINES ARE USED TO REDUCE THE01071000 + REL = PARMS #, % STACKSIZE OF EQUIV FOR RECURSION 01071100 + I = PRTS #, 01071200 + T = LSTS #, 01071250 + Q = LSTA #, 01071400 + LAST = TV #, 01071500 + B = SAVESUBS #, 01071600 + P = NAMEIND #, 01071700 + PRTX = LSTI #, 01071800 + C = FX1 #, 01071900 + INFA = FX2 #, 01072000 + INFB = FX3 #, 01072100 + INFC = NX1 #; 01072200 + LABEL XIT, CHECK; 01073000 +IF DEBUGTOG THEN FLAGROUTINE(" EQU","IV ",TRUE) ; 01073010 + IF GETC(R) <0 THEN GO TO XIT; 01074000 + PUTC(R,-GETC(R)) ; 01075000 + PRTX ~ GROUPPRT; 01076000 + C~REAL(GETC(R).CE=1) ; 01077000 + LAST~GETC(R).LASTC-1 ; 01078000 + BASS~GETC(R+1); P~0 ; 01079000 + FOR I ~ R+2 STEP 1 UNTIL LAST DO 01080000 + BEGIN IF GETC(I).CLASS=ENDCOM THEN I~GETC(I).LINK ; 01081000 + GETALL(T~GETC(I).LINK,INFA,INFB,INFC) ; 01082000 + IF Q~INFC.SIZE=0 THEN % A SIMPLE VARIABLE 01083000 + INFC.SIZE ~ Q ~ IF INFA.SUBCLASS { LOGTYPE THEN 1 ELSE 2; 01084000 + PUT(T+2,INFC); 01085000 + IF INFA.SUBCLASS>LOGTYPE THEN SEENADOUB~TRUE; 01085500 + IF BOOLEAN(C) THEN 01086000 + BEGIN COM[PWI].RELADD~REL~P ; 01087000 + P ~ P + Q; 01088000 + END ELSE COM[PWI].RELADD~REL~BASS-GETC(I).RELADD ; 01089000 + IF INFA < 0 THEN IF INFA .ADJ = 1 THEN 01090000 + B ~ -INFC.BASE - REL ELSE B ~ INFC.BASE - REL; 01091000 + END; 01092000 + FOR I ~ R+2 STEP 1 UNTIL LAST DO 01093000 + BEGIN IF GETC(I).CLASS=ENDCOM THEN I~GETC(I).LINK ; 01094000 + GETALL(T~GETC(I).LINK,INFA,INFB,INFC) ; 01095000 + IF INFA.CLASS = 1 THEN SWARYCT ~ 1; 01095500 + P~B+GETC(I).RELADD ; 01096000 + Q ~ INFC .SIZE; 01097000 + IF INFA < 0 THEN 01098000 + BEGIN IF INFA .ADJ = 1 THEN BASS ~ -INFC .BASE ELSE 01099000 + BASS ~ INFC.BASE; 01100000 + IF P ! BASS THEN 01101000 + BEGIN XTA ~ INFB ; FLAG(2) END; 01102000 + GO TO CHECK; 01104000 + END; 01105000 + INFA ~ -INFA & PRTX[TOADDR]; 01108000 + IF INFA .CLASS = UNKNOWN THEN INFA .CLASS ~ VARID; 01109000 + INFA .TYPEFIXED ~ 1; 01110000 + INFC.BASE ~ P; 01111000 + PUT(T+2,INFC); 01112000 + IF P < 0 THEN INFA .ADJ ~ 1; 01113000 + PUT(T,INFA); 01114000 + CHECK: 01115000 + IF P+Q > LENGTH THEN LENGTH ~ P+Q; 01116000 + IF P < LOWERBOUND THEN LOWERBOUND ~ P; 01117000 + END; 01118000 + FOR I ~ R+2 STEP 1 UNTIL LAST DO 01119000 + BEGIN 01120000 + IF GETC(I).CLASS=ENDCOM THEN I~GETC(I).LINK ; 01121000 + IF T~GETC(I).LASTC!R THEN 01122000 + IF GETC(T)}0 THEN 01122500 + BEGIN R~R&LAST[3:33:15]&I[18:33:15] ; 01122550 + EQUIV(T); LAST~R.[3:15]; I~R.[18:15]; R~R.[33:15] ; 01122600 + END; 01122650 + END; 01123000 + XIT: 01124000 +IF DEBUGTOG THEN FLAGROUTINE(" EQU","IV ",FALSE) ; 01124010 +END EQUIV; 01125000 +ALPHA PROCEDURE GETSPACE(S); VALUE S; ALPHA S; 01126000 +BEGIN LABEL RPLUS, FMINUS, XIT; 01127000 + LABEL DONE; 01128000 + REAL A; 01129000 + BOOLEAN OWNID; 01129100 + IF OWNID ~ S < 0 THEN S~ -S; % IN DATA STMT, THUS OWN 01129200 + IF A ~ GET(GETSPACE~S) < 0 THEN GO TO DONE; 01130000 + IF A.CLASS GEQ 13 THEN FLAG(34) ELSE %104-01130500 +CASE A.CLASS OF 01131000 +BEGIN 01132000 +BEGIN 01133000 + PUT(S,A~A&VARID[TOCLASS]); 01134000 + PUT(S+2,(GET(S+2) &(IF A.SUBCLASS { LOGTYPE 01135000 + THEN 1 ELSE 2 )[TOSIZE])); 01136000 +END; 01137000 + IF BOOLEAN(A.FORMAL) THEN BUMPLOCALS; 01138000 +; 01139000 +BEGIN A.TYPEFIXED ~ 1; GO TO RPLUS END; 01140000 +GO TO RPLUS; 01141000 +GO TO RPLUS; 01142000 +GO TO DONE; 01143000 +BEGIN A.TYPEFIXED ~ 1; IF BOOLEAN(A.FORMAL) THEN GO TO FMINUS 01144000 + ELSE GO TO RPLUS; 01145000 +END; 01146000 +BEGIN A.TYPEFIXED ~ 1; GO TO RPLUS END; 01147000 +IF BOOLEAN(A.FORMAL) THEN GO TO FMINUS ELSE GO TO RPLUS; 01148000 +IF BOOLEAN(A.FORMAL) THEN GO TO FMINUS ELSE GO TO RPLUS; 01149000 +GO TO RPLUS; 01150000 +GO TO RPLUS; 01151000 +END OF CASE STATEMENT; 01152000 +A.TYPEFIXED ~ 1; 01153000 +IF BOOLEAN(A.FORMAL) THEN 01154000 + GO TO FMINUS; 01155000 +IF BOOLEAN(A.CE) OR BOOLEAN(A.EQ) THEN 01156000 +BEGIN 01157000 + PUT(S,A); 01158000 + CALLEQUIV(A.ADDR,OWNID,GET(S+1)) ; 01159000 + GO TO DONE; 01160000 +END; 01161000 + A.TWOD ~ REAL(GET(S+2).SIZE > 1023); 01162000 +FMINUS: 01163000 + IF OWNID THEN BEGIN BUMPPRT; A.ADDR~PRTS END ELSE 01163100 + BEGIN BUMPLOCALS; A.ADDR ~ LOCALS +1536 END; 01164000 + IF A.CLASS = VARID THEN IF A.SUBCLASS } DOUBTYPE THEN 01165000 + IF OWNID THEN BUMPPRT ELSE 01165100 + BUMPLOCALS; 01166000 + GO TO XIT; 01167000 +RPLUS: 01168000 + BUMPPRT; A.ADDR~PRTS; 01169000 +XIT: 01170000 + PUT(S, -A); 01171000 +DONE: 01172000 +END GETSPACE; 01173000 +INTEGER STREAM PROCEDURE LBLSHFT(S); VALUE S; 01174000 + BEGIN 01175000 + LOCAL T; 01176000 + LABEL L; 01177000 + DI ~ LOC LBLSHFT; DS ~ 8 LIT "00 "; 01178000 + DI ~ DI - 6; SI ~LOC S; SI ~ SI + 2; 01179000 + TALLY ~ 1; T ~ TALLY; 01180000 + 5(T(IF SC="0" THEN BEGIN SI~SI+1; JUMP OUT 1 TO L END 01181000 + ELSE TALLY~0; T~TALLY); 01182000 + IF SC}"0" THEN DS~CHR ELSE IF SC=" " THEN SI~SI+1 01183000 + ELSE JUMP OUT; L: ) ; 01183100 + IF SC ! " " THEN BEGIN DI ~ LOC LBLSHFT; DS ~ LIT "+" END; 01184000 + END LBLSHFT; 01185000 + COMMENT EMITTERS AND CODE CONTROL; 01186000 +ALPHA PROCEDURE B2D(B); VALUE B; REAL B; 01187000 + B2D ~ 0&B[45:45:3]&B[39:42:3]&B[33:39:3]&B[27:36:3]; 01188000 +PROCEDURE DEBUG(S); % PRINTS OUT DEBUG CODE 01189000 + VALUE S; REAL S; % IF S<0 THEN S IS FIELD TYPE OPERATOR 01190000 + BEGIN 01191000 + FORMAT FF(X35,*(33(".")),A4,":",A1,2(X2,A4),X4,A4) ; 01192000 + ALPHA CODE,MNM,SYL; 01193000 + REAL T; 01194000 +PROCEDURE SEARCH(CODE,S); VALUE S; REAL S,CODE; 01195000 + BEGIN % SEARCHS WOP TO FIND CODE FOR S 01196000 + REAL N,I; 01197000 + LABEL L; 01198000 + N ~ 64; 01199000 + FOR I ~ 66 STEP IF WOP[I] < S THEN N ELSE -N 01200000 + WHILE N ~ N DIV 2 } 1 DO 01201000 + IF WOP[I] =S THEN GO TO L; 01202000 + I ~ 0; % NOT FOUND 01203000 + L: CODE ~ WOP[I+1]; 01204000 + END SEARCH; 01205000 + IF S < 0 THEN 01206000 + BEGIN % FIELD TYPE OPERATOR 01207000 + SYL ~ S; 01208000 + MNM ~ B2D(S.[36:6]); 01209000 + IF (S ~ S.[42:6]) = 37 THEN CODE ~ "ISO " ELSE 01210000 + IF S = 45 THEN CODE ~ "DIA " ELSE 01211000 + IF S = 49 THEN CODE ~ "DIB " ELSE 01212000 + IF S = 53 THEN CODE ~ "TRB "; 01213000 + END 01214000 + ELSE 01215000 + BEGIN 01216000 + IF (T ~ S.[46:2]) ! 1 THEN 01217000 + BEGIN 01218000 + SYL ~ S; 01219000 + MNM ~ B2D(S.[36:10]); 01220000 + IF T = 0 THEN CODE ~ "LITC" 01221000 + ELSE IF T =2 THEN CODE ~ "OPDC" 01222000 + ELSE CODE ~ "DESC"; 01223000 + END 01224000 + ELSE 01225000 + BEGIN % SEARCH WOP FOR OPERATOR NAME 01226000 + SYL ~ S; 01227000 + MNM ~ " "; 01228000 + SEARCH(CODE,S.[36:10]); 01229000 + END; 01230000 + END; 01231000 + WRITALIST(FF,6,IF ADR{DEBUGADR THEN 1 ELSE -1,B2D(ADR.[36:10]),01232000 + B2D(ADR.[46:2]),CODE,MNM,B2D(SYL),0,0) ; 01233000 + IF DEBUGADR0 THEN S~GET(GETSPACE(P)); 01276000 + IF S.CLASS = VARID THEN IF BOOLEAN(S.CE) THEN 01277000 + IF BOOLEAN(S.TWOD) THEN 01278000 + BEGIN 01279000 + EMITL( (T~GET(P+2).BASE).[33:7]); 01280000 + EMITDESCLIT(S.ADDR); 01281000 + EMITO(LOD); 01282000 + EMITL(T.[40:8]); 01283000 + EMITO(CDC); 01284000 + GO TO XIT; 01285000 + END ELSE 01286000 + EMITNUM(GET(P+2).BASE) 01287000 + ELSE 01288000 + IF NOT BOOLEAN(S.FORMAL) THEN IF NOT DESCREQ THEN 01289000 + BEGIN 01290000 + EMITL(S~S.ADDR); 01291000 + IF S.[37:2]=1 THEN %REFERENCING 2ND HALF OF PRT; 01292000 + BEGIN 01293000 + IF ADR } 4087 THEN 01294000 + BEGIN ADR ~ ADR+1; SEGOVF END; 01295000 + EMITO(XRT); 01296000 + END; 01297000 + GO TO XIT; 01298000 + END; 01299000 + EMITDESCLIT(S.ADDR); 01300000 + XIT: 01301000 +END EMITN; 01302000 +PROCEDURE EMITV(P); VALUE P; ALPHA P; 01303000 + BEGIN 01304000 + ALPHA S; 01305000 + IF S~ GET(P) > 0 THEN S ~ GET(GETSPACE(P)); 01306000 + IF S.CLASS = VARID THEN 01307000 + IF BOOLEAN(S.CE) THEN 01308000 + IF BOOLEAN(S.TWOD) THEN 01309000 + BEGIN 01310000 + EMITL( (T~GET(P+2).BASE).[33:7]); 01311000 + EMITDESCLIT(S.ADDR); 01312000 + EMITO(LOD); 01313000 + IF S.SUBCLASS } DOUBTYPE THEN 01314000 + BEGIN 01315000 + EMITO(DUP); 01316000 + EMITPAIR(T.[40:8]+1, COC); 01317000 + EMITO(XCH); 01318000 + EMITPAIR(T.[40:8], COC); 01319000 + END ELSE EMITPAIR(T.[40:8], COC); 01320000 + END 01321000 + ELSE 01322000 + IF S.SUBCLASS } DOUBTYPE THEN 01323000 + BEGIN 01324000 + EMITNUM( (T~GET(P+2).BASE)+1); 01325000 + EMITOPDCLIT(S.ADDR); 01326000 + EMITNUM(T); 01327000 + EMITOPDCLIT(S.ADDR); 01328000 + END ELSE 01329000 + BEGIN 01330000 + EMITNUM(GET(P+2).BASE); 01331000 + EMITOPDCLIT(S.ADDR); 01332000 + END 01333000 + ELSE 01334000 + IF S.SUBCLASS } DOUBTYPE THEN 01335000 + IF BOOLEAN(S.FORMAL) THEN 01336000 + BEGIN 01337000 + EMITDESCLIT(S.ADDR); 01338000 + EMITO(DUP); 01339000 + EMITPAIR(1, XCH); 01340000 + EMITO(INX); 01341000 + EMITO(LOD); 01342000 + EMITO(XCH); 01343000 + EMITO(LOD); 01344000 + END ELSE 01345000 + BEGIN 01346000 + EMITOPDCLIT(S.ADDR+1); 01347000 + EMITOPDCLIT(S.ADDR); 01348000 + END 01349000 + ELSE EMITOPDCLIT(S.ADDR) 01350000 + ELSE EMITOPDCLIT(S.ADDR); 01351000 +END EMITV; 01352000 +PROCEDURE EMITL(N); VALUE N; REAL N; 01353000 + BEGIN 01354000 + BUMPADR; 01355000 + PACK(EDOC[EDOCI],(N~0&N[36:38:10]),ADR.[46:2]); 01356000 + IF CODETOG THEN DEBUG(N); 01357000 +END EMITL; 01358000 +PROCEDURE EMITD(R, OP); VALUE R, OP; REAL R, OP; 01359000 +BEGIN 01360000 + BUMPADR; 01361000 + PACK(EDOC[EDOCI], (R ~ OP & R[36:42:6]), ADR.[46:2]); 01362000 + IF CODETOG THEN DEBUG(-R); 01363000 +END EMITD; 01364000 +PROCEDURE EMITDDT(B,A,X); VALUE B,A,X; INTEGER B,A,X ; 01364010 + BEGIN % DOES DIB B, DIA A, TRB X; HANDLES [B:A:X]. 01364020 + EMITD(B~B MOD 6+B DIV 6|8,DIB); EMITD(A~A MOD 6+A DIV 6|8,DIA) ; 01364030 + EMITD(X~X,TRB); 01364035 + END OF EMITDDT ; 01364040 +PROCEDURE EMITPAIR(L, OP); VALUE L, OP; INTEGER L, OP; 01365000 +BEGIN 01366000 + EMITL(L); 01367000 + IF L.[37:2] = 1 THEN 01368000 + BEGIN 01369000 + IF ADR } 4087 THEN 01370000 + BEGIN ADR ~ ADR+1; SEGOVF END; 01371000 + EMITO(XRT); 01372000 + END; 01373000 + EMITO(OP); 01374000 +END EMITPAIR; 01375000 +PROCEDURE ADJUST; 01376000 + WHILE ADR.[46:2] ! 3 DO EMITO(NOP); 01377000 +PROCEDURE EMITNUM(N); VALUE N; REAL N; 01378000 + BEGIN 01379000 + DEFINE CPLUS = 1792#; 01380000 + IF N.[3:6] =0 AND ABS(N) < 1024 THEN 01381000 + BEGIN 01382000 + EMITL(N); 01383000 + IF N < 0 THEN EMITO(SSN); 01384000 + END ELSE 01385000 + BEGIN 01386000 + IF ADR } 4079 THEN 01387000 + BEGIN ADR ~ ADR+1; SEGOVF END; 01388000 + EMITOPDCLIT(CPLUS + (ADR+1).[46:1] + 1); 01389000 + EMITL(2); 01390000 + EMITO(GFW); 01391000 + ADJUST; 01392000 + BUMPADR; 01393000 + PACK(EDOC[EDOCI],N.[1:11],ADR.[46:2]); 01394000 + BUMPADR; 01395000 + PACK(EDOC[EDOCI],N.[12:12],ADR.[46:2]); 01396000 + BUMPADR; 01397000 + PACK(EDOC[EDOCI],N.[24:12],ADR.[46:2]); 01398000 + BUMPADR; 01399000 + PACK(EDOC[EDOCI],N.[36:12],ADR.[46:2]); 01400000 + IF N.[36:12]=49 THEN %%% IF C-REL CONSTANT LOOKS LIKE AN XRT 01400400 + EMITO(NOP); %%% THEN INSURE AGAINST P-BIT INTERRUPT. 01400600 + IF CODETOG THEN DEBUGWORD(N); 01401000 + END; 01402000 +END EMITNUM; 01403000 +PROCEDURE EMITNUM2(HI,LO);VALUE HI,LO; REAL HI,LO; 01404000 + BEGIN 01405000 + BOOLEAN B; REAL I,N; 01406000 + LABEL Z,X; 01407000 + DEFINE CPLUS = 1792#; 01408000 + IF HI=0 OR LO=0 THEN BEGIN EMITNUM(LO); EMITNUM(HI); GO Z END; 01408100 + ADJUST; 01409000 + IF ADR } 4077 THEN 01410001 + BEGIN ADR~ADR+1; SEGOVF; ADR~-1 END; 01411000 + EMITOPDCLIT(CPLUS + 2); EMITOPDCLIT(CPLUS + 1); 01412000 + EMITPAIR(3,GFW); 01413000 + X: FOR I ~ 0 STEP 1 UNTIL 3 DO 01415000 + BEGIN 01416000 + CASE I OF BEGIN 01417000 + N ~ HI.[ 1:11]; 01418000 + N ~ HI.[12:12]; 01419000 + N ~ HI.[24:12]; 01420000 + N ~ HI.[36:12]; 01421000 + END CASE; 01422000 + BUMPADR; PACK(EDOC[EDOCI],N,ADR.[46:2]); 01423000 + END; 01424000 + IF CODETOG THEN DEBUGWORD(HI); 01425000 + IF NOT B THEN BEGIN B~TRUE; HI~LO; GO TO X; END; 01426000 + IF N=49 THEN %%% IF C-REL CONSTANT LOOKS LIKE AN XRT 01426400 + EMITO(NOP) ; %%% THEN INSURE AGAINST P-BIT INTERRUPT. 01426600 +Z: 01426650 + END EMITNUM2; 01427000 +PROCEDURE EMITLINK(N); VALUE N; REAL N; % EMITS LINKS 01428000 + BEGIN 01429000 + FORMAT FF(X35,*(33(".")),A4,":",A1," LINK",X10,A4,"******") ; 01430000 + BUMPADR; 01431000 + PACK(EDOC[EDOCI],N,ADR.[46:2]); 01432000 + IF CODETOG THEN 01433000 + WRITALIST(FF,4,IF ADR{DEBUGADR THEN 1 ELSE -1,B2D(ADR.[36:10]),01434000 + B2D(ADR.[46:2]),B2D(N),0,0,0,0) ; 01435000 + IF DEBUGADRLBRANCH THEN FATAL(123); 01530000 + BRANCHX ~ BRANCHES[LAX~BRANCHX]; 01531000 + BRANCHES[LAX] ~ -(ADR+1); 01532000 + EMITLINK(0); 01533000 + EMITO(IF C THEN BFC ELSE BFW); 01534000 + EMITO(NOP); 01534100 + END ELSE 01535000 + BEGIN 01536000 + SEG ~ A.SEGNO; 01537000 + A ~ A.LINK; 01538000 + BEOREF ~ ADR > A; 01539000 + IF A.[46:2] =0 THEN 01540000 + BEGIN 01541000 + IF SEG > 0 AND SEG ! NSEG THEN 01542000 + EMITOPDCLIT(PRGDESCBLDR(2, 0, A.[36:10], SEG)) 01543000 + ELSE 01544000 + EMITL(ABS((ADR+2).[36:10] - A.[36:10])); 01545000 + IF BEOREF THEN 01546000 + EMITO( IF C THEN GBC ELSE GBW) ELSE 01547000 + EMITO( IF C THEN GFC ELSE GFW); 01548000 + END ELSE 01549000 + BEGIN 01550000 + EMITL(ABS(ADR + 3 - A)); 01551000 + IF BEOREF THEN 01552000 + EMITO(IF C THEN BBC ELSE BBW) ELSE 01553000 + EMITO(IF C THEN BFC ELSE BFW); 01554000 + END; 01555000 + END; 01556000 +END EMITB; 01557000 +PROCEDURE EMITDESCLIT(N); VALUE N; REAL N; 01558000 + BEGIN 01559000 + IF N.[37:2] = 1 THEN 01560000 + BEGIN 01561000 + IF ADR } 4087 THEN 01562000 + BEGIN ADR ~ ADR+1; SEGOVF END; 01563000 + EMITO(XRT); 01564000 + END; 01565000 + BUMPADR; 01566000 + PACK(EDOC[EDOCI],(N~3&N[36:38:10]),ADR.[46:2]); 01567000 + IF CODETOG THEN DEBUG(N); 01568000 +END EMITDESCLIT; 01569000 +PROCEDURE EMITOPDCLIT(N); VALUE N; REAL N; 01570000 + BEGIN 01571000 + IF N.[37:2] = 1 THEN 01572000 + BEGIN 01573000 + IF ADR } 4087 THEN 01574000 + BEGIN ADR ~ ADR+1; SEGOVF END; 01575000 + EMITO(XRT); 01576000 + END; 01577000 + BUMPADR; 01578000 + PACK(EDOC[EDOCI],(N~2&N[36:38:10]),ADR.[46:2]); 01579000 + IF CODETOG THEN DEBUG(N); 01580000 +END EMITOPDCLIT; 01581000 +PROCEDURE EMITLABELDESC(N); VALUE N; ALPHA N; 01582000 +BEGIN 01583000 + LABEL XIT; 01584000 + REAL T,B,C,D ; 01585000 + IF N ~ LBLSHFT(XTA~N) = 0 OR N = BLANKS THEN 01586000 + BEGIN FLAG(135); GO TO XIT END; 01587000 + IF T ~ SEARCH(N) = 0 THEN 01588000 + T ~ ENTER(0 & LABELID[TOCLASS], N) ELSE 01588100 + IF GET(T).CLASS ! LABELID THEN 01588200 + BEGIN FLAG(144); GO TO XIT END; 01588300 + IF XREF THEN ENTERX(N,0&LABELID[TOCLASS]); 01588400 + IF B ~(C~GET(T+2)).BASE =0 THEN 01589000 + IF (D~GET(T)).SEGNO!0 THEN C.BASE~B~PRGDESCBLDR(2,0,D.ADDR DIV 4, 01589010 + D.SEGNO) ELSE 01589020 + BEGIN BUMPPRT; C.BASE~B~PRTS END; PUT(T+2,C); 01590000 + EMITL(B); EMITO(MKS); 01591000 + EMITDESCLIT(1536); % F+0 01592000 + EMITOPDCLIT(1537); % F+1 01593000 + EMITV(NEED(".LABEL", INTRFUNID)); 01594000 + XIT: 01595000 +END EMITLABELDESC; 01596000 +COMMENT TRACEBACK, OFLOWHANGERS, AND PRTSAVER ARE 01597000 +PROCEDURES USED TO ACCUMULATE FORMAT AND NAMELIST ARRAYS; 01598000 +PROCEDURE TRACEBACK(M,DEX,PRT); VALUE M,DEX,PRT; INTEGER M,DEX,PRT; 01599000 +BEGIN INTEGER I,J; REAL C; 01600000 + IF (C~GET(M+2)).BASE ! 0 THEN 01601000 + BEGIN I ~ ADR; ADR ~ C.BASE; 01602000 + DO BEGIN J ~ GIT(ADR); 01603000 + ADR ~ ADR - 1; 01604000 + EMITL(DEX); 01605000 + EMITPAIR(PRT,LOD); 01606000 + END UNTIL ADR ~ J = 0; 01607000 + ADR ~ I; 01608000 + END; 01609000 +INFO[M.IR,M.IC].ADDR ~ PRT; PUT(M+2,0&DEX[TOBASE]); 01610000 +END TRACEBACK; 01611000 +PROCEDURE OFLOWHANGERS(I); VALUE I; INTEGER I; 01612000 +BEGIN INTEGER J; LABEL XIT; 01613000 +FOR J ~ 1 STEP 1 UNTIL MAXNBHANG DO 01614000 +IF FNNHANG[J] = 0 THEN % MAKE AN ENTRY 01615000 +BEGIN FNNHANG[J] ~ I; 01616000 + PUT(I+2,J); 01617000 + GO TO XIT; 01618000 +END; 01619000 +XTA ~ MAXNBHANG; % IF WE REACH HERE WERE HURTIN 01620000 +FLAG(91); 01621000 +XIT: 01622000 +END OFLOWHANGERS; 01623000 +PROCEDURE PRTSAVER(M,SZ,ARY); VALUE M,SZ; 01624000 +INTEGER M,SZ; ARRAY ARY[0]; 01625000 +BEGIN INTEGER I; REAL INFA; 01626000 +LABEL SHOW,XIT; 01626100 +IF (INFA~GET(M)) < 0 THEN % PREVIOUSLY DEFINED 01627000 +BEGIN XTA ~ GET(M+1); 01628000 + FLAG(20); GO TO XIT; 01629000 +END; 01630000 +IF I ~ INFA .ADDR ! 0 THEN % PRT ASSIGNED AT OFLOW TIME 01631000 +SHOW: 01631100 +BEGIN I ~ PRGDESCBLDR(1,I,0,NXAVIL ~ NXAVIL + 1); 01632000 + WRITEDATA(SZ,NXAVIL,ARY); 01633000 + FNNHANG[GET(M+2).SIZE] ~ 0; 01634000 +END ELSE % ADD THIS ARRAY TO HOLD 01635000 +BEGIN IF FNNPRT=0 THEN BEGIN BUMPPRT; FNNPRT~PRTS END; 01636000 + IF FNNINDEX + SZ > DUMPSIZE THEN % ARRAY WONT FIT 01637000 + IF SZ > DUMPSIZE THEN % ARRAY WILL NEVER FIT 01638000 + BEGIN BUMPPRT;FNNHANG[GET(M+2).SIZE]~0; TRACEBACK(M,0,I~PRTS); 01639000 + GO TO SHOW; 01640000 + END ELSE % DUMP OUT CURRENT HOLDINGS 01641000 + BEGIN FNNPRT ~ PRGDESCBLDR(1,FNNPRT,0,NXAVIL ~ NXAVIL + 1); 01642000 + WRITEDATA(FNNINDEX,NXAVIL,FNNHOLD); 01643000 + FNNINDEX ~ 0; BUMPPRT; FNNPRT ~PRTS; 01644000 + END; 01645000 + FNNHANG[GET(M + 2).SIZE] ~0; 01646000 + TRACEBACK(M,FNNINDEX,FNNPRT); 01647000 + MOVEW(ARY,FNNHOLD[FNNINDEX],SZ.[36:6],SZ); 01648000 + FNNINDEX ~ FNNINDEX + SZ; 01649000 +END; 01650000 +PUT(M,-GET(M)); % ID NOW ASSIGNED 01651000 +XIT: 01651100 +END PRTSAVER; 01652000 +PROCEDURE SEGOVF; 01653000 + BEGIN 01654000 + REAL I, T, A, J, SADR, INFC, LABPRT; 01655000 + REAL SAVINS; 01655100 + FOR T ~ 1 STEP 1 UNTIL MAXNBHANG DO 01656000 +IF J~FNNHANG[T]!0 THEN BEGIN BUMPPRT;TRACEBACK(J,FNNHANG[T]~0,PRTS) END;01657000 + SEGOVFLAG ~ TRUE; 01661000 +BUMPPRT; 01662000 + IF PRTS.[37:2]=1 THEN BEGIN 01662300 + PACK(EDOC[EDOCI],(T~1&XRT[36:38:10]),ADR.[46:2]); 01662500 + IF CODETOG THEN DEBUG(T); ADR~ADR+1 END; 01662700 + PACK(EDOC[EDOCI], (T~2&PRTS[36:38:10]), ADR.[46:2]); 01663000 + IF CODETOG THEN DEBUG(T); 01664000 + ADR ~ ADR+1; 01665000 + PACK(EDOC[EDOCI], (T~1&BFW [36:38:10]), ADR.[46:2]); 01666000 + IF CODETOG THEN DEBUG(T); 01667000 + SADR ~ ADR; 01668000 + T ~ PRGDESCBLDR(2, PRTS, 0, NXAVIL+1); 01669000 + FOR I ~ 0 STEP 1 UNTIL SHX DO 01670000 + BEGIN T ~ STACKHEAD[I]; 01671000 + WHILE T ! 0 DO 01672000 + BEGIN IF (A~ GET(T)).CLASS = LABELID THEN 01673000 + IF A > 0 THEN 01674000 + BEGIN 01675000 + ADR ~ A.ADDR; 01676000 + IF LABPRT ~ (INFC~GET(T+2)).BASE = 0 THEN 01677000 + BEGIN 01678000 + BUMPPRT; LABPRT~PRTS; 01679000 + PUT(T+2, INFC & PRTS[TOBASE]); 01680000 + END; 01681000 + WHILE ADR ! 0 DO 01682000 + BEGIN J ~ GIT(ADR); ADR ~ ADR-1; 01683000 + SAVINS~GIT(ADR+2).[36:10]; 01683100 + EMITOPDCLIT(LABPRT); 01684000 + EMITO(SAVINS); 01684100 + ADR ~ J; 01685000 + END; 01686000 + INFO[T.IR,T.IC].ADDR ~ 0; 01687000 + END; 01688000 + T ~ A.LINK; 01689000 + END; 01690000 + END; 01691000 + FOR I ~ 0 STEP 1 UNTIL LBRANCH DO 01692000 + IF T ~ - BRANCHES[I] > 0 AND T < 4096 THEN 01693000 + BEGIN 01694000 + ADR ~ T-1; 01695000 + SAVINS~GIT(ADR+2).[36:10]; 01695100 + BUMPPRT; EMITOPDCLIT(PRTS); 01696000 + EMITO(SAVINS); 01696100 + BRANCHES[I] ~ - (PRTS+4096); 01697000 + END; 01698000 + SEGMENT((SADR+4) DIV 4,NSEG,FALSE,EDOC); 01699000 + SEGMENTSTART; 01700000 + EMITO(NOP); EMITO(NOP); 01701000 + SEGOVFLAG ~ FALSE; 01702000 +END SEGOVF; 01703000 +PROCEDURE ARRAYDEC(I); VALUE I; REAL I; 01704000 + BEGIN % DECLARES ARRAYS WHOSE INFO INDEX IS I 01705000 + REAL PRT,LNK,J; 01706000 + LABEL XIT; 01706010 + BOOLEAN OWNID; REAL X; 01706100 +IF DEBUGTOG THEN FLAGROUTINE(" ARRA","YDEC ",TRUE ); 01706110 + PRT ~ GET(I).ADDR; 01707000 + IF LNK ~ GET(I+2).SIZE = 0 THEN GO TO XIT ; 01708000 + IF (OWNID ~ PRT < 1536 AND DATAPRT ! 0) THEN 01708100 + BEGIN 01708200 + EMITOPDCLIT(DATAPRT); EMITO(LNG); 01708300 + EMITB(-1, TRUE); X ~ LAX; 01708400 + END; 01708500 + EMITO(MKS); 01709000 + EMITDESCLIT(PRT); % STACK OR PRT ADDRESS 01710000 + IF LNK { 1023 THEN 01711000 + BEGIN 01712000 + IF OWNID THEN EMITL(0); % LOWER BOUND 01712100 + EMITL(LNK); % ARRAY SIZE 01713000 + EMITL(1); % ONE DIMENSION 01714000 + END 01715000 + ELSE 01716000 + BEGIN 01717000 + J ~ (LNK + 255) DIV 256; 01718000 + LNK ~ 256; %INCLUDE ENTIRE ARRAY SIZE IN ESTIMATE %512- 01719000 + IF OWNID THEN EMITL(0); % FIRST LOWER BOUND 01719100 + EMITL(J); % NUMBER OF ROWS 01720000 + IF OWNID THEN EMITL(0); % SECOND LOWER BOUND 01720100 + EMITL(256); % SIZE OF EACH ROW 01721000 + EMITL(2); % TWO DIMENSIONS 01722000 + END; 01723000 + EMITL(1); % ONE ARRAY 01724000 + EMITL(IF OWNID THEN 2 ELSE 0); %OWN OR LOCAL 01725000 + EMITOPDCLIT(5); % CALL BLOCK 01726000 + ARYSZ ~ ARYSZ + J + LNK; 01727000 + IF NOT(F2TOG OR OWNID) THEN 01728000 + BEGIN 01729000 + F2TOG ~ TRUE; 01730000 + EMITL(1); 01731000 + EMITPAIR(FPLUS2,STD);% F+2~TRUE 01732000 + END; 01733000 + IF OWNID THEN FIXB(X); 01733100 + XIT: 01733105 +IF DEBUGTOG THEN FLAGROUTINE(" ARRA","YDEC ",FALSE) ; 01733200 + END ARRAYDEC; 01734000 +REAL PROCEDURE SEARCH(E); VALUE E; REAL E; 01735000 +BEGIN REAL T; LABEL XIT; 01736000 + T ~ STACKHEAD[E MOD SHX]; 01737000 + WHILE T ! 0 DO 01738000 + IF INFO[(T+1).IR,(T+1).IC] = E THEN GO TO XIT 01739000 + ELSE T ~ INFO[T.IR,T.IC].LINK; 01740000 + XIT: SEARCH ~ T; 01741000 +END SEARCH; 01742000 +INTEGER PROCEDURE GLOBALSEARCH(E); VALUE E; REAL E; 01743000 +BEGIN REAL T; LABEL XIT; 01744000 + T ~ GLOBALSTACKHEAD[E MOD GHX]; 01745000 + WHILE T ! 0 DO 01746000 + IF INFO[(T+1).IR,(T+1).IC] = E THEN GO TO XIT 01747000 + ELSE T ~ INFO[T.IR,T.IC].LINK; 01748000 + XIT: GLOBALSEARCH ~ T; 01749000 +END GLOBALSEARCH; 01750000 +PROCEDURE PURGEINFO; 01751000 +BEGIN REAL J; 01752000 + FLAG(13); 01753000 + FOR J ~ 0 STEP 1 UNTIL SHX DO STACKHEAD[J] ~ 0; 01754000 + NEXTINFO ~ 2; 01755000 + NEXTCOM ~ 0; 01756000 + END; 01757000 +INTEGER PROCEDURE ENTER(W, E); VALUE W, E; ALPHA W, E; 01758000 +BEGIN REAL J; 01759000 + IF GLOBALNEXTINFO { NEXTINFO THEN PURGEINFO; 01760000 + W.LINK ~ STACKHEAD[J ~ E MOD SHX]; 01761000 + STACKHEAD[J] ~ ENTER ~ J ~ NEXTINFO; 01762000 + INFO[J.IR,J.IC] ~ W; 01763000 + INFO[(J~J+1).IR,J.IC] ~ E; 01764000 + INFO[(J~J+1).IR,J.IC] ~ 0; 01765000 + NEXTINFO ~ NEXTINFO + 3; 01766000 +END ENTER; 01767000 +INTEGER PROCEDURE GLOBALENTER(W, E); VALUE W, E; ALPHA W, E; 01768000 +BEGIN REAL J; 01769000 + IF GLOBALNEXTINFO { NEXTINFO THEN PURGEINFO; 01770000 + W.LINK ~ GLOBALSTACKHEAD[J ~ E MOD GHX]; 01771000 + GLOBALSTACKHEAD[J] ~ GLOBALENTER ~ J ~ GLOBALNEXTINFO; 01772000 + INFO[J.IR,J.IC] ~ W; 01773000 + INFO[(J~J+1).IR,J.IC] ~ E; 01774000 + INFO[(J~J+1).IR,J.IC] ~ 0; 01775000 + GLOBALNEXTINFO ~ GLOBALNEXTINFO - 3; 01776000 +END GLOBALENTER; 01777000 +PROCEDURE LABELBRANCH(K, C); VALUE K, C; REAL K; BOOLEAN C; 01778000 +BEGIN REAL TS,T,I,X; 01779000 +DEFINE LABL = K#; 01780000 +COMMENT LABELBRANCH GENERATES A "LITC ..." AND "BRANCH" FROM THE 01781000 +CURRENT ADDRESS TO LABEL K. IF THE BOOLEAN C IS TRUE 01782000 +THE BRANCH IS CONDITIONAL. IF THE LABEL HAS NOT BEEN ENCOUNTERED 01783000 +THEN THE APPROPRIATE LINKAGE IS MADE; 01784000 + LABEL XIT; 01785000 + IF ADR } 4086 THEN 01786000 + BEGIN ADR ~ ADR+1; SEGOVF END; 01787000 + IF LABL ~ LBLSHFT(XTA~LABL) { 0 OR LABL = BLANKS THEN 01788000 + BEGIN FLAG(135); GO TO XIT END; 01789000 + IF T ~ SEARCH(LABL) ! 0 THEN 01790000 + BEGIN TS ~ (I ~ GET(T)).ADDR; 01791000 + IF I.CLASS ! LABELID THEN BEGIN FLAG(144); GO TO XIT END; 01791100 + IF I > 0 THEN 01792000 + BEGIN EMITLINK(TS); 01793000 + EMITO(IF C THEN BFC ELSE BFW); 01794000 + PUT(T,I&(ADR-1)[TOADDR]); 01795000 + EMITO(NOP); 01795100 + END ELSE 01796000 + IF I.SEGNO = NSEG THEN EMITB(TS, C) ELSE 01799000 + BEGIN IF TS~(X~GET(T+2)).BASE = 0 THEN 01800000 + X.BASE ~ TS ~ PRGDESCBLDR(2,0,(I.ADDR).[36:10],I.SEGNO); 01801000 + PUT(T+2,X); 01802000 + EMITOPDCLIT(TS); 01803000 + EMITO(IF C THEN BFC ELSE BFW); 01804000 + END; 01805000 +END ELSE 01806000 + BEGIN 01807000 + IF ADR < 0 THEN EMITO(NOP); 01808000 + EMITLINK(0); 01809000 + EMITO( IF C THEN BFC ELSE BFW); 01810000 + T ~ ENTER(0 & LABELID[TOCLASS] & (ADR-1)[TOADDR], LABL); 01811000 + EMITO(NOP); 01811100 + END; 01812000 + IF XREF THEN ENTERX(LABL,0&LABELID[TOCLASS]); 01812100 + XIT: 01813000 +END LABELBRANCH; 01814000 +PROCEDURE DATASET; % SCANS CONSTANTS IN BLOCK DATA 01815000 + BEGIN 01816000 + REAL LST,CUR,LTYP,CTYP,SIZ,RPT; 01817000 + REAL CUD; 01818000 + BOOLEAN SGN; 01819000 + 01820000 + 01821000 + DEFINE TYP = GLOBALNEXT#, 01822000 + TYPC = 18:33:15#; 01823000 + LABEL XIT,ERROR,DPP,SPP,CPP,COMM,S; 01824000 +IF DEBUGTOG THEN FLAGROUTINE(" DATA","SET ",TRUE) ; 01825000 + DATATOG ~ TRUE; FILETOG ~ TRUE; 01826000 + SCAN; 01827000 + LSTS ~ -1; LTYP ~77; 01828000 + S: IF TYP = PLUS OR (SGN ~ TYP = MINUS ) THEN SCAN; 01829000 + IF TYP = NUM THEN 01830000 + BEGIN 01831000 + IF NUMTYPE = STRINGTYPE AND STRINGSIZE > 1 THEN 01832000 + BEGIN 01833000 + IF LTYP ! 77 THEN 01834000 + BEGIN % NOT FIRST ENTRY-PUSH DOWN PRIOR NUMBER 01835000 + IF LSTS+2 > LSTMAX THEN 01836000 + BEGIN FLAG(127); GO TO ERROR END; 01837000 + LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; 01838000 + LSTT[LSTS~LSTS+1] ~ LST; 01839000 + LTYP ~ 77; 01840000 + END; 01841000 + 01841100 + IF LSTS + STRINGSIZE > LSTMAX THEN 01842000 + BEGIN FLAG(127); GO TO ERROR END; 01843000 + LSTT[LSTS~LSTS+1] ~ STRINGSIZE & STRINGTYPE[TYPC] 01844000 + & SIZ[3:33:15]; 01844100 + MOVEW(STRINGARRAY,LSTT[LSTS~LSTS+1], 01845000 + STRINGSIZE.[36:6],STRINGSIZE); 01846000 + LSTS ~ LSTS + STRINGSIZE -1; 01846100 + SCAN; 01847000 + GO TO COMM; 01848000 + END; 01849000 + % GOT NUMBER 01850000 + IF NUMTYPE = STRINGTYPE THEN 01851000 + BEGIN 01851100 + FNEXT ~ STRINGARRAY[0]; 01851200 + NUMTYPE ~ INTYPE; 01851300 + IF SIZ = 0 THEN SIZ ~ 1; 01851400 + END; 01851500 + CUR ~ IF SGN THEN -FNEXT ELSE FNEXT; 01852000 + CTYP ~ NUMTYPE; CUD ~ DBLOW; 01853000 + 01854000 + SCAN; 01855000 + IF TYP = COMMA OR TYP = SLASH THEN 01856000 + BEGIN 01857000 + IF SIZ = 0 THEN SIZ ~ 1; 01857100 + IF CTYP = DOUBTYPE THEN 01858000 + BEGIN 01859000 + DPP: IF LTYP ! 77 THEN 01860000 + BEGIN 01861000 + IF LSTS+2 > LSTMAX THEN 01862000 + BEGIN FLAG(127); GO TO ERROR END; 01863000 + LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; 01864000 + LSTT[LSTS~LSTS+1] ~ LST; 01865000 + LTYP ~ 77; 01866000 + END; 01867000 + IF LSTS+3 > LSTMAX THEN BEGIN FLAG(127); GO TO ERROR END; 01868000 + LSTT[LSTS~LSTS+1] ~ SIZ&DOUBTYPE[TYPC]; 01869000 + LSTT[LSTS~LSTS+1] ~ CUR; 01870000 + LSTT[LSTS~LSTS+1] ~ CUD; 01871000 + GO TO COMM; 01872000 + END; 01873000 + % SINGLE PRECISION 01874000 + SPP: 01875000 + IF LTYP = 77 THEN 01876000 + BEGIN 01877000 + LST ~ CUR; 01878000 + LTYP ~ CTYP; 01879000 + RPT ~ SIZ; 01880000 + GO TO COMM; 01881000 + END; 01882000 + IF LTYP = CTYP THEN 01883000 + IF REAL(BOOLEAN(CUR) EQV BOOLEAN(LST)) = REAL(NOT FALSE) THEN 01883100 + BEGIN 01884000 + RPT ~ RPT + SIZ; 01885000 + GO TO COMM; 01886000 + END; 01887000 + IF LSTS+2 > LSTMAX THEN BEGIN FLAG(127); GO TO ERROR END; 01888000 + LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; 01889000 + LSTT[LSTS~LSTS+1] ~ LST; 01890000 + RPT ~ SIZ; 01891000 + LST ~ CUR; LTYP ~ CTYP; 01892000 + GO TO COMM; 01893000 + END; 01894000 + % TYP ! COMMA - CHECK FOR * 01895000 + IF TYP ! STAR THEN BEGIN FLAG(125); GO TO ERROR END; 01896000 + IF CTYP ! INTYPE THEN BEGIN FLAG(113); GO TO ERROR END; 01897000 + IF SIZ ! 0 OR SIZ ~ CUR { 0 THEN 01898000 + BEGIN FLAG(64); GO TO ERROR END; 01899000 + SCAN; GO TO S; 01900000 + END; 01912000 + % TYP ! NUM AT LABEL S 01913000 + IF SIZ = 0 THEN SIZ ~ 1; 01913050 + IF NAME = "T " OR NAME = "F " THEN 01913100 + BEGIN 01913200 + CUR ~ REAL(NAME = "T "); 01913300 + CTYP ~ LOGTYPE; 01913400 + SCAN; GO TO SPP; 01913500 + END; 01913600 + IF TYP ! LPAREN THEN BEGIN FLAG(64); GO TO ERROR END; 01914000 + 01915000 + CPP: % COMPLEX 01916000 + IF LTYP ! 77 THEN 01917000 + BEGIN 01918000 + IF LSTS+2 > LSTMAX THEN 01919000 + BEGIN FLAG(127); GO TO ERROR END; 01920000 + LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; 01921000 + LSTT[LSTS~LSTS+1] ~ LST; 01922000 + LTYP ~ 77; 01923000 + END; 01924000 + SCAN; 01925000 + IF TYP = PLUS OR (SGN~TYP=MINUS) THEN SCAN; 01926000 + IF TYP ! NUM OR NUMTYPE > REALTYPE THEN 01927000 + BEGIN FLAG(64); GO TO ERROR END; 01928000 + IF LSTS+2 > LSTMAX THEN BEGIN FLAG(127); GO TO ERROR END;01929000 + LSTT[LSTS~LSTS+1] ~ SIZ&COMPTYPE[TYPC]; 01930000 + LSTT[LSTS~LSTS+1] ~ IF SGN THEN -FNEXT ELSE FNEXT; 01931000 + SCAN; 01932000 + IF TYP ! COMMA THEN BEGIN FLAG(114); GO TO ERROR END; 01933000 + SCAN; 01934000 + IF TYP = PLUS OR (SGN ~ TYP = MINUS) THEN SCAN; 01935000 + IF TYP ! NUM OR NUMTYPE > REALTYPE THEN 01936000 + BEGIN FLAG(64); GO TO ERROR END; 01937000 + LSTT[LSTS~LSTS+1]~IF SGN THEN - FNEXT ELSE FNEXT ; 01938000 + SCAN; 01939000 + IF TYP ! RPAREN THEN BEGIN FLAG(108); GO TO ERROR END; 01940000 + SCAN; 01941000 + COMM: 01942000 + SIZ ~ 0; 01942100 + IF TYP = COMMA THEN BEGIN SCAN; GO TO S; END; 01943000 + IF TYP = SLASH THEN GO TO XIT; 01944000 + FLAG(126); 01945000 + ERROR: 01946000 + LSTS ~ 0; 01947000 + WHILE TYP ! COMMA AND TYP ! SLASH AND TYP ! SEMI DO SCAN;01948000 + IF TYP = COMMA THEN GO TO COMM; 01949000 + XIT: 01950000 + IF LTYP ! 77 THEN 01951000 + BEGIN 01952000 + IF LSTS+2>LSTMAX THEN BEGIN FLAG(127); LSTS~0 END;01953000 + LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; 01954000 + LSTT[LSTS~LSTS+1] ~ LST; 01955000 + END; 01956000 + IF LSTS+1 > LSTMAX THEN BEGIN FLAG(127); LSTS~0 END; 01957000 + LSTT[LSTS~LSTS+1]~0; 01958000 +IF DEBUGTOG THEN FLAGROUTINE(" DATA","SET ",FALSE); 01959000 + DATATOG ~ FALSE; FILETOG ~ FALSE; 01960000 +END DATASET; 01961000 +ALPHA PROCEDURE CHECKDO; 01962000 +BEGIN ALPHA X, T; INTEGER N; 01963000 +STREAM PROCEDURE CKDO(A, ID, LAB); 01964000 +BEGIN 01965000 + SI ~ A; SI ~ SI+4; DI ~ LAB; DI ~ DI+2; 01966000 + 5(IF SC } "0" THEN DS ~ CHR ELSE JUMP OUT); 01967000 + DI ~ ID; DI ~ DI+2; 01968000 + 6(IF SC = ALPHA THEN DS ~ CHR ELSE JUMP OUT); 01969000 +END CKDO; 01970000 + IF (XTA~HOLDID[0]).[12:24] = "FILE" THEN FLOG(37) ELSE 01971000 + IF XTA.[12:12] ! "DO" THEN FLOG(17) ELSE 01971010 + BEGIN 01972000 + X ~ T ~ BLANKS; 01973000 + CKDO(HOLDID[0], X, T); 01974000 + IF X=BLANKS THEN FLOG(105); 01974500 + IF T ~ LBLSHFT(T) < 0 OR T = BLANKS THEN FLOG(17) ELSE 01975000 + TEST ~ NEED(T, LABELID); 01976000 + DOLAB[DT]~ T; 01977000 + IF XREF THEN ENTERX(T,0&LABELID[TOCLASS]); 01977100 + IF GET(TEST) < 0 THEN % TEST FOR PREV DEFINITION 01978000 + BEGIN 01979000 + XTA ~ GET(TEST+1); 01980000 + FLAG(15); 01981000 + DT ~ DT-1; 01982000 + END; 01983000 + IF N ~ SEARCH(X) = 0 THEN 01984000 + N~ENTER(TIPE[IF T~X.[12:6]!"0" THEN T ELSE 12],X); 01985000 + CHECKDO ~ GETSPACE(N); 01987000 + IF XREF THEN ENTERX(X,1&GET(N) [15:15:9]); 01987100 + IF (X~GET(N)).SUBCLASS > REALTYPE OR X.CLASS ! VARID THEN 01988000 + BEGIN XTA ~ GET(N+1); FLAG(84) END; 01989000 + IF GET(FX1).CLASS = UNKNOWN THEN PUT(FX1+1, "......"); 01990000 + END; 01991000 +END CHECKDO; 01992000 +PROCEDURE FIXB(N); VALUE N; REAL N; 01993000 +BEGIN 01994000 + REAL T, U, FROM; 01995000 + LABEL XIT, BIGJ; 01996000 +IF DEBUGTOG THEN FLAGROUTINE(" FI","XB ",TRUE); 01996010 + IF N } 10000 THEN FROM ~ N-10000 ELSE 01997000 + IF FROM ~ - BRANCHES[N] > 4095 THEN 01998000 + BEGIN 01999000 + ADJUST; 02000000 + T ~ PRGDESCBLDR(2, FROM.LINK, (ADR+1).[36:10], NSEG); 02001000 + GO TO XIT; 02002000 + END; 02003000 +T ~ ADR; ADR ~ FROM - 1; 02004000 +IF (T + 1).[46:2] = 0 THEN GO TO BIGJ; 02005000 +IF (U ~ T - 2 - ADR) { 1023 THEN EMITL(U) ELSE 02006000 +BEGIN ADR ~ T; ADJUST; T ~ ADR; ADR ~ FROM - 1; 02007000 +BIGJ: EMITL((T+1).[36:10] - (ADR+2).[36:10]); 02008000 + EMITO(IF BOOLEAN(GIT(FROM + 1).[36:1]) THEN GFW ELSE GFC); 02009000 +END; 02010000 +ADR ~ T; 02011000 + XIT: 02012000 + IF N < 10000 THEN BEGIN 02013000 + BRANCHES[N] ~ BRANCHX; 02014000 + BRANCHX ~ N; 02015000 + END; 02016000 +IF DEBUGTOG THEN FLAGROUTINE(" FI","XB ",FALSE); 02016010 +END FIXB; 02017000 +PROCEDURE DATIME; % PRODUCES HEADING LINE FOR LISTING. 02018000 + BEGIN 02019000 + INTEGER D; 02020000 + FORMAT T(X9,"B 5 7 0 0 F O R T R A N C O M P I L A T I O N ",02021000 +"XVI.0" 02022000 + ,",",A2,",",A8,"DAY, ",2(A2,"/"),A2,",",A2,":",A2," H,"/); 02022500 + WRITALIST(T,7, 02024000 + "16" %999-02025000 + ,TIME(6),(D~TIME(5)).[12:12],D.[24:12],D.[36:12], 02026000 + D~(D~RTI DIV 216000) MOD 10+D DIV 10|64, 02027000 + D~(D~RTI DIV 3600 MOD 60) MOD 10+D DIV 10|64,0) ; 02028000 + IF D~LINE.TYPE=10 OR D=12 OR D=13 THEN 02029000 + BEGIN 02030000 + LOCK(LINE); LINE.AREAS~0; LINE.AREASIZE~0 ; 02031000 + IF D ! 12 THEN LINE.TYPE~12; SPACE(LINE,2) ; 02032000 + END; 02033000 + FIRSTCALL~FALSE ; 02034000 + END DATIME; 02039000 +PROCEDURE PRINTCARD; 02040000 +BEGIN 02041000 + STREAM PROCEDURE MOVE(P, Q, A); VALUE A, Q; 02042000 + BEGIN 02043000 + SI ~ Q; DI ~ P; 02044000 + DS ~ CHR; 02045000 + DI ~ DI+11; SI ~ LOC A; 02046000 + DS ~ 4 DEC; 02047000 + END MOVE; 02048000 + STREAM PROCEDURE MOVEBACK(P); 02049000 + BEGIN DI ~ P; DS ~ LIT "]" END; 02050000 + MOVE (CRD[9],BUFL,(ADR+1).[36:10]); 02051000 + IF FIRSTCALL THEN DATIME; 02052000 + IF UNPRINTED THEN WRITAROW(15,CRD) ; 02053000 + MOVEBACK(CRD[9]); 02054000 + IF SEQERRORS THEN WRITAROW(14,ERRORBUFF) ; 02054010 +END PRINTCARD; 02055000 +BOOLEAN PROCEDURE READACARD; FORWARD; 02056000 +PROCEDURE FILEOPTION; FORWARD; 02058000 +BOOLEAN PROCEDURE LABELR; 02059000 +BEGIN 02060000 +LABEL XIT, LOOP; 02061000 + 02062000 +BOOLEAN STREAM PROCEDURE CHECK(CD, LAB); 02063000 +BEGIN LABEL XIT; LOCAL T1; 02064000 + SI ~ CD; 02065000 + IF SC ! " " THEN IF SC < "0" THEN 02066000 + BEGIN DI ~ LAB; DI ~ DI + 2; 02067000 + DS ~ 6 CHR; GO TO XIT; 02068000 + END; 02069000 + DI ~LOC T1; DS ~ 6 LIT " "; DI ~ DI -6; 02070000 + 5(IF SC } "0" THEN DS ~ CHR ELSE SI ~ SI+1); 02071000 + DI ~LAB; DI ~DI + 2; SI ~ LOC T1; 02072000 + 5(IF SC ! "0" THEN JUMP OUT; SI ~ SI + 1); 02073000 + 5(IF SC } "0" THEN DS ~ CHR ELSE JUMP OUT); 02074000 + TALLY ~ 1; 02075000 + XIT: CHECK ~ TALLY; 02076000 +END CHECK; 02077000 +BOOLEAN STREAM PROCEDURE BLANKCARD(CD); 02077100 +BEGIN LABEL XIT; 02077200 + SI ~ CD; 02077300 + 2(36( IF SC ! " " THEN JUMP OUT 2 TO XIT ELSE SI ~ SI + 1)); 02077400 + TALLY ~ 1; 02077600 + XIT: BLANKCARD ~ TALLY; 02077700 +END BLANKCARD; 02077800 + LOOP: 02078000 + LABL ~ BLANKS; 02079000 + IF LABELR ~ NOT READACARD THEN GO TO XIT; 02080000 + IF NOT CHECK(CRD[0],LABL) THEN 02081000 + BEGIN IF LABL = "FILE " THEN FILEOPTION ELSE 02082000 + BEGIN IF LISTOG THEN PRINTCARD; 02083000 + IF (XTA ~ LABL).[12:6] ! "C" THEN FLAG(135); 02083100 + END; 02083200 + GO TO LOOP; 02084000 + END; 02085000 + IF ENDSEGTOG THEN IF BLANKCARD(CRD) THEN 02086000 + BEGIN IF LISTOG THEN PRINTCARD; GO TO LOOP END ELSE 02086500 + BEGIN SEGMENTSTART; 02087000 + IF LISTOG THEN PRINTCARD; 02088000 + IF LABL = BLANKS THEN GO TO XIT; 02089000 + END ELSE 02090000 + BEGIN 00091000 + IF LABL = BLANKS THEN 02092000 + BEGIN IF LISTOG THEN PRINTCARD; GO TO XIT END; 02093000 + IF ADR > 0 THEN ADJUST; 02094000 + IF LISTOG THEN PRINTCARD; 02095000 + END; 02096000 + XIT: 02116000 +END LABELR; 02117000 +PROCEDURE FILEOPTION; 02118000 +BEGIN COMMENT THIS PROCEDURE PROCESSES THE OPTIONAL FILE CONTROL CARD. 02119000 +THE WORD "FILE" APPEARS IN COL. 1 - 4. COL. 5 AND 6 ARE BLANK. 02120000 +#1 BELOW IS REQUIRED, OTHER ENTRIES MAY BE AS SPARSE AS DESIRED. 02121000 +1. FILE = / 02122000 + OR 02123000 + FILE = 02124000 + THE FOLLOWING "/" IS A DOCUMMENTARY OR. 02125000 + THE SEQUENCE OF RESERVED WORDS MUST BE MAINTAINED. 02126000 +2. UNIT=PRINT/READER/PUNCH/DISK/TAPE7/TAPE9/REMOTE (UNIT DESIGNATE). 02127000 +3. UNLABELED (FOR UNLABELED TAPES) 02128000 +4. ALPHA (FOR ALPHA RECORDING MODE) 02129000 +5. BCL (IGNORED, FOR 3500 USE) 02130000 +6. FIXED (IGNORED, FOR 3500 USE) 02131000 +7. SAVE = (SAVE FACTOR IN DAYS) 02132000 +8. LOCK (LOCK FILE AT EOJ) 02133000 +9. RANDOM/SERIAL/UPDATE (DISK USE) 02134000 +10. AREA = (DISK RECORDS/ROW) 02135000 +11. BLOCKING = (RECORD PER BLOCK) 02136000 +12. RECORD = (RECORD SIZE) 02137000 +13. BUFFER = (# OF BUFFERS) 02138000 +14. WORKAREA (IGNORED, FOR 3500) ; 02139000 +ALPHA P,KEEP; BOOLEAN TOG,CA,TS; LABEL XIT; 02140000 +COMMENT INXFIL = INFC.ADINFO, MULTI FILE ID = FILEINFO[1,INXFIL], 02141000 + FILE ID = FILEINFO[2,INXFIL], DISK RECORDS = FILEINFO[3,INXFIL],02142000 + FILEINFO[0,INXFIL] FROM RIGHT TO LEFT IS; 02143000 +INTEGER % NAME USE BITS 02144000 + BUFF, % # BUFFERS 6 02145000 + RECORD, % RECORD SIZE 12 02146000 + BLOCK, % BLOCK SIZE 12 02147000 + SAVER, % SAVE FACTOR 12 02148000 + SPIN, % REW & LOCK @ EOJ 2 02149000 + ALPH; % RECORDING MODE 1 02150000 +PROCEDURE FETCH; 02151000 +BEGIN SCAN; XTA ~ SYMBOL; 02152000 + IF NEXT=COMMA OR NEXT=MINUS THEN 02153000 + BEGIN SCAN; XTA ~ SYMBOL; 02154000 + IF NEXT ! ID THEN FLOG(37); 02155000 + END; 02156000 +END FETCH; 02157000 +INTEGER STREAM PROCEDURE MAKEINT(XTA); 02158000 +BEGIN LABEL LOOP; LOCAL T; 02159000 +SI ~ XTA; SI ~ SI + 2; 02160000 +LOOP: IF SC } "0" THEN 02161000 + BEGIN TALLY ~ TALLY + 1; SI ~ SI + 1; GO TO LOOP END; 02162000 +T ~ TALLY; SI ~ XTA; SI ~ SI + 2; DI ~ LOC MAKEINT; DS ~ T OCT; 02163000 +END MAKEINT; 02164000 +INTEGER PROCEDURE REPLACEMENT; 02165000 +BEGIN 02166000 +FETCH; IF NEXT = EQUAL THEN 02167000 +BEGIN FETCH; IF XTA.[12:6] { 11 THEN BEGIN REPLACEMENT ~ MAKEINT(XTA); 02168000 + FETCH END ELSE FLOG(37); 02169000 +END ELSE FLOG(37); 02170000 +END REPLACEMENT; 02171000 +INTEGER STREAM PROCEDURE SRI7(S); 02172000 +BEGIN SI ~ S; DI ~ LOC SRI7; 02173000 + SI ~ SI + 2; DI ~ DI + 1; DS ~ 7 CHR; 02174000 +END SRI7; 02175000 +COMMENT * * * * * START OF CODE * * * * ; 02176000 +IF DEBUGTOG THEN FLAGROUTINE(" FILEO","PTION ", TRUE); 02176010 +ERRORTOG ~ FALSE; 02176100 +IF LISTOG THEN PRINTCARD; 02177000 +XTA ~ "FILE "; 02178000 +IF NSEG ! 0 THEN FLAG(60); 02179000 +IF INXFIL ~ INXFIL + 1 > MAXOPFILES THEN 02180000 +BEGIN FLAG(59); GO TO XIT END; 02181000 +BUMPPRT; 02182000 +MAXFILES ~ MAXFILES + 1; 02183000 +FILETOG ~ TRUE; SCN ~ 1; % START SCAN MAINTAINENCE 02184000 +FETCH; IF XTA.[12:6] > 11 THEN BEGIN FLAG(37); GO TO XIT END; 02185000 + IF XTA.[12:6] = 0 THEN BEGIN FLOG(037); GO TO XIT END; 02185010 +IF T ~ GLOBALSEARCH(P ~ 0&"."[12:42:6]&XTA[18:12:30]) ! 0 THEN FLAG(20) 02186000 +ELSE BEGIN P~ GLOBALENTER(-0&PRTS[TOADDR]&FILEID[TOCLASS],P); 02187000 + PUT(P+2,GET(P+2)&INXFIL[TOADINFO]); 02188000 + IF XREF THEN ENTERX(XTA &1[TOCE],1&FILEID[TOCLASS]); 02188100 + END; 02189000 +INFC ~ GET(P + 2); 02190000 +FETCH; IF NEXT = EQUAL THEN FETCH ELSE 02191000 + BEGIN FLOG(37); GO TO XIT; END; 02192000 +IF NEXT = SEMI THEN 02193000 +BEGIN FLAG(37); GO TO XIT END 02194000 + ELSE FILEINFO[2,INXFIL] ~ SRI7(ACCUM[1]); 02195000 +FETCH; IF NEXT = SLASH THEN 02196000 + BEGIN FILEINFO[1,INXFIL] ~ FILEINFO[2,INXFIL]; % MULTI FILE ID 02197000 + FETCH; 02198000 + IF NEXT = SEMI THEN BEGIN FLAG(37); GO TO XIT; END 02199000 + ELSE FILEINFO[2,INXFIL] ~ SRI7(ACCUM[1]); 02200000 + FETCH; 02201000 + END; 02202000 +IF XTA = "UNIT " THEN 02203000 +BEGIN 02204000 + FETCH; 02205000 + IF NEXT = EQUAL THEN FETCH ELSE FLOG(37); 02206000 + INFC.LINK ~ KEEP ~ (IF TOG ~ XTA = "PRINT " 02207000 + OR XTA = "PRINTE" THEN 18 ELSE 02208000 + IF CA ~ TOG ~ XTA = "READ " 02209000 + OR XTA = "READER" THEN 2 ELSE 02210000 + IF CA ~ TOG ~ XTA = "PUNCH " THEN 0 ELSE 02211000 + IF TOG ~ XTA = "DISK " THEN 12 ELSE 02212000 + IF TOG ~ XTA = "TAPE " 02213000 + OR XTA = "TAPE7 " THEN 2 ELSE 02214000 + IF TOG ~ XTA = "PAPER " THEN 8 ELSE 02214100 + IF CA ~TOG~XTA= "REMOTE" THEN 19 ELSE 02214500 + IF TOG ~ XTA = "TAPE9 " THEN 2 ELSE 2); 02215000 + IF TOG THEN FETCH ELSE FLOG(37) 02216000 +END ELSE INFC.LINK~KEEP~IF DCINPUT THEN 12 ELSE 2 ; 02217000 +TS~KEEP=12 ; 02217050 +IF XTA="BACKUP" THEN 02217100 + BEGIN 02217150 + FETCH; IF KEEP!0 AND KEEP!18 THEN FLAG(37); 02217200 + IF TOG~XTA="DISK " THEN KEEP~IF KEEP=0 THEN 22 ELSE 15 02217250 + ELSE IF TOG~XTA="TAPE " THEN KEEP~IF KEEP=0 THEN 20 ELSE 6 02217275 + ELSE BEGIN 02217300 + TOG~XTA="ALTERN"; KEEP~IF KEEP=0 THEN 25 ELSE 16 ; 02217350 + END; 02217400 + IF TOG THEN FETCH; INFC.LINK~KEEP ; 02217450 + END ; 02217500 +IF XTA = "UNLABE" THEN % FOR UNLABELED TAPES 02218000 + BEGIN IF KEEP = 2 THEN INFC .LINK ~ 9; FETCH; END; 02219000 +IF XTA = "ALPHA " THEN FETCH ELSE IF KEEP = 2 THEN ALPH ~ 1; % MODE 02220000 +IF XTA = "BCL " THEN FETCH; % FOR B3500 02221000 +IF XTA = "FIXED " THEN FETCH; % FOR B3500 02222000 +IF XTA = "SAVE " THEN SAVER ~ REPLACEMENT; 02223000 +IF XTA = "LOCK " THEN BEGIN SPIN ~ 2; FETCH END; % REW & LOCK AT EOJ 02224000 + IF TOG ~ XTA = "RANDOM" THEN T ~ 10 ELSE 02225000 + IF TOG ~ XTA = "SERIAL" THEN T ~ 12 ELSE 02226000 + IF TOG ~ XTA = "UPDATE" THEN T ~ 13; 02227000 +IF TOG THEN 02228000 + BEGIN IF KEEP=12 THEN INFC.LINK~T ELSE FLAG(37); FETCH END; 02229000 +IF XTA="AREA " THEN 02230000 + BEGIN 02230010 + IF KEEP!12 THEN FLAG(37); 02230020 + T~REPLACEMENT; 02230030 + IF XTA="EU " THEN 02230040 + IF I~REPLACEMENT>19 THEN FLAG(37) 02230045 + ELSE T.EUNF~I+1;% 0 MEANS EU NOT SPECIFIED 02230050 + IF XTA="SPEED " THEN 02230060 + BEGIN 02230070 + FETCH; 02230080 + IF NEXT=EQUAL THEN 02230090 + BEGIN 02230100 + FETCH; 02230110 + IF XTA.[12:6]{SLOWV THEN 02230115 + IF I~MAKEINT(XTA)>SLOWV THEN FLAG(37) 02230120 + ELSE 02230125 + ELSE IF XTA="FAST " THEN T.SPDF~FASTV 02230130 + ELSE IF XTA="SLOW " THEN T.SPDF~SLOWV 02230140 + ELSE FLOG(37); 02230150 + FETCH; 02230160 + END 02230170 + ELSE FLOG(37); 02230180 + END; 02230190 + IF XTA="SENSIT" THEN 02230200 + BEGIN 02230210 + T.SENSE~1; 02230220 + FETCH; 02230230 + END; 02230240 + FILEINFO[3,INXFIL]~T; 02230300 + END; 02230400 +IF XTA = "BLOCKI" THEN BLOCK ~ REPLACEMENT & 1[2:47:1]; 02231000 +RECORD ~ IF XTA="RECORD" THEN REPLACEMENT ELSE IF CA THEN 10 ELSE IF TS 02232000 + AND NOT (BOOLEAN(BLOCK.[2:1])) THEN 10 & 1[2:47:1] ELSE 17; 02232010 +BUFF ~ IF XTA = "BUFFER" THEN REPLACEMENT ELSE 2; 02233000 +IF XTA = "WORKAR" THEN FETCH; % IGNORED, FOR 3500 02234000 +IF BUFF<1 OR BUFF>32 THEN BEGIN XTA~"BUFFER"; FLAG(152) END ; 02236000 +IF RECORD<1 THEN BEGIN XTA~"RECORD"; FLAG(152)END ; 02236010 +IF SAVER>999 THEN BEGIN XTA~"SAVE "; FLAG(152) END ; 02236020 +IF T~INFC.LINK=10 OR T=12 OR T=13 THEN %%% ARE IN DISK FILE 02237000 + BEGIN 02237010 + IF BOOLEAN(RECORD.[2:1])THEN BLOCK ~ 300 02237012 + ELSE 02237015 + IF BLOCK~BLOCK|RECORD>1890 OR RECORD>1023 THEN 02237020 + BEGIN XTA~"BK/REC"; FLAG(152) END 02237021 + END 02237030 +ELSE IF BLOCK~BLOCK|RECORD>1023 OR RECORD>1023 THEN IF KEEP ! 2 THEN 02237040 + BEGIN XTA~"BK/REC"; FLAG(58 ) END ELSE BEGIN RECORD~257; BLOCK~0END;02237050 +FILEINFO[0,INXFIL] ~ 0&BUFF[42:42:6]&RECORD[30:36:12]&BLOCK[18:36:12] 02238000 + &SAVER[6:36:12]&SPIN[4:46:2]&ALPH[3:47:1]; 02239000 +XIT: IF NEXT ! SEMI THEN 02240000 + BEGIN FLOG(37); DO SCAN UNTIL NEXT = SEMI; END; 02241000 + FILETOG ~ FALSE; % END SCAN MAINTAINENCE 02242000 + PUT(P+2,INFC); 02243000 +IF DEBUGTOG THEN FLAGROUTINE(" FILEO","PTION ",FALSE) ; 02243100 +END FILEOPTION; 02244000 +PROCEDURE DOLOPT; 02245000 +BEGIN 02245300 +REAL STREAM PROCEDURE SCAN(BUF,ID); VALUE BUF; 02245600 + BEGIN LABEL LP,LA,LE,XIT; 02245900 + SI ~ BUF; DI ~ ID; DS ~ 2 LIT "0"; 02246200 + LP: IF SC = " " THEN BEGIN SI~SI+1; GO TO LP; END; 02246500 + IF SC = "," THEN BEGIN SI~SI+1; GO TO LP; END; 02246800 + IF SC = "+" THEN BEGIN DS~CHR; GO TO XIT; END; 02246900 + IF SC = "-" THEN BEGIN DS~CHR; GO TO XIT; END; 02247000 + IF SC < "A" THEN BEGIN DI ~ ID; DS ~ 8 LIT "+0000001"; 02247100 +LE: SI~SI+1; 02247200 + GO TO XIT; 02247400 + END; 02247700 + IF SC="|" THEN GO TO LE;% THIS IS > "A" 02247800 + IF SC="!" THEN GO TO LE;% THIS IS > "A" 02247900 + 6(IF SC = ALPHA THEN DS ~ CHR ELSE JUMP OUT); 02248000 + LA: IF SC = ALPHA THEN BEGIN SI~SI+1; GO TO LA; END; 02248300 + XIT: 02248600 + SCAN ~ SI; 02248900 + END SCAN; 02249200 +REAL STREAM PROCEDURE GETVOID(BUF,VOIDSEQ,FR); VALUE BUF,FR; 02249500 + BEGIN LABEL L,LC,LD,LE,XIT; LOCAL TA; 02249800 + SI ~ BUF; DI~VOIDSEQ; DS~8LIT" "; DI~VOIDSEQ; 02250100 + L: IF SC = " " THEN BEGIN SI~SI+1; GO TO L; END; 02250400 + TA ~ SI; 02250500 + IF SC = """ THEN 02250700 + BEGIN 9(SI~SI+1; 02251000 + IF SC = """ THEN BEGIN SI~SI+1; JUMP OUT TO LC; END 02251300 + ELSE TALLY ~ TALLY + 1); 02251600 + TALLY~TALLY+63; SI~TA; SI~SI+1; GO TO LE; 02251900 + END; 02252200 + IF SC < "0" THEN GO TO LD; 02252500 + DS:=8LIT"0"; %115-02252600 + 8(SI:=SI+1; DI:=DI-1; TALLY:=TALLY+1; %115-02252800 + IF SC LSS "0" THEN JUMP OUT); %115-02252850 + LC: SI ~ TA; 02252900 + LE: TA~TALLY; DS~TA CHR; GETVOID~SI; GO TO XIT; 02253100 + LD: GETVOID~SI; 02253400 + FR(DS~8LIT"9"); 02253700 + XIT: 02254000 + END GETVOID; 02254300 +REAL STREAM PROCEDURE SEQNUM(BUF,VLU); VALUE BUF; 02254600 + BEGIN LABEL L,LA,LC; LOCAL TA,TB; 02254900 + SI ~ BUF; 02255200 + L: IF SC = " " THEN BEGIN SI~SI+1; GO TO L; END; 02255500 + IF SC = "," THEN BEGIN SI~SI+1; GO TO L; END; 02255800 + TA ~ SI; 02256100 + IF SC = "+" THEN 02256400 + BEGIN SI~SI+1; 02256700 + LA: IF SC = " " THEN BEGIN SI~SI+1; GO TO LA;END; 02257400 + TB ~ SI; 02257300 + IF SC < "0" THEN BEGIN SI~TA; GO TO LC; END; 02257600 + DI~TB;TA~DI; 02257900 + END; 02258200 + 8(IF SC < "0" THEN JUMP OUT TO LC; 02258500 + TALLY~TALLY+1; SI~SI+1;); 02258800 + LC: TB ~ TALLY; SEQNUM ~ SI; 02259100 + SI ~ TA; DI ~ VLU; DS ~ TB OCT; 02259400 + END SEQNUM; 02259700 +REAL STREAM PROCEDURE MKABS(S); 02260000 + BEGIN SI ~ S; SI~SI+1; MKABS ~ SI; 02260300 + DI ~ S; 9(DI ~ DI + 8); DS ~ LIT "["; 02260600 + END MKABS; 02260900 +STREAM PROCEDURE MOVEW(P,Q); VALUE Q; 02260925 +BEGIN SI~P; DI ~ Q; DS~CHR; END ; 02260950 + REAL BUF,ID; 02261200 + BOOLEAN VAL, SAVELISTOG; %511-02261500 + LABEL LP,SET,RESET; 02261800 + FORMAT WARN(X18,A6," ILLEGAL CONSTRUCT ON DALLAR CARD XXXX",X39, 02262100 + "WARNING"); 02262400 + DEFINE GETID = BEGIN ID~ " "; BUF ~ SCAN(BUF,ID) END#; 02262700 + SAVELISTOG ~ LISTOG; %511- 02262775 + MOVEW(CRD[9],BUFL); 02262800 + BUF ~ MKABS(CRD[0]); 02263000 + GETID; 02263300 + IF ID = "VOID " THEN 02263600 + BEGIN BUF ~ GETVOID(BUF, VOIDSEQ,0); VOIDTOG ~ TRUE 02263900 + END ELSE 02264200 + IF ID = "VOIDT " THEN 02264500 + BEGIN BUF ~ GETVOID(BUF, VOIDTSEQ,0); VOIDTTOG ~ TRUE 02264800 + END ELSE 02265100 + BEGIN 02265400 + TAPETOG.[47:1] ~ LASTMODE = 2; %517-02265700 + IF ID = "SET " OR ID = "+ " THEN 02267200 +SET: BEGIN GETID; VAL~ TRUE END 02267500 + ELSE 02267800 + IF ID = "RESET " OR ID = "- " THEN 02268100 +RESET: BEGIN GETID; VAL ~ FALSE END 02268400 + ELSE 02268700 + BEGIN 02269000 + TSSMESTOG ~ VAL; TSSEDITOG ~ VAL; CHECKTOG ~ VAL; %501-02269300 + SINGLETOG~NOT VAL; HOLTOG~VAL; %501-02269600 + LISTOG~VAL; CODETOG ~ DEBUGTOG ~ VAL; NEWTPTOG ~ VAL; 02269900 + PRTOG~VAL; DOLIST~VAL; LIBTAPE~VAL; SEGPTOG~VAL; %501-02270200 + LISTPTOG ~ VAL; FREEFTOG ~ XREF ~ VAL ; 02270500 + VAL ~ TRUE; 02270800 + END; 02271100 +LP: IF ID > 0 THEN 02271400 + BEGIN 02271700 + IF ID = "TRACE " THEN 02272000 + BEGIN PRTOG~VAL; LISTOG~VAL; CODETOG~DEBUGTOG~VAL; 02272300 + END ELSE 02272400 + IF ID = "CARD " THEN 02272500 + BEGIN TAPETOG.[47:1]~NOT VAL; LASTMODE~2-REAL(VAL) END ELSE 02272510 + IF ID = "TAPE " THEN 02272550 + BEGIN TAPETOG.[47:1] ~ VAL; LASTMODE ~ REAL(VAL)+1; END ELSE02272560 + IF ID = "NOSEQ " THEN SEQTOG ~ FALSE ELSE 02272600 + IF ID = "SET " OR ID = "+ " THEN GO TO SET ELSE 02272900 + IF ID = "RESET " OR ID = "- " THEN GO TO RESET ELSE 02273200 + IF ID = "ONSITE" AND NOT REMFIXED THEN REMOTETOG ~ FALSE ELSE 02273500 + IF ID = "REMOTE" AND NOT REMFIXED THEN REMOTETOG ~ VAL ELSE 02273800 + IF ID = "FREEFO" THEN FREEFTOG ~ VAL ELSE 02274100 + IF ID = "SINGLE" OR ID = "SGL " THEN 02274400 + BEGIN SINGLETOG ~ VAL; LISTOG ~ TRUE; END ELSE 02274700 + IF ID = "NEW " OR ID = "NEWTAP" THEN 02275000 + BEGIN LIBTAPE~VAL; NEWTPTOG~VAL; NTAPTOG~TRUE; %501-02275100 + IF ID = "NEW " THEN %501-02275120 + BEGIN %501-02275140 + GETID; %501-02275160 + IF ID ! "TAPE " THEN %501-02275180 + GO TO LP; %501-02275200 + END; %501-02275220 + END ELSE %501-02275240 + IF ID = "LIST " THEN LISTOG ~ VAL ELSE 02275300 + IF ID = "SEQXEQ" AND NOT SEGSWFIXED THEN SEGSW ~ VAL ELSE 02275600 + IF ID = "PRT " THEN PRTOG ~ VAL ELSE 02275900 + IF ID = "DEBUGN" THEN 02276200 + BEGIN LISTOG~VAL; CODETOG~VAL; PRTOG ~ VAL END ELSE 02276500 + IF ID = "TIME " THEN TIMETOG ~ VAL ELSE 02276800 + IF ID = "ERRMES" THEN TSSMESTOG ~ VAL ELSE 02277100 + IF ID = "TSSEDI" THEN TSSEDITOG ~ VAL ELSE 02277400 + IF ID = "LISTLI" THEN LISTLIBTOG ~ VAL ELSE 02277700 + IF(ID = "SEGMEN" OR ID = "SEG ") AND VAL THEN 02278000 + BEGIN ADR~ADR+1; SEGOVF; END ELSE 02278300 + IF ID = "PAGE " AND VAL THEN WRITE(LINE[PAGE]) ELSE 02278600 + IF ID = "VOID " THEN 02278900 + BEGIN VOIDTOG ~ VAL; 02279200 + IF VAL THEN BUF ~ GETVOID(BUF,VOIDSEQ,1); 02279300 + END ELSE 02279500 + IF ID = "VOIDT " THEN 02279800 + BEGIN VOIDTTOG ~ VAL; 02280100 + IF VAL THEN BUF ~ GETVOID(BUF,VOIDTSEQ,1); 02280300 + END ELSE 02280400 + IF ID = "LIMIT " THEN 02280700 + BEGIN LIMIT ~ IF VAL THEN 0 ELSE @60; 02281000 + BUF ~ SEQNUM(BUF,LIMIT); 02281300 + IF LIMIT LEQ ERRORCT THEN GO TO POSTWRAPUP; 02281600 + END ELSE 02282500 + IF ID = "XREF " THEN 02282800 + BEGIN 02282850 + PXREF ~ TRUE; XREF ~ VAL; 02282900 + END ELSE 02282950 + IF ID = "SEQ " THEN 02283100 + BEGIN SEQTOG ~ VAL; 02283200 + IF VAL THEN 02283300 + BEGIN SEQBASE ~ SEQINCR ~ 0; 02283400 + BUF ~ SEQNUM(BUF,SEQBASE); 02283700 + BUF ~ SEQNUM(BUF,SEQINCR); 02284000 + IF SEQINCR { 0 THEN SEQINCR ~ 1000; 02284600 + END END ELSE 02284900 + IF ID = "LISTDO" THEN DOLIST ~ VAL ELSE 02285200 + IF ID = "HOL " THEN HOLTOG ~ VAL ELSE 02285500 + IF ID = "CHECK " THEN CHECKTOG ~ VAL ELSE 02285800 + IF ID = "NEWPAG" THEN SEGPTOG ~ VAL ELSE %501-02286100 + IF ID = "LISTP " THEN LISTPTOG ~ VAL ELSE 02286400 + BEGIN IF FIRSTCALL THEN DATIME; 02286700 + IF UNPRINTED THEN BEGIN PRINTCARD; UNPRINTED~FALSE END; 02287000 + IF SINGLETOG THEN WRITE(LINE,WARN,ID) 02287300 + ELSE WRITE(RITE,WARN,ID); 02287600 + END 02287900 + ; 02288200 + GETID; 02288500 + GO TO LP; 02288800 + END; 02289100 + END; 02289400 + IF DOLIST OR LISTOG OR SAVELISTOG THEN %511-02289450 + IF UNPRINTED THEN PRINTCARD; %517-02289500 + UNPRINTED ~ TRUE; 02289600 +END DOLOPT; 02289700 +STREAM PROCEDURE NEWSEQ(A,B); VALUE B; 02317000 + BEGIN 02318000 + SI ~ LOC B; DI ~ A; DS ~ 8 DEC; 02319000 + END NEWSEQ; 02320000 +INTEGER STREAM PROCEDURE SEQCHK(T,C); 02321000 + BEGIN 02322000 + SI ~ T; DI ~ C; 02323000 + IF 8 SC < DC THEN TALLY ~ 4 ELSE 02324000 + BEGIN 02325000 + SI ~ SI - 8; DI ~ DI - 8; 02326000 + IF 8 SC =DC THEN TALLY ~ 2 02327000 + ELSE TALLY ~ 3; 02328000 + END; 02329000 + SEQCHK ~ TALLY; 02330000 + END SEQCHK; 02331000 +BOOLEAN PROCEDURE READACARD; 02332000 +BEGIN 02333000 +DEFINE FLAGI(FLAGI1) = BEGIN FLAG(FLAGI1); GO TO E4A;END #; 02333050 +REAL STREAM PROCEDURE SCANINC(BUF,ID,RESULT,N,M); 02333100 + VALUE BUF,M,N; 02333120 + BEGIN 02333140 + LOCAL TA; 02333160 + LABEL LP,LQ,XIT; 02333180 + DI := RESULT; DI := DI +7; 02333200 + SI := BUF; 02333210 + LP: IF SC = " " THEN BEGIN SI := SI + 1; GO TO LP; END; 02333220 + IF SC = ALPHA THEN ELSE BEGIN DS:=LIT "1"; DI:=ID; DS~2LIT"0"; 02333240 + DS := CHR; DS := 5LIT" ";GO TO XIT; END; 02333260 + IF SC LSS "0" THEN DS:=LIT "2" ELSE DS:=LIT "3"; %400-02333270 + N (DI:=ID; DS:=8 LIT "0 "; DI:=DI-7; %400-02333280 + 7(IF SC=ALPHA THEN DS~CHR ELSE JUMP OUT 2 TO XIT); 02333300 + JUMP OUT TO XIT); 02333320 + M ( 8 ( IF SC LSS "0" THEN JUMP OUT 2 TO LQ; %400-02333360 + IF SC GTR "9" THEN JUMP OUT 2 TO LQ; %400-02333370 + SI:=SI+1; TALLY:=TALLY+1)); %400-02333380 + LQ: TA := TALLY; 02333400 + SI := SI - TA; 02333420 + DI := ID; 02333440 + DS := TA OCT; 02333460 + XIT: SCANINC := SI; 02333500 + END SCANINC; 02333520 +REAL STREAM PROCEDURE MKABS(S); 02333540 + BEGIN SI := S; SI := SI + 1; MKABS := SI; END; 02333550 +STREAM PROCEDURE MOVE(P, Q); VALUE Q; 02334000 +BEGIN SI ~ P; DI ~ Q; DS ~ CHR; 02335000 + DI ~ P; DS ~ LIT "]"; 02336000 +END MOVE; 02337000 +STREAM PROCEDURE MOVEC(C,B); VALUE B; 02337100 +BEGIN SI~B; DI~C; DS~CHR; END; 02337200 +BOOLEAN STREAM PROCEDURE GETCOL1(BUF); 02338000 + BEGIN 02339000 + SI ~ BUF; IF SC = "$" THEN TALLY ~ 1; 02340000 + GETCOL1 ~ TALLY; 02341000 + END; 02342000 +STREAM PROCEDURE TSSEDITS(C,P); BEGIN SI~C; DI~P; DS~10WDS; SI~C ; 02342010 +IF SC="C" THEN BEGIN DI~P; DI~DI+1; DS~LIT"-" END ELSE 02342020 +IF SC!"$" THEN BEGIN SI~SI+5; IF SC!" " THEN IF SC!"0" THEN BEGIN DI~P;02342030 +DS~6LIT"- " END END END OF TSSEDITS ; 02342040 +STREAM PROCEDURE MOVEW(F,T,B,R); VALUE B, R; 02343000 + BEGIN 02344000 + LABEL XIT; 02345000 + SI ~ F; DI ~ T; 02346000 + B( 02347000 + 2(40( IF SC = ALPHA THEN DS ~ CHR ELSE 02348000 + IF SC = " " THEN DS ~ CHR ELSE 02349000 + IF SC = "%" THEN BEGIN DS ~ LIT "("; SI ~ SI+1 END ELSE 02350000 + IF SC = "[" THEN BEGIN DS ~ LIT ")"; SI ~ SI+1 END ELSE 02351000 + IF SC = "#" THEN BEGIN DS ~ LIT "="; SI ~ SI+1 END ELSE 02352000 + IF SC = "&" THEN BEGIN DS ~ LIT "+"; SI ~ SI+1 END ELSE 02353000 + IF SC = "@" THEN BEGIN DS ~ LIT """; SI ~ SI+1 END ELSE 02354000 + IF SC = ":" THEN BEGIN DS ~ LIT """; SI ~ SI+1 END ELSE 02354100 + IF SC = "<" THEN BEGIN DS ~ LIT "+"; SI ~ SI+1 END ELSE 02355000 + IF SC = ">" THEN BEGIN DS ~ LIT "="; SI ~ SI+1 END ELSE 02356000 + DS ~ CHR )); JUMP OUT TO XIT); 02357000 + DS ~ 10 WDS; 02358000 + XIT: 02359000 + SI~LOC R; SI~SI+7; DI~DI+1 ; 02360000 + DS~CHR ; 02361000 + END MOVEW; 02362000 +ALPHA STREAM PROCEDURE DCMOVEW(F,T,B,FIL,R); VALUE B,FIL,R; 02362010 + BEGIN LOCAL C; LABEL L1,L2,L3,L4 ; 02362020 + SI~F; DI~T; 2(SI~SI+36; DS~36LIT" "); C~SI; DS~8CHR ; 02362030 + SI~LOC R; SI~SI+6; DS~2CHR; DI~C; DS~8LIT"]";TALLY~33;SI~F; 02362033 + IF SC = " " THEN %%% IT MIGHT BE A FILES CARD. 02362034 + BEGIN SI~SI+1; IF SC="F" THEN 02362035 + BEGIN DI~LOC FIL; DI~DI+2; IF 5SC=DC THEN 02362036 + BEGIN DI~F; SI~LOC FIL; SI~SI+2; DS~6CHR ; GO TO L1; END 02362037 + ELSE SI~F END ELSE SI~F END 02362038 + ELSE IF SC = "F" THEN BEGIN DI~LOC FIL;DI~DI+2;IF 6SC=DC THEN GO L1 02362040 + ELSE SI~F;END 02362041 + ELSE IF SC="-" THEN 02362042 + BEGIN %%% IT IS A CONTINUATION CARD. 02362044 + SI~SI+1; DI~T; DS~6LIT" *" ; 02362050 + 5(IF SC=" " THEN SI~SI+1 ELSE JUMP OUT); GO TO L2 ; 02362060 + END 02362063 + ELSE IF SC="C" THEN 02362066 + BEGIN %%% IT MIGHT BE A COMMENT CARD. 02362070 + SI~SI+1; IF SC="-" THEN GO TO L1 ELSE SI~F ; 02362080 + END ; 02362090 + IF SC!"$" THEN %%% IT IS NOT A COMMENT CARD, NOR IS IT A $ CARD, 02362100 + BEGIN %%% NOR A CONTINUATION CARD, NOR A FILES CARD. 02362110 + 2(33(IF SC=" " THEN SI~SI+1 ELSE JUMP OUT 2 TO L3)); L3: DI~T;02362120 + 5(IF SC=" " THEN SI~SI+1 ELSE IF SC}"0" THEN IF SC{"9" 02362130 + THEN DS~CHR ELSE JUMP OUT ELSE JUMP OUT) ; 02362140 + DI~T; DI~DI+6; IF SC=" " THEN SI~SI+1 ; 02362150 + END 02362160 + ELSE 02362170 + BEGIN 02362180 + L1: SI~F; DI~T; TALLY~36 ; 02362190 + END ; 02362200 + L2: C~TALLY ; 02362210 + B(2(C(IF SC>">" THEN DS~CHR ELSE IF SC<"[" THEN DS~CHR ELSE 02362220 + IF SC="%" THEN BEGIN DS~LIT"("; SI~SI+1 END ELSE 02362230 + IF SC="#" THEN BEGIN DS~LIT"="; SI~SI+1 END ELSE 02362235 + IF SC="&" THEN BEGIN DS~LIT"+"; SI~SI+1 END ELSE 02362240 + IF SC="@" THEN BEGIN DS~LIT"""; SI~SI+1 END ELSE 02362245 + IF SC=":" THEN BEGIN DS~LIT"""; SI~SI+1 END ELSE 02362250 + IF SC="<" THEN BEGIN DS~LIT"+"; SI~SI+1 END ELSE 02362255 + IF SC=">" THEN BEGIN DS~LIT"="; SI~SI+1 END ELSE 02362260 + IF SC="[" THEN BEGIN DS~LIT")"; SI~SI+1 END ELSE 02362265 + IF SC="]" THEN JUMP OUT 3 TO L4 ELSE DS~CHR));JUMP OUT TO L4);02362270 + 2(C(IF SC="]" THEN JUMP OUT 2 TO L4 ELSE DS~CHR)) ; 02362275 + L4: DI~LOC DCMOVEW; DS~8LIT"00 "; DI~DI-6 ; 02362280 + 6(IF SC="]" THEN JUMP OUT ELSE DS~CHR) ; 02362285 + END OF DCMOVEW ; 02362290 +STREAM PROCEDURE SEQERR(BUFF, NEW, OLD); 02362300 +BEGIN 02362400 + DI ~ BUFF; DS ~ 18 LIT "SEQUENCE ERROR "; 02362450 + SI ~ NEW; DS ~ LIT"""; 02362500 + DS ~ 8 CHR; DS ~ LIT """; 02362550 + DS ~ 3 LIT " < "; 02362600 + SI ~ OLD; DS ~ LIT """; 02362650 + DS ~ 8 CHR; DS ~ LIT """; 02362700 + DS ~ 59 LIT " "; 02362750 + DS ~ 8 LIT "X"; DS ~ 4 LIT " "; 02362800 +END SEQERR; 02362850 +STREAM PROCEDURE DCMOVE(E,C,A,N); VALUE A,N; 02362855 +BEGIN SI~C; DI~E; DS~10WDS; DS~4CHR; SI~LOC A; DS~4DEC; 02362860 + N(DS~8LIT" PATCH"); END; 02362865 + REAL BUF,ID; 02362900 + BOOLEAN NOWRI; LABEL ENDPB, E4B; 02362902 + LABEL LIBADD, ENDPA, E4A, E4, STRTA; 02362950 + LABEL E1,E2,E3,STRT,ENDP,XIT; 02363000 + UNPRINTED~TRUE; 02363100 + GO TO STRT; 02364000 +LIBADD: 02364100 + XTA := BLANKS; 02364130 + IF INSERTDEPTH = -1 THEN SAVECARD ~ NEXTCARD; 02364160 + MOVE (CRD[9],BUFL); 02364240 + 02364280 + IF (INSERTDEPTH ~ INSERTDEPTH + 1) GTR INSERTMAX THEN 02364300 + FLAG(158); 02364320 + NEWTPTOG ~ FALSE; 02364330 + INSERTINX ~ -1; 02364340 + INSERTCOP ~ 0; 02364350 + BLANKIT(SSNM[5],1,0); 02364360 + BUF ~ SCANINC(BUF,INSERTMID,RESULT,1,0); 02364380 + IF RESULT = 1 AND INSERTMID = "+ "THEN 02364381 + BEGIN BUF~SCANINC(BUF,ID,RESULT,1,0); 02364382 + IF ID = "COPY " THEN INSERTCOP ~ 1 02364383 + ELSE FLAG(155); 02364384 + BUF~SCANINC(BUF,INSERTMID,RESULT,1,0); 02364385 + END; 02364386 + IF RESULT NEQ 2 THEN FLAGI (155); 02364400 + BUF := SCANINC(BUF,ID,RESULT,0,1); %107-02364420 + IF RESULT = 1 THEN IF ID = "/ " THEN 02364440 + BEGIN BUF := SCANINC(BUF,INSERTFID,RESULT,1,0); 02364460 + IF RESULT NEQ 2 THEN FLAGI(155); 02364480 + BUF := SCANINC(BUF,ID,RESULT,0,1); 02364500 + END ELSE INSERTFID := TIME(-1) ELSE INSERTFID := TIME(-1); 02364520 + IF RESULT = 3 THEN 02364540 + BEGIN NEWSEQ(SSNM[5],ID); 02364560 + BUF := SCANINC(BUF,ID,RESULT,0,1); 02364580 + IF RESULT NEQ 1 THEN FLAGI(156); 02364600 + IF ID = "] " THEN NEWSEQ (INSERTSEQ,99999999) %400-02364605 + ELSE BEGIN %400-02364610 + BUF ~ SCANINC(BUF,ID,RESULT,0,1); 02364620 + IF RESULT NEQ 3 THEN FLAGI(157); 02364640 + NEWSEQ (INSERTSEQ,ID); 02364660 + END %400-02364670 + END ELSE IF ID = "] " THEN NEWSEQ(INSERTSEQ,999999999) 02364680 + ELSE FLAGI(157); 02364700 + IF INSERTDEPTH > 0 THEN CLOSE (LF,RELEASE); 02364720 + FILL LF WITH INSERTMID,INSERTFID; 02364740 + DO BEGIN 02364760 + READ (LF[INSERTINX ~ INSERTINX+1],10,DB[*])[E4]; 02364780 + END UNTIL SEQCHK(SSNM[5],DB[9]) NEQ 3; 02364800 + NEWTPTOG ~ BOOLEAN(INSERTCOP); 02364810 + IF NOT NEWTPTOG THEN 02364811 + BEGIN 02364815 + IF SEQTOG THEN 02364820 + BEGIN NEWSEQ(CRD[9],SEQBASE); MOVE(CRD[9],BUFL); 02364830 + SEQBASE~SEQBASE+SEQINCR; 02364840 + END; MOVEC(CRD[9],BUFL); 02364850 + IF LIBTAPE AND(INSERTDEPTH = 0 ) THEN WRITE(NEWTAPE,10,CRD[*]); 02364860 + END; %511- 02364885 + IF LISTOG OR DOLIST THEN PRINTCARD; %511- 02364890 + NEXTCARD~7; 02364900 + GO TO STRT; 02364910 + E1: IF NEXTCARD=1 THEN IF TAPETOG THEN 02365000 + BEGIN 02366000 + NEXTCARD~5; READ(TP,10,TB[*])[E2]; GO TO STRT ; 02367000 + END 02368000 + ELSE 02369000 + BEGIN 02370000 + NEXTCARD:=6; 02371000 + IF GETCOL1(CRD[0]) THEN BEGIN BUF := MKABS(CRD[0]); 02371002 + BUF:=SCANINC(BUF,ID,RESULT,1,0); IF ID NEQ INCLUDE 02371004 + THEN BLANKIT(CRD,9,1); END; 02371006 + GO TO ENDP ; 02371010 + END ; 02371020 + NEXTCARD ~ 5; GO TO ENDP; 02372000 + E2: IF NEXTCARD = 5 THEN 02372010 + BEGIN 02372020 + NEXTCARD:=6; 02372030 + IF GETCOL1(CRD[0]) THEN BEGIN BUF := MKABS(CRD[0]); 02372040 + BUF:=SCANINC(BUF,ID,RESULT,1,0); IF ID NEQ INCLUDE 02372050 + THEN BLANKIT(CRD,9,1); END; 02372060 + END 02373000 + ELSE IF NEXTCARD!2 THEN NEXTCARD~1 ELSE 02373010 + BEGIN 02373020 + NEXTCARD~1; TAPETOG~BOOLEAN(2); READ(CR,10,CB[*])[E1] ; 02373030 + END ; 02373040 + IF VOIDTTOG THEN IF SEQCHK(CRD[0],VOIDTSEQ) < 4 %114-02373045 + THEN VOIDTTOG~FALSE %114-02373100 + ELSE BEGIN VOIDTTOG~FALSE; GO TO STRT; END; %114-02373200 + GO TO ENDP ; 02374000 + E4B: NOWRI ~TRUE; 02374050 + IF SEQTOG THEN NEWSEQ(CRD[9],SEQBASE); 02374053 + IF NEWTPTOG THEN IF TSSEDITOG THEN 02374055 + BEGIN TSSEDITS(CRD,PRINTBUFF); WRITE(NEWTAPE,10,PRINTBUFF[*]); 02374060 + END ELSE WRITE(NEWTAPE,10,CRD[*]); 02374065 + E4: CLOSE (LF,RELEASE); 02374100 + NEWTPTOG~ SAVETOG; 02374110 + IF (INSERTDEPTH := INSERTDEPTH - 1) = -1 THEN 02374150 + BEGIN NEXTCARD ~ SAVECARD; GO TO ENDPA; END 02374200 + ELSE NEWTPTOG ~ BOOLEAN(INSERTCOP); 02374300 + FILL LF WITH INSERTMID,INSERTFID; 02374450 + READ(LF[INSERTINX := INSERTINX + 1],10,DB[*])[E4]; 02374470 + IF SEQCHK(INSERTSEQ,DB[9]) = 4 THEN GO TO E4; 02374500 + GO TO ENDP; 02374520 + E4A: 02374560 + NEWTPTOG~SAVETOG; 02374580 + IF (INSERTDEPTH ~ INSERTDEPTH-1) = -1 THEN NEXTCARD~SAVECARD 02374600 + ELSE NEWTPTOG ~ BOOLEAN(INSERTCOP); 02374680 + STRT: 02375000 + STRTA: 02375600 + IF NEXTCARD=6 THEN GO XIT ; 02376000 + CARDCOUNT ~ CARDCOUNT+1; 02377000 + IF NEXTCARD = 1 THEN 02378000 + BEGIN % CARD ONLY 02379000 + IF(NOT DCINPUT OR TSSEDITOG)AND NOT FREEFTOG 02380000 + THEN MOVEW(CB,CRD,HOLTOG,IF DCINPUT THEN "D" ELSE "R") 02380100 + ELSE IF SSNM[4]~DCMOVEW(CB,CRD,HOLTOG,"FILE ",IF FREEFTOG 02380125 + THEN " R" ELSE " D") ! " " THEN 02380150 + BEGIN XTA~SSNM[4] ; 02380175 + MOVESEQ(SSNM[4],LASTSEQ); MOVESEQ(LASTSEQ,CRD[9]) ; 02380200 + IF LISTOG THEN 02380210 + BEGIN IF FIRSTCALL THEN DATIME ; 02380220 + DCMOVE(PRINTBUFF,CRD,(ADR+1).[36:10],0); 02380230 + WRITAROW(11,PRINTBUFF); UNPRINTED~FALSE ; 02380240 + END ; 02380250 + FLOG(149); MOVESEQ(LASTSEQ,SSNM[4]) ; 02380300 + END ; 02380400 + IF GETCOL1(CRD[0]) THEN 02381000 + BEGIN 02382000 + BUF := MKABS(CRD[0]); 02382200 + BUF := SCANINC(BUF,ID,RESULT,1,0); 02382300 + IF ID NEQ INCLUDE THEN 02382400 + BEGIN 02382500 + DOLOPT; 02383000 + IF REAL(TAPETOG)=3 THEN READ(TP) ; 02383010 + READ(CR,10,CB[*])[E1]; 02384000 + IF NOT TAPETOG THEN GO TO STRT; 02385000 + READ(TP,10,TB[*])[E2]; 02386000 + NEXTCARD ~ SEQCHK(TB[9], CB[9]); 02387000 + GO TO STRT; 02388000 + END; 02389000 + END; 02389100 + IF LISTPTOG THEN 02389200 + BEGIN IF FIRSTCALL THEN DATIME; 02389300 + IF SEQTOG THEN NEWSEQ(CRD[9],SEQBASE); 02389400 + DCMOVE(PRINTBUFF,CRD,(ADR+1).[36:10],1); 02389500 + WRITAROW (12,PRINTBUFF); UNPRINTED ~ FALSE; 02389600 + END; 02389700 + READ(CR,10,CB[*])[E1]; 02390000 + GO TO ENDP; 02391000 + END; 02392000 + IF NEXTCARD = 5 THEN 02393000 + BEGIN 02394000 + MOVEW(TB,CRD,HOLTOG,"T") ; 02395000 + READ(TP, 10, TB[*])[E2]; 02396000 + IF VOIDTTOG THEN IF SEQCHK(CRD[9],VOIDTSEQ) < 4 THEN 02396100 + VOIDTTOG ~ FALSE ELSE GO TO STRT; 02396200 + GO TO ENDP; 02397000 + END; 02398000 + IF NEXTCARD { 3 THEN 02399000 + BEGIN % CARD OVER TAPE 02400000 + IF(NOT DCINPUT OR TSSEDITOG)AND NOT FREEFTOG 02401000 + THEN MOVEW(CB,CRD,HOLTOG,IF DCINPUT THEN "D" ELSE "R") 02401100 + ELSE IF SSNM[4]~DCMOVEW(CB,CRD,HOLTOG,"FILE ",IF FREEFTOG 02401125 + THEN " R" ELSE " D") ! " " THEN 02401150 + BEGIN XTA~SSNM[4] ; 02401175 + MOVESEQ(SSNM[4],LASTSEQ); MOVESEQ(LASTSEQ,CRD[9] ); 02401200 + IF LISTOG THEN 02401210 + BEGIN IF FIRSTCALL THEN DATIME; 02401220 + DCMOVE(PRINTBUFF,CRD,(ADR+1).[36:10],0); 02401230 + WRITAROW(11,PRINTBUFF); UNPRINTED~FALSE ; 02401240 + END; 02401250 + FLOG(149); MOVESEQ(LASTSEQ,SSNM[4]) ; 02401300 + END; 02401400 + IF NEXTCARD =2 THEN READ(TP,10,TB[*])[E2]; 02402000 + IF GETCOL1(CRD) THEN 02403000 + BEGIN 02404000 + BUF ~ MKABS(CRD[0]); 02404200 + BUF ~ SCANINC(BUF,ID,RESULT,1,0); 02404300 + IF ID NEQ INCLUDE THEN 02404400 + BEGIN 02404500 + DOLOPT; 02405000 + READ(CR,10,CB[*])[E3]; 02406000 + NEXTCARD ~ SEQCHK(TB[9], CB[9]); 02407000 + GO TO STRT; 02408000 + E3: NEXTCARD~5; GO TO STRT; 02408500 + END; 02409000 + END; 02409100 + IF LISTPTOG THEN 02409200 + BEGIN IF FIRSTCALL THEN DATIME; 02409300 + IF SEQTOG THEN NEWSEQ(CRD[9],SEQBASE); 02409400 + DCMOVE(PRINTBUFF,CRD,(ADR+1).[36:10],1); 02409500 + WRITAROW (12,PRINTBUFF); UNPRINTED ~ FALSE; 02409600 + END; 02409700 + READ(CR,10,CB[*])[E1]; 02410000 + NEXTCARD ~ SEQCHK(TB[9], CB[9]); 02411000 + GO TO ENDP; 02412000 + END; 02413000 + % TAPE BEFORE CARD 02414000 + IF NEXTCARD = 7 THEN 02414100 + BEGIN 02414150 + IF(NOT DCINPUT OR TSSEDITOG)AND NOT FREEFTOG 02414175 + THEN MOVEW(DB,CRD,HOLTOG,"L") ELSE IF XTA~DCMOVEW(DB,CRD, 02414200 + HOLTOG,"FILE ",IF FREEFTOG THEN " R" ELSE " D") 02414225 + ! " " THEN FLOG(149); 02414250 + IF GETCOL1(CRD[0]) THEN 02414260 + BEGIN 02414270 + BUF ~ MKABS(CRD[0]); 02414280 + BUF ~ SCANINC(BUF,ID,RESULT,1,0); 02414290 + IF ID = INCLUDE THEN GO TO LIBADD; 02414300 + END; 02414310 + READ(LF[INSERTINX~INSERTINX+1],10,DB[*])[E4B]; 02414370 + IF SEQCHK(INSERTSEQ,DB[9]) = 4 THEN GO TO E4B; 02414380 + IF GETCOL1(CRD[0]) THEN BEGIN DOLOPT; GO TO STRT; END; 02414382 + GO TO ENDP; 02414390 + END; 02414400 + MOVEW(TB,CRD,HOLTOG,"T") ; 02415000 + READ(TP,10,TB[*])[E2]; 02416000 + IF VOIDTTOG THEN IF SEQCHK(CRD[9],VOIDTSEQ) < 4 THEN 02416100 + VOIDTTOG~FALSE ELSE BEGIN NEXTCARD~SEQCHK(TB[9],CB[9]); %114-02416200 + GO TO STRT; END; %114-02416300 + NEXTCARD ~ SEQCHK(TB[9], CB[9]); 02417000 + ENDP: 02418000 + IF NEXTCARD NEQ 7 THEN 02418100 + IF VOIDTOG THEN IF SEQCHK(CRD[9],VOIDSEQ) < 4 THEN 02419000 + VOIDTOG ~ FALSE ELSE GO TO STRT; 02419050 + IF GETCOL1(CRD[0]) THEN 02419100 + BEGIN 02419150 + BUF ~ MKABS(CRD[0]); 02419200 + BUF ~ SCANINC(BUF,ID,RESULT,1,0); 02419250 + IF ID = INCLUDE THEN GO TO LIBADD ELSE GO TO STRT; 02419300 + END; 02419325 + SEQERRORS ~ FALSE; 02420000 + IF NEXTCARD = 7 THEN 02420010 + BEGIN MOVESEQ(LASTSEQ,CRD[9]); GO TO ENDPA; END; 02420011 + IF CHECKTOG AND SEQERRCT=0 THEN SEQERRCT~1 ; 02420015 + IF CHECKTOG THEN IF SEQCHK(LASTSEQ,CRD[9])=3 THEN 02420020 + BEGIN 02420030 + SEQERR(ERRORBUFF,CRD[9],LASTSEQ) ; 02420040 + MOVESEQ(LASTSEQ,CRD[9]) ; 02420050 + IF SEQTOG THEN 02420053 + BEGIN NEWSEQ(CRD[9],SEQBASE);SEQBASE~SEQBASE+SEQINCR END;02420057 + MOVESEQ(LINKLIST,CRD[9]); 02420060 + MOVE(CRD[9],BUFL) ; 02420070 + SEQERRCT~SEQERRCT+1 ; 02420080 + SEQERRORS~TRUE ; 02420090 + IF NOT LISTOG THEN PRINTCARD ; 02420100 + END 02420110 + ELSE MOVESEQ(LASTSEQ,CRD[9]) ELSE MOVESEQ(LASTSEQ,CRD[9]) ; 02420120 + 02420150 + 02420200 + 02420250 + 02420300 + 02420350 + 02420400 + 02420450 + 02420500 +ENDPA: 02420550 + IF SEQTOG THEN 02421000 + BEGIN 02422000 + NEWSEQ(CRD[9],SEQBASE); 02423000 + SEQBASE ~ SEQBASE + SEQINCR; 02424000 + END; 02425000 + IF NOWRI THEN GO TO ENDPB; 02425100 + IF NEWTPTOG THEN IF TSSEDITOG THEN BEGIN TSSEDITS(CRD,PRINTBUFF) ; 02426000 + WRITE(NEWTAPE,10,PRINTBUFF[*]) END ELSE WRITE(NEWTAPE,10,CRD[*]) ; 02426005 +ENDPB: 02426008 + IF NOT SEQERRORS THEN 02426010 + BEGIN 02426020 + MOVESEQ(LINKLIST,CRD[9]) ; 02426030 + MOVE(CRD[9],BUFL) ; 02426040 + END ; 02427000 + NCR ~ INITIALNCR; 02428000 + READACARD ~ TRUE; 02429000 +XIT: 02430000 + SEGSWFIXED ~ TRUE ; 02431000 + REMFIXED~TRUE ; 02431005 + IF TSSEDITOG THEN WARNED~TRUE ; 02431100 + IF LISTOG AND FIRSTCALL THEN DATIME; 02432000 + IF SEGSW THEN %%% ENTER SEQ# AND ADR TO LINESEG ARRAY. 02432100 + BEGIN IF LASTADDR!ADR THEN BEGIN NOLIN~NOLIN+1; LASTADDR~ADR END;02432200 + LINESEG[NOLIN.IR,NOLIN.IC]~0 & D2B(LASTSEQ)[10:20:28] & (ADR+3) 02432300 + [38:36:10] ; 02432400 + END ; 02432500 +END READACARD; 02433000 +INTEGER STREAM PROCEDURE CONVERT(NUB,SIZE,P,CHAR); VALUE P; 02434000 + BEGIN 02435000 + LOCAL T; 02436000 + SI ~ P; 02437000 + 8(IF SC < "0" THEN JUMP OUT; 02438000 + SI ~ SI + 1; TALLY ~ TALLY + 1); 02439000 + CONVERT ~ SI; 02440000 + DI ~ CHAR; DS ~ 7 LIT "0"; DS ~ CHR; 02441000 + T ~ TALLY; 02442000 + SI ~ P; DI ~ NUB; DS ~ T OCT; 02443000 + DI ~ SIZE ; SI ~ LOC T; DS ~ WDS; 02444000 + END CONVERT; 02445000 +PROCEDURE SCAN; 02446000 +BEGIN 02447000 +BOOLEAN STREAM PROCEDURE ADVANCE(NCR, ACR, CHAR, NCRV, ACRV); 02448000 +VALUE NCRV, ACRV, CHAR; 02449000 +BEGIN LABEL LOOP; 02450000 + LABEL DIG, ALPH, BK1, BK2, SPEC; 02451000 + DI ~ ACRV; 02452000 + SI ~ CHAR; SI ~ SI+8; 02453000 + IF SC ! " " THEN 02454000 + IF SC } "0" THEN BEGIN SI ~ NCRV; GO TO BK1 END ELSE 02455000 + BEGIN SI ~ NCRV; GO TO BK2 END; 02456000 + SI ~ NCRV; 02457000 + LOOP: 02458000 + IF SC = " " THEN BEGIN SI~SI+1; GO TO LOOP END; 02459000 + IF SC } "0" THEN 02460000 + BEGIN 02976000 + DIG: DS ~ CHR; 02977000 + BK1: IF SC = " " THEN BEGIN SI ~ SI+1; GO TO BK1 END; 02978000 + IF SC } "0" THEN GO TO DIG; 02979000 + GO TO SPEC; 02980000 + END; 02981000 + IF SC = ALPHA THEN 02982000 + BEGIN 02983000 + ALPH: DS ~ CHR; 02984000 + BK2: IF SC = " " THEN BEGIN SI ~ SI+1; GO TO BK2 END; 02985000 + IF SC = ALPHA THEN GO TO ALPH; 02986000 + END; 02987000 + SPEC: 02988000 + ACRV ~ DI; 02989000 + DS ~ 6 LIT " "; 02990000 + IF SC = "]" THEN 02991000 + BEGIN TALLY ~ 1; SI ~ LOC ACRV; 02992000 + DI ~ ACR; DS ~ WDS; 02993000 + DI ~ CHAR; DS ~ LIT ";"; 02994000 + END ELSE 02995000 + BEGIN DI ~ CHAR; DS ~ CHR; 02996000 + ACRV ~ SI; SI ~ LOC ACRV; 02997000 + DI ~ NCR; DS ~ WDS; 02998000 + END; 02999000 + ADVANCE ~ TALLY; 03000000 +END ADVANCE; 03001000 +BOOLEAN PROCEDURE CONTINUE; 03002000 +BEGIN 03003000 +LABEL LOOP; 03004000 + 03005000 +BOOLEAN STREAM PROCEDURE CONTIN(CD); 03006000 +BEGIN SI~CD; IF SC!"C" THEN IF SC!"$" THEN BEGIN SI~SI+5; IF SC!" " 03007000 +THEN IF SC!"0" THEN BEGIN TALLY~1; CONTIN~TALLY END END END OF CONTIN ;03008000 +BOOLEAN STREAM PROCEDURE COMNT(CD,T); VALUE T; 03009000 +BEGIN LABEL L ; 03010000 + SI ~ CD; IF SC = "C" THEN BEGIN T(SI~SI+1; IF SC="-" THEN TALLY~1 03011000 + ELSE JUMP OUT TO L); TALLY~1; L: END; COMNT~TALLY ; 03012000 +END COMNT; 03013000 +BOOLEAN STREAM PROCEDURE DCCONTIN(CD); 03014000 +BEGIN 03015000 + SI ~ CD; IF SC = "-" THEN TALLY ~ 1; 03016000 + DCCONTIN ~ TALLY; 03017000 +END DCCONTIN; 03018000 +LOOP: IF NOT(CONTINUE ~ 03019000 + IF(DCINPUT AND NOT TSSEDITOG)OR FREEFTOG THEN 03020000 + IF NEXTCARD < 4 THEN DCCONTIN(CB) 03021000 + ELSE IF NEXTCARD = 7 THEN DCCONTIN(DB)ELSE CONTIN(TB) 03022000 + ELSE IF NEXTCARD = 7 THEN CONTIN(DB) 03023000 + ELSE IF NEXTCARD < 4 THEN CONTIN(DB) ELSE 03024000 + CONTIN(TB)) THEN 03025000 + IF(IF NEXTCARD < 4 THEN 03026000 + COMNT(CB,(DCINPUT AND NOT TSSEDITOG) OR FREEFTOG) 03027000 + ELSE IF NEXTCARD = 7 THEN 03028000 + COMNT(CB,(DCINPUT AND NOT TSSEDITOG) OR FREEFTOG) 03029000 + ELSE COMNT(TB,0) AND NEXTCARD ! 6) THEN 03030000 + BEGIN 03031000 + IF READACARD THEN IF LISTOG THEN PRINTCARD; 03032000 + GO TO LOOP; 03033000 + END; 03034000 +END CONTINUE; 03035000 + 03036000 +PROCEDURE SCANX(EOF1, EOF2, EOS1, EOS2, OK1, OK2); 03037000 + VALUE EOF1, EOF2, EOS1, EOS2, OK1, OK2; 03038000 + INTEGER EOF1, EOF2, EOS1, EOS2, OK1, OK2; 03039000 +BEGIN LABEL LOOP, LOOP0 ; 03040000 + LOOP0: 03041000 + EXACCUM[1] ~ BLANKS; 03042000 + ACR ~ ACR1; 03043000 + LOOP: 03044000 + IF ADVANCE(NCR, ACR, CHR1, NCR, ACR) THEN 03045000 + IF CONTINUE THEN 03046000 + IF READACARD THEN 03047000 + BEGIN 03048000 + IF LISTOG THEN PRINTCARD ; 03049000 + IF ACR.[33:15]}EXACCUMSTOP THEN 03050000 + BEGIN XTA~BLANKS; FLOG(175); GO LOOP0 END ; 03051000 + GO LOOP ; 03052000 + END 03053000 + ELSE SCN ~ IF EXACCUM[1] = BLANKS THEN EOF1 ELSE EOF2 03054000 + ELSE SCN ~ IF EXACCUM[1] = BLANKS THEN EOS1 ELSE EOS2 03055000 + ELSE SCN ~ IF EXACCUM[1] = BLANKS THEN OK1 ELSE OK2; 03056000 +END SCANX; 03057000 + 03058000 +DEFINE CHAR = ACCUM[0]#; 03059000 +DEFINE T=SYMBOL#; 03060000 +INTEGER N; 03061000 +BOOLEAN STREAM PROCEDURE CHECKEXP(NCR, NCRV, A); VALUE NCRV; 03062000 +BEGIN 03063000 + SI ~ NCRV; 03064000 + IF SC = "*" THEN 03065000 + BEGIN DI ~ A; DI ~ DI+2; DS ~ 2 LIT "*"; SI ~ SI+1; NCRV ~ SI; 03066000 + TALLY ~ 1; CHECKEXP ~ TALLY; 03067000 + SI ~ LOC NCRV; DI ~ NCR; DS ~ WDS END; 03068000 +END CHECKEXP; 03069000 +PROCEDURE CHECKRESERVED; 03070000 +BEGIN LABEL RESWD, XIT, FOUND1, FOUND2, DONE; 03071000 +BOOLEAN STREAM PROCEDURE COMPLETECHECK(A,B,N); VALUE N ; 03072000 + BEGIN LABEL L ; 03073000 + SI~A; SI~SI-2; DI~B; N(IF SC!DC THEN JUMP OUT TO L); TALLY~1; 03074000 + L: COMPLETECHECK~TALLY ; 03075000 + END OF COMPLETECHECK; 03076000 +STREAM PROCEDURE XFER(FROM, T1, T2, N, M); VALUE FROM, N, M; 03077000 +BEGIN SI ~ FROM; DI ~ T1; DI ~ DI+2; 03078000 + DS ~ M CHR; 03079000 + SI ~ FROM; SI ~ SI+N; 03080000 + DI ~ T2; DI ~ DI+2; 03081000 + DS ~ 6 CHR; 03082000 +END XFER; 03083000 +STREAM PROCEDURE XFERA(FROM, NEXT1, NEXT2); 03084000 + VALUE FROM; 03085000 +BEGIN SI ~ FROM; SI ~ SI+6; 03086000 + DI ~ NEXT1; DI ~ DI+2; 03087000 + 5(IF SC } "0" THEN DS ~ CHR ELSE JUMP OUT); 03088000 + SI ~ SI+2; 03089000 + DI ~ NEXT2; DI ~ DI+2; 03090000 + 6(IF SC = ALPHA THEN DS ~ CHR ELSE JUMP OUT); 03091000 +END XFERA; 03092000 +BOOLEAN STREAM PROCEDURE CHECKFUN(FROM, TOO, N); VALUE FROM, N; 03093000 +BEGIN SI ~ FROM; SI ~ SI +N; 03094000 + IF SC = "O" THEN 03095000 + BEGIN SI ~ SI+1; 03096000 + IF SC = "N" THEN 03097000 + BEGIN SI ~ SI+1; TALLY ~ 1; 03098000 + DI ~ TOO; DI ~ DI+2; 03099000 + DS ~ 6 CHR; 03100000 + END; 03101000 + END; 03102000 + CHECKFUN ~ TALLY; 03103000 +END CHECKFUN; 03104000 +BOOLEAN STREAM PROCEDURE MORETHAN6(P); 03105000 +BEGIN SI ~ P; 03106000 + IF SC ! " " THEN TALLY ~ 1; 03107000 + MORETHAN6 ~ TALLY; 03108000 +END MORETHAN6; 03109000 +INTEGER I; ALPHA ID; 03110000 +INTEGER STOR ; 03111000 + IF ACCUM[1] = " " THEN 03112000 + BEGIN XTA ~ CHAR; FLOG(16); GO TO XIT END; 03113000 + IF CHAR = "= " OR CHAR = "# " THEN GO TO XIT; 03114000 + IF CHAR = "~ " THEN GO TO XIT; 03115000 + IF CHAR ! "( " AND CHAR ! "% " THEN GO TO RESWD; 03116000 + IF MORETHAN6(ACCUM[2]) THEN GO TO RESWD; 03117000 + COMMENT AT THIS POINT WE HAVE ( . 03118000 + THIS MUST BE ONE OF THE FOLLOWING: 03119000 + ASSIGNEMNT STATEMENT WITH SUBSCRIPTED VARIABLE AT THE LEFT. 03120000 + STATEMENT FUNCTION DECLARATION. 03121000 +CALL, REAL, ENTRY, GO TO, READ, WRITE, FORMAT, IF, DATA, CHAIN, PRINT OR03122000 + PUNCH; 03123000 + IF I ~ SEARCH(T) > 0 THEN 03124000 + IF GET(I).CLASS = ARRAYID THEN GO TO XIT; 03125000 + ID ~ T; ID.[36:12] ~ " "; 03126000 + FOR I~0 THRU RSP DO IF RESERVEDWORDSLP[I]=ID THEN IF (IF STOR 03127000 + ~RESLENGTHLP[I]-4<1 THEN TRUE ELSE COMPLETECHECK(ACCUM[2], 03128000 + RESERVEDWORDSLP[I+RSP1],STOR)) THEN GO FOUND1 ; 03129000 + GO TO XIT; 03130000 + FOUND1: 03131000 + NEXT ~ LPGLOBAL[I]; 03132000 + T ~ " "; 03133000 + XFER(ACR0, T, NEXTACC, I~RESLENGTHLP[I], IF I> 6 THEN 6 ELSE I); 03134000 + GO TO DONE; 03135000 + RESWD: 03136000 + COMMENT AT THIS POINT WE KNOW THE MUST BE A SPECIAL WORD 03137000 + TO IDENTIFY THE STATEMENT TYPE; 03138000 + ID ~ T; ID.[36:12] ~ " "; 03139000 + IF T = "ASSIGN" THEN 03140000 + BEGIN 03141000 + NEXTSCN ~ SCN; SCN ~ 14; 03142000 + NEXTACC ~ NEXTACC2 ~ " "; 03143000 + XFERA(ACR0, NEXTACC, NEXTACC2); 03144000 + NEXT ~ 1; 03145000 + GO TO XIT; 03146000 + END; 03147000 + FOR I~1 THRU RSH DO IF RESERVEDWORDS[I]=ID THEN IF (IF STOR~ 03148000 + RESLENGTH[I]-4<1 THEN TRUE ELSE COMPLETECHECK(ACCUM[2],RESERVEDWORDS03149000 + [I+RSH1],IF STOR>8 THEN 8 ELSE STOR)) THEN GO FOUND2 ; 03150000 + XTA ~ T; FLOG(16); GO TO XIT; 03151000 + FOUND2: 03152000 + NEXT ~ I+1; 03153000 + T ~ " "; 03154000 + XFER(ACR0, T, NEXTACC, I~RESLENGTH [I], IF I> 6 THEN 6 ELSE I); 03155000 + DONE: NEXTSCN ~ SCN; 03156000 + SCN ~ 6; 03157000 + IF NEXTACC = "FUNCTI" THEN 03158000 + IF CHECKFUN(ACR0, NEXTACC, I+6) THEN SCN ~ 13; 03159000 + XIT: 03160000 + EOSTOG~FALSE; 03161000 +END CHECKRESERVED; 03162000 + 03163000 +BOOLEAN PROCEDURE CHECKOCTAL; 03164000 +BEGIN 03165000 + INTEGER S, T; LABEL XIT; 03166000 +INTEGER STREAM PROCEDURE COUNT(ACRV,T); VALUE ACRV,T ; 03167000 + BEGIN 03168000 + LOCAL A,B; SI~LOC T; SI~SI+7 ; 03169000 + IF SC="1" THEN BEGIN SI~ACRV;IF SC="O" THEN SI~SI+1 END ELSE SI~ACRV;03170000 + IF SC!" " THEN 03171000 + BEGIN A~SI; 03172000 + 17(IF SC>"7" THEN BEGIN TALLY~17; JUMP OUT END ELSE IF SC < "0" THEN03173000 + BEGIN IF SC!" " THEN TALLY~17; JUMP OUT END; SI~SI+1; 03174000 + TALLY~TALLY+1) ; 03175000 + B~TALLY; SI~LOC B; SI~SI+7 ; 03176000 + IF SC="+" THEN BEGIN SI~A; IF SC>"3" THEN TALLY~17 END; 03177000 + END ; 03178000 + COUNT~TALLY ; 03179000 + END OF COUNT ; 03180000 +ALPHA STREAM PROCEDURE CONV(ACRV, S, T); VALUE ACRV, S, T; 03181000 +BEGIN SI ~ ACRV; IF SC = "O" THEN SI ~ SI+1; 03182000 + DI ~ LOC CONV; SKIP S DB; 03183000 + T(SKIP 3 SB; 3(IF SB THEN DS ~ SET ELSE DS ~ RESET; SKIP 1 SB)); 03184000 +END CONV; 03185000 + IF T~COUNT(ACR0,1) = 0 THEN 03186000 + BEGIN S ~ 1; 03187000 + IF T ~ CHAR ! "+ " AND T ! "& " THEN 03188000 + IF T = "- " THEN S ~ -1 ELSE GO TO XIT; 03189000 + SCANX(4, 4, 3, 3, 10, 10); 03190000 + IF SCN ! 10 THEN GO TO XIT; 03191000 + IF T~COUNT(ACR1,2) = 0 OR T > 16 THEN GO TO XIT ; 03192000 + FNEXT ~ CONV(ACR1, (16-T)|3, T); 03193000 + IF S < 0 THEN FNEXT ~ -FNEXT; 03194000 + END ELSE IF T < 17 THEN FNEXT~CONV(ACR0,(16-T)|3,T) ELSE GO TO XIT ; 03195000 + CHECKOCTAL ~ TRUE; 03196000 + NEXT ~ NUM; 03197000 + NUMTYPE ~ REALTYPE; 03198000 + XIT: 03199000 +END CHECKOCTAL; 03200000 + 03201000 +PROCEDURE HOLLERITH; 03202000 +BEGIN 03203000 + REAL T, COL1, T2, ENDP; 03204000 + LABEL XIT; 03205000 + INTEGER STREAM PROCEDURE STRCNT(S,D,SZ); VALUE S,SZ; 03206000 + BEGIN 03207000 + SI ~ S; DI ~ D;DS ~ 8 LIT "00 "; DI ~ D; 03208000 + DI ~ D; DI ~ DI + 2; DS ~SZ CHR; STRCNT ~ SI; 03209000 + END STRCNT; 03210000 + INTEGER STREAM PROCEDURE RSTORE(S,D,SKP,SZ); 03211000 + VALUE S, SKP, SZ; 03212000 + BEGIN 03213000 + DI ~ D; 03214000 + SI ~ S; DI ~DI + SKP; DS ~ SZ CHR; RSTORE ~ SI; 03215000 + END RSTORE; 03216000 + F1 ~ FNEXT; 03217000 + NUMTYPE ~ STRINGTYPE; 03218000 + T ~ 0 & NCR[30:33:15] & NCR[45:30:3]; 03219000 + COL1 ~ 0 & INITIALNCR[30:33:15]; 03220000 + ENDP ~ COL1 + 72; 03221000 + STRINGSIZE ~ 0; 03222000 + WHILE F1 >0 DO 03223000 + BEGIN 03224000 + T2 ~ IF F1 > 6 THEN 6 ELSE F1; 03225000 + IF STRINGSIZE > MAXSTRING THEN 03226000 + BEGIN FLAG(120); STRINGSIZE ~ 0 END; 03227000 + IF T+T2> ENDP THEN IF DCINPUT OR FREEFTOG THEN 03228000 + BEGIN XTA~BLANKS; FLOG(150); GO TO XIT END 03229000 + ELSE BEGIN 03230000 + IF TSSEDITOG THEN IF NOT DCINPUT THEN TSSED(BLANKS,1) ; 03231000 + NCR ~ STRCNT(NCR, STRINGARRAY[STRINGSIZE], ENDP-T); 03232000 + IF NOT CONTINUE THEN 03233000 + BEGIN FLOG(43); GO TO XIT END; 03234000 + IF READACARD THEN; 03235000 + IF LISTOG THEN PRINTCARD; 03236000 + NCR ~ RSTORE(NCR,STRINGARRAY[STRINGSIZE],ENDP-T+2,T2-(ENDP-T)); 03237000 + STRINGSIZE ~ STRINGSIZE+1; 03238000 + F1 ~ F1 - T2; 03239000 + T ~ COL1 + 6 + T2 - (ENDP - T); 03240000 + END ELSE 03241000 + BEGIN 03242000 + NCR ~ STRCNT(NCR, STRINGARRAY[STRINGSIZE], T2); 03243000 + STRINGSIZE ~ STRINGSIZE +1; 03244000 + T ~ T +T2; 03245000 + F1 ~ F1 - T2; 03246000 + END; 03247000 + END; 03248000 + NUMTYPE ~ STRINGTYPE; 03249000 + SCN ~ 1; 03250000 + XIT: 03251000 +END HOLLERITH; 03252000 +PROCEDURE QUOTESTRING; 03253000 +BEGIN 03254000 + REAL C; 03255000 + LABEL XIT; 03256000 + ALPHA STREAM PROCEDURE STRINGWORD(S,D,SKP,SZ,C); 03257000 + VALUE S,SKP,SZ; 03258000 + BEGIN 03259000 + LABEL QT, XIT; 03260000 + DI ~ D; SI ~ S; 03261000 + DI ~ DI+SKP; DI ~ DI+2; 03262000 + TALLY ~ SKP; 03263000 + SZ( IF SC = """ THEN JUMP OUT TO QT; 03264000 + IF SC = ":" THEN JUMP OUT TO QT; 03265000 + IF SC = "@" THEN JUMP OUT TO QT; 03266000 + IF SC = "]" THEN JUMP OUT TO XIT; 03267000 + DS ~ CHR; TALLY ~ TALLY+1); 03268000 + GO TO XIT; 03269000 + QT: TALLY ~ TALLY+7; SI ~ SI+1; 03270000 + XIT: STRINGWORD ~ SI; S ~ TALLY; 03271000 + SI ~ LOC S; DI ~ C; DS ~ WDS; 03272000 + END STRINGWORD; 03273000 + STRINGSIZE ~ 0; 03274000 + DO 03275000 + BEGIN 03276000 + IF STRINGSIZE > MAXSTRING THEN 03277000 + BEGIN FLAG(120); STRINGSIZE ~ 0 END; 03278000 + STRINGARRAY[STRINGSIZE] ~ BLANKS; 03279000 + NCR ~ STRINGWORD(NCR, STRINGARRAY[STRINGSIZE], 0, 6, C); 03280000 + IF C<6 THEN IF DCINPUT OR FREEFTOG 03281000 + THEN BEGIN XTA~BLANKS; FLOG(150); GO TO XIT END 03282000 + ELSE BEGIN 03283000 + IF TSSEDITOG THEN IF NOT DCINPUT THEN TSSED(BLANKS,1) ; 03284000 + IF NOT CONTINUE THEN 03285000 + BEGIN FLOG(121); GO TO XIT END; 03286000 + IF READACARD THEN; 03287000 + IF LISTOG THEN PRINTCARD; 03288000 + NCR ~ STRINGWORD(NCR, STRINGARRAY[STRINGSIZE ],C,6-C,C); 03289000 + END; 03290000 + STRINGSIZE ~ STRINGSIZE + 1; 03291000 + END UNTIL C } 7; 03292000 + IF C = 7 THEN STRINGSIZE ~ STRINGSIZE-1; 03293000 + FNEXT ~ STRINGSIZE; 03294000 + NEXT ~ NUM; 03295000 + SYMBOL ~ NAME ~ STRINGARRAY[0]; 03296000 + NUMTYPE ~ STRINGTYPE; 03297000 + SCN ~ 1; 03298000 + XIT: 03299000 +END QUOTESTRING; 03300000 + 03301000 +PROCEDURE CHECKPERIOD; 03302000 +BEGIN 03303000 +LABEL FRACTION, XIT, EXPONENT, EXPONENTSIGN; 03304000 +LABEL NUMFINI, FPLP, CHKEXP; 03305000 +ALPHA S, T, I, TS; 03306000 + INTEGER C2; 03307000 +BOOLEAN CON; 03308000 + IF T ~ CHAR ! ". " THEN GO TO CHKEXP; 03309000 +SCANX(4, 9, 3, 8, 10, 11); 03310000 +IF T ~ EXACCUM[1] = " " THEN 03311000 + BEGIN IF NUMTYPE ! DOUBTYPE THEN NUMTYPE ~ REALTYPE; GO TO XIT END; 03312000 +IF T = "E " OR T = "D " THEN GO TO EXPONENTSIGN; 03313000 +IF T.[12:6] { 9 THEN GO TO FRACTION; 03314000 +IF T.[18:6] { 9 THEN 03315000 +BEGIN 03316000 + IF S ~ T.[12:6] ! "E" AND S ! "D" THEN 03317000 + BEGIN XTA ~ T; FLOG(63); GO TO XIT END; 03318000 + EXACCUM[1].[12:6] ~ 0; 03319000 + I ~ 1; GO TO EXPONENT; 03320000 +END; 03321000 +IF EXACCUM[0] ! ". " THEN GO TO XIT; 03322000 +FOR I ~ 0 STEP 1 UNTIL 10 DO 03323000 + IF T = PERIODWORD[I] THEN 03324000 + BEGIN EXACCUM[2] ~ I; SCN ~ 12; GO TO XIT END; 03325000 +GO TO XIT; 03326000 +FRACTION: NEXT ~ NUM; 03327000 +IF NUMTYPE !DOUBTYPE THEN NUMTYPE ~ REALTYPE; XTA ~ ACR1; 03328000 +FPLP: 03329000 +F1 ~ 0; 03330000 +XTA ~ CONVERT(F1,C1,XTA ,TS); 03331000 +C2 ~ C2 + C1; 03332000 +IF (F2 ~ FNEXT|TEN[C1]+F1) { MAX 03333000 + THEN FNEXT ~ F2 03334000 + ELSE BEGIN 03335000 + NUMTYPE ~ DOUBTYPE; 03336000 + CON ~ TRUE; 03337000 + DOUBLE(FNEXT,DBLOW,TEN[C1],TEN[69+C1],|, 03338000 + F1,0,+,~,FNEXT,DBLOW); 03339000 + END; 03340000 +IF TS { 9 THEN GO TO FPLP; 03341000 +F1 ~ 0; 03342000 +IF T ~ EXACCUM[0] ! "E " AND T ! "D " THEN 03343000 +BEGIN IF SCN = 8 THEN SCN ~ 3 ELSE SCN ~ 10; 03344000 + GO TO NUMFINI; 03345000 +END; 03346000 +CHKEXP: FNEXT ~ FNEXT | 1.0; 03347000 +F1 ~ 0; 03348000 +I ~ 1; 03349000 +SCANX(4, 4, 3, 3, 20, 10); 03350000 +IF SCN = 20 THEN 03351000 +EXPONENTSIGN: 03352000 +BEGIN IF S ~ EXACCUM[0] ! "+ " AND S ! "& " THEN 03353000 + IF S = "- " THEN I ~ -1 ELSE 03354000 + BEGIN XTA ~ S; FLOG(63); SCN ~ 10; GO TO XIT END; 03355000 + SCANX(4, 4, 3, 3, 10, 10); 03356000 + END; 03357000 + IF (S ~ EXACCUM[1]).[12:6] > 9 THEN 03358000 + BEGIN XTA ~ IF S ! BLANKS THEN S ELSE T; FLOG(63); GO TO XIT END; 03359000 + EXPONENT: 03360000 + IF NUMTYPE ! DOUBTYPE THEN NUMTYPE ~ REALTYPE; 03361000 +IF T.[12:6] = "D" THEN NUMTYPE ~ DOUBTYPE; 03362000 + IF SCN = 8 THEN SCN ~ 3 ELSE IF SCN = 11 THEN SCN ~ 10; 03363000 + XTA ~ ACR1; 03364000 + XTA ~ CONVERT(F1,C1,XTA ,TS); 03365000 + IF I < 0 THEN F1 ~ -F1; 03366000 + NUMFINI: 03367000 + C1 ~ F1 - C2; 03368000 + IF I ~ (ABS(C1+(FNEXT.[3:6]&FNEXT[1:2:1]))) > 63 OR((ABS(C1) = I OR 03369000 + FNEXT } 5) AND ABS(F1) } 69) 03370000 + THEN BEGIN XTA ~ T; FLOG(87); GO TO XIT; END; 03371000 + IF NUMTYPE ! DOUBTYPE THEN 03372000 + BEGIN 03373000 + IF C1} 0 THEN FNEXT ~ FNEXT | TEN[C1] 03374000 + ELSE FNEXT ~ FNEXT / TEN[-C1]; 03375000 + END ELSE 03376000 + BEGIN 03377000 + IF C1 } 0 03378000 + THEN DOUBLE(FNEXT,DBLOW,TEN[C1],TEN[69+C1],|,~,FNEXT,DBLOW) 03379000 + ELSE DOUBLE(FNEXT,DBLOW,TEN[-C1],TEN[69-C1],/,~,FNEXT,DBLOW); 03380000 + IF CON THEN IF DBLOW.[9:33] = MAX.[9:33] THEN 03381000 + IF FNEXT.[3:6] LSS 14 03382000 + THEN IF BOOLEAN(FNEXT.[2:1]) THEN 03383000 + BEGIN DBLOW ~ 0; FNEXT ~ FNEXT + 1&FNEXT[2:2:7]; END; 03384000 + END; 03385000 + XIT: 03386000 +END CHECKPERIOD; 03387000 + 03388000 +LABEL LOOP0, NUMBER ; 03389000 +LABEL L,XIT; 03390000 +LABEL L1,L2,L3,L4,L5,L6,L7,L8,L9,L10,L11,L12,L13,L14,L15,L16,L17, 03391000 + L18,L19,L20,L21,BK ; 03392000 +SWITCH CASEL~L1,L2,L3,L4,L5,L6,L7,L8,L9,L10,L11,L12,L13,L14,L15, 03393000 + L16,L17,L18,L19,L20,L21 ; 03394000 +LABEL LOOP, CASESTMT; %994-03395000 +LABEL CASE0,CASE1,CASE2,CASE3,CASE4,CASE5,CASE6,CASE7; %994-03396000 +LABEL CASE8,CASE9,CASE10,CASE11,CASE12,CASE13,CASE14; %994-03397000 +PREC~NEXT~FNEXT~REAL(SCANENTER~FALSE) ; 03398000 +CASESTMT: 03399000 +CASE SCN OF 03400000 +BEGIN 03401000 +CASE0: %994-03402000 +GO TO IF LABELR THEN CASE5 ELSE CASE1; 03403000 +CASE1: 03404000 +BEGIN 03405000 + LOOP0: 03406000 + ACR ~ ACR0; 03407000 + ACCUM[1] ~ BLANKS; 03408000 + LOOP: 03409000 + IF ADVANCE(NCR, ACR, CHR0, NCR, ACR) THEN 03410000 + IF CONTINUE THEN 03411000 + IF READACARD THEN 03412000 + BEGIN 03413000 + IF LISTOG THEN PRINTCARD ; 03414000 + IF ACR.[33:15]}ACCUMSTOP THEN 03415000 + BEGIN XTA~BLANKS; FLOG(175); GO LOOP0 END ; 03416000 + GO LOOP ; 03417000 + END 03418000 + ELSE IF T ~ ACCUM[1] = " " THEN GO TO CASE5 ELSE SCN ~ 4 03419000 + ELSE IF T ~ ACCUM[1] = " " THEN 03420000 + GO TO CASE3 ELSE SCN ~ 3 03421000 + ELSE IF T ~ ACCUM[1] = " " THEN GO TO CASE2 ELSE SCN ~ 2; 03422000 +END; 03423000 +CASE2: 03424000 +BEGIN T ~ CHAR; SCN ~ 1 END; 03425000 +CASE3: 03426000 +BEGIN T ~ "; "; NEXT ~ SEMI; SCN ~ 0; 03427000 + IF EOSTOG THEN IF LOGIFTOG THEN BEGIN LOGIFTOG ~ FALSE; XTA ~ T; 03428000 + FLAG(101); END; 03429000 + GO TO XIT; 03430000 +END; 03431000 +CASE4: %994-03432000 +BEGIN T ~ "; "; NEXT ~ SEMI; SCN ~ 5; GO TO XIT END; 03433000 +CASE5: 03434000 +BEGIN T ~ " "; NEXT ~ EOF; EOSTOG ~ FALSE; GO TO XIT END; 03435000 +CASE6: %994-03436000 +BEGIN T ~ ACCUM[1] ~ NEXTACC; SCN ~ NEXTSCN; 03437000 + IF T = " " THEN GO TO CASESTMT; 03438000 +END; 03439000 +CASE7: %994-03440000 +BEGIN EOSTOG ~ TRUE; 03441000 + IF LABELR THEN GO TO CASE5 ELSE GO TO CASE1; 03442000 +END; 03443000 +CASE8: %994-03444000 +BEGIN T ~ EXACCUM[1]; SCN ~ 3 END; 03445000 +CASE9: %994-03446000 +BEGIN T ~ EXACCUM[1]; SCN ~ 4 END; 03447000 +CASE10: %994-03448000 +BEGIN T ~ CHAR ~ EXACCUM[0]; SCN ~ 1 END; 03449000 +CASE11: %994-03450000 +BEGIN T ~ EXACCUM[1]; SCN ~ 10 END; 03451000 +CASE12: %994-03452000 +BEGIN T ~ EXACCUM[1]; SCN ~ 1; 03453000 + IF N ~ EXACCUM[2] { 1 THEN 03454000 + BEGIN NEXT ~ NUM; FNEXT ~ N; GO TO XIT END; 03455000 + NEXT ~ 0; 03456000 + OP ~ N-1; 03457000 + PREC ~ IF N { 4 THEN N-1 ELSE 4; 03458000 + GO TO XIT; 03459000 +END; 03460000 +CASE13: %994-03461000 +BEGIN T ~ "FUNCTI"; NEXT ~ 16; SCN ~ 6; GO TO XIT END; 03462000 +CASE14: %994-03463000 +BEGIN T ~ ACCUM[1] ~ NEXTACC; 03464000 + NEXTACC ~ NEXTACC2; SCN ~ 6; 03465000 +END; 03466000 +END OF CASE STATEMENT; 03467000 +IF NOT FILETOG THEN 03468000 + IF EOSTOG THEN 03469000 + BEGIN 03470000 + NEXT ~ 0; 03471000 + IF T = "; " THEN GO TO CASESTMT; 03472000 + CHECKRESERVED; 03473000 + IF NEXT > 0 THEN GO TO XIT; 03474000 + END; 03475000 +IF (IDINFO~TIPE[T.[12:6]])>0 THEN 03476000 + BEGIN 03477000 +BK: NEXT~ID ; 03478000 + IF NOT FILETOG THEN 03479000 + IF SCANENTER~((FNEXT~SEARCH(T))=0) THEN FNEXT~ENTER(IDINFO,T) 03480000 + ELSE IF GET(FNEXT).CLASS=DUMMY THEN FNEXT~GET(FNEXT+2).BASE ; 03481000 + GO XIT ; 03482000 + END ; 03483000 +GO CASEL[-IDINFO]; % SEE INITIALIZATION OF "TIP". LINE 03433100%993- 03484000 +L1: %DIGITS %993- 03485000 +BEGIN NUMTYPE ~ INTYPE; NEXT ~ NUM; XTA ~ ACR0; 03486000 + FNEXT ~ DBLOW ~ C1 ~ 0; 03487000 + XTA ~ CONVERT(FNEXT,C1,XTA ,TS); 03488000 + WHILE TS { 9 DO 03489000 + BEGIN 03490000 + XTA ~ CONVERT(F1,C1,XTA ,TS); 03491000 + IF (F2 ~ FNEXT|TEN[C1]+F1) { MAX 03492000 + THEN FNEXT ~ F2 03493000 + ELSE BEGIN 03494000 + NUMTYPE ~ DOUBTYPE; 03495000 + DOUBLE(FNEXT,DBLOW,TEN[C1],TEN[69+C1],|, 03496000 + F1,0,+,~,FNEXT,DBLOW); 03497000 + END; 03498000 + END; 03499000 + IF CHAR = ". " OR CHAR = "E " OR CHAR = "D " THEN 03500000 + CHECKPERIOD 03501000 + ELSE IF CHAR = "H " THEN HOLLERITH; 03502000 + GO TO XIT; 03503000 +END; 03504000 +L2: % > %993- 03505000 +BEGIN PREC ~ 4; OP ~ 7; GO TO XIT END; 03506000 +L3: % } %993- 03507000 +BEGIN PREC ~ 4; OP ~ 8; GO TO XIT END; 03508000 +L4: % & OR + %993- 03509000 +BEGIN PREC ~ 5; OP ~ 10; NEXT ~ PLUS; GO TO XIT END; 03510000 +L5: % . %993- 03511000 +BEGIN 03512000 + FNEXT ~ DBLOW ~ C1 ~ 0; NUMTYPE ~ REALTYPE; 03513000 + CHECKPERIOD; 03514000 + T ~ EXACCUM[1]; 03515000 + IF SCN = 12 THEN 03516000 + BEGIN SCN ~ 1; 03517000 + IF N ~ EXACCUM[2] { 1 THEN 03518000 + BEGIN 03519000 + NEXT ~ NUM; FNEXT ~ N; 03520000 + NUMTYPE ~ LOGTYPE; GO TO XIT; 03521000 + END; 03522000 + NEXT ~ 0; 03523000 + OP ~ N-1; 03524000 + PREC ~ IF N { 4 THEN N-1 ELSE 4; 03525000 + GO TO XIT; 03526000 +END; 03527000 + IF NEXT ! NUM THEN BEGIN NEXT ~ NUM; XTA ~ T; FLOG(141) END; 03528000 + GO TO XIT; 03529000 +END; 03530000 +L6: % % OR ( %993-03531000 +BEGIN NEXT ~ LPAREN; GO TO XIT END; 03532000 +L7: % < %993-03533000 +BEGIN PREC ~ OP ~ 4; GO TO XIT END; 03534000 +L8: % LETTER 0 %993-03535000 +BEGIN IF DATATOG THEN IF CHECKOCTAL THEN GO TO XIT; 03536000 + IDINFO~TIPE[12]; GO BK ; 03537000 +END; 03538000 +L9: % $ %993-03539000 +BEGIN NEXT ~ DOLLAR; GO TO XIT END; 03540000 +L10: % * %993-03541000 +IF CHECKEXP(NCR, NCR, T) THEN 03542000 +BEGIN PREC ~ 9; OP ~ 15; NEXT ~ UPARROW; GO TO XIT END ELSE 03543000 +L11: 03544000 +BEGIN PREC ~ 7; OP ~ 13; NEXT ~ STAR; GO TO XIT END; 03545000 +L12: % - %993-03546000 +BEGIN PREC ~ 5; OP ~ 11; NEXT ~ MINUS; GO TO XIT END; 03547000 +L13: % ) OR [ %993-03548000 +BEGIN NEXT ~ RPAREN; GO TO XIT END; 03549000 +L14: % ; %993-03550000 +BEGIN NEXT ~ SEMI; GO TO XIT END; 03551000 +L15: % { %993-03552000 +BEGIN PREC ~ 4; OP ~ 5; GO TO XIT END; 03553000 +L16: % / %993-03554000 +BEGIN PREC ~ 7; OP ~ 14; NEXT ~ SLASH; GO TO XIT END; 03555000 +L17: % , %993-03556000 +BEGIN NEXT ~ COMMA; GO TO XIT END; 03557000 +L18: % ! %993-03558000 +BEGIN PREC ~ 4; OP ~ 9; GO TO XIT END; 03559000 +L19: % = OR ~ OR # %993- 03560000 +BEGIN NEXT ~ EQUAL; GO TO XIT END; 03561000 +L20: % ] %993-03562000 +BEGIN XTA ~ T; FLAG(0); GO TO CASESTMT END; 03563000 +L21: % " OR : OR @ %993-03564000 +BEGIN QUOTESTRING; GO TO XIT END; 03565000 +XIT: 03566000 +IF DEBUGTOG THEN WRITALIST(FD,3,NEXT,T," ",0,0,0,0,0) ; 03567000 + XTA ~ NAME ~ T; 03568000 +END SCAN; 03569000 + 03570000 +PROCEDURE WRAPUP; 03571000 + COMMENT WRAPUP OF COMPILIATION; 03572000 + BEGIN 03573000 +ARRAY PRT[0:7,0:127], 03574000 + SEGDICT[0:7,0:127], 03575000 + SEG0[0:29]; 03576000 +ARRAY FILES[0:BIGGESTFILENB]; 03577000 +INTEGER THEBIGGEST; 03578000 +SAVE ARRAY FPB[0:1022]; % FILE PARAMETER BLOCK 03579000 +REAL FPS,FPE; % START AND END OF FPB 03580000 +REAL GSEG,PRI,FID,MFID,IDNM,FILTYP,FPBI; 03581000 +BOOLEAN ALF; 03582000 +REAL PRTADR, SEGMNT, LNK, TSEGSZ, T1, I, FPBSZ; 03583000 + DEFINE 03584000 + SPDEUN= FPBSZ#, 03585000 + ENDDEF=#; 03586000 +ARRAY INTLOC[0:150]; 03587000 +REAL J; 03588000 +FORMAT SEGUS(A6, " IS SEGMENT ", I4, 03589000 + ", PRT IS ", A4, "."); 03590000 +LIST SEGLS(IDNM,NXAVIL,T1); 03591000 +LABEL LA, ENDWRAPUP; 03592000 + LABEL QQQDISKDEFAULT; %503-03593000 + COMMENT FORMAT OF SEGMENT DICTIONARY -RUN TIME ; 03594000 +DEFINE SGTYPF= [1:2]#, %0 = PROGRAM SEGMENTS 03595000 + SGTYPC= 1:46:2#,%1 = MCP INTRINSIC 03596000 + %2 = DATA SEGMENT 03597000 + PRTLINKF= [8:10]#, % LINK TO FIRT PRT ENTRY 03598000 + PRTLINKC= 8:38:10#, 03599000 + SGLCF = [18:15]#, % SEGMENT SIZE 03600000 + SGLCC = 23:38:10#, 03601000 + DKADRF = [33:15]#, % RELATIVE DISK ADDRESS OF SEGMENT 03602000 + % OR MCP INTRINSIC NUMBER 03603000 + DKADRC = 33:13:15#; 03604000 + COMMENT FORMAT OF FIRST SEGMENT OF CODE FILE- RUN TIME; 03605000 +COMMENT SEGO[0:29] 03606000 + WORD CONTENTS 03607000 + 0 LOCATION OF SEGMENT DICTIONARY 03608000 + 1 SIZE OF SEGMENT DICTIONARY 03609000 + 2 LOCATION OF PRT 03610000 + 3 SIZE OF PRT 03611000 + 4 LOCATION OF FILE PARAMETER BLOCK 03612000 + 5 SIZE OF FILE PARAMETER BLOCK 03613000 + 6 STARTING SEGMENT NUMBER 03614000 + 7-[2:1] IND FORTRAN FAULT DEC 03615000 + 7-[18:15] NUMBER OF FILES 03616000 + 7-[33:15] CORE REQUIRED/64 03617000 + ; 03618000 + COMMENT FORMAT OF PRT; 03619000 + % FLGF = [0:4] = 1101 = SET BY STREAM 03620000 +DEFINE MODEF =[4:2]#, % 0 = THUNK 03621000 + MODEC=4:46:2#, % 1 = WORD MODE PROGRAM DESCRIPTOR 03622000 + % 2 = LABEL DESCRIPTOR 03623000 + % 3 = CHARACTER MODE PROGRAM DESCRIPTOR 03624000 + STOPF =[6:1]#, % STOPPER = 1 FOR LAST DESCRIPTOR IN 03625000 + STOPC=6:47:1#, % CHAIN OF SAME SEGMENT DESCRIPTORS 03626000 + LINKF =[7:11]#, % IF STOP = 0 THEN PRTLINK 03627000 + LINKC=7:37:11#, % ELSE LINK TO SEGDICT 03628000 + FFF =[18:15]#,% INDEX INTO SEGMENT DICTIONARY 03629000 + FFC =18:33:15#, 03630000 + SINX = [33:15]#;% RELATIVE ADDRESS INTO SEGMENT 03631000 +DEFINE PDR = [37:5]#, 03632000 + PDC = [42:6]#; 03633000 +REAL STREAM PROCEDURE MKABS(F); 03634000 + BEGIN 03635000 + SI ~ F; MKABS ~ SI; 03636000 + END MKABS; 03637000 +REAL STREAM PROCEDURE BUILDFPB(DEST,FILNUM,FILTYP,MFID,FID,IDSZ, 03638000 + IDNM,SPDEUN); 03639000 + VALUE DEST,IDSZ,SPDEUN; 03640000 + BEGIN 03641000 + DI ~ DEST; 03642000 + SI ~ FILNUM; SI ~ SI + 6; DS ~ 2 CHR; 03643000 + SI ~ FILTYP; SI ~ SI + 7; DS ~ CHR; 03644000 + SI ~ MFID; SI ~ SI + 1; DS ~ 7 CHR; 03645000 + SI ~ FID; SI ~ SI + 1; DS ~ 7 CHR; 03646000 + SI ~ LOC IDSZ; SI ~ SI + 1; DS ~ IDSZ CHR; 03647000 + SI~LOC SPDEUN;SI~SI+6;DS~2 CHR;% DISK SPEED & EU NUMBER+1 03648000 + BUILDFPB ~ DI; 03649000 + DS ~ 2 LIT "0"; 03650000 + END BUILDFPB; 03651000 +REAL STREAM PROCEDURE GITSZ(F); 03652000 + BEGIN 03653000 + SI ~ F; SI ~SI + 7; TALLY ~ 7; 03654000 + 3(IF SC ! " " THEN JUMP OUT; 03655000 + SI ~SI - 1; TALLY ~ TALLY + 63;); 03656000 + GITSZ ~ TALLY; 03657000 + END GITSZ; 03658000 +STREAM PROCEDURE MOVE(F,T,SZ); VALUE SZ; 03659000 + BEGIN 03660000 + SI ~ F; DI ~T; DS ~ SZ WDS; 03661000 + END MOVE; 03662000 +INTEGER PROCEDURE MOVEANDBLOCK(FROM,SIZE); VALUE SIZE; 03663000 + ARRAY FROM[0,0]; INTEGER SIZE; 03664000 + BEGIN 03665000 + REAL T,NSEGS,J,I; 03666000 + STREAM PROCEDURE M2(F,T); BEGIN SI~F; DI~T; DS ~ 2 WDS; END M2; 03667000 + NSEGS ~ (SIZE+29) DIV 30; 03668000 + IF DALOC DIV CHUNK < T ~ (DALOC + NSEGS) DIV CHUNK 03669000 + THEN DALOC ~ CHUNK | T; 03670000 + MOVEANDBLOCK ~ DALOC; 03671000 + DO BEGIN FOR J ~ 0 STEP 2 WHILE J < 30 AND I 0 THEN 03705000 + BEGIN T1 ~ GET(T ~ GLOBALSEARCH(".SUBAR")+2); 03706000 + PUT(T,T1~T1&SAVESUBS[TOSIZE]); 03707000 + END; 03708000 + T1~PRGDESCBLDR(1,23,0,NSEG~NXAVIL~NXAVIL+1) ; % BUILD TPAR 03709000 + FILL LSTT[*] WITH 21(0),8(" ") ; % R+23 03710000 + WRITEDATA(29,NXAVIL,LSTT) ; 03711000 + PDPRT[(PDINX-1).[37:5],(PDINX-1).[42:6]].[6:1]~1 ; % SAVE BIT 03712000 + T1 ~ PRGDESCBLDR(1,22,0,NSEG ~ NXAVIL ~ NXAVIL + 1); 03713000 + WRITEDATA (138,NXAVIL,TEN); % POWERS OF TEN TABLE 03714000 + IF LSTI > 0 THEN 03715000 + BEGIN 03716000 + WRITEDATA(LSTI, NXAVIL ~ NXAVIL+1, LSTP); 03717000 + LSTA ~ PRGDESCBLDR(1, LSTA, 0, NXAVIL); 03718000 + END; 03719000 + IF TWODPRTX ! 0 THEN 03720000 + BEGIN 03721000 + FILL LSTT[*] WITH 03722000 + OCT0000000421410010, 03723000 + OCT0301001301412025, 03724000 + OCT2021010442215055, 03725000 + OCT2245400320211025, 03726000 + OCT0106177404310415, 03727000 + OCT1025042112350000; 03728000 + T ~ PRGDESCBLDR(0, TWODPRTX, 0, NXAVIL ~ NXAVIL+1); 03729000 + WRITEDATA(-6, NXAVIL, LSTT); 03730000 + END; 03731000 + COMMENT DECLARE GLOBAL FILES AND ARRAYS; 03732000 + FPS ~ FPE ~ MKABS(FPB); 03733000 + SEGMENTSTART; 03734000 + F2TOG ~ TRUE; 03735000 + GSEG ~ NSEG; 03736000 + FPBI ~ 0; 03737000 + EMITL(0); EMITL(2); EMITO(SSF); 03738000 + EMITL(1); % SET BLOCK COUNTER TO 1 03739000 + EMITL(16); EMITO(STD); 03740000 + EMITL(0); EMITOPDCLIT(23); EMITO(DEL); 03741000 + EMITL(REAL(HOLTOG)); EMITPAIR(21,STD); 03742000 + I ~ GLOBALNEXTINFO; WHILE I < 4093 DO 03743000 + BEGIN 03744000 + I ~ I+3; 03745000 + GETALL(I,INFA,INFB,INFC); 03746000 + IF INFA.CLASS = FILEID THEN %SEE COMMENTS ON LINE 02118000 %992-03747000 + BEGIN 03748000 + FPBI ~ FPBI + 1; 03749000 + PRI ~ INFA .ADDR; 03750000 + IF (XTA ~ INFB ).[18:6] < 10 THEN 03751000 + BEGIN 03752000 + IF XTA ~ MAKEINT(XTA) > BIGGESTFILENB THEN FLAG(77) ELSE 03753000 + FILES[XTA] ~ PRI; 03754000 + IF XTA > THEBIGGEST THEN THEBIGGEST ~ XTA; 03755000 + END; 03756000 + EMITO(MKS); 03757000 + IF J ~ INFC .ADINFO ! 0 THEN % OPTION FILE 03758000 + BEGIN FILTYP ~ INFC .LINK; 03759000 + IDNM ~ " "&"FILE"[6:24:24]&INFB[30:18:18]; 03760000 + T1 ~ GITSZ(IDNM); 03761000 + FID ~ FILEINFO[2,J]; 03762000 + MFID ~ FILEINFO[1,J]; 03763000 + IF FILTYP}10 AND (T~FILEINFO[3,J].DKAREASZ)!0 THEN 03764000 + BEGIN %%% SET UP ; 03765000 + SPDEUN~FILEINFO[3,J].SENSPDEUNF; 03766000 + B~IF (B~((J~FILEINFO[0,J]).[18:12])/(IF A~J.[30:12]{0 THEN03767000 + 1 ELSE A)){0 THEN 1 ELSE B ; 03768000 + %%% B=ORIGINAL "BLOCKING" SIZE = # LOGRECS/PHYSREC. 03769000 + A~ENTIER(B|ENTIER(T/(20|B)+.999999999)+.5) ; 03770000 + %%% T="AREA" SIZE = # LOGRECS IN TOTAL FILE. 03771000 + %%% A=# LOGRECS PER ROW. 03772000 + B~ENTIER(T/A+.999999999) ; 03773000 + %%% B = # ROWS IN FILE. 03774000 + %%% EQUIVALENT ALGOL FILE DESCRIPTION = [B:A]. 03775000 + %%% THE ABOVE LOGIC YIELDS: SHORTEST ROW CONTAINING 03776000 + %%% AN INTEGER NUMBER OF PHYSICAL RECORDS AND WHICH 03777000 + %%% REQUIRES 20 OR FEWER ROWS FOR THE TOTAL AREA, T.03778000 + EMITNUM(B); EMITNUM(A) ; 03779000 + END ELSE 03780000 + BEGIN EMITL(0); EMITL(0); 03781000 + J ~ FILEINFO[0,J]; % THIS ONE HAS ALL THE GOODIES 03782000 + END; 03783000 + QQQDISKDEFAULT: %503-03784000 + ESTIMATE~ESTIMATE+(J.[42:6])|(IF A~J.[18:12]=0 THEN J.[30:12] 03785000 + ELSE A) ; 03786000 + EMITL(J.[4:2]); % LOCK 03787000 + EMITL(FPBI); % FILE PARAM INDEX 03788000 + EMITDESCLIT(PRI); % PRT OF FILE 03789000 + EMITL(J.[42:6]); % # BUFFERS 03790000 + EMITL(J.[3:1]); % RECORDING MODE 03791000 + EMITNUM(J.[30:12]) ; % RECORD SIZE 03792000 + EMITNUM(J.[18:12]) ; % BLOCK SIZE 03793000 + EMITNUM(J.[ 6:12]) ; % SAVE FACTOR 03794000 + END ELSE 03795000 + BEGIN 03796000 + ALF ~TRUE; 03797000 + IF(FILTYP~INFC.LINK=2 OR FILTYP=12) AND INFB.[18:6]{9 THEN 03798000 + IDNM ~ 0&"FILE"[6:24:24]&INFB[30:18:18] 03799000 + ELSE 03800000 + BEGIN 03801000 + ALF ~ FALSE; 03802000 + IF (IDNM ~ " "&INFB[6:18:30]) = "READR " THEN 03803000 + IDNM ~ "READER "; 03804000 + END; 03805000 +IF IDNM="READER " OR IDNM="FILE5 " THEN IDNM~"CARD " ELSE %503-03806000 +IF IDNM="FILE6 " THEN BEGIN IDNM~"PRINTER";FILTYP~18;END ELSE %503-03807000 + BEGIN %503-03808000 + EMITL(20); EMITL(600); FILTYP~12; %20 | 600 REC DISK %503-03809000 + J~0&2[42:42:6]&10[30:36:12]&300[18:36:12]; %503-03810000 + FID~IDNM; MFID~"FORTEMP"; T1~GITSZ(IDNM); %503-03811000 + GO TO QQQDISKDEFAULT; %503-03812000 + END; %503-03813000 + T1 ~ GITSZ(IDNM); 03814000 + FID ~ IDNM; 03815000 + MFID ~ 0; 03816000 + IF DCINPUT AND ALF THEN BEGIN 03817000 + EMITL(20); % DISK ROWS 03818000 + EMITL(100); % DISK RECORD PER ROW 03819000 + EMITL(2); % REWIND AND LOCK 03820000 + EMITL(FPBI); % FILE NUMBER 03821000 + EMITDESCLIT(PRI); % PRT OF FILE 03822000 + EMITL(2); % NUMBER OF BUFFERS 03823000 + EMITL(1); % RECORDING MODE 03824000 + EMITL(10); % RECORD SIZE 03825000 + EMITL(30); % BLOCK SIZE 03826000 + EMITL(1); % SAVE FACTOR 03827000 + END ELSE 03828000 + BEGIN 03829000 + EMITL(0); % DISK ROWS 03830000 + EMITL(0); % DISK RECORDS PER ROW 03831000 + EMITL(0); % REWIND & RELEASE 03832000 + EMITL(FPBI); % FILE NUMBER 03833000 + EMITDESCLIT(PRI); % PRT OF FILE 03834000 + EMITL(2); % 2 BUFFERS 03835000 + EMITL(REAL(ALF)); 03836000 + EMITL(IF FILTYP = 0 THEN 10 ELSE 17); 03837000 + EMITL(0); % 15 WORD BUFFERS 03838000 + EMITL(0); % SAVE FACTOR (SCRATCH BY DEFAULT) 03839000 + END; 03840000 + END; 03841000 + EMITL(11); % INPUT OR OUTPUT 03842000 + EMITL(8); % SWITCH CODE FOR BLOCK 03843000 + EMITOPDCLIT(5); % CALL BLOCK 03844000 + FPE~BUILDFPB(FPE,FPBI,FILTYP,MFID,FID,T1,IDNM,SPDEUN); 03845000 + IF PRTOG THEN WRITALIST(FILEF,3,IDNM.[6:6],IDNM,B2D(PRI), 03846000 + 0,0,0,0,0) ; 03847000 + END 03848000 + ELSE 03849000 + IF INFA.CLASS = BLOCKID THEN 03850000 + BEGIN 03851000 + IF PRTOG THEN WRITALIST(BLOKF,3,INFB,B2D(INFA.ADDR), 03852000 + INFC.SIZE,0,0,0,0,0) ; 03853000 + IF INFA < 0 THEN ARRAYDEC(I); 03854000 + END; 03855000 + IF (T1 ~ INFA .CLASS) } FUNID 03856000 + AND T1 { SUBRID THEN 03857000 + BEGIN 03858000 + PRI ~ 0; 03859000 + IF INFA .SEGNO = 0 THEN 03860000 + BEGIN 03861000 + A~0; B~NUMINTM1 ; 03862000 + WHILE A+1 < B DO 03863000 + BEGIN 03864000 + PRI ~ REAL(BOOLEAN(A+B) AND BOOLEAN(1022)); 03865000 + IF IDNM ~ INT[PRI] = INFB THEN GO TO FOUND; 03866000 + IF INFB < IDNM THEN B ~ PRI.[36:11] ELSE A ~ PRI.[36:11]; 03867000 + END; 03868000 + IF IDNM ~ INT[PRI~(A+B)|2-PRI] = INFB THEN GO TO FOUND; 03869000 + XTA ~ INFB; FLAG(30); 03870000 + GO TO LA; 03871000 + FOUND: 03872000 + IF (T1~INT[PRI+1].INTPARMS)!0 03873000 + AND INFC < 0 03874000 + THEN IF T1 ! INFC.NEXTRA THEN 03875000 + BEGIN XTA ~ INFB ; FLAG(28); END; 03876000 + IF (FID~INTLOC[MFID~INT[PRI+1].INTNUM])=0 THEN 03877000 + BEGIN 03878000 + PDPRT[PDIR,PDIC] ~ 03879000 + 0&1[STYPC] 03880000 + &(FID ~ INTLOC[MFID] ~ NXAVIL ~ NXAVIL + 1)[SGNOC] 03881000 + &1[SEGSZC]; 03882000 + PDINX ~ PDINX + 1; 03883000 + END; 03884000 + T1 ~ PRGDESCBLDR(1,INFA .ADDR,0,FID); 03885000 + IF PRTOG THEN WRITALIST(SEGUS,3,IDNM,FID,B2D(T1),0,0,0,0,0) ; 03886000 + IF INT[PRI+1] < 0 THEN 03887000 + BEGIN 03888000 + T1 ~ PRGDESCBLDR(1,INT[PRI+1].INTPRT,0,FID); 03889000 + INT[PRI+1] ~ ABS(INT[PRI + 1]); 03890000 + END; 03891000 + END 03892000 + ELSE IF PRTOG THEN WRITALIST(SEGUS,3,INFB, 03893000 + INFA.SEGNO,B2D(INFA.ADDR),0,0,0,0,0) ; 03894000 + END; 03895000 + LA: 03896000 + END; 03897000 +COMMENT MUST FOLLOW THE FOR STATEMENT; 03898000 +IF FILEARRAYPRT ! 0 THEN 03899000 +BEGIN % BUILDING OBJECT TIME FILE SEARCH ARRAY 03900000 + J ~ PRGDESCBLDR(1,FILEARRAYPRT,0,NXAVIL ~ NXAVIL + 1); 03901000 + WRITEDATA(THEBIGGEST + 1,NXAVIL,FILES); 03902000 +END; 03903000 + XTA ~ BLANKS; 03904000 + IF NXAVIL > 1023 THEN FLAG(45); 03905000 + IF PRTS > 1023 THEN FLAG(46); 03906000 + IF STRTSEG = 0 THEN FLAG(65); 03907000 + PRI ~ 0; 03908000 + WHILE (IDNM ~ INT[PRI]) ! 0 DO 03909000 + IF INT[PRI+1] } 0 THEN PRI ~ PRI + 2 ELSE 03910000 + BEGIN 03911000 + IF (FID~INTLOC[MFID~INT[PRI+1].INTNUM])=0 THEN 03912000 + BEGIN 03913000 + PDPRT[PDIR,PDIC] ~ 03914000 + 0&1[STYPC] 03915000 + &MFID[DKAC] 03916000 + &(FID ~ INTLOC[MFID] ~ NXAVIL ~ NXAVIL + 1)[SGNOC] 03917000 + &1[SEGSZC]; 03918000 + PDINX ~ PDINX + 1; 03919000 + END; 03920000 + T1 ~ PRGDESCBLDR(1,INT[PRI + 1].INTPRT,0,FID); 03921000 + PRI ~ PRI+2; 03922000 + END; 03923000 + FOR I ~ 1 STEP 1 UNTIL BDX DO 03924000 + BEGIN EMITO(MKS); EMITOPDCLIT(BDPRT[I]) END; 03925000 + EMITO(MKS); 03926000 + EMITOPDCLIT(STRTSEG.[18:15]); 03927000 + T ~ PRGDESCBLDR(1,0,0,NSEG); 03928000 + SEGMENT((ADR+4) DIV 4,NSEG,FALSE,EDOC); 03929000 + IF ERRORCT ! 0 THEN GO TO ENDWRAPUP; 03930000 + FILL SEG0[*] WITH 03931000 + OCT020005, % BLOCK 03932000 + OCT220014, % WRITE 03933000 + OCT230015, % READ 03934000 + OCT240016; % FILE CONTROL 03935000 + COMMENT INTRINSIC FUNCTIONS; 03936000 + FOR I ~ 0 STEP 1 UNTIL 3 DO 03937000 + BEGIN 03938000 + T1 ~ PRGDESCBLDR(1,SEG0[I].[36:12],0, 03939000 + NSEG ~ NXAVIL ~ NXAVIL + 1); 03940000 + PDPRT[PDIR,PDIC] ~ 03941000 + 0&1[STYPC] 03942000 + &(SEG0[I].[30:6])[DKAC] 03943000 + &NXAVIL[SGNOC] 03944000 + &1[SEGSZC]; 03945000 + PDINX ~ PDINX + 1; 03946000 + END; 03947000 + COMMENT GENERATE PRT AND SEGMENT DICTIONARY; 03948000 + PRT[0,41] ~ PDPRT[0,0] & 63[10:42:6]; % USED FOR FAULT OPTN 03949000 + FOR I ~ 1 STEP 1 UNTIL PDINX-1 DO 03950000 + IF (T1~PDPRT[I.PDR,I.PDC]).SEGSZF = 0 THEN 03951000 + BEGIN % PRT ENTRY 03952000 + PRTADR ~T1.PRTAF; 03953000 + SEGMNT ~T1.SGNOF; 03954000 + LNK ~ SEGDICT[SEGMNT.[36:5], SEGMNT.[41:7]].PRTAF; 03955000 + MDESC(T1.RELADF&SEGMNT[FFC] 03956000 + &(REAL(LNK=0))[STOPC] 03957000 + &(IF LNK=0 THEN SEGMNT ELSE LNK)[LINKC] 03958000 + &(T1.DTYPF)[MODEC] 03959000 + &5[1:45:3], 03960000 + PRT[PRTADR.[36:5],PRTADR.[41:7]]); 03961000 + SEGDICT[SEGMNT.[36:5],SEGMNT.[41:7]].PRTLINKF ~ PRTADR; 03962000 + END 03963000 + ELSE 03964000 + BEGIN % SEGMENT DICTIONARY ENTRY 03965000 + SEGMNT ~ T1.SGNOF; 03966000 + SEGDICT[SEGMNT.[36:5],SEGMNT.[41:7]]~ 03967000 + SEGDICT[SEGMNT.[36:5],SEGMNT.[41:7]] 03968000 + &T1[SGLCC] 03969000 + &T1[DKADRC] 03970000 + & T1[4:12:1] 03971000 + &T1[6:6:1] 03972000 + &T1[1:1:2]; 03973000 + TSEGSZ ~ TSEGSZ + T1.SEGSZF; 03974000 + END; 03975000 + COMMENT WRITE OUT FILE PARAMETER BLOCK; 03976000 + FPBSZ ~ ((FPE.[33:15] - FPS) | 8 + FPE.[30:3] + 9) DIV 8; 03977000 + I ~ (FPBSZ + 29) DIV 30; 03978000 + IF DALOC DIV CHUNK < T1 ~ (DALOC +I) DIV CHUNK 03979000 + THEN DALOC ~ CHUNK | T1; 03980000 + SEG0[4] ~ DALOC; 03981000 + SEG0[5] ~ FPBSZ; 03982000 + SEG0[5].FPBVERSF~FPBVERSION; 03983000 + FOR I ~ 0 STEP 30 WHILE I < FPBSZ DO 03984000 + BEGIN 03985000 + MOVE(FPB[I],CODE(0),IF (FPBSZ-I) } 30 03986000 + THEN 30 ELSE (FPBSZ-I)); 03987000 + WRITE(CODE[DALOC]); 03988000 + DALOC ~ DALOC + 1; 03989000 + END; 03990000 + SEG0[2] ~ MOVEANDBLOCK(PRT,PRTS+1); % WRITES OUT PRT 03991000 + % SAVES ADDRESS OF PRT 03992000 + SEG0[3] ~ PRTS + 1; % SIZE OF PRT 03993000 + SEG0[0] ~ MOVEANDBLOCK(SEGDICT,NXAVIL + 1); % WRITE SEG DICT 03994000 + SEG0[1] ~ NXAVIL + 1; % SIZE OF SEGMENT DICTIONARY 03995000 + SEG0[6] ~ -GSEG; % FIRST SEGMENT TO EXECUTE 03996000 + SEG0[7].[33:15] ~ FPBI; % NUMBER OF FILES 03997000 + SEG0[7].[18:15] ~ ESTIMATE ~ IF % CORE ESTIMATE 03998000 + ( I ~ 03999000 + ESTIMATE+60+ %%% OPTION FILE BUFF SIZES + DEFAULT BUFF SIZES.04000000 + PRTS + 512 % PRT AND STACK SIZE 04001000 + +TSEGSZ % TOTAL SIZE OF CODE 04002000 + + 1022 % FOR INTRINSICS 04003000 + +ARYSZ % TOTAL ARRAY SIZE 04004000 + + (MAXFILES | 28) % SIZE OF ALL FIBS 04005000 + +FPBSZ % SIZE OF FILE PARAMETER BLOCK 04006000 + + (IF ESTIMATE = 0 THEN 0 ELSE (ESTIMATE + 1000)) 04007000 + + (NXAVIL + 1) % SIZE OF SEGMENT DICTIONARY 04008000 + ) > 32768 THEN 510 ELSE (I DIV 64); 04009000 + COMMENT IF SEGSW THEN UPDATE LINDICT, SEG0[0] & WRITE IT ; 04010000 + SEG0[7].[2:1] ~ 1; % USED FOR FORTRAN FAULT DEC; 04011000 + IF SEGSW THEN 04012000 + BEGIN 04013000 + FOR I ~ NXAVIL + 1 STEP -1 UNTIL 1 DO 04014000 + IF LINEDICT[I.IR,I.IC] = 0 THEN % INDICATE NO LINE SEGMENT 04015000 + LINEDICT[I.IR,I.IC] ~ -1; % FOR THIS SEGMENT 04016000 + SEG0[0] ~ SEG0[0] & (MOVEANDBLOCK(LINEDICT,NXAVIL+1))[TOBASE]; 04017000 + END; 04018000 + WRITE(CODE[0],30,SEG0[*]); 04019000 + IF ERRORCT = 0 AND SAVETIME } 0 THEN LOCK(CODE); 04020000 + ENDWRAPUP: 04021000 + LOCK(TAPE); %RW/L TAPE FILE OR LOCK DISK %502-04022000 + IF NTAPTOG THEN LOCK(NEWTAPE,*); %RW/L TAPE OR CRUNCH DISK%502-04023000 + END WRAPUP; 04024000 +PROCEDURE INITIALIZATION; 04025000 +BEGIN COMMENT INITIALIZATION; 04026000 +ALPHA STREAM PROCEDURE MKABS(P); 04027000 +BEGIN SI ~ P; MKABS ~ SI END; 04028000 +STREAM PROCEDURE BLANKOUT(CRD, N); VALUE N; 04029000 +BEGIN DI ~ CRD; N(DS ~ LIT " ") END; 04030000 +BLANKOUT(CRD[10], 40); 04031000 +BLANKOUT(LASTSEQ, 8); 04032000 +BLANKOUT(LASTERR, 8); 04033000 +INITIALNCR ~ MKABS(CRD[0])&6[30:45:3]; 04034000 +CHR0 ~ MKABS(ACCUM[0])& 2[30:45:3]; 04035000 +ACR0 ~ CHR0+1; 04036000 +ACR1 ~ (CHR1~MKABS(EXACCUM[0]) & 2[30:45:3]) +1; 04037000 +ACCUMSTOP~MKABS(ACCUM[11]); EXACCUMSTOP~MKABS(EXACCUM[11]) ; 04038000 +BUFL ~ MKABS(BUFF) & 2[30:45:3]; 04039000 +NEXTCARD ~ 1; 04040000 +GLOBALNEXTINFO ~ 4093; 04041000 +PDINX ~ 1; 04042000 +LASTNEXT~1000 ; 04043000 +PRTS ~ 41; % CURRENTLY . . . . . LAST USED PRT 04044000 +READ(CR, 10, CB[*]); 04045000 +LISTOG~TRUE; SINGLETOG~TRUE; CHECKTOG ~ FALSE; %DEFAULT %501- 04046000 +FIRSTCALL ~ TRUE; 04047000 +IF BOOLEAN(ERRORCT.[46:1]) THEN LISTOG ~ FALSE; 04048000 +IF BOOLEAN(ERRORCT.[47:1]) THEN DCINPUT ~ TRUE; 04049000 +ERRORCT ~ 0; 04050000 +IF DCINPUT THEN SEGSW ~ TRUE; 04051000 +IF DCINPUT THEN REMOTETOG ~ TRUE; 04052000 +LIMIT~IF DCINPUT THEN 20 ELSE 100 ; 04053000 +IF SEGSW THEN SEGSWFIXED ~ TRUE; 04054000 +EXTRAINFO[0,0] ~ 0 & EXPCLASS[TOCLASS]; 04055000 +NEXTEXTRA ~ 1; 04056000 +LASTMODE ~ 1; 04057000 +DALOC ~ 1; 04058000 +TYPE ~ -1; 04059000 + MAP[0] ~ MAP[2] ~ MAP[4] ~ MAP[7] ~ -10; 04060000 + MAP[5] ~ 1; MAP[6] ~ 2; 04061000 +FILL XR[*] WITH 0,0,0,0,0,0,0, 04062000 + "INTEGE","R R"," "," "," REAL "," ", 04063000 + "LOGICA","L L","DOUBLE"," ","COMPLE","X X", 04064000 + "------","- -"," "," "," ---- "," ", 04065000 + "------","- -","------"," ","------","- -"; 04066000 +FILL TYPES[*] WITH " ","INTGER"," ","REAL ", 04067000 + "LOGCAL", "DOUBLE", "COMPLX"; 04068000 +FILL KLASS[*] WITH 04069000 + "NULL ", "ARRAY ", "VARBLE", "STFUN ", 04070000 + "NAMLST", "FORMAT", "ERROR ", "FUNCTN", 04071000 + "INTRSC", "EXTRNL", "SUBRTN", "COMBLK", 04072000 + "FILE "; 04073000 +FILL RESERVEDWORDSLP[*] WITH 04074000 + "CALL ","ENTR ","FORM ","GOTO ","IF ","READ ", 04075000 + "REAL ","WRIT ","DATA ","CLOS ","LOCK ","PURG ","CHAI ", 04076000 + "PRIN ","PUNC ", 04077000 + 0,"Y ","AT ",0,0,0,0,"E ",0,"E ",0,"E ",04078000 + "N ","T ","H "; 04079000 +FILL RESERVEDWORDS[*] WITH 04080000 + "ASSI ","BACK ","BLOC ","CALL ","COMM ","COMP ","CONT ", 04081000 + "DATA ","DIME ","DOUB ","END ","ENDF ","ENTR ","EQUI ", 04082000 + "EXTE ","FUNC ","GOTO ","INTE ","LOGI ","NAME ","PAUS ", 04083000 + "PRIN ","PROG ","PUNC ","READ ","REAL ","RETU ","REWI ", 04084000 + "STOP ","SUBR ","WRIT ", 04085000 + "CLOS ","LOCK ","PURG ", 04086000 + 0,0,0, 04087000 + "FIXF ","VARY ","AUXM ","RELE ", 04088000 + "IMPL ", 04089000 + "GN ","SPACE ","KDATA ",0,"ON ","LEX ","INUE ", 04090000 + 0,"NSION ","LEPRECIS",0,"ILE ","Y ","VALENCE ","RNAL " 04091000 + ,"TION ",0,"GER ","CAL ","LIST ","E ","T ",04092000 + "RAM ","H ",0,0,"RN ","ND ",0,"OUTINE ", 04093000 + "E ","E ",0,"E ",0,0,0,"D ","ING ", 04094000 + "EM ","ASE " 04095000 + ,"ICIT " 04096000 + ; 04097000 +FILL RESLENGTHLP[*] WITH 04098000 + 4,5,6,4,2,4,4,5,4,5,4,5,5,5,5; 04099000 +FILL LPGLOBAL[*] WITH 04100000 + 4, 13, 36, 17, 35, 25, 04101000 + 26, 31, 8, 32, 33, 34, 37, 22, 24; 04102000 +FILL RESLENGTH[*] WITH 04103000 + 0, 9, 9, 4, 6, 04104000 + 7, 8, 4, 9, 15, 04105000 + 3, 7, 5, 11, 8, 04106000 + 8, 4, 7, 7, 8, 04107000 + 5, 5, 7, 5, 4, 04108000 + 4, 6, 6, 4, 10, 5, 04109000 + 5, 4, 5, 0, 0, 0, 5, 7, 6, 7 04110000 + ,8 04111000 + ; 04112000 + FILL WOP[*] WITH 04113000 + "LITC"," ", 04114000 + "OPDC","DESC", 04115000 + 10,"DEL ", 11,"NOP ", 12,"XRT ", 16,"ADD ", 17,"AD2 ", 18,"PRL ", 04116000 + 19,"LNG ", 21,"GEQ ", 22,"BBC ", 24,"INX ", 35,"LOR ", 37,"GTR ", 04117000 + 38,"BFC ", 39,"RTN ", 40,"COC ", 48,"SUB ", 49,"SB2 ", 64,"MUL ", 04118000 + 65,"ML2 ", 67,"LND ", 68,"STD ", 69,"NEQ ", 70,"SSN ", 71,"XIT ", 04119000 + 72,"MKS ", 04120000 + 128,"DIV ",129,"DV2 ",130,"COM ",131,"LQV ",132,"SND ",133,"XCH ", 04121000 + 134,"CHS ",167,"RTS ",168,"CDC ",197,"FTC ",260,"LOD ",261,"DUP ", 04122000 + 278,"GBC ",280,"SSF ",294,"GFC ",322,"ZP1 ",384,"IDV ",453,"FTF ", 04123000 + 515,"MDS ",532,"ISD ",533,"LEQ ",534,"BBW ",548,"ISN ",549,"LSS ", 04124000 + 550,"BFW ",581,"EQL ",582,"SSP ",584,"ECM ",709,"CTC ",790,"GBW ", 04125000 + 806,"GFW ",896,"RDV ",965,"CTF ", 04126000 + 1023,1023,1023,1023,1023,1023,1023,1023,1023,1023,1023, 1023; 04127000 +FILL TIPE[*] WITH 10(-1),-19,-21,OCT300000000,-21,-2,-3,-4, 04128000 + 8(OCT300000000),OCT100000000,-5,-13,-4,-6,-7,-19,-11, 04129000 + 5(OCT100000000),-8,3(OCT300000000),-9,-10,-12,-13,-14,04130000 + -15,-100,-16,8(OCT300000000),-17,-6,-18,-19,-20,-21 ; 04131000 +FILL PERIODWORD[*] WITH 04132000 + "FALSE ", "TRUE ", "OR ", "AND ", "NOT ", 04133000 + "LT ", "LE ", "EQ ", "GT ", "GE ", "NE "; 04134000 +ACCUM[0] ~ EXACCUM[0] ~ "; "; 04135000 +INCLUDE ~ "NCLUDE" & "I"[6:42:6]; 04136000 +INSERTDEPTH ~ -1; 04137000 +FILL TEN[*] WITH % POWERS OF TEN TO PRT 22 04138000 + OCT1141000000000000, OCT1131200000000000, OCT1121440000000000,04139000 + OCT1111750000000000, OCT1102342000000000, OCT1073032400000000,04140000 + OCT1063641100000000, OCT1054611320000000, OCT1045753604000000,04141000 + OCT1037346545000000, OCT1011124027620000, OCT0001351035564000,04142000 + OCT0011643245121000, OCT0022214116345200, OCT0032657142036440,04143000 + OCT0043432772446150, OCT0054341571157602, OCT0065432127413542,04144000 + OCT0076740555316473, OCT0111053071060221, OCT0121265707274265,04145000 + OCT0131543271153342, OCT0142074147406233, OCT0152513201307702,04146000 + OCT0163236041571663, OCT0174105452130240, OCT0205126764556310,04147000 + OCT0216354561711772, OCT0231004771627437, OCT0241206170175346,04148000 + OCT0251447626234640, OCT0261761573704010, OCT0272356132665012,04149000 + OCT0303051561442215, OCT0313664115752660, OCT0324641141345435,04150000 + OCT0336011371636744, OCT0347413670206535, OCT0361131664625026,04151000 + OCT0371360241772234, OCT0401654312370703, OCT0412227375067064,04152000 + OCT0422675274304701, OCT0433454553366061, OCT0444367706263475,04153000 + OCT0455465667740415, OCT0467003245730520, OCT0501060411731664,04154000 + OCT0511274514320241, OCT0521553637404312, OCT0532106607305374,04155000 + OCT0542530351166673, OCT0553256443424452, OCT0564132154331565,04156000 + OCT0575160607420123, OCT0606414751324147, OCT0621012014361120,04157000 + OCT0631214417455344, OCT0641457523370635, OCT0651773450267004,04158000 + OCT0662372362344605, OCT0673071057035747, OCT0703707272645341,04159000 + OCT0714671151416631, OCT0726047403722377, OCT0737461304707077,04160000 + OCT0751137556607071, OCT0761367512350710, OCT0771665435043072,04161000 + OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,04162000 + OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,04163000 + OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,04164000 + OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,04165000 + OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,04166000 + OCT0000000000000000, OCT0000000000000000, OCT0004000000000000,04167000 + OCT0001000000000000, OCT0001720000000000, OCT0004304000000000,04168000 + OCT0007365000000000, OCT0005262200000000, OCT0004536640000000,04169000 + OCT0001666410000000, OCT0000244112000000, OCT0000315134400000,04170000 + OCT0000400363500000, OCT0000450046042000, OCT0006562057452400,04171000 + OCT0004316473365100, OCT0005402212262320, OCT0006702654737004,04172000 + OCT0004463430126605, OCT0007600336154346, OCT0001540425607437,04173000 + OCT0004070533151347, OCT0005106662003641, OCT0005033043640461,04174000 + OCT0002241654610575, OCT0002712227752734, OCT0001474675745524,04175000 + OCT0002014055337051, OCT0004417070626663, OCT0007522706774440,04176000 + OCT0003447470573550, OCT0006361406732502, OCT0005005571052122,04177000 + OCT0006207127264547, OCT0001650755141700, OCT0006223150372260,04178000 + OCT0007670002470733, OCT0007646003207120, OCT0005617404050743,04179000 + OCT0001163305063137, OCT0007420166277771, OCT0001732422375777,04180000 + OCT0002321127075377, OCT0003005354714677, OCT0005606650100057,04181000 + OCT0007150422120072, OCT0003002526544103, OCT0001603254275130,04182000 + OCT0004144127354356, OCT0007175155247451, OCT0007034410521363,04183000 + OCT0007664351264566, OCT0003641443541723, OCT0004611754472310;04184000 +FILL INLINEINT[*] WITH % FILLS MUST BE IN ASCENDING ORDER FOR 04185000 + % BINARY SEARCH IN FUNCTION AND DOITINLINE. 04186000 + % INLINEINT[I].[1:1] = 1 ONCE CODE FOR INTRINSIC 04187000 + % HAS BEEN EMITTED INLINE.04188000 + % INLINEINT[I].[2:10]=INDEX INTO 2-ND WORD OF THE04189000 + % CORR ENTRY IN INT. 04190000 + % INLINEINT[I].[12:36]=NAME OF INTRINSIC. 04191000 +%********FIRST FILL MUST BE NUMBER OF INTRINSICS ****************** 04192000 +34, 04193000 +"00ABS ", 04194000 +"00AIMAG ", 04195000 +"00AINT ", 04196000 +"00AMAX0 ", 04197000 +"00AMAX1 ", 04198000 +"00AMIN0 ", 04199000 +"00AMIN1 ", 04200000 +"00AMOD ", 04201000 +"00AND ", 04202000 +"00CMPLX ", 04203000 +"00COMPL ", 04204000 +"00CONJG ", 04205000 +"00DABS ", 04206000 +"00DBLE ", 04207000 +"00DIM ", 04208000 +"00DSIGN ", 04209000 +"00EQUIV ", 04210000 +"00FLOAT ", 04211000 +"00IABS ", 04212000 +"00IDIM ", 04213000 +"00IDINT ", 04214000 +"00IFIX ", 04215000 +"00INT ", 04216000 +"00ISIGN ", 04217000 +"00MAX0 ", 04218000 +"00MAX1 ", 04219000 +"00MIN0 ", 04220000 +"00MIN1 ", 04221000 +"00MOD ", 04222000 +"00OR ", 04223000 +"00REAL ", 04224000 +"00SIGN ", 04225000 +"00SNGL ", 04226000 +"00TIME ", 04227000 + 0 ; 04228000 + FILL INT [*] WITH 04229000 +COMMENT THESE NAMES (1-ST WORD OF EACH TWO-WORD ENTRY) MUST BE IN 04230000 + ASCENDING ORDER FOR BINARY LOOKUPS. 04231000 + THE SECOND WORD HAS THE FOLLOWING FORMAT: 04232000 + .[1:1] = 0 IF THE INTRINSIC DOES NOT HAVE A PERMANENT PRT 04233000 + LOCATION, OTHERWISE = 1. MAY BE RESET BY 04234000 + WRAPUP. SEE .[18:6] BELOW. 04235000 + .[2:1] = .INTSEEN = 1 IFF INTRINSICS FUNCTION HAS BEEN SEEN. 04236000 + .[6:3] = .INTCLASS = CLASS OF THE INTRINSIC. 04237000 + .[9:3] = .INTPARMCLASS = CLASS OF PARAMETERS. 04238000 + .[12:6] = .INTINLINE = INDEX FOR DOITINLINE IF !0, OTHERWISE 04239000 + DO IT VIA INTRINSIC CALL. 04240000 + .[24:6] = .INTPRT = FIXED PRT LOCATION. SEE .[1:1] ABOVE. 04241000 + .[30:6] = .INTPARMS = NUMBER OF PARAMETERS REQUIRED BY THE INT.04242000 + .[36:12] = .INTNUM = INTRINSICS NUMBER. 04243000 + THE FIELDS .[3:3] AND .[18:6] ARE SO FAR UNUSED. 04244000 +; 04245000 +% 04246000 +%***********************************************************************04247000 +%********* IF YOU ADD AN INTRINSIC, BE SURE TO CHANGE NUMINTM1 *******04248000 +%********* AT SEQUENCE NUMBER 00155211.......THANK YOU. *******04249000 +%***********************************************************************04250000 +% 04251000 +"ABS ", OCT0033010000010007, 04252000 +"AIMAG ", OCT0036020000010074, 04253000 +"AINT ", OCT0033030000010054, 04254000 +"ALGAMA", OCT0033000000010127, 04255000 +"ALOG10", OCT0033000000010103, 04256000 +"ALOG ", OCT2033000035010017, 04257000 +"AMAX0 ", OCT0031250000000031, 04258000 +"AMAX1 ", OCT0033250000000031, 04259000 +"AMIN0 ", OCT0031250000000032, 04260000 +"AMIN1 ", OCT0033250000000032, 04261000 +"AMOD ", OCT0033040000020063, 04262000 +"AND ", OCT0033050000020130, 04263000 +"ARCOS ", OCT0033000000010117, 04264000 +"ARSIN ", OCT2033000032010116, 04265000 +"ATAN2 ", OCT2033000044020114, 04266000 +"ATAN ", OCT2033000037010016, 04267000 +"CABS ", OCT2036000045010053, 04268000 +"CCOS ", OCT0066000000010110, 04269000 +"CEXP ", OCT0066000000010100, 04270000 +"CLOG ", OCT0066000000010102, 04271000 +"CMPLX ", OCT0063060000020075, 04272000 +"COMPL ", OCT0033070000010132, 04273000 +"CONCAT", OCT0033000000050140, 04274000 +"CONJG ", OCT0066110000010076, 04275000 +"COSH ", OCT0033000000010121, 04276000 +"COS ", OCT0033000000010015, 04277000 +"COTAN ", OCT0033000000010112, 04278000 +"CSIN ", OCT0066000000010106, 04279000 +"CSQRT ", OCT0066000000010124, 04280000 +"DABS ", OCT0055010000010052, 04281000 +"DATAN2", OCT0055000000020115, 04282000 +"DATAN ", OCT2055000041010113, 04283000 +"DBLE ", OCT0053120000010062, 04284000 +"DCOS ", OCT0055000000010107, 04285000 +"DEXP ", OCT2055000047010077, 04286000 +"DIM ", OCT0033100000020072, 04287000 +"DLOG10", OCT0055000000010104, 04288000 +"DLOG ", OCT2055000042010101, 04289000 +"DMAX1 ", OCT0055000000000066, 04290000 +"DMIN1 ", OCT0055000000000067, 04291000 +"DMOD ", OCT2055000046020065, 04292000 +"DSIGN ", OCT0055130000020071, 04293000 +"DSIN ", OCT2055000043010105, 04294000 +"DSQRT ", OCT2055000050010123, 04295000 +"EQUIV ", OCT0033140000020133, 04296000 +"ERF ", OCT0033000000010125, 04297000 +"EXP ", OCT2033000033010020, 04298000 +"FLOAT ", OCT0031150000010060, 04299000 +"GAMMA ", OCT2033000040010126, 04300000 +"IABS ", OCT0011010000010007, 04301000 +"IDIM ", OCT0011100000020072, 04302000 +"IDINT ", OCT0015240000010057, 04303000 +"IFIX ", OCT0013030000010054, 04304000 +"INT ", OCT0013030000010054, 04305000 +"ISIGN ", OCT0011160000020070, 04306000 +".ERR. ", OCT2000000030000134, 04307000 +".FBINB", OCT0000000000000160, 04308000 +".FINAM", OCT0000000000000154, 04309000 +".FONAM", OCT0000000000000155, 04310000 +".FREFR", OCT0000000000000146, 04311000 +".FREWR", OCT0000000000000153, 04312000 +".FTINT", OCT0000000000000050, 04313000 +".FTNIN", OCT0000000000000156, 04314000 +".FTNOU", OCT0000000000000157, 04315000 +".FTOUT", OCT0000000000000051, 04316000 +".LABEL", OCT0000000000000021, 04317000 +".MATH ", OCT0000000000000055, 04318000 +".MEMHR", OCT0000000000000164, 04319000 +".XTOI ", OCT0000000000000056, 04320000 +"MAX0 ", OCT0011250000000135, 04321000 +"MAX1 ", OCT0013250000000135, 04322000 +"MIN0 ", OCT0011250000000136, 04323000 +"MIN1 ", OCT0013250000000136, 04324000 +"MOD ", OCT0011170000020137, 04325000 +"OR ", OCT0033200000020131, 04326000 +"REAL ", OCT0036210000010073, 04327000 +"SIGN ", OCT0033160000020070, 04328000 +"SINH ", OCT0033000000010120, 04329000 +"SIN ", OCT2033000034010014, 04330000 +"SNGL ", OCT0035230000010061, 04331000 +"SQRT ", OCT2033000031010013, 04332000 +"TANH ", OCT0033000000010122, 04333000 +"TAN ", OCT2033000036010111, 04334000 +"TIME ", OCT0031220000010064, 04335000 + 0; 04336000 +BLANKS~INLINEINT[MAX~0] ; 04337000 +FOR SCN~1 STEP 1 UNTIL BLANKS DO 04338000 + BEGIN 04339000 + EQVID~INLINEINT[SCN]; WHILE INT[MAX]!EQVID DO MAX~MAX+2 ; 04340000 + INLINEINT[SCN].INTX~MAX+1 ; 04341000 + END ; 04342000 +INTID.SUBCLASS ~ INTYPE; 04343000 +REALID.SUBCLASS ~ REALTYPE; 04344000 +EQVID ~ ".EQ000"; 04345000 +LISTID ~ ".LI000"; 04346000 +BLANKS ~ " "; 04347000 +ENDSEGTOG ~ TRUE; 04348000 +SCN ~ 7; 04349000 +MAX ~ REAL(NOT FALSE).[9:39]; 04350000 +SUPERMAXCOM~128|(MAXCOM+1) ; 04351000 +SEGPTOG ~ FALSE; %INHIBIT PAGE SKIP AFTER SUBROUTINES %501- 04352000 +END INITIALIZATION; 04353000 + 04354000 +ALPHA PROCEDURE NEED(T, C); VALUE T, C; ALPHA T, C; 04355000 +BEGIN INTEGER N; REAL ELBAT; 04356000 + REAL X; 04357000 + LABEL XIT, CHECK; 04358000 + ALPHA INFA, INFB, INFC; 04359000 +COMMENT NEED RETURNS THE ELBAT WORD FOR THE IDENTIFIER T. 04360000 +IF THIS IS THE FIRST OCCURRENCE OF T THEN AN INFO WORD IS BUILT AND 04361000 +GIVEN THEN CLASS C; 04362000 + ELBAT.CLASS ~ C; 04363000 + XTA ~ T; 04364000 + IF C { LABELID THEN 04365000 + BEGIN 04366000 + IF N ~ SEARCH(T) = 0 THEN N ~ ENTER(ELBAT, T) ELSE 04367000 + IF ELBAT ~ GET(N).CLASS = UNKNOWN 04368000 + THEN PUT(N,GET(N)&C[TOCLASS]) 04369000 + ELSE IF ELBAT ! C THEN FLOG(21); 04370000 + GO TO XIT; 04371000 + END; 04372000 + IF N ~ SEARCH(T) = 0 THEN 04373000 + BEGIN 04374000 + IF N ~ GLOBALSEARCH(T) ! 0 THEN GO TO CHECK; 04375000 + N ~ GLOBALENTER(ELBAT, T); 04376000 + GO TO XIT; 04377000 + END; 04378000 + GETALL(N,INFA,INFB,INFC); 04379000 + IF INFA.CLASS = DUMMY THEN BEGIN N ~ INFC.BASE; GO TO CHECK END; 04380000 + IF BOOLEAN(INFA. FORMAL) THEN GO TO CHECK; 04381000 + IF INFA.CLASS ! UNKNOWN THEN 04382000 + BEGIN 04383000 + IF N ~ GLOBALSEARCH(T) ! 0 THEN GO TO CHECK; 04384000 + ELBAT.SUBCLASS ~ INFA.SUBCLASS; 04385000 + N ~ GLOBALENTER(ELBAT, T); 04386000 + GO TO XIT; 04387000 + END; 04388000 + PUT(N, INFA & DUMMY[TOCLASS]); 04389000 + ELBAT.SUBCLASS ~ INFA .SUBCLASS; 04390000 + IF X ~ GLOBALSEARCH(T) = 0 THEN X ~ GLOBALENTER(ELBAT, T); 04391000 + PUT(N+2, INFC & X[TOBASE]); N ~ X; 04392000 + CHECK: 04393000 + INFA ~ GET(N); 04394000 + IF ELBAT ~ INFA .CLASS = UNKNOWN THEN 04395000 + BEGIN INFO[N.IR,N.IC].CLASS ~ C; GO TO XIT END; 04396000 + IF ELBAT ! C THEN 04397000 + IF ELBAT = EXTID AND 04398000 + (C = SUBRID OR C = FUNID) THEN 04399000 + INFO[N.IR,N.IC].CLASS ~ C 04400000 + ELSE IF (ELBAT=SUBRID OR ELBAT= FUNID) AND C = EXTID THEN 04401000 + ELSE FLOG(21); 04402000 + XIT: NEED ~ GETSPACE(N); 04403000 + XTA ~ NAME; % RESTORE XTA FOR DIAGNOSTIC PURPOSES 04404000 +END NEED; 04405000 +INTEGER PROCEDURE EXPR(B); VALUE B; BOOLEAN B; FORWARD; 03620000 +PROCEDURE SPLIT(A); VALUE A; REAL A; 03621000 +BEGIN 03622000 + EMITPAIR(JUNK, ISN); 03623000 + EMITD(40, DIA); 03624000 + EMITD(18, ISO); 03625000 + EMITDESCLIT(A); 03626000 + EMITO(LOD); 03627000 + EMITOPDCLIT(JUNK); 03628000 + EMITPAIR(255,CHS); 03629000 + EMITO(LND); 03630000 +END SPLIT; 03631000 +BOOLEAN PROCEDURE SUBSCRIPTS(LINK,FROM); VALUE LINK,FROM; 03632000 +INTEGER LINK, FROM; 03633000 +BEGIN INTEGER I, NSUBS, BDLINK; 03634000 + LABEL CONSTRUCT, XIT; 03635000 +REAL SUM, PROD, BOUND; 03636000 +REAL INFA,INFB,INFC; 03637000 +REAL SAVENSEG,SAVEADR ; 03637100 +INTEGER INDX; 03637200 +REAL INFD; 03637300 +BOOLEAN TOG, VARF; 03638000 +REAL SAVIT; 03639000 +DEFINE SS = LSTT#; 03640000 + 03641000 + 03642000 +IF DEBUGTOG THEN FLAGROUTINE(" SUBSC","RIPTS ",TRUE ) ; 03643000 + SAVIT ~ IT; 03644000 + LINK ~ GETSPACE(LINK); 03645000 +GETALL(LINK,INFA,INFB,INFC); 03646000 + IF INFA.CLASS ! ARRAYID THEN 03647000 + BEGIN XTA ~ INFB; FLOG(35); GO TO XIT END; 03648000 + NSUBS ~ INFC.NEXTRA; 03649000 + IF FROM = 4 THEN 03649100 + BEGIN IF NSUBS GTR SAVESUBS THEN SAVESUBS ~ NSUBS; 03649200 + IF NSUBS GTR NAMLIST[0] THEN NAMLIST[0] ~ NSUBS; 03649230 + NAMLIST[NAMEIND].[1:8] ~ NSUBS; 03649250 + INFD ~ GET(NEED(".SUBAR",BLOCKID)).ADDR; 03649300 + END; 03649400 + BDLINK ~ INFC.ADINFO-NSUBS+1; 03650000 + VARF ~ INFC < 0; 03651000 + FOR I ~ 1 STEP 1 UNTIL NSUBS DO 03652000 + BEGIN 03653000 + IT~IT+1; SAVENSEG~NSEG; SAVEADR~ADR ; 03654000 + IF EXPR(TRUE) > REALTYPE THEN FLAG(98); 03655000 + IF ADR=SAVEADR THEN FLAG(36) ; 03655500 + IF VARF THEN 03656000 + IF EXPRESULT=NUMCLASS AND NSEG=SAVENSEG THEN 03657000 + BEGIN 03658000 + ADR~SAVEADR ; 03659000 + EMITNUM(EXPVALUE-1); 03660000 + END ELSE EMITPAIR(1, SUB) 03661000 + ELSE 03662000 + IF EXPRESULT=NUMCLASS AND NSEG = SAVENSEG AND FROM NEQ 4 THEN 03663000 + BEGIN 03664000 + ADR~SAVEADR; IF SS[IT]~EXPVALUE{0 THEN FLAG(154) ; 03664100 + END 03664200 + ELSE SS[IT] ~ @9; 03665000 + IF FROM = 4 THEN 03665010 + BEGIN IF VARF THEN BEGIN EMITO(DUP); EMITPAIR(1,ADD); END; 03665100 + EMITL(INDX); INDX ~ INDX+1; 03665200 + EMITDESCLIT(INFD); 03665300 + EMITO(IF VARF THEN STD ELSE STN); 03665400 + END; 03665500 + IF I < NSUBS THEN 03666000 + BEGIN 03667000 + IF GLOBALNEXT ! COMMA THEN 03668000 + BEGIN XTA ~ INFB; FLOG(23) END; 03669000 + SCAN; 03670000 + END; 03671000 + END; 03672000 + IF GLOBALNEXT ! RPAREN THEN BEGIN XTA ~ INFB; FLOG(24); END 03673000 + ELSE IF FROM < 2 THEN 03673100 + BEGIN SCAN; IF PREC > 0 THEN FROM ~ 1; END; 03673200 + SUM ~ 0; 03674000 + TOG ~ VARF; 03675000 + IF VARF THEN 03676000 + FOR I ~ NSUBS-1 STEP -1 UNTIL 1 DO 03677000 + BEGIN 03678000 + IF BOUND ~ EXTRAINFO[(BDLINK~BDLINK+1).IR,BDLINK.IC] < 0 THEN 03679000 + EMITOPDCLIT(BOUND) ELSE EMITNUM(BOUND); 03680000 + EMITO(MUL); 03681000 + EMITO(ADD); 03682000 + END 03683000 + ELSE 03684000 + FOR I ~ NSUBS STEP -1 UNTIL 1 DO 03685000 + BEGIN 03686000 + IF I = 1 THEN BOUND ~ 1 ELSE 03687000 + BOUND ~ EXTRAINFO[(BDLINK~BDLINK+1).IR,BDLINK.IC]; 03688000 + IF T ~ SS[SAVIT+I] < @9 THEN 03689000 + BEGIN 03690000 + SUM ~ (SUM+T-1)|BOUND; 03691000 + IF TOG THEN PROD ~ PROD|BOUND; 03692000 + END 03693000 + ELSE 03694000 + BEGIN 03695000 + IF TOG THEN BEGIN EMITNUM(PROD); EMITO(MUL); EMITO(ADD) END 03696000 + ELSE TOG ~ TRUE; 03697000 + PROD ~ BOUND; 03698000 + SUM ~ (SUM-1)|BOUND; 03699000 + END; 03700000 + END; 03701000 + IF VARF THEN T ~ @9; 03702000 + IF INFA.SUBCLASS } DOUBTYPE THEN 03703000 + BEGIN 03704000 + IF TOG THEN 03705000 + BEGIN 03706000 + IF T < @9 THEN EMITNUM(2|PROD) ELSE EMITL(2); 03707000 + EMITO(MUL); 03708000 + END; 03709000 + SUM ~ SUM|2; 03710000 + END ELSE 03711000 + IF T < @9 AND TOG THEN BEGIN EMITNUM(PROD); EMITO(MUL) END; 03712000 + IF BOOLEAN(INFA.CE) THEN 03713000 + SUM ~ SUM + INFC.BASE ELSE 03714000 + IF BOOLEAN(INFA.FORMAL) THEN 03715000 + BEGIN EMITOPDCLIT(INFA.ADDR-1); 03716000 + IF TOG THEN EMITO(ADD) ELSE TOG ~ TRUE; 03717000 + END; 03718000 + IF BOOLEAN(INFA.TWOD) AND FROM > 0 THEN 03719000 + BEGIN 03720000 + IF SUM = 0 THEN 03721000 + IF TOG THEN ELSE 03722000 + BEGIN 03723000 + EMITL(0); 03724000 + EMITDESCLIT(INFA.ADDR); 03725000 + EMITO(LOD); 03726000 + EMITL(0); 03727000 + GO TO CONSTRUCT; 03728000 + END 03729000 + ELSE 03730000 + IF TOG THEN 03731000 + BEGIN 03732000 + EMITNUM(ABS(SUM)); 03733000 + IF SUM < 0 THEN EMITO(SUB) ELSE EMITO(ADD); 03734000 + END ELSE 03735000 + BEGIN 03736000 + EMITL(SUM.[33:7]); 03737000 + EMITDESCLIT(INFA.ADDR); 03738000 + EMITO(LOD); 03739000 + EMITL(SUM.[40:8]); 03740000 + GO TO CONSTRUCT; 03741000 + END; 03742000 + SPLIT(INFA.ADDR); 03743000 + CONSTRUCT: 03744000 + IF BOOLEAN(FROM) THEN 03745000 + BEGIN 03746000 + IF INFA.SUBCLASS } DOUBTYPE THEN 03747000 + BEGIN 03748000 + EMITO(CDC); 03749000 + EMITO(DUP); 03750000 + EMITPAIR(1, XCH); 03751000 + EMITO(INX); 03752000 + EMITO(LOD); 03753000 + EMITO(XCH); 03754000 + EMITO(LOD); 03755000 + END ELSE EMITO(COC); 03756000 + END ELSE EMITO(CDC); 03757000 + END ELSE 03758000 + BEGIN 03759000 + IF SUM = 0 THEN IF NOT TOG THEN EMITL(0) ELSE 03760000 + ELSE 03761000 + BEGIN 03762000 + IF TOG THEN 03763000 + BEGIN 03764000 + EMITNUM(ABS(SUM)); 03765000 + IF SUM < 0 THEN EMITO(SUB) ELSE EMITO(ADD); 03766000 + END 03767000 + ELSE EMITNUM(SUM); 03768000 + END; 03769000 + IF FROM > 0 THEN 03770000 + IF BOOLEAN (FROM) THEN 03771000 + IF INFA.SUBCLASS } DOUBTYPE THEN 03772000 + BEGIN 03773000 + EMITDESCLIT(INFA.ADDR); 03774000 + EMITO(DUP); 03775000 + EMITPAIR(1,XCH); 03776000 + EMITO(INX); 03777000 + EMITO(LOD); 03778000 + EMITO(XCH); 03779000 + EMITO(LOD); 03780000 + END ELSE EMITV(LINK) ELSE 03781000 + BEGIN DESCREQ ~ TRUE; EMITN(LINK); DESCREQ ~ FALSE END; 03782000 + END; 03783000 + XIT: 03784000 + IT ~ SAVIT; 03785000 + SUBSCRIPTS ~ BOOLEAN(FROM); 03785100 +IF DEBUGTOG THEN FLAGROUTINE(" SUBSC","RIPTS ",FALSE) ; 03786000 +END SUBSCRIPTS; 03787000 +BOOLEAN PROCEDURE BOUNDS(LINK); VALUE LINK; REAL LINK; 03788000 +BEGIN 03789000 + COMMENT CALLED TO PROCESS ARRAY BOUNDS; 03790000 + BOOLEAN VARF, SINGLETOG; %109-03791000 + DEFINE FNEW = LINK#; 03792000 + REAL T, NSUBS, INFA, INFB, INFC, FIRSTSS; 03793000 + LABEL LOOP; 03794000 +IF DEBUGTOG THEN FLAGROUTINE(" BOU","NDS ",TRUE ); 03795000 + GETALL(FNEW, INFA, INFB, INFC); 03796000 + FIRSTSS ~ NEXTSS; 03797000 + IF LINK < 0 THEN BEGIN SINGLETOG ~ TRUE; LINK ~ ABS(LINK) END; %109-03798000 + LOOP: 03799000 + IF NEXT = ID THEN 03800000 + BEGIN 03801000 + T ~ GET(FNEXT ~ GETSPACE(FNEXT)); 03802000 + IF T.CLASS ! VARID OR NOT BOOLEAN(T.FORMAL) THEN FLAG(92) ELSE 03803000 + IF T.SUBCLASS > REALTYPE THEN FLAG(93); 03804000 + T ~ -T.ADDR; 03805000 + VARF ~ TRUE; 03806000 + END ELSE 03807000 + IF NEXT = NUM THEN 03808000 + BEGIN 03809000 + IF NUMTYPE!INTYPE THEN FLAG(113); 03810000 + IF T~FNEXT=0 THEN FLAG(122) ; 03811000 + IF NOT VARF THEN IF NSUBS = 0 THEN LENGTH ~ FNEXT ELSE 03812000 + LENGTH ~ LENGTH|FNEXT; 03813000 + END ELSE FLOG(122); 03814000 + EXTRAINFO[NEXTSS.IR,NEXTSS.IC] ~ T; 03815000 + NEXTSS ~ NEXTSS-1; 03816000 + NSUBS ~ NSUBS+1; 03817000 + SCAN; 03818000 + IF NEXT = COMMA THEN BEGIN SCAN; GO TO LOOP END; 03819000 + IF NEXT ! RPAREN THEN FLOG(94); 03820000 + XTA ~ INFB; 03821000 + IF INFA.CLASS = ARRAYID THEN FLAG(95); 03822000 + INFA.CLASS ~ ARRAYID; 03823000 + IF VARF THEN 03827000 + BEGIN 03828000 + IF NOT BOOLEAN(INFA.FORMAL) THEN FLAG(96); 03829000 + IF NSUBS > 1 OR INFA .SUBCLASS } DOUBTYPE THEN 03830000 + BEGIN BUMPLOCALS;LENGTH~LOCALS + 1536;BOUNDS~TRUE END ELSE 03831000 + LENGTH ~-EXTRAINFO[FIRSTSS.IR,FIRSTSS.IC]; 03832000 + END ELSE 03833000 + IF NOT SINGLETOG AND INFA.SUBCLASS > LOGTYPE THEN %109-03834000 + BEGIN LENGTH ~ 2 | LENGTH; BOUNDS ~ TRUE END; %109-03834500 + IF LENGTH > 32767 THEN FLAG(99); 03835000 + INFC ~ LENGTH & NSUBS[TONEXTRA] & FIRSTSS[TOADINFO]; 03836000 + IF VARF THEN INFC ~ -INFC; 03837500 + PUT(FNEW, INFA); PUT(FNEW+2, INFC); 03838000 + SCAN; 03839000 +IF DEBUGTOG THEN FLAGROUTINE(" BOU","NDS ",FALSE) ; 03840000 +END BOUNDS; 03841000 +PROCEDURE PARAMETERS(LINK); VALUE LINK; REAL LINK; 03842000 +BEGIN 03843000 + 03844000 + 03845000 + LABEL LOOP; 03846000 + REAL NPARMS, EX, INFC, PTYPE; 03847000 + ALPHA EXPNAME; 03848000 + BOOLEAN CHECK, INTFID; 03849000 + BOOLEAN NOTZEROP; 03850000 + REAL SAVIT; 03851000 + DEFINE PARMTYPE = LSTT#; 03852000 + SAVIT ~ IT ~ IT+1; 03853000 +IF DEBUGTOG THEN FLAGROUTINE(" PARAM","ETERS ",TRUE ) ; 03854000 + INFC ~ GET(LINK+2); 03855000 + IF CHECK ~ BOOLEAN(INFC.[1:1]) THEN 03856000 + BEGIN 03857000 + EX ~ INFC.ADINFO; 03858000 + NOTZEROP ~ INFC.NEXTRA ! 0; 03859000 + INTFID ~ INFC.[36:12] = 1; 03859500 + END; 03860000 + LOOP: 03861000 + BEGIN SCAN; 03862000 + EXPNAME ~ NAME; 03863000 + IF GLOBALNEXT = 0 AND NAME = "$ " THEN 03864000 + BEGIN EXPRESULT ~ LABELID; SCAN; 03866000 + IF GLOBALNEXT ! NUM THEN FLAG(44); 03867000 + EMITLABELDESC(NAME); 03868000 + PTYPE ~ 0; 03869000 + SCAN; 03870000 + END 03871000 + ELSE PTYPE ~ EXPR(CHECK AND EXTRAINFO[EX.IR,EX.IC].CLASS 03872000 + = EXPCLASS AND INTFID); 03873000 + IF EXPRESULT = NUMCLASS THEN 03874000 + IF PTYPE = STRINGTYPE THEN 03875000 + BEGIN 03876000 + ADR ~ ADR - 1; 03876500 + PTYPE ~ INTYPE; 03877000 + EXPRESULT ~ SUBSVAR; 03878000 + IF STRINGSIZE = 1 AND 03879000 + (T ~ EXTRAINFO[EX.IR,EX.IC].CLASS = VARID OR 03880000 + T = EXPCLASS) THEN 03881000 + BEGIN 03882000 + EXPRESULT ~ EXPCLASS; 03883000 + EMITNUM(STRINGARRAY[0]); 03884000 + END ELSE 03885000 + BEGIN 03886000 + EXPRESULT~ARRAYID; 03887000 + EMITPAIR(PRGDESCBLDR(1,0,0,NXAVIL~NXAVIL+1), LOD); 03888000 + EMITL(0); 03889000 + WRITEDATA(STRINGSIZE, NXAVIL, STRINGARRAY); 03890000 + END; 03891000 + END ELSE EXPRESULT ~ EXPCLASS; 03892000 + PARMTYPE[IT] ~ 0 & EXPRESULT[TOCLASS] & PTYPE[TOSUBCL]; 03893000 + XTA ~ EXPNAME; 03894000 + IF TSSEDITOG THEN IF (EXPRESULT=FUNID OR EXPRESULT=SUBRID OR 03894050 + EXPRESULT=EXTID) AND NOT DCINPUT THEN TSSED(XTA,2); 03894060 + IF DCINPUT THEN IF EXPRESULT=FUNID OR EXPRESULT=SUBRID 03894100 + OR EXPRESULT=EXTID THEN FLAG(151) ; 03894200 + IF CHECK THEN 03895000 + BEGIN 03896000 + IF T ~ EXTRAINFO[EX.IR,EX.IC].CLASS ! EXPRESULT THEN 03897000 + CASE T OF 03898000 + BEGIN 03899000 + EXTRAINFO[EX.IR,EX.IC] ~ 0 & EXPRESULT[TOCLASS] 03900000 + & PTYPE[TOSUBCL]; 03901000 + IF EXPRESULT ! SUBSVAR THEN FLAG(66); 03902000 + IF EXPRESULT = SUBSVAR THEN 03903000 + IF NOT INTFID THEN 03903100 + BEGIN EMITO(CDC); 03903150 + IF PTYPE } DOUBTYPE THEN EMITL(0); 03903200 + END ELSE 03903400 + ELSE 03903500 + IF EXPRESULT = EXPCLASS THEN 03912000 + BEGIN IF PTYPE } DOUBTYPE THEN EMITO(XCH); 03913000 + EXTRAINFO[EX.IR,EX.IC].CLASS ~ EXPCLASS 03914000 + END ELSE FLAG(67); 03915000 + ; ; ; 03916000 + FLAG(68); 03917000 + IF EXPRESULT = EXTID THEN 03918000 + PUT(EXPLINK,GET(EXPLINK)&FUNID[TOCLASS]) ELSE 03919000 + FLAG(69); 03920000 + ; 03921000 + IF EXPRESULT = FUNID OR EXPRESULT = SUBRID THEN 03922000 + EXTRAINFO[EX.IR,EX.IC] ~ EXPRESULT ELSE FLAG(70); 03923000 + IF EXPRESULT = EXTID THEN 03924000 + PUT(EXPLINK,GET(EXPLINK)&SUBRID[TOCLASS]) ELSE 03925000 + FLAG(71); 03926000 + ; ; 03927000 + IF EXPRESULT = ARRAYID THEN EXTRAINFO[EX.IR,EX.IC].CLASS 03928000 + ~ ARRAYID ELSE 03929000 + IF EXPRESULT = VARID THEN 03930000 + BEGIN 03931000 + EXTRAINFO[EX.IR,EX.IC].CLASS ~ SBVEXP; 03932000 + EMITL(0) 03933000 + END ELSE 03934000 + IF EXPRESULT = EXPCLASS THEN 03935000 + BEGIN 03936000 + EXTRAINFO[EX.IR,EX.IC].CLASS ~ SBVEXP; 03937000 + IF PTYPE } DOUBTYPE THEN EMITO(XCH) ELSE EMITL(0); 03938000 + END ELSE FLAG(72); 03939000 + IF EXPRESULT = SUBSVAR THEN 03940000 + IF NOT INTFID THEN 03941000 + BEGIN EMITO(CDC); 03942000 + IF PTYPE } DOUBTYPE THEN EMITL(0) 03943000 + END 03944000 + ELSE 03945000 + ELSE IF EXPRESULT = VARID THEN 03946000 + IF NOT INTFID THEN 03947000 + IF PTYPE } DOUBTYPE THEN EMITL(0) ELSE ELSE 03948000 + ELSE FLAG(67); 03949000 + IF EXPRESULT = VARID THEN 03950000 + EMITL(0) ELSE 03951000 + IF EXPRESULT = EXPCLASS THEN 03952000 + IF PTYPE } DOUBTYPE THEN EMITO(XCH) ELSE EMITL(0) 03953000 + ELSE IF EXPRESULT ! SUBSVAR THEN FLAG(67); 03954000 + END OF CASE STATEMENT 03955000 + ELSE IF PTYPE } DOUBTYPE THEN 03956000 + IF EXPRESULT = VARID THEN EMITL(0) 03957000 + ELSE IF EXPRESULT = EXPCLASS AND NOT INTFID 03958000 + THEN EMITO(XCH); 03959000 + IF T ~ EXTRAINFO[EX.IR,EX.IC].SUBCLASS = 0 OR 03960000 + (T = INTYPE AND PTYPE = REALTYPE AND 03961000 + GET(LINK).SEGNO = 0) THEN 03962000 + EXTRAINFO[EX.IR,EX.IC].SUBCLASS ~ PTYPE ELSE 03963000 + IF NOT(T = PTYPE OR T = REALTYPE AND PTYPE = INTYPE ) THEN 03964000 + FLAG(88); 03965000 + END OF CHECK 03966000 + ELSE IF PTYPE } DOUBTYPE THEN 03967000 + IF EXPRESULT = VARID THEN EMITL(0) 03968000 + ELSE IF EXPRESULT = EXPCLASS THEN EMITO(XCH); 03969000 + IF NOTZEROP THEN EX ~ EX+1; 03970000 + IT ~ IT+1; 03971000 + END; 03972000 + IF GLOBALNEXT = COMMA THEN GO TO LOOP; 03973000 + NPARMS ~ IT - SAVIT; 03974000 + IF GLOBALNEXT ! RPAREN THEN FLOG(108); 03975000 + IF NOT CHECK THEN 03976000 + BEGIN 03977000 + INFC ~ GET(LINK+2); 03978000 + INFC ~ -(INFC & NPARMS[TONEXTRA] 03979000 + & NEXTEXTRA[TOADINFO]); 03980000 + PUT(LINK+2,INFC); 03981000 + FOR I ~ SAVIT STEP 1 UNTIL IT-1 DO 03982000 + BEGIN 03983000 + EXTRAINFO[NEXTEXTRA.IR,NEXTEXTRA.IC] ~ PARMTYPE[I]; 03984000 + NEXTEXTRA ~ NEXTEXTRA+1; 03985000 + END; 03986000 + END 03987000 + ELSE 03988000 + IF T ~ GET(LINK+2).NEXTRA > 0 AND T ! NPARMS OR 03989000 + T=0 AND INTFID AND NPARMS < 2 OR 03990000 + T = 0 AND NOT INTFID THEN 03991000 + BEGIN XTA ~ GET(LINK+1); FLAG(28) END; 03992000 +IF DEBUGTOG THEN FLAGROUTINE(" PARAM","ETERS ",FALSE) ; 03993000 + IT ~ SAVIT-1; 03994000 +END PARAMETERS; 03995000 + 03996000 +PROCEDURE STMTFUNREF(LINK); VALUE LINK; REAL LINK; 03997000 +BEGIN 03998000 + REAL I, PARMLINK, NPARMS, SEG; 03999000 +IF DEBUGTOG THEN FLAGROUTINE(" STMTF","UNREF ",TRUE); 04000000 + PARMLINK ~ GET(LINK+2).[36:12]; 04001000 + DO 04002000 + BEGIN 04003000 + SCAN; 04004000 + IF A~EXPR(TRUE) ! B~GET(PARMLINK).SUBCLASS THEN 04005000 + IF A > REALTYPE OR B > REALTYPE THEN %108-04006000 + BEGIN XTA ~ NNEW; FLAG(88) END; 04007000 + PARMLINK ~ PARMLINK-3; 04008000 + NPARMS ~ NPARMS+1; 04009000 + END UNTIL NEXT ! COMMA; 04010000 + IF NEXT ! RPAREN THEN FLAG(108); 04011000 + SCAN; 04012000 + GETALL(LINK, INFA, XTA, INFC); 04013000 + IF NPARMS ! INFC.NEXTRA THEN FLAG(28); 04014000 + SEG ~ INFA.SEGNO; 04015000 + BRANCHLIT(INFC.BASE&SEG[TOSEGNO],FALSE); 04016000 + EMITB(INFA.ADDR & SEG[TOSEGNO], FALSE); 04017000 + ADJUST; 04018000 + IF DEBUGTOG THEN FLAGROUTINE(" STMTF","UNREF ",FALSE); 04019000 + END STMTFUNREF; 04020000 + 04021000 + BOOLEAN PROCEDURE DOITINLINE(LNK); VALUE LNK; REAL LNK ; 04022000 + BEGIN 04023000 + REAL C,I,C1,C2,C3,C4,C5 ; 04024000 + LABEL HUNT,FOUND,XIT,AIMAG,AINT,CMPLX,LOOP,DDT111,SNGL ; 04025000 + DEFINE OPTYPE=LSTT#, E0=EMITO#, EP=EMITPAIR#, EOL=EMITOPDCLIT# ;04026000 + IF DEBUGTOG THEN FLAGROUTINE("DOITIN","LINE ",TRUE); 04027000 + C1~1; C2~INLINEINT[0]; C3~GET(ABS(LNK)+1) ; 04028000 + HUNT: 04029000 + IF (C~INLINEINT[I~(C1+C2).[36:11]].INAM)C3 THEN C2~I-1 ELSE GO FOUND ; 04031000 + IF C10 THEN INLINEINT[I]~-C4; I~0 ; 04058000 + IF XREF THEN ENTERX(C3,0&FUNID[TOCLASS]&C[21:6:3]); 04059000 + IF GLOBALNEXT!LPAREN THEN BEGIN FLOG(106); GO XIT END ; 04060000 + LOOP: SCAN; C5~XTA ; 04061000 + IF I=0 THEN 04062000 + IF LNK=10 THEN EMITL(0) ELSE IF LNK=21 THEN EMITDESCLIT(2) ; 04063000 + IF (C4~EXPR(TRUE))!C1 AND (C1!REALTYPE OR C4!INTYPE) THEN 04064000 + BEGIN XTA~C5; FLAG(88); C2~-2 END ; 04065000 + I~I+1; IF GLOBALNEXT=COMMA THEN GO LOOP ; 04066000 + IF GLOBALNEXT!RPAREN THEN BEGIN FLOG(108); C2~-2 END; SCAN ; 04067000 + IF I!C.INTPARMS THEN IF C.INTPARMS!0 OR I<2 THEN 04068000 + BEGIN XTA~C3; FLAG(28); C2~-2 END ; 04069000 + OPTYPE[IT]~C.INTCLASS; IF C2<0 THEN GO XIT ; 04070000 + CASE (LNK-1) OF 04071000 + BEGIN 04072000 + E0(SSP) ; % @1: ABS, DABS, IABS. 04073000 + AIMAG: E0(DEL) ; % @2: AIMAG. 04074000 + AINT: EP(1,IDV) ; % @3: AINT, IFIX, INT. 04075000 + E0(RDV) ; % @4: AMOD. 04076000 + E0(LND) ; % @5: LOGICAL AND. 04077000 + CMPLX: E0(XCH) ; % @6: CMPLX. 04078000 + E0(LNG) ; % @7: LOGICAL COMPLIMENT (NEGATION). 04079000 + BEGIN % @10: DIM, IDIM. 04080000 + E0(SUB); E0(DUP); EP(0,LESS) ; 04081000 + IF ADR>4082 THEN BEGIN ADR~ADR+1; SEGOVF END ; 04082000 + EP(2,BFC); E0(DEL); EMITL(0) ; 04083000 + END ; 04084000 + BEGIN E0(XCH); E0(CHS); GO CMPLX END ; % @11: CONJG. 04085000 + ; % @12: DBLE (SOME CODE ALREADY EMITTED ABOVE). 04086000 + BEGIN E0(XCH); E0(DEL) ; % @13: DSIGN. 04087000 + DDT111: EMITDDT(1,1,1) ; 04088000 + END; 04089000 + E0(LQV) ; % @14: LOGICAL EQUIVALENCE. 04090000 + ; % @15: FLOAT. 04091000 + GO DDT111 ; % @16: ISIGN, SIGN. 04092000 + BEGIN E0(RDV); GO AINT END ; % @17: MOD. 04093000 + E0(LOR) ; % @20: LOGICAL OR. 04094000 + BEGIN E0(XCH); GO AIMAG END ; % @21: REAL. 04095000 + EP(1,KOM) ; % @22: TIME. 04096000 + BEGIN % @23: SNGL. 04097000 + SNGL: EP(9,SND); E0(XCH); EMITDDT(47,9,1); EMITL(0) ; 04098000 + EMITDDT(9,9,38); EOL(9); EMITO(ADD); IF LNK=20 THEN GO AINT ; 04099000 + END ; 04100000 + GO SNGL ; % @24: IDINT. 04101000 + 04102000 + BEGIN % @25: AMAX0,AMAX1,AMIN0,AMIN1,MAX0,MAX1,MIN0,MIN1. 04103000 + % SOME CODE ALREADY EMITTED ABOVE. 04104000 + IF ADR>4068 THEN BEGIN ADR~ADR+1; SEGOVF END ; 04105000 + EP(9,STD); E0(DUP); EOL(9) ; 04106000 + E0(IF C3.[24:6]="A" OR C3.[24:6]="X" THEN LESS ELSE GRTR) ; 04107000 + EP(2,BFC); E0(DEL); EOL(9); E0(XCH); E0(TOP); E0(LNG) ; 04108000 + EP(14,BBC); E0(DEL); IF C3="MIN1 " OR C3="MAX1 " THEN GO AINT04109000 + END ; 04110000 + 04111000 + END OF CASE STATEMENT ; 04112000 + XIT: 04113000 + IF DEBUGTOG THEN FLAGROUTINE("DOITIN","LINE ",FALSE) ; 04114000 + END OF DOITINLINE ; 04115000 + 04116000 +REAL PROCEDURE LOOKFORINTRINSIC(L); VALUE L; REAL L; 04117000 +BEGIN 04118000 + ALPHA ID, I, X, NPARMS; 04119000 + REAL T; 04120000 + LABEL FOUND, XIT; 04121000 +IF DEBUGTOG THEN FLAGROUTINE("LOOKFO","RINTRN",TRUE); 04122000 + LOOKFORINTRINSIC ~ L ~ NEED(ID ~ GET(L+1),FUNID); 04123000 + IF GET(L+2) < 0 THEN GO TO XIT; % PARAMETER INFO KNOWN 04124000 + COMMENT B MUST BE SET TO K/2, WHERE K IS THE INDEX OF THE LAST 04125000 + INTRINSIC NAME IN THE ARRAY INT; 04126000 + A~0; B~NUMINTM1 ; 04127000 + WHILE A+1 < B DO 04128000 + BEGIN 04129000 + I ~ REAL(BOOLEAN(A+B) AND BOOLEAN(1022)); 04130000 + IF Z ~ INT[I] = ID THEN GO TO FOUND; 04131000 + IF ID < Z THEN B ~ I.[36:11] ELSE A ~ I.[36:11]; 04132000 + END; 04133000 + IF ID = INT[I~(A+B)|2-I] THEN GO TO FOUND; 04134000 + GO TO XIT; 04135000 + FOUND: 04136000 + NPARMS~(X~INT[I+1]).INTPARMS; INT[I+1].INTSEEN~1 ; 04137000 + INFO[L.IR,L.IC].SUBCLASS~X.INTCLASS ; 04138000 + PUT(L+2,-(1&NEXTEXTRA[TOADINFO]&NPARMS[TONEXTRA])); 04139000 + IF NPARMS = 0 THEN NPARMS ~ 1; 04140000 + T~X.INTPARMCLASS ; 04141000 + FOR I ~ 1 STEP 1 UNTIL NPARMS DO 04142000 + BEGIN 04143000 + EXTRAINFO[NEXTEXTRA.IR,NEXTEXTRA.IC] ~ 04144000 + 0 & EXPCLASS[TOCLASS] & T[TOSUBCL]; 04145000 + NEXTEXTRA ~ NEXTEXTRA + 1; 04146000 + END; 04147000 + XIT: 04148000 +IF DEBUGTOG THEN FLAGROUTINE("LOOKFO","RINTRN",FALSE ) ; 04149000 +END LOOKFORINTRINSIC; 04150000 +INTEGER PROCEDURE EXPR(VALREQ); VALUE VALREQ; BOOLEAN VALREQ; 04151000 +BEGIN LABEL LOOP, STACK, XIT, NOSCAN; REAL T; 04152000 + 04153000 + LABEL ARRY; 04154000 +LABEL HERE ; 04155000 + REAL SAVIT, SAVIP; 04156000 + BOOLEAN CNSTSEENLAST; %FOR HANDLING CONSTANT %113-04157000 + REAL SAVEADR; %EXPONENTS %113-04158000 + DEFINE OPTYPE = LSTT#; 04159000 +REAL EXPRESLT,EXPLNK; 04160000 + REAL EXPV; 04161000 + REAL TM ; 04162000 + DEFINE E0=EMITO#, EP=EMITPAIR#, EOL=EMITOPDCLIT#, 04163000 + ES1(OP)=BEGIN E0(XCH); EP(9,STD); E0(OP) END #, 04164000 + ES2=BEGIN EP(9,STD); E0(XCH); EP(17,SND); E0(MUL) END # ; 04165000 + LABEL CTYP, DTYP, RLESSC, DLESSC, CLESSD, CLESSC, RPLUSD, DTIMESC, 04166000 + CTIMESR, CDIVBYD, CTIMESR1, CTIMESR2, DLESSC1 ; 04167000 + LABEL SPECCHAR, RELATION; 04168000 + REAL LINK; 04169000 + DEFINE T1 = EXPT1#, T2 = EXPT2#, CODE = EXPT3#; 04170000 +COMMENT THE FOLLOWING TABLE GIVES THE PRECEDENCE (PREC) AND 04171000 +OPERATOR NUMBER (OP) OF THE ARITHMETIC AND LOGICAL OPERATORS. 04172000 + OPERATOR PREC OP 04173000 + ** 9 15 04174000 + UNARY - 8 12 04175000 + / 7 14 04176000 + * 7 13 04177000 + - 5 11 04178000 + + 5 10 04179000 + .NE. 4 9 04180000 + .GE. 4 8 04181000 + .GT. 4 7 04182000 + .EQ. 4 6 04183000 + .LE. 4 5 04184000 + .LT. 4 4 04185000 + .NOT. 3 3 04186000 + .AND. 2 2 04187000 + .OR. 1 1 04188000 + THE UNARY PLUS IS IGNORED; 04189000 +PROCEDURE MATH(D, C, T); VALUE D, C, T; REAL D, C, T; 04190000 +BEGIN 04191000 + EMITO(MKS); 04192000 + EMITL(C); 04193000 + EMITV(NEED(".MATH ", INTRFUNID)); 04194000 + EMITO(DEL); 04195000 + IF D = 2 THEN EMITO(DEL); 04196000 + OPTYPE[IT~IT-1] ~ T; 04197000 +END MATH; 04198000 + NNEW ~ NAME; 04199000 +IF DEBUGTOG THEN FLAGROUTINE(" EXPRE","SSION ",TRUE ) ; 04200000 + OPTYPE[SAVIT ~IT ~ IT+1] ~ 04201000 + PR[SAVIP~IP~IP+1] ~ OPST[IP] ~ 0; 04202000 + IF GLOBALNEXT = PLUS THEN GO TO LOOP; 04203000 + IF GLOBALNEXT = MINUS THEN 04204000 + BEGIN PREC ~ 8; OP ~ 12; GO TO STACK END; 04205000 + IF PREC > 0 THEN GO TO STACK; 04206000 + LINK~(EXPLNK~FNEXT)&REAL(SCANENTER)[2:47:1] ; 04207000 + GO TO NOSCAN; 04208000 + LOOP: SCAN; 04209000 + LINK ~ FNEXT; 04210000 + NOSCAN: 04211000 + CNSTSEENLAST~FALSE; %113- 04212000 + IF GLOBALNEXT = ID THEN 04213000 + BEGIN 04214000 + IF IP ! SAVIP THEN EXPRESLT ~ EXPCLASS; 04215000 + OPTYPE[IT~IT+1] ~ (A~GET(LINK)).SUBCLASS; 04216000 + SCAN; 04217000 + IF NOT RANDOMTOG THEN 04218000 + IF NEXT=EQUAL THEN BEGIN NEXT~0; OP~6; PREC~4 END ; 04219000 + IF GLOBALNEXT = ID OR GLOBALNEXT = NUM THEN 04220000 + BEGIN FLOG(1); GO TO XIT END; 04221000 + IF NOT VALREQ AND PREC > 0 THEN VALREQ ~ TRUE; 04222000 + IF GLOBALNEXT ! LPAREN THEN 04223000 + BEGIN 04224000 + LINK ~ GETSPACE(LINK); 04225000 + T ~ (A~GET(LINK)).CLASS; 04226000 + IF XREF THEN ENTERX(GET(LINK+1),0&A[15:15:9]); 04227000 + IF EXPRESLT = 0 THEN EXPRESLT ~ T; 04228000 + IF VALREQ THEN 04229000 + IF T = VARID THEN EMITV(LINK) ELSE 04230000 + BEGIN XTA ~ GET(LINK+1); FLAG(50) END 04231000 + ELSE 04232000 + BEGIN 04233000 + IF T = VARID THEN 04234000 + IF GLOBALNEXT > SLASH AND EXPRESLT = VARID THEN 04235000 + BEGIN 04236000 + DESCREQ~TRUE; EMITN(LINK); DESCREQ ~ FALSE; 04237000 + GO TO XIT; 04238000 + END ELSE EMITV(LINK) 04239000 + ELSE 04240000 + BEGIN 04241000 + IF T = ARRAYID THEN 04242000 + BEGIN 04243000 + IF BOOLEAN(A.CE) THEN 04244000 + EMITNUM(GET(LINK+2).BASE) ELSE 04245000 + IF BOOLEAN(A.FORMAL) THEN 04246000 + EMITOPDCLIT(A.ADDR-1) ELSE 04247000 + EMITL(0); 04248000 + GO TO ARRY; 04249000 + END ELSE EMITPAIR(A.ADDR,LOD); 04250000 + GO TO XIT; 04251000 + END; 04252000 + END; 04253000 + GO TO SPECCHAR; 04254000 + END; 04255000 + IF A.CLASS ! ARRAYID THEN 04256000 + BEGIN COMMENT FUNCTION REFERENCE; 04257000 + EXPRESLT ~ EXPCLASS; 04258000 + IF A.CLASS = STMTFUNID THEN 04259000 + BEGIN 04260000 + IF XREF THEN ENTERX(GET(LINK+1),0&A[15:15:9]); 04261000 + STMTFUNREF(LINK) ; 04262000 + IF NEXT=EQUAL THEN IF NOT RANDOMTOG THEN 04263000 + BEGIN NEXT~0; OP~6; PREC~4 END ; 04264000 + GO TO SPECCHAR ; 04265000 + END ; 04266000 + IF A.CLASS=EXTID OR GET(TM~GLOBALSEARCH(GET(LINK+1))).CLASS=04267000 + EXTID THEN LINK~REAL(DOITINLINE(-LINK)) ELSE 04268000 + IF A.CLASS SLASH AND EXPRESLT = SUBSVAR THEN 04293000 + BEGIN 04294000 + ARRY: 04295000 + IF BOOLEAN((A~GET(LINK)).TWOD) THEN 04296000 + BEGIN 04297000 + EMITPAIR(TWODPRT, LOD); 04298000 + T ~ A.ADDR; 04299000 + IF T { 1023 THEN 04300000 + BEGIN 04301000 + EMITL(T.[38:10]); 04302000 + EMITDESCLIT(10); 04303000 + END ELSE 04304000 + BEGIN 04305000 + EMITL(T.[40:8]); 04306000 + EMITDESCLIT(1536); 04307000 + EMITO(INX); 04308000 + END; 04309000 + EMITO(CTF); 04310000 + END ELSE EMITPAIR(A.ADDR,LOD); 04311000 + EMITO(XCH); 04312000 + GO TO XIT; 04313000 + END; 04314000 + IF BOOLEAN((A~GET(LINK)).TWOD) THEN 04315000 + BEGIN 04316000 + SPLIT(A.ADDR); 04317000 + IF A.SUBCLASS } DOUBTYPE THEN 04318000 + BEGIN 04319000 + EMITO(CDC); 04320000 + EMITO(DUP); 04321000 + EMITPAIR(1, XCH); 04322000 + EMITO(INX); 04323000 + EMITO(LOD); 04324000 + EMITO(XCH); 04325000 + EMITO(LOD); 04326000 + END ELSE EMITO(COC); 04327000 + END ELSE 04328000 + EMITV(LINK); 04329000 + END; 04330000 + END ARRAY REFERENCE; 04331000 + GO TO SPECCHAR; 04332000 + END; 04333000 + IF GLOBALNEXT = NUM THEN 04334000 + BEGIN 04335000 + IF NUMTYPE = STRINGTYPE THEN 04336000 + IF VALREQ THEN 04337000 + BEGIN 04338000 + NUMTYPE~INTYPE ; 04339000 + IF STRINGSIZE=1 THEN FNEXT~STRINGARRAY[0] 04340000 + ELSE BEGIN 04341000 + IF STRINGSIZE>2 OR STRINGARRAY[1].[18:30]!" " THEN 04342000 + FLAG(162) ; 04343000 + IF (FNEXT~STRINGARRAY[1].[12:6]&STRINGARRAY[0][6:12:36]) 04344000 + .[6:6]>7 THEN NUMTYPE~REALTYPE ; 04345000 + END ; 04346000 + END; 04347000 + SAVEADR~ADR; CNSTSEENLAST~TRUE; %113-04348000 + IF NUMTYPE = DOUBTYPE THEN 04349000 + EMITNUM2(FNEXT,DBLOW) ELSE EMITNUM (FNEXT); 04350000 + OPTYPE[IT~IT+1] ~ NUMTYPE; 04351000 + IF EXPRESLT = 0 THEN 04352000 + BEGIN EXPRESLT ~ NUMCLASS; EXPV ~ FNEXT END; 04353000 + SCAN; 04354000 + IF NOT RANDOMTOG THEN 04355000 + IF NEXT=EQUAL THEN BEGIN NEXT~0; OP~6; PREC~4 END; 04356000 + IF NOT VALREQ AND PREC > 0 THEN VALREQ ~ TRUE; 04357000 + IF GLOBALNEXT = ID OR GLOBALNEXT = NUM THEN 04358000 + BEGIN FLOG(1); GO TO XIT END; 04359000 + END; 04360000 + SPECCHAR: 04361000 + IF GLOBALNEXT = LPAREN THEN 04362000 + BEGIN 04363000 + SCAN; 04364000 + OPTYPE[IT~IT+1] ~ EXPR(TRUE); 04365000 + IF GLOBALNEXT = COMMA AND EXPRESULT = NUMCLASS THEN 04366000 + BEGIN 04367000 + IF OPTYPE[IT] > REALTYPE THEN FLAG(85); 04368000 + SCAN; 04369000 + IF EXPR(TRUE) > REALTYPE 04370000 + OR EXPRESULT ! NUMCLASS THEN FLAG(85); 04371000 + EMITO(XCH); 04372000 + OPTYPE[IT] ~ COMPTYPE; 04373000 + IF EXPRESLT = 0 THEN EXPRESLT ~ NUMCLASS; 04374000 + END ELSE EXPRESLT ~ EXPCLASS; 04375000 + IF GLOBALNEXT ! RPAREN THEN 04376000 + BEGIN FLOG(108); GO TO XIT END; 04377000 + GO TO LOOP; 04378000 + END; 04379000 + WHILE PR[IP] } PREC DO 04380000 + BEGIN 04381000 + IF IT { SAVIT THEN GO TO XIT; 04382000 + CODE ~ MAP[T1~OPTYPE[IT-1]]|3 + MAP[T2~OPTYPE[IT]]; 04383000 + CASE OPST[IP] OF 04384000 + BEGIN 04385000 + GO TO XIT; 04386000 + BEGIN 04387000 + IF T1 = LOGTYPE AND T2 = LOGTYPE THEN EMITO(LOR) 04388000 + ELSE FLAG(51); 04389000 + IT ~ IT-1; 04390000 + END; 04391000 + BEGIN 04392000 + IF T1 = LOGTYPE AND T2 = LOGTYPE THEN EMITO(LND) 04393000 + ELSE FLAG(52); 04394000 + IT ~ IT-1; 04395000 + END; 04396000 + IF T2 = LOGTYPE THEN EMITO(LNG) ELSE FLAG(53); 04397000 + BEGIN T ~ LESS; GO TO RELATION END; 04398000 + BEGIN T ~ LEQL; GO TO RELATION END; 04399000 + BEGIN T ~ EQUL; GO TO RELATION END; 04400000 + BEGIN T ~ GRTR; GO TO RELATION END; 04401000 + BEGIN T ~ GEQL; GO TO RELATION END; 04402000 + BEGIN T ~ NEQL; 04403000 + RELATION: 04404000 + IF CODE < 0 THEN FLAG(54) ELSE 04405000 + CASE CODE OF 04406000 + BEGIN ; 04407000 + BEGIN 04408000 + E0(CHS); EP(9,STD); E0(XCH); EOL(9); E0(XCH); EP(0,XCH) ;04409000 + E0(AD2) ; 04410000 + END; 04411000 + FLAG(90); 04412000 + BEGIN EMITPAIR(0, XCH); EMITO(SB2) END; 04413000 + EMITO(SB2); 04414000 + FLAG(90); 04415000 + FLAG(90); 04416000 + FLAG(90); 04417000 + IF T! EQUL AND T! NEQL THEN FLAG(54) %103-04418000 + ELSE %103-04419000 + BEGIN %103-04420000 + EP(9,STD); E0(XCH); EOL(9); E0(T); %103-04421000 + EP(9,STD ); E0(T); EOL(9); %103-04422000 + T~(IF T=EQUL THEN LND ELSE LOR); CODE~0; %103-04423000 + END; %103-04424000 + END RELATION CASE STATEMENT; 04425000 + IF CODE > 0 THEN 04426000 + BEGIN EMITO(XCH); EMITO(DEL); EMITL(0) END; 04427000 + EMITO(T); 04428000 + OPTYPE[IT~IT-1] ~ LOGTYPE; 04429000 + END; 04430000 + IF CODE < 0 THEN BEGIN FLAG(53); IT ~ IT-1 END ELSE 04431000 + CASE CODE OF 04432000 + BEGIN 04433000 + BEGIN 04434000 + EMITO(ADD); 04435000 + IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE 04436000 + OPTYPE[IT~IT-1] ~ REALTYPE; 04437000 + END; 04438000 + BEGIN TM~AD2 ; 04439000 + RPLUSD: EP(9,STD); E0(XCH); EOL(9); E0(XCH); EP(0,XCH); E0(TM) ; 04440000 + DTYP: OPTYPE[IT~IT-1]~DOUBTYPE ; 04441000 + END ; 04442000 + BEGIN TM~ADD; GO RLESSC END ; 04443000 + BEGIN 04444000 + EMITPAIR(0, XCH); 04445000 + EMITO(AD2); 04446000 + IT ~ IT-1; 04447000 + END; 04448000 + BEGIN EMITO(AD2); IT ~ IT-1 END; 04449000 + BEGIN TM~ADD; GO DLESSC END ; 04450000 + BEGIN EMITO(ADD); IT ~ IT-1 END; 04451000 + BEGIN TM~ADD; GO CLESSD END ; 04452000 + BEGIN TM~ADD; GO CLESSC END ; 04453000 + END ADD CASE STATEMENT; 04454000 + IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE 04455000 + CASE CODE OF 04456000 + BEGIN 04457000 + BEGIN 04458000 + EMITO(SUB); 04459000 + IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE 04460000 + OPTYPE[IT~IT-1] ~ REALTYPE; 04461000 + END; 04462000 + BEGIN E0(CHS); TM~AD2; GO RPLUSD END; 04463000 + BEGIN TM~SUB ; 04464000 + RLESSC: ES1(TM); GO DLESSC1 ; 04465000 + END ; 04466000 + BEGIN 04467000 + EMITPAIR(0, XCH); 04468000 + EMITO(SB2); 04469000 + IT ~ IT-1; 04470000 + END; 04471000 + BEGIN EMITO(SB2); IT ~ IT-1 END; 04472000 + BEGIN TM~SUB ; 04473000 + DLESSC: ES1(TM); E0(XCH); E0(DEL) ; 04474000 + DLESSC1: EOL(9); IF TM=SUB THEN E0(CHS); GO CTIMESR2 ; 04475000 + END ; 04476000 + BEGIN EMITO(SUB); IT ~ IT-1 END; 04477000 + BEGIN TM~SUB ; 04478000 + CLESSD: E0(XCH); E0(DEL); E0(TM) ; 04479000 + CTYP: OPTYPE[IT~IT-1]~COMPTYPE ; 04480000 + END ; 04481000 + BEGIN TM~SUB ; 04482000 + CLESSC: ES1(TM); GO CTIMESR1 ; 04483000 + END ; 04484000 + END SUBTRACT CASE STATEMENT; 04485000 + BEGIN % HANDLE NEGATIVE NUMBERS CASE STATEMENT. 04486000 + EXPV~-EXPV ; 04487000 + IF T2 { REALTYPE THEN EMITO(CHS) ELSE 04488000 + IF T2 = LOGTYPE THEN FLAG(55) ELSE 04489000 + IF T2 = DOUBTYPE THEN EMITO(CHS) ELSE 04490000 + IF T2 = COMPTYPE THEN 04491000 + BEGIN 04492000 + EMITO(CHS); EMITO(XCH); 04493000 + EMITO(CHS); EMITO(XCH); 04494000 + END ELSE FLAG(55); 04495000 + END OF NEG NUMBERS CASE STATEMNT ; 04496000 + IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE 04497000 + CASE CODE OF 04498000 + BEGIN 04499000 + BEGIN 04500000 + EMITO(MUL); 04501000 + IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE 04502000 + OPTYPE[IT~IT-1] ~ REALTYPE; 04503000 + END; 04504000 + BEGIN TM~ML2; GO RPLUSD END ; 04505000 + BEGIN ES2; GO DTIMESC END ; 04506000 + BEGIN 04507000 + EMITPAIR(0, XCH); 04508000 + EMITO(ML2); 04509000 + IT ~ IT-1; 04510000 + END; 04511000 + BEGIN EMITO(ML2); IT ~ IT-1 END; 04512000 + BEGIN ES2; E0(XCH); E0(DEL) ; 04513000 + DTIMESC: EOL(9); EOL(17); E0(MUL); GO CTYP ; 04514000 + END ; 04515000 + BEGIN TM~MUL ; 04516000 + CTIMESR: EP(9,SND); E0(TM) ; 04517000 + CTIMESR1:E0(XCH); EOL(9); E0(TM) ; 04518000 + CTIMESR2:E0(XCH); GO CTYP ; 04519000 + END ; 04520000 + BEGIN TM~MUL; GO CDIVBYD END ; 04521000 + MATH(2, 26, COMPTYPE); 04522000 + END MULTIPLY CASE STATEMENT; 04523000 + 04524000 + IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE 04525000 + CASE CODE OF 04526000 + BEGIN 04527000 + IF T1 = INTYPE AND T2 = INTYPE THEN 04528000 + BEGIN EMITO(IDV); IT ~ IT-1 END ELSE 04529000 + BEGIN EMITO(DIU); OPTYPE[IT~IT-1] ~ REALTYPE END; 04530000 + BEGIN 04531000 + EP(9,STD); EP(17,STD); EP(0,XCH); EOL(17); EOL(9); E0(DV2) ; 04532000 + GO DTYP ; 04533000 + END ; 04534000 + MATH(1, 29, COMPTYPE); 04535000 + BEGIN 04536000 + EMITPAIR(0, XCH); 04537000 + EMITO(DV2); 04538000 + IT ~ IT-1; 04539000 + END; 04540000 + BEGIN EMITO(DV2); IT ~ IT-1 END; 04541000 + MATH(2, 32, COMPTYPE); 04542000 + BEGIN TM~DIU; GO CTIMESR END ; 04543000 + BEGIN TM~DIU ; 04544000 + CDIVBYD: E0(XCH); E0(DEL); GO CTIMESR ; 04545000 + END ; 04546000 + MATH(2, 35, COMPTYPE); 04547000 + END OF DIVIDE CASE STATEMENT; 04548000 + IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE 04549000 + BEGIN 04550000 + IF CODE = 0 AND T2 = INTYPE AND 04551000 + CNSTSEENLAST THEN %113-04552000 + BEGIN 04553000 + IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE 04554000 + OPTYPE[IT~IT-1] ~ REALTYPE; 04555000 + EXPV~LINK; %113- 04556000 + A~1; ADR~SAVEADR; %113- 04557000 + WHILE EXPV DIV 2 ! 0 DO 04558000 + BEGIN 04559000 + EMITO(DUP); 04560000 + IF BOOLEAN(EXPV) THEN BEGIN A~A+1; EMITO(DUP) END; 04561000 + EMITO(MUL); 04562000 + EXPV ~ EXPV DIV 2; 04563000 + END; 04564000 + IF EXPV = 0 THEN BEGIN EMITO(DEL); EMITL(1) END ELSE 04565000 + WHILE A ~ A-1 ! 0 DO EMITO(MUL); 04566000 + END ELSE 04567000 + BEGIN 04568000 + EMITO(MKS); 04569000 + EMITL(CODE); 04570000 + EMITV(NEED(".XTOI ", INTRFUNID)); 04571000 + CASE CODE OF 04572000 + BEGIN 04573000 + BEGIN EMITO(DEL); OPTYPE[IT~IT-1]~IF (T1=INTYPE AND T2=INTYPE)04574000 + THEN INTYPE ELSE REALTYPE END; 04575000 + BEGIN EMITO(DEL); OPTYPE[IT~IT-1] ~ DOUBTYPE END; 04576000 + BEGIN EMITO(DEL); OPTYPE[IT~IT-1]~COMPTYPE END ; 04577000 + BEGIN EMITO(DEL); IT ~ IT-1 END; 04578000 + BEGIN EMITO(DEL); EMITO(DEL); IT ~ IT-1 END; 04579000 + BEGIN EMITO(DEL); EMITO(DEL); OPTYPE[IT~IT-1]~COMPTYPE END ; 04580000 + BEGIN EMITO(DEL); IT ~ IT-1 END; 04581000 + BEGIN EMITO(DEL); EMITO(DEL); IT ~ IT-1 END; 04582000 + BEGIN EMITO(DEL); EMITO(DEL); IT~IT-1 END ; 04583000 + END OF POWER CASE STATEMENT; 04584000 + END; 04585000 + END; 04586000 + END; 04587000 + IP ~ IP-1; 04588000 + END; 04589000 + EXPRESLT ~ EXPCLASS; 04590000 + STACK: 04591000 + PR[IP~IP+1] ~ PREC; 04592000 + OPST[IP] ~ OP; 04593000 + IF PREC > 0 AND PREC { 4 THEN 04594000 + BEGIN 04595000 + SCAN; LINK ~ FNEXT; 04596000 + IF NEXT = PLUS THEN GO TO LOOP; 04597000 + IF NEXT ! MINUS THEN GO TO NOSCAN; 04598000 + PREC ~ 8; OP ~ 12; 04599000 + GO TO STACK; 04600000 + END; 04601000 + GO TO LOOP; 04602000 + XIT: IF IP ! SAVIP THEN FLOG(56); 04603000 + IP ~ SAVIP-1; 04604000 + EXPR ~ OPTYPE[IT]; 04605000 + IF OPTYPE[IT-1] ! 0 THEN FLOG(56); 04606000 + IT ~ SAVIT-1; 04607000 + EXPRESULT ~ EXPRESLT; 04608000 + EXPVALUE ~ EXPV; 04609000 + EXPLINK ~ EXPLNK; 04610000 + IF DEBUGTOG THEN FLAGROUTINE(" EXPRE","SSION ",FALSE) ; 04611000 + END EXPR; 04612000 + 04613000 +PROCEDURE FAULT (X); 04614000 + VALUE X; 04615000 + REAL X; 04616000 + BEGIN REAL LINK; LABEL XIT; 04617000 + SCAN; IF GLOBALNEXT ! LPAREN THEN BEGIN FLAG(106); GO XIT END; 04618000 + SCAN; IF GLOBALNEXT ! ID THEN BEGIN FLAG(66); GO TO XIT END; 04619000 + IF X = 1 THEN PDPRT[0,0] ~ PDPRT[0,0] & 1[44:47:1] ELSE 04620000 + PDPRT[0,0] ~ PDPRT [0,0] & 1[43 :47:1]; 04621000 + EMITOPDCLIT(41); EMITO(DUP); 04622000 + IF X = 1 THEN BEGIN EMITL(2); EMITO(XCH); EMITL(1) END 04623000 + ELSE EMITL(6); 04624000 + EMITO(LND); 04625000 + IF X = 2 THEN EMITL(3); 04626000 + EMITO(SUB); 04627000 + IF X = 2 THEN 04628000 + BEGIN EMITO(DUP); EMITL(3); EMITO(SSN) ;EMITO(EQUL); EMITL(2)04629000 + ;EMITO(BFC) ; EMITO(DEL);EMITL(2); 04630000 + END; 04631000 + LINK ~ GET(GETSPACE(FNEXT)); EMITPAIR(LINK.ADDR,ISD); 04632000 + IF X = 1 THEN EMITL(30) ELSE EMITL(25); 04633000 + EMITO(LND); EMITL(41);EMITO(STD); 04634000 + SCAN; IF GLOBALNEXT ! RPAREN THEN FLAG(108); 04635000 + SCAN; 04636000 + XIT: 04637000 + END FAULT; 04638000 +PROCEDURE SUBREF; 04639000 +BEGIN REAL LINK,INFC; 04640000 + REAL ACCIDENT; 04641000 + LABEL XIT; 04642000 +IF DEBUGTOG THEN FLAGROUTINE(" SUB","REF ",TRUE ) ; 04643000 +IF TSSEDITOG THEN IF NAME="ZIP " AND NOT DCINPUT THEN TSSED(NAME,3) ; 04644000 + IF NAME = "EXIT " THEN 04645000 + BEGIN 04646000 + RETURNFOUND ~ TRUE; 04647000 + EMITL(1); 04648000 + EMITPAIR(16,STD); 04649000 + EMITPAIR(10,KOM); 04650000 + EMITPAIR( 5, KOM); 04651000 + PUT(FNEXT+1, "......"); 04652000 + SCAN; 04653000 + END ELSE IF NAME="ZIP " AND NOT DCINPUT THEN 04654000 + BEGIN 04655000 + EMITO(MKS); 04656000 + EMITL(0); EMITL(0); % DUMMY FILE AND FORMAT 04657000 + EMITPAIR(-1,SSN); 04658000 + EMITB(-1,FALSE); LADR1~LAX; ADJUST; DESCREQ~FALSE; 04659000 + IF ADR } 4085 THEN BEGIN ADR~ADR+1; SEGOVF END; 04660000 + ACCIDENT~PRGDESCBLDR(0,0,ADR.[36:10]+1,NSEG); 04661000 + EMITOPDCLIT(19); 04662000 + EMITO(GFW); 04663000 + LISTART ~ ADR&NSEG[TOSEGNO]; ADJUST;SCAN; 04664000 + IF GLOBALNEXT!LPAREN THEN BEGIN FLAG(106);GO TO XIT END; 04665000 + SCAN; IF GLOBALNEXT!ID THEN BEGIN FLAG(66); GO TO XIT END; 04666000 + LINDX ~ FNEXT; SCAN; XTA ~ GET(LINDX+1); 04667000 + IF GLOBALNEXT!RPAREN THEN BEGIN FLAG(108); GO TO XIT END; 04668000 + LINDX ~ GETSPACE(LINDX); 04669000 + IF T~(LINFA~GET(LINDX)).CLASS!ARRAYID THEN 04670000 + BEGIN FLAG(66); GO TO XIT END; 04671000 + IF XREF THEN ENTERX(XTA,0&LINFA[15:15:9]); 04672000 + EMITPAIR(LADDR~LINFA.ADDR,LOD); 04673000 + IF BOOLEAN(LINFA.FORMAL) THEN 04674000 + BEGIN 04675000 + IF T ~ GET(LINDX+2)<0 THEN EMITOPDCLIT(T.SIZE) 04676000 + ELSE EMITNUM(T.SIZE); EMITOPDCLIT(LADDR-1); EMITO(CTF) END 04677000 + ELSE EMITNUM(GET(LINDX+2).BASENSIZE); EMITL(18); EMITO(STD);; 04678000 + EMITL(LINFA.CLASNSUB&0[44:47:1]); EMITL(19); EMITO(STD); 04679000 + BRANCHLIT(LISTART,TRUE); EMITL(19); EMITO(STD); 04680000 + EMITO(RTS); ADJUST; 04681000 + EMITL(1); EMITO(CHS); EMITL(19); EMITO(STD); 04682000 + EMITDESCLIT(19); EMITO(RTS); FIXB(LADR1); DESCREQ~FALSE; 04683000 + EMITPAIR(ACCIDENT,LOD); EMITOPDCLIT(7); EMITO(FTF); 04684000 + EMITL(6); % EDITCODE 6 FOR ZIP 04685000 + EMITV(NEED(".FTOUT",INTRFUNID)); SCAN 04686000 + END ELSE IF NAME = "OVERFL" THEN FAULT(2) 04687000 + ELSE IF NAME = "DVCHK " THEN FAULT(1) 04688000 + ELSE 04689000 + BEGIN 04690000 + LINK ~ NEED(NAME, SUBRID); 04691000 + IF XREF THEN ENTERX(XTA,0&GET(LINK)[15:15:5]); 04692000 + EMITO(MKS); 04693000 + SCAN; 04694000 + IF GLOBALNEXT = LPAREN THEN 04695000 + BEGIN PARAMETERS(LINK); SCAN END ELSE 04696000 + IF NOT BOOLEAN((INFC~GET(LINK+2)).[1:1]) THEN 04697000 + PUT(LINK+2,-INFC) ELSE 04698000 + IF INFC.NEXTRA ! 0 THEN 04699000 + BEGIN XTA ~ GET(LINK+1); FLAG(28) END; 04700000 + EMITV(LINK); 04701000 + END; 04702000 + XIT: 04703000 +IF DEBUGTOG THEN FLAGROUTINE(" SUB","REF ",FALSE) ; 04704000 +END SUBREF; 04705000 + 04706000 +PROCEDURE DECLAREPARMS(FNEW); VALUE FNEW; REAL FNEW; 04707000 +BEGIN 04708000 + REAL I, T, NLABELS, INFA, INFB, INFC; 04709000 +IF DEBUGTOG THEN FLAGROUTINE("DECLAR","EPARMS",TRUE ) ; 04710000 + INFA ~ GET(FNEW); 04711000 + IF INFA.SEGNO ! 0 THEN BEGIN XTA ~ NNEW; FLAG(25) END; 04712000 + INFA.SEGNO ~ NSEG; PUT(FNEW,INFA); 04713000 + ENTRYLINK[ELX] ~ 0 & FNEW[TOLINK] & NEXTSS[TOADDR]; 04714000 + FOR I ~ 1 STEP 1 UNTIL PARMS DO 04715000 + BEGIN 04716000 + EXTRAINFO[NEXTSS.IR,NEXTSS.IC] ~ PARMLINK[I]; 04717000 + NEXTSS ~ NEXTSS-1; 04718000 + IF T ~ PARMLINK[I] ! 0 THEN 04719000 + BEGIN 04720000 + GETALL(T,INFA,INFB,INFC); 04721000 + IF BOOLEAN(INFA .FORMAL) THEN 04722000 + BEGIN 04723000 + IF INFA.SEGNO = ELX THEN 04724000 + BEGIN XTA ~ INFB ; FLAG(26) END; 04725000 + END ELSE IF (INFA < 0 AND INFA.ADDR < 1024) OR BOOLEAN(INFA.CE)04726000 + THEN BEGIN XTA ~ INFB; FLAG(107) END; 04727000 + INFA ~ INFA & 1[TOFORMAL] & ELX[TOSEGNO]; 04728000 + INFC .BASE ~ I; 04729000 + PUT(T,INFA); PUT(T+2,INFC); 04730000 + END ELSE NLABELS ~ NLABELS+1; 04731000 + END; 04732000 + IF NLABELS > 0 THEN 04733000 + BEGIN ENTRYLINK[ELX ].CLASS ~ NLABELS; 04734000 + IF LABELMOM=0 THEN BEGIN BUMPLOCALS; LABELMOM~LOCALS+1536 END; 04735000 + END; 04736000 + GETALL(FNEW,INFA,INFB,INFC); 04737000 + IF BOOLEAN(INFC.[1:1]) THEN 04738000 + BEGIN 04739000 + IF INFC.NEXTRA ! PARMS THEN 04740000 + BEGIN XTA ~ INFB; FLOG(41); 04741000 + PARMS ~ INFC.NEXTRA; 04742000 + END; 04743000 + T ~ INFC.ADINFO; 04744000 + FOR I ~ 1 STEP 1 UNTIL PARMS DO 04745000 + IF NOT(PARMLINK[I] = 0 EQV 04746000 + EXTRAINFO[(T+I-1).IR,(T+I-1).IC].CLASS = LABELID) THEN 04747000 + BEGIN IF PARMLINK[I] = 0 THEN XTA ~ "* " 04748000 + ELSE XTA ~ GET(PARMLINK[I]+1); 04749000 + FLAG(40); 04750000 + END; 04751000 + END 04752000 + ELSE 04753000 + BEGIN 04754000 + IF PARMS = 0 THEN INFC ~ -INFC ELSE 04755000 + INFC ~ -(INFC & PARMS[TONEXTRA] 04756000 + & NEXTEXTRA[TOADINFO]); 04757000 + PUT(FNEW+2,INFC); 04758000 + FOR I ~ 1 STEP 1 UNTIL PARMS DO 04759000 + BEGIN 04760000 + EXTRAINFO[NEXTEXTRA.IR,NEXTEXTRA.IC] ~ 0 & 04761000 + (IF PARMLINK[I] = 0 THEN LABELID ELSE 0)[TOCLASS]; 04762000 + NEXTEXTRA ~ NEXTEXTRA+1; 04763000 + END; 04764000 + END; 04765000 + IF ELX ~ ELX+1 > MAXEL THEN BEGIN FLAG(128); ELX ~ 0 END; 04766000 +IF DEBUGTOG THEN FLAGROUTINE("DECLAR","EPARMS",FALSE) ; 04767000 +END DECLAREPARMS; 04768000 +PROCEDURE IOLIST(LEVEL); REAL LEVEL; 04769000 +BEGIN ALPHA LADR2,T; 04770000 +BOOLEAN A; 04771000 +INTEGER INDX,I,BDLINK,NSUBS; 04772000 + LABEL ROUND,XIT,ERROR,LOOP,SCRAM; 04773000 +INTEGER STREAM PROCEDURE CNTNAM(IDEN); VALUE IDEN; 04774000 +BEGIN LABEL XIT; 04775000 + SI ~ LOC IDEN; SI ~ SI + 3; TALLY ~ 1; 04776000 + 5(IF SC = " " THEN JUMP OUT TO XIT;SI ~ SI+1;TALLY ~ TALLY+1); 04777000 + XIT: CNTNAM ~ TALLY; 04778000 +END CNTNAM; 04779000 +IF DEBUGTOG THEN FLAGROUTINE(" IOL","IST ",TRUE ) ; 04780000 +ROUND: DESCREQ ~ TRUE; 04781000 + LOCALNAME ~ FALSE; 04782000 +IF GLOBALNEXT = SEMI THEN GO TO XIT; 04783000 +IF GLOBALNEXT = STAR THEN 04784000 + BEGIN IF NOT NAMEDESC THEN 04785000 + TV ~ ENTER(0&LISTSID[TOCLASS],LISTID~LISTID+1); 04786000 + LOCALNAME ~ TRUE; NAMEDESC ~ TRUE; SCAN; 04787000 + END; 04788000 +IF GLOBALNEXT = ID THEN 04789000 +BEGIN LINDX ~ FNEXT; 04790000 + SCAN; XTA ~ GET(LINDX+1); 04791000 + IF GLOBALNEXT = EQUAL THEN %RETURN TO CALLER 04792000 + BEGIN IF (LINFA~GET(GETSPACE(LINDX))).CLASS ! VARID THEN FLAG(50);04793000 + SCRAM: IF (LEVEL ~ LEVEL-1) < 0 THEN FLOG(97); 04794000 + GO TO XIT; 04795000 + END; 04796000 + 04797000 + IF DATASTMTFLAG AND SPLINK } 0 THEN %DECLARE OWN 04798000 + BEGIN 04799000 + IF BOOLEAN(GET(LINDX).FORMAL) THEN FLAG(147); 04800000 + IF SPLINK>1 THEN 04801000 + IF GET(LINDX).ADDR>1023 THEN FLAG(174); 04802000 + LINDX ~ GETSPACE(-LINDX); 04803000 + IF BOOLEAN(GET(LINDX).EQ) THEN FLAG(168); 04804000 + END ELSE LINDX ~ GETSPACE(LINDX); 04805000 + IF T ~ (LINFA~GET(LINDX)).CLASS > VARID THEN FLAG(50); 04806000 + IF XREF THEN ENTERX(XTA,C2&LINFA[15:15:9]); 04807000 + IF GLOBALNAME OR LOCALNAME THEN 04808000 + IF NAMEIND~ NAMEIND+1 GTR LSTMAX THEN FLOG(161) 04809000 + ELSE NAMLIST[NAMEIND] ~ XTA & CNTNAM(XTA)[9:45:3]; 04810000 + IF T = ARRAYID THEN 04811000 + IF GLOBALNEXT ! LPAREN THEN 04812000 + BEGIN IF SPLINK ! 1 THEN 04813000 + BEGIN 04814000 + EMITL(0); 04815000 + EMITPAIR(LADDR ~ LINFA.ADDR,LOD); 04816000 + EMITO(FTC); 04817000 + EMITDESCLIT(2); 04818000 + EMITO(INX); 04819000 + EMITO(LOD); 04820000 + END ELSE EMITPAIR(LADDR-LINFA.ADDR,LOD); 04821000 + NSUBS ~ (T ~ GET (LINDX+2)).NEXTRA; 04822000 + IF GLOBALNAME OR LOCALNAME THEN 04823000 + BEGIN 04824000 + IF NSUBS GTR SAVESUBS THEN SAVESUBS ~ NSUBS; 04825000 + IF NSUBS GTR NAMLIST[0] THEN NAMLIST[0] ~ NSUBS; 04826000 + NAMLIST[NAMEIND].[1:8] ~ NSUBS; 04827000 + INDX ~ -1; 04828000 + INFA ~ GET(NEED(".SUBAR",BLOCKID)).ADDR; 04829000 + BDLINK ~ T.ADINFO+1; 04830000 + END; 04831000 + IF BOOLEAN (LINFA.FORMAL) THEN 04832000 + BEGIN 04833000 + IF T LSS 0 THEN EMITOPDCLIT(T.SIZE) 04834000 + ELSE EMITNUM(T.SIZE); 04835000 + EMITOPDCLIT(LADDR-1); 04836000 + EMITO(CTF); 04837000 + END ELSE EMITNUM(T.BASENSIZE); 04838000 + IF GLOBALNAME OR LOCALNAME THEN 04839000 + FOR I ~ 1 STEP 1 UNTIL NSUBS DO 04840000 + BEGIN IF T ~ EXTRAINFO[(BDLINK~BDLINK-1).IR, 04841000 + BDLINK.IC] LSS 0 THEN EMITOPDCLIT(T) 04842000 + ELSE EMITNUM(T); 04843000 + EMITNUM(INDX ~ INDX+1); 04844000 + EMITDESCLIT(INFA); 04845000 + EMITO(STD); 04846000 + END; 04847000 + EMITL(18); EMITO(STD); 04848000 + END ELSE 04849000 + BEGIN SCAN; 04850000 + A ~(IF GLOBALNAME OR LOCALNAME 04851000 + THEN SUBSCRIPTS(LINDX,4) ELSE SUBSCRIPTS(LINDX,2)); 04852000 + SCAN; 04853000 + END 04854000 + ELSE EMITN(LINDX); 04855000 + IF GLOBALNAME OR LOCALNAME THEN 04856000 + BEGIN EMITOPDCLIT(18); EMITNUM(NAMEIND); 04857000 + EMITD(43,DIA); EMITD(3,DIB); EMITD(15,TRB); 04858000 + EMITL(18); EMITO(STD); 04859000 + END; 04860000 + EMITL(LINFA.CLASNSUB&0[44:47:1]); 04861000 + EMITL(20); EMITO(STD); 04862000 + IF ADR > 4083 THEN 04863000 + BEGIN ADR~ADR+1; SEGOVF END ; 04864000 + BRANCHLIT(LISTART,TRUE); 04865000 + EMITL(19); EMITO(STD); 04866000 + EMITO(RTS); ADJUST; 04867000 + GO TO LOOP; 04868000 +END; 04869000 +IF GLOBALNEXT = LPAREN THEN % RECURSE ON ( 04870000 +BEGIN EMITB(-1,FALSE); 04871000 + ADJUST; 04872000 + LADR2 ~ (ADR + 1)&LAX[TOADDR]&NSEG[TOSEGNO]; 04873000 + SCAN; LEVEL ~ LEVEL + 1; 04874000 + IOLIST(LEVEL); 04875000 + IF GLOBALNEXT ! EQUAL THEN % PHONY IMP DO 04876000 + BEGIN BRANCHES[T ~ LADR2.ADDR] ~ BRANCHX; 04877000 + BRANCHX ~ T; 04878000 + IF GLOBALNEXT ! RPAREN THEN GO TO ERROR; 04879000 + SCAN; GO TO LOOP; 04880000 + END; 04881000 + IF XREF THEN ENTERX(GET(LINDX+1),1&LINFA[15:15:9]); 04882000 + IF LINFA.SUBCLASS > REALTYPE THEN 04883000 + BEGIN XTA ~ GET(LINDX + 1); 04884000 + FLAG(84); 04885000 + END; 04886000 + EMITB(-1,FALSE); 04887000 + LADR3 ~ LAX; 04888000 + FIXB(LADR2.ADDR); 04889000 + DESCREQ ~ FALSE; 04890000 + SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(102); % INITIAL VALUE 04891000 + EMITN(LINDX); EMITO(STD); 04892000 + EMITB(LADR2,FALSE); 04893000 + IF GLOBALNEXT ! COMMA THEN GO TO ERROR; 04894000 + ADJUST; 04895000 + LADR4 ~ (ADR + 1)&NSEG[TOSEGNO]; 04896000 + SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(102) ELSE EMITO(GRTR); 04897000 + EMITB(LADR2,TRUE); 04898000 + EMITB(-1,FALSE); 04899000 + LADR5 ~ LAX; 04900000 + FIXB(LADR3); 04901000 + IF GLOBALNEXT ! COMMA THEN EMITL(1) 04902000 + ELSE BEGIN SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(102); END; 04903000 + EMITV(LINDX); EMITO(ADD); 04904000 + EMITN(LINDX); EMITO(SND); 04905000 + EMITB(LADR4,FALSE); 04906000 + FIXB(LADR5); 04907000 + IF GLOBALNEXT = RPAREN THEN SCAN ELSE GO TO ERROR; 04908000 + LOOP: IF GLOBALNEXT = SEMI OR GLOBALNEXT = SLASH THEN GO TO XIT; 04909000 + IF GLOBALNEXT = RPAREN THEN GO TO SCRAM; 04910000 + IF GLOBALNEXT = COMMA THEN 04911000 + BEGIN SCAN; 04912000 + IF GLOBALNEXT = SEMI THEN GO TO ERROR; 04913000 + GO TO ROUND; 04914000 + END; 04915000 + ERROR: XTA ~ NAME; 04916000 + FLAG(94); 04917000 + IF GLOBALNEXT = SEMI THEN GO TO XIT; 04918000 + SCAN; 04919000 + IF GLOBALNEXT = ID THEN GO TO ROUND; 04920000 + ERRORTOG ~ TRUE; GO TO XIT; 04921000 + END; 04922000 + IF GLOBALNEXT = RPAREN THEN GO TO SCRAM ELSE 04923000 + IF GLOBALNEXT ! SLASH THEN GO TO ERROR; 04924000 + XIT: IF DEBUGTOG THEN FLAGROUTINE(" IOL","IST ",FALSE) ; 04925000 + END IOLIST; 04926000 + INTEGER PROCEDURE FILECHECK(FILENAME,FILETYPE); 04927000 + VALUE FILENAME,FILETYPE; ALPHA FILENAME; INTEGER FILETYPE; 04928000 + BEGIN COMMENT THIS PROCEDURE RETURNS THE PRT CELL ALLOCATED TO 04929000 + THE FILE FILENAME... A CELL IS CREATED IF NONE EXISTS; 04930000 + IF DEBUGTOG THEN FLAGROUTINE(" FILEC","HECK ",TRUE); 04931000 + EMITL(IF NOTOPIO THEN 2 ELSE 5); % FOR IO DESCRIPTOR 04932000 + IF T ~ GLOBALSEARCH(FILENAME) = 0 THEN % FILE UNDECLARED 04933000 + BEGIN MAXFILES ~ MAXFILES + 1; 04934000 + BUMPPRT; 04935000 + I ~ GLOBALENTER(-0&(FILECHECK~PRTS)[TOADDR] 04936000 + &FILEID[TOCLASS],FILENAME)+2; 04937000 + INFO[I.IR,I.IC]. LINK ~ FILETYPE; 04938000 + END ELSE % FILE ALREADY EXISTS 04939000 + FILECHECK ~ GET(T).ADDR; 04940000 + IF DEBUGTOG THEN FLAGROUTINE(" FILEC","HECK ",FALSE) ; 04941000 + END FILECHECK; 04942000 + PROCEDURE INLINEFILE; 04943000 + BEGIN COMMENT THIS PROCEDURE GENERATES THE CODE TO BRING UP THE FILE...04944000 + IF THE FILE IS AN INTEGER THEN FILECHECK IS CALLED, IF THE FILE 04945000 + IS NOT AN INTEGER THEN IN-LINE CODE IS GENERATED FOR OBJECT TIME 04946000 + ANALYSIS; 04947000 + REAL TEST; 04948000 + COMMENT IF LAST INSTRUCTION WAS A LIT CALL THEN WE HAVE SEEN REFERENCE 04949000 + TO AN INTEGER FILE ID; 04950000 + IF DEBUGTOG THEN FLAGROUTINE(" INLIN","EFILE ",TRUE ) ; 04951000 + TEST~ADR ; 04952000 + IF EXPR(TRUE)>REALTYPE THEN FLAG(102) 04953000 + ELSE IF EXPRESULT=NUMCLASS THEN 04954000 + BEGIN XTA~NNEW ; 04955000 + IF EXPVALUE}1.0@5 OR EXPVALUE{0.5 THEN FLAG(33) 04956000 + ELSE BEGIN 04957000 + IF ADR LSTMAX THEN GO TO NUL; 05147000 + WSA[TOTAL] ~ I ~ 0; GO TO ROUND; 05148000 + END ELSE GO TO ROUND ELSE GO TO NUL1; 05149000 + END; 05150000 + IF NOT STRINGF THEN 05151000 + IF SLCNT > 0 THEN 05152000 + IF T = "/" THEN BEGIN SLCNT ~ SLCNT+1; GO TO ROUND; END 05153000 + ELSE 05154000 + BEGIN WSA[TOTAL] ~ 0 & SLCNT[TOREPEAT] & SLASH[TOCODE]; 05155000 + IF NOT STR THEN 05156000 + IF REPEAT < 16 AND WSA[TOTAL-1].[42:6] = 0 THEN 05157000 + WSA[TOTAL~TOTAL-1] ~ WSA[TOTAL] & SLCNT[42:44:4] 05158000 + & 1[46:47:1]; 05159000 + COMMAS~DOLLARS~BOOLEAN(SLCNT~0); NCR~BACKNCR(NCR) ; 05160000 + GO TO NUL1; 05161000 + END; 05162000 + IF NOT QF THEN IF T = """ THEN IF STRINGF ~ NOT STRINGF THEN 05163000 + BEGIN IF CODE > 4 THEN BEGIN STRINGF ~ FALSE; 05164000 + NCR ~ BACKNCR(NCR); GO TO ENDER END; 05165000 + SAVTOTAL ~ TOTAL; J~0; I~3; QF ~ TRUE; 05166000 + WSA[TOTAL] ~ 0 & HPHASE[TOCODE]; 05167000 + GO TO ROUND; 05168000 + END ELSE 05169000 + BEGIN 05170000 + WSA[SAVTOTAL] ~ WSA[SAVTOTAL] & J[TOREPEAT]; 05171000 + IF I = 0 THEN TOTAL ~ TOTAL - 1; 05172000 + CODE ~ HPHASE; 05173000 + GO TO ENDER; 05174000 + END; 05175000 + IF STRINGF THEN 05176000 + BEGIN 05177000 + STORECHAR(WSA[TOTAL],I,T); 05178000 + J ~ J + 1; QF ~ FALSE; 05179000 + IF I ~ I+1 = 8 THEN 05180000 + BEGIN 05181000 + IF TOTAL ~ TOTAL +1> LSTMAX THEN GO TO NUL; 05182000 + I ~ WSA[TOTAL] ~ 0; 05183000 + END; 05184000 + GO TO ROUND; 05185000 + END; 05186000 +CASE T OF 05187000 +BEGIN 05188000 + BEGIN ZF ~ TRUE; % 0 05189000 + NUM: DECIMAL ~ 10 | DECIMAL + T; 05190000 + IF ASK THEN 05191000 + BEGIN FLAG(183); %111-05192000 +FL: DO BEGIN NCR~GETCHAR(NCR,T); XTA~T&XTA[12:18:30] END 05193000 + UNTIL T!"*" AND T>9 AND T!" " ; 05194000 + NCR~BACKNCR(NCR); XTA~BLANKS&XTA[18:12:30] ; 05195000 + END 05196000 + ELSE 05197000 + IF DECIMAL>4090 THEN BEGIN FLAG(172); DECIMAL~1 END ; 05198000 + IF CODE = 0 THEN REPEAT ~ DECIMAL 05199000 + ELSE IF PF THEN BEGIN IF DECIMAL>WIDTH AND WIDTH!0 AND CODE! 05200000 + VPHRASE THEN FLAG(129) END ELSE WIDTH~DECIMAL ; 05201000 + GO TO ROUND; 05202000 + END; 05203000 + GO TO NUM; GO TO NUM; GO TO NUM; % 1 2 3 05204000 + GO TO NUM; GO TO NUM; GO TO NUM; % 4 5 6 05205000 + GO TO NUM; GO TO NUM; GO TO NUM; % 7 8 9 05206000 + ; ; ; ; ; ; % # @ Q : > } 05207000 + BEGIN PLUSP ~ TRUE; GO TO ROUND; END; % + 05208000 + BEGIN CODE ~ APHASE; GO TO NOEND END; % A 05209000 + ; % B 05210000 + BEGIN CODE ~ CPHASE; GO TO NOEND END; % C 05211000 + BEGIN CODE ~ DPHASE; GO TO NOEND END; % D 05212000 + BEGIN CODE ~ EPHASE; GO TO NOEND END; % E 05213000 + BEGIN CODE ~ FPHASE; GO TO NOEND END; % F 05214000 + BEGIN CODE ~ GPHASE; GO TO NOEND END; % G 05215000 + BEGIN IF REPEAT = 0 THEN FLOG(130); % H 05216000 + IF ASK THEN BEGIN FLOG(32 ); GO SEMIC END ; 05217000 + HF ~ TRUE; I ~ 3; CODE ~ HPHASE; 05218000 + WSA[TOTAL] ~ 0 & HPHASE[TOCODE] & REPEAT[TOREPEAT]; 05219000 + GO TO ROUND; 05220000 + END; 05221000 + BEGIN CODE ~ IPHASE; GO TO NOEND END; % I 05222000 + BEGIN IF CODE < 11 OR CODE=15 THEN FLOG(134); % . 05223000 + IF CODE=0 OR PF THEN FLOG(32) ; 05224000 + PF~TRUE; DECIMAL~0; ASK~ZF~FALSE ; 05225000 + GO TO ROUND; 05226000 + END; 05227000 + GO TO RP; % [ 05228000 + ; % & 05229000 + LP: 05230000 + BEGIN IF CODE ! 0 THEN FLOG(32); % ( 05231000 + IF ASK THEN REPEAT~4095; IF REPEAT=0 AND ZF THEN FLAG(173) ;05232000 + NAMLIST[SAVLASTLP ~ PARENCT ~ PARENCT+1] ~ 0 & TOTAL[TOWIDTH]05233000 + &(IF REPEAT{0 AND PARENCT>1 THEN 1 ELSE REPEAT)[TOREPEAT] ; 05234000 + IF ASK THEN 05235000 + BEGIN ASK~VRB~FALSE ; 05236000 + WSA[TOTAL]~32&LPPHRASE[TOCODE]&4095[TOREPEAT] ; 05237000 + IF (TOTAL~TOTAL+1)>LSTMAX THEN GO NUL ; 05238000 + END ; 05239000 + ZF~BOOLEAN(REPEAT~DECIMAL~0) ; 05240000 + STR ~ TRUE; 05241000 + GO TO ROUND1; 05242000 + END; 05243000 + ; ; ; % < ~ | 05244000 + BEGIN CODE~JPHASE; WIDTH~-1; GO NOEND END ; % J 05245000 + BEGIN % K 05246000 + IF COMMAS OR CODE!0 THEN BEGIN FLAG(32); COMMAS~TRUE END 05247000 + ELSE BEGIN COMMAS~TRUE ; 05248000 +KK: DO BEGIN NCR~GETCHAR(NCR,T); XTA~T&XTA[12:18:30] END 05249000 + UNTIL T!" " ; 05250000 + IF (T<17 OR (T>25 AND T<33) OR (T>42 AND T<50) OR T>57) 05251000 + THEN BEGIN FLAG(32) ; 05252000 + IF T="*" OR T<10 THEN BEGIN DECIMAL~1; GO FL END ; 05253000 + END ; 05254000 + NCR~BACKNCR(NCR); XTA~BLANKS&XTA[18:12:30] ; 05255000 + END ; 05256000 + GO ROUND ; 05257000 + END OF K ; 05258000 + BEGIN CODE ~ LPHASE; GO TO NOEND; END; % L 05259000 + ; ; % M N 05260000 + BEGIN CODE ~ OPHASE; GO TO NOEND; END; % O 05261000 + BEGIN WSA[TOTAL] ~ 0 & PPHASE[TOCODE] % P 05262000 + & REAL(VRB)[42:47:1] 05263000 + & REAL(MINUSP)[TOSIGN] & REPEAT[TOWIDTH]&1[TOREPEAT]; 05264000 + MINUSP ~ PLUSP ~ FALSE; 05265000 + IF (DECIMAL = 0 AND NOT ZF) THEN FLOG(131); 05266000 + GO TO NUL1; 05267000 + END; 05268000 + ; ; % Q R 05269000 + BEGIN IF DOLLARS OR CODE!0 THEN FLAG(32) % $ 05270000 + ELSE BEGIN DOLLARS~TRUE; GO KK END ; 05271000 + DOLLARS~TRUE; GO ROUND ; 05272000 + END OF DOLLAR SIGN ; 05273000 + IF NOT ASK THEN % * 05274000 + BEGIN 05275000 + IF ZF OR DECIMAL NEQ 0 THEN FLAG(183); DECIMAL:=4095; %111-05276000 + IF CODE=0 THEN REPEAT~DECIMAL 05277000 + ELSE IF NOT PF THEN WIDTH~DECIMAL ; 05278000 + VRB := ASK := LISTEL := TRUE; GO ROUND; %101-05279000 + END ELSE BEGIN DECIMAL:=4095; FLAG(183); GO FL END ; %111-05280000 + BEGIN MINUSP ~ TRUE; GO TO ROUND; END; % - 05281000 + RP: 05282000 + BEGIN IF FIELD THEN BEGIN NCR ~ BACKNCR(NCR); % ) 05283000 + GO TO ENDER; END; 05284000 + IF DECIMAL ! 0 THEN FLAG(32); 05285000 + I ~ IF PARENCT = 1 THEN IF SAVLASTLP > 1 THEN 2 ELSE 1 05286000 + ELSE PARENCT; 05287000 + WSA[TOTAL]~(J~NAMLIST[I])&(TOTAL+1-J~J.[18:12])[TOLINK] 05288000 + & (IF PARENCT ~ PARENCT-1 = 0 THEN 77 ELSE 0)[TODECIMAL]; 05289000 + IF WSA[J].[1:5]=LPPHRASE AND PARENCT!0 THEN 05290000 + BEGIN WSA[J].[18:12]~TOTAL-J; WSA[TOTAL].[18:12]~TOTAL-J ;05291000 + END ; 05292000 + NAMLIST[I].[6:12] ~ 0; 05293000 + CODE ~ HPHASE; 05294000 + GO TO NUL1; 05295000 + END; 05296000 + ; ; % ; LEQ 05297000 + GO TO ROUND; % BLANKS 05298000 + BEGIN SLCNT ~ 1; % / 05299000 +SL: IF CODE=0 THEN IF ASK OR ZF OR DECIMAL!0 THEN 05300000 + BEGIN FLAG(32); ASK~ZF~BOOLEAN(DECIMAL~0) END ; 05301000 + IF CODE<5 THEN IF T="," THEN GO ROUND1 ELSE GO ROUND ELSE GO 05302000 + ENDER ; 05303000 + END; 05304000 + ; % S 05305000 + BEGIN IF REPEAT ! 0 THEN FLAG(32); % T 05306000 + CODE ~ TPHASE; 05307000 + GO TO NOEND; 05308000 + END; 05309000 + ; % U 05310000 + BEGIN VRB~TRUE; CODE~VPHRASE; WIDTH~-1; GO NOEND END ; % V 05311000 + ; % W 05312000 + BEGIN IF REPEAT = 0 THEN FLOG(130); % X 05313000 + IF STR THEN 05314000 + NEWWD: WSA[TOTAL] ~ 0 & XPHASE[TOCODE] & REPEAT[TOWIDTH] 05315000 + & 1[TOREPEAT] 05316000 + & REAL(VRB)[42:47:1] 05317000 + ELSE 05318000 + BEGIN 05319000 + IF (J~WSA[TOTAL-1]).[42:6]>0 OR (I~J.[1:5])=RTPARN 05320000 + OR (REPEAT}32 AND I!XPHASE) THEN GO NEWWD ; 05321000 + IF I=XPHASE AND (I~J.[18:12]+REPEAT){4090 THEN 05322000 + WSA[TOTAL~TOTAL-1] ~ J & I[TOWIDTH] 05323000 + ELSE IF REPEAT } 32 THEN GO TO NEWWD 05324000 + ELSE WSA[TOTAL~TOTAL-1] ~ J & REPEAT[TONUM] 05325000 + & 1[TOCNTRL]; 05326000 + END; 05327000 + GO TO NUL1; 05328000 + END; 05329000 + ; ; % Y Z 05330000 + GO SL ; % , 05331000 + GO TO LP; % % 05332000 + ; ; ; % ! = ] " 05333000 +END OF CASE STATEMENT; 05334000 +FLOG(132); % ILLEGAL CHARACTER; 05335000 +GO TO FALL; 05336000 +ENDER: IF CODE > 4 THEN 05337000 + BEGIN IF WIDTH=0 THEN FLAG(130) ; 05338000 + IF CODE=VPHRASE THEN 05339000 + BEGIN 05340000 + IF WIDTH=-1 THEN IF PF THEN FLAG(130)ELSE WIDTH~ 05341000 + DECIMAL~4094 ELSE 05342000 + IF NOT PF THEN DECIMAL~4094 ; 05343000 + END 05344000 + ELSE 05345000 + IF CODE > 10 AND CODE ! 15 THEN 05346000 + IF (DECIMAL = 0 AND NOT ZF) OR NOT PF THEN FLAG(133) 05347000 + ELSE ELSE DECIMAL ~ 0; 05348000 + IF REPEAT=0 THEN REPEAT~1 ; 05349000 + IF WIDTH=-1 THEN WIDTH~0 ; 05350000 + WSA[TOTAL] ~ 0 & CODE[TOCODE] & WIDTH[TOWIDTH] 05351000 + & REPEAT[TOREPEAT] & DECIMAL[TODECIMAL] 05352000 + & REAL(COMMAS) [44:47:1] 05353000 + & REAL(VRB)[42:47:1] 05354000 + & REAL(DOLLARS)[45:47:1]; 05355000 + END ELSE IF DECIMAL ! 0 THEN FLAG(32); 05356000 +NUL1: IF PLUSP THEN FLAG(164); 05357000 + IF CODE!VPHRASE THEN 05358000 + BEGIN 05359000 + IF DOLLARS AND(CODE < 9 OR CODE > 14) THEN FLAG(166); 05360000 + IF COMMAS AND NOT(CODE = 10 OR CODE = 12 OR CODE = 9) 05361000 + THEN FLAG(165); 05362000 + END; 05363000 + VRB~ 05364000 + ERRORTOG ~ FIELD ~ PF ~ PLUSP ~ DOLLARS ~ COMMAS ~ STR ~ FALSE; 05365000 + IF CODE = HPHASE THEN STR ~ TRUE; 05366000 + CODE ~ REPEAT ~ WIDTH ~ 0; 05367000 + XTA ~ BLANKS; 05368000 + GO TO FALL; 05369000 +NOEND: IF FIELD THEN FLAG(32); 05370000 + IF CODE ! TPHASE THEN LISTEL ~ TRUE ELSE REPEAT ~ 1; 05371000 + IF REPEAT=0 AND ZF THEN FLAG(173) ; 05372000 + FIELD ~ TRUE; 05373000 +FALL: IF MINUSP THEN BEGIN FLAG(32); MINUSP ~ FALSE END; 05374000 + ASK~ZF~FALSE ; 05375000 +NUL: DECIMAL ~ 0; 05376000 + IF PARENCT = 0 THEN BEGIN SCN ~ 1; GO TO SEMIC END; 05377000 + IF CODE < 5 THEN 05378000 + IF TOTAL ~ TOTAL+1 > LSTMAX THEN 05379000 + BEGIN FLOG(78);TOTAL ~ TOTAL-2; GO TO SEMIC; END; 05380000 +GO TO ROUND; 05381000 +NOPLACE: IF(DCINPUT OR FREEFTOG) AND (STRINGF OR HF) THEN FLOG(150); 05382000 + IF TSSEDITOG THEN IF (STRINGF OR HF) AND NOT DCINPUT 05383000 + THEN TSSED(XTA,1); 05384000 + IF CONTINUE THEN IF READACARD THEN 05385000 + BEGIN IF LISTOG THEN PRINTCARD; GO TO ROUND; END; 05386000 +SCN ~ 0; NEXT ~ SEMI; 05387000 +SEMIC: 05388000 +IF SCN = 1 THEN SCAN; 05389000 +IF STRINGF THEN FLAG(22); 05390000 +IF NOT LISTEL THEN WSA[0] ~ 0; 05391000 +IF PARENCT ! 0 THEN FLAG(IF PARENCT < 0 THEN 9 ELSE 8); 05392000 +IF D ! 0 THEN PRTSAVER(D,TOTAL+1,WSA); 05393000 +IF DEBUGTOG THEN BEGIN 05394000 + WRITE(LINE,FM) ; 05395000 + FOR I~0 STEP 1 UNTIL TOTAL DO BEGIN 05396000 + WRITE(LINE,[13]//,I,(J~WSA[I]).[1:5],J.[6:12],J.[18:12],J.[30:12], 05397000 + J.[41:1],J.[42:4],J.[42:5],J.[44:1],J.[45:1], 05398000 + J.[46:1],J.[46:2],J.[47:1]) ; 05399000 + IF J.[1:5]=2 THEN I~I+(J.[6:12]+2).[36:9] ; 05400000 + END ; 05401000 + WRITE(LINE[DBL]) ; 05402000 + END OF DEBUGSTUFF ; 05403000 +END FORMATER; 05404000 + 05405000 +PROCEDURE EXECUTABLE; 05406000 +BEGIN LABEL XIT; REAL T, J, TS, P; 05407000 + IF SPLINK < 0 THEN FLAG(12); 05408000 + IF LABL = BLANKS THEN GO TO XIT; 05409000 + IF T ~ SEARCH(XTA ~ LABL) = 0 THEN 05410000 + T ~ ENTER(-0 & LABELID[TOCLASS] & (ADR+1)[TOADDR] & 05411000 + NSEG[TOSEGNO], LABL) ELSE 05412000 + BEGIN IF (P ~ GET(T)).CLASS ! LABELID THEN 05413000 + BEGIN FLAG(144); GO TO XIT END; 05414000 + IF P < 0 THEN BEGIN FLAG(20); GO TO XIT END; 05415000 + TS ~ P.ADDR; 05416000 + WHILE TS ! 0 DO 05417000 + BEGIN J ~ GIT(TS); FIXB(TS+10000); TS ~ J END; 05418000 + PUT(T, P~-P & (ADR+1)[TOADDR] & NSEG[TOSEGNO]); 05419000 + IF (T ~ GET(T+2)).BASE ! 0 THEN 05420000 + T ~ PRGDESCBLDR(2, T.BASE, (ADR+1).[36:10], NSEG); 05421000 + END; 05422000 + IF XREF THEN ENTERX(LABL,1&LABELID[TOCLASS]); 05423000 + XIT: 05424000 +END EXECUTABLE; 05425000 + 05426000 +PROCEDURE IOCOMMAND(N); VALUE N; REAL N; 05427000 +COMMENT N COMMAND 05428000 + 0 READ 05429000 + 1 WRITE 05430000 + 2 PRINT 05431000 + 3 PUNCH 05432000 + 4 BACKSPACE 05433000 + 7 DATA; 05434000 +BEGIN LABEL XIT,SUCH,LISTER,NOFORM,FORMER,WRAP,DAAT,NF; 05435000 +LABEL LISTER1; 05436000 + BOOLEAN SUCHTOG, RDTRIN, FREEREAD; 05437000 + BOOLEAN FORMARY, NOFORMT; 05438000 + BOOLEAN NAMETOG; 05439000 +DEFINE DATATOG = DATASTMTFLAG#; 05440000 +REAL T, ACCIDENT, EDITCODE; 05441000 +REAL DATAB; 05442000 +PROCEDURE ACTIONLABELS(UNSEEN); VALUE UNSEEN; BOOLEAN UNSEEN; 05443000 +BEGIN LABEL EOF,ERR,RATA,XIT,ACTION,MULTI; 05444000 + BOOLEAN BACK,GOTERR,GOTEOF; 05445000 +IF UNSEEN THEN SCAN; 05446000 +EOF: IF GOTEOF THEN GO TO MULTI; 05447000 + IF BACK ~ NAME = "END " THEN GO TO ACTION; 05448000 +ERR: IF GOTERR THEN GO TO MULTI; 05449000 + IF NAME ! "ERR " THEN IF GOTEOF THEN 05450000 + BEGIN MULTI: XTA ~ NAME; FLOG(137); 05451000 + GO TO XIT; 05452000 + END ELSE GO TO RATA; 05453000 +ACTION: SCAN; 05454000 + IF NEXT = EQUAL THEN SCAN ELSE GO TO RATA; 05455000 + IF NEXT ! NUM THEN GO TO RATA; 05456000 + IF XREF THEN ENTERX(NAME,0&LABELID[TOCLASS]); 05457000 + IF BACK THEN NX1 ~ NAME ELSE NX2 ~ NAME; 05458000 + SCAN; IF NEXT = RPAREN THEN GO TO XIT; 05459000 + IF NEXT = COMMA THEN SCAN ELSE GO TO RATA; 05460000 + IF BACK THEN 05461000 + BEGIN BACK ~ NOT ( GOTEOF ~ TRUE); 05462000 + GO TO ERR; 05463000 + END; 05464000 + GOTERR ~ TRUE; 05465000 + GO TO EOF; 05466000 +RATA: XTA ~ NAME; FLOG(0); 05467000 +XIT: 05468000 +END ACTIONLABELS; 05469000 +IF DEBUGTOG THEN FLAGROUTINE(" IOCOM","MAND ",TRUE ); 05470000 +EODS~N!7 ; 05471000 +C2 ~ IF N = 0 OR N = 7 THEN 1 ELSE 0; 05472000 +SCAN; IF NEXT = SEMI THEN BEGIN FLOG(0); GO TO XIT END; 05473000 +IF N = 7 THEN 05474000 +BEGIN DATATOG ~ TRUE; 05475000 + IF LOGIFTOG THEN FLAG(101); 05476000 + LABL ~ BLANKS; 05477000 + IF SPLINK } 0 THEN %NOT BLOCK DATA STMT 05478000 + BEGIN 05479000 + IF DATAPRT=0 THEN BEGIN 05480000 + DATAPRT~PRTS~PRTS+1; ADJUST; 05481000 + DATASTRT~(ADR+1)&NSEG[TOSEGNO] END 05482000 + ELSE FIXB(DATALINK); 05483000 + EMITOPDCLIT(DATAPRT); EMITO(LNG); 05484000 + EMITB(-1, TRUE); DATAB ~ LAX; 05485000 + END; 05486000 + GO TO DAAT; 05487000 +END; 05488000 + EXECUTABLE; 05489000 +EMITO(MKS); 05490000 +IF N = 4 THEN 05491000 +BEGIN 05492000 + INLINEFILE; 05493000 + BEGIN EMITL(0); EMITL(0); EMITL(0); EMITL(0); 05494000 + EMITL(5); EMITL(0); EMITL(0); 05495000 + EMITV(NEED(".FBINB",INTRFUNID)); 05496000 + END; 05497000 + GO TO XIT; 05498000 +END; 05499000 +EDITCODE ~ NX1 ~ NX1 ~ 0; 05500000 +IF RDTRIN ~ 05501000 + N = 0 THEN IF NEXT = LPAREN THEN GO TO SUCH 05502000 + ELSE EMITDESCLIT(FILECHECK(".5 ",2+17|REAL %503-05503000 + (REMOTETOG))) 05504000 +ELSE IF N = 1 THEN IF NEXT ! LPAREN THEN FLAG(33) 05505000 + ELSE GO TO SUCH 05506000 + ELSE IF N = 2 THEN %503-05507000 + EMITDESCLIT(FILECHECK(".6 ",2+17|REAL %503-05508000 + (REMOTETOG))) 05509000 + ELSE EMITDESCLIT(FILECHECK(".PUNCH",0)); 05510000 +IF RDTRIN THEN EMITL(0) ELSE EMITPAIR(1,SSN); 05511000 +GO TO FORMER; 05512000 +SUCH: SCAN; RANDOMTOG~SUCHTOG~TRUE; INLINEFILE ; 05513000 + RANDOMTOG~FREEREAD~FALSE ; 05514000 + IF NEXT = EQUAL THEN % RANDOM KEY 05515000 + BEGIN SCAN; 05516000 + IF EXPR(TRUE) > REALTYPE THEN FLAG(102); 05517000 + IF RDTRIN THEN EMITPAIR(1,ADD); 05518000 + END ELSE IF RDTRIN THEN EMITL(0) ELSE EMITPAIR(1,SSN); 05519000 + IF NEXT = RPAREN THEN GO TO NF; 05520000 + IF NEXT ! COMMA THEN BEGIN FLOG(114); GO TO XIT END; 05521000 + SCAN; 05522000 + IF NEXT = ID THEN 05523000 + IF NAME = "ERR " OR NAME = "END " THEN 05524000 + BEGIN ACTIONLABELS(FALSE); 05525000 + NF: IF RDTRIN THEN EMITL(0) ELSE EMITPAIR(1,SSN); 05526000 + EMITL(0); 05527000 + NOFORMT ~ TRUE; 05528000 + SCAN; GO TO NOFORM; 05529000 + END; 05530000 +FORMER: IF ADR } 4085 THEN 05531000 + BEGIN ADR ~ ADR+1; SEGOVF END; 05532000 + IF NEXT = NUM THEN % FORMAT NUMBER 05533000 + BEGIN EDITCODE ~ 1; 05534000 + IF TEST ~ LBLSHFT(NAME) { 0 THEN 05535000 + BEGIN FLAG(135); GO TO LISTER END; 05536000 + IF I ~ SEARCH(TEST) = 0 THEN % NEVER SEEN 05537000 + OFLOWHANGERS(I~ENTER(0&FORMATID[TOCLASS], TEST)) ELSE 05538000 + IF GET(I).CLASS ! FORMATID THEN 05539000 + BEGIN FLAG(143); GO TO LISTER END; 05540000 + IF XREF THEN ENTERX(TEST,0&FORMATID[TOCLASS]); 05541000 + IF GET(I).ADDR = 0 THEN 05542000 + BEGIN EMITLINK((INFC ~ GET(I + 2)).BASE); 05543000 + PUT(I + 2,INFC&ADR[TOBASE]); 05544000 + EMITL(0); EMITL(0); EMITO(NOP); 05545000 + END ELSE 05546000 + BEGIN EMITL(GET(I+ 2).BASE); 05547000 + EMITPAIR(GET(I).ADDR,LOD); 05548000 + END; 05549000 + GO TO LISTER; 05550000 +END ELSE IF RDTRIN THEN IF(FREEREAD := NEXT=SLASH) THEN GO TO LISTER 05551000 +ELSE BEGIN IF NEXT NEQ ID THEN BEGIN FLOG(116);GO TO XIT; END;END 05552000 + ELSE IF NEXT NEQ ID THEN 05553000 + BEGIN IF NEXT = STAR THEN 05554000 + BEGIN NAMEDESC := TRUE; GLOBALNAME := TRUE; 05555000 + TV := ENTER(0&LISTSID[TOCLASS],LISTID:=LISTID+1); 05556000 + SCAN; 05557000 + END; 05558000 + IF NEXT = LPAREN THEN 05559000 + BEGIN SCAN; IF EXPR(TRUE) GTR REALTYPE THEN FLAG(120) ; 05560000 + SCAN; END ELSE EMITL(0); 05561000 + IF GLOBALNAME AND (FREEREAD := NEXT = SLASH) OR FREEREAD THEN 05562000 + GO TO LISTER ELSE BEGIN FLOG(110); GO TO XIT; END; 05563000 + END; 05564000 + GETALL(I ~ FNEXT,INFA,INFB,INFC); 05565000 + IF T ~ INFA.CLASS = ARRAYID THEN % FORMAT ARRAY 05566000 + BEGIN EDITCODE ~ 1; 05567000 + FORMARY ~ TRUE; 05568000 + T ~ EXPR(FALSE); 05569000 + ADR ~ ADR-1; % ELIMINATE XCH EMITTED BY EXPR 05570000 + IF EXPRESULT ! ARRAYID THEN FLOG(116); 05571000 + GO TO LISTER1; % SCAN ALREADY DONE IN EXPR 05572000 + END ELSE 05573000 + IF T = NAMELIST THEN 05574000 + BEGIN NAMETOG := TRUE; 05575000 + IF INFA.ADDR = 0 THEN % REFERENCED, NOT DEF 05576000 + BEGIN EMITLINK(INFC.BASE); 05577000 + PUT(I+ 2,(INFC ~ INFC&ADR[TOBASE])); 05578000 + EMITL(0); EMITL(0); EMITO(NOP); 05579000 + END ELSE 05580000 + BEGIN EMITL(INFC.BASE); 05581000 + EMITPAIR(INFA.ADDR,LOD); 05582000 + END 05583000 + END 05584000 + ELSE IF T = UNKNOWN THEN % ASSUME NAMELIST 05585000 + BEGIN PUT(I,(INFA ~ INFA&NAMELIST[TOCLASS])); 05586000 + NAMETOG := TRUE; 05587000 + OFLOWHANGERS(I); 05588000 + EMITLINK(0); PUT(I + 2,INFC&ADR[TOBASE]); 05589000 + EMITL(0); EMITL(0); EMITO(NOP); 05590000 + END ELSE BEGIN XTA ~ INFB; FLOG(116); GO TO XIT END; 05591000 + SCAN; 05592000 + IF NEXT = COMMA THEN ACTIONLABELS(TRUE); 05593000 + IF SUCHTOG THEN 05594000 + IF NEXT ! RPAREN THEN FLOG(108) ELSE SCAN; 05595000 + IF NEXT ! SEMI THEN BEGIN FLOG(118); GO TO XIT END; 05596000 + EMITL(0); EDITCODE ~ 4; EMITOPDCLIT(7); EMITO(FTC); 05597000 + GO TO WRAP; 05598000 +LISTER: SCAN; 05599000 + IF FREEREAD THEN IF NOT RDTRIN THEN 05600000 + BEGIN IF NEXT ! SLASH THEN EMITO(SSN) ELSE SCAN; 05601000 + IF NEXT = LPAREN THEN 05602000 + BEGIN SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(120);SCAN 05603000 + END ELSE EMITL(0); 05604000 + END; 05605000 +LISTER1: 05606000 + IF SUCHTOG THEN 05607000 + BEGIN IF NEXT = COMMA THEN ACTIONLABELS(TRUE); 05608000 + IF NEXT = RPAREN THEN SCAN ELSE BEGIN FLOG(108); GO TO XIT END; 05609000 + END ELSE IF NEXT=COMMA THEN SCAN ELSE IF RDTRIN THEN 05610000 + IF NEXT!SEMI THEN FLOG(114); 05611000 +NOFORM: IF NEXT=SEMI THEN 05612000 + BEGIN IF FREEREAD THEN FLOG(061) ELSE EMITL(0); GO TO WRAP END; 05613000 + IF (NEXT NEQ LPAREN) AND (NEXT NEQ ID) AND (NEXT NEQ STAR) THEN 05614000 + GO TO XIT; 05615000 + EDITCODE ~ EDITCODE + 2; 05616000 +DAAT: EMITB(-1,FALSE); LADR1 ~ LAX; ADJUST; DESCREQ ~ TRUE; 05617000 + IF ADR } 4085 THEN 05618000 + BEGIN ADR ~ ADR+1; SEGOVF; ADJUST END; 05619000 + ACCIDENT ~ PRGDESCBLDR(0,0,ADR.[36:10] + 1,NSEG); 05620000 + EMITOPDCLIT(19); EMITO(GFW); 05621000 + LISTART ~ ADR&NSEG[TOSEGNO]; ADJUST; 05622000 + LA ~ 0; IOLIST(LA); 05623000 + EMITL(1); EMITO(CHS); EMITL(19); EMITO(STD); 05624000 + EMITDESCLIT(19); EMITO(RTS); 5625000 + FIXB(LADR1); DESCREQ ~ FALSE; 05626000 + IF DATATOG THEN 05627000 + BEGIN DATASET; 05628000 + IF NEXT = SLASH THEN SCAN ELSE 05629000 + BEGIN FLOG(110); GO TO XIT END; 05630000 + IF LSTA = 0 THEN BEGIN BUMPPRT; LSTA~PRTS END; 05631000 + IF (LSTMAX - LSTI) { LSTS THEN 05632000 + BEGIN WRITEDATA(LSTI,NXAVIL ~ NXAVIL + 1,LSTP); 05633000 + LSTA ~ PRGDESCBLDR(1,LSTA,0,NXAVIL); 05634000 + LSTI ~ 0; BUMPPRT; LSTA~PRTS; 05635000 + END; 05636000 + MOVEW(LSTT,LSTP[LSTI],(LSTS ~ LSTS + 1).[36:6],LSTS); 05637000 + EMITO(MKS); EMITL(LSTI); EMITPAIR(LSTA,LOD); 05638000 + LSTI ~ LSTI + LSTS; 05639000 + EMITPAIR(ACCIDENT,LOD); EMITOPDCLIT(7); EMITO(FTF); 05640000 + EMITL(6); EMITL(0); EMITL(0); 05641000 + EMITV(NEED(".FBINB",INTRFUNID)); 05642000 + IF NEXT = COMMA THEN 05643000 + BEGIN SCAN; GO TO DAAT END; 05644000 + IF SPLINK } 0 THEN BEGIN 05645000 + EMITB(-1,FALSE); DATALINK~LAX; 05646000 + FIXB(DATAB) END; 05647000 + GO TO XIT; 05648000 + END; 05649000 + EMITPAIR(ACCIDENT,LOD); EMITOPDCLIT(7); EMITO(FTF); 05650000 +WRAP: IF NOT FREEREAD AND NOT NAMETOG THEN EMITL(EDITCODE); 05651000 +IF RDTRIN THEN 05652000 +BEGIN IF NX1 = 0 THEN EMITL(0) ELSE EMITLABELDESC(NX1); 05653000 + IF NX2 = 0 THEN EMITL(0) ELSE EMITLABELDESC(NX2); 05654000 + IF FREEREAD THEN EMITV(NEED(".FREFR", INTRFUNID)) 05655000 + ELSE IF NAMETOG THEN EMITV(NEED(".FINAM",INTRFUNID)) 05656000 + ELSE IF FORMARY THEN EMITV(NEED(".FTINT",INTRFUNID)) 05657000 + ELSE IF NOFORMT THEN EMITV(NEED(".FBINB",INTRFUNID)) 05658000 + ELSE EMITV(NEED(".FTNIN",INTRFUNID)); 05659000 +END ELSE 05660000 +IF FREEREAD THEN 05661000 + BEGIN 05662000 + IF NAMEDESC THEN 05663000 + BEGIN 05664000 + PRTSAVER(TV,NAMEIND+1,NAMLIST); 05665000 + EMITL(GET(TV+2).BASE); 05666000 + EMITPAIR(GET(TV).ADDR,LOD); 05667000 + IF NAMLIST[0] = 0 THEN EMITL(0) 05668000 + ELSE EMITPAIR(GET(GLOBALSEARCH(".SUBAR")).ADDR,LOD); 05669000 + NAMLIST[0] := NAMEIND := 0; 05670000 + END ELSE BEGIN EMITL(0);EMITL(0);EMITL(0);END; 05671000 + EMITV(NEED(".FREWR",INTRFUNID)) 05672000 + END ELSE IF NAMETOG THEN EMITV(NEED(".FONAM",INTRFUNID)) 05673000 + ELSE IF FORMARY THEN EMITV(NEED(".FTOUT",INTRFUNID)) 05674000 + ELSE BEGIN 05675000 + IF NX1=0 THEN EMITL(0) ELSE EMITLABELDESC(NX1); 05676000 + IF NX2=0 THEN EMITL(0) ELSE EMITLABELDESC(NX2); 05677000 + IF NOFORMT THEN EMITV(NEED(".FBINB",INTRFUNID)) ELSE 05678000 + EMITV(NEED(".FTNOU",INTRFUNID)); 05679000 + END; 05680000 +XIT: 05681000 + IF NAMEDESC THEN IF RDTRIN THEN FLAG(159) 05682000 + ELSE IF NOT FREEREAD THEN FLAG(160); 05683000 + DATATOG := FALSE; NAMEDESC := FALSE; GLOBALNAME := FALSE; 05684000 +IF DEBUGTOG THEN FLAGROUTINE(" IOCOM","MAND ",FALSE); 05685000 +END IOCOMMAND; 05686000 +PROCEDURE STMTFUN(LINK); VALUE LINK; REAL LINK; 05687000 +BEGIN 05688000 + DEFINE PARAM = LSTT#; 05689000 + REAL SAVEBRAD, I; 05690000 + REAL INFA, INFC, NPARMS, TYPE, PARMLINK, BEGINSUB, RETURN; 05691000 + LABEL XIT,TIX ; 05692000 + IF SPLINK < 0 THEN FLAG(12); 05693000 + LABL ~ BLANKS; 05694000 + FILETOG ~ TRUE; % PREVENTS SCANNER FROM ENTERING IDS IN INFO 05695000 + IF XREF THEN ENTERX(GET(LINK+1),0&STMTFUNID[TOCLASS] 05696000 + &(GET(LINK))[21:21:3]); 05697000 + DO 05698000 + BEGIN 05699000 + SCAN; 05700000 + IF NEXT ! ID THEN BEGIN FLOG(107); GO TO XIT END; 05701000 + PARAM[NPARMS~NPARMS+1] ~ NAME; 05702000 + SCAN; 05703000 + END UNTIL NEXT ! COMMA; 05704000 + IF NEXT ! RPAREN THEN FLOG(108) ELSE SCAN; 05705000 + IF NEXT ! EQUAL THEN BEGIN FLOG(104); GO TO XIT END; 05706000 + EMITB(-1,FALSE); SAVEBRAD ~ LAX; % BRANCH AROUND ST FUN 05707000 + ADJUST; 05708000 + BEGINSUB ~ ADR+1; 05709000 + BUMPLOCALS; EMITPAIR(RETURN~LOCALS+1536,STD); 05710000 + FOR I ~ NPARMS STEP -1 UNTIL 1 DO 05711000 + BEGIN 05712000 + IF T ~ SEARCH(PARAM[I]) ! 0 THEN 05713000 + TYPE ~ GET(T).SUBCLASS ELSE 05714000 + IF T~PARAM[I].[12:6] < "I" OR T > "N" THEN 05715000 + TYPE ~ REALTYPE ELSE TYPE ~ INTYPE; 05716000 + EMITSTORE( ENTER(0&VARID[TOCLASS]&1[TOTYPE] 05717000 + &TYPE[TOSUBCL], PARAM[I]), TYPE); 05718000 + IF XREF THEN ENTERX(NAME,0&VARID[TOCLASS]&TYPE[TOSUBCL]); 05719000 + END; 05720000 + PARMLINK ~ NEXTINFO-3; 05721000 + GETALL(LINK, INFA, XTA, INFC); 05722000 + FILETOG ~ FALSE; 05723000 + SCAN; 05724000 + IF (TYPE~(INFA~GET(LINK)).SUBCLASS)=LOGTYPE OR TYPE=COMPTYPE OR05725000 + (I~EXPR(TRUE))=LOGTYPE OR I=COMPTYPE THEN 05726000 + BEGIN IF I!TYPE THEN FLAG(139); GO TIX END ; 05727000 + IF TYPE=REALTYPE OR TYPE=INTYPE THEN 05728000 + BEGIN 05729000 + IF I=DOUBTYPE THEN BEGIN EMITO(XCH); EMITO(DEL) END; 05730000 + IF TYPE=INTYPE THEN IF I!INTYPE THEN EMITPAIR(1,IDV) ; 05731000 + GO TIX ; 05732000 + END ; 05733000 + IF I!DOUBTYPE THEN EMITPAIR(0,XCH) ; 05734000 +TIX: 05735000 + EMITOPDCLIT(RETURN) ; 05736000 + EMITO(GFW); 05737000 + FIXB(SAVEBRAD); 05738000 + IF INFA.CLASS ! UNKNOWN THEN FLAG(140); 05739000 + PUT(LINK, -INFA & 1[TOTYPE] & NSEG[TOSEGNO] 05740000 + & STMTFUNID[TOCLASS] & BEGINSUB[TOADDR]); 05741000 + PUT(LINK+2, -(0 & NPARMS[TONEXTRA] & ADR[TOBASE] 05742000 + & PARMLINK[36:36:12])); 05743000 + PARMLINK ~ PARMLINK+4; 05744000 + FOR I ~ 1 STEP 1 UNTIL NPARMS DO 05745000 + PUT(PARMLINK ~ PARMLINK-3, "......"); 05746000 + XIT: 05747000 + FILETOG ~ FALSE; 05748000 +END STMTFUN; 05749000 +PROCEDURE ASSIGNMENT; 05750000 +BEGIN 05751000 + LABEL XIT; 05752000 +BOOLEAN CHCK; 05753000 +BOOLEAN I; 05754000 +IF DEBUGTOG THEN FLAGROUTINE(" ASSIG","NMENT ",TRUE ) ; 05755000 + FX1 ~ FNEXT; 05756000 + SCAN; 05757000 + IF NEXT = LPAREN THEN 05758000 + BEGIN 05759000 +CHCK~TRUE; 05760000 + IF GET(FX1).CLASS = UNKNOWN THEN 05761000 + IF EODS THEN 05762000 + BEGIN XTA ~ GET(FX1+1); FLOG(035) ; 05763000 + PUT(FX1,GET(FX1) & ARRAYID[TOCLASS]) ; 05764000 + PUT(FX1+2,GET(FX1+2) & 1[TONEXTRA]) ; 05765000 + END 05766000 + ELSE BEGIN STMTFUN(FX1); GO TO XIT END ; 05767000 + IF XREF THEN ENTERX(GET(FX1+1),1&GET(FX1) [15:15:9]); 05768000 + EODS ~ TRUE ; 05769000 + EXECUTABLE; 05770000 + SCAN; 05771000 + I ~ SUBSCRIPTS(FX1,2); 05772000 + SCAN; 05773000 + END ELSE 05774000 + BEGIN 05775000 + EODS~TRUE ; 05776000 + EXECUTABLE; 05777000 + IF T ~ GET(FX1).CLASS = ARRAYID THEN 05778000 + BEGIN XTA ~ GET(FX1+1); FLAG(74) END; 05779000 + MOVEW(ACCUM[1],HOLDID[0],0,3); 05780000 + IF XREF THEN IF HOLDID[0].[12:12] ! "DO" THEN 05781000 + ENTERX(GET(FX1+1),1&GET(FX1)[21:21:3]&VARID[TOCLASS]); 05782000 + END; 05783000 + IF NEXT ! EQUAL THEN BEGIN FLAG(104); GO TO XIT END; 05784000 + SCAN; 05785000 + IF NEXT=SEMI OR NEXT=COMMA THEN BEGIN FLOG(0); GO TO XIT; END; 05786000 + FX2 ~ EXPR(TRUE); 05787000 + IF NEXT NEQ COMMA THEN IF HOLDID[0] = "DO" THEN IF XREF THEN 05788000 + ENTERX(HOLDID[0] ,1&GET(FX1)[21:21:3]&VARID[TOCLASS]); 05789000 + IF NEXT = COMMA THEN IF CHCK THEN FLOG(56) ELSE 05790000 + IF HOLDID[0].[12:12] ! "DO" THEN FLOG(56) ELSE 05791000 + BEGIN 05792000 + IF LOGIFTOG THEN FLAG(101); 05793000 + IF FX2 > REALTYPE THEN FLAG(102); 05794000 + IF DT ~ DT+1 > MAXDOS THEN BEGIN DT ~ 1; FLAG(138) END; 05795000 + EMITN(FX1~ CHECKDO); 05796000 + EMITO(STD); 05797000 + SCAN; 05798000 + IF NEXT=SEMI THEN BEGIN FLAG(36); GO TO XIT END; 05799000 + IF (ACCUM[0] = ", " OR ACCUM[0] = "; ") AND 05800000 + GLOBALNEXT=NUM AND ABS(FNEXT) > 1023 THEN 05801000 + BEGIN 05802000 + IF EXPR(TRUE) > REALTYPE THEN FLAG(102); 05803000 + IDINFO:=REALID;FNEXT:=ENTER(IDINFO,"2FNV00"&DT[36:36:12]);05804000 + EMITN(FNEXT:=GETSPACE(FNEXT)); EMITO(STD); 05805000 + EMITB(-1,FALSE); LADR1:=LAX; ADJUST; 05806000 + LADR2 ~ (ADR+1) & NSEG[TOSEGNO]; EMITV(FNEXT); 05807000 + END 05808000 + ELSE BEGIN 05809000 + EMITB(-1,FALSE); LADR1:=LAX; ADJUST; 05810000 + LADR2:=(ADR+1)&NSEG[TOSEGNO]; 05811000 + IF EXPR(TRUE) > REALTYPE THEN FLAG(102) ; 05812000 + END ; 05813000 + EMITO(GRTR); 05814000 + EMITB(-1, TRUE); 05815000 + LADR3 ~ LAX; 05816000 + EMITB(-1, FALSE); 05817000 + ADJUST; 05818000 + DOTEST[DT] ~ (ADR+1) & LAX[TOADDR] & NSEG[TOSEGNO]; 05819000 + IF NEXT ! COMMA THEN EMITL(1) ELSE 05820000 + BEGIN 05821000 + SCAN; 05822000 + IF NEXT=SEMI THEN BEGIN FLAG(36); GO TO XIT END ; 05823000 + IF EXPR(TRUE) > REALTYPE THEN FLAG(102); 05824000 + END; 05825000 + EMITV(FX1); 05826000 + EMITO(ADD); 05827000 + EMITN(FX1); 05828000 + EMITO(STN); 05829000 + EMITB(LADR2, FALSE); 05830000 + FIXB(LADR1); 05831000 + FIXB(LADR3); 05832000 + END ELSE EMITSTORE(FX1, FX2); 05833000 + XIT: 05834000 +IF DEBUGTOG THEN FLAGROUTINE(" ASSIG","NMENT ",FALSE ) ; 05835000 +END ASSIGNMENT; 05836000 +BOOLEAN PROCEDURE RINGCHECK; 05837000 +COMMENT THIS PROCEDURE PREVENTS THE POSSIBILITY OF DELINKING A 05838000 + HEADER FROM THE HEADER RING; 05839000 + BEGIN 05840000 + INTEGER I; 05841000 + I~A; 05842000 + DO 05843000 + IF I ~ GETC(I).ADDR = ROOT THEN RINGCHECK ~ TRUE 05844000 + UNTIL I = A; 05845000 + END RINGCHECK; 05846000 +PROCEDURE SETLINK(INFADDR); VALUE INFADDR; INTEGER INFADDR; 05847000 +COMMENT THIS PROCEDURE LINKS AN ELEMENT TO ITS PREVIOUS HEADER; 05848000 +BEGIN 05849000 + INTEGER LAST,I; REAL COML; LABEL XIT; 05850000 +XIT: 05851000 + LAST ~(GETC(INFADDR).LASTC)-1; 05852000 + FOR I ~ INFADDR+2 STEP 1 UNTIL LAST 05853000 + DO BEGIN IF GETC(I).CLASS = ENDCOM THEN I~GETC(I).LINK; 05854000 + IF FX1 = (COML~GETC(I)).LINK THEN 05855000 + IF INFADDR~COML.LASTC=A THEN COM[PWI].LASTC~ROOT 05856000 + ELSE GO XIT ; 05857000 + END; 05858000 +END SETLINK; 05859000 +PROCEDURE DIMENSION; 05860000 +BEGIN 05861000 + LABEL L, LOOP, ERROR ; 05862000 + BOOLEAN DOUBLED, SINGLETOG; %109-05863000 +IF DEBUGTOG THEN FLAGROUTINE(" DIMEN","SION ",TRUE ) ; 05864000 + IF LOGIFTOG THEN FLAG(101); 05865000 + LABL ~ BLANKS; 05866000 + IF NEXT=STAR THEN IF TYPE!DOUBTYPE THEN 05867000 + BEGIN 05868000 + SCAN ; 05869000 + IF NEXT=NUM AND NUMTYPE=INTYPE THEN 05870000 + BEGIN 05871000 + IF FNEXT=4 THEN 05872000 + BEGIN 05873000 + SINGLETOG ~ TRUE; %109-05874000 + IF TYPE=COMPTYPE THEN FLAG(176); GO L ; 05875000 + END ; 05876000 + IF FNEXT=8 THEN 05877000 + BEGIN 05878000 + IF TYPE=REALTYPE THEN TYPE~DOUBTYPE 05879000 + ELSE IF TYPE!COMPTYPE THEN FLAG(177) ; 05880000 + GO L ; 05881000 + END ; 05882000 + END ; 05883000 + FLAG(IF TYPE=REALTYPE THEN 178 05884000 + ELSE 177-REAL(TYPE=COMPTYPE)) ; 05885000 +L: NCR~REAL(NCR.[30:3]!0)+3"677777"+NCR; SCN~1; SCAN ; 05886000 + END ; 05887000 + LOOP: DOUBLED~FALSE; 05888000 + IF NEXT ! ID THEN BEGIN FLOG(105); GO TO ERROR END; 05889000 + FX1 ~ IF SINGLETOG THEN -FNEXT ELSE FNEXT; %109-05890000 + IF TYPE } DOUBTYPE THEN % FIX ARRAY TYPE OFR 05891000 + PUT(FX1,GET(FX1)&TYPE[TOSUBCL]); % BOUNDS ROUTINE 05892000 + IF XREF THEN BEGIN INFA ~ 0&GET(FX1)[15:15:9]; 05893000 + IF TYPE>0 THEN INFA.SUBCLASS~TYPE; 05894000 + END; 05895000 + XTA ~ INFB ~ NAME; 05896000 + SCAN; 05897000 + IF XREF THEN 05898000 + BEGIN IF INFA.CLASS = UNKNOWN THEN 05899000 + INFA.CLASS~IF NEXT=LPAREN THEN ARRAYID ELSE VARID; 05900000 + ENTERX(INFB,INFA); 05901000 + END; 05902000 + IF NEXT=LPAREN THEN BEGIN SCAN; DOUBLED~BOUNDS(FX1) END ELSE 05903000 + IF TYPE = -1 THEN FLOG(103); 05904000 + GETALL(FX1, INFA, XTA, INFC); 05905000 + IF TYPE > 0 THEN 05906000 + IF BOOLEAN(INFA.TYPEFIXED) THEN FLAG(31) ELSE 05907000 + BEGIN 05908000 + IF TYPE > LOGTYPE THEN 05909000 + IF GET(FX1+2) <0 THEN 05910000 + BEGIN 05911000 + IF NOT DOUBLED AND INFA.CLASS=1 THEN 05912000 + BEGIN 05913000 + BUMPLOCALS; 05914000 + LENGTH~LOCALS + 1536; 05915000 + PUT(FX1+2,INFC & LENGTH[TOSIZE]); 05916000 + END 05917000 + END ELSE IF NOT DOUBLED THEN 05918000 + BEGIN IF INFC.SIZE > 16383 THEN FLAG(99); 05919000 + PUT(FX1+2,INFC & (2 | INFC.SIZE)[TOSIZE]); 05920000 + END; 05921000 + PUT (FX1,INFA & 1[TOTYPE] & TYPE[TOSUBCL]); 05922000 + END; 05923000 + IF INFA < 0 THEN FLAG(39) ELSE 05924000 + IF TYPE = -2 THEN 05925000 + BEGIN 05926000 + BAPC(INFA&FX1[TOLINK]&1[TOCE]&ROOT[TOLASTC]); 05927000 + IF BOOLEAN(INFA.CE) THEN FLAG(2); 05928000 + IF BOOLEAN(INFA.EQ) THEN 05929000 + BEGIN 05930000 + COM[NEXTCOM.IR,NEXTCOM.IC].LASTC ~ A ~ INFA.ADDR; 05931000 + B~GETC(ROOT).ADDR ; 05932000 + SETLINK(A); 05933000 + IF NOT RINGCHECK THEN 05934000 + BEGIN 05935000 + COM[PWROOT].ADDR~GETC(A).ADDR ; 05936000 + PUTC(A,GETC(A)&B[TOADDR]&7[TOSUBCL]) ; 05937000 + END 05938000 + END ELSE 05939000 + PUT(FX1, INFA & 1[TOCE] & ROOT[TOADDR]); 05940000 + IF BOOLEAN(INFA.FORMAL) THEN FLAG(10); 05941000 + END; 05942000 + IF ERRORTOG THEN 05943000 + ERROR: 05944000 + WHILE NEXT ! COMMA AND NEXT ! SEMI AND NEXT ! SLASH DO SCAN; 05945000 + IF NEXT = COMMA THEN BEGIN SCAN; GO TO LOOP END; 05946000 +IF DEBUGTOG THEN FLAGROUTINE(" DIMEN","SION ",FALSE ); 05947000 +END DIMENSION; 05948000 +PROCEDURE FORMALPP(PARMSREQ, CLASS); VALUE PARMSREQ, CLASS; 05949000 + BOOLEAN PARMSREQ; REAL CLASS; 05950000 +BEGIN 05951000 + LABEL LOOP, XIT; 05952000 +IF DEBUGTOG THEN FLAGROUTINE(" FORM","ALPP ",TRUE ) ; 05953000 + PARMS ~ 0; 05954000 + SCAN; 05955000 + IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; 05956000 + IF CLASS = FUNID THEN 05957000 + IF FUNVAR = 0 THEN 05958000 + BEGIN 05959000 + IF TYPE > 0 THEN 05960000 + IF FUNVAR ~ GLOBALSEARCH(NAME) ! 0 THEN 05961000 + IF BOOLEAN((T ~ GET(FUNVAR)).TYPEFIXED) AND TYPE ! T.SUBCLASS 05962000 + THEN FLAG(31); 05963000 + PUT(FUNVAR ~ FNEXT,GET(FNEXT) & VARID[TOCLASS]); 05964000 + END; 05965000 + FNEW ~ NEED(NNEW ~ NAME, CLASS); 05966000 + ENTERX(NAME,IF CLASS = FUNID THEN 05967000 + 1&GET(FNEW)[15:15:9] ELSE 1&GET(FNEW)[15:15:5]); 05968000 + SCAN; 05969000 + IF NEXT ! LPAREN THEN 05970000 + IF PARMSREQ THEN FLOG(106) ELSE ELSE 05971000 + BEGIN 05972000 + LOOP: 05973000 + SCAN; 05974000 + IF NEXT = ID THEN PARMLINK[PARMS ~ PARMS+1] ~ FNEXT ELSE 05975000 + IF NEXT=STAR AND CLASS!FUNID THEN PARMLINK[PARMS~PARMS+1]~0ELSE05976000 + FLOG(107); 05977000 + IF XREF THEN ENTERX(NAME,IF NEXT = STAR THEN 0 ELSE 05978000 + 0&GET(FNEXT)[15:15:9]); 05979000 + SCAN; 05980000 + IF NEXT = COMMA THEN GO TO LOOP; 05981000 + IF NEXT ! RPAREN THEN FLOG(108); 05982000 + SCAN; 05983000 + END; 05984000 + IF NOT ERRORTOG THEN DECLAREPARMS(FNEW); 05985000 + XIT: 05986000 +IF DEBUGTOG THEN FLAGROUTINE(" FORM","ALPP ",FALSE) ; 05987000 +END FORMALPP; 05988000 + 05989000 +PROCEDURE ENDS; FORWARD; 05990000 + 05991000 +PROCEDURE FUNCTION ; 05992000 +BEGIN 05993000 + REAL A,B,C,I; LABEL FOUND ; 05994000 + IF SPLINK NEQ 0 THEN BEGIN FLAG(5); ENDS; SEGMENTSTART; END; 05995000 + LABL ~ BLANKS; 05996000 + FORMALPP(TRUE, FUNID); 05997000 + GETALL(FNEW, INFA, INFB, INFC); 05998000 + B~NUMINTM1 ; 05999000 + WHILE A+1SUPERMAXCOM THEN 06078000 + BEGIN ROOT~0; FATAL(124) END 06079000 + ELSE ROOT~NEXTCOM ; 06080000 + PUTC(ROOT,0&HEADER[TOCLASS]&1[TOCE]&ROOT[TOADDR]) ; 06081000 + BAPC(Z); 06082000 + END ELSE 06083000 + BEGIN 06084000 + ROOT ~ T.ADINFO; 06085000 + COM[(T~GETC(ROOT).LASTC).IR,T.IC].LINK~NEXTCOM+1 ; 06086000 + IF COM[PWROOT]<0 THEN FLAG(2) ; 06087000 + END; 06088000 + DIMENSION; 06089000 + BAPC(0&ENDCOM[TOCLASS]) ; 06090000 + COM[PWROOT].LASTC~NEXTCOM ; 06091000 + PUT(T~GETC(ROOT+1)+2,GET(T)&ROOT[TOADINFO]) ; 06092000 + IF NEXT ! SEMI THEN GO TO LOOP; 06093000 +END COMMON; 06094000 +PROCEDURE ENDS; 06095000 +BEGIN 06096000 + IF SPLINK=0 THEN FLAG(184) ELSE %112-06097000 + BEGIN %112-06098000 + EODS~FALSE ; 06099000 + IF LOGIFTOG THEN FLAG(101); 06100000 + LABL ~ BLANKS; 06101000 + IF SPLINK < 0 THEN EMITO(XIT) ELSE EMITPAIR(0, KOM); 06102000 + SEGMENT((ADR+4) DIV 4, NSEG, TRUE, EDOC); 06103000 + END; %112-06104000 +END ENDS; 06105000 +PROCEDURE ENTRY; 06106000 +BEGIN 06107000 + REAL SP; 06108000 + IF SPLINK = 0 THEN FLAG(111) ELSE 06109000 + IF SPLINK = 1 THEN BEGIN ELX ~ 0; FLAG(4) END; 06110000 + LABL ~ BLANKS; 06111000 + ADJUST ; 06112000 + SP ~ GET(SPLINK); 06113000 + FORMALPP( (T~SP.CLASS) = FUNID, T); 06114000 + GETALL(FNEW, INFA, INFB, INFC); 06115000 + IF INFA.CLASS = FUNID THEN 06116000 + PUT(FNEW, INFA & 1[TOTYPE] & (SP.SUBCLASS)[TOSUBCL]); 06117000 + PUT(FNEW+2, INFC & (ADR+1)[TOBASE]); 06118000 +END ENTRY; 06119000 +PROCEDURE EQUIVALENCE; 06120000 +COMMENT THIS PROCEDURE MAKES THE COM ENTRY FOR EQUIV ITEMS AND SETS 06121000 + THE EQ BIT IN BOTH THE COM AND INFO TABLES AND LINKS 06122000 + THE HEADS OF CHAINS; 06123000 +BEGIN 06124000 + REAL P, Q, R, S; 06125000 + BOOLEAN FIRST,PCOMM; 06126000 + LABEL XIT; 06127000 + IF LOGIFTOG THEN FLAG(101); 06128000 + LABL ~ BLANKS; 06129000 + DO 06130000 + BEGIN 06131000 + FIRST ~ FALSE; 06132000 + SCAN; 06133000 + IF NEXT ! LPAREN THEN BEGIN FLOG(106); GO TO XIT END; 06134000 + IF NEXTCOM~NEXTCOM+1>SUPERMAXCOM THEN 06135000 + BEGIN ROOT~0; FATAL(124) END 06136000 + ELSE ROOT~NEXTCOM ; 06137000 + PUTC(ROOT,0&HEADER[TOCLASS]&ROOT[TOADDR]) ; 06138000 + BAPC(0); Q~0 ; 06139000 + DO 06140000 + BEGIN 06141000 + SCAN; 06142000 + IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; 06143000 + IF XREF THEN ENTERX(NAME,0&GET(FNEXT)[15:15:9]); 06144000 + FX1 ~ FNEXT; 06145000 + LENGTH ~ 0; 06146000 + SCAN; 06147000 + IF NEXT = LPAREN THEN 06148000 + BEGIN 06149000 + IF GET(FX1).CLASS ! ARRAYID THEN 06150000 + BEGIN XTA ~ GET(FX1+1); FLOG(112) END; 06151000 + R ~ 0; P ~ 1; 06152000 + S ~ GET(FX1+2).ADINFO; 06153000 + DO 06154000 + BEGIN 06155000 + SCAN; 06156000 + IF NEXT ! NUM OR NUMTYPE ! INTYPE THEN FLAG(113); 06157000 + LENGTH ~ LENGTH + P|(FNEXT-1); 06158000 + P ~ P|EXTRAINFO[(S+R).IR,(S+R).IC] ; 06159000 + R ~ R-1; 06160000 + SCAN; 06161000 + END UNTIL NEXT ! COMMA; 06162000 + IF NEXT ! RPAREN THEN BEGIN FLOG(108); GO TO XIT END; 06163000 + IF R!-1 THEN IF R~R+GET(FX1+2).NEXTRA!0 THEN 06164000 + BEGIN XTA~GET(FX1+1); FLAG(IF R>0 THEN 23 ELSE 24) END ; 06165000 + SCAN; 06166000 + END; 06167000 + IF (INFA~GET(FX1)) < 0 THEN 6168000 + BEGIN XTA ~ GET(FX1+1); FLAG(39) END ELSE 6169000 + BEGIN 6170000 + IF INFA.SUBCLASS > LOGTYPE THEN LENGTH ~ 2|LENGTH ; 06171000 + BAPC(INFA&FX1[TOLINK]&LENGTH[TORELADD]&1[TOEQ]&ROOT[TOLASTC]); 06172000 + IF(PCOMM~BOOLEAN(INFA.CE)) OR BOOLEAN(INFA.EQ) THEN 06173000 + BEGIN 06174000 + IF FIRST AND PCOMM THEN BEGIN XTA~GET(FX1+1); FLAG(2) END 06175000 + ELSE IF NOT FIRST THEN FIRST ~ PCOMM; 06176000 + PUT(FX1,INFA & 1[TOEQ]); 06177000 + COM[NEXTCOM.IR,NEXTCOM.IC].LASTC ~ A ~ INFA.ADDR; 06178000 + B~GETC(ROOT).ADDR ; 06179000 + SETLINK(A); 06180000 + IF NOT RINGCHECK THEN 06181000 + BEGIN 06182000 + COM[PWROOT].ADDR~GETC(A).ADDR ; 06183000 + PUTC(A,GETC(A)&B[TOADDR]&7[TOSUBCL]) ; 06184000 + END 06185000 + END ELSE 06186000 + PUT(FX1,INFA & 1[TOEQ] & ROOT[TOADDR]); 06187000 + IF LENGTH > Q THEN Q ~ LENGTH; 06188000 + IF BOOLEAN(INFA.FORMAL) THEN 06189000 + BEGIN XTA ~ GET(FX1+1); FLAG(11) END; 06190000 + END; 06191000 + END UNTIL NEXT ! COMMA; 06192000 + IF NEXT ! RPAREN THEN BEGIN FLOG(108); GO TO XIT END; 06193000 + SCAN; 06194000 + PUTC(ROOT+1,Q); 06195000 + BAPC(0&ENDCOM[TOCLASS]) ; 06196000 + COM[PWROOT].LASTC~NEXTCOM ; 06197000 + END UNTIL NEXT ! COMMA; 06198000 + XIT: 06199000 +END EQUIVALENCE; 06200000 +PROCEDURE EXTERNAL; 06201000 +BEGIN 06202000 + IF SPLINK < 0 THEN FLAG( 12); 06203000 + IF LOGIFTOG THEN FLAG(101); 06204000 + LABL ~ BLANKS; 06205000 + DO 06206000 + BEGIN 06207000 + SCAN; 06208000 + IF NEXT ! ID THEN FLOG(105) ELSE 06209000 + BEGIN T ~ NEED(NAME,EXTID); 06210000 + IF XREF THEN ENTERX(NAME,0&GET(T)[15:15:9]); 06211000 + SCAN; 06212000 + END; 06213000 + END UNTIL NEXT ! COMMA; 06214000 +END EXTERNAL; 06215000 +PROCEDURE CHAIN; 06216000 +BEGIN 06217000 + LABEL AGN, XIT; 06218000 + REAL T1; 06219000 + DEFINE FLG(FLG1) = BEGIN FLOG(FLG1); GO TO XIT END#; 06220000 + EXECUTABLE; 06221000 + SCAN; 06222000 + T1 ~ 2; 06223000 + IF FALSE THEN 06224000 + AGN: IF GLOBALNEXT ! COMMA THEN FLG(28); 06225000 + SCAN; 06226000 + IF EXPR(TRUE) > REALTYPE THEN FLG(102); 06227000 + IF (T1 ~ T1 - 1) ! 0 THEN GO TO AGN; 06228000 + IF GLOBALNEXT ! RPAREN THEN FLG(3); 06229000 + EMITPAIR(37,KOM); 06230000 + SCAN; 06231000 + IF GLOBALNEXT ! SEMI THEN FLOG(117); 06232000 + XIT: WHILE GLOBALNEXT ! SEMI DO SCAN; 06233000 +END CHAIN; 06234000 +PROCEDURE GOTOS; 06235000 +BEGIN LABEL XIT; 06236000 + REAL ASSIGNEDID; 06237000 + EODS~TRUE ; 06238000 + EXECUTABLE; 06239000 + SCAN; 06240000 + IF NEXT = NUM THEN 06241000 + BEGIN 06242000 + LABELBRANCH(NAME, FALSE); 06243000 + SCAN; 06244000 + GO TO XIT; 06245000 + END; 06246000 + IF NEXT = ID THEN 06247000 + BEGIN 06248000 + ASSIGNEDID ~ FNEXT; 06249000 + IF XREF THEN ENTERX(XTA,0&GET(FNEXT)[15:15:9]); 06250000 + SCAN; 06251000 + IF NEXT ! COMMA THEN FLOG(114); 06252000 + SCAN; 06253000 + IF NEXT ! LPAREN THEN FLOG(106); 06254000 + DO 06255000 + BEGIN 06256000 + SCAN; 06257000 + IF NEXT ! NUM THEN FLOG(109); 06258000 + EMITV(ASSIGNEDID); 06259000 + EMITNUM(FNEXT); 06260000 + EMITO(NEQL); 06261000 + LABELBRANCH(NAME, TRUE); 06262000 + SCAN; 06263000 + END UNTIL NEXT ! COMMA; 06264000 + IF NEXT ! RPAREN THEN FLOG(108); 06265000 + SCAN; 06266000 + EMITPAIR(1, SSN); % CAUSE INVALID INDEX TERMINATION 06267000 + EMITDESCLIT(10); 06268000 + GO TO XIT; 06269000 + END; 06270000 + IF NEXT ! LPAREN THEN FLOG(106); 06271000 + P ~ 0; 06272000 + DO 06273000 + BEGIN 06274000 + SCAN; 06275000 + IF NEXT ! NUM THEN BEGIN FLOG(109); GO TO XIT END; 06276000 + LSTT[P~P+1] ~ NAME; 06277000 + SCAN; 06278000 + END UNTIL NEXT ! COMMA; 06279000 + IF NEXT ! RPAREN THEN BEGIN FLOG(108); GO TO XIT END; 06280000 + SCAN; 06281000 + IF NEXT ! COMMA THEN BEGIN FLOG(114); GO TO XIT END; 06282000 + SCAN; 06283000 + IT ~ P+1; % DONT LET EXPR WIPE OUT LSTT 06284000 + IF EXPR(TRUE) > REALTYPE THEN FLOG(102); 06285000 + EMITPAIR(JUNK, ISN); 06286000 + EMITPAIR(1,LESS); 06287000 + EMITOPDCLIT(JUNK); 06288000 + EMITO(LOR); 06289000 + EMITOPDCLIT(JUNK); 06290000 + EMITL(3); 06291000 + EMITO(MUL); 06292000 + IF ADR+3|P > 4085 THEN BEGIN ADR~ADR+1; SEGOVF END; 06293000 + EMITO(BFC); 06294000 + EMITPAIR(1, SSN); 06295000 + EMITDESCLIT(10); 06296000 + FOR I ~ 1 STEP 1 UNTIL P DO 06297000 + BEGIN 06298000 + J ~ ADR; LABELBRANCH(LSTT[I], FALSE); 06299000 + IF ADR-J = 2 THEN EMITO(NOP); 06300000 + END; 06301000 + XIT: 06302000 + IT ~ 0; 06303000 +END GOTOS; 06304000 +PROCEDURE IFS; 06305000 +BEGIN REAL TYPE, LOGIFADR, SAVELABL; 06306000 + EODS~TRUE; 06307000 + EXECUTABLE; 06308000 + SCAN; 06309000 + IF NEXT ! LPAREN THEN FLOG(106); 06310000 + SCAN; 06311000 + IF TYPE ~ EXPR(TRUE) = COMPTYPE THEN FLAG(89); 06312000 + IF NEXT ! RPAREN THEN FLOG(108); 06313000 + IF TYPE = LOGTYPE THEN 06314000 + BEGIN 06315000 + EMITB(-1, TRUE); 06316000 + LOGIFADR ~ LAX; 06317000 + LOGIFTOG ~ TRUE; EOSTOG ~ TRUE; 06318000 + SAVELABL ~ LABL; LABL ~ BLANKS; 06319000 + STATEMENT; 06320000 + LABL ~ SAVELABL; 06321000 + LOGIFTOG ~ FALSE; EOSTOG ~ FALSE; 06322000 + FIXB(LOGIFADR); 06323000 + END ELSE 06324000 + BEGIN 06325000 + IF TYPE = DOUBTYPE THEN 06326000 + BEGIN EMITO(XCH); EMITO(DEL) END; 06327000 + SCAN; 06328000 + IF NEXT ! NUM THEN FLOG(109); 06329000 + FX1 ~ FNEXT; NX1 ~ NAME; 06330000 + SCAN; 06331000 + IF NEXT ! COMMA THEN FLOG(114); 06332000 + SCAN; 06333000 + IF NEXT ! NUM THEN FLOG(109); 06334000 + FX2 ~ FNEXT; NX2 ~ NAME; 06335000 + SCAN; 06336000 + IF NEXT ! COMMA THEN FLOG(114); 06337000 + SCAN; 06338000 + IF NEXT ! NUM THEN FLOG(109); 06339000 + FX3 ~ FNEXT; NX3 ~ NAME; 06340000 + SCAN; 06341000 + IF FX2 = FX3 THEN 06342000 + BEGIN 06343000 + EMITPAIR(0,GEQL); 06344000 + LABELBRANCH(NX1, TRUE); 06345000 + LABELBRANCH(NX3, FALSE); 06346000 + IF XREF THEN ENTERX(NX2,0&LABELID[TOCLASS]); 06347000 + END ELSE 06348000 + IF FX1 = FX3 THEN 06349000 + BEGIN 06350000 + EMITPAIR(0,NEQL); 06351000 + LABELBRANCH(NX2, TRUE); 06352000 + LABELBRANCH(NX1, FALSE); 06353000 + IF XREF THEN ENTERX(NX3,0&LABELID[TOCLASS]); 06354000 + END ELSE 06355000 + IF FX1 = FX2 THEN 06356000 + BEGIN 06357000 + EMITPAIR(0,LEQL); 06358000 + LABELBRANCH(NX3, TRUE); 06359000 + LABELBRANCH(NX1, FALSE); 06360000 + IF XREF THEN ENTERX(NX2,0&LABELID[TOCLASS]); 06361000 + END ELSE 06362000 + BEGIN 06363000 + EMITO(DUP); 06364000 + EMITPAIR(0,NEQL); 06365000 + EMITB(-1,TRUE); 06366000 + EMITPAIR(0,LESS); 06367000 + LABELBRANCH(NX3, TRUE); 06368000 + LABELBRANCH(NX1, FALSE); 06369000 + FIXB(LAX); 06370000 + EMITO(DEL); 06371000 + LABELBRANCH(NX2, FALSE); 06372000 + END; 06373000 + END; 06374000 +END IFS; 06375000 +PROCEDURE NAMEL; 06376000 +BEGIN LABEL NIM,XIT,ELMNT,WRAP; 06377000 + IF SPLINK < 0 THEN FLAG(12); 06378000 + IF LOGIFTOG THEN FLAG(101); 06379000 + LABL ~ BLANKS; 06380000 + SCAN; IF NEXT ! SLASH THEN FLOG(110); 06381000 +NIM: SCAN; IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; 06382000 + IF J ~ (INFA ~ GET(LADR2 ~ FNEXT)).CLASS = UNKNOWN THEN 06383000 + PUT(LADR2,INFA&NAMELIST[TOCLASS]) 06384000 + ELSE IF J ! NAMELIST THEN 06385000 + BEGIN XTA ~ GET(LADR2 + 1); 06386000 + FLAG(20); 06387000 + END; 06388000 + LSTT[LSTS ~ LADR1 ~ 0] ~ NAME; 06389000 + IF XREF THEN ENTERX(NAME,0&NAMELIST[TOCLASS]); 06390000 + SCAN; IF NEXT ! SLASH THEN FLOG(110); 06391000 +ELMNT: SCAN; IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; 06392000 + LADR1 ~ LADR1 + 1; 06393000 + IF (T ~ GET(FNEW ~ GETSPACE(FNEXT)).CLASS) > VARID THEN FLAG(48); 06394000 + GETALL(FNEW,INFA,INFB,INFC); 06395000 + IF XREF THEN ENTERX(INFB,0&INFA[15:15:9]); 06396000 + IF LSTS ~ LSTS+1 = LSTMAX THEN BEGIN FLOG(78); GO TO XIT END ELSE 06397000 + LSTT[LSTS] ~ NAME&INFA.CLASNSUB[2:38:10]&0[8:47:1]; 06398000 + IF T = ARRAYID THEN 06399000 + BEGIN J ~ INFC.ADINFO; 06400000 + I ~ INFC.NEXTRA; 06401000 + IF LSTS + I + 1 > LSTMAX THEN 06402000 + BEGIN FLOG(78); GO TO XIT END; 06403000 + LSTT[LSTS ~ LSTS + 1] ~ 0&I[1:42:6] % # DIMENSIONS 06404000 + &INFA.ADDR[7:37:11] % REL ADR 06405000 + &INFC.BASE[18:33:15] % BASE 06406000 + &INFC.SIZE[33:33:15]; % SIZE 06407000 + FOR T ~ J STEP -1 UNTIL J - I + 1 DO 06408000 + LSTT[LSTS ~ LSTS + 1] ~ EXTRAINFO[T.IR,T.IC]; 06409000 + END ELSE BEGIN LSTT[LSTS~LSTS+1]~0&(INFA.ADDR)[7:37:11]; 06410000 + IF BOOLEAN(INFA.CE) THEN LSTT[LSTS]~LSTT[LSTS]&INFC.BASE[18:33:15]06411000 + &INFC.SIZE[33:33:15] END; 06412000 + SCAN; IF NEXT = COMMA THEN GO TO ELMNT; 06413000 + IF NEXT ! SEMI AND NEXT ! SLASH THEN FLOG(115); 06414000 + LSTT[LSTS + 1] ~ 0; 06415000 + LSTT[0].[2:10] ~ LADR1; 06416000 + PRTSAVER(LADR2,LSTS + 2,LSTT); 06417000 + IF NEXT ! SEMI THEN GO TO NIM; 06418000 +XIT: 06419000 +END NAMEL; 06420000 +PROCEDURE PAUSE; 06421000 +IF DCINPUT THEN BEGIN XTA~"PAUSE "; FLOG(151) END ELSE 06422000 +BEGIN 06423000 + EODS~TRUE ; 06424000 + IF TSSEDITOG THEN TSSED("PAUSE ",2) ; 06425000 + EXECUTABLE; 06426000 + SCAN; 06427000 + IF NEXT = SEMI THEN EMITL(0) ELSE 06428000 + IF NEXT = NUM THEN 06429000 + BEGIN 06430000 + EMITNUM(NAME); 06431000 + SCAN; 06432000 + END; 06433000 + EMITPAIR(33, KOM); 06434000 + EMITO(DEL); 06435000 +END PAUSE; 06436000 +PROCEDURE TYPIT(TYP,TMPNXT); VALUE TYP; REAL TYP,TMPNXT ; 06437000 + BEGIN 06438000 + TYPE~TYP; SCAN ; 06439000 + IF NEXT=16 THEN BEGIN TMPNXT~16; FUNCTION END ELSE DIMENSION ; 06440000 + END OF TYPIT ; 06441000 +DEFINE COMPLEX =TYPIT(COMPTYPE,TEMPNEXT) #, 06442000 + LOGICAL =TYPIT(LOGTYPE ,TEMPNEXT) #, 06443000 + DOUBLEPRECISION =TYPIT(DOUBTYPE,TEMPNEXT) #, 06444000 + INTEGERS =TYPIT(INTYPE ,TEMPNEXT) #, 06445000 + REALS =TYPIT(REALTYPE,TEMPNEXT) #; 06446000 +PROCEDURE STOP; 06447000 +BEGIN 06448000 + RETURNFOUND ~ TRUE; 06449000 + EODS~TRUE; 06450000 + EXECUTABLE; 06451000 + COMMENT INITIAL SCAN ALREADY DONE; 06452000 + EMITL(1); 06453000 + EMITPAIR(16,STD); 06454000 + EMITPAIR(10, KOM); 06455000 + EMITPAIR(5, KOM); 06456000 + WHILE NEXT ! SEMI DO SCAN; 06457000 +END STOP; 06458000 +PROCEDURE RETURN; 06459000 +BEGIN LABEL EXIT; 06460000 + REAL T, XITCODE; 06461000 + RETURNFOUND ~ TRUE; 06462000 + EODS~TRUE ; 06463000 + EXECUTABLE; 06464000 + SCAN; 06465000 + IF SPLINK=0 OR SPLINK=1 THEN 06466000 + BEGIN XTA~"RETURN"; FLOG(153); GO EXIT END ; 06467000 + IF NEXT = SEMI THEN 06468000 + BEGIN 06469000 + IF (T ~ GET(SPLINK)).CLASS = FUNID THEN 06470000 + BEGIN 06471000 + EMITV(FUNVAR); 06472000 + IF T.SUBCLASS > LOGTYPE THEN EMITPAIR(JUNK, STD); 06473000 + XITCODE ~ RTN; 06474000 + END ELSE XITCODE ~ XIT; 06475000 + IF ADR } 4077 THEN 06476000 + BEGIN ADR ~ ADR+1; SEGOVF END; 06477000 + EMITOPDCLIT(1538); % F+2 06478000 + EMITPAIR(3, BFC); 06479000 + EMITPAIR(10, KOM); 06480000 + EMITO(XITCODE); 06481000 + EMITOPDCLIT(16); 06482000 + EMITPAIR(1, SUB); 06483000 + EMITPAIR(16, STD); 06484000 + EMITO(XITCODE); 06485000 + GO TO EXIT; 06486000 + END; 06487000 + IF LABELMOM = 0 THEN FLOG(145); 06488000 + IF EXPR(TRUE) > REALTYPE THEN FLAG(102); 06489000 + IF EXPRESULT = NUMCLASS THEN 06490000 + BEGIN IF XREF THEN ENTERX(EXPVALUE,0&LABELID[TOCLASS]); 06491000 + ADR ~ ADR-1;EMITL(EXPVALUE-1) 06492000 + END ELSE 06493000 + EMITPAIR(1, SUB); 06494000 + EMITOPDCLIT(LABELMOM); 06495000 + EMITO(MKS); 06496000 + EMITL(9); 06497000 + EMITOPDCLIT(5); 06498000 + EXIT: 06499000 +END RETURN; 06500000 +PROCEDURE IMPLICIT ; 06501000 + BEGIN 06502000 + REAL R1,R2,R3,R4 ; 06503000 + LABEL R,A,X,L ; 06504000 + IF NOT(LASTNEXT=42 OR LASTNEXT=1000 OR LASTNEXT=30 %110-06505000 + OR LASTNEXT=16 OR LASTNEXT = 11) %110-06506000 + THEN BEGIN FLOG(181); FILETOG~TRUE; GO X END ; 06507000 +R: EOSTOG~ERRORTOG~TRUE; FILETOG~FALSE ; 06508000 + MOVEW(ACCUM[3],ACCUM[2],0,3); SCAN; ERRORTOG~FALSE; FILETOG~TRUE ; 06509000 + IF R1~IF R2~NEXT=18 THEN INTID ELSE IF R3=26 THEN REALID ELSE 0& 06510000 + (IF R3=10 THEN DOUBTYPE ELSE IF R3=19 THEN LOGTYPE ELSE IF R3=06511000 + 6 THEN COMPTYPE ELSE 0)[TOSUBCL]=0 THEN 06512000 + BEGIN FLOG(182); GO X END ; 06513000 + SCN~2; SCAN ; 06514000 + IF NEXT = STAR THEN IF R3!10 THEN 06515000 + BEGIN SCAN ; 06516000 + IF NEXT=NUM AND NUMTYPE=INTYPE THEN 06517000 + BEGIN 06518000 + IF FNEXT=4 THEN BEGIN IF R3=6 THEN FLAG(176); GO L END ; 06519000 + IF FNEXT=8 THEN 06520000 + BEGIN 06521000 + IF R3=26 THEN R1~0&DOUBTYPE[TOSUBCL] 06522000 + ELSE IF R3!6 THEN FLAG(177) ; 06523000 + GO L; 06524000 + END ; 06525000 + END ; 06526000 + FLAG(IF R3=26 THEN 178 ELSE 177-REAL(R3=6)) ; 06527000 +L: NCR~REAL(NCR.[30:3]!0)+3"677777"+NCR; SCN~1; SCAN ; 06528000 + END ; 06529000 + IF NEXT!LPAREN THEN BEGIN FLOG(106); GO X END ; 06530000 +A: SCAN; R4~ERRORCT ; 06531000 + IF R2~NAME.[12:6]<17 OR (R2>25 AND R2<33) OR (R2>41 AND R2<50) 06532000 + OR R2>57 OR NAME.[18:30]!" " THEN FLAG(179) ; 06533000 + SCAN ; 06534000 + IF NEXT!MINUS THEN 06535000 + BEGIN IF ERRORCT=R4 THEN TIPE[IF R2!"0" THEN R2 ELSE 12]~R1 END06536000 + ELSE BEGIN 06537000 + SCAN ; 06538000 + IF R3~NAME.[12:6]<17 OR (R3>25 AND R3<33) OR (R3>41 AND R3<50) 06539000 + OR R3>57 OR NAME.[18:30]!" " THEN FLAG(179) ; 06540000 + IF R3 LEQ R2 THEN FLAG(180) ; 06541000 + IF ERRORCT=R4 THEN FOR R2~R2 STEP 1 UNTIL R3 DO 06542000 + BEGIN 06543000 + IF R2>25 AND R2<33 THEN R2~33 ELSE IF R2>41 AND R2<50 06544000 + THEN R2~50 ; 06545000 + TIPE[IF R2!"0" THEN R2 ELSE 12]~R1 ; 06546000 + END ; 06547000 + SCAN ; 06548000 + END ; 06549000 + IF NEXT=COMMA THEN GO A ; 06550000 + IF NEXT!RPAREN THEN BEGIN FLOG(108); GO X END ; 06551000 + SCAN; IF NEXT=COMMA THEN GO R ; 06552000 + IF NEXT!SEMI THEN BEGIN FLOG(117); GO X END ; 06553000 + IF SPLINK > 1 THEN 06554000 + BEGIN 06555000 + IF BOOLEAN(TYPE.[2:1]) THEN IF GET(SPLINK).CLASS=FUNID THEN 06556000 + BEGIN 06557000 + INFO[SPLINK.IR,SPLINK.IC].SUBCLASS~R3~TIPE[IF R3~GET( 06558000 + SPLINK+1).[12:6]!"0" THEN R3 ELSE 12].SUBCLASS ; 06559000 + INFO[FUNVAR.IR,FUNVAR.IC].SUBCLASS~R3 ; 06560000 + END ; 06561000 + IF R1~GET(SPLINK+2)<0 THEN 06562000 + FOR R2~R1.NEXTRA-1+R1~R1.ADINFO STEP -1 UNTIL R1 DO 06563000 + IF R3~PARMLINK[R2-R1+1]!0 THEN 06564000 + BEGIN 06565000 + EXTRAINFO[R2.IR,R2.IC].SUBCLASS~R4~TIPE[IF R4~ 06566000 + GET(R3+1).[12:6]!"0" THEN R4 ELSE 12] 06567000 + .SUBCLASS ; 06568000 + INFO[R3.IR,R3.IC].SUBCLASS~R4 ; 06569000 + END ; 06570000 + END ; 06571000 +X: WHILE NEXT!SEMI DO SCAN; FILETOG~FALSE ; 06572000 + END OF IMPLICIT ; 06573000 + 06574000 +PROCEDURE SUBROUTINE; 06575000 +BEGIN 06576000 + IF SPLINK NEQ 0 THEN BEGIN FLAG(5); ENDS; SEGMENTSTART; END; 06577000 + LABL ~ BLANKS; 06578000 + FORMALPP(FALSE, SUBRID); 06579000 + SPLINK ~ FNEW; 06580000 +END SUBROUTINE; 06581000 +PROCEDURE MEMHANDLER(N); VALUE N; REAL N ; 06582000 + BEGIN 06583000 + REAL A ; 06584000 + LABEL L1,L2,L3,XIT ; 06585000 + IF DEBUGTOG THEN FLAGROUTINE(" MEMHA","NDLER ",TRUE) ; 06586000 + IF N LEQ 2 THEN 06587000 + BEGIN % FIXED=1, VARYING=2. 06588000 + N~IF N=1 THEN 6 ELSE 0 ; 06589000 +L1: SCAN; 06590000 + IF NEXT!ID THEN BEGIN FLOG(105); GO XIT END ; 06591000 + IF (A~GET(GETSPACE(FNEXT))).CLASS!ARRAYID THEN 06592000 + BEGIN FLOG(35); GO XIT END ; 06593000 + IF XREF THEN ENTERX(XTA,0&A[15:15:9]) ; 06594000 + IF BOOLEAN(A.EQ) OR BOOLEAN(A.FORMAL) THEN FLAG(169) 06595000 + ELSE BEGIN 06596000 + EMITO(MKS); EMITPAIR(A.ADDR,LOD); EMITL(N) ; 06597000 + EMITV(NEED(".MEMHR",INTRFUNID)) ; 06598000 + END ; 06599000 + SCAN; IF NEXT=COMMA THEN GO L1 ; 06600000 + END 06601000 + ELSE IF N=3 THEN 06602000 + BEGIN % AUXMEMED FUNCTION OR SUBROUTINE. 06603000 + SCAN ; 06604000 + IF NEXT!ID THEN BEGIN FLOG(105); GO XIT END ; 06605000 + IF GET(FNEXT+1)!GET(SPLINK+1) THEN 06606000 + BEGIN FLOG(170); GO XIT END ; 06607000 + PUT(SPLINK,GET(SPLINK)&1[TOADJ]) ; 06608000 + IF XREF THEN ENTERX(XTA,0&GET(FNEXT)[15:15:9]); SCAN ; 06609000 + END 06610000 + ELSE BEGIN % RELEASE. 06611000 +L2: SCAN ; 06612000 + IF NEXT!ID THEN BEGIN FLOG(105); GO XIT END ; 06613000 + IF (A~GET(GETSPACE(FNEXT))).CLASS=ARRAYID THEN 06614000 + BEGIN 06615000 + IF BOOLEAN(A.EQ) OR BOOLEAN(A.FORMAL) THEN FLAG(169) 06616000 + ELSE BEGIN 06617000 + EMITO(MKS); EMITPAIR(A.ADDR,LOD) ; 06618000 + EMITPAIR(1,SSN) ; 06619000 + EMITV(NEED(".MEMHR",INTRFUNID)) ; 06620000 + END ; 06621000 +L3: IF XREF THEN ENTERX(XTA,0&A[15:15:9]) ; 06622000 + END 06623000 + ELSE IF A.CLASS}BLOCKID OR A.CLASS{LABELID THEN 06624000 + BEGIN FLOG(171); GO XIT END 06625000 + ELSE BEGIN 06626000 + EMITPAIR(A.ADDR,LOD); EMITPAIR(38,KOM) ; 06627000 + EMITO(DEL); GO L3 ; 06628000 + END ; 06629000 + SCAN; IF NEXT=COMMA THEN GO L2 ; 06630000 + END ; 06631000 +XIT:IF DEBUGTOG THEN FLAGROUTINE(" MEMHA","NDLER ",FALSE) ; 06632000 + END OF MEMHANDLER ; 06633000 +PROCEDURE STATEMENT; 06634000 +BEGIN LABEL DOL1, XIT; 06635000 + REAL TEMPNEXT ; 06636000 + BOOLEAN ENDTOG; %112-06637000 + DO SCAN UNTIL NEXT ! SEMI; 06638000 + IF NEXT=ID THEN ASSIGNMENT ELSE IF NEXT LEQ RSH1 THEN 06639000 + CASE(TEMPNEXT~NEXT) OF 06640000 + BEGIN 06641000 + FLOG(16); 06642000 + ASSIGN; 06643000 + IOCOMMAND(4); %BACKSPACE 06644000 + BLOCKDATA; 06645000 + CALL; 06646000 + COMMON; 06647000 + COMPLEX; 06648000 + BEGIN EXECUTABLE; SCAN END; % CONTINUE 06649000 + IOCOMMAND(7); % DATA 06650000 + BEGIN SCAN; TYPE ~ -1; DIMENSION END; 06651000 + DOUBLEPRECISION; 06652000 + BEGIN ENDS; ENDTOG:=TRUE; SCAN END; %112-06653000 + FILECONTROL(1); %ENDFILE 06654000 + ENTRY; 06655000 + EQUIVALENCE; 06656000 + EXTERNAL; 06657000 + BEGIN TYPE ~ -1; FUNCTION END; 06658000 + GOTOS; 06659000 + INTEGERS; 06660000 + LOGICAL; 06661000 + NAMEL; 06662000 + PAUSE; 06663000 + IOCOMMAND(2); %PRINT 06664000 + ; 06665000 + IOCOMMAND(3); %PUNCH 06666000 + IOCOMMAND(0); %READ 06667000 + REALS; 06668000 + RETURN; 06669000 + FILECONTROL(0); %REWIND 06670000 + BEGIN SCAN; STOP END; 06671000 + SUBROUTINE; 06672000 + IOCOMMAND(1); %WRITE 06673000 + FILECONTROL(7); %CLOSE 06674000 + FILECONTROL(6); %LOCK 06675000 + FILECONTROL(4); %PURGE 06676000 + IFS; 06677000 + FORMATER; 06678000 + CHAIN; 06679000 + MEMHANDLER(1) ; %FIXED 06680000 + MEMHANDLER(2) ; %VARYING 06681000 + MEMHANDLER(3) ; %AUXMEM FOR SUBPROGRAMS 06682000 + MEMHANDLER(4) ; %RELEASE 06683000 + IMPLICIT ; 06684000 + END ELSE IF NEXT=EOF THEN GO XIT ELSE BEGIN NEXT~0; FLOG(16) END ; 06685000 + LASTNEXT.[33:15]~TEMPNEXT ; 06686000 + IF NOT ENDTOG THEN IF SPLINK=0 THEN SPLINK:=1; %112-06687000 + ENDTOG:=FALSE; %112-06688000 + IF LABL ! BLANKS THEN 06689000 + BEGIN 06690000 + IF DT ! 0 THEN 06691000 + BEGIN 06692000 + DOL1: IF LABL = DOLAB[TEST ~ DT] THEN 06693000 + BEGIN 06694000 + EMITB(DOTEST[DT], FALSE); 06695000 + FIXB(DOTEST[DT].ADDR); 06696000 + IF DT ~ DT-1 > 0 THEN GO TO DOL1; 06697000 + END ELSE 06698000 + WHILE TEST ~ TEST-1 > 0 DO 06699000 + IF DOLAB[TEST] = LABL THEN FLAG(14); 06700000 + END; 06701000 + LABL ~ BLANKS; 06702000 + END; 06703000 + IF NEXT ! SEMI THEN 06704000 + BEGIN 06705000 + FLAG(117); 06706000 + DO SCAN UNTIL NEXT=SEMI OR NEXT=EOF ; 06707000 + END; 06708000 + ERRORTOG ~ FALSE; 06709000 + EOSTOG ~ TRUE; 06710000 + XIT: 06711000 +END STATEMENT; 06712000 + 06713000 +BOOLEAN STREAM PROCEDURE FLAGLAST(BUFF,ERR) ; 06714000 + BEGIN 06715000 + LOCAL A; SI~ERR; 8(IF SC!" " THEN JUMP OUT;SI~SI+1;TALLY~TALLY+1);06716000 + A~TALLY; SI~LOC A; SI~SI+7 ; 06717000 + IF SC<"8" THEN 06718000 + BEGIN TALLY~1; FLAGLAST~TALLY ; 06719000 + DI~BUFF;DS~46 LIT"LAST SYNTAX ERROR OCCURRED AT SEQUENCE NUMBER ";06720000 + DS~LIT"""; SI~ERR; DS~8 CHR; DS~LIT"""; 06721000 + DS~32 LIT " "; %510-06722000 + DS~32 LIT " "; %510-06723000 + END 06724000 + END FLAGLAST ; 06725000 +INTEGER PROCEDURE FIELD(X); VALUE X; INTEGER X; 06726000 +FIELD~IF X<10 THEN 1 ELSE IF X<100 THEN 2 ELSE IF X<1000 THEN 3 ELSE IF 06727000 +X<10000 THEN 4 ELSE IF X<100000 THEN 5 ELSE IF X<1000000 THEN 6 ELSE 7; 06728000 +FORMAT EOC1(/ "NUMBER OF SYNTAX ERRORS DETECTED = ",I*,".",X*, 06729000 + "NUMBER OF SEQUENCE ERRORS DETECTED = ",I*,"."), 06730000 + EOC2("PRT SIZE = ",I*,"; TOTAL SEGMENT SIZE = ",I*, 06731000 + " WORDS; DISK SIZE = ",I*," SEGS; NO. PRGM. SEGS = ",I*, 06732000 + "."), 06733000 + EOC3("ESTIMATED CORE STORAGE REQUIREMENT = ",I*," WORDS;", 06734000 + " COMPILATION TIME = ",I*," MIN, ",I*," SECS;", 06735000 + " NO. CARDS = ",I*,"."), 06736000 + EOC4("ESTIMATED CORE STORAGE REQUIREMENT = ",I*," WORDS;" 06737000 + " COMPILATION TIME = ",I*," SECS; NO. CARDS = ",I*,"."), 06738000 + EOC5("NUMBER OF TSS WARNINGS DETECTED = ",I*,".") ; 06739000 +COMMENT MAIN DRIVER FOR FORTRAN COMPILER BEGINS HERE; 06740000 +RTI ~ TIME(1); 06741000 +INITIALIZATION; 06742000 + DO STATEMENT UNTIL NEXT = EOF; 06743000 + IF NOT ENDSEGTOG THEN IF SPLINK NEQ 0 %112-06744000 + THEN BEGIN XTA:=BLANKS; FLAG(5); ENDS END; %112-06745000 + WRAPUP; 06746000 +POSTWRAPUP: 06747000 +IF TIMETOG THEN IF FIRSTCALL THEN DATIME; 06748000 +IF NOT FIRSTCALL THEN 06749000 + BEGIN 06750000 + WRITE(RITE,EOC1,FIELD(ERRORCT),ERRORCT,IF SEQERRCT=0 THEN 99 ELSE 06751000 + 5,FIELD(SEQERRCT-1),SEQERRCT-1) ; 06752000 + IF WARNED AND NOT DCINPUT THEN WRITE(RITE,EOC5,FIELD(WARNCOUNT), 06753000 + WARNCOUNT) ; 06754000 + WRITE(RITE,EOC2,FIELD(PRTS),PRTS,FIELD(TSEGSZ),TSEGSZ,FIELD(DALOC-1),06755000 + DALOC-1,FIELD(NXAVIL),NXAVIL) ; 06756000 + IF C1~(TIME(1)-RTI)/60 > 59 THEN WRITE(RITE,EOC3,FIELD(64|ESTIMATE), 06757000 + 64|ESTIMATE,FIELD(C1 DIV 60),C1 DIV 60,FIELD(C1 MOD 60),C1 MOD 60, 06758000 + FIELD(CARDCOUNT-1),CARDCOUNT-1) ELSE WRITE(RITE,EOC4,FIELD(ESTIMATE 06759000 + |64),ESTIMATE|64,FIELD(C1),C1,FIELD(CARDCOUNT-1),CARDCOUNT-1) ; 06760000 + IF ERRORCT>0 THEN IF FLAGLAST(ERRORBUFF,LASTERR) THEN WRITE(RITE,15, 06761000 + ERRORBUFF[*]) ; 06762000 + END ; 06763000 +END INNER BLOCK; 06764000 +END. 06765000