Pastebin launched a little side project called VERYVIRAL.com, check it out ;-) Want more features on Pastebin? Sign Up, it's FREE!
Guest

PL/360 compiler

By: a guest on Mar 13th, 2012  |  syntax: None  |  size: 177.76 KB  |  views: 112  |  expires: Never
download  |  raw  |  embed  |  report abuse  |  print
Text below is selected. Please press Ctrl+C to copy to your clipboard. (⌘+C on Mac)
  1. $OS
  2. $$SET M  !-- See COMPL360 and MAKPLLIB --!
  3. $$SET D  !-- See CMPL360X and MAKPLLIX for debugging --!
  4. $1
  5. $XREF
  6. COMMENT
  7. "The source code for this computer program is placed in the public
  8.  domain and may be used by any party without notice to the copyright
  9.  holder, Stanford University. Stanford University provides no
  10.  support of any kind to this computer program.  Further:
  11.  
  12.  STANFORD MAKES NO REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED.
  13.  BY WAY OF EXAMPLE, BUT NOT LIMITATION, STANFORD MAKES NO
  14.  REPRESENTATIONS OR WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY
  15.  PARTICULAR PURPOSE OR THAT THE USE OF THE SOFTWARE WILL NOT INFRINGE
  16.  ANY PATENTS, COPYRIGHTS, TRADEMARKS, OR OTHER RIGHTS. STANFORD SHALL
  17.  NOT BE LIABLE FOR ANY LIABILITY OR DAMAGES WITH RESPECT TO ANY CLAIM
  18.  BY A USER OF THIS COMPUTER PROGRAM OR ANY DERIVATIVES OF THIS
  19.  COMPUTER PROGRAM."
  20. ;
  21.   comment -- C O M P I L E    O P T I O N S --
  22.   *
  23.   *       THE FOLLOWING OPTIONS ARE AVALABLE:
  24.   *       $IFF   -- COMPILE FOR O/S - DOS SYSTEM.
  25.   *       $IFT   -- COMPILE FOR 65K DOS SYSTEM.
  26.   *       $IFT M -- COMPILE FOR MTS SYSTEM.
  27.   *       INCLUDE $SET FOR 65K DOS SYSTEM AS NEXT CARD.
  28.   *
  29. $IFF M M
  30. $IFT
  31.   *  - - - - - - -  6 5 K   D O S   S Y S T E M  - - - - - - -
  32. $END
  33. $IFF
  34.   *  - - - - - - -  O / S   -   D O S   S Y S T E M  - - - - - - -
  35. $END
  36. $END M
  37. $IFT M M
  38.     *  - - - - - - - - - - -  M T S   S Y S T E M  - - - - - - -
  39. $OPT
  40. $END M
  41.   *
  42.   *  NOTE - KEEP TRACK OF WHERE THE OBJECT MODULE IS BEING STORED;
  43. $IFF M M
  44. $IFT
  45. $TITLE   THE PL360 COMPILER  65K DOS VERSION,  1/1/90  V1.90
  46. $END
  47. $IFF
  48. $TITLE   THE PL360 COMPILER O/S - DOS VERSION, 1/1/90  V1.90
  49. $END
  50. $END M
  51. $IFT M M
  52. $TITLE   MTS PL360 COMPILER V1.90 Jan. 90
  53. $END M
  54.  begin   !--  PL360 COMPILER --       --!
  55.     external procedure SYSINIT(R14); null;
  56.         !-- OBTAINS FREE STORAGE AND OPENS DATA SETS --!
  57.     external procedure SYSTERM(R14); null;
  58.         !-- RELEASES FREE STORAGE AND CLOSES DATA SETS --!
  59. $IFT M M
  60.     external procedure ERRBUFFR(R14); null;
  61.        !-- BUFFERS MOST ERROR MESSAGES -- SO WE CAN --!
  62.        !-- PRINT THEM AGAIN, AFTER THE XREF.        --!
  63.     external procedure ERRPRINT(R14); null;
  64.        !-- PRINTS ERROR MESSAGE SUMMARY ON SERCOM   --!
  65.        !-- AND SPRINT (IF THEY AREN'T THE SAME)     --!
  66.        !-- AFTER THE XREF.   ERROR MESSAGES ARE     --!
  67.        !-- STILL PRINTED IN THE USUAL MANNER,       --!
  68.        !-- INTERSPERSED IN THE LISTING.             --!
  69.     external procedure SERCOMPR(R14); null;
  70.        !-- PRINTS THE SUMMARY LINES ON SERCOM IF IT --!
  71.        !-- IS NOT ASSIGNED TO THE SAME FDNAME AS    --!
  72.        !-- SPRINT.                                  --!
  73. $END M
  74.  
  75.     function SETZONE(8,#96F0);  !-- DEFINE FUNCTION TO SET ZONE --!
  76.     function DRAIN(0,#07F0);   !-- MODEL 91 PIPELINE DRAIN --!
  77.     function REDUCE(6,#0600);   !-- BCTR(RN,0) --!
  78.     function SB(4,#9600), RB(4,#94FF);  !-- SET/RESET BITS --!
  79.     byte OSSYSTEM; comment USED TO DETERMINE PROPER PROGRAM ENTRY AND
  80.                            EXIT CODE;
  81.     byte NOTMOVED;  !-- USED TO SUPPRESS REDUNDANT ERROR MESSAGES --!
  82.     byte OVER=#00;  !-- OVERPRNT/UNDERLINE FLAG --!
  83.     byte PRNT=#00;  !-- USED TO INDICATE INPUT IMAGE PRINT --!
  84.     byte FLGS=#00;  !-- GENERAL PURPOSE FLAGS --!
  85.     equate DOLR syn #80, XITF syn #40, NOGO syn #20, ASCI syn #10;
  86.     byte TRACE=0; comment USED TO CONTROL TRACE OUTPUT --
  87.        0 - NO TRACE, bit 1 - ESD AND RLD PRINTOUT,
  88.        bit 2 - NAME PRINTOUT, bit 4 - SEGMENT INITIALIZATION PRINTED;
  89.     byte RUNFLAG,SKIPFLAG,NOPROGSEG,NODATASEG;
  90.     byte FLAG;  !-- USED IN SYNTACTIC ANALYSIS --!
  91.     byte SIGN, EXPOSIGN;  !-- SIGN FLAGS FOR NUMBER CONVERSION --!
  92.     byte CARRCONT="1";  !-- LISTING FORMS CONTROL CODE --!
  93.     byte BEGENDFLAG,REPFLAG=#00;
  94.     byte FILLFLAG=0;
  95.     byte DBGFLGS=0;
  96.     short integer BEGENDLVL,LITCOUNT=0,CBEGENDLVL;
  97.     integer N1,N2,N3,N4;  !-- NAME AND LABEL POINTERS --!
  98.     integer N5,N6;  !-- BRANCH TABLE POINTERS --!
  99.     short integer BLOCK;  !-- CURRENT BLOCK LEVEL --!
  100.     short integer FILLTYPE;  !-- USED IN DATA FILL --!
  101.     short integer PROCBR,PROCLK;  !-- USED FOR BRANCH AROUND PROC --!
  102.     short integer CSEGNO;  !-- CURRENT SEGMENT NUMBER --!
  103.     short integer NSEGNO;  !-- MAXIMUM USED SEGMENT NUMBER --!
  104.     short integer SEGNO;  !-- NEXT SEGMENT NUMBER --!
  105.     short integer MAXSEG;  !-- HIGHEST SEGMENT ASSIGNED --!
  106.     short integer LITX;  !-- LITERAL INDEX --!
  107.     short integer SYMTYPE; byte TYPEFLAG syn SYMTYPE(1);
  108.     short integer NAMEPOINTER;
  109.     short integer ERRCOUNT, ERRTOTL=0, LINECOUNT, PAGECOUNT, CARDCOUNT;
  110.     short integer ERRLIMIT=50, MAXLINE=60;
  111.     short integer ENDCHAIN=_1;
  112.     short integer MAXHASH=156;
  113.     array 5 short integer LENHASH=(0,32,64,96,128);
  114.     array 40 integer HASHCHAIN=40(_1);
  115.     array 47 byte ALPHASH=(2(0),3(4),11(8),4(12),3(16),2(20),
  116.        10(24),12(28));
  117. $IFT
  118.     byte XR=0;
  119. $END
  120. $IFF
  121.     byte XR=0, REFOUT=0, XREF=0;
  122. $IFT M M
  123.     byte TESTFLAG=0, SYM=0;
  124.     dummy base R0;  !-- Symbol block for SYM card output --!
  125.        array 7 integer SYMDATUM;
  126.        logical SYMLINK syn SYMDATUM;
  127.        short integer CARDNO syn SYMDATUM(4);
  128.        byte ORFIELD syn SYMDATUM(6);
  129.        array 3 byte AAFIELD syn SYMDATUM(7);
  130.        short integer DISPFIELD syn SYMDATUM(8);
  131.        array 10 byte SYMFIELD syn SYMDATUM(10);
  132.        byte FFIELD syn SYMDATUM(20);
  133.        byte LDFIELD syn SYMDATUM(21);
  134.        array 4 byte MFIELD syn SYMDATUM(24);
  135.        integer DUPFAC syn SYMDATUM(24);
  136.     close base;
  137.     integer DATAPTR syn 0;
  138.     integer PROCPTR;
  139. $END M
  140.     short integer LASTCARD;
  141.     array 40 integer REFCHAIN=40(_1);
  142.     dummy base R0;
  143.        integer LINKF;
  144.        array 10 byte REFNAME;
  145.        integer LINKN;
  146.        integer LINKL;
  147.     close base;
  148.     equate REFMOV syn REFNAME(10)-LINKF-1,
  149.            REFLEN syn LINKL(4)-LINKF;
  150.     integer REFLINK syn 0;
  151.     integer REFN1=0, REFN2=0, REFN3=0;  !-- REFERENCE POINTERS --!
  152.     integer REFSTART;
  153. $END
  154.     comment TO CHANGE THE LIMIT ON THE NUMBER OF DIFFERENT
  155.       SEGMENTS, CHANGE THE VALUE OF MAXSEGNO IN THE
  156.       FOLLOWING EQUATE DECLARATION. IT SHOULD NOT EXCEED 255;
  157.     equate ROUND syn 511, STACKLEN syn #800,
  158. $IFT
  159.            MAXSEGNO syn 75,   NAMEFILLSZ syn 606,
  160. $END
  161. $IFF
  162.            MAXSEGNO syn 255,  NAMEFILLSZ syn 1000,
  163. $END
  164.            ESDTBLLEN syn MAXSEGNO+1*8,
  165.            NAMETBLLEN syn MAXSEGNO+1*10,
  166.            NAMETABSZ syn NAMEFILLSZ * 2,
  167.            SIZE1 syn NAMETABSZ * 6;
  168.     integer LBTL=10, LTTL=30, NTBL=60, DTL=60, BRTBL=10; !PROG=86!
  169.     integer LTAB syn LBTL;  short integer QTAB syn LTAB(2);
  170.     array 10 byte SEGNAM="SEGNXXX   ";
  171.     byte MCCODE, MCTYPE;
  172. $IFT M M
  173.     integer PROCSTACK, DATASTACK, PSTAKBOT, DSTAKBOT, FREESPACE=0;
  174. $END M
  175.     integer I;  !-- STACK INDEX --!
  176.     integer DC1;  !-- DATA INITIALIZATION COUNTER --!
  177.     integer FUNC0,FUNC1,FUNC2;
  178.     integer FUNCCOUNT=0;
  179.     equate FT syn 20;   !-- FUNCTION TYPE LIMIT --!
  180.     integer EQUHOLD, STRNGADR;
  181.     integer STACKBASE,NAMEBASE,LITBASE,LABELBASE,DATABASE,PRTBASE;
  182.     integer BRANCHBASE;
  183.     integer PROGBASE, NAMEND;
  184.     integer SEGONEORG syn MEM(R13+72);
  185.     integer PTAG,  !-- USED TO PUT IN PROGRAM BASE REGISTER --!
  186.        STARTADR=@SEGONEORG,  !-- START OF INITIAL DATA AREA --!
  187.        DATAEND;  !-- END OF DATA FILL AREA --!
  188.     integer SAVERETURN;  !-- USED TO HOLD RETURN REGISTER FOR MAIN --!
  189.     long real CONWORK;  !-- USED TO CONVERT TO DECIMAL --!
  190.     array  32  byte TYPETABLE=
  191.        (0,1,3(0),1,4(0),1,3(0),1,1,16(0));
  192.     array 8 byte LENGTH=(1,2,3,2,4(0)),
  193.        ALENGTH=(1,3,7,3,4(0));
  194.     array 17 byte DTRTABLE=" 0123456789ABCDEF";
  195.        array 16 byte TRTABLE syn DTRTABLE(1);
  196.     byte OPTFLAG=0;  !-- CONTROLS OPTIMIZATION --!
  197.     short equate  CASESEQ      syn  18, !-- <CASE SEQ>  --!
  198.                   RELOP        syn  22, !-- <REL OP>    --!
  199.                   COMPAOR      syn  25, !-- <COMP AOR>  --!
  200.                   CONDTHEN     syn  26, !-- <COND THEN> --!
  201.                   DOTERM       syn  30, !-- <WHILE>     --!
  202.                   REPLIST1     syn  41, !-- <REP LIST1> --!
  203.                   TDECL3       syn  45, !-- <T DECL3>   --!
  204.                   BLOCKHEAD    syn  69, !-- <BLOCKHEAD> --!
  205.                   BLOCKBODY    syn  70, !-- <BLOCKBODY> --!
  206.                   PROGMINUS    syn  71, !-- <PROGRAM->  --!
  207.                   PROGSTAR     syn  72, !-- <PROGRAM*>  --!
  208.                   NUMBERSYMBOL syn  78, !-- <T NUMBER>  --!
  209.                   IFTERM       syn  79, !-- <IF>        --!
  210.                   RPTERM       syn  82, !-- <RP>        --!
  211.                   CONDEND      syn  86, !-- <COND END>  --!
  212.                   REPUNTIL     syn  92, !-- <REPUNTIL>  --!
  213.                   IDENTSYMBOL  syn  93, !-- <ID>        --!
  214.                   STRNGSYMBOL  syn  94, !-- <STRING>    --!
  215.                   SHIFTOP      syn  95, !-- <SHIFT OP>  --!
  216.                   ARITHOP      syn  96, !-- <ARITH OP>  --!
  217.                   ADROP        syn  97, !-- <ADR OP>    --!
  218.                   SEMICOLON    syn  98, !-- ;           --!
  219.                   EQUALSYM     syn  99, !-- =           --!
  220.                   NOTSYM       syn 100, !-- ^           --!
  221.                   LPAREN       syn 101, !-- (           --!
  222.                   RPAREN       syn 102, !-- )           --!
  223.                   COLONSYMBOL  syn 103, !-- :           --!
  224.                   COMMASYM     syn 104, !-- ,           --!
  225.                   ENDFILE      syn 105, !-- .           --!
  226.                   ASSIGNSYMBOL syn 106, !-- :=          --!
  227.                   FT2          syn 107, !-- DO          --!
  228.                   FT3          syn 111, !-- AND         --!
  229.                   ENDSYMBOL    syn 112, !-- END         --!
  230.                   FORSYMBOL    syn 113, !-- FOR         --!
  231.                   FT4          syn 116, !-- BASE        --!
  232.                   FT5          syn 127, !-- ARRAY       --!
  233.                   BEGINSYMBOL  syn 128, !-- BEGIN       --!
  234.                   FT6          syn 134, !-- COMMON      --!
  235.                   FT7          syn 138, !-- INTEGER     --!
  236.                   FT8          syn 141, !-- EXTERNAL    --!
  237.                   FT9          syn 144; !-- CHARACTER   --!
  238.  
  239.     array 12 short integer OPS = (
  240.                       SEMICOLON    ,    !-- ;           --!
  241.                       ARITHOP      ,    !-- <ARITH OP>  --!
  242.                       RELOP        ,    !-- <REL OP>    --!
  243.                       NOTSYM       ,    !-- ^           --!
  244.                       LPAREN       ,    !-- (           --!
  245.                       RPAREN       ,    !-- )           --!
  246.                       COLONSYMBOL  ,    !-- :           --!
  247.                       COMMASYM     ,    !-- ,           --!
  248.                       ADROP        ,    !-- <ADR OP>    --!
  249.                       ENDFILE      ,    !-- .           --!
  250.                       ASSIGNSYMBOL ,    !-- :=          --!
  251.                       EQUALSYM     );   !-- =           --!
  252.  
  253.     array DATAFILL short integer WORD2 =
  254.        ("DO","IF","OF","OR");
  255.  
  256.     array DATAFILL integer WORD3 =
  257.        ("AND ","END ","FOR ","SYN ","XOR ");
  258.  
  259.     array DATAFILL integer WORD4 =
  260.        ("BASE","BYTE","CASE","DATA","ELSE","GOTO","LONG","NULL",
  261.         "REAL","STEP","THEN");
  262.  
  263.     array DATAFILL integer WORD5 =
  264.        ("ARRAY   ","BEGIN   ","CLOSE   ","DUMMY   ",
  265.         "SHORT   ","UNTIL   ","WHILE   ");
  266.  
  267.     array DATAFILL integer WORD6 =
  268.        ("COMMON  ","EQUATE  ","GLOBAL  ","REPEAT  ");
  269.  
  270.     array DATAFILL integer WORD7 =
  271.        ("INTEGER ","LOGICAL ","SEGMENT ");
  272.  
  273.     array DATAFILL integer WORD8 =
  274.        ("EXTERNAL","FUNCTION","REGISTER");
  275.  
  276.     array DATAFILL integer WORD9 =
  277.        ("CHARACTER   ","PROCEDURE   ");
  278.  
  279.     array DATAFILL integer SHIFTWORD =
  280.        ("SHRL","SHLL","SHRA","SHLA");
  281.  
  282.     array 146 byte F      =
  283.        (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,
  284.        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,
  285.        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,
  286.        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,
  287.        11,3,10,7,9,7,12,2,3,3(11),10,9,10,9,4(10),9,8,10,8);
  288.  
  289.     array 146 byte G      =
  290.        (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,
  291.        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,
  292.        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,
  293.        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,
  294.        7,11,11,3(10),9,11,11);
  295.  
  296.     array 146 short integer MTB    =
  297.        (0,1,92,102,112,122,169,187,205,221,252,253,254,259,260,331,342,
  298.        368,373,390,396,402,412,417,426,456,468,469,479,484,485,504,505,
  299.        506,507,508,513,518,519,531,547,548,554,565,575,585,591,601,607,
  300.        613,619,625,631,637,647,663,673,680,686,692,698,703,714,720,726,
  301.        727,738,745,746,747,758,780,786,792,793,819,859,866,873,887,951,
  302.        952,975,988,989,990,991,992,1003,1004,1010,1028,1044,1045,1079,
  303.        1084,1085,1086,1097,1098,1103,1119,1128,1129,1130,1131,1142,1143,
  304.        1148,1153,1154,1159,1164,1165,1174,1175,1180,1181,1186,1194,1195,
  305.        1196,1202,1208,1213,1218,1219,1220,1227,1232,1238,1243,1254,1263,
  306.        1268,1284,1289,1306,1311,1316,1321,1331,1343,1348,1349,1354);
  307.  
  308. $IFT M M
  309.     integer AATYPE syn WORD5(4);
  310. $END M
  311.     comment THE FOLLOWING TWO TABLES ARE USED IN THE INSYMBOL SCAN
  312.        ROUTINE -- SCANTAB1 SCANS TO THE END OF COMMENTS,
  313.        SCANTAB2 SCANS TO THE NEXT NON-BLANK CHARACTER
  314.        USING THE FOLLOWING CODE:
  315.           0 -- BLANK, 1 -- NUMBER START, 2 -- ID START,
  316.           3 -- HEX NUMBER START, 4 -- STRING START,
  317.           5 -- ILLEGAL CHARACTER, >= 10 -- THESE ARE THE SPECIAL
  318.           SYMBOLS FOR PL360 SYNTAX.  FS + CODE - 10 IS THE SYNTACTIC
  319.           SYMBOL CODE ASSUMING THE FOLLOWING ORDER
  320.              SEMICOLON + - = < > ^ ( ) * / : , @ .                ;
  321.  
  322.     array 256 byte SCANTAB1=256(0);
  323.  
  324.     array 256 byte SCANTAB2 =
  325.          (64(5),                            !-- X'00' TO X'3F' --!
  326.           0, 10(5), 38, 18, 24, 12, 6,      !-- X'40' TO X'4F' --!
  327.           11(5), 7, 28, 26, 10, 22,         !-- X'50' TO X'5F' --!
  328.           14, 30, 8(5), 6, 34, 5, 1, 20, 5, !-- X'60' TO X'6F' --!
  329.           10(5), 32, 3, 36, 5, 16, 4,       !-- X'70' TO X'7F' --!
  330.           2(5, 9(2), 6(5)),                 !-- X'80' TO X'9F' --!
  331.           5, 22, 8(2), 6(5),                !-- X'A0' TO X'AF' --!
  332.           16(5),                            !-- X'B0' TO X'BF' --!
  333.           2(5, 9(2), 6(5)),                 !-- X'C0' TO X'DF' --!
  334.           2(5), 8(2), 6(5),                 !-- X'E0' TO X'EF' --!
  335.           10(1), 6(5));                     !-- X'F0' TO X'FF' --!
  336.     array 64 byte CONDTAB;  byte CONDCK syn CONDTAB(#2A);
  337.  
  338.     array 1000 byte ESDNAME syn MEM(R11);  !-- @ESDNAMETABLE --!
  339.  
  340.     comment ALLOCATION FOR THE COMPILER TABLES AND ARRAYS IS DONE
  341.        AT RUN TIME USING AVAILABLE CORE SPACE.  THE LITERAL TABLE
  342.        HAS A MAXIMUM LENGTH OF #3000 BYTES, DATA INITIALIZATION
  343.        SECTION A MAXIMUM LENGTH OF #8000 BYTES.  THE MAXIMUM LENGTH
  344.        OF THE OTHER VARIABLES IS GIVEN BELOW;
  345.     array  512  integer V syn 0;  !-- TRANSLATION STACK --!
  346.        short integer S syn V(12), T syn V(14);
  347.     integer V1 syn V(16);  short integer T1 syn T(16);
  348.     integer V2 syn V1(16);  short integer T2 syn T1(16);
  349.     array  #800  short integer LABEL syn 0;  !-- LABEL TABLE --!
  350.     short integer LABELADR syn LABEL(10);
  351.     short integer LABELCHAIN syn LABEL(12);
  352.     array #800 integer BRANCH syn 0;  !-- BRANCH TABLE --!
  353.        short integer BRANCHADR syn BRANCH,
  354.                      BRANCHAIN syn BRANCH(2);
  355.     array #1800 short integer TYPE syn 0;
  356.        array 2 short integer ADR syn TYPE(2);
  357.        short integer LINK syn TYPE(6);
  358.        byte NAME syn TYPE(8);  !-- NAME IS 2,4,6,8, OR 10 BYTES LONG --!
  359.     short equate SD syn 0, LD syn 1, ER syn 2, CM syn 5, XCM syn 6,
  360.        WER syn ER + 8, RLD syn 255;
  361.     array 14 byte ESDCODE="SDLDER****CMER";  !-- ESD TYPE NAMES --!
  362.     short equate ATYPE syn #0C, VTYPE syn #1C;
  363.     array 4 short integer ESDTBL syn MEM;
  364.        short integer PL360NO syn ESDTBL, RLDADDR syn ESDTBL(4),
  365.           ESDLINK syn ESDTBL(6);
  366.        byte ESDTYPE syn ESDTBL(2), RLDFLAG syn ESDTBL(3);
  367.     !-- DATA AND PROGRAM SEGMENT FORM --!
  368.     array 0 integer SEGAREA syn 0;
  369.        integer COUNTER syn SEGAREA, PREVSEG syn SEGAREA(4),
  370.           LASTINITIAL syn SEGAREA(8);
  371.        short integer SEGTYPE syn SEGAREA(12),
  372.           BLOCKLEVEL syn SEGAREA(14), SEGBASEREG syn SEGAREA(16);
  373.     short integer INITIALSTART syn 0, INITIALEN syn 2, TABLEN syn 0;
  374.     byte SEGHEAD syn 18;
  375.     short integer PROGRAM syn SEGHEAD(R9+4);
  376.     short integer PBREG syn SEGBASEREG(R9);
  377.     short integer DBREG syn SEGBASEREG(R10);
  378.     integer LC syn COUNTER(R9), DC syn COUNTER(R10);
  379.     byte GENFLAG=#FF, GENDECK=#FF;
  380. $IFF
  381.     byte XREFCC = " ";  !-- CARRIAGE CONTROL FOR XREF --!
  382. $END
  383.     array 5 integer PARAMSAVE;
  384.     integer PROGESDADR,PROGESDEND,DATAESDADR,DATAESDEND;
  385.     short integer PROGREG=15;
  386.     short integer SEGHDLEN=@SEGHEAD;
  387.  
  388.     array 10  byte RIGHTPART;  !-- USED IN SYNTACTIC ANALYSIS --!
  389.     equate NOMORERULES syn 255;  !-- END OF RIGHTPART RULES --!
  390. $IFF M M
  391.     array 20 integer CBUF;  !-- CARD BUFFER --!
  392. $END M
  393. $IFT M M
  394.     array 23 integer CBUF;  !-- CARD BUFFER, LINE NUMBER --!
  395.     array 6 byte EDMSK = (" ",3(#20),#21,#20);
  396. $END M
  397.     array 20 integer PBUF;  !-- PUNCH BUFFER --!
  398.     array 3  integer BLANK=3("    ");
  399.     array 133 byte WBUFF;  !-- PRINT BUFFER --!
  400.     array 132 byte WBUF syn WBUFF(1);
  401. $IFT M M
  402.     equate WCRDLN syn 6, WHDRLN syn 40;
  403.     array 10 byte WLINENUM syn WBUF(21);
  404.     array 72 byte WCARD syn WBUF(WHDRLN+2);
  405. $END M
  406. $IFF M M
  407.     equate WCRDLN syn 4, WHDRLN syn 34;
  408.     array 72 byte WCARD syn WBUF(WHDRLN+1);
  409. $END M
  410.     array 8 byte WSEQ syn WCARD(76);
  411.     array WHDRLN byte WHDR = WHDRLN(" ");  !-- LINE HEADER --!
  412.     array 3 byte WPSEG  syn WHDR(0);
  413.     array 4 byte WPDISP syn WHDR(4);
  414.     array 3 byte WDSEG  syn WHDR(11);
  415.     array 4 byte WDDISP syn WHDR(15);
  416.     array WCRDLN byte WCRDCNT syn WHDR(WHDRLN-WCRDLN-3);
  417.     array 2 byte WBGNEND syn WHDR(WHDRLN-2);
  418.     array 72 byte OBUF;      !-- OVERPRNT BUFFER --!
  419.     array 10 byte OMSK = 10(_1);  !-- MASK BYTES --!
  420. $IFT M M
  421.     array 32 byte ERRORBUF = 32(" ");
  422.     array 6 byte ERRWCRDCNT syn ERRORBUF(10);
  423.     array 16 byte ERRMESSAGE syn ERRWCRDCNT(6);
  424. $END M
  425.     array 133 byte HEADER   !-- LISTING PAGE HEADER --!
  426.        =("1PL360 COMPILATION",95(" "),"PAGE",16(" "));
  427.     array 133 byte SUBHEAD = 133(" ");
  428. $IFF
  429. $IFF M M
  430.     array 39 byte IDRDATA = ("1 DTR PL3600790", 24(" "));
  431. $END M
  432. $IFT M M
  433.     array 39 byte IDRDATA = (4(" "),"07-01-90 PL360",21(" "));
  434. $END M
  435. $END
  436.     short integer LIST = _1;  byte LISTFLAG syn LIST;
  437.     array  2  long real VALUEF;  !-- VALUE OF CURRENT SYMBOL --!
  438.     integer VALUE syn VALUEF;
  439.     short integer IVALUE syn VALUEF;
  440.     array  64  integer STRINGV;  !-- VALUE OF CURRENT STRING --!
  441.     array  3  integer ZERO=3(0);
  442.     equate DTHI syn #8765, DTLO syn #4321,
  443.            DTFILL syn DTHI shll 16 or DTLO;
  444.     byte C1 syn B1, C2 syn B2, C6 syn B6;
  445.     short integer H6 syn B6;
  446. $PAGE
  447.  procedure ERROREXIT(R4);   !-- EXIT FROM PROGRAM --!
  448.  begin  SB(XITF,FLGS);  goto EXIT;  end;
  449.  
  450.  procedure PRINT(R14);
  451.     begin  logical SAVE14; SAVE14 := R14;
  452.        R0 := 1 + LINECOUNT; CLI("0",CARRCONT); if = then
  453.        begin if R0 >= MAXLINE then CARRCONT := "1" else R0 := R0 + 1;
  454.        end;  CLI("1",CARRCONT); if = then
  455.        begin  R0 := 1 + PAGECOUNT; PAGECOUNT := R0;
  456.           CVD(R0,CONWORK); HEADER(118) := "`0`1`0";
  457.           ED(3,HEADER(117),CONWORK(6)); R0 := @HEADER; WRITE;
  458.           R0 := 3;  CARRCONT := "0";  CLC(93,SUBHEAD(1),SUBHEAD);
  459.           if ^= then  !-- SUPPLY SUB-HEADING --!
  460.           begin R0 := @SUBHEAD;  WRITE;  R0 := 4;
  461.           end;
  462.        end;
  463.        WBUFF(0/1) := CARRCONT; LINECOUNT := R0;
  464.        if R0 >= MAXLINE then CARRCONT := "1" else CARRCONT := " ";
  465.        R0 := @WBUFF; WRITE; R14 := SAVE14;
  466.     end;
  467.  
  468.  procedure OUTPUTCARD(R14);  if PRNT then
  469.     begin  array 4 integer SAVE40;  STM(R14,R1,SAVE40);
  470.        WBUF(0/WHDRLN) := WHDR;  WCARD(0/72) := CBUF;
  471. $IFT M M
  472.        WLINENUM(0/10) := CBUF(80);
  473. $END M
  474. $IFF M M
  475.        WDDISP(5/6) := BLANK;
  476. $END M
  477.        WSEQ(0/8) := CBUF(72);  PRINT;  RESET(PRNT);
  478.        WBUFF(0/133) := BLANK;  if TM(#80,OVER); ON then
  479.        begin  SET(PBUF);  PBUF(1/71) := PBUF;
  480.           PBUF(0/72) := PBUF xor OBUF;  !-- REVERSE MASK --!
  481.           WCARD(0/72) := WCARD and PBUF;  !-- BLANK FILL --!
  482.           if TM(#40,OVER); ON then  !-- UNDERLINE --!
  483.           begin  PBUF := "_";  PBUF(1/71) := PBUF;
  484.           end else PBUF(0/72) := CBUF;
  485.           PBUF(0/72) := PBUF and OBUF;  !-- OVERPRNT --!
  486.           if ^= then  !-- SOMETHING TO DO --!
  487.           begin  WCARD(0/72) := WCARD or PBUF;  WBUFF := "+";
  488.              R0 := @WBUFF;  WRITE;  !-- WRITE OVERPRNT --!
  489.           end;
  490.        end;  LM(R14,R1,SAVE40);  !-- RESTORE & RETURN --!
  491.     end;
  492.  
  493.  procedure ENDMESSAGES(R2);
  494.     begin  WBUF := "*** FURTHER ERROR MESSAGES SUPPRESSED";
  495.        PRINT; WBUFF(0/38) := BLANK; SETZONE(CARRCONT);
  496.     end;
  497.  
  498.  procedure ERROR (R4);
  499.     begin  array 3 integer ERRSAVE; STM(R0,R2,ERRSAVE);
  500.        if NOTMOVED then goto X;  SET(NOTMOVED);
  501.        R0 := 1 + ERRCOUNT; ERRCOUNT := R0; if R0 > ERRLIMIT then goto X;
  502.        SET(PRNT);  !-- INDICATE NEED TO PRINT IMAGE --!
  503.        WBUFF(0/125) := BLANK; R2 := R2-R2; IC(R2,XR);
  504.        R2 := R2 shll 4;   !-- RELATIVE ERROR MESSAGE --!
  505.        begin  segment base R1;  array 512 byte ERRORCODE=
  506.        ("00 SYNTAX       ","01 VAR MIX TYPES","02 FOR PARAMETER",
  507.         "03 REG ASS TYPES","04 BIN OP TYPES ","05 SHIFT OP     ",
  508.         "06 COMPARE TYPES","07 REG TYPE OR #","08 UNDEFINED ID ",
  509.         "09 MULT LAB DEF ","10 EXC INI VALUE","11 NOT INDEXABLE",
  510.         "12 DATA OVERFLOW","13 NO. OF ARGS  ","14 ILLEGAL CHAR ",
  511.         "15 MULTIPLE ID  ","16 PROGRAM OFLOW","17 INITIAL OFLOW",
  512.         "18 ADDRESS OFLOW","19 NUMBER OFLOW ","20 MISSING .    ",
  513.         "21 STRING LENGTH","22 NULL CASE ST.","23 FUNC DEF NO. ",
  514.         "24 ILLEGAL PARAM","25 NUMBER       ","26 SYN MIX      ",
  515.         "27 SEG NO OFLOW ","28 ILLEGAL CLOSE","29 NO DATA SEG  ",
  516.         "30 ILLEGAL INIT ","31 GET MORE CORE");
  517.        end; R1 := R1+R2; WBUF(11/16) := B1;
  518. $IFF M M
  519.        WBUF(2) := "ERROR NO"; R1 := @WBUF(R6+35); B1 := "!";
  520. $END M
  521. $IFT M M
  522.        ERRMESSAGE(0/16) := B1;  R1 := @ERRORBUF;  ERRBUFFR;
  523.        WBUF(2) := "ERROR NO"; R1 := @WCARD(R6); B1 := "!";
  524. $END M
  525.        WBUF(108) := "*";  WBUF(109/16) := WBUF(108);
  526.        PRINT; WBUFF(0/133) := BLANK; RESET(RUNFLAG);
  527.        if GENFLAG then RESET(GENDECK);
  528.        R0 := ERRCOUNT; if R0 = ERRLIMIT then ENDMESSAGES;
  529.  X:    LM(R0,R2,ERRSAVE);
  530.     end;
  531.  
  532.  procedure LABELERROR(R3);  !-- PRINTS OUT UNDEFINED LABELS --!
  533.     begin  integer TEMP, SAVE; WBUFF(0/121) := BLANK; SAVE := R0;
  534.        R2 := R1 + LABELBASE; WBUF(9/10) := LABEL(R2);
  535.        WBUF(20) := "UNDEF LAB";  RESET(RUNFLAG);
  536.        if GENFLAG then RESET(GENDECK);
  537.        R0 := CSEGNO; CVD(R0,CONWORK);
  538.        UNPK(2,7,WBUF,CONWORK); SETZONE(WBUF(2));
  539.        WBUF(108) := "*";  WBUF(109/16) := WBUF(108);
  540.        R2 := LABELCHAIN(R2); while R2 >= 0 do
  541.        begin TEMP := R2; UNPK(4,4,WBUF(4),TEMP); WBUF(8) := " ";
  542.           TR(3,WBUF(4),TRTABLE(_240)); PRINT; R2 := PROGRAM(R2+2);
  543.           R0 := 1+ERRCOUNT =: ERRCOUNT; if R0 > ERRLIMIT then goto Y;
  544.        end; if R0 = ERRLIMIT then ENDMESSAGES;
  545.  Y:    WBUFF(0/133) := BLANK;
  546.  X:    R0 := SAVE;
  547.     end;
  548.  
  549.  procedure EDIT (R8);
  550.     begin R1 := LC; PROGRAM(R1) := R0; R1 := R1+2; LC := R1;
  551.     end;
  552.  
  553.  procedure EMIT (R8);
  554.     begin R0 := R0 shll 4 or R1 shll 4 or R2 shll 4 or R3;
  555.        R1 := LC; PROGRAM(R1) := R0; R1 := R1+2; LC := R1;
  556.     end;
  557.  
  558.  procedure EMYT (R8);
  559.     begin R0 := R0 shll 4 or R1 shll 4 or R2 shll 20 or R3;
  560.        R1 := LC; PROGRAM(R1+2) := R0; R0 := R0 shrl 16;
  561.        PROGRAM(R1) := R0; R1 := R1+4; LC := R1;
  562.     end;
  563.  
  564.  procedure EMYTBRANCH(R8);
  565.     begin R0 := R0 or #4700; R1 := LC; PROGRAM(R1) := R0;
  566.        R0 := ENDCHAIN =: PROGRAM(R1+2);
  567.        V(R7) := R1; R1 := R1 + 4; LC := R1;
  568.     end;
  569.  
  570.  procedure ANDTORCHAIN(R4);
  571.     begin integer ANDCHAIN syn MEM(R3), ORCHAIN syn MEM(R3+4);
  572.        byte OPCODE syn B2, COND syn B2(1);
  573.        if R1 := ANDCHAIN; R1 ^= ENDCHAIN then
  574.        begin R1 := R1 and #FFFF;  R2 := @PROGRAM(R1);
  575.           if OPCODE = #46 then !-- BCT instruction --!
  576.           begin R0 := R1; R1 := LC;
  577.              R2 := #47F0S =: PROGRAM(R1);
  578.              R2 := @B1(4) =: LC;
  579.           end else
  580.           begin R0 := PROGRAM(R1+2);
  581.              if OPCODE = #47 and COND >= #F0 and OPTFLAG >= #80 then
  582.              begin LC := R1; goto X;
  583.              end; if < then XI(#F0,COND) else XI(#01,OPCODE);
  584.           end; R2 := ORCHAIN =: PROGRAM(R1+2); ORCHAIN := R1;
  585.  X:       ANDCHAIN := R0;
  586.        end;
  587.     end;
  588.  
  589.  procedure MERGECHAIN (R4);
  590.     begin short integer NEXT syn B2(2);
  591.        R1 := NEXT; NEXT := R0; R0 := R1;
  592.        while R1 := NEXT; R1 >= 0 do R2 := @PROGRAM(R1);
  593.        NEXT := R0;
  594.     end;
  595.  
  596.  procedure CHAINFIXUP (R4);
  597.     if R1 ^= ENDCHAIN then
  598.     begin integer SAVE4; SAVE4 := R4; R0 := R0 shll 16 shra 16;
  599.        R3 := N5 + BRANCHBASE; R2 := N6 + BRANCHBASE;
  600.        while R2 := @B2(4); R2 <= R3 do
  601.        begin if R0 = BRANCHADR(R2) then
  602.           begin R0 := R1; MERGECHAIN; R4 := SAVE4; goto X;
  603.           end;
  604.        end; BRANCHADR(R2) := R0; BRANCHAIN(R2) := R1;
  605.        R2 := R2 - BRANCHBASE =: N5; R1 := ENDCHAIN;
  606.  X: end;
  607.  
  608.  procedure ENTERBRANCH(R8);
  609.     begin comment R1 = ADDRESS OF START OF BRANCH CHAIN,
  610.           R2 = LABEL ID;
  611.        R5 := N4 + LABELBASE;
  612.        for R4 := N3 + LABELBASE step _14S until R5 do
  613.        if B2(0/10) = LABEL(R4) then
  614.        begin R0 := R1; R2 := @LABELCHAIN(R4-2); MERGECHAIN; goto L;
  615.        end; R4 := 14 + N3 =: N3 + LABELBASE; LABEL(R4/10) := B2;
  616.        LABELCHAIN(R4) := R1; R0 := R0 -- R0 =: LABELADR(R4);
  617. L:  end;
  618.  
  619.  procedure ENTERNAME(R8);
  620.     begin R5 := R5-R5; IC(R5,B1); IC(R5,ALPHASH(R5-193));
  621.        R3 := @B3(1) and #E;  R14 := NAMEBASE;
  622.        R5 := R5 + LENHASH(R3-2); REDUCE(R3); R4 := HASHCHAIN(R5);
  623.        while R4 >= N2 do
  624.        begin R4 := R4 + R14; EX(R3,CLC(0,B1,NAME(R4))); if = then
  625.           begin XR := 15; ERROR; R4 := N1 + NAMEBASE; goto X;
  626.           end; R4 := LINK(R4);
  627.           if R4 ^= ENDCHAIN then R4 := R4 and #FFFF;
  628.        end;
  629.        R4 := N1 + R14; EX(R3,MVC(0,NAME(R4),B1)); TYPE(R4) := R2;
  630.        ADR(R4+2) := R0; R0 := R0 shrl 16; ADR(R4) := R0;
  631.        R0 := HASHCHAIN(R5); LINK(R4) := R0;
  632.        R0 := N1; HASHCHAIN(R5) := R0; R0 := R0 + R3 + 9S; N1 := R0;
  633.        if R0 > NAMEND then    !NAMETABLE OVERFLOW!
  634.        begin  XR := 31;  ERROR;
  635.           WBUF := "CORE SIZE TOO SMALL ";
  636.           WBUF(STRING/132-STRING) := WBUF(STRING-1);  PRINT;
  637.           SB(NOGO,FLGS);  ERROREXIT;
  638.        end;
  639.        if TM(2,TRACE); ON then
  640.        begin  WBUFF(0/132) := BLANK; WBUF(19/10) := B1;
  641.           R14 := #FF and R2;  CVD(R14,CONWORK);
  642.           OI(#0F,CONWORK(7)); UNPK(1,1,WBUFF(31),CONWORK(6));
  643.           if R2 ^= 10S then
  644.           if R2 = 12S then
  645.           begin UNPK(8,4,WBUF(9),ADR(R4)); TR(7,WBUF(9),TRTABLE(_240));
  646.           end else
  647.           begin  UNPK(4,4,WBUF(13),ADR(R4));
  648.              TR(3,WBUF(13),TRTABLE(_240));
  649.              if R1 > R7 and R14 <= 4S then
  650.              begin  IC(R14,ALENGTH(R14));  R14 := @B14(1);
  651.                 if R14 ^= V(R7) then WBUF(35) := "A";
  652.              end;
  653.           end; WBUF(17) := " "; PRINT; WBUFF(0/40) := BLANK;
  654.        end;
  655.  X: end;
  656.  
  657.  procedure EMITLIT (R4);  !-- USED BY FOR STATEMENT --!
  658.     begin integer TEMP; TEMP := R5; R0 := 5; R3 := R3-R3; EMIT;
  659.        R1 := LITX; R3 := R1 + LITBASE; R1 := R1 + 8S; LITX := R1;
  660.        MVI(2,B3); MVI(3,B3(1)); B3(2/2) := LC(2);
  661.        B3(4/4) := TEMP; R0 := 2 + LC; LC := R0;
  662.     end;
  663.  
  664.  procedure MAKELITERAL(R4);
  665.     begin comment R0 = TYPE, R1 = LENGTH, R2 = FIXUP ADDRESS,
  666.           R3 = ADDRESS OF FIRST BYTE IF NOT SHORT INTEGER TYPE 1
  667.              OR ADDRESS - 2 IF SHORT INTEGER;
  668.        short integer ADDRESS; ADDRESS := R2;
  669.        R2 := LITX + LITBASE; STC(R0,B2); STC(R1,B2(1));
  670.        B2(2/2) := ADDRESS; CLI(1,B2); if = then
  671.        EX(R1,MVC(0,B2(4),B3(2))) else EX(R1,MVC(0,B2(4),B3));
  672.        R2 := @B2(R1+5) - LITBASE; LITX := R2;
  673.     end;
  674. $PAGE
  675. $IFT M M
  676.  segment procedure ENTERSYMLABEL(R8);
  677.     begin array 4 integer SAVE36;
  678.       STM(R3,R6,SAVE36); R4 := PROCSTACK; R6 := FREESPACE;
  679.       R5 := B6; FREESPACE := R5; R5 := DATAPTR(R4);
  680.       SYMLINK(R6) := R5; DATAPTR(R4) := R6; R0:= R0 and #0FFF;
  681.       MVI(0,AAFIELD(R6)); DISPFIELD(R6) := R0;
  682.       R4 := CARDCOUNT; CARDNO(R6) := R4;
  683.       case R1 of begin
  684.         begin SYMFIELD(R6/10) := V(R7); R1 := T(R7); end;
  685.         begin SYMFIELD(R6) := "#B"; R2 := CARDNO(R6);
  686.           CVD(R2,CONWORK); UNPK(5,3,FFIELD(R6),CONWORK(5));
  687.           SETZONE(MFIELD(R6+2)); SYMFIELD(R6+2/4) := FFIELD(R6);
  688.           R1 := 6;
  689.         end;
  690.         begin SYMFIELD(R6/10) := V1(R7); R1 := R3;
  691.            PROCPTR := R6;
  692.         end;
  693.         begin SYMFIELD(R6) := "#E"; R2 := CARDNO(R6);
  694.            CVD(R2,CONWORK); UNPK(5,3,FFIELD(R6),CONWORK(5));
  695.            SETZONE(MFIELD(R6+2)); SYMFIELD(R6+2/4) := FFIELD(R6);
  696.            R1 := 6;
  697.         end;
  698.         begin
  699.            SYMFIELD(R6) := "#END"; R1 := 4;
  700.         end;
  701.       end;
  702.       R1 := @B1(64); STC(R1,ORFIELD(R6)); LM(R3,R6,SAVE36);
  703.  end;
  704. $PAGE
  705.  segment procedure ENTERSYMDATA(R8);
  706.     begin array 7 integer SAVE06;
  707.       STM(R0,R6,SAVE06); R4 := DATASTACK; R6 := FREESPACE;
  708.       R5 := B6; FREESPACE := R5; R5 := DATAPTR(R4);
  709.       SYMLINK(R6) := R5; DATAPTR(R4) := R6; R0 := R0 and #0FFF;
  710.       MVI(0,AAFIELD(R6)); DISPFIELD(R6) := R0; R4 := CARDCOUNT;
  711.       CARDNO(R6) := R4; SYMFIELD(R6/10) := B1; R4:=128;
  712.       R5 := AATYPE; if R5 = B7(4) then begin R4 := @B4(64);
  713.          R5 := B7; end else R5 := R5 - R5;
  714.       R2 := 1 + T(R7) and #FF;  case R2 of begin
  715.         begin MVI(#14,FFIELD(R6)); MVI(1,LDFIELD(R6));
  716.            R5 := R5 shrl 1; end;
  717.         begin MVI(#10,FFIELD(R6)); MVI(3,LDFIELD(R6));
  718.            R5 := R5 shrl 2; end;
  719.         begin MVI(#1C,FFIELD(R6)); MVI(7,LDFIELD(R6));
  720.            R5 := R5 shrl 3; end;
  721.         begin MVI(#18,FFIELD(R6)); MVI(3,LDFIELD(R6));
  722.            R5 := R5 shrl 2; end;
  723.         begin MVI(#04,FFIELD(R6)); MVI(0,LDFIELD(R6)); end;
  724.         end;
  725.       DUPFAC(R6) := R5; MVI(0,MFIELD(R6));
  726.       R4 := R4 or R3; STC(R4,ORFIELD(R6)); LM(R0,R6,SAVE06);
  727.  end;
  728. $PAGE
  729. $END M
  730.  segment procedure ALLOCATELITERALS(R8);
  731.     begin  !-- R4 := LC IS A PARAMETER --!
  732.        array  3  integer TEMP; integer LITEND;
  733.        short integer ADDRESS;
  734.  
  735.     procedure RLDCHAINEMIT(R8);
  736.        begin comment FIX UP RLD CHAIN ENTRIES AND EMIT RLD LITERAL --
  737.           R4 = LC, FIRST ENTRY IS MAIN PROGRAM;
  738.           R0 := PROGESDEND; R1 := PROGESDADR;
  739.           R5 := RLDADDR(R1); if R5 >= 0 then
  740.           begin while R5 >= 0 do
  741.              begin R6 := PROGRAM(R5+2); R2 := PROGRAM(R5);
  742.                 R3 := R2 and #F shll 12 + R4 - R5; PROGRAM(R5+2) := R3;
  743.                 R2 := R2 and #FFF0; PROGRAM(R5) := R2; R5 := R6;
  744.              end;
  745.              R3 := R3-R3; PROGRAM(R4) := R3; PROGRAM(R4+2) := R3;
  746.              RLDADDR(R1) := R4;  R4 := @B4(4);
  747.           end;
  748.           R1 := R1 + 8S; while R1 < R0 do
  749.           begin  if ESDTYPE(R1) ^= SD then
  750.                  if ESDTYPE(R1) ^= ER then
  751.                  if ESDTYPE(R1) ^= WER then
  752.                  if ESDTYPE(R1) ^= XCM then goto SKIP;
  753.              R5 := RLDADDR(R1); if R5 < 0 then goto SKIP;
  754.              while R5 >= 0 do
  755.              begin R6 := PROGRAM(R5+2); R3 := PTAG + R4;
  756.                 PROGRAM(R5+2) := R3; R5 := R6;
  757.              end;
  758.              R3 := R3-R3; PROGRAM(R4) := R3; PROGRAM(R4+2) := R3;
  759.              RLDADDR(R1) := R4;  R4 := @B4(4);
  760. SKIP:        R1 := R1 + 8S;
  761.           end;  R5 := @PROGRAM(R4);  B5(0/4) := ZERO;
  762.        end;
  763.  
  764.     procedure ALLTYPE(R8);
  765.        begin comment R0 = LENGTH AND R4 = LC ARE PARAMETERS --
  766.           R7 = START OF LITERALS -- LITEND = END OF LITERALS;
  767.           R6 := R7; while R6 < LITEND do
  768.           begin IC(R1,B6(1)); IC(R2,B6); if R0 = R2 then
  769.              begin ADDRESS(0/2) := B6(2); R3 := ADDRESS;
  770.                 R4 := R4 + PTAG; PROGRAM(R3) := R4;
  771.                 ADDRESS:=R4; B6(2/2) := ADDRESS;
  772.                 R5 := @B6(R1+5); while R5 < LITEND do
  773.                 begin IC(R2,B5(1)); CLC(1,B5,B6); if = then
  774.                    begin EX(R2,CLC(0,B5(4),B6(4))); if = then
  775.                       begin ADDRESS(0/2) := B5(2); R3 := ADDRESS;
  776.                          PROGRAM(R3) := R4; MVI(4,B5);
  777.                          ADDRESS:=R4; B5(2/2) := ADDRESS;
  778.                       end;
  779.                    end; R5 := @B5(R2+5);
  780.                 end; R4 := R4 - PTAG; R5 := @PROGRAM(R4);
  781.                 EX(R1,MVC(0,B5,B6(4))); R4 := @B4(R1+1);
  782.              end; R6 := @B6(R1+5);
  783.           end;  R5 := @PROGRAM(R4);  B5(0/4) := ZERO;
  784.        end;
  785.  
  786.        STM(R6,R8,TEMP); R7 := LITBASE; R6 := R7 + LITX;
  787.        LITEND := R6; R6 := N4 + LABELBASE; R7 := R7 + LABEL(R6+2);
  788.        LM(R0,R2,ZERO);  ALLTYPE;
  789.        R0 := 1; R4 := R4 + 1 and _2; ALLTYPE;
  790.        R0 := 2; R4 := R4 + 3S and _4; ALLTYPE;
  791.        RLDCHAINEMIT; LM(R1,R2,ZERO);
  792.        R0 := 3; R4 := R4 + 7S and _8; ALLTYPE;
  793.        R6:=R7; while R6<LITEND do
  794.        begin IC(R2,B6); if R2>8S then
  795.           begin R2:=R2 shll 30; if R2<0 then
  796.              begin ADDRESS(0/2) := B6(8); R3:=ADDRESS+ LITBASE;
  797.                 B6(8/2) := B3(2);
  798.              end; R2:=R2 shll 1; if R2<0 then
  799.              begin ADDRESS(0/2) := B6(6); R3:=ADDRESS+LITBASE;
  800.                 B6(6/2) := B3(2);
  801.              end; R2:=8; STC(R2,B6);
  802.           end; IC(R1,B6(1)); R6:=@B6(R1+5);
  803.        end; R0:=8; ALLTYPE;
  804.        R3 := N4 + LABELBASE; R2 := LABEL(R3+2); LITX := R2;
  805.        LM(R6,R8,TEMP);
  806.     end;
  807.  
  808.  procedure SETDATAINIT(R8);
  809.     begin comment SET DATA INITIALIZATION --
  810.        R1 = COUNT -- AT EXIT R2 = ADDRESS TO MOVE DATA;
  811.        R3 := LASTINITIAL(R10); R2 := INITIALSTART(R3) + INITIALEN(R3);
  812.        R4 := DC1; if R2 ^= R4 then
  813.        begin  if R2 ^= INITIALSTART(R3) then
  814.           begin R3 := R3 + INITIALEN(R3) + 5S and _2;
  815.              LASTINITIAL(R10) := R3;  !-- NEW LAST --!
  816.              R0 := R0-R0; INITIALEN(R3) := R0;
  817.           end;  INITIALSTART(R3) := R4;
  818.        end;  R0 := 4 + R3 + R1 + INITIALEN(R3);  !-- @LAST BYTE --!
  819.        if R0 > DATAEND then
  820.        begin XR := 17; ERROR; SET(SKIPFLAG);
  821.           R1 := R1-R1; INITIALEN(R3) := R1;
  822.        end else
  823.        begin R0 := R4+R1;  if R0 > DC then
  824.           if FILLFLAG then DC := R0 else  !-- ERROR --!
  825.           begin XR := 10; ERROR; SET(SKIPFLAG); R1 := R1-R1;
  826.           end;
  827.        end;
  828.        R0 := R1 + INITIALEN(R3); R2 := 4 + R3 + INITIALEN(R3);
  829.        INITIALEN(R3) := R0; R0 := DC1 + R1; DC1 := R0;
  830.     end;
  831.  
  832.  procedure MOVETABLE(R4);
  833.     if R3 ^= 0 then
  834.     begin  !-- MOVE R3 BYTES FROM B1 TO B2 --!
  835.        for R3 := R3 - 1 step _256 until 256 do
  836.        begin B2(0/256) := B1; R1 := R1 + 256; R2 := R2 + 256;
  837.        end; EX(R3,MVC(0,B2,B1));
  838.     end;
  839.  
  840.  procedure INCRSEGNO(R8);
  841.     begin  !-- GET NEXT SEGMENT NUMBER --!
  842.        R0 := 1 + NSEGNO; if R0 > MAXSEGNO then
  843.        begin XR := 27; ERROR; R0 := MAXSEGNO;
  844.        end; NSEGNO := R0; SEGNO := R0;
  845.        if R0 > MAXSEG then MAXSEG := R0;
  846.     end;
  847.  
  848.  procedure FINDESDENTRY(R8);
  849.     begin comment R0 = END OF ESD TABLE, R1 = START OF ESD TABLE,
  850.        R2 = ESD TYPE, R3 = RLD FLAG, R4 = CSEGNO -- AT EXIT
  851.        R0 = NEW END OF ESD TABLE, R1 = ADDRESS OF ESD ENTRY --
  852.        A NEW ENTRY IS MADE IF NO ENTRY IS FOUND;
  853.        while R1 < R0 do
  854.        if R4 = PL360NO(R1) then goto FOUND else R1 := R1 + 8S;
  855.        PL360NO(R1) := R4; R0 := ENDCHAIN; RLDADDR(R1) := R0;
  856.        ESDLINK(R1) := R0;
  857.        STC(R2,ESDTYPE(R1)); STC(R3,RLDFLAG(R1)); R0 := 8 + R1;
  858. FOUND:
  859.     end;
  860.  
  861.  procedure STACKSEG(R4);
  862.     begin comment STACK CURRENT SEG TO BE READY TO OPEN NEW SEG --
  863.        R0 = END OF ESD TABLE, R1 = START OF ESD TABLE,
  864.        R5 = START OF SEGMENT TO STACK -- AT EXIT
  865.        R5 = START OF NEW SEGMENT AND PREVSEG SET TO STACKED SEG;
  866.        STM(R0,R4,PARAMSAVE);
  867.        R2 := LASTINITIAL(R5) + INITIALEN(R2) + 5S and _2;
  868.        R3 := R0 - R1; TABLEN(R2) := R3; R2 := R2 + 2; R0 := R2 + R3;
  869.        MOVETABLE; R1 := R0 + 3S and _4;
  870.        PREVSEG(R1) := R5; R5 := R1;
  871.        LM(R0,R4,PARAMSAVE);
  872.     end;
  873.  
  874.  procedure UNSTACKSEG(R4);
  875.     begin comment UNSTACK SEG --
  876.        R1 = START OF ESD TABLE, R5 = START OF SEGMENT TO UNSTACK,
  877.        AT EXIT R0 = END OF ESD TABLE;
  878.        STM(R1,R4,PARAMSAVE(4));
  879.        R2 := R1; R1 := LASTINITIAL(R5) + INITIALEN(R1) + 5S and _2;
  880.        R3 := TABLEN(R1); R1 := R1 + 2;
  881.        R0 := R2 + R3; MOVETABLE;
  882.        LM(R1,R4,PARAMSAVE(4));
  883.     end;
  884. $PAGE
  885.  procedure OPENSEG(R4);
  886.     begin comment OPEN NEW SEGMENT -- R5 = START OF SEGMENT,
  887.        R2 = TYPE OF SEG, R3 = BASE REGISTER FOR SEG;
  888. $IFF M M
  889.        STM(R0,R1,PARAMSAVE);
  890. $END M
  891. $IFT M M
  892.        STM(R0,R3,PARAMSAVE);
  893. $END M
  894.        SEGTYPE(R5) := R2; SEGBASEREG(R5) := R3;
  895. $IFF M M
  896.        R1 := R5 + SEGHDLEN; LASTINITIAL(R5) := R1; R0 := R0-R0;
  897. $END M
  898. $IFT M M
  899.        if TESTFLAG then
  900.        begin  if R2 > 10 then
  901.           begin  R3 := DATASTACK;  R3 := @B3(4);
  902.              if R3 = DSTAKBOT then
  903.              begin  RESET(TESTFLAG);  goto X;  end;
  904.              DATASTACK := R3;
  905.           end else
  906.           begin  R3 := PROCSTACK;  R3 := @B3(4);
  907.              if R3 = PSTAKBOT then
  908.              begin  RESET(TESTFLAG);  goto X;  end;
  909.              PROCSTACK := R3;
  910.           end;  R0 := neg 1;  DATAPTR(R3) := R0;
  911.        end;
  912.        X: R1 := R5 + SEGHDLEN; LASTINITIAL(R5) := R1; R0 := R0-R0;
  913. $END M
  914.        COUNTER(R5) := R0; INITIALSTART(R1) := R0; INITIALEN(R1) := R0;
  915.        R0 := BLOCK; BLOCKLEVEL(R5) := R0;
  916. $IFF M M
  917.        LM(R0,R1,PARAMSAVE);
  918. $END M
  919. $IFT M M
  920.        LM(R0,R3,PARAMSAVE);
  921. $END M
  922.     end;
  923. $PAGE
  924.  segment procedure CLOSESEG(R4);
  925.     begin comment CLOSE CURRENT SEGMENT -- R5 = START OF SEGMENT,
  926.        R0 = END OF ESD TABLE, R1 = START OF ESD TABLE;
  927.        array 2 logical SAVE01;  array 8 logical SAVE07;
  928.        array 40 short integer CARD syn PBUF; integer CARDI syn PBUF;
  929.        short integer ESDID, SEQNO;
  930.        integer WORK syn CONWORK; byte DUMPLINE syn WBUF(17);
  931.  
  932.     procedure DUMPHALF(R1);
  933.        begin UNPK(8,4,B2,B3); MVI(239,B2(8));
  934.           UNPK(8,4,B2(10),B3(4)); MVI(239,B2(18));
  935.           UNPK(8,4,B2(20),B3(8)); MVI(239,B2(28));
  936.           UNPK(8,4,B2(30),B3(12)); MVI(239,B2(38));
  937.           R2 := @B2(41); R3 := @B3(16);
  938.        end;
  939.  
  940.     procedure PUNCHSEQ (R8);
  941.        begin  R0 := 1 + SEQNO; SEQNO := R0; CVD(R0,CONWORK);
  942.           UNPK(3,7,CARD(76),CONWORK); SETZONE(CARD(79));
  943.           CARD(72/4) := SEGNAM; R0 := @CARD; PUNCH;
  944.        end;
  945.  
  946.     procedure CARDOUT (R8);
  947.        begin  logical SAVE8; SAVE8 := R8;
  948.           if R0 ^= 0 then
  949.           begin  CARD(10) := R0; PUNCHSEQ;
  950.           end;
  951.           R0 := R0-R0; R6 := @CARD; CARD(5/75) := CARD(4);
  952.           R8 := SAVE8;
  953.        end;
  954.  
  955.     procedure ESDPRINT(R8);
  956.        begin  comment PRINT ESD DICTIONARY ENTRY --
  957.           R6 + 16 = OBJECT ESD CARD ENTRY;
  958.           STM(R0,R1,SAVE01); WBUFF(0/133) := BLANK;
  959.           if C6(24) = ER then  !-- EXTRN --!
  960.           WBUF(40) := "EXTERNAL REFERENCE" else
  961.           if C6(24) = WER then  !-- WEAK EXTRN --!
  962.           WBUF(40) := "WEAK EXT REFERENCE" else
  963.           begin  WBUF(40) := "ENTRY (XX) AT";  R1 := R1-R1;
  964.              IC(R1,B6(24)); R1 := R1+R1; R1 := @ESDCODE(R1);
  965.              WBUF(47/2) := B1; UNPK(4,2,WBUF(54),B6(26));
  966.              TR(3,WBUF(54),TRTABLE(_240));  WBUF(58) := " ";
  967.           end;
  968.           WBUF(30/8) := B6(16); PRINT; LM(R0,R1,SAVE01);
  969.        end;
  970. $PAGE
  971. $IFF M M
  972.        STM(R0,R7,SAVE07);  R4 := SEGTYPE(R5);
  973. $END M
  974. $IFT M M
  975.  procedure GENLABEL(R7);
  976.     begin integer SAVE3;  SAVE3 := R3;  R3 := CARDNO(R5);
  977.        CVD(R3,CONWORK);  UNPK(5,3,WCARD(1),CONWORK(5));
  978.        SETZONE(WCARD(5));  WCARD := "#";  if R1 > 4S then
  979.        begin  SYMFIELD(R5+5/5) := WCARD;  R1 := 10;
  980.        end else
  981.        begin R3 := @B5(R1+1); SYMFIELD(R3/5) := WCARD; R1 := @B1(6);
  982.        end;  RB(#0F,ORFIELD(R5));  EX(R1,SB(0,ORFIELD(R5)));
  983.        R3 := SAVE3;
  984.     end;
  985.  
  986.  procedure PUTNAME(R7);
  987.     begin  R6 := @CARD(20);  R0 := 4;  if B3 = "SEGN" then
  988.        begin  B6(0/7) := B3;  R6 := @B6(7);  R1 := 7;  R0:= 11;
  989.        end else
  990.        begin  R1 := R1 - R1;
  991.  LOOP:    if B3(0/1) ^= " " then
  992.           begin  B6(0/1) := B3;  R3 := @B3(1);  R6 := @B6(1);
  993.              R0 := R0 + 1S; R1 := @B1(1); if R1 < 8S then goto LOOP;
  994.           end;
  995.        end;
  996.     end;
  997.  
  998.  procedure SEARCH(R8);
  999.    begin integer SAVE5;  SAVE5 := R5;  R2 := R5;  while R2 > 0 do
  1000.       begin  IC(R1,ORFIELD(R2));  R1 := R1 and 15;  REDUCE(R1);
  1001.          R3 := R3 - R3;  CLC(1,SYMFIELD(R2),"#B");  if ^= then
  1002.          begin  R5 := SYMLINK(R2);  RESET(SYM);  while R5 > 0 do
  1003.             begin  IC(R3,ORFIELD(R5));  R3 := R3 and 15;
  1004.                REDUCE(R3);  if R1 = R3 then
  1005.                begin  EX(R1,CLC(0,SYMFIELD(R5),SYMFIELD(R2)));
  1006.                   if = then
  1007.                   begin  GENLABEL;  SET(SYM);  R1 := R3;
  1008.                   end;
  1009.                end;  R5 := SYMLINK(R5);
  1010.             end;  if SYM then
  1011.             begin  RESET(SYM);  R5 := R2;  GENLABEL;
  1012.             end;
  1013.          end;  R2 := SYMLINK(R2);
  1014.       end;  R5 := SAVE5;
  1015.    end;
  1016.  
  1017.  procedure CSECT(R8);
  1018.     begin  R6 := PL360NO(R1);  R6 := R6 * 10S;  CARD := "`BSYMPL3 ";
  1019.        CARD(8/72) := CARD(7);  R3 := @ESDNAME(R6);  case R4 of
  1020.        begin
  1021.           begin  CARD(16/4) := #10000000;  PUTNAME;  end;
  1022.           begin  CARD(16/4) := #30000000;  PUTNAME;  end;
  1023.           null;
  1024.           begin  R2 := CARDNO(R5);  REDUCE(R2);  CVD(R2,CONWORK);
  1025.              UNPK(5,3,CARD(22),CONWORK(5));  SETZONE(CARD(26));
  1026.              CARD(16/6) := #200000007BC4X;  R6 := @CARD(26);
  1027.              R0 := 10;  R1 := 6;
  1028.           end;
  1029.        end;  EX(R1,SB(0,CARD(16)));
  1030.     end;
  1031.  
  1032.  procedure OUTSYM(R7);
  1033.     begin  R2 := R0 + R1;  if R2 <= 55S then R2 := R2 - R2 else
  1034.        begin  R2 := R2 - 55S;  R1 := R1 - R2;
  1035.        end;  EX(R1,MVC(0,B6,ORFIELD(R5)));  R1 := @B1(1);
  1036.        R0 := R0 + R1;  R6 := R6 + R1;  if R0 = 56 then
  1037.        begin  CARDOUT;  CARD := "`BSYMPL3 ";  CARD(8/64) := CARD(7);
  1038.           R6 := @CARD(16);  if R2 ^= 0 then
  1039.           begin  R3 := R5 + R1;  EX(R2,MVC(0,B6,ORFIELD(R3)));
  1040.              R6 := R6 + R2;  R0 := R2;
  1041.           end;
  1042.        end; R3 := FREESPACE; R2 := SYMLINK(R5); SYMLINK(R5) := R3;
  1043.        FREESPACE := R5; R5 := R2;
  1044.     end;
  1045.  
  1046.  procedure SYMPRINT(R7);
  1047.     begin  integer STOP=_1, SAVE7;  R0 := R0 - R0 =: SEQNO;
  1048.        SAVE7 := R7;  if R1 ^= DATAESDADR then
  1049.        begin  R6 := PROCSTACK;  if R4 = 3S then
  1050.           begin R6 := R6 - 4S; R5 := DATAPTR(R6); R2 := SYMLINK(R5);
  1051.              DATAPTR(R6) := R2;  PROCSTACK := R6;  R2 := FREESPACE;
  1052.              FREESPACE := R5;  B5 := R2;  goto FINISH;
  1053.           end;  R5 := DATAPTR(R6);  R0 := STOP;  while R5 > 0 do
  1054.           begin  R2 := SYMLINK(R5);  SYMLINK(R5) := R0;  R0 := R5;
  1055.              R5 := R2;
  1056.           end;  if R6 = DSTAKBOT then
  1057.           begin  R5 := R0;  R6 := R6 - 4S;
  1058.           end else
  1059.           begin  R6 := R6 - 4S;  R3 := DATAPTR(R6);
  1060.              R2 := SYMLINK(R3);  DATAPTR(R6) := R2;
  1061.              SYMLINK(R3) := R0;  R5 := R3;
  1062.              AAFIELD(R5/3) := #000000X;
  1063.           end;  PROCSTACK := R6;  CSECT;  R1 := R1 - R1;  SEARCH;
  1064.           while R5 > 0 do
  1065.           begin  IC(R1,ORFIELD(R5));  R1 := R1 and 15;
  1066.              R1 := @B1(3);  OUTSYM;
  1067.           end;
  1068.        end else
  1069.        begin  R6 := DATASTACK;  R5 := DATAPTR(R6);  R6 := R6 - 4S;
  1070.           DATASTACK := R6;  if R4 = 3S then
  1071.           begin  R6 := FREESPACE;  while R5 > 0 do
  1072.              begin  R2 := SYMLINK(R5);  SYMLINK(R5) := R6;
  1073.                 R6 := R5;  R5 := R2;
  1074.              end;  FREESPACE := R6;  goto FINISH;
  1075.           end;  if R5 = STOP then goto FINISH;
  1076.           R0 := STOP;  while R5 > 0 do
  1077.           begin  R2 := SYMLINK(R5);  SYMLINK(R5) := R0;  R0 := R5;
  1078.              R5 := R2;
  1079.           end;  R5 := R0;  CSECT;  R1 := R1 - R1;  SEARCH;
  1080.           while R5 > 0 do
  1081.           begin  IC(R1,ORFIELD(R5));  R3 := R1;  R1 := R1 and 15;
  1082.              REDUCE(R1);  CLI(#04,FFIELD(R5));  if = then
  1083.              begin  LDFIELD(R5+1/5) := MFIELD(R5);  R4 := 2;
  1084.              end else
  1085.              begin  LDFIELD(R5+1/4) := MFIELD(R5+1);  R4 := 1;
  1086.              end;  if R1 ^= 9S then
  1087.              begin  R2 := R5 + R1;  B2(11/6) := FFIELD(R5);
  1088.              end;  CLI(#C0,ORFIELD(R5));
  1089.              if >= then R1 := @B1(R4+8) else R1 := @B1(R4+5);
  1090.              OUTSYM;
  1091.           end;
  1092.        end; CARDOUT;
  1093.  FINISH:
  1094.        R7 := SAVE7;
  1095.     end;
  1096. $PAGE
  1097.        STM(R0,R7,SAVE07);  R4 := SEGTYPE(R5);
  1098.        if TESTFLAG then if RUNFLAG or GENDECK then
  1099.        begin SYMPRINT; LM(R0,R7,SAVE07); R4 := SEGTYPE(R5); end;
  1100. $END M
  1101.        if R4 >= 3S then goto FIN;  OUTPUTCARD;
  1102.     !-- LIST CURRENT SEGMENT --!
  1103.        WBUFF(0/133) := BLANK; SETZONE(CARRCONT);
  1104.        WBUF(27) := "SEGMENT";  R2 := PL360NO(R1);
  1105.        CVD(R2,CONWORK); UNPK(2,7,WBUF(35),CONWORK);
  1106.        SETZONE(WBUF(37));  WBUF(40) := "NAME =";
  1107.        R2 := R2 * 10S; R2 := @ESDNAME(R2); WBUF(47/10) := B2;
  1108.        R6 := 1;  if R5 = R9 and R4 = R6 then  !-- PROGRAM SEGMENT --!
  1109.        begin  R6 := NSEGNO;  R14 := R6 * 10S;  R14 := @ESDNAME(R14);
  1110.           while R14 > R2 and SEGNAM(0/4) ^= B14 do
  1111.           begin  REDUCE(R6);  R14 := R14 - 10S;
  1112.           end;  NSEGNO := R6;  !-- NEXT SEGMENT --!
  1113.        end;  WBUF(58) := "LENGTH =";  UNPK(4,4,WBUF(67),COUNTER(R5));
  1114.        TR(3,WBUF(67),TRTABLE(_240));  WBUF(71) := "  BASE REG =";
  1115.        R2 := SEGBASEREG(R5); CVD(R2,CONWORK);
  1116.        UNPK(1,7,WBUF(84),CONWORK); SETZONE(WBUF(85)); PRINT;
  1117.        if TM(4,TRACE); OFF then goto X;
  1118.        SETZONE(CARRCONT);  R7 := LASTINITIAL(R5);
  1119.        R5 := R5 + SEGHDLEN;  WBUFF(0/133) := BLANK;
  1120.        while R5 <= R7 do
  1121.        begin R4 := R4-R4; R6 := INITIALEN(R5);
  1122.           while R4 < R6 do
  1123.           begin R2 := R4 + INITIALSTART(R5); WORK := R2;
  1124.              MVI(239,DUMPLINE(8)); DUMPLINE(9/79) := DUMPLINE(8);
  1125.              UNPK(4,4,DUMPLINE,WORK); R3 := @B5(R4+4);
  1126.              TR(3,DUMPLINE,TRTABLE(_240));
  1127.              CLC(27,B3,B3(4)); if = then
  1128.              begin DUMPLINE(4) := " TO";
  1129.                 UNPK(8,4,DUMPLINE(18),B3); MVI(239,DUMPLINE(26));
  1130.  L1:            R4 := R4 + 32S; if R4 < R6 then
  1131.                 begin R3 := @B5(R4); CLC(31,B3,B3(4));
  1132.                    if = then goto L1;
  1133.                 end;
  1134.                 if R4 > R6 then R4 := R6;
  1135.                 R2 := R4 + INITIALSTART(R5) - 4; WORK := R2;
  1136.                 UNPK(4,4,DUMPLINE(8),WORK); MVI(239,DUMPLINE(12));
  1137.                 TR(79,DUMPLINE(8),DTRTABLE(_239));
  1138.                 PRINT; DUMPLINE(5/2) := DUMPLINE(4);
  1139.              end else
  1140.              begin DUMPLINE(4) := " ";  R0 := R6 - R4; R4 := @B4(32);
  1141.                 R2 := @DUMPLINE(8); if R0 >= 32S then
  1142.                 begin DUMPHALF; DUMPHALF;
  1143.                 end else
  1144.                 begin if R0 >= 16S then
  1145.                    begin R0 := R0 - 16S; DUMPHALF;
  1146.                    end;
  1147.                    while R0 >= 4 do
  1148.                    begin UNPK(8,4,B2,B3); MVI(239,B2(8));
  1149.                       R0 := R0 - 4; R2 := @B2(10); R3 := @B3(4);
  1150.                    end;
  1151.                    while R0 > 0 do
  1152.                    begin UNPK(2,1,B2,B3); R0 := R0 - 1S;
  1153.                       R2 := @B2(2); R3 := @B3(1);
  1154.                    end; MVI(239,B2);
  1155.                 end;
  1156.                 TR(79,DUMPLINE(8),DTRTABLE(_239)); PRINT;
  1157.              end;
  1158.           end;
  1159.           R5 := @B5(R6+5) and _2;
  1160.        end;
  1161.  X:    WBUFF(0/133) := BLANK; SETZONE(CARRCONT);
  1162.        if ^GENDECK then goto FIN;
  1163.     !-- PUNCH CURRENT SEGMENT AS CSECT --!
  1164.        LM(R0,R7,SAVE07); R2 := R0;
  1165.        if TM(1,TRACE); ON then
  1166.        begin WBUF(27) := "EXTERNAL SYMBOL DICTIONARY";  PRINT;
  1167.        end;
  1168.        R0 := R0-R0; ESDID := R0; R6 := @CARD; R7 := "  ";
  1169. $IFF M M
  1170.        SEQNO := R0;  !-- CLEAR SEQUENCE NUMBER --!
  1171. $END M
  1172. $IFT M M
  1173.        if ^TESTFLAG then SEQNO := R0;
  1174. $END M
  1175.                     !-- *** PUNCH ESD CARDS ***  --!
  1176.        CARD := "`BESD ";  CARD(5/75) := CARD(4);
  1177.        while R1 < R2 do
  1178.        begin
  1179.           if ESDTYPE(R1) ^= LD then    !-- LD HAS NO ESDID --!
  1180.           begin  R3 := ESDLINK(R1); if R3 >= 0 then
  1181.              begin  R3 := R3 + SAVE07(4); R3 := ESDLINK(R3);
  1182.              end else
  1183.              begin  R3 := 1 + ESDID; ESDID := R3;
  1184.              end;  ESDLINK(R1) := R3;
  1185.              if ESDTYPE(R1) ^= RLD and R7 = "  " then R7 := R3;
  1186.           end;
  1187.           if ESDTYPE(R1) ^= RLD then
  1188.           begin  R3 := PL360NO(R1)*10S; R3 := @ESDNAME(R3);
  1189.              B6(16/8) := B3; R3 := R3-R3; R4 := BLANK;
  1190.              if ESDTYPE(R1) = SD then
  1191.              begin   !-- CSECT --!
  1192.                 R3 := R3-R3; R4 := COUNTER(R5); goto X;
  1193.              end;
  1194.              if ESDTYPE(R1) = LD then
  1195.              begin   !-- ENTRY --!
  1196.                 R3 := RLDADDR(R1); R4 := 1; goto X;
  1197.              end;
  1198.              if ESDTYPE(R1) = ER then goto X;  !-- EXTRN --!
  1199.              if ESDTYPE(R1) = WER then goto X; !-- WEAK EXTRN --!
  1200.              if ESDTYPE(R1) = CM then
  1201.              begin  !-- COMMON --!
  1202.                 R3 := R3-R3; R4 := COUNTER(R5); goto X;
  1203.              end;
  1204.              if ESDTYPE(R1) = XCM then
  1205.              begin  !-- XCOMMON (EXTERNAL BLANK COMMON) --!
  1206.                 R3 := R3-R3; R4 := R4-R4; goto X;
  1207.              end;
  1208.  X:          STM(R3,R4,B6(24));
  1209.              if ESDTYPE(R1) = XCM then C6(24) := CM
  1210.                                   else C6(24) := ESDTYPE(R1);
  1211.              C6(28) := " ";  if TM(1,TRACE); ON  or
  1212.                 C6(24) ^= ER then ESDPRINT;
  1213.              R0 := R0 + 16S; R6 := R6 + 16S;
  1214.              if R0 = 48S then
  1215.              begin  CARD(14) := R7; CARDOUT; R7 := "  ";
  1216.              end;
  1217.           end;
  1218.           R1 := R1 + 8S;
  1219.        end;
  1220.        CARD(14) := R7; CARDOUT;
  1221.                     !--  *** PUNCH TXT CARDS ***  --!
  1222.        CARD := "`BTXT ";  CARD(5/75) := CARD(4);
  1223.        R7 := LASTINITIAL(R5); R5 := R5 + SEGHDLEN;
  1224.        while R5 <= R7 do
  1225.        begin  R1 := INITIALSTART(R5); R2 := INITIALEN(R5);
  1226.           R4 := 5 + R5 + R2 and _2;  R0 := 56;
  1227.           while R2 >= R0 do
  1228.           begin  CARD(14/2) := 1S; CARDI(4) := R1; CARD(4) := " ";
  1229.              CARD(16/56) := B5(4); CARDOUT; R0 := 56;
  1230.              R5 := R5 + R0; R1 := R1 + R0; R2 := R2 - R0;
  1231.           end;
  1232.           if R2 > 0 then
  1233.           begin
  1234.              R0 := R2; R2 := R2 - 1S;
  1235.              CARD(14/2) := 1S; CARDI(4) := R1; CARD(4) := " ";
  1236.              EX(R2,MVC(0,CARD(16),B5(4))); CARDOUT;
  1237.           end;
  1238.           R5 := R4;
  1239.        end;
  1240.                     !-- *** PUNCH RLD CARDS ***  --!
  1241.        CARD := "`BRLD ";  CARD(5/75) := CARD(4);
  1242.        LM(R0,R1,SAVE07); R2 := R0; R0 := R0-R0; R6 := @CARD;
  1243.        while R1 < R2 do
  1244.        begin
  1245.           R4 := RLDADDR(R1); if ESDTYPE(R1) ^= LD and R4 >= 0 then
  1246.           begin  if R0 = 56S then CARDOUT;
  1247.              R3 := ESDLINK(R1);  H6(16) := R3;  H6(18) := 1S;
  1248.              B6(20) := R4;  C6(20) := RLDFLAG(R1);
  1249.              R6 := R6 + 8S; R0 := R0 + 8S;
  1250.           end;
  1251.           R1 := R1 + 8S;
  1252.        end;
  1253.        CARDOUT;
  1254.                     !--  *** PUNCH END CARD ***  --!
  1255.        CARD := "`BEND ";  CARD(5/75) := CARD(4);
  1256.        R1 := SAVE07(4); R1 := PL360NO(R1); if R1 = 1S then
  1257.        begin  CARD(5/3) := 0; CARD(14/2) := 1S;
  1258. $IFT
  1259.        end; CARD(39/6) := HEADER(1); CARD(45/16) := HEADER(94);
  1260. $END
  1261. $IFF
  1262.        end; if OSSYSTEM then CARD(32/39) := IDRDATA else
  1263.        begin CARD(39/6) := HEADER(1); CARD(45/16) := HEADER(94);
  1264.        end;
  1265. $END
  1266.        PUNCHSEQ;  SETZONE(CARRCONT);
  1267.        WBUFF(0/133) := BLANK;
  1268. FIN:
  1269.        LM(R0,R7,SAVE07);
  1270.     end;
  1271. $PAGE
  1272.  procedure OPENPROCSEG(R4);
  1273.     begin  !-- OPEN A NEW PROCEDURE SEGMENT --!
  1274.     !--  T(R7) = TYPE OF PROCEDURE SEGMENT --!
  1275.     !--  V(R7) = NAMETABLE ENTRY ADDRESS --!
  1276.     !- V(R7+4) = RETURN REGISTER FOR PROCEDURE --!
  1277.        integer SAVE; SAVE := R4; INCRSEGNO;
  1278.        R0 := LC; R1 := LASTINITIAL(R9); INITIALEN(R1) := R0;
  1279.        R0 := PROGESDEND; R1 := PROGESDADR; R5 := R9; STACKSEG;
  1280.        R9 := R5; R2 := T(R7); R3 := PROGREG; OPENSEG;
  1281.        R0 := R1; R2 := SD; R3 := VTYPE; R4 := SEGNO;
  1282.        FINDESDENTRY; PROGESDEND := R0; R2 := 14 + N3;
  1283.        R0 := N4; N4 := R2; N3 := R2; R2 := R2 + LABELBASE;
  1284.        B2(0/12) := ZERO; LABELADR(R2) := R0;
  1285.        R0 := LITX; LABEL(R2+2) := R0;
  1286.        R0 := CSEGNO; LABEL(R2+8) := R0; CSEGNO := R4;
  1287.        R0 := N6; R1 := 4 + N5 =: N5 =: N6 + BRANCHBASE;
  1288.        BRANCHADR(R1) := R0;
  1289.        R4 := SAVE;
  1290.     end;
  1291.  
  1292.  procedure DATASEGERROR(R4);
  1293.     begin  !-- NO DATA SEGMENT FOR DECLARED VARIABLE -- OPEN DUMMY --!
  1294.        integer SAVER4; SAVER4 := R4;
  1295.        XR := 29; ERROR; RESET(NODATASEG); INCRSEGNO; R1 := DATAESDADR;
  1296.        R2 := 4; R3 := 13; R5 := R10; OPENSEG; R0 := R1;
  1297.        R2 := SD; R3 := ATYPE; R4 := SEGNO; FINDESDENTRY;
  1298.        DATAESDEND := R0; R4 := SAVER4;
  1299.     end;
  1300.  
  1301. $IFF
  1302. $PAGE
  1303.    procedure ENTEREF (R1);
  1304.    begin  array 6 integer SAVE;  STM(R0,R5,SAVE);
  1305.       if VALUE(3) = " " and VALUE(1) >= "0" then
  1306.       if VALUE(2) = " " or  VALUE(2) >= "0" then
  1307.       if VALUE = "R" or VALUE = "B"
  1308.       or VALUE = "C" or VALUE = "H" then goto Y;
  1309.       R3 := 1 + SYMTYPE and #E;
  1310.       R5 := R5-R5;  IC(R5,VALUE);
  1311.       IC(R5,ALPHASH(R5-193));
  1312.       R5 := R5 + LENHASH(R3-2);  R3 := R3 - 1;
  1313.       R4 := REFCHAIN(R5);  while R4 >= 0 do
  1314.       begin  R4 := R4 + REFSTART;
  1315.          EX(R3,CLC(0,REFNAME(R4),VALUE));
  1316.          if = then goto X;
  1317.          R4 := LINKN(R4);
  1318.       end;  R1 := REFLEN + REFN1;  if R1 > REFN2 then
  1319.       begin  SET(REFOUT);  goto Y;
  1320.       end;  R4 := REFN1 + REFSTART;  REFNAME(R4/10) := VALUE;
  1321.       R2 := REFN2;  LINKF(R4) := R2;  LINKL(R4) := R2;
  1322.       R0 := REFCHAIN(R5);  LINKN(R4) := R0;
  1323.       R0 := REFN1;  REFCHAIN(R5) := R0;  REFN1 := R1;
  1324.  X:   R0 := CARDCOUNT;  LASTCARD := R0;
  1325.       R0 := REFN2;  R1 := REFSTART;  R2 := LINKL(R4) + R1;
  1326.       LINKL(R4) := R0;  R4 := REFLINK(R2) or R0;
  1327.       REFLINK(R2) := R4;  !-- ENDCHAIN IS 0 IN BITS 14-31 --!
  1328.       R1 := R1+R0; R2 := CARDCOUNT shll 18; REFLINK(R1) := R2;
  1329.       R0 := R0 - 4;  if R0 < REFN1 then SET(REFOUT)
  1330.                                    else REFN2 := R0;
  1331.  Y:   LM(R0,R5,SAVE);
  1332.    end;
  1333. $PAGE
  1334.    procedure PRINTREFS(R1);
  1335.    begin array 10 integer SAVE;  STM(R0,R9,SAVE);
  1336.       OUTPUTCARD;  R1 := REFN1;  if R1 ^= 0 then
  1337.       begin  R8 := R1;
  1338.          R7 := REFLEN;  R9 := REFSTART - R7;
  1339.     X1:  R0 := R0-R0; R1 := R1 / R7 shrl 1 * R7;
  1340.          if R1 = 0 then goto X5;
  1341.          R2 := R8 - R1;
  1342.          R3 := R7;
  1343.     X2:  R4 := R3;
  1344.     X3:  R5 := R9 + R4;
  1345.          R6 := R5 + R1;
  1346.          CLC(9,REFNAME(R5),REFNAME(R6));
  1347.          if <= then goto X4;
  1348.          XC(REFMOV,LINKF(R6),LINKF(R5));
  1349.          XC(REFMOV,LINKF(R5),LINKF(R6));
  1350.          XC(REFMOV,LINKF(R6),LINKF(R5));
  1351.          if R4 <= R1 then goto X4;
  1352.          R4 := R4 - R1;  goto X3;
  1353.     X4:  if R2 = R3 then goto X1;
  1354.          R3 := R3 + R7;  goto X2;
  1355.     X5:  HEADER(8) := "ROSS REFERENCE";
  1356.          SUBHEAD(1/132) := SUBHEAD;  CARRCONT := "1";
  1357.          if REFOUT then  !-- XREF TABLE FULL --!
  1358.          begin  WBUFF(0/133) := BLANK;  R1 := LASTCARD;
  1359.             WBUF := "DECLARATIONS AND REFERENCES THROUGH LINE";
  1360.             CVD(R1,CONWORK);  UNPK(3,7,WBUF(41),CONWORK);
  1361.             SETZONE(WBUF(44));  PRINT;  CARRCONT := "0";
  1362.          end;  WBUFF(0/133) := BLANK;  WBUF(17) := "SYMBOLS,";
  1363.          R8 := #3FFFF;  R1 := REFN1 shrl 1;  CVD(R1,CONWORK);
  1364.          WBUF(12) := "`0`0`1`0";  ED(4,WBUF(11),CONWORK(5));
  1365.          WBUF(33) := "REFERENCES";  R1 := REFN3--REFN2 shrl 2 * 10S;
  1366.          CVD(R1,CONWORK);  WBUF(26) := "`0`0`0`0`1`0";
  1367.          ED(6,WBUF(25),CONWORK(4));  PRINT;  CARRCONT := "0";
  1368.          R9 := REFSTART;  R7 := R7-R7;  while R7 < REFN1 do
  1369.          begin  WBUFF(0/133) := BLANK; OC(0,CARRCONT,XREFCC);
  1370.             R4 := R7 + R9;  WBUF(0/10) := REFNAME(R4);
  1371.             R4 := LINKF(R4);
  1372.          X: R6 := R6-R6;  R5 := @WBUF(12);
  1373.             while R6 < 108S and R4 ^= 0 do
  1374.             begin  R4 := R4 + R9;  R4 := REFLINK(R4);
  1375.                R3 := R4 shrl 18;  R4 := R4 and R8;
  1376. $IFT M M
  1377.                CVD(R3,CONWORK); B5(0/6) := EDMSK;
  1378.                ED(5,B5,CONWORK(5)); R6 := @B6(6); R5 := @B5(6);
  1379. $END M
  1380. $IFF M M
  1381.                CVD(R3,CONWORK);  UNPK(3,7,B5,CONWORK);
  1382.                SETZONE(B5(3));   R6 := @B6(6);  R5 := @B5(6);
  1383. $END M
  1384.             end;  if R6 ^= 0 then
  1385.             begin  PRINT;  WBUFF(0/133) := BLANK;  goto X;
  1386.             end;  R7 := @B7(REFLEN);
  1387.          end;
  1388.       end;  HEADER(8) := "OMPILATION    ";
  1389.       LM(R0,R9,SAVE);
  1390.    end;
  1391.  
  1392. $END
  1393. $PAGE
  1394.   segment procedure  INSYMBOL(R8);  !-- USES R0 THRU R6 AND R8 --!
  1395.     begin  !-- DEFINE PROCEDURES USED ONLY BY INSYMBOL --!
  1396.  
  1397.     segment procedure GETCARD(R4);
  1398.     begin logical SAVE14;   !-- READ NEXT CARD AND CHECK OPTIONS --!
  1399.  
  1400.        procedure GETPARM (R14);
  1401.           begin SAVE14:=R14; IC(R0,CBUF(7));
  1402.              R0:=R0 and #F; CLI(" ",CBUF(8)); if ^= then
  1403.              begin IC(R14,CBUF(8)); R14:=R14 and #F;
  1404.                 R0:=R0*10S+R14;
  1405.              end; R14:=SAVE14;
  1406.           end;
  1407.  
  1408.        procedure PRNTDOLR (R14); if LISTFLAG then
  1409. $IFT M M
  1410.           if TM(DOLR,FLGS); ON then
  1411. $END M
  1412. $IFF M M
  1413.           if TM(DOLR,FLGS); OFF then WDDISP(5/6) := CBUF else
  1414. $END M
  1415.           begin SAVE14 := R14;  WBUFF(0/WHDRLN+3) := BLANK;
  1416.              WCARD(0/72) := CBUF; WSEQ(0/8) := CBUF(72);
  1417. $IFT M M
  1418.              WLINENUM(0/10) := CBUF(80);
  1419. $END M
  1420.              PRINT;  R14 := SAVE14;
  1421.           end;
  1422.  
  1423.           OUTPUTCARD; R0:=BEGENDLVL; CBEGENDLVL:=R0;
  1424.  TOP:     R0 := @CBUF; READ; if ^= then
  1425.           begin if ^NOPROGSEG then
  1426.              begin R6 := R6-R6; XR := 20; ERROR;
  1427.              end;  ERROREXIT;
  1428.           end; CLI("$",CBUF); if = then
  1429.           begin CLI("0",CBUF(1)); if >= then
  1430.              begin  TRACE(0/1) := CBUF(1);  NI(7,TRACE);
  1431.                 TR(0,TRACE,#0001030704050602X);  goto PDC;
  1432.              end; CLI("#",CBUF(4)); if = then
  1433.              begin if NOPROGSEG then
  1434.                 begin SEGNAM(0/3) := CBUF(1);  ESDNAME(0/3) := SEGNAM;
  1435.                    ESDNAME(10/3) := SEGNAM;  goto PDC;
  1436.                 end;  goto DOLERR;
  1437.              end; R0 := CBUF; if R0 = "$NOL" then
  1438.              begin PRNTDOLR; R0 := 1+LIST; LIST := R0; goto TOP;
  1439. $IFT M M
  1440.              end;  if R0 = "$TES" then
  1441.              begin  R0 := R0 - R0;
  1442.                 if R0 ^= FREESPACE then SET(TESTFLAG);
  1443.                 goto PDC;
  1444. $END M
  1445.              end;  if CBUF(1) = "IF" then   !-- $IF-STATEMENT --!
  1446.              if CBUF(3) = "T" or CBUF(3) = "F" or CBUF(3) = "J" then
  1447.              begin PRNTDOLR; NI(#3F,CBUF(5)); R14 := R14-R14;
  1448.                 IC(R14,CBUF(5));  CLI("J",CBUF(3));
  1449.                 if = then goto L;  IC(R14,CONDTAB(R14));
  1450.                 STC(R14,CONDCK); CLI("F",CBUF(3));
  1451.                 if = then XI(#FF,CONDCK);
  1452.                 if CONDCK then goto TOP;
  1453.                 NI(#3F,CBUF(7));  IC(R14,CBUF(7));
  1454.             L:  STC(R14,CONDCK);
  1455.             COND: R0 := @CBUF; READ; if ^= then
  1456.                 begin if ^NOPROGSEG then
  1457.                    begin R6 := R6-R6; XR := 20; ERROR;
  1458.                    end;  ERROREXIT;
  1459.                 end; CLC(3,CBUF,"$END"); if ^= then goto COND;
  1460.                 IC(R0,CBUF(5)); NI(#3F,CBUF(5)); CLC(0,CBUF(5),CONDCK);
  1461.                 if ^= then goto COND;  STC(R0,CBUF(5));  goto PDC;
  1462.              end; if R0 = "$TIT" then
  1463.              begin if LISTFLAG then CARRCONT := "1";
  1464.                 HEADER(30/63) := CBUF(9);
  1465.                 SUBHEAD(1/93) := SUBHEAD;  goto TOP;
  1466.              end; if R0 = "$STI" then
  1467.              begin  if LISTFLAG then CARRCONT := "1";
  1468.                 SUBHEAD(30/63) := CBUF(9); goto TOP;
  1469.              end; if R0 = "$PAG" then
  1470.              begin  R0 := "$EJE"; CBUF(0/2) := CBUF(6);
  1471.                 CBUF(7/2) := CBUF;
  1472.              end; if R0 = "$EJE" then
  1473.              begin GETPARM; if R0 = 0 then R0 := 1000;
  1474.                 R0 := R0 + LINECOUNT; if R0 > MAXLINE and LISTFLAG then
  1475.                 CARRCONT := "1"; goto TOP;
  1476.              end; if R0 = "$SPA" and LISTFLAG and LINECOUNT<MAXLINE then
  1477.              begin  logical SAVE0;  GETPARM;
  1478.                 if R0 = 0 then R0 := 1;
  1479.              !-- R0 HAS NUMBER OF LINES TO SPACE --!
  1480.                 WBUFF(0/133) := BLANK; CLI(" ",CARRCONT);
  1481.                 if ^= then
  1482.                 begin SAVE0 := R0; PRINT; R0 := SAVE0 - 1;
  1483.                 end; R14 := MAXLINE - LINECOUNT;
  1484.                 if R0 >= R14 then CARRCONT := "1" else
  1485.                 begin  while R0 > 1 do
  1486.                    begin  SAVE0 := R0; CARRCONT := "0"; PRINT;
  1487.                       R0 := SAVE0 - 2;
  1488.                    end;  if R0 = 0 then CARRCONT := " "
  1489.                                    else CARRCONT := "0";
  1490.                 end;  goto TOP;
  1491. $IFF
  1492.              end; if R0="$XRE" then
  1493.              begin R0 := R0-R0; if R0 ^= REFSTART then SET(XREF);
  1494.                 if CBUF(6) = "1" then XREFCC := " " else
  1495.                    if CBUF(6) = "2" then XREFCC := "0";
  1496.                 goto PDC;
  1497.              end; if R0 = "$NOX" then
  1498.              begin RESET(XREF); goto PDC;
  1499.              end; if R0 = "$COP" then
  1500.              begin  external procedure COPY (R14);  null;
  1501.                 R0 := @CBUF(6);  COPY;  goto PDC;
  1502. $END
  1503.              end; if R0 = "$SET" or R0 = "$RES" then
  1504.              begin R14 := R14-R14;  R0 := #FF;
  1505.                 CLI("R",CBUF(1));  if = then
  1506.                 begin IC(R14,CBUF(7));  R0 := R0-R0;
  1507.                 end else IC(R14,CBUF(5));
  1508.                 R14 := R14 and #3F;
  1509.                 STC(R0,CONDTAB(R14)); goto PDC;
  1510.              end; if R0 = "$ON " then
  1511.              begin SB(DOLR,FLGS);  goto PDC;
  1512.              end; if R0 = "$OFF" then
  1513.              begin PRNTDOLR; RB(DOLR,FLGS); goto TOP;
  1514.              end; if R0 = "$GEN" then
  1515.              begin RESET(GENFLAG);  goto PDC;
  1516.              end; if R0 = "$OPT" then
  1517.              begin SB(#80,OPTFLAG);  goto PDC;
  1518.              end; if R0 = "$NOO" or R0 = "$NOP" then
  1519.              begin RB(#80,OPTFLAG);  goto PDC;
  1520.              end; if R0 = "$DBG" then
  1521.              begin DBGFLGS(0/1) := CBUF(5) and 7; goto PDC;
  1522.              end; if R0 = "$LIS" then
  1523.              begin R0 := LIST-1; LIST := R0; goto PDC;
  1524.              end; if R0 = "$OS " then
  1525.              begin SET(OSSYSTEM);  goto PDC;
  1526.              end; if R0 = "$DOS" then
  1527.              begin RESET(OSSYSTEM);  goto PDC;
  1528.              end; if R0 = "$BOL" then
  1529.              begin  OVER := #80;  goto PDC;
  1530.              end; if R0 = "$UND" then
  1531.              begin  OVER := #C0;  goto PDC;
  1532.              end; if R0 = "$NOU" or R0 = "$NOB" then
  1533.              begin  RESET(OVER);  goto PDC;
  1534.              end; if R0 = "$NOG" then
  1535.              begin SB(NOGO,FLGS); goto PDC;
  1536.              end; if R0 = "$ASC" then
  1537.              begin SB(ASCI,FLGS); goto PDC;
  1538.              end; if R0 = "$BAS" then
  1539.              begin  R14 := CARDCOUNT;  if R14 = 0 then
  1540.                 begin PACK(7,1,CONWORK,CBUF(6));
  1541.                    OI(#0C,CONWORK(7));  CVB(R0,CONWORK);
  1542.                    if R0 ^= 0 and R0 <= 15 then
  1543.                    begin PROGREG := R0; R0 := R0 shll 12;
  1544.                       PTAG := R0;  goto PDC;
  1545.                    end;
  1546.                 end;  goto DOLERR;
  1547.              end;
  1548.     PDC:     PRNTDOLR; goto TOP;
  1549.     DOLERR:  WBUFF(0/WHDRLN+3) := BLANK;  WCARD(0/72) := CBUF;
  1550.              WSEQ(0/8) := CBUF(72);  WBUF(2) := "ILLEGAL $CARD";
  1551.              R0 := 1 + ERRCOUNT =: ERRCOUNT;  RESET(RUNFLAG);
  1552.              PRINT;  goto TOP;
  1553.           end;  R6 := R6-R6;  if BEGENDFLAG then
  1554.           begin  R0:=CBEGENDLVL;  CVD(R0,CONWORK);
  1555.              UNPK(1,7,WBGNEND,CONWORK);
  1556.              SETZONE(WBGNEND(1)); RESET(BEGENDFLAG);
  1557.           end else WBGNEND := "  ";  PRNT := LISTFLAG;
  1558.           R1 := DATAESDADR; R1 := PL360NO(R1);
  1559.           CVD(R1,CONWORK); UNPK(2,7,WDSEG,CONWORK);
  1560.           UNPK(4,4,WDDISP,DC); TR(3,WDDISP,TRTABLE(_240));
  1561.           SETZONE(WDSEG(2));  WDDISP(4) := " ";
  1562.           R0 := CSEGNO; CVD(R0,CONWORK); UNPK(2,7,WPSEG,CONWORK);
  1563.           UNPK(4,4,WPDISP,LC); TR(3,WPDISP,TRTABLE(_240));
  1564.           SETZONE(WPSEG(2));  WPDISP(4) := " ";
  1565.           R1 := 1 + CARDCOUNT; CARDCOUNT := R1; CVD(R1,CONWORK);
  1566. $IFT M M
  1567.           WCRDCNT(0/6) := EDMSK;  ED(5,WCRDCNT,CONWORK(5));
  1568.           ERRWCRDCNT(0/6) := WCRDCNT;  ERRORBUF(0/10) := CBUF(80);
  1569. $END M
  1570. $IFF M M
  1571.           UNPK(3,7,WCRDCNT,CONWORK);  SETZONE(WCRDCNT(3));
  1572.           R1 := 10 * R0;  R1 := @ESDNAME(R1);  SUBHEAD(113/8) := B1;
  1573. $END M
  1574.           if TM(#80,OVER); ON then  !-- ESTABLISH OVERPRNT BUFFER --!
  1575.           begin  RESET(OBUF);  OBUF(1/71) := OBUF;
  1576.           end;
  1577.     end;
  1578.  
  1579.     procedure NEXTCHAR(R4);
  1580.     begin R6 := @B6(1); if R6 > 71S then
  1581.        begin array 4 integer SAVER1R4;
  1582.           STM(R1,R4,SAVER1R4); GETCARD; LM(R1,R4,SAVER1R4);
  1583.        end;
  1584.        R0 := R0-R0; IC(R0,CBUF(R6));
  1585.     end;
  1586.  
  1587.     !-- BEGIN INSYMBOL --!
  1588.  TOP:  R2 := 71 - R6; R1 := @CBUF(R6); EX(R2,TRT(0,B1,SCANTAB2));
  1589.        if = then
  1590.        begin GETCARD; goto TOP;
  1591.        end;
  1592.        R0 := @CBUF; R6 := R1 - R0; R0 := R0-R0; IC(R0,CBUF(R6));
  1593.        VALUE(0/12) := BLANK;
  1594.        if R2 < 10S then
  1595.        case R2 of begin  !-- R2 HAS CODE FOR TYPE OF SYMBOL --!
  1596.  
  1597.        begin  !-- CODE 1 -- READ A NUMBER --!
  1598.           procedure ACCUM (R4);  !-- ACCUMULATE A DIGIT --!
  1599.           begin logical SAVE4; SAVE4 := R4;
  1600.              if R2 >= 214748364 then R1 := R1 + 1 else
  1601.              begin R0 := R0 and #F; R4 := R2; R5 := R3;
  1602.                 SLDL (R4, 1); SLDL (R2, 3); R2 := R2 + R4;
  1603.                 R3 := R3 ++ R5; if > or OVERFLOW then R2 := R2 + 1;
  1604.                 R3 := R3 ++ R0; if > or OVERFLOW then R2 := R2 + 1;
  1605.              end; NEXTCHAR; R4 := SAVE4;
  1606.           end;
  1607.           XC (7, VALUEF, VALUEF);  !-- CLEAR IN CASE INTEGER --!
  1608.           RESET (SIGN); if R0 = "_" then
  1609.           begin SET (SIGN); NEXTCHAR; if R0 < "0" or R0 > "9" then
  1610.              begin XR := 0; ERROR; goto TOP; end; end;
  1611.           TYPEFLAG := 1; R2 := R2 - R2; R3 := R0 and #F; NEXTCHAR;
  1612.           R1 := R2; while R0 >= "0" and R0 <= "9" do ACCUM;
  1613.        !-- WE ARE OVER THE INITIAL STRING OF DIGITS --!
  1614.           if R0 = "." then
  1615.           begin  !-- A DECIMAL POINT HAS BEEN FOUND --!
  1616.              TYPEFLAG := 3; NEXTCHAR;
  1617.              while R0 >= "0" and R0 <= "9" do
  1618.              begin R1 := R1 - 1; ACCUM; end;
  1619.           end;  !-- END OF DECIMAL POINT PROCESSING --!
  1620.           if R0 = "'" then  !-- IS THERE AN EXPONENT? --!
  1621.           begin NEXTCHAR; RESET (EXPOSIGN); TYPEFLAG := 3;
  1622.              if R0 = "_" then begin SET (EXPOSIGN); NEXTCHAR; end;
  1623.              if R0 < "0" or R0 > "9" then begin XR := 14; ERROR; end;
  1624.              R5 := R5 - R5; while R0 >= "0" and R0 <= "9" do
  1625.              begin R0 := R0 and #F; if R5 < 214748364 then
  1626.                 R5 := R5 * 10S + R0; NEXTCHAR; end;
  1627.              if EXPOSIGN then R1 := R1 - R5 else R1 := R1 + R5;
  1628.           end;  !-- CORRECT EXPONENT NOW IN R1 --!
  1629.           R5 := #40 or R0;  !-- Force upper case --!
  1630.           if TYPEFLAG = 1 and R5 = "S" then
  1631.           begin TYPEFLAG := 0; NEXTCHAR;
  1632.           end else if TYPEFLAG = 1 and R5 = "X" then
  1633.           begin TYPEFLAG := 4; NEXTCHAR;
  1634.           end else if R5 = "L" then
  1635.           begin TYPEFLAG := 2; NEXTCHAR;
  1636.           end else if R5 = "R" then
  1637.           begin TYPEFLAG := 3; NEXTCHAR;
  1638.           end; XR := 19;  !-- ONLY OVERFLOWS POSSIBLE NOW --!
  1639.           if TYPEFLAG ^= 2 and TYPEFLAG ^= 3 then  !-- INTEGER CASE --!
  1640.           begin if R2 ^= 0 then ERROR
  1641.              else if R3 < 0 then if ^SIGN then ERROR
  1642.              else if R3 ^= #80000000 then ERROR;
  1643.              if SIGN then R3 := neg R3;
  1644.              if TYPEFLAG = 0 then
  1645.              begin if R3 > 32767S or R3 < _32768S then
  1646.                 begin ERROR; R3 := R3 shll 16 shra 16; end;
  1647.              end else if TYPEFLAG = 4 then
  1648.              begin if R3 < 0 or R3 > 255S then
  1649.                 begin ERROR; R3 := R3 and #000000FF; end;
  1650.              end;
  1651.              VALUE := R3;
  1652.           end else
  1653.           begin  !-- REAL OR LONG REAL --!
  1654.              long real FIRST = #5600000000000000L,
  1655.                        SECOND = #4E00000000000000L;
  1656.              integer LEFT syn FIRST (4), RIGHT syn SECOND (4);
  1657.              long real FACT syn B4;
  1658.              long real TEN = 10L, MILLION = 1000000L;
  1659.              byte SCALED syn EXPOSIGN;
  1660.              long real X syn VALUEF;
  1661.           procedure SCALEUP (R5);
  1662.           begin R15 := R15 or #FF000000; DRAIN; F45 := F45 - F45;
  1663.              F4 := neg F0; F45 := F45 + F01; F23 := F23 + F45;
  1664.              F01 := F01 - F45 * FACT; F23 := F23 * FACT; DRAIN;
  1665.              if R15 > 0 then  !-- SET BY PROGCHECK ROUTINE --!
  1666.              begin R1 := R1 - R1; F01 := #7FFFFFFFFFFFFFFFL;
  1667.                 F23 := F23 - F23; ERROR;
  1668.              end;  R15 := R15 and #00FFFFFF;
  1669.           end;
  1670.           procedure SCALEDOWN (R5);
  1671.           if F01 = 0L and F23 = F01 then
  1672.           R1 := R1 - R1   !-- UNDERFLOW --!  else
  1673.           begin X := F01; F01 := F01 / FACT; F67 := F67 - F67;
  1674.              F6 := F0; F45 := neg F67 + F01 * FACT;
  1675.              F67 := F67 * FACT - X + F45;
  1676.              F23 := F23 - F67 / FACT;
  1677.           end;
  1678.              LEFT := R2; F01 := FIRST + 0L; RIGHT := R3;
  1679.              F23 := SECOND + 0L; F45 := F01; F01 := F01 + F23;
  1680.              if ^= then  !-- NOT ZERO --!
  1681.              begin F45 := F45 - F01; F23 := F23 + F45; RESET (SCALED);
  1682.                 if R1 < 0 then begin SET (SCALED);
  1683.                    F01 := F01 / #3310000000000000L;
  1684.                    F23 := F23 / #3310000000000000L;
  1685.                 end; R4 := @MILLION;  !-- SCALE UP BY 10**6 --!
  1686.                 while R1 >= 6 do begin R1 := R1 - 6; SCALEUP; end;
  1687.                 R4 := @TEN;  !-- SCALE UP BY 10 --!
  1688.                 while R1 >= 1 do begin R1 := R1 - 1; SCALEUP; end;
  1689.                 R4 := @MILLION;  !-- SCALE DOWN BY 10**6 --!
  1690.                 while R1 <= _6 do begin R1 := R1 + 6; SCALEDOWN; end;
  1691.                 R4 := @TEN;  !-- SCALE DOWN BY 10 --!
  1692.                 while R1 <= _1 do begin R1 := R1 + 1; SCALEDOWN; end;
  1693.                  !-- NOW ROUND TO LONG REAL --!
  1694.                 F45 := neg F01 - F23; F01 := F01 + F45 + F23;
  1695.                 F0 := F0 + F0; F01 := F01 - F45;
  1696.                 if SCALED then F01 := F01 / #4F10000000000000L;
  1697.                 if F01 = 0L then ERROR;  !-- UNDERFLOW --!
  1698.              end;
  1699.              VALUEF := F01;  !-- STORE LONG REAL VALUE --!
  1700.              if TYPEFLAG = 3 then  !-- ROUND TO REAL --!
  1701.              if F01 >= #7FFFFFFF80000000L then
  1702.              begin ERROR;  VALUEF(0/8) := #7FFFFFFF00000000L;
  1703.              end else
  1704.              begin XC (2, VALUEF (1), VALUEF (1));
  1705.                 F01 := F01 + VALUEF; VALUEF := F01;
  1706.                 XC (3, VALUEF (4), VALUEF (4));
  1707.              end;  !-- END OF ROUNDING ROUTINE --!
  1708.              if SIGN then OI (#80, VALUEF);
  1709.           end;
  1710.           R5 := NUMBERSYMBOL;
  1711.        end;
  1712.  
  1713.        begin  !-- CODE 2 -- READ AN IDENTIFIER --!
  1714.           R3 := @OBUF(R6);  !-- ID START FOR OVERPRNT --!
  1715.           R2-R2; while R0>="a" or R0="_" or R0="$" or R0="#" do
  1716.           begin if R2 < 10S then  !-- Allows certain nationals --!
  1717.              begin  R1 := #40 or R0;  STC(R1,VALUE(R2));  R2 := @B2(1);
  1718.              end;  if R6 = 71S then
  1719.              begin  R6 := @B6(1);  R0 := " ";
  1720.              end else NEXTCHAR;
  1721.           end;
  1722.           SYMTYPE := R2;
  1723.           if R2 < 10S then case R2 of
  1724.           begin  !-- CHECK FOR RESERVED WORDS OF LENGTH R2 --!
  1725.              begin  !-- NO TERMINALS OF LENGTH ONE --!
  1726.              end;
  1727.              begin R1 := IVALUE; for R5 := R5--R5 step 2S until 6S do
  1728.                 if R1 = WORD2(R5) then
  1729.                 begin  B3(0/2) := OMSK;
  1730.                    R5 := R5 shrl 1 + FT2; goto Y;
  1731.                 end;  !-- TERMINALS OF LENGTH TWO --!
  1732.              end;
  1733.              begin R1 := VALUE; for R5 := R5-R5 step 4S until 16S do
  1734.                 if R1 = WORD3(R5) then
  1735.                 begin  B3(0/3) := OMSK;
  1736.                    R5:=R5 shrl 2 + FT3; R2:=ENDSYMBOL-R5; if = then
  1737.                    begin SET(BEGENDFLAG);R2:=BEGENDLVL-1; BEGENDLVL:=R2;
  1738. $IFT M M
  1739.                    if TESTFLAG then
  1740.                    begin  R0 := LC;
  1741.                       R4 := R8;  R1 := 4;
  1742.                       ENTERSYMLABEL;  R8 := R4;
  1743.                    end;
  1744. $END M
  1745.                    end; goto Y;
  1746.                 end;  !-- TERMINALS OF LENGTH THREE --!
  1747.              end;
  1748.              begin R1 := VALUE; for R5 := R5-R5 step 4 until 40 do
  1749.                 if R1 = WORD4(R5) then
  1750.                 begin  B3(0/4) := OMSK;
  1751.                    R5 := R5 shrl 2 + FT4; goto Y;
  1752.                 end; for R5 := R5-R5 step 4 until 12 do
  1753.                 if R1 = SHIFTWORD(R5) then
  1754.                 begin  B3(0/4) := OMSK;
  1755.                    R5 := R5 shrl 2 + 8S; VALUE := R5;
  1756.                    R5 := SHIFTOP; goto Y;
  1757.                 end;  !-- TERMINALS OF LENGTH FOUR --!
  1758.              end;
  1759.              begin R1 := @WORD5; R2 := @WORD6; R5 := R1;
  1760.                 while R5 < R2 do
  1761.                 begin  if VALUE(0/5) = B5 then
  1762.                    begin  B3(0/5) := OMSK; R5:=R5-R1 shrl 3 + FT5;
  1763.                       R2:=BEGINSYMBOL; if R5 ^= R2 then goto Y;
  1764.                       SET(BEGENDFLAG); R2:=1+BEGENDLVL; BEGENDLVL:=R2;
  1765. $IFT M M
  1766.                       if TESTFLAG then
  1767.                       begin  R0 := LC;  R1 := 2;  R4 := R8;
  1768.                          ENTERSYMLABEL;  R8 := R4;
  1769.                       end;
  1770. $END M
  1771.                       goto Y;
  1772.                    end;  R5 := @B5(8);
  1773.                 end;  !-- TERMINALS OF LENGTH FIVE --!
  1774.              end;
  1775.              begin R1 := @WORD6; R2 := @WORD7; R5 := R1;
  1776.                 while R5 < R2 do
  1777.                 begin  if VALUE(0/6) = B5 then
  1778.                    begin  B3(0/6) := OMSK;
  1779.                       R5:=R5-R1 shrl 3 + FT6; goto Y;
  1780.                    end;  R5 := @B5(8);
  1781.                 end;  !-- TERMINALS OF LENGTH SIX --!
  1782.              end;
  1783.              begin  if VALUE = "COMMENT" then
  1784.                 begin  B3(0/7) := OMSK;  if R6 > 71S then NEXTCHAR;
  1785.                    SCANTAB1(#5E) := 1;  !-- Look for semicolon --!
  1786.                    R1 := @CBUF(R6); R2 := 71 - R6;
  1787.  COMLOOP:          EX(R2,TRT(0,B1,SCANTAB1)); if = then
  1788.                    begin GETCARD; R2 := 71; R1 := @CBUF; goto COMLOOP;
  1789.                    end else if > then GETCARD else
  1790.                    begin R0 := @CBUF(_1); R6 := R1 - R0;
  1791.                    end;  RESET(SCANTAB1(#5E));  goto TOP;
  1792.                 end; R1 := @WORD7; R2 := @WORD8; R5 := R1;
  1793.                 while R5 < R2 do
  1794.                 begin  if VALUE(0/7) = B5 then
  1795.                    begin  B3(0/7) := OMSK;
  1796.                       R5 := R5-R1 shrl 3 + FT7; goto Y;
  1797.                    end;  R5 := @B5(8);
  1798.                 end;  !-- TERMINALS OF LENGTH SEVEN AND COMMENT --!
  1799.              end;
  1800.              begin R1 := @WORD8; R2 := @WORD9; R5 := R1;
  1801.                 while R5 < R2 do
  1802.                 begin  if VALUE(0/8) = B5 then
  1803.                    begin  B3(0/8) := OMSK;
  1804.                       R5 := R5-R1 shrl 3 + FT8; goto Y;
  1805.                    end;  R5 := @B5(8);
  1806.                 end;  !-- TERMINALS OF LENGTH EIGHT --!
  1807.              end;
  1808.              begin  if VALUE(0/9) = WORD9 then
  1809.                 begin  B3(0/9) := OMSK;
  1810.                    R5 := FT9; goto Y;
  1811.                 end;  if VALUE(0/9) = WORD9(12) then
  1812.                 begin  B3(0/9) := OMSK;
  1813.                    R5 := 1 + FT9; goto Y;
  1814.                 end;  !-- TERMINALS OF LENGTH NINE --!
  1815.              end;
  1816.           end; R5 := IDENTSYMBOL;
  1817.  Y:       if R6 > 71S then NEXTCHAR;
  1818.        end;
  1819.  
  1820.        begin  !-- CODE 3 -- READ HEXADECIMAL NUMBER --!
  1821.           R1 := R1-R1; R2 := R1; R3 := R1; NEXTCHAR;
  1822.  X:       R5 := #40 or R0;  !-- Force upper case --!
  1823.           if R0 >= "0" then R5 := R5 - 240 else
  1824.           if R5<"A" or R5>"F" then goto Y else R5 := R5 - 183S;
  1825.           SLDL(R2,4); R3 := R3 or R5; NEXTCHAR; R1 := R1+1; goto X;
  1826.  Y:       if R1 = 0 or R1 > 16 then
  1827.           begin XR := 25;  ERROR;  R1 := 1;
  1828.           end;  if R5 = "X" then
  1829.           begin R1 := R1 + 1 shrl 1;  STM(R2,R3,VALUE);
  1830.              R2 := 8 - R1;  R2 := @VALUE(R2);
  1831.              STRINGV(0/8) := B2;  VALUE := R1;
  1832.              R5 := STRNGADR;  ADR(R5+2) := R1;
  1833.              NEXTCHAR;  R5 := STRNGSYMBOL;  goto Z;
  1834.           end;  if R5 = "L" then
  1835.           begin R1 := 2; STM(R2,R3,VALUE); NEXTCHAR;
  1836.           end else
  1837.           begin VALUE := R3; VALUE(4):= R2;
  1838.              if R5 = "S" then
  1839.              begin R1 := R1-R1; NEXTCHAR;
  1840.              end else
  1841.              if R5 = "R" then
  1842.              begin R1 := 3; NEXTCHAR;
  1843.              end else R1 := 1;
  1844.           end; R5 := NUMBERSYMBOL; SYMTYPE := R1;
  1845.  Z:    end;
  1846.  
  1847.        begin  !-- CODE 4 -- READ STRING --!
  1848.           R0 := """";  VALUE := R0;  R2 := R2-R2;
  1849.  X:       NEXTCHAR; if R0 = VALUE then
  1850.           begin NEXTCHAR; if R0 ^= VALUE then goto Y;
  1851.           end;  if R0 = #79 then  !-- Accent (`) escape --!
  1852.           begin  !-- Process accent (`) escape --!
  1853.               array DATAFILL byte ESCTABLE = (
  1854.              !   ,  A,  B,  C,  D,  E,  F,  G,!
  1855.               #40,#01,#02,#03,#37,#2D,#2E,#2F,
  1856.              !  H,  I,  [,  .,  <,  (,  +,   ,!
  1857.               #16,#05,#35,#1E,#1F,#1B,#1C,#40,
  1858.              !  &,  J,  K,  L,  M,  N,  O,  P,!
  1859.               #0A,#25,#0B,#0C,#0D,#0E,#0F,#10,
  1860.              !  Q,  R,  ],  $,  *,  ),  ;,  ^,!
  1861.               #11,#12,#04,#14,#15,#2B,#55,#FA,
  1862.              !  \,  /,  S,  T,  U,  V,  W,  X,!
  1863.               #22,#07,#13,#3C,#3D,#32,#26,#18,
  1864.              !  Y,  Z,   ,   ,  %,  Õ,  >,  ?,!
  1865.               #19,#3F,#40,#40,#17,#27,#28,#09,
  1866.              !  0,  1,   ,   ,   ,   ,   ,   ,!
  1867.               #20,#21,#40,#40,#40,#40,#40,#40,
  1868.              !   ,  `,  :,  #,  @,  å,  =,  ",!
  1869.               #40,#79,#08,#09,#00,#1D,#2C,#7F);
  1870.              NEXTCHAR;  R4 := #3F and R0;  IC(R0,ESCTABLE(R4));
  1871.           end; if R2 < 256S then STC(R0,STRINGV(R2)) else
  1872.           begin R2 := R2-R2; XR := 21; ERROR;
  1873.              R0 := ";";  VALUE := R0;
  1874.           end; R2 := R2 + 1; goto X;
  1875.  Y:       if R2 = 0 then begin XR := 21; ERROR; end else
  1876.           if TM(ASCI,FLGS); ON then  !-- ASCII conversion --!
  1877.           begin  segment base R5;  array 256 byte ASCIITAB =
  1878.              ! 0 1 2 3 4 5 6 7    8 9 A B C D E F !
  1879.             (#000102037F097F7FX,#7F7F7F0B0C0D0E0FX,  ! 00 !
  1880.              #101112137F0A087FX,#18197F7F7F7F7F7FX,  ! 10 !
  1881.              #1F1D1C7F7F0A171BX,#7F7F7F7F7F050607X,  ! 20 !
  1882.              #7F7F167F7F1E7F04X,#7F7F7F7F14157F1AX,  ! 30 !
  1883.              #207F7F7F7F7F7F7FX,#7F7F5E2E3C282B7CX,  ! 40 !
  1884.              #267F7F7F7F7F7F7FX,#7F7F21242A293B7EX,  ! 50 !
  1885.              #2D2F7F7F7F7F7F7FX,#7F7F7C2C255F3E3FX,  ! 60 !
  1886.              #7F7F7F7F7F7F7F7FX,#7F603A2340273D22X,  ! 70 !
  1887.              #7F61626364656667X,#68697F7B7F7F7F7FX,  ! 80 !
  1888.              #7F6A6B6C6D6E6F70X,#71727F7D7F7F7F7FX,  ! 90 !
  1889.              #7F7E737475767778X,#797A7F7F7F5B7F7FX,  ! A0 !
  1890.              #7F7F7F7F7F7F7F7FX,#7F7F7F7F7F5D5C7FX,  ! B0 !
  1891.              #7B41424344454647X,#48497F7F7F7F7F7FX,  ! C0 !
  1892.              #7D4A4B4C4D4E4F50X,#51527F7F7F7F7F7FX,  ! D0 !
  1893.              #5C7F535455565758X,#595A7F7F7F7F7F7FX,  ! E0 !
  1894.              #3031323334353637X,#38397F7F7F7F7F7FX); ! F0 !
  1895.              R4 := R2;  REDUCE(R4);    !-- Len-1 --!
  1896.              EX(R4,TR(0,STRINGV,B5));  !-- Translate --!
  1897.           end;  R5 := STRNGADR;  ADR(R5+2) := R2;
  1898.           VALUE := R2; R5 := STRNGSYMBOL;
  1899.        end;
  1900.  
  1901.        begin  !-- CODE 5 -- ILLEGAL CHARACTER --!
  1902.           XR := 14; ERROR ; NEXTCHAR; goto TOP;
  1903.        end;
  1904.  
  1905.        begin  !-- CODE 6 -- SHORT COMMENT !! --!
  1906.           R1 := R0;  STC(R1,SCANTAB1(R1));
  1907.           NEXTCHAR; R1 := @CBUF(R6); R2 := 71 - R6;
  1908. COMLOOP:  EX(R2,TRT(0,B1,SCANTAB1)); if = then
  1909.           begin GETCARD; R2 := 71; R1 := @CBUF; goto COMLOOP;
  1910.           end else if > then GETCARD else
  1911.           begin R0 := @CBUF(_1); R6 := R1 - R0;
  1912.           end; RESET(SCANTAB1(#4F)); RESET(SCANTAB1(#6A)); goto TOP;
  1913.        end;
  1914.  
  1915.        begin  !-- CODE 7 -- END OF LINE COMMENT $ ... --!
  1916.           GETCARD;  goto TOP;
  1917.        end;
  1918.  
  1919.        end else
  1920.        begin  !-- CODE >= 10 -- SPECIAL SYMBOL --!
  1921.           array 15 integer TOPS=(
  1922.           #00000000,#4E02A02E,#6002B02F,#7A160020,
  1923.           #7E04B043,#7E04D045,#7E060049,#00080000,
  1924.           #000A0000,#FF02C000,#FF02D000,#7E0C0140,
  1925.           #000E0000,#7C100101,#00120000);
  1926.           NEXTCHAR;
  1927.           R2:=R2+R2; R2:=TOPS(R2-20); SRDL(R2,24); if R2^=0 then
  1928.           begin while R0=" " do NEXTCHAR; if R2=R0 then
  1929.              begin R3:=R3 shll 12; NEXTCHAR;
  1930.              end; R2:=R3 shrl 20 and #F; VALUE:=R2; R2:=R2-R2;
  1931.           end; SLDL(R2,8); R5:=OPS(R2);
  1932.        end;
  1933.     end;
  1934. $PAGE
  1935.  segment procedure PROCCALL(R1);
  1936.     begin integer SAVER1,RETREG; short integer VH syn V;
  1937.        RETREG:=R0; SAVER1:=R1; R4:=VH(R7) shrl 8 and #FF;
  1938.        R5:=LC; if R4^=CSEGNO then
  1939.        begin R2:=VH(R7) and #F0 + #5800S; PROGRAM(R5):=R2;
  1940.           R0:=PROGESDEND; R1:=PROGESDADR; R2:=ER; R3:=VTYPE;
  1941.           FINDESDENTRY; PROGESDEND:=R0; R0:=RLDADDR(R1);
  1942.           PROGRAM(R5+2):=R0; RLDADDR(R1):=R5; R5:=@B5(4);
  1943.        end;
  1944.        R3:=VH(R7+2); if R3=0 then
  1945.        begin R2:=VH(R7) and #FF; SRDL(R2,4); R3:=R3 shrl 24 or R2+#500S;
  1946.           PROGRAM(R5):=R3; R5:=@B5(2);
  1947.        end else
  1948.        begin R2:=VH(R7) and #F0 shll 8 + R3; PROGRAM(R5+2):=R2;
  1949.           R3:=VH(R7) and #F shll 4 + #4500S;
  1950.           PROGRAM(R5):=R3; R5:=@B5(4);
  1951.        end;
  1952.        R3:=PBREG; R0:=RETREG; R2:=VH(R7) and #F;
  1953.        if R0^=16S then
  1954.        begin R2:=R3; R3:=R3 shll 4; R1:=@B3(#500); PROGRAM(R5+2):=R1;
  1955.           R1:= VH(R7) shrl 4 and #F; R0:=R0 shll 4 or R1 + #1200S;
  1956.           PROGRAM(R5):=R0;  R5:=@B5(4);
  1957.        end else
  1958.        if R4=CSEGNO then goto Y;
  1959.        R1:=PROGESDADR; R3:=PBREG shll 4 + #5800S + R2;
  1960.        PROGRAM(R5):=R3; R2:=RLDADDR(R1); PROGRAM(R5+2):=R2;
  1961.        RLDADDR(R1):=R5; R5:=@B5(4);
  1962.   Y:   LC:=R5; R1:=SAVER1;
  1963. $IFT D D
  1964.        if TM(4,DBGFLGS); ON then SET(PRNT);
  1965. $END D
  1966.     end;
  1967. $PAGE
  1968.   !--  ***************  EXECUTE  *************** --!
  1969.  segment procedure EXECUTE (R4);
  1970.  
  1971.  begin  integer SAVE, SAVE2;
  1972.  array 5 integer SAVEREG;  !-- USED BY THE EXECUTE PROCEDURES --!
  1973.  equate XEQ0 syn 46,            !-- NULL PROCESSES --!
  1974.         XEQ1 syn XEQ0 + 43,     !-- EXECUTE1'S RULES --!
  1975.         XEQ2 syn XEQ1 + 09,     !-- EXECUTE2'S RULES --!
  1976.         XEQ3 syn XEQ2 + 61,     !-- EXECUTE3'S RULES --!
  1977.         XEQ4 syn XEQ3 + 48;     !-- EXECUTE4'S RULES --!
  1978.  
  1979.  segment procedure EXECUTE1(R4);   !-- RULES <= XEQ1 --!
  1980.    begin  !-- LOCAL PROCEDURE FOLLOWS --!
  1981.  
  1982.     procedure ASSCELL (R4);
  1983.     begin SAVE := R4;
  1984.        R0 := T2(R7); R1 := R0 shll 2 + T(R7); R1 := @TYPETABLE(R1);
  1985.        CLI(0,B1); if = then begin XR := 3; ERROR; end;
  1986.        R0 := R0 + 4; R1 := 8; R2 := V(R7);
  1987.        R3 := V2(R7); EMYT; R4 := SAVE;
  1988.     end;
  1989.  
  1990.     procedure TCELLNUM (R4);
  1991.     begin SAVE := R4;
  1992.        R0 := V1(R7); R1 := V2(R7); R2 := T2(R7);
  1993.        if R2 > 1 then begin XR := 25; ERROR; goto X; end;
  1994.        R2 := V(R7+4);  if R0 = 11S then R1 := neg R1 else
  1995.        if R0 ^= 10S then
  1996.        begin XR := 0;  if R0 = 13S and R2 = 0 and
  1997.              R1 > 0 then V(R7+4) := R1
  1998.           else ERROR;  goto X;
  1999.        end;  if R2 ^= 0 then
  2000.        begin R1 := R1 + R2;  if <= then
  2001.           begin XR := 24;  ERROR;
  2002.           end else V(R7+4) := R1;  goto X;
  2003.        end; R2 := V(R7); SRDL(R2,12); R3 := R3 shrl 20 + R1;
  2004.        if R3>4095S or R3<0 then begin XR := 18; ERROR; goto X; end;
  2005.        R2 := R2 shll 12 or R3; V(R7) := R2;
  2006.    X:  R4 := SAVE;
  2007.     end;
  2008.  
  2009.     procedure ASSTNUM (R4);
  2010.     begin SAVE := R4;
  2011.        R2 := T2(R7); R1 := R2 shll 2 + T(R7); R1 := @TYPETABLE(R1);
  2012.        CLI(0,B1); if = then begin XR := 3; ERROR; end;
  2013.        R3 := V2(R7); if R2<2 and R3<4096S and R3>=0 then
  2014.        begin R0 := 4; R1 := 1; R2 := V(R7); EMYT;
  2015.        end else
  2016.        begin R1 := R1-R1; IC(R1,ALENGTH(R2)); IC(R0,LENGTH(R2));
  2017.           R2 := 2 + LC; R3 := @V2(R7);
  2018.           MAKELITERAL; R0 := 4 + T2(R7); R1 := 8;
  2019.           R2 := V(R7); R3 := R3-R3; EMYT;
  2020.        end; R4 := SAVE;
  2021.     end;
  2022.  
  2023.     procedure NEWUNARY (R4);
  2024.     begin  V2(R7/2) := V(R7+2);  V(R7/18) := V1(R7);
  2025.     end;
  2026.  
  2027.     procedure OLDUNARY (R4);
  2028.     begin  byte VC syn V, VC2 syn V(32);
  2029.        R1 := R1 -- R1;  R0 := V(R7);
  2030.        IC(R1,VC2(R7));  R2 := @VC2(R7+R1+1);
  2031.        if VC(R7+3) = 6 or VC(R7+3) = 4 or C2 = 6 or C2 = 4 then
  2032.        begin  R1 := @B1(1);  STC(R1,VC2(R7));  R2 := @B2(1);
  2033.        end else if VC(R7+3) = 3 then
  2034.        begin  C2 := C2 xor #01X;  goto X;
  2035.        end;  STC(R0,C2);
  2036.     X: R1 := @B1(17);  EX(R1,MVC(0,V(R7),V1(R7)));
  2037.     end;
  2038.  
  2039.     procedure ASSUNOP (R4);
  2040.     begin  byte VC syn V(48), OPCD syn B4;  SAVE := R4;
  2041.        R0 := T2(R7);  R1 := R0 shll 2 + T(R7);
  2042.        R1 := @TYPETABLE(R1);  if C1 = 0 then
  2043.        begin  XR := 3;  ERROR;  end;  R4 := R4 -- R4;
  2044.        R2 := V(R7);  R3 := V2(R7);  IC(R4,VC(R7));
  2045.        R4 := @VC(R7+R4+2);  SET(OPCD);  !-- End signal --!
  2046.        R4 := @VC(R7+1);  while ^OPCD do  !-- For all ops --!
  2047.        begin  if OPCD = 6 then !-- DEC (aka BCTR) --!
  2048.           begin  if R0 ^= 1S then begin  XR := 7;  ERROR;  end;
  2049.              if R2 ^= R3 then begin  R1 := 8;  EMIT;  end;
  2050.              R0 := R0 -- R0 =: R3;  !-- White lie --!
  2051.           end else if OPCD = 4 then  !-- HALF (aka HDR and HER) --!
  2052.           if R0 = 1S then begin  XR := 7;  ERROR;  end;
  2053.           R1 := R1 -- R1;  IC(R1,OPCD);  EMIT;
  2054.           R0 := T(R7);  R3 := R2;  R4 := @B4(1);
  2055.        end;  R4 := SAVE;
  2056.     end;
  2057.  
  2058.     procedure ADRSOP (R5);  !-- ASSIGN <ADR OP> REGISTER --!
  2059.     begin  SAVE := R5;  if = then REDUCE(R3) else
  2060.        begin  R5 := R2 shll 12 or R3 =: R3 shrl 16;
  2061.           if R2 = 0 or R2 = R5 then  !-- INVALID --!
  2062.           begin  XR := 0;  ERROR;  R3 := R3-R3;
  2063.              REDUCE(R3);   goto XIT;
  2064.           end;  !-- LOAD ASSIGNMENT REGISTER --!
  2065.        end;  SAVE2 := R3;  R3 := VTYPE;  R5 := LC;
  2066.        R2 := @B2(#580) shll 4 =: PROGRAM(R5);  R2 := R0;
  2067.        R1 := PROGESDADR;  R0 := PROGESDEND;  FINDESDENTRY;
  2068.        PROGESDEND := R0;  R0 := RLDADDR(R1) =: PROGRAM(R5+2);
  2069.        RLDADDR(R1) := R5;  R5 := @B5(4) =: LC;  R3 := SAVE2;
  2070.   XIT: R2 := V(R7);  R5 := SAVE;
  2071.     end;
  2072. $PAGE
  2073.     procedure STRTOINT (R4);  !- Convert <STRING> to <T NUM> -!
  2074.     begin  SAVE := R4;
  2075.        R3 := STRINGV;  R1 := 4 - V2(R7);  if < then
  2076.        begin  XR := 21;  ERROR;  !- Invalid length -!
  2077.        end else  !- Valid string length -!
  2078.        for R2 := 1 step 1 until R1 do R3 := R3 shrl 8;
  2079.        V2(R7) := R3;  T2(R7) := 1;  !- integer type -!
  2080.        R4 := SAVE;
  2081.     end;
  2082.  
  2083.     procedure INDXTNUM (R4);  !- Start index with integer -!
  2084.     begin  SAVE := R4;
  2085.        R1 := V1(R7); R2 := T1(R7);
  2086.        if R2 > 1 then begin XR := 0; ERROR; goto X; end;
  2087.        R2 := V(R7); SRDL(R2,12); R3 := R3 shrl 20 + R1;
  2088.        if R3>4095S or R3<0 then begin XR := 18; ERROR; goto X; end;
  2089.        R2 := R2 shll 12 or R3; V(R7) := R2;
  2090.     X: R4 := SAVE;
  2091.     end;
  2092.  
  2093.     procedure ARITHNUM (R4);  !- Do arith with number -!
  2094.     begin  SAVE := R4;
  2095.        R1 := R1-R1;
  2096.        R2 := T2(R7); IC(R1,ALENGTH(R2)); IC(R0,LENGTH(R2));
  2097.        R2 := 2 + LC; R3 := @V2(R7); MAKELITERAL;
  2098.        XR := 4; R1 := V1(R7); R0 := T2(R7);
  2099.        if R1 = 0 then begin ERROR; R1 := 8; end;
  2100.        R2 := R0 shll 2 + T(R7); R2 := @TYPETABLE(R2);
  2101.        CLI(0,B2);  if = then ERROR else
  2102.        if R1>=13S and R0=0 then ERROR;
  2103.        R2 := V(R7); if R0=1 then if R1=12S or R1=13S then
  2104.        begin R2 := R2 and #E;  !-- ODD REGISTER MUST BE SPECIFIED --!
  2105.           if R2=V(R7) then begin XR := 7; ERROR; end;
  2106.        end;
  2107.        R0 := R0 + 4; R3 := R3-R3; EMYT;
  2108.        R4 := SAVE;
  2109.     end;
  2110.  
  2111.     procedure LOGTNUM (R4);  !- Do logical operator with number -!
  2112.     begin  SAVE := R4;
  2113.        R1 := R1-R1; R2 := T2(R7); if R2 = 0 then R2 := 1;
  2114.        IC(R1,ALENGTH(R2)); IC(R0,LENGTH(R2));
  2115.        R2 := 2 + LC; R3 := @V2(R7); MAKELITERAL;
  2116.        R0 := 1; if R0^=T(R7) or R0^=T2(R7) then
  2117.        begin XR := 4; ERROR; end;
  2118.        R0 := 5; R1 := V1(R7); R2 := V(R7); R3 := R3-R3; EMYT;
  2119.        R4 := SAVE;
  2120.     end;
  2121. $PAGE
  2122.           !-- ********* THE FOLLOWING ARE NULL PROCESSES ********** --!
  2123.           !- <T CELL>     ::= <T CELL ID> -!
  2124.           !- <T CELL>     ::= <T CELL1> ) -!
  2125.           !- <T CELL>     ::= <T CELL2> ) -!
  2126.           !- <T CELL3>    ::= <T CELL ID> ( -!
  2127.           !- <FUNC2>      ::= <FUNC1> , -!
  2128.           !- <PROC1>      ::= <PROC ID> ( -!
  2129.           !- <SIMPLE ST>  ::= <K REG ASS> -!
  2130.           !- <SIMPLE ST>  ::= <CELL ST> -!
  2131.           !- <SIMPLE ST>  ::= NULL -!
  2132.           !- <SIMPLE ST>  ::= <PROC2> ) -!
  2133.           !- <GOTO ST>    ::= <GOTO ST*> -!
  2134.           !- <STATEMENT-> ::= <SIMPLE ST> -!
  2135.           !- <STATEMENT*> ::= <STATEMENT-> -!
  2136.           !- <STATEMENT>  ::= <STATEMENT*> -!
  2137.           !- <REP LIST1>  ::= <REP LIST2> , -!
  2138.           !- <REP LIST2>  ::= <REP LIST1><FILL> -!
  2139.           !- <T DECL2>    ::= <T DECL4> , -!
  2140.           !- <T DECL4>    ::= <T DECL1> -!
  2141.           !- <FUNC DC1>   ::= FUNCTION -!
  2142.           !- <FUNC DC1>   ::= <FUNC DC7> , -!
  2143.           !- <FUNC DC3>   ::= <FUNC DC2> ( -!
  2144.           !- <FUNC DC5>   ::= <FUNC DC4> , -!
  2145.           !- <FUNC DC7>   ::= <FUNC DC6> ) -!
  2146.           !- <SYN DC3>    ::= <SYN DC2> , -!
  2147.           !- <PROC HD2>   ::= <PROC HD1> ( -!
  2148.           !- <PROC HD4>   ::= <PROC HD3> ) -!
  2149.           !- <GLOB HD>    ::= <GLOB HD1> -!
  2150.           !- <DECL>       ::= <T DECL4> -!
  2151.           !- <DECL>       ::= <FUNC DC7> -!
  2152.           !- <DECL>       ::= <SYN DC2> -!
  2153.           !- <BLOCKHEAD>  ::= <BLOCKHEAD><DECL> ; -!
  2154.           !- <BLOCKBODY>  ::= <BLOCKHEAD> -!
  2155.           !- <BLOCKBODY>  ::= <BLOCKBODY><STATEMENT> ; -!
  2156.           !- <BLOCKBODY>  ::= <BLOCKBODY><LABEL DEF> -!
  2157.           !- <PROGRAM>    ::= <PROGRAM*> . -!
  2158.           !- <IF>         ::= IF -!
  2159.           !- <IF>         ::= <IF><STATEMENT> ; -!
  2160.           !- <COMP AOR>   ::= <COMP AOR><STATEMENT> ; -!
  2161.           !- <WHILE>      ::= <WHILE><STATEMENT> ; -!
  2162.           !- <PRIM COND>  ::= <COMP COND> -!
  2163.           !- <RP>         ::= <RP><STATEMENT> ; -!
  2164.           !- <CASE HEAD>  ::= <CASE HEAD><DECL> ; -!
  2165.           !- <CASE SEQ>   ::= <CASE HEAD> -!
  2166.           !- <CASE SEQ>   ::= <CASE SEQ><LABEL DEF> -!
  2167.           !- <REPEAT>     ::= <REPEAT><LABEL DEF> -!
  2168.           !- <REPEAT>     ::= <REPEAT><STATEMENT> ; -!
  2169. $PAGE
  2170.     R1 := R1 - XEQ0;   if > then  !-- NOT NULL RULE --!
  2171.     case R1 of begin  !-- EXECUTE1'S RULES --!
  2172.     begin !- <K REG ASS>  ::= <K REG> -!
  2173. $IFT D D
  2174.        if TM(1,DBGFLGS); ON then SET(PRNT); !-- List assignments --!
  2175. $END D
  2176.     end;
  2177.     begin !- <K REG>      ::= <ID> -!
  2178.        R1 := @V(R7); R3 := 1 + T(R7) and #E; R4 := R4-R4; IC(R4,V(R7));
  2179.        IC(R4,ALPHASH(R4-193)); R4 := R4 + LENHASH(R3-2);
  2180.        R4 := HASHCHAIN(R4);  REDUCE(R3);  R5 := NAMEBASE;
  2181.        if R4 >= 0 then
  2182.        begin  !-- SCAN NAME TABLE --!
  2183.        Z: R4 := R4 + R5; EX(R3,CLC(0,B1,NAME(R4))); if = then
  2184.           begin R0 := TYPE(R4); R2 := ADR(R4+2); SRDL(R2,16);
  2185.              R2 := ADR(R4); SRDL(R2,16); R5 := #FF;
  2186.              R4 := R0 and #FF00; R0 := R0 and R5; R5 := 80;
  2187.              if R0 > R5 then R0 := R0 - R5 else SET(FLAG);
  2188.              goto X;
  2189.           end; R4 := LINK(R4);  if R4 ^= ENDCHAIN then
  2190.           begin  R4 := R4 and #FFFF;  goto Z;  end;
  2191.        end; XR := 8; ERROR;
  2192.        R3 := 1; R0 := R3;
  2193.  X:    V(R7) := R3; V(R7+8) := R4; T(R7) := R0;
  2194.     end;
  2195.     begin !- <T CELL ID>  ::= <ID> -!
  2196.        R1 := 10; if R1 > T(R7) then
  2197.        begin R0 := V(R7) and #FFFFF;
  2198.           !- Check for DSTAR symbol reference -!
  2199.           if R0 = #D0FFF then R0 := DBREG shll 12 + DC
  2200.           !- Check for PSTAR symbol reference -!
  2201.           else if R0 = #E0FFF then R0 := PTAG + LC;
  2202.           V(R7) := R0;  R1 := R1-R1;  V(R7+4) := R1;
  2203.        end else SET(FLAG);
  2204.     end;
  2205.     begin !- <PROC ID>    ::= <ID> -!
  2206.        R1 := 10; if R1 ^= T(R7) then SET(FLAG);
  2207.     end;
  2208.     begin !- <FUNC ID>    ::= <ID> -!
  2209.        R1 := 11; if R1 ^= T(R7) then SET(FLAG);
  2210.     end;
  2211.     begin !- <T NUMBER>   ::= <ID> -!
  2212.        R1 := 1;  R2 := 12;  if R2 = T(R7) then goto X;
  2213.        R1 := R1-R1;  R2 := 15;  if R2 = T(R7) then goto X;
  2214.        SET(FLAG);  goto Z;
  2215.     X: T(R7) := R1; R1 := R1-R1; V(R7+4) := R1;  Z:
  2216.     end;
  2217.     begin !- <UNARY OP>   ::= <ID> -!
  2218.        R1 := 13;  if R1 ^= T(R7) then SET(FLAG);
  2219.     end;
  2220.     begin !- <BRINDX OP>  ::= <ID> -!
  2221.        R1 := 14;  if R1 ^= T(R7) then SET(FLAG);
  2222.     end;
  2223.     begin !- <T CELL1>    ::= <T CELL1><ARITH OP><STRING> -!
  2224.        STRTOINT;
  2225.        TCELLNUM;
  2226.     end;
  2227.     begin !- <T CELL1>    ::= <T CELL1><ARITH OP><T NUMBER> -!
  2228.        TCELLNUM;
  2229.     end;
  2230.     begin !- <T CELL1>    ::= <T CELL2><ARITH OP><T NUMBER> -!
  2231.        TCELLNUM;
  2232.     end;
  2233.     begin !- <T CELL1>    ::= <T CELL2><ARITH OP><K REG> -!
  2234.        R0 := 1; R1 := V2(R7); R2 := V(R7);
  2235.        if R0 ^= T2(R7) or R1 = 0 then
  2236.        begin XR := 7; ERROR; goto X;
  2237.        end;
  2238.        if R2 > #FFFF then begin XR := 11; ERROR; goto X; end;
  2239.        R0 := 10; if R0 ^= V1(R7) then
  2240.        begin XR := 0; ERROR; goto X;
  2241.        end;
  2242.        R2 := R2 and #FFFF; if R2 < 4096S then
  2243.        R1 := R1 shll 12 else R1 := R1 shll 16;
  2244.        R1 := R1 or R2; V(R7) := R1;
  2245.  X: end;
  2246.     begin !- <T CELL1>    ::= <T CELL3><STRING> -!
  2247.        R7 := R7 - 16S;  STRTOINT;  R7 := R7 + 16S;
  2248.        INDXTNUM;  !- Assign as number -!
  2249.     end;
  2250.     begin !- <T CELL1>    ::= <T CELL3><T NUMBER> -!
  2251.        INDXTNUM;
  2252.     end;
  2253.     begin !- <T CELL2>    ::= <T CELL3><K REG> -!
  2254.        R0 := 1; R1 := V1(R7); R2 := V(R7);
  2255.        if R0^=T1(R7) or R1=0 then begin XR := 7; ERROR; goto X; end;
  2256.        if R2 > #FFFF then begin XR := 11; ERROR; goto X; end;
  2257.        R2 := R2 and #FFFF; if R2 < 4096S then
  2258.        R1 := R1 shll 12 else R1 := R1 shll 16;
  2259.        R1 := R1 or R2; V(R7) := R1;
  2260.  X: end;
  2261.     begin !- <UNARY CELL> ::= <UNARY OP><T CELL> -!
  2262.        NEWUNARY;
  2263.     end;
  2264.     begin !- <UNARY CELL> ::= <UNARY OP><UNARY CELL> -!
  2265.        OLDUNARY;
  2266.     end;
  2267.     begin !- <UNARY NUM>  ::= <UNARY OP><T NUMBER> -!
  2268.        NEWUNARY;
  2269.     end;
  2270.     begin !- <UNARY NUM>  ::= <UNARY OP><UNARY NUM> -!
  2271.        OLDUNARY;
  2272.     end;
  2273.     begin !- <UNARY REG>  ::= <UNARY OP><K REG> -!
  2274.        NEWUNARY;
  2275.     end;
  2276.     begin !- <UNARY REG>  ::= <UNARY OP><UNARY REG> -!
  2277.        OLDUNARY;
  2278.     end;
  2279.     begin !- <LOG OP>     ::= AND -!
  2280.        R0 := #4; V(R7) := R0;
  2281.     end;
  2282.     begin !- <LOG OP>     ::= OR -!
  2283.        R0 := #6; V(R7) := R0;
  2284.     end;
  2285.     begin !- <LOG OP>     ::= XOR -!
  2286.        R0 := #7; V(R7) := R0;
  2287.     end;
  2288.     begin !- <K REG ASS>  ::= <K REG> := <T CELL> -!
  2289.        ASSCELL;
  2290.     end;
  2291.     begin !- <K REG ASS>  ::= <K REG> := <T NUMBER> -!
  2292.        ASSTNUM;
  2293.     end;
  2294.     begin !- <K REG ASS>  ::= <K REG> := <STRING> -!
  2295.        STRTOINT;
  2296.        ASSTNUM;
  2297.     end;
  2298.     begin !- <K REG ASS>  ::= <K REG> := <K REG> -!
  2299.        R0 := T2(R7); R1 := R0 shll 2 + T(R7); R1 := @TYPETABLE(R1);
  2300.        CLI(0,B1); if = then begin XR := 3; ERROR; end;
  2301.        R1 := 8; R2 := V(R7); R3 := V2(R7); if R2 ^= R3 then EMIT;
  2302.     end;
  2303.     begin !- <K REG ASS>  ::= <K REG> := <UNARY CELL> -!
  2304.        ASSCELL;  V2(R7/16) := V(R7);  ASSUNOP;
  2305.     end;
  2306.     begin !- <K REG ASS>  ::= <K REG> := <UNARY NUM> -!
  2307.        ASSTNUM;  V2(R7/16) := V(R7);  ASSUNOP;
  2308.     end;
  2309.     begin !- <K REG ASS>  ::= <K REG> := <UNARY REG> -!
  2310.        ASSUNOP;
  2311.     end;
  2312.     begin !- <K REG ASS>  ::= <K REG> := <ADR OP><T CELL> -!
  2313.        R0 := 1;  if R0 ^= T(R7) then
  2314.        begin  XR:=3;  ERROR;  !-- REG ASSIGN TYPE --!
  2315.        end;  R2 := V(R7);  R3 := V(R7+48);  R4 := V2(R7);
  2316.        if R4 ^= 0 and  R4 := V(R7+56) shrl 8;
  2317.           R4 < MAXSEGNO and R5 := R4 * 10S;
  2318.           R5 := @ESDNAME(R5);  B5 ^= "DUMMY " then
  2319.        begin  R0 := ER;  R3 := R3 and #F0FFF;  ADRSOP;
  2320.        end;  R0 := 4;  R1 := 1;  if R3 >= 0 then EMYT;
  2321.     end;
  2322.     begin !- <K REG ASS>  ::= <K REG> := <ADR OP><PROC ID> -!
  2323.        R0:=T(R7); if R0^=1 then begin XR:=3; ERROR; end;
  2324.        R4:=V(R7+48); SRDL(R4,12); R4:=R4 shrl 8; SRDL(R4,4);
  2325.        R5:=R5 shrl 16; R2:=V(R7); if R4^=CSEGNO then
  2326.        begin  R0 := ER;  R3 := V2(R7);  if R3 ^= 0 then R0 := WER;
  2327.           R3 := #FFF and R5;  ADRSOP;  R5 := R3;
  2328. $IFT D D
  2329.           if TM(4,DBGFLGS); ON then SET(PRNT); !-- List these --!
  2330. $END D
  2331.        end;  R0 := 4;  R1 := 1;  if LTR(R3,R5); > then EMYT;
  2332.     end;
  2333.     begin !- <K REG ASS>  ::= <K REG ASS><ARITH OP><STRING> -!
  2334.        STRTOINT;
  2335.        ARITHNUM;
  2336.     end;
  2337.     begin !- <K REG ASS>  ::= <K REG ASS><ARITH OP><T CELL> -!
  2338.        R0 := T2(R7); R1 := R0 shll 2 + T(R7); R1 := @TYPETABLE(R1);
  2339.        CLI(0,B1); if = then begin XR := 4; ERROR; end;
  2340.        R1 := V1(R7); R2 := V(R7);
  2341.        if R1>=13S and R0=0 then begin XR := 4; ERROR; end else
  2342.        if R0=1 then if R1=12S or R1=13S then
  2343.        begin R2 := R2 and #E;  !-- ODD REGISTER MUST BE SPECIFIED --!
  2344.           if R2=V(R7) then begin XR := 7; ERROR; end;
  2345.        end;
  2346.        R0 := R0 + 4; R3 := V2(R7); EMYT;
  2347.     end;
  2348.     begin !- <K REG ASS>  ::= <K REG ASS><ARITH OP><T NUMBER> -!
  2349.        ARITHNUM;
  2350.     end;
  2351.     begin !- <K REG ASS>  ::= <K REG ASS><ARITH OP><K REG> -!
  2352.        R0 := T2(R7); R1 := R0 shll 2 + T(R7); R1 := @TYPETABLE(R1);
  2353.        CLI(0,B1); if = then begin XR := 4; ERROR; end;
  2354.        R1 := V1(R7); R2 := V(R7); R3 := V2(R7);
  2355.        if R1 = 0 then  !-- REVERSE ASSIGNMENT --!
  2356.        begin  if R2 = R3 then goto X;
  2357.           R1 := R2;  R2 := R3;  R3 := R1;  R1 := 8;
  2358.        end;  if R0=1 then if R1=12S or R1=13S then
  2359.        begin R2 := R2 and #E;  !-- ODD REGISTER MUST BE SPECIFIED --!
  2360.           if R2=V(R7) then begin XR := 7; ERROR; end;
  2361.        end; EMIT;
  2362.  X: end;
  2363.     begin !- <K REG ASS>  ::= <K REG ASS><LOG OP><STRING> -!
  2364.        STRTOINT;
  2365.        LOGTNUM;
  2366.     end;
  2367.     begin !- <K REG ASS>  ::= <K REG ASS><LOG OP><T CELL> -!
  2368.        R0 := 1; if R0^=T(R7) or R0^=T2(R7) then
  2369.        begin XR := 4; ERROR;
  2370.        end;
  2371.        R0 := 5; R1 := V1(R7); R2 := V(R7); R3 := V2(R7); EMYT;
  2372.     end;
  2373.     begin !- <K REG ASS>  ::= <K REG ASS><LOG OP><T NUMBER> -!
  2374.        LOGTNUM;
  2375.     end;
  2376.     begin !- <K REG ASS>  ::= <K REG ASS><LOG OP><K REG> -!
  2377.        R0 := 1; if R0^=T(R7) or R0^=T2(R7) then
  2378.        begin XR := 4; ERROR;
  2379.        end;
  2380.        R1 := V1(R7); R2 := V(R7); R3 := V2(R7); EMIT;
  2381.     end;
  2382.     begin !- <K REG ASS>  ::= <K REG ASS><SHIFT OP><T NUMBER> -!
  2383.        R0 := 1; if R0^=T(R7) or R0<T2(R7) then
  2384.        begin XR := 5; ERROR;
  2385.        end;
  2386.        R0 := 8; R1 := V1(R7); R2 := V(R7); R3 := V2(R7);
  2387.        if R3<0 or R3>=32S then
  2388.        begin XR:=25; ERROR;
  2389.        end;
  2390.        if R3 ^= 0 then EMYT;
  2391.     end;
  2392.     begin !- <K REG ASS>  ::= <K REG ASS><SHIFT OP><K REG> -!
  2393.        R0 := 1; if R0^=T(R7) or R0^=T2(R7) then
  2394.        begin XR := 5; ERROR;
  2395.        end;
  2396.        R0 := 8; R1 := V1(R7); R2 := V(R7);
  2397.        R3 := V2(R7) shll 12; EMYT;
  2398.     end;
  2399.     end; LM(R1,R5,SAVEREG);
  2400.     end;
  2401. $PAGE
  2402. segment procedure EXECUTE2(R4);  !-- XEQ1 < RULES <= XEQ2 --!
  2403.    begin  !-- LOCAL PROCEDURES FOLLOW --!
  2404.  
  2405.     procedure  ARGUMENT(R8);  !-- Process FUNCTION arguments --!
  2406.     begin R0 := V(R7); SRDL(R0,4); V(R7) := R0; R1 := R1 shrl 28;
  2407.        R0 := V1(R7); R3 := T1(R7); XR := 24;
  2408.        if R1 = 0 then begin XR := 13; ERROR; end else
  2409.        case R1 of begin
  2410.           begin  !-- PAR 1 -- REGISTER -- BITS 8-11 --!
  2411.              if R2 ^= 4 then ERROR;
  2412.              R0 := R0 and #F shll 4 or FUNC0; FUNC0 := R0;
  2413.           end;
  2414.           begin  !-- PAR 2 -- NUMBER -- BITS 8-11 --!
  2415.              if R2 ^= 2 or R0 >= 16S or R0 < 0 then ERROR;
  2416.              R0 := R0 and #F shll 4 or FUNC0; FUNC0 := R0;
  2417.           end;
  2418.           begin  !-- PAR 3 -- REGISTER -- BITS 12-15 --!
  2419.              if R2 ^= 4 then ERROR;
  2420.              R0 := R0 and #F or FUNC0; FUNC0 := R0;
  2421.           end;
  2422.           begin  !-- PAR 4 -- NUMBER -- BITS 12-15 --!
  2423.              if R2 ^= 2 or R0 >= 16S or R0 < 0 then ERROR;
  2424.              R0 := R0 and #F or FUNC0; FUNC0 := R0;
  2425.           end;
  2426.           begin  !-- PAR 5 -- NUMBER STRING VARIABLE -- BITS 8-15 --!
  2427.              case R2 of begin
  2428.                 begin if R0 >= 256S then ERROR;
  2429.                 end;
  2430.                 begin if R3 < 2 then if R0 < 256S then
  2431.                    if R0 < 0 then ERROR;
  2432.                 end;
  2433.                 begin if R0 ^= 1 then begin XR := 21; ERROR; end;
  2434.                    IC(R0,STRINGV);
  2435.                 end;
  2436.                 begin  ERROR;
  2437.                 end;
  2438.              end;  R0 := R0 and #FF xor FUNC0;  FUNC0 := R0;
  2439.           end;
  2440.           begin  !-- PAR 6 -- NUMBER STRING VARIABLE -- BITS 12-31 --!
  2441.              case R2 of begin
  2442.                 null;
  2443.                 begin if R3 < 2 then if R0 < 4096S then
  2444.                    if R0 < 0 then ERROR;
  2445.                 end;
  2446.                 begin if R0 ^= 1 then begin XR := 21; ERROR; end;
  2447.                    IC(R0,STRINGV);
  2448.                 end;
  2449.                 begin  ERROR;
  2450.                 end;
  2451.              end; FUNC1 := R0; R0 := R0 shrl 16 and #F or FUNC0;
  2452.              FUNC0 := R0;
  2453.           end;
  2454.           begin  !-- PAR 7 -- LITERAL VARIABLE -- BITS 12-31 --!
  2455.              case R2 of begin
  2456.                 begin FUNC1:=R0; R0:=R0 shrl 16 and #F or FUNC0;
  2457.                    FUNC0:=R0;
  2458.                 end;
  2459.                 begin IC(R2,LENGTH(R3)); R1 := 1 shll R2 - 1;
  2460.                    R3:=LITX; FUNC1:=R3; R3:=1; LITCOUNT:=R3;
  2461.                    R0 := R2; R2 := 2 + LC; R3 := @V1(R7);
  2462.                    if R1 = 0 then R3 := @B3(3);  MAKELITERAL;
  2463.                 end;
  2464.                 begin R1 := R0 - 1; R0 := R0-R0; R2 := 2 + LC;
  2465.                    R3:=LITX; FUNC1:=R3; R3:=1; LITCOUNT:=R3;
  2466.                    R3 := @STRINGV; MAKELITERAL;
  2467.                 end;
  2468.                 begin  ERROR;
  2469.                 end;
  2470.              end;
  2471. $IFT D D
  2472.              if R3 ^= 4 and CLI(#43,FUNC0(2)); = then SET(PRNT);
  2473. $END D
  2474.           end;
  2475.           begin  !-- PAR 8 -- VARIABLE -- BITS 12-31 --!
  2476.              if R2 ^= 1 then ERROR; FUNC1 := R0;
  2477.              R0 := R0 shrl 16 and #F or FUNC0; FUNC0 := R0;
  2478. $IFT D D
  2479.              if R3 ^= 4 and CLI(#42,FUNC0(2)); = then SET(PRNT);
  2480. $END D
  2481.           end;
  2482.           begin  !-- PAR 9 -- NUMBER VARIABLE -- BITS 16-31 --!
  2483.              case R2 of begin
  2484.                 if R0 > #FFFF then begin XR := 11; ERROR; end;
  2485.                 begin if R3 < 2 then if R0 < 4096S then
  2486.                    if R0 < 0 then ERROR;
  2487.                 end;
  2488.                 begin  ERROR;
  2489.                 end;
  2490.                 begin  ERROR;
  2491.                 end;
  2492.              end; FUNC1 := R0;
  2493.           end;
  2494.           begin  !-- PAR A -- LITERAL VARIABLE -- BITS 16-31 --!
  2495.              case R2 of begin
  2496.                 begin FUNC1:=R0;
  2497.                    if R0 > #FFFF then begin XR:=11; ERROR; end;
  2498.                 end;
  2499.                 begin IC(R2,LENGTH(R3)); R1 := 1 shll R2 - 1;
  2500.                    R3:=LITX; FUNC1:=R3; R3:=1; LITCOUNT:=R3;
  2501.                    R0 := R2; R2 := 2 + LC; R3 := @V1(R7);
  2502.                    if R1 = 0 then R3 := @B3(3);  MAKELITERAL;
  2503.                 end;
  2504.                 begin R1 := R0 - 1; R0 := R0-R0; R2 := 2 + LC;
  2505.                    R3:=LITX; FUNC1:=R3; R3:=1; LITCOUNT:=R3;
  2506.                    R3 := @STRINGV; MAKELITERAL;
  2507.                 end;
  2508.                 begin  ERROR;
  2509.                 end;
  2510.              end;
  2511.           end;
  2512.           begin  !-- PAR B -- VARIABLE -- BITS 16-31 --!
  2513.              if R2 ^= 1 then ERROR else
  2514.              if R0 > #FFFF then begin XR := 11; ERROR; end;
  2515.              FUNC1 := R0;
  2516. $IFT D D
  2517.              if R3 ^= 4 then  !-- Not BYTE --!
  2518.              begin  !-- Test for certain functions --!
  2519.                 if CLI(#94,FUNC0(2)); = then  !-- NI --!
  2520.                 begin  if CLI(#7F,FUNC0(3)); ^= then SET(PRNT);
  2521.                 end else  !-- Look for all others --!
  2522.                 if CLI(#91,FUNC0(2)); >= and CLI(#97,FUNC0(2)); <=
  2523.                    and CLI(#80,FUNC0(3)); ^= then SET(PRNT);
  2524.              end;
  2525. $END D
  2526.           end;
  2527.           begin  !-- PAR C -- LITERAL VARIABLE -- BITS 32-47 --!
  2528.              case R2 of begin
  2529.                 begin FUNC2:=R0;
  2530.                    if R0 > #FFFF then begin XR:=11; ERROR; end;
  2531.                 end;
  2532.                 begin IC(R2,LENGTH(R3)); R1 := 1 shll R2 - 1;
  2533.                    R3:=LITX; FUNC2:=R3; R3:=LITCOUNT+2; LITCOUNT:=R3;
  2534.                    R0:=R2; R2:=4+LC;
  2535.                    R3:=FUNCCOUNT; if R3^=1 then R2:=R2-2;
  2536.                    R3:=@V1(R7);
  2537.                    if R1 = 0 then R3 := @B3(3);  MAKELITERAL;
  2538.                 end;
  2539.                 begin R1 := R0 - 1; R0 := R0-R0; R2 := 4 + LC;
  2540.                    R3:=LITX; FUNC2:=R3; R3:=LITCOUNT+2; LITCOUNT:=R3;
  2541.                    R3:=FUNCCOUNT; if R3^=1 then R2:=R2-2;
  2542.                    R3 := @STRINGV; MAKELITERAL;
  2543.                 end;
  2544.                 begin  ERROR;
  2545.                 end;
  2546.              end;
  2547.           end;
  2548.           begin  !-- PAR D -- REGISTER -- BITS 16-31 --!
  2549.              if R2 ^= 4 then ERROR;
  2550.              R0 := R0 and #F shll 4;  FUNC1 := R0;
  2551.           end;
  2552.        end;
  2553.     end;
  2554. $PAGE
  2555.  
  2556.     R1 := R1 - XEQ1; case R1 of begin  !-- EXECUTE2'S RULES --!
  2557.     begin !- <FUNC1>      ::= <FUNC2><T NUMBER> -!
  2558.        R2 := 2; ARGUMENT;
  2559.     end;
  2560.     begin !- <FUNC1>      ::= <FUNC2><K REG> -!
  2561.        R2 := 4; ARGUMENT;
  2562.     end;
  2563.     begin !- <FUNC1>      ::= <FUNC2><T CELL> -!
  2564.        R2 := 1; ARGUMENT;
  2565.     end;
  2566.     begin !- <FUNC1>      ::= <FUNC2><STRING> -!
  2567.        R2 := 3; ARGUMENT;
  2568.     end;
  2569.     begin !- <FUNC1>      ::= <FUNC2><FUNC3> -!
  2570.        R1 := FUNC2 and #FFFF;  R2 := FUNC0;
  2571.        R3 := FUNC1 shll 16 or R1; R0 := LITCOUNT;
  2572.        R1 := R2 shrl 8 - #44S; if = then begin XR := 24; ERROR; end;
  2573.        if R0>0 then
  2574.        begin R0 := R0+8S; SLDL(R2,16);
  2575.        end else R0 := 1;
  2576.        STM(R2,R3,STRINGV); R1 := FUNC0 shra 14 + 1 or 1;
  2577.        R2:=2+LC; R3:=@STRINGV; MAKELITERAL; R0:=R0-R0; LITCOUNT:=R0;
  2578.        V(R7):=R0; R0:=V1(R7+4); FUNC0:=R0;
  2579.        R0:=R0 shrl 8 -#44S; if ^= then begin XR:=24; ERROR; end;
  2580.     end;
  2581.     begin !- <FUNC2>      ::= <FUNC ID> ( -!
  2582.        array FT short integer FUNCTYPE=(#0000,#0031,#0071,
  2583.           #0B31,#00B5,#0CB5,#0001,#0005,#000B,#0091,#CB42,
  2584.           #0061,#0081,#0CA5,#00CB,#0007,#0A41,#0B41,#000D,#0009);
  2585.        R0:=FUNCCOUNT+1; FUNCCOUNT:=R0; R0:=FUNC0; V(R7+4):=R0;
  2586.        R0:=R0-R0; LITCOUNT:=R0;
  2587.        R2 := V(R7); SRDL(R2,16); R3 := R3 shrl 16; FUNC0 := R3;
  2588.        R2 := R2 shll 1; R0 := FUNCTYPE(R2) and #FFFF; V(R7) := R0;
  2589.     end;
  2590.     begin !- <FUNC3>      ::= <FUNC1> ) -!
  2591.        R0:=V(R7); if R0^=0 then begin XR:=13; ERROR; end;
  2592.     end;
  2593.     begin !- <CASE HEAD>  ::= CASE <K REG> OF BEGIN -!
  2594.        R0 := 1; R2 := V1(R7);
  2595.        if R0 ^= T1(R7) or R2 = 0 then
  2596.        begin XR := 7; ERROR;
  2597.        end; R1 := #A; R3 := R2; EMIT;
  2598.        R0 := 4; R1 := 8; EMIT;
  2599.        R1 := LC =: V(R7+8); R0 := PTAG =: PROGRAM(R1+4);
  2600.        R0 := #47F0 or R3 =: PROGRAM(R1+2); R1 := @B1(6) =: LC;
  2601.        R0 := ENDCHAIN =: V(R7); R0 := R0 -- R0 =: V(R7+4);
  2602.        R0 := N4; R1 := 14 + N3 =: N3 =: N4;     !-- OPEN BLOCK --!
  2603.        R1 := R1 + LABELBASE; B1(0/12) := ZERO; LABELADR(R1) := R0;
  2604.        R0 := N2; LABEL(R1+4) := R0; R0 := N1; N2 := R0;
  2605.        R0 := DBREG; LABEL(R1) := R0;
  2606.        R0 := PROCBR =: LABEL(R1+6);
  2607.        R0 := 1 =: PROCBR;
  2608.        R0 := PROCLK =: LABELCHAIN(R1);
  2609.        R2 := 1 + BLOCK; BLOCK := R2;
  2610.     end;
  2611.     begin !- <CASE SEQ>   ::= <CASE SEQ><STATEMENT> ; -!
  2612.        R0 := #F0; R2 := V(R7); EMYTBRANCH;
  2613.        R1 := V(R7); PROGRAM(R1+2) := R2;
  2614.        R1 := 2 + V(R7+4) =: V(R7+4);
  2615.     end;
  2616.     end; LM(R1,R5,SAVEREG);
  2617.     end;
  2618. $PAGE
  2619.  
  2620. segment procedure EXECUTE3(R4);  !-- XEQ2 < RULES <= XEQ3 --!
  2621.    begin  !-- LOCAL PROCEDURES FOLLOW --!
  2622.  
  2623.    procedure INITCOND(R4);
  2624.    begin V(R7+8) := R1; R1 := ENDCHAIN =: V(R7) =: V(R7+4);
  2625.    end;
  2626.  
  2627.    segment procedure CLOSEBLOCK(R8);
  2628.    begin array 3 integer SAVE68; integer SAVE8 syn SAVE68(8);
  2629.       STM(R6,R8,SAVE68);
  2630.       R14 := N4 + LABELBASE; R5 := LABELADR(R14) =: N4;
  2631.       R0 := LABEL(R14+6) =: PROCBR; R0 := LABEL(R14+12) =: PROCLK;
  2632.       R1 := N2; if R1 ^= N1 then
  2633.       begin for R2 := R2 -- R2 step 4S until MAXHASH do
  2634.          begin R3 := HASHCHAIN(R2); while R3 >= R1 do
  2635.             begin R3 := R3 + NAMEBASE; R3 := LINK(R3);
  2636.                if R3 ^= ENDCHAIN then R3 := R3 and #FFFF;
  2637.             end; HASHCHAIN(R2) := R3;
  2638.          end; N1 := R1;
  2639.       end; R1 := LABEL(R14+4) and #FFFF =: N2;
  2640.       if R14 ^= LABELBASE then R14 := R14 - 14S;
  2641.       R5 := R5 + LABELBASE; R5 := @B5(14);
  2642.       R6 := R14; R12 := N3 + LABELBASE;
  2643.       R7 := @B14(14); while R7 := @B7(14); R7 <= R12 do
  2644.       if R0 := LABELADR(R7); R0 ^= 0 then
  2645.       begin R1 := LABELCHAIN(R7); CHAINFIXUP;
  2646.       end else
  2647.       begin for R8 := R6 step _14S until R5 do
  2648.          begin if LABEL(R7/10) = LABEL(R8) then
  2649.             begin R0 := LABELCHAIN(R7); R2:= @LABELCHAIN(R8-2);
  2650.                MERGECHAIN; goto X;
  2651.             end;
  2652.          end; R14:= @B14(14); LABEL(R14/14) := LABEL(R7);
  2653.   X:  end; R14 := R14 - LABELBASE =: N3; LM(R6,R7,SAVE68);
  2654.       R2 := BLOCK; REDUCE(R2); BLOCK := R2; R5 := R10;
  2655.       while R2 < BLOCKLEVEL(R5) and ^NODATASEG do
  2656.       begin R2 := 7 + DC and _8 =: DC;
  2657.          R0 := DATAESDEND; R1 := DATAESDADR; CLOSESEG;
  2658.          R2 := PREVSEG(R5); if R2 = ENDCHAIN then
  2659.          begin SET(NODATASEG); R2 := BLOCK; R2 := @B2(1);
  2660.             R0 := R0 -- R0 =: COUNTER(R5) =: PL360NO(R1);
  2661.          end else
  2662.          begin R5 := R2; UNSTACKSEG; R2 := BLOCK; DATAESDEND := R0;
  2663.          end;
  2664.       end; R10 := R5; R8 := SAVE8;
  2665.    end;
  2666.  
  2667.    segment procedure GENMVCLC(R4);
  2668.    begin  SAVE := R4;
  2669.       R0 := V(R7) and #FFFF;  if R0 ^= V(R7) then
  2670.       begin XR := 11;  ERROR;  end;
  2671.       R2 := T(R7);  R3 := R3-R3;  R1 := V(R7+4);
  2672.       if R1 = R3 then  !-- CELL LENGTH NOT GIVEN --!
  2673.       begin  IC(R1,ALENGTH(R2));  R1 := @B1(1);
  2674.       end;  if R1 > 256 then  !-- TOO LONG --!
  2675.       begin XR := 24;  ERROR;  R1 := 256;  end;
  2676.       CLI(1,MCTYPE);  if = then
  2677.       begin  !-- <T NUMBER> --!
  2678.          R3 := T2(R7);  R4 := R4-R4;  IC(R4,ALENGTH(R3));
  2679.          R4 := @B4(1);  R3 := R3 and 3;  if R3 > 1 or R1 > R4 then
  2680.          begin if R1 ^= R4 then
  2681.             begin XR := 1;  ERROR;  end;  R3 := R3 xor 1;
  2682.          end else if R1 <= 3 then
  2683.          begin R3 := 3 - R1; EX(R3,CLC(0,V2(R7),0));
  2684.             if ^= then EX(R3,CLC(0,V2(R7),_1));
  2685.             if ^= then begin XR := 1; ERROR; end;
  2686.             if R3 = 0 then V2(R7/3) := V2(R7+1);
  2687.          end else R3 := 2;
  2688.       end else if < then
  2689.       begin  !-- <T CELL> --!
  2690.          R4 := V(R7+4);  R3 := V2(R7) and #FFFF;
  2691.          if R3 ^= V2(R7) then XR := 11 else
  2692.          begin if R4 ^= 0 or R2 = T2(R7) then goto X;
  2693.             XR := 1;   !-- INVALID TYPES --!
  2694.          end;  ERROR;   !-- EITHER 1 OR 11 --!
  2695.    X: end else
  2696.       begin  !-- <STRING> --!
  2697.          R3 := R3-R3; if R3=V(R7+4) or R1>V2(R7) then R1:=V2(R7);
  2698.          if R1 = 1 then V2(R7+3/1) := STRINGV;
  2699.       end;  V(R7+4) := R1;  REDUCE(R1);
  2700.       CLI(0,MCTYPE);  if ^= then if R1 ^= 0 then
  2701.       begin R0 := R0-R0;  CLI(2,MCTYPE);
  2702.          if = then R3 := @STRINGV else
  2703.          begin R0 := R3;  R3 := @V2(R7);
  2704.          end;  R2 := 4 + LC;
  2705.          MAKELITERAL;  R0 := R0-R0;  V2(R7) := R0;
  2706.       end else
  2707.       begin R3 := V2(R7) and #FF;  R0 := 9;  goto Y;
  2708.       end;  R3 := R1;  R0 := 13;
  2709.    Y: R2 := R2-R2;  R1 := R2;  IC(R1,MCCODE);  STC(R0,MCTYPE);
  2710.       EMIT;  R0 := V(R7);  EDIT;  CLI(13,MCTYPE);
  2711.       if = then  !-- MVC OR CLC --!
  2712.       begin R0 := V2(R7);  EDIT;
  2713.       end;  CLI(5,MCCODE);  if = then
  2714.       begin R1 := V1(R7) =: V(R7+8); R0 := ENDCHAIN =: V(R7) =: V(R7+4);
  2715.       end;  R4 := SAVE;
  2716.    end;
  2717. $PAGE
  2718.     R1 := R1 - XEQ2; case R1 of begin  !-- EXECUTE3'S RULES --!
  2719.     begin !- <PROC2>      ::= <PROC1><K REG> -!
  2720.        R0:=V1(R7); PROCCALL;
  2721.     end;
  2722.     begin !- <CELL ST>    ::= <T CELL> := <K REG> -!
  2723.        R0 := T(R7); R1 := R0 shll 2 + T2(R7); R1 := @TYPETABLE(R1);
  2724.        CLI(0,B1); if = then begin XR := 1; ERROR; end;
  2725.        R0 := R0 + 4; R1 := R1-R1; R2 := V2(R7); R3 := V(R7); EMYT;
  2726.     end;
  2727.     begin !- <CELL ST>    ::= <T CELL> := <T CELL> -!
  2728.        CLC(3,V(R7),V2(R7));  if ^= then
  2729.        begin MCTYPE := 0;  MCCODE := 2;  GENMVCLC;  end;
  2730.     end;
  2731.     begin !- <CELL ST>    ::= <T CELL> := <T NUMBER> -!
  2732.        MCTYPE := 1;  MCCODE := 2;  GENMVCLC;
  2733.     end;
  2734.     begin !- <CELL ST>    ::= <T CELL> := <STRING> -!
  2735.        MCTYPE := 2;  MCCODE := 2;  GENMVCLC;
  2736.     end;
  2737.     begin !- <CELL ST>    ::= <CELL ST><LOG OP><T CELL> -!
  2738.        MCTYPE := 0;  R1 := V1(R7);  STC(R1,MCCODE);  GENMVCLC;
  2739.     end;
  2740.     begin !- <CELL ST>    ::= <CELL ST><LOG OP><T NUMBER> -!
  2741.        MCTYPE := 1;  R1 := V1(R7);  STC(R1,MCCODE);  GENMVCLC;
  2742.     end;
  2743.     begin !- <CELL ST>    ::= <CELL ST><LOG OP><STRING> -!
  2744.        MCTYPE := 2;  R1 := V1(R7);  STC(R1,MCCODE);  GENMVCLC;
  2745.     end;
  2746.     begin !- <SIMPLE ST>  ::= <PROC ID> -!
  2747.        R0 := 16; PROCCALL;
  2748.     end;
  2749.     begin !- <SIMPLE ST>  ::= <FUNC ID> -!
  2750.        R0 := V(R7); EDIT;
  2751.        if R0 > #FFFF then begin XR := 13; ERROR; end;
  2752.     end;
  2753.     begin !- <SIMPLE ST>  ::= <FUNC3> -!
  2754.        R2 := FUNC0; R1 := LC; PROGRAM(R1) := R2;
  2755.        R3 := 2; R4 := R3; R2 := R2 shra 14; if ^= then
  2756.        begin R0 := FUNC1; PROGRAM(R1+2) := R0; if R2 > R3 then
  2757.           begin R0 := FUNC2; PROGRAM(R1+4) := R0; R4 := R4 + R3;
  2758.           end;  R4 := R4 + R3;
  2759.        end;  R1 := R1 + R4;
  2760.        LC := R1;
  2761.        R0:=R0-R0; FUNCCOUNT:=R0;
  2762.     end;
  2763.     begin !- <SIMPLE ST>  ::= <CASE SEQ> END -!
  2764.        R0 := V(R7+4); if R0 = 0 then
  2765.        begin XR := 22; ERROR;
  2766.        end else
  2767.        begin R0 := R0 + LC =: R4 =: LC + PTAG;
  2768.           R1 := V(R7); R3 := PROGRAM(R1+2); if OPTFLAG < #80 then
  2769.           begin R2 := PTAG shrl 12; R2 := @B2(#F0);
  2770.              STC(R2,PROGRAM(R1+1)); PROGRAM(R1+2) := R4; R1 := R3;
  2771.           end; while REDUCE(R4); REDUCE(R4); R3 >= 0 do
  2772.           begin R2 := @B3(4) =: PROGRAM(R4); R3 := PROGRAM(R3+2);
  2773.           end; R2 := V(R7+8); R3 := @B2(6) =: PROGRAM(R4);
  2774.           REDUCE(R4); REDUCE(R4); R4 := R4 + PTAG =: PROGRAM(R2);
  2775.           CHAINFIXUP;
  2776.        end; CLOSEBLOCK;
  2777.     end;
  2778.     begin !- <SIMPLE ST>  ::= <BLOCKBODY> END -!
  2779.        CLOSEBLOCK;
  2780.     end;
  2781.     begin !- <REL OP>     ::= = -!
  2782.        R0 := 7; V(R7) := R0;
  2783.     end;
  2784.     begin !- <CONDITION>  ::= <K REG><REL OP><T CELL> -!
  2785.        R0 := T2(R7); R1 := R0 shll 2 + T(R7); R1 := @TYPETABLE(R1);
  2786.        CLI(0,B1); if = then begin XR := 6; ERROR; end;
  2787.        R0 := R0 + 4; R1 := 9; R2 := V(R7); R3 := V2(R7); EMYT;
  2788.        R1 := V1(R7); INITCOND;
  2789.     end;
  2790.     begin !- <CONDITION>  ::= <K REG><REL OP><T NUMBER> -!
  2791.        R2 := T2(R7); R1 := R2 shll 2 + T(R7); R1 := @TYPETABLE(R1);
  2792.        CLI(0,B1); if = then begin XR := 6; ERROR; end;
  2793.        R1 := R1 - R1; if R1 = V2(R7) and R1 = V2(R7+4) then
  2794.        begin R0 := T(R7); R1 := 2; R2 := V(R7); R3 := R2; EMIT;
  2795.        end else
  2796.        begin R1 := R1-R1; IC(R1,ALENGTH(R2)); IC(R0,LENGTH(R2));
  2797.           R2 := 2 + LC; R3 := @V2(R7); MAKELITERAL;
  2798.           R0 := 4 + T2(R7); R1 := 9; R2 := V(R7); R3 := R3-R3; EMYT;
  2799.        end;
  2800.        R1 := V1(R7); INITCOND;
  2801.     end;
  2802.     begin !- <CONDITION>  ::= <K REG><REL OP><K REG> -!
  2803.        R0 := T(R7);
  2804.        if R0 ^= T2(R7) then begin XR := 6; ERROR; end;
  2805.        R1 := 9; R2 := V(R7); R3 := V2(R7); EMIT;
  2806.        R1 := V1(R7); INITCOND;
  2807.     end;
  2808.     begin !- <CONDITION>  ::= <K REG><REL OP><STRING> -!
  2809.        R0 := STRINGV; R1 := 4 - V2(R7);
  2810.        for R2 := 1 step 1 until R1 do R0 := R0 shrl 8;
  2811.        if R1 < 0 then begin XR := 21; ERROR; end;
  2812.        STRINGV := R0; R0 := 2; R1 := 3; R2 := 2 + LC;
  2813.        R3 := @STRINGV; MAKELITERAL; R0 := T(R7);
  2814.        if R0 ^= 1 then begin XR := 6; ERROR; end;
  2815.        R0 := 5; R1 := 9; R2 := V(R7); R3 := R3-R3; EMYT;
  2816.        R1 := V1(R7); INITCOND;
  2817.     end;
  2818.     begin !- <CONDITION>  ::= <T NUMBER> -!
  2819.        R1 := R7 - 16S;  R1 := S(R1);
  2820.        if R1=REPLIST1 or R1=TDECL3 then SET(FLAG) else
  2821.        begin R0 := 1; if R0 > T(R7) then
  2822.           begin XR := 25; ERROR;
  2823.           end; R1 := V(R7) and #F xor #F;
  2824.           if OPTFLAG < #80 then R1 := @B1(16);  INITCOND;
  2825.        end;
  2826.     end;
  2827.     begin !- <CONDITION>  ::= ^ <T NUMBER> -!
  2828.        R0 := 1; R1 := V1(R7) and #F;
  2829.        if R0 > T1(R7) then begin XR := 25; ERROR; end;
  2830.        if OPTFLAG < #80 then R1 := @B1(16);  INITCOND;
  2831.     end;
  2832.     begin !- <CONDITION>  ::= <T CELL><REL OP><T CELL> -!
  2833.        MCTYPE := 0;  MCCODE := 5;  GENMVCLC;
  2834.     end;
  2835.     begin !- <CONDITION>  ::= <T CELL><REL OP><T NUMBER> -!
  2836.        MCTYPE := 1;  MCCODE := 5;  GENMVCLC;
  2837.     end;
  2838.     begin !- <CONDITION>  ::= <T CELL><REL OP><STRING> -!
  2839.        MCTYPE := 2;  MCCODE := 5;  GENMVCLC;
  2840.     end;
  2841.     begin !- <CONDITION>  ::= <T CELL> -!
  2842.        R0 := #95FFS; EDIT; R0 := V(R7); R1 := T(R7);
  2843.        if R0 > #FFFF then begin XR := 11; ERROR; end else
  2844.        if R1 < 4 then begin XR := 6; ERROR; end;
  2845.        EDIT; R1 := 7; INITCOND;
  2846. $IFT D D
  2847.        if TM(2,DBGFLGS); ON then SET(PRNT); !-- List flag tests --!
  2848. $END D
  2849.     end;
  2850.     begin !- <CONDITION>  ::= ^ <T CELL> -!
  2851.        R0 := #95FFS; EDIT; R0 := V1(R7); R1 := T1(R7);
  2852.        if R0 > #FFFF then begin XR := 11; ERROR; end else
  2853.        if R1 < 4 then begin XR := 6; ERROR; end;
  2854.        EDIT; R1 := 9; INITCOND;
  2855. $IFT D D
  2856.        if TM(2,DBGFLGS); ON then SET(PRNT); !-- List flag tests --!
  2857. $END D
  2858.     end;
  2859.     begin !- <CONDITION>  ::= <REL OP> -!
  2860.        R1 := V(R7); INITCOND;
  2861.        !-- HAD TO TAKE THIS ONE OUT OF THE WOODWORK ... --!
  2862.     end;
  2863.     begin !- <CONDITION>  ::= <RP><PRIM COND> ) -!
  2864.        V(R7/8) := V1(R7); R0 := R0 -- R0 =: V(R7+8);
  2865.     end;
  2866.     begin !- <CONDITION>  ::= <UNARY REG> -!
  2867.        short integer VH syn V(16);  !-- For <UNARY OP> list --!
  2868.        if R0 := 6;  R0 ^= VH(R7) then
  2869.        begin  XR := 0;  ERROR;
  2870.        end;  if R0 := 1;  R0 ^= T(R7) then
  2871.        begin XR := 7;  ERROR;
  2872.        end;  R1 := LC =: V(R7+4);
  2873.        R0 := #460 or V(R7) shll 4 =: PROGRAM(R1);
  2874.        R0 := #47F0S =: PROGRAM(R1+4);
  2875.        R0 := ENDCHAIN =: PROGRAM(R1+2) =: PROGRAM(R1+6);
  2876.        R1 := @B1(4) =: V(R7);  R1 := @B1(4) =: LC;
  2877.        R0 := R0 -- R0 =: V(R7+8);
  2878.     end;
  2879.     begin !- <CONDITION>  ::= ^ <UNARY REG> -!
  2880.        short integer VH syn V(32);  !-- For <UNARY OP> list --!
  2881.        if R0 := 6;  R0 ^= VH(R7) then
  2882.        begin  XR := 0;  ERROR;
  2883.        end;  if R0 := 1;  R0 ^= T1(R7) then
  2884.        begin XR := 7;  ERROR;
  2885.        end;  R1 := LC =: V(R7);
  2886.        R0 := #460 or V1(R7) shll 4 =: PROGRAM(R1);
  2887.        R0 := ENDCHAIN =: V(R7+4) =: PROGRAM(R1+2);
  2888.        R0 := R0 -- R0 =: V(R7+8);  R1 := @B1(4) =: LC;
  2889.     end;
  2890.     begin !- <CONDITION>  ::= <K REG><BRINDX OP><K REG> -!
  2891.        if R0 := 1; R0 ^= T(R7) or R0 ^= T2(R7) then
  2892.        begin XR := 7; ERROR;
  2893.        end; R0 := V1(R7) or V(R7) shll 4 or V2(R7);
  2894.        R1 := LC =: V(R7); PROGRAM(R1) := R0;
  2895.        R0 := ENDCHAIN =: PROGRAM(R1+2) =: V(R7+4);
  2896.        R1 := @B1(4) =: LC; R0 := R0 -- R0 =: V(R7+8);
  2897.     end;
  2898.     begin !- <RP>         ::= ( -!
  2899.        R1 := R7 - 16S; R1 := S(R1);
  2900.        if R1^=IFTERM and R1^=DOTERM and R1^=COMPAOR
  2901.        and R1^=RPTERM and R1^=REPUNTIL then SET(FLAG);
  2902.     end;
  2903.     begin !- <COND>       ::= <CONDITION> -!
  2904.        R1 := R7 - 16S;  R1 := S(R1);
  2905.        if R1 ^= COMPAOR then SET(FLAG);
  2906.     end;
  2907.     begin !- <COMP COND>  ::= <CONDITION> -!
  2908.        if R0 := V(R7+8); R0 ^= 0 then
  2909.        begin R1 := LC; R0 := R0 shll 4 or #4700 =: PROGRAM(R1);
  2910.           R0 := V(R7+4) =: PROGRAM(R1+2);
  2911.           V(R7) := R1; R1 := @B1(4) =: LC;
  2912.        end;
  2913.     end;
  2914.     begin !- <COMP COND>  ::= <COMP AOR><COND> -!
  2915.        if R0 := V1(R7+8); R0 ^= 0 then
  2916.        begin R1 := LC; R0 := R0 shll 4 or #4700 =: PROGRAM(R1);
  2917.           R0 := V(R7) =: PROGRAM(R1+2);
  2918.           V(R7) := R1; R1 := @B1(4) =: LC;
  2919.        end else
  2920.        begin R0 := V1(R7); R2 := @V(R7); MERGECHAIN;
  2921.           R0 := V1(R7+4); R2 := @V(R7+4); MERGECHAIN;
  2922.        end;
  2923.     end;
  2924.     begin !- <COMP AOR>   ::= <COMP COND> AND -!
  2925.        R0 := LC + PTAG; R1 := V(R7+4); CHAINFIXUP; V(R7+4) := R1;
  2926.     end;
  2927.     begin !- <COMP AOR>   ::= <COMP COND> OR -!
  2928.        R3 := @V(R7); ANDTORCHAIN;
  2929.        R0 := LC + PTAG; R1:= V(R7); CHAINFIXUP; V(R7) := R1;
  2930.     end;
  2931.     begin !- <COND END>   ::= <COMP COND> END -!
  2932.        R0 := LC =: V(R7+8); CLOSEBLOCK;
  2933.     end;
  2934.     begin !- <COND THEN>  ::= <COMP COND> THEN -!
  2935.        R0 := LC; V(R7+8) := R0;
  2936.     end;
  2937.     begin !- <GOTO ST*>   ::= GOTO <ID> -!
  2938.        V(R7/10) := V1(R7);
  2939.     end;
  2940.     begin !- <TRUE PART>  ::= <SIMPLE ST> ELSE -!
  2941.        R0 := #F0; EMYTBRANCH; R0 := R0-R0; T(R7) := R0;
  2942.     end;
  2943.     begin !- <TRUE PART>  ::= <GOTO ST*> ELSE -!
  2944.        R0 := 1; T(R7) := R0;
  2945.        R3 := R7 - 16S; R0 := S(R3); R2 := LC;
  2946.        if R0 = CONDEND then
  2947.        begin R1 := V(R3+4); R4 := V(R3);
  2948.           if R4 = ENDCHAIN or R4 := @PROGRAM(R4);
  2949.              CLI(#47,B4); ^= or CLI(#F0,B4(1)); < then
  2950.           begin R4 := R1; R1 := R2; PROGRAM(R1+2) := R4;
  2951.              R0 := #47F0S =: PROGRAM(R1); R2 := @B1(4) =: LC;
  2952.           end;
  2953.        end else if R0 ^= CONDTHEN then goto X else
  2954.        begin ANDTORCHAIN; R1 := V(R3+4); R2 := LC;
  2955.        end; V(R3+8) := R2; R2 := R7; ENTERBRANCH;
  2956.  X: end;
  2957.     begin !- <REPEAT>     ::= REPEAT --!
  2958.        R0 := LC; V(R7) := R0;
  2959.     end;
  2960.     begin !- <WHILE>      ::= WHILE -!
  2961.        R0 := LC; V(R7) := R0;
  2962.     end;
  2963.     begin !- <COND DO>    ::= <COMP COND> DO -!
  2964.        R0 := LC + PTAG; V(R7+8) := R0;
  2965.     end;
  2966.     begin !- <ASS STEP>   ::= <K REG ASS> STEP <T NUMBER> -!
  2967.        R1 := T(R7); R0 := T2(R7);
  2968.        if R1^=1 or R0>1 then begin XR := 2; ERROR; end;
  2969.        T(R7) := R0; R0 := V2(R7); V(R7+4) := R0;
  2970.     end;
  2971.     begin !- <LIMIT>      ::= UNTIL <K REG> -!
  2972.        R0 := 1; if R0 ^= T1(R7) then begin XR := 2; ERROR; end;
  2973.        T(R7) := R0; R1 := V1(R7); V(R7) := R1;
  2974.     end;
  2975.     begin !- <LIMIT>      ::= UNTIL <T CELL> -!
  2976.        R0 := T1(R7); if R0 > 1 then begin XR := 2; ERROR; end;
  2977.        R0 := R0 + 4; T(R7) := R0; R1 := V1(R7); V(R7) := R1;
  2978.     end;
  2979.     begin !- <LIMIT>      ::= UNTIL <T NUMBER> -!
  2980.        R0 := 20; T(R7) := R0; R1 := V1(R7); V(R7) := R1;
  2981.     end;
  2982.     begin !- <DO>         ::= DO -!
  2983.        R0 := #F0; EMYTBRANCH;
  2984.     end;
  2985.     begin !- <IF PART>    ::= <IF><COND END> -!
  2986.        LM(R0,R1,V1(R7)); V(R7) := R0;
  2987.        R0 := V1(R7+8) + PTAG =: R5; CHAINFIXUP;
  2988.        R0 := R5; R1 := R7 - 32S; R1 := V(R1); CHAINFIXUP;
  2989.     end;
  2990.     begin !- <IF PART>    ::= <IF><COND END><STATEMENT-> -!
  2991.        LM(R0,R1,V1(R7)); V(R7) := R0;
  2992.        R0 := V1(R7+8) + PTAG; CHAINFIXUP;
  2993.        R0 := LC + PTAG; R1 := R7 - 32S; R1 := V(R1); CHAINFIXUP;
  2994.     end;
  2995.     begin !- <IF PART>    ::= <IF><COND END><GOTO ST> -!
  2996.        R1 := V1(R7+4); R2 := V1(R7) =: V(R7);
  2997.        if R2 = ENDCHAIN or R2 := @PROGRAM(R2);
  2998.          CLI(#47,B2); ^= or CLI(#F0,B2(1)); < then
  2999.        begin R2 := R1; R1 := LC; PROGRAM(R1+2) := R2;
  3000.           R0 := #47F0S =: PROGRAM(R1); R2 := @B1(4) =: LC;
  3001.        end; R2 := @V2(R7); ENTERBRANCH;
  3002.        R0 := LC + PTAG; R1 := R7 - 32S; R1 := V(R1); CHAINFIXUP;
  3003.     end;
  3004.     begin !- <IF PART>    ::= <IF><COND END><TRUE PART><STATEMENT-> -!
  3005.        if R0 := T2(R7); R0 ^= 0 then R0 := V1(R7+8) else
  3006.        begin R0 := V1(R7+8) + PTAG; R1 := V1(R7+4); CHAINFIXUP;
  3007.           R0 := LC+PTAG; R1 := V2(R7); CHAINFIXUP; R0 := 4+V2(R7);
  3008.        end;
  3009.        R0 := R0 + PTAG; R1 := R7 - 32S; R1 := V(R1); CHAINFIXUP;
  3010.        R0 := V1(R7) =: V(R7);
  3011.     end;
  3012.     begin !- <IF PART>    ::= <IF><COND END><TRUE PART><GOTO ST> -!
  3013.        R1 := R7 - 32S; R1 := V(R1); R2 := @V(R7+48); ENTERBRANCH;
  3014.        R0 := V1(R7) =: V(R7);
  3015.        if R0 := T2(R7); R0 = 0 then
  3016.        begin R0 := V1(R7+8) + PTAG; R1 := V1(R7+4); CHAINFIXUP;
  3017.           R0 := V2(R7) =: LC;
  3018.        end;
  3019.     end;
  3020.     begin !- <STATEMENT+> ::= <BLOCKBODY><IF PART> -!
  3021.        R0 := V1(R7) =: V(R7);
  3022.     end;
  3023.     begin !- <STATEMENT-> ::= <IF><COND THEN><STATEMENT-> -!
  3024.        R0 := V1(R7+8) + PTAG; R1 := V1(R7+4); CHAINFIXUP;
  3025.        R0 := LC + PTAG; R1 := V1(R7); CHAINFIXUP;
  3026.     end;
  3027.     begin !- <STATEMENT-> ::= <IF><COND THEN><GOTO ST> -!
  3028.        R3 := @V1(R7); ANDTORCHAIN;
  3029.        R1 := V1(R7+4); R2 := @V2(R7); ENTERBRANCH;
  3030.        R0 := LC + PTAG; R1 := V1(R7); CHAINFIXUP;
  3031.     end;
  3032.     begin !- <STATEMENT-> ::= <IF><COND THEN><TRUE PART><STATEMENT-> -!
  3033.        if R0 := T2(R7); R0 ^= 0 then R0 := V1(R7+8) else
  3034.        begin R0 := V1(R7+8) + PTAG; R1 := V1(R7+4); CHAINFIXUP;
  3035.           R0 := LC + PTAG; R1 := V2(R7) =: R5; CHAINFIXUP;
  3036.           R0 := @B5(4);
  3037.        end;
  3038.        R0 := R0 + PTAG; R1 := V1(R7); CHAINFIXUP;
  3039.     end;
  3040.     begin !- <STATEMENT-> ::= <IF><COND THEN><TRUE PART><GOTO ST> -!
  3041.        if R0 := T2(R7); R0 ^= 0 then
  3042.        begin LM(R1,R2,V1(R7)); if R2 = ENDCHAIN or R2 := @PROGRAM(R2);
  3043.              CLI(#47,B2); ^= or CLI(#F0,B2(1)); < then
  3044.           begin R2 := R1; R1 := LC; PROGRAM(R1+2) := R2;
  3045.              R0 := #47F0S =: PROGRAM(R1); R2 := @B1(4) =: LC;
  3046.           end;
  3047.        end else
  3048.        begin R0 := V1(R7+8) + PTAG; R1 := V1(R7+4); CHAINFIXUP;
  3049.           R0 := V2(R7) =: LC; R1 := V1(R7);
  3050.        end;
  3051.        R2 := @V(R7+48); ENTERBRANCH;
  3052.     end;
  3053.     begin !- <STATEMENT-> ::= <WHILE><COND DO><STATEMENT+> -!
  3054.        R0 := V1(R7+8); R1 := V1(R7+4); CHAINFIXUP;
  3055.        R0 := V(R7) + PTAG; R1 := V2(R7); CHAINFIXUP;
  3056.     end;
  3057.     begin !- <STATEMENT-> ::= <WHILE><COND DO><STATEMENT*> -!
  3058.        if R1 := V1(R7); R1 := @B1(4); R1 ^= LC then
  3059.        begin  !-- NORMAL CASE, NOT A NULL STATEMENT --!
  3060.           R0 := V1(R7+8); R1 := V1(R7+4); CHAINFIXUP;
  3061.           R0 := #F0; R2 := V(R7); EMYTBRANCH;
  3062.           R1 := V(R7); R0 := R2 + PTAG; CHAINFIXUP;
  3063.        end else
  3064.        begin  !-- HERE TO OPTIMIZE A NULL STATEMENT --!
  3065.           R3 := @V1(R7); ANDTORCHAIN;
  3066.           R0 := V(R7) + PTAG; R1 := V1(R7+4); CHAINFIXUP;
  3067.        end;
  3068.        R0 := LC + PTAG; R1 := V1(R7); CHAINFIXUP;
  3069.     end;
  3070.     end; LM(R1,R5,SAVEREG);
  3071.     end;
  3072. $PAGE
  3073. segment procedure EXECUTE4(R4);  !-- XEQ3 < RULES <= XEQ4 --!
  3074.     begin  procedure MOVEID (R1);
  3075.     begin  V(R7/10) := V1(R7); R0 := T1(R7); STC(R0,T(R7));
  3076.     end;   procedure TAGCELL (R5);  !-- DOES NOT RETURN --!
  3077.     begin  if R3 >= 4096S then begin XR := 12; ERROR; end;
  3078.        R0 := DBREG shll 12 or R3; R1 := @V1(R7);
  3079.        DC1 := R3; R3 := R3 + V(R7); DC := R3;
  3080.        R4 := DATAESDADR;  R3 := PL360NO(R4);
  3081.        R3 := R3 shll 8;  R2 := R2 or R3;  R3 := T1(R7);
  3082. $IFT M M
  3083.        if TESTFLAG then ENTERSYMDATA;
  3084. $END M
  3085.        ENTERNAME;  goto EXIT;
  3086.     end;
  3087.     R1 := R1 - XEQ3;  case R1 of begin  !-- EXECUTE4'S RULES --!
  3088.     begin !- <STATEMENT-> ::= <REPEAT> UNTIL <PRIM COND> -!
  3089.        R0 := V(R7) + PTAG; R1 := V2(R7); CHAINFIXUP;
  3090.        R0 := LC + PTAG; R1 := V2(R7+4); CHAINFIXUP;
  3091.     end;
  3092.     begin !- <STATEMENT-> ::= FOR <ASS STEP><LIMIT><DO><STATEMENT*> -!
  3093.        R5 := V1(R7+4); R2 := V1(R7); R1 := 10; EMITLIT;
  3094.        R1 := V(R7+48); R0 := LC + PTAG;
  3095.        PROGRAM(R1+2) := R0; R0 := T2(R7);
  3096.        R1 := 9; R2 := V1(R7); R3 := V2(R7); R5 := R3;
  3097.        if R0 = 1 then EMIT else
  3098.        if R0 = 20S then EMITLIT else EMYT;
  3099.        R0 := 4; R1 := 7; R3 := 4 + V(R7+48) + PTAG;
  3100.        R2 := V1(R7+4); if R2 >= 0 then R2 := 12 else R2 := 10; EMYT;
  3101.     end;
  3102.     begin !- <STATEMENT*> ::= <GOTO ST> -!
  3103.        R1 := LC; R0 := #47F0S; PROGRAM(R1) := R0;
  3104.        R0 := ENDCHAIN; PROGRAM(R1+2) := R0; R0 := 4 + R1; LC := R0;
  3105.        R2 := @V(R7); ENTERBRANCH;
  3106.     end;
  3107.     begin !- <SI T TYPE>  ::= SHORT INTEGER -!
  3108.        R0 := R0-R0; T(R7) := R0; R0 := 2; V(R7) := R0;
  3109.     end;
  3110.     begin !- <SI T TYPE>  ::= INTEGER -!
  3111.        R0 := 1; T(R7) := R0; R0 := 4; V(R7) := R0;
  3112.     end;
  3113.     begin !- <SI T TYPE>  ::= LOGICAL -!
  3114.        R0 := 1; T(R7) := R0; R0 := 4; V(R7) := R0;
  3115.     end;
  3116.     begin !- <SI T TYPE>  ::= REAL -!
  3117.        R0 := 3; T(R7) := R0; R0 := 4; V(R7) := R0;
  3118.     end;
  3119.     begin !- <SI T TYPE>  ::= LONG REAL -!
  3120.        R0 := 2; T(R7) := R0; R0 := 8; V(R7) := R0;
  3121.     end;
  3122.     begin !- <SI T TYPE>  ::= BYTE -!
  3123.        R0 := 4; T(R7) := R0; R0 := 1; V(R7) := R0;
  3124.     end;
  3125.     begin !- <SI T TYPE>  ::= CHARACTER -!
  3126.        R0 := 4; T(R7) := R0; R0 := 1; V(R7) := R0;
  3127.     end;
  3128.     begin !- <T TYPE>     ::= <SI T TYPE> -!
  3129.        RESET(FILLFLAG);  !-- No dynamic fill --!
  3130.     end;
  3131.     begin !- <T TYPE>     ::= ARRAY <T NUMBER><SI T TYPE> -!
  3132.        R1 := T2(R7); T(R7) := R1; R0 := T1(R7);
  3133.        R1 := V2(R7); R2 := V1(R7); RESET(FILLFLAG);
  3134.        if R2 = DTFILL then  !-- DATAFILL --!
  3135.        begin  R2 := R2-R2;  SET(FILLFLAG);
  3136.        end;  if R0>1 or R2<0 then  !-- INVALID NUMBER --!
  3137.        begin XR := 25; ERROR;
  3138.        end else R1 := R1 * R2; V(R7) := R1;
  3139.     end;
  3140.     begin !- <FILL>       ::= <STRING> -!
  3141.        if SKIPFLAG then goto X;
  3142.        R1 := V(R7); SETDATAINIT; if R1 = 0 then goto X;
  3143.        REDUCE(R1);  EX(R1,MVC(0,B2,STRINGV));
  3144.  X: end;
  3145.     begin !- <FILL>       ::= <ADR OP><T CELL> -!
  3146.        if SKIPFLAG then goto X;
  3147.        R5 := FILLTYPE; R1 := R1-R1; IC(R1,ALENGTH(R5));
  3148.        R1 := @B1(1); SETDATAINIT; if R1 = 0 then goto X;
  3149.        R0:=V1(R7); R1:=V(R7); if R1=0 then
  3150.        begin if R5>1 then XR:=24 else
  3151.           if R5=0 and R0>#FFFF then XR:=11 else
  3152.           begin if R5=0 then B2(0/2) := V1(R7+2) else
  3153.              B2(0/4) := V1(R7); goto X;
  3154.           end;
  3155.        end else
  3156.        begin if R5^=1 then XR:=24 else
  3157.           if R0>#FFFF then XR:=11 else
  3158.           if REPFLAG then XR:=30 else goto Z;
  3159.        end;
  3160.        ERROR; SET(SKIPFLAG); goto X;
  3161.  Z:    R1:=R0 and #FFF; R4:=V1(R7+4) shll 24;
  3162.        R1:=R1 or R4;  V1(R7):= R1;  MVC(3,B2,V1(R7));
  3163.        R4:=V1(R7+8) shrl 8;   !-- R4=SEGMENT NUMBER --!
  3164.        R3 := R4*10S;  R3 := @ESDNAME(R3);
  3165.        if R4 >= MAXSEGNO or B3 = "DUMMY   " then
  3166.        if SEGTYPE(R10) > 2 then goto X else
  3167.        begin  XR := 30; ERROR; goto X;
  3168.        end;
  3169.        R0:=DATAESDEND;R1:=DATAESDADR; R2:=ER; R3:=ATYPE; FINDESDENTRY;
  3170.        if R0=DATAESDEND then  !-- NOT A NEW ENTRY --!
  3171.        begin R2:=RLD; R5:=R1-DATAESDADR; R1:=R0; FINDESDENTRY;
  3172.           ESDLINK(R1):=R5;  !-- RLD ENTRY POINTING TO MAIN ENTRY --!
  3173.        end;
  3174.        DATAESDEND:=R0; R0:=DC1-4; RLDADDR(R1):=R0;
  3175.  X: end;
  3176.     begin !- <FILL>       ::= <ADR OP><PROC ID> -!
  3177.        if SKIPFLAG then goto X;
  3178.        R5:=FILLTYPE; R1:=R1-R1; IC(R1,ALENGTH(R5));
  3179.        R1 := @B1(1); SETDATAINIT; if R1=0 then goto X;
  3180.        R0:=V1(R7) shrl 24; R1:=V(R7); if R1=0 then
  3181.        begin if R5>1 then XR:=24 else
  3182.           begin  R0:=V1(R7); SRDL(R0,12); R0:=R0 shrl 8 and #F;
  3183.              SLDL(R0,12); V1(R7):=R0; if R5=0 then
  3184.              B2(0/2) := V1(R7+2) else B2(0/4) := V1(R7); goto X;
  3185.           end;
  3186.        end else
  3187.        begin if R5^=1 then XR:=24 else
  3188.           if REPFLAG then XR:=30 else goto Z;
  3189.        end;
  3190.        ERROR; SET(SKIPFLAG); goto X;
  3191.  Z:    R1:=V1(R7) and #FFF; V1(R7):=R1; B2(0/4) := V1(R7); R4:=R0;
  3192.        R0:=DATAESDEND;R1:=DATAESDADR; R2:=ER; R3:=ATYPE; FINDESDENTRY;
  3193.        if R0=DATAESDEND then  !-- NOT A NEW ENTRY --!
  3194.        begin R2:=RLD; R5:=R1-DATAESDADR; R1:=R0; FINDESDENTRY;
  3195.           ESDLINK(R1):=R5;  !-- RLD ENTRY POINTING TO MAIN ENTRY --!
  3196.        end;
  3197.        DATAESDEND:=R0; R0:=DC1-4; RLDADDR(R1):=R0;
  3198.  X: end;
  3199.     begin !- <FILL>       ::= <T NUMBER> -!
  3200.        if SKIPFLAG then goto X;
  3201.        R5 := FILLTYPE; R1 := R1-R1; IC(R1,ALENGTH(R5));
  3202.        R1 := @B1(1); SETDATAINIT; if R1 = 0 then goto X;
  3203.        IC(R5,LENGTH(R5)); R5 := @B5(1);
  3204.        case R5 of begin
  3205.           B2(0/1) := V(R7+3);  !-- BYTE FILL --!
  3206.           B2(0/2) := V(R7+2);  !-- HALF WORD FILL --!
  3207.           B2(0/4) := V(R7);  !-- FULL WORD FILL --!
  3208.           begin  !-- DOUBLE WORD FILL --!
  3209.              R3 := T(R7); if R3 = 1 then
  3210.              begin LM(R3,R4,V(R7)); R5 := R3; STM(R4,R5,V(R7));
  3211.              end; B2(0/8) := V(R7);
  3212.           end;
  3213.        end;
  3214.  X: end;
  3215.     begin !- <FILL>       ::= <REP LIST2> ) -!
  3216.        if SKIPFLAG then goto X;
  3217.        R1 := V(R7) - 1; if R1 = 0 then goto X;
  3218.        R5 := DC1 - V(R7+4); R1 := R1 * R5;
  3219.        SETDATAINIT; if R1 = 0 then goto X;
  3220.        R4 := R2; R2 := R1 - 1; R1 := R1 + R4; R3 := V(R7+8);
  3221.        while R4 < R1 do
  3222.        begin  R5 := R2;  while R5 >= 256S do
  3223.           begin  B4(0/256) := B3;  !-- MOVE DATA FIELD --!
  3224.              R3 := @B3(256);  R4 := @B4(256);  R5 := R5 - 256S;
  3225.           end;  EX(R5,MVC(0,B4,B3));  R4 := @B4(R5+1);
  3226.        end;
  3227.  X:    R0 := T(R7);  STC(R0,SKIPFLAG);
  3228.        R0:=R0 shrl 8; STC(R0,REPFLAG);
  3229.     end;
  3230.     begin !- <REP LIST1>  ::= <T NUMBER> ( -!
  3231.        IC(R2,REPFLAG); R2:=R2 shll 8;
  3232.        R0 := V(R7); R1 := T(R7); IC(R2,SKIPFLAG); T(R7) := R2;
  3233.        if R0<0 or R1>1 then begin XR := 25; SET(SKIPFLAG); ERROR; end;
  3234.        if R0=0 then SET(SKIPFLAG) else if R0>1 then SET(REPFLAG);
  3235.        R1 := R1-R1; SETDATAINIT; V(R7+8) := R2;
  3236.        R0 := DC1; V(R7+4) := R0;
  3237.     end;
  3238.     begin !- <REP LIST1>  ::= ( -!
  3239.        R1 := R7 - 16S; R2 := S(R1); if R2 = REPLIST1 or R2 = TDECL3 then
  3240.        begin
  3241.           R0 := 1; V(R7) := R0; R0 := DC1; V(R7+4) := R0;
  3242.           IC(R2,REPFLAG); R2:=R2 shll 8;
  3243.           IC(R2,SKIPFLAG); T(R7) := R2;
  3244.           R1 := R1-R1; SETDATAINIT; V(R7+8) := R2;
  3245.        end else SET(FLAG);
  3246.     end;
  3247.     begin !- <T DECL1>    ::= <T TYPE><ID> -!
  3248.        if NODATASEG then DATASEGERROR;
  3249.        R1 := R1-R1; R2 := T(R7); IC(R1,ALENGTH(R2));
  3250.        R3 := DC+R1; R1 := @B1(1); R1 := neg R1; R3 := R3 and R1;
  3251. $IFT D D
  3252.        if R3 ^= DC then SET(PRNT);
  3253. $END D
  3254.        TAGCELL;  !-- DOES NOT RETURN HERE --!
  3255.     end;
  3256.     begin !- <T DECL1>    ::= <T DECL2><ID> -!
  3257.        R3 := DC; R2 := T(R7);
  3258.        TAGCELL;  !-- DOES NOT RETURN HERE --!
  3259.     end;
  3260.     begin !- <T DECL1>    ::= <T TYPE> -!
  3261.        if NODATASEG then DATASEGERROR;
  3262.        R1 := R1 - R1; R2 := T(R7); IC(R1,ALENGTH(R2));
  3263.        R3 := DC+R1; R1 := @B1(1); R1 := neg R1; R3 := R3 and R1;
  3264.        if R3 > 4096S then begin XR := 12; ERROR; end;
  3265. $IFT D D
  3266.        if R3 ^= DC then SET(PRNT);
  3267. $END D
  3268.        DC1 := R3; R3 := R3 + V(R7); DC := R3;
  3269.     end;
  3270.     begin !- <T DECL1>    ::= <T DECL2> -!
  3271.        R3 := DC; if R3 > 4096S then begin XR := 12; ERROR; end;
  3272.        DC1 := R3; R3 := R3 + V(R7); DC := R3;
  3273.     end;
  3274.     begin !- <T DECL3>    ::= <T DECL1> = -!
  3275.        R0 := T(R7); FILLTYPE := R0; R0 := SEGTYPE(R10);
  3276.        if R0 ^= 2 then RESET(SKIPFLAG) else
  3277.        begin XR := 30; ERROR;
  3278.        end;
  3279.     end;
  3280.     begin !- <T DECL4>    ::= <T DECL3><FILL> -!
  3281.        R2 := T(R7);  R1 := R1-R1;  IC(R1,ALENGTH(R2));
  3282.        R2 := DC + R1;  R1 := @B1(1);  R1 := neg R1;
  3283.        R2 := R2 and R1;  !-- New ending --!
  3284. $IFT D D
  3285.        if R2 ^= DC then SET(PRNT);  !-- Non-aligned --!
  3286. $END D
  3287.        DC := R2;  SET(SKIPFLAG);
  3288.     end;
  3289.     begin !- <FUNC DC2>   ::= <FUNC DC1><ID> -!
  3290.        MOVEID;   !-- MOVE V AND T FIELDS --!
  3291.     end;
  3292.     begin !- <FUNC DC4>   ::= <FUNC DC3><T NUMBER> -!
  3293.        R1 := V1(R7);
  3294.        if R1 < 0 or R1 >= FT then
  3295.        begin XR := 23; ERROR; R1 := R1-R1;
  3296.        end;
  3297.        STC(R1,T(R7+1));
  3298.     end;
  3299.     begin !- <FUNC DC6>   ::= <FUNC DC5><T NUMBER> -!
  3300.        array FT byte TYPE =  !-- Function lengths --!
  3301.           (_2,_2,0,0,0,2,_2,_2,0,0,2,0,0,2,2,0,0,0,0,0);
  3302.        R2 := V1(R7);  R3 := T(R7);  R1 := #FF and R3;
  3303.        if R2 < 0 or R2 > #FFFF then goto ERR;
  3304.        R0 := R1 shll 16 or R2;  R3 := R3 shrl 8;
  3305.        R2 := R2 shrl 14 - 1 and #FE;  IC(R1,TYPE(R1));
  3306.        if R1 ^= R2 then goto ERR;
  3307.        R1 := @V(R7);  R2 := 11;  ENTERNAME;  goto X;
  3308.  ERR:  XR := 23;  ERROR;
  3309.  X: end;
  3310.     begin !- <SYN DC1>    ::= <T TYPE><ID> SYN -!
  3311.        MOVEID;   !-- MOVE V AND T FIELDS --!
  3312.     end;
  3313.     begin !- <SYN DC1>    ::= <SI T TYPE> REGISTER <ID> SYN -!
  3314.        R0 := T(R7); V(R7/10) := V2(R7);
  3315.        if R0=0 or R0>3S then begin XR := 7; ERROR; R0 := 1; end;
  3316.        R0 := R0 + 80S; T(R7) := R0; R0 := T2(R7); STC(R0,T(R7));
  3317.     end;
  3318.     begin !- <SYN DC1>    ::= <SYN DC3><ID> SYN -!
  3319.        MOVEID;   !-- MOVE V AND T FIELDS --!
  3320.     end;
  3321.     begin !- <SYN DC2>    ::= <SYN DC1><T CELL> -!
  3322.        R0 := V1(R7); R1 := @V(R7); R2 := T(R7);
  3323.        R3 := R2 shrl 8; R2 := R2 and #FF;
  3324.        if R2 > 80S then begin XR := 26; ERROR; end else begin
  3325. $IFT M M
  3326.           if TESTFLAG then ENTERSYMDATA;
  3327. $END M
  3328.           R2 := R2 or V1(R7+8);  ENTERNAME;  end;
  3329.     end;
  3330.     begin !- <SYN DC2>    ::= <SYN DC1><T NUMBER> -!
  3331.        R0 := V1(R7); R1 := @V(R7); R2 := T(R7);
  3332.        R3 := R2 shrl 8; R2 := R2 and #FF; R4 := T1(R7);
  3333.        if R0<0 or R4>1 then begin XR := 25; ERROR; end else
  3334.        if R2 > 80S then begin XR := 26; ERROR; end else
  3335.        begin  R2 := R2 or #FF00;  ENTERNAME;  end;
  3336.     end;
  3337.     begin !- <SYN DC2>    ::= <SYN DC1><K REG> -!
  3338.        R0 := V1(R7); R1 := @V(R7); R2 := T(R7);
  3339.        R3 := R2 shrl 8; R2 := R2 and #FF;
  3340.        if R2 < 80S then begin XR := 26; ERROR; end else ENTERNAME;
  3341.     end;
  3342.     begin !- <EQUATE>     ::= SHORT EQUATE -!
  3343.        R0 := 15;  S(R7-2) := R0;  !-- SHORT EQUATE type --!
  3344.     end;
  3345.     begin !- <EQUATE>     ::= EQUATE -!
  3346.        R0 := 12;  S(R7-2) := R0;  !-- EQUATE type --!
  3347.     end;
  3348.     begin !- <PROC HD1>   ::= PROCEDURE <ID> -!
  3349.        R2 := 10; R3 := T1(R7); T(R7) := R3;
  3350. $IFT M M
  3351.        if TESTFLAG then
  3352.        begin R0 := LC; R1 := 3; ENTERSYMLABEL;
  3353.        end;
  3354. $END M
  3355.        R1 := @V1(R7); R0 := R0-R0;
  3356.        ENTERNAME; V(R7) := R4;
  3357.     end;
  3358.     begin !- <PROC HD3>   ::= <PROC HD2><K REG> -!
  3359.        R1 := V1(R7); R2 := T1(R7); V(R7+4) := R1;
  3360.        if R2^=1 or R1=0 then
  3361.        begin XR := 7; ERROR;
  3362.        end;
  3363.     end;
  3364.     begin !- <PROC HD5>   ::= GLOBAL <PROC HD4> -!
  3365.        R1 := R7 - 16S;  R1 := S(R1);
  3366.        if R1 = ENDFILE then SET(FLAG) else
  3367.        begin
  3368.           R0 := 1; T(R7) := R0; V(R7/8) := V1(R7); OPENPROCSEG;
  3369.           R2 := CSEGNO*10S; R2 := @ESDNAME(R2); R1 := T1(R7) - 1;
  3370.           R3 := V(R7); B2(0/10) := BLANK; EX(R1,MVC(0,B2,NAME(R3)));
  3371.        end;
  3372.     end;
  3373.     begin !- <PROC HD5>   ::= EXTERNAL <PROC HD4> -!
  3374.        R0 := 3; T(R7) := R0; V(R7/8) := V1(R7); OPENPROCSEG;
  3375.        R2 := CSEGNO * 10S; R2 := @ESDNAME(R2); R1 := T1(R7) - 1;
  3376.        R3 := V(R7); B2(0/10) := BLANK; EX(R1,MVC(0,B2,NAME(R3)));
  3377.     end;
  3378.     begin !- <PROC HD5>   ::= SEGMENT <PROC HD4> -!
  3379.        R0 := 1; T(R7) := R0; V(R7/8) := V1(R7); OPENPROCSEG;
  3380.        R2 := CSEGNO; CVD(R2,CONWORK); R2 := R2 * 10S;
  3381.        R2:=@ESDNAME(R2); B2(0/10) := SEGNAM;
  3382.        UNPK(2,7,B2(4),CONWORK); SETZONE(B2(6));
  3383.     end;
  3384.     begin !- <PROC HD6>   ::= COMMON <PROC HD4> -!
  3385.        R5 := LC; if R5 ^= PROCBR then
  3386.        begin PROCLK := R5; R4 := #47F0S; PROGRAM(R5) := R4;
  3387.           R5 := @B5(4);
  3388.        end;  V(R7/8) := V1(R7);  R0 := R0-R0;  T(R7) := R0;
  3389. $IFT M M
  3390.        if TESTFLAG then
  3391.        begin  R4 := PROCPTR;  DISPFIELD(R4) := R5;  end;
  3392. $END M
  3393.        INCRSEGNO;  R4 := R0;  R1 := PROGESDADR;
  3394.        R2 := PBREG;  R3 := R2 shll 4 + R2 + #5800S;
  3395.        PROGRAM(R5) := R3;  R0 := RLDADDR(R1);  PROGRAM(R5+2) := R0;
  3396.        RLDADDR(R1) := R5;  R3 := ATYPE;  R2 := LD;
  3397.        R0 := PROGESDEND;  FINDESDENTRY;  PROGESDEND := R0;
  3398.        RLDADDR(R1) := R5;  R5 := @B5(4);  LC := R5;
  3399.        R4 := R4 * 10S;  R4 := @ESDNAME(R4);  R3 := V(R7);
  3400.        B4(0/10) := BLANK;  R2 := T1(R7) - 1;
  3401.        EX(R2,MVC(0,B4,NAME(R3)));  ADR(R3+2) := R5;
  3402.        R0 := CSEGNO shll 8;  R1 := PBREG shll 4
  3403.           or R0 or V(R7+4);  ADR(R3) := R1;
  3404.     end;
  3405.     begin !- <PROC HD6>   ::= <PROC HD4> -!
  3406.        R5 := LC; if R5 ^= PROCBR then
  3407.        begin PROCLK := R5; R4 := #47F0S; PROGRAM(R5) := R4;
  3408.           R5 := R5 + 4; LC := R5;
  3409.        end;
  3410. $IFT M M
  3411.        if TESTFLAG then
  3412.        begin  R4 := PROCPTR;  DISPFIELD(R4) := R5;  end;
  3413. $END M
  3414.        R4 := V(R7); ADR(R4+2) := R5; R0 := CSEGNO shll 8;
  3415.        R1 := PBREG shll 4 or R0 or V(R7+4); ADR(R4) := R1;
  3416.        R0 := R0-R0; T(R7) := R0;
  3417.     end;
  3418.     begin !- <PROC HD6>   ::= <PROC HD5> -!
  3419.       R1 := V(R7); R2 := PBREG shll 4 or V(R7+4);
  3420.       R4 := CSEGNO shll 8 or R2; ADR(R1) := R4;
  3421.     end;
  3422.     begin !- <PROC HD6>   ::= <PROC HD5> BASE <K REG> -!
  3423.       R0 := T2(R7); R1 := V2(R7); PBREG := R1;
  3424.       if R0^=1 or R1=0 then begin XR := 7; ERROR; end;
  3425.       R1 := V(R7); R2 := PBREG shll 4 or V(R7+4);
  3426.       R4 := CSEGNO shll 8 or R2; ADR(R1) := R4;
  3427.     end;
  3428.     begin !- <PROC HD7>   ::= <PROC HD6> ; -!
  3429.        R1 := PBREG shll 12; PTAG := R1;
  3430.     end;
  3431.     begin !- <GLOB HD1>   ::= GLOBAL <PROC HD4> -!
  3432.        R0 := 1; T(R7) := R0; V(R7/8) := V1(R7); OPENPROCSEG;
  3433.        R2 := CSEGNO * 10S; R2 := @ESDNAME(R2); R1 := T1(R7) - 1;
  3434.        R3 := V(R7); B2(0/10) := BLANK; EX(R1,MVC(0,B2,NAME(R3)));
  3435.        if SEGNAM = "SEG" then
  3436.        begin  SEGNAM(1) := "NN";  R3 := 2;
  3437.           if R1 > R3 then R1 := R3;  EX(R1,MVC(0,SEGNAM,B2));
  3438.        end;
  3439.     end;
  3440.     begin !- <GLOB HD>    ::= <GLOB HD1> BASE <K REG> -!
  3441.       R0 := T2(R7); R1 := V2(R7); PBREG := R1;
  3442.       if R0^=1 or R1=0 then begin XR := 7; ERROR; end;
  3443.     end;
  3444.     end; EXIT: LM(R1,R5,SAVEREG);
  3445.     end;
  3446. $PAGE
  3447.  segment procedure BRANCHFIXUP(R8);
  3448.  begin  !-- This routine does branch optimization --!
  3449.     dummy base R2;
  3450.        byte OPCODE, COND;
  3451.        short integer NEXT;
  3452.        short integer OP syn OPCODE;
  3453.     close base;
  3454.     short integer WORK syn CONWORK;
  3455.     R12 := N6 =: R0 + BRANCHBASE; R1 := BRANCHADR(R12) =: N6;
  3456.     R3 := N5 + BRANCHBASE; R0 := R0 - 4S; if < then R0 := R0 -- R0;
  3457.     N5 := R0; while R12 := @B12(4); R12 <= R3 do
  3458.     begin R2 := BRANCHADR(R12) and #FFFF;
  3459.        if OPTFLAG < #80 then goto B;  R0 := @PROGRAM(0) - PTAG;
  3460.        while R2 := R2 + R0; OPCODE=#07 or OPCODE=#47 do
  3461.        begin if OPCODE = #07 then
  3462.           begin if TM(#0F,COND); OFF or TM(#F0,COND); OFF then
  3463.              R2 := @B2(2) - R0 else
  3464.              if MIXED then goto A else R2 := OP shll 12;
  3465.           end else
  3466.           if TM(#F0,COND); OFF then R2 := @B2(4) - R0 else
  3467.           if CLI(#F0,COND); ^= then goto A else
  3468.           begin if R1 := NEXT; R1 >= ENDCHAIN and R1 < 4096S then
  3469.              begin R0 := BRANCHAIN(R12) =: NEXT; R0 := R1; R4 := R2;
  3470.                 while R1 := NEXT; R1 ^= ENDCHAIN and
  3471.                       if < or R1 >= 4096S then goto X;
  3472.                       R14 := @PROGRAM(R1); R14 ^= R4 do R2 := R14;
  3473.                 NEXT := R0; if R1 = ENDCHAIN then goto X;
  3474.                 BRANCHAIN(R12) := R1; R2 := BRANCHADR(R12);
  3475.              end else R2 := R1;
  3476.           end; R2 := R2 and #FFFF; R1 := R2 and #F000;
  3477.           if R1 ^= PTAG then goto B;
  3478.           if R1 := BRANCHADR(R12) and #FFFF; R2 = R1 then
  3479.           begin R1 := 1 + ERRCOUNT =: ERRCOUNT;
  3480.              if R1 > ERRLIMIT then goto B;
  3481.              WBUFF(0/125) := BLANK; WBUF(11) := "INFINITE LOOP AT";
  3482.              WORK := R2; NI(#0F,WORK); UNPK(4,2,WBUF(12+STRING),WORK);
  3483.              TR(3,WBUF(12+STRING),TRTABLE(_240));
  3484.              WBUF(16+STRING) := " "; WBUF(108) := "*";
  3485.              WBUF(109/16) := WBUF(108); RESET(RUNFLAG);
  3486.              if GENFLAG then RESET(GENDECK); PRINT;
  3487.              if R1 = ERRLIMIT then ENDMESSAGES;
  3488.              goto B;
  3489.           end;
  3490.        end;
  3491.  A:    R2 := R2 -- R0;
  3492.  B:    R1 := BRANCHAIN(R12); while R1 >= 0 do
  3493.        begin R0 := PROGRAM(R1+2); PROGRAM(R1+2) := R2; R1 := R0;
  3494.        end;
  3495.  X: end;
  3496.  end;
  3497. $PAGE
  3498.  procedure SETNAME (R4);
  3499.  begin  R0 := EQUHOLD; R1 := @V(R7); R3 := T(R7);
  3500.     if R3 ^= 0 then ENTERNAME;  goto EXIT;
  3501.  end;
  3502.  procedure CHKEQUATE (R4);
  3503.  begin  R0 := 1;   CLI(1,T2(R7+1));  if > then
  3504.     begin  SAVE := R4;  XR := 25;  ERROR;
  3505.        R4 := SAVE;  R0 := R0-R0;  T(R7) := R0;
  3506.     end;  LTR(R0,R0);
  3507.  end;
  3508.  procedure EQUARITH (R4);
  3509.  begin function SETUP(6,#0500);
  3510.     SAVE := R4;  !- Save return -!
  3511.     R0 := EQUHOLD; SRDA(R0,32); R3 := V2(R7);
  3512.     R2 := V1(R7) - 10S + R2;  if < then
  3513.     begin  XR := 4;  ERROR;  R2 := R2-R2;  R3 := R2;
  3514.     end;  if R3 = 0 and R2 = 6 then
  3515.     begin  !-- DIVISION BY ZERO --! XR := 19; ERROR; R3 := 1;
  3516.     end; SETUP(R5); EX(R0,B5(R2+8)); goto X;
  3517.        R1 := R1 + R3;
  3518.        R1 := R1 - R3;
  3519.        R1 := R1 * R3;
  3520.        R1 := R1 / R3;
  3521.        R1 := R1 ++ R3;
  3522.        R1 := R1 -- R3;
  3523.  X: EQUHOLD := R1;  R4 := SAVE;
  3524.  end;
  3525.   !-- MAIN CODE OF EXECUTE PROCEDURES --!
  3526.  STM(R1,R5,SAVEREG);
  3527.  if R1 <= XEQ2 then  !-- Low range --!
  3528.  begin  if R1 <= XEQ1 then EXECUTE1;  EXECUTE2;  end;
  3529.  if R1 <= XEQ4 then  !-- Mid range --!
  3530.  begin  if R1 <= XEQ3 then EXECUTE3;  EXECUTE4;  end;
  3531.   !-- XEQ4 < RULES <= END --!
  3532.     R1:=R1 - XEQ4; case R1 of begin
  3533.     begin !- <DSEG TYPE>  ::= GLOBAL DATA <ID> -!
  3534.        R0 := 1; T(R7) := R0; V(R7/10) := V2(R7); INCRSEGNO;
  3535.     end;
  3536.     begin !- <DSEG TYPE>  ::= EXTERNAL DATA <ID> -!
  3537.        R0 := 3; T(R7) := R0; V(R7/10) := V2(R7); INCRSEGNO;
  3538.     end;
  3539.     begin !- <DSEG TYPE>  ::= COMMON DATA <ID> -!
  3540.        R0 := 2; T(R7) := R0; V(R7/10) := V2(R7); INCRSEGNO;
  3541.     end;
  3542.     begin !- <DSEG TYPE>  ::= COMMON -!
  3543.        R0 := 2; T(R7) := R0; V(R7/10) := BLANK; INCRSEGNO;
  3544.     end;
  3545.     begin !- <DSEG TYPE>  ::= SEGMENT -!
  3546.        R0:=1; T(R7):=R0; V(R7/10) := SEGNAM; INCRSEGNO;
  3547.        CVD(R0,CONWORK); UNPK(2,7,V(R7+4),CONWORK); SETZONE(V(R7+6));
  3548.     end;
  3549.     begin !- <DSEG TYPE>  ::= DUMMY -!
  3550.        R0 := 4;  T(R7) := R0;  R0 := MAXSEGNO;
  3551.        if NODATASEG and R0 > NSEGNO then SEGNO := R0 else INCRSEGNO;
  3552.     end;
  3553.     begin !- <DECL>       ::= <PROC HD7><STATEMENT*> -!
  3554.        R0 := V(R7+4) or #07F0;  !-- EMIT RETURN INSTRUCTION --!
  3555.        R4 := LC; PROGRAM(R4) := R0; R4 := R4 + 2;
  3556.        R0 := T(R7); if R0 ^= 0 then
  3557.        begin  !-- CLOSE PROCEDURE SEGMENT --!
  3558.           for R1 := 14 + N4 step 14S until N3 do LABELERROR;
  3559.           ALLOCATELITERALS;
  3560.           if R4 > 4096S then
  3561.           begin R0 := R4; XR := 16; ERROR; R4 := R0;
  3562.           end; LC := R4;
  3563. $IFT M M
  3564.           if TESTFLAG then
  3565.           begin R0 := R4 - 2S; R1 := 5; ENTERSYMLABEL; end;
  3566. $END M
  3567.           BRANCHFIXUP;  !-- DO BRANCH OPTIMIZATION --!
  3568.           R0 := LC; R1 := LASTINITIAL(R9); INITIALEN(R1) := R0;
  3569.           R0 := PROGESDEND; R1 := PROGESDADR; R5 := R9; CLOSESEG;
  3570.           R5 := PREVSEG(R5); UNSTACKSEG; PROGESDEND := R0;
  3571.           R9 := R5; R3 := PBREG shll 12; PTAG := R3; R2 := N4;
  3572.           R2 := R2 + LABELBASE; R0 := LABELADR(R2); N4 := R0;
  3573.           R0 := LABEL(R2+8); CSEGNO := R0;
  3574.           R2 := R2 - LABELBASE;
  3575.           if R2 ^= 0 then R2 := R2 - 14S; N3 := R2;
  3576.        end else
  3577.        begin R3 := R4 + PTAG; R2 := PROCLK;
  3578.           PROGRAM(R2+2) := R3; PROCBR := R4; LC := R4;
  3579.        end;
  3580.     end;
  3581.     begin !- <DECL>       ::= <DSEG TYPE> BASE <K REG> -!
  3582.        R1 := T2(R7); R2 := V2(R7);
  3583.        if R1 ^= 1 then begin XR := 7; ERROR;  end;
  3584. Y:     R0 := DATAESDEND; R1 := DATAESDADR; R5 := R10;
  3585.        if NODATASEG then RESET(NODATASEG) else STACKSEG;
  3586. $IFF M M
  3587.        R2 := T(R7); R3 := V2(R7); OPENSEG; R10 := R5;
  3588. $END M
  3589. $IFT M M
  3590.        R2 := T(R7) + #010000; R3 := V2(R7); OPENSEG; R10 := R5;
  3591. $END M
  3592.        R0 := R1; R2 := T(R7); if R2 = 2 then R2 := CM else R2 := SD;
  3593.        R3 := ATYPE; R4 := SEGNO; FINDESDENTRY; DATAESDEND := R0;
  3594.        R0 := R0-R0; R2 := T(R7); if R2 ^= 4 and R0 ^= V2(R7) then
  3595.        begin R0 := PROGESDEND; R1 := PROGESDADR;
  3596.           CLC(9,V(R7),BLANK);
  3597.           if = and R2=2 then R2:=XCM else R2:=ER;
  3598.           R3 := ATYPE; R4 := SEGNO; FINDESDENTRY; PROGESDEND := R0;
  3599.           R2 := RLDADDR(R1); R3 := LC; PROGRAM(R3+2) := R2;
  3600.           RLDADDR(R1) := R3; R0 := V2(R7) shll 4 or #5800;
  3601.           PROGRAM(R3) := R0; R3 := R3 + 4; LC := R3;
  3602.        end;
  3603.        R1 := SEGNO * 10S; R1 := @ESDNAME(R1); B1(0/10) := V(R7);
  3604.     end;
  3605.     begin !- <DECL>       ::= CLOSE BASE -!
  3606.        R2 := BLOCK; if R2^=BLOCKLEVEL(R10) or NODATASEG then
  3607.        begin XR := 28; ERROR;
  3608.        end else
  3609.        begin R0 := DATAESDEND; R1 := DATAESDADR; R5 := R10; CLOSESEG;
  3610.           R2 := PREVSEG(R5); if R2 = ENDCHAIN then
  3611.           begin SET(NODATASEG); R0 := R0-R0; DC:=R0; PL360NO(R1) := R0;
  3612.           end else
  3613.           begin R5 := R2; UNSTACKSEG; DATAESDEND := R0; R10 := R5;
  3614.           end;
  3615.        end;
  3616.     end;
  3617.     begin !- <DECL>       ::= <EQU SYN2> -!
  3618.        R2 := S(R7-2);  SETNAME;  !-- NO RETURN --!
  3619.     end;
  3620.     begin !- <LABEL DEF>  ::= <ID> : -!
  3621.        R8 := LABELBASE + N4; R0 := LC + PTAG;
  3622.        for R2 := LABELBASE + N3 step _14S until R8 do
  3623.        if V(R7/10) = LABEL(R2) then
  3624.        begin if R4 := LABELADR(R2); R4 = 0 then goto X;
  3625.           XR := 9; ERROR; goto L;
  3626.        end; R2 := 14 + N3 =: N3 + LABELBASE;
  3627.        LABEL(R2/10) := V(R7); R1 := ENDCHAIN =: LABELCHAIN(R2);
  3628.  X:    LABELADR(R2) := R0;
  3629.  L:
  3630. $IFT M M
  3631.        if TESTFLAG then begin R1 := 1; ENTERSYMLABEL; end;
  3632. $END M
  3633.     end;
  3634.     begin !- <BLOCKHEAD>  ::= BEGIN -!
  3635.        R0 := N4; R1 := 14 + N3 =: N3 =: N4;
  3636.        R1 := R1 + LABELBASE; B1(0/12) := ZERO; LABELADR(R1) := R0;
  3637.        R0 := N2; LABEL(R1+4) := R0; R0 := N1; N2 := R0;
  3638.        R0 := DBREG; LABEL(R1) := R0;
  3639.        R0 := PROCBR =: LABEL(R1+6);
  3640.        R0 := 1 =: PROCBR;
  3641.        R0 := PROCLK =: LABEL(R1+12);
  3642.        R2 := 1 + BLOCK; BLOCK := R2;
  3643.     end;
  3644.     begin !- <PROGRAM->   ::= . -!
  3645.        R0 := N6; R1 := 4 + N5 =: N5 =: N6 + BRANCHBASE;
  3646.        BRANCHADR(R1) := R0;
  3647.        R0 := R0-R0; T(R7) := R0; R0 := 14; V(R7+4) := R0;
  3648.        R0 := PROGREG; PBREG := R0;
  3649.        if OSSYSTEM then
  3650.        begin  R0 := #90ECS; PROGRAM(0) := R0; R0 := #D00CS;
  3651.           PROGRAM(2) := R0; R3 := 15; if R3 ^= PROGREG then
  3652.           begin R0 := 4; LC := R0; R0 := 1; R1 := 8; R2 := PROGREG;
  3653.              EMIT; R1 := 2;
  3654.           end else R1 := R1-R1;
  3655.           R0 := #18EDS; PROGRAM(R1+4) := R0;
  3656.           R0 := #58D0S; PROGRAM(R1+6) := R0;
  3657.           R0 := #50E0S; PROGRAM(R1+10) := R0;
  3658.           R0 := #D004S; PROGRAM(R1+12) := R0;
  3659.           R0 := #50D0S; PROGRAM(R1+14) := R0;
  3660.           R0 := #E008S; PROGRAM(R1+16) := R0;
  3661.           R0 := #D703S; PROGRAM(R1+18) := R0;
  3662.           R0 := #E010S; PROGRAM(R1+20) := R0; PROGRAM(R1+22) := R0;
  3663.           R1 := R1 + 24S; LC := R1;
  3664.        end else
  3665.        begin  R0 := #05F0; PROGRAM(0) := R0; R0 := 2; LC := R0;
  3666.           R0 := 5; R1 := 8; R2 := PROGREG; R3 := #F; EMIT;
  3667.           R1 := PROGESDADR; R2 := RLDADDR(R1); PROGRAM(4) := R2;
  3668.           R0 := 2; RLDADDR(R1) := R0;
  3669.           R0 := #58D0S; PROGRAM(6) := R0; R0 := 10; LC := R0;
  3670.        end;
  3671. $IFF M M
  3672.        R2 := 1; R3 := STARTADR shrl 12; R5 := R10; OPENSEG;
  3673. $END M
  3674. $IFT M M
  3675.        R2 := #010001; R3 := STARTADR shrl 12; R5 := R10; OPENSEG;
  3676. $END M
  3677.        RESET(NODATASEG); R1 := DATAESDADR; R0 := R1; R2 := SD;
  3678.        R3 := ATYPE; R4 := R4-R4; FINDESDENTRY; DATAESDEND := R0;
  3679.        R0 := PROGESDEND; R1 := PROGESDADR; R2 := ER; FINDESDENTRY;
  3680.        PROGESDEND := R0; R2 := RLDADDR(R1);  R0 := 15;
  3681.        if R0 ^= PROGREG and OSSYSTEM then
  3682.        begin PROGRAM(10) := R2; R2 := 8;
  3683.        end else
  3684.        begin PROGRAM(8) := R2; R2 := 6;
  3685.        end;
  3686.        RLDADDR(R1) := R2; R0 := 1; BLOCKLEVEL(R10) := R0;
  3687.        R0 := STARTADR and #FFF; DC := R0; RESET(NOPROGSEG);
  3688.     end;
  3689.     begin !- <PROGRAM->   ::= . <GLOB HD> ; -!
  3690.        V(R7/16) := V1(R7); RESET(NOPROGSEG);
  3691.        R1 := PBREG shll 12; PTAG := R1;
  3692.        R1 := V(R7); R2 := PBREG shll 4 or V(R7+4);
  3693.        R4 := CSEGNO shll 8 or R2; ADR(R1) := R4;
  3694.     end;
  3695.     begin !- <PROGRAM*>   ::= <PROGRAM-><STATEMENT*> -!
  3696.        if R5 ^= ENDFILE then begin SET(FLAG); goto X; end;
  3697.        R4 := LC; R0 := T(R7); if R0 = 0 and OSSYSTEM then
  3698.        begin R0 := #58D0S; PROGRAM(R4) := R0;
  3699.           R0 := #D004S; PROGRAM(R4+2) := R0;
  3700.           R0 := #98ECS; PROGRAM(R4+4) := R0;
  3701.           R0 := #D00CS; PROGRAM(R4+6) := R0; R4 := R4 + 8S;
  3702.        end else if R0 = 0 then
  3703.        begin R0 := #0A0E; PROGRAM(R4) := R0; R4 := R4 + 2; goto Y;
  3704.        end;
  3705.        R0 := #07F0 or V(R7+4); PROGRAM(R4) := R0; R4 := R4 + 2;
  3706. Y:     ALLOCATELITERALS; LC := R4;
  3707. $IFT M M
  3708.        if TESTFLAG then
  3709.        begin R0 := R4 - 2S; R1 := 5; ENTERSYMLABEL; end;
  3710. $END M
  3711.        R2 := LASTINITIAL(R9); INITIALEN(R2) := R4;
  3712.        if R4 > 4096S then begin XR := 16; ERROR; end;
  3713.        BRANCHFIXUP;  !-- DO BRANCH OPTIMIZATION --!
  3714.        R1 := N4; while R1 := @B1(14); R1 <= N3 do
  3715.        begin R2 := R1 + LABELBASE; R0 := LABELADR(R2);
  3716.           if R0 = 0 then LABELERROR;
  3717.        end;
  3718.        R0 := PROGESDEND; R1 := PROGESDADR; R5 := R9; CLOSESEG;
  3719.  X:
  3720.     end;
  3721.     begin !- <EQU SYN1>   ::= <EQUATE><ID> SYN -!
  3722.        V(R7/10) := V1(R7); R0 := T1(R7); T(R7) := R0;
  3723.     end;
  3724.     begin !- <EQU SYN2>   ::= <EQU SYN1><T NUMBER> -!
  3725.        R0 := V1(R7);  CLI(1,T1(R7+1));  if > then
  3726.        begin  XR := 25; ERROR; R0 := R0-R0; T(R7) := R0;
  3727.        end;  EQUHOLD := R0;
  3728.     end;
  3729.     begin !- <EQU SYN2>   ::= <EQU SYN3><ARITH OP><T CELL> -!
  3730.        R1 := V1(R7);  if R1 ^= 11S then    !-- ^= - --!
  3731.        begin XR := 4; ERROR; R1 := R1-R1; T(R7) := R1; end;
  3732.        R0 := V2(R7) and #FFFF; if R0^=V2(R7) then
  3733.        begin XR:=11; ERROR; end;
  3734.        R0 := EQUHOLD and #F000; R1 := V2(R7) and #F000;
  3735.        if R0^=R1 then
  3736.        begin XR:=26; ERROR; end;
  3737.        R1 := EQUHOLD - V2(R7);
  3738.        EQUHOLD := R1;
  3739.     end;
  3740.     begin !- <EQU SYN2>   ::= <EQU SYN2><ARITH OP><STRING> -!
  3741.       R3 := STRINGV;  R1 := 4 - V2(R7);  if < then
  3742.       begin  XR := 21;  ERROR;  !- Invalid length -!
  3743.       end else  !- Valid string length -!
  3744.       begin  for R2 := 1 step 1 until R1 do R3 := R3 shrl 8;
  3745.          V2(R7) := R3;  EQUARITH;
  3746.       end;
  3747.     end;
  3748.     begin !- <EQU SYN2>   ::= <EQU SYN2><ARITH OP><T NUMBER> -!
  3749.       CHKEQUATE;  if ^= then EQUARITH;
  3750.     end;
  3751.     begin !- <EQU SYN2>   ::= <EQU SYN2><LOG OP><STRING> -!
  3752.       R3 := STRINGV;  R1 := 4 - V2(R7);  if < then
  3753.       begin  XR := 21;  ERROR;  !- Invalid length -!
  3754.       end else  !- Valid string length -!
  3755.       begin  for R2 := 1 step 1 until R1 do R3 := R3 shrl 8;
  3756.          R1 := EQUHOLD;  !- String in R3 -!
  3757.          R2 := V1(R7) shll 8 + #1013S; EQUHOLD := R2;
  3758.          EX(R0,EQUHOLD(2));  EQUHOLD := R1;
  3759.       end;
  3760.     end;
  3761.     begin !- <EQU SYN2>   ::= <EQU SYN2><LOG OP><T NUMBER> -!
  3762.       CHKEQUATE;  if ^= then
  3763.       begin R1 := EQUHOLD; R3 := V2(R7);
  3764.          R2 := V1(R7) shll 8 + #1013S; EQUHOLD := R2;
  3765.          EX(R0,EQUHOLD(2));  EQUHOLD := R1;
  3766.       end;
  3767.     end;
  3768.     begin !- <EQU SYN2>   ::= <EQU SYN2><SHIFT OP><T NUMBER> -!
  3769.       R3 := V2(R7); CHKEQUATE; if ^= then
  3770.       if R3 < 0 or R3 >= 32S then
  3771.       begin XR := 25; ERROR; R0 := R0-R0; T(R7) := R0;
  3772.       end else
  3773.       begin R0 := EQUHOLD; R2 := #80 + V1(R7) shll 24 or R3;
  3774.          EQUHOLD := R2;  EX(R0,EQUHOLD);  EQUHOLD := R0;
  3775.       end;
  3776.     end;
  3777.     begin !- <EQU SYN2>   ::= <EQU SYN1><UNARY NUM> -!
  3778.        byte VC syn V(32), OPCD syn B2;
  3779.        R1 := V1(R7);  R2 := R2 -- R2;  if CLI(1,T1(R7+1)); ^= then
  3780.        begin  XR := 25;  ERROR;  R1 := R2 =: T(R7);
  3781.        end;  IC(R2,VC(R7));  R2 := @VC(R7+R2+2);  SET(B2);
  3782.        R2 := @VC(R7);  while R2 := @B2(1);  ^OPCD do
  3783.        if OPCD = 4 then
  3784.        begin  XR := 26;  ERROR;
  3785.        end else if OPCD = 6 then REDUCE(R1) else
  3786.        begin R0 := R0 -- R0;  IC(R0,OPCD);
  3787.           R0 := R0 shll 8 or #1011 =: EQUHOLD;  EX(R0,EQUHOLD(2));
  3788.        end;  EQUHOLD := R1;
  3789.     end;
  3790.     begin !- <EQU SYN3>   ::= <EQU SYN1><T CELL> -!
  3791.       R0 := V1(R7);  EQUHOLD := R0;
  3792.       R0 := R0 and #FFFF; if R0^=EQUHOLD then
  3793.       begin XR:=11; ERROR; end;
  3794.     end;
  3795.     begin !- <EQU SYN2>   ::= <EQU SYN1><STRING> -!
  3796.        R0 := STRINGV; R1 := 4 - V1(R7);
  3797.        for R2 := 1 step 1 until R1 do R0 := R0 shrl 8;
  3798.        if R1 < 0 then begin XR := 21; ERROR; end;
  3799.        EQUHOLD := R0;
  3800.     end;
  3801.     begin !- <EQU SYN2>   ::= <EQU SYN1><K REG> -!
  3802.        R0 := V1(R7);  EQUHOLD := R0;
  3803.     end;
  3804.     begin !- <EQUATE>     ::= <EQU SYN2> , -!
  3805.        R2 := S(R7-2);  SETNAME;  !-- NO RETURN --!
  3806.     end;
  3807.     begin !- <PROC SYN>   ::= PROCEDURE <ID> SYN -!
  3808.        V(R7/10) := V1(R7);  R0 := T1(R7);  T(R7) := R0;
  3809.     end;
  3810.     begin !- <DECL>       ::= <PROC SYN> <PROC ID> -!
  3811.        R0 := V1(R7);  EQUHOLD := R0;  R2 := 10;  SETNAME;
  3812.     end;
  3813.     begin !- <FORUNTIL>   ::= UNTIL -!
  3814.        R1 := R7 - 32S;  R2 := FORSYMBOL;
  3815.        if R2 ^= S(R1) then SET(FLAG);
  3816.     end;
  3817.     begin !- <REPUNTIL>   ::= UNTIL -!
  3818.     end;
  3819.     end;
  3820.  EXIT: LM(R1,R5,SAVEREG);
  3821.     end;
  3822.  
  3823.     close base;  !-- CLOSE DATA SEGMENT --!
  3824.  
  3825.     segment base R11;  !-- USE R11 FOR BASE OF ESDNAMETABLE --!
  3826.  
  3827.     array NAMETBLLEN byte ESDNAMETABLE=
  3828.     ("SEGN000   ","SEGN001   ","READ      ","WRITE     ","PUNCH     ",
  3829.      "PAGE      ","PRINT     ","OPEN      ","GET       ","PUT       ",
  3830.      "KLOSE     ","CANCEL    ","BCDTOVAL  ","VALTOBCD  ");
  3831.     close base;
  3832.     segment base R8;  !-- CHANGE BASE REGISTERS --!
  3833.  
  3834.     array 1366 byte PRTB   =
  3835.        (255,0,1,14,47,2,5,106,1,14,71,2,78,106,1,14,72,2,94,106,1,14,73,
  3836.        2,1,106,1,14,74,2,10,106,1,14,75,2,11,106,1,14,76,2,12,106,1,14,
  3837.        77,3,5,97,106,1,14,78,3,3,97,106,1,14,79,2,5,22,1,23,113,2,78,22,
  3838.        1,23,114,2,1,22,1,23,115,2,94,22,1,23,116,2,1,88,1,23,128,255,0,
  3839.        2,5,1,1,101,2,8,4,255,1,101,3,19,6,0,3,21,107,255,1,101,4,16,95,
  3840.        0,4,21,108,255,2,1,106,5,81,100,2,5,106,5,81,101,2,78,106,5,81,
  3841.        102,2,94,106,5,81,103,2,5,22,5,23,119,2,78,22,5,23,120,2,94,22,5,
  3842.        23,121,0,5,23,122,255,1,102,6,5,2,2,94,96,6,6,55,2,78,96,6,6,56,
  3843.        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,
  3844.        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,
  3845.        11,9,11,65,1,1,9,12,66,1,12,9,12,67,3(255),0,12,23,126,2(255),0,
  3846.        14,21,7,2,94,96,14,14,80,2,5,96,14,14,81,2,78,96,14,14,82,2,1,96,
  3847.        14,14,83,2,94,13,14,14,84,2,5,13,14,14,85,2,78,13,14,14,86,2,1,
  3848.        13,14,14,87,2,78,95,14,14,88,2,1,95,14,14,89,2,78,125,14,32,143,
  3849.        255,1,104,15,16,5,1,102,15,17,96,255,1,78,16,15,90,1,1,16,15,91,
  3850.        1,5,16,15,92,1,94,16,15,93,1,17,16,15,94,255,0,17,21,109,255,1,
  3851.        68,18,18,44,2,98,37,18,18,98,1,112,18,21,110,255,1,1,19,20,99,
  3852.        255,1,102,20,21,10,255,0,21,35,12,1,120,21,29,138,255,0,22,23,
  3853.        124,255,0,23,80,130,0,23,24,131,255,0,24,83,40,1,111,24,25,133,1,
  3854.        110,24,25,134,1,112,24,86,135,1,126,24,26,136,1,107,24,31,142,
  3855.        255,2,98,37,25,25,38,1,80,25,24,132,2(255),0,27,28,11,1,120,27,
  3856.        29,139,255,0,28,36,162,2(255),2,98,37,30,30,39,2,84,31,30,35,158,
  3857.        2,36,31,30,35,159,5(255),0,35,36,13,255,0,36,37,14,2(255),0,38,
  3858.        39,170,3,114,93,143,38,54,189,255,1,93,39,43,179,0,39,43,181,2,
  3859.        114,93,39,54,188,2(255),1,40,41,42,16,255,1,104,42,41,15,1,102,
  3860.        42,40,176,255,0,43,46,18,1,99,43,45,183,255,1,93,44,43,180,0,44,
  3861.        43,182,255,1,40,45,46,184,255,1,104,46,44,17,0,46,67,28,255,1,93,
  3862.        47,48,185,255,1,101,48,49,21,255,1,78,49,50,186,255,1,104,50,51,
  3863.        22,255,1,78,51,52,187,255,1,102,52,53,23,255,1,104,53,47,20,0,53,
  3864.        67,29,255,1,5,54,55,191,1,78,54,55,192,1,1,54,55,193,255,1,104,
  3865.        55,56,24,0,55,67,30,255,2,114,93,56,54,190,255,1,101,57,58,25,
  3866.        255,1,1,58,59,197,255,1,102,59,60,26,255,0,60,62,202,255,0,61,62,
  3867.        203,2,1,116,61,62,204,255,1,98,62,63,205,255,1,36,63,67,214,
  3868.        2(255),0,65,64,27,2,1,116,65,64,207,255,2,1,116,66,67,215,3(255),
  3869.        2,98,67,69,69,31,0,69,70,32,255,2,98,37,70,70,33,1,68,70,70,34,1,
  3870.        112,70,21,111,1,85,70,84,153,255,1,36,71,72,222,255,1,105,72,73,
  3871.        35,2(255),1,78,74,75,224,1,11,74,75,231,1,5,74,76,232,1,94,74,75,
  3872.        233,1,1,74,75,234,255,0,75,67,217,2,94,96,75,75,226,2,78,96,75,
  3873.        75,227,2,94,13,75,75,228,2,78,13,75,75,229,2,78,95,75,75,230,1,
  3874.        104,75,77,235,255,2,5,96,76,75,225,255,2,114,93,77,74,223,255,0,
  3875.        78,23,117,0,78,40,175,1,101,78,41,177,255,2,98,37,79,79,37,1,86,
  3876.        79,85,148,2,35,86,79,85,149,2,28,86,79,85,150,3,35,29,86,79,85,
  3877.        151,3,28,29,86,79,85,152,2,35,26,79,35,154,2,28,26,79,35,155,3,
  3878.        35,29,26,79,35,156,3,28,29,26,79,35,157,2(255),0,81,21,8,2,5,13,
  3879.        81,81,104,2,78,13,81,81,105,2,94,13,81,81,106,255,2,98,37,82,82,
  3880.        41,2,102,83,82,23,125,5(255),2,98,67,87,87,42,0,87,18,43,2(255),
  3881.        1,3,89,67,237,255,1,68,90,90,45,2,98,37,90,90,46,2,83,92,90,35,
  3882.        160,255,1,1,91,33,144,1,5,91,33,145,1,78,91,33,146,2(255),0,93,1,
  3883.        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,
  3884.        1,103,93,68,218,255,0,94,40,172,3(255),1,5,97,40,173,1,3,97,40,
  3885.        174,2(255),0,99,22,112,255,1,78,100,23,118,1,5,100,23,123,1,12,
  3886.        100,23,127,255,0,101,82,129,0,101,41,178,4(255),0,105,71,220,2,
  3887.        98,64,105,71,221,2(255),0,107,34,147,255,0,108,79,36,2(255),0,
  3888.        110,13,69,255,0,111,13,68,2(255),4,36,34,33,32,113,35,161,2(255),
  3889.        0,115,13,70,2(255),0,117,38,168,255,3,128,109,1,118,87,97,3(255),
  3890.        1,93,121,27,137,255,1,124,122,38,167,255,0,123,21,9,255,0,124,38,
  3891.        166,3(255),2,38,78,127,39,171,255,0,128,69,219,255,1,116,129,67,
  3892.        216,255,0,130,66,213,255,1,138,131,38,163,1,135,131,77,194,255,0,
  3893.        132,91,238,0,132,92,239,255,0,133,30,141,255,1,60,134,62,201,2,
  3894.        93,119,134,66,210,0,134,66,211,255,0,135,77,195,255,1,60,136,61,
  3895.        198,1,60,136,65,206,2,93,119,136,66,208,255,0,137,90,140,255,0,
  3896.        138,38,164,255,0,139,38,165,255,1,60,140,61,200,0,140,66,212,255,
  3897.        1,60,141,61,199,2,93,119,141,66,209,255,0,142,47,19,2(255),0,144,
  3898.        38,169,255,1,93,145,57,196,2,114,93,145,89,236,255);
  3899.  
  3900.     comment STANDARD IDENTIFIERS FOR THE NAME TABLE ARE GIVEN BELOW.
  3901.        NEW ENTRIES, CHANGES, OR DELETIONS CAN BE MADE TO THE LIST IN
  3902.        ANY ORDER.  HOWEVER, LATER ENTRIES ARE ACCESSED VIA THE
  3903.        HASH CHAIN BEFORE EARLIER ENTRIES SO ORDER DOES AFFECT SPEED
  3904.        OF ACCESS.
  3905.  
  3906.        THE FOURTH AND FIFTH FIELDS OF EACH ENTRY DESCRIBE THE BCD
  3907.        NAME. THE FOURTH FIELD GIVES THE ACTUAL LENGTH OF THE BCD
  3908.        NAME (ONLY LENGTHS OF 2, 4, 6, 8, OR 10 ARE VALID).  THE FIFTH
  3909.        FIELD IS THE ACTUAL STRING (A BLANK MUST BE USED ON THE RIGHT
  3910.        TO MAKE ODD LENGTH ID'S HAVE AN EVEN LENGTH.).  AT RUN TIME
  3911.        THE LENGTH FIELD IS CONVERTED TO A CHAIN FIELD FOR THE HASH
  3912.        SCHEME USED.  A LENGTH FIELD OF _1 SIGNALS THE END OF THE
  3913.        STANDARD IDENTIFIERS.
  3914.  
  3915.        THE FIRST FIELD GIVES THE TYPE OF EACH ID.  FIELDS TWO AND THREE
  3916.        ARE A FOUR BYTE ADDRESS OR VALUE FOR EACH ID AND ARE FILLED
  3917.        ACCORDING TO THE TYPE OF THE ID.
  3918.           0 -- ID IS A SHORT INTEGER, 1 -- ID IS AN INTEGER OR LOGICAL,
  3919.           2 -- ID IS A LONG REAL, 3 -- ID IS A REAL,
  3920.           11 -- ID IS A FUNCTION, 81 -- ID IS AN INTEGER REGISTER,
  3921.           82 -- ID IS A LONG REAL REG., 83 -- ID IS A REAL REG,
  3922.           10 -- ID IS A PROCEDURE, 12 -- ID IS AN EQUATE INTEGER.
  3923.  
  3924.        FOR <T CELL> TYPES (TYPE < 10), FIELDS TWO AND THREE CONTAIN
  3925.        THE RELATIVE ADDRESS AS A FOUR BYTE QUANTITY.  NORMALLY FIELD
  3926.        TWO IS ZERO BECAUSE FIELD THREE CAN CONTAIN THE ENTIRE ADDRESS
  3927.        UNLESS AN INDEX REGISTER IS PART OF THE RELATIVE ADDRESS.
  3928.        FOR PROCEDURES, FIELD TWO CONTAINS THE SEGMENT NUMBER OF THE
  3929.        PROCEDURE IN THE FIRST BYTE, THE ENTRY POINT REGISTER IN THE
  3930.        UPPER HALF OF THE SECOND BYTE, AND THE RETURN REGISTER IN THE
  3931.        LOWER HALF OF THE SECOND BYTE, WHILE FIELD THREE
  3932.        CONTAINS THE RELATIVE ADDRESS OF THE PROCEDURE (WITHOUT BASE
  3933.        REGISTER R15 SPECIFIED).
  3934.        FOR FUNCTIONS, FIELD TWO CONTAINS THE FUNCTION CODE AND FIELD
  3935.        THREE CONTAINS THE FIRST HALF WORD OF THE FUNCTION.  FOR <K REG>
  3936.        TYPES (TYPE > 80) FIELD TWO IS 0 AND FIELD THREE IS THE ACTUAL
  3937.        HARDWARE REGISTER NUMBER;
  3938.     equate K0 syn #FF00,  !-- CELL TYPES NOT DEFINED IN SEGMENT --!
  3939.            K1 syn #FF01,  K2 syn #FF02,  K3 syn #FF03, K4 syn #FF04;
  3940.     array NAMEFILLSZ short integer NAMEFILL=(
  3941. $IFF
  3942.     (K4,   #E,#0FFF, 6,    "PSTAR "),(K4,   #D,#0FFF, 6,    "DSTAR "),
  3943.  $$ (K3,    0,#F000, 4,      "E15 "),(K3,    0,#E000, 4,      "E14 "),
  3944.  $$ (K3,    0,#D000, 4,      "E13 "),(K3,    0,#C000, 4,      "E12 "),
  3945.  $$ (K3,    0,#B000, 4,      "E11 "),(K3,    0,#A000, 4,      "E10 "),
  3946.  $$ (K3,    0,#9000, 2,        "E9"),(K3,    0,#8000, 2,        "E8"),
  3947.  $$ (K3,    0,#7000, 2,        "E7"),(K3,    0,#6000, 2,        "E6"),
  3948.  $$ (K3,    0,#5000, 2,        "E5"),(K3,    0,#4000, 2,        "E4"),
  3949.  $$ (K3,    0,#3000, 2,        "E3"),(K3,    0,#2000, 2,        "E2"),
  3950.  $$ (K3,    0,#1000, 2,        "E1"),
  3951.     (K2,    0,#F000, 4,      "L15 "),(K2,    0,#E000, 4,      "L14 "),
  3952.     (K2,    0,#D000, 4,      "L13 "),(K2,    0,#C000, 4,      "L12 "),
  3953.     (K2,    0,#B000, 4,      "L11 "),(K2,    0,#A000, 4,      "L10 "),
  3954.     (K2,    0,#9000, 2,        "L9"),(K2,    0,#8000, 2,        "L8"),
  3955.     (K2,    0,#7000, 2,        "L7"),(K2,    0,#6000, 2,        "L6"),
  3956.     (K2,    0,#5000, 2,        "L5"),(K2,    0,#4000, 2,        "L4"),
  3957.     (K2,    0,#3000, 2,        "L3"),(K2,    0,#2000, 2,        "L2"),
  3958.     (K2,    0,#1000, 2,        "L1"),
  3959.     (K0,    0,#F000, 4,      "H15 "),(K0,    0,#E000, 4,      "H14 "),
  3960.     (K0,    0,#D000, 4,      "H13 "),(K0,    0,#C000, 4,      "H12 "),
  3961.     (K0,    0,#B000, 4,      "H11 "),(K0,    0,#A000, 4,      "H10 "),
  3962.     (K0,    0,#9000, 2,        "H9"),(K0,    0,#8000, 2,        "H8"),
  3963.     (K0,    0,#7000, 2,        "H7"),(K0,    0,#6000, 2,        "H6"),
  3964.     (K0,    0,#5000, 2,        "H5"),(K0,    0,#4000, 2,        "H4"),
  3965.     (K0,    0,#3000, 2,        "H3"),(K0,    0,#2000, 2,        "H2"),
  3966.     (K0,    0,#1000, 2,        "H1"),
  3967.     (K4,    0,#F000, 4,      "C15 "),(K4,    0,#E000, 4,      "C14 "),
  3968.     (K4,    0,#D000, 4,      "C13 "),(K4,    0,#C000, 4,      "C12 "),
  3969.     (K4,    0,#B000, 4,      "C11 "),(K4,    0,#A000, 4,      "C10 "),
  3970.     (K4,    0,#9000, 2,        "C9"),(K4,    0,#8000, 2,        "C8"),
  3971.     (K4,    0,#7000, 2,        "C7"),(K4,    0,#6000, 2,        "C6"),
  3972.     (K4,    0,#5000, 2,        "C5"),(K4,    0,#4000, 2,        "C4"),
  3973.     (K4,    0,#3000, 2,        "C3"),(K4,    0,#2000, 2,        "C2"),
  3974.     (K4,    0,#1000, 2,        "C1"),
  3975. $END
  3976.     (K1,    0,#E000, 4,      "B14 "),(K1,    0,#F000, 4,      "B15 "),
  3977.     (82,    0,    4, 4,      "F45 "),(82,    0,    6, 4,      "F67 "),
  3978.     (82,    0,    0, 4,      "F01 "),(82,    0,    2, 4,      "F23 "),
  3979.     (83,    0,    4, 2,        "F4"),(83,    0,    6, 2,        "F6"),
  3980.     (83,    0,    0, 2,        "F0"),(83,    0,    2, 2,        "F2"),
  3981.     (13,    0,    0, 4,      "ABS "),(13,    0,    3, 4,      "NEG "),
  3982.     (13,    0,    6, 4,      "DEC "),(13,    0,    4, 4,      "HALF"),
  3983.     (14,    0, #860, 2,        "LE"),(14,    0, #870, 2,        "GT"),
  3984.     (10,#02FE,#0000, 4,      "READ"),(10,#03FE,#0000, 6,    "WRITE "),
  3985.     (10,#04FE,#0000, 6,    "PUNCH "),(10,#05FE,#0000, 4,      "PAGE"),
  3986.     (10,#06FE,#0000, 6,    "PRINT "),(10,#07FE,#0000, 4,      "OPEN"),
  3987.     (10,#08FE,#0000, 4,      "GET "),(10,#09FE,#0000, 4,      "PUT "),
  3988.     (10,#0AFE,#0000, 6,    "KLOSE "),(10,#0BFE,#0000, 6,    "CANCEL"),
  3989.     (10,#0CFE,#0000, 8,  "BCDTOVAL"),(10,#0DFE,#0000, 8,  "VALTOBCD"),
  3990.     (11,    5,#DC00, 2,        "TR"),(11,    5,#D100, 4,      "MVN "),
  3991.     (11,    5,#DE00, 2,        "ED"),(11,    2,#4400, 2,        "EX"),
  3992.     (11,   10,#F300, 4,      "UNPK"),(11,   12,#4E00, 4,      "CVD "),
  3993.     (11,    8,#92FF, 4,      "SET "),(11,    8,#9200, 6,    "RESET "),
  3994.     (11,    2,#4300, 2,        "IC"),(11,   12,#4200, 4,      "STC "),
  3995.     (11,    9,#8C00, 4,      "SRDL"),(11,    9,#8D00, 4,      "SLDL"),
  3996.     (11,    3,#9000, 4,      "STM "),(11,    3,#9800, 2,        "LM"),
  3997.     (11,    4,#9200, 4,      "MVI "),(11,    4,#9500, 4,      "CLI "),
  3998.     (11,    5,#D200, 4,      "MVC "),(11,   13,#D500, 4,      "CLC "),
  3999.     (11,    8,#95FF, 4,      "TEST"),(11,    2,#4100, 2,        "LA"),
  4000.     (11,    4,#9400, 2,        "NI"),(11,   12,#4F00, 4,      "CVB "),
  4001.     (11,    4,#9700, 2,        "XI"),(11,    4,#9600, 2,        "OI"),
  4002.     (11,   10,#F200, 4,      "PACK"),(11,    6,#0400, 4,      "SPM "),
  4003.     (11,    9,#8F00, 4,      "SLDA"),(11,    9,#8E00, 4,      "SRDA"),
  4004.     (11,    7,#0A00, 4,      "SVC "),(11,    4,#9100, 2,        "TM"),
  4005.     (11,    5,#DD00, 4,      "TRT "),(11,    5,#DF00, 4,      "EDMK"),
  4006.     (11,    1,#1200, 4,      "LTR "),(11,    5,#D300, 4,      "MVZ "),
  4007.     (11,   12,#4000, 4,      "STH "),(11,   12,#4800, 2,        "LH"),
  4008.     (11,    1,#0500, 4,      "BALR"),(11,    5,#D400, 2,        "NC"),
  4009.     (11,    5,#D600, 2,        "OC"),(11,    5,#D700, 2,        "XC"),
  4010.     (11,    8,#9300, 2,        "TS"),(11,   16,#BD00, 4,      "CLM "),
  4011.     (11,   17,#BE00, 4,      "STCM"),(11,   16,#BF00, 4,      "ICM "),
  4012.     (81,    0,   14, 4,      "R14 "),(81,    0,   15, 4,      "R15 "),
  4013.     (81,    0,   12, 4,      "R12 "),(81,    0,   13, 4,      "R13 "),
  4014.     (81,    0,   10, 4,      "R10 "),(81,    0,   11, 4,      "R11 "),
  4015.     (81,    0,    8, 2,        "R8"),(81,    0,    9, 2,        "R9"),
  4016.     (81,    0,    6, 2,        "R6"),(81,    0,    7, 2,        "R7"),
  4017.     (81,    0,    4, 2,        "R4"),(81,    0,    5, 2,        "R5"),
  4018.     (81,    0,    2, 2,        "R2"),(81,    0,    3, 2,        "R3"),
  4019.     (81,    0,    0, 2,        "R0"),(81,    0,    1, 2,        "R1"),
  4020.     (K1,    0,#C000, 4,      "B12 "),(K1,    0,#D000, 4,      "B13 "),
  4021.     (K1,    0,#A000, 4,      "B10 "),(K1,    0,#B000, 4,      "B11 "),
  4022.     (K1,    0,#8000, 2,        "B8"),(K1,    0,#9000, 2,        "B9"),
  4023.     (K1,    0,#6000, 2,        "B6"),(K1,    0,#7000, 2,        "B7"),
  4024.     (K1,    0,#4000, 2,        "B4"),(K1,    0,#5000, 2,        "B5"),
  4025.     (K1,    0,#2000, 2,        "B2"),(K1,    0,#3000, 2,        "B3"),
  4026.     (K1,    0,#0000, 4,      "MEM "),(K1,    0,#1000, 2,        "B1"),
  4027.     (12,    0,    4, 6,    "MIXED "),(12,    0,    1, 2,        "ON"),
  4028.     (12,    0,    8, 4,      "OFF "),(12,    0,    1, 8,  "OVERFLOW"),
  4029.     (12,#FFFF,#FFFF, 4,      "TRUE"),(12,    0,    0, 6,    "FALSE "),
  4030.     (12,    0,    3, 6,    "CARRY "),(12, DTHI, DTLO, 8,  "DATAFILL"),
  4031.      !-- FOLLOW TWO ENTRIES MUST BE THE LAST TWO --!
  4032.     (12,    0,    0, 6,    "STRING"),( 0,    0,    0,_1));
  4033. $PAGE
  4034.  segment procedure MAIN(R6);
  4035.  begin  !-- ALLOCATE CORE FOR PROGRAM, DATA, LITERALS AND LABELS --!
  4036.     SAVERETURN := R6;  !-- SAVE RETURN REGISTER --!
  4037.     if R0 = 0 then goto RESTART;
  4038.     SYSINIT(R9); comment FREE STORAGE BOUNDS RETURNED IN R3, R4,
  4039.        R1 SET TO ADDRESS OF 16 CHARACTER SYSTEM ID;
  4040.     STC(R9,OSSYSTEM);  !-- #FF => O/S, #00 => DOS --!
  4041. $IFF
  4042. $IFF M M
  4043.     IDRDATA(15/5) := B1(16);  IDRDATA(21/16) := B1;
  4044. $END M
  4045. $IFT M M
  4046.     IDRDATA(21/16) := B1;
  4047. $END M
  4048. $END
  4049.     HEADER(94/16) := B1;
  4050. $IFT M M
  4051.     LISTFLAG(0/1) := B1(16); TESTFLAG(0/1) := B1(17);
  4052.     XREF(0/1) := B1(18); TRACE(0/1) := B1(19);
  4053.     OVER(0/1) := B1(21);
  4054.     OPTFLAG(0/1) := B1(20);
  4055. $END M
  4056.     R3 := @B3(7) and _8;  R4 := R4 and _8;
  4057.     PRTBASE := R8; R8 := @NAMEFILL; NAMEBASE := R8;
  4058.     R4 := R4 - STACKLEN;  STACKBASE := R4;
  4059.     R4 := R4 - ESDTBLLEN;  PROGESDADR := R4;
  4060.     R4 := R4 - ESDTBLLEN;  DATAESDADR:=R4;
  4061.     R5 := R4 - R3;  PROGBASE := R3;  R9 := R3;
  4062. $IFF
  4063.     if R5 > #7800S then
  4064.     begin  !-- $XREF WILL BE POSSIBLE --!
  4065.        R7 := R5 shrl 1 - 12000S and _8;
  4066.        if R7 > 262144 then R7 := 262144;  R4 := R4-R7;
  4067.        REFSTART := R4;  R5 := R5-R7;  R7 := R7-4;  REFN3 := R7;
  4068. $IFT M M
  4069.     end;  if R5 > #5000S and TESTFLAG then
  4070.     begin  !-- $TEST WILL BE POSSIBLE --!
  4071.        R1 := R4; R2 := R5 - #4000S shrl 1 + 3000S and _8;
  4072.        if R2 > 262144 then R2 := 262144; R4 := R4 - R2;
  4073.        R5 - R2; R7 := R4 - 4S; DATASTACK := R7; R2 := @B7(#300);
  4074.        PROCSTACK := R2; R2 := @B2(4); DSTAKBOT := R2;
  4075.        R2 := @B2(#100); PSTAKBOT := R2; FREESPACE := R2;
  4076.        R7 := R2;  while R7 := @B7(28); R7 < R1 do
  4077.        begin B2 := R7; R2 := R7;
  4078.        end; R7 := neg 1; B2 := R7;
  4079. $END M
  4080.     end;
  4081. $END
  4082.     if R5 < SIZE1 then   !-- NOT ENOUGH CORE --!
  4083.     begin  XR := 31;   ERROR;
  4084.        WBUF := "CORE SIZE TOO SMALL ";
  4085.        WBUF(STRING/132-STRING) := WBUF(STRING-1);  PRINT;
  4086.        SB(NOGO,FLGS);  ERROREXIT;
  4087.     end;  R6 := neg ROUND;  REDUCE(R6);  R2 := #FE00;
  4088.     for R7 := R7 -- R7 step 4S until 16S do
  4089.     begin R14 := R5 * QTAB(R7) shrl 8;
  4090.        R14 := @B14(ROUND) and R6;
  4091.        if R14 > R2 then R14 := R2;  LTAB(R7) := R14;
  4092.     end;
  4093.     R4 := R4 - BRTBL;  BRANCHBASE := R4;
  4094.     R4 := R4 - LTTL;  LITBASE := R4;
  4095.     R4 := R4 - LBTL;  LABELBASE := R4;
  4096.     R7 := R4 - 56S;  DATAEND := R7;
  4097.     R4 := R4 - DTL;  DATABASE := R4;
  4098.     R4 := R4 - NTBL;  R7 := R4;  R2 := NAMEBASE;
  4099.     NAMEBASE := R4;  R1 := DATABASE;  R1 := R1 - R4;
  4100.     NAMEND := R1;  R1 := NAMETABSZ;
  4101.     while R1 >= 256S do  !-- MOVE NAME TABLE --!
  4102.     begin  B7(0/256) := B2;  R1 := R1 - 256S;
  4103.        R2 := @B2(256);  R7 := @B7(256);
  4104.     end;  EX(R1,MVC(0,B7,B2));
  4105.     R0 := R0-R0;  R7 := STACKBASE;  S(R7) := R0;
  4106.     R7 := @B7(16);  STACKBASE := R7;
  4107.     R3 := LINK(R4);  R2 := R2-R2;
  4108.     while R3 > 0 do
  4109.     begin IC(R2,NAME(R4)); IC(R2,ALPHASH(R2-193));
  4110.        R1 := LENHASH(R3-2) + R2; R0 := HASHCHAIN(R1); LINK(R4) := R0;
  4111.        R0 := R4 - NAMEBASE; HASHCHAIN(R1) := R0;
  4112.        R5 := R4; R4 := @B4(R3+8); R3 := LINK(R4);
  4113.     end;  STRNGADR := R5;
  4114.     R4 := R4 - NAMEBASE; NAMEPOINTER := R4;
  4115. RESTART:  !-- RESTART COMPILER FOR NEXT PROGRAM --!
  4116.     SET(RUNFLAG); SET(SKIPFLAG); CARRCONT := "1"; SET(GENFLAG);
  4117.     SET(GENDECK); SET(NOPROGSEG); SET(NODATASEG); RESET(NOTMOVED);
  4118.     R0 := R0-R0; N3 := R0; N4 := R0; LITX := R0; ERRCOUNT := R0;
  4119.     R0 =: N5 =: N6;
  4120. $IFF
  4121.     RESET(REFOUT);  REFN1 := R0;  R1 := REFN3;  REFN2:= R1;
  4122. $END
  4123.     BEGENDLVL := R0;  SEGNAM := "SEG";
  4124.     ESDNAME(0/3) := SEGNAM; ESDNAME(10/3) := SEGNAM;
  4125.     PAGECOUNT := R0; CARDCOUNT := R0; BLOCK := R0;
  4126.     WBUFF(0/133) := BLANK; HEADER(19/75) := HEADER(18);
  4127.     SUBHEAD(1/132) := SUBHEAD;
  4128.     R0 := 13; SEGNO := R0; NSEGNO := R0; MAXSEG := R0;
  4129.     R0 := 1; CSEGNO := R0; PROCBR := R0;
  4130.     R9 := PROGBASE; R10 := DATABASE; R7 := STACKBASE - 16S;
  4131.     R0 := R0-R0; R1 := DATAESDADR; DC := R0;
  4132.     PL360NO(R1) := R0; SYMTYPE := R0;
  4133.     R2 := STRNGADR;  ADR(R2+2) := R0;
  4134.     R0 := ENDCHAIN; PREVSEG(R9) := R0; PREVSEG(R10) := R0;
  4135.     R2 := 1; R3 := PROGREG; R5 := R9;
  4136.     OPENSEG; R3 := R3 shll 12; PTAG := R3;
  4137.     R1 := PROGESDADR; R0 := R1; R2 := SD; R3 := VTYPE; R4 := 1;
  4138.     FINDESDENTRY; PROGESDEND := R0;
  4139.     WBUFF(0/133) := BLANK; R1 := LABELBASE; B1(0/12) := ZERO;
  4140.     R1 := NAMEPOINTER; N1 := R1; N2 := R1;
  4141.     for R2 := R2-R2 step 4S until MAXHASH do
  4142.     begin R3 := HASHCHAIN(R2); while R3 >= R1 do
  4143.        begin R3 := R3 + NAMEBASE; R3 := LINK(R3);
  4144.        end; HASHCHAIN(R2) := R3;
  4145. $IFF
  4146.        R3 := ENDCHAIN;  REFCHAIN(R2) := R3;
  4147. $END
  4148.     end;  CONDTAB(0/64) := CONDTAB xor CONDTAB;
  4149.     RESET(PRNT);  R6 := 71;  CBUF(71) := " ";  R5 := ENDFILE;
  4150.      !-- END OF INITIALIZATION SECTION, SYNTAX LOOP NEXT --!
  4151. $PAGE
  4152.   !-- ALGORITHM FOR SYNTACTIC ANALYSIS --!
  4153.  
  4154.  SYNLOOP:
  4155.     begin R7 := R7 + 16S; I := R7; S(R7) := R5;
  4156.        R5:=SYMTYPE;  T(R7):=R5;
  4157.        V(R7/10) := VALUE; INSYMBOL; RESET(NOTMOVED); R2 := S(R7);
  4158. $IFF
  4159.        if XREF and R5=IDENTSYMBOL and ^REFOUT then ENTEREF;
  4160. $END
  4161.  X:    R1 := R1-R1; IC(R1,F(R2)); R4 := @G(R5); EX(R1,CLI(0,B4));
  4162.        if < then  !-- G < F --!
  4163.        begin R4 := S(R7); R2 := R2 - R2;
  4164.  Y:       R7 := R7 - 16S; R3 := S(R7); STC(R4,RIGHTPART(R2));
  4165.           IC(R1,F(R3)); R0 := R5; R5 := @G(R4); EX(R1,CLI(0,B5));
  4166.           R5 := R0; if = then
  4167.           begin R4 := R3; R2 := @B2(1); if R2 < 10 then goto Y;
  4168.           end; R7 := R7 + 16S; SET(FLAG);
  4169.           R4 := R4 shll 1; R3 := MTB(R4) + PRTBASE;
  4170.  Z:       if FLAG then
  4171.           begin IC(R1,B3); if R1 ^= NOMORERULES then
  4172.              begin if R1 = R2 then
  4173.                 begin EX(R2,CLC(0,RIGHTPART,B3(1))); if = then
  4174.                    begin RESET(FLAG); IC(R1,B3(R2+3));
  4175.                       EXECUTE;   !-- DO THE RULE --!
  4176.                    end;
  4177.                    R3 := @B3(R2+4); goto Z;
  4178.                 end;
  4179.                 R3 := @B3(R1+4); goto Z;
  4180.              end;
  4181.           end;
  4182.           if FLAG then
  4183.           begin XR := 0; ERROR; SET(SKIPFLAG);
  4184.              R2 := 6 + LC;  LC := R2;
  4185.              R7 := I; R2 := S(R7); if R2 = SEMICOLON then goto B;
  4186.  A:          if R5 = SEMICOLON then INSYMBOL else
  4187.              if R5 ^= BEGINSYMBOL and R5 ^= ENDSYMBOL
  4188.                 and R5 ^= ENDFILE then
  4189.              begin INSYMBOL; goto A;
  4190.              end;
  4191.  B:          R2 := S(R7); if R2 = BLOCKBODY then
  4192.              begin R2 := BLOCKHEAD; S(R7) := R2;
  4193.              end else if R7 = STACKBASE then
  4194.              begin RESET(FLAG); if R2 = ENDFILE then
  4195.                 begin R2 := PROGMINUS; S(R7) := R2; RESET(NOPROGSEG);
  4196.                 end;
  4197.              end else
  4198.              if R2^=BLOCKHEAD and R2^=CASESEQ then
  4199.              begin if R2 = BEGINSYMBOL then RESET(FLAG);
  4200.                 R7 := R7 - 16S; goto B;
  4201.              end; if ^FLAG then
  4202.              begin R2 := BLOCKHEAD; if R2 = S(R7) then
  4203.                 begin R2 := BLOCKBODY; S(R7) := R2;
  4204.                 end; R7 := R7 + 16S; R2 := BEGINSYMBOL; S(R7) := R2;
  4205.              end; I := R7; if R5 = ENDFILE then goto C;
  4206.           end else
  4207.           begin I := R7; R3 := R3 - 2; IC(R2,B3); S(R7) := R2;
  4208.           end; goto X;
  4209.        end;
  4210.        if R5 ^= ENDFILE then goto SYNLOOP;
  4211.  C: end;
  4212.     if R7 ^= STACKBASE then
  4213.     begin XR := 0; ERROR;
  4214.     end;
  4215.     R6 := SAVERETURN;  !-- RESTORE RETURN REGISTER --!
  4216.  end;
  4217. $PAGE
  4218.   !-- *************** START HERE *************** --!
  4219.  
  4220.     R0 := 1;  !-- FIRST TIME IN MAIN --!
  4221. LOOP:  !-- COMPILE NEXT PROGRAM --!
  4222.     MAIN;  !-- EXECUTE MAIN PROGRAM --!
  4223.  
  4224. $IFT
  4225.  EXIT:  OUTPUTCARD;  WBUFF(0/133) := BLANK;  SETZONE(CARRCONT);
  4226. $END
  4227. $IFF
  4228.  EXIT: PRINTREFS;  WBUFF(0/133) := BLANK; SETZONE(CARRCONT);
  4229. $END
  4230.     if TM(XITF,FLGS); OFF then  !-- PRINT SEGMENT COUNT --!
  4231.     begin  WBUF := " `0`0`1`0 MAX SEG ASSIGNED.";
  4232.        R1 := 10 * MAXSEG;  CVD(R1,CONWORK);
  4233.        ED(4,WBUF,CONWORK(5));  CARRCONT := "0";  PRINT;
  4234.        WBUFF(0/133) := BLANK;  SETZONE(CARRCONT);
  4235.     end;  if ^RUNFLAG then
  4236.     begin
  4237. $IFT M M
  4238.        ERRPRINT;  !-- PRODUCE THE ERROR SUMMARY --!
  4239. $END M
  4240.        R1 := 10 * ERRCOUNT;  WBUF := "*** `0`0`1`0 ERRORS DETECTED ***";
  4241.        CVD(R1,CONWORK); ED(4,WBUF(3),CONWORK(5));
  4242.        R1 := ERRCOUNT; if R1 > ERRLIMIT then
  4243.        WBUF(25) := "- ERROR MESSAGE LISTING INCOMPLETE ***";
  4244.        R1 := R1 + ERRTOTL; ERRTOTL := R1; SB(NOGO,FLGS);
  4245.     end else if ^NOPROGSEG then
  4246.     WBUF := "      NO ERRORS DETECTED";  CARRCONT := "0";  PRINT;
  4247. $IFT M M
  4248.     R1 := @WBUFF;  SERCOMPR;
  4249. $END M
  4250.     if TM(XITF,FLGS); OFF then begin R0 := R0-R0; goto LOOP; end;
  4251.     if TM(NOGO,FLGS); ON then
  4252.     begin WBUFF(0/133) := BLANK;  CARRCONT := " ";
  4253.        R1 := 10 * ERRTOTL;  if R1=0 then goto X;
  4254.        WBUF := "***        ERRORS DETECTED IN ENTIRE COMPILATION";
  4255.        WBUF(4) := "`0`0`0`0`1`0";
  4256.        CVD(R1,CONWORK); ED(6,WBUF(3),CONWORK(4)); PRINT;
  4257. $IFT M M
  4258.        R1 := @WBUFF;  SERCOMPR;
  4259. $END M
  4260. X:     R0 := 16;
  4261.     end else R0 := R0-R0;
  4262.     SYSTERM(R9);  !-- RELEASE SYSTEM RESOURCES --!
  4263.     if = then R0 := R0+8S;  !-- => NOLOADSW=X'00' --!
  4264.     R2 := MEM(R13+4); MEM(R2+16) := R0;  !-- SET RETURN CODE --!
  4265.  end.
clone this paste RAW Paste Data