Edinburgh IMP77 Compiler - Version 8.4 1 ! Missing COMREG, IOCP, CONSOURCE, LPUT, CPUTIME, NCODE 2 3 {%MAINEP ICL9CEZIMP 4 {%TRUSTEDPROGRAM 5 %BEGIN 6 !%string(127)%fn ITOS(%integer v,p) 7 ! %integer vv,q,pos 8 ! %byteintegerarray store(0:127) 9 ! 10 ! vv = v; vv = -vv %if vv > 0 11 ! pos = 127 12 ! %while vv <= -10 %cycle 13 ! q = vv//10 14 ! store(pos) = q*10-vv+'0'; pos = pos-1 15 ! vv = q 16 ! %repeat 17 ! store(pos) = '0'-vv 18 ! %if p <= 0 %start 19 ! p = 128+p 20 ! %else 21 ! p = 128-p 22 ! p = pos %if p > pos 23 ! p = p-1 24 ! %finish 25 ! pos = pos-1 %and store(pos) = '-' %if v < 0 26 ! %while pos > p %and pos > 1 %cycle 27 ! pos = pos-1; store(pos) = ' ' 28 ! %repeat 29 ! pos = pos-1; store(pos) = 127-pos 30 ! %result = string(addr(store(pos))) 31 !%end 32 33 !%integermap LONGINTEGER(%integer Addr) 34 ! %result == INTEGER(Addr) 35 !%end 36 !%routine pprofile 37 !%end 38 !%routine print ch(%integer I) 39 ! print symbol(I) 40 !%end 41 !%routine newpage 42 ! print ch(12) 43 !%end 44 !%integerfn IMOD(%integer I) 45 ! %result = |I| 46 !%end 47 !%realfn MOD(%real R) 48 ! %result = |R| 49 !%end 50 !%realfn FRACPT(%real r) 51 ! %result = r-INTPT(r) 52 !%end 53 %CONSTINTEGER RELEASE=10 54 %CONSTINTEGER YES=1,NO=0 55 %CONSTINTEGER USE IMP=YES 56 %CONSTINTEGER VMEB=NO 57 %CONSTSTRING(9) LADATE="28 Jan 81"; ! LAST ALTERED 58 %INTEGER I, J, K 59 ! PRODUCED BY OLDPS FROM NRIMPPS8 ON 16/12/80 60 %CONSTBYTEINTEGERARRAY CLETT(0: 500)= 1, 61+ 43, 1, 45, 1, 40, 1, 41, 1, 44, 2, 201, 198, 6, 213, 62+ 206, 204, 197, 211, 211, 5, 215, 200, 201, 204, 197, 5, 213, 206, 63+ 212, 201, 204, 3, 198, 207, 210, 1, 61, 4, 210, 197, 193, 204, 64+ 7, 201, 206, 212, 197, 199, 197, 210, 8, 204, 207, 206, 199, 210, 65+ 197, 193, 204, 4, 204, 207, 206, 199, 11, 194, 217, 212, 197, 201, 66+ 206, 212, 197, 199, 197, 210, 6, 211, 212, 210, 201, 206, 199, 11, 67+ 200, 193, 204, 198, 201, 206, 212, 197, 199, 197, 210, 7, 210, 207, 68+ 213, 212, 201, 206, 197, 2, 198, 206, 3, 205, 193, 208, 8, 198, 69+ 213, 206, 195, 212, 201, 207, 206, 6, 210, 197, 195, 207, 210, 196, 70+ 4, 206, 193, 205, 197, 5, 193, 210, 210, 193, 217, 9, 193, 210, 71+ 210, 193, 217, 206, 193, 205, 197, 9, 207, 198, 208, 210, 207, 199, 72+ 210, 193, 205, 6, 207, 198, 198, 201, 204, 197, 6, 207, 198, 204, 73+ 201, 211, 212, 6, 198, 207, 210, 205, 193, 212, 4, 211, 208, 197, 74+ 195, 3, 206, 207, 212, 3, 193, 206, 196, 2, 207, 210, 1, 58, 75+ 6, 206, 207, 210, 205, 193, 204, 3, 207, 215, 206, 8, 197, 216, 76+ 212, 197, 210, 206, 193, 204, 9, 197, 216, 212, 210, 201, 206, 211, 77+ 201, 195, 8, 195, 207, 206, 211, 212, 193, 206, 212, 5, 195, 207, 78+ 206, 211, 212, 5, 197, 214, 197, 206, 212, 5, 211, 212, 193, 210, 79+ 212, 9, 212, 200, 197, 206, 211, 212, 193, 210, 212, 4, 212, 200, 80+ 197, 206, 9, 197, 204, 211, 197, 211, 212, 193, 210, 212, 4, 197, 81+ 204, 211, 197, 1, 95, 6, 211, 217, 211, 212, 197, 205, 7, 196, 82+ 217, 206, 193, 205, 201, 195, 2, 42, 61, 1, 42, 4, 80, 85, 83+ 84, 95, 5, 67, 78, 79, 80, 95, 2, 204, 61, 1, 60, 1, 84+ 62, 4, 40, 196, 210, 43, 2, 196, 210, 1, 194, 3, 212, 207, 85+ 211, 3, 204, 206, 194, 3, 216, 206, 194, 2, 208, 195, 3, 195, 86+ 212, 194, 2, 45, 62, 6, 210, 197, 212, 213, 210, 206, 6, 210, 87+ 197, 211, 213, 204, 212, 7, 205, 207, 206, 201, 212, 207, 210, 4, 88+ 211, 212, 207, 208, 6, 211, 201, 199, 206, 193, 204, 4, 197, 216, 89+ 201, 212, 8, 195, 207, 206, 212, 201, 206, 213, 197, 6, 198, 201, 90+ 206, 201, 211, 200, 5, 195, 217, 195, 204, 197, 6, 210, 197, 208, 91+ 197, 193, 212, 3, 197, 206, 196, 5, 210, 197, 193, 204, 211, 5, 92+ 194, 197, 199, 201, 206, 2, 207, 206, 6, 211, 215, 201, 212, 195, 93+ 200, 4, 204, 201, 211, 212, 7, 211, 208, 197, 195, 201, 193, 204, 94+ 14, 212, 210, 213, 211, 212, 197, 196, 208, 210, 207, 199, 210, 193, 95+ 205, 6, 205, 193, 201, 206, 197, 208, 7, 195, 207, 206, 212, 210, 96+ 207, 204, 7, 201, 206, 195, 204, 213, 196, 197; 97 98 99 100 101 {%CONST}%ownINTEGERARRAY SYMBOL(1300: 2213)= 1307, 102+ 1303, 0, 1305, 2, 1307, 1000, 1319, 1312, 1001, 1357, 103+ 1824, 1315, 1003, 1020, 1319, 4, 1336, 6, 1329, 1323, 104+ 1001, 1014, 1325, 1003, 1329, 4, 1329, 6, 1336, 1336, 105+ 1010, 1028, 1319, 1011, 1350, 1343, 1343, 1010, 1028, 1307, 106+ 1011, 1343, 1350, 1348, 1026, 1307, 999, 1350, 1000, 1357, 107+ 1355, 1026, 1319, 999, 1357, 1000, 1365, 1363, 4, 1336, 108+ 1365, 6, 1365, 1000, 1372, 1370, 8, 1336, 999, 1372, 109+ 1000, 1377, 1375, 10, 1377, 13, 1401, 1384, 20, 1010, 110+ 1542, 1562, 1011, 1390, 26, 1010, 1542, 1562, 1011, 1401, 111+ 32, 1010, 1001, 36, 1336, 8, 1336, 8, 1336, 1011, 112+ 1408, 1406, 8, 1001, 999, 1408, 1000, 1415, 1411, 38, 113+ 1413, 43, 1415, 51, 1430, 1418, 43, 1420, 38, 1423, 114+ 60, 1408, 1425, 65, 1428, 77, 1925, 1430, 84, 1437, 115+ 1433, 96, 1437, 1031, 1415, 1437, 1444, 1440, 104, 1442, 116+ 107, 1444, 111, 1466, 1450, 1415, 1476, 1001, 1401, 1456, 117+ 120, 1466, 127, 1001, 1401, 1462, 1430, 1471, 1001, 1401, 118+ 1483, 1466, 127, 1001, 1401, 1471, 1469, 132, 1471, 1000, 119+ 1476, 1474, 127, 1476, 1000, 1483, 1479, 138, 1481, 127, 120+ 1483, 1000, 1493, 1491, 4, 1010, 1444, 1011, 1493, 6, 121+ 1493, 1000, 1502, 1500, 1030, 1010, 1444, 1011, 999, 1502, 122+ 1000, 1513, 1506, 148, 1016, 1508, 158, 1511, 165, 1018, 123+ 1513, 1016, 1518, 1516, 172, 1518, 1000, 1542, 1526, 172, 124+ 1001, 4, 1876, 1869, 6, 1535, 179, 1010, 1001, 1818, 125+ 1011, 4, 1001, 6, 1542, 1010, 1615, 1011, 4, 1001, 126+ 6, 1556, 1548, 1336, 1032, 1336, 1556, 1553, 4, 1542, 127+ 1562, 6, 1556, 184, 1542, 1562, 1560, 1037, 1336, 1562, 128+ 1000, 1573, 1567, 188, 1542, 1573, 1571, 192, 1542, 1580, 129+ 1573, 1000, 1580, 1578, 188, 1542, 999, 1580, 1000, 1587, 130+ 1585, 192, 1542, 999, 1587, 1000, 1595, 1591, 1033, 1336, 131+ 1593, 195, 1595, 1000, 1601, 1599, 179, 1008, 1601, 1015, 132+ 1606, 1604, 60, 1606, 197, 1615, 1613, 8, 1336, 195, 133+ 1336, 1606, 1615, 1000, 1624, 1620, 1476, 1001, 1401, 1624, 134+ 132, 1513, 1624, 1630, 1630, 1001, 1401, 1832, 1630, 1636, 135+ 1634, 8, 1624, 1636, 1000, 1652, 1646, 1476, 1010, 1001, 136+ 1401, 1840, 1011, 1652, 1006, 1652, 132, 1513, 1001, 1832, 137+ 1701, 1663, 1661, 8, 1010, 1001, 1401, 1840, 1011, 1652, 138+ 1663, 1000, 1674, 1666, 204, 1668, 208, 1670, 217, 1672, 139+ 227, 1674, 236, 1701, 1678, 1415, 1636, 1689, 120, 1476, 140+ 1010, 1001, 1401, 1011, 4, 1001, 6, 1006, 1701, 120, 141+ 132, 1513, 1010, 1001, 1832, 1011, 4, 1001, 6, 1006, 142+ 1711, 1709, 36, 1028, 1319, 1350, 1722, 1711, 1711, 1000, 143+ 1722, 1720, 8, 1012, 1028, 1319, 1350, 1722, 999, 1722, 144+ 1000, 1731, 1729, 4, 1028, 1319, 1350, 6, 1731, 1000, 145+ 1738, 1736, 8, 1009, 999, 1738, 1000, 1743, 1741, 242, 146+ 1743, 1000, 1749, 1747, 8, 1336, 1749, 1000, 1762, 1760, 147+ 8, 1001, 1401, 4, 1336, 195, 1336, 6, 999, 1762, 148+ 1000, 1769, 1767, 26, 1542, 1562, 1769, 1000, 1782, 1772, 149+ 1019, 1774, 1006, 1779, 1372, 1542, 1562, 1006, 1782, 1377, 150+ 1006, 1795, 1786, 248, 1034, 1789, 254, 1034, 1795, 264, 151+ 1010, 2060, 1011, 1801, 1801, 1799, 188, 2060, 1801, 1000, 152+ 1818, 1805, 269, 1034, 1813, 279, 1372, 1010, 1542, 1562, 153+ 1011, 1782, 1816, 279, 2060, 1818, 1000, 1824, 1822, 284, 154+ 1001, 1824, 1000, 1832, 1830, 284, 1001, 1357, 1824, 1832, 155+ 1000, 1840, 1840, 4, 1336, 195, 1336, 1606, 6, 1848, 156+ 1846, 36, 1028, 1319, 1350, 1848, 1000, 1858, 1852, 286, 157+ 1013, 1854, 208, 1856, 293, 1858, 1000, 1869, 1867, 1001, 158+ 36, 1336, 8, 1336, 8, 1336, 1869, 1000, 1876, 1874, 159+ 8, 1876, 999, 1876, 1000, 1916, 1882, 1415, 1476, 1001, 160+ 1401, 1889, 1415, 132, 1001, 1401, 1832, 1916, 1895, 120, 161+ 1466, 127, 1001, 1401, 1904, 120, 1010, 1001, 1401, 1011, 162+ 4, 1001, 6, 1916, 120, 132, 1010, 1001, 1401, 1832, 163+ 1916, 1011, 4, 1001, 6, 1925, 1923, 8, 1001, 1401, 164+ 1832, 999, 1925, 1000, 1932, 1930, 4, 1009, 6, 1932, 165+ 1000, 1950, 1936, 301, 1001, 1939, 304, 1001, 1942, 306, 166+ 1002, 1945, 1022, 1950, 1950, 311, 1009, 8, 1009, 1964, 167+ 1954, 1023, 1964, 1959, 1024, 317, 2003, 2008, 1964, 1025, 168+ 1005, 8, 1987, 1987, 1969, 320, 1001, 322, 1971, 2036, 169+ 1976, 4, 2036, 2025, 6, 1980, 324, 2036, 6, 1985, 170+ 4, 329, 2025, 6, 1987, 332, 2003, 1992, 320, 1001, 171+ 322, 1994, 2036, 1999, 4, 329, 2025, 6, 2003, 324, 172+ 1005, 6, 2008, 2006, 329, 2008, 1005, 2016, 2014, 8, 173+ 1005, 8, 1005, 2016, 1000, 2025, 2020, 0, 1005, 2023, 174+ 2, 1005, 2025, 1000, 2031, 2029, 0, 332, 2031, 1000, 175+ 2036, 2034, 36, 2036, 1000, 2051, 2041, 2031, 1300, 1003, 176+ 2044, 1001, 2016, 2049, 4, 2051, 2016, 6, 2051, 334, 177+ 2060, 2054, 338, 2056, 342, 2058, 346, 2060, 349, 2093, 178+ 2069, 1010, 1001, 1357, 1824, 1011, 1587, 1795, 2073, 353, 179+ 1001, 1357, 2075, 356, 2079, 363, 1033, 1336, 2082, 370, 180+ 1795, 2084, 378, 2089, 383, 1738, 1009, 1743, 2091, 390, 181+ 2093, 395, 2214, 2100, 1027, 1010, 2060, 1011, 1769, 2102, 182+ 1007, 2110, 1372, 1010, 1542, 1562, 1011, 1782, 1006, 2115, 183+ 404, 1035, 1801, 1006, 2120, 411, 1029, 1858, 1006, 2125, 184+ 417, 1036, 1762, 1006, 2130, 1377, 411, 1029, 1006, 2136, 185+ 1031, 1008, 1415, 1615, 1006, 2140, 424, 1502, 1006, 2144, 186+ 120, 1518, 1006, 2153, 1010, 1848, 1430, 1011, 1595, 1001, 187+ 1483, 1006, 2156, 1663, 1674, 2160, 428, 1601, 1006, 2164, 188+ 434, 1015, 1006, 2173, 440, 1021, 1738, 1009, 1731, 248, 189+ 1034, 1006, 2184, 443, 1001, 1401, 4, 1336, 195, 1336, 190+ 6, 1749, 1006, 2188, 450, 1006, 1017, 2193, 455, 127, 191+ 1001, 1006, 2197, 304, 1932, 1006, 2200, 463, 1006, 2204, 192+ 478, 1001, 1006, 2208, 485, 1003, 1006, 2212, 493, 1003, 193+ 1038, 2214, 1006; 194 195 %CONSTINTEGER SS= 2093 196 197 ! 198 %CONST %BYTE %INTEGER %ARRAY I TO E TAB(0 : 127) = {%C 199+ 16_40,16_40,16_40,16_40,16_40,16_40,16_40,16_40, 200+ 16_40,16_40,16_15,16_40,16_0C,16_40,16_40,16_40, 201+ 16_40,16_40,16_40,16_40,16_40,16_40,16_40,16_40, 202+ 16_40,16_40,16_40,16_40,16_40,16_40,16_40,16_40, 203+ 16_40,16_4F,16_7F,16_7B,16_5B,16_6C,16_50,16_7D, 204+ 16_4D,16_5D,16_5C,16_4E,16_6B,16_60,16_4B,16_61, 205+ 16_F0,16_F1,16_F2,16_F3,16_F4,16_F5,16_F6,16_F7, 206+ 16_F8,16_F9,16_7A,16_5E,16_4C,16_7E,16_6E,16_6F, 207+ 16_7C,16_C1,16_C2,16_C3,16_C4,16_C5,16_C6,16_C7, 208+ 16_C8,16_C9,16_D1,16_D2,16_D3,16_D4,16_D5,16_D6, 209+ 16_D7,16_D8,16_D9,16_E2,16_E3,16_E4,16_E5,16_E6, 210+ 16_E7,16_E8,16_E9,16_4A,16_5F,16_5A,16_6A,16_6D, 211+ 16_7C,16_81,16_82,16_83,16_84,16_85,16_86,16_87, 212+ 16_88,16_89,16_91,16_92,16_93,16_94,16_95,16_96, 213+ 16_97,16_98,16_99,16_A2,16_A3,16_A4,16_A5,16_A6, 214+ 16_A7,16_A8,16_A9,16_C0,16_40,16_D0,16_40,16_40 215 %CONSTINTEGERARRAY OPC(0:126)=0, 216+ M' JCC',M' JAT',M' JAF',0(4), 217+ M' VAL',M' CYD',M'INCA',M'MODD',M'PRCL',M' J',M' JLK',M'CALL', 218+ M' ADB',M' SBB',M'DEBJ',M' CPB',M' SIG',M' MYB',M' VMY',M'CPIB', 219+ M' LCT',M'MPSR',M'CPSR',M'STCT',M'EXIT',M'ESEX',M' OUT',M' ACT', 220+ M' SL',M'SLSS',M'SLSD',M'SLSQ',M' ST',M'STUH',M'STXN',M'IDLE', 221+ M' SLD',M' SLB',M'TDEC',M'INCT',M' STD',M' STB',M'STLN',M'STSF', 222+ M' L',M' LSS',M' LSD',M' LSQ',M'RRTC',M' LUH',M'RALN',M' ASF', 223+ M'LDRL',M' LDA',M'LDTB',M' LDB',M' LD',M' LB',M' LLN',M' LXN', 224+ M' TCH',M'ANDS',M' ORS',M'NEQS',M'EXPA',M' AND',M' OR',M' NEQ', 225+ M' PK',M' INS',M'SUPK',M' EXP',M'COMA',M' DDV',M'DRDV',M'DMDV', 226+ M'SWEQ',M'SWNE',M' CPS',M' TTR',M' FLT',M' IDV',M'IRDV',M'IMDV', 227+ M' MVL',M' MV',M'CHOV',M' COM',M' FIX',M' RDV',M'RRDV',M'RDVD', 228+ M' UAD',M' USB',M'URSB',M' UCP',M' USH',M' ROT',M' SHS',M' SHZ', 229+ M' DAD',M' DSB',M'DRSB',M' DCP',M' DSH',M' DMY',M'DMYD',M'CBIN', 230+ M' IAD',M' ISB',M'IRSB',M' ICP',M' ISH',M' IMY',M'IMYD',M'CDEC', 231+ M' RAD',M' RSB',M'RRSB',M' RCP',M' RSC',M' RMY',M'RMYD'; 232 %CONSTBYTEINTEGERARRAY ONE CASE(0 : 127) = {%C 233+ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15, 234+ 16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31, 235+ 32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47, 236+ 48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63, 237+ 64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79, 238+ 80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95, 239+ 96,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79, 240+ 80,81,82,83,84,85,86,87,88,89,90,123,124,125,126,127; 241 %CONSTINTEGERARRAY TSNAME (0:62)=16_1000(8), 242+ 16_1001,16_1000(5),16_1001,16_1062,16_1001(2),16_1062, 243+ 16_1000(2),16_52,16_51,16_62,16_1062(7), 244+ 16_1000,16_31,16_51,16_1062(2),16_31,16_1000, 245+ 16_51,16_62,16_1000(2),16_35,16_1000,16_1035, 246+ 16_31,16_35,16_1035,16_33,0,16_1000,16_31,16_52,16_51, 247+ 16_61,16_72,16_61,16_72,16_51,16_62,16_1051,16_41, 248+ 16_1000; 249 ! 250 %OWNINTEGERARRAY FIXED GLA(0:11)=0, 251+ 16_50000000,0(2),-1,0,0(6); 252 %CONSTBYTEINTEGERARRAY BYTES(0:7)=0(3),1,2,4,8,16; 253 %CONSTBYTEINTEGERARRAY TRTAB(0:255)=0(48), 254+ 1(10),0(7),2(26),0(6),2(26),0(5),0(128) 255 %CONSTINTEGER MAXLEVELS=31,CONCOP=13,FIXEDGLALEN=48 256 %CONSTINTEGER JOBBERBIT=16_40000000; ! SET IN JOBBER MODE 257 %CONSTINTEGER CEBIT=1; ! SET IN COMPILER ENVIRONMENT 258 %CONSTINTEGER MAXDICT=16_100; ! SET FOR MAX OF EVERYTHING 259 ! 260 ! THE PRINCIPAL OPCODES ARE HERE DEFINED AS THEIR MNEMONICS(AMENDED) 261 ! 262 %CONSTINTEGER LB=16_7A,SLB=16_52,STB=16_5A,ADB=16_20,CPB=16_26, {%C 263+ MYB=16_2A,SBB=16_22,CPIB=16_2E,OUT=16_3C,CPSR=16_34 264 %CONSTINTEGER LD=16_78,LDA=16_72,INCA=16_14,STD=16_58,LDB=16_76, {%C 265+ LDTB=16_74,LDRL=16_70,CYD=16_12,MODD=16_16,SLD=16_50 266 %CONSTINTEGER STLN=16_5C,ASF=16_6E,ST=16_48,RALN=16_6C,LXN=16_7E,{%C 267+ LLN=16_7C,LSS=16_62,SLSS=16_42,MPSR=16_32,STSF=16_5E,{%C 268+ LUH=16_6A,STUH=16_4A,LSD=16_64,SLSD=16_44,PRCL=16_18, {%C 269+ LSQ=16_66,SLSQ=16_46,STXN=16_4C,LCT=16_30,STCT=16_36 270 %CONSTINTEGER JUNC=16_1A,JLK=16_1C,CALL=16_1E,EXIT=16_38,JCC=2, {%C 271+ JAT=4,JAF=6,DEBJ=16_24 272 %CONSTINTEGER IAD=16_E0,ICP=16_E6,USH=16_C8,ISB=16_E2,IRSB=16_E4,{%C 273+ OR=16_8C,UCP=16_C6,IMY=16_EA,IMDV=16_AE,AND=16_8A, {%C 274+ ISH=16_E8,IMYD=16_EC,IDV=16_AA 275 %CONSTINTEGER RAD=16_F0,RSB=16_F2,RRSB=16_F4,FLT=16_A8,RRDV=16_BC, {%C 276+ RSC=16_F8,FIX=16_B8,RDV=16_BA,RDDV=16_BE,RMYD=16_FC, {%C 277+ RMY=16_FA 278 ! 279 %CONSTINTEGER MVL=16_B0,MV=16_B2,SWEQ=16_A0,SWNE=16_A2,CPS=16_A4 280 ! 281 ! DEFINE SOME MNEMONICS FOR THE VISIBLE REGISTERS (XCEPT LNB) 282 ! 283 %CONSTINTEGER ACCR=0,DR=1,LNB=2,XNB=3,PC=4,CTB=5,TOS=6,BREG=7 284 %CONSTBYTEINTEGERARRAY LDCODE(0:7)=0,16_78,16_7C,16_7E,0,48,0,16_7A; 285 ! 286 %CONSTSTRING(8)MDEP="S#NDIAG" 287 %CONSTSTRING(8)IOCPEP="S#IOCP"; ! EP FOR IOCP 288 %CONSTSTRING(11)AUXSTEP="ICL9CEAUXST";! DATA REF FOR INDIRECT AUX ST 289 %CONSTINTEGER SNPT=16_1006; ! SPECIALNAME PTYPE 290 %CONSTINTEGER COMMALT=2,ENDALT=9,UNASSPAT=16_81818181,DECALT=8 291 ! 292 %INTEGER DICTBASE, CONSTPTR, CONSTBTM, DFHEAD, CONSTHOLE, WKFILEAD, {%C 293+ WKFILEK, DUMMYFORMAT, P1SIZE, LEVELINF, IOCPDISP, PARMBITS1, {%C 294+ PARMBITS2,PARMLET 295 ! 296 %INTEGER ASL, NNAMES, ARSIZE, CABUF, PPCURR, CONSTLIMIT, OLDLINE, {%C 297+ LINE, LENGTH, NEXTP, SNUM, RLEVEL, NMAX, USTPTR, PLABEL,{%C 298+ LEVEL, CA, LASTNAME, CDCOUNT, ASL CUR BTM, PARMDYNAMIC 299 ! 300 %INTEGER FAULTY, HIT, INHCODE, IMPS, TTOPUT, LIST, PARMDIAG, {%C 301+ WARNFLAG, PARMTRACE, PARMLINE, PARMOPT, CTYPE, DCOMP, {%C 302+ CPRMODE, PARMCHK, PARMARR, ALLLONG, PARMDBUG,{%C 303+ COMPILER, LAST INST, SMAP, STACK, AUXST, PARMY, BFFLAG 304 ! 305 %INTEGER RBASE, N, FREE FORMAT, PARMPROF, EXITLAB, CONTLAB, {%C 306+ Q, R, S, NEST, FNAME, LDPTR, GLACA, GLACABUF, {%C 307+ GLACURR, CREFHEAD, SSTL, QMAX, STMTS, LASTAT, {%C 308+ FILE ADDR, FILE PTR, FILE END, FILE SIZE, LASTEND, {%C 309+ BIMSTR,STLIMIT,STRLINK,RECTB,ASL WARN,IHEAD 310 ! 311 %INTEGER MAX ULAB, SFLABEL 312 %LONGREAL CVALUE, IMAX, CTIME 313 %STRING(31)MAINEP 314 %RECORDFORMAT LISTF(%INTEGER S1,S2,S3,LINK) 315 %INTEGER LOGEPDISP,EXPEPDISP 316 ! 317 %SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N) 318 %BEGIN 319 FILE ADDR=COMREG(46); ! SOURCE FILE IF CLEAN 320 PARMBITS1=COMREG(27) 321 PARMBITS2=COMREG(28) 322 WKFILEAD=COMREG(14) 323 {WKFILEK=INTEGER(WKFILEAD+8)>>10 324 wkfilek = 128 325 %IF FILE ADDR<=0 %THEN FILESIZE=64000 %AND FILE ADDR=0 %ELSESTART 326 FILE PTR=FILE ADDR+INTEGER(FILE ADDR+4) 327 FILE END=FILE ADDR+INTEGER(FILE ADDR) 328 FILE SIZE=INTEGER(FILE ADDR) 329 %FINISH 330 NNAMES=255 331 %IF FILESIZE>10000 %THEN NNAMES=511 332 %IF PARMBITS1&JOBBER BIT=0 %START 333 %IF FILESIZE>32000 %THEN NNAMES=1023 334 %IF FILESIZE>256*1024 %OR PARMBITS2&MAXDICT#0 %OR WKFILEK>512 %THEN NNAMES=2047 335 %FINISH 336 ASL=3*NNAMES 337 ASL=4095 %IF ASL>4095 %AND PARMBITS2&MAXDICT=0;! STAY WITHIN 128K AUXSTACK 338 ARSIZE=WKFILEK*768-300 339 {%END ... extra block level enables dynamic array bound declarations ... 340 {%BYTEINTEGERARRAYFORMAT AF(0:ARSIZE) 341 {%BYTEINTEGERARRAYNAME A 342 %byteintegerarray A(0:WKFILEK*1024) 343 %RECORD(LISTF)%ARRAY ASLIST(0:ASL){(LISTF) 344 %INTEGERARRAY WORD, TAGS(0:NNAMES) 345 %INTEGERARRAY DVHEADS(0:12) 346 %INTEGERFNSPEC FROMAR4(%INTEGER PTR) 347 %INTEGERFNSPEC FROMAR2(%INTEGER PTR) 348 %ROUTINESPEC TOAR8(%INTEGER PTR, %LONGREAL VALUE) 349 %ROUTINESPEC TOAR4(%INTEGER PTR, VALUE) 350 %ROUTINESPEC TOAR2(%INTEGER PTR,VALUE) 351 %ROUTINESPEC WARN(%INTEGER N,V) 352 %ROUTINESPEC FAULT2(%INTEGER N,VAL,IDEN) 353 %ROUTINESPEC FAULT(%INTEGER N, VALUE) 354 %STRING(255)%FNSPEC PRINTNAME(%INTEGER N) 355 %INTEGERFNSPEC MORE SPACE 356 !%INTEGERFNSPEC NEWCELL 357 %ROUTINESPEC INSERTATEND(%INTEGERNAME S, %INTEGER A, B, C) 358 %ROUTINESPEC FROM12(%INTEGER CELL, %INTEGERNAME S1, S2) 359 %ROUTINESPEC FROM123(%INTEGER CELL, %INTEGERNAME S1, S2, S3) 360 %ROUTINESPEC POP(%INTEGERNAME C, P, Q, R) 361 %ROUTINESPEC PUSH(%INTEGERNAME C, %INTEGER S1, S2, S3) 362 %INTEGERFNSPEC FIND(%INTEGER LAB, LIST) 363 %ROUTINESPEC MLINK(%INTEGERNAME CELL) 364 %ROUTINESPEC REPLACE1(%INTEGER CELL, S1) 365 %ROUTINESPEC REPLACE2(%INTEGER CELL, S2) 366 %ROUTINESPEC REPLACE3(%INTEGER CELL,S3) 367 %ROUTINESPEC REPLACE123(%INTEGER CELL,A1,A2,S3) 368 %INTEGERFNSPEC FROM2(%INTEGER CELL) 369 %INTEGERFNSPEC FROM1(%INTEGER CELL) 370 %INTEGERFNSPEC FROM3(%INTEGER CELL) 371 %ROUTINESPEC BINSERT(%INTEGERNAME T,B,%INTEGER S1,S2,S3) 372 %ROUTINESPEC CLEARLIST(%INTEGERNAME HEAD) 373 %STRING(255)%FNSPEC MESSAGE(%INTEGER N) 374 %SYSTEMROUTINESPEC LPUT(%INTEGER A, B, C, D) 375 %SYSTEMLONGREALFNSPEC CPUTIME 376 !*DELSTART 377 %SYSTEMROUTINESPEC NCODE(%INTEGER START, FINISH, CA) 378 %ROUTINESPEC PRINTLIST(%INTEGER HEAD) 379 %ROUTINESPEC PRHEX(%INTEGER VALUE,PLACES) 380 %ROUTINESPEC CHECK ASL 381 !*DELEND 382 %IF VMEB=NO %THEN %START 383 %SYSTEMROUTINESPEC CONSOURCE(%STRING(31)FILE,%INTEGERNAME AD) 384 %FINISH 385 ! START OF COMPILATION 386 {A==ARRAY(WKFILE AD+256*WKFILEK, AF) 387 %BEGIN 388 !*********************************************************************** 389 !* THIS BLOCK INITIALISE THE COMPILER SCALARS AND ARRAYS * 390 !* WAS ORIGINALLY ROUTINE 'INITIALISE'. * 391 !* THE INITIALISATION OF THE CONSTANT LISTS WITH THE VALUES * 392 !* IN PERM MAY BE OMITTED IN BATCH OR CUT-DOWN VERSIONS. * 393 !*********************************************************************** 394 %ROUTINESPEC READ LINE(%INTEGER MODE,CHAR) 395 %INTEGERFNSPEC COMPARE(%INTEGER P) 396 %ROUTINESPEC PNAME(%INTEGER MODE) 397 %ROUTINESPEC CONST(%INTEGER MODE) 398 %ROUTINESPEC TEXTTEXT(%INTEGER EBCDIC) 399 %INTEGER CCSIZE,DSIZE,NEXT,ATLINE1,STARSTART 400 CCSIZE=1000; DSIZE=7*NNAMES 401 %INTEGERARRAY DISPLAY,SFS(0:MAXLEVELS) 402 %BYTEINTEGERARRAY TLINE(-60:161),CC(0:CCSIZE),LETT(0:DSIZE+20) 403 %LONGINTEGER ATL0,ASYM0 404 %CONSTBYTEINTEGERARRAY ILETT(0: 500)= 11, 405+ 'S','E','L','E','C','T','I','N','P','U','T', 12,'S','E','L','E', 406+ 'C','T','O','U','T','P','U','T', 7,'N','E','W','L','I','N','E', 407+ 5,'S','P','A','C','E', 10,'S','K','I','P','S','Y','M','B','O', 408+ 'L', 10,'R','E','A','D','S','T','R','I','N','G', 8,'N','E','W', 409+ 'L','I','N','E','S', 6,'S','P','A','C','E','S', 10,'N','E','X', 410+ 'T','S','Y','M','B','O','L', 11,'P','R','I','N','T','S','Y','M', 411+ 'B','O','L', 10,'R','E','A','D','S','Y','M','B','O','L', 4,'R', 412+ 'E','A','D', 5,'W','R','I','T','E', 7,'N','E','W','P','A','G', 413+ 'E', 4,'A','D','D','R', 6,'A','R','C','S','I','N', 3,'I','N', 414+ 'T', 5,'I','N','T','P','T', 6,'F','R','A','C','P','T', 5,'P', 415+ 'R','I','N','T', 7,'P','R','I','N','T','F','L', 4,'R','E','A', 416+ 'L', 7,'I','N','T','E','G','E','R', 3,'M','O','D', 6,'A','R', 417+ 'C','C','O','S', 4,'S','Q','R','T', 3,'L','O','G', 3,'S','I', 418+ 'N', 3,'C','O','S', 3,'T','A','N', 3,'E','X','P', 11,'C','L', 419+ 'O','S','E','S','T','R','E','A','M', 11,'B','Y','T','E','I','N', 420+ 'T','E','G','E','R', 8,'E','V','E','N','T','I','N','F', 421+ 6,'R','A','D','I','U','S', 6,'A','R','C','T','A','N', 422+ 6,'L','E','N','G','T','H', 11,'P','R','I','N','T','S','T','R', 423+ 'I','N','G', 2,'N','L', 8,'L','O','N','G','R','E','A','L', 7, 424+ 'P','R','I','N','T','C','H', 6,'R','E','A','D','C','H', 6,'S', 425+ 'T','R','I','N','G', 8,'R','E','A','D','I','T','E','M', 8,'N', 426+ 'E','X','T','I','T','E','M', 6,'C','H','A','R','N','O', 8,'T', 427+ 'O','S','T','R','I','N','G', 10,'F','R','O','M','S','T','R','I', 428+ 'N','G', 6,'R','E','C','O','R','D', 5,'A','R','R','A','Y', 10, 429+ 'S','E','T','M','A','R','G','I','N','S',4,'I','M','O','D',2,'P', 430+ 'I',9,'E','V','E','N','T','L','I','N','E',11,'L','O','N','G', 431+ 'I','N','T','E','G','E','R',12,'L','O','N','G','L','O','N','G', 432+ 'R','E','A','L',9,'L','E','N','G','T','H','E','N','I', 433+ 9,'L','E','N','G','T','H','E','N','R', 434+ 8,'S','H','O','R','T','E','N','I', 435+ 8,'S','H','O','R','T','E','N','R', 436+ 6,'N','E','X','T','C','H', 437+ 11,'H','A','L','F','I','N','T','E','G','E','R', 438+ 8,'P','P','R','O','F','I','L','E',255; 439 IMAX=(-1)>>1;PLABEL=24999 440 LETT(0)=0 441 ATLINE1=ADDR(TLINE(1)) 442 INTEGER(ADDR(ATL0)+4)=ATLINE1-1 443 INTEGER(ADDR(ATL0))=16_18000100 444 INTEGER(ADDR(ASYM0))=16_28000C00 445 INTEGER(ADDR(ASYM0)+4)=ADDR(SYMBOL(1300))-4*1300 446 N=12; 447 MAX ULAB=NNAMES+16384; ! LARGEST VALID USER LABEL 448 GLACURR=0; GLACA=FIXEDGLALEN; GLACABUF=GLACA 449 PARMOPT=1 ; PARMARR=1; LAST INST=0 450 PARMLINE=1; PARMTRACE=1; PARMDIAG=1 451 LIST=1; SFLABEL=20999; PARMCHK=1 452 EXITLAB=0; CONTLAB=0 453 CABUF=0; PPCURR=0; OLDLINE=0; COMPILER=0 454 RLEVEL=0; NMAX=0; USTPTR=0 455 LEVEL=0; CA=0; LASTAT=0 456 FAULTY=0; WARNFLAG=0; ALLLONG=0; INHCODE=0 457 DCOMP=0; BFFLAG=0; CPRMODE=0 458 NEXT=1; LDPTR=0 459 IOCPDISP=0; CREFHEAD=0; AUXST=0 460 RBASE=10; LOGEPDISP=0; EXPEPDISP=0; STRLINK=0 461 RECTB=0; IHEAD=0 462 SSTL=0; STMTS=1; SNUM=0; LEVELINF=0 463 CDCOUNT=0 464 BIMSTR=0 465 LOGEPDISP=0; EXPEPDISP=0 466 MAINEP="S#GO"; ! DEFAULT MAIN ENTRY 467 DICTBASE=ADDR(LETT(0)) 468 ! 469 ! OPEN OBJECT FILE HERE BEFORE MORE PAGES OF COMPILER CODE 470 ! ARE PAGED IN AND SUB-SYSTEM PAGES MOVE OUT 471 ! 472 LPUT(0,0,0,0) 473 CTIME=CPUTIME 474 I=COMREG(27) 475 STLIMIT=16_1F000 476 %IF I>>24&1#0 %THEN STLIMIT=COMREG(48)-4096 477 %IF I&2=2 %THEN LIST=0 478 %IF I&4=4 %THEN PARMDIAG=0 479 %IF I&16_800000#0 %THEN PARMLINE=0 480 %IF I&16=16 %THEN PARMCHK=0 481 %IF I&32=32 %THEN PARMARR=0 482 PARMPROF=(I>>15&1)!(I>>7&1); ! USE MAP OR PROFILE BIT PRO TEM 483 PARMDYNAMIC=I>>20&1 484 PARMLET=I>>13&1 485 DCOMP=I>>14&1; ! PARM CODE OR D 486 PARMDBUG=I>>18&1 487 %IF I&64=64 %THEN PARMTRACE=0 %AND PARMDIAG=0 488 FREE FORMAT=I&16_80000 489 STACK=I>>3&1 490 SMAP=I>>26&1; ! USE PARMZ BIT FOR DUMPING WKFILE 491 TTOPUT=COMREG(40) 492 %IF I&(1<<16)#0 %THEN %START 493 PARMARR=0; PARMOPT=0 494 PARMLINE=0; PARMCHK=0; PARMDIAG=0 495 %FINISH 496 PARMTRACE=PARMTRACE!PARMOPT; ! ALLOW NOTRACE ONLY WITH OPT 497 IMPS=I>>23&1; ! BIT SET IF IMPS REQUESTED 498 IMPS=1; ! FOR TESTING 499 NEWLINES(3); SPACES(14) 500 PRINTSTRING("ERCC. Imp") 501 %IF IMPS#0 %THEN PRINTSYMBOL('s') 502 PRINTSTRING(" Compiler Release") 503 WRITE(RELEASE,1) 504 PRINTSTRING(" Version ".LADATE) 505 NEWLINES(3) 506 WRITE(NNAMES,5); WRITE(ASL,5) 507 NEWLINE 508 ASL WARN=0 509 ASL CUR BTM=ASL-240 510 CONST LIMIT=4*ASL CUR BTM-8 511 %CYCLE I=ASL CUR BTM,1,ASL-1 ?Non-local 512 ASLIST(I+1)_LINK=I 513 %REPEAT 514 ASLIST(ASL CUR BTM)_LINK=0 515 ASLIST(0)_S1=-1 516 ASLIST(0)_S2=-1 517 ASLIST(0)_S3=-1 518 ASLIST(0)_LINK=0 519 %CYCLE I=0,1,NNAMES ?Non-local 520 WORD(I)=0; TAGS(I)=0; 521 %REPEAT 522 %CYCLE I=0,1,12 ?Non-local 523 DVHEADS(I)=0 524 %REPEAT 525 ! 526 ! NOW DECLARE THE SPECIAL NAMES WHICH ARE IN ARRAY ILETT. 527 ! 528 K=0; NEXT=1 529 I=ILETT(0) 530 %WHILE I<255 %CYCLE 531 %CYCLE J=I,-1,1 ?Non-local 532 CC(J)=ILETT(K+J) 533 %REPEAT 534 CC(I+1)=';' 535 R=2; Q=1; PNAME(1) 536 PUSH(TAGS(LASTNAME),SNPT<<16!16_8000,0,SNUM<<16) 537 SNUM=SNUM+1 538 K=K+I+1; I=ILETT(K) 539 %REPEAT 540 ! 541 COMREG(24)=16; ! RETURN CODE 542 DUMMY FORMAT=0; ! DUMMY RECORD FORMAT 543 DFHEAD=0 544 PUSH(DFHEAD,0,0,0) 545 PUSH(DUMMY FORMAT,0,0,DFHEAD); ! FOR BETTER ERROR RECOVERY 546 LINE=0; LENGTH=0; Q=1 547 R=1; LEVEL=1 548 %CYCLE 549 %IF Q>=LENGTH %THEN QMAX=1 %AND READ LINE(0,0) 550 WARNFLAG=0 551 STARSTART=R 552 R=R+3 553 OLDLINE=LINE 554 A(R)=LINE>>8 555 A(R+1)=LINE&255 556 R=R+2 557 %IF COMPARE(SS)=0 %THEN %START 558 FAULT(100,ADDR(CC(0))) 559 R=STARSTART 560 %FINISH %ELSE %START 561 FAULT(102, 0) %IF R>ARSIZE 562 %IF A(STARSTART+5)=COMMALT %THEN R=STARSTART %ELSE %START 563 I=R-STARSTART 564 A(STARSTART)=I>>16 565 A(STARSTART+1)=I>>8&255 566 A(STARSTART+2)=I&255 567 %IF A(STARSTART+5)=DECALT %AND LEVEL>1 %THEN %START 568 %IF SFS(LEVEL)=0 %THEN %START 569 TO AR4(DISPLAY(LEVEL),STARSTART) 570 DISPLAY(LEVEL)=STARSTART+6 571 %FINISH %ELSE A(STARSTART+6)=128;! FLAG AS UNLINKED 572 %FINISH 573 !*DELSTART 574 %IF SMAP#0 %THEN %START 575 NEWLINE; WRITE(LINE, 5) 576 WRITE(STARSTART,5); NEWLINE; J=0 577 %CYCLE I=STARSTART, 1, R-1 ?Non-local 578 WRITE(A(I), 5) 579 J=J+1 580 %IF J>=20 %THEN NEWLINE %AND J=0 581 %REPEAT 582 NEWLINE 583 %FINISH 584 !*DELEND 585 %EXIT %IF A(STARSTART+5)=ENDALT %AND 1<=A(STARSTART+6)<=2;! ENDOF PROG OR FILE 586 %IF LEVEL=0 %THEN FAULT(14, 0) %AND %EXIT 587 %FINISH 588 %FINISH 589 %REPEAT 590 TO AR8(R,0); R=R+8 591 %IF R+NEXT>ARSIZE %THEN FAULT(102,0) 592 P1SIZE=R 593 ! %IF USE IMP=YES %THEN %START 594 %CYCLE I=0,1,NEXT ?Non-local 595 A(R+I)=LETT(I) 596 %REPEAT 597 ! %FINISH %ELSE %START 598 ! *LDTB_16_18000000 599 ! *LDB_NEXT 600 ! *LDA_LETT+4 601 ! *CYD_0 602 ! *LDA_A+4 603 ! *INCA_R 604 ! *MV_%L=%DR 605 ! %FINISH 606 DICTBASE=ADDR(A(R)) 607 R=R+NEXT+1 608 ->BEND 609 %ROUTINE READ LINE(%INTEGER MODE,CHAR) 610 %ROUTINESPEC GET LINE 611 %INTEGER DEL, LL, LP 612 LL=0; LP=0; Q=1 613 LENGTH=0; DEL=0 614 NEXT: 615 ! %IF USE IMP=YES %THEN %START 616 LP=LP+1 617 %IF LP>LL %THEN GET LINE %AND LP=1 618 I=TLINE(LP) 619 %IF MODE=0 %THEN %START 620 %IF I='%' %THEN DEL=128 %AND ->NEXT 621 I=ONE CASE(I) 622 %IF 'A'<=I<='Z' %THEN I=I!DEL %ELSE %START 623 DEL=0 624 ->NEXT %IF I=' ' 625 %FINISH 626 LENGTH=LENGTH+1 627 CC(LENGTH)=I 628 %IF I='''' %OR I=34 %THEN MODE=1 %AND CHAR=I 629 %FINISH %ELSE %START 630 LENGTH=LENGTH+1 631 CC(LENGTH)=I 632 %IF I=CHAR %THEN MODE=0 633 %FINISH 634 ->NEXT %UNLESS I=NL 635 ! %FINISH %ELSE %START 636 ! *LB_LP 637 ! *ADB_1 638 ! *CPB_LL 639 ! *JCC_12, 640 ! GET LINE 641 ! *LB_1 642 !RLL1: 643 ! *STB_LP 644 ! *LB_(ATL0+%B) 645 ! *LSS_MODE 646 ! *JAF_4, 647 ! *CPB_37; !'%' 648 ! *JCC_7, 649 ! *L_128 650 ! *ST_DEL 651 ! *J_ 652 !RLL3: 653 ! *LSS_(ONE CASE+%B); ! LOWER CASE TO UPPER 654 ! *ICP_65; !'A' 655 ! *JCC_4, 656 ! *ICP_90; !'Z' 657 ! *JCC_2, 658 ! *OR_DEL 659 ! *J_ 660 !RLL4: 661 ! *LB_0 662 ! *STB_DEL 663 ! *ICP_32; !' ' 664 ! *JCC_8, 665 !RLL5: 666 ! *LB_LENGTH 667 ! *ADB_1 668 ! *STB_LENGTH 669 ! *ST_(CC+%B) 670 ! *ICP_39; !'''' 671 ! *JCC_8, 672 ! *ICP_34; !'"' 673 ! *JCC_7, 674 !RLL6: 675 ! *ST_CHAR 676 ! *LB_1 677 ! *STB_MODE 678 !RLL7: 679 ! *ICP_10 680 ! *JCC_7, 681 ! *J_ 682 !RLL2: 683 ! *LSS_%B 684 ! *LB_LENGTH 685 ! *ADB_1 686 ! *STB_LENGTH 687 ! *ST_(CC+%B) 688 ! *ICP_CHAR 689 ! *JCC_7, 690 ! *LB_0 691 ! *STB_MODE 692 !RLL9: 693 ! *ICP_10 694 ! *JCC_7, 695 !RLL8: 696 ! %FINISH 697 %IF CC(LENGTH-1)='C'+128 %THEN LENGTH=LENGTH-2 %AND ->NEXT 698 FAULT(101,0) %IF LENGTH>CCSIZE 699 %RETURN 700 %ROUTINE GET LINE 701 %SYSTEMROUTINESPEC IOCP(%INTEGER A,B) 702 %CONSTBYTEINTEGERARRAY ITOI(0:255)={%C 703+ 32(10),10,32(14),25,26,32(5), 704+ 32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47, 705+ 48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63, 706+ 64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79, 707+ 80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95, 708+ 96,97,98,99,100,101,102,103,104,105,106,107,108,109, 709+ 110,111,112,113,114,115,116,117,118,119, 710+ 120,121,122,123,124,125,126,32, 711+ 26(5),10,26(10), 712+ 26(16), 713+ 26(14),92,38, 714+ 26(11),35,26(4), 715+ 26(16), 716+ 26(9),35,26(5),94, 717+ 26(32); 718 %INTEGER K 719 LL=0 720 %IF FILE ADDR=0 %THEN %START; ! SOURCE NOT A 'CLEAN' FILE 721 {%UNTIL K=NL} %CYCLE 722 READ SYMBOL(K) 723 TLINE(LL+1)=ITOI(K) 724 LL=LL+1 725 %REPEAT %UNTIL K=NL 726 %FINISH %ELSE %START 727 %IF FILEPTR>=FILE END %START 728 %IF IHEAD#0 %THEN POP(IHEAD,FILEADDR,FILEPTR,FILEEND) %AND GETLINE %AND %RETURN 729 %SIGNAL %EVENT 9,1 730 %FINISH 731 ! %IF USE IMP=NO %THEN %START 732 ! *LDA_FILEPTR 733 ! *LB_FILEEND 734 ! *SBB_FILEPTR 735 ! *ADB_16_18000000 736 ! *LDTB_%B 737 ! *SWNE_%L=%DR,0,10 738 ! *JCC_8, 739 ! *CYD_0 740 ! *STUH_%B 741 ! *IAD_1 742 ! *ST_%B 743 ! *ISB_FILEPTR 744 ! *ST_LL 745 ! *LDA_FILEPTR 746 ! *STB_FILEPTR 747 ! *LDB_LL 748 ! *CYD_0 749 ! *LDA_ATLINE1 750 ! *MV_%L=%DR,0,0 751 ! *LDA_ATLINE1; *LDTB_16_18000000 752 ! *LDB_LL 753 ! *LSS_ITOI+4; *LUH_16_180000FF 754 ! *TTR_%L=%DR 755 ! ->OLIST 756 ! %FINISH 757 IMP: 758 {%UNTIL K=NL %OR K=0} %CYCLE 759 K=BYTE INTEGER(FILEPTR); ! NEXT CHAR FROM SORCE FILE 760 FILE PTR=FILE PTR+1 761 TLINE(LL+1)=ITOI(K) 762 LL=LL+1 763 %REPEAT %UNTIL K=NL %OR K=0 764 OLIST: 765 %FINISH 766 ! %IF MODE=0 %AND LL=1 %THEN GET LINE %AND %RETURN 767 ! LINE=LINE+1 %UNLESS MODE=0 %AND LENGTH>0 768 LINE=LINE+1; ! COUNT ALL LINES 769 %IF LIST#0 %THEN %START 770 %IF MODE=0 %AND LENGTH>0 %THEN PRINTSTRING(" C") %ELSE WRITE(LINE, 5) 771 ! SPACES(8) 772 %CYCLE K=-7,1,0 773 TLINE(K)=' ' 774 %REPEAT 775 %IF MODE#0 %THEN TLINE(-7)=M'"' 776 TLINE(-8)=LL+8 777 IOCP(15,ADDR(TLINE(-8))) 778 %FINISH 779 %IF FREE FORMAT=0 %AND LL>73 %THEN TLINE(73)=10 %AND LL=73 780 %END ?OLIST unused ?IMP unused 781 %END 782 %INTEGERFN COMPARE(%INTEGER P) 783 %INTEGER I, J, ITEM, RA, RL, RP, RQ, RR, RS, MARKER, SSL, ALT, PP 784 %OWNINTEGER SAVECOMP; ! FOR CHECKING DSIDED CONDS 785 %SWITCH BIP(999:1038) 786 ! %IF USE IMP=YES %THEN %START 787 RP=SYMBOL(P) 788 RL=LEVEL 789 P=P+1 790 PP=P; ! ROUTINE REALLY STARTS HERE 791 ! %FINISH %ELSE %START 792 ! *LB_P 793 ! *JLK_2 794 ! *EXIT_-64 795 !SUBENTRY: 796 ! *LSS_(ASYM0+%B) 797 ! *LUH_LEVEL 798 ! *ST_RL 799 ! *ADB_1 800 ! *STB_P 801 ! *STB_PP 802 ! %FINISH 803 COMM: 804 ! %IF USE IMP=YES %THEN %START 805 RQ=Q; ! RESET VALUES OF LINE&AR PTRS 806 RR=R 807 SSL=STRLINK; ! SAVE STRING LINK 808 ALT=1; ! FIRST ALTERNATIVE TO BE TRIED 809 RA=SYMBOL(P); ! RA TO NEXT PHRASE ALTERNATIVE 810 RS=P 811 ! %FINISH %ELSE %START 812 ! *LSD_Q 813 ! *ST_RQ 814 ! *LSS_1 815 ! *LUH_STRLINK 816 ! *ST_SSL 817 ! *LB_P 818 ! *LSS_(ASYM0+%B) 819 ! *ST_RA 820 ! *STB_RS 821 ! %FINISH 822 UPR: R=R+1 823 SUCC: ! SUCCESS ON TO NEXT ITEM 824 ! %IF USE IMP=YES %THEN %START 825 RS=RS+1; ! RS=NEXT ALTERNATIVE MEANS THAT 826 ! THIS ALT HAS BEEN COMPLETED SO 827 ! EXIT WITH HIT=1 828 %IF RS=RA %THEN ->FINI 829 ITEM=SYMBOL(RS); ! NEXT BRICK IN THE CURRENT ALT 830 %IF ITEM<999 %THEN ->LIT 831 ! %FINISH %ELSE %START 832 ! *LB_RS 833 ! *ADB_1 834 ! *CPB_RA 835 ! *JCC_8, 836 ! *STB_RS 837 ! *LB_(ASYM0+%B) 838 ! *CPB_999 839 ! *JCC_4, 840 ! *STB_ITEM 841 ! %FINISH 842 %IF ITEM<1300 %THEN ->BIP(ITEM) 843 ! BRICK IS A PHRASE TYPE 844 ! %IF USE IMP=YES %THEN %START 845 %IF COMPARE(ITEM)=0 %THEN ->FAIL 846 ! %FINISH %ELSE %START 847 ! *LSD_RA 848 ! *SLSQ_RP 849 ! *SLSQ_MARKER 850 ! *ST_%TOS 851 ! *LB_ITEM 852 ! *JLK_ 853 ! *ST_%B; ! RESULT=0 FOR FAIL 854 ! *LSQ_%TOS; *ST_MARKER 855 ! *LSQ_%TOS; *ST_RP 856 ! *LSD_%TOS; *ST_RA 857 ! *JAT_12, 858 ! %FINISH 859 ->SUCC 860 LIT: ! BRICK IS LITERAL 861 ! %IF USE IMP=YES %THEN %START 862 I=CC(Q); ! OBTAIN CURRENT CHARACTER 863 ->FAIL %UNLESS I=CLETT(ITEM+1) 864 Q=Q+1 865 K=CLETT(ITEM)+ITEM 866 ITEM=ITEM+2 867 %WHILE ITEM<=K %CYCLE 868 ->FAIL %UNLESS CC(Q)=CLETT(ITEM) 869 Q=Q+1 870 ITEM=ITEM+1 871 %REPEAT; ! CHECK IT WITH LITERAL DICT ENTRY 872 ! %FINISH %ELSE %START 873 ! *LDB_(CLETT+%B) 874 ! *INCA_%B 875 ! *INCA_1 876 ! *LSS_Q 877 ! *IAD_CC+4 878 ! *LUH_CC 879 ! *CPS_%L=%DR,0,0 880 ! *JCC_7, 881 ! *STUH_%B 882 ! *ISB_CC+4 883 ! *ST_Q 884 ! %FINISH 885 ->SUCC; ! MATCHED SUCCESSFULLY 886 FAIL: ! FAILURE - NOTE POSITION REACHD 887 ! %IF USE IMP=YES %THEN %START 888 %IF RA=RP %THEN ->TFAIL; ! TOTAL FAILURE NO ALT TO TRY 889 QMAX=Q %IF Q>QMAX 890 Q=RQ; ! RESET LINE AND A.R. POINTERS 891 R=RR+1; ! AVOID GOING VIA UPR: 892 STRLINK=SSL 893 ALT=ALT+1; ! MOVE TO NEXT ALT OF PHRASE 894 RS=RA 895 RA=SYMBOL(RA) 896 ! %FINISH %ELSE %START 897 ! *LB_RA 898 ! *CPB_RP 899 ! *JCC_8, 900 ! *LSS_Q 901 ! *ICP_QMAX 902 ! *JCC_12, 903 ! *ST_QMAX 904 !CPL1: *LSD_RQ 905 ! *IAD_1 906 ! *ST_Q 907 ! *L_SSL 908 ! *STUH_STRLINK 909 ! *IAD_1 910 ! *ST_ALT 911 ! *STB_RS 912 ! *L_(ASYM0+%B) 913 ! *ST_RA 914 ! %FINISH 915 ->SUCC 916 TFAIL: 917 LEVEL=RL 918 ! %IF USE IMP=YES %THEN %START 919 %RESULT=0 920 ! %FINISH %ELSE %START 921 ! *LSS_0; *J_%TOS 922 ! %FINISH 923 BIP(999): ! REPEATED PHRASE 924 A(RR)=ALT; P=PP 925 ->COMM 926 BIP(1000):FINI: ! NULL ALWAYS LAST & OK 927 A(RR)=ALT 928 ! %IF USE IMP=YES %THEN %START 929 %RESULT=1 930 ! %FINISH %ELSE %START 931 ! *LSS_1; *J_%TOS 932 ! %FINISH 933 BIP(1001): ! PHRASE NAME 934 BIP(1004): ! PHRASE OLDNAME 935 I=CC(Q); ! OBTAIN CURRENT CHARACTER 936 ->FAIL %UNLESS TRTAB(I)=2 937 PNAME(ITEM-1004) 938 ->SUCC %IF HIT=1; ->FAIL 939 BIP(1002): ! PHRASE INTEGER CONSTANT 940 BIP(1003): ! PHRASE CONST 941 CONST(ITEM-1003) 942 ->FAIL %IF HIT=0 943 ->SUCC 944 BIP(1005): ! PHRASE N 945 I=CC(Q); ! OBTAIN CURRENT CHARACTER 946 ->FAIL %UNLESS '0'<=I<='9' 947 S=0 948 %WHILE '0'<=I<='9' %CYCLE 949 S=10*S+I&15 950 Q=Q+1; I=CC(Q) 951 %REPEAT 952 TOAR2(R,S) 953 R=R+2; ->SUCC 954 BIP(1006): ! PHRASE S=SEPARATOR 955 I=CC(Q); ! OBTAIN CURRENT CHARACTER 956 ->SUCC %IF I=NL 957 ->FAIL %UNLESS I=';' 958 Q=Q+1; ->SUCC 959 BIP(1007): 960 ! PHRASE COMMENT TEXT 961 I=CC(Q); ! OBTAIN CURRENT CHARACTER 962 J=I 963 ->TX %IF I=';' %OR I=NL 964 ->FAIL %UNLESS I='!' %OR I='|' %OR (I='C'+128 %AND CC(Q+1)='O'+128 %AND CC(Q+2)=CC(Q+3)='M'+128 %AND CC(Q+4)='E'+128 %AND CC(Q+5)='N'+128 %AND CC(Q+6)='T'+128) 965 Q=Q+1+6*(I>>7); J=CC(Q) 966 %CYCLE 967 %EXIT %IF J=NL %OR J=';' 968 Q=Q+1; J=CC(Q) 969 %REPEAT 970 TX: Q=Q+1 %IF J=';' 971 ->SUCC 972 BIP(1008): ! PHRASE BIGHOLE 973 TO AR4(R,0) 974 R=R+4; ->SUCC 975 BIP(1009): ! PHRASE N255 976 I=CC(Q); ! OBTAIN CURRENT CHARACTER 977 ->FAIL %UNLESS '0'<=I<='9' 978 S=0 979 %WHILE '0'<=I<='9' %CYCLE 980 S=10*S+I&15 981 Q=Q+1; I=CC(Q) 982 %REPEAT 983 ->FAIL %UNLESS 0<=S<=255 984 A(R)=S; ->UPR 985 BIP(1010): ! PHRASE HOLE 986 MARKER=R; R=R+2; ->SUCC 987 BIP(1011): ! PHRASE MARK 988 I=R-MARKER 989 A(MARKER+1)<-I 990 A(MARKER)<-I>>8 991 ->SUCC 992 BIP(1012): ! PHRASE READLINE? 993 I=CC(Q); ! OBTAIN CURRENT CHARACTER 994 %WHILE I=NL %%CYCLE 995 READLINE(0,0) 996 RQ=1 997 I=CC(Q) 998 %REPEAT 999 FAULT(102,0) %IF R>ARSIZE 1000 ->SUCC 1001 BIP(1013): ! PHRASE CHECKIMPS 1002 ->FAIL %UNLESS IMPS=1; ->SUCC 1003 BIP(1014): ! PHRASE DUMMY APP 1004 A(R)=2; A(R+1)=2 1005 R=R+2; ->SUCC 1006 BIP(1015): ! PHRASE DOWN=NEW TEXT LEVEL 1007 LEVEL=LEVEL+1 1008 TO AR4(R,0) 1009 DISPLAY(LEVEL)=R 1010 SFS(LEVEL)=0 1011 R=R+4 1012 ->SUCC 1013 BIP(1016): ! PHRASE UP 1 TEXTUAL LEVEL 1014 DISPLAY(LEVEL)=0 1015 %WHILE SFS(LEVEL)#0 %CYCLE 1016 POP(SFS(LEVEL),I,J,K) 1017 %IF I=1 %THEN FAULT2(53,K,0); ! FINISH MISSING 1018 %IF I=2 %THEN FAULT2(13,K,0); ! %REPEAT MISSING 1019 %REPEAT 1020 LEVEL=LEVEL-1 1021 ->SUCC 1022 BIP(1017): ! PHRASE LISTON 1023 LIST=1; ->SUCC 1024 BIP(1018): ! PHRASE LISTOFF 1025 LIST=0; ->SUCC 1026 BIP(1019): ! PHRASE COLON FOR LABEL 1027 ->FAIL %UNLESS CC(Q-1)=':' 1028 ->SUCC 1029 BIP(1020): ! PHRASE NOTE CONST 1030 %IF CTYPE=5 %THEN TOAR4(S-4,STRLINK) %AND STRLINK=S-4 1031 ->SUCC 1032 BIP(1021): ! TRACE FOR ON CONDITIONS 1033 PARMTRACE=1; ->SUCC 1034 BIP(1022): ! SET MNEMONIC 1035 I=CC(Q); ! OBTAIN CURRENT CHARACTER 1036 S=M' ' 1037 %WHILE 'A'<=I<='Z' %CYCLE 1038 S=S<<8!I; Q=Q+1; I=CC(Q) 1039 %REPEAT 1040 ->FAIL %UNLESS I='_' %AND S#M' ' 1041 Q=Q+1; ->SUCC 1042 BIP(1023): ! PRIMARY FORMAT MNEMOINC 1043 %CYCLE I=7,1,126 1044 ->PFND %IF OPC(I)=S 1045 %REPEAT 1046 ->FAIL 1047 PFND: 1048 ->FAIL %IF 8<=I>>3<=11 %AND I&7<=3 1049 A(R)=2*I; ->UPR 1050 BIP(1024): ! SECONDARY FORMAT MNEMONIC 1051 %CYCLE I=64,8,88 1052 %CYCLE J=0,1,3 1053 ->SFND %IF OPC(I+J)=S 1054 %REPEAT 1055 %REPEAT 1056 ->FAIL 1057 SFND: A(R)=2*(I+J); ->UPR 1058 BIP(1025): ! TERTIARY FORMAT MNEMONIC 1059 %CYCLE I=3,-1,1 1060 %IF OPC(I)=S %THEN A(R)=2*I %AND ->UPR 1061 %REPEAT; ->FAIL 1062 BIP(1026): ! P(OP)=+,-,&,****,**,*,!!,!, 1063 ! //,/,>>,<<,.,\\,\; 1064 I=CC(Q); ! OBTAIN CURRENT CHARACTER 1065 ->FAIL %UNLESS 32>((I-32)&31)&16_4237000A#0 1066 Q=Q+1 1067 %IF I='+' %THEN A(R)=1 %AND ->UPR 1068 %IF I='-' %THEN A(R)=2 %AND ->UPR 1069 %IF I='&' %THEN A(R)=3 %AND ->UPR 1070 J=CC(Q) 1071 %IF I='*' %THEN %START 1072 %IF J#I %THEN A(R)=6 %AND ->UPR 1073 %IF CC(Q+1)=I=CC(Q+2) %THEN A(R)=4 %AND Q=Q+3 %AND ->UPR 1074 A(R)=5; Q=Q+1; ->UPR 1075 %FINISH 1076 %IF I='/' %THEN %START 1077 %IF J#I %THEN A(R)=10 %AND ->UPR 1078 A(R)=9; Q=Q+1; ->UPR 1079 %FINISH 1080 %IF I='!' %THEN %START 1081 %IF J#I %THEN A(R)=8 %AND ->UPR 1082 A(R)=7; Q=Q+1; ->UPR 1083 %FINISH 1084 %IF I='.' %THEN A(R)=13 %AND ->UPR 1085 %IF I=J='<' %THEN A(R)=12 %AND Q=Q+1 %AND ->UPR 1086 %IF I=J='>' %THEN A(R)=11 %AND Q=Q+1 %AND ->UPR 1087 %IF I='\' %THEN %START 1088 %IF J#I %THEN A(R)=15 %AND ->UPR 1089 Q=Q+1; A(R)=14; ->UPR 1090 %FINISH 1091 ->FAIL 1092 BIP(1027): ! PHRASE CHECK UI 1093 I=CC(Q); ! OBTAIN CURRENT CHARACTER 1094 ->SUCC %IF TRTAB(I)=2 %OR I='-' 1095 ->SUCC %IF 16_80000000>>(I&31)&16_14043000#0 1096 ->FAIL 1097 BIP(1028): ! P(+')=+,-,\,0 1098 I=CC(Q); ! OBTAIN CURRENT CHARACTER 1099 %IF I='\' %OR I=16_7E %THEN A(R)=3 %AND Q=Q+1 %AND ->UPR 1100 %IF I='-' %THEN A(R)=2 %AND Q=Q+1 %AND ->UPR 1101 %IF I='+' %THEN A(R)=1 %AND Q=Q+1 %AND ->UPR 1102 A(R)=4; ->UPR 1103 BIP(1029): ! PHRASE NOTE CYCLE 1104 TOAR4(R,0) 1105 PUSH(SFS(LEVEL),2,R,LINE) 1106 R=R+4 1107 ->SUCC 1108 BIP(1030): ! P(,')=',',0 1109 ! 1110 ! THIS IS VERY AWKWARD AS IT MEANS IT IS VERY TO HARD TO FIND 1111 ! THE END OF A PARAMETER LIST WITHOUT CHURNING. BY MAKING THIS A BIP 1112 ! WE CAN PEEP AHEAD FOR ')' AND FAIL HERE. 1113 ! 1114 I=CC(Q); ! OBTAIN CURRENT CHARACTER 1115 %IF I=')' %THEN ->FAIL 1116 %IF I=',' %THEN Q=Q+1 1117 ->SUCC 1118 BIP(1031): ! PHRASE CHECKTYPE IE ENSURE 1119 ! FIRST LETTER IS(B,H,I,L,R,S) & 1120 ! 3RD LETTER IS (A,L,N,R,T) 1121 I=CC(Q); ! OBTAIN CURRENT CHARACTER 1122 ->FAIL %UNLESS I>128 %AND 16_80000000>>(I&31)&16_20C83000#0 %AND 16_80000000>>(CC(Q+2)&31)&16_400A2800#0 1123 ->SUCC 1124 BIP(1032): ! PHRASE COMP1 1125 BIP(1037): ! PHRASE COMP2(IS 2ND HALF OF DSIDED) 1126 I=CC(Q); ! OBTAIN CURRENT CHARACTER 1127 ->FAIL %UNLESS 32>(I&31)&16_1004000E#0 1128 ! '='=1,'>='=2,'>'=3 1129 ! '#' OR '\='=4,'<='=5,'<'=6 1130 ! 7UNUSED,'->'=8,'=='=9 1131 ! '##' OR '\==' =10 1132 %IF I='=' %THEN %START 1133 %IF CC(Q+1)=I %THEN J=9 %AND ->JOIN1 1134 J=1; ->JOIN 1135 %FINISH 1136 %IF I='#' %THEN %START 1137 %IF CC(Q+1)=I %THEN J=10 %AND ->JOIN1 1138 J=4; ->JOIN 1139 %FINISH 1140 %IF I='\' %AND CC(Q+1)='=' %THEN %START 1141 Q=Q+1 1142 %IF CC(Q+1)='=' %THEN J=10 %AND ->JOIN1 1143 J=4; ->JOIN 1144 %FINISH 1145 %IF I='>' %THEN %START 1146 %IF CC(Q+1)='=' %THEN J=2 %AND ->JOIN1 1147 J=3; ->JOIN 1148 %FINISH 1149 %IF I='<' %THEN %START 1150 %IF CC(Q+1)='=' %THEN J=5 %AND ->JOIN1 1151 J=6; ->JOIN 1152 %FINISH 1153 %IF I='-' %AND CC(Q+1)='>' %THEN J=8 %AND ->JOIN1 1154 ->FAIL 1155 JOIN1:Q=Q+1 1156 JOIN: Q=Q+1 1157 A(R)=J 1158 %IF ITEM=1032 %THEN SAVECOMP=J %AND ->UPR 1159 ! SAVE J TO CHECK DSIDED 1160 %IF SAVECOMP>6 %OR J>6 %THEN Q=Q-1 %AND ->FAIL;! ILLEGAL DSIDED 1161 ->UPR; ! NB OWNS WONT WORK IF 1162 ! COND EXPRS ALLOWED AS THE 1163 ! CAN BE NESTED! 1164 BIP(1033): ! P(ASSOP)- ==,=,<-,-> 1165 I=CC(Q); ! OBTAIN CURRENT CHARACTER 1166 %IF I='=' %THEN %START 1167 %IF CC(Q+1)='=' %THEN A(R)=1 %AND Q=Q+2 %AND ->UPR 1168 A(R)=2; Q=Q+1; ->UPR 1169 %FINISH 1170 %IF I='<' %AND CC(Q+1)='-' %THEN A(R)=3 %AND Q=Q+2 %AND ->UPR 1171 %IF I='-' %AND CC(Q+1)='>' %THEN A(R)=4 %AND Q=Q+2 %AND ->UPR 1172 ->FAIL 1173 BIP(1034): ! NOTE START 1174 TOAR4(R,0); ! HOLE FOR FORWARD PTR 1175 PUSH(SFS(LEVEL),1,R,LINE) 1176 R=R+4 1177 ->SUCC 1178 BIP(1035): ! NOTE FINISH 1179 %IF SFS(LEVEL)=0 %THEN FAULT2(51,0,0) %AND ->SUCC 1180 POP(SFS(LEVEL),I,J,K) 1181 %IF I=2 %THEN FAULT2(59,K,0) 1182 TOAR4(J,STARSTART) 1183 ->SUCC 1184 BIP(1036): ! NOTE REPEAT 1185 %IF SFS(LEVEL)=0 %THEN FAULT2(1,0,0) %AND ->SUCC 1186 POP(SFS(LEVEL),I,J,K) 1187 %IF I=1 %THEN FAULT2(52,K,0); ! START INSTEAD OF CYCLE 1188 TOAR4(J,STARSTART) 1189 ->SUCC 1190 BIP(1038): ! INCLUDE "FILE" 1191 ->FAIL %IF VMEB=YES 1192 I=CC(Q) 1193 ->FAIL %UNLESS I=NL %OR I=';' 1194 Q=Q+1 %IF I=';' 1195 ->FAIL %UNLESS CTYPE=5 1196 PUSH(IHEAD,FILEADDR,FILEPTR,FILEEND) 1197 CONSOURCE(STRING(ADDR(A(S))),FILEADDR);! DEPARTS IF FAILS 1198 FILEPTR=FILEADDR+INTEGER(FILEADDR+4) 1199 FILEEND=FILEADDR+INTEGER(FILEADDR) 1200 ->SUCC 1201 %END; !OF ROUTINE 'COMPARE' 1202 %ROUTINE PNAME(%INTEGER MODE) 1203 !*********************************************************************** 1204 !* MODE=0 FOR OLD NAME(ALREADY IN DICT), MODE=1 FOR NEW NAME * 1205 !*********************************************************************** 1206 %CONSTINTEGERARRAY HASH(0:7)=71,47,97,79,29,37,53,59; 1207 %INTEGER JJ, KK, LL, FQ, FS, T, S, I 1208 %LONGINTEGER DRDES,ACCDES 1209 HIT=0; FQ=Q; FS=CC(Q) 1210 %RETURN %UNLESS TRTAB(FS)=2 %AND M'"'#CC(Q+1)#M'''' 1211 ! 1ST CHAR MUST BE LETTER 1212 T=1 1213 LETT(NEXT+1)=FS; JJ=71*FS 1214 ! %IF USE IMP=YES %THEN %START 1215 %CYCLE 1216 Q=Q+1 1217 I=CC(Q) 1218 %EXIT %IF TRTAB(I)=0 1219 JJ=JJ+HASH(T) %IF T<=7 1220 T=T+1 1221 LETT(NEXT+T)=I 1222 %REPEAT 1223 ! %FINISH %ELSE %START 1224 !CYC: 1225 ! *LB_Q 1226 ! *ADB_1 1227 ! *STB_Q 1228 ! *LB_(CC+%B) 1229 ! *LSS_(TRTAB+%B) 1230 ! *JAT_4, 1231 ! *STB_I 1232 ! *LSS_%B; ! I TO ACC 1233 ! *LB_T 1234 ! *CPB_7 1235 ! *JCC_2, 1236 ! *IMY_(HASH+%B) 1237 ! *IAD_JJ 1238 ! *ST_JJ 1239 !SKIP: 1240 ! *ADB_1 1241 ! *STB_T 1242 ! *LSS_I 1243 ! *ADB_NEXT 1244 ! *ST_(LETT+%B) 1245 ! *J_ 1246 !EXIT: 1247 ! %FINISH 1248 LETT(NEXT)=T; ! INSERT LENGTH 1249 S=T+1 1250 FAULT(103,0) %IF NEXT+S>DSIZE;!DICTIONARY OVERFLOW 1251 JJ=(JJ+113*T)&NNAMES 1252 ! %IF USE IMP=YES %THEN %START 1253 %CYCLE KK=JJ, 1, NNAMES 1254 LL=WORD(KK) 1255 ->HOLE %IF LL=0; ! NAME NOT KNOWN 1256 ->FND %IF STRING(ADDR(LETT(NEXT)))=STRING(ADDR(LETT(LL))) 1257 %REPEAT 1258 %CYCLE KK=0,1,JJ 1259 LL=WORD(KK) 1260 ->HOLE %IF LL=0; ! NAME NOT KNOWN 1261 ->FND %IF STRING(ADDR(LETT(NEXT)))=STRING(ADDR(LETT(LL))) 1262 %REPEAT 1263 ! %FINISH %ELSE %START 1264 ! *LDTB_16_18000000 1265 ! *LDB_S 1266 ! *LDA_LETT+4 1267 ! *STD_DRDES 1268 ! *INCA_NEXT 1269 ! *STD_ACCDES 1270 ! *LB_JJ 1271 !CYC1: 1272 ! *STB_KK 1273 ! *LB_(WORD+%B) 1274 ! *JAT_12, 1275 ! *LSD_ACCDES 1276 ! *LD_DRDES 1277 ! *INCA_%B 1278 ! *CPS_%L=%DR 1279 ! *JCC_8, 1280 ! *LB_KK 1281 ! *CPIB_NNAMES 1282 ! *JCC_7, 1283 ! *LB_0 1284 !CYC2: 1285 ! *STB_KK 1286 ! *LB_(WORD+%B) 1287 ! *JAT_12, 1288 ! *LSD_ACCDES 1289 ! *LD_DRDES 1290 ! *INCA_%B 1291 ! *CPS_%L=%DR 1292 ! *JCC_8, 1293 ! *LB_KK 1294 ! *CPIB_JJ 1295 ! *JCC_7, 1296 ! %FINISH 1297 FAULT(104, 0); ! TOO MANY NAMES 1298 HOLE: %IF MODE=0 %THEN Q=FQ %AND %RETURN 1299 WORD(KK)=NEXT; NEXT=NEXT+S 1300 FND: LASTAT=FQ; HIT=1; LASTNAME=KK 1301 A(R+1)<-LASTNAME 1302 A(R)=LASTNAME>>8; R=R+2 1303 LASTEND=Q 1304 %END ?ACCDES unused ?DRDES unused 1305 1306 1307 %ROUTINE CONST(%INTEGER MODE) 1308 !*********************************************************************** 1309 !* SYNTAX CHECK AND EVALUATE ALL THE FORMS OF IMP CONSTANT * 1310 !* MODE=0 FOR INTEGER CONSTANTS #0 FOR ANY SORT OF CONSTANT * 1311 !*********************************************************************** 1312 %INTEGER Z, DOTSEEN, EBCDIC, FS, CPREC, RR, S, T, SS 1313 {%LONG}%LONGREAL X,CVALUE,DUMMY 1314 %CONST{%LONG}%LONGREAL TEN=10.0 {R'41A00000000000000000000000000000' 1315 CPREC=5; RR=R; R=R+1 1316 DOTSEEN=0; HIT=0 1317 CVALUE=0; DUMMY=0; FS=CC(Q) 1318 S=0; ->N %IF M'0'<=FS<=M'9' 1319 ->DOT %IF FS='.' %AND MODE=0 %AND '0'<=CC(Q+1)<='9' 1320 ! 1 DIDT MIN 1321 CTYPE=1; EBCDIC=0 1322 ->QUOTE %IF FS=M'''' 1323 ->STR2 %IF FS=34 1324 ->NOTQUOTE %UNLESS CC(Q+1)=M''''; Q=Q+2 1325 ->HEX %IF FS='X' 1326 ->MULT %IF FS='M' 1327 ->BIN %IF FS=M'B' 1328 ->RHEX %IF FS='R' %AND MODE=0 1329 ->OCT %IF FS='K' 1330 %IF FS='C' %THEN EBCDIC=1 %AND ->MULT 1331 %IF FS='D' %AND MODE=0 %THEN %START 1332 CPREC=7 1333 %IF M'0'<=CC(Q)<=M'9' %THEN ->N 1334 %IF CC(Q)='.' %THEN ->DOT 1335 %FINISH 1336 Q=Q-2; %RETURN 1337 QUOTE: ! SINGLE CH BETWEEN QUOTES 1338 %IF CC(Q+2)=M'''' %THEN %START 1339 S=CC(Q+1) 1340 Q=Q+3 1341 %IF S#M'''' %THEN ->IEND 1342 %IF CC(Q)=M'''' %THEN Q=Q+1 %AND ->IEND 1343 %FINISH 1344 %RETURN; ! NOT VALID 1345 NOTQUOTE: ! CHECK FOR E"...." 1346 %RETURN %UNLESS FS='E' %AND CC(Q+1)=M'"' 1347 EBCDIC=1; Q=Q+1 1348 STR2: ! DOUBLE QUOTED STRING 1349 A(RR)=16_35; TEXTTEXT(EBCDIC) 1350 CTYPE=5; %RETURN 1351 HEX: T=0; ! HEX CONSTANTS 1352 %CYCLE 1353 I=CC(Q); Q=Q+1 1354 %EXIT %IF I=M'''' 1355 T=T+1 1356 %RETURN %UNLESS ('0'<=I<='9' %OR 'A'<=I<='F') %AND T<17 1357 %IF T=9 %THEN SS=S %AND S=0 1358 S=S<<4+I&15+9*I>>6 1359 %REPEAT 1360 %IF T>8 %START 1361 Z=4*(T-8) 1362 S=S!(SS<>(32-Z); CPREC=6 1364 %FINISH 1365 IEND: %IF CPREC=6 %THEN TOAR4(R,SS) %AND R=R+4 1366 %IF CPREC=5 %AND 0<=S<=16_7FFF %START 1367 CPREC=4; TOAR2(R,S); R=R+2 1368 %FINISH %ELSE TOAR4(R,S) %AND R=R+4 1369 HIT=1 %UNLESS MODE#0 %AND CPREC=6 1370 A(RR)=CPREC<<4!CTYPE 1371 %RETURN 1372 RHEX: ! REAL HEX CONSTANTS 1373 T=0 1374 %CYCLE 1375 I=CC(Q); Q=Q+1 1376 %IF T&7=0 %AND T#0 %START 1377 TOAR4(R,S); R=R+4; S=0 1378 %FINISH 1379 %EXIT %IF I=M''''; T=T+1 1380 %RETURN %UNLESS '0'<=I<='9' %OR 'A'<=I<='F' 1381 S=S<<4+I&15+9*I>>6 1382 %REPEAT 1383 %RETURN %UNLESS T=8 %OR T=16 %OR T=32 1384 %IF T=32 %THEN CPREC=7 %ELSE CPREC=4+T//8 1385 A(RR)=CPREC<<4!2 1386 HIT=1; %RETURN 1387 OCT: ! OCTAL CONSTANTS 1388 T=0 1389 %CYCLE 1390 I=CC(Q); Q=Q+1; T=T+1 1391 %EXIT %IF I=M'''' 1392 %RETURN %UNLESS '0'<=I<='7' %AND T<12 1393 S=S<<3!(I&7) 1394 %REPEAT 1395 ->IEND 1396 MULT: T=0; ! MULTIPLE CONSTANTS 1397 %CYCLE 1398 I=CC(Q); Q=Q+1; T=T+1 1399 %IF I=M'''' %THEN %START 1400 %IF CC(Q)#M'''' %THEN %EXIT %ELSE Q=Q+1 1401 %FINISH 1402 %RETURN %IF T>=5 1403 %IF EBCDIC#0 %THEN I=ITOETAB(I) 1404 S=S<<8!I 1405 %REPEAT 1406 ->IEND 1407 BIN: T=0; ! BINARY CONST 1408 %CYCLE 1409 I=CC(Q); Q=Q+1; T=T+1 1410 %EXIT %IF I=M'''' 1411 %RETURN %UNLESS '0'<=I<='1' %AND T<33 1412 S=S<<1!I&1 1413 %REPEAT 1414 ->IEND 1415 N: ! CONSTANT STARTS WITH DIGIT 1416 I=CC(Q) 1417 {%UNTIL IM'9'} %CYCLE 1418 CVALUE=TEN*CVALUE+(I&15) 1419 Q=Q+1; I=CC(Q); ! ONTO NEXT CHAR 1420 %REPEAT %UNTIL IM'9' 1421 ->ALPHA %UNLESS MODE=0 %AND I='.' 1422 DOT: Q=Q+1; X=TEN; I=CC(Q) 1423 DOTSEEN=1; ! CONSTANT HAS DECIMAL POINT 1424 %WHILE M'0'<=I<=M'9' %CYCLE 1425 CVALUE=CVALUE+(I&15)/X 1426 X=TEN*X; Q=Q+1; I=CC(Q) 1427 %REPEAT 1428 ALPHA: ! TEST FOR EXPONENT 1429 %IF MODE=0 %AND CC(Q)='@' %THEN %START 1430 Q=Q+1; X=CVALUE 1431 Z=1; I=CC(Q) 1432 %IF I='-' %THEN Z=-1 1433 %IF I='+' %OR I='-' %THEN Q=Q+1 1434 CONST(2) 1435 %IF HIT=0 %THEN %RETURN 1436 HIT=0 1437 R=RR+1 1438 %IF A(R)>>4#4 %THEN %RETURN; ! EXPONENT MUST BE HALFINTEGER 1439 S=FROM AR2(R+1)*Z 1440 %IF S=-99 %THEN CVALUE=0 %ELSE %START 1441 ! %IF USE IMP=NO %THEN %START 1442 ! *MPSR_16_8080; ! MASK OUT REAL OVERFLOW 1443 ! %FINISH 1444 %WHILE S>0 %CYCLE 1445 S=S-1 1446 CVALUE=CVALUE*TEN 1447 ! %IF USE IMP=NO %THEN %START 1448 ! *JAT_15, 1449 ! %FINISH 1450 %REPEAT 1451 %WHILE S<0 %AND CVALUE#0 %CYCLE 1452 S=S+1 1453 CVALUE=CVALUE/TEN 1454 %REPEAT 1455 %FINISH 1456 %FINISH 1457 ! SEE IF IT IS INTEGER 1458 %IF FS='D' %THEN %START 1459 I=CC(Q) 1460 %IF I='''' %THEN Q=Q+1 %ELSE %RETURN 1461 DOTSEEN=1; ! ENSURE NOT TAKEN AS INTEGER 1462 %FINISH 1463 %IF DOTSEEN=1 %OR CVALUE>IMAX %OR FRACPT(CVALUE)#0 %THEN CTYPE=2 %ELSE CTYPE=1 %AND S=INT(CVALUE) 1464 %IF CTYPE=1 %THEN ->IEND 1465 %IF CPREC=5 %THEN CPREC=6; ! NO 32 BIT REAL CONSTS 1466 %IF CPREC=6 %THEN %START 1467 ! %IF USE IMP=NO %THEN %START; ! SOFTWARE ROUND IN MC CODE ONLY 1468 ! *LSD_CVALUE 1469 ! *AND_16_FF00000000000000 1470 ! *SLSD_CVALUE+8 1471 ! *AND_16_0080000000000000 1472 ! *LUH_%TOS 1473 ! *RAD_CVALUE 1474 ! *ST_CVALUE 1475 ! %FINISH 1476 %FINISH 1477 TOAR8(R,CVALUE); R=R+8 1478 %IF CPREC=7 %THEN TOAR8(R,LONGREAL(ADDR(CVALUE)+8)) %AND R=R+8 1479 A(RR)=CPREC<<4+CTYPE 1480 HIT=1 1481 FAIL: %END ?FAIL unused 1482 %ROUTINE TEXTTEXT(%INTEGER EBCDIC) 1483 !*********************************************************************** 1484 !* PROCESSES TEXT BETWEEN DOUBLE QUOTES AND STORES IN ISO OR EBCDIC * 1485 !*********************************************************************** 1486 %INTEGER J, II 1487 %CONSTINTEGER QU='"' 1488 I=CC(Q) 1489 S=R+4; R=R+5; HIT=0 1490 %RETURN %UNLESS I=QU; ! FAIL UNLESS INITIAL QUOTE 1491 Q=Q+1 1492 %CYCLE 1493 I=CC(Q) 1494 %IF EBCDIC#0 %THEN II=ITOETAB(I) %ELSE II=I 1495 A(R)=II; R=R+1 1496 %IF I=QU %THEN %START 1497 Q=Q+1 1498 %IF CC(Q)#QU %THEN %EXIT 1499 %FINISH 1500 %IF I=10 %THEN READLINE(1,QU) %ELSE Q=Q+1 1501 FAULT(106,0) %IF R-S>256 1502 %REPEAT 1503 R=R-1; J=R-S-1 1504 A(S)=J; HIT=1 1505 %END 1506 BEND:%END; ! OF BLOCK CONTAINING PASS 1 1507 %IF LEVEL>1 %THEN FAULT(15, 0) 1508 I=0 1509 NEWLINE 1510 %IF FAULTY=0 %THEN %START 1511 WRITE(LINE, 5) 1512 PRINT STRING(" LINES ANALYSED IN") 1513 WRITE(INT(1000*(CPUTIME-CTIME)),5) 1514 PRINT STRING(" MSECS - SIZE=") 1515 WRITE(P1SIZE, 5) 1516 %IF LINE>90 %AND LIST#0 %THEN NEWPAGE %ELSE NEWLINE 1517 %FINISH %ELSE %START 1518 PRINTSTRING("CODE GENERATION NOT ATTEMPTED 1519+ ") 1520 COMREG(24)=8 1521 COMREG(47)=FAULTY 1522 %STOP 1523 %FINISH 1524 %BEGIN 1525 !*********************************************************************** 1526 !* SECOND OR CODE GENERATING PASS * 1527 !*********************************************************************** 1528 %INTEGERARRAY REGISTER, GRUSE, GRAT, GRINF1, GRINF2, OLINK(0:7) 1529 %BYTEINTEGERARRAY CODE, GLABUF(0:268) 1530 %INTEGERARRAY PLABS, DESADS, PLINK(0:31) 1531 %INTEGERARRAY SET, STACKBASE, RAL, FLAG, L, M, NMDECS, ONWORD, ONINF,{%C 1532+ JUMP, LABEL, JROUND, DIAGINF, DISPLAY, {%C 1533+ AUXSBASE, NAMES (0:MAXLEVELS) 1534 %INTEGERARRAY AVL WSP(0:4,0:MAXLEVELS) 1535 %recordformat rcf(%integerarray val(0:12* 2047 {NNAMES})) { unfortunately we can't have a dynamically-sized array in a record. Largest possible is 2047. 1536 %record (rcf) %name CTABLE 1537 {%INTEGERARRAYFORMAT CF(0:12*NNAMES) - Imp77 doesn't support ARRAY() mapping. 1538 {%INTEGERARRAY(1)%NAME CTABLE 1539 %ROUTINESPEC CNOP(%INTEGER I, J) 1540 %ROUTINESPEC PCLOD(%INTEGER FROM, TO) 1541 %ROUTINESPEC PCONST(%INTEGER X) 1542 %ROUTINESPEC PSF1(%INTEGER OPCODE,K,N) 1543 %ROUTINESPEC PF1(%INTEGER OPCODE,KP,KPP,N) 1544 %ROUTINESPEC PSORLF1(%INTEGER OPCODE,KP,KPP,N) 1545 %ROUTINESPEC PF2(%INTEGER OPCODE,H,Q,N,MASK,FILLER) 1546 %ROUTINESPEC PF3(%INTEGER OPCODE,MASK,KPPP,N) 1547 %ROUTINESPEC NOTE CREF(%INTEGER CA,VAL) 1548 %INTEGERFNSPEC PARAM DES(%INTEGER PREC) 1549 %INTEGERFNSPEC MAPDES(%INTEGER PREC) 1550 %INTEGERFNSPEC SPECIAL CONSTS(%INTEGER WHICH) 1551 %ROUTINESPEC STORE CONST(%INTEGERNAME D,%INTEGER L,AD) 1552 %ROUTINESPEC DUMP CONSTS 1553 %ROUTINESPEC PLANT(%INTEGER VALUE) 1554 %ROUTINESPEC PLUG(%INTEGER I, J, K, BYTES) 1555 %ROUTINESPEC CODEOUT 1556 %ROUTINESPEC PROLOGUE 1557 %ROUTINESPEC EPILOGUE 1558 %ROUTINESPEC COMPILE A STMNT 1559 %ROUTINESPEC CSS(%INTEGER P) 1560 %ROUTINESPEC LOAD DATA 1561 %ROUTINESPEC ABORT 1562 !*DELSTART 1563 %ROUTINESPEC PRINT USE 1564 !*DELEND 1565 %CYCLE I=0,1,7 ?Non-local 1566 REGISTER(I)=0; GRUSE(I)=0; GRINF1(I)=0; GRAT(I)=0 1567 GRINF2(I)=0 1568 %REPEAT 1569 %CYCLE I=0, 1, MAXLEVELS ?Non-local 1570 SET(I)=0; STACKBASE(I)=0; RAL(I)=0 1571 JUMP(I)=0; JROUND(I)=0 1572 LABEL(I)=0; FLAG(I)=0 1573 L(I)=0; M(I)=0; DIAGINF(I)=0 1574 DISPLAY(I)=0; ONWORD(I)=0; ONINF(I)=0 1575 NAMES(I)=-1 1576 %CYCLE J=0,1,4 ?Non-local 1577 AVL WSP(J,I)=0 1578 %REPEAT 1579 %REPEAT 1580 {CTABLE==ARRAY(ADDR(ASLIST(1)),CF) 1581 CTABLE==RECORD(ADDR(ASLIST(1))) 1582 CONST HOLE=0 1583 PROLOGUE 1584 LINE=0 1585 NEXTP=1; LEVEL=1; STMTS=0 1586 RLEVEL=0; RBASE=0 1587 %WHILE A(NEXTP+3)!A(NEXTP+4)#0 %CYCLE 1588 COMPILE A STMNT 1589 %REPEAT 1590 LINE=99999 1591 EPILOGUE 1592 LOAD DATA 1593 %STOP 1594 %ROUTINE COMPILE A STMNT 1595 %INTEGER I 1596 !*DELSTART 1597 %IF DCOMP#0 %AND CA>CABUF %THEN CODEOUT %AND PRINTUSE 1598 !*DELEND 1599 I=NEXTP 1600 NEXTP=NEXTP+A(NEXTP)<<16+A(NEXTP+1)<<8+A(NEXTP+2) 1601 LINE=A(I+3)<<8+A(I+4) 1602 STMTS=STMTS+1 1603 CSS(I+5) 1604 ! CHECK ASL %IF LINE&7=0 1605 %END 1606 %ROUTINE LOAD DATA 1607 !*********************************************************************** 1608 !* PASS INFORMATION TO LPUT TO ENABLE IT TO GENERATE THE * 1609 !* LOADER DATA AND COMPLETE THE PROGRAM FILE. * 1610 !*********************************************************************** 1611 %INTEGER LANGFLAG,PARMS 1612 GLACA=(GLACA+7)&(-8) 1613 USTPTR=(USTPTR+7)&(-8) 1614 CODE OUT 1615 CNOP(0, 8) 1616 DUMP CONSTS 1617 %IF PARMTRACE=0 %THEN LANGFLAG=6 %ELSE LANGFLAG=1 1618 LANGFLAG=LANGFLAG<<24 1619 PARMS=(PARMDIAG<<1!PARMLINE)<<1!PARMTRACE 1620 FIXED GLA(4)=LANGFLAG!1<<16!(CPRMODE&1)<<8!PARMS;! LANG RLSE & MAINPROG 1621 I=GLACA-GLACABUF 1622 %IF INHCODE=0 %THEN %START 1623 LPUT(2, I, GLACABUF, ADDR(GLABUF(0))) %UNLESS I=0 1624 ! BACK OF GLAP 1625 LPUT(2, FIXEDGLALEN, 0, ADDR(FIXED GLA(0)));! FRONT OF GLAP 1626 LPUT(19,2,8,5); ! RELOCATE GLA ST ADDRESS 1627 LPUT(19,2,12,4); ! RELOCATE CODE ST ADDRESS 1628 I=16_E2E2E2E2 1629 LPUT(4, 4, SSTL, ADDR(I)) 1630 ! 1631 %FINISH 1632 SSTL=(SSTL+11)&(-8) 1633 PRINTSTRING(" 1634+ CODE") 1635 WRITE(CA, 6); PRINTSTRING(" BYTES GLAP") 1636 WRITE(GLACA, 3); PRINTSTRING("+") 1637 WRITE(USTPTR, 1); PRINTSTRING(" BYTES DIAG TABLES") 1638 WRITE(SSTL, 3); PRINTSTRING(" BYTES 1639+ TOTAL") 1640 REGISTER(0)=CA; REGISTER(1)=GLACA 1641 REGISTER(2)=0 1642 REGISTER(3)=SSTL 1643 REGISTER(4)=USTPTR 1644 K=CA+GLACA+SSTL+USTPTR; REGISTER(5)=K 1645 WRITE(K, 5); PRINTSTRING(" BYTES") 1646 NEWLINE; PRINT CH(13); ! MARKER FOR COMP TO PRINT 1647 !SUMMARY 1648 %IF FAULTY=0 %THEN %START 1649 WRITE(STMTS, 7); PRINTSTRING(" STATEMENTS COMPILED IN") 1650 WRITE(INT(1000*(CPUTIME-CTIME)),5) 1651 PRINTSTRING(" MSECS") 1652 COMREG(47)=STMTS; ! NO OF STMTS FOR COMPER 1653 %FINISH %ELSE %START 1654 PRINTSTRING("PROGRAM CONTAINS"); WRITE(FAULTY, 2) 1655 PRINTSTRING(" FAULT"); PRINTSYMBOL('S') %IF FAULTY>1 1656 COMREG(47)=FAULTY; ! NO OF FAULTS FOR COMPER 1657 %FINISH 1658 NEWLINES(2) 1659 NEWLINE 1660 I=0; I=8 %IF FAULTY#0 1661 COMREG(24)=I 1662 %IF INHCODE=0 %THEN LPUT(7, 24, 0, ADDR(REGISTER(0))) 1663 ! SUMMARY INFO..REGISTER AS BUF 1664 ! PPROFILE 1665 %STOP 1666 %END 1667 ! 1668 !*********************************************************************** 1669 !* IMP CODE PLANTING ROUTINES * 1670 !* CODE AND GLAP ARE PUT INTO THE BUFFERS 'CODE,GLABUF(0:268)' * 1671 !* BY A NUMBER OF TRIVIAL ROUTINES.LPUT IS CALLED TO ADD THE * 1672 !* BUFFER TO THE OUTPUT FILE. THE BUFFERS ARE BASICALLY 0:255 * 1673 !* WITH A 12-BYTE MARGIN TO MINIMISE THE NUMBER OF TESTS FOR * 1674 !* THE BUFFER FULL CONDITION * 1675 !* * 1676 !* PPCURR(GLACURR) IS THE BUFFER POINTER * 1677 !* CA(GLACA) IS THE RELATIVE ADDRESS OF THE NEXT BYTE * 1678 !* CABUF(GLACABUF) IS CA(GLACA) FOR START OF BUFFER * 1679 !*********************************************************************** 1680 !*DELSTART 1681 %ROUTINE RECODE(%INTEGER S,F,AD) 1682 %IF S#F %START 1683 PRINTSTRING(" 1684+ CODE FOR LINE"); WRITE(LINE,5) 1685 NCODE(S,F,AD) 1686 %FINISH 1687 %END 1688 !*DELEND 1689 %ROUTINE CODEOUT 1690 %IF PPCURR>0 %THEN %START 1691 !*DELSTART 1692 RECODE(ADDR(CODE(0)), ADDR(CODE(PPCURR)), CABUF) %IF DCOMP#0 1693 !*DELEND 1694 LPUT(1, PPCURR, CABUF, ADDR(CODE(0))) %IF INHCODE=0 1695 PPCURR=0; CABUF=CA 1696 %FINISH 1697 %END 1698 %ROUTINE PLANT(%INTEGER HALFWORD) 1699 !*********************************************************************** 1700 !* ADD A HALF WORD OF BINARY TO THE BUFFER * 1701 !*********************************************************************** 1702 ! %IF USE IMP=YES %THEN %START 1703 CODE(PPCURR)<-HALFWORD>>8 1704 CODE(PPCURR+1)<-HALFWORD 1705 PPCURR=PPCURR+2 1706 ! %FINISH %ELSE %START 1707 ! *LDA_CODE+4 1708 ! *LDTB_16_58000002 1709 ! *LB_PPCURR 1710 ! *LSS_HALFWORD 1711 ! *ST_(%DR+%B) 1712 ! *ADB_2 1713 ! *STB_PPCURR 1714 ! %FINISH 1715 CA=CA+2 1716 CODEOUT %IF PPCURR>=256 1717 %END 1718 %ROUTINE PCONST(%INTEGER WORD) 1719 !*********************************************************************** 1720 !* ADD A WORD OF BINARY TO THE BUFFER * 1721 !*********************************************************************** 1722 %INTEGER I 1723 ! %IF USE IMP=YES %THEN %START 1724 %CYCLE I=24,-8,0 1725 CODE(PPCURR)=WORD>>I&255 1726 PPCURR=PPCURR+1 1727 %REPEAT 1728 ! %FINISH %ELSE %START 1729 ! *LDA_CODE+4 1730 ! *LDTB_16_58000004 1731 ! *LSS_WORD 1732 ! *LB_PPCURR 1733 ! *ST_(%DR+%B) 1734 ! *ADB_4 1735 ! *STB_PPCURR 1736 ! %FINISH 1737 CA=CA+4 1738 CODE OUT %IF PPCURR>=256 1739 %END 1740 %ROUTINE PSF1(%INTEGER OPCODE,K,N) 1741 !*********************************************************************** 1742 !* PLANT THE HALFWORD FORMS OF PRIMARY FORMAT NR INSTRNS * 1743 !* IF N IS TOO LARGE FOR THE SHORT FORM PF1 IS CALLED TO PLANT * 1744 !* THE CORRESPONDING LONG FORM * 1745 !*********************************************************************** 1746 %INTEGER KPP 1747 ! ABORT %UNLESS 0<=K<=2 %AND OPCODE&1=0 1748 %IF (K=0 %AND -64<=N<=63) %OR (K#0 %AND 0<=N<=511) %START 1749 %IF K#0 %THEN N=N//4 1750 ! %IF USE IMP=YES %THEN %START 1751 CODE(PPCURR)=OPCODE!K>>1 1752 CODE(PPCURR+1)=(K&1)<<7!N&127 1753 PPCURR=PPCURR+2 1754 ! %FINISH %ELSE %START 1755 ! *LSS_OPCODE 1756 ! *USH_1 1757 ! *OR_K 1758 ! *USH_7 1759 ! *SLSS_N 1760 ! *AND_127 1761 ! *LB_PPCURR 1762 ! *OR_%TOS 1763 ! *LDA_CODE+4 1764 ! *LDTB_16_58000002 1765 ! *ST_(%DR+%B) 1766 ! *ADB_2 1767 ! *STB_PPCURR 1768 ! %FINISH 1769 CA=CA+2 1770 CODEOUT %IF PPCURR>=256 1771 %FINISH %ELSE %START 1772 %IF K=0 %THEN KPP=0 %ELSE KPP=2 1773 PF1(OPCODE,K>>1<<1,KPP,N) 1774 %FINISH 1775 %END 1776 %ROUTINE PF1(%INTEGER OPCODE,KP,KPP,N) 1777 !*********************************************************************** 1778 !* PLANT THE NORMAL FORMS OF PRIMARY FORMAT INSTRNS(IE THOSE * 1779 !* WHICH DO NOT DEPEND ON THE SIZE OF N) * 1780 !*********************************************************************** 1781 %INTEGER INC 1782 ! ABORT %UNLESS 0<=KP<=3 %AND 0<=KPP<=7 %AND OPCODE&1=0 1783 INC=2 1784 %IF KPP=PC %THEN %START 1785 %IF N<0 %THEN N=N&16_7FFFFFFF %AND NOTE CREF(CA,N) 1786 N=(N-CA)//2 1787 %FINISH 1788 %IF (1<>16&3) 1792 CODE(PPCURR+2)=N>>8&255 1793 CODE(PPCURR+3)=N&255 1794 ! %FINISH %ELSE %START 1795 ! *LSS_OPCODE 1796 ! *USH_1 1797 ! *OR_3 1798 ! *USH_2 1799 ! *OR_KP 1800 ! *USH_3 1801 ! *OR_KPP 1802 ! *USH_18 1803 ! *SLSS_N 1804 ! *AND_16_3FFFF 1805 ! *OR_%TOS 1806 ! *LDTB_16_58000004 1807 ! *LDA_CODE+4 1808 ! *LB_PPCURR 1809 ! *ST_(%DR+%B) 1810 ! %FINISH 1811 %IF KPP<=5 %THEN INC=4 1812 PPCURR=PPCURR+INC 1813 CA=CA+INC 1814 CODEOUT %IF PPCURR>=256 1815 %END 1816 %ROUTINE PSORLF1(%INTEGER OPCODE,KP,KPP,N) 1817 !*********************************************************************** 1818 !* AS PF1 BUT CUT VALID FORMS TO SHORT FORM * 1819 !*********************************************************************** 1820 %INTEGER INC 1821 INC=2 1822 %IF (KPP=0=KP %AND -64<=N<=63) %OR (KPP=LNB %AND KP&1=0 %AND 0<=N<=511) %START 1823 %IF KPP=LNB %THEN KP=1+KP>>1 1824 %IF KP#0 %THEN N=N//4 1825 ! %IF USE IMP=YES %THEN %START 1826 CODE(PPCURR)=OPCODE!KP>>1 1827 CODE(PPCURR+1)=(KP&1)<<7!(N&127) 1828 ! %FINISH %ELSE %START 1829 ! *LSS_OPCODE 1830 ! *USH_1 1831 ! *OR_KP 1832 ! *USH_7 1833 ! *SLSS_N 1834 ! *AND_127 1835 ! *LB_PPCURR 1836 ! *OR_%TOS 1837 ! *LDA_CODE+4 1838 ! *LDTB_16_58000002 1839 ! *ST_(%DR+%B) 1840 ! %FINISH 1841 %FINISH %ELSE %START 1842 %IF KPP=PC %THEN %START 1843 %IF N<0 %THEN N=N&16_7FFFFFFF %AND NOTE CREF(CA,N) 1844 N=(N-CA)//2 1845 %FINISH 1846 %IF (1<>16&3) 1850 CODE(PPCURR+2)=N>>8&255 1851 CODE(PPCURR+3)=N&255 1852 ! %FINISH %ELSE %START 1853 ! *LSS_OPCODE 1854 ! *USH_1 1855 ! *OR_3 1856 ! *USH_2 1857 ! *OR_KP 1858 ! *USH_3 1859 ! *OR_KPP 1860 ! *USH_18 1861 ! *SLSS_N 1862 ! *AND_16_3FFFF 1863 ! *OR_%TOS 1864 ! *LDTB_16_58000004 1865 ! *LDA_CODE+4 1866 ! *LB_PPCURR 1867 ! *ST_(%DR+%B) 1868 ! %FINISH 1869 %IF KPP<=5 %THEN INC=4 1870 %FINISH 1871 CA=CA+INC; PPCURR=PPCURR+INC 1872 CODEOUT %IF PPCURR>=256 1873 %END 1874 %ROUTINE PF2(%INTEGER OPCODE,H,Q,N,MASK,FILLER) 1875 !*********************************************************************** 1876 !* PLANT SECONDARY(STORE TO STORE) FORMAT INSTRNS * 1877 !* THESE MAY BE 16 OR 32 BIT DEPENDING ON Q * 1878 !*********************************************************************** 1879 ! ABORT %UNLESS 0<=H<=1 %AND 0<=Q<=1 %AND 0<=N<=127 %AND OPCODE&1=0 1880 PLANT(OPCODE<<8!H<<8!Q<<7!N) 1881 %IF Q#0 %THEN PLANT(MASK<<8!FILLER) 1882 %END 1883 %ROUTINE PF3(%INTEGER OPCODE,MASK,KPPP,N) 1884 !*********************************************************************** 1885 !* PLANT THE TERTIARY(JUMP) FORMAT INSTRUCTIONS * 1886 !*********************************************************************** 1887 ! ABORT %UNLESS 0<=MASK<=15 %AND 0<=KPPP<=7 %AND OPCODE&1=0 1888 %IF KPPP=PC %THEN %START 1889 %IF N<0 %THEN N=N&16_7FFFFFFF %AND NOTE CREF(CA,N) 1890 N=(N-CA)//2 1891 %FINISH 1892 CODE(PPCURR)=OPCODE!MASK>>3&1 1893 CODE(PPCURR+1)=(MASK&7)<<5!KPPP<<2!(N>>16&3) 1894 PPCURR=PPCURR+2 1895 CA=CA+2 1896 %IF KPPP<=5 %THEN %START 1897 CODE(PPCURR)=N>>8&255 1898 CODE(PPCURR+1)=N&255 1899 PPCURR=PPCURR+2; CA=CA+2 1900 %FINISH 1901 CODEOUT %IF PPCURR>=256 1902 %END 1903 %ROUTINE NOTE CREF(%INTEGER CA,N) 1904 !*********************************************************************** 1905 !* NOTE THAT A (PC+N) INSTRUCTION HAS N RELATIVE TO CONST TABLE * 1906 !* NOT REATIVE TO CODE. REMEMBER THE ADDRESS OF THE INSTRUCTION * 1907 !* SO THAT AN LPUT(18) CORRECTION CAN BE MADE AT END OF COMPILATION * 1908 !*********************************************************************** 1909 %RECORD(LISTF)%NAME CELL {(LISTF) 1910 CELL==ASLIST(CREFHEAD) 1911 %IF CREFHEAD=0 %OR CELL_S3#0 %THEN PUSH(CREFHEAD,CA,0,0) %AND %RETURN 1912 %IF CELL_S2=0 %THEN CELL_S2=CA %ELSE CELL_S3=CA 1913 %END ?N unused 1914 %ROUTINE PCLOD(%INTEGER FROM, TO) 1915 !*********************************************************************** 1916 !* PLANT A SERIES OF INTRUNS FROM ARRAY FIXED CODE * 1917 !*********************************************************************** 1918 %INTEGER I 1919 !%CONSTINTEGERARRAY FIXED CODE(0:127) 1920 ! %CYCLE I=FROM, 1, TO 1921 ! PCONST(FIXED CODE(I)) 1922 ! %REPEAT 1923 %END ?I unused ?TO unused ?FROM unused 1924 %ROUTINE CNOP(%INTEGER I, J) 1925 PSF1(JUNC,0,1) %WHILE CA&(J-1)#I 1926 %END 1927 %ROUTINE PGLA(%INTEGER BDRY, L, INF ADR) 1928 %INTEGER I, J 1929 J=GLACA; GLACA=(J+BDRY-1)&(-BDRY) 1930 GLACURR=GLACURR+GLACA-J; ! COMPLETE THE ROUNDING 1931 %IF L+GLACURR>256 %THEN %START 1932 %IF INHCODE=0 %THEN LPUT(2, GLACURR, GLACABUF, ADDR(GLABUF(0))) 1933 GLACURR=0; GLACABUF=GLACA 1934 %FINISH 1935 %CYCLE I=0,1,L-1 1936 GLABUF(GLACURR+I)=BYTE INTEGER(I+INF ADR) 1937 %REPEAT 1938 GLACA=GLACA+L; GLACURR=GLACURR+L 1939 %END 1940 %ROUTINE PLUG(%INTEGER AREA, AT, VALUE, BYTES) 1941 !*********************************************************************** 1942 !* WRITE UP TO ONE WORD INTO OBJECT FILE OUT OF SEQUENCE * 1943 !*********************************************************************** 1944 %INTEGERNAME WCABUF 1945 %INTEGER I, RELAD, BUFAD 1946 WCABUF==CABUF; BUFAD=ADDR(CODE(0)) 1947 %IF AREA=2 %THEN WCABUF==GLACABUF %AND BUFAD=ADDR(GLABUF(0)) 1948 RELAD=AT-WCABUF 1949 %IF 0<=RELAD<=256 %AND AREA<=3 %THEN %START 1950 %CYCLE I=0,1,BYTES-1 1951 BYTEINTEGER(RELAD+BUFAD+I)<-VALUE>>((BYTES-1-I)<<3) 1952 %REPEAT 1953 %FINISH %ELSE %START 1954 %IF RELAD=-2 %THEN CODEOUT 1955 %IF INHCODE=0 %THEN LPUT(AREA,BYTES,AT,ADDR(VALUE)+4-BYTES) 1956 !*DELSTART 1957 NCODE(ADDR(VALUE)+4-BYTES,ADDR(VALUE)+4,AT) %IF DCOMP=1=AREA 1958 !*DELEND 1959 %FINISH 1960 %END 1961 1962 %INTEGERFN PARAM DES(%INTEGER PREC) 1963 !*********************************************************************** 1964 !* SET UP BNDED L=1 DESRIPTOR FOR PASSING VARIABLE BY REFERENCE * 1965 !* ONLY THE TOP HALF IS SET UP * 1966 !*********************************************************************** 1967 %INTEGER K,DES 1968 K=DESADS(PREC) 1969 %RESULT=K %UNLESS K=0 1970 %IF PREC=4 %THEN DES=16_58000002 %ELSE DES=PREC<<27!1 1971 STORE CONST (K,4,ADDR(DES)) 1972 DESADS(PREC)=K 1973 %RESULT=K 1974 %END 1975 %INTEGERFN MAPDES(%INTEGER PREC) 1976 !*********************************************************************** 1977 !* SET UP 8BIT ZERO ADDRESS UNSCALED BCI DESCRTR FOR MAPPING * 1978 !*********************************************************************** 1979 %INTEGER K,DES0,DES1 1980 K=DESADS(PREC+8) 1981 %RESULT=K %UNLESS K=0 1982 %IF PREC=4 %THEN DES0=16_58000002 %ELSE DES0=16_03000000!PREC<<27 1983 DES1=0; STORE CONST(K,8,ADDR(DES0)) 1984 DESADS(PREC+8)=K 1985 %RESULT=K 1986 %END 1987 %INTEGERFN SPECIAL CONSTS(%INTEGER WHICH) 1988 !*********************************************************************** 1989 !* PUTS CERTAIN SPECIAL CONSTANTS INTO THE CONSTANT TABLE ON * 1990 !* DEMAND AND REMEMBERS THEIR POSN TO AVOID SEARCHONG * 1991 !*********************************************************************** 1992 {%CONST}%ownINTEGERARRAY SCS(0:5) = 16_40800000,0, 1993+ 16_41100000,0, 1994+ 1,0; 1995 %INTEGER K 1996 K=DESADS(WHICH+16) 1997 %RESULT=K %UNLESS K=0 1998 STORE CONST(K,8,ADDR(SCS(2*WHICH))) 1999 DESADS(WHICH+16)=K 2000 %RESULT=K 2001 %END 2002 %ROUTINE STORE CONST(%INTEGERNAME D, %INTEGER L, AD) 2003 !*********************************************************************** 2004 !* PUT THE CONSTANT VAL OF LENGTH 'L' INTO THE CONSTANT TABLE * 2005 !* A CHECK IS MADE TO SEE IF THE CONSTANT HAS ALREADY * 2006 !* BEEN INSERTED IN WHICH CASE THE OLD COPY IS REUSED * 2007 !*********************************************************************** 2008 %INTEGER I, J, K, C1, C2, C3, C4, LP 2009 LP=L//4; C2=0; C3=0; C4=0 2010 %CYCLE I=0,1,L-1 2011 BYTEINTEGER(ADDR(C1)+I)=BYTEINTEGER(AD+I) 2012 %REPEAT 2013 %IF PARMOPT#0 %THEN ->SKIP 2014 K=CONST BTM; ! AFTER STRINGS IN CTABLE 2015 %IF L=4 %THEN %START 2016 ! %IF USE IMP=YES %THEN %START 2017 %WHILE K 2030 ! *ICP_(%DR+%B) 2031 ! *JCC_7, 2032 ! *CPB_CONSTHOLE 2033 ! *JCC_8, 2034 ! *LSS_%B 2035 ! *IMY_4 2036 ! *OR_16_80000000 2037 ! *ST_(D) 2038 ! *EXIT_-64 2039 ! %FINISH 2040 %FINISH %ELSE %START 2041 J=CONSTPTR-LP 2042 %WHILE K<=J %CYCLE 2043 %IF CTABLE_val(K)=C1 %AND CTABLE_val(K+1)=C2 %AND (CONSTHOLE=K+LP) %START 2044 %IF L=8 %OR (CTABLE_val(K+2)=C3 %AND CTABLE_val(K+3)=C4) %THEN D=4*K!16_80000000 %AND %RETURN 2045 %FINISH 2046 K=K+2 2047 %REPEAT 2048 %FINISH 2049 SKIP: 2050 %IF L=4 %AND CONSTHOLE#0 %START 2051 CTABLE_val(CONSTHOLE)=C1 2052 D=4*CONSTHOLE!16_80000000 2053 CONSTHOLE=0 2054 %RETURN 2055 %FINISH 2056 %IF L>4 %AND CONST PTR&1#0 %THEN CONSTHOLE=CONST PTR %AND CONSTPTR=CONST PTR+1 2057 D=4*CONST PTR!16_80000000 2058 CTABLE_val(CONSTPTR)=C1 2059 CTABLE_val(CONSTPTR+1)=C2 2060 %IF L=16 %THEN CTABLE_val(CONSTPTR+2)=C3 %AND CTABLE_val(CONSTPTR+3)=C4 2061 CONST PTR=CONST PTR+LP 2062 %IF CONST PTR>CONST LIMIT %THEN FAULT(107,0) 2063 %END 2064 %ROUTINE GET ENV(%INTEGERNAME HEAD) 2065 !*********************************************************************** 2066 !* SAVE A COPY OF THE REGISTER STATE FOR FUTURE REFERENCE * 2067 !*********************************************************************** 2068 %INTEGER I, USE 2069 %CYCLE I=0, 1, 7 2070 USE=GRUSE(I)&16_FF; ! MAIN USE ONLY 2071 PUSH(HEAD, GRINF1(I), GRAT(I), I<<8!USE) %IF USE#0 2072 %REPEAT 2073 %END 2074 %ROUTINE RESTORE(%INTEGER HEAD) 2075 !*********************************************************************** 2076 !* RESET THE REGISTERS TO ENVIRONMENT IN LIST HEADED BY 'HEAD' * 2077 !*********************************************************************** 2078 %INTEGER I, R, USE, INF, AT 2079 %CYCLE I=0, 1, 7 2080 %IF REGISTER(I)>=0 %THEN GRUSE(I)=0 %AND GRINF1(I)=0 2081 %REPEAT 2082 %WHILE HEAD#0 %CYCLE 2083 POP(HEAD, INF, AT, I) 2084 R=I>>8; USE=I&255 2085 %IF REGISTER(R)>=0 %THEN GRUSE(R)=USE %AND GRINF1(R)=INF 2086 GRAT(R)=AT 2087 %REPEAT 2088 %END 2089 %ROUTINE RELOCATE(%INTEGER GLARAD,VALUE,AREA) 2090 !*********************************************************************** 2091 !* PLANTS A WORD IN THE GLA (IF GLARAD<0) AND ARRANGES TO * 2092 !* RELOCATE IT RELATIVE TO AN AREA(CODE=1,GLA=2,CST=4,GST=5 * 2093 !* IF THE RELOCATION IS RELATIVE TO SYMBOL TABLES THE WORD * 2094 !* CAN NOT BE RELOCATED TILL SIZE OF THE CODE(OR GLA) IS KNOWN * 2095 !*********************************************************************** 2096 %IF GLARAD<0 %THEN PGLA(4,4,ADDR(VALUE)) %AND GLARAD=GLACA-4 2097 LPUT(19,2,GLARAD,AREA) 2098 %END 2099 %ROUTINE GXREF(%STRING(31) NAME,%INTEGER MODE,XTRA,AT) 2100 !*********************************************************************** 2101 !* ASK LPUT TO ARRANGE FOR A DOUBLE WORD AT 'AT' IN THE GLA * 2102 !* TO CONTAIN A DESCRIPTOR FOR NAME 'NAME'. * 2103 !* MODE=0 STATIC CODE XREF * 2104 !* MODE=1 DYNAMIC CODE XREF * 2105 !* MODE=2 DATA XREF XTRA=MINIMIUM LENGTH * 2106 !*********************************************************************** 2107 %INTEGER LPUTNO 2108 %IF MODE=2 %THEN LPUTNO=15 %ELSE LPUTNO=MODE+12 2109 LPUT(LPUTNO,XTRA,AT,ADDR(NAME)) 2110 %END 2111 %ROUTINE CXREF(%STRING(255) NAME,%INTEGER MODE,XTRA,%INTEGERNAME AT) 2112 !*********************************************************************** 2113 !* CREATE A ZEROED AREA IN THE GLA AND CALL GXREF TO GET * 2114 !* IT FILLED AT LOAD TIME WITH INFORMATION ON AN EXTERNAL OBJECT * 2115 !* PARAMETERS ARE AS FOR GXREF. * 2116 !*********************************************************************** 2117 %INTEGER Z1,Z2 2118 Z1=0; Z2=0 2119 PGLA(8,8,ADDR(Z1)); ! 2 ZERO WORDS 2120 AT=GLACA-8 2121 GXREF(NAME,MODE,XTRA,AT) 2122 %END 2123 %ROUTINE CODEDES(%INTEGERNAME AT) 2124 !*********************************************************************** 2125 !* PUT A CODE DESCRIPTOR INTO THE PLT FOR USE BY DEFINE EP * 2126 !*********************************************************************** 2127 %INTEGER DESC1,DESC2 2128 DESC1=16_E1000000; DESC2=0 2129 %IF CDCOUNT=0 %THEN FIXED GLA(0)=DESC1 %AND AT=0 %ELSE PGLA(8,8,ADDR(DESC1)) %AND AT=GLACA-8 2130 CDCOUNT=CDCOUNT+1 2131 %END 2132 %ROUTINE DEFINE EP(%STRING(255)NAME, %INTEGER ADR,AT,MAIN) 2133 !*********************************************************************** 2134 !* AN EP CONSISTS OF A CODE DESCRIPTOR IN THE GLA(PLT) OF * 2135 !* FILE CONTAINING THE EP. LPUT IS TOLD ABOUT THIS AND THE LOADER* 2136 !* ARRANGES TO PUT A DESCRIPTOR-DESCRIPTOR TO THE CODE-DESC * 2137 !* IN THE GLA OF ANY FILE REFERENCES THIS EP. THIS FIRST WORD * 2138 !* OF ICLS PLT IS THE MAIN EP AND WE MIMIC THIS AS FAR AS POSS * 2139 !*********************************************************************** 2140 %IF AT=0 %THEN FIXED GLA(1)=ADR %ELSE PLUG(2,AT+4,ADR,4) 2141 RELOCATE(AT+4,ADR,1) 2142 LPUT(11,MAIN<<31!2,AT,ADDR(NAME)) %IF NAME#"" 2143 %END 2144 %ROUTINE PROLOGUE 2145 !*********************************************************************** 2146 !* GENERATES THE SUBROUTINE THAT ALWAYS ARE REQUIRED ONTO THE * 2147 !* FRONT OF THE OBJECT PROGRAM WHERE THEY ARE DIRECTLY ADDRESABLE* 2148 !*********************************************************************** 2149 %INTEGERFNSPEC STRINGIN(%INTEGER POS) 2150 %ROUTINESPEC ERR EXIT(%INTEGER A, B, C) 2151 %INTEGER I, K, L, STCA 2152 I=16_C2C2C2C2 2153 LPUT(4,4,0,ADDR(I)) 2154 SSTL=4 2155 %CYCLE I=0, 1, 31 2156 PLABS(I)=0; PLINK(I)=0 2157 DESADS(I)=0 2158 %REPEAT 2159 ! 2160 ! GENERATE THE FIXED-FLOAT CONSTANTS THAT MAY BE NEEDED 2161 ! 2162 PLABS(1)=CA 2163 %CYCLE I=0, 1, 1 2164 PCONST(UNASSPAT) 2165 %REPEAT 2166 ! 2167 ! GENERATE THE RUN TIME ERROR ROUTINE :- 2168 ! MDIAGS FOR NR IS %ROUTINE MDIAGS(%INT PC,LNB,ERROR,XTRA) 2169 ! PC IS A DUMMY (SEG FIELD ONLY USED) EXCEPT AFTER CONTINGENCY 2170 ! ON ENTRY TO THIS SUBROUTINE ERROR & XTRA ARE IN ACC AS 64 BIT INTEGER 2171 ! ENTRY HAS BEEN BY JLK SO RETURN ADDRESS STACKED 2172 ! 2173 !RTF PRCL 4 TO PLANT PARAMS 2174 ! JLK +1 STACK DUMMY PC 2175 ! STLN TOS LNB AS SECOND PARAMETER 2176 ! ST TOS ERROR NO AS THIRD PARAM 2177 ! LXN (LNB+4) POINTER TO GLA 2178 ! RALN 9 TO STORED LNB 2179 ! CALL ((XNB+10)) VIA XREF=DESCRIPTOR-DESCRIPTOR 2180 ! J TOS BACK AFTER A MONITOR 2181 ! 2182 PLABS(2)=CA 2183 PSF1(PRCL,0,4) 2184 PSF1(JLK,0,1) 2185 PF1(STLN,0,TOS,0) 2186 PF1(ST,0,TOS,0) 2187 PSF1(LXN,1,16) 2188 PSF1(RALN,0,9) 2189 PF1(CALL,2,XNB,40) 2190 PF1(JUNC,0,TOS,0) 2191 ! 2192 ! SUBROUTINE TO CALL DEBUG ROUTINE(S#IMPMON) LINE NO IN ACC 2193 ! 2194 ! PRCL 4 2195 ! ST TOS 2196 ! LXN (LNB+4) 2197 ! RALN 6 2198 ! CALL ((XNB+IMPMONEPDISP)) 2199 ! JUNC TOS 2200 ! 2201 %IF PARMDBUG#0 %THEN %START 2202 PLABS(3)=CA 2203 CXREF("S#IMPMON",PARMDYNAMIC,2,K) 2204 PSF1(PRCL,0,4) 2205 PF1(ST,0,TOS,0) 2206 PSF1(LXN,1,16) 2207 PSF1(RALN,0,6) 2208 PF1(CALL,2,XNB,K) 2209 PF1(JUNC,0,TOS,0) 2210 %FINISH 2211 ! 2212 ! SUBROUTINE TO ADVANCE STACK FRONT BY B WORDS AND FILL WITH UNASSIGNED 2213 ! 2214 ! JAT 12,*+13 B IS ZERO 2215 ! LSS TOS 2216 ! STSF TOS 2217 ! LDTB STRING DECRIPTOR SET UP DESCRIPTOR FOR MVL 2218 ! LDA TOS 2219 ! ASF B ADVANCE BY B WORDS 2220 ! MYB 4 CHANGE B TO BYTES 2221 ! LDB B AND MOVE TO BOUND FIELD 2222 ! MVL L=DR AND FILL WITH X80S 2223 ! ST TOS 2224 ! J TOS RETURN 2225 ! 2226 %IF PARMCHK=1 %THEN %START; ! ONLY REQUIRED WITH CHKING 2227 CNOP(0,4); K=CA 2228 PCONST(16_58000000) 2229 PLABS(4)=CA 2230 PF3(JAT,12,0,13) 2231 PF1(LSS,0,TOS,0) 2232 PF1(STSF,0,TOS,0) 2233 PF1(LDTB,0,PC,K) 2234 PF1(LDA,0,TOS,0) 2235 PF1(ASF,0,BREG,0) 2236 PSF1(MYB,0,4) 2237 PF1(LDB,0,BREG,0) 2238 PF2(MVL,1,1,0,0,UNASSPAT&255) 2239 PF1(ST,0,TOS,0) 2240 PF1(JUNC,0,TOS,0) 2241 %FINISH 2242 ! 2243 ! SOME ERROR ROUTINES 2244 ! 2245 ERR EXIT(5, 16_801, 0) %IF PARMOPT#0; ! UNASSIGNED VARIABLE 2246 ERR EXIT(6, 16_504, 0); ! SWITCH LABEL UNSET 2247 ERR EXIT(7, 16_505, 1); ! ILLEGEAL EXPONENTIATION 2248 ERR EXIT(8,16_201, 0) %IF PARMOPT#0; ! EXCESS BLOCKS 2249 ERR EXIT(9, 16_601, 0); ! CAPACITY EXCEEDED 2250 ERR EXIT(10,21, 0) ; ! NO RESULT 2251 ERR EXIT(11,16_501, 0) %IF PARMOPT#0; ! CYCLE NOT VALID 2252 ERR EXIT(12,16_701,0); ! RES FAILS 2253 ERR EXIT(13,36,0) %IF PARMOPT#0; ! WRONG NO OF PARAMS 2254 ! 2255 ! PUT THE STRINGS ONTO THE FRONT OF CONSTANT AREA 2256 ! 2257 CTABLE_val(0)=16_18000001 2258 CTABLE_val(1)=4 2259 STCA=8; L=ADDR(CTABLE_val(0)) 2260 CONST PTR=2; ! IN CASE NO STRINGS 2261 %WHILE STRLINK#0 %CYCLE 2262 I=STRLINK; STRLINK=FROM AR4(I) 2263 TO AR4(I,STRINGIN(I+4)); ! CHANGE LINK TO STRING ADDR 2264 %REPEAT 2265 STRLINK=16_80000000 2266 CONST BTM=CONST PTR 2267 %IF PARMOPT#0 %THEN CTABLE_val(CONST PTR)=M'IDIA' %AND CONST PTR=CONST PTR+1 2268 GXREF(MDEP,PARMDYNAMIC,2,40) 2269 %IF PARMPROF#0 %THEN %START; ! ALLOCATE PROFILE COUNT AREA 2270 I=16_38000001+LINE 2271 K=8 2272 PARMPROF=GLACA 2273 PGLA(4,8,ADDR(I)) 2274 K=0 2275 %CYCLE I=0,1,LINE 2276 PGLA(4,4,ADDR(K)) 2277 %REPEAT 2278 LINE=0 2279 %FINISH 2280 LEVEL=1 2281 %CYCLE I=0,1,31 2282 %IF PLINK(I)#0 %THEN CLEAR LIST(PLINK(I)) 2283 %REPEAT 2284 %RETURN 2285 %INTEGERFN STRINGIN(%INTEGER POS) 2286 !*********************************************************************** 2287 !* PUT A STRING INTO THE CONSTANT AREA CHECKING FOR DUPLICATES * 2288 !*********************************************************************** 2289 %INTEGER J,K,IND,HD 2290 %RECORD(LISTF)%NAME CELL{(LISTF) 2291 K=A(POS) 2292 %IF K=0 %THEN %RESULT=0 2293 IND=K&31; HD=PLINK(IND) 2294 %WHILE HD#0 %CYCLE 2295 CELL==ASLIST(HD) 2296 %IF CELL_S1=K %AND STRING(L+CELL_S2)=STRING(ADDR(A(POS))) %THEN %RESULT=CELL_S2-4 2297 HD=CELL_LINK 2298 %REPEAT 2299 HD=STCA 2300 BYTEINTEGER(L+STCA)=K; STCA=STCA+1 2301 %CYCLE J=POS+1,1,POS+K 2302 BYTE INTEGER(L+STCA)=A(J) 2303 STCA=STCA+1 2304 %REPEAT 2305 CONST PTR=((STCA+7)&(-8))>>2 2306 PUSH(PLINK(IND),K,HD,0) 2307 %RESULT=HD-4 2308 %END 2309 %ROUTINE ERR EXIT(%INTEGER LAB, ERRNO, MODE) 2310 !*********************************************************************** 2311 !* MODE=0 FOR DUMMY(ZERO) XTRA - MODE=1 XTRA IN BREG * 2312 !*********************************************************************** 2313 PLABS(LAB)=CA 2314 %IF MODE=0 %THEN PSF1(LSS,0,0) %ELSE PF1(LSS,0,BREG,0) 2315 PSF1(LUH,0,ERRNO) 2316 PSF1(JLK,0,(PLABS(2)-CA)//2) 2317 %END 2318 %END 2319 %ROUTINE CSS(%INTEGER P) 2320 %ROUTINESPEC MERGE INFO 2321 %ROUTINESPEC REDUCE ENV(%INTEGERNAME HEAD) 2322 %ROUTINESPEC ENTER JUMP(%INTEGER MASK,STAD,FLAG) 2323 %INTEGERFNSPEC ENTER LAB(%INTEGER M,FLAG) 2324 %ROUTINESPEC REMOVE LAB(%INTEGER LAB) 2325 %ROUTINESPEC CEND(%INTEGER KKK) 2326 %INTEGERFNSPEC CCOND(%INTEGER CTO,A,B) 2327 %ROUTINESPEC CHECK STOF 2328 %INTEGERFNSPEC REVERSE(%INTEGER MASK) 2329 %ROUTINESPEC SET LINE 2330 %INTEGERFNSPEC SET XORYNB(%INTEGER WHICH,RLEVEL) 2331 %INTEGERFNSPEC XORYNB(%INTEGER USE,INF) 2332 %ROUTINESPEC GET IN ACC(%INTEGER ACC,SIZE,AC,AREA,DISP) 2333 %INTEGERFNSPEC AREA CODE 2334 %INTEGERFNSPEC AREA CODE2(%INTEGER BS) 2335 %ROUTINESPEC CUI(%INTEGER CODE) 2336 %ROUTINESPEC ASSIGN(%INTEGER A,B) 2337 %ROUTINESPEC CSTART(%INTEGER CCRES,MODE) 2338 %ROUTINESPEC CCYCBODY(%INTEGER UA,ELAB,CLAB) 2339 %ROUTINESPEC CLOOP(%INTEGER ALT,MARKC,MARKUI) 2340 %ROUTINESPEC CIFTHEN(%INTEGER MARKIU,MARKC,MARKUI,MARKE,MARKR,SKIP) 2341 %ROUTINESPEC CREATE AH(%INTEGER MODE) 2342 %ROUTINESPEC TORP(%INTEGERNAME HEAD,BOT,NOPS) 2343 %INTEGERFNSPEC INTEXP(%INTEGERNAME VALUE) 2344 %INTEGERFNSPEC CONSTEXP(%INTEGER PRECTYPE) 2345 %ROUTINESPEC CSEXP(%INTEGER REG,MODE) 2346 %ROUTINESPEC CSTREXP(%INTEGER A,B) 2347 %ROUTINESPEC CRES(%INTEGER LAB) 2348 %ROUTINESPEC EXPOP(%INTEGER A,B,C,D) 2349 %ROUTINESPEC TEST APP(%INTEGERNAME NUM) 2350 %ROUTINESPEC SKIP EXP 2351 %ROUTINESPEC SKIP APP 2352 %ROUTINESPEC NO APP 2353 %INTEGERFNSPEC DOPE VECTOR(%INTEGER A,B,MODE,ID,%INTEGERNAME C,D) 2354 %ROUTINESPEC DECLARE ARRAYS(%INTEGER A,B) 2355 %ROUTINESPEC DECLARE SCALARS(%INTEGER A,B) 2356 %ROUTINESPEC MAKE DECS(%INTEGER Q) 2357 %ROUTINESPEC SAVE AUX STACK 2358 %ROUTINESPEC RESET AUX STACK 2359 %ROUTINESPEC CRSPEC(%INTEGER M) 2360 %ROUTINESPEC CFPLIST(%INTEGERNAME A,B) 2361 %ROUTINESPEC CFPDEL 2362 %ROUTINESPEC CLT 2363 %ROUTINESPEC CQN(%INTEGER P) 2364 %ROUTINESPEC GET WSP(%INTEGERNAME PLACE,%INTEGER SIZE) 2365 %ROUTINESPEC RETURN WSP(%INTEGER PLACE,SIZE) 2366 %INTEGERFNSPEC TSEXP(%INTEGERNAME VALUE) 2367 %ROUTINESPEC CRCALL(%INTEGER RTNAME) 2368 %ROUTINESPEC NAMEOP(%INTEGER Z,REG,SIZE,NAMEP) 2369 %ROUTINESPEC CNAME(%INTEGER Z,REG) 2370 %ROUTINESPEC CANAME(%INTEGER Z,BS,DP) 2371 %ROUTINESPEC CSNAME(%INTEGER Z,REG) 2372 %ROUTINESPEC TEST ASS(%INTEGER REG,TYPE,SIZE) 2373 %ROUTINESPEC COPY TAG(%INTEGER KK) 2374 %ROUTINESPEC REDUCE TAG 2375 %ROUTINESPEC REPLACE TAG (%INTEGER KK) 2376 %ROUTINESPEC RT JUMP(%INTEGER CODE,%INTEGERNAME L) 2377 %ROUTINESPEC STORE TAG(%INTEGER KK,SLINK) 2378 %ROUTINESPEC UNPACK 2379 %ROUTINESPEC PACK(%INTEGERNAME PTYPE) 2380 %ROUTINESPEC DIAG POINTER(%INTEGER LEVEL) 2381 %ROUTINESPEC RDISPLAY(%INTEGER KK) 2382 %ROUTINESPEC RHEAD(%INTEGER KK) 2383 %ROUTINESPEC ODD ALIGN 2384 %INTEGERFNSPEC PTR OFFSET(%INTEGER RLEV) 2385 %ROUTINESPEC PPJ(%INTEGER MASK,N) 2386 %ROUTINESPEC CRFORMAT(%INTEGERNAME OPHEAD) 2387 %INTEGERFNSPEC DISPLACEMENT(%INTEGER LINK) 2388 %INTEGERFNSPEC COPY RECORD TAG(%INTEGERNAME SUBS) 2389 %ROUTINESPEC SAVE IRS 2390 %ROUTINESPEC COPY DR 2391 %ROUTINESPEC BOOT OUT(%INTEGER REG) 2392 %ROUTINESPEC CHANGE RD(%INTEGER REG) 2393 %ROUTINESPEC FORGET(%INTEGER REG) 2394 %ROUTINESPEC REMEMBER 2395 %ROUTINESPEC NOTE ASSMENT(%INTEGER REG,ASSOP,VAR) 2396 %SWITCH SW(1:24) 2397 %RECORDFORMAT RD(%BYTEINTEGER UPTYPE,PTYPE,XB,FLAG,{%C 2398+ %INTEGER D,XTRA) 2399 %INTEGER SNDISP,ACC,K,KFORM,STNAME,MIDCELL 2400 %INTEGER TCELL,NUMMOD,JJ,JJJ,KK,QQ,MARKER,REPORTUI,XDISP,MASK, {%C 2401+ BASE,AREA,ACCESS,DISP,EXTRN, CURR INST,VALUE,STRINGL, {%C 2402+ PTYPE,I,J,OLDI,USEBITS,TWSPHEAD,KKK,STRFNRES, {%C 2403+ MARKIU,MARKUI,MARKC,MARKE,MARKR 2404 %INTEGER LITL,ROUT,NAM,ARR,PREC,TYPE 2405 %RECORD (RD) EXPOPND{(RD); ! RESULT RECORD FOR EXPOP 2406 CURR INST=0 2407 TWSPHEAD=0 2408 %INTEGERARRAY SGRUSE,SGRINF(0:7) 2409 ->SW(A(P)) 2410 SW(23): ! INCLUDE SOMETHING 2411 SW(24): ! REDUNDANT SEP 2412 SW(2): ! 2413 CSSEXIT: LAST INST=CURR INST 2414 %WHILE TWSPHEAD#0 %CYCLE 2415 POP(TWSPHEAD,JJ,KK,QQ) 2416 RETURN WSP(JJ,KK) 2417 %REPEAT 2418 %RETURN 2419 SW(1): !(UI)(S) 2420 FAULT(57,0) %UNLESS LEVEL>=2 2421 MARKER=P+1+A(P+1)<<8+A(P+2) 2422 P=P+3 2423 ->LABFND %IF A(MARKER)=1 2424 %IF A(MARKER)=2 %THEN SET LINE %AND CUI(0) %AND ->CSSEXIT 2425 MARKE=0; MARKR=0 2426 MARKUI=P; MARKIU=MARKER+1 2427 MARKC=MARKIU+1 2428 %IF A(MARKER)=3 %THEN CIFTHEN(MARKIU,MARKC,MARKUI,0,0,NO) %AND ->CSSEXIT 2429 CLOOP(A(MARKIU),MARKC+2,MARKUI) 2430 ->CSSEXIT 2431 LABFND: ->SWITCH %UNLESS A(P)=1 %AND A(P+5)=2; ! 1ST OF UI AND NO APP 2432 ->SWITCH %UNLESS A(P+6)=2 %AND A(P+7)=2;! NO ENAMSE OR ASSNMNT 2433 JJ=ENTER LAB(FROM AR2(P+3),0); ->CSSEXIT 2434 SW(5): ! %CYCLE 2435 FAULT(57,0) %UNLESS LEVEL>=2 2436 %IF A(P+5)=2 %THEN %START; ! OPEN CYCLE 2437 CLOOP(0,P+1,0) 2438 %FINISH %ELSE %START 2439 CLOOP(6,P+6,P+1) 2440 %FINISH 2441 ->CSSEXIT 2442 ! 2443 SW(6): ! REPEAT 2444 ->CSSEXIT 2445 SW(22): ! '%CONTROL' (CONST) 2446 J=FROM AR4(P+2) 2447 CODEOUT 2448 DCOMP=J>>28; ->CSSEXIT 2449 ! 2450 SW(3): ! (%IU)(COND)%THEN(UI)(ELSE') 2451 MARKIU=P+1; MARKC=MARKIU+3 2452 MARKR=P+2+A(P+2)<<8+A(P+3); ! ! FROMAR2(P+2) 2453 MARKE=0 2454 %IF A(MARKR)=3 %THEN %START 2455 MARKE=MARKR+1+FROMAR2(MARKR+1) 2456 MARKUI=MARKR+3 2457 %FINISH 2458 CIFTHEN(MARKIU,MARKC,MARKUI,MARKE,MARKR,NO) 2459 ->CSSEXIT 2460 SW(4): 2461 ! '%FINISH(ELSE')(S) 2462 ->CSSEXIT 2463 SWITCH: %BEGIN; ! SWITCH LABEL 2464 %INTEGER HEAD,BASEPT,NAPS,FNAME 2465 %INTEGERARRAY BITS(0:2) 2466 FORGET(-1) 2467 FNAME=FROM AR2(P+3) 2468 %UNLESS A(P)=1 %AND A(P+5)=1 %THEN FAULT2(5,0,FNAME) %AND ->BEND 2469 ! 1ST OF UI + APP 2470 P=P+3; TEST APP(NAPS) 2471 P=P+6 2472 %UNLESS INTEXP(JJ)=0 %THEN FAULT2(41,0,0) %AND ->BEND 2473 ! UNLESS EXPRESSION EVALUATES AND 2474 %UNLESS NAPS=1 %THEN FAULT2(21,NAPS-1,FNAME) %AND ->BEND 2475 ! NO REST OF APP 2476 %UNLESS A(P+1)=2=A(P+2) %THEN FAULT2(5,0,FNAME) %AND ->BEND 2477 ! NO ENAME OR REST OF ASSIGMENT 2478 COPY TAG(FNAME) 2479 HEAD=K 2480 %IF OLDI#LEVEL %OR TYPE#6 %THEN FAULT(4,FNAME) %AND ->BEND 2481 FROM123(HEAD,BASEPT,KKK,KK); ! EXTRACT TABLE ADDR,LB & UB 2482 MLINK(HEAD); ! K POINTS TO BIT LIST 2483 ->INBD %IF KKK<=JJ<=KK 2484 FAULT2(50,JJ,FNAME); ->BEND 2485 INBD: Q=JJ-KKK 2486 %WHILE Q>=96 %%CYCLE 2487 MLINK(HEAD) 2488 Q=Q-96 2489 %REPEAT 2490 ! 2491 ! ASLIST(HEAD) IS THE START OF 96 BIT ENTRY IN THE BIT LIST 2492 ! CHECK BIT NO Q TO SEE IF LABEL ALREADY SET AND THEN SET BIT Q 2493 ! 2494 FROM123(HEAD,BITS(0),BITS(1),BITS(2)) 2495 QQ=Q>>5; ! RIGHT WORD 2496 Q=Q&31; JJJ=1<CSSEXIT 2509 SW(7): ! (%WU)(SC)(COND)(RESTOFWU) 2510 FAULT(57,0) %UNLESS LEVEL>=2 2511 MARKIU=P+1; ! TO WHILE/UNTIL 2512 MARKC=MARKIU+3; ! TO (SC)(COND) 2513 CLOOP(A(MARKIU)+3,MARKC,MARKIU+1+FROMAR2(MARKIU+1)) 2514 ->CSSEXIT 2515 ! 2516 SW(8): ! SIMPLE DECLN 2517 FAULT(57,0) %UNLESS LEVEL>=2 2518 FAULT(40,0) %IF NMDECS(LEVEL)&1#0 2519 QQ=P; P=P+5;CLT;ROUT=0; LITL=0 2520 %IF A(P)#1 %THEN %START; ! ARRAY DECLARATIONS 2521 FAULT(70,0) %IF TYPE=5 %AND ACC=0 2522 NAM=0 2523 SET LINE 2524 QQ=2-A(P+1); P=P+2; ! QQ=1 FOR ARRAYFORMATS 2525 DECLARE ARRAYS(QQ,0) 2526 %FINISH %ELSE %START 2527 %IF A(QQ+1)=128 %THEN %START;! NOT LINKED&SHUFFLED 2528 CQN(P+1); P=P+2 2529 DECLARE SCALARS(1,0) 2530 %FINISH 2531 %FINISH 2532 ->CSSEXIT 2533 ! 2534 SW(9): ! %END 2535 %BEGIN 2536 %SWITCH S(1:5) 2537 -> S(A(P+1)) 2538 S(1): ! ENDOFPROGRAM 2539 S(2): ! ENDOFFILE 2540 %IF CPRMODE=0 %THEN CPRMODE=2 2541 FAULT(15,0) %UNLESS LEVEL+CPRMODE=3 2542 FAULT(56,0) %UNLESS A(P+1)=CPRMODE 2543 CEND(CPRMODE) 2544 ->BEND 2545 S(3): ! ENDOFLIST 2546 LIST=0; 2547 ->BEND 2548 S(4): ! END 2549 CEND(FLAG(LEVEL)) 2550 BEND: %END 2551 ->CSSEXIT 2552 ! 2553 SW(11): 2554 %BEGIN 2555 %INTEGER MARKER1,KK,KKK 2556 %STRING(34)XNAME 2557 P=P+1; MARKER1=FROM AR2(P)+P; ! (SEX)(RT)(SPEC')(NAME)(FPP) 2558 AGN: Q=P; KK=FROM AR2(MARKER1+5); ! KK ON NAME 2559 EXTRN=A(P+2) 2560 LITL=EXTRN&3 2561 %IF A(MARKER1)=1 %THEN %START;! P<%SPEC'>='%SPEC' 2562 P=P+3; CRSPEC(1-EXTRN>>2);! 0 FOR ROUTINESPEC 2563 ! 1 FOR EXTERNAL (ETC) SPEC 2564 ->BEND 2565 %FINISH 2566 COPY TAG(KK) 2567 %IF OLDI=LEVEL %THEN %START 2568 %IF CPRMODE=0 %THEN CPRMODE=2;! FLAG AS FILE OF ROUTINES 2569 ! 2570 %IF (CPRMODE=2 %AND LEVEL=1) %START 2571 %IF EXTRN=3 %THEN EXTRN=2 2572 XNAME<-STRING(DICTBASE+WORD(KK)) 2573 %IF EXTRN=1 %THEN XNAME<-"S#".XNAME 2574 %IF EXTRN=4 %THEN XNAME="" 2575 JJ=MIDCELL; ! CODE DESCRIPTOR REL ADDR 2576 %IF EXTRN#4 %THEN USEBITS=2 2577 DEFINE EP(XNAME,CA,JJ,0) 2578 %IF JJ#0 %THEN PSF1(INCA,0,-JJ) 2579 %FINISH %ELSE %START; ! EXTERNALS IN PRGM OR WRNG LEVEL 2580 FAULT(55,KK) %UNLESS EXTRN=4; EXTRN=4 2581 %FINISH 2582 %IF A(P+3)=1 %THEN KKK=LITL<<14!16_1000 %ELSE %START 2583 ROUT=1; P=P+4; ! FIGURE OUT PTYPE FOR FNS&MAPS 2584 CLT; ARR=0; NAM=0 2585 %IF A(P)=2 %THEN NAM=2; ! SET NAME ARRAY BIT FOR MAPS 2586 PACK(KKK); ! AND STORE PTYPE IN KKK 2587 %FINISH 2588 %FINISH 2589 %UNLESS OLDI=LEVEL %AND J=15 %AND PTYPE=KKK %START 2590 P=Q+3; CRSPEC(0); P=Q; ->AGN 2591 %FINISH 2592 PTYPE=PTYPE!(EXTRN&3)<<14; ! DEAL WITH %ROUTINESPEC FOLLOWED 2593 ! BY %EXTERNALROUTINE 2594 %BEGIN 2595 %INTEGER PTR,PTYPEP,CNT,PP 2596 J=0; REPLACE TAG(KK);! BODY GIVEN SO UPDATE TAGS INFO 2597 JJ=K; PLABEL=PLABEL-1 2598 %UNLESS COMPILER=1 %OR (CPRMODE=2 %AND LEVEL=1) %START 2599 %IF JROUND(LEVEL+1)=0 %START; ! NOT JUMP OUTSTANDING 2600 JROUND(LEVEL+1)=PLABEL 2601 ENTER JUMP(15,PLABEL,0) 2602 %FINISH 2603 %FINISH 2604 PTYPEP=PTYPE 2605 P=MARKER1+7 2606 RHEAD(KK) 2607 N=20; CNT=1 2608 %WHILE A(P)=1 %CYCLE; ! WHILE SOME (MORE) FP PART 2609 PP=P+1+FROMAR2(P+1) 2610 P=P+3 2611 CFPDEL 2612 PTR=P 2613 {%UNTIL A(PTR-1)=2} %CYCLE; ! CYCLE DOWN NAMELIST 2614 %IF JJ#0 %THEN %START 2615 FROM12(JJ,J,JJJ); ! EXTRACT PTYPE XTRA INFO 2616 %UNLESS J>>16=PTYPE %AND(PTYPE#5 %OR JJJ>>16=ACC) %THEN FAULT2(9,CNT,KK) 2617 %FINISH %ELSE FAULT2(8,0,KK);! MORE FPS THAN IN SPEC 2618 PTR=PTR+3 2619 CNT=CNT+1 2620 MLINK(JJ) 2621 %REPEAT %UNTIL A(PTR-1)=2 2622 DECLARE SCALARS(0,0) 2623 P=PP 2624 %REPEAT; ! UNTIL NO MORE FP-PART 2625 N=(N+3)&(-4); ! TO WORD BOUNDARY AFTER ALL SYSTEM 2626 ! STANDARD PARAMETERS HAVE BEEN DECLARED 2627 FAULT2(10,0,KK) %UNLESS JJ=0 2628 PTYPE=PTYPEP 2629 %IF PTYPE&16_F0F=5 %THEN N=N+8;! STR FNS RESULT PARAM IS STACKED 2630 ! AS XTRA PARM JUST BEFORE DISPLAY 2631 RDISPLAY(KK) 2632 MAKE DECS(MARKER1+1) 2633 %END 2634 BEND: %END; ->CSSEXIT 2635 ! 2636 SW(13): !REALS(LN) 2637 FAULT(58,0) %UNLESS CPRMODE=0 2638 ALL LONG=A(P+1)&1;->CSSEXIT 2639 ! 2640 SW(14): !%BEGIN 2641 %BEGIN 2642 PTYPE=0 2643 %IF LEVEL=1 %AND RLEVEL=0 %AND CPRMODE=0 %START 2644 CODE DES(JJ) 2645 DEFINE EP(MAINEP, CA, JJ, 1) 2646 RLEVEL=1; RBASE=1 2647 L(1)=0; M(1)=0; DIAGINF(1)=0; AUXSBASE(1)=0 2648 CPRMODE=1 2649 N=24; NMAX=N 2650 FORGET(-1) 2651 DIAG POINTER(LEVEL+1) 2652 ! 2653 ! THE CODE PLANTED IS AS FOLLOWS:- 2654 ! STD (LNB+3) SAVE DESCRIPTOG TO GLA(PLT) 2655 ! LXN (LNB+4) TO GLA(PLT) 2656 ! STLN (XNB+5) SAVE LNB FOR STOP SEQUENCE 2657 ! ASF 1 FOR REPORT WORD 2658 ! 2659 PSF1(STD,1,12) 2660 PSF1(LXN,1,16) 2661 PF1(STLN,0,XNB,20) 2662 ! PSF1(ASF,0,1) 2663 ! 2664 ! THE NEXT 8 INSTRUCTIONS ARE REQUIRED TO SET SF 6 WORDS IN FRONT OF LNB 2665 ! AN ASF 1 WORKS AS WELL EXCEPT FOR K-STAND ALONE WHEN THERE MAY BE 2666 ! A USELESS REDUNDANT DESCRIPTOR ON THE STACK 2667 ! 2668 PF1(STLN,0,TOS,0) 2669 PF1(LSS,0,TOS,0) 2670 PSF1(IAD,0,24) 2671 PF1(STSF,0,TOS,0) 2672 PF1(ISB,0,TOS,0) 2673 PSF1(ISH,0,-2) 2674 PF1(ST,0,BREG,0) 2675 PF1(ASF,0,BREG,0) 2676 ! 2677 ! 2678 ! SET THE PROGRAM MASK TO MASK OUT UNDERFLOW AND ALLOW ALL OTHER INTS 2679 ! 2680 ! MPSR 16_40C0 2681 ! 2682 PF1(MPSR,0,0,16_40C0) 2683 PTYPE=1 2684 %FINISH %ELSE SET LINE; ! SO 'ENTERED FROM LINE' IS OK 2685 RHEAD(-1) 2686 RDISPLAY(-1) 2687 MAKE DECS(P+1) 2688 %END 2689 ->CSSEXIT 2690 ! 2691 SW(15): 2692 ! '%ON'(EVENT')(N)(NLIST)'%START' 2693 FAULT(57,0) %UNLESS LEVEL>=2 2694 FAULT(40,0) %IF NMDECS(LEVEL)&1#0 2695 NMDECS(LEVEL)=NMDECS(LEVEL)!16_11;! NO MORE DECS AND IN ONCOND 2696 %IF STACK=0 %THEN %START 2697 SAVE AUX STACK 2698 DISP=AUXSBASE(LEVEL) 2699 PSF1(LSS,2,DISP); ! SAVE TOP OF AUX STACK 2700 PSF1(ST,1,DISP+12) 2701 %FINISH 2702 GRUSE(ACCR)=0 2703 PSF1(CPSR,1,N+8) 2704 PLABEL=PLABEL-1 2705 JJJ=PLABEL 2706 ENTER JUMP(15,JJJ,B'10'); ! JUMP ROUND ON BODY 2707 ! 2708 P=P+2; JJ=0; ! SET UP A BITMASK IN JJ 2709 {%UNTIL A(P-1)=2} %CYCLE; ! UNTIL NO MORE NLIST 2710 KK=A(P) 2711 FAULT2(26,KK,0) %UNLESS 1<=KK<=14 2712 JJ=JJ!1<<(KK-1) 2713 P=P+2 2714 %REPEAT %UNTIL A(P-1)=2 2715 KK=CA; PGLA(4,4,ADDR(CA)) 2716 RELOCATE(GLACA-4,KK,1); ! ENTRY ADDRESS IN PLT 2717 ONWORD(LEVEL)=JJ<<18!(GLACA-4) 2718 FORGET(-1) 2719 PSF1(ST,1,N); ! STORE EVENT,SUBEVENT&LINE 2720 PSF1(MPSR,1,N+8) 2721 ONINF(LEVEL)=N; N=N+12 2722 %IF STACK=0 %THEN %START 2723 PSF1(LSS,1,DISP+12); ! RESET AUX STACK TOP 2724 PSF1(ST,2,DISP) 2725 %FINISH 2726 CSTART(0,3) 2727 NMDECS(LEVEL)=NMDECS(LEVEL)!!16_10;! NOT IN ONCOND 2728 JJ=ENTER LAB(JJJ,B'111'); ! REPLACE ENVIRONMENT 2729 ->CSSEXIT 2730 SW(16): 2731 FAULT(57,0) %UNLESS LEVEL>=2 2732 %BEGIN; ! %SWITCH (SWITCH LIST) 2733 %INTEGER Q,RANGE,KKK,KK,LB,PP,D0,D1,OPHEAD,V,ARRP,R 2734 Q=P 2735 ARRP=1 2736 %IF PARMOPT=0 %THEN ARRP=2 2737 {%UNTIL A(Q)=2} %CYCLE; ! UNTIL NO'REST OF SW LIST' 2738 P=P+3 2739 P=P+3 %WHILE A(P)=1 2740 P=P+4; ! TO P(+') 2741 KKK=INTEXP(LB); ! EXTRACT LOWER BOUND 2742 P=P+3 2743 KKK=KKK!INTEXP(KK); ! EXTRACT UPPER BOUND 2744 RANGE=(KK-LB+1) 2745 %IF RANGE<=0 %OR KKK#0 %START 2746 FAULT2(38,1-RANGE,FROMAR2(Q+1)) 2747 LB=0; KK=10; RANGE=11 2748 %FINISH 2749 %IF GLACA+8-4*LB<0 %THEN ARRP=1;! ZEROETH ELEMENT OFF FRONT 2750 PTYPE=16_56+ARRP<<8; ! WORD LABEL ARRAY 2751 PP=P; P=Q+1 2752 {%UNTIL A(P-1)=2} %CYCLE; ! DOWN NAMELIST 2753 K=FROM AR2(P) 2754 P=P+3 2755 OPHEAD=0; R=LB 2756 ! 2757 ! SET UP A BIT LIST (96 BITS PER CELL) TO CHECK FOR SWITCH LABELS 2758 ! SET TWICE 2759 ! 2760 {%UNTIL R>KK} %CYCLE 2761 PUSH(OPHEAD,0,0,0) 2762 R=R+96 2763 %REPEAT %UNTIL R>KK 2764 ! 2765 ! FOR CHECKING MODE USE A BOUNDED WORD DESCRIPTOR AND WORD SIZE 2766 ! ENTRIES PRESET TO "SW LABEL NOT SET". OPTIMISING USE BCI WORD 2767 ! ARRAYS WITH BASE SET TO ZEROETH ELEMENT 2768 2769 D1=(GLACA+15)&(-8); ! FIRST TABLE ENTRY 2770 D0=16_28000000!RANGE; ! SCALED WORD DES 2771 %IF ARRP=2 %THEN %START 2772 D0=D0!16_01000000 %UNLESS LB=0;! SET BCI BIT 2773 D1=D1-4*LB 2774 %FINISH 2775 PGLA(8,8,ADDR(D0)) 2776 SNDISP=GLACA>>2-2; ! WORD PLT DISP 2777 RELOCATE(GLACA-4,D1,2); ! RELOCATE RELATIVE TO GLA 2778 PUSH(OPHEAD,D1,LB,KK) 2779 KFORM=0; ACC=4 2780 J=1; STORE TAG(K,OPHEAD) 2781 ! 2782 !THE TABLE WILL CONSIST OF RELATIVE DISPLACEMENTS FROM THE TABLE HEAD 2783 ! TO THE LABEL POSN. SET ALL TO GO TO PLAB(6) INITIALLY 2784 ! 2785 V=PLABS(6) 2786 %CYCLE KKK=LB,1,KK 2787 RELOCATE(-1,V,1); ! PLABS(6) RELOCATED BY HD OF CODE 2788 %REPEAT 2789 %REPEAT %UNTIL A(P-1)=2; ! FOR ANY MORE NAMES IN NAMELIST 2790 Q=PP; P=Q 2791 %REPEAT %UNTIL A(Q)=2; ! UNTIL A(Q)=2 2792 %END;->CSSEXIT 2793 ! 2794 SW(17): LIST=1; ->CSSEXIT 2795 ! 2796 SW(12): ! '%OWN' (TYPE)(OWNDEC) 2797 %BEGIN 2798 !*********************************************************************** 2799 !* INITIALISED DECLARATION GO INTO THE GLA OR GLA SYMBOL TABLES * 2800 !* EXCEPT FOR CONST ARRAYS WHICH GO INTO THE CODE SYMBOL TABLES * 2801 !* STRINGS AND ARRAYS HAVE A HEADER IN THE GLA. LPUT ARRANGES * 2802 !* FOR THE LOADER TO RELOCATE THE HEADERS. * 2803 !* EXTERNALS ARE IDENTICAL WITH OWN BUT ALSO HAVE A DATA EP DEFN * 2804 !* IN THE LOAD DATA SO THEY CAN BE FOUND AT LOAD TIME * 2805 !* EXTRINSICS HAVE A DATA REFERENCE AND A DUMMY HEADER IN THE GLA * 2806 !* THE LOADER USES THE FORMER TO RELOCATE THE LATTER. * 2807 !*********************************************************************** 2808 %ROUTINESPEC CLEAR(%INTEGER L) 2809 %ROUTINESPEC STAG(%INTEGER J,DATALEN) 2810 %ROUTINESPEC XTRACT CONST(%INTEGER CONTYPE,CONPREC) 2811 %ROUTINESPEC INIT SPACE(%INTEGER A,B) 2812 %INTEGER LENGTH,BP,PP,SIGN,CBASE,MODE,UICONST,ICONST,TAGDISP,EPTYPE, {%C 2813+ EPDISP,AH1,AH2,AH3,AH4,AD,FNAM,FINF,SPOINT,CONSTSFOUND,CPREC,{%C 2814+ EXTRN,NNAMES,MARK,LPUTP,MARKER1,LB,CTYPE,CONSTP,FORMAT, {%C 2815+ PTSIZE,DIMEN,SACC,TYPEP 2816 %LONGREAL RCONST,LRCONST 2817 %OWNLONGREAL ZERO=0 2818 %STRING(255) SCONST,NAMTXT 2819 %INTEGERNAME STPTR 2820 LPUTP=5; STPTR==USTPTR; ! NORMAL CASE GLA SYMBOLTABLES 2821 ! FAULT(40,0) %IF NMDECS&1#0 2822 EXTRN=A(P+1) 2823 %IF EXTRN>=4 %THEN EXTRN=0; ! CONST & CONSTANT->0 2824 LITL=EXTRN 2825 %IF LITL<=1 %THEN LITL=LITL!!1 2826 KFORM=0; SNDISP=0 2827 CONSTS FOUND=0 2828 %IF EXTRN=0 %THEN LPUTP=4 %AND STPTR==SSTL 2829 P=P+3; CBASE=0 2830 MODE=A(P-1); ! MODE =1 FOR NORMAL OWNS 2831 ->RECORD %IF MODE>1; ! MODE =2 FOR OWN RECORDS 2832 CLT; ! MODE =3 FOR OWN RECORD ARRAYS 2833 %IF A(P)=1 %THEN CQN(P+1) %ELSE ARR=1 %AND NAM=0 2834 %IF TYPE=5 %AND ACC=0=NAM %THEN FAULT(70,0) %AND ACC=2 2835 ROUT=0; PACK(PTYPE) 2836 -> NON SCALAR %IF ARR#0 %AND NAM=0 2837 P=P+1 2838 {%UNTIL A(MARK)=2} %CYCLE; ! UNTIL NULL 2839 MARK= P+1+FROM AR2(P+1) 2840 NNAMES=1 2841 PP=P+3; P=PP+2; ! PP ON FIRST NAME' 2842 %WHILE A(P)=1 %%CYCLE 2843 NNAMES=NNAMES+1 2844 P=P+3 2845 %REPEAT 2846 P=P+1; ! P ON CONST' 2847 ! 2848 ! OBTAIN THE INITIAL CONSTANT,ITS TYPE(CTYPE) AND SIGN(SIGN) 2849 ! 2850 ICONST=0; UICONST=0 2851 RCONST=0; LRCONST=0; SCONST="" 2852 SIGN=3; CTYPE=TYPE; CONSTSFOUND=0; CPREC=PREC 2853 %IF NAM#0 %THEN CTYPE=1 %AND CPREC=5 2854 ! 2855 %IF A(P)=1 %THEN %START; ! CONSTANT GIVEN 2856 P=P+1 2857 XTRACT CONST(CTYPE,CPREC) 2858 %FINISH 2859 ! 2860 {%UNTIL NNAMES=0} %CYCLE; ! DOWN 2861 J=0; K=FROM AR2(PP) 2862 NAMTXT=STRING(DICTBASE+WORD(K)) 2863 %IF NAM#0 %THEN %START; ! OWNNAMES AND ARRAYNAMES 2864 %IF EXTRN=3 %THEN FAULT2(46,0,K);! NO EXTRINSIC NAMES 2865 UICONST=16_FFFF!PREC<<27 2866 PGLA(8,ACC,ADDR(UICONST)) 2867 TAGDISP=GLACA-ACC; EPDISP=TAGDISP 2868 %FINISH %ELSE %START 2869 %IF TYPE=5 %THEN %START; ! STRING 2870 QQ=STPTR; AD=ADDR(SCONST) 2871 %IF EXTRN=3 %THEN %START; ! EXTRINSIC STRINGS 2872 AH3=0; AH2=PREC<<27!ACC; ! DUMMY STRING HEADER 2873 %FINISH %ELSE %START 2874 LPUT(LPUTP,ACC,QQ,AD) %IF INHCODE=0;! O/P STRING 2875 STPTR=(STPTR+ACC+3)&(-4) 2876 AH3=QQ; AH2=3<<27!ACC 2877 %FINISH 2878 PGLA(8,8,ADDR(AH2)) 2879 TAGDISP=GLACA-8 2880 %IF EXTRN=3 %THEN GXREF(NAMTXT,2,2<<24!ACC,TAGDISP+4) %ELSE RELOCATE(TAGDISP+4,AH3,LPUTP) 2881 EPTYPE=5; EPDISP=QQ; ! DATA IN GLA SYMBOL TABLES 2882 %FINISH %ELSE %START; ! INTEGER & REAL 2883 %IF EXTRN=3 %THEN %START; ! EXTRINSICS 2884 PTYPE=PTYPE!1<<10; ! EXTRINSICS VIA PTR 2885 AH2=PREC<<27; AH3=0 2886 PGLA(8,8,ADDR(AH2)) 2887 TAGDISP=GLACA-8 2888 GXREF(NAMTXT,2,2<<24!ACC,TAGDISP+4) 2889 %FINISH %ELSE %START; ! OWN,EXTERNAL&CONST 2890 %IF TYPE=2 %THEN %START 2891 AD=ADDR(RCONST) 2892 %FINISH %ELSE %START; ! INTEGER VARIABLES 2893 AD=ADDR(ICONST)+4-ACC 2894 %FINISH 2895 %IF EXTRN#0 %THEN PGLA(ACC,ACC,AD); ! PUT CONSTANT INTO GLA 2896 TAGDISP=GLACA-ACC; ! OFFSET OF VAR FOR TAGS 2897 EPDISP=TAGDISP; ! AND FOR ENTRY DEFN 2898 EPTYPE=2; ! DATA IN ADRESSABLE GLA 2899 %FINISH 2900 %FINISH 2901 %FINISH 2902 STAG(TAGDISP,ACC) 2903 %IF EXTRN=0=NAM %START; ! CONST = LITERAL 2904 REPLACE2(TAGS(K),INTEGER(AD&(-4)));! BYTES! 2905 %IF PREC=6 %THEN REPLACE3(TAGS(K),INTEGER(AD+4)) 2906 %IF PREC=7 %THEN REPLACE3(TAGS(K),CONSTP) 2907 %FINISH 2908 PP=PP+3 2909 NNAMES=NNAMES-1 2910 %REPEAT %UNTIL NNAMES=0; ! DOWN 2911 P=MARK 2912 %REPEAT %UNTIL A(MARK)=2; ! UNTIL NULL 2913 ->BEND 2914 RECORD: ! '%RECORD' 2915 !*********************************************************************** 2916 !* NO INITIALISATION OF OWN RECORDS ALLOWED SO THEY ARE ALL * 2917 !* CLEARED TO ZERO. * 2918 !*********************************************************************** 2919 MARKER1=P+1+FROM AR2(P+1); ! TO FORMAT NAME 2920 FNAM=FROM AR2(MARKER1) 2921 COPYTAG(FNAM) 2922 FINF=TCELL 2923 %IF PTYPE#4 %THEN FAULT(62,FNAM) %AND ->BEND 2924 PTYPE=16_133!LITL<<14 2925 KFORM=FINF; UNPACK 2926 %IF MODE=3 %THEN FORMAT=2-A(P) %AND P=P+2 %AND ->RECIN 2927 P=P+1; BP=ACC; ! SIZE OF RECORD FROM FORMAT 2928 PTYPE=16_33; J=0 2929 %IF A(P-1)#3 %THEN CQN(P-1) %AND PACK(PTYPE) 2930 P=P+1; PTSIZE=ACC; ! SIZE OF HOLE FOR POINTER 2931 {%UNTIL A(P)=2} %CYCLE 2932 P=P+1; K=FROM AR2(P) 2933 NAMTXT=STRING(DICTBASE+WORD(K)) 2934 %IF NAM#0 %THEN %START; ! OWNNAMES AND ARRAYNAMES 2935 %IF EXTRN=3 %THEN FAULT2(46,0,K);! NO EXTRINSIC NAMES 2936 UICONST=16_FFFF!PREC<<27 2937 PGLA(8,PTSIZE,ADDR(UICONST)) 2938 EPTYPE=2 2939 TAGDISP=GLACA-PTSIZE; EPDISP=TAGDISP 2940 %FINISH %ELSE %START 2941 %IF EXTRN=3 %THEN %START; ! EXTRINISIC 2942 PTYPE=PTYPE!16_400; ! FORCE NAM=1 (IE VIA POINTER) 2943 AH2=16_18000000+BP 2944 AH3=0 2945 PGLA(8,8,ADDR(AH2)) 2946 TAGDISP=GLACA-8 2947 GXREF(NAMTXT,2,2<<24!BP,TAGDISP+4); ! RELOCATE BY EXTERNAL 2948 %FINISH %ELSE %START 2949 EPDISP=(GLACA+15)&(-8) 2950 AH3=EPDISP 2951 AH2=16_18000000+BP; ! TOP WORD OFDESRCIPTOR 2952 PGLA(8,4,ADDR(AH2)); ! ADDED 18MAR76 TO FIX BUG 2953 RELOCATE(-1,AH3,2); ! PUT DISP INTO GLA 2954 TAGDISP=EPDISP; ! AND RELOCATE REL APPROPIATE AREA 2955 EPTYPE=2; ! DATA IN GLA TABLES 2956 I=0; ICONST=0 2957 %WHILE IBEND 2968 NONSCALAR: ! OWN AND OWNRECORD ARRAYS 2969 !*********************************************************************** 2970 !* OWN ARRAYS CAN BE INITIALISED BUT ONLY ONE ARRAY CAN BE * 2971 !* DECLARED IN A STATEMENT.(THANK HEAVENS!) * 2972 !* OWN RECORD ARRAYS ARE CLEARED TO ZERO * 2973 !*********************************************************************** 2974 P=P+1 2975 FORMAT=2-A(P) 2976 RECIN: PP=P+1; P=P+3; NNAMES=1 2977 K=FROM AR2(PP) 2978 NAMTXT=STRING(DICTBASE+WORD(K)) 2979 %IF TYPE>=3 %THEN BP=ACC %ELSE BP=BYTES(PREC) 2980 SACC=ACC; TYPEP=PTYPE 2981 AH4=12+DOPE VECTOR(TYPE,BP,0,K,QQ,LB) 2982 SNDISP=AH4-12; ! DV DISP (+TOP BIT FLAG) 2983 %IF SNDISP=-1 %THEN SNDISP=0; ! BUM DOPE VECTOR 2984 SNDISP=(SNDISP&16_3FFFF)>>2; ! AS WORD DISPLACEMENT 2985 DIMEN=J; ! SAVE NO OF DIMENESIONS 2986 ACC=SACC; PTYPE=TYPEP; UNPACK 2987 %IF LB=0 %AND J=1 %AND TYPE<=3 %THEN ARR=2 %AND PACK (PTYPE) 2988 LENGTH=QQ//BP; ! NO OF ELEMENTS 2989 SPOINT=STPTR 2990 %IF MODE#3 %AND FORMAT=0 %THEN %START; ! NOT A RECORD ARRAY 2991 %IF A(P)=1 %THEN P=P+1 %AND INIT SPACE(QQ,LENGTH) 2992 %FINISH 2993 %IF CONSTS FOUND=0 %THEN %START;! NO CONSTANTS GIVEN 2994 ! SO CLEAR AN AREA TO ZERO 2995 CONSTS FOUND=LENGTH 2996 CLEAR(QQ) %UNLESS LENGTH<1 %OR EXTRN=3 %OR FORMAT#0 2997 %FINISH %ELSE %START 2998 FAULT2(49,0,K) %IF EXTRN=3 %OR FORMAT#0 2999 %FINISH 3000 %IF EXTRN=3 %THEN EPDISP=0 %ELSE EPDISP=SPOINT 3001 ! 3002 ! OUTPUT AN ARRAYHEAD INTO THE GLA RELATIVE TO THE START OF THE SYMBOL- 3003 ! TABLES IN WHICH THE ARRAY RESIDES. 3004 ! 3005 J=DIMEN; ! RESET DIMENSIONS AFTER INITTING 3006 %IF TYPE<=2 %THEN AH1=PREC<<27!LENGTH %ELSE AH1=3<<27!1<<25!QQ 3007 AH1=AH1!(1-PARMARR)<<24; ! SET BCI IF BASE TO BE SHIFTED 3008 %IF PREC=4 %THEN AH1=16_58000002 3009 AH2=EPDISP 3010 AH3=5<<27!3*J; ! DV DESPTR = WORD CHKD 3011 %IF TYPE<=3 %AND PARMARR=0=FORMAT %AND PARMCHK=0 %AND J=1 %THEN AH2=AH2-BP*LB 3012 PGLA(8,16,ADDR(AH1)) 3013 TAGDISP=GLACA-16 3014 %IF EXTRN=3 %THEN %START; ! EXTRINSIC ARRAYS 3015 GXREF(NAMTXT,2,2<<24!QQ,TAGDISP+4); ! RELOCATE ADDR(A(FIRST)) 3016 %FINISH %ELSE %START 3017 RELOCATE(TAGDISP+4,AH2,LPUTP);! RELOCATE ADDR(A(FIRST)) 3018 %FINISH 3019 RELOCATE(TAGDISP+12,AH4,1); ! RELOCATE DV POINTER 3020 AH4=(AH4<<1>>3)!16_80000000 3021 NOTE CREF(AH4!(TAGDISP+12)>>2<<16,(AH4&16_FFFF)<<2) 3022 EPTYPE=5; ! DATA IN GLA SYMBOL TABLES 3023 STAG(TAGDISP,QQ) 3024 -> BEND 3025 %ROUTINE INIT SPACE(%INTEGER SIZE,NELS) 3026 !*********************************************************************** 3027 !* P IS TO FIRST ENTRY FOR CONSTLIST * 3028 !* MAP SPACE ONTO WORKFILE END TO GIVE SANE ERROR MESSAGE IF * 3029 !* THERE WAS NOT ENOUGH SPACE * 3030 !*********************************************************************** 3031 %INTEGER RF,I,K,ELSIZE,AD,SPP,LENGTH,SAVER,WSIZE,WRIT 3032 {%BYTEINTEGERARRAYNAME SP 3033 3034 %IF SIZE>4096 %THEN WSIZE=4096 %ELSE WSIZE=SIZE 3035 {%BYTEINTEGERARRAYFORMAT SPF(0:WSIZE+256) 3036 SAVER=R; R=R+WSIZE+256 3037 %IF R>ARSIZE %THEN FAULT(102,0) 3038 %byteintegerarray SP(0:WSIZE+256) 3039 {SP==ARRAY(ADDR(A(SAVER)),SPF) 3040 %IF TYPE=1 %THEN AD=ADDR(ICONST)+4-ACC 3041 %IF TYPE=2 %THEN AD=ADDR(RCONST) 3042 %IF TYPE=5 %THEN AD=ADDR(SCONST) 3043 SPP=0; WRIT=0 3044 ELSIZE=SIZE//NELS 3045 {%UNTIL A(P-1)=2} %CYCLE 3046 XTRACT CONST(TYPE,PREC) 3047 %IF A(P)=1 %START; ! REPITITION FACTOR 3048 P=P+1 3049 %IF INTEXP(RF)#0 %THEN FAULT(44,CONSTS FOUND) %AND RF=1 3050 P=P+1 3051 %FINISH %ELSE RF=1 %AND P=P+2 3052 FAULT(44,CONSTS FOUND) %IF RF<=0 3053 %CYCLE I=RF,-1,1 3054 %CYCLE K=0,1,ELSIZE-1 3055 %IF CONSTS FOUND<=NELS %THEN SP(SPP)=BYTE INTEGER(AD+K) %AND SPP=SPP+1 3056 %REPEAT 3057 CONSTS FOUND=CONSTS FOUND+1 3058 %IF SPP>=4096 %START; ! EMPTY BUFFER 3059 LPUT(LPUTP,SPP,STPTR+WRIT,ADDR(SP(0))) %IF INHCODE=0 3060 WRIT=WRIT+SPP 3061 SPP=0 3062 %FINISH 3063 %REPEAT 3064 %REPEAT %UNTIL A(P-1)=2; ! UNTIL P=%NULL 3065 %IF CONSTS FOUND#NELS %THEN FAULT(45,CONSTS FOUND) 3066 STPTR=(STPTR+3)&(-4) 3067 LENGTH=(SIZE+3)&(-4) 3068 LPUT(LPUTP,LENGTH-WRIT,STPTR+WRIT,ADDR(SP(0))) %IF INHCODE=0 3069 STPTR=STPTR+LENGTH 3070 R=SAVER 3071 %END 3072 %ROUTINE CLEAR(%INTEGER LENGTH) 3073 STPTR=(STPTR+3)&(-4) 3074 LENGTH=(LENGTH+3)&(-4) 3075 LPUT(LPUTP,LENGTH,STPTR,0)%IF INHCODE=0 3076 STPTR=STPTR+LENGTH 3077 %END 3078 %ROUTINE STAG(%INTEGER J,DATALEN) 3079 %IF EXTRN=2 %THEN LPUT(14,EPTYPE<<24!DATALEN,EPDISP,ADDR(NAMTXT)) 3080 RBASE=CBASE 3081 STORE TAG(K,J) 3082 RBASE=RLEVEL 3083 %END 3084 %ROUTINE XTRACT CONST(%INTEGER CONTYPE,CONPREC) 3085 !*********************************************************************** 3086 !* P POINTS TO P<+'> OF <+'> AND IS UPDATED* 3087 !* THE CONST IS CONVERTED TO REQUIRED FORM AND IF INTEGER * 3088 !* IS LEFT IN ICONST, IF REAL IN RCONST AND IF STRING IN SCONST * 3089 !*********************************************************************** 3090 %INTEGER LENGTH,STYPE,SPREC,SACC,CPREC,MODE,I 3091 STYPE=PTYPE; SACC=ACC;! MAY BE CHANGED IF CONST IS EXPR 3092 %IF CONTYPE=5 %THEN %START 3093 CTYPE=5 3094 %IF A(P)=4 %AND A(P+1)=2 %AND A(P+2)=16_35 %AND A(P+A(P+7)+8)=2 %START 3095 SCONST=STRING(ADDR(A(P+7))) 3096 LENGTH=A(P+7) 3097 P=P+A(P+7)+9 3098 %FINISH %ELSE %START 3099 FAULT(44,CONSTS FOUND); SCONST="" 3100 LENGTH=0; P=P-3; SKIP EXP 3101 %FINISH 3102 %FINISH %ELSE %START 3103 MODE=CONPREC<<4!CONTYPE 3104 %IF CONPREC<5 %THEN MODE=CONTYPE!16_50 3105 CONSTP=CONSTEXP(MODE) 3106 %IF CONSTP=0 %THEN FAULT(41,0) %AND CONSTP=ADDR(ZERO);! CANT EVALUATE EXPT 3107 CTYPE=TYPE; CPREC=PREC 3108 %IF CTYPE=1 %THEN %START 3109 ICONST=INTEGER(CONSTP) 3110 %IF CONPREC=6 %THEN UICONST=ICONST %AND ICONST=INTEGER(CONSTP+4) 3111 %FINISH %ELSE %START 3112 RCONST=LONGREAL(CONSTP) 3113 %IF CONPREC=7 %THEN %START;! LONGLONGS UNALIGNED IN AR 3114 %CYCLE I=0,1,15 3115 BYTEINTEGER(ADDR(RCONST)+I)=BYTEINTEGER(CONSTP+I) 3116 %REPEAT 3117 %FINISH 3118 %FINISH 3119 %FINISH 3120 PTYPE=STYPE; UNPACK; ACC=SACC 3121 ! 3122 ! FAULT ANY OBVIOUS ERRORS IE:- 3123 ! CONSTANT FOR EXTRINSIC OR INCOMPATIBLE TYPE OR STRING TOO LONG 3124 ! 3125 %IF EXTRN=3 %OR (CTYPE=5 %AND LENGTH>=ACC) %OR (CONTYPE=1 %AND ((CONPREC=3 %AND ICONST>255) %OR (CONPREC=4 %AND ICONST>16_FFFF))) %THEN FAULT(44,CONSTS FOUND) 3126 %END ?SPREC unused 3127 BEND: %END; ->CSSEXIT 3128 SW(18): 3129 ABORT 3130 SW(10): 3131 %BEGIN; ! %RECORD (RDECLN) 3132 !*********************************************************************** 3133 !* RECORDS ARE ALLOCATED AT COMPILE TIME WHEN POSSIBLE * 3134 !* SEE CRFORMAT FOR ACTION ON RECORD FORMAT DECLARATIONS * 3135 !*********************************************************************** 3136 %INTEGER MODE,RECL,ALLOC,FNAM,FINF,NAME,OPHEAD 3137 P=P+1; MODE=A(P); SNDISP=0 3138 %IF MODE=1 %THEN %START; ! DEAL WITH FORMAT 3139 NAME=FROM AR2(P+1); P=P+3 3140 CRFORMAT(OPHEAD); K=NAME 3141 PTYPE=4; J=0 3142 KFORM=OPHEAD 3143 STORE TAG(K,OPHEAD) 3144 ->BEND 3145 %FINISH 3146 P=P+1; MARKER=P+FROM AR2(P) 3147 FNAM=FROM AR2(MARKER); ! FORMAT NAME 3148 COPY TAG(FNAM) 3149 FINF=TCELL 3150 %IF TYPE#4 %THEN %START 3151 FINF=DUMMY FORMAT 3152 ACC=4; FAULT(62,FNAM) 3153 %FINISH 3154 RECL=ACC 3155 %IF MODE=2%THEN %START; ! '%RECORDSPEC' 3156 COPY TAG(FROM AR2(P+2)) 3157 %IF A(P+4)=1 %AND TYPE=4 %START;! SPEC FOR FORMAT ELEMENT 3158 P=P+5 3159 Q=DISPLACEMENT(TCELL) 3160 UNPACK 3161 %FINISH 3162 %IF TYPE=3 %AND NAM=1 %AND FROM3(TCELL)&16_FFFF=0 %START 3163 REPLACE3(TCELL,FINF!K<<16) 3164 REPLACE2(TCELL,SNDISP<<16!RECL) 3165 %FINISH %ELSE FAULT(63,0) 3166 %FINISH %ELSE %START; ! RECORD DECLARATION 3167 FAULT(57,0) %UNLESS LEVEL>=2 3168 FAULT(40,0) %IF NMDECS(LEVEL)&1#0 3169 TYPE=3; PREC=3; ROUT=0 3170 %IF A(P+2)=1 %THEN %START; ! SIMPLE RECORD AND RECORDNAMES 3171 ALLOC=ACC; CQN(P+3) 3172 ACC=ALLOC; P=P+4 3173 DECLARE SCALARS(1,FINF) 3174 %FINISH %ELSE %START; ! ARRAYS OF RECORDS 3175 NAM=0 3176 Q=2-A(P+3); P=P+4; ! Q=1 FOR ARRAY FORMAT 3177 SET LINE 3178 DECLARE ARRAYS(Q,FINF) 3179 %FINISH 3180 %FINISH 3181 BEND: %END;->CSSEXIT 3182 ! 3183 SW(19): 3184 ! '*' (UCI) (S) 3185 FAULT(57,0) %UNLESS LEVEL>=2 3186 %BEGIN 3187 %ROUTINESPEC CIND 3188 %INTEGER FNAME,ALT,OPCODE,FORM,H,Q,MASK,FILLER 3189 %SWITCH SW(1:5),F(1:3),POP(1:6),TOP(1:4) 3190 ALT=A(P+1); P=P+2 3191 OPCODE=CALL 3192 ->SW(ALT) 3193 SW(1):SW(2): 3194 FNAME=FROM AR2(P) 3195 COPY TAG(FNAME) 3196 FAULT(33,FNAME) %UNLESS ROUT=NAM=0 %AND ARR=0 %AND PREC>4 %AND I=RBASE %AND TYPE#7 3197 %IF ALT=1 %THEN PSF1(ST,1,K) %ELSE GET IN ACC(ACCR,BYTES(PREC)>>2,0,LNB,K) 3198 ->EXIT 3199 SW(3): ! PUT (HEX HALFWORD) 3200 TYPE=A(P) 3201 PREC=TYPE>>4; TYPE=TYPE&7 3202 FAULT(32,0) %UNLESS TYPE=1 %AND PREC<6 3203 %IF PREC=5 %THEN P=P+2 3204 PLANT(FROM AR2(P+1)) 3205 ->EXIT 3206 SW(5): ! CNOP 3207 CNOP(A(P),A(P+1)) 3208 ->EXIT 3209 SW(4): ! ASSEMBLER 3210 FORM=A(P); ! FORM=PRIMARY,SECONDARY OR 3RY 3211 OPCODE=A(P+1) 3212 P=P+2; ->F(FORM) 3213 F(1): ! ALL PRIMARY FORMAT INSTRUCTIONS 3214 ALT=A(P); P=P+1 3215 ->POP(ALT) 3216 POP(1): ! LABELNAME 3217 FNAME=FROM AR2(P); P=P+2 3218 ENTER JUMP(OPCODE<<24!3<<23,FNAME,0) 3219 ->EXIT 3220 POP(2): ! DIRECT SYMBOLIC 3221 CIND 3222 POPI: PSORLF1(OPCODE,ACCESS,AREA,DISP) 3223 ->EXIT 3224 POP(3): ! INDIRECT SYMBOLIC 3225 CIND 3226 ACCESS=4-A(P); P=P+1 3227 ->POPI 3228 POP(4): ! DR SYMBOLICALLY MODIFIED 3229 CIND; ACCESS=1; ->POPI 3230 POP(5): ! (DR) & (DR+B) 3231 ACCESS=4-A(P); AREA=7 3232 DISP=0; P=P+1 3233 ->POPI 3234 POP(6): ! B 3235 ACCESS=0 3236 AREA=7; DISP=0; ->POPI 3237 F(2): ! SECONDARY (STORE-TO STORE)FORMAT 3238 MASK=0; FILLER=0; Q=0; FNAME=0 3239 H=2-A(P) 3240 %IF H=0 %THEN FNAME=FROM AR2(P+1)-1 %AND P=P+2 3241 FAULT(32,0) %UNLESS 0<=FNAME<=127 3242 ALT=A(P+1); P=P+2 3243 %IF ALT=1 %THEN %START 3244 Q=1 3245 MASK=FROM AR2(P) 3246 FILLER=FROM AR2(P+2) 3247 P=P+4 3248 FAULT(32,0) %UNLESS 0<=MASK!FILLER<=255 3249 %FINISH 3250 PF2(OPCODE,H,Q,FNAME,MASK,FILLER) 3251 ->EXIT 3252 F(3): ! TERTIARY FORMAT 3253 MASK=FROM AR2(P) 3254 ALT=A(P+2) 3255 FAULT(32,0) %UNLESS 0<=MASK<=15 3256 P=P+3; ->TOP(ALT) 3257 TOP(1): ! LABEL 3258 FNAME=FROM AR2(P); P=P+2 3259 ENTER JUMP(OPCODE<<24!MASK<<21,FNAME,0) 3260 ->EXIT 3261 TOP(2): ! SYMBOLIC OPERAND 3262 CIND 3263 FAULT(32,0) %IF AREA>=6 3264 %IF AREA=LNB %OR AREA=XNB %OR AREA=CTB %THEN DISP=DISP//4 3265 TOPI: PF3(OPCODE,MASK,AREA,DISP) 3266 ->EXIT 3267 TOP(3): ! (DR) & (DR+B) 3268 DISP=0; AREA=8-A(P) 3269 P=P+1; ->TOPI 3270 TOP(4): ! (DR+N) 3271 DISP=FROM AR2(P); P=P+2 3272 AREA=1; ->TOPI 3273 %ROUTINE CIND 3274 !*********************************************************************** 3275 !* COMPILE A SYMBOLIC OPERAND BY SETTING ACCESS,AREA &DISP * 3276 !*********************************************************************** 3277 %INTEGER ALT,AFN,FN0,FN1,FN2,FN3,JJ,D,CTYPE,CPREC 3278 %SWITCH SW(1:4) 3279 AFN=ADDR(FN0) 3280 ALT=A(P); ACCESS=0 3281 P=P+1; ->SW(ALT) 3282 SW(1): ! (=')(PLUS')(ICONST) 3283 P=P+1; ! PAST (=') 3284 D=A(P); CTYPE=A(P+1) 3285 CPREC=CTYPE>>4; CTYPE=CTYPE&7 3286 %IF CPREC=4 %THEN FN0=FROM AR2(P+2) %ELSE %START 3287 %CYCLE JJ=0,1,BYTES(CPREC)-1 3288 BYTEINTEGER(AFN+JJ)=A(P+JJ+2) 3289 %REPEAT 3290 %FINISH 3291 P=P+2+BYTES(CPREC) 3292 %IF D=2 %THEN %START 3293 %IF CTYPE=2 %THEN FN0=FN0!!16_80000000 %ELSE %START 3294 %IF CPREC=6 %THEN LONGINTEGER(AFN)=-LONGINTEGER(AFN) %ELSE FN0=-FN0 3295 %FINISH 3296 %FINISH 3297 CNST: ->LIT %UNLESS CTYPE=1 %AND CPREC<=5 %AND 16_FFFE0000<=FN0<=16_1FFFF 3298 AREA=0; DISP=FN0 3299 %RETURN 3300 LIT: FAULT(32,0) %UNLESS 1<=CTYPE<=2 %AND 5<=CPREC<=7 3301 STORE CONST(DISP,BYTES(CPREC),AFN) 3302 AREA=PC; ACCESS=0 3303 %RETURN 3304 SW(2): ! (NAME)(OPTINC) 3305 FN0=FROM AR2(P); P=P+2 3306 COPY TAG(FN0) 3307 %IF (LITL=1 %AND ARR=0) %START 3308 CTYPE=TYPE; CPREC=PREC 3309 ALT=TAGS(FN0) 3310 FROM123(ALT,D,FN0,FN1) 3311 %IF CPREC=7 %THEN AFN=FN1 3312 ->CNST 3313 %FINISH 3314 %IF TYPE>=6 %OR TYPE=4 %OR (ROUT=1 %AND NAM=0) %THEN FAULT(33,FN0) %AND %RETURN 3315 %IF ROUT=1 %THEN K=FROM1(K) 3316 AREA=LNB 3317 %IF I#RBASE %THEN AREA=SET XORYNB(XNB,I) 3318 ALT=A(P); D=FROM AR2(P+1) 3319 %IF ALT=1 %THEN K=K+D 3320 %IF ALT=2 %THEN K=K-D 3321 P=P+1; P=P+2 %IF ALT<=2 3322 DISP=K; %RETURN 3323 SW(3): ! '('(REG)(OPTINC)')' 3324 AREA=A(P)+1; ALT=A(P+1); P=P+2 3325 DISP=0 3326 D=FROM AR2(P) 3327 %IF ALT=1 %THEN DISP=D 3328 %IF ALT=2 %THEN FAULT(32,0) 3329 %IF AREA=PC %THEN DISP=CA+2*DISP %ELSE DISP=4*DISP 3330 P=P+2 %UNLESS ALT=3 3331 %RETURN 3332 SW(4): ! '%TOS' 3333 AREA=6; DISP=0 3334 %END ?FN3 unused ?FN2 unused 3335 EXIT: GRUSE(ACCR)=0 3336 GRUSE(DR)=0 3337 GRUSE(BREG)=0 3338 GRUSE(XNB)=0 %IF OPCODE=CALL %OR OPCODE=LXN %OR OPCODE=JLK %OR OPCODE=OUT 3339 GRUSE(CTB)=0 %IF OPCODE=CALL %OR OPCODE=LCT %OR OPCODE=JLK %OR OPCODE=OUT 3340 %END 3341 ->CSSEXIT 3342 SW(20): 3343 ! '%TRUSTEDPROGRAM' 3344 COMPILER=1 %IF PARMARR=0 %AND PARMCHK=0; ->CSSEXIT 3345 SW(21): ! '%MAINEP'(NAME) 3346 KK=FROM AR2(P+1) 3347 FAULT(58,0) %UNLESS CPRMODE=0 3348 MAINEP<-STRING(DICTBASE+WORD(KK)) 3349 ->CSSEXIT 3350 %ROUTINE CRFORMAT(%INTEGERNAME OPHEAD) 3351 !*********************************************************************** 3352 !* CONVERTS A RECORDFORMAT STATEMENT TO A LIST HEADED BY OPHEAD * 3353 !* FORMAT OF AN ENTRY. * 3354 !* S1=SUBNAME<<20!PTYPE<<4!J * 3355 !* S2,S3=4 16 BIT DISPLACEMENTS D2,ACC,D1,KFORM * 3356 !* NORMALLY D1=RECORD RELATIVE DISPLACEMENT AND ACC=LMAX(STRINGS)* 3357 !* FOR ARRAYS D2=FIRST ELEMENT DISPLACEMENT AND D1=DISPLACEMENT * 3358 !* OF RECORD RELATIVE ARRAYHEAD IN THE GLA * 3359 !* KFORM IS ONLY USED FOR RECORDS AND POINTS TO THE FORMAT * 3360 !* ON EXIT ACC HAS THE RECORD SIZE ROUNDED UP TO THE BOUNDARY * 3361 !* REQUIRED BY ITS LARGEST COMPONENT * 3362 !*********************************************************************** 3363 %INTEGER D1,D2,NLIST,FORM,RL,MRL,UNSCAL,SC,DESC,FN,INC,Q,R,A0,A1,A2,DV,RFD,LB,OB,TYPEP,SACC 3364 %SWITCH RFEL(1:5) 3365 %ROUTINESPEC SN(%INTEGER Q) 3366 %ROUTINESPEC ROUND 3367 NLIST=0; OPHEAD=0; FORM=0; ACC=0; OB=0 3368 MRL=0; INC=0; ! INC COUNTS DOWN RECORD 3369 NEXT: ROUT=0; LITL=0; NAM=0; RFD=A(P) 3370 %IF RFD<=2 %THEN P=P+1 %AND CLT 3371 ->RFEL(RFD) 3372 RFEL(1): ! (TYPE) (QNAME')(NAMELIST) 3373 CQN(P); P=P+1 3374 PACK(PTYPE); D2=0 3375 RL=3 3376 %IF NAM=0 %AND 3<=PREC<=4 %THEN RL=PREC-3 3377 AGN: ROUND ; J=0 3378 {%UNTIL A(P-1)=2} %CYCLE 3379 D1=INC; SN(P) 3380 P=P+3; INC=INC+ACC 3381 %REPEAT %UNTIL A(P-1)=2 3382 P=P+RFD>>2<<1; ! EXTRA 2 FOR RECORDS TO SKIP FORMAT 3383 TRY END: -> END %IF A(P)=2 3384 P=P+1; -> NEXT 3385 RFEL(2):RFEL2: ! (TYPE)%ARRAY(NAMELIST)(BPAIR) 3386 Q=P; ARR=1; PACK(PTYPE) 3387 %IF TYPE<=2 %THEN UNSCAL=0 %AND SC=PREC %ELSE UNSCAL=1 %AND SC=3 3388 %IF PREC=4 %THEN DESC=16_58000002 %ELSE DESC=SC<<27!UNSCAL<<25!(1-PARMARR)<<24 3389 {%UNTIL A(P-1)=2} %CYCLE; ! UNTIL NULL 3390 P=P+3 %UNTIL A(P-1)=2 3391 3392 TYPEP=PTYPE; SACC=ACC 3393 DV=DOPE VECTOR(TYPE,ACC,0,FROMAR2(Q),R,LB)+12 3394 ! DOPE VECTOR INTO SHAREABLE S.T. 3395 ACC=SACC; PTYPE=TYPEP; UNPACK 3396 %IF TYPE=5 %OR (TYPE=1 %AND PREC=3) %THEN RL=0 %ELSE RL=3 3397 ROUND 3398 {%UNTIL A(Q-1)=2} %CYCLE; ! HEAD INTO GLA FOR EACH ARRAY 3399 A0=R; %IF UNSCAL=0 %THEN A0=A0//ACC 3400 %IF PREC=4 %THEN A0=0; ! STRING DESCRIPTORS ! 3401 A0=A0!DESC; A1=INC 3402 %IF TYPE<=3 %AND PARMARR=0=PARMCHK %AND J=1 %THEN A1=A1-LB*ACC 3403 A2=5<<27!3*J 3404 PGLA(4,16,ADDR(A0)) 3405 D1=GLACA-16 3406 RELOCATE(D1+12,DV,1); ! RELOCATE DV POINTER 3407 NOTE CREF(16_80000000!(DV<<1>>3)!(D1+12)>>2<<16, (DV&16_FFFF)<<2) 3408 D2=INC 3409 SN(Q); INC=INC+R 3410 Q=Q+3 3411 %REPEAT %UNTIL A(Q-1)=2; ! HEAD INTO GLA FOR EACH ARRAY 3412 P=P+1; Q=P 3413 %REPEAT %UNTIL A(P-1)=2 3414 P=P+2 %IF RFD=5 3415 -> TRY END 3416 RFEL(3): ! %RECORD (%ARRAY) %NAME 3417 TYPE=3; PREC=3; NAM=1 3418 ARR=2-A(P+1); P=P+2 3419 PACK(PTYPE); D2=0 3420 RL=3; ACC=8+8*ARR 3421 FORM=0 3422 ->AGN 3423 RFEL(4): ! RECORDS IN RECORDS 3424 RFEL(5): ! RECORDARRAYS IN RECORDS 3425 Q=P+FROM AR2(P+1)+1 3426 FN=FROM AR2(Q) 3427 COPY TAG(FN); ! COPY FORMAT TAG & SET ACC 3428 FAULT(62,FN) %UNLESS PTYPE=4 3429 TYPE=3; PREC=3; FORM=TCELL 3430 %IF RFD=4 %THEN %START 3431 PTYPE=16_33; P=P+3; D2=0 3432 RL=3; ->AGN 3433 %FINISH 3434 P=P+3; ->RFEL2 3435 END: ! FINISH OFF 3436 RL=MRL; ROUND 3437 ACC=INC; ! SIZE ROUNDED APPROPRIATELY 3438 FAULT(98,0) %UNLESS INC<=16_7FFF 3439 CLEAR LIST(NLIST) 3440 %RETURN 3441 %ROUTINE SN(%INTEGER Q) 3442 !*********************************************************************** 3443 !* CHECK THE SUBNAME HAS NOT BEEN USED BEFORE IN THIS FORMAT * 3444 !* AND ENTER IT WITH ITS DESCRIPTORS INTO THE LIST. * 3445 !*********************************************************************** 3446 FNAME=FROM AR2(Q) 3447 FAULT2(61,0,FNAME) %UNLESS FIND(FNAME,NLIST)=-1 3448 BINSERT(OPHEAD,OB,FNAME<<20!PTYPE<<4!J,D2<<16!ACC,D1<<16!FORM) 3449 PUSH(NLIST,0,FNAME,0) 3450 %END 3451 %ROUTINE ROUND 3452 MRL=RL %IF RL>MRL 3453 INC=INC+1 %WHILE INC&RL#0 3454 %END 3455 %END; ! OF ROUTINE CRFORMAT 3456 %INTEGERFN DISPLACEMENT(%INTEGER LINK) 3457 !*********************************************************************** 3458 !* SEARCH A FORMAT LIST FOR A SUBNAME * 3459 !* A(P) HAS ENAME--LINK IS HEAD OF RFORMAT LIST. RESULT IS DISP * 3460 !* FROM START OF RECORD * 3461 !*********************************************************************** 3462 %RECORD(LISTF)%NAME FCELL,PCELL,LCELL{(LISTF) 3463 %INTEGER RR,II,ENAME,CELL 3464 ENAME=A(P)<<8+A(P+1); CELL=0 3465 %IF LINK#0 %THEN %START; ! CHK RECORDSPEC NOT OMITTED 3466 FCELL==ASLIST(LINK); ! ONTO FORMAT TAG CELL 3467 LINK=FCELL_S3&16_7FFF; ! LINK TO SIDE CHAIN 3468 CELL=LINK; II=-1; ACC=-1 3469 %WHILE LINK>0 %CYCLE 3470 LCELL==ASLIST(LINK) 3471 %IF LCELL_S1>>20=ENAME %START; ! RIGHT SUBNAME LOCATED 3472 TCELL=LINK 3473 RR=LCELL_S1 3474 SNDISP=LCELL_S2 3475 K=LCELL_S3 3476 J=RR&15; PTYPE=RR>>4&16_FFFF 3477 ACC=SNDISP&16_FFFF; SNDISP=SNDISP&16_FFFF0000//16_10000 3478 KFORM=K&16_FFFF; K=K>>16 3479 %IF LINK#CELL %START; ! NOT TOP CELL OF FORMAT 3480 PCELL_LINK=LCELL_LINK 3481 LCELL_LINK=CELL 3482 FCELL_S3=FCELL_S3&16_FFFF0000!LINK 3483 %FINISH; ! ARRANGING LIST WITH THIS SUBNAME 3484 ! AT THE TOP 3485 %RESULT=K 3486 %FINISH 3487 PCELL==LCELL 3488 LINK=LCELL_LINK 3489 %REPEAT 3490 %FINISH 3491 FAULT(65,ENAME) 3492 %IF CELL>0 %THEN PUSH(ASLIST(CELL)_LINK,ENAME<<20!7<<4,0,0) 3493 PTYPE=7; TCELL=0 3494 %RESULT=-1 3495 %END 3496 %INTEGERFN COPY RECORD TAG(%INTEGERNAME SUBS) 3497 !*********************************************************************** 3498 !* PRODUCE PTYPE ETC FOR A COMPOUND NAME BY CHAINING DOWN ONE * 3499 !* ONE OR MORE RECORD FORMAT LISTS. ON EXIT RESULT =0 IF NO * 3500 !* SUBNAME FOUND OR SUBNAME IS OF TYPE RECORD WITH NO FURTHER * 3501 !* SUBNAME ATTACHED. RESULT#0 IF BONE-FIDE SUBNAME LOCATED * 3502 !* ON ENTRY KFORM HAS POINTER TO THE (FIRST ) FORMAT LIST AND * 3503 !* P POINTS TO THE A.R. ENTRY FOR (FIRST) ENAME * 3504 !*********************************************************************** 3505 %INTEGER Q,FNAME 3506 SUBS=0 3507 {%UNTIL TYPE#3} %CYCLE 3508 FNAME=KFORM 3509 P=P+2; SKIP APP 3510 %RESULT=0 %IF A(P)=2 %OR FNAME<=0;! NO (FURTHER) ENAME 3511 SUBS=SUBS+1 3512 P=P+1; Q=DISPLACEMENT (FNAME) 3513 UNPACK 3514 %REPEAT %UNTIL TYPE#3 3515 %RESULT=Q+1; ! GIVES 0 IF SUBNAME NOT KNOWN 3516 %END 3517 %ROUTINE CRNAME(%INTEGER Z,REG,MODE,BS,AR,DP,%INTEGERNAME NAMEP) 3518 !*********************************************************************** 3519 !* DEAL WITH RECORD ELEMENT NAMES.Z AS FOR CNAME.CLINK=TAGS(RN) * 3520 !* MODE=ACCESS FOR RECORD(NOT THE ELEMENT!) * 3521 !* ON EXIT BASE,AREA & DISP POINT TO REQUIRED ELEMENT * 3522 !* RECURSIVE CALL IS NEEDED TO DEAL WITH RECORDS IN RECORDS * 3523 !* DEPTH SHEWS RECURSIVE LEVELS- NEEDED TO AVOID MIS SETTING * 3524 !* REGISTER IN USE IF RECORDNAME IN RECORD HAS THE SAME NAME AS * 3525 !* A GENUINE RECORD NAME. * 3526 !*********************************************************************** 3527 %INTEGER DEPTH,FNAME 3528 %ROUTINESPEC CENAME(%INTEGER MODE,FNAME,BS,AR,DP,XD) 3529 DEPTH=0 3530 FNAME=KFORM; ! POINTER TO FORMAT 3531 %IF ARR=0 %OR (Z=6 %AND A(P+2)=2) %START;! SIMPLE RECORD 3532 %IF A(P+2)=2 %THEN P=P+3 %ELSE NO APP 3533 CENAME(MODE,FNAME,BS,AR,DP,0) 3534 %FINISH %ELSE %START 3535 CANAME(ARR,BS,DP) 3536 CENAME(ACCESS,FNAME,BASE,AREA,DISP,0) 3537 %FINISH; %RETURN 3538 ! 3539 %ROUTINE CENAME(%INTEGER MODE,FNAME,BS,AR,DP,XD) 3540 !*********************************************************************** 3541 !* FINDS OUT ABOUT SUBNAME AND ACTS ACCORDINGLY.MOSTLY ACTION * 3542 !* CONSISTS OF UPPING XD BY OFFSET OF THE SUBNAME BUT IS VERY * 3543 !* HAIRY FOR RECORDS IN RECORDS ETC * 3544 !* MODE IS ACCESS FOR THE RECORD * 3545 !*********************************************************************** 3546 %ROUTINESPEC FETCH RAD 3547 %ROUTINESPEC LOCALISE(%INTEGER SIZE) 3548 %INTEGER Q,QQ,D,C,W 3549 DEPTH=DEPTH+1 3550 %IF A(P)=2 %THEN %START; ! ENAME MISSING 3551 ACCESS=MODE; AREA=AR; XDISP=XD 3552 BASE=BS; DISP=DP; ! FOR POINTER 3553 %IF Z<14 %THEN %START; ! NOT A RECORD OPERATION 3554 %UNLESS 3<=Z<=4 %OR Z=6 %START; ! ADDR(RECORD) 3555 FAULT(64,0); BASE=RBASE; AREA=-1 3556 DISP=0; ACCESS=0; PTYPE=1; UNPACK 3557 %FINISH 3558 %FINISH 3559 %RETURN 3560 %FINISH 3561 P=P+1; ! FIND OUT ABOUT SUBNAME 3562 Q=DISPLACEMENT(FNAME); ! TCELL POINTS TO CELL HOLDING 3563 UNPACK; ! INFO ABOUT THE SUBNAME 3564 %IF Q=-1=ACC %OR PTYPE=7 %START; ! WRONG SUBNAME(HAS BEEN FAULTED) 3565 P=P+2; SKIP APP; P=P-3 3566 ACCESS=0; BASE=RBASE; DISP=0; AREA=-1 3567 %RETURN 3568 %FINISH 3569 NAMEP=(A(P)<<8!A(P+1))<<16!NAMEP; ! NAMEP=-1 UNALTERED ! 3570 ->AE %IF ARR=1; ! ARRAYS INCLUDING RECORDARRAYS 3571 %IF A(P+2)=2 %THEN P=P+3 %ELSE NO APP 3572 %IF TYPE<=2 %OR TYPE=5 %OR (TYPE=3 %AND A(P)=2 %AND (3<=Z<=4 %OR Z=6)) %START 3573 ACCESS=MODE+4+4*NAM; BASE=BS; 3574 AREA=AR; DISP=DP; XDISP=XD+Q 3575 %RETURN 3576 %FINISH 3577 ! 3578 ! NOW CODING BECOMES HAIRY:- STILL LEFT ARE 3579 ! A) RECORDS IN RECORDS Q POINTS TO SECONDARY RECORD 3580 ! B) RECORDNAMES IN RECORDS Q HAS OFF-SET OF A POINTER 3581 ! C) RECORDARRAYNAMES IN RECORDS Q HAS OFF-SET A HEADER IN RECORD 3582 ! D) RECORDARRAYS IN RECORDS NOT YET ALLOWED 3583 ! Q WOULD HAVE OFF-SET OF A RECORD RELATIVE HEADER IN THE GLA 3584 ! 3585 XD=XD+Q 3586 NAMEP=-1 3587 %IF NAM=1 %THEN %START 3588 %IF MODE=0 %START 3589 DP=DP+XD; XD=0; MODE=2 3590 %FINISH %ELSE %START 3591 LOCALISE(8); ! PICK UP RECNAME DESCR &STCK 3592 AR=AREA; DP=DISP; BS=BASE 3593 %FINISH 3594 %FINISH 3595 CENAME(MODE,KFORM,BS,AR,DP,XD) 3596 %RETURN 3597 AE: ! ARRAYS AND ARRAYNAMES AS ELEMEN 3598 FROM123(TCELL,Q,SNDISP,K) 3599 ACC=SNDISP&16_FFFF; SNDISP=SNDISP&16_FFFF0000//16_10000 3600 KFORM=K&16_FFFF; K=K>>16 3601 C=ACC; D=SNDISP; Q=K; QQ=KFORM 3602 %IF (Z=6 %OR Z=12) %AND A(P+2)=2 %START;! 'GET ARRAYHEAD' CALL 3603 P=P+3 3604 %IF NAM=1 %THEN %START 3605 ACCESS=MODE+8; BASE=BS 3606 AREA=AR; DISP=DP; XDISP=XD+Q 3607 %RETURN 3608 %FINISH 3609 ! 3610 ! PASSING AN ARRAY IN A RECORD BY NAME MUST CONSTRUCT PROPER ARRAYHEAD 3611 ! FROM THE RECORD RELATIVE ONE AT Q(GLA) 3612 ! 3613 NAMEP=-1 3614 FETCH RAD 3615 AREA=-1; DISP=Q 3616 BASE=0; ACCESS=0; 3617 CREATE AH(1) 3618 %FINISH %ELSE %START; ! ARRAY ELEMENTS IN RECORDS 3619 NAMEP=-1 3620 %IF NAM=1 %THEN %START; ! ARRAYNAMES-FULLHEAD IN RECORD 3621 XD=XD+Q 3622 LOCALISE(16); ! MOVE HEAD UNDER LNB 3623 CANAME(3,BASE,DISP); ! ARRAY MODE SETS DISP,AREA&BASE 3624 %FINISH %ELSE %START; ! ARRAY RELATIVE HEAD IN GLA 3625 %IF MODE=0 %OR MODE=2 %%START 3626 %IF MODE=0 %THEN W=DP-4 %ELSE W=DP+4 3627 %FINISH %ELSE %START 3628 FETCH RAD; ! RECORD ADDR TO ACC 3629 GET WSP(W,1) 3630 PSF1(ST,1,W); XD=0 3631 BS=RBASE 3632 %FINISH 3633 CANAME(3,0,Q); ! RECORD REL ARRAY ACCESS 3634 ! CAN RETURN ACCESS=1 OR 3 ONLY 3635 %IF PARMARR=0=PARMCHK %AND ACCESS=3 %AND (PREC=3 %OR TYPE>=3) %START 3636 PSORLF1(ADB,0,AREA CODE2(BS),W) 3637 PSF1(ADB,0,XD) %UNLESS XD=0 3638 GRUSE(BREG)=0 3639 %FINISH %ELSE %START 3640 GET IN ACC(DR,2,0,AREA CODE,Q) 3641 PSORLF1(INCA,0,AREA CODE2(BS),W) 3642 %IF ACCESS=1 %THEN ACCESS=2 %AND AREA=7 %AND XD=XD+NUMMOD*BYTES(PREC) 3643 PSF1(INCA,0,XD) %UNLESS XD=0 3644 FORGET (DR) 3645 AREA=7; DISP=0; ! AND ACCESS = 2 OR 3 ONLY 3646 %IF TYPE=3 %AND A(P)=1 %START; ! WILL BE A FURTHER CALL 3647 ! ON ROUTINE CENAME 3648 GET WSP(DISP,2) 3649 PSF1(STD,1,DISP) 3650 AREA=LNB; BASE=RBASE 3651 %FINISH 3652 %FINISH 3653 %FINISH 3654 %IF TYPE=3 %THEN CENAME(ACCESS,QQ,BASE,AREA,DISP,0) 3655 %FINISH 3656 %RETURN 3657 %ROUTINE FETCH RAD 3658 !*********************************************************************** 3659 !* SET ACC TO 32 BIT ADDRESS OF RECORD. * 3660 !*********************************************************************** 3661 ACCESS=MODE+4 3662 AREA=AR; BASE=BS 3663 DISP=DP; XDISP=XD 3664 NAMEOP(4,ACCR,4,-1) 3665 %END 3666 %ROUTINE LOCALISE(%INTEGER SIZE) 3667 !*********************************************************************** 3668 !* REMOVES A DESCRIPTOR OR ARRAYHEAD FROM A RECORD AND STORES * 3669 !* IT IN A TEMPORARY UNDER LNB. * 3670 !*********************************************************************** 3671 %INTEGER HOLE 3672 ACCESS=MODE+4 3673 AREA=AR; BASE=BS; DISP=DP 3674 XDISP=XD 3675 NAMEOP(2,ACCR,SIZE,-1) 3676 GET WSP(HOLE,SIZE>>2) 3677 PSF1(ST,1,HOLE) 3678 MODE=2; AREA=LNB 3679 BASE=RBASE; DISP=HOLE; XD=0 3680 %END; ! OF ROUTINE LOCALISE 3681 %END; ! OF ROUTINE CENAME 3682 %END; ?REG unused 3683 ; ! OF ROUTINE CRNAME 3683 %ROUTINE CSTREXP(%INTEGER MODE,REG) 3684 !*********************************************************************** 3685 !* PLANT IN-LINE CODE FOR CONCATENATION. A WORK AREA UNDER * 3686 !* BASE REGISTER COVER IS USUALLY REQUIRED. THE CURRENT LENGTH * 3687 !* OF STRING IN THE WORK AREA IS KEPT IN A REGISTER (BREG) * 3688 !* WHICH IS PROTECTED THROUGH THE NORMAL INTERMEDIATE-RESULT * 3689 !* MECHANISMS. * 3690 !* ON ENTRY:- * 3691 !* MODE=0 NORMAL. WK AREA NOT USED FOR ONE OPERAND EXPSSNS * 3692 !* MODE=1 STRING MUST GO TO WORK AREA * 3693 !* (AND TO COME) * 3694 !* MODE=3 CONCATENATE INTO LHS OF =ASSNMNT (E.G. A=B.C) * 3695 !* MODE=4 OPTIMISE S=S.T BY NOT COPYING S * 3696 !* 2**4 BIT OF MODE IS SET IF WK-AREA NOT TO BE FREED ON EXIT * 3697 !* ON EXIT:- * 3698 !* BASE,DISP & INDEX DEFINE RESULT * 3699 !* VALUE#0 %IF RESULT IN A WORK AREA(CCOND MUST KNOW) * 3700 !* STRINGL SET IF STRING LENGTH KNOWN. STRFNRES DEFINES LENREG * 3701 !*********************************************************************** 3702 %INTEGER PP,WKAREA,DOTS,REXP,ERR,CLEN,KEEPWA,FNAM 3703 %INTEGERFNSPEC STROP(%INTEGER REG) 3704 KEEPWA=MODE&16; MODE=MODE&15 3705 PP=P; STRINGL=0; FNAM=0; WKAREA=0 3706 REXP=2-A(P+1+FROM AR2(P+1)); ! =0 %IF ONE OPERAND EXP 3707 -> NORMAL %UNLESS A(P+3)=4 %AND REXP=0 %AND MODE=0 3708 -> SIMPLE %IF A(P+4)=2 3709 -> NORMAL %UNLESS A(P+4)=1 3710 ! COPY TAG(FROM AR2(P+5)) 3711 ! %IF PTYPE=SNPT %THEN PTYPE=TSNAME(K) 3712 ! -> NORMAL %UNLESS ROUT=0 ; ! BEWARE OF MAP=FN 3713 ! -> NORMAL %IF PARMARR=1 %AND(ARR#0 %OR A(P+7)=1) 3714 SIMPLE: P=P+4 3715 ERR=STROP(REG) 3716 -> ERROR %UNLESS ERR=0 3717 VALUE=WKAREA 3718 P=P+1; STRFNRES=0 3719 %RETURN 3720 ERROR: FAULT2(ERR,0,FNAM) 3721 BASE=RBASE; DISP=0 3722 VALUE=0; ACCESS=0 3723 P=PP; SKIP EXP 3724 %RETURN 3725 NORMAL: CLEN=0; P=P+3; ! LENGTH OF CONSTANT PART 3726 ERR=72; ->ERROR %UNLESS A(P)=4 3727 P=P+1 3728 GET WSP(WKAREA,268); ! GET NEXT OPERAND 3729 DOTS=0; ! NO OPERATORS YET 3730 NEXT: STRINGL=0 3731 ERR=STROP(DR); ! GET NEXT OPERAND 3732 -> ERROR %UNLESS ERR=0 3733 %IF REGISTER(ACCR)#0 %THEN BOOT OUT(ACCR) 3734 PSF1(LB,0,WKAREA); ! BYTE DISP FROM LNB 3735 PPJ(0,19+DOTS); ! TO SUBROUTINE 19 OR 20 3736 %IF A(P)=2 %THEN -> TIDY; ! NO MORE OPERATIONS 3737 ERR=72; -> ERROR %UNLESS A(P+1)=CONCOP; ! CONCATENATE 3738 DOTS=DOTS!1 3739 P=P+2; -> NEXT 3740 TIDY: ! FINISH OFF 3741 VALUE=WKAREA 3742 P=P+1; ! PAST REST OF EXPRN 3743 RETURN WSP(WKAREA,268) %IF KEEPWA=0 3744 STRINGL=0 3745 %RETURN 3746 %INTEGERFN STROP(%INTEGER REG) 3747 !*********************************************************************** 3748 !* DEALS WITH OPERAND FOR CONCATENATION. RETURN RESULT=0 FOR * 3749 !* VALID OPERAND OTHERWISE AN ERROR NUMBER. * 3750 !*********************************************************************** 3751 %INTEGER CTYPE,VAL,MODE 3752 MODE=A(P); ! ALTERNATIVE OF OPERAND 3753 %RESULT=75 %IF MODE>2 3754 %IF MODE#1 %THEN %START 3755 CTYPE=A(P+1); ! GET CONST TYPE & LOSE AMCK FLAGS 3756 %IF CTYPE=16_35 %THEN %START 3757 STRINGL=A(P+6) 3758 DISP=FROM AR4(P+2) 3759 P=P+STRINGL+7 3760 %FINISH %ELSE %RESULT=71 3761 PF1(LDRL,0,PC,STRLINK) 3762 PSF1(INCA,0,DISP) %IF DISP#0 3763 %IF STRINGL#1 %THEN %START 3764 %IF STRINGL<=63 %THEN PSF1(LDB,0,STRINGL) %ELSE PF1(LDB,2,7,0);! ((DR)) 3765 %FINISH 3766 GRUSE(DR)=0 3767 %IF REG=ACCR %THEN COPY DR 3768 %FINISH %ELSE %START 3769 P=P+1; ! MUST CHECK FIRST 3770 REDUCE TAG; ! SINCE CNAME ONLY LOADS STRINGS 3771 ! AND LONGINTS TO DR! 3772 %IF 5#TYPE#7 %THEN FNAM=FROMAR2(P) %AND %RESULT=71 3773 CNAME(2,REG) 3774 STRINGL=0 3775 %IF ROUT#0 %AND NAM<=1 %START;! WAS FUNCTION NOT MAP 3776 %IF WKAREA=0 %AND KEEPWA#0 %THEN WKAREA=STRFNRES %ELSE RETURN WSP(STRFNRES,268) 3777 %FINISH 3778 %FINISH 3779 %RESULT=0 3780 %END; ?VAL unused 3781 ; ! OF INTEGERFN STROP 3781 %END; ! OF ROUTINE CSTREXP 3782 %ROUTINE CRES (%INTEGER LAB) 3783 !********************************************************************** 3784 !* COMPILES A RESOLUTION E.G A->B.(C).D.(E).F AND JUMPS TO LAB * 3785 !* ON FAILURE. (LAB=0 FOR UNCONDITIONAL RESOLUTION TO PERM ON * 3786 !* FAILURE ). * 3787 !* THE METHOD IS TO CALL A SUBROUTINE PASSING 3 PARAMS:- * 3788 !* P1 POINTS TO LHS(A) * 3789 !* P2 STRING TO CONTAIN FRAGMENT (PASSED BY NAME) * 3790 !* P3 THE EXPRESSION PASSED AS DESCRIPTOR * 3791 !* SUBROUTINE TRIES TO PERFORM THE RESOLUTION AND SETS THE * 3792 !* CONDITION CODE =8 IF IT SUCCEEDS. * 3793 !* * 3794 !* ON ENTRY LHS IS DEFINED BY DESCRIPTOR REG. * 3795 !* P POINTS TO P(+') OF RHS DEFINED AS (+')(OPERAND)(RESTOFEXP) * 3796 !* * 3797 !$ THE ROUTINE IS COMPACT BUT DIFFICULT TO FOLLOW (OR ALTER) * 3798 !* THE TIME IN PERM IS LARGE SO IT IS NOT WORTHWHILE TO PERSUE * 3799 !* CODE EFFICIENCY TOO INDUSTRIOUSLY . * 3800 !********************************************************************** 3801 %INTEGER P1,P2,SEXPRN,W,LAST,ERR,FNAM 3802 %RECORD (RD) R{(RD) 3803 LAST=0; FNAM=0; ! =1 WHEN END OF EXPRNSN FOUND 3804 SEXPRN=0; ! RESOLUTION(BRKTD) EXPRESSNS 3805 ERR=74; ! NORMAL CRES FAULT 3806 PSF1(INCA,0,1); ! TO FIRST CHAR 3807 P1=P; P=P+3 3808 ->RES %IF A(P)=4; ! LHS MUST BE A STRING 3809 ! BUT THIS CHECKED BEFORE CALL 3810 ERR=72 3811 ERROR: FAULT2(ERR,0,FNAM) 3812 P=P1; SKIP EXP; %RETURN 3813 RES: P=P+1; ! TO P(OPERAND) 3814 PSF1(PRCL,0,4) 3815 %IF SEXPRN=0 %THEN W=STD %ELSE W=ST 3816 PF1(W,0,TOS,0) 3817 %IF A(P)=3 %THEN PSF1(LSD,0,0) %AND GRUSE(ACCR)=0 %ELSE %START;! B OMITTED 3818 ->ERROR %UNLESS A(P)=1; ! P(OPERAND)=NAME 3819 P=P+1; P2=P 3820 CNAME(3,ACCR) 3821 %IF TYPE#5 %THEN ERR=71 %AND FNAM=FROMAR2(P2) %AND ->ERROR 3822 %IF A(P+1)#CONCOP %THEN ERR=72 %AND ->ERROR 3823 P=P+2 3824 %FINISH 3825 PF1(ST,0,TOS,0); ! B (OR DUMMY) TO P2 3826 ->ERROR %UNLESS A(P)=3; ! P(OPERAND)='('(EXPR)')' 3827 SEXPRN=SEXPRN+1; P=P+1 3828 CSTREXP(0,DR); ! TO REGISTER DR 3829 ! 3830 PF1(STD,0,TOS,0) 3831 PSF1(RALN,0,11) 3832 PPJ(-1,16) 3833 ! DEAL WITH CC#8 IE RESLN FAILED 3834 %IF LAB#0 %THEN ENTER JUMP(7,LAB,B'11') %ELSE PPJ(7,12) 3835 ! 3836 -> END %IF A(P)=2 3837 %IF A(P+1)#CONCOP %THEN ERR=72 %AND ->ERROR 3838 ->ERROR %UNLESS A(P+2)=1 3839 P2=P+1; P=P2+1 3840 P=P+3 %AND SKIP APP %UNTIL A(P)=2 3841 %IF A(P+1)=1 %THEN P=P2 %AND ->RES 3842 P1=P+1 3843 REGISTER(ACCR)=1 3844 OLINK(ACCR)=ADDR(R) 3845 R_PTYPE=1; R_XB=ACCR 3846 R_FLAG=9 3847 P=P2+2; CNAME(1,DR) 3848 %IF R_FLAG#9 %THEN PF1(LSD,0,TOS,0) 3849 REGISTER(ACCR)=0 3850 PF1(STUH,0,BREG,0) 3851 PF1(LUH,0,BREG,0) 3852 PF2(MVL,0,0,0,0,0) 3853 %IF ROUT#0 %OR NAM#0 %THEN PPJ(0,18);! ASSNMNT CHECK (Q.V) 3854 PF2(MV,1,1,0,0,UNASSPAT&255) 3855 GRUSE(ACCR)=0 3856 %IF PARMARR=1 %START 3857 PSF1(USH,0,8) 3858 PSF1(USH,0,-40) 3859 PPJ(36,9) 3860 %FINISH 3861 P=P1 3862 END: 3863 P=P+1 3864 %END 3865 %ROUTINE SAVE AUX STACK 3866 !*********************************************************************** 3867 !* COPY AUX STACK DESCRPTR & POINTER INTO CURRENT STACK FRAME * 3868 !* FIVE WORDS ARE USED FOR THIS PURPOSE:- * 3869 !* 1&2 HOLD AUX STACK DESCRIPTOR * 3870 !* 3 HOLDS VALUE AT BLK ENTRY FOR USE AT EXIT * 3871 !* 4 HOLDS STACKTOP VALUE AFTER ALL ARRAY DECLNS(FOR %ONS) * 3872 !* 5 HOLD STACKLIMIT FOR CHECKING AT ARRAY DECLARATIONS * 3873 !* THE LATTER IS OMITTED INPARM=OPT * 3874 !*********************************************************************** 3875 %INTEGER XYNB, DR0, DR1 3876 %IF AUXST=0 %THEN %START; ! FIRST REF PUT REF IN PLT 3877 DR0=16_30000001; DR1=0 3878 PGLA(8,8,ADDR(DR0)) 3879 AUXST=GLACA-8 3880 GXREF(AUXSTEP,2,16_02000008,AUXST+4) 3881 %FINISH 3882 %IF AUXSBASE(LEVEL)=0 %START 3883 XYNB=SET XORYNB(-1,-1) 3884 PF1(LD,2,XYNB,AUXST) 3885 %IF PARMOPT#0 %THEN %START 3886 PF1(LSS,1,0,2); ! PICK UP STACKTOP 3887 PSF1(ST,1,N+16) 3888 %FINISH 3889 PF1(LSS,2,7,0) 3890 PSF1(STD,1,N) 3891 PSF1(ST,1,N+8) 3892 AUXSBASE(LEVEL)=N; N=N+16 3893 %IF PARMOPT#0 %THEN N=N+4 3894 GRUSE(DR)=0; GRUSE(ACCR)=11; GRINF1(ACCR)=0 3895 %FINISH 3896 %END 3897 %ROUTINE RESET AUX STACK 3898 !*********************************************************************** 3899 !* IF ANY ARRAYS HAVE BEEN PUT ON THE AUXSTACK THEN UNDECLARE * 3900 !*********************************************************************** 3901 %IF AUXSBASE(LEVEL)#0 %START 3902 PSF1(LB,1,AUXSBASE(LEVEL)+8) 3903 PSF1(STB,2,AUXSBASE(LEVEL)) 3904 GRUSE(BREG)=0 3905 %FINISH 3906 %END 3907 %ROUTINE RT EXIT 3908 !*********************************************************************** 3909 !* THIS ROUTINE COMPILES CODE FOR ROUTINE EXIT(IE '%RETURN') * 3910 !*********************************************************************** 3911 RESET AUX STACK 3912 PSF1(EXIT,0,-16_40) 3913 %END 3914 %ROUTINE CLAIM ST FRAME(%INTEGER AT,VALUE) 3915 !*********************************************************************** 3916 !* FILL ASF INSTN IN RT ENTRY SEQUENCE TO CLAIM THE STACKFRAME * 3917 !*********************************************************************** 3918 %INTEGER INSTR, WK 3919 WK=AT>>18; ! BYTES CLAIMED BY ENTRY SEQ 3920 AT=AT&16_3FFFF; ! ADRR OF ASF INSTRN 3921 INSTR=(ASF+12*PARMCHK)<<24!3<<23!(VALUE-WK+3)>>2 3922 PLUG(1,AT,INSTR,4) 3923 %END 3924 %ROUTINE CEND (%INTEGER KKK) 3925 !*********************************************************************** 3926 !* DEAL WITH ALL OCCURENCES OF '%END' * 3927 !* KKK=PTYPE(>=16_1000) FOR ROUTINES,FNS AND MAPS * 3928 !* KKK=0 FOR ENDS OF '%BEGIN' BLOCKS * 3929 !* KKK=1 FOR '%ENDOFPROGRAM' * 3930 !* %ENDOFPROGRAM IS REALLY TWO ENDS. THE FIRST IS THE USERS * 3931 !* AND THE SECOND IS PERMS. KKK=2 FOR A RECURSIVE CALL OF CEND * 3932 !* ON END OF PROGRAM TO DEAL WITH THE %END CORRESPONDING TO * 3933 !* THE %BEGIN COMPILED IN THE INITIALISATION SEQUENCE * 3934 !*********************************************************************** 3935 %INTEGER KP,JJ,BIT 3936 %ROUTINESPEC DTABLE(%INTEGER LEVEL) 3937 SET LINE %UNLESS KKK=2 3938 FORGET(-1) 3939 BIT=1<16_1000 %AND COMPILER=0 %AND LAST INST=0 %THEN PPJ(15,10); ! RUN FAULT 11 3945 NMAX=N %IF N>NMAX; ! WORK SPACE POINTER 3946 ! 3947 ! CLEAR OUT THE LABEL LIST FAULTING LABELS WITH JUMPS OUTSTANDING 3948 ! AS NOT SET AND COMMENTING ON LABELS NOT USED 3949 ! 3950 %WHILE LABEL(LEVEL)#0 %CYCLE 3951 POP(LABEL(LEVEL),I,J,KP) 3952 I=I>>24 3953 %IF J&16_FFFF#0 %THEN %START 3954 J=J&16_FFFF 3955 %IF 0=16_1000 %OR KKK=1 %THEN CLAIM ST FRAME(SET(RLEVEL),NMAX) 3977 ! 3978 ! NOW PLANT THE BLOCK EXIT SEQUENCE 3979 ! 3980 %IF KKK&16_3FFF=16_1000 %AND LAST INST=0 %THEN RT EXIT 3981 PPJ(15,21) %IF KKK=1 %AND LAST INST=0;! %STOP AT %ENDOFPROGRAM 3982 %IF KKK=0 %THEN %START; ! BEGIN BLOCK EXIT 3983 %IF PARMTRACE=1 %THEN %START; ! RESTORE DIAGS POINTERS 3984 PSF1(LD,1,12) 3985 DIAG POINTER(LEVEL-1) 3986 PSF1(STD,1,12) 3987 %FINISH 3988 %IF STACK#0 %START 3989 JJ=NMDECS(LEVEL)>>14 3990 %IF JJ#0 %THEN %START; ! ARRAYS TO BE UNDECLARED 3991 PF1(STSF,0,TOS,0) 3992 PF1(LSS,0,TOS,0) 3993 PSF1(ISB,1,JJ) 3994 PSF1(USH,0,-2) 3995 PF1(ST,0,TOS,0) 3996 PF1(ASF,0,TOS,0) 3997 GRUSE(ACCR)=0 3998 %FINISH 3999 %FINISH %ELSE RESET AUX STACK 4000 %FINISH 4001 ! 4002 ! RETURN TO PREVIOUS LEVEL PROVIDED THERE IS A VALID ONE ! 4003 ! 4004 %UNLESS LEVEL>2 %OR (LEVEL=2 %AND CPRMODE=2) %THEN %START 4005 %IF KKK=1 %AND LEVEL=2 %THEN KKK=2 %ELSE FAULT(14,0) %AND %STOP 4006 %FINISH 4007 LEVEL=LEVEL-1 4008 %IF KKK>=16_1000 %THEN %START 4009 RLEVEL=RLEVEL-1 4010 RBASE=RLEVEL 4011 %FINISH 4012 ! 4013 ! RESTORE INFORMATION ABOUT THE (NEW) CURRENT LEVEL 4014 ! 4015 POP(LEVELINF,KP,N,KP) 4016 NMAX=N>>16 %IF KKK>=16_1000 4017 N=N&16_7FFF 4018 %IF KKK=2 %THEN CEND(KKK); ! ROUND AGAIN FOR 'ENDOFPROGRAM' 4019 ! 4020 ! COMPLETE THE JUMP AROUND ALL NON-EXTERNAL ROUTINES EXCEPT WHEN 4021 ! %TRUSTEDPROGRAM IS IN OPERATION. 4022 ! 4023 %IF ASL WARN#0 %THEN ASL WARN=0 %AND EPILOGUE 4024 %IF KKK>=16_1000 %AND COMPILER=0 %AND(RLEVEL>0 %OR CPRMODE#2) %THEN %START 4025 JJ=NEXTP+6 4026 %UNLESS A(NEXTP+5)=11 %AND A(JJ+FROMAR2(JJ))=2 %START 4027 JJ=ENTER LAB(JROUND(LEVEL+1),0) 4028 JROUND(LEVEL+1)=0 4029 %FINISH 4030 %FINISH 4031 %RETURN 4032 ! 4033 ! LAYOUT OF DIAGNOSIC TABLES 4034 ! ****** ** ********* ****** 4035 ! 4036 ! THE BOUND FIELD OF PLT DESCRIPTOR STORED AT (LNB+3 & LNB+4) IF 4037 ! USED TO CONTAIN A DISPLACEMENT RELATIVE TO THE START OF SST OF THE 4038 ! DIAGNOSTIC TABLES FOR THE BLOCK OR ROUTINE BEING EXECUTED. 4039 ! A ZERO BOUND MEANS NO DIAGNOSTIC REQUESTED.(NB THIS MAY MEAN A DUMMY 4040 ! FIRST WORD IN THE SST). 4041 ! THE ABSOLUTE ADDRESS OF THE SST FOR THE CURRENT CODE SEGMENT WILL 4042 ! ALWAYS BE FOUND IN THE STANDARD 10 WORDS OF THE GLA/PLT 4043 ! 4044 ! FORM OF THE TABLES:- 4045 ! 4046 ! WORD 0 = LINE OF RT IN SOURCE PROG <<16 ! LINE NO POSN(FROM LNB) 4047 ! WORD 1 = (12 LANG DEPENDENT BITS)<<18 ! ENVIRONMENT 4048 ! ( TOP 2 BITS OF LANG DEPENDENT HAS LITL FROM PTYPE) 4049 ! ( BOTTOM 4 BITS HAVE TEXTUAL LEVEL) 4050 ! WORD 2 = DISPLAY POSN (FROM LNB)<<16 ! RT TYPE INFO 4051 ! WORD 3 = ZERO FOR BLKS OR STRING(<=11BYTES) BEING THE 4052 ! RT NAME. THIS WILL TAKE WORDS 4 AND 5 IF NEEDED 4053 ! WORD 6 = LANGUAGE DEPENDENT INFO . IMP ON CONDITIONS ETC 4054 ! 4055 ! THE REST IS MADE UP OF VARIABLE ENTRIES AND THE SECTION IS TERMINATED BY 4056 ! A WORD OF 16_FFFFFFFF 4057 ! 4058 ! EACH VARIABLE ENTRY CONSISTS OF THE VARIABLE WORD FOLLOWED BY 4059 ! THE VARIABLE NAME AS A STRING. THE WORD CONSISTS OF 4060 ! BITS 2**31 TO 2**20 TYPE INFORMATION (MAY BE LANGUAGE DEPENDENT 4061 ! BIT 2**19 =0 UNDER LNB =1 IN GLA 4062 ! BITS 2**18 TO 2**0 DISPLACEMENT FROM LNB(GLA) IN BYTES 4063 ! 4064 ! 4065 ! THE ENVIRONMENT IS A POINTER (RELATIVE TO SST) OF THE NEXT OUTERMOST 4066 ! BLOCK OR A POINTER TO GLOBAL OWNS, EXTERNAL OR COMMON AREAS 4067 ! A ZERO MEANS NO ENCLOSING BLOCK. WORD1=WORD3=0 IS AN 4068 ! IMP MAIN PROGRAM AND WILL TERMINATE THE DIAGNOSTICS. 4069 ! 4070 %ROUTINE DTABLE(%INTEGER LEVEL) 4071 !*********************************************************************** 4072 !* THIS ROUTINE LOOKS AT THE DECLARATIONS FOR THE CURRENT LEVEL & * 4073 !* SETS UP THE SEGMENT OF SHARABLE SYMBOL TABLES TO DESCRIBE THEM.* 4074 !* FOR MAIN PROGRAMS OR EXTERNAL ROUTINES THE 'GLOBAL' VARIABLES * 4075 !* (IF ANY) ARE ALSO INCLUDED. * 4076 !*********************************************************************** 4077 %STRING(31) RT NAME 4078 %STRING(11) LOCAL NAME 4079 %RECORD(LISTF)%NAME LCELL{(LISTF) 4080 %CONSTINTEGER LARRROUT=16_F300 4081 %INTEGER DPTR,LNUM,ML,KK,JJ,Q,DEND,BIT,S1,S2,S3,S4,LANGD,II 4082 %INTEGERARRAY DD(0:500); ! BUFFER FOR SEGMENT OF SST 4083 ! 4084 ! FILL ALL OUTSTANDING REFERENCES TO THIS DIAGS BLOCK 4085 ! 4086 BIT=1<>14<<30!LEVEL<<18; ! GET LITL FROM PTYPE 4088 %WHILE RAL(LEVEL)#0 %CYCLE 4089 POP(RAL(LEVEL),Q,JJ,KK) 4090 PLUG(Q,JJ,KK!SSTL,4) 4091 %REPEAT 4092 PUSH(RAL(LEVEL-1),4,SSTL+4,LANGD) %IF PARMTRACE#0 4093 DD(0)=L(LEVEL)<<16!(DIAGINF(LEVEL)) 4094 DD(1)=LANGD 4095 DD(2)=DISPLAY(RLEVEL)<<16!FLAG(LEVEL)&16_3FFF 4096 ML=M(LEVEL); ! ROUTINE NAME(=0 FOR %BEGIN) 4097 LNUM=BYTEINTEGER(DICTBASE+ML); ! LENGTH OF THE NAME 4098 DPTR=4; DEND=0 4099 %IF LNUM=0 %THEN DD(3)=0 %ELSE %START 4100 Q=DICTBASE+ML 4101 RT NAME<-STRING(Q); ! FOR RTS MOVE IN 1ST 32 CHARS 4102 LNUM=BYTE INTEGER(ADDR(RT NAME)) 4103 STRING(ADDR(DD(3)))=RTNAME; ! AND UPDATE POINTER PAST 4104 DPTR=DPTR+LNUM>>2; ! ACTUAL NO OF CHARS 4105 %FINISH 4106 DD(DPTR)=ONWORD(LEVEL); ! ON CONDITION WORD 4107 DPTR=DPTR+1 4108 JJ=NAMES(LEVEL) 4109 %WHILE 0<=JJ<16_3FFF %CYCLE 4110 LCELL==ASLIST(TAGS(JJ)) 4111 ! OBTAIN NEXT NAME FORM DECLNS 4112 %IF LCELL_S1&16_F000=0 %THEN WARN(2,JJ) 4113 ! 4114 ! GET ONLY THE MINIMUM OF DETALS NECESSARY 4115 ! 4116 S1=LCELL_S1; S2=LCELL_S2 4117 S3=LCELL_S3; S4=LCELL_LINK 4118 LCELL_LINK=ASL; ASL=TAGS(JJ) 4119 TAGS(JJ)=S4&16_3FFFF 4120 PTYPE=S1>>16; TYPE=PTYPE&15 4121 I=S1>>4&15 4122 J=S1&15 4123 K=S3>>16 4124 ! 4125 ! ALLOW OWNS (LITL=0) AND EXTERNALS (=2) NOT CONSTS(=1) OR EXTRINSIC(=3) 4126 ! 4127 %IF PARMDIAG#0 %AND PTYPE&16_7300<=16_200 %AND DPTR<497 %AND (TYPE=1 %OR TYPE=2 %OR TYPE=5) %START 4128 Q=DICTBASE+WORD(JJ); ! ADDRESS OF NAME 4129 %IF I=0 %THEN II=1 %ELSE II=0; ! GLA OR LNB BIT 4130 DD(DPTR)=PTYPE<<20!II<<18!K 4131 LOCAL NAME<-STRING(Q); ! TEXT OF NAME FROM DICTIONARY 4132 LNUM=BYTE INTEGER(ADDR(LOCAL NAME)) 4133 STRING(ADDR(DD(DPTR))+4)=LOCAL NAME;! MOVE IN NAME 4134 DPTR=DPTR+(LNUM+8)>>2 4135 %FINISH 4136 %IF J=15 %AND S2#0 %THEN FAULT2(28,0,JJ) 4137 ! SPEC&CALLED BUT NO BODY GIVEN 4138 %IF PTYPE&16_3000#0 %OR TYPE=4 %OR TYPE=6 %THEN CLEAR LIST(K) %ELSE %START 4139 %IF I#0 %AND K>511 %AND PTYPE&LARRROUT=0 %AND TYPE#7 %THEN WARN(5,JJ) 4140 %FINISH 4141 JJ=S4>>18 4142 %REPEAT 4143 DD(DPTR)=-1; ! 'END OF SEGMENT' MARK 4144 DPTR=DPTR<<2+4 4145 %IF PARMTRACE=1 %THEN %START 4146 LPUT(4,DPTR,SSTL,ADDR(DD(0)));! ADD TO SHARABLE SYM TABS 4147 SSTL=SSTL+DPTR 4148 %FINISH 4149 %END; ! OF ROUTINE DTABLE 4150 %END 4151 %ROUTINE MAKE DECS(%INTEGER Q) 4152 !*********************************************************************** 4153 !* Q IS TO AR ENTRY FOR HEAD OF LINKED DECLARATIONS * 4154 !*********************************************************************** 4155 %INTEGER QQ,HEAD,PRIO,COUNT,SL 4156 %INTEGERNAME THEAD 4157 %RECORD(LISTF)%NAME CELL{(LISTF) 4158 SL=LINE; QQ=FROM AR4(Q) 4159 HEAD=0; COUNT=0 4160 %WHILE QQ#0 %CYCLE 4161 COUNT=COUNT+1 4162 ABORT %UNLESS A(QQ+5)=8; ! LINE IS A DECLARATION 4163 P=QQ+10; CLT 4164 %IF PREC=3 %OR A(P)#1 %OR A(P+1)# 3 %START 4165 INSERT AT END(HEAD,16_FFFF,QQ,0) %IF A(P)=1 4166 %FINISH %ELSE %START 4167 PRIO=PREC<<4!TYPE 4168 THEAD==HEAD 4169 %CYCLE 4170 CELL==ASLIST(THEAD) 4171 %IF THEAD=0 %OR PRIO=7 %START 4182 GET WSP(QQ,2); ! A DIUBLE WORD 4183 %IF AVL WSP(1,LEVEL)=0 %THEN GET WSP(QQ,1) 4184 %FINISH 4185 %WHILE HEAD#0 %CYCLE 4186 POP(HEAD,PRIO,QQ,COUNT) 4187 LINE=FROM AR2(QQ+3) 4188 P=QQ+10; CLT 4189 ROUT=0; LITL=0 4190 CQN(P+1); P=P+2 4191 DECLARE SCALARS(1,0) 4192 %REPEAT 4193 LINE=SL 4194 %END 4195 %ROUTINE DECLARE SCALARS(%INTEGER PERMIT,XTRA) 4196 !*********************************************************************** 4197 !* THIS ROUTINE DECLARES A LIST OF SCALARS FROM INFORMATION * 4198 !* IN THE GLOBAL VARIABLES ROUT,NAM,ARR,PREC,TYPE & ACC.IT WORKS * 4199 !* OUT ROUNDING FACTORS FOR ITSELF. * 4200 !* P POINTS TO THE NAMELIST ON ENTRY AND IS UPDATED. * 4201 !*********************************************************************** 4202 %INTEGER INC,Q,SCHAIN,DMADE,NPARMS,D0,SCAL NAME,TYPEP 4203 PACK(PTYPE); J=0 4204 INC=ACC; DMADE=0; SNDISP=0 4205 %IF PTYPE=16_33 %THEN INC=(INC+3)&(-4) 4206 %IF NAM#0 %AND ROUT=0 %AND ARR=0 %THEN INC=8 4207 %IF NAM>0 %AND ARR>0 %THEN INC=16 4208 %IF PTYPE=16_35 %AND ACC=0 %THEN FAULT(70,0) 4209 %IF PERMIT#0 %AND (INC=8 %OR INC=16) %THEN ODD ALIGN 4210 %IF PTYPE=16_33 %OR (PTYPE=16_35 %AND PERMIT#0)%START 4211 D0=16_18000000+ACC 4212 STORE CONST(Q,4,ADDR(D0)) 4213 PF1(LDTB,0,PC,Q) 4214 GRUSE(DR)=0 4215 %FINISH 4216 %IF PTYPE=16_35 %START 4217 INC=8 4218 %IF PERMIT#0 %START 4219 PF1(STSF,0,TOS,0) 4220 PF1(LDA,0,TOS,0) 4221 %FINISH 4222 %FINISH 4223 N=(N+3)&(-4) 4224 %IF PTYPE=16_33 %THEN %START 4225 PSF1(LDA,1,PTR OFFSET(RBASE)) 4226 PSF1(INCA,0,N+8) 4227 %FINISH 4228 {%UNTIL A(P-1)=2} %CYCLE; ! DOWN THE NAMELIST 4229 DMADE=DMADE+1 4230 SCAL NAME=FROM AR2(P) 4231 %IF PTYPE=16_31 %AND PERMIT=0 %THEN N=N+3;! BYTE PARAMS 4232 %IF PTYPE=16_41 %AND PERMIT=0 %THEN N=N+2 4233 SCHAIN=N 4234 KFORM=XTRA 4235 %IF ROUT=1 %THEN %START 4236 TYPEP=PTYPE; ! CHANGED BY CFPLIST! 4237 Q=P 4238 P=P+3 %UNTIL A(P-1)=2; ! TO FPP 4239 CFPLIST(SCHAIN,NPARMS) 4240 P=Q 4241 J=13 4242 KFORM=NPARMS; ! NO OF PARAMS OF FORMAL 4243 ACC=N; ! DISPLACEMENT TO MIDCELL 4244 PTYPE=TYPEP; UNPACK 4245 %FINISH 4246 P=P+3 4247 %IF PTYPE=16_33 %THEN %START 4248 PSF1(STD,1,N) 4249 N=N+8; SCHAIN=N 4250 %IF A(P-1)=1 %THEN PSF1(INCA,0,INC+8) 4251 %FINISH 4252 %IF PTYPE=16_35 %AND PERMIT#0 %START 4253 PSF1(STD,1,N) 4254 %IF A(P-1)=1 %THEN PSF1(INCA,0,(ACC+3)&(-4)) %ELSE %START 4255 Q=((ACC+3)>>2)*DMADE 4256 PSF1(ASF+12*PARMCHK,0,Q) 4257 %IF PARMCHK#0 %THEN PPJ(0,4) 4258 %FINISH 4259 %FINISH 4260 STORE TAG(SCAL NAME,SCHAIN) 4261 N=N+INC 4262 %REPEAT %UNTIL A(P-1)=2 4263 N=(N+3)&(-4) %IF PERMIT#0;! NO ROUNDING AMONG PARAMS 4264 %END 4265 %INTEGERFN DOPE VECTOR(%INTEGER TYPEP,ELSIZE,MODE,IDEN,%INTEGERNAME ASIZE,LB) 4266 !*********************************************************************** 4267 !* CONSTRUCTS THE DOPE-VECTOR FOR A CONSTANT ARRAY IN THE * 4268 !* SHAREABLE SYMBOL TABLES AND RETURNS ITS DISPLACEMENT AS RESULT* 4269 !* EVENTUALLY ALL NON DYNAMIC DOPE VECTORS SHOULD GO VIA HERE * 4270 !* P IS TO ALT (MUST BE 1!) OF P * 4271 !* DOPE VECTOR CONSISTS OF :- * 4272 !* DESRIPTOR (SCALED WORD) POINTING AT FIRST TRIPLE BND=3*ND * 4273 !* SIZE (IN BYTES OF ENTIRE ARRAY) FOR STACK ADJUSTMENT * 4274 !* AND ND TRIPLES EACH CONSISTING OF:- * 4275 !* LBI - THE LOWER BOUND OF THE ITH DIMENSION * 4276 !* MI - THE STRIDE FOR THE ITH DIMENSION * 4277 !* CBI THE UPPER CHECK =(UBI-LBI+1)*MI * 4278 !* WHERE M1=1(SCALED ARRAYS) OR THE ELEMENT SIZE AND * 4279 !* MI = M(I-1)*RANGE(I-1) * 4280 !* MODE=0 DV MUST BE CONST, MODE#0 CAN BE DYNAMIC * 4281 !* P TO ALT (ALWAYS=1) OF P(BPAIR) * 4282 !*********************************************************************** 4283 %INTEGER I, JJ, K, ND, D, UNSCAL, M0, HEAD, NOPS, TYPEPP, PIN, PTR 4284 %RECORD(LISTF)%NAME LCELL{(LISTF) 4285 %INTEGERARRAY LBH,LBB,UBH,UBB(0:12) 4286 %INTEGERARRAY DV(0:39); ! ENOUGH FOR 12 DIMENSIONS 4287 ND=0; NOPS=0; TYPEPP=0; PIN=P 4288 %IF TYPEP>2 %OR (TYPEP=1 %AND PREC=4) %THEN UNSCAL=1 %AND M0=ELSIZE %ELSE UNSCAL=0 %AND M0=1 4289 {%UNTIL A(P)=2} %CYCLE 4290 ND=ND+1; P=P+4 4291 LBH(ND)=0; LBB(ND)=0 4292 UBB(ND)=0; UBH(ND)=0 4293 TORP(LBH(ND),LBB(ND),NOPS) 4294 P=P+3 4295 TYPEPP=TYPEPP!TYPE 4296 TORP(UBH(ND),UBB(ND),NOPS) 4297 TYPEPP=TYPEPP!TYPE 4298 %REPEAT %UNTIL A(P)=2 4299 P=P+1 4300 ->NONCONST %UNLESS TYPEPP=1 %AND NOPS&16_40040000=0 4301 ! 4302 ! NOW ONE CAN WORK OUT AND FILL IN THE TRIPLES 4303 ! 4304 PTR=1 4305 %CYCLE D=ND,-1,1 4306 K=3*D 4307 EXPOP(LBH(PTR),ACCR,NOPS,16_251) 4308 EXPOPND_D=0 %AND FAULT(41,0) %UNLESS EXPOPND_FLAG<=1 %AND EXPOPND_PTYPE=16_51 4309 DV(K)=EXPOPND_D 4310 DV(K+1)=M0 4311 EXPOP(UBH(PTR),ACCR,NOPS,16_251) 4312 EXPOPND_D=10 %AND FAULT(41,0) %UNLESS EXPOPND_FLAG<=1 %AND EXPOPND_PTYPE=16_51 4313 JJ=EXPOPND_D 4314 M0=M0*(JJ-DV(K)+1) 4315 FAULT2(38,1-M0,IDEN) %UNLESS JJ>=DV(K) 4316 DV(K+2)=M0 4317 PTR=PTR+1 4318 %REPEAT 4319 ! 4320 %IF UNSCAL=0 %THEN M0=M0*ELSIZE 4321 %IF ND=1 %THEN LB=DV(3) 4322 ASIZE=M0 4323 DV(2)=ASIZE 4324 DV(1)=12 4325 DV(0)=5<<27!3*ND; ! DESPTR FOR DV 4326 K=3*ND+2 4327 J=ND; ! DIMENSIONALITY FOR DECLN 4328 HEAD=DVHEADS(ND) 4329 %WHILE HEAD#0 %CYCLE 4330 LCELL==ASLIST(HEAD) 4331 %IF LCELL_S2=ASIZE %AND LCELL_S3=DV(5) %START 4332 %CYCLE D=0,1,K 4333 ->ON %UNLESS DV(D)=CTABLE_val(D+LCELL_S1) 4334 %REPEAT 4335 %RESULT=16_80000000!4*LCELL_S1 4336 %FINISH 4337 ON: 4338 HEAD=LCELL_LINK 4339 %REPEAT 4340 %IF CONST PTR&1#0 %THEN CONST HOLE=CONST PTR %AND CONST PTR=CONST PTR+1 4341 I=4*CONST PTR!16_80000000 4342 PUSH(DVHEADS(ND),CONSTPTR,ASIZE,DV(5)) 4343 %CYCLE D=0,1,K 4344 CTABLE_val(CONST PTR)=DV(D) 4345 CONST PTR=CONST PTR+1 4346 %REPEAT 4347 %IF CONST PTR>CONST LIMIT %THEN FAULT(107,0) 4348 WAYOUT: 4349 %CYCLE D=ND,-1,1 4350 ASLIST(LBB(D))_LINK=ASL 4351 ASL=LBH(D) 4352 ASLIST(UBB(D))_LINK=ASL 4353 ASL=UBH(D) 4354 %REPEAT 4355 %RESULT =I 4356 NONCONST: ! NOT A CONST DV 4357 J=ND; I=-1 4358 LB=0; ASIZE=ELSIZE 4359 %IF MODE=0 %THEN FAULT(41,0) %ELSE P=PIN 4360 ->WAYOUT 4361 %END 4362 4363 %ROUTINE DECLARE ARRAYS(%INTEGER FORMAT, FINF) 4364 !*********************************************************************** 4365 !* FORMAT=1 FOR 'ARRAYFORMAT' =0 OTHERWISE * 4366 !* FINF>0 FOR RECORD FORMAT INFORMATION =0 OTHERWISE * 4367 !* P IS AT P IN * 4368 !* * 4369 !* P= * 4370 !* P = '('':'*')' * 4371 !* * 4372 !* ARRAYS WITH CONSTANT BOUNDS HAVE THEIR D-V IN THE SST * 4373 !* ALL OTHER ARRAYS HAVE A DOPE VECTOR AMONG THE LOCALS AND GET * 4374 !* THEIR SPACE OFF THE STACK AT RUN TIME * 4375 !* BOTH SORTS OF ARRAYS HAVE A FOUR WORD HEAD AND D-V TO EMAS * 4376 !* SYSTEM STANDARDS * 4377 !*********************************************************************** 4378 %ROUTINESPEC CLAIM AS 4379 %INTEGER DVDISP, PP, DVF, ELSIZE, TOTSIZE, D0, D1, PTYPEP, {%C 4380+ ARRP, NN, ND, II, JJ, QQ, R, CDV, UNSCAL, DESC, SC, {%C 4381+ LWB, PTYPEPP, JJJ, JJJJ, ADJ 4382 %IF STACK#0 %AND FLAG(LEVEL)=0=NMDECS(LEVEL)>>14 %START 4383 PSF1(STSF,1,N) 4384 NMDECS(LEVEL)=NMDECS(LEVEL)!(N<<14) 4385 N=N+4 4386 %FINISH 4387 %IF STACK=0 %THEN SAVE AUX STACK 4388 ARRP=2*FORMAT+1; ARR=ARRP; PACK(PTYPEP) 4389 ELSIZE=ACC 4390 %IF TYPE>2 %OR (TYPE=1 %AND PREC=4) %THEN UNSCAL=1 %AND SC=3 %ELSE UNSCAL=0 %AND SC=PREC 4391 DESC=SC<<27!UNSCAL<<25!(1-PARMARR)<<24;! ARRAY DESCRIPTOR SKELETON 4392 %IF PREC=4 %THEN DESC=16_58000002 4393 START:NN=1; P=P+1; ! NO OF NAMES IN NAMELIST 4394 PP=P; CDV=0; PTYPEPP=PTYPEP 4395 P=P+3 %AND NN=NN+1 %WHILE A(P+2)=1 4396 P=P+3 4397 DVDISP=DOPE VECTOR(TYPE,ELSIZE,1,FROMAR2(PP),TOTSIZE,LWB) 4398 ND=J 4399 ->CONSTDV %UNLESS DVDISP=-1 4400 ! NORMAL CASE - PLANT CODE TO SET UP DOPE-VECTOR AT RUN TIME 4401 4402 DVF=0; TOTSIZE=16_FFFF 4403 DVDISP=N; ! DVDISP IS D-V POSITION 4404 N=N+12*ND+12; ! CLAIM SPACE FOR THE D-V 4405 FAULT(37,0) %IF ND>12; ! TOO MANY DIMENSIONS 4406 D0=5<<27!3*ND; D1=12; ! DESCPTR FOR DV 4407 STORE CONST(JJ,8,ADDR(D0)) 4408 PF1(LD,0,PC,JJ) 4409 PSF1(STD,1,DVDISP) 4410 GRUSE(DR)=0 4411 4412 %IF UNSCAL=0 %THEN JJ=1 %ELSE JJ=ELSIZE 4413 PSF1(LSS,0,JJ); ! M1 THE FIRST MULTIPLIER 4414 GRUSE(ACCR)=0 4415 %CYCLE II=ND,-1,1 4416 P=P+1 4417 QQ=DVDISP+12*II; ! TRIPLE FOR IITH DIMENSION 4418 PSF1(ST,1,QQ+4); ! STORE MULTIPLIER 4419 CSEXP(ACCR,16_51); ! LOWER BOUND 4420 %IF ND=1 %AND PTYPEP&7<=3 %AND FORMAT=0 %AND GRUSE(ACCR)=5 %AND GRINF1(ACCR)=0 %THEN PTYPEPP=PTYPEPP+256 4421 PSF1(ST,1,QQ); ! STORED IN DV 4422 CSEXP(ACCR,16_51); ! UPPER BOUND 4423 PSF1(ISB,1,QQ) 4424 GRUSE(ACCR)=0 4425 %IF COMPILER=0 %OR PARMARR#0 %START 4426 PF3(JAF,6,0,3); ! JUMP UNLESS NEGATIVE 4427 PSF1(LSS,0,-1); ! SET UP -1 (ENSURES 0 ELEMENTS 4428 %FINISH 4429 PSF1(IAD,0,1); ! CONVERTED TO RANGE 4430 PSF1(IMY,1,QQ+4); ! RANGE*MULTIPLIER 4431 PSF1(ST,1,QQ+8); ! AND STORED IN DV 4432 %REPEAT 4433 P=P+1 4434 %IF UNSCAL=0 %AND ELSIZE#1 %THEN PSF1(IMY,0,ELSIZE) 4435 PSF1(ST,1,DVDISP+8) 4436 SNDISP=0; ! DV NOT AVAILABLE AT COMPILETIME 4437 ->DECL 4438 CONSTDV: ! ONE DIMENSION - CONSTANT BOUNDS 4439 DVF=1; CDV=1 4440 %IF ND=1 %AND LWB=0 %AND PTYPEP&15<=3 %AND FORMAT=0 %THEN PTYPEPP=PTYPEP+256 4441 ! SET ARR=2 IF LWB=ZERO 4442 SNDISP=(DVDISP&16_FFFFFF)>>2 4443 DECL: ! MAKE DECLN - BOTH WAYS 4444 J=ND 4445 ODD ALIGN 4446 PTYPE=PTYPEPP; UNPACK 4447 %IF DVF#0 %THEN %START; ! ARRAY IS STRING OF LOCALS 4448 R=TOTSIZE 4449 %IF UNSCAL=0 %THEN R=R//ELSIZE 4450 D0=DESC 4451 D0=D0!R %UNLESS PREC=4 4452 STORE CONST(D1,4,ADDR(D0)) 4453 PF1(LB,0,PC,D1) 4454 %FINISH %ELSE %START 4455 STORE CONST(D1,4,ADDR(DESC)) 4456 PF1(LB,0,PC,D1) 4457 PSF1(ADB,1,DVDISP+20) %UNLESS PREC=4 4458 %FINISH 4459 %IF DVF#0 %THEN QQ=PC %ELSE QQ=LNB 4460 PSORLF1(LDRL,0,QQ,DVDISP) 4461 GRUSE(BREG)=0; GRUSE(DR)=0 4462 %CYCLE JJJ=0,1,NN-1; ! DOWN NAMELIST 4463 PSF1(STB,1,N+16*JJJ); ! ARRAY BOUND 4464 PSF1(STD,1,N+8+16*JJJ); ! DV POINTER 4465 %REPEAT 4466 %IF PARMARR=0 %AND PARMCHK=0 %AND ND=1 %AND TYPE<=3 %AND PTYPEPP&16_F00#16_200 %THEN ADJ=1 %ELSE ADJ=0 4467 %CYCLE JJJ=0,1,NN-1; ! DOWN NAMELIST 4468 %IF ADJ#0 %START; ! ADJUST DESC 4469 %IF STACK#0 %START; ! ARRAY ON AUTOMATIC STACK 4470 PF1(STSF,0,BREG,0); ! CURRENT SF TO B 4471 %IF DVF#0 %THEN PSF1(SBB,0,LWB*ELSIZE) %ELSE %START 4472 %IF ELSIZE=1 %THEN PSF1(SBB,1,DVDISP+12) %ELSESTART 4473 PSF1(SLB,1,DVDISP+12) 4474 PSF1(MYB,0,ELSIZE) 4475 PF1(SLB,0,TOS,0) 4476 PF1(SBB,0,TOS,0) 4477 %FINISH 4478 %FINISH 4479 PSF1(STB,1,N+4) 4480 GRUSE(BREG)=0 4481 %FINISH %ELSE %START; ! ARRAY ON AUX STACK 4482 %IF DVF#0 %START; ! CONST DOPE VECTOR 4483 %UNLESS GRUSE(ACCR)=11 %%START 4484 PSF1(LSS,2,AUXSBASE(LEVEL)) 4485 GRUSE(ACCR)=11; GRINF1(ACCR)=0 4486 %FINISH 4487 JJJJ=LWB*ELSIZE-GRINF1(ACCR) 4488 PSF1(ISB,0,JJJJ) %UNLESS JJJJ=0 4489 GRINF1(ACCR)=LWB*ELSIZE 4490 %FINISH %ELSE %START; ! DYNAMIC ARRAYS 4491 %IF GRUSE(ACCR)=11 %AND GRINF1(ACCR)=0 %AND ELSIZE=1 %THEN PSF1(ISB,1,DVDISP+12) %ELSESTART 4492 PSF1(LSS,1,DVDISP+12) 4493 PSF1(IMY,0,ELSIZE) %UNLESS ELSIZE=1 4494 PSF1(IRSB,2,AUXSBASE(LEVEL)) 4495 %FINISH 4496 GRUSE(ACCR)=0 4497 %FINISH 4498 PSF1(ST,1,N+4) 4499 %FINISH 4500 %FINISH %ELSE %START; ! NO ADJUSTMENT OF DESCRPT 4501 %IF STACK#0 %THEN PSF1(STSF,1,N+4) %ELSE %START 4502 PSF1(LSS,2,AUXSBASE(LEVEL)) %UNLESS GRUSE(ACCR)=11 %AND GRINF1(ACCR)=0 4503 PSF1(ST,1,N+4) 4504 GRUSE(ACCR)=11; GRINF1(ACCR)=0 4505 %FINISH 4506 %FINISH 4507 4508 ACC=ELSIZE; ! RESET ACC AFTER DV CMPLD 4509 KFORM=FINF; ! FORMAT INFORMATION 4510 K=FROM AR2(PP+3*JJJ) 4511 STORE TAG(K,N) 4512 CLAIM AS %IF FORMAT = 0 4513 N=N+16 4514 %REPEAT 4515 P=P+1; ! PAST REST OF ARRAYLIST 4516 %IF A(P-1)=1 %THEN ->START 4517 %RETURN 4518 %ROUTINE CLAIM AS 4519 !*********************************************************************** 4520 !* CLAIM THE SPACE FOR AN ARRAY FROM STACK OR AUX STACK * 4521 !*********************************************************************** 4522 %INTEGER T, B, D,ADJMENT 4523 %IF STACK=1 %THEN %START; ! FROM AUTOMATIC STACK 4524 %IF CDV=1 %THEN %START; ! CONSTANT BOUNDS 4525 T=(TOTSIZE+3)//4 4526 PSF1(ASF+12*PARMCHK,0,T); ! ASF OR LB 4527 PPJ(0,4) %IF PARMCHK#0 4528 %FINISH %ELSE %START; ! DYNAMIC BOUNDS 4529 %IF PARMCHK=0 %AND PTYPEP&7<=2 %AND (ELSIZE=4 %OR ELSIZE=8) %START 4530 PSF1(ASF,1,DVDISP+20); ! SIZE IN ELEMENTS WORD 4531 PSF1(ASF,1,DVDISP+20) %IF ELSIZE=8 4532 %FINISH %ELSE %START 4533 PSF1(LSS,1,DVDISP+8); ! ARRAY SIZE BYTES 4534 PSF1(IAD,0,3) %IF ELSIZE&3#0 4535 PSF1(USH,0,-2); ! ARRAY SIZE WORDS 4536 PF1(ST,0,BREG,0) 4537 FORGET(BREG) 4538 %IF PARMCHK#0 %THEN PPJ(0,4) %ELSE PF1(ASF,0,BREG,0) 4539 %FINISH 4540 %FINISH 4541 CHECK STOF 4542 %FINISH %ELSE %START 4543 %UNLESS GRUSE(ACCR)=11 %AND (GRINF1(ACCR)=0 %OR CDV=1) %START 4544 PSF1(LSS,2,AUXSBASE(LEVEL)) 4545 GRUSE(ACCR)=11; GRINF1(ACCR)=0 4546 %FINISH 4547 %IF CDV=1 %THEN %START 4548 ADJMENT=(TOTSIZE+7)&(-8)+GRINF1(ACCR) 4549 %IF ADJMENT<16_1FFFF %THEN B=0 %AND D=ADJMENT %ELSE %START 4550 STORE CONST(D,4,ADDR(ADJMENT)) 4551 B=PC 4552 %FINISH 4553 %IF ADJ=1 %AND JJJ#NN-1 %AND PARMOPT=0 %THEN GRINF1(ACCR)=ADJMENT %ELSE %START 4554 GRINF1(ACCR)=0 4555 PSORLF1(IAD,0,B,D) %UNLESS B=D=0 4556 %FINISH 4557 %FINISH %ELSE %START 4558 B=LNB; D=DVDISP+8 4559 PSF1(IAD,1,D) 4560 %UNLESS ELSIZE&7=0 %START 4561 PSF1(IAD,0,7) 4562 PSF1(AND,0,-8) 4563 %FINISH 4564 GRINF1(ACCR)=0 4565 %FINISH 4566 PSF1(ST,2,AUXSBASE(LEVEL)) %IF JJJ=NN-1 %OR (ADJ=1 %AND CDV=0) 4567 %IF PARMOPT#0 %THEN %START 4568 PSF1(ICP,1,AUXSBASE(LEVEL)+16) 4569 PPJ(2,8) 4570 %FINISH 4571 %IF PARMCHK#0 %START 4572 PF1(LDTB,0,PC,PARAM DES(3)) 4573 PSORLF1(LDB,0,B,D) 4574 PSF1(LDA,1,N+4) 4575 PF2(MVL,1,1,0,0,UNASSPAT&255) 4576 GRUSE(DR)=0 4577 %FINISH 4578 %FINISH 4579 %END 4580 %END 4581 ! %ROUTINE TEST NST 4582 !!*********************************************************************** 4583 !!* SEE IF NAME 'K' HAS BEEN DECLARED BEFORE AT THIS LEVEL * 4584 !!*********************************************************************** 4585 ! FNAME=K 4586 ! FAULT(7,FNAME) %IF FROM1(TAGS(FNAME))>>8&15=LEVEL 4587 ! %END 4588 %ROUTINE CLT 4589 !*********************************************************************** 4590 !* DEAL WITH PHRASE TYPE AND SET PREC,TYPE & ACC * 4591 !* ONLY PROBLEM IS STRING WHICH HAS OPTIONAL MAX LENGTH ALSO * 4592 !* P ON PHRASE TYPE AT ENTRY - TO NEXT PHRASE AT EXIT. * 4593 !*********************************************************************** 4594 %CONSTBYTEINTEGERARRAY TYPEFLAG(1:10)= {%C 4595+ 16_51,16_52,0,16_31,16_35, 4596+ 16_41,0,16_62,16_61,16_72; 4597 %INTEGER ALT 4598 ALT=A(P) 4599 TYPE=TYPEFLAG(ALT) 4600 %IF TYPE=0 %THEN P=P+1 %AND TYPE=TYPEFLAG(A(P)+7) 4601 PREC=TYPE>>4 4602 TYPE=TYPE&7 4603 PREC=6 %IF TYPE=2 %AND ALL LONG#0 %AND PREC<=5;! DEAL WITH '%REALSLONG' 4604 ACC=BYTES(PREC) 4605 %IF TYPE=5 %THEN %START; ! P='%STRING' 4606 %IF A(P+1)=1 %THEN %START;! MAX LENGTH GIVEN 4607 P=P+2 4608 ACC=A(P)+1 4609 %FINISH %ELSE ACC=0 %AND P=P+1 4610 %FINISH 4611 P=P+1 4612 %END 4613 %ROUTINE CQN(%INTEGER P) 4614 !*********************************************************************** 4615 !* SET NAM,ARR & ACC FROM ALTERNATIVE OF PHRASE * 4616 !* P='%ARRAYNAME','%NAME',<%NULL> * 4617 !* P POINTS TO THE ANALYSIS RECORD ENTRY AS IS NOT UPDATED * 4618 !*********************************************************************** 4619 %INTEGER I 4620 I=A(P);NAM=0;ARR=0 4621 %IF I=1 %THEN ARR=1 %AND ACC=16;! ARRAYNAMES 4622 %IF I<=2 %THEN NAM=1; ! ARRAYNAMES & NAMES 4623 %IF I=2 %THEN ACC=8; ! NAMES USE 8-BYTE DESCRIPTOR 4624 %END 4625 %ROUTINE CRSPEC (%INTEGER M) 4626 !*********************************************************************** 4627 !* MODE=0 FOR NORMAL ROUTINE SPEC * 4628 !* MODE=1 FOR EXTERNAL(ETC) ROUTINE SPECS XREF NEEDED * 4629 !* P ON ENTRY TO P(RT) IN (RT)(MARK)(%SPEC')(NAME)(FPP) * 4630 !*********************************************************************** 4631 %INTEGER KK,JJ,TYPEP,OPHEAD,NPARMS 4632 %STRING(34) XNAME 4633 LITL=EXTRN&3 4634 %IF A(P)=1 %THEN %START; ! P=%ROUTINE 4635 TYPEP=LITL<<14!16_1000 4636 P=P+2; ! IGNORING ALT OF P(SPEC') 4637 %FINISH %ELSE %START; ! P= 4638 ROUT=1; ARR=0; P=P+1 4639 CLT; NAM=0 4640 %IF A(P)=2 %THEN NAM=2; ! 2 FOR MAP 0 FOR FN 4641 PACK(TYPEP) 4642 P=P+2; ! AGAIN IGNORING ALT OF P(SPEC') 4643 %FINISH 4644 P=P+4; ! PAST HOLE FOR DECLINKS 4645 KK=FROM AR2(P) 4646 JJ=0 4647 P=P+2 4648 CFPLIST(OPHEAD,NPARMS) 4649 %IF M=1 %THEN %START 4650 XNAME<-STRING(DICTBASE+WORD(KK)) 4651 %IF EXTRN=1 %THEN XNAME<-"S#".XNAME 4652 CXREF(XNAME,PARMDYNAMIC!(EXTRN//3),2,JJ); ! %STSTEM & %EXTERNAL =STATIC 4653 ! %DYNAMIC = DYNAMIC 4654 %FINISH 4655 %IF M=0 %AND RLEVEL=0 %THEN CODE DES(JJ) 4656 J=15-M; PTYPE=TYPEP 4657 KFORM=NPARMS 4658 SNDISP=JJ>>16 4659 ACC=JJ&16_FFFF 4660 STORE TAG(KK,OPHEAD) 4661 %END 4662 %ROUTINE CFPLIST(%INTEGERNAME OPHEAD,NPARMS) 4663 !*********************************************************************** 4664 !* COMPILE A FORMAL PARAMETER PART INTO A LIST OF PARAMETER TYPES * 4665 !* P(FPP)='('{(HOLE)(FPDEL)(NAMELIST)(MARK)}*')',0. * 4666 !* * 4667 !* THE LIST OF PARAMETER LOOKS LIKE:- * 4668 !* S1 = PTYPE FOR PARAM<<16! DIMENSION (DIMEN DEDUCED LATER) * 4669 !* S2 = ACC <<16 ! SPARE * 4670 !* S3 = 0 (RESERVED FOR FPP OF RTS) * 4671 !* * 4672 !* ON ENTRY P IS AT ALT OF FPP (WHICH MAY BE NULL) * 4673 !*********************************************************************** 4674 %INTEGER OPBOT, PP 4675 OPHEAD=0; OPBOT=0 4676 NPARMS=0; ! ZERO PARAMETERS AS YET 4677 %WHILE A(P)=1 %CYCLE; ! WHILE SOME(MORE) FPS 4678 PP=P+1+FROMAR2(P+1); ! TO NEXT FPDEL 4679 P=P+3; ! TO ALT OF FPDEL 4680 CFPDEL; ! GET TYPE & ACC FOR NEXT GROUP 4681 {%UNTIL A(P-1)=2} %CYCLE; ! DOWN FOR EACH DEL 4682 BINSERT(OPHEAD,OPBOT,PTYPE<<16,ACC<<16,0) 4683 NPARMS=NPARMS+1 4684 P=P+3 4685 %REPEAT %UNTIL A(P-1)=2; ! DOWN FOR EACH DEL 4686 P=PP 4687 %REPEAT 4688 P=P+1 4689 %END 4690 %ROUTINE CFPDEL 4691 !*********************************************************************** 4692 !* SET UP PTYPE & ACC FOR A FORMAL PARAMETER DEFINITION * 4693 !* P=<%QNAME'>, * 4694 !* '%RECORD'<%ARRAY'>'%NAME'. * 4695 !* (RT)(%NAME')(NAMELIST)(FPP), * 4696 !* '%NAME'. * 4697 !*********************************************************************** 4698 %SWITCH FP(1:4) 4699 %INTEGER FPALT 4700 FPALT=A(P); P=P+1 4701 KFORM=0; LITL=0 4702 ->FP(FPALT) 4703 FP(1): ! (TYPE)(%QNAME') 4704 ROUT=0; CLT 4705 CQN(P) 4706 FAULT(70,0) %IF TYPE=5 %AND ACC=0 4707 P=P+1 4708 ->PK 4709 FP(2): ! RECORD(%ARRAY')%NAME 4710 ARR=2-A(P); ROUT=0 4711 ACC=8+8*ARR; TYPE=3; PREC=3 4712 NAM=1; P=P+1; ->PK 4713 FP(3): ! (RT)(%NAME')(NAMELIST)(FPP) 4714 ROUT=1; NAM=1 4715 ARR=0 4716 %IF A(P)=1 %THEN %START; ! RT=%ROUITNE 4717 TYPE=0; PREC=0 4718 P=P+2 4719 %FINISH %ELSE %START 4720 P=P+1; CLT; ! RT=(TYPE)(FM) 4721 NAM=1 4722 %IF A(P)=2 %THEN NAM=3; ! 1 FOR FN 3 FOR MAP 4723 P=P+2; ! PAST (%NAME') WHICH IS IGNORED 4724 %FINISH 4725 ACC=16 4726 ->PK 4727 FP(4): ! %NAME 4728 ACC=8; NAM=1 4729 ROUT=0; TYPE=0 4730 ARR=0; PREC=0 4731 PK: PACK(PTYPE) 4732 %END 4733 %ROUTINE DIAG POINTER(%INTEGER LEVEL) 4734 %IF PARMTRACE#0 %THEN %START 4735 PUSH(RAL(LEVEL),1,CA,LDB<<24!3<<23) 4736 PF1(LDB,0,0,0) 4737 GRUSE(DR)=0 4738 %FINISH 4739 %END 4740 %ROUTINE RHEAD(%INTEGER KK) 4741 !*********************************************************************** 4742 !* COMPILES CODE FOR BLOCK AND ROUTINE ENTRY * 4743 !* KK IS THE RT/FN/MAP NAME (=-1 FOR %BEGIN BLOCKS) * 4744 !*********************************************************************** 4745 %INTEGER W1, W3, INSRN, AT 4746 PUSH(LEVELINF, 0, NMAX<<16!N, 0) 4747 LEVEL=LEVEL+1 4748 NMDECS(LEVEL)=0; AUXSBASE(LEVEL)=0 4749 NAMES(LEVEL)=-1 4750 ONINF(LEVEL)=0; ONWORD(LEVEL)=0 4751 %IF KK>=0 %THEN %START 4752 RLEVEL=RLEVEL+1; RBASE=RLEVEL 4753 %FINISH 4754 FAULT(34, 0) %IF LEVEL=MAX LEVELS 4755 FAULT(105, 0) %IF LEVEL>MAX LEVELS 4756 %IF KK>=0 %AND RLEVEL>1 %START;! ROUTINE ENTRY 4757 COPY TAG(KK); JJ=K; ! LIST OF JUMPS 4758 J=MIDCELL 4759 %IF J=0 %AND LEVEL>2 %START;! REPLACE 'NOT USED' BIT 4760 REPLACE1(TAGS(KK), FROM1(TAGS(KK))&16_FFFF3FFF) 4761 %FINISH 4762 ! 4763 ! NOW FILL ANY JUMPS TO THIS ROUTINE PLANTED SINCE 4764 ! THE ROUTINESPEC WAS COMPILED. SEE ALSO 'RT JUMP' 4765 ! 4766 %WHILE J#0 %CYCLE 4767 POP(J, INSRN, AT, W1) 4768 W3=CA-AT 4769 W3=W3//2 %IF INSRN>>25=CALL>>1 4770 INSRN=INSRN+W3 4771 PLUG(1, AT, INSRN,4) 4772 %REPEAT 4773 REPLACE2(TAGS(KK), CA); ! NOTE ADDR FOR FUTURE CALLS 4774 %FINISH 4775 %IF KK>=0 %AND RLEVEL=1 %THEN DIAG POINTER(LEVEL) %AND PSF1(STD,1,12) 4776 %IF KK<0 %THEN W3=0 %ELSE W3=WORD(KK) 4777 L(LEVEL)=LINE; M(LEVEL)=W3 4778 FLAG(LEVEL)=PTYPE; ! CURRENT BLOCK TYPE MARKER 4779 %END 4780 %ROUTINE RDISPLAY(%INTEGER KK) 4781 !*********************************************************************** 4782 !* SET UP OR COPY THE DISPLAY (A WORD ARRAY CONTAINING COPIES OF * 4783 !* LNB FOR THE GLOBAL LEVELS. THE HIGHEST LEVEL ENTRY IS TO THE * 4784 !* GLA(PLT) FOR OWNS AND IS ALSO KEPT IN(LNB+4) IN CASE WE WISH * 4785 !* TO MOVE TO READ-ONLY PLTS. ON INTERNAL CALLS THE LNB FOR THE * 4786 !* NEXT MOST GLOBAL LEVEL IS STACKED AS AN EXTRA PARAMETER * 4787 !*********************************************************************** 4788 %INTEGER W1,W2,STACK,OP,INC 4789 %IF KK>=0 %OR LEVEL=2 %START; ! DISPLAY NEEDED 4790 STACK=0; DISPLAY(RLEVEL)=N 4791 GRUSE(XNB)=0 4792 GRUSE(CTB)=0; GRUSE(BREG)=0 4793 %IF LEVEL#2 %THEN %START 4794 ! PF1(LXN,0,TOS,0) 4795 GRUSE(XNB)=4; GRINF1(XNB)=RLEVEL-1; GRAT(XNB)=CA 4796 PF1(LD,0,XNB,12); ! COPY PLT DESCRIPTOR 4797 DIAG POINTER(LEVEL) 4798 PSF1(STD,1,12) 4799 W1=RLEVEL-1; W2=DISPLAY(W1) 4800 %IF W1=1 %THEN PF1(STXN,0,TOS,0) %AND N=N+4 %ELSE %START 4801 %WHILE W1>0 %CYCLE 4802 OP=LSS; INC=1 4803 %IF W1>=2 %THEN OP=LSD %AND INC=2 4804 %IF W1>=4 %THEN OP=LSQ %AND INC=4 4805 PF1(OP+STACK,0,XNB,W2) 4806 STACK=-32; N=N+4*INC 4807 W2=W2+4*INC; W1=W1-INC 4808 %REPEAT 4809 %FINISH 4810 %FINISH 4811 %IF STACK#0 %THEN PF1(ST,0,TOS,0); ! ST TOS 4812 PF1(STLN,0,TOS,0) 4813 N=N+4 4814 %FINISH 4815 ! 4816 ! IF IN DIAGNOSTIC MODE PLANT CODE TO SAVE THE LINE & ROUTINE NO OF 4817 ! THE CALLING ROUTINE AND SET UP THE NEW BLOCK/ROUTINE IDENT NO. 4818 ! 4819 %IF PARMTRACE#0 %START 4820 PF1(LSS,0,PC,4*CONST BTM!16_80000000) %IF PARMOPT#0;! M'IDIA' 4821 %IF KK>=0 %OR LEVEL=2 %START 4822 %IF PARMOPT#0 %THEN %START 4823 PSF1(SLSS,0,LINE) 4824 N=N+4 4825 %FINISH %ELSE PSF1(LSS,0,LINE) 4826 PF1(ST,0,TOS,0) 4827 %FINISH %ELSE %START 4828 %IF PARMOPT#0 %THEN %START 4829 PSF1(ST,1,N) 4830 N=N+4 4831 %FINISH 4832 PSF1(LSS,0,LINE) 4833 PSF1(ST,1,N) 4834 PSF1(LD,1,12); ! UPDATE BND FIELD 4835 DIAG POINTER(LEVEL) 4836 PSF1(STD,1,12) 4837 %FINISH 4838 DIAGINF(LEVEL)=N 4839 N=N+4 4840 GRUSE(ACCR)=0; ! NEEDED FOR %BEGIN BLOCKS 4841 %FINISH 4842 %IF PARMOPT#0 %AND KK>=0 %AND LEVEL=2 %START 4843 PF1(STSF,0,BREG,0) 4844 PF1(STLN,0,TOS,0) 4845 PF1(SBB,0,TOS,0) 4846 PSF1(CPB,0,N) 4847 PPJ(7,13) 4848 %FINISH 4849 ! 4850 ! CLAIM (THE REST OF) THE STACK FRAME 4851 ! 4852 %IF KK>=0 %OR LEVEL=2 %START 4853 SET(RLEVEL)=N<<18!CA 4854 NMAX=N 4855 PF1(ASF+12*PARMCHK,0,0,0); ! ASF OR LB 4856 PPJ(0,4) %IF PARMCHK#0 4857 %FINISH 4858 ! 4859 %IF KK>=0 %AND PARMCHK#0 %START 4860 CHECK STOF; ! CHECK FOR STACK O'FLOW 4861 %FINISH 4862 %IF PARMDBUG#0 %THEN SET LINE; ! TO CALL DBUG PACKAGE 4863 %END 4864 %ROUTINE CHECK STOF 4865 !*********************************************************************** 4866 !* CHECK THE STACK FOR OVERFLOW (LEAVING 4K MARGIN FOR MDIAG * 4867 !*********************************************************************** 4868 %IF PARMOPT#0 %THEN %START 4869 ! 4870 ! STSF TOS GET STACK POINTER 4871 ! LSS TOS 4872 ! USH +14 4873 ! USH -15 LOSE SEGMENT NO 4874 ! ICP 16_1F800 CHECK WITHIN SEG ADDRESS 4875 ! SHIFTED DOWN 1 PLACE 4876 ! JCC 2,EXCESS BLKS 4877 ! 4878 PF1(STSF,0,TOS,0) 4879 PF1(LSS,0,TOS,0) 4880 PSF1(USH,0,14) 4881 PSF1(USH,0,-15) 4882 PF1(ICP,0,0,ST LIMIT>>1) 4883 PPJ(2,8) 4884 %FINISH 4885 %END; ! OF ROUTINE RHEAD 4886 %ROUTINE CIOCP(%INTEGER N,REG) 4887 !*********************************************************************** 4888 !* COMPILES A CALL ON IOCP ENTRY POINT NO 'N' * 4889 !* 2ND PARAMETER IS ALREAD IN THE ACC WHICH IS 32 BITS * 4890 !*********************************************************************** 4891 %INTEGER XYNB,OP1,OP2 4892 %IF IOCPDISP=0 %THEN CXREF(IOCPEP,PARMDYNAMIC,2,IOCPDISP) 4893 %IF REGISTER(BREG)#0 %THEN BOOT OUT(BREG) 4894 %IF REG=ACCR %THEN OP1=LUH %AND OP2=ST %ELSE OP1=LDTB %AND OP2=STD 4895 PSF1(OP1,0,N) 4896 PSF1(PRCL,0,4) 4897 PF1(OP2,0,TOS,0) 4898 XYNB=SET XORYNB(-1,-1); ! TO PLT 4899 PSF1(RALN,0,7) 4900 PF1(CALL,2,XYNB,IOCPDISP) 4901 FORGET(-1) 4902 %END 4903 %ROUTINE CUI(%INTEGER CODE) 4904 !*********************************************************************** 4905 !* COMPILE AN UNCONDITIONAL INSTRN WHEREEVER IT OCCURS * 4906 !* CODE=0 UNCONDITIOALLY,=1 AFTER %THEN, =2 AFTER %ELSE * 4907 !*********************************************************************** 4908 %INTEGER MARKER,J,LNAME,TYPEP,PRECP,GWRDD,LWB,XYNB,ARRP,ALT 4909 %SWITCH SW(1:9) 4910 REPORTUI=0 4911 ALT=A(P) 4912 ->SW(ALT) 4913 SW(1): ! (NAME)(APP)(ASSMNT?) 4914 P=P+1; MARKER=P+FROMAR2(P) 4915 %IF A(MARKER)=1 %THEN %START 4916 J=P+2; P=MARKER+2 4917 ASSIGN(A(MARKER+1),J) 4918 %FINISH %ELSE %START 4919 P=P+2 4920 CNAME(0,0) 4921 P=P+1 4922 %FINISH 4923 AUI: J=A(P); P=P+1 4924 %IF J=1 %THEN CUI(CODE) 4925 %RETURN 4926 SW(2): ! -> (NAME)(APP) 4927 NMDECS(LEVEL)=NMDECS(LEVEL)!1 4928 CURR INST=1 %IF CODE=0 4929 LNAME=FROM AR2(P+1) 4930 J=A(P+3); P=P+4 4931 %IF J=2 %THEN %START; ! SIMPLE LABEL 4932 ENTER JUMP(15,LNAME,0) 4933 REPORTUI=1 4934 %FINISH %ELSE %START; ! SWITCH LABELS 4935 COPY TAG(LNAME) 4936 ARRP=ARR 4937 GWRDD=SNDISP<<2; ! BYTE DISP OF DESCRIPTOR IN PLT 4938 %UNLESS OLDI=LEVEL %AND TYPE=6 %START 4939 FAULT(4,LNAME); P=P-1; SKIP APP 4940 %RETURN 4941 %FINISH 4942 LWB=FROM2(K); ! GET LOWER BOUND 4943 CSEXP(BREG,16_51) 4944 %IF ARRP=1 %THEN PSF1(SBB,0,LWB) 4945 XYNB=SET XORYNB(-1,-1); ! TO PLT 4946 PF1(JUNC,3,XYNB,GWRDD); ! JUMP INDIRECT VIA WORD ARRAY 4947 ! OF 32 BIT RELOCATED ADDRESSES 4948 REPORTUI=1; FORGET(-1) 4949 %FINISH 4950 %RETURN 4951 SW(3): ! RETURN 4952 FAULT(30,0) %UNLESS FLAG(LEVEL)&16_3FFF=16_1000 4953 P=P+1 4954 RET: RT EXIT 4955 REPORT UI=1 4956 CURR INST=1 %IF CODE=0 4957 %RETURN 4958 SW(4): ! %RESULT(ASSOP)(EXPR) 4959 PTYPE=FLAG(LEVEL)&16_3FFF; UNPACK 4960 %IF PTYPE>16_1000 %AND A(P+1)#3 %THEN %START;! ASSOP #'->' 4961 %IF A(P+1)=1 %AND NAM#0 %AND A(P+5)=4 %AND A(P+6)=1 %START 4962 P=P+7; TYPEP=TYPE; PRECP=PREC 4963 CNAME(4,ACCR) 4964 FAULT(81,0) %UNLESS A(P)=2; P=P+1 4965 FAULT(83,0) %UNLESS TYPEP=TYPE %AND PRECP=PREC 4966 ->RET 4967 %FINISH 4968 %IF A(P+1)=2 %THEN %START; ! ASSOP='=' 4969 P=P+2 4970 %IF NAM#0 %THEN TYPE=1; ! MAPS HAVE INTEGER RESULTS 4971 %IF TYPE=5 %THEN %START 4972 CSTREXP(0,ACCR) 4973 PSF1(LD,1,DISPLAY(RBASE)-8); ! RESULT DESCRPT 4974 PF1(IAD,0,PC,SPECIAL CONSTS(2)) 4975 PF2(MV,1,1,0,0,UNASSPAT&255) 4976 PSF1(LDB,2,DISPLAY(RBASE)-8) 4977 COPY DR 4978 %FINISH %ELSE %START 4979 %IF PREC<5 %THEN PREC=5 4980 %IF NAM=0 %THEN KK=PREC<<4!TYPE %ELSE KK=16_51 4981 CSEXP(ACCR,KK) 4982 %FINISH; ->RET 4983 %FINISH 4984 %FINISH 4985 FAULT(31,0) 4986 P=P+2; SKIP EXP; ! IGNORE SPURIOUS RESULT 4987 %RETURN 4988 SW(5): ! %MONITOR (AUI) 4989 PSF1(LSD,0,0); ! ERR=0 & EXTRA =0 4990 PPJ(0,2); ! TO ERROR ROUTINE 4991 P=P+1; ->AUI 4992 SW(6): ! %STOP 4993 PPJ(0,21) 4994 P=P+1 4995 CURR INST=1 %IF CODE=0 4996 REPORTUI=1 4997 %RETURN 4998 SW(7): !'%SIGNAL'(EVENT')(N)(OPEXPR) 4999 PSF1(PRCL,0,4) 5000 PSF1(JLK,0,1); ! STACK DUMMY PC 5001 %IF NMDECS(LEVEL)&16 #0 %START;! IN AN 'ON' GROUP 5002 %IF FLAG(LEVEL)<=2 %START; ! IN A BEGIN BLOCK 5003 PSF1(LD,1,12); ! SO RESET DIAG POINTER 5004 DIAGPOINTER(LEVEL-1); ! TO NEXT OUTER BLOCK 5005 PSF1(STD,1,12) 5006 PF1(STLN,0,TOS,0) 5007 %FINISH %ELSE %START; ! 'ON IN A RT/FN/MAP 5008 PSF1(LSS,1,0); ! GET PREVIOUS LNB 5009 PF1(ST,0,TOS,0); ! AND STACK THAT 5010 %FINISH 5011 %FINISH %ELSE PF1(STLN,0,TOS,0) 5012 GRUSE(ACCR)=0 5013 J=A(P+2); ! EVENT NO 5014 FAULT2(26,J,0) %UNLESS 1<=J<=15 5015 %IF A(P+3)=1 %START; ! SUBEVENT SPECIFIED 5016 P=P+4; CSEXP(ACCR,16_51) 5017 PF1(AND,0,0,255) 5018 PF1(OR,0,0,256*J) 5019 %FINISH %ELSE PF1(LSS,0,0,256*J) 5020 PSF1(SLSS,0,0) 5021 PF1(ST,0,TOS,0) 5022 XYNB=SET XORYNB(-1,-1); ! TO PLT 5023 PSF1(RALN,0,9) 5024 PF1(CALL,2,XYNB,40) 5025 CURR INST=1 %IF CODE=0 5026 REPORTUI=1; %RETURN 5027 SW(8): ! %EXIT 5028 SW(9): ! %CONTINUE 5029 ALT=ALT&7; ! 0 FOR EXIT 1 FOR CONTINUE 5030 %IF EXITLAB=0 %THEN FAULT2(54+ALT,0,0) %AND %RETURN 5031 KK=INTEGER(ADDR(EXITLAB)+4*ALT) 5032 ENTER JUMP(15,KK,B'10') 5033 REPORTUI=1 5034 CURR INST=1 %IF CODE=0 5035 %END 5036 %ROUTINE CIFTHEN(%INTEGER MARKIU,MARKC,MARKUI,MARKE,MARKR,SKIP) 5037 !*********************************************************************** 5038 !* THIS ROUTINE COMPILES CONDITIONAL EXPRESSIONS.IT REQUIRES THE * 5039 !* FOLLOWING PARAMETERS TO BE SET TO THEIR A .R. ENTRY. * 5040 !* MARKIU TO THE ENTRY FOR P(%IU) * 5041 !* MARKC TO THE ENTRY FOR P(COND) * 5042 !* MARKUI TO THE ENTRY FOR (FIRST OCCURRENCE OF) P(UI) * 5043 !* MARKE TO THE ENTRY FOR P(ELSE') - =0 FOR BACKWARDS CONDITION * 5044 !* MARKR TO ENTRY FOR P(RESTOFIU) - =0 FOR BACKWARDS CONDITION * 5045 !*********************************************************************** 5046 %INTEGER ALTUI,CCRES,ELRES,THENLAB,ELSELAB,USERLAB,REPORT,START,ELSEALT,K 5047 %CONSTINTEGER NULL ELSE=4 5048 %SWITCH ESW(1:NULL ELSE) 5049 SET LINE %UNLESS SKIP=YES 5050 MARKIU=A(MARKIU); ! ALT OF IU 1=%IF,2=%UNLESS 5051 PLABEL=PLABEL-1 5052 THENLAB=PLABEL 5053 START=0; ! NO START IN CONDITION YET 5054 ELSELAB=0; ! MEANS NO ELSE CLAUSE 5055 P=MARKC 5056 %IF MARKR>0 %AND A(MARKR)<=2 %THEN START=1;! '%START' OR '%THENSTART' 5057 %IF MARKE#0 %AND LEVEL<2 %AND START=0 %THEN FAULT(57,0) 5058 USERLAB=-1 5059 %IF START#0 %THEN ALTUI=0 %ELSE ALTUI=A(MARKUI) 5060 %IF ALTUI=2 %AND A(MARKUI+3)=2 %THEN USERLAB=FROM AR2(MARKUI+1); ! UI = SIMPLE LABEL 5061 %IF 8<=ALTUI<=9 %AND EXITLAB#0 %START; ! VALID EXIT 5062 %IF ALTUI=8 %THEN USERLAB=EXITLAB %ELSE USERLAB=CONTLAB 5063 %FINISH 5064 ! 5065 %IF SKIP=YES %THEN %START; ! NO CODE NEEDED 5066 %IF START#0 %START 5067 P=MARKR+1 5068 CSTART(2,1); ! NO CODE 5069 MARKE=P 5070 %FINISH 5071 CCRES=1; ! NO CODE FOR ELSE 5072 ->ELSE 5073 %FINISH 5074 ! 5075 %IF USERLAB>=0 %THEN %START; ! FIRST UI IS'->'