diff --git a/Mark-XVI/SYMBOL/FORTRAN.alg_m b/Mark-XVI/SYMBOL/FORTRAN.alg_m index 728e00e..e1301a7 100644 --- a/Mark-XVI/SYMBOL/FORTRAN.alg_m +++ b/Mark-XVI/SYMBOL/FORTRAN.alg_m @@ -2740,7 +2740,7 @@ PROCEDURE DATIME; % PRODUCES HEADING LINE FOR LISTING. 02018000 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 + ,".",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 @@ -3661,4581 +3661,4586 @@ BEGIN LABEL LOOP; 02450000 ADVANCE ~ TALLY; 02485000 END ADVANCE; 02486000 BOOLEAN PROCEDURE CONTINUE; 02487000 -BEGIN 02488000 -LABEL LOOP; 02489000 - 02490000 -BOOLEAN STREAM PROCEDURE CONTIN(CD); 02491000 -BEGIN SI~CD; IF SC!"C" THEN IF SC!"$" THEN BEGIN SI~SI+5; IF SC!" " 02492000 -THEN IF SC!"0" THEN BEGIN TALLY~1; CONTIN~TALLY END END END OF CONTIN ;02493000 -BOOLEAN STREAM PROCEDURE COMNT(CD,T); VALUE T; 02494000 -BEGIN LABEL L ; 02495000 - SI ~ CD; IF SC = "C" THEN BEGIN T(SI~SI+1; IF SC="-" THEN TALLY~1 02496000 - ELSE JUMP OUT TO L); TALLY~1; L: END; COMNT~TALLY ; 02497000 -END COMNT; 02498000 -BOOLEAN STREAM PROCEDURE DCCONTIN(CD); 02499000 -BEGIN 02500000 - SI ~ CD; IF SC = "-" THEN TALLY ~ 1; 02501000 - DCCONTIN ~ TALLY; 02502000 -END DCCONTIN; 02503000 -LOOP: IF NOT(CONTINUE ~ 02504000 - IF(DCINPUT AND NOT TSSEDITOG)OR FREEFTOG THEN 02505000 - IF NEXTCARD < 4 THEN DCCONTIN(CB) 02506000 - ELSE IF NEXTCARD = 7 THEN DCCONTIN(DB)ELSE CONTIN(TB) 02507000 - ELSE IF NEXTCARD = 7 THEN CONTIN(DB) 02508000 - ELSE IF NEXTCARD < 4 THEN CONTIN(DB) ELSE 02509000 - CONTIN(TB)) THEN 02510000 - IF(IF NEXTCARD < 4 THEN 02511000 - COMNT(CB,(DCINPUT AND NOT TSSEDITOG) OR FREEFTOG) 02512000 - ELSE IF NEXTCARD = 7 THEN 02513000 - COMNT(CB,(DCINPUT AND NOT TSSEDITOG) OR FREEFTOG) 02514000 - ELSE COMNT(TB,0) AND NEXTCARD ! 6) THEN 02515000 - BEGIN 02516000 - IF READACARD THEN IF LISTOG THEN PRINTCARD; 02517000 - GO TO LOOP; 02518000 - END; 02519000 -END CONTINUE; 02520000 - 02521000 -PROCEDURE SCANX(EOF1, EOF2, EOS1, EOS2, OK1, OK2); 02522000 - VALUE EOF1, EOF2, EOS1, EOS2, OK1, OK2; 02523000 - INTEGER EOF1, EOF2, EOS1, EOS2, OK1, OK2; 02524000 -BEGIN LABEL LOOP, LOOP0 ; 02525000 - LOOP0: 02526000 - EXACCUM[1] ~ BLANKS; 02527000 - ACR ~ ACR1; 02528000 - LOOP: 02529000 - IF ADVANCE(NCR, ACR, CHR1, NCR, ACR) THEN 02530000 - IF CONTINUE THEN 02531000 - IF READACARD THEN 02532000 - BEGIN 02533000 - IF LISTOG THEN PRINTCARD ; 02534000 - IF ACR.[33:15]}EXACCUMSTOP THEN 02535000 - BEGIN XTA~BLANKS; FLOG(175); GO LOOP0 END ; 02536000 - GO LOOP ; 02537000 - END 02538000 - ELSE SCN ~ IF EXACCUM[1] = BLANKS THEN EOF1 ELSE EOF2 02539000 - ELSE SCN ~ IF EXACCUM[1] = BLANKS THEN EOS1 ELSE EOS2 02540000 - ELSE SCN ~ IF EXACCUM[1] = BLANKS THEN OK1 ELSE OK2; 02541000 -END SCANX; 02542000 - 02543000 -DEFINE CHAR = ACCUM[0]#; 02544000 -DEFINE T=SYMBOL#; 02545000 -INTEGER N; 02546000 -BOOLEAN STREAM PROCEDURE CHECKEXP(NCR, NCRV, A); VALUE NCRV; 02547000 -BEGIN 02548000 - SI ~ NCRV; 02549000 - IF SC = "*" THEN 02550000 - BEGIN DI ~ A; DI ~ DI+2; DS ~ 2 LIT "*"; SI ~ SI+1; NCRV ~ SI; 02551000 - TALLY ~ 1; CHECKEXP ~ TALLY; 02552000 - SI ~ LOC NCRV; DI ~ NCR; DS ~ WDS END; 02553000 -END CHECKEXP; 02554000 -PROCEDURE CHECKRESERVED; 02555000 -BEGIN LABEL RESWD, XIT, FOUND1, FOUND2, DONE; 02556000 -BOOLEAN STREAM PROCEDURE COMPLETECHECK(A,B,N); VALUE N ; 02557000 - BEGIN LABEL L ; 02558000 - SI~A; SI~SI-2; DI~B; N(IF SC!DC THEN JUMP OUT TO L); TALLY~1; 02559000 - L: COMPLETECHECK~TALLY ; 02560000 - END OF COMPLETECHECK; 02561000 -STREAM PROCEDURE XFER(FROM, T1, T2, N, M); VALUE FROM, N, M; 02562000 -BEGIN SI ~ FROM; DI ~ T1; DI ~ DI+2; 02563000 - DS ~ M CHR; 02564000 - SI ~ FROM; SI ~ SI+N; 02565000 - DI ~ T2; DI ~ DI+2; 02566000 - DS ~ 6 CHR; 02567000 -END XFER; 02568000 -STREAM PROCEDURE XFERA(FROM, NEXT1, NEXT2); 02569000 - VALUE FROM; 02570000 -BEGIN SI ~ FROM; SI ~ SI+6; 02571000 - DI ~ NEXT1; DI ~ DI+2; 02572000 - 5(IF SC } "0" THEN DS ~ CHR ELSE JUMP OUT); 02573000 - SI ~ SI+2; 02574000 - DI ~ NEXT2; DI ~ DI+2; 02575000 - 6(IF SC = ALPHA THEN DS ~ CHR ELSE JUMP OUT); 02576000 -END XFERA; 02577000 -BOOLEAN STREAM PROCEDURE CHECKFUN(FROM, TOO, N); VALUE FROM, N; 02578000 -BEGIN SI ~ FROM; SI ~ SI +N; 02579000 - IF SC = "0" THEN 02580000 - BEGIN SI ~ SI+1; 02581000 - IF SC = "N" THEN 02582000 - BEGIN SI ~ SI+1; TALLY ~ 1; 02583000 - DI ~ TOO; DI ~ DI+2; 02584000 - DS ~ 6 CHR; 02585000 - END; 02586000 - END; 02587000 - CHECKFUN ~ TALLY; 02588000 -END CHECKFUN; 02589000 -BOOLEAN STREAM PROCEDURE MORETHAN6(P); 02590000 -BEGIN SI ~ P; 02591000 - IF SC ! " " THEN TALLY ~ 1; 02592000 - MORETHAN6 ~ TALLY; 02593000 -END MORETHAN6; 02594000 -INTEGER I; ALPHA ID; 02595000 -INTEGER STOR ; 02596000 - IF ACCUM[1] = " " THEN 02597000 - BEGIN XTA ~ CHAR; FLOG(16); GO TO XIT END; 02598000 - IF CHAR = "= " OR CHAR = "# " THEN GO TO XIT; 02599000 - IF CHAR = "~ " THEN GO TO XIT; 02600000 - IF CHAR ! "( " AND CHAR ! "% " THEN GO TO RESWD; 02601000 - IF MORETHAN6(ACCUM[2]) THEN GO TO RESWD; 02602000 - COMMENT AT THIS POINT WE HAVE ( . 02603000 - THIS MUST BE ONE OF THE FOLLOWING: 02604000 - ASSIGNEMNT STATEMENT WITH SUBSCRIPTED VARIABLE AT THE LEFT. 02605000 - STATEMENT FUNCTION DECLARATION. 02606000 -CALL, REAL, ENTRY, GO TO, READ, WRITE, FORMAT, IF, DATA, CHAIN, PRINT OR02607000 - PUNCH; 02608000 - IF I ~ SEARCH(T) > 0 THEN 02609000 - IF GET(I).CLASS = ARRAYID THEN GO TO XIT; 02610000 - ID ~ T; ID.[36:12] ~ " "; 02611000 - FOR I~0 THRU RSP DO IF RESERVEDWORDSLP[I]=ID THEN IF (IF STOR 02612000 - ~RESLENGTHLP[I]-4<1 THEN TRUE ELSE COMPLETECHECK(ACCUM[2], 02613000 - RESERVEDWORDSLP[I+RSP1],STOR)) THEN GO FOUND1 ; 02614000 - GO TO XIT; 02615000 - FOUND1: 02616000 - NEXT ~ LPGLOBAL[I]; 02617000 - T ~ " "; 02618000 - XFER(ACR0, T, NEXTACC, I~RESLENGTHLP[I], IF I> 6 THEN 6 ELSE I); 02619000 - GO TO DONE; 02620000 - RESWD: 02621000 - COMMENT AT THIS POINT WE KNOW THE MUST BE A SPECIAL WORD 02622000 - TO IDENTIFY THE STATEMENT TYPE; 02623000 - ID ~ T; ID.[36:12] ~ " "; 02624000 - IF T = "ASSIGN" THEN 02625000 - BEGIN 02626000 - NEXTSCN ~ SCN; SCN ~ 14; 02627000 - NEXTACC ~ NEXTACC2 ~ " "; 02628000 - XFERA(ACR0, NEXTACC, NEXTACC2); 02629000 - NEXT ~ 1; 02630000 - GO TO XIT; 02631000 - END; 02632000 - FOR I~1 THRU RSH DO IF RESERVEDWORDS[I]=ID THEN IF (IF STOR~ 02633000 - RESLENGTH[I]-4<1 THEN TRUE ELSE COMPLETECHECK(ACCUM[2],RESERVEDWORDS02634000 - [I+RSH1],IF STOR>8 THEN 8 ELSE STOR)) THEN GO FOUND2 ; 02635000 - XTA ~ T; FLOG(16); GO TO XIT; 02636000 - FOUND2: 02637000 - NEXT ~ I+1; 02638000 - T ~ " "; 02639000 - XFER(ACR0, T, NEXTACC, I~RESLENGTH [I], IF I> 6 THEN 6 ELSE I); 02640000 - DONE: NEXTSCN ~ SCN; 02641000 - SCN ~ 6; 02642000 - IF NEXTACC = "FUNCTI" THEN 02643000 - IF CHECKFUN(ACR0, NEXTACC, I+6) THEN SCN ~ 13; 02644000 - XIT: 02645000 - EOSTOG~FALSE; 02646000 -END CHECKRESERVED; 02647000 - 02648000 -BOOLEAN PROCEDURE CHECKOCTAL; 02649000 -BEGIN 02650000 - INTEGER S, T; LABEL XIT; 02651000 -INTEGER STREAM PROCEDURE COUNT(ACRV,T); VALUE ACRV,T ; 02652000 - BEGIN 02653000 - LOCAL A,B; SI~LOC T; SI~SI+7 ; 02654000 - IF SC="1" THEN BEGIN SI~ACRV;IF SC="0" THEN SI~SI+1 END ELSE SI~ACRV;02655000 - IF SC!" " THEN 02656000 - BEGIN A~SI; 02657000 - 17(IF SC>"7" THEN BEGIN TALLY~17; JUMP OUT END ELSE IF SC < "0" THEN02658000 - BEGIN IF SC!" " THEN TALLY~17; JUMP OUT END; SI~SI+1; 02659000 - TALLY~TALLY+1) ; 02660000 - B~TALLY; SI~LOC B; SI~SI+7 ; 02661000 - IF SC="+" THEN BEGIN SI~A; IF SC>"3" THEN TALLY~17 END; 02662000 - END ; 02663000 - COUNT~TALLY ; 02664000 - END OF COUNT ; 02665000 -ALPHA STREAM PROCEDURE CONV(ACRV, S, T); VALUE ACRV, S, T; 02666000 -BEGIN SI ~ ACRV; IF SC = "0" THEN SI ~ SI+1; 02667000 - DI ~ LOC CONV; SKIP S DB; 02668000 - T(SKIP 3 SB; 3(IF SB THEN DS ~ SET ELSE DS ~ RESET; SKIP 1 SB)); 02669000 -END CONV; 02670000 - IF T~COUNT(ACR0,1) = 0 THEN 02671000 - BEGIN S ~ 1; 02672000 - IF T ~ CHAR ! "+ " AND T ! "& " THEN 02673000 - IF T = "- " THEN S ~ -1 ELSE GO TO XIT; 02674000 - SCANX(4, 4, 3, 3, 10, 10); 02675000 - IF SCN ! 10 THEN GO TO XIT; 02676000 - IF T~COUNT(ACR1,2) = 0 OR T > 16 THEN GO TO XIT ; 02677000 - FNEXT ~ CONV(ACR1, (16-T)|3, T); 02678000 - IF S < 0 THEN FNEXT ~ -FNEXT; 02679000 - END ELSE IF T < 17 THEN FNEXT~CONV(ACR0,(16-T)|3,T) ELSE GO TO XIT ; 02680000 - CHECKOCTAL ~ TRUE; 02681000 - NEXT ~ NUM; 02682000 - NUMTYPE ~ REALTYPE; 02683000 - XIT: 02684000 -END CHECKOCTAL; 02685000 - 02686000 -PROCEDURE HOLLERITH; 02687000 -BEGIN 02688000 - REAL T, COL1, T2, ENDP; 02689000 - LABEL XIT; 02690000 - INTEGER STREAM PROCEDURE STRCNT(S,D,SZ); VALUE S,SZ; 02691000 - BEGIN 02692000 - SI ~ S; DI ~ D;DS ~ 8 LIT "00 "; DI ~ D; 02693000 - DI ~ D; DI ~ DI + 2; DS ~SZ CHR; STRCNT ~ SI; 02694000 - END STRCNT; 02695000 - INTEGER STREAM PROCEDURE RSTORE(S,D,SKP,SZ); 02696000 - VALUE S, SKP, SZ; 02697000 - BEGIN 02698000 - DI ~ D; 02699000 - SI ~ S; DI ~DI + SKP; DS ~ SZ CHR; RSTORE ~ SI; 02700000 - END RSTORE; 02701000 - F1 ~ FNEXT; 02702000 - NUMTYPE ~ STRINGTYPE; 02703000 - T ~ 0 & NCR[30:33:15] & NCR[45:30:3]; 02704000 - COL1 ~ 0 & INITIALNCR[30:33:15]; 02705000 - ENDP ~ COL1 + 72; 02706000 - STRINGSIZE ~ 0; 02707000 - WHILE F1 >0 DO 02708000 - BEGIN 02709000 - T2 ~ IF F1 > 6 THEN 6 ELSE F1; 02710000 - IF STRINGSIZE > MAXSTRING THEN 02711000 - BEGIN FLAG(120); STRINGSIZE ~ 0 END; 02712000 - IF T+T2> ENDP THEN IF DCINPUT OR FREEFTOG THEN 02713000 - BEGIN XTA~BLANKS; FLOG(150); GO TO XIT END 02714000 - ELSE BEGIN 02715000 - IF TSSEDITOG THEN IF NOT DCINPUT THEN TSSED(BLANKS,1) ; 02716000 - NCR ~ STRCNT(NCR, STRINGARRAY[STRINGSIZE], ENDP-T); 02717000 - IF NOT CONTINUE THEN 02718000 - BEGIN FLOG(43); GO TO XIT END; 02719000 - IF READACARD THEN; 02720000 - IF LISTOG THEN PRINTCARD; 02721000 - NCR ~ RSTORE(NCR,STRINGARRAY[STRINGSIZE],ENDP-T+2,T2-(ENDP-T)); 02722000 - STRINGSIZE ~ STRINGSIZE+1; 02723000 - F1 ~ F1 - T2; 02724000 - T ~ COL1 + 6 + T2 - (ENDP - T); 02725000 - END ELSE 02726000 - BEGIN 02727000 - NCR ~ STRCNT(NCR, STRINGARRAY[STRINGSIZE], T2); 02728000 - STRINGSIZE ~ STRINGSIZE +1; 02729000 - T ~ T +T2; 02730000 - F1 ~ F1 - T2; 02731000 - END; 02732000 - END; 02733000 - NUMTYPE ~ STRINGTYPE; 02734000 - SCN ~ 1; 02735000 - XIT: 02736000 -END HOLLERITH; 02737000 -PROCEDURE QUOTESTRING; 02738000 -BEGIN 02739000 - REAL C; 02740000 - LABEL XIT; 02741000 - ALPHA STREAM PROCEDURE STRINGWORD(S,D,SKP,SZ,C); 02742000 - VALUE S,SKP,SZ; 02743000 - BEGIN 02744000 - LABEL QT, XIT; 02745000 - DI ~ D; SI ~ S; 02746000 - DI ~ DI+SKP; DI ~ DI+2; 02747000 - TALLY ~ SKP; 02748000 - SZ( IF SC = """ THEN JUMP OUT TO QT; 02749000 - IF SC = ":" THEN JUMP OUT TO QT; 02750000 - IF SC = "@" THEN JUMP OUT TO QT; 02751000 - IF SC = "]" THEN JUMP OUT TO XIT; 02752000 - DS ~ CHR; TALLY ~ TALLY+1); 02753000 - GO TO XIT; 02754000 - QT: TALLY ~ TALLY+7; SI ~ SI+1; 02755000 - XIT: STRINGWORD ~ SI; S ~ TALLY; 02756000 - SI ~ LOC S; DI ~ C; DS ~ WDS; 02757000 - END STRINGWORD; 02758000 - STRINGSIZE ~ 0; 02759000 - DO 02760000 - BEGIN 02761000 - IF STRINGSIZE > MAXSTRING THEN 02762000 - BEGIN FLAG(120); STRINGSIZE ~ 0 END; 02763000 - STRINGARRAY[STRINGSIZE] ~ BLANKS; 02764000 - NCR ~ STRINGWORD(NCR, STRINGARRAY[STRINGSIZE], 0, 6, C); 02765000 - IF C<6 THEN IF DCINPUT OR FREEFTOG 02766000 - THEN BEGIN XTA~BLANKS; FLOG(150); GO TO XIT END 02767000 - ELSE BEGIN 02768000 - IF TSSEDITOG THEN IF NOT DCINPUT THEN TSSED(BLANKS,1) ; 02769000 - IF NOT CONTINUE THEN 02770000 - BEGIN FLOG(121); GO TO XIT END; 02771000 - IF READACARD THEN; 02772000 - IF LISTOG THEN PRINTCARD; 02773000 - NCR ~ STRINGWORD(NCR, STRINGARRAY[STRINGSIZE ],C,6-C,C); 02774000 - END; 02775000 - STRINGSIZE ~ STRINGSIZE + 1; 02776000 - END UNTIL C } 7; 02777000 - IF C = 7 THEN STRINGSIZE ~ STRINGSIZE-1; 02778000 - FNEXT ~ STRINGSIZE; 02779000 - NEXT ~ NUM; 02780000 - SYMBOL ~ NAME ~ STRINGARRAY[0]; 02781000 - NUMTYPE ~ STRINGTYPE; 02782000 - SCN ~ 1; 02783000 - XIT: 02784000 -END QUOTESTRING; 02785000 - 02786000 -PROCEDURE CHECKPERIOD; 02787000 -BEGIN 02788000 -LABEL FRACTION, XIT, EXPONENT, EXPONENTSIGN; 02789000 -LABEL NUMFINI, FPLP, CHKEXP; 02790000 -ALPHA S, T, I, TS; 02791000 - INTEGER C2; 02792000 -BOOLEAN CON; 02793000 - IF T ~ CHAR ! ". " THEN GO TO CHKEXP; 02794000 -SCANX(4, 9, 3, 8, 10, 11); 02795000 -IF T ~ EXACCUM[1] = " " THEN 02796000 - BEGIN IF NUMTYPE ! DOUBTYPE THEN NUMTYPE ~ REALTYPE; GO TO XIT END; 02797000 -IF T = "E " OR T = "D " THEN GO TO EXPONENTSIGN; 02798000 -IF T.[12:6] { 9 THEN GO TO FRACTION; 02799000 -IF T.[18:6] { 9 THEN 02800000 -BEGIN 02801000 - IF S ~ T.[12:6] ! "E" AND S ! "D" THEN 02802000 - BEGIN XTA ~ T; FLOG(63); GO TO XIT END; 02803000 - EXACCUM[1].[12:6] ~ 0; 02804000 - I ~ 1; GO TO EXPONENT; 02805000 -END; 02806000 -IF EXACCUM[0] ! ". " THEN GO TO XIT; 02807000 -FOR I ~ 0 STEP 1 UNTIL 10 DO 02808000 - IF T = PERIODWORD[I] THEN 02809000 - BEGIN EXACCUM[2] ~ I; SCN ~ 12; GO TO XIT END; 02810000 -GO TO XIT; 02811000 -FRACTION: NEXT ~ NUM; 02812000 -IF NUMTYPE !DOUBTYPE THEN NUMTYPE ~ REALTYPE; XTA ~ ACR1; 02813000 -FPLP: 02814000 -F1 ~ 0; 02815000 -XTA ~ CONVERT(F1,C1,XTA ,TS); 02816000 -C2 ~ C2 + C1; 02817000 -IF (F2 ~ FNEXT|TEN[C1]+F1) { MAX 02818000 - THEN FNEXT ~ F2 02819000 - ELSE BEGIN 02820000 - NUMTYPE ~ DOUBTYPE; 02821000 - CON ~ TRUE; 02822000 - DOUBLE(FNEXT,DBLOW,TEN[C1],TEN[69+C1],|, 02823000 - F1,0,+,~,FNEXT,DBLOW); 02824000 - END; 02825000 -IF TS { 9 THEN GO TO FPLP; 02826000 -F1 ~ 0; 02827000 -IF T ~ EXACCUM[0] ! "E " AND T ! "D " THEN 02828000 -BEGIN IF SCN = 8 THEN SCN ~ 3 ELSE SCN ~ 10; 02829000 - GO TO NUMFINI; 02830000 -END; 02831000 -CHKEXP: FNEXT ~ FNEXT | 1.0; 02832000 -F1 ~ 0; 02833000 -I ~ 1; 02834000 -SCANX(4, 4, 3, 3, 20, 10); 02835000 -IF SCN = 20 THEN 02836000 -EXPONENTSIGN: 02837000 -BEGIN IF S ~ EXACCUM[0] ! "+ " AND S ! "& " THEN 02838000 - IF S = "- " THEN I ~ -1 ELSE 02839000 - BEGIN XTA ~ S; FLOG(63); SCN ~ 10; GO TO XIT END; 02840000 - SCANX(4, 4, 3, 3, 10, 10); 02841000 - END; 02842000 - IF (S ~ EXACCUM[1]).[12:6] > 9 THEN 02843000 - BEGIN XTA ~ IF S ! BLANKS THEN S ELSE T; FLOG(63); GO TO XIT END; 02844000 - EXPONENT: 02845000 - IF NUMTYPE ! DOUBTYPE THEN NUMTYPE ~ REALTYPE; 02846000 -IF T.[12:6] = "D" THEN NUMTYPE ~ DOUBTYPE; 02847000 - IF SCN = 8 THEN SCN ~ 3 ELSE IF SCN = 11 THEN SCN ~ 10; 02848000 - XTA ~ ACR1; 02849000 - XTA ~ CONVERT(F1,C1,XTA ,TS); 02850000 - IF I < 0 THEN F1 ~ -F1; 02851000 - NUMFINI: 02852000 - C1 ~ F1 - C2; 02853000 - IF I ~ (ABS(C1+(FNEXT.[3:6]&FNEXT[1:2:1]))) > 63 OR((ABS(C1) = I OR 02854000 - FNEXT } 5) AND ABS(F1) } 69) 02855000 - THEN BEGIN XTA ~ T; FLOG(87); GO TO XIT; END; 02856000 - IF NUMTYPE ! DOUBTYPE THEN 02857000 - BEGIN 02858000 - IF C1} 0 THEN FNEXT ~ FNEXT | TEN[C1] 02859000 - ELSE FNEXT ~ FNEXT / TEN[-C1]; 02860000 - END ELSE 02861000 - BEGIN 02862000 - IF C1 } 0 02863000 - THEN DOUBLE(FNEXT,DBLOW,TEN[C1],TEN[69+C1],|,~,FNEXT,DBLOW) 02864000 - ELSE DOUBLE(FNEXT,DBLOW,TEN[-C1],TEN[69-C1],/,~,FNEXT,DBLOW); 02865000 - IF CON THEN IF DBLOW.[9:33] = MAX.[9:33] THEN 02866000 - IF FNEXT.[3:6] LSS 14 02867000 - THEN IF BOOLEAN(FNEXT.[2:1]) THEN 02868000 - BEGIN DBLOW ~ 0; FNEXT ~ FNEXT + 1&FNEXT[2:2:7]; END; 02869000 - END; 02870000 - XIT: 02871000 -END CHECKPERIOD; 02872000 - 02873000 -LABEL LOOP0, NUMBER ; 02874000 -LABEL L,XIT; 02875000 -LABEL L1,L2,L3,L4,L5,L6,L7,L8,L9,L10,L11,L12,L13,L14,L15,L16,L17, 02876000 - L18,L19,L20,L21,BK ; 02877000 -SWITCH CASEL~L1,L2,L3,L4,L5,L6,L7,L8,L9,L10,L11,L12,L13,L14,L15, 02878000 - L16,L17,L18,L19,L20,L21 ; 02879000 -LABEL LOOP, CASESTMT; %994-02880000 -LABEL CASE0,CASE1,CASE2,CASE3,CASE4,CASE5,CASE6,CASE7; %994-02881000 -LABEL CASE8,CASE9,CASE10,CASE11,CASE12,CASE13,CASE14; %994-02882000 -PREC~NEXT~FNEXT~REAL(SCANENTER~FALSE) ; 02883000 -CASESTMT: 02884000 -CASE SCN OF 02885000 -BEGIN 02886000 -CASE0: %994-02887000 -GO TO IF LABELR THEN CASE5 ELSE CASE1; 02888000 -CASE1: 02889000 -BEGIN 02890000 - LOOP0: 02891000 - ACR ~ ACR0; 02892000 - ACCUM[1] ~ BLANKS; 02893000 - LOOP: 02894000 - IF ADVANCE(NCR, ACR, CHR0, NCR, ACR) THEN 02895000 - IF CONTINUE THEN 02896000 -% 02897000 - IF READACARD THEN 02898000 - BEGIN 02899000 - IF LISTOG THEN PRINTCARD ; 02900000 - IF ACR.[33:15]}ACCUMSTOP THEN 02901000 - BEGIN XTA~BLANKS; FLOG(175); GO LOOP0 END ; 02902000 - GO LOOP ; 02903000 - END 02904000 - ELSE IF T ~ ACCUM[1] = " " THEN GO TO CASE5 ELSE SCN ~ 4 02905000 - ELSE IF T ~ ACCUM[1] = " " THEN 02906000 - GO TO CASE3 ELSE SCN ~ 3 02907000 - ELSE IF T ~ ACCUM[1] = " " THEN GO TO CASE2 ELSE SCN ~ 2; 02908000 -END; 02909000 -CASE2: 02910000 -BEGIN T ~ CHAR; SCN ~ 1 END; 02911000 -CASE3: 02912000 -BEGIN T ~ "; "; NEXT ~ SEMI; SCN ~ 0; 02913000 - IF EOSTOG THEN IF LOGIFTOG THEN BEGIN LOGIFTOG ~ FALSE; XTA ~ T; 02914000 - FLAG(101); END; 02915000 - GO TO XIT; 02916000 -END; 02917000 -CASE4: %994-02918000 -BEGIN T ~ "; "; NEXT ~ SEMI; SCN ~ 5; GO TO XIT END; 02919000 -CASE5: 02920000 -BEGIN T ~ " "; NEXT ~ EOF; EOSTOG ~ FALSE; GO TO XIT END; 02921000 -CASE6: %994-02922000 -BEGIN T ~ ACCUM[1] ~ NEXTACC; SCN ~ NEXTSCN; 02923000 - IF T = " " THEN GO TO CASESTMT; 02924000 +BEGIN 02487200 +LABEL LOOP; 02487400 +BOOLEAN STREAM PROCEDURE CONTIN(CD); 02487600 +BEGIN SI~CD; IF SC!"C" THEN IF SC!"$" THEN BEGIN SI~SI+5; IF SC!" " 02488000 +THEN IF SC!"0" THEN BEGIN TALLY~1; CONTIN~TALLY END END END OF CONTIN ;02489000 +BOOLEAN STREAM PROCEDURE COMNT(CD,T); VALUE T; 02489200 +BEGIN LABEL L ; 02489400 + SI ~ CD; IF SC = "C" THEN BEGIN T(SI~SI+1; IF SC="-" THEN TALLY~1 02489600 + ELSE JUMP OUT TO L); TALLY~1; L: END; COMNT~TALLY ; 02490000 +END COMNT; 02490200 +BOOLEAN STREAM PROCEDURE DCCONTIN(CD); 02490400 +BEGIN 02490500 + SI ~ CD; IF SC = "-" THEN TALLY ~ 1; 02490600 + DCCONTIN ~ TALLY; 02491000 +END DCCONTIN; 02491200 +LOOP: IF NOT(CONTINUE ~ 02491400 + IF(DCINPUT AND NOT TSSEDITOG)OR FREEFTOG THEN 02491600 + IF NEXTCARD < 4 THEN DCCONTIN(CB) 02491650 + ELSE IF NEXTCARD = 7 THEN DCCONTIN(DB)ELSE CONTIN(TB) 02491700 + ELSE IF NEXTCARD = 7 THEN CONTIN(DB) 02491800 + ELSE IF NEXTCARD < 4 THEN CONTIN(DB) ELSE 02492000 + CONTIN(TB)) THEN 02492200 + IF(IF NEXTCARD < 4 THEN 02492400 + COMNT(CB,(DCINPUT AND NOT TSSEDITOG) OR FREEFTOG) 02492450 + ELSE IF NEXTCARD = 7 THEN 02492500 + COMNT(CB,(DCINPUT AND NOT TSSEDITOG) OR FREEFTOG) 02492550 + ELSE COMNT(TB,0) AND NEXTCARD ! 6) THEN 02492600 + BEGIN 02493000 + IF READACARD THEN IF LISTOG THEN PRINTCARD; 02493200 + GO TO LOOP; 02493400 + END; 02493600 +END CONTINUE; 02494000 +PROCEDURE SCANX(EOF1, EOF2, EOS1, EOS2, OK1, OK2); 02495000 + VALUE EOF1, EOF2, EOS1, EOS2, OK1, OK2; 02496000 + INTEGER EOF1, EOF2, EOS1, EOS2, OK1, OK2; 02497000 +BEGIN LABEL LOOP, LOOP0 ; 02498000 + LOOP0: 02498100 + EXACCUM[1] ~ BLANKS; 02499000 + ACR ~ ACR1; 02500000 + LOOP: 02501000 + IF ADVANCE(NCR, ACR, CHR1, NCR, ACR) THEN 02502000 + IF CONTINUE THEN 02503000 +% 02504000 + IF READACARD THEN 02505000 + BEGIN 02506000 + IF LISTOG THEN PRINTCARD ; 02506010 + IF ACR.[33:15]}EXACCUMSTOP THEN 02506020 + BEGIN XTA~BLANKS; FLOG(175); GO LOOP0 END ; 02506030 + GO LOOP ; 02506040 + END 02506050 + ELSE SCN ~ IF EXACCUM[1] = BLANKS THEN EOF1 ELSE EOF2 02507000 + ELSE SCN ~ IF EXACCUM[1] = BLANKS THEN EOS1 ELSE EOS2 02508000 + ELSE SCN ~ IF EXACCUM[1] = BLANKS THEN OK1 ELSE OK2; 02509000 +END SCANX; 02510000 +DEFINE CHAR = ACCUM[0]#; 02511000 +DEFINE T=SYMBOL#; 02512000 +INTEGER N; 02513000 +BOOLEAN STREAM PROCEDURE CHECKEXP(NCR, NCRV, A); VALUE NCRV; 02514000 +BEGIN 02515000 + SI ~ NCRV; 02516000 + IF SC = "*" THEN 02517000 + BEGIN DI ~ A; DI ~ DI+2; DS ~ 2 LIT "*"; SI ~ SI+1; NCRV ~ SI; 02518000 + TALLY ~ 1; CHECKEXP ~ TALLY; 02519000 + SI ~ LOC NCRV; DI ~ NCR; DS ~ WDS END; 02520000 +END CHECKEXP; 02521000 +PROCEDURE CHECKRESERVED; 02522000 +BEGIN LABEL RESWD, XIT, FOUND1, FOUND2, DONE; 02523000 +BOOLEAN STREAM PROCEDURE COMPLETECHECK(A,B,N); VALUE N ; 02523100 + BEGIN LABEL L ; 02523200 + SI~A; SI~SI-2; DI~B; N(IF SC!DC THEN JUMP OUT TO L); TALLY~1; 02523300 + L: COMPLETECHECK~TALLY ; 02523400 + END OF COMPLETECHECK; 02523500 +STREAM PROCEDURE XFER(FROM, T1, T2, N, M); VALUE FROM, N, M; 02524000 +BEGIN SI ~ FROM; DI ~ T1; DI ~ DI+2; 02525000 + DS ~ M CHR; 02526000 + SI ~ FROM; SI ~ SI+N; 02527000 + DI ~ T2; DI ~ DI+2; 02528000 + DS ~ 6 CHR; 02529000 +END XFER; 02530000 +STREAM PROCEDURE XFERA(FROM, NEXT1, NEXT2); 02531000 + VALUE FROM; 02532000 +BEGIN SI ~ FROM; SI ~ SI+6; 02533000 + DI ~ NEXT1; DI ~ DI+2; 02534000 + 5(IF SC } "0" THEN DS ~ CHR ELSE JUMP OUT); 02535000 + SI ~ SI+2; 02536000 + DI ~ NEXT2; DI ~ DI+2; 02537000 + 6(IF SC = ALPHA THEN DS ~ CHR ELSE JUMP OUT); 02538000 +END XFERA; 02539000 +BOOLEAN STREAM PROCEDURE CHECKFUN(FROM, TOO, N); VALUE FROM, N; 02540000 +BEGIN SI ~ FROM; SI ~ SI +N; 02541000 + IF SC = "0" THEN 02542000 + BEGIN SI ~ SI+1; 02543000 + IF SC = "N" THEN 02544000 + BEGIN SI ~ SI+1; TALLY ~ 1; 02545000 + DI ~ TOO; DI ~ DI+2; 02546000 + DS ~ 6 CHR; 02547000 + END; 02548000 + END; 02549000 + CHECKFUN ~ TALLY; 02550000 +END CHECKFUN; 02551000 +BOOLEAN STREAM PROCEDURE MORETHAN6(P); 02552000 +BEGIN SI ~ P; 02553000 + IF SC ! " " THEN TALLY ~ 1; 02554000 + MORETHAN6 ~ TALLY; 02555000 +END MORETHAN6; 02556000 +INTEGER I; ALPHA ID; 02557000 +INTEGER STOR ; 02557100 + IF ACCUM[1] = " " THEN 02558000 + BEGIN XTA ~ CHAR; FLOG(16); GO TO XIT END; 02559000 + IF CHAR = "= " OR CHAR = "# " THEN GO TO XIT; 02560000 + IF CHAR = "~ " THEN GO TO XIT; 02560100 + IF CHAR ! "( " AND CHAR ! "% " THEN GO TO RESWD; 02561000 + IF MORETHAN6(ACCUM[2]) THEN GO TO RESWD; 02562000 + COMMENT AT THIS POINT WE HAVE ( . 02563000 + THIS MUST BE ONE OF THE FOLLOWING: 02564000 + ASSIGNEMNT STATEMENT WITH SUBSCRIPTED VARIABLE AT THE LEFT. 02565000 + STATEMENT FUNCTION DECLARATION. 02566000 +CALL, REAL, ENTRY, GO TO, READ, WRITE, FORMAT, IF, DATA, CHAIN, PRINT OR02567000 + PUNCH; 02567100 + IF I ~ SEARCH(T) > 0 THEN 02568000 + IF GET(I).CLASS = ARRAYID THEN GO TO XIT; 02569000 + ID ~ T; ID.[36:12] ~ " "; 02570000 + FOR I~0 THRU RSP DO IF RESERVEDWORDSLP[I]=ID THEN IF (IF STOR 02571000 + ~RESLENGTHLP[I]-4<1 THEN TRUE ELSE COMPLETECHECK(ACCUM[2], 02571100 + RESERVEDWORDSLP[I+RSP1],STOR)) THEN GO FOUND1 ; 02572000 + GO TO XIT; 02573000 + FOUND1: 02574000 + NEXT ~ LPGLOBAL[I]; 02575000 + T ~ " "; 02576000 + XFER(ACR0, T, NEXTACC, I~RESLENGTHLP[I], IF I> 6 THEN 6 ELSE I); 02577000 + GO TO DONE; 02578000 + RESWD: 02579000 + COMMENT AT THIS POINT WE KNOW THE MUST BE A SPECIAL WORD 02580000 + TO IDENTIFY THE STATEMENT TYPE; 02581000 + ID ~ T; ID.[36:12] ~ " "; 02582000 + IF T = "ASSIGN" THEN 02583000 + BEGIN 02584000 + NEXTSCN ~ SCN; SCN ~ 14; 02585000 + NEXTACC ~ NEXTACC2 ~ " "; 02586000 + XFERA(ACR0, NEXTACC, NEXTACC2); 02587000 + NEXT ~ 1; 02588000 + GO TO XIT; 02589000 + END; 02590000 + FOR I~1 THRU RSH DO IF RESERVEDWORDS[I]=ID THEN IF (IF STOR~ 02591000 + RESLENGTH[I]-4<1 THEN TRUE ELSE COMPLETECHECK(ACCUM[2],RESERVEDWORDS02591100 + [I+RSH1],IF STOR>8 THEN 8 ELSE STOR)) THEN GO FOUND2 ; 02592000 + XTA ~ T; FLOG(16); GO TO XIT; 02593000 + FOUND2: 02594000 + NEXT ~ I+1; 02695000 + T ~ " "; 02696000 + XFER(ACR0, T, NEXTACC, I~RESLENGTH [I], IF I> 6 THEN 6 ELSE I); 02697000 + DONE: NEXTSCN ~ SCN; 02698000 + SCN ~ 6; 02699000 + IF NEXTACC = "FUNCTI" THEN 02600000 + IF CHECKFUN(ACR0, NEXTACC, I+6) THEN SCN ~ 13; 02601000 + XIT: 02602000 + EOSTOG~FALSE; 02603000 +END CHECKRESERVED; 02604000 +BOOLEAN PROCEDURE CHECKOCTAL; 02605000 +BEGIN 02606000 + INTEGER S, T; LABEL XIT; 02607000 +INTEGER STREAM PROCEDURE COUNT(ACRV,T); VALUE ACRV,T ; 02608000 + BEGIN 02609000 + LOCAL A,B; SI~LOC T; SI~SI+7 ; 02610000 + IF SC="1" THEN BEGIN SI~ACRV;IF SC="0" THEN SI~SI+1 END ELSE SI~ACRV;02611000 + IF SC!" " THEN 02612000 + BEGIN A~SI; 02613000 + 17(IF SC>"7" THEN BEGIN TALLY~17; JUMP OUT END ELSE IF SC < "0" THEN02614000 + BEGIN IF SC!" " THEN TALLY~17; JUMP OUT END; SI~SI+1; 02614010 + TALLY~TALLY+1) ; 02614015 + B~TALLY; SI~LOC B; SI~SI+7 ; 02614020 + IF SC="+" THEN BEGIN SI~A; IF SC>"3" THEN TALLY~17 END; 02614030 + END ; 02614040 + COUNT~TALLY ; 02614050 + END OF COUNT ; 02614060 +ALPHA STREAM PROCEDURE CONV(ACRV, S, T); VALUE ACRV, S, T; 02615000 +BEGIN SI ~ ACRV; IF SC = "0" THEN SI ~ SI+1; 02616000 + DI ~ LOC CONV; SKIP S DB; 02617000 + T(SKIP 3 SB; 3(IF SB THEN DS ~ SET ELSE DS ~ RESET; SKIP 1 SB)); 02618000 +END CONV; 02619000 + IF T~COUNT(ACR0,1) = 0 THEN 02620000 + BEGIN S ~ 1; 02620100 + IF T ~ CHAR ! "+ " AND T ! "& " THEN 02620200 + IF T = "- " THEN S ~ -1 ELSE GO TO XIT; 02621000 + SCANX(4, 4, 3, 3, 10, 10); 02621100 + IF SCN ! 10 THEN GO TO XIT; 02622000 + IF T~COUNT(ACR1,2) = 0 OR T > 16 THEN GO TO XIT ; 02622100 + FNEXT ~ CONV(ACR1, (16-T)|3, T); 02622200 + IF S < 0 THEN FNEXT ~ -FNEXT; 02623000 + END ELSE IF T < 17 THEN FNEXT~CONV(ACR0,(16-T)|3,T) ELSE GO TO XIT ; 02623100 + CHECKOCTAL ~ TRUE; 02624000 + NEXT ~ NUM; 02625000 + NUMTYPE ~ REALTYPE; 02626000 + XIT: 02627000 +END CHECKOCTAL; 02628000 +PROCEDURE HOLLERITH; 02629000 +BEGIN 02630000 + REAL T, COL1, T2, ENDP; 02631000 + LABEL XIT; 02632000 + INTEGER STREAM PROCEDURE STRCNT(S,D,SZ); VALUE S,SZ; 02633000 + BEGIN 02634000 + SI ~ S; DI ~ D;DS ~ 8 LIT "00 "; DI ~ D; 02635000 + DI ~ D; DI ~ DI + 2; DS ~SZ CHR; STRCNT ~ SI; 02636000 + END STRCNT; 02637000 + INTEGER STREAM PROCEDURE RSTORE(S,D,SKP,SZ); 02638000 + VALUE S, SKP, SZ; 02639000 + BEGIN 02640000 + DI ~ D; 02641000 + SI ~ S; DI ~DI + SKP; DS ~ SZ CHR; RSTORE ~ SI; 02642000 + END RSTORE; 02643000 + F1 ~ FNEXT; 02644000 + NUMTYPE ~ STRINGTYPE; 02645000 + T ~ 0 & NCR[30:33:15] & NCR[45:30:3]; 02646000 + COL1 ~ 0 & INITIALNCR[30:33:15]; 02647000 + ENDP ~ COL1 + 72; 02648000 + STRINGSIZE ~ 0; 02649000 + WHILE F1 >0 DO 02650000 + BEGIN 02651000 + T2 ~ IF F1 > 6 THEN 6 ELSE F1; 02652000 + IF STRINGSIZE > MAXSTRING THEN 02653000 + BEGIN FLAG(120); STRINGSIZE ~ 0 END; 02654000 + IF T+T2> ENDP THEN IF DCINPUT OR FREEFTOG THEN 02655000 + BEGIN XTA~BLANKS; FLOG(150); GO TO XIT END 02655500 + ELSE BEGIN 02656000 + IF TSSEDITOG THEN IF NOT DCINPUT THEN TSSED(BLANKS,1) ; 02656100 + NCR ~ STRCNT(NCR, STRINGARRAY[STRINGSIZE], ENDP-T); 02657000 + IF NOT CONTINUE THEN 02658000 +% 02659000 + BEGIN FLOG(43); GO TO XIT END; 02660000 + IF READACARD THEN; 02661000 + IF LISTOG THEN PRINTCARD; 02662000 + NCR ~ RSTORE(NCR,STRINGARRAY[STRINGSIZE],ENDP-T+2,T2-(ENDP-T)); 02663000 + STRINGSIZE ~ STRINGSIZE+1; 02664000 + F1 ~ F1 - T2; 02665000 + T ~ COL1 + 6 + T2 - (ENDP - T); 02666000 + END ELSE 02667000 + BEGIN 02668000 + NCR ~ STRCNT(NCR, STRINGARRAY[STRINGSIZE], T2); 02669000 + STRINGSIZE ~ STRINGSIZE +1; 02670000 + T ~ T +T2; 02671000 + F1 ~ F1 - T2; 02672000 + END; 02673000 + END; 02674000 + NUMTYPE ~ STRINGTYPE; 02675000 + SCN ~ 1; 02676000 + XIT: 02677000 +END HOLLERITH; 02678000 +PROCEDURE QUOTESTRING; 02679000 +BEGIN 02680000 + REAL C; 02681000 + LABEL XIT; 02682000 + ALPHA STREAM PROCEDURE STRINGWORD(S,D,SKP,SZ,C); 02683000 + VALUE S,SKP,SZ; 02684000 + BEGIN 02685000 + LABEL QT, XIT; 02686000 + DI ~ D; SI ~ S; 02687000 + DI ~ DI+SKP; DI ~ DI+2; 02688000 + TALLY ~ SKP; 02689000 + SZ( IF SC = """ THEN JUMP OUT TO QT; 02690000 + IF SC = ":" THEN JUMP OUT TO QT; 02691000 + IF SC = "@" THEN JUMP OUT TO QT; 02692000 + IF SC = "]" THEN JUMP OUT TO XIT; 02693000 + DS ~ CHR; TALLY ~ TALLY+1); 02694000 + GO TO XIT; 02695000 + QT: TALLY ~ TALLY+7; SI ~ SI+1; 02696000 + XIT: STRINGWORD ~ SI; S ~ TALLY; 02697000 + SI ~ LOC S; DI ~ C; DS ~ WDS; 02698000 + END STRINGWORD; 02799000 + STRINGSIZE ~ 0; 02700000 + DO 02701000 + BEGIN 02702000 + IF STRINGSIZE > MAXSTRING THEN 02703000 + BEGIN FLAG(120); STRINGSIZE ~ 0 END; 02704000 + STRINGARRAY[STRINGSIZE] ~ BLANKS; 02705000 + NCR ~ STRINGWORD(NCR, STRINGARRAY[STRINGSIZE], 0, 6, C); 02706000 + IF C<6 THEN IF DCINPUT OR FREEFTOG 02707000 + THEN BEGIN XTA~BLANKS; FLOG(150); GO TO XIT END 02707500 + ELSE BEGIN 02708000 + IF TSSEDITOG THEN IF NOT DCINPUT THEN TSSED(BLANKS,1) ; 02708100 + IF NOT CONTINUE THEN 02709000 +% 02710000 + BEGIN FLOG(121); GO TO XIT END; 02711000 + IF READACARD THEN; 02712000 + IF LISTOG THEN PRINTCARD; 02713000 + NCR ~ STRINGWORD(NCR, STRINGARRAY[STRINGSIZE ],C,6-C,C); 02714000 + END; 02715000 + STRINGSIZE ~ STRINGSIZE + 1; 02716000 + END UNTIL C } 7; 02717000 + IF C = 7 THEN STRINGSIZE ~ STRINGSIZE-1; 02718000 + FNEXT ~ STRINGSIZE; 02719000 + NEXT ~ NUM; 02720000 + SYMBOL ~ NAME ~ STRINGARRAY[0]; 02721000 + NUMTYPE ~ STRINGTYPE; 02722000 + SCN ~ 1; 02723000 + XIT: 02724000 +END QUOTESTRING; 02725000 +PROCEDURE CHECKPERIOD; 02726000 +BEGIN 02727000 +LABEL FRACTION, XIT, EXPONENT, EXPONENTSIGN; 02728000 +LABEL NUMFINI, FPLP, CHKEXP; 02729000 +ALPHA S, T, I, TS; 02730000 + INTEGER C2; 02730050 +BOOLEAN CON; 02730100 + IF T ~ CHAR ! ". " THEN GO TO CHKEXP; 02731000 +SCANX(4, 9, 3, 8, 10, 11); 02732000 +IF T ~ EXACCUM[1] = " " THEN 02733000 + BEGIN IF NUMTYPE ! DOUBTYPE THEN NUMTYPE ~ REALTYPE; GO TO XIT END; 02733500 +IF T = "E " OR T = "D " THEN GO TO EXPONENTSIGN; 02734000 +IF T.[12:6] { 9 THEN GO TO FRACTION; 02735000 +IF T.[18:6] { 9 THEN 02736000 +BEGIN 02737000 + IF S ~ T.[12:6] ! "E" AND S ! "D" THEN 02738000 + BEGIN XTA ~ T; FLOG(63); GO TO XIT END; 02739000 + EXACCUM[1].[12:6] ~ 0; 02740000 + I ~ 1; GO TO EXPONENT; 02741000 +END; 02742000 +IF EXACCUM[0] ! ". " THEN GO TO XIT; 02743000 +FOR I ~ 0 STEP 1 UNTIL 10 DO 02744000 + IF T = PERIODWORD[I] THEN 02745000 + BEGIN EXACCUM[2] ~ I; SCN ~ 12; GO TO XIT END; 02746000 +GO TO XIT; 02747000 +FRACTION: NEXT ~ NUM; 02748000 +IF NUMTYPE !DOUBTYPE THEN NUMTYPE ~ REALTYPE; XTA ~ ACR1; 02749000 +FPLP: 02750000 +F1 ~ 0; 02751000 +XTA ~ CONVERT(F1,C1,XTA ,TS); 02752000 +C2 ~ C2 + C1; 02753000 +IF (F2 ~ FNEXT|TEN[C1]+F1) { MAX 02754000 + THEN FNEXT ~ F2 02755000 + ELSE BEGIN 02756000 + NUMTYPE ~ DOUBTYPE; 02757000 + CON ~ TRUE; 02757100 + DOUBLE(FNEXT,DBLOW,TEN[C1],TEN[69+C1],|, 02758000 + F1,0,+,~,FNEXT,DBLOW); 02759000 + END; 02760000 +IF TS { 9 THEN GO TO FPLP; 02761000 +F1 ~ 0; 02762000 +IF T ~ EXACCUM[0] ! "E " AND T ! "D " THEN 02763000 +BEGIN IF SCN = 8 THEN SCN ~ 3 ELSE SCN ~ 10; 02764000 + GO TO NUMFINI; 02765000 +END; 02766000 +CHKEXP: FNEXT ~ FNEXT | 1.0; 02767000 +F1 ~ 0; 02768000 +I ~ 1; 02769000 +SCANX(4, 4, 3, 3, 20, 10); 02770000 +IF SCN = 20 THEN 02771000 +EXPONENTSIGN: 02772000 +BEGIN IF S ~ EXACCUM[0] ! "+ " AND S ! "& " THEN 02773000 + IF S = "- " THEN I ~ -1 ELSE 02774000 + BEGIN XTA ~ S; FLOG(63); SCN ~ 10; GO TO XIT END; 02775000 + SCANX(4, 4, 3, 3, 10, 10); 02776000 + END; 02777000 + IF (S ~ EXACCUM[1]).[12:6] > 9 THEN 02778000 + BEGIN XTA ~ IF S ! BLANKS THEN S ELSE T; FLOG(63); GO TO XIT END; 02778100 + EXPONENT: 02779000 + IF NUMTYPE ! DOUBTYPE THEN NUMTYPE ~ REALTYPE; 02779500 +IF T.[12:6] = "D" THEN NUMTYPE ~ DOUBTYPE; 02780000 + IF SCN = 8 THEN SCN ~ 3 ELSE IF SCN = 11 THEN SCN ~ 10; 02781000 + XTA ~ ACR1; 02782000 + XTA ~ CONVERT(F1,C1,XTA ,TS); 02783000 + IF I < 0 THEN F1 ~ -F1; 02784000 + NUMFINI: 02785000 + C1 ~ F1 - C2; 02786000 + IF I ~ (ABS(C1+(FNEXT.[3:6]&FNEXT[1:2:1]))) > 63 OR((ABS(C1) = I OR 02787000 + FNEXT } 5) AND ABS(F1) } 69) 02787500 + THEN BEGIN XTA ~ T; FLOG(87); GO TO XIT; END; 02788000 + IF NUMTYPE ! DOUBTYPE THEN 02789000 + BEGIN 02790000 + IF C1} 0 THEN FNEXT ~ FNEXT | TEN[C1] 02791000 + ELSE FNEXT ~ FNEXT / TEN[-C1]; 02792000 + END ELSE 02793000 + BEGIN 02794000 + IF C1 } 0 02795000 + THEN DOUBLE(FNEXT,DBLOW,TEN[C1],TEN[69+C1],|,~,FNEXT,DBLOW) 02796000 + ELSE DOUBLE(FNEXT,DBLOW,TEN[-C1],TEN[69-C1],/,~,FNEXT,DBLOW); 02797000 + IF CON THEN IF DBLOW.[9:33] = MAX.[9:33] THEN 02797100 + IF FNEXT.[3:6] LSS 14 02797150 + THEN IF BOOLEAN(FNEXT.[2:1]) THEN 02797200 + BEGIN DBLOW ~ 0; FNEXT ~ FNEXT + 1&FNEXT[2:2:7]; END; 02797300 + END; 02798000 + XIT: 02799000 +END CHECKPERIOD; 02800000 +LABEL LOOP0, NUMBER ; 02801000 +LABEL L,XIT; 02802000 +LABEL L1,L2,L3,L4,L5,L6,L7,L8,L9,L10,L11,L12,L13,L14,L15,L16,L17, 02802100 + L18,L19,L20,L21,BK ; 02802200 +SWITCH CASEL~L1,L2,L3,L4,L5,L6,L7,L8,L9,L10,L11,L12,L13,L14,L15, 02802300 + L16,L17,L18,L19,L20,L21 ; 02802400 +LABEL LOOP, CASESTMT; %994-02803000 +LABEL CASE0,CASE1,CASE2,CASE3,CASE4,CASE5,CASE6,CASE7; %994-02803100 +LABEL CASE8,CASE9,CASE10,CASE11,CASE12,CASE13,CASE14; %994-02803200 +PREC~NEXT~FNEXT~REAL(SCANENTER~FALSE) ; 02804000 +CASESTMT: 02805000 +CASE SCN OF 02806000 +BEGIN 02807000 +CASE0: %994-02807999 +GO TO IF LABELR THEN CASE5 ELSE CASE1; 02808000 +CASE1: 02809000 +BEGIN 02810000 + LOOP0: 02810100 + ACR ~ ACR0; 02811000 + ACCUM[1] ~ BLANKS; 02812000 + LOOP: 02813000 + IF ADVANCE(NCR, ACR, CHR0, NCR, ACR) THEN 02814000 + IF CONTINUE THEN 02815000 +% 02816000 + IF READACARD THEN 02817000 + BEGIN 02818000 + IF LISTOG THEN PRINTCARD ; 02818010 + IF ACR.[33:15]}ACCUMSTOP THEN 02818020 + BEGIN XTA~BLANKS; FLOG(175); GO LOOP0 END ; 02818030 + GO LOOP ; 02818040 + END 02818050 + ELSE IF T ~ ACCUM[1] = " " THEN GO TO CASE5 ELSE SCN ~ 4 02819000 + ELSE IF T ~ ACCUM[1] = " " THEN 02820000 + GO TO CASE3 ELSE SCN ~ 3 02821000 + ELSE IF T ~ ACCUM[1] = " " THEN GO TO CASE2 ELSE SCN ~ 2; 02822000 +END; 02823000 +CASE2: 02824000 +BEGIN T ~ CHAR; SCN ~ 1 END; 02825000 +CASE3: 02826000 +BEGIN T ~ "; "; NEXT ~ SEMI; SCN ~ 0; 02827000 + IF EOSTOG THEN IF LOGIFTOG THEN BEGIN LOGIFTOG ~ FALSE; XTA ~ T; 02827100 + FLAG(101); END; 02827200 + GO TO XIT; 02827300 +END; 02827400 +CASE4: %994-02827999 +BEGIN T ~ "; "; NEXT ~ SEMI; SCN ~ 5; GO TO XIT END; 02828000 +CASE5: 02829000 +BEGIN T ~ " "; NEXT ~ EOF; EOSTOG ~ FALSE; GO TO XIT END; 02830000 +CASE6: %994-02830999 +BEGIN T ~ ACCUM[1] ~ NEXTACC; SCN ~ NEXTSCN; 02831000 + IF T = " " THEN GO TO CASESTMT; 02832000 +END; 02833000 +CASE7: %994-02833999 +BEGIN EOSTOG ~ TRUE; 02834000 + IF LABELR THEN GO TO CASE5 ELSE GO TO CASE1; 02835000 +END; 02836000 +CASE8: %994-02836999 +BEGIN T ~ EXACCUM[1]; SCN ~ 3 END; 02837000 +CASE9: %994-02837999 +BEGIN T ~ EXACCUM[1]; SCN ~ 4 END; 02838000 +CASE10: %994-02838999 +BEGIN T ~ CHAR ~ EXACCUM[0]; SCN ~ 1 END; 02839000 +CASE11: %994-02839999 +BEGIN T ~ EXACCUM[1]; SCN ~ 10 END; 02840000 +CASE12: %994-02840999 +BEGIN T ~ EXACCUM[1]; SCN ~ 1; 02841000 + IF N ~ EXACCUM[2] { 1 THEN 02842000 + BEGIN NEXT ~ NUM; FNEXT ~ N; GO TO XIT END; 02843000 + NEXT ~ 0; 02844000 + OP ~ N-1; 02845000 + PREC ~ IF N { 4 THEN N-1 ELSE 4; 02846000 + GO TO XIT; 02847000 +END; 02848000 +CASE13: %994-02848999 +BEGIN T ~ "FUNCTI"; NEXT ~ 16; SCN ~ 6; GO TO XIT END; 02849000 +CASE14: %994-02849999 +BEGIN T ~ ACCUM[1] ~ NEXTACC; 02850000 + NEXTACC ~ NEXTACC2; SCN ~ 6; 02851000 +END; 02852000 +END OF CASE STATEMENT; 02853000 +IF NOT FILETOG THEN 02854000 + IF EOSTOG THEN 02855000 + BEGIN 02856000 + NEXT ~ 0; 02857000 + IF T = "; " THEN GO TO CASESTMT; 02858000 + CHECKRESERVED; 02859000 + IF NEXT > 0 THEN GO TO XIT; 02860000 + END; 02861000 +IF (IDINFO~TIPE[T.[12:6]])>0 THEN 02862000 + BEGIN 02862100 +BK: NEXT~ID ; 02862200 + IF NOT FILETOG THEN 02862300 + IF SCANENTER~((FNEXT~SEARCH(T))=0) THEN FNEXT~ENTER(IDINFO,T) 02862400 + ELSE IF GET(FNEXT).CLASS=DUMMY THEN FNEXT~GET(FNEXT+2).BASE ; 02862500 + GO XIT ; 02862600 + END ; 02862700 +GO CASEL[-IDINFO]; % SEE INITIALIZATION OF "TIPE". LINE 03433100%993-02862800 +L1: %DIGITS %993-02863000 +BEGIN NUMTYPE ~ INTYPE; NEXT ~ NUM; XTA ~ ACR0; 02864000 + FNEXT ~ DBLOW ~ C1 ~ 0; 02865000 + XTA ~ CONVERT(FNEXT,C1,XTA ,TS); 02866000 + WHILE TS { 9 DO 02867000 + BEGIN 02868000 + XTA ~ CONVERT(F1,C1,XTA ,TS); 02869000 + IF (F2 ~ FNEXT|TEN[C1]+F1) { MAX 02870000 + THEN FNEXT ~ F2 02871000 + ELSE BEGIN 02872000 + NUMTYPE ~ DOUBTYPE; 02873000 + DOUBLE(FNEXT,DBLOW,TEN[C1],TEN[69+C1],|, 02874000 + F1,0,+,~,FNEXT,DBLOW); 02875000 + END; 02876000 + END; 02877000 + IF CHAR = ". " OR CHAR = "E " OR CHAR = "D " THEN 02878000 + CHECKPERIOD 02879000 + ELSE IF CHAR = "H " THEN HOLLERITH; 02883000 + GO TO XIT; 02884000 +END; 02885000 +L2: % > %993- 02898100 +BEGIN PREC ~ 4; OP ~ 7; GO TO XIT END; 02899000 +L3: % } %993- 02899100 +BEGIN PREC ~ 4; OP ~ 8; GO TO XIT END; 02900000 +L4: % & OR + %993- 02900100 +BEGIN PREC ~ 5; OP ~ 10; NEXT ~ PLUS; GO TO XIT END; 02901000 +L5: % . %993- 02910100 +BEGIN 02911000 + FNEXT ~ DBLOW ~ C1 ~ 0; NUMTYPE ~ REALTYPE; 02912000 + CHECKPERIOD; 02913000 + T ~ EXACCUM[1]; 02914000 + IF SCN = 12 THEN 02915000 + BEGIN SCN ~ 1; 02916000 + IF N ~ EXACCUM[2] { 1 THEN 02917000 + BEGIN 02918000 + NEXT ~ NUM; FNEXT ~ N; 02919000 + NUMTYPE ~ LOGTYPE; GO TO XIT; 02920000 + END; 02921000 + NEXT ~ 0; 02922000 + OP ~ N-1; 02923000 + PREC ~ IF N { 4 THEN N-1 ELSE 4; 02924000 + GO TO XIT; 02924100 END; 02925000 -CASE7: %994-02926000 -BEGIN EOSTOG ~ TRUE; 02927000 - IF LABELR THEN GO TO CASE5 ELSE GO TO CASE1; 02928000 -END; 02929000 -CASE8: %994-02930000 -BEGIN T ~ EXACCUM[1]; SCN ~ 3 END; 02931000 -CASE9: %994-02932000 -BEGIN T ~ EXACCUM[1]; SCN ~ 4 END; 02933000 -CASE10: %994-02934000 -BEGIN T ~ CHAR ~ EXACCUM[0]; SCN ~ 1 END; 02935000 -CASE11: %994-02936000 -BEGIN T ~ EXACCUM[1]; SCN ~ 10 END; 02937000 -CASE12: %994-02938000 -BEGIN T ~ EXACCUM[1]; SCN ~ 1; 02939000 - IF N ~ EXACCUM[2] { 1 THEN 02940000 - BEGIN NEXT ~ NUM; FNEXT ~ N; GO TO XIT END; 02941000 - NEXT ~ 0; 02942000 - OP ~ N-1; 02943000 - PREC ~ IF N { 4 THEN N-1 ELSE 4; 02944000 - GO TO XIT; 02945000 -END; 02946000 -CASE13: %994-02947000 -BEGIN T ~ "FUNCTI"; NEXT ~ 16; SCN ~ 6; GO TO XIT END; 02948000 -CASE14: %994-02949000 -BEGIN T ~ ACCUM[1] ~ NEXTACC; 02950000 - NEXTACC ~ NEXTACC2; SCN ~ 6; 02951000 -END; 02952000 -END OF CASE STATEMENT; 02953000 -IF NOT FILETOG THEN 02954000 - IF EOSTOG THEN 02955000 - BEGIN 02956000 - NEXT ~ 0; 02957000 - IF T = "; " THEN GO TO CASESTMT; 02958000 - CHECKRESERVED; 02959000 - IF NEXT > 0 THEN GO TO XIT; 02960000 - END; 02961000 -IF (IDINFO~TIPE[T.[12:6]])>0 THEN 02962000 - BEGIN 02963000 -BK: NEXT~ID ; 02964000 - IF NOT FILETOG THEN 02965000 - IF SCANENTER~((FNEXT~SEARCH(T))=0) THEN FNEXT~ENTER(IDINFO,T) 02966000 - ELSE IF GET(FNEXT).CLASS=DUMMY THEN FNEXT~GET(FNEXT+2).BASE ; 02967000 - GO XIT ; 02968000 - END ; 02969000 -GO CASEL[-IDINFO]; % SEE INITIALIZATION OF "TIPE". LINE 03433100%993-02970000 -L1: %DIGITS %993-02971000 -BEGIN NUMTYPE ~ INTYPE; NEXT ~ NUM; XTA ~ ACR0; 02972000 - FNEXT ~ DBLOW ~ C1 ~ 0; 02973000 - XTA ~ CONVERT(FNEXT,C1,XTA ,TS); 02974000 - WHILE TS { 9 DO 02975000 - BEGIN 02976000 - XTA ~ CONVERT(F1,C1,XTA ,TS); 02977000 - IF (F2 ~ FNEXT|TEN[C1]+F1) { MAX 02978000 - THEN FNEXT ~ F2 02979000 - ELSE BEGIN 02980000 - NUMTYPE ~ DOUBTYPE; 02981000 - DOUBLE(FNEXT,DBLOW,TEN[C1],TEN[69+C1],|, 02982000 - F1,0,+,~,FNEXT,DBLOW); 02983000 - END; 02984000 - END; 02985000 - IF CHAR = ". " OR CHAR = "E " OR CHAR = "D " THEN 02986000 - CHECKPERIOD 02987000 - ELSE IF CHAR = "H " THEN HOLLERITH; 02988000 - GO TO XIT; 02989000 -END; 02990000 -L2: % > %993- 02991000 -BEGIN PREC ~ 4; OP ~ 7; GO TO XIT END; 02992000 -L3: % } %993- 02993000 -BEGIN PREC ~ 4; OP ~ 8; GO TO XIT END; 02994000 -L4: % & OR + %993- 02995000 -BEGIN PREC ~ 5; OP ~ 10; NEXT ~ PLUS; GO TO XIT END; 02996000 -L5: % . %993- 02997000 -BEGIN 02998000 - FNEXT ~ DBLOW ~ C1 ~ 0; NUMTYPE ~ REALTYPE; 02999000 - CHECKPERIOD; 03000000 - T ~ EXACCUM[1]; 03001000 - IF SCN = 12 THEN 03002000 - BEGIN SCN ~ 1; 03003000 - IF N ~ EXACCUM[2] { 1 THEN 03004000 - BEGIN 03005000 - NEXT ~ NUM; FNEXT ~ N; 03006000 - NUMTYPE ~ LOGTYPE; GO TO XIT; 03007000 - END; 03008000 - NEXT ~ 0; 03009000 - OP ~ N-1; 03010000 - PREC ~ IF N { 4 THEN N-1 ELSE 4; 03011000 - GO TO XIT; 03012000 -END; 03013000 - IF NEXT ! NUM THEN BEGIN NEXT ~ NUM; XTA ~ T; FLOG(141) END; 03014000 - GO TO XIT; 03015000 -END; 03016000 -L6: % % OR ( %993-03017000 -BEGIN NEXT ~ LPAREN; GO TO XIT END; 03018000 -L7: % < %993-03019000 -BEGIN PREC ~ OP ~ 4; GO TO XIT END; 03020000 -L8: % LETTER 0 %993-03021000 -BEGIN IF DATATOG THEN IF CHECKOCTAL THEN GO TO XIT; 03022000 - IDINFO~TIPE[12]; GO BK ; 03023000 -END; 03024000 -L9: % $ %993-03025000 -BEGIN NEXT ~ DOLLAR; GO TO XIT END; 03026000 -L10: % * %993-03027000 -IF CHECKEXP(NCR, NCR, T) THEN 03028000 -BEGIN PREC ~ 9; OP ~ 15; NEXT ~ UPARROW; GO TO XIT END ELSE 03029000 -L11: 03030000 -BEGIN PREC ~ 7; OP ~ 13; NEXT ~ STAR; GO TO XIT END; 03031000 -L12: % - %993-03032000 -BEGIN PREC ~ 5; OP ~ 11; NEXT ~ MINUS; GO TO XIT END; 03033000 -L13: % ) OR [ %993-03034000 -BEGIN NEXT ~ RPAREN; GO TO XIT END; 03035000 -L14: % ; %993-03036000 -BEGIN NEXT ~ SEMI; GO TO XIT END; 03037000 -L15: % { %993-03038000 -BEGIN PREC ~ 4; OP ~ 5; GO TO XIT END; 03039000 -L16: % / %993-03040000 -BEGIN PREC ~ 7; OP ~ 14; NEXT ~ SLASH; GO TO XIT END; 03041000 -L17: % , %993-03042000 -BEGIN NEXT ~ COMMA; GO TO XIT END; 03043000 -L18: % ! %993-03044000 -BEGIN PREC ~ 4; OP ~ 9; GO TO XIT END; 03045000 -L19: % = OR ~ OR # %993- 03046000 -BEGIN NEXT ~ EQUAL; GO TO XIT END; 03047000 -L20: % ] %993-03048000 -BEGIN XTA ~ T; FLAG(0); GO TO CASESTMT END; 03049000 -L21: % " OR : OR @ %993-03050000 -BEGIN QUOTESTRING; GO TO XIT END; 03051000 -XIT: 03052000 -IF DEBUGTOG THEN WRITALIST(FD,3,NEXT,T," ",0,0,0,0,0) ; 03053000 - XTA ~ NAME ~ T; 03054000 -END SCAN; 03055000 - 03056000 -PROCEDURE WRAPUP; 03057000 - COMMENT WRAPUP OF COMPILIATION; 03058000 - BEGIN 03059000 -ARRAY PRT[0:7,0:127], 03060000 - SEGDICT[0:7,0:127], 03061000 - SEG0[0:29]; 03062000 -ARRAY FILES[0:BIGGESTFILENB]; 03063000 -INTEGER THEBIGGEST; 03064000 -SAVE ARRAY FPB[0:1022]; % FILE PARAMETER BLOCK 03065000 -REAL FPS,FPE; % START AND END OF FPB 03066000 -REAL GSEG,PRI,FID,MFID,IDNM,FILTYP,FPBI; 03067000 -BOOLEAN ALF; 03068000 -REAL PRTADR, SEGMNT, LNK, TSEGSZ, T1, I, FPBSZ; 03069000 - DEFINE 03070000 - SPDEUN= FPBSZ#, 03071000 - ENDDEF=#; 03072000 -ARRAY INTLOC[0:150]; 03073000 -REAL J; 03074000 -FORMAT SEGUS(A6, " IS SEGMENT ", I4, 03075000 - ", PRT IS ", A4, "."); 03076000 -LIST SEGLS(IDNM,NXAVIL,T1); 03077000 -LABEL LA, ENDWRAPUP; 03078000 - LABEL QQQDISKDEFAULT; %503-03079000 - COMMENT FORMAT OF SEGMENT DICTIONARY -RUN TIME ; 03080000 -DEFINE SGTYPF= [1:2]#, %0 = PROGRAM SEGMENTS 03081000 - SGTYPC= 1:46:2#,%1 = MCP INTRINSIC 03082000 - %2 = DATA SEGMENT 03083000 - PRTLINKF= [8:10]#, % LINK TO FIRT PRT ENTRY 03084000 - PRTLINKC= 8:38:10#, 03085000 - SGLCF = [18:15]#, % SEGMENT SIZE 03086000 - SGLCC = 23:38:10#, 03087000 - DKADRF = [33:15]#, % RELATIVE DISK ADDRESS OF SEGMENT 03088000 - % OR MCP INTRINSIC NUMBER 03089000 - DKADRC = 33:13:15#; 03090000 - COMMENT FORMAT OF FIRST SEGMENT OF CODE FILE- RUN TIME; 03091000 -COMMENT SEGO[0:29] 03092000 - WORD CONTENTS 03093000 - 0 LOCATION OF SEGMENT DICTIONARY 03094000 - 1 SIZE OF SEGMENT DICTIONARY 03095000 - 2 LOCATION OF PRT 03096000 - 3 SIZE OF PRT 03097000 - 4 LOCATION OF FILE PARAMETER BLOCK 03098000 - 5 SIZE OF FILE PARAMETER BLOCK 03099000 - 6 STARTING SEGMENT NUMBER 03100000 - 7-[2:1] IND FORTRAN FAULT DEC 03101000 - 7-[18:15] NUMBER OF FILES 03102000 - 7-[33:15] CORE REQUIRED/64 03103000 - ; 03104000 - COMMENT FORMAT OF PRT; 03105000 - % FLGF = [0:4] = 1101 = SET BY STREAM 03106000 -DEFINE MODEF =[4:2]#, % 0 = THUNK 03107000 - MODEC=4:46:2#, % 1 = WORD MODE PROGRAM DESCRIPTOR 03108000 - % 2 = LABEL DESCRIPTOR 03109000 - % 3 = CHARACTER MODE PROGRAM DESCRIPTOR 03110000 - STOPF =[6:1]#, % STOPPER = 1 FOR LAST DESCRIPTOR IN 03111000 - STOPC=6:47:1#, % CHAIN OF SAME SEGMENT DESCRIPTORS 03112000 - LINKF =[7:11]#, % IF STOP = 0 THEN PRTLINK 03113000 - LINKC=7:37:11#, % ELSE LINK TO SEGDICT 03114000 - FFF =[18:15]#,% INDEX INTO SEGMENT DICTIONARY 03115000 - FFC =18:33:15#, 03116000 - SINX = [33:15]#;% RELATIVE ADDRESS INTO SEGMENT 03117000 -DEFINE PDR = [37:5]#, 03118000 - PDC = [42:6]#; 03119000 -REAL STREAM PROCEDURE MKABS(F); 03120000 - BEGIN 03121000 - SI ~ F; MKABS ~ SI; 03122000 - END MKABS; 03123000 -REAL STREAM PROCEDURE BUILDFPB(DEST,FILNUM,FILTYP,MFID,FID,IDSZ, 03124000 - IDNM,SPDEUN); 03125000 - VALUE DEST,IDSZ,SPDEUN; 03126000 - BEGIN 03127000 - DI ~ DEST; 03128000 - SI ~ FILNUM; SI ~ SI + 6; DS ~ 2 CHR; 03129000 - SI ~ FILTYP; SI ~ SI + 7; DS ~ CHR; 03130000 - SI ~ MFID; SI ~ SI + 1; DS ~ 7 CHR; 03131000 - SI ~ FID; SI ~ SI + 1; DS ~ 7 CHR; 03132000 - SI ~ LOC IDSZ; SI ~ SI + 1; DS ~ IDSZ CHR; 03133000 - SI~LOC SPDEUN;SI~SI+6;DS~2 CHR;% DISK SPEED & EU NUMBER+1 03134000 - BUILDFPB ~ DI; 03135000 - DS ~ 2 LIT "0"; 03136000 - END BUILDFPB; 03137000 -REAL STREAM PROCEDURE GITSZ(F); 03138000 - BEGIN 03139000 - SI ~ F; SI ~SI + 7; TALLY ~ 7; 03140000 - 3(IF SC ! " " THEN JUMP OUT; 03141000 - SI ~SI - 1; TALLY ~ TALLY + 63;); 03142000 - GITSZ ~ TALLY; 03143000 - END GITSZ; 03144000 -STREAM PROCEDURE MOVE(F,T,SZ); VALUE SZ; 03145000 - BEGIN 03146000 - SI ~ F; DI ~T; DS ~ SZ WDS; 03147000 - END MOVE; 03148000 -INTEGER PROCEDURE MOVEANDBLOCK(FROM,SIZE); VALUE SIZE; 03149000 - ARRAY FROM[0,0]; INTEGER SIZE; 03150000 - BEGIN 03151000 - REAL T,NSEGS,J,I; 03152000 - STREAM PROCEDURE M2(F,T); BEGIN SI~F; DI~T; DS ~ 2 WDS; END M2; 03153000 - NSEGS ~ (SIZE+29) DIV 30; 03154000 - IF DALOC DIV CHUNK < T ~ (DALOC + NSEGS) DIV CHUNK 03155000 - THEN DALOC ~ CHUNK | T; 03156000 - MOVEANDBLOCK ~ DALOC; 03157000 - DO BEGIN FOR J ~ 0 STEP 2 WHILE J < 30 AND I 0 THEN 03191000 - BEGIN T1 ~ GET(T ~ GLOBALSEARCH(".SUBAR")+2); 03192000 - PUT(T,T1~T1&SAVESUBS[TOSIZE]); 03193000 - END; 03194000 - T1~PRGDESCBLDR(1,23,0,NSEG~NXAVIL~NXAVIL+1) ; % BUILD TPAR 03195000 - FILL LSTT[*] WITH 21(0),8(" ") ; % R+23 03196000 - WRITEDATA(29,NXAVIL,LSTT) ; 03197000 - PDPRT[(PDINX-1).[37:5],(PDINX-1).[42:6]].[6:1]~1 ; % SAVE BIT 03198000 - T1 ~ PRGDESCBLDR(1,22,0,NSEG ~ NXAVIL ~ NXAVIL + 1); 03199000 - WRITEDATA (138,NXAVIL,TEN); % POWERS OF TEN TABLE 03200000 - IF LSTI > 0 THEN 03201000 - BEGIN 03202000 - WRITEDATA(LSTI, NXAVIL ~ NXAVIL+1, LSTP); 03203000 - LSTA ~ PRGDESCBLDR(1, LSTA, 0, NXAVIL); 03204000 - END; 03205000 - IF TWODPRTX ! 0 THEN 03206000 - BEGIN 03207000 - FILL LSTT[*] WITH 03208000 - OCT0000000421410010, 03209000 - OCT0301001301412025, 03210000 - OCT2021010442215055, 03211000 - OCT2245400320211025, 03212000 - OCT0106177404310415, 03213000 - OCT1025042112350000; 03214000 - T ~ PRGDESCBLDR(0, TWODPRTX, 0, NXAVIL ~ NXAVIL+1); 03215000 - WRITEDATA(-6, NXAVIL, LSTT); 03216000 - END; 03217000 - COMMENT DECLARE GLOBAL FILES AND ARRAYS; 03218000 - FPS ~ FPE ~ MKABS(FPB); 03219000 - SEGMENTSTART; 03220000 - F2TOG ~ TRUE; 03221000 - GSEG ~ NSEG; 03222000 - FPBI ~ 0; 03223000 - EMITL(0); EMITL(2); EMITO(SSF); 03224000 - EMITL(1); % SET BLOCK COUNTER TO 1 03225000 - EMITL(16); EMITO(STD); 03226000 - EMITL(0); EMITOPDCLIT(23); EMITO(DEL); 03227000 - EMITL(REAL(HOLTOG)); EMITPAIR(21,STD); 03228000 - I ~ GLOBALNEXTINFO; WHILE I < 4093 DO 03229000 - BEGIN 03230000 - I ~ I+3; 03231000 - GETALL(I,INFA,INFB,INFC); 03232000 - IF INFA.CLASS = FILEID THEN %SEE COMMENTS ON LINE 02118000 %992-03233000 - BEGIN 03234000 - FPBI ~ FPBI + 1; 03235000 - PRI ~ INFA .ADDR; 03236000 - IF (XTA ~ INFB ).[18:6] < 10 THEN 03237000 - BEGIN 03238000 - IF XTA ~ MAKEINT(XTA) > BIGGESTFILENB THEN FLAG(77) ELSE 03239000 - FILES[XTA] ~ PRI; 03240000 - IF XTA > THEBIGGEST THEN THEBIGGEST ~ XTA; 03241000 - END; 03242000 - EMITO(MKS); 03243000 - IF J ~ INFC .ADINFO ! 0 THEN % OPTION FILE 03244000 - BEGIN FILTYP ~ INFC .LINK; 03245000 - IDNM ~ " "&"FILE"[6:24:24]&INFB[30:18:18]; 03246000 - T1 ~ GITSZ(IDNM); 03247000 - FID ~ FILEINFO[2,J]; 03248000 - MFID ~ FILEINFO[1,J]; 03249000 - IF FILTYP}10 AND (T~FILEINFO[3,J].DKAREASZ)!0 THEN 03250000 - BEGIN %%% SET UP ; 03251000 - SPDEUN~FILEINFO[3,J].SENSPDEUNF; 03252000 - B~IF (B~((J~FILEINFO[0,J]).[18:12])/(IF A~J.[30:12]{0 THEN03253000 - 1 ELSE A)){0 THEN 1 ELSE B ; 03254000 - %%% B=ORIGINAL "BLOCKING" SIZE = # LOGRECS/PHYSREC. 03255000 - A~ENTIER(B|ENTIER(T/(20|B)+.999999999)+.5) ; 03256000 - %%% T="AREA" SIZE = # LOGRECS IN TOTAL FILE. 03257000 - %%% A=# LOGRECS PER ROW. 03258000 - B~ENTIER(T/A+.999999999) ; 03259000 - %%% B = # ROWS IN FILE. 03260000 - %%% EQUIVALENT ALGOL FILE DESCRIPTION = [B:A]. 03261000 - %%% THE ABOVE LOGIC YIELDS: SHORTEST ROW CONTAINING 03262000 - %%% AN INTEGER NUMBER OF PHYSICAL RECORDS AND WHICH 03263000 - %%% REQUIRES 20 OR FEWER ROWS FOR THE TOTAL AREA, T.03264000 - EMITNUM(B); EMITNUM(A) ; 03265000 - END ELSE 03266000 - BEGIN EMITL(0); EMITL(0); 03267000 - J ~ FILEINFO[0,J]; % THIS ONE HAS ALL THE GOODIES 03268000 - END; 03269000 - QQQDISKDEFAULT: %503-03270000 - ESTIMATE~ESTIMATE+(J.[42:6])|(IF A~J.[18:12]=0 THEN J.[30:12] 03271000 - ELSE A) ; 03272000 - EMITL(J.[4:2]); % LOCK 03273000 - EMITL(FPBI); % FILE PARAM INDEX 03274000 - EMITDESCLIT(PRI); % PRT OF FILE 03275000 - EMITL(J.[42:6]); % # BUFFERS 03276000 - EMITL(J.[3:1]); % RECORDING MODE 03277000 - EMITNUM(J.[30:12]) ; % RECORD SIZE 03278000 - EMITNUM(J.[18:12]) ; % BLOCK SIZE 03279000 - EMITNUM(J.[ 6:12]) ; % SAVE FACTOR 03280000 - END ELSE 03281000 - BEGIN 03282000 - ALF ~TRUE; 03283000 - IF(FILTYP~INFC.LINK=2 OR FILTYP=12) AND INFB.[18:6]{9 THEN 03284000 - IDNM ~ 0&"FILE"[6:24:24]&INFB[30:18:18] 03285000 - ELSE 03286000 - BEGIN 03287000 - ALF ~ FALSE; 03288000 - IF (IDNM ~ " "&INFB[6:18:30]) = "READR " THEN 03289000 - IDNM ~ "READER "; 03290000 - END; 03291000 -IF IDNM="READER " OR IDNM="FILE5 " THEN IDNM~"CARD " ELSE %503-03292000 -IF IDNM="FILE6 " THEN BEGIN IDNM~"PRINTER";FILTYP~18;END ELSE %503-03293000 - BEGIN %503-03294000 - EMITL(20); EMITL(600); FILTYP~12; %20 | 600 REC DISK %503-03295000 - J~0&2[42:42:6]&10[30:36:12]&300[18:36:12]; %503-03296000 - FID~IDNM; MFID~"FORTEMP"; T1~GITSZ(IDNM); %503-03297000 - GO TO QQQDISKDEFAULT; %503-03298000 - END; %503-03299000 - T1 ~ GITSZ(IDNM); 03300000 - FID ~ IDNM; 03301000 - MFID ~ 0; 03302000 - IF DCINPUT AND ALF THEN BEGIN 03303000 - EMITL(20); % DISK ROWS 03304000 - EMITL(100); % DISK RECORD PER ROW 03305000 - EMITL(2); % REWIND AND LOCK 03306000 - EMITL(FPBI); % FILE NUMBER 03307000 - EMITDESCLIT(PRI); % PRT OF FILE 03308000 - EMITL(2); % NUMBER OF BUFFERS 03309000 - EMITL(1); % RECORDING MODE 03310000 - EMITL(10); % RECORD SIZE 03311000 - EMITL(30); % BLOCK SIZE 03312000 - EMITL(1); % SAVE FACTOR 03313000 - END ELSE 03314000 - BEGIN 03315000 - EMITL(0); % DISK ROWS 03316000 - EMITL(0); % DISK RECORDS PER ROW 03317000 - EMITL(0); % REWIND & RELEASE 03318000 - EMITL(FPBI); % FILE NUMBER 03319000 - EMITDESCLIT(PRI); % PRT OF FILE 03320000 - EMITL(2); % 2 BUFFERS 03321000 - EMITL(REAL(ALF)); 03322000 - EMITL(IF FILTYP = 0 THEN 10 ELSE 17); 03323000 - EMITL(0); % 15 WORD BUFFERS 03324000 - EMITL(0); % SAVE FACTOR (SCRATCH BY DEFAULT) 03325000 - END; 03326000 - END; 03327000 - EMITL(11); % INPUT OR OUTPUT 03328000 - EMITL(8); % SWITCH CODE FOR BLOCK 03329000 - EMITOPDCLIT(5); % CALL BLOCK 03330000 - FPE~BUILDFPB(FPE,FPBI,FILTYP,MFID,FID,T1,IDNM,SPDEUN); 03331000 - IF PRTOG THEN WRITALIST(FILEF,3,IDNM.[6:6],IDNM,B2D(PRI), 03332000 - 0,0,0,0,0) ; 03333000 - END 03334000 - ELSE 03335000 - IF INFA.CLASS = BLOCKID THEN 03336000 - BEGIN 03337000 - IF PRTOG THEN WRITALIST(BLOKF,3,INFB,B2D(INFA.ADDR), 03338000 - INFC.SIZE,0,0,0,0,0) ; 03339000 - IF INFA < 0 THEN ARRAYDEC(I); 03340000 - END; 03341000 - IF (T1 ~ INFA .CLASS) } FUNID 03342000 - AND T1 { SUBRID THEN 03343000 - BEGIN 03344000 - PRI ~ 0; 03345000 - IF INFA .SEGNO = 0 THEN 03346000 - BEGIN 03347000 - A~0; B~NUMINTM1 ; 03348000 - WHILE A+1 < B DO 03349000 - BEGIN 03350000 - PRI ~ REAL(BOOLEAN(A+B) AND BOOLEAN(1022)); 03351000 - IF IDNM ~ INT[PRI] = INFB THEN GO TO FOUND; 03352000 - IF INFB < IDNM THEN B ~ PRI.[36:11] ELSE A ~ PRI.[36:11]; 03353000 - END; 03354000 - IF IDNM ~ INT[PRI~(A+B)|2-PRI] = INFB THEN GO TO FOUND; 03355000 - XTA ~ INFB; FLAG(30); 03356000 - GO TO LA; 03357000 - FOUND: 03358000 - IF (T1~INT[PRI+1].INTPARMS)!0 03359000 - AND INFC < 0 03360000 - THEN IF T1 ! INFC.NEXTRA THEN 03361000 - BEGIN XTA ~ INFB ; FLAG(28); END; 03362000 - IF (FID~INTLOC[MFID~INT[PRI+1].INTNUM])=0 THEN 03363000 - BEGIN 03364000 - PDPRT[PDIR,PDIC] ~ 03365000 - 0&1[STYPC] 03366000 - &(FID ~ INTLOC[MFID] ~ NXAVIL ~ NXAVIL + 1)[SGNOC] 03367000 - &1[SEGSZC]; 03368000 - PDINX ~ PDINX + 1; 03369000 - END; 03370000 - T1 ~ PRGDESCBLDR(1,INFA .ADDR,0,FID); 03371000 - IF PRTOG THEN WRITALIST(SEGUS,3,IDNM,FID,B2D(T1),0,0,0,0,0) ; 03372000 - IF INT[PRI+1] < 0 THEN 03373000 - BEGIN 03374000 - T1 ~ PRGDESCBLDR(1,INT[PRI+1].INTPRT,0,FID); 03375000 - INT[PRI+1] ~ ABS(INT[PRI + 1]); 03376000 - END; 03377000 - END 03378000 - ELSE IF PRTOG THEN WRITALIST(SEGUS,3,INFB, 03379000 - INFA.SEGNO,B2D(INFA.ADDR),0,0,0,0,0) ; 03380000 - END; 03381000 - LA: 03382000 - END; 03383000 -COMMENT MUST FOLLOW THE FOR STATEMENT; 03384000 -IF FILEARRAYPRT ! 0 THEN 03385000 -BEGIN % BUILDING OBJECT TIME FILE SEARCH ARRAY 03386000 - J ~ PRGDESCBLDR(1,FILEARRAYPRT,0,NXAVIL ~ NXAVIL + 1); 03387000 - WRITEDATA(THEBIGGEST + 1,NXAVIL,FILES); 03388000 -END; 03389000 - XTA ~ BLANKS; 03390000 - IF NXAVIL > 1023 THEN FLAG(45); 03391000 - IF PRTS > 1023 THEN FLAG(46); 03392000 - IF STRTSEG = 0 THEN FLAG(65); 03393000 - PRI ~ 0; 03394000 - WHILE (IDNM ~ INT[PRI]) ! 0 DO 03395000 - IF INT[PRI+1] } 0 THEN PRI ~ PRI + 2 ELSE 03396000 - BEGIN 03397000 - IF (FID~INTLOC[MFID~INT[PRI+1].INTNUM])=0 THEN 03398000 - BEGIN 03399000 - PDPRT[PDIR,PDIC] ~ 03400000 - 0&1[STYPC] 03401000 - &MFID[DKAC] 03402000 - &(FID ~ INTLOC[MFID] ~ NXAVIL ~ NXAVIL + 1)[SGNOC] 03403000 - &1[SEGSZC]; 03404000 - PDINX ~ PDINX + 1; 03405000 - END; 03406000 - T1 ~ PRGDESCBLDR(1,INT[PRI + 1].INTPRT,0,FID); 03407000 - PRI ~ PRI+2; 03408000 - END; 03409000 - FOR I ~ 1 STEP 1 UNTIL BDX DO 03410000 - BEGIN EMITO(MKS); EMITOPDCLIT(BDPRT[I]) END; 03411000 - EMITO(MKS); 03412000 - EMITOPDCLIT(STRTSEG.[18:15]); 03413000 - T ~ PRGDESCBLDR(1,0,0,NSEG); 03414000 - SEGMENT((ADR+4) DIV 4,NSEG,FALSE,EDOC); 03415000 - IF ERRORCT ! 0 THEN GO TO ENDWRAPUP; 03416000 - FILL SEG0[*] WITH 03417000 - OCT020005, % BLOCK 03418000 - OCT220014, % WRITE 03419000 - OCT230015, % READ 03420000 - OCT240016; % FILE CONTROL 03421000 - COMMENT INTRINSIC FUNCTIONS; 03422000 - FOR I ~ 0 STEP 1 UNTIL 3 DO 03423000 - BEGIN 03424000 - T1 ~ PRGDESCBLDR(1,SEG0[I].[36:12],0, 03425000 - NSEG ~ NXAVIL ~ NXAVIL + 1); 03426000 - PDPRT[PDIR,PDIC] ~ 03427000 - 0&1[STYPC] 03428000 - &(SEG0[I].[30:6])[DKAC] 03429000 - &NXAVIL[SGNOC] 03430000 - &1[SEGSZC]; 03431000 - PDINX ~ PDINX + 1; 03432000 - END; 03433000 - COMMENT GENERATE PRT AND SEGMENT DICTIONARY; 03434000 - PRT[0,41] ~ PDPRT[0,0] & 63[10:42:6]; % USED FOR FAULT OPTN 03435000 - FOR I ~ 1 STEP 1 UNTIL PDINX-1 DO 03436000 - IF (T1~PDPRT[I.PDR,I.PDC]).SEGSZF = 0 THEN 03437000 - BEGIN % PRT ENTRY 03438000 - PRTADR ~T1.PRTAF; 03439000 - SEGMNT ~T1.SGNOF; 03440000 - LNK ~ SEGDICT[SEGMNT.[36:5], SEGMNT.[41:7]].PRTAF; 03441000 - MDESC(T1.RELADF&SEGMNT[FFC] 03442000 - &(REAL(LNK=0))[STOPC] 03443000 - &(IF LNK=0 THEN SEGMNT ELSE LNK)[LINKC] 03444000 - &(T1.DTYPF)[MODEC] 03445000 - &5[1:45:3], 03446000 - PRT[PRTADR.[36:5],PRTADR.[41:7]]); 03447000 - SEGDICT[SEGMNT.[36:5],SEGMNT.[41:7]].PRTLINKF ~ PRTADR; 03448000 - END 03449000 - ELSE 03450000 - BEGIN % SEGMENT DICTIONARY ENTRY 03451000 - SEGMNT ~ T1.SGNOF; 03452000 - SEGDICT[SEGMNT.[36:5],SEGMNT.[41:7]]~ 03453000 - SEGDICT[SEGMNT.[36:5],SEGMNT.[41:7]] 03454000 - &T1[SGLCC] 03455000 - &T1[DKADRC] 03456000 - & T1[4:12:1] 03457000 - &T1[6:6:1] 03458000 - &T1[1:1:2]; 03459000 - TSEGSZ ~ TSEGSZ + T1.SEGSZF; 03460000 - END; 03461000 - COMMENT WRITE OUT FILE PARAMETER BLOCK; 03462000 - FPBSZ ~ ((FPE.[33:15] - FPS) | 8 + FPE.[30:3] + 9) DIV 8; 03463000 - I ~ (FPBSZ + 29) DIV 30; 03464000 - IF DALOC DIV CHUNK < T1 ~ (DALOC +I) DIV CHUNK 03465000 - THEN DALOC ~ CHUNK | T1; 03466000 - SEG0[4] ~ DALOC; 03467000 - SEG0[5] ~ FPBSZ; 03468000 - SEG0[5].FPBVERSF~FPBVERSION; 03469000 - FOR I ~ 0 STEP 30 WHILE I < FPBSZ DO 03470000 - BEGIN 03471000 - MOVE(FPB[I],CODE(0),IF (FPBSZ-I) } 30 03472000 - THEN 30 ELSE (FPBSZ-I)); 03473000 - WRITE(CODE[DALOC]); 03474000 - DALOC ~ DALOC + 1; 03475000 - END; 03476000 - SEG0[2] ~ MOVEANDBLOCK(PRT,PRTS+1); % WRITES OUT PRT 03477000 - % SAVES ADDRESS OF PRT 03478000 - SEG0[3] ~ PRTS + 1; % SIZE OF PRT 03479000 - SEG0[0] ~ MOVEANDBLOCK(SEGDICT,NXAVIL + 1); % WRITE SEG DICT 03480000 - SEG0[1] ~ NXAVIL + 1; % SIZE OF SEGMENT DICTIONARY 03481000 - SEG0[6] ~ -GSEG; % FIRST SEGMENT TO EXECUTE 03482000 - SEG0[7].[33:15] ~ FPBI; % NUMBER OF FILES 03483000 - SEG0[7].[18:15] ~ ESTIMATE ~ IF % CORE ESTIMATE 03484000 - ( I ~ 03485000 - ESTIMATE+60+ %%% OPTION FILE BUFF SIZES + DEFAULT BUFF SIZES.03486000 - PRTS + 512 % PRT AND STACK SIZE 03487000 - +TSEGSZ % TOTAL SIZE OF CODE 03488000 - + 1022 % FOR INTRINSICS 03489000 - +ARYSZ % TOTAL ARRAY SIZE 03490000 - + (MAXFILES | 28) % SIZE OF ALL FIBS 03491000 - +FPBSZ % SIZE OF FILE PARAMETER BLOCK 03492000 - + (IF ESTIMATE = 0 THEN 0 ELSE (ESTIMATE + 1000)) 03493000 - + (NXAVIL + 1) % SIZE OF SEGMENT DICTIONARY 03494000 - ) > 32768 THEN 510 ELSE (I DIV 64); 03495000 - COMMENT IF SEGSW THEN UPDATE LINDICT, SEG0[0] & WRITE IT ; 03496000 - SEG0[7].[2:1] ~ 1; % USED FOR FORTRAN FAULT DEC; 03497000 - IF SEGSW THEN 03498000 - BEGIN 03499000 - FOR I ~ NXAVIL + 1 STEP -1 UNTIL 1 DO 03500000 - IF LINEDICT[I.IR,I.IC] = 0 THEN % INDICATE NO LINE SEGMENT 03501000 - LINEDICT[I.IR,I.IC] ~ -1; % FOR THIS SEGMENT 03502000 - SEG0[0] ~ SEG0[0] & (MOVEANDBLOCK(LINEDICT,NXAVIL+1))[TOBASE]; 03503000 - END; 03504000 - WRITE(CODE[0],30,SEG0[*]); 03505000 - IF ERRORCT = 0 AND SAVETIME } 0 THEN LOCK(CODE); 03506000 - ENDWRAPUP: 03507000 - LOCK(TAPE); %RW/L TAPE FILE OR LOCK DISK %502-03508000 - IF NTAPTOG THEN LOCK(NEWTAPE,*); %RW/L TAPE OR CRUNCH DISK%502-03509000 - END WRAPUP; 03510000 -PROCEDURE INITIALIZATION; 03511000 -BEGIN COMMENT INITIALIZATION; 03512000 -ALPHA STREAM PROCEDURE MKABS(P); 03513000 -BEGIN SI ~ P; MKABS ~ SI END; 03514000 -STREAM PROCEDURE BLANKOUT(CRD, N); VALUE N; 03515000 -BEGIN DI ~ CRD; N(DS ~ LIT " ") END; 03516000 -BLANKOUT(CRD[10], 40); 03517000 -BLANKOUT(LASTSEQ, 8); 03518000 -BLANKOUT(LASTERR, 8); 03519000 -INITIALNCR ~ MKABS(CRD[0])&6[30:45:3]; 03520000 -CHR0 ~ MKABS(ACCUM[0])& 2[30:45:3]; 03521000 -ACR0 ~ CHR0+1; 03522000 -ACR1 ~ (CHR1~MKABS(EXACCUM[0]) & 2[30:45:3]) +1; 03523000 -ACCUMSTOP~MKABS(ACCUM[11]); EXACCUMSTOP~MKABS(EXACCUM[11]) ; 03524000 -BUFL ~ MKABS(BUFF) & 2[30:45:3]; 03525000 -NEXTCARD ~ 1; 03526000 -GLOBALNEXTINFO ~ 4093; 03527000 -PDINX ~ 1; 03528000 -LASTNEXT~1000 ; 03529000 -PRTS ~ 41; % CURRENTLY . . . . . LAST USED PRT 03530000 -READ(CR, 10, CB[*]); 03531000 -LISTOG~TRUE; SINGLETOG~TRUE; CHECKTOG ~ FALSE; %DEFAULT %501- 03532000 -FIRSTCALL ~ TRUE; 03533000 -IF BOOLEAN(ERRORCT.[46:1]) THEN LISTOG ~ FALSE; 03534000 -IF BOOLEAN(ERRORCT.[47:1]) THEN DCINPUT ~ TRUE; 03535000 -ERRORCT ~ 0; 03536000 -IF DCINPUT THEN SEGSW ~ TRUE; 03537000 -IF DCINPUT THEN REMOTETOG ~ TRUE; 03538000 -LIMIT~IF DCINPUT THEN 20 ELSE 100 ; 03539000 -IF SEGSW THEN SEGSWFIXED ~ TRUE; 03540000 -EXTRAINFO[0,0] ~ 0 & EXPCLASS[TOCLASS]; 03541000 -NEXTEXTRA ~ 1; 03542000 -LASTMODE ~ 1; 03543000 -DALOC ~ 1; 03544000 -TYPE ~ -1; 03545000 - MAP[0] ~ MAP[2] ~ MAP[4] ~ MAP[7] ~ -10; 03546000 - MAP[5] ~ 1; MAP[6] ~ 2; 03547000 -FILL XR[*] WITH 0,0,0,0,0,0,0, 03548000 - "INTEGE","R R"," "," "," REAL "," ", 03549000 - "LOGICA","L L","DOUBLE"," ","COMPLE","X X", 03550000 - "------","- -"," "," "," ---- "," ", 03551000 - "------","- -","------"," ","------","- -"; 03552000 -FILL TYPES[*] WITH " ","INTGER"," ","REAL ", 03553000 - "LOGCAL", "DOUBLE", "COMPLX"; 03554000 -FILL KLASS[*] WITH 03555000 - "NULL ", "ARRAY ", "VARBLE", "STFUN ", 03556000 - "NAMLST", "FORMAT", "ERROR ", "FUNCTN", 03557000 - "INTRSC", "EXTRNL", "SUBRTN", "COMBLK", 03558000 - "FILE "; 03559000 -FILL RESERVEDWORDSLP[*] WITH 03560000 - "CALL ","ENTR ","FORM ","GOTO ","IF ","READ ", 03561000 - "REAL ","WRIT ","DATA ","CLOS ","LOCK ","PURG ","CHAI ", 03562000 - "PRIN ","PUNC ", 03563000 - 0,"Y ","AT ",0,0,0,0,"E ",0,"E ",0,"E ",03564000 - "N ","T ","H "; 03565000 -FILL RESERVEDWORDS[*] WITH 03566000 - "ASSI ","BACK ","BLOC ","CALL ","COMM ","COMP ","CONT ", 03567000 - "DATA ","DIME ","DOUB ","END ","ENDF ","ENTR ","EQUI ", 03568000 - "EXTE ","FUNC ","GOTO ","INTE ","LOGI ","NAME ","PAUS ", 03569000 - "PRIN ","PROG ","PUNC ","READ ","REAL ","RETU ","REWI ", 03570000 - "STOP ","SUBR ","WRIT ", 03571000 - "CLOS ","LOCK ","PURG ", 03572000 - 0,0,0, 03573000 - "FIXF ","VARY ","AUXM ","RELE ", 03574000 - "IMPL ", 03575000 - "GN ","SPACE ","KDATA ",0,"ON ","LEX ","INUE ", 03576000 - 0,"NSION ","LEPRECIS",0,"ILE ","Y ","VALENCE ","RNAL " 03577000 - ,"TION ",0,"GER ","CAL ","LIST ","E ","T ",03578000 - "RAM ","H ",0,0,"RN ","ND ",0,"OUTINE ", 03579000 - "E ","E ",0,"E ",0,0,0,"D ","ING ", 03580000 - "EM ","ASE " 03581000 - ,"ICIT " 03582000 - ; 03583000 -FILL RESLENGTHLP[*] WITH 03584000 - 4,5,6,4,2,4,4,5,4,5,4,5,5,5,5; 03585000 -FILL LPGLOBAL[*] WITH 03586000 - 4, 13, 36, 17, 35, 25, 03587000 - 26, 31, 8, 32, 33, 34, 37, 22, 24; 03588000 -FILL RESLENGTH[*] WITH 03589000 - 0, 9, 9, 4, 6, 03590000 - 7, 8, 4, 9, 15, 03591000 - 3, 7, 5, 11, 8, 03592000 - 8, 4, 7, 7, 8, 03593000 - 5, 5, 7, 5, 4, 03594000 - 4, 6, 6, 4, 10, 5, 03595000 - 5, 4, 5, 0, 0, 0, 5, 7, 6, 7 03596000 - ,8 03597000 - ; 03598000 - FILL WOP[*] WITH 03599000 - "LITC"," ", 03600000 - "OPDC","DESC", 03601000 - 10,"DEL ", 11,"NOP ", 12,"XRT ", 16,"ADD ", 17,"AD2 ", 18,"PRL ", 03602000 - 19,"LNG ", 21,"GEQ ", 22,"BBC ", 24,"INX ", 35,"LOR ", 37,"GTR ", 03603000 - 38,"BFC ", 39,"RTN ", 40,"COC ", 48,"SUB ", 49,"SB2 ", 64,"MUL ", 03604000 - 65,"ML2 ", 67,"LND ", 68,"STD ", 69,"NEQ ", 70,"SSN ", 71,"XIT ", 03605000 - 72,"MKS ", 03606000 - 128,"DIV ",129,"DV2 ",130,"COM ",131,"LQV ",132,"SND ",133,"XCH ", 03607000 - 134,"CHS ",167,"RTS ",168,"CDC ",197,"FTC ",260,"LOD ",261,"DUP ", 03608000 - 278,"GBC ",280,"SSF ",294,"GFC ",322,"ZP1 ",384,"IDV ",453,"FTF ", 03609000 - 515,"MDS ",532,"ISD ",533,"LEQ ",534,"BBW ",548,"ISN ",549,"LSS ", 03610000 - 550,"BFW ",581,"EQL ",582,"SSP ",584,"ECM ",709,"CTC ",790,"GBW ", 03611000 - 806,"GFW ",896,"RDV ",965,"CTF ", 03612000 - 1023,1023,1023,1023,1023,1023,1023,1023,1023,1023,1023, 1023; 03613000 -FILL TIPE[*] WITH 10(-1),-19,-21,OCT300000000,-21,-2,-3,-4, 03614000 - 8(OCT300000000),OCT100000000,-5,-13,-4,-6,-7,-19,-11, 03615000 - 5(OCT100000000),-8,3(OCT300000000),-9,-10,-12,-13,-14,03616000 - -15,-100,-16,8(OCT300000000),-17,-6,-18,-19,-20,-21 ; 03617000 -FILL PERIODWORD[*] WITH 03618000 - "FALSE ", "TRUE ", "OR ", "AND ", "NOT ", 03619000 - "LT ", "LE ", "EQ ", "GT ", "GE ", "NE "; 03620000 -ACCUM[0] ~ EXACCUM[0] ~ "; "; 03621000 -INCLUDE ~ "NCLUDE" & "I"[6:42:6]; 03622000 -INSERTDEPTH ~ -1; 03623000 -FILL TEN[*] WITH % POWERS OF TEN TO PRT 22 03624000 - OCT1141000000000000, OCT1131200000000000, OCT1121440000000000,03625000 - OCT1111750000000000, OCT1102342000000000, OCT1073032400000000,03626000 - OCT1063641100000000, OCT1054611320000000, OCT1045753604000000,03627000 - OCT1037346545000000, OCT1011124027620000, OCT0001351035564000,03628000 - OCT0011643245121000, OCT0022214116345200, OCT0032657142036440,03629000 - OCT0043432772446150, OCT0054341571157602, OCT0065432127413542,03630000 - OCT0076740555316473, OCT0111053071060221, OCT0121265707274265,03631000 - OCT0131543271153342, OCT0142074147406233, OCT0152513201307702,03632000 - OCT0163236041571663, OCT0174105452130240, OCT0205126764556310,03633000 - OCT0216354561711772, OCT0231004771627437, OCT0241206170175346,03634000 - OCT0251447626234640, OCT0261761573704010, OCT0272356132665012,03635000 - OCT0303051561442215, OCT0313664115752660, OCT0324641141345435,03636000 - OCT0336011371636744, OCT0347413670206535, OCT0361131664625026,03637000 - OCT0371360241772234, OCT0401654312370703, OCT0412227375067064,03638000 - OCT0422675274304701, OCT0433454553366061, OCT0444367706263475,03639000 - OCT0455465667740415, OCT0467003245730520, OCT0501060411731664,03640000 - OCT0511274514320241, OCT0521553637404312, OCT0532106607305374,03641000 - OCT0542530351166673, OCT0553256443424452, OCT0564132154331565,03642000 - OCT0575160607420123, OCT0606414751324147, OCT0621012014361120,03643000 - OCT0631214417455344, OCT0641457523370635, OCT0651773450267004,03644000 - OCT0662372362344605, OCT0673071057035747, OCT0703707272645341,03645000 - OCT0714671151416631, OCT0726047403722377, OCT0737461304707077,03646000 - OCT0751137556607071, OCT0761367512350710, OCT0771665435043072,03647000 - OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,03648000 - OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,03649000 - OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,03650000 - OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,03651000 - OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,03652000 - OCT0000000000000000, OCT0000000000000000, OCT0004000000000000,03653000 - OCT0001000000000000, OCT0001720000000000, OCT0004304000000000,03654000 - OCT0007365000000000, OCT0005262200000000, OCT0004536640000000,03655000 - OCT0001666410000000, OCT0000244112000000, OCT0000315134400000,03656000 - OCT0000400363500000, OCT0000450046042000, OCT0006562057452400,03657000 - OCT0004316473365100, OCT0005402212262320, OCT0006702654737004,03658000 - OCT0004463430126605, OCT0007600336154346, OCT0001540425607437,03659000 - OCT0004070533151347, OCT0005106662003641, OCT0005033043640461,03660000 - OCT0002241654610575, OCT0002712227752734, OCT0001474675745524,03661000 - OCT0002014055337051, OCT0004417070626663, OCT0007522706774440,03662000 - OCT0003447470573550, OCT0006361406732502, OCT0005005571052122,03663000 - OCT0006207127264547, OCT0001650755141700, OCT0006223150372260,03664000 - OCT0007670002470733, OCT0007646003207120, OCT0005617404050743,03665000 - OCT0001163305063137, OCT0007420166277771, OCT0001732422375777,03666000 - OCT0002321127075377, OCT0003005354714677, OCT0005606650100057,03667000 - OCT0007150422120072, OCT0003002526544103, OCT0001603254275130,03668000 - OCT0004144127354356, OCT0007175155247451, OCT0007034410521363,03669000 - OCT0007664351264566, OCT0003641443541723, OCT0004611754472310;03670000 -FILL INLINEINT[*] WITH % FILLS MUST BE IN ASCENDING ORDER FOR 03671000 - % BINARY SEARCH IN FUNCTION AND DOITINLINE. 03672000 - % INLINEINT[I].[1:1] = 1 ONCE CODE FOR INTRINSIC 03673000 - % HAS BEEN EMITTED INLINE.03674000 - % INLINEINT[I].[2:10]=INDEX INTO 2-ND WORD OF THE03675000 - % CORR ENTRY IN INT. 03676000 - % INLINEINT[I].[12:36]=NAME OF INTRINSIC. 03677000 -%********FIRST FILL MUST BE NUMBER OF INTRINSICS ****************** 03678000 -34, 03679000 -"00ABS ", 03680000 -"00AIMAG ", 03681000 -"00AINT ", 03682000 -"00AMAX0 ", 03683000 -"00AMAX1 ", 03684000 -"00AMIN0 ", 03685000 -"00AMIN1 ", 03686000 -"00AMOD ", 03687000 -"00AND ", 03688000 -"00CMPLX ", 03689000 -"00COMPL ", 03690000 -"00CONJG ", 03691000 -"00DABS ", 03692000 -"00DBLE ", 03693000 -"00DIM ", 03694000 -"00DSIGN ", 03695000 -"00EQUIV ", 03696000 -"00FLOAT ", 03697000 -"00IABS ", 03698000 -"00IDIM ", 03699000 -"00IDINT ", 03700000 -"00IFIX ", 03701000 -"00INT ", 03702000 -"00ISIGN ", 03703000 -"00MAX0 ", 03704000 -"00MAX1 ", 03705000 -"00MIN0 ", 03706000 -"00MIN1 ", 03707000 -"00MOD ", 03708000 -"00OR ", 03709000 -"00REAL ", 03710000 -"00SIGN ", 03711000 -"00SNGL ", 03712000 -"00TIME ", 03713000 - 0 ; 03714000 - FILL INT [*] WITH 03715000 -COMMENT THESE NAMES (1-ST WORD OF EACH TWO-WORD ENTRY) MUST BE IN 03716000 - ASCENDING ORDER FOR BINARY LOOKUPS. 03717000 - THE SECOND WORD HAS THE FOLLOWING FORMAT: 03718000 - .[1:1] = 0 IF THE INTRINSIC DOES NOT HAVE A PERMANENT PRT 03719000 - LOCATION, OTHERWISE = 1. MAY BE RESET BY 03720000 - WRAPUP. SEE .[18:6] BELOW. 03721000 - .[2:1] = .INTSEEN = 1 IFF INTRINSICS FUNCTION HAS BEEN SEEN. 03722000 - .[6:3] = .INTCLASS = CLASS OF THE INTRINSIC. 03723000 - .[9:3] = .INTPARMCLASS = CLASS OF PARAMETERS. 03724000 - .[12:6] = .INTINLINE = INDEX FOR DOITINLINE IF !0, OTHERWISE 03725000 - DO IT VIA INTRINSIC CALL. 03726000 - .[24:6] = .INTPRT = FIXED PRT LOCATION. SEE .[1:1] ABOVE. 03727000 - .[30:6] = .INTPARMS = NUMBER OF PARAMETERS REQUIRED BY THE INT.03728000 - .[36:12] = .INTNUM = INTRINSICS NUMBER. 03729000 - THE FIELDS .[3:3] AND .[18:6] ARE SO FAR UNUSED. 03730000 -; 03731000 -% 03732000 -%***********************************************************************03733000 -%********* IF YOU ADD AN INTRINSIC, BE SURE TO CHANGE NUMINTM1 *******03734000 -%********* AT SEQUENCE NUMBER 00155211.......THANK YOU. *******03735000 -%***********************************************************************03736000 -% 03737000 -"ABS ", OCT0033010000010007, 03738000 -"AIMAG ", OCT0036020000010074, 03739000 -"AINT ", OCT0033030000010054, 03740000 -"ALGAMA", OCT0033000000010127, 03741000 -"ALOG10", OCT0033000000010103, 03742000 -"ALOG ", OCT2033000035010017, 03743000 -"AMAX0 ", OCT0031250000000031, 03744000 -"AMAX1 ", OCT0033250000000031, 03745000 -"AMIN0 ", OCT0031250000000032, 03746000 -"AMIN1 ", OCT0033250000000032, 03747000 -"AMOD ", OCT0033040000020063, 03748000 -"AND ", OCT0033050000020130, 03749000 -"ARCOS ", OCT0033000000010117, 03750000 -"ARSIN ", OCT2033000032010116, 03751000 -"ATAN2 ", OCT2033000044020114, 03752000 -"ATAN ", OCT2033000037010016, 03753000 -"CABS ", OCT2036000045010053, 03754000 -"CCOS ", OCT0066000000010110, 03755000 -"CEXP ", OCT0066000000010100, 03756000 -"CLOG ", OCT0066000000010102, 03757000 -"CMPLX ", OCT0063060000020075, 03758000 -"COMPL ", OCT0033070000010132, 03759000 -"CONCAT", OCT0033000000050140, 03760000 -"CONJG ", OCT0066110000010076, 03761000 -"COSH ", OCT0033000000010121, 03762000 -"COS ", OCT0033000000010015, 03763000 -"COTAN ", OCT0033000000010112, 03764000 -"CSIN ", OCT0066000000010106, 03765000 -"CSQRT ", OCT0066000000010124, 03766000 -"DABS ", OCT0055010000010052, 03767000 -"DATAN2", OCT0055000000020115, 03768000 -"DATAN ", OCT2055000041010113, 03769000 -"DBLE ", OCT0053120000010062, 03770000 -"DCOS ", OCT0055000000010107, 03771000 -"DEXP ", OCT2055000047010077, 03772000 -"DIM ", OCT0033100000020072, 03773000 -"DLOG10", OCT0055000000010104, 03774000 -"DLOG ", OCT2055000042010101, 03775000 -"DMAX1 ", OCT0055000000000066, 03776000 -"DMIN1 ", OCT0055000000000067, 03777000 -"DMOD ", OCT2055000046020065, 03778000 -"DSIGN ", OCT0055130000020071, 03779000 -"DSIN ", OCT2055000043010105, 03780000 -"DSQRT ", OCT2055000050010123, 03781000 -"EQUIV ", OCT0033140000020133, 03782000 -"ERF ", OCT0033000000010125, 03783000 -"EXP ", OCT2033000033010020, 03784000 -"FLOAT ", OCT0031150000010060, 03785000 -"GAMMA ", OCT2033000040010126, 03786000 -"IABS ", OCT0011010000010007, 03787000 -"IDIM ", OCT0011100000020072, 03788000 -"IDINT ", OCT0015240000010057, 03789000 -"IFIX ", OCT0013030000010054, 03790000 -"INT ", OCT0013030000010054, 03791000 -"ISIGN ", OCT0011160000020070, 03792000 -".ERR. ", OCT2000000030000134, 03793000 -".FBINB", OCT0000000000000160, 03794000 -".FINAM", OCT0000000000000154, 03795000 -".FONAM", OCT0000000000000155, 03796000 -".FREFR", OCT0000000000000146, 03797000 -".FREWR", OCT0000000000000153, 03798000 -".FTINT", OCT0000000000000050, 03799000 -".FTNIN", OCT0000000000000156, 03800000 -".FTNOU", OCT0000000000000157, 03801000 -".FTOUT", OCT0000000000000051, 03802000 -".LABEL", OCT0000000000000021, 03803000 -".MATH ", OCT0000000000000055, 03804000 -".MEMHR", OCT0000000000000164, 03805000 -".XTOI ", OCT0000000000000056, 03806000 -"MAX0 ", OCT0011250000000135, 03807000 -"MAX1 ", OCT0013250000000135, 03808000 -"MIN0 ", OCT0011250000000136, 03809000 -"MIN1 ", OCT0013250000000136, 03810000 -"MOD ", OCT0011170000020137, 03811000 -"OR ", OCT0033200000020131, 03812000 -"REAL ", OCT0036210000010073, 03813000 -"SIGN ", OCT0033160000020070, 03814000 -"SINH ", OCT0033000000010120, 03815000 -"SIN ", OCT2033000034010014, 03816000 -"SNGL ", OCT0035230000010061, 03817000 -"SQRT ", OCT2033000031010013, 03818000 -"TANH ", OCT0033000000010122, 03819000 -"TAN ", OCT2033000036010111, 03820000 -"TIME ", OCT0031220000010064, 03821000 - 0; 03822000 -BLANKS~INLINEINT[MAX~0] ; 03823000 -FOR SCN~1 STEP 1 UNTIL BLANKS DO 03824000 - BEGIN 03825000 - EQVID~INLINEINT[SCN]; WHILE INT[MAX]!EQVID DO MAX~MAX+2 ; 03826000 - INLINEINT[SCN].INTX~MAX+1 ; 03827000 - END ; 03828000 -INTID.SUBCLASS ~ INTYPE; 03829000 -REALID.SUBCLASS ~ REALTYPE; 03830000 -EQVID ~ ".EQ000"; 03831000 -LISTID ~ ".LI000"; 03832000 -BLANKS ~ " "; 03833000 -ENDSEGTOG ~ TRUE; 03834000 -SCN ~ 7; 03835000 -MAX ~ REAL(NOT FALSE).[9:39]; 03836000 -SUPERMAXCOM~128|(MAXCOM+1) ; 03837000 -SEGPTOG ~ FALSE; %INHIBIT PAGE SKIP AFTER SUBROUTINES %501- 03838000 -END INITIALIZATION; 03839000 - 03840000 -ALPHA PROCEDURE NEED(T, C); VALUE T, C; ALPHA T, C; 03841000 -BEGIN INTEGER N; REAL ELBAT; 03842000 - REAL X; 03843000 - LABEL XIT, CHECK; 03844000 - ALPHA INFA, INFB, INFC; 03845000 -COMMENT NEED RETURNS THE ELBAT WORD FOR THE IDENTIFIER T. 03846000 -IF THIS IS THE FIRST OCCURRENCE OF T THEN AN INFO WORD IS BUILT AND 03847000 -GIVEN THEN CLASS C; 03848000 - ELBAT.CLASS ~ C; 03849000 - XTA ~ T; 03850000 - IF C { LABELID THEN 03851000 - BEGIN 03852000 - IF N ~ SEARCH(T) = 0 THEN N ~ ENTER(ELBAT, T) ELSE 03853000 - IF ELBAT ~ GET(N).CLASS = UNKNOWN 03854000 - THEN PUT(N,GET(N)&C[TOCLASS]) 03855000 - ELSE IF ELBAT ! C THEN FLOG(21); 03856000 - GO TO XIT; 03857000 - END; 03858000 - IF N ~ SEARCH(T) = 0 THEN 03859000 - BEGIN 03860000 - IF N ~ GLOBALSEARCH(T) ! 0 THEN GO TO CHECK; 03861000 - N ~ GLOBALENTER(ELBAT, T); 03862000 - GO TO XIT; 03863000 - END; 03864000 - GETALL(N,INFA,INFB,INFC); 03865000 - IF INFA.CLASS = DUMMY THEN BEGIN N ~ INFC.BASE; GO TO CHECK END; 03866000 - IF BOOLEAN(INFA. FORMAL) THEN GO TO CHECK; 03867000 - IF INFA.CLASS ! UNKNOWN THEN 03868000 - BEGIN 03869000 - IF N ~ GLOBALSEARCH(T) ! 0 THEN GO TO CHECK; 03870000 - ELBAT.SUBCLASS ~ INFA.SUBCLASS; 03871000 - N ~ GLOBALENTER(ELBAT, T); 03872000 - GO TO XIT; 03873000 - END; 03874000 - PUT(N, INFA & DUMMY[TOCLASS]); 03875000 - ELBAT.SUBCLASS ~ INFA .SUBCLASS; 03876000 - IF X ~ GLOBALSEARCH(T) = 0 THEN X ~ GLOBALENTER(ELBAT, T); 03877000 - PUT(N+2, INFC & X[TOBASE]); N ~ X; 03878000 - CHECK: 03879000 - INFA ~ GET(N); 03880000 - IF ELBAT ~ INFA .CLASS = UNKNOWN THEN 03881000 - BEGIN INFO[N.IR,N.IC].CLASS ~ C; GO TO XIT END; 03882000 - IF ELBAT ! C THEN 03883000 - IF ELBAT = EXTID AND 03884000 - (C = SUBRID OR C = FUNID) THEN 03885000 - INFO[N.IR,N.IC].CLASS ~ C 03886000 - ELSE IF (ELBAT=SUBRID OR ELBAT= FUNID) AND C = EXTID THEN 03887000 - ELSE FLOG(21); 03888000 - XIT: NEED ~ GETSPACE(N); 03889000 - XTA ~ NAME; % RESTORE XTA FOR DIAGNOSTIC PURPOSES 03890000 -END NEED; 03891000 -INTEGER PROCEDURE EXPR(B); VALUE B; BOOLEAN B; FORWARD; 03892000 -PROCEDURE SPLIT(A); VALUE A; REAL A; 03893000 -BEGIN 03894000 - EMITPAIR(JUNK, ISN); 03895000 - EMITD(40, DIA); 03896000 - EMITD(18, ISO); 03897000 - EMITDESCLIT(A); 03898000 - EMITO(LOD); 03899000 - EMITOPDCLIT(JUNK); 03900000 - EMITPAIR(255,CHS); 03901000 - EMITO(LND); 03902000 -END SPLIT; 03903000 -BOOLEAN PROCEDURE SUBSCRIPTS(LINK,FROM); VALUE LINK,FROM; 03904000 -INTEGER LINK, FROM; 03905000 -BEGIN INTEGER I, NSUBS, BDLINK; 03906000 - LABEL CONSTRUCT, XIT; 03907000 -REAL SUM, PROD, BOUND; 03908000 -REAL INFA,INFB,INFC; 03909000 -REAL SAVENSEG,SAVEADR ; 03910000 -INTEGER INDX; 03911000 -REAL INFD; 03912000 -BOOLEAN TOG, VARF; 03913000 -REAL SAVIT; 03914000 -DEFINE SS = LSTT#; 03915000 - 03916000 - 03917000 -IF DEBUGTOG THEN FLAGROUTINE(" SUBSC","RIPTS ",TRUE ) ; 03918000 - SAVIT ~ IT; 03919000 - LINK ~ GETSPACE(LINK); 03920000 -GETALL(LINK,INFA,INFB,INFC); 03921000 - IF INFA.CLASS ! ARRAYID THEN 03922000 - BEGIN XTA ~ INFB; FLOG(35); GO TO XIT END; 03923000 - NSUBS ~ INFC.NEXTRA; 03924000 - IF FROM = 4 THEN 03925000 - BEGIN IF NSUBS GTR SAVESUBS THEN SAVESUBS ~ NSUBS; 03926000 - IF NSUBS GTR NAMLIST[0] THEN NAMLIST[0] ~ NSUBS; 03927000 - NAMLIST[NAMEIND].[1:8] ~ NSUBS; 03928000 - INFD ~ GET(NEED(".SUBAR",BLOCKID)).ADDR; 03929000 - END; 03930000 - BDLINK ~ INFC.ADINFO-NSUBS+1; 03931000 - VARF ~ INFC < 0; 03932000 - FOR I ~ 1 STEP 1 UNTIL NSUBS DO 03933000 - BEGIN 03934000 - IT~IT+1; SAVENSEG~NSEG; SAVEADR~ADR ; 03935000 - IF EXPR(TRUE) > REALTYPE THEN FLAG(98); 03936000 - IF ADR=SAVEADR THEN FLAG(36) ; 03937000 - IF VARF THEN 03938000 - IF EXPRESULT=NUMCLASS AND NSEG=SAVENSEG THEN 03939000 - BEGIN 03940000 - ADR~SAVEADR ; 03941000 - EMITNUM(EXPVALUE-1); 03942000 - END ELSE EMITPAIR(1, SUB) 03943000 - ELSE 03944000 - IF EXPRESULT=NUMCLASS AND NSEG = SAVENSEG AND FROM NEQ 4 THEN 03945000 - BEGIN 03946000 - ADR~SAVEADR; IF SS[IT]~EXPVALUE{0 THEN FLAG(154) ; 03947000 - END 03948000 - ELSE SS[IT] ~ @9; 03949000 - IF FROM = 4 THEN 03950000 - BEGIN IF VARF THEN BEGIN EMITO(DUP); EMITPAIR(1,ADD); END; 03951000 - EMITL(INDX); INDX ~ INDX+1; 03952000 - EMITDESCLIT(INFD); 03953000 - EMITO(IF VARF THEN STD ELSE STN); 03954000 - END; 03955000 - IF I < NSUBS THEN 03956000 + IF NEXT ! NUM THEN BEGIN NEXT ~ NUM; XTA ~ T; FLOG(141) END; 02925100 + GO TO XIT; 02926000 +END; 02927000 +L6: % % OR ( %993-02929100 +BEGIN NEXT ~ LPAREN; GO TO XIT END; 02930000 +L7: % < %993-02930100 +BEGIN PREC ~ OP ~ 4; GO TO XIT END; 02931000 +L8: % LETTER 0 %993-02938100 +BEGIN IF DATATOG THEN IF CHECKOCTAL THEN GO TO XIT; 02939000 + IDINFO~TIPE[12]; GO BK ; 02939100 +END; 02939200 +L9: % $ %993-02942100 +BEGIN NEXT ~ DOLLAR; GO TO XIT END; 02943000 +L10: % * %993-02943100 +IF CHECKEXP(NCR, NCR, T) THEN 02944000 +BEGIN PREC ~ 9; OP ~ 15; NEXT ~ UPARROW; GO TO XIT END ELSE 02945000 +L11: 02945100 +BEGIN PREC ~ 7; OP ~ 13; NEXT ~ STAR; GO TO XIT END; 02946000 +L12: % - %993-02946100 +BEGIN PREC ~ 5; OP ~ 11; NEXT ~ MINUS; GO TO XIT END; 02947000 +L13: % ) OR [ %993-02947100 +BEGIN NEXT ~ RPAREN; GO TO XIT END; 02948000 +L14: % ; %993-02948100 +BEGIN NEXT ~ SEMI; GO TO XIT END; 02949000 +L15: % { %993-02949100 +BEGIN PREC ~ 4; OP ~ 5; GO TO XIT END; 02950000 +L16: % / %993-02951100 +BEGIN PREC ~ 7; OP ~ 14; NEXT ~ SLASH; GO TO XIT END; 02952000 +L17: % , %993-02960100 +BEGIN NEXT ~ COMMA; GO TO XIT END; 02961000 +L18: % ! %993-02962100 +BEGIN PREC ~ 4; OP ~ 9; GO TO XIT END; 02963000 +L19: % = OR ~ OR # %993- 02963100 +BEGIN NEXT ~ EQUAL; GO TO XIT END; 02964000 +L20: % ] %993-02964100 +BEGIN XTA ~ T; FLAG(0); GO TO CASESTMT END; 02965000 +L21: % " OR : OR @ %993-02965100 +BEGIN QUOTESTRING; GO TO XIT END; 02966000 +XIT: 02971000 +IF DEBUGTOG THEN WRITALIST(FD,3,NEXT,T," ",0,0,0,0,0) ; 02972000 + 02973000 + XTA ~ NAME ~ T; 02974000 +END SCAN; 02975000 +PROCEDURE WRAPUP; 02976000 + COMMENT WRAPUP OF COMPILIATION; 02977000 + BEGIN 02978000 +ARRAY PRT[0:7,0:127], 02979000 + SEGDICT[0:7,0:127], 02980000 + SEG0[0:29]; 02981000 +ARRAY FILES[0:BIGGESTFILENB]; 02982000 +INTEGER THEBIGGEST; 02983000 +SAVE ARRAY FPB[0:1022]; % FILE PARAMETER BLOCK 02984000 +REAL FPS,FPE; % START AND END OF FPB 02985000 +REAL GSEG,PRI,FID,MFID,IDNM,FILTYP,FPBI; 02986000 +BOOLEAN ALF; 02987000 +REAL PRTADR, SEGMNT, LNK, TSEGSZ, T1, I, FPBSZ; 02988000 + DEFINE 02988900 + SPDEUN= FPBSZ#, 02988910 + ENDDEF=#; 02988990 +ARRAY INTLOC[0:150]; 02989000 +REAL J; 02990000 +FORMAT SEGUS(A6, " IS SEGMENT ", I4, 02991000 + ", PRT IS ", A4, "."); 02992000 +LIST SEGLS(IDNM,NXAVIL,T1); 02993000 +LABEL LA, ENDWRAPUP; 02997000 + LABEL QQQDISKDEFAULT; %503-02997010 + COMMENT FORMAT OF SEGMENT DICTIONARY -RUN TIME ; 02998000 +DEFINE SGTYPF= [1:2]#, %0 = PROGRAM SEGMENTS 02999000 + SGTYPC= 1:46:2#,%1 = MCP INTRINSIC 03000000 + %2 = DATA SEGMENT 03001000 + PRTLINKF= [8:10]#, % LINK TO FIRT PRT ENTRY 03002000 + PRTLINKC= 8:38:10#, 03003000 + SGLCF = [18:15]#, % SEGMENT SIZE 03004000 + SGLCC = 23:38:10#, 03005000 + DKADRF = [33:15]#, % RELATIVE DISK ADDRESS OF SEGMENT 03006000 + % OR MCP INTRINSIC NUMBER 03007000 + DKADRC = 33:13:15#; 03008000 + COMMENT FORMAT OF FIRST SEGMENT OF CODE FILE- RUN TIME; 03009000 +COMMENT SEGO[0:29] 03010000 + WORD CONTENTS 03011000 + 0 LOCATION OF SEGMENT DICTIONARY 03012000 + 1 SIZE OF SEGMENT DICTIONARY 03013000 + 2 LOCATION OF PRT 03014000 + 3 SIZE OF PRT 03015000 + 4 LOCATION OF FILE PARAMETER BLOCK 03016000 + 5 SIZE OF FILE PARAMETER BLOCK 03017000 + 6 STARTING SEGMENT NUMBER 03018000 + 7-[2:1] IND FORTRAN FAULT DEC 03018100 + 7-[18:15] NUMBER OF FILES 03019000 + 7-[33:15] CORE REQUIRED/64 03020000 + ; 03021000 + COMMENT FORMAT OF PRT; 03022000 + % FLGF = [0:4] = 1101 = SET BY STREAM 03023000 +DEFINE MODEF =[4:2]#, % 0 = THUNK 03024000 + MODEC=4:46:2#, % 1 = WORD MODE PROGRAM DESCRIPTOR 03025000 + % 2 = LABEL DESCRIPTOR 03026000 + % 3 = CHARACTER MODE PROGRAM DESCRIPTOR 03027000 + STOPF =[6:1]#, % STOPPER = 1 FOR LAST DESCRIPTOR IN 03028000 + STOPC=6:47:1#, % CHAIN OF SAME SEGMENT DESCRIPTORS 03029000 + LINKF =[7:11]#, % IF STOP = 0 THEN PRTLINK 03030000 + LINKC=7:37:11#, % ELSE LINK TO SEGDICT 03031000 + FFF =[18:15]#,% INDEX INTO SEGMENT DICTIONARY 03032000 + FFC =18:33:15#, 03033000 + SINX = [33:15]#;% RELATIVE ADDRESS INTO SEGMENT 03034000 +DEFINE PDR = [37:5]#, 03035000 + PDC = [42:6]#; 03036000 +REAL STREAM PROCEDURE MKABS(F); 03037000 + BEGIN 03038000 + SI ~ F; MKABS ~ SI; 03039000 + END MKABS; 03040000 +REAL STREAM PROCEDURE BUILDFPB(DEST,FILNUM,FILTYP,MFID,FID,IDSZ, 03041000 + IDNM,SPDEUN); 03042000 + VALUE DEST,IDSZ,SPDEUN; 03043000 + BEGIN 03044000 + DI ~ DEST; 03045000 + SI ~ FILNUM; SI ~ SI + 6; DS ~ 2 CHR; 03046000 + SI ~ FILTYP; SI ~ SI + 7; DS ~ CHR; 03047000 + SI ~ MFID; SI ~ SI + 1; DS ~ 7 CHR; 03048000 + SI ~ FID; SI ~ SI + 1; DS ~ 7 CHR; 03049000 + SI ~ LOC IDSZ; SI ~ SI + 7; DS ~ CHR; 03050000 + SI ~ IDNM; SI ~ SI + 1; DS ~ IDSZ CHR; 03051000 + SI~LOC SPDEUN;SI~SI+6;DS~2 CHR;% DISK SPEED & EU NUMBER+1 03051200 + BUILDFPB ~ DI; 03052000 + DS ~ 2 LIT "0"; 03053000 + END BUILDFPB; 03054000 +REAL STREAM PROCEDURE GITSZ(F); 03055000 + BEGIN 03056000 + SI ~ F; SI ~SI + 7; TALLY ~ 7; 03057000 + 3(IF SC ! " " THEN JUMP OUT; 03058000 + SI ~SI - 1; TALLY ~ TALLY + 63;); 03059000 + GITSZ ~ TALLY; 03060000 + END GITSZ; 03061000 +STREAM PROCEDURE MOVE(F,T,SZ); VALUE SZ; 03062000 + BEGIN 03063000 + SI ~ F; DI ~T; DS ~ SZ WDS; 03064000 + END MOVE; 03065000 +INTEGER PROCEDURE MOVEANDBLOCK(FROM,SIZE); VALUE SIZE; 03066000 + ARRAY FROM[0,0]; INTEGER SIZE; 03067000 + BEGIN 03068000 + REAL T,NSEGS,J,I; 03069000 + STREAM PROCEDURE M2(F,T); BEGIN SI~F; DI~T; DS ~ 2 WDS; END M2; 03070000 + NSEGS ~ (SIZE+29) DIV 30; 03071000 + IF DALOC DIV CHUNK < T ~ (DALOC + NSEGS) DIV CHUNK 03072000 + THEN DALOC ~ CHUNK | T; 03073000 + MOVEANDBLOCK ~ DALOC; 03074000 + DO BEGIN FOR J ~ 0 STEP 2 WHILE J < 30 AND I 0 THEN 03106100 + BEGIN T1 ~ GET(T ~ GLOBALSEARCH(".SUBAR")+2); 03106125 + PUT(T,T1~T1&SAVESUBS[TOSIZE]); 03106150 + END; 03106175 + T1~PRGDESCBLDR(1,23,0,NSEG~NXAVIL~NXAVIL+1) ; % BUILD TPAR 03106200 + FILL LSTT[*] WITH 21(0),8(" ") ; % R+23 03106205 + WRITEDATA(29,NXAVIL,LSTT) ; 03106210 + PDPRT[(PDINX-1).[37:5],(PDINX-1).[42:6]].[6:1]~1 ; % SAVE BIT 03106215 + T1 ~ PRGDESCBLDR(1,22,0,NSEG ~ NXAVIL ~ NXAVIL + 1); 03107000 + WRITEDATA (138,NXAVIL,TEN); % POWERS OF TEN TABLE 03108000 + IF LSTI > 0 THEN 03109000 + BEGIN 03110000 + WRITEDATA(LSTI, NXAVIL ~ NXAVIL+1, LSTP); 03111000 + LSTA ~ PRGDESCBLDR(1, LSTA, 0, NXAVIL); 03112000 + END; 03113000 + IF TWODPRTX ! 0 THEN 03114000 + BEGIN 03115000 + FILL LSTT[*] WITH 03116000 + OCT0000000421410010, 03117000 + OCT0301001301412025, 03118000 + OCT2021010442215055, 03119000 + OCT2245400320211025, 03120000 + OCT0106177404310415, 03121000 + OCT1025042112350000; 03122000 + T ~ PRGDESCBLDR(0, TWODPRTX, 0, NXAVIL ~ NXAVIL+1); 03123000 + WRITEDATA(-6, NXAVIL, LSTT); 03124000 + END; 03125000 + COMMENT DECLARE GLOBAL FILES AND ARRAYS; 03126000 + FPS ~ FPE ~ MKABS(FPB); 03127000 + SEGMENTSTART; 03128000 + F2TOG ~ TRUE; 03129000 + GSEG ~ NSEG; 03130000 + FPBI ~ 0; 03131000 + EMITL(0); EMITL(2); EMITO(SSF); 03132000 + EMITL(1); % SET BLOCK COUNTER TO 1 03133000 + EMITL(16); EMITO(STD); 03134000 + EMITL(0); EMITOPDCLIT(23); EMITO(DEL); 03138000 + EMITL(REAL(HOLTOG)); EMITPAIR(21,STD); 03139000 + I ~ GLOBALNEXTINFO; WHILE I < 4093 DO 03140000 + BEGIN 03141000 + I ~ I+3; 03142000 + GETALL(I,INFA,INFB,INFC); 03143000 + IF INFA.CLASS = FILEID THEN %SEE COMMENTS ON LINE 02118000 %992-03144000 + BEGIN 03145000 + FPBI ~ FPBI + 1; 03146000 + PRI ~ INFA .ADDR; 03147000 + IF (XTA ~ INFB ).[18:6] < 10 THEN 03148000 + BEGIN 03149000 + IF XTA ~ MAKEINT(XTA) > BIGGESTFILENB THEN FLAG(77) ELSE 03150000 + FILES[XTA] ~ PRI; 03151000 + IF XTA > THEBIGGEST THEN THEBIGGEST ~ XTA; 03152000 + END; 03153000 + EMITO(MKS); 03154000 + IF J ~ INFC .ADINFO ! 0 THEN % OPTION FILE 03155000 + BEGIN FILTYP ~ INFC .LINK; 03156000 + IDNM ~ " "&"FILE"[6:24:24]&INFB[30:18:18]; 03157000 + T1 ~ GITSZ(IDNM); 03158000 + FID ~ FILEINFO[2,J]; 03159000 + MFID ~ FILEINFO[1,J]; 03160000 + IF FILTYP}10 AND (T~FILEINFO[3,J].DKAREASZ)!0 THEN 03161000 + BEGIN %%% SET UP ; 03162000 + SPDEUN~FILEINFO[3,J].SENSPDEUNF; 03162005 + B~IF (B~((J~FILEINFO[0,J]).[18:12])/(IF A~J.[30:12]{0 THEN03162007 + 1 ELSE A)){0 THEN 1 ELSE B ; 03162014 + %%% B=ORIGINAL "BLOCKING" SIZE = # LOGRECS/PHYSREC. 03162020 + A~ENTIER(B|ENTIER(T/(20|B)+.999999999)+.5) ; 03162030 + %%% T="AREA" SIZE = # LOGRECS IN TOTAL FILE. 03162040 + %%% A=# LOGRECS PER ROW. 03162050 + B~ENTIER(T/A+.999999999) ; 03162060 + %%% B = # ROWS IN FILE. 03162070 + %%% EQUIVALENT ALGOL FILE DESCRIPTION = [B:A]. 03162080 + %%% THE ABOVE LOGIC YIELDS: SHORTEST ROW CONTAINING 03162090 + %%% AN INTEGER NUMBER OF PHYSICAL RECORDS AND WHICH 03162100 + %%% REQUIRES 20 OR FEWER ROWS FOR THE TOTAL AREA, T.03162110 + EMITNUM(B); EMITNUM(A) ; 03162120 + END ELSE 03162129 + BEGIN EMITL(0); EMITL(0); 03163000 + J ~ FILEINFO[0,J]; % THIS ONE HAS ALL THE GOODIES 03164000 + END; 03164010 + QQQDISKDEFAULT: %503-03164045 + ESTIMATE~ESTIMATE+(J.[42:6])|(IF A~J.[18:12]=0 THEN J.[30:12] 03164050 + ELSE A) ; 03164100 + EMITL(J.[4:2]); % LOCK 03165000 + EMITL(FPBI); % FILE PARAM INDEX 03166000 + 03167000 + EMITDESCLIT(PRI); % PRT OF FILE 03168000 + EMITL(J.[42:6]); % # BUFFERS 03169000 + EMITL(J.[3:1]); % RECORDING MODE 03170000 + EMITNUM(J.[30:12]) ; % RECORD SIZE 03171000 + EMITNUM(J.[18:12]) ; % BLOCK SIZE 03172000 + EMITNUM(J.[ 6:12]) ; % SAVE FACTOR 03173000 + END ELSE 03174000 + BEGIN 03175000 + ALF ~TRUE; 03176000 + IF(FILTYP~INFC.LINK=2 OR FILTYP=12)AND INFB.[18:6]{9 THEN 03177000 + IDNM ~ 0&"FILE"[6:24:24]&INFB[30:18:18] 03178000 + ELSE 03179000 + BEGIN 03180000 + ALF ~ FALSE; 03181000 + IF (IDNM ~ " "&INFB[6:18:30]) = "READR " THEN 03182000 + IDNM ~ "READER "; 03183000 + END; 03184000 +IF IDNM="READER " OR IDNM="FILE5 " THEN IDNM~"CARD " ELSE %503-03184010 +IF IDNM="FILE6 " THEN BEGIN IDNM~"PRINTER";FILTYP~18;END ELSE %503-03184020 + BEGIN %503-03184030 + EMITL(20); EMITL(600); FILTYP~12; %20 | 600 REC DISK %503-03184040 + J~0&2[42:42:6]&10[30:36:12]&300[18:36:12]; %503-03184050 + FID~IDNM; MFID~"FORTEMP"; T1~GITSZ(IDNM); %503-03184054 + GO TO QQQDISKDEFAULT; %503-03184060 + END; %503-03184070 + T1 ~ GITSZ(IDNM); 03185000 + FID ~ IDNM; 03186000 + MFID ~ 0; 03187000 + IF DCINPUT AND ALF THEN BEGIN 03187100 + EMITL(20); % DISK ROWS 03187200 + EMITL(100); % DISK RECORD PER ROW 03187300 + EMITL(2); % REWIND AND LOCK 03187400 + EMITL(FPBI); % FILE NUMBER 03187450 + EMITDESCLIT(PRI); % PRT OF FILE 03187500 + EMITL(2); % NUMBER OF BUFFERS 03187550 + EMITL(1); % RECORDING MODE 03187600 + EMITL(10); % RECORD SIZE 03187650 + EMITL(30); % BLOCK SIZE 03187700 + EMITL(1); % SAVE FACTOR 03187750 + END ELSE 03187800 + BEGIN 03187900 + EMITL(0); % DISK ROWS 03188000 + EMITL(0); % DISK RECORDS PER ROW 03189000 + EMITL(0); % REWIND & RELEASE 03190000 + EMITL(FPBI); % FILE NUMBER 03191000 + 03192000 + EMITDESCLIT(PRI); % PRT OF FILE 03193000 + EMITL(2); % 2 BUFFERS 03194000 + EMITL(REAL(ALF)); 03195000 + EMITL(IF FILTYP = 0 THEN 10 ELSE 17); 03196000 + EMITL(0); % 15 WORD BUFFERS 03197000 + EMITL(0); % SAVE FACTOR (SCRATCH BY DEFAULT) 03198000 + END; 03198500 + END; 03199000 + EMITL(11); % INPUT OR OUTPUT 03200000 + EMITL(8); % SWITCH CODE FOR BLOCK 03201000 + EMITOPDCLIT(5); % CALL BLOCK 03202000 + FPE~BUILDFPB(FPE,FPBI,FILTYP,MFID,FID,T1,IDNM,SPDEUN); 03203000 + IF PRTOG THEN WRITALIST(FILEF,3,IDNM.[6:6],IDNM,B2D(PRI), 03204000 + 0,0,0,0,0) ; 03204010 + END 03205000 + ELSE 03206000 + IF INFA.CLASS = BLOCKID THEN 03207000 + BEGIN 03208000 + IF PRTOG THEN WRITALIST(BLOKF,3,INFB,B2D(INFA.ADDR), 03209000 + INFC.SIZE,0,0,0,0,0) ; 03210000 + IF INFA < 0 THEN ARRAYDEC(I); 03211000 + END; 03212000 + IF (T1 ~ INFA .CLASS) } FUNID 03213000 + AND T1 { SUBRID THEN 03214000 + BEGIN 03215000 + PRI ~ 0; 03216000 + IF INFA .SEGNO = 0 THEN 03217000 + BEGIN 03218000 + A~0; B~NUMINTM1 ; 03219000 + WHILE A+1 < B DO 03220000 + BEGIN 03221000 + PRI ~ REAL(BOOLEAN(A+B) AND BOOLEAN(1022)); 03222000 + IF IDNM ~ INT[PRI] = INFB THEN GO TO FOUND; 03223000 + IF INFB < IDNM THEN B ~ PRI.[36:11] ELSE A ~ PRI.[36:11]; 03224000 + END; 03225000 + IF IDNM ~ INT[PRI~(A+B)|2-PRI] = INFB THEN GO TO FOUND; 03226000 + XTA ~ INFB; FLAG(30); 03227000 + GO TO LA; 03228000 + FOUND: 03229000 + IF (T1~INT[PRI+1].INTPARMS)!0 03230000 + AND INFC < 0 03231000 + THEN IF T1 ! INFC.NEXTRA THEN 03232000 + BEGIN XTA ~ INFB ; FLAG(28); END; 03233000 + IF (FID~INTLOC[MFID~INT[PRI+1].INTNUM])=0 THEN 03234000 + BEGIN 03235000 + PDPRT[PDIR,PDIC] ~ 03236000 + 0&1[STYPC] 03237000 + &MFID[DKAC] 03238000 + &(FID ~ INTLOC[MFID] ~ NXAVIL ~ NXAVIL + 1)[SGNOC] 03239000 + &1[SEGSZC]; 03240000 + PDINX ~ PDINX + 1; 03241000 + END; 03242000 + T1 ~ PRGDESCBLDR(1,INFA .ADDR,0,FID); 03243000 + IF PRTOG THEN WRITALIST(SEGUS,3,IDNM,FID,B2D(T1),0,0,0,0,0) ; 03244000 + IF INT[PRI+1] < 0 THEN 03245000 + BEGIN 03246000 + T1 ~ PRGDESCBLDR(1,INT[PRI+1].INTPRT,0,FID); 03247000 + INT[PRI+1] ~ ABS(INT[PRI + 1]); 03248000 + END; 03249000 + END 03250000 + ELSE IF PRTOG THEN WRITALIST(SEGUS,3,INFB, 03251000 + INFA.SEGNO,B2D(INFA.ADDR),0,0,0,0,0) ; 03252000 + END; 03253000 + LA: 03254000 + END; 03255000 +COMMENT MUST FOLLOW THE FOR STATEMENT; 03256000 +IF FILEARRAYPRT ! 0 THEN 03257000 +BEGIN % BUILDING OBJECT TIME FILE SEARCH ARRAY 03258000 + J ~ PRGDESCBLDR(1,FILEARRAYPRT,0,NXAVIL ~ NXAVIL + 1); 03259000 + WRITEDATA(THEBIGGEST + 1,NXAVIL,FILES); 03260000 +END; 03261000 + XTA ~ BLANKS; 03262000 + IF NXAVIL > 1023 THEN FLAG(45); 03263000 + IF PRTS > 1023 THEN FLAG(46); 03264000 + IF STRTSEG = 0 THEN FLAG(65); 03265000 + PRI ~ 0; 03266000 + WHILE (IDNM ~ INT[PRI]) ! 0 DO 03267000 + IF INT[PRI+1] } 0 THEN PRI ~ PRI + 2 ELSE 03268000 + BEGIN 03269000 + IF (FID~INTLOC[MFID~INT[PRI+1].INTNUM])=0 THEN 03270000 + BEGIN 03271000 + PDPRT[PDIR,PDIC] ~ 03272000 + 0&1[STYPC] 03273000 + &MFID[DKAC] 03274000 + &(FID ~ INTLOC[MFID] ~ NXAVIL ~ NXAVIL + 1)[SGNOC] 03275000 + &1[SEGSZC]; 03276000 + PDINX ~ PDINX + 1; 03277000 + END; 03278000 + T1 ~ PRGDESCBLDR(1,INT[PRI + 1].INTPRT,0,FID); 03279000 + PRI ~ PRI+2; 03280000 + END; 03281000 + FOR I ~ 1 STEP 1 UNTIL BDX DO 03282000 + BEGIN EMITO(MKS); EMITOPDCLIT(BDPRT[I]) END; 03283000 + EMITO(MKS); 03284000 + EMITOPDCLIT(STRTSEG.[18:15]); 03285000 + T ~ PRGDESCBLDR(1,0,0,NSEG); 03288000 + SEGMENT((ADR+4) DIV 4,NSEG,FALSE,EDOC); 03289000 + IF ERRORCT ! 0 THEN GO TO ENDWRAPUP; 03290000 + FILL SEG0[*] WITH 03291000 + OCT020005, % BLOCK 03292000 + OCT220014, % WRITE 03293000 + OCT230015, % READ 03294000 + OCT240016; % FILE CONTROL 03295000 + COMMENT INTRINSIC FUNCTIONS; 03296000 + FOR I ~ 0 STEP 1 UNTIL 3 DO 03297000 + BEGIN 03298000 + T1 ~ PRGDESCBLDR(1,SEG0[I].[36:12],0, 03299000 + NSEG ~ NXAVIL ~ NXAVIL + 1); 03300000 + PDPRT[PDIR,PDIC] ~ 03301000 + 0&1[STYPC] 03302000 + &(SEG0[I].[30:6])[DKAC] 03303000 + &NXAVIL[SGNOC] 03304000 + &1[SEGSZC]; 03305000 + PDINX ~ PDINX + 1; 03306000 + END; 03307000 + COMMENT GENERATE PRT AND SEGMENT DICTIONARY; 03308000 + PRT[0,41] ~ PDPRT[0,0] & 63[10:42:6]; % USED FOR FAULT OPTN 03308100 + FOR I ~ 1 STEP 1 UNTIL PDINX-1 DO 03309000 + IF (T1~PDPRT[I.PDR,I.PDC]).SEGSZF = 0 THEN 03310000 + BEGIN % PRT ENTRY 03311000 + PRTADR ~T1.PRTAF; 03312000 + SEGMNT ~T1.SGNOF; 03313000 + LNK ~ SEGDICT[SEGMNT.[36:5], SEGMNT.[41:7]].PRTAF; 03314000 + MDESC(T1.RELADF&SEGMNT[FFC] 03315000 + &(REAL(LNK=0))[STOPC] 03316000 + &(IF LNK=0 THEN SEGMNT ELSE LNK)[LINKC] 03317000 + &(T1.DTYPF)[MODEC] 03318000 + &5[1:45:3], 03319000 + PRT[PRTADR.[36:5],PRTADR.[41:7]]); 03320000 + SEGDICT[SEGMNT.[36:5],SEGMNT.[41:7]].PRTLINKF ~ PRTADR; 03321000 + END 03322000 + ELSE 03323000 + BEGIN % SEGMENT DICTIONARY ENTRY 03324000 + SEGMNT ~ T1.SGNOF; 03325000 + SEGDICT[SEGMNT.[36:5],SEGMNT.[41:7]]~ 03326000 + SEGDICT[SEGMNT.[36:5],SEGMNT.[41:7]] 03327000 + &T1[SGLCC] 03328000 + &T1[DKADRC] 03329000 + & T1[4:12:1] 03329100 + &T1[6:6:1] 03329200 + &T1[1:1:2]; 03330000 + TSEGSZ ~ TSEGSZ + T1.SEGSZF; 03331000 + END; 03332000 + COMMENT WRITE OUT FILE PARAMETER BLOCK; 03333000 + FPBSZ ~ ((FPE.[33:15] - FPS) | 8 + FPE.[30:3] + 9) DIV 8; 03334000 + I ~ (FPBSZ + 29) DIV 30; 03335000 + IF DALOC DIV CHUNK < T1 ~ (DALOC +I) DIV CHUNK 03336000 + THEN DALOC ~ CHUNK | T1; 03337000 + SEG0[4] ~ DALOC; 03338000 + SEG0[5] ~ FPBSZ; 03339000 + SEG0[5].FPBVERSF~FPBVERSION; 03340000 + FOR I ~ 0 STEP 30 WHILE I < FPBSZ DO 03341000 + BEGIN 03342000 + MOVE(FPB[I],CODE(0),IF (FPBSZ-I) } 30 03343000 + THEN 30 ELSE (FPBSZ-I)); 03344000 + WRITE(CODE[DALOC]); 03345000 + DALOC ~ DALOC + 1; 03346000 + END; 03347000 + SEG0[2] ~ MOVEANDBLOCK(PRT,PRTS+1); % WRITES OUT PRT 03348000 + % SAVES ADDRESS OF PRT 03349000 + SEG0[3] ~ PRTS + 1; % SIZE OF PRT 03350000 + SEG0[0] ~ MOVEANDBLOCK(SEGDICT,NXAVIL + 1); % WRITE SEG DICT 03351000 + SEG0[1] ~ NXAVIL + 1; % SIZE OF SEGMENT DICTIONARY 03352000 + SEG0[6] ~ -GSEG; % FIRST SEGMENT TO EXECUTE 03353000 + SEG0[7].[33:15] ~ FPBI; % NUMBER OF FILES 03354000 + SEG0[7].[18:15] ~ ESTIMATE ~ IF % CORE ESTIMATE 03355000 + ( I ~ 03356000 + ESTIMATE+60+ %%% OPTION FILE BUFF SIZES + DEFAULT BUFF SIZES.03356100 + PRTS + 512 % PRT AND STACK SIZE 03357000 + +TSEGSZ % TOTAL SIZE OF CODE 03358050 + + 1022 % FOR INTRINSICS 03358050 + +ARYSZ % TOTAL ARRAY SIZE 03359000 + + (MAXFILES | 28) % SIZE OF ALL FIBS 03360000 + +FPBSZ % SIZE OF FILE PARAMETER BLOCK 03361000 + + (IF ESTIMATE = 0 THEN 0 ELSE (ESTIMATE + 1000)) 03361100 + + (NXAVIL + 1) % SIZE OF SEGMENT DICTIONARY 03362000 + ) > 32768 THEN 510 ELSE (I DIV 64); 03363000 + COMMENT IF SEGSW THEN UPDATE LINDICT, SEG0[0] & WRITE IT ; 03363100 + SEG0[7].[2:1] ~ 1; % USED FOR FORTRAN FAULT DEC; 03363150 + IF SEGSW THEN 03363200 + BEGIN 03363300 + FOR I ~ NXAVIL + 1 STEP -1 UNTIL 1 DO 03363400 + IF LINEDICT[I.IR,I.IC] = 0 THEN % INDICATE NO LINE SEGMENT 03363500 + LINEDICT[I.IR,I.IC] ~ -1; % FOR THIS SEGMENT 03363600 + SEG0[0] ~ SEG0[0] & (MOVEANDBLOCK(LINEDICT,NXAVIL+1))[TOBASE]; 03363700 + END; 03363800 + WRITE(CODE[0],30,SEG0[*]); 03364000 + IF ERRORCT = 0 AND SAVETIME } 0 THEN LOCK(CODE); 03365000 + ENDWRAPUP: 03366000 + LOCK(TAPE); %RW/L TAPE FILE OR LOCK DISK %502-03366100 + IF NTAPTOG THEN LOCK(NEWTAPE,*); %RW/L TAPE OR CRUNCH DISK%502-03366200 + END WRAPUP; 03367000 +PROCEDURE INITIALIZATION; 03368000 +BEGIN COMMENT INITIALIZATION; 03369000 +ALPHA STREAM PROCEDURE MKABS(P); 03370000 +BEGIN SI ~ P; MKABS ~ SI END; 03371000 +STREAM PROCEDURE BLANKOUT(CRD, N); VALUE N; 03372000 +BEGIN DI ~ CRD; N(DS ~ LIT " ") END; 03373000 +BLANKOUT(CRD[10], 40); 03374000 +BLANKOUT(LASTSEQ, 8); 03374100 +BLANKOUT(LASTERR,8) ; 03374200 +INITIALNCR ~ MKABS(CRD[0])&6[30:45:3]; 03375000 +CHR0 ~ MKABS(ACCUM[0])& 2[30:45:3]; 03376000 +ACR0 ~ CHR0+1; 03377000 +ACR1 ~ (CHR1~MKABS(EXACCUM[0]) & 2[30:45:3]) +1; 03378000 +ACCUMSTOP~MKABS(ACCUM[11]); EXACCUMSTOP~MKABS(EXACCUM[11]) ; 03378100 +BUFL ~ MKABS(BUFF) & 2[30:45:3]; 03379000 +NEXTCARD ~ 1; 03380000 +GLOBALNEXTINFO ~ 4093; 03381000 +PDINX ~ 1; 03381100 +LASTNEXT~1000 ; 03381200 +PRTS ~ 41; % CURRENTLY . . . . . LAST USED PRT 03382000 +READ(CR, 10, CB[*]); 03383000 +LISTOG~TRUE; SINGLETOG~TRUE; CHECKTOG ~ FALSE; %DEFAULT %501- 03384000 +FIRSTCALL ~ TRUE; 03385000 +IF BOOLEAN(ERRORCT.[46:1]) THEN LISTOG ~ FALSE; 03385100 +IF BOOLEAN(ERRORCT.[47:1]) THEN DCINPUT ~ TRUE; 03385200 +ERRORCT ~ 0; 03385300 +IF DCINPUT THEN SEGSW ~ TRUE; 03385350 +IF DCINPUT THEN REMOTETOG ~ TRUE; 03385355 +LIMIT~IF DCINPUT THEN 20 ELSE 100 ; 03385360 +IF SEGSW THEN SEGSWFIXED ~ TRUE; 03385400 +EXTRAINFO[0,0] ~ 0 & EXPCLASS[TOCLASS]; 03386000 +NEXTEXTRA ~ 1; 03387000 +LASTMODE ~ 1; 03387100 +DALOC ~ 1; 03388000 +TYPE ~ -1; 03389000 + MAP[0] ~ MAP[2] ~ MAP[4] ~ MAP[7] ~ -10; 03390000 + MAP[5] ~ 1; MAP[6] ~ 2; 03391000 +FILL XR[*] WITH 0,0,0,0,0,0,0, 03391100 + "INTEGE","R R"," "," "," REAL "," ", 03391200 + "LOGICA","L L","DOUBLE"," ","COMPLE","X X", 03391300 + "------","- -"," "," "," ---- "," ", 03391450 + "------","- -","------"," ","------","- -"; 03391450 +FILL TYPES[*] WITH " ","INTGER"," ","REAL ", 03392000 + "LOGCAL", "DOUBLE", "COMPLX"; 03393000 +FILL KLASS[*] WITH 03394000 + "NULL ", "ARRAY ", "VARBLE", "STFUN ", 03395000 + "NAMLST", "FORMAT", "ERROR ", "FUNCTN", 03396000 + "INTRSC", "EXTRNL", "SUBRTN", "COMBLK", 03397000 + "FILE "; 03398000 +FILL RESERVEDWORDSLP[*] WITH 03399000 + "CALL ","ENTR ","FORM ","GOTO ","IF ","READ ", 03400000 + "REAL ","WRIT ","DATA ","CLOS ","LOCK ","PURG ","CHAI ", 03401000 + "PRIN ","PUNC ", 03401100 + 0,"Y ","AT ",0,0,0,0,"E ",0,"E ",0,"E ",03401200 + "N ","T ","H "; 03401300 +FILL RESERVEDWORDS[*] WITH 03402000 + "ASSI ","BACK ","BLOC ","CALL ","COMM ","COMP ","CONT ", 03403000 + "DATA ","DIME ","DOUB ","END ","ENDF ","ENTR ","EQUI ", 03404000 + "EXTE ","FUNC ","GOTO ","INTE ","LOGI ","NAME ","PAUS ", 03405000 + "PRIN ","PROG ","PUNC ","READ ","REAL ","RETU ","REWI ", 03406000 + "STOP ","SUBR ","WRIT ", 03407000 + "CLOS ","LOCK ","PURG ", 03407100 + 0,0,0, 03407101 + "FIXF ","VARY ","AUXM ","RELE ", 03407102 + "IMPL ", 03407103 + "GN ","SPACE ","KDATA ",0,"ON ","LEX ","INUE ", 03407200 + 0,"NSION ","LEPRECIS",0,"ILE ","Y ","VALENCE ","RNAL "03407300 + ,"TION ",0,"GER ","CAL ","LIST ","E ","T ",03407400 + "RAM ","H ",0,0,"RN ","ND ",0,"OUTINE ", 03407500 + "E ","E ",0,"E ",0,0,0,"D ","ING ", 03407600 + "EM ","ASE " 03407601 + ,"ICIT " 03407602 + ; 03407990 +FILL RESLENGTHLP[*] WITH 03408000 + 4,5,6,4,2,4,4,5,4,5,4,5,5,5,5; 03409000 +FILL LPGLOBAL[*] WITH 03410000 + 4, 13, 36, 17, 35, 25, 03411000 + 26, 31, 8, 32, 33, 34, 37, 22, 24; 03411100 +FILL RESLENGTH[*] WITH 03412000 + 0, 9, 9, 4, 6, 03413000 + 7, 8, 4, 9, 15, 03414000 + 3, 7, 5, 11, 8, 03415000 + 8, 4, 7, 7, 8, 03416000 + 5, 5, 7, 5, 4, 03417000 + 4, 6, 6, 4, 10, 5, 03418000 + 5, 4, 5, 0, 0, 0, 5, 7, 6, 7 03418100 + ,8 03418101 + ; 03418990 + FILL WOP[*] WITH 03419000 + "LITC"," ", 03420000 + "OPDC","DESC", 03421000 + 10,"DEL ", 11,"NOP ", 12,"XRT ", 16,"ADD ", 17,"AD2 ", 18,"PRL ", 03422000 + 19,"LNG ", 21,"GEQ ", 22,"BBC ", 24,"INX ", 35,"LOR ", 37,"GTR ", 03423000 + 38,"BFC ", 39,"RTN ", 40,"COC ", 48,"SUB ", 49,"SB2 ", 64,"MUL ", 03424000 + 65,"ML2 ", 67,"LND ", 68,"STD ", 69,"NEQ ", 70,"SSN ", 71,"XIT ", 03425000 + 72,"MKS ", 03426000 + 128,"DIV ",129,"DV2 ",130,"COM ",131,"LQV ",132,"SND ",133,"XCH ", 03427000 + 134,"CHS ",167,"RTS ",168,"CDC ",197,"FTC ",260,"LOD ",261,"DUP ", 03428000 + 278,"GBC ",280,"SSF ",294,"GFC ",322,"ZP1 ",384,"IDV ",453,"FTF ", 03429000 + 515,"MDS ",532,"ISD ",533,"LEQ ",534,"BBW ",548,"ISN ",549,"LSS ", 03430000 + 550,"BFW ",581,"EQL ",582,"SSP ",584,"ECM ",709,"CTC ",790,"GBW ", 03431000 + 806,"GFW ",896,"RDV ",965,"CTF ", 03432000 + 1023,1023,1023,1023,1023,1023,1023,1023,1023,1023,1023, 1023; 03433000 +FILL TIPE[*] WITH 10(-1),-19,-21,OCT300000000,-21,-2,-3,-4, 03433100 + 8(OCT300000000),OCT100000000,-5,-13,-4,-6,-7,-19,-11, 03433110 + 5(OCT100000000),-8,3(OCT300000000),-9,-10,-12,-13,-14,03433120 + -15,-100,-16,8(OCT300000000),-17,-6,-18,-19,-20,-21 ; 03433130 +FILL PERIODWORD[*] WITH 03434000 + "FALSE ", "TRUE ", "OR ", "AND ", "NOT ", 03435000 + "LT ", "LE ", "EQ ", "GT ", "GE ", "NE "; 03436000 +ACCUM[0] ~ EXACCUM[0] ~ "; "; 03437000 +INCLUDE := "NCLUDE" & "I"[6:42:6]; 03437100 +INSERTDEPTH := -1; 03437110 +FILL TEN[*] WITH % POWERS OF TEN TO PRT 22 03438000 + OCT1141000000000000, OCT1131200000000000, OCT1121440000000000,03439000 + OCT1111750000000000, OCT1102342000000000, OCT1073032400000000,03440000 + OCT1063641100000000, OCT1054611320000000, OCT1045753604000000,03441000 + OCT1037346545000000, OCT1011124027620000, OCT0001351035564000,03442000 + OCT0011643245121000, OCT0022214116345200, OCT0032657142036440,03443000 + OCT0043432772446150, OCT0054341571157602, OCT0065432127413542,03444000 + OCT0076740555316473, OCT0111053071060221, OCT0121265707274265,03445000 + OCT0131543271153342, OCT0142074147406233, OCT0152513201307702,03446000 + OCT0163236041571663, OCT0174105452130240, OCT0205126764556310,03447000 + OCT0216354561711772, OCT0231004771627437, OCT0241206170175346,03448000 + OCT0251447626234640, OCT0261761573704010, OCT0272356132665012,03449000 + OCT0303051561442215, OCT0313664115752660, OCT0324641141345435,03450000 + OCT0336011371636744, OCT0347413670206535, OCT0361131664625026,03451000 + OCT0371360241772234, OCT0401654312370703, OCT0412227375067064,03452000 + OCT0422675274304701, OCT0433454553366061, OCT0444367706263475,03453000 + OCT0455465667740415, OCT0467003245730520, OCT0501060411731664,03454000 + OCT0511274514320241, OCT0521553637404312, OCT0532106607305374,03455000 + OCT0542530351166673, OCT0553256443424452, OCT0564132154331565,03456000 + OCT0575160607420123, OCT0606414751324147, OCT0621012014361120,03457000 + OCT0631214417455344, OCT0641457523370635, OCT0651773450267004,03458000 + OCT0662372362344605, OCT0673071057035747, OCT0703707272645341,03459000 + OCT0714671151416631, OCT0726047403722377, OCT0737461304707077,03460000 + OCT0751137556607071, OCT0761367512350710, OCT0771665435043072,03461000 + OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,03462000 + OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,03463000 + OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,03464000 + OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,03465000 + OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,03466000 + OCT0000000000000000, OCT0000000000000000, OCT0004000000000000,03467000 + OCT0001000000000000, OCT0001720000000000, OCT0004304000000000,03468000 + OCT0007365000000000, OCT0005262200000000, OCT0004536640000000,03469000 + OCT0001666410000000, OCT0000244112000000, OCT0000315134400000,03470000 + OCT0000400363500000, OCT0000450046042000, OCT0006562057452400,03471000 + OCT0004316473365100, OCT0005402212262320, OCT0006702654737004,03472000 + OCT0004463430126605, OCT0007600336154346, OCT0001540425607437,03473000 + OCT0004070533151347, OCT0005106662003641, OCT0005033043640461,03474000 + OCT0002241654610575, OCT0002712227752734, OCT0001474675745524,03475000 + OCT0002014055337051, OCT0004417070626663, OCT0007522706774440,03476000 + OCT0003447470573550, OCT0006361406732502, OCT0005005571052122,03477000 + OCT0006207127264547, OCT0001650755141700, OCT0006223150372260,03478000 + OCT0007670002470733, OCT0007646003207120, OCT0005617404050743,03479000 + OCT0001163305063137, OCT0007420166277771, OCT0001732422375777,03480000 + OCT0002321127075377, OCT0003005354714677, OCT0005606650100057,03481000 + OCT0007150422120072, OCT0003002526544103, OCT0001603254275130,03482000 + OCT0004144127354356, OCT0007175155247451, OCT0007034410521363,03483000 + OCT0007664351264566, OCT0003641443541723, OCT0004611754472310;03484000 +FILL INLINEINT[*] WITH % FILLS MUST BE IN ASCENDING ORDER FOR 03484100 + % BINARY SEARCH IN FUNCTION AND DOITINLINE. 03484120 + % INLINEINT[I].[1:1] = 1 ONCE CODE FOR INTRINSIC 03484122 + % HAS BEEN EMITTED INLINE.03484124 + % INLINEINT[I].[2:10]=INDEX INTO 2-ND WORD OF THE03484126 + % CORR ENTRY IN INT. 03484128 + % INLINEINT[I].[12:36]=NAME OF INTRINSIC. 03484130 +%********FIRST FILL MUST BE NUMBER OF INTRINSICS ****************** 03484140 +34, 03484160 +"00ABS ", 03484180 +"00AIMAG ", 03484200 +"00AINT ", 03484220 +"00AMAX0 ", 03484224 +"00AMAX1 ", 03484228 +"00AMIN0 ", 03484232 +"00AMIN1 ", 03484236 +"00AMOD ", 03484240 +"00AND ", 03484260 +"00CMPLX ", 03484280 +"00COMPL ", 03484300 +"00CONJG ", 03484320 +"00DABS ", 03484340 +"00DBLE ", 03484360 +"00DIM ", 03484380 +"00DSIGN ", 03484400 +"00EQUIV ", 03484420 +"00FLOAT ", 03484440 +"00IABS ", 03484460 +"00IDIM ", 03484480 +"00IDINT ", 03484500 +"00IFIX ", 03484520 +"00INT ", 03484540 +"00ISIGN ", 03484560 +"00MAX0 ", 03484564 +"00MAX1 ", 03484568 +"00MIN0 ", 03484572 +"00MIN1 ", 03484576 +"00MOD ", 03484580 +"00OR ", 03484600 +"00REAL ", 03484620 +"00SIGN ", 03484640 +"00SNGL ", 03484660 +"00TIME ", 03484680 + 0 ; 03484990 + FILL INT [*] WITH 03485000 +COMMENT THESE NAMES (1-ST WORD OF EACH TWO-WORD ENTRY) MUST BE IN 03486000 + ASCENDING ORDER FOR BINARY LOOKUPS. 03486010 + THE SECOND WORD HAS THE FOLLOWING FORMAT: 03486020 + .[1:1] = 0 IF THE INTRINSIC DOES NOT HAVE A PERMANENT PRT 03486030 + LOCATION, OTHERWISE = 1. MAY BE RESET BY 03486040 + WRAPUP. SEE .[18:6] BELOW. 03486050 + .[2:1] = .INTSEEN = 1 IFF INTRINSICS FUNCTION HAS BEEN SEEN. 03486055 + .[6:3] = .INTCLASS = CLASS OF THE INTRINSIC. 03486060 + .[9:3] = .INTPARMCLASS = CLASS OF PARAMETERS. 03486070 + .[12:6] = .INTINLINE = INDEX FOR DOITINLINE IF !0, OTHERWISE 03486080 + DO IT VIA INTRINSIC CALL. 03486090 + .[24:6] = .INTPRT = FIXED PRT LOCATION. SEE .[1:1] ABOVE. 03486100 + .[30:6] = .INTPARMS = NUMBER OF PARAMETERS REQUIRED BY THE INT.03486110 + .[36:12] = .INTNUM = INTRINSICS NUMBER. 03486120 + THE FIELDS .[3:3] AND .[18:6] ARE SO FAR UNUSED. 03486130 +; 03486140 +% 03486144 +%***********************************************************************03486145 +%********* IF YOU ADD AN INTRINSIC, BE SURE TO CHANGE NUMINTM1 *******03486146 +%********* AT SEQUENCE NUMBER 00155211.......THANK YOU. *******03486147 +%***********************************************************************03486148 +% 03486149 +"ABS ", OCT0033010000010007, 03487000 +"AIMAG ", OCT0036020000010074, 03488000 +"AINT ", OCT0033030000010054, 03489000 +"ALGAMA", OCT0033000000010127, 03490000 +"ALOG10", OCT0033000000010103, 03491000 +"ALOG ", OCT2033000035010017, 03492000 +"AMAX0 ", OCT0031250000000031, 03493000 +"AMAX1 ", OCT0033250000000031, 03494000 +"AMIN0 ", OCT0031250000000032, 03495000 +"AMIN1 ", OCT0033250000000032, 03496000 +"AMOD ", OCT0033040000020063, 03497000 +"AND ", OCT0033050000020130, 03498000 +"ARCOS ", OCT0033000000010117, 03499000 +"ARSIN ", OCT2033000032010116, 03500000 +"ATAN2 ", OCT2033000044020114, 03501000 +"ATAN ", OCT2033000037010016, 03501500 +"CABS ", OCT2036000045010053, 03502000 +"CCOS ", OCT0066000000010110, 03503000 +"CEXP ", OCT0066000000010100, 03504000 +"CLOG ", OCT0066000000010102, 03505000 +"CMPLX ", OCT0063060000020075, 03506000 +"COMPL ", OCT0033070000010132, 03507000 +"CONCAT", OCT0033000000050140, 03508000 +"CONJG ", OCT0066110000010076, 03509000 +"COSH ", OCT0033000000010121, 03510000 +"COS ", OCT0033000000010015, 03511000 +"COTAN ", OCT0033000000010112, 03512000 +"CSIN ", OCT0066000000010106, 03513000 +"CSQRT ", OCT0066000000010124, 03514000 +"DABS ", OCT0055010000010052, 03515000 +"DATAN2", OCT0055000000020115, 03516000 +"DATAN ", OCT2055000041010113, 03517000 +"DBLE ", OCT0053120000010062, 03518000 +"DCOS ", OCT0055000000010107, 03519000 +"DEXP ", OCT2055000047010077, 03520000 +"DIM ", OCT0033100000020072, 03521000 +"DLOG10", OCT0055000000010104, 03522000 +"DLOG ", OCT2055000042010101, 03522500 +"DMAX1 ", OCT0055000000000066, 03523000 +"DMIN1 ", OCT0055000000000067, 03524000 +"DMOD ", OCT2055000046020065, 03525000 +"DSIGN ", OCT0055130000020071, 03526000 +"DSIN ", OCT2055000043010105, 03527000 +"DSQRT ", OCT2055000050010123, 03528000 +"EQUIV ", OCT0033140000020133, 03529000 +"ERF ", OCT0033000000010125, 03530000 +"EXP ", OCT2033000033010020, 03531000 +"FLOAT ", OCT0031150000010060, 03532000 +"GAMMA ", OCT2033000040010126, 03533000 +"IABS ", OCT0011010000010007, 03534000 +"IDIM ", OCT0011100000020072, 03535000 +"IDINT ", OCT0015240000010057, 03536000 +"IFIX ", OCT0013030000010054, 03537000 +"INT ", OCT0013030000010054, 03538000 +"ISIGN ", OCT0011160000020070, 03539000 +".ERR. ", OCT2000000030000134, 03540000 +".FBINB", OCT0000000000000160, 03540500 +".FINAM", OCT0000000000000154, 03541000 +".FONAM", OCT0000000000000155, 03542000 +".FREFR", OCT0000000000000146, 03543000 +".FREWR", OCT0000000000000153, 03544000 +".FTINT", OCT0000000000000050, 03545000 +".FTNIN", OCT0000000000000156, 03546000 +".FTNOU", OCT0000000000000157, 03547000 +".FTOUT", OCT0000000000000051, 03548000 +".LABEL", OCT0000000000000021, 03549000 +".MATH ", OCT0000000000000055, 03550000 +".MEMHR", OCT0000000000000164, 03550500 +".XTOI ", OCT0000000000000056, 03551000 +"MAX0 ", OCT0011250000000135, 03552000 +"MAX1 ", OCT0013250000000135, 03553000 +"MIN0 ", OCT0011250000000136, 03554000 +"MIN1 ", OCT0013250000000136, 03555000 +"MOD ", OCT0011170000020137, 03556000 +"OR ", OCT0033200000020131, 03557000 +"REAL ", OCT0036210000010073, 03558000 +"SIGN ", OCT0033160000020070, 03559000 +"SINH ", OCT0033000000010120, 03560000 +"SIN ", OCT2033000034010014, 03561000 +"SNGL ", OCT0035230000010061, 03562000 +"SQRT ", OCT2033000031010013, 03563000 +"TANH ", OCT0033000000010122, 03563010 +"TAN ", OCT2033000036010111, 03563020 +"TIME ", OCT0031220000010064, 03563030 + 0; 03563900 +BLANKS~INLINEINT[MAX~0] ; 03563910 +FOR SCN~1 STEP 1 UNTIL BLANKS DO 03563920 + BEGIN 03563930 + EQVID~INLINEINT[SCN]; WHILE INT[MAX]!EQVID DO MAX~MAX+2 ; 03563940 + INLINEINT[SCN].INTX~MAX+1 ; 03563950 + END ; 03563960 +INTID.SUBCLASS ~ INTYPE; 03564000 +REALID.SUBCLASS ~ REALTYPE; 03565000 +EQVID ~ ".EQ000"; 03566000 +LISTID ~ ".LI000"; 03567100 +BLANKS ~ " "; 03568000 +ENDSEGTOG ~ TRUE; 03569000 +SCN ~ 7; 03570000 +MAX ~ REAL(NOT FALSE).[9:39]; 03571000 +SUPERMAXCOM~128|(MAXCOM+1) ; 03571100 +SEGPTOG ~ FALSE; %INHIBIT PAGE SKIP AFTER SUBROUTINES %501- 03571300 +END INITIALIZATION; 03572000 +ALPHA PROCEDURE NEED(T, C); VALUE T, C; ALPHA T, C; 03573000 +BEGIN INTEGER N; REAL ELBAT; 03574000 + REAL X; 03574100 + LABEL XIT, CHECK; 03575000 + ALPHA INFA, INFB, INFC; 03576000 +COMMENT NEED RETURNS THE ELBAT WORD FOR THE IDENTIFIER T. 03577000 +IF THIS IS THE FIRST OCCURRENCE OF T THEN AN INFO WORD IS BUILT AND 03578000 +GIVEN THEN CLASS C; 03579000 + ELBAT.CLASS ~ C; 03580000 + XTA ~ T; 03581000 + IF C { LABELID THEN 03582000 + BEGIN 03583000 + IF N ~ SEARCH(T) = 0 THEN N ~ ENTER(ELBAT, T) ELSE 03584000 + IF ELBAT ~ GET(N).CLASS = UNKNOWN 03585000 + THEN PUT(N,GET(N)&C[TOCLASS]) 03586000 + ELSE IF ELBAT ! C THEN FLOG(21); 03587000 + GO TO XIT; 03588000 + END; 03589000 + IF N ~ SEARCH(T) = 0 THEN 03590000 + BEGIN 03591000 + IF N ~ GLOBALSEARCH(T) ! 0 THEN GO TO CHECK; 03592000 + N ~ GLOBALENTER(ELBAT, T); 03593000 + GO TO XIT; 03594000 + END; 03595000 + GETALL(N,INFA,INFB,INFC); 03596000 + IF INFA.CLASS = DUMMY THEN BEGIN N ~ INFC.BASE; GO TO CHECK END; 03596100 + IF BOOLEAN(INFA. FORMAL) THEN GO TO CHECK; 03597000 + IF INFA.CLASS ! UNKNOWN THEN 03598000 + BEGIN 03599000 + IF N ~ GLOBALSEARCH(T) ! 0 THEN GO TO CHECK; 03600000 + ELBAT.SUBCLASS ~ INFA.SUBCLASS; 03601000 + N ~ GLOBALENTER(ELBAT, T); 03602000 + GO TO XIT; 03603000 + END; 03604000 + PUT(N, INFA & DUMMY[TOCLASS]); 03605000 + ELBAT.SUBCLASS ~ INFA .SUBCLASS; 03606000 + IF X ~ GLOBALSEARCH(T) = 0 THEN X ~ GLOBALENTER(ELBAT, T); 03607000 + PUT(N+2, INFC & X[TOBASE]); N ~ X; 03607100 + CHECK: 03608000 + INFA ~ GET(N); 03609000 + IF ELBAT ~ INFA .CLASS = UNKNOWN THEN 03610000 + BEGIN INFO[N.IR,N.IC].CLASS ~ C; GO TO XIT END; 03611000 + IF ELBAT ! C THEN 03612000 + IF ELBAT = EXTID AND 03613000 + (C = SUBRID OR C = FUNID) THEN 03614000 + INFO[N.IR,N.IC].CLASS ~ C 03615000 + ELSE IF (ELBAT=SUBRID OR ELBAT= FUNID) AND C = EXTID THEN 03616000 + ELSE FLOG(21); 03617000 + XIT: NEED ~ GETSPACE(N); 03618000 + XTA ~ NAME; % RESTORE XTA FOR DIAGNOSTIC PURPOSES 03618100 +END NEED; 03619000 +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 + 03795000 + 03796000 +IF DEBUGTOG THEN FLAGROUTINE(" BOU","NDS ",TRUE ); 03797000 + GETALL(FNEW, INFA, INFB, INFC); 03798000 + FIRSTSS ~ NEXTSS; 03799000 + IF LINK < 0 THEN BEGIN SINGLETOG ~ TRUE; LINK ~ ABS(LINK) END; %109-03799500 + LOOP: 03800000 + IF NEXT = ID THEN 03801000 + BEGIN 03802000 + T ~ GET(FNEXT ~ GETSPACE(FNEXT)); 03802100 + 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) ; 03810010 + 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; 03837000 + 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 03904000 + BEGIN IF PTYPE } DOUBTYPE THEN EMITO(XCH); 03904100 + EXTRAINFO[EX.IR,EX.IC].CLASS ~ EXPCLASS 03904200 + END ELSE FLAG(67); 03905000 + ; ; ; 03906000 + FLAG(68); 03907000 + IF EXPRESULT = EXTID THEN 03908000 + PUT(EXPLINK,GET(EXPLINK)&FUNID[TOCLASS]) ELSE 03909000 + FLAG(69); 03910000 + ; 03911000 + IF EXPRESULT = FUNID OR EXPRESULT = SUBRID THEN 03912000 + EXTRAINFO[EX.IR,EX.IC] ~ EXPRESULT ELSE FLAG(70); 03913000 + IF EXPRESULT = EXTID THEN 03914000 + PUT(EXPLINK,GET(EXPLINK)&SUBRID[TOCLASS]) ELSE 03915000 + FLAG(71); 03916000 + ; ; 03917000 + IF EXPRESULT = ARRAYID THEN EXTRAINFO[EX.IR,EX.IC].CLASS 03918000 + ~ ARRAYID ELSE 03919000 + IF EXPRESULT = VARID THEN 03920000 + BEGIN 03921000 + EXTRAINFO[EX.IR,EX.IC].CLASS ~ SBVEXP; 03922000 + EMITL(0) 03923000 + END ELSE 03924000 + IF EXPRESULT = EXPCLASS THEN 03925000 + BEGIN 03926000 + EXTRAINFO[EX.IR,EX.IC].CLASS ~ SBVEXP; 03927000 + IF PTYPE } DOUBTYPE THEN EMITO(XCH) ELSE EMITL(0); 03928000 + END ELSE FLAG(72); 03929000 + IF EXPRESULT = SUBSVAR THEN 03930000 + IF NOT INTFID THEN 03930100 + BEGIN EMITO(CDC); 03930200 + IF PTYPE } DOUBTYPE THEN EMITL(0) 03930300 + END 03930400 + ELSE 03930500 + ELSE IF EXPRESULT = VARID THEN 03930600 + IF NOT INTFID THEN 03930650 + IF PTYPE } DOUBTYPE THEN EMITL(0) ELSE ELSE 03930700 + ELSE FLAG(67); 03930800 + IF EXPRESULT = VARID THEN 03931000 + EMITL(0) ELSE 03932000 + IF EXPRESULT = EXPCLASS THEN 03933000 + IF PTYPE } DOUBTYPE THEN EMITO(XCH) ELSE EMITL(0) 03934000 + ELSE IF EXPRESULT ! SUBSVAR THEN FLAG(67); 03935000 + END OF CASE STATEMENT 03936000 + ELSE IF PTYPE } DOUBTYPE THEN 03936100 + IF EXPRESULT = VARID THEN EMITL(0) 03936200 + ELSE IF EXPRESULT = EXPCLASS AND NOT INTFID 03936300 + THEN EMITO(XCH); 03936400 + IF T ~ EXTRAINFO[EX.IR,EX.IC].SUBCLASS = 0 OR 03937000 + (T = INTYPE AND PTYPE = REALTYPE AND 03938000 + GET(LINK).SEGNO = 0) THEN 03939000 + EXTRAINFO[EX.IR,EX.IC].SUBCLASS ~ PTYPE ELSE 03940000 + IF NOT(T = PTYPE OR T = REALTYPE AND PTYPE = INTYPE ) THEN 03941000 + FLAG(88); 03942000 + END OF CHECK 03943000 + ELSE IF PTYPE } DOUBTYPE THEN 03943100 + IF EXPRESULT = VARID THEN EMITL(0) 03943200 + ELSE IF EXPRESULT = EXPCLASS THEN EMITO(XCH); 03943300 + IF NOTZEROP THEN EX ~ EX+1; 03944000 + IT ~ IT+1; 03945000 + END; 03946000 + IF GLOBALNEXT = COMMA THEN GO TO LOOP; 03947000 + NPARMS ~ IT - SAVIT; 03948000 + IF GLOBALNEXT ! RPAREN THEN FLOG(108); 03949000 + IF NOT CHECK THEN 03950000 + BEGIN 03951000 + INFC ~ GET(LINK+2); 03952000 + INFC ~ -(INFC & NPARMS[TONEXTRA] 03953000 + & NEXTEXTRA[TOADINFO]); 03954000 + PUT(LINK+2,INFC); 03955000 + FOR I ~ SAVIT STEP 1 UNTIL IT-1 DO 03956000 BEGIN 03957000 - IF GLOBALNEXT ! COMMA THEN 03958000 - BEGIN XTA ~ INFB; FLOG(23) END; 03959000 - SCAN; 03960000 - END; 03961000 - END; 03962000 - IF GLOBALNEXT ! RPAREN THEN BEGIN XTA ~ INFB; FLOG(24); END 03963000 - ELSE IF FROM < 2 THEN 03964000 - BEGIN SCAN; IF PREC > 0 THEN FROM ~ 1; END; 03965000 - SUM ~ 0; 03966000 - TOG ~ VARF; 03967000 - IF VARF THEN 03968000 - FOR I ~ NSUBS-1 STEP -1 UNTIL 1 DO 03969000 - BEGIN 03970000 - IF BOUND ~ EXTRAINFO[(BDLINK~BDLINK+1).IR,BDLINK.IC] < 0 THEN 03971000 - EMITOPDCLIT(BOUND) ELSE EMITNUM(BOUND); 03972000 - EMITO(MUL); 03973000 - EMITO(ADD); 03974000 - END 03975000 - ELSE 03976000 - FOR I ~ NSUBS STEP -1 UNTIL 1 DO 03977000 - BEGIN 03978000 - IF I = 1 THEN BOUND ~ 1 ELSE 03979000 - BOUND ~ EXTRAINFO[(BDLINK~BDLINK+1).IR,BDLINK.IC]; 03980000 - IF T ~ SS[SAVIT+I] < @9 THEN 03981000 - BEGIN 03982000 - SUM ~ (SUM+T-1)|BOUND; 03983000 - IF TOG THEN PROD ~ PROD|BOUND; 03984000 - END 03985000 - ELSE 03986000 - BEGIN 03987000 - IF TOG THEN BEGIN EMITNUM(PROD); EMITO(MUL); EMITO(ADD) END 03988000 - ELSE TOG ~ TRUE; 03989000 - PROD ~ BOUND; 03990000 - SUM ~ (SUM-1)|BOUND; 03991000 - END; 03992000 - END; 03993000 - IF VARF THEN T ~ @9; 03994000 - IF INFA.SUBCLASS } DOUBTYPE THEN 03995000 - BEGIN 03996000 - IF TOG THEN 03997000 - BEGIN 03998000 - IF T < @9 THEN EMITNUM(2|PROD) ELSE EMITL(2); 03999000 - EMITO(MUL); 04000000 - END; 04001000 - SUM ~ SUM|2; 04002000 - END ELSE 04003000 - IF T < @9 AND TOG THEN BEGIN EMITNUM(PROD); EMITO(MUL) END; 04004000 - IF BOOLEAN(INFA.CE) THEN 04005000 - SUM ~ SUM + INFC.BASE ELSE 04006000 - IF BOOLEAN(INFA.FORMAL) THEN 04007000 - BEGIN EMITOPDCLIT(INFA.ADDR-1); 04008000 - IF TOG THEN EMITO(ADD) ELSE TOG ~ TRUE; 04009000 - END; 04010000 - IF BOOLEAN(INFA.TWOD) AND FROM > 0 THEN 04011000 - BEGIN 04012000 - IF SUM = 0 THEN 04013000 - IF TOG THEN ELSE 04014000 - BEGIN 04015000 - EMITL(0); 04016000 - EMITDESCLIT(INFA.ADDR); 04017000 - EMITO(LOD); 04018000 - EMITL(0); 04019000 - GO TO CONSTRUCT; 04020000 - END 04021000 - ELSE 04022000 - IF TOG THEN 04023000 - BEGIN 04024000 - EMITNUM(ABS(SUM)); 04025000 - IF SUM < 0 THEN EMITO(SUB) ELSE EMITO(ADD); 04026000 - END ELSE 04027000 - BEGIN 04028000 - EMITL(SUM.[33:7]); 04029000 - EMITDESCLIT(INFA.ADDR); 04030000 - EMITO(LOD); 04031000 - EMITL(SUM.[40:8]); 04032000 - GO TO CONSTRUCT; 04033000 - END; 04034000 - SPLIT(INFA.ADDR); 04035000 - CONSTRUCT: 04036000 - IF BOOLEAN(FROM) THEN 04037000 - BEGIN 04038000 - IF INFA.SUBCLASS } DOUBTYPE THEN 04039000 - BEGIN 04040000 - EMITO(CDC); 04041000 - EMITO(DUP); 04042000 - EMITPAIR(1, XCH); 04043000 - EMITO(INX); 04044000 - EMITO(LOD); 04045000 - EMITO(XCH); 04046000 - EMITO(LOD); 04047000 - END ELSE EMITO(COC); 04048000 - END ELSE EMITO(CDC); 04049000 - END ELSE 04050000 - BEGIN 04051000 - IF SUM = 0 THEN IF NOT TOG THEN EMITL(0) ELSE 04052000 - ELSE 04053000 - BEGIN 04054000 - IF TOG THEN 04055000 - BEGIN 04056000 - EMITNUM(ABS(SUM)); 04057000 - IF SUM < 0 THEN EMITO(SUB) ELSE EMITO(ADD); 04058000 - END 04059000 - ELSE EMITNUM(SUM); 04060000 - END; 04061000 - IF FROM > 0 THEN 04062000 - IF BOOLEAN (FROM) THEN 04063000 - IF INFA.SUBCLASS } DOUBTYPE THEN 04064000 - BEGIN 04065000 - EMITDESCLIT(INFA.ADDR); 04066000 - EMITO(DUP); 04067000 - EMITPAIR(1,XCH); 04068000 - EMITO(INX); 04069000 - EMITO(LOD); 04070000 - EMITO(XCH); 04071000 - EMITO(LOD); 04072000 - END ELSE EMITV(LINK) ELSE 04073000 - BEGIN DESCREQ ~ TRUE; EMITN(LINK); DESCREQ ~ FALSE END; 04074000 - END; 04075000 - XIT: 04076000 - IT ~ SAVIT; 04077000 - SUBSCRIPTS ~ BOOLEAN(FROM); 04078000 -IF DEBUGTOG THEN FLAGROUTINE(" SUBSC","RIPTS ",FALSE) ; 04079000 -END SUBSCRIPTS; 04080000 -BOOLEAN PROCEDURE BOUNDS(LINK); VALUE LINK; REAL LINK; 04081000 -BEGIN 04082000 - COMMENT CALLED TO PROCESS ARRAY BOUNDS; 04083000 - BOOLEAN VARF, SINGLETOG; %109-04084000 - DEFINE FNEW = LINK#; 04085000 - REAL T, NSUBS, INFA, INFB, INFC, FIRSTSS; 04086000 - LABEL LOOP; 04087000 -IF DEBUGTOG THEN FLAGROUTINE(" BOU","NDS ",TRUE ); 04088000 - GETALL(FNEW, INFA, INFB, INFC); 04089000 - FIRSTSS ~ NEXTSS; 04090000 - IF LINK < 0 THEN BEGIN SINGLETOG ~ TRUE; LINK ~ ABS(LINK) END; %109-04091000 - LOOP: 04092000 - IF NEXT = ID THEN 04093000 - BEGIN 04094000 - T ~ GET(FNEXT ~ GETSPACE(FNEXT)); 04095000 - IF T.CLASS ! VARID OR NOT BOOLEAN(T.FORMAL) THEN FLAG(92) ELSE 04096000 - IF T.SUBCLASS > REALTYPE THEN FLAG(93); 04097000 - T ~ -T.ADDR; 04098000 - VARF ~ TRUE; 04099000 - END ELSE 04100000 - IF NEXT = NUM THEN 04101000 - BEGIN 04102000 - IF NUMTYPE!INTYPE THEN FLAG(113); 04103000 - IF T~FNEXT=0 THEN FLAG(122) ; 04104000 - IF NOT VARF THEN IF NSUBS = 0 THEN LENGTH ~ FNEXT ELSE 04105000 - LENGTH ~ LENGTH|FNEXT; 04106000 - END ELSE FLOG(122); 04107000 - EXTRAINFO[NEXTSS.IR,NEXTSS.IC] ~ T; 04108000 - NEXTSS ~ NEXTSS-1; 04109000 - NSUBS ~ NSUBS+1; 04110000 - SCAN; 04111000 - IF NEXT = COMMA THEN BEGIN SCAN; GO TO LOOP END; 04112000 - IF NEXT ! RPAREN THEN FLOG(94); 04113000 - XTA ~ INFB; 04114000 - IF INFA.CLASS = ARRAYID THEN FLAG(95); 04115000 - INFA.CLASS ~ ARRAYID; 04116000 - IF VARF THEN 04117000 - BEGIN 04118000 - IF NOT BOOLEAN(INFA.FORMAL) THEN FLAG(96); 04119000 - IF NSUBS > 1 OR INFA .SUBCLASS } DOUBTYPE THEN 04120000 - BEGIN BUMPLOCALS;LENGTH~LOCALS + 1536;BOUNDS~TRUE END ELSE 04121000 - LENGTH ~-EXTRAINFO[FIRSTSS.IR,FIRSTSS.IC]; 04122000 - END ELSE 04123000 - IF NOT SINGLETOG AND INFA.SUBCLASS > LOGTYPE THEN %109-04124000 - BEGIN LENGTH ~ 2 | LENGTH; BOUNDS ~ TRUE END; %109-04125000 - IF LENGTH > 32767 THEN FLAG(99); 04126000 - INFC ~ LENGTH & NSUBS[TONEXTRA] & FIRSTSS[TOADINFO]; 04127000 - IF VARF THEN INFC ~ -INFC; 04128000 - PUT(FNEW, INFA); PUT(FNEW+2, INFC); 04129000 - SCAN; 04130000 -IF DEBUGTOG THEN FLAGROUTINE(" BOU","NDS ",FALSE) ; 04131000 -END BOUNDS; 04132000 -PROCEDURE PARAMETERS(LINK); VALUE LINK; REAL LINK; 04133000 -BEGIN 04134000 - 04135000 - 04136000 - LABEL LOOP; 04137000 - REAL NPARMS, EX, INFC, PTYPE; 04138000 - ALPHA EXPNAME; 04139000 - BOOLEAN CHECK, INTFID; 04140000 - BOOLEAN NOTZEROP; 04141000 - REAL SAVIT; 04142000 - DEFINE PARMTYPE = LSTT#; 04143000 - SAVIT ~ IT ~ IT+1; 04144000 -IF DEBUGTOG THEN FLAGROUTINE(" PARAM","ETERS ",TRUE ) ; 04145000 - INFC ~ GET(LINK+2); 04146000 - IF CHECK ~ BOOLEAN(INFC.[1:1]) THEN 04147000 - BEGIN 04148000 - EX ~ INFC.ADINFO; 04149000 - NOTZEROP ~ INFC.NEXTRA ! 0; 04150000 - INTFID ~ INFC.[36:12] = 1; 04151000 - END; 04152000 - LOOP: 04153000 - BEGIN SCAN; 04154000 - EXPNAME ~ NAME; 04155000 - IF GLOBALNEXT = 0 AND NAME = "$ " THEN 04156000 - BEGIN EXPRESULT ~ LABELID; SCAN; 04157000 - IF GLOBALNEXT ! NUM THEN FLAG(44); 04158000 - EMITLABELDESC(NAME); 04159000 - PTYPE ~ 0; 04160000 - SCAN; 04161000 - END 04162000 - ELSE PTYPE ~ EXPR(CHECK AND EXTRAINFO[EX.IR,EX.IC].CLASS 04163000 - = EXPCLASS AND INTFID); 04164000 - IF EXPRESULT = NUMCLASS THEN 04165000 - IF PTYPE = STRINGTYPE THEN 04166000 - BEGIN 04167000 - ADR ~ ADR - 1; 04168000 - PTYPE ~ INTYPE; 04169000 - EXPRESULT ~ SUBSVAR; 04170000 - IF STRINGSIZE = 1 AND 04171000 - (T ~ EXTRAINFO[EX.IR,EX.IC].CLASS = VARID OR 04172000 - T = EXPCLASS) THEN 04173000 - BEGIN 04174000 - EXPRESULT ~ EXPCLASS; 04175000 - EMITNUM(STRINGARRAY[0]); 04176000 - END ELSE 04177000 - BEGIN 04178000 - EXPRESULT~ARRAYID; 04179000 - EMITPAIR(PRGDESCBLDR(1,0,0,NXAVIL~NXAVIL+1), LOD); 04180000 - EMITL(0); 04181000 - WRITEDATA(STRINGSIZE, NXAVIL, STRINGARRAY); 04182000 - END; 04183000 - END ELSE EXPRESULT ~ EXPCLASS; 04184000 - PARMTYPE[IT] ~ 0 & EXPRESULT[TOCLASS] & PTYPE[TOSUBCL]; 04185000 - XTA ~ EXPNAME; 04186000 - IF TSSEDITOG THEN IF (EXPRESULT=FUNID OR EXPRESULT=SUBRID OR 04187000 - EXPRESULT=EXTID) AND NOT DCINPUT THEN TSSED(XTA,2); 04188000 - IF DCINPUT THEN IF EXPRESULT=FUNID OR EXPRESULT=SUBRID 04189000 - OR EXPRESULT=EXTID THEN FLAG(151) ; 04190000 - IF CHECK THEN 04191000 - BEGIN 04192000 - IF T ~ EXTRAINFO[EX.IR,EX.IC].CLASS ! EXPRESULT THEN 04193000 - CASE T OF 04194000 + EXTRAINFO[NEXTEXTRA.IR,NEXTEXTRA.IC] ~ PARMTYPE[I]; 03958000 + NEXTEXTRA ~ NEXTEXTRA+1; 03959000 + END; 03960000 + END 03961000 + ELSE 03962000 + IF T ~ GET(LINK+2).NEXTRA > 0 AND T ! NPARMS OR 03963000 + T=0 AND INTFID AND NPARMS < 2 OR 03964000 + T = 0 AND NOT INTFID THEN 03964500 + BEGIN XTA ~ GET(LINK+1); FLAG(28) END; 03965000 +IF DEBUGTOG THEN FLAGROUTINE(" PARAM","ETERS ",FALSE) ; 03966000 + IT ~ SAVIT-1; 03967000 +END PARAMETERS; 03968000 +PROCEDURE STMTFUNREF(LINK); VALUE LINK; REAL LINK; 03969000 +BEGIN 03970000 + REAL I, PARMLINK, NPARMS, SEG; 03971000 +IF DEBUGTOG THEN FLAGROUTINE(" STMTF","UNREF ",TRUE); 03971010 + PARMLINK ~ GET(LINK+2).[36:12]; 03972000 + DO 03973000 + BEGIN 03974000 + SCAN; 03975000 + IF A~EXPR(TRUE) ! B~GET(PARMLINK).SUBCLASS THEN 03976000 + IF A > REALTYPE OR B > REALTYPE THEN %108-03977000 + BEGIN XTA ~ NNEW; FLAG(88) END; 03978000 + PARMLINK ~ PARMLINK-3; 03979000 + NPARMS ~ NPARMS+1; 03980000 + END UNTIL NEXT ! COMMA; 03981000 + IF NEXT ! RPAREN THEN FLAG(108); 03982000 + SCAN; 03983000 + GETALL(LINK, INFA, XTA, INFC); 03984000 + IF NPARMS ! INFC.NEXTRA THEN FLAG(28); 03985000 + SEG ~ INFA.SEGNO; 03986000 + BRANCHLIT(INFC.BASE&SEG[TOSEGNO],FALSE); 03987000 + EMITB(INFA.ADDR & SEG[TOSEGNO], FALSE); 03988000 + ADJUST; 03989000 + IF DEBUGTOG THEN FLAGROUTINE(" STMTF","UNREF ",FALSE); 03989010 + END STMTFUNREF; 03990000 + BOOLEAN PROCEDURE DOITINLINE(LNK); VALUE LNK; REAL LNK ; 03990010 + BEGIN 03990020 + REAL C,I,C1,C2,C3,C4,C5 ; 03990030 + LABEL HUNT,FOUND,XIT,AIMAG,AINT,CMPLX,LOOP,DDT111,SNGL ; 03990040 + DEFINE OPTYPE=LSTT#, E0=EMITO#, EP=EMITPAIR#, EOL=EMITOPDCLIT# ;03990045 + IF DEBUGTOG THEN FLAGROUTINE("DOITIN","LINE ",TRUE); 03990047 + C1~1; C2~INLINEINT[0]; C3~GET(ABS(LNK)+1) ; 03990050 + HUNT: 03990060 + IF (C~INLINEINT[I~(C1+C2).[36:11]].INAM)C3 THEN C2~I-1 ELSE GO FOUND ; 03990080 + IF C10 THEN INLINEINT[I]~-C4; I~0 ; 03990132 + IF XREF THEN ENTERX(C3,0&FUNID[TOCLASS]&C[21:6:3]); 03990134 + IF GLOBALNEXT!LPAREN THEN BEGIN FLOG(106); GO XIT END ; 03990136 + LOOP: SCAN; C5~XTA ; 03990140 + IF I=0 THEN 03990145 + IF LNK=10 THEN EMITL(0) ELSE IF LNK=21 THEN EMITDESCLIT(2) ; 03990150 + IF (C4~EXPR(TRUE))!C1 AND (C1!REALTYPE OR C4!INTYPE) THEN 03990160 + BEGIN XTA~C5; FLAG(88); C2~-2 END ; 03990165 + I~I+1; IF GLOBALNEXT=COMMA THEN GO LOOP ; 03990170 + IF GLOBALNEXT!RPAREN THEN BEGIN FLOG(108); C2~-2 END; SCAN ; 03990180 + IF I!C.INTPARMS THEN IF C.INTPARMS!0 OR I<2 THEN 03990190 + BEGIN XTA~C3; FLAG(28); C2~-2 END ; 03990195 + OPTYPE[IT]~C.INTCLASS; IF C2<0 THEN GO XIT ; 03990200 + CASE (LNK-1) OF 03990210 + BEGIN 03990220 + E0(SSP) ; % @1: ABS, DABS, IABS. 03990230 + AIMAG: E0(DEL) ; % @2: AIMAG. 03990240 + AINT: EP(1,IDV) ; % @3: AINT, IFIX, INT. 03990250 + E0(RDV) ; % @4: AMOD. 03990260 + E0(LND) ; % @5: LOGICAL AND. 03990270 + CMPLX: E0(XCH) ; % @6: CMPLX. 03990280 + E0(LNG) ; % @7: LOGICAL COMPLIMENT (NEGATION). 03990290 + 03990291 + BEGIN % @10: DIM, IDIM. 03990300 + E0(SUB); E0(DUP); EP(0,LESS) ; 03990310 + IF ADR>4082 THEN BEGIN ADR~ADR+1; SEGOVF END ; 03990315 + EP(2,BFC); E0(DEL); EMITL(0) ; 03990320 + END ; 03990330 + 03990331 + BEGIN E0(XCH); E0(CHS); GO CMPLX END ; % @11: CONJG. 03990340 + ; % @12: DBLE (SOME CODE ALREADY EMITTED ABOVE). 03990350 + 03990351 + BEGIN E0(XCH); E0(DEL) ; % @13: DSIGN. 03990360 + DDT111: EMITDDT(1,1,1) ; 03990370 + END; 03990380 + 03990381 + E0(LQV) ; % @14: LOGICAL EQUIVALENCE. 03990390 + ; % @15: FLOAT. 03990400 + GO DDT111 ; % @16: ISIGN, SIGN. 03990410 + BEGIN E0(RDV); GO AINT END ; % @17: MOD. 03990420 + E0(LOR) ; % @20: LOGICAL OR. 03990430 + BEGIN E0(XCH); GO AIMAG END ; % @21: REAL. 03990440 + EP(1,KOM) ; % @22: TIME. 03990450 + 03990460 + BEGIN % @23: SNGL. 03990470 + SNGL: EP(9,SND); E0(XCH); EMITDDT(47,9,1); EMITL(0) ; 03990480 + EMITDDT(9,9,38); EOL(9); EMITO(ADD); IF LNK=20 THEN GO AINT ; 03990490 + END ; 03990500 + 03990510 + GO SNGL ; % @24: IDINT. 03990520 + 03990530 + BEGIN % @25: AMAX0,AMAX1,AMIN0,AMIN1,MAX0,MAX1,MIN0,MIN1. 03990535 + % SOME CODE ALREADY EMITTED ABOVE. 03990540 + IF ADR>4068 THEN BEGIN ADR~ADR+1; SEGOVF END ; 03990542 + EP(9,STD); E0(DUP); EOL(9) ; 03990545 + E0(IF C3.[24:6]="A" OR C3.[24:6]="X" THEN LESS ELSE GRTR) ; 03990550 + EP(2,BFC); E0(DEL); EOL(9); E0(XCH); E0(TOP); E0(LNG) ; 03990555 + EP(14,BBC); E0(DEL); IF C3="MIN1 " OR C3="MAX1 " THEN GO AINT03990560 + END ; 03990565 + 03990566 + END OF CASE STATEMENT ; 03990800 + XIT: 03990810 + IF DEBUGTOG THEN FLAGROUTINE("DOITIN","LINE ",FALSE) ; 03990815 + END OF DOITINLINE ; 03990820 +REAL PROCEDURE LOOKFORINTRINSIC(L); VALUE L; REAL L; 03991000 +BEGIN 03992000 + ALPHA ID, I, X, NPARMS; 03993000 + REAL T; 03994000 + LABEL FOUND, XIT; 03995000 +IF DEBUGTOG THEN FLAGROUTINE("LOOKFO","RINTRN",TRUE); 03995010 + LOOKFORINTRINSIC ~ L ~ NEED(ID ~ GET(L+1),FUNID); 03996000 + IF GET(L+2) < 0 THEN GO TO XIT; % PARAMETER INFO KNOWN 03996050 + COMMENT B MUST BE SET TO K/2, WHERE K IS THE INDEX OF THE LAST 03996100 + INTRINSIC NAME IN THE ARRAY INT; 03996200 + A~0; B~NUMINTM1 ; 03997000 + WHILE A+1 < B DO 03998000 + BEGIN 03999000 + I ~ REAL(BOOLEAN(A+B) AND BOOLEAN(1022)); 04000000 + IF Z ~ INT[I] = ID THEN GO TO FOUND; 04001000 + IF ID < Z THEN B ~ I.[36:11] ELSE A ~ I.[36:11]; 04002000 + END; 04003000 + IF ID = INT[I~(A+B)|2-I] THEN GO TO FOUND; 04004000 + GO TO XIT; 04005000 + FOUND: 04006000 + NPARMS~(X~INT[I+1]).INTPARMS; INT[I+1].INTSEEN~1 ; 04007000 + INFO[L.IR,L.IC].SUBCLASS~X.INTCLASS ; 04008000 + PUT(L+2,-(1&NEXTEXTRA[TOADINFO]&NPARMS[TONEXTRA])); 04009000 + IF NPARMS = 0 THEN NPARMS ~ 1; 04010000 + T~X.INTPARMCLASS ; 04011000 + FOR I ~ 1 STEP 1 UNTIL NPARMS DO 04012000 + BEGIN 04013000 + EXTRAINFO[NEXTEXTRA.IR,NEXTEXTRA.IC] ~ 04014000 + 0 & EXPCLASS[TOCLASS] & T[TOSUBCL]; 04015000 + NEXTEXTRA ~ NEXTEXTRA + 1; 04016000 + END; 04017000 + XIT: 04018000 +IF DEBUGTOG THEN FLAGROUTINE("LOOKFO","RINTRN",FALSE ) ; 04018010 +END LOOKFORINTRINSIC; 04019000 +INTEGER PROCEDURE EXPR(VALREQ); VALUE VALREQ; BOOLEAN VALREQ; 04020000 +BEGIN LABEL LOOP, STACK, XIT, NOSCAN; REAL T; 04021000 + LABEL ARRY; 04022000 +LABEL HERE ; 04022010 + 04023000 + 04024000 + REAL SAVIT, SAVIP; 04025000 + BOOLEAN CNSTSEENLAST; %FOR HANDLING CONSTANT %113-04025500 + REAL SAVEADR; %EXPONENTS %113-04025600 + DEFINE OPTYPE = LSTT#; 04026000 +REAL EXPRESLT,EXPLNK; 04027000 + REAL EXPV; 04028000 + REAL TM ; 04028010 + DEFINE E0=EMITO#, EP=EMITPAIR#, EOL=EMITOPDCLIT#, 04028020 + ES1(OP)=BEGIN E0(XCH); EP(9,STD); E0(OP) END #, 04028030 + ES2=BEGIN EP(9,STD); E0(XCH); EP(17,SND); E0(MUL) END # ; 04028040 + LABEL CTYP, DTYP, RLESSC, DLESSC, CLESSD, CLESSC, RPLUSD, DTIMESC, 04028050 + CTIMESR, CDIVBYD, CTIMESR1, CTIMESR2, DLESSC1 ; 04028060 + LABEL SPECCHAR, RELATION; 04029000 + REAL LINK; 04030000 + DEFINE T1 = EXPT1#, T2 = EXPT2#, CODE = EXPT3#; 04031000 +COMMENT THE FOLLOWING TABLE GIVES THE PRECEDENCE (PREC) AND 04032000 +OPERATOR NUMBER (OP) OF THE ARITHMETIC AND LOGICAL OPERATORS. 04033000 + OPERATOR PREC OP 04034000 + ** 9 15 04035000 + UNARY - 8 12 04036000 + / 7 14 04037000 + * 7 13 04038000 + - 5 11 04039000 + + 5 10 04040000 + .NE. 4 9 04041000 + .GE. 4 8 04042000 + .GT. 4 7 04043000 + .EQ. 4 6 04044000 + .LE. 4 5 04045000 + .LT. 4 4 04046000 + .NOT. 3 3 04047000 + .AND. 2 2 04048000 + .OR. 1 1 04049000 + THE UNARY PLUS IS IGNORED; 04050000 +PROCEDURE MATH(D, C, T); VALUE D, C, T; REAL D, C, T; 04051000 +BEGIN 04052000 + EMITO(MKS); 04053000 + EMITL(C); 04054000 + EMITV(NEED(".MATH ", INTRFUNID)); 04055000 + EMITO(DEL); 04056000 + IF D = 2 THEN EMITO(DEL); 04057000 + OPTYPE[IT~IT-1] ~ T; 04058000 +END MATH; 04059000 + NNEW ~ NAME; 04060000 +IF DEBUGTOG THEN FLAGROUTINE(" EXPRE","SSION ",TRUE ) ; 04061000 + OPTYPE[SAVIT ~IT ~ IT+1] ~ 04062000 + PR[SAVIP~IP~IP+1] ~ OPST[IP] ~ 0; 04063000 + IF GLOBALNEXT = PLUS THEN GO TO LOOP; 04064000 + IF GLOBALNEXT = MINUS THEN 04065000 + BEGIN PREC ~ 8; OP ~ 12; GO TO STACK END; 04066000 + IF PREC > 0 THEN GO TO STACK; 04067000 + LINK~(EXPLNK~FNEXT)&REAL(SCANENTER)[2:47:1] ; 04068000 + GO TO NOSCAN; 04069000 + LOOP: SCAN; 04070000 + LINK ~ FNEXT; 04071000 + NOSCAN: 04072000 + CNSTSEENLAST~FALSE; %113-04072500 + IF GLOBALNEXT = ID THEN 04073000 + BEGIN 04074000 + IF IP ! SAVIP THEN EXPRESLT ~ EXPCLASS; 04074100 + OPTYPE[IT~IT+1] ~ (A~GET(LINK)).SUBCLASS; 04075000 + SCAN; 04076000 + IF NOT RANDOMTOG THEN 04076050 + IF NEXT=EQUAL THEN BEGIN NEXT~0; OP~6; PREC~4 END ; 04076100 + IF GLOBALNEXT = ID OR GLOBALNEXT = NUM THEN 04077000 + BEGIN FLOG(1); GO TO XIT END; 04078000 + IF NOT VALREQ AND PREC > 0 THEN VALREQ ~ TRUE; 04078100 + IF GLOBALNEXT ! LPAREN THEN 04079000 + BEGIN 04080000 + LINK ~ GETSPACE(LINK); 04081000 + T ~ (A~GET(LINK)).CLASS; 04082000 + IF XREF THEN ENTERX(GET(LINK+1),0&A[15:15:9]); 04082100 + IF EXPRESLT = 0 THEN EXPRESLT ~ T; 04083000 + IF VALREQ THEN 04084000 + IF T = VARID THEN EMITV(LINK) ELSE 04085000 + BEGIN XTA ~ GET(LINK+1); FLAG(50) END 04086000 + ELSE 04087000 + BEGIN 04088000 + IF T = VARID THEN 04089000 + IF GLOBALNEXT > SLASH AND EXPRESLT = VARID THEN 04090000 + BEGIN 04091000 + DESCREQ~TRUE; EMITN(LINK); DESCREQ ~ FALSE; 04092000 + GO TO XIT; 04093000 + END ELSE EMITV(LINK) 04094000 + ELSE 04095000 + BEGIN 04096000 + IF T = ARRAYID THEN 04097000 + BEGIN 04098000 + IF BOOLEAN(A.CE) THEN 04099000 + EMITNUM(GET(LINK+2).BASE) ELSE 04100000 + IF BOOLEAN(A.FORMAL) THEN 04101000 + EMITOPDCLIT(A.ADDR-1) ELSE 04102000 + EMITL(0); 04103000 + GO TO ARRY; 04104000 + END ELSE EMITPAIR(A.ADDR,LOD); 04105000 + GO TO XIT; 04106000 + END; 04107000 + END; 04108000 + GO TO SPECCHAR; 04109000 + END; 04110000 + IF A.CLASS ! ARRAYID THEN 04111000 + BEGIN COMMENT FUNCTION REFERENCE; 04112000 + EXPRESLT ~ EXPCLASS; 04112100 + IF A.CLASS = STMTFUNID THEN 04113000 + BEGIN 04114000 + IF XREF THEN ENTERX(GET(LINK+1),0&A[15:15:9]); 04114050 + STMTFUNREF(LINK) ; 04114100 + IF NEXT=EQUAL THEN IF NOT RANDOMTOG THEN 04114200 + BEGIN NEXT~0; OP~6; PREC~4 END ; 04114300 + GO TO SPECCHAR ; 04114400 + END ; 04114500 + IF A.CLASS=EXTID OR GET(TM~GLOBALSEARCH(GET(LINK+1))).CLASS=04114520 + EXTID THEN LINK~REAL(DOITINLINE(-LINK)) ELSE 04114530 + IF A.CLASS SLASH AND EXPRESLT = SUBSVAR THEN 04133000 + BEGIN 04134000 + ARRY: 04135000 + IF BOOLEAN((A~GET(LINK)).TWOD) THEN 04136000 + BEGIN 04137000 + EMITPAIR(TWODPRT, LOD); 04138000 + T ~ A.ADDR; 04139000 + IF T { 1023 THEN 04140000 + BEGIN 04141000 + EMITL(T.[38:10]); 04142000 + EMITDESCLIT(10); 04143000 + END ELSE 04144000 + BEGIN 04145000 + EMITL(T.[40:8]); 04146000 + EMITDESCLIT(1536); 04147000 + EMITO(INX); 04148000 + END; 04149000 + EMITO(CTF); 04150000 + END ELSE EMITPAIR(A.ADDR,LOD); 04151000 + EMITO(XCH); 04152000 + GO TO XIT; 04153000 + END; 04154000 + IF BOOLEAN((A~GET(LINK)).TWOD) THEN 04155000 + BEGIN 04156000 + SPLIT(A.ADDR); 04157000 + IF A.SUBCLASS } DOUBTYPE THEN 04158000 + BEGIN 04159000 + EMITO(CDC); 04160000 + EMITO(DUP); 04161000 + EMITPAIR(1, XCH); 04162000 + EMITO(INX); 04163000 + EMITO(LOD); 04164000 + EMITO(XCH); 04165000 + EMITO(LOD); 04166000 + END ELSE EMITO(COC); 04167000 + END ELSE 04168000 + EMITV(LINK); 04169000 + END; 04170000 + END ARRAY REFERENCE; 04171000 + GO TO SPECCHAR; 04172000 + END; 04173000 + IF GLOBALNEXT = NUM THEN 04174000 + BEGIN 04175000 + IF NUMTYPE = STRINGTYPE THEN 04176000 + IF VALREQ THEN 04177000 + BEGIN 04177200 + NUMTYPE~INTYPE ; 04177400 + IF STRINGSIZE=1 THEN FNEXT~STRINGARRAY[0] 04177500 + ELSE BEGIN 04177550 + IF STRINGSIZE>2 OR STRINGARRAY[1].[18:30]!" " THEN 04177575 + FLAG(162) ; 04177600 + IF (FNEXT~STRINGARRAY[1].[12:6]&STRINGARRAY[0][6:12:36]) 04177700 + .[6:6]>7 THEN NUMTYPE~REALTYPE ; 04177800 + END ; 04177900 + END; 04178000 + SAVEADR~ADR; CNSTSEENLAST~TRUE; %113-04178500 + IF NUMTYPE = DOUBTYPE THEN 04179000 + EMITNUM2(FNEXT,DBLOW) ELSE EMITNUM (FNEXT); 04180000 + OPTYPE[IT~IT+1] ~ NUMTYPE; 04181000 + IF EXPRESLT = 0 THEN 04182000 + BEGIN EXPRESLT ~ NUMCLASS; EXPV ~ FNEXT END; 04183000 + SCAN; 04184000 + IF NOT RANDOMTOG THEN 04184050 + IF NEXT=EQUAL THEN BEGIN NEXT~0; OP~6; PREC~4 END; 04184100 + IF NOT VALREQ AND PREC > 0 THEN VALREQ ~ TRUE; 04184200 + IF GLOBALNEXT = ID OR GLOBALNEXT = NUM THEN 04185000 + BEGIN FLOG(1); GO TO XIT END; 04186000 + END; 04187000 + SPECCHAR: 04188000 + IF GLOBALNEXT = LPAREN THEN 04189000 + BEGIN 04190000 + SCAN; 04191000 + OPTYPE[IT~IT+1] ~ EXPR(TRUE); 04192000 + 04193000 + IF GLOBALNEXT = COMMA AND EXPRESULT = NUMCLASS THEN 04194000 BEGIN 04195000 - EXTRAINFO[EX.IR,EX.IC] ~ 0 & EXPRESULT[TOCLASS] 04196000 - & PTYPE[TOSUBCL]; 04197000 - IF EXPRESULT ! SUBSVAR THEN FLAG(66); 04198000 - IF EXPRESULT = SUBSVAR THEN 04199000 - IF NOT INTFID THEN 04200000 - BEGIN EMITO(CDC); 04201000 - IF PTYPE } DOUBTYPE THEN EMITL(0); 04202000 - END ELSE 04203000 - ELSE 04204000 - IF EXPRESULT = EXPCLASS THEN 04205000 - BEGIN IF PTYPE } DOUBTYPE THEN EMITO(XCH); 04206000 - EXTRAINFO[EX.IR,EX.IC].CLASS ~ EXPCLASS 04207000 - END ELSE FLAG(67); 04208000 - ; ; ; 04209000 - FLAG(68); 04210000 - IF EXPRESULT = EXTID THEN 04211000 - PUT(EXPLINK,GET(EXPLINK)&FUNID[TOCLASS]) ELSE 04212000 - FLAG(69); 04213000 - ; 04214000 - IF EXPRESULT = FUNID OR EXPRESULT = SUBRID THEN 04215000 - EXTRAINFO[EX.IR,EX.IC] ~ EXPRESULT ELSE FLAG(70); 04216000 - IF EXPRESULT = EXTID THEN 04217000 - PUT(EXPLINK,GET(EXPLINK)&SUBRID[TOCLASS]) ELSE 04218000 - FLAG(71); 04219000 - ; ; 04220000 - IF EXPRESULT = ARRAYID THEN EXTRAINFO[EX.IR,EX.IC].CLASS 04221000 - ~ ARRAYID ELSE 04222000 - IF EXPRESULT = VARID THEN 04223000 - BEGIN 04224000 - EXTRAINFO[EX.IR,EX.IC].CLASS ~ SBVEXP; 04225000 - EMITL(0) 04226000 - END ELSE 04227000 - IF EXPRESULT = EXPCLASS THEN 04228000 - BEGIN 04229000 - EXTRAINFO[EX.IR,EX.IC].CLASS ~ SBVEXP; 04230000 - IF PTYPE } DOUBTYPE THEN EMITO(XCH) ELSE EMITL(0); 04231000 - END ELSE FLAG(72); 04232000 - IF EXPRESULT = SUBSVAR THEN 04233000 - IF NOT INTFID THEN 04234000 - BEGIN EMITO(CDC); 04235000 - IF PTYPE } DOUBTYPE THEN EMITL(0) 04236000 - END 04237000 - ELSE 04238000 - ELSE IF EXPRESULT = VARID THEN 04239000 - IF NOT INTFID THEN 04240000 - IF PTYPE } DOUBTYPE THEN EMITL(0) ELSE ELSE 04241000 - ELSE FLAG(67); 04242000 - IF EXPRESULT = VARID THEN 04243000 - EMITL(0) ELSE 04244000 - IF EXPRESULT = EXPCLASS THEN 04245000 - IF PTYPE } DOUBTYPE THEN EMITO(XCH) ELSE EMITL(0) 04246000 - ELSE IF EXPRESULT ! SUBSVAR THEN FLAG(67); 04247000 - END OF CASE STATEMENT 04248000 - ELSE IF PTYPE } DOUBTYPE THEN 04249000 - IF EXPRESULT = VARID THEN EMITL(0) 04250000 - ELSE IF EXPRESULT = EXPCLASS AND NOT INTFID 04251000 - THEN EMITO(XCH); 04252000 - IF T ~ EXTRAINFO[EX.IR,EX.IC].SUBCLASS = 0 OR 04253000 - (T = INTYPE AND PTYPE = REALTYPE AND 04254000 - GET(LINK).SEGNO = 0) THEN 04255000 - EXTRAINFO[EX.IR,EX.IC].SUBCLASS ~ PTYPE ELSE 04256000 - IF NOT(T = PTYPE OR T = REALTYPE AND PTYPE = INTYPE ) THEN 04257000 - FLAG(88); 04258000 - END OF CHECK 04259000 - ELSE IF PTYPE } DOUBTYPE THEN 04260000 - IF EXPRESULT = VARID THEN EMITL(0) 04261000 - ELSE IF EXPRESULT = EXPCLASS THEN EMITO(XCH); 04262000 - IF NOTZEROP THEN EX ~ EX+1; 04263000 - IT ~ IT+1; 04264000 - END; 04265000 - IF GLOBALNEXT = COMMA THEN GO TO LOOP; 04266000 - NPARMS ~ IT - SAVIT; 04267000 - IF GLOBALNEXT ! RPAREN THEN FLOG(108); 04268000 - IF NOT CHECK THEN 04269000 - BEGIN 04270000 - INFC ~ GET(LINK+2); 04271000 - INFC ~ -(INFC & NPARMS[TONEXTRA] 04272000 - & NEXTEXTRA[TOADINFO]); 04273000 - PUT(LINK+2,INFC); 04274000 - FOR I ~ SAVIT STEP 1 UNTIL IT-1 DO 04275000 - BEGIN 04276000 - EXTRAINFO[NEXTEXTRA.IR,NEXTEXTRA.IC] ~ PARMTYPE[I]; 04277000 - NEXTEXTRA ~ NEXTEXTRA+1; 04278000 - END; 04279000 - END 04280000 - ELSE 04281000 - IF T ~ GET(LINK+2).NEXTRA > 0 AND T ! NPARMS OR 04282000 - T=0 AND INTFID AND NPARMS < 2 OR 04283000 - T = 0 AND NOT INTFID THEN 04284000 - BEGIN XTA ~ GET(LINK+1); FLAG(28) END; 04285000 -IF DEBUGTOG THEN FLAGROUTINE(" PARAM","ETERS ",FALSE) ; 04286000 - IT ~ SAVIT-1; 04287000 -END PARAMETERS; 04288000 -PROCEDURE STMTFUNREF(LINK); VALUE LINK; REAL LINK; 04289000 -BEGIN 04290000 - REAL I, PARMLINK, NPARMS, SEG; 04291000 -IF DEBUGTOG THEN FLAGROUTINE(" STMTF","UNREF ",TRUE); 04292000 - PARMLINK ~ GET(LINK+2).[36:12]; 04293000 - DO 04294000 - BEGIN 04295000 - SCAN; 04296000 - IF A~EXPR(TRUE) ! B~GET(PARMLINK).SUBCLASS THEN 04297000 - IF A > REALTYPE OR B > REALTYPE THEN %108-04298000 - BEGIN XTA ~ NNEW; FLAG(88) END; 04299000 - PARMLINK ~ PARMLINK-3; 04300000 - NPARMS ~ NPARMS+1; 04301000 - END UNTIL NEXT ! COMMA; 04302000 - IF NEXT ! RPAREN THEN FLAG(108); 04303000 - SCAN; 04304000 - GETALL(LINK, INFA, XTA, INFC); 04305000 - IF NPARMS ! INFC.NEXTRA THEN FLAG(28); 04306000 - SEG ~ INFA.SEGNO; 04307000 - BRANCHLIT(INFC.BASE&SEG[TOSEGNO],FALSE); 04308000 - EMITB(INFA.ADDR & SEG[TOSEGNO], FALSE); 04309000 - ADJUST; 04310000 - IF DEBUGTOG THEN FLAGROUTINE(" STMTF","UNREF ",FALSE); 04311000 - END STMTFUNREF; 04312000 - BOOLEAN PROCEDURE DOITINLINE(LNK); VALUE LNK; REAL LNK ; 04313000 - BEGIN 04314000 - REAL C,I,C1,C2,C3,C4,C5 ; 04315000 - LABEL HUNT,FOUND,XIT,AIMAG,AINT,CMPLX,LOOP,DDT111,SNGL ; 04316000 - DEFINE OPTYPE=LSTT#, E0=EMITO#, EP=EMITPAIR#, EOL=EMITOPDCLIT# ;04317000 - IF DEBUGTOG THEN FLAGROUTINE("DOITIN","LINE ",TRUE); 04318000 - C1~1; C2~INLINEINT[0]; C3~GET(ABS(LNK)+1) ; 04319000 - HUNT: 04320000 - IF (C~INLINEINT[I~(C1+C2).[36:11]].INAM)C3 THEN C2~I-1 ELSE GO FOUND ; 04322000 - IF C10 THEN INLINEINT[I]~-C4; I~0 ; 04349000 - IF XREF THEN ENTERX(C3,0&FUNID[TOCLASS]&C[21:6:3]); 04350000 - IF GLOBALNEXT!LPAREN THEN BEGIN FLOG(106); GO XIT END ; 04351000 - LOOP: SCAN; C5~XTA ; 04352000 - IF I=0 THEN 04353000 - IF LNK=10 THEN EMITL(0) ELSE IF LNK=21 THEN EMITDESCLIT(2) ; 04354000 - IF (C4~EXPR(TRUE))!C1 AND (C1!REALTYPE OR C4!INTYPE) THEN 04355000 - BEGIN XTA~C5; FLAG(88); C2~-2 END ; 04356000 - I~I+1; IF GLOBALNEXT=COMMA THEN GO LOOP ; 04357000 - IF GLOBALNEXT!RPAREN THEN BEGIN FLOG(108); C2~-2 END; SCAN ; 04358000 - IF I!C.INTPARMS THEN IF C.INTPARMS!0 OR I<2 THEN 04359000 - BEGIN XTA~C3; FLAG(28); C2~-2 END ; 04360000 - OPTYPE[IT]~C.INTCLASS; IF C2<0 THEN GO XIT ; 04361000 - CASE (LNK-1) OF 04362000 - BEGIN 04363000 - E0(SSP) ; % @1: ABS, DABS, IABS. 04364000 - AIMAG: E0(DEL) ; % @2: AIMAG. 04365000 - AINT: EP(1,IDV) ; % @3: AINT, IFIX, INT. 04366000 - E0(RDV) ; % @4: AMOD. 04367000 - E0(LND) ; % @5: LOGICAL AND. 04368000 - CMPLX: E0(XCH) ; % @6: CMPLX. 04369000 - E0(LNG) ; % @7: LOGICAL COMPLIMENT (NEGATION). 04370000 - 04371000 - BEGIN % @10: DIM, IDIM. 04372000 - E0(SUB); E0(DUP); EP(0,LESS) ; 04373000 - IF ADR>4082 THEN BEGIN ADR~ADR+1; SEGOVF END ; 04374000 - EP(2,BFC); E0(DEL); EMITL(0) ; 04375000 - END ; 04376000 - 04377000 - BEGIN E0(XCH); E0(CHS); GO CMPLX END ; % @11: CONJG. 04378000 - ; % @12: DBLE (SOME CODE ALREADY EMITTED ABOVE). 04379000 - 04380000 - BEGIN E0(XCH); E0(DEL) ; % @13: DSIGN. 04381000 - DDT111: EMITDDT(1,1,1) ; 04382000 - END; 04383000 - 04384000 - E0(LQV) ; % @14: LOGICAL EQUIVALENCE. 04385000 - ; % @15: FLOAT. 04386000 - GO DDT111 ; % @16: ISIGN, SIGN. 04387000 - BEGIN E0(RDV); GO AINT END ; % @17: MOD. 04388000 - E0(LOR) ; % @20: LOGICAL OR. 04389000 - BEGIN E0(XCH); GO AIMAG END ; % @21: REAL. 04390000 - EP(1,KOM) ; % @22: TIME. 04391000 - 04392000 - BEGIN % @23: SNGL. 04393000 - SNGL: EP(9,SND); E0(XCH); EMITDDT(47,9,1); EMITL(0) ; 04394000 - EMITDDT(9,9,38); EOL(9); EMITO(ADD); IF LNK=20 THEN GO AINT ; 04395000 - END ; 04396000 - 04397000 - GO SNGL ; % @24: IDINT. 04398000 - 04399000 - BEGIN % @25: AMAX0,AMAX1,AMIN0,AMIN1,MAX0,MAX1,MIN0,MIN1. 04400000 - % SOME CODE ALREADY EMITTED ABOVE. 04401000 - IF ADR>4068 THEN BEGIN ADR~ADR+1; SEGOVF END ; 04402000 - EP(9,STD); E0(DUP); EOL(9) ; 04403000 - E0(IF C3.[24:6]="A" OR C3.[24:6]="X" THEN LESS ELSE GRTR) ; 04404000 - EP(2,BFC); E0(DEL); EOL(9); E0(XCH); E0(TOP); E0(LNG) ; 04405000 - EP(14,BBC); E0(DEL); IF C3="MIN1 " OR C3="MAX1 " THEN GO AINT04406000 - END ; 04407000 - 04408000 - END OF CASE STATEMENT ; 04409000 - XIT: 04410000 - IF DEBUGTOG THEN FLAGROUTINE("DOITIN","LINE ",FALSE) ; 04411000 - END OF DOITINLINE ; 04412000 -REAL PROCEDURE LOOKFORINTRINSIC(L); VALUE L; REAL L; 04413000 -BEGIN 04414000 - ALPHA ID, I, X, NPARMS; 04415000 - REAL T; 04416000 - LABEL FOUND, XIT; 04417000 -IF DEBUGTOG THEN FLAGROUTINE("LOOKFO","RINTRN",TRUE); 04418000 - LOOKFORINTRINSIC ~ L ~ NEED(ID ~ GET(L+1),FUNID); 04419000 - IF GET(L+2) < 0 THEN GO TO XIT; % PARAMETER INFO KNOWN 04420000 - COMMENT B MUST BE SET TO K/2, WHERE K IS THE INDEX OF THE LAST 04421000 - INTRINSIC NAME IN THE ARRAY INT; 04422000 - A~0; B~NUMINTM1 ; 04423000 - WHILE A+1 < B DO 04424000 - BEGIN 04425000 - I ~ REAL(BOOLEAN(A+B) AND BOOLEAN(1022)); 04426000 - IF Z ~ INT[I] = ID THEN GO TO FOUND; 04427000 - IF ID < Z THEN B ~ I.[36:11] ELSE A ~ I.[36:11]; 04428000 - END; 04429000 - IF ID = INT[I~(A+B)|2-I] THEN GO TO FOUND; 04430000 - GO TO XIT; 04431000 - FOUND: 04432000 - NPARMS~(X~INT[I+1]).INTPARMS; INT[I+1].INTSEEN~1 ; 04433000 - INFO[L.IR,L.IC].SUBCLASS~X.INTCLASS ; 04434000 - PUT(L+2,-(1&NEXTEXTRA[TOADINFO]&NPARMS[TONEXTRA])); 04435000 - IF NPARMS = 0 THEN NPARMS ~ 1; 04436000 - T~X.INTPARMCLASS ; 04437000 - FOR I ~ 1 STEP 1 UNTIL NPARMS DO 04438000 - BEGIN 04439000 - EXTRAINFO[NEXTEXTRA.IR,NEXTEXTRA.IC] ~ 04440000 - 0 & EXPCLASS[TOCLASS] & T[TOSUBCL]; 04441000 - NEXTEXTRA ~ NEXTEXTRA + 1; 04442000 - END; 04443000 - XIT: 04444000 -IF DEBUGTOG THEN FLAGROUTINE("LOOKFO","RINTRN",FALSE ) ; 04445000 -END LOOKFORINTRINSIC; 04446000 -INTEGER PROCEDURE EXPR(VALREQ); VALUE VALREQ; BOOLEAN VALREQ; 04447000 -BEGIN LABEL LOOP, STACK, XIT, NOSCAN; REAL T; 04448000 - LABEL ARRY; 04449000 -LABEL HERE ; 04450000 - 04451000 - 04452000 - REAL SAVIT, SAVIP; 04453000 - BOOLEAN CNSTSEENLAST; %FOR HANDLING CONSTANT %113-04454000 - REAL SAVEADR; %EXPONENTS %113-04455000 - DEFINE OPTYPE = LSTT#; 04456000 -REAL EXPRESLT,EXPLNK; 04457000 - REAL EXPV; 04458000 - REAL TM ; 04459000 - DEFINE E0=EMITO#, EP=EMITPAIR#, EOL=EMITOPDCLIT#, 04460000 - ES1(OP)=BEGIN E0(XCH); EP(9,STD); E0(OP) END #, 04461000 - ES2=BEGIN EP(9,STD); E0(XCH); EP(17,SND); E0(MUL) END # ; 04462000 - LABEL CTYP, DTYP, RLESSC, DLESSC, CLESSD, CLESSC, RPLUSD, DTIMESC, 04463000 - CTIMESR, CDIVBYD, CTIMESR1, CTIMESR2, DLESSC1 ; 04464000 - LABEL SPECCHAR, RELATION; 04465000 - REAL LINK; 04466000 - DEFINE T1 = EXPT1#, T2 = EXPT2#, CODE = EXPT3#; 04467000 -COMMENT THE FOLLOWING TABLE GIVES THE PRECEDENCE (PREC) AND 04468000 -OPERATOR NUMBER (OP) OF THE ARITHMETIC AND LOGICAL OPERATORS. 04469000 - OPERATOR PREC OP 04470000 - ** 9 15 04471000 - UNARY - 8 12 04472000 - / 7 14 04473000 - * 7 13 04474000 - - 5 11 04475000 - + 5 10 04476000 - .NE. 4 9 04477000 - .GE. 4 8 04478000 - .GT. 4 7 04479000 - .EQ. 4 6 04480000 - .LE. 4 5 04481000 - .LT. 4 4 04482000 - .NOT. 3 3 04483000 - .AND. 2 2 04484000 - .OR. 1 1 04485000 - THE UNARY PLUS IS IGNORED; 04486000 -PROCEDURE MATH(D, C, T); VALUE D, C, T; REAL D, C, T; 04487000 -BEGIN 04488000 - EMITO(MKS); 04489000 - EMITL(C); 04490000 - EMITV(NEED(".MATH ", INTRFUNID)); 04491000 - EMITO(DEL); 04492000 - IF D = 2 THEN EMITO(DEL); 04493000 - OPTYPE[IT~IT-1] ~ T; 04494000 -END MATH; 04495000 - NNEW ~ NAME; 04496000 -IF DEBUGTOG THEN FLAGROUTINE(" EXPRE","SSION ",TRUE ) ; 04497000 - OPTYPE[SAVIT ~IT ~ IT+1] ~ 04498000 - PR[SAVIP~IP~IP+1] ~ OPST[IP] ~ 0; 04499000 - IF GLOBALNEXT = PLUS THEN GO TO LOOP; 04500000 - IF GLOBALNEXT = MINUS THEN 04501000 - BEGIN PREC ~ 8; OP ~ 12; GO TO STACK END; 04502000 - IF PREC > 0 THEN GO TO STACK; 04503000 - LINK~(EXPLNK~FNEXT)&REAL(SCANENTER)[2:47:1] ; 04504000 - GO TO NOSCAN; 04505000 - LOOP: SCAN; 04506000 - LINK ~ FNEXT; 04507000 - NOSCAN: 04508000 - CNSTSEENLAST~FALSE; %113-04509000 - IF GLOBALNEXT = ID THEN 04510000 - BEGIN 04511000 - IF IP ! SAVIP THEN EXPRESLT ~ EXPCLASS; 04512000 - OPTYPE[IT~IT+1] ~ (A~GET(LINK)).SUBCLASS; 04513000 - SCAN; 04514000 - IF NOT RANDOMTOG THEN 04515000 - IF NEXT=EQUAL THEN BEGIN NEXT~0; OP~6; PREC~4 END ; 04516000 - IF GLOBALNEXT = ID OR GLOBALNEXT = NUM THEN 04517000 - BEGIN FLOG(1); GO TO XIT END; 04518000 - IF NOT VALREQ AND PREC > 0 THEN VALREQ ~ TRUE; 04519000 - IF GLOBALNEXT ! LPAREN THEN 04520000 - BEGIN 04521000 - LINK ~ GETSPACE(LINK); 04522000 - T ~ (A~GET(LINK)).CLASS; 04523000 - IF XREF THEN ENTERX(GET(LINK+1),0&A[15:15:9]); 04524000 - IF EXPRESLT = 0 THEN EXPRESLT ~ T; 04525000 - IF VALREQ THEN 04526000 - IF T = VARID THEN EMITV(LINK) ELSE 04527000 - BEGIN XTA ~ GET(LINK+1); FLAG(50) END 04528000 - ELSE 04529000 - BEGIN 04530000 - IF T = VARID THEN 04531000 - IF GLOBALNEXT > SLASH AND EXPRESLT = VARID THEN 04532000 - BEGIN 04533000 - DESCREQ~TRUE; EMITN(LINK); DESCREQ ~ FALSE; 04534000 - GO TO XIT; 04535000 - END ELSE EMITV(LINK) 04536000 - ELSE 04537000 - BEGIN 04538000 - IF T = ARRAYID THEN 04539000 - BEGIN 04540000 - IF BOOLEAN(A.CE) THEN 04541000 - EMITNUM(GET(LINK+2).BASE) ELSE 04542000 - IF BOOLEAN(A.FORMAL) THEN 04543000 - EMITOPDCLIT(A.ADDR-1) ELSE 04544000 - EMITL(0); 04545000 - GO TO ARRY; 04546000 - END ELSE EMITPAIR(A.ADDR,LOD); 04547000 - GO TO XIT; 04548000 - END; 04549000 - END; 04550000 - GO TO SPECCHAR; 04551000 - END; 04552000 - IF A.CLASS ! ARRAYID THEN 04553000 - BEGIN COMMENT FUNCTION REFERENCE; 04554000 - EXPRESLT ~ EXPCLASS; 04555000 - IF A.CLASS = STMTFUNID THEN 04556000 - BEGIN 04557000 - IF XREF THEN ENTERX(GET(LINK+1),0&A[15:15:9]); 04558000 - STMTFUNREF(LINK) ; 04559000 - IF NEXT=EQUAL THEN IF NOT RANDOMTOG THEN 04560000 - BEGIN NEXT~0; OP~6; PREC~4 END ; 04561000 - GO TO SPECCHAR ; 04562000 - END ; 04563000 - IF A.CLASS=EXTID OR GET(TM~GLOBALSEARCH(GET(LINK+1))).CLASS=04564000 - EXTID THEN LINK~REAL(DOITINLINE(-LINK)) ELSE 04565000 - IF A.CLASS SLASH AND EXPRESLT = SUBSVAR THEN 04591000 - BEGIN 04592000 - ARRY: 04593000 - IF BOOLEAN((A~GET(LINK)).TWOD) THEN 04594000 - BEGIN 04595000 - EMITPAIR(TWODPRT, LOD); 04596000 - T ~ A.ADDR; 04597000 - IF T { 1023 THEN 04598000 - BEGIN 04599000 - EMITL(T.[38:10]); 04600000 - EMITDESCLIT(10); 04601000 - END ELSE 04602000 - BEGIN 04603000 - EMITL(T.[40:8]); 04604000 - EMITDESCLIT(1536); 04605000 - EMITO(INX); 04606000 - END; 04607000 - EMITO(CTF); 04608000 - END ELSE EMITPAIR(A.ADDR,LOD); 04609000 - EMITO(XCH); 04610000 - GO TO XIT; 04611000 - END; 04612000 - IF BOOLEAN((A~GET(LINK)).TWOD) THEN 04613000 - BEGIN 04614000 - SPLIT(A.ADDR); 04615000 - IF A.SUBCLASS } DOUBTYPE THEN 04616000 - BEGIN 04617000 - EMITO(CDC); 04618000 - EMITO(DUP); 04619000 - EMITPAIR(1, XCH); 04620000 - EMITO(INX); 04621000 - EMITO(LOD); 04622000 - EMITO(XCH); 04623000 - EMITO(LOD); 04624000 - END ELSE EMITO(COC); 04625000 - END ELSE 04626000 - EMITV(LINK); 04627000 - END; 04628000 - END ARRAY REFERENCE; 04629000 - GO TO SPECCHAR; 04630000 - END; 04631000 - IF GLOBALNEXT = NUM THEN 04632000 - BEGIN 04633000 - IF NUMTYPE = STRINGTYPE THEN 04634000 - IF VALREQ THEN 04635000 - BEGIN 04636000 - NUMTYPE~INTYPE ; 04637000 - IF STRINGSIZE=1 THEN FNEXT~STRINGARRAY[0] 04638000 - ELSE BEGIN 04639000 - IF STRINGSIZE>2 OR STRINGARRAY[1].[18:30]!" " THEN 04640000 - FLAG(162) ; 04641000 - IF (FNEXT~STRINGARRAY[1].[12:6]&STRINGARRAY[0][6:12:36]) 04642000 - .[6:6]>7 THEN NUMTYPE~REALTYPE ; 04643000 - END ; 04644000 - END; 04645000 - SAVEADR~ADR; CNSTSEENLAST~TRUE; %113-04646000 - IF NUMTYPE = DOUBTYPE THEN 04647000 - EMITNUM2(FNEXT,DBLOW) ELSE EMITNUM (FNEXT); 04648000 - OPTYPE[IT~IT+1] ~ NUMTYPE; 04649000 - IF EXPRESLT = 0 THEN 04650000 - BEGIN EXPRESLT ~ NUMCLASS; EXPV ~ FNEXT END; 04651000 - SCAN; 04652000 - IF NOT RANDOMTOG THEN 04653000 - IF NEXT=EQUAL THEN BEGIN NEXT~0; OP~6; PREC~4 END; 04654000 - IF NOT VALREQ AND PREC > 0 THEN VALREQ ~ TRUE; 04655000 - IF GLOBALNEXT = ID OR GLOBALNEXT = NUM THEN 04656000 - BEGIN FLOG(1); GO TO XIT END; 04657000 - END; 04658000 - SPECCHAR: 04659000 - IF GLOBALNEXT = LPAREN THEN 04660000 - BEGIN 04661000 - SCAN; 04662000 - OPTYPE[IT~IT+1] ~ EXPR(TRUE); 04663000 - 04664000 - IF GLOBALNEXT = COMMA AND EXPRESULT = NUMCLASS THEN 04665000 - BEGIN 04666000 - IF OPTYPE[IT] > REALTYPE THEN FLAG(85); 04667000 - SCAN; 04668000 - IF EXPR(TRUE) > REALTYPE 04669000 - OR EXPRESULT ! NUMCLASS THEN FLAG(85); 04670000 - EMITO(XCH); 04671000 - OPTYPE[IT] ~ COMPTYPE; 04672000 - IF EXPRESLT = 0 THEN EXPRESLT ~ NUMCLASS; 04673000 - END ELSE EXPRESLT ~ EXPCLASS; 04674000 - IF GLOBALNEXT ! RPAREN THEN 04675000 - BEGIN FLOG(108); GO TO XIT END; 04676000 - GO TO LOOP; 04677000 - END; 04678000 - WHILE PR[IP] } PREC DO 04679000 - BEGIN 04680000 - IF IT { SAVIT THEN GO TO XIT; 04681000 - CODE ~ MAP[T1~OPTYPE[IT-1]]|3 + MAP[T2~OPTYPE[IT]]; 04682000 - CASE OPST[IP] OF 04683000 - BEGIN 04684000 - GO TO XIT; 04685000 - BEGIN 04686000 - IF T1 = LOGTYPE AND T2 = LOGTYPE THEN EMITO(LOR) 04687000 - ELSE FLAG(51); 04688000 - IT ~ IT-1; 04689000 - END; 04690000 - BEGIN 04691000 - IF T1 = LOGTYPE AND T2 = LOGTYPE THEN EMITO(LND) 04692000 - ELSE FLAG(52); 04693000 - IT ~ IT-1; 04694000 - END; 04695000 - IF T2 = LOGTYPE THEN EMITO(LNG) ELSE FLAG(53); 04696000 - BEGIN T ~ LESS; GO TO RELATION END; 04697000 - BEGIN T ~ LEQL; GO TO RELATION END; 04698000 - BEGIN T ~ EQUL; GO TO RELATION END; 04699000 - BEGIN T ~ GRTR; GO TO RELATION END; 04700000 - BEGIN T ~ GEQL; GO TO RELATION END; 04701000 - BEGIN T ~ NEQL; 04702000 - RELATION: 04703000 - IF CODE < 0 THEN FLAG(54) ELSE 04704000 - CASE CODE OF 04705000 - BEGIN ; 04706000 - BEGIN 04707000 - E0(CHS); EP(9,STD); E0(XCH); EOL(9); E0(XCH); EP(0,XCH) ;04708000 - E0(AD2) ; 04709000 - END; 04710000 - FLAG(90); 04711000 - BEGIN EMITPAIR(0, XCH); EMITO(SB2) END; 04712000 - EMITO(SB2); 04713000 - FLAG(90); 04714000 - FLAG(90); 04715000 - FLAG(90); 04716000 - IF T! EQUL AND T! NEQL THEN FLAG(54) %103-04717000 - ELSE %103-04718000 - BEGIN %103-04719000 - EP(9,STD); E0(XCH); EOL(9); E0(T); %103-04720000 - EP(9,STD ); E0(T); EOL(9); %103-04721000 - T~(IF T=EQUL THEN LND ELSE LOR); CODE~0; %103-04722000 - END; %103-04723000 - END RELATION CASE STATEMENT; 04724000 - IF CODE > 0 THEN 04725000 - BEGIN EMITO(XCH); EMITO(DEL); EMITL(0) END; 04726000 - EMITO(T); 04727000 - OPTYPE[IT~IT-1] ~ LOGTYPE; 04728000 - END; 04729000 - IF CODE < 0 THEN BEGIN FLAG(53); IT ~ IT-1 END ELSE 04730000 - CASE CODE OF 04731000 - BEGIN 04732000 - BEGIN 04733000 - EMITO(ADD); 04734000 - IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE 04735000 - OPTYPE[IT~IT-1] ~ REALTYPE; 04736000 - END; 04737000 - BEGIN TM~AD2 ; 04738000 - RPLUSD: EP(9,STD); E0(XCH); EOL(9); E0(XCH); EP(0,XCH); E0(TM) ; 04739000 - DTYP: OPTYPE[IT~IT-1]~DOUBTYPE ; 04740000 - END ; 04741000 - BEGIN TM~ADD; GO RLESSC END ; 04742000 - BEGIN 04743000 - EMITPAIR(0, XCH); 04744000 - EMITO(AD2); 04745000 - IT ~ IT-1; 04746000 - END; 04747000 - BEGIN EMITO(AD2); IT ~ IT-1 END; 04748000 - BEGIN TM~ADD; GO DLESSC END ; 04749000 - BEGIN EMITO(ADD); IT ~ IT-1 END; 04750000 - BEGIN TM~ADD; GO CLESSD END ; 04751000 - BEGIN TM~ADD; GO CLESSC END ; 04752000 - END ADD CASE STATEMENT; 04753000 - IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE 04754000 - CASE CODE OF 04755000 - BEGIN 04756000 - BEGIN 04757000 - EMITO(SUB); 04758000 - IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE 04759000 - OPTYPE[IT~IT-1] ~ REALTYPE; 04760000 - END; 04761000 - BEGIN E0(CHS); TM~AD2; GO RPLUSD END; 04762000 - BEGIN TM~SUB ; 04763000 - RLESSC: ES1(TM); GO DLESSC1 ; 04764000 - END ; 04765000 - BEGIN 04766000 - EMITPAIR(0, XCH); 04767000 - EMITO(SB2); 04768000 - IT ~ IT-1; 04769000 - END; 04770000 - BEGIN EMITO(SB2); IT ~ IT-1 END; 04771000 - BEGIN TM~SUB ; 04772000 - DLESSC: ES1(TM); E0(XCH); E0(DEL) ; 04773000 - DLESSC1: EOL(9); IF TM=SUB THEN E0(CHS); GO CTIMESR2 ; 04774000 - END ; 04775000 - BEGIN EMITO(SUB); IT ~ IT-1 END; 04776000 - BEGIN TM~SUB ; 04777000 - CLESSD: E0(XCH); E0(DEL); E0(TM) ; 04778000 - CTYP: OPTYPE[IT~IT-1]~COMPTYPE ; 04779000 - END ; 04780000 - BEGIN TM~SUB ; 04781000 - CLESSC: ES1(TM); GO CTIMESR1 ; 04782000 - END ; 04783000 - END SUBTRACT CASE STATEMENT; 04784000 - BEGIN % HANDLE NEGATIVE NUMBERS CASE STATEMENT. 04785000 - EXPV~-EXPV ; 04786000 - IF T2 { REALTYPE THEN EMITO(CHS) ELSE 04787000 - IF T2 = LOGTYPE THEN FLAG(55) ELSE 04788000 - IF T2 = DOUBTYPE THEN EMITO(CHS) ELSE 04789000 - IF T2 = COMPTYPE THEN 04790000 - BEGIN 04791000 - EMITO(CHS); EMITO(XCH); 04792000 - EMITO(CHS); EMITO(XCH); 04793000 - END ELSE FLAG(55); 04794000 - END OF NEG NUMBERS CASE STATEMNT ; 04795000 - IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE 04796000 - CASE CODE OF 04797000 - BEGIN 04798000 - BEGIN 04799000 - EMITO(MUL); 04800000 - IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE 04801000 - OPTYPE[IT~IT-1] ~ REALTYPE; 04802000 - END; 04803000 - BEGIN TM~ML2; GO RPLUSD END ; 04804000 - BEGIN ES2; GO DTIMESC END ; 04805000 - BEGIN 04806000 - EMITPAIR(0, XCH); 04807000 - EMITO(ML2); 04808000 - IT ~ IT-1; 04809000 - END; 04810000 - BEGIN EMITO(ML2); IT ~ IT-1 END; 04811000 - BEGIN ES2; E0(XCH); E0(DEL) ; 04812000 - DTIMESC: EOL(9); EOL(17); E0(MUL); GO CTYP ; 04813000 - END ; 04814000 - BEGIN TM~MUL ; 04815000 - CTIMESR: EP(9,SND); E0(TM) ; 04816000 - CTIMESR1:E0(XCH); EOL(9); E0(TM) ; 04817000 - CTIMESR2:E0(XCH); GO CTYP ; 04818000 - END ; 04819000 - BEGIN TM~MUL; GO CDIVBYD END ; 04820000 - MATH(2, 26, COMPTYPE); 04821000 - END MULTIPLY CASE STATEMENT; 04822000 - 04823000 - IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE 04824000 - CASE CODE OF 04825000 - BEGIN 04826000 - IF T1 = INTYPE AND T2 = INTYPE THEN 04827000 - BEGIN EMITO(IDV); IT ~ IT-1 END ELSE 04828000 - BEGIN EMITO(DIU); OPTYPE[IT~IT-1] ~ REALTYPE END; 04829000 - BEGIN 04830000 - EP(9,STD); EP(17,STD); EP(0,XCH); EOL(17); EOL(9); E0(DV2) ; 04831000 - GO DTYP ; 04832000 - END ; 04833000 - MATH(1, 29, COMPTYPE); 04834000 - BEGIN 04835000 - EMITPAIR(0, XCH); 04836000 - EMITO(DV2); 04837000 - IT ~ IT-1; 04838000 - END; 04839000 - BEGIN EMITO(DV2); IT ~ IT-1 END; 04840000 - MATH(2, 32, COMPTYPE); 04841000 - BEGIN TM~DIU; GO CTIMESR END ; 04842000 - BEGIN TM~DIU ; 04843000 - CDIVBYD: E0(XCH); E0(DEL); GO CTIMESR ; 04844000 - END ; 04845000 - MATH(2, 35, COMPTYPE); 04846000 - END OF DIVIDE CASE STATEMENT; 04847000 - IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE 04848000 - BEGIN 04849000 - IF CODE = 0 AND T2 = INTYPE AND 04850000 - CNSTSEENLAST THEN %113-04851000 - BEGIN 04852000 - IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE 04853000 - OPTYPE[IT~IT-1] ~ REALTYPE; 04854000 - EXPV~LINK; %113- 04855000 - A~1; ADR~SAVEADR; %113- 04856000 - WHILE EXPV DIV 2 ! 0 DO 04857000 - BEGIN 04858000 - EMITO(DUP); 04859000 - IF BOOLEAN(EXPV) THEN BEGIN A~A+1; EMITO(DUP) END; 04860000 - EMITO(MUL); 04861000 - EXPV ~ EXPV DIV 2; 04862000 - END; 04863000 - IF EXPV = 0 THEN BEGIN EMITO(DEL); EMITL(1) END ELSE 04864000 - WHILE A ~ A-1 ! 0 DO EMITO(MUL); 04865000 - END ELSE 04866000 - BEGIN 04867000 - EMITO(MKS); 04868000 - EMITL(CODE); 04869000 - EMITV(NEED(".XTOI ", INTRFUNID)); 04870000 - CASE CODE OF 04871000 - BEGIN 04872000 - BEGIN EMITO(DEL); OPTYPE[IT~IT-1]~IF (T1=INTYPE AND T2=INTYPE)04873000 - THEN INTYPE ELSE REALTYPE END; 04874000 - BEGIN EMITO(DEL); OPTYPE[IT~IT-1] ~ DOUBTYPE END; 04875000 - BEGIN EMITO(DEL); OPTYPE[IT~IT-1]~COMPTYPE END ; 04876000 - BEGIN EMITO(DEL); IT ~ IT-1 END; 04877000 - BEGIN EMITO(DEL); EMITO(DEL); IT ~ IT-1 END; 04878000 - BEGIN EMITO(DEL); EMITO(DEL); OPTYPE[IT~IT-1]~COMPTYPE END ; 04879000 - BEGIN EMITO(DEL); IT ~ IT-1 END; 04880000 - BEGIN EMITO(DEL); EMITO(DEL); IT ~ IT-1 END; 04881000 - BEGIN EMITO(DEL); EMITO(DEL); IT~IT-1 END ; 04882000 - END OF POWER CASE STATEMENT; 04883000 - END; 04884000 - END; 04885000 - END; 04886000 - IP ~ IP-1; 04887000 - END; 04888000 - EXPRESLT ~ EXPCLASS; 04889000 - STACK: 04890000 - PR[IP~IP+1] ~ PREC; 04891000 - OPST[IP] ~ OP; 04892000 - IF PREC > 0 AND PREC { 4 THEN 04893000 - BEGIN 04894000 - SCAN; LINK ~ FNEXT; 04895000 - IF NEXT = PLUS THEN GO TO LOOP; 04896000 - IF NEXT ! MINUS THEN GO TO NOSCAN; 04897000 - PREC ~ 8; OP ~ 12; 04898000 - GO TO STACK; 04899000 - END; 04900000 - GO TO LOOP; 04901000 - XIT: IF IP ! SAVIP THEN FLOG(56); 04902000 - IP ~ SAVIP-1; 04903000 - EXPR ~ OPTYPE[IT]; 04904000 - IF OPTYPE[IT-1] ! 0 THEN FLOG(56); 04905000 - IT ~ SAVIT-1; 04906000 - EXPRESULT ~ EXPRESLT; 04907000 - EXPVALUE ~ EXPV; 04908000 - EXPLINK ~ EXPLNK; 04909000 - IF DEBUGTOG THEN FLAGROUTINE(" EXPRE","SSION ",FALSE) ; 04910000 - END EXPR; 04911000 - 04912000 -PROCEDURE FAULT (X); 04913000 - VALUE X; 04914000 - REAL X; 04915000 - BEGIN REAL LINK; LABEL XIT; 04916000 - SCAN; IF GLOBALNEXT ! LPAREN THEN BEGIN FLAG(106); GO XIT END; 04917000 - SCAN; IF GLOBALNEXT ! ID THEN BEGIN FLAG(66); GO TO XIT END; 04918000 - IF X = 1 THEN PDPRT[0,0] ~ PDPRT[0,0] & 1[44:47:1] ELSE 04919000 - PDPRT[0,0] ~ PDPRT [0,0] & 1[43 :47:1]; 04920000 - EMITOPDCLIT(41); EMITO(DUP); 04921000 - IF X = 1 THEN BEGIN EMITL(2); EMITO(XCH); EMITL(1) END 04922000 - ELSE EMITL(6); 04923000 - EMITO(LND); 04924000 - IF X = 2 THEN EMITL(3); 04925000 - EMITO(SUB); 04926000 - IF X = 2 THEN 04927000 - BEGIN EMITO(DUP); EMITL(3); EMITO(SSN) ;EMITO(EQUL); EMITL(2)04928000 - ;EMITO(BFC) ; EMITO(DEL);EMITL(2); 04929000 - END; 04930000 - LINK ~ GET(GETSPACE(FNEXT)); EMITPAIR(LINK.ADDR,ISD); 04931000 - IF X = 1 THEN EMITL(30) ELSE EMITL(25); 04932000 - EMITO(LND); EMITL(41);EMITO(STD); 04933000 - SCAN; IF GLOBALNEXT ! RPAREN THEN FLAG(108); 04934000 - SCAN; 04935000 - XIT: 04936000 - END FAULT; 04937000 -PROCEDURE SUBREF; 04938000 -BEGIN REAL LINK,INFC; 04939000 - REAL ACCIDENT; 04940000 - LABEL XIT; 04941000 -IF DEBUGTOG THEN FLAGROUTINE(" SUB","REF ",TRUE ) ; 04942000 -IF TSSEDITOG THEN IF NAME="ZIP " AND NOT DCINPUT THEN TSSED(NAME,3) ; 04943000 - IF NAME = "EXIT " THEN 04944000 - BEGIN 04945000 - RETURNFOUND ~ TRUE; 04946000 - EMITL(1); 04947000 - EMITPAIR(16,STD); 04948000 - EMITPAIR(10,KOM); 04949000 - EMITPAIR( 5, KOM); 04950000 - PUT(FNEXT+1, "......"); 04951000 - SCAN; 04952000 - END ELSE IF NAME="ZIP " AND NOT DCINPUT THEN 04953000 - BEGIN 04954000 - EMITO(MKS); 04955000 - EMITL(0); EMITL(0); % DUMMY FILE AND FORMAT 04956000 - EMITPAIR(-1,SSN); 04957000 - EMITB(-1,FALSE); LADR1~LAX; ADJUST; DESCREQ~FALSE; 04958000 - IF ADR } 4085 THEN BEGIN ADR~ADR+1; SEGOVF END; 04959000 - ACCIDENT~PRGDESCBLDR(0,0,ADR.[36:10]+1,NSEG); 04960000 - EMITOPDCLIT(19); 04961000 - EMITO(GFW); 04962000 - LISTART ~ ADR&NSEG[TOSEGNO]; ADJUST;SCAN; 04963000 - IF GLOBALNEXT!LPAREN THEN BEGIN FLAG(106);GO TO XIT END; 04964000 - SCAN; IF GLOBALNEXT!ID THEN BEGIN FLAG(66); GO TO XIT END; 04965000 - LINDX ~ FNEXT; SCAN; XTA ~ GET(LINDX+1); 04966000 - IF GLOBALNEXT!RPAREN THEN BEGIN FLAG(108); GO TO XIT END; 04967000 - LINDX ~ GETSPACE(LINDX); 04968000 - IF T~(LINFA~GET(LINDX)).CLASS!ARRAYID THEN 04969000 - BEGIN FLAG(66); GO TO XIT END; 04970000 - IF XREF THEN ENTERX(XTA,0&LINFA[15:15:9]); 04971000 - EMITPAIR(LADDR~LINFA.ADDR,LOD); 04972000 - IF BOOLEAN(LINFA.FORMAL) THEN 04973000 - BEGIN 04974000 - IF T ~ GET(LINDX+2)<0 THEN EMITOPDCLIT(T.SIZE) 04975000 - ELSE EMITNUM(T.SIZE); EMITOPDCLIT(LADDR-1); EMITO(CTF) END 04976000 - ELSE EMITNUM(GET(LINDX+2).BASENSIZE); EMITL(18); EMITO(STD);; 04977000 - EMITL(LINFA.CLASNSUB&0[44:47:1]); EMITL(19); EMITO(STD); 04978000 - BRANCHLIT(LISTART,TRUE); EMITL(19); EMITO(STD); 04979000 - EMITO(RTS); ADJUST; 04980000 - EMITL(1); EMITO(CHS); EMITL(19); EMITO(STD); 04981000 - EMITDESCLIT(19); EMITO(RTS); FIXB(LADR1); DESCREQ~FALSE; 04982000 - EMITPAIR(ACCIDENT,LOD); EMITOPDCLIT(7); EMITO(FTF); 04983000 - EMITL(6); % EDITCODE 6 FOR ZIP 04984000 - EMITV(NEED(".FTOUT",INTRFUNID)); SCAN 04985000 - END ELSE IF NAME = "OVERFL" THEN FAULT(2) 04986000 - ELSE IF NAME = "DVCHK " THEN FAULT(1) 04987000 - ELSE 04988000 - BEGIN 04989000 - LINK ~ NEED(NAME, SUBRID); 04990000 - IF XREF THEN ENTERX(XTA,0&GET(LINK)[15:15:5]); 04991000 - EMITO(MKS); 04992000 - SCAN; 04993000 - IF GLOBALNEXT = LPAREN THEN 04994000 - BEGIN PARAMETERS(LINK); SCAN END ELSE 04995000 - IF NOT BOOLEAN((INFC~GET(LINK+2)).[1:1]) THEN 04996000 - PUT(LINK+2,-INFC) ELSE 04997000 - IF INFC.NEXTRA ! 0 THEN 04998000 - BEGIN XTA ~ GET(LINK+1); FLAG(28) END; 04999000 - EMITV(LINK); 05000000 - END; 05001000 - XIT: 05002000 -IF DEBUGTOG THEN FLAGROUTINE(" SUB","REF ",FALSE) ; 05003000 -END SUBREF; 05004000 - 05005000 -PROCEDURE DECLAREPARMS(FNEW); VALUE FNEW; REAL FNEW; 05006000 -BEGIN 05007000 - REAL I, T, NLABELS, INFA, INFB, INFC; 05008000 -IF DEBUGTOG THEN FLAGROUTINE("DECLAR","EPARMS",TRUE ) ; 05009000 - INFA ~ GET(FNEW); 05010000 - IF INFA.SEGNO ! 0 THEN BEGIN XTA ~ NNEW; FLAG(25) END; 05011000 - INFA.SEGNO ~ NSEG; PUT(FNEW,INFA); 05012000 - ENTRYLINK[ELX] ~ 0 & FNEW[TOLINK] & NEXTSS[TOADDR]; 05013000 - FOR I ~ 1 STEP 1 UNTIL PARMS DO 05014000 - BEGIN 05015000 - EXTRAINFO[NEXTSS.IR,NEXTSS.IC] ~ PARMLINK[I]; 05016000 - NEXTSS ~ NEXTSS-1; 05017000 - IF T ~ PARMLINK[I] ! 0 THEN 05018000 - BEGIN 05019000 - GETALL(T,INFA,INFB,INFC); 05020000 - IF BOOLEAN(INFA .FORMAL) THEN 05021000 - BEGIN 05022000 - IF INFA.SEGNO = ELX THEN 05023000 - BEGIN XTA ~ INFB ; FLAG(26) END; 05024000 - END ELSE IF (INFA < 0 AND INFA.ADDR < 1024) OR BOOLEAN(INFA.CE)05025000 - THEN BEGIN XTA ~ INFB; FLAG(107) END; 05026000 - INFA ~ INFA & 1[TOFORMAL] & ELX[TOSEGNO]; 05027000 - INFC .BASE ~ I; 05028000 - PUT(T,INFA); PUT(T+2,INFC); 05029000 - END ELSE NLABELS ~ NLABELS+1; 05030000 - END; 05031000 - IF NLABELS > 0 THEN 05032000 - BEGIN ENTRYLINK[ELX ].CLASS ~ NLABELS; 05033000 - IF LABELMOM=0 THEN BEGIN BUMPLOCALS; LABELMOM~LOCALS+1536 END; 05034000 - END; 05035000 - GETALL(FNEW,INFA,INFB,INFC); 05036000 - IF BOOLEAN(INFC.[1:1]) THEN 05037000 - BEGIN 05038000 - IF INFC.NEXTRA ! PARMS THEN 05039000 - BEGIN XTA ~ INFB; FLOG(41); 05040000 - PARMS ~ INFC.NEXTRA; 05041000 - END; 05042000 - T ~ INFC.ADINFO; 05043000 - FOR I ~ 1 STEP 1 UNTIL PARMS DO 05044000 - IF NOT(PARMLINK[I] = 0 EQV 05045000 - EXTRAINFO[(T+I-1).IR,(T+I-1).IC].CLASS = LABELID) THEN 05046000 - BEGIN IF PARMLINK[I] = 0 THEN XTA ~ "* " 05047000 - ELSE XTA ~ GET(PARMLINK[I]+1); 05048000 - FLAG(40); 05049000 - END; 05050000 - END 05051000 - ELSE 05052000 - BEGIN 05053000 - IF PARMS = 0 THEN INFC ~ -INFC ELSE 05054000 - INFC ~ -(INFC & PARMS[TONEXTRA] 05055000 - & NEXTEXTRA[TOADINFO]); 05056000 - PUT(FNEW+2,INFC); 05057000 - FOR I ~ 1 STEP 1 UNTIL PARMS DO 05058000 - BEGIN 05059000 - EXTRAINFO[NEXTEXTRA.IR,NEXTEXTRA.IC] ~ 0 & 05060000 - (IF PARMLINK[I] = 0 THEN LABELID ELSE 0)[TOCLASS]; 05061000 - NEXTEXTRA ~ NEXTEXTRA+1; 05062000 - END; 05063000 - END; 05064000 - IF ELX ~ ELX+1 > MAXEL THEN BEGIN FLAG(128); ELX ~ 0 END; 05065000 -IF DEBUGTOG THEN FLAGROUTINE("DECLAR","EPARMS",FALSE) ; 05066000 -END DECLAREPARMS; 05067000 -PROCEDURE IOLIST(LEVEL); REAL LEVEL; 05068000 -BEGIN ALPHA LADR2,T; 05069000 -BOOLEAN A; 05070000 -INTEGER INDX,I,BDLINK,NSUBS; 05071000 - LABEL ROUND,XIT,ERROR,LOOP,SCRAM; 05072000 -INTEGER STREAM PROCEDURE CNTNAM(IDEN); VALUE IDEN; 05073000 -BEGIN LABEL XIT; 05074000 - SI ~ LOC IDEN; SI ~ SI + 3; TALLY ~ 1; 05075000 - 5(IF SC = " " THEN JUMP OUT TO XIT;SI ~ SI+1;TALLY ~ TALLY+1); 05076000 - XIT: CNTNAM ~ TALLY; 05077000 -END CNTNAM; 05078000 -IF DEBUGTOG THEN FLAGROUTINE(" IOL","IST ",TRUE ) ; 05079000 -ROUND: DESCREQ ~ TRUE; 05080000 - LOCALNAME ~ FALSE; 05081000 -IF GLOBALNEXT = SEMI THEN GO TO XIT; 05082000 -IF GLOBALNEXT = STAR THEN 05083000 - BEGIN IF NOT NAMEDESC THEN 05084000 - TV ~ ENTER(0&LISTSID[TOCLASS],LISTID~LISTID+1); 05085000 - LOCALNAME ~ TRUE; NAMEDESC ~ TRUE; SCAN; 05086000 - END; 05087000 -IF GLOBALNEXT = ID THEN 05088000 -BEGIN LINDX ~ FNEXT; 05089000 - SCAN; XTA ~ GET(LINDX+1); 05090000 - IF GLOBALNEXT = EQUAL THEN %RETURN TO CALLER 05091000 - BEGIN IF (LINFA~GET(GETSPACE(LINDX))).CLASS ! VARID THEN FLAG(50);05092000 - SCRAM: IF (LEVEL ~ LEVEL-1) < 0 THEN FLOG(97); 05093000 - GO TO XIT; 05094000 - END; 05095000 - 05096000 - IF DATASTMTFLAG AND SPLINK } 0 THEN %DECLARE OWN 05097000 - BEGIN 05098000 - IF BOOLEAN(GET(LINDX).FORMAL) THEN FLAG(147); 05099000 - IF SPLINK>1 THEN 05100000 - IF GET(LINDX).ADDR>1023 THEN FLAG(174); 05101000 - LINDX ~ GETSPACE(-LINDX); 05102000 - IF BOOLEAN(GET(LINDX).EQ) THEN FLAG(168); 05103000 - END ELSE LINDX ~ GETSPACE(LINDX); 05104000 - IF T ~ (LINFA~GET(LINDX)).CLASS > VARID THEN FLAG(50); 05105000 - IF XREF THEN ENTERX(XTA,C2&LINFA[15:15:9]); 05106000 - IF GLOBALNAME OR LOCALNAME THEN 05107000 - IF NAMEIND~ NAMEIND+1 GTR LSTMAX THEN FLOG(161) 05108000 - ELSE NAMLIST[NAMEIND] ~ XTA & CNTNAM(XTA)[9:45:3]; 05109000 - IF T = ARRAYID THEN 05110000 - IF GLOBALNEXT ! LPAREN THEN 05111000 - BEGIN IF SPLINK ! 1 THEN 05112000 - BEGIN 05113000 - EMITL(0); 05114000 - EMITPAIR(LADDR ~ LINFA.ADDR,LOD); 05115000 - EMITO(FTC); 05116000 - EMITDESCLIT(2); 05117000 - EMITO(INX); 05118000 - EMITO(LOD); 05119000 - END ELSE EMITPAIR(LADDR-LINFA.ADDR,LOD); 05120000 - NSUBS ~ (T ~ GET (LINDX+2)).NEXTRA; 05121000 - IF GLOBALNAME OR LOCALNAME THEN 05122000 - BEGIN 05123000 - IF NSUBS GTR SAVESUBS THEN SAVESUBS ~ NSUBS; 05124000 - IF NSUBS GTR NAMLIST[0] THEN NAMLIST[0] ~ NSUBS; 05125000 - NAMLIST[NAMEIND].[1:8] ~ NSUBS; 05126000 - INDX ~ -1; 05127000 - INFA ~ GET(NEED(".SUBAR",BLOCKID)).ADDR; 05128000 - BDLINK ~ T.ADINFO+1; 05129000 - END; 05130000 - IF BOOLEAN (LINFA.FORMAL) THEN 05131000 - BEGIN 05132000 - IF T LSS 0 THEN EMITOPDCLIT(T.SIZE) 05133000 - ELSE EMITNUM(T.SIZE); 05134000 - EMITOPDCLIT(LADDR-1); 05135000 - EMITO(CTF); 05136000 - END ELSE EMITNUM(T.BASENSIZE); 05137000 - IF GLOBALNAME OR LOCALNAME THEN 05138000 - FOR I ~ 1 STEP 1 UNTIL NSUBS DO 05139000 - BEGIN IF T ~ EXTRAINFO[(BDLINK~BDLINK-1).IR, 05140000 - BDLINK.IC] LSS 0 THEN EMITOPDCLIT(T) 05141000 - ELSE EMITNUM(T); 05142000 - EMITNUM(INDX ~ INDX+1); 05143000 - EMITDESCLIT(INFA); 05144000 - EMITO(STD); 05145000 - END; 05146000 - EMITL(18); EMITO(STD); 05147000 - END ELSE 05148000 - BEGIN SCAN; 05149000 - A ~(IF GLOBALNAME OR LOCALNAME 05150000 - THEN SUBSCRIPTS(LINDX,4) ELSE SUBSCRIPTS(LINDX,2)); 05151000 - SCAN; 05152000 - END 05153000 - ELSE EMITN(LINDX); 05154000 - IF GLOBALNAME OR LOCALNAME THEN 05155000 - BEGIN EMITOPDCLIT(18); EMITNUM(NAMEIND); 05156000 - EMITD(43,DIA); EMITD(3,DIB); EMITD(15,TRB); 05157000 - EMITL(18); EMITO(STD); 05158000 - END; 05159000 - EMITL(LINFA.CLASNSUB&0[44:47:1]); 05160000 - EMITL(20); EMITO(STD); 05161000 - IF ADR > 4083 THEN 05162000 - BEGIN ADR~ADR+1; SEGOVF END ; 05163000 - BRANCHLIT(LISTART,TRUE); 05164000 - EMITL(19); EMITO(STD); 05165000 - EMITO(RTS); ADJUST; 05166000 - GO TO LOOP; 05167000 -END; 05168000 -IF GLOBALNEXT = LPAREN THEN % RECURSE ON ( 05169000 -BEGIN EMITB(-1,FALSE); 05170000 - ADJUST; 05171000 - LADR2 ~ (ADR + 1)&LAX[TOADDR]&NSEG[TOSEGNO]; 05172000 - SCAN; LEVEL ~ LEVEL + 1; 05173000 - IOLIST(LEVEL); 05174000 - IF GLOBALNEXT ! EQUAL THEN % PHONY IMP DO 05175000 - BEGIN BRANCHES[T ~ LADR2.ADDR] ~ BRANCHX; 05176000 - BRANCHX ~ T; 05177000 - IF GLOBALNEXT ! RPAREN THEN GO TO ERROR; 05178000 - SCAN; GO TO LOOP; 05179000 - END; 05180000 - IF XREF THEN ENTERX(GET(LINDX+1),1&LINFA[15:15:9]); 05181000 - IF LINFA.SUBCLASS > REALTYPE THEN 05182000 - BEGIN XTA ~ GET(LINDX + 1); 05183000 - FLAG(84); 05184000 - END; 05185000 - EMITB(-1,FALSE); 05186000 - LADR3 ~ LAX; 05187000 - FIXB(LADR2.ADDR); 05188000 - DESCREQ ~ FALSE; 05189000 - SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(102); % INITIAL VALUE 05190000 - EMITN(LINDX); EMITO(STD); 05191000 - EMITB(LADR2,FALSE); 05192000 - IF GLOBALNEXT ! COMMA THEN GO TO ERROR; 05193000 - ADJUST; 05194000 - LADR4 ~ (ADR + 1)&NSEG[TOSEGNO]; 05195000 - SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(102) ELSE EMITO(GRTR); 05196000 - EMITB(LADR2,TRUE); 05197000 - EMITB(-1,FALSE); 05198000 - LADR5 ~ LAX; 05199000 - FIXB(LADR3); 05200000 - IF GLOBALNEXT ! COMMA THEN EMITL(1) 05201000 - ELSE BEGIN SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(102); END; 05202000 - EMITV(LINDX); EMITO(ADD); 05203000 - EMITN(LINDX); EMITO(SND); 05204000 - EMITB(LADR4,FALSE); 05205000 - FIXB(LADR5); 05206000 - IF GLOBALNEXT = RPAREN THEN SCAN ELSE GO TO ERROR; 05207000 - LOOP: IF GLOBALNEXT = SEMI OR GLOBALNEXT = SLASH THEN GO TO XIT; 05208000 - IF GLOBALNEXT = RPAREN THEN GO TO SCRAM; 05209000 - IF GLOBALNEXT = COMMA THEN 05210000 - BEGIN SCAN; 05211000 - IF GLOBALNEXT = SEMI THEN GO TO ERROR; 05212000 - GO TO ROUND; 05213000 - END; 05214000 - ERROR: XTA ~ NAME; 05215000 - FLAG(94); 05216000 - IF GLOBALNEXT = SEMI THEN GO TO XIT; 05217000 - SCAN; 05218000 - IF GLOBALNEXT = ID THEN GO TO ROUND; 05219000 - ERRORTOG ~ TRUE; GO TO XIT; 05220000 - END; 05221000 - IF GLOBALNEXT = RPAREN THEN GO TO SCRAM ELSE 05222000 - IF GLOBALNEXT ! SLASH THEN GO TO ERROR; 05223000 - XIT: IF DEBUGTOG THEN FLAGROUTINE(" IOL","IST ",FALSE) ; 05224000 - END IOLIST; 05225000 - INTEGER PROCEDURE FILECHECK(FILENAME,FILETYPE); 05226000 - VALUE FILENAME,FILETYPE; ALPHA FILENAME; INTEGER FILETYPE; 05227000 - BEGIN COMMENT THIS PROCEDURE RETURNS THE PRT CELL ALLOCATED TO 05228000 - THE FILE FILENAME... A CELL IS CREATED IF NONE EXISTS; 05229000 - IF DEBUGTOG THEN FLAGROUTINE(" FILEC","HECK ",TRUE); 05230000 - EMITL(IF NOTOPIO THEN 2 ELSE 5); % FOR IO DESCRIPTOR 05231000 - IF T ~ GLOBALSEARCH(FILENAME) = 0 THEN % FILE UNDECLARED 05232000 - BEGIN MAXFILES ~ MAXFILES + 1; 05233000 - BUMPPRT; 05234000 - I ~ GLOBALENTER(-0&(FILECHECK~PRTS)[TOADDR] 05235000 - &FILEID[TOCLASS],FILENAME)+2; 05236000 - INFO[I.IR,I.IC]. LINK ~ FILETYPE; 05237000 - END ELSE % FILE ALREADY EXISTS 05238000 - FILECHECK ~ GET(T).ADDR; 05239000 - IF DEBUGTOG THEN FLAGROUTINE(" FILEC","HECK ",FALSE) ; 05240000 - END FILECHECK; 05241000 - PROCEDURE INLINEFILE; 05242000 - BEGIN COMMENT THIS PROCEDURE GENERATES THE CODE TO BRING UP THE FILE...05243000 - IF THE FILE IS AN INTEGER THEN FILECHECK IS CALLED, IF THE FILE 05244000 - IS NOT AN INTEGER THEN IN-LINE CODE IS GENERATED FOR OBJECT TIME 05245000 - ANALYSIS; 05246000 - REAL TEST; 05247000 - COMMENT IF LAST INSTRUCTION WAS A LIT CALL THEN WE HAVE SEEN REFERENCE 05248000 - TO AN INTEGER FILE ID; 05249000 - IF DEBUGTOG THEN FLAGROUTINE(" INLIN","EFILE ",TRUE ) ; 05250000 - TEST~ADR ; 05251000 - IF EXPR(TRUE)>REALTYPE THEN FLAG(102) 05252000 - ELSE IF EXPRESULT=NUMCLASS THEN 05253000 - BEGIN XTA~NNEW ; 05254000 - IF EXPVALUE}1.0@5 OR EXPVALUE{0.5 THEN FLAG(33) 05255000 - ELSE BEGIN 05256000 - IF ADR LSTMAX THEN GO TO NUL; 05446000 - WSA[TOTAL] ~ I ~ 0; GO TO ROUND; 05447000 - END ELSE GO TO ROUND ELSE GO TO NUL1; 05448000 - END; 05449000 - IF NOT STRINGF THEN 05450000 - IF SLCNT > 0 THEN 05451000 - IF T = "/" THEN BEGIN SLCNT ~ SLCNT+1; GO TO ROUND; END 05452000 - ELSE 05453000 - BEGIN WSA[TOTAL] ~ 0 & SLCNT[TOREPEAT] & SLASH[TOCODE]; 05454000 - IF NOT STR THEN 05455000 - IF REPEAT < 16 AND WSA[TOTAL-1].[42:6] = 0 THEN 05456000 - WSA[TOTAL~TOTAL-1] ~ WSA[TOTAL] & SLCNT[42:44:4] 05457000 - & 1[46:47:1]; 05458000 - COMMAS~DOLLARS~BOOLEAN(SLCNT~0); NCR~BACKNCR(NCR) ; 05459000 - GO TO NUL1; 05460000 - END; 05461000 - IF NOT QF THEN IF T = """ THEN IF STRINGF ~ NOT STRINGF THEN 05462000 - BEGIN IF CODE > 4 THEN BEGIN STRINGF ~ FALSE; 05463000 - NCR ~ BACKNCR(NCR); GO TO ENDER END; 05464000 - SAVTOTAL ~ TOTAL; J~0; I~3; QF ~ TRUE; 05465000 - WSA[TOTAL] ~ 0 & HPHASE[TOCODE]; 05466000 - GO TO ROUND; 05467000 - END ELSE 05468000 - BEGIN 05469000 - WSA[SAVTOTAL] ~ WSA[SAVTOTAL] & J[TOREPEAT]; 05470000 - IF I = 0 THEN TOTAL ~ TOTAL - 1; 05471000 - CODE ~ HPHASE; 05472000 - GO TO ENDER; 05473000 - END; 05474000 - IF STRINGF THEN 05475000 - BEGIN 05476000 - STORECHAR(WSA[TOTAL],I,T); 05477000 - J ~ J + 1; QF ~ FALSE; 05478000 - IF I ~ I+1 = 8 THEN 05479000 - BEGIN 05480000 - IF TOTAL ~ TOTAL +1> LSTMAX THEN GO TO NUL; 05481000 - I ~ WSA[TOTAL] ~ 0; 05482000 - END; 05483000 - GO TO ROUND; 05484000 - END; 05485000 -CASE T OF 05486000 -BEGIN 05487000 - BEGIN ZF ~ TRUE; % 0 05488000 - NUM: DECIMAL ~ 10 | DECIMAL + T; 05489000 - IF ASK THEN 05490000 - BEGIN FLAG(183); %111-05491000 -FL: DO BEGIN NCR~GETCHAR(NCR,T); XTA~T&XTA[12:18:30] END 05492000 - UNTIL T!"*" AND T>9 AND T!" " ; 05493000 - NCR~BACKNCR(NCR); XTA~BLANKS&XTA[18:12:30] ; 05494000 - END 05495000 - ELSE 05496000 - IF DECIMAL>4090 THEN BEGIN FLAG(172); DECIMAL~1 END ; 05497000 - IF CODE = 0 THEN REPEAT ~ DECIMAL 05498000 - ELSE IF PF THEN BEGIN IF DECIMAL>WIDTH AND WIDTH!0 AND CODE! 05499000 - VPHRASE THEN FLAG(129) END ELSE WIDTH~DECIMAL ; 05500000 - GO TO ROUND; 05501000 - END; 05502000 - GO TO NUM; GO TO NUM; GO TO NUM; % 1 2 3 05503000 - GO TO NUM; GO TO NUM; GO TO NUM; % 4 5 6 05504000 - GO TO NUM; GO TO NUM; GO TO NUM; % 7 8 9 05505000 - ; ; ; ; ; ; % # @ Q : > } 05506000 - BEGIN PLUSP ~ TRUE; GO TO ROUND; END; % + 05507000 - BEGIN CODE ~ APHASE; GO TO NOEND END; % A 05508000 - ; % B 05509000 - BEGIN CODE ~ CPHASE; GO TO NOEND END; % C 05510000 - BEGIN CODE ~ DPHASE; GO TO NOEND END; % D 05511000 - BEGIN CODE ~ EPHASE; GO TO NOEND END; % E 05512000 - BEGIN CODE ~ FPHASE; GO TO NOEND END; % F 05513000 - BEGIN CODE ~ GPHASE; GO TO NOEND END; % G 05514000 - BEGIN IF REPEAT = 0 THEN FLOG(130); % H 05515000 - IF ASK THEN BEGIN FLOG(32 ); GO SEMIC END ; 05516000 - HF ~ TRUE; I ~ 3; CODE ~ HPHASE; 05517000 - WSA[TOTAL] ~ 0 & HPHASE[TOCODE] & REPEAT[TOREPEAT]; 05518000 - GO TO ROUND; 05519000 - END; 05520000 - BEGIN CODE ~ IPHASE; GO TO NOEND END; % I 05521000 - BEGIN IF CODE < 11 OR CODE=15 THEN FLOG(134); % . 05522000 - IF CODE=0 OR PF THEN FLOG(32) ; 05523000 - PF~TRUE; DECIMAL~0; ASK~ZF~FALSE ; 05524000 - GO TO ROUND; 05525000 - END; 05526000 - GO TO RP; % [ 05527000 - ; % & 05528000 - LP: 05529000 - BEGIN IF CODE ! 0 THEN FLOG(32); % ( 05530000 - IF ASK THEN REPEAT~4095; IF REPEAT=0 AND ZF THEN FLAG(173) ;05531000 - NAMLIST[SAVLASTLP ~ PARENCT ~ PARENCT+1] ~ 0 & TOTAL[TOWIDTH]05532000 - &(IF REPEAT{0 AND PARENCT>1 THEN 1 ELSE REPEAT)[TOREPEAT] ; 05533000 - IF ASK THEN 05534000 - BEGIN ASK~VRB~FALSE ; 05535000 - WSA[TOTAL]~32&LPPHRASE[TOCODE]&4095[TOREPEAT] ; 05536000 - IF (TOTAL~TOTAL+1)>LSTMAX THEN GO NUL ; 05537000 - END ; 05538000 - ZF~BOOLEAN(REPEAT~DECIMAL~0) ; 05539000 - STR ~ TRUE; 05540000 - GO TO ROUND1; 05541000 - END; 05542000 - ; ; ; % < ~ | 05543000 - BEGIN CODE~JPHASE; WIDTH~-1; GO NOEND END ; % J 05544000 - BEGIN % K 05545000 - IF COMMAS OR CODE!0 THEN BEGIN FLAG(32); COMMAS~TRUE END 05546000 - ELSE BEGIN COMMAS~TRUE ; 05547000 -KK: DO BEGIN NCR~GETCHAR(NCR,T); XTA~T&XTA[12:18:30] END 05548000 - UNTIL T!" " ; 05549000 - IF (T<17 OR (T>25 AND T<33) OR (T>42 AND T<50) OR T>57) 05550000 - THEN BEGIN FLAG(32) ; 05551000 - IF T="*" OR T<10 THEN BEGIN DECIMAL~1; GO FL END ; 05552000 - END ; 05553000 - NCR~BACKNCR(NCR); XTA~BLANKS&XTA[18:12:30] ; 05554000 - END ; 05555000 - GO ROUND ; 05556000 - END OF K ; 05557000 - BEGIN CODE ~ LPHASE; GO TO NOEND; END; % L 05558000 - ; ; % M N 05559000 - BEGIN CODE ~ OPHASE; GO TO NOEND; END; % O 05560000 - BEGIN WSA[TOTAL] ~ 0 & PPHASE[TOCODE] % P 05561000 - & REAL(VRB)[42:47:1] 05562000 - & REAL(MINUSP)[TOSIGN] & REPEAT[TOWIDTH]&1[TOREPEAT]; 05563000 - MINUSP ~ PLUSP ~ FALSE; 05564000 - IF (DECIMAL = 0 AND NOT ZF) THEN FLOG(131); 05565000 - GO TO NUL1; 05566000 - END; 05567000 - ; ; % Q R 05568000 - BEGIN IF DOLLARS OR CODE!0 THEN FLAG(32) % $ 05569000 - ELSE BEGIN DOLLARS~TRUE; GO KK END ; 05570000 - DOLLARS~TRUE; GO ROUND ; 05571000 - END OF DOLLAR SIGN ; 05572000 - IF NOT ASK THEN % * 05573000 - BEGIN 05574000 - IF ZF OR DECIMAL NEQ 0 THEN FLAG(183); DECIMAL:=4095; %111-05575000 - IF CODE=0 THEN REPEAT~DECIMAL 05576000 - ELSE IF NOT PF THEN WIDTH~DECIMAL ; 05577000 - VRB := ASK := LISTEL := TRUE; GO ROUND; %101-05578000 - END ELSE BEGIN DECIMAL:=4095; FLAG(183); GO FL END ; %111-05579000 - BEGIN MINUSP ~ TRUE; GO TO ROUND; END; % - 05580000 - RP: 05581000 - BEGIN IF FEELD THEN BEGIN NCR ~ BACKNCR(NCR); % ) 05582000 - GO TO ENDER; END; 05583000 - IF DECIMAL ! 0 THEN FLAG(32); 05584000 - I ~ IF PARENCT = 1 THEN IF SAVLASTLP > 1 THEN 2 ELSE 1 05585000 - ELSE PARENCT; 05586000 - WSA[TOTAL]~(J~NAMLIST[I])&(TOTAL+1-J~J.[18:12])[TOLINK] 05587000 - & (IF PARENCT ~ PARENCT-1 = 0 THEN 77 ELSE 0)[TODECIMAL]; 05588000 - IF WSA[J].[1:5]=LPPHRASE AND PARENCT!0 THEN 05589000 - BEGIN WSA[J].[18:12]~TOTAL-J; WSA[TOTAL].[18:12]~TOTAL-J ;05590000 - END ; 05591000 - NAMLIST[I].[6:12] ~ 0; 05592000 - CODE ~ HPHASE; 05593000 - GO TO NUL1; 05594000 - END; 05595000 - ; ; % ; LEQ 05596000 - GO TO ROUND; % BLANKS 05597000 - BEGIN SLCNT ~ 1; % / 05598000 -SL: IF CODE=0 THEN IF ASK OR ZF OR DECIMAL!0 THEN 05599000 - BEGIN FLAG(32); ASK~ZF~BOOLEAN(DECIMAL~0) END ; 05600000 - IF CODE<5 THEN IF T="," THEN GO ROUND1 ELSE GO ROUND ELSE GO 05601000 - ENDER ; 05602000 - END; 05603000 - ; % S 05604000 - BEGIN IF REPEAT ! 0 THEN FLAG(32); % T 05605000 - CODE ~ TPHASE; 05606000 - GO TO NOEND; 05607000 - END; 05608000 - ; % U 05609000 - BEGIN VRB~TRUE; CODE~VPHRASE; WIDTH~-1; GO NOEND END ; % V 05610000 - ; % W 05611000 - BEGIN IF REPEAT = 0 THEN FLOG(130); % X 05612000 - IF STR THEN 05613000 - NEWWD: WSA[TOTAL] ~ 0 & XPHASE[TOCODE] & REPEAT[TOWIDTH] 05614000 - & 1[TOREPEAT] 05615000 - & REAL(VRB)[42:47:1] 05616000 - ELSE 05617000 - BEGIN 05618000 - IF (J~WSA[TOTAL-1]).[42:6]>0 OR (I~J.[1:5])=RTPARN 05619000 - OR (REPEAT}32 AND I!XPHASE) THEN GO NEWWD ; 05620000 - IF I=XPHASE AND (I~J.[18:12]+REPEAT){4090 THEN 05621000 - WSA[TOTAL~TOTAL-1] ~ J & I[TOWIDTH] 05622000 - ELSE IF REPEAT } 32 THEN GO TO NEWWD 05623000 - ELSE WSA[TOTAL~TOTAL-1] ~ J & REPEAT[TONUM] 05624000 - & 1[TOCNTRL]; 05625000 - END; 05626000 - GO TO NUL1; 05627000 - END; 05628000 - ; ; % Y Z 05629000 - GO SL ; % , 05630000 - GO TO LP; % % 05631000 - ; ; ; % ! = ] " 05632000 -END OF CASE STATEMENT; 05633000 -FLOG(132); % ILLEGAL CHARACTER; 05634000 -GO TO FALL; 05635000 -ENDER: IF CODE > 4 THEN 05636000 - BEGIN IF WIDTH=0 THEN FLAG(130) ; 05637000 - IF CODE=VPHRASE THEN 05638000 - BEGIN 05639000 - IF WIDTH=-1 THEN IF PF THEN FLAG(130)ELSE WIDTH~ 05640000 - DECIMAL~4094 ELSE 05641000 - IF NOT PF THEN DECIMAL~4094 ; 05642000 - END 05643000 - ELSE 05644000 - IF CODE > 10 AND CODE ! 15 THEN 05645000 - IF (DECIMAL = 0 AND NOT ZF) OR NOT PF THEN FLAG(133) 05646000 - ELSE ELSE DECIMAL ~ 0; 05647000 - IF REPEAT=0 THEN REPEAT~1 ; 05648000 - IF WIDTH=-1 THEN WIDTH~0 ; 05649000 - WSA[TOTAL] ~ 0 & CODE[TOCODE] & WIDTH[TOWIDTH] 05650000 - & REPEAT[TOREPEAT] & DECIMAL[TODECIMAL] 05651000 - & REAL(COMMAS) [44:47:1] 05652000 - & REAL(VRB)[42:47:1] 05653000 - & REAL(DOLLARS)[45:47:1]; 05654000 - END ELSE IF DECIMAL ! 0 THEN FLAG(32); 05655000 -NUL1: IF PLUSP THEN FLAG(164); 05656000 - IF CODE!VPHRASE THEN 05657000 - BEGIN 05658000 - IF DOLLARS AND(CODE < 9 OR CODE > 14) THEN FLAG(166); 05659000 - IF COMMAS AND NOT(CODE = 10 OR CODE = 12 OR CODE = 9) 05660000 - THEN FLAG(165); 05661000 - END; 05662000 - VRB~ 05663000 - ERRORTOG ~ FEELD ~ PF ~ PLUSP ~ DOLLARS ~ COMMAS ~ STR ~ FALSE; 05664000 - IF CODE = HPHASE THEN STR ~ TRUE; 05665000 - CODE ~ REPEAT ~ WIDTH ~ 0; 05666000 - XTA ~ BLANKS; 05667000 - GO TO FALL; 05668000 -NOEND: IF FEELD THEN FLAG(32); 05669000 - IF CODE ! TPHASE THEN LISTEL ~ TRUE ELSE REPEAT ~ 1; 05670000 - IF REPEAT=0 AND ZF THEN FLAG(173) ; 05671000 - FEELD ~ TRUE; 05672000 -FALL: IF MINUSP THEN BEGIN FLAG(32); MINUSP ~ FALSE END; 05673000 - ASK~ZF~FALSE ; 05674000 -NUL: DECIMAL ~ 0; 05675000 - IF PARENCT = 0 THEN BEGIN SCN ~ 1; GO TO SEMIC END; 05676000 - IF CODE < 5 THEN 05677000 - IF TOTAL ~ TOTAL+1 > LSTMAX THEN 05678000 - BEGIN FLOG(78);TOTAL ~ TOTAL-2; GO TO SEMIC; END; 05679000 -GO TO ROUND; 05680000 -NOPLACE: IF(DCINPUT OR FREEFTOG) AND (STRINGF OR HF) THEN FLOG(150); 05681000 - IF TSSEDITOG THEN IF (STRINGF OR HF) AND NOT DCINPUT 05682000 - THEN TSSED(XTA,1); 05683000 - IF CONTINUE THEN IF READACARD THEN 05684000 - BEGIN IF LISTOG THEN PRINTCARD; GO TO ROUND; END; 05685000 -SCN ~ 0; NEXT ~ SEMI; 05686000 -SEMIC: 05687000 -IF SCN = 1 THEN SCAN; 05688000 -IF STRINGF THEN FLAG(22); 05689000 -IF NOT LISTEL THEN WSA[0] ~ 0; 05690000 -IF PARENCT ! 0 THEN FLAG(IF PARENCT < 0 THEN 9 ELSE 8); 05691000 -IF D ! 0 THEN PRTSAVER(D,TOTAL+1,WSA); 05692000 -IF DEBUGTOG THEN BEGIN 05693000 - WRITE(LINE,FM) ; 05694000 - FOR I~0 STEP 1 UNTIL TOTAL DO BEGIN 05695000 - WRITE(LINE,[13]//,I,(J~WSA[I]).[1:5],J.[6:12],J.[18:12],J.[30:12], 05696000 - J.[41:1],J.[42:4],J.[42:5],J.[44:1],J.[45:1], 05697000 - J.[46:1],J.[46:2],J.[47:1]) ; 05698000 - IF J.[1:5]=2 THEN I~I+(J.[6:12]+2).[36:9] ; 05699000 - END ; 05700000 - WRITE(LINE[DBL]) ; 05701000 - END OF DEBUGSTUFF ; 05702000 -END FORMATER; 05703000 - 05704000 -PROCEDURE EXECUTABLE; 05705000 -BEGIN LABEL XIT; REAL T, J, TS, P; 05706000 - IF SPLINK < 0 THEN FLAG(12); 05707000 - IF LABL = BLANKS THEN GO TO XIT; 05708000 - IF T ~ SEARCH(XTA ~ LABL) = 0 THEN 05709000 - T ~ ENTER(-0 & LABELID[TOCLASS] & (ADR+1)[TOADDR] & 05710000 - NSEG[TOSEGNO], LABL) ELSE 05711000 - BEGIN IF (P ~ GET(T)).CLASS ! LABELID THEN 05712000 - BEGIN FLAG(144); GO TO XIT END; 05713000 - IF P < 0 THEN BEGIN FLAG(20); GO TO XIT END; 05714000 - TS ~ P.ADDR; 05715000 - WHILE TS ! 0 DO 05716000 - BEGIN J ~ GIT(TS); FIXB(TS+10000); TS ~ J END; 05717000 - PUT(T, P~-P & (ADR+1)[TOADDR] & NSEG[TOSEGNO]); 05718000 - IF (T ~ GET(T+2)).BASE ! 0 THEN 05719000 - T ~ PRGDESCBLDR(2, T.BASE, (ADR+1).[36:10], NSEG); 05720000 - END; 05721000 - IF XREF THEN ENTERX(LABL,1&LABELID[TOCLASS]); 05722000 - XIT: 05723000 -END EXECUTABLE; 05724000 - 05725000 -PROCEDURE IOCOMMAND(N); VALUE N; REAL N; 05726000 -COMMENT N COMMAND 05727000 - 0 READ 05728000 - 1 WRITE 05729000 - 2 PRINT 05730000 - 3 PUNCH 05731000 - 4 BACKSPACE 05732000 - 7 DATA; 05733000 -BEGIN LABEL XIT,SUCH,LISTER,NOFORM,FORMER,WRAP,DAAT,NF; 05734000 -LABEL LISTER1; 05735000 - BOOLEAN SUCHTOG, RDTRIN, FREEREAD; 05736000 - BOOLEAN FORMARY, NOFORMT; 05737000 - BOOLEAN NAMETOG; 05738000 -DEFINE DATATOG = DATASTMTFLAG#; 05739000 -REAL T, ACCIDENT, EDITCODE; 05740000 -REAL DATAB; 05741000 -PROCEDURE ACTIONLABELS(UNSEEN); VALUE UNSEEN; BOOLEAN UNSEEN; 05742000 -BEGIN LABEL EOF,ERR,RATA,XIT,ACTION,MULTI; 05743000 - BOOLEAN BACK,GOTERR,GOTEOF; 05744000 -IF UNSEEN THEN SCAN; 05745000 -EOF: IF GOTEOF THEN GO TO MULTI; 05746000 - IF BACK ~ NAME = "END " THEN GO TO ACTION; 05747000 -ERR: IF GOTERR THEN GO TO MULTI; 05748000 - IF NAME ! "ERR " THEN IF GOTEOF THEN 05749000 - BEGIN MULTI: XTA ~ NAME; FLOG(137); 05750000 - GO TO XIT; 05751000 - END ELSE GO TO RATA; 05752000 -ACTION: SCAN; 05753000 - IF NEXT = EQUAL THEN SCAN ELSE GO TO RATA; 05754000 - IF NEXT ! NUM THEN GO TO RATA; 05755000 - IF XREF THEN ENTERX(NAME,0&LABELID[TOCLASS]); 05756000 - IF BACK THEN NX1 ~ NAME ELSE NX2 ~ NAME; 05757000 - SCAN; IF NEXT = RPAREN THEN GO TO XIT; 05758000 - IF NEXT = COMMA THEN SCAN ELSE GO TO RATA; 05759000 - IF BACK THEN 05760000 - BEGIN BACK ~ NOT ( GOTEOF ~ TRUE); 05761000 - GO TO ERR; 05762000 - END; 05763000 - GOTERR ~ TRUE; 05764000 - GO TO EOF; 05765000 -RATA: XTA ~ NAME; FLOG(0); 05766000 -XIT: 05767000 -END ACTIONLABELS; 05768000 -IF DEBUGTOG THEN FLAGROUTINE(" IOCOM","MAND ",TRUE ); 05769000 -EODS~N!7 ; 05770000 -C2 ~ IF N = 0 OR N = 7 THEN 1 ELSE 0; 05771000 -SCAN; IF NEXT = SEMI THEN BEGIN FLOG(0); GO TO XIT END; 05772000 -IF N = 7 THEN 05773000 -BEGIN DATATOG ~ TRUE; 05774000 - IF LOGIFTOG THEN FLAG(101); 05775000 - LABL ~ BLANKS; 05776000 - IF SPLINK } 0 THEN %NOT BLOCK DATA STMT 05777000 - BEGIN 05778000 - IF DATAPRT=0 THEN BEGIN 05779000 - DATAPRT~PRTS~PRTS+1; ADJUST; 05780000 - DATASTRT~(ADR+1)&NSEG[TOSEGNO] END 05781000 - ELSE FIXB(DATALINK); 05782000 - EMITOPDCLIT(DATAPRT); EMITO(LNG); 05783000 - EMITB(-1, TRUE); DATAB ~ LAX; 05784000 - END; 05785000 - GO TO DAAT; 05786000 -END; 05787000 - EXECUTABLE; 05788000 -EMITO(MKS); 05789000 -IF N = 4 THEN 05790000 -BEGIN 05791000 - INLINEFILE; 05792000 - BEGIN EMITL(0); EMITL(0); EMITL(0); EMITL(0); 05793000 - EMITL(5); EMITL(0); EMITL(0); 05794000 - EMITV(NEED(".FBINB",INTRFUNID)); 05795000 - END; 05796000 - GO TO XIT; 05797000 -END; 05798000 -EDITCODE ~ NX1 ~ NX1 ~ 0; 05799000 -IF RDTRIN ~ 05800000 - N = 0 THEN IF NEXT = LPAREN THEN GO TO SUCH 05801000 - ELSE EMITDESCLIT(FILECHECK(".5 ",2+17|REAL %503-05802000 - (REMOTETOG))) 05803000 -ELSE IF N = 1 THEN IF NEXT ! LPAREN THEN FLAG(33) 05804000 - ELSE GO TO SUCH 05805000 - ELSE IF N = 2 THEN %503-05806000 - EMITDESCLIT(FILECHECK(".6 ",2+17|REAL %503-05807000 - (REMOTETOG))) 05808000 - ELSE EMITDESCLIT(FILECHECK(".PUNCH",0)); 05809000 -IF RDTRIN THEN EMITL(0) ELSE EMITPAIR(1,SSN); 05810000 -GO TO FORMER; 05811000 -SUCH: SCAN; RANDOMTOG~SUCHTOG~TRUE; INLINEFILE ; 05812000 - RANDOMTOG~FREEREAD~FALSE ; 05813000 - IF NEXT = EQUAL THEN % RANDOM KEY 05814000 - BEGIN SCAN; 05815000 - IF EXPR(TRUE) > REALTYPE THEN FLAG(102); 05816000 - IF RDTRIN THEN EMITPAIR(1,ADD); 05817000 - END ELSE IF RDTRIN THEN EMITL(0) ELSE EMITPAIR(1,SSN); 05818000 - IF NEXT = RPAREN THEN GO TO NF; 05819000 - IF NEXT ! COMMA THEN BEGIN FLOG(114); GO TO XIT END; 05820000 - SCAN; 05821000 - IF NEXT = ID THEN 05822000 - IF NAME = "ERR " OR NAME = "END " THEN 05823000 - BEGIN ACTIONLABELS(FALSE); 05824000 - NF: IF RDTRIN THEN EMITL(0) ELSE EMITPAIR(1,SSN); 05825000 - EMITL(0); 05826000 - NOFORMT ~ TRUE; 05827000 - SCAN; GO TO NOFORM; 05828000 - END; 05829000 -FORMER: IF ADR } 4085 THEN 05830000 - BEGIN ADR ~ ADR+1; SEGOVF END; 05831000 - IF NEXT = NUM THEN % FORMAT NUMBER 05832000 - BEGIN EDITCODE ~ 1; 05833000 - IF TEST ~ LBLSHFT(NAME) { 0 THEN 05834000 - BEGIN FLAG(135); GO TO LISTER END; 05835000 - IF I ~ SEARCH(TEST) = 0 THEN % NEVER SEEN 05836000 - OFLOWHANGERS(I~ENTER(0&FORMATID[TOCLASS], TEST)) ELSE 05837000 - IF GET(I).CLASS ! FORMATID THEN 05838000 - BEGIN FLAG(143); GO TO LISTER END; 05839000 - IF XREF THEN ENTERX(TEST,0&FORMATID[TOCLASS]); 05840000 - IF GET(I).ADDR = 0 THEN 05841000 - BEGIN EMITLINK((INFC ~ GET(I + 2)).BASE); 05842000 - PUT(I + 2,INFC&ADR[TOBASE]); 05843000 - EMITL(0); EMITL(0); EMITO(NOP); 05844000 - END ELSE 05845000 - BEGIN EMITL(GET(I+ 2).BASE); 05846000 - EMITPAIR(GET(I).ADDR,LOD); 05847000 - END; 05848000 - GO TO LISTER; 05849000 -END ELSE IF RDTRIN THEN IF(FREEREAD := NEXT=SLASH) THEN GO TO LISTER 05850000 -ELSE BEGIN IF NEXT NEQ ID THEN BEGIN FLOG(116);GO TO XIT; END;END 05851000 - ELSE IF NEXT NEQ ID THEN 05852000 - BEGIN IF NEXT = STAR THEN 05853000 - BEGIN NAMEDESC := TRUE; GLOBALNAME := TRUE; 05854000 - TV := ENTER(0&LISTSID[TOCLASS],LISTID:=LISTID+1); 05855000 - SCAN; 05856000 - END; 05857000 - IF NEXT = LPAREN THEN 05858000 - BEGIN SCAN; IF EXPR(TRUE) GTR REALTYPE THEN FLAG(120) ; 05859000 - SCAN; END ELSE EMITL(0); 05860000 - IF GLOBALNAME AND (FREEREAD := NEXT = SLASH) OR FREEREAD THEN 05861000 - GO TO LISTER ELSE BEGIN FLOG(110); GO TO XIT; END; 05862000 - END; 05863000 - GETALL(I ~ FNEXT,INFA,INFB,INFC); 05864000 - IF T ~ INFA.CLASS = ARRAYID THEN % FORMAT ARRAY 05865000 - BEGIN EDITCODE ~ 1; 05866000 - FORMARY ~ TRUE; 05867000 - T ~ EXPR(FALSE); 05868000 - ADR ~ ADR-1; % ELIMINATE XCH EMITTED BY EXPR 05869000 - IF EXPRESULT ! ARRAYID THEN FLOG(116); 05870000 - GO TO LISTER1; % SCAN ALREADY DONE IN EXPR 05871000 - END ELSE 05872000 - IF T = NAMELIST THEN 05873000 - BEGIN NAMETOG := TRUE; 05874000 - IF INFA.ADDR = 0 THEN % REFERENCED, NOT DEF 05875000 - BEGIN EMITLINK(INFC.BASE); 05876000 - PUT(I+ 2,(INFC ~ INFC&ADR[TOBASE])); 05877000 - EMITL(0); EMITL(0); EMITO(NOP); 05878000 - END ELSE 05879000 - BEGIN EMITL(INFC.BASE); 05880000 - EMITPAIR(INFA.ADDR,LOD); 05881000 - END 05882000 - END 05883000 - ELSE IF T = UNKNOWN THEN % ASSUME NAMELIST 05884000 - BEGIN PUT(I,(INFA ~ INFA&NAMELIST[TOCLASS])); 05885000 - NAMETOG := TRUE; 05886000 - OFLOWHANGERS(I); 05887000 - EMITLINK(0); PUT(I + 2,INFC&ADR[TOBASE]); 05888000 - EMITL(0); EMITL(0); EMITO(NOP); 05889000 - END ELSE BEGIN XTA ~ INFB; FLOG(116); GO TO XIT END; 05890000 - SCAN; 05891000 - IF NEXT = COMMA THEN ACTIONLABELS(TRUE); 05892000 - IF SUCHTOG THEN 05893000 - IF NEXT ! RPAREN THEN FLOG(108) ELSE SCAN; 05894000 - IF NEXT ! SEMI THEN BEGIN FLOG(118); GO TO XIT END; 05895000 - EMITL(0); EDITCODE ~ 4; EMITOPDCLIT(7); EMITO(FTC); 05896000 - GO TO WRAP; 05897000 -LISTER: SCAN; 05898000 - IF FREEREAD THEN IF NOT RDTRIN THEN 05899000 - BEGIN IF NEXT ! SLASH THEN EMITO(SSN) ELSE SCAN; 05900000 - IF NEXT = LPAREN THEN 05901000 - BEGIN SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(120);SCAN 05902000 - END ELSE EMITL(0); 05903000 - END; 05904000 -LISTER1: 05905000 - IF SUCHTOG THEN 05906000 - BEGIN IF NEXT = COMMA THEN ACTIONLABELS(TRUE); 05907000 - IF NEXT = RPAREN THEN SCAN ELSE BEGIN FLOG(108); GO TO XIT END; 05908000 - END ELSE IF NEXT=COMMA THEN SCAN ELSE IF RDTRIN THEN 05909000 - IF NEXT!SEMI THEN FLOG(114); 05910000 -NOFORM: IF NEXT=SEMI THEN 05911000 - BEGIN IF FREEREAD THEN FLOG(061) ELSE EMITL(0); GO TO WRAP END; 05912000 - IF (NEXT NEQ LPAREN) AND (NEXT NEQ ID) AND (NEXT NEQ STAR) THEN 05913000 - GO TO XIT; 05914000 - EDITCODE ~ EDITCODE + 2; 05915000 -DAAT: EMITB(-1,FALSE); LADR1 ~ LAX; ADJUST; DESCREQ ~ TRUE; 05916000 - IF ADR } 4085 THEN 05917000 - BEGIN ADR ~ ADR+1; SEGOVF; ADJUST END; 05918000 - ACCIDENT ~ PRGDESCBLDR(0,0,ADR.[36:10] + 1,NSEG); 05919000 - EMITOPDCLIT(19); EMITO(GFW); 05920000 - LISTART ~ ADR&NSEG[TOSEGNO]; ADJUST; 05921000 - LA ~ 0; IOLIST(LA); 05922000 - EMITL(1); EMITO(CHS); EMITL(19); EMITO(STD); 05923000 - EMITDESCLIT(19); EMITO(RTS); 5924000 - FIXB(LADR1); DESCREQ ~ FALSE; 05925000 - IF DATATOG THEN 05926000 - BEGIN DATASET; 05927000 - IF NEXT = SLASH THEN SCAN ELSE 05928000 - BEGIN FLOG(110); GO TO XIT END; 05929000 - IF LSTA = 0 THEN BEGIN BUMPPRT; LSTA~PRTS END; 05930000 - IF (LSTMAX - LSTI) { LSTS THEN 05931000 - BEGIN WRITEDATA(LSTI,NXAVIL ~ NXAVIL + 1,LSTP); 05932000 - LSTA ~ PRGDESCBLDR(1,LSTA,0,NXAVIL); 05933000 - LSTI ~ 0; BUMPPRT; LSTA~PRTS; 05934000 - END; 05935000 - MOVEW(LSTT,LSTP[LSTI],(LSTS ~ LSTS + 1).[36:6],LSTS); 05936000 - EMITO(MKS); EMITL(LSTI); EMITPAIR(LSTA,LOD); 05937000 - LSTI ~ LSTI + LSTS; 05938000 - EMITPAIR(ACCIDENT,LOD); EMITOPDCLIT(7); EMITO(FTF); 05939000 - EMITL(6); EMITL(0); EMITL(0); 05940000 - EMITV(NEED(".FBINB",INTRFUNID)); 05941000 - IF NEXT = COMMA THEN 05942000 - BEGIN SCAN; GO TO DAAT END; 05943000 - IF SPLINK } 0 THEN BEGIN 05944000 - EMITB(-1,FALSE); DATALINK~LAX; 05945000 - FIXB(DATAB) END; 05946000 - GO TO XIT; 05947000 - END; 05948000 - EMITPAIR(ACCIDENT,LOD); EMITOPDCLIT(7); EMITO(FTF); 05949000 -WRAP: IF NOT FREEREAD AND NOT NAMETOG THEN EMITL(EDITCODE); 05950000 -IF RDTRIN THEN 05951000 -BEGIN IF NX1 = 0 THEN EMITL(0) ELSE EMITLABELDESC(NX1); 05952000 - IF NX2 = 0 THEN EMITL(0) ELSE EMITLABELDESC(NX2); 05953000 - IF FREEREAD THEN EMITV(NEED(".FREFR", INTRFUNID)) 05954000 - ELSE IF NAMETOG THEN EMITV(NEED(".FINAM",INTRFUNID)) 05955000 - ELSE IF FORMARY THEN EMITV(NEED(".FTINT",INTRFUNID)) 05956000 - ELSE IF NOFORMT THEN EMITV(NEED(".FBINB",INTRFUNID)) 05957000 - ELSE EMITV(NEED(".FTNIN",INTRFUNID)); 05958000 -END ELSE 05959000 -IF FREEREAD THEN 05960000 - BEGIN 05961000 - IF NAMEDESC THEN 05962000 - BEGIN 05963000 - PRTSAVER(TV,NAMEIND+1,NAMLIST); 05964000 - EMITL(GET(TV+2).BASE); 05965000 - EMITPAIR(GET(TV).ADDR,LOD); 05966000 - IF NAMLIST[0] = 0 THEN EMITL(0) 05967000 - ELSE EMITPAIR(GET(GLOBALSEARCH(".SUBAR")).ADDR,LOD); 05968000 - NAMLIST[0] := NAMEIND := 0; 05969000 - END ELSE BEGIN EMITL(0);EMITL(0);EMITL(0);END; 05970000 - EMITV(NEED(".FREWR",INTRFUNID)) 05971000 - END ELSE IF NAMETOG THEN EMITV(NEED(".FONAM",INTRFUNID)) 05972000 - ELSE IF FORMARY THEN EMITV(NEED(".FTOUT",INTRFUNID)) 05973000 - ELSE BEGIN 05974000 - IF NX1=0 THEN EMITL(0) ELSE EMITLABELDESC(NX1); 05975000 - IF NX2=0 THEN EMITL(0) ELSE EMITLABELDESC(NX2); 05976000 - IF NOFORMT THEN EMITV(NEED(".FBINB",INTRFUNID)) ELSE 05977000 - EMITV(NEED(".FTNOU",INTRFUNID)); 05978000 - END; 05979000 -XIT: 05980000 - IF NAMEDESC THEN IF RDTRIN THEN FLAG(159) 05981000 - ELSE IF NOT FREEREAD THEN FLAG(160); 05982000 - DATATOG := FALSE; NAMEDESC := FALSE; GLOBALNAME := FALSE; 05983000 -IF DEBUGTOG THEN FLAGROUTINE(" IOCOM","MAND ",FALSE); 05984000 -END IOCOMMAND; 05985000 -PROCEDURE STMTFUN(LINK); VALUE LINK; REAL LINK; 05986000 -BEGIN 05987000 - DEFINE PARAM = LSTT#; 05988000 - REAL SAVEBRAD, I; 05989000 - REAL INFA, INFC, NPARMS, TYPE, PARMLINK, BEGINSUB, RETURN; 05990000 - LABEL XIT,TIX ; 05991000 - IF SPLINK < 0 THEN FLAG(12); 05992000 - LABL ~ BLANKS; 05993000 - FILETOG ~ TRUE; % PREVENTS SCANNER FROM ENTERING IDS IN INFO 05994000 - IF XREF THEN ENTERX(GET(LINK+1),0&STMTFUNID[TOCLASS] 05995000 - &(GET(LINK))[21:21:3]); 05996000 - DO 05997000 - BEGIN 05998000 - SCAN; 05999000 - IF NEXT ! ID THEN BEGIN FLOG(107); GO TO XIT END; 06000000 - PARAM[NPARMS~NPARMS+1] ~ NAME; 06001000 - SCAN; 06002000 - END UNTIL NEXT ! COMMA; 06003000 - IF NEXT ! RPAREN THEN FLOG(108) ELSE SCAN; 06004000 - IF NEXT ! EQUAL THEN BEGIN FLOG(104); GO TO XIT END; 06005000 - EMITB(-1,FALSE); SAVEBRAD ~ LAX; % BRANCH AROUND ST FUN 06006000 - ADJUST; 06007000 - BEGINSUB ~ ADR+1; 06008000 - BUMPLOCALS; EMITPAIR(RETURN~LOCALS+1536,STD); 06009000 - FOR I ~ NPARMS STEP -1 UNTIL 1 DO 06010000 - BEGIN 06011000 - IF T ~ SEARCH(PARAM[I]) ! 0 THEN 06012000 - TYPE ~ GET(T).SUBCLASS ELSE 06013000 - IF T~PARAM[I].[12:6] < "I" OR T > "N" THEN 06014000 - TYPE ~ REALTYPE ELSE TYPE ~ INTYPE; 06015000 - EMITSTORE( ENTER(0&VARID[TOCLASS]&1[TOTYPE] 06016000 - &TYPE[TOSUBCL], PARAM[I]), TYPE); 06017000 - IF XREF THEN ENTERX(NAME,0&VARID[TOCLASS]&TYPE[TOSUBCL]); 06018000 - END; 06019000 - PARMLINK ~ NEXTINFO-3; 06020000 - GETALL(LINK, INFA, XTA, INFC); 06021000 - FILETOG ~ FALSE; 06022000 - SCAN; 06023000 - IF (TYPE~(INFA~GET(LINK)).SUBCLASS)=LOGTYPE OR TYPE=COMPTYPE OR06024000 - (I~EXPR(TRUE))=LOGTYPE OR I=COMPTYPE THEN 06025000 - BEGIN IF I!TYPE THEN FLAG(139); GO TIX END ; 06026000 - IF TYPE=REALTYPE OR TYPE=INTYPE THEN 06027000 - BEGIN 06028000 - IF I=DOUBTYPE THEN BEGIN EMITO(XCH); EMITO(DEL) END; 06029000 - IF TYPE=INTYPE THEN IF I!INTYPE THEN EMITPAIR(1,IDV) ; 06030000 - GO TIX ; 06031000 - END ; 06032000 - IF I!DOUBTYPE THEN EMITPAIR(0,XCH) ; 06033000 -TIX: 06034000 - EMITOPDCLIT(RETURN) ; 06035000 - EMITO(GFW); 06036000 - FIXB(SAVEBRAD); 06037000 - IF INFA.CLASS ! UNKNOWN THEN FLAG(140); 06038000 - PUT(LINK, -INFA & 1[TOTYPE] & NSEG[TOSEGNO] 06039000 - & STMTFUNID[TOCLASS] & BEGINSUB[TOADDR]); 06040000 - PUT(LINK+2, -(0 & NPARMS[TONEXTRA] & ADR[TOBASE] 06041000 - & PARMLINK[36:36:12])); 06042000 - PARMLINK ~ PARMLINK+4; 06043000 - FOR I ~ 1 STEP 1 UNTIL NPARMS DO 06044000 - PUT(PARMLINK ~ PARMLINK-3, "......"); 06045000 - XIT: 06046000 - FILETOG ~ FALSE; 06047000 -END STMTFUN; 06048000 -PROCEDURE ASSIGNMENT; 06049000 -BEGIN 06050000 - LABEL XIT; 06051000 -BOOLEAN CHCK; 06052000 -BOOLEAN I; 06053000 -IF DEBUGTOG THEN FLAGROUTINE(" ASSIG","NMENT ",TRUE ) ; 06054000 - FX1 ~ FNEXT; 06055000 - SCAN; 06056000 - IF NEXT = LPAREN THEN 06057000 - BEGIN 06058000 -CHCK~TRUE; 06059000 - IF GET(FX1).CLASS = UNKNOWN THEN 06060000 - IF EODS THEN 06061000 - BEGIN XTA ~ GET(FX1+1); FLOG(035) ; 06062000 - PUT(FX1,GET(FX1) & ARRAYID[TOCLASS]) ; 06063000 - PUT(FX1+2,GET(FX1+2) & 1[TONEXTRA]) ; 06064000 - END 06065000 - ELSE BEGIN STMTFUN(FX1); GO TO XIT END ; 06066000 - IF XREF THEN ENTERX(GET(FX1+1),1&GET(FX1) [15:15:9]); 06067000 - EODS ~ TRUE ; 06068000 - EXECUTABLE; 06069000 - SCAN; 06070000 - I ~ SUBSCRIPTS(FX1,2); 06071000 - SCAN; 06072000 - END ELSE 06073000 - BEGIN 06074000 - EODS~TRUE ; 06075000 - EXECUTABLE; 06076000 - IF T ~ GET(FX1).CLASS = ARRAYID THEN 06077000 - BEGIN XTA ~ GET(FX1+1); FLAG(74) END; 06078000 - MOVEW(ACCUM[1],HOLDID[0],0,3); 06079000 - IF XREF THEN IF HOLDID[0].[12:12] ! "DO" THEN 06080000 - ENTERX(GET(FX1+1),1&GET(FX1)[21:21:3]&VARID[TOCLASS]); 06081000 - END; 06082000 - IF NEXT ! EQUAL THEN BEGIN FLAG(104); GO TO XIT END; 06083000 - SCAN; 06084000 - IF NEXT=SEMI OR NEXT=COMMA THEN BEGIN FLOG(0); GO TO XIT; END; 06085000 - FX2 ~ EXPR(TRUE); 06086000 - IF NEXT NEQ COMMA THEN IF HOLDID[0] = "DO" THEN IF XREF THEN 06087000 - ENTERX(HOLDID[0] ,1&GET(FX1)[21:21:3]&VARID[TOCLASS]); 06088000 - IF NEXT = COMMA THEN IF CHCK THEN FLOG(56) ELSE 06089000 - IF HOLDID[0].[12:12] ! "DO" THEN FLOG(56) ELSE 06090000 - BEGIN 06091000 - IF LOGIFTOG THEN FLAG(101); 06092000 - IF FX2 > REALTYPE THEN FLAG(102); 06093000 - IF DT ~ DT+1 > MAXDOS THEN BEGIN DT ~ 1; FLAG(138) END; 06094000 - EMITN(FX1~ CHECKDO); 06095000 - EMITO(STD); 06096000 - SCAN; 06097000 - IF NEXT=SEMI THEN BEGIN FLAG(36); GO TO XIT END; 06098000 - IF (ACCUM[0] = ", " OR ACCUM[0] = "; ") AND 06099000 - GLOBALNEXT=NUM AND ABS(FNEXT) > 1023 THEN 06100000 - BEGIN 06101000 - IF EXPR(TRUE) > REALTYPE THEN FLAG(102); 06102000 - IDINFO:=REALID;FNEXT:=ENTER(IDINFO,"2FNV00"&DT[36:36:12]);06103000 - EMITN(FNEXT:=GETSPACE(FNEXT)); EMITO(STD); 06104000 - EMITB(-1,FALSE); LADR1:=LAX; ADJUST; 06105000 - LADR2 ~ (ADR+1) & NSEG[TOSEGNO]; EMITV(FNEXT); 06106000 - END 06107000 - ELSE BEGIN 06108000 - EMITB(-1,FALSE); LADR1:=LAX; ADJUST; 06109000 - LADR2:=(ADR+1)&NSEG[TOSEGNO]; 06110000 - IF EXPR(TRUE) > REALTYPE THEN FLAG(102) ; 06111000 - END ; 06112000 - EMITO(GRTR); 06113000 - EMITB(-1, TRUE); 06114000 - LADR3 ~ LAX; 06115000 - EMITB(-1, FALSE); 06116000 - ADJUST; 06117000 - DOTEST[DT] ~ (ADR+1) & LAX[TOADDR] & NSEG[TOSEGNO]; 06118000 - IF NEXT ! COMMA THEN EMITL(1) ELSE 06119000 - BEGIN 06120000 - SCAN; 06121000 - IF NEXT=SEMI THEN BEGIN FLAG(36); GO TO XIT END ; 06122000 - IF EXPR(TRUE) > REALTYPE THEN FLAG(102); 06123000 - END; 06124000 - EMITV(FX1); 06125000 - EMITO(ADD); 06126000 - EMITN(FX1); 06127000 - EMITO(STN); 06128000 - EMITB(LADR2, FALSE); 06129000 - FIXB(LADR1); 06130000 - FIXB(LADR3); 06131000 - END ELSE EMITSTORE(FX1, FX2); 06132000 - XIT: 06133000 -IF DEBUGTOG THEN FLAGROUTINE(" ASSIG","NMENT ",FALSE ) ; 06134000 -END ASSIGNMENT; 06135000 -BOOLEAN PROCEDURE RINGCHECK; 06136000 -COMMENT THIS PROCEDURE PREVENTS THE POSSIBILITY OF DELINKING A 06137000 - HEADER FROM THE HEADER RING; 06138000 - BEGIN 06139000 - INTEGER I; 06140000 - I~A; 06141000 - DO 06142000 - IF I ~ GETC(I).ADDR = ROOT THEN RINGCHECK ~ TRUE 06143000 - UNTIL I = A; 06144000 - END RINGCHECK; 06145000 -PROCEDURE SETLINK(INFADDR); VALUE INFADDR; INTEGER INFADDR; 06146000 -COMMENT THIS PROCEDURE LINKS AN ELEMENT TO ITS PREVIOUS HEADER; 06147000 -BEGIN 06148000 - INTEGER LAST,I; REAL COML; LABEL XIT; 06149000 -XIT: 06150000 - LAST ~(GETC(INFADDR).LASTC)-1; 06151000 - FOR I ~ INFADDR+2 STEP 1 UNTIL LAST 06152000 - DO BEGIN IF GETC(I).CLASS = ENDCOM THEN I~GETC(I).LINK; 06153000 - IF FX1 = (COML~GETC(I)).LINK THEN 06154000 - IF INFADDR~COML.LASTC=A THEN COM[PWI].LASTC~ROOT 06155000 - ELSE GO XIT ; 06156000 - END; 06157000 -END SETLINK; 06158000 -PROCEDURE DIMENSION; 06159000 -BEGIN 06160000 - LABEL L, LOOP, ERROR ; 06161000 - BOOLEAN DOUBLED, SINGLETOG; %109-06162000 -IF DEBUGTOG THEN FLAGROUTINE(" DIMEN","SION ",TRUE ) ; 06163000 - IF LOGIFTOG THEN FLAG(101); 06164000 - LABL ~ BLANKS; 06165000 - IF NEXT=STAR THEN IF TYPE!DOUBTYPE THEN 06166000 - BEGIN 06167000 - SCAN ; 06168000 - IF NEXT=NUM AND NUMTYPE=INTYPE THEN 06169000 - BEGIN 06170000 - IF FNEXT=4 THEN 06171000 - BEGIN 06172000 - SINGLETOG ~ TRUE; %109-06173000 - IF TYPE=COMPTYPE THEN FLAG(176); GO L ; 06174000 - END ; 06175000 - IF FNEXT=8 THEN 06176000 - BEGIN 06177000 - IF TYPE=REALTYPE THEN TYPE~DOUBTYPE 06178000 - ELSE IF TYPE!COMPTYPE THEN FLAG(177) ; 06179000 - GO L ; 06180000 - END ; 06181000 - END ; 06182000 - FLAG(IF TYPE=REALTYPE THEN 178 06183000 - ELSE 177-REAL(TYPE=COMPTYPE)) ; 06184000 -L: NCR~REAL(NCR.[30:3]!0)+3"677777"+NCR; SCN~1; SCAN ; 06185000 - END ; 06186000 - LOOP: DOUBLED~FALSE; 06187000 - IF NEXT ! ID THEN BEGIN FLOG(105); GO TO ERROR END; 06188000 - FX1 ~ IF SINGLETOG THEN -FNEXT ELSE FNEXT; %109-06189000 - IF TYPE } DOUBTYPE THEN % FIX ARRAY TYPE OFR 06190000 - PUT(FX1,GET(FX1)&TYPE[TOSUBCL]); % BOUNDS ROUTINE 06191000 - IF XREF THEN BEGIN INFA ~ 0&GET(FX1)[15:15:9]; 06192000 - IF TYPE>0 THEN INFA.SUBCLASS~TYPE; 06193000 - END; 06194000 - XTA ~ INFB ~ NAME; 06195000 - SCAN; 06196000 - IF XREF THEN 06197000 - BEGIN IF INFA.CLASS = UNKNOWN THEN 06198000 - INFA.CLASS~IF NEXT=LPAREN THEN ARRAYID ELSE VARID; 06199000 - ENTERX(INFB,INFA); 06200000 - END; 06201000 - IF NEXT=LPAREN THEN BEGIN SCAN; DOUBLED~BOUNDS(FX1) END ELSE 06202000 - IF TYPE = -1 THEN FLOG(103); 06203000 - GETALL(FX1, INFA, XTA, INFC); 06204000 - IF TYPE > 0 THEN 06205000 - IF BOOLEAN(INFA.TYPEFIXED) THEN FLAG(31) ELSE 06206000 - BEGIN 06207000 - IF TYPE > LOGTYPE THEN 06208000 - IF GET(FX1+2) <0 THEN 06209000 - BEGIN 06210000 - IF NOT DOUBLED AND INFA.CLASS=1 THEN 06211000 - BEGIN 06212000 - BUMPLOCALS; 06213000 - LENGTH~LOCALS + 1536; 06214000 - PUT(FX1+2,INFC & LENGTH[TOSIZE]); 06215000 - END 06216000 - END ELSE IF NOT DOUBLED THEN 06217000 - BEGIN IF INFC.SIZE > 16383 THEN FLAG(99); 06218000 - PUT(FX1+2,INFC & (2 | INFC.SIZE)[TOSIZE]); 06219000 - END; 06220000 - PUT (FX1,INFA & 1[TOTYPE] & TYPE[TOSUBCL]); 06221000 - END; 06222000 - IF INFA < 0 THEN FLAG(39) ELSE 06223000 - IF TYPE = -2 THEN 06224000 - BEGIN 06225000 - BAPC(INFA&FX1[TOLINK]&1[TOCE]&ROOT[TOLASTC]); 06226000 - IF BOOLEAN(INFA.CE) THEN FLAG(2); 06227000 - IF BOOLEAN(INFA.EQ) THEN 06228000 - BEGIN 06229000 - COM[NEXTCOM.IR,NEXTCOM.IC].LASTC ~ A ~ INFA.ADDR; 06230000 - B~GETC(ROOT).ADDR ; 06231000 - SETLINK(A); 06232000 - IF NOT RINGCHECK THEN 06233000 - BEGIN 06234000 - COM[PWROOT].ADDR~GETC(A).ADDR ; 06235000 - PUTC(A,GETC(A)&B[TOADDR]&7[TOSUBCL]) ; 06236000 - END 06237000 - END ELSE 06238000 - PUT(FX1, INFA & 1[TOCE] & ROOT[TOADDR]); 06239000 - IF BOOLEAN(INFA.FORMAL) THEN FLAG(10); 06240000 - END; 06241000 - IF ERRORTOG THEN 06242000 - ERROR: 06243000 - WHILE NEXT ! COMMA AND NEXT ! SEMI AND NEXT ! SLASH DO SCAN; 06244000 - IF NEXT = COMMA THEN BEGIN SCAN; GO TO LOOP END; 06245000 -IF DEBUGTOG THEN FLAGROUTINE(" DIMEN","SION ",FALSE ); 06246000 -END DIMENSION; 06247000 -PROCEDURE FORMALPP(PARMSREQ, CLASS); VALUE PARMSREQ, CLASS; 06248000 - BOOLEAN PARMSREQ; REAL CLASS; 06249000 -BEGIN 06250000 - LABEL LOOP, XIT; 06251000 -IF DEBUGTOG THEN FLAGROUTINE(" FORM","ALPP ",TRUE ) ; 06252000 - PARMS ~ 0; 06253000 - SCAN; 06254000 - IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; 06255000 - IF CLASS = FUNID THEN 06256000 - IF FUNVAR = 0 THEN 06257000 - BEGIN 06258000 - IF TYPE > 0 THEN 06259000 - IF FUNVAR ~ GLOBALSEARCH(NAME) ! 0 THEN 06260000 - IF BOOLEAN((T ~ GET(FUNVAR)).TYPEFIXED) AND TYPE ! T.SUBCLASS 06261000 - THEN FLAG(31); 06262000 - PUT(FUNVAR ~ FNEXT,GET(FNEXT) & VARID[TOCLASS]); 06263000 - END; 06264000 - FNEW ~ NEED(NNEW ~ NAME, CLASS); 06265000 - ENTERX(NAME,IF CLASS = FUNID THEN 06266000 - 1&GET(FNEW)[15:15:9] ELSE 1&GET(FNEW)[15:15:5]); 06267000 - SCAN; 06268000 - IF NEXT ! LPAREN THEN 06269000 - IF PARMSREQ THEN FLOG(106) ELSE ELSE 06270000 - BEGIN 06271000 - LOOP: 06272000 - SCAN; 06273000 - IF NEXT = ID THEN PARMLINK[PARMS ~ PARMS+1] ~ FNEXT ELSE 06274000 - IF NEXT=STAR AND CLASS!FUNID THEN PARMLINK[PARMS~PARMS+1]~0ELSE06275000 - FLOG(107); 06276000 - IF XREF THEN ENTERX(NAME,IF NEXT = STAR THEN 0 ELSE 06277000 - 0&GET(FNEXT)[15:15:9]); 06278000 - SCAN; 06279000 - IF NEXT = COMMA THEN GO TO LOOP; 06280000 - IF NEXT ! RPAREN THEN FLOG(108); 06281000 - SCAN; 06282000 - END; 06283000 - IF NOT ERRORTOG THEN DECLAREPARMS(FNEW); 06284000 - XIT: 06285000 -IF DEBUGTOG THEN FLAGROUTINE(" FORM","ALPP ",FALSE) ; 06286000 -END FORMALPP; 06287000 - 06288000 -PROCEDURE ENDS; FORWARD; 06289000 - 06290000 -PROCEDURE FUNCTION ; 06291000 -BEGIN 06292000 - REAL A,B,C,I; LABEL FOUND ; 06293000 - IF SPLINK NEQ 0 THEN BEGIN FLAG(5); ENDS; SEGMENTSTART; END; 06294000 - LABL ~ BLANKS; 06295000 - FORMALPP(TRUE, FUNID); 06296000 - GETALL(FNEW, INFA, INFB, INFC); 06297000 - B~NUMINTM1 ; 06298000 - WHILE A+1SUPERMAXCOM THEN 06377000 - BEGIN ROOT~0; FATAL(124) END 06378000 - ELSE ROOT~NEXTCOM ; 06379000 - PUTC(ROOT,0&HEADER[TOCLASS]&1[TOCE]&ROOT[TOADDR]) ; 06380000 - BAPC(Z); 06381000 - END ELSE 06382000 - BEGIN 06383000 - ROOT ~ T.ADINFO; 06384000 - COM[(T~GETC(ROOT).LASTC).IR,T.IC].LINK~NEXTCOM+1 ; 06385000 - IF COM[PWROOT]<0 THEN FLAG(2) ; 06386000 - END; 06387000 - DIMENSION; 06388000 - BAPC(0&ENDCOM[TOCLASS]) ; 06389000 - COM[PWROOT].LASTC~NEXTCOM ; 06390000 - PUT(T~GETC(ROOT+1)+2,GET(T)&ROOT[TOADINFO]) ; 06391000 - IF NEXT ! SEMI THEN GO TO LOOP; 06392000 -END COMMON; 06393000 -PROCEDURE ENDS; 06394000 -BEGIN 06395000 - IF SPLINK=0 THEN FLAG(184) ELSE %112-06396000 - BEGIN %112-06397000 - EODS~FALSE ; 06398000 - IF LOGIFTOG THEN FLAG(101); 06399000 - LABL ~ BLANKS; 06400000 - IF SPLINK < 0 THEN EMITO(XIT) ELSE EMITPAIR(0, KOM); 06401000 - SEGMENT((ADR+4) DIV 4, NSEG, TRUE, EDOC); 06402000 - END; %112-06403000 -END ENDS; 06404000 -PROCEDURE ENTRY; 06405000 -BEGIN 06406000 - REAL SP; 06407000 - IF SPLINK = 0 THEN FLAG(111) ELSE 06408000 - IF SPLINK = 1 THEN BEGIN ELX ~ 0; FLAG(4) END; 06409000 - LABL ~ BLANKS; 06410000 - ADJUST ; 06411000 - SP ~ GET(SPLINK); 06412000 - FORMALPP( (T~SP.CLASS) = FUNID, T); 06413000 - GETALL(FNEW, INFA, INFB, INFC); 06414000 - IF INFA.CLASS = FUNID THEN 06415000 - PUT(FNEW, INFA & 1[TOTYPE] & (SP.SUBCLASS)[TOSUBCL]); 06416000 - PUT(FNEW+2, INFC & (ADR+1)[TOBASE]); 06417000 -END ENTRY; 06418000 -PROCEDURE EQUIVALENCE; 06419000 -COMMENT THIS PROCEDURE MAKES THE COM ENTRY FOR EQUIV ITEMS AND SETS 06420000 - THE EQ BIT IN BOTH THE COM AND INFO TABLES AND LINKS 06421000 - THE HEADS OF CHAINS; 06422000 -BEGIN 06423000 - REAL P, Q, R, S; 06424000 - BOOLEAN FIRST,PCOMM; 06425000 - LABEL XIT; 06426000 - IF LOGIFTOG THEN FLAG(101); 06427000 - LABL ~ BLANKS; 06428000 - DO 06429000 - BEGIN 06430000 - FIRST ~ FALSE; 06431000 - SCAN; 06432000 - IF NEXT ! LPAREN THEN BEGIN FLOG(106); GO TO XIT END; 06433000 - IF NEXTCOM~NEXTCOM+1>SUPERMAXCOM THEN 06434000 - BEGIN ROOT~0; FATAL(124) END 06435000 - ELSE ROOT~NEXTCOM ; 06436000 - PUTC(ROOT,0&HEADER[TOCLASS]&ROOT[TOADDR]) ; 06437000 - BAPC(0); Q~0 ; 06438000 - DO 06439000 - BEGIN 06440000 - SCAN; 06441000 - IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; 06442000 - IF XREF THEN ENTERX(NAME,0&GET(FNEXT)[15:15:9]); 06443000 - FX1 ~ FNEXT; 06444000 - LENGTH ~ 0; 06445000 - SCAN; 06446000 - IF NEXT = LPAREN THEN 06447000 - BEGIN 06448000 - IF GET(FX1).CLASS ! ARRAYID THEN 06449000 - BEGIN XTA ~ GET(FX1+1); FLOG(112) END; 06450000 - R ~ 0; P ~ 1; 06451000 - S ~ GET(FX1+2).ADINFO; 06452000 - DO 06453000 - BEGIN 06454000 - SCAN; 06455000 - IF NEXT ! NUM OR NUMTYPE ! INTYPE THEN FLAG(113); 06456000 - LENGTH ~ LENGTH + P|(FNEXT-1); 06457000 - P ~ P|EXTRAINFO[(S+R).IR,(S+R).IC] ; 06458000 - R ~ R-1; 06459000 - SCAN; 06460000 - END UNTIL NEXT ! COMMA; 06461000 - IF NEXT ! RPAREN THEN BEGIN FLOG(108); GO TO XIT END; 06462000 - IF R!-1 THEN IF R~R+GET(FX1+2).NEXTRA!0 THEN 06463000 - BEGIN XTA~GET(FX1+1); FLAG(IF R>0 THEN 23 ELSE 24) END ; 06464000 - SCAN; 06465000 - END; 06466000 - IF (INFA~GET(FX1)) < 0 THEN 6467000 - BEGIN XTA ~ GET(FX1+1); FLAG(39) END ELSE 6468000 - BEGIN 6469000 - IF INFA.SUBCLASS > LOGTYPE THEN LENGTH ~ 2|LENGTH ; 06470000 - BAPC(INFA&FX1[TOLINK]&LENGTH[TORELADD]&1[TOEQ]&ROOT[TOLASTC]); 06471000 - IF(PCOMM~BOOLEAN(INFA.CE)) OR BOOLEAN(INFA.EQ) THEN 06472000 - BEGIN 06473000 - IF FIRST AND PCOMM THEN BEGIN XTA~GET(FX1+1); FLAG(2) END 06474000 - ELSE IF NOT FIRST THEN FIRST ~ PCOMM; 06475000 - PUT(FX1,INFA & 1[TOEQ]); 06476000 - COM[NEXTCOM.IR,NEXTCOM.IC].LASTC ~ A ~ INFA.ADDR; 06477000 - B~GETC(ROOT).ADDR ; 06478000 - SETLINK(A); 06479000 - IF NOT RINGCHECK THEN 06480000 - BEGIN 06481000 - COM[PWROOT].ADDR~GETC(A).ADDR ; 06482000 - PUTC(A,GETC(A)&B[TOADDR]&7[TOSUBCL]) ; 06483000 - END 06484000 - END ELSE 06485000 - PUT(FX1,INFA & 1[TOEQ] & ROOT[TOADDR]); 06486000 - IF LENGTH > Q THEN Q ~ LENGTH; 06487000 - IF BOOLEAN(INFA.FORMAL) THEN 06488000 - BEGIN XTA ~ GET(FX1+1); FLAG(11) END; 06489000 - END; 06490000 - END UNTIL NEXT ! COMMA; 06491000 - IF NEXT ! RPAREN THEN BEGIN FLOG(108); GO TO XIT END; 06492000 - SCAN; 06493000 - PUTC(ROOT+1,Q); 06494000 - BAPC(0&ENDCOM[TOCLASS]) ; 06495000 - COM[PWROOT].LASTC~NEXTCOM ; 06496000 - END UNTIL NEXT ! COMMA; 06497000 - XIT: 06498000 -END EQUIVALENCE; 06499000 -PROCEDURE EXTERNAL; 06500000 -BEGIN 06501000 - IF SPLINK < 0 THEN FLAG( 12); 06502000 - IF LOGIFTOG THEN FLAG(101); 06503000 - LABL ~ BLANKS; 06504000 - DO 06505000 - BEGIN 06506000 - SCAN; 06507000 - IF NEXT ! ID THEN FLOG(105) ELSE 06508000 - BEGIN T ~ NEED(NAME,EXTID); 06509000 - IF XREF THEN ENTERX(NAME,0&GET(T)[15:15:9]); 06510000 - SCAN; 06511000 - END; 06512000 - END UNTIL NEXT ! COMMA; 06513000 -END EXTERNAL; 06514000 -PROCEDURE CHAIN; 06515000 -BEGIN 06516000 - LABEL AGN, XIT; 06517000 - REAL T1; 06518000 - DEFINE FLG(FLG1) = BEGIN FLOG(FLG1); GO TO XIT END#; 06519000 - EXECUTABLE; 06520000 - SCAN; 06521000 - T1 ~ 2; 06522000 - IF FALSE THEN 06523000 - AGN: IF GLOBALNEXT ! COMMA THEN FLG(28); 06524000 - SCAN; 06525000 - IF EXPR(TRUE) > REALTYPE THEN FLG(102); 06526000 - IF (T1 ~ T1 - 1) ! 0 THEN GO TO AGN; 06527000 - IF GLOBALNEXT ! RPAREN THEN FLG(3); 06528000 - EMITPAIR(37,KOM); 06529000 - SCAN; 06530000 - IF GLOBALNEXT ! SEMI THEN FLOG(117); 06531000 - XIT: WHILE GLOBALNEXT ! SEMI DO SCAN; 06532000 -END CHAIN; 06533000 -PROCEDURE GOTOS; 06534000 -BEGIN LABEL XIT; 06535000 - REAL ASSIGNEDID; 06536000 - EODS~TRUE ; 06537000 - EXECUTABLE; 06538000 - SCAN; 06539000 - IF NEXT = NUM THEN 06540000 - BEGIN 06541000 - LABELBRANCH(NAME, FALSE); 06542000 - SCAN; 06543000 - GO TO XIT; 06544000 - END; 06545000 - IF NEXT = ID THEN 06546000 - BEGIN 06547000 - ASSIGNEDID ~ FNEXT; 06548000 - IF XREF THEN ENTERX(XTA,0&GET(FNEXT)[15:15:9]); 06549000 - SCAN; 06550000 - IF NEXT ! COMMA THEN FLOG(114); 06551000 - SCAN; 06552000 - IF NEXT ! LPAREN THEN FLOG(106); 06553000 - DO 06554000 - BEGIN 06555000 - SCAN; 06556000 - IF NEXT ! NUM THEN FLOG(109); 06557000 - EMITV(ASSIGNEDID); 06558000 - EMITNUM(FNEXT); 06559000 - EMITO(NEQL); 06560000 - LABELBRANCH(NAME, TRUE); 06561000 - SCAN; 06562000 - END UNTIL NEXT ! COMMA; 06563000 - IF NEXT ! RPAREN THEN FLOG(108); 06564000 - SCAN; 06565000 - EMITPAIR(1, SSN); % CAUSE INVALID INDEX TERMINATION 06566000 - EMITDESCLIT(10); 06567000 - GO TO XIT; 06568000 - END; 06569000 - IF NEXT ! LPAREN THEN FLOG(106); 06570000 - P ~ 0; 06571000 - DO 06572000 - BEGIN 06573000 - SCAN; 06574000 - IF NEXT ! NUM THEN BEGIN FLOG(109); GO TO XIT END; 06575000 - LSTT[P~P+1] ~ NAME; 06576000 - SCAN; 06577000 - END UNTIL NEXT ! COMMA; 06578000 - IF NEXT ! RPAREN THEN BEGIN FLOG(108); GO TO XIT END; 06579000 - SCAN; 06580000 - IF NEXT ! COMMA THEN BEGIN FLOG(114); GO TO XIT END; 06581000 - SCAN; 06582000 - IT ~ P+1; % DONT LET EXPR WIPE OUT LSTT 06583000 - IF EXPR(TRUE) > REALTYPE THEN FLOG(102); 06584000 - EMITPAIR(JUNK, ISN); 06585000 - EMITPAIR(1,LESS); 06586000 - EMITOPDCLIT(JUNK); 06587000 - EMITO(LOR); 06588000 - EMITOPDCLIT(JUNK); 06589000 - EMITL(3); 06590000 - EMITO(MUL); 06591000 - IF ADR+3|P > 4085 THEN BEGIN ADR~ADR+1; SEGOVF END; 06592000 - EMITO(BFC); 06593000 - EMITPAIR(1, SSN); 06594000 - EMITDESCLIT(10); 06595000 - FOR I ~ 1 STEP 1 UNTIL P DO 06596000 - BEGIN 06597000 - J ~ ADR; LABELBRANCH(LSTT[I], FALSE); 06598000 - IF ADR-J = 2 THEN EMITO(NOP); 06599000 - END; 06600000 - XIT: 06601000 - IT ~ 0; 06602000 -END GOTOS; 06603000 -PROCEDURE IFS; 06604000 -BEGIN REAL TYPE, LOGIFADR, SAVELABL; 06605000 - EODS~TRUE; 06606000 - EXECUTABLE; 06607000 - SCAN; 06608000 - IF NEXT ! LPAREN THEN FLOG(106); 06609000 - SCAN; 06610000 - IF TYPE ~ EXPR(TRUE) = COMPTYPE THEN FLAG(89); 06611000 - IF NEXT ! RPAREN THEN FLOG(108); 06612000 - IF TYPE = LOGTYPE THEN 06613000 - BEGIN 06614000 - EMITB(-1, TRUE); 06615000 - LOGIFADR ~ LAX; 06616000 - LOGIFTOG ~ TRUE; EOSTOG ~ TRUE; 06617000 - SAVELABL ~ LABL; LABL ~ BLANKS; 06618000 - STATEMENT; 06619000 - LABL ~ SAVELABL; 06620000 - LOGIFTOG ~ FALSE; EOSTOG ~ FALSE; 06621000 - FIXB(LOGIFADR); 06622000 - END ELSE 06623000 - BEGIN 06624000 - IF TYPE = DOUBTYPE THEN 06625000 - BEGIN EMITO(XCH); EMITO(DEL) END; 06626000 - SCAN; 06627000 - IF NEXT ! NUM THEN FLOG(109); 06628000 - FX1 ~ FNEXT; NX1 ~ NAME; 06629000 - SCAN; 06630000 - IF NEXT ! COMMA THEN FLOG(114); 06631000 - SCAN; 06632000 - IF NEXT ! NUM THEN FLOG(109); 06633000 - FX2 ~ FNEXT; NX2 ~ NAME; 06634000 - SCAN; 06635000 - IF NEXT ! COMMA THEN FLOG(114); 06636000 - SCAN; 06637000 - IF NEXT ! NUM THEN FLOG(109); 06638000 - FX3 ~ FNEXT; NX3 ~ NAME; 06639000 - SCAN; 06640000 - IF FX2 = FX3 THEN 06641000 - BEGIN 06642000 - EMITPAIR(0,GEQL); 06643000 - LABELBRANCH(NX1, TRUE); 06644000 - LABELBRANCH(NX3, FALSE); 06645000 - IF XREF THEN ENTERX(NX2,0&LABELID[TOCLASS]); 06646000 - END ELSE 06647000 - IF FX1 = FX3 THEN 06648000 - BEGIN 06649000 - EMITPAIR(0,NEQL); 06650000 - LABELBRANCH(NX2, TRUE); 06651000 - LABELBRANCH(NX1, FALSE); 06652000 - IF XREF THEN ENTERX(NX3,0&LABELID[TOCLASS]); 06653000 - END ELSE 06654000 - IF FX1 = FX2 THEN 06655000 - BEGIN 06656000 - EMITPAIR(0,LEQL); 06657000 - LABELBRANCH(NX3, TRUE); 06658000 - LABELBRANCH(NX1, FALSE); 06659000 - IF XREF THEN ENTERX(NX2,0&LABELID[TOCLASS]); 06660000 - END ELSE 06661000 - BEGIN 06662000 - EMITO(DUP); 06663000 - EMITPAIR(0,NEQL); 06664000 - EMITB(-1,TRUE); 06665000 - EMITPAIR(0,LESS); 06666000 - LABELBRANCH(NX3, TRUE); 06667000 - LABELBRANCH(NX1, FALSE); 06668000 - FIXB(LAX); 06669000 - EMITO(DEL); 06670000 - LABELBRANCH(NX2, FALSE); 06671000 - END; 06672000 - END; 06673000 -END IFS; 06674000 -PROCEDURE NAMEL; 06675000 -BEGIN LABEL NIM,XIT,ELMNT,WRAP; 06676000 - IF SPLINK < 0 THEN FLAG(12); 06677000 - IF LOGIFTOG THEN FLAG(101); 06678000 - LABL ~ BLANKS; 06679000 - SCAN; IF NEXT ! SLASH THEN FLOG(110); 06680000 -NIM: SCAN; IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; 06681000 - IF J ~ (INFA ~ GET(LADR2 ~ FNEXT)).CLASS = UNKNOWN THEN 06682000 - PUT(LADR2,INFA&NAMELIST[TOCLASS]) 06683000 - ELSE IF J ! NAMELIST THEN 06684000 - BEGIN XTA ~ GET(LADR2 + 1); 06685000 - FLAG(20); 06686000 - END; 06687000 - LSTT[LSTS ~ LADR1 ~ 0] ~ NAME; 06688000 - IF XREF THEN ENTERX(NAME,0&NAMELIST[TOCLASS]); 06689000 - SCAN; IF NEXT ! SLASH THEN FLOG(110); 06690000 -ELMNT: SCAN; IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; 06691000 - LADR1 ~ LADR1 + 1; 06692000 - IF (T ~ GET(FNEW ~ GETSPACE(FNEXT)).CLASS) > VARID THEN FLAG(48); 06693000 - GETALL(FNEW,INFA,INFB,INFC); 06694000 - IF XREF THEN ENTERX(INFB,0&INFA[15:15:9]); 06695000 - IF LSTS ~ LSTS+1 = LSTMAX THEN BEGIN FLOG(78); GO TO XIT END ELSE 06696000 - LSTT[LSTS] ~ NAME&INFA.CLASNSUB[2:38:10]&0[8:47:1]; 06697000 - IF T = ARRAYID THEN 06698000 - BEGIN J ~ INFC.ADINFO; 06699000 - I ~ INFC.NEXTRA; 06700000 - IF LSTS + I + 1 > LSTMAX THEN 06701000 - BEGIN FLOG(78); GO TO XIT END; 06702000 - LSTT[LSTS ~ LSTS + 1] ~ 0&I[1:42:6] % # DIMENSIONS 06703000 - &INFA.ADDR[7:37:11] % REL ADR 06704000 - &INFC.BASE[18:33:15] % BASE 06705000 - &INFC.SIZE[33:33:15]; % SIZE 06706000 - FOR T ~ J STEP -1 UNTIL J - I + 1 DO 06707000 - LSTT[LSTS ~ LSTS + 1] ~ EXTRAINFO[T.IR,T.IC]; 06708000 - END ELSE BEGIN LSTT[LSTS~LSTS+1]~0&(INFA.ADDR)[7:37:11]; 06709000 - IF BOOLEAN(INFA.CE) THEN LSTT[LSTS]~LSTT[LSTS]&INFC.BASE[18:33:15]06710000 - &INFC.SIZE[33:33:15] END; 06711000 - SCAN; IF NEXT = COMMA THEN GO TO ELMNT; 06712000 - IF NEXT ! SEMI AND NEXT ! SLASH THEN FLOG(115); 06713000 - LSTT[LSTS + 1] ~ 0; 06714000 - LSTT[0].[2:10] ~ LADR1; 06715000 - PRTSAVER(LADR2,LSTS + 2,LSTT); 06716000 - IF NEXT ! SEMI THEN GO TO NIM; 06717000 -XIT: 06718000 -END NAMEL; 06719000 -PROCEDURE PAUSE; 06720000 -IF DCINPUT THEN BEGIN XTA~"PAUSE "; FLOG(151) END ELSE 06721000 -BEGIN 06722000 - EODS~TRUE ; 06723000 - IF TSSEDITOG THEN TSSED("PAUSE ",2) ; 06724000 - EXECUTABLE; 06725000 - SCAN; 06726000 - IF NEXT = SEMI THEN EMITL(0) ELSE 06727000 - IF NEXT = NUM THEN 06728000 - BEGIN 06729000 - EMITNUM(NAME); 06730000 - SCAN; 06731000 - END; 06732000 - EMITPAIR(33, KOM); 06733000 - EMITO(DEL); 06734000 -END PAUSE; 06735000 -PROCEDURE TYPIT(TYP,TMPNXT); VALUE TYP; REAL TYP,TMPNXT ; 06736000 - BEGIN 06737000 - TYPE~TYP; SCAN ; 06738000 - IF NEXT=16 THEN BEGIN TMPNXT~16; FUNCTION END ELSE DIMENSION ; 06739000 - END OF TYPIT ; 06740000 -DEFINE COMPLEX =TYPIT(COMPTYPE,TEMPNEXT) #, 06741000 - LOGICAL =TYPIT(LOGTYPE ,TEMPNEXT) #, 06742000 - DOUBLEPRECISION =TYPIT(DOUBTYPE,TEMPNEXT) #, 06743000 - INTEGERS =TYPIT(INTYPE ,TEMPNEXT) #, 06744000 - REALS =TYPIT(REALTYPE,TEMPNEXT) #; 06745000 -PROCEDURE STOP; 06746000 -BEGIN 06747000 - RETURNFOUND ~ TRUE; 06748000 - EODS~TRUE; 06749000 - EXECUTABLE; 06750000 - COMMENT INITIAL SCAN ALREADY DONE; 06751000 - EMITL(1); 06752000 - EMITPAIR(16,STD); 06753000 - EMITPAIR(10, KOM); 06754000 - EMITPAIR(5, KOM); 06755000 - WHILE NEXT ! SEMI DO SCAN; 06756000 -END STOP; 06757000 -PROCEDURE RETURN; 06758000 -BEGIN LABEL EXIT; 06759000 - REAL T, XITCODE; 06760000 - RETURNFOUND ~ TRUE; 06761000 - EODS~TRUE ; 06762000 - EXECUTABLE; 06763000 - SCAN; 06764000 - IF SPLINK=0 OR SPLINK=1 THEN 06765000 - BEGIN XTA~"RETURN"; FLOG(153); GO EXIT END ; 06766000 - IF NEXT = SEMI THEN 06767000 - BEGIN 06768000 - IF (T ~ GET(SPLINK)).CLASS = FUNID THEN 06769000 - BEGIN 06770000 - EMITV(FUNVAR); 06771000 - IF T.SUBCLASS > LOGTYPE THEN EMITPAIR(JUNK, STD); 06772000 - XITCODE ~ RTN; 06773000 - END ELSE XITCODE ~ XIT; 06774000 - IF ADR } 4077 THEN 06775000 - BEGIN ADR ~ ADR+1; SEGOVF END; 06776000 - EMITOPDCLIT(1538); % F+2 06777000 - EMITPAIR(3, BFC); 06778000 - EMITPAIR(10, KOM); 06779000 - EMITO(XITCODE); 06780000 - EMITOPDCLIT(16); 06781000 - EMITPAIR(1, SUB); 06782000 - EMITPAIR(16, STD); 06783000 - EMITO(XITCODE); 06784000 - GO TO EXIT; 06785000 - END; 06786000 - IF LABELMOM = 0 THEN FLOG(145); 06787000 - IF EXPR(TRUE) > REALTYPE THEN FLAG(102); 06788000 - IF EXPRESULT = NUMCLASS THEN 06789000 - BEGIN IF XREF THEN ENTERX(EXPVALUE,0&LABELID[TOCLASS]); 06790000 - ADR ~ ADR-1;EMITL(EXPVALUE-1) 06791000 - END ELSE 06792000 - EMITPAIR(1, SUB); 06793000 - EMITOPDCLIT(LABELMOM); 06794000 - EMITO(MKS); 06795000 - EMITL(9); 06796000 - EMITOPDCLIT(5); 06797000 - EXIT: 06798000 -END RETURN; 06799000 -PROCEDURE IMPLICIT ; 06800000 - BEGIN 06801000 - REAL R1,R2,R3,R4 ; 06802000 - LABEL R,A,X,L ; 06803000 - IF NOT(LASTNEXT=42 OR LASTNEXT=1000 OR LASTNEXT=30 %110-06804000 - OR LASTNEXT=16 OR LASTNEXT = 11) %110-06805000 - THEN BEGIN FLOG(181); FILETOG~TRUE; GO X END ; 06806000 -R: EOSTOG~ERRORTOG~TRUE; FILETOG~FALSE ; 06807000 - MOVEW(ACCUM[3],ACCUM[2],0,3); SCAN; ERRORTOG~FALSE; FILETOG~TRUE ; 06808000 - IF R1~IF R2~NEXT=18 THEN INTID ELSE IF R3=26 THEN REALID ELSE 0& 06809000 - (IF R3=10 THEN DOUBTYPE ELSE IF R3=19 THEN LOGTYPE ELSE IF R3=06810000 - 6 THEN COMPTYPE ELSE 0)[TOSUBCL]=0 THEN 06811000 - BEGIN FLOG(182); GO X END ; 06812000 - SCN~2; SCAN ; 06813000 - IF NEXT = STAR THEN IF R3!10 THEN 06814000 - BEGIN SCAN ; 06815000 - IF NEXT=NUM AND NUMTYPE=INTYPE THEN 06816000 - BEGIN 06817000 - IF FNEXT=4 THEN BEGIN IF R3=6 THEN FLAG(176); GO L END ; 06818000 - IF FNEXT=8 THEN 06819000 - BEGIN 06820000 - IF R3=26 THEN R1~0&DOUBTYPE[TOSUBCL] 06821000 - ELSE IF R3!6 THEN FLAG(177) ; 06822000 - GO L; 06823000 - END ; 06824000 - END ; 06825000 - FLAG(IF R3=26 THEN 178 ELSE 177-REAL(R3=6)) ; 06826000 -L: NCR~REAL(NCR.[30:3]!0)+3"677777"+NCR; SCN~1; SCAN ; 06827000 - END ; 06828000 - IF NEXT!LPAREN THEN BEGIN FLOG(106); GO X END ; 06829000 -A: SCAN; R4~ERRORCT ; 06830000 - IF R2~NAME.[12:6]<17 OR (R2>25 AND R2<33) OR (R2>41 AND R2<50) 06831000 - OR R2>57 OR NAME.[18:30]!" " THEN FLAG(179) ; 06832000 - SCAN ; 06833000 - IF NEXT!MINUS THEN 06834000 - BEGIN IF ERRORCT=R4 THEN TIPE[IF R2!"0" THEN R2 ELSE 12]~R1 END06835000 - ELSE BEGIN 06836000 - SCAN ; 06837000 - IF R3~NAME.[12:6]<17 OR (R3>25 AND R3<33) OR (R3>41 AND R3<50) 06838000 - OR R3>57 OR NAME.[18:30]!" " THEN FLAG(179) ; 06839000 - IF R3 LEQ R2 THEN FLAG(180) ; 06840000 - IF ERRORCT=R4 THEN FOR R2~R2 STEP 1 UNTIL R3 DO 06841000 - BEGIN 06842000 - IF R2>25 AND R2<33 THEN R2~33 ELSE IF R2>41 AND R2<50 06843000 - THEN R2~50 ; 06844000 - TIPE[IF R2!"0" THEN R2 ELSE 12]~R1 ; 06845000 - END ; 06846000 - SCAN ; 06847000 - END ; 06848000 - IF NEXT=COMMA THEN GO A ; 06849000 - IF NEXT!RPAREN THEN BEGIN FLOG(108); GO X END ; 06850000 - SCAN; IF NEXT=COMMA THEN GO R ; 06851000 - IF NEXT!SEMI THEN BEGIN FLOG(117); GO X END ; 06852000 - IF SPLINK > 1 THEN 06853000 - BEGIN 06854000 - IF BOOLEAN(TYPE.[2:1]) THEN IF GET(SPLINK).CLASS=FUNID THEN 06855000 - BEGIN 06856000 - INFO[SPLINK.IR,SPLINK.IC].SUBCLASS~R3~TIPE[IF R3~GET( 06857000 - SPLINK+1).[12:6]!"0" THEN R3 ELSE 12].SUBCLASS ; 06858000 - INFO[FUNVAR.IR,FUNVAR.IC].SUBCLASS~R3 ; 06859000 - END ; 06860000 - IF R1~GET(SPLINK+2)<0 THEN 06861000 - FOR R2~R1.NEXTRA-1+R1~R1.ADINFO STEP -1 UNTIL R1 DO 06862000 - IF R3~PARMLINK[R2-R1+1]!0 THEN 06863000 - BEGIN 06864000 - EXTRAINFO[R2.IR,R2.IC].SUBCLASS~R4~TIPE[IF R4~ 06865000 - GET(R3+1).[12:6]!"0" THEN R4 ELSE 12] 06866000 - .SUBCLASS ; 06867000 - INFO[R3.IR,R3.IC].SUBCLASS~R4 ; 06868000 - END ; 06869000 - END ; 06870000 -X: WHILE NEXT!SEMI DO SCAN; FILETOG~FALSE ; 06871000 - END OF IMPLICIT ; 06872000 - 06873000 -PROCEDURE SUBROUTINE; 06874000 -BEGIN 06875000 - IF SPLINK NEQ 0 THEN BEGIN FLAG(5); ENDS; SEGMENTSTART; END; 06876000 - LABL ~ BLANKS; 06877000 - FORMALPP(FALSE, SUBRID); 06878000 - SPLINK ~ FNEW; 06879000 -END SUBROUTINE; 06880000 -PROCEDURE MEMHANDLER(N); VALUE N; REAL N ; 06881000 - BEGIN 06882000 - REAL A ; 06883000 - LABEL L1,L2,L3,XIT ; 06884000 - IF DEBUGTOG THEN FLAGROUTINE(" MEMHA","NDLER ",TRUE) ; 06885000 - IF N LEQ 2 THEN 06886000 - BEGIN % FIXED=1, VARYING=2. 06887000 - N~IF N=1 THEN 6 ELSE 0 ; 06888000 -L1: SCAN; 06889000 - IF NEXT!ID THEN BEGIN FLOG(105); GO XIT END ; 06890000 - IF (A~GET(GETSPACE(FNEXT))).CLASS!ARRAYID THEN 06891000 - BEGIN FLOG(35); GO XIT END ; 06892000 - IF XREF THEN ENTERX(XTA,0&A[15:15:9]) ; 06893000 - IF BOOLEAN(A.EQ) OR BOOLEAN(A.FORMAL) THEN FLAG(169) 06894000 - ELSE BEGIN 06895000 - EMITO(MKS); EMITPAIR(A.ADDR,LOD); EMITL(N) ; 06896000 - EMITV(NEED(".MEMHR",INTRFUNID)) ; 06897000 - END ; 06898000 - SCAN; IF NEXT=COMMA THEN GO L1 ; 06899000 - END 06900000 - ELSE IF N=3 THEN 06901000 - BEGIN % AUXMEMED FUNCTION OR SUBROUTINE. 06902000 - SCAN ; 06903000 - IF NEXT!ID THEN BEGIN FLOG(105); GO XIT END ; 06904000 - IF GET(FNEXT+1)!GET(SPLINK+1) THEN 06905000 - BEGIN FLOG(170); GO XIT END ; 06906000 - PUT(SPLINK,GET(SPLINK)&1[TOADJ]) ; 06907000 - IF XREF THEN ENTERX(XTA,0&GET(FNEXT)[15:15:9]); SCAN ; 06908000 - END 06909000 - ELSE BEGIN % RELEASE. 06910000 -L2: SCAN ; 06911000 - IF NEXT!ID THEN BEGIN FLOG(105); GO XIT END ; 06912000 - IF (A~GET(GETSPACE(FNEXT))).CLASS=ARRAYID THEN 06913000 - BEGIN 06914000 - IF BOOLEAN(A.EQ) OR BOOLEAN(A.FORMAL) THEN FLAG(169) 06915000 - ELSE BEGIN 06916000 - EMITO(MKS); EMITPAIR(A.ADDR,LOD) ; 06917000 - EMITPAIR(1,SSN) ; 06918000 - EMITV(NEED(".MEMHR",INTRFUNID)) ; 06919000 - END ; 06920000 -L3: IF XREF THEN ENTERX(XTA,0&A[15:15:9]) ; 06921000 - END 06922000 - ELSE IF A.CLASS}BLOCKID OR A.CLASS{LABELID THEN 06923000 - BEGIN FLOG(171); GO XIT END 06924000 - ELSE BEGIN 06925000 - EMITPAIR(A.ADDR,LOD); EMITPAIR(38,KOM) ; 06926000 - EMITO(DEL); GO L3 ; 06927000 - END ; 06928000 - SCAN; IF NEXT=COMMA THEN GO L2 ; 06929000 - END ; 06930000 -XIT:IF DEBUGTOG THEN FLAGROUTINE(" MEMHA","NDLER ",FALSE) ; 06931000 - END OF MEMHANDLER ; 06932000 -PROCEDURE STATEMENT; 06933000 -BEGIN LABEL DOL1, XIT; 06934000 - REAL TEMPNEXT ; 06935000 - BOOLEAN ENDTOG; %112-06936000 - DO SCAN UNTIL NEXT ! SEMI; 06937000 - IF NEXT=ID THEN ASSIGNMENT ELSE IF NEXT LEQ RSH1 THEN 06938000 - CASE(TEMPNEXT~NEXT) OF 06939000 - BEGIN 06940000 - FLOG(16); 06941000 - ASSIGN; 06942000 - IOCOMMAND(4); %BACKSPACE 06943000 - BLOCKDATA; 06944000 - CALL; 06945000 - COMMON; 06946000 - COMPLEX; 06947000 - BEGIN EXECUTABLE; SCAN END; % CONTINUE 06948000 - IOCOMMAND(7); % DATA 06949000 - BEGIN SCAN; TYPE ~ -1; DIMENSION END; 06950000 - DOUBLEPRECISION; 06951000 - BEGIN ENDS; ENDTOG:=TRUE; SCAN END; %112-06952000 - FILECONTROL(1); %ENDFILE 06953000 - ENTRY; 06954000 - EQUIVALENCE; 06955000 - EXTERNAL; 06956000 - BEGIN TYPE ~ -1; FUNCTION END; 06957000 - GOTOS; 06958000 - INTEGERS; 06959000 - LOGICAL; 06960000 - NAMEL; 06961000 - PAUSE; 06962000 - IOCOMMAND(2); %PRINT 06963000 - ; 06964000 - IOCOMMAND(3); %PUNCH 06965000 - IOCOMMAND(0); %READ 06966000 - REALS; 06967000 - RETURN; 06968000 - FILECONTROL(0); %REWIND 06969000 - BEGIN SCAN; STOP END; 06970000 - SUBROUTINE; 06971000 - IOCOMMAND(1); %WRITE 06972000 - FILECONTROL(7); %CLOSE 06973000 - FILECONTROL(6); %LOCK 06974000 - FILECONTROL(4); %PURGE 06975000 - IFS; 06976000 - FORMATER; 06977000 - CHAIN; 06978000 - MEMHANDLER(1) ; %FIXED 06979000 - MEMHANDLER(2) ; %VARYING 06980000 - MEMHANDLER(3) ; %AUXMEM FOR SUBPROGRAMS 06981000 - MEMHANDLER(4) ; %RELEASE 06982000 - IMPLICIT ; 06983000 - END ELSE IF NEXT=EOF THEN GO XIT ELSE BEGIN NEXT~0; FLOG(16) END ; 06984000 - LASTNEXT.[33:15]~TEMPNEXT ; 06985000 - IF NOT ENDTOG THEN IF SPLINK=0 THEN SPLINK:=1; %112-06986000 - ENDTOG:=FALSE; %112-06987000 - IF LABL ! BLANKS THEN 06988000 - BEGIN 06989000 - IF DT ! 0 THEN 06990000 - BEGIN 06991000 - DOL1: IF LABL = DOLAB[TEST ~ DT] THEN 06992000 - BEGIN 06993000 - EMITB(DOTEST[DT], FALSE); 06994000 - FIXB(DOTEST[DT].ADDR); 06995000 - IF DT ~ DT-1 > 0 THEN GO TO DOL1; 06996000 - END ELSE 06997000 - WHILE TEST ~ TEST-1 > 0 DO 06998000 - IF DOLAB[TEST] = LABL THEN FLAG(14); 06999000 - END; 07000000 - LABL ~ BLANKS; 07001000 - END; 07002000 - IF NEXT ! SEMI THEN 07003000 - BEGIN 07004000 - FLAG(117); 07005000 - DO SCAN UNTIL NEXT=SEMI OR NEXT=EOF ; 07006000 - END; 07007000 - ERRORTOG ~ FALSE; 07008000 - EOSTOG ~ TRUE; 07009000 - XIT: 07010000 -END STATEMENT; 07011000 - 07012000 -BOOLEAN STREAM PROCEDURE FLAGLAST(BUFF,ERR) ; 07013000 - BEGIN 07014000 - LOCAL A; SI~ERR; 8(IF SC!" " THEN JUMP OUT;SI~SI+1;TALLY~TALLY+1);07015000 - A~TALLY; SI~LOC A; SI~SI+7 ; 07016000 - IF SC<"8" THEN 07017000 - BEGIN TALLY~1; FLAGLAST~TALLY ; 07018000 - DI~BUFF;DS~46 LIT"LAST SYNTAX ERROR OCCURRED AT SEQUENCE NUMBER ";07019000 - DS~LIT"""; SI~ERR; DS~8 CHR; DS~LIT"""; 07020000 - DS~32 LIT " "; %510-07021000 - DS~32 LIT " "; %510-07022000 - END 07023000 - END FLAGLAST ; 07024000 -INTEGER PROCEDURE FEELD(X); VALUE X; INTEGER X; 07025000 -FEELD~IF X<10 THEN 1 ELSE IF X<100 THEN 2 ELSE IF X<1000 THEN 3 ELSE IF 07026000 -X<10000 THEN 4 ELSE IF X<100000 THEN 5 ELSE IF X<1000000 THEN 6 ELSE 7; 07027000 -FORMAT EOC1(/ "NUMBER OF SYNTAX ERRORS DETECTED = ",I*,".",X*, 07028000 - "NUMBER OF SEQUENCE ERRORS DETECTED = ",I*,"."), 07029000 - EOC2("PRT SIZE = ",I*,"; TOTAL SEGMENT SIZE = ",I*, 07030000 - " WORDS; DISK SIZE = ",I*," SEGS; NO. PRGM. SEGS = ",I*, 07031000 - "."), 07032000 - EOC3("ESTIMATED CORE STORAGE REQUIREMENT = ",I*," WORDS;", 07033000 - " COMPILATION TIME = ",I*," MIN, ",I*," SECS;", 07034000 - " NO. CARDS = ",I*,"."), 07035000 - EOC4("ESTIMATED CORE STORAGE REQUIREMENT = ",I*," WORDS;" 07036000 - " COMPILATION TIME = ",I*," SECS; NO. CARDS = ",I*,"."), 07037000 - EOC5("NUMBER OF TSS WARNINGS DETECTED = ",I*,".") ; 07038000 -COMMENT MAIN DRIVER FOR FORTRAN COMPILER BEGINS HERE; 07039000 -RTI ~ TIME(1); 07040000 -INITIALIZATION; 07041000 - DO STATEMENT UNTIL NEXT = EOF; 07042000 - IF NOT ENDSEGTOG THEN IF SPLINK NEQ 0 %112-07043000 - THEN BEGIN XTA:=BLANKS; FLAG(5); ENDS END; %112-07044000 - WRAPUP; 07045000 -POSTWRAPUP: 07046000 -IF TIMETOG THEN IF FIRSTCALL THEN DATIME; 07047000 -IF NOT FIRSTCALL THEN 07048000 - BEGIN 07049000 - WRITE(RITE,EOC1,FEELD(ERRORCT),ERRORCT,IF SEQERRCT=0 THEN 99 ELSE 07050000 - 5,FEELD(SEQERRCT-1),SEQERRCT-1) ; 07051000 - IF WARNED AND NOT DCINPUT THEN WRITE(RITE,EOC5,FEELD(WARNCOUNT), 07052000 - WARNCOUNT) ; 07053000 - WRITE(RITE,EOC2,FEELD(PRTS),PRTS,FEELD(TSEGSZ),TSEGSZ,FEELD(DALOC-1),07054000 - DALOC-1,FEELD(NXAVIL),NXAVIL) ; 07055000 - IF C1~(TIME(1)-RTI)/60 > 59 THEN WRITE(RITE,EOC3,FEELD(64|ESTIMATE), 07056000 - 64|ESTIMATE,FEELD(C1 DIV 60),C1 DIV 60,FEELD(C1 MOD 60),C1 MOD 60, 07057000 - FEELD(CARDCOUNT-1),CARDCOUNT-1) ELSE WRITE(RITE,EOC4,FEELD(ESTIMATE 07058000 - |64),ESTIMATE|64,FEELD(C1),C1,FEELD(CARDCOUNT-1),CARDCOUNT-1) ; 07059000 - IF ERRORCT>0 THEN IF FLAGLAST(ERRORBUFF,LASTERR) THEN WRITE(RITE,15, 07060000 - ERRORBUFF[*]) ; 07061000 - END ; 07062000 -END INNER BLOCK; 07063000 -END. 07064000 - \ No newline at end of file + IF OPTYPE[IT] > REALTYPE THEN FLAG(85); 04196000 + SCAN; 04197000 + IF EXPR(TRUE) > REALTYPE 04198000 + OR EXPRESULT ! NUMCLASS THEN FLAG(85); 04198100 + EMITO(XCH); 04199000 + OPTYPE[IT] ~ COMPTYPE; 04200000 + IF EXPRESLT = 0 THEN EXPRESLT ~ NUMCLASS; 04201000 + END ELSE EXPRESLT ~ EXPCLASS; 04202000 + IF GLOBALNEXT ! RPAREN THEN 04203000 + BEGIN FLOG(108); GO TO XIT END; 04204000 + GO TO LOOP; 04205000 + END; 04206000 + WHILE PR[IP] } PREC DO 04207000 + BEGIN 04208000 + IF IT { SAVIT THEN GO TO XIT; 04208100 + CODE ~ MAP[T1~OPTYPE[IT-1]]|3 + MAP[T2~OPTYPE[IT]]; 04209000 + CASE OPST[IP] OF 04210000 + BEGIN 04211000 + GO TO XIT; 04212000 + BEGIN 04213000 + IF T1 = LOGTYPE AND T2 = LOGTYPE THEN EMITO(LOR) 04214000 + ELSE FLAG(51); 04215000 + IT ~ IT-1; 04216000 + END; 04217000 + BEGIN 04218000 + IF T1 = LOGTYPE AND T2 = LOGTYPE THEN EMITO(LND) 04219000 + ELSE FLAG(52); 04220000 + IT ~ IT-1; 04221000 + END; 04222000 + IF T2 = LOGTYPE THEN EMITO(LNG) ELSE FLAG(53); 04223000 + BEGIN T ~ LESS; GO TO RELATION END; 04224000 + BEGIN T ~ LEQL; GO TO RELATION END; 04225000 + BEGIN T ~ EQUL; GO TO RELATION END; 04226000 + BEGIN T ~ GRTR; GO TO RELATION END; 04227000 + BEGIN T ~ GEQL; GO TO RELATION END; 04228000 + BEGIN T ~ NEQL; 04229000 + RELATION: 04230000 + IF CODE < 0 THEN FLAG(54) ELSE 04231000 + CASE CODE OF 04232000 + BEGIN ; 04233000 + BEGIN 04234000 + E0(CHS); EP(9,STD); E0(XCH); EOL(9); E0(XCH); EP(0,XCH) ;04235000 + E0(AD2) ; 04236000 + END; 04238000 + FLAG(90); 04239000 + BEGIN EMITPAIR(0, XCH); EMITO(SB2) END; 04240000 + EMITO(SB2); 04241000 + FLAG(90); 04242000 + FLAG(90); 04243000 + FLAG(90); 04244000 + IF T! EQUL AND T! NEQL THEN FLAG(54) %103-04245000 + ELSE %103-04245100 + BEGIN %103-04245200 + EP(9,STD); E0(XCH); EOL(9); E0(T); %103-04245300 + EP(9,STD ); E0(T); EOL(9); %103-04245400 + T~(IF T=EQUL THEN LND ELSE LOR); CODE~0; %103-04245500 + END; %103-04245600 + END RELATION CASE STATEMENT; 04246000 + IF CODE > 0 THEN 04247000 + BEGIN EMITO(XCH); EMITO(DEL); EMITL(0) END; 04248000 + EMITO(T); 04249000 + OPTYPE[IT~IT-1] ~ LOGTYPE; 04250000 + END; 04251000 + IF CODE < 0 THEN BEGIN FLAG(53); IT ~ IT-1 END ELSE 04252000 + CASE CODE OF 04253000 + BEGIN 04254000 + BEGIN 04255000 + EMITO(ADD); 04256000 + IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE 04257000 + OPTYPE[IT~IT-1] ~ REALTYPE; 04258000 + END; 04259000 + BEGIN TM~AD2 ; 04260000 + RPLUSD: EP(9,STD); E0(XCH); EOL(9); E0(XCH); EP(0,XCH); E0(TM) ; 04260010 + DTYP: OPTYPE[IT~IT-1]~DOUBTYPE ; 04260020 + END ; 04260030 + BEGIN TM~ADD; GO RLESSC END ; 04261000 + BEGIN 04262000 + EMITPAIR(0, XCH); 04263000 + EMITO(AD2); 04264000 + IT ~ IT-1; 04265000 + END; 04266000 + BEGIN EMITO(AD2); IT ~ IT-1 END; 04267000 + BEGIN TM~ADD; GO DLESSC END ; 04268000 + BEGIN EMITO(ADD); IT ~ IT-1 END; 04269000 + BEGIN TM~ADD; GO CLESSD END ; 04270000 + BEGIN TM~ADD; GO CLESSC END ; 04271000 + END ADD CASE STATEMENT; 04272000 + IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE 04273000 + CASE CODE OF 04274000 + BEGIN 04275000 + BEGIN 04276000 + EMITO(SUB); 04277000 + IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE 04278000 + OPTYPE[IT~IT-1] ~ REALTYPE; 04279000 + END; 04280000 + BEGIN E0(CHS); TM~AD2; GO RPLUSD END; 04281000 + BEGIN TM~SUB ; 04282000 + RLESSC: ES1(TM); GO DLESSC1 ; 04282010 + END ; 04282030 + BEGIN 04283000 + EMITPAIR(0, XCH); 04284000 + EMITO(SB2); 04285000 + IT ~ IT-1; 04286000 + END; 04287000 + BEGIN EMITO(SB2); IT ~ IT-1 END; 04288000 + BEGIN TM~SUB ; 04289000 + DLESSC: ES1(TM); E0(XCH); E0(DEL) ; 04289005 + DLESSC1: EOL(9); IF TM=SUB THEN E0(CHS); GO CTIMESR2 ; 04289007 + END ; 04289010 + BEGIN EMITO(SUB); IT ~ IT-1 END; 04290000 + BEGIN TM~SUB ; 04291000 + CLESSD: E0(XCH); E0(DEL); E0(TM) ; 04291010 + CTYP: OPTYPE[IT~IT-1]~COMPTYPE ; 04291015 + END ; 04291020 + BEGIN TM~SUB ; 04292000 + CLESSC: ES1(TM); GO CTIMESR1 ; 04292010 + END ; 04292020 + END SUBTRACT CASE STATEMENT; 04293000 + BEGIN % HANDLE NEGATIVE NUMBERS CASE STATEMENT. 04293100 + EXPV~-EXPV ; 04293200 + IF T2 { REALTYPE THEN EMITO(CHS) ELSE 04294000 + IF T2 = LOGTYPE THEN FLAG(55) ELSE 04295000 + IF T2 = DOUBTYPE THEN EMITO(CHS) ELSE 04296000 + IF T2 = COMPTYPE THEN 04297000 + BEGIN 04298000 + EMITO(CHS); EMITO(XCH); 04299000 + EMITO(CHS); EMITO(XCH); 04300000 + END ELSE FLAG(55); 04301000 + END OF NEG NUMBERS CASE STATEMNT ; 04301100 + IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE 04302000 + CASE CODE OF 04303000 + BEGIN 04304000 + BEGIN 04305000 + EMITO(MUL); 04306000 + IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE 04307000 + OPTYPE[IT~IT-1] ~ REALTYPE; 04308000 + END; 04309000 + BEGIN TM~ML2; GO RPLUSD END ; 04310000 + BEGIN ES2; GO DTIMESC END ; 04311000 + BEGIN 04312000 + EMITPAIR(0, XCH); 04313000 + EMITO(ML2); 04314000 + IT ~ IT-1; 04315000 + END; 04316000 + BEGIN EMITO(ML2); IT ~ IT-1 END; 04317000 + BEGIN ES2; E0(XCH); E0(DEL) ; 04318000 + DTIMESC: EOL(9); EOL(17); E0(MUL); GO CTYP ; 04318010 + END ; 04318020 + BEGIN TM~MUL ; 04319000 + CTIMESR: EP(9,SND); E0(TM) ; 04319010 + CTIMESR1:E0(XCH); EOL(9); E0(TM) ; 04319020 + CTIMESR2:E0(XCH); GO CTYP ; 04319030 + END ; 04319040 + BEGIN TM~MUL; GO CDIVBYD END ; 04320000 + MATH(2, 26, COMPTYPE); 04321000 + END MULTIPLY CASE STATEMENT; 04322000 + IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE 04323000 + CASE CODE OF 04324000 + BEGIN 04325000 + IF T1 = INTYPE AND T2 = INTYPE THEN 04326000 + BEGIN EMITO(IDV); IT ~ IT-1 END ELSE 04327000 + BEGIN EMITO(DIU); OPTYPE[IT~IT-1] ~ REALTYPE END; 04328000 + BEGIN 04329000 + EP(9,STD); EP(17,STD); EP(0,XCH); EOL(17); EOL(9); E0(DV2) ; 04329010 + GO DTYP ; 04329020 + END ; 04329030 + MATH(1, 29, COMPTYPE); 04330000 + BEGIN 04331000 + EMITPAIR(0, XCH); 04332000 + EMITO(DV2); 04333000 + IT ~ IT-1; 04334000 + END; 04335000 + BEGIN EMITO(DV2); IT ~ IT-1 END; 04336000 + MATH(2, 32, COMPTYPE); 04337000 + BEGIN TM~DIU; GO CTIMESR END ; 04338000 + BEGIN TM~DIU ; 04339000 + CDIVBYD: E0(XCH); E0(DEL); GO CTIMESR ; 04339010 + END ; 04339020 + MATH(2, 35, COMPTYPE); 04340000 + END OF DIVIDE CASE STATEMENT; 04341000 + IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE 04342000 + BEGIN 04343000 + IF CODE = 0 AND T2 = INTYPE AND 04344000 + CNSTSEENLAST THEN %113-04345000 + BEGIN 04346000 + IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE 04347000 + OPTYPE[IT~IT-1] ~ REALTYPE; 04348000 + EXPV~LINK; %113- 04349000 + A~1; ADR~SAVEADR; %113- 04350000 + WHILE EXPV DIV 2 ! 0 DO 04351000 + BEGIN 04352000 + EMITO(DUP); 04353000 + IF BOOLEAN(EXPV) THEN BEGIN A~A+1; EMITO(DUP) END; 04354000 + EMITO(MUL); 04355000 + EXPV ~ EXPV DIV 2; 04356000 + END; 04357000 + IF EXPV = 0 THEN BEGIN EMITO(DEL); EMITL(1) END ELSE 04358000 + WHILE A ~ A-1 ! 0 DO EMITO(MUL); 04359000 + END ELSE 04360000 + BEGIN 04361000 + EMITO(MKS); 04362000 + EMITL(CODE); 04363000 + EMITV(NEED(".XTOI ", INTRFUNID)); 04364000 + CASE CODE OF 04365000 + BEGIN 04366000 + BEGIN EMITO(DEL); OPTYPE[IT~IT-1]~IF (T1=INTYPE AND T2=INTYPE)04367000 + THEN INTYPE ELSE REALTYPE END; 04367500 + BEGIN EMITO(DEL); OPTYPE[IT~IT-1] ~ DOUBTYPE END; 04368000 + BEGIN EMITO(DEL); OPTYPE[IT~IT-1]~COMPTYPE END ; 04369000 + BEGIN EMITO(DEL); IT ~ IT-1 END; 04370000 + BEGIN EMITO(DEL); EMITO(DEL); IT ~ IT-1 END; 04371000 + BEGIN EMITO(DEL); EMITO(DEL); OPTYPE[IT~IT-1]~COMPTYPE END ; 04372000 + BEGIN EMITO(DEL); IT ~ IT-1 END; 04373000 + BEGIN EMITO(DEL); EMITO(DEL); IT ~ IT-1 END; 04374000 + BEGIN EMITO(DEL); EMITO(DEL); IT~IT-1 END ; 04375000 + END OF POWER CASE STATEMENT; 04376000 + END; 04377000 + END; 04378000 + END; 04379000 + IP ~ IP-1; 04380000 + END; 04381000 + EXPRESLT ~ EXPCLASS; 04381100 + STACK: 04382000 + PR[IP~IP+1] ~ PREC; 04383000 + OPST[IP] ~ OP; 04384000 + 04385000 + IF PREC > 0 AND PREC { 4 THEN 04386000 + BEGIN 04387000 + SCAN; LINK ~ FNEXT; 04388000 + IF NEXT = PLUS THEN GO TO LOOP; 04389000 + IF NEXT ! MINUS THEN GO TO NOSCAN; 04390000 + PREC ~ 8; OP ~ 12; 04391000 + GO TO STACK; 04392000 + END; 04393000 + GO TO LOOP; 04394000 + XIT: IF IP ! SAVIP THEN FLOG(56); 04395000 + IP ~ SAVIP-1; 04396000 + EXPR ~ OPTYPE[IT]; 04397000 + IF OPTYPE[IT-1] ! 0 THEN FLOG(56); 04398000 + IT ~ SAVIT-1; 04399000 + EXPRESULT ~ EXPRESLT; 04400000 + EXPVALUE ~ EXPV; 04401000 + EXPLINK ~ EXPLNK; 04402000 + IF DEBUGTOG THEN FLAGROUTINE(" EXPRE","SSION ",FALSE) ; 04403000 + END EXPR; 04404000 +PROCEDURE FAULT (X); 04404050 + VALUE X; 04404100 + REAL X; 04404125 + BEGIN REAL LINK; LABEL XIT; 04404150 + SCAN; IF GLOBALNEXT ! LPAREN THEN BEGIN FLAG(106); GO XIT END; 04404200 + SCAN; IF GLOBALNEXT ! ID THEN BEGIN FLAG(66); GO TO XIT END; 04404250 + IF X = 1 THEN PDPRT[0,0] ~ PDPRT[0,0] & 1[44:47:1] ELSE 04404275 + PDPRT[0,0] ~ PDPRT [0,0] & 1[43 :47:1]; 04404300 + EMITOPDCLIT(41); EMITO(DUP); 04404325 + IF X = 1 THEN BEGIN EMITL(2); EMITO(XCH); EMITL(1) END 04404350 + ELSE EMITL(6); 04404375 + EMITO(LND); 04404425 + IF X = 2 THEN EMITL(3); 04404435 + EMITO(SUB); 04404450 + IF X = 2 THEN 04404475 + BEGIN EMITO(DUP); EMITL(3); EMITO(SSN) ;EMITO(EQUL); EMITL(2)04404500 + ;EMITO(BFC) ; EMITO(DEL);EMITL(2); 04404525 + END; 04404550 + LINK ~ GET(GETSPACE(FNEXT)); EMITPAIR(LINK.ADDR,ISD); 04404570 + IF X = 1 THEN EMITL(30) ELSE EMITL(25); 04404600 + EMITO(LND); EMITL(41);EMITO(STD); 04404625 + SCAN; IF GLOBALNEXT ! RPAREN THEN FLAG(108); 04404650 + SCAN; 04404660 + XIT: 04404675 + END FAULT; 04404700 +PROCEDURE SUBREF; 04405000 +BEGIN REAL LINK,INFC; 04406000 + REAL ACCIDENT; 04406010 + LABEL XIT; 04406020 +IF DEBUGTOG THEN FLAGROUTINE(" SUB","REF ",TRUE ) ; 04406025 +IF TSSEDITOG THEN IF NAME="ZIP " AND NOT DCINPUT THEN TSSED(NAME,3) ; 04406030 + IF NAME = "EXIT " THEN 04407000 + BEGIN 04408000 + RETURNFOUND ~ TRUE; 04408100 + EMITL(1); 04409000 + EMITPAIR(16,STD); 04410000 + EMITPAIR(10,KOM); 04411000 + EMITPAIR( 5, KOM); 04412000 + PUT(FNEXT+1, "......"); 04413000 + SCAN; 04414000 + END ELSE IF NAME="ZIP " AND NOT DCINPUT THEN 04415000 + BEGIN 04415010 + EMITO(MKS); 04415011 + EMITL(0); EMITL(0); % DUMMY FILE AND FORMAT 04415020 + EMITPAIR(-1,SSN); 04415021 + EMITB(-1,FALSE); LADR1~LAX; ADJUST; DESCREQ~FALSE; 04415030 + IF ADR } 4085 THEN BEGIN ADR~ADR+1; SEGOVF END; 04415040 + ACCIDENT~PRGDESCBLDR(0,0,ADR.[36:10]+1,NSEG); 04415050 + EMITOPDCLIT(19); 04415070 + EMITO(GFW); 04415080 + LISTART ~ ADR&NSEG[TOSEGNO]; ADJUST;SCAN; 04415090 + IF GLOBALNEXT!LPAREN THEN BEGIN FLAG(106);GO TO XIT END; 04415100 + SCAN; IF GLOBALNEXT!ID THEN BEGIN FLAG(66); GO TO XIT END; 04415110 + LINDX ~ FNEXT; SCAN; XTA ~ GET(LINDX+1); 04415120 + IF GLOBALNEXT!RPAREN THEN BEGIN FLAG(108); GO TO XIT END; 04415130 + LINDX ~ GETSPACE(LINDX); 04415140 + IF T~(LINFA~GET(LINDX)).CLASS!ARRAYID THEN 04415150 + BEGIN FLAG(66); GO TO XIT END; 04415160 + IF XREF THEN ENTERX(XTA,0&LINFA[15:15:9]); 04415165 + EMITPAIR(LADDR~LINFA.ADDR,LOD); 04415170 + IF BOOLEAN(LINFA.FORMAL) THEN 04415180 + BEGIN 04415190 + IF T ~ GET(LINDX+2)<0 THEN EMITOPDCLIT(T.SIZE) 04415200 + ELSE EMITNUM(T.SIZE); EMITOPDCLIT(LADDR-1); EMITO(CTF) END 04415210 + ELSE EMITNUM(GET(LINDX+2).BASENSIZE); EMITL(18); EMITO(STD);; 04415220 + EMITL(LINFA.CLASNSUB&0[44:47:1]); EMITL(19); EMITO(STD); 04415230 + BRANCHLIT(LISTART,TRUE); EMITL(19); EMITO(STD); 04415240 + EMITO(RTS); ADJUST; 04415250 + EMITL(1); EMITO(CHS); EMITL(19); EMITO(STD); 04415260 + EMITDESCLIT(19); EMITO(RTS); FIXB(LADR1); DESCREQ~FALSE; 04415270 + EMITPAIR(ACCIDENT,LOD); EMITOPDCLIT(7); EMITO(FTF); 04415280 + EMITL(6); % EDITCODE 6 FOR ZIP 04415290 + EMITV(NEED(".FTOUT",INTRFUNID)); SCAN 04415300 + END ELSE IF NAME = "OVERFL" THEN FAULT(2) 04415310 + ELSE IF NAME = "DVCHK " THEN FAULT(1) 04415320 + ELSE 04415330 + BEGIN 04416000 + LINK ~ NEED(NAME, SUBRID); 04417000 + IF XREF THEN ENTERX(XTA,0&GET(LINK)[15:15:5]); 04417100 + EMITO(MKS); 04418000 + SCAN; 04419000 + IF GLOBALNEXT = LPAREN THEN 04420000 + BEGIN PARAMETERS(LINK); SCAN END ELSE 04421000 + IF NOT BOOLEAN((INFC~GET(LINK+2)).[1:1]) THEN 04422000 + PUT(LINK+2,-INFC) ELSE 04423000 + IF INFC.NEXTRA ! 0 THEN 04424000 + BEGIN XTA ~ GET(LINK+1); FLAG(28) END; 04425000 + EMITV(LINK); 04426000 + 04426500 + 04426700 + END; 04427000 + XIT: 04427010 +IF DEBUGTOG THEN FLAGROUTINE(" SUB","REF ",FALSE) ; 04427025 +END SUBREF; 04428000 +PROCEDURE DECLAREPARMS(FNEW); VALUE FNEW; REAL FNEW; 04429000 +BEGIN 04430000 + REAL I, T, NLABELS, INFA, INFB, INFC; 04431000 +IF DEBUGTOG THEN FLAGROUTINE("DECLAR","EPARMS",TRUE ) ; 04431010 + INFA ~ GET(FNEW); 04432000 + IF INFA.SEGNO ! 0 THEN BEGIN XTA ~ NNEW; FLAG(25) END; 04433000 + INFA.SEGNO ~ NSEG; PUT(FNEW,INFA); 04434000 + ENTRYLINK[ELX] ~ 0 & FNEW[TOLINK] & NEXTSS[TOADDR]; 04435000 + FOR I ~ 1 STEP 1 UNTIL PARMS DO 04436000 + BEGIN 04437000 + EXTRAINFO[NEXTSS.IR,NEXTSS.IC] ~ PARMLINK[I]; 04438000 + NEXTSS ~ NEXTSS-1; 04439000 + IF T ~ PARMLINK[I] ! 0 THEN 04440000 + BEGIN 04441000 + GETALL(T,INFA,INFB,INFC); 04442000 + IF BOOLEAN(INFA .FORMAL) THEN 04443000 + BEGIN 04443100 + IF INFA.SEGNO = ELX THEN 04444000 + BEGIN XTA ~ INFB ; FLAG(26) END; 04445000 + END ELSE IF (INFA < 0 AND INFA.ADDR < 1024) OR BOOLEAN(INFA.CE)04445100 + THEN BEGIN XTA ~ INFB; FLAG(107) END; 04445200 + INFA ~ INFA & 1[TOFORMAL] & ELX[TOSEGNO]; 04446000 + INFC .BASE ~ I; 04447000 + PUT(T,INFA); PUT(T+2,INFC); 04448000 + END ELSE NLABELS ~ NLABELS+1; 04449000 + END; 04450000 + IF NLABELS > 0 THEN 04451000 + BEGIN ENTRYLINK[ELX ].CLASS ~ NLABELS; 04452000 + IF LABELMOM=0 THEN BEGIN BUMPLOCALS; LABELMOM~LOCALS+1536 END; 04453000 + END; 04454000 + GETALL(FNEW,INFA,INFB,INFC); 04455000 + IF BOOLEAN(INFC.[1:1]) THEN 04456000 + BEGIN 04457000 + IF INFC.NEXTRA ! PARMS THEN 04458000 + BEGIN XTA ~ INFB; FLOG(41); 04459000 + PARMS ~ INFC.NEXTRA; 04460000 + END; 04461000 + T ~ INFC.ADINFO; 04462000 + FOR I ~ 1 STEP 1 UNTIL PARMS DO 04463000 + IF NOT(PARMLINK[I] = 0 EQV 04464000 + EXTRAINFO[(T+I-1).IR,(T+I-1).IC].CLASS = LABELID) THEN 04465000 + BEGIN IF PARMLINK[I] = 0 THEN XTA ~ "* " 04466000 + ELSE XTA ~ GET(PARMLINK[I]+1); 04467000 + FLAG(40); 04468000 + END; 04469000 + END 04470000 + ELSE 04471000 + BEGIN 04472000 + IF PARMS = 0 THEN INFC ~ -INFC ELSE 04473000 + INFC ~ -(INFC & PARMS[TONEXTRA] 04474000 + & NEXTEXTRA[TOADINFO]); 04475000 + PUT(FNEW+2,INFC); 04476000 + FOR I ~ 1 STEP 1 UNTIL PARMS DO 04477000 + BEGIN 04478000 + EXTRAINFO[NEXTEXTRA.IR,NEXTEXTRA.IC] ~ 0 & 04479000 + (IF PARMLINK[I] = 0 THEN LABELID ELSE 0)[TOCLASS]; 04480000 + NEXTEXTRA ~ NEXTEXTRA+1; 04481000 + END; 04482000 + END; 04483000 + IF ELX ~ ELX+1 > MAXEL THEN BEGIN FLAG(128); ELX ~ 0 END; 04484000 +IF DEBUGTOG THEN FLAGROUTINE("DECLAR","EPARMS",FALSE) ; 04484010 +END DECLAREPARMS; 04485000 +PROCEDURE IOLIST(LEVEL); REAL LEVEL; 04486000 +BEGIN ALPHA LADR2,T; 04487000 +BOOLEAN A; 04487050 +INTEGER INDX,I,BDLINK,NSUBS; 04487100 + LABEL ROUND,XIT,ERROR,LOOP,SCRAM; 04488000 +INTEGER STREAM PROCEDURE CNTNAM(IDEN); VALUE IDEN; 04488100 +BEGIN LABEL XIT; 04488200 + SI ~ LOC IDEN; SI ~ SI + 3; TALLY ~ 1; 04488300 + 5(IF SC = " " THEN JUMP OUT TO XIT;SI ~ SI+1;TALLY ~ TALLY+1); 04488400 + XIT: CNTNAM ~ TALLY; 04488500 +END CNTNAM; 04488600 + 04489000 + 04490000 +IF DEBUGTOG THEN FLAGROUTINE(" IOL","IST ",TRUE ) ; 04491000 +ROUND: DESCREQ ~ TRUE; 04492000 + LOCALNAME ~ FALSE; 04492100 +IF GLOBALNEXT = SEMI THEN GO TO XIT; 04493000 +IF GLOBALNEXT = STAR THEN 04493100 + BEGIN IF NOT NAMEDESC THEN 04493150 + TV ~ ENTER(0&LISTSID[TOCLASS],LISTID~LISTID+1); 04493200 + LOCALNAME ~ TRUE; NAMEDESC ~ TRUE; SCAN; 04493300 + END; 04493350 +IF GLOBALNEXT = ID THEN 04494000 +BEGIN LINDX ~ FNEXT; 04495000 + SCAN; XTA ~ GET(LINDX+1); 04496000 + IF GLOBALNEXT = EQUAL THEN %RETURN TO CALLER 04497000 + BEGIN IF (LINFA~GET(GETSPACE(LINDX))).CLASS ! VARID THEN FLAG(50);04498000 + SCRAM: IF (LEVEL ~ LEVEL-1) < 0 THEN FLOG(97); 04498100 + GO TO XIT; 04498200 + END; 04499000 + 04500000 + IF DATASTMTFLAG AND SPLINK } 0 THEN %DECLARE OWN 04500100 + BEGIN 04500200 + IF BOOLEAN(GET(LINDX).FORMAL) THEN FLAG(147); 04500300 + IF SPLINK>1 THEN 04500310 + IF GET(LINDX).ADDR>1023 THEN FLAG(174); 04500320 + LINDX ~ GETSPACE(-LINDX); 04500400 + IF BOOLEAN(GET(LINDX).EQ) THEN FLAG(168); 04500420 + END ELSE LINDX ~ GETSPACE(LINDX); 04500500 + IF T ~ (LINFA~GET(LINDX)).CLASS > VARID THEN FLAG(50); 04500600 + IF XREF THEN ENTERX(XTA,C2&LINFA[15:15:9]); 04500655 + IF GLOBALNAME OR LOCALNAME THEN 04500700 + IF NAMEIND~ NAMEIND+1 GTR LSTMAX THEN FLOG(161) 04500725 + ELSE NAMLIST[NAMEIND] ~ XTA & CNTNAM(XTA)[9:45:3]; 04500750 + IF T = ARRAYID THEN 04501000 + IF GLOBALNEXT ! LPAREN THEN 04502000 + BEGIN IF SPLINK ! 1 THEN 04503000 + BEGIN 04503004 + EMITL(0); 04503008 + EMITPAIR(LADDR ~ LINFA.ADDR,LOD); 04503010 + EMITO(FTC); 04503020 + EMITDESCLIT(2); 04503030 + EMITO(INX); 04503040 + EMITO(LOD); 04503050 + END ELSE EMITPAIR(LADDR-LINFA.ADDR,LOD); 04503055 + NSUBS ~ (T ~ GET (LINDX+2)).NEXTRA; 04503100 + IF GLOBALNAME OR LOCALNAME THEN 04503125 + BEGIN 04503150 + IF NSUBS GTR SAVESUBS THEN SAVESUBS ~ NSUBS; 04503160 + IF NSUBS GTR NAMLIST[0] THEN NAMLIST[0] ~ NSUBS; 04503170 + NAMLIST[NAMEIND].[1:8] ~ NSUBS; 04503175 + INDX ~ -1; 04503180 + INFA ~ GET(NEED(".SUBAR",BLOCKID)).ADDR; 04503190 + BDLINK ~ T.ADINFO+1; 04503200 + END; 04503225 + IF BOOLEAN (LINFA.FORMAL) THEN 04504000 + BEGIN 04505000 + IF T LSS 0 THEN EMITOPDCLIT(T.SIZE) 04505200 + ELSE EMITNUM(T.SIZE); 04506000 + EMITOPDCLIT(LADDR-1); 04507000 + EMITO(CTF); 04508000 + END ELSE EMITNUM(T.BASENSIZE); 04509000 + IF GLOBALNAME OR LOCALNAME THEN 04509050 + FOR I ~ 1 STEP 1 UNTIL NSUBS DO 04509100 + BEGIN IF T ~ EXTRAINFO[(BDLINK~BDLINK-1).IR, 04509150 + BDLINK.IC] LSS 0 THEN EMITOPDCLIT(T) 04509200 + ELSE EMITNUM(T); 04509250 + EMITNUM(INDX ~ INDX+1); 04509300 + EMITDESCLIT(INFA); 04509350 + EMITO(STD); 04509400 + END; 04509450 + EMITL(18); EMITO(STD); 04510000 + END ELSE 04511000 + BEGIN SCAN; 04512000 + A ~(IF GLOBALNAME OR LOCALNAME 04513000 + THEN SUBSCRIPTS(LINDX,4) ELSE SUBSCRIPTS(LINDX,2)); 04513100 + SCAN; 04514000 + END 04515000 + ELSE EMITN(LINDX); 04516000 + IF GLOBALNAME OR LOCALNAME THEN 04516100 + BEGIN EMITOPDCLIT(18); EMITNUM(NAMEIND); 04516200 + EMITD(43,DIA); EMITD(3,DIB); EMITD(15,TRB); 04516300 + EMITL(18); EMITO(STD); 04516350 + END; 04516400 + EMITL(LINFA.CLASNSUB&0[44:47:1]); 04517000 + EMITL(20); EMITO(STD); 04518000 + IF ADR > 4083 THEN 04518100 + BEGIN ADR~ADR+1; SEGOVF END ; 04518200 + BRANCHLIT(LISTART,TRUE); 04519000 + EMITL(19); EMITO(STD); 04520000 + EMITO(RTS); ADJUST; 04521000 + GO TO LOOP; 04522000 +END; 04523000 +IF GLOBALNEXT = LPAREN THEN % RECURSE ON ( 04524000 +BEGIN EMITB(-1,FALSE); 04525000 + ADJUST; 04526000 + LADR2 ~ (ADR + 1)&LAX[TOADDR]&NSEG[TOSEGNO]; 04527000 + SCAN; LEVEL ~ LEVEL + 1; 04528000 + IOLIST(LEVEL); 04529000 + IF GLOBALNEXT ! EQUAL THEN % PHONY IMP DO 04530000 + BEGIN BRANCHES[T ~ LADR2.ADDR] ~ BRANCHX; 04531000 + BRANCHX ~ T; 04532000 + IF GLOBALNEXT ! RPAREN THEN GO TO ERROR; 04533000 + SCAN; GO TO LOOP; 04534000 + END; 04535000 + IF XREF THEN ENTERX(GET(LINDX+1),1&LINFA[15:15:9]); 04535500 + IF LINFA.SUBCLASS > REALTYPE THEN 04536000 + BEGIN XTA ~ GET(LINDX + 1); 04537000 + FLAG(84); 04538000 + END; 04539000 + EMITB(-1,FALSE); 04540000 + LADR3 ~ LAX; 04541000 + FIXB(LADR2.ADDR); 04542000 + DESCREQ ~ FALSE; 04543000 + SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(102); % INITIAL VALUE 04544000 + EMITN(LINDX); EMITO(STD); 04545000 + EMITB(LADR2,FALSE); 04546000 + IF GLOBALNEXT ! COMMA THEN GO TO ERROR; 04547000 + ADJUST; 04548000 + LADR4 ~ (ADR + 1)&NSEG[TOSEGNO]; 04549000 + SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(102) ELSE EMITO(GRTR); 04550000 + EMITB(LADR2,TRUE); 04551000 + EMITB(-1,FALSE); 04552000 + LADR5 ~ LAX; 04553000 + FIXB(LADR3); 04554000 + IF GLOBALNEXT ! COMMA THEN EMITL(1) 04555000 + ELSE BEGIN SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(102); END; 04556000 + EMITV(LINDX); EMITO(ADD); 04557000 + EMITN(LINDX); EMITO(SND); 04558000 + EMITB(LADR4,FALSE); 04559000 + FIXB(LADR5); 04560000 + IF GLOBALNEXT = RPAREN THEN SCAN ELSE GO TO ERROR; 04561000 + LOOP: IF GLOBALNEXT = SEMI OR GLOBALNEXT = SLASH THEN GO TO XIT; 04562000 + IF GLOBALNEXT = RPAREN THEN GO TO SCRAM; 04563000 + IF GLOBALNEXT = COMMA THEN 04564000 + BEGIN SCAN; 04565000 + IF GLOBALNEXT = SEMI THEN GO TO ERROR; 04566000 + GO TO ROUND; 04567000 + END; 04568000 + ERROR: XTA ~ NAME; 04569000 + FLAG(94); 04570000 + IF GLOBALNEXT = SEMI THEN GO TO XIT; 04571000 + SCAN; 04572000 + IF GLOBALNEXT = ID THEN GO TO ROUND; 04573000 + ERRORTOG ~ TRUE; GO TO XIT; 04574000 + END; 04575000 + IF GLOBALNEXT = RPAREN THEN GO TO SCRAM ELSE 04576000 + IF GLOBALNEXT ! SLASH THEN GO TO ERROR; 04577000 + XIT: IF DEBUGTOG THEN FLAGROUTINE(" IOL","IST ",FALSE) ; 04578000 + END IOLIST; 04579000 + INTEGER PROCEDURE FILECHECK(FILENAME,FILETYPE); 04580000 + VALUE FILENAME,FILETYPE; ALPHA FILENAME; INTEGER FILETYPE; 04581000 + BEGIN COMMENT THIS PROCEDURE RETURNS THE PRT CELL ALLOCATED TO 04582000 + THE FILE FILENAME... A CELL IS CREATED IF NONE EXISTS; 04583000 + IF DEBUGTOG THEN FLAGROUTINE(" FILEC","HECK ",TRUE); 04583010 + EMITL(IF NOTOPIO THEN 2 ELSE 5); % FOR IO DESCRIPTOR 04584000 + IF T ~ GLOBALSEARCH(FILENAME) = 0 THEN % FILE UNDECLARED 04585000 + BEGIN MAXFILES ~ MAXFILES + 1; 04586000 + BUMPPRT; 04586500 + I ~ GLOBALENTER(-0&(FILECHECK~PRTS)[TOADDR] 04587000 + &FILEID[TOCLASS],FILENAME)+2; 04588000 + INFO[I.IR,I.IC]. LINK ~ FILETYPE; 04589000 + END ELSE % FILE ALREADY EXISTS 04590000 + FILECHECK ~ GET(T).ADDR; 04591000 + IF DEBUGTOG THEN FLAGROUTINE(" FILEC","HECK ",FALSE) ; 04591010 + END FILECHECK; 04592000 + PROCEDURE INLINEFILE; 04593000 + BEGIN COMMENT THIS PROCEDURE GENERATES THE CODE TO BRING UP THE FILE...04594000 + IF THE FILE IS AN INTEGER THEN FILECHECK IS CALLED, IF THE FILE 04595000 + IS NOT AN INTEGER THEN IN-LINE CODE IS GENERATED FOR OBJECT TIME 04596000 + ANALYSIS; 04597000 + REAL TEST; 04598000 + COMMENT IF LAST INSTRUCTION WAS A LIT CALL THEN WE HAVE SEEN REFERENCE 04599000 + TO AN INTEGER FILE ID; 04600000 + IF DEBUGTOG THEN FLAGROUTINE(" INLIN","EFILE ",TRUE ) ; 04600010 + TEST~ADR ; 04601000 + IF EXPR(TRUE)>REALTYPE THEN FLAG(102) 04602000 + ELSE IF EXPRESULT=NUMCLASS THEN 04602500 + BEGIN XTA~NNEW ; 04603000 + IF EXPVALUE}1.0@5 OR EXPVALUE{0.5 THEN FLAG(33) 04603500 + ELSE BEGIN 04604000 + IF ADR LSTMAX THEN GO TO NUL; 04685500 + WSA[TOTAL] ~ I ~ 0; GO TO ROUND; 04686000 + END ELSE GO TO ROUND ELSE GO TO NUL1; 04686500 + END; 04687500 + IF NOT STRINGF THEN 04687510 + IF SLCNT > 0 THEN 04687520 + IF T = "/" THEN BEGIN SLCNT ~ SLCNT+1; GO TO ROUND; END 04687530 + ELSE 04687550 + BEGIN WSA[TOTAL] ~ 0 & SLCNT[TOREPEAT] & SLASH[TOCODE]; 04687560 + IF NOT STR THEN 04687580 + IF REPEAT < 16 AND WSA[TOTAL-1].[42:6] = 0 THEN 04687590 + WSA[TOTAL~TOTAL-1] ~ WSA[TOTAL] & SLCNT[42:44:4] 04687600 + & 1[46:47:1]; 04687620 + COMMAS~DOLLARS~BOOLEAN(SLCNT~0); NCR~BACKNCR(NCR) ; 04687650 + GO TO NUL1; 04687655 + END; 04687660 + IF NOT QF THEN IF T = """ THEN IF STRINGF ~ NOT STRINGF THEN 04688000 + BEGIN IF CODE > 4 THEN BEGIN STRINGF ~ FALSE; 04688500 + NCR ~ BACKNCR(NCR); GO TO ENDER END; 04689000 + SAVTOTAL ~ TOTAL; J~0; I~3; QF ~ TRUE; 04689500 + WSA[TOTAL] ~ 0 & HPHASE[TOCODE]; 04690000 + GO TO ROUND; 04690500 + END ELSE 04691000 + BEGIN 04691500 + WSA[SAVTOTAL] ~ WSA[SAVTOTAL] & J[TOREPEAT]; 04692000 + IF I = 0 THEN TOTAL ~ TOTAL - 1; 04693000 + CODE ~ HPHASE; 04693200 + GO TO ENDER; 04693500 + END; 04694000 + IF STRINGF THEN 04694500 + BEGIN 04695000 + STORECHAR(WSA[TOTAL],I,T); 04695550 + J ~ J + 1; QF ~ FALSE; 04696000 + IF I ~ I+1 = 8 THEN 04696500 + BEGIN 04697000 + IF TOTAL ~ TOTAL +1> LSTMAX THEN GO TO NUL; 04697500 + I ~ WSA[TOTAL] ~ 0; 04698000 + END; 04698500 + GO TO ROUND; 04699000 + END; 04699500 +CASE T OF 04707000 +BEGIN 04707500 + BEGIN ZF ~ TRUE; % 0 04708000 + NUM: DECIMAL ~ 10 | DECIMAL + T; 04708500 + IF ASK THEN 04708510 + BEGIN FLAG(183); %111-04708515 +FL: DO BEGIN NCR~GETCHAR(NCR,T); XTA~T&XTA[12:18:30] END 04708520 + UNTIL T!"*" AND T>9 AND T!" " ; 04708525 + NCR~BACKNCR(NCR); XTA~BLANKS&XTA[18:12:30] ; 04708530 + END 04708535 + ELSE 04708540 + IF DECIMAL>4090 THEN BEGIN FLAG(172); DECIMAL~1 END ; 04708550 + IF CODE = 0 THEN REPEAT ~ DECIMAL 04709500 + ELSE IF PF THEN BEGIN IF DECIMAL>WIDTH AND WIDTH!0 AND CODE! 04710000 + VPHRASE THEN FLAG(129) END ELSE WIDTH~DECIMAL ; 04710500 + GO TO ROUND; 04712000 + END; 04712500 + GO TO NUM; GO TO NUM; GO TO NUM; % 1 2 3 04713000 + GO TO NUM; GO TO NUM; GO TO NUM; % 4 5 6 04713500 + GO TO NUM; GO TO NUM; GO TO NUM; % 7 8 9 04714000 + ; ; ; ; ; ; % # @ Q : > } 04714500 + BEGIN PLUSP ~ TRUE; GO TO ROUND; END; % + 04714600 + BEGIN CODE ~ APHASE; GO TO NOEND END; % A 04715000 + ; % B 04715500 + BEGIN CODE ~ CPHASE; GO TO NOEND END; % C 04715600 + BEGIN CODE ~ DPHASE; GO TO NOEND END; % D 04716000 + BEGIN CODE ~ EPHASE; GO TO NOEND END; % E 04716500 + BEGIN CODE ~ FPHASE; GO TO NOEND END; % F 04717000 + BEGIN CODE ~ GPHASE; GO TO NOEND END; % G 04717500 + BEGIN IF REPEAT = 0 THEN FLOG(130); % H 04718000 + IF ASK THEN BEGIN FLOG(32 ); GO SEMIC END ; 04718100 + HF ~ TRUE; I ~ 3; CODE ~ HPHASE; 04719000 + WSA[TOTAL] ~ 0 & HPHASE[TOCODE] & REPEAT[TOREPEAT]; 04719500 + GO TO ROUND; 04720000 + END; 04720500 + BEGIN CODE ~ IPHASE; GO TO NOEND END; % I 04721000 + BEGIN IF CODE < 11 OR CODE=15 THEN FLOG(134); % . 04721500 + IF CODE=0 OR PF THEN FLOG(32) ; 04722000 + PF~TRUE; DECIMAL~0; ASK~ZF~FALSE ; 04722500 + GO TO ROUND; 04723000 + END; 04723500 + GO TO RP; % [ 04724000 + ; % & 04724500 + LP: 04725000 + BEGIN IF CODE ! 0 THEN FLOG(32); % ( 04725500 + IF ASK THEN REPEAT~4095; IF REPEAT=0 AND ZF THEN FLAG(173) ;04725550 + NAMLIST[SAVLASTLP ~ PARENCT ~ PARENCT+1] ~ 0 & TOTAL[TOWIDTH]04726000 + &(IF REPEAT{0 AND PARENCT>1 THEN 1 ELSE REPEAT)[TOREPEAT] ; 04726500 + IF ASK THEN 04726510 + BEGIN ASK~VRB~FALSE ; 04726520 + WSA[TOTAL]~32&LPPHRASE[TOCODE]&4095[TOREPEAT] ; 04726530 + IF (TOTAL~TOTAL+1)>LSTMAX THEN GO NUL ; 04726540 + END ; 04726550 + ZF~BOOLEAN(REPEAT~DECIMAL~0) ; 04727500 + STR ~ TRUE; 04727600 + GO TO ROUND1; 04728000 + END; 04728500 + ; ; ; % < ~ | 04729000 + BEGIN CODE~JPHASE; WIDTH~-1; GO NOEND END ; % J 04729500 + BEGIN % K 04730000 + IF COMMAS OR CODE!0 THEN BEGIN FLAG(32); COMMAS~TRUE END 04730100 + ELSE BEGIN COMMAS~TRUE ; 04730110 +KK: DO BEGIN NCR~GETCHAR(NCR,T); XTA~T&XTA[12:18:30] END 04730120 + UNTIL T!" " ; 04730125 + IF (T<17 OR (T>25 AND T<33) OR (T>42 AND T<50) OR T>57) 04730130 + THEN BEGIN FLAG(32) ; 04730135 + IF T="*" OR T<10 THEN BEGIN DECIMAL~1; GO FL END ; 04730137 + END ; 04730139 + NCR~BACKNCR(NCR); XTA~BLANKS&XTA[18:12:30] ; 04730140 + END ; 04730145 + GO ROUND ; 04730150 + END OF K ; 04730160 + BEGIN CODE ~ LPHASE; GO TO NOEND; END; % L 04730500 + ; ; % M N 04731000 + BEGIN CODE ~ OPHASE; GO TO NOEND; END; % O 04731500 + BEGIN WSA[TOTAL] ~ 0 & PPHASE[TOCODE] % P 04732000 + & REAL(VRB)[42:47:1] 04732100 + & REAL(MINUSP)[TOSIGN] & REPEAT[TOWIDTH]&1[TOREPEAT]; 04732500 + MINUSP ~ PLUSP ~ FALSE; 04733000 + IF (DECIMAL = 0 AND NOT ZF) THEN FLOG(131); 04733500 + GO TO NUL1; 04734500 + END; 04735000 + ; ; % Q R 04735500 + BEGIN IF DOLLARS OR CODE!0 THEN FLAG(32) % $ 04735600 + ELSE BEGIN DOLLARS~TRUE; GO KK END ; 04735610 + DOLLARS~TRUE; GO ROUND ; 04735620 + END OF DOLLAR SIGN ; 04735630 + IF NOT ASK THEN % * 04735700 + BEGIN 04735710 + IF ZF OR DECIMAL NEQ 0 THEN FLAG(183); DECIMAL:=4095; %111-04735715 + IF CODE=0 THEN REPEAT~DECIMAL 04735720 + ELSE IF NOT PF THEN WIDTH~DECIMAL ; 04735730 + VRB := ASK := LISTEL := TRUE; GO ROUND; %101-04735740 + END ELSE BEGIN DECIMAL:=4095; FLAG(183); GO FL END ; %111-04735750 + BEGIN MINUSP ~ TRUE; GO TO ROUND; END; % - 04736000 + RP: 04736500 + BEGIN IF FEELD THEN BEGIN NCR ~ BACKNCR(NCR); % ) 04737000 + GO TO ENDER; END; 04737500 + IF DECIMAL ! 0 THEN FLAG(32); 04737600 + I ~ IF PARENCT = 1 THEN IF SAVLASTLP > 1 THEN 2 ELSE 1 04738500 + ELSE PARENCT; 04739000 + WSA[TOTAL]~(J~NAMLIST[I])&(TOTAL+1-J~J.[18:12])[TOLINK] 04739500 + & (IF PARENCT ~ PARENCT-1 = 0 THEN 77 ELSE 0)[TODECIMAL]; 04740000 + IF WSA[J].[1:5]=LPPHRASE AND PARENCT!0 THEN 04740100 + BEGIN WSA[J].[18:12]~TOTAL-J; WSA[TOTAL].[18:12]~TOTAL-J ;04740110 + END ; 04740115 + NAMLIST[I].[6:12] ~ 0; 04740500 + CODE ~ HPHASE; 04740600 + GO TO NUL1; 04742000 + END; 04742500 + ; ; % ; LEQ 04743000 + GO TO ROUND; % BLANKS 04743500 + BEGIN SLCNT ~ 1; % / 04744000 +SL: IF CODE=0 THEN IF ASK OR ZF OR DECIMAL!0 THEN 04744100 + BEGIN FLAG(32); ASK~ZF~BOOLEAN(DECIMAL~0) END ; 04744110 + IF CODE<5 THEN IF T="," THEN GO ROUND1 ELSE GO ROUND ELSE GO 04744500 + ENDER ; 04744505 + END; 04745000 + ; % S 04745500 + BEGIN IF REPEAT ! 0 THEN FLAG(32); % T 04746000 + CODE ~ TPHASE; 04746050 + GO TO NOEND; 04746100 + END; 04746150 + ; % U 04746500 + BEGIN VRB~TRUE; CODE~VPHRASE; WIDTH~-1; GO NOEND END ; % V 04746750 + ; % W 04746800 + BEGIN IF REPEAT = 0 THEN FLOG(130); % X 04747000 + IF STR THEN 04747200 + NEWWD: WSA[TOTAL] ~ 0 & XPHASE[TOCODE] & REPEAT[TOWIDTH] 04747400 + & 1[TOREPEAT] 04747600 + & REAL(VRB)[42:47:1] 04747700 + ELSE 04747800 + BEGIN 04748000 + IF (J~WSA[TOTAL-1]).[42:6]>0 OR (I~J.[1:5])=RTPARN 04748800 + OR (REPEAT}32 AND I!XPHASE) THEN GO NEWWD ; 04749000 + IF I=XPHASE AND (I~J.[18:12]+REPEAT){4090 THEN 04749200 + WSA[TOTAL~TOTAL-1] ~ J & I[TOWIDTH] 04749400 + ELSE IF REPEAT } 32 THEN GO TO NEWWD 04749600 + ELSE WSA[TOTAL~TOTAL-1] ~ J & REPEAT[TONUM] 04749800 + & 1[TOCNTRL]; 04750000 + END; 04751000 + GO TO NUL1; 04752000 + END; 04752500 + ; ; % Y Z 04753000 + GO SL ; % , 04753500 + GO TO LP; % % 04754000 + ; ; ; % ! = ] " 04754500 +END OF CASE STATEMENT; 04755000 +FLOG(132); % ILLEGAL CHARACTER; 04755500 +GO TO FALL; 04756000 +ENDER: IF CODE > 4 THEN 04756500 + BEGIN IF WIDTH=0 THEN FLAG(130) ; 04757000 + IF CODE=VPHRASE THEN 04757400 + BEGIN 04757410 + IF WIDTH=-1 THEN IF PF THEN FLAG(130)ELSE WIDTH~ 04757420 + DECIMAL~4094 ELSE 04757425 + IF NOT PF THEN DECIMAL~4094 ; 04757430 + END 04757440 + ELSE 04757450 + IF CODE > 10 AND CODE ! 15 THEN 04757500 + IF (DECIMAL = 0 AND NOT ZF) OR NOT PF THEN FLAG(133) 04758000 + ELSE ELSE DECIMAL ~ 0; 04758100 + IF REPEAT=0 THEN REPEAT~1 ; 04758400 + IF WIDTH=-1 THEN WIDTH~0 ; 04758410 + WSA[TOTAL] ~ 0 & CODE[TOCODE] & WIDTH[TOWIDTH] 04758500 + & REPEAT[TOREPEAT] & DECIMAL[TODECIMAL] 04759000 + & REAL(COMMAS) [44:47:1] 04759100 + & REAL(VRB)[42:47:1] 04759150 + & REAL(DOLLARS)[45:47:1]; 04759200 + END ELSE IF DECIMAL ! 0 THEN FLAG(32); 04760000 +NUL1: IF PLUSP THEN FLAG(164); 04760500 + IF CODE!VPHRASE THEN 04760550 + BEGIN 04760560 + IF DOLLARS AND(CODE < 9 OR CODE > 14) THEN FLAG(166); 04760600 + IF COMMAS AND NOT(CODE = 10 OR CODE = 12 OR CODE = 9) 04760700 + THEN FLAG(165); 04760800 + END; 04760850 + VRB~ 04760890 + ERRORTOG ~ FEELD ~ PF ~ PLUSP ~ DOLLARS ~ COMMAS ~ STR ~ FALSE; 04760900 + IF CODE = HPHASE THEN STR ~ TRUE; 04760940 + CODE ~ REPEAT ~ WIDTH ~ 0; 04760980 + XTA ~ BLANKS; 04761000 + GO TO FALL; 04761500 +NOEND: IF FEELD THEN FLAG(32); 04762000 + IF CODE ! TPHASE THEN LISTEL ~ TRUE ELSE REPEAT ~ 1; 04762500 + IF REPEAT=0 AND ZF THEN FLAG(173) ; 04762510 + FEELD ~ TRUE; 04763000 +FALL: IF MINUSP THEN BEGIN FLAG(32); MINUSP ~ FALSE END; 04763500 + ASK~ZF~FALSE ; 04764000 +NUL: DECIMAL ~ 0; 04764500 + IF PARENCT = 0 THEN BEGIN SCN ~ 1; GO TO SEMIC END; 04765000 + IF CODE < 5 THEN 04765500 + IF TOTAL ~ TOTAL+1 > LSTMAX THEN 04766000 + BEGIN FLOG(78);TOTAL ~ TOTAL-2; GO TO SEMIC; END; 04766500 +GO TO ROUND; 04767000 +NOPLACE: IF(DCINPUT OR FREEFTOG) AND (STRINGF OR HF) THEN FLOG(150); 04767500 + IF TSSEDITOG THEN IF (STRINGF OR HF) AND NOT DCINPUT 04768000 + THEN TSSED(XTA,1); 04769000 + IF CONTINUE THEN IF READACARD THEN 04769500 + BEGIN IF LISTOG THEN PRINTCARD; GO TO ROUND; END; 04769500 +SCN ~ 0; NEXT ~ SEMI; 04770000 +SEMIC: 04770500 +IF SCN = 1 THEN SCAN; 04771000 +IF STRINGF THEN FLAG(22); 04771500 +IF NOT LISTEL THEN WSA[0] ~ 0; 04772000 +IF PARENCT ! 0 THEN FLAG(IF PARENCT < 0 THEN 9 ELSE 8); 04772500 +IF D ! 0 THEN PRTSAVER(D,TOTAL+1,WSA); 04772600 +IF DEBUGTOG THEN BEGIN 04772605 + WRITE(LINE,FM) ; 04772610 + FOR I~0 STEP 1 UNTIL TOTAL DO BEGIN 04772615 + WRITE(LINE,[13]//,I,(J~WSA[I]).[1:5],J.[6:12],J.[18:12],J.[30:12], 04772620 + J.[41:1],J.[42:4],J.[42:5],J.[44:1],J.[45:1], 04772625 + J.[46:1],J.[46:2],J.[47:1]) ; 04772630 + IF J.[1:5]=2 THEN I~I+(J.[6:12]+2).[36:9] ; 04772635 + END ; 04772640 + WRITE(LINE[DBL]) ; 04772645 + END OF DEBUGSTUFF ; 04772650 +END FORMATER; 04773000 +PROCEDURE EXECUTABLE; 04773010 +BEGIN LABEL XIT; REAL T, J, TS, P; 04773020 + IF SPLINK < 0 THEN FLAG(12); 04773030 + IF LABL = BLANKS THEN GO TO XIT; 04773040 + IF T ~ SEARCH(XTA ~ LABL) = 0 THEN 04773050 + T ~ ENTER(-0 & LABELID[TOCLASS] & (ADR+1)[TOADDR] & 04773060 + NSEG[TOSEGNO], LABL) ELSE 04773070 + BEGIN IF (P ~ GET(T)).CLASS ! LABELID THEN 04773080 + BEGIN FLAG(144); GO TO XIT END; 04773090 + IF P < 0 THEN BEGIN FLAG(20); GO TO XIT END; 04773100 + TS ~ P.ADDR; 04773110 + WHILE TS ! 0 DO 04773120 + BEGIN J ~ GIT(TS); FIXB(TS+10000); TS ~ J END; 04773130 + PUT(T, P~-P & (ADR+1)[TOADDR] & NSEG[TOSEGNO]); 04773140 + IF (T ~ GET(T+2)).BASE ! 0 THEN 04773150 + T ~ PRGDESCBLDR(2, T.BASE, (ADR+1).[36:10], NSEG); 04773160 + END; 04773170 + IF XREF THEN ENTERX(LABL,1&LABELID[TOCLASS]); 04773175 + XIT: 04773180 +END EXECUTABLE; 04773190 +PROCEDURE IOCOMMAND(N); VALUE N; REAL N; 04774000 +COMMENT N COMMAND 04775000 + 0 READ 04776000 + 1 WRITE 04777000 + 2 PRINT 04778000 + 3 PUNCH 04779000 + 4 BACKSPACE 04780000 + 04781000 + 04782000 + 7 DATA; 04783000 +BEGIN LABEL XIT,SUCH,LISTER,NOFORM,FORMER,WRAP,DAAT,NF; 04784000 +LABEL LISTER1; 04784200 + BOOLEAN SUCHTOG, RDTRIN, FREEREAD; 04785000 + BOOLEAN FORMARY, NOFORMT; 04785020 + BOOLEAN NAMETOG; 04785050 +DEFINE DATATOG = DATASTMTFLAG#; 04785100 +REAL T, ACCIDENT, EDITCODE; 04786000 +REAL DATAB; 04786100 +PROCEDURE ACTIONLABELS(UNSEEN); VALUE UNSEEN; BOOLEAN UNSEEN; 04787000 +BEGIN LABEL EOF,ERR,RATA,XIT,ACTION,MULTI; 04788000 + BOOLEAN BACK,GOTERR,GOTEOF; 04789000 +IF UNSEEN THEN SCAN; 04790000 +EOF: IF GOTEOF THEN GO TO MULTI; 04791000 + IF BACK ~ NAME = "END " THEN GO TO ACTION; 04792000 +ERR: IF GOTERR THEN GO TO MULTI; 04793000 + IF NAME ! "ERR " THEN IF GOTEOF THEN 04794000 + BEGIN MULTI: XTA ~ NAME; FLOG(137); 04795000 + GO TO XIT; 04796000 + END ELSE GO TO RATA; 04797000 +ACTION: SCAN; 04798000 + IF NEXT = EQUAL THEN SCAN ELSE GO TO RATA; 04799000 + IF NEXT ! NUM THEN GO TO RATA; 04800000 + IF XREF THEN ENTERX(NAME,0&LABELID[TOCLASS]); 04800100 + IF BACK THEN NX1 ~ NAME ELSE NX2 ~ NAME; 04801000 + SCAN; IF NEXT = RPAREN THEN GO TO XIT; 04802000 + IF NEXT = COMMA THEN SCAN ELSE GO TO RATA; 04803000 + IF BACK THEN 04804000 + BEGIN BACK ~ NOT ( GOTEOF ~ TRUE); 04805000 + GO TO ERR; 04806000 + END; 04807000 + GOTERR ~ TRUE; 04808000 + GO TO EOF; 04809000 +RATA: XTA ~ NAME; FLOG(0); 04810000 +XIT: 04811000 +END ACTIONLABELS; 04812000 +IF DEBUGTOG THEN FLAGROUTINE(" IOCOM","MAND ",TRUE ); 04812010 +EODS~N!7 ; 04812020 +C2 ~ IF N = 0 OR N = 7 THEN 1 ELSE 0; 04812050 +SCAN; IF NEXT = SEMI THEN BEGIN FLOG(0); GO TO XIT END; 04813000 +IF N = 7 THEN 04814000 +BEGIN DATATOG ~ TRUE; 04815000 + IF LOGIFTOG THEN FLAG(101); 04816000 + LABL ~ BLANKS; 04816100 + IF SPLINK } 0 THEN %NOT BLOCK DATA STMT 04816110 + BEGIN 04816120 + IF DATAPRT=0 THEN BEGIN 04816130 + DATAPRT~PRTS~PRTS+1; ADJUST; 04816135 + DATASTRT~(ADR+1)&NSEG[TOSEGNO] END 04816136 + ELSE FIXB(DATALINK); 04816137 + EMITOPDCLIT(DATAPRT); EMITO(LNG); 04816140 + EMITB(-1, TRUE); DATAB ~ LAX; 04816150 + END; 04816160 + GO TO DAAT; 04817000 +END; 04818000 + EXECUTABLE; 04819000 +EMITO(MKS); 04820000 +IF N = 4 THEN 04825100 +BEGIN 04825200 + INLINEFILE; 04826000 + BEGIN EMITL(0); EMITL(0); EMITL(0); EMITL(0); 04832000 + EMITL(5); EMITL(0); EMITL(0); 04833000 + EMITV(NEED(".FBINB",INTRFUNID)); 04834000 + END; 04835000 + GO TO XIT; 04836000 +END; 04837000 +EDITCODE ~ NX1 ~ NX1 ~ 0; 04838000 +IF RDTRIN ~ 04839000 + N = 0 THEN IF NEXT = LPAREN THEN GO TO SUCH 04840000 + ELSE EMITDESCLIT(FILECHECK(".5 ",2+17|REAL %503-04841000 + (REMOTETOG))) 04841100 +ELSE IF N = 1 THEN IF NEXT ! LPAREN THEN FLAG(33) 04842000 + ELSE GO TO SUCH 04843000 + ELSE IF N = 2 THEN %503-04844000 + EMITDESCLIT(FILECHECK(".6 ",2+17|REAL %503-04845000 + (REMOTETOG))) 04845100 + 04846000 + ELSE EMITDESCLIT(FILECHECK(".PUNCH",0)); 04847000 +IF RDTRIN THEN EMITL(0) ELSE EMITPAIR(1,SSN); 04848000 +GO TO FORMER; 04849000 +SUCH: SCAN; RANDOMTOG~SUCHTOG~TRUE; INLINEFILE ; 04850000 + RANDOMTOG~FREEREAD~FALSE ; 04850100 + IF NEXT = EQUAL THEN % RANDOM KEY 04852000 + BEGIN SCAN; 04853000 + IF EXPR(TRUE) > REALTYPE THEN FLAG(102); 04854000 + IF RDTRIN THEN EMITPAIR(1,ADD); 04855000 + END ELSE IF RDTRIN THEN EMITL(0) ELSE EMITPAIR(1,SSN); 04856000 + IF NEXT = RPAREN THEN GO TO NF; 04857000 + IF NEXT ! COMMA THEN BEGIN FLOG(114); GO TO XIT END; 04858000 + SCAN; 04859000 + IF NEXT = ID THEN 04860000 + IF NAME = "ERR " OR NAME = "END " THEN 04861000 + BEGIN ACTIONLABELS(FALSE); 04862000 + NF: IF RDTRIN THEN EMITL(0) ELSE EMITPAIR(1,SSN); 04863000 + EMITL(0); 04863100 + NOFORMT ~ TRUE; 04863500 + SCAN; GO TO NOFORM; 04864000 + END; 04865000 +FORMER: IF ADR } 4085 THEN 04866000 + BEGIN ADR ~ ADR+1; SEGOVF END; 04866100 + IF NEXT = NUM THEN % FORMAT NUMBER 04866200 + BEGIN EDITCODE ~ 1; 04867000 + IF TEST ~ LBLSHFT(NAME) { 0 THEN 04868000 + BEGIN FLAG(135); GO TO LISTER END; 04869000 + IF I ~ SEARCH(TEST) = 0 THEN % NEVER SEEN 04870000 + OFLOWHANGERS(I~ENTER(0&FORMATID[TOCLASS], TEST)) ELSE 04871000 + IF GET(I).CLASS ! FORMATID THEN 04871100 + BEGIN FLAG(143); GO TO LISTER END; 04871200 + IF XREF THEN ENTERX(TEST,0&FORMATID[TOCLASS]); 04873000 + IF GET(I).ADDR = 0 THEN 04874000 + BEGIN EMITLINK((INFC ~ GET(I + 2)).BASE); 04875000 + PUT(I + 2,INFC&ADR[TOBASE]); 04876000 + EMITL(0); EMITL(0); EMITO(NOP); 04877000 + END ELSE 04878000 + BEGIN EMITL(GET(I+ 2).BASE); 04879000 + EMITPAIR(GET(I).ADDR,LOD); 04880000 + END; 04881000 + GO TO LISTER; 04882000 +END ELSE IF RDTRIN THEN IF(FREEREAD := NEXT=SLASH) THEN GO TO LISTER 04883000 +ELSE BEGIN IF NEXT NEQ ID THEN BEGIN FLOG(116);GO TO XIT; END;END 04883100 + ELSE IF NEXT NEQ ID THEN 04883150 + BEGIN IF NEXT = STAR THEN 04883200 + BEGIN NAMEDESC := TRUE; GLOBALNAME := TRUE; 04883300 + TV := ENTER(0&LISTSID[TOCLASS],LISTID:=LISTID+1); 04883350 + SCAN; 04883400 + END; 04883450 + IF NEXT = LPAREN THEN 04883500 + BEGIN SCAN; IF EXPR(TRUE) GTR REALTYPE THEN FLAG(120) ; 04883550 + SCAN; END ELSE EMITL(0); 04883600 + IF GLOBALNAME AND (FREEREAD := NEXT = SLASH) OR FREEREAD THEN 04883650 + GO TO LISTER ELSE BEGIN FLOG(110); GO TO XIT; END; 04883700 + END; 04883750 + GETALL(I ~ FNEXT,INFA,INFB,INFC); 04884000 + IF T ~ INFA.CLASS = ARRAYID THEN % FORMAT ARRAY 04885000 + BEGIN EDITCODE ~ 1; 04886000 + FORMARY ~ TRUE; 04886050 + T ~ EXPR(FALSE); 04886100 + ADR ~ ADR-1; % ELIMINATE XCH EMITTED BY EXPR 04887000 + IF EXPRESULT ! ARRAYID THEN FLOG(116); 04887100 + GO TO LISTER1; % SCAN ALREADY DONE IN EXPR 04888000 + END ELSE 04889000 + IF T = NAMELIST THEN 04890000 + BEGIN NAMETOG := TRUE; 04890100 + IF INFA.ADDR = 0 THEN % REFERENCED, NOT DEF 04891000 + BEGIN EMITLINK(INFC.BASE); 04892000 + PUT(I+ 2,(INFC ~ INFC&ADR[TOBASE])); 04893000 + EMITL(0); EMITL(0); EMITO(NOP); 04894000 + END ELSE 04895000 + BEGIN EMITL(INFC.BASE); 04896000 + EMITPAIR(INFA.ADDR,LOD); 04897000 + END 04898000 + END 04898100 + ELSE IF T = UNKNOWN THEN % ASSUME NAMELIST 04899000 + BEGIN PUT(I,(INFA ~ INFA&NAMELIST[TOCLASS])); 04900000 + NAMETOG := TRUE; 04900100 + OFLOWHANGERS(I); 04901000 + EMITLINK(0); PUT(I + 2,INFC&ADR[TOBASE]); 04902000 + EMITL(0); EMITL(0); EMITO(NOP); 04903000 + END ELSE BEGIN XTA ~ INFB; FLOG(116); GO TO XIT END; 04904000 + SCAN; 04905000 + IF NEXT = COMMA THEN ACTIONLABELS(TRUE); 04906000 + IF SUCHTOG THEN 04907000 + IF NEXT ! RPAREN THEN FLOG(108) ELSE SCAN; 04908000 + IF NEXT ! SEMI THEN BEGIN FLOG(118); GO TO XIT END; 04909000 + EMITL(0); EDITCODE ~ 4; EMITOPDCLIT(7); EMITO(FTC); 04910000 + GO TO WRAP; 04911000 +LISTER: SCAN; 04912000 + IF FREEREAD THEN IF NOT RDTRIN THEN 04912100 + BEGIN IF NEXT ! SLASH THEN EMITO(SSN) ELSE SCAN; 04912200 + IF NEXT = LPAREN THEN 04912300 + BEGIN SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(120);SCAN 04912400 + END ELSE EMITL(0); 04912500 + END; 04912600 +LISTER1: 04912700 + IF SUCHTOG THEN 04913000 + BEGIN IF NEXT = COMMA THEN ACTIONLABELS(TRUE); 04914000 + IF NEXT = RPAREN THEN SCAN ELSE BEGIN FLOG(108); GO TO XIT END; 04915000 + END ELSE IF NEXT=COMMA THEN SCAN ELSE IF RDTRIN THEN 04916000 + IF NEXT!SEMI THEN FLOG(114); 04916100 +NOFORM: IF NEXT=SEMI THEN 04917000 + BEGIN IF FREEREAD THEN FLOG(061) ELSE EMITL(0); GO TO WRAP END; 04917100 + IF (NEXT NEQ LPAREN) AND (NEXT NEQ ID) AND (NEXT NEQ STAR) THEN 04918000 + GO TO XIT; 04918100 + EDITCODE ~ EDITCODE + 2; 04919000 +DAAT: EMITB(-1,FALSE); LADR1 ~ LAX; ADJUST; DESCREQ ~ TRUE; 04920000 + IF ADR } 4085 THEN 04920100 + BEGIN ADR ~ ADR+1; SEGOVF; ADJUST END; 04920200 + ACCIDENT ~ PRGDESCBLDR(0,0,ADR.[36:10] + 1,NSEG); 04921000 + EMITOPDCLIT(19); EMITO(GFW); 04922000 + LISTART ~ ADR&NSEG[TOSEGNO]; ADJUST; 04923000 + LA ~ 0; IOLIST(LA); 04924000 + EMITL(1); EMITO(CHS); EMITL(19); EMITO(STD); 04925000 + EMITDESCLIT(19); EMITO(RTS); 04926000 + FIXB(LADR1); DESCREQ ~ FALSE; 04927000 + IF DATATOG THEN 04928000 + BEGIN DATASET; 04929000 + IF NEXT = SLASH THEN SCAN ELSE 04930000 + BEGIN FLOG(110); GO TO XIT END; 04931000 + IF LSTA = 0 THEN BEGIN BUMPPRT; LSTA~PRTS END; 04932000 + IF (LSTMAX - LSTI) { LSTS THEN 04933000 + BEGIN WRITEDATA(LSTI,NXAVIL ~ NXAVIL + 1,LSTP); 04934000 + LSTA ~ PRGDESCBLDR(1,LSTA,0,NXAVIL); 04935000 + LSTI ~ 0; BUMPPRT; LSTA~PRTS; 04936000 + END; 04937000 + MOVEW(LSTT,LSTP[LSTI],(LSTS ~ LSTS + 1).[36:6],LSTS); 04938000 + EMITO(MKS); EMITL(LSTI); EMITPAIR(LSTA,LOD); 04939000 + LSTI ~ LSTI + LSTS; 04940000 + EMITPAIR(ACCIDENT,LOD); EMITOPDCLIT(7); EMITO(FTF); 04941000 + EMITL(6); EMITL(0); EMITL(0); 04942000 + EMITV(NEED(".FBINB",INTRFUNID)); 04943000 + IF NEXT = COMMA THEN 04944000 + BEGIN SCAN; GO TO DAAT END; 04945000 + IF SPLINK } 0 THEN BEGIN 04946000 + EMITB(-1,FALSE); DATALINK~LAX; 04946500 + FIXB(DATAB) END; 04946600 + GO TO XIT; 04947000 + END; 04948000 + EMITPAIR(ACCIDENT,LOD); EMITOPDCLIT(7); EMITO(FTF); 04949000 +WRAP: IF NOT FREEREAD AND NOT NAMETOG THEN EMITL(EDITCODE); 04950000 +IF RDTRIN THEN 04951000 +BEGIN IF NX1 = 0 THEN EMITL(0) ELSE EMITLABELDESC(NX1); 04952000 + IF NX2 = 0 THEN EMITL(0) ELSE EMITLABELDESC(NX2); 04953000 + IF FREEREAD THEN EMITV(NEED(".FREFR", INTRFUNID)) 04954000 + ELSE IF NAMETOG THEN EMITV(NEED(".FINAM",INTRFUNID)) 04954050 + ELSE IF FORMARY THEN EMITV(NEED(".FTINT",INTRFUNID)) 04954100 + ELSE IF NOFORMT THEN EMITV(NEED(".FBINB",INTRFUNID)) 04954150 + ELSE EMITV(NEED(".FTNIN",INTRFUNID)); 04954200 +END ELSE 04955000 +IF FREEREAD THEN 04956000 + BEGIN 04956005 + IF NAMEDESC THEN 04956010 + BEGIN 04956020 + PRTSAVER(TV,NAMEIND+1,NAMLIST); 04956040 + EMITL(GET(TV+2).BASE); 04956100 + EMITPAIR(GET(TV).ADDR,LOD); 04956200 + IF NAMLIST[0] = 0 THEN EMITL(0) 04956500 + ELSE EMITPAIR(GET(GLOBALSEARCH(".SUBAR")).ADDR,LOD); 04956550 + NAMLIST[0] := NAMEIND := 0; 04956600 + END ELSE BEGIN EMITL(0);EMITL(0);EMITL(0);END; 04956650 + EMITV(NEED(".FREWR",INTRFUNID)) 04956700 + END ELSE IF NAMETOG THEN EMITV(NEED(".FONAM",INTRFUNID)) 04956750 + ELSE IF FORMARY THEN EMITV(NEED(".FTOUT",INTRFUNID)) 04956800 + ELSE BEGIN 04956900 + IF NX1=0 THEN EMITL(0) ELSE EMITLABELDESC(NX1); 04956910 + IF NX2=0 THEN EMITL(0) ELSE EMITLABELDESC(NX2); 04956920 + IF NOFORMT THEN EMITV(NEED(".FBINB",INTRFUNID)) ELSE 04956925 + EMITV(NEED(".FTNOU",INTRFUNID)); 04956930 + END; 04956940 +XIT: 04957000 + IF NAMEDESC THEN IF RDTRIN THEN FLAG(159) 04957050 + ELSE IF NOT FREEREAD THEN FLAG(160); 04957055 + DATATOG := FALSE; NAMEDESC := FALSE; GLOBALNAME := FALSE; 04957100 +IF DEBUGTOG THEN FLAGROUTINE(" IOCOM","MAND ",FALSE); 04957110 +END IOCOMMAND; 04958000 +PROCEDURE STMTFUN(LINK); VALUE LINK; REAL LINK; 04959000 +BEGIN 04960000 + DEFINE PARAM = LSTT#; 04961000 + REAL SAVEBRAD, I; 04962000 + REAL INFA, INFC, NPARMS, TYPE, PARMLINK, BEGINSUB, RETURN; 04963000 + LABEL XIT,TIX ; 04964000 + IF SPLINK < 0 THEN FLAG(12); 04964100 + LABL ~ BLANKS; 04964200 + FILETOG ~ TRUE; % PREVENTS SCANNER FROM ENTERING IDS IN INFO 04965000 + IF XREF THEN ENTERX(GET(LINK+1),0&STMTFUNID[TOCLASS] 04965100 + &(GET(LINK))[21:21:3]); 04965200 + DO 04966000 + BEGIN 04967000 + SCAN; 04968000 + IF NEXT ! ID THEN BEGIN FLOG(107); GO TO XIT END; 04969000 + PARAM[NPARMS~NPARMS+1] ~ NAME; 04970000 + SCAN; 04971000 + END UNTIL NEXT ! COMMA; 04972000 + IF NEXT ! RPAREN THEN FLOG(108) ELSE SCAN; 04973000 + 04974000 + IF NEXT ! EQUAL THEN BEGIN FLOG(104); GO TO XIT END; 04975000 + EMITB(-1,FALSE); SAVEBRAD ~ LAX; % BRANCH AROUND ST FUN 04976000 + ADJUST; 04977000 + BEGINSUB ~ ADR+1; 04978000 + BUMPLOCALS; EMITPAIR(RETURN~LOCALS+1536,STD); 04979000 + FOR I ~ NPARMS STEP -1 UNTIL 1 DO 04980000 + BEGIN 04981000 + IF T ~ SEARCH(PARAM[I]) ! 0 THEN 04982000 + TYPE ~ GET(T).SUBCLASS ELSE 04983000 + IF T~PARAM[I].[12:6] < "I" OR T > "N" THEN 04984000 + TYPE ~ REALTYPE ELSE TYPE ~ INTYPE; 04985000 + EMITSTORE( ENTER(0&VARID[TOCLASS]&1[TOTYPE] 04986000 + &TYPE[TOSUBCL], PARAM[I]), TYPE); 04987000 + IF XREF THEN ENTERX(NAME,0&VARID[TOCLASS]&TYPE[TOSUBCL]); 04987100 + END; 04988000 + PARMLINK ~ NEXTINFO-3; 04989000 + GETALL(LINK, INFA, XTA, INFC); 04990000 + FILETOG ~ FALSE; 04991000 + SCAN; 04992000 + IF (TYPE~(INFA~GET(LINK)).SUBCLASS)=LOGTYPE OR TYPE=COMPTYPE OR04993000 + (I~EXPR(TRUE))=LOGTYPE OR I=COMPTYPE THEN 04993500 + BEGIN IF I!TYPE THEN FLAG(139); GO TIX END ; 04993510 + IF TYPE=REALTYPE OR TYPE=INTYPE THEN 04993530 + BEGIN 04993540 + IF I=DOUBTYPE THEN BEGIN EMITO(XCH); EMITO(DEL) END; 04993550 + IF TYPE=INTYPE THEN IF I!INTYPE THEN EMITPAIR(1,IDV) ; 04993560 + GO TIX ; 04993570 + END ; 04993580 + IF I!DOUBTYPE THEN EMITPAIR(0,XCH) ; 04993590 +TIX: 04993595 + EMITOPDCLIT(RETURN) ; 04994000 + EMITO(GFW); 04995000 + FIXB(SAVEBRAD); 04996000 + IF INFA.CLASS ! UNKNOWN THEN FLAG(140); 04997000 + PUT(LINK, -INFA & 1[TOTYPE] & NSEG[TOSEGNO] 04998000 + & STMTFUNID[TOCLASS] & BEGINSUB[TOADDR]); 04999000 + PUT(LINK+2, -(0 & NPARMS[TONEXTRA] & ADR[TOBASE] 05000000 + & PARMLINK[36:36:12])); 05001000 + PARMLINK ~ PARMLINK+4; 05002000 + FOR I ~ 1 STEP 1 UNTIL NPARMS DO 05003000 + PUT(PARMLINK ~ PARMLINK-3, "......"); 05004000 + XIT: 05005000 + FILETOG ~ FALSE; 05006000 +END STMTFUN; 05007000 +PROCEDURE ASSIGNMENT; 05008000 +BEGIN 05009000 + LABEL XIT; 05010000 +BOOLEAN CHCK; 05010500 +BOOLEAN I; 05010600 +IF DEBUGTOG THEN FLAGROUTINE(" ASSIG","NMENT ",TRUE ) ; 05011000 + FX1 ~ FNEXT; 05012000 + SCAN; 05013000 + IF NEXT = LPAREN THEN 05014000 + BEGIN 05015000 +CHCK~TRUE; 05015500 + IF GET(FX1).CLASS = UNKNOWN THEN 05016000 + IF EODS THEN 05017000 + BEGIN XTA ~ GET(FX1+1); FLOG(035) ; 05017010 + PUT(FX1,GET(FX1) & ARRAYID[TOCLASS]) ; 05017020 + PUT(FX1+2,GET(FX1+2) & 1[TONEXTRA]) ; 05017030 + END 05017040 + ELSE BEGIN STMTFUN(FX1); GO TO XIT END ; 05017050 + IF XREF THEN ENTERX(GET(FX1+1),1&GET(FX1) [15:15:9]); 05017055 + EODS ~ TRUE ; 05017060 + EXECUTABLE; 05017100 + SCAN; 05018000 + I ~ SUBSCRIPTS(FX1,2); 05019000 + SCAN; 05020000 + END ELSE 05021000 + BEGIN 05022000 + EODS~TRUE ; 05022010 + EXECUTABLE; 05022100 + IF T ~ GET(FX1).CLASS = ARRAYID THEN 05023000 + BEGIN XTA ~ GET(FX1+1); FLAG(74) END; 05024000 + MOVEW(ACCUM[1],HOLDID[0],0,3); 05025000 + IF XREF THEN IF HOLDID[0].[12:12] ! "DO" THEN 05025100 + ENTERX(GET(FX1+1),1&GET(FX1)[21:21:3]&VARID[TOCLASS]); 05025200 + END; 05026000 + IF NEXT ! EQUAL THEN BEGIN FLAG(104); GO TO XIT END; 05027000 + SCAN; 05028000 + IF NEXT=SEMI OR NEXT=COMMA THEN BEGIN FLOG(0); GO TO XIT; END; 05028010 + FX2 ~ EXPR(TRUE); 05029000 + IF NEXT NEQ COMMA THEN IF HOLDID[0] = "DO" THEN IF XREF THEN 05029200 + ENTERX(HOLDID[0] ,1&GET(FX1)[21:21:3]&VARID[TOCLASS]); 05029400 + IF NEXT = COMMA THEN IF CHCK THEN FLOG(56) ELSE 05030000 + IF HOLDID[0].[12:12] ! "DO" THEN FLOG(56) ELSE 05030100 + BEGIN 05031000 + IF LOGIFTOG THEN FLAG(101); 05032000 + IF FX2 > REALTYPE THEN FLAG(102); 05033000 + IF DT ~ DT+1 > MAXDOS THEN BEGIN DT ~ 1; FLAG(138) END; 05034000 + EMITN(FX1~ CHECKDO); 05035000 + EMITO(STD); 05036000 + SCAN; 05037000 + IF NEXT=SEMI THEN BEGIN FLAG(36); GO TO XIT END; 05038000 + IF (ACCUM[0] = ", " OR ACCUM[0] = "; ") AND 05038900 + GLOBALNEXT=NUM AND ABS(FNEXT) > 1023 THEN 05039000 + BEGIN 05040000 + IF EXPR(TRUE) > REALTYPE THEN FLAG(102); 05041000 + IDINFO:=REALID;FNEXT:=ENTER(IDINFO,"2FNV00"&DT[36:36:12]);05041100 + EMITN(FNEXT:=GETSPACE(FNEXT)); EMITO(STD); 05041200 + EMITB(-1,FALSE); LADR1:=LAX; ADJUST; 05041300 + LADR2 ~ (ADR+1) & NSEG[TOSEGNO]; EMITV(FNEXT); 05041400 + END 05041450 + ELSE BEGIN 05041500 + EMITB(-1,FALSE); LADR1:=LAX; ADJUST; 05041600 + LADR2:=(ADR+1)&NSEG[TOSEGNO]; 05041700 + IF EXPR(TRUE) > REALTYPE THEN FLAG(102) ; 05041800 + END ; 05042000 + EMITO(GRTR); 05043000 + EMITB(-1, TRUE); 05044000 + LADR3 ~ LAX; 05045000 + EMITB(-1, FALSE); 05046000 + ADJUST; 05047000 + DOTEST[DT] ~ (ADR+1) & LAX[TOADDR] & NSEG[TOSEGNO]; 05048000 + IF NEXT ! COMMA THEN EMITL(1) ELSE 05049000 + BEGIN 05050000 + SCAN; 05051000 + IF NEXT=SEMI THEN BEGIN FLAG(36); GO TO XIT END ; 05051100 + IF EXPR(TRUE) > REALTYPE THEN FLAG(102); 05052000 + END; 05053000 + EMITV(FX1); 05054000 + EMITO(ADD); 05055000 + EMITN(FX1); 05056000 + EMITO(STN); 05057000 + EMITB(LADR2, FALSE); 05058000 + FIXB(LADR1); 05059000 + FIXB(LADR3); 05060000 + END ELSE EMITSTORE(FX1, FX2); 05061000 + XIT: 05062000 +IF DEBUGTOG THEN FLAGROUTINE(" ASSIG","NMENT ",FALSE ) ; 05062010 +END ASSIGNMENT; 05063000 +BOOLEAN PROCEDURE RINGCHECK; 05063100 +COMMENT THIS PROCEDURE PREVENTS THE POSSIBILITY OF DELINKING A 05063110 + HEADER FROM THE HEADER RING; 05063120 + BEGIN 05063200 + INTEGER I; 05063250 + I~A; 05063300 + DO 05063350 + IF I ~ GETC(I).ADDR = ROOT THEN RINGCHECK ~ TRUE 05063400 + UNTIL I = A; 05063450 + END RINGCHECK; 05063500 +PROCEDURE SETLINK(INFADDR); VALUE INFADDR; INTEGER INFADDR; 05063600 +COMMENT THIS PROCEDURE LINKS AN ELEMENT TO ITS PREVIOUS HEADER; 05063601 +BEGIN 05063610 + INTEGER LAST,I; REAL COML; LABEL XIT; 05063620 +XIT: 05063625 + LAST ~(GETC(INFADDR).LASTC)-1; 05063630 + FOR I ~ INFADDR+2 STEP 1 UNTIL LAST 05063640 + DO BEGIN IF GETC(I).CLASS = ENDCOM THEN I~GETC(I).LINK; 05063650 + IF FX1 = (COML~GETC(I)).LINK THEN 05063660 + IF INFADDR~COML.LASTC=A THEN COM[PWI].LASTC~ROOT 05063670 + ELSE GO XIT ; 05063680 + END; 05063710 +END SETLINK; 05063730 +PROCEDURE DIMENSION; 05064000 +BEGIN 05065000 + LABEL L, LOOP, ERROR ; 05066000 + BOOLEAN DOUBLED, SINGLETOG; %109-05066005 +IF DEBUGTOG THEN FLAGROUTINE(" DIMEN","SION ",TRUE ) ; 05066010 + IF LOGIFTOG THEN FLAG(101); 05067000 + LABL ~ BLANKS; 05067100 + IF NEXT=STAR THEN IF TYPE!DOUBTYPE THEN 05067210 + BEGIN 05067220 + SCAN ; 05067230 + IF NEXT=NUM AND NUMTYPE=INTYPE THEN 05067240 + BEGIN 05067250 + IF FNEXT=4 THEN 05067260 + BEGIN 05067270 + SINGLETOG ~ TRUE; %109-05067275 + IF TYPE=COMPTYPE THEN FLAG(176); GO L ; 05067280 + END ; 05067290 + IF FNEXT=8 THEN 05067300 + BEGIN 05067310 + IF TYPE=REALTYPE THEN TYPE~DOUBTYPE 05067320 + ELSE IF TYPE!COMPTYPE THEN FLAG(177) ; 05067330 + GO L ; 05067340 + END ; 05067350 + END ; 05067360 + FLAG(IF TYPE=REALTYPE THEN 178 05067370 + ELSE 177-REAL(TYPE=COMPTYPE)) ; 05067380 +L: NCR~REAL(NCR.[30:3]!0)+3"677777"+NCR; SCN~1; SCAN ; 05067390 + END ; 05067420 + LOOP: DOUBLED~FALSE; 05068000 + IF NEXT ! ID THEN BEGIN FLOG(105); GO TO ERROR END; 05068100 + FX1 ~ IF SINGLETOG THEN -FNEXT ELSE FNEXT; %109-05069000 + IF TYPE } DOUBTYPE THEN % FIX ARRAY TYPE OFR 05069100 + PUT(FX1,GET(FX1)&TYPE[TOSUBCL]); % BOUNDS ROUTINE 05069200 + IF XREF THEN BEGIN INFA ~ 0&GET(FX1)[15:15:9]; 05069300 + IF TYPE>0 THEN INFA.SUBCLASS~TYPE; 05069400 + END; 05069500 + XTA ~ INFB ~ NAME; 05070000 + SCAN; 05071000 + IF XREF THEN 05071100 + BEGIN IF INFA.CLASS = UNKNOWN THEN 05071200 + INFA.CLASS~IF NEXT=LPAREN THEN ARRAYID ELSE VARID; 05071300 + ENTERX(INFB,INFA); 05071400 + END; 05071500 + IF NEXT=LPAREN THEN BEGIN SCAN; DOUBLED~BOUNDS(FX1) END ELSE 05072000 + IF TYPE = -1 THEN FLOG(103); 05073000 + GETALL(FX1, INFA, XTA, INFC); 05074000 + IF TYPE > 0 THEN 05075000 + IF BOOLEAN(INFA.TYPEFIXED) THEN FLAG(31) ELSE 05076000 + BEGIN 05077000 + IF TYPE > LOGTYPE THEN 05078000 + IF GET(FX1+2) <0 THEN 05078200 + BEGIN 05078400 + IF NOT DOUBLED AND INFA.CLASS=1 THEN 05078500 + BEGIN 05078800 + BUMPLOCALS; 05079000 + LENGTH~LOCALS + 1536; 05079200 + PUT(FX1+2,INFC & LENGTH[TOSIZE]); 05079400 + END 05079600 + END ELSE IF NOT DOUBLED THEN 05079800 + BEGIN IF INFC.SIZE > 16383 THEN FLAG(99); 05079900 + PUT(FX1+2,INFC & (2 | INFC.SIZE)[TOSIZE]); 05080000 + END; 05080100 + PUT (FX1,INFA & 1[TOTYPE] & TYPE[TOSUBCL]); 05080500 + END; 05081000 + IF INFA < 0 THEN FLAG(39) ELSE 05082000 + IF TYPE = -2 THEN 05083000 + BEGIN 05084000 + BAPC(INFA&FX1[TOLINK]&1[TOCE]&ROOT[TOLASTC]); 05085000 + IF BOOLEAN(INFA.CE) THEN FLAG(2); 05086000 + IF BOOLEAN(INFA.EQ) THEN 05086100 + BEGIN 05087000 + COM[NEXTCOM.IR,NEXTCOM.IC].LASTC ~ A ~ INFA.ADDR; 05088000 + B~GETC(ROOT).ADDR ; 05089000 + SETLINK(A); 05089050 + IF NOT RINGCHECK THEN 05089100 + BEGIN 05089200 + COM[PWROOT].ADDR~GETC(A).ADDR ; 05090000 + PUTC(A,GETC(A)&B[TOADDR]&7[TOSUBCL]) ; 05091000 + END 05091100 + END ELSE 05092000 + PUT(FX1, INFA & 1[TOCE] & ROOT[TOADDR]); 05093000 + IF BOOLEAN(INFA.FORMAL) THEN FLAG(10); 05094000 + END; 05095000 + IF ERRORTOG THEN 05096000 + ERROR: 05096100 + WHILE NEXT ! COMMA AND NEXT ! SEMI AND NEXT ! SLASH DO SCAN; 05097000 + IF NEXT = COMMA THEN BEGIN SCAN; GO TO LOOP END; 05098000 +IF DEBUGTOG THEN FLAGROUTINE(" DIMEN","SION ",FALSE ); 05098010 +END DIMENSION; 05099000 +PROCEDURE FORMALPP(PARMSREQ, CLASS); VALUE PARMSREQ, CLASS; 05100000 + BOOLEAN PARMSREQ; REAL CLASS; 05101000 +BEGIN 05102000 + LABEL LOOP, XIT; 05103000 +IF DEBUGTOG THEN FLAGROUTINE(" FORM","ALPP ",TRUE ) ; 05103010 + PARMS ~ 0; 05104000 + SCAN; 05105000 + IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; 05106000 + IF CLASS = FUNID THEN 05106100 + IF FUNVAR = 0 THEN 05107000 + BEGIN 05107020 + IF TYPE > 0 THEN 05107030 + IF FUNVAR ~ GLOBALSEARCH(NAME) ! 0 THEN 05107040 + IF BOOLEAN((T ~ GET(FUNVAR)).TYPEFIXED) AND TYPE ! T.SUBCLASS 05107050 + THEN FLAG(31); 05107060 + PUT(FUNVAR ~ FNEXT,GET(FNEXT) & VARID[TOCLASS]); 05107100 + END; 05107160 + FNEW ~ NEED(NNEW ~ NAME, CLASS); 05108000 + ENTERX(NAME,IF CLASS = FUNID THEN 05108100 + 1&GET(FNEW)[15:15:9] ELSE 1&GET(FNEW)[15:15:5]); 05108200 + SCAN; 05109000 + IF NEXT ! LPAREN THEN 05110000 + IF PARMSREQ THEN FLOG(106) ELSE ELSE 05111000 + BEGIN 05112000 + LOOP: 05113000 + SCAN; 05114000 + IF NEXT = ID THEN PARMLINK[PARMS ~ PARMS+1] ~ FNEXT ELSE 05115000 + IF NEXT=STAR AND CLASS!FUNID THEN PARMLINK[PARMS~PARMS+1]~0ELSE05116000 + FLOG(107); 05117000 + IF XREF THEN ENTERX(NAME,IF NEXT = STAR THEN 0 ELSE 05117100 + 0&GET(FNEXT)[15:15:9]); 05117150 + SCAN; 05118000 + IF NEXT = COMMA THEN GO TO LOOP; 05119000 + IF NEXT ! RPAREN THEN FLOG(108); 05120000 + SCAN; 05121000 + END; 05122000 + IF NOT ERRORTOG THEN DECLAREPARMS(FNEW); 05123000 + XIT: 05124000 +IF DEBUGTOG THEN FLAGROUTINE(" FORM","ALPP ",FALSE) ; 05124010 +END FORMALPP; 05125000 +PROCEDURE ENDS; FORWARD; 05125100 +PROCEDURE FUNCTION ; 05126000 +BEGIN 05127000 + REAL A,B,C,I; LABEL FOUND ; 05127100 + IF SPLINK NEQ 0 THEN BEGIN FLAG(5); ENDS; SEGMENTSTART; END; 05128000 + LABL ~ BLANKS; 05128100 + FORMALPP(TRUE, FUNID); 05129000 + GETALL(FNEW, INFA, INFB, INFC); 05130000 + B~NUMINTM1 ; 05130100 + WHILE A+1SUPERMAXCOM THEN 05185000 + BEGIN ROOT~0; FATAL(124) END 05186000 + ELSE ROOT~NEXTCOM ; 05186100 + PUTC(ROOT,0&HEADER[TOCLASS]&1[TOCE]&ROOT[TOADDR]) ; 05186200 + BAPC(Z); 05187000 + END ELSE 05188000 + BEGIN 05189000 + ROOT ~ T.ADINFO; 05190000 + COM[(T~GETC(ROOT).LASTC).IR,T.IC].LINK~NEXTCOM+1 ; 05191000 + IF COM[PWROOT]<0 THEN FLAG(2) ; 05191100 + END; 05192000 + DIMENSION; 05193000 + BAPC(0&ENDCOM[TOCLASS]) ; 05194000 + COM[PWROOT].LASTC~NEXTCOM ; 05195000 + PUT(T~GETC(ROOT+1)+2,GET(T)&ROOT[TOADINFO]) ; 05196000 + IF NEXT ! SEMI THEN GO TO LOOP; 05197000 +END COMMON; 05198000 +PROCEDURE ENDS; 05211000 +BEGIN 05212000 + IF SPLINK=0 THEN FLAG(184) ELSE %112-05212005 + BEGIN %112-05212007 + EODS~FALSE ; 05212010 + IF LOGIFTOG THEN FLAG(101); 05213000 + LABL ~ BLANKS; 05213100 + IF SPLINK < 0 THEN EMITO(XIT) ELSE EMITPAIR(0, KOM); 05214000 + SEGMENT((ADR+4) DIV 4, NSEG, TRUE, EDOC); 05215000 + END; %112-05216000 +END ENDS; 05217000 +PROCEDURE ENTRY; 05218000 +BEGIN 05219000 + REAL SP; 05220000 + IF SPLINK = 0 THEN FLAG(111) ELSE 05221000 + IF SPLINK = 1 THEN BEGIN ELX ~ 0; FLAG(4) END; 05222000 + LABL ~ BLANKS; 05222100 + ADJUST ; 05222500 + SP ~ GET(SPLINK); 05223000 + FORMALPP( (T~SP.CLASS) = FUNID, T); 05224000 + GETALL(FNEW, INFA, INFB, INFC); 05225000 + IF INFA.CLASS = FUNID THEN 05226000 + PUT(FNEW, INFA & 1[TOTYPE] & (SP.SUBCLASS)[TOSUBCL]); 05227000 + PUT(FNEW+2, INFC & (ADR+1)[TOBASE]); 05228000 +END ENTRY; 05229000 +PROCEDURE EQUIVALENCE; 05230000 +COMMENT THIS PROCEDURE MAKES THE COM ENTRY FOR EQUIV ITEMS AND SETS 05230100 + THE EQ BIT IN BOTH THE COM AND INFO TABLES AND LINKS 05230110 + THE HEADS OF CHAINS; 05230120 +BEGIN 05231000 + REAL P, Q, R, S; 05232000 + BOOLEAN FIRST,PCOMM; 05232050 + LABEL XIT; 05232100 + IF LOGIFTOG THEN FLAG(101); 05233000 + LABL ~ BLANKS; 05233100 + DO 05234000 + BEGIN 05235000 + FIRST ~ FALSE; 05235500 + SCAN; 05236000 + IF NEXT ! LPAREN THEN BEGIN FLOG(106); GO TO XIT END; 05237000 + IF NEXTCOM~NEXTCOM+1>SUPERMAXCOM THEN 05238000 + BEGIN ROOT~0; FATAL(124) END 05238100 + ELSE ROOT~NEXTCOM ; 05238200 + PUTC(ROOT,0&HEADER[TOCLASS]&ROOT[TOADDR]) ; 05238300 + BAPC(0); Q~0 ; 05239000 + DO 05240000 + BEGIN 05241000 + SCAN; 05242000 + IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; 05243000 + IF XREF THEN ENTERX(NAME,0&GET(FNEXT)[15:15:9]); 05243200 + FX1 ~ FNEXT; 05244000 + LENGTH ~ 0; 05245000 + SCAN; 05246000 + IF NEXT = LPAREN THEN 05247000 + BEGIN 05248000 + IF GET(FX1).CLASS ! ARRAYID THEN 05249000 + BEGIN XTA ~ GET(FX1+1); FLOG(112) END; 05250000 + R ~ 0; P ~ 1; 05251000 + S ~ GET(FX1+2).ADINFO; 05252000 + DO 05253000 + BEGIN 05254000 + SCAN; 05255000 + IF NEXT ! NUM OR NUMTYPE ! INTYPE THEN FLAG(113); 05256000 + LENGTH ~ LENGTH + P|(FNEXT-1); 05257000 + P ~ P|EXTRAINFO[(S+R).IR,(S+R).IC] ; 05258000 + R ~ R-1; 05259000 + SCAN; 05260000 + END UNTIL NEXT ! COMMA; 05261000 + IF NEXT ! RPAREN THEN BEGIN FLOG(108); GO TO XIT END; 05262000 + IF R!-1 THEN IF R~R+GET(FX1+2).NEXTRA!0 THEN 05262200 + BEGIN XTA~GET(FX1+1); FLAG(IF R>0 THEN 23 ELSE 24) END ; 05262300 + SCAN; 05263000 + END; 05264000 + IF (INFA~GET(FX1)) < 0 THEN 05265000 + BEGIN XTA ~ GET(FX1+1); FLAG(39) END ELSE 05266000 + BEGIN 05267000 + IF INFA.SUBCLASS > LOGTYPE THEN LENGTH ~ 2|LENGTH ; 05267100 + BAPC(INFA&FX1[TOLINK]&LENGTH[TORELADD]&1[TOEQ]&ROOT[TOLASTC]); 05268000 + IF(PCOMM~BOOLEAN(INFA.CE)) OR BOOLEAN(INFA.EQ) THEN 05269000 + BEGIN 05270000 + IF FIRST AND PCOMM THEN BEGIN XTA~GET(FX1+1); FLAG(2) END 05270100 + ELSE IF NOT FIRST THEN FIRST ~ PCOMM; 05270200 + PUT(FX1,INFA & 1[TOEQ]); 05270500 + COM[NEXTCOM.IR,NEXTCOM.IC].LASTC ~ A ~ INFA.ADDR; 05271000 + B~GETC(ROOT).ADDR ; 05272000 + SETLINK(A); 05272050 + IF NOT RINGCHECK THEN 05272100 + BEGIN 05272200 + COM[PWROOT].ADDR~GETC(A).ADDR ; 05273000 + PUTC(A,GETC(A)&B[TOADDR]&7[TOSUBCL]) ; 05274000 + END 05274200 + END ELSE 05275000 + PUT(FX1,INFA & 1[TOEQ] & ROOT[TOADDR]); 05276000 + IF LENGTH > Q THEN Q ~ LENGTH; 05277000 + IF BOOLEAN(INFA.FORMAL) THEN 05278000 + BEGIN XTA ~ GET(FX1+1); FLAG(11) END; 05279000 + END; 05280000 + END UNTIL NEXT ! COMMA; 05281000 + IF NEXT ! RPAREN THEN BEGIN FLOG(108); GO TO XIT END; 05282000 + SCAN; 05283000 + PUTC(ROOT+1,Q); 05284000 + BAPC(0&ENDCOM[TOCLASS]) ; 05285000 + COM[PWROOT].LASTC~NEXTCOM ; 05286000 + END UNTIL NEXT ! COMMA; 05287000 + XIT: 05287100 +END EQUIVALENCE; 05288000 +PROCEDURE EXTERNAL; 05289000 +BEGIN 05290000 + IF SPLINK < 0 THEN FLAG( 12); 05291000 + IF LOGIFTOG THEN FLAG(101); 05292000 + LABL ~ BLANKS; 05292100 + DO 05293000 + BEGIN 05294000 + SCAN; 05295000 + IF NEXT ! ID THEN FLOG(105) ELSE 05296000 + BEGIN T ~ NEED(NAME,EXTID); 05297000 + IF XREF THEN ENTERX(NAME,0&GET(T)[15:15:9]); 05297300 + SCAN; 05297500 + END; 05297800 + 05298000 + END UNTIL NEXT ! COMMA; 05299000 +END EXTERNAL; 05300000 +PROCEDURE CHAIN; 05300100 +BEGIN 05300150 + LABEL AGN, XIT; 05300160 + REAL T1; 05300170 + DEFINE FLG(FLG1) = BEGIN FLOG(FLG1); GO TO XIT END#; 05300180 + EXECUTABLE; 05300182 + SCAN; 05300184 + T1 ~ 2; 05300190 + IF FALSE THEN 05300210 + AGN: IF GLOBALNEXT ! COMMA THEN FLG(28); 05300220 + SCAN; 05300230 + IF EXPR(TRUE) > REALTYPE THEN FLG(102); 05300240 + IF (T1 ~ T1 - 1) ! 0 THEN GO TO AGN; 05300250 + IF GLOBALNEXT ! RPAREN THEN FLG(3); 05300260 + EMITPAIR(37,KOM); 05300270 + SCAN; 05300280 + IF GLOBALNEXT ! SEMI THEN FLOG(117); 05300290 + XIT: WHILE GLOBALNEXT ! SEMI DO SCAN; 05300300 +END CHAIN; 05300310 +PROCEDURE GOTOS; 05301000 +BEGIN LABEL XIT; 05302000 + REAL ASSIGNEDID; 05302100 + EODS~TRUE ; 05302110 + EXECUTABLE; 05303000 + SCAN; 05304000 + IF NEXT = NUM THEN 05305000 + BEGIN 05306000 + LABELBRANCH(NAME, FALSE); 05307000 + SCAN; 05308000 + GO TO XIT; 05309000 + END; 05310000 + IF NEXT = ID THEN 05311000 + BEGIN 05312000 + ASSIGNEDID ~ FNEXT; 05313000 + IF XREF THEN ENTERX(XTA,0&GET(FNEXT)[15:15:9]); 05313200 + SCAN; 05313300 + IF NEXT ! COMMA THEN FLOG(114); 05313600 + SCAN; 05314000 + IF NEXT ! LPAREN THEN FLOG(106); 05314300 + DO 05314600 + BEGIN 05315000 + SCAN; 05315300 + IF NEXT ! NUM THEN FLOG(109); 05315600 + EMITV(ASSIGNEDID); 05316000 + EMITNUM(FNEXT); 05316300 + EMITO(NEQL); 05316600 + LABELBRANCH(NAME, TRUE); 05317000 + SCAN; 05317300 + END UNTIL NEXT ! COMMA; 05317600 + IF NEXT ! RPAREN THEN FLOG(108); 05318000 + SCAN; 05318200 + EMITPAIR(1, SSN); % CAUSE INVALID INDEX TERMINATION 05318400 + EMITDESCLIT(10); 05318600 + GO TO XIT; 05319000 + END; 05320000 + IF NEXT ! LPAREN THEN FLOG(106); 05321000 + P ~ 0; 05322000 + DO 05323000 + BEGIN 05324000 + SCAN; 05325000 + IF NEXT ! NUM THEN BEGIN FLOG(109); GO TO XIT END; 05326000 + LSTT[P~P+1] ~ NAME; 05327000 + SCAN; 05328000 + END UNTIL NEXT ! COMMA; 05329000 + IF NEXT ! RPAREN THEN BEGIN FLOG(108); GO TO XIT END; 05330000 + SCAN; 05331000 + IF NEXT ! COMMA THEN BEGIN FLOG(114); GO TO XIT END; 05332000 + SCAN; 05333000 + IT ~ P+1; % DONT LET EXPR WIPE OUT LSTT 05334000 + IF EXPR(TRUE) > REALTYPE THEN FLOG(102); 05335000 + EMITPAIR(JUNK, ISN); 05336000 + EMITPAIR(1,LESS); 05337000 + EMITOPDCLIT(JUNK); 05338000 + EMITPAIR(P,GRTR); 05339000 + EMITO(LOR); 05340000 + EMITOPDCLIT(JUNK); 05341000 + EMITL(3); 05342000 + EMITO(MUL); 05343000 + 05344000 + IF ADR+3|P > 4085 THEN BEGIN ADR~ADR+1; SEGOVF END; 05345000 + EMITO(BFC); 05346000 + EMITPAIR(1, SSN); 05347000 + EMITDESCLIT(10); 05348000 + FOR I ~ 1 STEP 1 UNTIL P DO 05349000 + BEGIN 05349100 + J ~ ADR; LABELBRANCH(LSTT[I], FALSE); 05349200 + IF ADR-J = 2 THEN EMITO(NOP); 05349300 + END; 05349400 + XIT: 05350000 + IT ~ 0; 05351000 +END GOTOS; 05352000 +PROCEDURE IFS; 05353000 +BEGIN REAL TYPE, LOGIFADR, SAVELABL; 05354000 + EODS~TRUE; 05354010 + EXECUTABLE; 05355000 + SCAN; 05356000 + IF NEXT ! LPAREN THEN FLOG(106); 05357000 + SCAN; 05358000 + IF TYPE ~ EXPR(TRUE) = COMPTYPE THEN FLAG(89); 05359000 + IF NEXT ! RPAREN THEN FLOG(108); 05360000 + IF TYPE = LOGTYPE THEN 05361000 + BEGIN 05362000 + EMITB(-1, TRUE); 05363000 + LOGIFADR ~ LAX; 05364000 + LOGIFTOG ~ TRUE; EOSTOG ~ TRUE; 05365000 + SAVELABL ~ LABL; LABL ~ BLANKS; 05365100 + STATEMENT; 05366000 + LABL ~ SAVELABL; 05366100 + LOGIFTOG ~ FALSE; EOSTOG ~ FALSE; 05367000 + FIXB(LOGIFADR); 05368000 + END ELSE 05369000 + BEGIN 05370000 + IF TYPE = DOUBTYPE THEN 05371000 + BEGIN EMITO(XCH); EMITO(DEL) END; 05372000 + SCAN; 05373000 + IF NEXT ! NUM THEN FLOG(109); 05374000 + FX1 ~ FNEXT; NX1 ~ NAME; 05375000 + SCAN; 05376000 + IF NEXT ! COMMA THEN FLOG(114); 05377000 + SCAN; 05378000 + IF NEXT ! NUM THEN FLOG(109); 05379000 + FX2 ~ FNEXT; NX2 ~ NAME; 05380000 + SCAN; 05381000 + IF NEXT ! COMMA THEN FLOG(114); 05382000 + SCAN; 05383000 + IF NEXT ! NUM THEN FLOG(109); 05384000 + FX3 ~ FNEXT; NX3 ~ NAME; 05385000 + SCAN; 05386000 + IF FX2 = FX3 THEN 05387000 + BEGIN 05388000 + EMITPAIR(0,GEQL); 05389000 + LABELBRANCH(NX1, TRUE); 05390000 + LABELBRANCH(NX3, FALSE); 05391000 + IF XREF THEN ENTERX(NX2,0&LABELID[TOCLASS]); 05391200 + END ELSE 05392000 + IF FX1 = FX3 THEN 05393000 + BEGIN 05394000 + EMITPAIR(0,NEQL); 05395000 + LABELBRANCH(NX2, TRUE); 05396000 + LABELBRANCH(NX1, FALSE); 05397000 + IF XREF THEN ENTERX(NX3,0&LABELID[TOCLASS]); 05397200 + END ELSE 05398000 + IF FX1 = FX2 THEN 05399000 + BEGIN 05400000 + EMITPAIR(0,LEQL); 05401000 + LABELBRANCH(NX3, TRUE); 05402000 + LABELBRANCH(NX1, FALSE); 05403000 + IF XREF THEN ENTERX(NX2,0&LABELID[TOCLASS]); 05403200 + END ELSE 05404000 + BEGIN 05405000 + EMITO(DUP); 05406000 + EMITPAIR(0,NEQL); 05407000 + EMITB(-1,TRUE); 05408000 + EMITPAIR(0,LESS); 05409000 + LABELBRANCH(NX3, TRUE); 05410000 + LABELBRANCH(NX1, FALSE); 05411000 + FIXB(LAX); 05412000 + EMITO(DEL); 05413000 + LABELBRANCH(NX2, FALSE); 05414000 + END; 05415000 + END; 05416000 +END IFS; 05417000 +PROCEDURE NAMEL; 05430000 +BEGIN LABEL NIM,XIT,ELMNT,WRAP; 05431000 + IF SPLINK < 0 THEN FLAG(12); 05432000 + IF LOGIFTOG THEN FLAG(101); 05433000 + LABL ~ BLANKS; 05433100 + SCAN; IF NEXT ! SLASH THEN FLOG(110); 05434000 +NIM: SCAN; IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; 05435000 + IF J ~ (INFA ~ GET(LADR2 ~ FNEXT)).CLASS = UNKNOWN THEN 05436000 + PUT(LADR2,INFA&NAMELIST[TOCLASS]) 05437000 + ELSE IF J ! NAMELIST THEN 05438000 + BEGIN XTA ~ GET(LADR2 + 1); 05439000 + FLAG(20); 05440000 + END; 05441000 + LSTT[LSTS ~ LADR1 ~ 0] ~ NAME; 05442000 + IF XREF THEN ENTERX(NAME,0&NAMELIST[TOCLASS]); 05442500 + SCAN; IF NEXT ! SLASH THEN FLOG(110); 05443000 +ELMNT: SCAN; IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; 05444000 + LADR1 ~ LADR1 + 1; 05445000 + IF (T ~ GET(FNEW ~ GETSPACE(FNEXT)).CLASS) > VARID THEN FLAG(48); 05446000 + GETALL(FNEW,INFA,INFB,INFC); 05447000 + IF XREF THEN ENTERX(INFB,0&INFA[15:15:9]); 05447500 + IF LSTS ~ LSTS+1 = LSTMAX THEN BEGIN FLOG(78); GO TO XIT END ELSE 05448000 + LSTT[LSTS] ~ NAME&INFA.CLASNSUB[2:38:10]&0[8:47:1]; 05448500 + IF T = ARRAYID THEN 05449000 + BEGIN J ~ INFC.ADINFO; 05450000 + I ~ INFC.NEXTRA; 05451000 + IF LSTS + I + 1 > LSTMAX THEN 05451100 + BEGIN FLOG(78); GO TO XIT END; 05451200 + LSTT[LSTS ~ LSTS + 1] ~ 0&I[1:42:6] % # DIMENSIONS 05452000 + &INFA.ADDR[7:37:11] % REL ADR 05453000 + &INFC.BASE[18:33:15] % BASE 05454000 + &INFC.SIZE[33:33:15]; % SIZE 05455000 + FOR T ~ J STEP -1 UNTIL J - I + 1 DO 05456000 + LSTT[LSTS ~ LSTS + 1] ~ EXTRAINFO[T.IR,T.IC]; 05457000 + END ELSE BEGIN LSTT[LSTS~LSTS+1]~0&(INFA.ADDR)[7:37:11]; 05458000 + IF BOOLEAN(INFA.CE) THEN LSTT[LSTS]~LSTT[LSTS]&INFC.BASE[18:33:15]05458400 + &INFC.SIZE[33:33:15] END; 05458600 + SCAN; IF NEXT = COMMA THEN GO TO ELMNT; 05459000 + IF NEXT ! SEMI AND NEXT ! SLASH THEN FLOG(115); 05460000 + LSTT[LSTS + 1] ~ 0; 05461000 + LSTT[0].[2:10] ~ LADR1; 05462000 + PRTSAVER(LADR2,LSTS + 2,LSTT); 05463000 + IF NEXT ! SEMI THEN GO TO NIM; 05464000 +XIT: 05465000 +END NAMEL; 05466000 +PROCEDURE PAUSE; 05467000 +IF DCINPUT THEN BEGIN XTA~"PAUSE "; FLOG(151) END ELSE 05467100 +BEGIN 05468000 + EODS~TRUE ; 05468010 + IF TSSEDITOG THEN TSSED("PAUSE ",2) ; 05468100 + EXECUTABLE; 05469000 + SCAN; 05470000 + IF NEXT = SEMI THEN EMITL(0) ELSE 05471000 + IF NEXT = NUM THEN 05472000 + BEGIN 05473000 + EMITNUM(NAME); 05474000 + SCAN; 05475000 + END; 05476000 + EMITPAIR(33, KOM); 05477000 + EMITO(DEL); 05477100 +END PAUSE; 05478000 +PROCEDURE TYPIT(TYP,TMPNXT); VALUE TYP; REAL TYP,TMPNXT ; 05479000 + BEGIN 05480000 + TYPE~TYP; SCAN ; 05480010 + IF NEXT=16 THEN BEGIN TMPNXT~16; FUNCTION END ELSE DIMENSION ; 05480020 + END OF TYPIT ; 05480040 +DEFINE COMPLEX =TYPIT(COMPTYPE,TEMPNEXT) #, 05481000 + LOGICAL =TYPIT(LOGTYPE ,TEMPNEXT) #, 05482000 + DOUBLEPRECISION =TYPIT(DOUBTYPE,TEMPNEXT) #, 05483000 + INTEGERS =TYPIT(INTYPE ,TEMPNEXT) #, 05484000 + REALS =TYPIT(REALTYPE,TEMPNEXT) #; 05484500 +PROCEDURE STOP; 05485000 +BEGIN 05486000 + RETURNFOUND ~ TRUE; 05486100 + EODS~TRUE; 05486110 + EXECUTABLE; 05487000 + COMMENT INITIAL SCAN ALREADY DONE; 05488000 + EMITL(1); 05489000 + EMITPAIR(16,STD); 05490000 + EMITPAIR(10, KOM); 05491000 + EMITPAIR(5, KOM); 05492000 + WHILE NEXT ! SEMI DO SCAN; 05493000 +END STOP; 05494000 +PROCEDURE RETURN; 05495000 +BEGIN LABEL EXIT; 05496000 + REAL T, XITCODE; 05497000 + RETURNFOUND ~ TRUE; 05497100 + EODS~TRUE ; 05497110 + EXECUTABLE; 05498000 + 05498100 + 05498200 + SCAN; 05499000 + IF SPLINK=0 OR SPLINK=1 THEN 05499100 + BEGIN XTA~"RETURN"; FLOG(153); GO EXIT END ; 05500000 + IF NEXT = SEMI THEN 05501000 + BEGIN 05502000 + IF (T ~ GET(SPLINK)).CLASS = FUNID THEN 05503000 + BEGIN 05504000 + EMITV(FUNVAR); 05505000 + IF T.SUBCLASS > LOGTYPE THEN EMITPAIR(JUNK, STD); 05506000 + XITCODE ~ RTN; 05507000 + END ELSE XITCODE ~ XIT; 05508000 + IF ADR } 4077 THEN 05509000 + BEGIN ADR ~ ADR+1; SEGOVF END; 05510000 + EMITOPDCLIT(1538); % F+2 05511000 + EMITPAIR(3, BFC); 05512000 + EMITPAIR(10, KOM); 05513000 + EMITO(XITCODE); 05514000 + EMITOPDCLIT(16); 05515000 + EMITPAIR(1, SUB); 05516000 + EMITPAIR(16, STD); 05517000 + EMITO(XITCODE); 05518000 + GO TO EXIT; 05519000 + END; 05520000 + IF LABELMOM = 0 THEN FLOG(145); 05520100 + IF EXPR(TRUE) > REALTYPE THEN FLAG(102); 05521000 + IF EXPRESULT = NUMCLASS THEN 05521100 + BEGIN IF XREF THEN ENTERX(EXPVALUE,0&LABELID[TOCLASS]); 05521200 + ADR ~ ADR-1;EMITL(EXPVALUE-1) 05521400 + END ELSE 05521600 + EMITPAIR(1, SUB); 05522000 + EMITOPDCLIT(LABELMOM); 05523000 + EMITO(MKS); 05524000 + EMITL(9); 05525000 + EMITOPDCLIT(5); 05526000 + 05527000 + EXIT: 05528000 +END RETURN; 05529000 +PROCEDURE IMPLICIT ; 05529100 + BEGIN 05529105 + REAL R1,R2,R3,R4 ; 05529110 + LABEL R,A,X,L ; 05529120 + IF NOT(LASTNEXT=42 OR LASTNEXT=1000 OR LASTNEXT=30 %110-05529130 + OR LASTNEXT=16 OR LASTNEXT = 11) %110-05529131 + THEN BEGIN FLOG(181); FILETOG~TRUE; GO X END ; 05529140 +R: EOSTOG~ERRORTOG~TRUE; FILETOG~FALSE ; 05529210 + MOVEW(ACCUM[3],ACCUM[2],0,3); SCAN; ERRORTOG~FALSE; FILETOG~TRUE ; 05529215 + IF R1~IF R3~NEXT=18 THEN INTID ELSE IF R3=26 THEN REALID ELSE 0& 05529220 + (IF R3=10 THEN DOUBTYPE ELSE IF R3=19 THEN LOGTYPE ELSE IF R3=05529230 + 6 THEN COMPTYPE ELSE 0)[TOSUBCL]=0 THEN 05529240 + BEGIN FLOG(182); GO X END ; 05529250 + SCN~2; SCAN ; 05529260 + IF NEXT = STAR THEN IF R3!10 THEN 05529270 + BEGIN SCAN ; 05529280 + IF NEXT=NUM AND NUMTYPE=INTYPE THEN 05529290 + BEGIN 05529300 + IF FNEXT=4 THEN BEGIN IF R3=6 THEN FLAG(176); GO L END ; 05529310 + IF FNEXT=8 THEN 05529320 + BEGIN 05529330 + IF R3=26 THEN R1~0&DOUBTYPE[TOSUBCL] 05529340 + ELSE IF R3!6 THEN FLAG(177) ; 05529350 + GO L; 05529360 + END ; 05529370 + END ; 05529380 + FLAG(IF R3=26 THEN 178 ELSE 177-REAL(R3=6)) ; 05529390 +L: NCR~REAL(NCR.[30:3]!0)+3"677777"+NCR; SCN~1; SCAN ; 05529400 + END ; 05529410 + IF NEXT!LPAREN THEN BEGIN FLOG(106); GO X END ; 05529420 +A: SCAN; R4~ERRORCT ; 05529430 + IF R2~NAME.[12:6]<17 OR (R2>25 AND R2<33) OR (R2>41 AND R2<50) 05529440 + OR R2>57 OR NAME.[18:30]!" " THEN FLAG(179) ; 05529450 + SCAN ; 05529460 + IF NEXT!MINUS THEN 05529470 + BEGIN IF ERRORCT=R4 THEN TIPE[IF R2!"0" THEN R2 ELSE 12]~R1 END05529475 + ELSE BEGIN 05529480 + SCAN ; 05529490 + IF R3~NAME.[12:6]<17 OR (R3>25 AND R3<33) OR (R3>41 AND R3<50) 05529500 + OR R3>57 OR NAME.[18:30]!" " THEN FLAG(179) ; 05529510 + IF R3 LEQ R2 THEN FLAG(180) ; 05529520 + IF ERRORCT=R4 THEN FOR R2~R2 STEP 1 UNTIL R3 DO 05529530 + BEGIN 05529540 + IF R2>25 AND R2<33 THEN R2~33 ELSE IF R2>41 AND R2<50 05529550 + THEN R2~50 ; 05529560 + TIPE[IF R2!"0" THEN R2 ELSE 12]~R1 ; 05529570 + END ; 05529580 + SCAN ; 05529590 + END ; 05529600 + IF NEXT=COMMA THEN GO A ; 05529610 + IF NEXT!RPAREN THEN BEGIN FLOG(108); GO X END ; 05529620 + SCAN; IF NEXT=COMMA THEN GO R ; 05529630 + IF NEXT!SEMI THEN BEGIN FLOG(117); GO X END ; 05529635 + IF SPLINK > 1 THEN 05529640 + BEGIN 05529650 + IF BOOLEAN(TYPE.[2:1]) THEN IF GET(SPLINK).CLASS=FUNID THEN 05529660 + BEGIN 05529670 + INFO[SPLINK.IR,SPLINK.IC].SUBCLASS~R3~TIPE[IF R3~GET( 05529680 + SPLINK+1).[12:6]!"0" THEN R3 ELSE 12].SUBCLASS ; 05529690 + INFO[FUNVAR.IR,FUNVAR.IC].SUBCLASS~R3 ; 05529700 + END ; 05529710 + IF R1~GET(SPLINK+2)<0 THEN 05529720 + FOR R2~R1.NEXTRA-1+R1~R1.ADINFO STEP -1 UNTIL R1 DO 05529730 + IF R3~PARMLINK[R2-R1+1]!0 THEN 05529740 + BEGIN 05529750 + EXTRAINFO[R2.IR,R2.IC].SUBCLASS~R4~TIPE[IF R4~ 05529760 + GET(R3+1).[12:6]!"0" THEN R4 ELSE 12] 05529770 + .SUBCLASS ; 05529780 + INFO[R3.IR,R3.IC].SUBCLASS~R4 ; 05529790 + END ; 05529800 + END ; 05529810 +X: WHILE NEXT!SEMI DO SCAN; FILETOG~FALSE ; 05529820 + END OF IMPLICIT ; 05529830 +PROCEDURE SUBROUTINE; 05530000 +BEGIN 05531000 + IF SPLINK NEQ 0 THEN BEGIN FLAG(5); ENDS; SEGMENTSTART; END; 05532000 + LABL ~ BLANKS; 05532100 + FORMALPP(FALSE, SUBRID); 05533000 + SPLINK ~ FNEW; 05534000 +END SUBROUTINE; 05535000 +PROCEDURE MEMHANDLER(N); VALUE N; REAL N ; 05535010 + BEGIN 05535020 + REAL A ; 05535030 + LABEL L1,L2,L3,XIT ; 05535040 + IF DEBUGTOG THEN FLAGROUTINE(" MEMHA","NDLER ",TRUE) ; 05535045 + IF N LEQ 2 THEN 05535050 + BEGIN % FIXED=1, VARYING=2. 05535060 + N~IF N=1 THEN 6 ELSE 0 ; 05535070 +L1: SCAN; 05535080 + IF NEXT!ID THEN BEGIN FLOG(105); GO XIT END ; 05535090 + IF (A~GET(GETSPACE(FNEXT))).CLASS!ARRAYID THEN 05535100 + BEGIN FLOG(35); GO XIT END ; 05535110 + IF XREF THEN ENTERX(XTA,0&A[15:15:9]) ; 05535120 + IF BOOLEAN(A.EQ) OR BOOLEAN(A.FORMAL) THEN FLAG(169) 05535130 + ELSE BEGIN 05535140 + EMITO(MKS); EMITPAIR(A.ADDR,LOD); EMITL(N) ; 05535150 + EMITV(NEED(".MEMHR",INTRFUNID)) ; 05535160 + END ; 05535170 + SCAN; IF NEXT=COMMA THEN GO L1 ; 05535180 + END 05535190 + ELSE IF N=3 THEN 05535200 + BEGIN % AUXMEMED FUNCTION OR SUBROUTINE. 05535210 + SCAN ; 05535220 + IF NEXT!ID THEN BEGIN FLOG(105); GO XIT END ; 05535225 + IF GET(FNEXT+1)!GET(SPLINK+1) THEN 05535230 + BEGIN FLOG(170); GO XIT END ; 05535235 + PUT(SPLINK,GET(SPLINK)&1[TOADJ]) ; 05535240 + IF XREF THEN ENTERX(XTA,0&GET(FNEXT)[15:15:9]); SCAN ; 05535250 + END 05535420 + ELSE BEGIN % RELEASE. 05535430 +L2: SCAN ; 05535440 + IF NEXT!ID THEN BEGIN FLOG(105); GO XIT END ; 05535450 + IF (A~GET(GETSPACE(FNEXT))).CLASS=ARRAYID THEN 05535460 + BEGIN 05535470 + IF BOOLEAN(A.EQ) OR BOOLEAN(A.FORMAL) THEN FLAG(169) 05535480 + ELSE BEGIN 05535490 + EMITO(MKS); EMITPAIR(A.ADDR,LOD) ; 05535500 + EMITPAIR(1,SSN) ; 05535510 + EMITV(NEED(".MEMHR",INTRFUNID)) ; 05535520 + END ; 05535530 +L3: IF XREF THEN ENTERX(XTA,0&A[15:15:9]) ; 05535540 + END 05535550 + ELSE IF A.CLASS}BLOCKID OR A.CLASS{LABELID THEN 05535560 + BEGIN FLOG(171); GO XIT END 05535570 + ELSE BEGIN 05535575 + EMITPAIR(A.ADDR,LOD); EMITPAIR(38,KOM) ; 05535580 + EMITO(DEL); GO L3 ; 05535585 + END ; 05535590 + SCAN; IF NEXT=COMMA THEN GO L2 ; 05535595 + END ; 05535600 +XIT:IF DEBUGTOG THEN FLAGROUTINE(" MEMHA","NDLER ",FALSE) ; 05535605 + END OF MEMHANDLER ; 05535610 +PROCEDURE STATEMENT; 05536000 +BEGIN LABEL DOL1, XIT; 05537000 + REAL TEMPNEXT ; 05537100 + BOOLEAN ENDTOG; %112-05537200 + DO SCAN UNTIL NEXT ! SEMI; 05538000 + IF NEXT=ID THEN ASSIGNMENT ELSE IF NEXT LEQ RSH1 THEN 05539000 + CASE(TEMPNEXT~NEXT) OF 05540000 + BEGIN 05541000 + FLOG(16); 05542000 + ASSIGN; 05543000 + IOCOMMAND(4); %BACKSPACE 05544000 + BLOCKDATA; 05545000 + CALL; 05546000 + COMMON; 05547000 + COMPLEX; 05548000 + BEGIN EXECUTABLE; SCAN END; % CONTINUE 05549000 + IOCOMMAND(7); % DATA 05550000 + BEGIN SCAN; TYPE ~ -1; DIMENSION END; 05551000 + DOUBLEPRECISION; 05552000 + BEGIN ENDS; ENDTOG:=TRUE; SCAN END; %112-05553000 + FILECONTROL(1); %ENDFILE 05554000 + ENTRY; 05555000 + EQUIVALENCE; 05556000 + EXTERNAL; 05557000 + BEGIN TYPE ~ -1; FUNCTION END; 05558000 + GOTOS; 05559000 + INTEGERS; 05560000 + LOGICAL; 05561000 + NAMEL; 05562000 + PAUSE; 05563000 + IOCOMMAND(2); %PRINT 05564000 + ; 05565000 + IOCOMMAND(3); %PUNCH 05566000 + IOCOMMAND(0); %READ 05567000 + REALS; 05568000 + RETURN; 05569000 + FILECONTROL(0); %REWIND 05570000 + BEGIN SCAN; STOP END; 05571000 + SUBROUTINE; 05572000 + IOCOMMAND(1); %WRITE 05573000 + FILECONTROL(7); %CLOSE 05573100 + FILECONTROL(6); %LOCK 05573200 + FILECONTROL(4); %PURGE 05573300 + IFS; 05574000 + FORMATER; 05575000 + CHAIN; 05575100 + MEMHANDLER(1) ; %FIXED 05576000 + MEMHANDLER(2) ; %VARYING 05576100 + MEMHANDLER(3) ; %AUXMEM FOR SUBPROGRAMS 05576200 + MEMHANDLER(4) ; %RELEASE 05577000 + IMPLICIT ; 05577100 + END ELSE IF NEXT=EOF THEN GO XIT ELSE BEGIN NEXT~0; FLOG(16) END ; 05578000 + LASTNEXT.[33:15]~TEMPNEXT ; 05578100 + IF NOT ENDTOG THEN IF SPLINK=0 THEN SPLINK:=1; %112-05579000 + ENDTOG:=FALSE; %112-05579100 + IF LABL ! BLANKS THEN 05580000 + BEGIN 05581000 + IF DT ! 0 THEN 05582000 + BEGIN 05583000 + DOL1: IF LABL = DOLAB[TEST ~ DT] THEN 05584000 + BEGIN 05585000 + EMITB(DOTEST[DT], FALSE); 05586000 + FIXB(DOTEST[DT].ADDR); 05587000 + IF DT ~ DT-1 > 0 THEN GO TO DOL1; 05588000 + END ELSE 05589000 + WHILE TEST ~ TEST-1 > 0 DO 05590000 + IF DOLAB[TEST] = LABL THEN FLAG(14); 05591000 + END; 05592000 + LABL ~ BLANKS; 05592100 + END; 05593000 + 05594000 + IF NEXT ! SEMI THEN 05595000 + BEGIN 05596000 + FLAG(117); 05597000 + DO SCAN UNTIL NEXT=SEMI OR NEXT=EOF ; 05598000 + END; 05599000 + ERRORTOG ~ FALSE; 05600000 + EOSTOG ~ TRUE; 05601000 + XIT: 05602000 +END STATEMENT; 05603000 +BOOLEAN STREAM PROCEDURE FLAGLAST(BUFF,ERR) ; 05603010 + BEGIN 05603020 + LOCAL A; SI~ERR; 8(IF SC!" " THEN JUMP OUT;SI~SI+1;TALLY~TALLY+1);05603030 + A~TALLY; SI~LOC A; SI~SI+7 ; 05603040 + IF SC<"8" THEN 05603050 + BEGIN TALLY~1; FLAGLAST~TALLY ; 05603060 + DI~BUFF;DS~46 LIT"LAST SYNTAX ERROR OCCURRED AT SEQUENCE NUMBER ";05603070 + DS~LIT"""; SI~ERR; DS~8 CHR; DS~LIT"""; 05603080 + DS~32 LIT " "; %510-05603081 + DS~32 LIT " "; %510-05603082 + END 05603090 + END FLAGLAST ; 05603100 +INTEGER PROCEDURE FEELD(X); VALUE X; INTEGER X; 05603110 +FEELD~IF X<10 THEN 1 ELSE IF X<100 THEN 2 ELSE IF X<1000 THEN 3 ELSE IF 05603120 +X<10000 THEN 4 ELSE IF X<100000 THEN 5 ELSE IF X<1000000 THEN 6 ELSE 7; 05603130 +FORMAT EOC1(/ "NUMBER OF SYNTAX ERRORS DETECTED = ",I*,".",X*, 05604000 + "NUMBER OF SEQUENCE ERRORS DETECTED = ",I*,"."), 05605000 + EOC2("PRT SIZE = ",I*,"; TOTAL SEGMENT SIZE = ",I*, 05606000 + " WORDS; DISK SIZE = ",I*," SEGS; NO. PRGM. SEGS = ",I*, 05607000 + "."), 05607010 + EOC3("ESTIMATED CORE STORAGE REQUIREMENT = ",I*," WORDS;", 05608000 + " COMPILATION TIME = ",I*," MIN, ",I*," SECS;", 05608010 + " NO. CARDS = ",I*,"."), 05608020 + EOC4("ESTIMATED CORE STORAGE REQUIREMENT = ",I*," WORDS;" 05608030 + " COMPILATION TIME = ",I*," SECS; NO. CARDS = ",I*,"."), 05608040 + EOC5("NUMBER OF TSS WARNINGS DETECTED = ",I*,".") ; 05608050 +COMMENT MAIN DRIVER FOR FORTRAN COMPILER BEGINS HERE; 05609000 +RTI ~ TIME(1); 05610000 +INITIALIZATION; 05611000 + DO STATEMENT UNTIL NEXT = EOF; 05612000 + IF NOT ENDSEGTOG THEN IF SPLINK NEQ 0 %112-05612100 + THEN BEGIN XTA:=BLANKS; FLAG(5); ENDS END; %112-05612200 + WRAPUP; 05613000 +POSTWRAPUP: 05613900 +IF TIMETOG THEN IF FIRSTCALL THEN DATIME; 05614000 +IF NOT FIRSTCALL THEN 05615000 + BEGIN 05616000 + WRITE(RITE,EOC1,FEELD(ERRORCT),ERRORCT,IF SEQERRCT=0 THEN 99 ELSE 05617000 + 5,FEELD(SEQERRCT-1),SEQERRCT-1) ; 05618000 + IF WARNED AND NOT DCINPUT THEN WRITE(RITE,EOC5,FEELD(WARNCOUNT), 05618100 + WARNCOUNT) ; 05618110 + WRITE(RITE,EOC2,FEELD(PRTS),PRTS,FEELD(TSEGSZ),TSEGSZ,FEELD(DALOC-1),05619000 + DALOC-1,FEELD(NXAVIL),NXAVIL) ; 05619010 + IF C1~(TIME(1)-RTI)/60 > 59 THEN WRITE(RITE,EOC3,FEELD(64|ESTIMATE), 05619020 + 64|ESTIMATE,FEELD(C1 DIV 60),C1 DIV 60,FEELD(C1 MOD 60),C1 MOD 60, 05619030 + FEELD(CARDCOUNT-1),CARDCOUNT-1) ELSE WRITE(RITE,EOC4,FEELD(ESTIMATE 05619040 + |64),ESTIMATE|64,FEELD(C1),C1,FEELD(CARDCOUNT-1),CARDCOUNT-1) ; 05619045 + IF ERRORCT>0 THEN IF FLAGLAST(ERRORBUFF,LASTERR) THEN WRITE(RITE,15, 05619050 + ERRORBUFF[*]) ; 05619100 + END ; 05619200 +END INNER BLOCK; 05620000 +END. 05621000 \ No newline at end of file