         Edinburgh IMP77 Compiler - Version 8.4

    1  ! Missing COMREG, IOCP, CONSOURCE, LPUT, CPUTIME, NCODE
    2  
    3  {%MAINEP ICL9CEZIMP
    4  {%TRUSTEDPROGRAM
    5  %BEGIN
    6  !%string(127)%fn ITOS(%integer v,p)
    7  !  %integer vv,q,pos
    8  !  %byteintegerarray store(0:127)
    9  !  
   10  !  vv = v;  vv = -vv %if vv > 0
   11  !  pos = 127
   12  !  %while vv <= -10 %cycle
   13  !    q = vv//10
   14  !    store(pos) = q*10-vv+'0';  pos = pos-1
   15  !    vv = q
   16  !  %repeat
   17  !  store(pos) = '0'-vv
   18  !  %if p <= 0 %start
   19  !    p = 128+p
   20  !  %else
   21  !    p = 128-p
   22  !    p = pos %if p > pos
   23  !    p = p-1
   24  !  %finish
   25  !  pos = pos-1 %and store(pos) = '-' %if v < 0
   26  !  %while pos > p %and pos > 1 %cycle
   27  !    pos = pos-1;  store(pos) = ' '
   28  !  %repeat
   29  !  pos = pos-1;  store(pos) = 127-pos
   30  !  %result = string(addr(store(pos)))
   31  !%end
   32  
   33  !%integermap LONGINTEGER(%integer Addr)
   34  !  %result == INTEGER(Addr)
   35  !%end
   36  !%routine pprofile
   37  !%end
   38  !%routine print ch(%integer I)
   39  !  print symbol(I)
   40  !%end
   41  !%routine newpage
   42  !  print ch(12)
   43  !%end
   44  !%integerfn IMOD(%integer I)
   45  !  %result = |I|
   46  !%end
   47  !%realfn MOD(%real R)
   48  !  %result = |R|
   49  !%end
   50  !%realfn FRACPT(%real r)
   51  !  %result = r-INTPT(r)
   52  !%end
   53  %CONSTINTEGER RELEASE=10
   54  %CONSTINTEGER YES=1,NO=0
   55  %CONSTINTEGER USE IMP=YES
   56  %CONSTINTEGER VMEB=NO
   57  %CONSTSTRING(9) LADATE="28 Jan 81";       ! LAST ALTERED
   58  %INTEGER I, J, K
   59  ! PRODUCED BY OLDPS FROM NRIMPPS8 ON 16/12/80
   60  %CONSTBYTEINTEGERARRAY CLETT(0: 500)=   1,
   61+   43,   1,  45,   1,  40,   1,  41,   1,  44,   2, 201, 198,   6, 213,
   62+  206, 204, 197, 211, 211,   5, 215, 200, 201, 204, 197,   5, 213, 206,
   63+  212, 201, 204,   3, 198, 207, 210,   1,  61,   4, 210, 197, 193, 204,
   64+    7, 201, 206, 212, 197, 199, 197, 210,   8, 204, 207, 206, 199, 210,
   65+  197, 193, 204,   4, 204, 207, 206, 199,  11, 194, 217, 212, 197, 201,
   66+  206, 212, 197, 199, 197, 210,   6, 211, 212, 210, 201, 206, 199,  11,
   67+  200, 193, 204, 198, 201, 206, 212, 197, 199, 197, 210,   7, 210, 207,
   68+  213, 212, 201, 206, 197,   2, 198, 206,   3, 205, 193, 208,   8, 198,
   69+  213, 206, 195, 212, 201, 207, 206,   6, 210, 197, 195, 207, 210, 196,
   70+    4, 206, 193, 205, 197,   5, 193, 210, 210, 193, 217,   9, 193, 210,
   71+  210, 193, 217, 206, 193, 205, 197,   9, 207, 198, 208, 210, 207, 199,
   72+  210, 193, 205,   6, 207, 198, 198, 201, 204, 197,   6, 207, 198, 204,
   73+  201, 211, 212,   6, 198, 207, 210, 205, 193, 212,   4, 211, 208, 197,
   74+  195,   3, 206, 207, 212,   3, 193, 206, 196,   2, 207, 210,   1,  58,
   75+    6, 206, 207, 210, 205, 193, 204,   3, 207, 215, 206,   8, 197, 216,
   76+  212, 197, 210, 206, 193, 204,   9, 197, 216, 212, 210, 201, 206, 211,
   77+  201, 195,   8, 195, 207, 206, 211, 212, 193, 206, 212,   5, 195, 207,
   78+  206, 211, 212,   5, 197, 214, 197, 206, 212,   5, 211, 212, 193, 210,
   79+  212,   9, 212, 200, 197, 206, 211, 212, 193, 210, 212,   4, 212, 200,
   80+  197, 206,   9, 197, 204, 211, 197, 211, 212, 193, 210, 212,   4, 197,
   81+  204, 211, 197,   1,  95,   6, 211, 217, 211, 212, 197, 205,   7, 196,
   82+  217, 206, 193, 205, 201, 195,   2,  42,  61,   1,  42,   4,  80,  85,
   83+   84,  95,   5,  67,  78,  79,  80,  95,   2, 204,  61,   1,  60,   1,
   84+   62,   4,  40, 196, 210,  43,   2, 196, 210,   1, 194,   3, 212, 207,
   85+  211,   3, 204, 206, 194,   3, 216, 206, 194,   2, 208, 195,   3, 195,
   86+  212, 194,   2,  45,  62,   6, 210, 197, 212, 213, 210, 206,   6, 210,
   87+  197, 211, 213, 204, 212,   7, 205, 207, 206, 201, 212, 207, 210,   4,
   88+  211, 212, 207, 208,   6, 211, 201, 199, 206, 193, 204,   4, 197, 216,
   89+  201, 212,   8, 195, 207, 206, 212, 201, 206, 213, 197,   6, 198, 201,
   90+  206, 201, 211, 200,   5, 195, 217, 195, 204, 197,   6, 210, 197, 208,
   91+  197, 193, 212,   3, 197, 206, 196,   5, 210, 197, 193, 204, 211,   5,
   92+  194, 197, 199, 201, 206,   2, 207, 206,   6, 211, 215, 201, 212, 195,
   93+  200,   4, 204, 201, 211, 212,   7, 211, 208, 197, 195, 201, 193, 204,
   94+   14, 212, 210, 213, 211, 212, 197, 196, 208, 210, 207, 199, 210, 193,
   95+  205,   6, 205, 193, 201, 206, 197, 208,   7, 195, 207, 206, 212, 210,
   96+  207, 204,   7, 201, 206, 195, 204, 213, 196, 197;
   97  
   98  
   99  
  100  
  101  {%CONST}%ownINTEGERARRAY SYMBOL(1300: 2213)=  1307,
  102+   1303,     0,  1305,     2,  1307,  1000,  1319,  1312,  1001,  1357,
  103+   1824,  1315,  1003,  1020,  1319,     4,  1336,     6,  1329,  1323,
  104+   1001,  1014,  1325,  1003,  1329,     4,  1329,     6,  1336,  1336,
  105+   1010,  1028,  1319,  1011,  1350,  1343,  1343,  1010,  1028,  1307,
  106+   1011,  1343,  1350,  1348,  1026,  1307,   999,  1350,  1000,  1357,
  107+   1355,  1026,  1319,   999,  1357,  1000,  1365,  1363,     4,  1336,
  108+   1365,     6,  1365,  1000,  1372,  1370,     8,  1336,   999,  1372,
  109+   1000,  1377,  1375,    10,  1377,    13,  1401,  1384,    20,  1010,
  110+   1542,  1562,  1011,  1390,    26,  1010,  1542,  1562,  1011,  1401,
  111+     32,  1010,  1001,    36,  1336,     8,  1336,     8,  1336,  1011,
  112+   1408,  1406,     8,  1001,   999,  1408,  1000,  1415,  1411,    38,
  113+   1413,    43,  1415,    51,  1430,  1418,    43,  1420,    38,  1423,
  114+     60,  1408,  1425,    65,  1428,    77,  1925,  1430,    84,  1437,
  115+   1433,    96,  1437,  1031,  1415,  1437,  1444,  1440,   104,  1442,
  116+    107,  1444,   111,  1466,  1450,  1415,  1476,  1001,  1401,  1456,
  117+    120,  1466,   127,  1001,  1401,  1462,  1430,  1471,  1001,  1401,
  118+   1483,  1466,   127,  1001,  1401,  1471,  1469,   132,  1471,  1000,
  119+   1476,  1474,   127,  1476,  1000,  1483,  1479,   138,  1481,   127,
  120+   1483,  1000,  1493,  1491,     4,  1010,  1444,  1011,  1493,     6,
  121+   1493,  1000,  1502,  1500,  1030,  1010,  1444,  1011,   999,  1502,
  122+   1000,  1513,  1506,   148,  1016,  1508,   158,  1511,   165,  1018,
  123+   1513,  1016,  1518,  1516,   172,  1518,  1000,  1542,  1526,   172,
  124+   1001,     4,  1876,  1869,     6,  1535,   179,  1010,  1001,  1818,
  125+   1011,     4,  1001,     6,  1542,  1010,  1615,  1011,     4,  1001,
  126+      6,  1556,  1548,  1336,  1032,  1336,  1556,  1553,     4,  1542,
  127+   1562,     6,  1556,   184,  1542,  1562,  1560,  1037,  1336,  1562,
  128+   1000,  1573,  1567,   188,  1542,  1573,  1571,   192,  1542,  1580,
  129+   1573,  1000,  1580,  1578,   188,  1542,   999,  1580,  1000,  1587,
  130+   1585,   192,  1542,   999,  1587,  1000,  1595,  1591,  1033,  1336,
  131+   1593,   195,  1595,  1000,  1601,  1599,   179,  1008,  1601,  1015,
  132+   1606,  1604,    60,  1606,   197,  1615,  1613,     8,  1336,   195,
  133+   1336,  1606,  1615,  1000,  1624,  1620,  1476,  1001,  1401,  1624,
  134+    132,  1513,  1624,  1630,  1630,  1001,  1401,  1832,  1630,  1636,
  135+   1634,     8,  1624,  1636,  1000,  1652,  1646,  1476,  1010,  1001,
  136+   1401,  1840,  1011,  1652,  1006,  1652,   132,  1513,  1001,  1832,
  137+   1701,  1663,  1661,     8,  1010,  1001,  1401,  1840,  1011,  1652,
  138+   1663,  1000,  1674,  1666,   204,  1668,   208,  1670,   217,  1672,
  139+    227,  1674,   236,  1701,  1678,  1415,  1636,  1689,   120,  1476,
  140+   1010,  1001,  1401,  1011,     4,  1001,     6,  1006,  1701,   120,
  141+    132,  1513,  1010,  1001,  1832,  1011,     4,  1001,     6,  1006,
  142+   1711,  1709,    36,  1028,  1319,  1350,  1722,  1711,  1711,  1000,
  143+   1722,  1720,     8,  1012,  1028,  1319,  1350,  1722,   999,  1722,
  144+   1000,  1731,  1729,     4,  1028,  1319,  1350,     6,  1731,  1000,
  145+   1738,  1736,     8,  1009,   999,  1738,  1000,  1743,  1741,   242,
  146+   1743,  1000,  1749,  1747,     8,  1336,  1749,  1000,  1762,  1760,
  147+      8,  1001,  1401,     4,  1336,   195,  1336,     6,   999,  1762,
  148+   1000,  1769,  1767,    26,  1542,  1562,  1769,  1000,  1782,  1772,
  149+   1019,  1774,  1006,  1779,  1372,  1542,  1562,  1006,  1782,  1377,
  150+   1006,  1795,  1786,   248,  1034,  1789,   254,  1034,  1795,   264,
  151+   1010,  2060,  1011,  1801,  1801,  1799,   188,  2060,  1801,  1000,
  152+   1818,  1805,   269,  1034,  1813,   279,  1372,  1010,  1542,  1562,
  153+   1011,  1782,  1816,   279,  2060,  1818,  1000,  1824,  1822,   284,
  154+   1001,  1824,  1000,  1832,  1830,   284,  1001,  1357,  1824,  1832,
  155+   1000,  1840,  1840,     4,  1336,   195,  1336,  1606,     6,  1848,
  156+   1846,    36,  1028,  1319,  1350,  1848,  1000,  1858,  1852,   286,
  157+   1013,  1854,   208,  1856,   293,  1858,  1000,  1869,  1867,  1001,
  158+     36,  1336,     8,  1336,     8,  1336,  1869,  1000,  1876,  1874,
  159+      8,  1876,   999,  1876,  1000,  1916,  1882,  1415,  1476,  1001,
  160+   1401,  1889,  1415,   132,  1001,  1401,  1832,  1916,  1895,   120,
  161+   1466,   127,  1001,  1401,  1904,   120,  1010,  1001,  1401,  1011,
  162+      4,  1001,     6,  1916,   120,   132,  1010,  1001,  1401,  1832,
  163+   1916,  1011,     4,  1001,     6,  1925,  1923,     8,  1001,  1401,
  164+   1832,   999,  1925,  1000,  1932,  1930,     4,  1009,     6,  1932,
  165+   1000,  1950,  1936,   301,  1001,  1939,   304,  1001,  1942,   306,
  166+   1002,  1945,  1022,  1950,  1950,   311,  1009,     8,  1009,  1964,
  167+   1954,  1023,  1964,  1959,  1024,   317,  2003,  2008,  1964,  1025,
  168+   1005,     8,  1987,  1987,  1969,   320,  1001,   322,  1971,  2036,
  169+   1976,     4,  2036,  2025,     6,  1980,   324,  2036,     6,  1985,
  170+      4,   329,  2025,     6,  1987,   332,  2003,  1992,   320,  1001,
  171+    322,  1994,  2036,  1999,     4,   329,  2025,     6,  2003,   324,
  172+   1005,     6,  2008,  2006,   329,  2008,  1005,  2016,  2014,     8,
  173+   1005,     8,  1005,  2016,  1000,  2025,  2020,     0,  1005,  2023,
  174+      2,  1005,  2025,  1000,  2031,  2029,     0,   332,  2031,  1000,
  175+   2036,  2034,    36,  2036,  1000,  2051,  2041,  2031,  1300,  1003,
  176+   2044,  1001,  2016,  2049,     4,  2051,  2016,     6,  2051,   334,
  177+   2060,  2054,   338,  2056,   342,  2058,   346,  2060,   349,  2093,
  178+   2069,  1010,  1001,  1357,  1824,  1011,  1587,  1795,  2073,   353,
  179+   1001,  1357,  2075,   356,  2079,   363,  1033,  1336,  2082,   370,
  180+   1795,  2084,   378,  2089,   383,  1738,  1009,  1743,  2091,   390,
  181+   2093,   395,  2214,  2100,  1027,  1010,  2060,  1011,  1769,  2102,
  182+   1007,  2110,  1372,  1010,  1542,  1562,  1011,  1782,  1006,  2115,
  183+    404,  1035,  1801,  1006,  2120,   411,  1029,  1858,  1006,  2125,
  184+    417,  1036,  1762,  1006,  2130,  1377,   411,  1029,  1006,  2136,
  185+   1031,  1008,  1415,  1615,  1006,  2140,   424,  1502,  1006,  2144,
  186+    120,  1518,  1006,  2153,  1010,  1848,  1430,  1011,  1595,  1001,
  187+   1483,  1006,  2156,  1663,  1674,  2160,   428,  1601,  1006,  2164,
  188+    434,  1015,  1006,  2173,   440,  1021,  1738,  1009,  1731,   248,
  189+   1034,  1006,  2184,   443,  1001,  1401,     4,  1336,   195,  1336,
  190+      6,  1749,  1006,  2188,   450,  1006,  1017,  2193,   455,   127,
  191+   1001,  1006,  2197,   304,  1932,  1006,  2200,   463,  1006,  2204,
  192+    478,  1001,  1006,  2208,   485,  1003,  1006,  2212,   493,  1003,
  193+   1038,  2214,  1006;
  194  
  195  %CONSTINTEGER SS= 2093
  196  
  197  !
  198  %CONST %BYTE %INTEGER %ARRAY I TO E TAB(0 : 127) =       {%C
  199+ 16_40,16_40,16_40,16_40,16_40,16_40,16_40,16_40,
  200+ 16_40,16_40,16_15,16_40,16_0C,16_40,16_40,16_40,
  201+ 16_40,16_40,16_40,16_40,16_40,16_40,16_40,16_40,
  202+ 16_40,16_40,16_40,16_40,16_40,16_40,16_40,16_40,
  203+ 16_40,16_4F,16_7F,16_7B,16_5B,16_6C,16_50,16_7D,
  204+ 16_4D,16_5D,16_5C,16_4E,16_6B,16_60,16_4B,16_61,
  205+ 16_F0,16_F1,16_F2,16_F3,16_F4,16_F5,16_F6,16_F7,
  206+ 16_F8,16_F9,16_7A,16_5E,16_4C,16_7E,16_6E,16_6F,
  207+ 16_7C,16_C1,16_C2,16_C3,16_C4,16_C5,16_C6,16_C7,
  208+ 16_C8,16_C9,16_D1,16_D2,16_D3,16_D4,16_D5,16_D6,
  209+ 16_D7,16_D8,16_D9,16_E2,16_E3,16_E4,16_E5,16_E6,
  210+ 16_E7,16_E8,16_E9,16_4A,16_5F,16_5A,16_6A,16_6D,
  211+ 16_7C,16_81,16_82,16_83,16_84,16_85,16_86,16_87,
  212+ 16_88,16_89,16_91,16_92,16_93,16_94,16_95,16_96,
  213+ 16_97,16_98,16_99,16_A2,16_A3,16_A4,16_A5,16_A6,
  214+ 16_A7,16_A8,16_A9,16_C0,16_40,16_D0,16_40,16_40
  215  %CONSTINTEGERARRAY OPC(0:126)=0,
  216+ M' JCC',M' JAT',M' JAF',0(4),
  217+ M' VAL',M' CYD',M'INCA',M'MODD',M'PRCL',M'   J',M' JLK',M'CALL',
  218+ M' ADB',M' SBB',M'DEBJ',M' CPB',M' SIG',M' MYB',M' VMY',M'CPIB',
  219+ M' LCT',M'MPSR',M'CPSR',M'STCT',M'EXIT',M'ESEX',M' OUT',M' ACT',
  220+ M'  SL',M'SLSS',M'SLSD',M'SLSQ',M'  ST',M'STUH',M'STXN',M'IDLE',
  221+ M' SLD',M' SLB',M'TDEC',M'INCT',M' STD',M' STB',M'STLN',M'STSF',
  222+ M'   L',M' LSS',M' LSD',M' LSQ',M'RRTC',M' LUH',M'RALN',M' ASF',
  223+ M'LDRL',M' LDA',M'LDTB',M' LDB',M'  LD',M'  LB',M' LLN',M' LXN',
  224+ M' TCH',M'ANDS',M' ORS',M'NEQS',M'EXPA',M' AND',M'  OR',M' NEQ',
  225+ M'  PK',M' INS',M'SUPK',M' EXP',M'COMA',M' DDV',M'DRDV',M'DMDV',
  226+ M'SWEQ',M'SWNE',M' CPS',M' TTR',M' FLT',M' IDV',M'IRDV',M'IMDV',
  227+ M' MVL',M'  MV',M'CHOV',M' COM',M' FIX',M' RDV',M'RRDV',M'RDVD',
  228+ M' UAD',M' USB',M'URSB',M' UCP',M' USH',M' ROT',M' SHS',M' SHZ',
  229+ M' DAD',M' DSB',M'DRSB',M' DCP',M' DSH',M' DMY',M'DMYD',M'CBIN',
  230+ M' IAD',M' ISB',M'IRSB',M' ICP',M' ISH',M' IMY',M'IMYD',M'CDEC',
  231+ M' RAD',M' RSB',M'RRSB',M' RCP',M' RSC',M' RMY',M'RMYD';
  232  %CONSTBYTEINTEGERARRAY ONE CASE(0 : 127) =   {%C
  233+        0, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15,
  234+       16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,
  235+       32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,
  236+       48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,
  237+       64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,
  238+       80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,
  239+       96,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,
  240+       80,81,82,83,84,85,86,87,88,89,90,123,124,125,126,127;
  241  %CONSTINTEGERARRAY TSNAME (0:62)=16_1000(8),
  242+                16_1001,16_1000(5),16_1001,16_1062,16_1001(2),16_1062,
  243+                16_1000(2),16_52,16_51,16_62,16_1062(7),
  244+                16_1000,16_31,16_51,16_1062(2),16_31,16_1000,
  245+                 16_51,16_62,16_1000(2),16_35,16_1000,16_1035,
  246+                 16_31,16_35,16_1035,16_33,0,16_1000,16_31,16_52,16_51,
  247+                 16_61,16_72,16_61,16_72,16_51,16_62,16_1051,16_41,
  248+                16_1000;
  249  !
  250  %OWNINTEGERARRAY FIXED GLA(0:11)=0,
  251+                16_50000000,0(2),-1,0,0(6);
  252  %CONSTBYTEINTEGERARRAY BYTES(0:7)=0(3),1,2,4,8,16;
  253  %CONSTBYTEINTEGERARRAY TRTAB(0:255)=0(48),
  254+                     1(10),0(7),2(26),0(6),2(26),0(5),0(128)
  255  %CONSTINTEGER MAXLEVELS=31,CONCOP=13,FIXEDGLALEN=48
  256  %CONSTINTEGER JOBBERBIT=16_40000000;    ! SET IN JOBBER MODE
  257  %CONSTINTEGER CEBIT=1;                  ! SET IN COMPILER ENVIRONMENT
  258  %CONSTINTEGER MAXDICT=16_100;           ! SET FOR MAX OF EVERYTHING
  259  !
  260  ! THE PRINCIPAL OPCODES ARE HERE DEFINED AS THEIR MNEMONICS(AMENDED)
  261  !
  262  %CONSTINTEGER LB=16_7A,SLB=16_52,STB=16_5A,ADB=16_20,CPB=16_26, {%C
  263+               MYB=16_2A,SBB=16_22,CPIB=16_2E,OUT=16_3C,CPSR=16_34
  264  %CONSTINTEGER LD=16_78,LDA=16_72,INCA=16_14,STD=16_58,LDB=16_76, {%C
  265+               LDTB=16_74,LDRL=16_70,CYD=16_12,MODD=16_16,SLD=16_50
  266  %CONSTINTEGER STLN=16_5C,ASF=16_6E,ST=16_48,RALN=16_6C,LXN=16_7E,{%C
  267+               LLN=16_7C,LSS=16_62,SLSS=16_42,MPSR=16_32,STSF=16_5E,{%C
  268+               LUH=16_6A,STUH=16_4A,LSD=16_64,SLSD=16_44,PRCL=16_18, {%C
  269+               LSQ=16_66,SLSQ=16_46,STXN=16_4C,LCT=16_30,STCT=16_36
  270  %CONSTINTEGER JUNC=16_1A,JLK=16_1C,CALL=16_1E,EXIT=16_38,JCC=2, {%C
  271+               JAT=4,JAF=6,DEBJ=16_24
  272  %CONSTINTEGER IAD=16_E0,ICP=16_E6,USH=16_C8,ISB=16_E2,IRSB=16_E4,{%C
  273+               OR=16_8C,UCP=16_C6,IMY=16_EA,IMDV=16_AE,AND=16_8A, {%C
  274+               ISH=16_E8,IMYD=16_EC,IDV=16_AA
  275  %CONSTINTEGER RAD=16_F0,RSB=16_F2,RRSB=16_F4,FLT=16_A8,RRDV=16_BC, {%C
  276+               RSC=16_F8,FIX=16_B8,RDV=16_BA,RDDV=16_BE,RMYD=16_FC, {%C
  277+               RMY=16_FA
  278  !
  279  %CONSTINTEGER MVL=16_B0,MV=16_B2,SWEQ=16_A0,SWNE=16_A2,CPS=16_A4
  280  !
  281  ! DEFINE SOME MNEMONICS FOR THE VISIBLE REGISTERS (XCEPT LNB)
  282  !
  283  %CONSTINTEGER ACCR=0,DR=1,LNB=2,XNB=3,PC=4,CTB=5,TOS=6,BREG=7
  284  %CONSTBYTEINTEGERARRAY LDCODE(0:7)=0,16_78,16_7C,16_7E,0,48,0,16_7A;
  285  !
  286  %CONSTSTRING(8)MDEP="S#NDIAG"
  287  %CONSTSTRING(8)IOCPEP="S#IOCP";     ! EP FOR IOCP
  288  %CONSTSTRING(11)AUXSTEP="ICL9CEAUXST";! DATA REF FOR INDIRECT AUX ST
  289  %CONSTINTEGER SNPT=16_1006;         ! SPECIALNAME PTYPE
  290  %CONSTINTEGER COMMALT=2,ENDALT=9,UNASSPAT=16_81818181,DECALT=8
  291  !
  292  %INTEGER DICTBASE, CONSTPTR, CONSTBTM, DFHEAD, CONSTHOLE,  WKFILEAD, {%C
  293+          WKFILEK, DUMMYFORMAT, P1SIZE, LEVELINF, IOCPDISP, PARMBITS1, {%C
  294+          PARMBITS2,PARMLET
  295  !
  296  %INTEGER ASL, NNAMES, ARSIZE, CABUF, PPCURR, CONSTLIMIT, OLDLINE, {%C
  297+          LINE, LENGTH, NEXTP, SNUM, RLEVEL, NMAX, USTPTR, PLABEL,{%C
  298+          LEVEL, CA, LASTNAME, CDCOUNT, ASL CUR BTM, PARMDYNAMIC
  299  !
  300  %INTEGER FAULTY, HIT, INHCODE, IMPS, TTOPUT, LIST, PARMDIAG, {%C
  301+             WARNFLAG, PARMTRACE, PARMLINE, PARMOPT, CTYPE, DCOMP, {%C
  302+            CPRMODE, PARMCHK, PARMARR, ALLLONG, PARMDBUG,{%C
  303+             COMPILER, LAST INST, SMAP, STACK, AUXST, PARMY, BFFLAG
  304  !
  305  %INTEGER RBASE, N, FREE FORMAT, PARMPROF, EXITLAB, CONTLAB,  {%C
  306+          Q, R, S, NEST, FNAME, LDPTR, GLACA, GLACABUF, {%C
  307+          GLACURR, CREFHEAD, SSTL, QMAX, STMTS, LASTAT, {%C
  308+          FILE ADDR, FILE PTR, FILE END, FILE SIZE, LASTEND, {%C
  309+          BIMSTR,STLIMIT,STRLINK,RECTB,ASL WARN,IHEAD
  310  !
  311  %INTEGER MAX ULAB, SFLABEL
  312  %LONGREAL CVALUE, IMAX, CTIME
  313  %STRING(31)MAINEP
  314  %RECORDFORMAT LISTF(%INTEGER S1,S2,S3,LINK)
  315  %INTEGER LOGEPDISP,EXPEPDISP
  316  !
  317  %SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N)
  318  %BEGIN
  319        FILE ADDR=COMREG(46);          ! SOURCE FILE IF CLEAN
  320        PARMBITS1=COMREG(27)
  321        PARMBITS2=COMREG(28)
  322        WKFILEAD=COMREG(14)
  323        {WKFILEK=INTEGER(WKFILEAD+8)>>10
  324        wkfilek = 128
  325        %IF FILE ADDR<=0 %THEN FILESIZE=64000 %AND FILE ADDR=0 %ELSESTART
  326           FILE PTR=FILE ADDR+INTEGER(FILE ADDR+4)
  327           FILE END=FILE ADDR+INTEGER(FILE ADDR)
  328           FILE SIZE=INTEGER(FILE ADDR)
  329        %FINISH
  330        NNAMES=255
  331        %IF FILESIZE>10000 %THEN NNAMES=511
  332        %IF PARMBITS1&JOBBER BIT=0 %START
  333           %IF FILESIZE>32000 %THEN NNAMES=1023
  334           %IF FILESIZE>256*1024 %OR PARMBITS2&MAXDICT#0 %OR WKFILEK>512 %THEN NNAMES=2047
  335        %FINISH
  336        ASL=3*NNAMES
  337        ASL=4095 %IF ASL>4095 %AND PARMBITS2&MAXDICT=0;! STAY WITHIN 128K AUXSTACK
  338        ARSIZE=WKFILEK*768-300
  339  {%END  ... extra block level enables dynamic array bound declarations ...
  340  {%BYTEINTEGERARRAYFORMAT AF(0:ARSIZE)
  341  {%BYTEINTEGERARRAYNAME A
  342  %byteintegerarray A(0:WKFILEK*1024)
  343  %RECORD(LISTF)%ARRAY ASLIST(0:ASL){(LISTF)
  344  %INTEGERARRAY WORD, TAGS(0:NNAMES)
  345  %INTEGERARRAY DVHEADS(0:12)
  346  %INTEGERFNSPEC FROMAR4(%INTEGER PTR)
  347  %INTEGERFNSPEC FROMAR2(%INTEGER PTR)
  348  %ROUTINESPEC TOAR8(%INTEGER PTR, %LONGREAL VALUE)
  349  %ROUTINESPEC TOAR4(%INTEGER PTR, VALUE)
  350  %ROUTINESPEC TOAR2(%INTEGER PTR,VALUE)
  351  %ROUTINESPEC WARN(%INTEGER N,V)
  352  %ROUTINESPEC FAULT2(%INTEGER N,VAL,IDEN)
  353  %ROUTINESPEC FAULT(%INTEGER N, VALUE)
  354  %STRING(255)%FNSPEC PRINTNAME(%INTEGER N)
  355  %INTEGERFNSPEC MORE SPACE
  356  !%INTEGERFNSPEC NEWCELL
  357  %ROUTINESPEC INSERTATEND(%INTEGERNAME S, %INTEGER A, B, C)
  358  %ROUTINESPEC FROM12(%INTEGER CELL, %INTEGERNAME S1, S2)
  359  %ROUTINESPEC FROM123(%INTEGER CELL, %INTEGERNAME S1, S2, S3)
  360  %ROUTINESPEC POP(%INTEGERNAME C, P, Q, R)
  361  %ROUTINESPEC PUSH(%INTEGERNAME C, %INTEGER S1, S2, S3)
  362  %INTEGERFNSPEC FIND(%INTEGER LAB, LIST)
  363  %ROUTINESPEC MLINK(%INTEGERNAME CELL)
  364  %ROUTINESPEC REPLACE1(%INTEGER CELL, S1)
  365  %ROUTINESPEC REPLACE2(%INTEGER CELL, S2)
  366  %ROUTINESPEC REPLACE3(%INTEGER CELL,S3)
  367  %ROUTINESPEC REPLACE123(%INTEGER CELL,A1,A2,S3)
  368  %INTEGERFNSPEC FROM2(%INTEGER CELL)
  369  %INTEGERFNSPEC FROM1(%INTEGER CELL)
  370  %INTEGERFNSPEC FROM3(%INTEGER CELL)
  371  %ROUTINESPEC BINSERT(%INTEGERNAME T,B,%INTEGER S1,S2,S3)
  372  %ROUTINESPEC CLEARLIST(%INTEGERNAME HEAD)
  373  %STRING(255)%FNSPEC MESSAGE(%INTEGER N)
  374  %SYSTEMROUTINESPEC LPUT(%INTEGER A, B, C, D)
  375  %SYSTEMLONGREALFNSPEC CPUTIME
  376  !*DELSTART
  377  %SYSTEMROUTINESPEC NCODE(%INTEGER START, FINISH, CA)
  378  %ROUTINESPEC PRINTLIST(%INTEGER HEAD)
  379  %ROUTINESPEC PRHEX(%INTEGER VALUE,PLACES)
  380  %ROUTINESPEC CHECK ASL
  381  !*DELEND
  382  %IF VMEB=NO %THEN %START
  383        %SYSTEMROUTINESPEC CONSOURCE(%STRING(31)FILE,%INTEGERNAME AD)
  384  %FINISH
  385           ! START OF COMPILATION
  386           {A==ARRAY(WKFILE AD+256*WKFILEK, AF)
  387           %BEGIN
  388  !***********************************************************************
  389  !*       THIS BLOCK INITIALISE THE COMPILER SCALARS AND ARRAYS         *
  390  !*       WAS ORIGINALLY ROUTINE 'INITIALISE'.                          *
  391  !*       THE INITIALISATION OF THE CONSTANT LISTS WITH THE VALUES      *
  392  !*       IN PERM MAY BE OMITTED IN BATCH OR CUT-DOWN VERSIONS.         *
  393  !***********************************************************************
  394  %ROUTINESPEC READ LINE(%INTEGER MODE,CHAR)
  395  %INTEGERFNSPEC COMPARE(%INTEGER P)
  396  %ROUTINESPEC PNAME(%INTEGER MODE)
  397  %ROUTINESPEC CONST(%INTEGER MODE)
  398  %ROUTINESPEC TEXTTEXT(%INTEGER EBCDIC)
  399  %INTEGER CCSIZE,DSIZE,NEXT,ATLINE1,STARSTART
  400        CCSIZE=1000; DSIZE=7*NNAMES
  401  %INTEGERARRAY DISPLAY,SFS(0:MAXLEVELS)
  402  %BYTEINTEGERARRAY  TLINE(-60:161),CC(0:CCSIZE),LETT(0:DSIZE+20)
  403  %LONGINTEGER ATL0,ASYM0
  404  %CONSTBYTEINTEGERARRAY ILETT(0: 500)= 11,
  405+     'S','E','L','E','C','T','I','N','P','U','T', 12,'S','E','L','E',
  406+     'C','T','O','U','T','P','U','T',  7,'N','E','W','L','I','N','E',
  407+       5,'S','P','A','C','E', 10,'S','K','I','P','S','Y','M','B','O',
  408+     'L', 10,'R','E','A','D','S','T','R','I','N','G',  8,'N','E','W',
  409+     'L','I','N','E','S',  6,'S','P','A','C','E','S', 10,'N','E','X',
  410+     'T','S','Y','M','B','O','L', 11,'P','R','I','N','T','S','Y','M',
  411+     'B','O','L', 10,'R','E','A','D','S','Y','M','B','O','L',  4,'R',
  412+     'E','A','D',  5,'W','R','I','T','E',  7,'N','E','W','P','A','G',
  413+     'E',  4,'A','D','D','R',  6,'A','R','C','S','I','N',  3,'I','N',
  414+     'T',  5,'I','N','T','P','T',  6,'F','R','A','C','P','T',  5,'P',
  415+     'R','I','N','T',  7,'P','R','I','N','T','F','L',  4,'R','E','A',
  416+     'L',  7,'I','N','T','E','G','E','R',  3,'M','O','D',  6,'A','R',
  417+     'C','C','O','S',  4,'S','Q','R','T',  3,'L','O','G',  3,'S','I',
  418+     'N',  3,'C','O','S',  3,'T','A','N',  3,'E','X','P', 11,'C','L',
  419+     'O','S','E','S','T','R','E','A','M', 11,'B','Y','T','E','I','N',
  420+     'T','E','G','E','R',  8,'E','V','E','N','T','I','N','F',
  421+     6,'R','A','D','I','U','S',  6,'A','R','C','T','A','N',
  422+       6,'L','E','N','G','T','H', 11,'P','R','I','N','T','S','T','R',
  423+     'I','N','G',  2,'N','L',  8,'L','O','N','G','R','E','A','L',  7,
  424+     'P','R','I','N','T','C','H',  6,'R','E','A','D','C','H',  6,'S',
  425+     'T','R','I','N','G',  8,'R','E','A','D','I','T','E','M',  8,'N',
  426+     'E','X','T','I','T','E','M',  6,'C','H','A','R','N','O',  8,'T',
  427+     'O','S','T','R','I','N','G', 10,'F','R','O','M','S','T','R','I',
  428+     'N','G',  6,'R','E','C','O','R','D',  5,'A','R','R','A','Y', 10,
  429+     'S','E','T','M','A','R','G','I','N','S',4,'I','M','O','D',2,'P',
  430+     'I',9,'E','V','E','N','T','L','I','N','E',11,'L','O','N','G',
  431+     'I','N','T','E','G','E','R',12,'L','O','N','G','L','O','N','G',
  432+     'R','E','A','L',9,'L','E','N','G','T','H','E','N','I',
  433+      9,'L','E','N','G','T','H','E','N','R',
  434+      8,'S','H','O','R','T','E','N','I',
  435+      8,'S','H','O','R','T','E','N','R',
  436+       6,'N','E','X','T','C','H',
  437+       11,'H','A','L','F','I','N','T','E','G','E','R',
  438+       8,'P','P','R','O','F','I','L','E',255;
  439           IMAX=(-1)>>1;PLABEL=24999
  440           LETT(0)=0
  441           ATLINE1=ADDR(TLINE(1))
  442           INTEGER(ADDR(ATL0)+4)=ATLINE1-1
  443           INTEGER(ADDR(ATL0))=16_18000100
  444           INTEGER(ADDR(ASYM0))=16_28000C00
  445           INTEGER(ADDR(ASYM0)+4)=ADDR(SYMBOL(1300))-4*1300
  446           N=12;
  447           MAX ULAB=NNAMES+16384;   ! LARGEST VALID USER LABEL
  448           GLACURR=0; GLACA=FIXEDGLALEN; GLACABUF=GLACA
  449           PARMOPT=1 ;  PARMARR=1;  LAST INST=0
  450           PARMLINE=1; PARMTRACE=1;  PARMDIAG=1
  451           LIST=1; SFLABEL=20999; PARMCHK=1
  452           EXITLAB=0; CONTLAB=0
  453           CABUF=0;  PPCURR=0;  OLDLINE=0; COMPILER=0
  454           RLEVEL=0;  NMAX=0;  USTPTR=0
  455           LEVEL=0;  CA=0;  LASTAT=0
  456           FAULTY=0;  WARNFLAG=0; ALLLONG=0; INHCODE=0
  457           DCOMP=0;  BFFLAG=0;  CPRMODE=0
  458           NEXT=1;  LDPTR=0
  459           IOCPDISP=0; CREFHEAD=0; AUXST=0
  460           RBASE=10;  LOGEPDISP=0;  EXPEPDISP=0; STRLINK=0
  461           RECTB=0; IHEAD=0
  462           SSTL=0;  STMTS=1;  SNUM=0;  LEVELINF=0
  463           CDCOUNT=0
  464           BIMSTR=0
  465           LOGEPDISP=0; EXPEPDISP=0
  466           MAINEP="S#GO";                 ! DEFAULT MAIN ENTRY
  467           DICTBASE=ADDR(LETT(0))
  468  !
  469  ! OPEN OBJECT FILE HERE BEFORE MORE PAGES OF COMPILER CODE
  470  ! ARE PAGED IN AND SUB-SYSTEM PAGES MOVE OUT
  471  !
  472           LPUT(0,0,0,0)
  473           CTIME=CPUTIME
  474           I=COMREG(27)
  475           STLIMIT=16_1F000
  476           %IF I>>24&1#0 %THEN STLIMIT=COMREG(48)-4096
  477           %IF I&2=2 %THEN LIST=0
  478           %IF I&4=4 %THEN PARMDIAG=0
  479           %IF I&16_800000#0 %THEN PARMLINE=0
  480           %IF I&16=16 %THEN PARMCHK=0
  481           %IF I&32=32  %THEN PARMARR=0
  482           PARMPROF=(I>>15&1)!(I>>7&1);   ! USE MAP OR PROFILE BIT PRO TEM
  483           PARMDYNAMIC=I>>20&1
  484           PARMLET=I>>13&1
  485           DCOMP=I>>14&1;                 ! PARM CODE OR D
  486           PARMDBUG=I>>18&1
  487           %IF I&64=64 %THEN PARMTRACE=0 %AND PARMDIAG=0
  488           FREE FORMAT=I&16_80000
  489           STACK=I>>3&1
  490           SMAP=I>>26&1;                 ! USE PARMZ BIT FOR DUMPING WKFILE
  491           TTOPUT=COMREG(40)
  492           %IF I&(1<<16)#0 %THEN %START
  493              PARMARR=0; PARMOPT=0
  494              PARMLINE=0; PARMCHK=0; PARMDIAG=0
  495           %FINISH
  496           PARMTRACE=PARMTRACE!PARMOPT;   ! ALLOW NOTRACE ONLY WITH OPT
  497           IMPS=I>>23&1;              ! BIT SET IF IMPS REQUESTED
  498           IMPS=1;                        ! FOR TESTING
  499           NEWLINES(3); SPACES(14)
  500           PRINTSTRING("ERCC. Imp")
  501           %IF IMPS#0 %THEN PRINTSYMBOL('s')
  502           PRINTSTRING(" Compiler Release")
  503           WRITE(RELEASE,1)
  504           PRINTSTRING(" Version ".LADATE)
  505           NEWLINES(3)
  506           WRITE(NNAMES,5); WRITE(ASL,5)
  507           NEWLINE
  508           ASL WARN=0
  509           ASL CUR BTM=ASL-240
  510           CONST LIMIT=4*ASL CUR BTM-8
  511           %CYCLE I=ASL CUR BTM,1,ASL-1
?Non-local
  512               ASLIST(I+1)_LINK=I
  513           %REPEAT
  514           ASLIST(ASL CUR BTM)_LINK=0
  515           ASLIST(0)_S1=-1
  516           ASLIST(0)_S2=-1
  517           ASLIST(0)_S3=-1
  518           ASLIST(0)_LINK=0
  519           %CYCLE I=0,1,NNAMES
?Non-local
  520               WORD(I)=0; TAGS(I)=0;
  521           %REPEAT
  522           %CYCLE I=0,1,12
?Non-local
  523              DVHEADS(I)=0
  524           %REPEAT
  525  !
  526  ! NOW DECLARE THE SPECIAL NAMES WHICH ARE IN ARRAY ILETT.
  527  !
  528           K=0; NEXT=1
  529           I=ILETT(0)
  530           %WHILE I<255 %CYCLE
  531              %CYCLE J=I,-1,1
?Non-local
  532                  CC(J)=ILETT(K+J)
  533              %REPEAT
  534              CC(I+1)=';'
  535              R=2; Q=1; PNAME(1)
  536              PUSH(TAGS(LASTNAME),SNPT<<16!16_8000,0,SNUM<<16)
  537              SNUM=SNUM+1
  538              K=K+I+1; I=ILETT(K)
  539           %REPEAT
  540  !
  541           COMREG(24)=16;                ! RETURN CODE
  542           DUMMY FORMAT=0;        ! DUMMY RECORD FORMAT
  543           DFHEAD=0
  544           PUSH(DFHEAD,0,0,0)
  545           PUSH(DUMMY FORMAT,0,0,DFHEAD); ! FOR BETTER ERROR RECOVERY
  546           LINE=0; LENGTH=0; Q=1
  547           R=1;  LEVEL=1
  548           %CYCLE
  549              %IF Q>=LENGTH %THEN QMAX=1 %AND READ LINE(0,0)
  550              WARNFLAG=0
  551              STARSTART=R
  552              R=R+3
  553              OLDLINE=LINE
  554              A(R)=LINE>>8
  555              A(R+1)=LINE&255
  556              R=R+2
  557              %IF COMPARE(SS)=0 %THEN %START
  558                 FAULT(100,ADDR(CC(0)))
  559                 R=STARSTART
  560              %FINISH %ELSE %START
  561                 FAULT(102, 0) %IF R>ARSIZE
  562                 %IF A(STARSTART+5)=COMMALT %THEN R=STARSTART %ELSE %START
  563                    I=R-STARSTART
  564                    A(STARSTART)=I>>16
  565                    A(STARSTART+1)=I>>8&255
  566                    A(STARSTART+2)=I&255
  567                    %IF A(STARSTART+5)=DECALT %AND LEVEL>1 %THEN %START
  568                       %IF SFS(LEVEL)=0 %THEN %START
  569                          TO AR4(DISPLAY(LEVEL),STARSTART)
  570                          DISPLAY(LEVEL)=STARSTART+6
  571                       %FINISH %ELSE A(STARSTART+6)=128;!  FLAG AS UNLINKED
  572                    %FINISH
  573  !*DELSTART
  574                    %IF SMAP#0 %THEN %START
  575                       NEWLINE;  WRITE(LINE, 5)
  576                       WRITE(STARSTART,5);  NEWLINE; J=0
  577                       %CYCLE I=STARSTART, 1, R-1
?Non-local
  578                          WRITE(A(I), 5)
  579                       J=J+1
  580                       %IF J>=20 %THEN NEWLINE %AND J=0
  581                       %REPEAT
  582                       NEWLINE
  583                    %FINISH
  584  !*DELEND
  585                    %EXIT %IF A(STARSTART+5)=ENDALT %AND 1<=A(STARSTART+6)<=2;! ENDOF PROG OR FILE
  586                    %IF LEVEL=0 %THEN FAULT(14, 0) %AND %EXIT
  587                 %FINISH
  588              %FINISH
  589           %REPEAT
  590           TO AR8(R,0); R=R+8
  591           %IF R+NEXT>ARSIZE %THEN FAULT(102,0)
  592           P1SIZE=R
  593  !        %IF USE IMP=YES %THEN %START
  594              %CYCLE I=0,1,NEXT
?Non-local
  595                 A(R+I)=LETT(I)
  596              %REPEAT
  597  !        %FINISH %ELSE %START
  598  !           *LDTB_16_18000000
  599  !           *LDB_NEXT
  600  !           *LDA_LETT+4
  601  !           *CYD_0
  602  !           *LDA_A+4
  603  !           *INCA_R
  604  !           *MV_%L=%DR
  605  !        %FINISH
  606           DICTBASE=ADDR(A(R))
  607           R=R+NEXT+1
  608           ->BEND
  609  %ROUTINE READ LINE(%INTEGER MODE,CHAR)
  610  %ROUTINESPEC GET LINE
  611  %INTEGER DEL, LL, LP
  612        LL=0;  LP=0; Q=1
  613        LENGTH=0;  DEL=0
  614  NEXT:
  615  !     %IF USE IMP=YES %THEN %START
  616           LP=LP+1
  617           %IF LP>LL %THEN GET LINE %AND LP=1
  618           I=TLINE(LP)
  619           %IF MODE=0 %THEN %START
  620              %IF I='%' %THEN DEL=128 %AND ->NEXT
  621              I=ONE CASE(I)
  622              %IF 'A'<=I<='Z' %THEN I=I!DEL %ELSE %START
  623                 DEL=0
  624                 ->NEXT %IF I=' '
  625              %FINISH
  626              LENGTH=LENGTH+1
  627              CC(LENGTH)=I
  628              %IF I='''' %OR I=34 %THEN MODE=1 %AND CHAR=I
  629           %FINISH %ELSE %START
  630              LENGTH=LENGTH+1
  631              CC(LENGTH)=I
  632              %IF I=CHAR %THEN MODE=0
  633           %FINISH
  634           ->NEXT %UNLESS I=NL
  635  !     %FINISH %ELSE %START
  636  !        *LB_LP
  637  !        *ADB_1
  638  !        *CPB_LL
  639  !        *JCC_12,<RLL1>
  640  !        GET LINE
  641  !        *LB_1
  642  !RLL1:
  643  !        *STB_LP
  644  !        *LB_(ATL0+%B)
  645  !        *LSS_MODE
  646  !        *JAF_4,<RLL2>
  647  !        *CPB_37;                       !'%'      
  648  !        *JCC_7,<RLL3>
  649  !        *L_128
  650  !        *ST_DEL
  651  !        *J_<NEXT>
  652  !RLL3:
  653  !        *LSS_(ONE CASE+%B);            ! LOWER CASE TO UPPER
  654  !        *ICP_65;                       !'A'
  655  !        *JCC_4,<RLL4>
  656  !        *ICP_90;                       !'Z'
  657  !        *JCC_2,<RLL4>
  658  !        *OR_DEL
  659  !        *J_<RLL5>
  660  !RLL4:
  661  !        *LB_0
  662  !        *STB_DEL
  663  !        *ICP_32;                       !' '
  664  !        *JCC_8,<NEXT>
  665  !RLL5:
  666  !        *LB_LENGTH
  667  !        *ADB_1
  668  !        *STB_LENGTH
  669  !        *ST_(CC+%B)
  670  !        *ICP_39;                       !''''
  671  !        *JCC_8,<RLL6>
  672  !        *ICP_34;                       !'"'
  673  !        *JCC_7,<RLL7>
  674  !RLL6:
  675  !        *ST_CHAR
  676  !        *LB_1
  677  !        *STB_MODE
  678  !RLL7:
  679  !        *ICP_10
  680  !        *JCC_7,<NEXT>
  681  !        *J_<RLL8>
  682  !RLL2:
  683  !        *LSS_%B
  684  !        *LB_LENGTH
  685  !        *ADB_1
  686  !        *STB_LENGTH
  687  !        *ST_(CC+%B)
  688  !        *ICP_CHAR
  689  !        *JCC_7,<RLL9>
  690  !        *LB_0
  691  !        *STB_MODE
  692  !RLL9:
  693  !        *ICP_10
  694  !        *JCC_7,<NEXT>
  695  !RLL8:
  696  !     %FINISH
  697        %IF CC(LENGTH-1)='C'+128 %THEN LENGTH=LENGTH-2 %AND ->NEXT
  698        FAULT(101,0) %IF LENGTH>CCSIZE
  699        %RETURN
  700  %ROUTINE GET LINE
  701  %SYSTEMROUTINESPEC IOCP(%INTEGER A,B)
  702  %CONSTBYTEINTEGERARRAY ITOI(0:255)={%C
  703+                   32(10),10,32(14),25,26,32(5),
  704+                   32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,
  705+                   48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,
  706+                   64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,
  707+                   80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,
  708+                   96,97,98,99,100,101,102,103,104,105,106,107,108,109,
  709+                   110,111,112,113,114,115,116,117,118,119,
  710+                   120,121,122,123,124,125,126,32,
  711+                   26(5),10,26(10),
  712+                   26(16),
  713+                   26(14),92,38,
  714+                   26(11),35,26(4),
  715+                   26(16),
  716+                   26(9),35,26(5),94,
  717+                   26(32);
  718  %INTEGER K
  719        LL=0
  720        %IF FILE ADDR=0 %THEN %START;     ! SOURCE NOT A 'CLEAN' FILE
  721           {%UNTIL K=NL} %CYCLE
  722              READ SYMBOL(K)
  723              TLINE(LL+1)=ITOI(K)
  724              LL=LL+1
  725           %REPEAT %UNTIL K=NL
  726        %FINISH %ELSE %START
  727          %IF FILEPTR>=FILE END %START
  728              %IF IHEAD#0 %THEN POP(IHEAD,FILEADDR,FILEPTR,FILEEND) %AND GETLINE %AND %RETURN
  729                 %SIGNAL %EVENT 9,1
  730           %FINISH
  731  !        %IF USE IMP=NO %THEN %START
  732  !           *LDA_FILEPTR
  733  !           *LB_FILEEND
  734  !           *SBB_FILEPTR
  735  !           *ADB_16_18000000
  736  !           *LDTB_%B
  737  !           *SWNE_%L=%DR,0,10
  738  !           *JCC_8,<IMP>
  739  !           *CYD_0
  740  !           *STUH_%B
  741  !           *IAD_1
  742  !           *ST_%B
  743  !           *ISB_FILEPTR
  744  !           *ST_LL
  745  !           *LDA_FILEPTR
  746  !           *STB_FILEPTR
  747  !           *LDB_LL
  748  !           *CYD_0
  749  !           *LDA_ATLINE1
  750  !           *MV_%L=%DR,0,0
  751  !           *LDA_ATLINE1; *LDTB_16_18000000
  752  !           *LDB_LL
  753  !           *LSS_ITOI+4; *LUH_16_180000FF
  754  !           *TTR_%L=%DR
  755  !           ->OLIST
  756  !        %FINISH
  757  IMP:
  758           {%UNTIL K=NL %OR K=0} %CYCLE
  759              K=BYTE INTEGER(FILEPTR);    ! NEXT CHAR FROM SORCE FILE
  760              FILE PTR=FILE PTR+1
  761              TLINE(LL+1)=ITOI(K)
  762              LL=LL+1
  763           %REPEAT %UNTIL K=NL %OR K=0
  764  OLIST:
  765        %FINISH
  766  !      %IF MODE=0 %AND LL=1 %THEN GET LINE %AND %RETURN
  767  !      LINE=LINE+1 %UNLESS MODE=0 %AND LENGTH>0
  768        LINE=LINE+1;                      ! COUNT ALL LINES
  769        %IF LIST#0 %THEN %START
  770           %IF MODE=0 %AND LENGTH>0 %THEN PRINTSTRING("     C") %ELSE WRITE(LINE, 5)
  771  !         SPACES(8)
  772           %CYCLE K=-7,1,0
  773              TLINE(K)=' '
  774           %REPEAT
  775        %IF MODE#0 %THEN TLINE(-7)=M'"'
  776           TLINE(-8)=LL+8
  777           IOCP(15,ADDR(TLINE(-8)))
  778        %FINISH
  779        %IF FREE FORMAT=0 %AND LL>73 %THEN TLINE(73)=10 %AND LL=73
  780  %END
?OLIST unused
?IMP unused
  781  %END
  782  %INTEGERFN COMPARE(%INTEGER P)
  783  %INTEGER I, J, ITEM, RA, RL, RP, RQ, RR, RS, MARKER, SSL, ALT, PP
  784  %OWNINTEGER SAVECOMP;                   ! FOR CHECKING DSIDED CONDS
  785  %SWITCH BIP(999:1038)
  786  !     %IF USE IMP=YES %THEN %START
  787           RP=SYMBOL(P)
  788           RL=LEVEL
  789           P=P+1
  790           PP=P;                          ! ROUTINE REALLY STARTS HERE
  791  !     %FINISH %ELSE %START
  792  !        *LB_P
  793  !        *JLK_2
  794  !        *EXIT_-64
  795  !SUBENTRY:
  796  !        *LSS_(ASYM0+%B)
  797  !        *LUH_LEVEL
  798  !        *ST_RL
  799  !        *ADB_1
  800  !        *STB_P
  801  !        *STB_PP
  802  !     %FINISH
  803  COMM:
  804  !     %IF USE IMP=YES %THEN %START
  805           RQ=Q;                          ! RESET VALUES OF LINE&AR PTRS
  806           RR=R
  807           SSL=STRLINK;                   ! SAVE STRING LINK
  808           ALT=1;                         ! FIRST ALTERNATIVE TO BE TRIED
  809           RA=SYMBOL(P);                  ! RA TO NEXT PHRASE ALTERNATIVE
  810           RS=P
  811  !     %FINISH %ELSE %START
  812  !        *LSD_Q
  813  !        *ST_RQ
  814  !        *LSS_1
  815  !        *LUH_STRLINK
  816  !        *ST_SSL
  817  !        *LB_P
  818  !        *LSS_(ASYM0+%B)
  819  !        *ST_RA
  820  !        *STB_RS
  821  !     %FINISH
  822  UPR:     R=R+1
  823  SUCC:                                   ! SUCCESS ON TO NEXT ITEM
  824  !     %IF USE IMP=YES %THEN %START
  825           RS=RS+1;                       ! RS=NEXT ALTERNATIVE MEANS THAT
  826                                          ! THIS ALT HAS BEEN COMPLETED SO
  827                                          ! EXIT WITH HIT=1
  828           %IF RS=RA %THEN ->FINI
  829           ITEM=SYMBOL(RS);               ! NEXT BRICK IN THE CURRENT ALT
  830           %IF ITEM<999 %THEN ->LIT
  831  !     %FINISH %ELSE %START
  832  !        *LB_RS
  833  !        *ADB_1
  834  !        *CPB_RA
  835  !        *JCC_8,<FINI>
  836  !        *STB_RS
  837  !        *LB_(ASYM0+%B)
  838  !        *CPB_999
  839  !        *JCC_4,<LIT>
  840  !        *STB_ITEM
  841  !     %FINISH
  842        %IF ITEM<1300  %THEN ->BIP(ITEM)
  843                                          ! BRICK IS A PHRASE TYPE
  844  !     %IF USE IMP=YES %THEN %START
  845           %IF COMPARE(ITEM)=0 %THEN ->FAIL
  846  !     %FINISH %ELSE %START
  847  !        *LSD_RA
  848  !        *SLSQ_RP
  849  !        *SLSQ_MARKER
  850  !        *ST_%TOS
  851  !        *LB_ITEM
  852  !        *JLK_<SUBENTRY>
  853  !        *ST_%B;                        ! RESULT=0 FOR FAIL
  854  !        *LSQ_%TOS; *ST_MARKER
  855  !        *LSQ_%TOS; *ST_RP
  856  !        *LSD_%TOS; *ST_RA
  857  !        *JAT_12,<FAIL>
  858  !     %FINISH
  859        ->SUCC
  860  LIT:                                    ! BRICK IS LITERAL
  861  !     %IF USE IMP=YES %THEN %START
  862           I=CC(Q);                       ! OBTAIN CURRENT CHARACTER
  863           ->FAIL %UNLESS I=CLETT(ITEM+1)
  864           Q=Q+1
  865           K=CLETT(ITEM)+ITEM
  866           ITEM=ITEM+2
  867           %WHILE ITEM<=K %CYCLE
  868              ->FAIL %UNLESS CC(Q)=CLETT(ITEM)
  869              Q=Q+1
  870              ITEM=ITEM+1
  871           %REPEAT;                       ! CHECK IT WITH LITERAL DICT ENTRY
  872  !     %FINISH %ELSE %START
  873  !        *LDB_(CLETT+%B)
  874  !        *INCA_%B
  875  !        *INCA_1
  876  !        *LSS_Q
  877  !        *IAD_CC+4
  878  !        *LUH_CC
  879  !        *CPS_%L=%DR,0,0
  880  !        *JCC_7,<FAIL>
  881  !        *STUH_%B
  882  !        *ISB_CC+4
  883  !        *ST_Q
  884  !     %FINISH
  885        ->SUCC;                           ! MATCHED SUCCESSFULLY
  886  FAIL:                                   ! FAILURE - NOTE POSITION REACHD
  887  !     %IF USE IMP=YES %THEN %START
  888           %IF RA=RP %THEN ->TFAIL;       ! TOTAL FAILURE NO ALT TO TRY
  889           QMAX=Q %IF Q>QMAX
  890           Q=RQ;                          ! RESET LINE AND A.R. POINTERS
  891           R=RR+1;                        ! AVOID GOING VIA UPR:
  892           STRLINK=SSL
  893           ALT=ALT+1;                     ! MOVE TO NEXT ALT OF PHRASE
  894           RS=RA
  895           RA=SYMBOL(RA)
  896  !     %FINISH %ELSE %START
  897  !        *LB_RA
  898  !        *CPB_RP
  899  !        *JCC_8,<TFAIL>
  900  !        *LSS_Q
  901  !        *ICP_QMAX
  902  !        *JCC_12,<CPL1>
  903  !        *ST_QMAX
  904  !CPL1:    *LSD_RQ
  905  !        *IAD_1
  906  !        *ST_Q
  907  !        *L_SSL
  908  !        *STUH_STRLINK
  909  !        *IAD_1
  910  !        *ST_ALT
  911  !        *STB_RS
  912  !        *L_(ASYM0+%B)
  913  !        *ST_RA
  914  !     %FINISH
  915        ->SUCC
  916  TFAIL:
  917        LEVEL=RL
  918  !     %IF USE IMP=YES %THEN %START
  919           %RESULT=0
  920  !     %FINISH %ELSE %START
  921  !        *LSS_0; *J_%TOS
  922  !     %FINISH
  923  BIP(999):                               ! REPEATED PHRASE
  924        A(RR)=ALT; P=PP
  925        ->COMM
  926  BIP(1000):FINI:                         ! NULL ALWAYS LAST & OK
  927        A(RR)=ALT
  928  !     %IF USE IMP=YES %THEN %START
  929           %RESULT=1
  930  !     %FINISH %ELSE %START
  931  !        *LSS_1; *J_%TOS
  932  !     %FINISH
  933  BIP(1001):                              ! PHRASE NAME
  934  BIP(1004):                              ! PHRASE OLDNAME
  935        I=CC(Q);                          ! OBTAIN CURRENT CHARACTER
  936        ->FAIL %UNLESS TRTAB(I)=2
  937        PNAME(ITEM-1004)
  938        ->SUCC %IF HIT=1;  ->FAIL
  939  BIP(1002):                              ! PHRASE INTEGER CONSTANT
  940  BIP(1003):                              ! PHRASE CONST
  941        CONST(ITEM-1003)
  942        ->FAIL %IF HIT=0
  943        ->SUCC
  944  BIP(1005):                              ! PHRASE N 
  945        I=CC(Q);                          ! OBTAIN CURRENT CHARACTER
  946        ->FAIL %UNLESS '0'<=I<='9'
  947        S=0
  948        %WHILE '0'<=I<='9' %CYCLE
  949           S=10*S+I&15
  950           Q=Q+1; I=CC(Q)
  951        %REPEAT
  952        TOAR2(R,S)
  953        R=R+2; ->SUCC
  954  BIP(1006):                              ! PHRASE S=SEPARATOR
  955        I=CC(Q);                          ! OBTAIN CURRENT CHARACTER
  956        ->SUCC %IF I=NL
  957        ->FAIL %UNLESS I=';'
  958        Q=Q+1; ->SUCC
  959  BIP(1007):
  960                                          ! PHRASE COMMENT TEXT
  961        I=CC(Q);                          ! OBTAIN CURRENT CHARACTER
  962        J=I
  963        ->TX %IF I=';' %OR I=NL
  964        ->FAIL %UNLESS I='!' %OR I='|' %OR (I='C'+128 %AND CC(Q+1)='O'+128 %AND CC(Q+2)=CC(Q+3)='M'+128 %AND CC(Q+4)='E'+128 %AND CC(Q+5)='N'+128 %AND CC(Q+6)='T'+128)
  965        Q=Q+1+6*(I>>7); J=CC(Q)
  966        %CYCLE
  967           %EXIT %IF J=NL %OR J=';'
  968           Q=Q+1; J=CC(Q)
  969        %REPEAT
  970  TX:   Q=Q+1 %IF J=';'
  971        ->SUCC
  972  BIP(1008):                              ! PHRASE BIGHOLE
  973        TO AR4(R,0)
  974        R=R+4; ->SUCC
  975  BIP(1009):                              ! PHRASE N255
  976        I=CC(Q);                          ! OBTAIN CURRENT CHARACTER
  977        ->FAIL %UNLESS '0'<=I<='9'
  978        S=0
  979        %WHILE '0'<=I<='9' %CYCLE
  980           S=10*S+I&15
  981           Q=Q+1; I=CC(Q)
  982        %REPEAT
  983        ->FAIL %UNLESS 0<=S<=255
  984        A(R)=S; ->UPR
  985  BIP(1010):                              ! PHRASE HOLE
  986        MARKER=R;  R=R+2;  ->SUCC
  987  BIP(1011):                              ! PHRASE MARK
  988        I=R-MARKER
  989        A(MARKER+1)<-I
  990        A(MARKER)<-I>>8
  991        ->SUCC
  992  BIP(1012):                              ! PHRASE READLINE?
  993        I=CC(Q);                          ! OBTAIN CURRENT CHARACTER
  994        %WHILE I=NL %%CYCLE
  995           READLINE(0,0)
  996           RQ=1
  997           I=CC(Q)
  998        %REPEAT
  999        FAULT(102,0) %IF R>ARSIZE
 1000        ->SUCC
 1001  BIP(1013):                              ! PHRASE CHECKIMPS
 1002        ->FAIL %UNLESS IMPS=1;  ->SUCC
 1003  BIP(1014):                              ! PHRASE DUMMY APP
 1004        A(R)=2; A(R+1)=2
 1005        R=R+2; ->SUCC
 1006  BIP(1015):                              ! PHRASE DOWN=NEW TEXT LEVEL
 1007        LEVEL=LEVEL+1
 1008        TO AR4(R,0)
 1009        DISPLAY(LEVEL)=R
 1010        SFS(LEVEL)=0
 1011        R=R+4
 1012        ->SUCC
 1013  BIP(1016):                              ! PHRASE UP 1 TEXTUAL LEVEL
 1014        DISPLAY(LEVEL)=0
 1015        %WHILE SFS(LEVEL)#0 %CYCLE
 1016           POP(SFS(LEVEL),I,J,K)
 1017           %IF I=1 %THEN FAULT2(53,K,0);  ! FINISH MISSING
 1018           %IF I=2 %THEN FAULT2(13,K,0);  ! %REPEAT MISSING
 1019        %REPEAT
 1020        LEVEL=LEVEL-1
 1021        ->SUCC
 1022  BIP(1017):                              ! PHRASE LISTON
 1023        LIST=1;  ->SUCC
 1024  BIP(1018):                              ! PHRASE LISTOFF
 1025        LIST=0;  ->SUCC
 1026  BIP(1019):                              ! PHRASE COLON FOR LABEL
 1027        ->FAIL %UNLESS CC(Q-1)=':'
 1028        ->SUCC
 1029  BIP(1020):                              ! PHRASE NOTE CONST
 1030        %IF CTYPE=5 %THEN TOAR4(S-4,STRLINK) %AND STRLINK=S-4
 1031        ->SUCC
 1032  BIP(1021):                              ! TRACE FOR ON CONDITIONS
 1033        PARMTRACE=1; ->SUCC
 1034  BIP(1022):                              ! SET MNEMONIC
 1035        I=CC(Q);                          ! OBTAIN CURRENT CHARACTER
 1036        S=M'    '
 1037        %WHILE 'A'<=I<='Z' %CYCLE
 1038           S=S<<8!I; Q=Q+1; I=CC(Q)
 1039        %REPEAT
 1040        ->FAIL %UNLESS I='_' %AND S#M'    '
 1041        Q=Q+1; ->SUCC
 1042  BIP(1023):                              ! PRIMARY FORMAT MNEMOINC
 1043        %CYCLE I=7,1,126
 1044           ->PFND %IF OPC(I)=S
 1045        %REPEAT
 1046        ->FAIL
 1047  PFND:
 1048        ->FAIL %IF 8<=I>>3<=11 %AND I&7<=3
 1049        A(R)=2*I; ->UPR
 1050  BIP(1024):                              ! SECONDARY FORMAT MNEMONIC
 1051        %CYCLE I=64,8,88
 1052           %CYCLE J=0,1,3
 1053              ->SFND %IF OPC(I+J)=S
 1054           %REPEAT
 1055        %REPEAT
 1056        ->FAIL
 1057  SFND: A(R)=2*(I+J); ->UPR
 1058  BIP(1025):                             ! TERTIARY FORMAT MNEMONIC
 1059        %CYCLE I=3,-1,1
 1060           %IF OPC(I)=S %THEN A(R)=2*I %AND ->UPR
 1061        %REPEAT; ->FAIL
 1062  BIP(1026):                              ! P(OP)=+,-,&,****,**,*,!!,!,
 1063                                          ! //,/,>>,<<,.,\\,\;
 1064        I=CC(Q);                          ! OBTAIN CURRENT CHARACTER
 1065        ->FAIL %UNLESS 32<I<127 %AND 16_80000000>>((I-32)&31)&16_4237000A#0
 1066        Q=Q+1
 1067        %IF I='+' %THEN A(R)=1 %AND ->UPR
 1068        %IF I='-' %THEN A(R)=2 %AND ->UPR
 1069        %IF I='&' %THEN A(R)=3 %AND ->UPR
 1070        J=CC(Q)
 1071        %IF I='*' %THEN %START
 1072           %IF J#I %THEN A(R)=6 %AND ->UPR
 1073           %IF CC(Q+1)=I=CC(Q+2) %THEN A(R)=4 %AND Q=Q+3 %AND ->UPR
 1074           A(R)=5; Q=Q+1; ->UPR
 1075        %FINISH
 1076        %IF I='/' %THEN %START
 1077           %IF J#I %THEN A(R)=10 %AND ->UPR
 1078           A(R)=9; Q=Q+1; ->UPR
 1079        %FINISH
 1080        %IF I='!' %THEN %START
 1081           %IF J#I %THEN A(R)=8 %AND ->UPR
 1082           A(R)=7; Q=Q+1; ->UPR
 1083        %FINISH
 1084        %IF I='.' %THEN A(R)=13 %AND ->UPR
 1085        %IF I=J='<' %THEN A(R)=12 %AND Q=Q+1 %AND ->UPR
 1086        %IF I=J='>' %THEN A(R)=11 %AND Q=Q+1 %AND ->UPR
 1087        %IF I='\' %THEN %START
 1088           %IF J#I %THEN A(R)=15 %AND ->UPR
 1089           Q=Q+1; A(R)=14; ->UPR
 1090        %FINISH
 1091        ->FAIL
 1092  BIP(1027):                              ! PHRASE CHECK UI
 1093        I=CC(Q);                          ! OBTAIN CURRENT CHARACTER
 1094        ->SUCC %IF TRTAB(I)=2 %OR I='-'
 1095        ->SUCC %IF 16_80000000>>(I&31)&16_14043000#0
 1096        ->FAIL
 1097  BIP(1028):                              ! P(+')=+,-,\,0
 1098        I=CC(Q);                          ! OBTAIN CURRENT CHARACTER
 1099        %IF I='\' %OR I=16_7E %THEN A(R)=3 %AND Q=Q+1 %AND ->UPR
 1100        %IF I='-' %THEN A(R)=2 %AND Q=Q+1 %AND ->UPR
 1101        %IF I='+' %THEN A(R)=1 %AND Q=Q+1 %AND ->UPR
 1102        A(R)=4; ->UPR
 1103  BIP(1029):                              ! PHRASE NOTE CYCLE
 1104        TOAR4(R,0)
 1105        PUSH(SFS(LEVEL),2,R,LINE)
 1106        R=R+4
 1107        ->SUCC
 1108  BIP(1030):                              ! P(,')=',',0
 1109  !
 1110  ! THIS IS VERY AWKWARD AS IT MEANS IT IS VERY TO HARD TO FIND
 1111  ! THE END OF A PARAMETER LIST WITHOUT CHURNING. BY MAKING THIS A BIP
 1112  ! WE CAN PEEP AHEAD FOR ')' AND FAIL HERE.
 1113  !
 1114        I=CC(Q);                          ! OBTAIN CURRENT CHARACTER
 1115        %IF I=')' %THEN ->FAIL
 1116        %IF I=',' %THEN Q=Q+1
 1117        ->SUCC
 1118  BIP(1031):                              ! PHRASE CHECKTYPE IE ENSURE
 1119                                          ! FIRST LETTER IS(B,H,I,L,R,S) &
 1120                                          ! 3RD LETTER IS (A,L,N,R,T)
 1121        I=CC(Q);                          ! OBTAIN CURRENT CHARACTER
 1122        ->FAIL %UNLESS I>128 %AND 16_80000000>>(I&31)&16_20C83000#0 %AND 16_80000000>>(CC(Q+2)&31)&16_400A2800#0
 1123        ->SUCC
 1124  BIP(1032):                              ! PHRASE COMP1
 1125  BIP(1037):                              ! PHRASE COMP2(IS 2ND HALF OF DSIDED)
 1126        I=CC(Q);                          ! OBTAIN CURRENT CHARACTER
 1127        ->FAIL %UNLESS 32<I<=92 %AND 16_80000000>>(I&31)&16_1004000E#0
 1128                                          ! '='=1,'>='=2,'>'=3
 1129                                          ! '#' OR '\='=4,'<='=5,'<'=6
 1130                                          ! 7UNUSED,'->'=8,'=='=9
 1131                                          ! '##' OR '\==' =10
 1132        %IF I='=' %THEN %START
 1133           %IF CC(Q+1)=I %THEN J=9 %AND ->JOIN1
 1134           J=1; ->JOIN
 1135        %FINISH
 1136        %IF I='#' %THEN %START
 1137           %IF CC(Q+1)=I %THEN J=10 %AND ->JOIN1
 1138           J=4; ->JOIN
 1139        %FINISH
 1140        %IF I='\' %AND CC(Q+1)='=' %THEN %START
 1141           Q=Q+1
 1142           %IF CC(Q+1)='=' %THEN J=10 %AND ->JOIN1
 1143           J=4; ->JOIN
 1144        %FINISH
 1145        %IF I='>' %THEN %START
 1146           %IF CC(Q+1)='=' %THEN J=2 %AND ->JOIN1
 1147           J=3; ->JOIN
 1148        %FINISH
 1149        %IF I='<' %THEN %START
 1150           %IF CC(Q+1)='=' %THEN J=5 %AND ->JOIN1
 1151           J=6; ->JOIN
 1152        %FINISH
 1153        %IF I='-' %AND CC(Q+1)='>' %THEN J=8 %AND ->JOIN1
 1154        ->FAIL
 1155  JOIN1:Q=Q+1
 1156  JOIN: Q=Q+1
 1157        A(R)=J
 1158        %IF ITEM=1032 %THEN SAVECOMP=J %AND ->UPR
 1159                                          ! SAVE J TO CHECK DSIDED
 1160        %IF SAVECOMP>6 %OR J>6 %THEN Q=Q-1 %AND ->FAIL;! ILLEGAL DSIDED
 1161        ->UPR;                            ! NB OWNS WONT WORK IF
 1162                                          ! COND EXPRS ALLOWED AS THE
 1163                                          ! CAN BE NESTED!
 1164  BIP(1033):                              ! P(ASSOP)- ==,=,<-,->
 1165        I=CC(Q);                          ! OBTAIN CURRENT CHARACTER
 1166        %IF I='=' %THEN %START
 1167           %IF CC(Q+1)='=' %THEN A(R)=1 %AND Q=Q+2 %AND ->UPR
 1168           A(R)=2; Q=Q+1; ->UPR
 1169        %FINISH
 1170        %IF I='<' %AND CC(Q+1)='-' %THEN A(R)=3 %AND Q=Q+2 %AND ->UPR
 1171        %IF I='-' %AND CC(Q+1)='>' %THEN A(R)=4 %AND Q=Q+2 %AND ->UPR
 1172        ->FAIL
 1173  BIP(1034):                              ! NOTE START
 1174        TOAR4(R,0);                       ! HOLE FOR FORWARD PTR
 1175        PUSH(SFS(LEVEL),1,R,LINE)
 1176        R=R+4
 1177        ->SUCC
 1178  BIP(1035):                              ! NOTE FINISH
 1179        %IF SFS(LEVEL)=0 %THEN FAULT2(51,0,0) %AND ->SUCC
 1180        POP(SFS(LEVEL),I,J,K)
 1181        %IF I=2 %THEN FAULT2(59,K,0)
 1182        TOAR4(J,STARSTART)
 1183        ->SUCC
 1184  BIP(1036):                              ! NOTE REPEAT
 1185        %IF SFS(LEVEL)=0 %THEN FAULT2(1,0,0) %AND ->SUCC
 1186        POP(SFS(LEVEL),I,J,K)
 1187        %IF I=1 %THEN FAULT2(52,K,0);     ! START INSTEAD OF CYCLE
 1188        TOAR4(J,STARSTART)
 1189        ->SUCC
 1190  BIP(1038):                              ! INCLUDE "FILE"
 1191        ->FAIL %IF VMEB=YES
 1192        I=CC(Q)
 1193        ->FAIL %UNLESS I=NL %OR I=';'
 1194        Q=Q+1 %IF I=';'
 1195        ->FAIL %UNLESS CTYPE=5
 1196        PUSH(IHEAD,FILEADDR,FILEPTR,FILEEND)
 1197        CONSOURCE(STRING(ADDR(A(S))),FILEADDR);! DEPARTS IF FAILS
 1198        FILEPTR=FILEADDR+INTEGER(FILEADDR+4)
 1199        FILEEND=FILEADDR+INTEGER(FILEADDR)
 1200        ->SUCC
 1201  %END;                                   !OF ROUTINE 'COMPARE'
 1202  %ROUTINE PNAME(%INTEGER MODE)
 1203  !***********************************************************************
 1204  !*       MODE=0 FOR OLD NAME(ALREADY IN DICT), MODE=1 FOR NEW NAME     *
 1205  !***********************************************************************
 1206  %CONSTINTEGERARRAY HASH(0:7)=71,47,97,79,29,37,53,59;
 1207  %INTEGER JJ, KK, LL, FQ, FS, T, S, I
 1208  %LONGINTEGER DRDES,ACCDES
 1209        HIT=0;  FQ=Q;  FS=CC(Q)
 1210        %RETURN %UNLESS TRTAB(FS)=2 %AND M'"'#CC(Q+1)#M''''
 1211                                          ! 1ST CHAR MUST BE LETTER
 1212        T=1
 1213        LETT(NEXT+1)=FS; JJ=71*FS
 1214  !     %IF USE IMP=YES %THEN %START
 1215           %CYCLE
 1216              Q=Q+1
 1217              I=CC(Q)
 1218              %EXIT %IF TRTAB(I)=0
 1219              JJ=JJ+HASH(T) %IF T<=7
 1220              T=T+1
 1221              LETT(NEXT+T)=I
 1222           %REPEAT
 1223  !     %FINISH %ELSE %START
 1224  !CYC:
 1225  !        *LB_Q
 1226  !        *ADB_1
 1227  !        *STB_Q
 1228  !        *LB_(CC+%B)
 1229  !        *LSS_(TRTAB+%B)
 1230  !        *JAT_4,<EXIT>
 1231  !        *STB_I
 1232  !        *LSS_%B;                          ! I TO ACC
 1233  !        *LB_T
 1234  !        *CPB_7
 1235  !        *JCC_2,<SKIP>
 1236  !        *IMY_(HASH+%B)
 1237  !        *IAD_JJ
 1238  !        *ST_JJ
 1239  !SKIP:
 1240  !        *ADB_1
 1241  !        *STB_T
 1242  !        *LSS_I
 1243  !        *ADB_NEXT
 1244  !        *ST_(LETT+%B)
 1245  !        *J_<CYC>
 1246  !EXIT:
 1247  !     %FINISH
 1248        LETT(NEXT)=T;                     ! INSERT LENGTH
 1249        S=T+1
 1250        FAULT(103,0) %IF NEXT+S>DSIZE;!DICTIONARY OVERFLOW
 1251        JJ=(JJ+113*T)&NNAMES
 1252  !     %IF USE IMP=YES %THEN %START
 1253           %CYCLE KK=JJ, 1, NNAMES
 1254              LL=WORD(KK)
 1255              ->HOLE %IF LL=0;               ! NAME NOT KNOWN
 1256              ->FND %IF STRING(ADDR(LETT(NEXT)))=STRING(ADDR(LETT(LL)))
 1257           %REPEAT
 1258           %CYCLE KK=0,1,JJ
 1259              LL=WORD(KK)
 1260              ->HOLE %IF LL=0;               ! NAME NOT KNOWN
 1261              ->FND %IF STRING(ADDR(LETT(NEXT)))=STRING(ADDR(LETT(LL)))
 1262           %REPEAT
 1263  !     %FINISH %ELSE %START
 1264  !        *LDTB_16_18000000
 1265  !        *LDB_S
 1266  !        *LDA_LETT+4
 1267  !        *STD_DRDES
 1268  !        *INCA_NEXT
 1269  !        *STD_ACCDES
 1270  !        *LB_JJ
 1271  !CYC1:
 1272  !        *STB_KK
 1273  !        *LB_(WORD+%B)
 1274  !        *JAT_12,<HOLE>
 1275  !        *LSD_ACCDES
 1276  !        *LD_DRDES
 1277  !        *INCA_%B
 1278  !        *CPS_%L=%DR
 1279  !        *JCC_8,<FND>
 1280  !        *LB_KK
 1281  !        *CPIB_NNAMES
 1282  !        *JCC_7,<CYC1>
 1283  !        *LB_0
 1284  !CYC2:
 1285  !        *STB_KK
 1286  !        *LB_(WORD+%B)
 1287  !        *JAT_12,<HOLE>
 1288  !        *LSD_ACCDES
 1289  !        *LD_DRDES
 1290  !        *INCA_%B
 1291  !        *CPS_%L=%DR
 1292  !        *JCC_8,<FND>
 1293  !        *LB_KK
 1294  !        *CPIB_JJ
 1295  !        *JCC_7,<CYC2>
 1296  !     %FINISH
 1297        FAULT(104, 0);                    ! TOO MANY NAMES
 1298  HOLE: %IF MODE=0 %THEN Q=FQ %AND %RETURN
 1299        WORD(KK)=NEXT;  NEXT=NEXT+S
 1300  FND:  LASTAT=FQ;  HIT=1;  LASTNAME=KK
 1301        A(R+1)<-LASTNAME
 1302        A(R)=LASTNAME>>8; R=R+2
 1303        LASTEND=Q
 1304  %END
?ACCDES unused
?DRDES unused
 1305  
 1306  
 1307  %ROUTINE CONST(%INTEGER MODE)
 1308  !***********************************************************************
 1309  !*       SYNTAX CHECK AND EVALUATE ALL THE FORMS OF IMP CONSTANT       *
 1310  !*       MODE=0 FOR INTEGER CONSTANTS #0 FOR ANY SORT OF CONSTANT      *
 1311  !***********************************************************************
 1312  %INTEGER Z, DOTSEEN, EBCDIC, FS, CPREC, RR, S, T, SS
 1313  {%LONG}%LONGREAL X,CVALUE,DUMMY
 1314  %CONST{%LONG}%LONGREAL TEN=10.0 {R'41A00000000000000000000000000000'
 1315        CPREC=5;  RR=R;  R=R+1
 1316        DOTSEEN=0;  HIT=0
 1317        CVALUE=0;  DUMMY=0;  FS=CC(Q)
 1318        S=0;  ->N %IF M'0'<=FS<=M'9'
 1319        ->DOT %IF FS='.' %AND MODE=0 %AND '0'<=CC(Q+1)<='9'
 1320                                          ! 1 DIDT MIN
 1321        CTYPE=1;  EBCDIC=0
 1322        ->QUOTE %IF FS=M''''
 1323        ->STR2 %IF FS=34
 1324        ->NOTQUOTE %UNLESS CC(Q+1)=M'''';  Q=Q+2
 1325        ->HEX %IF FS='X'
 1326        ->MULT %IF FS='M'
 1327        ->BIN %IF FS=M'B'
 1328        ->RHEX %IF FS='R' %AND MODE=0
 1329        ->OCT %IF FS='K'
 1330        %IF FS='C' %THEN EBCDIC=1 %AND ->MULT
 1331        %IF FS='D' %AND MODE=0 %THEN %START
 1332           CPREC=7
 1333           %IF M'0'<=CC(Q)<=M'9' %THEN ->N
 1334           %IF CC(Q)='.' %THEN ->DOT
 1335        %FINISH
 1336        Q=Q-2;  %RETURN
 1337  QUOTE:                                  ! SINGLE CH BETWEEN QUOTES
 1338        %IF CC(Q+2)=M'''' %THEN %START
 1339           S=CC(Q+1)
 1340           Q=Q+3
 1341           %IF S#M'''' %THEN ->IEND
 1342           %IF CC(Q)=M'''' %THEN Q=Q+1 %AND ->IEND
 1343        %FINISH
 1344        %RETURN;                          ! NOT VALID
 1345  NOTQUOTE:                               ! CHECK FOR E"...."
 1346        %RETURN %UNLESS FS='E' %AND CC(Q+1)=M'"'
 1347        EBCDIC=1; Q=Q+1
 1348  STR2:                                   ! DOUBLE QUOTED STRING
 1349        A(RR)=16_35;  TEXTTEXT(EBCDIC)
 1350        CTYPE=5;  %RETURN
 1351  HEX:  T=0;                              ! HEX CONSTANTS
 1352        %CYCLE
 1353           I=CC(Q);  Q=Q+1
 1354           %EXIT %IF I=M''''
 1355           T=T+1
 1356           %RETURN %UNLESS ('0'<=I<='9' %OR 'A'<=I<='F') %AND T<17
 1357           %IF T=9 %THEN SS=S %AND S=0
 1358           S=S<<4+I&15+9*I>>6
 1359        %REPEAT
 1360        %IF T>8 %START
 1361           Z=4*(T-8)
 1362           S=S!(SS<<Z)
 1363           SS=SS>>(32-Z);  CPREC=6
 1364        %FINISH
 1365  IEND: %IF CPREC=6 %THEN TOAR4(R,SS) %AND R=R+4
 1366        %IF CPREC=5 %AND 0<=S<=16_7FFF %START
 1367           CPREC=4; TOAR2(R,S); R=R+2
 1368        %FINISH %ELSE TOAR4(R,S) %AND R=R+4
 1369        HIT=1 %UNLESS MODE#0 %AND CPREC=6
 1370        A(RR)=CPREC<<4!CTYPE
 1371        %RETURN
 1372  RHEX:                                   ! REAL HEX CONSTANTS
 1373        T=0
 1374        %CYCLE
 1375           I=CC(Q);  Q=Q+1
 1376           %IF T&7=0 %AND T#0 %START
 1377              TOAR4(R,S);  R=R+4;  S=0
 1378           %FINISH
 1379           %EXIT %IF I=M'''';  T=T+1
 1380           %RETURN %UNLESS '0'<=I<='9' %OR 'A'<=I<='F'
 1381           S=S<<4+I&15+9*I>>6
 1382        %REPEAT
 1383        %RETURN %UNLESS T=8 %OR T=16 %OR T=32
 1384        %IF T=32 %THEN CPREC=7 %ELSE CPREC=4+T//8
 1385        A(RR)=CPREC<<4!2
 1386        HIT=1;  %RETURN
 1387  OCT:                                    ! OCTAL CONSTANTS
 1388        T=0
 1389        %CYCLE
 1390           I=CC(Q);  Q=Q+1;  T=T+1
 1391           %EXIT %IF I=M''''
 1392           %RETURN %UNLESS '0'<=I<='7' %AND T<12
 1393           S=S<<3!(I&7)
 1394        %REPEAT
 1395        ->IEND
 1396  MULT: T=0;                              ! MULTIPLE CONSTANTS
 1397        %CYCLE
 1398           I=CC(Q);  Q=Q+1;  T=T+1
 1399           %IF I=M'''' %THEN %START
 1400              %IF CC(Q)#M'''' %THEN %EXIT %ELSE Q=Q+1
 1401           %FINISH
 1402           %RETURN %IF T>=5
 1403           %IF EBCDIC#0 %THEN I=ITOETAB(I)
 1404           S=S<<8!I
 1405        %REPEAT
 1406        ->IEND
 1407  BIN:  T=0;                              ! BINARY CONST
 1408        %CYCLE
 1409           I=CC(Q);  Q=Q+1;  T=T+1
 1410           %EXIT %IF I=M''''
 1411           %RETURN %UNLESS '0'<=I<='1' %AND T<33
 1412           S=S<<1!I&1
 1413        %REPEAT
 1414        ->IEND
 1415  N:                                      ! CONSTANT STARTS WITH DIGIT
 1416        I=CC(Q)
 1417        {%UNTIL I<M'0' %OR I>M'9'} %CYCLE
 1418           CVALUE=TEN*CVALUE+(I&15)
 1419           Q=Q+1;  I=CC(Q);               ! ONTO NEXT CHAR
 1420        %REPEAT %UNTIL I<M'0' %OR I>M'9'
 1421        ->ALPHA %UNLESS MODE=0 %AND I='.'
 1422  DOT:  Q=Q+1;  X=TEN;  I=CC(Q)
 1423        DOTSEEN=1;                        ! CONSTANT HAS DECIMAL POINT
 1424        %WHILE M'0'<=I<=M'9' %CYCLE
 1425           CVALUE=CVALUE+(I&15)/X
 1426           X=TEN*X;  Q=Q+1;  I=CC(Q)
 1427        %REPEAT
 1428  ALPHA:                                  ! TEST FOR EXPONENT
 1429        %IF MODE=0 %AND CC(Q)='@' %THEN %START
 1430           Q=Q+1;  X=CVALUE
 1431           Z=1;  I=CC(Q)
 1432           %IF I='-' %THEN Z=-1
 1433           %IF I='+' %OR I='-' %THEN Q=Q+1
 1434           CONST(2)
 1435           %IF HIT=0 %THEN %RETURN
 1436           HIT=0
 1437           R=RR+1
 1438           %IF A(R)>>4#4 %THEN %RETURN;   ! EXPONENT  MUST BE HALFINTEGER
 1439           S=FROM AR2(R+1)*Z
 1440           %IF S=-99 %THEN CVALUE=0 %ELSE %START
 1441  !           %IF USE IMP=NO %THEN %START
 1442  !               *MPSR_16_8080;          ! MASK OUT REAL OVERFLOW
 1443  !           %FINISH
 1444              %WHILE S>0 %CYCLE
 1445                 S=S-1
 1446                 CVALUE=CVALUE*TEN
 1447  !              %IF USE IMP=NO %THEN %START
 1448  !                 *JAT_15,<FAIL>
 1449  !              %FINISH
 1450              %REPEAT
 1451              %WHILE S<0 %AND CVALUE#0 %CYCLE
 1452                 S=S+1
 1453                 CVALUE=CVALUE/TEN
 1454              %REPEAT
 1455           %FINISH
 1456        %FINISH
 1457                                          ! SEE IF IT IS INTEGER
 1458        %IF FS='D' %THEN %START
 1459           I=CC(Q)
 1460           %IF I='''' %THEN Q=Q+1 %ELSE %RETURN
 1461           DOTSEEN=1;                     ! ENSURE NOT TAKEN AS INTEGER
 1462        %FINISH
 1463        %IF DOTSEEN=1 %OR CVALUE>IMAX %OR FRACPT(CVALUE)#0 %THEN CTYPE=2 %ELSE CTYPE=1 %AND S=INT(CVALUE)
 1464        %IF CTYPE=1 %THEN ->IEND
 1465        %IF CPREC=5 %THEN CPREC=6;        ! NO 32 BIT REAL CONSTS
 1466        %IF CPREC=6 %THEN %START
 1467  !        %IF USE IMP=NO %THEN %START;   ! SOFTWARE ROUND IN MC CODE ONLY
 1468  !           *LSD_CVALUE
 1469  !           *AND_16_FF00000000000000
 1470  !           *SLSD_CVALUE+8
 1471  !           *AND_16_0080000000000000
 1472  !           *LUH_%TOS
 1473  !           *RAD_CVALUE
 1474  !           *ST_CVALUE
 1475  !        %FINISH
 1476        %FINISH
 1477        TOAR8(R,CVALUE);  R=R+8
 1478        %IF CPREC=7 %THEN TOAR8(R,LONGREAL(ADDR(CVALUE)+8)) %AND R=R+8
 1479        A(RR)=CPREC<<4+CTYPE
 1480        HIT=1
 1481  FAIL: %END
?FAIL unused
 1482  %ROUTINE TEXTTEXT(%INTEGER EBCDIC)
 1483  !***********************************************************************
 1484  !*    PROCESSES TEXT BETWEEN DOUBLE QUOTES AND STORES IN ISO OR EBCDIC *  
 1485  !***********************************************************************
 1486  %INTEGER J, II
 1487  %CONSTINTEGER QU='"'
 1488           I=CC(Q)
 1489           S=R+4;  R=R+5; HIT=0
 1490           %RETURN %UNLESS I=QU;          ! FAIL UNLESS  INITIAL QUOTE
 1491           Q=Q+1
 1492           %CYCLE
 1493              I=CC(Q)
 1494              %IF EBCDIC#0 %THEN II=ITOETAB(I) %ELSE II=I
 1495              A(R)=II;  R=R+1
 1496              %IF I=QU %THEN %START
 1497                 Q=Q+1
 1498                 %IF CC(Q)#QU %THEN %EXIT
 1499              %FINISH
 1500              %IF I=10 %THEN READLINE(1,QU) %ELSE Q=Q+1
 1501              FAULT(106,0) %IF R-S>256
 1502           %REPEAT
 1503           R=R-1;  J=R-S-1
 1504           A(S)=J;   HIT=1
 1505  %END
 1506  BEND:%END;                              ! OF BLOCK CONTAINING PASS 1
 1507           %IF LEVEL>1 %THEN FAULT(15, 0)
 1508           I=0
 1509           NEWLINE
 1510           %IF FAULTY=0 %THEN %START
 1511              WRITE(LINE, 5)
 1512              PRINT STRING(" LINES ANALYSED IN")
 1513              WRITE(INT(1000*(CPUTIME-CTIME)),5)
 1514              PRINT STRING(" MSECS  -  SIZE=")
 1515              WRITE(P1SIZE, 5)
 1516              %IF LINE>90 %AND LIST#0 %THEN NEWPAGE %ELSE NEWLINE
 1517           %FINISH %ELSE %START
 1518              PRINTSTRING("CODE GENERATION NOT ATTEMPTED
 1519+ ")
 1520              COMREG(24)=8
 1521              COMREG(47)=FAULTY
 1522              %STOP
 1523           %FINISH
 1524  %BEGIN
 1525  !***********************************************************************
 1526  !*    SECOND OR CODE GENERATING PASS                                   *
 1527  !***********************************************************************
 1528  %INTEGERARRAY REGISTER, GRUSE, GRAT, GRINF1, GRINF2, OLINK(0:7)
 1529  %BYTEINTEGERARRAY CODE, GLABUF(0:268)
 1530  %INTEGERARRAY PLABS, DESADS, PLINK(0:31)
 1531  %INTEGERARRAY SET, STACKBASE, RAL, FLAG, L, M, NMDECS, ONWORD, ONINF,{%C
 1532+          JUMP, LABEL, JROUND, DIAGINF, DISPLAY, {%C
 1533+          AUXSBASE, NAMES (0:MAXLEVELS)
 1534  %INTEGERARRAY AVL WSP(0:4,0:MAXLEVELS)
 1535  %recordformat rcf(%integerarray val(0:12* 2047 {NNAMES}))  { unfortunately we can't have a dynamically-sized array in a record. Largest possible is 2047.
 1536  %record (rcf) %name CTABLE
 1537  {%INTEGERARRAYFORMAT CF(0:12*NNAMES)   -  Imp77 doesn't support ARRAY() mapping.
 1538  {%INTEGERARRAY(1)%NAME CTABLE
 1539  %ROUTINESPEC CNOP(%INTEGER I, J)
 1540  %ROUTINESPEC PCLOD(%INTEGER FROM, TO)
 1541  %ROUTINESPEC PCONST(%INTEGER X)
 1542  %ROUTINESPEC PSF1(%INTEGER OPCODE,K,N)
 1543  %ROUTINESPEC PF1(%INTEGER OPCODE,KP,KPP,N)
 1544  %ROUTINESPEC PSORLF1(%INTEGER OPCODE,KP,KPP,N)
 1545  %ROUTINESPEC PF2(%INTEGER OPCODE,H,Q,N,MASK,FILLER)
 1546  %ROUTINESPEC PF3(%INTEGER OPCODE,MASK,KPPP,N)
 1547  %ROUTINESPEC NOTE CREF(%INTEGER CA,VAL)
 1548  %INTEGERFNSPEC PARAM DES(%INTEGER PREC)
 1549  %INTEGERFNSPEC MAPDES(%INTEGER PREC)
 1550  %INTEGERFNSPEC SPECIAL CONSTS(%INTEGER WHICH)
 1551  %ROUTINESPEC STORE CONST(%INTEGERNAME D,%INTEGER L,AD)
 1552  %ROUTINESPEC DUMP CONSTS
 1553  %ROUTINESPEC PLANT(%INTEGER VALUE)
 1554  %ROUTINESPEC PLUG(%INTEGER I, J, K, BYTES)
 1555  %ROUTINESPEC CODEOUT
 1556  %ROUTINESPEC PROLOGUE
 1557  %ROUTINESPEC EPILOGUE
 1558  %ROUTINESPEC COMPILE A STMNT
 1559  %ROUTINESPEC CSS(%INTEGER P)
 1560  %ROUTINESPEC LOAD DATA
 1561  %ROUTINESPEC ABORT
 1562  !*DELSTART
 1563  %ROUTINESPEC PRINT USE
 1564  !*DELEND
 1565           %CYCLE I=0,1,7
?Non-local
 1566              REGISTER(I)=0; GRUSE(I)=0; GRINF1(I)=0; GRAT(I)=0
 1567              GRINF2(I)=0
 1568           %REPEAT
 1569           %CYCLE I=0, 1, MAXLEVELS
?Non-local
 1570              SET(I)=0;  STACKBASE(I)=0;  RAL(I)=0
 1571              JUMP(I)=0;  JROUND(I)=0
 1572              LABEL(I)=0;  FLAG(I)=0
 1573              L(I)=0; M(I)=0; DIAGINF(I)=0
 1574              DISPLAY(I)=0; ONWORD(I)=0; ONINF(I)=0
 1575              NAMES(I)=-1
 1576              %CYCLE J=0,1,4
?Non-local
 1577                AVL WSP(J,I)=0
 1578              %REPEAT
 1579           %REPEAT
 1580           {CTABLE==ARRAY(ADDR(ASLIST(1)),CF)
 1581           CTABLE==RECORD(ADDR(ASLIST(1)))
 1582           CONST HOLE=0
 1583           PROLOGUE
 1584           LINE=0
 1585           NEXTP=1; LEVEL=1; STMTS=0
 1586           RLEVEL=0; RBASE=0
 1587           %WHILE A(NEXTP+3)!A(NEXTP+4)#0 %CYCLE
 1588           COMPILE A STMNT
 1589           %REPEAT
 1590           LINE=99999
 1591           EPILOGUE
 1592           LOAD DATA
 1593           %STOP
 1594  %ROUTINE COMPILE A STMNT
 1595  %INTEGER I
 1596  !*DELSTART
 1597        %IF DCOMP#0 %AND CA>CABUF %THEN CODEOUT %AND PRINTUSE
 1598  !*DELEND
 1599        I=NEXTP
 1600        NEXTP=NEXTP+A(NEXTP)<<16+A(NEXTP+1)<<8+A(NEXTP+2)
 1601        LINE=A(I+3)<<8+A(I+4)
 1602        STMTS=STMTS+1
 1603        CSS(I+5)
 1604  !      CHECK ASL %IF LINE&7=0
 1605  %END
 1606  %ROUTINE LOAD DATA
 1607  !***********************************************************************
 1608  !*       PASS INFORMATION TO LPUT TO ENABLE IT TO GENERATE THE         *
 1609  !*       LOADER DATA AND COMPLETE THE PROGRAM FILE.                    *
 1610  !***********************************************************************
 1611  %INTEGER LANGFLAG,PARMS
 1612           GLACA=(GLACA+7)&(-8)
 1613           USTPTR=(USTPTR+7)&(-8)
 1614           CODE OUT
 1615           CNOP(0, 8)
 1616           DUMP CONSTS
 1617           %IF PARMTRACE=0 %THEN LANGFLAG=6 %ELSE LANGFLAG=1
 1618           LANGFLAG=LANGFLAG<<24
 1619           PARMS=(PARMDIAG<<1!PARMLINE)<<1!PARMTRACE
 1620           FIXED GLA(4)=LANGFLAG!1<<16!(CPRMODE&1)<<8!PARMS;! LANG RLSE & MAINPROG
 1621           I=GLACA-GLACABUF
 1622           %IF INHCODE=0 %THEN %START
 1623              LPUT(2, I, GLACABUF, ADDR(GLABUF(0))) %UNLESS I=0
 1624                                          ! BACK OF GLAP
 1625              LPUT(2, FIXEDGLALEN, 0, ADDR(FIXED GLA(0)));! FRONT OF GLAP
 1626              LPUT(19,2,8,5);             ! RELOCATE GLA ST ADDRESS
 1627              LPUT(19,2,12,4);            ! RELOCATE CODE ST ADDRESS
 1628              I=16_E2E2E2E2
 1629              LPUT(4, 4, SSTL, ADDR(I))
 1630  !
 1631           %FINISH
 1632           SSTL=(SSTL+11)&(-8)
 1633           PRINTSTRING("
 1634+ CODE")
 1635           WRITE(CA, 6);  PRINTSTRING(" BYTES      GLAP")
 1636           WRITE(GLACA, 3);  PRINTSTRING("+")
 1637           WRITE(USTPTR, 1);  PRINTSTRING(" BYTES      DIAG TABLES")
 1638           WRITE(SSTL, 3);  PRINTSTRING(" BYTES
 1639+ TOTAL")
 1640           REGISTER(0)=CA;  REGISTER(1)=GLACA
 1641           REGISTER(2)=0
 1642           REGISTER(3)=SSTL
 1643           REGISTER(4)=USTPTR
 1644           K=CA+GLACA+SSTL+USTPTR;  REGISTER(5)=K
 1645           WRITE(K, 5);  PRINTSTRING(" BYTES")
 1646           NEWLINE;  PRINT CH(13);        ! MARKER FOR COMP TO PRINT 
 1647                                          !SUMMARY
 1648           %IF FAULTY=0 %THEN %START
 1649              WRITE(STMTS, 7);  PRINTSTRING(" STATEMENTS COMPILED IN")
 1650              WRITE(INT(1000*(CPUTIME-CTIME)),5)
 1651              PRINTSTRING(" MSECS")
 1652              COMREG(47)=STMTS;           ! NO OF STMTS FOR COMPER
 1653           %FINISH %ELSE %START
 1654              PRINTSTRING("PROGRAM CONTAINS");  WRITE(FAULTY, 2)
 1655              PRINTSTRING(" FAULT"); PRINTSYMBOL('S') %IF FAULTY>1
 1656              COMREG(47)=FAULTY;          ! NO OF FAULTS FOR COMPER
 1657           %FINISH
 1658           NEWLINES(2)
 1659           NEWLINE
 1660           I=0;  I=8 %IF FAULTY#0
 1661           COMREG(24)=I
 1662           %IF INHCODE=0 %THEN LPUT(7, 24, 0, ADDR(REGISTER(0)))
 1663                                          ! SUMMARY INFO..REGISTER AS BUF
 1664  !        PPROFILE
 1665           %STOP
 1666  %END
 1667  !
 1668  !***********************************************************************
 1669  !*       IMP CODE PLANTING ROUTINES                                    *
 1670  !*       CODE AND GLAP ARE PUT INTO THE BUFFERS 'CODE,GLABUF(0:268)'   *
 1671  !*       BY A NUMBER OF TRIVIAL ROUTINES.LPUT IS CALLED TO ADD THE     *
 1672  !*       BUFFER TO THE OUTPUT FILE. THE BUFFERS ARE BASICALLY 0:255    *
 1673  !*       WITH A 12-BYTE MARGIN TO MINIMISE THE NUMBER OF TESTS FOR     *
 1674  !*       THE BUFFER FULL CONDITION                                     *
 1675  !*                                                                     *
 1676  !*       PPCURR(GLACURR) IS THE BUFFER POINTER                         *
 1677  !*       CA(GLACA)  IS THE RELATIVE ADDRESS OF THE NEXT BYTE           *
 1678  !*       CABUF(GLACABUF) IS CA(GLACA) FOR START OF BUFFER              *
 1679  !***********************************************************************
 1680  !*DELSTART
 1681  %ROUTINE RECODE(%INTEGER S,F,AD)
 1682           %IF S#F %START
 1683              PRINTSTRING("
 1684+ CODE FOR LINE"); WRITE(LINE,5)
 1685              NCODE(S,F,AD)
 1686           %FINISH
 1687  %END
 1688  !*DELEND
 1689  %ROUTINE CODEOUT
 1690           %IF PPCURR>0 %THEN %START
 1691  !*DELSTART
 1692              RECODE(ADDR(CODE(0)), ADDR(CODE(PPCURR)), CABUF) %IF DCOMP#0
 1693  !*DELEND
 1694              LPUT(1, PPCURR, CABUF, ADDR(CODE(0))) %IF INHCODE=0
 1695              PPCURR=0;  CABUF=CA
 1696           %FINISH
 1697  %END
 1698  %ROUTINE PLANT(%INTEGER HALFWORD)
 1699  !***********************************************************************
 1700  !*       ADD A HALF WORD OF BINARY TO THE BUFFER                       *
 1701  !***********************************************************************
 1702  !     %IF USE IMP=YES %THEN %START
 1703           CODE(PPCURR)<-HALFWORD>>8
 1704           CODE(PPCURR+1)<-HALFWORD
 1705           PPCURR=PPCURR+2
 1706  !     %FINISH %ELSE %START
 1707  !        *LDA_CODE+4
 1708  !        *LDTB_16_58000002
 1709  !        *LB_PPCURR
 1710  !        *LSS_HALFWORD
 1711  !        *ST_(%DR+%B)
 1712  !        *ADB_2
 1713  !        *STB_PPCURR
 1714  !     %FINISH
 1715        CA=CA+2
 1716        CODEOUT %IF PPCURR>=256
 1717  %END
 1718  %ROUTINE PCONST(%INTEGER WORD)
 1719  !***********************************************************************
 1720  !*       ADD A WORD OF BINARY TO THE BUFFER                            *
 1721  !***********************************************************************
 1722  %INTEGER I
 1723  !     %IF USE IMP=YES %THEN %START
 1724           %CYCLE I=24,-8,0
 1725              CODE(PPCURR)=WORD>>I&255
 1726              PPCURR=PPCURR+1
 1727           %REPEAT
 1728  !     %FINISH %ELSE %START
 1729  !        *LDA_CODE+4
 1730  !        *LDTB_16_58000004
 1731  !        *LSS_WORD
 1732  !        *LB_PPCURR
 1733  !        *ST_(%DR+%B)
 1734  !        *ADB_4
 1735  !        *STB_PPCURR
 1736  !     %FINISH
 1737        CA=CA+4
 1738        CODE OUT %IF PPCURR>=256
 1739  %END
 1740  %ROUTINE PSF1(%INTEGER OPCODE,K,N)
 1741  !***********************************************************************
 1742  !*       PLANT THE HALFWORD FORMS OF PRIMARY FORMAT NR INSTRNS         *
 1743  !*       IF N IS TOO LARGE FOR THE SHORT FORM PF1 IS CALLED TO PLANT   *
 1744  !*       THE CORRESPONDING LONG FORM                                   *
 1745  !***********************************************************************
 1746  %INTEGER KPP
 1747  !      ABORT %UNLESS 0<=K<=2 %AND OPCODE&1=0
 1748        %IF (K=0 %AND -64<=N<=63) %OR (K#0 %AND 0<=N<=511) %START
 1749           %IF K#0 %THEN N=N//4
 1750  !        %IF USE IMP=YES %THEN %START
 1751              CODE(PPCURR)=OPCODE!K>>1
 1752              CODE(PPCURR+1)=(K&1)<<7!N&127
 1753              PPCURR=PPCURR+2
 1754  !        %FINISH %ELSE %START
 1755  !           *LSS_OPCODE
 1756  !           *USH_1
 1757  !           *OR_K
 1758  !           *USH_7
 1759  !           *SLSS_N
 1760  !           *AND_127
 1761  !           *LB_PPCURR
 1762  !           *OR_%TOS
 1763  !           *LDA_CODE+4
 1764  !           *LDTB_16_58000002
 1765  !           *ST_(%DR+%B)
 1766  !           *ADB_2
 1767  !           *STB_PPCURR
 1768  !        %FINISH
 1769           CA=CA+2
 1770           CODEOUT %IF PPCURR>=256
 1771        %FINISH %ELSE %START
 1772           %IF K=0 %THEN KPP=0 %ELSE KPP=2
 1773           PF1(OPCODE,K>>1<<1,KPP,N)
 1774        %FINISH
 1775  %END
 1776  %ROUTINE PF1(%INTEGER OPCODE,KP,KPP,N)
 1777  !***********************************************************************
 1778  !*       PLANT THE NORMAL FORMS OF PRIMARY FORMAT INSTRNS(IE THOSE     *
 1779  !*       WHICH DO NOT DEPEND ON THE SIZE OF N)                         *
 1780  !***********************************************************************
 1781  %INTEGER INC
 1782  !      ABORT %UNLESS 0<=KP<=3 %AND 0<=KPP<=7 %AND OPCODE&1=0
 1783        INC=2
 1784        %IF KPP=PC %THEN %START
 1785           %IF N<0 %THEN N=N&16_7FFFFFFF %AND NOTE CREF(CA,N)
 1786           N=(N-CA)//2
 1787        %FINISH
 1788        %IF (1<<KPP)&B'101100'#0 %THEN N=N//4
 1789  !     %IF USE IMP=YES %THEN %START
 1790           CODE(PPCURR)=OPCODE!1
 1791           CODE(PPCURR+1)=16_80!KP<<5!KPP<<2!(N>>16&3)
 1792           CODE(PPCURR+2)=N>>8&255
 1793           CODE(PPCURR+3)=N&255
 1794  !     %FINISH %ELSE %START
 1795  !        *LSS_OPCODE
 1796  !        *USH_1
 1797  !        *OR_3
 1798  !        *USH_2
 1799  !        *OR_KP
 1800  !        *USH_3
 1801  !        *OR_KPP
 1802  !        *USH_18
 1803  !        *SLSS_N
 1804  !        *AND_16_3FFFF
 1805  !        *OR_%TOS
 1806  !        *LDTB_16_58000004
 1807  !        *LDA_CODE+4
 1808  !        *LB_PPCURR
 1809  !        *ST_(%DR+%B)
 1810  !     %FINISH
 1811        %IF KPP<=5 %THEN INC=4
 1812        PPCURR=PPCURR+INC
 1813        CA=CA+INC
 1814        CODEOUT %IF PPCURR>=256
 1815  %END
 1816  %ROUTINE PSORLF1(%INTEGER OPCODE,KP,KPP,N)
 1817  !***********************************************************************
 1818  !*       AS PF1 BUT CUT VALID FORMS TO SHORT FORM                      *
 1819  !***********************************************************************
 1820  %INTEGER INC
 1821        INC=2
 1822        %IF (KPP=0=KP %AND -64<=N<=63) %OR (KPP=LNB %AND KP&1=0 %AND 0<=N<=511) %START
 1823           %IF KPP=LNB %THEN KP=1+KP>>1
 1824           %IF KP#0 %THEN N=N//4
 1825  !        %IF USE IMP=YES %THEN %START
 1826              CODE(PPCURR)=OPCODE!KP>>1
 1827              CODE(PPCURR+1)=(KP&1)<<7!(N&127)
 1828  !        %FINISH %ELSE %START
 1829  !           *LSS_OPCODE
 1830  !           *USH_1
 1831  !           *OR_KP
 1832  !           *USH_7
 1833  !           *SLSS_N
 1834  !           *AND_127
 1835  !           *LB_PPCURR
 1836  !           *OR_%TOS
 1837  !           *LDA_CODE+4
 1838  !           *LDTB_16_58000002
 1839  !           *ST_(%DR+%B)
 1840  !        %FINISH
 1841        %FINISH %ELSE %START
 1842           %IF KPP=PC %THEN %START
 1843              %IF N<0 %THEN N=N&16_7FFFFFFF %AND NOTE CREF(CA,N)
 1844              N=(N-CA)//2
 1845           %FINISH
 1846           %IF (1<<KPP)&B'101100'#0 %THEN N=N//4
 1847  !        %IF USE IMP=YES %THEN %START
 1848              CODE(PPCURR)=OPCODE!1
 1849              CODE(PPCURR+1)=((4!KP)<<3!KPP)<<2!(N>>16&3)
 1850              CODE(PPCURR+2)=N>>8&255
 1851              CODE(PPCURR+3)=N&255
 1852  !        %FINISH %ELSE %START
 1853  !           *LSS_OPCODE
 1854  !           *USH_1
 1855  !           *OR_3
 1856  !           *USH_2
 1857  !           *OR_KP
 1858  !           *USH_3
 1859  !           *OR_KPP
 1860  !           *USH_18
 1861  !           *SLSS_N
 1862  !           *AND_16_3FFFF
 1863  !           *OR_%TOS
 1864  !           *LDTB_16_58000004
 1865  !           *LDA_CODE+4
 1866  !           *LB_PPCURR
 1867  !           *ST_(%DR+%B)
 1868  !        %FINISH
 1869           %IF KPP<=5 %THEN INC=4
 1870        %FINISH
 1871        CA=CA+INC; PPCURR=PPCURR+INC
 1872        CODEOUT %IF PPCURR>=256
 1873  %END
 1874  %ROUTINE PF2(%INTEGER OPCODE,H,Q,N,MASK,FILLER)
 1875  !***********************************************************************
 1876  !*       PLANT SECONDARY(STORE TO STORE) FORMAT INSTRNS                *
 1877  !*       THESE MAY BE 16 OR 32 BIT DEPENDING ON Q                      *
 1878  !***********************************************************************
 1879  !         ABORT %UNLESS 0<=H<=1 %AND 0<=Q<=1 %AND 0<=N<=127 %AND OPCODE&1=0
 1880           PLANT(OPCODE<<8!H<<8!Q<<7!N)
 1881           %IF Q#0 %THEN PLANT(MASK<<8!FILLER)
 1882  %END
 1883  %ROUTINE PF3(%INTEGER OPCODE,MASK,KPPP,N)
 1884  !***********************************************************************
 1885  !*       PLANT THE TERTIARY(JUMP) FORMAT INSTRUCTIONS                  *
 1886  !***********************************************************************
 1887  !         ABORT %UNLESS 0<=MASK<=15 %AND 0<=KPPP<=7 %AND OPCODE&1=0
 1888           %IF KPPP=PC %THEN %START
 1889              %IF N<0 %THEN N=N&16_7FFFFFFF %AND NOTE CREF(CA,N)
 1890              N=(N-CA)//2
 1891           %FINISH
 1892           CODE(PPCURR)=OPCODE!MASK>>3&1
 1893           CODE(PPCURR+1)=(MASK&7)<<5!KPPP<<2!(N>>16&3)
 1894           PPCURR=PPCURR+2
 1895           CA=CA+2
 1896           %IF KPPP<=5 %THEN %START
 1897              CODE(PPCURR)=N>>8&255
 1898              CODE(PPCURR+1)=N&255
 1899              PPCURR=PPCURR+2; CA=CA+2
 1900           %FINISH
 1901           CODEOUT %IF PPCURR>=256
 1902  %END
 1903  %ROUTINE NOTE CREF(%INTEGER CA,N)
 1904  !***********************************************************************
 1905  !*    NOTE THAT A (PC+N) INSTRUCTION HAS N RELATIVE TO CONST TABLE     *
 1906  !*    NOT REATIVE TO CODE. REMEMBER THE ADDRESS OF THE INSTRUCTION     *
 1907  !*    SO THAT AN LPUT(18) CORRECTION CAN BE MADE AT END OF COMPILATION *
 1908  !***********************************************************************
 1909  %RECORD(LISTF)%NAME CELL {(LISTF)
 1910        CELL==ASLIST(CREFHEAD)
 1911        %IF CREFHEAD=0 %OR CELL_S3#0 %THEN PUSH(CREFHEAD,CA,0,0) %AND %RETURN
 1912        %IF CELL_S2=0 %THEN CELL_S2=CA %ELSE CELL_S3=CA
 1913  %END
?N unused
 1914  %ROUTINE PCLOD(%INTEGER FROM, TO)
 1915  !***********************************************************************
 1916  !*       PLANT A SERIES OF INTRUNS FROM ARRAY FIXED CODE               *
 1917  !***********************************************************************
 1918  %INTEGER I
 1919  !%CONSTINTEGERARRAY FIXED CODE(0:127)
 1920  !         %CYCLE I=FROM, 1, TO
 1921  !            PCONST(FIXED CODE(I))
 1922  !         %REPEAT
 1923  %END
?I unused
?TO unused
?FROM unused
 1924  %ROUTINE CNOP(%INTEGER I, J)
 1925           PSF1(JUNC,0,1) %WHILE CA&(J-1)#I
 1926  %END
 1927  %ROUTINE PGLA(%INTEGER BDRY, L, INF ADR)
 1928  %INTEGER I, J
 1929           J=GLACA;  GLACA=(J+BDRY-1)&(-BDRY)
 1930           GLACURR=GLACURR+GLACA-J;       ! COMPLETE THE ROUNDING
 1931           %IF L+GLACURR>256 %THEN %START
 1932              %IF INHCODE=0 %THEN LPUT(2, GLACURR, GLACABUF, ADDR(GLABUF(0)))
 1933              GLACURR=0;  GLACABUF=GLACA
 1934           %FINISH
 1935           %CYCLE I=0,1,L-1
 1936              GLABUF(GLACURR+I)=BYTE INTEGER(I+INF ADR)
 1937           %REPEAT
 1938           GLACA=GLACA+L;  GLACURR=GLACURR+L
 1939  %END
 1940  %ROUTINE PLUG(%INTEGER AREA, AT, VALUE, BYTES)
 1941  !***********************************************************************
 1942  !*       WRITE UP TO ONE WORD INTO OBJECT FILE OUT OF SEQUENCE         *
 1943  !***********************************************************************
 1944  %INTEGERNAME WCABUF
 1945  %INTEGER I, RELAD, BUFAD
 1946           WCABUF==CABUF;  BUFAD=ADDR(CODE(0))
 1947           %IF AREA=2 %THEN WCABUF==GLACABUF %AND BUFAD=ADDR(GLABUF(0))
 1948           RELAD=AT-WCABUF
 1949           %IF 0<=RELAD<=256 %AND AREA<=3 %THEN %START
 1950              %CYCLE I=0,1,BYTES-1
 1951                BYTEINTEGER(RELAD+BUFAD+I)<-VALUE>>((BYTES-1-I)<<3)
 1952              %REPEAT
 1953           %FINISH %ELSE %START
 1954              %IF RELAD=-2 %THEN CODEOUT
 1955              %IF INHCODE=0 %THEN LPUT(AREA,BYTES,AT,ADDR(VALUE)+4-BYTES)
 1956  !*DELSTART
 1957              NCODE(ADDR(VALUE)+4-BYTES,ADDR(VALUE)+4,AT) %IF DCOMP=1=AREA
 1958  !*DELEND
 1959           %FINISH
 1960  %END
 1961  
 1962  %INTEGERFN PARAM DES(%INTEGER PREC)
 1963  !***********************************************************************
 1964  !*    SET UP BNDED L=1 DESRIPTOR FOR PASSING VARIABLE BY REFERENCE     *
 1965  !*    ONLY THE TOP HALF IS SET UP                                      *
 1966  !***********************************************************************
 1967  %INTEGER K,DES
 1968        K=DESADS(PREC)
 1969        %RESULT=K %UNLESS K=0
 1970        %IF PREC=4 %THEN DES=16_58000002 %ELSE DES=PREC<<27!1
 1971        STORE CONST (K,4,ADDR(DES))
 1972        DESADS(PREC)=K
 1973        %RESULT=K
 1974  %END
 1975  %INTEGERFN MAPDES(%INTEGER PREC)
 1976  !***********************************************************************
 1977  !*    SET UP 8BIT ZERO ADDRESS UNSCALED BCI DESCRTR FOR MAPPING        *
 1978  !***********************************************************************
 1979  %INTEGER K,DES0,DES1
 1980        K=DESADS(PREC+8)
 1981        %RESULT=K %UNLESS K=0
 1982        %IF PREC=4 %THEN DES0=16_58000002 %ELSE DES0=16_03000000!PREC<<27
 1983        DES1=0; STORE CONST(K,8,ADDR(DES0))
 1984        DESADS(PREC+8)=K
 1985        %RESULT=K
 1986  %END
 1987  %INTEGERFN SPECIAL CONSTS(%INTEGER WHICH)
 1988  !***********************************************************************
 1989  !*    PUTS CERTAIN SPECIAL CONSTANTS INTO THE CONSTANT TABLE ON        *
 1990  !*    DEMAND AND REMEMBERS THEIR POSN TO AVOID SEARCHONG               *
 1991  !***********************************************************************
 1992  {%CONST}%ownINTEGERARRAY SCS(0:5) =           16_40800000,0,
 1993+                                         16_41100000,0,
 1994+                                         1,0;
 1995  %INTEGER K
 1996        K=DESADS(WHICH+16)
 1997        %RESULT=K %UNLESS K=0
 1998        STORE CONST(K,8,ADDR(SCS(2*WHICH)))
 1999        DESADS(WHICH+16)=K
 2000        %RESULT=K
 2001  %END
 2002  %ROUTINE STORE CONST(%INTEGERNAME D, %INTEGER L, AD)
 2003  !***********************************************************************
 2004  !*       PUT THE CONSTANT VAL OF LENGTH 'L' INTO THE CONSTANT TABLE    *
 2005  !*       A CHECK IS MADE TO SEE IF THE CONSTANT HAS ALREADY            *
 2006  !*       BEEN INSERTED IN WHICH CASE THE OLD COPY IS REUSED            *
 2007  !***********************************************************************
 2008  %INTEGER I, J, K, C1, C2, C3, C4, LP
 2009        LP=L//4;  C2=0;  C3=0;  C4=0
 2010        %CYCLE I=0,1,L-1
 2011           BYTEINTEGER(ADDR(C1)+I)=BYTEINTEGER(AD+I)
 2012        %REPEAT
 2013        %IF PARMOPT#0 %THEN ->SKIP
 2014        K=CONST BTM;                      ! AFTER STRINGS IN CTABLE
 2015        %IF L=4 %THEN %START
 2016  !        %IF USE IMP=YES %THEN %START
 2017              %WHILE K<CONST PTR %CYCLE
 2018                 %IF CTABLE_val(K)=C1 %AND CONSTHOLE#K %THEN D=4*K!16_80000000 %AND %RETURN
 2019                 K=K+1
 2020              %REPEAT
 2021  !        %FINISH %ELSE %START
 2022  !           *LD_CTABLE
 2023  !           *LB_K
 2024  !           *SBB_1
 2025  !           *LSS_C1
 2026  !AGN1:
 2027  !           *ADB_1
 2028  !           *CPB_CONSTPTR
 2029  !           *JCC_10,<SKIP>
 2030  !           *ICP_(%DR+%B)
 2031  !           *JCC_7,<AGN1>
 2032  !           *CPB_CONSTHOLE
 2033  !           *JCC_8,<AGN1>
 2034  !           *LSS_%B
 2035  !           *IMY_4
 2036  !           *OR_16_80000000
 2037  !           *ST_(D)
 2038  !           *EXIT_-64
 2039  !        %FINISH
 2040        %FINISH %ELSE %START
 2041           J=CONSTPTR-LP
 2042           %WHILE K<=J %CYCLE
 2043              %IF CTABLE_val(K)=C1 %AND CTABLE_val(K+1)=C2 %AND (CONSTHOLE<K %OR CONSTHOLE>=K+LP) %START
 2044                 %IF L=8 %OR (CTABLE_val(K+2)=C3 %AND CTABLE_val(K+3)=C4) %THEN D=4*K!16_80000000 %AND %RETURN
 2045              %FINISH
 2046              K=K+2
 2047           %REPEAT
 2048        %FINISH
 2049  SKIP:
 2050        %IF L=4 %AND CONSTHOLE#0 %START
 2051           CTABLE_val(CONSTHOLE)=C1
 2052           D=4*CONSTHOLE!16_80000000
 2053           CONSTHOLE=0
 2054           %RETURN
 2055        %FINISH
 2056        %IF L>4 %AND CONST PTR&1#0 %THEN CONSTHOLE=CONST PTR %AND CONSTPTR=CONST PTR+1
 2057        D=4*CONST PTR!16_80000000
 2058        CTABLE_val(CONSTPTR)=C1
 2059        CTABLE_val(CONSTPTR+1)=C2
 2060        %IF L=16 %THEN CTABLE_val(CONSTPTR+2)=C3 %AND CTABLE_val(CONSTPTR+3)=C4
 2061        CONST PTR=CONST PTR+LP
 2062        %IF CONST PTR>CONST LIMIT %THEN FAULT(107,0)
 2063  %END
 2064  %ROUTINE GET ENV(%INTEGERNAME HEAD)
 2065  !***********************************************************************
 2066  !*       SAVE A COPY OF THE REGISTER STATE FOR FUTURE REFERENCE        *
 2067  !***********************************************************************
 2068  %INTEGER I, USE
 2069           %CYCLE I=0, 1, 7
 2070              USE=GRUSE(I)&16_FF;         ! MAIN USE ONLY
 2071              PUSH(HEAD, GRINF1(I), GRAT(I), I<<8!USE) %IF USE#0
 2072           %REPEAT
 2073  %END
 2074  %ROUTINE RESTORE(%INTEGER HEAD)
 2075  !***********************************************************************
 2076  !*       RESET THE REGISTERS TO ENVIRONMENT IN LIST HEADED BY 'HEAD'   *
 2077  !***********************************************************************
 2078  %INTEGER I, R, USE, INF, AT
 2079           %CYCLE I=0, 1, 7
 2080              %IF REGISTER(I)>=0 %THEN GRUSE(I)=0 %AND GRINF1(I)=0
 2081           %REPEAT
 2082           %WHILE HEAD#0 %CYCLE
 2083              POP(HEAD, INF, AT, I)
 2084              R=I>>8;  USE=I&255
 2085              %IF REGISTER(R)>=0 %THEN GRUSE(R)=USE %AND GRINF1(R)=INF
 2086              GRAT(R)=AT
 2087           %REPEAT
 2088  %END
 2089           %ROUTINE RELOCATE(%INTEGER GLARAD,VALUE,AREA)
 2090  !***********************************************************************
 2091  !*      PLANTS A WORD IN THE GLA (IF GLARAD<0) AND ARRANGES TO         *
 2092  !*       RELOCATE IT RELATIVE TO AN AREA(CODE=1,GLA=2,CST=4,GST=5      *
 2093  !*       IF THE RELOCATION IS RELATIVE TO SYMBOL TABLES THE WORD       *
 2094  !*       CAN NOT BE RELOCATED TILL SIZE OF THE CODE(OR GLA) IS KNOWN   *
 2095  !***********************************************************************
 2096           %IF GLARAD<0 %THEN PGLA(4,4,ADDR(VALUE)) %AND GLARAD=GLACA-4
 2097           LPUT(19,2,GLARAD,AREA)
 2098           %END
 2099           %ROUTINE GXREF(%STRING(31) NAME,%INTEGER MODE,XTRA,AT)
 2100  !***********************************************************************
 2101  !*       ASK LPUT TO ARRANGE FOR A DOUBLE WORD AT 'AT' IN THE GLA      *
 2102  !*       TO CONTAIN A DESCRIPTOR FOR NAME 'NAME'.                      *
 2103  !*       MODE=0 STATIC CODE XREF                                       *
 2104  !*       MODE=1 DYNAMIC CODE XREF                                      *
 2105  !*       MODE=2 DATA XREF XTRA=MINIMIUM LENGTH                         *
 2106  !***********************************************************************
 2107  %INTEGER LPUTNO
 2108           %IF MODE=2 %THEN LPUTNO=15 %ELSE LPUTNO=MODE+12
 2109           LPUT(LPUTNO,XTRA,AT,ADDR(NAME))
 2110           %END
 2111  %ROUTINE CXREF(%STRING(255) NAME,%INTEGER MODE,XTRA,%INTEGERNAME AT)
 2112  !***********************************************************************
 2113  !*       CREATE A ZEROED AREA IN THE GLA AND CALL GXREF TO GET         *
 2114  !*       IT FILLED AT LOAD TIME WITH INFORMATION ON AN EXTERNAL OBJECT *
 2115  !*       PARAMETERS ARE AS FOR GXREF.                                  *
 2116  !***********************************************************************
 2117  %INTEGER Z1,Z2
 2118           Z1=0; Z2=0
 2119           PGLA(8,8,ADDR(Z1));       ! 2 ZERO WORDS
 2120           AT=GLACA-8
 2121           GXREF(NAME,MODE,XTRA,AT)
 2122           %END
 2123  %ROUTINE CODEDES(%INTEGERNAME AT)
 2124  !***********************************************************************
 2125  !*       PUT A CODE DESCRIPTOR INTO THE PLT FOR USE BY DEFINE EP       *
 2126  !***********************************************************************
 2127  %INTEGER DESC1,DESC2
 2128           DESC1=16_E1000000; DESC2=0
 2129           %IF CDCOUNT=0 %THEN FIXED GLA(0)=DESC1 %AND AT=0 %ELSE PGLA(8,8,ADDR(DESC1)) %AND AT=GLACA-8
 2130           CDCOUNT=CDCOUNT+1
 2131  %END
 2132  %ROUTINE DEFINE EP(%STRING(255)NAME, %INTEGER ADR,AT,MAIN)
 2133  !***********************************************************************
 2134  !*       AN EP CONSISTS OF A CODE DESCRIPTOR IN THE GLA(PLT) OF        *
 2135  !*       FILE CONTAINING THE EP. LPUT IS TOLD ABOUT THIS AND THE LOADER*
 2136  !*       ARRANGES TO PUT A DESCRIPTOR-DESCRIPTOR TO THE CODE-DESC      *
 2137  !*        IN THE GLA OF ANY FILE REFERENCES THIS EP. THIS FIRST WORD   *
 2138  !*       OF ICLS PLT IS THE MAIN EP AND WE MIMIC THIS AS FAR AS POSS   *
 2139  !***********************************************************************
 2140           %IF AT=0 %THEN FIXED GLA(1)=ADR %ELSE PLUG(2,AT+4,ADR,4)
 2141           RELOCATE(AT+4,ADR,1)
 2142           LPUT(11,MAIN<<31!2,AT,ADDR(NAME)) %IF NAME#""
 2143  %END
 2144  %ROUTINE PROLOGUE
 2145  !***********************************************************************
 2146  !*       GENERATES THE SUBROUTINE THAT ALWAYS  ARE REQUIRED ONTO THE   *
 2147  !*       FRONT OF THE OBJECT PROGRAM WHERE THEY ARE DIRECTLY ADDRESABLE*
 2148  !***********************************************************************
 2149  %INTEGERFNSPEC STRINGIN(%INTEGER POS)
 2150  %ROUTINESPEC ERR EXIT(%INTEGER A, B, C)
 2151  %INTEGER I, K, L, STCA
 2152           I=16_C2C2C2C2
 2153           LPUT(4,4,0,ADDR(I))
 2154           SSTL=4
 2155           %CYCLE I=0, 1, 31
 2156              PLABS(I)=0; PLINK(I)=0
 2157              DESADS(I)=0
 2158           %REPEAT
 2159  !
 2160  ! GENERATE THE FIXED-FLOAT CONSTANTS THAT MAY BE NEEDED
 2161  !
 2162           PLABS(1)=CA
 2163           %CYCLE I=0, 1, 1
 2164              PCONST(UNASSPAT)
 2165           %REPEAT
 2166  !
 2167  ! GENERATE THE RUN TIME ERROR ROUTINE :-
 2168  ! MDIAGS FOR NR IS %ROUTINE MDIAGS(%INT PC,LNB,ERROR,XTRA)
 2169  ! PC IS A DUMMY (SEG FIELD ONLY USED) EXCEPT AFTER CONTINGENCY
 2170  ! ON ENTRY TO THIS SUBROUTINE ERROR & XTRA ARE IN ACC AS 64 BIT INTEGER
 2171  ! ENTRY HAS BEEN BY JLK SO RETURN ADDRESS STACKED
 2172  !
 2173  !RTF      PRCL   4                 TO PLANT PARAMS
 2174  !         JLK    +1                 STACK DUMMY PC
 2175  !         STLN   TOS               LNB AS SECOND PARAMETER
 2176  !         ST     TOS               ERROR NO AS THIRD PARAM
 2177  !         LXN    (LNB+4)           POINTER TO GLA
 2178  !         RALN   9                 TO STORED LNB
 2179  !         CALL   ((XNB+10))        VIA XREF=DESCRIPTOR-DESCRIPTOR
 2180  !         J      TOS               BACK AFTER A MONITOR
 2181  !
 2182           PLABS(2)=CA
 2183           PSF1(PRCL,0,4)
 2184           PSF1(JLK,0,1)
 2185           PF1(STLN,0,TOS,0)
 2186           PF1(ST,0,TOS,0)
 2187           PSF1(LXN,1,16)
 2188           PSF1(RALN,0,9)
 2189           PF1(CALL,2,XNB,40)
 2190           PF1(JUNC,0,TOS,0)
 2191  !
 2192  ! SUBROUTINE TO CALL DEBUG ROUTINE(S#IMPMON) LINE NO IN ACC
 2193  !
 2194  !        PRCL  4
 2195  !        ST    TOS
 2196  !        LXN   (LNB+4)
 2197  !        RALN  6
 2198  !        CALL  ((XNB+IMPMONEPDISP))
 2199  !        JUNC  TOS
 2200  !
 2201           %IF PARMDBUG#0 %THEN %START
 2202              PLABS(3)=CA
 2203              CXREF("S#IMPMON",PARMDYNAMIC,2,K)
 2204              PSF1(PRCL,0,4)
 2205              PF1(ST,0,TOS,0)
 2206              PSF1(LXN,1,16)
 2207              PSF1(RALN,0,6)
 2208              PF1(CALL,2,XNB,K)
 2209              PF1(JUNC,0,TOS,0)
 2210           %FINISH
 2211  !
 2212  ! SUBROUTINE TO ADVANCE STACK FRONT BY B WORDS AND FILL WITH UNASSIGNED
 2213  !
 2214  !        JAT   12,*+13                   B IS ZERO
 2215  !        LSS   TOS
 2216  !        STSF  TOS
 2217  !        LDTB  STRING DECRIPTOR         SET UP DESCRIPTOR FOR MVL
 2218  !        LDA   TOS
 2219  !        ASF   B                        ADVANCE BY B WORDS
 2220  !        MYB   4                        CHANGE B TO BYTES
 2221  !        LDB   B                        AND MOVE TO BOUND FIELD
 2222  !        MVL   L=DR                     AND FILL WITH X80S
 2223  !        ST    TOS
 2224  !        J     TOS                      RETURN
 2225  !
 2226           %IF PARMCHK=1 %THEN %START;      ! ONLY REQUIRED WITH CHKING
 2227              CNOP(0,4); K=CA
 2228              PCONST(16_58000000)
 2229              PLABS(4)=CA
 2230              PF3(JAT,12,0,13)
 2231              PF1(LSS,0,TOS,0)
 2232              PF1(STSF,0,TOS,0)
 2233              PF1(LDTB,0,PC,K)
 2234              PF1(LDA,0,TOS,0)
 2235              PF1(ASF,0,BREG,0)
 2236              PSF1(MYB,0,4)
 2237              PF1(LDB,0,BREG,0)
 2238              PF2(MVL,1,1,0,0,UNASSPAT&255)
 2239              PF1(ST,0,TOS,0)
 2240              PF1(JUNC,0,TOS,0)
 2241           %FINISH
 2242  !
 2243  ! SOME ERROR ROUTINES
 2244  !
 2245           ERR EXIT(5, 16_801, 0) %IF PARMOPT#0; ! UNASSIGNED VARIABLE
 2246           ERR EXIT(6,  16_504, 0);              ! SWITCH LABEL UNSET
 2247           ERR EXIT(7, 16_505, 1);               ! ILLEGEAL EXPONENTIATION
 2248           ERR EXIT(8,16_201, 0) %IF PARMOPT#0;  ! EXCESS BLOCKS
 2249           ERR EXIT(9, 16_601, 0);               ! CAPACITY EXCEEDED
 2250           ERR EXIT(10,21, 0) ;                  ! NO RESULT
 2251           ERR EXIT(11,16_501, 0) %IF PARMOPT#0; ! CYCLE NOT VALID
 2252           ERR EXIT(12,16_701,0);                ! RES FAILS
 2253           ERR EXIT(13,36,0) %IF PARMOPT#0;      ! WRONG NO OF PARAMS
 2254  !
 2255  ! PUT THE STRINGS ONTO THE FRONT OF CONSTANT AREA
 2256  !
 2257           CTABLE_val(0)=16_18000001
 2258           CTABLE_val(1)=4
 2259           STCA=8; L=ADDR(CTABLE_val(0))
 2260           CONST PTR=2;                   ! IN CASE NO STRINGS
 2261           %WHILE STRLINK#0 %CYCLE
 2262              I=STRLINK; STRLINK=FROM AR4(I)
 2263              TO AR4(I,STRINGIN(I+4));          ! CHANGE LINK TO STRING ADDR
 2264           %REPEAT
 2265           STRLINK=16_80000000
 2266           CONST BTM=CONST PTR
 2267           %IF PARMOPT#0 %THEN CTABLE_val(CONST PTR)=M'IDIA' %AND CONST PTR=CONST PTR+1
 2268           GXREF(MDEP,PARMDYNAMIC,2,40)
 2269           %IF PARMPROF#0 %THEN %START;   ! ALLOCATE PROFILE COUNT AREA
 2270              I=16_38000001+LINE
 2271              K=8
 2272              PARMPROF=GLACA
 2273              PGLA(4,8,ADDR(I))
 2274              K=0
 2275              %CYCLE I=0,1,LINE
 2276                 PGLA(4,4,ADDR(K))
 2277              %REPEAT
 2278              LINE=0
 2279           %FINISH
 2280           LEVEL=1
 2281           %CYCLE I=0,1,31
 2282              %IF PLINK(I)#0 %THEN CLEAR LIST(PLINK(I))
 2283           %REPEAT
 2284           %RETURN
 2285  %INTEGERFN STRINGIN(%INTEGER POS)
 2286  !***********************************************************************
 2287  !*    PUT A STRING INTO THE CONSTANT AREA CHECKING FOR DUPLICATES      *
 2288  !***********************************************************************
 2289  %INTEGER J,K,IND,HD
 2290  %RECORD(LISTF)%NAME CELL{(LISTF)
 2291        K=A(POS)
 2292        %IF K=0 %THEN %RESULT=0
 2293        IND=K&31; HD=PLINK(IND)
 2294        %WHILE HD#0 %CYCLE
 2295           CELL==ASLIST(HD)
 2296           %IF CELL_S1=K %AND STRING(L+CELL_S2)=STRING(ADDR(A(POS))) %THEN %RESULT=CELL_S2-4
 2297           HD=CELL_LINK
 2298        %REPEAT
 2299        HD=STCA
 2300        BYTEINTEGER(L+STCA)=K; STCA=STCA+1
 2301        %CYCLE J=POS+1,1,POS+K
 2302           BYTE INTEGER(L+STCA)=A(J)
 2303           STCA=STCA+1
 2304        %REPEAT
 2305        CONST PTR=((STCA+7)&(-8))>>2
 2306        PUSH(PLINK(IND),K,HD,0)
 2307        %RESULT=HD-4
 2308  %END
 2309  %ROUTINE ERR EXIT(%INTEGER LAB, ERRNO, MODE)
 2310  !***********************************************************************
 2311  !*       MODE=0 FOR DUMMY(ZERO) XTRA - MODE=1 XTRA IN BREG             *
 2312  !***********************************************************************
 2313           PLABS(LAB)=CA
 2314           %IF MODE=0 %THEN PSF1(LSS,0,0) %ELSE PF1(LSS,0,BREG,0)
 2315           PSF1(LUH,0,ERRNO)
 2316           PSF1(JLK,0,(PLABS(2)-CA)//2)
 2317  %END
 2318  %END
 2319  %ROUTINE CSS(%INTEGER P)
 2320  %ROUTINESPEC MERGE INFO
 2321  %ROUTINESPEC REDUCE ENV(%INTEGERNAME HEAD)
 2322  %ROUTINESPEC ENTER JUMP(%INTEGER MASK,STAD,FLAG)
 2323  %INTEGERFNSPEC ENTER LAB(%INTEGER M,FLAG)
 2324  %ROUTINESPEC REMOVE LAB(%INTEGER LAB)
 2325  %ROUTINESPEC CEND(%INTEGER KKK)
 2326  %INTEGERFNSPEC CCOND(%INTEGER CTO,A,B)
 2327  %ROUTINESPEC CHECK STOF
 2328  %INTEGERFNSPEC REVERSE(%INTEGER MASK)
 2329  %ROUTINESPEC SET LINE
 2330  %INTEGERFNSPEC SET XORYNB(%INTEGER WHICH,RLEVEL)
 2331  %INTEGERFNSPEC XORYNB(%INTEGER USE,INF)
 2332  %ROUTINESPEC GET IN ACC(%INTEGER ACC,SIZE,AC,AREA,DISP)
 2333  %INTEGERFNSPEC AREA CODE
 2334  %INTEGERFNSPEC AREA CODE2(%INTEGER BS)
 2335  %ROUTINESPEC CUI(%INTEGER CODE)
 2336  %ROUTINESPEC ASSIGN(%INTEGER A,B)
 2337  %ROUTINESPEC CSTART(%INTEGER CCRES,MODE)
 2338  %ROUTINESPEC CCYCBODY(%INTEGER UA,ELAB,CLAB)
 2339  %ROUTINESPEC CLOOP(%INTEGER ALT,MARKC,MARKUI)
 2340  %ROUTINESPEC CIFTHEN(%INTEGER MARKIU,MARKC,MARKUI,MARKE,MARKR,SKIP)
 2341  %ROUTINESPEC CREATE AH(%INTEGER MODE)
 2342  %ROUTINESPEC TORP(%INTEGERNAME HEAD,BOT,NOPS)
 2343  %INTEGERFNSPEC INTEXP(%INTEGERNAME VALUE)
 2344  %INTEGERFNSPEC CONSTEXP(%INTEGER PRECTYPE)
 2345  %ROUTINESPEC CSEXP(%INTEGER REG,MODE)
 2346  %ROUTINESPEC CSTREXP(%INTEGER A,B)
 2347  %ROUTINESPEC CRES(%INTEGER LAB)
 2348  %ROUTINESPEC EXPOP(%INTEGER A,B,C,D)
 2349  %ROUTINESPEC  TEST APP(%INTEGERNAME NUM)
 2350  %ROUTINESPEC SKIP EXP
 2351  %ROUTINESPEC SKIP APP
 2352  %ROUTINESPEC NO APP
 2353  %INTEGERFNSPEC DOPE VECTOR(%INTEGER A,B,MODE,ID,%INTEGERNAME C,D)
 2354  %ROUTINESPEC DECLARE ARRAYS(%INTEGER A,B)
 2355  %ROUTINESPEC DECLARE SCALARS(%INTEGER A,B)
 2356  %ROUTINESPEC MAKE DECS(%INTEGER Q)
 2357  %ROUTINESPEC SAVE AUX STACK
 2358  %ROUTINESPEC RESET AUX STACK
 2359  %ROUTINESPEC CRSPEC(%INTEGER M)
 2360  %ROUTINESPEC CFPLIST(%INTEGERNAME A,B)
 2361  %ROUTINESPEC CFPDEL
 2362  %ROUTINESPEC CLT
 2363  %ROUTINESPEC CQN(%INTEGER P)
 2364  %ROUTINESPEC GET WSP(%INTEGERNAME PLACE,%INTEGER SIZE)
 2365  %ROUTINESPEC RETURN WSP(%INTEGER PLACE,SIZE)
 2366  %INTEGERFNSPEC TSEXP(%INTEGERNAME VALUE)
 2367  %ROUTINESPEC CRCALL(%INTEGER RTNAME)
 2368  %ROUTINESPEC NAMEOP(%INTEGER Z,REG,SIZE,NAMEP)
 2369  %ROUTINESPEC CNAME(%INTEGER Z,REG)
 2370  %ROUTINESPEC CANAME(%INTEGER Z,BS,DP)
 2371  %ROUTINESPEC CSNAME(%INTEGER Z,REG)
 2372  %ROUTINESPEC TEST ASS(%INTEGER REG,TYPE,SIZE)
 2373  %ROUTINESPEC COPY TAG(%INTEGER KK)
 2374  %ROUTINESPEC REDUCE TAG
 2375  %ROUTINESPEC REPLACE TAG (%INTEGER KK)
 2376  %ROUTINESPEC RT JUMP(%INTEGER CODE,%INTEGERNAME L)
 2377  %ROUTINESPEC STORE TAG(%INTEGER KK,SLINK)
 2378  %ROUTINESPEC UNPACK
 2379  %ROUTINESPEC PACK(%INTEGERNAME PTYPE)
 2380  %ROUTINESPEC DIAG POINTER(%INTEGER LEVEL)
 2381  %ROUTINESPEC RDISPLAY(%INTEGER KK)
 2382  %ROUTINESPEC RHEAD(%INTEGER KK)
 2383  %ROUTINESPEC ODD ALIGN
 2384  %INTEGERFNSPEC PTR OFFSET(%INTEGER RLEV)
 2385  %ROUTINESPEC PPJ(%INTEGER MASK,N)
 2386  %ROUTINESPEC CRFORMAT(%INTEGERNAME OPHEAD)
 2387  %INTEGERFNSPEC DISPLACEMENT(%INTEGER LINK)
 2388  %INTEGERFNSPEC COPY RECORD TAG(%INTEGERNAME SUBS)
 2389  %ROUTINESPEC SAVE IRS
 2390  %ROUTINESPEC COPY DR
 2391  %ROUTINESPEC BOOT OUT(%INTEGER REG)
 2392  %ROUTINESPEC CHANGE RD(%INTEGER REG)
 2393  %ROUTINESPEC FORGET(%INTEGER REG)
 2394  %ROUTINESPEC REMEMBER
 2395  %ROUTINESPEC NOTE ASSMENT(%INTEGER REG,ASSOP,VAR)
 2396  %SWITCH SW(1:24)
 2397  %RECORDFORMAT RD(%BYTEINTEGER UPTYPE,PTYPE,XB,FLAG,{%C
 2398+    %INTEGER D,XTRA)
 2399  %INTEGER SNDISP,ACC,K,KFORM,STNAME,MIDCELL
 2400  %INTEGER TCELL,NUMMOD,JJ,JJJ,KK,QQ,MARKER,REPORTUI,XDISP,MASK, {%C
 2401+       BASE,AREA,ACCESS,DISP,EXTRN, CURR INST,VALUE,STRINGL, {%C
 2402+       PTYPE,I,J,OLDI,USEBITS,TWSPHEAD,KKK,STRFNRES, {%C
 2403+       MARKIU,MARKUI,MARKC,MARKE,MARKR
 2404  %INTEGER LITL,ROUT,NAM,ARR,PREC,TYPE
 2405  %RECORD (RD) EXPOPND{(RD);                    ! RESULT RECORD FOR EXPOP
 2406           CURR INST=0
 2407           TWSPHEAD=0
 2408           %INTEGERARRAY SGRUSE,SGRINF(0:7)
 2409           ->SW(A(P))
 2410  SW(23):                                 ! INCLUDE SOMETHING
 2411  SW(24):                                 ! REDUNDANT SEP
 2412  SW(2):                                  ! <CMARK> <COMMENT TEXT>
 2413  CSSEXIT:  LAST INST=CURR INST
 2414           %WHILE TWSPHEAD#0 %CYCLE
 2415              POP(TWSPHEAD,JJ,KK,QQ)
 2416              RETURN WSP(JJ,KK)
 2417           %REPEAT
 2418           %RETURN
 2419  SW(1):                                !(UI)(S)
 2420           FAULT(57,0) %UNLESS LEVEL>=2
 2421           MARKER=P+1+A(P+1)<<8+A(P+2)
 2422           P=P+3
 2423           ->LABFND %IF A(MARKER)=1
 2424           %IF A(MARKER)=2 %THEN SET LINE %AND CUI(0) %AND ->CSSEXIT
 2425           MARKE=0; MARKR=0
 2426           MARKUI=P; MARKIU=MARKER+1
 2427           MARKC=MARKIU+1
 2428           %IF A(MARKER)=3 %THEN CIFTHEN(MARKIU,MARKC,MARKUI,0,0,NO) %AND ->CSSEXIT
 2429           CLOOP(A(MARKIU),MARKC+2,MARKUI)
 2430           ->CSSEXIT
 2431  LABFND:  ->SWITCH %UNLESS A(P)=1 %AND A(P+5)=2;  ! 1ST OF UI AND NO APP
 2432           ->SWITCH %UNLESS A(P+6)=2 %AND A(P+7)=2;! NO ENAMSE OR ASSNMNT
 2433           JJ=ENTER LAB(FROM AR2(P+3),0); ->CSSEXIT
 2434  SW(5):                                 ! %CYCLE
 2435           FAULT(57,0) %UNLESS LEVEL>=2
 2436           %IF A(P+5)=2 %THEN %START;     ! OPEN CYCLE
 2437              CLOOP(0,P+1,0)
 2438           %FINISH %ELSE %START
 2439              CLOOP(6,P+6,P+1)
 2440        %FINISH
 2441           ->CSSEXIT
 2442  !
 2443  SW(6):                                 ! REPEAT
 2444           ->CSSEXIT
 2445  SW(22):                                ! '%CONTROL' (CONST)
 2446           J=FROM AR4(P+2)
 2447           CODEOUT
 2448           DCOMP=J>>28; ->CSSEXIT
 2449  !
 2450  SW(3):                                 ! (%IU)(COND)%THEN(UI)(ELSE')
 2451           MARKIU=P+1; MARKC=MARKIU+3
 2452           MARKR=P+2+A(P+2)<<8+A(P+3); ! ! FROMAR2(P+2)
 2453           MARKE=0
 2454           %IF A(MARKR)=3 %THEN %START
 2455              MARKE=MARKR+1+FROMAR2(MARKR+1)
 2456              MARKUI=MARKR+3
 2457           %FINISH
 2458           CIFTHEN(MARKIU,MARKC,MARKUI,MARKE,MARKR,NO)
 2459           ->CSSEXIT
 2460  SW(4):
 2461                                          ! '%FINISH(ELSE')(S)
 2462        ->CSSEXIT
 2463  SWITCH:  %BEGIN;                       ! SWITCH LABEL
 2464  %INTEGER HEAD,BASEPT,NAPS,FNAME
 2465  %INTEGERARRAY BITS(0:2)
 2466           FORGET(-1)
 2467           FNAME=FROM AR2(P+3)
 2468        %UNLESS A(P)=1 %AND A(P+5)=1 %THEN FAULT2(5,0,FNAME) %AND ->BEND
 2469                                          ! 1ST OF UI + APP
 2470           P=P+3; TEST APP(NAPS)
 2471           P=P+6
 2472           %UNLESS INTEXP(JJ)=0 %THEN FAULT2(41,0,0) %AND ->BEND
 2473                                          ! UNLESS EXPRESSION EVALUATES AND
 2474           %UNLESS NAPS=1 %THEN FAULT2(21,NAPS-1,FNAME) %AND ->BEND
 2475                                          ! NO REST OF APP
 2476           %UNLESS A(P+1)=2=A(P+2) %THEN FAULT2(5,0,FNAME) %AND ->BEND
 2477                                          ! NO ENAME OR REST OF ASSIGMENT
 2478           COPY TAG(FNAME)
 2479           HEAD=K
 2480           %IF OLDI#LEVEL %OR TYPE#6 %THEN FAULT(4,FNAME) %AND ->BEND
 2481           FROM123(HEAD,BASEPT,KKK,KK);      ! EXTRACT TABLE ADDR,LB & UB
 2482           MLINK(HEAD);                      ! K POINTS TO BIT LIST
 2483           ->INBD %IF KKK<=JJ<=KK
 2484           FAULT2(50,JJ,FNAME); ->BEND
 2485  INBD:    Q=JJ-KKK
 2486           %WHILE Q>=96 %%CYCLE
 2487              MLINK(HEAD)
 2488              Q=Q-96
 2489           %REPEAT
 2490  !
 2491  ! ASLIST(HEAD) IS THE START OF 96 BIT ENTRY IN THE BIT LIST
 2492  ! CHECK BIT NO Q TO SEE IF LABEL ALREADY SET AND THEN SET BIT Q
 2493  !
 2494           FROM123(HEAD,BITS(0),BITS(1),BITS(2))
 2495           QQ=Q>>5;                      ! RIGHT WORD
 2496           Q=Q&31; JJJ=1<<Q;             ! BIT IN WORD
 2497           FAULT2(6,JJ,FNAME) %UNLESS BITS(QQ)&JJJ=0
 2498           BITS(QQ)=BITS(QQ)!JJJ
 2499           REPLACE123(HEAD,BITS(0),BITS(1),BITS(2))
 2500  !
 2501  ! OPTIMISED (ARR=2) SWITCHES BASEPT POINTS TO THE
 2502  ! ZEROETH NOT THE FIRST ELEMENT
 2503  !
 2504           %IF ARR=2 %THEN KKK=0;         ! RESET LB IF DESC TO ELEMNT 0
 2505           QQ=BASEPT+(JJ-KKK)*4;          ! REL POSITION OF LABEL
 2506           PLUG(2,QQ,CA,4);               ! OVERWRITE THE WORD IN TABLE
 2507                                          ! RELOCATION(BY HD OF CODE) INTACT
 2508  BEND:    %END;   ->CSSEXIT
 2509  SW(7):                                 ! (%WU)(SC)(COND)(RESTOFWU)
 2510           FAULT(57,0) %UNLESS LEVEL>=2
 2511           MARKIU=P+1;                   ! TO WHILE/UNTIL
 2512           MARKC=MARKIU+3;               ! TO (SC)(COND)
 2513           CLOOP(A(MARKIU)+3,MARKC,MARKIU+1+FROMAR2(MARKIU+1))
 2514           ->CSSEXIT
 2515  !
 2516  SW(8):                                 ! SIMPLE DECLN
 2517           FAULT(57,0) %UNLESS LEVEL>=2
 2518           FAULT(40,0) %IF NMDECS(LEVEL)&1#0
 2519           QQ=P; P=P+5;CLT;ROUT=0; LITL=0
 2520           %IF A(P)#1 %THEN %START;      ! ARRAY DECLARATIONS
 2521              FAULT(70,0) %IF TYPE=5 %AND ACC=0
 2522              NAM=0
 2523              SET LINE
 2524              QQ=2-A(P+1); P=P+2;        ! QQ=1 FOR ARRAYFORMATS
 2525              DECLARE ARRAYS(QQ,0)
 2526           %FINISH %ELSE %START
 2527              %IF A(QQ+1)=128 %THEN %START;! NOT LINKED&SHUFFLED
 2528                 CQN(P+1); P=P+2
 2529                 DECLARE SCALARS(1,0)
 2530              %FINISH
 2531           %FINISH
 2532           ->CSSEXIT
 2533  !
 2534  SW(9):                                 ! %END
 2535           %BEGIN
 2536           %SWITCH S(1:5)
 2537           -> S(A(P+1))
 2538  S(1):                                  ! ENDOFPROGRAM
 2539  S(2):                                  ! ENDOFFILE
 2540           %IF CPRMODE=0 %THEN CPRMODE=2
 2541           FAULT(15,0) %UNLESS LEVEL+CPRMODE=3
 2542           FAULT(56,0) %UNLESS A(P+1)=CPRMODE
 2543           CEND(CPRMODE)
 2544           ->BEND
 2545  S(3):                                  ! ENDOFLIST
 2546           LIST=0;
 2547           ->BEND
 2548  S(4):                                  ! END
 2549           CEND(FLAG(LEVEL))
 2550  BEND:    %END
 2551           ->CSSEXIT
 2552  !
 2553  SW(11):
 2554           %BEGIN
 2555           %INTEGER MARKER1,KK,KKK
 2556           %STRING(34)XNAME
 2557           P=P+1; MARKER1=FROM AR2(P)+P; ! (SEX)(RT)(SPEC')(NAME)(FPP)
 2558  AGN:     Q=P; KK=FROM AR2(MARKER1+5);  ! KK ON NAME
 2559           EXTRN=A(P+2)
 2560           LITL=EXTRN&3
 2561           %IF A(MARKER1)=1 %THEN %START;! P<%SPEC'>='%SPEC'
 2562              P=P+3;  CRSPEC(1-EXTRN>>2);! 0 FOR ROUTINESPEC
 2563                                         ! 1 FOR EXTERNAL (ETC) SPEC
 2564              ->BEND
 2565           %FINISH
 2566           COPY TAG(KK)
 2567           %IF OLDI=LEVEL %THEN %START
 2568              %IF CPRMODE=0 %THEN CPRMODE=2;! FLAG AS FILE OF ROUTINES
 2569  !
 2570              %IF (CPRMODE=2 %AND LEVEL=1) %START
 2571                 %IF EXTRN=3 %THEN EXTRN=2
 2572                 XNAME<-STRING(DICTBASE+WORD(KK))
 2573                 %IF EXTRN=1 %THEN XNAME<-"S#".XNAME
 2574                 %IF EXTRN=4 %THEN XNAME=""
 2575                 JJ=MIDCELL;              ! CODE DESCRIPTOR REL ADDR
 2576                 %IF EXTRN#4 %THEN USEBITS=2
 2577                 DEFINE EP(XNAME,CA,JJ,0)
 2578                 %IF JJ#0 %THEN PSF1(INCA,0,-JJ)
 2579              %FINISH %ELSE %START;    ! EXTERNALS IN PRGM OR WRNG LEVEL
 2580                 FAULT(55,KK) %UNLESS EXTRN=4; EXTRN=4
 2581              %FINISH
 2582              %IF A(P+3)=1 %THEN KKK=LITL<<14!16_1000 %ELSE %START
 2583                 ROUT=1; P=P+4;           ! FIGURE OUT PTYPE FOR FNS&MAPS
 2584                 CLT; ARR=0; NAM=0
 2585                 %IF A(P)=2 %THEN NAM=2;  ! SET NAME ARRAY BIT FOR MAPS
 2586                 PACK(KKK);               ! AND STORE PTYPE IN KKK
 2587              %FINISH
 2588           %FINISH
 2589           %UNLESS OLDI=LEVEL %AND J=15 %AND PTYPE=KKK %START
 2590              P=Q+3; CRSPEC(0); P=Q; ->AGN
 2591           %FINISH
 2592           PTYPE=PTYPE!(EXTRN&3)<<14;     ! DEAL WITH %ROUTINESPEC FOLLOWED
 2593                                          ! BY %EXTERNALROUTINE
 2594  %BEGIN
 2595  %INTEGER PTR,PTYPEP,CNT,PP
 2596           J=0; REPLACE TAG(KK);!  BODY GIVEN SO UPDATE TAGS INFO
 2597           JJ=K; PLABEL=PLABEL-1
 2598           %UNLESS COMPILER=1 %OR (CPRMODE=2 %AND LEVEL=1) %START
 2599              %IF JROUND(LEVEL+1)=0 %START;    ! NOT JUMP OUTSTANDING
 2600                 JROUND(LEVEL+1)=PLABEL
 2601                 ENTER JUMP(15,PLABEL,0)
 2602              %FINISH
 2603           %FINISH
 2604           PTYPEP=PTYPE
 2605           P=MARKER1+7
 2606           RHEAD(KK)
 2607           N=20; CNT=1
 2608           %WHILE A(P)=1 %CYCLE;          ! WHILE SOME (MORE) FP PART
 2609              PP=P+1+FROMAR2(P+1)
 2610              P=P+3
 2611              CFPDEL
 2612              PTR=P
 2613              {%UNTIL A(PTR-1)=2} %CYCLE;   ! CYCLE DOWN NAMELIST
 2614                 %IF JJ#0 %THEN %START
 2615                    FROM12(JJ,J,JJJ);     ! EXTRACT PTYPE XTRA INFO
 2616                    %UNLESS J>>16=PTYPE %AND(PTYPE#5 %OR JJJ>>16=ACC) %THEN FAULT2(9,CNT,KK)
 2617                 %FINISH %ELSE FAULT2(8,0,KK);! MORE FPS THAN IN SPEC
 2618                 PTR=PTR+3
 2619                 CNT=CNT+1
 2620                 MLINK(JJ)
 2621              %REPEAT %UNTIL A(PTR-1)=2
 2622              DECLARE SCALARS(0,0)
 2623              P=PP
 2624           %REPEAT;                       ! UNTIL NO MORE FP-PART
 2625           N=(N+3)&(-4);                  ! TO WORD BOUNDARY AFTER ALL SYSTEM
 2626                                          ! STANDARD PARAMETERS HAVE BEEN DECLARED
 2627           FAULT2(10,0,KK) %UNLESS JJ=0
 2628           PTYPE=PTYPEP
 2629           %IF PTYPE&16_F0F=5 %THEN N=N+8;! STR FNS RESULT PARAM IS STACKED
 2630                                          ! AS XTRA PARM JUST BEFORE DISPLAY
 2631           RDISPLAY(KK)
 2632           MAKE DECS(MARKER1+1)
 2633           %END
 2634  BEND:    %END; ->CSSEXIT
 2635  !
 2636  SW(13):                                !REALS(LN)
 2637           FAULT(58,0) %UNLESS  CPRMODE=0
 2638           ALL LONG=A(P+1)&1;->CSSEXIT
 2639  !
 2640  SW(14):                                !%BEGIN
 2641  %BEGIN
 2642           PTYPE=0
 2643           %IF LEVEL=1 %AND RLEVEL=0 %AND CPRMODE=0 %START
 2644              CODE DES(JJ)
 2645              DEFINE EP(MAINEP, CA, JJ, 1)
 2646              RLEVEL=1; RBASE=1
 2647              L(1)=0; M(1)=0; DIAGINF(1)=0; AUXSBASE(1)=0
 2648              CPRMODE=1
 2649              N=24;  NMAX=N
 2650              FORGET(-1)
 2651              DIAG POINTER(LEVEL+1)
 2652  !
 2653  ! THE CODE PLANTED IS AS FOLLOWS:-
 2654  !         STD   (LNB+3)              SAVE DESCRIPTOG TO GLA(PLT)
 2655  !         LXN   (LNB+4)               TO GLA(PLT)
 2656  !         STLN  (XNB+5)               SAVE LNB FOR STOP SEQUENCE
 2657  !         ASF   1                    FOR REPORT WORD
 2658  !
 2659              PSF1(STD,1,12)
 2660              PSF1(LXN,1,16)
 2661              PF1(STLN,0,XNB,20)
 2662  !            PSF1(ASF,0,1)
 2663  !
 2664  ! THE NEXT 8 INSTRUCTIONS ARE REQUIRED TO SET SF 6 WORDS IN FRONT OF LNB
 2665  ! AN ASF 1 WORKS AS WELL EXCEPT FOR K-STAND ALONE WHEN THERE MAY BE
 2666  ! A USELESS REDUNDANT DESCRIPTOR ON THE STACK
 2667  !
 2668              PF1(STLN,0,TOS,0)
 2669              PF1(LSS,0,TOS,0)
 2670              PSF1(IAD,0,24)
 2671              PF1(STSF,0,TOS,0)
 2672              PF1(ISB,0,TOS,0)
 2673              PSF1(ISH,0,-2)
 2674              PF1(ST,0,BREG,0)
 2675              PF1(ASF,0,BREG,0)
 2676  !
 2677  !
 2678  ! SET THE PROGRAM MASK TO MASK OUT UNDERFLOW AND ALLOW ALL OTHER INTS
 2679  !
 2680  !         MPSR  16_40C0
 2681  !
 2682              PF1(MPSR,0,0,16_40C0)
 2683              PTYPE=1
 2684           %FINISH %ELSE SET LINE;       ! SO 'ENTERED FROM LINE' IS OK
 2685           RHEAD(-1)
 2686           RDISPLAY(-1)
 2687           MAKE DECS(P+1)
 2688  %END
 2689           ->CSSEXIT
 2690  !
 2691  SW(15):
 2692                                          ! '%ON'(EVENT')(N)(NLIST)'%START'
 2693        FAULT(57,0) %UNLESS LEVEL>=2
 2694        FAULT(40,0) %IF NMDECS(LEVEL)&1#0
 2695        NMDECS(LEVEL)=NMDECS(LEVEL)!16_11;! NO MORE DECS AND IN ONCOND
 2696        %IF STACK=0 %THEN %START
 2697           SAVE AUX STACK
 2698           DISP=AUXSBASE(LEVEL)
 2699           PSF1(LSS,2,DISP);              ! SAVE TOP OF AUX STACK
 2700           PSF1(ST,1,DISP+12)
 2701        %FINISH
 2702        GRUSE(ACCR)=0
 2703        PSF1(CPSR,1,N+8)
 2704        PLABEL=PLABEL-1
 2705        JJJ=PLABEL
 2706        ENTER JUMP(15,JJJ,B'10');         ! JUMP ROUND ON BODY
 2707  !
 2708        P=P+2; JJ=0;                      ! SET UP A BITMASK IN JJ
 2709        {%UNTIL A(P-1)=2} %CYCLE;           ! UNTIL NO MORE NLIST
 2710           KK=A(P)
 2711           FAULT2(26,KK,0) %UNLESS 1<=KK<=14
 2712           JJ=JJ!1<<(KK-1)
 2713           P=P+2
 2714        %REPEAT %UNTIL A(P-1)=2
 2715        KK=CA; PGLA(4,4,ADDR(CA))
 2716        RELOCATE(GLACA-4,KK,1);           ! ENTRY ADDRESS IN PLT
 2717        ONWORD(LEVEL)=JJ<<18!(GLACA-4)
 2718        FORGET(-1)
 2719        PSF1(ST,1,N);                     ! STORE EVENT,SUBEVENT&LINE
 2720        PSF1(MPSR,1,N+8)
 2721        ONINF(LEVEL)=N; N=N+12
 2722        %IF STACK=0 %THEN %START
 2723           PSF1(LSS,1,DISP+12);           ! RESET AUX STACK TOP
 2724           PSF1(ST,2,DISP)
 2725        %FINISH
 2726        CSTART(0,3)
 2727        NMDECS(LEVEL)=NMDECS(LEVEL)!!16_10;! NOT IN ONCOND
 2728        JJ=ENTER LAB(JJJ,B'111');         ! REPLACE ENVIRONMENT
 2729        ->CSSEXIT
 2730  SW(16):  
 2731           FAULT(57,0) %UNLESS LEVEL>=2
 2732           %BEGIN;                       ! %SWITCH (SWITCH LIST)
 2733           %INTEGER Q,RANGE,KKK,KK,LB,PP,D0,D1,OPHEAD,V,ARRP,R
 2734           Q=P
 2735           ARRP=1
 2736           %IF PARMOPT=0 %THEN ARRP=2
 2737           {%UNTIL A(Q)=2} %CYCLE;         ! UNTIL NO'REST OF SW LIST'
 2738              P=P+3
 2739              P=P+3 %WHILE A(P)=1
 2740              P=P+4;                      ! TO P(+')
 2741              KKK=INTEXP(LB);             ! EXTRACT LOWER BOUND
 2742              P=P+3
 2743              KKK=KKK!INTEXP(KK);         ! EXTRACT UPPER BOUND
 2744              RANGE=(KK-LB+1)
 2745              %IF RANGE<=0 %OR KKK#0 %START
 2746                 FAULT2(38,1-RANGE,FROMAR2(Q+1))
 2747                 LB=0; KK=10; RANGE=11
 2748              %FINISH
 2749              %IF GLACA+8-4*LB<0 %THEN ARRP=1;! ZEROETH ELEMENT OFF FRONT
 2750              PTYPE=16_56+ARRP<<8;         ! WORD LABEL ARRAY
 2751              PP=P; P=Q+1
 2752              {%UNTIL A(P-1)=2} %CYCLE;    !  DOWN NAMELIST
 2753                 K=FROM AR2(P)
 2754                 P=P+3
 2755                 OPHEAD=0; R=LB
 2756  !
 2757  ! SET UP A BIT LIST (96 BITS PER CELL) TO CHECK FOR SWITCH LABELS
 2758  ! SET TWICE
 2759  !
 2760                 {%UNTIL R>KK} %CYCLE
 2761                    PUSH(OPHEAD,0,0,0)
 2762                    R=R+96
 2763                 %REPEAT %UNTIL R>KK
 2764  !
 2765  ! FOR CHECKING MODE USE A BOUNDED WORD DESCRIPTOR AND WORD SIZE
 2766  ! ENTRIES PRESET TO "SW LABEL NOT SET". OPTIMISING USE BCI WORD
 2767  ! ARRAYS WITH BASE SET TO ZEROETH ELEMENT
 2768  
 2769                 D1=(GLACA+15)&(-8);      ! FIRST TABLE ENTRY
 2770                 D0=16_28000000!RANGE;    ! SCALED WORD DES
 2771                 %IF ARRP=2 %THEN %START
 2772                    D0=D0!16_01000000 %UNLESS LB=0;! SET BCI BIT
 2773                    D1=D1-4*LB
 2774                 %FINISH
 2775                 PGLA(8,8,ADDR(D0))
 2776                 SNDISP=GLACA>>2-2;       ! WORD PLT DISP
 2777                 RELOCATE(GLACA-4,D1,2);  ! RELOCATE RELATIVE TO GLA
 2778                 PUSH(OPHEAD,D1,LB,KK)
 2779                 KFORM=0; ACC=4
 2780                 J=1; STORE TAG(K,OPHEAD)
 2781  !
 2782  !THE TABLE WILL CONSIST OF RELATIVE DISPLACEMENTS FROM THE TABLE HEAD
 2783  ! TO THE LABEL POSN. SET ALL TO GO TO PLAB(6) INITIALLY
 2784  !
 2785                 V=PLABS(6)
 2786                 %CYCLE KKK=LB,1,KK
 2787                    RELOCATE(-1,V,1);     ! PLABS(6) RELOCATED BY HD OF CODE
 2788                 %REPEAT
 2789              %REPEAT %UNTIL A(P-1)=2;                   ! FOR ANY MORE NAMES IN NAMELIST
 2790              Q=PP; P=Q
 2791           %REPEAT %UNTIL A(Q)=2;                      ! UNTIL A(Q)=2
 2792           %END;->CSSEXIT
 2793  !
 2794  SW(17):       LIST=1; ->CSSEXIT
 2795  !
 2796  SW(12):                                ! '%OWN' (TYPE)(OWNDEC)
 2797           %BEGIN
 2798  !***********************************************************************
 2799  !*       INITIALISED DECLARATION GO INTO THE GLA OR GLA SYMBOL TABLES  *
 2800  !*       EXCEPT FOR CONST ARRAYS WHICH GO INTO THE CODE SYMBOL TABLES  *
 2801  !*       STRINGS AND ARRAYS HAVE A HEADER IN THE GLA. LPUT ARRANGES    *
 2802  !*       FOR THE LOADER TO RELOCATE THE HEADERS.                       *
 2803  !*      EXTERNALS ARE IDENTICAL WITH OWN BUT ALSO HAVE A DATA EP DEFN  *
 2804  !*       IN THE LOAD DATA SO THEY CAN BE FOUND AT LOAD TIME            *
 2805  !*      EXTRINSICS HAVE A DATA REFERENCE AND A DUMMY HEADER IN THE GLA *
 2806  !*      THE LOADER USES THE FORMER TO RELOCATE THE LATTER.             *
 2807  !***********************************************************************
 2808  %ROUTINESPEC CLEAR(%INTEGER L)
 2809  %ROUTINESPEC STAG(%INTEGER J,DATALEN)
 2810  %ROUTINESPEC XTRACT CONST(%INTEGER CONTYPE,CONPREC)
 2811  %ROUTINESPEC INIT SPACE(%INTEGER A,B)
 2812  %INTEGER LENGTH,BP,PP,SIGN,CBASE,MODE,UICONST,ICONST,TAGDISP,EPTYPE, {%C
 2813+          EPDISP,AH1,AH2,AH3,AH4,AD,FNAM,FINF,SPOINT,CONSTSFOUND,CPREC,{%C
 2814+          EXTRN,NNAMES,MARK,LPUTP,MARKER1,LB,CTYPE,CONSTP,FORMAT, {%C
 2815+          PTSIZE,DIMEN,SACC,TYPEP
 2816  %LONGREAL RCONST,LRCONST
 2817  %OWNLONGREAL ZERO=0
 2818  %STRING(255) SCONST,NAMTXT
 2819  %INTEGERNAME STPTR
 2820           LPUTP=5; STPTR==USTPTR;     ! NORMAL CASE GLA SYMBOLTABLES
 2821  !         FAULT(40,0) %IF NMDECS&1#0
 2822           EXTRN=A(P+1)
 2823           %IF EXTRN>=4 %THEN EXTRN=0;    ! CONST & CONSTANT->0
 2824           LITL=EXTRN
 2825           %IF LITL<=1 %THEN LITL=LITL!!1
 2826           KFORM=0; SNDISP=0
 2827           CONSTS FOUND=0
 2828           %IF EXTRN=0 %THEN LPUTP=4 %AND STPTR==SSTL
 2829           P=P+3; CBASE=0
 2830           MODE=A(P-1);                ! MODE =1 FOR NORMAL OWNS
 2831           ->RECORD %IF MODE>1;        ! MODE =2 FOR OWN RECORDS
 2832           CLT;                        ! MODE =3 FOR OWN RECORD ARRAYS
 2833           %IF A(P)=1 %THEN CQN(P+1) %ELSE ARR=1 %AND NAM=0
 2834           %IF TYPE=5 %AND ACC=0=NAM %THEN FAULT(70,0) %AND ACC=2
 2835           ROUT=0; PACK(PTYPE)
 2836           -> NON SCALAR %IF ARR#0 %AND NAM=0
 2837           P=P+1
 2838           {%UNTIL A(MARK)=2} %CYCLE;    ! UNTIL <RESTOFOWNDEC> NULL
 2839              MARK= P+1+FROM AR2(P+1)
 2840              NNAMES=1
 2841              PP=P+3; P=PP+2;             ! PP ON FIRST NAME'
 2842              %WHILE A(P)=1 %%CYCLE
 2843                 NNAMES=NNAMES+1
 2844                 P=P+3
 2845              %REPEAT
 2846              P=P+1;                         ! P ON CONST'
 2847     !
 2848     ! OBTAIN THE INITIAL CONSTANT,ITS TYPE(CTYPE) AND SIGN(SIGN)
 2849     !
 2850              ICONST=0; UICONST=0
 2851              RCONST=0; LRCONST=0; SCONST=""
 2852              SIGN=3; CTYPE=TYPE; CONSTSFOUND=0; CPREC=PREC
 2853              %IF NAM#0 %THEN CTYPE=1 %AND CPREC=5
 2854     !
 2855              %IF A(P)=1 %THEN %START;     ! CONSTANT GIVEN
 2856                 P=P+1
 2857                 XTRACT CONST(CTYPE,CPREC)
 2858              %FINISH
 2859     !
 2860              {%UNTIL NNAMES=0} %CYCLE;         ! DOWN <NAMELIST>
 2861                 J=0; K=FROM AR2(PP)
 2862                 NAMTXT=STRING(DICTBASE+WORD(K))
 2863                 %IF NAM#0 %THEN %START;     ! OWNNAMES AND ARRAYNAMES
 2864                    %IF EXTRN=3 %THEN FAULT2(46,0,K);! NO EXTRINSIC NAMES
 2865                    UICONST=16_FFFF!PREC<<27
 2866                    PGLA(8,ACC,ADDR(UICONST))
 2867                    TAGDISP=GLACA-ACC; EPDISP=TAGDISP
 2868                 %FINISH %ELSE %START
 2869                 %IF TYPE=5 %THEN %START;         ! STRING
 2870                    QQ=STPTR; AD=ADDR(SCONST)
 2871                    %IF EXTRN=3 %THEN %START;     ! EXTRINSIC STRINGS
 2872                       AH3=0; AH2=PREC<<27!ACC;   ! DUMMY STRING HEADER
 2873                    %FINISH %ELSE %START
 2874                       LPUT(LPUTP,ACC,QQ,AD) %IF INHCODE=0;! O/P STRING
 2875                       STPTR=(STPTR+ACC+3)&(-4)
 2876                       AH3=QQ; AH2=3<<27!ACC
 2877                    %FINISH
 2878                    PGLA(8,8,ADDR(AH2))
 2879                    TAGDISP=GLACA-8
 2880                    %IF EXTRN=3 %THEN GXREF(NAMTXT,2,2<<24!ACC,TAGDISP+4) %ELSE RELOCATE(TAGDISP+4,AH3,LPUTP)
 2881                    EPTYPE=5; EPDISP=QQ;        ! DATA IN GLA SYMBOL TABLES
 2882                 %FINISH %ELSE %START;           ! INTEGER & REAL
 2883                    %IF EXTRN=3 %THEN %START;    ! EXTRINSICS
 2884                       PTYPE=PTYPE!1<<10;        ! EXTRINSICS VIA PTR
 2885                       AH2=PREC<<27; AH3=0
 2886                       PGLA(8,8,ADDR(AH2))
 2887                       TAGDISP=GLACA-8
 2888                       GXREF(NAMTXT,2,2<<24!ACC,TAGDISP+4)
 2889                    %FINISH %ELSE %START;        ! OWN,EXTERNAL&CONST
 2890                       %IF TYPE=2 %THEN %START
 2891                          AD=ADDR(RCONST)
 2892                       %FINISH %ELSE %START;     ! INTEGER VARIABLES
 2893                          AD=ADDR(ICONST)+4-ACC
 2894                       %FINISH
 2895                       %IF EXTRN#0 %THEN PGLA(ACC,ACC,AD);      ! PUT CONSTANT INTO GLA
 2896                       TAGDISP=GLACA-ACC;        ! OFFSET OF VAR FOR TAGS
 2897                       EPDISP=TAGDISP;           ! AND FOR ENTRY DEFN
 2898                       EPTYPE=2;                ! DATA IN ADRESSABLE GLA
 2899                    %FINISH
 2900                 %FINISH
 2901                 %FINISH
 2902                 STAG(TAGDISP,ACC)
 2903                 %IF EXTRN=0=NAM %START;         ! CONST = LITERAL
 2904                    REPLACE2(TAGS(K),INTEGER(AD&(-4)));! BYTES!
 2905                    %IF PREC=6 %THEN REPLACE3(TAGS(K),INTEGER(AD+4))
 2906                    %IF PREC=7 %THEN REPLACE3(TAGS(K),CONSTP)
 2907                 %FINISH
 2908                 PP=PP+3
 2909                 NNAMES=NNAMES-1
 2910              %REPEAT %UNTIL NNAMES=0;           ! DOWN <NAMELIST>
 2911              P=MARK
 2912           %REPEAT %UNTIL A(MARK)=2;     ! UNTIL <RESTOFOWNDEC> NULL
 2913           ->BEND
 2914  RECORD:                                ! <XOWN>'%RECORD'<NAMELIST>
 2915  !***********************************************************************
 2916  !*       NO INITIALISATION OF OWN RECORDS ALLOWED SO THEY ARE ALL      *
 2917  !*       CLEARED TO ZERO.                                              *
 2918  !***********************************************************************
 2919           MARKER1=P+1+FROM AR2(P+1);        ! TO FORMAT NAME
 2920           FNAM=FROM AR2(MARKER1)
 2921           COPYTAG(FNAM)
 2922           FINF=TCELL
 2923           %IF PTYPE#4 %THEN FAULT(62,FNAM) %AND ->BEND
 2924           PTYPE=16_133!LITL<<14
 2925           KFORM=FINF; UNPACK
 2926           %IF MODE=3 %THEN FORMAT=2-A(P) %AND P=P+2 %AND ->RECIN
 2927           P=P+1; BP=ACC;                 ! SIZE OF RECORD FROM FORMAT
 2928           PTYPE=16_33; J=0
 2929           %IF A(P-1)#3 %THEN CQN(P-1) %AND PACK(PTYPE)
 2930           P=P+1; PTSIZE=ACC;           ! SIZE OF HOLE FOR POINTER
 2931           {%UNTIL A(P)=2} %CYCLE
 2932              P=P+1; K=FROM AR2(P)
 2933              NAMTXT=STRING(DICTBASE+WORD(K))
 2934              %IF NAM#0 %THEN %START;     ! OWNNAMES AND ARRAYNAMES
 2935                 %IF EXTRN=3 %THEN FAULT2(46,0,K);! NO EXTRINSIC NAMES
 2936                 UICONST=16_FFFF!PREC<<27
 2937                 PGLA(8,PTSIZE,ADDR(UICONST))
 2938                 EPTYPE=2
 2939                 TAGDISP=GLACA-PTSIZE; EPDISP=TAGDISP
 2940              %FINISH %ELSE %START
 2941                 %IF EXTRN=3 %THEN %START;     ! EXTRINISIC
 2942                    PTYPE=PTYPE!16_400;      ! FORCE NAM=1 (IE VIA POINTER)
 2943                    AH2=16_18000000+BP
 2944                    AH3=0
 2945                    PGLA(8,8,ADDR(AH2))
 2946                    TAGDISP=GLACA-8
 2947                    GXREF(NAMTXT,2,2<<24!BP,TAGDISP+4); ! RELOCATE BY EXTERNAL
 2948                 %FINISH %ELSE %START
 2949                    EPDISP=(GLACA+15)&(-8)
 2950                    AH3=EPDISP
 2951                    AH2=16_18000000+BP;      ! TOP WORD OFDESRCIPTOR
 2952                    PGLA(8,4,ADDR(AH2));     ! ADDED 18MAR76 TO FIX BUG
 2953                    RELOCATE(-1,AH3,2);      ! PUT DISP INTO GLA
 2954                    TAGDISP=EPDISP;          ! AND RELOCATE REL APPROPIATE AREA
 2955                    EPTYPE=2;                ! DATA IN GLA TABLES
 2956                    I=0; ICONST=0
 2957                    %WHILE I<BP %CYCLE
 2958                       PGLA(4,4,ADDR(ICONST))
 2959                       I=I+4
 2960                    %REPEAT
 2961                 %FINISH
 2962              %FINISH
 2963              ACC=BP;                     ! ACC TO SIZE OF RECORD
 2964              STAG(TAGDISP,BP)
 2965              P=P+2
 2966           %REPEAT %UNTIL A(P)=2
 2967           ->BEND
 2968  NONSCALAR:                             ! OWN AND OWNRECORD ARRAYS
 2969  !***********************************************************************
 2970  !*       OWN ARRAYS CAN BE INITIALISED BUT ONLY ONE ARRAY CAN BE       *
 2971  !*       DECLARED IN A STATEMENT.(THANK HEAVENS!)                      *
 2972  !*       OWN RECORD ARRAYS ARE CLEARED TO ZERO                         *
 2973  !***********************************************************************
 2974           P=P+1
 2975           FORMAT=2-A(P)
 2976  RECIN:   PP=P+1; P=P+3; NNAMES=1
 2977           K=FROM AR2(PP)
 2978           NAMTXT=STRING(DICTBASE+WORD(K))
 2979           %IF TYPE>=3 %THEN BP=ACC %ELSE BP=BYTES(PREC)
 2980           SACC=ACC; TYPEP=PTYPE
 2981           AH4=12+DOPE VECTOR(TYPE,BP,0,K,QQ,LB)
 2982           SNDISP=AH4-12;                 ! DV DISP (+TOP BIT FLAG)
 2983           %IF SNDISP=-1 %THEN SNDISP=0;  ! BUM DOPE VECTOR
 2984           SNDISP=(SNDISP&16_3FFFF)>>2;   ! AS WORD DISPLACEMENT
 2985           DIMEN=J;                       ! SAVE NO OF DIMENESIONS
 2986           ACC=SACC; PTYPE=TYPEP; UNPACK
 2987           %IF LB=0 %AND J=1 %AND TYPE<=3 %THEN ARR=2 %AND PACK (PTYPE)
 2988           LENGTH=QQ//BP;                 ! NO OF ELEMENTS
 2989           SPOINT=STPTR
 2990           %IF MODE#3 %AND FORMAT=0 %THEN %START;   ! NOT A RECORD ARRAY
 2991              %IF A(P)=1 %THEN P=P+1 %AND INIT SPACE(QQ,LENGTH)
 2992           %FINISH
 2993           %IF CONSTS FOUND=0 %THEN %START;! NO CONSTANTS GIVEN
 2994                                           ! SO CLEAR AN AREA TO ZERO
 2995              CONSTS FOUND=LENGTH
 2996              CLEAR(QQ) %UNLESS LENGTH<1 %OR EXTRN=3 %OR FORMAT#0
 2997           %FINISH %ELSE %START
 2998              FAULT2(49,0,K) %IF EXTRN=3 %OR FORMAT#0
 2999           %FINISH
 3000           %IF EXTRN=3 %THEN EPDISP=0 %ELSE EPDISP=SPOINT
 3001  !
 3002  ! OUTPUT AN ARRAYHEAD INTO THE GLA RELATIVE TO THE START OF THE SYMBOL-
 3003  ! TABLES IN WHICH THE ARRAY RESIDES.
 3004  !
 3005           J=DIMEN;                       ! RESET DIMENSIONS AFTER INITTING
 3006           %IF TYPE<=2 %THEN AH1=PREC<<27!LENGTH %ELSE AH1=3<<27!1<<25!QQ
 3007           AH1=AH1!(1-PARMARR)<<24;       ! SET BCI IF BASE TO BE SHIFTED
 3008           %IF PREC=4 %THEN AH1=16_58000002
 3009           AH2=EPDISP
 3010           AH3=5<<27!3*J;                 ! DV DESPTR = WORD CHKD
 3011           %IF TYPE<=3 %AND PARMARR=0=FORMAT %AND PARMCHK=0 %AND J=1 %THEN AH2=AH2-BP*LB
 3012           PGLA(8,16,ADDR(AH1))
 3013           TAGDISP=GLACA-16
 3014           %IF EXTRN=3 %THEN %START;     ! EXTRINSIC ARRAYS
 3015              GXREF(NAMTXT,2,2<<24!QQ,TAGDISP+4);   ! RELOCATE ADDR(A(FIRST))
 3016           %FINISH %ELSE %START
 3017              RELOCATE(TAGDISP+4,AH2,LPUTP);! RELOCATE ADDR(A(FIRST))
 3018           %FINISH
 3019           RELOCATE(TAGDISP+12,AH4,1);   ! RELOCATE DV POINTER
 3020           AH4=(AH4<<1>>3)!16_80000000
 3021           NOTE CREF(AH4!(TAGDISP+12)>>2<<16,(AH4&16_FFFF)<<2)
 3022           EPTYPE=5;                    ! DATA IN GLA SYMBOL TABLES
 3023           STAG(TAGDISP,QQ)
 3024           -> BEND
 3025  %ROUTINE INIT SPACE(%INTEGER SIZE,NELS)
 3026  !***********************************************************************
 3027  !*       P IS TO FIRST ENTRY FOR CONSTLIST                             *
 3028  !*    MAP SPACE ONTO WORKFILE END TO GIVE SANE ERROR MESSAGE IF        *
 3029  !*    THERE WAS NOT ENOUGH SPACE                                       *
 3030  !***********************************************************************
 3031  %INTEGER RF,I,K,ELSIZE,AD,SPP,LENGTH,SAVER,WSIZE,WRIT
 3032  {%BYTEINTEGERARRAYNAME SP
 3033  
 3034        %IF SIZE>4096 %THEN WSIZE=4096 %ELSE WSIZE=SIZE
 3035  {%BYTEINTEGERARRAYFORMAT SPF(0:WSIZE+256)
 3036        SAVER=R; R=R+WSIZE+256
 3037        %IF R>ARSIZE %THEN FAULT(102,0)
 3038  %byteintegerarray SP(0:WSIZE+256)
 3039        {SP==ARRAY(ADDR(A(SAVER)),SPF)
 3040        %IF TYPE=1 %THEN AD=ADDR(ICONST)+4-ACC
 3041        %IF TYPE=2 %THEN AD=ADDR(RCONST)
 3042        %IF TYPE=5 %THEN AD=ADDR(SCONST)
 3043        SPP=0; WRIT=0
 3044        ELSIZE=SIZE//NELS
 3045        {%UNTIL A(P-1)=2} %CYCLE
 3046           XTRACT CONST(TYPE,PREC)
 3047           %IF A(P)=1 %START;             ! REPITITION FACTOR
 3048              P=P+1
 3049              %IF INTEXP(RF)#0 %THEN FAULT(44,CONSTS FOUND) %AND RF=1
 3050              P=P+1
 3051           %FINISH %ELSE RF=1 %AND P=P+2
 3052           FAULT(44,CONSTS FOUND) %IF RF<=0
 3053           %CYCLE I=RF,-1,1
 3054              %CYCLE K=0,1,ELSIZE-1
 3055                 %IF CONSTS FOUND<=NELS %THEN SP(SPP)=BYTE INTEGER(AD+K) %AND SPP=SPP+1
 3056              %REPEAT
 3057              CONSTS FOUND=CONSTS FOUND+1
 3058              %IF SPP>=4096 %START;       ! EMPTY BUFFER
 3059                 LPUT(LPUTP,SPP,STPTR+WRIT,ADDR(SP(0))) %IF INHCODE=0
 3060                 WRIT=WRIT+SPP
 3061                 SPP=0
 3062              %FINISH
 3063           %REPEAT
 3064        %REPEAT %UNTIL A(P-1)=2;                          ! UNTIL P<ROCL>=%NULL
 3065        %IF CONSTS FOUND#NELS %THEN FAULT(45,CONSTS FOUND)
 3066        STPTR=(STPTR+3)&(-4)
 3067        LENGTH=(SIZE+3)&(-4)
 3068        LPUT(LPUTP,LENGTH-WRIT,STPTR+WRIT,ADDR(SP(0))) %IF INHCODE=0
 3069        STPTR=STPTR+LENGTH
 3070        R=SAVER
 3071  %END
 3072           %ROUTINE CLEAR(%INTEGER LENGTH)
 3073           STPTR=(STPTR+3)&(-4)
 3074           LENGTH=(LENGTH+3)&(-4)
 3075           LPUT(LPUTP,LENGTH,STPTR,0)%IF INHCODE=0
 3076           STPTR=STPTR+LENGTH
 3077           %END
 3078           %ROUTINE STAG(%INTEGER J,DATALEN)
 3079           %IF EXTRN=2 %THEN LPUT(14,EPTYPE<<24!DATALEN,EPDISP,ADDR(NAMTXT))
 3080           RBASE=CBASE
 3081           STORE TAG(K,J)
 3082           RBASE=RLEVEL
 3083           %END
 3084  %ROUTINE XTRACT CONST(%INTEGER CONTYPE,CONPREC)
 3085  !***********************************************************************
 3086  !*       P POINTS TO P<+'> OF <+'><OPERNAD><RESTOFEXPR>  AND IS UPDATED*
 3087  !*       THE CONST IS CONVERTED TO REQUIRED FORM AND IF INTEGER        *
 3088  !*       IS LEFT IN ICONST, IF REAL IN RCONST AND IF STRING IN SCONST  *
 3089  !***********************************************************************
 3090  %INTEGER LENGTH,STYPE,SPREC,SACC,CPREC,MODE,I
 3091        STYPE=PTYPE; SACC=ACC;! MAY BE CHANGED IF CONST IS EXPR
 3092        %IF CONTYPE=5 %THEN %START
 3093           CTYPE=5
 3094           %IF A(P)=4 %AND A(P+1)=2 %AND A(P+2)=16_35 %AND A(P+A(P+7)+8)=2 %START
 3095              SCONST=STRING(ADDR(A(P+7)))
 3096              LENGTH=A(P+7)
 3097           P=P+A(P+7)+9
 3098           %FINISH %ELSE %START
 3099              FAULT(44,CONSTS FOUND); SCONST=""
 3100              LENGTH=0; P=P-3; SKIP EXP
 3101           %FINISH
 3102        %FINISH %ELSE %START
 3103           MODE=CONPREC<<4!CONTYPE
 3104           %IF CONPREC<5 %THEN MODE=CONTYPE!16_50
 3105           CONSTP=CONSTEXP(MODE)
 3106           %IF CONSTP=0 %THEN FAULT(41,0) %AND CONSTP=ADDR(ZERO);! CANT EVALUATE EXPT
 3107           CTYPE=TYPE; CPREC=PREC
 3108           %IF CTYPE=1 %THEN %START
 3109              ICONST=INTEGER(CONSTP)
 3110              %IF CONPREC=6 %THEN UICONST=ICONST %AND ICONST=INTEGER(CONSTP+4)
 3111           %FINISH %ELSE %START
 3112              RCONST=LONGREAL(CONSTP)
 3113              %IF CONPREC=7 %THEN %START;! LONGLONGS UNALIGNED IN AR
 3114                 %CYCLE I=0,1,15
 3115                    BYTEINTEGER(ADDR(RCONST)+I)=BYTEINTEGER(CONSTP+I)
 3116                 %REPEAT
 3117              %FINISH
 3118           %FINISH
 3119        %FINISH
 3120        PTYPE=STYPE; UNPACK; ACC=SACC
 3121  !
 3122  ! FAULT ANY OBVIOUS ERRORS IE:-
 3123  ! CONSTANT FOR EXTRINSIC OR INCOMPATIBLE TYPE OR STRING TOO LONG
 3124  !
 3125           %IF EXTRN=3 %OR (CTYPE=5 %AND LENGTH>=ACC) %OR (CONTYPE=1 %AND ((CONPREC=3 %AND ICONST>255) %OR (CONPREC=4 %AND ICONST>16_FFFF))) %THEN FAULT(44,CONSTS FOUND)
 3126       %END
?SPREC unused
 3127  BEND:    %END; ->CSSEXIT
 3128  SW(18):
 3129           ABORT
 3130  SW(10):
 3131           %BEGIN;                       ! %RECORD (RDECLN)
 3132  !***********************************************************************
 3133  !*       RECORDS ARE ALLOCATED AT COMPILE TIME WHEN POSSIBLE           *
 3134  !*       SEE CRFORMAT FOR ACTION ON RECORD FORMAT DECLARATIONS         *
 3135  !***********************************************************************
 3136  %INTEGER MODE,RECL,ALLOC,FNAM,FINF,NAME,OPHEAD
 3137           P=P+1; MODE=A(P); SNDISP=0
 3138           %IF MODE=1 %THEN %START;      ! DEAL WITH FORMAT
 3139              NAME=FROM AR2(P+1); P=P+3
 3140              CRFORMAT(OPHEAD); K=NAME
 3141              PTYPE=4; J=0
 3142              KFORM=OPHEAD
 3143              STORE TAG(K,OPHEAD)
 3144              ->BEND
 3145           %FINISH
 3146           P=P+1; MARKER=P+FROM AR2(P)
 3147           FNAM=FROM AR2(MARKER);       ! FORMAT NAME
 3148           COPY TAG(FNAM)
 3149           FINF=TCELL
 3150           %IF TYPE#4 %THEN %START
 3151              FINF=DUMMY FORMAT
 3152              ACC=4; FAULT(62,FNAM)
 3153           %FINISH
 3154           RECL=ACC
 3155           %IF MODE=2%THEN %START;       ! '%RECORDSPEC'
 3156              COPY TAG(FROM AR2(P+2))
 3157              %IF A(P+4)=1 %AND TYPE=4 %START;! SPEC FOR FORMAT ELEMENT
 3158                 P=P+5
 3159                 Q=DISPLACEMENT(TCELL)
 3160                 UNPACK
 3161              %FINISH
 3162              %IF TYPE=3 %AND NAM=1 %AND FROM3(TCELL)&16_FFFF=0 %START
 3163                 REPLACE3(TCELL,FINF!K<<16)
 3164                 REPLACE2(TCELL,SNDISP<<16!RECL)
 3165              %FINISH %ELSE FAULT(63,0)
 3166           %FINISH %ELSE %START;         ! RECORD DECLARATION
 3167              FAULT(57,0) %UNLESS LEVEL>=2
 3168              FAULT(40,0) %IF NMDECS(LEVEL)&1#0
 3169              TYPE=3; PREC=3; ROUT=0
 3170             %IF A(P+2)=1 %THEN %START;  ! SIMPLE RECORD AND RECORDNAMES
 3171                 ALLOC=ACC; CQN(P+3)
 3172                 ACC=ALLOC; P=P+4
 3173                 DECLARE SCALARS(1,FINF)
 3174              %FINISH %ELSE %START;      ! ARRAYS OF RECORDS
 3175                 NAM=0
 3176                 Q=2-A(P+3); P=P+4;      ! Q=1 FOR ARRAY FORMAT
 3177                 SET LINE
 3178                 DECLARE ARRAYS(Q,FINF)
 3179              %FINISH
 3180           %FINISH
 3181  BEND:    %END;->CSSEXIT
 3182  !
 3183  SW(19):
 3184                                          ! '*' (UCI) (S)
 3185           FAULT(57,0) %UNLESS LEVEL>=2
 3186           %BEGIN
 3187           %ROUTINESPEC CIND
 3188           %INTEGER FNAME,ALT,OPCODE,FORM,H,Q,MASK,FILLER
 3189           %SWITCH SW(1:5),F(1:3),POP(1:6),TOP(1:4)
 3190           ALT=A(P+1); P=P+2
 3191           OPCODE=CALL
 3192           ->SW(ALT)
 3193  SW(1):SW(2):
 3194           FNAME=FROM AR2(P)
 3195           COPY TAG(FNAME)
 3196           FAULT(33,FNAME) %UNLESS ROUT=NAM=0 %AND ARR=0 %AND PREC>4 %AND I=RBASE %AND TYPE#7
 3197           %IF ALT=1 %THEN PSF1(ST,1,K) %ELSE GET IN ACC(ACCR,BYTES(PREC)>>2,0,LNB,K)
 3198           ->EXIT
 3199  SW(3):                                  ! PUT (HEX HALFWORD)
 3200           TYPE=A(P)
 3201           PREC=TYPE>>4; TYPE=TYPE&7
 3202           FAULT(32,0) %UNLESS TYPE=1 %AND PREC<6
 3203           %IF PREC=5 %THEN P=P+2
 3204           PLANT(FROM AR2(P+1))
 3205           ->EXIT
 3206  SW(5):                                  ! CNOP
 3207           CNOP(A(P),A(P+1))
 3208           ->EXIT
 3209  SW(4):                                  ! ASSEMBLER
 3210           FORM=A(P);                     ! FORM=PRIMARY,SECONDARY OR 3RY
 3211           OPCODE=A(P+1)
 3212           P=P+2; ->F(FORM)
 3213  F(1):                                   ! ALL PRIMARY FORMAT INSTRUCTIONS
 3214           ALT=A(P); P=P+1
 3215           ->POP(ALT)
 3216  POP(1):                                 ! LABELNAME
 3217           FNAME=FROM AR2(P); P=P+2
 3218           ENTER JUMP(OPCODE<<24!3<<23,FNAME,0)
 3219           ->EXIT
 3220  POP(2):                                 ! DIRECT SYMBOLIC
 3221           CIND
 3222  POPI:    PSORLF1(OPCODE,ACCESS,AREA,DISP)
 3223           ->EXIT
 3224  POP(3):                                ! INDIRECT SYMBOLIC
 3225           CIND
 3226           ACCESS=4-A(P); P=P+1
 3227           ->POPI
 3228  POP(4):                                 ! DR SYMBOLICALLY MODIFIED
 3229           CIND; ACCESS=1; ->POPI
 3230  POP(5):                                 ! (DR) & (DR+B)
 3231           ACCESS=4-A(P); AREA=7
 3232           DISP=0; P=P+1
 3233           ->POPI
 3234  POP(6):                                 ! B
 3235           ACCESS=0
 3236           AREA=7; DISP=0; ->POPI
 3237  F(2):                                   ! SECONDARY (STORE-TO STORE)FORMAT
 3238           MASK=0; FILLER=0; Q=0; FNAME=0
 3239           H=2-A(P)
 3240           %IF H=0 %THEN FNAME=FROM AR2(P+1)-1 %AND P=P+2
 3241           FAULT(32,0) %UNLESS 0<=FNAME<=127
 3242           ALT=A(P+1); P=P+2
 3243           %IF ALT=1 %THEN %START
 3244              Q=1
 3245              MASK=FROM AR2(P)
 3246              FILLER=FROM AR2(P+2)
 3247              P=P+4
 3248              FAULT(32,0) %UNLESS 0<=MASK!FILLER<=255
 3249           %FINISH
 3250           PF2(OPCODE,H,Q,FNAME,MASK,FILLER)
 3251           ->EXIT
 3252  F(3):                                   ! TERTIARY FORMAT
 3253           MASK=FROM AR2(P)
 3254           ALT=A(P+2)
 3255           FAULT(32,0) %UNLESS 0<=MASK<=15
 3256           P=P+3; ->TOP(ALT)
 3257  TOP(1):                                 ! LABEL
 3258           FNAME=FROM AR2(P); P=P+2
 3259           ENTER JUMP(OPCODE<<24!MASK<<21,FNAME,0)
 3260           ->EXIT
 3261  TOP(2):                                 ! SYMBOLIC OPERAND
 3262           CIND
 3263           FAULT(32,0) %IF AREA>=6
 3264           %IF AREA=LNB %OR AREA=XNB %OR AREA=CTB %THEN DISP=DISP//4
 3265  TOPI:    PF3(OPCODE,MASK,AREA,DISP)
 3266           ->EXIT
 3267  TOP(3):                                 ! (DR) & (DR+B)
 3268           DISP=0; AREA=8-A(P)
 3269           P=P+1; ->TOPI
 3270  TOP(4):                                 ! (DR+N)
 3271           DISP=FROM AR2(P); P=P+2
 3272           AREA=1; ->TOPI
 3273           %ROUTINE CIND          
 3274  !***********************************************************************
 3275  !*       COMPILE A SYMBOLIC OPERAND BY SETTING ACCESS,AREA &DISP       *
 3276  !***********************************************************************
 3277  %INTEGER ALT,AFN,FN0,FN1,FN2,FN3,JJ,D,CTYPE,CPREC
 3278  %SWITCH SW(1:4)
 3279        AFN=ADDR(FN0)
 3280           ALT=A(P); ACCESS=0
 3281           P=P+1; ->SW(ALT)
 3282  SW(1):                                  ! (=')(PLUS')(ICONST)
 3283           P=P+1;                         ! PAST (=')
 3284           D=A(P); CTYPE=A(P+1)
 3285           CPREC=CTYPE>>4; CTYPE=CTYPE&7
 3286           %IF CPREC=4 %THEN FN0=FROM AR2(P+2) %ELSE %START
 3287              %CYCLE JJ=0,1,BYTES(CPREC)-1
 3288                 BYTEINTEGER(AFN+JJ)=A(P+JJ+2)
 3289              %REPEAT
 3290           %FINISH
 3291           P=P+2+BYTES(CPREC)
 3292           %IF D=2 %THEN %START
 3293              %IF CTYPE=2 %THEN FN0=FN0!!16_80000000 %ELSE %START
 3294                 %IF CPREC=6 %THEN LONGINTEGER(AFN)=-LONGINTEGER(AFN) %ELSE FN0=-FN0
 3295              %FINISH
 3296           %FINISH
 3297  CNST:    ->LIT %UNLESS CTYPE=1 %AND CPREC<=5 %AND 16_FFFE0000<=FN0<=16_1FFFF
 3298           AREA=0; DISP=FN0
 3299           %RETURN
 3300  LIT:     FAULT(32,0) %UNLESS 1<=CTYPE<=2 %AND 5<=CPREC<=7
 3301           STORE CONST(DISP,BYTES(CPREC),AFN)
 3302           AREA=PC; ACCESS=0
 3303           %RETURN
 3304  SW(2):                                  ! (NAME)(OPTINC)
 3305           FN0=FROM AR2(P); P=P+2
 3306           COPY TAG(FN0)
 3307           %IF (LITL=1 %AND ARR=0) %START
 3308              CTYPE=TYPE; CPREC=PREC
 3309              ALT=TAGS(FN0)
 3310              FROM123(ALT,D,FN0,FN1)
 3311              %IF CPREC=7 %THEN AFN=FN1
 3312              ->CNST
 3313           %FINISH
 3314           %IF TYPE>=6 %OR TYPE=4 %OR (ROUT=1 %AND NAM=0) %THEN FAULT(33,FN0) %AND %RETURN
 3315           %IF ROUT=1 %THEN K=FROM1(K)
 3316           AREA=LNB
 3317           %IF I#RBASE %THEN AREA=SET XORYNB(XNB,I)
 3318           ALT=A(P); D=FROM AR2(P+1)
 3319           %IF ALT=1 %THEN K=K+D
 3320           %IF ALT=2 %THEN K=K-D
 3321           P=P+1; P=P+2 %IF ALT<=2
 3322           DISP=K; %RETURN
 3323  SW(3):                                  ! '('(REG)(OPTINC)')'
 3324           AREA=A(P)+1; ALT=A(P+1); P=P+2
 3325           DISP=0
 3326           D=FROM AR2(P)
 3327           %IF ALT=1 %THEN DISP=D
 3328           %IF ALT=2 %THEN FAULT(32,0)
 3329           %IF AREA=PC %THEN DISP=CA+2*DISP %ELSE DISP=4*DISP
 3330           P=P+2 %UNLESS ALT=3
 3331           %RETURN
 3332  SW(4):                                  ! '%TOS'
 3333           AREA=6; DISP=0
 3334  %END
?FN3 unused
?FN2 unused
 3335  EXIT:    GRUSE(ACCR)=0
 3336           GRUSE(DR)=0
 3337           GRUSE(BREG)=0
 3338           GRUSE(XNB)=0 %IF OPCODE=CALL %OR OPCODE=LXN %OR OPCODE=JLK %OR OPCODE=OUT
 3339           GRUSE(CTB)=0 %IF OPCODE=CALL %OR OPCODE=LCT %OR OPCODE=JLK %OR OPCODE=OUT
 3340  %END
 3341           ->CSSEXIT
 3342  SW(20):
 3343                                          ! '%TRUSTEDPROGRAM'
 3344           COMPILER=1 %IF PARMARR=0 %AND PARMCHK=0; ->CSSEXIT
 3345  SW(21):                                 ! '%MAINEP'(NAME)
 3346           KK=FROM AR2(P+1)
 3347           FAULT(58,0) %UNLESS CPRMODE=0
 3348           MAINEP<-STRING(DICTBASE+WORD(KK))
 3349           ->CSSEXIT
 3350           %ROUTINE CRFORMAT(%INTEGERNAME OPHEAD)
 3351  !***********************************************************************
 3352  !*       CONVERTS A RECORDFORMAT STATEMENT TO A LIST HEADED BY OPHEAD  *
 3353  !*       FORMAT OF AN ENTRY.                                           *
 3354  !*       S1=SUBNAME<<20!PTYPE<<4!J                                     *
 3355  !*       S2,S3=4  16 BIT DISPLACEMENTS  D2,ACC,D1,KFORM                *
 3356  !*       NORMALLY D1=RECORD RELATIVE DISPLACEMENT AND ACC=LMAX(STRINGS)*
 3357  !*       FOR ARRAYS D2=FIRST ELEMENT DISPLACEMENT AND D1=DISPLACEMENT  *
 3358  !*       OF RECORD RELATIVE ARRAYHEAD IN THE GLA                       *
 3359  !*       KFORM IS ONLY USED FOR RECORDS AND POINTS TO THE FORMAT       *
 3360  !*       ON EXIT ACC HAS THE RECORD SIZE ROUNDED UP TO THE BOUNDARY    *
 3361  !*       REQUIRED BY ITS LARGEST COMPONENT                             *
 3362  !***********************************************************************
 3363  %INTEGER D1,D2,NLIST,FORM,RL,MRL,UNSCAL,SC,DESC,FN,INC,Q,R,A0,A1,A2,DV,RFD,LB,OB,TYPEP,SACC
 3364  %SWITCH RFEL(1:5)
 3365  %ROUTINESPEC SN(%INTEGER Q)
 3366  %ROUTINESPEC ROUND
 3367           NLIST=0; OPHEAD=0; FORM=0; ACC=0; OB=0
 3368           MRL=0; INC=0;                 ! INC COUNTS DOWN RECORD
 3369  NEXT:    ROUT=0; LITL=0; NAM=0; RFD=A(P)
 3370           %IF RFD<=2 %THEN P=P+1 %AND CLT
 3371           ->RFEL(RFD)
 3372  RFEL(1):                               ! (TYPE) (QNAME')(NAMELIST)
 3373           CQN(P); P=P+1
 3374           PACK(PTYPE); D2=0
 3375           RL=3
 3376           %IF NAM=0 %AND 3<=PREC<=4 %THEN RL=PREC-3
 3377  AGN:     ROUND ; J=0
 3378           {%UNTIL A(P-1)=2} %CYCLE
 3379              D1=INC; SN(P)
 3380              P=P+3; INC=INC+ACC
 3381           %REPEAT %UNTIL A(P-1)=2
 3382           P=P+RFD>>2<<1;                ! EXTRA  2 FOR RECORDS TO SKIP FORMAT
 3383  TRY END: -> END %IF A(P)=2
 3384           P=P+1; -> NEXT
 3385  RFEL(2):RFEL2:                         ! (TYPE)%ARRAY(NAMELIST)(BPAIR)
 3386           Q=P; ARR=1; PACK(PTYPE)
 3387           %IF TYPE<=2 %THEN UNSCAL=0 %AND SC=PREC %ELSE UNSCAL=1 %AND SC=3
 3388           %IF PREC=4 %THEN DESC=16_58000002 %ELSE DESC=SC<<27!UNSCAL<<25!(1-PARMARR)<<24
 3389           {%UNTIL A(P-1)=2} %CYCLE;       ! UNTIL <RESTOFARRAYLIST> NULL
 3390              P=P+3 %UNTIL A(P-1)=2
 3391  
 3392              TYPEP=PTYPE; SACC=ACC
 3393              DV=DOPE VECTOR(TYPE,ACC,0,FROMAR2(Q),R,LB)+12
 3394                                          ! DOPE VECTOR INTO SHAREABLE S.T.
 3395              ACC=SACC; PTYPE=TYPEP; UNPACK
 3396              %IF TYPE=5 %OR (TYPE=1 %AND PREC=3) %THEN RL=0 %ELSE RL=3
 3397              ROUND
 3398              {%UNTIL A(Q-1)=2} %CYCLE;       ! HEAD  INTO GLA FOR EACH ARRAY
 3399                 A0=R; %IF UNSCAL=0 %THEN A0=A0//ACC
 3400                 %IF PREC=4 %THEN A0=0;   ! STRING DESCRIPTORS !
 3401                 A0=A0!DESC; A1=INC
 3402                 %IF TYPE<=3  %AND PARMARR=0=PARMCHK %AND J=1 %THEN A1=A1-LB*ACC
 3403                 A2=5<<27!3*J
 3404                 PGLA(4,16,ADDR(A0))
 3405                 D1=GLACA-16
 3406                 RELOCATE(D1+12,DV,1);    ! RELOCATE DV POINTER
 3407                 NOTE CREF(16_80000000!(DV<<1>>3)!(D1+12)>>2<<16, (DV&16_FFFF)<<2)
 3408                 D2=INC
 3409                 SN(Q); INC=INC+R
 3410                 Q=Q+3
 3411              %REPEAT %UNTIL A(Q-1)=2;       ! HEAD  INTO GLA FOR EACH ARRAY
 3412              P=P+1; Q=P
 3413           %REPEAT %UNTIL A(P-1)=2
 3414           P=P+2 %IF RFD=5
 3415           -> TRY END
 3416  RFEL(3):                               ! %RECORD (%ARRAY) %NAME
 3417           TYPE=3; PREC=3; NAM=1
 3418           ARR=2-A(P+1); P=P+2
 3419           PACK(PTYPE); D2=0
 3420           RL=3; ACC=8+8*ARR
 3421           FORM=0
 3422           ->AGN
 3423  RFEL(4):                               ! RECORDS IN RECORDS
 3424  RFEL(5):                                ! RECORDARRAYS IN RECORDS
 3425           Q=P+FROM AR2(P+1)+1
 3426           FN=FROM AR2(Q)
 3427           COPY TAG(FN);               ! COPY FORMAT TAG & SET ACC
 3428           FAULT(62,FN) %UNLESS PTYPE=4
 3429           TYPE=3; PREC=3; FORM=TCELL
 3430           %IF RFD=4 %THEN %START
 3431              PTYPE=16_33; P=P+3; D2=0
 3432              RL=3; ->AGN
 3433           %FINISH
 3434           P=P+3; ->RFEL2
 3435  END:                                   ! FINISH OFF
 3436           RL=MRL; ROUND
 3437           ACC=INC;                      ! SIZE ROUNDED APPROPRIATELY
 3438           FAULT(98,0) %UNLESS INC<=16_7FFF
 3439           CLEAR LIST(NLIST)
 3440           %RETURN
 3441           %ROUTINE SN(%INTEGER Q)
 3442  !***********************************************************************
 3443  !*       CHECK THE SUBNAME HAS NOT BEEN USED BEFORE IN THIS FORMAT     *
 3444  !*       AND ENTER IT WITH ITS DESCRIPTORS INTO THE LIST.              *
 3445  !***********************************************************************
 3446           FNAME=FROM AR2(Q)
 3447           FAULT2(61,0,FNAME) %UNLESS FIND(FNAME,NLIST)=-1
 3448           BINSERT(OPHEAD,OB,FNAME<<20!PTYPE<<4!J,D2<<16!ACC,D1<<16!FORM)
 3449           PUSH(NLIST,0,FNAME,0)
 3450           %END
 3451           %ROUTINE ROUND
 3452           MRL=RL %IF RL>MRL
 3453           INC=INC+1 %WHILE INC&RL#0
 3454           %END
 3455           %END;                         ! OF ROUTINE CRFORMAT
 3456           %INTEGERFN DISPLACEMENT(%INTEGER LINK)
 3457  !***********************************************************************
 3458  !*         SEARCH A FORMAT LIST FOR A SUBNAME                          *
 3459  !*      A(P) HAS ENAME--LINK IS HEAD OF RFORMAT LIST. RESULT IS DISP   *
 3460  !*      FROM START OF RECORD                                           *
 3461  !***********************************************************************
 3462  %RECORD(LISTF)%NAME FCELL,PCELL,LCELL{(LISTF)
 3463  %INTEGER RR,II,ENAME,CELL
 3464           ENAME=A(P)<<8+A(P+1); CELL=0
 3465           %IF LINK#0 %THEN %START;    ! CHK RECORDSPEC NOT OMITTED
 3466              FCELL==ASLIST(LINK);        ! ONTO FORMAT TAG CELL
 3467              LINK=FCELL_S3&16_7FFF;      ! LINK TO SIDE CHAIN
 3468              CELL=LINK; II=-1; ACC=-1
 3469              %WHILE LINK>0 %CYCLE
 3470                 LCELL==ASLIST(LINK)
 3471                 %IF LCELL_S1>>20=ENAME %START;      ! RIGHT SUBNAME LOCATED
 3472                    TCELL=LINK
 3473                    RR=LCELL_S1
 3474                    SNDISP=LCELL_S2
 3475                    K=LCELL_S3
 3476                    J=RR&15; PTYPE=RR>>4&16_FFFF
 3477                   ACC=SNDISP&16_FFFF; SNDISP=SNDISP&16_FFFF0000//16_10000
 3478                    KFORM=K&16_FFFF; K=K>>16
 3479                    %IF LINK#CELL %START; ! NOT TOP CELL OF FORMAT
 3480                       PCELL_LINK=LCELL_LINK
 3481                       LCELL_LINK=CELL
 3482                       FCELL_S3=FCELL_S3&16_FFFF0000!LINK
 3483                    %FINISH;              ! ARRANGING LIST WITH THIS SUBNAME
 3484                                          ! AT THE TOP
 3485                    %RESULT=K
 3486                 %FINISH
 3487                 PCELL==LCELL
 3488                 LINK=LCELL_LINK
 3489              %REPEAT
 3490           %FINISH
 3491           FAULT(65,ENAME)
 3492           %IF CELL>0 %THEN PUSH(ASLIST(CELL)_LINK,ENAME<<20!7<<4,0,0)
 3493           PTYPE=7; TCELL=0
 3494           %RESULT=-1
 3495           %END
 3496           %INTEGERFN COPY RECORD TAG(%INTEGERNAME SUBS)
 3497  !***********************************************************************
 3498  !*       PRODUCE PTYPE ETC FOR A COMPOUND NAME BY CHAINING DOWN ONE    *
 3499  !*       ONE OR MORE RECORD FORMAT LISTS. ON EXIT RESULT =0 IF NO      *
 3500  !*       SUBNAME FOUND OR SUBNAME IS OF TYPE RECORD WITH NO FURTHER    *
 3501  !*       SUBNAME ATTACHED. RESULT#0 IF BONE-FIDE SUBNAME LOCATED       *
 3502  !*       ON ENTRY KFORM HAS POINTER TO THE (FIRST ) FORMAT LIST AND    *
 3503  !*       P POINTS TO THE A.R. ENTRY FOR (FIRST) ENAME                  *
 3504  !***********************************************************************
 3505  %INTEGER Q,FNAME
 3506           SUBS=0
 3507           {%UNTIL TYPE#3} %CYCLE
 3508              FNAME=KFORM
 3509              P=P+2; SKIP APP
 3510              %RESULT=0 %IF A(P)=2 %OR FNAME<=0;! NO (FURTHER) ENAME
 3511              SUBS=SUBS+1
 3512              P=P+1; Q=DISPLACEMENT (FNAME)
 3513              UNPACK
 3514           %REPEAT %UNTIL TYPE#3
 3515           %RESULT=Q+1;       ! GIVES 0 IF SUBNAME NOT KNOWN
 3516           %END
 3517  %ROUTINE CRNAME(%INTEGER Z,REG,MODE,BS,AR,DP,%INTEGERNAME NAMEP)
 3518  !***********************************************************************
 3519  !*       DEAL WITH RECORD ELEMENT NAMES.Z AS FOR CNAME.CLINK=TAGS(RN)  *
 3520  !*       MODE=ACCESS FOR RECORD(NOT THE ELEMENT!)                      *
 3521  !*       ON EXIT BASE,AREA & DISP POINT TO REQUIRED ELEMENT            *
 3522  !*       RECURSIVE CALL IS NEEDED TO DEAL WITH RECORDS IN RECORDS      *
 3523  !*       DEPTH SHEWS  RECURSIVE LEVELS- NEEDED TO AVOID MIS SETTING    *
 3524  !*       REGISTER IN USE IF RECORDNAME IN RECORD HAS THE SAME NAME AS  *
 3525  !*       A GENUINE RECORD NAME.                                        *
 3526  !***********************************************************************
 3527  %INTEGER DEPTH,FNAME
 3528  %ROUTINESPEC CENAME(%INTEGER MODE,FNAME,BS,AR,DP,XD)
 3529           DEPTH=0
 3530           FNAME=KFORM;                  ! POINTER TO FORMAT
 3531           %IF ARR=0 %OR (Z=6 %AND A(P+2)=2) %START;! SIMPLE RECORD
 3532              %IF A(P+2)=2 %THEN P=P+3 %ELSE NO APP
 3533              CENAME(MODE,FNAME,BS,AR,DP,0)
 3534           %FINISH %ELSE %START
 3535              CANAME(ARR,BS,DP)
 3536              CENAME(ACCESS,FNAME,BASE,AREA,DISP,0)
 3537           %FINISH; %RETURN
 3538  !
 3539  %ROUTINE CENAME(%INTEGER MODE,FNAME,BS,AR,DP,XD)
 3540  !***********************************************************************
 3541  !*       FINDS OUT ABOUT SUBNAME AND ACTS ACCORDINGLY.MOSTLY ACTION    *
 3542  !*       CONSISTS OF UPPING XD BY OFFSET OF THE SUBNAME BUT IS VERY    *
 3543  !*       HAIRY FOR RECORDS IN RECORDS ETC                              *
 3544  !*       MODE IS ACCESS FOR THE RECORD                                  *
 3545  !***********************************************************************
 3546  %ROUTINESPEC FETCH RAD
 3547  %ROUTINESPEC LOCALISE(%INTEGER SIZE)
 3548  %INTEGER Q,QQ,D,C,W
 3549        DEPTH=DEPTH+1
 3550        %IF A(P)=2 %THEN %START;          ! ENAME MISSING
 3551           ACCESS=MODE; AREA=AR; XDISP=XD
 3552           BASE=BS; DISP=DP;              ! FOR POINTER
 3553           %IF Z<14 %THEN %START;         ! NOT A RECORD OPERATION
 3554              %UNLESS 3<=Z<=4 %OR Z=6 %START;   ! ADDR(RECORD)
 3555                 FAULT(64,0); BASE=RBASE; AREA=-1
 3556                 DISP=0; ACCESS=0; PTYPE=1; UNPACK
 3557              %FINISH
 3558           %FINISH
 3559           %RETURN
 3560        %FINISH
 3561        P=P+1;                            ! FIND OUT ABOUT SUBNAME
 3562        Q=DISPLACEMENT(FNAME);            ! TCELL POINTS TO CELL HOLDING
 3563        UNPACK;                           ! INFO ABOUT THE SUBNAME
 3564        %IF Q=-1=ACC %OR PTYPE=7 %START;  ! WRONG SUBNAME(HAS BEEN FAULTED)
 3565           P=P+2; SKIP APP; P=P-3
 3566           ACCESS=0; BASE=RBASE; DISP=0; AREA=-1
 3567           %RETURN
 3568        %FINISH
 3569        NAMEP=(A(P)<<8!A(P+1))<<16!NAMEP; ! NAMEP=-1 UNALTERED !
 3570        ->AE %IF ARR=1;                   ! ARRAYS INCLUDING RECORDARRAYS
 3571        %IF A(P+2)=2 %THEN P=P+3 %ELSE NO APP
 3572        %IF TYPE<=2 %OR TYPE=5 %OR (TYPE=3 %AND A(P)=2 %AND (3<=Z<=4 %OR Z=6)) %START
 3573           ACCESS=MODE+4+4*NAM; BASE=BS;
 3574           AREA=AR; DISP=DP; XDISP=XD+Q
 3575           %RETURN
 3576        %FINISH
 3577  !
 3578  ! NOW CODING BECOMES HAIRY:- STILL LEFT ARE
 3579  ! A) RECORDS IN RECORDS   Q POINTS TO SECONDARY RECORD
 3580  ! B) RECORDNAMES IN RECORDS   Q HAS OFF-SET OF A POINTER
 3581  ! C) RECORDARRAYNAMES IN RECORDS   Q HAS OFF-SET A HEADER IN RECORD
 3582  ! D) RECORDARRAYS IN RECORDS   NOT YET ALLOWED
 3583  !    Q WOULD HAVE OFF-SET OF A RECORD RELATIVE HEADER IN THE GLA
 3584  !
 3585        XD=XD+Q
 3586        NAMEP=-1
 3587        %IF NAM=1 %THEN %START
 3588           %IF MODE=0 %START
 3589              DP=DP+XD; XD=0; MODE=2
 3590           %FINISH %ELSE %START
 3591              LOCALISE(8);                ! PICK UP RECNAME DESCR &STCK
 3592              AR=AREA; DP=DISP; BS=BASE
 3593           %FINISH
 3594        %FINISH
 3595        CENAME(MODE,KFORM,BS,AR,DP,XD)
 3596        %RETURN
 3597  AE:                                     ! ARRAYS AND ARRAYNAMES AS ELEMEN
 3598        FROM123(TCELL,Q,SNDISP,K)
 3599        ACC=SNDISP&16_FFFF; SNDISP=SNDISP&16_FFFF0000//16_10000
 3600        KFORM=K&16_FFFF; K=K>>16
 3601        C=ACC; D=SNDISP; Q=K; QQ=KFORM
 3602        %IF (Z=6 %OR Z=12) %AND A(P+2)=2 %START;! 'GET ARRAYHEAD' CALL
 3603              P=P+3
 3604           %IF NAM=1 %THEN %START
 3605              ACCESS=MODE+8; BASE=BS
 3606              AREA=AR; DISP=DP; XDISP=XD+Q
 3607              %RETURN
 3608           %FINISH
 3609  !
 3610  ! PASSING AN ARRAY IN A RECORD BY NAME MUST CONSTRUCT PROPER ARRAYHEAD
 3611  ! FROM THE RECORD RELATIVE ONE AT Q(GLA)
 3612  !
 3613           NAMEP=-1
 3614           FETCH RAD
 3615           AREA=-1; DISP=Q
 3616           BASE=0; ACCESS=0;
 3617           CREATE AH(1)
 3618        %FINISH %ELSE %START;             ! ARRAY ELEMENTS IN RECORDS
 3619           NAMEP=-1
 3620           %IF NAM=1 %THEN %START;        ! ARRAYNAMES-FULLHEAD IN RECORD
 3621              XD=XD+Q
 3622              LOCALISE(16);               ! MOVE HEAD UNDER LNB
 3623              CANAME(3,BASE,DISP);        ! ARRAY MODE SETS DISP,AREA&BASE
 3624           %FINISH %ELSE %START;          ! ARRAY RELATIVE HEAD IN GLA
 3625              %IF MODE=0 %OR MODE=2 %%START
 3626                 %IF MODE=0 %THEN W=DP-4 %ELSE  W=DP+4
 3627              %FINISH %ELSE %START
 3628                 FETCH RAD;               ! RECORD ADDR TO ACC
 3629                 GET WSP(W,1)
 3630                 PSF1(ST,1,W); XD=0
 3631                 BS=RBASE
 3632              %FINISH
 3633              CANAME(3,0,Q);              ! RECORD REL ARRAY ACCESS
 3634                                          ! CAN RETURN ACCESS=1 OR 3 ONLY
 3635              %IF PARMARR=0=PARMCHK %AND ACCESS=3 %AND (PREC=3 %OR TYPE>=3) %START
 3636                 PSORLF1(ADB,0,AREA CODE2(BS),W)
 3637                 PSF1(ADB,0,XD) %UNLESS XD=0
 3638                 GRUSE(BREG)=0
 3639              %FINISH %ELSE %START
 3640                 GET IN ACC(DR,2,0,AREA CODE,Q)
 3641                 PSORLF1(INCA,0,AREA CODE2(BS),W)
 3642                 %IF ACCESS=1 %THEN ACCESS=2 %AND AREA=7 %AND XD=XD+NUMMOD*BYTES(PREC)
 3643                 PSF1(INCA,0,XD) %UNLESS XD=0
 3644                 FORGET (DR)
 3645                 AREA=7; DISP=0;          ! AND ACCESS = 2 OR 3 ONLY
 3646                 %IF TYPE=3 %AND A(P)=1 %START; ! WILL BE A FURTHER CALL
 3647                                            ! ON ROUTINE CENAME
 3648                    GET WSP(DISP,2)
 3649                    PSF1(STD,1,DISP)
 3650                    AREA=LNB; BASE=RBASE
 3651                 %FINISH
 3652              %FINISH
 3653           %FINISH
 3654           %IF TYPE=3 %THEN CENAME(ACCESS,QQ,BASE,AREA,DISP,0)
 3655        %FINISH
 3656        %RETURN
 3657  %ROUTINE FETCH RAD
 3658  !***********************************************************************
 3659  !*       SET ACC TO 32 BIT ADDRESS OF RECORD.                          *
 3660  !***********************************************************************
 3661           ACCESS=MODE+4
 3662           AREA=AR; BASE=BS
 3663           DISP=DP; XDISP=XD
 3664           NAMEOP(4,ACCR,4,-1)
 3665           %END
 3666  %ROUTINE LOCALISE(%INTEGER SIZE)
 3667  !***********************************************************************
 3668  !*       REMOVES A DESCRIPTOR OR ARRAYHEAD FROM A RECORD AND STORES    *
 3669  !*       IT IN A TEMPORARY UNDER LNB.                                  *
 3670  !***********************************************************************
 3671  %INTEGER HOLE
 3672           ACCESS=MODE+4
 3673           AREA=AR; BASE=BS; DISP=DP
 3674           XDISP=XD
 3675           NAMEOP(2,ACCR,SIZE,-1)
 3676           GET WSP(HOLE,SIZE>>2)
 3677           PSF1(ST,1,HOLE)
 3678           MODE=2; AREA=LNB
 3679           BASE=RBASE; DISP=HOLE; XD=0
 3680           %END;                         ! OF ROUTINE LOCALISE
 3681           %END;                         ! OF ROUTINE CENAME
 3682           %END;
?REG unused
 3683                ;                         ! OF ROUTINE CRNAME
 3683           %ROUTINE CSTREXP(%INTEGER MODE,REG)
 3684  !***********************************************************************
 3685  !*       PLANT IN-LINE CODE FOR CONCATENATION. A WORK AREA UNDER       *
 3686  !*       BASE REGISTER COVER IS USUALLY REQUIRED. THE CURRENT LENGTH   *
 3687  !*       OF STRING IN THE WORK AREA IS KEPT IN A REGISTER (BREG)       *
 3688  !*       WHICH IS PROTECTED THROUGH THE NORMAL INTERMEDIATE-RESULT     *
 3689  !*       MECHANISMS.                                                   *
 3690  !*       ON ENTRY:-                                                    *
 3691  !*       MODE=0    NORMAL. WK AREA NOT USED FOR ONE OPERAND EXPSSNS    *
 3692  !*       MODE=1     STRING MUST GO TO WORK AREA                        *
 3693  !*       (AND TO COME)                                                 *
 3694  !*       MODE=3    CONCATENATE INTO LHS OF =ASSNMNT (E.G. A=B.C)       *
 3695  !*       MODE=4    OPTIMISE  S=S.T   BY NOT COPYING S                  *
 3696  !*       2**4 BIT OF MODE IS SET IF WK-AREA NOT TO BE FREED ON EXIT    *
 3697  !*       ON EXIT:-                                                     *
 3698  !*       BASE,DISP & INDEX DEFINE RESULT                               *
 3699  !*       VALUE#0 %IF RESULT IN A WORK AREA(CCOND MUST KNOW)            *
 3700  !*       STRINGL SET IF STRING LENGTH KNOWN. STRFNRES DEFINES LENREG   *
 3701  !***********************************************************************
 3702  %INTEGER PP,WKAREA,DOTS,REXP,ERR,CLEN,KEEPWA,FNAM
 3703  %INTEGERFNSPEC STROP(%INTEGER REG)
 3704           KEEPWA=MODE&16; MODE=MODE&15
 3705           PP=P; STRINGL=0; FNAM=0; WKAREA=0
 3706           REXP=2-A(P+1+FROM AR2(P+1));         ! =0 %IF ONE OPERAND EXP
 3707           -> NORMAL %UNLESS A(P+3)=4 %AND REXP=0 %AND MODE=0
 3708           -> SIMPLE %IF A(P+4)=2
 3709           -> NORMAL %UNLESS A(P+4)=1
 3710  !         COPY TAG(FROM AR2(P+5))
 3711  !         %IF PTYPE=SNPT %THEN PTYPE=TSNAME(K)
 3712  !         -> NORMAL %UNLESS ROUT=0 ; ! BEWARE OF MAP=FN
 3713  !         -> NORMAL %IF PARMARR=1 %AND(ARR#0 %OR A(P+7)=1)
 3714  SIMPLE:  P=P+4
 3715           ERR=STROP(REG)
 3716           -> ERROR %UNLESS ERR=0
 3717           VALUE=WKAREA
 3718           P=P+1; STRFNRES=0
 3719           %RETURN
 3720  ERROR:   FAULT2(ERR,0,FNAM)
 3721           BASE=RBASE; DISP=0
 3722           VALUE=0; ACCESS=0
 3723           P=PP; SKIP EXP
 3724           %RETURN
 3725  NORMAL:  CLEN=0; P=P+3;                ! LENGTH OF CONSTANT PART
 3726           ERR=72; ->ERROR %UNLESS A(P)=4
 3727           P=P+1
 3728           GET WSP(WKAREA,268);          ! GET NEXT OPERAND
 3729           DOTS=0;                        ! NO OPERATORS YET
 3730  NEXT:    STRINGL=0
 3731           ERR=STROP(DR);                ! GET NEXT OPERAND
 3732           -> ERROR %UNLESS ERR=0
 3733           %IF REGISTER(ACCR)#0 %THEN BOOT OUT(ACCR)
 3734           PSF1(LB,0,WKAREA);             ! BYTE DISP FROM LNB
 3735           PPJ(0,19+DOTS);                ! TO SUBROUTINE 19 OR 20
 3736           %IF A(P)=2 %THEN -> TIDY;     ! NO MORE OPERATIONS
 3737           ERR=72; -> ERROR %UNLESS A(P+1)=CONCOP; ! CONCATENATE
 3738           DOTS=DOTS!1
 3739           P=P+2; -> NEXT
 3740  TIDY:                                  ! FINISH OFF
 3741           VALUE=WKAREA
 3742           P=P+1;                        ! PAST REST OF EXPRN
 3743           RETURN WSP(WKAREA,268) %IF KEEPWA=0
 3744           STRINGL=0
 3745           %RETURN
 3746  %INTEGERFN STROP(%INTEGER REG)
 3747  !***********************************************************************
 3748  !*       DEALS WITH OPERAND FOR CONCATENATION. RETURN RESULT=0 FOR     *
 3749  !*       VALID OPERAND OTHERWISE AN ERROR NUMBER.                      *
 3750  !***********************************************************************
 3751  %INTEGER CTYPE,VAL,MODE
 3752           MODE=A(P);                    ! ALTERNATIVE OF OPERAND
 3753           %RESULT=75 %IF MODE>2
 3754           %IF MODE#1 %THEN %START
 3755              CTYPE=A(P+1);             ! GET CONST TYPE & LOSE AMCK FLAGS
 3756              %IF CTYPE=16_35 %THEN %START
 3757                 STRINGL=A(P+6)
 3758                 DISP=FROM AR4(P+2)
 3759                 P=P+STRINGL+7
 3760              %FINISH %ELSE %RESULT=71
 3761              PF1(LDRL,0,PC,STRLINK)
 3762              PSF1(INCA,0,DISP) %IF DISP#0
 3763              %IF STRINGL#1 %THEN %START
 3764                 %IF STRINGL<=63 %THEN PSF1(LDB,0,STRINGL) %ELSE PF1(LDB,2,7,0);! ((DR))
 3765              %FINISH
 3766              GRUSE(DR)=0
 3767              %IF REG=ACCR %THEN COPY DR
 3768           %FINISH %ELSE %START
 3769              P=P+1;                      ! MUST CHECK FIRST
 3770              REDUCE TAG;                 ! SINCE CNAME ONLY LOADS STRINGS
 3771                                          ! AND LONGINTS TO DR!
 3772              %IF 5#TYPE#7 %THEN FNAM=FROMAR2(P) %AND %RESULT=71
 3773              CNAME(2,REG)
 3774              STRINGL=0
 3775              %IF ROUT#0 %AND NAM<=1 %START;! WAS FUNCTION NOT MAP
 3776                 %IF WKAREA=0 %AND KEEPWA#0 %THEN WKAREA=STRFNRES %ELSE RETURN WSP(STRFNRES,268)
 3777              %FINISH
 3778           %FINISH
 3779           %RESULT=0
 3780           %END;
?VAL unused
 3781                ;                         ! OF INTEGERFN STROP
 3781           %END;                         ! OF ROUTINE CSTREXP
 3782  %ROUTINE CRES (%INTEGER LAB)
 3783  !**********************************************************************
 3784  !*       COMPILES A RESOLUTION E.G A->B.(C).D.(E).F AND JUMPS TO LAB   *
 3785  !*       ON FAILURE. (LAB=0 FOR UNCONDITIONAL RESOLUTION TO PERM ON    *
 3786  !*       FAILURE ).                                                    *
 3787  !*       THE  METHOD IS TO CALL A SUBROUTINE PASSING 3 PARAMS:-        *
 3788  !*       P1  POINTS TO LHS(A)                                          *
 3789  !*       P2    STRING TO CONTAIN FRAGMENT (PASSED BY NAME)             *
 3790  !*       P3 THE EXPRESSION PASSED AS DESCRIPTOR                        *
 3791  !*       SUBROUTINE TRIES TO PERFORM THE RESOLUTION AND SETS THE       *
 3792  !*       CONDITION CODE =8 IF IT SUCCEEDS.                             *
 3793  !*                                                                     *
 3794  !*       ON ENTRY LHS IS DEFINED BY DESCRIPTOR REG.                    *
 3795  !*       P POINTS TO P(+') OF RHS DEFINED AS (+')(OPERAND)(RESTOFEXP)  *
 3796  !*                                                                     *
 3797  !$       THE ROUTINE IS COMPACT BUT DIFFICULT TO FOLLOW (OR ALTER)     *
 3798  !*       THE TIME IN PERM IS LARGE SO IT IS NOT WORTHWHILE TO PERSUE   *
 3799  !*       CODE EFFICIENCY TOO INDUSTRIOUSLY .                           *
 3800  !**********************************************************************
 3801  %INTEGER P1,P2,SEXPRN,W,LAST,ERR,FNAM
 3802  %RECORD (RD) R{(RD)
 3803           LAST=0; FNAM=0;                ! =1 WHEN END OF EXPRNSN FOUND
 3804           SEXPRN=0;                      ! RESOLUTION(BRKTD) EXPRESSNS
 3805           ERR=74;                        ! NORMAL CRES FAULT
 3806           PSF1(INCA,0,1);                ! TO FIRST CHAR
 3807           P1=P; P=P+3
 3808           ->RES %IF A(P)=4;              ! LHS MUST BE A STRING
 3809                                          ! BUT THIS CHECKED BEFORE CALL
 3810           ERR=72
 3811  ERROR:   FAULT2(ERR,0,FNAM)
 3812           P=P1; SKIP EXP; %RETURN
 3813  RES:     P=P+1;                        ! TO P(OPERAND)
 3814           PSF1(PRCL,0,4)
 3815           %IF SEXPRN=0 %THEN W=STD %ELSE W=ST
 3816           PF1(W,0,TOS,0)
 3817           %IF A(P)=3 %THEN PSF1(LSD,0,0) %AND GRUSE(ACCR)=0 %ELSE %START;! B OMITTED
 3818              ->ERROR %UNLESS A(P)=1;       ! P(OPERAND)=NAME
 3819              P=P+1; P2=P
 3820              CNAME(3,ACCR)
 3821              %IF TYPE#5 %THEN ERR=71 %AND FNAM=FROMAR2(P2) %AND ->ERROR
 3822              %IF A(P+1)#CONCOP %THEN ERR=72 %AND ->ERROR
 3823              P=P+2
 3824           %FINISH
 3825           PF1(ST,0,TOS,0);               ! B (OR DUMMY) TO P2
 3826           ->ERROR %UNLESS A(P)=3;        ! P(OPERAND)='('(EXPR)')'
 3827           SEXPRN=SEXPRN+1; P=P+1
 3828           CSTREXP(0,DR);                 ! TO REGISTER DR
 3829  !
 3830           PF1(STD,0,TOS,0)
 3831           PSF1(RALN,0,11)
 3832           PPJ(-1,16)
 3833                                         ! DEAL WITH CC#8 IE RESLN FAILED
 3834           %IF LAB#0 %THEN ENTER JUMP(7,LAB,B'11') %ELSE PPJ(7,12)
 3835  !
 3836           -> END %IF A(P)=2
 3837           %IF A(P+1)#CONCOP %THEN ERR=72 %AND ->ERROR
 3838           ->ERROR %UNLESS A(P+2)=1
 3839           P2=P+1; P=P2+1
 3840           P=P+3 %AND SKIP APP %UNTIL A(P)=2
 3841           %IF A(P+1)=1 %THEN P=P2 %AND ->RES
 3842           P1=P+1
 3843           REGISTER(ACCR)=1
 3844           OLINK(ACCR)=ADDR(R)
 3845           R_PTYPE=1; R_XB=ACCR
 3846           R_FLAG=9
 3847           P=P2+2; CNAME(1,DR)
 3848           %IF R_FLAG#9 %THEN PF1(LSD,0,TOS,0)
 3849           REGISTER(ACCR)=0
 3850           PF1(STUH,0,BREG,0)
 3851           PF1(LUH,0,BREG,0)
 3852           PF2(MVL,0,0,0,0,0)
 3853           %IF ROUT#0 %OR NAM#0 %THEN PPJ(0,18);! ASSNMNT CHECK (Q.V)
 3854           PF2(MV,1,1,0,0,UNASSPAT&255)
 3855           GRUSE(ACCR)=0
 3856           %IF PARMARR=1 %START
 3857              PSF1(USH,0,8)
 3858              PSF1(USH,0,-40)
 3859              PPJ(36,9)
 3860           %FINISH
 3861           P=P1
 3862  END:
 3863           P=P+1
 3864           %END
 3865  %ROUTINE SAVE AUX STACK
 3866  !***********************************************************************
 3867  !*       COPY AUX STACK DESCRPTR & POINTER INTO CURRENT STACK FRAME    *
 3868  !*       FIVE WORDS ARE USED FOR THIS PURPOSE:-                         *
 3869  !*       1&2 HOLD AUX STACK DESCRIPTOR                                 *
 3870  !*       3 HOLDS VALUE AT BLK ENTRY FOR USE AT EXIT                    *
 3871  !*       4 HOLDS STACKTOP VALUE AFTER ALL ARRAY DECLNS(FOR %ONS)       *
 3872  !*       5 HOLD STACKLIMIT FOR CHECKING AT ARRAY DECLARATIONS          *
 3873  !*       THE LATTER IS OMITTED INPARM=OPT                              *
 3874  !***********************************************************************
 3875  %INTEGER XYNB, DR0, DR1
 3876        %IF AUXST=0 %THEN %START;         ! FIRST REF PUT REF IN PLT
 3877           DR0=16_30000001; DR1=0
 3878           PGLA(8,8,ADDR(DR0))
 3879           AUXST=GLACA-8
 3880           GXREF(AUXSTEP,2,16_02000008,AUXST+4)
 3881        %FINISH
 3882        %IF AUXSBASE(LEVEL)=0 %START
 3883           XYNB=SET XORYNB(-1,-1)
 3884           PF1(LD,2,XYNB,AUXST)
 3885           %IF PARMOPT#0 %THEN %START
 3886              PF1(LSS,1,0,2);             ! PICK UP STACKTOP
 3887              PSF1(ST,1,N+16)
 3888           %FINISH
 3889           PF1(LSS,2,7,0)
 3890           PSF1(STD,1,N)
 3891           PSF1(ST,1,N+8)
 3892           AUXSBASE(LEVEL)=N; N=N+16
 3893           %IF PARMOPT#0 %THEN N=N+4
 3894           GRUSE(DR)=0; GRUSE(ACCR)=11; GRINF1(ACCR)=0
 3895        %FINISH
 3896  %END
 3897  %ROUTINE RESET AUX STACK
 3898  !***********************************************************************
 3899  !*       IF ANY ARRAYS HAVE BEEN PUT ON THE AUXSTACK THEN UNDECLARE    *
 3900  !***********************************************************************
 3901           %IF AUXSBASE(LEVEL)#0 %START
 3902              PSF1(LB,1,AUXSBASE(LEVEL)+8)
 3903              PSF1(STB,2,AUXSBASE(LEVEL))
 3904              GRUSE(BREG)=0
 3905           %FINISH
 3906  %END
 3907           %ROUTINE RT EXIT
 3908  !***********************************************************************
 3909  !*       THIS ROUTINE COMPILES CODE FOR ROUTINE EXIT(IE '%RETURN')     *
 3910  !***********************************************************************
 3911           RESET AUX STACK
 3912           PSF1(EXIT,0,-16_40)
 3913           %END
 3914  %ROUTINE CLAIM ST FRAME(%INTEGER AT,VALUE)
 3915  !***********************************************************************
 3916  !*       FILL ASF INSTN IN RT ENTRY SEQUENCE TO CLAIM THE STACKFRAME   *
 3917  !***********************************************************************
 3918  %INTEGER INSTR, WK
 3919           WK=AT>>18;               ! BYTES CLAIMED BY ENTRY SEQ
 3920           AT=AT&16_3FFFF;            ! ADRR OF ASF INSTRN
 3921           INSTR=(ASF+12*PARMCHK)<<24!3<<23!(VALUE-WK+3)>>2
 3922           PLUG(1,AT,INSTR,4)
 3923  %END
 3924           %ROUTINE CEND (%INTEGER KKK)
 3925  !***********************************************************************
 3926  !*       DEAL WITH ALL OCCURENCES OF '%END'                            *
 3927  !*       KKK=PTYPE(>=16_1000) FOR ROUTINES,FNS AND MAPS                *
 3928  !*       KKK=0 FOR ENDS OF '%BEGIN' BLOCKS                             *
 3929  !*       KKK=1 FOR '%ENDOFPROGRAM'                                     *
 3930  !*       %ENDOFPROGRAM IS REALLY TWO ENDS. THE FIRST IS THE USERS      *
 3931  !*       AND THE SECOND IS PERMS. KKK=2 FOR A RECURSIVE CALL OF CEND   *
 3932  !*       ON END OF PROGRAM TO DEAL WITH THE %END CORRESPONDING TO      *
 3933  !*       THE %BEGIN COMPILED IN THE INITIALISATION SEQUENCE            *
 3934  !***********************************************************************
 3935           %INTEGER KP,JJ,BIT
 3936           %ROUTINESPEC DTABLE(%INTEGER LEVEL)
 3937           SET LINE %UNLESS KKK=2
 3938           FORGET(-1)
 3939           BIT=1<<LEVEL
 3940  !
 3941  ! NOW PLANT AN ERROR EXIT FOR FNS AND MAPS - CONTROL SHOULD BE RETURNED
 3942  ! VIA %RESULT= AN SHOULD NEVVER REACH THE %END INSTRUCTION
 3943  !
 3944           %IF KKK&16_3FFF>16_1000 %AND COMPILER=0 %AND LAST INST=0 %THEN PPJ(15,10);          ! RUN FAULT 11
 3945           NMAX=N %IF N>NMAX;            ! WORK SPACE POINTER
 3946  !
 3947  ! CLEAR OUT THE LABEL LIST FAULTING LABELS WITH JUMPS OUTSTANDING
 3948  ! AS NOT SET AND COMMENTING ON LABELS NOT USED
 3949  !
 3950           %WHILE LABEL(LEVEL)#0 %CYCLE
 3951              POP(LABEL(LEVEL),I,J,KP)
 3952              I=I>>24
 3953              %IF J&16_FFFF#0 %THEN %START
 3954                 J=J&16_FFFF
 3955                 %IF 0<KP<=MAX ULAB %THEN FAULT2(11,FROM3(J),KP)
 3956                 CLEAR LIST(J)
 3957              %FINISH %ELSE %START
 3958                 %IF I=0 %AND KP<MAX ULAB %THEN WARN(3,KP)
 3959              %FINISH
 3960           %REPEAT
 3961  !
 3962           %CYCLE JJ=0,1,4
 3963              CLEAR LIST(AVL WSP(JJ,LEVEL));! RELEASE TEMPORARY LOCATIONS
 3964           %REPEAT
 3965  !
 3966           DTABLE(LEVEL);                ! OUTPUT DIAGNOSTIC TABLES
 3967  !
 3968  ! CLEAR DECLARATIONS - POP UP ANY GLOBAL NAMES THAT WERE REDECLARED
 3969  ! DESTROY SIDE CHAINS FOR ROUTINES,FORMATS AND SWITCHES
 3970  !
 3971  !
 3972  ! NOW CLAIM THE STACK FRAME BY FILING THE ASF IN THE BLOCK ENTRY CODING
 3973  !
 3974           NMAX=(NMAX+7)&(-8)
 3975           %IF KKK=2 %THEN %RETURN
 3976         %IF KKK>=16_1000 %OR KKK=1 %THEN CLAIM ST FRAME(SET(RLEVEL),NMAX)
 3977  !
 3978  ! NOW PLANT THE BLOCK EXIT SEQUENCE
 3979  !
 3980           %IF KKK&16_3FFF=16_1000 %AND LAST INST=0 %THEN RT EXIT
 3981           PPJ(15,21) %IF KKK=1 %AND LAST INST=0;! %STOP AT %ENDOFPROGRAM
 3982           %IF KKK=0 %THEN %START;         ! BEGIN BLOCK EXIT
 3983              %IF PARMTRACE=1 %THEN %START;    ! RESTORE DIAGS POINTERS
 3984                 PSF1(LD,1,12)
 3985                 DIAG POINTER(LEVEL-1)
 3986                 PSF1(STD,1,12)
 3987              %FINISH
 3988              %IF STACK#0 %START
 3989                 JJ=NMDECS(LEVEL)>>14
 3990                 %IF JJ#0 %THEN %START;   ! ARRAYS TO BE UNDECLARED
 3991                    PF1(STSF,0,TOS,0)
 3992                    PF1(LSS,0,TOS,0)
 3993                    PSF1(ISB,1,JJ)
 3994                    PSF1(USH,0,-2)
 3995                    PF1(ST,0,TOS,0)
 3996                    PF1(ASF,0,TOS,0)
 3997                    GRUSE(ACCR)=0
 3998                 %FINISH
 3999              %FINISH %ELSE RESET AUX STACK
 4000           %FINISH
 4001  !
 4002  ! RETURN TO PREVIOUS LEVEL PROVIDED THERE IS A VALID ONE !
 4003  !
 4004           %UNLESS LEVEL>2 %OR (LEVEL=2 %AND CPRMODE=2) %THEN %START
 4005              %IF KKK=1 %AND LEVEL=2 %THEN KKK=2 %ELSE FAULT(14,0) %AND %STOP
 4006           %FINISH
 4007           LEVEL=LEVEL-1
 4008           %IF KKK>=16_1000 %THEN %START
 4009              RLEVEL=RLEVEL-1
 4010              RBASE=RLEVEL
 4011           %FINISH
 4012  !
 4013  ! RESTORE INFORMATION ABOUT THE (NEW) CURRENT LEVEL
 4014  !
 4015           POP(LEVELINF,KP,N,KP)
 4016           NMAX=N>>16 %IF KKK>=16_1000
 4017           N=N&16_7FFF
 4018           %IF KKK=2 %THEN CEND(KKK);    ! ROUND AGAIN FOR 'ENDOFPROGRAM'
 4019  !
 4020  ! COMPLETE THE JUMP AROUND ALL NON-EXTERNAL ROUTINES EXCEPT WHEN
 4021  ! %TRUSTEDPROGRAM IS IN OPERATION.
 4022  !
 4023           %IF ASL WARN#0 %THEN ASL WARN=0 %AND EPILOGUE
 4024           %IF KKK>=16_1000 %AND COMPILER=0 %AND(RLEVEL>0 %OR CPRMODE#2) %THEN %START
 4025              JJ=NEXTP+6
 4026              %UNLESS A(NEXTP+5)=11 %AND A(JJ+FROMAR2(JJ))=2 %START
 4027                 JJ=ENTER LAB(JROUND(LEVEL+1),0)
 4028                 JROUND(LEVEL+1)=0
 4029              %FINISH
 4030           %FINISH
 4031           %RETURN
 4032  !
 4033  ! LAYOUT OF DIAGNOSIC TABLES
 4034  ! ****** ** ********* ******
 4035  !
 4036  ! THE BOUND FIELD OF PLT DESCRIPTOR STORED AT (LNB+3 & LNB+4) IF
 4037  ! USED TO CONTAIN A DISPLACEMENT RELATIVE TO THE START OF SST OF THE
 4038  ! DIAGNOSTIC TABLES FOR THE BLOCK OR ROUTINE BEING EXECUTED.
 4039  ! A ZERO BOUND MEANS NO DIAGNOSTIC REQUESTED.(NB THIS MAY MEAN A DUMMY
 4040  ! FIRST WORD IN THE SST).
 4041  ! THE ABSOLUTE ADDRESS OF THE SST FOR THE CURRENT CODE SEGMENT WILL
 4042  ! ALWAYS BE FOUND IN THE STANDARD 10 WORDS OF THE GLA/PLT
 4043  !
 4044  ! FORM OF THE TABLES:-
 4045  !
 4046  ! WORD 0    =   LINE OF RT IN SOURCE PROG <<16 ! LINE NO POSN(FROM LNB)
 4047  ! WORD 1    =   (12 LANG DEPENDENT BITS)<<18 ! ENVIRONMENT
 4048  !                ( TOP 2 BITS OF LANG DEPENDENT HAS LITL FROM PTYPE)
 4049  !                 ( BOTTOM 4 BITS HAVE TEXTUAL LEVEL)
 4050  ! WORD 2    =   DISPLAY POSN (FROM LNB)<<16 ! RT TYPE INFO
 4051  ! WORD 3    =   ZERO FOR BLKS OR STRING(<=11BYTES) BEING THE
 4052  !               RT NAME. THIS WILL TAKE WORDS 4 AND 5 IF NEEDED
 4053  ! WORD 6    =  LANGUAGE DEPENDENT INFO . IMP ON CONDITIONS ETC
 4054  !
 4055  ! THE REST IS MADE UP OF VARIABLE ENTRIES AND THE SECTION IS TERMINATED BY
 4056  ! A WORD OF 16_FFFFFFFF
 4057  !
 4058  !  EACH VARIABLE ENTRY CONSISTS OF THE VARIABLE WORD FOLLOWED BY
 4059  ! THE VARIABLE NAME AS A STRING. THE WORD CONSISTS OF
 4060  ! BITS 2**31 TO 2**20 TYPE INFORMATION (MAY BE LANGUAGE DEPENDENT
 4061  ! BIT  2**19  =0 UNDER LNB =1 IN GLA
 4062  ! BITS 2**18 TO 2**0 DISPLACEMENT FROM LNB(GLA) IN BYTES
 4063  !
 4064  !
 4065  ! THE ENVIRONMENT IS A POINTER (RELATIVE TO SST) OF THE NEXT OUTERMOST
 4066  ! BLOCK OR A POINTER TO GLOBAL OWNS, EXTERNAL OR COMMON AREAS
 4067  ! A ZERO MEANS NO ENCLOSING BLOCK. WORD1=WORD3=0 IS AN
 4068  ! IMP MAIN PROGRAM AND WILL TERMINATE THE DIAGNOSTICS.
 4069  !
 4070           %ROUTINE DTABLE(%INTEGER LEVEL)
 4071  !***********************************************************************
 4072  !*      THIS ROUTINE LOOKS AT THE DECLARATIONS FOR THE CURRENT LEVEL & *
 4073  !*      SETS UP THE SEGMENT OF SHARABLE SYMBOL TABLES TO DESCRIBE THEM.*
 4074  !*      FOR MAIN PROGRAMS OR EXTERNAL ROUTINES THE 'GLOBAL' VARIABLES  *
 4075  !*      (IF ANY) ARE ALSO INCLUDED.                                    *
 4076  !***********************************************************************
 4077  %STRING(31) RT NAME
 4078  %STRING(11) LOCAL NAME
 4079  %RECORD(LISTF)%NAME LCELL{(LISTF)
 4080  %CONSTINTEGER LARRROUT=16_F300
 4081  %INTEGER DPTR,LNUM,ML,KK,JJ,Q,DEND,BIT,S1,S2,S3,S4,LANGD,II
 4082  %INTEGERARRAY DD(0:500);       ! BUFFER FOR SEGMENT OF SST
 4083  !
 4084  ! FILL ALL OUTSTANDING REFERENCES TO THIS DIAGS BLOCK
 4085  !
 4086           BIT=1<<LEVEL
 4087           LANGD=KKK>>14<<30!LEVEL<<18;  ! GET LITL FROM PTYPE
 4088           %WHILE RAL(LEVEL)#0 %CYCLE
 4089              POP(RAL(LEVEL),Q,JJ,KK)
 4090              PLUG(Q,JJ,KK!SSTL,4)
 4091           %REPEAT
 4092           PUSH(RAL(LEVEL-1),4,SSTL+4,LANGD) %IF PARMTRACE#0
 4093           DD(0)=L(LEVEL)<<16!(DIAGINF(LEVEL))
 4094           DD(1)=LANGD
 4095           DD(2)=DISPLAY(RLEVEL)<<16!FLAG(LEVEL)&16_3FFF
 4096           ML=M(LEVEL);                   ! ROUTINE NAME(=0 FOR %BEGIN)
 4097           LNUM=BYTEINTEGER(DICTBASE+ML); ! LENGTH OF THE NAME
 4098           DPTR=4; DEND=0
 4099           %IF LNUM=0 %THEN DD(3)=0 %ELSE %START
 4100              Q=DICTBASE+ML
 4101              RT NAME<-STRING(Q);         ! FOR RTS MOVE IN 1ST 32 CHARS
 4102              LNUM=BYTE INTEGER(ADDR(RT NAME))
 4103              STRING(ADDR(DD(3)))=RTNAME; ! AND UPDATE POINTER PAST
 4104              DPTR=DPTR+LNUM>>2;          ! ACTUAL NO OF CHARS
 4105           %FINISH
 4106           DD(DPTR)=ONWORD(LEVEL);        ! ON CONDITION WORD
 4107           DPTR=DPTR+1
 4108           JJ=NAMES(LEVEL)
 4109           %WHILE 0<=JJ<16_3FFF %CYCLE
 4110              LCELL==ASLIST(TAGS(JJ))
 4111                                           ! OBTAIN NEXT NAME FORM DECLNS
 4112              %IF LCELL_S1&16_F000=0 %THEN WARN(2,JJ)
 4113  !
 4114  ! GET ONLY THE MINIMUM OF DETALS NECESSARY
 4115  !
 4116              S1=LCELL_S1; S2=LCELL_S2
 4117              S3=LCELL_S3; S4=LCELL_LINK
 4118              LCELL_LINK=ASL; ASL=TAGS(JJ)
 4119              TAGS(JJ)=S4&16_3FFFF
 4120              PTYPE=S1>>16; TYPE=PTYPE&15
 4121              I=S1>>4&15
 4122              J=S1&15
 4123              K=S3>>16
 4124  !
 4125  ! ALLOW OWNS (LITL=0) AND EXTERNALS (=2) NOT CONSTS(=1) OR EXTRINSIC(=3)
 4126  !
 4127              %IF PARMDIAG#0 %AND PTYPE&16_7300<=16_200 %AND DPTR<497 %AND (TYPE=1 %OR TYPE=2 %OR TYPE=5) %START
 4128                 Q=DICTBASE+WORD(JJ);     ! ADDRESS OF NAME
 4129                 %IF I=0 %THEN II=1 %ELSE II=0;   ! GLA OR LNB BIT
 4130                 DD(DPTR)=PTYPE<<20!II<<18!K
 4131                 LOCAL NAME<-STRING(Q);   ! TEXT OF NAME FROM DICTIONARY
 4132                 LNUM=BYTE INTEGER(ADDR(LOCAL NAME))
 4133                 STRING(ADDR(DD(DPTR))+4)=LOCAL NAME;! MOVE IN NAME 
 4134                 DPTR=DPTR+(LNUM+8)>>2
 4135              %FINISH
 4136              %IF J=15 %AND S2#0 %THEN FAULT2(28,0,JJ)
 4137                                          ! SPEC&CALLED BUT NO BODY GIVEN
 4138              %IF PTYPE&16_3000#0 %OR TYPE=4 %OR TYPE=6 %THEN CLEAR LIST(K) %ELSE %START
 4139                 %IF I#0 %AND K>511 %AND PTYPE&LARRROUT=0 %AND TYPE#7 %THEN WARN(5,JJ)
 4140              %FINISH
 4141              JJ=S4>>18
 4142           %REPEAT
 4143           DD(DPTR)=-1;                   ! 'END OF SEGMENT' MARK
 4144           DPTR=DPTR<<2+4
 4145           %IF PARMTRACE=1 %THEN %START
 4146              LPUT(4,DPTR,SSTL,ADDR(DD(0)));! ADD TO SHARABLE SYM TABS
 4147              SSTL=SSTL+DPTR
 4148           %FINISH
 4149           %END;                          ! OF ROUTINE DTABLE
 4150           %END
 4151  %ROUTINE MAKE DECS(%INTEGER Q)
 4152  !***********************************************************************
 4153  !*    Q IS TO AR ENTRY FOR HEAD OF LINKED DECLARATIONS                 *
 4154  !***********************************************************************
 4155  %INTEGER QQ,HEAD,PRIO,COUNT,SL
 4156  %INTEGERNAME THEAD
 4157  %RECORD(LISTF)%NAME CELL{(LISTF)
 4158        SL=LINE; QQ=FROM AR4(Q)
 4159        HEAD=0; COUNT=0
 4160        %WHILE QQ#0 %CYCLE
 4161           COUNT=COUNT+1
 4162           ABORT %UNLESS A(QQ+5)=8;       ! LINE IS A DECLARATION
 4163           P=QQ+10; CLT
 4164           %IF PREC=3 %OR A(P)#1 %OR A(P+1)# 3 %START
 4165                 INSERT AT END(HEAD,16_FFFF,QQ,0) %IF A(P)=1
 4166              %FINISH %ELSE %START
 4167              PRIO=PREC<<4!TYPE
 4168              THEAD==HEAD
 4169              %CYCLE
 4170                 CELL==ASLIST(THEAD)
 4171                 %IF THEAD=0 %OR PRIO<CELL_S1 %THEN PUSH(THEAD,PRIO,QQ,0) %AND %EXIT
 4172                 THEAD==CELL_LINK
 4173              %REPEAT
 4174           %FINISH
 4175           QQ=FROM AR4(QQ+6)
 4176        %REPEAT
 4177  !
 4178  !     NOW MAKE THE ORDEREED DECLARATIONS
 4179  ! FIRST GRAB TWO TEMPORARIES IF SPACE IS LIKELY TO BE TIGHT
 4180  !
 4181        %IF COUNT>=7 %START
 4182           GET WSP(QQ,2);                 ! A DIUBLE WORD
 4183           %IF AVL WSP(1,LEVEL)=0 %THEN GET WSP(QQ,1)
 4184        %FINISH
 4185        %WHILE HEAD#0 %CYCLE
 4186           POP(HEAD,PRIO,QQ,COUNT)
 4187           LINE=FROM AR2(QQ+3)
 4188           P=QQ+10; CLT
 4189           ROUT=0; LITL=0
 4190           CQN(P+1); P=P+2
 4191           DECLARE SCALARS(1,0)
 4192        %REPEAT
 4193        LINE=SL
 4194  %END
 4195  %ROUTINE DECLARE SCALARS(%INTEGER PERMIT,XTRA)
 4196  !***********************************************************************
 4197  !*       THIS ROUTINE DECLARES A LIST OF SCALARS FROM INFORMATION      *
 4198  !*       IN THE GLOBAL VARIABLES ROUT,NAM,ARR,PREC,TYPE & ACC.IT WORKS *
 4199  !*       OUT ROUNDING FACTORS FOR ITSELF.                              *
 4200  !*       P POINTS TO THE NAMELIST ON ENTRY AND IS UPDATED.             *
 4201  !***********************************************************************
 4202  %INTEGER INC,Q,SCHAIN,DMADE,NPARMS,D0,SCAL NAME,TYPEP
 4203        PACK(PTYPE); J=0
 4204        INC=ACC; DMADE=0; SNDISP=0
 4205        %IF PTYPE=16_33 %THEN INC=(INC+3)&(-4)
 4206        %IF NAM#0 %AND ROUT=0 %AND ARR=0 %THEN INC=8
 4207        %IF NAM>0 %AND ARR>0 %THEN INC=16
 4208        %IF PTYPE=16_35 %AND ACC=0 %THEN FAULT(70,0)
 4209        %IF PERMIT#0 %AND (INC=8 %OR INC=16) %THEN ODD ALIGN
 4210        %IF PTYPE=16_33 %OR (PTYPE=16_35 %AND PERMIT#0)%START
 4211           D0=16_18000000+ACC
 4212           STORE CONST(Q,4,ADDR(D0))
 4213           PF1(LDTB,0,PC,Q)
 4214           GRUSE(DR)=0
 4215        %FINISH
 4216        %IF PTYPE=16_35 %START
 4217           INC=8
 4218           %IF PERMIT#0 %START
 4219              PF1(STSF,0,TOS,0)
 4220              PF1(LDA,0,TOS,0)
 4221           %FINISH
 4222        %FINISH
 4223        N=(N+3)&(-4)
 4224        %IF PTYPE=16_33 %THEN %START
 4225           PSF1(LDA,1,PTR OFFSET(RBASE))
 4226           PSF1(INCA,0,N+8)
 4227        %FINISH
 4228        {%UNTIL A(P-1)=2} %CYCLE;      ! DOWN THE NAMELIST
 4229           DMADE=DMADE+1
 4230           SCAL NAME=FROM AR2(P)
 4231           %IF PTYPE=16_31 %AND PERMIT=0 %THEN N=N+3;! BYTE PARAMS
 4232           %IF PTYPE=16_41 %AND PERMIT=0 %THEN N=N+2
 4233           SCHAIN=N
 4234           KFORM=XTRA
 4235           %IF ROUT=1 %THEN %START
 4236              TYPEP=PTYPE;                ! CHANGED BY CFPLIST!
 4237              Q=P
 4238              P=P+3 %UNTIL A(P-1)=2;      ! TO FPP
 4239              CFPLIST(SCHAIN,NPARMS)
 4240              P=Q
 4241              J=13
 4242              KFORM=NPARMS;               ! NO OF PARAMS OF FORMAL
 4243              ACC=N;                      ! DISPLACEMENT TO MIDCELL
 4244              PTYPE=TYPEP; UNPACK
 4245           %FINISH
 4246           P=P+3
 4247           %IF PTYPE=16_33 %THEN %START
 4248              PSF1(STD,1,N)
 4249              N=N+8; SCHAIN=N
 4250              %IF A(P-1)=1 %THEN PSF1(INCA,0,INC+8)
 4251           %FINISH
 4252           %IF PTYPE=16_35 %AND PERMIT#0 %START
 4253              PSF1(STD,1,N)
 4254              %IF A(P-1)=1 %THEN PSF1(INCA,0,(ACC+3)&(-4)) %ELSE %START
 4255                 Q=((ACC+3)>>2)*DMADE
 4256                 PSF1(ASF+12*PARMCHK,0,Q)
 4257                 %IF PARMCHK#0 %THEN PPJ(0,4)
 4258              %FINISH
 4259           %FINISH
 4260           STORE TAG(SCAL NAME,SCHAIN)
 4261           N=N+INC
 4262        %REPEAT %UNTIL A(P-1)=2
 4263        N=(N+3)&(-4) %IF PERMIT#0;! NO ROUNDING AMONG PARAMS
 4264     %END
 4265  %INTEGERFN DOPE VECTOR(%INTEGER TYPEP,ELSIZE,MODE,IDEN,%INTEGERNAME ASIZE,LB)
 4266  !***********************************************************************
 4267  !*        CONSTRUCTS THE DOPE-VECTOR FOR A CONSTANT ARRAY IN THE       *
 4268  !*       SHAREABLE SYMBOL TABLES AND RETURNS ITS DISPLACEMENT AS RESULT*
 4269  !*       EVENTUALLY ALL NON DYNAMIC DOPE VECTORS SHOULD GO VIA HERE    *
 4270  !*       P IS TO ALT (MUST BE 1!) OF P<BPAIR>                          *
 4271  !*       DOPE VECTOR CONSISTS OF :-                                    *
 4272  !*       DESRIPTOR (SCALED WORD) POINTING AT FIRST TRIPLE BND=3*ND     *
 4273  !*       SIZE (IN BYTES OF ENTIRE ARRAY) FOR STACK ADJUSTMENT          *
 4274  !*       AND ND TRIPLES EACH CONSISTING OF:-                           *
 4275  !*       LBI - THE LOWER BOUND OF THE ITH DIMENSION                    *
 4276  !*       MI - THE STRIDE FOR THE ITH DIMENSION                         *
 4277  !*       CBI THE UPPER CHECK =(UBI-LBI+1)*MI                           *
 4278  !*       WHERE M1=1(SCALED ARRAYS) OR THE ELEMENT SIZE AND             *
 4279  !*       MI = M(I-1)*RANGE(I-1)                                        *
 4280  !*       MODE=0 DV MUST BE CONST, MODE#0 CAN BE DYNAMIC                *
 4281  !*       P TO ALT (ALWAYS=1) OF P(BPAIR)                               *
 4282  !***********************************************************************
 4283  %INTEGER I, JJ, K, ND, D, UNSCAL, M0, HEAD, NOPS, TYPEPP, PIN, PTR
 4284  %RECORD(LISTF)%NAME LCELL{(LISTF)
 4285  %INTEGERARRAY LBH,LBB,UBH,UBB(0:12)
 4286  %INTEGERARRAY DV(0:39);                 ! ENOUGH FOR 12 DIMENSIONS
 4287           ND=0; NOPS=0; TYPEPP=0; PIN=P
 4288           %IF TYPEP>2 %OR (TYPEP=1 %AND PREC=4) %THEN UNSCAL=1 %AND M0=ELSIZE %ELSE UNSCAL=0 %AND M0=1
 4289           {%UNTIL A(P)=2} %CYCLE
 4290              ND=ND+1; P=P+4
 4291              LBH(ND)=0; LBB(ND)=0
 4292              UBB(ND)=0; UBH(ND)=0
 4293              TORP(LBH(ND),LBB(ND),NOPS)
 4294              P=P+3
 4295              TYPEPP=TYPEPP!TYPE
 4296              TORP(UBH(ND),UBB(ND),NOPS)
 4297              TYPEPP=TYPEPP!TYPE
 4298           %REPEAT %UNTIL A(P)=2
 4299           P=P+1
 4300           ->NONCONST %UNLESS TYPEPP=1 %AND NOPS&16_40040000=0
 4301  !
 4302  ! NOW ONE CAN WORK OUT AND FILL IN THE TRIPLES
 4303  !
 4304           PTR=1
 4305           %CYCLE D=ND,-1,1
 4306              K=3*D
 4307              EXPOP(LBH(PTR),ACCR,NOPS,16_251)
 4308              EXPOPND_D=0 %AND FAULT(41,0) %UNLESS EXPOPND_FLAG<=1 %AND EXPOPND_PTYPE=16_51
 4309              DV(K)=EXPOPND_D
 4310              DV(K+1)=M0
 4311              EXPOP(UBH(PTR),ACCR,NOPS,16_251)
 4312              EXPOPND_D=10 %AND FAULT(41,0) %UNLESS EXPOPND_FLAG<=1 %AND EXPOPND_PTYPE=16_51
 4313              JJ=EXPOPND_D
 4314              M0=M0*(JJ-DV(K)+1)
 4315              FAULT2(38,1-M0,IDEN) %UNLESS JJ>=DV(K)
 4316              DV(K+2)=M0
 4317              PTR=PTR+1
 4318           %REPEAT
 4319  !
 4320           %IF UNSCAL=0 %THEN M0=M0*ELSIZE
 4321           %IF ND=1 %THEN LB=DV(3)
 4322           ASIZE=M0
 4323           DV(2)=ASIZE
 4324           DV(1)=12
 4325           DV(0)=5<<27!3*ND;           ! DESPTR FOR DV
 4326           K=3*ND+2
 4327           J=ND;                       ! DIMENSIONALITY FOR DECLN
 4328           HEAD=DVHEADS(ND)
 4329           %WHILE HEAD#0 %CYCLE
 4330              LCELL==ASLIST(HEAD)
 4331              %IF LCELL_S2=ASIZE %AND LCELL_S3=DV(5) %START
 4332                 %CYCLE D=0,1,K
 4333                    ->ON %UNLESS DV(D)=CTABLE_val(D+LCELL_S1)
 4334                 %REPEAT
 4335                 %RESULT=16_80000000!4*LCELL_S1
 4336              %FINISH
 4337  ON:
 4338              HEAD=LCELL_LINK
 4339           %REPEAT
 4340           %IF CONST PTR&1#0 %THEN CONST HOLE=CONST PTR %AND CONST PTR=CONST PTR+1
 4341           I=4*CONST PTR!16_80000000
 4342           PUSH(DVHEADS(ND),CONSTPTR,ASIZE,DV(5))
 4343           %CYCLE D=0,1,K
 4344              CTABLE_val(CONST PTR)=DV(D)
 4345              CONST PTR=CONST PTR+1
 4346           %REPEAT
 4347           %IF CONST PTR>CONST LIMIT %THEN FAULT(107,0)
 4348  WAYOUT:
 4349           %CYCLE D=ND,-1,1
 4350              ASLIST(LBB(D))_LINK=ASL
 4351              ASL=LBH(D)
 4352              ASLIST(UBB(D))_LINK=ASL
 4353              ASL=UBH(D)
 4354           %REPEAT
 4355           %RESULT =I
 4356  NONCONST:                               ! NOT A CONST DV
 4357           J=ND; I=-1
 4358           LB=0; ASIZE=ELSIZE
 4359           %IF MODE=0 %THEN FAULT(41,0) %ELSE P=PIN
 4360           ->WAYOUT
 4361  %END
 4362  
 4363  %ROUTINE DECLARE ARRAYS(%INTEGER FORMAT, FINF)
 4364  !***********************************************************************
 4365  !*       FORMAT=1 FOR 'ARRAYFORMAT'   =0 OTHERWISE                     *
 4366  !*       FINF>0 FOR RECORD FORMAT INFORMATION =0 OTHERWISE             *
 4367  !*       P IS AT P<ADECLN>   IN                                        *
 4368  !*                                                                     *
 4369  !*       P<ADECLN>=<NAMELIST> <BPAIR> <RESTOFDECLN>                    *
 4370  !*       P<BPAIR> = '('<EXPR>':'<EXRR><RESTOFBP>*')'                   *
 4371  !*                                                                     *
 4372  !*       ARRAYS WITH CONSTANT BOUNDS HAVE THEIR D-V IN THE SST         *
 4373  !*       ALL OTHER ARRAYS HAVE A DOPE VECTOR AMONG THE LOCALS AND GET  *
 4374  !*       THEIR SPACE OFF THE STACK AT RUN TIME                         *
 4375  !*       BOTH SORTS OF ARRAYS HAVE A FOUR WORD HEAD AND D-V TO EMAS    *
 4376  !*       SYSTEM STANDARDS                                              *
 4377  !***********************************************************************
 4378  %ROUTINESPEC CLAIM AS
 4379  %INTEGER DVDISP, PP, DVF, ELSIZE, TOTSIZE, D0, D1, PTYPEP,  {%C
 4380+          ARRP, NN, ND, II, JJ, QQ, R, CDV, UNSCAL, DESC, SC,  {%C
 4381+          LWB, PTYPEPP, JJJ, JJJJ, ADJ
 4382        %IF STACK#0 %AND FLAG(LEVEL)=0=NMDECS(LEVEL)>>14 %START
 4383           PSF1(STSF,1,N)
 4384           NMDECS(LEVEL)=NMDECS(LEVEL)!(N<<14)
 4385           N=N+4
 4386        %FINISH
 4387        %IF STACK=0 %THEN SAVE AUX STACK
 4388        ARRP=2*FORMAT+1;  ARR=ARRP;  PACK(PTYPEP)
 4389        ELSIZE=ACC
 4390        %IF TYPE>2 %OR (TYPE=1 %AND PREC=4) %THEN UNSCAL=1 %AND SC=3 %ELSE UNSCAL=0 %AND SC=PREC
 4391        DESC=SC<<27!UNSCAL<<25!(1-PARMARR)<<24;! ARRAY DESCRIPTOR SKELETON
 4392           %IF PREC=4 %THEN DESC=16_58000002
 4393  START:NN=1;  P=P+1;                     ! NO OF NAMES IN NAMELIST
 4394        PP=P;  CDV=0;  PTYPEPP=PTYPEP
 4395        P=P+3 %AND NN=NN+1 %WHILE A(P+2)=1
 4396        P=P+3
 4397        DVDISP=DOPE VECTOR(TYPE,ELSIZE,1,FROMAR2(PP),TOTSIZE,LWB)
 4398        ND=J
 4399        ->CONSTDV %UNLESS DVDISP=-1
 4400  ! NORMAL CASE - PLANT CODE TO SET UP DOPE-VECTOR AT RUN TIME
 4401  
 4402        DVF=0;  TOTSIZE=16_FFFF
 4403         DVDISP=N;                        ! DVDISP IS D-V POSITION
 4404        N=N+12*ND+12;                     ! CLAIM SPACE FOR THE D-V
 4405        FAULT(37,0) %IF ND>12;            ! TOO MANY DIMENSIONS
 4406        D0=5<<27!3*ND;  D1=12;            ! DESCPTR FOR DV
 4407        STORE CONST(JJ,8,ADDR(D0))
 4408        PF1(LD,0,PC,JJ)
 4409        PSF1(STD,1,DVDISP)
 4410        GRUSE(DR)=0
 4411  
 4412        %IF UNSCAL=0 %THEN JJ=1 %ELSE JJ=ELSIZE
 4413        PSF1(LSS,0,JJ);                   ! M1 THE FIRST MULTIPLIER
 4414        GRUSE(ACCR)=0
 4415        %CYCLE II=ND,-1,1
 4416           P=P+1
 4417           QQ=DVDISP+12*II;               ! TRIPLE FOR IITH DIMENSION
 4418           PSF1(ST,1,QQ+4);               ! STORE MULTIPLIER
 4419           CSEXP(ACCR,16_51);             ! LOWER BOUND
 4420           %IF ND=1 %AND PTYPEP&7<=3 %AND FORMAT=0 %AND GRUSE(ACCR)=5 %AND GRINF1(ACCR)=0 %THEN PTYPEPP=PTYPEPP+256
 4421           PSF1(ST,1,QQ);                 ! STORED IN DV
 4422           CSEXP(ACCR,16_51);             ! UPPER BOUND
 4423           PSF1(ISB,1,QQ)
 4424           GRUSE(ACCR)=0
 4425           %IF COMPILER=0 %OR PARMARR#0 %START
 4426              PF3(JAF,6,0,3);             ! JUMP UNLESS NEGATIVE
 4427              PSF1(LSS,0,-1);             ! SET UP -1 (ENSURES 0 ELEMENTS
 4428           %FINISH
 4429           PSF1(IAD,0,1);                 ! CONVERTED TO RANGE
 4430           PSF1(IMY,1,QQ+4);              ! RANGE*MULTIPLIER
 4431           PSF1(ST,1,QQ+8);               ! AND STORED IN DV
 4432        %REPEAT
 4433        P=P+1
 4434        %IF UNSCAL=0 %AND ELSIZE#1 %THEN PSF1(IMY,0,ELSIZE)
 4435        PSF1(ST,1,DVDISP+8)
 4436        SNDISP=0;                         ! DV NOT AVAILABLE AT COMPILETIME
 4437        ->DECL
 4438  CONSTDV:                                ! ONE DIMENSION - CONSTANT BOUNDS
 4439        DVF=1;  CDV=1
 4440        %IF ND=1 %AND LWB=0 %AND PTYPEP&15<=3 %AND FORMAT=0 %THEN PTYPEPP=PTYPEP+256
 4441                                          ! SET ARR=2 IF LWB=ZERO
 4442        SNDISP=(DVDISP&16_FFFFFF)>>2
 4443  DECL:                                   ! MAKE DECLN - BOTH WAYS
 4444        J=ND
 4445        ODD ALIGN
 4446        PTYPE=PTYPEPP;  UNPACK
 4447        %IF DVF#0 %THEN %START;           ! ARRAY IS STRING OF LOCALS
 4448           R=TOTSIZE
 4449           %IF UNSCAL=0 %THEN R=R//ELSIZE
 4450           D0=DESC
 4451           D0=D0!R %UNLESS PREC=4
 4452           STORE CONST(D1,4,ADDR(D0))
 4453           PF1(LB,0,PC,D1)
 4454        %FINISH %ELSE %START
 4455           STORE CONST(D1,4,ADDR(DESC))
 4456           PF1(LB,0,PC,D1)
 4457           PSF1(ADB,1,DVDISP+20) %UNLESS PREC=4
 4458        %FINISH
 4459        %IF DVF#0 %THEN QQ=PC %ELSE QQ=LNB
 4460        PSORLF1(LDRL,0,QQ,DVDISP)
 4461        GRUSE(BREG)=0; GRUSE(DR)=0
 4462        %CYCLE JJJ=0,1,NN-1;              ! DOWN NAMELIST
 4463           PSF1(STB,1,N+16*JJJ);          ! ARRAY BOUND
 4464           PSF1(STD,1,N+8+16*JJJ);        ! DV POINTER
 4465        %REPEAT
 4466        %IF PARMARR=0 %AND PARMCHK=0 %AND ND=1 %AND TYPE<=3 %AND PTYPEPP&16_F00#16_200 %THEN ADJ=1 %ELSE ADJ=0
 4467        %CYCLE JJJ=0,1,NN-1;              ! DOWN NAMELIST
 4468           %IF ADJ#0 %START;              ! ADJUST DESC
 4469              %IF STACK#0 %START;         ! ARRAY ON AUTOMATIC STACK
 4470                 PF1(STSF,0,BREG,0);      ! CURRENT SF TO B
 4471                 %IF DVF#0 %THEN PSF1(SBB,0,LWB*ELSIZE) %ELSE %START
 4472                    %IF ELSIZE=1 %THEN PSF1(SBB,1,DVDISP+12) %ELSESTART
 4473                       PSF1(SLB,1,DVDISP+12)
 4474                       PSF1(MYB,0,ELSIZE)
 4475                       PF1(SLB,0,TOS,0)
 4476                       PF1(SBB,0,TOS,0)
 4477                    %FINISH
 4478                 %FINISH
 4479                 PSF1(STB,1,N+4)
 4480                 GRUSE(BREG)=0
 4481              %FINISH %ELSE %START;      ! ARRAY ON AUX STACK
 4482                 %IF DVF#0 %START;        ! CONST DOPE VECTOR
 4483                    %UNLESS GRUSE(ACCR)=11 %%START
 4484                       PSF1(LSS,2,AUXSBASE(LEVEL))
 4485                       GRUSE(ACCR)=11; GRINF1(ACCR)=0
 4486                    %FINISH
 4487                    JJJJ=LWB*ELSIZE-GRINF1(ACCR)
 4488                    PSF1(ISB,0,JJJJ) %UNLESS JJJJ=0
 4489                    GRINF1(ACCR)=LWB*ELSIZE
 4490                 %FINISH %ELSE %START;    ! DYNAMIC ARRAYS
 4491                    %IF GRUSE(ACCR)=11 %AND GRINF1(ACCR)=0 %AND ELSIZE=1 %THEN PSF1(ISB,1,DVDISP+12) %ELSESTART
 4492                       PSF1(LSS,1,DVDISP+12)
 4493                       PSF1(IMY,0,ELSIZE) %UNLESS ELSIZE=1
 4494                       PSF1(IRSB,2,AUXSBASE(LEVEL))
 4495                    %FINISH
 4496                    GRUSE(ACCR)=0
 4497                 %FINISH
 4498                 PSF1(ST,1,N+4)
 4499              %FINISH
 4500           %FINISH %ELSE %START;          ! NO ADJUSTMENT OF DESCRPT
 4501              %IF STACK#0 %THEN PSF1(STSF,1,N+4) %ELSE %START
 4502                 PSF1(LSS,2,AUXSBASE(LEVEL)) %UNLESS GRUSE(ACCR)=11 %AND GRINF1(ACCR)=0
 4503                 PSF1(ST,1,N+4)
 4504                 GRUSE(ACCR)=11; GRINF1(ACCR)=0
 4505              %FINISH
 4506           %FINISH
 4507  
 4508           ACC=ELSIZE;                    ! RESET ACC AFTER DV CMPLD
 4509           KFORM=FINF;                    ! FORMAT INFORMATION
 4510           K=FROM AR2(PP+3*JJJ)
 4511           STORE TAG(K,N)
 4512           CLAIM AS %IF FORMAT = 0
 4513           N=N+16
 4514        %REPEAT
 4515        P=P+1;                            ! PAST REST OF ARRAYLIST
 4516        %IF A(P-1)=1 %THEN ->START
 4517        %RETURN
 4518  %ROUTINE CLAIM AS
 4519  !***********************************************************************
 4520  !*       CLAIM THE SPACE FOR AN ARRAY FROM STACK OR AUX STACK          *
 4521  !***********************************************************************
 4522  %INTEGER T, B, D,ADJMENT
 4523        %IF STACK=1 %THEN %START;         ! FROM AUTOMATIC STACK
 4524           %IF CDV=1 %THEN %START;        ! CONSTANT BOUNDS
 4525              T=(TOTSIZE+3)//4
 4526              PSF1(ASF+12*PARMCHK,0,T);   ! ASF OR LB
 4527              PPJ(0,4) %IF PARMCHK#0
 4528           %FINISH %ELSE %START;          ! DYNAMIC BOUNDS
 4529              %IF PARMCHK=0 %AND PTYPEP&7<=2 %AND (ELSIZE=4 %OR ELSIZE=8) %START
 4530                 PSF1(ASF,1,DVDISP+20);   ! SIZE IN ELEMENTS WORD
 4531                 PSF1(ASF,1,DVDISP+20) %IF ELSIZE=8
 4532              %FINISH %ELSE %START
 4533                 PSF1(LSS,1,DVDISP+8);    ! ARRAY SIZE BYTES
 4534                 PSF1(IAD,0,3) %IF ELSIZE&3#0
 4535                 PSF1(USH,0,-2);          ! ARRAY SIZE WORDS
 4536                 PF1(ST,0,BREG,0)
 4537                 FORGET(BREG)
 4538                 %IF PARMCHK#0 %THEN PPJ(0,4) %ELSE PF1(ASF,0,BREG,0)
 4539              %FINISH
 4540           %FINISH
 4541           CHECK STOF
 4542        %FINISH %ELSE %START
 4543           %UNLESS GRUSE(ACCR)=11 %AND (GRINF1(ACCR)=0 %OR CDV=1) %START
 4544              PSF1(LSS,2,AUXSBASE(LEVEL))
 4545              GRUSE(ACCR)=11; GRINF1(ACCR)=0
 4546           %FINISH
 4547           %IF CDV=1 %THEN %START
 4548              ADJMENT=(TOTSIZE+7)&(-8)+GRINF1(ACCR)
 4549              %IF ADJMENT<16_1FFFF %THEN B=0 %AND D=ADJMENT %ELSE %START
 4550                 STORE CONST(D,4,ADDR(ADJMENT))
 4551                 B=PC
 4552              %FINISH
 4553              %IF ADJ=1 %AND JJJ#NN-1 %AND PARMOPT=0 %THEN GRINF1(ACCR)=ADJMENT %ELSE %START
 4554                 GRINF1(ACCR)=0
 4555                 PSORLF1(IAD,0,B,D) %UNLESS B=D=0
 4556              %FINISH
 4557           %FINISH %ELSE %START
 4558              B=LNB; D=DVDISP+8
 4559              PSF1(IAD,1,D)
 4560              %UNLESS ELSIZE&7=0 %START
 4561                 PSF1(IAD,0,7)
 4562                 PSF1(AND,0,-8)
 4563              %FINISH
 4564              GRINF1(ACCR)=0
 4565           %FINISH
 4566           PSF1(ST,2,AUXSBASE(LEVEL)) %IF JJJ=NN-1 %OR (ADJ=1 %AND CDV=0)
 4567           %IF PARMOPT#0 %THEN %START
 4568              PSF1(ICP,1,AUXSBASE(LEVEL)+16)
 4569              PPJ(2,8)
 4570           %FINISH
 4571           %IF PARMCHK#0 %START
 4572              PF1(LDTB,0,PC,PARAM DES(3))
 4573              PSORLF1(LDB,0,B,D)
 4574              PSF1(LDA,1,N+4)
 4575              PF2(MVL,1,1,0,0,UNASSPAT&255)
 4576              GRUSE(DR)=0
 4577           %FINISH
 4578        %FINISH
 4579  %END
 4580  %END
 4581  !         %ROUTINE TEST NST
 4582  !!***********************************************************************
 4583  !!*       SEE IF NAME 'K' HAS BEEN DECLARED BEFORE AT THIS LEVEL        *
 4584  !!***********************************************************************
 4585  !         FNAME=K
 4586  !         FAULT(7,FNAME) %IF FROM1(TAGS(FNAME))>>8&15=LEVEL
 4587  !         %END
 4588           %ROUTINE CLT
 4589  !***********************************************************************
 4590  !*       DEAL WITH PHRASE TYPE AND SET PREC,TYPE & ACC                 *
 4591  !*       ONLY PROBLEM IS STRING WHICH HAS OPTIONAL MAX LENGTH ALSO     *
 4592  !*       P ON PHRASE TYPE AT ENTRY - TO NEXT PHRASE AT EXIT.           *
 4593  !***********************************************************************
 4594  %CONSTBYTEINTEGERARRAY TYPEFLAG(1:10)= {%C
 4595+                                         16_51,16_52,0,16_31,16_35,
 4596+                                         16_41,0,16_62,16_61,16_72;
 4597  %INTEGER ALT
 4598           ALT=A(P)
 4599           TYPE=TYPEFLAG(ALT)
 4600           %IF TYPE=0 %THEN P=P+1 %AND TYPE=TYPEFLAG(A(P)+7)
 4601           PREC=TYPE>>4
 4602           TYPE=TYPE&7
 4603           PREC=6 %IF TYPE=2 %AND ALL LONG#0 %AND PREC<=5;! DEAL WITH '%REALSLONG'
 4604           ACC=BYTES(PREC)
 4605           %IF TYPE=5 %THEN %START;    ! P<TYPE>='%STRING'
 4606              %IF A(P+1)=1 %THEN %START;! MAX LENGTH GIVEN
 4607                 P=P+2
 4608                 ACC=A(P)+1
 4609              %FINISH %ELSE ACC=0 %AND P=P+1
 4610           %FINISH
 4611           P=P+1
 4612           %END
 4613           %ROUTINE CQN(%INTEGER P)
 4614  !***********************************************************************
 4615  !*       SET NAM,ARR & ACC FROM ALTERNATIVE OF PHRASE <QNAME'>         *
 4616  !*       P<QNAME'>='%ARRAYNAME','%NAME',<%NULL>                        *
 4617  !*       P POINTS TO THE ANALYSIS RECORD ENTRY AS IS NOT UPDATED       *
 4618  !***********************************************************************
 4619           %INTEGER I
 4620           I=A(P);NAM=0;ARR=0
 4621           %IF I=1 %THEN ARR=1 %AND ACC=16;! ARRAYNAMES
 4622           %IF I<=2 %THEN NAM=1;           ! ARRAYNAMES & NAMES
 4623           %IF I=2 %THEN ACC=8;            ! NAMES USE 8-BYTE DESCRIPTOR
 4624           %END
 4625  %ROUTINE CRSPEC (%INTEGER M)
 4626  !***********************************************************************
 4627  !*    MODE=0  FOR NORMAL ROUTINE SPEC                                  *
 4628  !*    MODE=1 FOR EXTERNAL(ETC) ROUTINE SPECS XREF NEEDED               *
 4629  !*    P ON ENTRY TO P(RT) IN (RT)(MARK)(%SPEC')(NAME)(FPP)             *
 4630  !***********************************************************************
 4631  %INTEGER KK,JJ,TYPEP,OPHEAD,NPARMS
 4632  %STRING(34) XNAME
 4633        LITL=EXTRN&3
 4634        %IF A(P)=1 %THEN %START;          ! P<RT>=%ROUTINE
 4635           TYPEP=LITL<<14!16_1000
 4636           P=P+2;                         ! IGNORING ALT OF P(SPEC')
 4637        %FINISH %ELSE %START;             ! P<RT>=<TYPE><FNORMAP>
 4638           ROUT=1; ARR=0; P=P+1
 4639           CLT; NAM=0
 4640           %IF A(P)=2 %THEN NAM=2;        ! 2 FOR MAP 0 FOR FN
 4641           PACK(TYPEP)
 4642           P=P+2;                         ! AGAIN IGNORING ALT OF P(SPEC')
 4643        %FINISH
 4644        P=P+4;                            ! PAST HOLE FOR DECLINKS 
 4645        KK=FROM AR2(P)
 4646        JJ=0
 4647        P=P+2
 4648        CFPLIST(OPHEAD,NPARMS)
 4649        %IF M=1 %THEN %START
 4650           XNAME<-STRING(DICTBASE+WORD(KK))
 4651           %IF EXTRN=1 %THEN XNAME<-"S#".XNAME
 4652           CXREF(XNAME,PARMDYNAMIC!(EXTRN//3),2,JJ); ! %STSTEM & %EXTERNAL =STATIC
 4653                                          ! %DYNAMIC = DYNAMIC
 4654        %FINISH
 4655        %IF M=0 %AND RLEVEL=0 %THEN CODE DES(JJ)
 4656        J=15-M; PTYPE=TYPEP
 4657        KFORM=NPARMS
 4658        SNDISP=JJ>>16
 4659        ACC=JJ&16_FFFF
 4660        STORE TAG(KK,OPHEAD)
 4661  %END
 4662  %ROUTINE CFPLIST(%INTEGERNAME OPHEAD,NPARMS)
 4663  !***********************************************************************
 4664  !*    COMPILE A FORMAL PARAMETER PART INTO A LIST OF PARAMETER TYPES   *
 4665  !*    P(FPP)='('{(HOLE)(FPDEL)(NAMELIST)(MARK)}*')',0.                 *
 4666  !*                                                                     *
 4667  !*    THE LIST OF PARAMETER LOOKS LIKE:-                               *
 4668  !*    S1 = PTYPE FOR PARAM<<16! DIMENSION    (DIMEN DEDUCED LATER)     *
 4669  !*    S2 = ACC <<16 ! SPARE                                            *
 4670  !*    S3 = 0                                 (RESERVED FOR FPP OF RTS) *
 4671  !*                                                                     *
 4672  !*    ON ENTRY P IS AT ALT OF FPP (WHICH MAY BE NULL)                  *
 4673  !***********************************************************************
 4674  %INTEGER OPBOT, PP
 4675        OPHEAD=0; OPBOT=0
 4676        NPARMS=0;                         ! ZERO PARAMETERS AS YET
 4677        %WHILE A(P)=1 %CYCLE;             ! WHILE SOME(MORE) FPS
 4678           PP=P+1+FROMAR2(P+1);           ! TO NEXT FPDEL
 4679           P=P+3;                         ! TO ALT OF FPDEL
 4680           CFPDEL;                        ! GET TYPE & ACC FOR NEXT GROUP
 4681           {%UNTIL A(P-1)=2} %CYCLE;        ! DOWN <NAMELIST> FOR EACH DEL
 4682              BINSERT(OPHEAD,OPBOT,PTYPE<<16,ACC<<16,0)
 4683              NPARMS=NPARMS+1
 4684              P=P+3
 4685           %REPEAT %UNTIL A(P-1)=2;       ! DOWN <NAMELIST> FOR EACH DEL
 4686           P=PP
 4687        %REPEAT
 4688        P=P+1
 4689  %END
 4690  %ROUTINE CFPDEL
 4691  !***********************************************************************
 4692  !*    SET UP PTYPE & ACC FOR A FORMAL PARAMETER DEFINITION             *
 4693  !*    P<FPDEL>=<TYPE><%QNAME'>,                                        *
 4694  !*             '%RECORD'<%ARRAY'>'%NAME'.                              *
 4695  !*             (RT)(%NAME')(NAMELIST)(FPP),                            *
 4696  !*             '%NAME'.                                                *
 4697  !***********************************************************************
 4698  %SWITCH FP(1:4)
 4699  %INTEGER FPALT
 4700        FPALT=A(P); P=P+1
 4701        KFORM=0; LITL=0
 4702        ->FP(FPALT)
 4703  FP(1):                                  ! (TYPE)(%QNAME')
 4704        ROUT=0; CLT
 4705        CQN(P)
 4706        FAULT(70,0) %IF TYPE=5 %AND ACC=0
 4707        P=P+1
 4708        ->PK
 4709  FP(2):                                  ! RECORD(%ARRAY')%NAME
 4710        ARR=2-A(P); ROUT=0
 4711        ACC=8+8*ARR; TYPE=3; PREC=3
 4712        NAM=1; P=P+1; ->PK
 4713  FP(3):                                  ! (RT)(%NAME')(NAMELIST)(FPP)
 4714        ROUT=1; NAM=1
 4715        ARR=0
 4716        %IF A(P)=1 %THEN %START;          ! RT=%ROUITNE
 4717           TYPE=0; PREC=0
 4718           P=P+2
 4719        %FINISH %ELSE %START
 4720           P=P+1; CLT;                    ! RT=(TYPE)(FM)
 4721           NAM=1
 4722           %IF A(P)=2 %THEN NAM=3;        ! 1 FOR FN 3 FOR MAP
 4723           P=P+2;                         ! PAST (%NAME') WHICH IS IGNORED
 4724        %FINISH
 4725        ACC=16
 4726        ->PK
 4727  FP(4):                                  ! %NAME
 4728        ACC=8; NAM=1
 4729        ROUT=0; TYPE=0
 4730        ARR=0; PREC=0
 4731  PK:   PACK(PTYPE)
 4732  %END
 4733  %ROUTINE DIAG POINTER(%INTEGER LEVEL)
 4734           %IF PARMTRACE#0 %THEN %START
 4735              PUSH(RAL(LEVEL),1,CA,LDB<<24!3<<23)
 4736              PF1(LDB,0,0,0)
 4737              GRUSE(DR)=0
 4738           %FINISH
 4739  %END
 4740  %ROUTINE RHEAD(%INTEGER KK)
 4741  !***********************************************************************
 4742  !*       COMPILES CODE FOR BLOCK AND ROUTINE ENTRY                     *
 4743  !*       KK IS THE RT/FN/MAP NAME (=-1 FOR %BEGIN BLOCKS)              *
 4744  !***********************************************************************
 4745  %INTEGER W1, W3, INSRN, AT
 4746           PUSH(LEVELINF, 0, NMAX<<16!N, 0)
 4747           LEVEL=LEVEL+1
 4748           NMDECS(LEVEL)=0; AUXSBASE(LEVEL)=0
 4749           NAMES(LEVEL)=-1
 4750           ONINF(LEVEL)=0; ONWORD(LEVEL)=0
 4751           %IF KK>=0 %THEN %START
 4752              RLEVEL=RLEVEL+1;  RBASE=RLEVEL
 4753           %FINISH
 4754           FAULT(34, 0) %IF LEVEL=MAX LEVELS
 4755           FAULT(105, 0) %IF LEVEL>MAX LEVELS
 4756           %IF KK>=0 %AND RLEVEL>1 %START;! ROUTINE ENTRY
 4757              COPY TAG(KK); JJ=K;         ! LIST OF JUMPS
 4758              J=MIDCELL
 4759              %IF J=0 %AND LEVEL>2 %START;! REPLACE 'NOT USED' BIT
 4760                 REPLACE1(TAGS(KK), FROM1(TAGS(KK))&16_FFFF3FFF)
 4761              %FINISH
 4762  !
 4763  ! NOW FILL ANY JUMPS TO THIS ROUTINE PLANTED SINCE
 4764  ! THE ROUTINESPEC WAS COMPILED. SEE ALSO 'RT JUMP'
 4765  !
 4766              %WHILE J#0 %CYCLE
 4767                 POP(J, INSRN, AT, W1)
 4768                 W3=CA-AT
 4769                 W3=W3//2 %IF INSRN>>25=CALL>>1
 4770                 INSRN=INSRN+W3
 4771                 PLUG(1, AT, INSRN,4)
 4772              %REPEAT
 4773              REPLACE2(TAGS(KK), CA);     ! NOTE ADDR FOR FUTURE CALLS
 4774           %FINISH
 4775           %IF KK>=0 %AND RLEVEL=1 %THEN DIAG POINTER(LEVEL) %AND PSF1(STD,1,12)
 4776           %IF KK<0 %THEN W3=0 %ELSE W3=WORD(KK)
 4777           L(LEVEL)=LINE;  M(LEVEL)=W3
 4778           FLAG(LEVEL)=PTYPE;             ! CURRENT BLOCK TYPE MARKER
 4779  %END
 4780  %ROUTINE RDISPLAY(%INTEGER KK)
 4781  !***********************************************************************
 4782  !*       SET UP OR COPY THE DISPLAY (A WORD ARRAY CONTAINING COPIES OF *
 4783  !*       LNB FOR THE GLOBAL LEVELS. THE HIGHEST LEVEL ENTRY IS TO THE  *
 4784  !*       GLA(PLT) FOR OWNS AND IS ALSO KEPT IN(LNB+4) IN CASE WE WISH  * 
 4785  !*       TO MOVE TO READ-ONLY PLTS. ON INTERNAL CALLS THE LNB FOR THE  *
 4786  !*       NEXT MOST GLOBAL LEVEL IS STACKED AS AN EXTRA PARAMETER       *
 4787  !***********************************************************************
 4788  %INTEGER W1,W2,STACK,OP,INC
 4789           %IF KK>=0 %OR LEVEL=2 %START;    ! DISPLAY NEEDED
 4790              STACK=0; DISPLAY(RLEVEL)=N
 4791              GRUSE(XNB)=0
 4792                 GRUSE(CTB)=0; GRUSE(BREG)=0
 4793              %IF LEVEL#2 %THEN %START
 4794  !               PF1(LXN,0,TOS,0)
 4795                 GRUSE(XNB)=4; GRINF1(XNB)=RLEVEL-1; GRAT(XNB)=CA
 4796                 PF1(LD,0,XNB,12);         ! COPY PLT DESCRIPTOR
 4797                 DIAG POINTER(LEVEL)
 4798                 PSF1(STD,1,12)
 4799                 W1=RLEVEL-1; W2=DISPLAY(W1)
 4800                 %IF W1=1 %THEN PF1(STXN,0,TOS,0) %AND N=N+4 %ELSE %START
 4801                    %WHILE W1>0 %CYCLE
 4802                       OP=LSS; INC=1
 4803                       %IF W1>=2 %THEN OP=LSD %AND INC=2
 4804                       %IF W1>=4 %THEN OP=LSQ %AND INC=4
 4805                       PF1(OP+STACK,0,XNB,W2)
 4806                       STACK=-32; N=N+4*INC
 4807                       W2=W2+4*INC; W1=W1-INC
 4808                    %REPEAT
 4809                 %FINISH
 4810              %FINISH
 4811              %IF STACK#0 %THEN PF1(ST,0,TOS,0);    ! ST TOS
 4812              PF1(STLN,0,TOS,0)
 4813              N=N+4
 4814           %FINISH
 4815  !
 4816  ! IF IN DIAGNOSTIC MODE PLANT CODE TO SAVE THE LINE & ROUTINE NO OF
 4817  ! THE CALLING ROUTINE AND SET UP THE NEW BLOCK/ROUTINE IDENT NO.
 4818  !
 4819           %IF PARMTRACE#0 %START
 4820              PF1(LSS,0,PC,4*CONST BTM!16_80000000) %IF PARMOPT#0;! M'IDIA'
 4821              %IF KK>=0 %OR LEVEL=2 %START
 4822                 %IF PARMOPT#0 %THEN %START
 4823                    PSF1(SLSS,0,LINE)
 4824                    N=N+4
 4825                 %FINISH %ELSE PSF1(LSS,0,LINE)
 4826                 PF1(ST,0,TOS,0)
 4827              %FINISH %ELSE %START
 4828                 %IF PARMOPT#0 %THEN %START
 4829                    PSF1(ST,1,N)
 4830                    N=N+4
 4831                 %FINISH
 4832                 PSF1(LSS,0,LINE)
 4833                 PSF1(ST,1,N)
 4834                 PSF1(LD,1,12);           ! UPDATE BND FIELD
 4835                 DIAG POINTER(LEVEL)
 4836                 PSF1(STD,1,12)
 4837              %FINISH
 4838              DIAGINF(LEVEL)=N
 4839              N=N+4
 4840              GRUSE(ACCR)=0;               ! NEEDED FOR %BEGIN BLOCKS
 4841           %FINISH
 4842           %IF PARMOPT#0 %AND KK>=0 %AND LEVEL=2 %START
 4843              PF1(STSF,0,BREG,0)
 4844              PF1(STLN,0,TOS,0)
 4845              PF1(SBB,0,TOS,0)
 4846              PSF1(CPB,0,N)
 4847              PPJ(7,13)
 4848           %FINISH
 4849  !
 4850  ! CLAIM (THE REST OF) THE STACK FRAME
 4851  !
 4852           %IF KK>=0 %OR LEVEL=2 %START
 4853              SET(RLEVEL)=N<<18!CA
 4854              NMAX=N
 4855              PF1(ASF+12*PARMCHK,0,0,0);   ! ASF OR LB
 4856              PPJ(0,4) %IF PARMCHK#0
 4857           %FINISH
 4858  !
 4859           %IF KK>=0 %AND PARMCHK#0 %START
 4860              CHECK STOF;                   ! CHECK FOR STACK O'FLOW
 4861           %FINISH
 4862           %IF PARMDBUG#0 %THEN SET LINE; ! TO CALL DBUG PACKAGE
 4863  %END
 4864  %ROUTINE CHECK STOF
 4865  !***********************************************************************
 4866  !*       CHECK THE STACK FOR OVERFLOW (LEAVING 4K MARGIN FOR MDIAG     *
 4867  !***********************************************************************
 4868           %IF PARMOPT#0 %THEN %START
 4869  !
 4870  !         STSF  TOS                    GET STACK POINTER
 4871  !         LSS   TOS
 4872  !         USH   +14
 4873  !         USH   -15                    LOSE SEGMENT NO
 4874  !         ICP   16_1F800               CHECK WITHIN SEG ADDRESS
 4875  !                                      SHIFTED DOWN 1 PLACE
 4876  !         JCC   2,EXCESS BLKS
 4877  !
 4878              PF1(STSF,0,TOS,0)
 4879              PF1(LSS,0,TOS,0)
 4880              PSF1(USH,0,14)
 4881              PSF1(USH,0,-15)
 4882              PF1(ICP,0,0,ST LIMIT>>1)
 4883              PPJ(2,8)
 4884            %FINISH
 4885  %END;                                   ! OF ROUTINE RHEAD
 4886  %ROUTINE CIOCP(%INTEGER N,REG)
 4887  !***********************************************************************
 4888  !*       COMPILES A CALL ON IOCP ENTRY POINT NO 'N'                    *
 4889  !*       2ND PARAMETER IS ALREAD IN THE ACC WHICH IS 32 BITS           *
 4890  !***********************************************************************
 4891  %INTEGER XYNB,OP1,OP2
 4892           %IF IOCPDISP=0 %THEN CXREF(IOCPEP,PARMDYNAMIC,2,IOCPDISP)
 4893           %IF REGISTER(BREG)#0 %THEN BOOT OUT(BREG)
 4894           %IF REG=ACCR %THEN OP1=LUH %AND OP2=ST %ELSE OP1=LDTB %AND OP2=STD
 4895           PSF1(OP1,0,N)
 4896           PSF1(PRCL,0,4)
 4897           PF1(OP2,0,TOS,0)
 4898           XYNB=SET XORYNB(-1,-1);        ! TO PLT
 4899           PSF1(RALN,0,7)
 4900           PF1(CALL,2,XYNB,IOCPDISP)
 4901           FORGET(-1)
 4902  %END
 4903  %ROUTINE CUI(%INTEGER CODE)
 4904  !***********************************************************************
 4905  !*       COMPILE AN UNCONDITIONAL INSTRN WHEREEVER IT OCCURS           *
 4906  !*       CODE=0 UNCONDITIOALLY,=1 AFTER %THEN, =2 AFTER %ELSE          *
 4907  !***********************************************************************
 4908  %INTEGER MARKER,J,LNAME,TYPEP,PRECP,GWRDD,LWB,XYNB,ARRP,ALT
 4909  %SWITCH SW(1:9)
 4910           REPORTUI=0
 4911           ALT=A(P)
 4912           ->SW(ALT)
 4913  SW(1):                                ! (NAME)(APP)(ASSMNT?)
 4914           P=P+1; MARKER=P+FROMAR2(P)
 4915           %IF A(MARKER)=1 %THEN %START
 4916              J=P+2; P=MARKER+2
 4917              ASSIGN(A(MARKER+1),J)
 4918           %FINISH %ELSE %START
 4919              P=P+2
 4920              CNAME(0,0)
 4921              P=P+1
 4922           %FINISH
 4923  AUI:     J=A(P); P=P+1
 4924           %IF J=1 %THEN CUI(CODE)
 4925           %RETURN
 4926  SW(2):                                  ! -> (NAME)(APP)
 4927           NMDECS(LEVEL)=NMDECS(LEVEL)!1
 4928           CURR INST=1 %IF CODE=0
 4929           LNAME=FROM AR2(P+1)
 4930           J=A(P+3); P=P+4
 4931           %IF J=2 %THEN %START;           ! SIMPLE LABEL
 4932              ENTER JUMP(15,LNAME,0)
 4933              REPORTUI=1
 4934           %FINISH %ELSE %START;          ! SWITCH LABELS
 4935              COPY TAG(LNAME)
 4936              ARRP=ARR
 4937              GWRDD=SNDISP<<2;            ! BYTE DISP OF DESCRIPTOR IN PLT
 4938              %UNLESS OLDI=LEVEL %AND TYPE=6 %START
 4939                 FAULT(4,LNAME); P=P-1; SKIP APP
 4940                 %RETURN
 4941              %FINISH
 4942              LWB=FROM2(K);                ! GET LOWER BOUND
 4943              CSEXP(BREG,16_51)
 4944              %IF ARRP=1 %THEN PSF1(SBB,0,LWB)
 4945              XYNB=SET XORYNB(-1,-1);     ! TO PLT
 4946              PF1(JUNC,3,XYNB,GWRDD);     ! JUMP INDIRECT VIA WORD ARRAY
 4947                                          ! OF 32 BIT RELOCATED ADDRESSES
 4948              REPORTUI=1; FORGET(-1)
 4949           %FINISH
 4950           %RETURN
 4951  SW(3):                                  ! RETURN
 4952           FAULT(30,0) %UNLESS FLAG(LEVEL)&16_3FFF=16_1000
 4953           P=P+1
 4954  RET:     RT EXIT
 4955           REPORT UI=1
 4956           CURR INST=1 %IF CODE=0
 4957           %RETURN
 4958  SW(4):                                 ! %RESULT(ASSOP)(EXPR)
 4959           PTYPE=FLAG(LEVEL)&16_3FFF; UNPACK
 4960           %IF PTYPE>16_1000 %AND A(P+1)#3 %THEN %START;! ASSOP #'->'
 4961              %IF A(P+1)=1 %AND NAM#0 %AND A(P+5)=4 %AND A(P+6)=1 %START
 4962                 P=P+7; TYPEP=TYPE; PRECP=PREC
 4963                 CNAME(4,ACCR)
 4964                 FAULT(81,0) %UNLESS A(P)=2; P=P+1
 4965                 FAULT(83,0) %UNLESS TYPEP=TYPE %AND PRECP=PREC
 4966                 ->RET
 4967              %FINISH
 4968              %IF A(P+1)=2 %THEN %START;    ! ASSOP='='
 4969                 P=P+2
 4970                 %IF NAM#0 %THEN TYPE=1;    ! MAPS HAVE INTEGER RESULTS
 4971                 %IF TYPE=5 %THEN %START
 4972                    CSTREXP(0,ACCR)
 4973                    PSF1(LD,1,DISPLAY(RBASE)-8); ! RESULT DESCRPT
 4974                    PF1(IAD,0,PC,SPECIAL CONSTS(2))
 4975                    PF2(MV,1,1,0,0,UNASSPAT&255)
 4976                    PSF1(LDB,2,DISPLAY(RBASE)-8)
 4977                    COPY DR
 4978                 %FINISH %ELSE %START
 4979                    %IF PREC<5 %THEN PREC=5
 4980                    %IF NAM=0 %THEN KK=PREC<<4!TYPE %ELSE KK=16_51
 4981                    CSEXP(ACCR,KK)
 4982                 %FINISH; ->RET
 4983              %FINISH
 4984           %FINISH
 4985           FAULT(31,0)
 4986           P=P+2; SKIP EXP;                 ! IGNORE SPURIOUS RESULT
 4987           %RETURN
 4988  SW(5):                                  ! %MONITOR (AUI)
 4989           PSF1(LSD,0,0);                 ! ERR=0 & EXTRA =0
 4990           PPJ(0,2);                      ! TO ERROR ROUTINE
 4991           P=P+1; ->AUI
 4992  SW(6):                                 ! %STOP
 4993           PPJ(0,21)
 4994           P=P+1
 4995           CURR INST=1 %IF CODE=0
 4996           REPORTUI=1
 4997           %RETURN
 4998  SW(7):                                  !'%SIGNAL'(EVENT')(N)(OPEXPR)
 4999           PSF1(PRCL,0,4)
 5000           PSF1(JLK,0,1);                 ! STACK DUMMY PC
 5001           %IF NMDECS(LEVEL)&16 #0 %START;! IN AN 'ON' GROUP
 5002              %IF FLAG(LEVEL)<=2 %START;  ! IN A BEGIN BLOCK
 5003                 PSF1(LD,1,12);           ! SO RESET DIAG POINTER
 5004                 DIAGPOINTER(LEVEL-1);    ! TO NEXT OUTER BLOCK
 5005                 PSF1(STD,1,12)
 5006                 PF1(STLN,0,TOS,0)
 5007              %FINISH %ELSE %START;       ! 'ON IN A RT/FN/MAP
 5008                 PSF1(LSS,1,0);           ! GET PREVIOUS LNB
 5009                 PF1(ST,0,TOS,0);         ! AND STACK THAT
 5010              %FINISH
 5011           %FINISH %ELSE PF1(STLN,0,TOS,0)
 5012           GRUSE(ACCR)=0
 5013           J=A(P+2);                      ! EVENT NO
 5014           FAULT2(26,J,0) %UNLESS 1<=J<=15
 5015           %IF A(P+3)=1 %START;           ! SUBEVENT SPECIFIED
 5016              P=P+4; CSEXP(ACCR,16_51)
 5017              PF1(AND,0,0,255)
 5018              PF1(OR,0,0,256*J)
 5019           %FINISH %ELSE PF1(LSS,0,0,256*J)
 5020           PSF1(SLSS,0,0)
 5021           PF1(ST,0,TOS,0)
 5022           XYNB=SET XORYNB(-1,-1);        ! TO PLT
 5023           PSF1(RALN,0,9)
 5024           PF1(CALL,2,XYNB,40)
 5025           CURR INST=1 %IF CODE=0
 5026           REPORTUI=1; %RETURN
 5027  SW(8):                                  ! %EXIT
 5028  SW(9):                                  ! %CONTINUE
 5029           ALT=ALT&7;                     ! 0 FOR EXIT 1 FOR CONTINUE
 5030           %IF EXITLAB=0 %THEN FAULT2(54+ALT,0,0) %AND %RETURN
 5031           KK=INTEGER(ADDR(EXITLAB)+4*ALT)
 5032           ENTER JUMP(15,KK,B'10')
 5033           REPORTUI=1
 5034           CURR INST=1 %IF CODE=0
 5035  %END
 5036  %ROUTINE CIFTHEN(%INTEGER MARKIU,MARKC,MARKUI,MARKE,MARKR,SKIP)
 5037  !***********************************************************************
 5038  !*    THIS ROUTINE COMPILES CONDITIONAL EXPRESSIONS.IT REQUIRES THE    *
 5039  !*    FOLLOWING PARAMETERS TO BE SET TO THEIR A .R. ENTRY.             *
 5040  !*    MARKIU TO THE ENTRY FOR P(%IU)                                   *
 5041  !*    MARKC  TO THE ENTRY FOR P(COND)                                  *
 5042  !*    MARKUI TO THE ENTRY FOR (FIRST OCCURRENCE OF)  P(UI)             *
 5043  !*    MARKE  TO THE ENTRY FOR P(ELSE')  - =0 FOR BACKWARDS CONDITION   *
 5044  !*    MARKR  TO ENTRY FOR P(RESTOFIU)   - =0 FOR BACKWARDS CONDITION   *
 5045  !***********************************************************************
 5046  %INTEGER ALTUI,CCRES,ELRES,THENLAB,ELSELAB,USERLAB,REPORT,START,ELSEALT,K
 5047  %CONSTINTEGER NULL ELSE=4
 5048  %SWITCH ESW(1:NULL ELSE)
 5049        SET LINE %UNLESS SKIP=YES
 5050        MARKIU=A(MARKIU);                 ! ALT OF IU 1=%IF,2=%UNLESS
 5051        PLABEL=PLABEL-1
 5052        THENLAB=PLABEL
 5053        START=0;                          ! NO START IN CONDITION YET
 5054        ELSELAB=0;                        ! MEANS NO ELSE CLAUSE
 5055        P=MARKC
 5056        %IF MARKR>0 %AND A(MARKR)<=2 %THEN START=1;! '%START' OR '%THENSTART'
 5057        %IF MARKE#0 %AND LEVEL<2 %AND START=0 %THEN FAULT(57,0)
 5058        USERLAB=-1
 5059        %IF START#0 %THEN ALTUI=0 %ELSE ALTUI=A(MARKUI)
 5060        %IF ALTUI=2 %AND A(MARKUI+3)=2 %THEN USERLAB=FROM AR2(MARKUI+1);    ! UI = SIMPLE LABEL
 5061        %IF 8<=ALTUI<=9 %AND EXITLAB#0 %START; ! VALID EXIT
 5062           %IF ALTUI=8 %THEN USERLAB=EXITLAB %ELSE USERLAB=CONTLAB
 5063        %FINISH
 5064  !
 5065        %IF SKIP=YES %THEN %START;        ! NO CODE NEEDED
 5066           %IF START#0 %START
 5067              P=MARKR+1
 5068              CSTART(2,1);                ! NO CODE
 5069              MARKE=P
 5070           %FINISH
 5071           CCRES=1;                       ! NO CODE FOR ELSE
 5072           ->ELSE
 5073        %FINISH
 5074  !
 5075        %IF USERLAB>=0 %THEN %START;      ! FIRST UI IS'->'<LABEL>
 5076           NMDECS(LEVEL)=NMDECS(LEVEL)!1
 5077           CCRES=CCOND(0,3-MARKIU,USERLAB)
 5078           %IF CCRES#0 %THEN CCRES=CCRES!!3;! CONDITION BACKWARDS!
 5079           THENLAB=0;                     ! NO THENLAB IN THIS CASE
 5080           REPORT=1;                      ! UI TRANSFERED CONTROL
 5081        %FINISH %ELSE %START
 5082           CCRES=CCOND(1,MARKIU,THENLAB)
 5083           %IF START#0 %THEN %START;      ! %THEN %START
 5084              %IF CCRES=0 %START;         ! CONDITIONAL
 5085                 FAULT(57,0) %IF LEVEL<2
 5086                 NMDECS(LEVEL)=NMDECS(LEVEL)!1
 5087              %FINISH
 5088              P=MARKR+1
 5089              CSTART(CCRES,1)
 5090              %IF A(P)<=2 %THEN PLABEL=PLABEL-1 %AND ELSELAB=PLABEL
 5091              MARKE=P
 5092              REPORT=LAST INST
 5093           %FINISH %ELSE %START
 5094              %IF CCRES#2 %START
 5095                 P=MARKUI; CUI(1)
 5096                 REPORT=REPORTUI
 5097              %FINISH %ELSE %START;       ! FIRST UI NEVER EXECUTED
 5098                 REPORT=1
 5099              %FINISH
 5100           %FINISH
 5101        %FINISH
 5102  ELSE:                                   ! ELSE PART
 5103        %IF MARKE=0 %THEN ELSEALT=NULL ELSE %ELSE ELSEALT=A(MARKE)
 5104        %IF ELSEALT<NULL ELSE %THEN PLABEL=PLABEL-1 %AND ELSELAB=PLABEL
 5105        P=MARKE+1
 5106        %IF REPORT=0=CCRES %AND ELSEALT<NULL ELSE %THEN REPORT=1 %AND ENTER JUMP(15,ELSELAB,B'10');! LONG JUMP BUT SAVE ENV
 5107        %IF THENLAB>0 %THEN ELRES=ENTER LAB(THENLAB,B'11'!REPORT<<2)
 5108                                          ! CONDITIONAL&MERGE OR REPLACE
 5109        ->ESW(ELSEALT)
 5110  ESW(1):                                 ! '%ELSESTART'
 5111        %IF CCRES=0 %THEN NMDECS(LEVEL)=NMDECS(LEVEL)!1
 5112        CSTART(CCRES,2)
 5113        REPORT=LAST INST
 5114        ->ENTER ELSELAB
 5115  ESW(2):                                 ! '%ELSE' (%IU) ETC
 5116        MARKE=0; MARKUI=0
 5117        MARKR=P+1+FROMAR2(P+1)
 5118        %IF A(MARKR)=3 %THEN %START
 5119           MARKE=MARKR+1+FROM AR2(MARKR+1)
 5120           MARKUI=MARKR+3
 5121        %FINISH
 5122        %IF CCRES=1 %OR SKIP=YES %THEN K=YES %ELSE K=NO
 5123        CIFTHEN(P,P+3,MARKUI,MARKE,MARKR,K)
 5124        ->ENTER ELSELAB
 5125  ESW(3):                                 ! '%ELSE'<UI>
 5126        %IF CCRES#1 %THEN %START
 5127           %IF START#0 %THEN SET LINE;    ! FOR CORRECT LINE IF FAILS IN UI
 5128           %IF THENLAB=0 %THEN K=0 %ELSE K=2
 5129           CUI(K)
 5130           REPORT=REPORTUI
 5131        %FINISH
 5132  ENTER ELSELAB:
 5133        %IF ELSELAB>0 %THEN ELRES=ENTER LAB(ELSELAB,B'11'!REPORT<<2)
 5134                                          ! CONDITIONAL MERGE
 5135  ESW(NULL ELSE):                         ! NULL ELSE CLAUSE
 5136  %END
 5137  %ROUTINE CSTART(%INTEGER CCRES,CODE)
 5138  !***********************************************************************
 5139  !*    COMPILE A COMPLETE START-FINISH BLOCK BY RECURSION               *
 5140  !*    IF START NEVER EXECUTED SKIP TO CORRESPONDING FINISH             *
 5141  !*    CODE=0 WAS UNCONDITIONAL NOW SHOULD BE UNUSED                    *
 5142  !*    CODE=1 AFTER THEN                                                *
 5143  !*    CODE=2 AFTER ELSE                                                *
 5144  !*    CODE=3 AFTER ONEVENT                                             *
 5145  !*    P ON ENTRY TO FORWARD POINTER TO THE RIGHT FINISH                *
 5146  !*    P ON EXIT TO THE ELSE CLAUSE AFTER THE RIGHT FINISH              *
 5147  !***********************************************************************
 5148  %INTEGER SKIPCODE,FINISHAR,OLDNEXTP,OLDLINE
 5149        SKIPCODE=NO
 5150        %IF 1<=CODE<=2 %AND CCRES!CODE=3 %THEN SKIPCODE=YES;! NEVER EXECUTED
 5151        FINISHAR=FROMAR4(P);              ! TO START OF AR FOR FINISH
 5152        %IF FINISHAR<=P %THEN ABORT;      ! FOR TESTING
 5153        OLDLINE=LINE;                     ! FOR ERROR MESSAGES
 5154        %CYCLE;                           ! THROUGH INTERVENING STATMNTS {I didn't change this one. Looks like both forms of until were accepted.}
 5155           OLDNEXTP=NEXTP
 5156           %IF SKIP CODE=NO %THEN COMPILE A STMNT %ELSE %START
 5157              LINE=A(NEXTP+3)<<8!A(NEXTP+4)
 5158              NEXTP=NEXTP+A(NEXTP)<<16+A(NEXTP+1)<<8+A(NEXTP+2)
 5159           %FINISH
 5160        %REPEAT %UNTIL OLDNEXTP>=FINISHAR;! HAVING COMPILED FINISH
 5161        P=FINISHAR+6;                     ! TO ELSE CLAUSE
 5162  !
 5163        %IF A(P)<=2 %AND CODE#1 %THEN FAULT2(45+CODE,OLDLINE,0)
 5164        %IF SKIPCODE=YES %THEN LAST INST=1
 5165  %END
 5166  %ROUTINE CCYCBODY(%INTEGER UA,ELAB,CLAB)
 5167  !***********************************************************************
 5168  !*    COMPILES A CYCLE REPEAT BODY BY RECURSION                        *
 5169  !*    ON ENTRY P IS TO FORWARD POINTER. ON EXIT TO ALT OF UNTIL        *
 5170  !*    UA = O IF UNTIL NOT ALLOWED                                      *
 5171  !*    ELAB&CLAB ARE LABELS FOR ELSE & CONTINUE                         *
 5172  !***********************************************************************
 5173  %INTEGER FINISHAR,OLDLINE,SAVEE,SAVEC
 5174        FINISHAR=FROMAR4(P)
 5175        %IF FINISHAR<=P %THEN ABORT
 5176        OLDLINE=LINE; SAVEE=EXIT LAB; SAVEC=CONTLAB
 5177        EXITLAB=ELAB; CONTLAB=CLAB
 5178        %WHILE NEXTP<=FINISHAR %CYCLE
 5179           COMPILE A STMNT
 5180        %REPEAT
 5181        EXIT LAB=SAVEE; CONTLAB=SAVEC
 5182        P=FINISHAR+6
 5183        %IF A(P)=1 %AND UA=0 %THEN FAULT2(12,OLDLINE,0)
 5184  %END
 5185  
 5186  %ROUTINE CLOOP(%INTEGER ALT, MARKC, MARKUI)
 5187  !***********************************************************************
 5188  !*    ALT=1 FOR %WHILE, =2 FOR %UNTIL, =3 FOR %FOR                     *
 5189  !*    MARKC IS TO THE CONDITION OR CONTROL CLAUSE                      *
 5190  !*    MARKUI IS TO THE UI, SPECIAL FOR %CYCLE                          *
 5191  !***********************************************************************
 5192  %INTEGER L1,L2,L3,CCRES,ELRES
 5193  %INTEGER FORNAME,INITTYPE,INITVAL,STEPTYPE,STEPVAL,FINALTYPE,FINALVAL,FACC,FDISP,FBASE,INITP,REPMASK,USEDEBJ,DEBTO
 5194  %ROUTINESPEC FOREXP(%INTEGERNAME ETYPE,EVALUE,%INTEGER TT,REG)
 5195  %ROUTINESPEC VALIDATE FOR
 5196  %SWITCH SW(0:6)
 5197        P=MARKC
 5198        SFLABEL=SFLABEL-2
 5199        L1=SFLABEL; L2=L1+1
 5200  !
 5201  ! SET L3 FOR ALTS 0,5&6 ONLY
 5202  !
 5203        L3=0
 5204        %IF B'1100001'&1<<ALT#0 %THEN L3=SFLABEL-1 %AND SFLABEL=L3
 5205  !
 5206  ! UPDATE THE LINE NUMBER FOR ALTS 1 TO 3 ONLY
 5207  !
 5208        %IF 1<=ALT<=3 %THEN SET LINE
 5209  !
 5210  ! ENTER THE FIRST LABEL(L1) FOR ALL ALTS EXCEPT 3 & 6
 5211  !
 5212        %IF B'0110111'&1<<ALT#0 %THEN ELRES=ENTER LAB(L1,0)
 5213        ->SW(ALT)
 5214  SW(0):                                  ! %CYCLE
 5215        C CYC BODY(1,L2,L3)
 5216        ELRES=ENTER LAB(L3,B'011')
 5217        %IF A(P)=1 %START;                ! %REPEAT %UNTIL <COND>
 5218           P=P+1; CCRES=CCOND(0,1,L1)
 5219        %FINISH %ELSE ENTER JUMP(15,L1,0)
 5220        ELRES=ENTER LAB(L2,B'011')
 5221  WAYOUT:                                 ! REMOVE LABELS NOT REQUIRED
 5222        REMOVE LAB(L1)
 5223        REMOVE LAB(L2)
 5224        REMOVE LAB(L3) %IF L3>0
 5225        %RETURN
 5226  SW(1):                                  ! UI WHILE COND
 5227        CCRES=CCOND(0,1,L2)
 5228        P=MARKUI
 5229        CUI(1)
 5230        ENTERJUMP(15,L1,0);               ! UNCONDITIONALLY BACK TO WHILE
 5231        ELRES =ENTER LAB(L2,B'111');      ! CONDITIONAL(?) & REPLACE ENV
 5232        ->WAYOUT
 5233  SW(2):                                  ! UI %UNTIL COND
 5234        P=MARKUI
 5235        CUI(1)
 5236        P=MARKC
 5237        CCRES=CCOND(0,1,L1)
 5238        ->WAYOUT
 5239  SW(3):                                  ! UI %FOR ....
 5240  SW(6):                                  ! %FOR ... %CYCLE
 5241  
 5242        FORNAME=FROMAR2(P)
 5243        INITP=P+2; P=INITP
 5244        COPY TAG(FORNAME)
 5245        FDISP=K; FBASE=I; FACC=2*NAM
 5246        FAULT2(91,0,FORNAME) %UNLESS TYPE=1 %AND PREC=5 %AND ROUT=0=ARR
 5247        WARN(4,FORNAME) %UNLESS FBASE=RBASE
 5248  !
 5249        SKIP EXP;                         ! P TO STEP EXPRSN
 5250        FOR EXP(STEPTYPE,STEPVAL,1,ACCR); ! STEP TO ACCR AND TEMP
 5251        %IF STEPTYPE=0 %START
 5252           FAULT2(92,0,0) %IF  STEPVAL=0; ! ZERO STEP
 5253        %FINISH %ELSE %START
 5254           %IF PARMOPT#0 %THEN PPJ(26,11);! FAULT COMPUTED ZERO STEP
 5255        %FINISH
 5256  !
 5257        FOR EXP(FINALTYPE,FINALVAL,1,ACCR);! EVALUATE FINAL
 5258  !
 5259        P=INITP
 5260        FOR EXP(INITTYPE,INITVAL,0,BREG);! INITIAL VALUE TO B
 5261        %IF PARMOPT#0 %THEN VALIDATE FOR
 5262  !
 5263        USEDEBJ=0;                        ! DONT USE IT
 5264        %IF STEPVAL=-1 %AND FINALTYPE!STEPTYPE=0 %AND FINALVAL=1 %START
 5265           USEDEBJ=1;                     ! CAN USE BEST BRANCH INSTRN
 5266           PSF1(LB,0,INITVAL) %IF INITTYPE=0
 5267           %UNLESS INITTYPE=0 %AND INITVAL>=1 %THEN ENTERJUMP(32+13,L2,B'10');  ! JAF B>0 NO TRAVERSES
 5268           DEBTO=CA;                      ! SAVE CA FOR DEBJ
 5269        %FINISH %ELSE %START
 5270           %IF INITTYPE!STEPTYPE=0 %THEN %START
 5271              PSF1(LB,0,INITVAL-STEPVAL)
 5272           %FINISH %ELSE %START
 5273              PSF1(LB,0,INITVAL) %IF INITTYPE=0
 5274              PSF1(SBB,STEPTYPE,STEPVAL)
 5275           %FINISH
 5276  !
 5277  ! HAVE B SET TO INIT-STEP.  FOR COMPUTED STEPS NOW MUST CHECK
 5278  ! FOR NEGATIVE TRAVERSES. FOR FIXED STEPS THIS CAN BE SET
 5279  ! IN MASK FOR REPEATING
 5280  !
 5281           %IF STEPTYPE=1 %THEN %START
 5282              PF1(LSS,0,BREG,0)
 5283              PSF1(IRSB,FINALTYPE,FINALVAL)
 5284              PSF1(IDV,1,STEPVAL)
 5285              GRUSE(ACCR)=0
 5286              ENTERJUMP(37,L2,B'10')
 5287              REPMASK=7
 5288           %FINISH %ELSE REPMASK=8!(2<<(STEPVAL>>31));  ! A OR C
 5289  !
 5290           ELRES=ENTER LAB(L1,0);         ! LABEL FOR REPEATING
 5291  !
 5292           %IF STEPTYPE=0 %AND STEPVAL=1 %START
 5293              PSF1(CPIB,FINALTYPE,FINALVAL)
 5294           %FINISH %ELSE %START
 5295              PSF1(CPB,FINALTYPE,FINALVAL)
 5296              PSF1(ADB,STEPTYPE,STEPVAL)
 5297           %FINISH
 5298           GRUSE(BREG)=0
 5299           ENTER JUMP(REPMASK,L2,B'10')
 5300        %FINISH
 5301        BASE=FBASE; AREA=-1
 5302        PSORLF1(STB,FACC,AREA CODE,FDISP)
 5303        NOTE ASSMENT(BREG,2,FORNAME)
 5304  !
 5305        P=MARKUI;                         ! TO UI OR '%CYCLE'(HOLE)
 5306        %IF ALT=3 %THEN %START;           ! DEAL WITH CONTROLLED STMNTS
 5307           CUI(0)
 5308        %FINISH %ELSE %START
 5309           CCYCBODY(0,L2,L3)
 5310           ELRES=ENTER LAB(L3,B'011');    ! LABEL FOR CONTINUE
 5311        %FINISH
 5312        BASE=FBASE; ACCESS=FACC
 5313        AREA=-1; DISP=FDISP
 5314        NAMEOP(2,BREG,4,FORNAME);         ! CONTROL TO B
 5315        %IF USEDEBJ=0 %THEN ENTER JUMP(15,L1,0) %ELSE PSF1(DEBJ,0,(DEBTO-CA)//2) %AND GRUSE(BREG)=0
 5316        ELRES=ENTERLAB(L2,B'111'!!(USEDEBJ<<2));! REPLACE ENV UNLESS DEBJ
 5317                                          ! WHEN MERGE ENV
 5318        ->WAYOUT
 5319  SW(4):                                  ! %WHILE COND %CYCLE
 5320        CCRES = CCOND(0,1,L2)
 5321        C CYC BODY(0,L2,L1)
 5322        ENTER JUMP(15,L1,0)
 5323        ELRES = ENTER LAB(L2,B'111');     ! CONDITIONAL & REPLACE ENV
 5324        ->WAYOUT
 5325  SW(5):                                  ! %UNTIL ... %CYCLE
 5326                                          ! ALSO %CYCLE... %REPEAT %UNTIL
 5327                                          ! MARKUI TO %CYCLE
 5328        P=MARKUI
 5329        C CYC BODY(0,L2,L3)
 5330        P=MARKC; ELRES=ENTER LAB(L3,B'011');! CONTINUE LABEL IF NEEDED
 5331        CCRES=CCOND(0,1,L1)
 5332        ELRES=ENTER LAB(L2,B'011')
 5333        ->WAYOUT
 5334  %ROUTINE FOREXP(%INTEGERNAME ETYPE,EVALUE,%INTEGER TOTEMP,USEREG)
 5335  !***********************************************************************
 5336  !*    P INDEXES EXPRESSION.  IF CONST PUT INTO EVALUE OTHERWISE        *
 5337  !*    COMPILE TO USEREG AND STORE IN TEMP IF TOTEMP#0                  *
 5338  !***********************************************************************
 5339  %INTEGER INP,VAL,OP
 5340        INP=P; P=P+3
 5341        %IF INTEXP(VAL)=0 %AND IMOD(VAL)<16_1FFFF %START
 5342           EVALUE=VAL; ETYPE=0;           ! EXPRESSION A LITERAL CONST
 5343           %RETURN
 5344        %FINISH
 5345        P=INP
 5346        CSEXP(USEREG,16_51);              ! INTEGER MODE TO REG
 5347        ETYPE=1;                          ! NOT CONST
 5348        %IF TOTEMP#0 %START
 5349           GET WSP(VAL,1)
 5350           %IF USEREG=ACCR %THEN OP=ST %ELSE OP=STB
 5351           PSF1(OP,1,VAL)
 5352           EVALUE=VAL
 5353        %FINISH
 5354  %END
 5355  %ROUTINE VALIDATE FOR
 5356  !***********************************************************************
 5357  !*    INITIAL VALUE IN BREG OR A CONSTANT                              *
 5358  !***********************************************************************
 5359  %INTEGER I
 5360        %IF INITTYPE!STEPTYPE!FINALTYPE=0 %START
 5361           J=FINALVAL-INITVAL;            ! ALL CONSTANT CAN CHECK NOW
 5362           %IF (J//STEPVAL)*STEPVAL#J %THEN FAULT2(93,0,0)
 5363           %RETURN
 5364        %FINISH
 5365        %IF STEPTYPE=0 %AND IMOD(STEPVAL)=1 %THEN %RETURN
 5366  !
 5367  ! CHECK BY PLANTING CODE
 5368  !
 5369        %IF INITTYPE=0 %THEN PSF1(LSS,0,INITVAL) %ELSE PF1(LSS,0,BREG,0)
 5370        PSF1(IRSB,FINALTYPE,FINALVAL)
 5371        PSF1(IMDV,STEPTYPE,STEPVAL)
 5372        PF1(LSS,0,TOS,0)
 5373        GRUSE(ACCR)=0
 5374        PPJ(36,11)
 5375  %END
?I unused
 5376  %END
 5377           %ROUTINE ASSIGN(%INTEGER ASSOP,P1)
 5378  !***********************************************************************
 5379  !*       HANDLES ARITHMETIC,STRING & ADDRESS ASSIGNMENTS TO VARIABLES  *
 5380  !*       FORMAL PARAMETERS AND DOPEVECTORS                             *
 5381  !*       ASSOP:-                                                       *
 5382  !*        1 IS FOR '=='                                                *
 5383  !*        2 IS FOR '='                                                 *
 5384  !*        3 IS FOR '<-' (JAM TRANSFER)                                 *
 5385  !*        4 IS FOR '->' (UNCONDITIONAL RESOLUTION)                     *
 5386  !*       >4 IS FOR STORE ACC BY 'ASSOP&3' INTO NAME                    *
 5387  !*                                                                     *
 5388  !*       P POINTS TO THE EXPRESSION. P1 TO THE NAME ON LHS             *
 5389  !***********************************************************************
 5390  %INTEGER Q,QQ,KK,TYPEP,PRECP,PTYPEP,JJJ,P2,JJ,REG,STCODE,RHTYPE,ACCP,II,HEAD1,NOPS,TPCELL,LVL,BOT1,LHNAME,RHNAME
 5391  %RECORD (RD) R{(RD)
 5392  %SWITCH SW(0:3);                       ! TO SWITCH ON ASSOP
 5393           P2=P
 5394           %IF ASSOP>4 %THEN RHTYPE=TYPE
 5395           LHNAME=A(P1)<<8!A(P1+1)
 5396           P=P1; REDUCE TAG;             ! LOOK AT LH SIDE
 5397           PTYPEP=PTYPE; JJ=J
 5398           KK=K; II=I; LVL=OLDI
 5399           TPCELL=TCELL; ACCP=ACC
 5400           P=P2; TYPEP=TYPE; PRECP=PREC; ! SAVE USEFUL INFO FOR LATER
 5401           -> SW(ASSOP&3)
 5402  !
 5403  SW(2):SW(3):                           ! ARITHMETIC ASSIGNMENTS
 5404           %IF TYPE=3 %THEN ->RECOP
 5405           TYPE=1 %UNLESS TYPE=2 %OR TYPE=5;! IN CASE OF RUBBISHY SUBNAMES
 5406           ->STring %IF TYPE=5;              ! LHS IS A STRING
 5407  BACK:    HEAD1=0;                      ! CLEAR TEMPORAYRY LIST HEADS
 5408           TYPE=1 %UNLESS TYPE=2;        ! DEAL WITH UNSET NAMES
 5409           TYPEP=TYPE
 5410           NOPS=1<<18+1; P=P2+3
 5411           PUSH(HEAD1,ASSOP&3+33,PRECP,0); ! ASSIGNMENT OPERATOR
 5412           BOT1=HEAD1
 5413           PUSH(HEAD1,PTYPEP<<16!2,P1,0);  ! LHS
 5414           %IF ASSOP>4 %THEN %START
 5415              FAULT(24,0) %UNLESS TYPE=RHTYPE
 5416              PUSH(HEAD1,RHTYPE<<16!9,0,0)
 5417              OLINK(ACCR)=HEAD1
 5418           %FINISH %ELSE TORP(HEAD1,BOT1,NOPS); ! RHS TO REVERSE POLISH
 5419           EXPOP(HEAD1,-1,NOPS,256+PRECP<<4+TYPEP); ! PLANT CODE
 5420  !        CLEAR LIST(HEAD1)
 5421           ASLIST(BOT1)_LINK=ASL
 5422           ASL=HEAD1
 5423           %RETURN
 5424  !NA:      NOTE ASSMENT(-1,ASSOP&3,A(P1))
 5425  STring:                                    ! STRINGS
 5426  !
 5427  ! PICK OFF NULL STRINGS AND SUBSTITUTE A CRAFTY MVL FOR S=""
 5428  !
 5429           %IF A(P+3)=4 %AND A(P+4)=2 %AND A(P+5)=16_35 %AND A(P+10)=0 %AND A(P+11)=2 %THEN %START
 5430              Q=P+12-A(P+10)>>1
 5431              P=P1; CNAME(1,DR)
 5432              PF2(MVL,0,1,0,0,0)
 5433              P=Q; %RETURN
 5434           %FINISH
 5435           %IF ASSOP<=3 %THEN CSTREXP(0,ACCR)
 5436           ASSOP=ASSOP&3
 5437           QQ=STRINGL; Q=P
 5438           REGISTER(ACCR)=1
 5439           OLINK(ACCR)=ADDR(R)
 5440           R_PTYPE=16_51; R_FLAG=9; R_UPTYPE=0
 5441           R_XB=ACCR
 5442           P=P1; CNAME(1,DR)
 5443           %IF R_FLAG#9 %THEN PF1(LSD,0,TOS,0)
 5444           PF1(IAD,0,PC,SPECIAL CONSTS(2))
 5445           %IF ASSOP#3 %AND (ROUT#0 %OR NAM#0=ARR) %AND QQ=0 %START
 5446                                          ! LHS=MAP : DR BOUND NOT VALID
 5447                                          ! ALSO NAMES MAPPED ==STRING(ADDR)
 5448              %IF PARMOPT#0 %THEN PPJ(0,18) %ELSE %START
 5449                 PF1(STUH,0,BREG,0)
 5450                 PF1(LUH,0,BREG,0)
 5451                 PF1(LDB,0,BREG,0)
 5452              %FINISH
 5453              GRUSE(BREG)=0
 5454           %FINISH
 5455           GRUSE(ACCR)=0
 5456           REGISTER(ACCR)=0
 5457           %IF QQ>0 %AND ASSOP#3 %THEN PF2(MV,0,0,QQ,0,0) %ELSESTART
 5458              %IF ASSOP=3 %THEN PF1(STD,0,TOS,0)
 5459              PF2(MV,1,1,0,0,UNASSPAT&255)
 5460              %IF PARMARR#0 %OR ASSOP=3 %THEN PSF1(USH,0,8) %AND PSF1(USH,0,-40)
 5461              %IF PARMARR#0 %AND ASSOP=2 %THEN PPJ(36,9)
 5462              %IF ASSOP=3 %THEN %START
 5463                 PF1(IRSB,2,TOS,0)
 5464                 PF1(ST,2,7,0);           ! STORE AMENDED CURRENT LENGTH  {EMAS Imp9 vs Imp77 - ST is both a constant and a label in EMAS Imp9}
 5465              %FINISH
 5466           %FINISH
 5467           P=Q; %RETURN
 5468  !
 5469  ! THIS SECTION DEALS WITH OPERATIONS ON COMPLETE RECORDS
 5470  !
 5471  RECOP:                                   ! LHS IS RECORD WITHOUT SUBNAME
 5472           REG=ACCR;                      ! IN CASE FAULT 66
 5473           Q=TSEXP(JJJ)
 5474           %IF Q=1 %AND JJJ=0 %START;     ! CLEAR A RECORD TO ZERO
 5475              P=P1; CNAME(3,DR)
 5476              %IF ACC<=128 %THEN JJ=0 %AND KK=ACC-1 %ELSE %START
 5477                 JJ=1; KK=0
 5478                 %IF NAM#0 %OR ARR#0 %THEN PSF1(LDB,0,ACC)
 5479              %FINISH
 5480              PF2(MVL,JJ,1,KK,0,0)
 5481           %FINISH %ELSE %START
 5482              ->BACK %UNLESS TYPE=3 %AND A(P2+3)=4 %AND A(P2+4)=1
 5483              P=P2+5; CNAME(3,ACCR)
 5484              ACCP=ACC
 5485              %UNLESS A(P)=2 %THEN FAULT2(66,0,LHNAME) %AND ->F00
 5486              R_PTYPE=16_61; R_FLAG=9
 5487              R_XB=ACCR<<5; R_D=0
 5488              OLINK(ACCR)=ADDR(R)
 5489              REGISTER(ACCR)=1
 5490              P=P1; CNAME(3,DR)
 5491              REGISTER(ACCR)=0
 5492              %IF R_FLAG#9 %THEN PF1(LSD,0,TOS,0)
 5493              %IF ASSOP=2 %AND ACCP#ACC %THEN FAULT2(67,LHNAME,FROMAR2(P2+5)) %AND ->F00
 5494              %IF ACCP>ACC %THEN ACCP=ACC
 5495              {%UNTIL ACCP=0} %CYCLE
 5496                 %IF ACCP>128 %THEN KK=128 %ELSE KK=ACCP
 5497                 PF2(MV,0,0,KK-1,0,0)
 5498                 ACCP=ACCP-KK
 5499              %REPEAT %UNTIL ACCP=0
 5500              GRUSE(ACCR)=0
 5501           %FINISH
 5502           P=P2; SKIP EXP
 5503           GRUSE(DR)=0
 5504           %RETURN
 5505  SW(0):                                 ! RESOLUTION
 5506           P=P1; CNAME(2,DR)
 5507           P=P2;
 5508           %IF TYPE=5 %THEN CRES(0) %ELSE %START
 5509              SKIP EXP
 5510              FAULT2(71,0,FROMAR2(P1)) %UNLESS TYPE=7
 5511           %FINISH
 5512           %RETURN
 5513  SW(1):                                 ! '==' AND %NAME PARAMETERS
 5514           REG=ACCR; STCODE=ST;           ! NORMALLY USE ACC
 5515           ->F81 %UNLESS A(P2+3)=4 %AND A(P2+4)=1
 5516           FAULT2(82,0,LHNAME) %AND ->F00 %UNLESS NAM=1; ! ONLY POINTERS ON LHS OF==
 5517           P=P2+5
 5518           RHNAME=A(P)<<8!A(P+1)
 5519           ->ARRNAME %IF ARR=1
 5520           %IF A(P1+2)=2=A(P1+3) %START;  ! LHS SCALAR POINTERNAME
 5521              COPYTAG(RHNAME)        ;    ! LOOK AT RHS
 5522              %IF PTYPE#SNPT %AND ARR#0 %THEN REG=DR %AND STCODE=STD
 5523           %FINISH
 5524           CNAME(3,REG);                  ! DESCRPTR TO ACC
 5525           R_PTYPE=16_61; R_FLAG=9
 5526           R_XB=REG
 5527           OLINK(REG)=ADDR(R)
 5528           REGISTER(REG)=1
 5529           ->F81 %UNLESS A(P)=2;          ! NO REST OF EXP ON RHS
 5530           Q=P+1; P=P1
 5531           ->F83 %UNLESS TYPE=TYPEP %AND PREC=PRECP
 5532           ->F86 %UNLESS OLDI<=LVL %OR BASE=0 %OR NAM#0
 5533                                          ! GLOBAL == NONOWN LOCAL
 5534           CNAME(6,0)
 5535           %IF R_FLAG#9 %THEN %START
 5536              %IF REG#ACCR %THEN ABORT
 5537              PF1(LSD,0,TOS,0)
 5538              GRUSE(ACCR)=0
 5539           %FINISH
 5540           REGISTER(REG)=0
 5541  COM:     PSORLF1(STCODE,ACCESS,AREA CODE,DISP)
 5542           %IF REG=DR %AND ACCESS#0 %THEN ABORT
 5543           NOTE ASSMENT(REG,1,A(P1)<<8!A(P1+1))
 5544           P=Q; %RETURN
 5545  ARRNAME: CNAME(12,ACCR)
 5546           %IF ACCESS>=8 %THEN ACCESS=ACCESS-4 %ELSE ACCESS=0
 5547           ->F83 %UNLESS TYPE=TYPEP %AND PREC=PRECP %AND ARR>0
 5548           ->F86 %UNLESS OLDI<=LVL %OR BASE=0 %OR NAM#0
 5549                                          ! GLOBAL == NONOWN LOCAL
 5550           TYPE=0
 5551           NAMEOP(2,ACCR,16,-1)
 5552           R_PTYPE=16_72; R_UPTYPE=0
 5553           R_FLAG=9; R_XB=ACCR
 5554           R_D=-1
 5555           REGISTER(ACCR)=1
 5556           OLINK(ACCR)=ADDR(R)
 5557           ->F81 %UNLESS A(P)=2
 5558           Q=P+1; P=P1
 5559           CNAME(6,0)
 5560           PF1(LSQ,0,TOS,0) %UNLESS R_FLAG=9
 5561           REGISTER(ACCR)=0
 5562           ->COM
 5563  F83:     FAULT2(83,LHNAME,RHNAME); ->F00
 5564  F86:     FAULT2(86,LHNAME,RHNAME); ->F00
 5565  F81:    FAULT2(81,0,LHNAME)
 5566  F00:
 5567           REGISTER(REG)=0
 5568           P=P2; SKIP EXP
 5569           %END
 5570           %ROUTINE CSEXP(%INTEGER REG,MODE)
 5571  !***********************************************************************
 5572  !*       COMPILE A SIGNED EXPRESSION TO REGISTER 'REG' IN MODE 'MODE'  *
 5573  !*       MODE=1 FOR %INTEGER, =2 REAL, =3 LONG,=0 INTEGER %IF POSSIBLE *
 5574  !*       MODE=5 FOR ADDRESS EXPRESSNS(IE LEAVE ANY CONSTANT IN 'ADISP')*
 5575  !***********************************************************************
 5576  %INTEGER EXPHEAD,NOPS,EXPBOT
 5577           EXPHEAD=0; EXPBOT=0
 5578           NOPS=0
 5579           P=P+3
 5580           TORP(EXPHEAD,EXPBOT,NOPS)
 5581  !
 5582           EXPOP(EXPHEAD,REG,NOPS,MODE)
 5583  !         CLEAR LIST(EXPHEAD)
 5584           ASLIST(EXPBOT)_LINK=ASL
 5585           ASL=EXPHEAD
 5586           %END
 5587  %INTEGERFN CONSTEXP(%INTEGER PRECTYPE)
 5588  !***********************************************************************
 5589  !*    COMPILES AN EXPRESSION WHICH SHOULD EVALUATE TO A CONSTANT OF    *
 5590  !*    TYPE 'PRECTYPE'. P AS FOR FN INTEXP.                             *
 5591  !***********************************************************************
 5592  %INTEGER EXPHEAD,EXPBOT,NOPS,RES
 5593        EXPHEAD=0; EXPBOT=0; NOPS=0; RES=0
 5594        TORP(EXPHEAD,EXPBOT,NOPS)
 5595        ->WAYOUT %UNLESS NOPS&16_00040000=0
 5596        EXPOP(EXPHEAD,ACCR,NOPS,16_200+PRECTYPE)
 5597        %IF EXPOPND_FLAG=3 %THEN RES=EXPOPND_XTRA %AND ->WAYOUT
 5598        ->WAYOUT %UNLESS EXPOPND_FLAG<=1
 5599        RES=ADDR(EXPOPND_D)
 5600  WAYOUT:
 5601        %MONITOR %IF RES=0 %AND DCOMP#0
 5602        ASLIST(EXPBOT)_LINK=ASL
 5603        ASL=EXPHEAD
 5604        %RESULT=RES
 5605  %END
 5606  %INTEGERFN INTEXP(%INTEGERNAME VALUE)
 5607  !***********************************************************************
 5608  !*    COMPILES AN EXPRESSION WHICH SHOULD EVALUATE TO A CONSTANT       *
 5609  !*    VALUE RETURNED IN VALUE. RESULT#0 IF FAILED TO EVALUATE          *
 5610  !*    P POINTS TO P(+') IN (+')(OPERNAD)(RESTOFEXPR)                   *
 5611  !***********************************************************************
 5612  %INTEGER EXPHEAD,EXPBOT,NOPS,CODE,SPTYPE,SACC
 5613        EXPHEAD=0; EXPBOT=0; NOPS=0; CODE=0
 5614        SPTYPE=PTYPE; SACC=ACC;           ! CALLED IN DECLARATIONS
 5615        TORP(EXPHEAD,EXPBOT,NOPS)
 5616        %IF NOPS&16_00040000=0 %AND TYPE=1 %START
 5617           EXPOP(EXPHEAD,ACCR,NOPS,16_251)
 5618           CODE=1 %UNLESS EXPOPND_FLAG<=1 %AND EXPOPND_PTYPE=16_51
 5619           VALUE=EXPOPND_D
 5620        %FINISH %ELSE CODE=1 %AND VALUE=1
 5621        ASLIST(EXPBOT)_LINK=ASL
 5622        ASL=EXPHEAD
 5623        ACC=SACC; PTYPE=SPTYPE
 5624        UNPACK
 5625        %RESULT=CODE
 5626  %END
 5627           %ROUTINE TORP(%INTEGERNAME HEAD,BOT,NOPS)
 5628  !***********************************************************************
 5629  !*       CONVERT THE SIGNED EXPRESSION INDEXED BY P INTO REVERSE       *
 5630  !*      POLISH NOTATION. THE REVERSE POLISH LIST IS ADDED TO 'HEAD'    *
 5631  !*      WHICH MAY CONTAIN ANOTHER EXPRESSION. THE NUMBER OF OPERATORS  *
 5632  !*      IS ADDED TO NOPS.                                              *
 5633  !*      N.B. AN INTEGER EXPRESSION IS A SPECIAL CASE OF A REAL EXPRSN  *
 5634  !*    THE TOP 20 BITS OF NOPS ARE USED TO RETURN DETAILS OF THE EXPR   *
 5635  !*    THESE BITS SIGNIFY AS FOLLOWS:-                                  *
 5636  !*    1<<17    CONTAINS VARIABLE OF MORE THAN 32 BITS                  *
 5637  !*    1<<18    NOT CONSTANT EXPRSSN IE CONTAINS AT LEAST 1 VARIABLE    *
 5638  !*    1<<19    COMPLEX IE CONTAINS FN CALL OR NEEDS DR TO EVALUATE     *
 5639  !*    1<<20    CONTAINS THE OPERATOR +                                 *
 5640  !*    1<<21    CONTAINS THE - OPERATOR(INCLUDES UNARY MINUS)           *
 5641  !*    1<<22    CONTAINS OPERATOR !! (INCUDES UNARY NOT)                *
 5642  !*    1<<23-7  CONTAINS OPERATORS !,*,//,/,& RESPECTIVELY              *
 5643  !*    1<28&9   CONTAINS << OR >>                                       *
 5644  !*    1<<30    CONTAINS EXPONETIATION                                  *
 5645  !***********************************************************************
 5646  %SWITCH OPERAND(1:3)
 5647  %CONSTBYTEINTEGERARRAY PRECEDENCE(1:15)=3,3,4,5,5,4,3,3,4,4,5,5,3,5,5;
 5648  %CONSTBYTEINTEGERARRAY OPVAL(1:15)=20,21,27,37,30,24,22,23,25,26,
 5649+                                    28,29,20,37,30;
 5650  %INTEGER RPHEAD,PASSHEAD,SAVEHEAD,REAL,REALOP,COMPLEX,{%C
 5651+          OPERATOR,OPPREC,OPND,C,D,E,RPTYPE,RPINF,BDISP,{%C
 5652+          OPNAME,OPMASK,XTRA,RPBOT,OPSTK,OPPSTK,PASSBOT
 5653  %RECORD(LISTF)%NAME LCELL{(LISTF)
 5654  !
 5655           PASSHEAD=0; RPHEAD=0; SAVEHEAD=0
 5656           REAL=0; REALOP=0; BDISP=0
 5657           RPBOT=0; OPSTK=0; OPPSTK=0
 5658  !
 5659           C=A(P)
 5660           %IF 2<=C<=3 %THEN %START;     ! INITIAL '-' OR '\'
 5661              NOPS=NOPS+1
 5662                                         ! '-' =(11,3)   '\' =(10,5)
 5663              OPSTK=4-C
 5664              OPPSTK=C<<1-1
 5665              OPMASK=1<<(19+C);          ! - %OR !!
 5666           %FINISH %ELSE OPMASK=0
 5667  NEXTOPND:OPND=A(P+1); P=P+2
 5668           COMPLEX=0; XTRA=0
 5669           -> OPERAND(OPND);             ! SWITCH ON OPERAND
 5670  OPERAND(1):                            ! NAME
 5671           OPNAME=A(P)<<8+A(P+1)
 5672           LCELL==ASLIST(TAGS(OPNAME))
 5673           PTYPE=LCELL_S1>>16
 5674           %IF PTYPE=16_FFFF %THEN PTYPE=7;! NAME NOT SET
 5675           TYPE=PTYPE&7; PREC=PTYPE>>4&15
 5676           %IF PTYPE=SNPT %THEN %START
 5677              D=LCELL_S3>>16
 5678              %IF D=38 %AND A(P+2)=2 %THEN %START;    ! PICK OFF NL
 5679                 RPTYPE=0; RPINF=10; PTYPE=16_51; P=P+2; ->SKNAM
 5680              %FINISH
 5681              %IF D=52 %AND A(P+2)=2 %START;! PICK OFF PI
 5682                 RPTYPE=1; PTYPE=16_62; RPINF=16_413243F6
 5683                 XTRA=16_A8885A31
 5684                 P=P+2; REAL=1; ->SKNAM
 5685              %FINISH
 5686              COMPLEX=1
 5687               PTYPE=TSNAME(D); UNPACK
 5688           %FINISH
 5689           %IF PTYPE&16_FF00=16_4000 %AND A(P+2)=2=A(P+3) %AND 1<=TYPE<=2 %THEN %START; ! CONST VAR
 5690              LCELL_S1=LCELL_S1!16_8000;  ! SET USED BIT
 5691              RPINF=LCELL_S2; XTRA=LCELL_S3
 5692              RPTYPE=1; PTYPE=PTYPE&255
 5693              %IF TYPE=1 %AND PREC<=5 %AND 16_FFFE0000<=RPINF<=16_1FFFF %THEN RPTYPE=0 %AND PTYPE=16_51
 5694              %IF PREC=7 %THEN RPTYPE=3
 5695              REAL=1 %IF TYPE=2
 5696              P=P+2; ->SKNAM
 5697           %FINISH
 5698           XTRA=OPNAME
 5699           %IF PTYPE&16_3F00#0 %OR PARMCHK=1 %OR PREC<5 %THEN COMPLEX=1 %AND XTRA=-1
 5700           OPMASK=OPMASK!(COMPLEX<<19)
 5701           %IF A(P+2)#2 %OR A(P+3)#2 %THEN XTRA=-1;! XTRA=NAME FOR LOCAL SCALRS ONLY
 5702           %IF TYPE=3 %THEN %START
 5703              D=P; KFORM=LCELL_S3&16_FFFF
 5704              C=COPY RECORD TAG(E); P=D;
 5705              COMPLEX=1 %UNLESS E=1 %AND 1<=TYPE<=2 %AND NAM=ARR=0 %AND PREC#3
 5706           %FINISH
 5707           %IF PREC>=6 %THEN OPMASK=OPMASK!1<<17;! MORE THAN 32 BITS
 5708           RPTYPE=2; RPINF=P; PTYPE=16_51 %IF PTYPE=7
 5709           %IF TYPE=5 %THEN FAULT2(76,0,OPNAME) %AND RPTYPE=0 %AND PTYPE=16_51
 5710           %IF TYPE=2 %THEN REAL=1
 5711           P=P+2
 5712  SKNAM:   %IF A(P)=2 %THEN P=P+1 %ELSE SKIP APP
 5713           %IF A(P)=1 %THEN P=P+3 %AND ->SKNAM
 5714           P=P+2
 5715  INS:     %IF RPTYPE=2 %THEN OPMASK=OPMASK!1<<18
 5716           BINSERT(RPHEAD,RPBOT,PTYPE<<16!COMPLEX<<8!RPTYPE,RPINF,XTRA)
 5717           -> OP
 5718  OPERAND(2):                            ! CONSTANT
 5719           PTYPE=A(P); D=PTYPE>>4
 5720           C=PTYPE&7
 5721           %IF D=4 %THEN %START
 5722              RPINF=FROM AR2(P+1)
 5723              PTYPE=16_51
 5724           %FINISH %ELSE RPINF=FROM AR4(P+1)
 5725           REAL=1 %IF C=2; RPTYPE=1
 5726           %IF D=6 %THEN XTRA=FROM AR4(P+5)
 5727           %IF C=5 %THEN %START;      ! STRING CONSTANT
 5728              FAULT2(77,0,0); RPINF=1; RPTYPE=0
 5729              P=P+A(P+5)+7; PTYPE=16_51
 5730           %FINISH %ELSE %START
 5731              %IF D=7 %THEN XTRA=ADDR(A(P+1)) %AND RPTYPE=3
 5732              %IF PTYPE=16_51 %AND 16_FFFE0000<=RPINF<=16_1FFFF %THEN RPTYPE=0
 5733              P=P+2+BYTES(D)
 5734           %FINISH; -> INS
 5735  OPERAND(3):                            ! SUB EXPRESSION
 5736           PASSHEAD=0; PASSBOT=0
 5737           P=P+3
 5738           TORP(PASSHEAD,PASSBOT,NOPS)
 5739           REAL=1 %IF TYPE=2
 5740  !         CONCAT(RPHEAD,PASSHEAD)
 5741           %IF RPBOT=0 %THEN RPHEAD=PASSHEAD %ELSE ASLIST(RPBOT)_LINK=PASSHEAD
 5742           RPBOT=PASSBOT
 5743           P=P+1
 5744  OP:                                     ! DEAL WITH OPERATOR
 5745           -> EOE %IF A(P-1)=2;           ! EXPR FINISHED
 5746           OPERATOR=A(P)
 5747  !
 5748  ! THE STRING OPERATOR '.' CAUSES CHAOS IN AN ARITHMETIC EXPRSN
 5749  ! SO FAULT IT AND CHANGE IT TO THE INNOCUOUS '+'
 5750  !
 5751           %IF OPERATOR=CONCOP %THEN FAULT2(78,0,0)
 5752           OPPREC=PRECEDENCE(OPERATOR)
 5753           OPERATOR=OPVAL(OPERATOR)
 5754           %IF OPERATOR=26 %OR OPERATOR=30 %THEN REAL=1
 5755           NOPS=NOPS+1
 5756  !
 5757  ! UNLOAD THE OPERATOR STACK OF ALL OPERATORS WHOSE PRECEDENCE IS
 5758  ! NOT LOWER THAN THE CURRENT OPERATOR. AN EMPTY STACK GIVES'-1'
 5759  ! AS PRECEDENCE.
 5760  !
 5761           %WHILE OPPREC<=OPPSTK&31 %CYCLE
 5762              BINSERT(RPHEAD,RPBOT,OPSTK&31+9,0,0)
 5763              OPSTK=OPSTK>>5; OPPSTK=OPPSTK>>5
 5764           %REPEAT
 5765  !
 5766  ! THE CURRENT OPERATOR CAN NOW BE STORED
 5767  !
 5768           OPSTK=OPSTK<<5!(OPERATOR-9)
 5769           OPPSTK=OPPSTK<<5!OPPREC
 5770           %IF OPERATOR>=31 %THEN OPERATOR=30
 5771           OPMASK=OPMASK!(1<<OPERATOR)
 5772           -> NEXTOPND
 5773  EOE:                                   ! END OF EXPRESSION
 5774                                         ! EMPTY REMAINING OPERATORS
 5775           %WHILE OPSTK#0 %CYCLE
 5776              BINSERT(RPHEAD,RPBOT,OPSTK&31+9,0,0)
 5777              OPSTK=OPSTK>>5
 5778           %REPEAT
 5779           PTYPE=REAL+1
 5780           TYPE=PTYPE
 5781  !         CONCAT(RPHEAD,HEAD)
 5782           %IF HEAD=0 %THEN BOT=RPBOT %ELSE ASLIST(RPBOT)_LINK=HEAD
 5783           HEAD=RPHEAD;                ! HEAD BACK TO TOP OF LIST
 5784           NOPS=NOPS!OPMASK
 5785           %END
 5786           %ROUTINE EXPOP(%INTEGER INHEAD,REG,NOPS,MODE)
 5787  !***********************************************************************
 5788  !*    EVALUATE A LIST OF OPERAND AND'NOPS' OPERATORS AND LEAVE         *
 5789  !*    THE RESULT IN REG                                                *
 5790  !*    INHEAD HOLDS THE LIST THE BOTTOM BYTE OF STREAM 1 DEFINES THE    *
 5791  !*    ENTRY AS FOLLOWS:-                                               *
 5792  !*       0 = SHORT (INTEGER) CONSTANT <18 BITS --S2=CONSTANT           *
 5793  !*       1 = OTHER CONSTANT    S2 (+S3 IF NEEDED) = CONSTANT           *
 5794  !*       2 = VARIABLE S2 POINT TO AR ENTRY FOR NAME&SUBSCRIPTS         *
 5795  !*      (3 = DOPE VECTOR ITEM IF NEEDED)                               *
 5796  !*      (4 = CONDITONAL EXPRESSION AS IN ALGOL)                        *
 5797  !*       7 = INTERMEDIATE RESULT UNDER LNB  S2=DISPLCMNT FROM LNB      *
 5798  !*       8 = INTERMEDIATE RESULT STACKED                               *
 5799  !*       9 = INTERMEDIATE RESULT IN A REGISTER S2 = REG                *
 5800  !*                                                                     *
 5801  !*       10-19 = UNARY OPERATOR S2=OP S3 =EXTRA                        *
 5802  !*       20 UP = BINARY OPERATOR                                       *
 5803  !*                                                                     *
 5804  !*    ARRAY MCINST HOLD THE OPCODES CORRESPONDING TO THE OPERATORS:-   *
 5805  !*       TOP BYTE = REAL FORWARD FORM                                  *
 5806  !*       2ND BYTE = REAL REVERSE FORM                                  *
 5807  !*       3RD BYTE = INTEGER FORWARD FORM                               *
 5808  !*       BTM BYTE = INTEGER REVERSE FORM                               *
 5809  !*       MODE HAS TYPE & PREC REQD +256 BIT IF NO RESULT REQD          *
 5810  !***********************************************************************
 5811  %ROUTINESPEC CTOP(%INTEGERNAME A)
 5812  %ROUTINESPEC VMY
 5813  %ROUTINESPEC VMY1
 5814  %ROUTINESPEC CHOOSE(%INTEGERNAME I)
 5815  %ROUTINESPEC PUT
 5816  %ROUTINESPEC STARSTAR
 5817  %ROUTINESPEC REXP
 5818  %ROUTINESPEC LOAD(%RECORD(RD)%NAME OP,%INTEGER REG,MODE)
 5819  %ROUTINESPEC FLOAT(%RECORD(RD)%NAME OPND,%INTEGER OTHERPTYPE)
 5820  %ROUTINESPEC COERCET(%RECORD(RD)%NAME OP1,OP2,%INTEGER MODE)
 5821  %ROUTINESPEC COERCEP(%RECORD(RD)%NAME OP1,OP2)
 5822  %ROUTINESPEC LENGTHEN(%RECORD(RD)%NAME OP)
 5823  %ROUTINESPEC SHORTEN (%RECORD(RD)%NAME OP)
 5824  !
 5825  %INTEGERARRAY OPERAND(1:2),STK(0:99)
 5826  %RECORD(LISTF)%NAME LIST{(LISTF)
 5827  %RECORD(RD)%name OPND1,OPND2,OPND {(RD)
 5828  !
 5829  %INTEGER C,D,KK,JJ,OPCODE,COMM,XTRA,PP,PT,JJJ,LOADREG,EVALREG,STPTR,CONSTFORM,CONDFORM,SAVEP
 5830  %CONSTINTEGERARRAY MCINST(10:37)=16_8E8E,16_F4F4E4E4,16_A8A8,
 5831+                                  16_F4F4E4E4,0(6),
 5832+                                  16_F0F0E0E0,16_F2F4E2E4,
 5833+                                  16_8E8E,16_8C8C,16_FAFAEAEA,
 5834+                                  16_AAAC,16_BABC0000,
 5835+                                  16_8A8A,16_C800(2),16_FA000000,
 5836+                                  16_F6F6E6E6,16_00F600E6,
 5837+                                  16_2C002C00,16_02000200,
 5838+                                  16_48004800(2),16_EA00;
 5839  %CONSTBYTEINTEGERARRAY CORULES(20:37)=16_1F(2),16_11(2),16_1F,16_11,
 5840+                                        16_12,16_11,1,1,0,16_1F(2),
 5841+                                       0(4),1;
 5842  %CONSTBYTEINTEGERARRAY FCOMP(1:28)={%C
 5843+                                         8,10,2,7,12,4,7,
 5844+                                         8,12,4,7,10,2,7,
 5845+                                         16,34,17,32,33,18,32,
 5846+                                         16,33,18,32,34,17,32;
 5847  %SWITCH SW(10:37)
 5848  !
 5849           STPTR=0; CONSTFORM= MODE&512
 5850           CONDFORM=MODE&256
 5851           SAVEP=P
 5852           EVALREG=ACCR;                  ! EVALUATE IN ACC UNLESS
 5853           %IF REG=BREG %AND NOPS&16_7EC20000=0 %THEN EVALREG=BREG
 5854                                          ! ONLY '+' %AND '*' PRESENT
 5855                                          ! NOTHING >32 BITS
 5856  NEXT:    LIST==ASLIST(INHEAD)
 5857           C=LIST_S1; XTRA=LIST_S2
 5858           JJ=C&255; D=INHEAD
 5859           INHEAD=LIST_LINK
 5860           -> OPERATOR %IF JJ>=10
 5861  !
 5862  ! ANY OPERAND WHICH MAY NEED DR OR B OR ACC IN THEIR EVALUATION
 5863  ! EG FUNCTIONS,ARRAY ELEMENTS ETC ARE FETCHED AND STACKKED FIRST
 5864  !
 5865           OPERAND(1)=ADDR(ASLIST(D))
 5866  {        OPND1==ASLIST(D)  { <---   format mismatch!
 5867           OPND1==RECORD(ADDR(ASLIST(D)))  { force format.
 5868  {
 5869  {  This looks weird!
 5870  {
 5871  {  %RECORDFORMAT RD(%BYTEINTEGER UPTYPE,PTYPE,XB,FLAG,%C
 5872  {  %INTEGER D,XTRA)
 5873  {
 5874  {  %RECORDFORMAT LISTF(%INTEGER S1,S2,S3,LINK)
 5875  {
 5876  {  %RECORDARRAY ASLIST(0:ASL)(LISTF)
 5877  {
 5878  {  %RECORDNAME OPND1,OPND2,OPND (RD)
 5879  {
 5880           %IF OPND1_FLAG=2 %AND OPND1_XB#0 %THEN LOAD(OPND1,EVALREG,0)
 5881           STK(STPTR)=OPERAND(1)
 5882           STPTR=STPTR+1
 5883           ABORT %IF STPTR>99
 5884  ANYMORE:
 5885           ->NEXT %UNLESS INHEAD=0 %OR MODE=100
 5886           -> FINISH
 5887  OPERATOR:
 5888           %IF JJ<19 %THEN KK=1 %ELSE KK=2; ! UNARY OR BINARY
 5889           %CYCLE KK=KK,-1,1
 5890              STPTR=STPTR-1
 5891              C=STK(STPTR)
 5892              OPERAND(KK)=C
 5893           %REPEAT
 5894           OPCODE=MCINST(JJ)
 5895           COMM=1
 5896           OPND1 == RECORD(OPERAND(1))
 5897           OPND2 == OPND1
 5898           %IF JJ>=19 %THEN %START
 5899              OPND2==RECORD(OPERAND(2))
 5900              C=CORULES(JJ)
 5901              %IF C&15#0 %THEN COERCET(OPND1,OPND2,C&15)
 5902              %IF C>>4#0 %THEN COERCEP(OPND1,OPND2)
 5903           %FINISH
 5904           %IF JJ>19 %START
 5905              CHOOSE(COMM)
 5906              OPND1==RECORD(OPERAND(COMM))
 5907              OPND2==RECORD(OPERAND(3-COMM))
 5908           %FINISH
 5909           PTYPE=OPND1_PTYPE; TYPE=PTYPE&7
 5910           %IF TYPE=1 %THEN OPCODE=OPCODE&16_FFFF %ELSE OPCODE=OPCODE>>16;! INTEGER OR REAL FORMS
 5911           %IF 2#OPND1_FLAG<4 %AND 2#OPND2_FLAG<4 %THEN CTOP(JJ)
 5912           -> STRES %IF JJ=0;            ! CTOP CARRIED OUT
 5913           -> SW(JJ)
 5914  SW(10):                                !  \
 5915           LOAD(OPND1,EVALREG,2)
 5916           FAULT(24,0) %UNLESS TYPE=1 %OR TYPE=7
 5917           PSF1(OPCODE&255,0,-1);         ! NEQ -1
 5918           GRUSE(EVALREG)=0
 5919  SUSE:    OLINK(EVALREG)=OPERAND(COMM)
 5920  STRES:   STK(STPTR)=OPERAND(COMM)
 5921           STPTR=STPTR+1
 5922           ->ANYMORE
 5923  SW(11):                                ! NEGATE
 5924           LOAD(OPND1,EVALREG,2)
 5925           %IF EVALREG=BREG %THEN PSF1(SLB,0,0) %AND PF1(SBB,0,TOS,0) %ELSE PSF1(OPCODE&255,0,0); ! IRSB 0 OR RRSB 0
 5926           GRUSE(EVALREG)=0
 5927           -> SUSE
 5928  SW(12):                                ! FLOAT
 5929           ABORT
 5930  SW(13):                                 ! ABS
 5931           LOAD(OPND1,EVALREG,2);             ! OPERAND TO ACC
 5932           %IF TYPE=2 %THEN C=2 %ELSE C=6
 5933           PF3(JAF,C,0,3);                ! JAF *+3 ON ACC<0
 5934           PSF1(OPCODE&255,0,0);          ! IRSB 0 OR RRSB 0
 5935           GRUSE(EVALREG)=0
 5936           ->SUSE
 5937  SW(14):                                 ! STRETCH
 5938           ABORT
 5939  SW(20):                                 ! ADD
 5940           %IF TYPE=1 %AND GRUSE(EVALREG)=10 %AND OPND1_FLAG=2 %AND OPND2_FLAG=0 %AND REGISTER(EVALREG)=0 %START
 5941              P=OPND1_D; D=GRINF1(EVALREG)
 5942              %IF FROMAR2(P)=D&16_FFFF %AND A(P+2)=2=A(P+3) %START
 5943                 %IF EVALREG=ACCR %THEN C=IAD %ELSE C=ADB
 5944                 PSF1(C,0,OPND2_D-D>>16)
 5945                 GRINF1(EVALREG)=D&16_FFFF!OPND2_D<<16
 5946                 REGISTER(EVALREG)=1
 5947                 OPND1_FLAG=9; OPND1_XB=EVALREG<<4
 5948                 OPND1_D=0; ->SUSE
 5949              %FINISH
 5950           %FINISH
 5951  BINOP:   LOAD(OPND1,EVALREG,2);
 5952           LOAD(OPND2,EVALREG,1)
 5953           PUT; -> SUSE
 5954  SW(21):                                 ! SUBTRACT
 5955           ->BINOP
 5956  SW(22):                                 ! EXCLUSIVE OR
 5957  SW(23):                                 ! OR
 5958  SW(27):                                 ! AND
 5959           ->BINOP %IF TYPE=1
 5960  F24:     FAULT(24,0) %UNLESS TYPE=7
 5961           JJ=20; OPCODE=MCINST(20)
 5962           ->BINOP;                       ! CHANGE OPN TO +
 5963  SW(28):                                 ! SRL
 5964           %IF OPND2_FLAG=0 %THEN OPND2_D=-OPND2_D %ELSE %START
 5965              LOAD(OPND2,EVALREG,2);          ! OPND TO ACC
 5966              PSF1(IRSB,0,0);             ! AND NEGATE IT
 5967              GRUSE(EVALREG)=0
 5968           %FINISH
 5969  SW(29):                                 ! SLL
 5970           %IF OPND2_PTYPE>>4=6 %THEN SHORTEN(OPND2);! LONINT TO INT
 5971           -> BINOP
 5972  SW(24):                                ! MULT
 5973           -> BINOP
 5974  SW(25):                                 ! INTEGER DIVISION
 5975           ->F24 %UNLESS TYPE=1
 5976           -> BINOP
 5977  SW(26):                                 ! NORMAL DIVISION
 5978           -> BINOP
 5979  SW(30):                                 ! EXP IN REAL EXPRSN
 5980           %IF OPND1_PTYPE&7=1 %THEN FLOAT(OPND1,0)
 5981           %IF OPND2_PTYPE&7=1 %THEN STARSTAR %AND ->SUSE
 5982                                          ! REAL**REAL BY SUBROUTINE
 5983           REXP; COMM=2; ->SUSE
 5984  SW(37):                                 ! EXP IN INTEGER CONTEXT
 5985           STARSTAR; -> SUSE
 5986  SW(31):                                 ! COMPARISONS
 5987  SW(32):                                 ! DSIDED COMPARISONS 
 5988           PTYPE=OPND1_PTYPE
 5989           ->Z1 %IF OPND1_FLAG<=1 %AND OPND1_D=0 %AND JJ=31 %AND (OPND1_XTRA=0 %OR PTYPE>>4=5);! INT 0 OR LONGINT 0
 5990           -> Z2 %IF OPND2_FLAG<=1 %AND OPND2_D=0 %AND (OPND2_XTRA=0 %OR OPND2_PTYPE>>4=5)
 5991           LOAD(OPND1,EVALREG,2)
 5992           LOAD(OPND2,EVALREG,1)
 5993           PUT
 5994           REGISTER(EVALREG)=0
 5995           BFFLAG=COMM-1;                ! NOTE BACKWARDS OR FORWARDS
 5996           MASK=FCOMP(XTRA+7*BFFLAG)
 5997           COMM=2; ->STRES;              ! 2ND OPERAND MAY BE NEEDED IN
 5998                                         ! DOUBLE SIDED AND IS THEREFORE
 5999                                         ! TAKEN AS THE 'RESULT'
 6000  Z1:      COMM=3-COMM
 6001  Z2:      OPND==RECORD(OPERAND(COMM))
 6002           C=EVALREG; D=EVALREG!!7
 6003           %IF OPND_FLAG=2 %AND GRUSE(D)=9 %AND (GRINF1(D)&16_FFFF=OPND_XTRA %OR GRINF1(D)>>16=OPND_XTRA) %THEN C=D
 6004           LOAD(OPND,C,2)
 6005           REGISTER(C)=0
 6006           MASK=FCOMP(XTRA+7*COMM+7)
 6007           %IF TYPE=1 %THEN MASK=MASK+4
 6008           %IF C=BREG %THEN MASK=MASK+8
 6009           COMM=2; ->STRES
 6010  SW(33):                                 ! SPECIAL MH FOR ARRAY ACCESS
 6011           C=OPND2_D>>24;                 ! CURRENT DIMENSION
 6012           D=OPND2_D>>16&31;              ! TOTAL NO OF DIMENSIONS
 6013           %IF D=1 %THEN VMY1 %ELSE VMY
 6014           %IF OPND1_FLAG>1 %THEN OLINK(LOADREG)=OPERAND(COMM);!  IF RESULT THEN PROTECT IT
 6015           %IF C=1 %THEN ->STRES
 6016           ->ANYMORE
 6017  SW(34):                                   ! ->LAB MASKS AND LAB AS OPND2
 6018                                            ! OPND1 MIDDLE OF D-SIDED
 6019           ABORT
 6020  SW(35):                                   ! ASSIGN(=)
 6021  SW(36):                                 ! ASSIGN(<-)
 6022           PT=OPND2_PTYPE; PP=OPND2_D
 6023           %IF PT&7=1 %AND OPND1_PTYPE&7=2 %THEN  FAULT(24,0)
 6024           %IF PT&7=2 %AND OPND1_PTYPE&7=1 %THEN FLOAT(OPND1,OPND2_PTYPE)
 6025           LOAD(OPND1,EVALREG,2);             ! RHS TO ACC
 6026           REGISTER(EVALREG)=2
 6027           C=PT>>4; D=OPND1_PTYPE>>4
 6028           %IF C<5 %THEN C=5
 6029           %IF D<5 %THEN D=5
 6030           LENGTHEN(OPND1) %AND D=OPND1_PTYPE>>4 %WHILE D<C
 6031           %WHILE (C<D %AND TYPE=1 %AND JJ#36) %OR C<D-1 %CYCLE
 6032              SHORTEN(OPND1)
 6033              D=OPND1_PTYPE>>4
 6034           %REPEAT
 6035           P=PP; CNAME(1,0);              ! STORE CALL
 6036           D=DISP; C=ACCESS; JJJ=AREA;    ! SAVE INFO FOR STORE
 6037           KK=PREC
 6038           LOAD(OPND1,EVALREG,2);             ! IN CASE STACKED
 6039           %IF JJ=36 %AND TYPE=1 %START
 6040              %IF 3<=XTRA<=4 %THEN PF1(AND,0,0,(-1)>>(8*(6-XTRA))) %AND GRUSE(ACCR)=0
 6041              %IF KK<=5 %AND PREC=6 %THEN PSF1(MPSR,0,17) %AND GRUSE(ACCR)=0
 6042           %FINISH
 6043           %IF TYPE=2 %AND KK<PREC %THEN KK=STUH %ELSE KK=ST
 6044           %IF EVALREG=BREG %THEN KK=STB
 6045           PSORLF1(KK,C,JJJ,D)
 6046           %IF (C&1=0 %AND STNAME>0) %OR (C=3 %AND STNAME>>16>0) %THEN NOTE ASSMENT(EVALREG,JJ-33,STNAME)
 6047           %IF C>=2 %AND JJJ#7 %START;    ! DR WILL BE LOADED SY STORE
 6048              %IF STNAME>0 %THEN GRUSE(DR)=7 %AND GRINF1(DR)=STNAME&16_FFFF %ELSE GRUSE(DR)=0
 6049           %FINISH
 6050           %IF KK=STUH %THEN GRUSE(ACCR)=0
 6051           COMM=1; ->STRES
 6052  FINISH:  C=STK(STPTR-1)
 6053           OPERAND(1)=C
 6054           OPND1==RECORD(C)
 6055           %IF OPND1_PTYPE>>4&15<5 %THEN OPND1_PTYPE=OPND1_PTYPE&16_F!16_50;! BITS&BYTES->INTEGERS
 6056           %IF CONDFORM=0 %START;         ! IN CONDS ONLY CC MATTERS
 6057                                          ! SKIP GETIING OPND INRIGHT FORM
 6058                                          ! AND IN THE RIGHT REGISTER
 6059              D=MODE>>4&7; D=5 %IF D<5
 6060              %IF MODE&7=2 %AND OPND1_PTYPE&7=1 %THEN FLOAT(OPND1,D<<4)
 6061              SHORTEN(OPND1) %WHILE D<OPND1_PTYPE>>4
 6062              LENGTHEN(OPND1) %WHILE D>OPND1_PTYPE>>4 
 6063              %IF CONSTFORM=0 %OR 2<=OPND1_FLAG#3 %THEN LOAD(OPND1,REG,2)
 6064           %FINISH
 6065           EXPOPND=OPND1;                 ! SET RESULT RECORD
 6066           PTYPE=OPND1_PTYPE
 6067           TYPE=PTYPE&7; PREC=PTYPE>>4
 6068           %IF TYPE=2 %AND MODE&7=1 %THEN FAULT(24,0)
 6069           %IF OPND1_FLAG=9 %THEN REGISTER(OPND1_XB>>4)=0
 6070           P=SAVEP
 6071           %RETURN
 6072  !
 6073  %ROUTINE CHOOSE(%INTEGERNAME CHOICE)
 6074  %RECORD (RD) %NAME OPND1,OPND2{(RD)
 6075           OPND1==RECORD(OPERAND(1))
 6076           OPND2==RECORD(OPERAND(2))
 6077           CHOICE=1
 6078           %RETURN %IF JJ=21 %AND EVALREG=BREG;! NO REVERSE SUBTRACT B
 6079           CHOICE=2 %IF OPCODE&16_FF00FF00=0 %OR (OPCODE&16_FF00FF#0 %AND (OPND2_FLAG=9 %OR(OPND2_FLAG=2 %AND GRUSE(EVALREG)=9 %AND GRINF1(EVALREG)=OPND2_XTRA>0)))
 6080           %END
 6081  %ROUTINE LOAD(%RECORD (RD) %NAME OPND,%INTEGER REG,MODE)
 6082  !***********************************************************************
 6083  !*       LOAD OPERAND OPND AS DIRECTED BY MODE TO REGISTER REG         *
 6084  !*       MODE=0   LEAVE IN STORE IF POSSIBLE                           *
 6085  !*       MODE=1 LEAVE IN STORE IF SUITABLE FOR RX INSTRUCTIONS         *
 6086  !*       MODE=2 LOAD TO REGISTER REGARDLESS                            *
 6087  !***********************************************************************
 6088  %INTEGER K,KK
 6089  {%RECORDSPEC OPND(RD)
 6090  %SWITCH SW(0:9)
 6091           K=OPND_FLAG
 6092          %RETURN %UNLESS MODE=2 %OR K=2 %OR(K<=3 %AND MODE=1)
 6093           PTYPE=OPND_PTYPE
 6094           TYPE=PTYPE&15
 6095           PREC=PTYPE>>4
 6096           %IF K<0 %OR K>9 %THEN ABORT
 6097           ->SW(K)
 6098  SW(0):LITCONST:                        ! CONSTANT < 18 BITS
 6099           AREA=0; ACCESS=0
 6100           %IF PREC<=5 %THEN DISP=OPND_D %ELSE %START
 6101              DISP=OPND_XTRA
 6102              ABORT %UNLESS (DISP>=0 %AND OPND_D=0) %OR (DISP<0 %AND OPND_D=-1)
 6103           %FINISH
 6104           %IF MODE=2 %THEN %START;       ! FETCH TO REG
 6105              %IF GRUSE(REG)&255=5=PREC %AND GRINF1(REG)=DISP %START
 6106                 %IF REGISTER(REG)#0 %THEN BOOT OUT(REG)
 6107              %FINISHELSE GET IN ACC(REG,BYTES(PREC)>>2,ACCESS,AREA,DISP)
 6108              %IF PREC<=5 %THEN GRUSE(REG)=5 %AND GRINF1(REG)=DISP
 6109              ->LDED
 6110           %FINISH
 6111           %IF PREC=3 %THEN OPND_PTYPE=16_51;  ! CONSTBYTEINTEGERS AGAIN
 6112           OPND_FLAG=7; OPND_XB=AREA<<4!ACCESS
 6113           OPND_D=DISP
 6114           %RETURN
 6115  SW(1):                                  ! LONG CONSTANT
 6116           %IF OPND_D=0=OPND_XTRA %AND PREC<=6 %THEN ->LITCONST
 6117  SW(3):                                  ! 128 BIT CONSTANT
 6118           %IF PREC=7 %THEN KK=OPND_XTRA %ELSE KK=ADDR(OPND_D)
 6119           STORE CONST(DISP,BYTES(PREC),KK)
 6120           %IF MODE#2 %THEN %START
 6121              OPND_FLAG=7; OPND_XB=PC<<4
 6122              OPND_D=DISP; %RETURN
 6123           %FINISH
 6124           %IF GRUSE(REG)&255=6 %AND GRINF1(REG)=DISP %THEN %START
 6125              %IF REGISTER(REG)#0 %THEN BOOT OUT (REG)
 6126           %FINISH %ELSE GET IN ACC(REG,BYTES(PREC)>>2,0,PC,DISP)
 6127           GRUSE(REG)=6; GRINF1(REG)=DISP
 6128           ->LDED
 6129  SW(2):                                  ! NAME
 6130           P=OPND_D
 6131           -> LOAD %IF MODE=2 %OR OPND_XB#0;! COMPLEX NAMES MUST BE LOADED
 6132           CNAME(5,REG)
 6133           ->LDED %IF NEST>=0
 6134           AREA=-1
 6135           AREA=AREA CODE
 6136           OPND_PTYPE<-PTYPE
 6137           OPND_FLAG=7
 6138           OPND_XB=AREA<<4!ACCESS
 6139           OPND_D=DISP; %RETURN
 6140  LOAD:    CNAME(2,REG)
 6141  LDED:    REGISTER(REG)=1;          ! CLAIM THE REGISTER
 6142           OLINK(REG)=ADDR(OPND)
 6143           %IF PREC<5 %THEN OPND_PTYPE=OPND_PTYPE&15!16_50
 6144           OPND_FLAG=9; OPND_D=0; OPND_XB=REG<<4
 6145           %IF REG=BREG %AND REGISTER(ACCR)&1#0 %THEN REGISTER(BREG)=2
 6146           %RETURN
 6147  SW(4):                                  ! CONDITIONAL EXPRESSION
 6148  SW(5):                                  ! UNASSIGNED
 6149  SW(6):                                  ! UNASSIGNED
 6150           ABORT
 6151  SW(7):                                  ! I-R IN A STACK FRAME
 6152           AREA=OPND_XB>>4
 6153           ACCESS=OPND_XB&15
 6154           DISP=OPND_D
 6155  PICKUP:  GET IN ACC(REG,BYTES(PREC)>>2,ACCESS,AREA,DISP)
 6156           ->LDED
 6157  SW(8):                                  ! I-R THAT HAS BEEN STACKED
 6158           AREA=TOS; ACCESS=0; DISP=0; ->PICK UP
 6159  SW(9):                                  ! I-R IN A REGISTER
 6160           %IF OPND_XB>>4=REG %THEN -> LDED
 6161           %IF REG#ACCR %THEN %START
 6162              BOOT OUT(BREG) %UNLESS REGISTER(BREG)=0
 6163              PF1(ST,0,BREG,0)
 6164           %FINISH %ELSE GET IN ACC(ACCR,1,0,BREG,0)
 6165           REGISTER(OPND_XB>>4)=0
 6166           OPND_XB=REG<<4; GRUSE(REG)=0
 6167           REGISTER(REG)=1; OLINK(REG)=ADDR(OPND)
 6168           %END
 6169  %ROUTINE PUT
 6170  !***********************************************************************
 6171  !*       THIS ROUTINE PLANTS CODE TO PERFORM THE BASIC                 *
 6172  !*       OPERATION DEFINED BY OPND1,OPND2 & OPCODE                     *
 6173  !***********************************************************************
 6174  %INTEGER CODE,OCODE
 6175           CODE=OPCODE
 6176           %IF COMM=1 %THEN CODE=CODE>>8
 6177           CODE=CODE&255; OCODE=CODE
 6178           %IF EVALREG=BREG %THEN CODE=CODE-16_C0
 6179           ABORT %UNLESS OPND1_FLAG=9
 6180           PSORLF1(CODE,OPND2_XB&15,OPND2_XB>>4,OPND2_D)
 6181           %IF OCODE=IAD %AND GRUSE(EVALREG)=9 %AND OPND2_XB=0 %AND OPND2_D<4095 %AND GRINF1(EVALREG)>>16=0 %THEN %START
 6182              GRUSE(EVALREG)=10
 6183              GRINF1(EVALREG)=GRINF1(EVALREG)&16_FFFF!OPND2_D<<16
 6184           %FINISH %ELSE %START
 6185              GRUSE(EVALREG)=0 %UNLESS 31<=JJ<=32
 6186           %FINISH
 6187           OLINK(EVALREG)=OPERAND(COMM)
 6188           %END
 6189  %ROUTINE FLOAT(%RECORD(RD)%NAME OPND,%INTEGER OTHERPTYPE)
 6190  !***********************************************************************
 6191  !*       PLANT CODE TO CONERT OPERAND FROM FIXED TO FLOATING           *
 6192  !***********************************************************************
 6193  {%RECORDSPEC OPND(RD)
 6194           %IF OPND_FLAG<=1 %THEN %START
 6195              CVALUE=OPND_D
 6196              OPND_D=INTEGER(ADDR(CVALUE))
 6197              OPND_XTRA=INTEGER(ADDR(CVALUE)+4)
 6198              OPND_FLAG=1
 6199           %FINISH %ELSE %START
 6200              LOAD(OPND,ACCR,2)
 6201              %IF OTHERPTYPE&16_F0=16_70 %AND OPND_PTYPE&16_F0<=16_50 %THEN PSF1(IMYD,0,1) %AND OPND_PTYPE=OPND_PTYPE&15!16_60
 6202              PSF1(FLT,0,0)
 6203              GRUSE(ACCR)=0
 6204           %FINISH
 6205           OPND_PTYPE=OPND_PTYPE+16_11
 6206           TYPE=2
 6207  %END
 6208  %ROUTINE COERCET(%RECORD(RD)%NAME OPND1,OPND2,%INTEGER MODE)
 6209  !***********************************************************************
 6210  !*         MODE=1 BOTH OPERANDS INTEGER ELSE ERROR                     *
 6211  !*         MODE=2 FORCE BOTH OPERAND TO BE OF TYPE REAL                *
 6212  !*         MODE=15  BOTH OPERANDS TO BE OF LAGEST TYPE                 *
 6213  !***********************************************************************
 6214  {%RECORDSPEC OPND1(RD)
 6215  {%RECORDSPEC OPND2(RD)
 6216  %INTEGER PT1,PT2
 6217           PT1=OPND1_PTYPE&7
 6218           PT2=OPND2_PTYPE&7
 6219           %IF (MODE=1 %OR MODE=15) %AND PT1=1=PT2 %THEN %RETURN
 6220           %IF MODE=1 %THEN FAULT(24,0) %AND %RETURN
 6221           %IF PT1=1 %THEN FLOAT(OPND1,OPND2_PTYPE)
 6222           %IF PT2=1 %THEN FLOAT(OPND2,OPND1_PTYPE)
 6223  %END
 6224  %ROUTINE COERCEP(%RECORD(RD)%NAME OPND1,OPND2)
 6225  !***********************************************************************
 6226  !*       FORCE BOTH OPERAND TO THE SAME PRECISION BEFORE OPRNTN        *
 6227  !***********************************************************************
 6228  {%RECORDSPEC OPND1(RD)
 6229  {%RECORDSPEC OPND2(RD)
 6230  %INTEGER PREC1,PREC2
 6231           PREC1=OPND1_PTYPE>>4
 6232           PREC2=OPND2_PTYPE>>4
 6233           %WHILE PREC1<PREC2 %CYCLE
 6234              LENGTHEN(OPND1)
 6235              PREC1=OPND1_PTYPE>>4
 6236           %REPEAT
 6237  !
 6238           %WHILE PREC2<PREC1 %CYCLE
 6239              LENGTHEN(OPND2)
 6240              PREC2=OPND2_PTYPE>>4
 6241           %REPEAT
 6242  %END
 6243  %ROUTINE LENGTHEN(%RECORD(RD)%NAME OPND)
 6244  !***********************************************************************
 6245  !*       INCREASE OPND PRECISION BY ONE SIZE AT COMPILE TIME IF POSS   *
 6246  !***********************************************************************
 6247  {%RECORDSPEC OPND(RD)
 6248  %INTEGER TP,PR
 6249           TP=OPND_PTYPE&7
 6250           PR=OPND_PTYPE>>4
 6251           %IF OPND_FLAG<=1 %AND PR<=4+TP %START;  ! LENGTHEN CONSTANT
 6252              %IF TP=1 %AND OPND_FLAG<=1 %START;! INTEGER CONSTANT
 6253                 OPND_XTRA=OPND_D
 6254                 %IF OPND_XTRA<0 %THEN OPND_D=-1 %ELSE OPND_D=0
 6255              %FINISH %ELSE %START
 6256                 %IF PR=6 %THEN %START
 6257                    TOAR8(R,LONGREAL(ADDR(OPND_D)))
 6258                    TOAR8(R+8,0)
 6259                    OPND_XTRA=ADDR(A(R))
 6260                    OPND_FLAG=3
 6261                    R=R+16
 6262                 %FINISH %ELSE OPND_XTRA=0
 6263              %FINISH
 6264           %FINISH %ELSE %START;          ! CODE PLANTING REQRD
 6265              LOAD(OPND,ACCR,2)
 6266             %IF TP=1 %THEN PSF1(IMYD,0,1) %ELSE PF1(RMYD,0,PC,SPECIAL CONSTS(1));!  REAL ONE=16_41000000
 6267              GRUSE(ACCR)=0
 6268           %FINISH
 6269           OPND_PTYPE=(PR+1)<<4+TP
 6270  %END
 6271  %ROUTINE SHORTEN(%RECORD(RD)%NAME OPND)
 6272  !***********************************************************************
 6273  !*       PLANT CODE TO REDUCE ACC SIZE                                 *
 6274  !***********************************************************************
 6275  {%RECORDSPEC OPND(RD)
 6276  %INTEGER TY,PR,F,I,J
 6277           TY=OPND_PTYPE&7
 6278           PR=OPND_PTYPE>>4
 6279           F=OPND_FLAG
 6280           %IF F=3 %START;                ! LONGLONGREAL CONSTS
 6281              %CYCLE I=0,1,3
 6282                 BYTEINTEGER(ADDR(J)+I)=BYTEINTEGER(OPND_XTRA+4+I)
 6283              %REPEAT
 6284              OPND_XTRA=J
 6285              OPND_FLAG=1;                ! CONST NOW IN _D & _XTRA
 6286              ->WAYOUT
 6287           %FINISH
 6288           %IF F<=1 %START
 6289              %IF TY=2 %THEN ->WAYOUT
 6290              %IF (OPND_D=0 %AND OPND_XTRA>=0) %OR (OPND_D=-1 %AND OPND_XTRA<0) %THEN OPND_D=OPND_XTRA %AND ->WAYOUT
 6291           %FINISH
 6292           LOAD(OPND,ACCR,2)
 6293           %IF PR=7 %THEN %START;          ! SHORTEN QUAD
 6294              PF1(RDDV,0,PC,SPECIAL CONSTS(1))
 6295           %FINISH %ELSE %START
 6296              %IF TYPE=1=PARMARR %THEN PSF1(ISH,0,32)
 6297              PSF1(USH,0,-32) %IF PARMARR=1 %OR TYPE#1
 6298              %IF REGISTER(BREG)=0 %THEN PF1(STUH,0,BREG,0) %AND GRUSE(BREG)=0 %ELSE PSF1(MPSR,0,17);! ACS TO 1 WORD
 6299           %FINISH
 6300           GRUSE(ACCR)=0
 6301  WAYOUT:
 6302           OPND_PTYPE=(PR-1)<<4+TY
 6303  %END
 6304  %ROUTINE EXTRACT(%RECORD(RD)%NAME OPND,%LONGINTEGERNAME VAL,{%LONG}%LONGREALNAME RVAL)
 6305  !***********************************************************************
 6306  !*    EXTRACTS A CONTANT OPERAND RETURNING REAL &INT VALUES           *
 6307  !***********************************************************************
 6308  {%RECORDSPEC OPND(RD)
 6309  %INTEGER TYPE,PREC,S,I,AD
 6310        TYPE=OPND_PTYPE; PREC=TYPE>>4
 6311        TYPE=TYPE&15
 6312        %IF TYPE=1 %THEN %START
 6313           %IF PREC<=5 %THEN VAL=OPND_D %ELSE %START
 6314              INTEGER(ADDR(VAL))=OPND_D
 6315              INTEGER(ADDR(VAL)+4)=OPND_XTRA
 6316           %FINISH
 6317           RVAL=VAL
 6318        %FINISH %ELSE %START
 6319           RVAL=0
 6320           %IF PREC=7 %THEN S=15 %AND AD=OPND_XTRA %ELSE S=7 %AND AD=ADDR(OPND_D)
 6321           %CYCLE I=0,1,S
 6322              BYTEINTEGER(ADDR(RVAL)+I)=BYTEINTEGER(AD+I)
 6323           %REPEAT
 6324        %FINISH
 6325  %END
 6326  
 6327  %ROUTINE VMY1
 6328  !***********************************************************************
 6329  !*    DOES VECTOR MULTIPLIES FOR ONE DIMENSION ARRAYS                  *
 6330  !***********************************************************************
 6331  %INTEGER OPNAME,VUSE,DVPOS,DVNAME,X,Y,DTYPE,DPREC,DACC,DPTYPE
 6332        DPTYPE=XTRA>>16
 6333        DVNAME=XTRA&16_FFFF
 6334        DVPOS=OPND2_D&16_FFFF
 6335        %IF DVPOS>0 %AND OPND1_FLAG<=1 %START;! CONST ITEM & DV FOLD IT
 6336           X=OPND1_D
 6337           X=X-CTABLE_val(DVPOS+3)
 6338           X=X*CTABLE_val(DVPOS+4)
 6339           %IF X<0 %OR X>=CTABLE_val(DVPOS+5) %THEN FAULT2(50,X,DVNAME)
 6340  !
 6341  ! IF ARRAY BASE HAS BEEN SHIFTED TO ZERO ELEMENT PUT BACK THE LB CORRN
 6342  ! NOW THE BOUND CHECK HAS BEEN COMPUTED
 6343  !
 6344           %IF PARMARR=0=PARMCHK %AND DPTYPE&16_C0F<=3 %THEN X=X+CTABLE_val(DVPOS+3)*CTABLE_val(DVPOS+4)
 6345           OPND1_D=X
 6346           %RETURN
 6347        %FINISH
 6348        OPNAME=-1
 6349        %IF OPND1_FLAG=2 %THEN OPNAME=OPND1_XTRA
 6350        VUSE=DVNAME!OPNAME<<16
 6351        %IF OPNAME>=0 %AND GRUSE(BREG)=14 %AND GRINF1(BREG)= VUSE %THEN ->DONE
 6352        %IF PARMARR=0=PARMCHK %AND DVPOS>0 %START
 6353           LOAD(OPND1,BREG,2)
 6354           X=CTABLE_val(DVPOS+4)
 6355           %IF X#1 %THEN PSF1(MYB,0,X) %AND GRUSE(BREG)=0
 6356           Y=X*CTABLE_val(DVPOS+3)
 6357           %IF DPTYPE&16_C0F<=3 %THEN %START
 6358              %IF X#1 %THEN ->DONE
 6359              ->OUT
 6360           %FINISH
 6361                                          ! TEST NAM=0 WHEN ZERO ADJSTD
 6362           %IF Y#0 %THEN PSF1(SBB,0,Y) %AND GRUSE(BREG)=0
 6363           ->DONE
 6364        %FINISH
 6365        %IF PARMARR=0=PARMCHK %AND (DPTYPE&16_300=16_200 %OR DPTYPE&16_C0F<=3 %OR COMPILER#0)%START;! IE ARR=2 OR NAM=0
 6366           DTYPE=DPTYPE&15; DPREC=DPTYPE>>4&7
 6367           LOAD (OPND1,BREG,2) %UNLESS OPND1_FLAG<=1
 6368           %IF DTYPE>=3 %OR DPREC=4 %THEN %START
 6369              DACC=LIST_S3;               ! PUT THERE BY CANAME
 6370              %IF OPND1_FLAG<=1 %THEN OPND1_D=OPND1_D*DACC %AND %RETURN
 6371              PSF1(MYB,0,DACC) %UNLESS DACC=1
 6372              GRUSE(BREG)=0
 6373              ->DONE
 6374           %FINISH
 6375           %IF OPND1_FLAG<=1 %THEN %RETURN
 6376           LOADREG=BREG; ->OUT
 6377        %FINISH
 6378        %IF OPND1_FLAG=9 %AND OPND1_XB>>4=ACCR %THEN %START
 6379           PF1(ST,0,TOS,0);            ! ACC CANNOT BE USED IN DVM
 6380           CHANGE RD(ACCR)
 6381           REGISTER(ACCR)=0
 6382        %FINISH
 6383  !
 6384        BASE=OPND2_XTRA>>18; AREA=-1
 6385        GET IN ACC(DR,2,0,AREA CODE,OPND2_XTRA&16_1FFFF+8)
 6386  !
 6387        LOAD(OPND1,EVALREG,0)
 6388        %IF OPND1_PTYPE>>4>=6 %THEN FAULT(24,0)
 6389        %IF REGISTER(BREG)>=1 %AND (OPND1_FLAG#9 %OR OPND1_XB>>4#BREG) %THEN %START
 6390           OPND==RECORD(OLINK(BREG))
 6391           OPND_D=0
 6392           REGISTER(BREG)=2
 6393           BOOT OUT(BREG)
 6394        %FINISH
 6395        AREA=OPND1_XB>>4; ACCESS=OPND1_XB&15
 6396        PSORLF1(OPCODE>>8,ACCESS,AREA,OPND1_D)
 6397        GRUSE(BREG)=0
 6398  DONE:
 6399        %IF OPNAME>=0 %THEN %START
 6400           GRUSE(BREG)=14
 6401           GRINF1(BREG)=VUSE
 6402           GRINF2(BREG)=0
 6403        %FINISH
 6404  OUT:
 6405        LOADREG=BREG
 6406        REGISTER(LOADREG)=1
 6407        OPND1_FLAG=9; OPND1_XB=LOADREG<<4
 6408  %END
 6409  %ROUTINE VMY
 6410  !***********************************************************************
 6411  !*    DOES ALL VECTOR MULTIPLIES EXCEPT ONE DIMENSION                  *
 6412  !***********************************************************************
 6413        %IF OPND1_FLAG=9 %AND OPND1_XB>>4=ACCR %THEN %START
 6414           PF1(ST,0,TOS,0);            ! ACC CANNOT BE USED IN DVM
 6415           CHANGE RD(ACCR)
 6416           REGISTER(ACCR)=0
 6417        %FINISH
 6418  !
 6419        %IF C=D %THEN %START;          ! TOP DIMENSION LOAD DV DES
 6420           BASE=OPND2_XTRA>>18; AREA=-1
 6421           GET IN ACC(DR,2,0,AREA CODE,OPND2_XTRA&16_1FFFF+8)
 6422        %FINISH
 6423  !
 6424        LOAD(OPND1,EVALREG,0)
 6425        %IF OPND1_PTYPE>>4>=6 %THEN FAULT(24,0)
 6426        %IF C=D %AND REGISTER(BREG)>=1 %AND (OPND1_FLAG#9 %OR OPND1_XB>>4#BREG) %THEN %START
 6427           OPND==RECORD(OLINK(BREG))
 6428           OPND_D=0
 6429           REGISTER(BREG)=2
 6430           BOOT OUT(BREG)
 6431        %FINISH
 6432        AREA=OPND1_XB>>4; ACCESS=OPND1_XB&15
 6433        PSORLF1(OPCODE>>8,ACCESS,AREA,OPND1_D)
 6434           GRUSE(BREG)=0
 6435  !
 6436        LOADREG=ACCR
 6437        %IF C=D %THEN GET IN ACC(ACCR,1,0,7,0) %ELSE PF1(IAD,0,BREG,0)
 6438        %IF C=1 %THEN %START
 6439           PF1(ST,0,BREG,0)
 6440           REGISTER(ACCR)=0
 6441           LOADREG=BREG
 6442        %FINISH
 6443        REGISTER(LOADREG)=1
 6444        OPND1_FLAG=9; OPND1_XB=LOADREG<<4
 6445  %END
 6446  %ROUTINE CTOP(%INTEGERNAME FLAG)
 6447  !***********************************************************************
 6448  !*       AN OPERATION HAS BEEN FOUND WHERE BOTH OPERANDS ARE CONSTANTS *
 6449  !*       THIS ROUTINE ATTEMPTS TO INTERPRET THIS OPERATION IF IT       *
 6450  !*       CAN BE DONE SAFELY                                            *
 6451  !*       ON EXIT FLAG=0 %IF OPERATION CARRIED OUT                      *
 6452  !***********************************************************************
 6453  %CONSTINTEGER TRUNCMASK=16_01300800
 6454  %INTEGER K,TYPEP,PRECP,OP,TYPEPP,VAL,SVAL1,SVAL2
 6455  %LONGINTEGER VAL1,VAL2
 6456  {%LONG}%LONGREAL RVAL1,RVAL2
 6457  %SWITCH ISW,RSW(10:32)
 6458        %ON %EVENT 1,2 %START
 6459           %RETURN
 6460        %FINISH
 6461        TYPEP=TYPE; PRECP=PTYPE>>4&15; OP=FLAG
 6462        EXTRACT(OPND1,VAL1,RVAL1)
 6463        EXTRACT(OPND2,VAL2,RVAL2)
 6464        SVAL1<-VAL1; SVAL2<-VAL2
 6465        %IF TYPEP=1 %AND OP=37 %THEN ->ISW37
 6466        %RETURN %IF OP>32
 6467        %IF TYPEP=2 %THEN ->RSW(OP) %ELSE ->ISW(OP)
 6468  ISW(10):                                ! \
 6469        VAL1=\VAL1
 6470  INTEND:
 6471        %IF PRECP=6 %THEN %START
 6472           OPND1_D<-VAL1>>32
 6473           OPND1_XTRA<-VAL1
 6474           FLAG=0
 6475        %FINISH %ELSE %START
 6476           VAL<-VAL1
 6477           %IF VAL=VAL1 %OR 1<<OP&TRUNCMASK=0 %THEN FLAG=0 %AND OPND1_D=VAL;! NO ARITH OFLOW CONDITION
 6478        %FINISH
 6479        %IF FLAG=0 %START
 6480           OPND1_PTYPE=PRECP<<4!1
 6481           %IF 16_FFFE0000<=VAL1<=16_1FFFF %THEN OPND1_FLAG=0 %ELSE OPND1_FLAG=1
 6482        %FINISH
 6483        %RETURN
 6484  ISW(11):                                ! INTEGER NEGATE
 6485        VAL1=-VAL1; -> INT END
 6486  ISW(13):                                ! INTEGER ABS
 6487        VAL1=IMOD(VAL1); -> INT END
 6488  ISW(12):                                ! INTEGER FLOAT
 6489        RVAL1=VAL1; PRECP=5+XTRA
 6490        ->REAL END
 6491  RSW(14):                                ! STRETCH REAL
 6492        PRECP=PRECP+1
 6493  REAL END:OPND1_FLAG=1
 6494        OPND1_D=INTEGER(ADDR(RVAL1))
 6495        OPND1_XTRA=INTEGER(ADDR(RVAL1)+4)
 6496        %IF PRECP=7 %THEN %START
 6497           OPND1_FLAG=3
 6498           OPND1_XTRA=ADDR(A(R))
 6499           %CYCLE K=0,1,15
 6500              A(R)=BYTEINTEGER(ADDR(RVAL1)+K)
 6501              R=R+1
 6502           %REPEAT
 6503        %FINISH
 6504        FLAG=0; OPND1_PTYPE=16*PRECP+2
 6505        %RETURN
 6506  ISW(14):                                ! STRETCH INTEGER
 6507  RSW(12):                                ! FLOAT REAL
 6508        ABORT
 6509  ISW(20):                                ! ADD
 6510        VAL1=VAL1+VAL2; -> INT END
 6511  ISW(21):                                ! MINUS
 6512        VAL1=VAL1-VAL2; -> INT END
 6513  ISW(22):                                ! EXCLUSIVE OR
 6514        VAL1=VAL1!!VAL2; -> INT END
 6515  ISW(23):                                ! OR
 6516        VAL1=VAL1!VAL2; -> INT END
 6517  ISW(24):                                ! MULT
 6518        VAL1=VAL1*VAL2; -> INT END
 6519  ISW(26): %RETURN;                       ! / DIVISION
 6520  ISW(25): %RETURN %IF VAL2=0;            ! // DIVISION
 6521        VAL1=VAL1//VAL2; -> INT END
 6522  ISW(27):                                ! AND
 6523        VAL1=VAL1&VAL2; -> INT END
 6524  ISW(29):                                ! SLL
 6525        %IF PRECP=6 %THEN VAL1=VAL1<<SVAL2 %ELSE VAL1=SVAL1<<SVAL2
 6526        ->INT END
 6527  ISW(28):                                ! SRL
 6528        %IF PRECP=6 %THEN VAL1=VAL1>>SVAL2 %ELSE VAL1=SVAL1>>SVAL2
 6529        ->INT END
 6530  
 6531  ISW(31):ISW(32):                        ! COMPARISONS
 6532  RSW(31):RSW(32):                        ! REAL COMPARISONS
 6533        BFFLAG=COMM-1
 6534        MASK=FCOMP(XTRA+7*BFFLAG)
 6535        COMM=2; FLAG=0
 6536        %IF TYPE=2 %THEN ->RCOMP
 6537        %IF (MASK&8#0 %AND VAL1=VAL2) %OR (MASK&4#0 %AND VAL1<VAL2) %OR (MASK&2#0 %AND VAL1>VAL2) %THEN MASK=15 %ELSE MASK=0
 6538        %RETURN
 6539  RCOMP:
 6540        %IF (MASK&8#0 %AND RVAL1=RVAL2) %OR (MASK&4#0 %AND RVAL1<RVAL2) %OR (MASK&2#0 %AND RVAL1>RVAL2) %THEN MASK=15 %ELSE MASK=0
 6541        %RETURN
 6542  RSW(11):                                ! NEGATE
 6543        RVAL1=-RVAL1; -> REAL END
 6544  RSW(13):                                ! ABS
 6545        RVAL1=MOD(RVAL1); -> REAL END
 6546  RSW(20):                                ! ADD
 6547        RVAL1=RVAL1+RVAL2; -> REAL END
 6548  RSW(21):                                ! SUBTRACT
 6549        RVAL1=RVAL1-RVAL2; -> REAL END
 6550  RSW(24):                                ! MULT
 6551        RVAL1=RVAL1*RVAL2; -> REAL END
 6552  RSW(26):                                ! DIVISION
 6553        %RETURN %IF RVAL2=0;              ! AVOID DIV BY ZERO
 6554        RVAL1=RVAL1/RVAL2; -> REAL END
 6555  ISW(30):                                ! '**' WITH 2 INTEGER OPERANDS
 6556  ISW37:                                  ! '****' WITH 2 INTEGER OPERAND
 6557        %RETURN %UNLESS 0<=VAL2<=63
 6558        VAL2=1
 6559        %WHILE SVAL2>0 %CYCLE
 6560           VAL2=VAL2*VAL1
 6561           SVAL2=SVAL2-1
 6562           %RETURN %IF VAL2#INTEGER(ADDR(VAL2)+4)
 6563        %REPEAT
 6564        VAL1=VAL2; ->INT END
 6565  RSW(22):RSW(23):
 6566  RSW(25):RSW(27):RSW(28):RSW(29):
 6567  %END
?TYPEPP unused
 6568  %ROUTINE REXP
 6569  !***********************************************************************
 6570  !*       CALLS A PERM ROUTINE TO PERFORM REAL**REAL                    *
 6571  !***********************************************************************
 6572  %INTEGER I,PR
 6573  %RECORD(RD)%NAME OPND{(RD)
 6574        %IF REGISTER(BREG)>0 %THEN BOOT OUT(BREG)
 6575        %CYCLE I=1,1,2
 6576           OPND==RECORD(OPERAND(I))
 6577           LOAD(OPND,ACCR,2) %UNLESS I=1 %AND OPND_FLAG=8
 6578           PR=OPND_PTYPE>>4
 6579           %IF PR<6 %THEN LENGTHEN(OPND)
 6580           %IF PR>6 %THEN SHORTEN(OPND)
 6581        %REPEAT
 6582        PPJ(0,17)
 6583  %END
 6584  %ROUTINE STARSTAR
 6585  !***********************************************************************
 6586  !*       PLANT IN-LINE CODE FOR EXPONENTIATION                         *
 6587  !*       IMP ALLOWS EXPONENTS IN INTEGER EXPRESSIONS FROM 0-63 AND     *
 6588  !*       IN REAL EXPRESSIONS FROM-255 TO +255                          *
 6589  !***********************************************************************
 6590  %INTEGER TYPEP,PRECP,WORK,C,EXPWORK,VALUE
 6591        PTYPE=OPND1_PTYPE;                ! INSPECT THE OPERAND
 6592        UNPACK
 6593        TYPEP=TYPE; PRECP=PREC
 6594        %IF TYPEP=2 %THEN OPCODE=16_FA %ELSE OPCODE=16_EA
 6595        VALUE=0
 6596        %IF OPND2_FLAG=0 %AND 1<=OPND2_D<=63*TYPE %THEN VALUE=OPND2_D;                 ! EXPONENT IS #0 AND CONSTANT
 6597        LOAD(OPND1,ACCR,2);               ! FETCH OPERAND TO ACC
 6598        %IF TYPEP=2 %AND PRECP=5 %THEN LENGTHEN(OPND1) %AND PRECP=6
 6599  !
 6600  ! OPTIMISE **2 **3 AND **4
 6601  !
 6602        %IF 2<=VALUE<=4 %THEN %START
 6603           PF1(ST,0,TOS,0)
 6604           %IF VALUE=3 %THEN PF1(ST,0,TOS,0)
 6605           PF1(OPCODE,0,TOS,0)
 6606           %IF VALUE=4 %THEN PF1(ST,0,TOS,0)
 6607           %IF VALUE>2 %THEN PF1(OPCODE,0,TOS,0)
 6608           GRUSE(ACCR)=0
 6609           %RETURN
 6610        %FINISH
 6611  !
 6612  ! OTHERWISE STORE OPERAND IN 'WORK' AND GET HOLD OF EXPONENT
 6613  !
 6614        GET WSP(WORK,BYTES(PRECP)>>2)
 6615        %IF TYPEP=2 %THEN GET WSP(EXPWORK,1)
 6616        PSF1(ST,1,WORK)
 6617        REGISTER(ACCR)=0
 6618        PLABEL=PLABEL-1;                  ! LABEL FOR JUMPING OUT
 6619        %IF OPND2_PTYPE>>4=6 %THEN SHORTEN(OPND2);! LONG EXPONENT
 6620        LOAD(OPND2,BREG,2);               ! EXPONENT TO ANY REGISTER
 6621        %IF TYPEP=2 %THEN PSF1(STB,1,EXPWORK)
 6622  !
 6623  ! GET '1' INTO ACC IN APPROPIATE FORM
 6624  !
 6625        GET IN ACC(ACCR,BYTES(PRECP+1-TYPEP)>>2,0,0,1)
 6626        %IF TYPEP=2 %THEN PSF1(FLT,0,0)
 6627  !
 6628  ! IF EXPONENT NOT KNOWN AT COMPILE TIME TO BE +VE CONSTANT MUST
 6629  ! ALLOW FOR ZERO  :- XX**0=1 FOR ALL XX
 6630  ! ALSO ALLOW FOR X**(-N) WHICH IS 1/(X**N) FOR ALL X & N
 6631  !
 6632        %IF VALUE=0 %THEN %START;         ! NOT +VE CONSTANT
 6633           ENTER JUMP(28,PLABEL,B'11');   ! J(B=0) END OF EXP ROUTINE
 6634           %IF TYPEP=2 %THEN %START
 6635              PF3(JAT,13,0,4);            ! J*+4 IF B>0
 6636              PSF1(SLB,0,0)
 6637              PF1(SBB,0,TOS,0)
 6638           %FINISH
 6639  !
 6640  ! IN CHECKING MODE PLANT CODE TO CHECK RANGE OF EXPONENT
 6641  !
 6642           %IF PARMOPT=1 %THEN %START
 6643              %IF TYPEP=1 %THEN PPJ(30,7);! JUMP B<0
 6644              PSF1(CPB,0,64*TYPEP*TYPEP-1)
 6645              PPJ(2,7)
 6646           %FINISH
 6647        %FINISH
 6648        C=CA
 6649        PSF1(OPCODE,1,WORK)
 6650        PSF1(DEBJ,0,(C-CA)//2)
 6651  !
 6652  ! FOR REAL EXPONENTS CHECK IF NEGATIVE AND EVALUATE INVERSE
 6653  !
 6654        %IF VALUE=0 %AND TYPEP=2 %THEN %START
 6655           PSF1(LB,1,EXPWORK);            ! LB ON ORIGINAL EXPONENT
 6656           ENTER JUMP(46,PLABEL,B'11');! BP END OF EXP ROUTINE
 6657           %IF PRECP<7 %THEN PF1(RRDV,0,PC,SPECIAL CONSTS(1))%ELSESTART
 6658              PSF1(SLSD,0,1); PSF1(FLT,0,0)
 6659              PF1(RDV,0,TOS,0)
 6660           %FINISH
 6661        %FINISH
 6662  !
 6663  ! ALL OVER. REAL RESULTS ARE IN FR WORK. INT RESULTS IN GR WORK+1
 6664  ! FREE AND FORGET ANY OTHER REGISTERS
 6665  !
 6666        TYPE=TYPEP; PREC=PRECP
 6667        REGISTER(BREG)=0
 6668        GRUSE(ACCR)=0
 6669        GRUSE(BREG)=0
 6670        REGISTER(ACCR)=1
 6671        OPND1_PTYPE=16*PREC+TYPE
 6672        OPND1_XB=0; OPND1_D=ACCR
 6673        C=ENTER LAB(PLABEL,B'11');        ! LABEL AT END OF EXP ROUTINE
 6674  %END
 6675   %END;                                  ! OF ROUTINE EXPOP
 6676           %ROUTINE REDUCE ENV(%INTEGERNAME HEAD)
 6677  !***********************************************************************
 6678  !*       HEAD HAS AN ENVIRONMENT  - THIS ROUTINE REMOVES ANYTHING      *
 6679  !*       INCOMPATIBLE WITH THE CURRENT REGISTER STATE                  *
 6680  !***********************************************************************
 6681           %INTEGER NEWHEAD,I,J,K,REG,USE
 6682           NEWHEAD=0
 6683           %WHILE HEAD#0 %CYCLE
 6684              POP(HEAD,I,J,K)
 6685              REG=K>>8; USE=K&255
 6686              %IF USE=GRUSE(REG)&255 %AND I=GRINF1(REG) %THEN PUSH(NEWHEAD,I,J,K)
 6687           %REPEAT
 6688           HEAD=NEWHEAD
 6689           %END
 6690  %INTEGERFN CCOND(%INTEGER CTO,IU,FARLAB)
 6691  !***********************************************************************
 6692  !*       COMPILES <IU><SC><RESTOFCOND>%THEN<UI1>%ELSE<UI2>             *
 6693  !*       CTO=0 JUMP TO FARLAB MUST BE PLANTED IF COND UNCONDITIONAL    *
 6694  !*       CTO#0 JUMP MAY BE OMITTED                                     *
 6695  !*       IU=1 FOR %IF   =2 FOR UNLESS. FARLAB TO GO ON UI2             *
 6696  !*       THE ROUTINE MAKES FOUR PASSES THROUGH THE CONDITION           *
 6697  !*       PASS 1 ANALYSES THE STRUCTURE AND DECIDES TO BRANCH ON TRUE   *
 6698  !*       (TF=2)   OR ON FALSE (TF=1) FOR EACH COMPARISON               *
 6699  !*       PASS 2 WORKS OUT WHERE THE BRANCHES OF PASS 1 SHOULD GO TO    *
 6700  !*       PASS 3 ASSIGNS LABEL NUMBERS                                  *
 6701  !*       PASS 4 EVALUATES COMPARISIONS AND PLANTS THE CODE             *
 6702  !*                                                                     *
 6703  !*       ON ENTRY P POINTS TO <SC> IN<HOLE><SC><RESTOFCOND>            *
 6704  !*       RESULT=0 CONDITION COMPILED                                   *
 6705  !*       RESULT=1 UNCONDITIONALLY TO 1ST ALTERNATIVE                   *
 6706  !*       RESULT=2 UNCONDITIONALLY TO 2ND ALTERNATIVE(FARLAB)           *
 6707  !***********************************************************************
 6708  %ROUTINESPEC WRITE CONDLIST
 6709  %ROUTINESPEC SKIP SC(%INTEGER REVERSED)
 6710  %ROUTINESPEC SKIP COND(%INTEGER REVERSED)
 6711  %INTEGERFNSPEC CCOMP
 6712  %%ROUTINESPEC JUMP(%INTEGER MASK,LAB,FLAGS)
 6713  %ROUTINESPEC LAB UNUSED(%INTEGER LAB)
 6714  %ROUTINESPEC OMIT TO(%INTEGER LAB)
 6715  !
 6716  ! FCOMP HAS BC MASKS FOR EACH STRING COMPARATOR.
 6717  ! THE FIRST 7 ARE TO BRANCH IF TRUE WITH NORMAL COMPARISON
 6718  ! THE SECOND SEVEN ARE TO BRANCH IF TRUE WITH BACKWARDS COMPARISON
 6719  !
 6720  %CONSTBYTEINTEGERARRAY FCOMP(1:21)=8,13,5,7,10,2,7,
 6721+                                    8,10,2,7,13,5,7,
 6722+                                    27,0,0,43,0,0,43;
 6723  !
 6724  %INTEGER PIN,PP,II,L,CPTR,CMAX,LL,BITMASK,LA
 6725  %RECORDFORMAT CF(%BYTEINTEGER TF,CMP1,CMP2,LABU,LVL,JMP,REV,SP,%INTEGER LABNO,SP1,SP2)
 6726  %RECORD(CF)%ARRAY CLIST(1:30){(CF)
 6727  %RECORD(CF)%NAME C1,C2{(CF)
 6728  !
 6729  ! PASS 1.   ANALYSES THE CONDITION
 6730  !
 6731           PIN=P;                        ! SAVE INITIAL AR POINTER
 6732           CPTR=1; L=3;                  ! LEVEL=3 TO ALLOW 2 LOWER
 6733           C1==CLIST(CPTR);              ! SET UP RECORD FOR FIRST CMPARSN
 6734           C1=0
 6735           SKIP SC(0);                   ! SKIP THE 1ST CMPARSN
 6736           SKIP COND(0);                   ! AND ANY %AND/%OR CLAUSES
 6737           C1_LVL=2;                     ! LEVEL =-1 FOR %IF/%THEN ENTRY
 6738           C1_TF=IU
 6739           CMAX=CPTR+1
 6740           C1==CLIST(CMAX); C1=0
 6741           C1_LVL=1;                     ! LEVEL =-2 FOR ELSE ENTRY
 6742           C1_TF=3-IU;                    ! C1_REV NEVER SET HERE (PDS HOPES)
 6743           C1_LABNO=FARLAB
 6744           PP=P;                         ! SAVE FINAL AR POINTER
 6745           FAULT(209,0) %IF CMAX>29;     ! TOO COMPLICATED
 6746  !
 6747  ! PASS 2 WORKS OUT WHERE TO JUMP TO
 6748  ! THE JUMP IS FORWARD TO THE START OF THE CLAUSE WITH A DIFFERENT
 6749  ! CONNECTOR (AND/OR) PROVIDED THIS IS AT A LOWER LEVEL THAN THE BRANCH
 6750  ! AND ALSO AT A LOWER LEVEL THAN THE LOWEST POINT REACHED ENROUTE
 6751  !
 6752  ! ALSO CONTAINS PASS 3 (TRIVIAL)
 6753  ! ASSIGN LABELS WHERE LABU SHOWS THEY ARE REQUIRED
 6754  !
 6755           %CYCLE CPTR=1,1,CMAX-1
 6756              C1==CLIST(CPTR)
 6757              L=C1_LVL; LL=L;            ! LL FOR LOWEST LEVEL ENROUTE
 6758              %CYCLE II=CPTR+1,1,CMAX+1
 6759                C2==CLIST(II)
 6760                %EXIT %IF C1_TF#C2_TF %AND C2_LVL<LL
 6761                %IF C2_LVL<LL %THEN LL=C2_LVL
 6762              %REPEAT
 6763              C1_JMP=II;                 ! CLAUSE TO JUMP TO
 6764              C2_LABU=C2_LABU+1
 6765               %IF C1_CMP2#0 %OR C1_CMP1=8 %START; ! D-SIDED OR RESLN
 6766                                         ! REQIUIRES A LABEL ON THE
 6767                 C1_LABU=C1_LABU+1;      ! THE NEXT SIMPLE CONDITION
 6768              %FINISH
 6769              %IF C1_LABU#0 %AND C1_LABNO<=0 %THEN PLABEL=PLABEL-1 %AND C1_LABNO=PLABEL
 6770           %REPEAT
 6771  !
 6772  ! PASS 4 GENERATE THE CODE
 6773  ! MAINTAIN BIT MASK TO HELP. 2**0 JUMP TO FAR LAB PLANTED
 6774  !                            2**1 JUMP TO INTERMEDIATE LAB PLANTED
 6775  !
 6776           WRITE CONDLIST %IF DCOMP=1
 6777           BITMASK=0
 6778           CPTR=1
 6779           %CYCLE
 6780              C1==CLIST(CPTR)
 6781              LA=CCOMP
 6782              %IF LA#0 %START
 6783                 OMIT TO(LA)
 6784                 %IF CPTR>=CMAX %THEN %START
 6785                    %IF CTO=0 %THEN ENTER JUMP(15,LA,B'11')
 6786                    %RESULT=2
 6787                 %FINISH
 6788                 C1==CLIST(CPTR)
 6789              %FINISH
 6790              %IF C1_LABNO>0 %THEN II=ENTER LAB(C1_LABNO,B'11')
 6791              CPTR=CPTR+1
 6792              %EXIT %IF CPTR>=CMAX
 6793           %REPEAT
 6794  !
 6795           P=PP;
 6796           %RESULT=1 %IF BITMASK&1=0
 6797           %RESULT=0
 6798  %ROUTINE LAB UNUSED(%INTEGER LAB)
 6799  !***********************************************************************
 6800  !*       A LABEL IS NOT JUMPED TO AS CONDITION ALWAYS FALSE            *
 6801  !*       REMOVE IT FROM LIST                                           *
 6802  !***********************************************************************
 6803  %INTEGER I
 6804  %RECORD(CF)%NAME C1{(CF)
 6805        %CYCLE I=CPTR,1,CMAX-1
 6806           C1==CLIST(I)
 6807           %IF C1_LABNO=LAB %START
 6808              C1_LABU=C1_LABU-1;          ! COUNT DOWN USE COUNT
 6809              %IF C1_LABU=0 %THEN C1_LABNO=0
 6810              %RETURN
 6811           %FINISH
 6812        %REPEAT
 6813  %END
 6814  %ROUTINE OMIT TO(%INTEGER LAB)
 6815  !***********************************************************************
 6816  !*    A JUMP TURNS OUT TO BE UNCONDITIONAL. OMIT CODE FOR SKIPPED BIT  *
 6817  !***********************************************************************
 6818  %RECORD(CF)%NAME C1{(CF)
 6819        %CYCLE
 6820           C1==CLIST(CPTR)
 6821           %IF C1_LABNO>0 %START
 6822              %IF C1_LABNO=LAB % %THEN %RETURN
 6823              JUMP(15,LAB,B'11')
 6824              %RETURN
 6825           %FINISH
 6826           CPTR=CPTR+1
 6827           %EXIT %IF CPTR>=CMAX
 6828        %REPEAT
 6829  %END
 6830  %ROUTINE SKIP SC(%INTEGER REVERSED)
 6831  !***********************************************************************
 6832  !*       REVERSED=1 FOR RECURSIVE CALL IN %NOT(SC)                     *
 6833  !*       SKIPS OVER A SIMPLE CONDITION. P ON ALT OF<SC>                *
 6834  !***********************************************************************
 6835  %SWITCH SCALT(1:3)
 6836  %INTEGER ALT
 6837        ALT=A(P); P=P+1
 6838        ->SCALT(ALT)
 6839  SCALT(1):                               ! <EXP><COMP><EXP><SECONDSIDE>
 6840        C1_SP1=P-PIN
 6841        SKIP EXP
 6842        C1_CMP1=A(P)
 6843        C1_REV=3*REVERSED
 6844        P=P+1; C1_SP2=P-PIN
 6845        SKIP EXP
 6846        %IF A(P)=2 %THEN P=P+1 %ELSE %START
 6847           C1_CMP2=A(P+1);              ! DEAL WITH 2ND HALF OF D-SIDED
 6848           P=P+2; SKIP EXP
 6849        %FINISH
 6850        %RETURN
 6851  SCALT(2):                               ! '('<SC><RESTOFCOND>')'
 6852         L=L+1
 6853         SKIP SC(REVERSED)
 6854         SKIP COND(REVERSED)
 6855         L=L-1
 6856        %RETURN
 6857  SCALT(3):                               ! %NOT(SC)
 6858        SKIP SC(REVERSED!!1)
 6859  %END;                                   ! OF ROUTINE SKIP SC
 6860  %ROUTINE SKIP COND(%INTEGER REVERSED)
 6861  !***********************************************************************
 6862  !*       SKIPS OVER <RESTOFCOND>                                       *
 6863  !***********************************************************************
 6864  %INTEGER ALT,ALTP
 6865        ALT=A(P);                         ! 1=%AND<ANDC>,2=%OR<ORC>,3=NULL
 6866        P=P+1
 6867        %IF ALT\=3 %THEN %START;          ! NULL ALTERNATIVE NOTHING TO DO
 6868           {%UNTIL ALTP=2} %CYCLE;          ! UNTIL NO MORE <SC>S
 6869              C1_LVL=L; C1_TF=ALT
 6870              C1_TF=C1_TF!!(3*REVERSED)
 6871              CPTR=CPTR+1
 6872              C1==CLIST(CPTR); C1=0
 6873              SKIP SC(REVERSED)
 6874              ALTP=A(P); P=P+1
 6875           %REPEAT %UNTIL ALTP=2;         ! UNTIL NO MORE <SC>S
 6876        %FINISH
 6877  %END
 6878  %ROUTINE WRITE CONDLIST
 6879  %CONSTSTRING(5) %ARRAY CM(0:10)="     ","    =","   >=","    >",
 6880+                        "    #","   <=","    <","   \=","   ->",
 6881+                        "   ==","  \==";
 6882        PRINTSTRING("
 6883+  NO   TF   C1   C2   LABU   LVL  JMP  REV   LABNO
 6884+ ")
 6885        %CYCLE CPTR=1,1,CMAX
?Non-local
 6886           C1==CLIST(CPTR)
 6887           WRITE(CPTR,2)
 6888           WRITE(C1_TF,4)
 6889           PRINTSTRING(CM(C1_CMP1))
 6890           PRINTSTRING(CM(C1_CMP2))
 6891           WRITE(C1_LABU,6)
 6892           WRITE(C1_LVL,5)
 6893           WRITE(C1_JMP,4)
 6894           WRITE(C1_REV,4)
 6895           WRITE(C1_LABNO,7)
 6896           NEWLINE
 6897        %REPEAT
 6898  %END
 6899  %INTEGERFN CCOMP
 6900  !***********************************************************************
 6901  !*       COMPILES A COMPARISION: THREE DIFFERENT CASES                 *
 6902  !*       1) ARITHMETIC EXPRESSIONS EXPOP IS USED                       *
 6903  !*       2) STRING EXPRESSION AD-HOC CODE PLANTED BY THIS ROUTINE      *
 6904  !*       3) RESOLUTIONS - CRES CAN BE USED                             *
 6905  !*       4) EQUIVALENCES   INTEGER COMPARISONS ON ADDRESSES            *
 6906  !*       RESULT=0 CODE COMPILED                                        *
 6907  !*       RESULT#0 UNCODITIONAL JUMP TO LAB=RESULT                      *
 6908  !***********************************************************************
 6909  %ROUTINESPEC ACOMP(%INTEGER TF,DS)
 6910  %ROUTINESPEC ADCOMP(%INTEGER TF)
 6911  %ROUTINESPEC SCOMP(%INTEGER DS,TF,LAB,%INTEGERNAME WA)
 6912  %INTEGER HEAD1,HEAD2,NOPS,TE1,TE2,TEX1,TEX2,P1,P2,FEXIT,IEXIT,CMP,WA1,WA2,WA3,BOT1,BOT2
 6913  !
 6914           HEAD1=0; HEAD2=0; NOPS=0
 6915           BOT1=0; BOT2=0
 6916           FEXIT=CLIST(C1_JMP)_LABNO;    ! FINAL EXIT
 6917           IEXIT=FEXIT;                  ! INTERMEDIATE EXIT (D-SIDED ETC)
 6918           %IF C1_REV!!C1_TF=2 %AND (C1_CMP1=8 %OR C1_CMP2#0) %THEN IEXIT=C1_LABNO
 6919  !
 6920           P=PIN+C1_SP2
 6921           P2=P; P1=PIN+C1_SP1
 6922           %IF C1_CMP1=8 %THEN %START
 6923                                         ! CONDITIONAL RESOLUTION
 6924                                         ! NB CRES BRANCHES ON FALSE!!
 6925              P=P1
 6926              %IF A(P+3)=4 %AND A(P+4)=1 %START
 6927                 P=P+5; CNAME(2,DR);     ! LH STRING TO DR
 6928                 %IF A(P)=2 %THEN %START
 6929                    %IF TYPE#5 %THEN FAULT2(71,0,FROMAR2(P1+5)) %AND %RESULT=0
 6930                    P=P2
 6931                    CRES(IEXIT);         ! FAILURES -> IEXIT
 6932                    %IF IEXIT=FARLAB %THEN BITMASK=BITMASK!1 %ELSE BITMASK=BITMASK!2
 6933                    %IF C1_REV!!C1_TF=2 %THEN JUMP(15,FEXIT,B'11')
 6934                    %RESULT=0
 6935                 %FINISH
 6936              %FINISH
 6937              FAULT2(74,0,0)
 6938              %RESULT=0
 6939           %FINISH
 6940        %IF C1_CMP1>8 %THEN ->ADRCOMP
 6941           MASK=FCOMP(C1_CMP1)
 6942           TE2=TSEXP(TEX2)
 6943           ->STR %IF TYPE=5
 6944           ->ARITH %UNLESS TE2=1
 6945           P=P1; TE1=TSEXP(TEX1)
 6946           ->STR %IF TYPE=5
 6947  ARITH:                                 ! ARITHMETIC COMPARISIONS
 6948           P=P1+3
 6949           TORP(HEAD1,BOT1,NOPS);      ! FIRST EXPRESSION TO REVERSE POL
 6950           CMP=C1_CMP1
 6951           P=P2+3
 6952           %IF C1_CMP2#0 %THEN %START;   ! IF D-SIDED DEAL WITH MIDDLE
 6953              ACOMP(1,1);                ! BRANCH IEXIT %IF FALSE
 6954              %IF MASK=15 %THEN %RESULT=IEXIT
 6955              JUMP(MASK,IEXIT,B'11')
 6956              P=P+5;                     ! TO THE THIRD EXPRSN
 6957              CMP=C1_CMP2;               ! COMPARATOR NO 2
 6958           %FINISH
 6959  !
 6960           ACOMP(C1_REV!!C1_TF,0);       ! SECOND OR ONLY COMPARISION
 6961           %IF MASK=15 %THEN %RESULT=FEXIT
 6962           JUMP(MASK,FEXIT,B'11')
 6963           %RESULT=0
 6964  STR:                                   ! STRING COMPARISIONS
 6965                                         ! SOME CARE IS NEEDED IN FREEING
 6966                                         ! STRING WK-AREAS SET BY CSTREXP
 6967           P=P1
 6968           WA1=0; WA2=0; WA3=0
 6969           %IF C1_CMP2=0 %AND 7<=FCOMP(C1_CMP1)<=8 %AND A(P2+3)=4 %AND A(P2+4)=2 %AND A(P2+5)=16_35 %AND A(P2+10)=0 %AND A(P2+11)=2 %THEN %START
 6970              CSTREXP(0,DR)
 6971              MASK=FCOMP(C1_CMP1+14)
 6972              %IF C1_REV!!C1_TF=1 %THEN MASK=REVERSE(MASK)
 6973              JUMP(MASK,FEXIT,B'11')
 6974              %RESULT=0
 6975           %FINISH
 6976           CSTREXP(16,ACCR);            ! DO NOT FREE WK-AREA
 6977           WA1=VALUE;                   ! SAVE ADDRESS OF WK-AREA
 6978           CMP=C1_CMP1
 6979           P=P2
 6980  !
 6981           %IF C1_CMP2#0 %THEN %START;  ! D-SIDED DEAL WITH MIDDLE
 6982              SCOMP(1,1,IEXIT,WA2)
 6983              P=P+2; CMP=C1_CMP2
 6984              %IF WA1#0 %THEN RETURN WSP(WA1,256) %AND WA1=0
 6985           %FINISH
 6986  !
 6987           SCOMP(0,C1_REV!!C1_TF,FEXIT,WA3)
 6988           %CYCLE CMP=ADDR(WA1),4,ADDR(WA3)
 6989              %IF INTEGER(CMP)#0 %THEN RETURN WSP(INTEGER(CMP),256)
 6990           %REPEAT
 6991           %RESULT=0
 6992  ADRCOMP:                                ! ADRESS COMPARISONS
 6993        ADCOMP(C1_REV!!C1_TF)
 6994        JUMP(MASK,FEXIT,B'11')
 6995        %RESULT=0
 6996  %ROUTINE ADCOMP(%INTEGER TF)
 6997  !***********************************************************************
 6998  !*    COMPILES AN == OR ADDRESS COMPARISON WHICH CAN NOT BE            *
 6999  !*    DOUBLESIDED. BETTER CODE COULD BE GENERATED FOR THE              *
 7000  !*    MOST COMMON CASE IE POINTERNAME==VARIABLE                        *
 7001  !************************************************************************
 7002  %INTEGER TYPEP,PRECP,LHNAME,RHNAME,FNAME
 7003  %RECORD(RD) R{(RD)
 7004        LHNAME=A(P1+5)<<8!A(P1+6)
 7005        FNAME=RHNAME
 7006        RHNAME=A(P2+5)<<8!A(P2+6)
 7007        ->FLT %UNLESS A(P1+3)=4 %AND A(P1+4)=1
 7008        P=P1+5; CNAME(4,ACCR)
 7009        ->FLT %UNLESS A(P)=2;             ! NO REST OF EXPR
 7010        TYPEP=TYPE; PRECP=PREC
 7011        REGISTER(ACCR)=1
 7012        OLINK(ACCR)=ADDR(R)
 7013        R_PTYPE=1; R_XB=ACCR<<4
 7014        R_FLAG=9
 7015  !
 7016        FNAME=LHNAME
 7017        ->FLT %UNLESS A(P2+3)=4 %AND A(P2+4)=1
 7018        P=P2+5; CNAME(4,ACCR)
 7019        ->FLT %UNLESS A(P)=2;              ! NO REST OF EXPR
 7020        FAULT2(83,LHNAME,RHNAME) %UNLESS TYPEP=TYPE %AND PRECP=PREC
 7021        PF1(ICP,0,TOS,0)
 7022        %IF C1_CMP1=10 %THEN MASK=7 %ELSE MASK=8
 7023        %IF TF=1 %THEN MASK=REVERSE(MASK)
 7024        %RETURN
 7025  FLT:  REGISTER(ACCR)=0
 7026        FAULT2(80,0,FNAME)
 7027        MASK=7
 7028  %END
 7029  %ROUTINE ACOMP(%INTEGER TF,DS)
 7030  !***********************************************************************
 7031  !*       TYPE & PREC DEFINE THE EXPRSN IN REVERSE POLISH IN HEAD1      *
 7032  !*       THIS ROUTINE CONVERTS THE NEXT EXPRSN TO REVERSE POLISH AND   *
 7033  !*       ADDS OPERATORS FOR TYPE CHANGING(IF REQ) CMPRSN AND JUMP      *
 7034  !***********************************************************************
 7035  %INTEGER PRECP,TYPEP,REG
 7036           PRECP=PTYPE>>4&15; TYPEP=TYPE
 7037  !
 7038  ! ADD OPERATOR AT BOTTOM. EITHER COMPARE(31) OR DS COMPARE(32)
 7039  !
 7040           PUSH(HEAD2,31+DS,CMP,0)
 7041           BOT2=HEAD2
 7042           NOPS=(NOPS+1)!1<<31;           ! FLAG COMPARE 
 7043  !
 7044  ! CONVERT NEXT EXPRSN TO REVERSE POLISH AND TO THE SAME TYPE AS THE
 7045  ! FIRST IF POSSIBLE. MODE=0 INTEGER IF POSSIBLE,=2 REAL, =3 LONGREAL
 7046  !
 7047           TORP(HEAD2,BOT2,NOPS)
 7048           %IF TYPEP>TYPE %THEN TYPE=TYPEP
 7049  !         CONCAT(HEAD1,HEAD2)
 7050           ASLIST(BOT1)_LINK=HEAD2
 7051           BOT1=BOT2; BOT2=0; HEAD2=0
 7052           EXPOP(HEAD1,-1,NOPS,256+16*PRECP+TYPE);      ! PLANT THE CODE
 7053  !         CLEAR LIST(HEAD1)
 7054           ASLIST(BOT1)_LINK=ASL
 7055           ASL=HEAD1
 7056           HEAD1=0
 7057           %IF DS#0 %START
 7058              PUSH(HEAD1,INTEGER(ADDR(EXPOPND)),EXPOPND_D,EXPOPND_XTRA)
 7059              BOT1=HEAD1
 7060              %IF EXPOPND_FLAG=9 %START
 7061                 REG=EXPOPND_D>>4
 7062                 REGISTER(REG)=1
 7063                 OLINK(REG)=ADDR(ASLIST(HEAD1))
 7064              %FINISH
 7065           %FINISH
 7066           %IF TF=1 %THEN MASK=REVERSE(MASK)
 7067  %END
 7068           %ROUTINE SCOMP(%INTEGER DS,TF,LAB,%INTEGERNAME WA)
 7069  !***********************************************************************
 7070  !*       1ST STRING IS DEFINED BY (ACCR)                               *
 7071  !*       THIS ROUTINE EVALUATES THE NEXT STRING EXPRS AND PERFORMS     *
 7072  !*       THE COMPARISON & BRANCH.                                      *
 7073  !*       DS=0 UNLESS THIS COMPARISON IS THE FIRST HALF OF A DBLE-SIDED *
 7074  !***********************************************************************
 7075  %INTEGER MASK
 7076  %RECORD(RD) R{(RD)
 7077  !
 7078           REGISTER(ACCR)=1
 7079           OLINK(ACCR)=ADDR(R)
 7080           R_PTYPE=1; R_XB=ACCR<<4; R_FLAG=9
 7081           MASK=FCOMP(CMP)
 7082           %IF TF=1 %THEN MASK=REVERSE(MASK); ! REVERSE MASK TO JMP IF FALS
 7083  !
 7084           CSTREXP(16,DR);                ! SAVE WK-AREA
 7085           WA=VALUE
 7086           REGISTER(ACCR)=0
 7087           %IF R_FLAG#9 %THEN PF1(LSD,0,TOS,0)
 7088           %IF DS#0 %THEN PF1(STD,0,TOS,0)
 7089           PSF1(INCA,0,1); PSF1(IAD,0,1)
 7090           PF2(CPS,1,1,0,0,0)
 7091           GRUSE(ACCR)=0; GRUSE(DR)=0
 7092  !
 7093  ! IF CC=8 MUST CHECK THAT ACC STRING IS EXHAUSTED OTHERWISE CHANGE CC
 7094  ! TO GIVE RESULT ACC>DR. THIS IS BEST FIDDLED USING ISH.
 7095  ! CAN SKIP THIS CHECK IF MASK IS SUCH THAT 2**3 &2**2 BITS SET THE SAME
 7096  !
 7097           %IF 0#MASK&16_C#16_C %THEN %START
 7098              PF3(JCC,7,0,4)
 7099              PSF1(USH,0,-32)
 7100              PSF1(ISH,0,-24)
 7101           %FINISH
 7102           %IF DS#0 %THEN PF1(LSD,0,TOS,0);    ! DOES NOT CHANGE CC
 7103           JUMP(MASK,LAB,B'11')
 7104           %END
 7105           %END
 7106  %ROUTINE JUMP(%INTEGER MASK,LAB,FLAGS)
 7107  !***********************************************************************
 7108  !*    CALLS ENTER JUMP WHILE MAINTAINING BITMASK                        *
 7109  !***********************************************************************
 7110        %IF MASK=0 %THEN LAB UNUSED(LAB) %AND %RETURN
 7111        ENTER JUMP(MASK,LAB,FLAGS)
 7112        %IF LAB=FARLAB %THEN BITMASK=BITMASK!1 %ELSE BITMASK=BITMASK!2
 7113  %END
 7114  %END;                                  ! OF CCOND
 7115           %INTEGERFN REVERSE(%INTEGER MASK)
 7116  !***********************************************************************
 7117  !*       REVERSE THE MASK FOR A JCC(MASK<=15),JAT(>15) OR JAF(>31)     *
 7118  !***********************************************************************
 7119           %IF MASK>15 %THEN MASK=MASK!!16_30 %ELSE MASK=MASK!!15
 7120           %RESULT=MASK
 7121  %END
 7122  %INTEGERFN ENTER LAB(%INTEGER LAB,FLAGS)
 7123  !***********************************************************************
 7124  !*       ENTER A NEW LABEL ON THE LABEL LIST FOR THE CURRENT LEVEL     *
 7125  !*       2**0  OF FLAGS  = 1  CONDITIONAL ENTRY                        *
 7126  !*       2**1  OF FLAGS  = 1  UPDATE ENVIRONMENT                       *
 7127  !*       2**2  OF FLAGS  = 1  REPLACE ENV     =0  MERGE ENV            *
 7128  !*       THE LABEL LIST                                                *
 7129  !*       S1 =   USE BITS<<8 ! LABEL ADDR                               *
 7130  !*       S2 =   ENVIRONMENT LIST << 16 ! UNFILLED JUMPS LIST           *
 7131  !*       S3 = LAB NO - RESET TO FFFF WHEN USED FOR INTERNAL LABELS     *
 7132  !*       RESULT = 1 LABEL ENTERED                                      *
 7133  !*       RESULT = 0 CONDITIONAL LABEL NOT REQUIRED                     *
 7134  !***********************************************************************
 7135  %INTEGER CELL,AT,ENVHEAD,JUMPHEAD,INSTRN,OLDCELL,WORK
 7136  %RECORD(LISTF)%NAME LCELL{(LISTF)
 7137  %INTEGERNAME LHEAD
 7138           CELL=LABEL(LEVEL); OLDCELL=0
 7139           %WHILE CELL>0 %CYCLE
 7140              LCELL==ASLIST(CELL)
 7141              %EXIT %IF LCELL_S3=LAB
 7142              OLDCELL=CELL; CELL=LCELL_LINK
 7143           %REPEAT
 7144  !
 7145           %IF CELL<=0 %THEN %START;      ! LABEL NOT KNOWN
 7146              %IF FLAGS&1=0 %THEN %START;! UNCONDITIONAL ENTRY
 7147                 PUSH(LABEL(LEVEL),CA,0,LAB)
 7148                 FORGET(-1)
 7149                 %RESULT=1
 7150              %FINISH
 7151              %RESULT=0
 7152           %FINISH
 7153  !
 7154  ! LABEL HAS BEEN REFERENCED - FILL IN ITS ADDRESS
 7155  !
 7156           %IF LCELL_S1&16_FFFFFF# 0 %THEN %START
 7157              FAULT(2,LAB);             ! LABEL SET TWICE
 7158           %FINISH %ELSE %START
 7159              LCELL_S1=16_1000000!CA
 7160           %FINISH
 7161  !
 7162  ! SORT OUT ENVIRONMENTS  -  AS DIRECTED BY FLAGS
 7163  !
 7164           JUMPHEAD=LCELL_S2
 7165           ENVHEAD=JUMPHEAD>>16
 7166           JUMPHEAD=JUMPHEAD&16_FFFF
 7167           %IF FLAGS&2=0 %THEN %START
 7168              FORGET(-1)
 7169              CLEAR LIST(ENVHEAD)
 7170           %FINISH %ELSE %START
 7171              REMEMBER %IF FLAGS&4=0
 7172              RESTORE (ENVHEAD)
 7173              ENVHEAD=0
 7174              MERGE INFO %IF FLAGS&4=0
 7175           %FINISH
 7176  !
 7177  ! NOW FILL JUMPS TO THIS LABEL - JUMP LIST FORMAT GIVEN IN 'ENTER JMP'
 7178  !
 7179           %WHILE  JUMPHEAD#0  %CYCLE
 7180              POP(JUMPHEAD,AT,INSTRN,WORK)
 7181              PLUG(1,AT,INSTRN!(CA-AT)//2,4)
 7182           %REPEAT
 7183           LCELL_S2=0
 7184           %IF LAB> MAX ULAB  %THEN %START
 7185              %IF OLDCELL=0 %THEN LHEAD==LABEL(LEVEL)  %ELSE LHEAD==ASLIST(OLDCELL)_LINK
 7186              POP(LHEAD,AT,AT,AT)
 7187           %FINISH
 7188           %RESULT=1
 7189  %END
 7190  %ROUTINE ENTER JUMP(%INTEGER MASK,LAB,FLAGS)
 7191  !***********************************************************************
 7192  !*       IF LAB HAS BEEN ENCOUNTERED THEN PLANT A JCC OTHERWISE ENTER  *
 7193  !*       THE LABEL IN THE LABEL LIST AND ATTACH THE JUMP TO IT SO IT   *
 7194  !*       CAN BE PLANTED WHEN THE LABEL IS FOUND                        *
 7195  !*       THE LABEL LIST IS DESCRIBED UNDER 'ENTER LAB'                 *
 7196  !*       THE JUMP SUB-LIST HAS THE FORM                                *
 7197  !*       S1= ADDR OF JUMP                                              *
 7198  !*       S2=INSTRN                                                     *
 7199  !*       S3=LINE NO OF JUMP FOR DIAGNOSTICS                            *
 7200  !*                                                                     *
 7201  !*       FLAGS BITS SIGNIFY AS FOLLOWS                                 *
 7202  !*       2**0 =1  JUMP IS KNOWN TO BE SHORT                            *
 7203  !*       2**1 =1  ENVIRONMENT MERGEING REQUIRED                        *
 7204  !***********************************************************************
 7205  %INTEGER AT,CELL,J,JJ,LABADDR,I,ENVHEAD,OLDENV,JCODE,INSTRN
 7206  %RECORD(LISTF)%NAME LCELL{(LISTF)
 7207           ENVHEAD=0; AT=CA
 7208           %IF LAB<MAX ULAB %THEN FLAGS=FLAGS&16_FD;! NO MERGE
 7209           %IF LAB<21000 %THEN FLAGS=FLAGS&16_FE; ! SF OR USER LAB=LONG
 7210           CELL=LABEL(LEVEL)
 7211           %WHILE CELL>0 %CYCLE
 7212              LCELL==ASLIST(CELL)
 7213              %IF LAB=LCELL_S3 %THEN %EXIT
 7214              CELL=LCELL_LINK
 7215           %REPEAT
 7216           INSTRN=MASK
 7217           %IF INSTRN>>8=0 %THEN %START
 7218              JCODE=JCC
 7219              %IF MASK>=16 %THEN JCODE=JAT
 7220              %IF MASK>=32 %THEN JCODE=JAF
 7221              INSTRN=JCODE<<24!(MASK&15)<<21
 7222              %IF MASK=15 %THEN INSTRN=JUNC<<24!3<<23
 7223           %FINISH
 7224           -> FIRSTREF %IF CELL<=0
 7225           LABADDR=LCELL_S1&16_FFFFFF
 7226           -> NOT YET SET %IF LABADDR=0
 7227           LCELL_S1=LABADDR!16_1000000;! FLAG LABEL AS USED
 7228           I=(LABADDR-CA)//2
 7229           %IF MASK=15 %THEN PSF1(JUNC,0,I) %ELSE PCONST(INSTRN!(I&16_3FFFF))
 7230           %RETURN
 7231  FIRSTREF:                              ! FIRST REFERENCE TO A NEW LABEL
 7232           %IF LAB>MAX ULAB %AND FLAGS&2#0 %THEN GET ENV(ENV HEAD)
 7233           PUSH(LABEL(LEVEL),16_1000000,ENVHEAD<<16,LAB)
 7234           CELL=LABEL(LEVEL)
 7235           LCELL==ASLIST(CELL)
 7236           -> CODE
 7237  NOT YET SET:                           ! LABEL REFERENCED BEFORE
 7238           %IF LAB>MAX ULAB %AND FLAGS&2#0 %THEN %START
 7239              I=LCELL_S2
 7240              OLDENV=I>>16
 7241              REDUCE ENV(OLD ENV)
 7242              LCELL_S2=OLDENV<<16!I&16_FFFF
 7243           %FINISH
 7244  CODE:                                  ! ACTUALLY PLANT THE JUMP
 7245           J=LCELL_S2
 7246           JJ=J&16_FFFF
 7247           PUSH(JJ,CA,INSTRN,LINE)
 7248           LCELL_S2=J&16_FFFF0000!JJ
 7249           PCONST(INSTRN)
 7250           %END
 7251  %ROUTINE REMOVE LAB(%INTEGER LAB)
 7252  !***********************************************************************
 7253  !*    REMOVES A ALBEL FROM THE CURRENT LABEL LIST WHEN KNOWN TO        *
 7254  !*    BE REDUNDANT. MAINLY USED FOR CYCLE LABELS                       *
 7255  !***********************************************************************
 7256  %RECORD(LISTF)%NAME LCELL{(LISTF)
 7257  %INTEGERNAME LHEAD
 7258  %INTEGER CELL,AT
 7259        LHEAD==LABEL(LEVEL); CELL=LHEAD
 7260        %WHILE CELL>0 %CYCLE
 7261           LCELL==ASLIST(CELL)
 7262           %EXIT %IF LCELL_S3=LAB
 7263           LHEAD==LCELL_LINK
 7264           CELL=LHEAD
 7265        %REPEAT
 7266        %IF CELL>0 %THEN POP(LHEAD,AT,AT,AT)
 7267  %END
 7268           %ROUTINE MERGE INFO
 7269  !***********************************************************************
 7270  !*       MERGE THE CURRENT STATUS OF THE REGISTERS WITH THE VALUES     *
 7271  !*      AT THE START OF THE CONDITIONAL CLAUSE. THIS PERMITS THE       *
 7272  !*       THE COMPILER TO REMEMBER UNCHANGED REGISTERS BUT NOT THOSE    *
 7273  !*      WHICH DEPEND ON A PARTICULAR RUN TIME ROUTE BEING TAKEN        *
 7274  !***********************************************************************
 7275           %INTEGER I
 7276           %CYCLE I=0,1,7
 7277             GRUSE(I)=0 %UNLESS SGRUSE(I)=GRUSE(I)&255 %AND SGRINF(I)=GRINF1(I)
 7278           %REPEAT
 7279           %END
 7280           %ROUTINE REMEMBER
 7281  %INTEGER I
 7282           %CYCLE I=0,1,7
 7283              SGRUSE(I)=GRUSE(I)&255
 7284              SGRINF(I)=GRINF1(I)
 7285           %REPEAT
 7286           %END
 7287  %ROUTINE CREATE AH(%INTEGER MODE)
 7288  !***********************************************************************
 7289  !*       CREATE AN ARRAY HEAD IN TEMPORARY SPACE BY MODIFYING THE HEAD *
 7290  !*       THE HEAD AT AREA,ACCESS & DISP AS FOLOWS:-                    *
 7291  !*       MODE=0 (ARRAY MAPPING) ACC HAS ADDR(1ST ELEMENT)              *
 7292  !*       MODE=1 (ARRAYS IN RECORDS) ACC HAS RELOCATION FACTOR          *
 7293  !***********************************************************************
 7294  %INTEGER WK
 7295           GET WSP(WK,4)
 7296           AREA=AREA CODE
 7297           %IF MODE=0 %THEN %START
 7298              %IF COMPILER=1=J %AND TYPE<=2 %START
 7299                 PF1(SLSS,2,AREA,DISP+8); ! LWB TO ACC
 7300                 PSF1(IMY,0,-BYTES(PREC)) %UNLESS PREC=3
 7301                 PF1(IAD,0,TOS,0)
 7302                 GRUSE(DR)=0
 7303              %FINISH
 7304              PSORLF1(LUH,ACCESS,AREA,DISP)
 7305           %FINISH %ELSE %START
 7306              PSF1(LUH,0,0)
 7307              PSORLF1(IAD,ACCESS,AREA,DISP)
 7308           %FINISH
 7309  !
 7310           PSF1(ST,1,WK);                 ! 1ST PART OF HEAD =DESC TO ARRAY
 7311           PSORLF1(LSD,ACCESS,AREA,DISP+8)
 7312           PSF1(ST,1,WK+8);               ! 2ND PART = DESCPTR TO DV
 7313           GRUSE(ACCR)=0
 7314           ACCESS=0; AREA=LNB; DISP=WK
 7315  %END
 7316           %ROUTINE CSNAME(%INTEGER Z,REG)
 7317  !***********************************************************************
 7318  !*       COMPILE A SPECIAL NAME - PTYPE=10006 (=%ROUTINE %LABEL)       *
 7319  !*       THEIR TRUE PTYPE IS IN GLOBAL ARRAY TSNAME.                   *
 7320  !*       SNINFO HAS A FOUR BYTE RECORD FOR EACH NAME (%BI FLAG,PTR,    *
 7321  !*       %SI XTRA). THE TOP BITS OF FLAG CATEGORISE AS FOLLOWS:-       *
 7322  !*       2**7 SET FOR IMPLICITLY SPECIFIED CONSTRUCT A %SPEC           *
 7323  !*       2**6 SET FOR IOCP CALL                                        *
 7324  !*       2**5 SET FOR BUILT IN MAPPING FUNCTIONS                       *
 7325  !*       2**4 SET IF AD-HOC CODE PLANTED BY THIS ROUTINE               *
 7326  !*       2**3 SET IF FIRST PARAMETER IS OF %NAME TYPE                  *
 7327  !*       2**2-2**0 HOLD NUMBER OF PARAMS                               *
 7328  !*                                                                     *
 7329  !*       THE FULL SPECS ARE AS FOLLOWS:-                               *
 7330  !*       0=%ROUTINE SELECT INPUT(%INTEGER STREAM)                      *
 7331  !*       1=%ROUTINE SELECT OUTPUT(%INTEGER STREAM)                     *
 7332  !*       2=%ROUTINE NEWLINE                                            *
 7333  !*       3=%ROUTINE SPACE                                              *
 7334  !*       4=%ROUTINE SKIP SYMBOL                                        *
 7335  !*       5=%ROUTINE READ STRINWG(%STRINGNAME S)                        *
 7336  !*       6=%ROUTINE NEWLINES(%INTEGER N)                               *
 7337  !*       7=%ROUTINE SPACES(%INTEGER N)                                 *
 7338  !*       8=%INTEGERFN NEXT SYMBOL                                      *
 7339  !*       9=%ROUTINE PRINT SYMBOL(%INTEGER SYMBOL)                      *
 7340  !*       10=%ROUTINE READ SYMBOL(%NAME SYMBOL)                         *
 7341  !*       11=%ROUTINE READ(%NAME NUMBER)                                *
 7342  !*       12=%ROUTINE WRITE(%INTEGER VALUE,PLACES)                      *
 7343  !*       13=%ROUTINE NEWPAGE                                           *
 7344  !*       14=%INTEGERFN ADDR(%NAME VARIABLE)                            *
 7345  !*       15=%LONGREALFN ARCSIN(%LONGREAL X)                            *
 7346  !*       16=%INTEGERFN INT(%LONGREAL X)                                *
 7347  !*       17=%INTEGERFN INTPT(%LONRGREAL X)                             *
 7348  !*       18=%LONGREALFN FRACPT(%LONGREAL X)                            *
 7349  !*       19=%ROUTINE PRINT(%LONGREAL NUMBER,%INTEGER BEFORE,AFTER)     *
 7350  !*       20=%ROUTINE PRINTFL(%LONGREAL NUMBER,%INTEGER PLACES)         *
 7351  !*       21=%REALMAP REAL(%INTEGER VAR ADDR)                           *
 7352  !*       22=%INTEGERMAP INTEGER(%INTEGER VAR ADDR)                     *
 7353  !*       23=%LONGREALFN MOD(%LONGREAL X)                               *
 7354  !*       24=%LONGREALFN ARCCOS(%LONGREAL X)                            *
 7355  !*       25=%LONGREALFN SQRT(%LONGREAL X)                              *
 7356  !*       26=%LONGREALFN LOG(%LONGREAL X)                               *
 7357  !*       27=%LONGREALFN SIN(%LONGREAL X)                               *
 7358  !*       28=%LONGREALFN COS(%LONGREAL X)                               *
 7359  !*       29=%LONGREALFN TAN(%LONGREAL X)                               *
 7360  !*       30=%LONGREALFN EXP(%LONGREAL X)                               *
 7361  !*       31=%ROUTINE CLOSE STREAM(%INTEGER STREAM)                     *
 7362  !*       32=%BYTEINTEGERMAP BYTE INTEGER(%INTEGER VAR ADDR)            *
 7363  !*       33=%INTEGERFN EVENTINF                                        *
 7364  !*       34=%LONGREALFN RADIUS(%LONGREAL X,Y)                          *
 7365  !*       35=%LONGREALFN ARCTAN(%LONGREAL X,Y)                          *
 7366  !*       36=%BYTEINTEGERMAP LENGTH(%STRINGNAME  S)                     *
 7367  !*       37=%ROUTINE PRINT STRING(%STRING(255) MESSAGE)                *
 7368  !*       38=%INTEGERFN NL                                              *
 7369  !*       39=%LONGREALMAP LONG REAL(%INTEGER VAR ADDR)                  *
 7370  !*       40=%ROUTINE PRINT CH(%INTEGER CHARACTER)                      *
 7371  !*       41=%ROUTINE READ CH(%NAME CHARACTER)                          *
 7372  !*       42=%STRINGMAP STRING(%INTEGER VAR ADDR)                       *
 7373  !*       43=%ROUTINE READ ITEM(%STRINGNAME ITEM)                       *
 7374  !*       44=%STRING(1)%FN NEXT ITEM                                    *
 7375  !*       45=%BYTEINTEGERMAP CHARNO(%STRINGNAME STR,%INTEGER CHARREQD)  *
 7376  !*       46=%STRING(1)%FN TOSTRING(%INTEGER SYMBOL)                    *
 7377  !*       47=%STRING(255)%FN FROMSTRING(%STRING(255)S,%INTEGER BEG,END) *
 7378  !*       48=%RECORDMAP RECORD(%INTEGER REC ADDR)                       *
 7379  !*       49=%ARRAYMAP ARRAY(%INTEGER A1ADDR,%ARRAYNAME FORMAT)         *
 7380  !*       50=%ROUTINE SETMARGINS(%INTEGER INOUT,LHM,RHM)                *
 7381  !*       51=%INTEGERFN IMOD(%INTEGER VALUE)                            *
 7382  !*       52=%LONGREALFN PI                                             *
 7383  !*       53=%INTEGERFN EVENTLINE                                       *
 7384  !*       54=%LONGINTEGERMAP LONGINTEGER(%INTEGER ADR)                  *
 7385  !*       55=%LONGLONGREALMAP LONGLONGREAL(%INTEGER ADR)                *
 7386  !*       56=%LONGINTGEREFN LENGTHENI(%INTEGER VAL)                     *
 7387  !*       57=%LONGLONGREALFN LENGTHENR(%LONGREAL VAL)                   *
 7388  !*       58=%INTEGERFN SHORTENI(%LONGINTEGER VAL)                      *
 7389  !*       59=%LONGREALFN SHORTENR(%LONGLONGREAL VAL)                    *
 7390  !*       60=%INTEGERFN NEXTCH                                          *
 7391  !*       61=%HALFINTEGERMAP HALFINTEGER(%INTEGER ADDR)                 *
 7392  !*       62=%ROUTINE PPROFILE                                          *
 7393  !***********************************************************************
 7394  %INTEGERFNSPEC OPTMAP
 7395  %SWITCH ADHOC(1:15)
 7396  %CONSTINTEGERARRAY SNINFO(0:62)={%C
 7397+                     16_41080001,16_41090001,16_408A0001,16_40A00001,
 7398+                     16_40010001,16_800D0000,16_11010001,16_11010001,
 7399+                     16_10020024,16_41030001,16_19030001,16_80130001,
 7400+                     16_801B0014,16_408C0001,16_19050024,16_80010002,
 7401+                     16_11040024,16_11040024,16_80010005,16_80090006,
 7402+                     16_80060007,16_2100003E,16_2100003E,16_11060024,
 7403+                     16_80010008,16_80010009,16_8001000A,16_8001000B,
 7404+                     16_8001000C,16_8001000D,16_8001000E,16_8015000F,
 7405+                     16_2100003E,16_100D0024,16_80030010,16_80030011,
 7406+                     16_1907003E,16_41070001,16_10080024,16_2100003E,
 7407+                     16_41050001,16_19030001,16_2100003E,16_19030001,
 7408+                     16_10020024,16_1A07003E,16_11090024,16_800F0012,
 7409+                     16_110A8018,16_120B1000,16_80170013,16_11060024,
 7410+                     16_100C0024,16_100D0024,16_2100003E(2),
 7411+                     16_110E0024(4),
 7412+                     16_10020024,16_2100003E,16_100F0001;
 7413  %CONSTSTRING(11)%ARRAY SNXREFS(0:20)={%C
 7414+                   "READSTRING", "S#READ",   "S#IARCSIN", "S#INT",
 7415+                   "S#INTPT" , "S#FRACPT", "S#PRINT" , "S#PRINTFL",
 7416+                   "S#IARCCOS","S#ISQRT" , "S#ILOG"  , "S#ISIN",
 7417+                   "S#ICOS"  , "S#ITAN"  , "S#IEXP"  , "CLOSESTREAM",
 7418+                   "S#IRADIUS","S#IARCTAN","FROMSTRING","SETMARGINS",
 7419+                   "S#WRITE" ;
 7420  !
 7421  ! SNPARAMS HOLDS NUMBER AND PTYPE OF FORMAL PARAMETER FOR IMPLICITLY
 7422  ! SPECIFIED EXTERNAL ROUTINES. A POINTER IN SNINFO MEANS THAT NO
 7423  ! DUPLICATES NEED TO BE RECORDED.
 7424  !
 7425  %CONSTINTEGERARRAY SNPARAMS(0:29)=0,
 7426+                1,16_62,       2,16_62,16_62,  2,16_62,16_51,
 7427+                3,16_62,16_51,16_51,   1,16_435,   3,16_35,16_51,16_51,
 7428+                1,16_400,     1,16_51,      3,16_51,16_51,16_51,
 7429+                2,16_51,16_51;
 7430  !
 7431  %ROUTINESPEC RTOS(%INTEGER REG)
 7432  %RECORD(RD) R{(RD)
 7433  %INTEGER ERRNO,FLAG,POINTER,WREG,PIN,SNNO,SNNAME,NAPS,SNPTYPE,JJ,XTRA,IOCPEP,B,D,SNINF,P0,OPHEAD
 7434        SNNAME=FROM AR2(P)
 7435        SNNO=K;                           ! INDEX INTO SNINFO
 7436        TESTAPP(NAPS);                    ! COUNT ACTUAL PARAMETERS
 7437        PIN=P; P=P+2
 7438        SNPTYPE=TSNAME(SNNO)
 7439        SNINF=SNINFO(SNNO)
 7440        XTRA=SNINF&16_FFFF
 7441        POINTER=(SNINF>>16)&255
 7442        FLAG=SNINF>>24
 7443  !
 7444  ! THE IMPLICITLY SPECIFIED ROUTINE ARE THE EASIEST OF ALL TO DEAL WITH.
 7445  ! JUST SET UP THE EXTERNAL SPEC & PARAMETERS. THEN A RECURSIVE CALL
 7446  ! OF CNAME THEN FINDS THE ROUTINE UNDER ITS TRUE COLOURS AND COMPILES
 7447  ! THE CALL. ALL CALLS EXCEPT THE FIRST ARE DEALT WITH DIRECTLY BY CNAME.
 7448  ! ALL NONTRIVIAL ROUTINES SHOULD BE DEALT WITH IN THIS MANNER
 7449  ! XTRA HAS INDEX INTO ARRAY OF EXTERNAL NAMES SO THAT THESE
 7450  ! CAN EASILY BE CHANGED.
 7451  !
 7452        %IF FLAG&16_80#0 %THEN %START
 7453           CXREF(SNXREFS(XTRA),PARMDYNAMIC,2,JJ);! JJ SET WITH REF DISPLACEMENT
 7454           %IF SNNO=26 %THEN LOGEPDISP=JJ
 7455           %IF SNNO=31 %THEN EXPEPDISP=JJ
 7456           OPHEAD=0; P0=SNPARAMS(POINTER)
 7457           K=OPHEAD; D=1
 7458           %WHILE D<=P0 %CYCLE
 7459              PTYPE=SNPARAMS(POINTER+D)
 7460              UNPACK
 7461              %IF NAM=0 %THEN ACC=BYTES(PREC) %ELSE ACC=8
 7462              %IF PTYPE=16_35 %THEN ACC=256;!STRING BY VALUE
 7463              INSERTAT END(OPHEAD,PTYPE<<16,ACC<<16,0)
 7464              D=D+1
 7465           %REPEAT
 7466           I=1; J=14
 7467           OLDI=0; PTYPE=SNPTYPE
 7468           K=OPHEAD; KFORM=P0
 7469           REPLACETAG(SNNAME)
 7470           REPLACE2(TAGS(SNNAME),JJ);     ! DIPLACEMENT INTO S2
 7471           P=PIN; CNAME(Z,REG);           ! RECURSIVE CALL
 7472           NEST=REG
 7473           P=P-1; %RETURN;                ! DUPLICATES CHECK OF <ENAME>
 7474        %FINISH
 7475  !
 7476  ! ALL ROUTINES EXCEPT THE IMPLICITS REQUIRE A CHECK THAT THE USE OF THE
 7477  ! NAME IS LEGAL AND THAT THE CORRECT NO OF PARAMETERS(BOTTOM 2 BITS OF
 7478  ! FLAG) HAS BEEN SUPPLIED. THE CHECK IS TRIVIAL - THE PROBLEM
 7479  ! IS TO GET THE RIGHT ERROR NUMBER.
 7480  ! XTRA HAS A BITMASK OF ALLOWED USES(IE ALLOWED Z VALUES)
 7481  !
 7482        %IF NAPS#FLAG&3 %THEN ERRNO=19 %AND ->ERREXIT
 7483        JJ=1<<Z
 7484        %IF JJ&XTRA=0 %THEN %START;       ! ILLEGAL USE
 7485           ERRNO=23
 7486           %IF Z=0 %THEN ERRNO=17
 7487           %IF Z=1 %OR 3<=Z<=4 %THEN ERRNO=29
 7488           %IF XTRA&16_F000#0 %THEN ERRNO=84
 7489           ->ERR EXIT
 7490        %FINISH
 7491  !
 7492  ! A NUMBER OF INPUT-OUTPUT ROUTINES ARE MAPPED ONTO CALLS OF IOCP.
 7493  ! THIS ARRANGEMENT HAS THE ADVANTAGE OF REQUIRING ONL 1 EXTERNAL REF
 7494  ! IN THE GLA BUT HAS THE DISADVANTAGE THAT THE I-O ROUTINES CAN NOT
 7495  ! BE PASSED AS RT-TYPE PARAMETERS AS WELL AS REQUIRING MESSY CODE
 7496  ! HEREABOUTS.  SNINF_PTR HOLD EITHER:-
 7497  !       1) THE IOCP ENTRY POINT NO
 7498  !   OR  2) THE SYMBOL TO BE OUTPUT WITH 2**7 BIT SET
 7499  !
 7500  ! THIS SECTION DEALS WITH SELECT INPUT,SELECT OUTPUT,NEWLINE,NEWPAGE
 7501  !                         SPACE,SKIP SYMBOL,PRINT SYMBOL,PRINT STRING
 7502  !                         AND PRINT CH
 7503  !
 7504        %IF FLAG&16_40#0 %THEN %START
 7505           IOCPEP=POINTER; B=ACCR
 7506           %IF FLAG&3#0 %THEN %START;     ! RT HAS PARAMS
 7507              P=P+1
 7508              %IF SNNO=37 %THEN CSTREXP(0,DR) %AND B=DR %ELSE CSEXP(ACCR,16_51)
 7509           %FINISH
 7510           %IF IOCPEP>127 %THEN PSF1(LSS,0,IOCPEP&127) %AND IOCPEP=5
 7511           %IF SNNO=4 %THEN PSF1(LSS,0,0);! SKIP SYMBOL FORCE ACS=1
 7512           CIOCP(IOCPEP,B);               ! PLANT CALL OF IOCP
 7513           P=P+1
 7514           ->OKEXIT
 7515        %FINISH
 7516  !
 7517  ! THE BUILT-IN MAPS (INTEGER ETC BUT NOT RECORD OR ARRAY)
 7518  !
 7519        %IF FLAG&16_20#0 %THEN %START
 7520           SNPTYPE=16_1C00+SNPTYPE;       ! ADD MAP BITS
 7521           %IF PARMOPT=0 %AND OPTMAP#0 %THEN ->OKEXIT
 7522           %IF Z=1 %THEN  BIMSTR=1;       ! SPECIAL FLAG FOR STORE VIA MAP
 7523           P=P+1
 7524           CSEXP(BREG,16_51); P=P+1
 7525           %IF Z=1 %THEN BIMSTR=0
 7526           JJ=SNPTYPE>>4&15
 7527           DISP=MAPDES(JJ)
 7528           AREA=PC; ACCESS=3
 7529           OLDI=0;                        ! FOR CHECK IN == ASSGNMNT
 7530           ->OKEXIT
 7531        %FINISH
 7532  !
 7533  ! ADHOC CODING IS REQUIRED FOR THE REMAINING ROUTINES APART FROM
 7534  ! A CHECK FOR NAMETYPE PARAMETERS. THE SWITCH NO IS KEPT IN POINTER
 7535  !
 7536        P=P+1
 7537        %IF FLAG&8#0 %AND(A(P+3)#4 %OR A(P+4)#1 %OR A(P+FROM AR2(P+1)+1)#2) %THEN ERRNO=22 %AND ->ERREXIT
 7538        ->ADHOC(POINTER)
 7539  ADHOC(1):                               ! NEWLINES(=6) & SPACES(=7)
 7540        CSEXP(ACCR,16_51);                ! REPITITION NO TO ACC
 7541        %IF SNNO=6 %THEN JJ=10 %ELSE JJ=32
 7542        PSF1(USH,0,8);                    ! SHIFT UP 8 PLACES
 7543        PSF1(OR,0,JJ);                    ! OR SYMBOL
 7544        CIOCP(17,ACCR)
 7545        P=P+1
 7546        ->OKEXIT
 7547  ADHOC(2):                               ! NEXTSYMBOL(=8) & NEXTITEM(=44)
 7548                                          ! ALSO NEXTCH(=60)
 7549        GET IN ACC(ACCR,1,0,0,0);         ! PRESERVE ANY INTERMEDIATES
 7550        %IF SNNO=60 %THEN JJ=18 %ELSE JJ=2
 7551        CIOCP(JJ,ACCR);                   ! LEAVES THE SYMBOL IN ACC
 7552        %IF SNNO=44 %THEN %START
 7553           RTOS(BREG)
 7554           SNPTYPE=16_1435
 7555           AREA=PC; ACCESS=3
 7556           DISP=MAPDES(3)
 7557        %FINISH
 7558        NEST=ACCR;                        ! CONVERT R1 TO STRING
 7559        ->OKEXIT
 7560  ADHOC(3):                               ! READSYMBOL(=10),CH(=41)&ITEM(=43)
 7561        %IF SNNO=41 %THEN JJ=4 %ELSE JJ=1
 7562        PSF1(LSS,0,0)
 7563        CIOCP(JJ,ACCR);                   ! SYMBOL OR CH TO GR1
 7564        P=P+5
 7565        %IF SNNO=43 %THEN %START
 7566           TYPE=5; RTOS(ACCR)
 7567           PF1(LUH,0,PC,PARAM DES(3))
 7568        %FINISH  %ELSE %START
 7569           REGISTER(ACCR)=1; TYPE=1
 7570        %FINISH
 7571        JJ=TYPE
 7572        ASSIGN(6,P);                      ! BY '=' TO PARAMETER
 7573        P=PIN+6+FROM AR2(PIN+4)
 7574        ->OKEXIT
 7575  ADHOC(4):                               ! INT(=16) AND INTPT (=17)
 7576        CSEXP(ACCR,16_62)
 7577        %IF SNNO=16 %THEN PF1(RAD,0,PC,SPECIAL CONSTS(0));! RAD 0.5
 7578        %IF PARMOPT=0 %THEN PSF1(RSC,0,55) %AND PSF1(RSC,0,-55)
 7579        %IF REGISTER(BREG)#0 %THEN BOOT OUT(BREG)
 7580        PF1(FIX,0,BREG,0)
 7581        PSF1(MYB,0,4)
 7582        PSF1(CPB,0,-64)
 7583        PF3(JCC,10,0,3)
 7584        PSF1(LB,0,-64)
 7585        PF1(ISH,0,BREG,0)
 7586        PF1(STUH,0,BREG,0)
 7587        GRUSE(ACCR)=0; GRUSE(BREG)=0
 7588        NEST=ACCR
 7589        P=P+1
 7590        ->OKEXIT
 7591  ADHOC(5):                               ! ADDR(=14)
 7592        P=P+5; CNAME(4,REG);              ! FETCH ADDRESS MODE
 7593        NEST=REG
 7594        P=P+2; ->OKEXIT
 7595  ADHOC(6):                               ! MOD(=23), IMOD(=51)
 7596        %IF SNNO=51 %THEN %START
 7597           JJ=16_51; B=5; D=IRSB
 7598           XTRA=3; WREG=ACCR
 7599           %IF REG=BREG %START
 7600              B=13; D=SLB; XTRA=4; WREG=BREG
 7601           %FINISH
 7602        %FINISH %ELSE %START
 7603           JJ=16_62; B=1; D=RRSB
 7604           XTRA=3; WREG=ACCR
 7605        %FINISH
 7606        CSEXP(WREG,JJ);                   ! INTEGER OR LONGREAL MODE
 7607        PF3(JAT,B,0,XTRA);                ! JUMP ACC >0
 7608        PSF1(D,0,0)
 7609        %IF WREG=BREG %THEN PF1(SBB,0,TOS,0)
 7610        GRUSE(WREG)=0
 7611        NEST=WREG
 7612        P=P+1
 7613        ->OKEXIT
 7614  ADHOC(7):                               ! CHARNO(=45) & LENGTH(=36)
 7615        P=P+5
 7616        %IF PARMARR#0 %AND SNNO=45 %THEN CNAME(Z,DR) %ELSE CNAME(4,BREG)
 7617        ERRNO=22
 7618        ->ERREXIT %UNLESS TYPE=5 %AND ROUT=0
 7619        P=P+2
 7620        %IF SNNO#36 %THEN %START
 7621           %IF PARMARR=0=PARMCHK %THEN %START
 7622              PF1(STB,0,TOS,0)
 7623              CSEXP(BREG,16_51)
 7624              PF1(ADB,0,TOS,0)
 7625           %FINISH %ELSE %START;          ! FRIG BND CHECK FOR PARM=ARR
 7626              GET WSP(JJ,2)
 7627              %IF Z=2 %OR Z=5 %THEN B=INCA %ELSE B=MODD
 7628              PSF1(B,0,1)
 7629              PSF1(STD,1,JJ)
 7630              CSEXP(BREG,16_51)
 7631              PSF1(LD,1,JJ)
 7632              PSF1(SBB,0,1)
 7633              PF1(MODD,0,BREG,0)
 7634              GRUSE(DR)=0
 7635              PSF1(ADB,1,JJ+4)
 7636           %FINISH
 7637           P=P+1
 7638           GRUSE(BREG)=0
 7639        %FINISH
 7640        DISP=MAPDES(3)
 7641        AREA=PC; ACCESS=3
 7642        STNAME=-1 %IF Z=1;                ! CANT REMEBER NAME
 7643        SNPTYPE=SNPTYPE+16_1C00
 7644        ->OKEXIT
 7645  ADHOC(12):                              ! PI(=52)
 7646  ADHOC(8):                               ! NL(=38). THIS FN IS PICKED OFF
 7647        NEST=0;                           ! IN CSEXP.ONLY COMES HERE IN
 7648        P=P+1
 7649        ->OKEXIT;                         ! ERROR EG NL=A+B
 7650  ADHOC(9):                               ! TOSTRING(=46)
 7651        CSEXP(ACCR,16_51);                ! RET EXPSN
 7652        P=P+1
 7653        RTOS(BREG)
 7654        DISP=MAPDES(3)
 7655        AREA=PC; ACCESS=3
 7656        SNPTYPE=SNPTYPE+16_1C00
 7657        ->OKEXIT
 7658  ADHOC(10):                              ! RECORD(=48)
 7659        %IF RECTB=0 %THEN JJ=16_1800FFFF %AND STORECONST(RECTB,4,ADDR(JJ))
 7660        %IF REG=ACCR %THEN %START
 7661           CSEXP(ACCR,16_51)
 7662           PF1(LUH,0,PC,RECTB)
 7663        %FINISH %ELSE %START
 7664           CSEXP(BREG,16_51)
 7665           PF1(LDTB,0,PC,RECTB)
 7666           PF1(LDA,0,BREG,0)
 7667        %FINISH
 7668        P=P+1
 7669        GRUSE(REG)=0
 7670        OLDI=0; ACC=16_FFFF
 7671        SNPTYPE=SNPTYPE+16_1C00;          ! ADD MAP BITS
 7672        ->OKEXIT
 7673  ADHOC(11):                              ! ARRAY(=49)
 7674        CSEXP(ACCR,16_51);                ! ADDR(A(0)) TO ACCR
 7675        ERRNO=22
 7676        ->ERREXIT %UNLESS A(P+4)=4 %AND A(P+5)=1
 7677        REGISTER(ACCR)=1; OLINK(ACCR)=ADDR(R)
 7678        R=0; R_PTYPE=16_51
 7679        R_FLAG=9; R_XB=ACCR
 7680        P=P+6; CNAME(12,0)
 7681        %IF R_FLAG#9 %THEN PF1(LSS,0,TOS,0)
 7682        REGISTER(ACCR)=0
 7683        ->ERREXIT %UNLESS A(P)=2 %AND ARR>0
 7684        P=P+2
 7685        CREATE AH(0)
 7686        %RETURN
 7687  ADHOC(13):                              ! EVENTINF(=33) & EVENTLINE
 7688        D=ONINF(LEVEL)
 7689        FAULT(16,SNNAME) %IF D=0
 7690        D=D+4 %IF SNNO#33
 7691        GET IN ACC(ACCR,1,0,LNB,D)
 7692        GRUSE(ACCR)=0
 7693        NEST=ACCR
 7694        ->OKEXIT
 7695  ADHOC(14):                              ! LENGTHEN AND SHORTEN
 7696        D=(SNNO&3)*8
 7697        CSEXP(ACCR,16_62517261>>D&255)
 7698        P=P+1; NEST=ACCR
 7699        ->OKEXIT
 7700  ADHOC(15):                              ! PPROFILE(IGNORED UNLESS PARM SET)
 7701        PPJ(0,22) %UNLESS PARMPROF=0
 7702  OKEXIT:                                 ! NORMAL EXIT
 7703        PTYPE=SNPTYPE; UNPACK
 7704        %RETURN
 7705  ERREXIT:                                ! ERROR EXIT
 7706        FAULT(ERRNO,SNNAME)
 7707        BASE=0; DISP=0; ACCESS=0; AREA=0
 7708        P=PIN+2; SKIP APP
 7709        P=P-1; %RETURN
 7710  %INTEGERFN OPTMAP
 7711  !***********************************************************************
 7712  !*       LOOK FOR EXPRESSION LIKE INTEGER(ADDR(X)) AND AVOID USING DR  *
 7713  !***********************************************************************
 7714  %INTEGER VARNAME,REXP,PP,CVAL,OP,XYNB
 7715           %IF 3<=Z<=4 %OR SNNO=42 %OR SNNO=32 %OR SNNO=61 %THEN %RESULT=0
 7716           PP=P+2; REXP=FROM AR2(PP)+PP;  ! TO REST OF EXP
 7717           VARNAME=FROM AR2(PP+4);             ! SHOULD BE ADDR
 7718           %RESULT=0 %UNLESS A(PP+2)=4 %AND A(PP+3)=1
 7719           COPY TAG(VARNAME);             ! CHECK IT WAS ADDR
 7720           ->WASADR %IF PTYPE=SNPT %AND K=14 %AND A(PP+6)=1
 7721           ->WASLOC %IF PTYPE&16_FBFF=16_51 %AND A(PP+6)=2=A(PP+7)
 7722           %RESULT=0
 7723  WASADR:  PP=PP+10
 7724           %RESULT=0 %UNLESS A(PP)=4 %AND A(PP+1)=1 %AND A(PP+4)=2=A(PP+5) %AND A(PP+6)=2=A(PP+7) %AND A(PP+8)=2
 7725           VARNAME=FROM AR2(PP+2); COPY TAG(VARNAME)
 7726           %RESULT=0 %UNLESS PTYPE&16_FF0C=0
 7727           %IF A(REXP)=2 %THEN P=REXP+2 %ELSE %START
 7728              OP=A(REXP+1)
 7729              %RESULT=0 %UNLESS 1<=OP<=2 %AND A(REXP+2)=2 %AND A(REXP+3)=16_41 %AND A(REXP+6)=2
 7730              CVAL=FROM AR2(REXP+4)
 7731              %IF OP=1 %THEN K=K+CVAL %ELSE K=K-CVAL
 7732              %RESULT=0 %IF K<0
 7733              P=REXP+8
 7734           %FINISH
 7735           BASE=I
 7736           DISP=K; AREA=-1; ACCESS=0
 7737           AREA=AREA CODE
 7738           %RESULT=1
 7739  
 7740  WASLOC:                                 ! FORM INTEGER(NAME+CONST)
 7741           CVAL=0
 7742           %IF A(REXP)=2 %THEN PP=REXP+2 %AND ->FETCH
 7743           %RESULT=0 %UNLESS A(REXP+1)=1 %AND A(REXP+2)=2
 7744           %IF A(REXP+3)=16_41 %AND A(REXP+6)=2 %THEN CVAL=FROM AR2(REXP+4) %AND PP=REXP+8 %AND ->FETCH
 7745           %IF A(REXP+3)=16_51 %AND A(REXP+8)=2 %THEN CVAL=FROM AR4(REXP+4) %AND PP=REXP+10 %AND ->FETCH
 7746           %RESULT=0
 7747  FETCH:   %RESULT=0 %UNLESS CVAL&3=0 %AND CVAL>>20=0;! MAX FOR XNB+N
 7748           XYNB=XORYNB(9,VARNAME)
 7749           %UNLESS GRUSE(XYNB)=9 %AND GRINF1(XYNB)=VARNAME %START
 7750              AREA=-1; BASE=I
 7751              PSORLF1(LDCODE(XYNB),2*NAM,AREA CODE,K)
 7752              GRUSE(XYNB)=9; GRINF1(XYNB)=VARNAME
 7753           %FINISH
 7754           P=PP; AREA=XYNB
 7755           ACCESS=0; DISP=CVAL
 7756           %RESULT=1
 7757  %END
 7758           %ROUTINE RTOS(%INTEGER REG)
 7759  !***********************************************************************
 7760  !*       PLANTS CODE TO CONVERT A SYMBOL IN ACC TO A ONE               *
 7761  !*       CHARACTER STRING IN A TEMPORARARY VARIABLE.                   *
 7762  !***********************************************************************
 7763           %INTEGER KK
 7764           GET WSP(KK,1);               ! GET 1 WORD WK AREA
 7765           STRINGL=1; DISP=KK+2
 7766           PF1(OR,0,0,256)
 7767           PSF1(ST,1,KK)
 7768           GET IN ACC(REG,1,0,LNB,PTR OFFSET(RBASE))
 7769           %IF REG=BREG %THEN KK=ADB %ELSE KK=IAD
 7770           PSF1(KK,0,DISP)
 7771           GRUSE(BREG)=0
 7772           %END
 7773           %END;                        ! OF ROUTINE CSNAME
 7774  %ROUTINE CANAME(%INTEGER ARRP,BS,DP)
 7775  !***********************************************************************
 7776  !*       BS & DP DEFINE THE POSITION OF THE ARRAY HEAD                 * 
 7777  !*       ARRP=1 FOR ARRAYS,2 FOR VECTORS,3 FOR ARRAYS IN RECORDS       *
 7778  !*       BASIC DISP = DISPMNT OF A(0) FOR VECTORS OR ARRAYS IN RECORDS *
 7779  !***********************************************************************
 7780  %INTEGER HEAD1,HEAD2,HEAD3,NOPS,PTYPEP,KK,PP,JJ,SOLDI,TYPEP,ARRNAME,Q,PRECP,ELSIZE,NAMINF,BOT1,BOT2,BOT3,DVD,VMYOP
 7781        PP=P; TYPEP=TYPE
 7782        JJ=J; PTYPEP=PTYPE; PRECP=PREC; SOLDI=OLDI
 7783        %IF TYPE<=2 %THEN ELSIZE=BYTES(PRECP) %ELSE ELSIZE=ACC
 7784        DVD=SNDISP;                       ! LOCATION OF DV IF CONSTANT
 7785        ARRNAME=FROM AR2(P);              ! NAME OF ENTITY
 7786        NAMINF=TAGS(ARRNAME)
 7787        FAULT(29,ARRNAME) %IF ARR=3;      ! ARRAYFORMAT USED AS ARRAY
 7788        NAMINF=-2 %AND DVD=0 %IF ARRP>2;  ! ARRAYS IN RECORDS 
 7789        TEST APP(Q);                      ! COUNT NO OF SUBSCRIPTS
 7790  !
 7791  ! CHECK CORRECT NO OF SUBSCRIPTS PROVIDED. HOWEVER ENTITIES DECLARED
 7792  ! AS %<TYPE>ARRAYNAME HAVE NO DIMENSION . THIS SECTION SETS THE
 7793  ! DIMENSION FROM THE FIRST USE OF THE NAME.
 7794  !
 7795        %IF JJ=0 %THEN %START;            ! 0 DIMENSIONS = NOT KNOWN
 7796           REPLACE1(TCELL,FROM1(TCELL)!Q);! DIMSN IS BOTTOM 4 BITS OF TAG
 7797           JJ=Q
 7798        %FINISH
 7799        %IF JJ=Q#0 %THEN %START;          ! IN LINE CODE
 7800  !
 7801  ! FOR IN-LINE CODE WE SET UP A CHAIN OF REVERSE POLISH OPERATIONS TO
 7802  ! EVALUATE THE VARIOUS SUBSCRIPTS,MULTIPLY BY THE MULTIPLIERS AND
 7803  ! ADD THEM TOGETHER.
 7804  !
 7805           NOPS=0;HEAD1=0;HEAD2=0;HEAD3=0;! CLEAR LISTHEADS
 7806           BOT1=0; BOT3=0
 7807  !
 7808  ! NOW PROCESS THE SUBSCRIPTS CALLINR TORP TO CONVERT THE EXPRESSIONS
 7809  ! TO REVERSE POLISH AND ADDING THE EXTRA OPERATIONS.
 7810  !
 7811           P=PP+3
 7812           %CYCLE KK=1,1,JJ;                ! THROUGH THE SUBSCRIPTS
 7813              P=P+3; BOT2=0
 7814              TORP(HEAD2,BOT2,NOPS);      ! SUBSCRIPT TO REVERSE POLISH
 7815              P=P+1
 7816  !
 7817  ! MULTIPLIERS ARE DOPE VECTOR ITEMS (OPTYPE=3)
 7818  !
 7819  ! N SUBSCRIPTS WILL REQUIRE (N-1) MULTIPLICATIONS AND ADDITIONS
 7820  !
 7821              NOPS=(NOPS+1)!1<<24;          ! DVM AS '*'
 7822              PUSH(HEAD3,33,PTYPEP<<16!ARRNAME,ELSIZE);! DOPE VECTOR MULTIPLY
 7823              BOT3=HEAD3 %IF BOT3=0
 7824              VMYOP=KK<<24!JJ<<16!DVD
 7825              PUSH(HEAD3,1<<16,VMYOP,BS<<18!DP);! MULTIPLIER
 7826              %IF HEAD1=0 %THEN HEAD1=HEAD2 %ELSE ASLIST(BOT1)_LINK=HEAD2
 7827              BOT1=BOT2; HEAD2=0
 7828           %REPEAT
 7829  !
 7830  ! ADD OPERATORS TO THE BACK OF OPERANDS AND EVALUATE
 7831  !
 7832           ASLIST(BOT1)_LINK=HEAD3
 7833           BOT1=BOT3
 7834           EXPOP(HEAD1,BREG,NOPS,16_251);    ! EVALUATE THE REVERSE POLISH LIST
 7835                                         ! CONSTANT ACCEPTABLE AS RESULT
 7836           ASLIST(BOT1)_LINK=ASL
 7837           ASL=HEAD1
 7838           BASE=BS; DISP=DP; ACCESS=3; AREA=-1
 7839           %IF EXPOPND_FLAG<=1 %START;    ! EVALUATED TO CONSTANT
 7840              NUMMOD=EXPOPND_D;           ! VALUE OF CONSTANT
 7841              %IF NUMMOD<0 %THEN GETINACC(BREG,1,0,0,NUMMOD) %ELSE ACCESS=1;                ! DESCPTR WITH CONST MODIFIER
 7842           %FINISH
 7843        %FINISH %ELSE %START
 7844              %IF JJ>Q %THEN FAULT2(20,JJ-Q,ARRNAME) %ELSE FAULT2(21,Q-JJ,ARRNAME)
 7845              P=P+2; SKIP APP
 7846              BASE=BS; DISP=0; ACCESS=3; AREA=-1
 7847        %FINISH
 7848        ACC=ELSIZE
 7849        PTYPE=PTYPEP; UNPACK; J=JJ
 7850        OLDI=SOLDI;                       ! FOR NAME==A(EL) VALIDATION
 7851  %END;                                   ! OF ROUTINE CANAME
 7852  %ROUTINE CNAME(%INTEGER Z, REG)
 7853  !***********************************************************************
 7854  !*       THIS IS THE MAIN ROUTINE FOR PROCESSING NAMES.CANAME,CSNAME   *
 7855  !*       AND CRNAME ARE ONLY CALLED FROM HERE,THE NAME (AND ANY PARAMS *
 7856  !*       OR SUBNAMES) ARE ACCESSED BY P WHICH IS ADVANCED.             *
 7857  !*       Z SPECIFIES ACTION AS FOLLOWS:-                               *
 7858  !*       Z=0 COMPILE A ROUTINE CALL                                    *
 7859  !*       Z=1 SET ACCESS,AREA AND DISP FOR A 'STORE' OPERATION          *
 7860  !*       Z=2 FETCH NAME TO 'REG'                                       *
 7861  !*       Z=3 SET DESCRIPTOR IN REG FOR PASSING BY NAME                 *
 7862  !*       Z=4 SET 32 BIT ADDRESS OF NAME IN REG                         *
 7863  !*       Z=5 DELAYED FETCH IF NAME SIMPLE ELSE AS Z=2                  *
 7864  !*       Z=6 STORE 'REG' (CONTAINS POINTER) INTO POINTER VARIABLE      *
 7865  !*       Z=7->11  NOT NOW USED                                         *
 7866  !*       Z=12 SET BASE AND DISP TO POINT TO ARRAYHEAD                  *
 7867  !*       Z=13 SET REG TO POINT TO 4 WORD ROUTINE DISCRIPTOR            *
 7868  !*              (INTERNAL ROUTINES FIRST CREATE THE DISCRIPTOR)        *
 7869  !*       Z=14 STORE 'REG' INTO A RECORD NAME VARIABLE                  *
 7870  !*       Z=15 SET 'REG' TO POINT TO A RECORD                           *
 7871  !*       Z=16 SET BASE AND DISP  FOR RECORD                            *
 7872  !*                                                                     *
 7873  !*       REG (WHERE APPROPRIATE) IS SET AS FOLLOWS:-                   *
 7874  !*       >=0  A REGISTER                                               *
 7875  !*       -1   MEANS CHOOSE ANY REGISTER                                *
 7876  !*       IF A REGISTER IS CHOSEN THEN NEST IS SET WITH CHOICE          *
 7877  !***********************************************************************
 7878  %INTEGER JJ, JJJ, KK, RR, LEVELP, DISPP, NAMEP, PP, SAVESL, FNAME
 7879  %SWITCH S, FUNNY(12:13), SW(0:8), MAP(0:3)
 7880           PP=P
 7881           FNAME=A(P)<<8+A(P+1)
 7882           %IF Z=1 %OR Z=6 %THEN STNAME=FNAME
 7883           COPYTAG(FNAME)
 7884           %IF I=-1 %THEN %START
 7885              FAULT(16, FNAME)
 7886              I=RLEVEL;  J=0;  K=FNAME
 7887              KFORM=0; SNDISP=0; ACC=4
 7888              PTYPE=7;  STORE TAG(K, N)
 7889              K=N;  N=N+4;  COPYTAG(FNAME);! SET USE BITS!
 7890           %FINISH
 7891           SAVESL=ACC
 7892           JJ=J;  JJ=0 %IF JJ=15
 7893           NAMEP=FNAME
 7894           LEVELP=I;  DISPP=K
 7895           FAULT(29, FNAME) %IF LITL=1 %AND ROUT=0=NAM %AND (Z=1 %OR Z=3 %OR (Z=4 %AND TYPE<5 %AND ARR=0))
 7896           ->NOT SET %IF TYPE=7
 7897           %IF (Z=0 %AND (ROUT#1 %OR 0#TYPE#6)) %OR (Z=13 %AND ROUT=0) %THEN FAULT2(27,0,FNAME) %AND ->NOT SET
 7898           ->FUNNY(Z) %IF Z>=10
 7899           ->RTCALL %IF ROUT=1
 7900           ->SW(TYPE)
 7901  SW(6):
 7902  SW(4):                                  !RECORD FORMAT NAME
 7903           FAULT2(5, 0, FNAME)
 7904  SW(7):
 7905  NOT SET:                                ! NAME NOT SET
 7906           NEST=0;  BASE=I;  DISP=K;  ACCESS=0
 7907           AREA=LNB; PTYPE=1;  UNPACK
 7908           P=P+2; SKIP APP;  ->CHKEN
 7909  FUNNY(12):                              ! SET BASE & DISP FOR ARRAYHEAD
 7910           ->SW(3) %IF TYPE=3 %AND (ARR=0 %OR A(P+2)=1)
 7911           %IF PTYPE=SNPT %THEN CSNAME(12,REG) %AND ->CHKEN
 7912           %IF A(P+2)=2 %THEN P=P+3 %ELSE NO APP
 7913           ACCESS=0; BASE=I; DISP=K; AREA=-1
 7914  ADJUST HEAD:
 7915           %IF ARR=1=J %AND PARMARR=0=NAM %AND PARMCHK=0 %AND TYPE<=3 %START;             ! ADJUST DESR TO 1ST ELMNT
 7916              GET WSP(JJ,4)
 7917              GET IN ACC(ACCR,4,ACCESS,AREA CODE,DISP)
 7918              PSF1(ST,1,JJ)
 7919              GET IN ACC(BREG,1,2,LNB,JJ+8);                          
 7920              %IF TYPE=3 %THEN KK=ACC %ELSE KK=BYTES(PREC)
 7921              PSF1(MYB,0,KK) %UNLESS KK=1
 7922              PSF1(LD,1,JJ)
 7923              PF1(INCA,0,BREG,0);         ! ADJUST DESCRPTR
 7924              PSF1(STD,1,JJ)
 7925              GRUSE(DR)=0; GRUSE(ACCR)=0
 7926              GRUSE(BREG)=0; AREA=LNB; DISP=JJ
 7927           %FINISH
 7928           ->CHKEN
 7929  S(12):                                  ! ARRAYS IN RECORDS BY NAME
 7930           NAMEOP(1,ACCR,16,NAMEP);       ! Z=STORE TO UPDATE BASE&DISP
 7931           ->ADJUST HEAD
 7932  FUNNY(13):                              ! LOAD ADDR FOR RT-TYPE
 7933           %IF PTYPE=SNPT %THEN CSNAME(Z,REG) %AND P=P+1 %AND->CHKEN
 7934           DISP=MIDCELL; BASE=I
 7935           %IF NAM&1#0 %THEN %START
 7936              AREA=-1
 7937              GET IN ACC(REG,4,0,AREA CODE,DISP)
 7938           %FINISH %ELSE %START
 7939              %IF J=14 %THEN %START;      ! EXTERNAL ROUTINE PASSED
 7940                 GET IN ACC(REG,2,0,0,0); ! ZERO ENVIRONMENT
 7941                 GET IN ACC(DR,2,0,SET XORYNB(-1,-1),DISP)
 7942  !               PSF1(MODD,0,0);          ! PROVOKE ESCAPE IF DYNAMIC
 7943              %FINISH %ELSE %START
 7944                 %IF BASE=0 %AND CPRMODE=2 %START;! IN FILE OF RTS
 7945                    PSF1(LD,1,12)
 7946                    PSF1(INCA,0,DISP) %UNLESS DISP=0
 7947                    GET IN ACC(ACCR,2,0,0,0)
 7948                 %FINISH %ELSE %START
 7949                    PSF1(JLK,0,1);           ! GET PC TO TOS
 7950                    RTJUMP(LDA,ASLIST(TAGS(FNAME))_S2);! ADD N TO POINT @ ENTRY
 7951                    PF1(INCA,0,TOS,0);       ! AND TO DES REG
 7952                    JJ=16_E0000001
 7953                    STORE CONST(JJJ,4,ADDR(JJ))
 7954                    PF1(LDTB,0,PC,JJJ)
 7955                    GET IN ACC(ACCR,1,0,LNB,PTR OFFSET(BASE))
 7956                    JJ=M'IMP'
 7957                    STORE CONST(JJJ,4,ADDR(JJ))
 7958                    PF1(LUH,0,PC,JJJ);    ! SPARE FIELD IN RT HDDR
 7959                 %FINISH
 7960              %FINISH
 7961              PF1(STD,0,TOS,0);           ! DR TO TOP OF STACK
 7962              PF1(LUH,0,TOS,0);           ! AND TO TOP 64 BITS OF ACC
 7963              GRUSE(DR)=0
 7964           %FINISH
 7965           %IF A(P+2)=2 %THEN P=P+3 %ELSE NO APP; ->CHKEN
 7966  SW(3):                                 ! RECORD
 7967           CRNAME(Z, REG, 2*NAM, I, -1, K, NAMEP)
 7968           ->S(Z) %IF Z>=10
 7969           STNAME=NAMEP %IF Z=1 %OR Z=6
 7970           ->STRINREC %IF TYPE=5 %AND Z#6
 7971           ->NOT SET %IF TYPE=7
 7972           NAMEOP(Z,REG,BYTES(PREC),NAMEP)
 7973           ->CHKEN
 7974  SW(5):                                  ! TYPE =STRING
 7975  !
 7976  ! ALL STRING OPERATIONS ARE ON THE RELEVANT DESCRIPTOR. Z=2 &Z=5
 7977  ! REQUIRE A CURRENT LENGTH(IE MODIFIED) DESCRIPTOR. OTHER OPERATIONS
 7978  ! REQUIRE THE MAX LENGTH DESCRIPTOR (IE UNMODIFIED HEADER)
 7979  !
 7980           %IF Z=6 %THEN ->SW(1)
 7981           ->STRARR %IF ARR>=1
 7982           %IF A(P+2)=2 %THEN P=P+3 %ELSE NO APP
 7983           BASE=I; ACCESS=2; AREA=-1; DISP=K
 7984  SNINREC:         %IF Z=1 %THEN Z=3;     ! STRINGNAMES IN RECORDS
 7985           %IF Z=3 %OR Z=4 %THEN NAMEOP(Z,REG,8,-1) %AND ->CHKEN
 7986           %IF ACCESS=2 %AND PARMCHK=0 %AND REGISTER(DR)=0 %START
 7987              PSORLF1(LDB,2,AREA CODE,DISP);! LOAD BND & DR IN 1 INSTRN
 7988              GRUSE(DR)=0
 7989              %IF REG=ACCR %THEN COPY DR
 7990              ->CHKEN
 7991           %FINISH
 7992           NAMEOP(3,DR,8,-1)
 7993  MBND:    %IF PARMCHK=1 %THEN TEST ASS(DR,5,8)
 7994           PF1(LDB,2,7,0);                ! LBOUND FIRST BYTE=CURRENT L
 7995           %IF REG=ACCR %THEN COPY DR
 7996           ->CHKEN
 7997  STRARR:                                 ! STRINGARRAYS &  ARRAYNAMES
 7998           CANAME(ARR, I, K)
 7999           NAMEP=-1
 8000           %IF Z=1 %OR Z=6 %THEN STNAME=NAMEP
 8001  SAINREC:                                ! STRING ARRAYS IN RECORDS
 8002           %IF Z=1 %OR Z=3 %THEN %START
 8003              %IF NAM=1 %THEN %START
 8004                 GET IN ACC(DR,2,0,AREA CODE,DISP+8);! DV DR
 8005                                          ! CANAME WILL HAVE SET J=DIMEN
 8006                                          ! FOR ALL CASES INCLUDING RECORDS
 8007                 PF1(SLB,1,0,1+3*(J-1));  ! STACK MODIFIER AND
 8008                                          ! SET BREG TO STRING LENGTH
 8009              %FINISH
 8010              GET IN ACC(DR,2,0,AREA CODE,DISP)%IF AREA#7;! ALREADY IN DR
 8011              %IF NAM=1 %THEN %START
 8012                 PF1(MODD,0,TOS,0)
 8013                 PF1(LDB,0,BREG,0)
 8014              %FINISH %ELSE %START
 8015                 %IF ACCESS=1 %THEN %START
 8016                    PSF1(MODD,0,NUMMOD) %UNLESS NUMMOD=0
 8017                 %FINISH %ELSE %START
 8018                    PF1(MODD,0,BREG,0) %IF ACCESS=3
 8019                 %FINISH
 8020                 PSF1(LDB,0,ACC)
 8021              %FINISH
 8022              %IF REG=ACCR %THEN COPY DR
 8023              ->CHKEN
 8024           %FINISH
 8025           %IF Z=4 %THEN NAMEOP(Z,REG,4,-1) %AND ->CHKEN
 8026           GET IN ACC(DR,2,0,AREA CODE,DISP) %UNLESS AREA=7
 8027           %IF ACCESS=1 %THEN %START
 8028              PSF1(MODD,0,NUMMOD) %UNLESS NUMMOD=0
 8029           %FINISH %ELSE %START
 8030              PF1(MODD,0,BREG,0) %IF ACCESS=3
 8031           %FINISH
 8032           ->MBND
 8033  STRINREC:                               ! STRINGS IN RECORDS
 8034           ->SAINREC %IF ARR#0
 8035           ->SNINREC %IF NAM#0 %OR Z=4
 8036  !
 8037  ! STRINGS IN RECORDS HAVE NO HEADER AND ARE SPECIAL
 8038  !
 8039           NAMEOP(4,BREG,4,-1)
 8040           PF1(LDTB,0,PC,PARAM DES(3))
 8041           PF1(LDA,0,BREG,0)
 8042           PSF1(LDB,0,ACC) %UNLESS Z=2 %AND PARMCHK=0
 8043           GRUSE(DR)=0
 8044           ->MBND %IF Z=2
 8045           COPY DR %IF REG=ACCR
 8046           ->CHKEN
 8047  !
 8048  ! SECTION TO DEAL WITH ALL NAMES INVOLVING ROUTINE CALL
 8049  !
 8050  RTCALL:                                 ! FIRST CHECK
 8051           %IF TYPE=0 %AND Z#0 %THEN FAULT(23, FNAME) %AND ->NOT SET
 8052                                          ! RT NAME IN EXPRSN
 8053           %IF PTYPE=SNPT %THEN %START
 8054              CSNAME(Z, REG);             ! SPECIAL NAME
 8055              ->BIM %IF ROUT=1 %AND NAM>=1 %AND Z#0
 8056              %IF TYPE#0 %AND NEST=ACCR %THEN ->MVFNRES
 8057              ->CHKEN
 8058           %FINISH
 8059           CRCALL(FNAME);  P=P+1;         ! DEAL WITH PARAMS
 8060           ->CHKEN %IF PTYPE&15=0
 8061           ->UDM %IF NAM>1;               ! MAPS
 8062           %UNLESS Z=2 %OR Z=5 %THEN %START;   ! FUNCTIONS
 8063              FAULT(29, FNAME);  BASE=0
 8064              ACCESS=0;  DISP=0
 8065           %FINISH
 8066  MVFNRES: %IF TYPE=5 %THEN %START;       ! STRING FNS
 8067              %IF REG=DR %THEN PF1(ST,0,TOS,0) %AND PF1(LD,0,TOS,0)
 8068           %FINISH %ELSE %START
 8069              %IF REG=BREG %THEN %START
 8070                 BOOT OUT(BREG) %IF REGISTER(BREG)#0
 8071                 PF1(ST,0,BREG,0)
 8072              %FINISH
 8073           %FINISH
 8074           NEST=REG; ->CHKEN
 8075  UDM:                                    ! USER DEFINED MAPS
 8076           PF1(ST,0,BREG,0);              ! RETURN 32 BIT ADDR IN ACC
 8077           DISP=MAPDES(PREC)
 8078           ACCESS=3; AREA=PC
 8079           NAMEP=-1; STNAME=-1
 8080  BIM:                                    ! BUILT IN MAPS
 8081           NAMEP=-1 %AND STNAME=-1 %UNLESS AREA=PC %AND ACCESS=3
 8082           ->CHKEN %IF TYPE=3;            ! MAP RECORD USE VERY LIMITED
 8083           %IF Z=3 %OR (TYPE=5 %AND Z#4) %START
 8084              PF1(LDTB,0,PC,DISP)
 8085              %IF TYPE=5 %AND (PARMCHK#0 %OR Z#2) %THEN PSF1(LDB,0,255)
 8086              PF1(LDA,0,BREG,0)
 8087              GRUSE(DR)=0
 8088           %FINISH %ELSE %START
 8089              %IF GRUSE(DR)=7 %AND NAMEP>0 %AND GRINF1(DR)=NAMEP&16_FFFF %AND 1<=Z<=2 %THEN AREA=7
 8090                                          ! CHANGE TO(%DR+%B) FORM
 8091           %FINISH
 8092  !         NAM=0
 8093           KK=Z; KK=2 %IF Z=5
 8094           ->MAP(KK&3)
 8095  MAP(0):                                 ! FETCH ADDRESS
 8096           %IF REG#BREG %THEN GET IN ACC(ACCR,1,0,BREG,0)
 8097           ->CHKEN
 8098  MAP(1):                                 ! STORE
 8099           ->CHKEN %UNLESS TYPE=5; ->MAP(3)
 8100  MAP(2):                                 ! FETCH
 8101           %IF TYPE=5 %THEN ->MBND
 8102           GET IN ACC(REG,BYTES(PREC)>>2,ACCESS,AREA,DISP)
 8103           %IF NAMEP>0 %THEN GRUSE(DR)=7 %AND GRINF1(DR)=NAMEP
 8104           %IF PARMCHK=1 %AND PREC>=5 %THEN TEST ASS(REG,1,BYTES(PREC))
 8105           ->CHKEN
 8106  MAP(3):                                 ! SET DESCRIPTOR
 8107           %IF TYPE=5 %THEN PF1(LDB,0,0,256)
 8108           COPY DR %UNLESS REG=DR
 8109           ->CHKEN
 8110  SW(0):                                  ! %NAME PARAMETERS NO TYPE
 8111                                          ! ALLOW FETCH ADDR OPERATIONS
 8112                                          ! AND SPECIAL FOR BUILTIN MAPS
 8113           %UNLESS 3<=Z<=4 %THEN %START
 8114              FAULT2(90,0,FNAME);  TYPE=1
 8115           %FINISH
 8116  SW(1):                                  ! TYPE =INTEGER
 8117  SW(2):                                  ! TYPE=REAL
 8118           %IF ARR=0 %OR (Z=6 %AND A(P+2)=2) %THEN %START
 8119              BASE=I; ACCESS=2*NAM
 8120              DISP=K; AREA=-1
 8121              %IF A(P+2)=2 %THEN P=P+3 %ELSE NO APP
 8122           %FINISH %ELSE %START
 8123              CANAME(ARR, I, K)
 8124              NAM=0
 8125           %FINISH
 8126           NAMEOP(Z,REG,BYTES(PREC),NAMEP)
 8127           ->CHKEN
 8128  !
 8129                                          ! GENERAL FETCHING & STORING 
 8130                                          !SECTION
 8131  !
 8132  CHKEN:   %WHILE A(P)=1 %CYCLE
 8133              FAULT(69,FNAME)
 8134              P=P+3; SKIP APP
 8135           %REPEAT
 8136           P=P+1
 8137  %END
?RR unused
 8138  
 8139  %ROUTINE NAMEOP(%INTEGER Z, REG, SIZE, NAMEP)
 8140  !***********************************************************************
 8141  !*    FETCH OR STORE REG FROM OR TO VARIABLE DEFINED BY AREA ACCESS    *
 8142  !*    BASE AND DISP.                                                   *
 8143  !***********************************************************************
 8144  %SWITCH MOD(0:47)
 8145  %INTEGERFNSPEC BASEREG(%INTEGER GRUSEVAL,GRINFVAL)
 8146  %INTEGER KK, JJJ, TOTHER, XYNB, JJ, OP1, OP2
 8147        KK=Z;  KK=2 %IF Z=5
 8148        %IF Z=6 %THEN %START
 8149           FAULT2(82,0,NAMEP) %UNLESS NAM=1 %AND ROUT=0 %AND (ACCESS>=8 %OR ACCESS=2)
 8150           KK=1;  SIZE=8
 8151           %IF ACCESS>=8 %THEN ACCESS=ACCESS-4 %ELSE ACCESS=0
 8152        %FINISH
 8153        KK=KK&3
 8154        ->MOD(ACCESS<<2!KK)
 8155  !
 8156  
 8157  ! AREA AND ACCESS
 8158  !**** *** ******
 8159  ! THESE VARIABLES DEFINE HOW TO ACCESS ANY IMP VARIABLE. AREA HAS THE
 8160  ! THREE BIT AREA CODE FROM THE PRIMARY FORMAT INSTRN.(EG 6=TOS ETC)
 8161  ! THE SPECIAL CASE AREA=-1 IS USED FOR ENTITIES IN STACK FRAME 'BASE'
 8162  ! THE FN AREA CODE CONVERTS THIS CASE TO AREA=LNB OR AREA=XNB ARRANGING
 8163  ! TO LOAD XNB IF NECESSARY.
 8164  
 8165  ! ACCESS HAS TWO VERSIONS OF THE 2-BIT INDIRECTION CODE FROM PRIMARY
 8166  ! FORMAT INSTRNS:-
 8167  ! =0 VARIABLE DIRECTLY ADDRESSED IN 'AREA' BY 'DISP'
 8168  ! =1 VARIABLE ADDRESSED BY DESCPTR AT AREA & DISP MODDED BY CONST NUMMOD
 8169  ! =2 DESCRIPTOR TO VARIABLE DIRECTLY ADDRESS BY 'AREA' & 'DISP'
 8170  ! =3 DESCRIPTOR AS IN =2 IS TO BE MODIFIED BY 'B'
 8171  ! =4 VARIABLE 'XDISP' INTO RECORD DIRECTLY ADDRESSED BY 'AREA' & 'DISP'
 8172  ! =5 VARIABLE 'XDISP' INTO RECORD ADDRESSED BY DR MODIFIED AS =1
 8173  ! =6 VAR 'XDISP' INTO RECORD ADDRESSED BY DESCRIPTOR AT 'AREA' & 'DISP'
 8174  ! =7 AS =6 BUT DESCRIPTOR MODIFIED BY B
 8175  ! =8-11 AS 4-7 BUT THERE IS A DESCRIPTOR TO ITEM AT 'XDISP' INTO RECORD
 8176  
 8177  ! THESE COVER ALL THE COMMON CASES. ITEMS LIKE ARRAYS IN RECORD ARRAYS
 8178  ! NEED AN INTERMEDIATE DESCRIPTOR TO BE CALCULATED AND(USUALLY) STACKED
 8179  
 8180  !
 8181  ! NOTE THAT ACCESS=1 AS USED ON VARIABLES IS DIFFERENT FROM ACCESS=1
 8182  ! AS USED IN ACTUAL PLANTING ROUTINES PF1 ETC. THE CODE ACCESS=1  NEEDS
 8183  ! THE RELEVANT DESCRIPOR IN DR FIRST !
 8184  !
 8185  ! AREA=7 WITH ACCESS =2 OR 3 IS USED WHEN THE DESCRIPTOR IS ALREADY
 8186  ! LOADED IN DR. THIS IS AWKARD ESPECIALLY ON THE GET 32 BIT ADDR
 8187  ! CASE AND NEEDS PLANTING OF IMAGE STORE FORMAT INSTRNS
 8188  !
 8189  MOD(0):                                 ! ACCESS=0 FETCH ADDRESS
 8190        %IF TYPE=3 %THEN GETINACC(REG,1,0,AREA CODE,DISP-4) %AND %RETURN
 8191        GET IN ACC(REG,1,0,LNB,PTR OFFSET(BASE))
 8192        %IF REG=BREG %THEN JJJ=ADB %ELSE JJJ=IAD
 8193        PSF1(JJJ,0,DISP)
 8194        %IF BIMSTR=1 %THEN NOTE ASSMENT(REG,3,NAMEP)
 8195        %RETURN
 8196  MOD(1):                                 ! ACCESS=0 STORE
 8197        %IF 1<=SIZE<=2 %THEN %START;      ! BYTES & HALFS REQUIRE DESCRIPTOR
 8198           PF1(LDTB,0,PC,MAP DES(SIZE+2)) %UNLESS GRUSE(DR)=SIZE+11
 8199           PSF1(LDA,1,PTR OFFSET(BASE)) %UNLESS 12<=GRUSE(DR)<=13 %AND GRINF1(DR)=BASE
 8200           GRUSE(DR)=SIZE+11;  GRINF1(DR)=BASE
 8201           ACCESS=1;  AREA=0
 8202        %FINISH %ELSE AREA=AREA CODE
 8203        %RETURN
 8204  MOD(2):                                 ! ACCESS=0 FETCH
 8205        %IF SIZE>2 %AND Z=5 %AND PARMCHK=0 %THEN NEST=-1 %AND %RETURN
 8206  MOD(10):                                ! ACCESS=2 FETCH
 8207        %IF GRUSE(REG)>=9 %AND NAMEP>0 %THEN %START
 8208           %IF (GRINF1(REG)=NAMEP %AND GRUSE(REG)&255=9) %OR (GRINF2(REG)=NAMEP %AND GRUSE(REG)>>16=9) %START
 8209              %IF REGISTER(REG)#0 %THEN BOOT OUT(REG)
 8210              NEST=REG;  %RETURN
 8211           %FINISH
 8212        %FINISH
 8213        TOTHER=REG!!7
 8214        %IF GRUSE(TOTHER)>=9 %AND NAMEP>0 %START
 8215           KK=GRINF1(TOTHER)
 8216           %IF (KK=NAMEP %AND GRUSE(TOTHER)&255=9) %OR (GRINF2(TOTHER)=NAMEP %AND GRUSE(TOTHER)>>16=9) %START
 8217              %IF REG=BREG %AND REGISTER(BREG)=0 %START
 8218                 PF1(ST,0,BREG,0);        ! ACC TO BRGE
 8219                 GRUSE(REG)=GRUSE(TOTHER)
 8220                 GRINF1(REG)=GRINF1(TOTHER)
 8221                 GRINF2(REG)=GRINF2(TOTHER)
 8222                 NEST=REG
 8223                 %RETURN
 8224              %FINISH
 8225              %IF REG=ACCR %AND Z=2 %THEN %START
 8226                 ACCESS=0;  AREA=7
 8227                 SIZE=4;  DISP=0
 8228              %FINISH
 8229           %FINISH
 8230        %FINISH
 8231        %IF 1<=SIZE<=2 %AND ACCESS=0 %THEN %START;  ! BYTES
 8232           PF1(LDTB,0,PC,MAP DES(SIZE+2)) %UNLESS GRUSE(DR)=SIZE+11
 8233           PSF1(LDA,1,PTR OFFSET(BASE)) %UNLESS 12<=GRUSE(DR)<=13 %AND GRINF1(DR)=BASE
 8234           GRUSE(DR)=SIZE+11;  GRINF1(DR)=BASE
 8235           %IF Z=5 %AND PARMCHK=0 %START
 8236              ACCESS=1;  AREA=0;  NEST=-1;  %RETURN
 8237           %FINISH
 8238           GET IN ACC(REG,1,1,0,DISP)
 8239           %IF PARMCHK#0 %AND SIZE=2 %THEN TEST ASS(REG,TYPE,SIZE)
 8240           NEST=REG;  %RETURN
 8241        %FINISH
 8242  MOD(14):                                ! ACCESS=3 FETCH
 8243        %IF ACCESS>=2 %AND(AREA=7 %OR  (GRUSE(DR)=7 %AND NAMEP>0 %AND GRINF1(DR)=NAMEP&16_FFFF)) %THEN AREA=7 %AND DISP=0 %ELSE AREA=AREA CODE
 8244  DRFETCH:
 8245        GET IN ACC(REG,SIZE>>2,ACCESS,AREA,DISP)
 8246        %IF PARMCHK=1 %AND SIZE#1 %THEN TEST ASS(REG,TYPE,SIZE)
 8247        %IF (ACCESS=0 %OR ACCESS=2) %AND NAMEP>0 %THEN GRUSE(REG)=9 %AND GRINF1(REG)=NAMEP
 8248        %IF ACCESS>=2 %AND NAMEP>0 %THEN GRUSE(DR)=7 %AND GRINF1(DR)=NAMEP&16_FFFF
 8249        NEST=REG;  %RETURN
 8250  MOD(3):                                 ! ACCESS=0 SET DESCRIPTOR
 8251        ABORT %UNLESS REG=ACCR %OR REG=DR
 8252        %IF TYPE=3 %THEN %START
 8253           GET IN ACC(REG,2,0,AREA CODE,DISP-8);    ! PTR BEFORE START
 8254           %RETURN
 8255        %FINISH %ELSE JJJ=PARAM DES(PREC)
 8256  
 8257        %IF REG=ACCR %THEN %START
 8258           GET IN ACC(REG,1,0,LNB,PTR OFFSET(BASE))
 8259           OP1=IAD;  OP2=LUH
 8260        %FINISH %ELSE %START
 8261           PSF1(LDA,1,PTR OFFSET(BASE))
 8262           OP1=INCA;  OP2=LDTB
 8263        %FINISH
 8264        PSF1(OP1,0,DISP)
 8265        PF1(OP2,0,PC,JJJ)
 8266        GRUSE(REG)=0
 8267        %RETURN
 8268  MOD(4):                                 ! ACCESS=1 FETCH ADDRESS
 8269        JJ=NUMMOD
 8270        JJ=JJ*BYTES(PREC) %IF PREC>4;     ! HALF COME WITH BYTE MODIFIER
 8271        ->MD20
 8272  MOD(20):                                ! ACCESS=5 FETCH ADDRESS
 8273        JJ=NUMMOD+XDISP
 8274  MD20: GET IN ACC(REG,1,0,AREA CODE,DISP+4);! BACK HALF OF DESCTR
 8275        %IF REG=ACCR %THEN OP1=IAD %ELSE OP1=ADB
 8276        PSF1(OP1,0,JJ) %UNLESS JJ=0
 8277        %RETURN
 8278  MOD(7):                                 ! ACCESS=1 SET DESCRIPTOR
 8279        JJ=NUMMOD
 8280        JJ=JJ*BYTES(PREC) %IF PREC>4;     ! HALF COME WITH BYTE MODIFIER
 8281        GET IN ACC(REG,2,0,AREA CODE,DISP);! DESCTR
 8282        %IF REG=ACCR %THEN OP1=IAD %ELSE OP1=INCA
 8283        PSF1(OP1,0,JJ) %UNLESS JJ=0
 8284        %RETURN
 8285  MOD(5):                                 ! ACCESS=1 STORE
 8286  MOD(6):                                 ! ACCESS=1 FETCH
 8287        %IF NUMMOD=0 %THEN ACCESS=2 %AND ->MOD(KK+8)
 8288  
 8289        %UNLESS GRUSE(DR)=7 %AND NAMEP>0 %AND GRINF1(DR)=NAMEP&16_FFFF %THEN GET IN ACC(DR,2,0,AREA CODE,DISP)
 8290        %IF NAMEP>0 %THEN GRUSE(DR)=7 %AND GRINF1(DR)=NAMEP&16_FFFF
 8291        AREA=0; DISP=NUMMOD
 8292        ->DRFETCH %IF Z=2
 8293        %RETURN
 8294  MOD(12):                                ! ACCESS=3 FETCH ADDRESS
 8295        JJJ=BYTES(PREC)
 8296  !
 8297  ! REMEMBER HALF INTEGERS READY SCALED BY VMY OR IN CANAME
 8298  !
 8299        PSF1(MYB,0,JJJ) %AND GRUSE(BREG)=0 %UNLESS JJJ=1 %OR PREC=4
 8300  MD12: %IF REG=BREG %THEN %START
 8301           %IF AREA=7 %START
 8302              PF1(INCA,0,BREG,0)
 8303              GRUSE(DR)=0
 8304              PF1(LB,2,0,11);             ! DR BTM HALF TO B VIA IMAGE STORE INSTRUCTION
 8305           %FINISH %ELSE PF1(ADB,0,AREA CODE,DISP+4)
 8306           GRUSE(BREG)=0
 8307           %RETURN
 8308        %FINISH
 8309  MOD(8):                                 ! ACCESS=2 FETCH ADDRESS
 8310        %IF AREA=7 %THEN GET IN ACC(REG,1,2,0,11) %ELSE GET IN ACC(REG,1,0,AREA CODE,DISP+4)
 8311        %IF ACCESS&3=3 %THEN PF1(IAD,0,BREG,0)
 8312        %RETURN
 8313  MOD(9):                                 ! ACCESS=2 STORE
 8314  MOD(13):                                ! ACCESS=3 STORE
 8315        %IF AREA=7 %THEN DISP=0 %AND %RETURN
 8316        %IF GRUSE(DR)=7 %AND NAMEP>0 %AND GRINF1(DR)=NAMEP&16_FFFF %THEN AREA=7 %AND DISP=0 %ELSE AREA=AREA CODE
 8317        %RETURN
 8318  MOD(11):                                ! ACCESS=2 SET DESCRIPTOR
 8319        %IF AREA=7 %THEN %START
 8320           COPY DR %UNLESS REG=DR
 8321           %RETURN
 8322        %FINISH
 8323        GET IN ACC(REG,2,0,AREA CODE,DISP)
 8324        %RETURN
 8325  MOD(15):                                ! ACCESS=3 SET DESCRIPTOR
 8326        GET IN ACC(DR,2,0,AREA CODE,DISP) %UNLESS AREA=7
 8327        %IF PREC=4 %OR(TYPE=3 %AND PARMARR=0) %THEN JJ=INCA %ELSE JJ=MODD
 8328        PF1(JJ,0,BREG,0)
 8329        %IF REG#DR %THEN COPY DR
 8330        GRUSE(DR)=0
 8331        %RETURN
 8332  MOD(17):                                ! ACCESS=4 STORE
 8333  MOD(18):                                ! ACCESS=4 FETCH
 8334        %IF SIZE=1 %THEN DISP=DISP-8 %AND ->MD2526
 8335        DISP=DISP+XDISP
 8336        ACCESS=0
 8337        ->MOD(KK);                        ! REDUCES TO ACCESS=0
 8338  MOD(36):                                ! ACCESS=9 FETCH ADDRESS
 8339  MOD(37):                                ! ACCESS=9 STORE
 8340  MOD(38):                                ! ACCESS=9 FETCH
 8341  MOD(39):                                ! ACCESS=9 SET DESCRIPTOR
 8342        XYNB=BASEREG(8,NAMEP&16_FFFF)
 8343        DISP=NUMMOD+XDISP; AREA=XYNB
 8344        ACCESS=3; NAMEP=0
 8345        ->MOD(KK+8);                      ! HAS REDUCED TO ACCESS=2
 8346  MOD(16):                                ! ACCESS=4 FETCH ADDRESS
 8347        DISP=DISP-8
 8348  MOD(24):                                ! ACCESS=6 FETCH ADDRESS
 8349        GET IN ACC(REG,1,0,AREA CODE,DISP+4)
 8350        %IF REG=BREG %THEN KK=ADB %ELSE KK=IAD
 8351        PSF1(KK,0,XDISP) %UNLESS XDISP=0
 8352        %RETURN
 8353  MD2526:
 8354  MOD(25):                                ! ACCESS=6 STORE
 8355  MOD(26):                                ! ACCESS=6 FETCH
 8356        %IF SIZE>2 %START
 8357           XYNB=BASEREG(8,NAMEP&16_FFFF)
 8358           AREA=XYNB;  ACCESS=0
 8359           DISP=XDISP; ->MOD(KK)
 8360        %FINISH
 8361        %IF SIZE=1 %THEN %START;          ! SIZE = 1 FOR BYTES
 8362           PSORLF1(LD,0,AREA CODE,DISP) %UNLESS GRUSE(DR)=7 %AND NAMEP>0 %AND GRINF1(DR)=NAMEP&16_FFFF
 8363        %FINISH %ELSE %START;             ! SIZE=2 FOR HALFS
 8364           PF1(LDTB,0,PC,MAP DES(4)) %UNLESS GRUSE(DR)=13 %OR GRUSE(DR)=15
 8365           PSORLF1(LDA,0,AREA CODE,DISP+4) %UNLESS NAMEP>0 %AND GRINF1(DR)=NAMEP&16_FFFF %AND (GRUSE(DR)=7 %OR GRUSE(DR)=15)
 8366        %FINISH
 8367        GRUSE(DR)=0
 8368        %IF NAMEP>0 %THEN GRUSE(DR)=8*SIZE-1 %AND GRINF1(DR)=NAMEP&16_FFFF
 8369        ACCESS=1;  AREA=0
 8370        DISP=XDISP
 8371        %IF DISP=0 %AND ACCESS=1 %THEN AREA=7 %AND ACCESS=2
 8372        ->DRFETCH %IF Z=2
 8373        %RETURN
 8374  MOD(23):                                ! ACCESS=5 SET DESCRIPTOR
 8375        XDISP=NUMMOD+XDISP
 8376        ->MD31
 8377  MOD(19):                                ! ACCESS=4 SET DESCRIPTOR
 8378        DISP=DISP-8
 8379  MOD(27):                                ! ACCESS=6 SET DESCRIPTOR
 8380  MOD(31):                                ! ACCESS=7 SET DESRCPTOR
 8381  MD31: GET IN ACC(DR,2,0,AREA CODE,DISP)
 8382        PSF1(INCA,0,XDISP) %UNLESS XDISP=0
 8383        PF1(INCA,0,BREG,0) %IF ACCESS=7
 8384        %IF TYPE=3 %OR TYPE=5 %THEN PSORLF1(LDB,0,0,ACC) %ELSE PF1(LDTB,0,PC,PARAM DES(PREC))
 8385        %IF REG#DR %THEN COPY DR
 8386        %RETURN
 8387  MOD(28):                                ! ACCESS=7 FETCH ADDRESS
 8388        PSF1(ADB,0,XDISP) %AND GRUSE(BREG)=0 %UNLESS XDISP=0
 8389        ACCESS=3;  ->MD12
 8390  MOD(29):                                ! ACCESS=7 STORE
 8391  MOD(30):                                ! ACCESS=7 FETCH
 8392  MOD(21):                                ! ACCESS=5 STORE
 8393  MOD(22):                                ! ACCESS=5 FETCH
 8394        %IF 1<=SIZE<=2 %THEN %START
 8395           %IF SIZE=1 %THEN %START
 8396              PSORLF1(LD,0,AREA CODE,DISP) %UNLESS GRUSE(DR)=7 %AND NAMEP>0 %AND GRINF1(DR)=NAMEP&16_FFFF
 8397           %FINISH %ELSE %START;          ! SIZE=2 HALFS
 8398              PSORLF1(LDA,0,AREA CODE,DISP+4) %UNLESS NAMEP>=0 %AND GRINF1(DR)=NAMEP&16_FFFF %AND (GRUSE(DR)=7 %OR GRUSE(DR)=15)
 8399              PF1(LDTB,0,PC,MAPDES(4)) %UNLESS GRUSE(DR)=13 %OR GRUSE(DR)=15
 8400           %FINISH
 8401           GRUSE(DR)=0
 8402           %IF NAMEP>0 %THEN GRUSE(DR)=8*SIZE-1 %AND GRINF1(DR)=NAMEP&16_FFFF
 8403           %IF ACCESS=7 %START
 8404              PSF1(ADB,0,XDISP) %IF XDISP#0
 8405              ACCESS=3; AREA=7
 8406              DISP=0
 8407              GRUSE(BREG)=0
 8408           %FINISH %ELSE %START;          ! ACCESS = 5
 8409              DISP=XDISP+NUMMOD
 8410              ACCESS=1;  AREA=0
 8411           %FINISH
 8412           NAMEP=0
 8413           ->DRFETCH %IF Z=2
 8414           %RETURN
 8415        %FINISH
 8416        %IF ACCESS=7 %START
 8417           PSORLF1(ADB,0,AREA CODE,DISP+4)
 8418           GRUSE(BREG)=0
 8419           XYNB=XORYNB(0,0)
 8420           PF1(LDCODE(XYNB),0,BREG,0)
 8421           GRUSE(XYNB)=0
 8422           DISP=XDISP
 8423        %FINISH %ELSE %START;             ! ACCESS=5
 8424           XYNB=BASEREG(8,NAMEP&16_FFFF)
 8425           DISP=NUMMOD+XDISP
 8426        %FINISH
 8427        AREA=XYNB;  ACCESS=0
 8428        NAMEP=0
 8429        ->MOD(KK)
 8430  MOD(32):                                ! ACCESS=8 FETCH ADDRESS
 8431  MOD(33):                                ! ACCESS=8 STORE
 8432  MOD(34):                                ! ACCESS=8 FETCH
 8433  MOD(35):                                ! ACCESS=8 SET DESCRIPTOR
 8434        DISP=DISP+XDISP
 8435        NAMEP=0
 8436        ACCESS=2;  ->MOD(KK+8)
 8437  MOD(40):                                ! ACCESS=10 FETCH ADDRESS
 8438  MOD(41):                                ! ACCESS=10 STORE
 8439  MOD(42):                                ! ACCESS=10 FETCH
 8440  MOD(43):                                ! ACCESS=10 SET DESCRIPTOR
 8441        XYNB=BASEREG(8,NAMEP&16_FFFF)
 8442        AREA=XYNB;  ACCESS=2;  DISP=XDISP
 8443        NAMEP=0
 8444        ->MOD(KK+8)
 8445  MOD(44):                                ! ACCESS=11 FETCH ADDRESS
 8446  MOD(45):                                ! ACCESS=11 STORE
 8447  MOD(46):                                ! ACCESS=11 FETCH
 8448  MOD(47):                                ! ACCESS=11 SET DESCRIPTOR
 8449        PSORLF1(ADB,0,AREA CODE,DISP+4)
 8450        GRUSE(BREG)=0
 8451        XYNB=XORYNB(0,0)
 8452        PF1(LDCODE(XYNB),0,BREG,0)
 8453        GRUSE(XYNB)=0
 8454        NAMEP=0;  AREA=XYNB
 8455        ACCESS=2;  DISP=XDISP;  ->MOD(KK+8)
 8456  %INTEGERFN BASEREG(%INTEGER GRUSEVAL,GRINFVAL)
 8457  !***********************************************************************
 8458  !*    SETS A BASE REGISTER FOR RECORD WHOSE POINTER IS AT AREA&DISP     *
 8459  !***********************************************************************
 8460  %INTEGER XYNB
 8461        %IF NAMEP<=0 %THEN GRUSEVAL=0 %AND GRINFVAL=0
 8462        XYNB=XORYNB(GRUSEVAL,GRINFVAL)
 8463        PSORLF1(LDCODE(XYNB),0,AREA CODE,DISP+4) %UNLESS GRUSE(XYNB)=GRUSEVAL>0 %AND GRINF1(XYNB)=GRINFVAL
 8464        GRUSE(XYNB)=GRUSEVAL
 8465        GRINF1(XYNB)=GRINFVAL
 8466        GRAT(XYNB)=CA
 8467        %RESULT=XYNB
 8468  %END
 8469  %END
 8470           %ROUTINE CRCALL(%INTEGER RTNAME)
 8471  !***********************************************************************
 8472  !*       COMPILE A ROUTINE OR FN CALL                                  *
 8473  !*       THE PROCEDURE CONSIST OF THREE PARTS:-                        *
 8474  !*       A) PLANT THE PARAMETER (IF ANY)                               *
 8475  !*       B) ENTER THE ROUTINE OR FN                                    *
 8476  !*       C) FORGET ANY REGISTERS WHICH HOLD ENTITIES THAT CAN BE       *
 8477  !*          ALTERED BY THE CALLED PROCEDURE.                           *
 8478  !***********************************************************************
 8479  %SWITCH FPD(0:3)
 8480  %INTEGER II,III,QQQ,DLINK,JJ,JJJ,NPARMS,PT,LP,PSIZE,TWSP,FPTR,TYPEP,PRECP,NAMP,TL,MOVEPTR,CLINK,RDISP
 8481  %RECORD(LISTF)%NAME LCELL{(LISTF)
 8482           PT=PTYPE; JJJ=J; TL=OLDI
 8483           TWSP=0
 8484           LP=I; CLINK=K
 8485           TYPEP=TYPE; PRECP=PREC; NAMP=NAM
 8486           RDISP=MIDCELL
 8487  !
 8488  ! NOW CHECK THAT THE RIGHT NUMBER OF PARAMETERS HAVE BEEN PROVIDED
 8489  !
 8490           TEST APP(NPARMS)
 8491           P=P+2
 8492           %IF KFORM#NPARMS %THEN %START
 8493              FAULT(19,RTNAME);          ! WRONG NO OF PARAMETERS GIVEN
 8494              SKIP APP; P=P-1
 8495              %RETURN
 8496           %FINISH
 8497  !
 8498           SAVE IRS;                      ! STACK ANY IRS BEFORS ASF
 8499           PSF1(PRCL,0,4)
 8500           FPTR=20
 8501           ->FIRST PARM
 8502  !
 8503  NEXT PARM:CLINK=LCELL_LINK
 8504  FIRSTPARM:->ENTRY SEQ %IF CLINK=0;      ! DEPART AT ONCE IF NO PARAMS
 8505           LCELL==ASLIST(CLINK)
 8506           PSIZE=LCELL_S2>>16
 8507           P=P+1
 8508           PTYPE=LCELL_S1>>16
 8509           UNPACK
 8510           II=TYPE;III=PREC
 8511           JJ=(NAM<<1!ARR)&3
 8512           %UNLESS (JJ=0 %AND ROUT=0) %OR (A(P+3)=4 %AND A(P+4)=1 %AND A(P+FROMAR2(P+1)+1)=2) %START
 8513              FAULT(22,0); SKIP EXP
 8514              ->NEXT PARM
 8515           %FINISH
 8516  !
 8517  ! RT TYPE PARAMS, PASS 4 WORDS SET UP AS CODE DESC,DUMMY & ENVIRONMENT
 8518  !
 8519           %IF ROUT=1 %THEN %START
 8520              II=PTYPE; P=P+5
 8521              CNAME(13,ACCR);            ! SET UP 4 WDS IN ACC
 8522              FAULT(22,0) %IF II&255#PTYPE&255;! PREC&TYPE SIMILAR
 8523              P=P+1; MOVEPTR=16
 8524              ->STUFF
 8525           %FINISH
 8526           ->FPD(JJ)
 8527  FPD(0):                                ! VALUE PARAMETERS
 8528           %IF TYPE=5 %THEN %START
 8529              CSTREXP(17,DR);             ! TO WK AREA & KEEP WK AREA
 8530              PSF1(LDB,0,PSIZE)
 8531              %IF REGISTER(ACCR)=3 %THEN PF1(ST,0,TOS,0) %AND REGISTER(ACCR)=0
 8532              PF1(STD,0,TOS,0)
 8533              PUSH(TWSP,VALUE,268,0);   ! RETURN WK AREA AT CALL
 8534              FPTR=FPTR+8; ->NEXT PARM
 8535           %FINISH %ELSE %START
 8536              %IF PREC=6 %THEN JJ=3 %ELSE JJ=TYPE
 8537              CSEXP(ACCR,III<<4!II)
 8538              MOVEPTR=((BYTES(III)+3)&(-4))
 8539           %FINISH
 8540           ->STUFF
 8541  !
 8542  FPD(2):                                ! NAME PARAMETERS
 8543           P=P+5
 8544           FNAME=FROM AR2(P)
 8545           COPY TAG(FNAME)
 8546           %IF II#0 %OR TYPE=0 %START
 8547              CNAME(3,ACCR)
 8548              FAULT(22,FNAME) %UNLESS II=TYPE %AND III=PREC
 8549           %FINISH %ELSE %START
 8550              CNAME(4,ACCR)
 8551              %IF TYPE<=2 %THEN JJ=PREC<<27!TYPE %ELSE JJ=16_1A<<24+ACC
 8552              STORE CONST(III,4,ADDR(JJ))
 8553              PF1(LUH,0,PC,III)
 8554           %FINISH
 8555           P=P+1; MOVEPTR=8
 8556           ->STUFF
 8557  !
 8558  FPD(1):FPD(3):                        ! ARRAY NAME (&VALUE)
 8559  !
 8560  ! FOR ARRAYNAME PARAMETERS THE NO OF DIMENSIONS OF THE ARRAY IS
 8561  ! DEDUCED FROM THE FIRST CALL AND STORED IN STREAM3 OF THE PARAMETER
 8562  ! LIST. ON ANY SUBSEQUENT CALL ONLY ARRAYS OF THE SAME DIMENSION CAN
 8563  ! BE PASSED
 8564  !
 8565           P=P+5
 8566           CNAME(12,ACCR)
 8567           GET IN ACC(ACCR,4,0,AREA CODE,DISP)
 8568           P=P+1; MOVEPTR=16
 8569           FAULT(22,0) %AND ->STUFF %UNLESS 1<=ARR<=2 %AND II=TYPE %AND III=PREC
 8570           QQQ=FROM1(TCELL)&15;           ! DIMENSION OF ACTUAL(IF KNOWN)
 8571           JJ=LCELL_S1&15;                ! DIMENSION OF FORMAL
 8572           %IF JJ=0 %THEN JJ=QQQ %AND LCELL_S1=LCELL_S1!JJ
 8573           %IF QQQ=0 %THEN QQQ=JJ %AND REPLACE1(TCELL,FROM1(TCELL)!JJ)
 8574           FAULT(22,0) %UNLESS JJ=QQQ
 8575  STUFF:   REGISTER(ACCR)=3
 8576           FPTR=FPTR+MOVEPTR
 8577           -> NEXT PARM
 8578  ENTRY SEQ:                             ! CODE FOR RT ENTRY
 8579           %IF REGISTER(ACCR)=3 %THEN PF1(ST,0,TOS,0) %AND REGISTER(ACCR)=0
 8580           J=JJJ
 8581  !
 8582  ! RETURN ANY STRING WSPACE HERE. CAN BE UXED AGAIN FOR RESULT
 8583  !
 8584           %WHILE TWSP#0 %CYCLE
 8585              POP(TWSP,QQQ,JJ,III)
 8586              RETURN WSP(QQQ,268)
 8587           %REPEAT
 8588  !
 8589  ! STRING FNS NEED A WORK AREA TO RETURN THEIR RESULTS
 8590  !
 8591           %IF TYPEP=5 %AND NAMP<=1 %THEN %START
 8592              GET WSP(QQQ,268)
 8593              STRFNRES=QQQ;               ! FOR CSTREXP TO USE
 8594              III=16_18000100; QQQ=QQQ+8
 8595              STORE CONST(JJ,8,ADDR(III))
 8596              PF1(LD,0,PC,JJ)
 8597              PSF1(INCA,1,PTR OFFSET(RBASE))
 8598              PF1(STD,0,TOS,0)
 8599              FPTR=FPTR+8
 8600           %FINISH
 8601  !
 8602  ! ORDINARY ROUTINES WILL AND RT PARAMS MAY REQUIRE AN EXTRA PARAMETER
 8603  ! BEING LNB FOR THE LEVEL OF ROUTINE DECLARATION TO BE STACKED
 8604  !
 8605           %IF JJJ=14 %THEN %START;    ! EXTERNAL
 8606              NMDECS(LEVEL)=NMDECS(LEVEL)!2
 8607              II=SET XORYNB(-1,-1)
 8608              PSF1(RALN,0,FPTR>>2)
 8609              PF1(CALL,2,II,RDISP)
 8610           %FINISH %ELSE %START
 8611              %IF NAMP&1=0 %THEN %START;! INTERNAL RT CALLS
 8612                 %IF LP=0 %THEN %START
 8613                    PSF1(LD,1,12)
 8614                    PSF1(INCA,0,RDISP) %UNLESS RDISP=0
 8615                    PSF1(RALN,0,FPTR>>2)
 8616                    PF1(CALL,2,7,0)
 8617                 %FINISH %ELSE %START;! NORMAL INTERNAL CALL
 8618                    II=SET XORYNB(XNB,LP)
 8619                    PSF1(RALN,0,FPTR>>2)
 8620                    RT JUMP(CALL,ASLIST(TAGS(RTNAME))_S2)
 8621                 %FINISH
 8622              %FINISH %ELSE %START
 8623                 AREA=-1; BASE=LP
 8624                 AREA=AREA CODE
 8625                 GET IN ACC(DR,2,0,AREA,RDISP);! DESCR TO DR
 8626                 PSORLF1(LXN,0,AREA,RDISP+12);! XNB TO ENVIRONMENT
 8627                 PSF1(RALN,0,FPTR>>2);    ! RAISE FOR NORMAL PARAMS
 8628                 PF1(CALL,2,7,0)         ;! AND ENTER VIA DESCRPTR IN DR
 8629              %FINISH
 8630           %FINISH
 8631           FORGET(-1)
 8632           ROUT=1; TYPE=TYPEP; NAM=NAMP
 8633           PREC=PRECP; PTYPE=PT
 8634           %END
?DLINK unused
 8635  %ROUTINE RT JUMP(%INTEGER CODE,%INTEGERNAME LINK)
 8636  !***********************************************************************
 8637  !*       PLANTS A CALL TO THE APPROPIATE ENTRY ADDRESS IN LINK         *
 8638  !*       IF ROUTINE HAS BEEN SPECIFIED BUT NOT DESCRIBED THE JUMP CAN  *
 8639  !*       NOT BE PLANTED AND IS LINKED INTO A LIST HEADED BY LINK       *
 8640  !*       TO AWAIT FILLING (BY ' RHEAD ') WHEN THE BODY IS GIVEN.       *
 8641  !*       THE FORMAT OF AN ENTRY IS :-                                  *
 8642  !*       S1(32 BITS) = INSTRN TO BE PLANTED                            *
 8643  !*       S2(32 BITS) = ADDRESS OF JUMP TO BE FILLED                    *
 8644  !*       THE CODING ASSUMES I,J&OLDI ARE SET UP FOR THE CALLED ROUTINE *
 8645  !***********************************************************************
 8646  %INTEGER DP
 8647           %IF J=15 %THEN %START;        ! RT BODY NOT GIVEN YET
 8648              PUSH(LINK,CODE<<24!3<<23,CA,0)
 8649              PF1(CODE,0,0,0)
 8650           %FINISH %ELSE %START;          ! BODY GIVEN AND ADDRESS KNOWN
 8651              DP=LINK-CA
 8652              DP=DP//2 %IF CODE=CALL;    ! CALL WORKS IN HALFWORDS!
 8653              PSF1(CODE,0,DP)
 8654           %FINISH
 8655  %END
 8656  %INTEGERFN TSEXP(%INTEGERNAME VALUE)
 8657  %SWITCH SW(1:3)
 8658  %INTEGER PP,REXP,KK,SIGN,CT
 8659           TYPE=1; PP=P
 8660           REXP=2-A(P+1+FROM AR2(P+1))
 8661           P=P+3
 8662           SIGN=A(P)
 8663           ->TYPED %UNLESS SIGN=4 %OR A(P+1)=2
 8664           ->SW(A(P+1))
 8665  SW(1):                                  ! NAME
 8666           P=P+2; REDUCE TAG
 8667           ->TYPED
 8668  SW(2):                                  ! CONSTANT
 8669           CT=A(P+2); TYPE=CT&7
 8670           ->TYPED %UNLESS CT=16_41 %AND SIGN#3
 8671           KK=FROMAR2(P+3)
 8672           %IF REXP#0 %AND A(P+6)=CONCOP %THEN TYPE=5 %AND ->TYPED
 8673           ->TYPED %UNLESS REXP=0 %AND 0<=KK<=255
 8674           VALUE=KK
 8675           P=P+6
 8676           %IF SIGN#2 %THEN %RESULT=1
 8677            VALUE=-VALUE; %RESULT=-1
 8678  SW(3):                                  ! SUB EXPRN
 8679  TYPED:   P=PP; %RESULT=0
 8680  %END
 8681  %ROUTINE SKIP EXP
 8682  !***********************************************************************
 8683  !*       SKIPS OVER THE EXPRESSION POINTED AT BY P. USED FOR ERROR     *
 8684  !*       RECOVERY AND TO EXTRACT INFORMATION ABOUT THE EXPRESSION.     *
 8685  !***********************************************************************
 8686  %INTEGER OPTYPE, PIN, J
 8687           PIN=P
 8688           P=P+3;                         ! TO P<+'>
 8689           %CYCLE;                        ! DOWN THE LIST OF OPERATORS
 8690             OPTYPE=A(P+1);               ! ALT OF P<OPERAND>
 8691             P=P+2
 8692             %IF OPTYPE=0 %OR OPTYPE>3 %THEN ABORT
 8693             %IF OPTYPE=3 %THEN SKIP EXP; ! SUB EXPRESSIONS
 8694  !
 8695             %IF OPTYPE=2 %THEN %START;   ! OPERAND IS A CONSTANT
 8696                J=A(P)&7;                 ! CONSTANT TYPE
 8697                %IF J=5 %THEN P=P+A(P+5)+6 %ELSE P=P+1+BYTES(A(P)>>4)
 8698             %FINISH
 8699  !
 8700             %IF OPTYPE=1 %THEN %START;   ! NAME
 8701                P=P-1
 8702                P=P+3 %AND SKIP APP %UNTIL A(P)=2 ;! TILL NO ENAME
 8703                P=P+1
 8704             %FINISH
 8705  !
 8706             P=P+1
 8707             %IF A(P-1)=2 %THEN %EXIT;    ! NO MORE REST OF EXP
 8708           %REPEAT
 8709           %END;                        ! OF ROUTINE SKIP EXP
 8710  %ROUTINE SKIP APP
 8711  !***********************************************************************
 8712  !*       SKIPS ACTUAL PARAMETER PART                                   *
 8713  !*       P IS ON ALT OF P<APP> AT ENTRY                                *
 8714  !***********************************************************************
 8715  %INTEGER PIN
 8716           PIN=P
 8717           P=P+1 %AND SKIP EXP %WHILE A(P)=1 
 8718           P=P+1
 8719            %END
 8720           %ROUTINE NO APP
 8721              P=P+2
 8722              %IF A(P)=1 %THEN %START;    ! <APP> PRESENT
 8723                 FAULT2(17,0,FROM AR2(P-2))
 8724                 SKIP APP
 8725              %FINISH %ELSE P=P+1;         ! P NOW POINTS TO ENAME
 8726           %END
 8727  %ROUTINE TEST APP(%INTEGERNAME NUM)
 8728  !***********************************************************************
 8729  !*       THIS ROUTINE COUNTS THE NUMBER OF ACTUAL PARAMETERS           *
 8730  !*       WHICH IT RETURNS IN NUM.                                      *
 8731  !***********************************************************************
 8732  %INTEGER PP, Q
 8733           Q=0;  PP=P;  P=P+2;            ! P ON NAME AT ENTRY
 8734           %WHILE A(P)=1 %CYCLE;          ! NO (MORE) PARAMETERS
 8735              P=P+1;  Q=Q+1
 8736              SKIP EXP
 8737           %REPEAT
 8738           P=PP;  NUM=Q
 8739  %END
 8740  %ROUTINE TEST ASS(%INTEGER REG,TYPE,SIZE)
 8741  !***********************************************************************
 8742  !*       TEST ACC OR B FOR THE UNASSIGNED PATTERN                      *
 8743  !***********************************************************************
 8744  %INTEGER OPCODE,A,D
 8745           %IF TYPE=5 %THEN %START
 8746              %RETURN %UNLESS REG=DR
 8747              PF1(STD,0,TOS,0)
 8748              PF2(SWEQ,1,1,0,0,UNASSPAT&255)
 8749           %FINISH %ELSE %START
 8750              %IF REG=BREG %THEN OPCODE=CPB %ELSE OPCODE=UCP
 8751              %IF SIZE=16 %THEN PF1(STUH,0,TOS,0)
 8752              %IF SIZE=2 %THEN A=0 %AND D=UNASSPAT>>16 %ELSE A=PC %AND D=PLABS(1)
 8753              PF1(OPCODE,0,A,D)
 8754              %IF SIZE=16 %THEN PF1(LUH,0,TOS,0)
 8755           %FINISH
 8756           PPJ(8,5);                      ! BE ERROR ROUTINE 5
 8757           %IF TYPE=5 %THEN PF1(LD,0,TOS,0)
 8758  %END
 8759           %ROUTINE GET WSP(%INTEGERNAME PLACE,%INTEGER SIZE)
 8760  !***********************************************************************
 8761  !*       FIND OR CREATE A TEMPORARY VARIABLE OF 'SIZE' WORDS           *
 8762  !***********************************************************************
 8763           %INTEGER J,K,L
 8764           %IF SIZE>4 %THEN SIZE=0
 8765           POP(AVL WSP(SIZE,LEVEL),J,K,L)
 8766           %IF K<=0 %THEN %START;        ! MUST CREATE TEMPORARY
 8767              %IF SIZE>1 %THEN ODD ALIGN
 8768              K=N
 8769              %IF SIZE=0 %THEN N=N+268 %ELSE N=N+SIZE<<2
 8770           %FINISH
 8771           PLACE=K
 8772           PUSH(TWSPHEAD,K,SIZE,0) %UNLESS SIZE=0
 8773           %END
 8774           %ROUTINE RETURN WSP(%INTEGER PLACE,SIZE)
 8775           %IF SIZE>4 %THEN SIZE=0
 8776           %IF PLACE<511 %THEN PUSH(AVL WSP(SIZE,LEVEL),0,PLACE,0) %ELSE INSERT AT END(AVL WSP(SIZE,LEVEL),0,PLACE,0)
 8777           %END
 8778           %ROUTINE SETLINE
 8779  !***********************************************************************
 8780  !*       UPDATE THE STATEMENT NO                                       *
 8781  !***********************************************************************
 8782  %INTEGER XYNB,I,LDI,STI,REG
 8783        LDI=LSS; STI=ST; REG=ACCR
 8784        %IF PARMDBUG!PARMPROF=0 %AND GRUSE(ACCR)#0 %AND (GRUSE(BREG)=0 %OR GRUSE(BREG)=5) %START
 8785           LDI=LB; STI=STB; REG=BREG
 8786        %FINISH
 8787        PSF1(LDI,0,LINE) %IF PARMLINE!PARMDBUG#0
 8788        %IF PARMLINE=1 %THEN %START
 8789           PSF1(STI, 1, DIAGINF(LEVEL))
 8790           GRUSE(REG)=5; GRINF1(REG)=LINE
 8791         %FINISH
 8792        %IF PARMDBUG#0 %THEN PPJ(0,3)
 8793        %IF PARMPROF#0 %THEN %START
 8794           XYNB=SET XORYNB(-1,0);      ! TO PLT
 8795           PSF1(LSS,0,1)
 8796           I=PARMPROF+8+4*LINE
 8797           PF1(IAD,0,XYNB,I)
 8798           PF1(ST,0,XYNB,I)
 8799           GRUSE(ACCR)=0
 8800        %FINISH
 8801  %END
 8802           %ROUTINE FORGET(%INTEGER REG)
 8803  %INTEGER L,U
 8804           L=REG; U=L
 8805           %IF L<0 %THEN L=0 %AND U=7
 8806           %CYCLE REG=L,1,U
 8807              %IF REGISTER(REG)>= 0 %THEN GRUSE(REG)=0 %AND GRINF1(REG)=0
 8808           %REPEAT
 8809           %END
 8810  %ROUTINE SAVE IRS
 8811  !***********************************************************************
 8812  !*       DUMP ACC AND-OR B ONTO THE STACK.  USED BEFORE CALLING FNS     *
 8813  !*      IN EXPRESSIONS.                                                 *
 8814  !***********************************************************************
 8815           ABORT %IF REGISTER(ACCR)=1=REGISTER(BREG)
 8816           %IF REGISTER(ACCR)>=1 %THEN BOOT OUT(ACCR)
 8817           %IF REGISTER(BREG)>=1 %THEN BOOT OUT(BREG)
 8818           %IF REGISTER(DR)>=1 %THEN BOOT OUT(DR)
 8819  %END
 8820  %ROUTINE BOOT OUT(%INTEGER REG)
 8821  !***********************************************************************
 8822  !*       REMOVE TEMPORARIES FROM REG INTO LOCAL OR ONTO STACK          *
 8823  !*       IT IS VITAL THAT ACC IS STACKED FIRST BEFORE B OR DR          *
 8824  !*       OTHERWISE MIXUPS OCCUR WHEN PASSING MULTI-DIMENSION ARRAY     *
 8825  !*       ELEMENTS WITH FNS AS SUBSCRIPTS AS VALUE SCALARS              *
 8826  !***********************************************************************
 8827  %CONSTBYTEINTEGERARRAY BOOTCODE(0:7)=16_48,16_58,16_5C,0(4),16_5A;
 8828  %INTEGER CODE
 8829  %RECORD(RD)%NAME R{(RD)
 8830           CODE=BOOTCODE(REG)
 8831           ABORT %UNLESS 1<=REGISTER(REG)<=3 %AND  CODE#0
 8832           R==RECORD(OLINK(REG))
 8833           %IF REGISTER(REG)=2 %THEN %START
 8834              %IF R_D=0 %THEN GET WSP(R_D,BYTES(R_PTYPE>>4)>>2)
 8835                 PSF1(CODE,1,R_D)
 8836           %FINISH %ELSE %START
 8837              %IF REG#ACCR %AND(REGISTER(ACCR)=1 %OR REGISTER(ACCR)=3) %THEN BOOT OUT(ACCR)
 8838              PF1(CODE,0,TOS,0)
 8839           %FINISH
 8840           CHANGE RD(REG)
 8841           REGISTER(REG)=0
 8842  %END
 8843  %ROUTINE COPY DR
 8844  !***********************************************************************
 8845  !*       COPY THE DR TO ACC SAVING ANYTHING IN ACC                     *
 8846  !***********************************************************************
 8847           %IF REGISTER (ACCR)#0 %THEN BOOT OUT(ACCR)
 8848           PSF1(CYD,0,0)
 8849           GRUSE(ACCR)=0
 8850  %END
 8851  %ROUTINE CHANGE RD(%INTEGER REG)
 8852  !***********************************************************************
 8853  !*         CHANGE A RESULT DESCRIPTOR WHEN OPERAND IS STACKED          *
 8854  !***********************************************************************
 8855  %RECORD(RD)%NAME OPND{(RD)
 8856           ABORT %UNLESS 1<=REGISTER(REG)<=3;! I-R OR PARAM
 8857           OPND==RECORD(OLINK(REG))
 8858           %IF REGISTER(REG)=1 %THEN %START;   ! CHANGE RESULT DESCRIPTOR
 8859              ABORT %UNLESS OPND_FLAG=9 %AND OPND_XB>>4=REG
 8860              OPND_FLAG=8;             ! CHANGE TO 'STACKED'
 8861              OPND_XB=TOS<<4
 8862           %FINISH
 8863           %IF REGISTER(REG)=2 %START
 8864              OPND_FLAG=7; OPND_XB=LNB<<4
 8865           %FINISH
 8866  %END
 8867  %ROUTINE STORE TAG(%INTEGER KK, SLINK)
 8868  %INTEGER Q, QQ, QQQ, I, TCELL
 8869  %RECORD(LISTF)%NAME LCELL{(LISTF)
 8870           TCELL=TAGS(KK)
 8871           Q=PTYPE<<16!LEVEL<<8!RBASE<<4!J
 8872  !         ABORT %UNLESS (KFORM!ACC)>>16=0
 8873           QQQ=SLINK<<16!KFORM
 8874           QQ=SNDISP<<16!ACC
 8875           %IF FROM1(TCELL)>>8&63=LEVEL %THEN %START
 8876              FAULT(7,KK)
 8877              Q=FROM1(TCELL)&16_C000!Q;! COPY USED BITS ACCROSS
 8878              REPLACE123(TCELL,Q,QQ,QQQ)
 8879           %FINISH %ELSE %START
 8880              I=ASL; %IF I=0 %THEN I=MORE SPACE
 8881              LCELL==ASLIST(I)
 8882              ASL=LCELL_LINK
 8883              LCELL_LINK=TAGS(KK)!NAMES(LEVEL)<<18
 8884              LCELL_S1=Q; LCELL_S2=QQ; LCELL_S3=QQQ
 8885              TAGS(KK)=I
 8886              NAMES(LEVEL)=KK
 8887           %FINISH
 8888  %END
 8889  %ROUTINE COPY TAG(%INTEGER KK)
 8890  %INTEGER QQQ
 8891  %RECORD(LISTF)%NAME LCELL{(LISTF)
 8892           TCELL=TAGS(KK)
 8893           %IF TCELL=0 %THEN %START;        ! NAME NOT SET
 8894             TYPE=7; PTYPE=16_57; PREC=5
 8895             ROUT=0; NAM=0; ARR=0; LITL=0; ACC=4
 8896             I=-1; J=-1; K=-1; OLDI=-1
 8897           %FINISH %ELSE %START
 8898              LCELL==ASLIST(TCELL)
 8899              KK=LCELL_S1
 8900              LCELL_S1=KK!16_8000
 8901              MIDCELL=LCELL_S2
 8902              QQQ=LCELL_S3
 8903              PTYPE=KK>>16; USEBITS=KK>>14&3
 8904              OLDI=KK>>8&63; I=KK>>4&15; J=KK&15
 8905              SNDISP=MIDCELL&16_FFFF0000//16_10000
 8906              ACC=MIDCELL&16_FFFF
 8907              K=QQQ>>16
 8908              KFORM=QQQ&16_FFFF
 8909              LITL=PTYPE>>14
 8910              ROUT=PTYPE>>12&3
 8911              NAM=PTYPE>>10&3
 8912              ARR=PTYPE>>8&3
 8913              PREC=PTYPE>>4&15
 8914              TYPE=PTYPE&15
 8915           %FINISH
 8916  %END
 8917  %ROUTINE REDUCE TAG
 8918  !***********************************************************************
 8919  !*       AS COPY TAG FOR NAME AT A(P) EXCEPT:-                         *
 8920  !*       1) SPECIAL NAMES HAVE THEIR CORRECT PREC & TYPE SUBSTITUTED   *
 8921  !*       2) RECORD ELEMENTS HAVE THE SUBNAME PARTICULARS RETURNED      *
 8922  !***********************************************************************
 8923  %INTEGER SUBS,QQ,PP
 8924           COPY TAG(FROMAR2(P))
 8925           %IF PTYPE=SNPT %THEN %START
 8926              PTYPE=TSNAME(K);  UNPACK
 8927              ROUT=1
 8928           %FINISH;                       ! TO AVOID CHECKING PARAMS
 8929           %IF TYPE=3 %THEN %START
 8930              PP=P; QQ=COPY RECORD TAG(SUBS); P=PP
 8931           %FINISH
 8932  %END
 8933  %ROUTINE REPLACE TAG(%INTEGER KK)
 8934  %INTEGER P, Q
 8935           P=TAGS(KK)
 8936           Q=PTYPE<<16!USEBITS<<14!OLDI<<8!I<<4!J
 8937           REPLACE 1(P, Q)
 8938           REPLACE3(P, K<<16!KFORM)
 8939  %END
 8940  ! LAYOUT OF PTYPE
 8941  ! ****** ** *****
 8942  ! PTYPE REQUIRES 16 BITS TO DEFINE A VARIABLE AND CAN BE REGARDED AS
 8943  ! AS TWO BYTEINTEGERS:=
 8944  ! UPPER ONE(UPTYPE):= LITL<<6!ROUT<<4!NAM<<2!ARR
 8945  ! LOWER ONE(PTYPE) :=PREC<<4!TYPE
 8946  ! OFTEN (EG IN EXPOP) ONLY THE LOWER PART IS REQUIRED AS FUNCTIONS
 8947  ! ETC ARE PREFETCHED AND STACKED.
 8948  ! LITL:= 1=CONST,2=EXTERNAL,3=EXTRINSIC(OR DYNAMIC), 0=NONE OF THESE
 8949  ! ROUT:= 1 FOR ROUTINE OR FN OR MAP, =0 NONE OF THESE
 8950  ! NAM := 2 FOR MAPS AND 'REFREFS',=1 FOR NAMES ,=0 DIRECTLY ADDRESSED
 8951  ! ARR :=1 FOR ARRAYS =0 SCALARS
 8952  ! PREC IS DESCRIPTOR SIZE CODE FOR EACH PRECISION:-
 8953  !     :=0 BITS,=3 BYTES, =5 WORDS, =6 D-WRDS, =7,QUAD WRDS
 8954  ! TYPE:= THE VARIABLE TYPE 
 8955  !     :=0 (TYPE GENERAL),=1 INTEGER, =2 REAL, =3 RECORD
 8956  !     :=4 (RECORDFORMAT),=5 STRING,  =6 LABEL/SWITCH. =7 NOT SET
 8957  !
 8958  %ROUTINE UNPACK
 8959           LITL=PTYPE>>14
 8960           ROUT=PTYPE>>12&3
 8961           NAM=PTYPE>>10&3
 8962           ARR=PTYPE>>8&3
 8963           PREC=PTYPE>>4&15
 8964           TYPE=PTYPE&15
 8965  %END
 8966  %ROUTINE PACK(%INTEGERNAME PTYPE)
 8967           PTYPE=((((LITL<<2!ROUT)<<2!NAM)<<2!ARR)<<4!PREC)<<4!TYPE
 8968  %END
 8969  %ROUTINE PPJ(%INTEGER MASK,N)
 8970  !***********************************************************************
 8971  !*       PLANT A 'JCC MASK,PERMENTRY(N)'                               *
 8972  !*       IF MASK=0 THEN PLANT A JLK                                    *
 8973  !*       IF MASK=-1 THEN PLANT A CALL TO PERM                          *
 8974  !***********************************************************************
 8975  %INTEGER VAL, INSTRN, CODE, J
 8976  %RECORD(LISTF)%NAME LCELL{(LISTF)
 8977           %IF MASK=0 %THEN CODE=JLK %ELSE CODE=CALL
 8978           %IF MASK>0 %THEN CODE=JCC
 8979           %IF MASK>=16 %THEN CODE=JAT
 8980           %IF MASK>=32 %THEN CODE=JAF
 8981           VAL=PLABS(N)
 8982           %IF MASK<=0 %THEN INSTRN=CODE<<24!3<<23 %ELSE INSTRN=CODE<<24!(MASK&15)<<21
 8983           %IF VAL>0 %THEN INSTRN=INSTRN!((VAL-CA)//2)&16_3FFFF %ELSESTART
 8984              LCELL==ASLIST(PLINK(N))
 8985              J=INSTRN!CA;                ! ONLY 18 BITS NEEDED FOR CA
 8986              %IF LCELL_S3#0 %THEN PUSH(PLINK(N),J,0,0) %ELSE %START
 8987                 %IF LCELL_S2=0 %THEN LCELL_S2=J %ELSE LCELL_S3=J
 8988              %FINISH
 8989           %FINISH
 8990           PCONST(INSTRN)
 8991           FORGET(-1) %IF MASK<=0
 8992  %END
 8993  %INTEGERFN SET XORYNB(%INTEGER WHICH,RLEV)
 8994  !***********************************************************************
 8995  !*       SET EXTRA NAME BASE TO ADDRESS ROUTINE LEVEL 'RLEV'           *
 8996  !*       RLEV=0 FOR OWNS, =-1 FOR THE PLT THESE ARE THE SAME! BUT CODED*
 8997  !*       SEPARATELY SO THAT THEY CAN BE SEPARATED IF NECESSARY         *
 8998  !***********************************************************************
 8999  %INTEGER USE,INF,OFFSET
 9000           ABORT %UNLESS -1<=RLEV<=RLEVEL
 9001        %IF RLEV<=0 %THEN USE=3 %AND INF=0 %ELSE USE=4 %AND INF=RLEV
 9002        %IF WHICH<=0 %THEN WHICH=XORYNB(USE,INF)
 9003        %IF GRUSE(WHICH)=USE %AND GRINF1(WHICH)=INF %THEN GRAT(WHICH)=CA %AND %RESULT=WHICH
 9004        OFFSET=PTR OFFSET(RLEV)
 9005        PSF1(LDCODE(WHICH),1,OFFSET)
 9006        GRUSE(WHICH)=USE; GRINF1(WHICH)=INF; GRAT(WHICH)=CA
 9007        %RESULT=WHICH
 9008  %END
 9009  %INTEGERFN XORYNB(%INTEGER USE,INF)
 9010  !***********************************************************************
 9011  !*    CHECKS IF XNB OR YNB SET UP. IF NOT DECIDES WHICH TO OVERWRITE   *
 9012  !***********************************************************************
 9013        %IF GRUSE(XNB)=USE %AND GRINF1(XNB)=INF %THEN GRAT(XNB)=CA %AND %RESULT=XNB
 9014        %IF GRUSE(CTB)=USE %AND GRINF1(CTB)=INF %THEN GRAT(CTB)=CA %AND %RESULT=CTB
 9015        %IF GRUSE(XNB)!GRUSE(CTB)=0 %THEN %START;! BOTH REGS ARE FREE
 9016           %IF USE=3 %THEN %RESULT=CTB
 9017           %RESULT=XNB
 9018        %FINISH
 9019  !
 9020  ! IF ONLY ONE FREE THEN NO PROBLEM
 9021        %IF GRUSE(XNB)=0 %THEN %RESULT=XNB
 9022        %IF GRUSE(CTB)=0 %THEN %RESULT=CTB
 9023  !
 9024  ! BOTH ARE IN USE. THIS IS WORTH CAREFUL CONSIDERATION AND EXPERIMENT
 9025  ! A VALUE TABLE MAY BE USE AS MAY LOOK AHEAD. CURRENTLY TRY LRU
 9026  !
 9027        %IF GRAT(XNB)<GRAT(CTB) %THEN %RESULT=XNB
 9028        %RESULT=CTB
 9029  %END
 9030  %ROUTINE ODDALIGN
 9031  !***********************************************************************
 9032  !*    SETS N TO ODD WORD BOUNDARY. SINCE PRECALL ALSO SETS SF TO ODD   *
 9033  !*    WORD BOUNDARY THIS MEANS 64 BIT QUANTITIES ARE 64 BIT ALIGNED    *
 9034  !*    AND CAN BE REFERNCED IN A SINGL CORE CYCLE                       *
 9035  !***********************************************************************
 9036        %IF N&7=0 %THEN RETURN WSP(N,1) %AND N=N+4
 9037  %END
 9038  %INTEGERFN PTROFFSET(%INTEGER RLEV)
 9039  !***********************************************************************
 9040  !*    RETURNS OFFSET FROM LNB OF RELEVANT ITEM IN THE CURRENT DISPLAY  *
 9041  !*    WHICH ENABLES TEXTTUAL LEVEL 'RLEV' TO BE ADDRESSED              *
 9042  !*    A FUNCTION IS USED TO ALLOW CHANGES IN THE DISPLAY FORMAT        *
 9043  !***********************************************************************
 9044        %IF RLEV<=0 %THEN %RESULT=16
 9045        %RESULT=DISPLAY(RLEVEL)+(RLEV-1)<<2
 9046  %END
 9047  %INTEGERFN AREA CODE
 9048  !***********************************************************************
 9049  !*       RETURNS THE AREA CODE FOR ROUTINE LEVEL 'BASE' LOADING        *
 9050  !*       XNB WHERE THIS IS NEEDED                                      *
 9051  !***********************************************************************
 9052           %IF AREA<0 %THEN %START
 9053              %IF BASE=RBASE %THEN AREA=LNB %AND %RESULT=LNB;! LOCAL LEVEL
 9054              AREA=SET XORYNB(-1,BASE)
 9055           %FINISH
 9056           %RESULT=AREA
 9057  %END
 9058  %INTEGERFN AREA CODE2(%INTEGER BS)
 9059  !***********************************************************************
 9060  !*    A VERSION OF AREA CODE WITHOUT SIDE EFFECTS !                    *
 9061  !***********************************************************************
 9062        %IF BS=RBASE %THEN %RESULT=LNB
 9063        %RESULT=SET XORYNB(-1,BS)
 9064  %END
 9065  %ROUTINE GET IN ACC(%INTEGER REG,SIZE,ACCESS,AREA,DISP)
 9066  !***********************************************************************
 9067  !*         LOADS THE REGISTER SPECIFIED ARRANGING FOR AUTOMATIC        *
 9068  !*       STACKING WHEN THIS IS NEEDED                                  *
 9069  !*       IT IS VITAL THAT ACC IS STACKED FIRST BEFORE B OR DR          *
 9070  !*       OTHERWISE MIXUPS OCCUR WHEN PASSING MULTI-DIMENSION ARRAY     *
 9071  !*       ELEMENTS WITH FNS AS SUBSCRIPTS AS VALUE SCALARS              *
 9072  !***********************************************************************
 9073  %INTEGER OPCODE
 9074        SIZE=1 %IF SIZE=0;       ! BITS ABD BYTES!
 9075  !      ABORT %UNLESS REG=ACCR %OR(REG=DR %AND SIZE=2) %OR (REG=BREG %AND SIZE=1)
 9076        %IF REG=DR %THEN OPCODE=LD %ELSE %START
 9077           %IF REG=BREG %THEN OPCODE=LB %ELSE OPCODE=LSS+SIZE&6
 9078        %FINISH
 9079  !
 9080        %IF REGISTER(REG)>=1 %THEN %START
 9081           %IF REGISTER(REG)=2 %OR(ACCESS=2 %AND AREA=0)%THEN BOOT OUT(REG) %ELSE %START; ! CANNOT SLSS ISN ON ALL MCS
 9082              %IF REG#ACCR %AND(REGISTER(ACCR)=1 %OR REGISTER(ACCR)=3) %THEN BOOT OUT(ACCR)
 9083              CHANGE RD(REG)
 9084              REGISTER(REG)=0
 9085             %IF REG=ACCR %THEN OPCODE=OPCODE-32 %ELSE OPCODE=OPCODE-40
 9086           %FINISH
 9087        %FINISH
 9088        PSORLF1(OPCODE,ACCESS,AREA,DISP)
 9089        %IF ACCESS>=2 %AND 0#AREA#7 %THEN GRUSE(DR)=0
 9090        GRUSE(REG)=0
 9091  %END
 9092  %ROUTINE NOTE ASSMENT(%INTEGER REG, ASSOP, VAR)
 9093  !***********************************************************************
 9094  !*       NOTES THE ASSIGNMENT TO SCALAR 'VAR'.  THIS INVOLVES REMOVING *
 9095  !*       OLD COPIES FROM REGISTERS TO AVOID CONFUSING OLD AND NEW VALUE*
 9096  !*       ASSOP =1 FOR'==',=2 FOR '=',=3 FOR '<-'                       *
 9097  !***********************************************************************
 9098  %CONSTINTEGER EEMASK=B'100011110000000';! MASK OF USES RELEVANT TO ==
 9099  %CONSTINTEGER EMASK=B'100011000000000';! MASK OF USES RELEVANT TO =
 9100  %CONSTINTEGER NREGS=5
 9101  %CONSTINTEGER REGS=16*16*16*16*CTB+16*16*16*XNB+16*16*ACCR+16*BREG+DR
 9102  %INTEGER I,USE1,USE2,II
 9103        %RETURN %IF VAR<=0
 9104        %IF ASSOP=1 %THEN %START
 9105           %CYCLE I=0,1,7
 9106              USE1=GRUSE(I); USE2=USE1>>16; USE1=USE1&255
 9107              %IF EEMASK&1<<USE2#0 %AND (GRINF2(I)&16_FFFF=VAR %OR GRINF2(I)>>16=VAR) %THEN GRUSE(I)=USE1 %AND USE2=0
 9108              %IF EEMASK&1<<USE1#0 %AND (GRINF1(I)&16_FFFF=VAR %OR GRINF1(I)>>16=VAR) %THEN GRUSE(I)=USE2 %AND GRINF1(I)=GRINF2(I)
 9109           %REPEAT
 9110           GRUSE(REG)=7
 9111           GRINF1(REG)=VAR
 9112        %FINISH %ELSE %START
 9113           %CYCLE II=0,4,4*(NREGS-1)
 9114           I=REGS>>II&15
 9115              USE1=GRUSE(I); USE2=USE1>>16; USE1=USE1&255
 9116              %IF EMASK&1<<USE2#0 %AND (GRINF2(I)&16_FFFF=VAR %OR GRINF2(I)>>16=VAR %OR GRINF2(I)=VAR) %THEN GRUSE(I)=USE1 %AND USE2=0
 9117              %IF EMASK&1<<USE1#0 %AND (GRINF1(I)&16_FFFF=VAR  %OR GRINF1(I)>>16=VAR %OR GRINF1(I)=VAR) %THEN GRUSE(I)=USE2 %AND GRINF1(I)=GRINF2(I)
 9118  !
 9119  ! ALL THE FOREGOING CONDITIONS ARE NOT AS SILLY AS THEY SEEM. MUST
 9120  ! BEAR IN MIND THAT BOTH GRINF&VAR MAY BE RECORD ELEMENTS DEFINED
 9121  ! BY ALL 32 BITS OF INF AS WELL AS MODIFIED SCALARS WHEN THE NAME
 9122  ! ONLY TAKES 16 BITS
 9123  !
 9124           %REPEAT
 9125           %IF ASSOP=2 %AND VAR>0 %START
 9126              USE1=GRUSE(REG)
 9127              %IF 5<=USE1&255<=6 %START;  ! ASSIGN CONST TO VAR
 9128                 GRUSE(REG)=USE1&255!(9<<16)
 9129                 GRINF2(REG)=VAR
 9130              %FINISH %ELSE %START;       ! ASSIGN VAR OR EXP TO VAR
 9131                 GRUSE(REG)=USE1<<16!9
 9132                 GRINF2(REG)=GRINF1(REG); ! PREVIOUS USE BECOMES 2NDRY
 9133                 GRINF1(REG)=VAR
 9134              %FINISH
 9135           %FINISH
 9136        %FINISH
 9137  %END
 9138  %END;                                  ! OF ROUTINE CSS
 9139  !*DELSTART
 9140  %ROUTINE PRINTUSE
 9141  !***********************************************************************
 9142  !*    UP TO TWO USES ARE REMEMBERED INFO IN GRINF1 & GRINF2            *
 9143  !*    BOTTOM HALF OF GRUSE RELATES TO INF1 TOP HALF TO INF2            *
 9144  !*    THE MEANS CLEARING GRUSE TO FORGETS THE REG COMPLETELY           *
 9145  !*    ARRAY REGISTER KEEPS THE CLAIM STATUS AND GRAT THE LAST USE      *
 9146  !***********************************************************************
 9147  %CONSTSTRING(3)%ARRAY REGS(0:7)="ACC"," DR","LNB","XNB",
 9148+                                       " PC","CTB","TOS","  B";
 9149  %CONSTSTRING(15)%ARRAY USES(0:15) =" NOT KNOWN "," I-RESULT  ",
 9150+                                    " TEMPORARY ","  PLTBASE  ",
 9151+                                    " NAMEBASE  "," LIT CONST ",
 9152+                                    " TAB CONST "," DESC FOR  ",
 9153+                                    " RECD BASE "," LOCAL VAR ",
 9154+                                    " NAME+CNST "," AUXSTPTR- ",
 9155+                                    " BYTE DES  "," HALF DES  ",
 9156+                                    "  VMY RES  "," REC HDES  ";
 9157  %CONSTSTRING(11)%ARRAY STATE(-1:3)={%C
 9158+                                         "  LOCKED   ","   FREE    ",
 9159+                                         " I-RESULT  "," TEMPORARY ",
 9160+                                         " RT-PARAM  ";
 9161  %ROUTINESPEC OUT(%INTEGER USE,INF)
 9162  %INTEGER I,USE,INF
 9163        %CYCLE I=0,1,7
 9164           %IF REGISTER(I)!GRUSE(I)#0 %START
 9165              USE=GRUSE(I)
 9166              PRINTSTRING(REGS(I).STATE(REGISTER(I)))
 9167              OUT(USE&255,GRINF1(I))
 9168              %IF USE>>16#0 %THEN PRINTSTRING(" ALSO ") %AND OUT(USE>>16,GRINF2(I))
 9169              NEWLINE
 9170           %FINISH
 9171        %REPEAT
 9172        %RETURN
 9173  %ROUTINE OUT(%INTEGER USE,INF)
 9174  %CONSTINTEGER LNMASK=B'1100011110000000'
 9175  %CONSTINTEGER UNMASK=B'0100001110000000'
 9176        PRINTSTRING(" USE = ".USES(USE))
 9177        %IF LNMASK&1<<USE#0 %THEN PRINTSTRING(PRINTNAME(INF&16_FFFF)) %ELSE WRITE(INF,1)
 9178        %IF USE=10 %THEN PRINTSYMBOL('+') %AND WRITE(INF>>16,1)
 9179        %IF UNMASK&1<<USE#0 %AND INF>>16#0 %THEN PRINTSTRING(" MODBY") %AND PRINTSTRING(PRINTNAME(INF>>16))
 9180  %END
 9181  %END
?INF unused
 9182  !*DELEND
 9183  %ROUTINE ABORT
 9184           PRINTSTRING("
 9185+ ****************      ABORT********************    ABORT    *******")
 9186  !*DELSTART
 9187           NCODE(ADDR(CODE(0)), ADDR(CODE(PPCURR)), CABUF) %UNLESS CA=CABUF
 9188           PRINT USE
 9189  !*DELEND
 9190           %MONITOR
 9191           %STOP
 9192  %END
 9193  %ROUTINE EPILOGUE
 9194  !***********************************************************************
 9195  !*       PLANT ANY SUBROUINES THAT HAVE BEEN REQUIRED DURING           *
 9196  !*       THE CODE GENERATION PHASE                                     *
 9197  !***********************************************************************
 9198  %INTEGER D,J
 9199  %ROUTINESPEC FILL(%INTEGER LAB)
 9200           %IF PLINK(15)=0 %THEN ->P16
 9201           ABORT
 9202  P16:
 9203  !
 9204  ! STRING RESOLUTION SUBROUTINE
 9205  ! THIS IS ENTERED VIA A CALL INSTRN AND HAS 3 PARAMETERS
 9206  ! P1(LNB+5) = RESD A CURRENT LENGTH DESCRIPTOR POINTING AT THE FIRST BYTE
 9207  !             OF THE STRING BEING RESOLVED
 9208  ! P2(LNB+7) = STD A MAX LENGTH DESCRIPTOR TO THE STRING IN WHICH ANY
 9209  !             FRAGMENT IS TO BE STORED
 9210  ! P3(LNB+9) - EXPD A CURRENT LENGTH DESCRIPTOR POINTING AT THE 
 9211  !             LENGTH BYTE OF STRING TO BE SEARCHED FOR
 9212  !
 9213  ! IF RESOLUTION IS SUCCESSFULL CC IS SET TO 0 AND AN UPDATED VERSION
 9214  ! OF RESD IS RETURNED IN THE ACC IN CASE THERE ARE FURTHER RESLNS
 9215  !
 9216  ! CODE IS AS FOLLOWS:-
 9217  !
 9218  !        LXN   (LNB+0)                  OLD LNB
 9219  !        LD    (XNB+3)                  PLT DESCRIPTOR
 9220  !        LDB   0                        ZERO BOUND FOR MDIAG
 9221  !        STD   (LNB+3)                  STANDARD PLACE
 9222  !        ASF   4                        GRAB 2 TEMPORARIES
 9223  !        LD    (LNB+5)                  RESULT IF NULL ROUTE TAKEN
 9224  !        SLD   (LNB+9)                  EXPD
 9225  !        LB    0
 9226  !        JAT   11,LNULL                 JUMP IF EXP NULL
 9227  !        INCA  1                        TO FIRST CHAR
 9228  !        LB    @DR                      FIRST CHAR INTO B
 9229  !        STD   (LNB+11)                 TEMP1
 9230  !        LSS   (LNB+5)                  TYPE&BND OF RESD
 9231  !        AND   XIFF
 9232  !        JAT   4,RESFAIL                RESD IS NULL &EXPD NOT NULL
 9233  !        LD    (LNB+5)                  RESD TO DR
 9234  !AGN     SWNE  L=DR                     SEARCH FOR FIRST CHAR
 9235  !        JCC   8,RESFAIL                NOT FOUND
 9236  !        STD   (LNB+13)                 SAVE IN TEMP 2
 9237  !        CYD   0
 9238  !        LD    (LNB+11)                 EXP DESCRIPTOR FOR COMPARISON
 9239  !        CPS   L=DR,FILLER=FF           CHECK REST OF EXPRSN
 9240  !        JCC   8,L2                     RESLN HAS SUCCEEDED
 9241  !        LD    (LNB+13)                 RESUME SCANNING
 9242  !        SWEQ  L=1                      ADVANCE BY 1 AVOIDING MODD
 9243  !        J     AGN
 9244  !
 9245  ! RESOLUTION COMPLETE. ARRANGE TO STORE FRAGMENT WITHOUT ANY FILLER CHARS
 9246  ! SO S->S.(T).Z WORKS OK AND ALLOWING STD TO BE NULL
 9247  !
 9248  !L2      SLSS  (LNB+5)                  STORE UPDATED DES & GET BND
 9249  !        ISB   (LNB+13)                 GIVE LENGTH OF FRAGMENT
 9250  !        ST    B
 9251  !        LSS   (LNB+7)                  LENGTH OF STD
 9252  !        JAF   4,*+6                    ! ZERO FOR NO 1ST PART RESLN
 9253  !        LSS   1
 9254  !        AND   X1FF
 9255  !        ICP   B
 9256  !        JCC   12,RESFAIL
 9257  !LNULL   LD    (LNB+7)                  STD TO DR
 9258  !        JAT   11,L3                    STD NULL DONT SET LENGTH
 9259  !        LSD   (LNB+5)                  ORIGINIAL STRING
 9260  !        MVL   L=1                      SET LENGTH BYTE FROM B
 9261  !        LDB   B                        TO STORE CHARS
 9262  !        MV    L=DR,FILLER=16_80        ASSIGN
 9263  !L3      LD    TOS                      RESULT AND SET CC=0
 9264  !        CYD   0
 9265  !        EXIT
 9266  !RESFAIL MPSR  16_24                    SET CC=1
 9267  !        EXIT
 9268           %IF PLINK(16)=0 %THEN ->P17
 9269           FILL(16)
 9270           PSF1(LXN,1,0)
 9271           PF1(LD,0,XNB,12)
 9272           PSF1(LDB,0,0)
 9273           PSF1(STD,1,12)
 9274           PSF1(ASF,0,4)
 9275           PSF1(LD,1,20)
 9276           PSF1(SLD,1,36)
 9277           PSF1(LB,0,0)
 9278           PF3(JAT,11,0,16_24)
 9279           PSF1(INCA,0,1)
 9280           PF1(LB,2,7,0)
 9281           PSF1(STD,1,44)
 9282           PSF1(LSS,1,20)
 9283           PF1(AND,0,0,16_1FF)
 9284           PF3(JAT,4,0,16_27)
 9285           PSF1(LD,1,23)
 9286           PF2(SWNE,1,0,0,0,0)
 9287           PF3(JCC,8,0,16_23)
 9288           PSF1(STD,1,52)
 9289           PSF1(CYD,0,0)
 9290           PSF1(LD,1,44)
 9291           PF2(CPS,1,1,0,0,16_FF)
 9292           PF3(JCC,8,0,5)
 9293           PSF1(LD,1,52)
 9294           PF2(SWEQ,0,0,0,0,0)
 9295           PSF1(JUNC,0,-12)
 9296           PSF1(SLSS,1,20)
 9297           PSF1(ISB,1,52)
 9298           PF1(ST,0,BREG,0)
 9299           PSF1(LSS,1,28)
 9300           PF3(JAF,4,0,3)
 9301           PSF1(LSS,0,1)
 9302           PF1(AND,0,0,16_1FF)
 9303           PF1(ICP,0,BREG,0)
 9304           PF3(JCC,12,0,13)
 9305           PSF1(LD,1,28)
 9306           PF3(JAT,11,0,7)
 9307           PSF1(LSD,1,20)
 9308           PF2(MVL,0,0,0,0,0)
 9309           PF1(LDB,0,BREG,0)
 9310           PF2(MV,1,1,0,0,UNASSPAT&255)
 9311           PF1(LD,0,TOS,0)
 9312           PSF1(CYD,0,0)
 9313           PSF1(EXIT,0,-16_40)
 9314           PSF1(MPSR,0,16_24)
 9315           PSF1(EXIT,0,-16_40)
 9316  P17:
 9317  !
 9318  ! EVALUATE X**Y
 9319  ! ******** ****
 9320  ! Y IS IN ACC X IS STACKED BELOW THE LINK(UNAVOIDABLE)
 9321  ! FAULT(21) IS GIVEN IF X<0 OR (X=0 AND Y<=0)
 9322  ! REPEATED MULTIPLICATION IS USED IF Y>0 AND FRACPT(Y)=0
 9323  ! OTHERWISE RESULT=EXP(Y*LOG(Y))
 9324  !
 9325  !        LB    TOS                      SWOP RETURN ADDRESS & X
 9326  !        LD    TOS                      X TO DR
 9327  !        STB   TOS
 9328  !        STD   TOS
 9329  !        SLSD  TOS                      X TO ACC Y TO TOS
 9330  !        JAT   2,EXPERR                 ERROR IF X<0
 9331  !        JAF   0,TRYMULT                JUMP X#0
 9332  !        SLSD  TOS                      STACK X & GET Y
 9333  !        JAF   1.EXPERR                 Y<=0
 9334  !        LSD   TOS                      X (=0) =RESULT TO ACC
 9335  !        J     TOS                      RETURN
 9336  !TRYMULT                                X IS IN ACC & Y STACKED
 9337  !        SLSD  TOS                      Y TO ACC AND X STACKED
 9338  !        ST    TOS                      Y STACKED
 9339  !        JAT   2,NONINT                 Y IS NEGATAIVE
 9340  !        RSC   55
 9341  !        RSC   -55
 9342  !        FIX   B                        FIX PINCHED FROM ICL ALGOL
 9343  !        MYB   4
 9344  !        CPB   -64
 9345  !        JCC   10,*+3
 9346  !        LB    -64
 9347  !        ISH   B
 9348  !        STUH  B                        ACC TO 1 WORD
 9349  !        JCC   7,NONINT                 JUMP IF TRUNCATION
 9350  !        ASF   -2                       LOSE Y OF STACK
 9351  !        ST    B                        INTEGER VERSION OF Y TO B
 9352  !        LSS   1
 9353  !        FLT   0
 9354  !        JAF   12,MUL                   JUMP IF B#0
 9355  !        ASF   -2                       LOSE X OFF STACK
 9356  !        J     TOS                      X**0 =1
 9357  !AGN     STD   TOS                      STACK ANOTHER COPY OF X
 9358  !MUL     RMY   TOS
 9359  !        DEBJ  AGN                      REPEATED MULTIPLICATION
 9360  !        J     TOS
 9361  !NONINT                                 Y IS STACKED OVER X
 9362  !        LSD   TOS
 9363  !        SLSD  TOS
 9364  !        PRCL  4
 9365  !        ST    TOS
 9366  !        LXN   (LNB+4)
 9367  !        RALN  7
 9368  !        CALL  ((XNB+LOGEPDISP)
 9369  !        RMY   TOS
 9370  !        PRCL  4
 9371  !        ST    TOS
 9372  !        LXN   (LNB+4)                  TO PLT
 9373  !        RALN  7
 9374  !        CALL  ((XNB+EXPEPDISP))        CALL EXP
 9375  !        J     TOS
 9376  !EXPERR  J     ERROR RT NO 7
 9377  !
 9378           %IF PLINK(17)=0 %THEN ->P18
 9379           FILL(17)
 9380           %IF LOGEPDISP=0 %THEN CXREF("S#ILOG",PARMDYNAMIC,2,LOGEPDISP)
 9381           %IF EXPEPDISP=0 %THEN CXREF("S#IEXP",PARMDYNAMIC,2,EXPEPDISP)
 9382           PF1(LB,0,TOS,0)
 9383           PF1(LD,0,TOS,0)
 9384           PF1(STB,0,TOS,0)
 9385           PF1(STD,0,TOS,0)
 9386           PF1(SLSD,0,TOS,0)
 9387           PF3(JAT,2,0,16_35)
 9388           PF3(JAF,0,0,7)
 9389           PF1(SLSD,0,TOS,0)
 9390           PF3(JAF,1,0,16_30)
 9391           PF1(LSD,0,TOS,0)
 9392           PF1(JUNC,0,TOS,0)
 9393           PF1(SLSD,0,TOS,0)
 9394           PF1(ST,0,TOS,0)
 9395           PF3(JAT,2,0,26)
 9396           PSF1(RSC,0,55)
 9397           PSF1(RSC,0,-55)
 9398           PF1(FIX,0,BREG,0)
 9399           PSF1(MYB,0,4)
 9400           PSF1(CPB,0,-64)
 9401           PF3(JCC,10,0,3)
 9402           PSF1(LB,0,-64)
 9403           PF1(ISH,0,BREG,0)
 9404           PF1(STUH,0,BREG,0)
 9405           PF3(JCC,7,0,14)
 9406           PSF1(ASF,0,-2)
 9407           PF1(ST,0,BREG,0)
 9408           PSF1(LSS,0,1)
 9409           PSF1(FLT,0,0)
 9410           PF3(JAF,12,0,5)
 9411           PSF1(ASF,0,-2)
 9412           PF1(JUNC,0,TOS,0)
 9413           PF1(STD,0,TOS,0)
 9414           PF1(RMY,0,TOS,0)
 9415           PSF1(DEBJ,0,-2)
 9416           PF1(JUNC,0,TOS,0)
 9417           PF1(LSD,0,TOS,0)
 9418           PF1(SLSD,0,TOS,0)
 9419           PSF1(PRCL,0,4)
 9420           PF1(ST,0,TOS,0)
 9421           PSF1(LXN,1,16)
 9422           PSF1(RALN,0,7)
 9423           PF1(CALL,2,XNB,LOGEPDISP)
 9424           PF1(RMY,0,TOS,0)
 9425           PSF1(PRCL,0,4)
 9426           PF1(ST,0,TOS,0)
 9427           PSF1(LXN,1,16)
 9428           PSF1(RALN,0,7)
 9429           PF1(CALL,2,XNB,EXPEPDISP)
 9430           PF1(JUNC,0,TOS,0)
 9431           PF1(JUNC,0,0,(PLABS(7)-CA)//2)
 9432  P18:
 9433  !
 9434  ! MAPPED STRING ASSIGNMENT CHECK. CHECKING MODE ONLY. MUST MOVE ONLY
 9435  ! CURRENT LENGTH INTO MAPPED STRINGS BUT MUST NOT OMIT THE CAPACITY
 9436  ! CHECK. ACC & DR SET FOR MV
 9437  !
 9438  !        ST    TOS                      SAVE ACC DESRPTR
 9439  !        AND   16_1FF00000000            GET CURRENT LENGTH
 9440  !        STUH  B                        INTO BREG
 9441  !        LSD   TOS                      RESTORE ACC
 9442  !        STD   TOS                      SAVE DR DESCRPTR
 9443  !        SBB   1
 9444  !        JAF 13,*+3
 9445  !        MODD  B                        PROVOKE FAILURE IF RELEVANT
 9446  !        ADB   1
 9447  !        LD    TOS
 9448  !        LDB   B                        BOUND=CURRENT L +1(FOR LBYTE)
 9449  !        J     TOS
 9450  !
 9451           %IF PLINK(18)=0 %THEN ->P19
 9452           CNOP(0,8)
 9453           D=CA
 9454           PCONST(511)
 9455           PCONST(0);                     ! XFF00000000
 9456           FILL(18)
 9457           PF1(ST,0,TOS,0)
 9458           PF1(AND,0,PC,D)
 9459           PF1(STUH,0,BREG,0)
 9460           PF1(LSD,0,TOS,0)
 9461           PF1(STD,0,TOS,0)
 9462           PSF1(SBB,0,1)
 9463           PF3(JAF,13,0,3)
 9464           PF1(MODD,0,BREG,0)
 9465           PSF1(ADB,0,1)
 9466           PF1(LD,0,TOS,0)
 9467           PF1(LDB,0,BREG,0)
 9468           PF1(JUNC,0,TOS,0)
 9469  P19:
 9470  ! CONCATENATION ONE
 9471  ! COPY THE FIRST STRING INTO THE WORK AREA
 9472  ! B HAS REL DISP OF THE WORK AREA FROM LNB
 9473  ! DR HAS CURRENT LENGTH DESCRIPTOR OF FIRST STRING
 9474  ! RESULT IS A CURRENT LENGTH DESCRIPTOR TO WORK AREA IN DR AND ACC
 9475  !
 9476  !        STLN TOS
 9477  !        ADB   TOS
 9478  !        LXN   B                        XNB TO WORK AREA
 9479  !        SLB   @DR                      CURRENT LENGTH TO B
 9480  !        STB   (%XNB+2)                 INTO LENGTH BYTE OF WK AREA
 9481  !        INCA  1                        DR PAST LENGTH BYTE
 9482  !        CYD   0                        BECOMES SOURCE STRING
 9483  !        LD    =16_180000FF0000000C     
 9484  !        INCA  TOS                      DESCRIPTOR TO WK STRING
 9485  !        STD   (%XNB+0)                 STORED FOR LATER
 9486  !        LDB   B                        ADJUSTED SO NO FILLING
 9487  !        MV    L=DR                     THE MOVE
 9488  !        LD    (%XNB+0)                 SET UP DR WITH RESULT
 9489  !        LDB   B                        CURRENT LENGTH AS BOUND
 9490  !        INCA  -1                       TO POINT AT LENGTH BYTE
 9491  !        CYD   0                        TO ACC AS WELL
 9492  !        J     TOS                      RETURN
 9493        %IF PLINK(19)!PLINK(20)=0 %THEN ->P21
 9494        CNOP(0,8);                        ! DOUBLE WORD ALLIGN
 9495        D=CA
 9496        PCONST(16_180000FF); PCONST(12)
 9497        FILL(19)
 9498        PF1(STLN,0,TOS,0)
 9499        PF1(ADB,0,TOS,0)
 9500        PF1(LXN,0,BREG,0)
 9501        PF1(SLB,2,7,0)
 9502        PF1(STB,0,XNB,8)
 9503        PSF1(INCA,0,1)
 9504        PSF1(CYD,0,0)
 9505        PF1(LD,0,PC,D)
 9506        PF1(INCA,0,TOS,0)
 9507        PF1(STD,0,XNB,0)
 9508        PF1(LDB,0,BREG,0)
 9509        PF2(MV,1,0,0,0,0)
 9510        PF1(LD,0,XNB,0)
 9511        PF1(LDB,0,BREG,0)
 9512        PSF1(INCA,0,-1)
 9513        PSF1(CYD,0,0)
 9514        PF1(JUNC,0,TOS,0)
 9515  !
 9516  ! CONCATENATION TWO
 9517  ! ADD THE SECOND AND SUBSEQUENT STRINGS TO THE FIRST
 9518  ! PARAMETERS AND RESULTS AS CONCATENATION ONE
 9519  !
 9520  !        STLN TOS
 9521  !        ADB   TOS
 9522  !        LXN   B                        XNB TO WORK AREA
 9523  !        LB    @DR                      CURRENT LENGTH TO B
 9524  !        STB   TOS                      KEEP FOR THE MOVE
 9525  !        ADB   (%XNB+2)                 ADD OLD LENGTH
 9526  !        INCA  1                        PAST LENGTH BYTE
 9527  !        CYD   0                        BECOMES SOURCE STRING
 9528  !        LD    (%XNB+0)                 GET DESCRIPTOR TO WK STRING
 9529  !        MODD  (%XNB+2)                 MOVE ON PAST FIRST STRING
 9530  !        LDB   TOS                      TO MOVE RIGHT AMOUNT
 9531  !        MV    L=DR
 9532  !        STB   (%XNB+2)                 UP DATE WK STRING LENGTH
 9533  !        CPB   255
 9534  !        JCC   2,CAPACITY EXCEEDED
 9535  !        LD    (%XNB+0)                 SET UP DR WITH RESULT
 9536  !        LDB   B                        CURRENT LENGTH AS BOUND
 9537  !        INCA  -1                       TO POINT AT LENGTH BYTE
 9538  !        CYD   0                        TO ACC AS WELL
 9539  !        J     TOS                      RETURN
 9540        %IF PLINK(20)=0 %THEN ->P21
 9541        FILL(20)
 9542        PF1(STLN,0,TOS,0)
 9543        PF1(ADB,0,TOS,0)
 9544        PF1(LXN,0,BREG,0)
 9545        PF1(LB,2,7,0)
 9546        PF1(STB,0,TOS,0)
 9547        PF1(ADB,0,XNB,8)
 9548        PSF1(INCA,0,1)
 9549        PSF1(CYD,0,0)
 9550        PF1(LD,0,XNB,0)
 9551        PF1(MODD,0,XNB,8)
 9552        PF1(LDB,0,TOS,0)
 9553        PF2(MV,1,0,0,0,0)
 9554        PF1(STB,0,XNB,8)
 9555        PF1(CPB,0,0,255)
 9556        PF3(JCC,2,0,(PLABS(9)-CA)//2)
 9557        PF1(LD,0,XNB,0)
 9558        PF1(LDB,0,BREG,0)
 9559        PSF1(INCA,0,-1)
 9560        PSF1(CYD,0,0)
 9561        PF1(JUNC,0,TOS,0)
 9562  P21:
 9563  !
 9564  ! THE STOP SEQUENCE
 9565  ! CALL %SYSTEMROUTINE STOP(NO PARAMETERS)
 9566  !
 9567  !STOP1   PRCL   4
 9568  !        LXN   (LNB+4)
 9569  !        RALN  5
 9570  !        CALL  ((XNB+STOPEPDISP))       ! **PLEASE DONT COME BACK**
 9571  !
 9572           %IF PLINK(21)=0 %THEN ->P22
 9573           FILL(21)
 9574           CXREF("S#STOP",PARMDYNAMIC,2,J)
 9575           PSF1(PRCL,0,4)
 9576           PSF1(LXN,1,16)
 9577           PSF1(RALN,0,5)
 9578           PF1(CALL,2,XNB,J)
 9579           PF1(16_4E,0,0,16_B00B);        ! IDLE B00B
 9580  P22:
 9581  !
 9582  ! PRINTPROFILE
 9583  !
 9584           %IF PLINK(22)=0 %THEN ->P23
 9585           FILL(22)
 9586           CXREF("S#PPROFILE",PARMDYNAMIC,2,J)
 9587           PSF1(PRCL,0,4)
 9588           PSF1(LXN,1,16)
 9589           PF1(LDRL,0,XNB,PARMPROF)
 9590           PF1(STD,0,TOS,0)
 9591           PSF1(RALN,0,7)
 9592           PF1(CALL,2,XNB,J)
 9593           PF1(JUNC,0,TOS,0)
 9594  P23:
 9595           %RETURN
 9596  %ROUTINE FILL(%INTEGER LAB)
 9597  !***********************************************************************
 9598  !*       FILL JUMPS TO THIS LAB WITH JUMP TO CURRENT ADDRESS           *
 9599  !***********************************************************************
 9600  %INTEGER AT,INSTRN,I,J
 9601  %INTEGERARRAY A(0:2)
 9602           %WHILE PLINK(LAB)#0 %CYCLE
 9603               POP(PLINK(LAB),A(0),A(1),A(2))
 9604              %CYCLE I=0,1,2
 9605                 INSTRN=A(I)
 9606                 %IF  INSTRN#0 %THEN %START
 9607                    AT=INSTRN&16_3FFFF
 9608                    INSTRN=INSTRN&16_FFC00000
 9609                    INSTRN=INSTRN!(CA-AT)>>1
 9610                     PLUG(1,AT,INSTRN,4)
 9611                 %FINISH
 9612              %REPEAT
 9613           %REPEAT
 9614           PLABS(LAB)=CA
 9615  %END
?J unused
 9616  %END
 9617  %ROUTINE DUMP CONSTS
 9618  !***********************************************************************
 9619  !*    OUTPUT THE CONSTANT TABLE AND MAKE ANY RELEVANT RELOCATIONS      *
 9620  !***********************************************************************
 9621  %ROUTINESPEC DOIT(%INTEGER VAL)
 9622  %ROUTINESPEC FILL(%INTEGER CREFHEAD)
 9623  %INTEGER I,J,K,DISP,SIZE,BASE
 9624        BASE=0
 9625        SIZE=CONSTPTR-BASE
 9626        %IF SIZE<=0 %THEN %RETURN
 9627        CNOP(0,8) %UNLESS CA&7=0
 9628        CODE OUT
 9629        LPUT(1,SIZE*4,CA,ADDR(CTABLE_val(BASE)))
 9630  !*DELSTART
 9631        %IF DCOMP#0 %START
 9632           PRINTSTRING("
 9633+ CONSTANT TABLE")
 9634           I=BASE
 9635           %CYCLE
 9636              NEWLINE
 9637              PRHEX(CA+4*(I-BASE),5)
 9638              %CYCLE J=0,1,7
 9639                 SPACES(2)
 9640                 PRHEX(CTABLE_val(I+J),8)
 9641              %REPEAT
 9642              SPACE
 9643              %CYCLE J=0,1,31
 9644                 K=BYTEINTEGER(ADDR(CTABLE_val(I))+J)
 9645                 %IF K<31 %OR K>95 %THEN K=32
 9646                 PRINT SYMBOL(K)
 9647              %REPEAT
 9648              I=I+8
 9649              %EXIT %IF I>=CONSTPTR
 9650           %REPEAT
 9651        %FINISH
 9652  !*DELEND
 9653  !
 9654        FILL(CREFHEAD)
 9655        SIZE=(SIZE+1)&(-2)
 9656        CA=CA+4*SIZE
 9657        CABUF=CA
 9658        %RETURN
 9659  %ROUTINE FILL(%INTEGER CREFHEAD)
 9660        DISP=(CA-4*BASE)//2;            ! RELOCATION FACTOR
 9661        %WHILE CREFHEAD#0 %CYCLE
 9662           POP(CREFHEAD,I,J,K)
 9663           DOIT(I)
 9664           %IF J#0 %THEN DOIT(J)
 9665           %IF K#0 %THEN DOIT(K)
 9666        %REPEAT
 9667  %END
 9668  %ROUTINE DOIT(%INTEGER VAL)
 9669  !***********************************************************************
 9670  !*    IF VAL +VE THEN VAL IS CODE ADDRESS FOR LPUT(18) UPDATE          *
 9671  !*    IF VAL -VE IT IS GLAWRDADDRR<<16!CTABLE WRD ADDR                 *
 9672  !*    THE GLA WORD IS TO RELOCATED BY HEAD OF CODE(ALREADY DONE)       *
 9673  !*    HOWEVER THE GLAWORD NEEDS UPDATING FROM  REL CTABLE TO REL CODE  *
 9674  !***********************************************************************
 9675  %INTEGER I,J
 9676        %IF VAL>0 %THEN LPUT(18,0,VAL,DISP) %ELSE %START
 9677           I=(VAL>>16&16_7FFF)<<2;        ! GLA BYTE ADDRESS
 9678           J=4*(VAL&16_FFFF)+CA;          ! CTABLE ENTRY REL HD OF CODE
 9679           PLUG(2,I,J,4);                 ! UPDATE THE GLA WORD
 9680        %FINISH
 9681  %END
 9682  %END
 9683  %END;
?PCLOD unused
 9684       ;                                   ! OF SUBBLOCK CONTAINING PASS2
 9684  
 9685  %STRING(255)%FN MESSAGE(%INTEGER N)
 9686  !***********************************************************************
 9687  !*       OUTPUTS AN ERROR MESSAGE STORED IN A COMPRESSED FORMAT        *
 9688  !*       1  %REPEAT is not required                                    *
 9689  !*       2  Label & has already been set in this block                 *
 9690  !*       4  Switch & has not been declared                             *
 9691  !*       5  Switch name & in expression or assignment                  *
 9692  !*       6  Switch label &(#) set a second time                        *
 9693  !*       7  Name & has already been declared                           *
 9694  !*       8  Routine or fn & has more parameters than specified         *
 9695  !*       9  Parameter # of & differs in type from specification        *
 9696  !*      10  Routine or fn & has fewer parameters than specified        *
 9697  !*      11  Label & referenced at line # has not been set              *
 9698  !*      12  %CYCLE at line # has two control clauses                   *
 9699  !*      13  %REPEAT for %CYCLE at line # is missing                    *
 9700  !*      14  TOO MANY ENDS                                              *
 9701  !*      15  MISSING ENDS                                               *
 9702  !*      16  Name & has not been declared                               *
 9703  !*      17  Name & does not require parameters or subscripts           *
 9704  !*      19  WRONG NO OF PARAMETERS                                     *
 9705  !*      20  # too few subscripts provided for array &                  *
 9706  !*      21  # too many subscripts provided for array &                 *
 9707  !*      22  ACTUAL PARAMETERS NOT AS SPEC                              *
 9708  !*      23  ROUTINE NAME IN EXPRSSN                                    *
 9709  !*      24  REAL IN INTEGER EXPRSSN                                    *
 9710  !*      26  # is not a valid %EVENT number                             *
 9711  !*      27  & is not a routine name                                    *
 9712  !*      28  Routine or fn & has specification but no body              *
 9713  !*      29  LHS NOT DESTNTN                                            *
 9714  !*      30  %RETURN outwith routine body                               *
 9715  !*      31  %RESULT outwith fn or map body                             *
 9716  !*      32  INVALID ASSEMBLER                                          *
 9717  !*      33  INVALID NAME IN ASSEMBLER                                  *
 9718  !*      34  TOO MANY LEVELS                                            *
 9719  !*      37  TOO MANY DIMENSIONS                                        *
 9720  !*      38  Array & has upper bound # less than lower bound            *
 9721  !*      40  DECLN MISPLACED                                            *
 9722  !*      41  Constant cannot be evaluated at compile time               *
 9723  !*      44  ILLEGAL CONST                                              *
 9724  !*      45  WRONG NO OF CONST                                          *
 9725  !*      46  & is declared as invalid type %EXTRINSIC %NAME             *
 9726  !*      47  %ELSE already given at line #                              *
 9727  !*      48  %ELSE invalid after %ON %EVENT                             *
 9728  !*      49  Attempt to initialise %EXTRINSIC or %FORMAT &              *
 9729  !*      50  Subscript of # is outwith the bounds of &                  *
 9730  !*      51  %FINISH is not required                                    *
 9731  !*      52  %REPEAT instead of %FINISH for %START at line #            *
 9732  !*      53  %FINISH for %START at line # is missing                    *
 9733  !*      54  %EXIT outwith %CYCLE %REPEAT body                          *
 9734  !*      55  %CONTINUE outwith %CYCLE %REPEAT body                      *
 9735  !*      56  ENDOFFILE OUT OF CONTEXT                                   *
 9736  !*      57  BEGIN MISSING                                              *
 9737  !*      58  CONTROL STMNT MISPLACED                                    *
 9738  !*      59  %FINISH instead of %REPEAT for %CYCLE at line #            *
 9739  !*      61  Name & has already been used in this %FORMAT               *
 9740  !*      62  NOT FORMAT NAME                                            *
 9741  !*      63  RECORD SPEC ERROR                                          *
 9742  !*      64  SUBNAME MISSING                                            *
 9743  !*      65  SUBNAME NOT IN FORMAT                                      *
 9744  !*      66  Expression assigned to record &                            *
 9745  !*      67  Records && and & have different formats                    *
 9746  !*      69  SUBNAME OUT OF CONTEXT                                     *
 9747  !*      70  ILLEGAL STRING DECLN                                       *
 9748  !*      71  & is not a String varaible                                 *
 9749  !*      72  Arithmetic operator in a String expression                 *
 9750  !*      73  Arithmetic constant in a String expression                 *
 9751  !*      74  Resolution is not the correct format                       *
 9752  !*      75  String expression contains a sub expression                *
 9753  !*      76  String variable & in arithmetic expression                 *
 9754  !*      77  String constant in arithmetic expression                   *
 9755  !*      78  String operator '.' in arithmetic expression               *
 9756  !*      80  Pointer variable & compared with expression                *
 9757  !*      81  Pointer variable & equivalenced to expression              *
 9758  !*      82  & is not a pointer name                                    *
 9759  !*      83  && and & are not equivalent in type                        *
 9760  !*      84  RECORD OUT OF CONTEXT                                      *
 9761  !*      86  Global pointer && equivalenced to local &                  *
 9762  !*      90  Untyped name & used as variable                            *
 9763  !*      91  %FOR control variable & not integer                        *
 9764  !*      92  %FOR clause has zero step                                  *
 9765  !*      93  %FOR clause has noninteger number of traverses             *
 9766  !*     101  SOURCE LINE TOO LONG                                       *
 9767  !*     102  WORKFILE TOO SMALL                                         *
 9768  !*     103  NAMES TOO LONG                                             *
 9769  !*     104  TOO MANY NAMES                                             *
 9770  !*     105  TOO MANY LEVELS                                            *
 9771  !*     106  STRING CONST TOO LONG                                      *
 9772  !*     107  COMPILER TABLES FULL                                       *
 9773  !*     202  Name & not used                                            *
 9774  !*     203  Label & not used                                           *
 9775  !*     204  Global %FOR control variable &                             *
 9776  !*     205  Name & not addressable                                     *
 9777  !*     255  SEE IMP MANUAL                                             *
 9778  !***********************************************************************
 9779  %CONSTBYTEINTEGERARRAY OUTTT(0:63)='?','A','B','C','D','E','F','G',
 9780+                                         'H','I','J','K','L','M','N',
 9781+                                         'O','P','Q','R','S','T','U',
 9782+                                         'V','W','X','Y','Z','&','-',
 9783+                                         '/','''','(',')',
 9784+                                         'a','b','c','d','e','f','g',
 9785+                                         'h','i','j','k','l','m','n',
 9786+                                         'o','p','q','r','s','t','u',
 9787+                                         'v','w','x','y','z','.','%',
 9788+                                         '#','?'(2)
 9789  %CONSTINTEGER WORDMAX= 584,DEFAULT= 580
 9790  {%CONST}%own{HALF}%INTEGERARRAY WORD(0:WORDMAX)=0,{%C
 9791+               1, 32769, 32771, 32772, 32773,     2, 32775, 32776,
 9792+           32777, 32778, 32780, 32781, 32782, 32783, 32784,     4,
 9793+           32785, 32776, 32777, 32772, 32780, 32787,     5, 32785,
 9794+           32789, 32776, 32782, 32790, 32792, 32793,     6, 32785,
 9795+           32795, 32796, 32781, 32797, 32798, 32800,     7, 32801,
 9796+           32776, 32777, 32778, 32780, 32787,     8, 32802, 32792,
 9797+           32804, 32776, 32777, 32805, 32806, 32808, 32809,     9,
 9798+           32811, 32813, 32814, 32776, 32815, 32782, 32817, 32818,
 9799+           32819,    10, 32802, 32792, 32804, 32776, 32777, 32822,
 9800+           32806, 32808, 32809,    11, 32775, 32776, 32823, 32825,
 9801+           32826, 32813, 32777, 32772, 32780, 32781,    12, 32827,
 9802+           32825, 32826, 32813, 32777, 32829, 32830, 32832,    13,
 9803+           32769, 32834, 32827, 32825, 32826, 32813, 32771, 32835,
 9804+              14, 32837, 32838, 32839,    15, 32840, 32839,    16,
 9805+           32801, 32776, 32777, 32772, 32780, 32787,    17, 32801,
 9806+           32776, 32842, 32772, 32843, 32806, 32792, 32845,    19,
 9807+           32847, 32848, 32849, 32850,    20, 32813, 32852, 32853,
 9808+           32845, 32854, 32834, 32856, 32776,    21, 32813, 32852,
 9809+           32857, 32845, 32854, 32834, 32856, 32776,    22, 32858,
 9810+           32850, 32860, 32861, 32862,    23, 32863, 32865, 32866,
 9811+           32867,    24, 32869, 32866, 32870, 32867,    26, 32813,
 9812+           32771, 32772, 32797, 32872, 32873, 32875,    27, 32776,
 9813+           32771, 32772, 32797, 32877, 32789,    28, 32802, 32792,
 9814+           32804, 32776, 32777, 32819, 32879, 32880, 32881,    29,
 9815+           32882, 32860, 32883,    30, 32885, 32887, 32877, 32881,
 9816+              31, 32889, 32887, 32804, 32792, 32891, 32881,    32,
 9817+           32892, 32894,    33, 32892, 32865, 32866, 32894,    34,
 9818+           32837, 32838, 32896,    37, 32837, 32838, 32898,    38,
 9819+           32900, 32776, 32777, 32901, 32902, 32813, 32903, 32808,
 9820+           32904, 32902,    40, 32905, 32906,    41, 32908, 32910,
 9821+           32912, 32913, 32825, 32915, 32800,    44, 32917, 32919,
 9822+              45, 32847, 32848, 32849, 32919,    46, 32776, 32771,
 9823+           32787, 32920, 32921, 32817, 32923, 32925,    47, 32926,
 9824+           32778, 32927, 32825, 32826, 32813,    48, 32926, 32921,
 9825+           32928, 32929, 32873,    49, 32930, 32932, 32933, 32923,
 9826+           32792, 32935, 32776,    50, 32937, 32814, 32813, 32771,
 9827+           32887, 32939, 32940, 32814, 32776,    51, 32942, 32771,
 9828+           32772, 32773,    52, 32769, 32944, 32814, 32942, 32834,
 9829+           32946, 32825, 32826, 32813,    53, 32942, 32834, 32946,
 9830+           32825, 32826, 32813, 32771, 32835,    54, 32948, 32887,
 9831+           32827, 32769, 32881,    55, 32949, 32887, 32827, 32769,
 9832+           32881,    56, 32951, 32953, 32849, 32954,    57, 32956,
 9833+           32840,    58, 32957, 32959, 32906,    59, 32942, 32944,
 9834+           32814, 32769, 32834, 32827, 32825, 32826, 32813,    61,
 9835+           32801, 32776, 32777, 32778, 32780, 32960, 32782, 32783,
 9836+           32935,    62, 32860, 32961, 32865,    63, 32963, 32862,
 9837+           32965,    64, 32966, 32840,    65, 32966, 32860, 32866,
 9838+           32961,    66, 32968, 32970, 32932, 32972, 32776,    67,
 9839+           32974, 32976, 32977, 32776, 32978, 32979, 32981,    69,
 9840+           32966, 32953, 32849, 32954,    70, 32917, 32983, 32905,
 9841+              71, 32776, 32771, 32772, 32797, 32985, 32987,    72,
 9842+           32989, 32991, 32782, 32797, 32985, 32790,    73, 32989,
 9843+           32993, 32782, 32797, 32985, 32790,    74, 32995, 32771,
 9844+           32772, 32939, 32997, 32999,    75, 32985, 32790, 33001,
 9845+           32797, 33003, 32790,    76, 32985, 33004, 32776, 32782,
 9846+           33006, 32790,    77, 32985, 32993, 32782, 33006, 32790,
 9847+              78, 32985, 32991, 33008, 32782, 33006, 32790,    80,
 9848+           33009, 33004, 32776, 33011, 33013, 32790,    81, 33009,
 9849+           33004, 32776, 33014, 32932, 32790,    82, 32776, 32771,
 9850+           32772, 32797, 33017, 32789,    83, 32976, 32977, 32776,
 9851+           33019, 32772, 33020, 32782, 32817,    84, 32963, 32953,
 9852+           32849, 32954,    86, 33022, 33017, 32976, 33014, 32932,
 9853+           33024, 32776,    91, 33025, 32830, 33004, 32776, 32772,
 9854+           33026,    92, 33025, 33028, 32777, 33030, 33031,    93,
 9855+           33025, 33028, 32777, 33032, 32875, 32814, 33034,    90,
 9856+           33036, 32789, 32776, 32960, 32920, 33004,     8, 33038,
 9857+             101, 33041, 33043, 32837, 33044,   102, 33045, 32837,
 9858+           33047,   103, 33048, 32837, 33044,   104, 32837, 32838,
 9859+           33048,   105, 32837, 32838, 32896,   106, 32983, 32919,
 9860+           32837, 33044,   107, 33049, 33051, 33053,   202, 32801,
 9861+           32776, 32772, 32960,   203, 32775, 32776, 32772, 32960,
 9862+             204, 33022, 33025, 32830, 33004, 32776,   205, 32801,
 9863+           32776, 32772, 33054,   255, 33057, 33058, 33059,     0
 9864           
 9865  %CONSTINTEGERARRAY LETT(0: 292)=0,{%C
 9866+         16_7890A80B,16_02A00000,16_53980000,16_5D7E8000,
 9867+         16_652E3AD3,16_652C8000,16_190C52D8,16_36000000,
 9868+         16_510E6000,16_436652C3,16_49C80000,16_452CB700,
 9869+         16_672E8000,16_53700000,16_69453980,16_4565F1D6,
 9870+         16_27BD3A47,16_50000000,16_492C7643,16_652C8000,
 9871+         16_5D0DB280,16_4BC6194B,16_679D37DC,16_5F900000,
 9872+         16_439E74CF,16_5D6CB768,16_590C52D8,16_36FFB000,
 9873+         16_42000000,16_672C77DD,16_48000000,16_694DB280,
 9874+         16_1D0DB280,16_257EBA53,16_5D280000,16_4D700000,
 9875+         16_5B7E5280,16_610E50DB,16_4BA4B966,16_69443700,
 9876+         16_6784B1D3,16_4D4CB200,16_210E50DB,16_4BA4B900,
 9877+         16_7A000000,16_5F300000,16_494CD34B,16_65980000,
 9878+         16_69CE1280,16_4D95F680,16_6784B1D3,16_4D4C70E9,
 9879+         16_537DC000,16_4D2EF2E4,16_652CD2E5,16_4B7472C8,
 9880+         16_43A00000,16_594DD280,16_781B2199,16_0A000000,
 9881+         16_69BDE000,16_477DDA65,16_5F600000,16_47643AE7,
 9882+         16_4B980000,16_4D7E4000,16_5B4E79D3,16_5D380000,
 9883+         16_2879E000,16_1A09CC80,16_0A708980,16_1A4A6993,
 9884+         16_1C380000,16_497CB980,16_652E3AD3,16_65280000,
 9885+         16_67AC59C7,16_654E1A66,16_2E91E70E,16_1C780000,
 9886+         16_1E300000,16_200A409B,16_0AA0A926,16_697DE000,
 9887+         16_4D2EE000,16_6195FB53,16_492C8000,16_439650F2,
 9888+         16_5B0DDC80,16_021A8A83,16_18000000,16_1C7A8000,
 9889+         16_02980000,16_2680A180,16_247AAA13,16_1C280000,
 9890+         16_1C09A280,16_12700000,16_0AC20927,16_26700000,
 9891+         16_24282600,16_1272828F,16_0A900000,16_6D0D94C8,
 9892+         16_782AC29D,16_28000000,16_5DADB14B,16_64000000,
 9893+         16_657EBA53,16_5D280000,16_45AE8000,16_5D780000,
 9894+         16_457C9C80,16_18426000,16_082A6A1D,16_28700000,
 9895+         16_7890AA2B,16_24700000,16_5FAE9BD3,16_69400000,
 9896+         16_7890A9AB,16_18A00000,16_5B0E0000,16_1272C099,
 9897+         16_12200000,16_029A629B,16_0460A900,16_182AC299,
 9898+         16_26000000,16_0849A29D,16_2649E726,16_039650F2,
 9899+         16_6B8612E4,16_457EB748,16_592E7980,16_597EF2E4,
 9900+         16_0828661C,16_1A4A6819,16_0218A200,16_077DD9E9,
 9901+         16_43768000,16_470DD75F,16_68000000,16_45280000,
 9902+         16_4BB4366B,16_43A4B200,16_477DB853,16_59280000,
 9903+         16_1261828F,16_02600000,16_0679C9A8,16_43980000,
 9904+         16_5376D0D9,16_53200000,16_782B0A25,16_12726486,
 9905+         16_7870268A,16_7829898A,16_4F4ED2DC,16_433692E4,
 9906+         16_7879C000,16_03A692DB,16_61A00000,16_69780000,
 9907+         16_53753A53,16_436539CA,16_7831E91B,16_02A00000,
 9908+         16_27AC59C7,16_654E1A00,16_6944A000,16_457EB749,
 9909+         16_66000000,16_78312713,16_26400000,16_53767A4B,
 9910+         16_43200000,16_789A80A5,16_28000000,16_782B04A8,
 9911+         16_7819E729,16_1272A280,16_0A70878D,16_0C498280,
 9912+         16_1EAA8000,16_0679CA0B,16_30A00000,16_0428E49C,
 9913+         16_0679CA25,16_1E600000,16_26A1A728,16_6B9CB200,
 9914+         16_0C7A4683,16_28000000,16_242867A5,16_08000000,
 9915+         16_0A9247A4,16_26A84703,16_1A280000,16_0BC6194B,
 9916+         16_679D37DC,16_439E74CF,16_5D2C8000,16_652C77E5,
 9917+         16_48000000,16_252C77E5,16_49980000,16_36D80000,
 9918+         16_43748000,16_510ED280,16_494CD34B,16_652DDA00,
 9919+         16_4D7E56C3,16_69980000,16_26A2449D,16_0E000000,
 9920+         16_27A654DD,16_4E000000,16_6D0E50D3,16_4564A000,
 9921+         16_03953A51,16_5B2E94C6,16_5F84B943,16_697E4000,
 9922+         16_477DD9E9,16_43768000,16_252E77D9,16_6BA537DC,
 9923+         16_477E594B,16_47A00000,16_4D7E56C3,16_68000000,
 9924+         16_477DDA43,16_53766000,16_67AC4000,16_6D0E54C3,
 9925+         16_4564A000,16_43953A51,16_5B2E94C6,16_3DDBC000,
 9926+         16_217D3769,16_4B900000,16_477DB843,16_652C8000,
 9927+         16_6F4E9400,16_4B8EB4ED,16_4364B747,16_4B200000,
 9928+         16_617D3769,16_4B900000,16_4394A000,16_4B8EB4ED,
 9929+         16_4364B768,16_0F65F143,16_58000000,16_597C70D8,
 9930+         16_7831E900,16_537692CF,16_4B900000,16_47643AE7,
 9931+         16_4A000000,16_752E5780,16_67A4B800,16_5D7DD4DD,
 9932+         16_692CF2E4,16_69943B4B,16_659CB980,16_2B769CE1,
 9933+         16_4B200000,16_0220890B,16_26982113,16_184A8C80,
 9934+         16_267AA907,16_0A000000,16_1849C280,16_1879C380,
 9935+         16_2E7A458D,16_1260A000,16_26682618,16_1C09A2A6,
 9936+         16_0679A813,16_182A4000,16_2808460B,16_26000000,
 9937+         16_0CA98600,16_4324994B,16_679C3159,16_4A000000,
 9938+         16_2628A000,16_126A0000,16_1A09CA83,16_18000000
 9939          
 9940  %INTEGER I,J,K,M,Q,S
 9941  %STRING(70)OMESS
 9942        OMESS=" "
 9943        %CYCLE I=1,1,WORDMAX-1
 9944           ->FOUND %IF N=WORD(I)
 9945        %REPEAT
 9946        I=DEFAULT
 9947  FOUND:
 9948        J=1
 9949        %CYCLE
 9950           K=WORD(I+J)
 9951           %IF K&16_8000=0 %THEN %EXIT
 9952           K=K!!16_8000
 9953           OMESS=OMESS." " %UNLESS J=1
 9954           {%UNTIL M&1=0} %CYCLE
 9955              M=LETT(K); S=25
 9956              {%UNTIL S<0} %CYCLE
 9957                 Q=M>>S&63; 
 9958                 %IF Q\=0 %THEN OMESS=OMESS.TOSTRING(OUTTT(Q))
 9959                 S=S-6
 9960              %REPEAT %UNTIL S<0
 9961              K=K+1
 9962           %REPEAT %UNTIL M&1=0
 9963           J=J+1
 9964        %REPEAT
 9965        %RESULT=OMESS
 9966  %END
 9967  %STRING(16)%FN SWRITE(%INTEGER VALUE, PLACES)
 9968    %result = ITOS(VALUE,PLACES)  {ITOS available in new Imp2021 but not earlier Imp77}
 9969    {This block was NOT guarded by conditional compilation test "%IF USE IMP=YES %THEN %START" ...}
 9970  !%STRING (16) S
 9971  !%INTEGER D0, D1, D2, D3, L
 9972  !      PLACES=PLACES&15
 9973  !      *LSS_VALUE;  *CDEC_0
 9974  !      *LD_S;  *INCA_1;  *STD_%TOS
 9975  !      *CPB_%B;                          ! SET CC=0
 9976  !      *SUPK_%L=15,0,32;                 ! UNPACK & SPACE FILL
 9977  !      *STD_D2;  *JCC_8,<WASZERO>
 9978  !      *LD_%TOS;  *STD_D0;               ! FOR SIGN INSERTION
 9979  !      *LD_%TOS
 9980  !      *MVL_%L=15,63,0;                  ! FORCE ISO ZONE CODES
 9981  !      %IF VALUE<0 %THEN BYTEINTEGER(D1)='-'
 9982  !      L=D3-D1
 9983  !OUT:  %IF PLACES>=L %THEN L=PLACES+1
 9984  !      D3=D3-L-1
 9985  !      BYTEINTEGER(D3)=L
 9986  !      %RESULT=STRING(D3)
 9987  !WASZERO:
 9988  !      BYTEINTEGER(D3-1)='0'
 9989  !      L=2;  ->OUT
 9990  %END
 9991  %ROUTINE FAULT2(%INTEGER N, DATA, IDENT)
 9992  !***********************************************************************
 9993  !*    SETS UP AN ERROR MESSAGE AND SHOVES IT OUT ONTO THE LISTING      *
 9994  !*    AN ALSO OPTIONALLY TO THE TERMINAL                               *
 9995  !***********************************************************************
 9996  %INTEGER I, J, T
 9997  %STRING(255)MESS1,MESS2,WK1,WK2
 9998  !*DELSTART
 9999        %MONITOR %IF FAULTY<=1 %AND (SMAP#0 %OR DCOMP#0)
10000  !*DELEND
10001        MESS1=""; MESS2=""
10002        FAULTY=FAULTY+1
10003        %IF N=100 %THEN %START;           ! SYNTAX FAULTS ARE SPECIAL
10004           MESS1=snl."*    Failed to analyse line ".SWRITE(LINE,2).snl."     "
10005           %IF LINE#OLDLINE %THEN %START
10006            MESS1=MESS1."Text mode failure - erroneos source line not available".snl
10007           %FINISH %ELSE %START
10008              J=0;  S=0;  T=0
10009              {%UNTIL (J=';' %AND Q>QMAX) %OR Q=LENGTH} %CYCLE
10010                 I=J;  J=BYTEINTEGER(DATA+Q);! DATA HAS ADDR(CC(0))
10011                 %IF J>128 %AND I<128 %THEN MESS2=MESS2." %" %AND T=T+2
10012                 %IF I>128 %AND J<128 %THEN MESS2=MESS2." " %AND T=T+1
10013                 MESS2=MESS2.TOSTRING(J)
10014                 T=T+1
10015                 %IF Q=QMAX %THEN S=T
10016                 Q=Q+1
10017                 %EXIT %IF T>=250
10018              %REPEAT %UNTIL (J=';' %AND Q>QMAX) %OR Q=LENGTH
10019              %IF Q=QMAX %THEN S=T
10020           %FINISH
10021        %FINISH %ELSE %START
10022           MESS1="
10023+ *".SWRITE(LINE, 4)."   "
10024           PARMOPT=1
10025           INHCODE=1 %IF PARMLET=0;    ! STOP GENERATING CODE
10026           MESS1=MESS1."FAULT".SWRITE(N,2)
10027           MESS2=MESSAGE(N)
10028           %IF MESS2->WK1.("##").WK2 %THEN MESS2=WK1.SWRITE(IDENT,1).WK2
10029           %IF MESS2->WK1.("#").WK2 %THEN MESS2=WK1.SWRITE(DATA,1).WK2
10030           %IF MESS2->WK1.("&&").WK2 %THEN MESS2=WK1.PRINTNAME(DATA).WK2
10031           %IF MESS2->WK1.("&").WK2 %THEN MESS2=WK1.PRINTNAME(IDENT).WK2
10032           %IF N>100 %THEN MESS2=MESS2." Disaster"
10033        %FINISH
10034        %CYCLE I=2,-1,1
10035           SELECT OUTPUT(TTOPUT) %IF I=1
10036           PRINTSTRING(MESS1)
10037           PRINTSTRING(MESS2) %IF MESS2#""
10038           %IF N=100 %AND S<115 %THEN %START
10039              NEWLINE; SPACES(S+4); PRINTSYMBOL('!')
10040           %FINISH
10041           NEWLINE
10042           SELECT OUTPUT(82) %IF I=1
10043           %EXIT %IF TTOPUT<=0
10044        %REPEAT
10045        %IF N>100 %THEN %MONITOR %AND %STOP
10046  %END
10047  %ROUTINE FAULT(%INTEGER N,FNAME)
10048        FAULT2(N,FNAME,FNAME)
10049  %END
10050  %ROUTINE WARN(%INTEGER N,V)
10051  %STRING(30) T; %STRING(120) S
10052        S=MESSAGE(N+200)
10053        %IF S->S.("&").T %THEN S=S.PRINTNAME(V).T
10054        PRINTSTRING("
10055+ ?  Warning :- ".S." at line No".SWRITE(LINE,1))
10056        NEWLINE
10057  %END
10058                                          ! THE NEXT 4 ROUTINES CAN BE 
10059                                          !MACROISED USING MVC
10060  !
10061  %ROUTINE TOAR2(%INTEGER PTR,VALUE)
10062  !     %IF USE IMP=YES %THEN %START
10063           A(PTR+1)<-VALUE
10064           A(PTR)<-VALUE>>8
10065  !     %FINISH %ELSE %START
10066  !    *LSS_VALUE
10067  !       *LDTB_16_58000002
10068  !       *LDA_A+4
10069  !       *INCA_PTR
10070  !       *ST_(%DR)
10071  !     %FINISH
10072  %END
10073  %ROUTINE TOAR4(%INTEGER PTR, VALUE)
10074  %INTEGER I
10075  !     %IF USE IMP=YES %THEN %START
10076           %CYCLE I=0,1,3
10077              A(PTR+I)=BYTE INTEGER(ADDR(VALUE)+I)
10078           %REPEAT
10079  !     %FINISH %ELSE %START
10080  !       *LSS_VALUE
10081  !       *LDTB_16_58000004
10082  !       *LDA_A+4
10083  !       *INCA_PTR
10084  !       *ST_(%DR)
10085  !     %FINISH
10086  %END
10087  %ROUTINE TOAR8(%INTEGER PTR, %LONGREAL VALUE)
10088  %INTEGER I
10089  !     %IF USE IMP=YES %THEN %START
10090           %CYCLE I=0,1,7
10091              A(PTR+I)=BYTE INTEGER(ADDR(VALUE)+I)
10092           %REPEAT
10093  !     %FINISH %ELSE %START
10094  !       *LSD_VALUE
10095  !       *LDTB_16_58000008
10096  !       *LDA_A+4
10097  !       *INCA_PTR
10098  !       *ST_(%DR)
10099  !     %FINISH
10100  %END
10101  %INTEGERFN FROMAR2(%INTEGER PTR)
10102  !     %IF USE IMP=YES %THEN %start
10103           %RESULT=A(PTR)<<8!A(PTR+1)
10104  !     %finish%ELSE%START
10105  !       *LDTB_16_58000002
10106  !       *LDA_A+4
10107  !       *INCA_PTR
10108  !       *LSS_(%DR)
10109  !       *EXIT_-64
10110  !     %FINISH
10111  %END
10112  %INTEGERFN FROMAR4(%INTEGER PTR)
10113  !     %IF USE IMP=YES %THEN %START
10114           %RESULT=A(PTR)<<24!A(PTR+1)<<16!A(PTR+2)<<8!A(PTR+3)
10115  !     %FINISH %ELSE %START
10116  !       *LDTB_16_58000004
10117  !       *LDA_A+4
10118  !       *INCA_PTR
10119  !       *LSS_(%DR)
10120  !       *EXIT_-64
10121  !     %FINISH
10122  %END
10123  %STRING(255)%FN PRINTNAME(%INTEGER N)
10124  %INTEGER V, K
10125  %STRING(255)S
10126        V=WORD(N)
10127           K=BYTE INTEGER(DICTBASE+V)
10128        %IF K=0 %THEN S="???" %ELSE S=STRING(DICTBASE+V)
10129        %RESULT=S
10130   %END
10131  !*DELSTART
10132  %ROUTINE PRHEX(%INTEGER VALUE, PLACES)
10133  %CONSTBYTEINTEGERARRAY HEX(0:15)='0','1','2','3','4',
10134+                '5','6','7','8','9','A','B','C','D','E','F'
10135  %INTEGER I
10136           %CYCLE I=PLACES<<2-4, -4, 0
10137              PRINT SYMBOL(HEX(VALUE>>I&15))
10138           %REPEAT
10139  %END
10140           %ROUTINE PRINT LIST(%INTEGER HEAD)
10141           %INTEGER I,J,K
10142           PRINTSTRING("
10143+ PRINT OF LIST ")
10144           WRITE(HEAD,2)
10145           NEWLINE
10146           %WHILE HEAD#0 %CYCLE
10147              FROM123(HEAD,I,J,K)
10148              WRITE(HEAD,3)
10149              SPACES(3)
10150              PRHEX(I,8)
10151              SPACES(3)
10152              PRHEX(J,8)
10153              SPACES(3)
10154              PRHEX(K,8)
10155              NEWLINE
10156              MLINK(HEAD)
10157              HEAD=HEAD&16_FFFF;          ! EXTRA LINK IN TAGS LIST!!
10158           %REPEAT
10159           %END
10160  !
10161  %ROUTINE CHECK ASL
10162  !***********************************************************************
10163  !*    CHECK ASL AND PRINT NO OF FREE CELLS. DEBUGGING SERVICE ONLY     *
10164  !***********************************************************************
10165  %INTEGER N,Q
10166        Q=ASL; N=0
10167        %WHILE Q#0 %CYCLE
10168           N=N+1
10169           Q=ASLIST(Q)_LINK
10170        %REPEAT
10171        NEWLINE
10172        PRINTSTRING("FREE CELLS AFTER LINE ")
10173        WRITE(LINE,3)
10174        PRINTSYMBOL('=')
10175        WRITE(N,3)
10176  %END
10177  !*DELEND
10178  %INTEGERFN MORE SPACE
10179  !***********************************************************************
10180  !*    FORMATS UP SOME MORE OF THE ASL                                  *
10181  !***********************************************************************
10182  %INTEGER I,N,CL,AMOUNT
10183        N=ASL CUR BTM-1
10184        AMOUNT=(NNAMES+1)>>3;             ! EIGHTTH OF NNAMES
10185        I=ASL CUR BTM-((CONST PTR+8)>>2);! GAP BETWEEN CONSTS &ASL
10186        %IF I>>1<AMOUNT %THEN AMOUNT=I>>1 %AND ASL WARN=1;! HALF THE GAP MAX
10187        %IF AMOUNT<20 %THEN AMOUNT=0
10188        ASL CUR BTM=ASL CUR BTM-AMOUNT
10189        %IF ASL CUR BTM<=1 %THEN ASL CUR BTM=1
10190        CL=4*ASL CUR BTM-8
10191        %IF ASL CUR BTM>=N %OR CONST PTR>CL %THEN %START
10192           ASL CUR BTM=N+1;               ! AS YOU WERE
10193           %CYCLE I=12,-1,1
10194              %IF DVHEADS(I)#0 %THEN CLEAR LIST(DVHEADS(I))
10195           %REPEAT
10196           %IF ASL#0 %THEN %RESULT=ASL
10197           FAULT(107,0)
10198        %FINISH %ELSE CONST LIMIT=CL;     ! NEW VALUE WITH BIGGER ASL
10199        %CYCLE I=ASL CUR BTM,1,N-1
10200           ASLIST(I+1)_LINK=I
10201        %REPEAT
10202        ASLIST(ASL CUR BTM)_LINK=0
10203        ASL=N; %RESULT=N
10204  %END
10205  !%INTEGERFN NEW CELL
10206  !***********************************************************************
10207  !*       PROVIDE A NEW LIST PROCESSING CELL. CRAPOUT IF NONE AVAILABLE *
10208  !***********************************************************************
10209  !%INTEGER I
10210  !         %IF ASL=0 %THEN ASL=MORE SPACE
10211  !         I=ASL
10212  !         ASL=ASLIST(ASL)_LINK
10213  !         ASLIST(I)_LINK=0
10214  !         %RESULT =I
10215  !%END
10216  %ROUTINE PUSH(%INTEGERNAME CELL, %INTEGER S1, S2, S3)
10217  !***********************************************************************
10218  !*       PUSH A CELL CONTAINING THE 3 STREAMS OF INFORMATION GIVEN     *
10219  !*       ONTO THE TOP OF THE LIST POINTED AT BY CELL.                  *
10220  !***********************************************************************
10221  %RECORD(LISTF)%NAME LCELL{(LISTF)
10222  %INTEGER I
10223        I=ASL
10224        %IF I=0 %THEN I=MORE SPACE
10225  !     %IF USE IMP=YES %THEN %START
10226           LCELL==ASLIST(I)
10227           ASL=LCELL_LINK
10228           LCELL_LINK=CELL
10229           CELL=I
10230           LCELL_S1=S1
10231           LCELL_S2=S2
10232           LCELL_S3=S3
10233  !     %FINISH %ELSE %START
10234  !        *LB_I
10235  !        *MYB_16
10236  !        *ADB_ASLIST+4
10237  !        *LCT_%B
10238  !        *LSS_(%CTB+3)
10239  !        *ST_ASL
10240  !        *LB_I
10241  !        *LSS_(CELL)
10242  !        *STB_(%DR)
10243  !        *LUH_S3
10244  !        *LUH_S1
10245  !        *ST_(%CTB+0)
10246  !     %FINISH
10247  %END
10248  %ROUTINE POP(%INTEGERNAME CELL, S1, S2, S3)
10249  !***********************************************************************
10250  !*       COPY THE INFORMATION FROM THE TOP CELL OF LIST 'CELL' INTO    *
10251  !*         S1,S2&S3 AND THEN POP THE LIST UP 1 CELL. EMPTYLIST GIVE -1S*
10252  !***********************************************************************
10253  %RECORD(LISTF)%NAME LCELL{(LISTF)
10254  %INTEGER I
10255  !     %IF USE IMP=YES %THEN %START
10256           I=CELL
10257           LCELL==ASLIST(I)
10258           S1=LCELL_S1
10259           S2=LCELL_S2
10260           S3=LCELL_S3
10261           %IF I# 0 %THEN %START
10262              CELL=LCELL_LINK
10263              LCELL_LINK=ASL
10264              ASL=I
10265           %FINISH
10266  !     %FINISH %ELSE %START
10267  !        *LB_(CELL)
10268  !        *STB_I
10269  !        *MYB_16
10270  !        *ADB_ASLIST+4
10271  !        *LCT_%B
10272  !        *LSD_(%CTB+0)
10273  !        *STUH_(S1)
10274  !        *LB_I
10275  !        *ST_(S2)
10276  !        *LSD_(%CTB+2)
10277  !        *STUH_(S3)
10278  !        *JAT_12,<END>
10279  !        *ST_(CELL)
10280  !        *LSS_ASL
10281  !        *ST_(%CTB+3)
10282  !        *STB_ASL
10283  !END:
10284  !     %FINISH
10285  %END
10286  %ROUTINE REPLACE1(%INTEGER CELL, S1)
10287           ASLIST(CELL)_S1=S1
10288  %END
10289  %ROUTINE REPLACE2(%INTEGER CELL, S2)
10290           ASLIST(CELL)_S2=S2
10291  %END
10292  %ROUTINE REPLACE3(%INTEGER CELL, S3)
10293           ASLIST(CELL)_S3=S3
10294  %END
10295           %ROUTINE BINSERT(%INTEGERNAME TOP,BOT,%INTEGER S1,S2,S3)
10296  !***********************************************************************
10297  !*       INSERT A CELL AT THE BOTTOM OF A LIST                         *
10298  !*       UPDATING TOP AND BOTTOM POINTERS APPROPIATELY                 *
10299  !***********************************************************************
10300  %INTEGER I,J
10301  %RECORD(LISTF)%NAME LCELL{(LISTF)
10302           I=ASL
10303           %IF I=0 %THEN I=MORE SPACE
10304           LCELL==ASLIST(I)
10305           ASL=LCELL_LINK
10306           LCELL_S1=S1; LCELL_S2=S2
10307           LCELL_S3=S3; LCELL_LINK=0
10308           J=BOT
10309           %IF J=0 %THEN BOT=I %AND TOP=BOT %ELSE %START
10310              ASLIST(J)_LINK=I
10311              BOT=I
10312           %FINISH
10313  %END
10314  %ROUTINE INSERT AT END(%INTEGERNAME CELL, %INTEGER S1, S2, S3)
10315  !***********************************************************************
10316  !*       ADD A CELL TO THE BOTTOM OF THE LIST HEADED BY 'CELL'         *
10317  !***********************************************************************
10318  %INTEGER I,J,N
10319  %RECORD(LISTF)%NAME LCELL{(LISTF)
10320           I=CELL; J=I
10321           %WHILE I#0 %CYCLE
10322              J=I
10323              I=ASLIST(J)_LINK
10324           %REPEAT
10325           N=ASL
10326           %IF N=0 %THEN N=MORE SPACE
10327           LCELL==ASLIST(N)
10328           ASL=LCELL_LINK
10329           %IF J=0 %THEN CELL=N %ELSE ASLIST(J)_LINK=N
10330           LCELL_S1=S1
10331           LCELL_S2=S2
10332           LCELL_S3=S3
10333           LCELL_LINK=0
10334  %END
10335  %ROUTINE REPLACE123(%INTEGER CELL,S1,S2,S3)
10336           ASLIST(CELL)_S1=S1
10337           ASLIST(CELL)_S2=S2
10338           ASLIST(CELL)_S3=S3
10339  %END
10340  %ROUTINE MLINK(%INTEGERNAME CELL)
10341           CELL=ASLIST(CELL)_LINK
10342  %END
10343  %INTEGERFN FIND(%INTEGER LAB, LIST)
10344  !***********************************************************************
10345  !*       THIS FUNCTION SEARCHES LIST 'LIST' FOR LAB IN STREAM2 AND     *
10346  !*       RETURNS THE CORRESPONDING CELL NO.IT USED FOR MORE THAN       *
10347  !*       SCANNING LABEL LISTS.                                         *
10348  !***********************************************************************
10349           %WHILE LIST#0 %CYCLE
10350              %RESULT=LIST %IF LAB=ASLIST(LIST)_S2
10351              LIST=ASLIST(LIST)_LINK
10352           %REPEAT
10353           %RESULT=-1
10354  %END
10355  %ROUTINE FROM123(%INTEGER CELL, %INTEGERNAME S1, S2, S3)
10356  !***********************************************************************
10357  !*       ALL THE FROMS RETURN INFO FROM CELLS OF A LIST WITHOUT        *
10358  !*       AFFECTING THE LIST IN ANY WAY.                                *
10359  !***********************************************************************
10360  %RECORD(LISTF)%NAME LCELL{(LISTF)
10361           LCELL==ASLIST(CELL)
10362           S1=LCELL_S1
10363           S2=LCELL_S2
10364           S3=LCELL_S3
10365  %END
10366  %ROUTINE FROM12(%INTEGER CELL, %INTEGERNAME S1, S2)
10367  %RECORD(LISTF)%NAME LCELL{(LISTF)
10368           LCELL==ASLIST(CELL)
10369           S1=LCELL_S1
10370           S2=LCELL_S2
10371  %END
10372  %INTEGERFN FROM1(%INTEGER CELL)
10373           %RESULT =ASLIST(CELL)_S1
10374  %END
10375  %INTEGERFN FROM2(%INTEGER CELL)
10376           %RESULT =ASLIST(CELL)_S2
10377  %END
10378  %INTEGERFN FROM3(%INTEGER CELL)
10379           %RESULT =ASLIST(CELL)_S3
10380  %END
10381  %ROUTINE CLEAR LIST(%INTEGERNAME OPHEAD)
10382  !***********************************************************************
10383  !*       THROW AWAY A COMPLETE LIST (MAY BE NULL!)                     *
10384  !***********************************************************************
10385  %INTEGER I, J
10386            I=OPHEAD; J=I
10387           %WHILE I#0 %CYCLE
10388              J=I
10389              I=ASLIST(J)_LINK
10390           %REPEAT
10391           %IF J#0 %START
10392              ASLIST(J)_LINK=ASL
10393              ASL=OPHEAD; OPHEAD=0
10394           %FINISH
10395  %END
10396  !%ROUTINE CONCAT(%INTEGERNAME LIST1, LIST2)
10397  !!***********************************************************************
10398  !!*        ADDS LIST2 TO BOTTOM OF LIST1                                *
10399  !!***********************************************************************
10400  !%INTEGER I,J
10401  !         I=LIST1
10402  !         J=I
10403  !         %WHILE I#0 %THEN J=I %AND I=ASLIST(J)_LINK
10404  !         %IF J=0 %THEN LIST1=LIST2 %ELSE ASLIST(J)_LINK=LIST2
10405  !         LIST2=0
10406  !%END;                                   ! AN ERROR PUTS CELL TWICE ONTO
10407                                          ! FREE LIST - CATASTROPHIC!
10408  %end
?CHECKASL unused
?PRINTLIST unused
10409  %ENDOFPROGRAM
?PARMY unused
?RSB unused
?STCT unused
?SLSQ unused
?LLN unused
?CEBIT unused
?USEIMP unused

 7940 Statements compiled
