         Edinburgh IMP77 Compiler - Version 8.4

    1  ! Currently throwing a syntax error if more than one %OWN variable declared in one statement
    2  %CONTROL X'10000000' ; ! Decode
    3  
    4  ! There are two places where errors are generated when compiling the clean source of this
    5  ! compiler.  Since it should probably be expected to be able to compile itself, these errors
    6  ! are almost certainly bogus and a result of some difference in the sparc compiler used to
    7  ! compile this.  I have commented out those two error reports (look for '{' and 'erroneous')
    8  ! and when that is done the source does compile and the output looks plausible.
    9  
   10  ! I've supplied a recode and an lput which were missing from the allimpc1 source, and modified
   11  ! lput to output all the generated code and data, not just the code that recode outputs.
   12  ! Successive runs with no source changes produce *slightly* different output in the 'D' psect.
   13  ! This is either due to something time-related, or more likely, an unassigned variable.
   14  ! (It's not time-related as this code doesn't access CPU TIME, TIME, or DATE functions)
   15  
   16  ! Using the sparc compiler solves the problems that arose using other Imp77 compilers
   17  ! on little-endian machines like the Vax and X86.  Also the x86 compilers do not
   18  ! support both 32 bit integers and 16 bit integers.
   19  
   20  ! The Imp to C translator *ought* to be able to compile and run this if the
   21  ! mips C compiler is used as it too is big-endian.  Mips code runs under emulation
   22  ! on the X86 linux transparently.
   23  
   24  ! Note the compile-time warnings, Warning: value truncated to 16 bits signed at line 215
   25  ! - this is because %SHORTINTEGER is a signed 16 bit quantity but some of the data
   26  ! in the tables is initialised with *unsigned* 16 bit data in excess of 32767.  These
   27  ! constants could be replaced in the source with the negative literal values that
   28  ! would allow the source to compile without warnings.  This has not yet been done.
   29  
   30                 %BEGIN
   31  
   32  %constinteger debug=0
   33  %owninteger com2 = 20000 ;! free memory size?
   34  %owninteger com24 = 0    ;! exit code I think
   35  
   36  %integerfn com(%integer idx)
   37    %if idx=24 %then %result = com24
   38    %if idx=2  %then %result = com2
   39    %stop
   40  %end
   41  
   42  %routine setcom(%integer idx, val)
   43    %if idx=24 %then com24=val %and %return
   44    %if idx=2  %then com2 =val %and %return
   45    %stop
   46  %end
   47  
   48  %routine set short integer(%integer address, %short value)
   49    short integer(address) = value
   50  %end
   51  
   52  
   53                 %INTEGER I,J,K,SS
   54  %OWNBYTEINTEGERARRAY CLETT(1: 425)=   1,
   55+   43,   1,  45,   1,  92,   1,  40,   1,  41,   1,  33,   1,  44,   2,
   56+   42,  42,   2,  33,  33,   1,  42,   2,  47,  47,   1,  47,   1,  38,
   57+    2,  62,  62,   2,  60,  60,   1,  46,   1,  63,   2, 201, 198,   6,
   58+  213, 206, 204, 197, 211, 211,   7, 201, 206, 212, 197, 199, 197, 210,
   59+    4, 210, 197, 193, 204,   4, 194, 217, 212, 197,   5, 211, 200, 207,
   60+  210, 212,   4, 204, 207, 206, 199,   6, 211, 212, 210, 201, 206, 199,
   61+    7, 210, 207, 213, 212, 201, 206, 197,   2, 198, 206,   3, 205, 193,
   62+  208,   4, 206, 193, 205, 197,   6, 210, 197, 195, 207, 210, 196,   4,
   63+  211, 212, 207, 208,   7, 195, 207, 205, 208, 201, 204, 197,   6, 201,
   64+  199, 206, 207, 210, 197,   2, 207, 206,   3, 207, 198, 198,   5, 193,
   65+  210, 210, 193, 217,   3, 193, 206, 196,   2, 207, 210,   2,  61,  61,
   66+    1,  61,   2,  60,  45,   2,  45,  62,   4, 211, 208, 197, 195,   6,
   67+  206, 207, 210, 205, 193, 204,   6, 214, 197, 195, 212, 207, 210,   1,
   68+   58,   2,  62,  61,   1,  62,   1,  35,   2,  60,  61,   1,  60,   2,
   69+   92,  61,   4, 197, 204, 211, 197,   1,  95,   6, 211, 217, 211, 212,
   70+  197, 205,   8, 197, 216, 212, 197, 210, 206, 193, 204,   5, 195, 204,
   71+  193, 201, 205,   7, 210, 197, 204, 197, 193, 211, 197,   1,  80,   3,
   72+   80,  85,  84,   1,  64,   9, 208, 210, 201, 206, 212, 212, 197, 216,
   73+  212,   6, 210, 197, 212, 213, 210, 206,   7, 210, 197, 211, 213, 204,
   74+  212,  61,   7, 205, 207, 206, 201, 212, 207, 210,   5, 211, 212, 193,
   75+  210, 212,   7, 209, 213, 197, 210, 201, 197, 211,   5, 195, 217, 195,
   76+  204, 197,   6, 210, 197, 208, 197, 193, 212,   4, 212, 200, 197, 206,
   77+    3, 197, 206, 196,   7, 195, 207, 205, 205, 197, 206, 212,   5, 210,
   78+  197, 193, 204, 211,   5, 194, 197, 199, 201, 206,   2, 207, 198,   7,
   79+  208, 210, 207, 199, 210, 193, 205,   6, 211, 215, 201, 212, 195, 200,
   80+    8, 210, 197, 199, 201, 211, 212, 197, 210,   3, 207, 215, 206,   5,
   81+  205, 195, 207, 196, 197,   5, 198, 193, 213, 204, 212,   4, 198, 201,
   82+  204, 197,   6, 196, 197, 198, 201, 206, 197,   1, 210,   7, 211, 208,
   83+  197, 195, 201, 193, 204,   4, 204, 201, 211, 212,   7, 195, 207, 206,
   84+  212, 210, 207, 204,   6, 198, 201, 206, 201, 211, 200,   6, 198, 207,
   85+  210, 205, 193, 212;
   86  %OWNSHORTINTEGERARRAY SYMBOL(1300: 2148)=  1309,
   87+   1303,     1,  1305,     3,  1307,     5,  1309,  1000,  1316,  1312,
   88+      1,  1314,     3,  1316,  1000,  1335,  1321,  1001,  1342,  1706,
   89+   1323,  1003,  1329,     7,  1300,  1316,  1335,     9,  1335,    11,
   90+   1300,  1316,  1335,    11,  1342,  1340,  1361,  1316,  1335,  1342,
   91+   1000,  1352,  1350,     7,  1300,  1316,  1335,  1352,     9,  1352,
   92+   1000,  1361,  1359,    13,  1300,  1316,  1335,  1352,  1361,  1000,
   93+   1388,  1364,    15,  1366,     1,  1368,     3,  1370,    18,  1372,
   94+     11,  1374,    21,  1376,    23,  1378,    26,  1380,    28,  1382,
   95+     30,  1384,    33,  1386,    36,  1388,  1000,  1393,  1391,    38,
   96+   1393,  1000,  1398,  1396,    13,  1398,  1000,  1403,  1401,    40,
   97+   1403,    43,  1420,  1406,    50,  1408,    58,  1411,    63,    50,
   98+   1414,    68,    50,  1417,    74,    58,  1420,    79,  1883,  1426,
   99+   1423,    86,  1426,  1403,  1426,  1431,  1429,    94,  1431,    97,
  100+   1445,  1435,  1420,  1467,  1438,  1403,  1472,  1441,  1462,   101,
  101+   1445,   106,  1462,   101,  1450,  1448,  1005,  1450,  1001,  1457,
  102+   1453,   113,  1455,   118,  1457,   126,  1462,  1460,   133,  1462,
  103+    136,  1467,  1465,   140,  1467,  1000,  1472,  1470,   101,  1472,
  104+   1000,  1484,  1477,   101,   140,   101,  1480,   140,   101,  1482,
  105+    101,  1484,  1000,  1493,  1491,     7,  1431,  1009,  1493,     9,
  106+   1493,  1000,  1501,  1499,  1393,  1431,  1009,  1493,  1501,  1000,
  107+   1520,  1513,  1010,  1300,  1316,  1335,  1669,  1300,  1316,  1335,
  108+   1520,  1011,  1520,     7,  1010,  1501,  1528,  1011,     9,  1528,
  109+   1526,  1669,  1300,  1316,  1335,  1528,  1000,  1539,  1533,   146,
  110+   1501,  1539,  1537,   150,  1501,  1546,  1539,  1000,  1546,  1544,
  111+    146,  1501,  1539,  1546,  1000,  1553,  1551,   150,  1501,  1546,
  112+   1553,  1000,  1562,  1560,  1562,  1300,  1316,  1335,  1388,  1562,
  113+   1000,  1571,  1565,   153,  1567,   156,  1569,   158,  1571,   161,
  114+   1576,  1574,   164,  1576,  1000,  1581,  1579,    74,  1581,   169,
  115+   1588,  1586,    13,  1714,  1581,  1588,  1000,  1599,  1592,  1472,
  116+   1009,  1596,  1467,   140,  1599,  1599,   176,  1613,  1607,  1607,
  117+   1009,     7,  1714,  1581,     9,  1607,  1613,  1611,    13,  1599,
  118+   1613,  1000,  1618,  1618,  1009,  1635,  1618,  1624,  1622,    13,
  119+   1613,  1624,  1000,  1635,  1629,  1001,  1723,  1006,  1635,   140,
  120+   1001,  1635,  1890,  1004,  1644,  1644,     7,  1309,  1003,   183,
  121+   1309,  1003,     9,  1651,  1649,    13,  1005,  1644,  1651,  1000,
  122+   1661,  1659,    13,  1005,  1644,   161,  1445,  1651,  1661,  1000,
  123+   1669,  1667,    13,  1009,  1635,  1661,  1669,  1000,  1686,  1672,
  124+    156,  1674,   185,  1676,   188,  1678,   190,  1680,   192,  1682,
  125+    195,  1684,   197,  1686,   161,  1694,  1689,  1006,  1694,  1398,
  126+   1501,  1528,  1006,  1700,  1698,   200,  1902,  1700,  1000,  1706,
  127+   1704,   205,  1001,  1706,  1000,  1714,  1712,   205,  1001,  1342,
  128+   1706,  1714,  1000,  1723,  1723,  1300,  1316,  1335,   183,  1300,
  129+   1316,  1335,  1730,  1728,   156,  1300,  1003,  1730,  1000,  1737,
  130+   1733,   207,  1735,   214,  1737,  1000,  1742,  1740,   223,  1742,
  131+    229,  1747,  1745,   140,  1747,   106,  1757,  1755,  1393,  1403,
  132+   1467,   140,  1599,  1747,  1757,  1000,  1764,  1762,  1431,  1009,
  133+   1493,  1764,  1000,  1772,  1768,  1001,  1857,  1772,   195,  1445,
  134+    188,  1785,  1780,  1005,     7,  1005,    13,  1005,     9,  1785,
  135+   1764,     7,  1005,     9,  1792,  1789,  1764,  1883,  1792,  1005,
  136+   1792,  1805,  1799,     7,  1005,    13,  1005,     9,  1803,     7,
  137+   1005,     9,  1805,  1000,  1811,  1809,    13,  1003,  1811,  1000,
  138+   1817,  1814,  1764,  1817,  1005,  1883,  1857,  1823,  1012,  1005,
  139+     13,  1005,  1828,  1013,  1005,    13,  1785,  1835,  1014,  1005,
  140+     13,  1005,    13,  1811,  1839,  1015,  1811,  1805,  1844,  1016,
  141+   1005,    13,  1811,  1849,  1017,  1772,    13,  1811,  1854,  1018,
  142+   1772,    13,  1772,  1857,  1019,  1005,  1863,  1861,     1,  1005,
  143+   1863,  1000,  1883,  1872,    21,  1005,    13,  1895,  1001,  1342,
  144+   1706,  1876,   161,   237,  1005,  1879,  1002,  1817,  1883,   239,
  145+    205,  1003,  1890,  1888,     7,  1005,     9,  1890,  1000,  1895,
  146+   1893,   156,  1895,  1000,  1902,  1898,   243,  1900,   156,  1902,
  147+   1000,  1943,  1910,  1010,  1001,  1342,  1706,  1011,  1553,  1918,
  148+    161,  1001,     7,  1300,  1316,  1335,     9,  1921,   161,  1445,
  149+   1924,   245,  1008,  1926,   255,  1931,   262,  1300,  1316,  1335,
  150+   1933,   113,  1936,   270,   113,  1938,   278,  1940,   270,  1943,
  151+    284,  1457,  2149,  1949,  1010,  1902,  1011,  1686,  1967,   292,
  152+   1001,  1342,  1706,   156,  1300,  1316,  1335,    13,  1300,  1316,
  153+   1335,    13,  1300,  1316,  1335,  1006,  1970,   298,  1006,  1973,
  154+   1445,   183,  1985,  1398,  1010,  1501,  1528,   305,  1011,  1010,
  155+   1902,  1011,  1694,  1006,  1988,    11,  1007,  1992,  1403,  1588,
  156+   1006,  1995,   310,  1006,  2004,  1010,  1730,  1420,  1011,  1571,
  157+   1001,  1484,  1006,  2007,   314,  1007,  2011,   322,  1576,  1006,
  158+   2014,   328,  1006,  2019,   310,   334,   337,  1006,  2026,  1001,
  159+      7,  1309,  1003,     9,   183,  2032,   345,  1009,  1635,  1661,
  160+   1006,  2036,  1450,   284,  1006,  2040,   352,  1001,  1006,  2044,
  161+    361,  1403,  1624,  2050,  1737,  1742,   352,  1001,  1006,  2053,
  162+    365,  1006,  2057,    68,    86,  1006,  2061,    21,  1863,  1006,
  163+   2069,   371,  1005,  1644,   161,  1445,  1651,  1006,  2074,   310,
  164+    334,   377,  1006,  2079,   310,   334,   365,  1006,  2084,   382,
  165+    118,   389,  1006,  2090,   164,  1001,  1706,  1484,  1006,  2095,
  166+    391,   101,  1001,  1006,  2098,   399,  1006,  2103,   310,   334,
  167+    399,  1006,  2107,   404,  1003,  1006,  2111,   412,  1694,  1006,
  168+   2120,   106,   419,  1001,     7,  1757,  1747,     9,  1006,  2129,
  169+    106,  1010,  1588,  1011,     7,  1001,     9,  1006,  2136,  1010,
  170+   1420,   101,  1011,  1009,  1006,  2147,   106,   164,  1010,  1001,
  171+   1700,  1011,     7,  1001,     9,  1006,  2149,  1006;
  172  SS= 1943
  173           %OWNBYTEINTEGERARRAY OPC(0:120)=0,
  174+              8,9,X'10',X'11',X'12',
  175+                X'13',X'20',X'21',X'22',X'23',
  176+                X'30',X'31',X'32',X'33',X'24',
  177+                X'34',0,X'45',X'46',X'47',
  178+                X'54',X'55',X'56',X'57',X'58',X'59',X'5A',X'5B',X'5C',
  179+                X'5D',X'5E',X'5F',X'68',X'69',X'6A',
  180+                X'6B',X'6C',X'6D',X'6E',X'6F',
  181+                X'78',X'79',X'7A',X'7B',X'7C',
  182+                X'7D',X'7E',X'7F',0,X'70',
  183+                X'60',X'50',X'4E',X'4F',X'4C',
  184+                X'4B',X'4A',X'49',X'48',X'44',
  185+                X'43',X'42',X'41',X'40',0,
  186+                X'90',X'98',X'86',X'87',0,
  187+                X'91',X'92',X'94',X'95',X'96',
  188+                X'97',X'9C',X'9E',X'9D',X'9F',
  189+                X'82',X'84',X'85',0,X'88',
  190+                X'89',X'8A',X'8B',X'8C',X'8D',
  191+                X'8E',X'8F',0,X'D0',X'D1',
  192+                X'D2',X'D4',X'D5',X'D6',X'D7',
  193+                X'D8',X'DC',X'DD',X'DE',X'DF',
  194+                X'D3',0,X'F1',X'F2',X'F3',
  195+                X'F8',X'F9',X'FA',X'FB',X'FC',
  196+                X'FD',0,10,4,X'80';
  197           %OWNINTEGERARRAY NEM(0:120)=M'CNOP',
  198+                M'ISK',M'SSK',M'LP',M'LN',M'LT',
  199+                M'LC',M'LPD',M'LND',M'LTD',M'LCD',
  200+                M'LPE',M'LNE',M'LTE',M'LCE',M'HD',
  201+                M'HE',0,M'BAL',M'BCT',M'BC',
  202+                'N',M'CL','O','X','L','C','A','S','M','D',
  203+                M'AL',M'SL',M'LD',M'CD',M'AD',
  204+                M'SD',M'MD',M'DD',M'AW',M'SW',
  205+                M'LE',M'CE',M'AE',M'SE',M'ME',
  206+                M'DE',M'AU',M'SU',0,M'STE',
  207+                M'STD',M'ST',M'CVD',M'CVB',M'MH',
  208+                M'SH',M'AH',M'CH',M'LH',M'EX',
  209+                M'IC',M'STC',M'LA',M'STH',0,
  210+                M'STM',M'LM',M'BXH',M'BXLE',0,
  211+                M'TM',M'MVI',M'NI',M'CLI',M'OI',
  212+                M'XI',M'SDV',M'HDV',M'TDV',M'CKC',
  213+                M'PC',M'WRD',M'RDD',0,M'SRL',
  214+                M'SLL',M'SRA',M'SLA',M'SRDL',M'SLDL',
  215+                M'SRDA',M'SLDA',0,M'SSP',M'MVN',
  216+                M'MVC',M'NC',M'CLC',M'OC',M'XC',
  217+                M'LSP',M'TR',M'TRT',M'ED',M'EDMK',
  218+                M'MVZ',0,M'MVO',M'PACK',M'UNPK',
  219+                M'ZAP',M'CP',M'AP',M'SP',M'MP',
  220+                M'DP',0,M'SVC',M'SPM',M'IDL';
  221           %OWNSHORTINTEGERARRAY CLODS(0:88)=  %C
  222+                4,X'50CD',X'001C',X'58CD',X'5C',
  223+                4,X'50FB',X'003C',X'45FC',X'4C',
  224+          6,X'5820',X'2000',X'0620',
  225+                X'8920',24,X'1602',0,
  226+                8,X'50B0',0,X'4AB0',X'4002',
  227+                    X'41BB',X'7',X'54BD',84,
  228+                4,X'581D',36,X'9200',X'1001',
  229+                11,X'0510',X'2826',X'6E6D',X'48',
  230+                    X'6A6D',X'28',X'2B26',X'47B0',
  231+                    X'1014',X'6A2D',X'30',
  232+                4, X'9003',X'B000',X'41BB',X'10',
  233+                5, X'4100',0,X'58EC',186,X'5FE',
  234+                5, X'904E',X'B010',X'98CE',
  235+                    X'D000',X'5FE',
  236+                7, X'904E',X'B010',X'98CF',0,
  237+                    X'9859',X'F014',X'5FE',
  238+                5,X'4100',255,X'8900',X'18',X'1610',
  239+                6,X'4100',4,X'59BD',X'44',
  240+                    X'4720',X'C054',
  241+                6,X'6000',X'B040',X'4100',12,X'5000',X'B048'
  242           %OWNBYTEINTEGERARRAY TSNAME (0:50)=0(8),
  243+                1,0(5),1,26,1,1,26,0(2),2,1,26(8),
  244+                3,9,17,26(2),1,0,1,26,0(2),5,0(8)
  245           NEWLINES(3); SPACES(30)
  246           print string("E.R.C.C. IMP(SYS1) COMPILER ")
  247           print string(" RELEASE 5 ALL-IMP VERSION")
  248           print string("   DATED 1/5/70")
  249           NEWLINES(3)
  250           %OWNBYTEINTEGERARRAY BYTES(0:3)=4,1,2,8;
  251           %OWNBYTEINTEGERARRAY PRECEDENCE (1:12)=0,3,3,3,3,4,4,4,4,5,5,5;
  252           %OWNBYTEINTEGERARRAY TYPEFLAG(1:6)=1,2,
  253+                B'1001',B'10001',B'11010',5;
  254           %OWNINTEGER MASK1=X'0F0F0F0F'
  255           %OWNINTEGER MASK2=X'0F0F0F0F'
  256           %OWNSHORTINTEGER MAXLEVELS=11
  257           %OWNINTEGER CODER=12
  258           %OWNINTEGER  LINK =15
  259           %OWNINTEGER  WSPR =11
  260           %OWNINTEGER  GLA =13
  261           %SHORTINTEGER CCSIZE,ARSIZE,DSIZE,NROUTS
  262           %ROUTINESPEC SIZES
  263           %INTEGER ASL,NNAMES
  264           %INTEGER CABUF,PPCURR,QPREAL,OLDLINE
  265           %INTEGER LINE,LENGTH,LENGTHP,N0,NUM,SNUM
  266           %INTEGER RLEVEL,NMAX,OWNLINK,CONSTPTR
  267           %INTEGER PLABEL,LEVEL,CA,MARKER1,MARKER2,LABSET
  268           %INTEGER R13,RP13,SIGFIGS
  269           %BYTEINTEGER AFLAG,FFLAG,CHECKS,SBFLAG
  270           %BYTEINTEGER FAULTY,MONE,HIT,QU,PERM,MCSWITCH,LIST,ALLLONG
  271           %BYTEINTEGER LINENOS,DIAGS1,DIAGS2,CHECKSP
  272           %BYTEINTEGER CTYPE,DCOMP,COMPILER,CPRMODE
  273           %BYTEINTEGER UNASS,PRINTMAP
  274           %LONGREAL CVALUE,IMAX
  275           %INTEGER MASK,RBASE,SFLABEL
  276  %INTEGER NEXT,N,NR,ITEM,STRINST
  277           %INTEGER P,Q,R,S,T,U,V,NEST,FNAME
  278           %INTEGER XREFLINK,LDPTR
  279           %SHORTINTEGER NEPS,EPLINK
  280           %INTEGER SSTL,QMAX,STMTS
  281                 %INTEGERARRAY REGISTER(0:15)
  282           %INTEGERARRAY ST(0:1300)
  283           %INTEGER %ARRAY SET,CODEBASE,FREG,RAL(0:MAXLEVELS)
  284           %SHORTINTEGERARRAY CYCLE,JUMP,NAME,LABEL,FLAG,SBR,WSP,%C
  285+ L,M,LWSP,MDARR,RNEXT,NMDECS,STRWSP(0:MAXLEVELS)
  286           %SHORTINTEGERARRAY CODE(0:192)
  287           %SHORTINTEGERARRAY PAGENOS(0:50)
  288           %INTEGERARRAY UVARREG(5:8)
  289           SIZES
  290           %BYTEINTEGERARRAY CC(0:CCSIZE),ASLIST(0:ASL),LETT(0:DSIZE+20)
  291           %SHORTINTEGERARRAY RA(0:NROUTS),A(-2:ARSIZE)
  292           %SHORTINTEGERARRAY WORD,TAGS(0:NNAMES)
  293           {%SYSTEMINTEGERFNSPEC COM(%INTEGER N)
  294           {%SYSTEMROUTINESPEC SET COM(%INTEGER I,J)
  295           {%SYSTEMROUTINESPEC IOCP(%INTEGER A,B)
  296           %ROUTINESPEC CNOP(%INTEGER I,J)
  297           %ROUTINESPEC PCONST(%INTEGER X)
  298           %ROUTINESPEC PSI(%INTEGER OPCODE,J,BASE,DISP)
  299           %ROUTINESPEC PSS(%INTEGER OPCODE,N,BASE,DISP,P,Q)
  300           %ROUTINESPEC PRX(%INTEGER OPCODE,R1,R2,BASE,DISP)
  301           %ROUTINESPEC PACLOD(%INTEGER PTR,AT,VALUE)
  302           %ROUTINESPEC PCLOD(%INTEGER PTR)
  303           %ROUTINESPEC PLANT(%INTEGER VALUE)
  304           %ROUTINESPEC PRR (%INTEGER OPCODE,R1,R2)
  305           %EXTERNALROUTINESPEC LPUT(%INTEGER A,B,C,D)
  306           %ROUTINESPEC PLUG(%INTEGER J,K)
  307           %ROUTINESPEC PRHEX(%INTEGER VALUE,PLACES)
  308           %ROUTINESPEC INITIALISE
  309           %ROUTINESPEC PSYM(%INTEGER X)
  310                  %ROUTINESPEC COMPARE
  311           %ROUTINESPEC PNAME
  312           %ROUTINESPEC CONST(%BYTEINTEGER MODE)
  313           %ROUTINESPEC CONSTLIST
  314           %ROUTINESPEC TEXTTEXT
  315           %ROUTINESPEC FROMAR8(%INTEGER PTR,%LONGREALNAME VALUE)
  316           %ROUTINESPEC FROMAR4(%INTEGER PTR,%INTEGERNAME VALUE)
  317           %ROUTINESPEC TOAR8(%INTEGER PTR,%LONGREAL VALUE)
  318           %ROUTINESPEC TOAR4(%INTEGER PTR,VALUE)
  319           %ROUTINESPEC CSS(%INTEGER P)
  320           %ROUTINESPEC FAULT(%BYTEINTEGER N)
  321            %ROUTINESPEC FINALISE
  322                  %ROUTINESPEC PRINT NAME (%INTEGER N)
  323  
  324           ! Using an alternative RECODE extracted from PSR's IMPI interpreter.
  325           %EXTERNALROUTINESPEC RECODE (%INTEGER START,FINISH,CA)
  326  
  327           %ROUTINESPEC READ LINE(%BYTEINTEGER N)
  328           %on %event 9 {,18} %start
  329             %if 0=0 {event_event = 9} {TEMP UNTIL RECORD FIELDS WORKING} %then ->INEND
  330             ! %if event_event = 18 %then ->SUBSCHAR
  331             ! I need to find out which characters were being substituted!
  332             ! %signal %event event
  333           %finish
  334   ! START OF COMPILATION
  335           INITIALISE
  336           LPUT(0,1,1,ADDR(LETT(1)))
  337  L8:       READLINE(0); Q=1
  338  L5:       R=1; P=SS
  339           OLDLINE=LINE; COMPARE
  340           FAULT(102) %IF R>ARSIZE
  341                 ->L6 %IF HIT=0
  342           STMTS=STMTS+1
  343            CSS(1)
  344           %IF DCOMP#0 %AND CA>CABUF %THEN %START
  345           RECODE(ADDR(CODE(0)),ADDR(CODE(PPCURR)),CABUF)
  346           NEWLINE
  347           LPUT(1,CA-CABUF,CABUF,ADDR(CODE(0)))
  348           PPCURR=0; CABUF=CA; %FINISH
  349           ->L7 %IF A(1)=13;              ! END OF PROGRAM
  350  L9:       ->L8 %IF Q>=LENGTH              ;->L5
  351  L6:             FAULT(100); ->L9
  352  L7:             !DEAL WITH END OF PROGRAM
  353            FINALISE
  354           SET COM(24,0) %IF COMPILER =0 %AND FAULTY=0
  355           %STOP
  356  INEND:   FAULT(108)
  357  SUBSCHAR:LINE=LINE+1;FAULT(48)
  358           SPACES(5)
  359  L15:      READSYMBOL(I); ->L8 %IF I=10
  360           PRINTSYMBOL(I); ->L15
  361            %ROUTINE    FINALISE
  362           N0=N0+1 %IF N0&1#1
  363           CNOP(0,8);ST(0)=X'20000'
  364           ST(1)=X'10100000'
  365           ST(4)=-1; ST(6)=255
  366  ST(8)=OWNLINK
  367           ST(12)=X'41100000';           ! D'1'
  368           ST(14)=X'41200000';           ! D'2'
  369           ST(18)=X'4E000000';           ! FOR IN LINE FLOATING
  370           ST(20)=-4; ST(21)=-8
  371           ST(22)=XREFLINK; XREFLINK=88
  372           ST(26)=X'80000000'; ST(27)=X'06492350'; ST(28)=M'ERMA'
  373           !!                          ^^^^^^^^^          ^^^^^^           WARNING! Big-endian issue?
  374           ST(29)=X'904EB010';           ! ROUTINE ENTRY SUBROUTINE
  375           ST(30)= X'5A10D01C'
  376           ST(31)=X'07F10700'
  377           ST(32)=X'80808080'
  378           ST(33)=X'80808080'
  379           ST(38)=X'80000000'; ST(39)=X'06532349'; ST(40)=M'OCP '
  380           !!                         ^^^^^^^^^^^         ^^^^^^^          WARNING! More Big-endianness?
  381           K=CA
  382           LPUT(1,CA-CABUF,CABUF,ADDR(CODE(0))) %UNLESS CA=CABUF
  383           LPUT(2,N0<<2+4,0,ADDR(ST(0)));! GLA
  384           FAULT(99) %IF N0>1023
  385           I=X'E2E2E2E2'
  386           LPUT(4,4,SSTL,ADDR(I))
  387           %IF CONSTPTR&1#0 %THEN PSYM(0)
  388           ->L129 %IF FAULTY #0
  389           NEWLINE; WRITE(STMTS,4)
  390           print string(" STATEMENTS COMPILED SUCCESSFULLY")
  391  L120:          print string("
  392+ CODE OCCUPIES")
  393           WRITE(K,3);print string(" BYTES      GLAP")
  394           WRITE(N0<<2,3); print string(" +")
  395           WRITE(CONSTPTR<<2,1); print string(" BYTES      DIAG TABLES")
  396           WRITE(SSTL+4,4); print string(" BYTES      TOTAL")
  397           ST(0)=CA; ST(1)=N0<<2+4
  398           ST(2)=(LDPTR<<2+7)&(-8); ST(3)=(SSTL+11)&(-8)
  399           ST(4)=CONSTPTR<<2
  400           ST(5)=CA+ST(1)+ST(2)+ST(3)+ST(4)
  401           WRITE(ST(5),5); print string(" BYTES")
  402           NEWLINE
  403           NEWLINE
  404           LPUT(7,24,0,ADDR(ST(0)))
  405  %RETURN
  406  L129:     print string("
  407+ PROGRAM CONTAINS"); WRITE(FAULTY,2); print string(" FAULTS"); ->L120
  408           %END
  409           %ROUTINE     READ LINE(%BYTEINTEGER N)
  410           !%SHORTROUTINE
  411           %INTEGER DEL
  412           %BYTEINTEGER NP
  413           %COMMENT ABOUT 30% CPU TIME OF COMPILATION IS SPENT IN THIS
  414           %COMMENT ROUTINE AS WRITTEN. A HAND CODED VERSION USING I
  415           %COMMENT ISO CARD NOT READ SYMBOL IS USED IN PRODUCTION VRSN
  416           Q=1; LINE=LINE+1
  417           LENGTH=0; DEL=0
  418  L1:       ->START %UNLESS N=0 %AND NEXT SYMBOL=10;! IGNORE EMPTY LINES
  419           SKIP SYMBOL; ->L1;                       ! IN PROGRAM MODE ONLY
  420  START:   ->L2 %IF LIST=0
  421           WRITE(LINE,5)
  422           PRINT SYMBOL('''') %IF N#0
  423           SPACES(4*LEVEL-N)
  424  L2:       READ SYMBOL(I)
  425           PRINT SYMBOL(I) %UNLESS LIST=0
  426           ->L4 %UNLESS N=0
  427           ->L3 %UNLESS I='%'
  428           DEL=128; ->L2
  429  L3:       DEL=0 %UNLESS 'A'<=I<='Z'
  430           ->L2 %IF I=' '
  431  L4:       LENGTH=LENGTH+1
  432           CC(LENGTH)=I!DEL
  433           %IF I='''' %THEN N=1-N
  434           ->L2 %UNLESS I=10
  435           %RETURN %UNLESS CC(LENGTH-1)= 'C'+128
  436           LENGTH=LENGTH-1
  437           ->L2 %IF LIST=0
  438           SPACES(5); PRINTSYMBOL('C'); SPACES(4*LEVEL); ->L2
  439           %END
?NP unused
  440           %ROUTINE     FAULT(%BYTEINTEGER N)
  441           !%SHORTROUTINE
  442           %INTEGER I,J,QP
  443           print string("
  444+ *");      WRITE(LINE,4); I=3; I=3*LEVEL %IF LIST=0     ; SPACES(I)
  445           FAULTY=FAULTY+1
  446           ->L9 %IF N=100; print string("FAULT"); WRITE(N,2)
  447           ->L2 %IF N<100; print string(" DISASTER ")
  448           %MONITOR ; %STOP
  449  L2:       PRINTNAME(FNAME) %UNLESS 7#N#16; ->L99
  450  L9:       print string("  SYNTAX   ")
  451           ->L11 %IF LINE#OLDLINE
  452           QP=Q
  453                 %CYCLE Q=Q,1,LENGTH-1
?Non-local
  454                 %IF CC(Q)&128 # 0 %THEN PRINTSYMBOL(CC(Q)&127-'A'+'a') %ELSE PRINTSYMBOL(CC(Q))
  455                 ->L10 %IF CC(Q)=';'
  456           %REPEAT
  457  L10:            Q =Q+1
  458           ->L99 %IF I+20+Q-QP>120
  459           NEWLINE; SPACES(I+QMAX-QP+17)
  460           PRINTSYMBOL('!')
  461           NEWLINE
  462           ->L99
  463  L11:      print string("
  464+          TEXT MODE FAILURE "); WRITE(LINE-OLDLINE,1)
  465           print string(" LINES LOST ")
  466           NEWLINE; Q=QMAX
  467  L99:      NEWLINE; %END
?J unused
  468                 %ROUTINE COMPARE
  469           !%SHORTROUTINE
  470           %INTEGER RA,RP,RQ,RR,RS,MARKER
  471           %SWITCH BIP(1000:1019)
  472           RP=SYMBOL(P)
  473           RQ=Q; RR=R;                   ! RESET VALUES OF LINE&AR PTRS
  474           A(R)=1;                       ! FIRST ALTERNATIVE TO BE TRIED
  475           P=P+1; RA=SYMBOL(P); RS=P;    ! RA TO NEXT PHRASE ALTERNATIVE
  476           %COMMENT  ROUTINE REALLY STARTS HERE
  477  L1:       R=R+1
  478  BIP(1000):L2:                           ! SUCCESS ON TO NEXT ITEM
  479           RS=RS+1; ->L8 %IF RS=RA;       ! RS=NEXT ALTERNATIVE MEANS THAT
  480                                         ! THIS ALT HAS BEEN COMPLETED SO
  481                                         ! EXIT WITH HIT=1
  482           ITEM=SYMBOL(RS);              ! NEXT BRICK IN THE CURRENT ALT
  483           ->L4 %IF ITEM>=1300;           ! BRICK IS A PHRASE TYPE
  484           ->L6 %IF ITEM>=1000;           ! BRICK IS BUILT IN PHRASE
  485           %CYCLE J=1,1,CLETT(ITEM);
?Non-local
  486                                    ;     ! BRICK IS LITERAL
  486           ->L3 %UNLESS CC(Q)=CLETT(J+ITEM)
  487           Q=Q+1; %REPEAT;               !CHECK IT WITH LITERAL DICT ENTRY
  488           ->L2;                          ! MATCHED SUCCESSFULLY
  489  L4:                                     ! PHRASE TYPE ALTERNATE
  490           P=ITEM; COMPARE;              ! RCALL COMPARE TO RECOGNISE IT
  491           ->L2 %IF HIT#0;                ! FOUND
  492  L3:       QMAX=Q %IF Q>QMAX;            ! FAILURE - NOTE POSITION REACHD
  493           Q=RQ; R=RR;                   ! RESET LINE AND A.R. POINTERS
  494           ->L7 %IF RA=RP;                !TOTAL FAILURE NO ALT LEFT TO TRY
  495           RS=RA; A(R)=A(R)+1;           ! MOVE TO NEXT ALT OF PHRASE
  496           RA=SYMBOL(RA); ->L1
  497  L8:                                     ! COMPLETE SUCCESS
  498           HIT=1; %RETURN
  499  L7:                                     ! UTTER FAILURE
  500           HIT=0; %RETURN
  501  L6:                                     ! BUILT IN PHRASE
  502           I=CC(Q); ->BIP(ITEM);         ! SO SWITCH TO IT
  503  BIP(1001):                             ! PHRASE NAME
  504                 PNAME; ->L1 %IF HIT=1; ->L3
  505  BIP(1002):                             ! PHRASE U/CODE INSRN
  506           ->L3 %UNLESS 'A'<=I<='Z'
  507           S=I; J=1
  508  L200:     Q=Q+1; I=CC(Q)
  509           ->L201 %UNLESS 'A'<=I<='Z'
  510           S=S<<8!I;J=J+1; ->L200
  511  L201:     ->L3 %UNLESS I='_' %AND J<=4
  512           Q=Q+1; ->L2
  513  BIP(1003):                             ! PHRASE CONST
  514           CONST(0)
  515                 ->L3 %IF HIT=0
  516           ->L1 %IF CTYPE=5
  517           ->L26 %IF CTYPE=2;             ! %REAL
  518           ->L22 %IF S>>12=0
  519           A(R)=1
  520           TOAR4(R+1,S); R=R+3; ->L2
  521  L22:      A(R)=9; R=R+1; A(R)=S; ->L1
  522  L26:      A(R)=2; TOAR8(R+1,CVALUE); R=R+5; ->L2
  523  BIP(1005):                             ! PHRASE N
  524           ->L3 %UNLESS '0'<=I<='9';      ! MUST START WITH DIGIT
  525           CONST(2); A(R)=S; ->L1
  526  BIP(1004):                             ! PHRASE CONSTLIST
  527           CONSTLIST;->L1
  528  BIP(1006):                             ! PHRASE S=SEPARATOR
  529           ->L2 %IF I=10
  530           ->L3 %UNLESS I=';'
  531           Q=Q+1; ->L2
  532  BIP(1007):L30:                          ! PHRASE TEXT=COMMENT TEXT
  533           ->L1 %UNLESS 10#I#';'
  534           Q=Q+1; I=CC(Q); ->L30
  535  BIP(1008):                             ! PHRASE TEXTTEXT=BETWEEN QUOTES
  536           TEXTTEXT
  537           ->L3 %IF HIT=0;->L1
  538  BIP(1009):                             ! PHRASE NAMELIST
  539           ! GIVES AR IN FORM NNAMES,NAME1,....NAMEN
  540           U=R; V=1; R=R+1
  541           PNAME; ->L3 %IF HIT=0
  542  L90:      ->L91 %UNLESS CC(Q)=','
  543           Q=Q+1; R=R+1
  544           I=CC(Q)
  545           PNAME
  546           ->L92 %IF HIT=0; V=V+1; ->L90
  547  L92:      R=R-1; Q=Q-1
  548  L91:      A(U)=V; ->L1
  549  BIP(1010):                             ! PHRASE HOLE
  550           MARKER=R; ->L1
  551  BIP(1011):                             ! PHRASE MARK
  552           A(MARKER)=R-MARKER; ->L2
  553  BIP(1012):                             ! PHRASE UCRR=RR FORMAT
  554           ->L124 %IF S&255='R';          ! LAST LETTER=R
  555           %CYCLE I=0,1,2
?Non-local
  556           ->L120 %IF S=NEM(I)
  557           %REPEAT; ->L3
  558  L120:     A(R)=OPC(I)&63; ->L1
  559  L124:       J=S>>8; %CYCLE I=2,1,48
?Non-local
  560           ->L120 %IF J=NEM(I)
  561           %REPEAT; ->L3
  562  BIP(1013):                             ! PHRASE UCRX=RX FORMAT
  563           %CYCLE I=18,1,64
?Non-local
  564           ->L130 %IF S=NEM(I)
  565           %REPEAT; ->L3
  566  L130:     A(R)=OPC(I); ->L1
  567  BIP(1014):                             ! PHRASE UCRS=R,R,DB FORMAT
  568           %CYCLE I=66,1,69
?Non-local
  569           ->L130 %IF S=NEM(I)
  570           %REPEAT; ->L3
  571  BIP(1015):                             ! PHRASE UCSI=STORE IMDTE
  572           %CYCLE I=71,1,83
?Non-local
  573           ->L130 %IF S=NEM(I)
  574           %REPEAT; ->L3
  575  BIP(1016):                             ! PHRASE UCSHIFT=SHIFT INSTRNS
  576           %CYCLE I=85,1,92
?Non-local
  577           ->L130 %IF S=NEM(I)
  578           %REPEAT; ->L3
  579  BIP(1017):                             ! PHRASE UCSS=STORE TO STORE
  580           %CYCLE I=94,1,106
?Non-local
  581           ->L130 %IF S=NEM(I)
  582           %REPEAT; ->L3
  583  BIP(1018):                             ! PHRASE UCPD=PACKED DECIMAL
  584           %CYCLE I=108,1,116
?Non-local
  585           ->L130 %IF S=NEM(I)
  586           %REPEAT; ->L3
  587  BIP(1019):                             ! PHRASE UCSPEC=THE FUNNIES
  588           %CYCLE I=118,1,120
?Non-local
  589           ->L130 %IF S=NEM(I)
  590           %REPEAT; ->L3
  591                 %END                    ;!OF ROUTINE 'COMPARE'
  592           %INTEGERFN HASH(%INTEGER ADDR)
  593           %RESULT=NNAMES &(19*BYTE INTEGER(ADDR)+31*BYTE INTEGER(ADDR+1))
  594           %END
  595           %ROUTINE PNAME
  596           %INTEGER  JJ,KK,LL
  597           !%SHORTROUTINE
  598           HIT=0; I=CC(Q)
  599           ->L3 %UNLESS 'A'<=I<='Z';     ! 1ST CHAR MUST BE LETTER
  600           ->L3 %IF CC(Q+1)='''' %AND(I='B' %OR I='X' %OR I='M')
  601           S=2; T=1; ->L10
  602  L12:      Q=Q+1; I=CC(Q)
  603           ->L101 %UNLESS 'A'<=I<='Z' %OR '0'<=I<='9'
  604           T=T+1; S=S+1
  605  L10:      LETT(NEXT+T)=I; ->L12
  606  L101:     LETT(NEXT)=T;                 ! INSERT LENGTH
  607           FAULT(108) %IF NEXT+S>DSIZE;  !DICTIONARY OVERFLOW
  608           JJ=HASH(ADDR(LETT(NEXT)));    !PREPARE TO LOOK UP
  609           %CYCLE NUM=JJ,1,JJ+NNAMES
?Non-local
  610           KK=NUM&NNAMES;                ! TREAT DICTIONARY AS CYCLIC
  611           LL=WORD(KK)
  612           ->L2 %IF LL=0;                ! NAME NOT KNOWN
  613           %CYCLE JJ=1,1,LETT(LL)
  614           ->FAIL %UNLESS LETT(NEXT+JJ)=LETT(LL+JJ)
  615           %REPEAT; ->L41;               ! NAME FOUND
  616  FAIL:    %REPEAT
  617           FAULT(104);                   ! TOO MANY NAMES
  618  L2:       WORD(KK)=NEXT; NEXT=NEXT+S
  619  L41:      A(R)=KK; HIT=1
  620  L3:       %END
  621           %ROUTINE     CONST(%BYTEINTEGER MODE)
  622           %COMMENT MODE=0 FOR NORMAL  MODE=2 FOR EXPONENT ETC
  623           %INTEGER Z
  624           %LONGREAL X
  625           CVALUE=0; I=CC(Q)
  626           !%SHORTROUTINE
  627                 S=0; ->N %IF '0'<=I<='9'
  628           ->DOT %IF I='.' %AND MODE=0 %AND '0'<=CC(Q+1)<='9';! 1 DIDT MIN
  629           ->PI %IF I='$' %AND MODE=0;! PI was represented back then by the character which now prints as '$'!
  630           ->L101 %IF I=''''
  631           ->L150 %UNLESS CC(Q+1)=''''; Q=Q+2
  632           ->L102 %IF I='X'; ->MULT %IF I='M'
  633           ->L104 %IF I='B'
  634           Q=Q-2; ->L150
  635  PI:
  636           CVALUE=3.14159 26535 89793 23846; Q=Q+1; ->L40
  637  L101:     S=R; A(R)=5; R=R+1
  638           TEXTTEXT
  639           ->L24 %IF A(S+1)=0;            ! NULL STRING
  640           ->L27 %IF A(S+1)=1;            ! SINGLE CHAR CONSTANT
  641           CTYPE=5; %RETURN
  642  L24:      R=S; S=0; ->L99
  643  L27:      R=S; S=A(S+2); ->L99
  644  L102:     I=CC(Q); Q=Q+1;               ! HEX CONSTANTS
  645           ->L99 %IF I=''''
  646                 ->L5 %IF '0'<=I<='9'
  647           ->L150 %UNLESS 'A'<=I<='F'
  648           S=S<<4!(I-'A'+10); ->L102
  649  L5:       S=S<<4!(I-'0'); ->L102
  650  MULT:          T=0;                    ! MULTIPLE CONSTANTS
  651  L28:            I=CC(Q); Q=Q+1; ->L22 %IF I=''''
  652  L29:      S=S<<8!I; T=T+1; ->L150 %IF T>=5; ->L28
  653  L22:      ->L99 %UNLESS CC(Q)=''''; Q=Q+1; ->L29
  654  L104:     T=Q;                          ! BINARY CONST
  655  L32:            I=CC(Q); Q=Q+1
  656                 ->L31 %IF '1'#I#'0'
  657                 S=S<<1!(I-'0')
  658           ->L150 %IF Q-T>=33; ->L32
  659  L31:      ->L99 %IF I=''''; ->L150
  660  N:       I=I&15; CVALUE=10*CVALUE+I
  661           Q=Q+1; I=CC(Q)
  662           ->N %IF '0'<=I<='9'
  663           ->ALPHA %UNLESS MODE=0 %AND I='.'
  664  DOT:     Q=Q+1; X=10
  665  L45:      I=CC(Q); ->ALPHA %UNLESS '0'<=I<='9'
  666           I=I&15; CVALUE=CVALUE+I/X
  667           X=10*X
  668           Q=Q+1; ->L45
  669  ALPHA:   %COMMENT TEST FOR EXPONENT
  670           ->FIX %UNLESS MODE=0 %AND CC(Q)='@'
  671           Q=Q+1; X=CVALUE
  672           Z=1; ->L39 %IF '+'#CC(Q)#'-'
  673           Z=-1 %IF CC(Q)='-'; Q=Q+1
  674  L39:      CONST(2); ->L150 %IF HIT=0; S=S*Z
  675           %IF S=-99 %THEN CVALUE=0 %ELSE CVALUE=X*10^^S
  676  FIX:     %COMMENT SEE IF IT IS INTEGER
  677           ->L40 %IF CVALUE>IMAX;         ! TOO BIG
  678           ->L41 %IF {FRACPT(CVALUE)=0}INTPT(CVALUE)=CVALUE
  679  L40:      CTYPE=2; HIT=1; %RETURN
  680  L41:      S=INT(CVALUE)
  681  L99:      CTYPE=1; HIT=1; %RETURN
  682  L150:     HIT=0;                        ! FAILURE
  683                 %END
  684           %ROUTINE CONSTLIST
  685           !%SHORTROUTINE
  686           %INTEGER PRECP,NCONST,RF,J,K,CPW
  687           %INTEGER KK,SIGN,SP,RQ,VALUE
  688           %INTEGER TYPEP,ACC,RP,N,JJ
  689           %LONGREAL C
  690           VALUE=0; NCONST=0
  691           %IF CONSTPTR&1#0 %THEN PSYM(0)
  692           A(R+1)=CONSTPTR
  693           RP=R; R=R+2; ACC=0; N=24
  694           TYPEP=TYPEFLAG(A(2)); PRECP=TYPEP>>3
  695           TYPEP=TYPEP&7
  696           %IF TYPEP=5 %THEN ACC=A(4)
  697           PRECP=3 %IF TYPEP=2 %AND ALL LONG=1
  698           CPW=4//BYTES(PRECP)
  699           CPW=4 %IF TYPEP=5
  700  L6:       RQ=Q; I=CC(Q); SIGN=1; ->L7 %IF I='-'
  701           ->L8 %IF I='+'; ->L9
  702  L7:       SIGN=-1; ->L99 %IF CPW=4
  703  L8:       Q=Q+1; I=CC(Q)
  704  L9:       CONST(0); RF=1
  705           ->L98 %IF HIT=0
  706           ->L1 %UNLESS CC(Q)='('
  707           J=S; Q=Q+1; C=CVALUE
  708           CONST(2); ->L98 %UNLESS HIT=1 %AND S>0 %AND CC(Q)=')'
  709           Q=Q+1
  710           CVALUE=C; RF=S; S=J
  711  L1:       ->L21 %IF TYPEP=2
  712           ->L51 %IF TYPEP=5
  713           ->L99 %IF CPW=4 %AND S>255
  714           ->L99 %IF CPW=2 %AND |S|>>16#0;! SHORT TOO LARGE
  715           S=S*SIGN
  716           S=S&X'FFFF' %IF CPW=2
  717            %CYCLE KK=1,1,RF
  718           J=NCONST//CPW
  719           K=NCONST-CPW*J
  720           SP=S<<(32*(CPW-K-1)//CPW)
  721           VALUE=SP!VALUE
  722           NCONST=NCONST+1
  723           ->L5 %UNLESS (CPW-1)&NCONST=0
  724           PSYM(VALUE); VALUE=0
  725  L5:       %REPEAT
  726           L11:   ->L99 %UNLESS CC(Q)=','; Q=Q+1
  727           ->L6 %UNLESS CC(Q)=10
  728           READLINE(0); Q=1; ->L6
  729  L21:      %IF CTYPE=1 %THEN CVALUE=S
  730           CVALUE=SIGN*CVALUE
  731           J=INTEGER(ADDR(CVALUE))
  732           K=INTEGER(ADDR(CVALUE)+4)
  733           %CYCLE KK=1,1,RF; NCONST=NCONST+1
  734           PSYM(J); PSYM(K) %IF PRECP=3
  735           %REPEAT; ->L11
  736  L51:      ->L52 %IF CTYPE=5
  737           ->L98 %UNLESS CTYPE=1 %AND S<=127
  738           A(RP+3)=1; A(RP+4)=S
  739  L52:      ->L98 %UNLESS SIGN=1 %AND ACC>=A(RP+3)
  740           %CYCLE KK=1,1,RF
  741           %CYCLE JJ=0,1,ACC
  742           S=A(RP+JJ+3)&127
  743           SP=S<<N
  744           VALUE=SP!VALUE; N=N-8
  745           ->L55 %UNLESS N<0
  746           PSYM(VALUE); N=24; VALUE=0
  747  L55:      %REPEAT
  748           NCONST=NCONST+1
  749           %REPEAT; R=RP+2; ->L11
  750  L98:      Q=RQ
  751  L99:      R=RP; A(R)=NCONST
  752  PSYM(VALUE) %IF(TYPEP=5%AND N#24)%OR(TYPEP#5 %AND(CPW-1)&NCONST#0)
  753           %END
  754           %ROUTINE TEXTTEXT
  755           !%SHORTROUTINE
  756           %INTEGER S,J
  757           S=R; R=R+1
  758           ->L98 %UNLESS I=''''          ;!FAIL UNLESS  INITIAL QUOTE
  759           Q=Q+1
  760  L1:       I=CC(Q);A(R)=I;R=R+1
  761           ->L31 %IF I=''''
  762           ->L32 %IF I=10
  763           Q=Q+1;FAULT(106) %IF R-S>256
  764           ->L1
  765  L32:      READ LINE(1);Q=1;->L1
  766  L31:      ->L35 %UNLESS CC(Q+1)=''''
  767           Q=Q+2;->L1
  768  L35:      R=R-2;J=R-S;->L36 %UNLESS J&1=0
  769           R=R+1;A(R)=0
  770  L36:      A(S)=J;Q=Q+1;HIT=1;->L99
  771  L98:      HIT=0
  772  L99:      %END
  773           %ROUTINE SET UP LIST
  774           !%SHORTROUTINE
  775           %INTEGER J,K
  776           %CYCLE J=0,8,ASL-16
  777           SET SHORT INTEGER(ADDR(ASLIST(J))+14, J)
  778           %REPEAT
  779           INTEGER(ADDR(ASLIST(0)))=-1;  !   INITIALISE BOTTOM CELL
  780           INTEGER(ADDR(ASLIST(4)))=X'FFFF0000'
  781           ASL=ASL-8
  782           %END
?K unused
  783  %ROUTINE INITIALISE
  784           !%SHORTROUTINE
  785           %OWNBYTEINTEGERARRAY ILETT(1:320)=11,
  786+                'S','E','L','E','C','T','I','N','P','U','T',
  787+                12,'S','E','L','E','C','T','O','U','T','P','U','T',
  788+                7,'N','E','W','L','I','N','E',
  789+                5,'S','P','A','C','E',
  790+                10,'S','K','I','P','S','Y','M','B','O','L',
  791+                6,'R','U','N','O','U','T',
  792+                8,'N','E','W','L','I','N','E','S',
  793+                6,'S','P','A','C','E','S',
  794+                10,'N','E','X','T','S','Y','M','B','O','L',
  795+                11,'P','R','I','N','T','S','Y','M','B','O','L',
  796+                10,'R','E','A','D','S','Y','M','B','O','L',
  797+                4,'R','E','A','D',
  798+                5,'W','R','I','T','E',
  799+                7,'N','E','W','P','A','G','E',
  800+                4,'A','D','D','R',
  801+                6,'A','R','C','S','I','N',
  802+                3,'I','N','T',
  803+                5,'I','N','T','P','T',
  804+                6,'F','R','A','C','P','T',
  805+                5,'P','R','I','N','T',
  806+                7,'P','R','I','N','T','F','L',
  807+                4,'R','E','A','L',
  808+                7,'I','N','T','E','G','E','R',
  809+                3,'M','O','D',
  810+                6,'A','R','C','C','O','S',
  811+                4,'S','Q','R','T',
  812+                3,'L','O','G',
  813+                3,'S','I','N',
  814+                3,'C','O','S',
  815+                3,'T','A','N',
  816+                3,'E','X','P',
  817+                9,'M','A','P','R','E','C','O','R','D' ,
  818+                11,'B','Y','T','E','I','N','T','E','G','E','R',
  819+                12,'S','H','O','R','T','I','N','T','E','G','E','R',
  820+                6,'R','A','D','I','U','S',
  821+                6,'A','R','C','T','A','N',
  822+                6,'P','A','R','I','T','Y',
  823+               11,'P','R','I','N','T','S','T','R','I','N','G',
  824+                2,'N','L',
  825+                8,'L','O','N','G','R','E','A','L',
  826+                7,'P','R','I','N','T','C','H',
  827+                6,'R','E','A','D','C','H',
  828+          6,'S','T','R','I','N','G'
  829           %OWNSHORTINTEGERARRAY IWORD(0:42)=1,
  830+                13,26,34,40,51,58,67,74,85,97,
  831+                108,113,119,127,132,139,143,149,156,162,
  832+                170,175,183,187,194,199,203,207,211,215,
  833+                219,229,241,254,261,268,275,287,290,299,307,
  834+          314
  835           %INTEGER I
  836  
  837           open input(1, "TEST.imp")
  838           select input(1)
  839  
  840           CABUF=0; PPCURR=0; QPREAL=0; OLDLINE=0
  841           LINE=0; RLEVEL=0; NMAX=0; CONSTPTR=0
  842           LEVEL=0; CA=0; AFLAG=0; FFLAG=0; SBFLAG=0
  843           FAULTY=0; PERM=0; MCSWITCH=0; ALL LONG=0
  844           DCOMP=0; COMPILER=0; CPRMODE=0; PRINT MAP=0
  845           NEXT=1; NR=0; LDPTR=0; NEPS=0; EPLINK=0
  846           RBASE=0; STRINST=0
  847           IMAX=(-1)>>1;PLABEL=24999
  848           SSTL=0; STMTS=0; SNUM=0
  849           LABSET=3<<30;LETT(0)=0
  850           N0=41; N=12
  851           CHECKSP=1 ;  CHECKS=1
  852           LINENOS=1; DIAGS1=1; QU=1; MONE=1
  853           LIST=1; SFLABEL=20999; UNASS=1
  854           OWNLINK=0; XREFLINK=136
  855           I=COM(24)
  856           LIST=0 %IF I&2#0
  857           LINENOS=0 %IF I&4#0
  858           UNASS=0 %IF I&16#0
  859           CHECKS=0 %IF I&32#0
  860           PRINTMAP=1 %IF I&X'8000'#0
  861           DIAGS1=0 %IF I&64#0
  862           %CYCLE I=0,1,MAXLEVELS
  863           SET(I)=0; CODEBASE(I)=0; FREG(I)=0; RAL(I)=0
  864           LWSP(I)=0; MDARR(I)=0; RNEXT(I)=0; STRWSP(I)=0
  865           CYCLE(I)=0; JUMP(I)=0; NAME(I)=0
  866           LABEL(I)=0; FLAG(I)=0; SBR(I)=0; WSP(I)=0
  867           %REPEAT
  868           %CYCLE I=0,1,50
  869           ST(I)=0; PAGENOS(I)=0
  870           REGISTER(I)=0 %IF I<16
  871           UVARREG(I)=0 %IF 5<=I<=8
  872           %REPEAT; PAGENOS(1)=10
  873           %CYCLE I=0,1,NNAMES
  874           WORD(I)=0; TAGS(I)=0
  875           %REPEAT
  876           SET UP LIST
  877           PCLOD(0);                     !  ST 12,28(GLA)--L 12,92(GLA)
  878           PCLOD(5);                     !  ST 15,60(11)--BAL 15,RTI
  879           A(1)=28
  880           %CYCLE I=0,1,42
  881           J=IWORD(I)
  882           %CYCLE K=1,1,ILETT(J)
?Non-local
  883           CC(K)=ILETT(J+K);             ! COPY SPECIAL NAMES TO SOURCE
  884           %REPEAT; CC(K+1)=';'
  885           R=2;Q=1; PNAME;               ! SPECIAL NAME TO DICTIONARY
  886           CSS(1); %REPEAT;              ! AND COMPILED
  887           A(1)=12; CSS(1);              ! COMPILE A BEGIN
  888           %END
  889  !
  890           %COMMENT THE NEXT 4 ROUTINES CAN BE MACROISED USING MVC
  891  !
  892           %ROUTINE     TOAR4(%INTEGER PTR,VALUE)
  893           %INTEGER AD; AD=ADDR(VALUE)
  894           A(PTR)<-SHORT INTEGER(AD)
  895           A(PTR+1)<-SHORT INTEGER (AD+2)
  896           %END
  897           %ROUTINE     TOAR8(%INTEGER PTR,%LONGREAL VALUE)
  898           %INTEGER AD; AD=ADDR(VALUE)
  899           A(PTR)<-SHORT INTEGER(AD)
  900           A(PTR+1)<-SHORT INTEGER(AD+2)
  901           A(PTR+2)<-SHORT INTEGER(AD+4)
  902           A(PTR+3)<-SHORT INTEGER(AD+6)
  903           %END
  904           %ROUTINE     FROMAR4(%INTEGER PTR,%INTEGERNAME VALUE)
  905           %INTEGER AD; AD=ADDR(VALUE)
  906           SET SHORT INTEGER(AD, A(PTR))
  907           SET SHORT INTEGER(AD+2, A(PTR+1))
  908           %END
  909           %ROUTINE     FROMAR8(%INTEGER PTR,%LONGREALNAME VALUE)
  910           %INTEGER AD; AD=ADDR(VALUE)
  911           SET SHORT INTEGER(AD,  A(PTR))
  912           SET SHORT INTEGER(AD+2, A(PTR+1))
  913           SET SHORT INTEGER(AD+4, A(PTR+2))
  914           SET SHORT INTEGER(AD+6, A(PTR+3))
  915           %END
  916                 %ROUTINE PRINTNAME (%INTEGER N)
  917           !%SHORTROUTINE
  918           %INTEGER J,V
  919           ->L4 %IF N>=0; N=-N
  920           ->L5 %UNLESS 16384<=N<=16384+NNAMES
  921           N=N-16384; ->L4
  922  L5:       WRITE(N,1); ->L3
  923  L4:       SPACE; V=WORD(N)
  924           %CYCLE J=1,1,LETT(V)
  925           PRINT SYMBOL(LETT(V+J))
  926           %REPEAT
  927  L3:             %END
  928           %ROUTINE     PCLOD(%INTEGER PTR)
  929           %INTEGER I
  930           %CYCLE I=PTR+1,1,PTR+CLODS(PTR)
  931           PLANT(CLODS(I))
  932           %REPEAT
  933           %END
  934           %ROUTINE     PACLOD(%INTEGER PTR,AT,VALUE)
  935           %INTEGER I,J,K
  936           J=CLODS(PTR); AT=AT+PTR
  937           %CYCLE I=PTR+1,1,PTR+J
  938           K=CLODS(I)
  939           K=K!VALUE %IF I=AT
  940           PLANT(K);%REPEAT
  941           %END
  942           %ROUTINE     PLANT(%INTEGER VALUE)
  943           !%SHORTROUTINE
  944           CODE(PPCURR)<-VALUE
  945     PPCURR=PPCURR+1; CA=CA+2
  946           %RETURN %UNLESS PPCURR=192
  947           LPUT(1,384,CABUF,ADDR(CODE(0)))
  948           PPCURR=0; CABUF=CA
  949           %END
  950           %ROUTINE     PRR (%INTEGER OPCODE,R1,R2)
  951           PLANT(OPCODE<<8!R1<<4!R2)
  952           %END
  953           %ROUTINE     PRX(%INTEGER OPCODE,R1,R2,BASE,DISP)
  954           PLANT(OPCODE<<8!R1<<4!R2)
  955           PLANT(BASE<<12!DISP)
  956           %END
  957           %ROUTINE     PSI(%INTEGER OPCODE,J,BASE,DISP)
  958           PLANT(OPCODE<<8!J)
  959           PLANT(BASE<<12!DISP)
  960           %END
  961           %ROUTINE     PSS(%INTEGER OPCODE,N,BASE,DISP,P,Q)
  962           PLANT(OPCODE<<8!(N-1))
  963           PLANT(BASE<<12!DISP)
  964           PLANT(P<<12!Q)
  965           %END
  966           %ROUTINE     PCONST(%INTEGER X)
  967           PLANT(X>>16); PLANT(X&X'FFFF')
  968           %END
  969           %ROUTINE     CNOP(%INTEGER I,J)
  970           J=J-1
  971  L1:       ->L9 %IF CA&J=I; PLANT(X'0700'); ->L1
  972  L9:       %END
  973           %ROUTINE     PSYM(%INTEGER X)
  974           LPUT(5,4,CONSTPTR<<2,ADDR(X))
  975           CONSTPTR=CONSTPTR+1
  976           %END
  977           %ROUTINE     PLUG(%INTEGER J,K)
  978           !%SHORTROUTINE
  979           ->INBUF %IF J>=CABUF
  980           LPUT(1,2,J,ADDR(K)+2)    ; ->L99
  981  INBUF:   CODE((J-CABUF)>>1)<-K
  982  L99:      %END
  983           %ROUTINE     PRHEX(%INTEGER VALUE,PLACES)
  984           %OWNBYTEINTEGERARRAY HEX(0:15)='0','1','2','3','4',
  985+                '5','6','7','8','9','A','B','C','D','E','F';
  986           %INTEGER I
  987           %CYCLE I=PLACES<<2-4,-4,0
  988           PRINT SYMBOL(HEX(VALUE>>I&15))
  989           %REPEAT
  990           %END
  991           %ROUTINE SIZES
  992           !%SHORTROUTINE
  993           %ROUTINESPEC SUM(%INTEGER I)
  994           %INTEGER I,J,FREE,TOTAL
  995  
  996           free=20000
  997           sum(5)
  998           %if debug=1 %start
  999           print string("NNAMES="); write(NNAMES,0);
 1000           print string("  CCSIZE="); write(CCSIZE,0);
 1001           print string("  NROUTS="); write(NROUTS,0);
 1002           print string("  ASL="); write(ASL,0);
 1003           print string("  ARSIZE="); write(ARSIZE,0);
 1004           print string("  DSIZE="); write(DSIZE,0);
 1005           print string("  TOTAL="); write(TOTAL,0);
 1006           newlines(2)
 1007           %finish
 1008           
 1009           !!I=COM(2)
 1010           !!FREE=INTEGER(I+4);            !TOP OF STORE
 1011           !!FREE=FREE-ADDR(TOTAL)-10000
 1012           ! TOTAL IS CURRENT TOP OF STACK - 10K FOR COMPARE
 1013           !!%CYCLE J=0,1,5; SUM(J)
 1014           !!->L1 %IF TOTAL>FREE
 1015           !!%REPEAT
 1016           %RETURN
 1017  L1:       ->L2 %UNLESS J=0
 1018           print string("NOT ENOUGH CORE ALLOCATED FOR IMP")
 1019           %MONITOR ; %STOP
 1020  L2:       SUM(J-1)
 1021           %RETURN
 1022           %ROUTINE     SUM(%INTEGER I)
 1023           NNAMES=128*2^^I-1
 1024           CCSIZE=200+40*I
 1025           NROUTS=NNAMES//2
 1026           ASL   =24*NNAMES
 1027           ASL=32760 %IF ASL>32760;      ! MAX FOR 16BIT LINKS
 1028           ARSIZE=300+50*I
 1029           DSIZE= 6*NNAMES
 1030           TOTAL=CCSIZE+ASL+2*(NROUTS+ARSIZE+DSIZE)
 1031           %END
 1032           %END
?L1 unused
?I unused
 1033  !
 1034           %ROUTINE CSS (%INTEGER P)
 1035         %ROUTINESPEC REDEFINE EP(%INTEGER TYPEP,%INTEGERARRAYNAME PARAMS)
 1036           %ROUTINESPEC CIOCP(%INTEGER N)
 1037           %ROUTINESPEC DEFINE EP(%INTEGER MODE, NAME, ADDR)
 1038           %ROUTINESPEC LOAD DATA
 1039           %ROUTINESPEC P LOCAL JUMP(%INTEGER MASK,LAB)
 1040           %ROUTINESPEC FILL LOCAL JUMPS
 1041           %ROUTINESPEC CLEAR LIST (%SHORTINTEGERNAME OPHEAD)     ; ! Care needed with short conversion!
 1042           %ROUTINESPEC STORE STRING(%INTEGER Z,FROM,TO,BML,DML)
 1043           %ROUTINESPEC CEND(%INTEGER KKK)
 1044           %ROUTINESPEC CBPAIR(%INTEGERNAME LB,UB)
 1045           %ROUTINESPEC UNDCRF (%SHORTINTEGERNAME OPHEAD)     ; ! Care needed with short conversion!
 1046            %ROUTINESPEC CCOND(%INTEGER IU,REG,ADDR)
 1047           %ROUTINESPEC FILL JUMPS(%INTEGER LEVEL)
 1048                 %ROUTINESPEC SET LINE
 1049           %ROUTINESPEC CUI(%BYTEINTEGER CODE)
 1050           %ROUTINESPEC SET80(%INTEGER WHERE,N)
 1051           %ROUTINESPEC CVDECLN
 1052           %ROUTINESPEC CSEXP(%INTEGER REG,%BYTEINTEGER MODE)
 1053           %ROUTINESPEC CSTREXP(%INTEGER REG)
 1054                 %ROUTINESPEC CHECK RF
 1055           %ROUTINESPEC ASSIGN (%INTEGER P1,P2)
 1056           %INTEGERFNSPEC COPY RECORD TAG
 1057           %INTEGERFNSPEC COUNT APS
 1058           %INTEGERFNSPEC DISPLACEMENT(%INTEGER LINK)
 1059           %ROUTINESPEC LOADAD(%INTEGER REG,BASE,X,DISP)
 1060                  %ROUTINESPEC SKIP APP
 1061           %ROUTINESPEC CQUERY(%INTEGER REG)
 1062           %ROUTINESPEC CRFORMAT
 1063           %ROUTINESPEC CADCLN(%BYTEINTEGER MODE)
 1064           %ROUTINESPEC CQN(%INTEGER P)
 1065           %ROUTINESPEC CLT
 1066                 %ROUTINESPEC MOVE R(%INTEGER R,N)
 1067           %INTEGERFNSPEC GET ARR WSP
 1068           %INTEGERFNSPEC GET DBLE WRD
 1069           %ROUTINESPEC CRCALL (%INTEGER CLINK)
 1070           %ROUTINESPEC CNAME(%INTEGER Z,REG)
 1071           %ROUTINESPEC CRNAME(%INTEGER Z,MODE,CLINK,BS,DP)
 1072           %ROUTINESPEC CANAME(%INTEGER Z,BS,DP,LINK,BSRF,DPRF)
 1073           %ROUTINESPEC CENAME(%INTEGER Z,MODE,BS,DP)
 1074           %ROUTINESPEC INSERTAFTER(%SHORTINTEGERNAME STAD,%INTEGER S1,S2)     ; ! Care needed with short conversion!
 1075           %ROUTINESPEC FROM LIST(%INTEGER CELL,%INTEGERNAME S1,S2)
 1076           %ROUTINESPEC POP(%SHORTINTEGERNAME CELL,%INTEGERNAME S1,S2)     ; ! Care needed with short conversion!
 1077           %ROUTINESPEC PUSH(%SHORTINTEGERNAME CELL,%INTEGER S1,S2)     ; ! Care needed with short conversion!
 1078           %INTEGERFNSPEC FIND(%INTEGER LAB,LIST)
 1079           %ROUTINESPEC MLINK(%INTEGERNAME CELL)
 1080           %ROUTINESPEC REPLACE2(%INTEGER CELL,S2)
 1081           %ROUTINESPEC REPLACE1(%INTEGER CELL,S1)
 1082           %ROUTINESPEC REPLACE BOTH(%INTEGER CELL,S1,S2)
 1083           %ROUTINESPEC FROM2(%INTEGER CELL,%INTEGERNAME S2)
 1084           %ROUTINESPEC FROM1(%INTEGER CELL,%INTEGERNAME S1)
 1085           %ROUTINESPEC CRES(%INTEGER MODE,LAB)
 1086                 %INTEGERFNSPEC NEWCELL
 1087                 %ROUTINESPEC COPY TAG (%INTEGER KK)
 1088           %ROUTINESPEC CSNAME(%INTEGER Z,REG)
 1089                 %ROUTINESPEC REPLACE TAG (%INTEGER KK)
 1090                 %INTEGERFNSPEC PARK(%INTEGER REG)
 1091           %INTEGERFN %SPEC PARKF (%INTEGER REG,PREC)
 1092           %INTEGERFNSPEC  CLAIMABLE REG
 1093                 %INTEGERFNSPEC       FIND PP
 1094           %INTEGERFNSPEC GET STR WSP
 1095           %ROUTINESPEC SETEX
 1096           %ROUTINESPEC GXREF(%INTEGER NAME,HASH)
 1097           %ROUTINESPEC UNPARK(%INTEGER OPCODE,REG,Q)
 1098           %ROUTINESPEC STORE TAG(%INTEGER KK,SLINK)
 1099           %INTEGERFNSPEC PAGENO(%INTEGER N)
 1100                 %ROUTINESPEC TESTNST
 1101                 %ROUTINESPEC CUCI
 1102                 %ROUTINESPEC SKIP EXP
 1103                 %ROUTINESPEC UNPACK
 1104           %INTEGERFNSPEC SORT CONST(%INTEGER P,LONG,TYPE)
 1105           %ROUTINESPEC PACK(%INTEGERNAME PTYPE)
 1106           %ROUTINESPEC CRSPEC (%BYTEINTEGER M)
 1107           %ROUTINESPEC DUMP(%INTEGER CODE,REG,DIS,X,LEVEL)
 1108           %ROUTINESPEC RHEAD(%INTEGER KK)
 1109           %ROUTINESPEC TEST ASS(%INTEGER REG)
 1110                 %ROUTINESPEC PJ(%INTEGER MASK,STAD)
 1111           %ROUTINESPEC COMPILE FORMAL PARAMETER
 1112           %ROUTINESPEC PPJ(%BYTEINTEGER N)
 1113                 %ROUTINESPEC PLAB(%INTEGER M)
 1114           %ROUTINESPEC CHECK CAPACITY(%INTEGER REG,DIS,X,LEVEL)
 1115                 %INTEGERFNSPEC TSEXP(%INTEGERNAME CODE)
 1116           %SWITCH SW(1:45)
 1117           %INTEGER INC,INCP,BXLE,ACC
 1118           %SHORTINTEGER OPHEAD
 1119           %INTEGER JJ,JJJ,KK,KKK,Q,QQ,EXTRN
 1120           %INTEGER BASE,DISP,VALUE,INDEX
 1121           %INTEGER LOCAL BASE, LOCAL ADDR
 1122           %SHORTINTEGER LOCAL JUMP,LOCAL LABEL
 1123           %BYTEINTEGER ROUT,NAM,ARR,PREC,TYPE,PRECP
 1124           %INTEGER PTYPE,I,J,K,OLDI,INREG
 1125           %INTEGER PTYPEP,SAVE13,CHNGE13
 1126           LOCAL JUMP=0;LOCAL LABEL=0
 1127           LOCAL BASE=0
 1128           OLDI=0; ->SW(A(P))
 1129  SW(1):   MARKER2=P+1+A(P+1); SET LINE
 1130           P=P+2; ->L101 %IF A(MARKER2)=2
 1131           MASK=15; CUI(0); ->L1
 1132  L101:     Q=P
 1133           FAULT(54) %IF A(P)=9;         ! START
 1134           SAVE13=R13; CHNGE13=0
 1135           ->L103 %IF A(P)=3;   ! UI =JUMP
 1136           PLABEL=PLABEL-2; JJJ=PLABEL+1
 1137           KKK=PLABEL; P=MARKER2+2
 1138           CCOND(A(P-1)-1,JJJ,KKK)
 1139           PLOCAL JUMP(MASK,KKK)
 1140           R13=0 %UNLESS R13=SAVE13 %AND CHNGE13=0
 1141           PUSH(LOCAL LABEL,CA,JJJ)
 1142           P=Q; CUI(1)
 1143  L104:     PUSH(LOCAL LABEL,CA,KKK)
 1144           R13=0 %UNLESS R13=SAVE13 %AND CHNGE13=0
 1145  L102:     REGISTER(LOCAL BASE)=0 %UNLESS LOCAL BASE=10 %OR LOCALBASE=0
 1146           FILL LOCAL JUMPS; ->L1
 1147  L103:     PLABEL=PLABEL-1; JJJ=PLABEL
 1148           NMDECS(LEVEL)=1
 1149           KKK=A(P+2)+(A(P+1)-1)<<14
 1150           P=MARKER2+2; CCOND(2-A(P-1),JJJ,KKK)
 1151           PLOCAL JUMP(MASK,KKK)
 1152           R13=0 %UNLESS R13=SAVE13 %AND CHNGE13=0
 1153           PUSH(LOCAL LABEL,CA,JJJ); ->L102
 1154  !
 1155  SW(2):   SET LINE;P=P+1; BXLE=0; CNAME(3,4)
 1156           INC=N; N=N+12
 1157                 FAULT(25) %UNLESS TYPE=1 %AND PREC=0
 1158           Q=P; SKIP EXP; REGISTER(4)=1
 1159           JJ=P; BXLE=1 %IF 3900>CA-CODEBASE(LEVEL)%AND 1<=TSEXP(JJJ)<=2
 1160           P=JJ; CSEXP(2,1);             ! INTEGER TO REG2
 1161           JJJ=P; KKK=TSEXP(QQ); P=JJJ
 1162           DUMP(1,2,INC,0,RBASE) %IF KKK=0
 1163           CSEXP(3,1)
 1164           %IF KKK=0 %THEN PRX(X'90',3,4,RBASE,INC+4) %ELSE %C
 1165+ PRX(X'90',2,4,RBASE,INC)
 1166           P=Q; CSEXP(1,1)
 1167           ->L202 %IF CHECKSP=0
 1168           DUMP(0,2,INC,0,RBASE); PPJ(17)
 1169  L202:     PLAB(-1); REGISTER(4)=0
 1170           DUMP(1,1,0,0,4)
 1171           PUSH(CYCLE(LEVEL),K,INC+4096*BXLE)
 1172           ->L1
 1173  !
 1174   SW(3):        !REPEAT
 1175           SET LINE
 1176                 POP(CYCLE(LEVEL),J,K)
 1177           ->L302 %UNLESS J=-1
 1178           FAULT(1); ->L1
 1179  L302:     BXLE=K>>12; K=K&4095
 1180           PRX(X'98',2,4,RBASE,K);       ! LM 2,4,?
 1181           DUMP(2,1,0,0,4); ->L301 %IF BXLE=1
 1182           PLANT(X'1A12');               ! AR 1,2
 1183           PCONST(X'59304000');          !  C 3,0(4)
 1184           K=J; PJ(7,K); ->L1
 1185  L301:     I=FIND(J,LABEL(LEVEL))
 1186           PRX(X'87',1,2,10,I-CODEBASE(LEVEL)); ->L1;! BXLE 1,2,ADDR
 1187  SW(4):                                 ! (LABEL)':'
 1188           K=A(P+2)+(A(P+1)-1)<<14
 1189          ->L402 %IF FIND(K,LABEL(LEVEL))=-1
 1190           FAULT(2); ->L1
 1191  L402:     PLAB(K); ->L1
 1192  SW(5):   Q=P+1; MARKER2=P+3+A (P+2);
 1193           SET LINE; P=MARKER2
 1194           SAVE13=R13; CHNGE13=0
 1195           ->L510 %IF A(P)=3;   ! UI=JUMP
 1196           ->L520 %IF A(P)=9;   ! UI =START
 1197           PLABEL=PLABEL-2; JJJ=PLABEL+1; KKK=PLABEL
 1198           P=Q+2; CCOND(A(Q)-1,JJJ,KKK)
 1199           P LOCAL JUMP(MASK,KKK)
 1200           R13=0 %UNLESS R13=SAVE13 %AND CHNGE13=0
 1201           PUSH(LOCAL LABEL,CA,JJJ)
 1202           P=MARKER2; CUI(1)
 1203           ->L104 %UNLESS A(P)=1;         ! %ELSE FOLLOWS
 1204           P=P+1; ->L107 %IF A(P)=9;      ! UI=START
 1205           PLABEL=PLABEL-1; JJJ=PLABEL
 1206           P LOCAL JUMP(15,JJJ)
 1207           PUSH(LOCAL LABEL,CA,KKK)
 1208           R13=0 %UNLESS R13=SAVE13 %AND CHNGE13=0
 1209           MASK=15; CUI(2); KKK=JJJ; ->L104
 1210  L107:     PJ(15,SFLABEL-1)
 1211           CUI(2); ->L104
 1212  L510:     PLABEL=PLABEL-1; JJJ=PLABEL
 1213           NMDECS(LEVEL)=1
 1214           KKK=A(P+2)+(A(P+1)-1)<<14
 1215           P=Q+2; CCOND(2-A(Q),JJJ,KKK)
 1216           PLOCAL JUMP(MASK,KKK)
 1217           R13=0 %UNLESS R13=SAVE13 %AND CHNGE13=0
 1218           PUSH(LOCAL LABEL,CA,JJJ)
 1219           P=MARKER2+3; ->L102 %UNLESS A(P)=1
 1220           P=P+1; MASK=15; CUI(0); ->L102
 1221  L520:     PLABEL=PLABEL-1; JJJ=PLABEL
 1222          KKK=SFLABEL-1
 1223           P=Q+2; CCOND(A(Q)-1,JJJ,KKK)
 1224           P LOCAL JUMP(MASK,KKK)
 1225           R13=0 %UNLESS R13=SAVE13 %AND CHNGE13=0
 1226           PUSH(LOCAL LABEL,CA,JJJ)
 1227           P=MARKER2; CUI(1); P=P+1
 1228           FAULT(53) %IF A(P)=1; ->L102
 1229  SW(6):L1:                               ! %COMMENT
 1230           %RETURN
 1231  SW(7):                                 ! SIMPLE DECLN
 1232           FAULT(57) %UNLESS LEVEL>=2
 1233           FAULT(40) %IF NMDECS(LEVEL)#0
 1234           P=P+1;CLT;ROUT=0
 1235           FAULT(70) %IF TYPE=5 %AND ACC=0
 1236           ->SCALAR %IF A(P)=1
 1237           ->VECTOR %IF A(P)=3
 1238           ARR=1; NAM=(2-A(P+1))<<1;     ! NAME ARRAY BIT
 1239           PACK(PTYPE); P=P+2; SET LINE
 1240           ACC=4 %IF NAM#0;CADCLN(0);->L1
 1241  VECTOR:  ARR=2; NAM=0; PACK(PTYPE)
 1242           P=P+1; SET LINE; CVDECLN; ->L1
 1243  SCALAR:  J=0;ROUT=0;CQN(P+1);P=P+2
 1244           INC=N
 1245           QQ=ACC;ACC=4 %IF TYPE=5;JJ=0
 1246           ->L701 %UNLESS ACC=8 %AND N&7#0
 1247           PUSH(WSP(LEVEL),0,N);N=N+4    ;!DOUBLE WORD BOUNDARY
 1248  L701:     SET LINE %IF TYPE=5
 1249           PACK(PTYPE)
 1250           %CYCLE KK=1,1,A(P)
 1251           K=A(P+KK);TESTNST
 1252           STORE TAG(K,N)
 1253           ->L705 %UNLESS TYPE=5
 1254           JJ=JJ+QQ
 1255           PSS(X'D2',2,WSPR,0,GLA,128) %IF UNASS=1
 1256           PRX(X'50',WSPR,RBASE,0,N)     ;!STORE POINTER
 1257           PSI(X'92',QQ-1,RBASE,N)       ;!STORE MAX LENGTH
 1258           %IF KK=A(P) %THEN QQ=QQ+(JJ+7)&(-8)-JJ
 1259           PRX(X'41',WSPR,WSPR,0,QQ)     ;!ADVANCE WORK SPACE
 1260  L705:     N=N+ACC;%REPEAT
 1261           N=N+3; N=N&(-4)
 1262           SET80(INC,N-INC) %IF UNASS=1 %AND TYPE#5
 1263           ->L1
 1264  SW(8):                                 ! %END
 1265           CEND(FLAG(LEVEL))
 1266                ->L1
 1267  SW(9):   P=P+1; MARKER1=A(P)+P;    !(SEX)(RT)(SPEC')(NAME)(FPP)
 1268  L900:     Q=P; KKK=A(MARKER1+1);        !KKK ON NAME
 1269           EXTRN=A(P+1)
 1270           ->L902 %IF A(MARKER1)=2
 1271           P=P+1; CRSPEC(0); ->L1 %IF EXTRN=3
 1272           N0=N0-1; KK='S'*(2-EXTRN)
 1273           GXREF(KKK,KK); JJ=TAGS(KKK)
 1274           FROM1(JJ,Q)
 1275           REPLACE1(JJ,Q&(-2)); ->L1
 1276  L902:     FILL JUMPS(LEVEL)
 1277           KK=KKK
 1278           COPY TAG(KKK); ->L939 %IF OLDI#LEVEL
 1279           %UNLESS EXTRN=3 %THEN %START
 1280           CPRMODE=2 %IF CPRMODE=0
 1281                 FAULT(55) %UNLESS CPRMODE=2 %AND LEVEL=1
 1282           DEFINE EP(EXTRN,KKK,CA)
 1283                 PCLOD(0);               !  ST 12,28(GLA)--L 12,=A(PERM)
 1284           %FINISH
 1285           ->L908 %IF A(P+2)=1; ROUT=1
 1286           P=P+3
 1287           CLT;ARR=0;NAM=(A(P)-1)<<1;    ! SET NAME ARRAY BIT FOR MAPS
 1288           PACK(KKK); ->L909
 1289  L908:     KKK=10000
 1290  L909:     ->L940 %IF J=15 %AND PTYPE=KKK
 1291           FNAME=KK; FAULT(7) %UNLESS PTYPE&7=7
 1292  L939:     P=Q+1; CRSPEC(0); P=Q; ->L900
 1293  L940:     J=0; REPLACETAG(KK); JJ=K;   ! CHANGE TAG TO ROUT SPECIFIED AND DESCRIBED
 1294           PLABEL=PLABEL-1
 1295           PJ(15,PLABEL) %UNLESS COMPILER=1 %OR(CPRMODE=2 %AND LEVEL=1)
 1296           RAL(LEVEL)=NMAX<<16!SBFLAG<<15!N
 1297           RHEAD(KK)
 1298           PPJ(40) %UNLESS EXTRN=3;      ! TO RELOCATE OWNS
 1299           FLAG(LEVEL)=PTYPE
 1300           P=MARKER1+1
 1301           ->L942 %IF A(P+1)=2
 1302  L943:     P=P+2; COMPILE FORMAL PARAMETER
 1303           %CYCLE BXLE=1,1,A(P)
 1304           MLINK(JJ); ->L945 %UNLESS JJ=0
 1305           FAULT(8); ->L946
 1306  L945:     FROM LIST(JJ,J,JJJ)
 1307           ->L946 %IF J=PTYPE %AND(PTYPE#5 %OR JJJ=ACC)
 1308           FAULT(9); PRINT NAME(A(P+BXLE))
 1309  L946:     K=A(P+BXLE); TESTNST
 1310           OPHEAD=0; UNPACK
 1311           ->L947 %IF ROUT=1;             ! RT TYPES
 1312           ->L9040 %IF PTYPE=5; J=JJJ
 1313           ->L948 %IF TYPE=3;             !RECORDS
 1314           R=N; ->L950 %IF ARR=1
 1315           ->L949 %IF PREC=3 %AND NAM=0;  ! LONG
 1316           N=N+4-ACC; R=N
 1317  L950:     STORE TAG(K,N)
 1318           N=R+ACC; ->L999
 1319  L947:     PUSH(OPHEAD,N,1000);          !SET DUMMY SIDECHAIN FOR RT TYPES
 1320           J=13
 1321  L951:     KK=OPHEAD
 1322           R=N; N=KK; ->L950
 1323  L9040:    PRX(X'41',1,0,RBASE,N+4);     ! STRING VALUE SET PTR
 1324           PRX(X'50',1,0,RBASE,N)
 1325           PSI(X'92',JJJ-1,RBASE,N)
 1326           STORE TAG(K,N)
 1327           N=N+(ACC+7)&(-4); ->L999
 1328  L948:     PUSH(OPHEAD,0,N); J=0; ->L951; ! DUMMY SIDECHAIN FOR RECORD
 1329  L949:     R=N; ->L950 %IF N&7=0
 1330           PUSH(WSP(LEVEL),0,N)
 1331           N=N+4; R=N; ->L950;            !ALLIGN ON D W BOUNDARY
 1332  L999:     %REPEAT
 1333           P=P+1+BXLE; ->L943 %IF A(P)=1
 1334  L942:     MLINK(JJ); FAULT(10) %UNLESS JJ=0; ->L1202
 1335  !
 1336   SW(10):       ! COMMENT
 1337                 ->L1
 1338  !
 1339  SW(11):                                !REALS(LN)
 1340           ALL LONG=A(P+1)&1;->L1
 1341  SW(12):                                !%BEGIN
 1342           FILL JUMPS(LEVEL)
 1343           RAL(LEVEL)=SBFLAG<<15!N
 1344           PTYPE=0; RHEAD(-1)
 1345           FLAG(LEVEL)=0
 1346           ->L1 %IF LEVEL=1=RLEVEL
 1347           ->L1202 %UNLESS LEVEL=2
 1348           CPRMODE=1 %IF CPRMODE=0
 1349           DEFINE EP(0,0,0)
 1350           FAULT(55) %UNLESS CPRMODE=1
 1351  L1202:    PLANT(X'05A0'); CODEBASE(LEVEL)=CA; ->L1
 1352  SW(13):                                ! %ENDOFPROGRAM
 1353           FAULT(15) %UNLESS LEVEL=2
 1354           FAULT(56) %UNLESS CPRMODE=1
 1355           PERM=0; CEND(1)
 1356           LOAD DATA; ->L1
 1357  SW(14):  %BEGIN;                       !SWITCH LABEL
 1358           !%SHORTROUTINE
 1359           R13=0;MONE=1
 1360           COPYTAG(A(P+1))
 1361           ->L1401 %IF OLDI=LEVEL %AND TYPE=6
 1362           FAULT(4); ->L1
 1363  L1401:    FROM LIST(K,ACC,KKK)
 1364           MLINK(K); FROM LIST(K,QQ,KK); ! UB & BIT LIST PART 1
 1365           ->L1411 %UNLESS A(P+3)&7=1
 1366           %IF A(P+3)=9 %THEN JJ=A(P+4) %ELSE %START
 1367           FROMAR4(P+4,JJ); P=P+1; %FINISH
 1368           JJ=-JJ %IF A(P+2)=2
 1369           ->L1402 %IF KKK<=JJ<=KK
 1370  L1411:    FAULT(5); ->L1
 1371  L1402:    Q=JJ-KKK
 1372  L1404:    ->L1403 %IF 31>=Q
 1373           MLINK(K); Q=Q-32
 1374           FROM LIST(K,QQ,JJJ); ->L1404
 1375  L1403:    JJJ=1<<Q; FAULT(6) %UNLESS JJJ&QQ=0
 1376           REPLACE1(K,QQ!JJJ);           ! UPDATE BIT LIST
 1377           Q=CA-CODEBASE(LEVEL)
 1378           ->L1407 %IF PREC#0
 1379           QQ=ACC+8+(JJ-KKK)<<2;         ! WHERE TO PLUG
 1380           PLUG(QQ,Q>>16) %UNLESS Q>>16=0
 1381  L1406:    PLUG(QQ+2,Q&X'FFFF'); ->L1
 1382  L1407:    QQ=ACC+6+(JJ-KKK)<<1
 1383           FAULT(99) %IF Q>X'7FFF';->L1406
 1384  !
 1385  L1:       %END;->L1
 1386  SW(15):  %BEGIN;                       !SWITCH (SWITCH LIST)
 1387           !%SHORTROUTINE
 1388           %INTEGER BP,QQQ
 1389           Q=P;CNOP(0,4);PJ(15,PLABEL-1)
 1390           FAULT(56) %UNLESS LEVEL>=2
 1391  L1528:    P=Q+A(Q+1)+2
 1392           CBPAIR(KKK,KK);               ! LB TO KKK, UB TO KK
 1393           ->L1501 %UNLESS |KKK|<X'7FFF'>|KK|
 1394           ->L1535 %IF KKK<=KK; FAULT(27); KK=KKK
 1395  L1535:    %CYCLE QQ=1,1,A(Q+1)
?Non-local
 1396           K=A(Q+QQ+1);TEST NST
 1397           PREC=0
 1398           PREC=2 %IF SBFLAG=1 %OR COMPILER=1
 1399           TYPE=6; ROUT=0; NAM=0; ARR=1; PACK(PTYPE)
 1400           OPHEAD=NEWCELL; JJ=OPHEAD
 1401           J=0;STORE TAG(K,OPHEAD);R=KKK
 1402           INSERT AFTER (OPHEAD,0,KK)
 1403  L1503:    ->L1504 %IF KK-R<32
 1404           INSERT AFTER(OPHEAD,0,0)
 1405           R=R+32; ->L1503;               ! SET UP BIT LIST
 1406  L1504:    REPLACE BOTH(JJ,CA,KKK)
 1407           PCONST(KKK&X'FFFFFF'!PREC<<24)
 1408           PCONST(KK)
 1409           JJJ=KK-KKK
 1410           JJJ=(JJJ+1)//2 %IF PREC=2
 1411           %CYCLE I=0,1,JJJ
?Non-local
 1412           PCONST(0);%REPEAT
 1413           %REPEAT
 1414           Q=P; ->L1528 %UNLESS A(Q)=2
 1415           PLAB(-1); ->L1
 1416  L1501:    FAULT(18); KK=0; KKK=0; ->L1535
 1417  L1:       %END;
?QQQ unused
?BP unused
 1418                 ;->L1
 1418  SW(16):  QU=\A(P+1)&1; P=P+2; ->L1
 1419  !
 1420  SW(17):                                ! '%REGISTER' (NAME)
 1421           KK=CLAIMABLE REG
 1422           ->L1999 %IF KK=0
 1423           REGISTER(KK)=-LEVEL
 1424           UVARREG(KK)=LEVEL
 1425           PTYPE=8; J=0
 1426           K=A(P+1); TESTNST
 1427           STORE TAG(K,KK); ->L1
 1428  SW(18):                                ! '%OWN' (TYPE)(OWNDEC)
 1429           %BEGIN
 1430           !%SHORTROUTINE
 1431           %INTEGER WSP1,LENGTH,BP,PP,SIGN
 1432           %INTEGERNAME VAR
 1433           FAULT(40) %UNLESS NMDECS(LEVEL)=0
 1434           P=P+1; CLT
 1435           FAULT(70) %IF TYPE=5 %AND ACC=0
 1436           NAM=0; ROUT=0; ARR=A(P)-1; PACK(PTYPE)
 1437           PP=P+1; P=P+2; ->NONSCALAR %UNLESS ARR=0
 1438           ->L1801 %UNLESS A(P)=2;        ! NO CONST
 1439           A(P+1)=4; A(P+2)=9; A(P+3)=0; ! 0== NULL STRING ALSO
 1440  L1801:    SIGN=A(P+1); ->L1820 %IF TYPE=5;! STRING
 1441           JJ= SORT CONST(P+2,PREC&1,TYPE)
 1442           ->L1810 %IF TYPE=2
 1443           VAR==ST(N0-1)
 1444           FAULT(44)%IF(PREC=1 %AND VAR>255)%OR(PREC=2 %AND |VAR|>>16#0)
 1445           FAULT(44) %IF A(P+2)&7=2;     ! REAL CONST FOR INTEGER VARIABLE
 1446           %IF SIGN=2 %THEN VAR=-VAR
 1447           %IF SIGN=3 %THEN VAR=\VAR
 1448  L1803:    K=A(PP); TESTNST
 1449           JJ=JJ+4-BYTES(PREC) %UNLESS PREC=3
 1450           PUSH(TAGS(K),PTYPE<<16!LEVEL<<8!GLA<<4,JJ)
 1451           PUSH(NAME(LEVEL),0,K); ->L99
 1452  L1810:    FAULT(44) %IF SIGN=3;         ! \ WITH REAL
 1453           ->L1803 %UNLESS SIGN=2
 1454           ST(JJ>>2)=ST(JJ>>2)!X'80000000';! OR IN SIGN BIT
 1455           ->L1803
 1456  L1820:                                  ! STRINGS
 1457           ->L1822 %UNLESS A(P+2)=9 %AND A(P+3)<127
 1458           A(P+2)=5; A(P+4)=A(P+3); A(P+3)=1
 1459  L1822:    FAULT(44) %UNLESS SIGN=4 %AND A(P+2)=5 %AND A(P+3)<ACC
 1460           QQ=CONSTPTR<<2
 1461           %CYCLE JJ=0,4,(ACC-1)&(-4)
?Non-local
 1462           WSP1=A(P+JJ+3)<<8!A(P+JJ+4)&255;! COLLECT THE SYMBOLS FROM
 1463           WSP1=WSP1<<8!A(P+JJ+5)&255;   ! A.R AND ASSEMBLE INTO FOURS
 1464           WSP1=WSP1<<8!A(P+JJ+6)&255
 1465           PSYM(WSP1);                   ! THEN ADD TO SYMBOL TABLES
 1466           %REPEAT
 1467                 PRX(X'58',2,0,GLA,8);   ! BASE OF ST TO REG2
 1468                 LOADAD(1,2,GLA,QQ);     ! ABSOLUTE ADDR OF STING
 1469                 PRX(X'50',1,0,RBASE,N); ! STUFF IT OFF
 1470                 PSI(X'92',ACC-1,RBASE,N);                               !
 1471           K=A(PP); TESTNST
 1472           J=0;STORE TAG(K,N)
 1473           N=N+4; ->L99
 1474  NONSCALAR:CBPAIR(KK,KKK)
 1475           %IF TYPE=5 %THEN BP=ACC %ELSE BP=BYTES(PREC)
 1476           LENGTH=KKK-KK+1
 1477           %IF A(P+1)=0 %THEN ->L3;       ! NO CONSTLIST
 1478  L1:       FAULT(45) %UNLESS KKK>=KK %AND LENGTH=A(P+1)
 1479           QQ=CONSTPTR<<2
 1480           JJ=A(P+2)<<2
 1481           %COMMENT OUTPUT AN ARRAYHEAD RELATIVE TO QQ
 1482           ST(N0)=JJ-KK*BP
 1483           ST(N0+1)=JJ
 1484           ST(N0+2)=QQ
 1485           ST(N0+3)=OWNLINK
 1486           %COMMENT NOW OUTPUT DOPE VECTOR
 1487           PSYM(1<<16!BP)
 1488           PSYM(KK)
 1489           PSYM(KKK)
 1490           %COMMENT NOW PLANT CODE
 1491           K=A(PP); J=1; TEST NST
 1492           OWNLINK=N0<<2
 1493           RBASE=GLA; STORETAG(K,OWNLINK)
 1494           RBASE=10-RLEVEL; N0=N0+4; ->L99
 1495  L3:       A(P+2)=CONSTPTR
 1496           A(P+1)=LENGTH; ->L1 %IF LENGTH<1
 1497           %CYCLE JJ=1,1,(LENGTH*BP+3)//4
?Non-local
 1498           PSYM(0); %REPEAT; ->L1
 1499  L99:      %END; ->L1
 1500  SW(19):                                ! %CLAIM/RELEASE ETC
 1501           COPY TAG(A(P+3))
 1502           ->L1910 %IF A(P+2)=1;          ! '%ARRAY'
 1503           ->L1999 %UNLESS ARR=0 %AND TYPE=3
 1504           FROM2(K,K); ->L1920
 1505  L1910:    ->L1999 %UNLESS ARR=1 %AND TYPE<=3 %AND J<=2
 1506  L1920:    ->L1930 %IF A(P+1)=2;          ! %RELEASE
 1507           KK=CLAIMABLE REG; ->L1999 %IF KK=0
 1508           REGISTER(KK)=A(P+3)+1
 1509           PRX(X'58',KK,0,I,K);          ! LOAD THE REGISTER
 1510           JJ=TAGS(A(P+3))
 1511           FROM1(JJ,JJJ)
 1512           JJJ=JJJ!KK<<12
 1513  L1925:    REPLACE1(JJ,JJJ); ->L1
 1514  L1930:    ->L1999 %UNLESS INREG#0 %AND REGISTER(INREG)=A(P+3)+1
 1515           REGISTER(INREG)=0; JJ=TAGS(A(P+3))
 1516           FROM1(JJ,JJJ)
 1517           JJJ=JJJ&X'FFFF0FFF'; ->L1925
 1518  L1999:    FAULT(58); ->L1
 1519  SW(26):  COMPILER=1; UNASS=0; ->L1
 1520  SW(27):                                ! '%SPEC' FPP
 1521           P=P+1; ->L2701 %IF A(P+1)=1
 1522           CRSPEC(2); ->L1
 1523  L2701:    COPY TAG(A(P))
 1524           ->L3901 %UNLESS PTYPE=4 %AND A(P+4)=2=A(P+3)
 1525           P=P+2; K=DISPLACEMENT(TAGS(A(P-2)))
 1526           ->L1 %IF K=-1; OPHEAD=K;
 1527           P=P+2; CRSPEC(3); ->L1
 1528  SW(20):  MCSWITCH=1; PERM=1; ->L1;       ! %MCODE
 1529  SW(21):  SBFLAG=1; ->L1
 1530  SW(22):  P=2; CUCI; ->L1;                ! *UCI(S)
 1531  SW(23):                                ! %FAULT FAULTLIST
 1532           FAULT(26) %UNLESS LEVEL=2 %AND CPRMODE#2
 1533           P=P+1; Q=P+1
 1534  L2302:    %IF A(Q)=2 %THEN ->L2303
 1535           Q=Q+2; ->L2302
 1536  L2303:    K=A(Q+2)+(A(Q+1)-1)<<14
 1537           KKK=A(P);PCONST(X'41100000'!KKK)
 1538           FAULT(36) %IF KKK>32 %OR KKK=0 %OR KKK=29 %OR 12<=KKK<=13
 1539           PPJ(20); QQ=CA
 1540           PJ(15,K);                     ! JUMP TO LABEL
 1541           PCONST(X'07000700') %UNLESS CA=QQ+8;! JUMP MUST BE 8 BYTES
 1542           P=P+2; ->L2303 %IF A(P-1)=1
 1543           ->L1 %IF A(P+2)=2
 1544           P=P+3; Q=P+1; ->L2302
 1545  SW(24):  FAULT(56) %UNLESS CPRMODE=2 %AND RLEVEL=1
 1546           LOAD DATA;FINALISE
 1547           %STOP
 1548  SW(25):  MCSWITCH=0; PERM=0; ->L1;       ! %ENDOFMCODE
 1549  SW(28):                                !%NAME - SPECIAL NAME
 1550           J=0; PTYPE=10006
 1551           STORE TAG(A(P+1),SNUM)
 1552           SNUM=SNUM+1;->L1
 1553  SW(29):  LIST=1; ->L1;                   ! %LIST
 1554  SW(30):   LIST=0; ->L1
 1555  SW(31):                      ! %CONTROL CONST
 1556           %IF A(P+1)=9 %THEN J=A(P+2) %ELSE FROMAR4(P+2,J)
 1557           K=J&15; LINENOS=K %UNLESS K=15
 1558           K=J>>4&15; DIAGS1=K %UNLESS K=15
 1559           K=J>>8&15
 1560           CHECKS=K %UNLESS K=15
 1561           CHECKSP=K&14 %UNLESS K=15
 1562           K=J>>12&15
 1563           UNASS=K %UNLESS K=15
 1564           K=J>>28
 1565           DCOMP=K %UNLESS K=15
 1566           ->L1
 1567  SW(32):  POP(SBR(LEVEL),J,K);           ! FINISH (ELSE')
 1568           ->L321 %UNLESS J=-1; FAULT(51); ->L1
 1569  L321:     POP(CYCLE(LEVEL),JJ,KK)
 1570           ->L322 %IF 0>=JJ
 1571           FAULT(52); ->L321
 1572  L322:     ->L402 %UNLESS A(2)=1;         ! ELSE FOLLOWS
 1573            FAULT(47) %UNLESS J=1
 1574           P=P+2; KK=K
 1575           MONE=0;R13=0;SET LINE         ;!CLEAR AFTER FINISH
 1576           %IF A(P)=9 %THEN JJ=SFLABEL-1 %ELSE JJ=PLABEL-1
 1577           PJ(15,JJ); PLAB(KK); CUI(2); PLAB(-1); ->L1
 1578  SW(33):                                !RECORD FORMAT
 1579           FAULT(56) %UNLESS LEVEL>=2
 1580           SET LINE; CRFORMAT; ->L1
 1581  SW(34):                                !RECORDS
 1582           %BEGIN
 1583           !%SHORTROUTINE
 1584           %ROUTINESPEC TEST AND SET
 1585           SET LINE; P=P+1; MARKER1=P+A(P)
 1586           FAULT(57) %UNLESS LEVEL>=2
 1587           FAULT(40) %IF NMDECS(LEVEL)#0
 1588           CHECK RF;->L1 %IF K=-1
 1589           TYPE=3;PREC=0;ROUT=0
 1590           ->SCALAR %IF A(P+1)=1
 1591           FAULT(41) %UNLESS A(P+2)=2;   ! RECORD NAME ARRAYS FAULTED
 1592           NAM=0; ARR=1; PACK(PTYPE)
 1593           P=P+3
 1594  L3401:    QQ=P+1
 1595           PSS(X'D2',4,WSPR,0,4,0); ! MVC FOR LENGTH
 1596           CADCLN(2)
 1597           %CYCLE Q=1,1,A(QQ)
?Non-local
 1598           K=A(Q+QQ)
 1599           TEST AND SET
 1600           PPJ(13)
 1601           PRX(X'90',0,3,RBASE,N)
 1602           N=N+16
 1603           %REPEAT
 1604           ->L1 %IF A(P)=2
 1605           P=P+1;CHECK RF;->L3401
 1606  SCALAR:  CQN(P+2);P=P+3;J=0
 1607           PACK(PTYPE)
 1608           %CYCLE Q=1,1,A(P)
?Non-local
 1609           K=A(P+Q)
 1610           TEST AND SET
 1611           %IF NAM=1 %THEN PSS(X'D2',4,RBASE,N,GLA,128) %ELSE %C
 1612+                PACLOD(18,2,RBASE<<12!N)
 1613  %COMMENT = ST WSP,? - AH WSP,LENGTH - LA WSP,7(WSP) - N WSP,=F'-8'
 1614           N=N+4; %REPEAT; ->L1
 1615           %ROUTINE TEST AND SET
 1616           TEST NST
 1617           JJJ=NEWCELL
 1618           STORE TAG(K,JJJ)
 1619           REPLACE BOTH(JJJ,TAGS(A(MARKER1)),N)
 1620           %END
 1621  L1:       %END;->L1
 1622  SW(35):                                ! (RT)'%NAME'(NAMELIST)
 1623           P=P+1; MARKER1=P+A(P)
 1624           ->L3801 %IF A(P+1)=1
 1625           ROUT=1; P=P+2;CLT
 1626           ARR=2-A(P+1);NAM=(A(P+2)-1)<<1
 1627           PACK(PTYPE); ->L3802
 1628  L3801:    PTYPE=11000
 1629  L3802:    J=0;%CYCLE KK=1,1,A(MARKER1)
 1630           K=A(MARKER1+KK)
 1631           TESTNST; OPHEAD=0
 1632           PUSH(OPHEAD,N,1000);          ! SIDE CHAIN AS RT PARAM
 1633           STORE TAG(K,OPHEAD);          !LINK IN SIDE CHAIN
 1634           N=N+40; %REPEAT; ->L1
 1635  SW(36):                                ! RECORD SPEC
 1636           P=P+1; MARKER1=P+A(P)
 1637           CHECK RF; ->L1 %IF K=-1
 1638           P=P+1; COPYTAG(A(P))
 1639           ->L3910 %IF A(P+1)=1
 1640           ->L3902 %IF TYPE=3 %AND NAM=1
 1641  L3901:    FAULT(63); ->L1
 1642  L3902:    FROM1(K,Q)
 1643           FAULT(63) %UNLESS Q=0
 1644           REPLACE1(K,TAGS(A(MARKER1))); ->L1
 1645  L3910:
 1646           P=P+2; K=DISPLACEMENT(TAGS(A(P-2)))
 1647           ->L3901 %IF K=-1; ->L3902
 1648  SW(37):  ->L1;                          ! (S)
 1649  !
 1650           %ROUTINE CEND (%INTEGER KKK)
 1651           !%SHORT %ROUTINE
 1652           %INTEGER DPTR,LNUM,W1,W2
 1653           %INTEGERARRAY DD(0:300)
 1654           SET LINE; R13=0; MONE=1
 1655  L1:       FROM LIST (SBR(LEVEL),J,K)
 1656           ->L2 %IF J=-1; FAULT(53);     ! FINISH MISSING
 1657           A(2)=32; A(3)=2; CSS(2);      ! SO COMPILE IT IN
 1658           ->L1
 1659  L2:       FILL JUMPS(LEVEL)
 1660           NMAX=N %IF N>NMAX;            ! WORK SPACE POINTER
 1661           POP (JUMP(LEVEL),J,K)
 1662           ->L3 %IF J=-1
 1663           ->L2 %IF K>=SFLABEL; FAULT(11)
 1664           %IF K<16384 %THEN WRITE(K,4) %ELSE PRINTNAME(K-16384); ->L2;
 1665  L3:       CLEAR LIST(LABEL(LEVEL))
 1666           CLEAR LIST (WSP (LEVEL))
 1667           CLEAR LIST(LWSP(LEVEL))
 1668           CLEAR LIST(MDARR(LEVEL))
 1669           CLEAR LIST(STR WSP(LEVEL))
 1670           %COMMENT CLEAR DECLARATIONS -PLANT DIAGNOSTICS IF REQUIRED
 1671           ->L10 %IF DIAGS1=0
 1672           LNUM=LETT(M(LEVEL))
 1673           DD(0)=X'C2C2C2C2'
 1674           DD(1)=L(LEVEL)<<16!RBASE<<8!LNUM
 1675           DPTR=3; ->L9 %UNLESS LNUM=0
 1676           DD(2)=L(LEVEL-1); ->L10
 1677  L9:       W1=M(LEVEL)
 1678           %CYCLE W2=1,1,LNUM
 1679           BYTE INTEGER(ADDR(DD(0))+7+W2)=LETT(W1+W2);! MOVE IN RT NAME
 1680           %REPEAT
 1681           DPTR=DPTR+(LNUM-1)>>2
 1682  L10:      POP(NAME(LEVEL),J,JJ)
 1683           ->L20 %IF J=-1
 1684           COPY TAG(JJ);POP(TAGS(JJ),KK,KK)
 1685           %IF PTYPE=8 %THEN %START
 1686           REGISTER(K)=0; UVARREG(K)=0; %FINISH;!RELEASE REGISTERS
 1687           %IF INREG#0 %THEN REGISTER(INREG) =0
 1688           ->L12 %UNLESS J=15
 1689           FAULT(28); PRINT NAME (JJ)
 1690  L12:      OPHEAD=K; ->L13 %IF TYPE=4
 1691           ->L14 %UNLESS ROUT=1 %OR TYPE=3 %OR TYPE=6 %OR ARR=2
 1692           CLEAR LIST(OPHEAD); ->L10
 1693  L13:      UNDCRF (OPHEAD)
 1694           ->L10
 1695  L14:      ->L10 %UNLESS TYPE=1 %OR TYPE=2 %OR TYPE=5
 1696           ->L10 %UNLESS ARR=0 %AND DIAGS1=1 %AND ROUT=0
 1697           ->L10 %IF DPTR>297
 1698           Q=WORD(JJ);LNUM=LETT(Q)
 1699           LNUM=8 %IF LNUM>8;            ! TRUNCATE NAMES TO 8 CHARS
 1700           PTYPE= NAM<<6!PREC<<3!TYPE
 1701           DD(DPTR)=PTYPE<<24!I<<20!K<<8!LNUM
 1702           %CYCLE W1=1,1,LNUM
 1703           BYTE INTEGER(ADDR(DD(DPTR))+W1+3)=LETT(W1+Q)
 1704           %REPEAT
 1705           DPTR=DPTR+1+(LNUM+3)>>2;->L10
 1706  L20:      ->L21 %IF DIAGS 1=0
 1707           DD(DPTR)=-1
 1708           LPUT(4,DPTR<<2+4,SSTL,ADDR(DD(0)))
 1709           SSTL=SSTL+DPTR<<2+4
 1710           %COMMENT CHECK CYCLE-REPEATS
 1711  L21:      ->L22 %IF CYCLE(LEVEL)=0
 1712           FROM2(CYCLE(LEVEL),J)
 1713           ->L22 %IF J=0
 1714           POP(CYCLE(LEVEL),I,I)
 1715           FAULT(13); ->L21
 1716  L22:      %COMMENT GARBAGE COLECT DICTIONARY
 1717           NEXT=RNEXT(LEVEL)
 1718           %CYCLE W1=0,1,NNAMES
 1719           WORD(W1)=0 %IF WORD(W1)>NEXT
 1720           %REPEAT
 1721           %COMMENT PLANT ANY NECESSARY CODE
 1722           NMAX=(NMAX+7)&(-8)
 1723           FAULT(99) %IF NMAX>4092
 1724           PLUG(SET(RLEVEL),NMAX) %IF KKK>=10000 %OR KKK=1
 1725           ->L23 %IF KKK=10000
 1726           ->L24 %IF KKK=0
 1727           %IF KKK>10000 %AND COMPILER =0 %THEN %START
 1728           PCONST(X'4100000B')           ;!LA 0,11  --- FAULT 11
 1729           PPJ(21);%FINISH               ;! *->RTF1
 1730           PPJ(6) %IF KKK=1; ->L30;       ! 'STOP' AT END OF PROGRAM
 1731  L23:      P=P+1; A(P)=5; CUI(0); ->L30;  ! COMPILE '%RTURN' FOR ROUTINES
 1732  L24:      JJ=X'FFF'&RAL(LEVEL-1)
 1733           PRX(X'98',10,11,RBASE,JJ);    ! RESTORE R11&12
 1734           PSS(X'D2',4,GLA,20,RBASE,JJ+8) %IF DIAGS1=1
 1735  L30:      ->L99 %IF KKK=2; NEWLINE
 1736           %IF PRINTMAP=1 %AND LIST=1 %AND KKK#0 %THEN %START
 1737           print string(" LOCALS EXTEND TO ")
 1738           WRITE(NMAX,2); NEWLINE; %FINISH
 1739           ->L31 %IF LIST#0; WRITE(LINE,5)
 1740           SPACES(3*LEVEL-3); print string("END")
 1741  L31:      ->L33 %IF LEVEL>2 %OR PERM=1 %OR CPRMODE=2
 1742           ->L32 %IF KKK=1
 1743           FAULT(14); A(1)=13; ->L99;     ! TOO MANY ENDS
 1744  L32:      KKK=2
 1745  L33:      LEVEL=LEVEL-1
 1746           RLEVEL=RLEVEL-1 %IF KKK>=10000
 1747           RBASE=10-RLEVEL; REGISTER (9-RLEVEL)=0
 1748           N=RAL(LEVEL); SBFLAG=N>>15&1
 1749           NMAX=N>>16 %IF KKK>=10000; N=N&4095
 1750           ->L2 %IF KKK=2;                ! ROUND AGAIN FOR 'ENDOFPROGRAM'
 1751           ->L99 %IF RLEVEL=1 %AND CPRMODE=2
 1752           ->L99 %IF KKK=0 %OR COMPILER=1
 1753           FROM2(JUMP(LEVEL),J)    ; PLAB(J)
 1754  L99:      %END
 1755           %ROUTINE     CRSPEC (%BYTEINTEGER M)
 1756           !%SHORTROUTINE
 1757           %INTEGER PP,KK,JJ,JJJ,Q,TYPEP
 1758           ->L12 %IF M=3
 1759           PP=P; ->L2 %UNLESS M=2
 1760           KK=A(P); P=P+1; COPYTAG(KK)
 1761           ->L1 %IF OLDI=LEVEL %AND 10006#PTYPE>=10000
 1762           FAULT(3); ->L99
 1763  L1:       FROM LIST(K,JJ,Q); OPHEAD=K
 1764           ->L12 %IF Q=1000; ->L10
 1765  L2:       ->L3 %IF A(PP+1)=2
 1766           TYPEP=10000; P=PP+3; ->L4
 1767  L3:       ROUT=1;ARR=0;P=PP+2;CLT
 1768           NAM=(A(P)-1)*2; PACK(TYPEP); P=P+2
 1769  L4:       KK=A(P); COPYTAG(KK)
 1770           ->L11 %IF OLDI#LEVEL
 1771           ->L1 %IF PTYPE=TYPEP %OR |PTYPE-TYPEP|=1000
 1772  L10:      FNAME=KK;FAULT(7) %UNLESS PTYPE=7
 1773           ->L99 %IF M=2
 1774  L11:      JJ=NR; NR=NR+1; RA(JJ)=4*N0; N0=N0+1
 1775           FAULT(109) %IF NR>NROUTS
 1776           OPHEAD=NEWCELL;J=15;PTYPE=TYPEP
 1777           STORE TAG(KK,OPHEAD)
 1778  L12:      JJJ=OPHEAD; Q=0; ->L24 %IF A(P+1)=2;     ! NO FORMAL PARAMS
 1779  L13:      P=P+2; COMPILE FORMAL PARAMETER
 1780           %CYCLE PP=1,1,A(P)
 1781           KK=0; KK=ACC %IF PTYPE=5
 1782           INSERT AFTER(OPHEAD,PTYPE,KK);! FOR STRINGS PUSH IN LMAX
 1783           Q=Q+1; %REPEAT
 1784           P=P+PP+1; ->L13 %IF A(P)=1
 1785  L24:      REPLACE2(JJJ,Q)
 1786           ->L99 %IF M=3
 1787           REPLACE1(JJJ,JJ)
 1788  L99:      %END
 1789           %ROUTINE     COMPILE FORMAL PARAMETER
 1790           !%SHORT %ROUTINE
 1791           %SWITCH FPD(1:5)
 1792           ->FPD(A(P))
 1793  FPD(1):  !(RT)
 1794           ACC=16;ROUT=1;NAM=1
 1795           ARR=0
 1796           ->L1 %UNLESS A(P+1)=1
 1797           PREC=0;TYPE=0;P=P+3; ->L98
 1798  L1:       P=P+2; CLT;NAM =2*(A(P)-1)+1
 1799           P=P+2; ACC=16; ->L98
 1800  FPD(2):  !(LENGTH')(TYPE)(ARRAY')(NAME)
 1801           P=P+1; CLT
 1802           CQN(P); ROUT=0
 1803           FAULT(70) %IF TYPE=5 %AND ACC=0
 1804           P=P+1; ->L98
 1805  FPD(3):  !%NAME
 1806           TYPE=0
 1807  L31:      NAM=1; ARR=2-A(P+1); ROUT=0
 1808           ACC=4+12*ARR
 1809           PREC=0; P=P+2; ->L98
 1810  FPD(4):  TYPE=3; ->L31
 1811  L98:      PACK(PTYPE)
 1812           %END
 1813           %ROUTINE ASSIGN (%INTEGER P1,P2)
 1814           !%SHORTROUTINE
 1815           %INTEGER Q,ASSOP,KK,REG,PRECP,Z,ZP,TYPEP
 1816           %INTEGER JJJ
 1817           %SWITCH SW(1:4), S(0:15)
 1818           ASSOP=A(P2); ->SW(ASSOP);     !P2 ON ASSOP
 1819  SW(2):SW(3):   COPYTAG(A(P1+1)); P=P2+1
 1820           ->REGVAR %IF TYPE=8
 1821           ->MAPS %IF ROUT=1
 1822           ->L34 %IF TYPE=2
 1823           ->L50 %IF TYPE=5
 1824           ->L35 %IF TYPE=3
 1825           ->L32 %IF NAM=0 %AND TYPE=1 %AND ARR=0
 1826  L33:      P=P2+1
 1827           KK=0; KK=4 %UNLESS ARR=0 %AND ROUT=0 %AND 1>=TYPE
 1828  L36:      %IF KK=4 %AND REGISTER(4)#0 %THEN KK=14
 1829           CSEXP(KK,1); REG=NEST;KK=P
 1830           REGISTER(REG)=1 %IF REGISTER(REG)=0
 1831           P=P1+1; CNAME((ASSOP-1)*(ASSOP-1),REG)
 1832           REGISTER(REG)=0 %IF REGISTER(REG)>0
 1833  L30:
 1834           P=KK; %IF A(P)=1=QU  %THEN CQUERY (REG)
 1835           P=P+1; ->L1
 1836  L31:      print string(" CRUNCH "); %MONITOR ; %STOP
 1837  L32:      ->L33 %IF ROUT=1 %OR A(P1+2)=1 %OR A(P1+3)=1;! ACTUAL PARAMS
 1838           ->L33 %IF UNASS =1
 1839           PRECP=PREC; TYPEP=PTYPE
 1840           KK=K; REG=I; Q=TSEXP(JJJ)
 1841           PTYPE=TYPEP; UNPACK
 1842           ->L33 %IF Q=0 %OR A(P)=1=QU
 1843           ->L37 %IF 10<=Q<=12 %AND Q-10=PRECP
 1844           ->L33 %UNLESS Q=1 %AND PRECP=1
 1845           PSI(X'92',JJJ,REG,KK);        ! MVI TO SET BYTE
 1846           P=P+1;->L1;                     ! SKIP QUERY IF ANY
 1847  L37:      PSS(X'D2',BYTES(PRECP),REG,KK,I,K); ! MVC IF POSSIBL
 1848           P=P+1; ->L1
 1849  L34:      Q=2; Q=3 %IF PREC=3
 1850           %IF A(P1+2)=1 %THEN %START
 1851           P=P1+2; FFLAG=0; SKIP APP; ->L55 %IF FFLAG#0
 1852           P=P2+1; %FINISH
 1853           CSEXP(0,Q); KK=P
 1854           FREG(NEST)=1; REG=NEST
 1855           P=P1+1; CNAME(1,NEST)
 1856           FREG(REG)=0
 1857           ->L30
 1858  L35:      P=P1+1; Q=COPY RECORD TAG
 1859           P=P2+1
 1860           TYPE=1 %UNLESS TYPE=2 %OR TYPE=5
 1861           ->L50 %IF TYPE=5
 1862           KK=4; ->L36 %IF TYPE=1; ->L34
 1863  L50:      CSTREXP(4);KK=P
 1864           REGISTER(4)=1
 1865           P=P1+1;
 1866           CNAME((ASSOP-1)^^2,4)
 1867           REGISTER(4)=0
 1868           REG=4; ->L30
 1869  MAPS:    %IF PTYPE=10006 %THEN %START
 1870           TYPE=TSNAME(K);PREC=TYPE>>3
 1871           TYPE=TYPE&7; %FINISH
 1872           ->L33 %IF TYPE=1;              ! NORMAL CHANNELS FOR INT MAPS
 1873           ->L50 %IF TYPE=5;              ! STRING MAPS
 1874  L55:      P=P2+1; PRECP=PREC
 1875           CSEXP(0,2+PREC&1)
 1876           Q=PARKF(NEST,3)
 1877           KK=P; P=P1+1; CNAME(3,1);     ! ADDR TO GR1
 1878           DUMP(16,0,Q,0,RBASE);         ! PICK UP TO FR0
 1879           DUMP(9+2*PREC,0,0,0,1);       ! STUFF IT OFF
 1880           PUSH(LWSP(LEVEL),0,Q); ->L30;  ! TO QUERY PRINT
 1881  REGVAR:  FAULT(59) %UNLESS A(P1+2)=2=A(P1+3)
 1882           KK=K; CSEXP(KK,1)
 1883           REGISTER(KK)=-1
 1884           %IF A(P)=1=QU %THEN CQUERY(REG)
 1885           P=P+1; ->L1
 1886  SW(4):                                  !ASSOP=->L
 1887           P=P1+1; CNAME(2,1)
 1888           P=P2+1
 1889           CRES(0,0)
 1890           P=P+1;->L1
 1891  SW(1):   !ASSOP='=='
 1892           P=P1+1; COPYTAG(A(P))
 1893           ->L9 %IF I=-1;Q=1
 1894           %IF TYPE=3 %THEN Q=COPY RECORD TAG
 1895           ->L201 %IF Q=0
 1896           FAULT(81) %UNLESS A(P2+1)=4 %AND A(P2+2)=1
 1897           ->L101 %IF ROUT=1; NEST=4
 1898           ->S((NAM&2+ARR)<<2!(NAM&1)*2!(2-A(P+1)))
 1899  L9:       FNAME=A(P); FAULT(16)
 1900  S(0):S(1):S(3):S(4):S(5):
 1901  S(7):S(8):S(10):S(11):S(12):
 1902  L10:      FAULT(82)
 1903           P=P2+1; SKIPEXP; P=P+1; ->L1
 1904  S(2): ! NAM=1; S(9):!NAMARR + APP; S(15):! NAMARR +NAM+APP; S(13):
 1905           Z=3; ZP=6
 1906  L12:      P=P2+3; CNAME(Z,4)
 1907           ->L10 %UNLESS A(P)=2; PRECP=PREC
 1908           TYPEP=TYPE
 1909           KK=P+2; P=P1+1; CNAME(ZP,4)
 1910  L14:
 1911           P=KK;     ->L1 %IF PREC=PRECP %AND TYPE=TYPEP
 1912           FAULT(83); ->L1
 1913  S(6):    ! ARRAYNAME-NO APP
 1914  S(14):   !NAMARRAYNAME-NO APP
 1915           Z=12; ZP=11; ->L12
 1916  L201:
 1917           ->S(6) %IF ARR=1 %AND NAM=1 %AND A(P+1)=2
 1918           Z=15; ZP=14; ->L12
 1919  L101:     P=P1+1; CNAME(13,1);          ! ASSIGNMENTS TO RECORDNAMES
 1920           PRECP=PREC; TYPEP=TYPE; JJJ=K;
 1921           ->L10 %UNLESS J=0 %AND NAM=1
 1922           REG=FINDPP; ->L31 %IF REG=0
 1923           DUMP(0,REG,DISP,INDEX,BASE);  ! ADDRESS OF LHS TO SAFE PLACE
 1924           P=P2+3; CNAME(13,1);          ! RHSIDE
 1925           ->L102 %IF BASE=GLA %AND J=0;  ! COMMON OR GARDEN ROUTINE
 1926           PSS(X'D2',16,REG,0,BASE,DISP)
 1927           ->L103 %IF J=14;     ! EXTERNAL ROUTINE
 1928  L110:     REGISTER(REG)=0; KK=P+2
 1929           FROM2(JJJ,Z); FROM2(K,ZP)
 1930           FAULT(83) %UNLESS Z=ZP
 1931           ->L14
 1932  L102:     DUMP(2,2,DISP,INDEX,BASE);      ! PICK UP RT ADDR
 1933           PRX(X'5A',2,0,GLA,28);        ! RELOCATE
 1934           PCONST(X'180C181D');          ! LR 0,12 LR1,13 PERM AND GLA
 1935           PRR(X'18',3,REG);             ! CUNNING PTR TO ENVRMNT
 1936           PRX(X'90',0,9,REG,0); ->L110;  ! STUFF OFF + ENVRMNT
 1937  L103:     PRX(X'50',9,0,REG,12); ->L110; ! EXTRNS DUMMY ENVRMNT
 1938  L1:       %END
 1939           %ROUTINE     CUI(%BYTEINTEGER CODE)
 1940           !%SHORTROUTINE
 1941           %INTEGER KK,JJ,QQ
 1942           %SWITCH SW(1:11)
 1943                 ->SW(A(P))
 1944  SW(1):   P=P+1; MARKER1=P+A(P);      !(NAME)(APP)(RESTOFUI)
 1945                 ->L3 %IF A(MARKER 1)=1
 1946           P=P+1; CNAME(0,0); P=P+1; ->L1
 1947  L3:       ASSIGN(P,MARKER1+1); ->L1
 1948  SW(2):   !->L<NAME><EXRN>
 1949           NMDECS(LEVEL)=1
 1950                 COPY TAG(A(P+1))
 1951           PTYPEP=PTYPE
 1952           KK=K; P=P+2
 1953           ->L200 %IF OLDI=LEVEL %AND TYPE=6
 1954           FAULT(4);SKIP EXP; ->L1
 1955  L200:     CSEXP(1,1);PTYPE=PTYPEP; UNPACK
 1956           FROM LIST(KK,QQ,JJ)
 1957           QQ=QQ-CODEBASE(LEVEL)
 1958           ->L205 %IF CHECKSP=0
 1959  L201:     LOADAD( 2,10,0,QQ);PPJ(7); ->L1
 1960  L205:     JJ=8+QQ-JJ*BYTES(PREC);       !@ SW(0)
 1961           ->L201 %UNLESS 0<=JJ<=4095
 1962           ->L210 %IF PREC=0
 1963           PLANT(X'1A11');KK= X'48';     !AR_1,1
 1964  L207:     PRX(KK,1,1,10,JJ);            !L(H)_1,JJ(1,10)
 1965           PCONST(X'47F1A000');->L1;      !BC_15,0(1,10)
 1966  L210:     PCONST(X'89100002');KK= X'58';->L207;! SLL_1,2
 1967  SW(3):                                 ! '->L'(LABEL)
 1968           NMDECS(LEVEL)=1
 1969           K=A(P+2)+(A(P+1)-1)<<14
 1970           PJ(MASK,K); P=P+3; ->L1
 1971   SW(4):        !PRINT TEXT
 1972           K=(A(P+1)+2)//2; P=P+1; PPJ(30)
 1973           %CYCLE KK=1,1,K; PLANT(A(P)<<8!A(P+1))
 1974           P=P+2; %REPEAT; ->L1
 1975   SW(5):        !RETURN
 1976           FAULT(30) %UNLESS FLAG(LEVEL)=10000 %OR PERM=1
 1977                 P=P+1
 1978  L6:       PSS(X'D2',4,GLA,20,RBASE,0) %IF DIAGS1=1
 1979           %COMMENT CHECK FOR REGISTER VARS & UPDATE CORE COPY
 1980           %CYCLE KK=5,1,8
 1981           %IF 0#UVARREG(KK)<LEVEL %THEN PRX(X'50',KK,0,RBASE,KK<<2)
 1982           %REPEAT
 1983           PRX(X'98',4,15,RBASE,16);     ! LM OLD REGISTERS
 1984           R13=0; PRR(7,15,LINK); ->L1;   ! BR LINK
 1985  SW(6):   ! %RESULT =EXPR
 1986           P=P+1; KK=FLAG(LEVEL)
 1987           FAULT(31) %UNLESS KK>10000
 1988           ->L61 %IF KK=10002
 1989           ->L62 %IF KK=10032
 1990           ->L63 %IF KK=10005
 1991           CSEXP(1,1); ->L6
 1992  L61:      CSEXP(2,2); ->L6
 1993  L62:      CSEXP(2,3); ->L6
 1994  L63:      CSTREXP(1); ->L6
 1995  SW(7):SW(8):   ! STOP & MONITORSTOP
 1996           PPJ(6*(A(P)-6)); P=P+1; ->L1
 1997  SW(9):  SFLABEL=SFLABEL-1
 1998          PUSH(SBR(LEVEL),CODE,SFLABEL)
 1999           PUSH(CYCLE(LEVEL),0,0)
 2000           ->L1
 2001  SW(11):                                ! %QUERIES (ONOFF)
 2002           KK=2-A(P+1); P=P+2
 2003           PSI(X'92',KK,GLA,1); ->L1
 2004  SW(10):  PPJ(31); P=P+1; ;             ! %MONITOR
 2005  L1:            %END
 2006           %ROUTINE     CRFORMAT
 2007           !%SHORTROUTINE
 2008           %INTEGER LENGTHP,QQQ,REP,CODE
 2009           K=A(P+1);TEST NST
 2010           J=0;PTYPE=4;OPHEAD=NEWCELL
 2011           JJJ=OPHEAD;STORE TAG(K,JJJ)
 2012           P=3;Q=0;INC=4;INCP=0
 2013  ! INC COUNTS ALONG RECORD FORMAT DOPEVECTOR..INCP BYTES FROM RECORDHD
 2014           ->L101 %IF A(P)=2;             ! NO FPP
 2015  L1:       P=P+1; COMPILE FORMAL PARAMETER
 2016           LENGTHP=ACC-1; LENGTHP=3 %IF ACC>8
 2017  L2:       ->L3 %IF INCP&LENGTHP=0; INCP=INCP+1; ->L2
 2018  L3:       %CYCLE REP=1,1,A(P); P=P+1
 2019           CODE=255; LENGTHP=ACC
 2020           ->L11 %IF ROUT=1
 2021           ->L12 %IF TYPE=3;QQQ=INCP
 2022           ->L4 %UNLESS TYPE=5
 2023           CODE=250; LENGTHP=ACC-1; QQQ=INC
 2024  L4:       INSERT AFTER(OPHEAD,PTYPE<<4!A(P)<<20,QQQ)
 2025           PSI(X'92',CODE,RBASE,N+INC)
 2026           PSI(X'92',LENGTHP,RBASE,N+INC+1)
 2027           Q=Q+1
 2028           INC=INC+4; INCP=INCP+ACC
 2029           ->L15
 2030  L11:      QQQ=NEWCELL; REPLACE BOTH(QQQ,INCP,100)
 2031           FAULT(41) %UNLESS PTYPE=11000;! FUNCTIONS TOO DICEY AT PRESENT
 2032           ACC=40; LENGTHP=ACC; ->L4;     ! RT NAME MUST CARRY ENVRMNT
 2033  L12:      QQQ=NEWCELL; REPLACE BOTH(QQQ,0,INCP); ->L4
 2034  L15:      %REPEAT
 2035           P=P+1;                        ! P ON REST OF FP LIST
 2036           ->L101 %IF A(P)=2; P=P+1; ->L1
 2037  L101:     P=P+1
 2038  L102:     ->L201 %IF A(P)=2;             ! NO ARRAYS
 2039           P=P+2; CLT
 2040           NAM= 2*(2-A(P))
 2041           ACC=4 %IF NAM#0;P=P+1
 2042           ROUT=0; ARR=1; PACK(PTYPE)
 2043  L103:
 2044           PSI(X'92',0,RBASE,N+INC);     ! FLAG FOR ARRAYS
 2045           DUMP(1,WSPR,N+INC+8,0,RBASE); ! PTR TO DOPE VECTOR
 2046           QQ=P; CADCLN(1)
 2047           JJ=P; P=QQ+2
 2048           REP=P+A(P-1);                 ! AFTER LAST NAME
 2049  L105:     INSERT AFTER(OPHEAD,J!PTYPE<<4!A(P)<<20,INC)
 2050           INC=INC+16; Q=Q+1
 2051           P=P+1; ->L106 %IF P=REP
 2052           PSS(X'D2',16,RBASE,N+INC,RBASE,N+INC-16); ->L105
 2053  L106:     P=JJ+2
 2054           ->L103 %IF A(P-1)=1; ->L102;    ! P ON RESTOFARRAYLIST
 2055  L201:     REPLACE BOTH(JJJ,N,Q)
 2056           PRX(X'41',1,0,0,Q);           ! LA 1,ITEMS
 2057           DUMP(5,1,N,0,RBASE);         !STH
 2058           DUMP(0,1,N,0,RBASE)
 2059           PPJ(25); N=N+INC
 2060           %END
 2061           %ROUTINE     CADCLN(%BYTEINTEGER MODE)
 2062           !%SHORTROUTINE
 2063  ! MODE=0 NORMAL DECN, =1 IN RECORD FORMAY, =2 RECORD ARRAY
 2064  ! P POINTS TO NAMELIST -1
 2065           %INTEGER Q,QQ,KK,S,JJ,JJJ
 2066           Q=P; PTYPEP=PTYPE
 2067  L1:       P=A(Q+1)+Q+1
 2068           KK=0;  %IF MODE=1 %THEN ->L4
 2069           PRX(X'50',WSPR,0,GLA,36);     ! PTR TO DOPE VECTOR INTO GLA
 2070           PSI(X'92',1,GLA,36) %IF UNASS=1;! FLAG TO FILL WITH X'000'
 2071  L4:       P=P+2; JJ=P; KK=KK+1
 2072           SKIP EXP; QQ=TSEXP(JJJ); P=JJ
 2073           %IF QQ=0 %THEN CSEXP(4,1) %ELSE CSEXP(1,1)
 2074           REGISTER(4)=1; CSEXP(2,1); REGISTER(4)=0
 2075           PRR(X'18',1,4) %IF QQ=0;      ! BOUND PAIR NOW IN R1 & R2
 2076           ->L41 %UNLESS KK=1; S=1
 2077           %UNLESS MODE=2 %THEN %START
 2078           S=0; PRX(X'41',0,0,0,ACC); %FINISH;
 2079           PRX(X'90',S,2,WSPR,4*S); !      STM TO DUMP BOUND PAIR & R0
 2080           PSI(X'92',3-A(P),WSPR,1);     ! MVI TO SET DIMENSION
 2081           MOVER(WSPR,16); ->L42
 2082  L41:      S=(KK&1)<<2
 2083           %IF S=0 %THEN JJJ=8*A(P) %ELSE JJJ=16
 2084           PRX(X'90',1,2,WSPR,S)
 2085           MOVER(WSPR,JJJ)
 2086  L42:      ->L4 %IF A(P)=1;               ! FOR NEXT BOUND PAIR
 2087           ->L5 %IF KK<=2
 2088           FAULT(37) %IF KK>6
 2089                 PACLOD(27,3,KK);        !  L 1,=A(DV)--MVI 1(1),KK
 2090  L5:       QQ=Q+1; J=KK; PTYPE=PTYPEP; ->L9 %IF MODE >=1
 2091           %CYCLE JJJ=1,1,A(QQ)
 2092           K=A(QQ+JJJ); TESTNST; J=KK
 2093           STORE TAG(K,N);PPJ(13)
 2094           PRX(X'90',0,3,RBASE,N);       ! STM 0,3--SAVE ARRAYHEAD
 2095           N=N+16; %REPEAT
 2096           Q=P+2; ->L1 %IF A(Q-1)=1
 2097  L9:       %END
 2098           %ROUTINE     CVDECLN
 2099           !%SHORTROUTINE
 2100           %INTEGER LB,UB,ADV,Q,QQ,RANGE,JJJ,KK,DISP0,DISP1
 2101           Q=P
 2102           P=A(Q+1)+Q+2
 2103           CBPAIR(LB,UB)
 2104           ADV=N0
 2105           ST(N0)=1<<16!ACC
 2106           ST(N0+1)=LB
 2107           ST(N0+2)=UB
 2108           RANGE=UB-LB+1
 2109           ST(N0+3)=RANGE; N0=N0+4
 2110           FAULT(44) %IF LB>UB
 2111           PRX(X'41',2,0,GLA,ADV<<2)
 2112           PRX(X'41',3,0,0,RANGE)
 2113           QQ=Q+1; J=1
 2114           %CYCLE JJJ=1,1,A(QQ)
 2115           N=(N+7)&(-8)
 2116           DISP1=N+16
 2117           DISP0=DISP1-LB*ACC; FAULT(44) %UNLESS 0<DISP0<4095
 2118           KK=NEWCELL; REPLACE BOTH(KK,DISP0,N)
 2119           PRX(X'41',0,0,RBASE,DISP0)
 2120           PRX(X'41',1,0,RBASE,DISP1)
 2121           K=A(QQ+JJJ); TESTNST
 2122           STORE TAG(K,KK)
 2123           PRX(X'90',0,3,RBASE,N)
 2124           SET80(DISP1,ACC*RANGE) %IF UNASS=1
 2125           N=DISP1+ACC*RANGE
 2126           %REPEAT
 2127           P=P+1; %IF A(P-1)=1 %THEN CVDECLN
 2128           N=(N+3)&(-4)
 2129           %END
 2130           %ROUTINE     CSEXP(%INTEGER REG,%BYTEINTEGER MODE)
 2131           %COMMENT MODE=1 FOR %INTEGER, =2REAL, =3LONG,=0INTEGER %IF PNS
 2132           %INTEGER C,D,QP,NOP,X,JJ,OPCODE
 2133           %INTEGER EVALUATE,OPND
 2134           %SHORTINTEGER OPHEAD
 2135           %BYTEINTEGER REAL,LONGREAL,REALOP
 2136           %INTEGER OPERATOR,NOPS,LASTOP
 2137           %INTEGERARRAY BS,PT,DP(1:2)
 2138                 %INTEGERARRAY OP,OPPREC(0:5)
 2139           %ROUTINESPEC TEST(%INTEGER N)
 2140           %ROUTINESPEC PLANT(%INTEGER A,B,C)
 2141           %INTEGERFNSPEC FINDR
 2142           %ROUTINESPEC LOAD(%INTEGERNAME N,%INTEGER REG,MODE)
 2143           %ROUTINESPEC PRINT ORDERS
 2144           %OWNINTEGER N0=1024
 2145           QP=0; OPHEAD=0; OPCODE=0
 2146           REAL=0; LONGREAL=0; REALOP=0
 2147           NOPS=0; LASTOP=0
 2148           %BEGIN
 2149           !%SHORTROUTINE
 2150           %SWITCH S,SW(1:4)
 2151           AFLAG=0; NOP=N0
 2152           OP(0)=0; OPPREC(0)=0
 2153           ->S(A(P));                    !SWITCH ON PHRASE (+1)
 2154  S(2):                                  !NEGATE
 2155           OP(1)=11;
 2156  L101:     OPPREC(1)=2+OP(1)//6; QP=1; ->L1
 2157  S(3):    OP(1)=23; ->L101;              !INITIAL NOT
 2158  S(1):S(4):L1:                           ! PLUS OR NULL ALTERNATIVE
 2159           OPND=A(P+1); P=P+2; QP=QP+1
 2160           ->SW(OPND);         ! SWITCH ON OPERAND
 2161  SW(1):                                 !NAME
 2162           COPYTAG(A(P))
 2163           ->REGVAR %IF TYPE=8
 2164           ->L19 %IF TYPE=3 %AND ARR=0 %AND INREG#0
 2165           ->L171 %IF ARR=2 %AND A(P+1)=1
 2166           ->L17 %IF 1<=TYPE<=2 %AND ARR=0 %AND ROUT=0 %AND A(P+1)=2=A(P+2)
 2167  L10:
 2168           ->L14 %UNLESS TYPE=1 %OR(ROUT=1%AND TYPE=6%AND TSNAME(K)&7=1)
 2169           C=P; ->L11 %IF QP>1
 2170           P=P+1; SKIPAPP; ->L11 %UNLESS A(P)=A(P+1)=2
 2171           P=C; C=REG
 2172           %IF REG<=0 %THEN %START
 2173           C=FINDR; REGISTER(C)=0
 2174           %FINISH
 2175           CNAME(2,C); NEST=C; ->L80;     ! ONE OPND EXPR
 2176  L11:      P=C
 2177           C=FINDPP; ->L14 %IF C=0
 2178           CNAME(2,C); NEST=C
 2179           ->L80 %IF QP=1 %AND A(P)=2;P=P+1;   ! ONE OPND EXPR
 2180  L12:      ST(N0)=9; ST(N0+1)=C; N0=N0+3
 2181           REGISTER(C)=1
 2182           ->L50
 2183  L14:      %COMMENT OPERAND MUST BE FETCHED AND STORED
 2184           CNAME (2,2);NEST =2
 2185           %IF TYPE=5 %THEN %START; FAULT(42); TYPE=1; %FINISH;
 2186           %IF TYPE=2 %THEN FREG(2)=1 %ELSE REGISTER(2)=1
 2187           NAM=0;ARR=0;ROUT=0
 2188           LONGREAL=1 %IF PREC=3
 2189           ->L80 %IF QP=1 %AND A(P)=2
 2190  L16:      ->L15 %IF TYPE=1
 2191           REAL=1; LONGREAL=1 %IF PREC=3
 2192           ->L161 %IF A(P)=2;             ! EXPRESSION ENDED
 2193           C=PARKF(NEST,PREC)
 2194           FREG(NEST)=0
 2195  L13:      ST(N0)=10; P=P+1
 2196           ST(N0+1)=RBASE!(TYPE!PREC<<3!NAM<<6)<<8
 2197           ST(N0+2)=C; N0=N0+3; ->L50
 2198  L161:     ST(N0)=8; ST(N0+1)=NEST+512+PREC<<11
 2199           FREG(NEST)=1
 2200           N0=N0+3; P=P+1; ->L50
 2201  L15:      C=NEST
 2202           C=PARK(NEST)
 2203           REGISTER(NEST)=0 %UNLESS NEST=C
 2204           ->L18 %IF C>0;     ! IN GENERAL REGISTER
 2205           C=|C|; PREC=0; ->L13;          ! IN CORE EQUIVALENT TO INTEGER
 2206  L18:      P=P+1; ->L12
 2207  L17:      %COMMENT OPND HAS BASE REGISTER COVER
 2208           ST(N0)=2; ST(N0+1)=I!(TYPE!PREC<<3!NAM<<6)<<8
 2209           ST(N0+2)=K; P=P+4; N0=N0+3
 2210           REAL=1 %IF TYPE=2
 2211           LONGREAL=1 %IF PREC=3
 2212           ->L50 %UNLESS UNASS=1 %AND(PREC=0 %OR PREC=3)
 2213           ->L50 %IF NAM=1
 2214           PSS(X'D5',BYTES(PREC),I,K,GLA,128);      ! CLC V,=X'80808080'
 2215           PRX(X'47',8,0,CODER,40); ->L50;;! CHECK ASSIGNED
 2216  L171:     ->L10 %UNLESS A(P+2)=4 %AND A(P+3)=2 %AND A(P+4)=9
 2217           ->L10 %UNLESS A(P+5)<256 %AND A(P+6)=2 %AND A(P+7)=2=A(P+8)
 2218           FROM1(K,C); C=C+BYTES(PREC)*A(P+5)
 2219           ->L10 %UNLESS 0<C<4096; K=C; P=P+6; ->L17
 2220  L19:      ->L14 %UNLESS A(P+1)=2 %AND A(P+2)=1;    ! NO APP BIUT ENAME
 2221           P=P+3; FROM1(K,FNAME); I=INREG
 2222           K=DISPLACEMENT(FNAME)
 2223           ->L191 %IF I=-1; UNPACK
 2224           ->L17 %IF ARR=0 %AND ROUT=0 %AND 1<=TYPE<=2 %AND A(P+1)=2%C
 2225+          =A(P+2);                      ! NO APP OR SECOND ENAME
 2226  L191:     P=P-3; ->L14
 2227  REGVAR:  ->L14 %UNLESS A(P+1)=2=A(P+2);! NO APP OR ENAME
 2228           P=P+4; ST(N0)=9; ST(N0+1)=K
 2229           N0=N0+3; ->L50
 2230  SW(2):                                 !CONSTANT
 2231           C=A(P); ST(N0+1)=P; ST(N0+2)=A(P+1)
 2232           ->L24 %IF C&7=2
 2233           %IF C=5 %THEN %START
 2234           FAULT(42); P=P+A(P+1)&X'FE'+1
 2235           C=9; %FINISH
 2236           ->L22 %UNLESS C>8;             !GO UNLESS IMMEDIATE
 2237           ST(N0)=0
 2238  L21:      N0=N0+3; P=P+3;
 2239           ->L50
 2240  L22:      ST(N0)=1; P=P+1; ->L21
 2241  L24:      REAL=1; P=P+2; ->L22
 2242  SW(3):SW(4):                 ! SUB EXPRESSION
 2243           D=0; D=1 %IF MODE=1 %OR LASTOP=12;! INTEGER EXPONENTS
 2244           CSEXP(0,D)
 2245           ->L32 %UNLESS OPND=4
 2246           D=16*TYPE
 2247           D=48 %IF TYPE=2 %AND PREC=0
 2248           PRR(D,NEST,NEST);             !DEAL WITH MOD SIGNS
 2249  L32:      LONGREAL=1 %IF PREC=3
 2250           ->L80 %IF QP=1 %AND A(P)=2;    !ONE OPD EXPRESSION
 2251           ->L16 ;                        !TO STORE RESULT
 2252  L50:      %COMMENT DEAL WITH OPERATOR
 2253           ->L60 %IF A(P-1)=2;            !EXPRESSION FINISHED
 2254           OPERATOR=A(P)
 2255           %IF OPERATOR=12 %THEN %START; ! '.'
 2256           FAULT(42); OPERATOR=2; %FINISH;!   CHANGE TO +
 2257           OPERATOR = 6 %IF OPERATOR=13;     !%NULL == *
 2258           REALOP=1 %IF OPERATOR=1 %OR OPERATOR=8
 2259           OPERATOR=12 %IF OPERATOR=1
 2260           NOPS=NOPS+1; LASTOP=OPERATOR
 2261           C=PRECEDENCE(OPERATOR)
 2262  L51:      ->L52 %IF C>OPPREC(QP-1);      !OPERATOR MAY BE STORED
 2263           QP=QP-1
 2264           ST(N0)=OP(QP)
 2265           N0=N0+3; ->L51;                !UNLOAD STACK
 2266  L52:      OP(QP)=10+OPERATOR
 2267           OPPREC(QP)=C; ->L1;            !FOR NEXT OPERAND
 2268  L60:      %COMMENT - END OF EXPRESSION
 2269           %CYCLE JJ=QP-1,-1,0
?Non-local
 2270           ST(N0)=OP(JJ)
 2271           N0=N0+3; %REPEAT;             !EMPTY OPERATOR STACK
 2272           REAL=1 %IF MODE#1 %AND REALOP=1
 2273           ->L70 %IF REAL=1
 2274           %COMMENT - CAN EVALUATE AS INTEGER
 2275           PRINT ORDERS
 2276  L61:      ->L71 %IF MODE>=2
 2277  L72:      D=1; REG=REG-1 %IF 0>=REG
 2278           LOAD(D,REG,REAL) %UNLESS REAL=0 %AND 0>REG %AND DP(1)<0 %C
 2279+          %AND REGISTER(BS(1))<0;       ! RESULT IN LOCKED REG
 2280           NEST=BS(1)
 2281           %IF REAL=1 %THEN FREG(NEST)=0 %ELSE %START
 2282           REGISTER(NEST)=0 %IF REGISTER(NEST)>0; %FINISH
 2283           PTYPE=1+30*LONGREAL+REAL
 2284           N0=NOP; UNPACK; ->L99
 2285  L70:      %COMMENT EVALUATE AS REAL
 2286           FAULT(24) %IF MODE=1;         ! REAL IN INTEGER EXPRN
 2287           LONGREAL=1 %IF MODE=3
 2288           EVALUATE=16*LONGREAL
 2289           PRINT ORDERS
 2290           ->L72
 2291  L71:      LONGREAL=1 %IF MODE=3
 2292           REAL=1
 2293           EVALUATE=16*LONGREAL
 2294           ->L72
 2295  L80:      %COMMENT SINGLE OPERAND EXPRESSION
 2296           BS(1)=NEST; DP(1)=-1
 2297           PT(1)=PREC<<3!TYPE
 2298           AFLAG=0; P=P+1
 2299           FAULT(24) %IF TYPE=2 %AND MODE=1
 2300           ->L61 %IF TYPE=1; ->L71
 2301  L99:      %END;->L99
 2302           %INTEGERFN FINDR
 2303           !%SHORTROUTINE
 2304           %INTEGER I
 2305           ->L2 %IF 0>=REG
 2306           I=REG; ->L1 %IF REGISTER(I)=0
 2307  L2:       %CYCLE I=1,1,RBASE-1
 2308           ->L1 %IF REGISTER(I)=0
 2309           %REPEAT; FAULT(241)
 2310  L1:       REGISTER(I)=1; %RESULT=I; %END
 2311           %INTEGERFN FINDPR
 2312           %INTEGER I
 2313           %CYCLE I=0,2,6
 2314           ->FOUND %IF REGISTER(I)=0 %AND REGISTER(I+1)=0
 2315           %REPEAT
 2316           FAULT(242)
 2317  FOUND:   REGISTER(I)=1
 2318           REGISTER(I+1)=1
 2319           %RESULT=I
 2320           %END
 2321           %INTEGERFN FIND FR
 2322           !%SHORTROUTINE
 2323           %INTEGER I
 2324           %CYCLE I=6,-2,0
 2325           ->L1 %IF FREG (I)=0
 2326           %REPEAT; FAULT(242)
 2327  L1:       FREG(I)=1; %RESULT=I
 2328           %END
 2329           %ROUTINE     LOAD(%INTEGERNAME N,%INTEGER REG,MODE)
 2330           !%SHORTROUTINE
 2331           %INTEGER I,X
 2332           %INTEGERNAME BSI,DPI,PTI
 2333           I=N; ->NOCHOICE %UNLESS I=0
 2334           I=1; ->CHOSEN %IF DP(1)<0 %AND REGISTER(BS(1))>=0
 2335           I=2; ->CHOSEN %IF DP(2)<0 %AND REGISTER(BS(2))>=0
 2336           ->CHOSEN %IF MODE=0 %AND (PT(2)=255 %OR PT(2)&24=8)
 2337           ->CHOSEN %IF MODE=1 %AND (PT(2)&7=1 %OR (EVALUATE>0 %AND  %C
 2338+          PT(2)&24=0)); I=1
 2339  CHOSEN:  N=I
 2340  NOCHOICE:BSI==BS(I);DPI==DP(I);PTI==PT(I)
 2341           ->SHORT CONST %IF MODE=0 %AND PTI=255
 2342           TEST(I) %IF MODE=1 %OR PTI&64#0
 2343           ->INREG %IF DPI<0
 2344           ->NOFIND %IF REG>=0
 2345           %IF MODE=0 %THEN REG=FINDR %ELSE REG=FINDFR
 2346  NOFIND:  X=MODE<<3! (PTI>>2&6)+2
 2347           DUMP(X,REG,DPI,0,BSI) ; ->L98 ;! PICK UP VARIABLE
 2348  INREG:   ->L90 %IF MODE=1
 2349           ->L99 %IF BSI=REG
 2350           ->LOCKED %IF REGISTER(BSI)<0
 2351           ->L99 %IF 0>REG
 2352           REGISTER(BSI)=0
 2353  SWOP:    PRR(X'18',REG,BSI); ->L98
 2354  LOCKED:  REG=FINDR %IF 0>REG; ->SWOP
 2355  L90:      ->L91 %IF BSI=0;             !CURRENTLY CAN LEAVE NOTHING INFR0
 2356           ->L99 %IF BSI=REG %OR 0>REG
 2357  L91:
 2358           REG=FINDFR %IF 0>REG
 2359           PRR(X'38'-EVALUATE,REG,BSI)
 2360           FREG(BSI)=0; ->L98
 2361  SHORT CONST:   REG=FINDR %IF 0>REG
 2362               DUMP(0,REG,DPI,0,0);      !LOAD ADDRESS
 2363  L98:      BSI=REG; DPI=-2
 2364  L99:      %END
 2365           %ROUTINE PLANT(%INTEGER OPCODE,R1,R2)
 2366           !%SHORTROUTINE
 2367           %INTEGER BSR2
 2368           BSR2=BS(R2);R1=BS(R1)
 2369           ->RROP %IF DP(R2)<0
 2370           %IF PT(R2)&24=16 %AND X'5A'<=OPCODE<=X'5B' %THEN   %C
 2371+          OPCODE=OPCODE-16;             ! CAN PLANT HALF LENGTH OP
 2372           PRX(OPCODE,R1,0,BSR2,DP(R2));->L99
 2373  RROP:    PRR(OPCODE-64,R1,BSR2)
 2374           %IF REAL=1 %THEN FREG(BSR2)=0
 2375           %IF REAL=0 %AND REGISTER(BSR2)>0 %THEN REGISTER(BSR2)=0
 2376  L99:      %END
 2377           %ROUTINE TEST(%INTEGER N)
 2378           !%SHORTROUTINE
 2379           %COMMENT INSPECTS OPERAND - MAKES TYPE CONVERSIONS ETC.
 2380           %INTEGER X
 2381           %INTEGERNAME LBASE,LDISP,LPTYPE
 2382           %BYTEINTEGER LPREC
 2383           LPTYPE==PT(N); LDISP==DP(N)
 2384           LBASE==BS(N); LPREC=LPTYPE>>3&3
 2385           ->SHORTCONST %IF LPTYPE=255
 2386           ->START %UNLESS LPTYPE&64 #0 ;! GO UNLESS NAME TYPE
 2387           RP13=R13;R13=LBASE<<12!LDISP
 2388           PRX(X'58',LINK,0,LBASE,LDISP) %UNLESS R13=RP13
 2389           LPTYPE=LPTYPE&31; LBASE=LINK;LDISP=0
 2390  START:   ->FLOATING %IF REAL#0
 2391           ->FINISH %IF LPREC=0 %OR (LPREC=2 %AND 12<=OPCODE<=13)
 2392  PICKUP:  LOAD(N,-1,0)
 2393           LPREC=0; ->FINISH
 2394  SHORTCONST:    LPREC=0; ->PICK UP %IF REAL=0
 2395                 ->INGLA %IF 0<=LDISP<=2;! THESE 3 ALWAYS IN THE GLA
 2396           A(-2)=9; A(-1)=LDISP
 2397           LDISP= SORT CONST(-2,LONGREAL,2);! COMPILE TIME FLOAT
 2398  L1:       LBASE=GLA; ->FINISH
 2399  INGLA:   LDISP= 8*LDISP+40; ->L1
 2400  FLOATING:->FLOAT IT %IF LPTYPE&7=1     ;! INTEGER - RUN TIME FLOAT
 2401           ->FINISH %IF LPREC=3 %OR EVALUATE=0
 2402           %COMMENT MUST STRETCH A 32 BIT REAL
 2403           FREG(LBASE)=1 %IF LDISP<0
 2404           X=FINDFR;PRR(X'2B',X,X);      !FIND AND CLEAR REGISTER
 2405           %IF LDISP<0 %THEN %START
 2406           PRR(X'38',X,LBASE);           ! LER_X,LBASE
 2407           FREG(LBASE)=0;
 2408           %FINISH %ELSE PRX(X'78',X,0,LBASE,LDISP)
 2409           LBASE=X;LDISP=-2; ->FINISH
 2410  FLOATIT: LOAD(N,1,0);PPJ(43); REGISTER(1)=0
 2411           LBASE=0; LDISP=-2
 2412  FINISH:  LPTYPE=(1+REAL)!LPREC<<3
 2413           %IF LONGREAL=1 %AND REAL=1 %THEN LPTYPE=LPTYPE!24
 2414           %END
 2415           %ROUTINE     MULT(%INTEGERNAME RESULT)
 2416           !%SHORTROUTINE
 2417           %INTEGER I,K
 2418           %CYCLE I=1,1,2
 2419           ->L30 %IF PT(I)=255 %AND DP(I)=2
 2420           ->L1 %IF DP(I)<0 %AND REGISTER(BS(I))>=0
 2421  L5:       %REPEAT
 2422           I=1; K=FINDPR
 2423           LOAD(I,K+1,0); ->L11
 2424  L1:       ->L14 %IF BS(I)&1=1 %AND I>0 %AND REGISTER(BS(I)-1)=0
 2425           ->L12 %IF BS(I)&1=0 %AND REGISTER(BS(I)+1)=0
 2426           ->L5
 2427  L12:      K=BS(I); REGISTER(K+1)=1
 2428           PRR(X'18',K+1,K); ->L13
 2429  L14:      REGISTER(BS(I)-1)=1
 2430  L11:      BS(I)=BS(I)-1
 2431  L13:      TEST(3-I); PLANT(X'5C',I,3-I);! MULTIPLY
 2432           ->L15 %IF CHECKSP=0
 2433           PRX(X'8F',BS(I),0,0,32);      ! SLDA ?,32
 2434  L15:      RESULT=257+BS(I)-CHECKSP
 2435           REGISTER(BS(I)+CHECKSP)=0
 2436           AFLAG=CHECKS
 2437           ->L99
 2438  L30:      K= 3-I; LOAD(K,-1,0)
 2439           PRR(X'1A',BS(K),BS(K))
 2440           AFLAG=1; RESULT=256+BS(K)
 2441  L99:      %END
 2442           %ROUTINE     DIV(%INTEGERNAME RESULT)
 2443           !%SHORTROUTINE
 2444           %INTEGER I,K
 2445           ->L3 %IF DP(1)<0
 2446  L1:       K=FIND PR
 2447  L2:       I=1; LOAD(I,K,0); ->L10
 2448  L3:       ->L4 %IF BS(1)&1=0 %AND REGISTER(BS(1)+1)=0
 2449           K=FINDPR; ->L2
 2450  L4:       ->L1 %IF REGISTER(BS(1))<0;    !A CLAIMED REGISTER
 2451           REGISTER(BS(1)+1)=1; K=BS(1)
 2452  L10:      PRX(X'8E',K,0,0,32);          ! SRDA K,32
 2453           TEST(2); PLANT(X'5D',1,2);    ! DIVIDE
 2454           ->L20 %IF CHECKSP=0
 2455           ->L20 %IF OPCODE=17; PRR(X'12',K,K);     ! LTR
 2456           PRX(X'47',7,0,CODER,64);         ! BC 7,64(CODE)
 2457  L20:      REGISTER(K)=0
 2458           AFLAG=0;RESULT=K+257
 2459           %END
 2460           %ROUTINE PRINT ORDERS
 2461           !%SHORTROUTINE
 2462           %SWITCH S(0:49)
 2463           %INTEGER C,D,LAST,KK
 2464           LAST=N0-6
 2465           %CYCLE JJ=NOP,3,LAST
?Non-local
 2466           OPCODE=ST(JJ)
 2467           ->SKIP %IF 10>=OPCODE %OR OPCODE=24
 2468           %IF OPCODE=11 %OR OPCODE=23 %THEN KK=1 %ELSE KK=2
 2469           %CYCLE KK=KK,-1,1
 2470           POP(OPHEAD,C,DP(KK))
 2471           PT(KK)=C>>8; BS(KK)=C&15
 2472           %REPEAT
 2473  SKIP:    ->S(OPCODE+25*REAL)
 2474  S(0):                                  ! INTEGER CONST<4096 IN INT EXP
 2475  S(25):                                 ! INT CONST<4096 IN REAL EXRRN
 2476           D=X'FF00'; C=ST(JJ+2);->L99
 2477  S(1):                                  ! LONG INT CONST IN INT EXPRN
 2478           C=SORT CONST(ST(JJ+1),0,1)
 2479           D=256+GLA;->L99
 2480  S(26):                                 ! LONG ICONST IN EXPRN
 2481           D=512+GLA; D=D+3<<11 %IF LONGREAL=1
 2482           C=SORT CONST(ST(JJ+1),LONGREAL,2);->L99
 2483  S(2):    S(27):                        !LOCAL VARIABLE
 2484           D=ST(JJ+1); C=ST(JJ+2); ->L99
 2485  S(33):                            ! REAL IN FR
 2486           D=ST(JJ+1); C=-2; ->L99
 2487  S(9):    S(34):                        !(INTEGER)  IN G.R.
 2488           D=256+ST(JJ+1); C=-2; ->L99
 2489  S(10):   S(35):                        !PARKED IN CORE
 2490           C=ST(JJ+2);D=ST(JJ+1)
 2491           %IF REAL=1 %AND D>>8&24=24 %THEN PUSH(LWSP(LEVEL),0,C) %ELSE %C
 2492+          PUSH(WSP(LEVEL),0,C); ->L99
 2493  S(11):                                 ! NEGATE IN INTEGER EXPRN
 2494           ->L109 %UNLESS PT(1)=255 %AND DP(1)=1
 2495           AFLAG=0; D=256+GLA; C=16; ->L99 ;! OPTIMISE (-1)
 2496  S(36):                                 ! NEGATE IN REAL EXPRN
 2497  L109:     C=1; D=X'13'+REAL*(32-EVALUATE)
 2498           LOAD(C,-1,REAL)
 2499           AFLAG=1
 2500           PRR(D,BS(1),BS(1));           ! LCR,LCER,LCDR
 2501  L111:     D=(REAL+1+24*LONGREAL)<<8!BS(C)
 2502           C=-2; ->L99
 2503  S(23):                                 !INITIAL NOT
 2504           C=1; AFLAG=2; LOAD(C,-1,0)
 2505           PRX(X'57',BS(1),0,GLA,16); ->L111
 2506  S(12):   S(37):                        !ADDITION
 2507           AFLAG=1;D=X'5A'
 2508  L125:     C=0
 2509  L126:     LOAD(C,-1,REAL); TEST(3-C)
 2510           D=D+REAL*(X'20'-EVALUATE)
 2511           PLANT(D,C,3-C);->L111
 2512  S(13):   S(38):                        !SUBTRACTION
 2513           AFLAG=1; D=X'5B';C=1
 2514           ->L126 %UNLESS REAL=0 %AND PT(2)=255 %AND 1<=DP(2)<=2
 2515           AFLAG=0; LOAD(C,-1,0)
 2516           PRR(6,BS(1),0) %IF DP(2)=2
 2517           PRR(6,BS(1),0);->L111          ;!BCTR TO SUBTRACT 1 OR 2
 2518  S(14):   D=X'57';                      !EXCLUSIVE OR
 2519  L141:     AFLAG=2; ->L125
 2520  S(15):   D=X'56';->L141;                !OR
 2521  S(16):   MULT(D); C=-2; ->L99
 2522  S(17):S(18):   DIV(D); C=-2; ->L99
 2523  S(19):   D=X'54';->L141;                !AND
 2524  S(20):S(21):                           !SLL(21) AND SLR
 2525           D=0
 2526           C=1; LOAD(C,-1,0)
 2527           D=1 %IF PT(2)=255
 2528           C=2; LOAD(C,-1,0) %IF D=0
 2529           PRX(X'89'+OPCODE-21,BS(1),0,BS(2),D*DP(2))
 2530           REGISTER(BS(2))=0 %IF D=0
 2531           C=1; AFLAG=0; ->L111
 2532  S(22):   %CYCLE C=1,1,2
 2533           LOAD(C,-1,0)
 2534           DUMP(1,BS(C),28+4*C,0,GLA)
 2535           REGISTER(BS(C))=0; %REPEAT
 2536           ->L221 %IF REGISTER(0)#0
 2537           C=2; AFLAG=0
 2538           REGISTER(0)=1
 2539           PPJ(15); BS(2)=0; ->L111;      ! RESULT IN R0
 2540  L221:     C=FINDR; D=FINDR; PRR(X'18',C,0)
 2541           PPJ(15); PRR(X'18',D,0); PRR(X'18',0,C)
 2542           REGISTER(C)=0; C=2; AFLAG=0; BS(2)=D; ->L111
 2543  S(39):S(40):S(42):S(44):S(45):S(46):S(48):  !INTEGER OP IN REAL
 2544           FAULT(24);                    ! INTEGER OP IN REAL
 2545           %IF OPCODE=23 %THEN OPCODE=36 %ELSE OPCODE=37;! \ ->L - ...
 2546           ->S(OPCODE);                  ! ! TREAT OTHERS AS +
 2547  S(41):                                 !REAL MULT
 2548           D=X'5C';C=0
 2549  L410:     AFLAG=0; ->L126
 2550  S(43):                                 ! REAL DIVISION
 2551           D=X'5D';C=1;->L410
 2552  S(47):                                 !REAL EXPONENTIATION
 2553           C=1; LOAD(C,-1,1)
 2554           ->L222 %IF PT(2)=255 %AND DP(2)=2;       ! OPTIMISE **2
 2555           PRR(X'38'-EVALUATE,0,BS(1))
 2556           C=2; FAULT(39) %UNLESS PT(2)=255 %OR PT(2)&7<=1
 2557           LOAD(C,1,0); PPJ(36)
 2558           REGISTER(1)=0
 2559           PRR(X'38'-EVALUATE,BS(1),0)
 2560           C=1;->L111
 2561  L222:     PRR(X'3C'-EVALUATE,BS(1),BS(1))
 2562           C=1; ->L111
 2563  L99:      PUSH(OPHEAD,D,C) %UNLESS JJ=LAST
 2564  S(24):S(49): %REPEAT
 2565           DP(1)=C;PT(1)=D>>8;BS(1)=D&15 ;! FINAL RESULT
 2566           %END
 2567  L99:      %END;
?X unused
 2568                 ;               ! OF ROUTINE CSEXP
 2568           %INTEGERFN SORT CONST(%INTEGER P,LONG,TYPE)
 2569           !%SHORTROUTINE
 2570           %LONGREAL CVALUE
 2571           %INTEGER I,K
 2572           ->L50 %IF TYPE=2
 2573  {         FAULT(24) %IF A(P)&7#1   ; ! This is faulting erroneously on the sparc
 2574           %IF A(P)=9 %THEN I=A(P+1) %ELSE FROMAR4(P+1,I)
 2575  L40:      K=N0
 2576           ST(K)=I; N0=N0+1
 2577           %RESULT =K<<2
 2578  L50:      CVALUE=0
 2579           ->L60 %UNLESS A(P)&7=1
 2580           %IF A(P)=9 %THEN I=A(P+1) %ELSE FROMAR4(P+1,I)
 2581           CVALUE=I;->L70
 2582  L60:      FROMAR8(P+1,CVALUE)
 2583  L70:      ->L75 %IF LONG#0
 2584           I=INTEGER(ADDR(CVALUE)); ->L40
 2585  L75:      K=(N0+1)&(-2)
 2586           ST(K)=INTEGER(ADDR(CVALUE))
 2587           ST(K+1)=INTEGER(ADDR(CVALUE)+4)
 2588           N0=K+2
 2589           %RESULT=K<<2
 2590           %END
 2591           %ROUTINE CSTREXP(%INTEGER REG)
 2592           !%SHORTROUTINE
 2593           %COMMENT EVALUATES STRING EXPR USING CURRENT
 2594           %COMMENT WORKAREA AND 1 SUBROUTINES LEAVES ADDR IN
 2595           %COMMENT REG -VE IF STRING MUST BE MOVED TO WK.ARREA
 2596           %INTEGER JJ,QQ,KK,WKAREA,PP
 2597           SETEX %UNLESS STRINST#0
 2598           PP=P
 2599           JJ=TSEXP(QQ); ->L71 %IF JJ=20 %AND REG>=0
 2600           P=PP; REG=|REG|
 2601           WKAREA=GET STR WSP
 2602           PSI(X'92',0,RBASE,WKAREA);    ! CLEAR WORK AREA
 2603           ->L2 %IF A(P)=4
 2604  L1:       FAULT(71)
 2605  L4:       P=PP; SKIP EXP; ->L99
 2606  L5:       FAULT(72); ->L4
 2607  L2:       ->L10 %IF A(P+1)=2
 2608           ->L1 %UNLESS A(P+1)=1          ;!NAME
 2609           P=P+2; CNAME(2,1)
 2610           ->L1 %UNLESS TYPE=5;->L20
 2611  L10:      P=P+2;->L14 %IF A(P)=5
 2612           ->L1 %UNLESS A(P)=9 %AND A(P+1)<127
 2613           ->L11 %IF A(P+1)=0
 2614                 PRX(X'41',1,0,0,A(P+1))
 2615           P=P+2;->L20
 2616  L11:      P=P+2; ->L21;                  ! NULL STRING
 2617  L14:      %COMMENT STRING CONSTANT PUT IN CODE CF (TEXTTEXT)
 2618           KK=(CA+6+A(P+1)-CODEBASE(LEVEL))&(-2)
 2619           QQ=0;->L15 %IF KK<4095
 2620           KK=KK+4;QQ=1
 2621           PRX(X'58',1,GLA,0,PAGENO(KK)<<2)
 2622  L15:      PRX(X'45',1,10,QQ,KK&4095)
 2623           P=P+1; %CYCLE KK=1,1,(A(P)+2)//2
 2624           PLANT(A(P)<<8!A(P+1))
 2625           P=P+2;%REPEAT
 2626  L20:      PRX(X'41',2,RBASE,0,WKAREA)
 2627           PPJ(26)
 2628  L21:      ->L90 %IF A(P)=2;              ! END OF EXPRN
 2629           ->L5 %UNLESS A(P+1)=12
 2630           P=P+1;->L2
 2631  L71:      DUMP(2,REG,K,I,0); ->L99
 2632  L90:      P=P+1
 2633           PUSH(STR WSP(LEVEL),0,WKAREA)
 2634           PRX(X'41',REG,0,RBASE,WKAREA)
 2635  L99:      PTYPE=5; UNPACK; %END
 2636           %ROUTINE     CRES(%INTEGER MODE,LAB)
 2637           %ROUTINESPEC SKIP NAME
 2638           %ROUTINESPEC FAIL(%INTEGER MASK)
 2639           !%SHORTROUTINE
 2640           %INTEGER P1,P2,P3,W,SEXPRN
 2641           %COMMENT MODE=0 UNCONDITIONAL # 0 CONDITIONAL
 2642           %COMMENT ENTER WITH ADDR OF LHS IN R1 AND P ON PLUS''
 2643           SEXPRN=0;W=GET DBLE WRD
 2644           P1=P;->L1 %IF A(P)=4
 2645  L1000:    P=P1;SKIP EXP
 2646           FAULT(74);->L99
 2647  L1:       ->L1000 %UNLESS TYPE=5
 2648           PRR(X'1B',2,2)                ;!SR_2,2
 2649           PRX(X'90',1,2,RBASE,W)        ;!STM_1,2,W(RBASE)
 2650           P2=-1;P=P+2
 2651           ->L10 %IF A(P-1)=3             ;!SUB EXPRESSION
 2652           ->L1000 %UNLESS A(P-1)=1
 2653  L3:       P2=P;SKIP NAME
 2654           ->L50 %IF A(P)=2               ;!END
 2655           ->L1000 %UNLESS A(P+1)=12      ;!ONLY - PERMITTED
 2656           ->L1000 %UNLESS A(P+2)=3; P=P+3
 2657  L10:      CSTREXP(-4);          ! STRING MUST GO TO WK.AREA
 2658                                 ! IN CASE OF SIDE EFFECTS
 2659           SEXPRN=SEXPRN+1
 2660           PRX(X'98',1,2,RBASE,W)
 2661           PPJ(27)
 2662           FAIL(7)
 2663           PRX(X'90',1,2,RBASE,W);       ! SAVE R1 AND R2 FOR LATER
 2664           ->L15 %IF P2<0
 2665           P3=P;P=P2
 2666           CNAME(1,4)
 2667           FAULT(71) %UNLESS TYPE=5
 2668           P=P3
 2669  L12:      ->L1000 %UNLESS A(P)=1 %AND A(P+1)=12 %AND A(P+2)=1
 2670           P=P+3;->L3
 2671  L15:      PSI(X'95',0,4,0)
 2672           FAIL(7);->L12
 2673  L50:      ->L1000 %IF SEXPRN=0
 2674           PRX(X'98',1,2,RBASE,W);       ! SAVE R1 AND R2 FOR LATER
 2675           PPJ(37)
 2676           P3=P;P=P2
 2677           CNAME(1,4)
 2678           FAULT(71) %UNLESS TYPE=5
 2679           P=P3+1
 2680  L99:      PUSH(LWSP(LEVEL),0,W)
 2681           %RETURN
 2682           %ROUTINE SKIP NAME
 2683  L1:       P=P+1;SKIP APP
 2684           P=P+1;%RETURN %IF A(P-1)=2
 2685           P=P+1;->L1
 2686           %END
 2687           %ROUTINE FAIL(%INTEGER MASK)
 2688           %IF MODE=0 %THEN PRX(X'47',MASK,0,CODER,152) %ELSE %C
 2689+ P LOCAL JUMP(MASK,LAB)
 2690           %END
 2691           %END
 2692           %ROUTINE CCOND(%INTEGER IU,NEARLAB,FARLAB)
 2693                 %COMMENT IU=0 FOR IF =1 FOR UNLESS
 2694                 %ROUTINESPEC CCC
 2695           %ROUTINESPEC CSC(%INTEGERNAME FLAB)
 2696           %COMMENT  P ON ALT OF (SC)
 2697           %INTEGER T,C,FAILPT,BASE,DISP
 2698           %INTEGER JNPORFP,TP,CLAUSES
 2699           CLAUSES=0
 2700           T=A(P+1+A(P+1))
 2701           T=0 %IF T=3;                  !0=SC  1=%AND 2=%OR
 2702           TP=T ; TP=TP+1 %IF T=0
 2703           %IF IU!!(TP-1)=0 %THEN JNPORFP=FARLAB %ELSE JNPORFP=NEARLAB
 2704           FAILPT = 0; CCC ;  ->L99
 2705                 %ROUTINE CCOMP(%INTEGER C)
 2706           !%SHORTROUTINE
 2707                 ! C=1 FIRST TIME, 2 SECOND
 2708           %INTEGER M,L,Q,R,T
 2709           %OWNBYTEINTEGERARRAY FCOMP(1:7)=8,10,2,7,12,4,7;
 2710           %OWNBYTEINTEGERARRAY BCOMP(1:7)=8,12,4,7,10,2,7;
 2711           %SWITCH SW(-10:2)
 2712           M=A(P)
 2713           P=P+1; ->SW(C) %UNLESS M=8
 2714           FAULT(73); SKIP EXP; ->L1
 2715  SW(-10):                               ! FIRST OPERAND SIMPLE STRING
 2716           CSTREXP(1); NEST=1; DUMP(2,2,DISP,0,BASE); ->L161
 2717  SW(-9):  T=P; R=TSEXP(Q)
 2718           ->REG1 %IF R=10 %AND A(P)=2
 2719           ->REG2 %IF R=11 %AND A(P)=2
 2720           P=T; CSEXP(0,0)
 2721           ->REG3 %IF TYPE=2
 2722           PRR(X'19',DISP,NEST); ->L20;   !CR
 2723  REG1:    Q=X'59'; ->RCOM
 2724  REG2:    Q=X'49'
 2725  RCOM:    PRX(Q,DISP,0,I,K); ->L20;      !C OR CH
 2726  REG3:    PRR(X'18',1,DISP); ->L37 ;     !TO FLOAT ETC
 2727  SW(-5):                                !FIRST OPERAND LONG REAL
 2728           CSEXP(0,3); Q=X'69';          ! COMPILE LONG
 2729  L51:      PRX(Q,NEST,0,BASE,DISP); ->L21
 2730  SW(-4):                                !FIRST OPERAND SHORT REAL
 2731           Q=X'79'; CSEXP(0,2)
 2732  L40:      ->L51 %IF PREC=0;              !SHORT EXPRESSION
 2733           PRR(X'2B',0,0)
 2734           PRX(X'78',0,0,BASE,DISP);     !STETCH IST OPN
 2735           PRR(X'29',0,NEST); ->L20
 2736  SW(-3):                                !FIRST OPERAND ASHORT CONSTANY
 2737           CSEXP(0,0)
 2738           ->L30 %IF VALUE=0
 2739           ->L36 %IF TYPE=2
 2740           R=2
 2741           R=1 %IF NEST=2
 2742           DUMP(0,R,VALUE,0,0);          !LOAD ADDR FOR CONSTANT
 2743  L29:      PRR(X'19',R,NEST); ->L20;      !CR2,1
 2744  L30:                                    !COMPARISONS WITH ZERO
 2745           ->L35 %IF TYPE=5
 2746           ->L32 %IF AFLAG=1
 2747           ->L31 %IF TYPE=2
 2748           ->L32 %IF AFLAG=2 %AND 7<=FCOMP(M)<=8
 2749  L31:      PRR((TYPE-1)*(2-PREC&1)*16+X'12',NEST,NEST);   !LTR,LTER,LTDR
 2750  L32:      ->L21 %IF C=-3; ->L20
 2751  L35:      PSI(X'95',0,NEST,0); ->L20;    ! NULL STRING LENGTH=0
 2752  L36:      DUMP(0,1,VALUE,0,0);
 2753  L37:      PPJ(43);
 2754           PRR((1-PREC&1)*16+X'29',0,NEST);        ! CDR OR CER
 2755           ->L20
 2756  SW(-2):  Q=X'49';                      !OPERAND SHORT
 2757  L24:      CSEXP(0,0); ->L25 %IF TYPE=2
 2758            PRX(Q,NEST,0,BASE,DISP); ->L21;          ! C OR CH
 2759  L25:      R=2; R=6 %IF Q=X'49';         ! HERE FOR REALS
 2760  L26:      DUMP(R,1,DISP,0,BASE); ->L37
 2761  SW(-1):  ! FIRST OPERAND A BYTE
 2762           T=P; R=TSEXP(Q); L=1
 2763           ->L18 %IF R=11 %AND A(P)=2
 2764           ->L19 %IF R=1 %AND A(P)=2
 2765           P=T;CSEXP(0,0); ->L14 %IF TYPE=2
 2766           R=2; R=1 %IF NEST=2
 2767           DUMP(4,R,DISP,0,BASE); ->L29
 2768  L14:      R=4; ->L26
 2769  L18:      PSS(X'D5',L,BASE,DISP,I,K); ->L20;       ! CLC COMPARISONS
 2770  L19:      PSI(X'95',Q,BASE,DISP);->L20;  !CLI FOR BYTE/INTEGER
 2771  SW(0):                                 !FIRST OPERAND INTEGER
 2772           T=P; R=TSEXP(Q); L=4
 2773           ->RSTORE %UNLESS R=10 %AND A(P)=2
 2774           ->L18 %IF 7<=FCOMP(M)<=8
 2775  RSTORE:  P=T; Q=X'59'; ->L24
 2776  SW(1):                                 !FIRST OPERAND EXPRESSION
 2777  SW(2):                                 !2ND HALT OF DOUBLE SEDED
 2778           T=P; PTYPEP=PTYPE; R=TSEXP(VALUE)
 2779           PTYPE=PTYPEP;UNPACK
 2780           ->L30 %IF R=1 %AND VALUE=0 %AND(A(P)=2 %OR C=2)
 2781           ->L160 %IF TYPE=5
 2782           ->L150 %IF TYPE=2
 2783           ->L120 %IF R=0 %OR 14<=R<=15 %OR(A(P)=1 %AND C=1)
 2784           ->L130 %IF UNASS=1 %OR R=100 %OR R=11 %OR R<=2
 2785           ->L131 %IF R=50;               ! REGISTER VARIABLE
 2786           Q=X'59'; Q=X'49' %IF R=12
 2787           PRX(Q,NEST,0,I,K); ->L20
 2788  L130:     !1ST OPND INTEGER IN NEST-2ND OPN SIMPLE INTEGER EXPRN
 2789           R=NEST; REGISTER(R)=1 %IF REGISTER(R)=0
 2790           P=T; CSEXP(0,1)
 2791           REGISTER(R)=0 %IF REGISTER(R)>0; ->L29
 2792  L131:      PRR(X'19',NEST,K); ->L20
 2793  L120:     !1ST OPND INTEGER EXPRN IN NEST-SECOND OPND UNKNOWN
 2794           Q=PARK(NEST); P=T
 2795           CSEXP(0,0); ->L122 %IF TYPE=2
 2796           UNPARK(X'59',NEST,Q); ->L21
 2797  L122:     UNPARK(X'58',1,Q); ->L37;       ! TO FLOAT FIRST OPERAND
 2798  L150:     P=T; Q=PARKF(NEST,PREC);      !
 2799           ->L155 %IF PREC=0
 2800           CSEXP(0,3);                   !1ST OPND LONG REAL EXPR
 2801           PUSH(LWSP(LEVEL),0,Q)
 2802           BASE=RBASE
 2803           DISP=Q; Q=X'69'; ->L51
 2804  L155:     CSEXP(0,2);                   !1ST OPND SHORT REAL EXPRN
 2805           PUSH(WSP(LEVEL),0,Q)
 2806           BASE=RBASE;DISP=Q
 2807           Q=X'79'; ->L40
 2808  L160:     %COMMENT 1ST OPERAND A STRING EXPRESSION PTR IN NEST
 2809           P=T; POP(STR WSP(LEVEL),R,T);! RMEOVE WKAREA WITH STRING%C
 2810  !FROM FREE LIST TO PREVENT CORRUPTION
 2811           R=PARK(NEST)
 2812           CSTREXP(1); NEST=1
 2813           UNPARK(X'58',2,R)
 2814           PUSH(STR WSP(LEVEL),0,T)
 2815  L161:     ->L162 %UNLESS 7<=FCOMP(M)<=8; ! OPTIMISE = & \=
 2816           PRX(X'43',3,0,1,0);           ! IC TO SET UP FOR EX
 2817           PRX(X'44',3,0,GLA,STRINST+6); ->L20;     ! EX_3,COMPARISON
 2818  L162:     PPJ(35);                      ! GO TO SUBROUTINE FOR COMPARISON
 2819  L20:      MASK=FCOMP(M); ->L1;           ! MASK FOR NORMAL COMPARISON
 2820  L21:      MASK=BCOMP(M);                ! BACKWARDS COMPARISON
 2821  L1:             %END
 2822           %ROUTINE CCC
 2823           !%SHORTROUTINE
 2824           %INTEGER LINE,FLAB
 2825           CSC(FLAB)
 2826           C=A(P) ; P=P+1
 2827           CLAUSES=CLAUSES+1
 2828           ->L10 %IF T=0       %OR(CLAUSES>1 %AND C=2)
 2829           ->L2 %IF FAILPT#0
 2830           FAILPT=1 ; LINE=1 ; ->L3
 2831  L2:       LINE=0
 2832  L3:
 2833           PLOCAL JUMP(MASK,JNPORFP)
 2834           %UNLESS FLAB=0 %THEN %START
 2835           PUSH(LOCAL LABEL,CA,FLAB)
 2836           R13=0 %UNLESS R13=SAVE13 %AND CHNGE13=0
 2837           %FINISH
 2838           CCC;                          !FIX NEXT CLAUSE
 2839           ->L10 %IF LINE=0
 2840           MASK=MASK!!15 %IF JNPORFP=NEARLAB
 2841  L10:      %END
 2842           %ROUTINE CSC(%INTEGERNAME FLAB)
 2843           !%SHORTROUTINE
 2844           %INTEGER LINE,Q,R,S,TP,NEAR
 2845           FLAB=0
 2846           S=A(P+1+A(P+1))
 2847           LINE=S
 2848           NEAR=NEARLAB
 2849           ->START %IF T=0 %OR(S=2 %AND CLAUSES>0)
 2850           PLABEL=PLABEL-1; NEAR=PLABEL
 2851  START:   ->L1 %IF A(P)=1
 2852           P=P+2
 2853           ->REDUND %IF T=0
 2854           ->REDUND2 %IF T=A(P+1+A(P+1))
 2855           FLAB=NEAR %UNLESS NEAR=NEARLAB
 2856           TP=T-1; ->LAST %IF NEAR=NEARLAB
 2857           CCOND(TP,NEAR,FARLAB); ->L9
 2858  REDUND:CCOND(IU,NEARLAB,FARLAB); ->L9
 2859  REDUND2: CCOND(IU,NEARLAB,FARLAB)
 2860           MASK=MASK!!15 %IF JNPORFP=NEARLAB       ;->L9
 2861  LAST:    CCOND(IU,NEAR,FARLAB)
 2862           NEARLAB=0; ->L9
 2863  L1:       %COMMENT CLASSIFY SIMPLE CONDITION AND ACT ACCORDINGLY
 2864           P=P+2; S=P; SKIP EXP
 2865           ->L21 %IF A(P)=8;              ! RESOLUTION (ALL OCCURRENCES)
 2866           P=P+1; Q=TSEXP(R);            ! TEST MIDDLE OPERAND FIRST
 2867           %IF TYPE=3 %THEN %START
 2868           P=P+2; R=COPY RECORD TAG; %FINISH
 2869           ->STR %IF TYPE=5
 2870           ->ZERO %IF Q=1 %AND R=0 %AND A(P)=2;! ! NOT DOUBLE SIDED
 2871           P=S; Q=TSEXP(R);              ! TEST LHS
 2872           ->CONST %IF 1<=Q<=2
 2873           ->SIMPLE %IF Q=20
 2874           ->REGVAR %IF Q=50
 2875           ->STR %IF TYPE=5
 2876           ->NORMAL %UNLESS UNASS=0 %AND 10<=Q<=15
 2877  SIMPLE:  BASE=I; DISP=K; CCOMP(10-Q); ->L8
 2878  REGVAR:  DISP=K; CCOMP(-9); ->L8
 2879  STR:     P=S; CSTREXP(1); NEST=1; CCOMP(1); ->L8
 2880  CONST:   VALUE=R; CCOMP(-3); ->L8
 2881  L21:      P=S+2; ->L22 %UNLESS A(S)=4 %AND A(S+1)=1
 2882           CNAME(2,1)
 2883           ->L23 %IF A(P)=2 %AND TYPE=5
 2884  L22:      P=S; SKIP EXP
 2885  L28:      P=P+1; SKIP EXP
 2886           FAULT(73); ->L8
 2887  L23:      P=P+2
 2888           FLAB=NEAR %UNLESS NEAR=NEARLAB
 2889           %IF T#2 %THEN R=JNPORFP %ELSE %START
 2890           %IF JNPORFP#FARLAB %AND LINE=2 %AND CLAUSES>0  %C
 2891+          %THEN R=FARLAB %ELSE R=NEAR
 2892           %FINISH
 2893           CRES(1,R)
 2894           ->L28 %UNLESS A(P)=2           ;! NO DOUBLE SIDED RESOLUTION
 2895           P=P+1;
 2896           MASK=15; ->L10
 2897  ZERO:    P=S; Q=TSEXP(R); ->SIMPLE %IF Q=11;    ! CLI FOR BYTE/ZERO
 2898           ->STR %IF TYPE=5
 2899  NORMAL:  P=S; CSEXP(0,0); CCOMP(1)
 2900  L8:       P=P+1
 2901                 ->L10 %IF A(P-1)=2;      ! GO UNLESS DOUBLESIDED
 2902           FLAB=NEAR %UNLESS NEAR=NEARLAB
 2903           ->ORCOND %IF T=2
 2904           R=JNPORFP; ->L7
 2905  ORCOND:  %IF JNPORFP#FARLAB %AND LINE=2 %AND CLAUSES>0 %THEN %C
 2906+ R=FARLAB %ELSE R=NEAR
 2907  %COMMENT LAST DOUBLESIDED IN OR CONDITION IS SPECIAL
 2908  L7:
 2909           PLOCAL JUMP(MASK!!15,R)
 2910           CCOMP(2)
 2911  L10:      MASK=MASK!!15 %IF T=1 %OR(T=0 %AND IU=0)
 2912  L9:       %END
 2913  L99:           %END                    ;!OF CCOND
 2914           %ROUTINE FILL LOCAL JUMPS
 2915           !%SHORTROUTINE
 2916           %INTEGER T,C,J
 2917  L1:       POP(LOCAL JUMP,T,C)
 2918           ->L98 %IF T=-1
 2919           J=FIND(C,LOCAL LABEL)
 2920           FAULT(233) %IF J=-1
 2921           J=J-LOCAL ADDR
 2922           PLUG(T+2,J); ->L1
 2923  L98:      CLEAR LIST(LOCAL LABEL)
 2924           %END
 2925           %ROUTINE P LOCAL JUMP(%INTEGER MASK,LABEL)
 2926           !%SHORTROUTINE
 2927           %RETURN %IF MASK=0
 2928           CHNGE13=1 %UNLESS SAVE13=R13
 2929           ->L1 %IF LABEL>21000
 2930           PJ(MASK,LABEL); ->L99
 2931  L1:       ->L2 %UNLESS LOCAL BASE=0
 2932           LOCAL BASE=10; LOCAL ADDR=CODEBASE(LEVEL)
 2933           ->L2 %IF SBFLAG=1 %OR 3000+800*COMPILER>CA-CODEBASE(LEVEL)
 2934           LOCAL BASE=FIND PP
 2935           FAULT(231) %IF LOCAL BASE<=0
 2936           PRR(5,LOCAL BASE,0); LOCAL ADDR=CA
 2937  L2:       PUSH(LOCAL JUMP,CA,LABEL)
 2938           PRX(X'47',MASK,LOCAL BASE,0,0)
 2939  L99:      %END
 2940           %ROUTINE     CSNAME(%INTEGER Z,REG)
 2941           %INTEGERARRAY B(0:5)
 2942           %OWNBYTEINTEGERARRAY PLABEL(0:45)=9,9,3,3,
 2943+                1,14(3),2,3,1,18,4,3,12(2),
 2944+          33,42,34,35,32,12(16),5,12(8);
 2945           %OWNBYTEINTEGERARRAY MODE(0:45)=16(2),
 2946+          0(3),16(3),2,16(2),31,32,0,
 2947+          18,31,18(3),63,47,23(2),18,31(7),
 2948+          31,23(2),47(2),18,16,2,23,16(2),
 2949+          23,0(3);
 2950           ! TOP 4 BITS OF MODE = NO OF PARAMS BOTTOM 4 ALLOWED Z VALUE
 2951           %SWITCH SW(0:45)
 2952           %INTEGER PL,KK,PP,V,JJ
 2953           KK=K; JJ=COUNTAPS
 2954           PL=PLABEL(KK); PP=P+1; V=MODE(K)
 2955           P=P+1; P=P+1 %IF V>>4#0
 2956           ->L1010 %IF V&15=15
 2957           ->L1001 %IF V>>4#JJ; V=V&15
 2958           ->L1002 %IF V=0 %AND Z#0;      ! ROUTINE CALL IN EXPRESSION
 2959           ->L1003 %IF V=2 %AND Z#2;      ! FN CALLED INCORRECTLY
 2960           ->L1005 %IF Z=0 %AND V#0
 2961  L1010:    ->SW(KK)
 2962  L1001:    FAULT(19); PRINTNAME(FNAME)
 2963  L1000:    P=PP; SKIP APP; P=P-1; ->L99
 2964  L1002:    FAULT(23); ->L1000
 2965  L1003:    FAULT(29); ->L1000
 2966  L1004:    FAULT(22); ->L1000
 2967  L1005:    FAULT(17); ->L1000
 2968  L1:       PPJ(PL); ->L99
 2969  SW(4):   CIOCP(1); ->L99;               ! SKIP SYMBOL
 2970  SW(2):   V=10;                         ! NEWLINE
 2971           PRX(X'41',1,0,0,V)
 2972  L23:      CIOCP(3); ->L99
 2973  L21:      PRX(X'41',1,0,0,V); ->L1
 2974  SW(3):   V=32; ->L21;                   ! SPACE
 2975  SW(5):   V=0;                          ! RUNOUT
 2976  L51:      CSEXP(2,1); ->L21
 2977  SW(6):   V=10; ->L51;                   ! NEWLINES(N)
 2978  SW(7):   V=32; ->L51;                   ! SPACES(N)
 2979  SW(0):SW(1):                           ! SELECT INPUT AND OUTPUT
 2980           CSEXP(1,1); CIOCP(KK+8)
 2981           ->L99
 2982  SW(9):                                 ! PRINTSYMBOL
 2983           CSEXP(1,1); ->L23
 2984  SW(8):   CIOCP(2);                     ! NEXT SYMBOL
 2985  L81:      %UNLESS REG=1 %THEN PRR(X'18',REG,1)
 2986  L82:      PTYPE=10001;UNPACK; ->L99
 2987  SW(10):  CIOCP(1);                     ! READ SYMBOL
 2988  L106:     ->L1004 %UNLESS A(P)=4 %AND A(P+1)=1
 2989           P=P+2; COPYTAG(A(P)); UNPACK
 2990           ->L104 %UNLESS TYPE=1 %AND ARR=0 %AND ROUT=0
 2991           CNAME(1,1)
 2992  L102:     ->L1004 %UNLESS A(P)=2; P=P+1; ->L99
 2993  L104:     PLANT(X'1841'); REGISTER(4)=1
 2994           CNAME(1,4); REGISTER(4)=0
 2995           ->L1004 %UNLESS TYPE=1; ->L102
 2996  SW(11):                                ! READ
 2997           B(0)=1; B(1)=1000
 2998  L110:     JJ=10000; ->L1004 %IF 0#Z#13; ->L302
 2999  SW(12):                                ! WRITE
 3000           CSEXP(1,1); P=P+1
 3001           JJ=P; V=TSEXP(KK)
 3002           ->L121 %UNLESS V=0
 3003           V=PARK(1); CSEXP(2,1)
 3004           UNPARK(X'58',1,V)
 3005  L120:     PPJ(PL); ->L99
 3006  L121:     P=JJ; REGISTER(1)=1
 3007           CSEXP(2,1); REGISTER(1)=0; ->L120
 3008  SW(13):                                ! NEWPAGE
 3009           PRX(X'41',1,0,0,12);          ! LA 0,12
 3010           CIOCP(5); ->L99
 3011  SW(14):  ->L1004 %UNLESS A(P)=4 %AND A(P+1)=1;! ADDR
 3012           P=P+2
 3013           CNAME(3,REG); ->L1004 %UNLESS A(P)=2
 3014           P=P+1; ->L82
 3015  SW(16):                                ! INT
 3016  SW(17):                                ! INTPT
 3017           CSEXP(0,3)
 3018           PRR(X'28',0,NEST)%UNLESS NEST=0
 3019           PPJ(PL); ->L81
 3020  SW(18):        CSEXP(6,3)      ;       ! FRACPT
 3021                 PCLOD(32);              !INSERT FRACPT SR IN LINE
 3022           PRR(X'28',REG,2) %UNLESS REG=2
 3023           PTYPE=10032; UNPACK; ->L99
 3024  SW(19):                                ! PRINT
 3025           B(0)=3;B(3)=1
 3026  L191:     B(1)=32;B(2)=1;->L110
 3027  SW(20):                                ! PRINTFL
 3028           QPREAL=N0<<2+4
 3029           B(0)=2;->L191
 3030  SW(39):  JJ=11032; ->L210;              ! LONGREAL
 3031  SW(21):  JJ=11002;                     ! REAL
 3032  L210:     CSEXP(0,1); P=P+1
 3033           ->L212 %UNLESS NEST=0
 3034           PLANT(X'1810'); NEST=1
 3035  L212:     PTYPE=JJ; UNPACK; ->L99
 3036  SW(22):  JJ=11001; ->L210;              ! INTEGER
 3037  SW(23):  CSEXP(REG,3);                 ! MOD
 3038           PRR(X'20',REG,REG); ->L99;     ! LPDR
 3039  SW(25):SW(26):SW(27):                  ! SQRT,LOG,SIN
 3040  SW(28):SW(29):SW (30):                 ! COS,TAN,EXP
 3041           B(0)=1
 3042  L301:     B(1)=32;JJ=10032;
 3043           ->L1004 %IF 2#Z#13
 3044  L302:     REDEFINE EP(JJ,B)
 3045           CNAME(Z,REG);P=P-2;->L99
 3046  SW(31):  ! MAP RECORD
 3047           CSEXP(REG,1); FAULT(84) %UNLESS Z=15
 3048           PTYPE=3; UNPACK
 3049           ->L99
 3050  SW(32):  JJ=11011; ->L210;              ! BYTEINTEGER
 3051  SW(33):  JJ=11021; ->L210;              ! SHORT INTEGER
 3052  SW(34):SW(35):                         !RADIUS & ARCTAN
 3053           B(0)=2; B(2)=32; ->L301
 3054  SW(36):                                ! %INTEGERFN PARITY
 3055                 CSEXP(REG,1)
 3056                 PRX(X'89',REG,0,0,31);  ! SLL REL,31
 3057                 PRX(X'8A',REG,0,0,30);  ! SRA REG,30
 3058                 PRX(X'5B',REG,0,GLA,16);! S_REG,,=F'-1'
 3059           ->L99
 3060  SW(37):  CSTREXP(1); CIOCP(7); ->L99;   ! PRINT STRING
 3061  SW(38):  PRX(X'41',REG,0,0,10); ->L82
 3062  SW(40):                                ! PRINTCH
 3063           CSEXP(1,1); CIOCP(5); ->L99
 3064  SW(41):                                ! READ CH
 3065           CIOCP(4); ->L106
 3066  SW(42):  JJ=11005; ->L210;              ! STRING
 3067  L99:      %END
 3068           %ROUTINE     CIOCP(%INTEGER N)
 3069           PRX(X'41',0,0,0,N);           ! LA 0,N
 3070           PRX(X'90',4,1,11,16);         ! STM 4,1,16(11)
 3071           PRX(X'98',12,14,GLA,140);     ! LM 12,14,=V(IOCP)
 3072           PRR(X'05',15,14);             ! BALR 15,14
 3073           R13=0
 3074           %END
 3075           %ROUTINE     CANAME(%INTEGER Z,BS,DP,CLINK,BSRF,DPRF)
 3076           ! BS& DP FOR ARRAY HEAD BSRF & DPRF POINT TO MULTIPLIER
 3077           ! IN RECORD FORMAT FOR RECORD ARRAYS LINK POINTS TO LP CELL HOLDING
 3078           ! DIMENSION OF ARRAY IN CASE THIS HAS TO BE DEDUCED & INSERTED
 3079           !%SHORTROUTINE
 3080           %SWITCH S(0:3)
 3081           %INTEGER PTYPEP,KK,RR,PP,JJ,JJJ
 3082           %INTEGER KKK,DIS,Q,PRECP,CHECKSP
 3083           %INTEGER BASEREG,ARRP,BASIC DISP
 3084           CHECKSP=CHECKS; CHECKSP=1 %IF TYPE=0; ! NO TYPE MUST GO TO PERM
 3085           PP=P; BASEREG=LINK
 3086           %IF INREG#0 %THEN %START
 3087           CHECKSP=0 %IF TYPE#0; BASEREG=INREG
 3088           %FINISH
 3089           JJ=J; PTYPEP=PTYPE
 3090           ARRP=ARR
 3091           Q=COUNT APS; ->L1 %UNLESS JJ=0
 3092           FROM1(CLINK,JJ)
 3093           REPLACE1(CLINK,JJ!Q); JJ=Q
 3094  L1:       ->L4 %IF JJ=Q#0
 3095           FAULT(19); PRINTNAME(FNAME)
 3096           P=P+1; SKIP APP; ->L99
 3097  L4:
 3098           %IF ARRP=2 %THEN FROM LIST(K,BASIC DISP,DP)
 3099           ->L12 %UNLESS CHECKSP=0 %AND JJ=1 %AND Z#3
 3100           ->L12 %UNLESS 2>=TYPE
 3101           PRECP=PREC; KKK=0; P=PP+2; JJJ=TSEXP(KKK)
 3102           %IF 3<=JJJ<=99 %THEN DIS=0 %ELSE DIS=KKK*BYTES(PRECP)
 3103           ->L12 %IF DIS>4095 %OR (ARRP=2 %AND DIS+BASIC DISP>4095)
 3104           ->REGVAR %IF JJJ=50 %AND PRECP=1
 3105           ->RDISP %IF JJJ=101
 3106           ->CONST %IF 1<=JJJ<=2
 3107           ->L12 %UNLESS JJJ=100
 3108           DUMP(2+2*PREC,1,K,0,I); P=P+1; ->L9
 3109  REGVAR:  JJJ=K; P=P+1; ->L8;            !CAN ONLY OPTIMISE BYTES
 3110  RDISP:   ->REGVAR %IF PRECP=1
 3111           PRR(X'18',1,K); P=P+1; ->L9
 3112  L12:      P=PP+2; DIS=0
 3113           ->L21 %UNLESS JJ=1
 3114           CSEXP(1,1);P=P+1
 3115           ->L10 %IF CHECKSP=1
 3116  L9:       JJJ=1
 3117  L8:       %IF BASEREG#LINK %THEN ->L5
 3118           ->VECTOR %IF ARRP=2
 3119           RP13=R13; R13=BS<<12!DP
 3120           PRX(X'58',LINK,0,BS,DP) %UNLESS R13=RP13; ! ADDR A0
 3121           ->L5
 3122  VECTOR:  DIS=DIS+BASIC DISP; BASEREG=BS
 3123  L5:       PTYPE=PTYPEP; UNPACK
 3124           ->L6 %IF JJJ=0
 3125           ->STR %IF TYPE=5
 3126           ->S(PREC) %UNLESS TYPE=3;     ! RECORDS
 3127  L3:       PRX(X'4C',1,0,BSRF,DPRF); ->L6
 3128  STR:     PRX(X'58',2,0,BS,DP+8);       ! ADDR OF DV
 3129           BSRF=2; DPRF=2; ->L3
 3130  S(3):                                  !LONG REAL
 3131  S(0):    ! %INTEGER
 3132                 PCONST(X'89100002'! PREC); ->L6;   ! SLL 1,2 OR 3
 3133  S(2):    ! %SHORT
 3134                 PLANT(X'1A11');         ! AR 1,1
 3135  S(1):L6:  DISP=DIS; INDEX=JJJ; BASE=BASEREG; ->L99
 3136  CONST:   JJJ=0; P=P+1;                 ! 1 D WITH A CONSTANT SUFFIX
 3137           ->L8
 3138  L10:      ! 1 DIMENSION PLUS CHECKS
 3139           DUMP(0,3,DP,0,BS);         ! ADDR ARRAYHEAD
 3140           PPJ(22+JJ); JJJ=1;            ! PERM CHECKS BOUNDS AND SHIFTS
 3141  L11:      PTYPE=PTYPEP; UNPACK
 3142           ->L6
 3143  L21:      ! TWO DIMENSIONS
 3144           ->L31 %UNLESS JJ=2 %AND CHECKSP=0
 3145           CSEXP(2,1);JJJ=2;P=P+1
 3146           KK=P;Q=TSEXP(PP);P=KK
 3147           ->L22 %UNLESS Q=0
 3148           JJJ=PARK(2)
 3149  L22:      CSEXP(1,1);P=P+1
 3150           PRX(X'4C',1,0,BS,DP+14);      ! MH 1,MULTIPLIER
 3151           UNPARK(X'5A',1,JJJ);          !ADD 1ST SUFFIX
 3152           ->L9
 3153  L31:      !MULTIDIMENSION - ALWAYS VIA PERM
 3154           RR=GET ARR WSP
 3155           %CYCLE PP=0,1,JJ-1
 3156           CSEXP(0,1);P=P+1
 3157           DUMP(1,NEST,RR+PP<<2,0,RBASE)
 3158           %REPEAT
 3159           DUMP(0,1,RR+PP<<2,0,RBASE);   !LA  1,2
 3160           DUMP(0,2,DP,0,BS)             ;!LA  2,ARRAY HEAD
 3161           PPJ(24);JJJ=1;
 3162           PUSH(MDARR(LEVEL),0,RR)       ;!FREE WORK SPACE
 3163           ->L11
 3164  L99:      J=JJ; %END
 3165           %ROUTINE     CENAME(%INTEGER Z,MODE,BS,DP)
 3166           !%SHORTROUTINE
 3167           %COMMENT MODE=0 POINTER TO RECORD IN CORE AT BS & DP
 3168           %COMMENT MODE=1 POINTER TO RECORD IN REGISTER BS DP RUBBISH
 3169           %COMMENT MODE=2 RECORD REG CLAIMED
 3170  ! P POINTS TO (ENAME)***** FNAME HOLD FORMAT NAME
 3171           %INTEGER Q,QQQ,BSRF,DPRF
 3172           ->L2 %IF A(P)=1
 3173           ->L1 %IF Z>=14; FAULT(64)
 3174            P=P-2
 3175           PTYPE=1; UNPACK; ->L99
 3176  L1:       BASE=BS; DISP=DP
 3177           DISP=-1 %IF MODE#0
 3178           INDEX=0; ->L99
 3179  L2:       P=P+1; Q=DISPLACEMENT(FNAME); UNPACK
 3180           ! K POINTS TO CELL HOLD ING DETAILS FOR THOS CELL
 3181           ->L98 %IF Q=-1; ->L50 %IF TYPE =3
 3182           ->L20 %IF ARR=1
 3183           ->L30 %IF TYPE=5
 3184           ->L11 %IF MODE#0
 3185           RP13=R13; R13=BS<<12!DP
 3186           PRX(X'58',LINK,0,BS,DP) %UNLESS R13=RP13
 3187           BASE=LINK
 3188  L7:       INDEX=0; DISP=Q
 3189           %IF ROUT=1 %THEN FROM1(Q,DISP); ->L99
 3190  L11:      BASE=BS; ->L7
 3191  L20:      ! DEAL WITH ARRAY IN RECORD
 3192           FROM LIST(FNAME,BSRF,QQQ)
 3193           BSRF=BSRF>>4&15
 3194           FROM1(QQQ,DPRF)
 3195           ->L21 %IF Z<10 %OR A(P+1)=1; K=DPRF+Q
 3196           I=BSRF;                       ! SS5V1
 3197           DUMP(2,1,DP,0,BS) %IF MODE=0; ->L99;    ! R1 NOW POINTS TO REORD
 3198  L21:      ->L22 %UNLESS MODE=0 %AND BS<4;! WILL POINTER BE DESTROTED?
 3199           DUMP(2,1,DP,0,BS); MODE=1; BS=1;        ! YES-- SO SAVE IT
 3200  L22:      QQQ=PARK(1) %IF MODE=1
 3201           CANAME(3,BSRF,DPRF+Q,K,0,0)
 3202           R13=0
 3203           %IF MODE=0 %THEN PRX(X'5A',INDEX,BS,0,DP)
 3204           %IF MODE=1 %THEN UNPARK(X'5A',INDEX,QQQ)
 3205           %IF MODE=2 %THEN PRR(X'1A',INDEX,BS)
 3206           I=BSRF; K=DPRF+Q
 3207           ->L99
 3208  L30:      FROMLIST(FNAME,BSRF,QQQ)
 3209           FROM1(QQQ,DPRF); BSRF=BSRF>>4&15
 3210           PRR(X'18',1,BS) %IF MODE#0 %AND BS#1
 3211           PRX(X'58',1,BS,0,DP) %IF MODE=0
 3212           PRX(X'5A',1,BSRF,0,DPRF+Q)
 3213           BASE=1; INDEX=0; DISP=0
 3214           I=BSRF; K=DPRF+Q; ->L99
 3215  L50:      ! RECORDNAME IN RECORD--Q POINTS TO SIDECHAIN
 3216           DUMP(2,1,DP,0,BS) %IF MODE=0;! LOAD PTR TO FIRST RECORD
 3217           PRR(X'18',1,BS) %IF MODE#0
 3218           FROM2(Q,QQQ)
 3219           CRNAME(Z,1,K,1,QQQ); ->L99
 3220  L98:      P=P+1; SKIP APP; P=P-2
 3221  L99:      %END
 3222           %ROUTINE     CRNAME(%INTEGER Z,MODE,CLINK,BS,DP)
 3223           !%SHORTROUTINE
 3224  %COMMENT DEALS WITH RECORD NAME CALLING CENAME TO COMPILE SUBFIELDS
 3225           %COMMENT MODE=0 POINTER TO RECORD IN CORE AT BS & DP
 3226           %COMMENT MODE=1 POINTER TO RECORD IN REGISTER BS DP RUBBISH
 3227  %COMMENT CLINK POINTS TO CELL CONTAING NAME DETAILS
 3228           %INTEGER KK,JJ,Q,QQ
 3229           FROM2(CLINK,Q)
 3230           FROM1(Q,FNAME)
 3231           ->L50 %IF ARR=0
 3232           I=BS; K=DP;
 3233           ->L99 %IF 11<=Z<=12 %AND A(P+1)=2           ;! FETCH ARRAYHEAD
 3234           FROM LIST(FNAME,KK,JJ)
 3235           KK=KK>>4&15;                  ! BASE REG OF FORMAT
 3236           FROM1(JJ,JJ)
 3237           %IF MODE=2 %THEN PRR(X'1A',INDEX,BS)
 3238           ->L3  %UNLESS MODE=0 %AND BS<4;! WILL POINTER BE DESTROTED?
 3239           DUMP(2,1,DP,0,BS); MODE=1; BS=1;        ! YES-- SO SAVE IT
 3240  L3:
 3241           QQ=BS; QQ=PARK(BS) %IF MODE=1
 3242           CANAME(Z,QQ,DP,CLINK,KK,JJ+2)
 3243           FROM1(Q,FNAME)
 3244           REGISTER(QQ)=0 %IF MODE=1
 3245           PRR(X'1A',1,LINK)
 3246           CENAME(Z,1,1,0); ->L99
 3247  L50:      P=P+1; ->L51 %IF A(P)=2
 3248           FAULT(19); SKIP APP
 3249  L51:      P=P+1
 3250           %IF INREG=0 %OR Z=14 %THEN CENAME(Z,0,BS,DP) %ELSE %C
 3251+          CENAME(Z,2,INREG,0)
 3252  L99:      %END
 3253           %ROUTINE     CNAME(%INTEGER Z,REG)
 3254           %INTEGER JJ,JJJ,KK,RR,PTYPEP,LEVELP
 3255           %INTEGER DISPP
 3256           %COMMENT Z=0-RTCALL, Z=1 STORE(=), Z=2 FETCH, Z=3 FETCH ADDR, Z=4 STORE(<-), Z=6 STORE PTR, Z=12 FETCH ARRAYHEAD, Z=11 STORE ARRAY HEAD
 3257           %SWITCH S,FUNNY(10:15)
 3258           %SWITCH SW(0:8),MOD(0:31)
 3259           FNAME=A(P); COPYTAG(FNAME)
 3260                 ->L3 %UNLESS I=-1;
 3261  { FAULT(16)   ;! Generating erroneous fault
 3262                 I=LEVEL; J=0; K=FNAME
 3263           PTYPE=7;STORE TAG(K,N)
 3264           K=N; N=N+4; UNPACK
 3265  L3:       JJ=J; JJ=0 %IF JJ=15
 3266           LEVELP=I; DISPP=K
 3267           ->L502 %IF TYPE=7
 3268           ->L500 %IF Z=0 %AND (ROUT#1 %OR 0#TYPE#6)
 3269           ->FUNNY(Z) %IF Z>=10
 3270           ->L501 %IF ROUT=1
 3271           ->SW(TYPE)
 3272  L500:     ->SW(3) %IF TYPE=3
 3273           FAULT(17) %UNLESS TYPE=7; ->L502
 3274  SW(6):   ->L661 %UNLESS Z=3 %AND ARR=1
 3275           K=K<<2; ARR=0; I=10; ->L600
 3276  SW(4):                                 !RECORD FORMAT NAME
 3277  L661:     FAULT(20)
 3278  SW(7):L502:     P=P+1;                  ! NAME NOT SET
 3279           PTYPE=1; UNPACK; ->L6 %IF A(P)=2; ->L102
 3280  FUNNY(11): ->L1011 %IF TYPE=3
 3281           FAULT(17) %UNLESS ARR=1 %AND NAM=1 %AND K>>12=0
 3282           PRX(X'90',0,3,I,K); ->L91
 3283  L1011:          PCLOD(44);->SW(3);      !STM 0,3,0(11) - LA 11,16(11)
 3284  S(11):   MOVER(WSPR,-16)
 3285           PSS(X'D2',16,1,0,WSPR,0); ->L91
 3286  FUNNY(12):     ->SW(3) %IF TYPE=3
 3287           ->L1202 %IF ARR=2;             ! VECTORS
 3288           FAULT(17) %UNLESS ARR=1
 3289  L1201:    PRX(X'98',0,3,I,K&4095); ->L91
 3290  L1202:    FROM2(K,K); ->L1201
 3291  S(12):   ->L1201 %IF TYPE=3 %AND ARR=1
 3292           PRR(X'18',0,1)
 3293           PRX(X'5A',0,0,I,K)
 3294           PRX(X'5A',1,0,I,K+4)
 3295           PRX(X'98',2,3,I,K+8); ->L91
 3296  FUNNY(13):     ! SET BASE & DISP FOR ROUTINE ADDR
 3297           ->SW(3) %IF TYPE=3
 3298           ->L1302 %IF PTYPE=10006
 3299           ->L1301 %IF ROUT=1 %AND NAM&1=1
 3300           BASE=GLA; FROM1(K,DISP)
 3301           INDEX=0; DISP=RA(DISP)
 3302           DISP=DISP+4 %IF J=14;         ! EXTERNAL ROUTINES SKIP LINK
 3303  L1300:    ->L500 %UNLESS ROUT=1
 3304           ->L91
 3305  L1301:    BASE=I; FROM1(K,DISP)
 3306           INDEX=0; ->L91
 3307  L1302:    CSNAME(Z,REG); ->L6
 3308  S(13):   FROM2(K,K); ->L1300
 3309  FUNNY(15):                             ! FETCH RECORD NAME
 3310           ->L1501 %IF PTYPE=10006
 3311  FUNNY(14):     ! STORE INTO RECORD NAME
 3312           RR=0; %IF ARR=0 %AND INREG#0 %AND A(P+1)=2=A(P+2)%THEN RR=INREG
 3313           ->SW(3) %IF TYPE=3; ->L661
 3314  S(14):   FAULT(20) %UNLESS TYPE=3 %AND NAM=1
 3315           PRR(X'18',RR,REG) %IF REG#RR#0
 3316           DISP=0 %IF DISP<0
 3317           R13=0 %IF R13=BASE<<12!DISP
 3318  L1401:    DUMP(Z-13,REG,DISP,INDEX,BASE)
 3319           P=P+1; ->L9005
 3320  S(15):   ->L661 %UNLESS TYPE=3
 3321           ->L1401 %IF DISP>=0
 3322           DUMP(0,REG,0,INDEX,BASE); P=P+1; ->L9005
 3323  L1501:    CSNAME(Z,REG)
 3324           FAULT(22) %UNLESS A(P)=2 %AND A(P+1)=2; P=P+2; ->L9005
 3325  SW(3):   ! RECORD
 3326           FROM2(K,JJJ)
 3327           CRNAME(Z,0,TAGS(A(P)),I,JJJ)
 3328           ->S(Z) %IF Z>=10
 3329           ->L5020 %IF TYPE=5
 3330           ->L601 %UNLESS Z=0
 3331           ->L500 %UNLESS ROUT=1 %AND NAM=1
 3332           LEVELP=PARK(BASE); RR=DISP
 3333           PTYPEP=PTYPE; FROM2(K,JJ)
 3334           FROM2(JJ,K); ->L22
 3335  SW(5):                                 !STRINGS
 3336           BASE=I; INDEX=0; DISP=K
 3337           JJJ=2; ->L5000 %UNLESS ARR=1
 3338           CANAME(Z,I,K,TAGS(FNAME),0,0)
 3339  L4998:    NAM=NAM>>1;JJJ=0
 3340           ->L5000 %UNLESS Z=3
 3341           DUMP(0,REG,DISP,INDEX,BASE)
 3342           PRX (X'58',2,0,LEVELP,DISPP+8) %IF CHECKS#0
 3343           PACLOD(10,6,REG<<4); ->L9
 3344           %COMMENT L 2,LMAX. BCTR 2,0. SLL 2,24. OR REG,2
 3345  L5000:    ->L605 %IF 2<=Z<=3
 3346           PRR(X'18',4,REG) %UNLESS REG=4
 3347           DUMP(JJJ,1,DISP,INDEX,BASE)
 3348           ->L5001 %IF ARR=0
 3349           PRX(X'58',2,0,LEVELP,DISPP+8) %IF Z=4 %OR CHECKS#0
 3350           I=2; K=3
 3351  L5001:    STORE STRING(Z,4,1,I,K);->L9
 3352  L5020:    ! STRINGS IN RE CORDS
 3353           ->L5025 %IF ARR=1
 3354           ->L9 %IF 2<=Z<=3
 3355           PRR(X'18',4,REG) %UNLESS REG=4; ->L5001
 3356  L5025:    ! STRING ARRAYS IN RECORDS
 3357           LEVELP=I; DISPP=K; ->L4998
 3358  SW(8):                                 !REGISTER VARIABLE
 3359           FAULT(29) %UNLESS 1<=Z<=2 %OR Z=4
 3360           ->L9 %IF K=REG
 3361           %IF Z=2 %THEN PRR(X'18',REG,K) %ELSE PRR(X'18',K,REG)
 3362           ->L9
 3363  SW(0):   %UNLESS Z=3 %OR Z>10 %THEN %START
 3364           FAULT(12); TYPE=1; PTYPE=PTYPE+1; %FINISH
 3365  SW(2):                                 !REAL
 3366  SW(1):   ->L600 %IF ARR=0;              ! TYPE 1 = %INTEGER
 3367           CANAME(Z,I,K,TAGS(FNAME),0,0)
 3368           TYPE=1 %IF TYPE=0;            ! IN CASE OF ABUSE OF ARRAYNAME
 3369           NAM=NAM>>1; ->L601
 3370  L501:     ->L503 %UNLESS Z#0 %AND PTYPE=10000;!     ROUTINES
 3371           FAULT(23); PRINTNAME(A(P)); ->L503
 3372  L503:     PTYPEP=PTYPE
 3373           ->L20 %UNLESS PTYPE=10006
 3374           CSNAME(Z,REG)
 3375           ->L202 %IF ROUT=1 %AND NAM>=1 %AND Z#0; ->L6; ! MAPS
 3376  L20:      KK=K; FROM LIST(KK,RR,K)
 3377  L22:      ->L21 %UNLESS K=1000; FAULT(21); ->L502
 3378  L21:      CRCALL(KK)
 3379           PTYPE=PTYPEP; UNPACK
 3380           ->L37 %IF NAM&1=1
 3381           ->L36 %IF JJ=14
 3382           DUMP(2,1,RA(RR),0,GLA)        ;! RT ADDR TO REG1
 3383           PRX(X'45',LINK,0,GLA,116);    ! BAL 15,SR IN PERM
 3384  L371:     MONE=1; R13=0
 3385           P=P+1
 3386           ->L1 %IF PTYPE=10000 %OR PTYPE=11000;    ! ROUTINE OR RTNAME
 3387           ->L201 %IF NAM>1;              !MAPS
 3388           FAULT(29) %UNLESS Z=2;        !FN OUT OF CONTEXT
 3389           ->L43 %IF TYPE=2
 3390  L44:      PRR(X'18',REG,1) %UNLESS REG=1; ->L1
 3391  L43:      PRR(X'28',REG,2) %UNLESS REG=2; ->L1
 3392  L36:      ! CALL OF EXTERNAL ROUTINE
 3393                 PACLOD(55,4,RA(RR)+4);  !STM 4,14 - LM 12,14-BALR 13,14
 3394           ->L371
 3395  L37:       ! CALL OF RT PARAM******** REGISTERS MUST BE RESET
 3396           REGISTER(LEVELP)=0 %IF LEVELP<RBASE
 3397                 PACLOD(61,4,LEVELP<<12!RR)
 3398  %COMMENT STM 4,14,?--LM 12,15 ? -- LM 5,9,20(15) -- BALR 15,14
 3399           ->L371
 3400  L201:     %COMMENT - REAL MAPS AND INTEGER MAPS
 3401           NEST=1
 3402  L202:
 3403           ->L205 %IF TYPE=5;             ! STRING MAPS
 3404           ->L203 %IF Z=3
 3405           JJJ=Z; JJJ=1 %IF Z=4
 3406           JJJ=TYPE<<3+PREC<<1-8+JJJ
 3407           DUMP(JJJ,REG,0,0,NEST)
 3408           CHECK CAPACITY(REG,0,0,NEST) %IF Z=1 %AND CHECKS=1
 3409           TEST ASS(REG) %IF Z=2 %AND UNASS=1
 3410           ->L1
 3411  L203:     PRR(X'18',REG,NEST) %UNLESS REG=NEST; ->L1
 3412  L205:     %COMMENT STRING MAPS
 3413           %IF NEST#1 %THEN PRR(X'18',1,NEST)
 3414           ->L206 %IF 2<=Z<=3
 3415           STORE STRING(Z,REG,1,0,255); ->L1
 3416  L206:           PCLOD(69);->L44;         ! LA 0,255--SLL 0,24 OR 1,0
 3417                 !ARR=0
 3418  L600:     BASE=I; INDEX=0; DISP=K
 3419  L601:     ->L602 %IF Z=6
 3420           ->MOD(NAM<<4!PREC<<2!Z&3)
 3421  L602:     FAULT(17) %IF NAM=0
 3422           R13=0 %IF R13=BASE<<12!DISP
 3423           JJJ=1; ->L605
 3424  MOD(1):  ! INTEGER STORE (=)
 3425  MOD(0):  ! INTEGER STORE(<-)
 3426  MOD(5):  ! BYTE STORE(=)
 3427  MOD(4):  ! BYTE STORE(<-)
 3428  MOD(9):  ! SHORT STORE(=)
 3429  MOD(8):  ! SHORT STORE(<-)
 3430  MOD(12):                               !LONG REAL STORE (<-)
 3431  MOD(13):                               !LONG REAL STORE (=)
 3432  MOD(2):                                !INTEGER OR REAL FETCH
 3433  MOD(14):                               !LONGREAL FETCH
 3434           JJJ=Z; JJJ=1 %IF Z=4
 3435           JJJ=TYPE<<3+PREC<<1-8+JJJ
 3436  L605:     DUMP(JJJ,REG,DISP,INDEX,BASE)
 3437           CHECK CAPACITY(REG,DISP,INDEX,BASE) %IF Z=1 %AND CHECKS=1
 3438           TEST ASS(REG) %IF Z=2 %AND UNASS=1
 3439           ->L9
 3440  MOD(31):                               !LONG REAL NAME FETCH ADDR
 3441  MOD(19):       ! INTEGER NAME FETCH ADDR
 3442  MOD(23):       ! BYTE    NAME FETCH ADDR
 3443  MOD(27):       ! SHORT   NAME FETCH ADDR
 3444           JJJ=2;->L605
 3445  MOD(15):                               !LONG REAL FETCH ADDR
 3446  MOD(3):  ! INTEGER FETCH ADDR
 3447  MOD(7):  ! BYTE    FETCH ADDR
 3448  MOD(11): ! SHORT   FETCH ADDR
 3449           JJJ=0;->L605
 3450  MOD(6):  ! BYTE  FETCH
 3451  MOD(10): ! SHORT FETCH
 3452           JJJ=PREC<<1+2;->L605
 3453  MOD(16):       ! INTEGER NAME STORE (<-)
 3454  MOD(20):       ! BYTE    NAME STORE (<-)
 3455  MOD(24):       ! SHORT   NAME STORE (<-)
 3456  MOD(17):       ! INTEGER NAME STORE (=)
 3457  MOD(21):       ! BYTE    NAME STORE (=)
 3458  MOD(25):       ! SHORT   NAME STORE (=)
 3459  MOD(28):                               !LONG REAL NAME STORE (<-)
 3460  MOD(29):                               !LONG REAL NAME STORE (=)
 3461  MOD(18):       ! INTEGER NAME FETCH
 3462  MOD(22):       ! BYTE    NAME FETCH
 3463  MOD(26):       ! SHORT   NAME FETCH
 3464  MOD(30):                               !LONG REAL NAME FETCH
 3465           RP13=R13; R13=BASE<<12!DISP
 3466           PRX(X'58',LINK,INDEX,BASE,DISP) %UNLESS R13=RP13 %AND INDEX=0
 3467           JJJ=Z; JJJ=1 %IF Z=4
 3468           JJJ=TYPE<<3+PREC<<1-8+JJJ
 3469           DUMP(JJJ,REG,0,0,LINK)
 3470           CHECK CAPACITY(REG,0,0,LINK) %IF Z=1 %AND CHECKS=1
 3471           TEST ASS (REG) %IF Z=2 %AND UNASS=1
 3472  L9:       ->L1 %UNLESS ARR=0
 3473  L91:      P=P+1
 3474                 ->L6 %IF A(P)=2
 3475                 FAULT(19)
 3476  L102:           SKIP APP; ->L1
 3477  L6:            P=P+1
 3478  L1:       P=P+1; ->L9005 %IF A(P-1)=2
 3479           FAULT(69); ->L91
 3480  L9005:    %END
 3481           %ROUTINE CRCALL (%INTEGER CLINK)
 3482           !%SHORTROUTINE
 3483           %SWITCH FPD(0:3)
 3484           %INTEGER KK,II,III,Q,QQ,QQQ,PP,RF
 3485           %ROUTINESPEC MOVEBACK
 3486           %INTEGER MOVED,TOMOVE,TYPEP
 3487           %SHORTINTEGER LIST; LIST=0
 3488           FFLAG=0; KK=COUNT APS
 3489           P=P+1; ->L2 %IF K=KK
 3490           FAULT(19); PRINTNAME(FNAME)
 3491           SKIP APP; P=P-1; ->L99
 3492  L2:       ->L99 %IF K=0;                 ! NO PARAMETERS
 3493           Q=0; QQ=64; RF=1-FFLAG;       ! RF=1 NO NEED TO MOVE WSPR
 3494           MOVED=0; RF=1 %IF KK=1
 3495  L7:       MLINK(CLINK)
 3496           FROM1(CLINK,PTYPE)
 3497           P=P+1; UNPACK
 3498           II=TYPE; III=PREC; QQQ=P
 3499           PP=(NAM<<1!ARR)&3
 3500           ->L10 %UNLESS(PP=0 %AND ROUT=0) %OR(A(P)=4 %AND A(P+1)=1)
 3501           ->L12 %IF ROUT=1; ->FPD(PP)
 3502  L10:      P=QQQ; SKIP EXP;
 3503  L11:      FAULT(22); ->L53
 3504           %COMMENT ROUTINE TYPE PARAMETERS
 3505  L12:      II=PTYPE; P=P+2; CNAME(13,0)
 3506           ->L10 %IF 1000#|PTYPE-II|#0
 3507           ->L10 %IF A(P)=1; P=P+1
 3508           ->L13 %IF J=14;      ! EXTERNAL
 3509           ->L15 %IF NAM&1#0;             ! RT NAME OR RTTYPE
 3510           DUMP(2,2,DISP,INDEX,BASE);      ! PICK UP RT ADDR
 3511           PRX(X'5A',2,0,GLA,28);        ! RELOCATE
 3512           PCONST(X'180C181D');          ! LR 0,12 LR1,13 PERM AND GLA
 3513           PUSH(LIST,QQ+12,0); ->L69
 3514  L13:      PRX(X'98',0,2,BASE,DISP);     ! CODE,GLA,EP
 3515           PRR(X'18',3,9); ->L69;         ! ANYTHING D W ALIGNED AS ENVRMNT
 3516  L15:      PRX(X'98',0,3,BASE,DISP); ->L69
 3517  FPD(0):  ->L41 %IF PREC=3
 3518           ->L45 %IF TYPE=5
 3519           ->L39 %UNLESS UNASS=0 %AND TYPE=1
 3520           PP=P; TYPEP=PREC
 3521           II=TSEXP(III)
 3522           ->L42 %IF II=10 %AND TYPEP=0
 3523           ->L43 %IF II=1 %AND TYPEP=1
 3524           P=PP; TYPE=1
 3525  L39:      CSEXP(0,TYPE)
 3526           MOVE BACK
 3527           DUMP(8*TYPE-7,NEST,QQ-MOVED,0,WSPR)
 3528           CHECK CAPACITY(NEST,QQ-MOVED,0,WSPR) %IF CHECKS=1
 3529           TOMOVE=4;->L50
 3530  L42:      MOVEBACK
 3531           PSS(X'D2',4,WSPR,QQ-MOVED,I,K)
 3532           TOMOVE=4; ->L50
 3533  L43:      MOVEBACK
 3534           PSI(X'92',III,WSPR,QQ-MOVED+3)
 3535           TOMOVE=4; ->L50
 3536  L41:      II=0; II=4 %UNLESS QQ&7=0;    !LONG REAL
 3537           CSEXP(0,3)
 3538           DUMP(15,NEST,QQ-MOVED+II,0,WSPR)
 3539           TOMOVE=8+II;->L50
 3540  L45:      CSTREXP(4); FROM2(CLINK,III)
 3541           PRX(X'41',1,0,WSPR,QQ-MOVED+4)
 3542           STORE STRING(1,4,1,0,III-1)
 3543           TOMOVE =(III+7)&(-4); ->L50
 3544  FPD(2):                                ! NAME TYPES INCLUDES RECORDNAME
 3545           P=P+2
 3546           %IF TYPE=3 %THEN CNAME(15,1) %ELSE CNAME(3,1)
 3547           ->L10  %IF A(P)=1; P=P+1;      ! CHECK NO RESTOF EXPRN
 3548           ->L11 %UNLESS (II=TYPE %AND III=PREC) %OR II=0
 3549           MOVE BACK
 3550           DUMP(1,1,QQ-MOVED,0,WSPR)
 3551           TOMOVE=4;->L50 %UNLESS II=0
 3552           FAULT(12) %UNLESS 2>=TYPE
 3553           PSI(X'92',PREC<<3!TYPE,WSPR,QQ-MOVED); ->L50;!FLAG FOR %NAME
 3554  FPD(1):FPD(3):                         ! ARRAYNAME (+ARRAY VALUE)
 3555           P=P+2; CNAME(12,0); ->L10 %IF A(P)=1;     ! REST OF EXPRN
 3556           P=P+1
 3557           FROM2(CLINK,PP)
 3558           %IF PP=0 %THEN %START; REPLACE2(CLINK,J); %FINISH
 3559           FAULT(22) %UNLESS ARR>0 %AND(J=0 %OR PP=0 %OR J=PP)
 3560           FAULT(22) %UNLESS II=0 %OR(TYPE=II %AND III=PREC)
 3561  L69:      MOVE BACK
 3562           PRX(X'90',0,3,WSPR,QQ-MOVED); ! STM
 3563           TOMOVE=16
 3564  L50:      QQ=QQ+TOMOVE
 3565           ->L53 %IF RF=1 %OR Q=KK-1
 3566            II=(QQ+7)&(-8)-MOVED
 3567           MOVER(WSPR,II); MOVED=MOVED+II
 3568  L53:      Q=Q+1; ->L7 %UNLESS Q=KK
 3569           MOVER(WSPR,-MOVED) %UNLESS RF=1
 3570  L55:      POP(LIST,Q,QQ); ->L99 %IF Q=-1
 3571           PRX(X'50',WSPR,0,WSPR,Q); ->L55;! POINTER TO SAVE AREA RTTYPES
 3572           %ROUTINE MOVEBACK
 3573           ->L1 %IF QQ>=MOVED
 3574           MOVER(WSPR,QQ-MOVED); MOVED=QQ
 3575  L1:       %END
 3576  L99:      %END
 3577  %COMMENT Z=1 FOR= ,4 FOR <- AND MAX LENGTH IN BYTE DEFINED BY BML&DML
 3578           %ROUTINE     STORE STRING(%INTEGER Z,FROM,TO,BML,DML)
 3579           !%SHORTROUTINE
 3580  %COMMENT REGISTER 2 IS ASSUMED TO BE USABLE.
 3581           FAULT(239) %UNLESS TO=1 %AND FROM=4
 3582           ->L10 %IF Z=4
 3583           ->L2 %IF CHECKS=0
 3584           ->L1 %IF BML>0
 3585           PSI(X'95',DML,FROM,0); ->L3;   ! CLI FOR FIXED LENGTH
 3586  L1:
 3587           PSS(X'D5',1,FROM,0,BML,DML)   ;!CLC_ACTUALL(1),MAX
 3588  L3:
 3589           PRX(X'47',2,0,CODER,88)       ;!BH_FAIL
 3590  L2:       PRX(X'43',2,0,FROM,0)         ;!IC_2,ACTUALL
 3591           PRX(X'44',2,0,GLA,STRINST)    ;!EX_2,MOVE
 3592           ->L99
 3593  L10:      PRX(X'43',2,0,BML,DML)        ;!IC_2,MAXL
 3594           PPJ(39)
 3595  L99:      %END
 3596                 %ROUTINE TEST NST
 3597                 FNAME=K
 3598                 FAULT(7) %UNLESS FIND(FNAME,NAME(LEVEL))=-1
 3599                 %END
 3600           %ROUTINE CUCI
 3601           !%SHORTROUTINE
 3602           %ROUTINESPEC DXB
 3603           %ROUTINESPEC DLB
 3604           %ROUTINESPEC DB
 3605           %ROUTINESPEC CUCS
 3606           %INTEGER Z,KK,X,OPCODE,REG
 3607           %SWITCH SW(1:4),S(1:8)
 3608           P=2; ->SW(A(P))
 3609  SW(1):         ! **(N),(@')(NAME)(APP)
 3610           NEST=A(3); P=5; Z=A(4)-1
 3611           Z=3 %IF Z=0; CNAME(Z,NEST)
 3612           ->L99
 3613  SW(2):   PPJ(A(P+1)); ->L99
 3614  SW(4):   ! *PUT_CONST
 3615           ->L401 %IF A(P+1)#9
 3616           PLANT(A(P+2)); P=P+3; ->L99
 3617  L401:     FAULT(32) %UNLESS A(P+1)=1
 3618           PLANT(A(P+3));                ! LEAST SIGNIFICANT 16 BITS ONLY
 3619           P=P+4; ->L99
 3620  SW(3):   OPCODE=A(P+2);P=P+3; ->S(A(P-2))
 3621  S(1):    ->L87 %IF OPCODE=0;
 3622           PRR(OPCODE,A(P),A(P+1)); P=P+2; ->L99;           ! RR
 3623  S(2):    REG=A(P); P=P+1;DXB;                    !RX
 3624  L11:      PRX(OPCODE,REG,X,I,K);->L99
 3625  S(3):    REG=A(P); X=A(P+1);P=P+2;               !RS
 3626           DB; ->L11
 3627  S(4):    DB;Z=0;->L41 %IF A(P)=2;Z=A(P+2);        !SI
 3628           FAULT(32) %UNLESS A(P+1)=9 %AND Z<256
 3629           P=P+2
 3630  L41:      PSI(OPCODE,Z,I,K);P=P+1; ->L99
 3631  S(5):    REG=A(P);P=P+1; DB;                     !SHIFT INSTR.
 3632           X=0; ->L11
 3633  S(6):    DLB;KK=K;Z=X;REG=I;DB;                  !SS FORMAT
 3634           Z=1 %IF Z=0
 3635  L61:      PSS(OPCODE,Z,REG,KK,I,K); ->L99
 3636  S(7):    DLB; KK=K; Z=X; REG=I;                  !PACKED DECIMAL
 3637           DLB; Z=1 %IF Z=0
 3638           X=1 %IF X=0
 3639           Z=(Z-1)<<4!X; ->L61
 3640  S(8):    REG=A(P); P=P+1;                        !FUNNIES
 3641           ->L85 %IF OPCODE=X'80'       ;! IDL
 3642           ->L83 %IF OPCODE=10;           ! SVC
 3643           PRR(OPCODE,REG,0);->L99
 3644  L83:      PLANT(X'A00'!REG); ->L99
 3645  L85:      PSI(OPCODE,REG,0,0); ->L99
 3646  L87:      CNOP(A(P),A(P+1)); ->L99
 3647           %ROUTINE DB
 3648           ->L2 %IF A(P)=1
 3649           K=A(P+1); I=0; P=P+3
 3650           ->L99 %IF A(P-1)=2
 3651           I=A(P);P=P+1;->L99
 3652  L2:       CUCS
 3653  L99:      %END
 3654           %ROUTINE DXB
 3655           %SWITCH SW(1:3)
 3656           ->L2 %IF A(P)=2
 3657           CUCS;X=0;P=P+1
 3658           ->L99 %IF A(P-1)=2
 3659           X=A(P);P=P+1; ->L99
 3660  L2:       K=A(P+1);P=P+2;I=0;X=0
 3661           ->SW(A(P))
 3662  SW(1):   X=A(P+1);P=P+1
 3663  SW(2):   I=A(P+1);P=P+1
 3664  SW(3):   P=P+1
 3665  L99:      %END
 3666           %ROUTINE DLB
 3667           ->L2 %IF A(P)=2
 3668           K=A(P+1); X=A(P+2); I=A(P+3); P=P+4; ->L99
 3669  L2:       CUCS; X=A(P); P=P+1
 3670  L99:      %END
 3671           %ROUTINE     CUCS
 3672           %SWITCH UTYPE(0:8)
 3673           P=P+1
 3674           ->L10 %IF A(P)=2
 3675           FNAME=A(P+1); COPYTAG(FNAME)
 3676           P=P+3; ->L1 %UNLESS I=-1
 3677           FAULT(16); J=0; I=LEVEL; PTYPE=7; UNPACK
 3678           STORE TAG(FNAME,N);K=N;N=N+4
 3679  L1:       FAULT(33) %IF ROUT=1; ->UTYPE(TYPE)
 3680  UTYPE(3):      FROM2(K,K); ->L9;        ! RECORDS
 3681  UTYPE(4):      FROM1(K,K); ->L9;        ! FORMATS
 3682  UTYPE(8):FAULT(33); ->L9
 3683  UTYPE(6):      FROM1(K,K);             ! SWITCHES
 3684           K=K-CODEBASE(OLDI); FAULT(99) %IF K>4095
 3685           I=10
 3686  UTYPE(0):UTYPE(1):UTYPE(2):UTYPE(5):UTYPE(7):
 3687           ->L9 %UNLESS ARR=2;            ! VECTOR
 3688           FROM2(K,K);                   ! EXTRACT DISPLACEMENT
 3689  L9:       ->L99 %IF A(P-1)=2
 3690           K=K+A(P); P=P+1; ->L99
 3691  L10:      K=A(P+2)+(A(P+1)-1)<<14
 3692           J=FIND(K,LABEL(LEVEL))
 3693           ->L25 %IF J=-1
 3694           K=J-CODEBASE(LEVEL); I=10
 3695           FAULT(99) %IF K>4095; P=P+3; ->L99
 3696  L25:      PUSH(JUMP(LEVEL),CA!LABSET,K)
 3697           K=0; I=0; P=P+3
 3698  L99:      %END
 3699  L99:      %END
 3700           %ROUTINE     TEST ASS(%INTEGER REG)
 3701           !%SHORTROUTINE
 3702           %INTEGER J
 3703           %RETURN %UNLESS 1<=TYPE<=2
 3704           ->L5 %IF TYPE=1
 3705           J=X'79'; J=X'69' %IF PREC=3
 3706  L3:       PRX(J,REG,0,GLA,128)
 3707           PRX(X'47',8,0,CODER,40); ->L99
 3708  L5:       ->L99 %UNLESS PREC=0
 3709           J=X'59'; ->L3
 3710  L99:      %END
 3711           %ROUTINE     GXREF(%INTEGER NAME,HASH)
 3712           !%SHORTROUTINE
 3713           %INTEGER I,J,K,N,NP
 3714           I=N0; N0=N0+7; J=WORD(NAME)
 3715           ST(I+1)=0; ST(I+2)=0; ST(I+3)=0
 3716           N=LETT(J); NP=N; NP=8 %IF NP>8
 3717           K=ADDR(ST(I+5)); ->L1 %IF HASH=0
 3718           ST(I+5)=HASH<<16!'#'<<8
 3719           K=K+2; N=N+2
 3720           NP=6 %IF NP>6
 3721  L1:       %CYCLE NP=1,1,NP
 3722           BYTEINTEGER(K+NP)=LETT(J+NP); %REPEAT
 3723           N=8 %IF N>8; ST(I+4)=X'80000000'; ! MARK NEW FORMAT
 3724           ST(I)=XREFLINK; XREFLINK=I<<2; ! LINK IN REFERENCE
 3725           BYTE INTEGER(ADDR(ST(I+5)))=N
 3726           N0=N0+1 %IF N=8
 3727           %END
 3728           %ROUTINE UNDCRF (%SHORTINTEGERNAME OPHEAD)     ; ! Care needed with short conversion!
 3729           %INTEGER I,J
 3730           %SHORTINTEGER OP
 3731           %COMMENT UNSCRAMBLES RECORD FORMAT TAGS LIST & SIDECHAIN
 3732           POP (OPHEAD,I,J);             ! LST ITEM IS DESPMENT
 3733  L1:       POP (OPHEAD,I,J)
 3734           ->L9 %IF I=-1
 3735           OP=J;PTYPE=I>>4&X'FFFF';UNPACK
 3736           %IF ROUT=1 %OR TYPE=3 %THEN CLEAR LIST(OP)
 3737           ->L1
 3738  L9:       %END
 3739           %ROUTINE CLT
 3740           !%SHORTROUTINE
 3741           %COMMENT P ON PHRASE TYPE AT ENTRY - TO NEXT PHRASE AT EXIT
 3742           TYPE=TYPEFLAG(A(P))
 3743           PREC=TYPE>>3; TYPE=TYPE&7
 3744           PREC=3 %IF TYPE=2 %AND ALL LONG#0
 3745           ACC=BYTES(PREC);P=P+1
 3746           ->L99 %UNLESS TYPE=5
 3747           ->L2 %UNLESS A(P)=2
 3748           ACC=0; P=P+1; ->L99
 3749  L1:       P=P+1;FAULT(70);->L99
 3750  L2:       P=P+1;ACC=A(P)+1
 3751           ->L1 %UNLESS 2<=ACC<=256
 3752           P=P+1
 3753  L99:      %END
 3754           %ROUTINE     CQN(%INTEGER P)
 3755           !%SHORTROUTINE
 3756           %BYTEINTEGER I
 3757           I=A(P);NAM=0;ARR=0
 3758           NAM=2 %IF I=1 ;ARR=1 %IF I<=2
 3759           NAM=NAM!1 %IF I<=3;ACC=16 %IF ARR=1
 3760           ACC=4 %IF I=3
 3761           %END
 3762           %ROUTINE SKIP EXP
 3763           !%SHORTROUTINE
 3764           %SWITCH SW(1:4);%INTEGER J
 3765           %OWNINTEGER RT=10000
 3766  L3:       P=P+1; ->SW(A(P));            ! SWITCH ON OPERAND
 3767  SW(1):   P=P+2;                        ! OPERAND = NAME
 3768           J=ADDR(ASLIST(TAGS(A(P-1))))
 3769           ->L5 %IF SHORT INTEGER(J)<RT; FFLAG=1
 3770  L5:       SKIP APP; P=P+1
 3771           ->L1 %IF A(P-1)=2; P=P+1; ->L5
 3772  SW(2):                                 ! CONST
 3773           P=P+1; J=A(P)
 3774           %IF J=9 %THEN %START; P=P+2; ->L1; %FINISH
 3775           %IF J=1 %THEN %START; P=P+3; ->L1; %FINISH
 3776           %IF J=2 %THEN %START; P=P+5; ->L1; %FINISH
 3777           P=P+A(P+1)&X'FE'+3; ->L1
 3778  SW(3):SW(4): P=P+1; SKIP EXP
 3779  L1:       P=P+1; ->L3 %IF A(P-1)=1
 3780           %END
 3781            %ROUTINE SKIP APP;           ! SKIPS ACTUAL PARAMETER PART
 3782  L5:       P=P+1; ->L1 %IF A(P-1)=2; SKIP EXP; ->L5
 3783  L1:        %END
 3784           %ROUTINE     CQUERY(%INTEGER REG)
 3785           !%SHORTROUTINE
 3786           PSI(X'95',0,GLA,1);           ! CLI 1(GLA),0
 3787           PJ(8,PLABEL-1);               ! JUMP ROUND IF QUERIES OFF
 3788             ->L1 %IF TYPE=2
 3789           ->L5 %IF TYPE=5
 3790           PRR(X'18',1,REG) %UNLESS REG=1;         ! LR 1,REG
 3791           PCONST(X'4120000B');          ! LA 2,11
 3792           PPJ(4); ->L9;                  ! TO WRITE
 3793  L1:       PCONST(X'41100020'); PPJ(3);  ! OUTPUT SPACE
 3794           %IF QPREAL=0 %THEN %START
 3795           QPREAL=N0<<2+4
 3796           ST(N0)=XREFLINK; XREFLINK=QPREAL-4
 3797           ST(N0+4)=8; ST(N0+5)=M'I#PR'; ST(N0+6)=M'INTF'
 3798           !!                   ^^^^^^            ^^^^^^^          WARNING! Endianness
 3799           N0=N0+7; %FINISH
 3800           PACLOD(82,1,REG<<4)
 3801           %COMMENT STD REG,64(11).LA 0,12.ST 0,68(11) %ABD SS ENTRYPRINTF
 3802           PACLOD(55,4,QPREAL); ->L9
 3803  L5:       PCONST(X'4110000A'); PPJ(3);  ! NEWLINE
 3804           PRR(X'18',1,REG); PPJ(5)
 3805  L9:       PLAB(-1)
 3806           %END
 3807           %ROUTINE     LOADAD(%INTEGER REG,BASE,X,DISP)
 3808           !%SHORTROUTINE
 3809           ! LOADS ADDRESS & DEALS CORRECTLY WITH DISP>4095
 3810           %INTEGER I
 3811                 PRX(X'41',REG,X,BASE,DISP&4095)
 3812           I=PAGENO(DISP)
 3813           PRX(X'5A',REG,0,GLA,4*I)%UNLESS 4095>=DISP
 3814           %END
 3815                 %INTEGERFN TSEXP(%INTEGERNAME CODE)
 3816           !%SHORTROUTINE
 3817           %SWITCH SW(1:4)
 3818           TYPE=1
 3819           ->L9 %IF 1#A(P)#4; ->SW(A(P+1))
 3820  SW(1):   CODE=A(P+2); COPYTAG(CODE)
 3821           %IF PTYPE=10006 %THEN %START
 3822           TYPE=TSNAME(K);PREC=TYPE>>3
 3823           TYPE=TYPE&7; %FINISH
 3824           ->L40 %IF TYPE=8;              !REGISTER VARIABLE
 3825           ->L30 %IF TYPE=3 %AND ARR=0 %AND INREG#0
 3826           ->L50 %IF ARR=2 %AND TYPE=1
 3827           ->L9 %UNLESS A(P+3)=2 =A(P+4); ! NO APP OR ENAME
 3828           ->L9 %UNLESS ROUT=0 %AND ARR=0
 3829           ->L20 %IF TYPE=5
 3830           ->L9 %UNLESS NAM=0
 3831           ->L14 %IF TYPE=2
 3832           ->L9 %UNLESS TYPE=1
 3833           ->L11 %IF A(P+5)=2;            ! NO RST OF EXPS
 3834           ->L9 %UNLESS A(P+6)=2=A(P+7)
 3835           ->L9 %UNLESS A(P+8)=9 %AND A(P+10)=2
 3836           CODE=A(P+9); P=P+11; %RESULT=100
 3837  L11:      P=P+6; %RESULT=10+PREC
 3838  L14:      ->L9 %UNLESS A(P+5)=2;         !NO NOT OF EXPRN
 3839           P=P+6; %RESULT=14+PREC&1
 3840  L20:      ->L9 %UNLESS A(P+5)=2
 3841           P=P+6; %RESULT=20
 3842  L30:      ->L9 %UNLESS A(P+3)=2 %AND A(P+4)=1;     ! NO APP BUT ENAME
 3843           P=P+5; FROM1(K,FNAME); I=INREG
 3844           K=DISPLACEMENT(FNAME); UNPACK
 3845           ->L9 %IF I=-1 %OR ARR#0 %OR ROUT#0
 3846           ->L9 %UNLESS 1<=TYPE<=2 %AND A(P+1)=2=A(P+2)
 3847           ->L9 %UNLESS A(P+3)=2;         ! NO REST OF EXPRN
 3848           P=P-2; ->L11 %IF TYPE=1; ->L14
 3849  L40:      ->L41 %IF A(P+5)=2;            !NO REST OF EXP
 3850           ->L9 %UNLESS A(P+6)=2=A(P+7)
 3851           ->L9 %UNLESS A(P+8)=9 %AND A(P+10)=2
 3852           CODE=A(P+9);P=P+11; %RESULT=101
 3853  L41:      P=P+6; %RESULT=50
 3854  L50:      ->L9 %UNLESS A(P+3)=1 %AND A(P+4)=4 %AND A(P+5)=2
 3855           ->L9 %UNLESS A(P+6)=9 %AND A(P+7)<256 %AND A(P+8)=2
 3856           ->L9 %UNLESS A(P+9)=2 %AND A(P+10)=2 %AND A(P+11)=2
 3857         FROM1(K,K); K=K+A(P+7)*BYTES(PREC)
 3858           ->L9 %UNLESS 0<=K<4096
 3859           P=P+12; %RESULT=10+PREC
 3860  SW(2):   TYPE=A(P+2)&7
 3861           ->L9 %UNLESS A(P+2)=9
 3862           ->L21 %IF A(P+4)=1;            ! REST OF EXPR
 3863                 CODE=A(P+3); P=P+5
 3864           %RESULT=1 %IF 256>CODE
 3865           %RESULT=2
 3866  L21:      %IF A(P+5)=12 %THEN TYPE=5;! STRING EXPRESSION
 3867  SW(3):SW(4):L9:%RESULT=0
 3868                 %END
 3869                 %ROUTINE     MOVE R(%INTEGER R,N)
 3870           !%SHORTROUTINE
 3871                 ->L99 %IF N=0; ->L2 %IF 0>N
 3872           DUMP(0,R,N,0,R); ->L99
 3873  L2:       N=-N; ->L3 %UNLESS N=4 %OR N=8
 3874           PRX(X'5A',R,0,GLA,76+N); ->L99
 3875  L3:       PCONST(X'41000000'!N);        ! LA 0,N
 3876           PRR(X'1B',R,0);               ! SR R,0
 3877  L99:      %END
 3878                 %INTEGERFN     FIND PP
 3879           !%SHORTROUTINE
 3880                 %INTEGER I
 3881           %CYCLE I=9-RLEVEL,-1,4
 3882                 ->L1 %IF REGISTER(I)=0
 3883                 %REPEAT
 3884           %RESULT=0
 3885  L1:             REGISTER(I)=1
 3886                 %RESULT=I
 3887                 %END
 3888           %ROUTINE     UNPARK(%INTEGER OPCODE,REG,Q)
 3889           !%SHORTROUTINE
 3890           ->L1 %IF 0>Q
 3891           PRR(OPCODE-X'40',REG,Q); REGISTER(Q)=0; ->L9
 3892  L1:       Q=|Q|; PRX(OPCODE,REG,0,RBASE,Q)
 3893           PUSH(WSP(LEVEL),0,Q);
 3894  L9:       %END
 3895                 %INTEGERFN     PARK(%INTEGER REG)
 3896           !%SHORTROUTINE
 3897           %INTEGER I,J,P
 3898           P=CLAIMABLE REG
 3899           ->L1 %IF P=0
 3900           REGISTER(P)=1
 3901                 ->L2 %IF P=REG
 3902           PRR(X'18',P,REG);             ! LR P,REG
 3903  L2:             %RESULT=P
 3904  L1:       POP(WSP(LEVEL),I,J); ->L3 %UNLESS J=-1
 3905           J=N; N=N+4
 3906  L3:       DUMP(1,REG,J,0,RBASE); %RESULT=-J
 3907                 %END
 3908           %INTEGERFN     CLAIMABLE REG
 3909           !%SHORTROUTINE
 3910           %INTEGER I
 3911           ->L1 %IF RBASE<= 4
 3912           %CYCLE I=5,1,RBASE
 3913           %RESULT=I %IF REGISTER(I)=0
 3914           %REPEAT
 3915  L1:       %RESULT=0
 3916           %END
 3917           %INTEGERFN PARKF (%INTEGER REG,PREC)
 3918           !%SHORTROUTINE
 3919           %INTEGER I,J
 3920           ->L10 %UNLESS PREC=0
 3921           POP(WSP(LEVEL),I,J)
 3922           ->L3 %UNLESS J=-1
 3923           J=N; N=N+4
 3924  L3:       DUMP(9+2*PREC,REG,J,0,RBASE)
 3925           %RESULT=J
 3926  L10:      J=GET DBLE WRD;->L3             ;!PARKING SPACE
 3927           %END
 3928           %INTEGERFN GET ARR WSP
 3929           %COMMENT PRODUCES 6 CONTIGUOUS WORDS UNDER BASE
 3930           %COMMENT REGISTER COVER FOR ARRAY ACCESS
 3931           %INTEGER I,J
 3932           POP(MDARR(LEVEL),I,J)
 3933           ->L1 %IF J>0
 3934           J=N;  N=N+24
 3935  L1:       %RESULT =J
 3936           %END
 3937           %ROUTINE     RHEAD(%INTEGER KK)
 3938           !%SHORTROUTINE
 3939           %INTEGER FLAG,W1,W2
 3940           FLAG=KK;FLAG=10000 %IF RLEVEL=0
 3941           ->L5 %IF RLEVEL=0
 3942           ->L5 %UNLESS LIST=0
 3943           NEWLINE;WRITE(LINE,5);SPACES(3*LEVEL)
 3944           %IF KK<0 %THEN print string("BEGIN") %ELSE %START
 3945           print string("RT/FN/MAP "); PRINTNAME(KK); %FINISH
 3946           WRITE(CA,6)
 3947  L5:       LEVEL=LEVEL+1
 3948           ->L6 %IF FLAG<0
 3949           RLEVEL=RLEVEL+1;RBASE=10-RLEVEL;R13=0
 3950           FAULT(35) %IF RBASE=4 %OR REGISTER(RBASE)#0
 3951           REGISTER(RBASE)=1
 3952  L6:       FAULT(34) %IF LEVEL=10
 3953           FAULT(105) %IF LEVEL>MAX LEVELS
 3954           NMDECS(LEVEL)=0
 3955           ->L10 %IF FLAG>=0
 3956           PRX(X'90',10,11,RBASE,N);     ! STM 10,11,?
 3957           N=N+12;W1=RBASE;W2=N-4
 3958           ->L20
 3959  L10:      ->L25 %IF KK<0
 3960           FROM LIST(JJ,J,K);ST(RA(J)>>2)=CA
 3961           PRX(X'50',LINK,0,WSPR,60);    !SAVE LINK
 3962           W1=WSPR; W2=0
 3963  L20:      ->L21 %IF DIAGS1=0
 3964           PSS(X'D2',4,W1,W2,GLA,20)
 3965           LOADAD(0,0,0,LINE)
 3966           PCONST(X'4000D014') ;         !STH 0,20(GLA)
 3967  L21:      MONE=1;SET LINE
 3968  L25:      PRR(X'18',RBASE,WSPR) %UNLESS FLAG<0
 3969           %IF KK<0 %THEN W1=0 %ELSE W1=WORD(KK)
 3970           L(LEVEL)=LINE;M(LEVEL)=W1
 3971           RNEXT(LEVEL)=NEXT
 3972           %RETURN %IF FLAG<0
 3973           SET(RLEVEL)=CA+2
 3974           PRX(X'41',WSPR,WSPR,0,0);     ! LA WSP,?(WSP)
 3975           %IF CHECKS#0 %THEN PCLOD(75); ! CHECK VFOR EXCESS BLOCKS
 3976           N=64; NMAX=N;
 3977           %END
 3978           %ROUTINE     SET80(%INTEGER WHERE,N)
 3979           %RETURN %IF N<=2
 3980           %INTEGER K
 3981           !%SHORTROUTINE
 3982           PSI(X'92',X'80',RBASE,WHERE)
 3983           N=N-1; K=WHERE
 3984  L1:       ->L2 %IF N<=256
 3985           PSS(X'D2',256,RBASE,K+1,RBASE,K)
 3986           K=K+256; N=N-256; ->L1
 3987  L2:       PSS(X'D2',N,RBASE,K+1,RBASE,K)
 3988           %END
 3989           %ROUTINE     CBPAIR(%INTEGERNAME LB,UB)
 3990           !%SHORTROUTINE
 3991           %INTEGER KK,KKK,JJ,BP
 3992           P=P+1; KK=0
 3993           %CYCLE JJ=1,1,2; KKK=KK
 3994           %IF A(P)=2 %THEN KK=-1 %ELSE KK=1
 3995           ->REAL %IF A(P+1)&7=2
 3996           ->STRING %IF A(P+1)&7=5
 3997           %IF A(P+1)=9 %THEN BP=A(P+2) %ELSE %START
 3998           FROMAR4(P+2,BP); P=P+1; %FINISH
 3999           KK=KK*BP; P=P+3; ->AGAIN
 4000  REAL:    FAULT(24); P=P+6; KK=0; ->AGAIN
 4001  STRING:  FAULT(42); P=P*A(P+2)&X'FE'+2; KK=0
 4002  AGAIN:   %REPEAT
 4003           LB=KKK; UB=KK
 4004           %END
 4005           %ROUTINE LOAD DATA
 4006           !%SHORTROUTINE
 4007           %INTEGER LDLINK,JJ,KK,PTR,JJJ
 4008           %SHORTINTEGER HEAD
 4009           LDPTR=8+8*NEPS
 4010           %INTEGERARRAY BUFFER(0:LDPTR)
 4011           BUFFER(0)=7; BUFFER(2)=88
 4012           BUFFER(3)=0; BUFFER(4)=0
 4013           BUFFER(5)=0; BUFFER(6)=64
 4014           PTR=8;  LDLINK=0
 4015  L1:       POP(EPLINK,JJ,KK)
 4016           ->L10 %IF JJ<0
 4017           HEAD=KK
 4018           BUFFER(PTR)=LDLINK
 4019           LDLINK=PTR<<2
 4020           BUFFER(PTR+1)=0
 4021           BUFFER(PTR+2)=0
 4022           BUFFER(PTR+3)=JJ
 4023           BUFFER(PTR+4)=X'80000000'
 4024           POP(HEAD,BUFFER(PTR+5),KK);   ! FIRST BIT OF ID.
 4025           %IF KK>3 %THEN POP(HEAD,BUFFER(PTR+6),JJJ)
 4026           PTR=PTR+7; %IF KK>7 %THEN %START
 4027           POP(HEAD,BUFFER(PTR),JJJ); PTR=PTR+1; %FINISH; ->L1
 4028  L10:      BUFFER(1)=LDLINK
 4029           LPUT(3,PTR<<2,0,ADDR(BUFFER(0)))
 4030           LDPTR=PTR
 4031           %END
 4032           %ROUTINE DEFINE EP(%INTEGER MODE,NAME,ADR)
 4033           !%SHORTROUTINE
 4034           %SHORTINTEGER HEAD
 4035           %INTEGER JJ,KK,LENGTH,ID1,ID2,ID3
 4036           %SWITCH SW(0:2)
 4037           KK=WORD(NAME)
 4038           HEAD=0;  ->SW(MODE)
 4039  SW(0):   %COMMENT DEFINE S#GO
 4040                                                          !! WARNING!!! The fact that these M'xxx' constants are 3 bytes, and
 4041                                                          !! the length byte is plugged in below suggests that we are looking
 4042                                                          !! at some big-endian-dependent code here!  Which might explain why
 4043                                                          !! there are problems with the PRIMs.
 4044           LENGTH=4; ID1=M'S#G'; ID2=M'O   '; ->L10
 4045           !!            ^^^^^^
 4046  SW(1):   %COMMENT SYSTEM EP
 4047           LENGTH=LETT(KK)+2
 4048           ID1=M'S#A'; %CYCLE JJ=1,1,6
 4049           !!  ^^^^^^
 4050           BYTEINTEGER(ADDR(ID1)+JJ+2)=LETT(KK+JJ)
 4051           %REPEAT; ->L10
 4052  SW(2):   %COMMENT ENTRY TO EXTERNAL ROUTINE
 4053           LENGTH=LETT(KK)
 4054           %CYCLE JJ=1,1,8
 4055           BYTE INTEGER(ADDR(ID1)+JJ)=LETT(KK+JJ)
 4056           %REPEAT
 4057  L10:      LENGTH=8 %IF LENGTH>8
 4058           BYTE INTEGER(ADDR(ID1))=LENGTH
 4059           %IF LENGTH>7 %THEN PUSH(HEAD,ID3,0)
 4060           %IF LENGTH>3 %THEN PUSH(HEAD,ID2,0)
 4061           PUSH(HEAD,ID1,LENGTH) ;       ! COMPLETE SIDE CHAIN
 4062           PUSH(EPLINK,ADR,HEAD);        ! LINK TO MAIN LIST
 4063           NEPS=NEPS+1
 4064           %END
 4065         %ROUTINE     REDEFINE EP(%INTEGER TYPEP,%INTEGERARRAYNAME PARAMS)
 4066           !%SHORTROUTINE
 4067           %INTEGER JJ,KK;%SHORTINTEGER OPHEAD
 4068           JJ=N0;P=P-2;GXREF(A(P),'I')
 4069           K=NEWCELL;OPHEAD=K
 4070           ->L1 %IF PARAMS(0)=0 ; %CYCLE KK=1,1,PARAMS(0)
 4071           INSERT AFTER(OPHEAD,PARAMS(KK),0)
 4072           %REPEAT
 4073  L1:       I=9;J=14;OLDI=0;PTYPE=TYPEP
 4074           REPLACE TAG(A(P));REPLACE BOTH(K,NR,PARAMS(0))
 4075           RA(NR)=JJ<<2;NR=NR+1
 4076           %END
 4077           %INTEGERFN GET DBLE WRD
 4078           !%SHORT %ROUTINE
 4079           %COMMENT PRODUCES A DOUBLE WORD OF TEMPORARY SPACE
 4080           %COMMENT COVERED BY CURRENT BASE REGISTER (RBASE)
 4081           %INTEGER I,J
 4082           POP(LWSP(LEVEL),I,J)
 4083           ->L3 %UNLESS I=-1
 4084           ->L2 %IF N&7=0
 4085           PUSH(WSP(LEVEL),0,N);N=N+4
 4086  L2:       J=N;N=N+8
 4087  L3:       %RESULT =J
 4088           %END
 4089           %INTEGERFN     GET STR WSP
 4090           !%SHORTROUTINE
 4091           %INTEGER I,J
 4092           POP(STR WSP(LEVEL),I,J)
 4093           ->L2 %UNLESS J=-1
 4094           J=N; N=N+256
 4095  L2:       %RESULT=J
 4096           %END
 4097           %ROUTINE SETEX
 4098           %RETURN %UNLESS STRINST=0
 4099           ST(N0)=X'D2001000'
 4100           ST(N0+1)=X'4000D500'
 4101           ST(N0+2)=X'20001000'
 4102           STRINST=N0<<2; N0=N0+3
 4103           %END
 4104                 %ROUTINE SETLINE
 4105           !%SHORTROUTINE
 4106           %INTEGER K
 4107           %OWNINTEGER VALUE
 4108           %RETURN %UNLESS LINENOS=1
 4109           K=LINE&255
 4110           MONE=1 %IF K=0
 4111           PSI(X'92',K,GLA,23) %UNLESS K=VALUE %AND MONE=0
 4112           VALUE=K
 4113                 ->L9 %IF MONE=0
 4114           PSI(X'92',LINE>>8,GLA,22);         ! MVI
 4115  L9:       MONE=0; %END
 4116           %ROUTINE     CHECK CAPACITY(%INTEGER REG,DIS,X,LEVEL)
 4117           !%SHORTROUTINE
 4118           %INTEGER MASK
 4119           %RETURN %UNLESS TYPE=1 %AND 1<=PREC<=2
 4120           ->L3 %IF PREC=1;               ! %YTE
 4121           MASK=7
 4122           PRX(X'49',REG,LEVEL,X,DIS);   ! CH REG,STORED VALUE
 4123  L1:       PRX(X'47',MASK,12,0,88); ->L99;          ! BC MASK,CAPACITY EXCE
 4124  L3:       PRX(X'55',REG,0,GLA,24);      ! CL_1,=F'255'
 4125           MASK=2; ->L1
 4126  L99:      %END
 4127  ! ******* LIST***PROCESSING***ROUTINES
 4128  %COMMENT MACROISING  THE FROMS,REPLACES & MLINK SAVES TIME & SPACE;
 4129  %COMMENT MACROISING  THE OTHERS SAVES TIME BUT INCREASES SIZE
 4130           %ROUTINE FROM LIST(%INTEGER CELL,%INTEGERNAME S1,S2)
 4131           %INTEGER J
 4132           J=ADDR(ASLIST(CELL))
 4133           S1=INTEGER(J)
 4134           S2= SHORT INTEGER(J+4)
 4135           %END
 4136           %INTEGERFN NEW CELL
 4137           %INTEGER  P
 4138           P=ASL; FAULT(107) %IF P=0
 4139           ASL= SHORT INTEGER(ADDR(ASLIST(P+6)));! NEXT FREE CELL
 4140           SET SHORT INTEGER(ADDR(ASLIST(P+6)), 0);   ! LINK OF NEWCELL TO 0
 4141           %RESULT=P
 4142           %END
 4143           %ROUTINE PUSH(%SHORTINTEGERNAME CELL,%INTEGER S1,S2)     ; ! Care needed with short conversion!
 4144           %INTEGER P,Q
 4145           P=NEWCELL
 4146           Q=ADDR(ASLIST(P))
 4147           INTEGER(Q)=S1
 4148           SET SHORT INTEGER(Q+4, S2)
 4149           SET SHORT INTEGER(Q+6, CELL)
 4150           CELL=P
 4151           %END
 4152           %ROUTINE POP(%SHORTINTEGERNAME CELL,%INTEGERNAME S1,S2)
 4153           %INTEGER P,Q
 4154           Q=ADDR(ASLIST(CELL))
 4155           S1=INTEGER(Q)
 4156           S2=SHORT INTEGER(Q+4)
 4157           ->L1 %IF CELL=0;              ! LIST ALREADY EMPTY
 4158           P=CELL; CELL=SHORT INTEGER(Q+6);! CELL ONTO NEXT CELL
 4159           SHORT INTEGER(Q+6)=ASL; ASL=P;! OLD CELL ONTO FREE LIST
 4160  L1:       %END
 4161           %ROUTINE     REPLACE1(%INTEGER CELL,S1)
 4162           INTEGER(ADDR(ASLIST(CELL)))=S1
 4163           %END
 4164           %ROUTINE     REPLACE2(%INTEGER CELL,S2)
 4165           SHORT INTEGER(ADDR(ASLIST(CELL+4)))=S2
 4166           %END
 4167           %ROUTINE     MLINK(%INTEGERNAME CELL)
 4168           CELL=SHORT INTEGER(ADDR(ASLIST(CELL+6)))
 4169           %END
 4170           %ROUTINE INSERT AFTER(%SHORTINTEGERNAME CELL,%INTEGER S1,S2)
 4171           ->L1 %IF CELL=0
 4172           PUSH(SHORT INTEGER(ADDR(ASLIST(CELL+6))),S1,S2)
 4173           CELL=SHORT INTEGER(ADDR(ASLIST(CELL+6)))
 4174           %RETURN
 4175  L1:       PUSH(CELL,S1,S2)
 4176           %END
 4177           %INTEGERFN     FIND(%INTEGER LAB,LIST)
 4178  L3:       ->L1 %IF LIST=0
 4179           ->L4 %IF SHORT INTEGER(ADDR(ASLIST(LIST+4)))=LAB
 4180           MLINK(LIST); ->L3
 4181  L4:       %RESULT=INTEGER(ADDR(ASLIST(LIST)))
 4182  L1:       %RESULT =-1
 4183           %END
 4184           %ROUTINE     FROM1(%INTEGER CELL,%INTEGERNAME S1)
 4185           S1=INTEGER(ADDR(ASLIST(CELL)))
 4186           %END
 4187           %ROUTINE     FROM2(%INTEGER CELL,%INTEGERNAME S2)
 4188           S2=SHORT INTEGER(ADDR(ASLIST(CELL+4)))
 4189           %END
 4190           %ROUTINE     REPLACE BOTH(%INTEGER CELL,S1,S2)
 4191           %INTEGER I
 4192           I=ADDR(ASLIST(CELL))
 4193           INTEGER(I)=S1
 4194           SHORT INTEGER(I+4)=S2
 4195           %END
 4196           %ROUTINE CLEAR LIST (%SHORTINTEGERNAME OPHEAD)
 4197           %INTEGER I,J
 4198  L1:       POP(OPHEAD,I,J)
 4199           ->L1 %UNLESS I=-1
 4200           %END
 4201  ! ************END****OF****LIST****PROCESSING ROUTINES
 4202           %ROUTINE     STORE TAG(%INTEGER KK,SLINK)
 4203           PUSH(TAGS(KK),PTYPE<<16!LEVEL<<8!RBASE<<4!J,SLINK)
 4204           PUSH(NAME(LEVEL),0,KK) %UNLESS LEVEL<=1
 4205           %END
 4206           %INTEGERFN     COUNT APS
 4207           %INTEGER PP,Q
 4208           Q=0; PP=P; P=P+1;             ! P ON NAME AT ENTRY
 4209  L1:       ->L2 %IF A(P)=2
 4210        P=P+1; Q=Q+1; SKIP EXP; ->L1
 4211  L2:       P=PP; %RESULT=Q
 4212           %END
 4213           %INTEGERFN     DISPLACEMENT(%INTEGER LINK)
 4214           !%SHORTROUTINE
 4215  ! A(P) HAS ENAME--LINK IS HEAD OF RFORMAT LIST. RESULT IS DISP FROM
 4216  ! START OF RECORD FOR SCALAR DISP OF DV FROM RECORD FORMAT FOR ARRAY
 4217           %INTEGER RR,II
 4218           ->L2 %IF LINK=0
 4219           FROM2(LINK,LINK)
 4220  L1:       MLINK(LINK); FROM LIST(LINK,RR,II)
 4221           ->L2 %IF II=-1
 4222           J=RR&15;PTYPE=RR>>4&X'FFFF'
 4223           RR=RR>>20;K=LINK
 4224           INREG=0
 4225           ->L99 %IF RR=A(P); ->L1
 4226  L2:       FAULT(65); PRINT NAME(A(P))
 4227           PTYPE=1
 4228  L99:      %RESULT=II
 4229           %END
 4230           %INTEGERFN     COPY RECORD TAG
 4231           !%SHORTROUTINE
 4232           ! AS COPY TAG-GIVES TYNE ETC OF THE ENAME
 4233           !P POINTS TO RECORD NAME
 4234           %INTEGER Q,FNAME
 4235           ! K POINT TO SIDE CHAIN
 4236  L1:       FROM1(K,FNAME)
 4237           P=P+1; SKIP APP
 4238           %RESULT=0 %IF A(P)=2
 4239           P=P+1; Q=DISPLACEMENT (FNAME)
 4240           PTYPE=7 %IF Q=-1
 4241           UNPACK
 4242           %IF TYPE=3 %THEN %START
 4243           K=Q; ->L1; %FINISH
 4244           %RESULT=-1 %IF Q=-1
 4245           %RESULT=1
 4246           %END
 4247           %ROUTINE COPY TAG(%INTEGER KK)
 4248           %INTEGER Q
 4249           FROM LIST(TAGS(KK),Q,K)
 4250           ->NOTSET %IF Q=-1
 4251           PTYPE=Q>>16
 4252           INREG=Q>>12&15
 4253           OLDI=Q>>8&15
 4254           I=Q>>4&15
 4255           J=Q&15
 4256  L1:       UNPACK
 4257           %RETURN
 4258  NOTSET:  PTYPE=7
 4259           I=-1; J=I; OLDI=J; ->L1
 4260           %END
 4261                 %ROUTINE REPLACE TAG (%INTEGER KK)
 4262           !%SHORTROUTINE
 4263           %INTEGER P,Q
 4264                 P=TAGS(KK)
 4265           Q=PTYPE<<16!INREG<<12!OLDI<<8!I<<4!J
 4266           REPLACE BOTH(P,Q,K)
 4267                 %END
 4268           %ROUTINE UNPACK
 4269           %INTEGER Q
 4270           ROUT=PTYPE//10000
 4271           Q=PTYPE-10000*ROUT
 4272           NAM=Q//1000
 4273           Q=Q-1000*NAM
 4274           ARR=Q//100
 4275           Q=Q-100*ARR
 4276           PREC=Q//10
 4277           TYPE=Q-10*PREC
 4278           %END
 4279           %ROUTINE     PACK(%INTEGERNAME PTYPE)
 4280           %INTEGER Q
 4281           Q=10000*ROUT+1000*NAM+100*ARR
 4282           PTYPE=Q+10*PREC+TYPE
 4283           %END
 4284  !************* LABEL ***** AND**** JUMP **** ROUTINES*************
 4285           %ROUTINE     PPJ(%BYTEINTEGER N)
 4286           R13=0; PCONST(X'45F0C000'!N<<2);   ! BAL LINP,PLAB N
 4287                 %END
 4288           %INTEGERFN     PAGENO(%INTEGER N)
 4289           %INTEGER I,J
 4290           J=N>>12; I=PAGENOS(J)
 4291           %RESULT=I %UNLESS I=0
 4292           ST(N0)=J<<12
 4293           PAGENOS(J)=N0
 4294           N0=N0+1
 4295           %RESULT=N0-1
 4296           %END
 4297           %ROUTINE FILL JUMPS(%INTEGER LEVEL)
 4298           !%SHORTROUTINE
 4299           %INTEGER J,K,Q,KK
 4300           OPHEAD=0
 4301  L1:       POP(JUMP(LEVEL),J,K); ->L3 %IF J=-1
 4302           Q=FIND(K,LABEL(LEVEL))
 4303           ->L2 %UNLESS Q=-1;
 4304           PUSH(OPHEAD,J,K); ->L1
 4305  L2:       KK=0
 4306           Q=Q-CODEBASE(LEVEL); K=Q>>12
 4307           ->L22 %IF J&LABSET#0
 4308           ->L23 %IF SBFLAG=1
 4309           PLUG(J,X'58E0')
 4310           PLUG(J+2,GLA<<12!4*PAGENO(Q)); J=J+4
 4311           KK=14 %UNLESS K=0
 4312  L21:      PLUG(J+2,KK<<12!Q&X'FFF'); ->L1
 4313  L22:      J=J&X'FFFFFF'; KK=10
 4314  L23:      FAULT(99) %IF Q>4095; ->L21
 4315  L3:       JUMP(LEVEL)=OPHEAD
 4316           %END
 4317           %ROUTINE PJ(%INTEGER MASK,LAB)
 4318           !%SHORTROUTINE
 4319           %INTEGER I,J,Q
 4320           J=FIND(LAB,LABEL(LEVEL)); ->L200 %IF J=-1
 4321           I=J-CODEBASE(LEVEL); ->L50 %IF I>=4096
 4322           PRX(X'47',MASK,0,10,I); ->L999;!     BC MASK,I(10,0)
 4323  L50:      Q=4*PAGENO(I);                ! DISPLACEMENT OF MULTIPLE OF 4K
 4324           PCONST(X'58E0D000'!Q);        ! L 14,Q(GLA)
 4325           PRX(X'47',MASK,14,10,I&4095); ->L999;! BC MASK,?(10,14)
 4326  L200:     PUSH(JUMP(LEVEL),CA,LAB); PCONST(0) %UNLESS SBFLAG=1
 4327           PRX(X'47',MASK,10,0,0);       ! BC MASK,?(10,?)
 4328  L999:     %END
 4329                 %ROUTINE     PLAB(%INTEGER M)
 4330           !%SHORTROUTINE
 4331                 MONE=1
 4332           %IF M>=0 %THEN ->L1
 4333                 PLABEL=PLABEL-1; K=PLABEL
 4334                 M=K
 4335  L1:       PUSH(LABEL(LEVEL),CA,M)
 4336           R13=0
 4337           %END
 4338  !********** END **** OF **** LABEL ****** ROUTINES **************
 4339                 %ROUTINE CHECK RF
 4340           !%SHORTROUTINE
 4341           COPYTAG(A(MARKER1))
 4342           ->L1 %UNLESS TYPE=4
 4343                 JJ=K; FROM LIST(JJ,Q,FNAME)
 4344           DUMP(0,4,Q,0,I);    ! ADDR OF FORMAT TO R4
 4345           ->L9
 4346  L1:       K=-1; FAULT(62)
 4347  L9:       %END
 4348           %ROUTINE     DUMP(%INTEGER CODE,REG,DIS,X,LEVEL)
 4349           !%SHORTROUTINE
 4350           %COMMENT CODE=8*(TYPE-1)+2*PREC+Z
 4351           %INTEGER J
 4352           %OWNBYTEINTEGERARRAY OPCODE(0:16)=X'41',
 4353+          X'50',X'58',X'42',X'43',X'40',X'48',X'59',X'49',
 4354+          X'70',X'78',0(4),X'60',X'68'
 4355           J=OPCODE(CODE);FAULT(248) %IF J=0
 4356           ->L4 %IF CODE=4;               ! IC NEEDED
 4357           ->L1 %UNLESS CODE=0=DIS;       ! OPTIMISE LOAD ADDR
 4358           ->L3 %UNLESS LEVEL=0=X
 4359           PRR(X'1F',REG,REG); ->L99;     ! SLR INSTEAD LO LA REG,0
 4360  L3:       ->L1 %UNLESS LEVEL=0 %OR X=0
 4361           PRR(X'18',REG,X+LEVEL) %UNLESS REG=X+LEVEL;->L99
 4362  L4:       PRR(X'1F',REG,REG) %IF X#REG#LEVEL;    ! SLR FOR BYTE
 4363  L1:       PRX(J,REG,X,LEVEL,DIS)
 4364           %COMMENT AND WITH 255 FOR BYTE IF SLR NOT POSSIBLE AS ADDR IN R
 4365           PRX(X'54',REG,0,GLA,24) %UNLESS CODE#4 %OR X#REG#LEVEL
 4366  L99:      %END
 4367           %END
?PRECP unused
 4368           %ENDOFPROGRAM
?SUBSCHAR unused
?PRHEX unused
?DIAGS2 unused
?SIGFIGS unused
?LENGTHP unused
?MASK2 unused
?MASK1 unused

 5323 Statements compiled
