Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- $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, !-- <CASE SEQ> --!
- RELOP syn 22, !-- <REL OP> --!
- COMPAOR syn 25, !-- <COMP AOR> --!
- CONDTHEN syn 26, !-- <COND THEN> --!
- DOTERM syn 30, !-- <WHILE> --!
- REPLIST1 syn 41, !-- <REP LIST1> --!
- TDECL3 syn 45, !-- <T DECL3> --!
- BLOCKHEAD syn 69, !-- <BLOCKHEAD> --!
- BLOCKBODY syn 70, !-- <BLOCKBODY> --!
- PROGMINUS syn 71, !-- <PROGRAM-> --!
- PROGSTAR syn 72, !-- <PROGRAM*> --!
- NUMBERSYMBOL syn 78, !-- <T NUMBER> --!
- IFTERM syn 79, !-- <IF> --!
- RPTERM syn 82, !-- <RP> --!
- CONDEND syn 86, !-- <COND END> --!
- REPUNTIL syn 92, !-- <REPUNTIL> --!
- IDENTSYMBOL syn 93, !-- <ID> --!
- STRNGSYMBOL syn 94, !-- <STRING> --!
- SHIFTOP syn 95, !-- <SHIFT OP> --!
- ARITHOP syn 96, !-- <ARITH OP> --!
- ADROP syn 97, !-- <ADR OP> --!
- 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 , !-- <ARITH OP> --!
- RELOP , !-- <REL OP> --!
- NOTSYM , !-- ^ --!
- LPAREN , !-- ( --!
- RPAREN , !-- ) --!
- COLONSYMBOL , !-- : --!
- COMMASYM , !-- , --!
- ADROP , !-- <ADR OP> --!
- 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 R6<LITEND do
- begin IC(R2,B6); if R2>8S 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<MAXLINE then
- begin logical SAVE0; GETPARM;
- if R0 = 0 then R0 := 1;
- !-- R0 HAS NUMBER OF LINES TO SPACE --!
- WBUFF(0/133) := BLANK; CLI(" ",CARRCONT);
- if ^= then
- begin SAVE0 := R0; PRINT; R0 := SAVE0 - 1;
- end; R14 := MAXLINE - LINECOUNT;
- if R0 >= 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 <ADR OP> 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 <STRING> to <T NUM> -!
- 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 ********** --!
- !- <T CELL> ::= <T CELL ID> -!
- !- <T CELL> ::= <T CELL1> ) -!
- !- <T CELL> ::= <T CELL2> ) -!
- !- <T CELL3> ::= <T CELL ID> ( -!
- !- <FUNC2> ::= <FUNC1> , -!
- !- <PROC1> ::= <PROC ID> ( -!
- !- <SIMPLE ST> ::= <K REG ASS> -!
- !- <SIMPLE ST> ::= <CELL ST> -!
- !- <SIMPLE ST> ::= NULL -!
- !- <SIMPLE ST> ::= <PROC2> ) -!
- !- <GOTO ST> ::= <GOTO ST*> -!
- !- <STATEMENT-> ::= <SIMPLE ST> -!
- !- <STATEMENT*> ::= <STATEMENT-> -!
- !- <STATEMENT> ::= <STATEMENT*> -!
- !- <REP LIST1> ::= <REP LIST2> , -!
- !- <REP LIST2> ::= <REP LIST1><FILL> -!
- !- <T DECL2> ::= <T DECL4> , -!
- !- <T DECL4> ::= <T DECL1> -!
- !- <FUNC DC1> ::= FUNCTION -!
- !- <FUNC DC1> ::= <FUNC DC7> , -!
- !- <FUNC DC3> ::= <FUNC DC2> ( -!
- !- <FUNC DC5> ::= <FUNC DC4> , -!
- !- <FUNC DC7> ::= <FUNC DC6> ) -!
- !- <SYN DC3> ::= <SYN DC2> , -!
- !- <PROC HD2> ::= <PROC HD1> ( -!
- !- <PROC HD4> ::= <PROC HD3> ) -!
- !- <GLOB HD> ::= <GLOB HD1> -!
- !- <DECL> ::= <T DECL4> -!
- !- <DECL> ::= <FUNC DC7> -!
- !- <DECL> ::= <SYN DC2> -!
- !- <BLOCKHEAD> ::= <BLOCKHEAD><DECL> ; -!
- !- <BLOCKBODY> ::= <BLOCKHEAD> -!
- !- <BLOCKBODY> ::= <BLOCKBODY><STATEMENT> ; -!
- !- <BLOCKBODY> ::= <BLOCKBODY><LABEL DEF> -!
- !- <PROGRAM> ::= <PROGRAM*> . -!
- !- <IF> ::= IF -!
- !- <IF> ::= <IF><STATEMENT> ; -!
- !- <COMP AOR> ::= <COMP AOR><STATEMENT> ; -!
- !- <WHILE> ::= <WHILE><STATEMENT> ; -!
- !- <PRIM COND> ::= <COMP COND> -!
- !- <RP> ::= <RP><STATEMENT> ; -!
- !- <CASE HEAD> ::= <CASE HEAD><DECL> ; -!
- !- <CASE SEQ> ::= <CASE HEAD> -!
- !- <CASE SEQ> ::= <CASE SEQ><LABEL DEF> -!
- !- <REPEAT> ::= <REPEAT><LABEL DEF> -!
- !- <REPEAT> ::= <REPEAT><STATEMENT> ; -!
- $PAGE
- R1 := R1 - XEQ0; if > then !-- NOT NULL RULE --!
- case R1 of begin !-- EXECUTE1'S RULES --!
- begin !- <K REG ASS> ::= <K REG> -!
- $IFT D D
- if TM(1,DBGFLGS); ON then SET(PRNT); !-- List assignments --!
- $END D
- end;
- begin !- <K REG> ::= <ID> -!
- R1 := @V(R7); R3 := 1 + T(R7) and #E; R4 := R4-R4; IC(R4,V(R7));
- IC(R4,ALPHASH(R4-193)); R4 := R4 + LENHASH(R3-2);
- R4 := HASHCHAIN(R4); REDUCE(R3); R5 := NAMEBASE;
- if R4 >= 0 then
- begin !-- SCAN NAME TABLE --!
- Z: R4 := R4 + R5; EX(R3,CLC(0,B1,NAME(R4))); if = then
- begin R0 := TYPE(R4); R2 := ADR(R4+2); SRDL(R2,16);
- R2 := ADR(R4); SRDL(R2,16); R5 := #FF;
- R4 := R0 and #FF00; R0 := R0 and R5; R5 := 80;
- if R0 > R5 then R0 := R0 - R5 else SET(FLAG);
- goto X;
- end; R4 := LINK(R4); if R4 ^= ENDCHAIN then
- begin R4 := R4 and #FFFF; goto Z; end;
- end; XR := 8; ERROR;
- R3 := 1; R0 := R3;
- X: V(R7) := R3; V(R7+8) := R4; T(R7) := R0;
- end;
- begin !- <T CELL ID> ::= <ID> -!
- R1 := 10; if R1 > T(R7) then
- begin R0 := V(R7) and #FFFFF;
- !- Check for DSTAR symbol reference -!
- if R0 = #D0FFF then R0 := DBREG shll 12 + DC
- !- Check for PSTAR symbol reference -!
- else if R0 = #E0FFF then R0 := PTAG + LC;
- V(R7) := R0; R1 := R1-R1; V(R7+4) := R1;
- end else SET(FLAG);
- end;
- begin !- <PROC ID> ::= <ID> -!
- R1 := 10; if R1 ^= T(R7) then SET(FLAG);
- end;
- begin !- <FUNC ID> ::= <ID> -!
- R1 := 11; if R1 ^= T(R7) then SET(FLAG);
- end;
- begin !- <T NUMBER> ::= <ID> -!
- R1 := 1; R2 := 12; if R2 = T(R7) then goto X;
- R1 := R1-R1; R2 := 15; if R2 = T(R7) then goto X;
- SET(FLAG); goto Z;
- X: T(R7) := R1; R1 := R1-R1; V(R7+4) := R1; Z:
- end;
- begin !- <UNARY OP> ::= <ID> -!
- R1 := 13; if R1 ^= T(R7) then SET(FLAG);
- end;
- begin !- <BRINDX OP> ::= <ID> -!
- R1 := 14; if R1 ^= T(R7) then SET(FLAG);
- end;
- begin !- <T CELL1> ::= <T CELL1><ARITH OP><STRING> -!
- STRTOINT;
- TCELLNUM;
- end;
- begin !- <T CELL1> ::= <T CELL1><ARITH OP><T NUMBER> -!
- TCELLNUM;
- end;
- begin !- <T CELL1> ::= <T CELL2><ARITH OP><T NUMBER> -!
- TCELLNUM;
- end;
- begin !- <T CELL1> ::= <T CELL2><ARITH OP><K REG> -!
- R0 := 1; R1 := V2(R7); R2 := V(R7);
- if R0 ^= T2(R7) or R1 = 0 then
- begin XR := 7; ERROR; goto X;
- end;
- if R2 > #FFFF then begin XR := 11; ERROR; goto X; end;
- R0 := 10; if R0 ^= V1(R7) then
- begin XR := 0; ERROR; goto X;
- end;
- R2 := R2 and #FFFF; if R2 < 4096S then
- R1 := R1 shll 12 else R1 := R1 shll 16;
- R1 := R1 or R2; V(R7) := R1;
- X: end;
- begin !- <T CELL1> ::= <T CELL3><STRING> -!
- R7 := R7 - 16S; STRTOINT; R7 := R7 + 16S;
- INDXTNUM; !- Assign as number -!
- end;
- begin !- <T CELL1> ::= <T CELL3><T NUMBER> -!
- INDXTNUM;
- end;
- begin !- <T CELL2> ::= <T CELL3><K REG> -!
- R0 := 1; R1 := V1(R7); R2 := V(R7);
- if R0^=T1(R7) or R1=0 then begin XR := 7; ERROR; goto X; end;
- if R2 > #FFFF then begin XR := 11; ERROR; goto X; end;
- R2 := R2 and #FFFF; if R2 < 4096S then
- R1 := R1 shll 12 else R1 := R1 shll 16;
- R1 := R1 or R2; V(R7) := R1;
- X: end;
- begin !- <UNARY CELL> ::= <UNARY OP><T CELL> -!
- NEWUNARY;
- end;
- begin !- <UNARY CELL> ::= <UNARY OP><UNARY CELL> -!
- OLDUNARY;
- end;
- begin !- <UNARY NUM> ::= <UNARY OP><T NUMBER> -!
- NEWUNARY;
- end;
- begin !- <UNARY NUM> ::= <UNARY OP><UNARY NUM> -!
- OLDUNARY;
- end;
- begin !- <UNARY REG> ::= <UNARY OP><K REG> -!
- NEWUNARY;
- end;
- begin !- <UNARY REG> ::= <UNARY OP><UNARY REG> -!
- OLDUNARY;
- end;
- begin !- <LOG OP> ::= AND -!
- R0 := #4; V(R7) := R0;
- end;
- begin !- <LOG OP> ::= OR -!
- R0 := #6; V(R7) := R0;
- end;
- begin !- <LOG OP> ::= XOR -!
- R0 := #7; V(R7) := R0;
- end;
- begin !- <K REG ASS> ::= <K REG> := <T CELL> -!
- ASSCELL;
- end;
- begin !- <K REG ASS> ::= <K REG> := <T NUMBER> -!
- ASSTNUM;
- end;
- begin !- <K REG ASS> ::= <K REG> := <STRING> -!
- STRTOINT;
- ASSTNUM;
- end;
- begin !- <K REG ASS> ::= <K REG> := <K REG> -!
- R0 := T2(R7); R1 := R0 shll 2 + T(R7); R1 := @TYPETABLE(R1);
- CLI(0,B1); if = then begin XR := 3; ERROR; end;
- R1 := 8; R2 := V(R7); R3 := V2(R7); if R2 ^= R3 then EMIT;
- end;
- begin !- <K REG ASS> ::= <K REG> := <UNARY CELL> -!
- ASSCELL; V2(R7/16) := V(R7); ASSUNOP;
- end;
- begin !- <K REG ASS> ::= <K REG> := <UNARY NUM> -!
- ASSTNUM; V2(R7/16) := V(R7); ASSUNOP;
- end;
- begin !- <K REG ASS> ::= <K REG> := <UNARY REG> -!
- ASSUNOP;
- end;
- begin !- <K REG ASS> ::= <K REG> := <ADR OP><T CELL> -!
- R0 := 1; if R0 ^= T(R7) then
- begin XR:=3; ERROR; !-- REG ASSIGN TYPE --!
- end; R2 := V(R7); R3 := V(R7+48); R4 := V2(R7);
- if R4 ^= 0 and R4 := V(R7+56) shrl 8;
- R4 < MAXSEGNO and R5 := R4 * 10S;
- R5 := @ESDNAME(R5); B5 ^= "DUMMY " then
- begin R0 := ER; R3 := R3 and #F0FFF; ADRSOP;
- end; R0 := 4; R1 := 1; if R3 >= 0 then EMYT;
- end;
- begin !- <K REG ASS> ::= <K REG> := <ADR OP><PROC ID> -!
- R0:=T(R7); if R0^=1 then begin XR:=3; ERROR; end;
- R4:=V(R7+48); SRDL(R4,12); R4:=R4 shrl 8; SRDL(R4,4);
- R5:=R5 shrl 16; R2:=V(R7); if R4^=CSEGNO then
- begin R0 := ER; R3 := V2(R7); if R3 ^= 0 then R0 := WER;
- R3 := #FFF and R5; ADRSOP; R5 := R3;
- $IFT D D
- if TM(4,DBGFLGS); ON then SET(PRNT); !-- List these --!
- $END D
- end; R0 := 4; R1 := 1; if LTR(R3,R5); > then EMYT;
- end;
- begin !- <K REG ASS> ::= <K REG ASS><ARITH OP><STRING> -!
- STRTOINT;
- ARITHNUM;
- end;
- begin !- <K REG ASS> ::= <K REG ASS><ARITH OP><T CELL> -!
- R0 := T2(R7); R1 := R0 shll 2 + T(R7); R1 := @TYPETABLE(R1);
- CLI(0,B1); if = then begin XR := 4; ERROR; end;
- R1 := V1(R7); R2 := V(R7);
- if R1>=13S and R0=0 then begin XR := 4; ERROR; end else
- 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 := V2(R7); EMYT;
- end;
- begin !- <K REG ASS> ::= <K REG ASS><ARITH OP><T NUMBER> -!
- ARITHNUM;
- end;
- begin !- <K REG ASS> ::= <K REG ASS><ARITH OP><K REG> -!
- R0 := T2(R7); R1 := R0 shll 2 + T(R7); R1 := @TYPETABLE(R1);
- CLI(0,B1); if = then begin XR := 4; ERROR; end;
- R1 := V1(R7); R2 := V(R7); R3 := V2(R7);
- if R1 = 0 then !-- REVERSE ASSIGNMENT --!
- begin if R2 = R3 then goto X;
- R1 := R2; R2 := R3; R3 := R1; R1 := 8;
- end; 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; EMIT;
- X: end;
- begin !- <K REG ASS> ::= <K REG ASS><LOG OP><STRING> -!
- STRTOINT;
- LOGTNUM;
- end;
- begin !- <K REG ASS> ::= <K REG ASS><LOG OP><T CELL> -!
- 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 := V2(R7); EMYT;
- end;
- begin !- <K REG ASS> ::= <K REG ASS><LOG OP><T NUMBER> -!
- LOGTNUM;
- end;
- begin !- <K REG ASS> ::= <K REG ASS><LOG OP><K REG> -!
- R0 := 1; if R0^=T(R7) or R0^=T2(R7) then
- begin XR := 4; ERROR;
- end;
- R1 := V1(R7); R2 := V(R7); R3 := V2(R7); EMIT;
- end;
- begin !- <K REG ASS> ::= <K REG ASS><SHIFT OP><T NUMBER> -!
- R0 := 1; if R0^=T(R7) or R0<T2(R7) then
- begin XR := 5; ERROR;
- end;
- R0 := 8; R1 := V1(R7); R2 := V(R7); R3 := V2(R7);
- if R3<0 or R3>=32S then
- begin XR:=25; ERROR;
- end;
- if R3 ^= 0 then EMYT;
- end;
- begin !- <K REG ASS> ::= <K REG ASS><SHIFT OP><K REG> -!
- R0 := 1; if R0^=T(R7) or R0^=T2(R7) then
- begin XR := 5; ERROR;
- end;
- R0 := 8; R1 := V1(R7); R2 := V(R7);
- R3 := V2(R7) shll 12; EMYT;
- end;
- end; LM(R1,R5,SAVEREG);
- end;
- $PAGE
- segment procedure EXECUTE2(R4); !-- XEQ1 < RULES <= XEQ2 --!
- begin !-- LOCAL PROCEDURES FOLLOW --!
- procedure ARGUMENT(R8); !-- Process FUNCTION arguments --!
- begin R0 := V(R7); SRDL(R0,4); V(R7) := R0; R1 := R1 shrl 28;
- R0 := V1(R7); R3 := T1(R7); XR := 24;
- if R1 = 0 then begin XR := 13; ERROR; end else
- case R1 of begin
- begin !-- PAR 1 -- REGISTER -- BITS 8-11 --!
- if R2 ^= 4 then ERROR;
- R0 := R0 and #F shll 4 or FUNC0; FUNC0 := R0;
- end;
- begin !-- PAR 2 -- NUMBER -- BITS 8-11 --!
- if R2 ^= 2 or R0 >= 16S or R0 < 0 then ERROR;
- R0 := R0 and #F shll 4 or FUNC0; FUNC0 := R0;
- end;
- begin !-- PAR 3 -- REGISTER -- BITS 12-15 --!
- if R2 ^= 4 then ERROR;
- R0 := R0 and #F or FUNC0; FUNC0 := R0;
- end;
- begin !-- PAR 4 -- NUMBER -- BITS 12-15 --!
- if R2 ^= 2 or R0 >= 16S or R0 < 0 then ERROR;
- R0 := R0 and #F or FUNC0; FUNC0 := R0;
- end;
- begin !-- PAR 5 -- NUMBER STRING VARIABLE -- BITS 8-15 --!
- case R2 of begin
- begin if R0 >= 256S then ERROR;
- end;
- begin if R3 < 2 then if R0 < 256S then
- if R0 < 0 then ERROR;
- end;
- begin if R0 ^= 1 then begin XR := 21; ERROR; end;
- IC(R0,STRINGV);
- end;
- begin ERROR;
- end;
- end; R0 := R0 and #FF xor FUNC0; FUNC0 := R0;
- end;
- begin !-- PAR 6 -- NUMBER STRING VARIABLE -- BITS 12-31 --!
- case R2 of begin
- null;
- begin if R3 < 2 then if R0 < 4096S then
- if R0 < 0 then ERROR;
- end;
- begin if R0 ^= 1 then begin XR := 21; ERROR; end;
- IC(R0,STRINGV);
- end;
- begin ERROR;
- end;
- end; FUNC1 := R0; R0 := R0 shrl 16 and #F or FUNC0;
- FUNC0 := R0;
- end;
- begin !-- PAR 7 -- LITERAL VARIABLE -- BITS 12-31 --!
- case R2 of begin
- begin FUNC1:=R0; R0:=R0 shrl 16 and #F or FUNC0;
- FUNC0:=R0;
- end;
- begin IC(R2,LENGTH(R3)); R1 := 1 shll R2 - 1;
- R3:=LITX; FUNC1:=R3; R3:=1; LITCOUNT:=R3;
- R0 := R2; R2 := 2 + LC; R3 := @V1(R7);
- if R1 = 0 then R3 := @B3(3); MAKELITERAL;
- end;
- begin R1 := R0 - 1; R0 := R0-R0; R2 := 2 + LC;
- R3:=LITX; FUNC1:=R3; R3:=1; LITCOUNT:=R3;
- R3 := @STRINGV; MAKELITERAL;
- end;
- begin ERROR;
- end;
- end;
- $IFT D D
- if R3 ^= 4 and CLI(#43,FUNC0(2)); = then SET(PRNT);
- $END D
- end;
- begin !-- PAR 8 -- VARIABLE -- BITS 12-31 --!
- if R2 ^= 1 then ERROR; FUNC1 := R0;
- R0 := R0 shrl 16 and #F or FUNC0; FUNC0 := R0;
- $IFT D D
- if R3 ^= 4 and CLI(#42,FUNC0(2)); = then SET(PRNT);
- $END D
- end;
- begin !-- PAR 9 -- NUMBER VARIABLE -- BITS 16-31 --!
- case R2 of begin
- if R0 > #FFFF then begin XR := 11; ERROR; end;
- begin if R3 < 2 then if R0 < 4096S then
- if R0 < 0 then ERROR;
- end;
- begin ERROR;
- end;
- begin ERROR;
- end;
- end; FUNC1 := R0;
- end;
- begin !-- PAR A -- LITERAL VARIABLE -- BITS 16-31 --!
- case R2 of begin
- begin FUNC1:=R0;
- if R0 > #FFFF then begin XR:=11; ERROR; end;
- end;
- begin IC(R2,LENGTH(R3)); R1 := 1 shll R2 - 1;
- R3:=LITX; FUNC1:=R3; R3:=1; LITCOUNT:=R3;
- R0 := R2; R2 := 2 + LC; R3 := @V1(R7);
- if R1 = 0 then R3 := @B3(3); MAKELITERAL;
- end;
- begin R1 := R0 - 1; R0 := R0-R0; R2 := 2 + LC;
- R3:=LITX; FUNC1:=R3; R3:=1; LITCOUNT:=R3;
- R3 := @STRINGV; MAKELITERAL;
- end;
- begin ERROR;
- end;
- end;
- end;
- begin !-- PAR B -- VARIABLE -- BITS 16-31 --!
- if R2 ^= 1 then ERROR else
- if R0 > #FFFF then begin XR := 11; ERROR; end;
- FUNC1 := R0;
- $IFT D D
- if R3 ^= 4 then !-- Not BYTE --!
- begin !-- Test for certain functions --!
- if CLI(#94,FUNC0(2)); = then !-- NI --!
- begin if CLI(#7F,FUNC0(3)); ^= then SET(PRNT);
- end else !-- Look for all others --!
- if CLI(#91,FUNC0(2)); >= and CLI(#97,FUNC0(2)); <=
- and CLI(#80,FUNC0(3)); ^= then SET(PRNT);
- end;
- $END D
- end;
- begin !-- PAR C -- LITERAL VARIABLE -- BITS 32-47 --!
- case R2 of begin
- begin FUNC2:=R0;
- if R0 > #FFFF then begin XR:=11; ERROR; end;
- end;
- begin IC(R2,LENGTH(R3)); R1 := 1 shll R2 - 1;
- R3:=LITX; FUNC2:=R3; R3:=LITCOUNT+2; LITCOUNT:=R3;
- R0:=R2; R2:=4+LC;
- R3:=FUNCCOUNT; if R3^=1 then R2:=R2-2;
- R3:=@V1(R7);
- if R1 = 0 then R3 := @B3(3); MAKELITERAL;
- end;
- begin R1 := R0 - 1; R0 := R0-R0; R2 := 4 + LC;
- R3:=LITX; FUNC2:=R3; R3:=LITCOUNT+2; LITCOUNT:=R3;
- R3:=FUNCCOUNT; if R3^=1 then R2:=R2-2;
- R3 := @STRINGV; MAKELITERAL;
- end;
- begin ERROR;
- end;
- end;
- end;
- begin !-- PAR D -- REGISTER -- BITS 16-31 --!
- if R2 ^= 4 then ERROR;
- R0 := R0 and #F shll 4; FUNC1 := R0;
- end;
- end;
- end;
- $PAGE
- R1 := R1 - XEQ1; case R1 of begin !-- EXECUTE2'S RULES --!
- begin !- <FUNC1> ::= <FUNC2><T NUMBER> -!
- R2 := 2; ARGUMENT;
- end;
- begin !- <FUNC1> ::= <FUNC2><K REG> -!
- R2 := 4; ARGUMENT;
- end;
- begin !- <FUNC1> ::= <FUNC2><T CELL> -!
- R2 := 1; ARGUMENT;
- end;
- begin !- <FUNC1> ::= <FUNC2><STRING> -!
- R2 := 3; ARGUMENT;
- end;
- begin !- <FUNC1> ::= <FUNC2><FUNC3> -!
- R1 := FUNC2 and #FFFF; R2 := FUNC0;
- R3 := FUNC1 shll 16 or R1; R0 := LITCOUNT;
- R1 := R2 shrl 8 - #44S; if = then begin XR := 24; ERROR; end;
- if R0>0 then
- begin R0 := R0+8S; SLDL(R2,16);
- end else R0 := 1;
- STM(R2,R3,STRINGV); R1 := FUNC0 shra 14 + 1 or 1;
- R2:=2+LC; R3:=@STRINGV; MAKELITERAL; R0:=R0-R0; LITCOUNT:=R0;
- V(R7):=R0; R0:=V1(R7+4); FUNC0:=R0;
- R0:=R0 shrl 8 -#44S; if ^= then begin XR:=24; ERROR; end;
- end;
- begin !- <FUNC2> ::= <FUNC ID> ( -!
- array FT short integer FUNCTYPE=(#0000,#0031,#0071,
- #0B31,#00B5,#0CB5,#0001,#0005,#000B,#0091,#CB42,
- #0061,#0081,#0CA5,#00CB,#0007,#0A41,#0B41,#000D,#0009);
- R0:=FUNCCOUNT+1; FUNCCOUNT:=R0; R0:=FUNC0; V(R7+4):=R0;
- R0:=R0-R0; LITCOUNT:=R0;
- R2 := V(R7); SRDL(R2,16); R3 := R3 shrl 16; FUNC0 := R3;
- R2 := R2 shll 1; R0 := FUNCTYPE(R2) and #FFFF; V(R7) := R0;
- end;
- begin !- <FUNC3> ::= <FUNC1> ) -!
- R0:=V(R7); if R0^=0 then begin XR:=13; ERROR; end;
- end;
- begin !- <CASE HEAD> ::= CASE <K REG> OF BEGIN -!
- R0 := 1; R2 := V1(R7);
- if R0 ^= T1(R7) or R2 = 0 then
- begin XR := 7; ERROR;
- end; R1 := #A; R3 := R2; EMIT;
- R0 := 4; R1 := 8; EMIT;
- R1 := LC =: V(R7+8); R0 := PTAG =: PROGRAM(R1+4);
- R0 := #47F0 or R3 =: PROGRAM(R1+2); R1 := @B1(6) =: LC;
- R0 := ENDCHAIN =: V(R7); R0 := R0 -- R0 =: V(R7+4);
- R0 := N4; R1 := 14 + N3 =: N3 =: N4; !-- OPEN BLOCK --!
- R1 := R1 + LABELBASE; B1(0/12) := ZERO; LABELADR(R1) := R0;
- R0 := N2; LABEL(R1+4) := R0; R0 := N1; N2 := R0;
- R0 := DBREG; LABEL(R1) := R0;
- R0 := PROCBR =: LABEL(R1+6);
- R0 := 1 =: PROCBR;
- R0 := PROCLK =: LABELCHAIN(R1);
- R2 := 1 + BLOCK; BLOCK := R2;
- end;
- begin !- <CASE SEQ> ::= <CASE SEQ><STATEMENT> ; -!
- R0 := #F0; R2 := V(R7); EMYTBRANCH;
- R1 := V(R7); PROGRAM(R1+2) := R2;
- R1 := 2 + V(R7+4) =: V(R7+4);
- end;
- end; LM(R1,R5,SAVEREG);
- end;
- $PAGE
- segment procedure EXECUTE3(R4); !-- XEQ2 < RULES <= XEQ3 --!
- begin !-- LOCAL PROCEDURES FOLLOW --!
- procedure INITCOND(R4);
- begin V(R7+8) := R1; R1 := ENDCHAIN =: V(R7) =: V(R7+4);
- end;
- segment procedure CLOSEBLOCK(R8);
- begin array 3 integer SAVE68; integer SAVE8 syn SAVE68(8);
- STM(R6,R8,SAVE68);
- R14 := N4 + LABELBASE; R5 := LABELADR(R14) =: N4;
- R0 := LABEL(R14+6) =: PROCBR; R0 := LABEL(R14+12) =: PROCLK;
- R1 := N2; if R1 ^= N1 then
- begin for R2 := R2 -- R2 step 4S until MAXHASH do
- begin R3 := HASHCHAIN(R2); while R3 >= R1 do
- begin R3 := R3 + NAMEBASE; R3 := LINK(R3);
- if R3 ^= ENDCHAIN then R3 := R3 and #FFFF;
- end; HASHCHAIN(R2) := R3;
- end; N1 := R1;
- end; R1 := LABEL(R14+4) and #FFFF =: N2;
- if R14 ^= LABELBASE then R14 := R14 - 14S;
- R5 := R5 + LABELBASE; R5 := @B5(14);
- R6 := R14; R12 := N3 + LABELBASE;
- R7 := @B14(14); while R7 := @B7(14); R7 <= R12 do
- if R0 := LABELADR(R7); R0 ^= 0 then
- begin R1 := LABELCHAIN(R7); CHAINFIXUP;
- end else
- begin for R8 := R6 step _14S until R5 do
- begin if LABEL(R7/10) = LABEL(R8) then
- begin R0 := LABELCHAIN(R7); R2:= @LABELCHAIN(R8-2);
- MERGECHAIN; goto X;
- end;
- end; R14:= @B14(14); LABEL(R14/14) := LABEL(R7);
- X: end; R14 := R14 - LABELBASE =: N3; LM(R6,R7,SAVE68);
- R2 := BLOCK; REDUCE(R2); BLOCK := R2; R5 := R10;
- while R2 < BLOCKLEVEL(R5) and ^NODATASEG do
- begin R2 := 7 + DC and _8 =: DC;
- R0 := DATAESDEND; R1 := DATAESDADR; CLOSESEG;
- R2 := PREVSEG(R5); if R2 = ENDCHAIN then
- begin SET(NODATASEG); R2 := BLOCK; R2 := @B2(1);
- R0 := R0 -- R0 =: COUNTER(R5) =: PL360NO(R1);
- end else
- begin R5 := R2; UNSTACKSEG; R2 := BLOCK; DATAESDEND := R0;
- end;
- end; R10 := R5; R8 := SAVE8;
- end;
- segment procedure GENMVCLC(R4);
- begin SAVE := R4;
- R0 := V(R7) and #FFFF; if R0 ^= V(R7) then
- begin XR := 11; ERROR; end;
- R2 := T(R7); R3 := R3-R3; R1 := V(R7+4);
- if R1 = R3 then !-- CELL LENGTH NOT GIVEN --!
- begin IC(R1,ALENGTH(R2)); R1 := @B1(1);
- end; if R1 > 256 then !-- TOO LONG --!
- begin XR := 24; ERROR; R1 := 256; end;
- CLI(1,MCTYPE); if = then
- begin !-- <T NUMBER> --!
- R3 := T2(R7); R4 := R4-R4; IC(R4,ALENGTH(R3));
- R4 := @B4(1); R3 := R3 and 3; if R3 > 1 or R1 > R4 then
- begin if R1 ^= R4 then
- begin XR := 1; ERROR; end; R3 := R3 xor 1;
- end else if R1 <= 3 then
- begin R3 := 3 - R1; EX(R3,CLC(0,V2(R7),0));
- if ^= then EX(R3,CLC(0,V2(R7),_1));
- if ^= then begin XR := 1; ERROR; end;
- if R3 = 0 then V2(R7/3) := V2(R7+1);
- end else R3 := 2;
- end else if < then
- begin !-- <T CELL> --!
- R4 := V(R7+4); R3 := V2(R7) and #FFFF;
- if R3 ^= V2(R7) then XR := 11 else
- begin if R4 ^= 0 or R2 = T2(R7) then goto X;
- XR := 1; !-- INVALID TYPES --!
- end; ERROR; !-- EITHER 1 OR 11 --!
- X: end else
- begin !-- <STRING> --!
- R3 := R3-R3; if R3=V(R7+4) or R1>V2(R7) then R1:=V2(R7);
- if R1 = 1 then V2(R7+3/1) := STRINGV;
- end; V(R7+4) := R1; REDUCE(R1);
- CLI(0,MCTYPE); if ^= then if R1 ^= 0 then
- begin R0 := R0-R0; CLI(2,MCTYPE);
- if = then R3 := @STRINGV else
- begin R0 := R3; R3 := @V2(R7);
- end; R2 := 4 + LC;
- MAKELITERAL; R0 := R0-R0; V2(R7) := R0;
- end else
- begin R3 := V2(R7) and #FF; R0 := 9; goto Y;
- end; R3 := R1; R0 := 13;
- Y: R2 := R2-R2; R1 := R2; IC(R1,MCCODE); STC(R0,MCTYPE);
- EMIT; R0 := V(R7); EDIT; CLI(13,MCTYPE);
- if = then !-- MVC OR CLC --!
- begin R0 := V2(R7); EDIT;
- end; CLI(5,MCCODE); if = then
- begin R1 := V1(R7) =: V(R7+8); R0 := ENDCHAIN =: V(R7) =: V(R7+4);
- end; R4 := SAVE;
- end;
- $PAGE
- R1 := R1 - XEQ2; case R1 of begin !-- EXECUTE3'S RULES --!
- begin !- <PROC2> ::= <PROC1><K REG> -!
- R0:=V1(R7); PROCCALL;
- end;
- begin !- <CELL ST> ::= <T CELL> := <K REG> -!
- R0 := T(R7); R1 := R0 shll 2 + T2(R7); R1 := @TYPETABLE(R1);
- CLI(0,B1); if = then begin XR := 1; ERROR; end;
- R0 := R0 + 4; R1 := R1-R1; R2 := V2(R7); R3 := V(R7); EMYT;
- end;
- begin !- <CELL ST> ::= <T CELL> := <T CELL> -!
- CLC(3,V(R7),V2(R7)); if ^= then
- begin MCTYPE := 0; MCCODE := 2; GENMVCLC; end;
- end;
- begin !- <CELL ST> ::= <T CELL> := <T NUMBER> -!
- MCTYPE := 1; MCCODE := 2; GENMVCLC;
- end;
- begin !- <CELL ST> ::= <T CELL> := <STRING> -!
- MCTYPE := 2; MCCODE := 2; GENMVCLC;
- end;
- begin !- <CELL ST> ::= <CELL ST><LOG OP><T CELL> -!
- MCTYPE := 0; R1 := V1(R7); STC(R1,MCCODE); GENMVCLC;
- end;
- begin !- <CELL ST> ::= <CELL ST><LOG OP><T NUMBER> -!
- MCTYPE := 1; R1 := V1(R7); STC(R1,MCCODE); GENMVCLC;
- end;
- begin !- <CELL ST> ::= <CELL ST><LOG OP><STRING> -!
- MCTYPE := 2; R1 := V1(R7); STC(R1,MCCODE); GENMVCLC;
- end;
- begin !- <SIMPLE ST> ::= <PROC ID> -!
- R0 := 16; PROCCALL;
- end;
- begin !- <SIMPLE ST> ::= <FUNC ID> -!
- R0 := V(R7); EDIT;
- if R0 > #FFFF then begin XR := 13; ERROR; end;
- end;
- begin !- <SIMPLE ST> ::= <FUNC3> -!
- R2 := FUNC0; R1 := LC; PROGRAM(R1) := R2;
- R3 := 2; R4 := R3; R2 := R2 shra 14; if ^= then
- begin R0 := FUNC1; PROGRAM(R1+2) := R0; if R2 > R3 then
- begin R0 := FUNC2; PROGRAM(R1+4) := R0; R4 := R4 + R3;
- end; R4 := R4 + R3;
- end; R1 := R1 + R4;
- LC := R1;
- R0:=R0-R0; FUNCCOUNT:=R0;
- end;
- begin !- <SIMPLE ST> ::= <CASE SEQ> END -!
- R0 := V(R7+4); if R0 = 0 then
- begin XR := 22; ERROR;
- end else
- begin R0 := R0 + LC =: R4 =: LC + PTAG;
- R1 := V(R7); R3 := PROGRAM(R1+2); if OPTFLAG < #80 then
- begin R2 := PTAG shrl 12; R2 := @B2(#F0);
- STC(R2,PROGRAM(R1+1)); PROGRAM(R1+2) := R4; R1 := R3;
- end; while REDUCE(R4); REDUCE(R4); R3 >= 0 do
- begin R2 := @B3(4) =: PROGRAM(R4); R3 := PROGRAM(R3+2);
- end; R2 := V(R7+8); R3 := @B2(6) =: PROGRAM(R4);
- REDUCE(R4); REDUCE(R4); R4 := R4 + PTAG =: PROGRAM(R2);
- CHAINFIXUP;
- end; CLOSEBLOCK;
- end;
- begin !- <SIMPLE ST> ::= <BLOCKBODY> END -!
- CLOSEBLOCK;
- end;
- begin !- <REL OP> ::= = -!
- R0 := 7; V(R7) := R0;
- end;
- begin !- <CONDITION> ::= <K REG><REL OP><T CELL> -!
- R0 := T2(R7); R1 := R0 shll 2 + T(R7); R1 := @TYPETABLE(R1);
- CLI(0,B1); if = then begin XR := 6; ERROR; end;
- R0 := R0 + 4; R1 := 9; R2 := V(R7); R3 := V2(R7); EMYT;
- R1 := V1(R7); INITCOND;
- end;
- begin !- <CONDITION> ::= <K REG><REL OP><T NUMBER> -!
- R2 := T2(R7); R1 := R2 shll 2 + T(R7); R1 := @TYPETABLE(R1);
- CLI(0,B1); if = then begin XR := 6; ERROR; end;
- R1 := R1 - R1; if R1 = V2(R7) and R1 = V2(R7+4) then
- begin R0 := T(R7); R1 := 2; R2 := V(R7); R3 := R2; EMIT;
- 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 := 9; R2 := V(R7); R3 := R3-R3; EMYT;
- end;
- R1 := V1(R7); INITCOND;
- end;
- begin !- <CONDITION> ::= <K REG><REL OP><K REG> -!
- R0 := T(R7);
- if R0 ^= T2(R7) then begin XR := 6; ERROR; end;
- R1 := 9; R2 := V(R7); R3 := V2(R7); EMIT;
- R1 := V1(R7); INITCOND;
- end;
- begin !- <CONDITION> ::= <K REG><REL OP><STRING> -!
- R0 := STRINGV; R1 := 4 - V2(R7);
- for R2 := 1 step 1 until R1 do R0 := R0 shrl 8;
- if R1 < 0 then begin XR := 21; ERROR; end;
- STRINGV := R0; R0 := 2; R1 := 3; R2 := 2 + LC;
- R3 := @STRINGV; MAKELITERAL; R0 := T(R7);
- if R0 ^= 1 then begin XR := 6; ERROR; end;
- R0 := 5; R1 := 9; R2 := V(R7); R3 := R3-R3; EMYT;
- R1 := V1(R7); INITCOND;
- end;
- begin !- <CONDITION> ::= <T NUMBER> -!
- R1 := R7 - 16S; R1 := S(R1);
- if R1=REPLIST1 or R1=TDECL3 then SET(FLAG) else
- begin R0 := 1; if R0 > T(R7) then
- begin XR := 25; ERROR;
- end; R1 := V(R7) and #F xor #F;
- if OPTFLAG < #80 then R1 := @B1(16); INITCOND;
- end;
- end;
- begin !- <CONDITION> ::= ^ <T NUMBER> -!
- R0 := 1; R1 := V1(R7) and #F;
- if R0 > T1(R7) then begin XR := 25; ERROR; end;
- if OPTFLAG < #80 then R1 := @B1(16); INITCOND;
- end;
- begin !- <CONDITION> ::= <T CELL><REL OP><T CELL> -!
- MCTYPE := 0; MCCODE := 5; GENMVCLC;
- end;
- begin !- <CONDITION> ::= <T CELL><REL OP><T NUMBER> -!
- MCTYPE := 1; MCCODE := 5; GENMVCLC;
- end;
- begin !- <CONDITION> ::= <T CELL><REL OP><STRING> -!
- MCTYPE := 2; MCCODE := 5; GENMVCLC;
- end;
- begin !- <CONDITION> ::= <T CELL> -!
- R0 := #95FFS; EDIT; R0 := V(R7); R1 := T(R7);
- if R0 > #FFFF then begin XR := 11; ERROR; end else
- if R1 < 4 then begin XR := 6; ERROR; end;
- EDIT; R1 := 7; INITCOND;
- $IFT D D
- if TM(2,DBGFLGS); ON then SET(PRNT); !-- List flag tests --!
- $END D
- end;
- begin !- <CONDITION> ::= ^ <T CELL> -!
- R0 := #95FFS; EDIT; R0 := V1(R7); R1 := T1(R7);
- if R0 > #FFFF then begin XR := 11; ERROR; end else
- if R1 < 4 then begin XR := 6; ERROR; end;
- EDIT; R1 := 9; INITCOND;
- $IFT D D
- if TM(2,DBGFLGS); ON then SET(PRNT); !-- List flag tests --!
- $END D
- end;
- begin !- <CONDITION> ::= <REL OP> -!
- R1 := V(R7); INITCOND;
- !-- HAD TO TAKE THIS ONE OUT OF THE WOODWORK ... --!
- end;
- begin !- <CONDITION> ::= <RP><PRIM COND> ) -!
- V(R7/8) := V1(R7); R0 := R0 -- R0 =: V(R7+8);
- end;
- begin !- <CONDITION> ::= <UNARY REG> -!
- short integer VH syn V(16); !-- For <UNARY OP> list --!
- if R0 := 6; R0 ^= VH(R7) then
- begin XR := 0; ERROR;
- end; if R0 := 1; R0 ^= T(R7) then
- begin XR := 7; ERROR;
- end; R1 := LC =: V(R7+4);
- R0 := #460 or V(R7) shll 4 =: PROGRAM(R1);
- R0 := #47F0S =: PROGRAM(R1+4);
- R0 := ENDCHAIN =: PROGRAM(R1+2) =: PROGRAM(R1+6);
- R1 := @B1(4) =: V(R7); R1 := @B1(4) =: LC;
- R0 := R0 -- R0 =: V(R7+8);
- end;
- begin !- <CONDITION> ::= ^ <UNARY REG> -!
- short integer VH syn V(32); !-- For <UNARY OP> list --!
- if R0 := 6; R0 ^= VH(R7) then
- begin XR := 0; ERROR;
- end; if R0 := 1; R0 ^= T1(R7) then
- begin XR := 7; ERROR;
- end; R1 := LC =: V(R7);
- R0 := #460 or V1(R7) shll 4 =: PROGRAM(R1);
- R0 := ENDCHAIN =: V(R7+4) =: PROGRAM(R1+2);
- R0 := R0 -- R0 =: V(R7+8); R1 := @B1(4) =: LC;
- end;
- begin !- <CONDITION> ::= <K REG><BRINDX OP><K REG> -!
- if R0 := 1; R0 ^= T(R7) or R0 ^= T2(R7) then
- begin XR := 7; ERROR;
- end; R0 := V1(R7) or V(R7) shll 4 or V2(R7);
- R1 := LC =: V(R7); PROGRAM(R1) := R0;
- R0 := ENDCHAIN =: PROGRAM(R1+2) =: V(R7+4);
- R1 := @B1(4) =: LC; R0 := R0 -- R0 =: V(R7+8);
- end;
- begin !- <RP> ::= ( -!
- R1 := R7 - 16S; R1 := S(R1);
- if R1^=IFTERM and R1^=DOTERM and R1^=COMPAOR
- and R1^=RPTERM and R1^=REPUNTIL then SET(FLAG);
- end;
- begin !- <COND> ::= <CONDITION> -!
- R1 := R7 - 16S; R1 := S(R1);
- if R1 ^= COMPAOR then SET(FLAG);
- end;
- begin !- <COMP COND> ::= <CONDITION> -!
- if R0 := V(R7+8); R0 ^= 0 then
- begin R1 := LC; R0 := R0 shll 4 or #4700 =: PROGRAM(R1);
- R0 := V(R7+4) =: PROGRAM(R1+2);
- V(R7) := R1; R1 := @B1(4) =: LC;
- end;
- end;
- begin !- <COMP COND> ::= <COMP AOR><COND> -!
- if R0 := V1(R7+8); R0 ^= 0 then
- begin R1 := LC; R0 := R0 shll 4 or #4700 =: PROGRAM(R1);
- R0 := V(R7) =: PROGRAM(R1+2);
- V(R7) := R1; R1 := @B1(4) =: LC;
- end else
- begin R0 := V1(R7); R2 := @V(R7); MERGECHAIN;
- R0 := V1(R7+4); R2 := @V(R7+4); MERGECHAIN;
- end;
- end;
- begin !- <COMP AOR> ::= <COMP COND> AND -!
- R0 := LC + PTAG; R1 := V(R7+4); CHAINFIXUP; V(R7+4) := R1;
- end;
- begin !- <COMP AOR> ::= <COMP COND> OR -!
- R3 := @V(R7); ANDTORCHAIN;
- R0 := LC + PTAG; R1:= V(R7); CHAINFIXUP; V(R7) := R1;
- end;
- begin !- <COND END> ::= <COMP COND> END -!
- R0 := LC =: V(R7+8); CLOSEBLOCK;
- end;
- begin !- <COND THEN> ::= <COMP COND> THEN -!
- R0 := LC; V(R7+8) := R0;
- end;
- begin !- <GOTO ST*> ::= GOTO <ID> -!
- V(R7/10) := V1(R7);
- end;
- begin !- <TRUE PART> ::= <SIMPLE ST> ELSE -!
- R0 := #F0; EMYTBRANCH; R0 := R0-R0; T(R7) := R0;
- end;
- begin !- <TRUE PART> ::= <GOTO ST*> ELSE -!
- R0 := 1; T(R7) := R0;
- R3 := R7 - 16S; R0 := S(R3); R2 := LC;
- if R0 = CONDEND then
- begin R1 := V(R3+4); R4 := V(R3);
- if R4 = ENDCHAIN or R4 := @PROGRAM(R4);
- CLI(#47,B4); ^= or CLI(#F0,B4(1)); < then
- begin R4 := R1; R1 := R2; PROGRAM(R1+2) := R4;
- R0 := #47F0S =: PROGRAM(R1); R2 := @B1(4) =: LC;
- end;
- end else if R0 ^= CONDTHEN then goto X else
- begin ANDTORCHAIN; R1 := V(R3+4); R2 := LC;
- end; V(R3+8) := R2; R2 := R7; ENTERBRANCH;
- X: end;
- begin !- <REPEAT> ::= REPEAT --!
- R0 := LC; V(R7) := R0;
- end;
- begin !- <WHILE> ::= WHILE -!
- R0 := LC; V(R7) := R0;
- end;
- begin !- <COND DO> ::= <COMP COND> DO -!
- R0 := LC + PTAG; V(R7+8) := R0;
- end;
- begin !- <ASS STEP> ::= <K REG ASS> STEP <T NUMBER> -!
- R1 := T(R7); R0 := T2(R7);
- if R1^=1 or R0>1 then begin XR := 2; ERROR; end;
- T(R7) := R0; R0 := V2(R7); V(R7+4) := R0;
- end;
- begin !- <LIMIT> ::= UNTIL <K REG> -!
- R0 := 1; if R0 ^= T1(R7) then begin XR := 2; ERROR; end;
- T(R7) := R0; R1 := V1(R7); V(R7) := R1;
- end;
- begin !- <LIMIT> ::= UNTIL <T CELL> -!
- R0 := T1(R7); if R0 > 1 then begin XR := 2; ERROR; end;
- R0 := R0 + 4; T(R7) := R0; R1 := V1(R7); V(R7) := R1;
- end;
- begin !- <LIMIT> ::= UNTIL <T NUMBER> -!
- R0 := 20; T(R7) := R0; R1 := V1(R7); V(R7) := R1;
- end;
- begin !- <DO> ::= DO -!
- R0 := #F0; EMYTBRANCH;
- end;
- begin !- <IF PART> ::= <IF><COND END> -!
- LM(R0,R1,V1(R7)); V(R7) := R0;
- R0 := V1(R7+8) + PTAG =: R5; CHAINFIXUP;
- R0 := R5; R1 := R7 - 32S; R1 := V(R1); CHAINFIXUP;
- end;
- begin !- <IF PART> ::= <IF><COND END><STATEMENT-> -!
- LM(R0,R1,V1(R7)); V(R7) := R0;
- R0 := V1(R7+8) + PTAG; CHAINFIXUP;
- R0 := LC + PTAG; R1 := R7 - 32S; R1 := V(R1); CHAINFIXUP;
- end;
- begin !- <IF PART> ::= <IF><COND END><GOTO ST> -!
- R1 := V1(R7+4); R2 := V1(R7) =: V(R7);
- if R2 = ENDCHAIN or R2 := @PROGRAM(R2);
- CLI(#47,B2); ^= or CLI(#F0,B2(1)); < then
- begin R2 := R1; R1 := LC; PROGRAM(R1+2) := R2;
- R0 := #47F0S =: PROGRAM(R1); R2 := @B1(4) =: LC;
- end; R2 := @V2(R7); ENTERBRANCH;
- R0 := LC + PTAG; R1 := R7 - 32S; R1 := V(R1); CHAINFIXUP;
- end;
- begin !- <IF PART> ::= <IF><COND END><TRUE PART><STATEMENT-> -!
- if R0 := T2(R7); R0 ^= 0 then R0 := V1(R7+8) else
- begin R0 := V1(R7+8) + PTAG; R1 := V1(R7+4); CHAINFIXUP;
- R0 := LC+PTAG; R1 := V2(R7); CHAINFIXUP; R0 := 4+V2(R7);
- end;
- R0 := R0 + PTAG; R1 := R7 - 32S; R1 := V(R1); CHAINFIXUP;
- R0 := V1(R7) =: V(R7);
- end;
- begin !- <IF PART> ::= <IF><COND END><TRUE PART><GOTO ST> -!
- R1 := R7 - 32S; R1 := V(R1); R2 := @V(R7+48); ENTERBRANCH;
- R0 := V1(R7) =: V(R7);
- if R0 := T2(R7); R0 = 0 then
- begin R0 := V1(R7+8) + PTAG; R1 := V1(R7+4); CHAINFIXUP;
- R0 := V2(R7) =: LC;
- end;
- end;
- begin !- <STATEMENT+> ::= <BLOCKBODY><IF PART> -!
- R0 := V1(R7) =: V(R7);
- end;
- begin !- <STATEMENT-> ::= <IF><COND THEN><STATEMENT-> -!
- R0 := V1(R7+8) + PTAG; R1 := V1(R7+4); CHAINFIXUP;
- R0 := LC + PTAG; R1 := V1(R7); CHAINFIXUP;
- end;
- begin !- <STATEMENT-> ::= <IF><COND THEN><GOTO ST> -!
- R3 := @V1(R7); ANDTORCHAIN;
- R1 := V1(R7+4); R2 := @V2(R7); ENTERBRANCH;
- R0 := LC + PTAG; R1 := V1(R7); CHAINFIXUP;
- end;
- begin !- <STATEMENT-> ::= <IF><COND THEN><TRUE PART><STATEMENT-> -!
- if R0 := T2(R7); R0 ^= 0 then R0 := V1(R7+8) else
- begin R0 := V1(R7+8) + PTAG; R1 := V1(R7+4); CHAINFIXUP;
- R0 := LC + PTAG; R1 := V2(R7) =: R5; CHAINFIXUP;
- R0 := @B5(4);
- end;
- R0 := R0 + PTAG; R1 := V1(R7); CHAINFIXUP;
- end;
- begin !- <STATEMENT-> ::= <IF><COND THEN><TRUE PART><GOTO ST> -!
- if R0 := T2(R7); R0 ^= 0 then
- begin LM(R1,R2,V1(R7)); if R2 = ENDCHAIN or R2 := @PROGRAM(R2);
- CLI(#47,B2); ^= or CLI(#F0,B2(1)); < then
- begin R2 := R1; R1 := LC; PROGRAM(R1+2) := R2;
- R0 := #47F0S =: PROGRAM(R1); R2 := @B1(4) =: LC;
- end;
- end else
- begin R0 := V1(R7+8) + PTAG; R1 := V1(R7+4); CHAINFIXUP;
- R0 := V2(R7) =: LC; R1 := V1(R7);
- end;
- R2 := @V(R7+48); ENTERBRANCH;
- end;
- begin !- <STATEMENT-> ::= <WHILE><COND DO><STATEMENT+> -!
- R0 := V1(R7+8); R1 := V1(R7+4); CHAINFIXUP;
- R0 := V(R7) + PTAG; R1 := V2(R7); CHAINFIXUP;
- end;
- begin !- <STATEMENT-> ::= <WHILE><COND DO><STATEMENT*> -!
- if R1 := V1(R7); R1 := @B1(4); R1 ^= LC then
- begin !-- NORMAL CASE, NOT A NULL STATEMENT --!
- R0 := V1(R7+8); R1 := V1(R7+4); CHAINFIXUP;
- R0 := #F0; R2 := V(R7); EMYTBRANCH;
- R1 := V(R7); R0 := R2 + PTAG; CHAINFIXUP;
- end else
- begin !-- HERE TO OPTIMIZE A NULL STATEMENT --!
- R3 := @V1(R7); ANDTORCHAIN;
- R0 := V(R7) + PTAG; R1 := V1(R7+4); CHAINFIXUP;
- end;
- R0 := LC + PTAG; R1 := V1(R7); CHAINFIXUP;
- end;
- end; LM(R1,R5,SAVEREG);
- end;
- $PAGE
- segment procedure EXECUTE4(R4); !-- XEQ3 < RULES <= XEQ4 --!
- begin procedure MOVEID (R1);
- begin V(R7/10) := V1(R7); R0 := T1(R7); STC(R0,T(R7));
- end; procedure TAGCELL (R5); !-- DOES NOT RETURN --!
- begin if R3 >= 4096S then begin XR := 12; ERROR; end;
- R0 := DBREG shll 12 or R3; R1 := @V1(R7);
- DC1 := R3; R3 := R3 + V(R7); DC := R3;
- R4 := DATAESDADR; R3 := PL360NO(R4);
- R3 := R3 shll 8; R2 := R2 or R3; R3 := T1(R7);
- $IFT M M
- if TESTFLAG then ENTERSYMDATA;
- $END M
- ENTERNAME; goto EXIT;
- end;
- R1 := R1 - XEQ3; case R1 of begin !-- EXECUTE4'S RULES --!
- begin !- <STATEMENT-> ::= <REPEAT> UNTIL <PRIM COND> -!
- R0 := V(R7) + PTAG; R1 := V2(R7); CHAINFIXUP;
- R0 := LC + PTAG; R1 := V2(R7+4); CHAINFIXUP;
- end;
- begin !- <STATEMENT-> ::= FOR <ASS STEP><LIMIT><DO><STATEMENT*> -!
- R5 := V1(R7+4); R2 := V1(R7); R1 := 10; EMITLIT;
- R1 := V(R7+48); R0 := LC + PTAG;
- PROGRAM(R1+2) := R0; R0 := T2(R7);
- R1 := 9; R2 := V1(R7); R3 := V2(R7); R5 := R3;
- if R0 = 1 then EMIT else
- if R0 = 20S then EMITLIT else EMYT;
- R0 := 4; R1 := 7; R3 := 4 + V(R7+48) + PTAG;
- R2 := V1(R7+4); if R2 >= 0 then R2 := 12 else R2 := 10; EMYT;
- end;
- begin !- <STATEMENT*> ::= <GOTO ST> -!
- R1 := LC; R0 := #47F0S; PROGRAM(R1) := R0;
- R0 := ENDCHAIN; PROGRAM(R1+2) := R0; R0 := 4 + R1; LC := R0;
- R2 := @V(R7); ENTERBRANCH;
- end;
- begin !- <SI T TYPE> ::= SHORT INTEGER -!
- R0 := R0-R0; T(R7) := R0; R0 := 2; V(R7) := R0;
- end;
- begin !- <SI T TYPE> ::= INTEGER -!
- R0 := 1; T(R7) := R0; R0 := 4; V(R7) := R0;
- end;
- begin !- <SI T TYPE> ::= LOGICAL -!
- R0 := 1; T(R7) := R0; R0 := 4; V(R7) := R0;
- end;
- begin !- <SI T TYPE> ::= REAL -!
- R0 := 3; T(R7) := R0; R0 := 4; V(R7) := R0;
- end;
- begin !- <SI T TYPE> ::= LONG REAL -!
- R0 := 2; T(R7) := R0; R0 := 8; V(R7) := R0;
- end;
- begin !- <SI T TYPE> ::= BYTE -!
- R0 := 4; T(R7) := R0; R0 := 1; V(R7) := R0;
- end;
- begin !- <SI T TYPE> ::= CHARACTER -!
- R0 := 4; T(R7) := R0; R0 := 1; V(R7) := R0;
- end;
- begin !- <T TYPE> ::= <SI T TYPE> -!
- RESET(FILLFLAG); !-- No dynamic fill --!
- end;
- begin !- <T TYPE> ::= ARRAY <T NUMBER><SI T TYPE> -!
- R1 := T2(R7); T(R7) := R1; R0 := T1(R7);
- R1 := V2(R7); R2 := V1(R7); RESET(FILLFLAG);
- if R2 = DTFILL then !-- DATAFILL --!
- begin R2 := R2-R2; SET(FILLFLAG);
- end; if R0>1 or R2<0 then !-- INVALID NUMBER --!
- begin XR := 25; ERROR;
- end else R1 := R1 * R2; V(R7) := R1;
- end;
- begin !- <FILL> ::= <STRING> -!
- if SKIPFLAG then goto X;
- R1 := V(R7); SETDATAINIT; if R1 = 0 then goto X;
- REDUCE(R1); EX(R1,MVC(0,B2,STRINGV));
- X: end;
- begin !- <FILL> ::= <ADR OP><T CELL> -!
- if SKIPFLAG then goto X;
- R5 := FILLTYPE; R1 := R1-R1; IC(R1,ALENGTH(R5));
- R1 := @B1(1); SETDATAINIT; if R1 = 0 then goto X;
- R0:=V1(R7); R1:=V(R7); if R1=0 then
- begin if R5>1 then XR:=24 else
- if R5=0 and R0>#FFFF then XR:=11 else
- begin if R5=0 then B2(0/2) := V1(R7+2) else
- B2(0/4) := V1(R7); goto X;
- end;
- end else
- begin if R5^=1 then XR:=24 else
- if R0>#FFFF then XR:=11 else
- if REPFLAG then XR:=30 else goto Z;
- end;
- ERROR; SET(SKIPFLAG); goto X;
- Z: R1:=R0 and #FFF; R4:=V1(R7+4) shll 24;
- R1:=R1 or R4; V1(R7):= R1; MVC(3,B2,V1(R7));
- R4:=V1(R7+8) shrl 8; !-- R4=SEGMENT NUMBER --!
- R3 := R4*10S; R3 := @ESDNAME(R3);
- if R4 >= MAXSEGNO or B3 = "DUMMY " then
- if SEGTYPE(R10) > 2 then goto X else
- begin XR := 30; ERROR; goto X;
- end;
- R0:=DATAESDEND;R1:=DATAESDADR; R2:=ER; R3:=ATYPE; FINDESDENTRY;
- if R0=DATAESDEND then !-- NOT A NEW ENTRY --!
- begin R2:=RLD; R5:=R1-DATAESDADR; R1:=R0; FINDESDENTRY;
- ESDLINK(R1):=R5; !-- RLD ENTRY POINTING TO MAIN ENTRY --!
- end;
- DATAESDEND:=R0; R0:=DC1-4; RLDADDR(R1):=R0;
- X: end;
- begin !- <FILL> ::= <ADR OP><PROC ID> -!
- if SKIPFLAG then goto X;
- R5:=FILLTYPE; R1:=R1-R1; IC(R1,ALENGTH(R5));
- R1 := @B1(1); SETDATAINIT; if R1=0 then goto X;
- R0:=V1(R7) shrl 24; R1:=V(R7); if R1=0 then
- begin if R5>1 then XR:=24 else
- begin R0:=V1(R7); SRDL(R0,12); R0:=R0 shrl 8 and #F;
- SLDL(R0,12); V1(R7):=R0; if R5=0 then
- B2(0/2) := V1(R7+2) else B2(0/4) := V1(R7); goto X;
- end;
- end else
- begin if R5^=1 then XR:=24 else
- if REPFLAG then XR:=30 else goto Z;
- end;
- ERROR; SET(SKIPFLAG); goto X;
- Z: R1:=V1(R7) and #FFF; V1(R7):=R1; B2(0/4) := V1(R7); R4:=R0;
- R0:=DATAESDEND;R1:=DATAESDADR; R2:=ER; R3:=ATYPE; FINDESDENTRY;
- if R0=DATAESDEND then !-- NOT A NEW ENTRY --!
- begin R2:=RLD; R5:=R1-DATAESDADR; R1:=R0; FINDESDENTRY;
- ESDLINK(R1):=R5; !-- RLD ENTRY POINTING TO MAIN ENTRY --!
- end;
- DATAESDEND:=R0; R0:=DC1-4; RLDADDR(R1):=R0;
- X: end;
- begin !- <FILL> ::= <T NUMBER> -!
- if SKIPFLAG then goto X;
- R5 := FILLTYPE; R1 := R1-R1; IC(R1,ALENGTH(R5));
- R1 := @B1(1); SETDATAINIT; if R1 = 0 then goto X;
- IC(R5,LENGTH(R5)); R5 := @B5(1);
- case R5 of begin
- B2(0/1) := V(R7+3); !-- BYTE FILL --!
- B2(0/2) := V(R7+2); !-- HALF WORD FILL --!
- B2(0/4) := V(R7); !-- FULL WORD FILL --!
- begin !-- DOUBLE WORD FILL --!
- R3 := T(R7); if R3 = 1 then
- begin LM(R3,R4,V(R7)); R5 := R3; STM(R4,R5,V(R7));
- end; B2(0/8) := V(R7);
- end;
- end;
- X: end;
- begin !- <FILL> ::= <REP LIST2> ) -!
- if SKIPFLAG then goto X;
- R1 := V(R7) - 1; if R1 = 0 then goto X;
- R5 := DC1 - V(R7+4); R1 := R1 * R5;
- SETDATAINIT; if R1 = 0 then goto X;
- R4 := R2; R2 := R1 - 1; R1 := R1 + R4; R3 := V(R7+8);
- while R4 < R1 do
- begin R5 := R2; while R5 >= 256S do
- begin B4(0/256) := B3; !-- MOVE DATA FIELD --!
- R3 := @B3(256); R4 := @B4(256); R5 := R5 - 256S;
- end; EX(R5,MVC(0,B4,B3)); R4 := @B4(R5+1);
- end;
- X: R0 := T(R7); STC(R0,SKIPFLAG);
- R0:=R0 shrl 8; STC(R0,REPFLAG);
- end;
- begin !- <REP LIST1> ::= <T NUMBER> ( -!
- IC(R2,REPFLAG); R2:=R2 shll 8;
- R0 := V(R7); R1 := T(R7); IC(R2,SKIPFLAG); T(R7) := R2;
- if R0<0 or R1>1 then begin XR := 25; SET(SKIPFLAG); ERROR; end;
- if R0=0 then SET(SKIPFLAG) else if R0>1 then SET(REPFLAG);
- R1 := R1-R1; SETDATAINIT; V(R7+8) := R2;
- R0 := DC1; V(R7+4) := R0;
- end;
- begin !- <REP LIST1> ::= ( -!
- R1 := R7 - 16S; R2 := S(R1); if R2 = REPLIST1 or R2 = TDECL3 then
- begin
- R0 := 1; V(R7) := R0; R0 := DC1; V(R7+4) := R0;
- IC(R2,REPFLAG); R2:=R2 shll 8;
- IC(R2,SKIPFLAG); T(R7) := R2;
- R1 := R1-R1; SETDATAINIT; V(R7+8) := R2;
- end else SET(FLAG);
- end;
- begin !- <T DECL1> ::= <T TYPE><ID> -!
- if NODATASEG then DATASEGERROR;
- R1 := R1-R1; R2 := T(R7); IC(R1,ALENGTH(R2));
- R3 := DC+R1; R1 := @B1(1); R1 := neg R1; R3 := R3 and R1;
- $IFT D D
- if R3 ^= DC then SET(PRNT);
- $END D
- TAGCELL; !-- DOES NOT RETURN HERE --!
- end;
- begin !- <T DECL1> ::= <T DECL2><ID> -!
- R3 := DC; R2 := T(R7);
- TAGCELL; !-- DOES NOT RETURN HERE --!
- end;
- begin !- <T DECL1> ::= <T TYPE> -!
- if NODATASEG then DATASEGERROR;
- R1 := R1 - R1; R2 := T(R7); IC(R1,ALENGTH(R2));
- R3 := DC+R1; R1 := @B1(1); R1 := neg R1; R3 := R3 and R1;
- if R3 > 4096S then begin XR := 12; ERROR; end;
- $IFT D D
- if R3 ^= DC then SET(PRNT);
- $END D
- DC1 := R3; R3 := R3 + V(R7); DC := R3;
- end;
- begin !- <T DECL1> ::= <T DECL2> -!
- R3 := DC; if R3 > 4096S then begin XR := 12; ERROR; end;
- DC1 := R3; R3 := R3 + V(R7); DC := R3;
- end;
- begin !- <T DECL3> ::= <T DECL1> = -!
- R0 := T(R7); FILLTYPE := R0; R0 := SEGTYPE(R10);
- if R0 ^= 2 then RESET(SKIPFLAG) else
- begin XR := 30; ERROR;
- end;
- end;
- begin !- <T DECL4> ::= <T DECL3><FILL> -!
- R2 := T(R7); R1 := R1-R1; IC(R1,ALENGTH(R2));
- R2 := DC + R1; R1 := @B1(1); R1 := neg R1;
- R2 := R2 and R1; !-- New ending --!
- $IFT D D
- if R2 ^= DC then SET(PRNT); !-- Non-aligned --!
- $END D
- DC := R2; SET(SKIPFLAG);
- end;
- begin !- <FUNC DC2> ::= <FUNC DC1><ID> -!
- MOVEID; !-- MOVE V AND T FIELDS --!
- end;
- begin !- <FUNC DC4> ::= <FUNC DC3><T NUMBER> -!
- R1 := V1(R7);
- if R1 < 0 or R1 >= FT then
- begin XR := 23; ERROR; R1 := R1-R1;
- end;
- STC(R1,T(R7+1));
- end;
- begin !- <FUNC DC6> ::= <FUNC DC5><T NUMBER> -!
- array FT byte TYPE = !-- Function lengths --!
- (_2,_2,0,0,0,2,_2,_2,0,0,2,0,0,2,2,0,0,0,0,0);
- R2 := V1(R7); R3 := T(R7); R1 := #FF and R3;
- if R2 < 0 or R2 > #FFFF then goto ERR;
- R0 := R1 shll 16 or R2; R3 := R3 shrl 8;
- R2 := R2 shrl 14 - 1 and #FE; IC(R1,TYPE(R1));
- if R1 ^= R2 then goto ERR;
- R1 := @V(R7); R2 := 11; ENTERNAME; goto X;
- ERR: XR := 23; ERROR;
- X: end;
- begin !- <SYN DC1> ::= <T TYPE><ID> SYN -!
- MOVEID; !-- MOVE V AND T FIELDS --!
- end;
- begin !- <SYN DC1> ::= <SI T TYPE> REGISTER <ID> SYN -!
- R0 := T(R7); V(R7/10) := V2(R7);
- if R0=0 or R0>3S then begin XR := 7; ERROR; R0 := 1; end;
- R0 := R0 + 80S; T(R7) := R0; R0 := T2(R7); STC(R0,T(R7));
- end;
- begin !- <SYN DC1> ::= <SYN DC3><ID> SYN -!
- MOVEID; !-- MOVE V AND T FIELDS --!
- end;
- begin !- <SYN DC2> ::= <SYN DC1><T CELL> -!
- R0 := V1(R7); R1 := @V(R7); R2 := T(R7);
- R3 := R2 shrl 8; R2 := R2 and #FF;
- if R2 > 80S then begin XR := 26; ERROR; end else begin
- $IFT M M
- if TESTFLAG then ENTERSYMDATA;
- $END M
- R2 := R2 or V1(R7+8); ENTERNAME; end;
- end;
- begin !- <SYN DC2> ::= <SYN DC1><T NUMBER> -!
- R0 := V1(R7); R1 := @V(R7); R2 := T(R7);
- R3 := R2 shrl 8; R2 := R2 and #FF; R4 := T1(R7);
- if R0<0 or R4>1 then begin XR := 25; ERROR; end else
- if R2 > 80S then begin XR := 26; ERROR; end else
- begin R2 := R2 or #FF00; ENTERNAME; end;
- end;
- begin !- <SYN DC2> ::= <SYN DC1><K REG> -!
- R0 := V1(R7); R1 := @V(R7); R2 := T(R7);
- R3 := R2 shrl 8; R2 := R2 and #FF;
- if R2 < 80S then begin XR := 26; ERROR; end else ENTERNAME;
- end;
- begin !- <EQUATE> ::= SHORT EQUATE -!
- R0 := 15; S(R7-2) := R0; !-- SHORT EQUATE type --!
- end;
- begin !- <EQUATE> ::= EQUATE -!
- R0 := 12; S(R7-2) := R0; !-- EQUATE type --!
- end;
- begin !- <PROC HD1> ::= PROCEDURE <ID> -!
- R2 := 10; R3 := T1(R7); T(R7) := R3;
- $IFT M M
- if TESTFLAG then
- begin R0 := LC; R1 := 3; ENTERSYMLABEL;
- end;
- $END M
- R1 := @V1(R7); R0 := R0-R0;
- ENTERNAME; V(R7) := R4;
- end;
- begin !- <PROC HD3> ::= <PROC HD2><K REG> -!
- R1 := V1(R7); R2 := T1(R7); V(R7+4) := R1;
- if R2^=1 or R1=0 then
- begin XR := 7; ERROR;
- end;
- end;
- begin !- <PROC HD5> ::= GLOBAL <PROC HD4> -!
- R1 := R7 - 16S; R1 := S(R1);
- if R1 = ENDFILE then SET(FLAG) else
- begin
- R0 := 1; T(R7) := R0; V(R7/8) := V1(R7); OPENPROCSEG;
- R2 := CSEGNO*10S; R2 := @ESDNAME(R2); R1 := T1(R7) - 1;
- R3 := V(R7); B2(0/10) := BLANK; EX(R1,MVC(0,B2,NAME(R3)));
- end;
- end;
- begin !- <PROC HD5> ::= EXTERNAL <PROC HD4> -!
- R0 := 3; T(R7) := R0; V(R7/8) := V1(R7); OPENPROCSEG;
- R2 := CSEGNO * 10S; R2 := @ESDNAME(R2); R1 := T1(R7) - 1;
- R3 := V(R7); B2(0/10) := BLANK; EX(R1,MVC(0,B2,NAME(R3)));
- end;
- begin !- <PROC HD5> ::= SEGMENT <PROC HD4> -!
- R0 := 1; T(R7) := R0; V(R7/8) := V1(R7); OPENPROCSEG;
- R2 := CSEGNO; CVD(R2,CONWORK); R2 := R2 * 10S;
- R2:=@ESDNAME(R2); B2(0/10) := SEGNAM;
- UNPK(2,7,B2(4),CONWORK); SETZONE(B2(6));
- end;
- begin !- <PROC HD6> ::= COMMON <PROC HD4> -!
- R5 := LC; if R5 ^= PROCBR then
- begin PROCLK := R5; R4 := #47F0S; PROGRAM(R5) := R4;
- R5 := @B5(4);
- end; V(R7/8) := V1(R7); R0 := R0-R0; T(R7) := R0;
- $IFT M M
- if TESTFLAG then
- begin R4 := PROCPTR; DISPFIELD(R4) := R5; end;
- $END M
- INCRSEGNO; R4 := R0; R1 := PROGESDADR;
- R2 := PBREG; R3 := R2 shll 4 + R2 + #5800S;
- PROGRAM(R5) := R3; R0 := RLDADDR(R1); PROGRAM(R5+2) := R0;
- RLDADDR(R1) := R5; R3 := ATYPE; R2 := LD;
- R0 := PROGESDEND; FINDESDENTRY; PROGESDEND := R0;
- RLDADDR(R1) := R5; R5 := @B5(4); LC := R5;
- R4 := R4 * 10S; R4 := @ESDNAME(R4); R3 := V(R7);
- B4(0/10) := BLANK; R2 := T1(R7) - 1;
- EX(R2,MVC(0,B4,NAME(R3))); ADR(R3+2) := R5;
- R0 := CSEGNO shll 8; R1 := PBREG shll 4
- or R0 or V(R7+4); ADR(R3) := R1;
- end;
- begin !- <PROC HD6> ::= <PROC HD4> -!
- R5 := LC; if R5 ^= PROCBR then
- begin PROCLK := R5; R4 := #47F0S; PROGRAM(R5) := R4;
- R5 := R5 + 4; LC := R5;
- end;
- $IFT M M
- if TESTFLAG then
- begin R4 := PROCPTR; DISPFIELD(R4) := R5; end;
- $END M
- R4 := V(R7); ADR(R4+2) := R5; R0 := CSEGNO shll 8;
- R1 := PBREG shll 4 or R0 or V(R7+4); ADR(R4) := R1;
- R0 := R0-R0; T(R7) := R0;
- end;
- begin !- <PROC HD6> ::= <PROC HD5> -!
- R1 := V(R7); R2 := PBREG shll 4 or V(R7+4);
- R4 := CSEGNO shll 8 or R2; ADR(R1) := R4;
- end;
- begin !- <PROC HD6> ::= <PROC HD5> BASE <K REG> -!
- R0 := T2(R7); R1 := V2(R7); PBREG := R1;
- if R0^=1 or R1=0 then begin XR := 7; ERROR; end;
- R1 := V(R7); R2 := PBREG shll 4 or V(R7+4);
- R4 := CSEGNO shll 8 or R2; ADR(R1) := R4;
- end;
- begin !- <PROC HD7> ::= <PROC HD6> ; -!
- R1 := PBREG shll 12; PTAG := R1;
- end;
- begin !- <GLOB HD1> ::= GLOBAL <PROC HD4> -!
- R0 := 1; T(R7) := R0; V(R7/8) := V1(R7); OPENPROCSEG;
- R2 := CSEGNO * 10S; R2 := @ESDNAME(R2); R1 := T1(R7) - 1;
- R3 := V(R7); B2(0/10) := BLANK; EX(R1,MVC(0,B2,NAME(R3)));
- if SEGNAM = "SEG" then
- begin SEGNAM(1) := "NN"; R3 := 2;
- if R1 > R3 then R1 := R3; EX(R1,MVC(0,SEGNAM,B2));
- end;
- end;
- begin !- <GLOB HD> ::= <GLOB HD1> BASE <K REG> -!
- R0 := T2(R7); R1 := V2(R7); PBREG := R1;
- if R0^=1 or R1=0 then begin XR := 7; ERROR; end;
- end;
- end; EXIT: LM(R1,R5,SAVEREG);
- end;
- $PAGE
- segment procedure BRANCHFIXUP(R8);
- begin !-- This routine does branch optimization --!
- dummy base R2;
- byte OPCODE, COND;
- short integer NEXT;
- short integer OP syn OPCODE;
- close base;
- short integer WORK syn CONWORK;
- R12 := N6 =: R0 + BRANCHBASE; R1 := BRANCHADR(R12) =: N6;
- R3 := N5 + BRANCHBASE; R0 := R0 - 4S; if < then R0 := R0 -- R0;
- N5 := R0; while R12 := @B12(4); R12 <= R3 do
- begin R2 := BRANCHADR(R12) and #FFFF;
- if OPTFLAG < #80 then goto B; R0 := @PROGRAM(0) - PTAG;
- while R2 := R2 + R0; OPCODE=#07 or OPCODE=#47 do
- begin if OPCODE = #07 then
- begin if TM(#0F,COND); OFF or TM(#F0,COND); OFF then
- R2 := @B2(2) - R0 else
- if MIXED then goto A else R2 := OP shll 12;
- end else
- if TM(#F0,COND); OFF then R2 := @B2(4) - R0 else
- if CLI(#F0,COND); ^= then goto A else
- begin if R1 := NEXT; R1 >= ENDCHAIN and R1 < 4096S then
- begin R0 := BRANCHAIN(R12) =: NEXT; R0 := R1; R4 := R2;
- while R1 := NEXT; R1 ^= ENDCHAIN and
- if < or R1 >= 4096S then goto X;
- R14 := @PROGRAM(R1); R14 ^= R4 do R2 := R14;
- NEXT := R0; if R1 = ENDCHAIN then goto X;
- BRANCHAIN(R12) := R1; R2 := BRANCHADR(R12);
- end else R2 := R1;
- end; R2 := R2 and #FFFF; R1 := R2 and #F000;
- if R1 ^= PTAG then goto B;
- if R1 := BRANCHADR(R12) and #FFFF; R2 = R1 then
- begin R1 := 1 + ERRCOUNT =: ERRCOUNT;
- if R1 > ERRLIMIT then goto B;
- WBUFF(0/125) := BLANK; WBUF(11) := "INFINITE LOOP AT";
- WORK := R2; NI(#0F,WORK); UNPK(4,2,WBUF(12+STRING),WORK);
- TR(3,WBUF(12+STRING),TRTABLE(_240));
- WBUF(16+STRING) := " "; WBUF(108) := "*";
- WBUF(109/16) := WBUF(108); RESET(RUNFLAG);
- if GENFLAG then RESET(GENDECK); PRINT;
- if R1 = ERRLIMIT then ENDMESSAGES;
- goto B;
- end;
- end;
- A: R2 := R2 -- R0;
- B: R1 := BRANCHAIN(R12); while R1 >= 0 do
- begin R0 := PROGRAM(R1+2); PROGRAM(R1+2) := R2; R1 := R0;
- end;
- X: end;
- end;
- $PAGE
- procedure SETNAME (R4);
- begin R0 := EQUHOLD; R1 := @V(R7); R3 := T(R7);
- if R3 ^= 0 then ENTERNAME; goto EXIT;
- end;
- procedure CHKEQUATE (R4);
- begin R0 := 1; CLI(1,T2(R7+1)); if > then
- begin SAVE := R4; XR := 25; ERROR;
- R4 := SAVE; R0 := R0-R0; T(R7) := R0;
- end; LTR(R0,R0);
- end;
- procedure EQUARITH (R4);
- begin function SETUP(6,#0500);
- SAVE := R4; !- Save return -!
- R0 := EQUHOLD; SRDA(R0,32); R3 := V2(R7);
- R2 := V1(R7) - 10S + R2; if < then
- begin XR := 4; ERROR; R2 := R2-R2; R3 := R2;
- end; if R3 = 0 and R2 = 6 then
- begin !-- DIVISION BY ZERO --! XR := 19; ERROR; R3 := 1;
- end; SETUP(R5); EX(R0,B5(R2+8)); goto X;
- R1 := R1 + R3;
- R1 := R1 - R3;
- R1 := R1 * R3;
- R1 := R1 / R3;
- R1 := R1 ++ R3;
- R1 := R1 -- R3;
- X: EQUHOLD := R1; R4 := SAVE;
- end;
- !-- MAIN CODE OF EXECUTE PROCEDURES --!
- STM(R1,R5,SAVEREG);
- if R1 <= XEQ2 then !-- Low range --!
- begin if R1 <= XEQ1 then EXECUTE1; EXECUTE2; end;
- if R1 <= XEQ4 then !-- Mid range --!
- begin if R1 <= XEQ3 then EXECUTE3; EXECUTE4; end;
- !-- XEQ4 < RULES <= END --!
- R1:=R1 - XEQ4; case R1 of begin
- begin !- <DSEG TYPE> ::= GLOBAL DATA <ID> -!
- R0 := 1; T(R7) := R0; V(R7/10) := V2(R7); INCRSEGNO;
- end;
- begin !- <DSEG TYPE> ::= EXTERNAL DATA <ID> -!
- R0 := 3; T(R7) := R0; V(R7/10) := V2(R7); INCRSEGNO;
- end;
- begin !- <DSEG TYPE> ::= COMMON DATA <ID> -!
- R0 := 2; T(R7) := R0; V(R7/10) := V2(R7); INCRSEGNO;
- end;
- begin !- <DSEG TYPE> ::= COMMON -!
- R0 := 2; T(R7) := R0; V(R7/10) := BLANK; INCRSEGNO;
- end;
- begin !- <DSEG TYPE> ::= SEGMENT -!
- R0:=1; T(R7):=R0; V(R7/10) := SEGNAM; INCRSEGNO;
- CVD(R0,CONWORK); UNPK(2,7,V(R7+4),CONWORK); SETZONE(V(R7+6));
- end;
- begin !- <DSEG TYPE> ::= DUMMY -!
- R0 := 4; T(R7) := R0; R0 := MAXSEGNO;
- if NODATASEG and R0 > NSEGNO then SEGNO := R0 else INCRSEGNO;
- end;
- begin !- <DECL> ::= <PROC HD7><STATEMENT*> -!
- R0 := V(R7+4) or #07F0; !-- EMIT RETURN INSTRUCTION --!
- R4 := LC; PROGRAM(R4) := R0; R4 := R4 + 2;
- R0 := T(R7); if R0 ^= 0 then
- begin !-- CLOSE PROCEDURE SEGMENT --!
- for R1 := 14 + N4 step 14S until N3 do LABELERROR;
- ALLOCATELITERALS;
- if R4 > 4096S then
- begin R0 := R4; XR := 16; ERROR; R4 := R0;
- end; LC := R4;
- $IFT M M
- if TESTFLAG then
- begin R0 := R4 - 2S; R1 := 5; ENTERSYMLABEL; end;
- $END M
- BRANCHFIXUP; !-- DO BRANCH OPTIMIZATION --!
- R0 := LC; R1 := LASTINITIAL(R9); INITIALEN(R1) := R0;
- R0 := PROGESDEND; R1 := PROGESDADR; R5 := R9; CLOSESEG;
- R5 := PREVSEG(R5); UNSTACKSEG; PROGESDEND := R0;
- R9 := R5; R3 := PBREG shll 12; PTAG := R3; R2 := N4;
- R2 := R2 + LABELBASE; R0 := LABELADR(R2); N4 := R0;
- R0 := LABEL(R2+8); CSEGNO := R0;
- R2 := R2 - LABELBASE;
- if R2 ^= 0 then R2 := R2 - 14S; N3 := R2;
- end else
- begin R3 := R4 + PTAG; R2 := PROCLK;
- PROGRAM(R2+2) := R3; PROCBR := R4; LC := R4;
- end;
- end;
- begin !- <DECL> ::= <DSEG TYPE> BASE <K REG> -!
- R1 := T2(R7); R2 := V2(R7);
- if R1 ^= 1 then begin XR := 7; ERROR; end;
- Y: R0 := DATAESDEND; R1 := DATAESDADR; R5 := R10;
- if NODATASEG then RESET(NODATASEG) else STACKSEG;
- $IFF M M
- R2 := T(R7); R3 := V2(R7); OPENSEG; R10 := R5;
- $END M
- $IFT M M
- R2 := T(R7) + #010000; R3 := V2(R7); OPENSEG; R10 := R5;
- $END M
- R0 := R1; R2 := T(R7); if R2 = 2 then R2 := CM else R2 := SD;
- R3 := ATYPE; R4 := SEGNO; FINDESDENTRY; DATAESDEND := R0;
- R0 := R0-R0; R2 := T(R7); if R2 ^= 4 and R0 ^= V2(R7) then
- begin R0 := PROGESDEND; R1 := PROGESDADR;
- CLC(9,V(R7),BLANK);
- if = and R2=2 then R2:=XCM else R2:=ER;
- R3 := ATYPE; R4 := SEGNO; FINDESDENTRY; PROGESDEND := R0;
- R2 := RLDADDR(R1); R3 := LC; PROGRAM(R3+2) := R2;
- RLDADDR(R1) := R3; R0 := V2(R7) shll 4 or #5800;
- PROGRAM(R3) := R0; R3 := R3 + 4; LC := R3;
- end;
- R1 := SEGNO * 10S; R1 := @ESDNAME(R1); B1(0/10) := V(R7);
- end;
- begin !- <DECL> ::= CLOSE BASE -!
- R2 := BLOCK; if R2^=BLOCKLEVEL(R10) or NODATASEG then
- begin XR := 28; ERROR;
- end else
- begin R0 := DATAESDEND; R1 := DATAESDADR; R5 := R10; CLOSESEG;
- R2 := PREVSEG(R5); if R2 = ENDCHAIN then
- begin SET(NODATASEG); R0 := R0-R0; DC:=R0; PL360NO(R1) := R0;
- end else
- begin R5 := R2; UNSTACKSEG; DATAESDEND := R0; R10 := R5;
- end;
- end;
- end;
- begin !- <DECL> ::= <EQU SYN2> -!
- R2 := S(R7-2); SETNAME; !-- NO RETURN --!
- end;
- begin !- <LABEL DEF> ::= <ID> : -!
- R8 := LABELBASE + N4; R0 := LC + PTAG;
- for R2 := LABELBASE + N3 step _14S until R8 do
- if V(R7/10) = LABEL(R2) then
- begin if R4 := LABELADR(R2); R4 = 0 then goto X;
- XR := 9; ERROR; goto L;
- end; R2 := 14 + N3 =: N3 + LABELBASE;
- LABEL(R2/10) := V(R7); R1 := ENDCHAIN =: LABELCHAIN(R2);
- X: LABELADR(R2) := R0;
- L:
- $IFT M M
- if TESTFLAG then begin R1 := 1; ENTERSYMLABEL; end;
- $END M
- end;
- begin !- <BLOCKHEAD> ::= BEGIN -!
- R0 := N4; R1 := 14 + N3 =: N3 =: N4;
- R1 := R1 + LABELBASE; B1(0/12) := ZERO; LABELADR(R1) := R0;
- R0 := N2; LABEL(R1+4) := R0; R0 := N1; N2 := R0;
- R0 := DBREG; LABEL(R1) := R0;
- R0 := PROCBR =: LABEL(R1+6);
- R0 := 1 =: PROCBR;
- R0 := PROCLK =: LABEL(R1+12);
- R2 := 1 + BLOCK; BLOCK := R2;
- end;
- begin !- <PROGRAM-> ::= . -!
- R0 := N6; R1 := 4 + N5 =: N5 =: N6 + BRANCHBASE;
- BRANCHADR(R1) := R0;
- R0 := R0-R0; T(R7) := R0; R0 := 14; V(R7+4) := R0;
- R0 := PROGREG; PBREG := R0;
- if OSSYSTEM then
- begin R0 := #90ECS; PROGRAM(0) := R0; R0 := #D00CS;
- PROGRAM(2) := R0; R3 := 15; if R3 ^= PROGREG then
- begin R0 := 4; LC := R0; R0 := 1; R1 := 8; R2 := PROGREG;
- EMIT; R1 := 2;
- end else R1 := R1-R1;
- R0 := #18EDS; PROGRAM(R1+4) := R0;
- R0 := #58D0S; PROGRAM(R1+6) := R0;
- R0 := #50E0S; PROGRAM(R1+10) := R0;
- R0 := #D004S; PROGRAM(R1+12) := R0;
- R0 := #50D0S; PROGRAM(R1+14) := R0;
- R0 := #E008S; PROGRAM(R1+16) := R0;
- R0 := #D703S; PROGRAM(R1+18) := R0;
- R0 := #E010S; PROGRAM(R1+20) := R0; PROGRAM(R1+22) := R0;
- R1 := R1 + 24S; LC := R1;
- end else
- begin R0 := #05F0; PROGRAM(0) := R0; R0 := 2; LC := R0;
- R0 := 5; R1 := 8; R2 := PROGREG; R3 := #F; EMIT;
- R1 := PROGESDADR; R2 := RLDADDR(R1); PROGRAM(4) := R2;
- R0 := 2; RLDADDR(R1) := R0;
- R0 := #58D0S; PROGRAM(6) := R0; R0 := 10; LC := R0;
- end;
- $IFF M M
- R2 := 1; R3 := STARTADR shrl 12; R5 := R10; OPENSEG;
- $END M
- $IFT M M
- R2 := #010001; R3 := STARTADR shrl 12; R5 := R10; OPENSEG;
- $END M
- RESET(NODATASEG); R1 := DATAESDADR; R0 := R1; R2 := SD;
- R3 := ATYPE; R4 := R4-R4; FINDESDENTRY; DATAESDEND := R0;
- R0 := PROGESDEND; R1 := PROGESDADR; R2 := ER; FINDESDENTRY;
- PROGESDEND := R0; R2 := RLDADDR(R1); R0 := 15;
- if R0 ^= PROGREG and OSSYSTEM then
- begin PROGRAM(10) := R2; R2 := 8;
- end else
- begin PROGRAM(8) := R2; R2 := 6;
- end;
- RLDADDR(R1) := R2; R0 := 1; BLOCKLEVEL(R10) := R0;
- R0 := STARTADR and #FFF; DC := R0; RESET(NOPROGSEG);
- end;
- begin !- <PROGRAM-> ::= . <GLOB HD> ; -!
- V(R7/16) := V1(R7); RESET(NOPROGSEG);
- R1 := PBREG shll 12; PTAG := R1;
- R1 := V(R7); R2 := PBREG shll 4 or V(R7+4);
- R4 := CSEGNO shll 8 or R2; ADR(R1) := R4;
- end;
- begin !- <PROGRAM*> ::= <PROGRAM-><STATEMENT*> -!
- if R5 ^= ENDFILE then begin SET(FLAG); goto X; end;
- R4 := LC; R0 := T(R7); if R0 = 0 and OSSYSTEM then
- begin R0 := #58D0S; PROGRAM(R4) := R0;
- R0 := #D004S; PROGRAM(R4+2) := R0;
- R0 := #98ECS; PROGRAM(R4+4) := R0;
- R0 := #D00CS; PROGRAM(R4+6) := R0; R4 := R4 + 8S;
- end else if R0 = 0 then
- begin R0 := #0A0E; PROGRAM(R4) := R0; R4 := R4 + 2; goto Y;
- end;
- R0 := #07F0 or V(R7+4); PROGRAM(R4) := R0; R4 := R4 + 2;
- Y: ALLOCATELITERALS; LC := R4;
- $IFT M M
- if TESTFLAG then
- begin R0 := R4 - 2S; R1 := 5; ENTERSYMLABEL; end;
- $END M
- R2 := LASTINITIAL(R9); INITIALEN(R2) := R4;
- if R4 > 4096S then begin XR := 16; ERROR; end;
- BRANCHFIXUP; !-- DO BRANCH OPTIMIZATION --!
- R1 := N4; while R1 := @B1(14); R1 <= N3 do
- begin R2 := R1 + LABELBASE; R0 := LABELADR(R2);
- if R0 = 0 then LABELERROR;
- end;
- R0 := PROGESDEND; R1 := PROGESDADR; R5 := R9; CLOSESEG;
- X:
- end;
- begin !- <EQU SYN1> ::= <EQUATE><ID> SYN -!
- V(R7/10) := V1(R7); R0 := T1(R7); T(R7) := R0;
- end;
- begin !- <EQU SYN2> ::= <EQU SYN1><T NUMBER> -!
- R0 := V1(R7); CLI(1,T1(R7+1)); if > then
- begin XR := 25; ERROR; R0 := R0-R0; T(R7) := R0;
- end; EQUHOLD := R0;
- end;
- begin !- <EQU SYN2> ::= <EQU SYN3><ARITH OP><T CELL> -!
- R1 := V1(R7); if R1 ^= 11S then !-- ^= - --!
- begin XR := 4; ERROR; R1 := R1-R1; T(R7) := R1; end;
- R0 := V2(R7) and #FFFF; if R0^=V2(R7) then
- begin XR:=11; ERROR; end;
- R0 := EQUHOLD and #F000; R1 := V2(R7) and #F000;
- if R0^=R1 then
- begin XR:=26; ERROR; end;
- R1 := EQUHOLD - V2(R7);
- EQUHOLD := R1;
- end;
- begin !- <EQU SYN2> ::= <EQU SYN2><ARITH OP><STRING> -!
- R3 := STRINGV; R1 := 4 - V2(R7); if < then
- begin XR := 21; ERROR; !- Invalid length -!
- end else !- Valid string length -!
- begin for R2 := 1 step 1 until R1 do R3 := R3 shrl 8;
- V2(R7) := R3; EQUARITH;
- end;
- end;
- begin !- <EQU SYN2> ::= <EQU SYN2><ARITH OP><T NUMBER> -!
- CHKEQUATE; if ^= then EQUARITH;
- end;
- begin !- <EQU SYN2> ::= <EQU SYN2><LOG OP><STRING> -!
- R3 := STRINGV; R1 := 4 - V2(R7); if < then
- begin XR := 21; ERROR; !- Invalid length -!
- end else !- Valid string length -!
- begin for R2 := 1 step 1 until R1 do R3 := R3 shrl 8;
- R1 := EQUHOLD; !- String in R3 -!
- R2 := V1(R7) shll 8 + #1013S; EQUHOLD := R2;
- EX(R0,EQUHOLD(2)); EQUHOLD := R1;
- end;
- end;
- begin !- <EQU SYN2> ::= <EQU SYN2><LOG OP><T NUMBER> -!
- CHKEQUATE; if ^= then
- begin R1 := EQUHOLD; R3 := V2(R7);
- R2 := V1(R7) shll 8 + #1013S; EQUHOLD := R2;
- EX(R0,EQUHOLD(2)); EQUHOLD := R1;
- end;
- end;
- begin !- <EQU SYN2> ::= <EQU SYN2><SHIFT OP><T NUMBER> -!
- R3 := V2(R7); CHKEQUATE; if ^= then
- if R3 < 0 or R3 >= 32S then
- begin XR := 25; ERROR; R0 := R0-R0; T(R7) := R0;
- end else
- begin R0 := EQUHOLD; R2 := #80 + V1(R7) shll 24 or R3;
- EQUHOLD := R2; EX(R0,EQUHOLD); EQUHOLD := R0;
- end;
- end;
- begin !- <EQU SYN2> ::= <EQU SYN1><UNARY NUM> -!
- byte VC syn V(32), OPCD syn B2;
- R1 := V1(R7); R2 := R2 -- R2; if CLI(1,T1(R7+1)); ^= then
- begin XR := 25; ERROR; R1 := R2 =: T(R7);
- end; IC(R2,VC(R7)); R2 := @VC(R7+R2+2); SET(B2);
- R2 := @VC(R7); while R2 := @B2(1); ^OPCD do
- if OPCD = 4 then
- begin XR := 26; ERROR;
- end else if OPCD = 6 then REDUCE(R1) else
- begin R0 := R0 -- R0; IC(R0,OPCD);
- R0 := R0 shll 8 or #1011 =: EQUHOLD; EX(R0,EQUHOLD(2));
- end; EQUHOLD := R1;
- end;
- begin !- <EQU SYN3> ::= <EQU SYN1><T CELL> -!
- R0 := V1(R7); EQUHOLD := R0;
- R0 := R0 and #FFFF; if R0^=EQUHOLD then
- begin XR:=11; ERROR; end;
- end;
- begin !- <EQU SYN2> ::= <EQU SYN1><STRING> -!
- R0 := STRINGV; R1 := 4 - V1(R7);
- for R2 := 1 step 1 until R1 do R0 := R0 shrl 8;
- if R1 < 0 then begin XR := 21; ERROR; end;
- EQUHOLD := R0;
- end;
- begin !- <EQU SYN2> ::= <EQU SYN1><K REG> -!
- R0 := V1(R7); EQUHOLD := R0;
- end;
- begin !- <EQUATE> ::= <EQU SYN2> , -!
- R2 := S(R7-2); SETNAME; !-- NO RETURN --!
- end;
- begin !- <PROC SYN> ::= PROCEDURE <ID> SYN -!
- V(R7/10) := V1(R7); R0 := T1(R7); T(R7) := R0;
- end;
- begin !- <DECL> ::= <PROC SYN> <PROC ID> -!
- R0 := V1(R7); EQUHOLD := R0; R2 := 10; SETNAME;
- end;
- begin !- <FORUNTIL> ::= UNTIL -!
- R1 := R7 - 32S; R2 := FORSYMBOL;
- if R2 ^= S(R1) then SET(FLAG);
- end;
- begin !- <REPUNTIL> ::= UNTIL -!
- end;
- end;
- EXIT: LM(R1,R5,SAVEREG);
- end;
- close base; !-- CLOSE DATA SEGMENT --!
- segment base R11; !-- USE R11 FOR BASE OF ESDNAMETABLE --!
- array NAMETBLLEN byte ESDNAMETABLE=
- ("SEGN000 ","SEGN001 ","READ ","WRITE ","PUNCH ",
- "PAGE ","PRINT ","OPEN ","GET ","PUT ",
- "KLOSE ","CANCEL ","BCDTOVAL ","VALTOBCD ");
- close base;
- segment base R8; !-- CHANGE BASE REGISTERS --!
- array 1366 byte PRTB =
- (255,0,1,14,47,2,5,106,1,14,71,2,78,106,1,14,72,2,94,106,1,14,73,
- 2,1,106,1,14,74,2,10,106,1,14,75,2,11,106,1,14,76,2,12,106,1,14,
- 77,3,5,97,106,1,14,78,3,3,97,106,1,14,79,2,5,22,1,23,113,2,78,22,
- 1,23,114,2,1,22,1,23,115,2,94,22,1,23,116,2,1,88,1,23,128,255,0,
- 2,5,1,1,101,2,8,4,255,1,101,3,19,6,0,3,21,107,255,1,101,4,16,95,
- 0,4,21,108,255,2,1,106,5,81,100,2,5,106,5,81,101,2,78,106,5,81,
- 102,2,94,106,5,81,103,2,5,22,5,23,119,2,78,22,5,23,120,2,94,22,5,
- 23,121,0,5,23,122,255,1,102,6,5,2,2,94,96,6,6,55,2,78,96,6,6,56,
- 255,1,102,7,5,3,2,78,96,7,6,57,2,1,96,7,6,58,255,1,94,8,6,59,1,
- 78,8,6,60,1,1,8,7,61,255,1,5,9,10,62,1,10,9,10,63,1,78,9,11,64,1,
- 11,9,11,65,1,1,9,12,66,1,12,9,12,67,3(255),0,12,23,126,2(255),0,
- 14,21,7,2,94,96,14,14,80,2,5,96,14,14,81,2,78,96,14,14,82,2,1,96,
- 14,14,83,2,94,13,14,14,84,2,5,13,14,14,85,2,78,13,14,14,86,2,1,
- 13,14,14,87,2,78,95,14,14,88,2,1,95,14,14,89,2,78,125,14,32,143,
- 255,1,104,15,16,5,1,102,15,17,96,255,1,78,16,15,90,1,1,16,15,91,
- 1,5,16,15,92,1,94,16,15,93,1,17,16,15,94,255,0,17,21,109,255,1,
- 68,18,18,44,2,98,37,18,18,98,1,112,18,21,110,255,1,1,19,20,99,
- 255,1,102,20,21,10,255,0,21,35,12,1,120,21,29,138,255,0,22,23,
- 124,255,0,23,80,130,0,23,24,131,255,0,24,83,40,1,111,24,25,133,1,
- 110,24,25,134,1,112,24,86,135,1,126,24,26,136,1,107,24,31,142,
- 255,2,98,37,25,25,38,1,80,25,24,132,2(255),0,27,28,11,1,120,27,
- 29,139,255,0,28,36,162,2(255),2,98,37,30,30,39,2,84,31,30,35,158,
- 2,36,31,30,35,159,5(255),0,35,36,13,255,0,36,37,14,2(255),0,38,
- 39,170,3,114,93,143,38,54,189,255,1,93,39,43,179,0,39,43,181,2,
- 114,93,39,54,188,2(255),1,40,41,42,16,255,1,104,42,41,15,1,102,
- 42,40,176,255,0,43,46,18,1,99,43,45,183,255,1,93,44,43,180,0,44,
- 43,182,255,1,40,45,46,184,255,1,104,46,44,17,0,46,67,28,255,1,93,
- 47,48,185,255,1,101,48,49,21,255,1,78,49,50,186,255,1,104,50,51,
- 22,255,1,78,51,52,187,255,1,102,52,53,23,255,1,104,53,47,20,0,53,
- 67,29,255,1,5,54,55,191,1,78,54,55,192,1,1,54,55,193,255,1,104,
- 55,56,24,0,55,67,30,255,2,114,93,56,54,190,255,1,101,57,58,25,
- 255,1,1,58,59,197,255,1,102,59,60,26,255,0,60,62,202,255,0,61,62,
- 203,2,1,116,61,62,204,255,1,98,62,63,205,255,1,36,63,67,214,
- 2(255),0,65,64,27,2,1,116,65,64,207,255,2,1,116,66,67,215,3(255),
- 2,98,67,69,69,31,0,69,70,32,255,2,98,37,70,70,33,1,68,70,70,34,1,
- 112,70,21,111,1,85,70,84,153,255,1,36,71,72,222,255,1,105,72,73,
- 35,2(255),1,78,74,75,224,1,11,74,75,231,1,5,74,76,232,1,94,74,75,
- 233,1,1,74,75,234,255,0,75,67,217,2,94,96,75,75,226,2,78,96,75,
- 75,227,2,94,13,75,75,228,2,78,13,75,75,229,2,78,95,75,75,230,1,
- 104,75,77,235,255,2,5,96,76,75,225,255,2,114,93,77,74,223,255,0,
- 78,23,117,0,78,40,175,1,101,78,41,177,255,2,98,37,79,79,37,1,86,
- 79,85,148,2,35,86,79,85,149,2,28,86,79,85,150,3,35,29,86,79,85,
- 151,3,28,29,86,79,85,152,2,35,26,79,35,154,2,28,26,79,35,155,3,
- 35,29,26,79,35,156,3,28,29,26,79,35,157,2(255),0,81,21,8,2,5,13,
- 81,81,104,2,78,13,81,81,105,2,94,13,81,81,106,255,2,98,37,82,82,
- 41,2,102,83,82,23,125,5(255),2,98,67,87,87,42,0,87,18,43,2(255),
- 1,3,89,67,237,255,1,68,90,90,45,2,98,37,90,90,46,2,83,92,90,35,
- 160,255,1,1,91,33,144,1,5,91,33,145,1,78,91,33,146,2(255),0,93,1,
- 48,0,93,2,49,0,93,3,50,0,93,4,51,0,93,78,52,0,93,9,53,0,93,88,54,
- 1,103,93,68,218,255,0,94,40,172,3(255),1,5,97,40,173,1,3,97,40,
- 174,2(255),0,99,22,112,255,1,78,100,23,118,1,5,100,23,123,1,12,
- 100,23,127,255,0,101,82,129,0,101,41,178,4(255),0,105,71,220,2,
- 98,64,105,71,221,2(255),0,107,34,147,255,0,108,79,36,2(255),0,
- 110,13,69,255,0,111,13,68,2(255),4,36,34,33,32,113,35,161,2(255),
- 0,115,13,70,2(255),0,117,38,168,255,3,128,109,1,118,87,97,3(255),
- 1,93,121,27,137,255,1,124,122,38,167,255,0,123,21,9,255,0,124,38,
- 166,3(255),2,38,78,127,39,171,255,0,128,69,219,255,1,116,129,67,
- 216,255,0,130,66,213,255,1,138,131,38,163,1,135,131,77,194,255,0,
- 132,91,238,0,132,92,239,255,0,133,30,141,255,1,60,134,62,201,2,
- 93,119,134,66,210,0,134,66,211,255,0,135,77,195,255,1,60,136,61,
- 198,1,60,136,65,206,2,93,119,136,66,208,255,0,137,90,140,255,0,
- 138,38,164,255,0,139,38,165,255,1,60,140,61,200,0,140,66,212,255,
- 1,60,141,61,199,2,93,119,141,66,209,255,0,142,47,19,2(255),0,144,
- 38,169,255,1,93,145,57,196,2,114,93,145,89,236,255);
- comment STANDARD IDENTIFIERS FOR THE NAME TABLE ARE GIVEN BELOW.
- NEW ENTRIES, CHANGES, OR DELETIONS CAN BE MADE TO THE LIST IN
- ANY ORDER. HOWEVER, LATER ENTRIES ARE ACCESSED VIA THE
- HASH CHAIN BEFORE EARLIER ENTRIES SO ORDER DOES AFFECT SPEED
- OF ACCESS.
- THE FOURTH AND FIFTH FIELDS OF EACH ENTRY DESCRIBE THE BCD
- NAME. THE FOURTH FIELD GIVES THE ACTUAL LENGTH OF THE BCD
- NAME (ONLY LENGTHS OF 2, 4, 6, 8, OR 10 ARE VALID). THE FIFTH
- FIELD IS THE ACTUAL STRING (A BLANK MUST BE USED ON THE RIGHT
- TO MAKE ODD LENGTH ID'S HAVE AN EVEN LENGTH.). AT RUN TIME
- THE LENGTH FIELD IS CONVERTED TO A CHAIN FIELD FOR THE HASH
- SCHEME USED. A LENGTH FIELD OF _1 SIGNALS THE END OF THE
- STANDARD IDENTIFIERS.
- THE FIRST FIELD GIVES THE TYPE OF EACH ID. FIELDS TWO AND THREE
- ARE A FOUR BYTE ADDRESS OR VALUE FOR EACH ID AND ARE FILLED
- ACCORDING TO THE TYPE OF THE ID.
- 0 -- ID IS A SHORT INTEGER, 1 -- ID IS AN INTEGER OR LOGICAL,
- 2 -- ID IS A LONG REAL, 3 -- ID IS A REAL,
- 11 -- ID IS A FUNCTION, 81 -- ID IS AN INTEGER REGISTER,
- 82 -- ID IS A LONG REAL REG., 83 -- ID IS A REAL REG,
- 10 -- ID IS A PROCEDURE, 12 -- ID IS AN EQUATE INTEGER.
- FOR <T CELL> TYPES (TYPE < 10), FIELDS TWO AND THREE CONTAIN
- THE RELATIVE ADDRESS AS A FOUR BYTE QUANTITY. NORMALLY FIELD
- TWO IS ZERO BECAUSE FIELD THREE CAN CONTAIN THE ENTIRE ADDRESS
- UNLESS AN INDEX REGISTER IS PART OF THE RELATIVE ADDRESS.
- FOR PROCEDURES, FIELD TWO CONTAINS THE SEGMENT NUMBER OF THE
- PROCEDURE IN THE FIRST BYTE, THE ENTRY POINT REGISTER IN THE
- UPPER HALF OF THE SECOND BYTE, AND THE RETURN REGISTER IN THE
- LOWER HALF OF THE SECOND BYTE, WHILE FIELD THREE
- CONTAINS THE RELATIVE ADDRESS OF THE PROCEDURE (WITHOUT BASE
- REGISTER R15 SPECIFIED).
- FOR FUNCTIONS, FIELD TWO CONTAINS THE FUNCTION CODE AND FIELD
- THREE CONTAINS THE FIRST HALF WORD OF THE FUNCTION. FOR <K REG>
- TYPES (TYPE > 80) FIELD TWO IS 0 AND FIELD THREE IS THE ACTUAL
- HARDWARE REGISTER NUMBER;
- equate K0 syn #FF00, !-- CELL TYPES NOT DEFINED IN SEGMENT --!
- K1 syn #FF01, K2 syn #FF02, K3 syn #FF03, K4 syn #FF04;
- array NAMEFILLSZ short integer NAMEFILL=(
- $IFF
- (K4, #E,#0FFF, 6, "PSTAR "),(K4, #D,#0FFF, 6, "DSTAR "),
- $$ (K3, 0,#F000, 4, "E15 "),(K3, 0,#E000, 4, "E14 "),
- $$ (K3, 0,#D000, 4, "E13 "),(K3, 0,#C000, 4, "E12 "),
- $$ (K3, 0,#B000, 4, "E11 "),(K3, 0,#A000, 4, "E10 "),
- $$ (K3, 0,#9000, 2, "E9"),(K3, 0,#8000, 2, "E8"),
- $$ (K3, 0,#7000, 2, "E7"),(K3, 0,#6000, 2, "E6"),
- $$ (K3, 0,#5000, 2, "E5"),(K3, 0,#4000, 2, "E4"),
- $$ (K3, 0,#3000, 2, "E3"),(K3, 0,#2000, 2, "E2"),
- $$ (K3, 0,#1000, 2, "E1"),
- (K2, 0,#F000, 4, "L15 "),(K2, 0,#E000, 4, "L14 "),
- (K2, 0,#D000, 4, "L13 "),(K2, 0,#C000, 4, "L12 "),
- (K2, 0,#B000, 4, "L11 "),(K2, 0,#A000, 4, "L10 "),
- (K2, 0,#9000, 2, "L9"),(K2, 0,#8000, 2, "L8"),
- (K2, 0,#7000, 2, "L7"),(K2, 0,#6000, 2, "L6"),
- (K2, 0,#5000, 2, "L5"),(K2, 0,#4000, 2, "L4"),
- (K2, 0,#3000, 2, "L3"),(K2, 0,#2000, 2, "L2"),
- (K2, 0,#1000, 2, "L1"),
- (K0, 0,#F000, 4, "H15 "),(K0, 0,#E000, 4, "H14 "),
- (K0, 0,#D000, 4, "H13 "),(K0, 0,#C000, 4, "H12 "),
- (K0, 0,#B000, 4, "H11 "),(K0, 0,#A000, 4, "H10 "),
- (K0, 0,#9000, 2, "H9"),(K0, 0,#8000, 2, "H8"),
- (K0, 0,#7000, 2, "H7"),(K0, 0,#6000, 2, "H6"),
- (K0, 0,#5000, 2, "H5"),(K0, 0,#4000, 2, "H4"),
- (K0, 0,#3000, 2, "H3"),(K0, 0,#2000, 2, "H2"),
- (K0, 0,#1000, 2, "H1"),
- (K4, 0,#F000, 4, "C15 "),(K4, 0,#E000, 4, "C14 "),
- (K4, 0,#D000, 4, "C13 "),(K4, 0,#C000, 4, "C12 "),
- (K4, 0,#B000, 4, "C11 "),(K4, 0,#A000, 4, "C10 "),
- (K4, 0,#9000, 2, "C9"),(K4, 0,#8000, 2, "C8"),
- (K4, 0,#7000, 2, "C7"),(K4, 0,#6000, 2, "C6"),
- (K4, 0,#5000, 2, "C5"),(K4, 0,#4000, 2, "C4"),
- (K4, 0,#3000, 2, "C3"),(K4, 0,#2000, 2, "C2"),
- (K4, 0,#1000, 2, "C1"),
- $END
- (K1, 0,#E000, 4, "B14 "),(K1, 0,#F000, 4, "B15 "),
- (82, 0, 4, 4, "F45 "),(82, 0, 6, 4, "F67 "),
- (82, 0, 0, 4, "F01 "),(82, 0, 2, 4, "F23 "),
- (83, 0, 4, 2, "F4"),(83, 0, 6, 2, "F6"),
- (83, 0, 0, 2, "F0"),(83, 0, 2, 2, "F2"),
- (13, 0, 0, 4, "ABS "),(13, 0, 3, 4, "NEG "),
- (13, 0, 6, 4, "DEC "),(13, 0, 4, 4, "HALF"),
- (14, 0, #860, 2, "LE"),(14, 0, #870, 2, "GT"),
- (10,#02FE,#0000, 4, "READ"),(10,#03FE,#0000, 6, "WRITE "),
- (10,#04FE,#0000, 6, "PUNCH "),(10,#05FE,#0000, 4, "PAGE"),
- (10,#06FE,#0000, 6, "PRINT "),(10,#07FE,#0000, 4, "OPEN"),
- (10,#08FE,#0000, 4, "GET "),(10,#09FE,#0000, 4, "PUT "),
- (10,#0AFE,#0000, 6, "KLOSE "),(10,#0BFE,#0000, 6, "CANCEL"),
- (10,#0CFE,#0000, 8, "BCDTOVAL"),(10,#0DFE,#0000, 8, "VALTOBCD"),
- (11, 5,#DC00, 2, "TR"),(11, 5,#D100, 4, "MVN "),
- (11, 5,#DE00, 2, "ED"),(11, 2,#4400, 2, "EX"),
- (11, 10,#F300, 4, "UNPK"),(11, 12,#4E00, 4, "CVD "),
- (11, 8,#92FF, 4, "SET "),(11, 8,#9200, 6, "RESET "),
- (11, 2,#4300, 2, "IC"),(11, 12,#4200, 4, "STC "),
- (11, 9,#8C00, 4, "SRDL"),(11, 9,#8D00, 4, "SLDL"),
- (11, 3,#9000, 4, "STM "),(11, 3,#9800, 2, "LM"),
- (11, 4,#9200, 4, "MVI "),(11, 4,#9500, 4, "CLI "),
- (11, 5,#D200, 4, "MVC "),(11, 13,#D500, 4, "CLC "),
- (11, 8,#95FF, 4, "TEST"),(11, 2,#4100, 2, "LA"),
- (11, 4,#9400, 2, "NI"),(11, 12,#4F00, 4, "CVB "),
- (11, 4,#9700, 2, "XI"),(11, 4,#9600, 2, "OI"),
- (11, 10,#F200, 4, "PACK"),(11, 6,#0400, 4, "SPM "),
- (11, 9,#8F00, 4, "SLDA"),(11, 9,#8E00, 4, "SRDA"),
- (11, 7,#0A00, 4, "SVC "),(11, 4,#9100, 2, "TM"),
- (11, 5,#DD00, 4, "TRT "),(11, 5,#DF00, 4, "EDMK"),
- (11, 1,#1200, 4, "LTR "),(11, 5,#D300, 4, "MVZ "),
- (11, 12,#4000, 4, "STH "),(11, 12,#4800, 2, "LH"),
- (11, 1,#0500, 4, "BALR"),(11, 5,#D400, 2, "NC"),
- (11, 5,#D600, 2, "OC"),(11, 5,#D700, 2, "XC"),
- (11, 8,#9300, 2, "TS"),(11, 16,#BD00, 4, "CLM "),
- (11, 17,#BE00, 4, "STCM"),(11, 16,#BF00, 4, "ICM "),
- (81, 0, 14, 4, "R14 "),(81, 0, 15, 4, "R15 "),
- (81, 0, 12, 4, "R12 "),(81, 0, 13, 4, "R13 "),
- (81, 0, 10, 4, "R10 "),(81, 0, 11, 4, "R11 "),
- (81, 0, 8, 2, "R8"),(81, 0, 9, 2, "R9"),
- (81, 0, 6, 2, "R6"),(81, 0, 7, 2, "R7"),
- (81, 0, 4, 2, "R4"),(81, 0, 5, 2, "R5"),
- (81, 0, 2, 2, "R2"),(81, 0, 3, 2, "R3"),
- (81, 0, 0, 2, "R0"),(81, 0, 1, 2, "R1"),
- (K1, 0,#C000, 4, "B12 "),(K1, 0,#D000, 4, "B13 "),
- (K1, 0,#A000, 4, "B10 "),(K1, 0,#B000, 4, "B11 "),
- (K1, 0,#8000, 2, "B8"),(K1, 0,#9000, 2, "B9"),
- (K1, 0,#6000, 2, "B6"),(K1, 0,#7000, 2, "B7"),
- (K1, 0,#4000, 2, "B4"),(K1, 0,#5000, 2, "B5"),
- (K1, 0,#2000, 2, "B2"),(K1, 0,#3000, 2, "B3"),
- (K1, 0,#0000, 4, "MEM "),(K1, 0,#1000, 2, "B1"),
- (12, 0, 4, 6, "MIXED "),(12, 0, 1, 2, "ON"),
- (12, 0, 8, 4, "OFF "),(12, 0, 1, 8, "OVERFLOW"),
- (12,#FFFF,#FFFF, 4, "TRUE"),(12, 0, 0, 6, "FALSE "),
- (12, 0, 3, 6, "CARRY "),(12, DTHI, DTLO, 8, "DATAFILL"),
- !-- FOLLOW TWO ENTRIES MUST BE THE LAST TWO --!
- (12, 0, 0, 6, "STRING"),( 0, 0, 0,_1));
- $PAGE
- segment procedure MAIN(R6);
- begin !-- ALLOCATE CORE FOR PROGRAM, DATA, LITERALS AND LABELS --!
- SAVERETURN := R6; !-- SAVE RETURN REGISTER --!
- if R0 = 0 then goto RESTART;
- SYSINIT(R9); comment FREE STORAGE BOUNDS RETURNED IN R3, R4,
- R1 SET TO ADDRESS OF 16 CHARACTER SYSTEM ID;
- STC(R9,OSSYSTEM); !-- #FF => O/S, #00 => DOS --!
- $IFF
- $IFF M M
- IDRDATA(15/5) := B1(16); IDRDATA(21/16) := B1;
- $END M
- $IFT M M
- IDRDATA(21/16) := B1;
- $END M
- $END
- HEADER(94/16) := B1;
- $IFT M M
- LISTFLAG(0/1) := B1(16); TESTFLAG(0/1) := B1(17);
- XREF(0/1) := B1(18); TRACE(0/1) := B1(19);
- OVER(0/1) := B1(21);
- OPTFLAG(0/1) := B1(20);
- $END M
- R3 := @B3(7) and _8; R4 := R4 and _8;
- PRTBASE := R8; R8 := @NAMEFILL; NAMEBASE := R8;
- R4 := R4 - STACKLEN; STACKBASE := R4;
- R4 := R4 - ESDTBLLEN; PROGESDADR := R4;
- R4 := R4 - ESDTBLLEN; DATAESDADR:=R4;
- R5 := R4 - R3; PROGBASE := R3; R9 := R3;
- $IFF
- if R5 > #7800S then
- begin !-- $XREF WILL BE POSSIBLE --!
- R7 := R5 shrl 1 - 12000S and _8;
- if R7 > 262144 then R7 := 262144; R4 := R4-R7;
- REFSTART := R4; R5 := R5-R7; R7 := R7-4; REFN3 := R7;
- $IFT M M
- end; if R5 > #5000S and TESTFLAG then
- begin !-- $TEST WILL BE POSSIBLE --!
- R1 := R4; R2 := R5 - #4000S shrl 1 + 3000S and _8;
- if R2 > 262144 then R2 := 262144; R4 := R4 - R2;
- R5 - R2; R7 := R4 - 4S; DATASTACK := R7; R2 := @B7(#300);
- PROCSTACK := R2; R2 := @B2(4); DSTAKBOT := R2;
- R2 := @B2(#100); PSTAKBOT := R2; FREESPACE := R2;
- R7 := R2; while R7 := @B7(28); R7 < R1 do
- begin B2 := R7; R2 := R7;
- end; R7 := neg 1; B2 := R7;
- $END M
- end;
- $END
- if R5 < SIZE1 then !-- NOT ENOUGH CORE --!
- begin XR := 31; ERROR;
- WBUF := "CORE SIZE TOO SMALL ";
- WBUF(STRING/132-STRING) := WBUF(STRING-1); PRINT;
- SB(NOGO,FLGS); ERROREXIT;
- end; R6 := neg ROUND; REDUCE(R6); R2 := #FE00;
- for R7 := R7 -- R7 step 4S until 16S do
- begin R14 := R5 * QTAB(R7) shrl 8;
- R14 := @B14(ROUND) and R6;
- if R14 > R2 then R14 := R2; LTAB(R7) := R14;
- end;
- R4 := R4 - BRTBL; BRANCHBASE := R4;
- R4 := R4 - LTTL; LITBASE := R4;
- R4 := R4 - LBTL; LABELBASE := R4;
- R7 := R4 - 56S; DATAEND := R7;
- R4 := R4 - DTL; DATABASE := R4;
- R4 := R4 - NTBL; R7 := R4; R2 := NAMEBASE;
- NAMEBASE := R4; R1 := DATABASE; R1 := R1 - R4;
- NAMEND := R1; R1 := NAMETABSZ;
- while R1 >= 256S do !-- MOVE NAME TABLE --!
- begin B7(0/256) := B2; R1 := R1 - 256S;
- R2 := @B2(256); R7 := @B7(256);
- end; EX(R1,MVC(0,B7,B2));
- R0 := R0-R0; R7 := STACKBASE; S(R7) := R0;
- R7 := @B7(16); STACKBASE := R7;
- R3 := LINK(R4); R2 := R2-R2;
- while R3 > 0 do
- begin IC(R2,NAME(R4)); IC(R2,ALPHASH(R2-193));
- R1 := LENHASH(R3-2) + R2; R0 := HASHCHAIN(R1); LINK(R4) := R0;
- R0 := R4 - NAMEBASE; HASHCHAIN(R1) := R0;
- R5 := R4; R4 := @B4(R3+8); R3 := LINK(R4);
- end; STRNGADR := R5;
- R4 := R4 - NAMEBASE; NAMEPOINTER := R4;
- RESTART: !-- RESTART COMPILER FOR NEXT PROGRAM --!
- SET(RUNFLAG); SET(SKIPFLAG); CARRCONT := "1"; SET(GENFLAG);
- SET(GENDECK); SET(NOPROGSEG); SET(NODATASEG); RESET(NOTMOVED);
- R0 := R0-R0; N3 := R0; N4 := R0; LITX := R0; ERRCOUNT := R0;
- R0 =: N5 =: N6;
- $IFF
- RESET(REFOUT); REFN1 := R0; R1 := REFN3; REFN2:= R1;
- $END
- BEGENDLVL := R0; SEGNAM := "SEG";
- ESDNAME(0/3) := SEGNAM; ESDNAME(10/3) := SEGNAM;
- PAGECOUNT := R0; CARDCOUNT := R0; BLOCK := R0;
- WBUFF(0/133) := BLANK; HEADER(19/75) := HEADER(18);
- SUBHEAD(1/132) := SUBHEAD;
- R0 := 13; SEGNO := R0; NSEGNO := R0; MAXSEG := R0;
- R0 := 1; CSEGNO := R0; PROCBR := R0;
- R9 := PROGBASE; R10 := DATABASE; R7 := STACKBASE - 16S;
- R0 := R0-R0; R1 := DATAESDADR; DC := R0;
- PL360NO(R1) := R0; SYMTYPE := R0;
- R2 := STRNGADR; ADR(R2+2) := R0;
- R0 := ENDCHAIN; PREVSEG(R9) := R0; PREVSEG(R10) := R0;
- R2 := 1; R3 := PROGREG; R5 := R9;
- OPENSEG; R3 := R3 shll 12; PTAG := R3;
- R1 := PROGESDADR; R0 := R1; R2 := SD; R3 := VTYPE; R4 := 1;
- FINDESDENTRY; PROGESDEND := R0;
- WBUFF(0/133) := BLANK; R1 := LABELBASE; B1(0/12) := ZERO;
- R1 := NAMEPOINTER; N1 := R1; N2 := R1;
- for R2 := R2-R2 step 4S until MAXHASH do
- begin R3 := HASHCHAIN(R2); while R3 >= R1 do
- begin R3 := R3 + NAMEBASE; R3 := LINK(R3);
- end; HASHCHAIN(R2) := R3;
- $IFF
- R3 := ENDCHAIN; REFCHAIN(R2) := R3;
- $END
- end; CONDTAB(0/64) := CONDTAB xor CONDTAB;
- RESET(PRNT); R6 := 71; CBUF(71) := " "; R5 := ENDFILE;
- !-- END OF INITIALIZATION SECTION, SYNTAX LOOP NEXT --!
- $PAGE
- !-- ALGORITHM FOR SYNTACTIC ANALYSIS --!
- SYNLOOP:
- begin R7 := R7 + 16S; I := R7; S(R7) := R5;
- R5:=SYMTYPE; T(R7):=R5;
- V(R7/10) := VALUE; INSYMBOL; RESET(NOTMOVED); R2 := S(R7);
- $IFF
- if XREF and R5=IDENTSYMBOL and ^REFOUT then ENTEREF;
- $END
- X: R1 := R1-R1; IC(R1,F(R2)); R4 := @G(R5); EX(R1,CLI(0,B4));
- if < then !-- G < F --!
- begin R4 := S(R7); R2 := R2 - R2;
- Y: R7 := R7 - 16S; R3 := S(R7); STC(R4,RIGHTPART(R2));
- IC(R1,F(R3)); R0 := R5; R5 := @G(R4); EX(R1,CLI(0,B5));
- R5 := R0; if = then
- begin R4 := R3; R2 := @B2(1); if R2 < 10 then goto Y;
- end; R7 := R7 + 16S; SET(FLAG);
- R4 := R4 shll 1; R3 := MTB(R4) + PRTBASE;
- Z: if FLAG then
- begin IC(R1,B3); if R1 ^= NOMORERULES then
- begin if R1 = R2 then
- begin EX(R2,CLC(0,RIGHTPART,B3(1))); if = then
- begin RESET(FLAG); IC(R1,B3(R2+3));
- EXECUTE; !-- DO THE RULE --!
- end;
- R3 := @B3(R2+4); goto Z;
- end;
- R3 := @B3(R1+4); goto Z;
- end;
- end;
- if FLAG then
- begin XR := 0; ERROR; SET(SKIPFLAG);
- R2 := 6 + LC; LC := R2;
- R7 := I; R2 := S(R7); if R2 = SEMICOLON then goto B;
- A: if R5 = SEMICOLON then INSYMBOL else
- if R5 ^= BEGINSYMBOL and R5 ^= ENDSYMBOL
- and R5 ^= ENDFILE then
- begin INSYMBOL; goto A;
- end;
- B: R2 := S(R7); if R2 = BLOCKBODY then
- begin R2 := BLOCKHEAD; S(R7) := R2;
- end else if R7 = STACKBASE then
- begin RESET(FLAG); if R2 = ENDFILE then
- begin R2 := PROGMINUS; S(R7) := R2; RESET(NOPROGSEG);
- end;
- end else
- if R2^=BLOCKHEAD and R2^=CASESEQ then
- begin if R2 = BEGINSYMBOL then RESET(FLAG);
- R7 := R7 - 16S; goto B;
- end; if ^FLAG then
- begin R2 := BLOCKHEAD; if R2 = S(R7) then
- begin R2 := BLOCKBODY; S(R7) := R2;
- end; R7 := R7 + 16S; R2 := BEGINSYMBOL; S(R7) := R2;
- end; I := R7; if R5 = ENDFILE then goto C;
- end else
- begin I := R7; R3 := R3 - 2; IC(R2,B3); S(R7) := R2;
- end; goto X;
- end;
- if R5 ^= ENDFILE then goto SYNLOOP;
- C: end;
- if R7 ^= STACKBASE then
- begin XR := 0; ERROR;
- end;
- R6 := SAVERETURN; !-- RESTORE RETURN REGISTER --!
- end;
- $PAGE
- !-- *************** START HERE *************** --!
- R0 := 1; !-- FIRST TIME IN MAIN --!
- LOOP: !-- COMPILE NEXT PROGRAM --!
- MAIN; !-- EXECUTE MAIN PROGRAM --!
- $IFT
- EXIT: OUTPUTCARD; WBUFF(0/133) := BLANK; SETZONE(CARRCONT);
- $END
- $IFF
- EXIT: PRINTREFS; WBUFF(0/133) := BLANK; SETZONE(CARRCONT);
- $END
- if TM(XITF,FLGS); OFF then !-- PRINT SEGMENT COUNT --!
- begin WBUF := " `0`0`1`0 MAX SEG ASSIGNED.";
- R1 := 10 * MAXSEG; CVD(R1,CONWORK);
- ED(4,WBUF,CONWORK(5)); CARRCONT := "0"; PRINT;
- WBUFF(0/133) := BLANK; SETZONE(CARRCONT);
- end; if ^RUNFLAG then
- begin
- $IFT M M
- ERRPRINT; !-- PRODUCE THE ERROR SUMMARY --!
- $END M
- R1 := 10 * ERRCOUNT; WBUF := "*** `0`0`1`0 ERRORS DETECTED ***";
- CVD(R1,CONWORK); ED(4,WBUF(3),CONWORK(5));
- R1 := ERRCOUNT; if R1 > ERRLIMIT then
- WBUF(25) := "- ERROR MESSAGE LISTING INCOMPLETE ***";
- R1 := R1 + ERRTOTL; ERRTOTL := R1; SB(NOGO,FLGS);
- end else if ^NOPROGSEG then
- WBUF := " NO ERRORS DETECTED"; CARRCONT := "0"; PRINT;
- $IFT M M
- R1 := @WBUFF; SERCOMPR;
- $END M
- if TM(XITF,FLGS); OFF then begin R0 := R0-R0; goto LOOP; end;
- if TM(NOGO,FLGS); ON then
- begin WBUFF(0/133) := BLANK; CARRCONT := " ";
- R1 := 10 * ERRTOTL; if R1=0 then goto X;
- WBUF := "*** ERRORS DETECTED IN ENTIRE COMPILATION";
- WBUF(4) := "`0`0`0`0`1`0";
- CVD(R1,CONWORK); ED(6,WBUF(3),CONWORK(4)); PRINT;
- $IFT M M
- R1 := @WBUFF; SERCOMPR;
- $END M
- X: R0 := 16;
- end else R0 := R0-R0;
- SYSTERM(R9); !-- RELEASE SYSTEM RESOURCES --!
- if = then R0 := R0+8S; !-- => NOLOADSW=X'00' --!
- R2 := MEM(R13+4); MEM(R2+16) := R0; !-- SET RETURN CODE --!
- end.
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement