!<arch>
//              1014905739  0     0     0       20        `
impcompdate.inc/



pass1.i/        844781016   12014 11130 100644  79093     `
!*                                                                  rs6p104
!* 21/12/92 - Changes to correctly number include file lines(pds)
!*                                                             rs6p102.i
!* 30/08/89 - changes incorporated (ex Sun3 version) to get source
!*            directly from buffer using Consource since read symbol
!*            is not supported (gm)
!*                                                             m88p102
!* 29/08/89 - original from pds (m88p102s on emas)
!*
%include "hostcodes.inc"

%CONSTINTEGER HOST=mips
%CONSTINTEGER TARGET=mips
! PRODUCED BY newps FROM imptocps on locust
%CONSTBYTEINTEGERARRAY CLETT(0: 436)=   1,
  40,   1,  41,   1,  42,   1,  44,   2, 201, 198,   6, 213, 206, 204,
 197, 211, 211,   5, 215, 200, 201, 204, 197,   5, 213, 206, 212, 201,
 204,   3, 198, 207, 210,   1,  61,   5, 193, 204, 201, 193, 211,   7,
 201, 206, 212, 197, 199, 197, 210,   4, 210, 197, 193, 204,   4, 204,
 207, 206, 199,   4, 194, 217, 212, 197,   6, 211, 212, 210, 201, 206,
 199,   4, 200, 193, 204, 198,   5, 211, 200, 207, 210, 212,   6, 210,
 197, 195, 207, 210, 196,   7, 210, 207, 213, 212, 201, 206, 197,   2,
 198, 206,   3, 205, 193, 208,   8, 198, 213, 206, 195, 212, 201, 207,
 206,   4, 206, 193, 205, 197,   9, 193, 210, 210, 193, 217, 206, 193,
 205, 197,   9, 207, 198, 208, 210, 207, 199, 210, 193, 205,   6, 207,
 198, 198, 201, 204, 197,   6, 207, 198, 204, 201, 211, 212,   6, 198,
 207, 210, 205, 193, 212,   3, 206, 207, 212,   3, 193, 206, 196,   2,
 207, 210,   1,  58,   4, 211, 208, 197, 195,   5, 193, 210, 210, 193,
 217,   3, 207, 215, 206,   8, 197, 216, 212, 197, 210, 206, 193, 204,
   9, 197, 216, 212, 210, 201, 206, 211, 201, 195,   8, 195, 207, 206,
 211, 212, 193, 206, 212,   5, 195, 207, 206, 211, 212,   5, 197, 214,
 197, 206, 212,   5, 211, 212, 193, 210, 212,   9, 212, 200, 197, 206,
 211, 212, 193, 210, 212,   4, 212, 200, 197, 206,   9, 197, 204, 211,
 197, 211, 212, 193, 210, 212,   4, 197, 204, 211, 197,   1,  95,   6,
 211, 217, 211, 212, 197, 205,   7, 196, 217, 206, 193, 205, 201, 195,
   4,  80,  85,  84,  95,   5,  67,  78,  79,  80,  95,   1,  43,   1,
  45,   1,  64,   2,  45,  62,   6, 210, 197, 212, 213, 210, 206,   6,
 210, 197, 211, 213, 204, 212,   7, 205, 207, 206, 201, 212, 207, 210,
   4, 211, 212, 207, 208,   6, 211, 201, 199, 206, 193, 204,   4, 197,
 216, 201, 212,   8, 195, 207, 206, 212, 201, 206, 213, 197,   6, 198,
 201, 206, 201, 211, 200,   5, 195, 217, 195, 204, 197,   6, 210, 197,
 208, 197, 193, 212,   3, 197, 206, 196,   7, 201, 206, 195, 204, 213,
 196, 197,   5, 194, 197, 199, 201, 206,   2, 207, 206,   6, 211, 215,
 201, 212, 195, 200,   4, 204, 201, 211, 212,  14, 212, 210, 213, 211,
 212, 197, 196, 208, 210, 207, 199, 210, 193, 205,   6, 205, 193, 201,
 206, 197, 208,   7, 195, 207, 206, 212, 210, 207, 204,   4,  40,  42,
  41,  58;

%CONSTINTEGERARRAY SYMBOL(1300: 2096)=  1311,
  1305,  1001,  1358,  1783,  1307,  1003,  1311,     0,  1337,     2,
  1321,  1315,  1001,  1014,  1317,  1003,  1321,     0,  1321,     2,
  1328,  1328,  1010,  1028,  1311,  1011,  1351,  1337,  1335,  1010,
  1028,  1311,  1011,  1351,  1337,     4,  1344,  1344,  1010,  1028,
  1300,  1011,  1344,  1351,  1349,  1026,  1300,   999,  1351,  1000,
  1358,  1356,  1026,  1311,   999,  1358,  1000,  1366,  1364,     0,
  1337,  1366,     2,  1366,  1000,  1373,  1371,     6,  1337,   999,
  1373,  1000,  1378,  1376,     8,  1378,    11,  1402,  1385,    18,
  1010,  1530,  1552,  1011,  1391,    24,  1010,  1530,  1552,  1011,
  1402,    30,  1010,  1001,    34,  1337,     6,  1337,     6,  1337,
  1011,  1408,  1406,    36,  1013,  1408,  1000,  1415,  1413,     6,
  1001,   999,  1415,  1000,  1420,  1418,    42,  1420,  1000,  1428,
  1423,    42,  1425,    50,  1428,    55,    50,  1453,  1431,    42,
  1433,    50,  1436,    55,  1420,  1439,    60,  1415,  1442,    65,
  1689,  1445,    72,  1415,  1448,    77,  1415,  1453,    83,     0,
  1845,     2,  1460,  1456,    90,  1460,  1031,  1428,  1460,  1467,
  1463,    98,  1465,   101,  1467,   105,  1483,  1473,  1428,  1488,
  1001,  1408,  1479,  1453,  1483,  1001,  1408,  1495,  1483,   114,
  1001,  1408,  1488,  1486,   114,  1488,  1000,  1495,  1491,   119,
  1493,   114,  1495,  1000,  1505,  1503,     0,  1010,  1467,  1011,
  1505,     2,  1505,  1000,  1514,  1512,  1030,  1010,  1467,  1011,
   999,  1514,  1000,  1525,  1518,   129,  1016,  1520,   139,  1523,
   146,  1018,  1525,  1016,  1530,  1528,   153,  1530,  1000,  1546,
  1536,  1337,  1032,  1337,  1546,  1541,     0,  1530,  1552,     2,
  1544,   160,  1530,  1546,  1337,  1552,  1550,  1037,  1337,  1552,
  1000,  1563,  1557,   164,  1530,  1563,  1561,   168,  1530,  1570,
  1563,  1000,  1570,  1568,   164,  1530,   999,  1570,  1000,  1577,
  1575,   168,  1530,   999,  1577,  1000,  1585,  1581,  1033,  1337,
  1583,   171,  1585,  1000,  1592,  1589,   173,  1010,  1592,  1015,
  1010,  1596,  1595,   173,  1596,  1605,  1603,     6,  1337,   171,
  1337,  1596,  1605,  1000,  1614,  1610,  1488,  1001,  1408,  1614,
   178,  1525,  1614,  1620,  1620,  1001,  1408,  1791,  1620,  1626,
  1624,     6,  1614,  1626,  1000,  1645,  1637,  1488,  1592,  1010,
  1001,  1402,  1799,  1011,  1645,  1006,  1645,   178,  1525,  1592,
  1001,  1402,  1791,  1667,  1656,  1654,     6,  1010,  1001,  1402,
  1799,  1011,  1645,  1656,  1000,  1667,  1659,   184,  1661,   188,
  1663,   197,  1665,   207,  1667,   216,  1678,  1676,    34,  1012,
  1028,  1300,  1344,  1689,  1678,  1678,  1000,  1689,  1687,     6,
  1012,  1028,  1300,  1344,  1689,   999,  1689,  1000,  1696,  1694,
     0,  1328,     2,  1696,  1000,  1703,  1701,     6,  1321,   999,
  1703,  1000,  1708,  1706,   222,  1708,  1000,  1714,  1712,     6,
  1337,  1714,  1000,  1727,  1725,     6,  1001,  1408,     0,  1337,
   171,  1337,     2,   999,  1727,  1000,  1734,  1732,    24,  1530,
  1552,  1734,  1000,  1747,  1737,  1019,  1739,  1006,  1744,  1373,
  1530,  1552,  1006,  1747,  1378,  1006,  1760,  1751,   228,  1034,
  1754,   234,  1034,  1760,   244,  1010,  1939,  1011,  1766,  1766,
  1764,   164,  1939,  1766,  1000,  1783,  1770,   249,  1034,  1778,
   259,  1373,  1010,  1530,  1552,  1011,  1747,  1781,   259,  1939,
  1783,  1000,  1791,  1789,   264,  1001,  1358,  1783,  1791,  1000,
  1799,  1799,     0,  1337,   171,  1337,  1596,     2,  1807,  1805,
    34,  1028,  1300,  1344,  1807,  1000,  1816,  1810,   266,  1812,
   188,  1814,   273,  1816,  1000,  1827,  1825,  1001,    34,  1337,
     6,  1337,     6,  1337,  1827,  1000,  1834,  1832,     6,  1852,
   999,  1834,  1000,  1845,  1838,   173,  1001,  1845,  1001,     0,
  1852,  1827,  1870,     2,  1852,  1848,  1001,  1852,  1852,  1827,
  1870,  1862,  1856,  1428,  1862,  1862,     0,  1852,  1827,  1870,
     2,  1870,  1867,  1488,  1001,  1408,  1870,   178,  1614,  1878,
  1876,   168,  1852,  1827,   999,  1878,  1000,  1901,  1885,     4,
  1910,  1001,  1901,  1006,  1889,   281,  1002,  1006,  1893,  1022,
  1917,  1006,  1899,   286,  1009,     6,  1009,  1006,  1901,  1043,
  1910,  1905,   292,  1005,  1908,   294,  1005,  1910,  1000,  1917,
  1913,   296,  1915,    34,  1917,  1000,  1939,  1920,  1023,  1923,
  1024,  1321,  1926,  1025,  1321,  1929,  1039,  1321,  1934,  1040,
  1321,     6,  1321,  1939,  1041,  1321,     6,  1321,  1972,  1948,
  1010,  1001,  1358,  1783,  1011,  1577,  1760,  1952,   298,  1001,
  1358,  1954,   301,  1958,   308,  1033,  1337,  1961,   315,  1760,
  1963,   323,  1968,   328,  1703,  1321,  1708,  1970,   335,  1972,
   340,  2097,  1979,  1027,  1010,  1939,  1011,  1734,  1981,  1007,
  1989,  1373,  1010,  1530,  1552,  1011,  1747,  1006,  1994,   349,
  1035,  1766,  1006,  1999,   356,  1029,  1816,  1006,  2004,   362,
  1036,  1727,  1006,  2009,  1378,   356,  1029,  1006,  2016,  1031,
  1010,  1428,  1011,  1605,  1006,  2020,   369,  1514,  1006,  2025,
    83,   153,  1834,  1006,  2035,  1010,  1807,  1453,  1011,  1585,
  1001,  1402,  1495,  1006,  2039,  1656,  1428,  1626,  2043,   373,
  1003,  1038,  2048,   381,  1015,  1010,  1006,  2057,   387,  1021,
  1703,  1321,  1696,   228,  1034,  1006,  2068,   390,  1001,  1408,
     0,  1337,   171,  1337,     2,  1714,  1006,  2072,   397,  1006,
  1017,  2078,   259,  1035,  1004,  1034,  1006,  2081,     4,  1878,
  2084,   402,  1006,  2088,   417,  1001,  1006,  2092,   424,  1003,
  1006,  2095,  1001,   432,  2097,  1006;
%CONSTINTEGER SS= 1972
%conststring(11)%array qcodes(0:233)="HALT"{=0},
                              "IADD"{=1},"ISUB"{=2},"IMULT"{=3},"IDIV"{=4},
                              "INEG"{=5},"IABS"{=6},"IREM"{=7},"IAND"{=8},
                              "IOR"{=9},"INOT"{=10},"IXOR"{=11},"ISHLL"{=12},
                              "ISHRL"{=13},"ISHLA"{=14},"ISHRA"{=15},"IGT"{=16},
                              "ILT"{=17},"IEQ"{=18},"INE"{=19},"IGE"{=20},
                              "ILE"{=21},"BNOT"{=22},"ITWB"{=36},"SFA"{=41},
                              "RETURN"{=42},"ASF"{=43},"IPUSH"{=44},"IPOP"{=45},
                              "EXCH"{=46},"DUPL"{=47},"DISCARD"{=48},"INDEX1"{=51},
                              "INDEX2"{=52},"INDEX4"{=53},"INDEX8"{=54},"INDEX"{=55},
                              "MVB"{=56},"CHK"{=57},"TMASK"{=58},"MVW"{=59},
                              "EZERO"{=60},"CPBGT"{=62},"CPBLT"{=63},"CPBEQ"{=64},
                              "CPBNE"{=65},"CPBGE"{=66},"CPBLE"{=67},"EMAKED"{68},
                              "ESPLITD"{69},"UMULT"{77},"UREM"{78},"UDIV"{79},
                              "UADD"{=80},"USUB"{=81},"UGT"{=82},"ULT"{=83},
                              "UEQ"{=84},"UNE"{=85},"UGE"{=86},"ULE"{=87},
                              "UCVTII"{=100},"IADDST"{=101},"ISUBST"{=102},"IMULTST"{=103},
                              "IDIVST"{=104},"INEGST"{=105},"UREMST"{106},"UDIVST"{107},
                              "IANDST"{=108},"IORST"{=109},"INOTST"{=110},"IXORST"{=111},
                              "IREMST"{=112},"RADD"{=113},"RSUB"{=114},"RMULT"{=115},
                              "RDIV"{=116},"RNEG"{=117},"RABS"{=118},"TNCRU"{130},
                              "CVTSBI"{=131},"CVTUI"{=132},"CVTUR"{=133},"CVTIU"{=134},
                              "CVTRU"{=135},"CVTII"{=136},"CVTIR"{=137},"CVTRR"{=138},
                              "TNCRI"{=139},"RNDRI"{=140},"EFLOOR"{=141},"TNCRR"{=142},
                              "RNDRR"{=143},"RGT"{=144},"RLT"{=145},"REQ"{=146},
                              "RNE"{=147},"RGE"{=148},"RLE"{=149},"RTWB"{=162},
                              "UCHECK"{=177},"ESTORE"{=184},"EDUPSTORE"{=185},"PUSHVAL"{=186},
                              "PUSHADDR"{=187},"EVAL"{=188},"EVALADDR"{=189},"EADDRESS"{=190},
                              "EINTRES"{=191},"EREALRES"{=192},"ESIZE"{=193},"EPOWER"{=194},
                              "EPOWERI"{=195},"ARGPROC"{=196},"PUSHBYTES"{=197},"EAUXST"{=198},
                              "EAUXADD"{=199},"EAUXRES"{=200},"EOLDLNB"{=201},"EFILL"{=202},
                              "ECDUP"{=203},"EMCHIP"{=205},"CXADD"{=257},"CXSUB"{=258},
                              "CXMULT"{=259},"CXDIV"{=260},"CXNEG"{=261},"CXASGN"{=262},
                              "CXEQ"{=263},"CXNE"{=264},"ECMPLX1"{=286},"ECMPLX2"{=287},
                              "ECONJG"{=279},"EANINT"{=266},"EM1EXP"{=267},"EISIGN"{=268},
                              "ESIGN"{=269},"EIMOD"{=270},"ERMOD"{=271},"EIDIM"{=272},
                              "ERDIM"{=273},"EIMIN"{=274},"ERMIN"{=275},"EIMAX"{=276},
                              "ERMAX"{=277},"EDMULT"{=278},"ECHAR"{=280},"EICHAR"{=281},
                              "EINDEXCHAR"{=282},"ECONCAT"{=283},"EASGNCHAR"{=284},"ECOMPCHAR"{=285},
                              "EISHFT"{=288},"EIBITS"{=289},"EIBSET"{=290},"EIBTEST"{=291},
                              "EIBCLR"{=292},"EISHFTC"{=293},"PROCARG"{=294},"IPROCARG"{=295},
                              "CHARARG"{=296},"IPROCCALL"{=297},"ARGPROCCALL"{=298},"CALLTPLATE"{=299},
                              "NOTEIORES"{=300},"STKIORES"{=301},"EFCVT"{=302},"EFCVTASGN"{=303},
                              "EARGLEN"{=304},"EFDVACC"{=305},"EFNOTEVR"{=306},"EFSETVR"{=307},
                              "EINCR"{=308},"EDECR"{=309},"ELOADB"{=310},"ESTOREB"{=311},
                              "EINCRB"{=312},"EDECRB"{=313},"EDINIT"{=314},"ELSHIFT"{=315},
                              "ERSHIFT"{=316},"EADJL"{=317},"EADJR"{=318},"EVERIFY"{=319},
                              "STRGT"{=511},"STRLT"{=512},"STREQ"{=513},"STRNE"{=514},
                              "STRGE"{=515},"STRLE"{=516},"PTREQ"{=520},"PTRNE"{=521},
                              "SETI"{=530},"SETU"{=531},"SETD"{=532},"SETLE"{=533},
                              "SETEQ"{=534},"SETNE"{=535},"SETIN"{=536},"SETSING"{=537},
                              "SETRANGE"{=538},"SETEMPTY"{=539},"CAPMOVE"{=547},"INDEXP"{=548},
                              "EOFOP"{=559},"EOLOP"{=560},"LAZYOP"{=574},"ISQR"{=601},
                              "IODD"{=602},"ISUCC"{=603},"IPRED"{=604},"UODD"{=605},
                              "USUCC"{=606},"UPRED"{=607},"RSQR"{=611},"CHKLT"{=620},
                              "CHKGT"{=621},"CHKNE"{=629},"CHKRNG"{=622},"CHKSETGT"{=623},
                              "CHKSETRNG"{=624},"UCHKLT"{=625},"UCHKGT"{=626},"UCHKNE"{=627},
                              "UCHKRNG"{=628},"CHKNEW2"{=630},"CHKUNDEF"{=631},"SETUNDEF"{=632},
                              "TRAP"{=633},"ICLPSH"{=642},"ICLPROT"{=643},""{=0},
                              "ESTKLIT"{=255};
%constshortinteger%array opc(0:233)=0,
                              1,2,3,4,
                              5,6,7,8,
                              9,10,11,12,
                              13,14,15,16,
                              17,18,19,20,
                              21,22,36,41,
                              42,43,44,45,
                              46,47,48,51,
                              52,53,54,55,
                              56,57,58,59,
                              60,62,63,64,
                              65,66,67,68,
                              69,77,78,79,
                              80,81,82,83,
                              84,85,86,87,
                              100,101,102,103,
                              104,105,106,107,
                              108,109,110,111,
                              112,113,114,115,
                              116,117,118,130,
                              131,132,133,134,
                              135,136,137,138,
                              139,140,141,142,
                              143,144,145,146,
                              147,148,149,162,
                              177,184,185,186,
                              187,188,189,190,
                              191,192,193,194,
                              195,196,197,198,
                              199,200,201,202,
                              203,205,257,258,
                              259,260,261,262,
                              263,264,286,287,
                              279,266,267,268,
                              269,270,271,272,
                              273,274,275,276,
                              277,278,280,281,
                              282,283,284,285,
                              288,289,290,291,
                              292,293,294,295,
                              296,297,298,299,
                              300,301,302,303,
                              304,305,306,307,
                              308,309,310,311,
                              312,313,314,315,
                              316,317,318,319,
                              511,512,513,514,
                              515,516,520,521,
                              530,531,532,533,
                              534,535,536,537,
                              538,539,547,548,
                              559,560,574,601,
                              602,603,604,605,
                              606,607,611,620,
                              621,629,622,623,
                              624,625,626,627,
                              628,630,631,632,
                              633,642,643,0,
                              255;
!
%CONSTINTEGER FIRST UCUB=224
%CONSTINTEGER FIRST UCSB=first ucub+0
%CONSTINTEGER FIRST UCW=first ucsb+1
%CONSTINTEGER FIRST UCUBUB=first ucw+1
%CONSTINTEGER FIRST UCUBW=0
%CONSTINTEGER FIRST UCJUMP=0
%CONSTINTEGER LASTUC=0
%CONSTINTEGER LRLPT=X'62'
%CONSTINTEGER NO OF SNS=67
                                        ! THE SPECIAL NAMES ARE HERE  TO ALLOW
                                        ! DIFFERENCES OF PRECISION BETWEEN COMPILERS
                                        ! ESPECIAL THE MAPS HALF&SHORT
%CONSTINTEGERARRAY TSNAME (0:NO OF SNS)=X'1000'(8),
               X'1041',X'1000'(5),X'1051',X'1000'+LRLPT,
               X'1051'(2),X'1000'+LRLPT,
               X'1000'(2),X'52',X'51',LRLPT,X'1000'+LRLPT(7),
               X'1000',X'31',X'51',X'1000'+LRLPT(2),X'31',X'1000',
                X'4051',LRLPT,X'1000'(2),X'35',X'1000',X'1035',
                X'31',X'35',X'1035',X'33',0,X'1051',X'51',X'4062',X'51',
                X'61',X'72',X'61',X'72',X'51',LRLPT,X'1051',X'51',
               X'1000',LRLPT,X'1061'(2),X'41',X'1051';
! %END OF FILE M88Kponeas ie M88K TARGET DEPENDENT TABLES
!
! Changes for poneb02s
!   1) Improvements to UP and DOWN to flag internal blks or procs
!
!
%CONST %BYTE %INTEGER %ARRAY I TO E TAB(0 : 127) =       %C
X'40',X'40',X'40',X'40',X'40',X'40',X'40',X'40',
X'40',X'40',X'15',X'40',X'0C',X'40',X'40',X'40',
X'40',X'40',X'40',X'40',X'40',X'40',X'40',X'40',
X'40',X'40',X'40',X'40',X'40',X'40',X'40',X'40',
X'40',X'4F',X'7F',X'7B',X'5B',X'6C',X'50',X'7D',
X'4D',X'5D',X'5C',X'4E',X'6B',X'60',X'4B',X'61',
X'F0',X'F1',X'F2',X'F3',X'F4',X'F5',X'F6',X'F7',
X'F8',X'F9',X'7A',X'5E',X'4C',X'7E',X'6E',X'6F',
X'7C',X'C1',X'C2',X'C3',X'C4',X'C5',X'C6',X'C7',
X'C8',X'C9',X'D1',X'D2',X'D3',X'D4',X'D5',X'D6',
X'D7',X'D8',X'D9',X'E2',X'E3',X'E4',X'E5',X'E6',
X'E7',X'E8',X'E9',X'4A',X'5F',X'5A',X'6A',X'6D',
X'7C',X'81',X'82',X'83',X'84',X'85',X'86',X'87',
X'88',X'89',X'91',X'92',X'93',X'94',X'95',X'96',
X'97',X'98',X'99',X'A2',X'A3',X'A4',X'A5',X'A6',
X'A7',X'A8',X'A9',X'C0',X'40',X'D0',X'40',X'40'
%CONSTBYTEINTEGERARRAY ONE CASE(0 : 255) =   %C
       0, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15,
      16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,
      32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,
      48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,
      64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,
      80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,
      96,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,
      80,81,82,83,84,85,86,87,88,89,90,123,124,125,126,127,
       0, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15,
      16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,
      32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,
      48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,
      64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,
      80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,
      96,65+128,66+128,67+128,68+128,69+128,70+128,71+128,72+128,73+128,74+128,75+128,76+128,77+128,78+128,79+128,
      80+128,81+128,82+128,83+128,84+128,85+128,86+128,87+128,88+128,89+128,90+128,123,124,125,126,127;
%CONSTINTEGER MAXLEVELS=31,COMMALT=2,DECALT=8,ENDALT=9,SNPT=X'1006'
%CONSTINTEGER MAXIBITS=32;              ! BITS IN LARGEST INTEGER
%CONSTBYTEINTEGERARRAY TRTAB(0:255)=0(48),1(10),
                                        0(7),2(26),0(6),2(26),0(*);
!
! RECORDFORMAT FOR ALL THE OPTION AND FLAG VARAIBLES
!
! amended to remove non-alined longreal prior to bootstrapping to gould
!
%RECORDFORMAT PARMF(%INTEGER BITS1,BITS2,TTOPUT,
      %BYTEINTEGER LET,DYNAMIC,LINE,TRACE,ARR,DBUG,CHK,DIAG,OPT,FREE,
      LIST,CPRMODE,COMPILER,Z,Y,PROF,INHCODE,DCOMP,FAULTY,X,STACK,MAP,QUOTES,S2,
      %INTEGER LPOPUT,SP0)
%RECORDFORMAT LEVELF(%INTEGER RBASE, DIAGINF, RAL, FLAG, L, M, NMDECS, ONWORD, ONINF,
         LABEL, JROUND, UNATT FORMATS, PSIZE, ENTRYAD, DISPLAY, AUXSBASE,
         NAMES, SNMAX,SN,RESSIZE,CLEVEL,SET, MAXPP, EXITLAB, CONTLAB, S3,
       %INTEGERARRAY AVL WSP(0:4))

%IF 1<<host&unsignedshorts=0 %START
%RECORDFORMAT RD((%INTEGER S1 %OR %SHORT PTYPE,%BYTE XB,FLAG),
      ((%INTEGER D %OR %REAL R),
      %INTEGER XTRA %OR %SHORT H0,H1,H2,H3 %OR %BYTE B0,B1,B2,B3,B4,B5,B6,B7))
%RECORDFORMAT TAGF((%SHORTINTEGER PTYPE,UIOJ,SNDISP,ACC,SLINK,KFORM %OR %C
      %INTEGER S1,S2,S3),%INTEGER LINK)
%RECORDFORMAT TRIPF(%BYTE OPERN,OPTYPE,CNT,DPTH,
      %SHORTINTEGER FLAGS,PUSE,FLINK,BLINK,%INTEGER X1,
      %RECORD(RD) OPND1,OPND2)
%RECORDFORMAT LISTF((%SHORTINTEGER PTYPE,(%SHORT UIOJ %OR %BYTE XB,FLAG),
      %SHORT SNDISP,ACC,SLINK,KFORM %OR  %INTEGER S1,S2,S3),%INTEGER LINK)
%FINISH %ELSE %START
%RECORDFORMAT RD((%INTEGER S1 %OR %HALF PTYPE,%BYTE XB,FLAG),
      ((%INTEGER D %OR %REAL R),
      %INTEGER XTRA %OR %HALF H0,H1,H2,H3 %OR %BYTE B0,B1,B2,B3,B4,B5,B6,B7))
%RECORDFORMAT TAGF((%HALFINTEGER PTYPE,UIOJ,SNDISP,ACC,SLINK,KFORM %OR %C
      %INTEGER S1,S2,S3),%INTEGER LINK)
%RECORDFORMAT TRIPF(%BYTE OPERN,OPTYPE,CNT,DPTH,
      %HALFINTEGER FLAGS,PUSE,FLINK,BLINK,%INTEGER X1,
      %RECORD(RD) OPND1,OPND2)
%RECORDFORMAT LISTF((%HALFINTEGER PTYPE,(%HALF UIOJ %OR %BYTE XB,FLAG),
      %HALF SNDISP,ACC,SLINK,KFORM %OR  %INTEGER S1,S2,S3),%INTEGER LINK)
%FINISH
%RECORDFORMAT WORKAF(%INTEGER NNAMES,CCSIZE,DSIZE,ASL MAX,ASL CUR BTM,CONST PTR,
      CONST BTM,LASTTRIP,WKFILEAD,WKFILEK,FILE ADDR,RELEASE,AASL0,CONST LIMIT,
      RTCOUNT,ARTOP,AMAINEP,DICTBASE,OPTCNT,INCLHEAD,S2,S3,S4,
      %INTEGERNAME LINE,N,S5,%STRING(9)LADATE,
      %BYTEINTEGERARRAYNAME CC,A,LETT,
      %INTEGERARRAYNAME WORD,TAGS,CTABLE,
      %RECORD(LEVELF)%ARRAYNAME LEVELINF,
      %INTEGERARRAY PLABS,PLINK(0:31),
      %RECORD(LISTF)%ARRAYNAME ASLIST)
!
! TRIPF_FLAGS SIGNIFY AS FOLLOWS
%CONSTINTEGER LEAVE STACKED=2****0;     ! SET LEAVE RESULT IN ESTACK
%CONSTINTEGER LOADOP1=2****1;           ! OPERAND 1 NEEDS LOADING
%CONSTINTEGER LOADOP2=2****2;           ! OPERAND 2 NEEDS LOADING
%CONSTINTEGER NOTINREG=2****3;          ! PREVENT REG OPTIMISNG
                                        ! OF TEMPS OVER LOOPS&JUMPS
%CONSTINTEGER USE ESTACK=2****4;        ! KEEP DUPLICATE IN ESTACK
%CONSTINTEGER USE MSTACK=2****5;        ! PUT DUPLICAT ON MSTACK
%CONSTINTEGER CONSTANTOP=2****6;        ! ONE OPERAND IS CONSTANT(FOR FOLDING)
%CONSTINTEGER COMMUTABLE=2****7;        ! OPERATION IS COMMUTABLE
%CONSTINTEGER BSTRUCT=2****12;          ! Proc contains inner blks or RTs
%CONSTINTEGER USED LATE=2****13;        ! I-RESULT USED AFTER LAB OR A LONG WAY AHEAD
%CONSTINTEGER ASS LEVEL=2****14;        ! ASSEMBLER LEVEL OPERATION
%CONSTINTEGER DONT OPT=2****15;         ! DONT DUPLICATE THIS RESULT
                                        ! USED FOR BYTE PTR & OTHER SODS!
!
%RECORDFORMAT EMASFHDRF(%INTEGER ENDRA,STARTRA,FBYTESIZE,W3,W4,W5,W6,W7)
                                        ! FORMAT FOR ARRAY HEADS
! %END %OF  %FILE "ERCC07.TRIMP_TFORM1S"
%EXTRINSICRECORD(PARMF)PARM
%EXTRINSICRECORD(WORKAF)WORKA
%EXTERNALROUTINESPEC POP(%INTEGERNAME A,B,C,D)
%EXTERNALROUTINESPEC PUSH(%INTEGERNAME A,%INTEGER B,C,D)
%externalroutinespec insert at end(%integername a,%integer b,c,d)
%EXTERNALROUTINESPEC FAULT(%INTEGER A,B,C)
!*
%externalintegerfnspec malloc(%integer bytes)
%externalintegerfnspec fileread %alias "read" (%integer fid, bad, blen)
%externalroutinespec free(%integer bytes)
!*
%if Target=MIPS %start
   %conststring(3) assprefix=" #"
%finish %else %if Target=M88k %start
   %conststring(3) assprefix=" ;"
%finish %else %start
   %conststring(3) assprefix=""
%finish
%EXTERNALINTEGERFN PASSONE
%ROUTINESPEC NEW SOURCE(%INTEGER NEW FIL AD)
%integerfnspec OLD SOURCE
%ROUTINESPEC READ LINE(%INTEGER MODE,CHAR)
%INTEGERFNSPEC COMPARE(%INTEGER P)
%ROUTINESPEC PNAME(%INTEGER MODE)
%ROUTINESPEC EVALCONST(%INTEGER MODE)
%ROUTINESPEC TEXTTEXT(%INTEGER EBCDIC)
%EXTERNALROUTINESPEC MOVE BYTES(%INTEGER LENGTH,FBASE,FOFF,TOBASE,TOOFF)
%if 1<<host&IBMFPFORMAT#0 %start
      %CONSTINTEGERARRAY PRECONSTS(0:3)=10,0,{NL}X'413243F6',X'A8885A31'{PI};
%finish %else %if host=Vax %Start
      %constintegerarray preconsts(0:3)=10,0,X'21fb4029',x'2d185444'
%finish %else %if 1<<host&wordswopped#0 %start
      %constintegerarray preconsts(0:3)=10,0,x'54442d18',x'400921fb';
%finish %else %start;          ! IEEE unswopped
       %constintegerarray preconsts(0:3)=10,0,x'400921fb',x'54442d18'
%finish
%INTEGER I,J,K,LLENGTH,LEVEL,QMAX,Q,R,S,SNUM,NNAMES,DSIZE,NEXT,JJ,CPTR,
      STARSTART,ARSIZE,HIT,CTYPE,LASTAT,LASTNAME,LASTEND,STRLINK,IHEAD,
      IDEPTH,FILEADDR,FILEPTR,FILEEND
%OWNBYTEINTEGERARRAYFORMAT SRCEF(0:1024*1024)

%RECORD(EMASFHDRF)%NAME HDR
%LONGREAL IMAX
%integer curlinead
%STRING(15)NEM
%INTEGERNAME LINE
%BYTEINTEGERARRAYNAME CC,SOURCE,A
%INTEGERARRAYNAME WORD,TAGS
      LINE==WORKA_LINE
      CC==WORKA_CC
      A==WORKA_A
      TAGS==WORKA_TAGS
      WORD==WORKA_WORD
      NNAMES=WORKA_NNAMES
      DSIZE=8*NNAMES
      ARSIZE=1024*WORKA_WKFILEK-(WORKA_CCSIZE+256);!256 BYTE MARGIN LEFT AT MAP TIME
      IMAX=(-1)>>1
%INTEGERARRAY Downptr,SFS(0:MAXLEVELS)

%BYTEINTEGERARRAYFORMAT LETTF(0:DSIZE+20)
%BYTEINTEGERARRAYNAME LETT
%BYTEINTEGERARRAY  TLINE(0:2047)
%CONSTBYTEINTEGERARRAY ILETT(0: 532)= 11,
    'S','E','L','E','C','T','I','N','P','U','T', 12,'S','E','L','E',
    'C','T','O','U','T','P','U','T',  7,'N','E','W','L','I','N','E',
      5,'S','P','A','C','E', 10,'S','K','I','P','S','Y','M','B','O',
    'L', 10,'R','E','A','D','S','T','R','I','N','G',  8,'N','E','W',
    'L','I','N','E','S',  6,'S','P','A','C','E','S', 10,'N','E','X',
    'T','S','Y','M','B','O','L', 11,'P','R','I','N','T','S','Y','M',
    'B','O','L', 10,'R','E','A','D','S','Y','M','B','O','L',  4,'R',
    'E','A','D',  5,'W','R','I','T','E',  7,'N','E','W','P','A','G',
    'E',  4,'A','D','D','R',  6,'A','R','C','S','I','N',  3,'I','N',
    'T',  5,'I','N','T','P','T',  6,'F','R','A','C','P','T',  5,'P',
    'R','I','N','T',  7,'P','R','I','N','T','F','L',  4,'R','E','A',
    'L',  7,'I','N','T','E','G','E','R',  3,'M','O','D',  6,'A','R',
    'C','C','O','S',  4,'S','Q','R','T',  3,'L','O','G',  3,'S','I',
    'N',  3,'C','O','S',  3,'T','A','N',  3,'E','X','P', 11,'C','L',
    'O','S','E','S','T','R','E','A','M', 11,'B','Y','T','E','I','N',
    'T','E','G','E','R',  8,'E','V','E','N','T','I','N','F',
    6,'R','A','D','I','U','S',  6,'A','R','C','T','A','N',
      6,'L','E','N','G','T','H', 11,'P','R','I','N','T','S','T','R',
    'I','N','G',  2,'N','L',  8,'L','O','N','G','R','E','A','L',  7,
    'P','R','I','N','T','C','H',  6,'R','E','A','D','C','H',  6,'S',
    'T','R','I','N','G',  8,'R','E','A','D','I','T','E','M',  8,'N',
    'E','X','T','I','T','E','M',  6,'C','H','A','R','N','O',  8,'T',
    'O','S','T','R','I','N','G',  9,'S','U','B','S','T','R','I',
    'N','G',  6,'R','E','C','O','R','D',  5,'A','R','R','A','Y',  6,
    'S','I','Z','E','O','F',4,'I','M','O','D',2,'P',
    'I',9,'E','V','E','N','T','L','I','N','E',11,'L','O','N','G',
    'I','N','T','E','G','E','R',12,'L','O','N','G','L','O','N','G',
    'R','E','A','L',9,'L','E','N','G','T','H','E','N','I',
     9,'L','E','N','G','T','H','E','N','R',
     8,'S','H','O','R','T','E','N','I',
     8,'S','H','O','R','T','E','N','R',
      6,'N','E','X','T','C','H',
      11,'H','A','L','F','I','N','T','E','G','E','R',
      8,'P','P','R','O','F','I','L','E',
      5,'F','L','O','A','T',
      4,'L','I','N','T',
      6,'L','I','N','T','P','T',
      12,'S','H','O','R','T','I','N','T','E','G','E','R',
      5,'T','R','U','N','C',255;
!*
%byteintegerarrayformat inbuffm(0:4095)
%ownbyteintegerarrayname inbuf
%owninteger inptr=4095
%owninteger dataad
!*
         LETT==ARRAY(ADDR(A(ARSIZE-DSIZE-20)),LETTF)
         ARSIZE=ARSIZE-DSIZE-300
!*
         dataad = malloc(4096)
         inbuf == array(dataad, inbuffm)
!*
         LETT(0)=0
         LEVEL=0

         WORKA_LETT==LETT
         %CYCLE I=0,1,MAXLEVELS
            SFS(I)=0
         %REPEAT
         %CYCLE I=0,1,NNAMES
             WORD(I)=0; TAGS(I)=0;
         %REPEAT
         FILEADDR=WORKA_FILEADDR
         IDEPTH=0; IHEAD=0
         %IF FILEADDR#0 %THEN %START
            HDR==RECORD(FILEADDR)
            SOURCE==ARRAY(FILEADDR,SRCEF)
            FILEPTR=HDR_STARTRA
            FILEEND=HDR_ENDRA
         %FINISH
         PARM_OPT=1; PARM_ARR=1
         PARM_LINE=1; PARM_TRACE=1;  PARM_DIAG=1
         PARM_CHK=1
         I=PARM_BITS1
         %IF I&4=4 %THEN PARM_DIAG=0
         %IF I&X'800000'#0 %THEN PARM_LINE=0
         %IF I&16=16 %THEN PARM_CHK=0
         PARM_MAP={I>>17&}1;              ! MAP CONTROLS FUNNY LISTING OF INCLUDES
         PARM_LIST=(I>>1&1)!!1
!         PARM_FREE=I>>19&1
         %IF I&32=32  %THEN PARM_ARR=0
         PARM_PROF=I>>7&1;              ! PROFILE BIT
         parm_prof=0 %if parm_map#0; ! Cant profile funny listint
         PARM_DYNAMIC=I>>20&1
         PARM_LET=I>>13&1
         PARM_DCOMP=I>>14&1;            ! PARM CODE OR D
         PARM_DBUG=I>>18&1
         PARM_QUOTES=I&1
         %IF I&64=64 %THEN PARM_TRACE=0 %AND PARM_DIAG=0
         PARM_X=I>>28&1;                ! DONT REFORMAT REALS FOR SIMULATOR
         PARM_Y=I>>27&1
         PARM_Z=I>>26&1;             ! USE PARMZ BIT FOR DUMPING WKFILE
         PARM_STACK=I>>3&1
         %IF I&(1<<16)#0 %THEN %START
            PARM_ARR=0; PARM_OPT=0
            PARM_LINE=0; PARM_CHK=0; PARM_DIAG=0
         %FINISH
         PARM_TRACE=PARM_TRACE!PARM_OPT;   ! ALLOW NOTRACE ONLY WITH OPT
         NEWLINES(3)
!        %if target=MIPS %or Target=M88K %then printstring(assprefix)
         SPACES(4)
         PRINTSTRING("/* EPC Imp to C Translation ")
         PRINTSTRING("Release")
         WRITE(WORKA_RELEASE,1)
         PRINTSTRING(" Version ".WORKA_LADATE." */")
         NEWLINES(3)
         printstring("#include ""imptoc.h""
")
!        %if target=MIPS %or Target=M88k %then printstring(assprefix)
!         WRITE(NNAMES,5); WRITE(WORKA_ASL MAX,5)
!         NEWLINE
!
! NOW DECLARE THE SPECIAL NAMES WHICH ARE IN ARRAY ILETT.
!
%BEGIN
%RECORD(TAGF) SNTAG
      CPTR=0; SNUM=0; STRLINK=0
      K=0
      %IF HOST//10<=1 %THEN NEXT=1 %ELSE NEXT=2; !START AT 2 FOR WORD ADDRESSES HOSTS
      I=ILETT(0)
      %WHILE I<255 %CYCLE
         %CYCLE J=I,-1,1
            CC(J)=ILETT(K+J)!32
         %REPEAT
         CC(I+1)=';'
         R=2; Q=1; PNAME(1)
         SNTAG=0; SNTAG_UIOJ<-X'8000';   ! SET USED BIT
         JJ=TSNAME(SNUM)
         %IF JJ&X'C000'#X'4000' %START; ! NOT A CONST VARAIBLE
            SNTAG_PTYPE=SNPT
            SNTAG_ACC=JJ;               ! TRUE PTYPE HERE
            SNTAG_SLINK=SNUM
         %FINISHELSESTART
            SNTAG_PTYPE=JJ
            SNTAG_S2=PRECONSTS(CPTR)
            SNTAG_S3=PRECONSTS(CPTR+1)
            CPTR=CPTR+2
         %FINISH
         PUSH(TAGS(LASTNAME),SNTAG_S1,SNTAG_S2,SNTAG_S3)
         SNUM=SNUM+1
         K=K+I+1; I=ILETT(K)
         %exit %if snum>no of sns
      %REPEAT
!
! The idea of the above exit is to allow further special names to be added
! without preventing the rebuilds of compilers that do not support the extra facilities
! Until no of sns is increased in the steering consts the new names are ignored
!
%END
!
         LINE=0; LLENGTH=0; Q=1
         R=1;  LEVEL=1
         %CYCLE
         curlinead=file addr+fileptr
            %IF Q>=LLENGTH %THEN QMAX=1 %AND READ LINE(0,0)
            %if llength=-1 %then %exit        { no more input}
            STARSTART=R
            R=R+3
            A(R)=LINE>>8
            A(R+1)=LINE&255
            R=R+2
            movebytes(4,addr(curlinead),0,addr(a(0)),r)
            r=r+4
            %IF COMPARE(SS)=0 %THEN %START
               FAULT(100,Q,QMAX<<16!LLENGTH)
               R=STARSTART
               Q=Q+1 %WHILE CC(Q)#';' %AND Q<LLENGTH
               Q=Q+1
            %FINISH %ELSE %START
               FAULT(102, WORKA_WKFILEK, 0) %IF R>ARSIZE
!               %IF A(STARSTART+9)=COMMALT %THEN R=STARSTART %ELSE %START
                  I=R-STARSTART
                  A(STARSTART)=I>>16
                  A(STARSTART+1)=I>>8&255
                  A(STARSTART+2)=I&255
!*DELSTART
                  %IF PARM_Z#0 %THEN %START
                     NEWLINE;  WRITE(LINE, 5)
                     WRITE(STARSTART,5);  NEWLINE; J=0
                     %CYCLE I=STARSTART, 1, R-1
                        WRITE(A(I), 5)
                     J=J+1
                     %IF J>=20 %THEN NEWLINE %AND J=0
                     %REPEAT
                     NEWLINE
                  %FINISH
!*DELEND
                  %IF A(STARSTART+9)=ENDALT %AND %C
                     1<=A(STARSTART+10)<=2 %START;! ENDOF PROG OR FILE
                     %IF IHEAD=0 %THEN %EXIT
                     llength=OLD SOURCE
                     R=STARSTART;       ! IGNORE ENDOFFILE LIKE IMP77
                     LLENGTH=1
                     %CONTINUE
                  %FINISH
                  %IF LEVEL=0 %THEN %START
                     FAULT(14, 0, 0)
                     R=STARSTART;       ! IGNORE IT
                     LEVEL=1
                  %FINISH
!               %FINISH
            %FINISH
         %REPEAT
         %WHILE SFS(1)#0 %CYCLE
            POP(SFS(1),I,J,K)
            %IF I=1 %THEN FAULT(53,K,0);  ! FINISH MISSING
            %IF I=2 %THEN FAULT(13,K,0);  ! %REPEAT MISSING
         %REPEAT
         A(I)=0 %FOR I=R,1,R+7; R=R+8
         R=(R+7)&(-8)
         WORKA_DICTBASE=R
!         %CYCLE I=0,1,NEXT
!            A(R+I)=LETT(I)
!         %REPEAT
         move bytes(next+1,addr(lett(0)),0,addr(a(0)),r)
         WORKA_LETT==ARRAY(ADDR(A(R)),SRCEF)
         R=R+NEXT+1
         %IF LEVEL>1 %THEN FAULT(15,LEVEL-1,0)
         R=(R+7)&(-8)
         NEWLINE
         %IF PARM_FAULTY=0 %THEN %START
            free(dataad)
         %FINISH %ELSE %START
            PRINTSTRING("C GENERATION NOT ATTEMPTED
")
         %FINISH
         %RESULT=R
%ROUTINE NEWSOURCE(%INTEGER NEWFILEADDR)
!***********************************************************************
!*    SETS UP COMPILER TO USE AN INCLUDED SOURCE FILES                 *
!***********************************************************************
%externalinteger filesseen=0
      PUSH(IHEAD,FILEADDR,FILEPTR,LINE)
      FILEADDR=NEWFILEADDR
      HDR==RECORD(FILEADDR)
      SOURCE==ARRAY(FILEADDR,SRCEF)
      FILEPTR=HDR_STARTRA
      FILEEND=HDR_ENDRA
      IDEPTH=IDEPTH+1
      filesseen=filesseen+1
      %IF PARM_MAP#0 %THEN LINE=18000+2000*filesseen
%END
%integerfn OLDSOURCE
!***********************************************************************
!*    UNDOES THE ABOVE
!***********************************************************************
%INTEGER ALT LINE
      %IF IHEAD#0 %THEN %START
         POP(IHEAD,FILEADDR,FILEPTR,ALTLINE)
          %if Fileaddr#0 %start;       ! if it was mapped remap
            HDR==RECORD(FILEADDR)
            FILEEND=HDR_ENDRA
            SOURCE==ARRAY(FILEADDR,SRCEF)
         %finish
         %IF PARM_MAP#0 %THEN LINE=ALT LINE
         IDEPTH=IDEPTH-1
         %result=1
      %FINISH %ELSE %result=0
%END
%ROUTINE READ LINE(%INTEGER MODE,CHAR)
%integerfnSPEC GET LINE
%INTEGER DEL, LL, LP, PREV, LASTC, PPREV, LASTNS, i,j
      LL=0;  LP=0; PREV=0; Q=1
      LLENGTH=0;  DEL=0; LASTC=-1;   ! NO CONTINUATIONS AS YET
NEXT:
      LP=LP+1
      %IF LP>LL %THEN lp=GET LINE
     %if lp=0 %then llength=-1 %and %return
      I=TLINE(LP)
      %IF MODE=0 %THEN %START
         %WHILE I='{' %CYCLE
            %CYCLE
               PREV=I
               LP=LP+1
               I=TLINE(LP)
            %REPEAT %UNTIL PREV='}' %OR I=NL
         %REPEAT
         %while I='/' %and tline(lp+1)='*' %cycle
            %cycle
              pprev=prev; prev=i; lp=lp+1
              i=tline(lp);
            %repeat %until i=nl %or (prev='/' %and pprev='*')
         %repeat
         %IF I='%'   %THEN DEL=128 %AND ->NEXT
!         %if parm_quotes#0 %then i=onecase(i+128) %else I=ONE CASE(I)
         %IF 'A'<=I<='Z' %THEN %start
            I=I!DEL
         %finish %else %if 'a'<=i<='z' %then %start
             %if del#0 %then i=(i-32)!DEL
         %else
            DEL=0
!            ->NEXT %IF I=' '
         %FINISH
         LLENGTH=LLENGTH+1
         CC(LLENGTH)=I
         %IF I='''' %OR I=34 %THEN MODE=1 %AND CHAR=I
      %FINISH %ELSE %START
         LLENGTH=LLENGTH+1
         CC(LLENGTH)=I
         %IF I=CHAR %THEN MODE=0
      %FINISH
      ->NEXT %UNLESS I=NL
      j=LLENGTH
      LASTNS=CC(LLENGTH-1)
      %while  LASTNS=' ' %cycle             { Dont allow trailing spaces to trip us up}
         j=j-1
         LASTNS=CC(j-1)
      %repeat
      %IF LLENGTH-1=LASTC %THEN LLENGTH=LASTC %AND ->NEXT
      %IF LASTNS='C'+128 %THEN %start
         CC(j-1)=' '                 { obnliterate %c with space }
         LLENGTH=LLENGTH-1
         LASTC=LLENGTH
         ->NEXT
      %finish
      %IF MODE=0 %AND LASTNS='\' %THEN cc(LLENGTH)=13 %and LASTC=LLENGTH %AND ->NEXT
      %IF MODE=0 %AND LASTNS=',' %THEN LLENGTH=LLENGTH-1 %AND LASTC=LLENGTH %AND ->NEXT
      FAULT(101,0,0) %IF LLENGTH>WORKA_CCSIZE
      %RETURN
%%integerfn GET LINE
%externalintegerspec SrcId
%CONSTBYTEINTEGERARRAY ITOI(0:255)=%C
                  32(10),10,32(14),25,26,32(5),
                  32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,
                  48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,
                  64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,
                  80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,
                  96,97,98,99,100,101,102,103,104,105,106,107,108,109,
                  110,111,112,113,114,115,116,117,118,119,
                  120,121,122,123,124,125,126,32,
                  26(5),10,26(10),
                  26(16),
                  26(14),92,38,
                  26(11),35,26(4),
                  26(16),
                  26(9),35,26(5),94,
                  26(32);
%INTEGER K
      LL=0
      %IF FILE ADDR=0 %THEN %START;     ! SOURCE NOT A 'CLEAN' FILE
         %UNTIL K=NL %CYCLE
            { Since there is no support for read symbol, use }
            { Unix block read which is faster anyway.        }
            { READ SYMBOL(K)                                 }
            inptr = inptr + 1
            %if inptr = 4096 %thenstart
               k = fileread(SrcId, addr(inbuf(0)), 4096)
               inptr = 0
            %finish
            k = inbuf(inptr)
            TLINE(LL+1)=ITOI(K)
            LL=LL+1
         %REPEAT
         curlinead=0
      %FINISH %ELSE %START
        %IF FILEPTR>=FILE END %START
            %if OLD SOURCE=0 %then %result=0;                 ! RESET SOURCE FILES
            %result=GETLINE
         %FINISH
!         curlinead=file addr+fileptr
         %UNTIL K=NL %OR K=0 %CYCLE
            K=SOURCE(FILEPTR);          ! NEXT CHAR FROM SORCE FILE
            FILE PTR=FILE PTR+1
            TLINE(LL+1)=ITOI(K)
            LL=LL+1
         %REPEAT
      %FINISH
      %while ll>1 %and TLINE(ll-1)=' ' %cycle     { deal with trailing spaces }
         TLINE(LL-1)=TLINE(LL)
         LL=LL-1
      %repeat
      LINE=LINE+1;                      ! COUNT ALL LINES
      %IF PARM_LIST#0 %THEN %START
         %IF MODE=0 %AND LLENGTH>0 %THEN %C
            PRINTSTRING("     C") %ELSE WRITE(LINE, 5)
      %IF MODE#0 %THEN PRINTSTRING("""       ") %ELSE SPACES(8)
         %IF HOST=ACCENT %or ll>255 %THEN %START
            PRINT SYMBOL(TLINE(K)) %FOR K=1,1,LL
          %ELSE
            tline(0)=ll
            printstring(string(ADDR(TLINE(0))))
         %finish
      %FINISH
!      %IF PARM_FREE=0 %AND LL>73 %THEN TLINE(73)=10 %AND LL=73
      %result=1             { line got OK}
%END
%END
%integerfn next nonspace
%integer i
      i=cc(q)
      q=q+1 %and i=cc(q) %while i=' '
      %result=i
%end
%INTEGERFN COMPARE(%INTEGER P)
%INTEGER I, J, ITEM, RA, RL, RP, RQ, RR, RS, MARKER, SSL, ALT, PP, nbochar
%OWNINTEGER SAVECOMP;                   ! FOR CHECKING DSIDED CONDS
%SWITCH BIP(999:1043)
      RP=SYMBOL(P)
      RL=LEVEL
      P=P+1
      PP=P;                          ! ROUTINE REALLY STARTS HERE
COMM:
      RQ=Q;                             ! RESET VALUES OF LINE&AR PTRS
      RR=R
      SSL=STRLINK;                      ! SAVE STRING LINK
      ALT=1;                            ! FIRST ALTERNATIVE TO BE TRIED
      RA=SYMBOL(P);                     ! RA TO NEXT PHRASE ALTERNATIVE
      RS=P
UPR:     R=R+1
SUCC:                                   ! SUCCESS ON TO NEXT ITEM
      RS=RS+1;                          ! RS=NEXT ALTERNATIVE MEANS THAT
                                        ! THIS ALT HAS BEEN COMPLETED SO
                                        ! EXIT WITH HIT=1
      %IF RS=RA %THEN ->FINI
      ITEM=SYMBOL(RS);                  ! NEXT BRICK IN THE CURRENT ALT
!printstring("testing item&sym"); write(item,4); space; printsymbol(nextnonspace&127); 
!      write(q,5);
!      write(nextnonspace,4); newline
      %IF ITEM<999 %THEN ->LIT
      %IF ITEM<1300  %THEN ->BIP(ITEM)
                                        ! BRICK IS A PHRASE TYPE
      %IF COMPARE(ITEM)=0 %THEN ->FAIL
      ->SUCC
LIT:                                    ! BRICK IS LITERAL
      I=next nonspace;                  ! OBTAIN CURRENT CHARACTER
      ->FAIL %UNLESS I=CLETT(ITEM+1)
      Q=Q+1
      K=CLETT(ITEM)+ITEM
      ITEM=ITEM+2
      %WHILE ITEM<=K %CYCLE
         ->FAIL %UNLESS next nonspace=CLETT(ITEM)
         Q=Q+1
         ITEM=ITEM+1
      %REPEAT;                          ! CHECK IT WITH LITERAL DICT ENTRY
      ->SUCC;                           ! MATCHED SUCCESSFULLY
FAIL:                                   ! FAILURE - NOTE POSITION REACHD
      %IF RA=RP %THEN ->TFAIL;          ! TOTAL FAILURE NO ALT TO TRY
      QMAX=Q %IF Q>QMAX
      Q=RQ;                             ! RESET LINE AND A.R. POINTERS
      R=RR+1;                           ! AVOID GOING VIA UPR:
      STRLINK=SSL
      ALT=ALT+1;                        ! MOVE TO NEXT ALT OF PHRASE
      RS=RA
      RA=SYMBOL(RA)
      ->SUCC
TFAIL:
      LEVEL=RL
      %RESULT=0
BIP(999):                               ! REPEATED PHRASE
      A(RR)=ALT; P=PP
      ->COMM
BIP(1000):FINI:                         ! NULL ALWAYS LAST & OK
      A(RR)=ALT
      %RESULT=1
BIP(1001):                              ! PHRASE NAME
      I=next nonspace;                  ! OBTAIN CURRENT CHARACTER
      ->FAIL %UNLESS TRTAB(I)=2
      PNAME(ITEM-1004)
      ->SUCC %IF HIT=1;  ->FAIL
BIP(1002):                              ! PHRASE INTEGER CONSTANT
BIP(1003):                              ! PHRASE CONST
      EVALCONST(ITEM-1003)
      ->FAIL %IF HIT=0
      ->SUCC
BIP(1004):                              ! PHRASE DUMMYSTART
      A(R)=1;                           ! THERE IS AN '%ELSESTART'
      R=R+1
      ->SUCC
BIP(1005):                              ! PHRASE N
      I=next nonspace;                  ! OBTAIN CURRENT CHARACTER
      ->FAIL %UNLESS '0'<=I<='9'
      S=0
      %WHILE '0'<=I<='9' %CYCLE
         S=10*S+I&15
         Q=Q+1; I=next nonspace
      %REPEAT
      A(R)<-S>>8; A(R+1)=S&255
      R=R+2; ->SUCC
BIP(1006):                              ! PHRASE S=SEPARATOR
      I=next nonspace;                  ! OBTAIN CURRENT CHARACTER
      a(r)=I; r=r+1
      ->SUCC %IF I=NL
      ->FAIL %UNLESS I=';'
      Q=Q+1; ->SUCC
BIP(1007):
                                        ! PHRASE COMMENT TEXT
      I=next nonspace;                  ! OBTAIN CURRENT CHARACTER
      %IF I='#' %THEN %start
         a(r)=1; r=r+1
         Q=Q+1; ->COMFOUND
      %finish
      %IF I='!' %THEN %start
         a(r)=2; r=r+1
         Q=Q+1; ->COMFOUND
      %finish
      ->FAIL %UNLESS I='C'+128 %AND CC(Q+1)=%C
         'O'+128 %AND CC(Q+2)=CC(Q+3)='M'+128 %AND CC(Q+4)='E'+128
         ->FAIL %UNLESS CC(Q+5)='N'+128 %AND CC(Q+6)='T'+128
      Q=Q+7
      a(r)=3; r=r+1
COMFOUND:
      J=CC(Q)
      %CYCLE
         a(r)=j; r=r+1
         %EXIT %IF J=NL
         Q=Q+1; J=CC(Q)
      %REPEAT
      ->SUCC
BIP(1008):                              ! PHRASE BIGHOLE
                                        ! NOT CURRENTLY USED IN TRIMP
!      A(I)=0 %FOR I=R,1,R+3
!      R=R+4
      ->SUCC
BIP(1009):                              ! PHRASE N255
      I=next nonspace;                  ! OBTAIN CURRENT CHARACTER
      ->FAIL %UNLESS '0'<=I<='9'
      S=0
      %WHILE '0'<=I<='9' %CYCLE
         S=10*S+I&15
         Q=Q+1; I=next nonspace
      %REPEAT
      ->FAIL %UNLESS 0<=S<=255
      A(R)=S; ->UPR
BIP(1010):                              ! PHRASE HOLE
      MARKER=R;  R=R+2;  ->SUCC
BIP(1011):                              ! PHRASE MARK
      I=R-MARKER
      A(MARKER+1)<-I
      A(MARKER)<-I>>8
      ->SUCC
BIP(1012):                              ! PHRASE read line?
      I=next nonspace;                  ! OBTAIN CURRENT CHARACTER
      %WHILE I=NL %%CYCLE
         %if llength=-1 %then fault(110,0,0)
         read line(0,0)
         RQ=1
         I=next nonspace
      %REPEAT
      FAULT(102, WORKA_WKFILEK,0) %IF R>ARSIZE
      ->SUCC
BIP(1013):                              ! PHRASE CHECKIMPS
      TEXTTEXT(0)
      ->FAIL %IF HIT=0
      ->SUCC
BIP(1014):                              ! PHRASE DUMMY APP
      A(R)=2; A(R+1)=2
      R=R+2; ->SUCC
BIP(1015):                              ! PHRASE DOWN=NEW TEXT LEVEL
      %if level>1 %then a(downptr(level))=1;   ! flag down in enclosing blk
      LEVEL=LEVEL+1
      SFS(LEVEL)=0
      Downptr(level)=r
      ->SUCC
BIP(1016):                              ! PHRASE UP 1 TEXTUAL LEVEL
      %WHILE SFS(LEVEL)#0 %CYCLE
         POP(SFS(LEVEL),I,J,K)
         %IF I=1 %THEN FAULT(53,K,0);  ! FINISH MISSING
         %IF I=2 %THEN FAULT(13,K,0);  ! %REPEAT MISSING
      %REPEAT
      LEVEL=LEVEL-1
      ->SUCC
BIP(1017):                              ! PHRASE LISTON
      PARM_LIST=1;  ->SUCC
BIP(1018):                              ! PHRASE LISTOFF
      PARM_LIST=0;  ->SUCC
BIP(1019):                              ! PHRASE COLON FOR LABEL
      ->FAIL %UNLESS CC(Q-1)=':'
      ->SUCC
BIP(1020):                              ! PHRASE NOTE CONST
      ->SUCC
BIP(1021):                              ! TRACE FOR ON CONDITIONS
      PARM_TRACE=1; ->SUCC
BIP(1022):                              ! SET MNEMONIC
      I=next nonspace;                  ! OBTAIN CURRENT CHARACTER
      J=0
      NEM="123456789abcdef"
      %WHILE 'A'<=I<='Z' %OR '0'<=I<='9' %CYCLE
         J=J+1
         %if j>=15 %then ->fail
         CHARNO(NEM,J)=I
         Q=Q+1; I=next nonspace
      %REPEAT
      ->FAIL %UNLESS J>0
      LENGTH(NEM)=J
      %IF I='_' %THEN Q=Q+1
      ->SUCC
BIP(1023):                              ! UCNOP MNEMONIC SANS OPERANDS
      ->FAIL %IF (TARGET=PNX %OR  TARGET=ACCENT %or %c
         target=drs %or target=wwc %or target=perq3) %AND CC(Q-1)='_'
                                        ! EFFICIENCY FROG FOR ASSBLERS
                                        ! WITH NO PARAMETER OPCODES
      %CYCLE I=0,1,FIRSTUCUB-1
         ->PFND %IF NEM=QCODES(I)
      %REPEAT
      ->FAIL
PFND:
      J=OPC(I)
      A(R)<-J>>8; A(R+1)<-J
      R=R+2; ->SUCC;                    ! ALLOW MORE THAN 255 OPCODES
BIP(1024):                              ! UCUB MNEMONIC WITH UNSIGNED BYTE OPERAND
      %CYCLE I=FIRST UCUB,1,FIRST UCSB-1
         ->PFND %IF NEM=QCODES(I)
      %REPEAT
      ->FAIL
BIP(1025):                             ! UCUB SIGNED BYTE OPERANDS
      %CYCLE I=FIRST UCSB,1,FIRST UCW-1
         ->PFND %IF NEM=QCODES(I)
      %REPEAT; ->FAIL
BIP(1026):                              ! P(OP)=+,-,&,****,**,*,!!,!,
                                        ! //,/,>>,<<,.,\\,\
      I=next nonspace;                  ! OBTAIN CURRENT CHARACTER
      ->FAIL %UNLESS 32<I<127 %AND %C
         X'80000000'>>((I-32)&31)&X'4237000A'#0
      Q=Q+1
      %IF I='+' %THEN A(R)=1 %AND ->UPR
      %IF I='-' %THEN A(R)=2 %AND ->UPR
      %IF I='&' %THEN A(R)=3 %AND ->UPR
      J=next nonspace
      %IF I='*' %THEN %START
         %IF J#I %THEN A(R)=6 %AND ->UPR
         %IF CC(Q+1)=I=CC(Q+2) %THEN A(R)=4 %AND Q=Q+3 %AND ->UPR
         A(R)=5; Q=Q+1; ->UPR
      %FINISH
      %IF I='/' %THEN %START
         %IF J#I %THEN A(R)=10 %AND ->UPR
         A(R)=9; Q=Q+1; ->UPR
      %FINISH
      %IF I='!' %THEN %START
         %IF J#I %THEN A(R)=8 %AND ->UPR
         A(R)=7; Q=Q+1; ->UPR
      %FINISH
      %IF I='.' %THEN A(R)=13 %AND ->UPR
      %IF I=J='<' %THEN A(R)=12 %AND Q=Q+1 %AND ->UPR
      %IF I=J='>' %THEN A(R)=11 %AND Q=Q+1 %AND ->UPR
      %IF I='\' %THEN %START
         %IF J#I %THEN A(R)=15 %AND ->UPR
         Q=Q+1; A(R)=14; ->UPR
      %FINISH
      ->FAIL
BIP(1027):                              ! PHRASE CHECK UI
      I=next nonspace;                  ! OBTAIN CURRENT CHARACTER
      ->SUCC %IF TRTAB(I)=2 %OR I='-'
      ->SUCC %IF X'80000000'>>(I&31)&X'14043000'#0
      ->FAIL
BIP(1028):                              ! P(+')=+,-,\,0
      I=next nonspace;                  ! OBTAIN CURRENT CHARACTER
      %IF I='\' %OR I=X'7E' %THEN A(R)=3 %AND Q=Q+1 %AND ->UPR
      %IF I='-' %THEN A(R)=2 %AND Q=Q+1 %AND ->UPR
      %IF I='+' %THEN A(R)=1 %AND Q=Q+1 %AND ->UPR
      A(R)=4; ->UPR
BIP(1029):                              ! PHRASE NOTE CYCLE
      A(R)=0; A(R+1)=0
      A(R+2)=0; A(R+3)=0
      PUSH(SFS(LEVEL),2,R,LINE)
      R=R+4
      ->SUCC
BIP(1030):                              ! P(,')=',',0
!
! THIS IS VERY AWKWARD AS IT MEANS IT IS VERY TO HARD TO FIND
! THE END OF A PARAMETER LIST WITHOUT CHURNING. BY MAKING THIS A BIP
! WE CAN PEEP AHEAD FOR ')' AND FAIL HERE.
!
      I=next nonspace;                  ! OBTAIN CURRENT CHARACTER
      %IF I=')' %THEN ->FAIL
      %IF I=',' %THEN Q=Q+1
      ->SUCC
BIP(1031):                              ! PHRASE CHECKTYPE IE ENSURE
                                        ! FIRST LETTER IS(B,H,I,L,R,S) &
                                        ! 3RD LETTER IS (A,L,N,O,R,T)
      I=next nonspace;                  ! OBTAIN CURRENT CHARACTER
      ->FAIL %UNLESS I>128 %AND X'80000000'>>(I&31)&X'20C83000'#0%C
         %AND X'80000000'>>(CC(Q+2)&31)&X'500B2800'#0
      ->SUCC
BIP(1032):                              ! PHRASE COMP1
BIP(1037):                              ! PHRASE COMP2(IS 2ND HALF OF DSIDED)
      I=next nonspace;                  ! OBTAIN CURRENT CHARACTER
      ->FAIL %UNLESS 32<I<=92 %AND %C
         X'80000000'>>(I&31)&X'1004000E'#0
                                        ! '='=1,'>='=2,'>'=3
                                        ! '#' OR '\=' OR '<>'=4
                                        ! '<='=5,'<'=6
                                        ! 7UNUSED,'->'=8,'=='=9
                                        ! '##' OR '\==' =10
      q=q+1; nbochar=next nonspace
      %IF I='=' %THEN %START
         %IF nbochar=I %THEN J=9 %AND ->JOIN1
         J=1; ->JOIN
      %FINISH
      %IF I='#' %THEN %START
         %IF nbochar=I %THEN J=10 %AND ->JOIN1
         J=4; ->JOIN
      %FINISH
      %IF I='\' %AND nbochar='=' %THEN %START
         Q=Q+1
         %IF next nonspace='=' %THEN J=10 %AND ->JOIN1
         J=4; ->JOIN
      %FINISH
      %IF I='>' %THEN %START
         %IF nbochar='=' %THEN J=2 %AND ->JOIN1
         J=3; ->JOIN
      %FINISH
      %IF I='<' %THEN %START
         %IF nbochar='>' %THEN J=4 %AND ->JOIN1
         %IF nbochar='=' %THEN J=5 %AND ->JOIN1
         J=6; ->JOIN
      %FINISH
      %IF I='-' %AND nbochar='>' %THEN J=8 %AND ->JOIN1
      ->FAIL
JOIN1:Q=Q+1
JOIN:
      A(R)=J
      %IF ITEM=1032 %THEN SAVECOMP=J %AND ->UPR
                                        ! SAVE J TO CHECK DSIDED
      %IF SAVECOMP>6 %OR J>6 %THEN Q=Q-1 %AND ->FAIL;! ILLEGAL DSIDED
      ->UPR;                            ! NB OWNS WONT WORK IF
                                        ! COND EXPRS ALLOWED AS THE
                                        ! CAN BE NESTED!
BIP(1033):                              ! P(ASSOP)- ==,=,<-,->
      I=next nonspace
      q=q+1; nbochar=next nonspace
      %if i='=' %then %start
         %if nbochar='=' %then A(R)=1 %AND Q=Q+1 %AND ->UPR
         A(R)=2; ->UPR
      %FINISH
      %IF I='<' %AND nbochar='-' %THEN A(R)=3 %AND Q=Q+1 %AND ->UPR
      %IF I='-' %AND nbochar='>' %THEN A(R)=4 %AND Q=Q+1 %AND ->UPR
      ->FAIL
BIP(1034):                              ! NOTE START
      A(R)=0; A(R+1)=0
      A(R+2)=0; A(R+3)=0;               ! HOLE FOR FORWARD PTR
      PUSH(SFS(LEVEL),1,R,LINE)
      R=R+4
      ->SUCC
BIP(1035):                              ! NOTE FINISH
      %IF SFS(LEVEL)=0 %THEN FAULT(51,0,0) %AND ->SUCC
      POP(SFS(LEVEL),I,J,K)
      %IF I=2 %THEN FAULT(59,K,0)
      MOVEBYTES(4,ADDR(STARSTART),0,ADDR(A(0)),J)
      ->SUCC
BIP(1036):                              ! NOTE REPEAT
      %IF SFS(LEVEL)=0 %THEN FAULT(1,0,0) %AND ->SUCC
      POP(SFS(LEVEL),I,J,K)
      %IF I=1 %THEN FAULT(52,K,0);     ! START INSTEAD OF CYCLE
      MOVEBYTES(4,ADDR(STARSTART),0,ADDR(A(0)),J)
      ->SUCC
BIP(1038):                              ! INCLUDE "FILE"
      ->FAIL %IF IDEPTH>10
      I=next nonspace
      ->FAIL %UNLESS I=NL %OR I=';'
      Q=Q+1 %IF I=';'
      ->FAIL %UNLESS CTYPE=5 %AND (Host#emas %or A(S)<=31)
%BEGIN
%STRING(255) FNAME
%SYSTEMROUTINESPEC CONSOURCE(%STRING(255)FILENAME,%INTEGERNAME FILEADDR)
      LENGTH(FNAME)=A(S)
      CHARNO(FNAME,I)=A(S+I) %FOR I=1,1,A(S)
      %if host=Vax %Start
         %unless fname->(".") %then fname=fname.".INC"
      %finish
      CONSOURCE(FNAME,J)
      NEWSOURCE(J)
%END
      ->succ
BIP(1039):                              ! UCW = USERCODE WORD OFFSET INSTRS
      %CYCLE I=FIRST UCW,1,FIRST UCUBUB-1
         ->PFND %IF NEM=QCODES(I)
      %REPEAT
      ->FAIL
BIP(1040):                              ! UCUBUB TWO UNSIGNED BYTE OPERANDS
      %CYCLE I=FIRST UCUBUB,1,FIRST UCUBW-1
         ->PFND %IF NEM=QCODES(I)
      %REPEAT; ->FAIL
BIP(1041):                              ! UCUCUBW - BYTE&WORD OPERANDS
      %CYCLE I=FIRST UCUBW,1,FIRST UCJUMP-1
         ->PFND %IF NEM=QCODES(I)
      %REPEAT; ->FAIL
BIP(1042):                              ! UCJUMP = JUMP MNEMONICS
      %CYCLE I=FIRST UCJUMP,1,LASTUC
         ->PFND %IF NEM=QCODES(I)
      %REPEAT; ->FAIL
BIP(1043):                              ! UCWRONG ERRORS AND OTHER M-CS
      I=next nonspace
      %CYCLE
         Q=Q+1
         %EXIT %IF I=NL %OR I=';'
         I=next nonspace
      %REPEAT
      ->SUCC
%END;                                   !OF ROUTINE 'COMPARE'
%ROUTINE PNAME(%INTEGER MODE)
!***********************************************************************
!*       MODE=0 FOR OLD NAME(ALREADY IN DICT), MODE=1 FOR NEW NAME     *
!***********************************************************************
%CONSTINTEGERARRAY HASH(0:7)=71,47,97,79,29,37,53,59;
%INTEGER JJ, KK, LL, FQ, FS, T, S, I
      HIT=0;  FQ=Q;  FS=next nonspace
      q=q+1
      %RETURN %UNLESS TRTAB(FS)=2 %AND M'"'#next nonspace#M''''
                                        ! 1ST CHAR MUST BE LETTER
      %if PARM_QUOTES=0 %then FS=FS!32
      T=1
      LETT(NEXT+1)=FS; JJ=71*FS
      q=q-1
      %CYCLE
         Q=Q+1
         I=next nonspace
         %EXIT %IF TRTAB(I)=0
         %if PARM_QUOTES=0 %then I=I!32
         JJ=JJ+HASH(T)*I %IF T<=7
         T=T+1
         LETT(NEXT+T)=I
      %REPEAT
      LETT(NEXT)=T;                     ! INSERT LENGTH
      S=T+1
      FAULT(103,0,0) %IF NEXT+S>DSIZE; !DICTIONARY OVERFLOW
      JJ=(JJ+113*T)&NNAMES
      %CYCLE KK=JJ, 1, NNAMES
         LL=WORD(KK)
         ->HOLE %IF LL=0;               ! NAME NOT KNOWN
         ->FND %IF STRING(ADDR(LETT(NEXT)))=STRING(ADDR(LETT(LL)))
      %REPEAT
      %CYCLE KK=0,1,JJ
         LL=WORD(KK)
         ->HOLE %IF LL=0;               ! NAME NOT KNOWN
         ->FND %IF STRING(ADDR(LETT(NEXT)))=STRING(ADDR(LETT(LL)))
      %REPEAT
      FAULT(104, 0, 0);                 ! TOO MANY NAMES
HOLE: %IF MODE=0 %THEN Q=FQ %AND %RETURN
      WORD(KK)=NEXT
      %IF HOST//10<=1 %THEN NEXT=NEXT+S %ELSE NEXT=(NEXT+S+1)&(-2)
FND:  LASTAT=FQ;  HIT=1;  LASTNAME=KK
      A(R+1)<-LASTNAME
      A(R)=LASTNAME>>8; R=R+2
      LASTEND=Q
%END

%ROUTINE EVALCONST(%INTEGER MODE)
!***********************************************************************
!*       SYNTAX CHECK AND EVALUATE ALL THE FORMS OF IMP CONSTANT       *
!*       MODE=0 FOR INTEGER CONSTANTS #0 FOR ANY SORT OF CONSTANT      *
!***********************************************************************
%CONSTBYTEINTEGERARRAY RSHIFT(0:32)=0,0,1,0,2,0(3),3,0(7),4,0(15),5;
%INTEGER Z, DOTSEEN, EBCDIC, FS, CPREC, RR, S, SS, T, RS, J, nbochar, QQ
%integer hexformat
%integerarray rhexpat(0:3)
%constinteger powerl=75
%IF 1<<HOST&LLREALAVAIL#0 %START
   %if 1<<host&ibmfpformat#0 %Start
%constinteger powerll=-78
! from ibm assembler which claims to evaluate exactly and round to 128 bits
%CONSTLONGLONGREALARRAY    POWERS (-78:75)=                  %C
       {Ten to the -78}           R'001DA48CE468E7C772026520247D3556' ,
       {Ten to the -77}           R'011286D80EC190DC73617F3416CE4156' ,
       {Ten to the -76}           R'01B94470938FA89B73CEF808E40E8D5B' ,
       {Ten to the -75}           R'0273CAC65C39C96174615B058E891859' ,
       {Ten to the -74}           R'03485EBBF9A41DDC75DCD8E37915AF38' ,
       {Ten to the -73}           R'042D3B357C0692AA760A078E2BAD8D83' ,
       {Ten to the -72}           R'051C45016D841BAA774644B8DB4C7872' ,
       {Ten to the -71}           R'0611AB20E472914A786BEAF3890FCB47' ,
       {Ten to the -70}           R'06B0AF48EC79ACE878372D835A9DF0C7' ,
       {Ten to the -69}           R'076E6D8D93CC0C1179227C7218A2B67C' ,
       {Ten to the -68}           R'084504787C5F878A7AB58DC74F65B20E' ,
       {Ten to the -67}           R'092B22CB4DBBB4B67BB1789C919F8F49' ,
       {Ten to the -66}           R'0A1AF5BF109550F27C2EEB61DB03B98D' ,
       {Ten to the -65}           R'0B10D9976A5D52977D5D531D28E253F8' ,
       {Ten to the -64}           R'0BA87FEA27A539E97DA53F2398D747B3' ,
       {Ten to the -63}           R'0C694FF258C744327E0747763F868CD0' ,
       {Ten to the -62}           R'0D41D1F7777C8A9F7F448CA9E7B41802' ,
       {Ten to the -61}           R'0E29233AAAADD6A3008AD7EA30D08F01' ,
       {Ten to the -60}           R'0F19B604AAACA6260136C6F25E825961' ,
       {Ten to the -59}           R'101011C2EAABE7D702E23C577B1177DD' ,
       {Ten to the -58}           R'10A0B19D2AB70E6E02D65B6ACEAEAE9D' ,
       {Ten to the -57}           R'11646F023AB269050345F922C12D2D22' ,
       {Ten to the -56}           R'123EC56164AF81A3044BBBB5B8BC3C35' ,
       {Ten to the -55}           R'13273B5CDEEDB106050F55519375A5A1' ,
       {Ten to the -54}           R'1418851A0B548EA306C99552FC298785' ,
       {Ten to the -53}           R'14F53304714D926506DFD53DD99F4B30' ,
       {Ten to the -52}           R'15993FE2C6D07B7F07ABE546A8038EFE' ,
       {Ten to the -51}           R'165FC7EDBC424D2F08CB6F4C2902395F' ,
       {Ten to the -50}           R'173BDCF495A9703D09DF258F99A163DB' ,
       {Ten to the -49}           R'18256A18DD89E6260AAB7779C004DE69' ,
       {Ten to the -48}           R'1917624F8A762FD80B2B2AAC18030B02' ,
       {Ten to the -47}           R'19E9D71B689DDE710BAFAAB8F01E6E11' ,
       {Ten to the -46}           R'1A9226712162AB070C0DCAB3961304CA' ,
       {Ten to the -45}           R'1B5B5806B4DDAAE40D689EB03DCBE2FF' ,
       {Ten to the -44}           R'1C391704310A8ACE0EC1632E269F6DDF' ,
       {Ten to the -43}           R'1D23AE629EA696C10F38DDFCD823A4AB' ,
       {Ten to the -42}           R'1E164CFDA3281E3810C38ABE071646EB' ,
       {Ten to the -41}           R'1EDF01E85F912E3710A36B6C46DEC52F' ,
       {Ten to the -40}           R'1F8B61313BBABCE211C62323AC4B3B3E' ,
       {Ten to the -39}           R'20571CBEC554B60D12BBD5F64BAF0507' ,
       {Ten to the -38}           R'213671F73B54F1C8139565B9EF4D6324' ,
       {Ten to the -37}           R'2222073A8515171D145D5F9435905DF7' ,
       {Ten to the -36}           R'23154484932D2E72155A5BBCA17A3ABA' ,
       {Ten to the -35}           R'23D4AD2DBFC3D0771587955E4EC64B45' ,
       {Ten to the -34}           R'2484EC3C97DA624A16B4BD5AF13BEF0B' ,
       {Ten to the -33}           R'255313A5DEE87D6E17B0F658D6C57567' ,
       {Ten to the -32}           R'2633EC47AB514E65182E99F7863B6960' ,
       {Ten to the -31}           R'272073ACCB12D0FF193D203AB3E521DC' ,
       {Ten to the -30}           R'2814484BFEEBC29F1A863424B06F352A' ,
       {Ten to the -29}           R'28CAD2F7F5359A3B1A3E096EE45813A0' ,
       {Ten to the -28}           R'297EC3DAF94180651B06C5E54EB70C44' ,
       {Ten to the -27}           R'2A4F3A68DBC8F03F1C243BAF513267AB' ,
       {Ten to the -26}           R'2B318481895D96271D76A54D92BF80CB' ,
       {Ten to the -25}           R'2C1EF2D0F5DA7DD81EAA27507BB7B07F' ,
       {Ten to the -24}           R'2D1357C299A88EA71F6A58924D52CE4F' ,
       {Ten to the -23}           R'2DC16D9A0095928A1F2775B7053C0F18' ,
       {Ten to the -22}           R'2E78E480405D7B962058A9926345896F' ,
       {Ten to the -21}           R'2F4B8ED0283A6D3D21F769FB7E0B75E5' ,
       {Ten to the -20}           R'302F39421924844622BAA23D2EC729AF' ,
       {Ten to the -19}           R'311D83C94FB6D2AC2334A5663D3C7A0E' ,
       {Ten to the -18}           R'3212725DD1D243AB24A0E75FE645CC48' ,
       {Ten to the -17}           R'32B877AA3236A4B4244909BEFEB9FAD5' ,
       {Ten to the -16}           R'33734ACA5F6226F025ADA6175F343CC5' ,
       {Ten to the -15}           R'34480EBE7B9D5856266C87CE9B80A5FB' ,
       {Ten to the -14}           R'352D09370D4257362703D4E1213067BD' ,
       {Ten to the -13}           R'361C25C26849768128C2650CB4BE40D6' ,
       {Ten to the -12}           R'37119799812DEA1129197F27F0F6E886' ,
       {Ten to the -11}           R'37AFEBFF0BCB24AA29FEF78F69A5153A' ,
       {Ten to the -10}           R'386DF37F675EF6EA2ADF5AB9A2072D44' ,
       {Ten to the  -9}           R'3944B82FA09B5A522BCB98B405447C4B' ,
       {Ten to the  -8}           R'3A2AF31DC46118732CBF3F70834ACDAF' ,
       {Ten to the  -7}           R'3B1AD7F29ABCAF482D5787A6520EC08D' ,
       {Ten to the  -6}           R'3C10C6F7A0B5ED8D2E36B4C7F3493858' ,
       {Ten to the  -5}           R'3CA7C5AC471B47842E230FCF80DC3372' ,
       {Ten to the  -4}           R'3D68DB8BAC710CB22F95E9E1B089A027' ,
       {Ten to the  -3}           R'3E4189374BC6A7EF309DB22D0E560419' ,
       {Ten to the  -2}           R'3F28F5C28F5C28F531C28F5C28F5C28F' ,
       {Ten to the  -1}           R'4019999999999999329999999999999A' ,
       {Ten to the   0}           R'41100000000000003300000000000000' ,
       {Ten to the   1}           R'41A00000000000003300000000000000' ,
       {Ten to the   2}           R'42640000000000003400000000000000' ,
       {Ten to the   3}           R'433E8000000000003500000000000000' ,
       {Ten to the   4}           R'44271000000000003600000000000000' ,
       {Ten to the   5}           R'45186A00000000003700000000000000' ,
       {Ten to the   6}           R'45F42400000000003700000000000000' ,
       {Ten to the   7}           R'46989680000000003800000000000000' ,
       {Ten to the   8}           R'475F5E10000000003900000000000000' ,
       {Ten to the   9}           R'483B9ACA000000003A00000000000000' ,
       {Ten to the  10}           R'492540BE400000003B00000000000000' ,
       {Ten to the  11}           R'4A174876E80000003C00000000000000' ,
       {Ten to the  12}           R'4AE8D4A5100000003C00000000000000' ,
       {Ten to the  13}           R'4B9184E72A0000003D00000000000000' ,
       {Ten to the  14}           R'4C5AF3107A4000003E00000000000000' ,
       {Ten to the  15}           R'4D38D7EA4C6800003F00000000000000' ,
       {Ten to the  16}           R'4E2386F26FC100004000000000000000' ,
       {Ten to the  17}           R'4F16345785D8A0004100000000000000' ,
       {Ten to the  18}           R'4FDE0B6B3A7640004100000000000000' ,
       {Ten to the  19}           R'508AC7230489E8004200000000000000' ,
       {Ten to the  20}           R'5156BC75E2D631004300000000000000' ,
       {Ten to the  21}           R'523635C9ADC5DEA04400000000000000' ,
       {Ten to the  22}           R'5321E19E0C9BAB244500000000000000' ,
       {Ten to the  23}           R'54152D02C7E14AF64680000000000000' ,
       {Ten to the  24}           R'54D3C21BCECCEDA14600000000000000' ,
       {Ten to the  25}           R'558459516140148447A0000000000000' ,
       {Ten to the  26}           R'5652B7D2DCC80CD248E4000000000000' ,
       {Ten to the  27}           R'5733B2E3C9FD080349CE800000000000' ,
       {Ten to the  28}           R'58204FCE5E3E25024A61100000000000' ,
       {Ten to the  29}           R'591431E0FAE6D7214B7CAA0000000000' ,
       {Ten to the  30}           R'59C9F2C9CD04674E4BDEA40000000000' ,
       {Ten to the  31}           R'5A7E37BE2022C0914C4B268000000000' ,
       {Ten to the  32}           R'5B4EE2D6D415B85A4DCEF81000000000' ,
       {Ten to the  33}           R'5C314DC6448D93384EC15B0A00000000' ,
       {Ten to the  34}           R'5D1ED09BEAD87C034F78D8E640000000' ,
       {Ten to the  35}           R'5E13426172C74D82502B878FE8000000' ,
       {Ten to the  36}           R'5EC097CE7BC9071550B34B9F10000000' ,
       {Ten to the  37}           R'5F785EE10D5DA46D51900F436A000000' ,
       {Ten to the  38}           R'604B3B4CA85A86C4527A098A22400000' ,
       {Ten to the  39}           R'612F050FE938943A53CC45F655680000' ,
       {Ten to the  40}           R'621D6329F1C35CA454BFABB9F5610000' ,
       {Ten to the  41}           R'63125DFA371A19E655F7CB54395CA000' ,
       {Ten to the  42}           R'63B7ABC62705030555ADF14A3D9E4000' ,
       {Ten to the  43}           R'6472CB5BD86321E3568CB6CE6682E800' ,
       {Ten to the  44}           R'6547BF19673DF52E5737F2410011D100' ,
       {Ten to the  45}           R'662CD76FE086B93C58E2F768A00B22A0' ,
       {Ten to the  46}           R'671C06A5EC5433C6590DDAA16406F5A4' ,
       {Ten to the  47}           R'68118427B3B4A05B5AC8A8A4DE845987' ,
       {Ten to the  48}           R'68AF298D050E43955AD69670B12B7F41' ,
       {Ten to the  49}           R'696D79F82328EA3D5BA61E066EBB2F89' ,
       {Ten to the  50}           R'6A446C3B15F992665C87D2C40534FDB5' ,
       {Ten to the  51}           R'6B2AC3A4EDBBFB805D14E3BA83411E91' ,
       {Ten to the  52}           R'6C1ABA4714957D305E0D0E549208B31B' ,
       {Ten to the  53}           R'6D10B46C6CDD6E3E5F0828F4DB456FF1' ,
       {Ten to the  54}           R'6DA70C3C40A64E6C5F51999090B65F68' ,
       {Ten to the  55}           R'6E6867A5A867F10360B2FFFA5A71FBA1' ,
       {Ten to the  56}           R'6F4140C78940F6A2614FDFFC78873D45' ,
       {Ten to the  57}           R'7028C87CB5C89A256271EBFDCB54864B' ,
       {Ten to the  58}           R'71197D4DF19D60576367337E9F14D3EF' ,
       {Ten to the  59}           R'71FEE50B7025C36A630802F236D04754' ,
       {Ten to the  60}           R'729F4F2726179A22644501D762422C94' ,
       {Ten to the  61}           R'7363917877CEC055656B21269D695BDD' ,
       {Ten to the  62}           R'743E3AEB4AE138356662F4B82261D96A' ,
       {Ten to the  63}           R'7526E4D30ECCC321675DD8F3157D27E2' ,
       {Ten to the  64}           R'76184F03E93FF9F468DAA797ED6E38ED' ,
       {Ten to the  65}           R'76F316271C7FC390688A8BEF464E3946' ,
       {Ten to the  66}           R'7797EDD871CFDA3A695697758BF0E3CC' ,
       {Ten to the  67}           R'785EF4A74721E8646A761EA977768E5F' ,
       {Ten to the  68}           R'793B58E88C75313E6BC9D329EAAA18FC' ,
       {Ten to the  69}           R'7A25179157C93EC76C3E23FA32AA4F9D' ,
       {Ten to the  70}           R'7B172EBAD6DDC73C6D86D67C5FAA71C2' ,
       {Ten to the  71}           R'7BE7D34C64A9C85D6D4460DBBCA87197' ,
       {Ten to the  72}           R'7C90E40FBEEA1D3A6E4ABC8955E946FE' ,
       {Ten to the  73}           R'7D5A8E89D75252446F6EB5D5D5B1CC5F' ,
       {Ten to the  74}           R'7E3899162693736A70C531A5A58F1FBB' ,
       {Ten to the  75}           R'7F235FADD81C282271BB3F07877973D5';
   %else
%constinteger powerll=0
%constlonglongrealarray powers(0:75)=1, 10, 1@2, 1@3, 1@4, 1@5, 1@6, 1@7,
                               1@8, 1@9, 1@10, 1@11, 1@12, 1@13, 1@14, 1@15,
                               1@16, 1@17, 1@18, 1@19, 1@20, 1@21, 1@22, 1@23,
                               1@24, 1@25, 1@26, 1@27, 1@28, 1@29, 1@30, 1@31,
                               1@32, 1@33, 1@34, 1@35, 1@36, 1@37, 1@38, 1@39,
                               1@40, 1@41, 1@42, 1@43, 1@44, 1@45, 1@46, 1@47,
                               1@48, 1@49, 1@50, 1@51, 1@52, 1@53, 1@54, 1@55,
                               1@56, 1@57, 1@58, 1@59, 1@60, 1@61, 1@62, 1@63,
                               1@64, 1@65, 1@66, 1@67, 1@68, 1@69, 1@70, 1@71,
                               1@72, 1@73, 1@74, 1@75;
      %finish
      %LONGLONGREAL X,dvalue,CVALUE,DUMMY
      %CONSTLONGLONGREAL TEN=10
%FINISH %ELSE %START
      %LONGREAL X,dvalue,CVALUE,DUMMY
%constinteger powerll=0
%constlongrealarray powers(0:75)=1, 10, 1@2, 1@3, 1@4, 1@5, 1@6, 1@7,
                               1@8, 1@9, 1@10, 1@11, 1@12, 1@13, 1@14, 1@15,
                               1@16, 1@17, 1@18, 1@19, 1@20, 1@21, 1@22, 1@23,
                               1@24, 1@25, 1@26, 1@27, 1@28, 1@29, 1@30, 1@31,
                               1@32, 1@33, 1@34, 1@35, 1@36, 1@37, 1@38, 1@39,
                               1@40, 1@41, 1@42, 1@43, 1@44, 1@45, 1@46, 1@47,
                               1@48, 1@49, 1@50, 1@51, 1@52, 1@53, 1@54, 1@55,
                               1@56, 1@57, 1@58, 1@59, 1@60, 1@61, 1@62, 1@63,
                               1@64, 1@65, 1@66, 1@67, 1@68, 1@69, 1@70, 1@71,
                               1@72, 1@73, 1@74, 1@75;
      %CONSTLONGREAL TEN=10
%FINISH
%longreal cvaluep
%IF 1<<HOST&LINTAVAIL#0 %START
      %LONGINTEGER RADIXV
%FINISH %ELSE %START
      %INTEGER RADIXV
%FINISH
      %ON %EVENT 1,2 %START
         HIT=0; hexformat=0
         %RETURN
      %FINISH
      CPREC=5;  RR=R;  R=R+1
      DOTSEEN=0;  HIT=0; hexformat=0
      CVALUE=0;  DUMMY=0; X=0;  FS=next nonspace
      qq=q; q=q+1; nbochar=next nonspace; q=qq
      S=0;  ->N %IF M'0'<=FS<=M'9'
      ->DOT %IF FS='.' %AND MODE=0 %AND '0'<=nbo char<='9'
                                        ! 1 DIDT MIN
      CTYPE=1;  EBCDIC=0
      ->QUOTE %IF FS=M''''
      ->STR2 %IF FS=34
      ->NOTQUOTE %UNLESS nbo char=M'''';  Q=Q+2
      ->HEX %IF FS='X' %or FS='x'
      ->MULT %IF FS='M' %or FS='m'
      ->BIN %IF FS=M'B' %or FS='b'
      ->RHEX %IF (FS='R' %or FS='H' %or FS='r' %or FS='h') %AND MODE=0
      ->OCT %IF FS='K' %or FS='k'
      %IF FS='C' %or FS='c' %THEN EBCDIC=1 %AND ->MULT
      %IF (FS='D' %or FS='d') %AND MODE=0 %THEN %START
         CPREC=7
         %IF M'0'<=next nonspace<=M'9' %THEN ->N
         %IF next nonspace='.' %THEN ->DOT
      %FINISH
      Q=Q-2;  %RETURN
QUOTE:                                  ! SINGLE CH BETWEEN QUOTES
      hexformat=8; cprec=3
      q=q+1; s=cc(q); q=q+1
      %if s=nl %start
         READ LINE(1,'''')
         fault(110,0,0) %if llength=-1
        Q=1
      %finish
      %IF next nonspace=M'''' %THEN %START
         Q=Q+1
         %IF S#M'''' %THEN ->IEND
         %IF next nonspace=M'''' %THEN Q=Q+1 %AND ->IEND
      %FINISH
      %RETURN;                          ! NOT VALID
NOTQUOTE:                               ! CHECK FOR E"...."
      %RETURN %UNLESS FS='E' %AND nbochar=M'"'
      EBCDIC=1; Q=Q+1
STR2:                                   ! DOUBLE QUOTED STRING
      A(RR)=X'35';  TEXTTEXT(EBCDIC)
      CTYPE=5;  %RETURN
HEX:  T=0;                              ! HEX CONSTANTS
      hexformat=8
      %CYCLE
         I=next nonspace;  Q=Q+1
         %EXIT %IF I=M''''
         T=T+1
         %RETURN %UNLESS  %C
         ('0'<=I<='9' %OR 'A'<=I<='F' %OR 'a'<=I<='f') %AND t<17
         %IF T=9 %THEN SS=S %AND S=0
         S=S<<4+I&15+9*I>>6
      %REPEAT
      %IF T>8 %START
         Z=4*(T-8)
         %unless Z=32 %then S=S!(SS<<Z) %and SS=SS>>(32-Z);! shifts modulo 31 on gould!
         CPREC=6
      %FINISH
IEND:
      %IF CPREC=6 %THEN %Start
         %if 1<<host&wordswopped#0 %Start
            move bytes(4,addr(ss),0,addr(a(0)),R+4)
            move bytes(4,addr(s),0,addr(a(0)),R)
         %else
            MOVEBYTES(4,ADDR(SS),0,ADDR(A(0)),R)
            move bytes(4,addr(s),0,addr(a(0)),r+4)
         %finish
         r=r+8
      %finish %else %IF cprec=3 %or cprec=4 %or (CPREC=5 %AND 0<=S<=X'7FFF') %START
         %if cprec=5 %then CPREC=4;
         A(R)<-S>>8; A(R+1)=S&255; R=R+2
      %FINISH %ELSE %START
         MOVEBYTES(4,ADDR(S),0,ADDR(A(0)),R)
         R=R+4
      %FINISH
      HIT=1 %UNLESS MODE#0 %AND CPREC=6
      A(RR)=CPREC<<4!CTYPE! hexformat
      %RETURN
RHEX:                                   ! REAL HEX CONSTANTS
      T=0
      %CYCLE
         I=next nonspace;  Q=Q+1
         %IF T&7=0 %AND T#0 %START
            rhexpat(t//8-1)=s;  S=0
         %FINISH
         %EXIT %IF I=M'''';  T=T+1
         %RETURN %UNLESS '0'<=I<='9' %OR 'A'<=I<='F' %OR 'a'<=I<='f'
         S=S<<4+I&15+9*I>>6
      %REPEAT
      %RETURN %UNLESS T=8 %OR T=16 %OR T=32
      %IF T=32 %THEN CPREC=7 %ELSE CPREC=4+T//8
      A(RR)=CPREC<<4!2
      %if host#target %and ibmfpformat>>host&1#ibmfpformat>>target&1 %c
          %and FS='R'%then A(RR)=A(RR)!8;         ! Flag const not to converted
      t=t//8-1
      %for i=0,1,t %cycle
         %if 1<<host&wordswopped#0 %Then j=4*(t-i) %else j=4*i
         move bytes(4,addr(rhexpat(0)),j,addr(a(0)),r)
         r=r+4
      %repeat
      HIT=1;  %RETURN
OCT:                                    ! OCTAL CONSTANTS
      hexformat=8
      T=0
      %CYCLE
         I=next nonspace;  Q=Q+1;  T=T+1
         %EXIT %IF I=M''''
         %RETURN %UNLESS '0'<=I<='7' %AND T<12
         S=S<<3!(I&7)
      %REPEAT
      ->IEND
MULT: T=0;                              ! MULTIPLE CONSTANTS
      %CYCLE
         I=cc(q);  Q=Q+1;  T=T+1
         %IF I=M'''' %THEN %START
            %IF next nonspace#M'''' %THEN %EXIT %ELSE Q=Q+1
         %FINISH
         %RETURN %IF T>=5
         %IF EBCDIC#0 %THEN I=ITOETAB(I)
         S=S<<8!I
      %REPEAT
      ->IEND
BIN:  T=0;                              ! BINARY CONST
      hexformat=8
      %CYCLE
         I=next nonspace;  Q=Q+1;  T=T+1
         %EXIT %IF I=M''''
         %RETURN %UNLESS '0'<=I<='1' %AND T<33
         S=S<<1!I&1
      %REPEAT
      ->IEND
RADIX:                                  ! BASE_VALUE CONSTANTS
      hexformat=8
      T=0; RADIXV=0
      RS=RSHIFT(S)
      Q=Q+1
      %CYCLE
         I=next nonspace
         %EXIT %UNLESS '0'<=I<='9' %OR 'A'<=I<='Z' %OR 'a'<=I<='z'
         %IF I<='9' %THEN I=I-'0' %ELSE I=I&15+9
         %EXIT %IF I>=S;                ! MUST BE LESS THAN BASE
         Q=Q+1
         %IF RS#0 %THEN RADIXV=RADIXV<<RS+I %AND T=T+RS %C
            %ELSE RADIXV=RADIXV*S+I %AND T=T+1
      %REPEAT
      %RETURN %IF T=0 %OR (1<<TARGET&LINTAVAIL=0 %AND RS>0 %AND T>MAXIBITS);! NO VALID DIGITS
      %IF 1<<HOST&LINTAVAIL#0 %THEN SS<-RADIXV>>32 %ELSE SS=0
      S<-RADIXV
      CTYPE=1
      %IF SS#0 %THEN CPREC=6
      ->IEND
N:                                      ! CONSTANT STARTS WITH DIGIT
      I=next nonspace
      %UNTIL I<M'0' %OR I>M'9' %CYCLE
         CVALUE=TEN*CVALUE+(I&15)
         Q=Q+1;  I=next nonspace;               ! ONTO NEXT CHAR
      %REPEAT
      %IF I='_' %AND 2<=CVALUE<33 %THEN S=INT(CVALUE) %AND ->RADIX
      ->ALPHA %UNLESS MODE=0 %AND I='.'
DOT:  Q=Q+1;   I=next nonspace
      DOTSEEN=1;                        ! CONSTANT HAS DECIMAL POINT

      dvalue=0; s=0
      %WHILE M'0'<=I<=M'9' %CYCLE
         dvalue=ten*dvalue+(i&15)
         s=s+1
        Q=Q+1;  I=next nonspace
      %REPEAT
      cvalue=cvalue+(dvalue/powers(s))
ALPHA:                                  ! TEST FOR EXPONENT
      %IF MODE=0 %AND next nonspace='@' %THEN %START
         Q=Q+1;  X=CVALUE
         Z=1;  I=next nonspace
         %IF I='-' %THEN Z=-1
         %IF I='+' %OR I='-' %THEN Q=Q+1
         EVALCONST(2)
         %IF HIT=0 %THEN %RETURN
         HIT=0
         DOTSEEN=1;                     ! @ IMPLIES REAL IN IMP80
         R=RR+1
         %IF A(R)>>4#4 %THEN %RETURN;   ! EXPONENT  MUST BE HALFINTEGER
         S=(A(R+1)<<8!A(R+2))*Z
         %IF S=-99 %THEN CVALUE=0 %ELSE %START
            %if powerll<=s<=powerl %then cvalue=cvalue*powers(s) %else %c
              %if imod(s)<=powerl %then cvalue=cvalue/powers(-s) %else %Start
               %if 1<<Target&LLREALAVAIL#0 %then cprec=7
               %WHILE S>0 %CYCLE
                  S=S-1
                  CVALUE=CVALUE*TEN
               %REPEAT
               %WHILE S<0 %AND CVALUE#0 %CYCLE
                  S=S+1
                 CVALUE=CVALUE/TEN
               %REPEAT
            %finish
         %FINISH
      %FINISH
                                        ! SEE IF IT IS INTEGER
      %IF FS='D' %THEN %START
         I=next nonspace
         %IF I='''' %THEN Q=Q+1 %ELSE %RETURN
         DOTSEEN=1;                     ! ENSURE NOT TAKEN AS INTEGER
      %FINISH
      %if 1<<Host&LINTAVAIL#0 %and 1<<Target&LINTAVAIL#0 %andc
         dotseen=0 %and cvalue>imax %start
         radixv=lint(cvalue)
         ss<-radixv>>32; s<-radixv
         cprec=6; ->iend
      %finish
      %IF DOTSEEN=1 %OR CVALUE>IMAX %THEN CTYPE=2 %C
         %ELSE CTYPE=1 %AND S=INT(CVALUE)
      %IF CTYPE=1 %THEN ->IEND
      %IF CPREC=5 %THEN CPREC=6;        ! ONLY 64 BIT REAL CONSTS
      %IF CPREC=6 %THEN %START
         cvaluep=cvalue;                 ! may perform a round
         MOVEBYTES(8,ADDR(CVALUEp),0,ADDR(A(0)),R);  R=R+8
      %FINISH %ELSE %START;             ! PREC = 7 CONTSTANTS
         MOVEBYTES(16,ADDR(CVALUE),0,ADDR(A(0)),R)
         R=R+16
      %FINISH
      A(RR)=CPREC<<4+CTYPE
      HIT=1
%END
%ROUTINE TEXTTEXT(%INTEGER EBCDIC)
!***********************************************************************
!*    PROCESSES TEXT BETWEEN DOUBLE QUOTES AND STORES IN ISO OR EBCDIC *
!***********************************************************************
%INTEGER J, II
%CONSTINTEGER QU='"'
         I=next nonspace
         S=R;  R=R+1; HIT=0
         %RETURN %UNLESS I=QU;          ! FAIL UNLESS  INITIAL QUOTE
         Q=Q+1
         %CYCLE
            I=cc(q)
            %IF EBCDIC#0 %THEN II=ITOETAB(I) %ELSE II=I
            A(R)=II;  R=R+1
            %IF I=QU %THEN %START
               Q=Q+1
               %IF next nonspace#QU %THEN %EXIT
            %FINISH
            %IF I=10 %THEN %start
               READ LINE(1,QU)
              fault(110,0,0) %if llength=-1
            %finish %ELSE Q=Q+1
            FAULT(106,0,0) %IF R-S>256
         %REPEAT
         R=R-1;  J=R-S-1
         A(S)=J;   HIT=1
%END
%END;                              ! OF ROUTINE PASS ONE
%ENDOFFILE

pass2.i/        872091674   12014 11130 100644  306507    `
!
! m88p205f.3.i Sep93 pds Change in CRNAME to return correct size
! when recordarrayelement in a record has a record as a subname
!
! m88p205f.i 3Mar 92 PDS
! changes to allow record alignment to go to pass4 on record assignment
%externalroutine ICL9CEZRS6IMP
%constinteger RELEASE=4
%include "hostcodes.inc"
!
%CONSTINTEGER HOST=mips
%CONSTINTEGER TARGET=MIPS
%CONSTINTEGER STANDARDPT=X'51'
%CONSTINTEGER MINAPT=X'51';             ! MINIMUM PTYPE FOR WHICH ARITHMETIC
                                        ! OPERATORS ARE AVAILABLE
%CONSTINTEGER MINAPREC=MINAPT>>4
%CONSTHALFINTEGERARRAY TYPEFLAG(0:12)=0,
                                        X'51'{%INTEGER},
                                        X'52'{%REAL},
                                        X'8009'{%LONG SOMETHING},
                                        X'4031'{%BYTE},
                                        X'35'{%STRING},
                                        X'6051'{%HALF->%INTEGER+WARNING},
                                        X'4041'{%SHORT},
                                        X'33'{%RECORD},
                                        0,
                                        X'61'{%LONG INTEGER FAULT},
                                        X'62'{%LONG REAL},
                                        X'72'{%LONGLONGREAL WARN};
!
! 2****15 SET FOR RELAY TO LOWER PART OF TYPEFLAGS
! 2****14 SET TO SKIP NEXT AR ENTRY FOR BYTE(INTEGER?) ETC
! 2****13 SET IF A DIFFERENT PRECISION USED GIVES WARNING
! 2****12 SET FOR COMBINATION WE CANT SUPPORT GIVES FAULT99
!
%CONSTBYTEINTEGERARRAY PTRSIZE(0:127)= %C
                                        8,0(15)                 {PREC=0},   
                                        0(16)                   {PREC=1},
                                        0(16)                   {PREC=2},
                                        8,4,0,4,0,8,0,4,0(8)    {PREC=3},
                                        8,4,0(14)               {PREC=4},
                                        8,4,4,0(13)             {PREC=5},
                                        8,0,4,0(13)             {PREC=6},
                                        8,0(15)                 {PREC=7};
%CONSTBYTEINTEGERARRAY PTRROUNDING(0:3*128-1)=%C
                  3(128)                {ALL PTRS IN RECORDS},
                  3(128)                {ALL PTRS IN STACK FRAMES},
                  3(128)                {ALL PTRS IN PARAMETERS};
%CONSTINTEGER SFRAMEMISALIGN=0;         ! NEEDED ONLY FOR 2900 WHERE PRECALL
                                        ! MISALIGNS STACK FRAMES !
%CONSTINTEGER AHEADPT=X'61';            ! PTYPE OF ARRAYHEAD WHEN USED AS SCALAR
%CONSTINTEGER AHEADSIZE=8;              ! SIZE OF ARRAY HEAD(BYTES)
%CONSTINTEGER MINPARAMSIZE=4;           ! MINIMUM STACKABLE PARAMETER(BYTES)
%CONSTINTEGER RTPARAMPT=X'51';          ! PTYPER OF RTPARAM WHEN USED AS SCALAR
%CONSTINTEGER RTPARAMSIZE=4;            ! SIZE OF RT PARAMETER (BYTES)
%CONSTINTEGER ARRAYROUNDING=7;          ! ALL ARRAYS TO 4 BYTE BNDR
%CONSTINTEGER ARRAYINRECROUNDING=0;     ! ARRAYS IN RECORDS TO 4 BYTE BOUNDARY
%CONSTINTEGER STRVALINWA=YES;           ! STRING VALUE PARAMETERS STACKED
%CONSTINTEGER STRRESINWA=YES;           ! STRING&RECORD FN RESULTS STACKED
%CONSTINTEGER RECVALINWA=NO;           ! Record values passed via work area
!
%CONSTBYTEINTEGERARRAY RNDING(0:3*128-1)= %C
                  {VALUES FOR SCALARS PTYPES 0->X'7F' IN SITUATIONS}
                  {FIRST SITUATION IS IN RECORDS}
                  {SECOND SITUATION IS IN STACK FRAMES}
                  {THIRD SITUATION IS AS PARAMETERS}

         0(16)                          {PREC=0},
         0(16)                          {PREC=1},
         0(16)                          {PREC=2},
         0(3),3,0,0,0(10)               {PREC=3},
         0,1,0(14)                      {PREC=4},
         0,3,3,0(13)                    {PREC=5},
         0,7,7,0(13)                    {PREC=6},
         0,7,7,0(13)                    {PREC=7},


         0(16)                          {PREC=0},
         0(16)                          {PREC=1},
         0(16)                          {PREC=2},
         0(3),3,0,1,0(10)               {PREC=3},
         0,1,0(14)                      {PREC=4},
         0,3,3,0(13)                    {PREC=5},
         0,7,7,0(13)                    {PREC=6},
         0,7,7,0(13)                    {PREC=7},


         0(16)                          {PREC=0},
         0(16)                          {PREC=1},
         0(16)                          {PREC=2},
         0,3,0,3,0,3,0(10)              {PREC=3},
         0,3,0(14)                      {PREC=4},
         0,3,3,0(13)                    {PREC=5},
        0,7,7,0(13)                     {PREC=6},   {for non-SPARC}
         {0,3,3,0(13)                   PREC=6,}    {for SPARC and RS6000}
         0,7,7,0(13)                    {PREC=7};

%CONSTBYTEINTEGERARRAY BYTES(0:7)=0(3),1,2,4,8,16;
%CONSTBYTEINTEGERARRAY WORDS(0:7)=0(3),1,1,2,4,8;
%CONSTINTEGER DAREA=6;                  ! SPECIAL DIAGS AREA ON PERQ
%CONSTINTEGER DVAREA=4;                 ! CONST DOPE VECTORS IN sst
%CONSTINTEGER LHSADDRFIRST=NO;          ! EVALUATE LHS ADDR BEFORE RHS ON ASSNMNT
%CONSTINTEGER JRNDBODIES=NO;            ! NO NEED TO JUMP ROUNT RT BODIES
%CONSTINTEGER STACK DOWN=YES
%CONSTINTEGER PARAMSBWARDS=NO;          ! YES FOR REVERSED PARAMETERS
%CONSTINTEGER DISPLAY NEEDED=YES;       ! DISPLAY NEEDED IN LOCAL SPACE
%CONSTINTEGER DISPLAY ROUNDING=7;      ! Display on D-W bndry
%CONSTINTEGER DISPLAY C1=4;             ! 4 bytes per routine level on RS6000
%CONSTINTEGER DISPLAY C0=4;             ! 4 for globals
%CONSTINTEGER RTPARAM1OFFSET=0;         ! OFFSET FROM LNB TO PARAM1
%CONSTINTEGER ALPHA=0;                  ! post parmeter linkage
!
! END OF CONCATENATED DEFINITIONS
!
!
! Recent Source Changes
!**********************
!
!*                                                                p205e.i
!* 06/12/91 - Changes (pds) to base dictionary size directly on workfile
!*              and/or MAXDICT. Source file size is poor indicator in view
!*              of many large includes.
!*
! Oct 89   Version 5
! Chnages (mostly in CRCALL) to pass record values via work area & pointer
! for risc chips. Controlled by const integer in steering file
!
! DEc88 Version 3 produced
! Changes to note included procedures for Gould and others
! Also change to allow LINT &LINTPT to compile when lonlongs are treated as longs
!
! 8May87 Changes in FPlist so that RT Parameters are aligned according
!        the rules of array Rnding
!
!
! Warning this module has the revised triples spec.
!
! In first attempt at Triple Imp considerable use was made of constant operands
! to pass information from Pass2 to GEN. Although for specialised operations%c
like
! passing Labels this still applies, this adhocery has caused problems with%c
arrays
! and pointers particularly in mapped records. The operands for four triples
! have thus been redefined in a more standard way.
!
! GETPTR    X1 is now (ptype of passed)<<16! DIMENSION
!           Opnd2 is either a 32 bit const with the size (ACC) as value or
!           the ptr or arrayhead as normal operand.
!
! VMY       X1 is now dim<<28!maxdim<<24!array name(where known)
!           Opnd2 is either a 32 bit const with DV offset into const area or
!           the arrayhead as a standard operand
!
! AINDX     X1 is ELSIZE<<20 !spare
!           Opnd2 is arrayhead as standard operand
!           NOTE:- The Operands have been swopped for consistency with norm.
!
! BADJ      X1 is arrayptype<<16!no of Dimensions (latter in case of backward%c
dvs)
!           Opnd2 exactly as for VMY
!

%include "impcompdate.inc"
   %const %integer MAXRECSIZE=x'ffff'
   %const %integer NO OF SNS=67
   %const %integer LRLPT=X'62'
!
   %const %integer MAXLEVELS=31,CONCOP=13
!
!
! FIRST THE OPERAND FLAG CONSTANTS
!
%CONSTINTEGER SCONST=0;                 ! CONST UPTO 64 BITS value is carried
                                        ! in opnd_d and opnd_xtra
%CONSTINTEGER LCONST=1;                 ! CONST LONGER THAN SCONST const can be
                                        ! found elsewhere(at top of ar) by
                                        ! meanse of base&offset inf in_d and _xtra
%CONSTINTEGER DNAME=2;                  ! NAME BY DICTIONARY NO the base and disp in
                                        ! the dictionary after adjusting by
                                        ! possible offset for item in
                                        ! in records lead to the variable
%CONSTINTEGER ARNAME=3;                 ! NAME BY AR POINTER opnd_d the ar pointer
                                        ! this form local to pass2
                                        ! and used to identify functions
                                        ! with params before the call
                                        ! is planted
%CONSTINTEGER VIAPTR=4;                 ! VIA TRIPLE WITHOFFSET TO POINTER
                                        ! At an offset(_xtra) from address in
                                        ! referenced triple can be found a
                                        ! pointer to the required operand
%CONSTINTEGER INDNAME=5;                ! INDIRECT VIA DICTIONARY base&disp
                                        ! in dictionary identify a pointer
                                        ! variable at possible offset from
                                        ! this pointer
%CONSTINTEGER INDIRECT=6;               ! INDIRECT VIA TRIPLE WITH OFFSET
                                        ! the refenced triple has computed
                                        ! the (32bit) address of an item
                                        ! an offset may have to be applied
                                        ! before the fetch or store
%CONSTINTEGER LOCALIR=7;                ! BASE DISP REF IN CURRENT STACK FRAME
                                        ! opnd_b=base<<16!offset used only for
                                        ! compiler generated temporaries
%CONSTINTEGER REFTRIP=8;                ! REFERENCE TO A TRIPLE the operand is the result of 
                                        ! triple opnd_d
%CONSTINTEGER INAREG=9;                 ! REGISTER OPERAND this form is local to the
                                        ! code generating pass(es)
%CONSTINTEGER developped=10;            ! also local to generator
%CONSTINTEGER DEVADDR=11;               ! ALSO LOCAL TO GENERATOR
%CONSTINTEGER BTREFMASK=1<<REFTRIP!1<<INDIRECT!1<<VIAPTR
%CONSTINTEGER REFER NEEDED=1<<INDIRECT!1<<VIAPTR
!
! NOW THE DEFINITIONS OF ONE OPERAND TRIPLES <128
!
%CONSTINTEGER RTHD=1;                   ! ROUTINE-BLOCK HEADING
%CONSTINTEGER RDSPY=2;                  ! ROUTINE ENTRY SET DISPLAY
%CONSTINTEGER RDAREA=3;                 ! ROUTINE LEAVE DIAGNOSTIC SPACE
%CONSTINTEGER RDPTR=4;                  ! SET DIAGNOSTIC POINTER
%CONSTINTEGER RTBAD=5;                  ! ROUTINE-FN BAD EXIT
%CONSTINTEGER RTXIT=6;                  ! "%RETURN"
%CONSTINTEGER XSTOP=7;                  ! EXECUTE "%STO"
%CONSTINTEGER NOTL=10;                  ! LOGICAL NOT
%CONSTINTEGER LNEG=11;                  ! LOGICAL NEGATE
%CONSTINTEGER IFLOAT=12;                ! CONVERT INTEGER TO REAL
%CONSTINTEGER MODULUS=13;               ! AS USED BY IMOD&RMOD
%CONSTINTEGER SHRTN=14;                 ! SHORTEN TO LOWER PRECISION
%CONSTINTEGER LNGTHN=15;                ! LENGTHEN TO HIGHER PRECISION
%CONSTINTEGER JAMSHRTN=16;              ! SHORTEN FOR JAM TRANSFER
%CONSTINTEGER NULLT=18;                 ! FOR REDUNDANT TRIPLES
%CONSTINTEGER PRELOAD=19;               ! PREFETCH FOR OPTIMISATION REASONS
%CONSTINTEGER SSPTR=21;                 ! STORE STACK POINTER
%CONSTINTEGER RSPTR=22;                 ! RESTORE STACK POINTER
%CONSTINTEGER ASPTR=23;                 ! ADVANCE STACK PTR
%CONSTINTEGER DARRAY=24;                ! DECLARE ARRAY(IE STORE HD)
%CONSTINTEGER SLINE=25;                 ! UPDATE LINE NO
%CONSTINTEGER STPCK=26;                 ! CHECK FOR ZERO STEPS
%CONSTINTEGER FORPRE=27;                ! PREAMBLE FOR "FOR"
%CONSTINTEGER FORPOST=28;               ! POSTAMBLE FOR "FOR"
%CONSTINTEGER FORPR2=29;                ! FOR SECOND PREAMBLE
%CONSTINTEGER PRECL=30;                 ! PREPARATION FOR CALL
%CONSTINTEGER RCALL=31;                 ! THE CALL
%CONSTINTEGER RCRFR=32;                 ! RECOVER FN RESULT
%CONSTINTEGER RCRMR=33;                 ! RECOVER MAP RESULT
%CONSTINTEGER GETAD=35;                 ! GET ADDRESS OF NAME
%CONSTINTEGER RTOI1=36;                 ! REAL TO INTEGER AS INT
%CONSTINTEGER RTOI2=37;                 ! REAL TO INTEGER INTPT
%CONSTINTEGER ITOS1=38;                 ! INTEGER TO STRING AS TOSTRING
%CONSTINTEGER MNITR=39;                 ! %MONITOR
%CONSTINTEGER PPROF=40;                 ! PRINT PROFILE
%CONSTINTEGER RTFP=41;                  ! TURN RT INTO FORMAL PARAMETER
%CONSTINTEGER ONEV1=42;                 ! ON EVENT 1 PRIOR TO TRAP
%CONSTINTEGER ONEV2=43;                 ! ON EVENT 2 AFTER TRAP
%CONSTINTEGER DVSTT=44;                 ! START OF DOPE VECTOR
%CONSTINTEGER DVEND=45;                 ! END OF DV EVALUATE TOTSIZE ETC
%CONSTINTEGER FOREND=46;                ! END OF FOR LOOP
%CONSTINTEGER DMASS=47;                 ! assign via bim warning to opt only
%CONSTINTEGER RTOI3=48;                 ! real to integer as TRUNC
!
! CODES FOR USER WRITTEN ASSEMBLER. NATURALLY THESE ARE NOT
! MACHINE INDEPENDENT
!
%CONSTINTEGER UCNOP=50;                 ! FOR CNOPS
%CONSTINTEGER UCB1=51;                  ! ONE BYTE OPERATIONS
%CONSTINTEGER UCB2=52;                  ! FOR 2 BYTE OPERATIONE
%CONSTINTEGER UCB3=53;                  ! FOR 3 BYTE OPERATIONS
%CONSTINTEGER UCW=54;                   ! FOR WORD OPERATIONS
%CONSTINTEGER UCBW=55;                  ! FOR OPC,BYTEWORD OPERATIONE
%CONSTINTEGER UCWW=56;                  ! FOR OPC,WORD,WORD OPERAIONS
%CONSTINTEGER UCLW=57;                  ! FOR LONGWORD OPERATIONS
%CONSTINTEGER UCB2W=58;                 ! FOR OPC,B1,B2,WORD OPERATIONS
%CONSTINTEGER UCNAM=59;                 ! FOR ACESS TO NAMES FROM ASSEMBLER
!
! NOW THE BINARY OPERATIONS
!
%CONSTINTEGER ADD=128;                  ! ADDITION
%CONSTINTEGER SUB=129;                  ! SUBTRACTION
%CONSTINTEGER NONEQ=130;                ! INTEGER NONEQUIVALENCE
%CONSTINTEGER ORL=131;                  ! LOGICAL OR
%CONSTINTEGER MULT=132;                 ! MULTIPLICATION
%CONSTINTEGER INTDIV=133;               ! INTEGER DIVISION
%CONSTINTEGER REALDIV=134;              ! REAL DIVISION
%CONSTINTEGER ANDL=135;                 ! LOGICAL AND
%CONSTINTEGER RSHIFT=136;               ! LOGICAL RIGHT SHIFT
%CONSTINTEGER LSHIFT=137;               ! LOGICAL LEFT SHIFT
%CONSTINTEGER REXP=138;                 ! REAL EXPONENTIATION
%CONSTINTEGER COMP=139;                 ! COMPARISONS
%CONSTINTEGER DCOMP=140;                ! FIRST PART OF DSIDED(NEEDED?)
%CONSTINTEGER VMY=141;                  ! VECTOR MULTIPLY
%CONSTINTEGER COMB=142;                 ! COMBINE (IE ADD OF LA) ON VMY RESULTS
%CONSTINTEGER VASS=143;                 ! VARAIABLE ASSIGN WITH CHECKING
%CONSTINTEGER VJASS=144;                ! VARIABLE JAMMED ASSIGN
%CONSTINTEGER IEXP=145;                 ! INTEGER EXPONENTIAITION
%CONSTINTEGER BADJ=146;                 ! BASE ADJUST ARRAY INDEX
%CONSTINTEGER AINDX=147;                ! INDEX ARRAY(COMBINE BS&IX)
%CONSTINTEGER IFETCH=148;               ! NO LONGER USED
%CONSTINTEGER LASS=149;                 ! ASSIGN LOCAL TEMPORARY
%CONSTINTEGER FORCK=150;                ! VALIDATE FOR
%CONSTINTEGER PRECC=151;                ! PRELIMINARY CONNCATENATION
%CONSTINTEGER CONCAT=152;               ! CONCATENATION
%CONSTINTEGER IOCPC=153;                ! CALL IOCP
%CONSTINTEGER PASS1=154;                ! PRIMARY PARAMETER ASSIGNMENT
%CONSTINTEGER PASS2=155;                ! PARAMETER PASSING POINTER PARAMS
%CONSTINTEGER PASS3=156;                ! PARAMETERPASSING ARRAY PARAMETERS
%CONSTINTEGER PASS4=157;                ! PASS A FORMAL PROCEDURE
%CONSTINTEGER PASS5=158;                ! PASS AN UNTYPE(%NAME) PARAMETER
%CONSTINTEGER PASS6=159;                ! PASS STRFN OR RECFN RESULT AREA
%CONSTINTEGER BJUMP=160;                ! BACKWARDS JUMPS
%CONSTINTEGER FJUMP=161;                ! FORWARD JUMPS
%CONSTINTEGER REMLB=162;                ! REMOVE LAB FROM LABELIST
                                        ! NEEDS TO BE TRIPLE IF COMBINED
                                        ! LABEL LIST IS USED
%CONSTINTEGER TLAB=163;                 ! TO ENTER A LABEL
%CONSTINTEGER DCLSW=164;                ! DECLARE A SWITCH ARRAY
%CONSTINTEGER SETSW=165;                ! SET A SWITCH TO "CA"
%CONSTINTEGER GOTOSW=166;               ! GO TO A SWITCH LABEL
%CONSTINTEGER STRASS1=167;              ! STRING GENERAL ASSIGNMET
%CONSTINTEGER STRASS2=168;              ! STRING FIXED LENGTH ASSNMENT
%CONSTINTEGER STRJT=169;                ! STRING JAM TRANSFER
%CONSTINTEGER AHASS=170;                ! ASSIGNMENT OF ARRAYHEADS
%CONSTINTEGER PTRAS=171;                ! ASSIGNMENT OF POINTERS
%CONSTINTEGER MAPRES=172;               ! ASSIGN MAPPING FN RESULT
%CONSTINTEGER FNRES=173;                ! ASSIGN FN RESULT
%CONSTINTEGER SCOMP=174;                ! STRING COMPARISON
%CONSTINTEGER SDCMP=175;                ! FIRST PART OF STRING D-SIDED
%CONSTINTEGER PRES1=176;                ! PRE RESOLUTION 1
%CONSTINTEGER PRES2=177;                ! PRE RESOLUTION 2
%CONSTINTEGER RESLN=178;                ! STRING RESOLUTION
%CONSTINTEGER RESFN=179;                ! RESOLUTION FINALE
%CONSTINTEGER SIGEV=180;                ! SIGNAL EVENT
%CONSTINTEGER RECASS=181;               ! WHOLE RECORD ASSIGNMENT
%CONSTINTEGER AAINC=182;                ! ARRAY ADDRESS ADJUST FOR
                                        ! RECORD RELATIVE TO ABSOLUTE
%CONSTINTEGER AHADJ=183;                ! MODIFY HEAD FOR MAPPING
%CONSTINTEGER CTGEN=184;                ! CREATE TYPE GENERAL PARAMETER
%CONSTINTEGER GETPTR=185;               ! POINTER FOR PASSING BY NAME
%CONSTINTEGER SINDX=186;                ! INDEX STRING IE CHARNO
                                        ! SAME AS AINDX FOR ALL TARGETS
                                        ! BUT PNX !
%CONSTINTEGER ZCOMP=187;                ! COMPARISONS WITH ZERO
                                        ! GENERATED BY OPTIMISER
%CONSTINTEGER CLSHIFT=188;              ! CONSTANT LOGICAL SHIFT
                                        ! GENERATED BY OPTIMISER
%CONSTINTEGER CASHIFT=189;              ! CONSTANT ARITHMETIC SHIFT
                                        ! GENERATED BYOPTIMISER
%CONSTINTEGER DVBPR=190;                ! GENERATE DV ENTRY FOR BOUND PAIR
%CONSTINTEGER RSTORE=191;               ! REGISTER TO STORE OPERATION
%CONSTINTEGER MULTX=192;                ! MULTIPLY AND EXTEND PRECISION
!
! RECORDFORMAT FOR ALL THE OPTION AND FLAG VARAIBLES
!
! amended to remove non-alined longreal prior to bootstrapping to gould
!
%RECORDFORMAT PARMF(%INTEGER BITS1,BITS2,TTOPUT,
      %BYTEINTEGER LET,DYNAMIC,LINE,TRACE,ARR,DBUG,CHK,DIAG,OPT,FREE,
      LIST,CPRMODE,COMPILER,Z,Y,PROF,INHCODE,DCOMP,FAULTY,X,STACK,MAP,QUOTES,S2,
      %INTEGER LPOPUT,SP0)
%RECORDFORMAT LEVELF(%INTEGER RBASE, DIAGINF, RAL, FLAG, L, M, NMDECS, ONWORD, ONINF,
         LABEL, JROUND, UNATT FORMATS, PSIZE, ENTRYAD, DISPLAY, AUXSBASE, 
         NAMES, SNMAX,SN,RESSIZE,CLEVEL,SET, iblkid, EXITLAB, CONTLAB, S3,
       %INTEGERARRAY AVL WSP(0:4))

%IF 1<<host&unsignedshorts=0 %START
%RECORDFORMAT RD((%INTEGER S1 %OR %SHORT PTYPE,%BYTE XB,FLAG),
      ((%INTEGER D %OR %REAL R),
      %INTEGER XTRA %OR %SHORT H0,H1,H2,H3 %OR %BYTE B0,B1,B2,B3,B4,B5,B6,B7))
%RECORDFORMAT TAGF((%SHORTINTEGER PTYPE,UIOJ,SNDISP,ACC,SLINK,KFORM %OR %C
      %INTEGER S1,S2,S3),%INTEGER LINK)
%RECORDFORMAT TRIPF(%BYTE OPERN,OPTYPE,CNT,DPTH,
      %SHORTINTEGER FLAGS,PUSE,FLINK,BLINK,%INTEGER X1,
      %RECORD(RD) OPND1,OPND2)
%RECORDFORMAT LISTF((%SHORTINTEGER PTYPE,(%SHORT UIOJ %OR %BYTE XB,FLAG),
      %SHORT SNDISP,ACC,SLINK,KFORM %OR  %INTEGER S1,S2,S3),%INTEGER LINK)
%FINISH %ELSE %START
%RECORDFORMAT RD((%INTEGER S1 %OR %HALF PTYPE,%BYTE XB,FLAG),
      ((%INTEGER D %OR %REAL R),
      %INTEGER XTRA %OR %HALF H0,H1,H2,H3 %OR %BYTE B0,B1,B2,B3,B4,B5,B6,B7))
%RECORDFORMAT TAGF((%HALFINTEGER PTYPE,UIOJ,SNDISP,ACC,SLINK,KFORM %OR %C
      %INTEGER S1,S2,S3),%INTEGER LINK)
%RECORDFORMAT TRIPF(%BYTE OPERN,OPTYPE,CNT,DPTH,
      %HALFINTEGER FLAGS,PUSE,FLINK,BLINK,%INTEGER X1,
      %RECORD(RD) OPND1,OPND2)
%RECORDFORMAT LISTF((%HALFINTEGER PTYPE,(%HALF UIOJ %OR %BYTE XB,FLAG),
      %HALF SNDISP,ACC,SLINK,KFORM %OR  %INTEGER S1,S2,S3),%INTEGER LINK)
%FINISH
%RECORDFORMAT WORKAF(%INTEGER NNAMES,CCSIZE,DSIZE,ASL MAX,ASL CUR BTM,CONST PTR,
      CONST BTM,LASTTRIP,WKFILEAD,WKFILEK,FILE ADDR,RELEASE,AASL0,CONST LIMIT,
      RTCOUNT,ARTOP,AMAINEP,DICTBASE,OPTCNT,INCLHEAD,S2,S3,S4,
      %INTEGERNAME LINE,N,S5,%STRING(9)LADATE,
      %BYTEINTEGERARRAYNAME CC,A,LETT,
      %INTEGERARRAYNAME WORD,TAGS,CTABLE,
      %RECORD(LEVELF)%ARRAYNAME LEVELINF,
      %INTEGERARRAY PLABS,PLINK(0:31),
      %RECORD(LISTF)%ARRAYNAME ASLIST)
!
! TRIPF_FLAGS SIGNIFY AS FOLLOWS
%CONSTINTEGER LEAVE STACKED=2****0;     ! SET LEAVE RESULT IN ESTACK
%CONSTINTEGER LOADOP1=2****1;           ! OPERAND 1 NEEDS LOADING
%CONSTINTEGER LOADOP2=2****2;           ! OPERAND 2 NEEDS LOADING
%CONSTINTEGER NOTINREG=2****3;          ! PREVENT REG OPTIMISNG
                                        ! OF TEMPS OVER LOOPS&JUMPS
%CONSTINTEGER USE ESTACK=2****4;        ! KEEP DUPLICATE IN ESTACK
%CONSTINTEGER USE MSTACK=2****5;        ! PUT DUPLICAT ON MSTACK
%CONSTINTEGER CONSTANTOP=2****6;        ! ONE OPERAND IS CONSTANT(FOR FOLDING)
%CONSTINTEGER COMMUTABLE=2****7;        ! OPERATION IS COMMUTABLE
%CONSTINTEGER BSTRUCT=2****12;          ! Proc contains inner blks or RTs
%CONSTINTEGER USED LATE=2****13;        ! I-RESULT USED AFTER LAB OR A LONG WAY AHEAD
%CONSTINTEGER ASS LEVEL=2****14;        ! ASSEMBLER LEVEL OPERATION
%CONSTINTEGER DONT OPT=2****15;         ! DONT DUPLICATE THIS RESULT
                                        ! USED FOR BYTE PTR & OTHER SODS!
!
%RECORDFORMAT EMASFHDRF(%INTEGER ENDRA,STARTRA,FBYTESIZE,W3,W4,W5,W6,W7)
                                        ! FORMAT FOR ARRAY HEADS
! %END %OF  %FILE "ERCC07.TRIMP_TFORM1S"
   %const %integer SNPT=X'1006';         ! SPECIALNAME PTYPE
   %const %integer UNASSPAT=X'80808080'
   %const %integer LABUSEDBIT=X'01000000'
   %const %integer LABSETBIT=X'02000000'
   %const %integer MAXDICT=X'100';       ! PARM MAXDICT BIT
!
   %integer I,K,DUMMYFORMAT,P1SIZE,STARSIZE,ASL,ARSIZE,OLDLINE,NEXTP,SNUM,
      RLEVEL,NMAX,PLABEL,LEVEL,PROFAAD,LAST INST,LINE,N,BFFLAG,RBASE,Q,R,
      FNAME,STMTS,FILE SIZE,BIMSTR,MAX ULAB,SFLABEL,NEXTTRIP
   %integer %name SSTL,USTPTR
   %integer curlinead,nextlinead,currentSSalt
   %string (31) MAINEP
!
   %external %integer %array CAS(0:12)
   %external %record (PARMF) PARM
   %external %record (WORKAF) WORKA
   %if HOST=IBM %or HOST=AMDAHL %or HOST=IBMXA %or HOST=Vax %start
      %external %integer %map %spec COMREG %alias "s#comregmap"(%integer N)
   %finish %else %if HOST=Gould%or Host=M88k %or Host=RS6 %or Host=MIPS  %then %Start
      %externalintegermapspec COMREG  (%integer N)
   %else
      %external %integer %map %spec COMREG %alias "s#comreg"(%integer N)
   %finish
   %const %integer BYTESPERKFORSOURCE=256;  ! FRACTION OF KB IN WK FILE
                                         ! THATS IS ALLOCATE FOR SOURCE (&LPUT)
   %begin
      %record (EMASFHDRF) %name SHDR,WHDR
      worka = 0
      WORKA_FILE ADDR = COMREG(46);      ! SOURCE FILE IF CLEAN
      PARM = 0
      PARM_BITS1 = COMREG(27)
      PARM_BITS2 = COMREG(28)! MAXDICT
      PARM_TTOPUT = COMREG(40)
      PARM_LPOPUT = COMREG(23)
      WORKA_WKFILEAD = COMREG(14)
      COMREG(24) = 16;                   ! failure as return code
      WHDR == RECORD(WORKA_WKFILEAD)
      WORKA_WKFILEK = WHDR_FBYTESIZE>>10
      %if WORKA_FILE ADDR<=0 %then %start
         %if WORKA_FILE ADDR<-1 %then FILESIZE = IMOD(WORKA_FILE ADDR) %else %c
            FILESIZE = 64000
         WORKA_FILE ADDR = 0
      %finish %else %start
         SHDR == RECORD(WORKA_FILE ADDR)
         FILE SIZE = SHDR_ENDRA
      %finish
!
! Derive nnames form workfile K ignoring source size because of includes
!
! Note if nnames goes over 4095 the linking of arrayname parameters
! in sw(11) goes wong as their are only 12 bits left intags_uioj
! this is an absolute limit unless pds in prepared to be very ingenious
!

      WORKA_NNAMES = 1023
      %if WORKA_WKFILEK>513 %then WORKA_NNAMES=2047
     %if WORKA_WKFILEK>1000 %or PARM_BITS2&MAXDICT#0  %then WORKA_NNAMES = 4095
      ASL = 3*WORKA_NNAMES
!      %if ASL>4095 %and (HOST#EMAS %or PARM_BITS2&MAXDICT=0) %then ASL = 4095
      WORKA_ASL MAX = ASL
      ARSIZE = WORKA_WKFILEK*(1024-BYTESPERKFORSOURCE)-300
   %end
   %byte %integer %array %format AF(0:ARSIZE)
   %byte %integer %array %name A
   %record (LISTF) %array ASLIST(0:ASL)
   %integer %array TAGS(0:WORKA_NNAMES)
   %integer %array WORD(0:WORKA_NNAMES)
   %integer %array DVHEADS(0:12)
   %record (LEVELF) %array LEVELINF(0:MAXLEVELS)
  %record%format swdataform(%integer lseen,default,%integerarray slabs(0:1023))
   %externalroutinespec free(%integer ad)
   %externalintegerfnspec malloc(%integer space)
   %external %routine %spec INITASL(%record (LISTF) %array %name A,
      %integer %name B)
 %externalroutinespec printtrips(%record(tripf)%arrayname trops)
 %externalroutinespec phex (%integer val)
   %external %integer %fn %spec MORE SPACE
!%externalintegerfnspec NEWCELL
   %external %routine %spec INSERTATEND(%integer %name S, %integer A,B,C)
   %external %routine %spec INSERT AFTER(%integer %name S, %integer A,B,C)
   %external %routine %spec POP(%integer %name C,P,Q,R)
   %external %routine %spec PUSH(%integer %name C, %integer S1,S2,S3)
   %external %integer %fn %spec FIND(%integer LAB,LIST)
   %external %routine %spec BINSERT(%integer %name T,B, %integer S1,S2,S3)
   %external %routine %spec CLEARLIST(%integer %name HEAD)
   %external %routine %spec FILL DTABREFS(%integer %name HEAD)
   %external %routine %spec CXREF(%string (255) NAME, %integer MODE,XTRA,
      %integer %name AT)
   %external %routine %spec IMPABORT
   %external %routine %spec PROLOGUE(%record (LISTF) %array %name ALIST)
   %external %routine %spec EPILOGUE(%integer STMTS)
   %external %routine %spec PDATA(%integer AREA,BNDRY,L,AD)
   %external %routine %spec PRDATA(%integer AREA,BNDRY,L,REP,AD)
   %external %integer %fn %spec PINITOWN(%integer PTYPE,ACC,
      %record (RD) %name INIT, %string %name XNAME)
   %external %integer %fn %spec POWNARRAYHEAD(%integer PTYPE,J,LB,SIZE,
      AOFFSET,AAREA,DVOFFSET, %string (31) XNAME)
   %external %routine %spec FAULT(%integer A,B,C)
   %external %routine %spec WARN(%integer N,V)
   %external %routine %spec TRIP OPT(%record (TRIPF) %array %name T,
      %integer  first TRIP)
   %external %routine %spec MOVE BYTES(%integer LENGTH,FBASE,FOFF,TOBASE,TOOFF)
   %external %routine %spec CTOP(%integer %name OP,MASK, %integer XTRA,
      %record (RD) %name OPND1,OPND2)
   %if HOST#TARGET %start
      %external %routine %spec REFORMATC(%record (RD) %name OPND)
      %external %routine %spec CHANGE SEX(%integer BASEAD,OFFSET,L)
   %finish
   %external %routine %spec GENERATE(%record (TRIPF) %array %name T,
      %integer CURRLEVEL, %routine GETWSP(%integer %name PL, %integer SIZE))
%externalstringfnspec printname (%integer jj)
   %external %routine %spec PRINTLIST(%integer HEAD)
                                         ! START OF COMPILATION
   K = host//10
      %if k=0 %then k=1
   K = BYTESPERKFORSOURCE//K;             ! DISTINGUISH BYTE&WORD ADDRESSED%c
                                         HOSTS
                                         ! ALLOW FOR BYTE & WORD ADDRESS M-CS
   A == ARRAY(WORKA_WKFILE AD+K*WORKA_WKFILEK,AF)
   %begin
!***********************************************************************
!*       THIS BLOCK INITIALISE THE COMPILER SCALARS AND ARRAYS         *
!*       WAS ORIGINALLY ROUTINE 'INITIALISE'.                          *
!*       THE INITIALISATION OF THE CONSTANT LISTS WITH THE VALUES      *
!*       IN PERM MAY BE OMITTED IN BATCH OR CUT-DOWN VERSIONS.         *
!***********************************************************************
      %external %integer %fn %spec PASSONE
      WORKA_CCSIZE = BYTESPERKFORSOURCE*(WORKA_WKFILEK-1);  ! CCSIZE ALWAYS AS%c
                                                            BYTES
      %byte %integer %array %format CCF(0:WORKA_CCSIZE)
      %byte %integer %array %name CC
      CC == ARRAY(WORKA_WKFILEAD+32,CCF)
      WORKA_CC == CC
      WORKA_A == A
      WORKA_WORD == WORD
      WORKA_TAGS == TAGS
      WORKA_LINE == LINE
      WORKA_N == N
      WORKA_RELEASE = RELEASE
      WORKA_LADATE = LADATE
      WORKA_AASL0 = ADDR(ASLIST(0))
      WORKA_AMAINEP = ADDR(MAINEP)
      WORKA_LASTTRIP = WORKA_CCSIZE//40-2;  ! 40 IS SIZE OF THE TRIP ARRAY
      %if WORKA_LASTTRIP>699 %then WORKA_LASTTRIP = 699
      WORKA_OPTCNT = 0;                  ! ZERO COUNT OF OPTIMISATIONS
      worka_const ptr=1;                ! leaving zero for dont knows
      WORKA_ASLIST == ASLIST
      PLABEL = 24999
      N = 12;
      MAX ULAB = WORKA_NNAMES+16384;     ! LARGEST VALID USER LABEL
      LAST INST = 0
      SFLABEL = 20999
      RLEVEL = 0; NMAX = 0; BFFLAG = 0
      RBASE = 1
      SSTL == CAS(4); USTPTR == CAS(5)
      STMTS = 1; SNUM = 0
      BIMSTR = 0
      WORKA_RTCOUNT = 1;                 ! ROUTINE 0 RESERVED FOR MAIN PROG
      MAINEP = "s#go";                   ! DEFAULT MAIN ENTRY
      INITASL(ASLIST,ASL)
      %cycle I = 0,1,12
         CAS(I) = 0; DVHEADS(I) = 0
      %repeat
!
      DUMMY FORMAT = 0;                  ! DUMMY RECORD FORMAT
      PUSH(DUMMY FORMAT,0,0,0);          ! FOR BETTER ERROR RECOVERY
      P1SIZE = PASSONE
      R = P1SIZE
      WORKA_ARTOP = P1SIZE
   %end;                                 ! OF BLOCK CONTAINING PASS 1
   %if PARM_FAULTY#0 %start
      COMREG(24) = 8
      COMREG(47) = PARM_FAULTY
      %return
   %finish
   %begin
!***********************************************************************
!*    SECOND OR TRIPLES GENERATING PASS                                *
!***********************************************************************
      %record (LEVELF) %name CURRINF
      %integer TWSPHEAD,FORCNT,FORDPTH,FORCECNT,internalblockid
      %if HOST=EMAS %or HOST=IBM %or HOST=AMDAHL %or HOST=IBMXA %start
                                         ! LPUT BASED WORKFILE USED FOR OBJECT
         %record (TRIPF) %array TRIPLES(0:WORKA_LASTTRIP)
      %finish %else %start
         %record (TRIPF) %array %format TRIPLESFORM(0:WORKA_LASTTRIP)
         %record (TRIPF) %array %name TRIPLES
         TRIPLES == ARRAY(WORKA_WKFILEAD+32,TRIPLESFORM)
      %finish
      %integer %array %format CF(0:12*WORKA_NNAMES)
      %integer %array %name CTABLE
!%routinespec NOTE CREF(%integer CA)
!%routinespec STORE CONST(%integername D,%integer L,AD)
!%integerfnspec WORD CONST(%integer VALUE)
      %routine %spec REUSE TEMPS
      %routine %spec GET WSP(%integer %name PLACE, %integer SIZE)
      %routine %spec RETURN WSP(%integer PLACE,SIZE)
      %routine %spec COMPILE A STMNT
      %routine %spec outsym(%integer sym)
      %routinespec force line
      %routine %spec outstring(%string(255) str)
      %routinespec outint(%integer id)
      %integer %fn %spec NEW TRIP
      %integer %fn %spec FROMAR4(%integer PTR)
      %integer %fn %spec FROMAR2(%integer PTR)
      %integer %fn %spec UCONSTTRIP(%integer OPERN,OPTYPE,FLAGS,CONST)
      %integer %fn %spec ULCONSTTRIP(%integer OPERN,OPTYPE,FLAGS,CONST1,CONST2)
      %integer %fn %spec UNAMETRIP(%integer OPERN,OPTYPE,FLAGS,NAME)
      %integer %fn %spec UTEMPTRIP(%integer OPERN,OPTYPE,FLAGS,TEMP)
      %integer %fn %spec BRECTRIP(%integer OPERN,OPTYPE,FLAGS,
         %record (RD) %name OPND1,OPND2)
      %integer %fn %spec URECTRIP(%integer OPERN,OPTYPE,FLAG,
         %record (RD) %name OPND1)
      %routine %spec KEEPUSECOUNT(%record (RD) %name OPND)
      %routine %spec CSS(%integer P)
       %recordformat outform(%integer line,length,lastnl,prevlast,%bytearrayname l)
      %ownbyteintegerarray lspace(0:128*1024)
      %ownrecord(outform) opline
      %constinteger breakoplines=99

      opline=0
      opline_l==lspace
      %cycle I = 0,1,MAXLEVELS
         LEVELINF(I) = 0
         LEVELINF(I)_NAMES = -1
      %repeat
      CTABLE == ARRAY(ADDR(ASLIST(1)),CF)
      WORKA_CTABLE == CTABLE
      WORKA_LEVELINF == LEVELINF
      CTABLE(0) = M'CTAB'
      TWSPHEAD = 0
      FORCNT = 0;                        ! COUNTS FORS TO DETECT NESTING
      FORDPTH = 0;                       ! COUNTS DEPTH OF NESTED FORS
      FORCECNT = 0;                      ! UPDATED WHEN TRIPLES FORCED OUT
                                         ! KEPT SO THAT GLAENING IS POSSIBLE
      internalblockid=0
      PROLOGUE(ASLIST)
      LINE = 0
      NEXTTRIP = 1
      TRIPLES(0) = 0
      NEXTP = 1; LEVEL = 1; STMTS = 0
      CURRINF == LEVELINF(LEVEL)
      RLEVEL = 0; RBASE = 0
      CURRINF = 0
      CURRINF_CLEVEL = LEVEL
      CURRINF_NAMES = -1
!      %if target=gould %then currinf_maxpp = 8;  ! max parameters passed
      %while A(NEXTP+3)!A(NEXTP+4)#0 %cycle
         COMPILE A STMNT
      %repeat
      outsym(NL)
      outstring("/* end of automatic translation */")
      outsym(NL)
      force line
      LINE = 99999
      EPILOGUE(STMTS)

      %if PARM_FAULTY#0 %start
         COMREG(24) = 8
         STMTS = PARM_FAULTY
      %else
         COMREG(24) = 0
      %finish
      COMREG(47) = STMTS
      %if HOST=PERQ %start
         *RETURN;                        ! JUMP WONT REACH!
      %finish %else ->P2END
%integerfn insert curly(%integer cad,at)
!***********************************************************************
!*  Adds in a curly bracket comment                                    *
!*  Checks for the case of a C macro (Ist char #) %and reinserts       *
!*  The 'comment' unchanged                                            *
!***********************************************************************
%integer i,j,k,scount,res
%ownbytearray save (1:64*1024)
      scount=0
      %if at >opline_length %then at=opline_length { should not happen }
      %for i=at,1,opline_length-1 %cycle
          scount=scount+1
          save(scount)=opline_l(i)
      %repeat
      opline_length=at

      %if byteinteger(curlinead)#'#' { C macro } %start
         outsym(9)            { Tab }
         outstring("/*")
      %else
         outsym('{')
      %finish
      j=cad
      i=0
      %cycle
         j=j+1; i=i+1
         %if byteinteger(j)=NL %or byteinteger(j)='}' %start
            %if byteinteger(curlinead)#'#' { C macro } %start
               outstring("*/")
            %else
               %if byteinteger(j)='}' %then outsym('}')
            %finish
            res=i+1
            %exit
          %else
             opline_l(opline_length)=byteinteger(j)
             opline_length=opline_length+1
          %finish
        %repeat
      %for i=1,1,scount %cycle
        opline_l(opline_length)=save(i)
        opline_length=opline_length+1
      %repeat
      %result=res
%end
%integerfn locate curly(%integer cad)
!***********************************************************************
!* Try to find where to insert a curly comment by counting commas      *
!***********************************************************************
%integer ccount,firstc,i,bcount,commaafter
      ccount=0; bcount=0; commaafter=0
!
! first check if there is a comma after the curly comment
!
     i=cad
     i=i+1 %until byteinteger(i)='}' %or byteinteger(i)=NL
     %if byteinteger(i)='}' %start
        i=i+1
        i=i+1 %while byteinteger(i)=' '
        %if byteinteger(i)=',' %then commaafter=1 %and ccount=1
     %finish
      %for i=cad,-1,curlinead %cycle
         %if byteinteger(i)=',' %start
            %if ccount=0 %then firstc=i
            ccount=ccount+1
         %finish
      %repeat
      %if ccount=0 %then %result=opline_length
      %if commaafter=0 %start
         %for i=firstc,1,cad-1 %cycle
             %if 33<=byteinteger(i)<=127 %then bcount=bcount+1
             %if byteinteger(i)='{' %or byteinteger(i)='}' %then bcount=bcount+1
         %repeat
      %finish
      %for i=0,1,opline_length %cycle
         %if opline_l(i)=',' %or opline_l(i)=';' %start
            ccount=ccount-1
            %if ccount=0 %then -> next
         %finish
      %repeat
      %result=opline_length
next:
!printstring("locate "); write(commaafter,1); write(bcount,0)
!     write(opline_l(i),4);  write(opline_l(i+1),4); newline
      %if commaafter#0 %then %result=i
      %if bcount=0 %then %result=i+1
      %for i=i,1,opline_length %cycle
        %if 33<=opline_l(i)<=127 %then bcount=bcount-1
        %if bcount=0 %then %start
            i=i+1 %while i<opline_length-1 %andc
               ('a'<=opline_l(i+1)<='z' %or 'A'<=opline_l(i+1)<='Z' %orc
                 '0'<=opline_l(i+1)<='9' %or opline_l(i+1)='_') %andc
               ('a'<=opline_l(i)<='z' %or 'A'<=opline_l(i)<='Z' %orc
                 '0'<=opline_l(i)<='9' %or opline_l(i)='_')
            %if opline_l(i+1)='*' %and opline_l(i)='/' %then i=i-1
            %if opline_l(i+1)='/'  %and opline_l(i)='*' %then i=i+1
             %if opline_l(i+1)='*' %and opline_l(i+2)='/' %then i=i+2
!printstring("locate2 ");     write(opline_l(i),4);  write(opline_l(i+1),4); newline
            %result=i+1
        %finish
      %repeat
      %result=opline_length
%end
%routine curly check(%integer mode)
%owninteger last linead
%integer i,at

!printstring("checking curly"); write(nextlinead,6); write(curlinead,6)
!write(last linead,6); printsymbol(byteinteger(curlinead));
!printsymbol(byteinteger(curlinead+1)); printsymbol(byteinteger(curlinead+2)); 
!printsymbol(byteinteger(curlinead+3)); printsymbol(byteinteger(curlinead+4));newline
!         %if nextlinead=curlinead %start
!           i=curlinead
!           i=i+1 %while byteinteger(i)=' '
!           %if byteinteger(i)='{' %then warn(12,0)
!        %finish
         %if nextlinead>curlinead %and curlinead#last linead  %c
           %and nextlinead-curlinead <=2047 %start
            %for i=curlinead,1,nextlinead-1 %cycle
               %if byteinteger(i)='{' %then %start
                 at=locate curly(i)
                 i=i+insert curly(i,at)
!                 %if mode=1 %then warn(12,0)
               %finish
            %repeat
           last linead=curlinead     { avoid multiple copies of curlies }
         %finish
%end
!*
%routine force line
!***********************************************************************
!*   Push out current line after dealing with any missed or            *
!*   faulty lines and merging back any {} comments                     *
!***********************************************************************
%integer i,at
%externalintegerspec filesseen
      %if filesseen=0 %or line <20000 %start { omit include ifiles if any }
!printstring("Force line"); write(nextlinead,5); write(curlinead,5); write(lastlinead,5); newline
!      %for i=curlinead,1,nextlinead %cycle
!          printsymbol(byteinteger(i))
!      %repeat
!      newline
!      %for i=0,1,opline_length-1 %cycle
!           printsymbol(opline_l(i))
!      %repeat
!     newline
!        printstring("  end of force line daignostics"); newline
         curlycheck(0)
         %return %if opline_length=0
         %for i=0,1,opline_length-1 %cycle
            print symbol(opline_l(i))
         %repeat
         newline
      %finish
      i=opline_length-1
      i=i-1 %while I>0 %and (opline_l(i)='}' %or opline_l(i)=NL )
	%if i>=0 %then opline_prevlast=opline_l(i)
      opline_length=0
      opline_lastnl=-1
%end
%routine outsym(%integer sym)
      %if sym=NL %then opline_lastnl=opline_length
      opline_l(opline_length)=sym
      opline_length=opline_length+1
      %if currentSSalt=12{Const integers and constlists } %and sym=',' %c
         %and opline_length-opline_lastnl > breakoplines>>1 %start
         outsym(NL); %return
      %finish
      %if opline_length-opline_lastnl > breakoplines %start
         %if opline_l(opline_lastnl+1)#'#' %start
            %if sym=' ' %or sym=',' %or sym=')' %then outsym(NL)
         %finish
      %finish
%end {outsym}
!*
%routine outsep
!***********************************************************************
!*    Outputs a semicolon avoiding obvious duplicates                  *
!***********************************************************************
%integer i
      i=opline_length-1
      %while i>=0 %and %c
         (opline_l(i)=NL %or opline_l(i)='}') %cycle
         i=i-1
      %repeat
!      printstring("Outsep i,l(i),prev="); write(i,1); space
!      printsymbol(opline_l(i))%if i>=0
!      space; printsymbol(opline_prevlast); newline
      %if i>=0 %and opline_l(i)=';' %then %return
      %if i<0 %and opline_prevlast=';' %then %return
      outsym(';')
%end {outsep}
!*
%routine outstring(%string(255) s)
%integer i,j,sym
      j=opline_length
      %for i=1,1,length(s) %cycle
         sym=charno(s,i)
         %if sym=NL %then %start
            opline_l(j)='\'; opline_l(j+1)='n'; j=j+2
         %finish %else %if sym='"' %start
            opline_l(j)='\'; opline_l(j+1)='"'; j=j+2
         %else
            opline_l(j)=sym
            j=j+1
         %finish
      %repeat
      opline_length=j
%end
%routine outcommentend
      %if opline_l(opline_length-1)#'*' %start
         outsym(' ') %while opline_length-opline_lastnl <78
      %finish
      outstring("*/")
%end
%string(255)%fn validname(%string(255) name)
!***********************************************************************
!* Check name is not a C reserved word. If so amaned it                *
!***********************************************************************
%constinteger nr=34
%conststring(11)%array rnames(0:nr)="sizeof","auto","static","extern","register",
                                    "typedef","char","short","long","int",
                                    "unsigned","float","double","void","enum",
                                    "struct","union","if","else","while",
                                    "do","for","switch","case","default",
                                    "break","continue","return","goto","abs",
                                    "fabs","volatile","asm","const","signed";
%integer i
      %for i=0,1,nr %cycle
         %if name=rnames(i) %then %start
            charno(name,1)=charno(name,1)-32
            %result=name
         %finish
      %repeat
      %result=name
%end
!*
%routine revisename(%string(255)%name name)
%integer i
     %{if parm_quotes#0 %then} %return
     %for i=1,1,length(name) %cycle
        %if 'a'<=charno(name,i)<='z' %then charno(name,i)=charno(name,i)-32
     %repeat
%end
!*
%routine outname(%integer id)
!***********************************************************************
!*    produce name text from an id                                     *
!***********************************************************************
%integer i,ad
%record(listf)%name lcell
%string(255) name
      i=worka_word(id)
      ad=addr(worka_lett(i))
      name=string(ad)
      lcell==aslist(worka_tags(id))
      %if lcell_ptype&x'ff00'=x'4000' %and lcell_uioj&x'f0'=0 %c
         %then revisename(name)
      name=validname(name) %unless lcell_ptype=x'156'   { Dont revise switches CmcP }
      outstring(name)
      %if opline_length-opline_lastnl > breakoplines %start
         %if opline_l(opline_lastnl+1)#'#' %then outsym(NL)
      %finish
%end
!*
%routine outswadname(%integer id)
!***********************************************************************
!*   output a sw name adjusting it if in an inner block
!***********************************************************************
%integer i,ad
%record(listf)%name lcell
%string(255) name
      i=worka_word(id)
      ad=addr(worka_lett(i))
      name=string(ad)
      lcell==aslist(worka_tags(id))
      %if lcell_ptype&x'ff00'=x'4000' %and lcell_uioj&x'f0'=0 %c
         %then revisename(name)
      outstring(name)
      %if currinf_iblkid>0 %start
         outsym('_'); outint(currinf_iblkid)
      %finish
%end

%integerfn possible typename(%integer id,%stringname typename)
!***********************************************************************
!*   if id ends in "...type" set typename to ..._type                  *
!***********************************************************************
%integer i,ad,j
%string(255) name,firstpart,s,t
      i=worka_word(id)
      ad=addr(worka_lett(i))
      name=string(ad)
      j=0;
      %while name -> s.("type").name %cycle
         %if j=0 %then firstpart=s %else firstpart=firstpart."type".s
        j=j+1
      %repeat
      %if name="" %and length(firstpart)>3 %start      { ended in ...type }
         typename=firstpart."_type"
         %result=1
      %else
         typename="not_a_valid_type_name"
         %result=0
      %finish
%end

%routine outrevisablename(%integer id)
!***********************************************************************
!*    produce name text from an id  and revise without tag check       *
!***********************************************************************
%integer i,ad
%string(255) name
      i=worka_word(id)
      ad=addr(worka_lett(i))
      name=string(ad)
      revisename(name)
      outstring(validname(name))
      %if opline_length-opline_lastnl > breakoplines %start
         %if opline_l(opline_lastnl+1)#'#' %then outsym(NL)
      %finish
%end
!*
%routine out formatname(%integer kf)
%integer i,kk
%record(listf)%name lcell
%string(255) s
      %for i=0,1,worka_nnames %cycle
         kk=tags(i)
         %if kk#0 %start
            lcell==aslist(kk)
            %if lcell_ptype&15=4 %and lcell_kform=kf %start
               %if possible typename(i,s)>0 %start
                  outstring(s)
               %else
                  %if lcell_ptype=4 %then outstring("struct ") %else outstring("union ")
                  outname(i)
               %finish
               %return
            %finish
         %finish
       %repeat
       outstring(" ? unknown format name ?")
!      %monitor
%end
!*
!*
%routine out extern(%integer extern)
      %if extern&3=0 %start
         outstring("static const ")
      %finish %else %if extern=1 %start
        outstring("static ")
      %finish %else %if extern=3 %start
        outstring("extern ")
      %finish
%end
%routine outtype(%integer type,kf)
      %if type=x'31' %start
         outstring("unsigned char ")
      %finish %else %if type=x'41' %start
         outstring("short int ")
      %finish %else %if type=x'51' %start
         outstring("int ")
      %finish %else %if type=x'61' %start
         outstring("INT64 ")
      %finish %else %if type=x'52' %start
         outstring("float ")
      %finish %else %if type=x'62' %start
         outstring("double ")
      %finish %else %if type=x'72' %start
         outstring("long double ")
      %finish %else %if type=x'35'  %start
          outstring("char * ")
      %finish %else %if type=x'33' %start
          outformatname(kf)
         outsym(' ')
      %else
         outstring("void ")
      %finish
%end {outtype }
!*
%routine outxtype(%integer xtype,kf)
%integer rout,nam,arr,type
       rout=xtype>>12&1
       nam=xtype>>10&3
       arr=xtype>>8&3
       type=xtype&7
       outtype(xtype&255,kf)
       %if (rout#0 %or arr#0 %or nam&1#0) %and type#5 %then outsym('*')
%end

%routine outlhex(%integer msh,lsh)
%CONSTSTRING(1)%ARRAY HEX(0:15)="0","1","2","3","4",
               "5","6","7","8","9","A","B","C","D","E","F"
%INTEGER I,digit
%string(16)res
      RES=""
      %FOR I=8<<2-4,-4,0 %CYCLE
         digit=msh>>I&15
          %if res#"" %or digit#0 %then RES=RES.HEX(digit)
      %REPEAT
      %FOR I=8<<2-4,-4,0 %CYCLE
         digit=lsh>>I&15
          %if res#"" %or digit#0 %then RES=RES.HEX(digit)
      %REPEAT
      %if res="" %then res="0"
      outstring("0x".res)
%end
%routine outhex(%integer value)
%CONSTSTRING(1)%ARRAY HEX(0:15)="0","1","2","3","4",
               "5","6","7","8","9","A","B","C","D","E","F"
%INTEGER I,digit
%STRING(8)RES
      RES=""
      %FOR I=8<<2-4,-4,0 %CYCLE
         digit=VALUE>>I&15
          %if res#"" %or digit#0 %then RES=RES.HEX(digit)
      %REPEAT
      %if res="" %then res="0"
      outstring("0x".res)
%end
!*
%routine outint(%integer value)
!***********************************************************************
!*    SIMPLE MINDED ALL IMP VERSION NOT USING STRINGS                  *
!***********************************************************************
%INTEGER SIGN,WORK,PTR
%BYTEINTEGERARRAY CH(0:15)
      %if value=x'80000000' %then outhex(value) %and %return
      SIGN=' '
      %IF VALUE<0 %THEN SIGN='-' %AND VALUE=-VALUE
      PTR=0
      %CYCLE
         WORK=VALUE//10
         CH(PTR)=VALUE-10*WORK
         VALUE=WORK
         PTR=PTR+1
      %REPEATUNTIL VALUE=0
      WORK=PTR-1
      OUTSYM(SIGN) %if sign='-'
      outSYM(CH(PTR)+'0') %FOR PTR=WORK,-1,0
%end
!*
%routine outinternames(%integer info)
!***********************************************************************
!* output any intermediate (union) names needed to access              *
!* elements of imps more general record as C struct                    *
!************************************************************************

%integer k,id
      %for k=12,-4,0 %cycle
         id=info>>k&15
         %if id#0 %start
            %if id&8#0 %then %start
               outstring("s")
               outint(id&7)
            %else
               outstring("u")
               outint(id&7-1{ union update })
            %finish
            outsym('.')
         %finish
      %repeat
%end
!*
%ROUTINESPEC OUTFL (%LONGREAL X, %INTEGER N)
%ROUTINE PRINT (%LONGREAL X, %INTEGER N,M)
!***********************************************************************
!*       PRINTS A REAL NUMBER (X) ALLOWING N PLACES BEFORE THE DECIMAL *
!*       POINT AND M PLACES AFTER.IT REQUIRES (M+N+2) PRINT PLACES     *
!*       UNLESS (M=0) WHEN  (N+1) PLACES ARE REQUIRED.                 *
!*                                                                     *
!*       A LITTLE CARE IS NEEDED TO AVOID UNNECESSARY LOSS OF ACCURACY *
!*       AND TO AVOID OVERFLOW WHEN DEALING WITH VERY LARGE NUMBERS    *
%CONSTLONGREAL DZ=0
!***********************************************************************
%LONGREAL Y,Z,ROUND,FACTOR
%INTEGER I,J,L,MORIG
%BYTEINTEGER SIGN
      M=M&63;                           ! DEAL WITH STUPID PARAMS
      MORIG=M
      %IF N<0 %THEN N=1; N=N&31;        ! DEAL WITH STUPID PARAMS
      X=X+DZ;                           ! NORMALISE
      SIGN=' ';                         ! '+' IMPLIED
      %IF X<0 %THEN SIGN='-'
      Y=MOD(X);                         ! ALL WORK DONE WITH Y
      ROUND=0.5/10**M;                  ! ROUNDING FACTOR
      %IF Y>1.0*10**16 %OR N=0 %THENSTART;    ! MEANINGLESS FIGURES GENERATED
         %IF N>M %THEN M=N;             ! FOR FIXED POINT PRINTING
         OUTFL(X,M);                 ! OF ENORMOUS NUMBERS
         %RETURN;                       ! SO PRINT IN FLOATING FORM
      %FINISH
      I=0; Z=1; Y=Y+ROUND
      %UNTIL Z>Y %CYCLE;                ! COUNT LEADING PLACES
         I=I+1; Z=10*Z;                 ! NO DANGER OF OVERFLOW HERE
      %REPEAT
      OUTSYM(SIGN)
      J=I-1; Z=10**J
      FACTOR=1/10
      %CYCLE
         %UNTIL J<0 %CYCLE
            L=INT PT(Y/Z);              ! OBTAIN NEXT DIGIT
            Y=Y-L*Z; Z=Z*FACTOR;        ! AND REDUCE TOTAL
            OUTSYM(L+'0')
            J=J-1
         %REPEAT
         %IF M=0 %THENEXIT;           ! NO DECIMAL PART TO BE O/P
         OUTSTRING(".")
         J=M-1; Z=10**(J-1); M=0
         Y=10*Y*Z
      %REPEAT
      %if MORIG>0 %start          { Chop any redundant trailing 0s}
         opline_length=opline_length-1 %while %c
           opline_l(opline_length-1)='0' %and opline_l(opline_length-2)#'.'
      %finish
%END;                                   ! OF ROUTINE PRINT
%ROUTINE OUTFL (%LONGREAL X, %INTEGER N)
!***********************************************************************
!*       PRINTS IN FLOATING POINT FORMAT WITH N PLACES AFTER THE       *
!*       DECIMAL POINT. ALWAYS TAKES N+7 PRINTING POSITIONS.           *
!*       CARE REQUIRED TO AVOID OVERFLOW WITH LARGE X                  *
!***********************************************************************
%LONGREAL SIGN,ROUND,FACTOR,LB,UB
%CONSTLONGREAL DZ=0
%INTEGER COUNT,INC
     inc=integer(addr(x))
      %if inc>>20&x'7ff'=x'7ff' %start
         outstring("NAN {"); outhex(inc); outhex(integer(addr(x)+4))
         outsym('}'); %return
      %finish
      ROUND=0.5/10**N;                  ! TO ROUND SCALED NO
      LB=1-ROUND; UB=10-ROUND
      SIGN=1
      X=X+DZ;                           ! NORMALISE
      %IF X=0 %THEN COUNT=0 %ELSESTART
         %IF X<0 %THEN X=-X %AND SIGN=-SIGN
         INC=1; COUNT=0
         FACTOR=1/10
         %IF X<=1 %THEN FACTOR=10 %AND INC=-1
                                        ! FORCE INTO RANGE 1->10
         %WHILE X<LB %OR X>=UB %CYCLE
            X=X*FACTOR; COUNT=COUNT+INC
         %REPEAT
      %FINISH
      PRINT(SIGN*X,1,N)
      %if count#0 %start
         OUTSTRING("E")
         OUTINT(COUNT)
      %finish
%END;                                   ! OF ROUTINE OUTFL
   %routine FORCE TRIPS
!***********************************************************************
!*    FORCE OUT THE TRIPLES TO CODE. NEEDED IN CEND ETC                *
!***********************************************************************
      triples(0)=0
      nexttrip=1
      triples(0)_flink=1       { return any triples }
      %end

      %routine COMPILE A STMNT
         %integer I
         force trips
         I = NEXTP
         STARSIZE = A(NEXTP)<<16+A(NEXTP+1)<<8+A(NEXTP+2)
         NEXTP = NEXTP+STARSIZE
         LINE = A(I+3)<<8+A(I+4)
         curlinead=fromar4(I+5)
         nextlinead=fromar4(NEXTP+5)
         STMTS = STMTS+1
         opline_line=line
         CSS(I+9)
          %if a(NEXTP+3)<<8!A(NEXTP+4)=line %then %start
           curly check(1)
           outsym(9)
         %else
            force line
         %finish
      %end
%integerfn nextstmntalt
      %result=a(NEXTP+9)
%end
      %routine CSS(%integer Pinit)
         %routine %spec ENTER JUMP(%integer MASK,STAD,FLAG)
         %integer %fn %spec ENTER LAB(%integer M,FLAG)
         %routine %spec REMOVE LAB(%integer LAB)
         %routine %spec SAVE STACK PTR
         %routine %spec CEND(%integer KKK)
         %integer %fn %spec CCOND(%integer CTO,A,B,JFLAGS)
         %integer %fn %spec REVERSE(%integer MASK)
         %routine %spec SET LINE
         %routine %spec CUI(%integer CODE)
         %routine %spec ASSIGN(%integer A,B)
         %routine %spec CSTART(%integer CCRES,MODE)
         %routine %spec CCYCBODY(%integer UA,ELAB,CLAB)
         %routine %spec CLOOP(%integer ALT,MARKC,MARKUI)
         %routine %spec CIFTHEN(%integer MARKIU,MARKC,MARKUI,MARKE,MARKR,Afterelse)
         %integer %fn %spec CREATE AH(%integer MODE,
            %record (RD) %name EOPND,NOPND)
         %routine %spec TORP(%integer %name HEAD,BOT,NOPS,%integer mode)
         %integer %fn %spec INTEXP(%integer %name VALUE, %integer PRECTYPE)
         %integer %fn %spec CONSTEXP(%integer PRECTYPE)
         %routine %spec CSEXP(%integer MODE)
         %routine %spec labexp
         %routine %spec outopnd(%record(rd)%name opnd,%integer mode)
         %routine %spec outtriple(%integer tripno,mode)
         %routine %spec CSTREXP(%integer B)
         %routine %spec CRES(%integer LAB)
         %routine %spec EXPOP(%integer %name A,B, %integer C,D)
         %routine %spec TEST APP(%integer %name NUM)
         %routine %spec SKIP EXP
         %routine %spec SKIP APP
         %routine %spec NO APP
         %integer %fn %spec DOPE VECTOR(%integer A,B,C,MODE,ID)
         %routine %spec DECLARE ARRAYS(%integer A,B)
         %routine %spec DECLARE SCALARS(%integer B)
         %routine %spec CRSPEC(%integer M)
         %routine %spec CFPLIST(%integer %name A,B)
         %routine %spec CFPDEL
         %routine %spec CLT
         %integer %fn %spec ROUNDING LENGTH(%integer PTYPE,RULES)
         %routine %spec CQN(%integer P)
         %integer %fn %spec TSEXP(%integer %name VALUE)
          %integer %fn %spec tcond
         %routine %spec CRCALL(%integer RTNAME)
         %routine %spec NAMEOP(%integer Z,SIZE,NAMEP)
         %routine %spec CNAME(%integer Z)
         %routine %spec CANAME(%integer Z,ARRP, %record (RD) %name HDOPND)
         %routine %spec CSNAME(%integer Z)
         %routine %spec COPY TAG(%integer KK,DECLARE)
         %routine %spec REDUCE TAG(%integer DECLARE)
         %routine %spec STORE TAG(%integer KK,LEVEL,RBASE,J,SNDISP,ACC,SLINK,
            KFORM)
         %routine %spec UNPACK
         %routine %spec PACK(%integer %name PTYPE)
         %routine %spec RDISPLAY(%integer KK)
         %routine %spec RHEAD(%integer RTNAME,AXNAME,Xtra)
         %integer %fn %spec CFORMATREF
         %routine %spec CRFORMAT(%integer myrflevel)
            %routinespec process format(%integer level,alt,structor union,intid,
                  %integername strid,ophed,opbot)
         %integer %fn %spec DISPLACEMENT(%integer LINK)
         %integer %fn %spec COPY RECORD TAG(%integer %name SUBS)
         %integer %fn %spec CHK REC ALIGN(%integer p1)
         %switch SW(1:24)
         %const %byte %integer %array FCOMP(0:14)=0,
                                   8,10,2,7,12,4,7,
                                   8,12,4,7,10,2,7
%integer %array rfhead,rfbot(0:12,0:12),rfalt(0:12)
%integer rflevel

         %integer P,SNDISP,ACC,K,KFORM,STNAME,MIDCELL
         %integer TCELL,JJ,JJJ,KK,QQ,MARKER,REPORTUI,XDISP,MASK,BASE,AREA,
            ACCESS,DISP,EXTRN,CURR INST,VALUE,STRINGL,PTYPE,I,J,OLDI,USEBITS,
            STRFNRES,MARKIU,MARKUI,MARKC,MARKE,MARKR,INAFORMAT
         %integer LITL,ROUT,NAM,ARR,PREC,TYPE,lhformatname,doinglabel
         %record (RD) EXPOPND,NAMEOPND,MLOPND;  ! RESULT RECORD FOR EXPOP&CNAME
!
! on some machines global parameters are difficult to access hence
! copy pinit into local P which is frequently updated globally
!
         P = Pinit
        doinglabel=0
         CURR INST = 0; INAFORMAT = 0
         currentSSalt=a(p)
         ->SW(currentSSalt)
SW(13):                                  ! INCLUDE SOMETHING
      %begin
      %string(255) s,head,tail
      s=string(addr(a(P+2)))       { File name}
      %if s-> head.(".inc").tail %then s=head.".h"
      outstring("#include "); outsym('"')
      outstring(s)
      outsym('"')
      %end
      ->cssexit2
SW(24):                                  ! REDUNDANT SEP
      %if a(p+1)=10 %then outsym(' ')         { extar neline }
      ->css exit2
SW(2):                                   ! <CMARK> <COMMENT TEXT>
      p=p+1
      kk=a(p); p=p+1;                    ! kk=1 # comment, =2 ! comment, =3 %comment
       jj=a(p); jjj=0
      %if KK=1 %then outsym('#') %else outstring("/*")    { preserve any #defines in the imp}
      %while jj#NL %cycle
         %if JJ>128 %and jjj<128 %then outsym('%')
         outsym(jj&127)
         jjj=jj
         p=p+1; jj=a(p)
         %if jjj='\' %and JJ=13{CR} %and KK=1 %then outsym(NL) %and p=p+1 %and %continue
         %if jjj=',' %and ((kk=2 %and jj='!') %or (kk=1 %and jj='#')) %start { unscramble comments ending with a comma = continuation}
            %if kk=1 %start
               outsym(NL); outsym('#')
            %else
               outcommentend; outsym(NL)
               outstring("/*")
            %finish
            jjj=jj; p=p+1; jj=a(p)
         %finish
      %repeat
      %if kk>1 %then outcommentend
      ->CSSEXIT2
CSSEXIT: outsep %unless opline_length>0 %and  opline_l(opline_length-1)='}'
Cssexit2: LAST INST = CURR INST
         %return
SW(1):                                   !(UI)(S)
!         FAULT(57,0,0) %unless LEVEL>=2
         MARKER = P+1+A(P+1)<<8+A(P+2)
         P = P+3
         ->LABFND %if A(MARKER)=1
         %if A(MARKER)=2 %then SET LINE %and CUI(0) %and ->CSSEXIT
         MARKE = 0; MARKR = 0
         MARKUI = P; MARKIU = MARKER+1
         MARKC = MARKIU+1
         %if A(MARKER)=3 %then %c
            CIFTHEN(MARKIU,MARKC,MARKUI,0,0,NO) %and ->CSSEXIT
         CLOOP(A(MARKIU),MARKC+2,MARKUI)
         ->CSSEXIT
LABFND:  OLDLINE = 0
         ->SWITCH %unless A(P)=1 %and A(P+5)=2;  ! 1ST OF UI AND NO APP
         ->SWITCH %unless A(P+6)=2 %and A(P+7)=2;  ! NO ENAMSE OR ASSNMNT
         JJ = ENTER LAB(FROM AR2(P+3),0)
         outname(from ar2(P+3))
         outsym(':'); curly check(0);  outsym(NL);
        %if 1<<next stmntalt&(1<<6!1<<4!1<<18!1<<9)#0 %then outsep
         ->CSSEXIT2
SW(5):                                   ! %cycle
!         FAULT(57,0,0) %unless LEVEL>=2
         %if A(P+5)=2 %then %start;      ! OPEN CYCLE
            CLOOP(0,P+1,P+1)
         %finish %else %start
            SET LINE
            CLOOP(6,P+6,P+1)
         %finish
         ->CSSEXIT
!
SW(6):                                   ! REPEAT
         ->CSSEXIT2
SW(22):                                  ! '%CONTROL' (CONST)
         ->CSSEXIT2
!
SW(3):                                   ! (%iu)(COND)%then(UI)(ELSE')
         MARKIU = P+1; MARKC = MARKIU+3
         MARKR = P+2+A(P+2)<<8+A(P+3);   ! ! FROMAR2(P+2)
         MARKE = 0
         %if A(MARKR)=3 %then %start
            MARKE = MARKR+1+FROMAR2(MARKR+1)
            MARKUI = MARKR+3
         %finish
         CIFTHEN(MARKIU,MARKC,MARKUI,MARKE,MARKR,NO)
         ->CSSEXIT
SW(4):
                                         ! '%FINISH(ELSE')(S)
SW(18):
                                         ! '%ELSE' MEANING FINISH ELSE START
         ->CSSEXIT2
SWITCH:  %begin;                         ! SWITCH LABEL
            %record (LISTF) %name LCELL
            %record(swdataform)%name swdata
            %integer NAPS,FNAME
            FNAME = FROM AR2(P+3)
            %unless A(P)=1 %and A(P+5)=1 %then FAULT(5,0,FNAME) %and ->BEND
                                         ! 1ST OF UI + APP
            P = P+6
            COPY TAG(FNAME,NO)
            %if OLDI#LEVEL %or TYPE#6 %then FAULT(4,0,FNAME) %and ->BEND
            LCELL==aslist(k)
            swdata==record(LCELL_S1)
            swdata_slabs(swdata_lseen)=p
            swdata_lseen=swdata_lseen+1
            outswadname(fname); outstring("_"); labexp; outsym(':')
            curly check(0); outsym(NL);
           %if 1<<next stmntalt&(1<<6!1<<4!1<<18!1<<9)#0 %then outsep
BEND:    %end
         FORCE TRIPS %if PARM_OPT=0
         ->CSSEXIT2
SW(23):
                                         ! SWITCH(*):
         %begin
            %record (LISTF) %name LCELL
            %record(swdataform)%name swdata
            %integer FNAME,JJ,RES
            FNAME = FROM AR2(P+1)
            COPY TAG(FNAME,NO)
            %if OLDI=LEVEL %and TYPE=6 %start
               LCELL == ASLIST(K)
               swdata==record(LCELL_S1)
               swdata_default=p
               outswadname(fname); outstring("_default:")
            %finish %else FAULT(4,0,FNAME)
         %end
         FORCE TRIPS %if PARM_OPT=0
         ->CSSEXIT2
!
SW(7):                                   ! (%wu)(SC)(COND)(RESTOFWU)
!         FAULT(57,0,0) %unless LEVEL>=2
         MARKIU = P+1;                   ! TO WHILE/UNTIL
         MARKC = MARKIU+3;               ! TO (SC)(COND)
         CLOOP(A(MARKIU)+3,MARKC,MARKIU+1+FROMAR2(MARKIU+1))
         ->CSSEXIT
!
SW(8):                                   ! SIMPLE DECLN
!         FAULT(57,0,0) %unless LEVEL>=2
         P = P+1
         MARKER = P+FROMAR2(P);          ! TO ALT OF DECLN
         P = P+2; ROUT = 0; LITL = 0
         %if A(MARKER)#1 %then %start;   ! ARRAY DECLARATIONS
            CLT
            %if TYPE=5 %and (ACC<=0 %or ACC>256) %then %c
               FAULT(70,ACC-1,0) %and ACC = 255
            NAM = 0
            SET LINE
            QQ = 2-A(P+1); P = P+2;      ! QQ=1 FOR ARRAYFORMATS
            DECLARE ARRAYS(QQ,KFORM)
            %if qq=1 %then ->cssexit2   { ignore formats }
            FORCE TRIPS %if PARM_OPT=0
         %finish %else %start
            CLT
            CQN(P+1); P = P+2
            DECLARE SCALARS(KFORM)
         %finish
         ->CSSEXIT
!
SW(9):                                   ! %end
         %begin
            %switch S(1:5)
           %integer etype
            etype=A(P+1)
            ->S(etype)
S(1):                                    ! ENDOFPROGRAM
         outstring("imp_stop();"); outsym(NL)
S(2):                                    ! ENDOFFILE
            %if PARM_CPRMODE=0 %then PARM_CPRMODE = 2
            FAULT(15,LEVEL+PARM_CPRMODE-3,0) %unless LEVEL+PARM_CPRMODE=3
            CEND(PARM_CPRMODE)
            outsym('}') %if etype=1
            ->BEND
S(3):                                    ! ENDOFLIST
            ->BEND
S(4):                                    ! END
            %if PARM_CPRMODE=1 %and LEVEL=2 %then FAULT(14,0,0) %else %c
               CEND(CURRINF_FLAG)
            outstring("}"); ! outstring(" /* proc */")
BEND:    %end
         ->CSSEXIT2
!
SW(11):
         %begin
            %integer MARKER1,RTNAME,KKK,PTR,PTYPEP,CNT,PP,PCHAIN,AXNAME,
               PNAME,NPARAMS,SCHAIN,PARMSPACE,D,PARAMPTYPE,PARAMACC,pcount
            %record (LISTF) %name LCELL,LCELL2,TCELL
            P = P+1; MARKER1 = FROM AR2(P)+P;  ! (SEX)(RT)(SPEC')(NAME)(FPP)
           markc=a(marker1)
AGN:        Q = P; RTNAME = FROM AR2(MARKER1+3);  ! RTNAME ON NAME
            EXTRN = A(P+2);              ! 1=SYSTEM,2=EXTERNAL
                                         ! 3=DYNAMIC, 4=INTERNAL

            LITL = EXTRN&3
            %if A(MARKER1)=1 %then %start;  ! P<%spec'>='%spec'
               P = P+3; CRSPEC(1-EXTRN>>2);  ! 0 FOR ROUTINESPEC
                                         ! 1 FOR EXTERNAL (ETC) SPEC
               ->BEND
            %finish
            FORCE TRIPS;                 ! IN CASE OPTIMISING
            COPY TAG(RTNAME,NO)
            AXNAME = ADDR(WORKA_LETT(WORD(RTNAME)))
            %if EXTRN=3 %then EXTRN = 2
            %if TARGET=EMAS %and EXTRN=1 %then WARN(11,0)
            %if A(MARKER1+5)=1 %then %start;! extract alias name
               MOVE BYTES(A(MARKER1+6)+1,ADDR(A(0)),MARKER1+6,ADDR(A(0)),
                  WORKA_ARTOP)
               AXNAME = ADDR(A(WORKA_ARTOP))
               WORKA_ARTOP = (WORKA_ARTOP+4+A(MARKER1+6))&(-4)
            %finish
            %if EXTRN=4 %then AXNAME = 0
            %if OLDI#LEVEL %then %start;  ! NAME NOT KNOWN AT THIS LEVEL
               P = Q+3; CRSPEC(2); P = Q; ->AGN
            %finish %else %start;        ! NAME ALREADY KNOWN AT THIS LEVEL
               %if PARM_CPRMODE=0 %then PARM_CPRMODE = 2;  ! FLAG AS FILE OF%c
                                                           ROUTINES
               FAULT(56,0,RTNAME) %unless %c
                  EXTRN=4 %or (PARM_CPRMODE=2 %and LEVEL=1)
               %if A(P+3)=1 %then KKK = LITL<<14!X'1000' %else %start
                  ROUT = 1; P = P+4;     ! FIGURE OUT PTYPE FOR FNS&MAPS
                  CLT; ARR = 0; NAM = 0
                  %if A(P)=2 %then NAM = 2;  ! SET NAME ARRAY BIT FOR MAPS
                  PACK(KKK);             ! AND STORE PTYPE IN KKK
               %finish
            %finish
!
! UNLESS A MATCH WAS OBTAINED BETWEEN HEADING AND SPEC SOMETHING
! HAS GONE WRONG. COMPILE HEADING AGAIN AS SPEC. THIS WILL
! PREVENT ANY INCONSISTENCIED AND CAUSE A "NAME SET TWICE"
! FOR ANY ERROR
!
            %unless (J=15 %or J=7*EXTRN) %and PTYPE&X'FFFF'=KKK %start
               P = Q+3; CRSPEC(2); P = Q; ->AGN
            %finish
            PTYPE = PTYPE!(EXTRN&3)<<14;  ! DEAL WITH %routinespec FOLLOWED
                                         ! BY %externalroutine
!
! RESET THE TAGS TO BODY GIVEN AND ALLOWING FOR SPEC/EXTERNALROUTINE
! AND EXTERNALSPEC/EXTERNAL ROUTINE COMBINATIONS. RESTORE THE USE
! BITS WHICH WILL SHOW USED AS A RESULT OF THE COPY TAG IN THIS SEQUENCE
!
            TCELL == ASLIST(TAGS(RTNAME))
            TCELL_PTYPE <- PTYPE
            %if PTYPE&x'c000'=x'8000' %then USEBITS = 2;  ! externals presumed%c
                                                          'used'

            TCELL_UIOJ <- TCELL_UIOJ&X'3FF0'!USEBITS<<14
                                         ! NEWPTYPE & SET J=0
            %if (target=Perq %or Target=Accent) %and J=14 %then %c
              TCELL_S2 = WORKA_RTCOUNT %and WORKA_RTCOUNT = WORKA_RTCOUNT+1
                                         ! NO RT NO ALLOCATED TO EXTERNAL SPECS
            PTYPEP = PTYPE
               %if ptypep&x'c000'=0 %then outstring("static ")
               outtype(ptypep&255,tcell_kform)
               %if ptypep&x'800'#0 %and ptypep&7#5 %then outsym('*')
               %if axname=0 %then outname(rtname) %else outstring(string(axname))
               outsym('(')
            PCHAIN = TCELL_SLINK;        ! CHAIN OF PARAMETER DESCRIPTUONS
            RHEAD(RTNAME,AXNAME,fromar2(marker1+1));! FIRST PART OF ENTRY SEQUENCE
!
! NOW DECLARE THE FORMAL PARAMETERS. FOLLOW BY CLAIMING DISPLAY
! AND SETTING DIAGNOSTIC PTR IN ROUTINE RDISPLAY
!
            P = MARKER1+6
            %if A(P-1)=1 %then P = P+A(P)+1;  ! SKIP OVER ALIASNAME
            CNT = 0
            PTYPE = PTYPEP; UNPACK
            N = RTPARAM1OFFSET
            %if TARGET=PERQ %or TARGET=ACCENT %start
               %if TYPE#0 %then N = (BYTES(PREC)+1)&(-2)
               %if TYPE=5 %or TYPE=3 %then N = 4;  ! MAPS
               %if NAM#0 %then %start
                  %if TYPE=5 %then N = 4 %else N = PTRSIZE(PTYPE&127)
                                         ! BYTE MAPS RETURN BYTE PTR
               %finish
               CURRINF_RESSIZE = N
            %finish
            NPARAMS = 0; PARMSPACE = 0
            %if PCHAIN#0 %then NPARAMS = ASLIST(PCHAIN)_S3
            %if NPARAMS#0 %then %c
               PARMSPACE = NPARAMS>>16 %and NPARAMS = NPARAMS&X'FF'
                                         ! ALLOW ACTUAL PARAMETER SPACE
            %while A(P)=1 %cycle;        ! WHILE SOME (MORE) FP PART
               PP = P+1+FROMAR2(P+1)
               P = P+3
               CFPDEL
               PARAMPTYPE = PTYPE; PARAMACC = ACC;  ! may get cahnged for rt%c
                                                    types
               PTR = P
               %until A(PTR-1)=2 %cycle;  ! CYCLE DOWN NAMELIST
                  %if PARAMS BWARDS=YES %start;  ! MAP PCHAIN TO REVERSE ORDER%c
                                                 LIST
                     PCHAIN = TCELL_SLINK
                     PCHAIN = ASLIST(PCHAIN)_LINK %for KKK = 2,1,NPARAMS-CNT
                  %finish
                  LCELL == ASLIST(PCHAIN);  ! EXTRACT PTYPE XTRA INFO
                  %if PCHAIN#0 %then %start
                     %unless LCELL_PTYPE=PARAMPTYPE %and %c
                        LCELL_ACC&x'FFFF'=PARAMACC %then FAULT(9,CNT+1,RTNAME)
                  %finish
                  PNAME = FROM AR2(PTR);  ! NAME FOR PARAM INTERNALLY
                  LCELL_UIOJ <- LCELL_UIOJ!PNAME<<4;  ! SAVED IN LIST( max 12 bits!)
                  D = LCELL_SNDISP+N;    ! PARAMETER OFFSET
                  %if PARAMPTYPE&x'1000'#0 %start;  ! PROCEDURE PARAMETERS
                     P = PTR
                     P = P+3 %until A(P-1)=2
                     CFPLIST(SCHAIN,KKK);  ! PARAMETERLIST FOR PASSED PROC
                     PTYPE = PARAMPTYPE;  ! CHANGED BY CFPLIST
                     outtype(paramptype&255,kform); outname(pname); outstring("(")
                     lcell2==aslist(schain)
                     %if KKK=0 %then outstring("void ") %else %start
                        %for pcount=1,1,KKK %cycle
                           %if lcell2_s1&x'10000000'#0 %start
                              outtype(lcell2_s1>>16&255,lcell2_sndisp); outstring("()")
                           %else
                              outxtype(lcell2_s1>>16,lcell2_sndisp)
                           %finish
                           %if lcell2_link#0 %then outsym(',')
                           lcell2==aslist(lcell2_link)
                        %repeat
                     %finish
                     outstring(")")
                     STORETAG(PNAME,LEVEL,RBASE,13,D,LCELL_ACC,SCHAIN,0)
                  %finish %else %start
                     %if TARGET=EMAS %and PTYPE=X'33' %then D = D+8
                                         ! FOR HISTORIC PARAMTER COMPATABILITY
                     %if STRVALINWA=YES %and PTYPE=X'35' %then PTYPE = X'435'
!                      %if recvalinwa=yes %and ptype=X'33' %and acc#4 %then ptype=x'433'
                     outxtype(paramptype,kform); outname(pname);
                     STORE TAG(PNAME,LEVEL,RBASE,LCELL_UIOJ&15,0,ACC,D,KFORM)
                     PTYPE = PARAMPTYPE
                  %finish
                  PTR = PTR+3
                  CNT = CNT+1
                  PCHAIN = LCELL_LINK %if PARAMS BWARDS=NO
            outsym(',') %unless pchain=0
               %repeat
               P = PP
            %repeat;                     ! UNTIL NO MORE FP-PART
            outstring(") {")
            N = N+PARMSPACE
            N = (N+MINPARAMSIZE-1)&(-MINPARAMSIZE);  ! TO WORD BOUNDARY AFTER%c
                                                     ALL SYSTEM
                                         ! STANDARD PARAMETERS HAVE BEEN%c
                                         DECLARED
            FAULT(8,0,RTNAME) %if CNT>NPARAMS
            FAULT(10,0,RTNAME) %if CNT<NPARAMS
            PTYPE = PTYPEP
            %if STRRESINWA=YES %start;   ! NEEDS FN RESULT DESC
               %unless 3#PTYPE&X'F0F'#5 %then N = N+PTRSIZE(X'35')
                                         ! STR FNS RESULT PARAM IS STACKED
               CURRINF_RESSIZE = N
            %finish
            N = N+ALPHA;                 ! allow for link bytes on unix(etc)
            %if TARGET=PNX %then %start
               IMPABORT %if N&7#0
            %finish
                                         ! AS XTRA PARM JUST BEFORE DISPLAY
            RDISPLAY(RTNAME)
BEND:    %end
      Force trips %if parm_opt=0;! Problems if procname redeclared
                                         ! as new proc before entry code planted
         ->cssexit2
!
SW(14):                                  ! %begin
         %begin
            FORCE TRIPS;                 ! IN CASE OPTIMISING
            PTYPE = 0
            %if LEVEL=1 %and RLEVEL=0 %start
               %if PARM_CPRMODE=0 %then %start
                  RLEVEL = 1; RBASE = 1
                  PARM_CPRMODE = 1
                  RHEAD(-1,ADDR(MAINEP),1)
                  N = RTPARAM1OFFSET+alpha
                  outstring("main() {")
               %finish %else FAULT(58,0,0)
            %finish %else %start
               SET LINE;                 ! SO 'ENTERED FROM LINE' IS OK
               outstring("{")
               RHEAD(-1,0,1)
            %finish
            RDISPLAY(-1)
         %end
         ->CSSEXIT2
!
SW(15):
                                         ! '%ON'(EVENT')(N)(NLIST)'%start'
         outstring("***untranslateable IMP construct***")
         ->CSSEXIT
SW(16):
         %begin;                         ! %switch (SWITCH LIST)
            %integer Q,RANGE,KKK,LB,UB,PP,D0,OPHEAD,V,R,datad
            %record (RD) OPND1,OPND2
            %record(swdataform)%name swdata
!            FAULT(57,0,0) %unless LEVEL>=2
            Q = P
            %until A(Q)=2 %cycle;        ! UNTIL NO'REST OF SW LIST'
               P = P+3
               P = P+3 %while A(P)=1
               P = P+4;                  ! TO P(+')
               KKK = INTEXP(LB,MINAPT);  ! EXTRACT LOWER BOUND
               P = P+3
               KKK = KKK!INTEXP(UB,MINAPT);  ! EXTRACT UPPER BOUND
               RANGE = (UB-LB+1)
               %if RANGE<=0 %or KKK#0 %start
                  LB = 0; UB = 10; RANGE = 1024
               %finish
               datad=malloc(4*range+8)
               swdata==record(datad)
               swdata_lseen=0; swdata_default=0
               PTYPE = X'56'+1<<8;       ! WORD LABEL ARRAY
               PP = P; P = Q+1
               %until A(P-1)=2 %cycle;   !  DOWN NAMELIST
                  K = FROM AR2(P)
                  P = P+3
                  OPHEAD = 0
                  OPND1_PTYPE <- PTYPE
                  OPND1_XB = 0
                  OPND1_FLAG = DNAME
                  OPND1_D = K
                  OPND1_XTRA = 0
                  OPND2_PTYPE = X'61'
                  OPND2_XB = 0
                  OPND2_FLAG = DNAME
                  OPND2_D = LB
                  OPND2_XTRA = UB
                  V = BRECTRIP(DCLSW,PTYPE,0,OPND1,OPND2)
                  PUSH(OPHEAD,datad,LB,UB)
                  STORE TAG(K,LEVEL,RBASE,1,0,4,OPHEAD,0)
                  outstring("int "); outswadname(k)
                  outstring("_value;")
               %repeat;                  ! FOR ANY MORE NAMES IN NAMELIST
               Q = PP; P = Q
            %repeat;                     ! UNTIL A(Q)=2
         %end; ->CSSEXIT2
!
SW(17):  ->CSSEXIT
!
SW(12):                                  ! '%OWN' (TYPE)(OWNDEC)
         %begin
!***********************************************************************
!*       INITIALISED DECLARATION GO INTO THE GLA OR GLA SYMBOL TABLES  *
!*       EXCEPT FOR CONST ARRAYS WHICH GO INTO THE CODE SYMBOL TABLES  *
!*       STRINGS AND ARRAYS HAVE A HEADER IN THE GLA. QPUT ARRANGES    *
!*       FOR THE LOADER TO RELOCATE THE HEADERS.                       *
!*       EXTERNALS ARE IDENTICAL WITH OWN BUT ALSO HAVE A DATA EP DEFN *
!*       IN THE LOAD DATA SO THEY CAN BE FOUND AT LOAD TIME            *
!*       EXTRINSICS HAVE A DATA REFERENCE AND A DUMMY HEADER IN THE GLA*
!*       THE LOADER USES THE FORMER TO RELOCATE THE LATTER.            *
!***********************************************************************
            %routine %spec CLEAR(%integer L)
            %routine %spec XTRACT CONST(%integer CONTYPE,CONPREC)
            %routine %spec INIT SPACE(%integer A,B)
            %integer SLENGTH,PP,SIGN,TAGDISP,DVO,K,STALLOC,SPOINT,tp,savep,
               CONSTSFOUND,CPREC,EXTRN,NNAMES,MARK,QPUTP,LB,CTYPE,CONSTP,
               FORMAT,DPTYPE,DIMEN,SACC,TYPEP,KK,orlevel,savesndisp,savekform,II
            %record (RD) COPND,FCOPND
            %own %long %real ZERO=0
            %string (255) SCONST,NAMTXT
            %record (LISTF) %name LCELL
            QPUTP = 5;                  ! NORMAL CASE GLA SYMBOLTABLES
            EXTRN = A(P+1)
            P = P+2
            %if EXTRN>=4 %then EXTRN = 0;  ! CONST & CONSTANT->0
            SNDISP = 0
            CONSTS FOUND = 0
            %if EXTRN=0 %then QPUTP = 4
            CLT
!
! CHECK FOR %spec AND CHANGE EXTERNAL SPEC TO EXTRINSIC
!
            %if A(P+2)=1 %start
               %if EXTRN=2 %then EXTRN = 3 %else FAULT(46,0,0)
            %finish
            %if 2<=EXTRN<=3 %and ((A(P)=1 %and A(P+1)#3) %or (A(P)=2 %and %c
               A(P+1)#2)) %then FAULT(46,0,0)
            %if type=5 %and a(p)#1 %and extrn=0 %then extrn=1
            LITL = EXTRN
            %if LITL<=1 %then LITL = LITL!!1
            %if A(P)=1 %then CQN(P+1) %else ARR = 1 %and NAM = 0
            %if TYPE=5 %and NAM=0 %and (ACC<=0 %or ACC>256) %then %c
               FAULT(70,ACC-1,0) %and ACC = 2
            STALLOC = ACC;               ! ALLOCATION OF STORE FOR ITEM OR%c
                                         POINTER
            %if (TARGET=PERQ %or TARGET=ACCENT %or TARGET=PNX) %and %c
               TYPE=5 %then STALLOC = (STALLOC+1)&X'FFE'
            ROUT = 0; PACK(PTYPE); DPTYPE = PTYPE;  ! FOR DECLARATION
            %if NAM#0 %start;            ! OWN POINTERS
               %if ARR#0 %then STALLOC = 8 %else STALLOC = 4
            %finish %else %start;        ! OWN VARS & ARRAYS
               ->NON SCALAR %if ARR#0
            %finish
            P = P+2
            %until A(MARK)=2 %cycle;     ! UNTIL <RESTOFOWNDEC> NULL
               MARK = P+1+FROM AR2(P+1)
               PP = P+3; P = PP+2;       ! PP ON FIRST NAME'
               K = FROM AR2(PP);         ! FOR ERROR MESSAGES RE CONST
               NAMTXT = STRING(ADDR(WORKA_LETT(WORD(K))))
               %if A(P)=1 %then %start;  ! ALAIS GIVEN
                  %if LITL=0 %then WARN(10,0)
                  LENGTH(NAMTXT) = A(P+1)
                  CHARNO(NAMTXT,KK) = A(P+KK+1) %for KK = 1,1,A(P+1)
                  P = P+A(P+1)+1
                  outstring("#define "); outname(k); outsym(' ')
                  outstring(namtxt); outsym(NL)
               %finish
               P = P+1;                  ! P ON CONST'
!
! OBTAIN THE INITIAL CONSTANT,ITS TYPE(CTYPE) AND SIGN(SIGN)
!
               SCONST = ""
               PTYPE = DPTYPE; UNPACK;   ! MAY HAVE BEEN CONSTANT EVALUATIONS
                                         ! WHICH HAVE CHANGED PTYPE
               SIGN = 3; CTYPE = TYPE; CONSTSFOUND = 0; CPREC = PREC
               %if TYPE=3 %then CTYPE = 1;  ! RECS INITTED TO REPEATED BYTE
               %if NAM#0 %then CTYPE = 1 %and CPREC = 5
               P = P+1
               %if RLEVEL=0 %and EXTRN=0 %start
                  outstring("#define ")
                  outrevisablename(k)
               %else
                  out extern(EXTRN)
                  %if ptype=x'35' %then outstring("char ") %else outtype(ptype&255,kform)
                  %if nam#0 %then outsym('*')
                  outname(k)
               %finish
               %if ptype=x'35' %then %start
                  outstring(" ["); outint(stalloc); outsym(']')
               %finish
               tp=1
               %if A(P-1)=1 %then %start;  ! CONSTANT GIVEN
                  savep=p; p=p-3; tp=tsexp(kk); p=savep
                  %if RLEVEL=0 %and EXTRN=0 %start
                     outstring(" "); outstring("(") %if tp<=0
                  %else
                     outsym('=')
                  %finish
                  XTRACT CONST(CTYPE,CPREC)
               %finish %else %start
                  WARN(7,K) %if EXTRN=0;  ! %const NOT INITIALISED
                  FCOPND = 0; COPND = 0
               %finish
               %if RLEVEL=0 %and EXTRN=0 %start
                 outsym(')') %if tp<=0
               %else
                 outsep
               %finish
               outsym(NL) %unless a(MARK)=2
               PTYPE = DPTYPE; UNPACK;   ! MAY HAVE BEEN CONSTANT EVALUATIONS
                                         ! WHICH HAVE CHANGED PTYPE
               J = 0; orlevel = 0
               %if NAM#0 %then %start;   ! OWNNAMES AND ARRAYNAMES
                  %if ARR=0 %then %start
                     %if (target=ibm %or target=amdahl %or target=ibmxa) %and %c
                        extrn=0 %start
                        tagdisp = worka_const ptr
                        %if type=5 %then ctable(tagdisp)=acc %and %c
                             worka_const ptr=worka_const ptr+1
                        ctable(worka_const ptr) = fcopnd_d
                        worka_const ptr = worka_const ptr+1
                        %if worka_const ptr>worka_const limit %then %c
                           fault(102,worka_wkfilek,0)
                        tagdisp = 4*tagdisp; orlevel = 14
                     %finish %else TAGDISP = PINITOWN(PTYPE,ACC,FCOPND,NAMTXT)
                  %finish %else %start;  ! ARRAYNAMES
!                     DVO = DOPE VECTOR(NO,TYPE,ACC,-1,K,QQ,LB)
                     %if PARM_COMPILER#0 %and LB#0 %then FAULT(99,0,0)
                     %if EXTRN#0 %then SNDISP = 0 %and J = 0 %else %c
                        J = 1 %and SNDISP = (SNDISP&X'3FFFF')>>2
                     TAGDISP = POWNARRAYHEAD(PTYPE,J,LB,X'FFFFFF',COPND_D,0,
                        DVO,NAMTXT)
                  %finish
                  STORE TAG(K,LEVEL,orlevel,J,SNDISP,ACC,TAGDISP,KFORM)
                  P = MARK
                  %continue
               %finish
               %if EXTRN=3 %then %start;  ! EXTRINISIC
!                  PTYPE = PTYPE!X'400';  ! FORCE NAM=1 (IE VIA POINTER)
                  FCOPND_D = 0
                  TAGDISP = PINITOWN(PTYPE,ACC,FCOPND,NAMTXT)
                  STORE TAG(K,LEVEL,0,J,SNDISP,ACC,TAGDISP,KFORM)
                  P = MARK
                  %continue
               %finish
               %if TYPE=3 %then %start;  ! RECORDS
                  TAGDISP = PINITOWN(PTYPE,ACC,FCOPND,NAMTXT)
               %finish
               %if 1<<TYPE&B'100110'#0 %start;  ! INTEGER & REAL & STRING
                  %if EXTRN#0 %then %start
                     TAGDISP = PINITOWN(PTYPE,ACC,FCOPND,NAMTXT)
                  %finish %else TAGDISP = 0
               %finish
               STORE TAG(K,LEVEL,0,J,SNDISP,ACC,TAGDISP,KFORM)
               %if EXTRN=0=NAM %and 1<<TYPE&B'100110'#0 %start
                                         ! CONST = LITERAL
                  LCELL == ASLIST(TAGS(K))
                  lcell_s1=lcell_S1!(copnd_ptype&8)<<16
                  LCELL_S2 = COPND_D
                  LCELL_S3 = COPND_XTRA
                  %if TYPE=5 %then %start
                     LCELL_S2 = WORKA_ARTOP
                     WORKA_ARTOP = (WORKA_ARTOP+COPND_XTRA+4)&(-4)
                  %finish
               %finish
               P = MARK
            %repeat
            ->BEND
NONSCALAR:                               ! OWN AND OWNRECORD ARRAYS
!***********************************************************************
!*       OWN ARRAYS CAN BE INITIALISED BUT ONLY ONE ARRAY CAN BE       *
!*       DECLARED IN A STATEMENT.(THANK HEAVENS!)                      *
!*       OWN RECORD ARRAYS ARE INITIALISED AS BYTE ARRAYS              *
!***********************************************************************
            P = P+1
            FORMAT = 2-A(P)
            %if FORMAT#0 %then arr=3 %and pack(ptype)
            PP = P+2; P = P+4; NNAMES = 1
            K = FROM AR2(PP)
            NAMTXT = STRING(ADDR(WORKA_LETT(WORD(K))))
            %if A(P)=1 %then %start;     ! ALAIS GIVEN
               %if LITL=0 %then WARN(10,0)
               LENGTH(NAMTXT) = A(P+1)
               CHARNO(NAMTXT,KK) = A(P+KK+1) %for KK = 1,1,A(P+1)
               P = P+A(P+1)+1
            %finish
            P = P+1;                     ! P ON CONSTLIST
            SACC = ACC; TYPEP = PTYPE; savekform=kform
            DVO = DOPE VECTOR(NO,TYPE,STALLOC,0,K)
            %if SNDISP=-1 %then SNDISP = 0;  ! BUM DOPE VECTOR
            SNDISP = (SNDISP&X'3FFFF')>>2;  ! AS WORD DISPLACEMENT
            savesndisp=sndisp           { Not proof against C-T concatenation !}
            DIMEN = J;                   ! SAVE NO OF DIMENESIONS
            ACC = SACC; PTYPE = TYPEP; UNPACK
            PP=p
            %if format=0 %start
               outextern(EXTRN)
               outtype(ptype&255,savekform)
               outname(k)
               %for ii=dimen,-1,1 %cycle
                  p=ctable(savesndisp+3*ii+2)
                  outstring(" [")
                  csexp(x'51')
                  %if ctable(savesndisp+3*ii)=x'80000000'%start
                     outsym('-'); p=ctable(savesndisp+3*ii+1)
                     outsym('('); csexp(x'51'); outstring(")+1")
                  %finish %else %if ctable(savesndisp+3*ii)<1 %start
                     outsym('+'); outint(1-ctable(savesndisp+3*ii))
                  %finish %else %if ctable(savesndisp+3*ii)>1 %start
                     outsym('-'); outint(ctable(savesndisp+3*ii)-1)
                  %finish
                  outsym(']')
               %repeat
            %finish
            PTYPE = TYPEP; UNPACK
            %if LB=0 %and FORMAT=0 %then ARR = 2 %and PACK(PTYPE)
            %if TYPE=3 %then SLENGTH = QQ %else SLENGTH = QQ//STALLOC
                                         ! NO OF ELEMENTS
            cas(qputp)=(cas(qputp)+arrayrounding)&(\arrayrounding)
            SPOINT = cas(qputp)
            %if FORMAT=0 %then %start
               %if A(PP)=1 %then P = PP+1 %and INIT SPACE(QQ,SLENGTH)
            %finish
            outsep  %if format=0
            %if EXTRN=3 %then SPOINT = 0
!
! OUTPUT AN ARRAYHEAD INTO THE GLA RELATIVE TO THE START OF THE SYMBOL-
! TABLES IN WHICH THE ARRAY RESIDES.
!
            PTYPE = TYPEP; UNPACK
            %if Format#0 %then qputp=0     { avoid data fixup in pownarrayhead}
            TAGDISP = POWNARRAYHEAD(PTYPE,dimen,LB,QQ,SPOINT,QPUTP,DVO,NAMTXT)
            SNDISP=savesndisp
            STORE TAG(K,LEVEL,0,dimen,SNDISP,ACC,TAGDISP,saveKFORM)
            ->BEND
%routine INIT SPACE(%integer SIZE,NELS)
!***********************************************************************
!*       P IS TO FIRST ENTRY FOR CONSTLIST                             *
!*    MAP SPACE ONTO WORKFILE END TO GIVE SANE ERROR MESSAGE IF        *
!*    THERE WAS NOT ENOUGH SPACE                                       *
!***********************************************************************
%const %integer BUFSIZE=512
%integer RF,I,II,ELSIZE,AD,SPP,SLENGTH,WRIT,PIN,PP,contype,conprec,ppp,value
      pIN=p; contype=type
      conprec=prec
 outstring(" = {")
      SPP = 0; WRIT = 0
      %until A(P-1)=2 %cycle
         p=p-3; PP=p; skip exp
         %if A(P)=1 %start;     ! REPITITION FACTOR
            P = P+2
            %if A(P-1)=2 %then %start     { * found issue warning }
               RF = 1                     { Except for 0(*) when detectable }
               %unless a(PP+3)=4 %and a(PP+4)=2 %and a(PP+5)=x'41' %andc
                  a(PP+6)=a(PP+7)=0 %and a(PP+8)=2 %then warn(10,0)
            %finish %else %start
               P = P+2
               %if INTEXP(RF,MINAPT)#0 %then warn(10,0) %and RF = 1
            %finish
            P = P+1
         %finish %else RF = 1 %and P = P+2
         warn(10,0) %if RF<=0
          spp=p
         %cycle I = RF,-1,1
            p=pp
            %if contype=5 %then cstrexp(1) %else csexp(conprec<<4!contype)
            consts found=consts found+1
            outsym(',') %unless i=1 %and a(spp-1)=2  { very last const}
         %if (contype=5 %and consts found&3=0) %or consts found&7=0 %c
              %then outsym(NL)
         %repeat
         p=spp
      %repeat
      outstring("}")
%end
%routine XTRACT CONST(%integer CONTYPE,CONPREC)
!***********************************************************************
!*       P POINTS TO P<+'> OF <+'><OPERNAD><RESTOFEXPR>  AND IS UPDATED*
!*       THE CONST IS CONVERTED TO REQUIRED FORM AND IF INTEGER        *
!*       IS LEFT IN ICONST, IF REAL IN RCONST AND IF STRING IN SCONST  *
!***********************************************************************
               %integer SLENGTH,STYPE,SACC,MODE,CH,WR,I,PP
               STYPE = PTYPE; SACC = ACC;  ! MAY BE CHANGED IF CONST IS EXPR
               %if CONTYPE=5 %then %start
                  P = P-3; CSTREXP(1)
                  WR = WORKA_ARTOP
                  %if EXPOPND_FLAG=LCONST %and EXPOPND_PTYPE=X'35' %start
                     SLENGTH = EXPOPND_XTRA
                     LENGTH(SCONST) = SLENGTH
                     A(WR) = SLENGTH
                     %for I = 1,1,SLENGTH %cycle
                        CH = A(EXPOPND_D+I)
                        CHARNO(SCONST,I) = CH
                        A(WR+I) = CH
                     %repeat
                     COPND_PTYPE = X'35'; COPND_FLAG = LCONST
                     COPND_D = EXPOPND_D
                     COPND_XTRA = SLENGTH
                  %finish %else %start
                     FAULT(44,CONSTS FOUND,K); SCONST = ""
                     SLENGTH = 0
                  %finish
               %finish %else %start
                  MODE = CONPREC<<4!CONTYPE
                  %if CONPREC<5 %then MODE = CONTYPE!X'50'
                  PP=P; p=p-3; csexp(mode)
                  p=pp; I = CONSTEXP(MODE)   { Evaluate again to get storeable value }
!                  %if CONSTP=0 %then FAULT(41,0,0)
                                         ! CANT EVALUATE EXPT
                  COPND = EXPOPND;       ! GET RESULT OPND
                  COPND_PTYPE = MODE
               %finish
               PTYPE = STYPE; UNPACK; ACC = SACC

               FCOPND = COPND
            %end
BEND:    %end; ->CSSEXIT2
SW(10):
      %begin;                         ! %recordformat (RDECLN)
      %integer NAME,OPHEAD,OPBOT,NLIST,HeadCell,FHEAD,SPEC,l1,l2,strid,fpt
      %record (LISTF) %name LCELL,FRCELL
       %string(255) typename
      SNDISP = 0
      SPEC = A(P+1);               ! 1 FOR SPEC 2 FOR FORMAT
      NAME = FROM AR2(P+2); P = P+4
      COPY TAG(NAME,NO)
      %if SPEC=1 %or %not (PTYPE=4 %and J=15 %and OLDI=LEVEL) %start
         KFORM = 0
         PUSH(KFORM,0,0,0)
         PTYPE = 4
         STORE TAG(NAME,LEVEL,RBASE,15,0,MAXRECSIZE,KFORM,KFORM)
                                   ! IN CASE OF REFS IN FORMAT
      %finish
      %if SPEC=2 %start
         ophead=0; opbot=0; nlist=0
         %for l1=0,1,12 %cycle
           %for l2=0,1,12 %cycle
              rfhead(l1,l2)=0
              rfbot(l1,l2)=0
           %repeat
           rfalt(l1)=0
          %repeat
         INAFORMAT = 1
         rflevel=0
         crformat(rflevel)
         INAFORMAT = 0
         %if PARM_Z#0 %start
            %for l1=0,1,12 %cycle
              %for l2=0,1,12 %cycle
                  %if rfhead(l1,l2)#0 %start
                      printstring("level&rfalt="); write(l1,5); write(l2,5); newline
                      printlist(rfhead(l1,l2))
                  %finish
               %repeat
            %repeat
         %finish
         strid=0;                 { for generating internal names }
        HeadCell=rfhead(0,1)
         %if HeadCell=0 %start      { No alternatives at top level }
            outstring("struct "); outname(name)
            outsym('{'); outsym(NL)
            process format(0,0,'s',0,strid,ophead,opbot)
            fpt=4
         %else
            outstring("union "); outname(name)
            outsym('{'); outsym(NL)
            process format(0,0,'u',0,strid,ophead,opbot)
            fpt=x'14'
         %finish
         outsym('}'); outsym(';'); outsym(NL)
         %if PARM_Z#0 %start
            printstring("after processing")
            printlist(ophead)
         %finish
         %if possible typename(name,typename)#0 %start
            outsym(NL)
            outstring("typedef ")
            %if HeadCell=0 %start      { No alternatives at top level }
               outstring("struct ")
            %else
               outstring("union ")
            %finish
            outname(name)
            outstring(" ".typename.";")
            outsym(NL)
         %finish
         CLEAR LIST(NLIST)
!
! IN CASE OF FORWARD REFS COPY TOP CELL OF FORMAT CHAIN INTO DUMMY
! SET UP BEFORE CALL OF CRFORMAT. ALSO RESET J&ACC TO CORRECT VALUE
           LCELL == ASLIST(TAGS(NAME))
         KFORM = LCELL_KFORM
         %if PARM_Z#0 %start
                printstring("before throwing dummy cell")
                printlist(kform)
         %finish
         POP(KFORM,I,I,FHEAD);     ! THROW DUMMY CELL
                                   ! GET HEAD OF FORWARD REFS
         fhead=ophead
         %while FHEAD>0 %cycle;    ! THROUGH format changeFORWARD REFS
            FRCELL == ASLIST(fhead)
            %if frcell_ptype=x'433' %and frcell_kform=lcell_kform %start
               FRCELL_UIOJ = FRCELL_UIOJ&X'FFFFFFF0';  ! SET J BACK TO 0
               FRCELL_ACC <- ACC;     ! ACC TO CORRECT VALUE
               FRCELL_KFORM = OPHEAD;  ! CORRECT KFORM
            %finish
            fhead=frcell_link
         %repeat
         LCELL_UIOJ = LCELL_UIOJ&X'FFFFFFF0';  ! J BACK TO ZERO
         LCELL_ACC <- ACC
         LCELL_SLINK = name;     ! KFORM&SLINK TO SIDECHAIN & name
         LCELL_PTYPE=fpt        { To distinguish unions from structs }
         LCELL_KFORM = OPHEAD
         %if PARM_Z#0 %start
            printstring("after processing self refs")
            printlist(ophead)
         %finish
      %finish
%end; ->CSSEXIT2
!
SW(19):
                                         ! '*' (UCI) (S)
!         FAULT(57,0,0) %unless LEVEL>=2
        outstring("***Untranslateable stmnt***")
         i=curlinead
         %while i<nextlinead %cycle
            outsym(byteinteger(i))
            i=i+1
         %repeat
         ->CSSEXIT
SW(20):
                                         ! '%TRUSTEDPROGRAM'
         PARM_COMPILER = 1 %if PARM_ARR=0 %and PARM_CHK=0; ->CSSEXIT
SW(21):                                  ! '%MAINEP'(NAME)
         KK = FROM AR2(P+1)
         FAULT(97,0,0) %unless PARM_CPRMODE=0
         MAINEP <- STRING(ADDR(WORKA_LETT(WORD(KK))))
         ->CSSEXIT
         %integer %fn CFORMATREF
!***********************************************************************
!*    P IS TO ALT OF FORMAT REF                                        *
!*    P<FORMTAREF>::=(NAME),(RFDEC)(RESTOFRFDEC)(ALTRFDEC)             *
!*    RETURNS CELL NO OF TOP CELL OF THE FORMATLIST                    *
!***********************************************************************
            %integer FNAM,OPHEAD,OPBOT,NHEAD,MRL
            %record (LISTF) %name LCELL
            %if A(P)=1 %start;           ! A RECORD OF RECORDFORMAT NAME
               FNAM = FROM AR2(P+1)
               P = P+3
               COPY TAG(FNAM,NO)
               %if 3<=TYPE<=4 %then %result = KFORM
               %if INAFORMAT#0 %and OLDI#LEVEL %start
                  PTYPE = 4; ACC = MAXRECSIZE
                  PUSH(KFORM,0,0,0)
                  STORE TAG(FNAM,LEVEL,RBASE,15,0,MAXRECSIZE,KFORM,KFORM)
                  %result = KFORM
               %finish
               FAULT(62,0,FNAM);         ! NOT A RECORD OF FORMAT NAME
               ACC = 8;                  ! GUESS A RECORD SIZE
               %result = DUMMY FORMAT
            %finish
                                         ! FORMAT ACTUALLY SPECIFIED
            P = P+1
            OPHEAD = 0; OPBOT = 0
              outstring("*** imp construction too difficult***")
            %result = OPHEAD
         %end

         %routine CRFORMAT(%integer myrflevel)
!***********************************************************************
!*       CONVERTS A RECORDFORMAT STATEMENT TO A LIST HEADED BY OPHEAD  *
!*       FORMAT OF AN ENTRY.                                           *
!*       S1=SUBNAME<<20!PTYPE<<4!J                                     *
!*       S2,S3=4  16 BIT DISPLACEMENTS  D2,ACC,D1,KFORM                *
!*       NORMALLY D1=RECORD RELATIVE DISPLACEMENT AND ACC=LMAX(STRINGS)*
!*       FOR ARRAYS D2=FIRST ELEMENT DISPLACEMENT AND D1=DISPLACEMENT  *
!*       OF RECORD RELATIVE ARRAYHEAD IN THE GLA                       *
!*       KFORM IS ONLY USED FOR RECORDS AND POINTS TO THE FORMAT       *
!*       ON EXIT ACC HAS THE RECORD SIZE ROUNDED UP TO THE BOUNDARY    *
!*       REQUIRED BY ITS LARGEST COMPONENT                             *
!***********************************************************************
            %integer D1,D2,FORM,RL,STALLOC,INC,Q,R,RFD,LB,TYPEP,SACC,DVO
            %routine %spec SN(%integer Q)
            %routine %spec ROUND
            FORM = 0; ACC = 0
            INC = 0;          ! INC COUNTS DOWN RECORD
            %cycle
               ROUT = 0; LITL = 0; NAM = 0; RFD = A(P)
               P = P+1
               %if RFD=1 %then %start
                  CLT
                  FORM = KFORM
                  STALLOC = ACC
                  P = P+1
                  %if A(P-1)=1 %start
                                         ! (TYPE) (QNAME')(NAMELIST)
                     FORM = KFORM
                     CQN(P); P = P+1
                     PACK(PTYPE); D2 = 0
                     RL = ROUNDING LENGTH(PTYPE,0)
                     %if NAM=1 %then %start
                        STALLOC = PTRSIZE(PREC<<4!TYPE)
                         RL=PTRrounding(ptype&127)
                        %if ARR#0 %then STALLOC = AHEADSIZE %and RL=ROUNDINGLENGTH(AHEADPT,0)
                     %finish
                     fault(70,0,0) %if type=5 %and stalloc=0
                     ROUND; J = 0
                     %until A(P-1)=2 %cycle
                        D1 = 0; SN(P)
                        P = P+3; INC = INC+STALLOC
                     %repeat
                  %finish %else %start
                                         ! (TYPE)%array(NAMELIST)(BPAIR)
                     Q = P+1; ARR = 1; PACK(PTYPE)
                     %cycle
                        P = Q
                        P = P+3 %until A(P-1)=2
                        TYPEP = PTYPE; SACC = ACC
                        D2=dope vector(NO,typep&7,acc,0,fromar2(q))>>2
                                         ! DOPE VECTOR INTO SHAREABLE S.T.
                        ACC = SACC; PTYPE = TYPEP; UNPACK
                        RL = ROUNDING LENGTH(PTYPE&255,0);  ! FOR ELEMENT AS%c
                                                            SCALAR
                        %if RL<ARRAYINREC ROUNDING %then %c
                           RL = ARRAYINREC ROUNDING
                        %cycle
                           ROUND
                           D1 = 0
                           SN(Q);! INC = INC+R
                           Q = Q+3
                        %repeat %until A(Q-1)=2;  ! TILL NAMELIST NULL
                        P = P+1; Q = P+1
                     %repeat %until A(P-1)=2;  ! UNTIL <RESTOFARRAYLIST> NULL
                  %finish
               %finish %else %start
                                         ! (FORMAT)
                  rflevel=rflevel+1
                  binsert(rfhead(myrflevel,rfalt(myrflevel)),rfbot(myrflevel,rfalt(myrflevel)),
                    0,rflevel,0)
                  CRFORMAT(rflevel)
                  INC = ACC
               %finish
               P = P+1
            %repeat %until A(P-1)=2;     ! UNTIL <RESTOFRFDEC> NULL
                                         ! FINISH OFF
            %if A(P)=1 %start;           ! WHILE %or CLAUSES
               P = P+1
                  rfalt(myrflevel)=rfalt(myrflevel)+1
               CRFORMAT(myrflevel)
               %if ACC>INC %then INC = ACC
            %finish %else P = P+1
            ACC = INC;                   ! SIZE ROUNDED APPROPRIATELY
            %return
            %routine SN(%integer Q)
!***********************************************************************
!*       CHECK THE SUBNAME HAS NOT BEEN USED BEFORE IN THIS FORMAT     *
!*       AND ENTER IT WITH ITS DESCRIPTORS INTO THE LIST.              *
!*       CARE IS NEEDED TO MATCH TAG LAYOUT ON BYTE SWOPPED HOSTS      *
!***********************************************************************
               %record (TAGF) CELL
               FNAME = FROM AR2(Q)
               %if aslist(tags(fname))_ptype=x'4051' %then warn(11,0)
               CELL_PTYPE <- PTYPE; CELL_UIOJ <- FNAME<<4!J
               CELL_ACC <- ACC
               CELL_SNDISP <- D2&X'FFFF';  ! IN CASE OF BUM FORMATS
               CELL_SLINK <- D1&X'FFFF';  ! IN CASE OF BUM FORMATS
               CELL_KFORM = FORM
               BINSERT(rfhead(myrflevel,rfalt(myrflevel)),rfbot(myrflevel,rfalt(myrflevel)),
                  CELL_S1,CELL_S2,CELL_S3)
!               %if PTYPE=X'433' %and ACC=MAXRECSIZE %then %c
                  PUSH(ASLIST(FORM)_S3,OPBOT,0,0)
! NOTE FORWARD REFERENCE
            %end
            %routine ROUND
            %end
         %end;                           ! OF ROUTINE CRFORMAT
%routine out fmt cell(%record(listf)%name lcell)
!***********************************************************************
!* print out a single cell of a format list                            *
!***********************************************************************
%integer pt,name,dvdisp,nd,ii
%record(listf)%name fcell
      pt=lcell_s1>>16
      name=lcell_S1>>4&X'FFF'
      %if pt&x'cff'=x'35' %start
         outstring("char "); outname(name)
      %else
         OUT XTYPE(PT&x'cff',lcell_kform)
         outname(name)
      %finish
      %if PT&x'300'#0 %start
         nd=lcell_s1&15
         dvdisp=lcell_sndisp
            %for ii=nd,-1,1 %cycle
               p=ctable(dvdisp+3*ii+2)
               outstring(" [")
               csexp(x'51')
               %if ctable(dvdisp+3*ii)=x'80000000'%start
                  outsym('-'); p=ctable(dvdisp+3*ii+1)
                  outsym('('); csexp(x'51'); outstring(")+1")
               %finish %else %if ctable(dvdisp+3*ii)<1 %start
                  outsym('+'); outint(1-ctable(dvdisp+3*ii))
               %finish %else %if ctable(dvdisp+3*ii)>1 %start
                  outsym('-'); outint(ctable(dvdisp+3*ii)-1)
               %finish
               outsym(']')
            %repeat
      %finish
      %if pt&x'cff'=x'35' %start
         outsym('['); outint(lcell_acc); outsym(']')
      %finish
      outsep
      outsym(NL)
%end
%routine process format(%integer level,alt,structor union,intid,
      %integername strid,ophead,opbot)
!***********************************************************************
!* process one level of the recordformay data structure and call       &
!* itself recursively to handle lower levels. Note C unions cal        &
!* can have only one element in each alternative so imp multi-         &
!* element alternatives have to be coalesced into structures           &
!* this is the main problem                                            &
!***********************************************************************
%record (listf)lcell
%integer i,j,k,newid,lstrid

      %if structorunion='s' %start   { struct only 1 alt }
         %while rfhead(level,alt)#0 %cycle
            pop(rfhead(level,alt),lcell_s1,lcell_s2,lcell_s3)
            %if lcell_s1#0 %start
               out fmt cell(lcell)
               lcell_slink=intid
               binsert(ophead,opbot,lcell_s1,lcell_s2,lcell_s3)
            %else                   { union within struct }
               newid=intid<<4!(lcell_s2{-1}{ union update })
               outstring("union {"); outsym(NL)
               process format(lcell_s2,0,'u',newid,strid,ophead,opbot)
               outstring("} u"); outint(lcell_s2-1)
               outsym(';'); outsym(NL)
            %finish
         %repeat
      %else                          { union with at least 2 alternatives }
         %for i=alt,1,rfalt(level) %cycle
            %if rfhead(level,i)=rfbot(level,i) %start   { only 1 alt }
               pop(rfhead(level,i),lcell_s1,lcell_s2,lcell_s3)
               %if lcell_s1#0 %start
                  out fmt cell(lcell)
                  lcell_slink=intid
                  binsert(ophead,opbot,lcell_s1,lcell_s2,lcell_s3)
               %else                   { union within union }
                  newid=intid<<4!(lcell_s2{-1}{ union update })
                  outstring("union {"); outsym(NL)
                  process format(lcell_s2,0,'u',newid,strid,ophead,opbot)
                  outstring("} u"); outint(lcell_s2-1)
                  outsym(';'); outsym(NL)
               %finish
            %else                 { force in a struct }
               lstrid=strid; strid=strid+1
               newid=intid<<4!8!lstrid
               outstring("struct {"); outsym(NL)
               process format(level,i,'s',newid,strid,ophead,opbot)
               outstring("} s"); outint(lstrid)
               outsym(';'); outsym(NL)
            %finish
        %repeat
      %finish
%end

         %integer %fn DISPLACEMENT(%integer LINK)
!***********************************************************************
!*         SEARCH A FORMAT LIST FOR A SUBNAME                          *
!*      A(P) HAS ENAME--LINK IS HEAD OF RFORMAT LIST. RESULT IS DISP   *
!*      FROM START OF RECORD                                           *
!***********************************************************************
            %record (LISTF) %name FCELL,PCELL,LCELL
            %record (TAGF) TOPND
            %integer RR,II,ENAME,CELL
            ENAME = A(P)<<8+A(P+1); CELL = 0
            %if LINK#0 %then %start;     ! CHK RECORDSPEC NOT OMITTED
               FCELL == ASLIST(LINK);    ! ONTO FIRST CELL
               CELL = LINK; II = -1; ACC = -1
               %while LINK>0 %cycle
                  LCELL == ASLIST(LINK)
                  %if LCELL_UIOJ<<16>>20=ENAME %start;  ! RIGHT SUBNAME LOCATED
                     TCELL = LINK
                     SNDISP = LCELL_SNDISP
                     K = LCELL_SLINK
                     J = LCELL_UIOJ&15; PTYPE = LCELL_PTYPE
                     ACC = LCELL_ACC&X'FFFF'
                     SNDISP = LCELL_SNDISP
                     KFORM = LCELL_KFORM
                     %if LINK#CELL %start;  ! NOT TOP CELL OF FORMAT
                        PCELL_LINK = LCELL_LINK
                        LCELL_LINK = FCELL_LINK
                        FCELL_LINK = LINK
                     %finish;            ! ARRANGING LIST WITH THIS SUBNAME
                                         ! NEXT TO THE TOP
                     %result = K
                  %finish
                  PCELL == LCELL
                  LINK = LCELL_LINK
               %repeat
            %finish
            FAULT(65,0,ENAME)
            %if CELL>0 %then %start
               TOPND_PTYPE = x'51'
               TOPND_UIOJ <- ENAME<<4
               PUSH(ASLIST(CELL)_LINK,TOPND_S1,0,0)
            %finish
            PTYPE = X'51'; TCELL = 0; unpack
            %result = -1
         %end
         %integer %fn COPY RECORD TAG(%integer %name SUBS)
!***********************************************************************
!*       PRODUCE PTYPE ETC FOR A COMPOUND NAME BY CHAINING DOWN ONE    *
!*       ONE OR MORE RECORD FORMAT LISTS. ON EXIT RESULT =0 IF NO      *
!*       SUBNAME FOUND OR SUBNAME IS OF TYPE RECORD WITH NO FURTHER    *
!*       SUBNAME ATTACHED. RESULT#0 IF BONE-FIDE SUBNAME LOCATED       *
!*       ON ENTRY KFORM HAS POINTER TO THE (FIRST ) FORMAT LIST AND    *
!*       P POINTS TO THE A.R. ENTRY FOR (FIRST) ENAME                  *
!***********************************************************************
            %integer Q,FNAME
            SUBS = 0
            %until TYPE#3 %cycle
               FNAME = KFORM
               P = P+2; SKIP APP
               %result = 0 %if A(P)=2 %or FNAME<=0;  ! NO (FURTHER) ENAME
               SUBS = SUBS+1
               P = P+1; Q = DISPLACEMENT(FNAME)
               UNPACK
            %repeat
            %result = Q+1;               ! GIVES 0 IF SUBNAME NOT KNOWN
         %end
%integerfn chk rec align(%integer p1)
!***********************************************************************
!*      Tiddles down chain looking for an integer or larger            *
!*      returns 0 unless at least word aligned                         *
!***********************************************************************
%integer cell,i
%integerfnspec scan(%integer cell)
      p=p1; reduce tag(no);    ! leaves kform set for records
      cell=kform
!        printstring("chk align ".printname(a(p1)<<8!a(p1+1)))
!        write(kform,5); newline
!           printlist(cell)
      %result=scan(cell)
%integerfn scan(%integer cell)
%integer j
      %while cell #0 %cycle
         i=aslist(cell)_ptype>>4&7
         %if i>=5 %then %result=i
         %if aslist(cell)_ptype=x'33' %then %start
            i=scan(aslist(cell)_kform)
          %if i>=5 %then %result=i
         %finish
         cell=aslist(cell)_link
      %repeat
      %result=0
%end
%end { chk rec align }
         %routine CRNAME(%integer Z,MODE,BS,DP, %integer %name NAMEP)
!***********************************************************************
!*       DEAL WITH RECORD ELEMENT NAMES.Z AS FOR CNAME.CLINK=TAGS(RN)  *
!*       MODE=ACCESS FOR RECORD(NOT THE ELEMENT!)                      *
!*       ON EXIT BASE,AREA & DISP POINT TO REQUIRED ELEMENT            *
!*       RECURSIVE CALL IS NEEDED TO DEAL WITH RECORDS IN RECORDS      *
!*       DEPTH SHEWS  RECURSIVE LEVELS- NEEDED TO AVOID MIS SETTING    *
!*       REGISTER IN USE IF RECORDNAME IN RECORD HAS THE SAME NAME AS  *
!*       A GENUINE RECORD NAME.                                        *
!***********************************************************************
            %integer DEPTH,FNAME,EMNAME
            %routine %spec CENAME(%integer MODE,FNAME,BS,DP,XD)
            %record (RD) HDOPND
            HDOPND = 0
            DEPTH = 0
            EMNAME = NAMEP&X'FFFF';      ! ORIGINAL RECORD NAME FOR ERROR%c
                                         MESSES
            FNAME = KFORM;               ! POINTER TO FORMAT
            %if ARR=0 %or (6<=z<=7 %and A(P+2)=2) %start;  ! SIMPLE RECORD
               %if A(P+2)=2 %then P = P+3 %else NO APP
               CENAME(MODE,FNAME,BS,DP,0)
            %finish %else %start
               HDOPND_PTYPE = AHEADPT
               HDOPND_FLAG = LOCALIR
               HDOPND_D = BS<<16!DP
               CANAME(Z,ARR,HDOPND)
               NAMEP = -1
               CENAME(ACCESS,FNAME,BASE,DISP,0)
            %finish; %return
!
%routine CENAME(%integer MODE,FNAME,BS,DP,XD)
!***********************************************************************
!*       FINDS OUT ABOUT SUBNAME AND ACTS ACCORDINGLY.MOSTLY ACTION    *
!*       CONSISTS OF UPPING XD BY OFFSET OF THE SUBNAME BUT IS VERY    *
!*       HAIRY FOR RECORDS IN RECORDS ETC                              *
!*       MODE IS ACCESS FOR THE RECORD                                 *
!***********************************************************************
%routine %spec FETCH RAD
%integer Q,QQ,D,C,TR,ENAME,RPTYPE,EPTYPE
%record (RD) RADOPND,OPND1
%record (LISTF) %name LCELL
               DEPTH = DEPTH+1
              RPTYPE=PTYPE
               %if A(P)=2 %then %start;  ! ENAME MISSING
                  ACCESS = MODE; XDISP = XD
                  BASE = BS; DISP = DP;  ! FOR POINTER
                  %if Z<14 %then %start;  ! NOT A RECORD OPERATION
                     %unless 3<=Z<=4 %or Z=6 %or Z=7 %start;  ! ADDR(RECORD)
                        FAULT(64,0,EMNAME); BASE = RBASE
                        DISP = 0; ACCESS = 0; PTYPE = X'51'
                        UNPACK
                     %finish
                  %finish
                  %return
               %finish
               P = P+1;                  ! FIND OUT ABOUT SUBNAME
               Q = DISPLACEMENT(FNAME);  ! TCELL POINTS TO CELL HOLDING
              EPTYPE=PTYPE;                ! Save ptype of ename
               UNPACK;                   ! INFO ABOUT THE SUBNAME
!               %if Q=-1=ACC %or PTYPE=X'51' %start;  ! WRONG SUBNAME(HAS BEEN%c
!                                                     FAULTED)
!                  P = P+2; SKIP APP; P = P-3
!                  ACCESS = 0; BASE = RBASE; DISP = 0
!                  %return
!               %finish
               ENAME = A(P)<<8!A(P+1)
               NAMEP = ENAME<<16!NAMEP;  ! NAMEP=-1 UNALTERED !
               %if rptype&x'f00'=x'400' %then outstring("->") %else outstring(".")
               outinternames(q)
               outname(ename)
               ->AE %if ARR=1;           ! ARRAYS INCLUDING RECORDARRAYS
               %if A(P+2)=2 %then P = P+3 %else NO APP
               %if TYPE<=2 %or TYPE=5 %or (TYPE=3 %and A(P)=2 %and %c
                  (3<=Z<=4 %or 6<=z<=7)) %start
                  ACCESS = MODE+4+4*NAM; BASE = BS;
                  DISP = DP; XDISP = XD+Q
                  %return
               %finish
!
! NOW CODING BECOMES HAIRY:- STILL LEFT ARE
! A) RECORDS IN RECORDS   Q POINTS TO SECONDARY RECORD
! B) RECORDNAMES IN RECORDS   Q HAS OFF-SET OF A POINTER
! C) RECORDARRAYNAMES IN RECORDS   Q HAS OFF-SET A HEADER IN RECORD
! D) RECORDARRAYS IN RECORDS   NOT YET ALLOWED
!    Q WOULD HAVE OFF-SET OF A RECORD RELATIVE HEADER IN THE GLA
!
               XD = XD+Q
               NAMEP = NAMEP!X'FFFF0000'
               %if NAM=1 %then %start
                  MODE = MODE+4;         ! SO ADDRESS OF POINTER FETCHED
                  FETCH RAD;             ! NEW METHOD IS AS FOR REC FNS
                  EXPOPND = RADOPND;     ! EXPOPND IS ADDRESS TO WHICH POINTER%c
                                         POINTED
                  MODE = 3
                  DP = 0; XD = 0; BS = 0
                  NAMEP = -1
               %finish
               CENAME(MODE,KFORM,BS,DP,XD)
               %return
AE:                                      ! ARRAYS AND ARRAYNAMES AS ELEMEN
               LCELL == ASLIST(TCELL)
               ACC = LCELL_ACC&X'FFFF'; SNDISP = LCELL_SNDISP&X'FFFF'
               KFORM = LCELL_KFORM; K = LCELL_SLINK&x'ffff'
               C = ACC; D = SNDISP; Q = K; QQ = KFORM
               %if (Z=6 %or Z>=11) %and A(P+2)=2 %start;  ! 'GET ARRAYHEAD'%c
                                                          CALL
                  P = P+3
                  %if NAM=1 %then %start
                     ACCESS = MODE+8; BASE = BS
                     DISP = DP; XDISP = XD+Q
                     PTYPE = AHEADPT
                     NAMEOP(6,8,NAMEP);  ! PTR TO HEAD
                     %return
                  %finish
!
! PASSING AN ARRAY IN A RECORD BY NAME MUST CONSTRUCT PROPER ARRAYHEAD
! FROM THE RECORD RELATIVE ONE AT Q(GLA)
!
                  FETCH RAD
                  NAMEP = -1
                  OPND1 = 0
                  OPND1_PTYPE = AHEADPT
                  OPND1_FLAG = LOCALIR
                  OPND1_D = Q
                  NAMEOPND_D = CREATE AH(1,RADOPND,OPND1)
                  NAMEOPND_PTYPE = AHEADPT; NAMEOPND_FLAG = REFTRIP
                  NAMEOPND_XTRA = 0
               %finish %else %start;     ! ARRAY ELEMENTS IN RECORDS
                  %if NAM=1 %then %start;  ! ARRAYNAMES-FULLHEAD IN RECORD
                     XD = XD+Q
                     ACCESS = MODE+8
                     BASE = BS; DISP = DP; XDISP = XD
                     NAMEOP(6,AHEADSIZE,NAMEP)
                     OPND1 = NAMEOPND
                     OPND1_PTYPE = AHEADPT
                     PTYPE = LCELL_PTYPE; UNPACK
                     CANAME(Z,3,OPND1);  ! ARRAY MODE SETS DISP,AREA&BASE
                     XD = 0
                  %finish %else %start;  ! ARRAY RELATIVE HEAD IN GLA
                     FETCH RAD;          ! 32 BIT ADDR TO ETOS
                     OPND1 = 0; OPND1_PTYPE = AHEADPT
                     OPND1_FLAG = LOCALIR
                     OPND1_D = Q
                     CANAME(Z,3,OPND1);  ! RECORD REL ARRAY ACCESS
                                         ! CAN RETURN ACCESS=1 OR 3 ONLY
                      TR =0
!                     TR = BRECTRIP(AAINC,X'51',0,RADOPND,EXPOPND)
                     EXPOPND_FLAG = REFTRIP
                     EXPOPND_D = TR
!                     TRIPLES(TR)_X1 = PTYPE&255;  ! FRIG FOR PERQ&ACCENT 3%c
                                                  WORD BYTE PTRS!
                     XD = 0
                  %finish
                  NAMEP = -1
                  XDISP = XD
                  %if TYPE=3 %then%start
                     CENAME(ACCESS,QQ,BASE,DISP,XD)
                     c=acc;         ! to return element size
                  %else
                        %if Z>=11 %then FAULT(17,0,ENAME)
                  %finish
                                         ! AN ELEMENT IS NOT AN ARRAY FOR P-P
               %finish
               ACC = C;                  ! NEEDED FOR STRING ARRAYS
               %return
%routine FETCH RAD
!***********************************************************************
!*       SET ACC TO 32 BIT ADDRESS OF RECORD.                          *
!***********************************************************************
                  ACCESS = MODE+4
                  BASE = BS
                  DISP = DP; XDISP = XD
               ptype=rptype; unpack
                  NAMEOP(4,4,NAMEP)
                 ptype=eptype; unpack
                  RADOPND = NAMEOPND
               %end
            %end;                        ! OF ROUTINE CENAME
         %end;                           ! OF ROUTINE CRNAME
         %routine CSTREXP(%integer MODE)
!***********************************************************************
!*       PLANT IN-LINE CODE FOR CONCATENATION. A WORK AREA IN THE      *
!*       CURRENT STACK FRAME IS USUALLY REQUIRED.                      *
!*       ON ENTRY:-                                                    *
!*       MODE=0    NORMAL. WK AREA NOT USED FOR ONE OPERAND EXPSSNS    *
!*       MODE=1     STRING MUST GO TO WORK AREA                        *
!*       2**5 BIT OF MODE SET IF FULL VIRTUAL ADDRESS REQUIRED         *
!*       2**4 BIT OF MODE IS SET IF WK-AREA NOT TO BE FREED ON EXIT    *
!*       ON EXIT:-                                                     *
!*       VALUE#0 %if RESULT IN A WORK AREA(CCOND MUST KNOW)            *
!***********************************************************************
            %integer PP,WKAREA,DOTS,ERR,KEEPWA,FNAM,I,ENDFLAG,Firsttrip,trip
            %record (RD) OPND1,OPND2,OPND3
            %integer %fn %spec STROP(%record (RD) %name OPND)
            KEEPWA = MODE&16; MODE = MODE&15
            OPND1 = 0
            OPND1_PTYPE = X'35'
            OPND1_FLAG = LOCALIR
            OPND1_XTRA = 268;            ! THE WORK AREA SIZE NEEDED FOR
            PP = P; STRINGL = 0; FNAM = 0; WKAREA = 0
            P = P+3;                     ! LENGTH OF CONSTANT PART
            ERR = 72; ->ERROR %unless A(P)=4
            P = P+1
            DOTS = 0;                    ! NO OPERATORS YET
            ENDFLAG = 0
            STRINGL = 0
            ERR = STROP(OPND2);          ! GET FIRST OPERAND
            %if STRRESINWA=NO %and PTYPE&X'1000'#0 %then MODE = 1
                                         ! IF FN RESULT NOT IN A WORK AREA
                                         ! COPY IN FROM TOP OF STACK
                                         ! SOMETIMES NOT NECESSARY BUT FN=FN%c
                                         COMPARISONS
                                         ! WILL GO WRONG WITHOUT THIS
            ->ERROR %unless ERR=0
NEXT:       %if A(P)=2 %then ENDFLAG = 1 %else %start
               %if A(P+1)#CONCOP %then ERR = 72 %and ->ERROR
               P = P+2
!
! LEFT TO RIGHT EVALUATION IS DEFINED BUT IF FIRST OPERAND IS ACONST
! WE CAN EVALUATE THE SECOND. THIS ENABLES US TO FOLD "TOSTRING(NL)" ETC
!
               %if DOTS=0 %and OPND2_FLAG=LCONST %then %start
                  ERR = STROP(OPND3)
                  ->ERROR %unless ERR=0
               %finish %else OPND3_FLAG = 255
            %finish
            %if ENDFLAG=0 %and OPND2_FLAG=LCONST=OPND3_FLAG  %and mode=1 %start
!
! CAN FOLD OUT A CONCATENATION HERE
!
               I = CONCAT
               CTOP(I,ERR,0,OPND2,OPND3)
               %if I=0 %then ->NEXT;     ! FOLDED OUR
            %finish
            %if DOTS=0 %start
               %if  ENDFLAG#0 %start;  ! NO RUN-TIME OPERATIONS
                  outopnd(opnd2,0)
                  OPND1 = OPND2; ->TIDY
               %finish
               Firsttrip = BRECTRIP(PRECC,X'35',0,OPND1,OPND2)
               OPND1_FLAG = REFTRIP
               OPND1_D = Firsttrip;              ! CHANGE TO TRIPLES REFERENCE
               DOTS = DOTS + 1
            %finish
            %if ENDFLAG=0 %then %start
               %if OPND3_FLAG=255 %start;  ! 3 NEED EVALUATION
                  ERR = STROP(OPND3)
                  ->ERROR %unless ERR=0
               %finish
               OPND1_D = BRECTRIP(CONCAT,X'35',0,OPND1,OPND3)
               dots = dots +1; ->NEXT
            %finish
!          printtrips(triples)
            outstring("imp_concat(") %for i=2,1,DOTS
            trip=Firsttrip
            %while trip #0 %cycle
               outopnd(Triples(trip)_opnd2,0)
               %if trip=Firsttrip %then outstring(",") %else %start
                  outstring(")")
                  outsym(',') %unless Triples(trip)_puse=0
               %finish
               trip=Triples(trip)_puse
            %repeat
TIDY:                                    ! FINISH OFF
            EXPOPND = OPND1;             ! LEAVE REULT IN EXPOPND
            VALUE = WKAREA
            P = P+1;                     ! PAST REST OF EXPRN
            RETURN WSP(WKAREA,268) %if KEEPWA=0 %and WKAREA>0
            STRINGL = 0
            %return
ERROR:      FAULT(ERR,0,FNAM)
            EXPOPND = OPND1
            BASE = RBASE; DISP = 0
            VALUE = 0; ACCESS = 0
            P = PP; SKIP EXP
            %return
            %integer %fn STROP(%record (RD) %name OPND)
!***********************************************************************
!*       DEALS WITH OPERAND FOR CONCATENATION. RETURN RESULT=0 FOR     *
!*       VALID OPERAND OTHERWISE AN ERROR NUMBER.                      *
!***********************************************************************
               %integer CTYPE,alt,I
               alt  = A(P);              ! ALTERNATIVE OF OPERAND
               OPND = 0
               %result = 75 %if alt >2
               %if alt #1 %then %start
                  CTYPE = A(P+1);        ! GET CONST TYPE & LOSE AMCK FLAGS
                  %if CTYPE=X'35' %then %start
                     PTYPE = CTYPE
                     STRINGL = A(P+2)
                     OPND_PTYPE = CTYPE
                     OPND_FLAG = LCONST
                     OPND_D = P+2
                     OPND_XTRA = STRINGL
                     P = P+STRINGL+3
                  %finish %else %result = 73
               %finish %else %start
                  P = P+1;               ! MUST CHECK FIRST
                  COPYTAG(FROMAR2(P),NO)
                  %if PTYPE=x'1006' %then TYPE = ACC&7;  ! special for "string"
                  %if TYPE=3 %then REDUCE TAG(NO)
                  %if 5#TYPE#7 %then FNAM = FROMAR2(P) %and %result = 71
                  %if ptype=x'4035' %and A(P+2)=2=A(P+3) %and mode#0 %start
                      opnd_flag=lconst; opnd_ptype=x'35'
                      opnd_d=midcell; opnd_xtra=kform
                      stringl=opnd_xtra
                      p=p+4
                      %result=0
                  %finish
                  %if PTYPE=X'35' %and A(P+2)=2=A(P+3) %start
                     OPND_FLAG = DNAME
                     OPND_XTRA = 0
                     OPND_PTYPE <- PTYPE
                     OPND_D = FROMAR2(P)
                     P = P+4
                  %finish %else %start
                     OPND_FLAG = ARNAME
                     OPND_D = P
                     p=p+2; skip app
                     %while a(p)=1 %cycle
                        p=p+3; skip app;
                     %repeat
                     p=p+1
                  %finish
                  STRINGL = 0
               %finish
               %result = 0
            %end;                        ! OF INTEGERFN STROP
         %end;                           ! OF ROUTINE CSTREXP
%routine CRES(%integer LAB)
!**********************************************************************
!*       COMPILES A RESOLUTION E.G A->B.(C).D.(E).F AND JUMPS TO LAB   *
!*       ON FAILURE. (LAB=0 FOR UNCONDITIONAL RESOLUTION TO PERM ON    *
!*       FAILURE ).                                                    *
!*       THE  METHOD IS TO CALL A SUBROUTINE PASSING 5 PARAMS:-        *
!*       P1(32BITS)  POINTS TO LHS(A)                                  *
!*       P2(16BITS) ORIGINAL LENGTH OF A                               *
!*       P3(32BITS) FULL POINTER TO BYTES USED UP INITIALLY 0          *
!*       P4(48BITS) STRING TO CONTAIN FRAGMENT                         *
!*                (PASSED AS LMAX FOLLOWED BY 32BIT ADDRESS)           *
!*       P5(32BITS) THE EXPRESSION PASSED AS 32 BIT ADDRESS            *
!*       SUBROUTINE TRIES TO PERFORM THE RESOLUTION AND SETS THE       *
!*       RESULT TO TRUE IF IT SUCCEEDS.                                *
!*                                                                     *
!*       ON ENTRY LHS IS IN THE ESTACK(32BITS).                        *
!*       P POINTS TO P(+') OF RHS DEFINED AS (+')(OPERAND)(RESTOFEXP)  *
!*                                                                     *
!$       THE ROUTINE IS COMPACT BUT DIFFICULT TO FOLLOW (OR ALTER)     *
!*       THE TIME IN PERM IS LARGE SO IT IS NOT WORTHWHILE TO PERSUE   *
!*       CODE EFFICIENCY TOO INDUSTRIOUSLY .                           *
!**********************************************************************
%integer P1,P2,SEXPRN,W,LAST,ERR,FNAM,JJ
%record (RD) OPND1,OPND2
      LAST = 0; FNAM = 0;          ! =1 WHEN END OF EXPRNSN FOUND
      SEXPRN = 0;                  ! RESOLUTION(BRKTD) EXPRESSNS
      P1 = P
      ERR = 43
      %if NAMEOPND_PTYPE&X'C700'=X'4000' %then %c
         FNAM = NAMEOPND_D %and ->ERROR
                                   !  CANT RESOLVE A CONST STRING
      ERR = 74;                    ! NORMAL CRES FAULT
      GET WSP(W,4);                ! TO HOLD P1,P2 AND VALUE OF P3
      OPND1_PTYPE = X'61'
      OPND1_FLAG = LOCALIR
      OPND1_D = RBASE<<16!W
      P = P+3
      ->RES %if A(P)=4;            ! LHS MUST BE A STRING
                                   ! BUT THIS CHECKED BEFORE CALL
            ERR = 72
ERROR:FAULT(ERR,0,FNAM)
      P = P1; SKIP EXP; %return
RES:  P = P+1;                     !    TO P(OPERAND)
      %if A(P)=3 %then %start;     ! B OMITTED
         OPND2_PTYPE = X'51'
         OPND2_FLAG = SCONST
         OPND2_D = 0;              ! ZERO CONST FOR NO DEST
         outstring("NULL,")
      %finish %else %start
         ->ERROR %unless A(P)=1;   ! P(OPERAND)=NAME
         P = P+1; P2 = P
         CNAME(2)
         outsym(',')
         OPND2 = NAMEOPND
         %if TYPE#5 %then ERR = 71 %and FNAM = FROMAR2(P2) %and ->ERROR
         %if A(P+1)#CONCOP %then ERR = 72 %and ->ERROR
         P = P+2
      %finish
      ->ERROR %unless A(P)=3;      ! P(OPERAND)='('(EXPR)')'
      SEXPRN = SEXPRN+1; P = P+1
      CSTREXP(0);                 ! FULL 32 BIT ADDRESS
      outsym(',')
      OPND2_PTYPE = X'51'; OPND2_FLAG = SCONST
      OPND2_D = LAB
      %if A(P)=2 %then outstring("NULL") %and ->END
      %if A(P+1)#CONCOP %then ERR = 72 %and ->ERROR
      P2 = P+1; P = P2+1
      %if A(P)=3 %then %start
        P = P2
         outstring("_imptempstring)")
         %if lab=0 %then outsym(';') %else outsym('+')
         outstring("imp_resolve(_imptempstring,")
         ->RES
      %finish
      ->ERROR %unless A(P)=1
      P = P+3 %and SKIP APP %until A(P)=2
      %if A(P+1)=1 %then %start
        P = P2
         outstring("_imptempstring)")
         %if lab=0 %then outsym(';') %else outsym('+')
         outstring("imp_resolve(_imptempstring,")
         ->RES
      %finish
      P1 = P+1
      P = P2+2
      CNAME(2)
      P = P1
END:
      P = P+1
%end
         %routine SAVE STACK PTR
!***********************************************************************
!*    SAVE THE CURRENT STACK TOP AND POSSIBLY A DESCRIPTOR TO IT       *
!*    NEEDED ON AUX STACK IMPLEMENTATIONS AND ALSO IN BEGIN-END BLOCKS *
!*    SO ARRAYS CAN BE UNDECLARED ON BLOCK EXIT. ONLY ACTS ON THE FIRST*
!*    CALL IN ANY BLOCK OR ROUITNE                                     *
!***********************************************************************
            %integer JJJ
            %if CURRINF_AUXSBASE=0 %start
               JJJ = UTEMPTRIP(SSPTR,MINAPT,0,N);  ! SAVE THE STACK POINTER
               CURRINF_AUXSBASE = N
               %if TARGET=EMAS %and PARM_STACK=0 %then N = N+16 %else N = N+4
            %finish
         %end
         %routine CEND(%integer KKK)
!***********************************************************************
!*       DEAL WITH ALL OCCURENCES OF '%END'                            *
!*       KKK=PTYPE(>=X'1000') FOR ROUTINES,FNS AND MAPS                *
!*       KKK=0 FOR ENDS OF '%BEGIN' BLOCKS                             *
!*       KKK=1 FOR '%ENDOFPROGRAM'                                     *
!*       %endofprogram IS REALLY TWO ENDS. THE FIRST IS THE USERS      *
!*       AND THE SECOND IS PERMS. KKK=2 FOR A RECURSIVE CALL OF CEND   *
!*       ON END OF PROGRAM TO DEAL WITH THE %end CORRESPONDING TO      *
!*       THE %begin COMPILED IN THE INITIALISATION SEQUENCE            *
!***********************************************************************
            %integer KP,JJ,BIT
            %record (TAGF) %name RCELL,TCELL,PCELL
            %routine %spec DTABLE(%integer LEVEL)
            SET LINE %unless KKK=2
            BIT = 1<<LEVEL
!
! NOW PLANT AN ERROR EXIT FOR FNS AND MAPS - CONTROL SHOULD BE RETURNED
! VIA %result= AN SHOULD NEVVER REACH THE %end INSTRUCTION
!
            %if KKK&X'3FFF'>X'1000' %and PARM_COMPILER=0 %and %c
               LAST INST=0 %then JJ = UCONSTTRIP(RTBAD,X'51',0,0)
                                         ! RUN FAULT 11
            %if KKK=0 %then %start;      ! BEGIN BLOCK EXIT
               %if PARM_TRACE=1 %then %start;  ! RESTORE DIAGS POINTERS
                  JJ = UCONSTTRIP(RDPTR,X'51',0,LEVEL-1)
               %finish
               JJ = CURRINF_AUXSBASE
               %if JJ#0 %then %start;    ! ARRAYS TO BE UNDECLARED
                  JJ = UCONSTTRIP(RSPTR,X'51',0,JJ)
               %finish
            %finish
            FORCE TRIPS;                 ! BEFOR LABEL LIST CLEARED IN OPT MODE
            NMAX = N %if N>NMAX;         ! WORK SPACE POINTER
!
! CLEAR OUT THE LABEL LIST FAULTING LABELS WITH JUMPS OUTSTANDING
! AS NOT SET AND COMMENTING ON LABELS NOT USED
!
            %while CURRINF_LABEL#0 %cycle
               POP(CURRINF_LABEL,I,J,KP)
               %if J&X'FFFF'#0 %then %start
                  J = J&X'FFFF'
                  %if 0<KP<=MAX ULAB %then FAULT(11,ASLIST(J)_S3&X'FFFF',KP)
                  CLEAR LIST(J)
               %finish %else %start
                  %if I&LABUSEDBIT=0 %and KP<MAX ULAB %then WARN(3,KP)
               %finish
            %repeat
!
            NMAX = (NMAX+7)&(-8)
            CURRINF_SNMAX = NMAX
!
! FOR ROUITNE CHECK PARAMETER LIST FOR ARRAY PARAMETERS AND PASS
! BACK ANY INFORMATION ON DIMENSIONALAITY GLEANED DURING THE BODY
!
            JJ = CURRINF_M-1;            ! RT NALE
            %if JJ>=0 %start
               RCELL == ASLIST(TAGS(JJ))
               %if RCELL_PTYPE&X'1000'#0 %start;  ! NAME COULD BE REDECLARED%c
                                                  AS LOCAL
                                         ! IF THIS HAPPENS SKIP GLEANING
                  K = RCELL_SLINK
                  %while K>0 %cycle;     ! DOWN PARAM LIST
                     TCELL == ASLIST(K)
                     %if TCELL_PTYPE&X'F00'=X'500' %and TCELL_UIOJ&15=0 %start
                                         ! TCELL IS ARRAY OF UNKNOWN DIMENSION
                        PCELL == ASLIST(TAGS((TCELL_UIOJ>>4)&4095))
                                         ! ONTO LOCAL TAGS
                        TCELL_UIOJ = TCELL_UIOJ!PCELL_UIOJ&15
                                         ! COPY BACK DIMENSIO
                     %finish
                     K = TCELL_LINK
                  %repeat
               %finish
            %finish
!
! NOW PLANT THE BLOCK EXIT SEQUENCE
!
            %if KKK&X'1000'#0 %then JJ = UCONSTTRIP(RTXIT,X'51',0,KKK)
            JJ = UCONSTTRIP(XSTOP,X'51',0,KKK) %if KKK=1;  ! %stop AT%c
                                                           %endofprogram
            CLEAR LIST(TWSPHEAD);        ! CAN NOT CARRY FORWARD
            %cycle JJ = 0,1,4
               CLEAR LIST(CURRINF_AVL WSP(JJ));  ! RELEASE TEMPORARY LOCATIONS
            %repeat
            %if TARGET=PERQ %or TARGET=ACCENT %then FORCE TRIPS
                                         ! PERQ NEED THIS BEFORE DTABLE AS
                                         ! DTABLE OFFSET GOES IN RTDICT

                                         ! PNX MUST HAVE DATBLE FIRST OR
                                         ! FILLING OF DTABLE REFS FAILS
            DTABLE(LEVEL);               ! OUTPUT DIAGNOSTIC TABLES
            FORCE TRIPS
                                         ! ALL TRIPS MUST BE DEALT WITH
                                         ! BEFORE CURRENT LEVELS ARE CHANGED
            %while CURRINF_UNATT FORMATS#0 %cycle
               POP(CURRINF_UNATT FORMATS,I,J,JJ)
               CLEAR LIST(I)
               CLEAR LIST(J)
               CLEAR LIST(JJ)
            %repeat
!
! NOW CLAIM THE STACK FRAME BY FILING THE ASF IN THE BLOCK ENTRY CODING
!
            %if KKK=2 %then %return
!
! RETURN TO PREVIOUS LEVEL PROVIDED THERE IS A VALID ONE !
!
            %unless LEVEL>2 %or (LEVEL=2 %and PARM_CPRMODE=2) %then %start
               %if KKK=1 %and LEVEL=2 %then KKK = 2 %else FAULT(109,0,0)
                                         ! SHOULD BE CHKD IN PASS1
            %finish
            LEVEL = LEVEL-1
            CURRINF == LEVELINF(LEVEL)
            %if KKK&X'1000'#0 %then %start
               RLEVEL = CURRINF_RBASE
               RBASE = RLEVEL
            %finish
!
! RESTORE INFORMATION ABOUT THE (NEW) CURRENT LEVEL
!
            NMAX = CURRINF_SNMAX %if KKK&X'1000'#0
            N = CURRINF_SN
            %if KKK=2 %then CEND(KKK);   ! ROUND AGAIN FOR 'ENDOFPROGRAM'
!
! COMPLETE THE JUMP AROUND ALL NON-EXTERNAL ROUTINES EXCEPT WHEN
! %trustedprogram IS IN OPERATION.
!
            %if KKK&X'1000'#0 %and PARM_COMPILER=0 %and (RLEVEL>0 %or %c
               PARM_CPRMODE#2) %then %start
               JJ = NEXTP+6
               %unless A(NEXTP+5)=11 %and A(JJ+FROMAR2(JJ))=2 %start
                  JJ = ENTER LAB(CURRINF_JROUND,1)
                  CURRINF_JROUND = 0
               %finish
            %finish
            %return
!
! LAYOUT OF DIAGNOSIC TABLES
! ****** ** ********* ******
!
! THE BOUND FIELD OF PLT DESCRIPTOR STORED AT (LNB+3 & LNB+4) IF
! USED TO CONTAIN A DISPLACEMENT RELATIVE TO THE START OF SST OF THE
! DIAGNOSTIC TABLES FOR THE BLOCK OR ROUTINE BEING EXECUTED.
! A ZERO BOUND MEANS NO DIAGNOSTIC REQUESTED.(NB THIS MAY MEAN A DUMMY
! FIRST WORD IN THE SST).
! THE ABSOLUTE ADDRESS OF THE SST FOR THE CURRENT CODE SEGMENT WILL
! ALWAYS BE FOUND IN THE STANDARD 10 WORDS OF THE GLA/PLT
!
! FORM OF THE TABLES:-
!
! WORD 0    =   LINE OF RT IN SOURCE PROG <<16 ! LINE NO POSN(FROM LNB)
! WORD 1    =   (12 LANG DEPENDENT BITS)<<18 ! ENVIRONMENT
!                ( TOP 2 BITS OF LANG DEPENDENT HAS LITL FROM PTYPE)
!                 ( BOTTOM 4 BITS HAVE TEXTUAL LEVEL)
! WORD 2    =   DISPLAY POSN (FROM LNB)<<16 ! RT TYPE INFO
! WORD 3    =   ZERO FOR BLKS OR STRING(<=11BYTES) BEING THE
!               RT NAME. THIS WILL TAKE WORDS 4 AND 5 IF NEEDED
! WORD 6    =  LANGUAGE DEPENDENT INFO . IMP ON CONDITIONS ETC
!
! THE REST IS MADE UP OF VARIABLE ENTRIES AND THE SECTION IS TERMINATED BY
! A WORD OF X'FFFFFFFF'
!
!  EACH VARIABLE ENTRY CONSISTS OF THE VARIABLE WORD FOLLOWED BY
! THE VARIABLE NAME AS A STRING. THE WORD CONSISTS OF
! BITS 2**31 TO 2**20 TYPE INFORMATION (MAY BE LANGUAGE DEPENDENT
! BIT  2**19  =0 UNDER LNB =1 IN GLA
! BITS 2**18 TO 2**0 DISPLACEMENT FROM LNB(GLA) IN BYTES
!
!
! THE ENVIRONMENT IS A POINTER (RELATIVE TO SST) OF THE NEXT OUTERMOST
! BLOCK OR A POINTER TO GLOBAL OWNS, EXTERNAL OR COMMON AREAS
! A ZERO MEANS NO ENCLOSING BLOCK. WORD1=WORD3=0 IS AN
! IMP MAIN PROGRAM AND WILL TERMINATE THE DIAGNOSTICS.
!
            %routine DTABLE(%integer LEVEL)
!***********************************************************************
!*      THIS ROUTINE LOOKS AT THE DECLARATIONS FOR THE CURRENT LEVEL & *
!*      SETS UP THE SEGMENT OF SHARABLE SYMBOL TABLES TO DESCRIBE THEM.*
!*      FOR MAIN PROGRAMS OR EXTERNAL ROUTINES THE 'GLOBAL' VARIABLES  *
!*      (IF ANY) ARE ALSO INCLUDED.                                    *
!***********************************************************************
%integerfnspec swopof(%integer ptype,value)
%string (11) RT NAME
%string (11) LOCAL NAME
%if 1<<host&unsignedshorts=0 %start
   %record %format HEADF(%short RTLINE,LINEOFF,OFLAGS,ENV,
      DISPLAY,RTFLAGS,(%integer IDHEAD %or %string (11) RTNAME))
   %record %format VARF(%short FLAGS,DISP, %string (11) VNAME)
%finish %else %start
   %record %format HEADF(%half %integer RTLINE,LINEOFF,OFLAGS,
      ENV,DISPLAY,RTFLAGS,
      (%integer IDHEAD %or %string (11) RTNAME))
   %record %format VARF(%half %integer FLAGS,DISP,
      %string (11) VNAME)
%finish
%record (HEADF) %name DHEAD
%record (VARF) %name VAR
%record (LISTF) %name LCELL,scell
%record(swdataform)%name swdata
%const %integer LARRROUT=X'F300'
%record (TAGF) T
%integer DPTR,LNUM,ML,KK,JJ,Q,DEND,BIT,S4,LANGD,RULES,II
%const %integer DLIMIT=700
%integer %array DD(0:DLIMIT);  ! BUFFER FOR SEGMENT OF SST
!
! FILL ALL OUTSTANDING REFERENCES TO THIS DIAGS BLOCK
!
      BIT = 1<<LEVEL
      LANGD = KKK>>14<<30!LEVEL<<18;    ! GET LITL FROM PTYPE
      %if PARM_TRACE=1 %then PDATA(DAREA,4,0,ADDR(DD(0)));    ! TO WORD BOUNDARY
      FILL DTABREFS(CURRINF_RAL)
      PUSH(LEVELINF(LEVEL-1)_RAL,DAREA,CAS(DAREA)+4,LANGD) %if PARM_TRACE#0
      DHEAD == RECORD(ADDR(DD(0)))
      DHEAD_RTLINE <-swopof(X'41', CURRINF_L)
      DHEAD_LINEOFF <-Swop of(x'41', CURRINF_DIAGINF)
      DHEAD_OFLAGS <-Swop of(x'41', LANGD>>16)
      DHEAD_ENV = 0
      %if TARGET=IBM %or TARGET=IBMXA %or TARGET=AMDAHL %then %c
         DHEAD_DISPLAY = CURRINF_RBASE %else %c
         DHEAD_DISPLAY <-Swop of(x'41', CURRINF_DISPLAY)
      DHEAD_RTFLAGS <-Swop of(x'41', CURRINF_FLAG&X'3FFF')
      ML = CURRINF_M;                   ! ROUTINE NAME(=0 FOR %begin)
      %if ML#0 %then ML = WORD(ML-1);   ! IF NOT BLOCK GET DIRPTR
      LNUM = WORKA_LETT(ML);            ! LENGTH OF THE NAME
      DPTR = 4; DEND = 0
      %if LNUM=0 %then DHEAD_IDHEAD = 0 %else %start
         Q = ADDR(WORKA_LETT(ML))
         RT NAME <- STRING(Q);          ! FOR RTS MOVE IN 1ST 32 CHARS
         LNUM = LENGTH(RT NAME)
         DHEAD_RTNAME = RTNAME;         ! AND UPDATE POINTER PAST
!         %if HOST#TARGET %and PARM_TRACE#0 %then %c
!            CHANGE SEX(ADDR(DD(0)),12,LNUM+1)
         DPTR = DPTR+LNUM>>2;           ! ACTUAL NO OF CHARS
      %finish
      DD(DPTR) <-Swop of(X'51',CURRINF_ONWORD);! ON CONDITION WORD
      DPTR = DPTR+1
      JJ = CURRINF_NAMES
      %while 0<=JJ<X'3FFF' %cycle
         LCELL == ASLIST(TAGS(JJ))
         T = LCELL
!     printstring("undeclaring"); printstring(printname(jj)); newline
                                         ! OBTAIN NEXT NAME FORM DECLNS
!
! GET ONLY THE MINIMUM OF DETALS NECESSARY
!
         S4 = LCELL_LINK
         PTYPE = T_PTYPE; TYPE = PTYPE&15
!
! FAULT ALL UNUSED NAMES EXCEPT CONSTINTEGERS&REALS
!
         %if (TYPE>2 %or PTYPE&X'FF00'#X'4000' %or %c
            PARM_STACK#0) %and T_UIOJ&X'C000'=0 %then WARN(2,JJ)
         I = T_UIOJ>>4&15
         J = T_UIOJ&15
         K = T_SLINK
!
! ALLOW OWNS (LITL=0) AND EXTERNALS (=2) NOT CONSTS(=1) OR EXTRINSIC(=3)
!
         %if PARM_DIAG#0 %and PTYPE&X'7300'<=X'200' %and %c
            DPTR<DLIMIT-3 %and (1<=TYPE<=3 %or TYPE=5) %start
            Q = ADDR(WORKA_LETT(WORD(JJ)));  ! ADDRESS OF NAME
            %if I=0 %then II = 1 %else II = 0;! GLA OR LNB BIT
            VAR == RECORD(ADDR(DD(DPTR)))
            VAR_FLAGS <- swopof(X'41',PTYPE<<4!II<<2)
            %if ((PARAMS BWARDS=YES %and k<currinf_display) %or (STACK DOWN=YES %and k>Currinf_display))%c
                  %and PTYPE&X'C00'=0 %and II=0 %and %c
               (TYPE=3 %or TYPE=5) %start;! VALUE RECS&STRS
               %if K<Currinf_display %then rules=2 %else rules=1
                KK=rounding length(ptype,rules)
               K = (K+T_ACC+kk)&(\KK)
            %finish
            VAR_DISP <- swopof(X'41', K)
           %if target=eamd %and I#0 %Then var_disp=k+64;! frig so standard diags work
            LOCAL NAME <- STRING(Q);   ! TEXT OF NAME FROM DICTIONARY
            LNUM = LENGTH(LOCAL NAME)
            VAR_VNAME = LOCAL NAME;     ! MOVE IN NAME
            %if HOST#TARGET %and PARM_TRACE#0 %then %c
               CHANGE SEX(ADDR(DD(0)),4*DPTR+4,LNUM+1)
            DPTR = DPTR+(LNUM+8)>>2
         %finish
         %if J=15 %and PTYPE&X'3000'#0 %and T_UIOJ&X'C000'#0 %then %c
            FAULT(28,0,JJ)
                                         ! SPEC&USED BUT NO BODY GIVEN
         %if J=15 %and TYPE=4 %then FAULT(62,0,JJ)
         %if PTYPE&X'3000'#0  %then %start
!            printstring("clearing list for "); printstring(printname(jj)); newline; printlist(k)
            CLEAR LIST(K)
         %Finish
         %if TYPE=4  %then %start
!            printstring("clearing list for "); printstring(printname(jj)); newline; printlist(t_kform)
            CLEAR LIST(t_kform)
         %Finish
         %if type=6 %start
            scell==aslist(lcell_slink)
            swdata==record(scell_s1)
            outstring("goto "); outswadname(jj); outstring("_skip;"); outsym(NL)
            outswadname(jj); outstring("_despatch:"); outsym(NL)
            outstring("switch ("); outswadname(jj);
            outstring("_value) {"); outsym(NL)
            %for lnum=0,1,swdata_lseen-1 %cycle
               outstring("case ")
               p=swdata_slabs(lnum); csexp(x'51') { No symbolic consts}
               outstring(": goto "); outswadname(jj)
               outsym('_')
               p=swdata_slabs(lnum); labexp
               outsym(';'); outsym(NL)
            %repeat
            outstring("default:")
            %if swdata_default#0 %then %start
                outstring("goto "); outswadname(jj)
                outstring("_default;")
            %else
                outstring("BADSWITCH("); outswadname(jj); outstring("_value,__LINE__,__FILE__);")
            %finish
            outsym(NL); outsym('}'); outsym(NL)
            outswadname(jj); outstring("_skip:;"); outsym(NL)
            free(addr(swdata))
            kk=t_slink
            clear list(kk)
         %finish
         LCELL_LINK = ASL; ASL = TAGS(JJ)
         TAGS(JJ) = S4&X'3FFFF'
         JJ = S4>>18
      %repeat
      DD(DPTR) = -1;                    ! 'END OF SEGMENT' MARK (Not swopped!)
      DPTR = DPTR<<2+4
      %if PARM_TRACE=1 %then PDATA(DAREA,4,DPTR,ADDR(DD(0)))
                                         ! ADD TO SHARABLE SYM TABS
      %return
%integerfn Swopof(%integer ptype,value)
!***********************************************************************
!*      Does the byte swopping for cross compilers using rt in P4      *
!***********************************************************************
%record(rd)opnd
      %if host#target %then %start
         Opnd=0
         Opnd_d=value
        Opnd_ptype=ptype
         Reformatc(Opnd)
         value=Opnd_d
      %finish
      %result=Value
%end
%end;                        ! OF ROUTINE DTABLE
         %end
%routine DECLARE SCALARS(%integer XTRA)
!***********************************************************************
!*       THIS ROUTINE DECLARES A LIST OF SCALARS FROM INFORMATION      *
!*       IN THE GLOBAL VARIABLES ROUT,NAM,ARR,PREC,TYPE & ACC.IT WORKS *
!*       OUT ROUNDING FACTORS FOR ITSELF.                              *
!*       P POINTS TO THE NAMELIST ON ENTRY AND IS UPDATED.             *
!***********************************************************************
%integer INC,SCAL NAME,RL
      PACK(PTYPE)
      INC = ACC; SNDISP = 0
      RL = ROUNDING LENGTH(PTYPE,1)
      %if NAM#0 %and ARR=0 %then INC = PTRSIZE(PTYPE&127) %and RL=ptrrounding(ptype&127+128)
      %if NAM>0 %and ARR>0 %then INC = AHEADSIZE %and RL=rounding length(aheadpt,1)
      %if PTYPE=X'35' %and (ACC<=0 %or ACC>256) %then %c
         FAULT(70,ACC-1,0) %and ACC = 255
      %if type=5 %start
        outstring("char ")
      %finish %else outtype(ptype&255,xtra)
      %until A(P-1)=2 %cycle;      ! DOWN THE NAMELIST
         N = (N+RL+SFRAME MISALIGN)&(\RL)-SFRAME MISALIGN
         SCAL NAME = FROM AR2(P)
         %if nam#0 %then outstring("*")
         outname(scalname)
         P = P+3
         STORE TAG(SCAL NAME,LEVEL,RBASE,0,SNDISP,ACC,N,XTRA)
         N = N+INC
         %if type=5 %and nam=0 %start
           outstring(" ["); outint(acc);
           outstring("] ")
         %finish
         %if a(p-1)=1 %then outsym(',')
      %repeat
      N = (N+MIN PARAM SIZE-1)&(-MIN PARAM SIZE);  ! THIS IS NECESSARY !
%end
%integer %fn DOPE VECTOR(%integer TAMPER,TYPEP,ELSIZE,MODE,IDEN)
!***********************************************************************
!* Construcst a pseudo dope vector for the handling of arrays          *
!* which is as much like the compiler one as possible. Since           *
!* C arrays all start from 0 but Imp ones can start from anywhere      *
!* provision is needed to take off the lower bound from each index     *
!* on every access.                                                    *
!* The dope vector consists of:-                                       *
!*     word 0 ignored                                                  *
!*     word 1 dimensions<<16 ! element size                            *
!*     word 2 ignored                                                  *
!*     and then a triple for each dimension                            *
!*     word 0 the lower bound if constant                              *
!*     word 1 pointer to the lb expression                             *
!*     word 2 pointer to the ub expression                             *
!*                                                                     *
!* If TAMPER =YES then small +ve lower bounds are reset                *
!* to zero in the interests of access efficiency                       *
!*  IDEN is only for error messages                                    *
!*  Mode not relevant                                                  *
!***********************************************************************
%integer I,JJ,K,ND,D,M0,HEAD,NOPS,TYPEPP,PIN,etype,value
%record (RD) OPND
%record (LISTF) %name LCELL
%integer %array LBH,LBB,LBp,UBp(0:12)
%integer %array DV(0:39);    ! ENOUGH FOR 12 DIMENSIONS
      ND = 0; TYPEPP = 0; PIN = P
      M0 = 1
      %until A(P)=2 %cycle
         ND = ND+1; P = P+1
         LBp(ND)=p; etype=tsexp(value)
         p= LBp(ND)+3
         FAULT(37,0,IDEN) %and ND = 1 %if ND>12
         LBH(ND) = 0; LBB(ND) = 0
         NOPS=0
         TORP(LBH(ND),LBB(ND),NOPS,1)
         UBp(ND)=p
         skip exp
         %if imod(etype)=1 %start
            expop(LBH(ND),LBB(ND),NOPS,x'251')
            lbb(ND)=expopnd_d
         %else
            lbb(ND)=x'80000000'       { Mark as not known }
         %finish
      %repeat
      P = P+1
!
! now tamper with the lower bounds if permitted
!
      %if TAMPER=YES %start
         %cycle D = 1,1,ND
            %if LBB(d)>0 %and LBB(d)*ND<=6 %then LBB(d)=0
         %repeat
      %finish
!
! SET UP THE DOPEVECTOR 
!
      DV(1) = ND<<16!ELSIZE
      %for d=1,1,nd %cycle
         k=3*d
         DV(k)=LBB(d)
         DV(K+1)=LBp(d)
         DV(k+2)=UBp(d)
      %repeat

      K = 3*ND+2
      j = ND;                 ! set dimensionality
      SNDISP = 4*WORKA_CONST PTR
      I = SNDISP
      %cycle D = 0,1,K
         CTABLE(WORKA_CONST PTR) = DV(D)
         WORKA_CONST PTR = WORKA_CONST PTR+1
      %repeat
      %if WORKA_CONST PTR>WORKA_CONST LIMIT %then %c
         FAULT(102,WORKA_WKFILEK,0)
      %result = I
%end

%routine DECLARE ARRAYS(%integer FORMAT,FINF)
!***********************************************************************
!*       FORMAT=1 FOR 'ARRAYFORMAT'   =0 OTHERWISE                     *
!*       FINF>0 FOR RECORD FORMAT INFORMATION =0 OTHERWISE             *
!*       P IS AT P<ADECLN>   IN                                        *
!*                                                                     *
!*       P<ADECLN>=<NAMELIST> <BPAIR> <RESTOFDECLN>                    *
!*       P<BPAIR> = '('<EXPR>':'<EXRR><RESTOFBP>*')'                   *
!*                                                                     *
!*       ARRAYS WITH CONSTANT BOUNDS HAVE THEIR D-V IN THE SST         *
!*       ALL OTHER ARRAYS HAVE A DOPE VECTOR AMONG THE LOCALS AND GET  *
!*       THEIR SPACE OFF THE STACK AT RUN TIME                         *
!*       BOTH SORTS OF ARRAYS HAVE A FOUR WORD HEAD AND D-V TO EMAS    *
!*       SYSTEM STANDARDS                                              *
!***********************************************************************
%integer DVDISP,PP,DVF,ELSIZE,TOTSIZE,PTYPEP,ARRP,NN,ND,II,CDV,
   LWB,PTYPEPP,JJJ,JJ,TRIP1,RL,TOPp,iden
%record (RD) OPND1
      SAVE STACK PTR;              ! FOR LATER UNDECLARING
      ARRP = 2*FORMAT+1; ARR = ARRP; PACK(PTYPEP)
      ELSIZE = ACC
START:NN = 1; P = P+1;             ! NO OF NAMES IN NAMELIST
      PP = P; CDV = 0; PTYPEPP = PTYPEP
      P = P+3 %and NN = NN+1 %while A(P+2)=1
      P = P+3
      DVDISP = DOPE VECTOR(YES,TYPE,ELSIZE,1,FROMAR2(PP))
      TOPP=P
      ND = J
      CDV = 1
      %if LWB=0 %and FORMAT=0 %then PTYPEPP = PTYPEP+256
      SNDISP = SNDISP>>2
      DVDISP=DVDISP>>2
DECL:                                    ! MAKE DECLN - BOTH WAYS
      J = ND
      RL=ROUNDINGLENGTH(AHEADPT,1)
      N = (N+RL)&(\RL);              ! MAY BE BENEFITS IN WORD ALIGNMENT
      %cycle JJJ = 0,1,NN-1;       ! DOWN NAMELIST
         iden = FROM AR2(PP+3*JJJ)
         PTYPE = PTYPEPP; UNPACK
         STORE TAG(iden,LEVEL,RBASE,ND,dvdisp,ELSIZE,N,FINF)
         N = N+AHEADSIZE
         %if format=0 %start
             %if ptypepp&15=5 %then outstring("char ") %else outtype(ptypepp&255,finf)
            outname(iden)
            %for ii=nd,-1,1 %cycle
               p=ctable(dvdisp+3*ii+2)
               outstring(" [")
               csexp(x'51')
               %if ctable(dvdisp+3*ii)=x'80000000'%start
                  outsym('-'); p=ctable(dvdisp+3*ii+1)
                  outsym('('); csexp(x'51'); outstring(")+1")
               %finish %else %if ctable(dvdisp+3*ii)<1 %start
                  outsym('+'); outint(1-ctable(dvdisp+3*ii))
               %finish %else %if ctable(dvdisp+3*ii)>1 %start
                  outsym('-'); outint(ctable(dvdisp+3*ii)-1)
               %finish
               outsym(']')
               %if ptypepp&15=5 %start
                 outstring(" ["); outint(elsize);
                 outstring("] ")
               %finish
            %repeat
            %if jjj#NN-1 %then outsym(';') %and outsym(NL)
         %finish
      %repeat
      P = TOPP+1;                     ! PAST REST OF ARRAYLIST
      %if A(P-1)=2 %then %return
      outsym(';') %and outsym(NL)
      ->start
%end
         %integer %fn ROUNDING LENGTH(%integer PTYPE,RULES)
!***********************************************************************
!*    RULES=0 IN RECORDS(BEST DEFINED)                                 *
!*    RULES=1 IN STACK FRAME(MOST LATITUDE)                            *
!*    RULES=2 AS PARAMETERS(FUNNY HARDWARE CONSIDERATIONS)             *
!***********************************************************************
            %if PTYPE&X'1000'#0 %then %result = PTR ROUNDING(128*RULES)
                                         ! TREAT RT PARAMS AS %name
            %if PTYPE&X'C00'#0 %then %c
               %result = PTR ROUNDING(PTYPE&X'7F'+128*RULES)
            %result = RNDING(PTYPE&X'7F'+128*RULES)
         %end
         %routine CLT
!***********************************************************************
!*       DEAL WITH PHRASE TYPE AND SET PREC,TYPE & ACC                 *
!*       ONLY PROBLEM ARE STRINGS WHICH HAS OPTIONAL MAX LENGTH ALSO   *
!*       RECORD WHICH HAVE A FORMAT                                    *
!*       P ON PHRASE TYPE AT ENTRY - TO NEXT PHRASE AT EXIT.           *
!***********************************************************************
            %integer ALT,PTYPEP,I,FLAGS,SJ
            ALT = A(P)
            FLAGS = TYPEFLAG(ALT)
            %if FLAGS&X'8000'#0 %then %c
               P = P+1 %and FLAGS = TYPEFLAG(A(P)+FLAGS&15)
            %if FLAGS&X'4000'#0 %then P = P+1;  ! ALLOWS BYTE OR BYTEINTEGER%c
                                                ETC
            %if FLAGS&X'2000'#0 %then WARN(8,0);  ! SUBSTITUTION MADE
            %if FLAGS&X'1000'#0 %then FAULT(99,0,0)
            PREC = FLAGS>>4&15
            TYPE = FLAGS&7
            P = P+1
            ACC = BYTES(PREC)
            PACK(PTYPEP);                ! PRESERVE ALL COMPONENT
                                         ! BEFORE CALLINT INTEXP ETC
            %if TYPE=5 %then %start;     ! P<TYPE>='%STRING'
               %if A(P)=1 %then %start;  ! MAX LENGTH GIVEN
                  %if A(P+1)=1 %start;   ! EXPRESSION NOT STAR
                     P = P+4
                     %if INTEXP(I,MINAPT)#0 %then FAULT(41,0,0) %and i=255
                     FAULT(70,I,0) %unless 1<=I<=255
                     ACC = I+1
                     PTYPE = PTYPEP; UNPACK
                  %finish %else ACC = 0 %and P = P+2
               %finish %else ACC = 0 %and P = P+1
            %finish
            KFORM = 0
            %if TYPE=3 %then %start
               SJ = J
               KFORM = CFORMATREF
               PTYPE = PTYPEP
               UNPACK
               J = SJ
            %finish
         %end
         %routine CQN(%integer P)
!***********************************************************************
!*       SET NAM & ARR FROM ALTERNATIVE OF PHRASE <QNAME'>             *
!*       P<QNAME'>='%arrayname','%name',<%NULL>                        *
!*       P POINTS TO THE ANALYSIS RECORD ENTRY AS IS NOT UPDATED       *
!***********************************************************************
            %integer I
            I = A(P); NAM = 0; ARR = 0
            %if I=1 %then ARR = 1;       ! ARRAYNAMES
            %if I<=2 %then NAM = 1;      ! ARRAYNAMES & NAMES
         %end

%routine CRSPEC(%integer M)
!***********************************************************************
!*    MODE=0  FOR NORMAL ROUTINE SPEC                                  *
!*    MODE=1 FOR EXTERNAL(ETC) ROUTINE SPECS XREF NEEDED               *
!*    P ON ENTRY TO P(RT) IN (RT)(MARK)(%spec')(NAME)(FPP)             *
!***********************************************************************
%integer KK,JJ,TYPEP,OPHEAD,NPARMS,AXNAME,SACC,SKFORM,PCHKWORD,pcount
%record(listf) %name lcell
%string(255) ss
      LITL = EXTRN&3
      ACC = 0; KFORM = 0;          ! FOR NORMAL RTS-CLT WILL REVISE
      %if A(P)=1 %then %start;     ! P<RT>=%routine
         TYPEP = LITL<<14!X'1000'
         P = P+4;                  ! IGNORING ALT OF P(SPEC') and hole
      %finish %else %start;        ! P<RT>=<TYPE><FNORMAP>
         ROUT = 1; ARR = 0; P = P+1
         CLT; NAM = 0
         %if A(P)=2 %then NAM = 2;  ! 2 FOR MAP 0 FOR FN
         PACK(TYPEP)
         P = P+4;                  ! AGAIN IGNORING ALT OF P(SPEC') and hole
      %finish
      KK = FROM AR2(P)
      AXNAME = ADDR(WORKA_LETT(WORD(KK)))
      JJ = 0
      P = P+3
      SACC = ACC; SKFORM = KFORM;  ! FOR RECORD MAPS WITH PARAMS
      %if A(P-1)=1 %then %start
         %if LITL=0 %then WARN(10,0)
         MOVE BYTES(A(P)+1,ADDR(A(0)),P,ADDR(A(0)),WORKA_ARTOP)
         outstring("#define "); outstring(string(axname))
         AXNAME = ADDR(A(WORKA_ARTOP))
         outsym(' ')
         %if string(axname)="s_cstring" %then outstring("s__cstring") %else outstring(string(axname))
          outsym(NL)
         WORKA_ARTOP = (WORKA_ARTOP+4+A(P))&(-4)
         P = P+A(P)+1
      %finish
      CFPLIST(OPHEAD,NPARMS)
      PCHKWORD = 0
      ss=string(axname)             { symbol table vsn of name }
      %if 0<=m<=1 %start
         %unless typep&x'c000'#0 %andc
             (ss="malloc" %or ss="free" %or ss="realloc" %or ss="perror" %orc
              ss="getcwd"  %or ss="strlen") %c
             %then %start
!            %if typep&x'c000'=0 %then outstring("static ")
            %if typep&x'c000'=x'8000' %then outstring("extern ")
            outtype(typep&255,skform)
            %if typep&x'800'#0 %and typep&7#5 %then outsym('*')
            outname(kk); outsym('('); outsym(' ')
            lcell==aslist(ophead)
            %if nparms=0 %then outstring("void ") %else %start
               %for pcount=1,1,nparms %cycle
                  %if lcell_s1&x'10000000'#0 %start
                     outtype(lcell_s1>>16&255,lcell_sndisp); outstring("()")
                  %else
                     outxtype(lcell_s1>>16,lcell_sndisp)
                  %finish
                  %if lcell_link#0 %then outsym(',')
                  lcell==aslist(lcell_link)
               %repeat
            %finish
            outstring(");")
         %finish
      %finish
      %if NPARMS>0 %then PCHKWORD = NPARMS<<16!ASLIST(OPHEAD)_S3>>16
      %if M=1 %then %start
         %if TARGET=EMAS %or TARGET=PNX %or TARGET=IBM %or %c
            TARGET=IBMXA %or target=amdahl %or %c
            1<<target&emachine#0 %then %c
            CXREF(STRING(AXNAME),3*PARM_DYNAMIC!EXTRN,PCHKWORD,JJ)
                                   ! %system & %external =STATIC
                                   ! UNLESS PARM DYNAMIC SET
                                   ! %dynamic = DYNAMIC
         %if TARGET=PERQ %or TARGET=ACCENT %then %c
            JJ = AXNAME-ADDR(A(WORKA_DICTBASE))
      %finish %else %start
         %if TARGET=PERQ %or TARGET=ACCENT %then %c
            JJ = WORKA_RTCOUNT %and WORKA_RTCOUNT = WORKA_RTCOUNT+1
      %finish
      %if M=0 %and RLEVEL=0 %start
         %if PARM_CPRMODE=0 %then PARM_CPRMODE = 2
         %if PARM_CPRMODE#2 %then FAULT(56,0,KK)
      %finish
      J = 15-M&1; PTYPE = TYPEP
      STORE TAG(KK,LEVEL,RBASE,j,JJ,SACC,OPHEAD,SKFORM)
%end
         %routine CFPLIST(%integer %name OPHEAD,NPARMS)
!***********************************************************************
!*    COMPILE A FORMAL PARAMETER PART INTO A LIST OF PARAMETER TYPES   *
!*    P(FPP)='('{(HOLE)(FPDEL)(NAMELIST)(MARK)}*')',0.                 *
!*                                                                     *
!*    THE LIST OF PARAMETER LOOKS LIKE:-                               *
!*    S1 = PTYPE FOR PARAM<<16!LNAME<<12!DIMENSION(DIMEN DEDUCED LATER)*
!*                                      LNAME IS PARAMS LOCAL NAME     *
!*    S2 = PARAMETER OFFSET(SNDISP) <<16 ! ACC                         *
!*    S3 = 0                                 (RESERVED FOR FPP OF RTS) *
!*                                                                     *
!*    ON ENTRY P IS AT ALT OF FPP (WHICH MAY BE NULL)                  *
!***********************************************************************
            %integer OPBOT,PP,INC,RL,RSIZE,CELL,PSIMPLE
            %record (LISTF) %name LCELL
            OPHEAD = 0; OPBOT = 0
            NPARMS = 0;                  ! ZERO PARAMETERS AS YET
            PSIMPLE = 1;                 ! NO COMPLEX PARAMS YET
            %while A(P)=1 %cycle;        ! WHILE SOME(MORE) FPS
               PP = P+1+FROMAR2(P+1);    ! TO NEXT FPDEL
               P = P+3;                  ! TO ALT OF FPDEL
               CFPDEL;                   ! GET TYPE & ACC FOR NEXT GROUP
               PSIMPLE = 0 %unless %c
                  PTYPE=X'51' %or (ROUT=ARR=0 %and NAM=1 %and 0<TYPE<=3)
               %if rout#0 %Start
                  INC = RT PARAM SIZE
                  RL = ROUNDING LENGTH(RTPARAMPT,2)
               %finish %else %if ARR=1 %then %start
                  INC = AHEADSIZE;
                  RL = ROUNDING LENGTH(AHEADPT,2)
               %finish %else %if NAM=1 %then %start
                  INC = PTRSIZE(PTYPE&X'7F')
                  RL = PTRROUNDING(PTYPE&X'7F'+256)
               %finish %else %if STRVALINWA=YES %and PTYPE=X'35' %then %start
                  INC = PTRSIZE(X'35')
                  RL = PTRROUNDING(256+X'35')
               %finish %else %if RECVALINWA=YES %and PTYPE=X'33' %then %start
                  INC = PTRSIZE(X'33')
                  RL = PTRROUNDING(256+X'33')
              %finish %else %if TARGET=EMAS %and PTYPE=X'33' %then %start
                  INC = ACC+8;           ! ALLOW FOR DESCRPTR FOR IMP80%c
                                         COMPATABILITY
                  RL = 3;                ! STRICTLY ROUNDING LENGTH(X'33',2)
               %finish %else INC = ACC %and RL = ROUNDING LENGTH(PTYPE,2)
               %until A(P-1)=2 %cycle;   ! DOWN <NAMELIST> FOR EACH DEL
                  %if PARAMS BWARDS=YES %then %start
                     PUSH(OPHEAD,0,0,RL)
                     CELL = OPHEAD
                  %finish %else %start
                     BINSERT(OPHEAD,OPBOT,0,0,RL)
                     CELL = OPBOT
                  %finish
                  LCELL == ASLIST(CELL)
                  LCELL_PTYPE <- PTYPE;  ! DIRECT "PUSH" FAILS ON HALF SWOPPED%c
                                         MACHINES
                  LCELL_SNDISP = kform
                  LCELL_ACC <- ACC
                  NPARMS = NPARMS+1
                  P = P+3
               %repeat
               P = PP
            %repeat
            OPBOT = OPHEAD; INC = 0;     ! FURTHER PASS TO ALLOCATE SPACE
!            %while OPBOT>0 %cycle
!               LCELL == ASLIST(OPBOT)
!               RL = LCELL_S3; LCELL_S3 = 0;  ! EXTRACT ROUNDIMG LENGTH
!               RSIZE = LCELL_SNDISP;     ! INC EXTRACTED
!               INC = (INC+RL+SFRAME MISALIGN)&(\RL)-SFRAME MISALIGN
!               %if PARAMSBWARDS=NO %and RSIZE<MINPARAMSIZE %and %c
!                  LCELL_PTYPE&7<=2 %then INC = INC+MINPARAMSIZE-RSIZE
!                                         ! MAINTAIN BYTES &SHORTS IN BTM
!                                         ! OF WORDS FOR 2900&IBM ARCHITECTURE
!               LCELL_SNDISP <- INC;      ! THE PARAMETER OFFSET
!               INC = INC+RSIZE
!               OPBOT = LCELL_LINK
!            %repeat
            INC = (INC+RL+SFRAME MISALIGN)&(\RL)-SFRAME MISALIGN
            P = P+1
            PRINT LIST(OPHEAD) %if PARM_Z#0
            PP = INC<<16!NPARMS
            %if (TARGET=IBM %or TARGET=IBMXA %or TARGET=AMDAHL) %then %c
               PP = PP!PSIMPLE<<15
            %if NPARMS>0 %then ASLIST(OPHEAD)_S3 = PP
            PRINTLIST(OPHEAD) %if PARM_Z#0
         %end
         %routine CFPDEL
!***********************************************************************
!*    SET UP PTYPE & ACC FOR A FORMAL PARAMETER DEFINITION             *
!*    P<FPDEL>=<TYPE><%qname'>,                                        *
!*             (RT)(%name')(NAMELIST)(FPP),                            *
!*             '%NAME'.                                                *
!***********************************************************************
            %switch FP(1:3)
            %integer FPALT
            FPALT = A(P); P = P+1
            KFORM = 0; LITL = 0
            ->FP(FPALT)
FP(1):                                   ! (TYPE)(%qname')
            ROUT = 0; CLT
            CQN(P)
            %if TYPE=5 %and NAM=0 %and (ACC<=0 %or ACC>256) %then %c
               FAULT(70,ACC-1,0) %and ACC = 255
            P = P+1
            ->PK
FP(2):                                   ! (RT)(%name')(NAMELIST)(FPP)
            ROUT = 1; NAM = 1
            ARR = 0
            %if A(P)=1 %then %start;     ! RT=%rouitne
               TYPE = 0; PREC = 0
               P = P+2
            %finish %else %start
               P = P+1; CLT;             ! RT=(TYPE)(FM)
               NAM = 1
               %if A(P)=2 %then NAM = 3;  ! 1 FOR FN 3 FOR MAP
               P = P+2;                  ! PAST (%name') WHICH IS IGNORED
            %finish
            ACC = RT PARAM SIZE
            ->PK
FP(3):                                   ! %name
            ACC = PTRSIZE(0); NAM = 1
            ROUT = 0; TYPE = 0
            ARR = 0; PREC = 0
PK:         PACK(PTYPE)
         %end
         %routine RHEAD(%integer RTNAME,AXNAME,Xtra)
!***********************************************************************
!*       COMPILES CODE FOR BLOCK AND ROUTINE ENTRY                     *
!*       RTNAME IS THE RT/FN/MAP NAME (=-1 FOR %begin BLOCKS)          *
!*       XNAME IS THE EXTERNAL NAME (="" FOR INTERNALS&BLOCKS          *
!*       ACTIONS INCLUDE PLANTING JUMPS ROUND RT BODY AND              *
!*       DEFINING EXTERNAL ENTRIES AS WELL AS PLANTING ENTRY CODE      *
!***********************************************************************
            %integer W3,Flags
            %record (LISTF) %name LCELL
            Flags=0
            %if Xtra#0 %then flags=Bstruct
            CURRINF_SNMAX = NMAX; CURRINF_SN = N
            %if RTNAME>=0 %then %start;  ! SECTION FOR ROUTINES
               LCELL == ASLIST(TAGS(RTNAME))
!
! FIRST JUMP ROUND BODY UNLESS AT TOP LEVEL OR IN COMPILER
! OR A JUMP IS ALREADY OUTSTANDING AT THIS LEVEL
! MUST DO THIS HERE BEFORE LEVEL IS CHANGED OR LABEL LIST IS WRONG
!
               %if PARM_COMPILER=0 %and LEVEL>1 %and CURRINF_JROUND=0 %start
                  PLABEL = PLABEL-1
                  CURRINF_JROUND = PLABEL
                  %if JRNDBODIES=YES %then ENTER JUMP(15,PLABEL,0)
               %finish
               RLEVEL = RLEVEL+1; RBASE = RLEVEL
               FAULT(105,0,0) %if RLEVEL>=2
            %finish
            LEVEL = LEVEL+1
            CURRINF == LEVELINF(LEVEL)
            CURRINF = 0
            CURRINF_RBASE = RBASE
            CURRINF_CLEVEL = LEVEL;      ! SELF POINTER IS NEEDED IN GENERATE
            CURRINF_NAMES = -1
            CURRINF_DIAGINF = LEVELINF(LEVEL-1)_DIAGINF
!            %if target=gould %then currinf_maxpp = levelinf(level-1)_maxpp
            CURRINF_DISPLAY = LEVELINF(LEVEL-1)_DISPLAY
            FAULT(34,0,0) %if LEVEL=MAX LEVELS
            FAULT(105,0,0) %if LEVEL>MAX LEVELS
!
! DEAL WITH EXTERNAL ENTRIES SO THAT THEY COME TO THIS POINT
! IN THE CODE. THE DESCRIPTORS SET UP ARE OF NO INTEREST TO THIS MODULE
! ONLY TO OTHER MODULES SO NO DETAILS OF THEN ARE RECORDED IN TAGS
!
            %if RTNAME<0 %then %start      { For begin blocks  }
               %if axname=0  %start        { not initial begin }
                  currinf_iblkid=internalblockid
                  internalblockid=internalblockid+1   { keep a blk no for switches & labels }
               %finish
               W3 = 0
            %else
               W3 = RTNAME+1
               internalblockid=0
            %finish
            CURRINF_L = LINE; CURRINF_M = W3
            CURRINF_FLAG = PTYPE&X'FFFF';  ! CURRENT BLOCK TYPE MARKER
                                         ! SIGN MUST NOT PROPOGATE
!
! TILL LOADER COPIES GLAP TO GLA MUST CALL A FRIG ROUTINE TO DO
! THIS ESSENTIAL AS SOON AS POSSIBLE IN ANYTHING EXTERNAL
!
            W3 = ULCONSTTRIP(RTHD,X'61',Flags,RTNAME,AXNAME)
         %end
         %routine RDISPLAY(%integer KK)
!***********************************************************************
!*       SET UP OR COPY THE DISPLAY                                    *
!*       SINCE THIS IS IN REGISTERS ON 360 IT IS EASY                  *
!*       ALSO CLAIM STACK SPACE AND SET DIAGNOSTIC POINTERS            *
!***********************************************************************
            %integer TRIPNO
            %if KK>=0 %or LEVEL=2 %start;  ! DISPLAY NEEDED
                                         ! DONE BY THE QCODE CALL
               CURRINF_PSIZE = N-alpha;  ! REMEMBER PARAMETER SIZE FOR RTDICT
               %if 1<<target&riskmc#0 %then N=(N+display rounding)&(\display rounding)
               CURRINF_DISPLAY = N
               %if DISPLAY NEEDED=YES %start
                  N = N+DISPLAY C1*RLEVEL+DISPLAY C0;  ! RESERVE DISPLAY SPACE
               %finish
               TRIPNO = UCONSTTRIP(RDSPY,X'51',0,CURRINF_DISPLAY)
            %finish
!
! IF IN DIAGNOSTIC MODE PLANT CODE TO SAVE THE LINE & ROUTINE NO OF
! THE CALLING ROUTINE AND SET UP THE NEW BLOCK/ROUTINE IDENT NO.
!
            %if PARM_TRACE#0 %start
               %if KK>=0 %or LEVEL=2 %start;  ! ROUTINE NEW AREA NEEDED
                  %if target=vns %then %c
                     currinf_diaginf = currinf_psize+8 %else %start
                     TRIPNO = UCONSTTRIP(RDAREA,X'51',0,N)
                     N = N+4
                     N = N+4 %if 1<<Target & Riskmc#0;! extra word here on risks
                     CURRINF_DIAGINF = N
                     N = N+4
!
! For risk and some others it is better to use words for line & diag pointers
! if half word access is slow.
!
                     %if target=ORN %or 1<<target&riskmc#0 %then N=N+4
                  %finish
               %finish
               TRIPNO = UCONSTTRIP(RDPTR,X'51',0,LEVEL)
            %finish
            OLDLINE = 0
            SET LINE
!
! NORMALLY CODE IS PLANTED HERE TO CHECK PARAMETERS BUT I CANNOT
! SEE HOW TO DO THIS ON PERQ ARCHITECTURE. IT MAY BE IN THE QCODE ANYHOW
!
!
! CLAIM (THE REST OF) THE STACK FRAME
!
            %if KK>=0 %or LEVEL=2 %start
               NMAX = N
            %finish
         %end
         %routine CUI(%integer CODE)
!***********************************************************************
!*       COMPILE AN UNCONDITIONAL INSTRN WHEREEVER IT OCCURS           *
!*       CODE=0 UNCONDITIOALLY,=1 AFTER %then, =2 AFTER %else          *
!***********************************************************************
%integer PT,MARKER,J,LNAME,TYPEP,PRECP,ALT,KK
%record (RD) OPND1
%integer HEAD1,BOT1,NOPS,savepos
%record (RD) RPOP
%record (LISTF) %name LCELL
%record(swdataform)%name swdata
%owninteger depth
%switch SW(1:9)
      depth=depth+1
      %if depth=1 %then savepos=opline_length %and outsym(' ')
      REPORTUI = 0
      ALT = A(P)
      ->SW(ALT)
SW(1):                                   ! (NAME)(APP)(ASSMNT?)
      P = P+1; MARKER = P+FROMAR2(P)
      %if A(MARKER)=1 %then %start
         J = P+2; P = MARKER+2
         ASSIGN(A(MARKER+1),J)
      %finish %else %start
         P = P+2
         CNAME(0)
         P = P+1
      %finish
AUI:  J = A(P); P = P+1
      %if j=1 %start
         %if depth=1 %then opline_l(savepos)='{'
         outstring("; ")
         CUI(CODE)
        %if depth=1 %then outstring(";}")
      %finish
      depth=depth-1
      %return
SW(2):                                   ! -> (NAME)(APP)
      CURRINF_NMDECS = CURRINF_NMDECS!1
      CURR INST = 1 %if CODE=0
      LNAME = FROM AR2(P+1)
      J = A(P+3); P = P+4
      %if J=2 %then %start;        ! SIMPLE LABEL
         ENTER JUMP(15,LNAME,0)
         REPORTUI = 1
         outstring("goto "); outname(lname)
      %finish %else %start;        ! SWITCH LABELS
         COPY TAG(LNAME,NO)
         %unless OLDI=LEVEL %and TYPE=6 %start
            FAULT(4,0,LNAME); P = P-1; SKIP APP
            %return
         %finish
         outsym('{'); outswadname(lname); outstring("_value=")
         CSEXP(MINAPT)
         outstring("; goto "); outswadname(lname)
         outstring("_despatch;}")
         REPORTUI = 1
      %finish
      depth=depth-1
      %return
SW(3):                                   ! RETURN
      FAULT(30,0,0) %unless CURRINF_FLAG&X'3FFF'=X'1000'
      P = P+1
      outstring("return ")
RET:  KK = UCONSTTRIP(RTXIT,X'51',0,0)
      REPORT UI = 1
      CURR INST = 1 %if CODE=0
      depth=depth-1
      %return
SW(4):                                   ! %result(ASSOP)(EXPR)
      outstring("return ")
      PTYPE = CURRINF_FLAG&X'3FFF'; UNPACK
      PT=ptype&255
      OPND1 = 0
      OPND1_PTYPE <- PTYPE; OPND1_FLAG = DNAME
      OPND1_D = CURRINF_M-1
      %if PTYPE>X'1000' %and A(P+1)#3 %then %start;  ! ASSOP #'->'
         %if A(P+1)=1 %and NAM#0 %and A(P+5)=4 %and A(P+6)=1 %start
            P = P+7; TYPEP = TYPE; PRECP = PREC; J = P
            CNAME(4)
            KK = BRECTRIP(MAPRES,PTYPE&255,0,OPND1,NAMEOPND)
            FAULT(81,0,0) %unless A(P)=2; P = P+1
            FAULT(83,CURRINF_M-1,FROMAR2(J)) %unless %c
               TYPEP=TYPE %and PRECP=PREC
            ->RET
         %finish
         %if A(P+1)=2 %and NAM=0 %then %start;  ! ASSOP='='
            P = P+2
            %if TYPE=5 %then %start
               CSTREXP(0);        ! FULL VIRTAD
            %finish %else %if TYPE=3 %start
               ->BAD RES %unless A(P+3)=4 %and A(P+4)=1
               P = P+5
               CNAME(3)
               FAULT(66,0,OPND1_D) %unless TYPE=3
               EXPOPND = NAMEOPND
            %finish %else %start
               %if PREC<4 %then PREC = 4
               CSEXP(PREC<<4!TYPE)
            %finish
            %if PT=X'31' %or PT=X'41' %Start
               kk=urectrip(SHRTN,PT,0,expopnd)
               expopnd_flag=reftrip; expopnd_d=kk
               expopnd_ptype=PT
            %finish
            KK = BRECTRIP(FNRES,PTYPE&255,0,OPND1,EXPOPND)
            ->RET
         %finish
      %finish
      P = P+2
BAD RES:
      FAULT(31,0,0)
      SKIP EXP;                    ! IGNORE SPURIOUS RESULT
      depth=depth-1
      %return
SW(5):                                   ! %monitor (AUI)
      P = P+1; ->AUI
SW(6):                                   ! %stop
      outstring("imp_stop()")
!      KK = UCONSTTRIP(XSTOP,X'51',0,0)
      P = P+1
      CURR INST = 1 %if CODE=0
      REPORTUI = 1
      depth=depth-1
      %return
SW(7):                                   !'%SIGNAL'(EVENT')(N)(OPEXPR)
      P = P+5
      KK = INTEXP(J,MINAPT);       ! EVENT NO TO J
      %if A(P)=1 %start;           ! SUBEVENT SPECIFIED
               P = P+3;  skip exp
      %finish
      outstring("*** IMP signals untranslateable *****")
      depth=depth-1
      %return
SW(8):                                   ! %exit
      outstring(" break ")
      REPORTUI = 1
      CURR INST = 1 %if CODE=0
      depth=depth-1
      %return
SW(9):                                   ! %continue
      REPORTUI = 1
      CURR INST = 1 %if CODE=0
      outstring(" continue ")
      depth=depth-1
      %return
         %end
         %routine CIFTHEN(%integer MARKIU,MARKC,MARKUI,MARKE,MARKR,Afterelse)
!***********************************************************************
!*    THIS ROUTINE COMPILES CONDITIONAL EXPRESSIONS.IT REQUIRES THE    *
!*    FOLLOWING PARAMETERS TO BE SET TO THEIR A .R. ENTRY.             *
!*    MARKIU TO THE ENTRY FOR P(%iu)                                   *
!*    MARKC  TO THE ENTRY FOR P(COND)                                  *
!*    MARKUI TO THE ENTRY FOR (FIRST OCCURRENCE OF)  P(UI)             *
!*    MARKE  TO THE ENTRY FOR P(ELSE')  - =0 FOR BACKWARDS CONDITION   *
!*    MARKR  TO ENTRY FOR P(RESTOFIU)   - =0 FOR BACKWARDS CONDITION   *
!***********************************************************************
%integer ALTUI,CCRES,ELRES,THENLAB,ELSELAB,USERLAB,REPORT,START,
   ELSEALT,K,J,CS,LINETRIP,ctype
%const %integer NULL ELSE=4
%switch ESW(1:NULL ELSE)
%owninteger depth=0
            depth=depth+1
            LINETRIP = -1
            SET LINE %and LINETRIP = TRIPLES(0)_BLINK
            MARKIU = A(MARKIU);          ! ALT OF IU 1=%if,2=%unless
            PLABEL = PLABEL-1
            THENLAB = PLABEL
            START = 0; CS = 0;           ! NO START IN CONDITION YET
            CS = 1 %if STARSIZE>100;     ! LONG JUMPS FOR COMPLEX STMTS
            ELSELAB = 0;                 ! MEANS NO ELSE CLAUSE
            P = MARKC
            %if MARKR>0 %and A(MARKR)<=2 %then %c
               START = 1
! '%START' OR '%THENSTART'
!            %if MARKE#0 %and LEVEL<2 %and START=0 %then FAULT(57,0,0)
            USERLAB = -1
            %if START#0 %then ALTUI = 0 %else ALTUI = A(MARKUI)
            %if ALTUI=2 %and A(MARKUI+3)=2 %then USERLAB = FROM AR2(MARKUI+1)
                                         ! UI = SIMPLE LABEL
            %if 8<=ALTUI<=9 %and currinf_EXITLAB#0 %start;  ! VALID EXIT
               %if ALTUI=8 %then USERLAB = currinf_EXITLAB %else %c
                  USERLAB = currinf_CONTLAB
            %finish
!
            ctype=rlevel
            %if tcond#0 %then ctype=0
            P = MARKC                   { may be changed by tcond }
            %if ctype=0 %start
                %if Afterelse=NO %then outsym(NL) %and outstring("#if")
            %else
               outstring("if ")
            %finish
            CCRES = CCOND(1,MARKIU,THENLAB,B'11'!!START!!CS)
            %if START#0 %then %start;  ! %then %start
               %if CCRES=0 %start;    ! CONDITIONAL
!                  FAULT(57,0,0) %if LEVEL<2
                  CURRINF_NMDECS = CURRINF_NMDECS!1
               %finish %else %start
                                      ! DELETE LINE NO UPDATE FOR%c
                                      CONDITIONAL STARTR
                                      ! (IT MIGHT CONTAIN M-C CODE!)
                  %if LINE TRIP>0 %then TRIPLES(LINETRIP)_OPERN = NULLT
               %finish
               P = MARKR+1
               %If ctype#0 %then  curly check(1) %and outsym('{'); outsym(NL)
               CSTART(CCRES,1)
               %If ctype#0 %then outstring("}");! outstring(" /* if clause */")
               %if A(P)<=2 %then PLABEL = PLABEL-1 %and ELSELAB = PLABEL
               MARKE = P
               REPORT = LAST INST
            %finish %else %start
               %if CCRES#2 %start
                  %if ctype=0 %then outsym(NL)
                  P = MARKUI; CUI(1)
                  %if MARKE#0 %and a(MARKE)#NULL ELSE %and opline_l(opline_length-1)#'}' %then outsep
                  REPORT = REPORTUI
               %finish %else %start;  ! FIRST UI NEVER EXECUTED
                  REPORT = 1
               %finish
            %finish
ELSE:                                    ! ELSE PART
            %if MARKE=0 %then ELSEALT = NULL ELSE %else ELSEALT = A(MARKE)
            %if ELSEALT<NULL ELSE %then PLABEL = PLABEL-1 %and ELSELAB = PLABEL
            P = MARKE+1
                                         ! CONDITIONAL&MERGE OR REPLACE
            ->ESW(ELSEALT)
ESW(1):                                  ! '%ELSESTART'
            %if ctype=0 %start
               outsym(NL); outstring("#else"); curly check(1); outsym(NL)
            %else
               outstring(" else {"); curly check(1);  outsym(NL)
             %finish
            %if CCRES=0 %then CURRINF_NMDECS = CURRINF_NMDECS!1
            CSTART(CCRES,2)
            %If ctype#0 %then outstring("}"); ! outstring(" /* else clause*/")
            %if ctype=0 %start
               outsym(NL); outstring("#endif")
            %finish
            ->ENTER ELSELAB
ESW(2):                                  ! '%ELSE' (%iu) ETC
            MARKE = 0; MARKUI = 0
            MARKR = P+1+FROMAR2(P+1)
            %if A(MARKR)=3 %then %start
               MARKE = MARKR+1+FROM AR2(MARKR+1)
               MARKUI = MARKR+3
            %finish
            J = NEXT TRIP
            %if ctype=0 %start
               outsym(NL); outstring("#else"); outsym(NL)
               CIFTHEN(P,P+3,MARKUI,MARKE,MARKR,no)
               outsym(NL); outstring("#endif")
            %else
               outstring(" else ");       ! outsym('{')
               CIFTHEN(P,P+3,MARKUI,MARKE,MARKR,NO)
               outsym(NL);                !  outsym('}')
            %finish
            REPORT = 0;                  ! CANT TELL IN GENERAL
            ->ENTER ELSELAB
ESW(3):                                  ! '%ELSE'<UI>
             %if ctype=0 %start
               outsym(nl); outstring("#else"); outsym(NL)
           %else
               outstring(" else ")
           %finish
            %if CCRES#1 %then %start
               %if START#0 %then SET LINE;  ! FOR CORRECT LINE IF FAILS IN UI
               %if THENLAB=0 %then K = 0 %else K = 2
               CUI(K)
               REPORT = REPORTUI
               %if ctype=0 %then %start
                  outsep
                  outsym(NL)
                  outstring("#endif")
               %else
                  %if depth>1 %then outsep
               %finish
            %finish
ENTER ELSELAB:
            %if ELSELAB>0 %then ELRES = ENTER LAB(ELSELAB,B'11'!REPORT<<2)
      depth=depth-1; %return
                                         ! CONDITIONAL MERGE
ESW(NULL ELSE):                          ! NULL ELSE CLAUSE
           %if ctype=0 %start
               outsep %if start=0
               outsym(NL); outstring("#endif")
           %finish
         depth=depth-1; 
         %end
         %routine CSTART(%integer CCRES,CODE)
!***********************************************************************
!*    COMPILE A COMPLETE START-FINISH BLOCK BY RECURSION               *
!*    IF START NEVER EXECUTED SKIP TO CORRESPONDING FINISH             *
!*    CODE=0 WAS UNCONDITIONAL NOW SHOULD BE UNUSED                    *
!*    CODE=1 AFTER THEN                                                *
!*    CODE=2 AFTER ELSE                                                *
!*    CODE=3 AFTER ONEVENT                                             *
!*    P ON ENTRY TO FORWARD POINTER TO THE RIGHT FINISH                *
!*    P ON EXIT TO THE ELSE CLAUSE AFTER THE RIGHT FINISH              *
!***********************************************************************
%integer SKIPCODE,FINISHAR,OLDNEXTP,OLDLINE
      SKIPCODE = NO
      %if 1<=CODE<=2 %and CCRES!CODE=3 %then SKIPCODE = YES
                                   ! NEVER EXECUTED
      FINISHAR = FROMAR4(P);       ! TO START OF AR FOR FINISH
      OLDLINE = LINE;              ! FOR ERROR MESSAGES
      %cycle;                      ! THROUGH INTERVENING STATMNTS
         OLDNEXTP = NEXTP
         COMPILE A STMNT
      %repeat %until OLDNEXTP>=FINISHAR;  ! HAVING COMPILED FINISH

      P = FINISHAR+10;              ! TO ELSE CLAUSE
!
      %if A(P)<=3 %and CODE#1 %then FAULT(45+CODE,OLDLINE,0)
      %if SKIPCODE=YES %then LAST INST = 1
%end
         %routine CCYCBODY(%integer UA,ELAB,CLAB)
!***********************************************************************
!*    COMPILES A CYCLE REPEAT BODY BY RECURSION                        *
!*    ON ENTRY P IS TO FORWARD POINTER. ON EXIT TO ALT OF UNTIL        *
!*    UA = O IF UNTIL NOT ALLOWED                                      *
!*    ELAB&CLAB ARE LABELS FOR ELSE & CONTINUE                         *
!***********************************************************************
%integer FINISHAR,OLDLINE,SAVEE,SAVEC
      FINISHAR = FROMAR4(P)
      %if FINISHAR<=P %then IMPABORT
      FORDPTH = FORDPTH+1
      OLDLINE = LINE; SAVEE = currinf_EXITLAB; SAVEC = currinf_CONTLAB
      currinf_EXITLAB = ELAB; currinf_CONTLAB = CLAB
      curly check(1)
      outsym('{'); outsym(NL)
      %while NEXTP<=FINISHAR %cycle
         COMPILE A STMNT
      %repeat
      outstring("}"); ! outstring(" /* loop */")
      currinf_EXITLAB = SAVEE; currinf_CONTLAB = SAVEC
      P = FINISHAR+10
      FORDPTH = FORDPTH-1
      %if A(P)=1 %and UA=0 %then FAULT(12,OLDLINE,0)
%end

%routine CLOOP(%integer ALT,MARKC,MARKUI)
!***********************************************************************
!*    ALT=1 FOR %while, =2 FOR %until, =3 FOR %for                     *
!*    MARKC IS TO THE CONDITION OR CONTROL CLAUSE                      *
!*    MARKUI IS TO THE UI, SPECIAL FOR %cycle                          *
!*    FORBITS DEFINES FOR LOOP AS FOLLOWS:-                            *
!*    2**2 TO 2**0 SET FOR CONSTANT INITIAL,INC &FINAL                 *
!*    CORRESPONDING UPPER BYTE SET DEFINES CONSTANT FURTHER            *
!*       2**7 NEGATIVE CONSTANT                                        *
!*       2**4 CONSTANT IS 2                                            *
!*       2**3 CONSTANT IS 1                                            *
!*       2**2 CONSTANT IS 0                                            *
!*       2**1 CONSTANT IS -1                                           *
!*       2**0 CONSTANT IS -2                                           *
!*    THESE BITS ARE PASSED ON TO GENERATOR FOR SPECIAL CASE           *
!***********************************************************************
%integer L1,L2,L3,L4,CCRES,ELRES,FLINE,TRIP,FOT,PP,DEBJ,JJ,FSTRIP
%integer FORNAME,INITP,STEPP,FINALP,REPMASK,FORPT,FORWORDS,FORBITS
%record (RD) INITOPND,STEPOPND,FINALOPND,DIFFOPND,ZOPND,OPND
%record (TRIPF) %name CURRT
%routine %spec FOREXP(%record (RD) %name EOPND, %integer TT,SH)
%switch SW(0:6)
      P = MARKC
      FORBITS = 0
      SFLABEL = SFLABEL-2
      L1 = SFLABEL; L2 = L1+1
!
! SET L3 FOR ALTS 0,5&6 ONLY
!
      L3 = 0
      %if B'1100001'&1<<ALT#0 %then L3 = SFLABEL-1 %and SFLABEL = L3
!
! UPDATE THE LINE NUMBER FOR ALTS 1 TO 3 ONLY
!
            %if 1<=ALT<=3 %then SET LINE
!
! ENTER THE FIRST LABEL FOR ALL ALTS EXCEPT 3 & 6
!
!            %if B'0110111'&1<<ALT#0 %then ELRES = ENTER LAB(L1,0)
      ->SW(ALT)
SW(0):                                   ! %cycle
      PP = FROM AR4(P)+10;          ! TO UNTIL CLAUSE IF ANY
      outstring("do ")
      %if A(PP)=1 %start;          ! %repeat %until <COND>
         C CYC BODY(1,L2,L3)
!         L3 = L3*ENTER LAB(L3,B'011');  ! DELETE IF NOT NEEDED
         SET LINE
         outstring(" while ")
         P = PP+1; CCRES = CCOND(0,2,L1,0)
      %finish %else %start
         C CYC BODY(1,L2,L1);      ! CONTINUES DIRECT TO TOP
         outstring(" while (1) /* FOR EVER */")
!         ENTER JUMP(15,L1,0)
      %finish
!      L2 = L2*ENTER LAB(L2,B'011');  ! DELETE IF NOT NEEDED
WAYOUT:                                  ! REMOVE LABELS NOT REQUIRED
      %return
sw(1):                            ! UI while cond
      outstring("while ")
      ccres=ccond(0,1,l2,b'11')
      p=markui
      cui(1)
!      enter jump(15,l1,0)         ! uncoditional back to while
!      L2 = L2*ENTER LAB(L2,B'111');  ! CONDITIONAL(?) & REPLACE ENV
      ->WAYOUT
SW(2):                                   ! UI %until COND
      P = MARKUI
      outstring("do ")
      CUI(1)
      P = MARKC
      outsep; outstring(" while ")
      CCRES = CCOND(0,2,L1,0)
      ->WAYOUT
SW(6):                                   ! %for ... %cycle
SW(3):                                   ! UI %for ....
      FORCNT = FORCNT+1;           ! TO DETCT FORS IN ENCLOSED STMTS
      FORNAME = FROMAR2(P)
      INITP = P+2
      COPY TAG(FORNAME,YES);       ! DECLARE IF UNKNOWN TO COMPILER
      FAULT(91,0,FORNAME) %and ptype=X'51'  %unless %c
         (TYPE=7 %or TYPE=1) %and 4<=PREC<=5 %and ROUT=0=ARR %and LITL#1
      FOT = DNAME;                 ! FOR OPERAND TYPE
      %if NAM#0 %then FOT = INDNAME
      FORPT = PTYPE&255;           ! SAVE TYPE&PREC OF CONTROL
!
      P = INITP
      SKIP EXP;                    ! P TO STEP EXPRSN
      STEPP = P; SKIP EXP;         ! P TO FINAL
      FINALP=p
!
      P = STEPP
      FOR EXP(STEPOPND,1,1);       ! Investigate step and evaluate if constant
      outstring(" for (")
      %if FOT=INDNAME %then outsym('*')
      outname(FORNAME)
      outsym('=')
      P = INITP; csexp(FORPT)
      outsep
      outsym(' ')
      %if FOT=INDNAME %then outsym('*')
      outname(FORNAME)
      %if STEPOPND_FLAG<=1 %start
         FAULT(92,0,0) %if STEPOPND_D=0;  ! ZERO STEP
         %if STEPOPND_D<0 %then outstring(">=") %else outstring("<=")
      %finish %else %start
         outstring("<=")
         warn(10,0)
      %finish
      p=finalp; csexp(FORPT)
      outsep
      outsym(' ')
      %if FOT=INDNAME %then outsym('*')
      outname(FORNAME)
      %if STEPOPND_FLAG<=1 %and iMOD(STEPOPND_D)=1 %start
         %if STEPOPND_D<0 %then outstring("--") %else outstring("++")
      %else
         outstring("+=")
         p=STEPP; csexp(FORPT)
      %finish
      outstring(") ")
!
      P = MARKUI;                  ! TO UI OR '%CYCLE'(HOLE)
      %if ALT=3 %then %start;      ! DEAL WITH CONTROLLED STMNTS
         CUI(0)
      %finish %else %start
         CCYCBODY(0,L2,L3)
         %finish
      ->WAYOUT
SW(4):                                   ! %while COND %cycle
      SET LINE
      outstring("while ")
      CCRES = CCOND(0,1,L2,2);     ! merge but not short
      C CYC BODY(0,L2,L1)
!      ENTER JUMP(15,L1,0)
!      L2 = L2*ENTER LAB(L2,B'111');  ! CONDITIONAL & REPLACE ENV
      ->WAYOUT
SW(5):                                   ! %until ... %cycle
                                         ! ALSO %cycle... %repeat %until
                                         ! MARKUI TO %cycle
      P = MARKUI
      FLINE = LINE
      outstring("do ")
      C CYC BODY(0,L2,L3)
      P = MARKC
!      L3 = L3*ENTER LAB(L3,B'011');  ! CONTINUE LABEL IF NEEDED
      LINE = FLINE; SET LINE
      outsep; outstring(" while ")
      CCRES = CCOND(0,2,L1,0)
!      L2 = L2*ENTER LAB(L2,B'011')
      ->WAYOUT
%routine FOR EXP(%record (RD) %name EOPND, %integer TOTEMP,SHIFT)
!***********************************************************************
!*    P INDEXES EXPRESSION.  IF CONST PUT INTO EVALUE OTHERWISE        *
!*    dont generate anything                                           *
!***********************************************************************
%integer INP,VAL,SUBBITS
%integer exphead,expbot,nops
      exphead=0; expbot=0; nops=0
      INP = P; P = P+3
      torp(exphead,expbot,nops,1)
      %if nops>>16&7=0 %start        { nothing difficult }
         expop(exphead,expbot,nops,x'200'+FORPT)
         EOPND = EXPOPND;       ! EXPRESSION A LITERAL CONST
      %else
         eopnd_flag=255
      %finish
%end
%end
!*
         %routine ASSIGN(%integer ASSOP,P1)
!***********************************************************************
!*       HANDLES ARITHMETIC,STRING & ADDRESS ASSIGNMENTS TO VARIABLES  *
!*       FORMAL PARAMETERS AND DOPEVECTORS                             *
!*       ASSOP:-                                                       *
!*        1 IS FOR '=='                                                *
!*        2 IS FOR '='                                                 *
!*        3 IS FOR '<-' (JAM TRANSFER)                                 *
!*        4 IS FOR '->' (UNCONDITIONAL RESOLUTION)                     *
!*                                                                     *
!*       P POINTS TO THE EXPRESSION. P1 TO THE NAME ON LHS             *
!***********************************************************************
            %integer Q,KK,TYPEP,PRECP,PTYPEP,JJJ,P2,JJ,B,D,HEAD2,BOT2,ACCP,
               II,HEAD1,NOPS,TPCELL,LVL,BOT1,LHNAME,RHNAME,a1,a2
            %record (LISTF) %name LHCELL
            %record (RD) OPND1,OPND2
            %switch SW(0:4);             ! TO SWITCH ON ASSOP
            P2 = P
            LHNAME = A(P1)<<8!A(P1+1)
            LHCELL == ASLIST(TAGS(LHNAME))
            P = P1; REDUCE TAG(NO);      ! LOOK AT LH SIDE
            PTYPEP = PTYPE; JJ = J
            KK = K; II = I; LVL = OLDI
            TPCELL = TCELL; ACCP = ACC
            P = P2; TYPEP = TYPE; PRECP = PREC;  ! SAVE USEFUL INFO FOR LATER
            ->SW(ASSOP)
SW(2):
SW(3):                                   ! ARITHMETIC ASSIGNMENTS
            %if TYPE=3 %then ->RECOP
            TYPE = 1 %unless TYPE=2 %or TYPE=5;  ! IN CASE OF RUBBISHY SUBNAMES
            ->ST %if TYPE=5;             ! LHS IS A STRING
BACK:       HEAD1 = 0; BOT1 = 0;         ! CLEAR TEMPORAYRY LIST HEADS
            HEAD2 = 0; BOT2 = 0
            TYPE = 1 %unless TYPE=2;     ! DEAL WITH UNSET NAMES
            TYPEP = TYPE
            NOPS = 1<<18+1
            PTYPE = PTYPEP; UNPACK
            %if LHSADDRFIRST=NO %or (NAM=0=ARR %and A(P1+2)=2=A(P1+3)) %start
                                         ! SCALAR
               OPND1 = 0
               OPND1_PTYPE <- PTYPE; OPND1_FLAG = ARNAME
               BINSERT(HEAD1,BOT1,OPND1_S1,P1,LHNAME)
            %finish %else %start
               P = P1; CNAME(3);         ! 32 BIT ADDR TO STACK
               BINSERT(HEAD1,BOT1,NAMEOPND_S1,NAMEOPND_D,NAMEOPND_XTRA)
            %finish
            P = P2+3
            TORP(HEAD2,BOT2,NOPS,0);       ! RHS TO REVERSE POLISH
            OPND2 = 0; OPND2_FLAG = VASS+ASSOP-2
            BINSERT(HEAD2,BOT2,OPND2_S1,LHNAME<<16!PTYPEP,0)
                                         ! = OR <-OPERATOR
            ASLIST(BOT1)_LINK = HEAD2
            HEAD2 = 0; BOT1 = BOT2
            PRINT LIST(HEAD1) %if PARM_Z#0
            EXPOP(HEAD1,BOT1,NOPS,256+PRECP<<4+TYPEP);  ! PLANT CODE
         tripopt(triples,triples(0)_flink)
            outopnd(expopnd,0)
            %return
ST:                                      ! STRINGS
            p = p1
            %if assop=3 %then %start
               outstring("imp_strjam(")
               %if nam#0 %then warn(10,0)
            %finish %else outstring("strcpy(")
            CNAME(2)
            outsym(',')
         p = p2
            CSTREXP(0)
            %if assop=3 %then outsym(',') %and outint(accp-1)
            outsym(')')
            %return
!
! THIS SECTION DEALS WITH OPERATIONS ON COMPLETE RECORDS
!
RECOP:                                   ! LHS IS RECORD WITHOUT SUBNAME
            Q = TSEXP(JJJ)
            %if Q=1 %and JJJ=0 %start;   ! CLEAR A RECORD TO ZERO
               outstring("memset(")
               P = P1; CNAME(3)
               outstring(",0,")
               OPND1 = NAMEOPND
               OPND2 = 0
               OPND2_PTYPE = X'51'; OPND2_FLAG = SCONST
               outstring("sizeof( ")
               p=p1; reducetag(NO)
               outformatname(kform)
               outsym(')'); outsym(')')
               P = P2; SKIP EXP
               %return
            %finish
            %if assop=3 {<-} %start
               ->BACK %unless TYPE=3 %and A(P2+3)=4 %and A(P2+4)=1
               outstring("memcpy(")
               P = P1; CNAME(3)
               outsym(',')
               OPND1 = NAMEOPND
               ACCP = ACC
               P = P2+5; CNAME(3)
               outsym(',')
               OPND2 = NAMEOPND
               %unless A(P)=2 %then FAULT(66,0,LHNAME) %and ->F00
!               %if ASSOP=2 %and ACCP#ACC %then %c
!                  FAULT(67,LHNAME,FROMAR2(P2+5)) %and ->F00
               %if ACCP>ACC %then ACCP = ACC
               outstring("sizeof( ")
               p=p1; reducetag(NO)
               outformatname(kform)
               outsym(')'); outsym(')')
               P = P2; SKIP EXP
               %return
            %finish
            p=P1; cname(7)
            outstring("=")
            p=p2+5; cname(7)
            P = P2; SKIP EXP
            %return
SW(4):                                   ! RESOLUTION
            outstring("imp_resolve(")
            P = P1; CNAME(2)
            outsym(',')
            P = P2;
            %if TYPE=5 %then CRES(0) %else %start
               SKIP EXP
               FAULT(71,0,LHNAME) %unless TYPE=7
            %finish
            outsym(')')
            %return
SW(1):                                   ! '==' AND %name PARAMETERS
            ->F81 %unless A(P2+3)=4 %and A(P2+4)=1
            FAULT(82,0,LHNAME) %and ->F00 %unless NAM=1 %and LITL#1
                                         ! ONLY NON-CONST POINTERS ON LHS OF==
           lhformatname=kform
            %if ARR=1 %then %start
               JJ = 11; KK = 12
               II = AHASS; B = AHEADPT
            %finish %else %start
               JJ = 6; KK = 3
               II = PTRAS; B = X'51'
               %if PTRSIZE(PTYPE&255)>4 %then B = X'61'
            %finish
            P = P1; CNAME(JJ)
            outsym('=')
            P = P2+5
            RHNAME = A(P)<<8!A(P+1)
            %if typep=3 %start
              reduce tag(NO)
              %if kform#lhformatname %start
                 outsym('('); outformatname(lhformatname)
                 outstring("*)")
              %finish
            %finish
            CNAME(KK);                   ! DESCRPTR FETCHED
            %if kk=12 %start
!printstring("dv reset "); write( LHCELL_SNDISP,5); write(sndisp,5); write(ctable(sndisp+3),5); newline
            %if lhcell_uioj&15=0 %then  lhcell_uioj= lhcell_uioj!(j&15)
            %if LHCELL_SNDISP=0 %then LHCELL_SNDISP=sndisp
         %finish
            ->F81 %unless A(P)=2;        ! NO REST OF EXP ON RHS
!            ->F83 %unless TYPE=TYPEP %and PREC=PRECP %and (ARR>0 %or II=PTRAS)
!            ->F86 %unless OLDI<=LVL %or I=0 %or NAM#0
                                         ! GLOBAL == NONOWN LOCAL
            P = P+1
            %return
F83:        FAULT(83,LHNAME,RHNAME); ->F00
F86:        FAULT(86,LHNAME,RHNAME); ->F00
F81:        FAULT(81,0,LHNAME)
F00:
            P = P2; SKIP EXP
         %end
%routine outopnd(%record(rd)%name opnd,%integer mode)
!***********************************************************************
!*   Outputs an operand which may be a complete tree                   *
!*      mode&1 = 0 output as is                                        *
!*      mode&1 = 1 output enclosed in ( and )                          *
!*       mode&2#0 output as a store not a load                         *
!*       Mode&256#0 all consts as numeric for switches                 *
!***********************************************************************
%integer i,pp
%longreal r
%switch sw(0:9)
      %if mode&1=1 %then outsym('(')
      ->sw(opnd_flag)
sw(0):                                {short const }
sw(1):                               {long const }
      %if opnd_ptype&7=1 %start
         %if opnd_ptype&x'f0'=x'60' %then outlhex(opnd_d,opnd_xtra) %else %start
            %if opnd_ptype&8#0 %and doinglabel=0 %then %start
               %if opnd_ptype>>4&7=3 %start
                  outsym(''''); outsym(opnd_d); outsym('''')
               %finish %else outhex(opnd_d)
            %finish %else outint(opnd_d)
         %finish
      %finish
      %if opnd_ptype=x'52' %then outfl(opnd_r,7)
      %if opnd_ptype=x'62' %start
         integer(addr(r))=opnd_d
         integer(addr(r)+4)=opnd_xtra
         outfl(r,15)
      %finish
      %if opnd_ptype=x'72' %start
         outstring("NAN or unrepresentable value")
      %finish
      %if opnd_ptype=x'35' %start
         outsym('"')
         outstring(string(addr(a(opnd_d))))
         outsym('"')
      %finish
wayout:
      %if mode&1=1 %then outsym(')')
      %return
sw(2):                              { name as dictionary no }
      outname(opnd_d)
      ->wayout
sw(3):                              { name(app) as ar pointer }
      pp=p; p=opnd_d
      %if mode&2#0 %then cname(1) %else cname(2)
      p=pp; ->wayout
sw(8):                              { triple }
      outtriple(opnd_d,mode&x'ff00')
      ->wayout
%end
%routine outtriple(%integer tripno,mode)
!***********************************************************************
!*  output an expression defined by a triple which can head a tree     *
!*  mode as for outopnd                                                *
!***********************************************************************
%record(tripf)%name trip
%conststring(3)%array rsassop(ADD:ANDL)="+=","-=","^=",
                                       "|=","*=","/="(2),"&=";
%string(15) op,opl
%integer case,i,j
%switch sw(0:192)
      trip==triples(tripno)
      %if mode=1 %and doinglabel=0 %then outsym('(')
      case=trip_opern
      ->sw(case)
sw(ADD):
      op="+"; opl="plus"
binop:
      outopnd(trip_opnd1,mode&x'ff00'!trip_opnd1_flag>>3&1)
       %if doinglabel#0 %then outstring(opl) %else outstring(op)
      outopnd(trip_opnd2,mode&x'ff00'!trip_opnd2_flag>>3&1)
wayout:
      %if mode=1 %and doinglabel=0 %then outsym(')')
      %return
sw(SUB): op="-"; opl="minus"; ->binop
sw(NONEQ): op="^"; opl="non"; ->binop
sw(ORL): op="|"; opl="or"; ->binop
sw(MULT): op="*"; opl="mul"; ->binop
sw(INTDIV): op=" / "; opl="idiv"; ->binop
sw(REALDIV): op=" / "; opl="div"; ->binop
sw(ANDL): op="&"; opl="and"; ->binop
sw(RSHIFT): op=">>"; opl="rsh";  
      %if doinglabel=0 %then %start
         %if trip_opnd1_ptype&x'ff'=x'61' %then %start
             outstring("(UINT64)")
         %else
             outstring("(unsigned)")
         %finish
      %finish; ->binop
sw(LSHIFT): op="<<"; opl="lsh"; ->binop
sw(iexp):
      outstring("(int)")
sw(REXP):
      outstring("pow(")
      outopnd(trip_opnd1,mode&x'ff00')
      outstring(",")
      outopnd(trip_opnd2,mode&x'ff00')
      outstring(")")
      ->wayout
sw(RSTORE):
!     printstring("Rstore:")
      %if ADD<=trip_x1<=SUB %and 0<=trip_opnd2_flag<=1 %andc
          trip_opnd2_d=1 %and trip_opnd1_ptype&x'ff00'=0{not pointer}%start
         outopnd(trip_opnd1,mode&x'ff00')
         %if trip_x1=ADD %then outstring("++") %else outstring("--")
         ->wayout
      %finish
      op=rsassop(trip_x1); ->assop
sw(VASS):sw(VJASS):
      op="="
assop:
      outopnd(trip_opnd1,mode&x'ff00'!2)
      outstring(op)
      outopnd(trip_opnd2,mode&x'ff00'!0)
      ->wayout
sw(NOTL): op="~"; opl="not"
unaryop:
       %if doinglabel#0 %then outstring(opl) %else outstring(op)
       outopnd(trip_opnd1,mode&x'ff00'!trip_opnd1_flag>>3&1)
      ->wayout
sw(LNEG):
      op="-"; opl="uminus"; ->unaryop
sw(IFLOAT):
      %if trip_opnd1_flag=SCONST %start
           trip_opnd1_ptype=x'62'
           %begin
           %longreal x;
           x=trip_opnd1_d
           trip_opnd1_d=integer(addr(x))
           trip_opnd1_xtra=integer(addr(x)+4)
           %end
           op=""
           ->unaryop
      %finish
      op="(double)"; ->unaryop
sw(SHRTN):sw(LNGTHN):sw(JAMSHRTN):sw(NULLT):sw(PRELOAD):
      outopnd(trip_opnd1,mode&x'ff00'!0)
%end {outtriple }
         %routine CSEXP(%integer MODE)
!***********************************************************************
!*       COMPILE A SIGNED EXPRESSION TO REGISTER 'REG' IN MODE 'MODE'  *
!*       MODE=1 FOR %integer, =2 REAL, =3 LONG,=0 INTEGER %if POSSIBLE *
!*       MODE=5 FOR ADDRESS EXPRESSNS(IE LEAVE ANY CONSTANT IN 'ADISP')*
!***********************************************************************
            %integer EXPHEAD,NOPS,EXPBOT,form
            EXPHEAD = 0; EXPBOT = 0
            NOPS = 0; Form=0
            P = P+3
            %if a(p)=4 %and a(P+1)=3 %then Form=1   { Bracketed expr }
            TORP(EXPHEAD,EXPBOT,NOPS,0)
            EXPOP(EXPHEAD,EXPBOT,NOPS,MODE&x'ffff')
!            tripopt(triples,triples(0)_flink)
            outopnd(expopnd,Form! mode>>16)
         %end
%routine labexp
!***********************************************************************
!*    Evaluates the expression in a switch label to a valid cname      *
!*    This means operators have to be replaced by lettere              *
!***********************************************************************
      doinglabel=1
      csexp(x'51')
      doinglabel=0
%end
         %integer %fn CONSTEXP(%integer PRECTYPE)
!***********************************************************************
!*    COMPILES AN EXPRESSION WHICH SHOULD EVALUATE TO A CONSTANT OF    *
!*    TYPE 'PRECTYPE'. P AS FOR FN INTEXP.                             *
!***********************************************************************
            %integer EXPHEAD,EXPBOT,NOPS,RES
            EXPHEAD = 0; EXPBOT = 0; NOPS = 0; RES = 0
            TORP(EXPHEAD,EXPBOT,NOPS,1)
!      ->WAYOUT %unless NOPS&X'00040000'=0
            EXPOP(EXPHEAD,EXPBOT,NOPS,X'200'+PRECTYPE)
            ->WAYOUT %unless EXPOPND_FLAG<=1
            RES = ADDR(EXPOPND_D)
WAYOUT:
            %result = RES
         %end
         %integer %fn INTEXP(%integer %name VALUE, %integer PRECTYPE)
!***********************************************************************
!*    COMPILES AN EXPRESSION WHICH SHOULD EVALUATE TO A CONSTANT       *
!*    VALUE RETURNED IN VALUE. RESULT#0 IF FAILED TO EVALUATE          *
!*    IN THIS CASE RESULT IS IN ETOS. USED FOR BOUND CALCULATIONS      *
!*    P POINTS TO P(+') IN (+')(OPERNAD)(RESTOFEXPR)                   *
!***********************************************************************
            %integer EXPHEAD,EXPBOT,NOPS,CODE,SPTYPE,SACC
            EXPHEAD = 0; EXPBOT = 0; NOPS = 0; CODE = 0
            SPTYPE = PTYPE; SACC = ACC;  ! CALLED IN DECLARATIONS
            TORP(EXPHEAD,EXPBOT,NOPS,1)
            EXPOP(EXPHEAD,EXPBOT,NOPS,X'200'+PRECTYPE)
            CODE = 1 %unless EXPOPND_FLAG<=1 %and EXPOPND_PTYPE&x'77'=PRECTYPE
            VALUE = EXPOPND_D
            ACC = SACC; PTYPE = SPTYPE
            UNPACK
            %result = CODE
         %end
         %routine TORP(%integer %name HEAD,BOT,NOPS,%integer mode)
!***********************************************************************
!*       CONVERT THE SIGNED EXPRESSION INDEXED BY P INTO REVERSE       *
!*      POLISH NOTATION. THE REVERSE POLISH LIST IS ADDED TO 'HEAD'    *
!*      WHICH MAY CONTAIN ANOTHER EXPRESSION. THE NUMBER OF OPERATORS  *
!*      IS ADDED TO NOPS.                                              *
!*      N.B. AN INTEGER EXPRESSION IS A SPECIAL CASE OF A REAL EXPRSN  *
!*    THE TOP 20 BITS OF NOPS ARE USED TO RETURN DETAILS OF THE EXPR   *
!*    THESE BITS SIGNIFY AS FOLLOWS:-                                  *
!*    1<<17    CONTAINS VARIABLE OF MORE THAN 32 BITS                  *
!*    1<<18    NOT CONSTANT EXPRSSN IE CONTAINS AT LEAST 1 VARIABLE    *
!*    1<<19    COMPLEX IE CONTAINS FN CALL OR NEEDS DR TO EVALUATE     *
!*    mode # 0 if const expressions to be evaluated                    *
!***********************************************************************
            %switch OPERAND(1:3)
            %const %byte %integer %array PRECEDENCE(0:20)=0,3,3,4,5,5,4,3,3,4,4,5,5,3,5,5,
                                        0(3),3,5

            %const %byte %integer %array OPVAL(0:20)=0,ADD,SUB,ANDL,IEXP,REXP,MULT,NONEQ,
                  ORL,INTDIV,REALDIV,RSHIFT,LSHIFT,ADD,IEXP,REXP,0(3),LNEG,NOTL

            %integer RPHEAD,PASSHEAD,SAVEHEAD,REAL,REALOP,OPERATOR,OPPREC,
               OPND,C,D,E,BDISP,OPNAME,OPMASK,RPBOT,OPSTK,OPPSTK,PASSBOT,PIN
            %record (TAGF) %name LCELL
            %record (RD) RPOP
!
            PASSHEAD = 0; RPHEAD = 0; SAVEHEAD = 0
            REAL = 0; REALOP = 0; BDISP = 0
            RPBOT = 0; OPSTK = 0; OPPSTK = 0
            PIN=p
!
            C = A(P)
            %if 2<=C<=3 %then %start;    ! INITIAL '-' OR '\'
               NOPS = NOPS+1
                                         ! '-' =(11,3)   '\' =(10,5)
               OPSTK = C+17
               OPPSTK = PRECEDENCE(OPSTK)
               OPMASK = 1<<(19+C);       ! - %or !!
            %finish %else OPMASK = 0
NEXTOPND:   OPND = A(P+1); P = P+2
            RPOP = 0
            ->OPERAND(OPND);             ! SWITCH ON OPERAND
OPERAND(1):                              ! NAME
            OPNAME = A(P)<<8+A(P+1)
            LCELL == ASLIST(TAGS(OPNAME))
            LCELL_UIOJ <- LCELL_UIOJ!X'8000';  ! SET USED BIT
            PTYPE = LCELL_PTYPE
            TYPE = PTYPE&7; PREC = PTYPE>>4&15
            %if PTYPE=X'FFFF' %then PTYPE = X'51';  ! NAME NOT SET
            %if PTYPE=SNPT %then PTYPE = LCELL_ACC %and UNPACK
            %if (mode#0 %or string(addr(worka_lett(word(opname))))="pi") %c
               %and PTYPE&X'FF00'=X'4000' %and A(P+2)=2=A(P+3) %and 1<=TYPE<=2 %then %start
                                         ! CONST VAR
               RPOP_D = LCELL_S2; RPOP_XTRA = LCELL_S3
               RPOP_FLAG = 1; PTYPE = PTYPE&255
               %if TYPE=1 %and PREC<=5 %and X'FFFF8000'<RPOP_D<=X'7FFF' %then %c
                  RPOP_FLAG = 0 %and PTYPE = MINAPT
               REAL = 1 %if TYPE=2
               P = P+2; ->SKNAM
            %finish
            RPOP_XTRA = OPNAME
            RPOP_FLAG = ARNAME; RPOP_D = P; PTYPE = X'51' %if PTYPE=X'57'
            %if TYPE=3 %then %start
               D = P; KFORM = LCELL_KFORM
               C = COPY RECORD TAG(E); P = D;
            %finish
            %if TYPE=5 %then FAULT(76,0,OPNAME) %and RPOP_FLAG = 0 %and %c
               PTYPE = X'51'
            %if PREC>=6 %then OPMASK = OPMASK!1<<17;  ! MORE THAN 32 BITS
            %if TYPE=2 %then REAL = 1
            P = P+2
SKNAM:      %if A(P)=2 %then P = P+1 %else SKIP APP
            %if A(P)=1 %then P = P+3 %and ->SKNAM
            P = P+2
INS:        %if RPOP_FLAG=ARNAME %then OPMASK = OPMASK!1<<18
            %if PTYPE>>4&15>5 %then OPMASK = OPMASK!1<<17;  ! CONTINS LONG
            %if 3<=PTYPE&7<=7 %then PTYPE = X'51';  ! NOT SET TO INTEGER
            RPOP_PTYPE <- PTYPE
            BINSERT(RPHEAD,RPBOT,RPOP_S1,RPOP_D,RPOP_XTRA)
            ->OP
OPERAND(2):                              ! CONSTANT
            PTYPE = A(P); D = PTYPE>>4
            C = PTYPE&7
            %if (PTYPE=x'61' %and 1<<TARGET&LINTAVAIL=0) %or %c
               (D=7 %and c=2 %and 1<<TARGET&LLREALAVAIL=0) %then FAULT(99,0,0)
            %if D>=6 %then OPMASK = OPMASK!1<<17;  ! MORE THAN 32 BIT OPERAND
            %if D=4 %or d=3 %then %start
               d=4; RPOP_D = FROM AR2(P+1)
!               PTYPE = ptype&8!X'51'
            %finish %else RPOP_D = FROM AR4(P+1)
            REAL = 1 %if C=2; RPOP_FLAG = 1
            %if D=6 %then RPOP_XTRA = FROM AR4(P+5)
            %if C=5 %then %start;        ! STRING CONSTANT
               FAULT(77,0,0); RPOP_D = 1; RPOP_FLAG = 0
               P = P+A(P+1)+3; PTYPE = X'51'
            %finish %else %start
               %if D=7 %then RPOP_XTRA = RPOP_D %and RPOP_D = P+1
               %if PTYPE=X'51' %and X'FFFF8000'<=RPOP_D<=X'7FFF' %then %c
                  RPOP_FLAG = 0 %and PTYPE = MINAPT
               P = P+2+BYTES(D)
            %finish; ->INS
OPERAND(3):                              ! SUB EXPRESSION
            PASSHEAD = 0; PASSBOT = 0
            P = P+3
            TORP(PASSHEAD,PASSBOT,NOPS,mode)
            REAL = 1 %if TYPE=2
!         CONCAT(RPHEAD,PASSHEAD)
            %if RPBOT=0 %then RPHEAD = PASSHEAD %else %c
               ASLIST(RPBOT)_LINK = PASSHEAD
            RPBOT = PASSBOT
            P = P+1
OP:                                      ! DEAL WITH OPERATOR
            RPOP = 0
            ->EOE %if A(P-1)=2;          ! EXPR FINISHED
            OPERATOR = A(P)
!
! THE STRING OPERATOR '.' CAUSES CHAOS IN AN ARITHMETIC EXPRSN
! SO FAULT IT AND CHANGE IT TO THE INNOCUOUS '+'
!
            %if OPERATOR=CONCOP %then FAULT(78,0,0)
            OPPREC = PRECEDENCE(OPERATOR)
            C = OPVAL(OPERATOR)
            %if C=REALDIV %or C=REXP %then REAL = 1
            NOPS = NOPS+1
!
! UNLOAD THE OPERATOR STACK OF ALL OPERATORS WHOSE PRECEDENCE IS
! NOT LOWER THAN THE CURRENT OPERATOR. AN EMPTY STACK GIVES'-1'
! AS PRECEDENCE.
!
            %while OPPREC<=OPPSTK&31 %cycle
               RPOP_FLAG = OPVAL(OPSTK&31)
               BINSERT(RPHEAD,RPBOT,RPOP_S1,0,0)
               OPSTK = OPSTK>>5; OPPSTK = OPPSTK>>5
            %repeat
!
! THE CURRENT OPERATOR CAN NOW BE STORED
!
            OPSTK = OPSTK<<5!OPERATOR
            OPPSTK = OPPSTK<<5!OPPREC
            ->NEXTOPND
EOE:                                     ! END OF EXPRESSION
                                         ! EMPTY REMAINING OPERATORS
            %while OPSTK#0 %cycle
               RPOP_FLAG = OPVAL(OPSTK&31)
               BINSERT(RPHEAD,RPBOT,RPOP_S1,0,0)
               OPSTK = OPSTK>>5
            %repeat
            PTYPE = REAL+1
            TYPE = PTYPE
!         CONCAT(RPHEAD,HEAD)
            %if HEAD=0 %then BOT = RPBOT %else ASLIST(RPBOT)_LINK = HEAD
            HEAD = RPHEAD;               ! HEAD BACK TO TOP OF LIST
            NOPS = NOPS!OPMASK
         %end
         %routine EXPOP(%integer %name HEAD,BOT, %integer NOPS,MODE)
!***********************************************************************
!*    EVALUATE A LIST OF OPERAND AND'NOPS' OPERATORS AND LEAVE         *
!*    THE RESULT IN REG                                                *
!*    INHEAD HOLDS THE LIST THE BOTTOM BYTE OF STREAM 1 DEFINES THE    *
!*    ENTRY AS FOLLOWS:-                                               *
!*       0 = SHORT (INTEGER) CONSTANT <18 BITS --S2=CONSTANT           *
!*       1 = OTHER CONSTANT    S2 (+S3 IF NEEDED) = CONSTANT           *
!*       2 = VARIABLE S2 POINT TO AR ENTRY FOR NAME&SUBSCRIPTS         *
!*      (3 = DOPE VECTOR ITEM IF NEEDED)                               *
!*      (4 = CONDITONAL EXPRESSION AS IN ALGOL)                        *
!*       7 = INTERMEDIATE RESULT UNDER LNB  S2=DISPLCMNT FROM LNB      *
!*       8 = INTERMEDIATE RESULT STACKED                               *
!*       9 = INTERMEDIATE RESULT IN A REGISTER S2 = REG                *
!*                                                                     *
!*       10-19 = UNARY OPERATOR S2=OP S3 =EXTRA                        *
!*       20 UP = BINARY OPERATOR                                       *
!*                                                                     *
!*       MODE HAS TYPE & PREC REQD +256 BIT IF NO RESULT REQD          *
!***********************************************************************
            %routine %spec PSEVAL
!
            %integer %array OPERAND(0:2),STK(0:99)
            %record (LISTF) %name LIST
            %record (RD) %name OPND1,OPND2,OPND
            %record (TRIPF) %name CURRT

!
            %integer C,D,KK,JJ,COMM,XTRA,INHEAD,CURR TRIP,STPTR,CONSTFORM,
               CONDFORM,SAVEP,INITTRIP
!
! CORULES GIVE INFORMATION ON OPERATORS.
!     BTM 4 BITS HAVE TYPE CONVERSION RULES(SEE COERCET)
!     NEXT 4 BITS HAVE PREC RULES (SEE COERCEP)
!     2**8 SET IF COMMUTATIVE
!
            %const %half %integer %array CORULES(0:20)= %c
                                        X'1FF'{+},X'FF'{-},
                                        X'1F1'{!!},X'1F1'{!},
                                        X'1FF'{*},X'F1'{//},
                                        X'F2'{/},X'1F1'{&},X'71'{>>},
                                        X'71'{<<},X'43'{**},
                                        X'1FF'{COMP},X'FF'{DCOMP},
                                        X'21'{VMY},X'1F1'{COMB},
                                        X'14'{ASSIGN=},
                                        X'54'{ASSIGN<-},X'71'{****},
                                        X'01'{ARR BADJ},
                                        X'001'{ARR INDEX},
                                        X'100'{INDEXED FETCH}

            %const %integer %array PTYPECH(0:19)=0(12),X'11',0,-X'10',X'10',-X'10',0(3)


!
            STPTR = 0; CONSTFORM = MODE&512
            INITTRIP = NEXTTRIP
            CONDFORM = MODE&256
            SAVEP = P
            INHEAD = HEAD
            PSEVAL
NEXT:       LIST == ASLIST(INHEAD)
            XTRA = LIST_S2
            JJ = LIST_FLAG; D = INHEAD
            INHEAD = LIST_LINK
            ->OPERATOR %if JJ>=10
!
! ANY OPERAND WHICH MAY NEED DR OR B OR ACC IN THEIR EVALUATION
! EG FUNCTIONS,ARRAY ELEMENTS ETC ARE FETCHED AND STACKKED FIRST
!
            OPND1 == ASLIST(D)
            STK(STPTR) = D
            STPTR = STPTR+1
            IMPABORT %if STPTR>99
ANYMORE:
            ->NEXT %unless INHEAD=0
            OPND1 == ASLIST(STK(STPTR-1))
            EXPOPND = OPND1
            ->FINISH
OPERATOR:
            %if JJ<128 %then KK = 1 %else KK = 2;  ! UNARY OR BINARY
            %cycle KK = KK,-1,1
               STPTR = STPTR-1
               OPERAND(KK) = STK(STPTR)
            %repeat
            COMM = 1
            OPND1 == ASLIST(OPERAND(1))
            %if JJ>=128 %then %start
               OPND2 == ASLIST(OPERAND(2))

            %finish %else OPND2 == RECORD(0)
! next line must be wrong 32 is not dsided
!            %if JJ=32 %then COMM = 2;    ! DSIDED RESULT=2ND OPERAND
                                         ! ALL OTHERS RESULT=1ST OPERAND
            %if JJ<128 %then C = 0 %else C = CORULES(JJ-128)
            %if JJ=VASS %or JJ=VJASS %then KK = 1 %else KK = 2
                                         ! CNAME FETCH-STORE
!            %if OPND1_FLAG=ARNAME %and (LHSADDRFIRST=YES %or KK=2) %start
!                                         ! EXPAND UP NAMES BUT NOT LHS
!                                         ! ASSIGNMENT NAMES
!               P = OPND1_D; CNAME(KK)
!               OPND1 = NAMEOPND
!            %finish
!            %if JJ>=128 %and OPND2_FLAG=ARNAME %then %start
!               P = OPND2_D
!               CNAME(2)
!               OPND2 = NAMEOPND
!            %finish
!            %if OPND1_FLAG=ARNAME %then %start
!               P = OPND1_D
!               CNAME(KK)
!               OPND1 = NAMEOPND
!            %finish
            %if constform#0 %and OPND1_FLAG<2 %and (JJ<128 %or OPND2_FLAG<2) %then %c
               CTOP(JJ,MASK,XTRA,OPND1,OPND2)
            %if JJ#0 %then %start;       ! CODE REQUIRED OP TRIPLE
               CURR TRIP = NEW TRIP
               CURRT == TRIPLES(CURR TRIP)
               CURRT_DPTH = 0;           ! LEAVE DEPTHS TO BE WORKED OUT IN%c
                                         OPT PASS
               CURRT_CNT = 0
               CURRT_FLAGS = 1!(C>>1&128)
               CURRT_OPERN = JJ
               CURRT_OPTYPE <- OPND1_PTYPE
               %if 12<=JJ<=16 %start;    ! UNARY(TYPECHANGE)OPN
                  CURRT_OPTYPE <- XTRA; XTRA = 0
               %finish %else %if %c
                  OPND1_PTYPE&7=1 %and OPND1_PTYPE&255<MINAPT %then %c
                  CURRT_OPTYPE = MINAPT
                                         ! PREVENT OPTIMISING BYTE ARRAY SCALE
                                         ! AS THESE CREATE EXTRA WORD
                                         ! WHICH DEFEATS ALGORITHMS
               %if (TARGET=PERQ %or TARGET=ACCENT %or TARGET=PNX) %and %c
                  JJ=39 %and XTRA>>20=1 %then %c
                  CURRT_FLAGS <- CURRT_FLAGS!DONT OPT
               CURRT_X1 = XTRA
               CURRT_OPND1 = OPND1
               %if 1<<OPND1_FLAG&BTREFMASK#0 %then KEEP USE COUNT(OPND1)
               %if JJ>=128 %then %start
                  CURRT_OPND2 = OPND2
                  %if 1<<OPND2_FLAG&BTREFMASK#0 %then KEEP USE COUNT(OPND2)
               %finish
               OPND1_FLAG = 8
               OPND1_PTYPE = CURRT_OPTYPE
               OPND1_D = CURR TRIP
            %finish
            STK(STPTR) = OPERAND(COMM)
            STPTR = STPTR+1
            ->ANYMORE
FINISH:
!            %if EXPOPND_FLAG=ARNAME %then %start
!               P = EXPOPND_D
!               CNAME(2)
!               EXPOPND = NAMEOPND
!            %finish
            PTYPE = EXPOPND_PTYPE
            TYPE = PTYPE&7; PREC = PTYPE>>4
            P = SAVEP
            ASLIST(BOT)_LINK = ASL
            ASL = HEAD
            HEAD = 0; BOT = 0
            %return
            %routine PSEVAL
!***********************************************************************
!*    PERFORMS A PSEUDO EVALUATION ON THE EXPRESSION TO DETERMINE      *
!*    THE POSITION OF ANY TYPE CHANGES AND THEN INSERTS                *
!*    THESE UNARY OPERATIONS                                           *
!***********************************************************************
               %routine %spec AMEND(%record (RD) %name OPND, %integer OP)
               %routine %spec COERCET(%integer RULES)
               %routine %spec COERCEP(%integer RULES)
               %integer TMPHEAD,INHEAD,C,JJ,NEXT
               %record (RD) %name OPND1
               %record (RD) OPND2,RPOP
               %record (LISTF) %name CELL
               PRINT LIST(HEAD) %and IMPABORT %unless ASLIST(BOT)_LINK=0
               RPOP = 0
               TMPHEAD = 0
               INHEAD = HEAD
!
               %while INHEAD#0 %cycle
                  CELL == ASLIST(INHEAD)
                  NEXT = CELL_LINK
                  RPOP <- CELL;          ! COPY BEFOR ADJUSTING PTYPE
                  JJ = RPOP_FLAG;        ! FLAG
                  %if JJ<10 %start;      ! AN OPERAND
!            %if RPOP_PTYPE>>4&15<MINAPREC %then RPOP_PTYPE%c
=RPOP_PTYPE&X'FF0F'!(MINAPREC<<4)
                     PUSH(TMPHEAD,RPOP_S1,RPOP_D,INHEAD)
                  %finish %else %start;  ! AN OPERATOR
                     %if JJ>=128 %start;  ! BINARY OPERATOR
                        POP(TMPHEAD,OPND2_S1,OPND2_D,OPND2_XTRA)
                        OPND1 == ASLIST(TMPHEAD);  ! MAPPING SAVES POP&PUSH
                        C = CORULES(JJ-128)
                        %if JJ=REXP %and OPND2_PTYPE&7=2 %then C = X'F2'
                                         ! REAL TO THE REAL
                        %if C&15#0 %then COERCET(C&15)
                        %if C>>4&15#0 %then COERCEP(C>>4&15)
                     %else
                        OPND1 == ASLIST(TMPHEAD)
                        %if JJ=MODULUS %start
                           %if OPND1_PTYPE&7=1 %and RPOP_D&7=2 %then COERCET(3)
                           %if OPND1_PTYPE>>4&15<RPOP_D>>4&15 %then %c
                              AMEND(OPND1,LNGTHN)
                           %if OPND1_PTYPE>>4&15>RPOP_D>>4&15 %then %c
                              AMEND(OPND1,SHRTN)
                         %else
                            %if jj<19 %then opnd1_ptype=opnd1_ptype+ptypech(jj)
                        %finish
                     %finish
                     OPND1_XTRA = INHEAD;  ! IN CASE(FURTHER)TYPE CHANGE
                  %finish
                  INHEAD = NEXT
               %repeat
!
! FINAL COERCION ON RESULT
!
               POP(TMPHEAD,OPND2_S1,OPND2_D,OPND2_XTRA)
               PRINT LIST(HEAD) %and IMPABORT %unless TMPHEAD=0
               %if CONDFORM=0 %start
                  %if MODE&7=1 %and OPND2_PTYPE&7=2 %then FAULT(25,0,0)
                  %if OPND2_PTYPE&7=1 %and MODE&7=2 %then AMEND(OPND2,IFLOAT)
                  C = MODE>>4&15;        ! TARGET PREC
                  AMEND(OPND2,SHRTN) %while C<OPND2_PTYPE>>4&15
                  AMEND(OPND2,LNGTHN) %while C>OPND2_PTYPE>>4&15
               %finish
               PRINTLIST(HEAD) %if PARM_DCOMP#0 %and PARM_Z#0
               BOT = ASLIST(BOT)_LINK %while ASLIST(BOT)_LINK#0
               %return
               %routine AMEND(%record (RD) %name OPND, %integer OP)
!***********************************************************************
!*    ADDS IN AN OPERATION TO CHANGE THE TYPE OR PREC OF OPND          *
!*     On E machines we can not elide uneceesary changes               *
!***********************************************************************
                  %record (RD) RPOP
                  %if 1<<target&Emachine=0 %and OP=LNGTHN %and OPND_PTYPE&255<MINAPT %then %c
                     OPND_PTYPE <- OPND_PTYPE&X'FF00'!MINAPT %and %return
                  RPOP = 0
                  RPOP_FLAG = OP
                  %if OP=IFLOAT %and OPND_PTYPE&255<MINAPT %then %c
                     OPND_PTYPE = MINAPT
                  OPND_PTYPE = OPND_PTYPE+PTYPECH(OP)
                    %if 1<<target&Llrealavail=0 %and op=ifloat %c
                       %and Opnd_ptype&255=X'72' %then OPnd_ptype=opnd_ptype-x'10'
                                       ! float longinteger when longlongreal not available
                  INSERT AFTER(OPND_XTRA,RPOP_S1,OPND_PTYPE,0)
                  NOPS = NOPS+1
               %end
               %routine COERCET(%integer RULES)
!***********************************************************************
!*         RULES=1 BOTH OPERANDS INTEGER ELSE ERROR                    *
!*         RULES=2 FORCE BOTH OPERAND TO BE OF TYPE REAL               *
!*         RULES=3 OPND1 ONLY TO BE REAL(FOR **)                       *
!*         RULES=4 OPND2 TO BE OPND 1(ASSIGNMENT)                      *
!*         RULES=15  BOTH OPERANDS TO BE OF LARGEST TYPE               *
!***********************************************************************
                  %integer PT1,PT2
                  %record (RD) RPOP
                  RPOP = 0; RPOP_FLAG = 12;  ! FLOAT
                  PT1 = OPND1_PTYPE&7;
                  PT2 = OPND2_PTYPE&7; %if PT2=7 %then PT2=1
                  %if RULES=4 %then PT1 = CELL_S2&7;  ! ORIGINAL PT FOR ARRAYS%c
                                                      ETC
                  %if PT1=7 %then PT1=1
                  %if (RULES=1 %or RULES=15 %or RULES=4) %and PT1=1=PT2 %then %c
                     %return
                  %if RULES=1 %or (RULES=4 %and PT1=1) %then %c
                     FAULT(24,0,0) %and %return
                  %if PT1=1 %then AMEND(OPND1,IFLOAT)
                  %if PT2=1 %and (RULES=2 %or RULES=4 %or RULES=15) %then %c
                     AMEND(OPND2,IFLOAT)
               %end
               %routine COERCEP(%integer RULES)
!***********************************************************************
!*       RULES DEFINE COERCION AS FOLLOWS:                             *
!*       RULES=1 FORCE OPND2 TO BE OPND1(ASSIGNMENT)                   *
!*       RULES=2 OPERAND 1 TO BE 'STANDARD' INTEGER                    *
!*       RULES=4 OPERAND 2 TO BE 'STANDARD' INTEGER                    *
!*       RULES=5 AS RULES=1 BUT FOR <- ASSIGNMENT                      *
!*       RULES=6 BOTH OPERANDS TO BE 'STANDARD' INTEGER                *
!*       RULES=7 OPND1>=32BITS, OPND2 TO BE 'STANDARD'                 *
!*       RULES=15 BOTH OPERANDS TO THE LARGEST PRECISION               *
!***********************************************************************
                  %integer PREC1,PREC2,TPREC,OPER
                  %record (RD) %name OPND
                  %record (RD) RPOP
                  RPOP = 0
                  %if RULES=6 %then COERCEP(4) %and RULES = 2
                  PREC1 = OPND1_PTYPE>>4&15
                  PREC2 = OPND2_PTYPE>>4&15
                  %if RULES=5 %or RULES=1 %start;  !  ASSIGN
                     PREC1 = CELL_S2>>4&15;  ! ORIGINAL PREC FOR ARRAY ASSIGN
                     %if PREC2>PREC1 %start
                        %cycle
                           %if RULES=1 %then OPER = SHRTN %else OPER = JAMSHRTN
                           AMEND(OPND2,OPER)
                           PREC2 = PREC2-1
                        %repeat %until PREC1=PREC2
                        %return
                     %finish %else RULES = 1;  ! IN CASE LENGTHEN NEEDED
                  %finish
                  %if PREC1<MINAPREC %then %c
                     PREC1 = MINAPREC %and %c
                     OPND1_PTYPE <- OPND1_PTYPE&X'FF0F'!(MINAPREC<<4)
                  %if PREC2<MINAPREC %then %c
                     PREC2 = MINAPREC %and %c
                     OPND2_PTYPE <- OPND2_PTYPE&X'FF0F'!(MINAPREC<<4)
                  %if RULES=7 %start;    ! FORCE SHIFT INTO 32 BIT MIN REG
                     RULES = 4
                     %if PREC1=4 %then AMEND(OPND1,LNGTHN) %and PREC1 = 5
                  %finish
                  %if 2<=RULES<=4 %start
                     %if RULES<=2 %then OPND == OPND1 %else OPND == OPND2
                     %if OPND_PTYPE&X'FF'>MINAPT %then AMEND(OPND,SHRTN)
                     %return
                  %finish
                  %if PREC1<PREC2 %then %c
                     TPREC = PREC2 %and OPND == OPND1 %else %c
                     TPREC = PREC1 %and OPND == OPND2
                  OPER = OPND_PTYPE
                  AMEND(OPND,LNGTHN) %while OPND_PTYPE>>4&15<TPREC
               %end
            %end
         %end;                           ! OF ROUTINE EXPOP
         %integer %fn CCOND(%integer CTO,IU,FARLAB,JFLAGS)
!***********************************************************************
!*       COMPILES <IU><SC><RESTOFCOND>%then<UI1>%else<UI2>             *
!*       CTO=0 JUMP TO FARLAB MUST BE PLANTED IF COND UNCONDITIONAL    *
!*       CTO#0 JUMP MAY BE OMITTED                                     *
!*       IU=1 FOR %if   =2 FOR UNLESS. FARLAB TO GO ON UI2             *
!*       THE ROUTINE MAKES FOUR PASSES THROUGH THE CONDITION           *
!*       PASS 1 ANALYSES THE STRUCTURE AND DECIDES TO BRANCH ON TRUE   *
!*       (TF=2)   OR ON FALSE (TF=1) FOR EACH COMPARISON               *
!*       PASS 2 WORKS OUT WHERE THE BRANCHES OF PASS 1 SHOULD GO TO    *
!*       PASS 3 ASSIGNS LABEL NUMBERS                                  *
!*       PASS 4 EVALUATES COMPARISIONS AND PLANTS THE CODE             *
!*                                                                     *
!*       ON ENTRY P POINTS TO <SC> IN<HOLE><SC><RESTOFCOND>            *
!*       RESULT=0 CONDITION COMPILED                                   *
!*       RESULT=1 UNCONDITIONALLY TO 1ST ALTERNATIVE                   *
!*       RESULT=2 UNCONDITIONALLY TO 2ND ALTERNATIVE(FARLAB)           *
!***********************************************************************
!%routinespec WRITE CONDLIST
            %routine %spec SKIP SC(%integer REVERSED)
            %routine %spec SKIP COND(%integer REVERSED)
            %integer %fn %spec CCOMP
            %routine %spec JUMP(%integer MASK,LAB,FLAGS)
            %routine %spec NOTE JUMP(%integer LAB)
            %routine %spec LAB UNUSED(%integer LAB)
            %routine %spec OMIT TO(%integer LAB)
!
! FCOMP HAS BC MASKS FOR EACH STRING COMPARATOR.
! THE FIRST 7 ARE TO BRANCH IF TRUE WITH NORMAL COMPARISON
! THE SECOND SEVEN ARE TO BRANCH IF TRUE WITH BACKWARDS COMPARISON
!
!
            %integer PIN,PP,II,L,CPTR,CMAX,LL,BITMASK,LLA
            %record %format CF(%byte %integer TF,CMP1,CMP2,LABU,LVL,JMP,REV,
               JUMPED, %integer LABNO,SP1,SP2,sp3)
            %record (CF) %array CLIST(0:30)
            %record (CF) %name C1,C2
!
! PASS 1.   ANALYSES THE CONDITION
!
            PIN = P;                     ! SAVE INITIAL AR POINTER
            CPTR = 1; L = 3;             ! LEVEL=3 TO ALLOW 2 LOWER
            C1 == CLIST(CPTR);           ! SET UP RECORD FOR FIRST CMPARSN
            C1 = 0
            %if iu=2 %then outstring("(!")
            outsym('(')
            SKIP SC(0);                  ! SKIP THE 1ST CMPARSN
            SKIP COND(0);                ! AND ANY %and/%or CLAUSES
           %if iu=2 %then outsym(')')
            outstring(") ")
            %result=0
%routine SKIP SC(%integer REVERSED)
!***********************************************************************
!*       REVERSED=1 FOR RECURSIVE CALL IN %not(SC)                     *
!*       SKIPS OVER A SIMPLE CONDITION. P ON ALT OF<SC>                *
!***********************************************************************
%conststring(5) %array CMP(0:10)=" ??? ","==",">=",">",
                       "!=","<=","<","!=","?->??",
                       "==","!="
%switch SCALT(1:4)
%integer ALT,TE1,TE2,PRECP,TYPEp,finalp,rexp
      ALT = A(P); P = P+1
      ->SCALT(ALT)
SCALT(1):                                ! <EXP><COMP><EXP><SECONDSIDE>
      C1_SP1 = P
      te1=tsexp(TE2)
      typep=type; precp=prec
      p = c1_sp1             { tsexp may not reset p }
      SKIP EXP
      C1_CMP1 = A(P)
      C1_REV = 3*REVERSED
      P = P+1; C1_SP2 = P
      SKIP EXP
      %if A(P)=2 %then P = P+1 %else %start
         C1_CMP2 = A(P+1);      ! DEAL WITH 2ND HALF OF D-SIDED
         P = P+2; C1_SP3=P; SKIP EXP
      %finish
      finalp=p
!      outsym('(') %unless a(finalp)=3
      %if typep=5 %start
         p=c1_sp1
         %if c1_cmp1=8 %start
           outstring("imp_resolve(")
           p=p+5; cname(2)
            outsym(',')
           p=c1_sp2; cres(1)
           outstring(")==0")
            %if c1_cmp2#0 %then outstring("untranslateable cond")
        %else
            %if c1_cmp2#0 %then outsym('(')
            outstring("strcmp(")
            cstrexp(0)
            outsym(',')
            p=c1_sp2; cstrexp(0)
            outsym(')')
            outstring(cmp(c1_cmp1))
            outsym('0')
            %if c1_cmp2#0 %then %start
               outstring(") && (")
               p=c1_sp2; cstrexp(0)
               outsym(',')
               p=c1_sp3
               cstrexp(0)
               outsym(')')
            %finish
        %finish
      %else
         %if c1_cmp2#0 %then outsym('(')
         p=c1_sp1
         REXP = 2-A(P+1+FROM AR2(P+1))
         %if rexp#0 %then outsym('(')
         %if c1_cmp1>8 %then p=p+5 %and cname(4) %else csexp(precp<<4!typep!256)
         %if rexp#0 %then outsym(')')
         outstring(cmp(c1_cmp1))
         p=c1_sp2
         REXP = 2-A(P+1+FROM AR2(P+1))
         %if rexp#0 %then outsym('(')
         %if c1_cmp1>8 %then p=p+5 %and cname(4) %else csexp(precp<<4!typep!256)
         %if rexp#0 %then outsym(')')
         %if c1_cmp2#0 %start
            outstring(") && (")
            %if rexp#0 %then outsym('(')
            p=c1_sp2; csexp(precp<<4!typep)
            %if rexp#0 %then outsym(')')
            outstring(cmp(c1_cmp2))
            p=c1_sp3
            REXP = 2-A(P+1+FROM AR2(P+1))
            %if rexp#0 %then outsym('(')
            csexp(precp<<4!typep)
            %if rexp#0 %then outsym(')')
            outsym(')')
         %finish
      %finish
      p=finalp
!      outsym(')') %unless a(finalp)=3
      %return
SCALT(2):                                ! '('<SC><RESTOFCOND>')'
      outsym('(')
      L = L+1
      SKIP SC(REVERSED)
      SKIP COND(REVERSED)
      L = L-1
      outsym(')')
      %return
SCALT(3):                                ! %not(SC)
      outstring("!(")
      SKIP SC(REVERSED!!1)
      outsym(')')
      %return
SCALT(4):
      csexp(x'51');             ! single pseudo boolean expr
   %end;                        ! OF ROUTINE SKIP SC
            %routine SKIP COND(%integer REVERSED)
!***********************************************************************
!*       SKIPS OVER <RESTOFCOND>                                       *
!***********************************************************************
               %integer ALT,ALTP
               ALT = A(P);               ! 1=%and<ANDC>,2=%or<ORC>,3=NULL
               P = P+1
               %if ALT\=3 %then %start;  ! NULL ALTERNATIVE NOTHING TO DO
                  %until ALTP=2 %cycle;  ! UNTIL NO MORE <SC>S
                     C1_LVL = L; C1_TF = ALT
                     C1_TF = C1_TF!!(3*REVERSED)
                     %if alt=1 %then outstring(" && ") %else outstring(" || ")
                     CPTR = CPTR+1
                     C1 == CLIST(CPTR); C1 = 0
                     SKIP SC(REVERSED)
                     ALTP = A(P); P = P+1
                  %repeat
               %finish
            %end
!%routine WRITE CONDLIST
!%conststring(5) %array CM(0:10)="     ","    =","   >=","    >",
!                       "    #","   <=","    <","   \=","   ->",
!                       "   ==","  \=="
!      PRINTSTRING("
! NO   TF   C1   C2   LABU   LVL  JMP  REV   LABNO JUMPED
!")
!      %cycle CPTR=1,1,CMAX
!         C1==CLIST(CPTR)
!         WRITE(CPTR,2)
!         WRITE(C1_TF,4)
!         PRINTSTRING(CM(C1_CMP1))
!         PRINTSTRING(CM(C1_CMP2))
!         WRITE(C1_LABU,6)
!         WRITE(C1_LVL,5)
!         WRITE(C1_JMP,4)
!         WRITE(C1_REV,4)
!         WRITE(C1_LABNO,7)
!         WRITE(C1_JUMPED,6)
!         NEWLINE
!      %repeat
!%end
         %end;                           ! OF CCOND
         %integer %fn REVERSE(%integer MASK)
!***********************************************************************
!*       REVERSE THE MASK FOR A JCC(MASK<=15),JAT(>15) OR JAF(>31)     *
!***********************************************************************
            %if MASK=0 %or MASK=15 %then %result = MASK!!15
            %result = MASK!!X'8F'
         %end

         %integer %fn ENTER LAB(%integer LAB,FLAGS)
         %result=0
         %end
         %routine ENTER JUMP(%integer TFMASK,LAB,FLAGS)
         %end
         %routine REMOVE LAB(%integer LAB)
         %end
         %integer %fn CREATE AH(%integer MODE, %record (RD) %name EOPND,NOPND)
!***********************************************************************
!*       CREATES AN ARRAYHEAD IN THE ESTACK BY MODIFYING THE           *
!*       HEAD ALREADY THERE AS FOLLOWS:-                               *
!*       MODE=0 (ARRAYMAPPING)  ETOS-4&5 HAS 32BIT ADDR OF FIRST ELEMNT*
!*       MODE=1 (ARRAYS IN RECORDS)ETOS-4&5 HAS 32BIT RELOCATION FACTOR*
!***********************************************************************
            %integer JJ
            JJ = BRECTRIP(AHADJ,AHEADPT,0,EOPND,NOPND)
            TRIPLES(JJ)_X1 = PTYPE<<4!MODE
            %result = JJ
         %end;                           ! OF ROUTINE CREATE AH
         %routine CSNAME(%integer Z)
!***********************************************************************
!*       COMPILE A SPECIAL NAME - PTYPE=10006 (=%routine %label)       *
!*       THEIR TRUE PTYPE IS IN GLOBAL ARRAY TAGS_S2.                  *
!*       SNINFO HAS A FOUR BYTE RECORD FOR EACH NAME (%bi FLAG,PTR,    *
!*       %si XTRA). THE TOP BITS OF FLAG CATEGORISE AS FOLLOWS:-       *
!*       2**7 SET FOR IMPLICITLY SPECIFIED CONSTRUCT A %spec           *
!*       2**6 SET FOR IOCP CALL                                        *
!*       2**5 SET FOR BUILT IN MAPPING FUNCTIONS                       *
!*       2**4 SET IF AD-HOC CODE PLANTED BY THIS ROUTINE               *
!*       2**3 SET IF FIRST PARAMETER IS OF %name TYPE                  *
!*       2**2-2**0 HOLD NUMBER OF PARAMS                               *
!*                                                                     *
!*       THE FULL SPECS ARE AS FOLLOWS:-                               *
!*       0=%routine SELECT INPUT(%integer STREAM)                      *
!*       1=%routine SELECT OUTPUT(%integer STREAM)                     *
!*       2=%routine NEWLINE                                            *
!*       3=%routine SPACE                                              *
!*       4=%routine SKIP SYMBOL                                        *
!*       5=%routine READ STRING(%stringname S)                         *
!*       6=%routine NEWLINES(%integer N)                               *
!*       7=%routine SPACES(%integer N)                                 *
!*       8=%integerfn NEXT SYMBOL                                      *
!*       9=%routine PRINT SYMBOL(%integer SYMBOL)                      *
!*       10=%routine READ SYMBOL(%name SYMBOL)                         *
!*       11=%routine READ(%name NUMBER)                                *
!*       12=%routine WRITE(%integer VALUE,PLACES)                      *
!*       13=%routine NEWPAGE                                           *
!*       14=%integerfn ADDR(%name VARIABLE)                            *
!*       15=%longrealfn ARCSIN(%longreal X)                            *
!*       16=%integerfn INT(%longreal X)                                *
!*       17=%integerfn INTPT(%lonrgreal X)                             *
!*       18=%longrealfn FRACPT(%longreal X)                            *
!*       19=%routine PRINT(%longreal NUMBER,%integer BEFORE,AFTER)     *
!*       20=%routine PRINTFL(%longreal NUMBER,%integer PLACES)         *
!*       21=%realmap REAL(%integer VAR ADDR)                           *
!*       22=%integermap INTEGER(%integer VAR ADDR)                     *
!*       23=%longrealfn MOD(%longreal X)                               *
!*       24=%longrealfn ARCCOS(%longreal X)                            *
!*       25=%longrealfn SQRT(%longreal X)                              *
!*       26=%longrealfn LOG(%longreal X)                               *
!*       27=%longrealfn SIN(%longreal X)                               *
!*       28=%longrealfn COS(%longreal X)                               *
!*       29=%longrealfn TAN(%longreal X)                               *
!*       30=%longrealfn EXP(%longreal X)                               *
!*       31=%routine CLOSE STREAM(%integer STREAM)                     *
!*       32=%byteintegermap BYTE INTEGER(%integer VAR ADDR)            *
!*       33=%integerfn EVENTINF                                        *
!*       34=%longrealfn RADIUS(%longreal X,Y)                          *
!*       35=%longrealfn ARCTAN(%longreal X,Y)                          *
!*       36=%byteintegermap LENGTH(%stringname  S)                     *
!*       37=%routine PRINT STRING(%string(255) MESSAGE)                *
!*       38=%integerfn NL                                              *
!*       39=%longrealmap LONG REAL(%integer VAR ADDR)                  *
!*       40=%routine PRINT CH(%integer CHARACTER)                      *
!*       41=%routine READ CH(%name CHARACTER)                          *
!*       42=%stringmap STRING(%integer VAR ADDR)                       *
!*       43=%routine READ ITEM(%stringname ITEM)                       *
!*       44=%string(1)%fn NEXT ITEM                                    *
!*       45=%byteintegermap CHARNO(%stringname STR,%integer CHARREQD)  *
!*       46=%string(1)%fn TOSTRING(%integer SYMBOL)                    *
!*       47=%string(255)%fn SUBSTRING(%stringname S,%integer BEG,END)  *
!*       48=%recordmap RECORD(%integer REC ADDR)                       *
!*       49=%arraymap ARRAY(%integer A1ADDR,%arrayname FORMAT)         *
!*       50=%integerfn SIZEOF(%name X)                                 *
!*       51=%integerfn IMOD(%integer VALUE)                            *
!*       52=%longrealfn PI                                             *
!*       53=%integerfn EVENTLINE                                       *
!*       54=%longintegermap LONGINTEGER(%integer ADR)                  *
!*       55=%longlongrealmap LONGLONGREAL(%integer ADR)                *
!*       56=%longintgerefn LENGTHENI(%integer VAL)                     *
!*       57=%longlongrealfn LENGTHENR(%longreal VAL)                   *
!*       58=%integerfn SHORTENI(%longinteger VAL)                      *
!*       59=%longrealfn SHORTENR(%longlongreal VAL)                    *
!*       60=%integerfn NEXTCH                                          *
!*       61=%halfintegermap HALFINTEGER(%integer ADDR)                 *
!*       62=%routine PPROFILE                                          *
!*       63=%longrealfn FLOAT(%integer VALUE)                          *
!*       64=%longintegerfn LINT(%longlongreal X)                       *
!*       65=%longintegerfn LINTPT(%longlongreal X)                     *
!*       66=%shortintegermap SHORTINTEGER(%integer N)                  *
!*       67=%integerfn TRUNC(%longreal X)                              *
!***********************************************************************
%integer %fn %spec OPTMAP
%switch ADHOC(0:67)
%const %integer %array SNINFO(0:NO OF SNS)= %c
        X'41080001',X'41090001',X'408A0001',X'40A00001',
        X'40010001',X'800D0000',X'11010001',X'11010001',
        X'10020024',X'41030001',X'19030001',X'80130001',
        X'80170014',X'408C0001',X'19050024',X'80010002',
        X'11040024',X'11040024',X'80010005',X'80090006',
        X'80060007',X'2100003E',X'2100003E',X'11060024',
        X'80010008',X'80010009',X'8001000A',X'8001000B',
        X'8001000C',X'8001000D',X'8001000E',X'8015000F',
        X'2100003E',X'100D0024',X'80030010',X'80030011',
        X'1907003E',X'41070001',X'10080024',X'2100003E',
        X'41050001',X'19030001',X'2100003E',X'19030001',
        X'10020024',X'1A07003E',X'11090024',X'800F0012',
        X'110A0018',X'120B1000',X'80130013',X'11060024',
        X'100C0024',X'100D0024',X'2100003E'(2),
        X'110E0024'(4),
        X'10020024',X'2100003E',X'100F0001',X'11100024',
        X'11110024',X'11110024',X'2100003E',X'11040024'


%const %string (13) %array SNXREFS(0:20)= %c
      "s#readstring", "s#read",   "s#iarcsin", "s#int",
      "s#intpt" , "s#fracpt", "s#print" , "s#printfl",
      "s#iarccos","sqrt" , "log"  , "sin",
      "cos"  , "tan"  , "exp"  , "s#closestream",
      "s#iradius","atan2","imp_substring","s#sizeof",
      "s#write"

!
! SNPARAMS HOLDS NUMBER AND PTYPE OF FORMAL PARAMETER FOR IMPLICITLY
! SPECIFIED EXTERNAL ROUTINES. A POINTER IN SNINFO MEANS THAT NO
! DUPLICATES NEED TO BE RECORDED.
!
            %if PARAMS BWARDS=YES %then %start
   %const %integer %array SNPARAMS(0:25)=0{NO PARAMS},
   8<<16!1,LRLPT{%LONGREAL X},
   16<<16!2,8<<16!LRLPT,LRLPT{%LONGREAL X,Y},
   12<<16!2,12<<16!LRLPT,4<<16!X'51'{%LONGREAL X,%INTEGER I},
   16<<16!3,8<<16!LRLPT,4<<16!X'51',X'51'{%LONGREAL X,%INTEGER I,J},
   8<<16!1,X'435'{%STRINGNAME S},
   16<<16!3,8<<16!X'435',4<<16!X'51',X'51'{%STRINGNAME S,%INTEGER I,J},
   8<<16!1,X'400'{%NAME X},
   4<<16!1,X'51'{%INTEGER I},
   8<<16!2,4<<16!X'51',X'51'{%INTEGER I,J}
 %finish %else %start
   %const %integer %array SNPARAMS(0:25)=0{NO PARAMS},
   8<<16!1,LRLPT{%LONGREAL X},
   16<<16!2,LRLPT,8<<16!LRLPT{%LONGREAL X,Y},
   12<<16!2,LRLPT,8<<16!X'51'{%LONGREAL X,%INTEGER I},
   16<<16!3,LRLPT,8<<16!X'51',12<<16!X'51'{%LONGREAL X,%INTEGER I,J},
   8<<16!1,X'435'{%STRINGNAME S},
   16<<16!3,X'435',8<<16!X'51',12<<16!X'51'{%STRINGNAME S,%INTEGER I,J},
   8<<16!1,X'400'{%NAME X},
   4<<16!1,X'51'{%INTEGER I},
   8<<16!2,X'51',4<<16!X'51'{%INTEGER I,J}
 %finish
!
%const %byte %integer %array WRONGZ(0:15)=27,29,23,29,29,23,82,109(5),
                            23,27,109(2)

%routine %spec RTOS
%integer %fn %spec CIOCP(%integer N, %record (RD) %name PARAM)
%record (LISTF) %name LCELL
%record (LISTF) PCELL
%record (RD) OPND,OPERATOR
%record (TRIPF) %name CURRT
%string (31) SNXREF
%integer ERRNO,FLAG,POINTER,PIN,SNNO,SNNAME,NAPS,SNPTYPE,JJ,XTRA,
   IOCPEP,B,D,SNINF,P0,OPHEAD,ERRVAL,EXPHEAD,EXPBOT,formatname,NOPS
      SNNAME = FROM AR2(P)
      SNNO = K;                    ! INDEX INTO SNINFO
      TESTAPP(NAPS);               ! COUNT ACTUAL PARAMETERS
      PIN = P; P = P+2
      SNPTYPE = ACC
      SNINF = SNINFO(SNNO)
      XTRA = SNINF&X'FFFF'
      POINTER = (SNINF>>16)&255
      FLAG = SNINF>>24
      %if snptype&255=x'61' %and 1<<Target&LINTAVAIL=0 %then %c
         errno=99 %and ->errexit
!
! THE IMPLICITLY SPECIFIED ROUTINE ARE THE EASIEST OF ALL TO DEAL WITH.
! JUST SET UP THE EXTERNAL SPEC & PARAMETERS. THEN A RECURSIVE CALL
! OF CNAME THEN FINDS THE ROUTINE UNDER ITS TRUE COLOURS AND COMPILES
! THE CALL. ALL CALLS EXCEPT THE FIRST ARE DEALT WITH DIRECTLY BY CNAME.
! ALL NONTRIVIAL ROUTINES SHOULD BE DEALT WITH IN THIS MANNER
! XTRA HAS INDEX INTO ARRAY OF EXTERNAL NAMES SO THAT THESE
! CAN EASILY BE CHANGED.
!
      ->adhoc(snno)
adhoc(47):                                   ! substring
         outstring("imp_substring(")
      p=p+1; cstrexp(0); outsym(',')
      p=p+1; csexp(x'51'); outsym(',')
      p=p+1; csexp(x'51'); outsym(')');
      p=p+1; ->OKEXIT
adhoc(24):                                   ! arccos
adhoc(25):                                   ! sqrt
adhoc(26):                                   ! log
adhoc(27):                                   ! sin
adhoc(28):                                   ! cos
adhoc(29):                                   !tan
adhoc(30):                                   ! exp
      SNXREF = SNXREFS(XTRA)
      P0 = SNPARAMS(POINTER)
      %if TARGET=PERQ %or TARGET=ACCENT %then %start
         JJ = ADDR(SNXREF)
         D = LENGTH(SNXREF)
         MOVE BYTES(D+1,JJ,0,ADDR(A(0)),WORKA_ARTOP)
         JJ = ADDR(A(WORKA_ARTOP))-ADDR(A(WORKA_DICTBASE))
         WORKA_ARTOP = (WORKA_ARTOP+D+4)&(-4)
      %finish %else CXREF(SNXREF,3*PARM_DYNAMIC,P0<<16!P0>>16,JJ)
                                ! JJ SET WITH REF DISPLACEMENT
      OPHEAD = 0
      K = OPHEAD; D = 1
      %while D<=P0&15 %cycle
         B = SNPARAMS(POINTER+D)
         PTYPE = B&X'FFFF'
         UNPACK
         %if NAM=0 %then ACC = BYTES(PREC) %else ACC = 8
         %if PTYPE=X'35' %then ACC = 256;  !STRING BY VALUE
         PCELL = 0;             ! SET UP PARAMETER DESC VIA RECORD
         PCELL_PTYPE <- PTYPE;  ! FOR CONSISTENCY ON BYTE SWOPPED%c
                                HOSTS
         PCELL_SNDISP = B>>16
         PCELL_ACC <- ACC
         %if PARAMS BWARDS=YES %then %c
            PUSH(OPHEAD,PCELL_S1,PCELL_S2,0) %else %c
            INSERTAT END(OPHEAD,PCELL_S1,PCELL_S2,0)
         D = D+1
      %repeat
      %if P0>0 %then ASLIST(OPHEAD)_S3 = P0;  ! INSERT NO OF PARAMS
                                ! UPPER PART OF P0(TOTAL PARAMSPACE)
                                ! APPARENTLY NOT NEEDED AS NO BODIES
                                ! ARE PROVIDED.
      LCELL == ASLIST(TAGS(SNNAME))
      LCELL_PTYPE = SNPTYPE
      LCELL_UIOJ = 1<<4!14;     ! I=1 & J=14
      LCELL_SNDISP <- JJ;       ! RT ENTRY DISPLACEMENT
      LCELL_ACC = BYTES(SNPTYPE>>4&15)
      LCELL_SLINK = OPHEAD
      LCELL_KFORM = 0;          ! KFORM(=FORMAT INFO)
      P = PIN; CNAME(Z);        ! RECURSIVE CALL
      P = P-1; %return;         ! DUPLICATES CHECK OF <ENAME>
ADHOC(6):ADHOC(7):                       ! NEWLINES(=6) & SPACES(=7)
      %if parm_arr=0 %start
         %if snno=6 %then outstring("_imp_newlines(") %else outstring("_imp_spaces(")
         p=p+1; csexp(x'51')
         outsym(')')
         p=p+1
         ->OKEXIT
      %finish
      p=p+1
      %if tsexp(jj)>0 %and jj>0 %start
         outstring("printf("); outsym('"')
         %for xtra=1,1,jj %cycle
            %if snno=6 %then outstring("\n") %else outstring(" ")
        %repeat
         outsym('"'); outsym(')')
      %else
         p=PIN+3
         outstring("{ for (_imptempint=1; _imptempint<=")
         csexp(x'51')
         outstring("; _imptempint++) printf("); outsym('"')
         %if snno=6 %then outstring("\n") %else outstring(" ")
         outsym('"')
         outstring(");}")
      %finish
      P = P+1
      ->OKEXIT
ADHOC(37):                                  ! printstring
      %if parm_arr=0 %then outstring("_imp_printstring(") %else outstring("printf(")
      p=p+1
      cstrexp(0)
      outstring(")")
      P=P+1; ->OKEXIT
adhoc(2):                                   ! newline
      %if parm_arr=0 %start
         outstring("_imp_newlines(1)")
      %else
         outstring("printf(");outsym('"'); outstring("\n"); outsym('"'); outsym(')')
      %finish
      P=P+1; ->OKEXIT
adhoc(3):                                        ! space
      %if parm_arr=0 %start
         outstring("_imp_spaces(1)")
      %else
         outstring("printf("); outsym('"'); outsym(' '); outsym('"'); outsym(')')
      %finish
      P=P+1; ->OKEXIT
adhoc(21):                                  ! real
adhoc(22):                                  ! integer
adhoc(61):                                  ! halfinteger
adhoc(66):                                  ! shortinteger
adhoc(39):                                  ! longreal
adhoc(32):                                  ! byteinteger
adhoc(54):adhoc(55):                         ! long int & longlongreal
      outstring("(*(")
      outtype(snptype&255,0)
      outstring(" *)(")
      p=p+1; csexp(x'51')
      outstring("))")
      P=P+1; ->OKEXIT
adhoc(42):                                  ! string
      outstring("((char *)")
      p=p+1; csexp(x'51')
      outstring(")")
      P=P+1; ->OKEXIT
adhoc(45):                                   ! charno
      %if z#2 %then warn(10,0)
      p=p+1; cstrexp(0)
      outsym('[')
      p=p+1; csexp(x'51')
      outstring("-1]")
      p=p+1
      ->OKexit
ADHOC(36):                               ! length
      %if z#2 %then warn(10,0)
      outstring("strlen(")
      p=p+1; cstrexp(0)
      outstring(")")
      P=P+1; ->OKEXIT
adhoc(46):                                  ! tostring
      outstring("imp_tostring(")
      p=p+1; csexp(x'51')
      outstring(")")
      P=P+1; ->OKEXIT
ADHOC(9): adhoc(40):                      ! printsymbol & printch
      %if parm_arr=0 %start
         outstring("_imp_printsymbol(")
      %else
         outstring("printf("); outsym('"'); outstring("%c"); outsym('"'); outsym(',')
      %finish
      p=p+1; csexp(x'51')
      outstring(")")
      P = P+1
      ->OKEXIT
ADHOC(12):                               ! write
      %if parm_arr=0 %start
         outstring("_imp_write(")
         p=p+1; csexp(x'51'); outsym(',')
         p=p+1; csexp(x'51'); outsym(')')
         p=P+1; ->OKEXIT
      %finish
      p=p+1; skip exp; p=p+1; jj=tsexp(xtra)
      p=PIN+2
      %if jj#0 %start
         outstring("printf("); outsym('"'); outstring("%")
         outint(imod(xtra)+1); outstring("d"); outsym('"'); outstring(",")
      %else
         outstring("printf("); outsym('"'); outstring(" %d"); outsym('"'); outstring(",")
      %finish
      p=p+1; csexp(x'51')
      outstring(")")
      p=PIN+2; skip app
      p=p-1; ->OKEXIT
ADHOC(19):                               ! print
      %if parm_arr=0 %start
         outstring("_imp_print(")
         p=p+1; csexp(x'62'); outsym(',')
         p=p+1; csexp(x'51'); outsym(',')
         p=p+1; csexp(x'51'); outsym(')')
      %else
         outstring("printf("); outsym('"'); outstring(" %f"); outsym('"'); outstring(",")
         p=p+1; csexp(x'62')
         outstring(")")
      %Finish
      p=PIN+2; skip app
      p=p-1; ->OKEXIT
ADHOC(20):                               ! printfl
      %if parm_arr=0 %start
         outstring("_imp_printf(")
         p=p+1; csexp(x'62'); outsym(',')
         p=p+1; csexp(x'51'); outsym(')')
      %else
         outstring("printf("); outsym('"'); outstring(" %e"); outsym('"'); outstring(",")
         p=p+1; csexp(x'62')
         outstring(")")
      %finish
      p=PIN+2; skip app
      p=p-1; ->OKEXIT
ADHOC(1):                               ! SELECT OUTPUT
      %if parm_arr=0 %start
         outstring("_imp_selectoutput(")
         p=p+1; csexp(x'51'); outsym(')')
         p=p+1; ->OKEXIT
      %finish
      ! if C i-o we can not handle this so fall thru
ADHOC(*):                                ! NEXTSYMBOL(=8) & NEXTITEM(=44)
                                         ! ALSO ANY WITH NO C EQUIVALENTS
      outstring("/* ****call on untranslateable imp support routine**** */")
     skip app; p=p-1; -> OKEXIT
ADHOC(64):ADHOC(65):                      ! LINT(=64) AND LINTPT(=65)
            %unless TYPEFLAG(10)&255=X'61' %and TYPEFLAG(12)&255>=X'62' %then %c
               ERRNO = 99 %and ->ERREXIT
! NEED LONGINTS&LLREALS
      outstring("((long int) floor(")
      p=p+1
      CSEXP(typeflag(12)&255);    ! LONGLONGREAL MODE or longreal if defaulted
      %if SNNO=64 %then outstring("+0.5")
      outstring("))")
      P = P+1
      P0 = X'61'; ->OKEXIT
ADHOC(16):ADHOC(17):                      ! INT(=16) AND INTPT (=17)
      outstring("((int) floor(")
      p=p+1
      CSEXP(LRLPT)
      %if SNNO=16 %then outstring("+0.5")
      outstring("))")
      P = P+1
      ->OKEXIT
ADHOC(67):                                 ! trunc
      outstring("((int)(")
      p=p+1
      CSEXP(LRLPT)
      outstring("))")
      P = P+1
      ->OKEXIT
ADHOC(14):                                ! ADDR(=14)
      P = P+6; CNAME(4);           ! FETCH ADDRESS MODE
      P = P+2; ->OKEXIT
ADHOC(23):                                ! MOD(=23)
      outstring("fabs(")
      p=p+1
      csexp(x'62')
      outstring(")")
      P = P+1
      ->OKEXIT
ADHOC(51):                               ! imod
      outstring("abs(")
      p=p+1
      csexp(x'51')
      outstring(")")
      P = P+1
      ->OKEXIT
ADHOC(52):                               ! PI(=52)
ADHOC(38):                                ! NL(=38). THIS FN IS PICKED OFF
            P = P+1
            ->OKEXIT;                    ! ERROR EG NL=A+B
ADHOC(48):                               ! RECORD(=48)
      p=p+1
      %if tsexp(jj)=1 %and jj=0 %start
         outstring("NULL")
      %else
         %if z#4 %start
            outsym('(')
!            outsym('('); outtype(x'33',lhformatname)
!            outsym('*')
!            outsym(')')
         %finish
         p=PIN+3
         CSEXP(X'51')
         P = P+1
         outsym(')')
      %finish
      DISP = 0; BASE = 0; ACCESS = 3
      OLDI = 0; ACC = X'FFFF'
      SNPTYPE = SNPTYPE+X'1C00';   ! ADD MAP BITS
      PTYPE = SNPTYPE; UNPACK
      %return
ADHOC(49):                               ! ARRAY(=49)
      p=p+1
      skip exp
      ERRNO = 22; ERRVAL = 2
      ->ERREXIT %unless A(P+4)=4 %and A(P+5)=1
      P = P+6; formatname=fromar2(p)
      copytag(formatname,NO)
      p=p+4
      ->ERREXIT %unless A(P)=2
      xtra=p+2
      outstring("(("); outtype(ptype&255,lhformatname)
      outstring("*)(")
      p=PIN+3
      CSEXP(X'51');                ! ADDR(A(0)) TO NEST
      outstring("))")
      copytag(formatname,NO)
      P = xtra
      %return
ADHOC(13):                               ! EVENTINF(=33) & EVENTLINE
            D = CURRINF_ONINF
            FAULT(16,0,SNNAME) %if D=0
            D = D+4 %if SNNO#33
            BASE = RBASE; ACCESS = 0
            DISP = D; SNPTYPE = SNPTYPE+X'1C00';  ! ADD MAP BITS
            ->OKEXIT
!ADHOC(14):                               ! LENGTHEN AND SHORTEN
            D = (SNNO&3)*8
            JJ = X'62517261'>>D&255
            %if 1<<TARGET&LLREALAVAIL=0 %and JJ=X'72' %then JJ = X'62'
            %if 1<<TARGET&LINTAVAIL=0 %and JJ=X'61' %then JJ = X'51'
            CSEXP(JJ)
            P = P+1
            NAMEOPND = EXPOPND
            ->OKEXIT
ADHOC(15):                               ! PPROFILE(IGNORED UNLESS PARM SET)
            JJ = UCONSTTRIP(PPROF,X'51',0,PROFAAD) %unless PARM_PROF=0
            ->OKEXIT
!ADHOC(16):                               ! FLOAT
            CSEXP(LRLPT)
            NAMEOPND = EXPOPND
            P = P+1
OKEXIT:                                  ! NORMAL EXIT
            PTYPE = SNPTYPE; UNPACK
            ACC = BYTES(PREC)
            %return
ERREXIT:                                 ! ERROR EXIT
            FAULT(ERRNO,ERRVAL,SNNAME)
            NAMEOPND = 0; NAMEOPND_PTYPE = X'51'
            BASE = 0; DISP = 0; ACCESS = 0; AREA = 0
            PTYPE = SNPTYPE; UNPACK
            P = PIN+2; SKIP APP
            P = P-1; %return
            %integer %fn CIOCP(%integer EP, %record (RD) %name PARAM)
!***********************************************************************
!*    CALL IOCP PASSING A PARAMETER
!*    RETURNS THE TRIPLE NO OF THE CALL
!***********************************************************************
               %record (RD) OPND
               OPND_PTYPE = MINAPT; OPND_FLAG = SCONST
               OPND_D = EP
               %result = BRECTRIP(IOCPC,MINAPT,DONT OPT,OPND,PARAM)
            %end
            %routine RTOS
!***********************************************************************
!*       PLANTS CODE TO CONVERT A SYMBOL IN EXPOPND TO A ONE           *
!*       CHARACTER STRING IN A TEMPORARARY VARIABLE.                   *
!***********************************************************************
               %integer KK,JJ
               %if EXPOPND_FLAG<=1 %start
                  KK = ITOS1
                  CTOP(KK,JJ,0,EXPOPND,NAMEOPND)
                  %if KK=0 %then NAMEOPND = EXPOPND %and %return
               %finish
               JJ = URECTRIP(ITOS1,X'35',0,EXPOPND)
               NAMEOPND_PTYPE = X'35'; NAMEOPND_FLAG = REFTRIP
               NAMEOPND_D = JJ
            %end
         %end;                           ! OF ROUTINE CSNAME
         %routine CANAME(%integer Z,ARRP, %record (RD) %name HDOPND)
!***********************************************************************
!*       BS & DP DEFINE THE POSITION OF THE ARRAY HEAD                 *
!*       ARRP=1 FOR ARRAYS,2 FOR VECTORS,3 FOR ARRAYS IN RECORDS       *
!*       BASIC DISP = DISPMNT OF A(0) FOR VECTORS OR ARRAYS IN RECORDS *
!***********************************************************************
%integer HEAD1,BOT1,NOPS,ELSIZE,PTYPEP,JJ,SOLDI,KK,PP,TYPEP,LB,
   ARRNAME,Q,PRECP,NAMINF,DVD,DVDP,PRIVOPS
%record (RD) VMYOP,RPOP
%record (TAGF) %name LCELL
%integer %array HEADS,BOTS(0:12)
            NOPS = 0; HEAD1 = 0; BOT1 = 0
            PP = P; TYPEP = TYPE
            JJ = J; PTYPEP = PTYPE; PRECP = PREC; SOLDI = OLDI
            %if TYPE<=2 %then ELSIZE = BYTES(PRECP) %else ELSIZE = ACC
            %if ELSIZE>4095 %or (TYPE=5 %and NAM#0) %then ELSIZE = 0
            DVD = SNDISP;                ! LOCATION OF DV IF CONSTANT
            VMYOP_FLAG = 0; VMYOP_XB = 0
            ARRNAME = FROM AR2(P);       ! NAME OF ENTITY
            NAMINF = TAGS(ARRNAME)
            FAULT(87,0,ARRNAME) %if ARR=3;  ! ARRAYFORMAT USED AS ARRAY
!            NAMINF = -2 %and DVD = 0 %if ARRP>2;  ! ARRAYS IN RECORDS
            %if DVD>0 %then VMYOP_PTYPE = X'51' %and VMYOP_D = DVD %else %c
               VMYOP = HDOPND
            TEST APP(Q);                 ! COUNT NO OF SUBSCRIPTS
!
! CHECK CORRECT NO OF SUBSCRIPTS PROVIDED. HOWEVER ENTITIES DECLARED
! AS %<TYPE>ARRAYNAME HAVE NO DIMENSION . THIS SECTION SETS THE
! DIMENSION FROM THE FIRST USE OF THE NAME.
!
            %if JJ=0 %then %start;       ! 0 DIMENSIONS = NOT KNOWN
               LCELL == ASLIST(TCELL)
               LCELL_UIOJ = LCELL_UIOJ!Q;  ! DIMSN IS BOTTOM 4 BITS OF TAG
               JJ = Q
            %finish
            %if JJ=Q#0 %then %start;     ! IN LINE CODE
!
! FOR IN-LINE CODE WE SET UP A CHAIN OF REVERSE POLISH OPERATIONS TO
! EVALUATE THE VARIOUS SUBSCRIPTS,MULTIPLY BY THE MULTIPLIERS AND
! ADD THEM TOGETHER.
!
!
! NOW PROCESS THE SUBSCRIPTS CALLING TORP TO CONVERT THE EXPRESSIONS
! TO REVERSE POLISH AND ADDING THE EXTRA OPERATIONS.
!
               P = PP+3
               %cycle KK = 1,1,JJ;       ! THROUGH THE SUBSCRIPTS
                  heads(kk)=p; skip exp
                  P = P+1
               %repeat
               pp=p; outstring(" [")
               DVDP=DVD+3*jj
               %cycle KK = jj,-1,1
                  p=heads(kk); csexp(x'51')
                  LB=Ctable(DVDP)
                  %if DVD#0 %start    { we know how to adjust bounds }
                     %if LB=x'80000000' %start
                        outstring("-(")
                        p=Ctable(DVDP+1); csexp(x'51'); outsym(')')
                     %finish %else %if lb>0 %start
                        outsym('-'); outint(LB)
                     %finish %else %if LB=0 %start
!                        outint(LB)
                     %finish %else %if LB<0 %start
                        outsym('+'); outint(-LB)
                     %finish
                  %else
                     warn(13,0)
                  %finish
                  outstring("] [") %unless kk=1
                  DVDP=DVDP-3
               %repeat
               p=pp; outsym(']')
            %finish %else %start
               RPOP = 0; RPOP_FLAG = SCONST
               BINSERT(HEAD1,BOT1,RPOP_S1,0,0)
               %if JJ>Q %then FAULT(20,JJ-Q,ARRNAME) %else %c
                  FAULT(21,Q-JJ,ARRNAME)
               P = P+2; SKIP APP
            %finish
            SOLDI = OLDI
            ACCESS = 3
            ACC = ELSIZE; PTYPE = PTYPEP; UNPACK; J = JJ
            %if TYPE=5 %and NAM>0 %then MLOPND = HDOPND
            OLDI = SOLDI;                ! FOR NAME==A(EL) VALIDATION
            %return
         %end;                           ! OF ROUTINE CANAME
%routine namepreamble(%integer z,fname)
!***********************************************************************
!*     puts any unary operators on front of the name                   *
!*     assumes ptype has been set and unpacked                         *
!***********************************************************************
%integer typep,qq,subs,pp
      typep=type
      pp=p
      %if typep=3 %then qq=copy record tag(subs) %and p=pp
      %if z=3 %and type#5 %and (nam=0 %or arr#0) %then outsym('&')
      %if z=4 %and type#5 %and (nam=0 %or arr#0) %then outstring("(int)&")
      %if z=4 %and (type=5 %or (nam#0 %and arr=0)) %then outstring("(int)")
      %if (z=1 %or z=2) %and ((nam#0 %and arr=0=rout) %orc
      (nam>=2 %and rout=1{mapping fn call })) %and type#5 %c
       %and %not(typep=3 %and qq=0){ NOT RECORD WITHOUT SUBNAME} %then outsym('*')
      %if z=7 %and typep=3 %and qq=0 %and nam#0 %and arr=0 %thenc
         outsym('*')          { record pointer without subname }
      outname(fname)
      %if typep=3 %then copy tag(fname,no)
%end
!*
         %routine CNAME(%integer Z)
!***********************************************************************
!*       THIS IS THE MAIN ROUTINE FOR PROCESSING NAMES.CANAME,CSNAME   *
!*       AND CRNAME ARE ONLY CALLED FROM HERE,THE NAME (AND ANY PARAMS *
!*       OR SUBNAMES) ARE ACCESSED BY P WHICH IS ADVANCED.             *
!*       Z SPECIFIES ACTION AS FOLLOWS:-                               *
!*       Z=0 COMPILE A ROUTINE CALL                                    *
!*       Z=1 ARRANGE  A 'STORE' OPERATION FROM ESTACK                  *
!*       Z=2 FETCH NAME TO ESTACK                                      *
!*       Z=3 GET 32 BIT ADDRESS(48BIT FOR BYTES) FOR PASSING BY NAME   *
!*       Z=4 SET 20 BIT ADDRESS(36BIT FOR BYTES) OF NAME IN REG        *
!*       Z=5  AS Z=2                                                   *
!*       Z=6 STORE ETOS (CONTAINS POINTER) INTO POINTER VARIABLE       *
!*       Z=7->10  NOT NOW USED                                         *
!*       Z=11 FETCH 32 BIT ADDRESS OF ARRAYHEAD                        *
!*       Z=12 FETCH ARRAYHEAD TO ESTACK                                *
!*       Z=13 GET 4 WORD ROUTINE DISCRIPTOR                            *
!*              (INTERNAL ROUTINES FIRST CREATE THE DISCRIPTOR)        *
!*                                                                     *
!***********************************************************************
            %integer JJ,KK,LEVELP,DISPP,NAMEP,PP,SAVESL,FNAME
            %record (RD) TOPND
            %switch S,FUNNY(11:13),SW(0:8)
            PP = P
            FNAME = A(P)<<8+A(P+1)
            %if Z=1 %or Z=6 %then STNAME = FNAME
            copy tag(Fname,YES);         ! DECLARE IF UNKNOWN AT THIS POINT
            SAVESL = ACC
            JJ = J; JJ = 0 %if JJ=15
            NAMEP = FNAME
            LEVELP = I; DISPP = K
            FAULT(43,0,FNAME) %if %c
               LITL=1 %and ROUT=0=NAM %and (Z=1 %or Z=3 %or (Z=4 %and ARR=0))
            ->NOT SET %if TYPE=7
            %if (Z=0 %and (ROUT#1 %or 0#TYPE#6)) %or (Z=13 %and ROUT=0) %then %c
               FAULT(27,0,FNAME) %and ->NOT SET
            ->FUNNY(Z) %if Z>=10
            ->RTCALL %if ROUT=1
           namepreamble(z,fname)
            ->SW(TYPE)
SW(6):
            FAULT(5,0,FNAME)
            ->NOT SET
SW(4):                                   !RECORD FORMAT NAME
            FAULT(87,0,FNAME)
NOT SET:                                 ! NAME NOT SET
           namepreamble(z,fname)
SW(7):
            BASE = I; DISP = K; ACCESS = 0
            NAMEOPND = 0; NAMEOPND_PTYPE = X'51'
            PTYPE = X'51'; UNPACK
            P = P+2
            %if a(p)=1 %start
               {%if z=1 %or z=3 %or z=4 %then jj='[' %else} jj='('
               outsym(jj)
               p=p+1; csexp(x'51')
               %while a(p)=1 %cycle
                   outsym(','); p=p+1; csexp(x'51')
               %repeat
               outsym(jj+1+jj>>6)      { ')' or ']' }
           %finish
           p=p+1
          ->CHKEN
FUNNY(11):                               ! SET 32 BIT ADRESS OF ARRAYHEAD
FUNNY(12):                               ! MOVE ARRAYHEAD TO ESTACK
            %if PTYPE=SNPT %then CSNAME(12) %and ->CHKEN
            namepreamble(z,fname)
            ->SW(3) %if TYPE=3 %and (ARR=0 %or A(P+2)=1)
            %if A(P+2)=2 %then P = P+3 %else NO APP
            NAMEOPND_FLAG = DNAME
            NAMEOPND_D = FNAME
            NAMEOPND_XTRA = 0
S(12):
S(11):                                   ! ARRAYS IN RECORDS BY NAME
            NAMEOPND_PTYPE = AHEADPT
            ->CHKEN
FUNNY(13):                               ! LOAD ADDR FOR RT-TYPE
            %if PTYPE=SNPT %then CSNAME(Z) %and P = P+1 %and ->CHKEN
           namepreamble(z,fname)
            JJ = UNAMETRIP(RTFP,RTPARAMPT,0,FNAME)
            NAMEOPND_PTYPE = RTPARAMPT; NAMEOPND_FLAG = REFTRIP
            NAMEOPND_D = JJ
            NAMEOPND_XTRA = 0
            %if A(P+2)=2 %then P = P+3 %else NO APP
            ->CHKEN
RFUN:                                    ! RECORD FUNCTIONS
            EXPOPND = NAMEOPND
RMAP:                                    ! RECORD MAPS
            COPY TAG(NAMEP,NO);          ! SET KFORM ETC
            P = P-3
            NAMEP = -1
            CRNAME(Z,3,0,0,NAMEP)
            ->RBACK
SW(3):                                   ! RECORD
            CRNAME(Z,2*NAM,I,K,NAMEP)
RBACK:
            ->S(Z) %if Z>=10
            ->STRINREC %if TYPE=5 %and Z#6
            ->NOT SET %if TYPE=7
            NAMEOP(Z,BYTES(PREC),NAMEP)
            STNAME = NAMEP %if Z=1 %or Z=6
            ->CHKEN
SW(5):                                   ! TYPE =STRING
!
! ALL STRING OPERATIONS ARE ON THE RELEVANT DESCRIPTOR. Z=2 &Z=5
! REQUIRE A CURRENT LENGTH(IE MODIFIED) DESCRIPTOR. OTHER OPERATIONS
! REQUIRE THE MAX LENGTH DESCRIPTOR (IE UNMODIFIED HEADER)
!
            %if Z=6 %then ->SW(1)
            ->STRARR %if ARR>=1
            %if A(P+2)=2 %then P = P+3 %else NO APP
            BASE = I; ACCESS = 2*NAM; DISP = K
SMAP:       MLOPND = 0
            %if NAM#1 %then %start
               MLOPND_PTYPE = X'51'
               MLOPND_D = SAVESL-1
            %else
               MLOPND_PTYPE = X'61'
               MLOPND_FLAG = LOCALIR
               MLOPND_D = I<<16!K
            %finish
            NAMEOP(Z,4,NAMEP)
            ->CHKEN
STRARR:                                  ! STRINGARRAYS &  ARRAYNAMES
            TOPND = 0
            TOPND_PTYPE = AHEADPT; TOPND_FLAG = DNAME
            TOPND_D = FNAME
            CANAME(Z,ARR,TOPND)
            ->SMAP %unless Z=3 %and NAM#0
                                         ! MLOPND LEFT SET BY CANAME
            NAMEOP(3,4,NAMEP)
            ->CHKEN
STRINREC:                                ! STRINGS IN RECORDS
            SAVESL = ACC
            ->SMAP %unless Z=3 %and NAM#0 %and ARR#0
                                         ! MLOPND SET BY CANAME & SET LEFT SET%c
                                         BY CENAME
            NAMEOP(3,4,NAMEP)
            ->CHKEN
!
! SECTION TO DEAL WITH ALL NAMES INVOLVING ROUTINE CALL
!
RTCALL:                                  ! FIRST CHECK
            %if TYPE=0 %and Z#0 %then FAULT(23,0,FNAME) %and ->NOT SET
                                         ! RT NAME IN EXPRSN
            %if PTYPE=SNPT %then %start
               CSNAME(Z);                ! SPECIAL NAME
               ->BIM %if ROUT=1 %and NAM>1 %and Z#0
               ->CHKEN
            %finish
           namepreamble(z,fname)
            CRCALL(FNAME); P = P+1;      ! DEAL WITH PARAMS
            ->CHKEN %if PTYPE&15=0
            ->UDM %if NAM>1;             ! MAPS
            %unless Z=2 %or Z=5 %or Z=3=TYPE %start;  ! FUNCTIONS
               FAULT(29,0,FNAME); BASE = 0
               ACCESS = 0; DISP = 0
            %finish
            ->RFUN %if TYPE=3
            ->CHKEN
UDM:                                     ! USER DEFINED MAPS
            DISP = 0
            ACCESS = 3
            BASE = 0
            EXPOPND = NAMEOPND
            ->RMAP %if TYPE=3
BIM:                                     ! BUILT IN MAPS
            NAMEP = -1
            STNAME = -1
            %if TYPE=5 %then SAVESL = 256 %and ->SMAP
            KK = Z; KK = 2 %if Z=5
            NAMEOP(Z,BYTES(PREC),NAMEP)
            ->CHKEN
SW(0):                                   ! %name PARAMETERS NO TYPE
                                         ! ALLOW FETCH ADDR OPERATIONS
                                         ! AND SPECIAL FOR BUILTIN MAPS
            %unless 3<=Z<=4 %then %start
               FAULT(90,0,FNAME); TYPE = 1
            %finish
SW(1):                                   ! TYPE =INTEGER
SW(2):                                   ! TYPE=REAL
            %if ARR=0 %or (Z=6 %and A(P+2)=2) %then %start
               BASE = I; ACCESS = 2*NAM
               DISP = K
               %if A(P+2)=2 %then P = P+3 %else NO APP
            %finish %else %start
               TOPND = 0
               TOPND_PTYPE = AHEADPT; TOPND_FLAG = DNAME
               TOPND_D = FNAME
               CANAME(Z,ARR,TOPND)
               NAM = 0
            %finish
            NAMEOP(Z,BYTES(PREC),NAMEP)
            ->CHKEN
!
CHKEN:      %while A(P)=1 %cycle
               FAULT(69,FROMAR2(P+1),FNAME)
               outsym('_'); outname(fromar2(P+1))
               P = P+3; SKIP APP
            %repeat
            P = P+1
         %end

         %routine NAMEOP(%integer Z,SIZE,NAMEP)
         %end
         %routine CRCALL(%integer RTNAME)
!***********************************************************************
!*       COMPILE A ROUTINE OR FN CALL                                  *
!*       THE PROCEDURE CONSIST OF THREE PARTS:-                        *
!*       A) PLANT THE PARAMETER (IF ANY)                               *
!*       B) ENTER THE ROUTINE OR FN                                    *
!*       C) FORGET ANY REGISTERS WHICH HOLD ENTITIES THAT CAN BE       *
!*          ALTERED BY THE CALLED PROCEDURE.                           *
!***********************************************************************
%integer II,III,QQQ,JJ,JJJ,NPARMS,PT,LP,PSIZE,TWSP,PARMNO,ERRNO,
   FPTR,TYPEP,PRECP,NAMP,TL,CLINK,PSPECED,OUTP,PPTYPE,DVD,DVDP,LB,KK
%record (RD) OPND,OPND1,OPND2
%record (LISTF) %name LCELL
            PT = PTYPE; JJJ = J; TL = OLDI
            TWSP = 0; FPTR = 0
            LP = I; CLINK = K
            TYPEP = TYPE; PRECP = PREC; NAMP = NAM
            %if CLINK=0 %then PSPECED = 0 %else PSPECED = ASLIST(CLINK)_S3&255
!
            %begin
               %integer %array ARP(0:PSPECED)
               %switch FPD(0:3)
! NOW CHECK THAT THE RIGHT NUMBER OF PARAMETERS HAVE BEEN PROVIDED
! ALSO NOTE THE POINTERS TO ACTUAL PARAMETERS ALLOWING FOC 'C' COMPATABILITY
!
               P = P+2
               NPARMS = 0
               %while A(P)=1 %cycle
                  P = P+1
                  %if NPARMS<PSPECED %start
                     %if PARAMS BWARDS=YES %then %c
                        ARP(PSPECED-NPARMS) = P %else ARP(NPARMS+1) = P
                  %finish
                  NPARMS = NPARMS+1
                  SKIP EXP
               %repeat
               OUTP = P
               %if PSPECED#NPARMS %then %start
                                         ! WRONG NO OF PARAMETERS GIVEN
                  %if PSPECED=0 %then ERRNO = 17 %else %start
                     %if NPARMS<PSPECED %then ERRNO = 18 %else ERRNO = 19
                  %finish
                  FAULT(ERRNO,IMOD(PSPECED-NPARMS),RTNAME)
                  SKIP APP; P = P-1
                  NAMEOPND = 0; NAMEOPND_PTYPE = X'51';  ! ENSURE SENSIBLE%c
                                                         RESULT TRIPLE
                  ->OVER
               %finish
!
               II = UNAMETRIP(PRECL,PT&255,0,RTNAME)
               PARMNO = 0
               outsym('(')
               ->FIRST PARM
!
BAD PARM:                                ! BAD PARAMETER FAULT IT
            %if PARAMS BWARDS=Yes %then II=pspeced-parmno+1 %else ii=parmno
               FAULT(22,II,RTNAME)
NEXT PARM:     CLINK = LCELL_LINK
              outsym(',') %unless clink=0
FIRSTPARM:     ->ENTRY SEQ %if CLINK=0;  ! DEPART AT ONCE IF NO PARAMS
               LCELL == ASLIST(CLINK)
               PSIZE = LCELL_ACC&X'FFFF'
               PARMNO = PARMNO+1
               P = ARP(PARMNO)
               PTYPE = LCELL_PTYPE
               UNPACK
               II = TYPE; III = PREC
               JJ = (NAM<<1!ARR)&3
               ->BAD PARM %unless %c
                  (JJ=0 %and ROUT=0) %or JJ=2 %or (A(P+3)=4 %and %c
                  A(P+4)=1 %and A(P+FROMAR2(P+1)+1)=2)
               OPND_PTYPE <- PTYPE; OPND_FLAG = DNAME
               OPND_D = RTNAME
               OPND_XTRA = PARMNO<<24!CLINK
!
! RT TYPE PARAMS, PASS 4 WORDS AS SET UP  BY QCODE INSTRN LVRD
!
               %if ROUT=1 %then %start
                  II = PTYPE; P = P+5
                  CNAME(13);             ! SET UP 4 WDS IN ACC
                  ->BAD PARM %if II&255#PTYPE&255;  ! PREC&TYPE SIMILAR
                  P = P+1
                  FPTR = FPTR+RTPARAMSIZE
                  ->NEXT PARM
               %finish
               ->FPD(JJ)
FPD(0):                                  ! VALUE PARAMETERS
               %if TYPE=3 %start;        ! RECORDS BY VALUE
                  II = TSEXP(III);       ! CHECK FOR ZERO AS RECORD VALUE
                  %if II=1 %and III=0 %start
                     -> bad parm
                  %finish %else %start
                     P = ARP(PARMNO);    ! RESET NEEDED AFTER TSEXP
                     ->BAD PARM %unless %c
                        A(P+3)=4 %and A(P+4)=1 %and A(P+FROMAR2(P+1)+1)=2
                     P = P+5
                     CNAME(6)
                     P = P+1
                     JJ = 1
                     EXPOPND = NAMEOPND
                     ->BAD PARM %unless ACC=PSIZE
                  %finish
                  FPTR = FPTR+PSIZE
                  %if TARGET=EMAS %then FPTR = FPTR+8;  ! TIRESOME BACK%c
                                                        COMPATIBILITY
                                         ! WITH EMAS IMP ON RECORD VALUES
               %finish %else %if TYPE=5 %then %start
                  %if STRVALINWA=YES %start;  ! USING WORK AREA (2900)
                     CSTREXP(0)
                     PUSH(TWSP,VALUE,0,0);  ! REMEBER WA
                     FPTR = FPTR+PTRSIZE(X'35')
                     pptype = x'51'
                     %if ptrsize(x'35')>4 %then pptype = x'61'
                     opnd1 = 0; opnd2 = 0
                     opnd2_flag = sconst; opnd2_ptype = x'51'
                     opnd2_d = lcell_acc-1
                     opnd1_flag = localir; opnd1_ptype = x'35'
                     opnd1_d = rbase<<16!value
                     opnd1_flag = reftrip; opnd1_ptype = pptype
                     ->next parm
                  %finish %else %start
                     CSTREXP(0)
                     FPTR = FPTR+ACC
                  %finish
               %finish %else %start
                  CSEXP(III<<4!II)
                  FPTR = FPTR+BYTES(III)
               %finish
               FPTR = (FPTR+MINPARAMSIZE-1)&(-MINPARAMSIZE)
               ->NEXT PARM
!
FPD(2):                                  ! NAME PARAMETERS
               PPTYPE = X'51';           ! PTYPE OF RESULTANT POINTER
               %if PTRSIZE(PTYPE&255)>4 %then PPTYPE = X'61'
               %if II#0 %start;          ! NOT A GENERAL NAME
                  QQQ = 0
                  %if A(P+3)=4 %and A(P+4)=1 %and A(P+FROMAR2(P+1)+1)=2 %start
                     P = P+5
                     REDUCE TAG(YES)
                     %if II=TYPE %and III=PREC %and (LITL#1 %or NAM#0) %and %c
                        (ROUT=0 %or NAM=2) %then QQQ = 1 %else P = P-5
                  %finish
                  %if QQQ#0 %then CNAME(3) {TRUE REF} %else %start
                                         ! EXPRESSION BY REFERENCE
                     ->BAD PARM %unless JJJ=14 %or LP=0
                     ->BAD PARM %if II=3
                     %if II=5 %start;    ! STRING EXPRESSION
                        CSTREXP(0)
                        PUSH(TWSP,VALUE,0,0)
                        QQQ = VALUE
                        OPND2_D = 255
                     %finish %else %start
                        GET WSP(QQQ,BYTES(III)>>2)
                        CSEXP(LCELL_PTYPE&255)
                        OPND2_D = BYTES(III)
                     %finish
                     OPND2_FLAG = SCONST
                     OPND2_PTYPE = X'51'
                     OPND1_FLAG = LOCALIR
                     OPND1_PTYPE = LCELL_PTYPE&255
                     OPND1_D = RBASE<<16!QQQ
                     OPND1_XTRA = 268;               ! size of area needed for stack dowm m-cs
                     %if II#5 %then %c
                     NAMEOPND_FLAG = REFTRIP
                     NAMEOPND_PTYPE = PPTYPE
                     NAMEOPND_D = QQQ
                  %finish
                  JJ = PTRSIZE(III<<4!II)
                  FPTR = FPTR+JJ
               %finish %else %start
                  ->BAD PARM %unless %c
                     A(P+3)=4 %and A(P+4)=1 %and A(P+1+FROMAR2(P+1))=2
                  P = P+5
                  FNAME = FROM AR2(P)
                  REDUCE TAG(NO)
                  OPND2_PTYPE = X'51'; OPND2_FLAG = SCONST
                  OPND2_D = ACC<<16!PTYPE
                  OPND2_XTRA = 0
                  %if TYPE=0 %start;     ! NAME AS GENERAL NAME
                     NAMEOPND_PTYPE <- PTYPE; NAMEOPND_FLAG = DNAME
                     NAMEOPND_D = FNAME
                     NAMEOPND_XTRA = X'80000000'
                  %finish %else %if NAM#0 %and TYPE=5 %start
                     CNAME(3)
                  %finish %else CNAME(4)
                  EXPOPND_PTYPE = X'61'; EXPOPND_FLAG = REFTRIP
                  EXPOPND_XTRA = 0
                  FPTR = FPTR+PTRSIZE(0)
               %finish
               P = P+1
               ->NEXT PARM
FPD(1):
FPD(3):                                  ! ARRAY NAME (&VALUE)
!
! FOR ARRAYNAME PARAMETERS THE NO OF DIMENSIONS OF THE ARRAY IS
! DEDUCED FROM THE FIRST CALL AND STORED IN STREAM3 OF THE PARAMETER
! LIST. ON ANY SUBSEQUENT CALL ONLY ARRAYS OF THE SAME DIMENSION CAN
! BE PASSED
!
               P = P+5
               reduce tag(NO)
               DVD = SNDISP
               %if DVD#0 %then outsym('&'); CNAME(12)
               P = P+1
               ->BAD PARM %unless 1<=ARR<=2 %and II=TYPE %and III=PREC
               QQQ = ASLIST(TCELL)_UIOJ&15;  ! DIMENSION OF ACTUAL(IF KNOWN)
               JJ = LCELL_UIOJ&15;       ! DIMENSION OF FORMAL
               %if JJ=0 %then JJ = QQQ %and LCELL_UIOJ = LCELL_UIOJ!JJ
               %if QQQ=0 %then QQQ = JJ %and %c
                  ASLIST(TCELL)_UIOJ = ASLIST(TCELL)_UIOJ!JJ
               ->BAD PARM %unless JJ=QQQ
               %if DVD#0 %start    { have info to adjust basepoint }
                  DVDP=DVD+3*jj
                  %cycle KK = jj,-1,1
                     LB=Ctable(DVDP)
                     outsym('[')
                     %if LB=x'80000000' %start
                        outstring("-(")
                        p=Ctable(DVDP+1); csexp(x'51'); outsym(')')
                     %finish %else %if lb>0 %start
                        outsym('-'); outint(LB)
                     %finish %else %if LB<=0 %start
                        {outsym('+');} outint(-LB)
                     %finish
                     outstring("] ")
                     DVDP=DVDP-3
                  %repeat
               %finish
               FPTR = FPTR+AHEADSIZE
               ->NEXT PARM
ENTRY SEQ:                               ! CODE FOR RT ENTRY
               outsym(')')
               %while TWSP>0 %cycle
                  POP(TWSP,QQQ,JJ,III);  ! ONLY IF STR VALS & EMAS
                  RETURN WSP(QQQ,268)
               %repeat
               %if STRRESINWA=YES %and NAMP<=1 %and (TYPEP=3 %or %c
                  TYPEP=5) %start
                  GET WSP(QQQ,268);      ! AUTOMATIC RETURN
                  OPND2_PTYPE <- PT
                  OPND2_FLAG = LOCALIR
                  OPND2_D = RBASE<<16!QQQ
                  OPND2_XTRA = 268
                  Opnd_ptype<-pt; opnd_flag=dname
                  opnd_d=rtname; opnd_xtra=(pspeced+1)<<24
                  FPTR = FPTR+PTRSIZE(X'35')
               %finish
               II = UNAMETRIP(RCALL,PT&255,0,RTNAME)
               TRIPLES(II)_OPND1_XTRA = FPTR;  ! PASS PARAM SIZE TOTAL
               CURRINF_NMDECS = CURRINF_NMDECS!2
               ROUT = 1; TYPE = TYPEP; NAM = NAMP
               PREC = PRECP; PTYPE = PT
!
! RECOVER THE RESULT OF FNS & MAPS. OFTEN NOCODE WILL BE NEEDED
!
               %if PT&255#0 %start
                  %if NAM>=2 %then II = RCRMR %else II = RCRFR
                  II = UNAMETRIP(II,PT&255,0,RTNAME)
                  %if STRRESINWA=YES %then TRIPLES(II)_OPND1_XTRA = QQQ
                                         ! WORK AREA OFFSET
                  NAMEOPND_PTYPE = PT&255; NAMEOPND_FLAG = REFTRIP
                  NAMEOPND_D = II
                  NAMEOPND_XTRA = 0
               %finish
OVER:          P = OUTP
            %end;                        ! OF INNER BLOCK
         %end
%integer %fn TSEXP(%integer %name VALUE)
%switch SW(1:3)
%integer PP,KK,SIGN,CT
      TYPE = 1; PP = P
      P = P+3
      SIGN = A(P)
      ->TYPED %unless SIGN=4 %or A(P+1)=2
      ->SW(A(P+1))
SW(1):                                   ! NAME
      P = P+2; REDUCE TAG(NO)
      %if ptype&x'ff0f'=x'4001' %start   { any const int }
         %if a(p+2)=2 %and a(p+3)=2 %and a(p+4)=2 %then %start
            value=midcell
            p=p+5
            %if sign#2 %then %result = 2
            value=-value; %result=-2
         %finish
      %finish
      ->TYPED
SW(2):                                   ! CONSTANT
      CT = A(P+2); TYPE = CT&7
      ->TYPED %unless CT=X'41' %and SIGN#3
      KK = FROMAR2(P+3)
      ->TYPED %unless a(p+5)=2
      VALUE = KK
      P = P+6
      %if SIGN#2 %then %result = 1
      VALUE = -VALUE; %result = -1
SW(3):                                   ! SUB EXPRN
TYPED:P = PP; %result = 0
%end
!*
%integerfn tsc
%integer value,res,PP
%switch sw(1:4)
!printstring("tsc  with p="); write(p,5); newline
      PP=p
      ->sw(a(p))
sw(1):
         p=p+1
         res=tsexp(value)
         %if res=0 %then %result=0
         p=p+1
!printstring("tcond part2 with p="); write(p,5); newline
         res=tsexp(value)
         %if res=0 %then %result=0
         p=p+1
         %if a(p-1)=1 %then %result=0
         %RESULT=1
SW(2):
         p=p+1; res=tcond
!printstring("returns from tcond with res & p "); write(res,1); write(p,5); newline
         %result=res
SW(3):
         P=P+1
         %result=tsc
sw(4):                   ! boolean
      %result=tsexp(value)
%end
%integerfn tcond
!***********************************************************************
!*     Check for a simple compile time condition. PP to First exp      *
!***********************************************************************
%integer value,res,PP
!printstring("tcond with p="); write(p,5); newline
      PP=p
      res=tsc
      %if res=0 %then %result=0
      %if a(p)=3 %then p=p+1 %and %result=1
      %until a(p)=2 %cycle
         p=p+1; res=tsc
         %if res=0 %then %result=0
      %repeat
      p=p+1
      %result=1
%end
         %routine SKIP EXP
!***********************************************************************
!*       SKIPS OVER THE EXPRESSION POINTED AT BY P. USED FOR ERROR     *
!*       RECOVERY AND TO EXTRACT INFORMATION ABOUT THE EXPRESSION.     *
!***********************************************************************
%integer OPTYPE,PIN,J,precp
            PIN = P
            P = P+3;                     ! TO P<+'>
            %cycle;                      ! DOWN THE LIST OF OPERATORS
               OPTYPE = A(P+1);          ! ALT OF P<OPERAND>
               P = P+2
               %if OPTYPE=0 %or OPTYPE>3 %then IMPABORT
               %if OPTYPE=3 %then SKIP EXP;  ! SUB EXPRESSIONS
!
               %if OPTYPE=2 %then %start;  ! OPERAND IS A CONSTANT
                  J = A(P)&7;            ! CONSTANT TYPE
                  %if J=5 %then P = P+A(P+1)+2 %else %start
                     precp=A(P)>>4
                     %if precp=3 %then precp=4
                     P = P+1+BYTES(precp)
                  %finish
               %finish
!
               %if OPTYPE=1 %then %start;  ! NAME
                  P = P-1
                  P = P+3 %and SKIP APP %until A(P)=2;  ! TILL NO ENAME
                  P = P+1
               %finish
!
               P = P+1
               %if A(P-1)=2 %then %exit;  ! NO MORE REST OF EXP
            %repeat
         %end;                           ! OF ROUTINE SKIP EXP
         %routine SKIP APP
!***********************************************************************
!*       SKIPS ACTUAL PARAMETER PART                                   *
!*       P IS ON ALT OF P<APP> AT ENTRY                                *
!***********************************************************************
            %integer PIN
            PIN = P
            P = P+1 %and SKIP EXP %while A(P)=1
            P = P+1
         %end
%routine NO APP
!***********************************************************************
!*  Deals with unexpected parameters                                   *
!***********************************************************************
      P = P+2
      %if A(P)=1 %then %start;     ! <APP> PRESENT
         FAULT(17,0,FROM AR2(P-2))
         outsym('[')
         %while a(p)=1 %cycle
           p=p+1
           csexp(x'51')
           %if a(p)=1 %then outsym(',')
         %repeat
        p=p+1; outsym(']')
      %finish %else P = P+1;       ! P NOW POINTS TO ENAME
%end
         %routine TEST APP(%integer %name NUM)
!***********************************************************************
!*       THIS ROUTINE COUNTS THE NUMBER OF ACTUAL PARAMETERS           *
!*       WHICH IT RETURNS IN NUM.                                      *
!***********************************************************************
            %integer PP,Q
            Q = 0; PP = P; P = P+2;      ! P ON NAME AT ENTRY
            %while A(P)=1 %cycle;        ! NO (MORE) PARAMETERS
               P = P+1; Q = Q+1
               SKIP EXP
            %repeat
            P = PP; NUM = Q
         %end
         %routine SET LINE
!***********************************************************************
!*       UPDATE THE STATEMENT NO                                       *
!***********************************************************************
%integer I,offset
            %return %if RLEVEL=0;        ! AMONG CONDITIONAL GLOBAL DECS
            offset=CURRINF_DIAGINF+2
            %if target=ORN %or 1<<target&riskmc#0 %Then Offset=Offset+2
            I = UCONSTTRIP(SLINE,X'41',0,LINE<<16!Offset)
            %if PARM_PROF#0 %then %start
               I = PROFAAD+4+4*LINE
            %finish
         %end
%routine STORE TAG(%integer KK,LEVEL,RBASE,J,SNDISP,ACC,SLINK,KFORM)
            %integer Q,I,TCELL
            %record (TAGF) %name LCELL
            TCELL = TAGS(KK)
!
! above line to stop local and routine having the same name
!
            Q = LEVEL<<8!RBASE<<4!J
            IMPABORT %unless (KFORM!ACC)>>16=0
            LCELL == ASLIST(TCELL)
            %if LCELL_UIOJ>>8&63=LEVEL %or kk=currinf_m-1 %then %start
!               FAULT(7,0,KK)
               LCELL_UIOJ <- LCELL_UIOJ&X'C000'!Q;  ! COPY USED BITS ACCROSS
            %finish %else %start
               I = ASL; %if I=0 %then I = MORE SPACE
               LCELL == ASLIST(I)
               ASL = LCELL_LINK
               LCELL_LINK = TCELL!CURRINF_NAMES<<18
               LCELL_UIOJ = Q
               TAGS(KK) = I
               CURRINF_NAMES = KK
            %finish
            LCELL_PTYPE <- PTYPE
            LCELL_ACC <- ACC
            LCELL_SNDISP <- SNDISP
            LCELL_KFORM = KFORM
            LCELL_SLINK <- SLINK
         %end
         %routine COPY TAG(%integer TNAME,DECLARE)
!***********************************************************************
!*    A TAG IS A LIST CELL POINTED AT BY TAGS(NAME)                    *
!*    S1 HAS PTYPE<<16!USEBITS(2)!TEXT LEVEL(OLDI6)!RTLEVE(4)!DIMEN    *
!*    S2 HAS SECONDARY DISP(SIGNED)<<16! ACC OR ITEM SIZE IN BYTES     *
!*    S3 HAS PRIMARY DISP(K)<<16!KFORM WHICH IS POINTER TO FORMAT      *
!*                SIDE CHAIN FOR ITEMS OF TYPE RECORD                  *
!*    LINK HAS PTR TO TAG OF NAME HIDDEN WHEN THIS ONE DECLARED        *
!***********************************************************************
            %record (TAGF) %name LCELL
            TCELL = TAGS(TNAME)
            %if TCELL=0 %then %start;    ! NAME NOT SET
               TYPE = 7; PTYPE = X'57'; PREC = 5
               %if DECLARE=YES %start
                  FAULT(16,0,TNAME)
                  STORE TAG(TNAME,LEVEL,RBASE,0,0,4,N,0)
                  N = N+4
                  COPY TAG(TNAME,NO);    ! TO SET USE BITS
                  %return
               %finish
               ROUT = 0; NAM = 0; ARR = 0; LITL = 0; ACC = 4
               I = -1; J = -1; K = -1; OLDI = -1; kform = -1
            %finish %else %start
               LCELL == ASLIST(TCELL)
               PTYPE = LCELL_PTYPE&X'FFFF'
               USEBITS = LCELL_UIOJ>>14&3
               OLDI = LCELL_UIOJ>>8&63
               I = LCELL_UIOJ>>4&15
               J = LCELL_UIOJ&15
               LCELL_UIOJ <- LCELL_UIOJ!X'8000'
               MIDCELL = LCELL_S2
               SNDISP = LCELL_SNDISP&X'FFFF';  ! Sign extension on some hosts
               ACC = LCELL_ACC&X'FFFF'
               K = LCELL_SLINK&X'FFFF';  ! Sign extension on some hosts
               KFORM = LCELL_KFORM
               LITL = PTYPE>>14&3;       ! SIGNEXTENSION ON 16 BIT MACHINES
               ROUT = PTYPE>>12&3
               NAM = PTYPE>>10&3
               ARR = PTYPE>>8&3
               PREC = PTYPE>>4&15
               TYPE = PTYPE&15
            %finish
         %end
         %routine REDUCE TAG(%integer DECLARE)
!***********************************************************************
!*       AS COPY TAG FOR NAME AT A(P) EXCEPT:-                         *
!*       1) SPECIAL NAMES HAVE THEIR CORRECT PREC & TYPE SUBSTITUTED   *
!*       2) RECORD ELEMENTS HAVE THE SUBNAME PARTICULARS RETURNED      *
!***********************************************************************
            %integer SUBS,QQ,PP
            COPY TAG(FROMAR2(P),DECLARE)
            %if PTYPE=SNPT %then %start
               PTYPE = ACC; UNPACK
               %if k=42 {string} %then acc = 256 %else %if %c
                  k=48 {record} %then acc = x'7fff' %else ACC = BYTES(PREC)
            %finish;                     ! TO AVOID CHECKING PARAMS
            %if TYPE=3 %then %start
               PP = P; QQ = COPY RECORD TAG(SUBS); P = PP
            %finish
         %end
! LAYOUT OF PTYPE
! ****** ** *****
! PTYPE REQUIRES 16 BITS TO DEFINE A VARIABLE AND CAN BE REGARDED AS
! AS TWO BYTEINTEGERS:=
! UPPER ONE(UPTYPE):= LITL<<6!ROUT<<4!NAM<<2!ARR
! LOWER ONE(PTYPE) :=PREC<<4!TYPE
! OFTEN (EG IN EXPOP) ONLY THE LOWER PART IS REQUIRED AS FUNCTIONS
! ETC ARE PREFETCHED AND STACKED.
! LITL:= 1=CONST,2=EXTERNAL,3=EXTRINSIC(OR DYNAMIC), 0=NONE OF THESE
! ROUT:= 1 FOR ROUTINE OR FN OR MAP, =0 NONE OF THESE
! NAM := 2 FOR MAPS AND 'REFREFS',=1 FOR NAMES ,=0 DIRECTLY ADDRESSED
! ARR :=1 FOR ARRAYS =0 SCALARS
! PREC IS DESCRIPTOR SIZE CODE FOR EACH PRECISION:-
!     :=0 BITS,=3 BYTES, =5 WORDS, =6 D-WRDS, =7,QUAD WRDS
! TYPE:= THE VARIABLE TYPE
!     :=0 (TYPE GENERAL),=1 INTEGER, =2 REAL, =3 RECORD
!     :=4 (RECORDFORMAT),=5 STRING,  =6 LABEL/SWITCH. =7 NOT SET
!
         %routine UNPACK
            LITL = PTYPE>>14
            ROUT = PTYPE>>12&3
            NAM = PTYPE>>10&3
            ARR = PTYPE>>8&3
            PREC = PTYPE>>4&15
            TYPE = PTYPE&15
         %end
         %routine PACK(%integer %name PTYPE)
            PTYPE = (((((LITL&3)<<2!ROUT&3)<<2!NAM&3)<<2!ARR&3)<<4!PREC&15) %c
               <<4!TYPE&15
         %end
      %end;                              ! OF ROUTINE CSS

      %integer %fn NEWTRIP
!***********************************************************************
!*    SETS UP A NEW TRIPLE AND LINKS IT IN
!***********************************************************************
         %record (TRIPF) %name CURRT
         %integer I
         CURRT == TRIPLES(NEXT TRIP)
         I = NEXT TRIP
         %if I>=WORKA_LAST TRIP %then i=1{FAULT(102,WORKA_WKFILEK,0)}
         NEXT TRIP = i +1
         CURRT = 0
         CURRT_BLINK = TRIPLES(0)_BLINK
         TRIPLES(0)_BLINK = I
         TRIPLES(CURRT_BLINK)_FLINK = I
         %result = I
      %end
      %integer %fn UCONSTTRIP(%integer OPERN,OPTYPE,FLAGS,CONST)
!***********************************************************************
!*    SETS UP A UNARY TRIPLE WITH CONSTANT OPERAND                     *
!***********************************************************************
         %record (TRIPF) %name CURRT
         %integer CELL
         CELL = NEW TRIP
         CURRT == TRIPLES(CELL)
         CURRT_OPERN = OPERN
         CURRT_OPTYPE <- OPTYPE
         CURRT_FLAGS <- FLAGS
         CURRT_OPND1_PTYPE = X'51'
         CURRT_OPND1_D = CONST
         %result = CELL
      %end
      %integer %fn ULCONSTTRIP(%integer OPERN,OPTYPE,FLAGS,CONST1,CONST2)
!***********************************************************************
!*    SETS UP A UNARY TRIPLE WITH CONSTANT OPERAND                     *
!***********************************************************************
         %record (TRIPF) %name CURRT
         %integer CELL
         CELL = NEW TRIP
         CURRT == TRIPLES(CELL)
         CURRT_OPERN = OPERN
         CURRT_OPTYPE <- OPTYPE
         CURRT_FLAGS <- FLAGS
         CURRT_OPND1_PTYPE = X'61'
         CURRT_OPND1_D = CONST1
         CURRT_OPND1_XTRA = CONST2
         %result = CELL
      %end
      %integer %fn UNAMETRIP(%integer OPERN,OPTYPE,FLAGS,NAME)
!***********************************************************************
!*    SETS UP A UNARY TRIPLE WITH ONE NAME OPERAND                     *
!***********************************************************************
         %record (TAGF) %name TAGINF
         %record (TRIPF) %name CURRT
         %integer CELL
         TAGINF == ASLIST(TAGS(NAME))
         CELL = NEW TRIP
         CURRT == TRIPLES(CELL)
         CURRT_OPERN = OPERN
         CURRT_OPTYPE <- OPTYPE
         CURRT_FLAGS <- FLAGS
         CURRT_OPND1_PTYPE = TAGINF_PTYPE
         CURRT_OPND1_FLAG = DNAME
         CURRT_OPND1_D = NAME
         CURRT_OPND1_XTRA = 0
         %result = CELL
      %end
      %integer %fn UTEMPTRIP(%integer OPERN,OPTYPE,FLAGS,TEMP)
!***********************************************************************
!*    SETS UP A UNARY TRIPLE WITH LOCAL TEMPORARY OPND                 *
!***********************************************************************
         %integer CELL
         %record (TRIPF) %name CURRT
         CELL = NEWTRIP
         CURRT == TRIPLES(CELL)
         CURRT_OPERN = OPERN
         CURRT_OPTYPE <- OPTYPE
         CURRT_FLAGS <- FLAGS
         CURRT_OPND1_PTYPE = OPTYPE; CURRT_OPND1_FLAG = LOCALIR
         CURRT_OPND1_D = TEMP
         %result = CELL
      %end
      %routine KEEPUSECOUNT(%record (RD) %name OPND)
!***********************************************************************
!*    KEEPS PUSE AND CNT UP TO DATE                                    *
!***********************************************************************
         %record (TRIPF) %name REFT
         REFT == TRIPLES(OPND_D)
         %if REFT_CNT=0 %then %start
!            printstring("setting puse ")
!            write(opnd_d,4); write(triples(0)_blink,4); write(reft_puse,3)
!             newline
           REFT_PUSE = TRIPLES(0)_BLINK
         %finish
         REFT_CNT = REFT_CNT+1
      %end
      %integer %fn URECTRIP(%integer OPERN,OPTYPE,FLAGS,
         %record (RD) %name OPND1)
!***********************************************************************
!*    SETS UP A BINARY TRIPLE WITH  COMPLETE OPERANDS PROVIDED         *
!***********************************************************************
         %integer CELL
         %record (TRIPF) %name CURRT
         CELL = NEWTRIP
         CURRT == TRIPLES(CELL)
         CURRT_OPERN = OPERN
         CURRT_OPTYPE <- OPTYPE
         CURRT_FLAGS <- FLAGS
         CURRT_OPND1 = OPND1
         %if 1<<OPND1_FLAG&BTREFMASK#0 %then KEEPUSECOUNT(OPND1)
         %result = CELL
      %end
      %integer %fn BRECTRIP(%integer OPERN,OPTYPE,FLAGS,
         %record (RD) %name OPND1,OPND2)
!***********************************************************************
!*    SETS UP A BINARY TRIPLE WITH  COMPLETE OPERANDS PROVIDED         *
!***********************************************************************
         %integer CELL
         %record (TRIPF) %name CURRT
         CELL = NEWTRIP
         CURRT == TRIPLES(CELL)
         CURRT_OPERN = OPERN
         CURRT_OPTYPE <- OPTYPE
         CURRT_FLAGS <- FLAGS
         CURRT_OPND1 = OPND1
         CURRT_OPND2 = OPND2
         %if 1<<OPND1_FLAG&BTREFMASK#0 %then KEEP USE COUNT(OPND1)
         %if 1<<OPND2_FLAG&BTREFMASK#0 %then KEEP USE COUNT(OPND2)
         %result = CELL
      %end
      %routine GET WSP(%integer %name PLACE, %integer SIZE)
!***********************************************************************
!*       FIND OR CREATE A TEMPORARY VARIABLE OF 'SIZE' WORDS           *
!***********************************************************************
         %integer J,K,L,F
         F = SIZE>>31;                   ! TOP BIT SET FOR MANUAL RETURN
                                         ! OTHERWISE NOTE IN TWSP LIST
                                         ! FOR AUTOMATIC RETURN
         SIZE = SIZE<<1>>1
         %if SIZE>4 %then SIZE = 0
         POP(CURRINF_AVL WSP(SIZE),J,K,L)
         %if K<=0 %then %start;          ! MUST CREATE TEMPORARY
            %if size=4 %then l=rnding(128+x'72') %else %if Size=2 %c
                %then l=rnding(128+x'62') %else l=3
            n=(n+L)&(\l)
            K = N
            %if SIZE=0 %then N = N+268 %else N = N+SIZE<<2
         %finish
         PLACE = K
         PUSH(TWSPHEAD,K,SIZE,0) %unless F#0
      %end
      %routine RETURN WSP(%integer PLACE,SIZE)
!***********************************************************************
!*    RETURNS WORKSPACE TO ORDERED FREE LIST. ADDRESSABLE CELLS        *
!*    ARE PUT AT THE TOP. NON-ADDRESSABLE ON THE BACK                  *
!***********************************************************************
         %integer CELL
         IMPABORT %unless PLACE<=N %and PLACE&1=0
         %if SIZE>4 %then SIZE = 0
         CELL = CURRINF_AVL WSP(SIZE)
         %while CELL>0 %cycle
            IMPABORT %if ASLIST(CELL)_S2=PLACE
            CELL = ASLIST(CELL)_LINK
         %repeat
         %if PLACE<511 %then PUSH(CURRINF_AVL WSP(SIZE),0,PLACE,0) %else %c
            INSERT AT END(CURRINF_AVL WSP(SIZE),0,PLACE,0)
      %end
      %routine REUSE TEMPS
         %integer JJ,KK,QQ
         %while TWSPHEAD#0 %cycle
            POP(TWSPHEAD,JJ,KK,QQ)
            RETURN WSP(JJ,KK)
         %repeat
      %end
      %integer %fn FROMAR2(%integer PTR)
         %result = A(PTR)<<8!A(PTR+1)
      %end
      %integer %fn FROMAR4(%integer PTR)
         %integer I
         MOVE BYTES(4,ADDR(A(0)),PTR,ADDR(I),0)
         %result = I
      %end
P2END:                                   ! EXITS AFTER COMPILATION
   %end;                                 ! OF SUBBLOCK CONTAINING PASS2
%end
%end %of %file

pass3.i/        798464829   12014 11130 100666  51204     `
%include "hostcodes.inc"

%CONSTINTEGER HOST=M88K
%CONSTINTEGER TARGET=RS6
!
! Warning this module has the revised triples spec.
!
! In first attempt at Triple Imp considerable use was made of constant operands
! to pass information from Pass2 to GEN. Although for specialised operations like
! passing Labels this still applies, this adhocery has caused problems with arrays
! and pointers particularly in mapped records. The operands for four triples
! have thus been redefined in a more standard way.
!
! GETPTR    X1 is now (ptype of passed)<<16! DIMENSION
!           Opnd2 is either a 32 bit const with the size (ACC) as value or
!           the ptr or arrayhead as normal operand.
!
! VMY       X1 is now dim<<28!maxdim<<24!array name(where known)
!           Opnd2 is either a 32 bit const with DV offset into const area or
!           the arrayhead as a standard operand
!
! AINDX     X1 is ELSIZE<<20 !spare
!           Opnd2 is arrayhead as standard operand
!           NOTE:- The Operands have been swopped for consistency with norm.
!
! BADJ      X1 is arrayptype<<16!no of Dimensions (latter in case of backward dvs)
!           Opnd2 exactly as for VMY
!

!
! RECORDFORMAT FOR ALL THE OPTION AND FLAG VARAIBLES
!
! amended to remove non-alined longreal prior to bootstrapping to gould
!
%RECORDFORMAT PARMF(%INTEGER BITS1,BITS2,TTOPUT,
      %BYTEINTEGER LET,DYNAMIC,LINE,TRACE,ARR,DBUG,CHK,DIAG,OPT,FREE,
      LIST,CPRMODE,COMPILER,Z,Y,PROF,INHCODE,DCOMP,FAULTY,X,STACK,MAP,QUOTES,S2,
      %INTEGER LPOPUT,SP0)
%RECORDFORMAT LEVELF(%INTEGER RBASE, DIAGINF, RAL, FLAG, L, M, NMDECS, ONWORD, ONINF,
         LABEL, JROUND, UNATT FORMATS, PSIZE, ENTRYAD, DISPLAY, AUXSBASE, 
         NAMES, SNMAX,SN,RESSIZE,CLEVEL,SET, MAXPP, EXITLAB, CONTLAB, S3,
       %INTEGERARRAY AVL WSP(0:4))

%IF 1<<host&unsignedshorts=0 %START
%RECORDFORMAT RD((%INTEGER S1 %OR %SHORT PTYPE,%BYTE XB,FLAG),
      ((%INTEGER D %OR %REAL R),
      %INTEGER XTRA %OR %SHORT H0,H1,H2,H3 %OR %BYTE B0,B1,B2,B3,B4,B5,B6,B7))
%RECORDFORMAT TAGF((%SHORTINTEGER PTYPE,UIOJ,SNDISP,ACC,SLINK,KFORM %OR %C
      %INTEGER S1,S2,S3),%INTEGER LINK)
%RECORDFORMAT TRIPF(%BYTE OPERN,OPTYPE,CNT,DPTH,
      %SHORTINTEGER FLAGS,PUSE,FLINK,BLINK,%INTEGER X1,
      %RECORD(RD) OPND1,OPND2)
%RECORDFORMAT LISTF((%SHORTINTEGER PTYPE,(%SHORT UIOJ %OR %BYTE XB,FLAG),
      %SHORT SNDISP,ACC,SLINK,KFORM %OR  %INTEGER S1,S2,S3),%INTEGER LINK)
%FINISH %ELSE %START
%RECORDFORMAT RD((%INTEGER S1 %OR %HALF PTYPE,%BYTE XB,FLAG),
      ((%INTEGER D %OR %REAL R),
      %INTEGER XTRA %OR %HALF H0,H1,H2,H3 %OR %BYTE B0,B1,B2,B3,B4,B5,B6,B7))
%RECORDFORMAT TAGF((%HALFINTEGER PTYPE,UIOJ,SNDISP,ACC,SLINK,KFORM %OR %C
      %INTEGER S1,S2,S3),%INTEGER LINK)
%RECORDFORMAT TRIPF(%BYTE OPERN,OPTYPE,CNT,DPTH,
      %HALFINTEGER FLAGS,PUSE,FLINK,BLINK,%INTEGER X1,
      %RECORD(RD) OPND1,OPND2)
%RECORDFORMAT LISTF((%HALFINTEGER PTYPE,(%HALF UIOJ %OR %BYTE XB,FLAG),
      %HALF SNDISP,ACC,SLINK,KFORM %OR  %INTEGER S1,S2,S3),%INTEGER LINK)
%FINISH
%RECORDFORMAT WORKAF(%INTEGER NNAMES,CCSIZE,DSIZE,ASL MAX,ASL CUR BTM,CONST PTR,
      CONST BTM,LASTTRIP,WKFILEAD,WKFILEK,FILE ADDR,RELEASE,AASL0,CONST LIMIT,
      RTCOUNT,ARTOP,AMAINEP,DICTBASE,OPTCNT,INCLHEAD,S2,S3,S4,
      %INTEGERNAME LINE,N,S5,%STRING(9)LADATE,
      %BYTEINTEGERARRAYNAME CC,A,LETT,
      %INTEGERARRAYNAME WORD,TAGS,CTABLE,
      %RECORD(LEVELF)%ARRAYNAME LEVELINF,
      %INTEGERARRAY PLABS,PLINK(0:31),
      %RECORD(LISTF)%ARRAYNAME ASLIST)
!
! TRIPF_FLAGS SIGNIFY AS FOLLOWS
%CONSTINTEGER LEAVE STACKED=2****0;     ! SET LEAVE RESULT IN ESTACK
%CONSTINTEGER LOADOP1=2****1;           ! OPERAND 1 NEEDS LOADING
%CONSTINTEGER LOADOP2=2****2;           ! OPERAND 2 NEEDS LOADING
%CONSTINTEGER NOTINREG=2****3;          ! PREVENT REG OPTIMISNG
                                        ! OF TEMPS OVER LOOPS&JUMPS
%CONSTINTEGER USE ESTACK=2****4;        ! KEEP DUPLICATE IN ESTACK
%CONSTINTEGER USE MSTACK=2****5;        ! PUT DUPLICAT ON MSTACK
%CONSTINTEGER CONSTANTOP=2****6;        ! ONE OPERAND IS CONSTANT(FOR FOLDING)
%CONSTINTEGER COMMUTABLE=2****7;        ! OPERATION IS COMMUTABLE
%CONSTINTEGER BSTRUCT=2****12;          ! Proc contains inner blks or RTs
%CONSTINTEGER USED LATE=2****13;        ! I-RESULT USED AFTER LAB OR A LONG WAY AHEAD
%CONSTINTEGER ASS LEVEL=2****14;        ! ASSEMBLER LEVEL OPERATION
%CONSTINTEGER DONT OPT=2****15;         ! DONT DUPLICATE THIS RESULT
                                        ! USED FOR BYTE PTR & OTHER SODS!
!
%RECORDFORMAT EMASFHDRF(%INTEGER ENDRA,STARTRA,FBYTESIZE,W3,W4,W5,W6,W7)
                                        ! FORMAT FOR ARRAY HEADS
! %END %OF  %FILE "ERCC07.TRIMP_TFORM1S"
!
! FIRST THE OPERAND FLAG CONSTANTS
!
%CONSTINTEGER SCONST=0;                 ! CONST UPTO 64 BITS value is carried
                                        ! in opnd_d and opnd_xtra
%CONSTINTEGER LCONST=1;                 ! CONST LONGER THAN SCONST const can be
                                        ! found elsewhere(at top of ar) by
                                        ! meanse of base&offset inf in_d and _xtra
%CONSTINTEGER DNAME=2;                  ! NAME BY DICTIONARY NO the base and disp in
                                        ! the dictionary after adjusting by
                                        ! possible offset for item in
                                        ! in records lead to the variable
%CONSTINTEGER ARNAME=3;                 ! NAME BY AR POINTER opnd_d the ar pointer
                                        ! this form local to pass2
                                        ! and used to identify functions
                                        ! with params before the call
                                        ! is planted
%CONSTINTEGER VIAPTR=4;                 ! VIA TRIPLE WITHOFFSET TO POINTER
                                        ! At an offset(_xtra) from address in
                                        ! referenced triple can be found a
                                        ! pointer to the required operand
%CONSTINTEGER INDNAME=5;                ! INDIRECT VIA DICTIONARY base&disp
                                        ! in dictionary identify a pointer
                                        ! variable at possible offset from
                                        ! this pointer
%CONSTINTEGER INDIRECT=6;               ! INDIRECT VIA TRIPLE WITH OFFSET
                                        ! the refenced triple has computed
                                        ! the (32bit) address of an item
                                        ! an offset may have to be applied
                                        ! before the fetch or store
%CONSTINTEGER LOCALIR=7;                ! BASE DISP REF IN CURRENT STACK FRAME
                                        ! opnd_b=base<<16!offset used only for
                                        ! compiler generated temporaries
%CONSTINTEGER REFTRIP=8;                ! REFERENCE TO A TRIPLE the operand is the result of 
                                        ! triple opnd_d
%CONSTINTEGER INAREG=9;                 ! REGISTER OPERAND this form is local to the
                                        ! code generating pass(es)
%CONSTINTEGER developped=10;            ! also local to generator
%CONSTINTEGER DEVADDR=11;               ! ALSO LOCAL TO GENERATOR
%CONSTINTEGER BTREFMASK=1<<REFTRIP!1<<INDIRECT!1<<VIAPTR
%CONSTINTEGER REFER NEEDED=1<<INDIRECT!1<<VIAPTR
!
! NOW THE DEFINITIONS OF ONE OPERAND TRIPLES <128
!
%CONSTINTEGER RTHD=1;                   ! ROUTINE-BLOCK HEADING
%CONSTINTEGER RDSPY=2;                  ! ROUTINE ENTRY SET DISPLAY
%CONSTINTEGER RDAREA=3;                 ! ROUTINE LEAVE DIAGNOSTIC SPACE
%CONSTINTEGER RDPTR=4;                  ! SET DIAGNOSTIC POINTER
%CONSTINTEGER RTBAD=5;                  ! ROUTINE-FN BAD EXIT
%CONSTINTEGER RTXIT=6;                  ! "%RETURN"
%CONSTINTEGER XSTOP=7;                  ! EXECUTE "%STO"
%CONSTINTEGER NOTL=10;                  ! LOGICAL NOT
%CONSTINTEGER LNEG=11;                  ! LOGICAL NEGATE
%CONSTINTEGER IFLOAT=12;                ! CONVERT INTEGER TO REAL
%CONSTINTEGER MODULUS=13;               ! AS USED BY IMOD&RMOD
%CONSTINTEGER SHRTN=14;                 ! SHORTEN TO LOWER PRECISION
%CONSTINTEGER LNGTHN=15;                ! LENGTHEN TO HIGHER PRECISION
%CONSTINTEGER JAMSHRTN=16;              ! SHORTEN FOR JAM TRANSFER
%CONSTINTEGER NULLT=18;                 ! FOR REDUNDANT TRIPLES
%CONSTINTEGER PRELOAD=19;               ! PREFETCH FOR OPTIMISATION REASONS
%CONSTINTEGER SSPTR=21;                 ! STORE STACK POINTER
%CONSTINTEGER RSPTR=22;                 ! RESTORE STACK POINTER
%CONSTINTEGER ASPTR=23;                 ! ADVANCE STACK PTR
%CONSTINTEGER DARRAY=24;                ! DECLARE ARRAY(IE STORE HD)
%CONSTINTEGER SLINE=25;                 ! UPDATE LINE NO
%CONSTINTEGER STPCK=26;                 ! CHECK FOR ZERO STEPS
%CONSTINTEGER FORPRE=27;                ! PREAMBLE FOR "FOR"
%CONSTINTEGER FORPOST=28;               ! POSTAMBLE FOR "FOR"
%CONSTINTEGER FORPR2=29;                ! FOR SECOND PREAMBLE
%CONSTINTEGER PRECL=30;                 ! PREPARATION FOR CALL
%CONSTINTEGER RCALL=31;                 ! THE CALL
%CONSTINTEGER RCRFR=32;                 ! RECOVER FN RESULT
%CONSTINTEGER RCRMR=33;                 ! RECOVER MAP RESULT
%CONSTINTEGER GETAD=35;                 ! GET ADDRESS OF NAME
%CONSTINTEGER RTOI1=36;                 ! REAL TO INTEGER AS INT
%CONSTINTEGER RTOI2=37;                 ! REAL TO INTEGER INTPT
%CONSTINTEGER ITOS1=38;                 ! INTEGER TO STRING AS TOSTRING
%CONSTINTEGER MNITR=39;                 ! %MONITOR
%CONSTINTEGER PPROF=40;                 ! PRINT PROFILE
%CONSTINTEGER RTFP=41;                  ! TURN RT INTO FORMAL PARAMETER
%CONSTINTEGER ONEV1=42;                 ! ON EVENT 1 PRIOR TO TRAP
%CONSTINTEGER ONEV2=43;                 ! ON EVENT 2 AFTER TRAP
%CONSTINTEGER DVSTT=44;                 ! START OF DOPE VECTOR
%CONSTINTEGER DVEND=45;                 ! END OF DV EVALUATE TOTSIZE ETC
%CONSTINTEGER FOREND=46;                ! END OF FOR LOOP
%CONSTINTEGER DMASS=47;                 ! assign via bim warning to opt only
%CONSTINTEGER RTOI3=48;                 ! real to integer as TRUNC
!
! CODES FOR USER WRITTEN ASSEMBLER. NATURALLY THESE ARE NOT
! MACHINE INDEPENDENT
!
%CONSTINTEGER UCNOP=50;                 ! FOR CNOPS
%CONSTINTEGER UCB1=51;                  ! ONE BYTE OPERATIONS
%CONSTINTEGER UCB2=52;                  ! FOR 2 BYTE OPERATIONE
%CONSTINTEGER UCB3=53;                  ! FOR 3 BYTE OPERATIONS
%CONSTINTEGER UCW=54;                   ! FOR WORD OPERATIONS
%CONSTINTEGER UCBW=55;                  ! FOR OPC,BYTEWORD OPERATIONE
%CONSTINTEGER UCWW=56;                  ! FOR OPC,WORD,WORD OPERAIONS
%CONSTINTEGER UCLW=57;                  ! FOR LONGWORD OPERATIONS
%CONSTINTEGER UCB2W=58;                 ! FOR OPC,B1,B2,WORD OPERATIONS
%CONSTINTEGER UCNAM=59;                 ! FOR ACESS TO NAMES FROM ASSEMBLER
!
! NOW THE BINARY OPERATIONS
!
%CONSTINTEGER ADD=128;                  ! ADDITION
%CONSTINTEGER SUB=129;                  ! SUBTRACTION
%CONSTINTEGER NONEQ=130;                ! INTEGER NONEQUIVALENCE
%CONSTINTEGER ORL=131;                  ! LOGICAL OR
%CONSTINTEGER MULT=132;                 ! MULTIPLICATION
%CONSTINTEGER INTDIV=133;               ! INTEGER DIVISION
%CONSTINTEGER REALDIV=134;              ! REAL DIVISION
%CONSTINTEGER ANDL=135;                 ! LOGICAL AND
%CONSTINTEGER RSHIFT=136;               ! LOGICAL RIGHT SHIFT
%CONSTINTEGER LSHIFT=137;               ! LOGICAL LEFT SHIFT
%CONSTINTEGER REXP=138;                 ! REAL EXPONENTIATION
%CONSTINTEGER COMP=139;                 ! COMPARISONS
%CONSTINTEGER DCOMP=140;                ! FIRST PART OF DSIDED(NEEDED?)
%CONSTINTEGER VMY=141;                  ! VECTOR MULTIPLY
%CONSTINTEGER COMB=142;                 ! COMBINE (IE ADD OF LA) ON VMY RESULTS
%CONSTINTEGER VASS=143;                 ! VARAIABLE ASSIGN WITH CHECKING
%CONSTINTEGER VJASS=144;                ! VARIABLE JAMMED ASSIGN
%CONSTINTEGER IEXP=145;                 ! INTEGER EXPONENTIAITION
%CONSTINTEGER BADJ=146;                 ! BASE ADJUST ARRAY INDEX
%CONSTINTEGER AINDX=147;                ! INDEX ARRAY(COMBINE BS&IX)
%CONSTINTEGER IFETCH=148;               ! NO LONGER USED
%CONSTINTEGER LASS=149;                 ! ASSIGN LOCAL TEMPORARY
%CONSTINTEGER FORCK=150;                ! VALIDATE FOR
%CONSTINTEGER PRECC=151;                ! PRELIMINARY CONNCATENATION
%CONSTINTEGER CONCAT=152;               ! CONCATENATION
%CONSTINTEGER IOCPC=153;                ! CALL IOCP
%CONSTINTEGER PASS1=154;                ! PRIMARY PARAMETER ASSIGNMENT
%CONSTINTEGER PASS2=155;                ! PARAMETER PASSING POINTER PARAMS
%CONSTINTEGER PASS3=156;                ! PARAMETERPASSING ARRAY PARAMETERS
%CONSTINTEGER PASS4=157;                ! PASS A FORMAL PROCEDURE
%CONSTINTEGER PASS5=158;                ! PASS AN UNTYPE(%NAME) PARAMETER
%CONSTINTEGER PASS6=159;                ! PASS STRFN OR RECFN RESULT AREA
%CONSTINTEGER BJUMP=160;                ! BACKWARDS JUMPS
%CONSTINTEGER FJUMP=161;                ! FORWARD JUMPS
%CONSTINTEGER REMLB=162;                ! REMOVE LAB FROM LABELIST
                                        ! NEEDS TO BE TRIPLE IF COMBINED
                                        ! LABEL LIST IS USED
%CONSTINTEGER TLAB=163;                 ! TO ENTER A LABEL
%CONSTINTEGER DCLSW=164;                ! DECLARE A SWITCH ARRAY
%CONSTINTEGER SETSW=165;                ! SET A SWITCH TO "CA"
%CONSTINTEGER GOTOSW=166;               ! GO TO A SWITCH LABEL
%CONSTINTEGER STRASS1=167;              ! STRING GENERAL ASSIGNMET
%CONSTINTEGER STRASS2=168;              ! STRING FIXED LENGTH ASSNMENT
%CONSTINTEGER STRJT=169;                ! STRING JAM TRANSFER
%CONSTINTEGER AHASS=170;                ! ASSIGNMENT OF ARRAYHEADS
%CONSTINTEGER PTRAS=171;                ! ASSIGNMENT OF POINTERS
%CONSTINTEGER MAPRES=172;               ! ASSIGN MAPPING FN RESULT
%CONSTINTEGER FNRES=173;                ! ASSIGN FN RESULT
%CONSTINTEGER SCOMP=174;                ! STRING COMPARISON
%CONSTINTEGER SDCMP=175;                ! FIRST PART OF STRING D-SIDED
%CONSTINTEGER PRES1=176;                ! PRE RESOLUTION 1
%CONSTINTEGER PRES2=177;                ! PRE RESOLUTION 2
%CONSTINTEGER RESLN=178;                ! STRING RESOLUTION
%CONSTINTEGER RESFN=179;                ! RESOLUTION FINALE
%CONSTINTEGER SIGEV=180;                ! SIGNAL EVENT
%CONSTINTEGER RECASS=181;               ! WHOLE RECORD ASSIGNMENT
%CONSTINTEGER AAINC=182;                ! ARRAY ADDRESS ADJUST FOR
                                        ! RECORD RELATIVE TO ABSOLUTE
%CONSTINTEGER AHADJ=183;                ! MODIFY HEAD FOR MAPPING
%CONSTINTEGER CTGEN=184;                ! CREATE TYPE GENERAL PARAMETER
%CONSTINTEGER GETPTR=185;               ! POINTER FOR PASSING BY NAME
%CONSTINTEGER SINDX=186;                ! INDEX STRING IE CHARNO
                                        ! SAME AS AINDX FOR ALL TARGETS
                                        ! BUT PNX !
%CONSTINTEGER ZCOMP=187;                ! COMPARISONS WITH ZERO
                                        ! GENERATED BY OPTIMISER
%CONSTINTEGER CLSHIFT=188;              ! CONSTANT LOGICAL SHIFT
                                        ! GENERATED BY OPTIMISER
%CONSTINTEGER CASHIFT=189;              ! CONSTANT ARITHMETIC SHIFT
                                        ! GENERATED BYOPTIMISER
%CONSTINTEGER DVBPR=190;                ! GENERATE DV ENTRY FOR BOUND PAIR
%CONSTINTEGER RSTORE=191;               ! REGISTER TO STORE OPERATION
%CONSTINTEGER MULTX=192;                ! MULTIPLY AND EXTEND PRECISION
%EXTRINSIC %RECORD (WORKAF) WORKA
%EXTRINSIC %RECORD (PARMF) PARM
%EXTERNAL %ROUTINE %SPEC IMPABORT
      %IF HOST#TARGET %START
      %EXTERNAL %ROUTINE %SPEC REFORMATC(%RECORD (RD) %NAME OPND)
      %FINISH
%EXTERNAL %ROUTINE %SPEC MOVE BYTES(%INTEGER L,FB,FO,TB,TO)
%EXTERNAL %ROUTINE %SPEC FAULT(%INTEGER N,DATA,IDENT)
%EXTERNAL %ROUTINE %SPEC PRINT TRIPS(%RECORD (TRIPF) %ARRAY %NAME TRIPLES)
%CONST %BYTE %INTEGER %ARRAY BYTES(0:7)=0(3),1,2,4,8,16;
%CONST %BYTE %INTEGER %ARRAY WORDS(0:7)=0(3),1,1,1,2,4;
%EXTERNAL %ROUTINE CTOP(%INTEGER %NAME FLAG,MASK, %INTEGER XTRA, %RECORD (RD) %NAME OPND1,OPND2)
!***********************************************************************
!*    AN OPERATION HAS BEEN FOUND WHERE BOTH OPERANDS ARE              *
!*    CONSTANTS OR KNOWN AT COMPILE TIME. THIS ROUTINE INTERPRETS      *
!*    THE OPERATION                                                    *
!*    ON EXIT FLAG=0 IF INTERPRETED. REFRAINS FROM INTERPRETING        *
!*    X=1/0 FOR EXAMPLE. CODE IS PLANTED FOR THESE FUNNIES             *
!***********************************************************************
%ROUTINE %SPEC EXTRACT(%RECORD (RD) %NAME OPND)
%INTEGER %FN %SPEC DEBYTESWOP(%INTEGER VAL)
%CONST %INTEGER UTRUNCMASK=X'00000800',BTRUNCMASK=X'00000013'
%INTEGER K,TYPEP,PRECP,OP,MAXD,SVAL,SVAL1,SVAL2,C,D,JJ,KK,TRUNCMASK,LB,UB,MP
%STRING (255) STRVAL,STRVAL1,STRVAL2
%LONG %REAL LR
      %IF 1<<HOST&LINTAVAIL#0 %THEN %START
      %LONG %INTEGER VAL,VAL1,VAL2
      %FINISH %ELSE %START
      %INTEGER VAL,VAL1,VAL2
      %FINISH
      %IF 1<<HOST&LLREALAVAIL#0 %THEN %START
      %LONG %LONG %REAL RVAL,RVAL1,RVAL2
      %FINISH %ELSE %START
      %LONG %REAL RVAL,RVAL1,RVAL2
      %FINISH
%SWITCH UISW,URSW(10:48),BISW,BRSW(0:47)
      %ON %EVENT 1,2 %START
         %RETURN
      %FINISH
      TYPEP=OPND1_PTYPE&7; PRECP=OPND1_PTYPE>>4&15; OP=FLAG
      %RETURN %IF 1<<HOST&LINTAVAIL=0 %AND OPND1_PTYPE=X'61'
      %RETURN %IF 1<<HOST&LLREALAVAIL=0 %AND OPND1_PTYPE=X'72'
      %if opnd1_ptype&x'8'#0 %then %return; ! Foreign constants can not be folded
      EXTRACT(OPND1)
      VAL1=VAL; RVAL1=RVAL; STRVAL1=STRVAL
      SVAL1<-VAL1
      %IF OP<128 %START;                 ! UNARY
         %RETURN %UNLESS 10<=OP<=48
         TRUNCMASK=UTRUNCMASK
         %IF TYPEP=2 %THEN ->URSW(OP) %ELSE ->UISW(OP)
      %FINISH
      OP=OP-128
      %RETURN %IF OP>47
      %if opnd2_ptype&8#0 %then %return
      EXTRACT(OPND2)
      VAL2=VAL; RVAL2=RVAL; STRVAL2=STRVAL
      SVAL2<-VAL2
      TRUNCMASK=BTRUNCMASK
      %IF TYPEP=2 %THEN ->BRSW(OP) %ELSE ->BISW(OP)
UISW(10):                                ! \
      VAL1=\VAL1
INTEND:
      %IF 1<<HOST&LINTAVAIL#0 %AND PRECP=6 %THEN %START
         OPND1_D<-VAL1>>32
         OPND1_XTRA<-VAL1
         FLAG=0
      %FINISH %ELSE %START
         SVAL<-VAL1
         %IF SVAL=VAL1 %OR 1<<OP&TRUNCMASK=0 %THEN FLAG=0 %AND OPND1_D=SVAL
                                         ! NO ARITH OFLOW CONDITION
      %FINISH
      %IF FLAG=0 %START
         OPND1_PTYPE=PRECP<<4!1
         OPND1_FLAG=0
      %FINISH
      %RETURN
UISW(11):                                ! INTEGER NEGATE
      VAL1=-VAL1; ->INT END
UISW(13):                                ! INTEGER ABS
      VAL1=IMOD(VAL1); ->INT END
UISW(12):                                ! INTEGER FLOAT
      RVAL1=VAL1; PRECP=PRECP+1
      ->REAL END
URSW(15):                                ! STRETCH REAL
      PRECP=PRECP+1
REAL END:OPND1_FLAG=SCONST
      %IF PRECP=5 %THEN OPND1_R=RVAL1 %ELSE %IF PRECP=6 %THEN %START
         LR=RVAL1;                       ! may be rounding
         MOVE BYTES(8,ADDR(LR),0,ADDR(OPND1_D),0)
      %FINISH %ELSE %START
         OPND1_FLAG=LCONST
         OPND1_D=WORKA_ARTOP
         OPND1_XTRA=INTEGER(ADDR(RVAL1))
         WORKA_ARTOP=WORKA_ARTOP+16
         MOVE BYTES(16,ADDR(RVAL1),0,ADDR(WORKA_A(0)),OPND1_D)
      %FINISH
      FLAG=0; OPND1_PTYPE=16*PRECP+2
      %RETURN
UISW(15):                                ! STRETCH INTEGER
      %IF 1<<HOST&LINTAVAIL#0 %AND PRECP=5 %THEN PRECP=6 %AND ->INT END
      %IF PRECP=4 %THEN PRECP=5 %AND ->INT END
      %RETURN
UISW(14):                                ! SHORTEN INTEGER
      %if precp=4 %and 0<=val1<=255 %then precp=3 %and ->int end
      %IF PRECP=5 %and IMOD(VAL1)<=X'7FFF' %THEN PRECP=4 %AND ->INT END
      %IF PRECP=6 %AND VAL1=SVAL1 %THEN PRECP=5 %AND ->INT END
      %RETURN
URSW(14):                                ! SHORTEN REAL
      PRECP=PRECP-1
      ->REAL END
URSW(12):                                ! FLOAT REAL
      IMPABORT
UISW(16):                                ! SHORTEN FOR <-
      %IF PRECP=5 %THEN VAL1=VAL1&X'FFFF' %AND PRECP=4 %AND ->INTEND
      %RETURN
URSW(36):                                ! INT
      %RETURN %UNLESS MOD(RVAL1)<X'7FFFFFFE'
      VAL1=INT(RVAL1)
      PRECP=5
      ->INTEND
URSW(37):                                ! INTPT
      %RETURN %UNLESS MOD(RVAL1)<X'7FFFFFFE'
      VAL1=INTPT(RVAL1)
      PRECP=5
      ->INTEND
UISW(38):                                ! TOSTRING
      STRVAL1=TOSTRING(VAL1)
      ->STREND
URSW(48):                                ! TRUNC coded without using itself as it
                                         ! it is not provided in the older compilers
      %RETURN %UNLESS MOD(RVAL1)<x'7ffffffe'
      %IF RVAL>=0 %THEN VAL1=INTPT(RVAL1) %ELSE VAL1=-INTPT(MOD(RVAL1))
      PRECP=5
      ->INTEND
BISW(0):                                 ! ADD
BISW(14):                                ! COMBINE VMY RESULTS
      VAL1=VAL1+VAL2; ->INT END
BISW(1):                                 ! MINUS
      VAL1=VAL1-VAL2; ->INT END
BISW(2):                                 ! EXCLUSIVE OR
      VAL1=VAL1!!VAL2; ->INT END
BISW(3):                                 ! OR
      VAL1=VAL1!VAL2; ->INT END
BISW(4):                                 ! MULT
      VAL1=VAL1*VAL2; ->INT END
BISW(6):%RETURN;                         ! / DIVISION
BISW(5):%RETURN %IF VAL2=0;              ! // DIVISION
      VAL1=VAL1//VAL2; ->INT END
BISW(7):                                 ! AND
      VAL1=VAL1&VAL2; ->INT END
BISW(9):                                 ! SLL
      %IF PRECP=6 %THEN VAL1=VAL1<<SVAL2 %ELSE VAL1=SVAL1<<SVAL2
      ->INT END
BISW(8):                                 ! SRL
      %IF PRECP=6 %THEN VAL1=VAL1>>SVAL2 %ELSE VAL1=SVAL1>>SVAL2
      ->INT END
BISW(13):                                ! VMY & CHK BOUNDS
      MAXD=XTRA>>24&15;                  ! MAX DIMENSION
      C=XTRA>>28;                        ! DIMENSION
      D=OPND2_D&X'FFFF';                 ! DV POINTER
      %IF TARGET=PNX %OR TARGET=PERQ %OR TARGET=ACCENT %OR 1<<TARGET&EMACHINE#0 %START
         LB=DEBYTESWOP(WORKA_CTABLE(D+3*C+1))
         UB=DEBYTESWOP(WORKA_CTABLE(D+3*C))
         MP=DEBYTESWOP(WORKA_CTABLE(D+3*C-1))
         %IF VAL1<LB %OR VAL1>UB %THEN FAULT(50,VAL1,XTRA&X'FFFF')
         VAL1=VAL1*MP %UNLESS C=1
         ->INT END
      %FINISH
      %IF TARGET=EMAS %START
         C=3*(MAXD+1-C)
         JJ=(VAL1-WORKA_CTABLE(D+C))*WORKA_CTABLE(D+C+1)
         %IF JJ<0 %OR JJ>WORKA_CTABLE(D+C+2) %THEN FAULT(50,VAL1,XTRA&X'FFFF')
         VAL1=JJ
         ->INT END
      %FINISH
      %IF TARGET=IBM %OR TARGET=AMDAHL %OR TARGET=IBMXA %START
         %IF VAL1<WORKA_CTABLE(D+3*C) %OR VAL1>WORKA_CTABLE(D+3*C+1) %THEN FAULT(50,VAL1,XTRA&X'FFFF')
         VAL1=VAL1*WORKA_CTABLE(D+3*C+2)
         ->INTEND
      %FINISH
      %RETURN
BISW(18):                                ! BADJ ADUST ARRAY BASE
      %IF TARGET=PERQ %OR 1<<TARGET&EMACHINE#0 %OR TARGET=ACCENT %OR TARGET=PNX %START
         D=XTRA>>24&15;                  ! TOTAL NO OF DIMENSIONS
         KK=VAL2;                        ! DV DISP
         %RETURN %UNLESS KK>0
         JJ=DEBYTESWOP(WORKA_CTABLE(KK));! adjustment
         VAL1=VAL1+JJ
      %FINISH
      ->INT END
BISW(46):
BISW(47):                                ! scomp & sdcomp
BRSW(46):
BRSW(47):                                ! scomp & sdcomp
BISW(11):
BISW(12):                                ! COMPARISONS
BRSW(11):
BRSW(12):                                ! REAL COMPARISONS
      MASK=XTRA;                         ! XTRA HAS IBM TYPE MASK
                                         ! RETURN MASK AS 15(=JUMP) OR 0 (IGNORE)
      FLAG=0
      %IF TYPEP=2 %THEN ->RCOMP
      %IF TYPEP=5 %THEN ->SCOMP
      %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 %C
         MASK=0
      %if op=12{dsided} %then opnd1=opnd2
      %RETURN
RCOMP:
      %IF (MASK&8#0 %AND RVAL1=RVAL2) %OR (MASK&4#0 %AND RVAL1<RVAL2) %OR (MASK&2#0 %AND RVAL1>RVAL2) %THEN %C
         MASK=15 %ELSE MASK=0
      %if op=12{dsided} %then opnd1=opnd2
      %RETURN
SCOMP:
      %IF (MASK&8#0 %AND STRVAL1=STRVAL2) %OR (MASK&4#0 %AND STRVAL1<STRVAL2) %OR (MASK&2#0 %AND %C
         STRVAL1>STRVAL2) %THEN MASK=15 %ELSE MASK=0
      %if op=47{dsided} %then opnd1=opnd2
      %RETURN
URSW(11):                                ! NEGATE
      RVAL1=-RVAL1; ->REAL END
BRSW(13):                                ! ABS
      RVAL1=MOD(RVAL1); ->REAL END
BRSW(0):                                 ! ADD
      RVAL1=RVAL1+RVAL2; ->REAL END
BRSW(1):                                 ! SUBTRACT
      RVAL1=RVAL1-RVAL2; ->REAL END
BRSW(4):                                 ! MULT
      RVAL1=RVAL1*RVAL2; ->REAL END
BRSW(6):                                 ! DIVISION
      %RETURN %IF RVAL2=0;               ! AVOID DIV BY ZERO
      RVAL1=RVAL1/RVAL2; ->REAL END
BISW(10):                                ! '**' WITH 2 INTEGER OPERANDS
BRSW(10):                                ! '**' WITH AT LEAST 1 REAL
      %RETURN %UNLESS OPND2_PTYPE&7=1 %AND-77<=VAL2<=75
!      RVAL1=RVAL1**VAL2
!
! avoid exponentiation in case a support routine reqd
!
      RVAL2=1
         rval2=rval2*rval1 %for jj=1,1,imod(val2)
      %if val2<0 %then rval1=1.0/rval2 %else rval1=rval2
      ->REALEND
BISW(17):                                ! '****' WITH 2 INTEGER OPERAND
      %RETURN %UNLESS 0<=VAL2<=63
      VAL2=1
      %WHILE SVAL2>0 %CYCLE
         VAL2=VAL2*VAL1
         SVAL2=SVAL2-1
      %REPEAT
      VAL1=VAL2; ->INT END
BISW(24):                                ! CONCAT
      %RETURN %IF LENGTH(STRVAL1)+LENGTH(STRVAL2)>255
      STRVAL1=STRVAL1.STRVAL2
STREND:                                  ! RETURN VALUE
      OPND1_PTYPE=X'35'
      OPND1_FLAG=LCONST
      OPND1_XTRA=LENGTH(STRVAL1)
      JJ=WORKA_ARTOP
      WORKA_A(JJ)=OPND1_XTRA
      %FOR K=1,1,OPND1_XTRA %CYCLE
         WORKA_A(JJ+K)=CHARNO(STRVAL1,K)
      %REPEAT
      OPND1_D=JJ
      WORKA_ARTOP=(JJ+OPND1_XTRA+2)&(-2);  ! PERQ KEEP 16 BIT ALIGNED
      FLAG=0
      %RETURN
URSW(*):
UISW(*):
BRSW(*):
BISW(*):
      %RETURN
%ROUTINE EXTRACT(%RECORD (RD) %NAME OPND)
!***********************************************************************
!*    EXTRACTS A CONTANT OPERAND RETURNING REAL &INT VALUES           *
!***********************************************************************
%INTEGER TYPE,PREC,I,AD
      TYPE=OPND_PTYPE; PREC=TYPE>>4
      TYPE=TYPE&15
      VAL=0; RVAL=0; STRVAL=""
      %IF TYPE=5 %START
         LENGTH(STRVAL)=WORKA_A(OPND_D)
         %FOR I=1,1,OPND_XTRA %CYCLE
            CHARNO(STRVAL,I)=WORKA_A(OPND_D+I)
         %REPEAT
      %FINISH %ELSE %IF TYPE=1 %THEN %START
         %IF 1<<HOST&LINTAVAIL#0 %AND PREC=6 %THEN VAL=LENGTHENI(OPND_D)<<32!(OPND_XTRA&(LENGTHENI(-1)>>32)) %ELSE %C
            VAL=OPND_D
         RVAL=VAL
      %FINISH %ELSE %START
         %IF PREC=5 %THEN RVAL=OPND_R %ELSE %IF PREC=6 %THEN %START
            MOVE BYTES(8,ADDR(OPND_D),0,ADDR(LR),0)
            RVAL=LR
         %FINISH %ELSE MOVE BYTES(16,ADDR(WORKA_A(0)),OPND_D,ADDR(RVAL),0)
      %FINISH
%END
%INTEGER %FN DEBYTESWOP(%INTEGER VAL)
!***********************************************************************
!*    ITEMS IN THE THE CONST TABLE MAY BE BYTE SWOPPED. DEBYTESWOP BY  *
!*    BYTE SWOPPING AGAIN. PDS PRAYS THERE WILL NEVER BE ARCHITECTURE  *
!*    WHERE THIS IS NOT TRUE!                                          *
!***********************************************************************
%RECORD (RD) OPND
      OPND=0
      OPND_PTYPE=X'51'
      OPND_D=VAL
      %IF HOST#TARGET %THEN REFORMATC(OPND)
      %RESULT=OPND_D
%END
%END
%EXTERNAL %ROUTINE TRIP OPT(%RECORD (TRIPF) %ARRAY %NAME TRIPLES, %INTEGER inptr)
!***********************************************************************
!*    SCANS A TRIPLES LIST FOR POSSIBLE OPTIMISATIONS                  *
!***********************************************************************
%INTEGER CHANGES,DUPS,DUPTNO,PTR,I,J,K,VAL,XVAL,CURR,NEXT,OP1,OP2,CTOPOP,REVOP,APTYPE,FOLD AGAIN
%BYTE %INTEGER %ARRAY %NAME A
%RECORD (TRIPF) %NAME CURRT,NEWT,NEXTT
%RECORD (RD) %NAME OPND1,OPND2,POPND,ROPND
%ROUTINE %SPEC SWOP OPERANDS(%RECORD (TRIPF) %NAME CURRT)
%INTEGER %FN %SPEC POWEROF2(%INTEGER VAL)
%INTEGER %FN %SPEC PRELOAD PLACE(%INTEGER TRIP)
%ROUTINE %SPEC INDOPT(%RECORD (RD) %NAME OPND)
%ROUTINE %SPEC VMYOPT(%INTEGER CURR)
%INTEGER %FN %SPEC SAME OPND(%RECORD (RD) %NAME OPND1,OPND2,%integer ASSN)
%ROUTINE %SPEC INVERT DIV(%RECORD (TRIPF) %NAME CURRT)
%ROUTINE %SPEC CHECK DUPS(%INTEGER STRIPNO,STRIPNO)
%ROUTINE %SPEC PROPAGATE CASS(%INTEGER STRIPNO, %RECORD (RD) %NAME N,C)
%ROUTINE %SPEC DUPLICATE TRIP(%INTEGER TRIPNO,DTRIPNO,FLAGBITS)
%ROUTINE %SPEC DEC USE(%INTEGER TRIPLE NO)
%ROUTINE %SPEC DELETE TRIPLE(%INTEGER TRIPLE NO)
      %IF TARGET=AMDAHL %OR TARGET=IBM %OR TARGET=IBMXA %START

                                         ! ON IBM VMY OF 0 ALWAYS ZERO
      %CONST %BYTE %INTEGER %ARRAY FOLD NOOP INFO(0:199)= 0(128),
                    X'89',X'41',X'89',X'89',X'B6',{+,-,!!,!,*} %C
                    2,0,X'A4',1,1,{//,/,&,>>,<<} %C
                    2,0,0,32,X'89',{**,COMP,DCOMP,VMY,COMB} %C
                    0,0,2,0,0,{=,<-,****,BADJ,INDEX} %C
                    0{IFETCH},0(3),
                    X'40'{CONCAT},0(*)
      %FINISH %ELSE %IF TARGET=EMAS %START
                                         ! INDEX IS NOT NECESSARILY A NOOP WHEN INDEX IS 0
!
      %CONST %BYTE %INTEGER %ARRAY FOLD NOOP INFO(0:199)= 0(128),
                    X'89',X'41',X'89',X'89',X'B6',{+,-,!!,!,*} %C
                    2,0,X'A4',1,1,{//,/,&,>>,<<} %C
                    2,0,0,3,X'89',{**,COMP,DCOMP,VMY,COMB} %C
                    0,0,2,0,0,{=,<-,****,BADJ,INDEX} %C
                    0{IFETCH},0(3),
                    X'40'{CONCAT},0(*)
      %FINISH %ELSE %START
      %CONST %BYTE %INTEGER %ARRAY FOLD NOOP INFO(0:199)= 0(128),
                    X'89',X'41',X'89',X'89',X'B6',{+,-,!!,!,*} %C
                    2,0,X'A4',1,1,{//,/,&,>>,<<} %C
                    2,0,0,3,X'89',{**,COMP,DCOMP,VMY,COMB} %C
                    0,0,2,0,1,{=,<-,****,BADJ,INDEX} %C
                    0{IFETCH},0(3),
                    X'40'{CONCAT},0(*)
      %FINISH

! 2**0 SET IF SECOND OPERAND ZERO IS NOOP
! 2**1 SET IF SECOND OPERAND 1 IS A NOOP
! 2**2 SET IF SECOND OPERAND 0 MEANS RESULT=0
! 2**3 SET IF FIRST OPERAND ZERO IS NOOP
! 2**4 SET IF FIRST OPERAND 1 IS A NOOP
! 2**5 SET IF  FIRST OPERAND ZERO MEANS RESULT=0
! 2**6 SET IF FOLDING WITH ITSELF POSSIBLE BUT NOT SIMPE
! 2**7 SET FOR NORMAL FOLDING
!
      A==WORKA_A
      CHANGES=0;                         ! NO CHANGES AS YET
      DUPS=0;                            ! NO DUPLICATES YET
      %if parm_dcomp#0 %then printstring("Optimising triples ") %and print trips(triples)

!
! LOOK FOR REGISTER TO STORE OPERATIONS ON  EMACHINES (xcept VNS and risk)
!
         PTR=inptr
         %WHILE PTR>0 %CYCLE
            CURRT==TRIPLES(PTR)
            PTR=CURRT_FLINK
            NEXTT==TRIPLES(PTR)
            %EXIT %IF PTR=0;             ! THE END
            %UNLESS NEXTT_OPERN=VASS %AND NEXTT_OPTYPE=X'51'=CURRT_OPTYPE %AND (NEXTT_OPND1_FLAG=DNAME %OR %C
               NEXTT_OPND1_FLAG=INDNAME %or NEXTT_OPND1_FLAG=arname) %AND NEXTT_OPND2_FLAG=REFTRIP %AND CURRT_PUSE=PTR %AND CURRT_CNT=1 %THEN %C
               %CONTINUE
            %CONTINUE %UNLESS ADD<=CURRT_OPERN<=ANDL;  ! lshift & rshift also possible on pnx
            %IF CURRT_FLAGS&COMMUTABLE#0 %AND SAME OPND(CURRT_OPND2,NEXTT_OPND1,NO)=YES %THEN %C
               SWOP OPERANDS(CURRT) %ELSE %START
               %CONTINUE %UNLESS SAME OPND(CURRT_OPND1,NEXTT_OPND1,NO)=YES
            %FINISH
            NEXTT_X1=CURRT_OPERN
            NEXTT_OPERN=RSTORE
            NEXTT_PUSE=0
            NEXTT_FLAGS<-DONT OPT!CURRT_FLAGS&(\LOAD OP1);  ! THIS AVOIDS A USELESS PRELOAD
            NEXTT_opnd2=CURRT_opnd2
            triples(NEXTT_BLINK)_opern=NULLT
            changes=changes+1
         %REPEAT
      %IF CHANGES>0 %AND PARM_DCOMP#0 %THEN PRINT TRIPS(TRIPLES)
      WORKA_OPTCNT=WORKA_OPTCNT+CHANGES
      %RETURN
%INTEGER %FN POWEROF2(%INTEGER VAL)
!***********************************************************************
!*    CHECKS IF VAL IS A POWER OF 2                                    *
!***********************************************************************
%INTEGER I,J
      %FOR I=1,1,30 %CYCLE
         J=1<<I
         %IF J=VAL %THEN %RESULT=I
         %IF J>VAL %THEN %RESULT=0
      %REPEAT
      %RESULT=0
%END
%ROUTINE SWOP OPERANDS(%RECORD (TRIPF) %NAME CURRT)
!***********************************************************************
!*    EXCHANGE OPND1&OPND2 KEEPING THE FLAGS CORRECT                   *
!***********************************************************************
%RECORD (RD) TOPND
%INTEGER FLAGS,NEWFLAGS
      TOPND=CURRT_OPND1
      CURRT_OPND1=CURRT_OPND2
      CURRT_OPND2=TOPND
      FLAGS=CURRT_FLAGS
      NEWFLAGS=FLAGS&(\(LOADOP1+LOADOP2))
      %IF FLAGS&LOADOP1#0 %THEN NEWFLAGS=NEWFLAGS!LOADOP2
      %IF FLAGS&LOADOP2#0 %THEN NEWFLAGS=NEWFLAGS!LOADOP1
      CURRT_FLAGS=NEWFLAGS
      CHANGES=CHANGES+1
%END
%INTEGER %FN PRELOAD PLACE(%INTEGER TRIP)
!***********************************************************************
!*    LOOK FOR FIRST TRIPLE IN THE CHAIN THAT LEADS TO TRIP            *
!*    CAN BE VERY COMPILCATED. RETURN -1 IF NOT SIMPLE                 *
!***********************************************************************
%CONST %INTEGER TRIPREFS=X'140';         ! BITMASK OF OPERAND FORMATS
%RECORD (RD) %NAME OPND1,OPND2
%RECORD (TRIPF) %NAME CURRT
      CURRT==TRIPLES(TRIP)
      OPND1==CURRT_OPND1
      OPND2==CURRT_OPND2
      %IF CURRT_OPERN<128 %OR 1<<CURRT_OPND2_FLAG&TRIPREFS=0 %START
                                         ! BACK VIA OPND1
         %IF 1<<CURRT_OPND1_FLAG&TRIPREFS=0 %THEN %RESULT=TRIP
         %RESULT=PRELOAD PLACE(OPND1_D)
      %FINISH
      %IF 1<<CURRT_OPND1_FLAG&TRIPREFS=0 %OR OPND1_D=CURRT_BLINK %THEN %RESULT=PRELOAD PLACE(OPND2_D)
!
! BOTH OPERANDS ARE LOADED TRIPLES
!
      %IF CURRT_BLINK=OPND2_D %THEN %RESULT=PRELOADPLACE(OPND1_D)
      %RESULT=-1;                        ! TOO COMPLICATED
%END
%ROUTINE INDOPT(%RECORD (RD) %NAME OPND)
!***********************************************************************
!*    OPND IS AN INDIRECT OFFSET. TRY TO SUBSUME PART OF THE EXPRESSION*
!*    INTO THE OFFSET, REALLY GUNNING FOR IMP REFERENCES TO PAG0 ON IBM*
!***********************************************************************
%INTEGER COP,X,VAL,OP,LIMIT
%RECORD (TRIPF) %NAME RTRIP
%RECORD (RD) %NAME COPND
      %IF TARGET=IBM %OR TARGET=AMDAHL %OR TARGET=IBMXA %THEN LIMIT=4096 %ELSE %IF TARGET=EMAS %THEN %C
         LIMIT=X'7FFFFFFF' %ELSE LIMIT=1<<16
      RTRIP==TRIPLES(OPND_D)
      %RETURN %UNLESS RTRIP_CNT=1 %AND RTRIP_FLAGS&CONSTANTOP#0
      OP=RTRIP_OPERN
      %RETURN %UNLESS OP=ADD %OR OP=SUB
      %RETURN %UNLESS RTRIP_OPTYPE&7=1 %AND RTRIP_OPTYPE>>4<6
      %IF RTRIP_OPND1_FLAG<=1 %THEN %START
         COP=1;                          ! CONSTANT IS OP 1
         COPND==RTRIP_OPND1;             ! DEFINED BY COPND
      %ELSE
         COP=2;                          ! CONSTANT IS OPERAND 2
         COPND==RTRIP_OPND2
      %FINISH
      X=OPND_XTRA;                       ! CURRENT OFFSET
      %IF X<0 %THEN X=0
      VAL=COPND_D
      %IF OP=ADD %AND LIMIT>X+VAL>=0 %THEN COPND_D=0 %AND OPND_XTRA=X+VAL %AND %RETURN
                                         ! THE ZERO ADD WILL BE ELAIMINATED
      %IF OP=SUB %AND LIMIT>X-VAL>=0 %AND COP=2 %THEN COPND_D=0 %AND OPND_XTRA=X-VAL
%END
%ROUTINE VMYOPT(%INTEGER CURR)
!***********************************************************************
!*    ANALYSES A VMY AND REPACES WITH A CONSTANT MULTIPLY IF POSSIBLE  *
!***********************************************************************
%RECORD (TRIPF) %NAME CURRT
%RECORD (RD) %NAME OPND2
%INTEGER C,D,VALUE,APTYPE,DV,I,J,DVNAME
      CURRT==TRIPLES(CURR)
      OPND2==CURRT_OPND2
      C=CURRT_X1>>28;                    ! CURRENT DIMENSION
      D=CURRT_X1>>24&15;                 ! MAX DIMENSION
      DV=0
      %IF OPND2_FLAG=SCONST %THEN DV=OPND2_D;  ! DOPE VECTOR IF CONST
      %IF (TARGET=PNX %OR TARGET=PERQ %OR TARGET=ACCENT) %AND C=1 %THEN VALUE=1 %AND ->TOMULT
      APTYPE=-1;                         ! ARRAY PTYPE
      DVNAME=CURRT_X1&X'FFFF'
      %IF DVNAME>0 %THEN APTYPE=WORKA_ASLIST(WORKA_TAGS(DVNAME))_PTYPE
      %IF TARGET=EMAS %START
         %IF DV>0 %START
            I=3*(D+1-C)
            %IF WORKA_CTABLE(DV+I)=0 %THEN VALUE=WORKA_CTABLE(DV+I+1) %AND ->TOMULT
         %FINISH
         %IF APTYPE>>8=2 {ARR=2,NAM=0} %AND C=1 %AND APTYPE&7<=2 %AND APTYPE&255#X'41' %THEN VALUE=1 %AND ->TOMULT
      %FINISH
      %IF TARGET=IBM %OR TARGET=AMDAHL %OR TARGET=IBMXA %START
         %IF C=1=D %AND CURRT_OPND1_FLAG=REFTRIP %THEN IBMVMY(CURR)
         %IF OPND1_FLAG=SCONST %AND OPND1_D=0 %THEN VALUE=1 %AND ->TOMULT
                                         ! ANY VMY OF 0 =0 ON IBMS
         %IF DV>0 %THEN VALUE=WORKA_CTABLE(DV+3*C+2) %AND ->TOMULT
         %IF C=1 %START
            %IF APTYPE&7<=2 %THEN VALUE=BYTES(APTYPE>>4&7) %AND ->TOMULT
            %IF APTYPE&X'0C00'=0 %START;  ! NAM=0
               %IF DVNAME>0 %THEN VALUE=WORKA_ASLIST(WORKA_TAGS(DVNAME))_ACC %AND ->TOMULT
            %FINISH
         %FINISH
      %FINISH
      %RETURN
TOMULT:                                  ! CHANGE VMY TO INTEGER MULT
      CURRT_OPERN=MULT
      CURRT_FLAGS=CURRT_FLAGS!CONSTANT OP
      OPND2_PTYPE=CURRT_OPTYPE;          ! SOME M-CS HAVE 16 BIT OPERATIONS
      OPND2_FLAG=SCONST
      OPND2_D=VALUE
      CHANGES=CHANGES+1
%END
%ROUTINE DEC USE(%INTEGER TRIPLE NO)
!***********************************************************************
!*    A TRIPLE HAS BEEN PASSED INTO 'DEAD' CODE. DECREMENT ITS USE     *
!*    AND IF RELEVANT DELETE OPERATIONS LEADING TO IT                  *
!***********************************************************************
%RECORD (TRIPF) %NAME CURRT
      CURRT==TRIPLES(TRIPLE NO)
      %IF CURRT_CNT=0 %START
         PRINTSTRING("dec use???
")
         PRINT TRIPS(TRIPLES)
         %MONITOR
      %FINISH
      CURRT_CNT<-CURRT_CNT-1
      %IF CURRT_CNT=1 %THEN DUPS=DUPS-1
      %IF CURRT_CNT=0 %AND CURRT_OPERN#RSTORE %AND CURRT_OPERN#NULLT %THEN DELETE TRIPLE(TRIPLE NO)
%END
%ROUTINE DELETE TRIPLE(%INTEGER TRIPLE NO)
%RECORD (TRIPF) %NAME DELT
      DELT==TRIPLES(TRIPLE NO)
      %IF 1<<DELT_OPND1_FLAG&BTREFMASK#0 %THEN DEC USE(DELT_OPND1_D)
      %IF DELT_OPERN>=128 %AND 1<<DELT_OPND2_FLAG&BTREFMASK#0 %THEN DEC USE(DELT_OPND2_D)
      DELT_X1=DELT_OPERN;                ! FOR DEBUGGING
      DELT_OPERN=NULLT;                  ! NO OP
      CHANGES=CHANGES+1
      DELT_FLAGS<-DELT_FLAGS!DONT OPT
%END
%ROUTINE DUPLICATE TRIP(%INTEGER TRIPNO,DTRIPNO,FLAGBITS)
!***********************************************************************
!*    DTRIPNO IS A DUPLICATE OF TRIPNO. CHANGE ALL REFERENCES          *
!*    AND DELETE IT                                                    *
!***********************************************************************
%RECORD (RD) %NAME OPND1,OPND2
%RECORD (TRIPF) %NAME MASTER,CURRT,DUPT
%INTEGER CNT,PTR
      DUPS=DUPS+1
      DUPTNO=TRIPNO
      MASTER==TRIPLES(TRIPNO)
      DUPT==TRIPLES(DTRIPNO)
      MASTER_FLAGS=MASTER_FLAGS!FLAGBITS
      CNT=DUPT_CNT
      PTR=DUPT_FLINK
!
      %WHILE CNT>0 %AND PTR>0 %CYCLE
         CURRT==TRIPLES(PTR)
         PTR=CURRT_FLINK
         %IF CURRT_OPERN=NULLT %THEN %CONTINUE
         OPND1==CURRT_OPND1
         OPND2==CURRT_OPND2
         %IF OPND1_D=DTRIPNO %AND 1<<OPND1_FLAG&BTREFMASK#0 %START
            MASTER_CNT=MASTER_CNT+1
            OPND1_D=TRIPNO
            CURRT_FLAGS=CURRT_FLAGS!LOAD OP1
            CNT=CNT-1
         %FINISH
         %IF CURRT_OPERN>=128 %AND OPND2_D=DTRIPNO %AND 1<<OPND2_FLAG&BTREFMASK#0 %START
            MASTER_CNT=MASTER_CNT+1
            OPND2_D=TRIPNO
            CURRT_FLAGS=CURRT_FLAGS!LOAD OP2
            CNT=CNT-1
         %FINISH
      %REPEAT
      DELETE TRIPLE(DTRIPNO)
%END
%ROUTINE INVERT DIV(%RECORD (TRIPF) %NAME CURRT)
!***********************************************************************
!*    DIVISION BY A REAL CONSTANT HAS BEEN FOUND                       *
!*    SO INVERT IT AND CHANGE TO MULTIPLY. USE CTOP FOR OPERATIONS     *
!*    THIS WILL FAIL IF NOT ENOUGH PRECISION ON HOST FOR TARGET        *
!***********************************************************************
%INTEGER OP,PREC,FLAG,J
%RECORD (RD) WOPND,COPND
%LONG %REAL LR
      COPND=CURRT_OPND2;                 ! THE CONST TO BE INVERTED
      PREC=CURRT_OPTYPE>>4;              ! PRECISION
      WOPND_S1=COPND_S1
!
! SET UP WOPND AS REAL ONE IN GIGTH PRECISION
!
      %IF PREC=5 %THEN WOPND_R=1.0 %ELSE %IF PREC=6 %THEN %START
         LR=1.0
         MOVE BYTES(8,ADDR(LR),0,ADDR(WOPND_D),0)
      %FINISH %ELSE %START
         WOPND_PTYPE=X'61'
         WOPND_D=0
         WOPND_XTRA=1
         OP=IFLOAT
         CTOP(OP,J,0,WOPND,COPND);       ! FLOAT LONG 1 TO REAL
         %RETURN %IF OP#0;               ! NO CAN DO
      %FINISH
      OP=REAL DIV
      CTOP(OP,J,0,WOPND,COPND)
      %RETURN %IF OP#0
      CURRT_OPERN=MULT
      CURRT_OPND2=WOPND
%END
%ROUTINE CHECK DUPS(%INTEGER TRIPNO,STRIPNO)
!***********************************************************************
!*    CHECK STARTING FROM STRIPNO FOR DUPLICATES OF TRIPNO             *
!*    MAY BE MORE THAN ONE                                             *
!***********************************************************************
%RECORD (TRIPF) %NAME CURRT,DUPT,WORKT
%RECORD (RD) AOPND,DOPND1,DOPND2,WOPND1,WOPND2
%CONST %INTEGER LMAX=4
%INTEGER %ARRAY LABS(0:LMAX)
%INTEGER OP,NEXT,LPTR,I,J,CTRIPNO,OPERN,F,C11,C12,C21,C22,W12,W22,LABP
      DUPT==TRIPLES(TRIPNO)
      DOPND1=DUPT_OPND1; DOPND2=DUPT_OPND2
      OPERN=DUPT_OPERN
                                         ! COMPARISONS ARE IMPOSSIBLE TO OPTIMISE
                                         ! ON CONDITION CODE MACHINES
                                         ! POSSIBLE BUT DIFFICULT ON TRUE FLAG MCS
      %IF OPERN=COMP %OR OPERN=DCOMP %OR OPERN=SCOMP %OR OPERN=SDCMP %THEN %RETURN
      %IF OPERN=PRECC %OR OPERN=CONCAT %OR OPERN=PRES1 %OR OPERN=PRES2 %THEN %RETURN
      %IF OPERN=PRECL %OR PASS1<=OPERN<=PASS6 %THEN %RETURN
      %if opern=getptr %and dupt_optype=X'61' %then %return
                                        ! two word pointers are tricky things to store and pickup
      F=DUPT_FLAGS
      LPTR=0; LABP=0
      %WHILE STRIPNO>0 %CYCLE
         CURRT==TRIPLES(STRIPNO)
         %EXIT %IF CURRT_FLAGS&ASS LEVEL#0
         OP=CURRT_OPERN
         %IF OP=FJUMP %AND LPTR<=LMAX %START
            J=CURRT_OPND1_D
            I=J&X'FFFF';                 ! THE LAB NO
            %IF J<0 %AND I>WORKA_NNAMES %THEN LABS(LPTR)=I %AND LPTR=LPTR+1
         %FINISH
         %IF OP=TLAB %START
            LABP=USED LATE;              ! FLAG OPERAND IF DUPLICATE FOUND
            J=CURRT_OPND1_D&X'FFFF';     ! THE LAB NO
            %FOR I=0,1,LPTR-1 %CYCLE
               ->JSEEN %IF J=LABS(I)
            %REPEAT
            %EXIT;                       ! CAN NOT NORMALLY PASS LABES
JSEEN:                                   ! THE FIRST JUMP TO THIS LAB HAS
                                         ! BEEN PASSED. THERE ARE NO BACK JUMPS
                                         ! TO INTERNAL LABELS FIRST REFERENCED
                                         ! VIA A FORWARD JUMP
         %FINISH
         %EXIT %IF OP=RTXIT %OR OP=RCALL
         %EXIT %IF OP=SETSW %OR OP=AHASS %OR OP=PTRAS %OR OP=LASS
         %IF OP=VASS %OR OP=VJASS %or strass1<=op<=strjt %OR OP=DMASS %OR OP=RSTORE %START;  ! ASSIGNMENT
            AOPND=CURRT_OPND1;           ! DEST OF ASSIGNMENT
            %IF AOPND_FLAG=INDIRECT %AND (DOPND1_FLAG=INDIRECT %OR DOPND2_FLAG=INDIRECT) %START
                                         ! MAPPED ARRAYS MAKE AY ARRAY OR MAP ASSIGNMENT
                                         ! DIFFICULT TO CHECK OUT. ONLY SAFE CASE
                                         ! IS TO DIFFERENT ARRAYS BUT NOT
                                         ! IF EITHER ARE ARRAYNAMES
               %EXIT
            %FINISH %ELSE %START
               %EXIT %IF SAME OPND(AOPND,DOPND1,yes)=YES
               %EXIT %IF OPERN>=128 %AND SAME OPND(AOPND,DOPND2,yes)=YES
            %FINISH
         %FINISH
         %if op=getad %or op=getptr %Start
            aopnd=currt_opnd1
            %if same opnd(aopnd,dopnd1,yes)=yes %then %exit
            %if opern>=128 %and same opnd(aopnd,dopnd2,yes)=yes %then %exit
         %finish
         CTRIPNO=STRIPNO
         STRIPNO=CURRT_FLINK
         %IF OP=OPERN %AND (OP#VMY %OR DUPT_X1=CURRT_X1) %START
            C11=SAME OPND(DOPND1,CURRT_OPND1,NO)
            %IF OPERN<128 %START
               %IF C11=YES %THEN DUPLICATE TRIP(TRIPNO,CTRIPNO,LABP)
               %CONTINUE
            %FINISH
                                         ! NOW BINARY ONES
            C22=SAME OPND(DOPND2,CURRT_OPND2,NO)
            C12=NO; C21=NO
            %IF F&COMMUTABLE#0 %START
               C12=SAME OPND(DOPND1,CURRT_OPND2,NO)
               C21=SAME OPND(DOPND2,CURRT_OPND1,NO)
            %FINISH
            %IF C11=YES=C22 %OR C21=YES=C12 %START
               DUPLICATE TRIP(TRIPNO,CTRIPNO,LABP)
               %CONTINUE
            %FINISH
!
! now check for distributed common expressions ie (a+b) %AND (a+x+b). The latter
! is changes to (a+b+x) and the common element eliminated
!
            %IF C12!C11!C22!C21=YES %START
               WORKT==TRIPLES(CURRT_PUSE)
               WOPND1=WORKT_OPND1; WOPND2=WORKT_OPND2
               %IF OP=WORKT_OPERN %AND WORKT_CNT=1 %AND F&COMMUTABLE#0 %START
                  W22=SAME OPND(DOPND2,WOPND2,NO)
                  W12=SAME OPND(DOPND1,WOPND2,NO)
                  %IF C12=YES=W22 %OR C22=YES=W12 %OR C21=YES=W12 %OR C11=YES=W22 %START
                     %IF C12=YES %OR C22=YES %START
                        WORKT_OPND2=CURRT_OPND1
                        CURRT_OPND1=WOPND2
                     %FINISH %ELSE %START
                        WORKT_OPND2=CURRT_OPND2
                        CURRT_OPND2=WOPND2
                     %FINISH
                     DUPLICATE TRIP(TRIPNO,CTRIPNO,LABP)
                     %CONTINUE
                  %FINISH
               %FINISH
            %FINISH
         %FINISH
      %REPEAT
%END
%ROUTINE PROPAGATE CASS(%INTEGER STRIPNO, %RECORD (RD) %NAME NOPND,COPND)
!***********************************************************************
!*    CHECK STARTING FROM STRIPNO FOR DUPLICATES OF TRIPNO             *
!*    MAY BE MORE THAN ONE                                             *
!***********************************************************************
%RECORD (TRIPF) %NAME CURRT
%RECORD (RD) AOPND
%CONST %INTEGER LMAX=4
%INTEGER %ARRAY LABS(0:LMAX)
%INTEGER OP,NEXT,LPTR,I,J,CTRIPNO,LABP
      LPTR=0;
      %WHILE STRIPNO>0 %CYCLE
         CURRT==TRIPLES(STRIPNO)
         %EXIT %IF CURRT_FLAGS&ASS LEVEL#0
         OP=CURRT_OPERN
         %IF OP=FJUMP %AND LPTR<=LMAX %START
            J=CURRT_OPND1_D
            I=J&X'FFFF';                 ! THE LAB NO
            %IF J<0 %AND I>WORKA_NNAMES %THEN LABS(LPTR)=I %AND LPTR=LPTR+1
         %FINISH
         %IF OP=TLAB %START
            J=CURRT_OPND1_D&X'FFFF';     ! THE LAB NO
            %FOR I=0,1,LPTR-1 %CYCLE
               ->JSEEN %IF J=LABS(I)
            %REPEAT
            %EXIT;                       ! CAN NOT NORMALLY PASS LABES
JSEEN:                                   ! THE FIRST JUMP TO THIS LAB HAS
                                         ! BEEN PASSED. THERE ARE NO BACK JUMPS
                                         ! TO INTERNAL LABELS FIRST REFERENCED
                                         ! VIA A FORWARD JUMP
         %FINISH
         %EXIT %IF OP=RTXIT %OR OP=RCALL
         %EXIT %IF OP=SETSW %OR OP=PTRAS
         %IF OP=VASS %OR OP=STRASS2 %OR OP=VJASS %OR OP=DMASS %OR OP=RSTORE %OR OP=GETAD %OR OP=GETPTR %START
                                         ! ASSIGNMENT
            AOPND=CURRT_OPND1;           ! DEST OF ASSIGNMENT
            %EXIT %IF SAME OPND(AOPND,NOPND,yes)=YES
         %FINISH
         %IF SAME OPND(CURRT_OPND1,NOPND,NO)=YES %START
            CHANGES=CHANGES+1
            %IF OP<128 %OR CURRT_FLAGS&CONSTANTOP#0 %THEN FOLD AGAIN=YES
            CURRT_FLAGS=CURRT_FLAGS!CONSTANTOP
            CURRT_OPND1=COPND
         %FINISH
         %IF OP>=128 %AND SAME OPND(CURRT_OPND2,NOPND,NO)=YES %START
            CHANGES=CHANGES+1
            %IF CURRT_FLAGS&CONSTANTOP#0 %THEN FOLD AGAIN=YES
            CURRT_FLAGS=CURRT_FLAGS!CONSTANTOP
            CURRT_OPND2=COPND
         %FINISH
         STRIPNO=CURRT_FLINK
      %REPEAT
%END
%INTEGER %FN SAME OPND(%RECORD (RD) %NAME OPND1,OPND2,%integer ASSN)
!***********************************************************************
!*    ARE THESE OPERANDS THE SAME ?                                    *
!*    If assn=yes then allow for possible overlapping assignments      *
!*    in variant records                                               *
!***********************************************************************
%INTEGER F,I,B1,B2
!   printstring(" same opnd"); write(opnd1_flag,2); write(opnd2_flag,2); newline
      F=OPND1_FLAG
      %if f=3 %start     { ar pointer }
         %result=no %unless f=opnd2_flag
         b1=opnd1_d; b2=opnd2_d
         %if a(b1)=a(b2) %and a(b1+1)=a(b2+1) %and a(b1+2)=2 %and a(b2+2)=2 %c
            %and a(b1+3)=2 %and a(b2+3)=2 %then %result=yes
         %result=no
      %finish
      %IF F=2 %OR F=5 %START
           %result=no %unless f=opnd2_flag
         %RESULT=NO %UNLESS OPND1_D=OPND2_D %AND OPND1_PTYPE&X'3000'=0
         %IF ASSN=NO %AND OPND1_PTYPE#OPND2_PTYPE %THEN %RESULT=NO
         %IF OPND1_XTRA=OPND2_XTRA %THEN %RESULT=YES
         B1=BYTES(OPND1_PTYPE>>4&15)
         B2=BYTES(OPND2_PTYPE>>4&15)
         i=IMOD(OPND1_XTRA&X'FFFF'-OPND2_XTRA&X'FFFF')
         %IF ASSN=YES %AND (i<=B1 %or i<=B2) %THEN %RESULT=YES
         %RESULT=NO
      %FINISH
      %RESULT=NO %UNLESS OPND1_S1&X'FFFF00FF'=OPND2_S1&X'FFFF00FF'
      %IF F<=1 %START;                   ! CONSTANTS
         %IF OPND1_PTYPE=X'35' %START
            %RESULT=NO %UNLESS OPND1_XTRA=OPND2_XTRA
            %FOR I=1,1,OPND1_XTRA %CYCLE
               %RESULT=NO %UNLESS A(OPND1_D+I)=A(OPND2_D+I)
            %REPEAT
            %RESULT=YES
         %FINISH
         %RESULT=YES %IF OPND1_D=OPND2_D %AND (OPND1_XTRA=OPND2_XTRA %OR OPND1_PTYPE&X'F0'<=X'50')
         %RESULT=NO
      %FINISH
      %RESULT=YES %IF OPND1_D=OPND2_D %AND OPND1_XTRA=OPND2_XTRA
      %RESULT=NO
%END
%END
%END %OF %FILE
ftncomp65.4.i/  791657588   12014 11130 100666  116046    `
%ownstring(255) rcsid="$What: <@(#) ftncomp.i,v	63.0> $"
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
%ownstring(90) copyright = " Copyright (c) 1987, 1989 Edinburgh Portable Compilers Ltd. All Rights Reserved."
!* $Log: ftncomp.i,v $
!*                                                             ftncomp65.3
!* 26/07/93 - Switch off code scheduling when -g                        
!*                                                             ftncomp65.2
!* 19/07/93 - Removed EInitialise call from this module - it's back in
!*            ftndata again. (rt)
!*                                                             ftncomp65.1
!* 15/07/93 - Added -gisbuff=                                
!*                                                             ftncomp65rt
!* 13/07/93 - Added gY option and made gg enable rather than
!*            disable global scheduling. (rt)
!*                                                             ftncomp65g
!* 06/07/93 - add support for O4, O5 and rt private options
!*          - add calls to Esetoptions,EsetGISoptions
!*            and Einitialise (Note: deleted call in ftndata)
!*                                                             ftncomp64g
!* 01/06/93 - consolidated version for 88110 and Mips
!* 31/05/93 - recognise private options Zn and Xn for Fortran opt control
!*                                                             ftncomp63.1
!* 15/04/93 - -SC option for ADI Shared Commons
!*            includes coff.inc if object format is ISCOFF
!* 12Apr93  - added cgpeepmon and directed Malloc via getspace(pds)
!*
!* Revision 63.0  1992/12/23  15:25:00  simon
!*                                                             ftncomp63
!* 23/11/92 - case sensitivity option {-CS}
!*            intrinsics left as lower case namelist IO - libI
!*            passed -CS option
!*
!*                                                             ftncomp62.2
!* 23/11/92 - Case sensitivity option {-CS}                  
!*            recognises -CS in command line
!*            sets bits in com_options2 and cgoptions
!*                                                             ftncomp62.1
!* 04/07/92 - Make no scheduling the default, only schedule
!*            when optimiser switched on or -P cgshced
!*          - for RS6000 -O3 no longer sets hsflt and as
!*            reciprocation is done by the rs6000 code generator
!*            the -O3 option is obsolete.
!*
!* Revision 62.0  1992/07/10  11:49:31  simon
!*                                                             ftncomp62
!* 10/07/92 - Common source:
!*            Merge Intel change:
!*            Only hardwire -us by clearing nus bit in
!*            options2 if OMRON,not just when non OCScompliant
!*          - 88K ELF change:
!*            Increment vptr after processing pic options!
!*          - RS6000 change:
!* 17/06/92  Add cgparamsind to cgoptions for scheduler
!*
!*
!* Revision 61.0  92/01/07  11:44:06  simon
!                                                              ftncomp61.2
!* 08/04/92 - Add -q[no]chkof to always do overflow checks
!*            of floating point calculations
!* 18/03/92 - Set options2 to nus for RS6000 to be compatible
!*            with ibm's xlf compiler
!*            also scheduling always on unless -x set
!* 04/03/92 - Add -q[no]rndsngl,-q[no]hssngl for RS6000
!*                                                             ftncomp61.1
!* 24/01/91 - Change for IMP, whereby -O (optimise) implies
!*            NOTRACE - this improves code scheduling.
!*
!*          - Also includes Pete's changes for his Imp compiler:
!*            !06/12/91 - for IMP
!*                Decouple MAXDICT and MAXWORK. Maxdict only
!*                         affects names,
!*                Allow -N2048 etc to specify exact workfilesize,
!*                Reset BIGWORK to 512K (old Maxwork) and maxwork
!*                         to 1023K,
!*                Allow -m to mean MAXWORK+MAXDICT,
!*                -m sets the workfile size to 1023K rather
!*                         than 513K.
!*                                                             ftncomp61
!*            Merge in changes from sparc and omron:
!* 
!*            SPARC:                                           ftncomp60.2
!* 11/12/91 - for Emachine 4, tell the code generator if -pl
!*            (for line profiling) has been specified.
!* 
!*            for SPARC, switches off code scheduling (requested
!*            via -P cgsched) if compiling with diagnostics or
!*            sdb/dbx.
!*                                                             ftncomp60.1
!* 28/11/91 - Added the options -pic+ and -PIC+ to select
!*            small-model and large-model position independent
!*            code - currently no action is taken for Emachine 3
!* 
!* 14/11/91 - Added the private option CGSCHED to select
!*            code scheduling (on SPARC scheduling is
!*            normally only performed when optimising).
!* 
!*          - Added the private option CGSCHEDMON to switch on
!*            Emachine4 code scheduler tracing, in bprocs2
!*            onwards. This option also selects code scheduling.
!*  
!*            OMRON:                                           ftncomp60.1
!* 22/11/91 - set -us flag unconditionally for OMRON
!* 
!* Revision 60.0  91/10/21  11:25:52  simon
!*                                                               ftncomp60
!* 19/10/91 - common source
!*          - define and set superscalar
!*          - define and set G2traceMOO
!* 
!* 
!                                                             ftncomp59.2
! 03/10/91 - Allow -132 if Env=Gould which gives users
!            two ways of having long lines (-132 and -ff)
!                                                               ftncomp59.1
! 11/09/91 - Merge in Gould Changes:
!          - call putincname from select include
!          - add 77+ option
!          - add closein
!                                                               ftncomp59
! 28/07/91 - common source (==ftncomp58.1)
!                                                               ftncomp58.2a
!  7/08/91 - for m88k, rationalise use of Target = M88000 and
!            Host = M88000 for the Sun3/Sun4 M88110 compiler.
!
!  6/08/91 - for IMP, put references to lineprofiler, profiler,
!            timeprofiler, autoflag, and recipopt behind
!            Compiler=Fortran conditional compilation.
!                                                               ftncomp58.1
! 30/04/91 - for 88k call disabletraps to disable 88k fpu traps
!                                                               ftncomp58
! 28/03/91 - added the private option NOUNROLL which inhibits
!            loop unrolling (will only work in ftnloop27 onwards)
!
! 25/03/91 - uses getstat.c and the host independent form of
!            the file information table - compatible with
!            fstatfmt10.inc onwards
!
!          - add function Nusoption which returns 1 if -nus
!            has been used (88k only)
!
!          - add call to Esourcefile to pass the source file to
!            dgen (Host=DRS only)
!
!          - implement -Y option to declare unshared common
!            blocks (Allowparallel only)
!
!          - add procedure Abort (to provide a uniformity
!            when reporting an error)
!                                                               ftncomp57
! 22/01/91 - expanded the searchpaths for an INCLUDE file to
!            include (a) the current working directory after
!                        searching -I directories
!                    (b) /usr/include after the current
!                        working directory
!            (required by Release 2.6.2)
!
! 16/01/91 - add recipopt, misalignedreals, and Opt2max to
!            the -P OPTIONS output
!
! 08/01/91 - make instruction scheduling the default for 88k
!          - moved Copyright text in Printvers into vers.X.inc
!                                                               ftncomp56
! 08/01/91 - set recipopt if -O3
!                                                               ftncomp55.1
!  5/12/90 - allow the -o option to nominate an alternative
!            name for the object file - compatible with a
!            driver which only passes the -o option through
!            for a command line which specifies -c
!
! 16/09/90 - checks for (and skips) 'X' after any -G option
!                                                               ftncomp54
! 12/09/90 - allow for a .for file extension
!
! 11/09/90 - for Emachine>=4, set cgoptions as appropriate if
!            profiling (-p or -pg) has been specified
!
!          - expects the driver to pass -pg as -p and hence
!            interprets -pg as -p -g (ie. profile and sdb/dbx)
!                                                               ftncomp53
! 05/09/90 - Add -P ctriads option to get triads with ecodes
!
! 31/08/90 - uses the new include file vers.inc which defines   ftncomp52
!            the compiler's Release and Reldate
!
! 16/08/90 - support -us (underscore) for m88k - compatible     ftncomp51
!            with a driver which passes -us as -us+ and -u
!            as -u
!
!          - the warning message associated with inconsistent
!            use of options is now constructed dynamically to
!            avoid drawing a user's attention to options which
!            he did not specify and which although recognised
!            may not be documented for his system. (Note -p
!            nor -pg invoke this warning, only -pl and -pt)
!
!          - moved additional DRS/SEQUENT specifics behind
!            conditional compilation
!
!          - the externalstring SRCEFILENAME has been
!            increased in size from 64 to 255 (this string
!            is read by ftnmess)
!
!          - on Emachine4 Targets, compatible with ftnprofdum1.i
!
! 15/08/90 - merge with ftncomp49.2.i                           ftncomp50.1
! 15/06/90 - merge in Sequent/386 mfcompile47t.i                ftncomp50
!
! 6/06/90 - renamed for systems which only recognise up         ftncomp49.1
!           to 16 character filenames
!
!         - support -V for parameter checking (but not if
!            targetting on Gould)
!
!         - removed support for -args
!
!         - -U no longer selects parameter checking (except
!           for Gould)
!
!         - no longer EXIT(1) after performing a syntax
!           check - otherwise the driver will report
!          'compiler error'
!
!         - relocated the check for inconsistent options
!           specified with -O (the original location was
!           after the call to Msetoptions and was therefore
!           done too late)
!
!         - for m88k Fortran: initialise Options2 to nus
!                                                           mfcompile49
!19/05/90 - support -args
!
!30/04/90 - incorporates access control from Rob            mfcompile48.15
!
!         - also no longer breaks if the compiler is
!           passed no source file
!
!17/04/90 - for Emachine>=4, added -x to unconditionally    mfcompile48.14
!           switch off instruction scheduling
!
!         - for Fortran, added private option MISALIGN
!           which is used by the Fortran compiler on
!           Risc machines to assume that longreal arguments
!           are not 8-byte aligned
!
!         - for Fortran, correct handling of the private
!           option SCAN
!
! 6/04/90 - for Fortran, added externalinteger autoflag     mfcompile48.13
!
! 1/04/90 - for Emachine>=4 and Fortran, tell Msetoptions
!           if the -g option has been specified
!
!14/03/90 - initialise Comreg (especially 26) before        mfcompile48.12
!           calling Msetoptions
!
!         - increase the size of Comreg from 50 to 60
!           because Elfput may set Comreg(59)
!
! 5/03/90 - for both: enable instruction scheduling if      mfcompile48.11
!                     any -O flag present
!
! 1/03/90 - for IMP: make CHECK a recognised long option    mfcompile48.10
!                    mark unrecognised long options in
!                       the listing
!26/02/90 - for IMP: make ARRAY the default                 mfcompile48.9
!                    recognise -P MAP (the IMP compiler
!                       will report and generate line
!                       numbers with respect to the
!                       current source or include file
!                       and not the listing file
!                    make parm OPT imply NOARRAY
!                    set x'00800000' in options passed to
!                       Msetoptions if compiling with parm
!                       CHECK - the code generator will
!                       initialise floating point traps
!                       if compiling a main program
!
!02/02/90 - for Fortran, set minimum diags preparation      mfcompile48.8
!           when calling Msetoptions if one or both of
!           Unassigned or Array Bound checking has been
!           requested, even if -d has not been specified
!
!28/01/90 - common m88k and sparc version                   mfcompile48.7
!
!24/01/90 - if host is m88k then declare and initialise     mfcompile48.6
!           the diagnostics-stopper in main()
!
!18/01/90 - for Fortran modify criterion for setting the    mfcompile48.6
!           externalinteger Comopt3 from Usechipfns=Weitek
!           to Fregopt=1 {available}. If Fregopt=1 or host=drs
!           then the interpretation of the -O option is as
!           described under mfcompile47b
!
!         - for Fortran, add a declaration for externalinteger
!           Parallelise
!
!         - for Fortran, set x'00400000' in options passed
!           to Msetoptions if the compiler is optimising
!
!05/01/90 - modify the options passed to Msetoptions (if    mfcompile48.5
!           Emachine>= 4) as follows:
!
!               IMP:     OPT     => parm NOLINE
!                        NOTRACE => no preparation for diags
!
!               FORTRAN: default => no preparation for diags
!                                   and no dynamic line numbers
!                             -d => prepare for diags and
!                                   dynamic line numbers
!
!03/01/90 - for IMP, implement -P ARRAY and interpret -C    mfcompile48.4
!           as -P ARRAY.
!
!28/11/89 - temporarily added NOARRAY to the default        mfcompile48.3
!           parameters for IMP because there currently
!           is a problem with CBOUNDCHECK (in cprocs24).
!
!27/11/89 - added more compatibility with IMP using mf18i   mfcompile48.2
!           from castle as a model - in particular:
!
!             MAXWORK and MAXDICT are the defaults: added
!             the private option MINWORK if the original
!             default is required.
!
!             the option -m sets the workfile size to 513K
!             rather than 256K.
!
!             do a select output (Stdout) before calling
!             Pgenerateobject (or Mgenerateobject) so
!             that any tracing goes into the listing file
!             and re-select Stderr on return.
!
!             for IMP hijack the -w option to inhibit
!             the verbose mode of the compiler.
!                                                           mfcompile48.1
!19/11/89 - uses the constinteger COMPILER in ftnht rather
!           than the local constinteger LANGUAGE.
!
!         - all references to comreg bar comreg(26) are
!           now under COMPILER=IMP conditional compilation.
!
!         - placed -s and -V under ALLOWVECTOR= YES.
!
!         - added private option FILEMON (and FMON).
!
!         - does not attempt to align the buffer acquired
!           from malloc on some boundary.
!
!         - updated for Emachine>= 4: in particular all
!           PUT interfaces are assumed to start with P
!           rather than M, and also:
!
!             added private option CGMON to switch on fragment
!             and instruction allocation/deallocation
!
!             added call to Msetoptions
!
!         - also merged in code from sicompile3.4 (mfcompile
!           for IMP on SPARC) which in turn was based on
!           micompile2 (mfcompile for IMP on SUN). These
!           changes are under the constinteger COMPILER=IMP
!           and the following differences may be perceived
!           if this version is used in conjunction with an
!           IMP compiler:
!
!             for private option CODE set bit x'00004000' in
!             comreg(27) - this passes the option to the
!             impcompiler
!
!             added private option NOCHECK
!
!             -L is ignored (use -G instead)
!
!           The following changes may be preceived if earlier
!           versions of mfcompile were used by the IMP
!           compiler:
!
!             used Consource from micompile2
!
!             initialise com27 to x'010A0022' rather than
!             to x'01080000'
!
!             signals are set by default (via setsigs)
!
!             no longer outputs the compilation options
!             specified and is relatively quiet about the
!             source filename. The object filename is not
!             output either
!
!             added private options BIGWORK and MAXWORK
!
!             does not attempt to align the work file
!             acquired from malloc on some boundary
!
!             does not include dummy routine for either
!             pow_ri or poweroften
!
!                                                           mfcompile48
!06/09/89 - version 48 taken for common EPC source
!         - reldate string placed in ftnht to avoid having
!           to change mfcompile source each time
{07/08/89 - modified searchpath used by SELECT INCLUDE      mfcompile47g}
{           which was incorporated into mfcompile47d.                   }
{                                                                       }
{           requires DR40 or later for the -Idir option.                }
{                                                                       }
{           instead of using $PATH if -I (by itself) was                }
{           specified, the new searchpath is:                           }
{              1/. the host directory of the file which                 }
{                  is being compiled (note that this is                 }
{                  how INCLUDE files have always been                   }
{                  searched for in EPC Fortran).                        }
{              2/. each directory specified by a -Idir                  }
{                  option (note that -I (by itself) is                  }
{                  ignored)                                             }
{              3/. normally C would, as a last resort, look             }
{                  in /usr/include - but this is considered             }
{                  NOT suitable for Fortran as it may pick              }
{                  up a C include file by mistake.                      }
{                                                                       }
{         - passes the full name of the INCLUDE file (which             }
{           was used in the successful open) to MSETFILES.              }
{           MSETFILES (in cdput8) however will currently                }
{           perform a no-op on this call.                               }
{         - removed a second (and therefore redundant) call             }
{           on Malloc to align workareas if Fortran.                    }
{29/06/89 - add optcontrols                                 mfcompile47f}
{19/04/89 - -Idir option implemented                        mfcompile47d}
{           uses dr36                                                   }
{14/12/88 - use new include files                           mfcompile47c}
{ 7/08/88 - supports the new interpretation of the -O       mfcompile47b}
{           option for the 386 which is as follows:                     }
{                                                                       }
{                -O      normal optimisation                            }
{                -O1     normal optimisation + fregvars                 }
{                -O2     normal optimisation + in-lining                }
{                -O12    normal optimisation                            }
{                 or            + fregvars                              }
{                -O3            + in-lining                             }
{                                                                       }
{           this new interpretation is currently controlled             }
{           by HOST=DRS.                                                }
{         - note this procedure requires dr22.c onwards.                }
{ 2/08/88 - includes: ftn_ioconsts                          mfcompile47a}
{                     ftn_ioparams                                      }
{                     ftn_statfmt                                       }
{                                                                       }
{           use of these includes files removes the requirement         }
{           to examine the form of the file information table           }
{           when moving to another target.                              }
{         - add externalinteger COMOPT3 to select fregvar               }
{           allocation in ftncode if using -O1: also add                }
{           private option NOFREG to switch allocation off.             }
{ 7/06/88 - remove private option NOUND.                     mfcompile47}
{         - inhibit -ff setting UseFarData.                             }
{         - merged UNISYS changes up to mfcompile42d                    }
{                                                                       }
{           these include:                                              }
{         - tidied up output of the listing file when Stdout            }
{           is different from Stderr: -the listing file gets            }
{           the source file name as well: -Stderr gets a copy           }
{           of any compilation errors.                                  }
{         - also outputs the version text before the source             }
{           file name.                                                  }
{         - re-sited position at which version text and                 }
{           source file name is output to Stderr.                       }
{         - introduce externalinteger Unasscheck to pass                }
{           to PUT.                                                     }
{                                                                       }
{         - also merged SUN3 changes up to mfcompile42.1                }
{           these include:                                              }
{                                                                       }
{         - uses the constinteger ENV in FTN_HT.                        }
{         - change "include" argument to Msetfiles as SUN3              }
{           impcompiler does not support a string value as              }
{           a string name parameter.                                    }
{         - the SUN3 compiler does not support Pcodeon or               }
{           Lineprofile.                                                }
{                                                                       }
{ NOTE:   - if hosting on other than Gould, Unix5 DRS, or               }
{           Sun3, then the format of the file information               }
{           table should be checked.                                    }
{25/05/88 - spell analyzed the American way                  mfcompile46}
{         - -i2 equivalent to -I2                                       }
{         - when checking line length check for tab                     }
{15/05/88 - Include files to be in source dir (from 43.1)    mfcompile45}
{18/04/88 - replace private option fuse by nofuse            mfcompile44}
{16/04/88 - make source file name visible                    mfcompile43}
{25/03/88 - provide alternative file info format for DRS     mfcompile42}
{         - -nbs to set bslashnatural                                   }
{17/03/88 - support -P Ov (optimise vectors)                 mfcompile41}
{11/03/88 - set Opt2max for max inline subroutine size       mfcompile40}
{         - support -P newbr                                            }
{06/03/88 - support -72 and add param to Sourceline          mfcompile39}
{29/02/88 - generalised for 386 etc.                                    }
{         - -f adequate for freeformat if not Gould                     }
{         - assume 132 char buffer                                      }
{         - replace fuse,fusex by fuseall,fuse,fuselist                 }
{24/02/88 - Checknus will always be called from gput for cmn mfcompile38}
{23/02/88 - support -nus[file] and -P div; add Ckecknus      mfcompile37}
{19/02/88 - Replace fuseloops by fuse and fusex                         }
{14/01/88 - version 1.1                                      mfcompile36}
{23/12/87 - Support -P fuseloops                             mfcompile35}
{         - -P code now gives private listing
{17/12/87 - -O now equivalent to -O1                         mfcompile34}
{11/12/87 - Copyright to screen                              mfcompile32}

{09/12/87 - Support -sr and -se                              mfcompile31}
{18/11/87 - Support -P minvect                               mfcompile30}
{09/11/87 - -q means no output                               mfcompile29}
{                                                            mfcompile28}
{05/11/87 - change depcheck to nodepcheck                               }
{                                                            mfcompile27}
{15/10/87 - support for -ff,-bs,-be,-bm,-bu , X after G,any digit string}
{22/08/87 - add support for -nv to inhibit vectors}

    { Compilation Control routine for PNX }
    { Begun 14/oct/83 - Alan              }
    { Revised 30/dec/83   }
    { rel 1.2 12/dec/84 accept -N(dltb)  compile2}
    { rel 1.3 17/dec/84 accept -N(dltba)  compile3}
    { rel 1.6 20/feb/84 fix include non-existant file compile4 }
    {                   -i => -A; -r => -v }
    { rel1.1(G)  delete objectfile if compilation fails }
    { rel1.1(K) -A => -q }
    { rel1.2(A) forbid diagnostic options with optimising ones - compile7 }
    { rel1.2(B) Add routine DeleteObjectFile - compile8  15/Oct/85}
    { rel1.2(C) Check local filename length < 14 chars. compile9.i 9/dec/85}
    { alter for 680020 Fortran by using fort77 and P -> M }
    { rel0.1    Check -P text for UNSET before calling SetSigs. This is a }
    {           consequence of ditching FORTENTRY in favour of /lib/crt0.o}
    {           Control is received by routine COMPILE aliased to "main"  }
    {                                                            (Driver7)}
    { rel0.2    -L becomes -G (use Driver8 for compatibility)           }
    {           by default no signal traps are set; use of '-P set' will}
    {              set the traps    (MFCOMPILE6)                        }

    { 28/7/86  Unite Fortran and Imp control routines - Alan  }
    { 2/9/86  Amended compiler flags for Gould. - Alan }
    { 14/09/86 modified header and set Options2 for Inclusion/Exclusion - Geoff}
    { 30/9/86 Modified version text and stdout for -S - alan }
    { 14/Oct/86 Vsn 17 Set options2 on -f flag - alan }
    { 31/Oct/86 Vsn 17 Take + as -W terminator - alan }
    { 4/Nov/86 Vsn 17a DO not open object if -y option set  - alan }
    { 5/Nov/86         Fix check for opt and diag together. }
    {                  Remove check on file length. - alan }
    { 17/4/87 Vsn 18 Put in release identifier }
    { 23/4/87 Vsn 19 Put in name table size -Nx }
    { 29/5/87 vsn 20 Support -P depanal - graham }
    { 02/7/87 vsn 22 Support -P depcheck - geoff }
    { 22/7/87 vsn 23 recode resolution of long names - geoff }
    {                ignore -g to avoid loader failure - geoff }
    { 11/08/87 vsn 24 support -P prof }
    { 05/10/87 vsn 26 accept -Ws,lines }

%include "ftnht.inc"
%include "vers.inc"
%include "protection.inc"

%constinteger YES = 1
%constinteger NO  = 0

%if Object Format = ISCOFF %start
  %include "coff.inc"
%finishelsestart
  %constinteger ADI Shared Commons = NO
%finish

%if Compiler= Fortran %thenstart

   %externalinteger optcontrols  {enable suppression of opt features}
                                 { 1 no fregs in inner loops }
                                 { 2 limit loop init (sred)  }
                                 { 4 movement of TEMPs       }
                                 {16 no loop unrolling       }
   %externalinteger quiet        { suppresses passive compiler output }
   %externalinteger Comopt3      { set if non-interference             }
   %externalinteger recipopt     { set if compile-time reciprocate ia allowed}
   %externalinteger Autoflag
   %externalinteger hardoptions
   %externalinteger misalignedreals=0
   %externalinteger Opt2max=0
   %externalinteger ctriads

   %if Host= DRS %and Env= Sequent %thenstart
      %externalinteger ATSfort=0
   %finish

   %if Allowparallel# 0 %thenstart
      %externalinteger Paralleloptions=0
      %externalstring(31) %array Unshcom(1:127)
      %externalinteger Nunshcom = 0
   %finish

   %externalinteger Parallelise=0
   %externalinteger Profiler=0
   %externalinteger Lineprofiler=0
   %externalinteger Timeprofiler=0

   %externalintegerspec Inhib8X
   %externalstring(255) Srcefilename

   %externalinteger superscalar = 1  
   %externalinteger G2traceMOO = 0  
%finish

%externalinteger Xoptimiseoptions = 0  {referenced b Fortran optimiser}
%externalinteger Poptimiseoptions = 0

%externalinteger Unasscheck   { referenced by PUT}

%if Target = Sparc %thenstart
   %externalinteger Sparcfsqrt = 0
%finish

%if Host=M88000 %start
   %externalroutinespec disabletraps
%finish
%if HOST=DRS %thenstart
   %externalroutinespec Esourcefile(%string(255) %name src)
   %if Usechipfns=Weitek %and Env=Sequent %thenstart
      %externalroutinespec Set Weitek Flags
   %finish
%finish

%if Host# Sun3 %or Env= GOULD %thenstart

   %if Emachine>= 4 %thenstart
      %externalroutinespec Mcodeon
   %finishelsestart
      %externalroutinespec Pcodeon
   %finish

   %if Compiler= Fortran %thenstart

      %externalintegerspec lineprofile
      %externalinteger f77plus=0    { set by -f77+ option. Turns on 77+ extensions}
   %finish
%finish


%if Compiler= Fortran %and (Host# GOULD %or Opsys# MPX) %thenstart

   %externalintegerfnspec Compstream (%integer fildes1, fildes2)
%finish


%if Emachine>= 4 %thenstart

   %externalroutinespec   Pfaulty
   %externalroutinespec   Pmonon
   %externalroutinespec   Emonon
   %externalroutinespec   Set Sigs
   %externalroutinespec   Phex(%integer n)
   %externalroutinespec   Pgenerate Object(%stringname s)
   %externalroutinespec   Psetfiles(%string(255) %name src,obj,%integer syntax)
   %externalroutinespec   Msetoptions(%integer options) {generator control}
   %externalroutinespec   Esetoptions(%integer cgoptions,botraceoptions, %c
                            boinhiboptions,proc,fraglow,fraghigh)
   %externalroutinespec   EsetGISoptions(%integer buffzone,fullopt,trace, %c
                            inhib,rangeregion)
   %externalroutinespec   Cstring %alias "s_cstring" (%string(*) %name Impstr, %integer adCstr)
%finishelsestart

   %externalinteger       Msetoptions
   %externalroutinespec   Mfaulty
   %externalroutinespec   Mmonon
   %externalroutinespec   Emonon
   %externalroutinespec   Set Sigs
   %externalroutinespec   Phex(%integer n)
   %externalroutinespec   Mgenerate Object(%stringname s)
   %externalroutinespec   Msetfiles(%string(255) %name src,obj,%integer syntax)
   %externalroutinespec   Cstring(%string(*) %name Impstr, %integer adCstr)
%finish


%if Compiler= IMP %and Host= Sun3 %thenstart

   %externalintegerspec   SaveRegs { flag used by mgen and mcode to genearate}
                                   { code for saving d2-d7,a2-a5 for sun 3   }
                                   { when invoked by -P regsav               }
%finish


%if Compiler= Fortran %Start
   %externalintegerfnspec FORT77(%integer Control,options1,options2,
                                           F77parm,optflags,srcflags,
                                           Console,Liststream,Diagstream,
                                           Diagnostic level,Dsize,Tsize,
                                           Bsize,Lsize,Asize,Nsize)
   %recordformat Optfilesfmt(%integer inaddr,inlen,exaddr,exlen,nusaddr,nuslen)
   %externalrecord(Optfilesfmt) Optfiles
   %if Protection=FLEXLM %start        {Highland's licence server}
      %externalintegerfnspec getlicense %alias "get_license" %c
                                           (%integer adfeaturename)
      %ownstring(6) featurename="EPCF77"
   %finishelseif Protection=ALF %start {ADI's licence server}
      %if Env=Gould %start
         %externalintegerfnspec getadilicense %alias "adi_get_gould_f77_license"
         %externalroutinespec freeadilicense %alias "adi_free_gould_f77_license"
      %finishelsestart
         %externalintegerfnspec getadilicense %alias "adi_get_f77_license"
         %externalroutinespec freeadilicense %alias "adi_free_f77_license"
      %finish
   %finishelsestart                      {EPC timebomb}
      %externalintegerfnspec accesscontrol %alias "access_control_" %c
                             (%integer adproducttag, adproductname)
      %ownstring(5) producttag="F77"
      %ownstring(6) productname="EPCF77"
   %finish

%finishelsestart

    %if Target= SPARC %or Target= rs6000 %or Target=MIPS %thenstart
       %externalroutinespec IMPCOMPILER %alias "icl9cezrs6imp"
    %finishelsestart
       %externalroutinespec IMPCOMPILER %alias "icl9cezgouldimp"
    %finish
%finish



%externalstring(15) %fnspec Itos    (%integer n)

%externalroutinespec   EXIT   (%integer Process return code) { Sys call }
%externalintegerfnspec Open   (%integer adname,mode)         { Sys Call }
%externalroutinespec   LSeek  (%integer id,offset,whence)    { Sys Call }
%externalintegerfnspec Read   (%integer id,bytead,bytesize)  { Sys Call }
%externalroutinespec   Close  (%integer id)                  { Sys Call }
%externalintegerfnspec Unlink (%integer bytead)              { Sys Call }
%externalintegerfnspec Malloc%alias "getspace" (%integer bytesize) { C Library via interface}
%externalroutinespec   Free   (%integer bytead)              { C Library }

%externalintegerfnspec Getfstat %alias "s_getfstat" (%integer id,bufad)


%if Compiler= IMP %or (Host= GOULD %and Opsys= MPX) %thenstart

   %externalintegerfnspec IsaTTY(%integer id)                { C library }
%finish


%if Compiler= IMP %Start
   %recordformat EmasFileHeaderformat(%integer dataend,
                                               datastart,
                                               filesize,
                                               filetype,
                                               sum,
                                               datetime,
                                               lda,
                                               ofm)
%finish

%include "fstatfmt.inc"



%if Compiler= Fortran %thenstart

   %routinespec  InitialiseSource
 
   %constinteger bufsize=4096
   %owninteger   bufad
   %owninteger   PrimarySrcID
   %owninteger   warnlinelen = 0
%finish


%if Compiler= IMP %thenstart

   %owninteger      srclink=0
   %owninteger      workad
   %externalinteger SrcId
   %owninteger      Srcsize
%finish


%if Emachine>= 4 %thenstart

   %externalinteger TargetVariant=0
   %owninteger cgoptions
   !*
   %constinteger cgreport    = x'00000001'
   %constinteger cgcodelist  = x'00000002'
   %constinteger cgschedmon  = x'00000004'
   %constinteger cgparamsind = x'00000008'
   %constinteger cgpeepmon   = x'00000010'
   %constinteger cgglobsched = x'00000100'
   %constinteger cgleafopt   = x'00000200'
   %constinteger cgpeepopt   = x'00000400'
   %constinteger cgprofile   = x'00010000'
   %constinteger cgsetdbx    = x'00020000'
   %constinteger cgdiags     = x'00040000'
   %constinteger cglinenos   = x'00080000'
   %constinteger cglinetab   = x'00100000'
   %constinteger cgtrapovf   = x'00200000'
   %constinteger cgregvaropt = x'00400000'
   %constinteger cgFPUtraps  = x'00800000'
   %constinteger cgschedule  = x'01000000'
   %constinteger cgargchecks = x'02000000'
   %constinteger cgRTcodelist= x'04000000'
   %constinteger cglineprof  = x'20000000'
   %constinteger cgcasesense = x'40000000'
   %constinteger notcgglob   = x'FFFFFEFF'
   %constinteger notcgleaf   = x'FFFFFDFF'
   %constinteger notcgpeep   = x'FFFFFBFF'
   %constinteger notcgsched  = x'FEFFFFFF'
   %if Target#RS6000 %start
      %constinteger cgsmallPIC  = x'08000000'
      %constinteger cglargePIC  = x'10000000'
   %finishelsestart
      %constinteger cgrndsngl   = x'08000000'
      %constinteger cghssngl    = x'10000000'
      %constinteger cghsflt     = x'40000000'
   %finish

   %owninteger botraceoptions = 0
   %owninteger boinhiboptions = 0
   %owninteger gisproc        = 0
   %owninteger gisfraglow     = 0
   %owninteger gisfraghigh    = 0
   %owninteger gisbuffzone    = 0
   %owninteger gisfullopt     = 0
   %owninteger gistrace       = 0
   %owninteger gisinhib       = 0
   %owninteger rangeregion    = -1
%finish


%constinteger        READING = 0
%owninteger          syntaxcheck=0
%owninteger          monopt = 0
%owninteger          mmon = 0
%ownbyteintegerarray Cstr(0:255)
%owninteger        adCstr
%ownstring(255)      IncludeDir
%ownstring(255)      IncludePath {a concatenation of all the directories}
                                 {specified by any -Idir options        }


%externalintegermap Comreg(%integer n)
  %ownintegerarray C(0:60)
  %result == C(n)
%end
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!


  %constinteger Stdin  = 0,
                Stdout = 1,
                Stderr = 2

  %constinteger            active = x'80000000', { Possible values of F77PARM}
                          depanal = x'40000000',
                              sdb = x'10000000',
                               I2 = x'08000000',
                         Optriads = x'04000000',
                           Triads = x'02000000',
                             Maps = x'01000000',
                        NoWarnlen = x'00002000',
                         NoWarn77 = x'00001000',
                          Onetrip = x'00000800',
                              F77 = x'00000400',
                          Vaxflag = x'00000200',
                             Unix = x'00000100',
                           Strict = x'00000080',
                      No Warnings = x'00000040',
                      No Comments = x'00000020',
                          NoBound = x'00000010',
                         MinBound =          8,
                          NoUnass =          4,
                            Noarg =          2,
                           NoChar =          1

  %constinteger              Xref = x'00000800', { Possible values of CONTROL}
                             Code = x'00004000',
                             Attr = x'00008000',
                           NoList = x'00000002'

  %constinteger          Listnone = x'00000800', { Possible values of Options1 }
                             Opt3 = x'00400000',
                             Opt2 = x'00200000',
                             Opt1 = x'00100000',
                          Maxdict = x'00000100',
                           NoCode = x'00000020',
                           Optext = x'00000010'


%constinteger           Dline  = x'00000001',   { Possible values of Options2 }
                        Xline  = x'00000002',
                        Yline  = x'00000004',
                        R8     = x'00000008',
                 List Includes = x'00000010',
                     Profile   = x'00000020',
                     Noerrors  = x'00000040',
                     Vectorise = x'00000080',
                    Inclusions = x'00000100',
                    Exclusions = x'00000200',
                    UseFarData = x'00000400',
                  Nounderscore = x'00000800',
                    nodepcheck = x'00001000',
                       fuseall = x'00002000',
                        nofuse = x'00004000',
                      fuselist = x'00008000',
                 bslashnatural = x'00010000',
                  optionalargs = x'00020000',
                    freeformat = x'00040000',
                      sroption = x'00080000',
                      seoption = x'00100000',
                           nus = x'00200000',
                       nusfile = x'00400000',
                optimisevector = x'00800000',
                      csoption = x'01000000'


%constinteger           divset = x'00000001'    {Possible values of hardoptions}
%constinteger           newbr  = x'00000002'   



                                  { FORT77 flags }
  %owninteger F77parm   = active!Vaxflag!Unix!NoUnass!Noarg!NoChar!NoBound
  %owninteger control   = NoList
  %owninteger options1  = 0
  %if Target= M88000 %or Target=RS6000 %thenstart
     %owninteger options2= nus                     {for 88OPEN conformance}
                                                   {or ibm compatibility  }
  %finishelsestart
     %owninteger options2= 0
  %finish
  %owninteger srcflags  = 0
  %owninteger optflags  = 0


%constinteger           quotes = x'00000001' , {possible values for Comreg(27)}
                       {NoList = x'00000002'}     {same as for CONTROL}
                        NoDiag = x'00000004' ,
                        iStack = x'00000008' ,
                       NoCheck = x'00000010' ,
                       NoArray = x'00000020' ,
                       NoTrace = x'00000040' ,
                      iProfile = x'00000080' ,
                       NoRange = x'00000100' ,
                      inhibiof = x'00000200' ,
                          zero = x'00000400' ,
                         {xref = x'00000800'}     {same as for CONTROL}
                        labels = x'00001000' ,
                           let = x'00002000' ,
                         {code = x'00004000'}     {same as for CONTROL}
                         {attr = x'00008000'}     {same as for CONTROL}
                           opt = x'00010000' ,
                          iMap = x'00020000' ,
                         debug = x'00040000' ,
                         iFree = x'00080000' ,
                       dynamic = x'00100000' ,
              {diag stream set = x'00200000'} 
                        ebcdic = x'00400000' ,
                        NoLine = x'00800000' ,
               {stack size set = x'01000000'}
                        NoMain = x'02000000' ,
                         parmz = x'04000000' ,
                         parmy = x'08000000' ,
                         parmx = x'10000000' ,
                      mismatch = x'20000000'
                     {not used = x'40000000'}
                     {not used = x'80000000'}


%if Compiler= Fortran %thenstart

   %owninteger dsize = 0
   %owninteger tsize = 0
   %owninteger lsize = 0
   %owninteger bsize = 0
   %owninteger asize = 0
   %owninteger nsize = 0

   %owninteger      Diagnostic level = -1 { no diagnostics is default }
   %externalinteger minvect= 4            {minimum array extent for vector code}

   %owninteger dup output = 0  {set if info on Stdout is to be copied on Stderr}
   %if Target=RS6000 %start
      %owninteger nohsflt      {set to 1 if user specifies -qnohsflt}
   %finish
%finish


   %owninteger Liststream = Stdout
   %owninteger Diagstream = Stderr

   %owninteger consolestream = 0{STDERR}



%routine Abort (%string(31) error, %string(255) extra info)
!***************************************************************************
!* Reports an error message and then exit(1)'s - if extra info#"" then it  *
!* too will be included in the error message                               *
!***************************************************************************
      newline
      printstring ("***")
      printstring (error)
      printstring (extra info) %if extra info#""
      newline
      exit(1)
%end;! Abort
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!


%if Compiler= Imp %thenstart 

%externalroutine ConSource(%string(255)filename, %integername filead)
!***************************************************************************
!* Connect source-file. Historically this derives from EMAS where the file *
!* is mapped onto virtual memory. On UNIX systems two alternatives exits:  *
!* either the file is read into a large buffer whose address is returned   *
!* via FileAd, or the file is simply opened and reading conducted on a     *
!* block-by-block basis. In this case, FileAd is preset to -1.             *
!***************************************************************************
%byteintegerarray Cstr(0:255)
%integer adCstr,i
%record(Emasfileheaderformat) %name  Hdr
%record(stat information table) Fid

  adcstr = addr(cstr(0)){*2}
  Cstring(filename,adcstr)                  { Get source filename in C format}
  SrcId = Open(adcstr,READING)              { Open source file}
  %if monopt # 0 %then printstring("
SrcID = ") %and write(SRcId,4)
  %if Srcid=3 %then SrcID = Open(adcstr,READING)     { Open source file}
!  THIS IS JUST TILL WE GET AN OBJECT GENERATOR GOING - SRC MUST BE 4
  %if Srcid=-1 %then printstring("
Cannot open source file ") %and ->crunch
  i = Getfstat(Srcid,addr(Fid))             { Request info. about source}
  Srcsize = Fid_filesize                    { Find out its size}
  %if Srcsize=0 %then printstring("
Empty file - ") %and ->crunch
  %if i=0 %start                            { If ok so far}
    %if monopt#0 %then printstring("
claiming source buffer of ") %and phex(Srcsize+32)
    filead = malloc(Srcsize+32){//2}        { Grab global space for source }
    %if monopt#0 %then printstring(" at ") %and phex(filead) %and newline
  %finishelse   printstring("
Cannot get status on source ") %c           { otherwise abort }
    %and ->crunch
  %if filead=0 %start                       { abort if failed to get space }
    printstring("
Malloc source buffer fails ")
    %monitor;  ->crunch
  %finish
  %if monopt#0 %then printstring("
file size = ") %and write(Srcsize,1)
  i = READ(SrcID,(filead{*2})+32,Srcsize)   { Read source file into global }
  CLOSE(SrcID)                              { close file }
  Hdr == record(filead)                     { produce a pseudo emas header}
  Hdr = 0
  Hdr_datastart = 32
  Hdr_dataend   = 32 + Srcsize
  Hdr_ofm = srclink                         { use spare field in hdr to  }
  srclink = filead                          { chain source areas together }
  %return

crunch: printstring(filename)
        %stop
%end;! ConSource
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!
%finish; !if IMP


%externalroutine FreeSourceAreas
!***************************************************************************
!* This routine is called at the end of pass 1 to free source buffers.     *
!***************************************************************************
  %if Compiler = Imp %start
     %cycle
        FREE(srclink)
        srclink = integer(srclink+28)
     %repeat %until srclink=0
  %finish
%end;! FreeSourceAreas
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!


%if Compiler= Fortran %thenstart

   %routine printvers
         printstring(F77version)
         printstring(F77copyright text)
         newline
   %end;! printvers
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!


%routine Output (%stringname text)

   {This procedure prints the parameter on  }
   {Stderr. If DUP OUTPUT is not set to zero}
   {the text will also be printed on Stdout }
   {It assumes that Stderr is the currently }
   {selected output stream                  }

    print string (text)

   %if dup output# 0 %thenstart
       select output (Stdout)
        print string (text)
       select output (Stderr)
      %finish
%end;! Output
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!
%finish; !if Fortran



%routine Prepare (%integer argc, argv)
!***************************************************************************
!* Prepare compiler options from the argument strings collected by the     *
!* compiler driver. argc is the number of arguments on the shell statement *
!* argv is a pointer to an array of string pointers specifying the argum-  *
!* ents as null-terminated strings.                                        *
!***************************************************************************

%integerfnspec readn
%integerfnspec readbv
%routinespec readnn(%integername val1,val2)

  %ownbyteintegerarrayformat argfm(1:1000)
  %ownbyteintegerarrayname args
  %ownintegerarrayformat argptrfm(1:100)
  %ownintegerarrayname  argptr
  %integer argument
  %integer i,vptr,c,ptr,invalid
  %string(254) source,s,object,root
  %integer table
  %integer slen
  %integer setsigs flag   {set to 1 if signal traps are to be set}
                          {set to 0 otherwise                    }

  %owninteger com26= 0
  %if ADI Shared Commons=YES %start
     %externalroutinespec shcom list set up(%string(32)  common)
     %byteintegername    new shcom byte
     %string(32)  new shcom      {temp for -SC option}
  %finish

  %if Compiler= IMP %thenstart
     %record(Emasfileheaderformat) %name  Hdr

     %owninteger workK = 2047
     %owninteger srcad
     %owninteger com27= x'01000000' {stack size set} ! iFree ! NoList
     %owninteger com28 = 0
     %owninteger com23 = -1
     %owninteger com40 = Stderr
     %owninteger noisy = 1

     %stringname params {mapped onto Cstr while processing private options}

  %finish


  %if Compiler= Fortran %thenstart
     %record(stat information table) Fid

     %integer    filead
     %integer    type
     %integer    ID
     %integer    size
     %integer    x
     %ownstring(5) producttag="F77"
     %ownstring(6) productname="EPCF77"
     %ownstring(80)  Warning 1 Text= ""
     %conststring(4) %array Warning 1 Option (1:7)= " -d" , " -U" , " -V" ,
                                                    " -C" , " -g" , " -pl",
                                                    " -pt"
                           {the above order is dependent upon the order in}
                           {which Prepare looks for inconsistent options  }
     %integer    Warning 1 flag
  %finish


%if Compiler= IMP %thenstart

   comreg(40) = 2  { Imp error stream }
   setsigs flag= 1 { set signals after processing any options/switches}
%finishelsestart

   size= 0
   setsigs flag= 0 { dont set signals}
%finish

  argptr == array(argv,argptrfm)
  argument = 1

  adcstr = addr(Cstr(0))

  Includepath = ""
  object = ""      { not explicitly specified }

{---------------------------------------------------------------------------}
{ ********* Analyse Streams specified }

     { If list or diag stream is not tied to console: , tell compiler }
     {  with a negative number. Otherwise set positive }

%if Compiler= IMP %or (Host= GOULD %and Opsys= MPX) %thenstart
   %if IsaTTY(Stdout)#1 %then Liststream = - Stdout
   %unless Diagstream=0 %start
      %if IsaTTY(Stderr)#1 %then Diagstream = - Stderr
   %finish
%finishelse %if Compstream (Stdout,Stderr)= 0 %then Liststream= - Stdout 

   select output (stderr)  { All status messages to go to STDERR}
%if Compiler= Fortran %Start
   printvers
   %if Protection=FLEXLM %start
      i = getlicense(addr(featurename))
   %finishelseif Protection=ALF %start
      i = getadilicense
   %finishelsestart
      i = access control(addr(producttag), addr(productname))
   %finish
   %if i#0 %then EXIT(1)
%finish

{---------------------------------------------------------------------------}
{ *********** Options following - are second parameter }
{             Standard UNIX single letter options      }

 %if argc < 2 %start { No command line arguments }
   EXIT(0)
 %finish

 %cycle
  args == array(argptr(argument+1),argfm)
  %if args(1)='-' %start
    argument = argument+1
    vptr = 2   { discard '-' }
     %cycle
      c = args(vptr)
      %exit %if c = 0

      %ifc

 c = '1' %start
         %if Compiler= Fortran %thenstart
             %if args(vptr+1)='3' %and args(vptr+2)='2' %start  { - 132 }
                Options2 = Options2 ! freeformat
                warnlinelen = 132
                vptr = vptr+2
             %finishelsestart  { ONETRIP every DO loop to exec at least once }
                F77parm = F77parm!Onetrip
             %finish
         %finish
         %finishelseifc

 c = 'C' %start                                      { array bound checks on }
         %if args(vptr+1)='S' %thenstart    {-CS case sensitivity on}
            %if Compiler=Fortran %thenstart
               options2=options2!csoption
               vptr = vptr + 1
            %finish
         %finishelsestart                   { array bound checks on }
            %if Compiler= IMP %thenstart
               com27 = com27&(\NoArray)
            %finishelsestart
               F77parm = (F77parm!MinBound)&(\NoChar)
            %finish
         %finish
         %finish %elseifc

 c = 'g' %start                                       {SDB flag or gis buff  }
             %if args(vptr+1)='i' %thenstart          {-gisbuff=             }
                vptr = vptr + 7
                i = 0
                %cycle
                   c = args(vptr+1)                   {get digits}
                   %exit %unless '0' <= c <= '9'
                   i = (i*10) + (c - '0')
                   vptr = vptr+1
                %repeat
                %if c = '+' %then vptr = vptr + 1
                gisbuffzone=i                          {set value}
              %finishelsestart                         {-g}
                F77parm = F77parm!sdb
                com26 = com26!4 { tell PUT }
                cgoptions = cgoptions & (\cgschedule)  {scheduling off}
              %finish 
         %finish %elseifc

 c = 'G' %start                                                 {Listing reqd}
         c = args(vptr+1)
         %if Compiler= IMP %thenstart
            com27 = com27&(\NoList)
         %finishelsestart
            Control = Control&(\NoList)              
            %if c='1' %or c='2' %start  
               %if c='1' %then Options2=Options2!ListIncludes { and list include files }
               %if c='2' %then Options1=Options1! Optext      { and show code movement by optimiser }
               vptr=vptr+1
               c = args(vptr+1)
            %finish
         %finish
         %if c='X' %then vptr=vptr+1
         %finishelseifc

 c = 'u' %thenstart
         %if args(vptr+1)= 's' %and args(vptr+2)= '+' %thenstart { -underscore }
            options2 = options2 & (~nus)
            vptr     = vptr + 2
         %finishelsestart
            F77parm = F77parm!x'4000'                            { type=undef  }
         %finish
         %finishelseifc

 c = 'w' %start                              { suppress warnings and comments}
         %if Compiler= IMP %thenstart
            noisy= 0
         %finishelsestart
            %if args(vptr+1)='7' %start  { suppress F77 warnings }
               F77parm = F77parm!NoWarn77 
               vptr=vptr+2  { pass over  '77' }
               %finishelse F77parm = F77parm!No Warnings!No Comments!NoWarn77
         %finish
         %finishelseifc
 c = 'x' %start
         %if Emachine>= 4 %thenstart
            cgoptions = cgoptions & (\cgschedule) { -x used }
         %finish
         %finishelseifc
 c = 'y' %start                                                { syntax check}
                Options1 = Options1!NoCode 
                syntaxcheck=1
                %if Compiler= IMP %thenstart
                   %if Emachine>= 4 %then Pfaulty                            %c
                                    %else Mfaulty
                %finish
         %finishelseifc

 c = 'p' %start                              { generate profile information }
                                             { position independent code    }
         %if args(vptr+1)='i' %and args(vptr+2)='c' %and                     %c
             args(vptr+3)='+' %thenstart
            %if Emachine= 4 %and Target#RS6000 %thenstart
               vptr=vptr+2
               cgoptions= cgoptions ! cgsmallPIC
            %finishelsestart

            %finish
         %finishelsestart
            %if args(vptr+1)='l' %thenstart
                %if Emachine= 4 %thenstart
                   cgoptions= cgoptions ! cglineprof
                %finish
                %if Target# SPARC %and Compiler= Fortran %then Lineprofiler = 1
                vptr=vptr+1
            %finishelsestart
               %if args(vptr+1)='t' %thenstart
                  %if Compiler= Fortran %then Timeprofiler = 1
                  vptr=vptr+1
               %finishelsestart
                  %if Compiler= Fortran %then Profiler = 1
                  Options2 = Options2 ! profile              
                  %if Emachine >=4 %thenstart
                     cgoptions= cgoptions!cgprofile
                  %finish
               %finish
            %finish
         %finish
         %finishelseifc

 c = 'P' %start                     {position independent code - large model}
         %if args(vptr+1)='I' %and args(vptr+2)='C' %and                     %c
             args(vptr+3)='+' %thenstart
            %if Emachine= 4 %and Target#RS6000 %thenstart
               vptr=vptr+2
               cgoptions= cgoptions ! cglargePIC
            %finishelsestart

            %finish
         %finish
         %finishelseifc

 c = 'q' %thenstart
            %if Target=RS6000 %start
               %if args(vptr+1)='n' %and  args(vptr+2)='o' %start
                  %if args(vptr+3)='c' %and args(vptr+4)='h' %start
                     cgoptions=cgoptions & (~cgtrapovf)        {-qnochkof}
                     vptr=vptr+7
                  %finishelseif args(vptr+3)='r' %and args(vptr+4)='n' %andc
                      args(vptr+5)='d' %start                 {-qnorndsngl}
                        cgoptions=cgoptions & (~cgrndsngl)
                        vptr=vptr+9
                  %finishelseif args(vptr+3)='h' %and args(vptr+4)='s' %start
                     %if args(vptr+5)='s' %start              {-qnohssngl}
                        cgoptions=cgoptions & (~cghssngl)
                        vptr=vptr+8
                     %finishelseif args(vptr+5)='f' %start        {-qnohsflt}
                        cgoptions=cgoptions & (~cghsflt)      
                        nohsflt=1
                        vptr=vptr+7
                     %finish
                  %finish
                %finishelseif args(vptr+1)='c' %and args(vptr+2)='h' %start
                   cgoptions=cgoptions ! cgtrapovf             {-qchkof}
                   vptr=vptr+5
                %finishelse %if args(vptr+1)='r' %and args(vptr+2)='n' %andc
                      args(vptr+3)='d' %start                 {-qrndsngl}
                        cgoptions=cgoptions ! cgrndsngl
                        vptr=vptr+7
                %finishelseif args(vptr+1)='h' %and args(vptr+2)='s' %start
                     %if args(vptr+3)='s' %start              {-qhssngl}
                        cgoptions=cgoptions ! cghssngl
                        vptr=vptr+6
                     %finishelseif args(vptr+3)='f' %start    {-qhsflt}
                        cgoptions=cgoptions ! cghsflt     
                        vptr=vptr+5
                        nohsflt=0
                     %finish
                %finishelsestart
                    Consolestream = 0 
                %finish 
             %finishelsestart
                Consolestream = 0 
             %finish
         %finishelseifc
 c = 'S' %thenstart                              {list of shared commons}
          %if (ADI Shared commons=YES) %and (args(vptr+1) = 'C') %start
            vptr=vptr+1
            %while args(vptr) # '+' %cycle
               vptr=vptr+1
               i=0
               %while (args(vptr+i) # ',') %and (args(vptr+i) # '+') %and i<32 %cycle
                  new shcom byte == byteinteger(addr(new shcom) + i + 1)
                  new shcom byte = args(vptr+i)
                  i=i+1
               %repeat
               new shcom byte == byteinteger(addr(new shcom))
               new shcom byte = i {set up length}
               vptr=vptr+i
               shcom list set up(new shcom) {pass as string}
               %while (args(vptr) # ',') %and (args(vptr) # '+') %cycle
                  vptr=vptr+1
               %repeat
            %repeat
          %finishelsestart
                Control = Control!code
                %if Emachine>= 4 %thenstart
                   cgoptions=cgoptions!cgcodelist
                %finishelsestart
                   %if Compiler= IMP %thenstart
                      com27 = com27 ! code
                   %finish
                %finish
          %finish
         %finishelseifc

 c = 'a' %start                                               { xref listing } 
              %if Compiler= Fortran                      %andc
                  args(vptr+1)='u' %and args(vptr+2)='t' %andc
                  args(vptr+3)='o'                       %thenstart {automatic}
                    Autoflag=1 
                    vptr=vptr+3
              %finishelsestart
                 %if Compiler= Fortran           %andc
                     Host= DRS %and Env= Sequent %thenstart
                    %if args(vptr+1)='t' %and args(vptr+2)='s' %thenstart {ats}
                       ATSfort=1 
                       vptr=vptr+2
                    %finishelse Control = Control!xref!attr                   
                 %finishelse Control = Control!xref!attr                   
              %finish
         %finishelseifc

 c = 'U' %thenstart                                 { unassigned checking on }
                %if Target= Gould %thenstart
                   F77parm = F77parm&(\(NoUnass!Noarg))
                %finishelsestart
                   F77parm = F77parm&(\NoUnass)
                %finish
                Unasscheck=1
         %finishelseifc

 c = 'O' %start                                               { optimisation }
                cgoptions = cgoptions ! cgschedule ! cgpeepopt ! cgleafopt
                %if Compiler = IMP %start
                  com27 = com27!opt
                %finishelsestart
                              { enable instr scheduling}
                 %if args(vptr+1)='X' %start  { default case - just -O }
                   Options1=Options1!opt1
                   vptr=vptr+1
                 %finishelsestart
                     Options1=Options1!opt1 %if Host=drs %or Fregopt=1
                    %cycle 
                       vptr=vptr+1
                       c=args(vptr)
                       %exit %if c='X'
                       %if c='1' %thenstart
                          Options1=Options1!opt1 %if Host#drs %and Fregopt=0
                          Comopt3 =1 %if Fregopt=1 {available}
                           cgoptions=cgoptions!cgparamsind
                       %finishelsestart
                          %if c='2' %then Options1=Options1!opt2
                          %if c='3' %thenstart
                             recipopt=1 {compile-time invert}
                          %finish
                          %if c='4' %or c='5' %thenstart
                             cgoptions = cgoptions ! cgglobsched
                             %if c='5' %then gisfullopt = 1
                          %finish
                       %finish
                    %repeat
                 %finish
                  
                %finish
                  %finishelseifc
 c = 'D' %start                              { Conditional compilation markers }
         %if Compiler= Fortran %thenstart
               vptr = vptr + 1
               c = args(vptr)
              %if c='D' %then Options2 = Options2 ! Dline
              %if c='X' %then Options2 = Options2 ! Xline
              %if c='Y' %then Options2 = Options2 ! Yline
         %finish
        %finishelseifc
 c = 'n' %start                                  
         %if Compiler= Fortran %thenstart
               vptr = vptr + 1
               c = args(vptr)
               %if c='b' %thenstart
                  vptr = vptr + 1
                  c = args(vptr)
                  %if c='s' %thenstart
                     Options2 = Options2 ! bslashnatural
                  %finish
                  ->continue
               %finish
               %if c='v' %then Inhib8X=1
               %if c='u' %thenstart
                  vptr = vptr + 1
                  c = args(vptr)
                  %if c='s' %thenstart;! nus
                     Options2=Options2!nus
                     vptr = vptr + 1 
                     %if args(vptr)='+' %then ->continue
                     s = ""
                     %cycle
                        s = s.tostring(args(vptr))
                        vptr = vptr + 1
                     %repeat %until args(vptr) = '+'
                     cstring(s,addr(cstr(0)))
                     ID = OPEN(addr(cstr(0)),READING)
                     %if ID<0 %start
                        Abort ("Failed to open -nus file","")
                     %finish
                     i = Getfstat(ID,addr(Fid))
                     size = Fid_filesize
                     filead = malloc(size)
                     i = READ(ID,filead,size)
                     %if i<0 %start
                        Abort ("Failed to read -nus file","")
                     %finish
                     Close(ID)
                     Optfiles_nusaddr = filead
                     Optfiles_nuslen = size
                     Options2=Options2 ! nusfile
                  %finish
               %finish
          %finish
        %finishelseifc
 c = 'e'  %start                                  { switch off error reporting }
               Options2 = Options2! noerrors
                   %finishelseifc
 c = 'r'  %start                                      { force double precision }
                vptr = vptr+1  { get over '8' }
               Options2 = Options2 ! R8
         %finishelseifc
 c = 'f'  %start                      
          %if Target = Sparc %thenstart          {look for fsqrt}
             %if args(vptr+1)='s' %and args(vptr+2)='q' %and   %c
                 args(vptr+3)='r' %and args(vptr+4)='t' %and   %c
                 args(vptr+5)='+' %thenstart
                Sparcfsqrt=1
                vptr=vptr+5
                ->continue
             %finish
          %finish
          %if Compiler= Fortran %thenstart
            c = args(vptr+1)
            %if c='f' %thenstart                            { free format }
              Options2 = Options2 ! freeformat
              warnlinelen = 132
              vptr= vptr + 1
            %finishelsestart                               { Use Far Data }
               %if Target=GOULD %thenstart
                  %if c = 'X' %then vptr = vptr + 1 
                  Options2 = Options2 ! UseFarData
               %finishelsestart
                  Options2 = Options2 ! freeformat
                  warnlinelen = 132
               %finish
            %finish
          %finish
         %finishelseifc
 c = 'b'  %start                                         { NP1 Vectorise }
            vptr = vptr + 1
            c = args(vptr)
            %if c = 's' %then Options2 = Options2 ! bslashnatural
            %if c = 'm' %then Options2 = Options2 ! optionalargs
         %finishelseifc

 c = 's'  %start                                         { scalar SUM    }
          %if Allowvector= 1 %thenstart
             vptr = vptr + 1
             c = args(vptr)
             %if c = 'r' %then Options2 = Options2 ! sroption
             %if c = 'e' %then Options2 = Options2 ! sroption ! seoption
         %finishelsestart
            %if Allowparallel#0 %thenstart
              %if args(vptr+1)='i' %and args(vptr+2)='n' %and %c
                  args(vptr+3)='g' %and args(vptr+4)='l' %and %c
                  args(vptr+5)='e' %thenstart {single}
                    Paralleloptions=Paralleloptions!1 
                    vptr=vptr+5
              %finish
           %finish
         %finish
         %finishelseifc

 c = 'V'  %start
          %if Target= Gould %thenstart                   { NP1 Vectorise }
             %if Allowvector= 1 %thenstart
                Options2 = Options2 ! Vectorise
             %finish
          %finishelsestart                          { Parameter Checking }
             F77parm = F77parm&(\Noarg)
          %finish
         %finishelseifc
 c = 'W'   %start                                { File of routine names }
                                                 { for Optimiser }
              %if Compiler= Fortran %start
                vptr = vptr +1   { get over 'O' }
                type = args(vptr)
                %if type = 's' %start  { -Ws,<digits>  (lines) }
                   vptr = vptr + 1
                   i = 0
                   %cycle
                     c = args(vptr+1)
                     %exit %unless '0' <= c <= '9'
                     i = (i*10) + (c - '0')
                     vptr = vptr+1
                   %repeat
                   vptr = vptr+1 %if c='+'
                   vptr = vptr+1
                   Opt2max=i
                   %continue
                %finish
                vptr = vptr +2
                s = ""
                %cycle
                  s = s.tostring(args(vptr))
                  vptr = vptr + 1
                %repeat %until args(vptr) = '+'
                cstring(s,addr(cstr(0)))
                ID = OPEN(addr(cstr(0)),READING)
                %if ID<0 %start
                   Abort ("Failed to open -WO file","")
                %finish
                i = Getfstat(ID,addr(Fid))
                size = Fid_filesize
              filead = malloc(size)
                i = READ(ID,filead,size)
                %if i<0 %start
                   Abort ("Failed to read -WO file","")
                %finish
                Close(ID)
                %if type = 'i' %start
                   Optfiles_inaddr = filead
                   Optfiles_inlen = size
                   Options2 = Options2 ! Inclusions
                %finishelsestart
                   Optfiles_exaddr = filead
                   Optfiles_exlen = size
                   Options2 = Options2 ! Exclusions
                %finish
             %finish { fortran }
              %finishelseifc

 c = 'I' %or c = 'i' %start                       { set default integer size }
             vptr = vptr + 1
             c = args(vptr)
         %if c = '2' %then F77Parm = F77Parm!I2 %elsec
         %if c # '4'  %and args(vptr-1) = 'I' %thenstart

                  ptr = addr(s)
           %cycle
                  ptr = ptr + 1
                  byteinteger(ptr)= c
                  %if c = '+' %thenexit
                  vptr = vptr + 1
                  c = args (vptr)
           %repeat
               i = ptr - (addr(s))
           %if i > 1 %then length(s) = i %and Includepath = Includepath . s
           %finish
         %finishelseifc

 c = 'o' %start                     { nominate an alternative object filename }
               ptr = addr(object)
            %cycle
                   v ptr = vptr + 1
                   c = args(vptr)
                   %exit %if c = '+'
                   ptr = ptr + 1
                   byteinteger(ptr) = c
            %repeat
               length(object) = ptr - addr(object)
         %finishelseifc

 c = 'Y' %start
         %if Allowparallel# 0 %thenstart
             vptr = vptr + 1
             c = args(vptr)
             ptr = addr(s)
             %cycle
                  %if c = '+' %thenexit
                  ptr = ptr + 1
                  byteinteger(ptr)= c
                  vptr = vptr + 1
                  c = args (vptr)
             %repeat
             i = ptr - (addr(s))
             %if i > 0 %thenstart
                length(s) = i
                %if Nunshcom<127 %thenstart
                   Nunshcom = Nunshcom+1
                   Unshcom(Nunshcom) <- s
                %finishelsestart
                   Abort ("Only 127 unshared common blocks allowed","")
                %finish
             %finish
         %finish
         %finishelseifc

 c = 'N' %start                                                 { Table size }
                vptr = vptr + 1
                table = args(vptr)
                i = 0
                %cycle
                   c = args(vptr+1)
                   %exit %unless '0' <= c <= '9'
                   i = (i*10) + (c - '0')
                   vptr = vptr+1
                %repeat
                %if c = '+' %then vptr = vptr + 1
                %if Compiler= Fortran %thenstart
                   %if table = 'd' %then dsize = i %elsec
                   %if table = 't' %then tsize = i %elsec
                   %if table = 'l' %then lsize = i %elsec
                   %if table = 'b' %then bsize = i %elsec
                   %if table = 'x' %then nsize = i %elsec
                   %if table = 'a' %then asize = i
                %finishelsestart
                   workK= i
                %finish

         %finishelseifc

 c = '7' %start                                             { line length check}
         %if Compiler= Fortran %thenstart
                vptr=vptr+1
                c = args(vptr)
                %if c='2' %thenstart
                   warnlinelen = 72
                   c = args(vptr+1)
                %finishelsestart
                     %if Env=Gould %and c='7' %start
                          c = args(vptr+1)
                          %if c='+' %start
                               f77plus=1         {77+ extensions}
                               vptr=vptr+1
                          %finish
                     %finish
                %finish
         %finish
         %finishelseifc

 c = 'd' %start                                                { Diagnostics }
         %if Compiler= Fortran %thenstart
                i = 0
                %cycle
                  c = args(vptr+1)
                  %exit %unless '0' <= c <= '9'
                  i = (i*10) + (c - '0')
                  vptr = vptr+1
                %repeat
                %if c = '+' %then vptr = vptr + 1
                Diagnostic level = I
         %finish
         %finishelseifc

 c = 'm' %thenstart                                               { parallel }
            %if Allowparallel#0 %thenstart
                %if args(vptr+1)='p' %thenstart 
                  vptr=vptr+1                                 { pass over  'p' }
                  Parallelise=1                  
                %finish
            %finish
            %if Compiler= IMP %thenstart
               com28 = com28!x'100'
               workK = 2047 %if workK<2047
            %finish
         %finish

continue:

not implemented:
      vptr = vptr+1
    %repeat
  %finish %else %exit
%repeat

%if Allowparallel#0 %thenstart
   %if Parallelise=1 %and Lineprofiler=1 %then Lineprofiler=0
   %if Parallelise=1 %and Timeprofiler=1 %then Timeprofiler=2
%finish
%if OCScompliant=0 %and (Target=M88000 %and Object Format=ISBSDOMRON) %start
   options2 = options2&(~nus)  {hardwire -us only for OMRON}
%finish

argument = argument+1
{----------------------------------------------------------------------------}
{ ********* SOURCE FILE is  third parameter }

  source=""
   args == array(argptr(argument),argfm)
   vptr = 1
   argument = argument+1
  %cycle
    source=source.tostring(args(vptr))
    vptr=vptr+1
  %repeat %until args(vptr)=0 
  root = source
  length(root) = length(root)-1 { discard 'i' }

%if Compiler= Fortran %thenstart
   Srcefilename=source  {available for error reports}
   printstring(source)
   newline
%finish

{----------------------------------------------------------------------------}
{ ******** Fourth parameter is -P text used for private verbose options }

%if Host= Sun3 %and Compiler= IMP %thenstart
   SaveRegs=0   { assume registers are not to be saved }
%finish

   s = ""
%if Compiler= IMP %thenstart
   params== string (AdCstr)           {params will be used to save the identity}
   params= ""                         {    of the private options specified    }
%finish

  %if argptr(argument)=0 %then ->NOfourthPARAM
    args == array(argptr(argument),argfm)
     vptr = 1
  %cycle
    c = args(vptr)
    %if c=',' %or c='/' %or c=0 %start
      %exit %if s="(NULL)"            {no long options}

      invalid=0
      %if Compiler = IMP %start
        %if s = "LIST"       %then com27 = com27&(\NoList)         %elseifc 
            s = "CODE"       %thenstart
                                com27 = com27 ! code
                                %if Host# Sun3 %or Env= GOULD %thenstart
                                   %if Emachine>= 4 %then Mcodeon             %c
                                                    %else Pcodeon
                                %finishelse control= control ! code
                             %finish                               %elseifc
 {          s = "DIAG"       %then Diagstream = 2 {Stderr}{        %elseifc    }
            s = "OPT"        %then com27 = com27!opt               %elseifc
            s = "QUOTES" %or s="CASESENS"     %then com27 = com27!1                 %elseifc
            s = "MAP"        %then com27 = com27!iMap              %elseifc
            s = "FIXED"      %then com27 = com27&(\iFree)          %elseifc
            s = "PROFILE"    %then com27 = com27!iProfile          %elseifc
            s = "NOTRACE"    %then com27 = com27!NoTrace           %elseifc
            s = "NOLINE"     %then com27 = com27!NoLine            %elseifc
            s = "NOCHECK"    %then com27 = com27!NoCheck           %elseifc
            s = "MIPS2" %then TargetVariant=5{R4000}               %elseifc
            s = "CHECK"      %then com27 = com27&(\Nocheck)        %elseifc
            s = "NODIAG"     %then com27 = com27!NoDiag            %elseifc
            s = "NOARRAY"    %then com27 = com27!NoArray           %elseifc
            s = "ARRAY"      %then com27 = com27&(\NoArray)        %elseifc
            s = "PARMX"      %then com27 = com27!parmx             %elseifc
            s = "PARMY"      %then com27 = com27!parmy             %elseifc
            s = "PARMZ"      %then com27 = com27!parmz             %elseifc
            s = "LINE"       %then com27 = com27&(\NoLine)         %elseifc
            s = "MINWORK"    %then com28 = com28&x'FFFFFEFF'                  %c
                             %and  workK = 128                     %elseifc
            s = "BIGWORK"    %then  workK = 512                    %elseifc
            s = "MAXWORK"    %then  %start
                                workK = 2047 %if workK<2047
                             %finish %elseifc
            s = "MAXDICT"    %then com28 = com28!x'100'            %elseifc
            Host= Sun3    %andc
            s = "REGSAV"     %then SaveRegs= 1                     %elsec
            { none of these }      invalid=invalid+1
      %finish

      %if  s = "SCAN"       %thenstart
                            %if Emachine>= 4 %then Pfaulty                    %c
                                             %else Mfaulty
                            Options1 = Options1!NoCode
                            syntaxcheck= 1
                            %finish                                %elseifc
           s = "VERSION"    %then printstring(reldate)             %elseifc
           s = "OPTIONS"    %then monopt = 1                       %elseifc
           s = "SET"        %then setsigs flag= 1                  %elseifc
           s = "UNSET"      %then setsigs flag= 0                  %elseifc
           s = "FILEMON" %orc
           s = "FMON"       %then com26= com26!16                  %elseifc
           s = "MALLOCMON"  %then com26= com26!128                            %c
                            %and  mmon=1                           %elseifc
           s = "CGMON"      %thenstart
                              %if Emachine>=4 %then cgoptions=cgoptions!cgreport
                            %finish                                %elseifc
           s = "CGSCHED"    %thenstart
                              %if Emachine>=4 %thenstart
                                 cgoptions=cgoptions!cgschedule
                              %finish
                            %finish                                %elseifc
           s = "CGSCHEDMON" %thenstart
                              %if Emachine>=4 %thenstart
                                 cgoptions=cgoptions!cgschedule!cgschedmon
                              %finish
                            %finish                                %elseifc

           s = "CGPEEPMON" %thenstart
                              %if Emachine>=4 %thenstart
                                 cgoptions=cgoptions!cgpeepmon
                              %finish
                            %finish                                %elseifc
           s = "PMON" %orc
           s = "P"          %thenstart
                            %if Emachine>= 4 %then Pmonon                     %c
                                             %else Mmonon
                            %finish                                %elseifc
           s = "EMON" %orc
           s = "E"          %then Emonon                           %elsec
           { none of these }       invalid=invalid+1

      %if Compiler = Fortran %start
      
      %if  s = "LIST"       %then Control = Control&(\NoList)      %elseifc
           s = "XREF"       %then Control = Control!xref           %elseifc
           s = "OPT"        %then control = control!opt            %elseifc
           s = "CODE"       %thenstart
                               %if Host# Sun3 %or Env= GOULD %thenstart
                                  %if Emachine>= 4 %then Mcodeon              %c
                                                   %else Pcodeon
                               %finishelse control= control ! code
                            %finish                                %elseifc
           s = "ATTR"       %then Control = Control!attr           %elseifc
           s = "QUOTES"     %then Control = Control!1              %elseifc
           s = "D1"         %then options1=options1!x'10000'       %elseifc
           s = "D2"         %then options1=options1!x'20000'       %elseifc
           s = "D3"         %then options1=options1!x'30000'       %elseifc
           s = "D4"         %then options1=options1!x'40000'       %elseifc
{          s = "NOUND"      %then options2=options2!Nounderscore   %elseifc    }
           s = "DEPANAL"    %then F77parm = F77parm!depanal        %elseifc
           s = "NODEPCHECK" %then options2=options2!nodepcheck     %elseifc
           s = "NOFUSE"     %then options2=options2!nofuse         %elseifc
           s = "FUSEALL"    %then options2=options2!fuseall        %elseifc
           s = "FUSELIST"   %then options2=options2!fuselist       %elseifc
           s = "OV"         %then options2=options2!optimisevector %elseifc
           s = "DIV"        %then hardoptions=hardoptions!divset   %elseifc
           s = "NEWBR"      %then hardoptions=hardoptions!newbr    %elseifc
           s = "PROF"       %thenstart
                            %if Host# Sun3 %or Env= GOULD %then lineprofile=1
                            %finish                                %elseifc
           s = "OPTRIADS"   %then F77parm = F77parm!Optriads       %elseifc
           s = "TRIADS"     %then F77parm = F77parm!Triads         %elseifc
           s = "MAPS"       %then F77parm = F77parm!Maps           %elseifc
           s = "MISALIGN"   %then misalignedreals= 1               %elseifc
           s = "STRICT"     %then F77parm = F77parm!Strict         %elseifc
           s = "NOWARNLEN"  %then F77parm = F77parm!NoWarnlen      %elseifc
           s = "NOWARNINGS" %then F77parm = F77parm!No Warnings    %elseifc
           s = "NOCOMMENTS" %then F77parm = F77parm!No Comments    %elseifc
           s = "NOBOUND"    %then F77parm = F77parm!NoBound        %elseifc
           s = "MINBOUND"   %then F77parm = F77parm!MinBound       %elseifc
           s = "NOUNASS"    %then F77parm = F77parm!NoUnass        %elseifc
           s = "NOARG"      %then F77parm = F77parm!Noarg          %elseifc
           s = "NOCHAR"     %then F77parm = F77parm!NoChar         %elseifc
           s = "NOWARN77"   %then F77parm = F77parm!NoWarn77       %elseifc
           s = "F77"        %then F77parm = F77parm!F77            %elseifc
           s = "NOVAX"      %then F77parm = F77parm&(\Vaxflag)     %elseifc
           s = "NOUNIX"     %then F77parm = F77parm&(\Unix)        %elseifc
           s = "OPT1"       %then Options1 = Options1!opt1         %elseifc
           s = "OPT2"       %then Options1 = Options1!opt2         %elseifc
           s = "OPT3"       %then Options1 = Options1!opt3         %elseifc
           s = "OPTEXT"     %then Options1 = Options1!optext       %elseifc
           s = "NOFREG"     %then Comopt3 = 0                      %elseifc
           s = "LIMIT1"     %then optcontrols=optcontrols!1        %elseifc
           s = "LIMIT2"     %then optcontrols=optcontrols!2        %elseifc
           s = "LIMIT4"     %then optcontrols=optcontrols!4        %elseifc
           s = "LIMIT8"     %then optcontrols=optcontrols!8        %elseifc
           s = "LIMIT16"    %then optcontrols=optcontrols!16       %elseifc
           s = "NOUNROLL"   %then optcontrols=optcontrols!16       %elseifc
           s = "NONUMCHUNKS" %thenstart
                             %if Allowparallel# 0 %thenstart
                                Paralleloptions=Paralleloptions!1
                             %finish
                             %finish                               %elseifc
           s = "PT0"        %then Timeprofiler=3                   %elseifc
           s = "PTS"        %then Timeprofiler=4                   %elseifc
           s = "PTP"        %then Timeprofiler=5                   %elseifc
           s = "FULLBOUND"  %then F77parm = F77parm & (\(NoBound!MinBound)) %elseifc
           s = "CTRIADS"    %then ctriads=1                        %elseifc
           s = "MOO"        %then G2traceMOO=1                     %elseifc

           s = "LISTNONE"   %then Options1 = Options1!listnone     %elsec
           { none of these }      invalid=invalid+1
      %finish
      %if compiler = IMP %start
         %if invalid=2 %then s="[".s."]"
         %if params="" %then params=s %else params=params.",".s
      %finish
      %if c=0 %then %exit
      s=""
      vptr = vptr+1 { discard , or / }
      %continue
    %finish
    %if 'a'<=c<='z' %then c = c - 32
    s = s.tostring(c)
    %if Compiler = Fortran %or Compiler = Imp %Start
      %if s="G" %thenstart
         c = args(vptr+1)
         vptr = vptr+1
         %if c='x' %thenstart
                   cgoptions = cgoptions & notcgsched
                   %finishelseif %c
             c='l' %thenstart
                   cgoptions = cgoptions & notcgleaf
                   %finishelseif %c
             c='g' %thenstart
                   cgoptions = cgoptions ! cgglobsched
                   %finishelseif %c
             c='p' %thenstart
                   cgoptions = cgoptions & notcgpeep
                   %finishelseif %c
             c='Y' %thenstart
                   cgoptions = cgoptions ! cgschedmon
                   %finishelseif %c
             c='m' %thenstart
                   i = readn
                   cgoptions = cgoptions ! ((i&15)<<12)
                   %finishelseif %c
             c='t' %thenstart
                   gistrace = readbv
                   %finishelseif %c
             c='I' %thenstart
                   gisinhib = readbv
                   %finishelseif %c
             c='B' %thenstart
                   boinhiboptions = readbv
                   %finishelseif %c
             c='P' %thenstart
                   gisproc = readn
                   %finishelseif %c
             c='R' %thenstart
                   readnn(gisfraglow,gisfraghigh)
                   %finishelseif %c
             c='u' %thenstart
                   rangeregion = readn
                   %finishelseif %c
             c='b' %thenstart
                   botraceoptions = readbv
                   %finishelsestart
                   printstring("invalid option g".tostring(c))
                   newline
         %finish
         s=""
      %finish
   %finish
   %if Compiler = Fortran %start

      %if s = "SF" %or s="OF"  %or s="LIMIT" %or s="MINVECT"  %c
                   %or s="X" %or s="Z" %start
        i = 0
        %cycle
          c = args(vptr+1)
          %exit %unless '0' <= c <= '9'
          i = (i*10) + (c - '0')
          vptr = vptr+1
        %repeat
        %if s="X" %then Xoptimiseoptions = Xoptimiseoptions ! i
        %if s="Z" %then Poptimiseoptions = Poptimiseoptions ! i
        %if s="SF" %then srcflags = i
        %if s="OF" %then optflags=i
        %if s="LIMIT" %then optcontrols=optcontrols ! i
        {%if s="LIM" %then options2=options2!(i<<16)}
        %if s="MINVECT" %then minvect=i
        s=""
      %finish
    %finish
    vptr = vptr+1
  %repeat
NOFOURTHPARAM:

!check if signal traps are to be set (for diagnostics}
     !
     Set Sigs %unless setsigs flag= 0

  comreg(26)= com26 %if com26# 0
  comreg(27)= com27 %if Compiler= Imp %and com27# 0
  comreg(28)= com28 %if Compiler= Imp %and com28# 0


%if Compiler= Fortran %start
!*
!***************************************************************************
!* analyse options/switches specified                                      *
!***************************************************************************
!*
   Warning 1 Flag= 0
   %if options1&(opt1!opt2!opt3) # 0 %thenstart
      %if Diagnostic level # -1 %thenstart 
         Warning 1 Flag= 1
      %finish
      %if F77parm&NoUnass  =  0 %thenstart
         Warning 1 Flag= Warning 1 Flag ! 2
      %finish
      %if F77parm&Noarg    =  0 %thenstart
         Warning 1 Flag= Warning 1 Flag ! 4
      %finish
      %if F77parm&MinBound #  0 %thenstart
         Warning 1 Flag= Warning 1 Flag ! 8
      %finish
      %if F77parm&sdb      #  0 %thenstart
         Warning 1 Flag= Warning 1 Flag ! 16
      %finish
      %if Lineprofiler     #  0 %thenstart
         Warning 1 Flag= Warning 1 Flag ! 32
      %finish
      %if Emachine= 4 %andc
         (cgoptions & cglineprof) # 0 %then Warning 1 Flag= Warning 1 Flag ! 32
      %if Timeprofiler     #  0 %then Warning 1 Flag= Warning 1 Flag ! 64
        !
        !(Optimising overrides Diagnostics, Unassigned Checking, Argument
        !            Checking, Array Bound Checks, SDB, Line Profiling,
        !            and Time Profiling}

      %if Warning 1 Flag# 0 %thenstart {undo any damage}
         F77parm = (F77parm & ( \(MinBound!sdb)) ! NoChar ! NoUnass ! Noarg )
         %if Emachine= 4 %thenstart
            cgoptions= cgoptions & (~cglineprof)
         %finish
         Diagnostic level = -1
         !Note:
         !    Check consistency of options before calling Msetoptions. Any
         !    inconsistency however cannot be reported until the status of
         !    the listing and error stream has been established - hence set
         !    a flag which will be inspected later
      %finish
   %finish
%finish

%if Emachine>= 4 %thenstart
!*
!***************************************************************************
!* prepare options for code generator                                      *
!***************************************************************************
!*
    %if Compiler= IMP %thenstart
       %if (com27 & opt    )# 0 %then com27=com27 ! NoLine ! NoArray ! NoTrace%c
                                %and  comreg(27)= com27
       %if (com27 & NoTrace)= 0 %then cgoptions= cgoptions ! cgdiags
       %if (com27 & NoLine )= 0 %then cgoptions= cgoptions ! cglinenos
       %if (com27 & Nocheck)= 0 %then cgoptions= cgoptions ! cgFPUtraps
    %finish

    %if Compiler= Fortran %thenstart
       %if Diagnostic level>= 0 %orc
           (F77parm & 15)   # 7 %then cgoptions=cgoptions ! cgdiags ! cglinenos
       %if (F77parm & sdb)  # 0 %then cgoptions=cgoptions ! cgsetdbx
       %if (F77parm & Noarg)= 0 %then cgoptions=cgoptions ! cgargchecks
       %if (Options1 & opt1)# 0 %then cgoptions=cgoptions ! cgregvaropt
    %finish

    !
    %if Target = M88000 %or Target = SPARC %then %start
       { no instruction scheduling if any diagnostic options are set }
       %if (cgoptions & (cgdiags ! cglinenos ! cgsetdbx ! cgargchecks) <> 0) %c
         %then cgoptions = cgoptions & (\cgschedule)
    %finish
    !

    %if options2&csoption#0 %then cgoptions=cgoptions!cgcasesense  {-CS}

    %if Compiler = Fortran %or Compiler = Imp %thenstart     {modified 06/07/93}
       Esetoptions(cgoptions,botraceoptions,boinhiboptions,gisproc,  %c
                    gisfraglow,gisfraghigh)
       EsetGISoptions(gisbuffzone,gisfullopt,gistrace, %c
                            gisinhib,rangeregion)
    %finishelsestart
       Msetoptions (cgoptions)
    %finish

%finishelsestart
    Msetoptions = F77parm
%finish

{--------------------------------------------------------------------------}

  s = source
  {i=i+1 %while s ->("/").s}
  IncludeDir = ""
  slen=length(s)
  %cycle i=slen,-1,1
     %if charno(s,i)='/' %thenstart
        IncludeDir = s
        length(Includedir)=i
        charno(s,i)=slen-i
        s=string(addr(s)+i)
        %exit
     %finish
  %repeat
  !%if length(s)>14 %start
      !print string ("Error: File name longer than 14 characters ")
      !print string ( s )
      !newline
      !EXIT(1)
  !%finish

  %if object="" %thenstart
     slen= length(s) - 1                        {prepare to discard 'f' or 'i'}
     %if Compiler= Fortran %thenstart
        %if charno(s,slen)='f' %thenstart
           slen= slen - 1                       {allow for .fv}
        %finishelsestart
           %if (charno(s,slen)='o' %and charno(s,slen-1)='f') %thenstart
              slen= slen - 2                    {allow for .for}
           %finish
        %finish
     %finish
     length(s)= slen
     object = s."o"
  %finish

%if Compiler= Imp %and (com27 & NoList)= 0 %thenstart
!*
!***************************************************************************
!* print header to the listing file (if IMP and LIST)                      *
!***************************************************************************
!*
    %if params= "" %then params= "Defaults"
    %if Diagstream> Liststream %thenstart
       print string (source)                                       {on Stderr}
       newline
    %finish
    select output (Stdout)
    print string ("Source:    "); print string (source); newline
    print string ("Object:    "); print string (object); newline
    print string ("Parms:     "); print string (params); newline
%finishelsestart

   %if Compiler= IMP %then print string (source) %and newline
%finish

  %if Host=DRS %thenstart
     Esourcefile(source)                   { Inform gen of sourcefilename }
  %finish

  %if Emachine>= 4 %thenstart
     Psetfiles(source,object,syntaxcheck)  { Inform Put of source and object}
  %finishelsestart
     Msetfiles(source,object,syntaxcheck)  { Inform Put of source and object}
  %finish

  %if Compiler= Fortran %start
     Cstring(source,adcstr)
     primarySrcID = Open(adcstr,READING)
     %if primarySrcID<0 %thenstart
        Abort ("Failed to open Sourcefile - ",source)
     %finish
  %finish

%if Compiler= IMP %start
!*
!***************************************************************************
!* Claim compiler work-space by allocating WorkAd kbytes from memory.      *
!***************************************************************************
!*
    %if monopt#0 %then printstring("
claiming workspace at ")

  { Set up Work File }
    workad = malloc(workK*1024)
    %if monopt#0 %then phex(workad) %and printstring(" of ") %and phex(workk*1024)
    comreg(14) = workad
    Hdr == record(workad)
    Hdr = 0
    Hdr_datastart = 32
    Hdr_filesize = workK*1024
!*
!***************************************************************************
!* Connect source-file. In this case simply open the file for reading.     *
!***************************************************************************
!*
    ConSource(source,srcad)                   { grab source file }
    selectinput(Srcid)
    comreg(1)=Srcsize
    comreg(46) = srcad                        { c46 holds address for Peter }

    com23= -1 %if noisy= 0

    %if (com27 & NoList)= 0 %orc
      (Control & Code  )# 0 %orc
                 noisy  = 1 %thenstart
        com23= Stdout
        com40= -1 %if Diagstream> 0 %and Liststream> 0
    %finish
    comreg(40)= com40
    comreg(23)= com23
    select output (com23)

%finish


%if Compiler= Fortran %start

{--------------------------------------------------------------------------}
{ ********* Analyse Options/Switches specified }

   %if control&2=0 %thenstart  {listing requested}

      %if Liststream< 0 %or Diagstream< 0 %thenstart
          select output (Stdout)
          dup output= 1
          printvers
          print string (source)
          newlines (2)
          select output (Stderr)
         %finishelse newline
   %finish

   %if gisbuffzone#0 %and (cgoptions & cgglobsched#cgglobsched) %thenstart
Warning 1 Text="Warning: -gisbuff= option used without -O4 or -O5
"
       Output (Warning 1 Text)
       %finish

   %if Warning 1 flag# 0 %thenstart
      i= 1
      Warning 1 Text= ""
      %while Warning 1 Flag# 1 %cycle
         %if Warning 1 Flag & 1# 0 %thenstart
            Warning 1 Text= "," . Warning 1 Option(i) . Warning 1 Text
         %finish
         i= i + 1
         Warning 1 Flag= Warning 1 Flag>> 1
      %repeat
      x= length(Warning 1 Text)
      Warning 1 Text= Warning 1 Option(i) . Warning 1 Text
      %if x# 0 %then Warning 1 Text= "s" . Warning 1 Text . " are"           %c
               %else Warning 1 Text= Warning 1 Text . " is"
      Warning 1 Text= "Warning: Diagnostic option" . Warning 1 Text          %c
                                                   . " overridden by -O
"
      Output (Warning 1 Text)
   %finish {warning about inconsistent options}

   %if control&code#0 %then selectoutput(Stdout)
 %finish


%if Compiler= Fortran %Start
    bufad = malloc(bufsize+1)    { get buffer to read source into }
    InitialiseSource


    %if monopt#0 %start
      select output (Stdout)
      printstring("
FORT77( Control  = ");  phex(control)
      printstring("
         options1 = ");  phex(options1)
      printstring("
         options2 = ");  phex(options2)
      printstring("
         F77parm  = ");  phex(F77parm)
      printstring("
         Optflags = ");  phex(optflags)
      printstring("
         Comopt3  = ");  write(Comopt3,1)
      printstring("
         recipopt = ");  write(recipopt,1)
      printstring("
         Opt2max  = ");  write(Opt2max,1)
      printstring("
         optcontrols = ");  phex(optcontrols)
      printstring("
         misalignedreals = ");  write(misalignedreals,1)
      printstring("
         Srcflags = ");  phex(Srcflags)
      printstring("
         Liststream = "); write(Liststream,1)
      printstring("
         Console = "); write(2,1)
      printstring("
         Diagstream = "); write(Diagstream,1)
      printstring("
         Diagnostic level = "); write(Diagnostic level,1)
      printstring("
         Dsize = "); write(Dsize,1)
      printstring("
         Tsize = "); write(Tsize,1)
      printstring("
         Bsize = "); write(Bsize,1)
      printstring("
         Lsize = "); write(Lsize,1)
      printstring("
         Asize = "); write(Asize,1)
      printstring("
         Nsize = "); write(Nsize,1)
      newline
      printstring("
          cgoptions = "); phex(cgoptions)
      newline
  %finish; !Note currently selected may be either STDOUT or STDERR at this point
%finish

    Cstring(object,adcstr)  { leave object filename in buffer for unlink }

%integerfn readn
%integer i,c
      i = 0
      %cycle
         c = args(vptr+1)
         %exit %unless '0' <= c <= '9'
         i = (i*10) + (c-'0')
         vptr=vptr+1
      %repeat
      %result = i
%end {readn}

%integerfn readbv
%integer i,j,c
      i = 0
      j = readn
err:  %unless 0<=j<=31 %thenstart
         printstring("invalid bit vector
")
         %result = 0
      %finish
      %cycle
         i = i ! (1<<j)
         c = args(vptr+1)
         %exit %unless c = ':'
         vptr=vptr+1
         j = readn
         %unless 0<=j<=31 %then -> err
      %repeat
      %result = i
%end {readbv}

%routine readnn(%integername val1,val2)
%integer i,c
      val1 = readn
      c = args(vptr+1)
      %unless c = ':' %thenstart
         printstring("invalid fragrange
")
         val2 = 0
         %return
      %finish
      vptr=vptr+1
      val2 = readn
%end {readnn}

%end;! Prepare
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!


%externalroutine COMPILE %alias "main" (%integer argc, argv)

   %routinespec print summary (%integer i)
   %string(1) s
   %integer i
   !
   %if Compiler= Fortran %then recipopt = 0
   %if Target=RS6000 %start
      nohsflt=0   {user has not used -qnohsflt yet}
   %finish
   %if Host = M88000 %then %start
      %integer DiagStopper

      DiagStopper = M'ZDIA'     { in case of compiler crash! }
   %finish
   !
   %if Host = M88000 %then %start
      disabletraps              { disable all 88k fpu traps        }
                                { and set rounding mode to nearest }
   %finish
   !
   %if Target = M88000 %then %start
      cgoptions = cgschedule    { default is to enable instr scheduling }
   %finish
   !
   %if Host=MIPs %start
      cgoptions = cgschedule     { Mips default is to schedule }
   %finish
   Prepare( argc, argv)         { to keep stack size down }

  %if Host=DRS %and Usechipfns=Weitek %thenstart
     %if Env=Sequent %then Set Weitek Flags
  %finish

   %if Compiler= IMP %start
      IMPCOMPILER
      %if comreg(24)=0 %or comreg(27)=8 %start { return code }
         FREE(workad)
         i= comreg(47)              {=> continue to generate the object file}
      %finishelse i= -1             {=> terminate quickly with a failure    }
  %finishelsestart
      i=FORT77(Control,options1,options2,F77parm,Optflags,Srcflags,0,Liststream,
                Diagstream,diagnostic level,Dsize,Tsize,Bsize,Lsize,Asize,Nsize)

  %finish
      select output (Stderr)
      print summary (i) %if Compiler= Fortran %or (i> 0 %and comreg(40)# -1)

  %if i>=0 %start
     %if syntaxcheck=0 %thenstart
        select output (Stdout)
        %if Emachine>= 4 %then Pgenerateobject (s)                            %c
                         %else Mgenerateobject (s)
        select output (Stderr)
     %finish
     %if Protection=ALF %start
        freeadilicense
     %finish
     EXIT(0)
  %finishelsestart
!     i = UNLINK(AdCstr)
     %if Protection=ALF %start
        freeadilicense
     %finish
     EXIT(1)
  %finish


%if Compiler= Fortran %thenstart

%routine print summary (%integer i)
  %string(31) s,t
  %integer    n
              n= i
              n=-n %if n< 0

   s= "
   ".itos (n)
  %if i< 0 %then t= " Error"    %c
           %else t= " Line"
                 s= s.t

  %if i>1 %or i<-1 %then s= s . "s"

  %if i>0 %thenstart
      %if syntaxcheck= 0 %then t= " Compiled
"                        %else t= " Analyzed
";    %finishelse t= "
";           s= s.t

    output (s)
%end;! print summary
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!
%finish


%if Compiler= IMP %thenstart

%routine print summary (%integer i)
  %string(63) s,t

   s= "
   ".itos (i)

  %if i= 1 %then t= " Statement"                                              %c
           %else t= " Statements"

   s= s.t

  %if syntaxcheck= 0 %then t= " Translated to C
"                    %else t= " Analyzed
";              s= s.t

    print string (s)
%end;! print summary
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!
%finish


%end;! COMPILE
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!


%if Compiler= Fortran %thenstart

%externalroutine DeleteObjectFile
  %integer i

  i = UNLINK(AdCstr)
%end;! DeleteObjectFile
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!
%finish


%if Compiler= Fortran %start
!---------------------------------------------------------------------------
!************************* SPACE CLAIMED HERE  *****************************
!---------------------------------------------------------------------------

!*
%externalroutine F77area(%integer Index,Size,%integername Address)
%conststring(9)%array Id(0:6)=  %c
      "T#DICT","T#NAMES","T#TRIADS","T#BLOCKS","T#TABS",
      "T#LOOPS","T#BUFFS"
!integer I
!       I=malloc(0);! to find current address
!       %if I>0 %thenstart;! force alignment to 4K boundary
!          %if I&X'FFF'#0 %thenstart
!             I=malloc(I&X'FFFFF000'+X'1000'-I)
!          %finish
!       %finish
      Address=malloc(Size)
      %if mmon#0 %start
        printstring("
Creating area ")
        printstring(Id(Index))
        printstring("  size = X")
        phex(Size)
      %finish
      %if Address>0 %thenstart
        %if mmon#0 %start
          printstring(" address = X")
          phex(Address)
          newline
        %finish
      %finishelsestart
        printstring("Create area  response=")
        write(Address,1)
        newline
        %stop
      %finish
%end;! F77area
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!



!---------------------------------------------------------------------------
!******************  SOURCE INPUT TO COMPILER  *****************************
!---------------------------------------------------------------------------

%owninteger id                     { file descriptor of current source file }
%ownbyteintegerarray spacepat(0:71)=' '(72)
%owninteger adspaces
%owninteger next
%owninteger linestart
%owninteger left
%recordformat incfm(%integer parent,next,left,bufad,id)
%ownrecord(incfm) %name inc

      %if Bytesreversed=YES %thenstart
         %constinteger EOF = X'00001901'
      %finishelsestart
         %constinteger EOF = X'01190000'
      %finish


%routine InitialiseSource
  id = PrimarySrcid
  adspaces = addr(spacepat(0))
  linestart = bufad
  left=0
{   left = READ(id,bufad,bufsize) }
{   %if left = 0 %start           }   { end of file }
{     printstring(" }
{ Source is Empty ") }
{     exit(0) }
{   %finish }
{   %if left<bufsize %then byteinteger(bufad+left)=NL  %and left=left+1 }{ make sure all lines terminate }
  next = bufad
  inc == record(0)
%end;! InitialiseSource
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!

%externalroutine Closeinc(%integer Lwad)
 
!  Force closure of an include file.
!  Closeinc is called when an end line has been specified on the
!  INCLUDE statement and this has been reached (Gould Fortran-77+)
 
   %integer lbad,i,parent
 
   lbad=lwad
   integer(lbad) = EOF
   CLOSE(id)
   free(bufad)                { release buffer space }
   parent = addr(inc)
   %if parent#0 %start        { safety first - should always be true}
       next  = inc_next         { reset vars to parent file }
       left  = inc_left
       bufad = inc_bufad
       id    = inc_id
       i   = inc_parent
       free(parent)           { release include record space }
       inc == record(i)
   %finish
    
%end {Closeinc}


%externalroutine SourceLine(%integer Lwad,%integername long)
  %integer t,i,linesize,parent,top,lbad

  {------------------- Have we run out of data ? ---------------------------}

  lbad = lwad
  %if left <= 0 %start               { Buffer is empty }
    left = READ(id,bufad,bufsize)
    %if left = 0 %start             { end of file }
      integer(lbad) = EOF
      CLOSE(id)
      free(bufad)                { release buffer space }
      parent = addr(inc)
      %if parent#0 %start        { if it was an include file }
        next  = inc_next         { reset vars to parent file }
        left  = inc_left
        bufad = inc_bufad
        id    = inc_id
        i   = inc_parent
        free(parent)           { release include record space }
        inc == record(i)
      %finish
      %return
    %finish
    %if left = bufsize %start     { Have not got endoffile in buffer }
      top = bufad+left-1           { backup to end of last complete line }
      %cycle i = top,-1,bufad      { to avoid split lines }
        %if byteinteger(i)=NL %start
          left = left - (top-i)
          LSEEK(id,i-top,1)        { adjust file position back }
          %exit
        %finish                    { to reread incomplete line next time }
      %repeat
    %finish %elsestart           { put an extra NL in case last line incomplete }
      %if byteinteger(bufad+left-1)#NL %then byteinteger(bufad+left) = NL %andc
      left = left + 1
    %finish
    next = bufad
  %finish

  { ---------------  ch by ch through source ---------------------}

  linestart = next

  next = next + 1 %while byteinteger(next) # NL

          {  OR }

!   **NLch         { search for NL character }
!   **next         { starting at byte address 'next' }
!   **bufsize      { stop after 'bufsize characters - always a nl there }
!   *PUT_x'FD9E'   { swne }
!   *DISCARD       { get rid of true/false }
!   **=next        { put address of NL in next }

  {--------------- set up LINE buffer -------------------}

  long = 0
  linesize = next - linestart
  left = left - (linesize + 1)
  %if warnlinelen # 0 %thenstart
     i = linesize
     %if byteinteger(lbad+1) = 9 {tab} %then i = i + 5
     %if i > warnlinelen %then long = warnlinelen
  %finish
  linesize = 132 %if linesize > 132
  next = next + 1                   { over NL }
  %if byteinteger(next-2)=13{CR} %then linesize=linesize-1    { Lose CR's }
  byteinteger(lbad) = linesize      { lbad(0) = length }
  t = lbad + 1
  **linestart; **t; **linesize; *MVB
!   %cycle i=0,1,linesize-1
!      byteinteger(t+i)=byteinteger(linestart+i)
!   %repeat

  %if linesize < 73 %start          { insert trailing spaces }
    t = lbad + linesize + 1
    i = 72 - linesize
    **adspaces; **t; **i; *MVB
!    %cycle i=0,1,71-linesize
!      byteinteger(t+i)=32
!    %repeat
  %finish
%end;! SourceLine
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!

%externalroutinespec putincname(%string(*)%name s,
                                %integer j)

%externalintegerfn select include(%string(255) Incname)
  %ownbyteintegerarray cstr(0:255)
  %ownstring(13) usr include text= "/usr/include/"
  %ownstring(7) INCLUDE text= "include"
  %integer i,parent,parentid,slen, cstr adr
  %string(255) s

  %string(255) Searchpaths1 {writable copy of IncludeDir}
  %stringname  Searchpaths2 {mapped onto the next path in Searchpaths1}

  parentid = id
  cstr adr = addr(cstr(0))

  { If there is no '/' in the Include file name then look for it in }
  { the directory containing the source , not the current directory }

  %if charno(Incname,1)= '/' %then s= Incname                                %c
                             %else s= IncludeDir . Incname
  putincname(s,1)
  Cstring(s,cstr adr)
  ID = Open(cstr adr,READING)
  %if ID = -1 %start
     %if charno(Incname,1) = '/' %then -> cant open

  { If the Include file name wasnt found, try the directories specified}
  { by the -I option (if any) so long as the Include file name does not}
  { start with a '/'                                                   }

     %if Includepath # "" %thenstart
        Searchpaths1 = Includepath
        Searchpaths2== Searchpaths1

        %cycle {through all the pathnames specified by -I}
           slen= length(Searchpaths2)

           %cycle i= 1,1,slen                      {locate terminating '+'}
              %exit %if charno(Searchpaths2,i)= '+'
           %repeat
           length(Searchpaths2)= i - 1
           s= Searchpaths2                         {= searchpath for Incname}

           Searchpaths2== string (addr(Searchpaths2) + i)
           length(Searchpaths2)= slen - i          {discard current searchpath}
                                                   {    from the list         }
           s = s."/".Incname
           Cstring(s,cstr adr)
           ID = Open(cstr adr,READING)
           %if ID >= 0 %then -> Include Opened
           %if Searchpaths2= "" %thenexit
        %repeat
     %finish

  { If no success from the -I<dir> option, try the current working directory}

     Cstring(Incname, cstr adr)
     ID = Open(cstr adr,READING)
     %if ID >= 0 %then -> Include Opened

  { If no success from the current working directory, try /usr/include}

     s = usr include text . Incname
     Cstring(s,cstr adr)
     ID = Open(cstr adr,READING)
     %if ID = -1 %then -> cant open

  %finish

Include Opened:
  parent = addr(inc)
  i = malloc( 32 {size of inc})
  inc == record(i)
  inc_bufad  = bufad
  inc_parent = parent
  inc_id     = parentid
  inc_next   = next
  inc_left   = left
  bufad = malloc(bufsize+1)    { get buffer to read source into }
  left = 0                     { trigger READ on next source line request }
  %if comreg(26)&4#0 {sdb/dbx} %thenstart
     %if Emachine>= 4 %then Psetfiles(s,INCLUDE text,0) { for DBX }          %c
                      %else Msetfiles(s,INCLUDE text,0) { for DBX }
  %finish
  %result = 0

cant open: ID = parentid
           %result = 1
%end;! Select Include
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!

%externalintegerfn Checknus(%stringname s)
%integer I,J,C,ad,len
%ownbyteintegerarray A(0:31)
!*
      %if options2&nus=0 %then %result=0 {no nus option}
      %if options2&nusfile=0 %then %result=1 {no underscores}
      ad=optfiles_nusaddr
      len=optfiles_nuslen
      J=0
      %cycle I=0,1,Len-1
         C=byteinteger(Ad+I)
{printstring("Char:");write(C,1);newline}
         %if C<=' ' %or C=',' %thenstart  {valid separators?}
            %if J>0 %thenstart
               A(0)=J
               %if s=string(addr(A(0))) %then %result=1
               J=0
            %finish
         %finishelsestart
            %if 'A'<=C<='Z' %then C=C-'A'+'a'
            %if J<31 %thenstart
               J=J+1
               A(J)=C
            %finish
         %finish
      %repeat
      A(0)=J
      %if s=string(addr(A(0))) %then %result=1
      %result=0
%end;! Checknus
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!
%finish

%if Target=M88000 %start

    %externalintegerfn Nusoption
         %if options2&nus=0 %then %result=0
         %result=1
    %end;! Nusoption

%finish
!
! Copyright (c) 1991 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!


%if Compiler= Fortran %thenstart

%externalroutine x %alias "pow_ri"
%end
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!
%finish

%endoffile
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!
services.i/     844774462   12014 11130 100644  48568     `
%constinteger malmon=0
%EXTERNAL %ROUTINE %SPEC Phex {*~np1 %alias "s_phex"}(%INTEGER n)
%EXTERNAL %INTEGER %FN %SPEC MALLOC(%INTEGER bytesize)
%INCLUDE "hostcodes.inc"
%CONSTINTEGER HOST=M88K
!%INCLUDE "tform2s"
!
! RECORDFORMAT FOR ALL THE OPTION AND FLAG VARAIBLES
!
! amended to remove non-alined longreal prior to bootstrapping to gould
!
%RECORDFORMAT PARMF(%INTEGER BITS1,BITS2,TTOPUT,
      %BYTEINTEGER LET,DYNAMIC,LINE,TRACE,ARR,DBUG,CHK,DIAG,OPT,FREE,
      LIST,CPRMODE,COMPILER,Z,Y,PROF,INHCODE,DCOMP,FAULTY,X,STACK,MAP,QUOTES,S2,
      %INTEGER LPOPUT,SP0)
%RECORDFORMAT LEVELF(%INTEGER RBASE, DIAGINF, RAL, FLAG, L, M, NMDECS, ONWORD, ONINF,
         LABEL, JROUND, UNATT FORMATS, PSIZE, ENTRYAD, DISPLAY, AUXSBASE, 
         NAMES, SNMAX,SN,RESSIZE,CLEVEL,SET, MAXPP, EXITLAB, CONTLAB, S3,
       %INTEGERARRAY AVL WSP(0:4))

%IF 1<<host&unsignedshorts=0 %START
%RECORDFORMAT RD((%INTEGER S1 %OR %SHORT PTYPE,%BYTE XB,FLAG),
      ((%INTEGER D %OR %REAL R),
      %INTEGER XTRA %OR %SHORT H0,H1,H2,H3 %OR %BYTE B0,B1,B2,B3,B4,B5,B6,B7))
%RECORDFORMAT TAGF((%SHORTINTEGER PTYPE,UIOJ,SNDISP,ACC,SLINK,KFORM %OR %C
      %INTEGER S1,S2,S3),%INTEGER LINK)
%RECORDFORMAT TRIPF(%BYTE OPERN,OPTYPE,CNT,DPTH,
      %SHORTINTEGER FLAGS,PUSE,FLINK,BLINK,%INTEGER X1,
      %RECORD(RD) OPND1,OPND2)
%RECORDFORMAT LISTF((%SHORTINTEGER PTYPE,(%SHORT UIOJ %OR %BYTE XB,FLAG),
      %SHORT SNDISP,ACC,SLINK,KFORM %OR  %INTEGER S1,S2,S3),%INTEGER LINK)
%FINISH %ELSE %START
%RECORDFORMAT RD((%INTEGER S1 %OR %HALF PTYPE,%BYTE XB,FLAG),
      ((%INTEGER D %OR %REAL R),
      %INTEGER XTRA %OR %HALF H0,H1,H2,H3 %OR %BYTE B0,B1,B2,B3,B4,B5,B6,B7))
%RECORDFORMAT TAGF((%HALFINTEGER PTYPE,UIOJ,SNDISP,ACC,SLINK,KFORM %OR %C
      %INTEGER S1,S2,S3),%INTEGER LINK)
%RECORDFORMAT TRIPF(%BYTE OPERN,OPTYPE,CNT,DPTH,
      %HALFINTEGER FLAGS,PUSE,FLINK,BLINK,%INTEGER X1,
      %RECORD(RD) OPND1,OPND2)
%RECORDFORMAT LISTF((%HALFINTEGER PTYPE,(%HALF UIOJ %OR %BYTE XB,FLAG),
      %HALF SNDISP,ACC,SLINK,KFORM %OR  %INTEGER S1,S2,S3),%INTEGER LINK)
%FINISH
%RECORDFORMAT WORKAF(%INTEGER NNAMES,CCSIZE,DSIZE,ASL MAX,ASL CUR BTM,CONST PTR,
      CONST BTM,LASTTRIP,WKFILEAD,WKFILEK,FILE ADDR,RELEASE,AASL0,CONST LIMIT,
      RTCOUNT,ARTOP,AMAINEP,DICTBASE,OPTCNT,INCLHEAD,S2,S3,S4,
      %INTEGERNAME LINE,N,S5,%STRING(9)LADATE,
      %BYTEINTEGERARRAYNAME CC,A,LETT,
      %INTEGERARRAYNAME WORD,TAGS,CTABLE,
      %RECORD(LEVELF)%ARRAYNAME LEVELINF,
      %INTEGERARRAY PLABS,PLINK(0:31),
      %RECORD(LISTF)%ARRAYNAME ASLIST)
!
! TRIPF_FLAGS SIGNIFY AS FOLLOWS
%CONSTINTEGER LEAVE STACKED=2****0;     ! SET LEAVE RESULT IN ESTACK
%CONSTINTEGER LOADOP1=2****1;           ! OPERAND 1 NEEDS LOADING
%CONSTINTEGER LOADOP2=2****2;           ! OPERAND 2 NEEDS LOADING
%CONSTINTEGER NOTINREG=2****3;          ! PREVENT REG OPTIMISNG
                                        ! OF TEMPS OVER LOOPS&JUMPS
%CONSTINTEGER USE ESTACK=2****4;        ! KEEP DUPLICATE IN ESTACK
%CONSTINTEGER USE MSTACK=2****5;        ! PUT DUPLICAT ON MSTACK
%CONSTINTEGER CONSTANTOP=2****6;        ! ONE OPERAND IS CONSTANT(FOR FOLDING)
%CONSTINTEGER COMMUTABLE=2****7;        ! OPERATION IS COMMUTABLE
%CONSTINTEGER USED LATE=2****13;        ! I-RESULT USED AFTER LAB OR A LONG WAY AHEAD
%CONSTINTEGER ASS LEVEL=2****14;        ! ASSEMBLER LEVEL OPERATION
%CONSTINTEGER DONT OPT=2****15;         ! DONT DUPLICATE THIS RESULT
                                        ! USED FOR BYTE PTR & OTHER SODS!
!
%RECORDFORMAT EMASFHDRF(%INTEGER ENDRA,STARTRA,FBYTESIZE,W3,W4,W5,W6,W7)
                                        ! FORMAT FOR ARRAY HEADS
! %END %OF  %FILE "TFORM2S"
%OWNINTEGERNAME ASL
%OWNRECORD(LISTF)%ARRAYNAME ASLIST
%EXTRINSICRECORD(WORKAF)WORKA
%EXTRINSICRECORD(PARMF)PARM
%EXTERNALROUTINE MOVE BYTES(%INTEGER LENGTH,FBASE,FOFF,TOBASE,TOOFF)
!************************************************************************
!*    A MOVE BYTES ROUTINE THAT WILL WORK ON WORD&BYTE ADDRESS M-CS    *
!***********************************************************************
%INTEGER I
AGN:
      %RETURN %IF LENGTH<=0
      %IF HOST=EMAS %START;             ! EMAS BYTE ADDRESSES
         I=X'18000000'+LENGTH
         *LDA_TOBASE; *INCA_TOOFF; *LDTB_I
         *LSS_FBASE; *IAD_FOFF; *LUH_I
         *MV_%L=%DR
      %FINISH %else %IF HOST=PERQ %START;             ! WORD ADDRESS+BYTE OFFSET
         FBASE=FBASE+FOFF>>1
         FOFF=FOFF&1
         TOBASE=TOBASE+TOOFF>>1
         TOOFF=TOOFF&1
         %IF (TOBASE+LENGTH>>1)>>16#TOBASE>>16 %OR %C
               (FBASE+LENGTH>>1)>>16#FBASE>>16 %START
                                        ! TLATE FAILS IF SEG BNDRY CROSSED
            MOVEBYTES(1,FBASE,FOFF,TOBASE,TOOFF)
            TOOFF=TOOFF+1
            FOFF=FOFF+1
            LENGTH=LENGTH-1
            ->AGN
         %FINISH
         *LDLDB_6;                      ! TO BASE
         *LDL8;                         ! TOOFF (BTM BITS)
         *LDLDB_2;                      ! FBASE
         *LDL4;                         ! FOFF
         *LDL0;                         ! LENGTH
         *STLATE_X'63'
         *MVBW
      %FINISH %else %IF HOST=ACCENT %START;             ! WORD ADDRESS+BYTE OFFSET
         FBASE=FBASE+FOFF>>1
         FOFF=FOFF&1
         TOBASE=TOBASE+TOOFF>>1
         TOOFF=TOOFF&1
         *LDLDB_6;                      ! TO BASE
         *LDL8;                         ! TOOFF (BTM BITS)
         *LDLDB_2;                      ! FBASE
         *LDL4;                         ! FOFF
         *LDL0;                         ! LENGTH
         *MVBW
      %FINISH %else %IF HOST=PNX %start
         FBASE=2*FBASE+FOFF
         TOBASE=2*TOBASE+TOOFF
         **FBASE
         **TOBASE
         **LENGTH
         *MVB
      %FINISH %else %IF 1<<host&emachine#0 %START 
         FBASE=FBASE+FOFF
         TOBASE=TOBASE+TOOFF
         **FBASE
         **TOBASE
         **LENGTH
         *MVB
      %FINISH %else %IF HOST=IBM %OR HOST=IBMXA %OR HOST=AMDAHL %START
         *L_0,TOBASE; *A_0,TOOFF
         *L_2,FBASE; *A_2,FOFF
         *L_1,LENGTH; *LR_3,1
         *MVCL_0,2
      %else
         FBASE=FBASE+FOFF
         TOBASE=TOBASE+TOOFF
         BYTEINTEGER(TOBASE+I)=BYTEINTEGER(FBASE+I) %FOR I=0,1,LENGTH-1
      %FINISH
%END
%EXTERNALSTRING(255)%FN PRINTNAME(%INTEGER N)
%CONSTSTRING(1)%ARRAY HEX(0:15)="0","1","2","3","4","5","6","7","8","9",
                                        "A","B","C","D","E","F";
%INTEGER V,K,TOP
%STRING(255) S
      S="?"
      TOP=N>>16
      N=N&X'FFFF'
      %IF 0<=N<=WORKA_NNAMES %START
         V=WORKA_WORD(N)
         K=WORKA_LETT(V)
         %IF K#0 %THEN S=STRING(ADDR(WORKA_LETT(V)))
      %FINISH
      %IF S="?" %START;                 ! UNPRINTABLE
         S=S.HEX(N>>K&15) %FOR K=28,-4,0
      %FINISH %ELSE %START
         %IF TOP>0 %THEN S=PRINTNAME(TOP)."_".S
      %FINISH
      %RESULT=S
%END


%STRINGFN MESSAGE(%INTEGER N)
!***********************************************************************
!*       OUTPUTS AN ERROR MESSAGE STORED IN A COMPRESSED FORMAT        *
!*       1  %REPEAT is not required                                    *
!*       2  Label & has already been set in this block                 *
!*       3  Jump into %CYCLE at Label & from line #                    *
!*       4  & is not a Switch name at current textual level            *
!*       5  Switch name & in expression or assignment                  *
!*       6  Switch label &(#) set a second time                        *
!*       7  Name & has already been declared                           *
!*       8  Routine or fn & has more parameters than specified         *
!*       9  Parameter # of & differs in type from specification        *
!*      10  Routine or fn & has fewer parameters than specified        *
!*      11  Label & referenced at line # has not been set              *
!*      12  %CYCLE at line # has two control clauses                   *
!*      13  %REPEAT for %CYCLE at line # is missing                    *
!*      14  %END is not required                                       *
!*      15  # %ENDs are missing                                        *
!*      16  Name & has not been declared                               *
!*      17  Name & does not require parameters or subscripts           *
!*      18  # too few parameters provided for &                        *
!*      19  # too many parameters provided for &                       *
!*      20  # too few subscripts provided for array &                  *
!*      21  # too many subscripts provided for array &                 *
!*      22  Actual parameter # of & conflicts with specification       *
!*      23  Routine name & in an expression                            *
!*      24  Integer operator has Real operands                         *
!*      25  Real expression in integer context                         *
!*      26  # is not a valid %EVENT number                             *
!*      27  & is not a routine name                                    *
!*      28  Routine or fn & has specification but no body              *
!*      29  %FUNCTION name & not in expression                         *
!*      30  %RETURN outwith routine body                               *
!*      31  %RESULT outwith fn or map body                             *
!*      34  Too many textual levels                                    *
!*      37  Array & has too many dimensions                            *
!*      38  Array & has upper bound # less than lower bound            *
!*      39  Size of Array & is more than X'FFFFFF' bytes               *
!*      40  Declaration is not at head of block                        *
!*      41  Constant cannot be evaluated at compile time               *
!*      42  # is an invalid repetition factor                          *
!*      43  %CONSTANT name & not in expression                         *
!*      44  Invalid constant initialising & after # items              *
!*      45  Array initialising items expected ## items given #         *
!*      46  Invalid %EXTERNAL %EXTRINSIC or variable %SPEC             *
!*      47  %ELSE already given at line #                              *
!*      48  %ELSE invalid after %ON %EVENT                             *
!*      49  Attempt to initialise %EXTRINSIC or %FORMAT &              *
!*      50  Subscript of # is outwith the bounds of &                  *
!*      51  %FINISH is not required                                    *
!*      52  %REPEAT instead of %FINISH for %START at line #            *
!*      53  %FINISH for %START at line # is missing                    *
!*      54  %EXIT outwith %CYCLE %REPEAT body                          *
!*      55  %CONTINUE outwith %CYCLE %REPEAT body                      *
!*      56  %EXTERNALROUTINE & at wrong textual level                  *
!*      57  Executable statement found at textual level zero           *
!*      58  Program among external routines                            *
!*      59  %FINISH instead of %REPEAT for %CYCLE at line #            *
!*      61  Name & has already been used in this %FORMAT               *
!*      62  & is not a %RECORD or %RECORD %FORMAT name                 *
!*      63  %RECORD length is greater than # bytes                     *
!*      64  Name & requires a subname in this context                  *
!*      65  Subname & is not in the %RECORD %FORMAT                    *
!*      66  Expression assigned to record &                            *
!*      67  Records && and & have different formats                    *
!*      69  Subname && is attached to & which is not of type %RECORD   *
!*      70  String declaration has invalid max length of #             *
!*      71  & is not a String variable                                 *
!*      72  Arithmetic operator in a String expression                 *
!*      73  Arithmetic constant in a String expression                 *
!*      74  Resolution is not the correct format                       *
!*      75  String expression contains a sub expression                *
!*      76  String variable & in arithmetic expression                 *
!*      77  String constant in arithmetic expression                   *
!*      78  String operator '.' in arithmetic expression               *
!*      80  Pointer variable & compared with expression                *
!*      81  Pointer variable & equivalenced to expression              *
!*      82  & is not a pointer name                                    *
!*      83  && and & are not equivalent in type                        *
!*      86  Global pointer && equivalenced to local &                  *
!*      87  %FORMAT name & used in expression                          *
!*      90  Untyped name & used in expression                          *
!*      91  %FOR control variable & not integer                        *
!*      92  %FOR clause has zero step                                  *
!*      93  %FOR clause has noninteger number of traverses             *
!*      95  Name & not valid in assembler                              *
!*      96  Operand # not valid in assembler                           *
!*      97  Assembler construction not valid                           *
!*      98  Addressability                                             *
!*      99  Facility not supported by target hardware                  *
!*     101  Source line has too many continuations                     *
!*     102  Workfile of # Kbytes is too small                          *
!*     103  Dictionary completely full                                 *
!*     104  Dictionary completely full                                 *
!*     105  Too many textual levels                                    *
!*     106  String constant too long                                   *
!*     107  Compiler tables are completely full                        *
!*     108  Condition too complicated                                  *
!*     109  Compiler inconsistent                                      *
!*     110  Input ended                                                *
!*     201  Long integers are inefficient as subscripts                *
!*     202  Name & not used                                            *
!*     203  Label & not used                                           *
!*     204  Global %FOR control variable &                             *
!*     205  Name & not addressable                                     *
!*     206  Semicolon in comment text                                  *
!*     207  %CONSTANT variable & not initialised                       *
!*     208  Unsupported precision used - nearest available substituted *
!*     209  Target machine is word addressed                           *
!*     210  Redundant %ALIAS provided                                  *
!*     211  Prefix %SYSTEM not supported. Use %ALIAS                   *
!*     212  Unproductive logical operation noted                       *
!*     255  Contact Advisory Service                                   *
!***********************************************************************
%CONSTBYTEINTEGERARRAY OUTTT(0:63)='?','A','B','C','D','E','F','G',
                                        'H','I','J','K','L','M','N',
                                        'O','P','Q','R','S','T','U',
                                        'V','W','X','Y','Z','&','-',
                                        '/','''','(',')',
                                        'a','b','c','d','e','f','g',
                                        'h','i','j','k','l','m','n',
                                        'o','p','q','r','s','t','u',
                                        'v','w','x','y','z','.','%',
                                        '#','?'(2)
%CONSTINTEGER WORDMAX= 802,DEFAULT= 798
%CONSTshortINTEGERARRAY WORD(0:WORDMAX)=0,%C
              1, 32769, 32771, 32772, 32773,     2, 32775, 32776,
          32777, 32778, 32780, 32781, 32782, 32783, 32784,     3,
          32785, 32786, 32787, 32789, 32775, 32776, 32790, 32791,
          32792,     4, 32776, 32771, 32772, 32793, 32794, 32796,
          32789, 32797, 32799, 32801,     5, 32794, 32796, 32776,
          32782, 32802, 32804, 32805,     6, 32794, 32807, 32808,
          32781, 32793, 32809, 32811,     7, 32812, 32776, 32777,
          32778, 32780, 32813,     8, 32815, 32804, 32817, 32776,
          32777, 32818, 32819, 32821, 32822,     9, 32824, 32792,
          32826, 32776, 32827, 32782, 32829, 32790, 32830,    10,
          32815, 32804, 32817, 32776, 32777, 32833, 32819, 32821,
          32822,    11, 32775, 32776, 32834, 32789, 32791, 32792,
          32777, 32772, 32780, 32781,    12, 32787, 32789, 32791,
          32792, 32777, 32836, 32837, 32839,    13, 32769, 32841,
          32787, 32789, 32791, 32792, 32771, 32842,    14, 32844,
          32771, 32772, 32773,    15, 32792, 32845, 32846, 32842,
             16, 32812, 32776, 32777, 32772, 32780, 32813,    17,
          32812, 32776, 32847, 32772, 32848, 32819, 32804, 32850,
             18, 32792, 32852, 32853, 32819, 32854, 32841, 32776,
             19, 32792, 32852, 32856, 32819, 32854, 32841, 32776,
             20, 32792, 32852, 32853, 32850, 32854, 32841, 32857,
          32776,    21, 32792, 32852, 32856, 32850, 32854, 32841,
          32857, 32776,    22, 32858, 32860, 32792, 32826, 32776,
          32862, 32864, 32830,    23, 32815, 32796, 32776, 32782,
          32865, 32802,    24, 32866, 32868, 32777, 32870, 32871,
             25, 32870, 32802, 32782, 32873, 32875,    26, 32792,
          32771, 32772, 32793, 32877, 32878, 32880,    27, 32776,
          32771, 32772, 32793, 32882, 32796,    28, 32815, 32804,
          32817, 32776, 32777, 32830, 32884, 32885, 32886,    29,
          32887, 32796, 32776, 32772, 32782, 32802,    30, 32889,
          32891, 32882, 32886,    31, 32893, 32891, 32817, 32804,
          32895, 32886,    34, 32896, 32856, 32799, 32897,    37,
          32899, 32776, 32777, 32852, 32856, 32900,    38, 32899,
          32776, 32777, 32902, 32903, 32792, 32904, 32821, 32905,
          32903,    39, 32906, 32826, 32899, 32776, 32771, 32818,
          32821, 32907, 32909,    40, 32910, 32771, 32772, 32789,
          32913, 32826, 32784,    41, 32914, 32916, 32918, 32919,
          32789, 32921, 32811,    42, 32792, 32771, 32865, 32923,
          32925, 32927,    43, 32929, 32796, 32776, 32772, 32782,
          32802,    44, 32931, 32933, 32935, 32776, 32938, 32792,
          32939,    45, 32899, 32935, 32939, 32940, 32942, 32939,
          32943, 32792,    46, 32931, 32944, 32946, 32804, 32948,
          32950,    47, 32951, 32778, 32943, 32789, 32791, 32792,
             48, 32951, 32923, 32938, 32952, 32878,    49, 32953,
          32955, 32956, 32946, 32804, 32958, 32776,    50, 32960,
          32826, 32792, 32771, 32891, 32962, 32963, 32826, 32776,
             51, 32965, 32771, 32772, 32773,    52, 32769, 32967,
          32826, 32965, 32841, 32969, 32789, 32791, 32792,    53,
          32965, 32841, 32969, 32789, 32791, 32792, 32771, 32842,
             54, 32971, 32891, 32787, 32769, 32886,    55, 32972,
          32891, 32787, 32769, 32886,    56, 32974, 32776, 32789,
          32978, 32799, 32801,    57, 32979, 32981, 32983, 32789,
          32799, 32801, 32984,    58, 32985, 32987, 32988, 32990,
             59, 32965, 32967, 32826, 32769, 32841, 32787, 32789,
          32791, 32792,    61, 32812, 32776, 32777, 32778, 32780,
          32992, 32782, 32783, 32958,    62, 32776, 32771, 32772,
          32793, 32993, 32804, 32993, 32958, 32796,    63, 32993,
          32995, 32771, 32997, 32821, 32792, 32909,    64, 32812,
          32776, 32999, 32793, 33001, 32782, 32783, 32875,    65,
          33003, 32776, 32771, 32772, 32782, 32962, 32993, 32958,
             66, 33005, 33007, 32955, 33009, 32776,    67, 33011,
          33013, 33014, 32776, 33015, 33016, 33018,    69, 33003,
          33013, 32771, 33020, 32955, 32776, 33022, 32771, 32772,
          32826, 32829, 32993,    70, 33023, 33025, 32777, 32923,
          33028, 32995, 32826, 32792,    71, 32776, 32771, 32772,
          32793, 33023, 32948,    72, 33029, 32868, 32782, 32793,
          33023, 32802,    73, 33029, 32933, 32782, 32793, 33023,
          32802,    74, 33031, 32771, 32772, 32962, 33033, 33035,
             75, 33023, 32802, 33037, 32793, 33039, 32802,    76,
          33023, 32948, 32776, 32782, 33040, 32802,    77, 33023,
          32933, 32782, 33040, 32802,    78, 33023, 32868, 33042,
          32782, 33040, 32802,    80, 33043, 32948, 32776, 33045,
          32864, 32802,    81, 33043, 32948, 32776, 33047, 32955,
          32802,    82, 32776, 32771, 32772, 32793, 33050, 32796,
             83, 33013, 33014, 32776, 32846, 32772, 33052, 32782,
          32829,    86, 33054, 33050, 33013, 33047, 32955, 33056,
          32776,    87, 32958, 32796, 32776, 32992, 32782, 32802,
             90, 33057, 32796, 32776, 32992, 32782, 32802,    91,
          33059, 32837, 32948, 32776, 32772, 32873,    92, 33059,
          33060, 32777, 32984, 33062,    93, 33059, 33060, 32777,
          33063, 32880, 32826, 33065,    90, 33057, 32796, 32776,
          32992, 33067, 32948,    95, 32812, 32776, 32772, 32877,
          32782, 33068,    96, 33070, 32792, 32772, 32877, 32782,
          33068,    97, 33072, 33074, 32772, 32877,    98, 33077,
             99, 33080, 32772, 33082, 33084, 33085, 33087,   101,
          33089, 32791, 32777, 32852, 32856, 33091,   102, 33094,
          32826, 32792, 33096, 32771, 32852, 33098,   103, 33099,
          33101, 33103,   104, 33099, 33101, 33103,   105, 32896,
          32856, 32799, 32897,   106, 33023, 32933, 32852, 33104,
            107, 33105, 33107, 32846, 33101, 33103,   108, 33109,
          32852, 33111,   109, 33105, 33114,   110, 33117, 33118,
            201, 33119, 33120, 32846, 33122, 33067, 32850,   202,
          32812, 32776, 32772, 32992,   203, 32775, 32776, 32772,
          32992,   204, 33054, 33059, 32837, 32948, 32776,   205,
          32812, 32776, 32772, 33125,   206, 33128, 32782, 33130,
          33132,   207, 32929, 32948, 32776, 32772, 33133,   208,
          33136, 33139, 32992, 33141, 33142, 33144, 33146,   209,
          33149, 33151, 32771, 33153, 33154,   210, 33156, 33158,
          32854,   211, 33160, 33162, 32772, 33164, 33166, 33158,
            212, 33167, 33170, 33172, 33174,   255, 33175, 33177,
          33179,     0
%CONSTINTEGERARRAY LETT(0: 412)=0,%C
        X'7890A80B',X'02A00000',X'53980000',X'5D7E8000',
        X'652E3AD3',X'652C8000',X'190C52D8',X'36000000',
        X'510E6000',X'436652C3',X'49C80000',X'452CB700',
        X'672E8000',X'53700000',X'69453980',X'4565F1D6',
        X'15ADB800',X'53769780',X'781B2199',X'0A000000',
        X'43A00000',X'4D95F680',X'594DD280',X'7A000000',
        X'42000000',X'27BD3A47',X'50000000',X'5D0DB280',
        X'47AE594B',X'5DA00000',X'692F1A6B',X'43600000',
        X'592ED2D8',X'4BC6194B',X'679D37DC',X'5F900000',
        X'439E74CF',X'5D6CB768',X'590C52D8',X'36FFB000',
        X'672C77DD',X'48000000',X'694DB280',X'1D0DB280',
        X'492C7643',X'652C8000',X'257EBA53',X'5D280000',
        X'4D700000',X'5B7E5280',X'610E50DB',X'4BA4B966',
        X'69443700',X'6784B1D3',X'4D4CB200',X'210E50DB',
        X'4BA4B900',X'5F300000',X'494CD34B',X'65980000',
        X'69CE1280',X'6784B1D3',X'4D4C70E9',X'537DC000',
        X'4D2EF2E4',X'652CD2E5',X'4B7472C8',X'69BDE000',
        X'477DDA65',X'5F600000',X'47643AE7',X'4B980000',
        X'4D7E4000',X'5B4E79D3',X'5D380000',X'7829C200',
        X'7829C266',X'4394A000',X'497CB980',X'652E3AD3',
        X'65280000',X'67AC59C7',X'654E1A66',X'697DE000',
        X'4D2EE000',X'6195FB53',X'492C8000',X'5B0DDC80',
        X'439650F2',X'031E9AC3',X'58000000',X'610E50DB',
        X'4BA4B900',X'477DD359',X'531E9980',X'6F4E9400',
        X'43700000',X'137692CF',X'4B900000',X'5F84B943',
        X'697E4000',X'252C3600',X'5F84B943',X'5D266000',
        X'537692CF',X'4B900000',X'477DDA4B',X'71A00000',
        X'6D0D94C8',X'782AC29D',X'28000000',X'5DADB14B',
        X'64000000',X'657EBA53',X'5D280000',X'45AE8000',
        X'5D780000',X'457C9C80',X'7832A707',X'2849E700',
        X'7890AA2B',X'24700000',X'5FAE9BD3',X'69400000',
        X'7890A9AB',X'18A00000',X'5B0E0000',X'297DE000',
        X'592ED2D9',X'66000000',X'039650F2',X'494DB2DD',
        X'674DF766',X'6B8612E4',X'457EB748',X'592E7980',
        X'597EF2E4',X'274F5280',X'30F0C30D',X'0C30CF00',
        X'45CE92E6',X'092C7643',X'650E94DF',X'5C000000',
        X'512C3200',X'077DD9E9',X'43768000',X'470DD75F',
        X'68000000',X'45280000',X'4BB4366B',X'43A4B200',
        X'477DB853',X'59280000',X'5376D0D9',X'53200000',
        X'652E12E9',X'53A537DC',X'4D0C7A5F',X'64000000',
        X'7819E727',X'2809CA00',X'1376D0D9',X'53200000',
        X'477DD9E9',X'43768000',X'53753A53',X'436539D3',
        X'5D380000',X'433692E4',X'53A4B6E6',X'4BC612C7',
        X'692C8000',X'7BE80000',X'4F4ED2DC',X'782B0A0B',
        X'24702600',X'782B0A25',X'12726486',X'6D0E54C3',
        X'4564A000',X'789A0286',X'7829898A',X'7879C000',
        X'03A692DB',X'61A00000',X'69780000',X'53753A53',
        X'436539CA',X'7831E91B',X'02A00000',X'27AC59C7',
        X'654E1A00',X'6944A000',X'457EB749',X'66000000',
        X'78312713',X'26400000',X'53767A4B',X'43200000',
        X'789A80A5',X'28000000',X'782B04A8',X'7819E729',
        X'1272A280',X'782B0A0B',X'24702625',X'1EAA849D',
        X'0A000000',X'6F95F74E',X'0BC4B1EB',X'690C564A',
        X'67A43A4B',X'5B2DDA00',X'4D7EB748',X'752E5780',
        X'2195F3E5',X'43680000',X'436DF74E',X'4BC692E5',
        X'5D0D8000',X'657EBA53',X'5D2E6000',X'6B9CB200',
        X'7890A19F',X'24200000',X'592DD3E9',X'50000000',
        X'4F94B0E9',X'4B900000',X'652E3AD3',X'652E6000',
        X'67AC5743',X'5B280000',X'27AC5743',X'5B280000',
        X'0BC6194B',X'679D37DC',X'439E74CF',X'5D2C8000',
        X'652C77E5',X'48000000',X'252C77E5',X'49980000',
        X'36D80000',X'43748000',X'510ED280',X'494CD34B',
        X'652DDA00',X'4D7E56C3',X'69980000',X'43A690C7',
        X'512C8000',X'6F4531D0',X'27A654DD',X'4E000000',
        X'492C7643',X'650E94DF',X'5C000000',X'5B0F0000',
        X'03953A51',X'5B2E94C6',X'252E77D9',X'6BA537DC',
        X'477E594B',X'47A00000',X'4D7E56C3',X'68000000',
        X'477DDA43',X'53766000',X'67AC4000',X'43953A51',
        X'5B2E94C6',X'3DDBC000',X'217D3769',X'4B900000',
        X'477DB843',X'652C8000',X'4B8EB4ED',X'4364B747',
        X'4B200000',X'617D3769',X'4B900000',X'4B8EB4ED',
        X'4364B768',X'0F65F143',X'58000000',X'597C70D8',
        X'2B769CE1',X'4B200000',X'7831E900',X'47643AE7',
        X'4A000000',X'67A4B800',X'5D7DD4DD',X'692CF2E4',
        X'69943B4B',X'659CB980',X'43980000',X'439E72DB',
        X'4564B900',X'1F84B943',X'5D200000',X'039E72DB',
        X'4564B900',X'477DD9E9',X'65AC7A53',X'5F700000',
        X'0324994B',X'679C3153',X'594E9C80',X'0D0C74D9',
        X'53A72000',X'67AE185F',X'65A4B200',X'45C80000',
        X'690E53CB',X'68000000',X'510E526F',X'4394A000',
        X'277EB947',X'4A000000',X'477DDA53',X'5DAC3A53',
        X'5F766000',X'2F7E55CD',X'5364A000',X'17173A4B',
        X'66000000',X'676C3658',X'094C7A53',X'5F743972',
        X'477DB859',X'4BA4B672',X'4DAD9600',X'597DD380',
        X'077DB853',X'592E4000',X'690C564B',X'66000000',
        X'077DD253',X'694DF700',X'477DB859',X'531C3A4B',
        X'48000000',X'537477DD',X'674E7A4B',X'5DA00000',
        X'13761AE8',X'4B7492C8',X'197DD380',X'537692CF',
        X'4B966000',X'5374B34D',X'531D32DD',X'68000000',
        X'4324994B',X'679C3159',X'4A000000',X'272DB4C7',
        X'5F65F700',X'477DB6CB',X'5DA00000',X'692F1A00',
        X'53753A53',X'436539CB',X'48000000',X'2B767AE1',
        X'617E5A4B',X'48000000',X'6194B1D3',X'674DF700',
        X'38000000',X'5D2C394B',X'67A00000',X'43B434D9',
        X'43159280',X'67AC59E9',X'53A6BA4B',X'48000000',
        X'290E53CB',X'68000000',X'5B0C7453',X'5D280000',
        X'6F7E5200',X'4324994B',X'679CB200',X'252C9ADD',
        X'490DDA00',X'78098483',X'26000000',X'2194B353',
        X'70000000',X'789B29A9',X'0A680000',X'67AE185F',
        X'65A4B276',X'2B9CA000',X'2B76195F',X'49AC7A53',
        X'6D280000',X'597CF4C7',X'43600000',X'5F84B943',
        X'694DF700',X'5D7E92C8',X'077DDA43',X'47A00000',
        X'0326D4E7',X'5F972000',X'272E5B53',X'47280000'
        
%INTEGER I,J,K,M,Q,S
%STRING(70)OMESS
      OMESS=" "
      %CYCLE I=1,1,WORDMAX-1
         ->FOUND %IF N=WORD(I)
      %REPEAT
      I=DEFAULT
FOUND:
      J=1
      %CYCLE
         K=WORD(I+J)
         %IF K&X'8000'=0 %THEN %EXIT
         K=K&X'7FFF'
         OMESS=OMESS." " %UNLESS J=1
         %UNTIL M&1=0 %CYCLE
            M=LETT(K); S=25
            %UNTIL S<0 %CYCLE
               Q=M>>S&63; 
               %IF Q\=0 %THEN OMESS=OMESS.TOSTRING(OUTTT(Q))
               S=S-6
            %REPEAT
            K=K+1
         %REPEAT
         J=J+1
      %REPEAT
      %RESULT=OMESS
%END
%EXTERNALSTRING(16)%FN SWRITE(%INTEGER VALUE, PLACES)
%STRING (16) S
%STRING(1)SIGN
%INTEGER D0, D1, D2
      PLACES=PLACES&15
      SIGN=" "
      S=""
      %IF VALUE<0 %THEN SIGN="-" %AND VALUE=-VALUE
      D0=VALUE
      %CYCLE
         D1=D0//10
         D2=D0-10*D1
         S=TOSTRING(D2+'0').S
         D0=D1
      %REPEAT %UNTIL D0=0
      S=SIGN.S
      S=" ".S %WHILE LENGTH(S)<=PLACES
      %RESULT=S
%END
%EXTERNALROUTINE FAULT(%INTEGER N, DATA, IDENT)
!***********************************************************************
!*    SETS UP AN ERROR MESSAGE AND SHOVES IT OUT ONTO THE LISTING      *
!*    AN ALSO OPTIONALLY TO THE TERMINAL                               *
!***********************************************************************
%INTEGER I, J, S, T, Q, QMAX, LENGTH
%STRING(255)MESS1,MESS2,WK1,WK2
!*DELSTART
      %MONITOR %IF (PARM_FAULTY=0 %or n>100) %AND (PARM_Z#0 %OR PARM_DCOMP#0)
!*DELEND
      MESS1=""; MESS2=""
      %if parm_faulty < 255 %then PARM_FAULTY=PARM_FAULTY+1
      %IF N=100 %THEN %START;           ! SYNTAX FAULTS ARE SPECIAL
         MESS1="
*    Failed to analyse line ".SWRITE(WORKA_LINE,2)."
     "
         J=0;  S=0;  T=0;  Q=DATA;  QMAX=IDENT>>16
         LENGTH=IDENT&X'FFFF'
         %UNTIL (J=';' %AND Q>QMAX) %OR Q=LENGTH %CYCLE
            I=J;  J=WORKA_CC(Q);        ! DATA HAS START OF LINE POSN
            %IF J>128 %AND I<128 %THEN MESS2=MESS2." %" %AND T=T+2
            %IF I>128 %AND J<128 %THEN MESS2=MESS2." " %AND T=T+1
            %IF Q=QMAX %THEN %START
               S=T+1
               %IF S>=11 %THEN MESS2=MESS2."?" %AND T=T+1
            %FINISH
            MESS2=MESS2.TOSTRING(J&127)
            T=T+1
            Q=Q+1
            %EXIT %IF T>=250
         %REPEAT
         %IF Q=QMAX %THEN S=T
      %FINISH %ELSE %START
         MESS1="
*".SWRITE(WORKA_LINE, 4)."   "
         PARM_OPT=1
         PARM_INHCODE=1 %IF PARM_LET=0;    ! STOP GENERATING CODE
         MESS1=MESS1."FAULT".SWRITE(N,2)
         MESS2=MESSAGE(N)
         %IF MESS2->WK1.("##").WK2 %THEN %C
            MESS2=WK1.SWRITE(IDENT,1).WK2
         %IF MESS2->WK1.("#").WK2 %THEN %C
            MESS2=WK1.SWRITE(DATA,1).WK2
         %IF MESS2->WK1.("&&").WK2 %THEN %C
            MESS2=WK1.PRINTNAME(DATA).WK2
         %IF MESS2->WK1.("&").WK2 %THEN %C
               MESS2=WK1.PRINTNAME(IDENT).WK2
         %IF N>100 %THEN MESS2=MESS2." Disaster"
      %FINISH
         SELECT OUTPUT(PARM_TTOPUT) %unless PARM_TTOPUT=-1
         PRINTSTRING(MESS1)
         PRINTSTRING(MESS2) %IF MESS2#""
         %IF N=100 %AND S<115 %THEN %START
            NEWLINE; SPACES(S+4); PRINTSYMBOL('!')
         %FINISH
         NEWLINE
         SELECT OUTPUT(parm_lpoput) %unless PARM_TTOPUT=-1
      %IF N=109 %THEN %MONITOR
!      %IF N=109 %THEN PARM_DCOMP=1 %AND CODEOUT
      %IF N>100 %THEN %STOP
%END
%EXTERNALROUTINE WARN(%INTEGER N,V)
%string (255) mess
      %return %if worka_line>=20000     { In an included file }
      %if n=10 %start
        mess="
? Warning: Inspect the C produced for input line ".SWRITE(WORKA_LINE,2)."
"
         select output( PARM_TTOPUT) %unless PARM_TTOPUT=-1
         printstring(mess)
         select output(parm_lpoput) %unless PARM_TTOPUT=-1
      %finish
      %if n=11 %start
         mess="
? Warning: Structure member name the same as defined name line ".SWRITE(WORKA_LINE,2)."
"
         select output( PARM_TTOPUT) %unless PARM_TTOPUT=-1
         printstring(mess)
         select output(parm_lpoput) %unless PARM_TTOPUT=-1
      %finish
     %if n=12 %start
         mess="
? Warning: Possible Missed comment at line ".SWRITE(WORKA_LINE,2)."
"
         select output( PARM_TTOPUT) %unless PARM_TTOPUT=-1
         printstring(mess)
         select output(parm_lpoput) %unless PARM_TTOPUT=-1
      %finish
      %if n=13 %start
        mess="
? Warning: No dope vector found for array access at line ".SWRITE(WORKA_LINE,2)."
           Lower bound(s) of zero perforce assumed
"
         select output( PARM_TTOPUT) %unless PARM_TTOPUT=-1
         printstring(mess)
         select output(parm_lpoput) %unless PARM_TTOPUT=-1
      %finish
%END
%EXTERNALROUTINE PRHEX(%INTEGER VALUE, PLACES)
%CONSTBYTEINTEGERARRAY HEX(0:15)='0','1','2','3','4',
               '5','6','7','8','9','A','B','C','D','E','F'
%INTEGER I
      %CYCLE I=PLACES<<2-4, -4, 0
         PRINT SYMBOL(HEX(VALUE>>I&15))
      %REPEAT
%END
%EXTERNALROUTINE PRINT THIS TRIP(%RECORD(TRIPF)%ARRAYNAME TRIPS,
      %INTEGER I)
!***********************************************************************
!*    OUTPUTS A TRIPLE IN READABLE FORM                                *
!***********************************************************************
%CONST%STRING(5)%ARRAY OPERATION(0:192)= %C
         "  ?  ","RT HD","RDSPY","RDARE","RDPTR",
         "RTBAD","RTXIT","XSTOP","  ?  ","  ?  ",
         "  \  ","  -U "," FLT "," ABS ","SHRNK",
         "STRCH"," JAM "," ??? ","NO OP","PRELD",
         "  ?  ","SSPTR","RSPTR","ASPTR","DARRY",
         "SLINE","STPCK","FRPRE","FPOST","FRPR2",
         "PRECL","RCALL","RCRFR","RCRMR","  ?  ",
         "GETAD"," INT ","INTPT","TOSTR","MNITR",
         "PPROF","RTFP ","ONEV1","ONEV2","DVSTT",
         "DVEND","FREND","DMASS","  ?  "(2),
         "UCNOP","UCB1 ","UCB2 ","UCB3 "," UCW ",
         "UCBW ","UCWW ","UCLW ","UCB2W","UCNAM",
         "  ?  "(68),
         "  +  ","  -  ","  !! ","  !  ","  *  ",
         "  // ","  /  ","  &  ","  >> ","  << ",
         " REXP"," COMP","DCOMP"," VMY "," COMB",
         "  =  ","  <- "," IEXP"," ADJ ","AINDX",
         "IFTCH","LASS ","FORCK","PRECC","CNCAT",
         "IOCPC","PASS1","PASS2","PASS3",
         "PASS4","PASS5","PASS6",
         "BJUMP","FJUMP","REMLB","TLAB ","DCLSW",
         "SETSW","-> SW"," S=1 "," S=2 "," S<- ",
         "AHASS","PTRAS","MAPRS","FNRES","SCOMP",
         "SDCMP","PRES1","PRES2","RESLN","RESFN",
         "SIGEV","RECAS","AAINC","AHADJ","CTGEN",
         "GETPR","SINDX","ZCOMP","CLSFT","CASFT",
         "DVBPR","RSTRE","MULTX";
%RECORD(TRIPF)%NAME CURR
%ROUTINESPEC OPOUT(%RECORD(RD)%NAME OPND)
      NEWLINE
      CURR==TRIPS(I)
      WRITE(I,2)
      SPACE
      PRINTSTRING(OPERATION(CURR_OPERN))
      SPACE
      PRHEX(CURR_OPTYPE,2)
      WRITE(CURR_CNT,2)
      WRITE(CURR_DPTH,2)
      SPACES(1)
      PRHEX(CURR_FLAGS,4)
      WRITE(CURR_PUSE,3)
      SPACE
      PRHEX(CURR_X1,8)
      SPACE
      OPOUT(CURR_OPND1)
      OPOUT(CURR_OPND2) %IF CURR_OPERN>=128
      %RETURN
%ROUTINE OPOUT(%RECORD(RD)%NAME OPND)
%STRING(17)T
%STRING(8)S
%INTEGER I,J
%SWITCH SW(0:11)
      PRHEX(OPND_PTYPE,4)
      J=OPND _FLAG
      ->SW(J) %UNLESS J>11
      PRINTSTRING("?")
      PRHEX(OPND_S1&X'FFFF',4)
      SPACE
      PRHEX(OPND_D,8)
      SPACE
      PRHEX(OPND_XTRA,8)
      %RETURN
SW(0):SW(1):                            ! CONSTANT
      %if j=0 %then printstring("s") %else PRINTSTRING(" ")
      %IF OPND_PTYPE&7=5 %START;        ! STRING CONSTS
         I=WORKA_A(OPND_D)
            I=17 %IF I>17
         LENGTH(T)=I
         %CYCLE I=1,1,I
            J=WORKA_A(OPND_D+I)
            J='_' %IF J<=31
            CHARNO(T,I)=J
            %REPEAT
         T<-T."                    "
         PRINTSTRING(T)
      %FINISH %ELSE %START
         PRHEX(OPND_D,8)
         SPACES(4)
         %IF OPND_PTYPE>>4>5 %THEN PRHEX(OPND_XTRA,8) %ELSE SPACES(8)
      %FINISH
      SPACES(2)
      %RETURN
SW(2):                                  ! NAME
      PRINTSTRING(" NAME ")
NAM:  S<-PRINTNAME(OPND_D)."                "
      PRINTSTRING(S)
      %IF OPND_XTRA#0 %THEN PRHEX(OPND_XTRA,8) %ELSE SPACES(8)
      SPACE
      %RETURN
sw(3):
    printstring(" AR ptr "); write(opnd_d,2); spaces(10)
     %return
SW(4):                                  ! VIA STORED POINTER @TRIPLE
      PRINTSTRING("OFFSET-PTR")
      ->COM
SW(5):                                  ! 32 BIT ADDRESS
      PRINTSTRING(" PNTR ")
      ->NAM
SW(7):                                  ! IN A STACK FRAME
      PRINTSTRING(" TEMP ")
      PRHEX(OPND_D,8)
      SPACE
      PRHEX(OPND_XTRA,8)
      %RETURN
SW(6):                                  ! INDIRECT
      PRINTSTRING(" IND-OFFST")
COM:  WRITE(OPND_D,2)
      SPACE
      PRHEX(OPND_XTRA,8)
      SPACE
      %RETURN
SW(8):                                  ! A TRIPLE
      PRINTSTRING(" TRIPLE ")
      WRITE(OPND_D,2)
      SPACES(12)
      %RETURN
SW(9):                                  ! REGISTER ITEM
      PRINTSTRING(" ITEM IN REGSTR ")
      SPACES(4)
      %RETURN
SW(10):                                 ! B-D FORFM
      PRINTSTRING("BASE&DIS ")
      PRHEX(OPND_XB,2)
      SPACE
      PRHEX(OPND_D,8)
      %RETURN
SW(11):                                 ! VIA LA ON B&D
      PRINTSTRING("ADDR(B&D)")
      PRHEX(OPND_XB,2)
      SPACE
      PRHEX(OPND_D,8)
%END
%END
%EXTERNALROUTINE PRINT TRIPS(%RECORD(TRIPF)%ARRAYNAME TRIPS)
%INTEGER I
!      %RETURN %IF PARM_Y=0 %AND PARM_Z=0;! TRIPLES ON CODE+PARMY OR Z
      PRINTSTRING("
TRIPLES FOR LINE"); WRITE(WORKA_LINE,3)
      PRINTSTRING("
 NO OPRN  PT  C  D FLGS PUSE   X1         OPERAND 1                  OPERAND 2")
      I=TRIPS(0)_FLINK
      %WHILE I>0 %CYCLE
         PRINT THIS TRIP(TRIPS,I)
         I=TRIPS(I)_FLINK
      %REPEAT
%END
%EXTERNALROUTINE INITASL(%RECORD(LISTF)%ARRAYNAME SPACE,%INTEGERNAME PTR)
!***********************************************************************
!*    INITIALISES THE ASL AND REMEMBERS IT LOCATION
!***********************************************************************
%INTEGER I
      ASLIST==SPACE
      ASL==PTR
      WORKA_ASL CUR BTM=ASL-240
      WORKA_CONST LIMIT=4*WORKA_ASL CUR BTM-8
      %CYCLE I=WORKA_ASL CUR BTM,1,ASL-1
         aslist(i+1)=0
          ASLIST(I+1)_LINK=I
      %REPEAT
      ASLIST(WORKA_ASL CUR BTM)_LINK=0
      ASLIST(0)_S1=-1
      ASLIST(0)_S2=-1
      ASLIST(0)_S3=-1
      ASLIST(0)_LINK=0
%END
%EXTERNALROUTINE PRINT LIST(%INTEGER HEAD)
!***********************************************************************
!*    A DEBUGGING ONLY ROUTINE. 
!***********************************************************************
%RECORD(LISTF)%NAME LCELL
%INTEGER I,J,K
      PRINTSTRING("
PRINT OF LIST ")
      WRITE(HEAD,2)
      NEWLINE
      %WHILE HEAD#0 %CYCLE
         LCELL==ASLIST(HEAD)
         WRITE(HEAD,3)
         SPACES(3)
         PRHEX(LCELL_S1,8)
         SPACES(3)
         PRHEX(LCELL_S2,8)
         SPACES(3)
         PRHEX(LCELL_S3,8)
         SPACES(3)
         PRHEX(LCELL_LINK,8)
         NEWLINE
         HEAD=LCELL_LINK&X'FFFF';       ! EXTRA LINK IN TAGS LIST!!
      %REPEAT
%END
%EXTERNALROUTINE CHECK ASL
!***********************************************************************
!*    CHECK ASL AND PRINT NO OF FREE CELLS. DEBUGGING SERVICE ONLY     *
!***********************************************************************
%INTEGER N,Q
      Q=ASL; N=0
      %WHILE Q#0 %CYCLE
         N=N+1
         Q=ASLIST(Q)_LINK
      %REPEAT
      NEWLINE
      PRINTSTRING("FREE CELLS AFTER LINE ")
      WRITE(WORKA_LINE,3)
      PRINTSYMBOL('=')
      WRITE(N,3)
%END
%EXTERNALINTEGERFN MORE SPACE
!***********************************************************************
!*    FORMATS UP SOME MORE OF THE ASL                                  *
!***********************************************************************
%INTEGER I,N,CL,AMOUNT
      N=WORKA_ASL CUR BTM-1
      AMOUNT=(WORKA_NNAMES+1)>>3;             ! EIGHTTH OF NNAMES
      I=WORKA_ASL CUR BTM-((WORKA_CONST PTR+8)>>2);! GAP BETWEEN CONSTS &ASL
      %IF I>>1<AMOUNT %THEN AMOUNT=I>>1;! TAKE ONLY HALF THE REMAINDER
      %IF AMOUNT<20 %THEN AMOUNT=0
      WORKA_ASL CUR BTM=WORKA_ASL CUR BTM-AMOUNT
      %IF WORKA_ASL CUR BTM<=1 %THEN WORKA_ASL CUR BTM=1
      CL=4*WORKA_ASL CUR BTM-8
      %IF WORKA_ASL CUR BTM>=N %OR WORKA_CONST PTR>CL %THEN %START
         FAULT(102, WORKA_WKFILEK,0)
      %FINISH %ELSE WORKA_CONST LIMIT=CL;     ! NEW VALUE WITH BIGGER ASL
      %CYCLE I=WORKA_ASL CUR BTM,1,N-1
         ASLIST(I+1)_LINK=I
      %REPEAT
      ASLIST(WORKA_ASL CUR BTM)_LINK=0
      ASL=N; %RESULT=N
%END
!%EXTERNALINTEGERFN NEW CELL
!***********************************************************************
!*       PROVIDE A NEW LIST PROCESSING CELL. CRAPOUT IF NONE AVAILABLE *
!***********************************************************************
!%INTEGER I
!         %IF ASL=0 %THEN ASL=MORE SPACE
!         I=ASL
!         ASL=ASLIST(ASL)_LINK
!         ASLIST(I)_LINK=0
!         %RESULT =I
!%END
%EXTERNALROUTINE PUSH(%INTEGERNAME CELL, %INTEGER S1, S2, S3)
!***********************************************************************
!*       PUSH A CELL CONTAINING THE 3 STREAMS OF INFORMATION GIVEN     *
!*       ONTO THE TOP OF THE LIST POINTED AT BY CELL.                  *
!***********************************************************************
%RECORD(LISTF)%NAME LCELL
%INTEGER I
      I=ASL
      %IF I=0 %THEN I=MORE SPACE
      LCELL==ASLIST(I)
      ASL=LCELL_LINK
      LCELL_LINK=CELL
      CELL=I
      LCELL_S1=S1
      LCELL_S2=S2
      LCELL_S3=S3
%END
%EXTERNALROUTINE POP(%INTEGERNAME CELL, S1, S2, S3)
!***********************************************************************
!*       COPY THE INFORMATION FROM THE TOP CELL OF LIST 'CELL' INTO    *
!*         S1,S2&S3 AND THEN POP THE LIST UP 1 CELL. EMPTYLIST GIVE -1S*
!***********************************************************************
%INTEGER I
%RECORD(LISTF)%NAME LCELL
      I=CELL
      LCELL==ASLIST(I)
      S1=LCELL_S1
      S2=LCELL_S2
      S3=LCELL_S3
      %IF I# 0 %THEN %START
         CELL=LCELL_LINK
         LCELL_LINK=ASL
         ASL=I
      %FINISH
%END
%EXTERNALROUTINE BINSERT(%INTEGERNAME TOP,BOT,%INTEGER S1,S2,S3)
!***********************************************************************
!*       INSERT A CELL AT THE BOTTOM OF A LIST                         *
!*       UPDATING TOP AND BOTTOM POINTERS APPROPIATELY                 *
!***********************************************************************
%INTEGER I,J
%RECORD(LISTF)%NAME LCELL
         I=ASL
         %IF I=0 %THEN I=MORE SPACE
         LCELL==ASLIST(I)
         ASL=LCELL_LINK
         LCELL_S1=S1; LCELL_S2=S2
         LCELL_S3=S3; LCELL_LINK=0
         J=BOT
         %IF J=0 %THEN BOT=I %AND TOP=BOT %ELSE %START
            ASLIST(J)_LINK=I
            BOT=I
         %FINISH
%END
%EXTERNALROUTINE INSERT AFTER(%INTEGERNAME PLACE,%INTEGER S1,S2,S3)
!***********************************************************************
!*    ADDS A CELL INT THE MIDDLE OF A LIST AFTER "CELL" WHICH          *
!*    IS UPDATED                                                       *
!***********************************************************************
%INTEGER I
%RECORD(LISTF)%NAME OLDCELL,CELL
      FAULT(109,0,0) %IF PLACE<=0
      I=ASL
      %IF I=0 %THEN I=MORE SPACE
      CELL==ASLIST(I)
      ASL=CELL_LINK
      OLDCELL==ASLIST(PLACE)
      CELL_S1=S1; CELL_S2=S2
      CELL_S3=S3
      CELL_LINK=OLDCELL_LINK
      OLDCELL_LINK=I
      PLACE=I
%END
%EXTERNALROUTINE INSERT AT END(%INTEGERNAME CELL, %INTEGER S1, S2, S3)
!***********************************************************************
!*       ADD A CELL TO THE BOTTOM OF THE LIST HEADED BY 'CELL'         *
!***********************************************************************
%INTEGER I,J,N
%RECORD(LISTF)%NAME LCELL
         I=CELL; J=I
         %WHILE I#0 %CYCLE
            J=I
            I=ASLIST(J)_LINK
         %REPEAT
         N=ASL
         %IF N=0 %THEN N=MORE SPACE
         LCELL==ASLIST(N)
         ASL=LCELL_LINK
         %IF J=0 %THEN CELL=N %ELSE ASLIST(J)_LINK=N
         LCELL_S1=S1
         LCELL_S2=S2
         LCELL_S3=S3
         LCELL_LINK=0
%END
%EXTERNALINTEGERFN FIND(%INTEGER LAB, LIST)
!***********************************************************************
!*       THIS FUNCTION SEARCHES LIST 'LIST' FOR LAB IN STREAM2 AND     *
!*       RETURNS THE CORRESPONDING CELL NO.IT USED FOR MORE THAN       *
!*       SCANNING LABEL LISTS.                                         *
!***********************************************************************
         %WHILE LIST#0 %CYCLE
            %RESULT=LIST %IF LAB=ASLIST(LIST)_S2
            LIST=ASLIST(LIST)_LINK
         %REPEAT
         %RESULT=-1
%END
%EXTERNALROUTINE CLEAR LIST(%INTEGERNAME OPHEAD)
!***********************************************************************
!*       THROW AWAY A COMPLETE LIST (MAY BE NULL!)                     *
!***********************************************************************
%INTEGER I, J
          I=OPHEAD; J=I
         %WHILE I#0 %CYCLE
            J=I
            I=ASLIST(J)_LINK
         %REPEAT
         %IF J#0 %START
            ASLIST(J)_LINK=ASL
            ASL=OPHEAD; OPHEAD=0
         %FINISH
%END
!%EXTERNALROUTINE CONCAT(%INTEGERNAME LIST1, LIST2)
!!***********************************************************************
!!*        ADDS LIST2 TO BOTTOM OF LIST1                                *
!!***********************************************************************
!%INTEGER I,J
!         I=LIST1
!         J=I
!         %WHILE I#0 %THEN J=I %AND I=ASLIST(J)_LINK
!         %IF J=0 %THEN LIST1=LIST2 %ELSE ASLIST(J)_LINK=LIST2
!         LIST2=0
!%END;                                   ! AN ERROR PUTS CELL TWICE ONTO
                                        ! FREE LIST - CATASTROPHIC!
%ROUTINE PutError(%STRING (255) s)
!***********************************************************************
!*    Compilation ends in disarray. Message and stop tidily            *
!***********************************************************************
%INTEGER bad
      printstring("** PUT error **"); newline
      bad=addr(s)+1
      %monitor; %STOP
%END {PutError}



%externalroutine free space(%integer ad)
!***********************************************************************
!*    This is EPCs interface to FREE                                   *
!*    Enables monitoring or checking to take place                     *
!************************************************************************
         printstring(" FREE "); write(ad,1)
         newline
%end; ! Free space
!*
%EXTERNAL %INTEGER %FN Get Space(%INTEGER size{bytes})
!************************************************************************
!*     This is EPC's interface to MALLOC                               *
!*    Enables monitoring or checking to take place                     *
!************************************************************************
%INTEGER flag
      size=(size+7)&(-8)         { keep everything d-w aligned }
      %IF malmon#0 %START
         printstring(" MALLOC "); write(size,1)
         flag=MALLOC(size)
         printstring(" flag = "); phex(flag)
         newline
         %IF flag+size>maxdata %THEN maxdata=flag+size
      %FINISH %ELSE flag=MALLOC(size)
      %IF flag=0 %THEN PutError(" MALLOC out of space ")
      %RESULT=flag
%END
%externalroutine changesex
%end
%externalroutine pownarrayhead
%end
%externalroutine emonon
%end
%externalroutine prdata
%end
%externalroutine generate
%end
%externalroutine pinitown
%end
%externalroutine esetoptions
%end
%externalroutine psetfiles
%end
%externalroutine epilogue
%end
%externalroutine impabort
%end
%externalroutine mcodeon
%end
%externalroutine reformatc
%end
%externalroutine pfaulty
%end
%externalroutine prologue
%end
%externalroutine filldtabrefs
%end
%externalroutine cxref
%end
%externalroutine esetgisoptions
%end
%externalroutine pdata
%end
%externalroutine pgenerateobject
%end
%externalroutine pmonon
%end
%END %OF %FILE
coff.inc/       777810878   12014 11130 100644  41        `
! a dummy since there is no coff on mips

fstatfmt.inc/   777810896   12014 11130 100644  104       `
! Copyright (c) 1988 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!
%include "fstatfmt10.inc"
fstatfmt10.inc/ 777810896   12014 11130 100745  1150      `
! Copyright (c) 1988 Edinburgh Portable Compilers Ltd. All Rights Reserved.
! All Machines FSTATFMT10.INC

      !Defines the format returned by GETSTAT or GETFSTAT on all Hosts!

! Modified 11/03/91 - rewritten to be Host independent, requires getfstat1.c
!                     ftncomp58 onwards
! Modified  5/02/91 - allow for Sequent's PTX
! Modfied   8/03/90 - compatible with FIOPARS3 onwards and allows for M88K
! Modified  7/02/90 - compatible with FIOPARS2 onwards and allows for UNIX5.4
! Modified 10/11/89 - allow for SunOS4 SPARC
! Modified 28/11/88 - allow for Clan4
! Modified 20/08/88 - uses new values in ftn_ioparams
! Modified 16/06/88 - create include file


%RECORDFORMAT STAT INFORMATION TABLE (                                %C
                                                                      %C
             %INTEGER FILE SIZE      ,
             %INTEGER INODE          ,
             %INTEGER FILE MODE      ,
             %INTEGER DEV NUMBER     )

             !This is the form in which getstat.c returns
             !information which it has acquired from stat(2)

%CONSTINTEGER Size of STAT INFO TABLE= 16 {bytes}
ftnht.inc/      844936896   12014 11130 100644  100       `
! Copyright (c) 1988 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!
%include "ftnht8.inc"
ftnht11.2.inc/  844876094   12014 11130 100666  5972      `
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!*          17/04/96 - Added AllowR16 for Fortran90                ftnht11.2
!*          19/11/92 - Add platform constants for MIPS and DRS486  ftnht11.1
!*          19/11/92 - Add Language Variant which takes values of  ftnht11
!*                     Fortran77 or Fortran90
!*          28/08/92 - Add rs6000
!*                                                                 ftnht9
!*          07/01/92 - common version
!*                   - add Object Format ISBSDOMRON
!*                   - add OCScompliant
!*          19/10/91 - common version                              ftnht8
!*          07/10/91 - Add Object format for ftnend etc            ftnht7.11
!*          20/08/91 - Add M88k sched                              ftnht7.12
!*          12/07/91 - Add M88110 as a variant for Usechipfns      ftnht7.11
!*          29/11/90 - Add sunf77 for full sun77 compatibility     ftnht7.10
!*          09/09/90 - remove release number and date to vers.inc  ftnht7.9
!*          09/07/90 - updated release number in message           ftnht7.8
!*                   - changed Scaleopt1 to 0
!* modified 05/04/90 - add constinteger for Aligndata              ftnht7.6
!* modified 13/03/90 - add constinteger for Locust                 ftnht7.5
!* modified 18/01/90 - define Allowparallel                        ftnht7.4
!*                   - define Directcomplex
!*                   - define Fregopt
!* modified 12/01/90 - define ALIGN8 for REAL*8 alignment reqmnts  ftnht7.3
!* modified 17/11/89 - define Emachine                             ftnht7.2
!* modified 30/09/89 - define sparc,m88000,i860,paramdirection     ftnht7.1
!* modified 05/09/89 - Add constinteger for modula
!*                   - add constinteger for compiler
!*                   - put reldate in ftnht instead of mfcompile
!* modified 01/05/89 - define TrueValue 
!* modified 25/03/89 - define Allowintprc to govern the legality of
!*                     internal procedures
!* modified 06/01/89 - Remove flag NP2
!* modified 12/12/88 - Set NP2=1 Goulddivnewbr=1 for NP2
!* modified 10/12/88 - NP2 defined as a Boolean
!* modified 25/11/88 - define Goulddivnewbr
!*                   - define Scaleopt1,Allowcase,IEEE
!* modified 06/05/88 - define NP2
!* modified 21/03/88 - define Allowgldfns
!* modified 04/03/88 - more definitions added
!* modified 26/01/88 - define Numoptregs
!* modified 25/01/88 - define Bytesreversed
!*                   - define BSSavailable
!*                   - define Usechipfns
!*                   - define Allowvaxnames
!*                   - define Allow99cont
!*                   - define Realsubscripts
!*                   - define AllowI8decl
!* modified 13/09/87 - define Evalrealslong
!*                   - define AllowI8
!* modified 07/09/87 - define Array temps on stack
!*
%constinteger ICL2900 = 1
%constinteger IBM     = 4
%constinteger SPARC   =16
%constinteger M88000  =17
%constinteger Locust  =19
%constinteger M88110  =20
%constinteger M88100  =21
%constinteger M88100forM88110 =22
%constinteger RS6000  =23
%constinteger MIPS    =24
%constinteger DRS486  =25

!*
%constinteger POSITIVE =  1
%constinteger NEGATIVE = -1
!*
%constinteger HOST    = DRS486
%constinteger TARGET  = DRS486
%constinteger Env     = DRS486
%constinteger STACK DIRECTION = NEGATIVE
%constinteger PARAM DIRECTION = POSITIVE
!*
%constinteger ALIGN8  =  (1 << SPARC) ! (1 << M88000)
!*
%constinteger Goulddivnewbr = 0  { 0 not available  1 available }
!*
%constinteger Allowvector = 0            { 0  No   1  Yes }
%constinteger Allowparallel = 0          { 0  No   1  Yes }
%constinteger Emachine      = 4
%constinteger Directcomplex = 1  { 0 No (indirect operands)  1 Yes (direct)  }
%constinteger OCScompliant  = 0  { 0 No  1 Yes }
!*
%constinteger Array temps on stack = 0   { 0  No   1  Yes }
%constinteger AllowI8 = 0                { 0  No   1  Yes }
%constinteger AllowR16= 0                { 0  No   1  Yes }
%constinteger Evalrealslong = 0          { 0  No   1  Yes }
%constinteger Bytesreversed = 0          { 0  No   1  Yes }
%constinteger BSSavailable  = 1          { 0  No   1  Yes }
%constinteger Allowvaxnames = 1          { 0  No   1  Yes }
%constinteger Allow99cont   = 1          { 0  No   1  Yes }
%constinteger Realsubscripts= 1          { 0  No   1  Yes }
%constinteger AllowI8decl   = 0          { 0  No   1  Yes }
%constinteger AllowI1decl   = 0          { 0  No   1  Yes }
%constinteger Allowfind     = 1          { 0  No   1  Yes   definefile,find}
%constinteger VAXparam      = 1          { 0  No   1  Yes }
%constinteger Bytesigned    = 1          { 0  No   1  Yes }
%constinteger FullVAX       = 1          { 0  No   1  Yes }
%constinteger Allowgldfns   = 0          { 0  No   1  Yes }
%constinteger Allowcase     = 0
%constinteger Numoptregs    = 1
%constinteger Allowintprc   = 0          {0   No   1  Yes }
%constinteger IEEE          = 1
%constinteger Scaleopt1     = 1
%constinteger Aligndata     = 1 { 1 add filler bytes in common}
%constinteger SunF77        = 1          {1 = full sun f77 compatibility}
!*
%constinteger TrueValue     = 1          {usually 1, but x'ff' on PN and MPX}
!*
!*
%constinteger M68881     = 1
%constinteger Intel287   = 2
%constinteger Intel387   = 3
%constinteger Weitek     = 4
%constinteger Usechipfns = SPARC         {0 if none available}
!*
%constinteger M88ksched = M88000
%constinteger Fregopt = 1                {0 not available  1 available}
!*
%constinteger full387 = 0                {applicable only on Intel}
%constinteger IMP     =  1
%constinteger fortran =  2
%constinteger ccomp   = 11
%constinteger pascal  = 14
%constinteger modula  = 15

%constinteger Compiler = Fortran

%constinteger Fortran77 = 0
%constinteger Fortran90 = 1

%constinteger Language Variant = Fortran90

%constinteger ISCOFF = 0
%constinteger ISELF = 1
%constinteger ISBSD = 2
%constinteger ISBSDOMRON = 3
%constinteger Object Format = ISBSD
ftnht8.inc/     777810815   12014 11130 100644  6145      `
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!*  13Oct93    Added PENTIUM (pds)                                   ftnht8.inc
!*          01/03/92 - set scaleopt1=1 for RS6000                  ftnht7.14
!*          22/02/92 - Add ISBSDOMRON                              ftnht7.13
!*          14/02/92 - Add RS6000 target for IBM RS6000            ftnht7.12
!*          07/10/90 - Add Object Format for ftnend etc            ftnht7.11
!*          29/11/90 - Add sunf77 for full sun77 compatibility     ftnht7.10
!*          09/09/90 - remove release number and date to vers.inc  ftnht7.9
!*          09/07/90 - updated release number in message           ftnht7.8
!*                   - changed Scaleopt1 to 0
!* modified 05/04/90 - add constinteger for Aligndata              ftnht7.6
!* modified 13/03/90 - add constinteger for Locust                 ftnht7.5
!* modified 18/01/90 - define Allowparallel                        ftnht7.4
!*                   - define Directcomplex
!*                   - define Fregopt
!* modified 12/01/90 - define ALIGN8 for REAL*8 alignment reqmnts  ftnht7.3
!* modified 17/11/89 - define Emachine                             ftnht7.2
!* modified 30/09/89 - define sparc,m88000,i860,paramdirection     ftnht7.1
!* modified 05/09/89 - Add constinteger for modula
!*                   - add constinteger for compiler
!*                   - put reldate in ftnht instead of mfcompile
!* modified 01/05/89 - define TrueValue 
!* modified 25/03/89 - define Allowintprc to govern the legality of
!*                     internal procedures
!* modified 06/01/89 - Remove flag NP2
!* modified 12/12/88 - Set NP2=1 Goulddivnewbr=1 for NP2
!* modified 10/12/88 - NP2 defined as a Boolean
!* modified 25/11/88 - define Goulddivnewbr
!*                   - define Scaleopt1,Allowcase,IEEE
!* modified 06/05/88 - define NP2
!* modified 21/03/88 - define Allowgldfns
!* modified 04/03/88 - more definitions added
!* modified 26/01/88 - define Numoptregs
!* modified 25/01/88 - define Bytesreversed
!*                   - define BSSavailable
!*                   - define Usechipfns
!*                   - define Allowvaxnames
!*                   - define Allow99cont
!*                   - define Realsubscripts
!*                   - define AllowI8decl
!* modified 13/09/87 - define Evalrealslong
!*                   - define AllowI8
!* modified 07/09/87 - define Array temps on stack
!*
%constinteger ICL2900 = 1
%constinteger PERQPNX = 2
%constinteger ACCENT  = 3
%constinteger IBM     = 4
%constinteger VAX     = 5
%constinteger M68000  = 6
%constinteger Sun3    = 6
%constinteger INTEL   = 7
%constinteger LATTICE = 8
%constinteger VNS     = 9
%constinteger GOULD   =10
%constinteger WWC     =11
%constinteger WCW     =11
%constinteger DRS     =11
%constinteger AMDAHL  =14
%constinteger Sequent =15
%constinteger SPARC   =16
%constinteger M88000  =17
%constinteger i860    =18
%constinteger Locust  =19
%constinteger M88110  =20
%constinteger M88100  =21
%constinteger M88100forM88110 =22
%constinteger RS6000=23
%constinteger MIPS=24
%constinteger PENTIUM=25
!*
%constinteger POSITIVE =  1
%constinteger NEGATIVE = -1
!*
%constinteger HOST    = MIPS
%constinteger TARGET  = MIPS
%constinteger Env     = MIPS
%constinteger STACK DIRECTION = NEGATIVE
%constinteger PARAM DIRECTION = POSITIVE
!*
%constinteger ALIGN8  = (1 << GOULD) ! (1 << SPARC) ! (1 << M88000) ! (1<<RS6000)
!*
%constinteger Concept = 0        {}
%constinteger NP1     = 1        {only applicable if host/target=Gould}
%constinteger Cpu     = Concept  {}
%constinteger Goulddivnewbr = 0  { 0 not available  1 available }
!*
%constinteger Allowvector = 0            { 0  No   1  Yes }
%constinteger Allowparallel = 0          { 0  No   1  Yes }
%constinteger Emachine      = 4
%constinteger Directcomplex = 1  { 0 No (indirect operands)  1 Yes (direct)  }
!*
%constinteger Array temps on stack = 0   { 0  No   1  Yes }
%constinteger AllowI8 = 0                { 0  No   1  Yes }
%constinteger Evalrealslong = 0          { 0  No   1  Yes }
%constinteger Bytesreversed = 0          { 0  No   1  Yes }
%constinteger BSSavailable  = 1          { 0  No   1  Yes }
%constinteger Allowvaxnames = 1          { 0  No   1  Yes }
%constinteger Allow99cont   = 1          { 0  No   1  Yes }
%constinteger Realsubscripts= 1          { 0  No   1  Yes }
%constinteger AllowI8decl   = 0          { 0  No   1  Yes }
%constinteger AllowI1decl   = 0          { 0  No   1  Yes }
%constinteger Allowfind     = 1          { 0  No   1  Yes   definefile,find}
%constinteger VAXparam      = 1          { 0  No   1  Yes }
%constinteger Bytesigned    = 1          { 0  No   1  Yes }
%constinteger FullVAX       = 1          { 0  No   1  Yes }
%constinteger Allowgldfns   = 0          { 0  No   1  Yes }
%constinteger Allowcase     = 0
%constinteger Numoptregs    = 1
%constinteger Allowintprc   = 0          {0   No   1  Yes }
%constinteger IEEE          = 1
%constinteger Aligndata     = 1 { 1 add filler bytes in common}
%constinteger SunF77        = 1          {1 = full sun f77 compatibility}
%constinteger OCScompliant  = 0  { 0 No  1 Yes }
%if Target=RS6000 %or Target=Sparc %thenstart
   %constinteger Scaleopt1     = 1
%finishelsestart
   %constinteger Scaleopt1     = 0
%finish
!*
%constinteger TrueValue     = 1          {usually 1, but x'ff' on PN and MPX}
!*
%constinteger UTX     = 0        {}
%constinteger MPX     = 1        {only applicable if host/target=Gould}
%constinteger Opsys   = UTX      {}
!*
%constinteger M68881     = 1
%constinteger Intel287   = 2
%constinteger Intel387   = 3
%constinteger Weitek     = 4
%constinteger Usechipfns = RS6000        {0 if none available}
!*
%constinteger Fregopt = 1                {0 not available  1 available}
!*
%constinteger full387 = 0                {applicable only on Intel}
%constinteger IMP     =  1
%constinteger fortran =  2
%constinteger ccomp   = 11
%constinteger pascal  = 14
%constinteger modula  = 15

%constinteger Compiler = IMP

%constinteger ISCOFF = 0
%constinteger ISELF = 1
%constinteger ISBSD = 2
%constinteger ISBSDOMRON = 3
%constinteger Object Format = ISELF

hostcodes.inc/  845044322   12014 11130 100644  3010      `

%CONSTINTEGER YES=1,NO=0
            
!
! THESE CODE ARE ARBITARY BUT THE TOP DECIMAL DIGIT GIVES THE NO OF BYTES
! IN THE UNIT OF ADDRESSABILITY. BYTE ADDRESSED HOSTS BEING 1N ( also 0N) AND
! 16 BIT WORD ADDRESSED HOSTS BEING 2N ETC
%CONSTINTEGER PENTIUM=4;                ! PENTIUM chip Unix stack and completely swopped
%constinteger MIPS=05;                  ! Imp on MIPS (all variants)
%CONSTINTEGER RS6=06;                   ! imp on IBM rs6000
%CONSTINTEGER M88K=07;                  ! Imp on all forms of 88k
                                        ! also serves for Sparc sinc there is a common b-e
%CONSTINTEGER VAX=08;                   ! Imp on Vax using F & G formats
%CONSTINTEGER UNISYS=09;                ! Imp on UnisSys. Unix stack unswopped Vax reals
%CONSTINTEGER EMAS=10;                  ! emas on 2900 (unsigned shorts)
%CONSTINTEGER IBM=11;                   ! emas on 24 bit ibm hardware
%CONSTINTEGER IBMXA=12;                 ! emas of XA 31 bit hardware
%CONSTINTEGER WWC=13;                   ! WWc (Natsemi chip) completely swopped
%CONSTINTEGER AMDAHL=14;                ! Emas on Amdahls guess at Xa Minor differences fron IBM)
%CONSTINTEGER PERQ3=15;                 ! ICL packaged 68k chip Unix stack but not swopped
%CONSTINTEGER GOULD=16;                 ! Gould unswopped forward stack. Needs 4&8 byte alined
%CONSTINTEGER VNS=17;                   ! Unix on 2900 unsigned shorts params as
                                        ! 2900. Long int available but not in Ecode
%CONSTINTEGER EAMD=18;                  ! Amdahl via the Emachine
%CONSTINTEGER DRS=19;                   ! Intel chip Unix stack and mostly swopped
%CONSTINTEGER PERQ=20;                  ! Pos perq now obselete. Fully swopped forward stack
%CONSTINTEGER PNX=21;                   ! ICL's perq2 Unix stack byte swopped (unsigned shorts)
%CONSTINTEGER ACCENT=22;                ! Perq 1 under accent. obsolete now
                                        ! ACCENT DIFFERS FROM PERQ ONLY IN
                                        ! ASSEMBLES SEQUENCES&SYNTAX
                                        ! AND GENERATOR
%constinteger ORN=23
%CONSTINTEGER UNSIGNEDSHORTS=1<<emas!1<<pnx!1<<vns
%CONSTINTEGER LINTAVAIL=1<<IBM!1<<IBMXA!1<<amdahl!1<<EMAS!1<<GOULD!1<<MIPS
%CONSTINTEGER LLREALAVAIL=1<<IBM!1<<IBMXA!1<<amdahl!1<<EMAS!1<<MIPS
%CONSTINTEGER EMACHINE=1<<DRS!1<<PENTIUM!1<<WWC!1<<Vax!1<<GOULD!1<<PERQ3!1<<VNS!1<<EAMD!1<<ORN!1<<UniSys!1<<m88k!1<<rs6!1<<MIPS
%CONSTINTEGER IBMFPFORMAT=1<<ibm!1<<ibmxa!1<<amdahl!1<<emas!1<<gould!1<<vns!1<<EAMD
%constinteger VAXFPFORMAT=1<<Vax!1<<UniSys
%constinteger IEEEFPFORMAT=1<<WWC!1<<PERQ3!1<<DRS!1<<PENTIUM!1<<PERQ!1<<accent!1<<m88k!1<<rs6!1<<MIPS
%CONSTINTEGER BYTESWOPPED=1<<PERQ!1<<ACCENT!1<<WWC!1<<Vax!1<<PNX!1<<ORN
%CONSTINTEGER HALFSWOPPED=1<<PERQ!1<<ACCENT!1<<WWC!1<<Vax!1<<DRS!1<<PENTIUM!1<<ORN
%CONSTINTEGER WORDSWOPPED=1<<PERQ!1<<ACCENT!1<<WWC!1<<Vax!1<<DRS!1<<PENTIUM!1<<ORN
%CONSTINTEGER RISKMC=1<<M88K!1<<rs6!1<<MIPS
!
! end of file hostcodes
!
/0              797770018   12014 11130 100640  55        `
   %const %string (9) LADATE="Apr 95";  ! LAST ALTERED

protection.inc/ 777810865   12014 11130 100644  114       `
%constinteger EPCTIMEBOMB = 0
%constinteger FLEXLM = 1
%constinteger ALF = 2
%constinteger Protection=EPCTIMEBOMB
rterrs.inc/     844876095   12014 11130 100666  622       `
! Copyright (c) 1992 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!
!     Fortran Run-Time Library: - include Run-Time error constants
!     --------------------------

!     Author : Andy Kettler         Created on : 06 Sep 92

!     Modifications :

!     Date     Dev Vers  Description of Modification
!     ----     --- ----  ---------------------------
!     30/04/96  AK       includes f90rterror5
!     08/09/95  AK       includes f90rterror4
!     14/12/94  AK       includes f90rterror3
!     09/06/94  AK       includes f90rterror2
!     06/09/92  AK       Original version

%include "f90rterror5.inc"
vers.inc/       777810842   12014 11130 100644  27        `
!*
%include "vers4.30.inc"

vers4.30.inc/   777810842   12014 11130 100644  690       `
! Copyright (c) 1991 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!*
!* modified 15/02/92 - added dwarf version
!* modified 31/08/90 - first version - defines the compiler Release
!*
%conststring(60) Impversion= %c
"EPC IMP80 Version 4.30
"
!*
%conststring(60) F77copyright text= %c
"Copyright (c) 1991 EPCL.  All Rights Reserved."
!*
%conststring(50) Reldate= %c
"
15/04/93
"

!*
!* dwarf version is used by elf puts for the at_producer attribute in
!* compile_unit debug information entries. This information MUST be
!* updated whenever the version info is changed. The 4 fields will
!* will be required by edb/
!*
%ownstring(60) dwarf version= %c
"EPC Fortran77 (88000) 2.6.6"
impsup.c/       788804735   12014 11130 100664  1892      `
#include <string.h>
static char space[15] [256];
static int point= -1;
 char *imp_concat(char *lhs,char *rhs)
{
    point=(point+1)&15;
    strcpy(space[point],lhs);
    strcat(space[point],rhs);
    return space[point];
}
int imp_resolve( char *origlhs, char * dest1, char * exp, char * dest2)
{
      int l1;
      char * s1, *lp;
      char lhs[256];
      strcpy(lhs,origlhs);
      s1=strstr(lhs,exp);
      if (s1==NULL) return 1;
      s1[0]=0;
      l1=strlen(lhs)+strlen(exp);
      if (dest1!=NULL) strcpy(dest1,lhs);
      lp=(char *)lhs+l1;
      if (dest2!=NULL) strcpy(dest2,lp);
      return 0;
}
 char * imp_tostring(int sym)
      {
      static char aa[2];
      aa[0]=sym;
      aa[1]=0;
      return aa;
}
void imp_stop()
{
      printf("\n\n IMP %%stop Called\n\n");
      exit(0);
}
char * imp_substring(char * source,int from,int to)
{
      static char lhs[256];
      int i,j;
      i=0;
      for (j=from; j<=to; j++) lhs[i++]=source[j];
      lhs[i]=0;
      return lhs;
}
 void imp_strjam(char * lhs,char * rhs,int max)
{
      lhs[0]=0;
      strncat(lhs,rhs,max);
}
void s__cstring(char * impstring, char * cstring)
{
      /* dummy version for when strings are already cstring */
     strcpy(cstring,impstring);
}
 char * itos(int val){
      static char sp[20];
      sprintf(sp,"%d",val);
      return sp;
}
void phex (int val)
{
      printf("%8x",val);
}
char * htos(int val,int places)
{
     char sp[9];
     switch (places) {
case 1:
      sprintf(sp,"%1x",val);
      break;
case 2:
      sprintf(sp,"%2x",val);
      break;
case 3:
      sprintf(sp,"%3x",val);
      break;
case 4:
      sprintf(sp,"%4x",val);
      break;
case 5:
      sprintf(sp,"%5x",val);
      break;
case 6:
      sprintf(sp,"%6x",val);
      break;
case 7:
      sprintf(sp,"%7x",val);
      break;
default:
      sprintf(sp,"%8x",val);
      break;
      }
      return sp;
}
imptoc.h/       787419167   12014 11130 100664  414       `
#ifndef __IMPINCLUDES 
#define __IMPINCLUDES
#include <stdio.h>
#include <string.h>
#include <math.h>
#include <stdlib.h>
#define nl 10
 static int _imptempint;
 static char _imptempstring[256];
 char * imp_concat( char *,char *);
 int imp_resolve(char *, char *, char *,char *);
 char * imp_tostring(int );
 void * imp_strjam(char *,char *,int);
 void imp_stop();
 char * imp_substring(char *,int ,int );
#endif