!* 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)
!*
!!{GT:}%include "hostcodes.inc"
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
!
{GT:}CONSTINTEGER HOST={mips}PENTIUM
{GT:}CONSTINTEGER TARGET={mips}PENTIUM
! 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};
constshortintegerarray 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'#0C
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