$OS $$SET M !-- See COMPL360 and MAKPLLIB --! $$SET D !-- See CMPL360X and MAKPLLIX for debugging --! $1 $XREF COMMENT "The source code for this computer program is placed in the public domain and may be used by any party without notice to the copyright holder, Stanford University. Stanford University provides no support of any kind to this computer program. Further: STANFORD MAKES NO REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED. BY WAY OF EXAMPLE, BUT NOT LIMITATION, STANFORD MAKES NO REPRESENTATIONS OR WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR THAT THE USE OF THE SOFTWARE WILL NOT INFRINGE ANY PATENTS, COPYRIGHTS, TRADEMARKS, OR OTHER RIGHTS. STANFORD SHALL NOT BE LIABLE FOR ANY LIABILITY OR DAMAGES WITH RESPECT TO ANY CLAIM BY A USER OF THIS COMPUTER PROGRAM OR ANY DERIVATIVES OF THIS COMPUTER PROGRAM." ; comment -- C O M P I L E O P T I O N S -- * * THE FOLLOWING OPTIONS ARE AVALABLE: * $IFF -- COMPILE FOR O/S - DOS SYSTEM. * $IFT -- COMPILE FOR 65K DOS SYSTEM. * $IFT M -- COMPILE FOR MTS SYSTEM. * INCLUDE $SET FOR 65K DOS SYSTEM AS NEXT CARD. * $IFF M M $IFT * - - - - - - - 6 5 K D O S S Y S T E M - - - - - - - $END $IFF * - - - - - - - O / S - D O S S Y S T E M - - - - - - - $END $END M $IFT M M * - - - - - - - - - - - M T S S Y S T E M - - - - - - - $OPT $END M * * NOTE - KEEP TRACK OF WHERE THE OBJECT MODULE IS BEING STORED; $IFF M M $IFT $TITLE THE PL360 COMPILER 65K DOS VERSION, 1/1/90 V1.90 $END $IFF $TITLE THE PL360 COMPILER O/S - DOS VERSION, 1/1/90 V1.90 $END $END M $IFT M M $TITLE MTS PL360 COMPILER V1.90 Jan. 90 $END M begin !-- PL360 COMPILER -- --! external procedure SYSINIT(R14); null; !-- OBTAINS FREE STORAGE AND OPENS DATA SETS --! external procedure SYSTERM(R14); null; !-- RELEASES FREE STORAGE AND CLOSES DATA SETS --! $IFT M M external procedure ERRBUFFR(R14); null; !-- BUFFERS MOST ERROR MESSAGES -- SO WE CAN --! !-- PRINT THEM AGAIN, AFTER THE XREF. --! external procedure ERRPRINT(R14); null; !-- PRINTS ERROR MESSAGE SUMMARY ON SERCOM --! !-- AND SPRINT (IF THEY AREN'T THE SAME) --! !-- AFTER THE XREF. ERROR MESSAGES ARE --! !-- STILL PRINTED IN THE USUAL MANNER, --! !-- INTERSPERSED IN THE LISTING. --! external procedure SERCOMPR(R14); null; !-- PRINTS THE SUMMARY LINES ON SERCOM IF IT --! !-- IS NOT ASSIGNED TO THE SAME FDNAME AS --! !-- SPRINT. --! $END M function SETZONE(8,#96F0); !-- DEFINE FUNCTION TO SET ZONE --! function DRAIN(0,#07F0); !-- MODEL 91 PIPELINE DRAIN --! function REDUCE(6,#0600); !-- BCTR(RN,0) --! function SB(4,#9600), RB(4,#94FF); !-- SET/RESET BITS --! byte OSSYSTEM; comment USED TO DETERMINE PROPER PROGRAM ENTRY AND EXIT CODE; byte NOTMOVED; !-- USED TO SUPPRESS REDUNDANT ERROR MESSAGES --! byte OVER=#00; !-- OVERPRNT/UNDERLINE FLAG --! byte PRNT=#00; !-- USED TO INDICATE INPUT IMAGE PRINT --! byte FLGS=#00; !-- GENERAL PURPOSE FLAGS --! equate DOLR syn #80, XITF syn #40, NOGO syn #20, ASCI syn #10; byte TRACE=0; comment USED TO CONTROL TRACE OUTPUT -- 0 - NO TRACE, bit 1 - ESD AND RLD PRINTOUT, bit 2 - NAME PRINTOUT, bit 4 - SEGMENT INITIALIZATION PRINTED; byte RUNFLAG,SKIPFLAG,NOPROGSEG,NODATASEG; byte FLAG; !-- USED IN SYNTACTIC ANALYSIS --! byte SIGN, EXPOSIGN; !-- SIGN FLAGS FOR NUMBER CONVERSION --! byte CARRCONT="1"; !-- LISTING FORMS CONTROL CODE --! byte BEGENDFLAG,REPFLAG=#00; byte FILLFLAG=0; byte DBGFLGS=0; short integer BEGENDLVL,LITCOUNT=0,CBEGENDLVL; integer N1,N2,N3,N4; !-- NAME AND LABEL POINTERS --! integer N5,N6; !-- BRANCH TABLE POINTERS --! short integer BLOCK; !-- CURRENT BLOCK LEVEL --! short integer FILLTYPE; !-- USED IN DATA FILL --! short integer PROCBR,PROCLK; !-- USED FOR BRANCH AROUND PROC --! short integer CSEGNO; !-- CURRENT SEGMENT NUMBER --! short integer NSEGNO; !-- MAXIMUM USED SEGMENT NUMBER --! short integer SEGNO; !-- NEXT SEGMENT NUMBER --! short integer MAXSEG; !-- HIGHEST SEGMENT ASSIGNED --! short integer LITX; !-- LITERAL INDEX --! short integer SYMTYPE; byte TYPEFLAG syn SYMTYPE(1); short integer NAMEPOINTER; short integer ERRCOUNT, ERRTOTL=0, LINECOUNT, PAGECOUNT, CARDCOUNT; short integer ERRLIMIT=50, MAXLINE=60; short integer ENDCHAIN=_1; short integer MAXHASH=156; array 5 short integer LENHASH=(0,32,64,96,128); array 40 integer HASHCHAIN=40(_1); array 47 byte ALPHASH=(2(0),3(4),11(8),4(12),3(16),2(20), 10(24),12(28)); $IFT byte XR=0; $END $IFF byte XR=0, REFOUT=0, XREF=0; $IFT M M byte TESTFLAG=0, SYM=0; dummy base R0; !-- Symbol block for SYM card output --! array 7 integer SYMDATUM; logical SYMLINK syn SYMDATUM; short integer CARDNO syn SYMDATUM(4); byte ORFIELD syn SYMDATUM(6); array 3 byte AAFIELD syn SYMDATUM(7); short integer DISPFIELD syn SYMDATUM(8); array 10 byte SYMFIELD syn SYMDATUM(10); byte FFIELD syn SYMDATUM(20); byte LDFIELD syn SYMDATUM(21); array 4 byte MFIELD syn SYMDATUM(24); integer DUPFAC syn SYMDATUM(24); close base; integer DATAPTR syn 0; integer PROCPTR; $END M short integer LASTCARD; array 40 integer REFCHAIN=40(_1); dummy base R0; integer LINKF; array 10 byte REFNAME; integer LINKN; integer LINKL; close base; equate REFMOV syn REFNAME(10)-LINKF-1, REFLEN syn LINKL(4)-LINKF; integer REFLINK syn 0; integer REFN1=0, REFN2=0, REFN3=0; !-- REFERENCE POINTERS --! integer REFSTART; $END comment TO CHANGE THE LIMIT ON THE NUMBER OF DIFFERENT SEGMENTS, CHANGE THE VALUE OF MAXSEGNO IN THE FOLLOWING EQUATE DECLARATION. IT SHOULD NOT EXCEED 255; equate ROUND syn 511, STACKLEN syn #800, $IFT MAXSEGNO syn 75, NAMEFILLSZ syn 606, $END $IFF MAXSEGNO syn 255, NAMEFILLSZ syn 1000, $END ESDTBLLEN syn MAXSEGNO+1*8, NAMETBLLEN syn MAXSEGNO+1*10, NAMETABSZ syn NAMEFILLSZ * 2, SIZE1 syn NAMETABSZ * 6; integer LBTL=10, LTTL=30, NTBL=60, DTL=60, BRTBL=10; !PROG=86! integer LTAB syn LBTL; short integer QTAB syn LTAB(2); array 10 byte SEGNAM="SEGNXXX "; byte MCCODE, MCTYPE; $IFT M M integer PROCSTACK, DATASTACK, PSTAKBOT, DSTAKBOT, FREESPACE=0; $END M integer I; !-- STACK INDEX --! integer DC1; !-- DATA INITIALIZATION COUNTER --! integer FUNC0,FUNC1,FUNC2; integer FUNCCOUNT=0; equate FT syn 20; !-- FUNCTION TYPE LIMIT --! integer EQUHOLD, STRNGADR; integer STACKBASE,NAMEBASE,LITBASE,LABELBASE,DATABASE,PRTBASE; integer BRANCHBASE; integer PROGBASE, NAMEND; integer SEGONEORG syn MEM(R13+72); integer PTAG, !-- USED TO PUT IN PROGRAM BASE REGISTER --! STARTADR=@SEGONEORG, !-- START OF INITIAL DATA AREA --! DATAEND; !-- END OF DATA FILL AREA --! integer SAVERETURN; !-- USED TO HOLD RETURN REGISTER FOR MAIN --! long real CONWORK; !-- USED TO CONVERT TO DECIMAL --! array 32 byte TYPETABLE= (0,1,3(0),1,4(0),1,3(0),1,1,16(0)); array 8 byte LENGTH=(1,2,3,2,4(0)), ALENGTH=(1,3,7,3,4(0)); array 17 byte DTRTABLE=" 0123456789ABCDEF"; array 16 byte TRTABLE syn DTRTABLE(1); byte OPTFLAG=0; !-- CONTROLS OPTIMIZATION --! short equate CASESEQ syn 18, !-- --! RELOP syn 22, !-- --! COMPAOR syn 25, !-- --! CONDTHEN syn 26, !-- --! DOTERM syn 30, !-- --! REPLIST1 syn 41, !-- --! TDECL3 syn 45, !-- --! BLOCKHEAD syn 69, !-- --! BLOCKBODY syn 70, !-- --! PROGMINUS syn 71, !-- --! PROGSTAR syn 72, !-- --! NUMBERSYMBOL syn 78, !-- --! IFTERM syn 79, !-- --! RPTERM syn 82, !-- --! CONDEND syn 86, !-- --! REPUNTIL syn 92, !-- --! IDENTSYMBOL syn 93, !-- --! STRNGSYMBOL syn 94, !-- --! SHIFTOP syn 95, !-- --! ARITHOP syn 96, !-- --! ADROP syn 97, !-- --! SEMICOLON syn 98, !-- ; --! EQUALSYM syn 99, !-- = --! NOTSYM syn 100, !-- ^ --! LPAREN syn 101, !-- ( --! RPAREN syn 102, !-- ) --! COLONSYMBOL syn 103, !-- : --! COMMASYM syn 104, !-- , --! ENDFILE syn 105, !-- . --! ASSIGNSYMBOL syn 106, !-- := --! FT2 syn 107, !-- DO --! FT3 syn 111, !-- AND --! ENDSYMBOL syn 112, !-- END --! FORSYMBOL syn 113, !-- FOR --! FT4 syn 116, !-- BASE --! FT5 syn 127, !-- ARRAY --! BEGINSYMBOL syn 128, !-- BEGIN --! FT6 syn 134, !-- COMMON --! FT7 syn 138, !-- INTEGER --! FT8 syn 141, !-- EXTERNAL --! FT9 syn 144; !-- CHARACTER --! array 12 short integer OPS = ( SEMICOLON , !-- ; --! ARITHOP , !-- --! RELOP , !-- --! NOTSYM , !-- ^ --! LPAREN , !-- ( --! RPAREN , !-- ) --! COLONSYMBOL , !-- : --! COMMASYM , !-- , --! ADROP , !-- --! ENDFILE , !-- . --! ASSIGNSYMBOL , !-- := --! EQUALSYM ); !-- = --! array DATAFILL short integer WORD2 = ("DO","IF","OF","OR"); array DATAFILL integer WORD3 = ("AND ","END ","FOR ","SYN ","XOR "); array DATAFILL integer WORD4 = ("BASE","BYTE","CASE","DATA","ELSE","GOTO","LONG","NULL", "REAL","STEP","THEN"); array DATAFILL integer WORD5 = ("ARRAY ","BEGIN ","CLOSE ","DUMMY ", "SHORT ","UNTIL ","WHILE "); array DATAFILL integer WORD6 = ("COMMON ","EQUATE ","GLOBAL ","REPEAT "); array DATAFILL integer WORD7 = ("INTEGER ","LOGICAL ","SEGMENT "); array DATAFILL integer WORD8 = ("EXTERNAL","FUNCTION","REGISTER"); array DATAFILL integer WORD9 = ("CHARACTER ","PROCEDURE "); array DATAFILL integer SHIFTWORD = ("SHRL","SHLL","SHRA","SHLA"); array 146 byte F = (0,5,3(10),5,3,3,7,7,3(5),7,3,3,7,4,4,7,3,2,7,5,4,4,6,2,2,6,4,5, 1,1,5,2,2,1,9,8,4,1,3,6,8,1,3,8,10,7,3,7,3,3,7,3,8,10,7,3,3,2,1, 5,1,2,2,1,9,9,4,5,1,1,7,3,3,8,10,4,5,3,4,3,2,2,6,9,7,7,4,7,4,12, 5,3(7),12,11,7,11,7,9,11,9,7,9,11,7,11,11,9,1,9,9,7,10,7,8,9,8, 11,3,10,7,9,7,12,2,3,3(11),10,9,10,9,4(10),9,8,10,8); array 146 byte G = (0,7,8,7,8,7,4(8),3(7),3,7,8,8,5(7),4(5),4,7,6,6,7,4,3(1),6,5,4, 10,10,1,2,2,14(10),3(11),4(10),9,10,10,9,4,7,7,3(1),4(10),7,7,4, 7,5,4,5,4,4,7,5,10,7,2,4,8,7,3,3,7,1,6,5,10,3,12,3,1,5,4,7,5, 3(4),7,12,4,2,11,7,10,2,7,11,7,11,3,4,10,7,10,10,11,5,7,10,11,10, 7,11,11,3(10),9,11,11); array 146 short integer MTB = (0,1,92,102,112,122,169,187,205,221,252,253,254,259,260,331,342, 368,373,390,396,402,412,417,426,456,468,469,479,484,485,504,505, 506,507,508,513,518,519,531,547,548,554,565,575,585,591,601,607, 613,619,625,631,637,647,663,673,680,686,692,698,703,714,720,726, 727,738,745,746,747,758,780,786,792,793,819,859,866,873,887,951, 952,975,988,989,990,991,992,1003,1004,1010,1028,1044,1045,1079, 1084,1085,1086,1097,1098,1103,1119,1128,1129,1130,1131,1142,1143, 1148,1153,1154,1159,1164,1165,1174,1175,1180,1181,1186,1194,1195, 1196,1202,1208,1213,1218,1219,1220,1227,1232,1238,1243,1254,1263, 1268,1284,1289,1306,1311,1316,1321,1331,1343,1348,1349,1354); $IFT M M integer AATYPE syn WORD5(4); $END M comment THE FOLLOWING TWO TABLES ARE USED IN THE INSYMBOL SCAN ROUTINE -- SCANTAB1 SCANS TO THE END OF COMMENTS, SCANTAB2 SCANS TO THE NEXT NON-BLANK CHARACTER USING THE FOLLOWING CODE: 0 -- BLANK, 1 -- NUMBER START, 2 -- ID START, 3 -- HEX NUMBER START, 4 -- STRING START, 5 -- ILLEGAL CHARACTER, >= 10 -- THESE ARE THE SPECIAL SYMBOLS FOR PL360 SYNTAX. FS + CODE - 10 IS THE SYNTACTIC SYMBOL CODE ASSUMING THE FOLLOWING ORDER SEMICOLON + - = < > ^ ( ) * / : , @ . ; array 256 byte SCANTAB1=256(0); array 256 byte SCANTAB2 = (64(5), !-- X'00' TO X'3F' --! 0, 10(5), 38, 18, 24, 12, 6, !-- X'40' TO X'4F' --! 11(5), 7, 28, 26, 10, 22, !-- X'50' TO X'5F' --! 14, 30, 8(5), 6, 34, 5, 1, 20, 5, !-- X'60' TO X'6F' --! 10(5), 32, 3, 36, 5, 16, 4, !-- X'70' TO X'7F' --! 2(5, 9(2), 6(5)), !-- X'80' TO X'9F' --! 5, 22, 8(2), 6(5), !-- X'A0' TO X'AF' --! 16(5), !-- X'B0' TO X'BF' --! 2(5, 9(2), 6(5)), !-- X'C0' TO X'DF' --! 2(5), 8(2), 6(5), !-- X'E0' TO X'EF' --! 10(1), 6(5)); !-- X'F0' TO X'FF' --! array 64 byte CONDTAB; byte CONDCK syn CONDTAB(#2A); array 1000 byte ESDNAME syn MEM(R11); !-- @ESDNAMETABLE --! comment ALLOCATION FOR THE COMPILER TABLES AND ARRAYS IS DONE AT RUN TIME USING AVAILABLE CORE SPACE. THE LITERAL TABLE HAS A MAXIMUM LENGTH OF #3000 BYTES, DATA INITIALIZATION SECTION A MAXIMUM LENGTH OF #8000 BYTES. THE MAXIMUM LENGTH OF THE OTHER VARIABLES IS GIVEN BELOW; array 512 integer V syn 0; !-- TRANSLATION STACK --! short integer S syn V(12), T syn V(14); integer V1 syn V(16); short integer T1 syn T(16); integer V2 syn V1(16); short integer T2 syn T1(16); array #800 short integer LABEL syn 0; !-- LABEL TABLE --! short integer LABELADR syn LABEL(10); short integer LABELCHAIN syn LABEL(12); array #800 integer BRANCH syn 0; !-- BRANCH TABLE --! short integer BRANCHADR syn BRANCH, BRANCHAIN syn BRANCH(2); array #1800 short integer TYPE syn 0; array 2 short integer ADR syn TYPE(2); short integer LINK syn TYPE(6); byte NAME syn TYPE(8); !-- NAME IS 2,4,6,8, OR 10 BYTES LONG --! short equate SD syn 0, LD syn 1, ER syn 2, CM syn 5, XCM syn 6, WER syn ER + 8, RLD syn 255; array 14 byte ESDCODE="SDLDER****CMER"; !-- ESD TYPE NAMES --! short equate ATYPE syn #0C, VTYPE syn #1C; array 4 short integer ESDTBL syn MEM; short integer PL360NO syn ESDTBL, RLDADDR syn ESDTBL(4), ESDLINK syn ESDTBL(6); byte ESDTYPE syn ESDTBL(2), RLDFLAG syn ESDTBL(3); !-- DATA AND PROGRAM SEGMENT FORM --! array 0 integer SEGAREA syn 0; integer COUNTER syn SEGAREA, PREVSEG syn SEGAREA(4), LASTINITIAL syn SEGAREA(8); short integer SEGTYPE syn SEGAREA(12), BLOCKLEVEL syn SEGAREA(14), SEGBASEREG syn SEGAREA(16); short integer INITIALSTART syn 0, INITIALEN syn 2, TABLEN syn 0; byte SEGHEAD syn 18; short integer PROGRAM syn SEGHEAD(R9+4); short integer PBREG syn SEGBASEREG(R9); short integer DBREG syn SEGBASEREG(R10); integer LC syn COUNTER(R9), DC syn COUNTER(R10); byte GENFLAG=#FF, GENDECK=#FF; $IFF byte XREFCC = " "; !-- CARRIAGE CONTROL FOR XREF --! $END array 5 integer PARAMSAVE; integer PROGESDADR,PROGESDEND,DATAESDADR,DATAESDEND; short integer PROGREG=15; short integer SEGHDLEN=@SEGHEAD; array 10 byte RIGHTPART; !-- USED IN SYNTACTIC ANALYSIS --! equate NOMORERULES syn 255; !-- END OF RIGHTPART RULES --! $IFF M M array 20 integer CBUF; !-- CARD BUFFER --! $END M $IFT M M array 23 integer CBUF; !-- CARD BUFFER, LINE NUMBER --! array 6 byte EDMSK = (" ",3(#20),#21,#20); $END M array 20 integer PBUF; !-- PUNCH BUFFER --! array 3 integer BLANK=3(" "); array 133 byte WBUFF; !-- PRINT BUFFER --! array 132 byte WBUF syn WBUFF(1); $IFT M M equate WCRDLN syn 6, WHDRLN syn 40; array 10 byte WLINENUM syn WBUF(21); array 72 byte WCARD syn WBUF(WHDRLN+2); $END M $IFF M M equate WCRDLN syn 4, WHDRLN syn 34; array 72 byte WCARD syn WBUF(WHDRLN+1); $END M array 8 byte WSEQ syn WCARD(76); array WHDRLN byte WHDR = WHDRLN(" "); !-- LINE HEADER --! array 3 byte WPSEG syn WHDR(0); array 4 byte WPDISP syn WHDR(4); array 3 byte WDSEG syn WHDR(11); array 4 byte WDDISP syn WHDR(15); array WCRDLN byte WCRDCNT syn WHDR(WHDRLN-WCRDLN-3); array 2 byte WBGNEND syn WHDR(WHDRLN-2); array 72 byte OBUF; !-- OVERPRNT BUFFER --! array 10 byte OMSK = 10(_1); !-- MASK BYTES --! $IFT M M array 32 byte ERRORBUF = 32(" "); array 6 byte ERRWCRDCNT syn ERRORBUF(10); array 16 byte ERRMESSAGE syn ERRWCRDCNT(6); $END M array 133 byte HEADER !-- LISTING PAGE HEADER --! =("1PL360 COMPILATION",95(" "),"PAGE",16(" ")); array 133 byte SUBHEAD = 133(" "); $IFF $IFF M M array 39 byte IDRDATA = ("1 DTR PL3600790", 24(" ")); $END M $IFT M M array 39 byte IDRDATA = (4(" "),"07-01-90 PL360",21(" ")); $END M $END short integer LIST = _1; byte LISTFLAG syn LIST; array 2 long real VALUEF; !-- VALUE OF CURRENT SYMBOL --! integer VALUE syn VALUEF; short integer IVALUE syn VALUEF; array 64 integer STRINGV; !-- VALUE OF CURRENT STRING --! array 3 integer ZERO=3(0); equate DTHI syn #8765, DTLO syn #4321, DTFILL syn DTHI shll 16 or DTLO; byte C1 syn B1, C2 syn B2, C6 syn B6; short integer H6 syn B6; $PAGE procedure ERROREXIT(R4); !-- EXIT FROM PROGRAM --! begin SB(XITF,FLGS); goto EXIT; end; procedure PRINT(R14); begin logical SAVE14; SAVE14 := R14; R0 := 1 + LINECOUNT; CLI("0",CARRCONT); if = then begin if R0 >= MAXLINE then CARRCONT := "1" else R0 := R0 + 1; end; CLI("1",CARRCONT); if = then begin R0 := 1 + PAGECOUNT; PAGECOUNT := R0; CVD(R0,CONWORK); HEADER(118) := "`0`1`0"; ED(3,HEADER(117),CONWORK(6)); R0 := @HEADER; WRITE; R0 := 3; CARRCONT := "0"; CLC(93,SUBHEAD(1),SUBHEAD); if ^= then !-- SUPPLY SUB-HEADING --! begin R0 := @SUBHEAD; WRITE; R0 := 4; end; end; WBUFF(0/1) := CARRCONT; LINECOUNT := R0; if R0 >= MAXLINE then CARRCONT := "1" else CARRCONT := " "; R0 := @WBUFF; WRITE; R14 := SAVE14; end; procedure OUTPUTCARD(R14); if PRNT then begin array 4 integer SAVE40; STM(R14,R1,SAVE40); WBUF(0/WHDRLN) := WHDR; WCARD(0/72) := CBUF; $IFT M M WLINENUM(0/10) := CBUF(80); $END M $IFF M M WDDISP(5/6) := BLANK; $END M WSEQ(0/8) := CBUF(72); PRINT; RESET(PRNT); WBUFF(0/133) := BLANK; if TM(#80,OVER); ON then begin SET(PBUF); PBUF(1/71) := PBUF; PBUF(0/72) := PBUF xor OBUF; !-- REVERSE MASK --! WCARD(0/72) := WCARD and PBUF; !-- BLANK FILL --! if TM(#40,OVER); ON then !-- UNDERLINE --! begin PBUF := "_"; PBUF(1/71) := PBUF; end else PBUF(0/72) := CBUF; PBUF(0/72) := PBUF and OBUF; !-- OVERPRNT --! if ^= then !-- SOMETHING TO DO --! begin WCARD(0/72) := WCARD or PBUF; WBUFF := "+"; R0 := @WBUFF; WRITE; !-- WRITE OVERPRNT --! end; end; LM(R14,R1,SAVE40); !-- RESTORE & RETURN --! end; procedure ENDMESSAGES(R2); begin WBUF := "*** FURTHER ERROR MESSAGES SUPPRESSED"; PRINT; WBUFF(0/38) := BLANK; SETZONE(CARRCONT); end; procedure ERROR (R4); begin array 3 integer ERRSAVE; STM(R0,R2,ERRSAVE); if NOTMOVED then goto X; SET(NOTMOVED); R0 := 1 + ERRCOUNT; ERRCOUNT := R0; if R0 > ERRLIMIT then goto X; SET(PRNT); !-- INDICATE NEED TO PRINT IMAGE --! WBUFF(0/125) := BLANK; R2 := R2-R2; IC(R2,XR); R2 := R2 shll 4; !-- RELATIVE ERROR MESSAGE --! begin segment base R1; array 512 byte ERRORCODE= ("00 SYNTAX ","01 VAR MIX TYPES","02 FOR PARAMETER", "03 REG ASS TYPES","04 BIN OP TYPES ","05 SHIFT OP ", "06 COMPARE TYPES","07 REG TYPE OR #","08 UNDEFINED ID ", "09 MULT LAB DEF ","10 EXC INI VALUE","11 NOT INDEXABLE", "12 DATA OVERFLOW","13 NO. OF ARGS ","14 ILLEGAL CHAR ", "15 MULTIPLE ID ","16 PROGRAM OFLOW","17 INITIAL OFLOW", "18 ADDRESS OFLOW","19 NUMBER OFLOW ","20 MISSING . ", "21 STRING LENGTH","22 NULL CASE ST.","23 FUNC DEF NO. ", "24 ILLEGAL PARAM","25 NUMBER ","26 SYN MIX ", "27 SEG NO OFLOW ","28 ILLEGAL CLOSE","29 NO DATA SEG ", "30 ILLEGAL INIT ","31 GET MORE CORE"); end; R1 := R1+R2; WBUF(11/16) := B1; $IFF M M WBUF(2) := "ERROR NO"; R1 := @WBUF(R6+35); B1 := "!"; $END M $IFT M M ERRMESSAGE(0/16) := B1; R1 := @ERRORBUF; ERRBUFFR; WBUF(2) := "ERROR NO"; R1 := @WCARD(R6); B1 := "!"; $END M WBUF(108) := "*"; WBUF(109/16) := WBUF(108); PRINT; WBUFF(0/133) := BLANK; RESET(RUNFLAG); if GENFLAG then RESET(GENDECK); R0 := ERRCOUNT; if R0 = ERRLIMIT then ENDMESSAGES; X: LM(R0,R2,ERRSAVE); end; procedure LABELERROR(R3); !-- PRINTS OUT UNDEFINED LABELS --! begin integer TEMP, SAVE; WBUFF(0/121) := BLANK; SAVE := R0; R2 := R1 + LABELBASE; WBUF(9/10) := LABEL(R2); WBUF(20) := "UNDEF LAB"; RESET(RUNFLAG); if GENFLAG then RESET(GENDECK); R0 := CSEGNO; CVD(R0,CONWORK); UNPK(2,7,WBUF,CONWORK); SETZONE(WBUF(2)); WBUF(108) := "*"; WBUF(109/16) := WBUF(108); R2 := LABELCHAIN(R2); while R2 >= 0 do begin TEMP := R2; UNPK(4,4,WBUF(4),TEMP); WBUF(8) := " "; TR(3,WBUF(4),TRTABLE(_240)); PRINT; R2 := PROGRAM(R2+2); R0 := 1+ERRCOUNT =: ERRCOUNT; if R0 > ERRLIMIT then goto Y; end; if R0 = ERRLIMIT then ENDMESSAGES; Y: WBUFF(0/133) := BLANK; X: R0 := SAVE; end; procedure EDIT (R8); begin R1 := LC; PROGRAM(R1) := R0; R1 := R1+2; LC := R1; end; procedure EMIT (R8); begin R0 := R0 shll 4 or R1 shll 4 or R2 shll 4 or R3; R1 := LC; PROGRAM(R1) := R0; R1 := R1+2; LC := R1; end; procedure EMYT (R8); begin R0 := R0 shll 4 or R1 shll 4 or R2 shll 20 or R3; R1 := LC; PROGRAM(R1+2) := R0; R0 := R0 shrl 16; PROGRAM(R1) := R0; R1 := R1+4; LC := R1; end; procedure EMYTBRANCH(R8); begin R0 := R0 or #4700; R1 := LC; PROGRAM(R1) := R0; R0 := ENDCHAIN =: PROGRAM(R1+2); V(R7) := R1; R1 := R1 + 4; LC := R1; end; procedure ANDTORCHAIN(R4); begin integer ANDCHAIN syn MEM(R3), ORCHAIN syn MEM(R3+4); byte OPCODE syn B2, COND syn B2(1); if R1 := ANDCHAIN; R1 ^= ENDCHAIN then begin R1 := R1 and #FFFF; R2 := @PROGRAM(R1); if OPCODE = #46 then !-- BCT instruction --! begin R0 := R1; R1 := LC; R2 := #47F0S =: PROGRAM(R1); R2 := @B1(4) =: LC; end else begin R0 := PROGRAM(R1+2); if OPCODE = #47 and COND >= #F0 and OPTFLAG >= #80 then begin LC := R1; goto X; end; if < then XI(#F0,COND) else XI(#01,OPCODE); end; R2 := ORCHAIN =: PROGRAM(R1+2); ORCHAIN := R1; X: ANDCHAIN := R0; end; end; procedure MERGECHAIN (R4); begin short integer NEXT syn B2(2); R1 := NEXT; NEXT := R0; R0 := R1; while R1 := NEXT; R1 >= 0 do R2 := @PROGRAM(R1); NEXT := R0; end; procedure CHAINFIXUP (R4); if R1 ^= ENDCHAIN then begin integer SAVE4; SAVE4 := R4; R0 := R0 shll 16 shra 16; R3 := N5 + BRANCHBASE; R2 := N6 + BRANCHBASE; while R2 := @B2(4); R2 <= R3 do begin if R0 = BRANCHADR(R2) then begin R0 := R1; MERGECHAIN; R4 := SAVE4; goto X; end; end; BRANCHADR(R2) := R0; BRANCHAIN(R2) := R1; R2 := R2 - BRANCHBASE =: N5; R1 := ENDCHAIN; X: end; procedure ENTERBRANCH(R8); begin comment R1 = ADDRESS OF START OF BRANCH CHAIN, R2 = LABEL ID; R5 := N4 + LABELBASE; for R4 := N3 + LABELBASE step _14S until R5 do if B2(0/10) = LABEL(R4) then begin R0 := R1; R2 := @LABELCHAIN(R4-2); MERGECHAIN; goto L; end; R4 := 14 + N3 =: N3 + LABELBASE; LABEL(R4/10) := B2; LABELCHAIN(R4) := R1; R0 := R0 -- R0 =: LABELADR(R4); L: end; procedure ENTERNAME(R8); begin R5 := R5-R5; IC(R5,B1); IC(R5,ALPHASH(R5-193)); R3 := @B3(1) and #E; R14 := NAMEBASE; R5 := R5 + LENHASH(R3-2); REDUCE(R3); R4 := HASHCHAIN(R5); while R4 >= N2 do begin R4 := R4 + R14; EX(R3,CLC(0,B1,NAME(R4))); if = then begin XR := 15; ERROR; R4 := N1 + NAMEBASE; goto X; end; R4 := LINK(R4); if R4 ^= ENDCHAIN then R4 := R4 and #FFFF; end; R4 := N1 + R14; EX(R3,MVC(0,NAME(R4),B1)); TYPE(R4) := R2; ADR(R4+2) := R0; R0 := R0 shrl 16; ADR(R4) := R0; R0 := HASHCHAIN(R5); LINK(R4) := R0; R0 := N1; HASHCHAIN(R5) := R0; R0 := R0 + R3 + 9S; N1 := R0; if R0 > NAMEND then !NAMETABLE OVERFLOW! begin XR := 31; ERROR; WBUF := "CORE SIZE TOO SMALL "; WBUF(STRING/132-STRING) := WBUF(STRING-1); PRINT; SB(NOGO,FLGS); ERROREXIT; end; if TM(2,TRACE); ON then begin WBUFF(0/132) := BLANK; WBUF(19/10) := B1; R14 := #FF and R2; CVD(R14,CONWORK); OI(#0F,CONWORK(7)); UNPK(1,1,WBUFF(31),CONWORK(6)); if R2 ^= 10S then if R2 = 12S then begin UNPK(8,4,WBUF(9),ADR(R4)); TR(7,WBUF(9),TRTABLE(_240)); end else begin UNPK(4,4,WBUF(13),ADR(R4)); TR(3,WBUF(13),TRTABLE(_240)); if R1 > R7 and R14 <= 4S then begin IC(R14,ALENGTH(R14)); R14 := @B14(1); if R14 ^= V(R7) then WBUF(35) := "A"; end; end; WBUF(17) := " "; PRINT; WBUFF(0/40) := BLANK; end; X: end; procedure EMITLIT (R4); !-- USED BY FOR STATEMENT --! begin integer TEMP; TEMP := R5; R0 := 5; R3 := R3-R3; EMIT; R1 := LITX; R3 := R1 + LITBASE; R1 := R1 + 8S; LITX := R1; MVI(2,B3); MVI(3,B3(1)); B3(2/2) := LC(2); B3(4/4) := TEMP; R0 := 2 + LC; LC := R0; end; procedure MAKELITERAL(R4); begin comment R0 = TYPE, R1 = LENGTH, R2 = FIXUP ADDRESS, R3 = ADDRESS OF FIRST BYTE IF NOT SHORT INTEGER TYPE 1 OR ADDRESS - 2 IF SHORT INTEGER; short integer ADDRESS; ADDRESS := R2; R2 := LITX + LITBASE; STC(R0,B2); STC(R1,B2(1)); B2(2/2) := ADDRESS; CLI(1,B2); if = then EX(R1,MVC(0,B2(4),B3(2))) else EX(R1,MVC(0,B2(4),B3)); R2 := @B2(R1+5) - LITBASE; LITX := R2; end; $PAGE $IFT M M segment procedure ENTERSYMLABEL(R8); begin array 4 integer SAVE36; STM(R3,R6,SAVE36); R4 := PROCSTACK; R6 := FREESPACE; R5 := B6; FREESPACE := R5; R5 := DATAPTR(R4); SYMLINK(R6) := R5; DATAPTR(R4) := R6; R0:= R0 and #0FFF; MVI(0,AAFIELD(R6)); DISPFIELD(R6) := R0; R4 := CARDCOUNT; CARDNO(R6) := R4; case R1 of begin begin SYMFIELD(R6/10) := V(R7); R1 := T(R7); end; begin SYMFIELD(R6) := "#B"; R2 := CARDNO(R6); CVD(R2,CONWORK); UNPK(5,3,FFIELD(R6),CONWORK(5)); SETZONE(MFIELD(R6+2)); SYMFIELD(R6+2/4) := FFIELD(R6); R1 := 6; end; begin SYMFIELD(R6/10) := V1(R7); R1 := R3; PROCPTR := R6; end; begin SYMFIELD(R6) := "#E"; R2 := CARDNO(R6); CVD(R2,CONWORK); UNPK(5,3,FFIELD(R6),CONWORK(5)); SETZONE(MFIELD(R6+2)); SYMFIELD(R6+2/4) := FFIELD(R6); R1 := 6; end; begin SYMFIELD(R6) := "#END"; R1 := 4; end; end; R1 := @B1(64); STC(R1,ORFIELD(R6)); LM(R3,R6,SAVE36); end; $PAGE segment procedure ENTERSYMDATA(R8); begin array 7 integer SAVE06; STM(R0,R6,SAVE06); R4 := DATASTACK; R6 := FREESPACE; R5 := B6; FREESPACE := R5; R5 := DATAPTR(R4); SYMLINK(R6) := R5; DATAPTR(R4) := R6; R0 := R0 and #0FFF; MVI(0,AAFIELD(R6)); DISPFIELD(R6) := R0; R4 := CARDCOUNT; CARDNO(R6) := R4; SYMFIELD(R6/10) := B1; R4:=128; R5 := AATYPE; if R5 = B7(4) then begin R4 := @B4(64); R5 := B7; end else R5 := R5 - R5; R2 := 1 + T(R7) and #FF; case R2 of begin begin MVI(#14,FFIELD(R6)); MVI(1,LDFIELD(R6)); R5 := R5 shrl 1; end; begin MVI(#10,FFIELD(R6)); MVI(3,LDFIELD(R6)); R5 := R5 shrl 2; end; begin MVI(#1C,FFIELD(R6)); MVI(7,LDFIELD(R6)); R5 := R5 shrl 3; end; begin MVI(#18,FFIELD(R6)); MVI(3,LDFIELD(R6)); R5 := R5 shrl 2; end; begin MVI(#04,FFIELD(R6)); MVI(0,LDFIELD(R6)); end; end; DUPFAC(R6) := R5; MVI(0,MFIELD(R6)); R4 := R4 or R3; STC(R4,ORFIELD(R6)); LM(R0,R6,SAVE06); end; $PAGE $END M segment procedure ALLOCATELITERALS(R8); begin !-- R4 := LC IS A PARAMETER --! array 3 integer TEMP; integer LITEND; short integer ADDRESS; procedure RLDCHAINEMIT(R8); begin comment FIX UP RLD CHAIN ENTRIES AND EMIT RLD LITERAL -- R4 = LC, FIRST ENTRY IS MAIN PROGRAM; R0 := PROGESDEND; R1 := PROGESDADR; R5 := RLDADDR(R1); if R5 >= 0 then begin while R5 >= 0 do begin R6 := PROGRAM(R5+2); R2 := PROGRAM(R5); R3 := R2 and #F shll 12 + R4 - R5; PROGRAM(R5+2) := R3; R2 := R2 and #FFF0; PROGRAM(R5) := R2; R5 := R6; end; R3 := R3-R3; PROGRAM(R4) := R3; PROGRAM(R4+2) := R3; RLDADDR(R1) := R4; R4 := @B4(4); end; R1 := R1 + 8S; while R1 < R0 do begin if ESDTYPE(R1) ^= SD then if ESDTYPE(R1) ^= ER then if ESDTYPE(R1) ^= WER then if ESDTYPE(R1) ^= XCM then goto SKIP; R5 := RLDADDR(R1); if R5 < 0 then goto SKIP; while R5 >= 0 do begin R6 := PROGRAM(R5+2); R3 := PTAG + R4; PROGRAM(R5+2) := R3; R5 := R6; end; R3 := R3-R3; PROGRAM(R4) := R3; PROGRAM(R4+2) := R3; RLDADDR(R1) := R4; R4 := @B4(4); SKIP: R1 := R1 + 8S; end; R5 := @PROGRAM(R4); B5(0/4) := ZERO; end; procedure ALLTYPE(R8); begin comment R0 = LENGTH AND R4 = LC ARE PARAMETERS -- R7 = START OF LITERALS -- LITEND = END OF LITERALS; R6 := R7; while R6 < LITEND do begin IC(R1,B6(1)); IC(R2,B6); if R0 = R2 then begin ADDRESS(0/2) := B6(2); R3 := ADDRESS; R4 := R4 + PTAG; PROGRAM(R3) := R4; ADDRESS:=R4; B6(2/2) := ADDRESS; R5 := @B6(R1+5); while R5 < LITEND do begin IC(R2,B5(1)); CLC(1,B5,B6); if = then begin EX(R2,CLC(0,B5(4),B6(4))); if = then begin ADDRESS(0/2) := B5(2); R3 := ADDRESS; PROGRAM(R3) := R4; MVI(4,B5); ADDRESS:=R4; B5(2/2) := ADDRESS; end; end; R5 := @B5(R2+5); end; R4 := R4 - PTAG; R5 := @PROGRAM(R4); EX(R1,MVC(0,B5,B6(4))); R4 := @B4(R1+1); end; R6 := @B6(R1+5); end; R5 := @PROGRAM(R4); B5(0/4) := ZERO; end; STM(R6,R8,TEMP); R7 := LITBASE; R6 := R7 + LITX; LITEND := R6; R6 := N4 + LABELBASE; R7 := R7 + LABEL(R6+2); LM(R0,R2,ZERO); ALLTYPE; R0 := 1; R4 := R4 + 1 and _2; ALLTYPE; R0 := 2; R4 := R4 + 3S and _4; ALLTYPE; RLDCHAINEMIT; LM(R1,R2,ZERO); R0 := 3; R4 := R4 + 7S and _8; ALLTYPE; R6:=R7; while R68S then begin R2:=R2 shll 30; if R2<0 then begin ADDRESS(0/2) := B6(8); R3:=ADDRESS+ LITBASE; B6(8/2) := B3(2); end; R2:=R2 shll 1; if R2<0 then begin ADDRESS(0/2) := B6(6); R3:=ADDRESS+LITBASE; B6(6/2) := B3(2); end; R2:=8; STC(R2,B6); end; IC(R1,B6(1)); R6:=@B6(R1+5); end; R0:=8; ALLTYPE; R3 := N4 + LABELBASE; R2 := LABEL(R3+2); LITX := R2; LM(R6,R8,TEMP); end; procedure SETDATAINIT(R8); begin comment SET DATA INITIALIZATION -- R1 = COUNT -- AT EXIT R2 = ADDRESS TO MOVE DATA; R3 := LASTINITIAL(R10); R2 := INITIALSTART(R3) + INITIALEN(R3); R4 := DC1; if R2 ^= R4 then begin if R2 ^= INITIALSTART(R3) then begin R3 := R3 + INITIALEN(R3) + 5S and _2; LASTINITIAL(R10) := R3; !-- NEW LAST --! R0 := R0-R0; INITIALEN(R3) := R0; end; INITIALSTART(R3) := R4; end; R0 := 4 + R3 + R1 + INITIALEN(R3); !-- @LAST BYTE --! if R0 > DATAEND then begin XR := 17; ERROR; SET(SKIPFLAG); R1 := R1-R1; INITIALEN(R3) := R1; end else begin R0 := R4+R1; if R0 > DC then if FILLFLAG then DC := R0 else !-- ERROR --! begin XR := 10; ERROR; SET(SKIPFLAG); R1 := R1-R1; end; end; R0 := R1 + INITIALEN(R3); R2 := 4 + R3 + INITIALEN(R3); INITIALEN(R3) := R0; R0 := DC1 + R1; DC1 := R0; end; procedure MOVETABLE(R4); if R3 ^= 0 then begin !-- MOVE R3 BYTES FROM B1 TO B2 --! for R3 := R3 - 1 step _256 until 256 do begin B2(0/256) := B1; R1 := R1 + 256; R2 := R2 + 256; end; EX(R3,MVC(0,B2,B1)); end; procedure INCRSEGNO(R8); begin !-- GET NEXT SEGMENT NUMBER --! R0 := 1 + NSEGNO; if R0 > MAXSEGNO then begin XR := 27; ERROR; R0 := MAXSEGNO; end; NSEGNO := R0; SEGNO := R0; if R0 > MAXSEG then MAXSEG := R0; end; procedure FINDESDENTRY(R8); begin comment R0 = END OF ESD TABLE, R1 = START OF ESD TABLE, R2 = ESD TYPE, R3 = RLD FLAG, R4 = CSEGNO -- AT EXIT R0 = NEW END OF ESD TABLE, R1 = ADDRESS OF ESD ENTRY -- A NEW ENTRY IS MADE IF NO ENTRY IS FOUND; while R1 < R0 do if R4 = PL360NO(R1) then goto FOUND else R1 := R1 + 8S; PL360NO(R1) := R4; R0 := ENDCHAIN; RLDADDR(R1) := R0; ESDLINK(R1) := R0; STC(R2,ESDTYPE(R1)); STC(R3,RLDFLAG(R1)); R0 := 8 + R1; FOUND: end; procedure STACKSEG(R4); begin comment STACK CURRENT SEG TO BE READY TO OPEN NEW SEG -- R0 = END OF ESD TABLE, R1 = START OF ESD TABLE, R5 = START OF SEGMENT TO STACK -- AT EXIT R5 = START OF NEW SEGMENT AND PREVSEG SET TO STACKED SEG; STM(R0,R4,PARAMSAVE); R2 := LASTINITIAL(R5) + INITIALEN(R2) + 5S and _2; R3 := R0 - R1; TABLEN(R2) := R3; R2 := R2 + 2; R0 := R2 + R3; MOVETABLE; R1 := R0 + 3S and _4; PREVSEG(R1) := R5; R5 := R1; LM(R0,R4,PARAMSAVE); end; procedure UNSTACKSEG(R4); begin comment UNSTACK SEG -- R1 = START OF ESD TABLE, R5 = START OF SEGMENT TO UNSTACK, AT EXIT R0 = END OF ESD TABLE; STM(R1,R4,PARAMSAVE(4)); R2 := R1; R1 := LASTINITIAL(R5) + INITIALEN(R1) + 5S and _2; R3 := TABLEN(R1); R1 := R1 + 2; R0 := R2 + R3; MOVETABLE; LM(R1,R4,PARAMSAVE(4)); end; $PAGE procedure OPENSEG(R4); begin comment OPEN NEW SEGMENT -- R5 = START OF SEGMENT, R2 = TYPE OF SEG, R3 = BASE REGISTER FOR SEG; $IFF M M STM(R0,R1,PARAMSAVE); $END M $IFT M M STM(R0,R3,PARAMSAVE); $END M SEGTYPE(R5) := R2; SEGBASEREG(R5) := R3; $IFF M M R1 := R5 + SEGHDLEN; LASTINITIAL(R5) := R1; R0 := R0-R0; $END M $IFT M M if TESTFLAG then begin if R2 > 10 then begin R3 := DATASTACK; R3 := @B3(4); if R3 = DSTAKBOT then begin RESET(TESTFLAG); goto X; end; DATASTACK := R3; end else begin R3 := PROCSTACK; R3 := @B3(4); if R3 = PSTAKBOT then begin RESET(TESTFLAG); goto X; end; PROCSTACK := R3; end; R0 := neg 1; DATAPTR(R3) := R0; end; X: R1 := R5 + SEGHDLEN; LASTINITIAL(R5) := R1; R0 := R0-R0; $END M COUNTER(R5) := R0; INITIALSTART(R1) := R0; INITIALEN(R1) := R0; R0 := BLOCK; BLOCKLEVEL(R5) := R0; $IFF M M LM(R0,R1,PARAMSAVE); $END M $IFT M M LM(R0,R3,PARAMSAVE); $END M end; $PAGE segment procedure CLOSESEG(R4); begin comment CLOSE CURRENT SEGMENT -- R5 = START OF SEGMENT, R0 = END OF ESD TABLE, R1 = START OF ESD TABLE; array 2 logical SAVE01; array 8 logical SAVE07; array 40 short integer CARD syn PBUF; integer CARDI syn PBUF; short integer ESDID, SEQNO; integer WORK syn CONWORK; byte DUMPLINE syn WBUF(17); procedure DUMPHALF(R1); begin UNPK(8,4,B2,B3); MVI(239,B2(8)); UNPK(8,4,B2(10),B3(4)); MVI(239,B2(18)); UNPK(8,4,B2(20),B3(8)); MVI(239,B2(28)); UNPK(8,4,B2(30),B3(12)); MVI(239,B2(38)); R2 := @B2(41); R3 := @B3(16); end; procedure PUNCHSEQ (R8); begin R0 := 1 + SEQNO; SEQNO := R0; CVD(R0,CONWORK); UNPK(3,7,CARD(76),CONWORK); SETZONE(CARD(79)); CARD(72/4) := SEGNAM; R0 := @CARD; PUNCH; end; procedure CARDOUT (R8); begin logical SAVE8; SAVE8 := R8; if R0 ^= 0 then begin CARD(10) := R0; PUNCHSEQ; end; R0 := R0-R0; R6 := @CARD; CARD(5/75) := CARD(4); R8 := SAVE8; end; procedure ESDPRINT(R8); begin comment PRINT ESD DICTIONARY ENTRY -- R6 + 16 = OBJECT ESD CARD ENTRY; STM(R0,R1,SAVE01); WBUFF(0/133) := BLANK; if C6(24) = ER then !-- EXTRN --! WBUF(40) := "EXTERNAL REFERENCE" else if C6(24) = WER then !-- WEAK EXTRN --! WBUF(40) := "WEAK EXT REFERENCE" else begin WBUF(40) := "ENTRY (XX) AT"; R1 := R1-R1; IC(R1,B6(24)); R1 := R1+R1; R1 := @ESDCODE(R1); WBUF(47/2) := B1; UNPK(4,2,WBUF(54),B6(26)); TR(3,WBUF(54),TRTABLE(_240)); WBUF(58) := " "; end; WBUF(30/8) := B6(16); PRINT; LM(R0,R1,SAVE01); end; $PAGE $IFF M M STM(R0,R7,SAVE07); R4 := SEGTYPE(R5); $END M $IFT M M procedure GENLABEL(R7); begin integer SAVE3; SAVE3 := R3; R3 := CARDNO(R5); CVD(R3,CONWORK); UNPK(5,3,WCARD(1),CONWORK(5)); SETZONE(WCARD(5)); WCARD := "#"; if R1 > 4S then begin SYMFIELD(R5+5/5) := WCARD; R1 := 10; end else begin R3 := @B5(R1+1); SYMFIELD(R3/5) := WCARD; R1 := @B1(6); end; RB(#0F,ORFIELD(R5)); EX(R1,SB(0,ORFIELD(R5))); R3 := SAVE3; end; procedure PUTNAME(R7); begin R6 := @CARD(20); R0 := 4; if B3 = "SEGN" then begin B6(0/7) := B3; R6 := @B6(7); R1 := 7; R0:= 11; end else begin R1 := R1 - R1; LOOP: if B3(0/1) ^= " " then begin B6(0/1) := B3; R3 := @B3(1); R6 := @B6(1); R0 := R0 + 1S; R1 := @B1(1); if R1 < 8S then goto LOOP; end; end; end; procedure SEARCH(R8); begin integer SAVE5; SAVE5 := R5; R2 := R5; while R2 > 0 do begin IC(R1,ORFIELD(R2)); R1 := R1 and 15; REDUCE(R1); R3 := R3 - R3; CLC(1,SYMFIELD(R2),"#B"); if ^= then begin R5 := SYMLINK(R2); RESET(SYM); while R5 > 0 do begin IC(R3,ORFIELD(R5)); R3 := R3 and 15; REDUCE(R3); if R1 = R3 then begin EX(R1,CLC(0,SYMFIELD(R5),SYMFIELD(R2))); if = then begin GENLABEL; SET(SYM); R1 := R3; end; end; R5 := SYMLINK(R5); end; if SYM then begin RESET(SYM); R5 := R2; GENLABEL; end; end; R2 := SYMLINK(R2); end; R5 := SAVE5; end; procedure CSECT(R8); begin R6 := PL360NO(R1); R6 := R6 * 10S; CARD := "`BSYMPL3 "; CARD(8/72) := CARD(7); R3 := @ESDNAME(R6); case R4 of begin begin CARD(16/4) := #10000000; PUTNAME; end; begin CARD(16/4) := #30000000; PUTNAME; end; null; begin R2 := CARDNO(R5); REDUCE(R2); CVD(R2,CONWORK); UNPK(5,3,CARD(22),CONWORK(5)); SETZONE(CARD(26)); CARD(16/6) := #200000007BC4X; R6 := @CARD(26); R0 := 10; R1 := 6; end; end; EX(R1,SB(0,CARD(16))); end; procedure OUTSYM(R7); begin R2 := R0 + R1; if R2 <= 55S then R2 := R2 - R2 else begin R2 := R2 - 55S; R1 := R1 - R2; end; EX(R1,MVC(0,B6,ORFIELD(R5))); R1 := @B1(1); R0 := R0 + R1; R6 := R6 + R1; if R0 = 56 then begin CARDOUT; CARD := "`BSYMPL3 "; CARD(8/64) := CARD(7); R6 := @CARD(16); if R2 ^= 0 then begin R3 := R5 + R1; EX(R2,MVC(0,B6,ORFIELD(R3))); R6 := R6 + R2; R0 := R2; end; end; R3 := FREESPACE; R2 := SYMLINK(R5); SYMLINK(R5) := R3; FREESPACE := R5; R5 := R2; end; procedure SYMPRINT(R7); begin integer STOP=_1, SAVE7; R0 := R0 - R0 =: SEQNO; SAVE7 := R7; if R1 ^= DATAESDADR then begin R6 := PROCSTACK; if R4 = 3S then begin R6 := R6 - 4S; R5 := DATAPTR(R6); R2 := SYMLINK(R5); DATAPTR(R6) := R2; PROCSTACK := R6; R2 := FREESPACE; FREESPACE := R5; B5 := R2; goto FINISH; end; R5 := DATAPTR(R6); R0 := STOP; while R5 > 0 do begin R2 := SYMLINK(R5); SYMLINK(R5) := R0; R0 := R5; R5 := R2; end; if R6 = DSTAKBOT then begin R5 := R0; R6 := R6 - 4S; end else begin R6 := R6 - 4S; R3 := DATAPTR(R6); R2 := SYMLINK(R3); DATAPTR(R6) := R2; SYMLINK(R3) := R0; R5 := R3; AAFIELD(R5/3) := #000000X; end; PROCSTACK := R6; CSECT; R1 := R1 - R1; SEARCH; while R5 > 0 do begin IC(R1,ORFIELD(R5)); R1 := R1 and 15; R1 := @B1(3); OUTSYM; end; end else begin R6 := DATASTACK; R5 := DATAPTR(R6); R6 := R6 - 4S; DATASTACK := R6; if R4 = 3S then begin R6 := FREESPACE; while R5 > 0 do begin R2 := SYMLINK(R5); SYMLINK(R5) := R6; R6 := R5; R5 := R2; end; FREESPACE := R6; goto FINISH; end; if R5 = STOP then goto FINISH; R0 := STOP; while R5 > 0 do begin R2 := SYMLINK(R5); SYMLINK(R5) := R0; R0 := R5; R5 := R2; end; R5 := R0; CSECT; R1 := R1 - R1; SEARCH; while R5 > 0 do begin IC(R1,ORFIELD(R5)); R3 := R1; R1 := R1 and 15; REDUCE(R1); CLI(#04,FFIELD(R5)); if = then begin LDFIELD(R5+1/5) := MFIELD(R5); R4 := 2; end else begin LDFIELD(R5+1/4) := MFIELD(R5+1); R4 := 1; end; if R1 ^= 9S then begin R2 := R5 + R1; B2(11/6) := FFIELD(R5); end; CLI(#C0,ORFIELD(R5)); if >= then R1 := @B1(R4+8) else R1 := @B1(R4+5); OUTSYM; end; end; CARDOUT; FINISH: R7 := SAVE7; end; $PAGE STM(R0,R7,SAVE07); R4 := SEGTYPE(R5); if TESTFLAG then if RUNFLAG or GENDECK then begin SYMPRINT; LM(R0,R7,SAVE07); R4 := SEGTYPE(R5); end; $END M if R4 >= 3S then goto FIN; OUTPUTCARD; !-- LIST CURRENT SEGMENT --! WBUFF(0/133) := BLANK; SETZONE(CARRCONT); WBUF(27) := "SEGMENT"; R2 := PL360NO(R1); CVD(R2,CONWORK); UNPK(2,7,WBUF(35),CONWORK); SETZONE(WBUF(37)); WBUF(40) := "NAME ="; R2 := R2 * 10S; R2 := @ESDNAME(R2); WBUF(47/10) := B2; R6 := 1; if R5 = R9 and R4 = R6 then !-- PROGRAM SEGMENT --! begin R6 := NSEGNO; R14 := R6 * 10S; R14 := @ESDNAME(R14); while R14 > R2 and SEGNAM(0/4) ^= B14 do begin REDUCE(R6); R14 := R14 - 10S; end; NSEGNO := R6; !-- NEXT SEGMENT --! end; WBUF(58) := "LENGTH ="; UNPK(4,4,WBUF(67),COUNTER(R5)); TR(3,WBUF(67),TRTABLE(_240)); WBUF(71) := " BASE REG ="; R2 := SEGBASEREG(R5); CVD(R2,CONWORK); UNPK(1,7,WBUF(84),CONWORK); SETZONE(WBUF(85)); PRINT; if TM(4,TRACE); OFF then goto X; SETZONE(CARRCONT); R7 := LASTINITIAL(R5); R5 := R5 + SEGHDLEN; WBUFF(0/133) := BLANK; while R5 <= R7 do begin R4 := R4-R4; R6 := INITIALEN(R5); while R4 < R6 do begin R2 := R4 + INITIALSTART(R5); WORK := R2; MVI(239,DUMPLINE(8)); DUMPLINE(9/79) := DUMPLINE(8); UNPK(4,4,DUMPLINE,WORK); R3 := @B5(R4+4); TR(3,DUMPLINE,TRTABLE(_240)); CLC(27,B3,B3(4)); if = then begin DUMPLINE(4) := " TO"; UNPK(8,4,DUMPLINE(18),B3); MVI(239,DUMPLINE(26)); L1: R4 := R4 + 32S; if R4 < R6 then begin R3 := @B5(R4); CLC(31,B3,B3(4)); if = then goto L1; end; if R4 > R6 then R4 := R6; R2 := R4 + INITIALSTART(R5) - 4; WORK := R2; UNPK(4,4,DUMPLINE(8),WORK); MVI(239,DUMPLINE(12)); TR(79,DUMPLINE(8),DTRTABLE(_239)); PRINT; DUMPLINE(5/2) := DUMPLINE(4); end else begin DUMPLINE(4) := " "; R0 := R6 - R4; R4 := @B4(32); R2 := @DUMPLINE(8); if R0 >= 32S then begin DUMPHALF; DUMPHALF; end else begin if R0 >= 16S then begin R0 := R0 - 16S; DUMPHALF; end; while R0 >= 4 do begin UNPK(8,4,B2,B3); MVI(239,B2(8)); R0 := R0 - 4; R2 := @B2(10); R3 := @B3(4); end; while R0 > 0 do begin UNPK(2,1,B2,B3); R0 := R0 - 1S; R2 := @B2(2); R3 := @B3(1); end; MVI(239,B2); end; TR(79,DUMPLINE(8),DTRTABLE(_239)); PRINT; end; end; R5 := @B5(R6+5) and _2; end; X: WBUFF(0/133) := BLANK; SETZONE(CARRCONT); if ^GENDECK then goto FIN; !-- PUNCH CURRENT SEGMENT AS CSECT --! LM(R0,R7,SAVE07); R2 := R0; if TM(1,TRACE); ON then begin WBUF(27) := "EXTERNAL SYMBOL DICTIONARY"; PRINT; end; R0 := R0-R0; ESDID := R0; R6 := @CARD; R7 := " "; $IFF M M SEQNO := R0; !-- CLEAR SEQUENCE NUMBER --! $END M $IFT M M if ^TESTFLAG then SEQNO := R0; $END M !-- *** PUNCH ESD CARDS *** --! CARD := "`BESD "; CARD(5/75) := CARD(4); while R1 < R2 do begin if ESDTYPE(R1) ^= LD then !-- LD HAS NO ESDID --! begin R3 := ESDLINK(R1); if R3 >= 0 then begin R3 := R3 + SAVE07(4); R3 := ESDLINK(R3); end else begin R3 := 1 + ESDID; ESDID := R3; end; ESDLINK(R1) := R3; if ESDTYPE(R1) ^= RLD and R7 = " " then R7 := R3; end; if ESDTYPE(R1) ^= RLD then begin R3 := PL360NO(R1)*10S; R3 := @ESDNAME(R3); B6(16/8) := B3; R3 := R3-R3; R4 := BLANK; if ESDTYPE(R1) = SD then begin !-- CSECT --! R3 := R3-R3; R4 := COUNTER(R5); goto X; end; if ESDTYPE(R1) = LD then begin !-- ENTRY --! R3 := RLDADDR(R1); R4 := 1; goto X; end; if ESDTYPE(R1) = ER then goto X; !-- EXTRN --! if ESDTYPE(R1) = WER then goto X; !-- WEAK EXTRN --! if ESDTYPE(R1) = CM then begin !-- COMMON --! R3 := R3-R3; R4 := COUNTER(R5); goto X; end; if ESDTYPE(R1) = XCM then begin !-- XCOMMON (EXTERNAL BLANK COMMON) --! R3 := R3-R3; R4 := R4-R4; goto X; end; X: STM(R3,R4,B6(24)); if ESDTYPE(R1) = XCM then C6(24) := CM else C6(24) := ESDTYPE(R1); C6(28) := " "; if TM(1,TRACE); ON or C6(24) ^= ER then ESDPRINT; R0 := R0 + 16S; R6 := R6 + 16S; if R0 = 48S then begin CARD(14) := R7; CARDOUT; R7 := " "; end; end; R1 := R1 + 8S; end; CARD(14) := R7; CARDOUT; !-- *** PUNCH TXT CARDS *** --! CARD := "`BTXT "; CARD(5/75) := CARD(4); R7 := LASTINITIAL(R5); R5 := R5 + SEGHDLEN; while R5 <= R7 do begin R1 := INITIALSTART(R5); R2 := INITIALEN(R5); R4 := 5 + R5 + R2 and _2; R0 := 56; while R2 >= R0 do begin CARD(14/2) := 1S; CARDI(4) := R1; CARD(4) := " "; CARD(16/56) := B5(4); CARDOUT; R0 := 56; R5 := R5 + R0; R1 := R1 + R0; R2 := R2 - R0; end; if R2 > 0 then begin R0 := R2; R2 := R2 - 1S; CARD(14/2) := 1S; CARDI(4) := R1; CARD(4) := " "; EX(R2,MVC(0,CARD(16),B5(4))); CARDOUT; end; R5 := R4; end; !-- *** PUNCH RLD CARDS *** --! CARD := "`BRLD "; CARD(5/75) := CARD(4); LM(R0,R1,SAVE07); R2 := R0; R0 := R0-R0; R6 := @CARD; while R1 < R2 do begin R4 := RLDADDR(R1); if ESDTYPE(R1) ^= LD and R4 >= 0 then begin if R0 = 56S then CARDOUT; R3 := ESDLINK(R1); H6(16) := R3; H6(18) := 1S; B6(20) := R4; C6(20) := RLDFLAG(R1); R6 := R6 + 8S; R0 := R0 + 8S; end; R1 := R1 + 8S; end; CARDOUT; !-- *** PUNCH END CARD *** --! CARD := "`BEND "; CARD(5/75) := CARD(4); R1 := SAVE07(4); R1 := PL360NO(R1); if R1 = 1S then begin CARD(5/3) := 0; CARD(14/2) := 1S; $IFT end; CARD(39/6) := HEADER(1); CARD(45/16) := HEADER(94); $END $IFF end; if OSSYSTEM then CARD(32/39) := IDRDATA else begin CARD(39/6) := HEADER(1); CARD(45/16) := HEADER(94); end; $END PUNCHSEQ; SETZONE(CARRCONT); WBUFF(0/133) := BLANK; FIN: LM(R0,R7,SAVE07); end; $PAGE procedure OPENPROCSEG(R4); begin !-- OPEN A NEW PROCEDURE SEGMENT --! !-- T(R7) = TYPE OF PROCEDURE SEGMENT --! !-- V(R7) = NAMETABLE ENTRY ADDRESS --! !- V(R7+4) = RETURN REGISTER FOR PROCEDURE --! integer SAVE; SAVE := R4; INCRSEGNO; R0 := LC; R1 := LASTINITIAL(R9); INITIALEN(R1) := R0; R0 := PROGESDEND; R1 := PROGESDADR; R5 := R9; STACKSEG; R9 := R5; R2 := T(R7); R3 := PROGREG; OPENSEG; R0 := R1; R2 := SD; R3 := VTYPE; R4 := SEGNO; FINDESDENTRY; PROGESDEND := R0; R2 := 14 + N3; R0 := N4; N4 := R2; N3 := R2; R2 := R2 + LABELBASE; B2(0/12) := ZERO; LABELADR(R2) := R0; R0 := LITX; LABEL(R2+2) := R0; R0 := CSEGNO; LABEL(R2+8) := R0; CSEGNO := R4; R0 := N6; R1 := 4 + N5 =: N5 =: N6 + BRANCHBASE; BRANCHADR(R1) := R0; R4 := SAVE; end; procedure DATASEGERROR(R4); begin !-- NO DATA SEGMENT FOR DECLARED VARIABLE -- OPEN DUMMY --! integer SAVER4; SAVER4 := R4; XR := 29; ERROR; RESET(NODATASEG); INCRSEGNO; R1 := DATAESDADR; R2 := 4; R3 := 13; R5 := R10; OPENSEG; R0 := R1; R2 := SD; R3 := ATYPE; R4 := SEGNO; FINDESDENTRY; DATAESDEND := R0; R4 := SAVER4; end; $IFF $PAGE procedure ENTEREF (R1); begin array 6 integer SAVE; STM(R0,R5,SAVE); if VALUE(3) = " " and VALUE(1) >= "0" then if VALUE(2) = " " or VALUE(2) >= "0" then if VALUE = "R" or VALUE = "B" or VALUE = "C" or VALUE = "H" then goto Y; R3 := 1 + SYMTYPE and #E; R5 := R5-R5; IC(R5,VALUE); IC(R5,ALPHASH(R5-193)); R5 := R5 + LENHASH(R3-2); R3 := R3 - 1; R4 := REFCHAIN(R5); while R4 >= 0 do begin R4 := R4 + REFSTART; EX(R3,CLC(0,REFNAME(R4),VALUE)); if = then goto X; R4 := LINKN(R4); end; R1 := REFLEN + REFN1; if R1 > REFN2 then begin SET(REFOUT); goto Y; end; R4 := REFN1 + REFSTART; REFNAME(R4/10) := VALUE; R2 := REFN2; LINKF(R4) := R2; LINKL(R4) := R2; R0 := REFCHAIN(R5); LINKN(R4) := R0; R0 := REFN1; REFCHAIN(R5) := R0; REFN1 := R1; X: R0 := CARDCOUNT; LASTCARD := R0; R0 := REFN2; R1 := REFSTART; R2 := LINKL(R4) + R1; LINKL(R4) := R0; R4 := REFLINK(R2) or R0; REFLINK(R2) := R4; !-- ENDCHAIN IS 0 IN BITS 14-31 --! R1 := R1+R0; R2 := CARDCOUNT shll 18; REFLINK(R1) := R2; R0 := R0 - 4; if R0 < REFN1 then SET(REFOUT) else REFN2 := R0; Y: LM(R0,R5,SAVE); end; $PAGE procedure PRINTREFS(R1); begin array 10 integer SAVE; STM(R0,R9,SAVE); OUTPUTCARD; R1 := REFN1; if R1 ^= 0 then begin R8 := R1; R7 := REFLEN; R9 := REFSTART - R7; X1: R0 := R0-R0; R1 := R1 / R7 shrl 1 * R7; if R1 = 0 then goto X5; R2 := R8 - R1; R3 := R7; X2: R4 := R3; X3: R5 := R9 + R4; R6 := R5 + R1; CLC(9,REFNAME(R5),REFNAME(R6)); if <= then goto X4; XC(REFMOV,LINKF(R6),LINKF(R5)); XC(REFMOV,LINKF(R5),LINKF(R6)); XC(REFMOV,LINKF(R6),LINKF(R5)); if R4 <= R1 then goto X4; R4 := R4 - R1; goto X3; X4: if R2 = R3 then goto X1; R3 := R3 + R7; goto X2; X5: HEADER(8) := "ROSS REFERENCE"; SUBHEAD(1/132) := SUBHEAD; CARRCONT := "1"; if REFOUT then !-- XREF TABLE FULL --! begin WBUFF(0/133) := BLANK; R1 := LASTCARD; WBUF := "DECLARATIONS AND REFERENCES THROUGH LINE"; CVD(R1,CONWORK); UNPK(3,7,WBUF(41),CONWORK); SETZONE(WBUF(44)); PRINT; CARRCONT := "0"; end; WBUFF(0/133) := BLANK; WBUF(17) := "SYMBOLS,"; R8 := #3FFFF; R1 := REFN1 shrl 1; CVD(R1,CONWORK); WBUF(12) := "`0`0`1`0"; ED(4,WBUF(11),CONWORK(5)); WBUF(33) := "REFERENCES"; R1 := REFN3--REFN2 shrl 2 * 10S; CVD(R1,CONWORK); WBUF(26) := "`0`0`0`0`1`0"; ED(6,WBUF(25),CONWORK(4)); PRINT; CARRCONT := "0"; R9 := REFSTART; R7 := R7-R7; while R7 < REFN1 do begin WBUFF(0/133) := BLANK; OC(0,CARRCONT,XREFCC); R4 := R7 + R9; WBUF(0/10) := REFNAME(R4); R4 := LINKF(R4); X: R6 := R6-R6; R5 := @WBUF(12); while R6 < 108S and R4 ^= 0 do begin R4 := R4 + R9; R4 := REFLINK(R4); R3 := R4 shrl 18; R4 := R4 and R8; $IFT M M CVD(R3,CONWORK); B5(0/6) := EDMSK; ED(5,B5,CONWORK(5)); R6 := @B6(6); R5 := @B5(6); $END M $IFF M M CVD(R3,CONWORK); UNPK(3,7,B5,CONWORK); SETZONE(B5(3)); R6 := @B6(6); R5 := @B5(6); $END M end; if R6 ^= 0 then begin PRINT; WBUFF(0/133) := BLANK; goto X; end; R7 := @B7(REFLEN); end; end; HEADER(8) := "OMPILATION "; LM(R0,R9,SAVE); end; $END $PAGE segment procedure INSYMBOL(R8); !-- USES R0 THRU R6 AND R8 --! begin !-- DEFINE PROCEDURES USED ONLY BY INSYMBOL --! segment procedure GETCARD(R4); begin logical SAVE14; !-- READ NEXT CARD AND CHECK OPTIONS --! procedure GETPARM (R14); begin SAVE14:=R14; IC(R0,CBUF(7)); R0:=R0 and #F; CLI(" ",CBUF(8)); if ^= then begin IC(R14,CBUF(8)); R14:=R14 and #F; R0:=R0*10S+R14; end; R14:=SAVE14; end; procedure PRNTDOLR (R14); if LISTFLAG then $IFT M M if TM(DOLR,FLGS); ON then $END M $IFF M M if TM(DOLR,FLGS); OFF then WDDISP(5/6) := CBUF else $END M begin SAVE14 := R14; WBUFF(0/WHDRLN+3) := BLANK; WCARD(0/72) := CBUF; WSEQ(0/8) := CBUF(72); $IFT M M WLINENUM(0/10) := CBUF(80); $END M PRINT; R14 := SAVE14; end; OUTPUTCARD; R0:=BEGENDLVL; CBEGENDLVL:=R0; TOP: R0 := @CBUF; READ; if ^= then begin if ^NOPROGSEG then begin R6 := R6-R6; XR := 20; ERROR; end; ERROREXIT; end; CLI("$",CBUF); if = then begin CLI("0",CBUF(1)); if >= then begin TRACE(0/1) := CBUF(1); NI(7,TRACE); TR(0,TRACE,#0001030704050602X); goto PDC; end; CLI("#",CBUF(4)); if = then begin if NOPROGSEG then begin SEGNAM(0/3) := CBUF(1); ESDNAME(0/3) := SEGNAM; ESDNAME(10/3) := SEGNAM; goto PDC; end; goto DOLERR; end; R0 := CBUF; if R0 = "$NOL" then begin PRNTDOLR; R0 := 1+LIST; LIST := R0; goto TOP; $IFT M M end; if R0 = "$TES" then begin R0 := R0 - R0; if R0 ^= FREESPACE then SET(TESTFLAG); goto PDC; $END M end; if CBUF(1) = "IF" then !-- $IF-STATEMENT --! if CBUF(3) = "T" or CBUF(3) = "F" or CBUF(3) = "J" then begin PRNTDOLR; NI(#3F,CBUF(5)); R14 := R14-R14; IC(R14,CBUF(5)); CLI("J",CBUF(3)); if = then goto L; IC(R14,CONDTAB(R14)); STC(R14,CONDCK); CLI("F",CBUF(3)); if = then XI(#FF,CONDCK); if CONDCK then goto TOP; NI(#3F,CBUF(7)); IC(R14,CBUF(7)); L: STC(R14,CONDCK); COND: R0 := @CBUF; READ; if ^= then begin if ^NOPROGSEG then begin R6 := R6-R6; XR := 20; ERROR; end; ERROREXIT; end; CLC(3,CBUF,"$END"); if ^= then goto COND; IC(R0,CBUF(5)); NI(#3F,CBUF(5)); CLC(0,CBUF(5),CONDCK); if ^= then goto COND; STC(R0,CBUF(5)); goto PDC; end; if R0 = "$TIT" then begin if LISTFLAG then CARRCONT := "1"; HEADER(30/63) := CBUF(9); SUBHEAD(1/93) := SUBHEAD; goto TOP; end; if R0 = "$STI" then begin if LISTFLAG then CARRCONT := "1"; SUBHEAD(30/63) := CBUF(9); goto TOP; end; if R0 = "$PAG" then begin R0 := "$EJE"; CBUF(0/2) := CBUF(6); CBUF(7/2) := CBUF; end; if R0 = "$EJE" then begin GETPARM; if R0 = 0 then R0 := 1000; R0 := R0 + LINECOUNT; if R0 > MAXLINE and LISTFLAG then CARRCONT := "1"; goto TOP; end; if R0 = "$SPA" and LISTFLAG and LINECOUNT= R14 then CARRCONT := "1" else begin while R0 > 1 do begin SAVE0 := R0; CARRCONT := "0"; PRINT; R0 := SAVE0 - 2; end; if R0 = 0 then CARRCONT := " " else CARRCONT := "0"; end; goto TOP; $IFF end; if R0="$XRE" then begin R0 := R0-R0; if R0 ^= REFSTART then SET(XREF); if CBUF(6) = "1" then XREFCC := " " else if CBUF(6) = "2" then XREFCC := "0"; goto PDC; end; if R0 = "$NOX" then begin RESET(XREF); goto PDC; end; if R0 = "$COP" then begin external procedure COPY (R14); null; R0 := @CBUF(6); COPY; goto PDC; $END end; if R0 = "$SET" or R0 = "$RES" then begin R14 := R14-R14; R0 := #FF; CLI("R",CBUF(1)); if = then begin IC(R14,CBUF(7)); R0 := R0-R0; end else IC(R14,CBUF(5)); R14 := R14 and #3F; STC(R0,CONDTAB(R14)); goto PDC; end; if R0 = "$ON " then begin SB(DOLR,FLGS); goto PDC; end; if R0 = "$OFF" then begin PRNTDOLR; RB(DOLR,FLGS); goto TOP; end; if R0 = "$GEN" then begin RESET(GENFLAG); goto PDC; end; if R0 = "$OPT" then begin SB(#80,OPTFLAG); goto PDC; end; if R0 = "$NOO" or R0 = "$NOP" then begin RB(#80,OPTFLAG); goto PDC; end; if R0 = "$DBG" then begin DBGFLGS(0/1) := CBUF(5) and 7; goto PDC; end; if R0 = "$LIS" then begin R0 := LIST-1; LIST := R0; goto PDC; end; if R0 = "$OS " then begin SET(OSSYSTEM); goto PDC; end; if R0 = "$DOS" then begin RESET(OSSYSTEM); goto PDC; end; if R0 = "$BOL" then begin OVER := #80; goto PDC; end; if R0 = "$UND" then begin OVER := #C0; goto PDC; end; if R0 = "$NOU" or R0 = "$NOB" then begin RESET(OVER); goto PDC; end; if R0 = "$NOG" then begin SB(NOGO,FLGS); goto PDC; end; if R0 = "$ASC" then begin SB(ASCI,FLGS); goto PDC; end; if R0 = "$BAS" then begin R14 := CARDCOUNT; if R14 = 0 then begin PACK(7,1,CONWORK,CBUF(6)); OI(#0C,CONWORK(7)); CVB(R0,CONWORK); if R0 ^= 0 and R0 <= 15 then begin PROGREG := R0; R0 := R0 shll 12; PTAG := R0; goto PDC; end; end; goto DOLERR; end; PDC: PRNTDOLR; goto TOP; DOLERR: WBUFF(0/WHDRLN+3) := BLANK; WCARD(0/72) := CBUF; WSEQ(0/8) := CBUF(72); WBUF(2) := "ILLEGAL $CARD"; R0 := 1 + ERRCOUNT =: ERRCOUNT; RESET(RUNFLAG); PRINT; goto TOP; end; R6 := R6-R6; if BEGENDFLAG then begin R0:=CBEGENDLVL; CVD(R0,CONWORK); UNPK(1,7,WBGNEND,CONWORK); SETZONE(WBGNEND(1)); RESET(BEGENDFLAG); end else WBGNEND := " "; PRNT := LISTFLAG; R1 := DATAESDADR; R1 := PL360NO(R1); CVD(R1,CONWORK); UNPK(2,7,WDSEG,CONWORK); UNPK(4,4,WDDISP,DC); TR(3,WDDISP,TRTABLE(_240)); SETZONE(WDSEG(2)); WDDISP(4) := " "; R0 := CSEGNO; CVD(R0,CONWORK); UNPK(2,7,WPSEG,CONWORK); UNPK(4,4,WPDISP,LC); TR(3,WPDISP,TRTABLE(_240)); SETZONE(WPSEG(2)); WPDISP(4) := " "; R1 := 1 + CARDCOUNT; CARDCOUNT := R1; CVD(R1,CONWORK); $IFT M M WCRDCNT(0/6) := EDMSK; ED(5,WCRDCNT,CONWORK(5)); ERRWCRDCNT(0/6) := WCRDCNT; ERRORBUF(0/10) := CBUF(80); $END M $IFF M M UNPK(3,7,WCRDCNT,CONWORK); SETZONE(WCRDCNT(3)); R1 := 10 * R0; R1 := @ESDNAME(R1); SUBHEAD(113/8) := B1; $END M if TM(#80,OVER); ON then !-- ESTABLISH OVERPRNT BUFFER --! begin RESET(OBUF); OBUF(1/71) := OBUF; end; end; procedure NEXTCHAR(R4); begin R6 := @B6(1); if R6 > 71S then begin array 4 integer SAVER1R4; STM(R1,R4,SAVER1R4); GETCARD; LM(R1,R4,SAVER1R4); end; R0 := R0-R0; IC(R0,CBUF(R6)); end; !-- BEGIN INSYMBOL --! TOP: R2 := 71 - R6; R1 := @CBUF(R6); EX(R2,TRT(0,B1,SCANTAB2)); if = then begin GETCARD; goto TOP; end; R0 := @CBUF; R6 := R1 - R0; R0 := R0-R0; IC(R0,CBUF(R6)); VALUE(0/12) := BLANK; if R2 < 10S then case R2 of begin !-- R2 HAS CODE FOR TYPE OF SYMBOL --! begin !-- CODE 1 -- READ A NUMBER --! procedure ACCUM (R4); !-- ACCUMULATE A DIGIT --! begin logical SAVE4; SAVE4 := R4; if R2 >= 214748364 then R1 := R1 + 1 else begin R0 := R0 and #F; R4 := R2; R5 := R3; SLDL (R4, 1); SLDL (R2, 3); R2 := R2 + R4; R3 := R3 ++ R5; if > or OVERFLOW then R2 := R2 + 1; R3 := R3 ++ R0; if > or OVERFLOW then R2 := R2 + 1; end; NEXTCHAR; R4 := SAVE4; end; XC (7, VALUEF, VALUEF); !-- CLEAR IN CASE INTEGER --! RESET (SIGN); if R0 = "_" then begin SET (SIGN); NEXTCHAR; if R0 < "0" or R0 > "9" then begin XR := 0; ERROR; goto TOP; end; end; TYPEFLAG := 1; R2 := R2 - R2; R3 := R0 and #F; NEXTCHAR; R1 := R2; while R0 >= "0" and R0 <= "9" do ACCUM; !-- WE ARE OVER THE INITIAL STRING OF DIGITS --! if R0 = "." then begin !-- A DECIMAL POINT HAS BEEN FOUND --! TYPEFLAG := 3; NEXTCHAR; while R0 >= "0" and R0 <= "9" do begin R1 := R1 - 1; ACCUM; end; end; !-- END OF DECIMAL POINT PROCESSING --! if R0 = "'" then !-- IS THERE AN EXPONENT? --! begin NEXTCHAR; RESET (EXPOSIGN); TYPEFLAG := 3; if R0 = "_" then begin SET (EXPOSIGN); NEXTCHAR; end; if R0 < "0" or R0 > "9" then begin XR := 14; ERROR; end; R5 := R5 - R5; while R0 >= "0" and R0 <= "9" do begin R0 := R0 and #F; if R5 < 214748364 then R5 := R5 * 10S + R0; NEXTCHAR; end; if EXPOSIGN then R1 := R1 - R5 else R1 := R1 + R5; end; !-- CORRECT EXPONENT NOW IN R1 --! R5 := #40 or R0; !-- Force upper case --! if TYPEFLAG = 1 and R5 = "S" then begin TYPEFLAG := 0; NEXTCHAR; end else if TYPEFLAG = 1 and R5 = "X" then begin TYPEFLAG := 4; NEXTCHAR; end else if R5 = "L" then begin TYPEFLAG := 2; NEXTCHAR; end else if R5 = "R" then begin TYPEFLAG := 3; NEXTCHAR; end; XR := 19; !-- ONLY OVERFLOWS POSSIBLE NOW --! if TYPEFLAG ^= 2 and TYPEFLAG ^= 3 then !-- INTEGER CASE --! begin if R2 ^= 0 then ERROR else if R3 < 0 then if ^SIGN then ERROR else if R3 ^= #80000000 then ERROR; if SIGN then R3 := neg R3; if TYPEFLAG = 0 then begin if R3 > 32767S or R3 < _32768S then begin ERROR; R3 := R3 shll 16 shra 16; end; end else if TYPEFLAG = 4 then begin if R3 < 0 or R3 > 255S then begin ERROR; R3 := R3 and #000000FF; end; end; VALUE := R3; end else begin !-- REAL OR LONG REAL --! long real FIRST = #5600000000000000L, SECOND = #4E00000000000000L; integer LEFT syn FIRST (4), RIGHT syn SECOND (4); long real FACT syn B4; long real TEN = 10L, MILLION = 1000000L; byte SCALED syn EXPOSIGN; long real X syn VALUEF; procedure SCALEUP (R5); begin R15 := R15 or #FF000000; DRAIN; F45 := F45 - F45; F4 := neg F0; F45 := F45 + F01; F23 := F23 + F45; F01 := F01 - F45 * FACT; F23 := F23 * FACT; DRAIN; if R15 > 0 then !-- SET BY PROGCHECK ROUTINE --! begin R1 := R1 - R1; F01 := #7FFFFFFFFFFFFFFFL; F23 := F23 - F23; ERROR; end; R15 := R15 and #00FFFFFF; end; procedure SCALEDOWN (R5); if F01 = 0L and F23 = F01 then R1 := R1 - R1 !-- UNDERFLOW --! else begin X := F01; F01 := F01 / FACT; F67 := F67 - F67; F6 := F0; F45 := neg F67 + F01 * FACT; F67 := F67 * FACT - X + F45; F23 := F23 - F67 / FACT; end; LEFT := R2; F01 := FIRST + 0L; RIGHT := R3; F23 := SECOND + 0L; F45 := F01; F01 := F01 + F23; if ^= then !-- NOT ZERO --! begin F45 := F45 - F01; F23 := F23 + F45; RESET (SCALED); if R1 < 0 then begin SET (SCALED); F01 := F01 / #3310000000000000L; F23 := F23 / #3310000000000000L; end; R4 := @MILLION; !-- SCALE UP BY 10**6 --! while R1 >= 6 do begin R1 := R1 - 6; SCALEUP; end; R4 := @TEN; !-- SCALE UP BY 10 --! while R1 >= 1 do begin R1 := R1 - 1; SCALEUP; end; R4 := @MILLION; !-- SCALE DOWN BY 10**6 --! while R1 <= _6 do begin R1 := R1 + 6; SCALEDOWN; end; R4 := @TEN; !-- SCALE DOWN BY 10 --! while R1 <= _1 do begin R1 := R1 + 1; SCALEDOWN; end; !-- NOW ROUND TO LONG REAL --! F45 := neg F01 - F23; F01 := F01 + F45 + F23; F0 := F0 + F0; F01 := F01 - F45; if SCALED then F01 := F01 / #4F10000000000000L; if F01 = 0L then ERROR; !-- UNDERFLOW --! end; VALUEF := F01; !-- STORE LONG REAL VALUE --! if TYPEFLAG = 3 then !-- ROUND TO REAL --! if F01 >= #7FFFFFFF80000000L then begin ERROR; VALUEF(0/8) := #7FFFFFFF00000000L; end else begin XC (2, VALUEF (1), VALUEF (1)); F01 := F01 + VALUEF; VALUEF := F01; XC (3, VALUEF (4), VALUEF (4)); end; !-- END OF ROUNDING ROUTINE --! if SIGN then OI (#80, VALUEF); end; R5 := NUMBERSYMBOL; end; begin !-- CODE 2 -- READ AN IDENTIFIER --! R3 := @OBUF(R6); !-- ID START FOR OVERPRNT --! R2-R2; while R0>="a" or R0="_" or R0="$" or R0="#" do begin if R2 < 10S then !-- Allows certain nationals --! begin R1 := #40 or R0; STC(R1,VALUE(R2)); R2 := @B2(1); end; if R6 = 71S then begin R6 := @B6(1); R0 := " "; end else NEXTCHAR; end; SYMTYPE := R2; if R2 < 10S then case R2 of begin !-- CHECK FOR RESERVED WORDS OF LENGTH R2 --! begin !-- NO TERMINALS OF LENGTH ONE --! end; begin R1 := IVALUE; for R5 := R5--R5 step 2S until 6S do if R1 = WORD2(R5) then begin B3(0/2) := OMSK; R5 := R5 shrl 1 + FT2; goto Y; end; !-- TERMINALS OF LENGTH TWO --! end; begin R1 := VALUE; for R5 := R5-R5 step 4S until 16S do if R1 = WORD3(R5) then begin B3(0/3) := OMSK; R5:=R5 shrl 2 + FT3; R2:=ENDSYMBOL-R5; if = then begin SET(BEGENDFLAG);R2:=BEGENDLVL-1; BEGENDLVL:=R2; $IFT M M if TESTFLAG then begin R0 := LC; R4 := R8; R1 := 4; ENTERSYMLABEL; R8 := R4; end; $END M end; goto Y; end; !-- TERMINALS OF LENGTH THREE --! end; begin R1 := VALUE; for R5 := R5-R5 step 4 until 40 do if R1 = WORD4(R5) then begin B3(0/4) := OMSK; R5 := R5 shrl 2 + FT4; goto Y; end; for R5 := R5-R5 step 4 until 12 do if R1 = SHIFTWORD(R5) then begin B3(0/4) := OMSK; R5 := R5 shrl 2 + 8S; VALUE := R5; R5 := SHIFTOP; goto Y; end; !-- TERMINALS OF LENGTH FOUR --! end; begin R1 := @WORD5; R2 := @WORD6; R5 := R1; while R5 < R2 do begin if VALUE(0/5) = B5 then begin B3(0/5) := OMSK; R5:=R5-R1 shrl 3 + FT5; R2:=BEGINSYMBOL; if R5 ^= R2 then goto Y; SET(BEGENDFLAG); R2:=1+BEGENDLVL; BEGENDLVL:=R2; $IFT M M if TESTFLAG then begin R0 := LC; R1 := 2; R4 := R8; ENTERSYMLABEL; R8 := R4; end; $END M goto Y; end; R5 := @B5(8); end; !-- TERMINALS OF LENGTH FIVE --! end; begin R1 := @WORD6; R2 := @WORD7; R5 := R1; while R5 < R2 do begin if VALUE(0/6) = B5 then begin B3(0/6) := OMSK; R5:=R5-R1 shrl 3 + FT6; goto Y; end; R5 := @B5(8); end; !-- TERMINALS OF LENGTH SIX --! end; begin if VALUE = "COMMENT" then begin B3(0/7) := OMSK; if R6 > 71S then NEXTCHAR; SCANTAB1(#5E) := 1; !-- Look for semicolon --! R1 := @CBUF(R6); R2 := 71 - R6; COMLOOP: EX(R2,TRT(0,B1,SCANTAB1)); if = then begin GETCARD; R2 := 71; R1 := @CBUF; goto COMLOOP; end else if > then GETCARD else begin R0 := @CBUF(_1); R6 := R1 - R0; end; RESET(SCANTAB1(#5E)); goto TOP; end; R1 := @WORD7; R2 := @WORD8; R5 := R1; while R5 < R2 do begin if VALUE(0/7) = B5 then begin B3(0/7) := OMSK; R5 := R5-R1 shrl 3 + FT7; goto Y; end; R5 := @B5(8); end; !-- TERMINALS OF LENGTH SEVEN AND COMMENT --! end; begin R1 := @WORD8; R2 := @WORD9; R5 := R1; while R5 < R2 do begin if VALUE(0/8) = B5 then begin B3(0/8) := OMSK; R5 := R5-R1 shrl 3 + FT8; goto Y; end; R5 := @B5(8); end; !-- TERMINALS OF LENGTH EIGHT --! end; begin if VALUE(0/9) = WORD9 then begin B3(0/9) := OMSK; R5 := FT9; goto Y; end; if VALUE(0/9) = WORD9(12) then begin B3(0/9) := OMSK; R5 := 1 + FT9; goto Y; end; !-- TERMINALS OF LENGTH NINE --! end; end; R5 := IDENTSYMBOL; Y: if R6 > 71S then NEXTCHAR; end; begin !-- CODE 3 -- READ HEXADECIMAL NUMBER --! R1 := R1-R1; R2 := R1; R3 := R1; NEXTCHAR; X: R5 := #40 or R0; !-- Force upper case --! if R0 >= "0" then R5 := R5 - 240 else if R5<"A" or R5>"F" then goto Y else R5 := R5 - 183S; SLDL(R2,4); R3 := R3 or R5; NEXTCHAR; R1 := R1+1; goto X; Y: if R1 = 0 or R1 > 16 then begin XR := 25; ERROR; R1 := 1; end; if R5 = "X" then begin R1 := R1 + 1 shrl 1; STM(R2,R3,VALUE); R2 := 8 - R1; R2 := @VALUE(R2); STRINGV(0/8) := B2; VALUE := R1; R5 := STRNGADR; ADR(R5+2) := R1; NEXTCHAR; R5 := STRNGSYMBOL; goto Z; end; if R5 = "L" then begin R1 := 2; STM(R2,R3,VALUE); NEXTCHAR; end else begin VALUE := R3; VALUE(4):= R2; if R5 = "S" then begin R1 := R1-R1; NEXTCHAR; end else if R5 = "R" then begin R1 := 3; NEXTCHAR; end else R1 := 1; end; R5 := NUMBERSYMBOL; SYMTYPE := R1; Z: end; begin !-- CODE 4 -- READ STRING --! R0 := """"; VALUE := R0; R2 := R2-R2; X: NEXTCHAR; if R0 = VALUE then begin NEXTCHAR; if R0 ^= VALUE then goto Y; end; if R0 = #79 then !-- Accent (`) escape --! begin !-- Process accent (`) escape --! array DATAFILL byte ESCTABLE = ( ! , A, B, C, D, E, F, G,! #40,#01,#02,#03,#37,#2D,#2E,#2F, ! H, I, [, ., <, (, +, ,! #16,#05,#35,#1E,#1F,#1B,#1C,#40, ! &, J, K, L, M, N, O, P,! #0A,#25,#0B,#0C,#0D,#0E,#0F,#10, ! Q, R, ], $, *, ), ;, ^,! #11,#12,#04,#14,#15,#2B,#55,#FA, ! \, /, S, T, U, V, W, X,! #22,#07,#13,#3C,#3D,#32,#26,#18, ! Y, Z, , , %, Õ, >, ?,! #19,#3F,#40,#40,#17,#27,#28,#09, ! 0, 1, , , , , , ,! #20,#21,#40,#40,#40,#40,#40,#40, ! , `, :, #, @, å, =, ",! #40,#79,#08,#09,#00,#1D,#2C,#7F); NEXTCHAR; R4 := #3F and R0; IC(R0,ESCTABLE(R4)); end; if R2 < 256S then STC(R0,STRINGV(R2)) else begin R2 := R2-R2; XR := 21; ERROR; R0 := ";"; VALUE := R0; end; R2 := R2 + 1; goto X; Y: if R2 = 0 then begin XR := 21; ERROR; end else if TM(ASCI,FLGS); ON then !-- ASCII conversion --! begin segment base R5; array 256 byte ASCIITAB = ! 0 1 2 3 4 5 6 7 8 9 A B C D E F ! (#000102037F097F7FX,#7F7F7F0B0C0D0E0FX, ! 00 ! #101112137F0A087FX,#18197F7F7F7F7F7FX, ! 10 ! #1F1D1C7F7F0A171BX,#7F7F7F7F7F050607X, ! 20 ! #7F7F167F7F1E7F04X,#7F7F7F7F14157F1AX, ! 30 ! #207F7F7F7F7F7F7FX,#7F7F5E2E3C282B7CX, ! 40 ! #267F7F7F7F7F7F7FX,#7F7F21242A293B7EX, ! 50 ! #2D2F7F7F7F7F7F7FX,#7F7F7C2C255F3E3FX, ! 60 ! #7F7F7F7F7F7F7F7FX,#7F603A2340273D22X, ! 70 ! #7F61626364656667X,#68697F7B7F7F7F7FX, ! 80 ! #7F6A6B6C6D6E6F70X,#71727F7D7F7F7F7FX, ! 90 ! #7F7E737475767778X,#797A7F7F7F5B7F7FX, ! A0 ! #7F7F7F7F7F7F7F7FX,#7F7F7F7F7F5D5C7FX, ! B0 ! #7B41424344454647X,#48497F7F7F7F7F7FX, ! C0 ! #7D4A4B4C4D4E4F50X,#51527F7F7F7F7F7FX, ! D0 ! #5C7F535455565758X,#595A7F7F7F7F7F7FX, ! E0 ! #3031323334353637X,#38397F7F7F7F7F7FX); ! F0 ! R4 := R2; REDUCE(R4); !-- Len-1 --! EX(R4,TR(0,STRINGV,B5)); !-- Translate --! end; R5 := STRNGADR; ADR(R5+2) := R2; VALUE := R2; R5 := STRNGSYMBOL; end; begin !-- CODE 5 -- ILLEGAL CHARACTER --! XR := 14; ERROR ; NEXTCHAR; goto TOP; end; begin !-- CODE 6 -- SHORT COMMENT !! --! R1 := R0; STC(R1,SCANTAB1(R1)); NEXTCHAR; R1 := @CBUF(R6); R2 := 71 - R6; COMLOOP: EX(R2,TRT(0,B1,SCANTAB1)); if = then begin GETCARD; R2 := 71; R1 := @CBUF; goto COMLOOP; end else if > then GETCARD else begin R0 := @CBUF(_1); R6 := R1 - R0; end; RESET(SCANTAB1(#4F)); RESET(SCANTAB1(#6A)); goto TOP; end; begin !-- CODE 7 -- END OF LINE COMMENT $ ... --! GETCARD; goto TOP; end; end else begin !-- CODE >= 10 -- SPECIAL SYMBOL --! array 15 integer TOPS=( #00000000,#4E02A02E,#6002B02F,#7A160020, #7E04B043,#7E04D045,#7E060049,#00080000, #000A0000,#FF02C000,#FF02D000,#7E0C0140, #000E0000,#7C100101,#00120000); NEXTCHAR; R2:=R2+R2; R2:=TOPS(R2-20); SRDL(R2,24); if R2^=0 then begin while R0=" " do NEXTCHAR; if R2=R0 then begin R3:=R3 shll 12; NEXTCHAR; end; R2:=R3 shrl 20 and #F; VALUE:=R2; R2:=R2-R2; end; SLDL(R2,8); R5:=OPS(R2); end; end; $PAGE segment procedure PROCCALL(R1); begin integer SAVER1,RETREG; short integer VH syn V; RETREG:=R0; SAVER1:=R1; R4:=VH(R7) shrl 8 and #FF; R5:=LC; if R4^=CSEGNO then begin R2:=VH(R7) and #F0 + #5800S; PROGRAM(R5):=R2; R0:=PROGESDEND; R1:=PROGESDADR; R2:=ER; R3:=VTYPE; FINDESDENTRY; PROGESDEND:=R0; R0:=RLDADDR(R1); PROGRAM(R5+2):=R0; RLDADDR(R1):=R5; R5:=@B5(4); end; R3:=VH(R7+2); if R3=0 then begin R2:=VH(R7) and #FF; SRDL(R2,4); R3:=R3 shrl 24 or R2+#500S; PROGRAM(R5):=R3; R5:=@B5(2); end else begin R2:=VH(R7) and #F0 shll 8 + R3; PROGRAM(R5+2):=R2; R3:=VH(R7) and #F shll 4 + #4500S; PROGRAM(R5):=R3; R5:=@B5(4); end; R3:=PBREG; R0:=RETREG; R2:=VH(R7) and #F; if R0^=16S then begin R2:=R3; R3:=R3 shll 4; R1:=@B3(#500); PROGRAM(R5+2):=R1; R1:= VH(R7) shrl 4 and #F; R0:=R0 shll 4 or R1 + #1200S; PROGRAM(R5):=R0; R5:=@B5(4); end else if R4=CSEGNO then goto Y; R1:=PROGESDADR; R3:=PBREG shll 4 + #5800S + R2; PROGRAM(R5):=R3; R2:=RLDADDR(R1); PROGRAM(R5+2):=R2; RLDADDR(R1):=R5; R5:=@B5(4); Y: LC:=R5; R1:=SAVER1; $IFT D D if TM(4,DBGFLGS); ON then SET(PRNT); $END D end; $PAGE !-- *************** EXECUTE *************** --! segment procedure EXECUTE (R4); begin integer SAVE, SAVE2; array 5 integer SAVEREG; !-- USED BY THE EXECUTE PROCEDURES --! equate XEQ0 syn 46, !-- NULL PROCESSES --! XEQ1 syn XEQ0 + 43, !-- EXECUTE1'S RULES --! XEQ2 syn XEQ1 + 09, !-- EXECUTE2'S RULES --! XEQ3 syn XEQ2 + 61, !-- EXECUTE3'S RULES --! XEQ4 syn XEQ3 + 48; !-- EXECUTE4'S RULES --! segment procedure EXECUTE1(R4); !-- RULES <= XEQ1 --! begin !-- LOCAL PROCEDURE FOLLOWS --! procedure ASSCELL (R4); begin SAVE := R4; R0 := T2(R7); R1 := R0 shll 2 + T(R7); R1 := @TYPETABLE(R1); CLI(0,B1); if = then begin XR := 3; ERROR; end; R0 := R0 + 4; R1 := 8; R2 := V(R7); R3 := V2(R7); EMYT; R4 := SAVE; end; procedure TCELLNUM (R4); begin SAVE := R4; R0 := V1(R7); R1 := V2(R7); R2 := T2(R7); if R2 > 1 then begin XR := 25; ERROR; goto X; end; R2 := V(R7+4); if R0 = 11S then R1 := neg R1 else if R0 ^= 10S then begin XR := 0; if R0 = 13S and R2 = 0 and R1 > 0 then V(R7+4) := R1 else ERROR; goto X; end; if R2 ^= 0 then begin R1 := R1 + R2; if <= then begin XR := 24; ERROR; end else V(R7+4) := R1; goto X; end; R2 := V(R7); SRDL(R2,12); R3 := R3 shrl 20 + R1; if R3>4095S or R3<0 then begin XR := 18; ERROR; goto X; end; R2 := R2 shll 12 or R3; V(R7) := R2; X: R4 := SAVE; end; procedure ASSTNUM (R4); begin SAVE := R4; R2 := T2(R7); R1 := R2 shll 2 + T(R7); R1 := @TYPETABLE(R1); CLI(0,B1); if = then begin XR := 3; ERROR; end; R3 := V2(R7); if R2<2 and R3<4096S and R3>=0 then begin R0 := 4; R1 := 1; R2 := V(R7); EMYT; end else begin R1 := R1-R1; IC(R1,ALENGTH(R2)); IC(R0,LENGTH(R2)); R2 := 2 + LC; R3 := @V2(R7); MAKELITERAL; R0 := 4 + T2(R7); R1 := 8; R2 := V(R7); R3 := R3-R3; EMYT; end; R4 := SAVE; end; procedure NEWUNARY (R4); begin V2(R7/2) := V(R7+2); V(R7/18) := V1(R7); end; procedure OLDUNARY (R4); begin byte VC syn V, VC2 syn V(32); R1 := R1 -- R1; R0 := V(R7); IC(R1,VC2(R7)); R2 := @VC2(R7+R1+1); if VC(R7+3) = 6 or VC(R7+3) = 4 or C2 = 6 or C2 = 4 then begin R1 := @B1(1); STC(R1,VC2(R7)); R2 := @B2(1); end else if VC(R7+3) = 3 then begin C2 := C2 xor #01X; goto X; end; STC(R0,C2); X: R1 := @B1(17); EX(R1,MVC(0,V(R7),V1(R7))); end; procedure ASSUNOP (R4); begin byte VC syn V(48), OPCD syn B4; SAVE := R4; R0 := T2(R7); R1 := R0 shll 2 + T(R7); R1 := @TYPETABLE(R1); if C1 = 0 then begin XR := 3; ERROR; end; R4 := R4 -- R4; R2 := V(R7); R3 := V2(R7); IC(R4,VC(R7)); R4 := @VC(R7+R4+2); SET(OPCD); !-- End signal --! R4 := @VC(R7+1); while ^OPCD do !-- For all ops --! begin if OPCD = 6 then !-- DEC (aka BCTR) --! begin if R0 ^= 1S then begin XR := 7; ERROR; end; if R2 ^= R3 then begin R1 := 8; EMIT; end; R0 := R0 -- R0 =: R3; !-- White lie --! end else if OPCD = 4 then !-- HALF (aka HDR and HER) --! if R0 = 1S then begin XR := 7; ERROR; end; R1 := R1 -- R1; IC(R1,OPCD); EMIT; R0 := T(R7); R3 := R2; R4 := @B4(1); end; R4 := SAVE; end; procedure ADRSOP (R5); !-- ASSIGN REGISTER --! begin SAVE := R5; if = then REDUCE(R3) else begin R5 := R2 shll 12 or R3 =: R3 shrl 16; if R2 = 0 or R2 = R5 then !-- INVALID --! begin XR := 0; ERROR; R3 := R3-R3; REDUCE(R3); goto XIT; end; !-- LOAD ASSIGNMENT REGISTER --! end; SAVE2 := R3; R3 := VTYPE; R5 := LC; R2 := @B2(#580) shll 4 =: PROGRAM(R5); R2 := R0; R1 := PROGESDADR; R0 := PROGESDEND; FINDESDENTRY; PROGESDEND := R0; R0 := RLDADDR(R1) =: PROGRAM(R5+2); RLDADDR(R1) := R5; R5 := @B5(4) =: LC; R3 := SAVE2; XIT: R2 := V(R7); R5 := SAVE; end; $PAGE procedure STRTOINT (R4); !- Convert to -! begin SAVE := R4; R3 := STRINGV; R1 := 4 - V2(R7); if < then begin XR := 21; ERROR; !- Invalid length -! end else !- Valid string length -! for R2 := 1 step 1 until R1 do R3 := R3 shrl 8; V2(R7) := R3; T2(R7) := 1; !- integer type -! R4 := SAVE; end; procedure INDXTNUM (R4); !- Start index with integer -! begin SAVE := R4; R1 := V1(R7); R2 := T1(R7); if R2 > 1 then begin XR := 0; ERROR; goto X; end; R2 := V(R7); SRDL(R2,12); R3 := R3 shrl 20 + R1; if R3>4095S or R3<0 then begin XR := 18; ERROR; goto X; end; R2 := R2 shll 12 or R3; V(R7) := R2; X: R4 := SAVE; end; procedure ARITHNUM (R4); !- Do arith with number -! begin SAVE := R4; R1 := R1-R1; R2 := T2(R7); IC(R1,ALENGTH(R2)); IC(R0,LENGTH(R2)); R2 := 2 + LC; R3 := @V2(R7); MAKELITERAL; XR := 4; R1 := V1(R7); R0 := T2(R7); if R1 = 0 then begin ERROR; R1 := 8; end; R2 := R0 shll 2 + T(R7); R2 := @TYPETABLE(R2); CLI(0,B2); if = then ERROR else if R1>=13S and R0=0 then ERROR; R2 := V(R7); if R0=1 then if R1=12S or R1=13S then begin R2 := R2 and #E; !-- ODD REGISTER MUST BE SPECIFIED --! if R2=V(R7) then begin XR := 7; ERROR; end; end; R0 := R0 + 4; R3 := R3-R3; EMYT; R4 := SAVE; end; procedure LOGTNUM (R4); !- Do logical operator with number -! begin SAVE := R4; R1 := R1-R1; R2 := T2(R7); if R2 = 0 then R2 := 1; IC(R1,ALENGTH(R2)); IC(R0,LENGTH(R2)); R2 := 2 + LC; R3 := @V2(R7); MAKELITERAL; R0 := 1; if R0^=T(R7) or R0^=T2(R7) then begin XR := 4; ERROR; end; R0 := 5; R1 := V1(R7); R2 := V(R7); R3 := R3-R3; EMYT; R4 := SAVE; end; $PAGE !-- ********* THE FOLLOWING ARE NULL PROCESSES ********** --! !- ::= -! !- ::= ) -! !- ::= ) -! !- ::= ( -! !- ::= , -! !- ::= ( -! !- ::= -! !- ::= -! !- ::= NULL -! !- ::= ) -! !- ::= -! !- ::= -! !- ::= -! !- ::= -! !- ::= , -! !- ::= -! !- ::= , -! !- ::= -! !- ::= FUNCTION -! !- ::= , -! !- ::= ( -! !- ::= , -! !- ::= ) -! !- ::= , -! !- ::= ( -! !- ::= ) -! !- ::= -! !- ::= -! !- ::= -! !- ::= -! !- ::= ; -! !- ::= -! !- ::= ; -! !- ::=