%MAINEP ICL9CEZIMP80 %TRUSTEDPROGRAM %BEGIN %CONSTINTEGER RELEASE=1 %CONSTINTEGER YES=1,NO=0 %CONSTINTEGER USE IMP=NO %CONSTINTEGER VMEB=NO %CONSTSTRING(9) LADATE="15 Dec 81"; ! LAST ALTERED %INTEGER I, J, K ! PRODUCED BY OLDPS FROM IMP80PS01 ON 02/07/81 %CONSTBYTEINTEGERARRAY CLETT(0: 481)= 1, 43, 1, 45, 1, 40, 1, 41, 1, 42, 1, 44, 2, 201, 198, 6, 213, 206, 204, 197, 211, 211, 5, 215, 200, 201, 204, 197, 5, 213, 206, 212, 201, 204, 3, 198, 207, 210, 1, 61, 5, 193, 204, 201, 193, 211, 7, 201, 206, 212, 197, 199, 197, 210, 4, 210, 197, 193, 204, 8, 204, 207, 206, 199, 210, 197, 193, 204, 4, 204, 207, 206, 199, 4, 194, 217, 212, 197, 6, 211, 212, 210, 201, 206, 199, 4, 200, 193, 204, 198, 6, 210, 197, 195, 207, 210, 196, 7, 210, 207, 213, 212, 201, 206, 197, 2, 198, 206, 3, 205, 193, 208, 8, 198, 213, 206, 195, 212, 201, 207, 206, 4, 206, 193, 205, 197, 9, 193, 210, 210, 193, 217, 206, 193, 205, 197, 9, 207, 198, 208, 210, 207, 199, 210, 193, 205, 6, 207, 198, 198, 201, 204, 197, 6, 207, 198, 204, 201, 211, 212, 6, 198, 207, 210, 205, 193, 212, 3, 206, 207, 212, 3, 193, 206, 196, 2, 207, 210, 1, 58, 4, 211, 208, 197, 195, 5, 193, 210, 210, 193, 217, 3, 207, 215, 206, 8, 197, 216, 212, 197, 210, 206, 193, 204, 9, 197, 216, 212, 210, 201, 206, 211, 201, 195, 8, 195, 207, 206, 211, 212, 193, 206, 212, 5, 195, 207, 206, 211, 212, 5, 197, 214, 197, 206, 212, 5, 211, 212, 193, 210, 212, 9, 212, 200, 197, 206, 211, 212, 193, 210, 212, 4, 212, 200, 197, 206, 9, 197, 204, 211, 197, 211, 212, 193, 210, 212, 4, 197, 204, 211, 197, 1, 95, 6, 211, 217, 211, 212, 197, 205, 7, 196, 217, 206, 193, 205, 201, 195, 4, 80, 85, 84, 95, 5, 67, 78, 79, 80, 95, 2, 204, 61, 1, 60, 1, 62, 4, 40, 196, 210, 43, 2, 196, 210, 1, 194, 3, 212, 207, 211, 3, 204, 206, 194, 3, 216, 206, 194, 2, 208, 195, 3, 195, 212, 194, 2, 45, 62, 6, 210, 197, 212, 213, 210, 206, 6, 210, 197, 211, 213, 204, 212, 7, 205, 207, 206, 201, 212, 207, 210, 4, 211, 212, 207, 208, 6, 211, 201, 199, 206, 193, 204, 4, 197, 216, 201, 212, 8, 195, 207, 206, 212, 201, 206, 213, 197, 6, 198, 201, 206, 201, 211, 200, 5, 195, 217, 195, 204, 197, 6, 210, 197, 208, 197, 193, 212, 3, 197, 206, 196, 7, 201, 206, 195, 204, 213, 196, 197, 5, 194, 197, 199, 201, 206, 2, 207, 206, 6, 211, 215, 201, 212, 195, 200, 4, 204, 201, 211, 212, 7, 211, 208, 197, 195, 201, 193, 204, 14, 212, 210, 213, 211, 212, 197, 196, 208, 210, 207, 199, 210, 193, 205, 6, 205, 193, 201, 206, 197, 208, 7, 195, 207, 206, 212, 210, 207, 204, 4, 40, 42, 41, 58; %CONSTINTEGERARRAY SYMBOL(1300: 2168)= 1307, 1303, 0, 1305, 2, 1307, 1000, 1319, 1312, 1001, 1366, 1800, 1315, 1003, 1020, 1319, 4, 1345, 6, 1329, 1323, 1001, 1014, 1325, 1003, 1329, 4, 1329, 6, 1336, 1336, 1010, 1028, 1319, 1011, 1359, 1345, 1343, 1010, 1028, 1319, 1011, 1359, 1345, 8, 1352, 1352, 1010, 1028, 1307, 1011, 1352, 1359, 1357, 1026, 1307, 999, 1359, 1000, 1366, 1364, 1026, 1319, 999, 1366, 1000, 1374, 1372, 4, 1345, 1374, 6, 1374, 1000, 1381, 1379, 10, 1345, 999, 1381, 1000, 1386, 1384, 12, 1386, 15, 1410, 1393, 22, 1010, 1551, 1571, 1011, 1399, 28, 1010, 1551, 1571, 1011, 1410, 34, 1010, 1001, 38, 1345, 10, 1345, 10, 1345, 1011, 1416, 1414, 40, 1013, 1416, 1000, 1423, 1421, 10, 1001, 999, 1423, 1000, 1428, 1426, 46, 1428, 1000, 1435, 1431, 54, 1433, 46, 1435, 59, 1452, 1438, 46, 1440, 54, 1443, 68, 1428, 1446, 73, 1423, 1449, 78, 1706, 1452, 85, 1423, 1474, 1455, 46, 1457, 54, 1460, 68, 1428, 1463, 73, 1423, 1466, 78, 1706, 1469, 85, 1423, 1474, 90, 4, 1851, 6, 1481, 1477, 97, 1481, 1031, 1435, 1481, 1488, 1484, 105, 1486, 108, 1488, 112, 1504, 1494, 1452, 1509, 1001, 1416, 1500, 1474, 1504, 1001, 1416, 1516, 1504, 121, 1001, 1416, 1509, 1507, 121, 1509, 1000, 1516, 1512, 126, 1514, 121, 1516, 1000, 1526, 1524, 4, 1010, 1488, 1011, 1526, 6, 1526, 1000, 1535, 1533, 1030, 1010, 1488, 1011, 999, 1535, 1000, 1546, 1539, 136, 1016, 1541, 146, 1544, 153, 1018, 1546, 1016, 1551, 1549, 160, 1551, 1000, 1565, 1557, 1345, 1032, 1345, 1565, 1562, 4, 1551, 1571, 6, 1565, 167, 1551, 1571, 1569, 1037, 1345, 1571, 1000, 1582, 1576, 171, 1551, 1582, 1580, 175, 1551, 1589, 1582, 1000, 1589, 1587, 171, 1551, 999, 1589, 1000, 1596, 1594, 175, 1551, 999, 1596, 1000, 1604, 1600, 1033, 1345, 1602, 178, 1604, 1000, 1610, 1608, 180, 1008, 1610, 1015, 1614, 1613, 180, 1614, 1623, 1621, 10, 1345, 178, 1345, 1614, 1623, 1000, 1632, 1628, 1509, 1001, 1416, 1632, 185, 1546, 1632, 1638, 1638, 1001, 1416, 1808, 1638, 1644, 1642, 10, 1632, 1644, 1000, 1662, 1655, 1509, 1610, 1010, 1001, 1410, 1816, 1011, 1662, 1006, 1662, 185, 1546, 1610, 1001, 1808, 1684, 1673, 1671, 10, 1010, 1001, 1410, 1816, 1011, 1662, 1673, 1000, 1684, 1676, 191, 1678, 195, 1680, 204, 1682, 214, 1684, 223, 1695, 1693, 38, 1012, 1028, 1319, 1359, 1706, 1695, 1695, 1000, 1706, 1704, 10, 1012, 1028, 1319, 1359, 1706, 999, 1706, 1000, 1713, 1711, 4, 1336, 6, 1713, 1000, 1720, 1718, 10, 1009, 999, 1720, 1000, 1725, 1723, 229, 1725, 1000, 1731, 1729, 10, 1345, 1731, 1000, 1744, 1742, 10, 1001, 1416, 4, 1345, 178, 1345, 6, 999, 1744, 1000, 1751, 1749, 28, 1551, 1571, 1751, 1000, 1764, 1754, 1019, 1756, 1006, 1761, 1381, 1551, 1571, 1006, 1764, 1386, 1006, 1777, 1768, 235, 1034, 1771, 241, 1034, 1777, 251, 1010, 2006, 1011, 1783, 1783, 1781, 171, 2006, 1783, 1000, 1800, 1787, 256, 1034, 1795, 266, 1381, 1010, 1551, 1571, 1011, 1764, 1798, 266, 2006, 1800, 1000, 1808, 1806, 271, 1001, 1366, 1800, 1808, 1000, 1816, 1816, 4, 1345, 178, 1345, 1614, 6, 1824, 1822, 38, 1028, 1319, 1359, 1824, 1000, 1833, 1827, 273, 1829, 195, 1831, 280, 1833, 1000, 1844, 1842, 1001, 38, 1345, 10, 1345, 10, 1345, 1844, 1000, 1851, 1849, 10, 1858, 999, 1851, 1000, 1858, 1854, 1001, 1858, 1858, 1844, 1876, 1868, 1862, 1452, 1868, 1868, 4, 1858, 1844, 1876, 6, 1876, 1873, 1509, 1001, 1416, 1876, 185, 1632, 1884, 1882, 175, 1858, 1844, 999, 1884, 1000, 1896, 1888, 288, 1002, 1891, 1022, 1896, 1896, 293, 1009, 10, 1009, 1910, 1900, 1023, 1910, 1905, 1024, 299, 1949, 1954, 1910, 1025, 1005, 10, 1933, 1933, 1915, 302, 1001, 304, 1917, 1982, 1922, 4, 1982, 1971, 6, 1926, 306, 1982, 6, 1931, 4, 311, 1971, 6, 1933, 314, 1949, 1938, 302, 1001, 304, 1940, 1982, 1945, 4, 311, 1971, 6, 1949, 306, 1005, 6, 1954, 1952, 311, 1954, 1005, 1962, 1960, 10, 1005, 10, 1005, 1962, 1000, 1971, 1966, 0, 1005, 1969, 2, 1005, 1971, 1000, 1977, 1975, 0, 314, 1977, 1000, 1982, 1980, 38, 1982, 1000, 1997, 1987, 1977, 1300, 1003, 1990, 1001, 1962, 1995, 4, 1997, 1962, 6, 1997, 316, 2006, 2000, 320, 2002, 324, 2004, 328, 2006, 331, 2039, 2015, 1010, 1001, 1366, 1800, 1011, 1596, 1777, 2019, 335, 1001, 1366, 2021, 338, 2025, 345, 1033, 1345, 2028, 352, 1777, 2030, 360, 2035, 365, 1720, 1009, 1725, 2037, 372, 2039, 377, 2169, 2046, 1027, 1010, 2006, 1011, 1751, 2048, 1007, 2056, 1381, 1010, 1551, 1571, 1011, 1764, 1006, 2061, 386, 1035, 1783, 1006, 2066, 393, 1029, 1833, 1006, 2071, 399, 1036, 1744, 1006, 2076, 1386, 393, 1029, 1006, 2084, 1004, 1008, 1010, 1452, 1011, 1623, 1006, 2088, 406, 1535, 1006, 2098, 90, 160, 1001, 4, 1858, 1844, 1876, 6, 1006, 2108, 1010, 1824, 1474, 1011, 1604, 1001, 1410, 1516, 1006, 2112, 1673, 1452, 1644, 2116, 410, 1003, 1038, 2120, 418, 1015, 1006, 2129, 424, 1021, 1720, 1009, 1713, 235, 1034, 1006, 2140, 427, 1001, 1416, 4, 1345, 178, 1345, 6, 1731, 1006, 2144, 434, 1006, 1017, 2149, 439, 121, 1001, 1006, 2153, 8, 1884, 1006, 2156, 447, 1006, 2160, 462, 1001, 1006, 2164, 469, 1003, 1006, 2167, 1001, 477, 2169, 1006; %CONSTINTEGER SS= 2039 ! %CONST %BYTE %INTEGER %ARRAY I TO E TAB(0 : 127) = %C X'40',X'40',X'40',X'40',X'40',X'40',X'40',X'40', X'40',X'40',X'15',X'40',X'0C',X'40',X'40',X'40', X'40',X'40',X'40',X'40',X'40',X'40',X'40',X'40', X'40',X'40',X'40',X'40',X'40',X'40',X'40',X'40', X'40',X'4F',X'7F',X'7B',X'5B',X'6C',X'50',X'7D', X'4D',X'5D',X'5C',X'4E',X'6B',X'60',X'4B',X'61', X'F0',X'F1',X'F2',X'F3',X'F4',X'F5',X'F6',X'F7', X'F8',X'F9',X'7A',X'5E',X'4C',X'7E',X'6E',X'6F', X'7C',X'C1',X'C2',X'C3',X'C4',X'C5',X'C6',X'C7', X'C8',X'C9',X'D1',X'D2',X'D3',X'D4',X'D5',X'D6', X'D7',X'D8',X'D9',X'E2',X'E3',X'E4',X'E5',X'E6', X'E7',X'E8',X'E9',X'4A',X'5F',X'5A',X'6A',X'6D', X'7C',X'81',X'82',X'83',X'84',X'85',X'86',X'87', X'88',X'89',X'91',X'92',X'93',X'94',X'95',X'96', X'97',X'98',X'99',X'A2',X'A3',X'A4',X'A5',X'A6', X'A7',X'A8',X'A9',X'C0',X'40',X'D0',X'40',X'40' %CONSTINTEGERARRAY OPC(0:126)=0, M' JCC',M' JAT',M' JAF',0(4), M' VAL',M' CYD',M'INCA',M'MODD',M'PRCL',M' J',M' JLK',M'CALL', M' ADB',M' SBB',M'DEBJ',M' CPB',M' SIG',M' MYB',M' VMY',M'CPIB', M' LCT',M'MPSR',M'CPSR',M'STCT',M'EXIT',M'ESEX',M' OUT',M' ACT', M' SL',M'SLSS',M'SLSD',M'SLSQ',M' ST',M'STUH',M'STXN',M'IDLE', M' SLD',M' SLB',M'TDEC',M'INCT',M' STD',M' STB',M'STLN',M'STSF', M' L',M' LSS',M' LSD',M' LSQ',M'RRTC',M' LUH',M'RALN',M' ASF', M'LDRL',M' LDA',M'LDTB',M' LDB',M' LD',M' LB',M' LLN',M' LXN', M' TCH',M'ANDS',M' ORS',M'NEQS',M'EXPA',M' AND',M' OR',M' NEQ', M' PK',M' INS',M'SUPK',M' EXP',M'COMA',M' DDV',M'DRDV',M'DMDV', M'SWEQ',M'SWNE',M' CPS',M' TTR',M' FLT',M' IDV',M'IRDV',M'IMDV', M' MVL',M' MV',M'CHOV',M' COM',M' FIX',M' RDV',M'RRDV',M'RDVD', M' UAD',M' USB',M'URSB',M' UCP',M' USH',M' ROT',M' SHS',M' SHZ', M' DAD',M' DSB',M'DRSB',M' DCP',M' DSH',M' DMY',M'DMYD',M'CBIN', M' IAD',M' ISB',M'IRSB',M' ICP',M' ISH',M' IMY',M'IMYD',M'CDEC', M' RAD',M' RSB',M'RRSB',M' RCP',M' RSC',M' RMY',M'RMYD'; %CONSTBYTEINTEGERARRAY ONE CASE(0 : 127) = %C 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15, 16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31, 32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47, 48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63, 64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79, 80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95, 96,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79, 80,81,82,83,84,85,86,87,88,89,90,123,124,125,126,127; %CONSTINTEGER NO OF SNS=63 %CONSTHALFINTEGERARRAY TSNAME (0:NO OF SNS)=X'1000'(8), X'1001',X'1000'(5),X'1001',X'1062',X'1001'(2),X'1062', X'1000'(2),X'52',X'51',X'62',X'1062'(7), X'1000',X'31',X'51',X'1062'(2),X'31',X'1000', X'51',X'62',X'1000'(2),X'35',X'1000',X'1035', X'31',X'35',X'1035',X'33',0,X'1001',X'51',X'52',X'51', X'61',X'72',X'61',X'72',X'51',X'62',X'1051',X'41', X'1000',X'62'; ! %OWNINTEGERARRAY FIXED GLA(0:11)=0, X'50000000',0(2),-1,0,0(6); %CONSTBYTEINTEGERARRAY BYTES(0:7)=0(3),1,2,4,8,16; %CONSTBYTEINTEGERARRAY TRTAB(0:255)=0(48), 1(10),0(7),2(26),0(6),2(26),0(5),0(128) %CONSTINTEGER MAXLEVELS=31,CONCOP=13,FIXEDGLALEN=48 %CONSTINTEGER JOBBERBIT=X'40000000'; ! SET IN JOBBER MODE %CONSTINTEGER CEBIT=1; ! SET IN COMPILER ENVIRONMENT %CONSTINTEGER MAXDICT=X'100'; ! SET FOR MAX OF EVERYTHING ! ! THE PRINCIPAL OPCODES ARE HERE DEFINED AS THEIR MNEMONICS(AMENDED) ! %CONSTINTEGER LB=X'7A',SLB=X'52',STB=X'5A',ADB=X'20',CPB=X'26', %C MYB=X'2A',SBB=X'22',CPIB=X'2E',OUT=X'3C',CPSR=X'34' %CONSTINTEGER LD=X'78',LDA=X'72',INCA=X'14',STD=X'58',LDB=X'76', %C LDTB=X'74',LDRL=X'70',CYD=X'12',MODD=X'16',SLD=X'50' %CONSTINTEGER STLN=X'5C',ASF=X'6E',ST=X'48',RALN=X'6C',LXN=X'7E',%C LLN=X'7C',LSS=X'62',SLSS=X'42',MPSR=X'32',STSF=X'5E',%C LUH=X'6A',STUH=X'4A',LSD=X'64',SLSD=X'44',PRCL=X'18', %C LSQ=X'66',SLSQ=X'46',STXN=X'4C',LCT=X'30',STCT=X'36' %CONSTINTEGER JUNC=X'1A',JLK=X'1C',CALL=X'1E',EXIT=X'38',JCC=2, %C JAT=4,JAF=6,DEBJ=X'24' %CONSTINTEGER IAD=X'E0',ICP=X'E6',USH=X'C8',ISB=X'E2',IRSB=X'E4',%C OR=X'8C',UCP=X'C6',IMY=X'EA',IMDV=X'AE',AND=X'8A', %C ISH=X'E8',IMYD=X'EC',IDV=X'AA' %CONSTINTEGER RAD=X'F0',RSB=X'F2',RRSB=X'F4',FLT=X'A8',RRDV=X'BC', %C RSC=X'F8',FIX=X'B8',RDV=X'BA',RDDV=X'BE',RMYD=X'FC', %C RMY=X'FA' ! %CONSTINTEGER MVL=X'B0',MV=X'B2',SWEQ=X'A0',SWNE=X'A2',CPS=X'A4' ! ! DEFINE SOME MNEMONICS FOR THE VISIBLE REGISTERS (XCEPT LNB) ! %CONSTINTEGER ACCR=0,DR=1,LNB=2,XNB=3,PC=4,CTB=5,TOS=6,BREG=7 %CONSTBYTEINTEGERARRAY LDCODE(0:7)=0,LD,LLN,LXN,0,LCT,0,LB; ! %CONSTSTRING(8)MDEP="S#NDIAG" %CONSTSTRING(8)IOCPEP="S#IOCP"; ! EP FOR IOCP %CONSTSTRING(11)AUXSTEP="ICL9CEAUXST";! DATA REF FOR INDIRECT AUX ST %CONSTINTEGER SNPT=X'1006'; ! SPECIALNAME PTYPE %CONSTINTEGER COMMALT=2,ENDALT=9,UNASSPAT=X'81818181',DECALT=8 ! %INTEGER DICTBASE, CONSTPTR, CONSTBTM, CONSTHOLE, WKFILEAD, %C WKFILEK, DUMMYFORMAT, P1SIZE, LEVELINF, IOCPDISP, PARMBITS1, %C PARMBITS2,PARMLET ! %INTEGER ASL, NNAMES, ARSIZE, CABUF, PPCURR, CONSTLIMIT, OLDLINE, %C LINE, LENGTH, NEXTP, SNUM, RLEVEL, NMAX, USTPTR, PLABEL,%C LEVEL, CA, LASTNAME, CDCOUNT, ASL CUR BTM, PARMDYNAMIC ! %INTEGER FAULTY, HIT, INHCODE, IMPS, TTOPUT, LIST, PARMDIAG, %C WARNFLAG, PARMTRACE, PARMLINE, PARMOPT, CTYPE, DCOMP, %C CPRMODE, PARMCHK, PARMARR, PARMDBUG,%C COMPILER, LAST INST, SMAP, STACK, AUXST, PARMY, BFFLAG ! %INTEGER RBASE, N, FREE FORMAT, PARMPROF, EXITLAB, CONTLAB, %C Q, R, S, NEST, FNAME, LDPTR, GLACA, GLACABUF, %C GLACURR, CREFHEAD, SSTL, QMAX, STMTS, LASTAT, %C FILE ADDR, FILE PTR, FILE END, FILE SIZE, LASTEND, %C BIMSTR,STLIMIT,STRLINK,RECTB,ASL WARN,IHEAD ! %INTEGER MAX ULAB, SFLABEL %LONGREAL CVALUE, IMAX, CTIME %STRING(31)MAINEP %RECORDFORMAT LISTF(%INTEGER S1,S2,S3,LINK) %INTEGER LOGEPDISP,EXPEPDISP ! %SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N) %BEGIN FILE ADDR=COMREG(46); ! SOURCE FILE IF CLEAN PARMBITS1=COMREG(27) PARMBITS2=COMREG(28) WKFILEAD=COMREG(14) WKFILEK=INTEGER(WKFILEAD+8)>>10 %IF FILE ADDR<=0 %THEN FILESIZE=64000 %AND FILE ADDR=0 %ELSESTART FILE PTR=FILE ADDR+INTEGER(FILE ADDR+4) FILE END=FILE ADDR+INTEGER(FILE ADDR) FILE SIZE=INTEGER(FILE ADDR) %FINISH NNAMES=255 %IF FILESIZE>10000 %THEN NNAMES=511 %IF PARMBITS1&JOBBER BIT=0 %START %IF FILESIZE>32000 %THEN NNAMES=1023 %IF FILESIZE>256*1024 %OR PARMBITS2&MAXDICT#0 %OR %C WKFILEK>512 %THEN NNAMES=2047 %FINISH ASL=3*NNAMES ASL=4095 %IF ASL>4095 %AND PARMBITS2&MAXDICT=0;! STAY WITHIN 128K AUXSTACK ARSIZE=WKFILEK*768-300 %END %BYTEINTEGERARRAYFORMAT AF(0:ARSIZE) %BYTEINTEGERARRAYNAME A %RECORD(LISTF)%ARRAY ASLIST(0:ASL) %INTEGERARRAY WORD, TAGS(0:NNAMES) %INTEGERARRAY DVHEADS(0:12) %INTEGERFNSPEC FROMAR4(%INTEGER PTR) %INTEGERFNSPEC FROMAR2(%INTEGER PTR) %ROUTINESPEC TOAR8(%INTEGER PTR, %LONGREAL VALUE) %ROUTINESPEC TOAR4(%INTEGER PTR, VALUE) %ROUTINESPEC TOAR2(%INTEGER PTR,VALUE) %ROUTINESPEC WARN(%INTEGER N,V) %ROUTINESPEC FAULT(%INTEGER N,VAL,IDEN) %STRINGFNSPEC PRINTNAME(%INTEGER N) %INTEGERFNSPEC MORE SPACE !%INTEGERFNSPEC NEWCELL %ROUTINESPEC INSERTATEND(%INTEGERNAME S, %INTEGER A, B, C) %ROUTINESPEC FROM12(%INTEGER CELL, %INTEGERNAME S1, S2) %ROUTINESPEC FROM123(%INTEGER CELL, %INTEGERNAME S1, S2, S3) %ROUTINESPEC POP(%INTEGERNAME C, P, Q, R) %ROUTINESPEC PUSH(%INTEGERNAME C, %INTEGER S1, S2, S3) %INTEGERFNSPEC FIND(%INTEGER LAB, LIST) %ROUTINESPEC MLINK(%INTEGERNAME CELL) %ROUTINESPEC REPLACE1(%INTEGER CELL, S1) %ROUTINESPEC REPLACE2(%INTEGER CELL, S2) %ROUTINESPEC REPLACE3(%INTEGER CELL,S3) %ROUTINESPEC REPLACE123(%INTEGER CELL,A1,A2,S3) %INTEGERFNSPEC FROM2(%INTEGER CELL) %INTEGERFNSPEC FROM1(%INTEGER CELL) %INTEGERFNSPEC FROM3(%INTEGER CELL) %ROUTINESPEC BINSERT(%INTEGERNAME T,B,%INTEGER S1,S2,S3) %ROUTINESPEC CLEARLIST(%INTEGERNAME HEAD) %STRING(255)%FNSPEC MESSAGE(%INTEGER N) %SYSTEMROUTINESPEC LPUT(%INTEGER A, B, C, D) %SYSTEMLONGREALFNSPEC CPUTIME !*DELSTART %SYSTEMROUTINESPEC NCODE(%INTEGER START, FINISH, CA) %ROUTINESPEC PRINTLIST(%INTEGER HEAD) %ROUTINESPEC PRHEX(%INTEGER VALUE,PLACES) %ROUTINESPEC CHECK ASL !*DELEND %IF VMEB=NO %THEN %START %SYSTEMROUTINESPEC CONSOURCE(%STRING(31)FILE,%INTEGERNAME AD) %FINISH ! START OF COMPILATION A==ARRAY(WKFILE AD+256*WKFILEK, AF) %BEGIN !*********************************************************************** !* THIS BLOCK INITIALISE THE COMPILER SCALARS AND ARRAYS * !* WAS ORIGINALLY ROUTINE 'INITIALISE'. * !* THE INITIALISATION OF THE CONSTANT LISTS WITH THE VALUES * !* IN PERM MAY BE OMITTED IN BATCH OR CUT-DOWN VERSIONS. * !*********************************************************************** %ROUTINESPEC READ LINE(%INTEGER MODE,CHAR) %INTEGERFNSPEC COMPARE(%INTEGER P) %ROUTINESPEC PNAME(%INTEGER MODE) %ROUTINESPEC CONST(%INTEGER MODE) %ROUTINESPEC TEXTTEXT(%INTEGER EBCDIC) %INTEGER DSIZE,NEXT,ATLINE1,STARSTART,CCSIZE DSIZE=7*NNAMES; CCSIZE=256*(WKFILEK-1) %IF PARMBITS2&MAXDICT#0 %THEN DSIZE=DSIZE+NNAMES %INTEGERARRAY DISPLAY,SFS(0:MAXLEVELS) %BYTEINTEGERARRAY TLINE(-60:161),LETT(0:DSIZE+20) %BYTEINTEGERARRAYFORMAT CCF(0:CCSIZE) %BYTEINTEGERARRAYNAME CC %LONGINTEGER ATL0,ASYM0 %CONSTBYTEINTEGERARRAY ILETT(0: 501)= 11, 'S','E','L','E','C','T','I','N','P','U','T', 12,'S','E','L','E', 'C','T','O','U','T','P','U','T', 7,'N','E','W','L','I','N','E', 5,'S','P','A','C','E', 10,'S','K','I','P','S','Y','M','B','O', 'L', 10,'R','E','A','D','S','T','R','I','N','G', 8,'N','E','W', 'L','I','N','E','S', 6,'S','P','A','C','E','S', 10,'N','E','X', 'T','S','Y','M','B','O','L', 11,'P','R','I','N','T','S','Y','M', 'B','O','L', 10,'R','E','A','D','S','Y','M','B','O','L', 4,'R', 'E','A','D', 5,'W','R','I','T','E', 7,'N','E','W','P','A','G', 'E', 4,'A','D','D','R', 6,'A','R','C','S','I','N', 3,'I','N', 'T', 5,'I','N','T','P','T', 6,'F','R','A','C','P','T', 5,'P', 'R','I','N','T', 7,'P','R','I','N','T','F','L', 4,'R','E','A', 'L', 7,'I','N','T','E','G','E','R', 3,'M','O','D', 6,'A','R', 'C','C','O','S', 4,'S','Q','R','T', 3,'L','O','G', 3,'S','I', 'N', 3,'C','O','S', 3,'T','A','N', 3,'E','X','P', 11,'C','L', 'O','S','E','S','T','R','E','A','M', 11,'B','Y','T','E','I','N', 'T','E','G','E','R', 8,'E','V','E','N','T','I','N','F', 6,'R','A','D','I','U','S', 6,'A','R','C','T','A','N', 6,'L','E','N','G','T','H', 11,'P','R','I','N','T','S','T','R', 'I','N','G', 2,'N','L', 8,'L','O','N','G','R','E','A','L', 7, 'P','R','I','N','T','C','H', 6,'R','E','A','D','C','H', 6,'S', 'T','R','I','N','G', 8,'R','E','A','D','I','T','E','M', 8,'N', 'E','X','T','I','T','E','M', 6,'C','H','A','R','N','O', 8,'T', 'O','S','T','R','I','N','G', 9,'S','U','B','S','T','R','I', 'N','G', 6,'R','E','C','O','R','D', 5,'A','R','R','A','Y', 6, 'S','I','Z','E','O','F',4,'I','M','O','D',2,'P', 'I',9,'E','V','E','N','T','L','I','N','E',11,'L','O','N','G', 'I','N','T','E','G','E','R',12,'L','O','N','G','L','O','N','G', 'R','E','A','L',9,'L','E','N','G','T','H','E','N','I', 9,'L','E','N','G','T','H','E','N','R', 8,'S','H','O','R','T','E','N','I', 8,'S','H','O','R','T','E','N','R', 6,'N','E','X','T','C','H', 11,'H','A','L','F','I','N','T','E','G','E','R', 8,'P','P','R','O','F','I','L','E', 5,'F','L','O','A','T',255; CC==ARRAY(WKFILEAD+32,CCF) IMAX=(-1)>>1;PLABEL=24999 LETT(0)=0 ATLINE1=ADDR(TLINE(1)) INTEGER(ADDR(ATL0)+4)=ATLINE1-1 INTEGER(ADDR(ATL0))=X'18000100' INTEGER(ADDR(ASYM0))=X'28000C00' INTEGER(ADDR(ASYM0)+4)=ADDR(SYMBOL(1300))-4*1300 N=12; MAX ULAB=NNAMES+16384; ! LARGEST VALID USER LABEL GLACURR=0; GLACA=FIXEDGLALEN; GLACABUF=GLACA PARMOPT=1 ; PARMARR=1; LAST INST=0 PARMLINE=1; PARMTRACE=1; PARMDIAG=1 LIST=1; SFLABEL=20999; PARMCHK=1 EXITLAB=0; CONTLAB=0 CABUF=0; PPCURR=0; OLDLINE=0; COMPILER=0 RLEVEL=0; NMAX=0; USTPTR=0 LEVEL=0; CA=0; LASTAT=0 FAULTY=0; WARNFLAG=0; INHCODE=0 DCOMP=0; BFFLAG=0; CPRMODE=0 NEXT=1; LDPTR=0 IOCPDISP=0; CREFHEAD=0; AUXST=0 RBASE=10; LOGEPDISP=0; EXPEPDISP=0; STRLINK=0 RECTB=0; IHEAD=0 SSTL=0; STMTS=1; SNUM=0; LEVELINF=0 CDCOUNT=0 BIMSTR=0 LOGEPDISP=0; EXPEPDISP=0 MAINEP="S#GO"; ! DEFAULT MAIN ENTRY DICTBASE=ADDR(LETT(0)) ! ! OPEN OBJECT FILE HERE BEFORE MORE PAGES OF COMPILER CODE ! ARE PAGED IN AND SUB-SYSTEM PAGES MOVE OUT ! LPUT(0,0,0,0) CTIME=CPUTIME I=COMREG(27) STLIMIT=X'1F000' %IF I>>24&1#0 %THEN STLIMIT=COMREG(48)-4096 %IF I&2=2 %THEN LIST=0 %IF I&4=4 %THEN PARMDIAG=0 %IF I&X'800000'#0 %THEN PARMLINE=0 %IF I&16=16 %THEN PARMCHK=0 %IF I&32=32 %THEN PARMARR=0 PARMPROF=(I>>15&1)!(I>>7&1); ! USE MAP OR PROFILE BIT PRO TEM PARMDYNAMIC=I>>20&1 PARMLET=I>>13&1 DCOMP=I>>14&1; ! PARM CODE OR D PARMDBUG=I>>18&1 %IF I&64=64 %THEN PARMTRACE=0 %AND PARMDIAG=0 FREE FORMAT=I&X'80000' STACK=I>>3&1 SMAP=I>>26&1; ! USE PARMZ BIT FOR DUMPING WKFILE PARMY=I>>27&1; ! PARMY FLAGS UNUSED CONSTS TTOPUT=COMREG(40) %IF I&(1<<16)#0 %THEN %START PARMARR=0; PARMOPT=0 PARMLINE=0; PARMCHK=0; PARMDIAG=0 %FINISH PARMTRACE=PARMTRACE!PARMOPT; ! ALLOW NOTRACE ONLY WITH OPT IMPS=I>>23&1; ! BIT SET IF IMPS REQUESTED IMPS=1; ! FOR TESTING NEWLINES(3); SPACES(14) PRINTSTRING("ERCC. Imp80") PRINTSTRING(" Compiler Release") WRITE(RELEASE,1) PRINTSTRING(" Version ".LADATE) NEWLINES(3) WRITE(NNAMES,5); WRITE(ASL,5) NEWLINE ASL WARN=0 ASL CUR BTM=ASL-240 CONST LIMIT=4*ASL CUR BTM-8 %CYCLE I=ASL CUR BTM,1,ASL-1 ASLIST(I+1)_LINK=I %REPEAT ASLIST(ASL CUR BTM)_LINK=0 ASLIST(0)_S1=-1 ASLIST(0)_S2=-1 ASLIST(0)_S3=-1 ASLIST(0)_LINK=0 %CYCLE I=0,1,NNAMES WORD(I)=0; TAGS(I)=0; %REPEAT %CYCLE I=0,1,12 DVHEADS(I)=0 %REPEAT ! ! NOW DECLARE THE SPECIAL NAMES WHICH ARE IN ARRAY ILETT. ! K=0; NEXT=1 I=ILETT(0) %WHILE I<255 %CYCLE %CYCLE J=I,-1,1 CC(J)=ILETT(K+J) %REPEAT CC(I+1)=';' R=2; Q=1; PNAME(1) PUSH(TAGS(LASTNAME),SNPT<<16!X'8000',0,SNUM<<16) SNUM=SNUM+1 K=K+I+1; I=ILETT(K) %REPEAT ! COMREG(24)=16; ! RETURN CODE DUMMY FORMAT=0; ! DUMMY RECORD FORMAT PUSH(DUMMY FORMAT,0,0,0); ! FOR BETTER ERROR RECOVERY LINE=0; LENGTH=0; Q=1 R=1; LEVEL=1 %CYCLE %IF Q>=LENGTH %THEN QMAX=1 %AND READ LINE(0,0) WARNFLAG=0 STARSTART=R R=R+3 OLDLINE=LINE A(R)=LINE>>8 A(R+1)=LINE&255 R=R+2 %IF COMPARE(SS)=0 %THEN %START FAULT(100,ADDR(CC(0)),0) R=STARSTART %FINISH %ELSE %START FAULT(102, WKFILEK, 0) %IF R>ARSIZE %IF A(STARSTART+5)=COMMALT %THEN R=STARSTART %ELSE %START I=R-STARSTART A(STARSTART)=I>>16 A(STARSTART+1)=I>>8&255 A(STARSTART+2)=I&255 %IF A(STARSTART+5)=DECALT %AND LEVEL>1 %THEN %START %IF SFS(LEVEL)=0 %THEN %START TO AR4(DISPLAY(LEVEL),STARSTART) DISPLAY(LEVEL)=STARSTART+6 %FINISH %ELSE A(STARSTART+6)=128;! FLAG AS UNLINKED %FINISH !*DELSTART %IF SMAP#0 %THEN %START NEWLINE; WRITE(LINE, 5) WRITE(STARSTART,5); NEWLINE; J=0 %CYCLE I=STARSTART, 1, R-1 WRITE(A(I), 5) J=J+1 %IF J>=20 %THEN NEWLINE %AND J=0 %REPEAT NEWLINE %FINISH !*DELEND %IF A(STARSTART+5)=ENDALT %AND %C 1<=A(STARSTART+6)<=2 %START;! ENDOF PROG OR FILE %IF IHEAD=0 %THEN %EXIT POP(IHEAD,FILEADDR,FILEPTR,FILEEND) R=STARSTART; ! IGNORE ENDOFFILE LIKE IMP77 LENGTH=1 %CONTINUE %FINISH %IF LEVEL=0 %THEN %START FAULT(14, 0, 0) R=STARSTART; ! IGNORE IT LEVEL=1 %FINISH %FINISH %FINISH %REPEAT TO AR8(R,0); R=R+8 %IF R+NEXT>ARSIZE %THEN FAULT(102, WKFILEK,0) P1SIZE=R %IF USE IMP=YES %THEN %START %CYCLE I=0,1,NEXT A(R+I)=LETT(I) %REPEAT %FINISH %ELSE %START *LDTB_X'18000000' *LDB_NEXT *LDA_LETT+4 *CYD_0 *LDA_A+4 *INCA_R *MV_%L=%DR %FINISH DICTBASE=ADDR(A(R)) R=R+NEXT+1 ->BEND %ROUTINE READ LINE(%INTEGER MODE,CHAR) %ROUTINESPEC GET LINE %INTEGER DEL, LL, LP, PREV LL=0; LP=0; Q=1 LENGTH=0; DEL=0 NEXT: %IF USE IMP=YES %THEN %START LP=LP+1 %IF LP>LL %THEN GET LINE %AND LP=1 I=TLINE(LP) %IF MODE=0 %THEN %START %IF I='{' %THEN %START %CYCLE PREV=I LP=LP+1 I=TLINE(LP) %REPEAT %UNTIL PREV='}' %OR I=NL %FINISH %IF I='%' %THEN DEL=128 %AND ->NEXT I=ONE CASE(I) %IF 'A'<=I<='Z' %THEN I=I!DEL %ELSE %START DEL=0 ->NEXT %IF I=' ' %FINISH LENGTH=LENGTH+1 CC(LENGTH)=I %IF I='''' %OR I=34 %THEN MODE=1 %AND CHAR=I %FINISH %ELSE %START LENGTH=LENGTH+1 CC(LENGTH)=I %IF I=CHAR %THEN MODE=0 %FINISH ->NEXT %UNLESS I=NL %FINISH %ELSE %START *LB_LP *ADB_1 *CPB_LL *JCC_12, GET LINE *LB_1 RLL1: *STB_LP *LB_(ATL0+%B) *LSS_MODE *JAF_4, *CPB_123; !'{' *JCC_7, *LB_LP CB2: *ADB_1 *LSS_(%DR+%B) *ICP_10 *JCC_8, *ICP_125; ! '}' *JCC_7, *ADB_1 *LSS_(%DR+%B) CB3: *STB_LP *ST_%B; ! CHAR TO BREG FOR MAIN SEQUENCE CB1: *CPB_37; !'%' *JCC_7, *L_128 *ST_DEL *J_ RLL3: *LSS_(ONE CASE+%B); ! LOWER CASE TO UPPER *ICP_65; !'A' *JCC_4, *ICP_90; !'Z' *JCC_2, *OR_DEL *J_ RLL4: *LB_0 *STB_DEL *ICP_32; !' ' *JCC_8, RLL5: *LB_LENGTH *ADB_1 *STB_LENGTH *ST_(CC+%B) *ICP_39; !'''' *JCC_8, *ICP_34; !'"' *JCC_7, RLL6: *ST_CHAR *LB_1 *STB_MODE RLL7: *ICP_10 *JCC_7, *J_ RLL2: *LSS_%B *LB_LENGTH *ADB_1 *STB_LENGTH *ST_(CC+%B) *ICP_CHAR *JCC_7, *LB_0 *STB_MODE RLL9: *ICP_10 *JCC_7, RLL8: %FINISH I=CC(LENGTH-1) %IF I='C'+128 %THEN LENGTH=LENGTH-2 %AND ->NEXT %IF MODE=0 %AND I=',' %THEN LENGTH=LENGTH-1 %AND ->NEXT FAULT(101,0,0) %IF LENGTH>CCSIZE %RETURN %ROUTINE GET LINE %SYSTEMROUTINESPEC IOCP(%INTEGER A,B) %CONSTBYTEINTEGERARRAY ITOI(0:255)=%C 32(10),10,32(14),25,26,32(5), 32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47, 48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63, 64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79, 80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95, 96,97,98,99,100,101,102,103,104,105,106,107,108,109, 110,111,112,113,114,115,116,117,118,119, 120,121,122,123,124,125,126,32, 26(5),10,26(10), 26(16), 26(14),92,38, 26(11),35,26(4), 26(16), 26(9),35,26(5),94, 26(32); %INTEGER K LL=0 %IF FILE ADDR=0 %THEN %START; ! SOURCE NOT A 'CLEAN' FILE %UNTIL K=NL %CYCLE READ SYMBOL(K) TLINE(LL+1)=ITOI(K) LL=LL+1 %REPEAT %FINISH %ELSE %START %IF FILEPTR>=FILE END %START %IF IHEAD#0 %THEN POP(IHEAD,FILEADDR,FILEPTR,FILEEND) %C %AND GETLINE %AND %RETURN FAULT(110,0,0) %FINISH %IF USE IMP=NO %THEN %START *LDA_FILEPTR *LB_FILEEND *SBB_FILEPTR *ADB_X'18000000' *LDTB_%B *SWNE_%L=%DR,0,10 *JCC_8, *CYD_0 *STUH_%B *IAD_1 *ST_%B *ISB_FILEPTR *ST_LL *LDA_FILEPTR *STB_FILEPTR *LDB_LL *CYD_0 *LDA_ATLINE1 *MV_%L=%DR,0,0 *LDA_ATLINE1; *LDTB_X'18000000' *LDB_LL *LSS_ITOI+4; *LUH_X'180000FF' *TTR_%L=%DR ->OLIST %FINISH IMP: %UNTIL K=NL %OR K=0 %CYCLE K=BYTE INTEGER(FILEPTR); ! NEXT CHAR FROM SORCE FILE FILE PTR=FILE PTR+1 TLINE(LL+1)=ITOI(K) LL=LL+1 %REPEAT OLIST: %FINISH ! %IF MODE=0 %AND LL=1 %THEN GET LINE %AND %RETURN ! LINE=LINE+1 %UNLESS MODE=0 %AND LENGTH>0 LINE=LINE+1; ! COUNT ALL LINES %IF LIST#0 %THEN %START %IF MODE=0 %AND LENGTH>0 %THEN %C PRINTSTRING(" C") %ELSE WRITE(LINE, 5) ! SPACES(8) %CYCLE K=-7,1,0 TLINE(K)=' ' %REPEAT %IF MODE#0 %THEN TLINE(-7)=M'"' TLINE(-8)=LL+8 IOCP(15,ADDR(TLINE(-8))) %FINISH %IF FREE FORMAT=0 %AND LL>73 %THEN TLINE(73)=10 %AND LL=73 %END %END %INTEGERFN COMPARE(%INTEGER P) %INTEGER I, J, ITEM, RA, RL, RP, RQ, RR, RS, MARKER, SSL, ALT, PP %OWNINTEGER SAVECOMP; ! FOR CHECKING DSIDED CONDS %SWITCH BIP(999:1038) %IF USE IMP=YES %THEN %START RP=SYMBOL(P) RL=LEVEL P=P+1 PP=P; ! ROUTINE REALLY STARTS HERE %FINISH %ELSE %START *LB_P *JLK_2 *EXIT_-64 SUBENTRY: *LSS_(ASYM0+%B) *LUH_LEVEL *ST_RL *ADB_1 *STB_P *STB_PP %FINISH COMM: %IF USE IMP=YES %THEN %START RQ=Q; ! RESET VALUES OF LINE&AR PTRS RR=R SSL=STRLINK; ! SAVE STRING LINK ALT=1; ! FIRST ALTERNATIVE TO BE TRIED RA=SYMBOL(P); ! RA TO NEXT PHRASE ALTERNATIVE RS=P %FINISH %ELSE %START *LSD_Q *ST_RQ *LSS_1 *LUH_STRLINK *ST_SSL *LB_P *LSS_(ASYM0+%B) *ST_RA *STB_RS %FINISH UPR: R=R+1 SUCC: ! SUCCESS ON TO NEXT ITEM %IF USE IMP=YES %THEN %START RS=RS+1; ! RS=NEXT ALTERNATIVE MEANS THAT ! THIS ALT HAS BEEN COMPLETED SO ! EXIT WITH HIT=1 %IF RS=RA %THEN ->FINI ITEM=SYMBOL(RS); ! NEXT BRICK IN THE CURRENT ALT %IF ITEM<999 %THEN ->LIT %FINISH %ELSE %START *LB_RS *ADB_1 *CPB_RA *JCC_8, *STB_RS *LB_(ASYM0+%B) *CPB_999 *JCC_4, *STB_ITEM %FINISH %IF ITEM<1300 %THEN ->BIP(ITEM) ! BRICK IS A PHRASE TYPE %IF USE IMP=YES %THEN %START %IF COMPARE(ITEM)=0 %THEN ->FAIL %FINISH %ELSE %START *LSD_RA *SLSQ_RP *SLSQ_MARKER *ST_%TOS *LB_ITEM *JLK_ *ST_%B; ! RESULT=0 FOR FAIL *LSQ_%TOS; *ST_MARKER *LSQ_%TOS; *ST_RP *LSD_%TOS; *ST_RA *JAT_12, %FINISH ->SUCC LIT: ! BRICK IS LITERAL %IF USE IMP=YES %THEN %START I=CC(Q); ! OBTAIN CURRENT CHARACTER ->FAIL %UNLESS I=CLETT(ITEM+1) Q=Q+1 K=CLETT(ITEM)+ITEM ITEM=ITEM+2 %WHILE ITEM<=K %CYCLE ->FAIL %UNLESS CC(Q)=CLETT(ITEM) Q=Q+1 ITEM=ITEM+1 %REPEAT; ! CHECK IT WITH LITERAL DICT ENTRY %FINISH %ELSE %START *LDB_(CLETT+%B) *INCA_%B *INCA_1 *LSS_Q *IAD_CC+4 *LUH_CC *CPS_%L=%DR,0,0 *JCC_7, *STUH_%B *ISB_CC+4 *ST_Q %FINISH ->SUCC; ! MATCHED SUCCESSFULLY FAIL: ! FAILURE - NOTE POSITION REACHD %IF USE IMP=YES %THEN %START %IF RA=RP %THEN ->TFAIL; ! TOTAL FAILURE NO ALT TO TRY QMAX=Q %IF Q>QMAX Q=RQ; ! RESET LINE AND A.R. POINTERS R=RR+1; ! AVOID GOING VIA UPR: STRLINK=SSL ALT=ALT+1; ! MOVE TO NEXT ALT OF PHRASE RS=RA RA=SYMBOL(RA) %FINISH %ELSE %START *LB_RA *CPB_RP *JCC_8, *LSS_Q *ICP_QMAX *JCC_12, *ST_QMAX CPL1: *LSD_RQ *IAD_1 *ST_Q *L_SSL *STUH_STRLINK *IAD_1 *ST_ALT *STB_RS *L_(ASYM0+%B) *ST_RA %FINISH ->SUCC TFAIL: LEVEL=RL %IF USE IMP=YES %THEN %START %RESULT=0 %FINISH %ELSE %START *LSS_0; *J_%TOS %FINISH BIP(999): ! REPEATED PHRASE A(RR)=ALT; P=PP ->COMM BIP(1000):FINI: ! NULL ALWAYS LAST & OK A(RR)=ALT %IF USE IMP=YES %THEN %START %RESULT=1 %FINISH %ELSE %START *LSS_1; *J_%TOS %FINISH BIP(1001): ! PHRASE NAME I=CC(Q); ! OBTAIN CURRENT CHARACTER ->FAIL %UNLESS TRTAB(I)=2 PNAME(ITEM-1004) ->SUCC %IF HIT=1; ->FAIL BIP(1002): ! PHRASE INTEGER CONSTANT BIP(1003): ! PHRASE CONST CONST(ITEM-1003) ->FAIL %IF HIT=0 ->SUCC BIP(1004): ! PHRASE CHECK EXTENDEDTYPE ! FIRST LETTER IS (B,H,I,L,R,S) ! 3RD LETTER (A,L,N,R,T,C) I=CC(Q) ->FAIL %UNLESS I>128 %AND X'80000000'>>(I&31)&X'20C83000'#0%C %AND X'80000000'>>(CC(Q+2)&31)&X'500A2800'#0 ->SUCC BIP(1005): ! PHRASE N I=CC(Q); ! OBTAIN CURRENT CHARACTER ->FAIL %UNLESS '0'<=I<='9' S=0 %WHILE '0'<=I<='9' %CYCLE S=10*S+I&15 Q=Q+1; I=CC(Q) %REPEAT TOAR2(R,S) R=R+2; ->SUCC BIP(1006): ! PHRASE S=SEPARATOR I=CC(Q); ! OBTAIN CURRENT CHARACTER ->SUCC %IF I=NL ->FAIL %UNLESS I=';' Q=Q+1; ->SUCC BIP(1007): ! PHRASE COMMENT TEXT I=CC(Q); ! OBTAIN CURRENT CHARACTER ->FAIL %UNLESS I='!' %OR I='|' %OR (I='C'+128 %AND CC(Q+1)=%C 'O'+128 %AND CC(Q+2)=CC(Q+3)='M'+128 %AND CC(Q+4)='E'+128 %C %AND CC(Q+5)='N'+128 %AND CC(Q+6)='T'+128) Q=Q+1+6*(I>>7); J=CC(Q) %CYCLE %EXIT %IF J=NL WARN(6,0) %IF J=';' %AND CC(Q+1)#'!' Q=Q+1; J=CC(Q) %REPEAT ->SUCC BIP(1008): ! PHRASE BIGHOLE TO AR4(R,0) R=R+4; ->SUCC BIP(1009): ! PHRASE N255 I=CC(Q); ! OBTAIN CURRENT CHARACTER ->FAIL %UNLESS '0'<=I<='9' S=0 %WHILE '0'<=I<='9' %CYCLE S=10*S+I&15 Q=Q+1; I=CC(Q) %REPEAT ->FAIL %UNLESS 0<=S<=255 A(R)=S; ->UPR BIP(1010): ! PHRASE HOLE MARKER=R; R=R+2; ->SUCC BIP(1011): ! PHRASE MARK I=R-MARKER A(MARKER+1)<-I A(MARKER)<-I>>8 ->SUCC BIP(1012): ! PHRASE READLINE? I=CC(Q); ! OBTAIN CURRENT CHARACTER %WHILE I=NL %%CYCLE READLINE(0,0) RQ=1 I=CC(Q) %REPEAT FAULT(102, WKFILEK,0) %IF R>ARSIZE ->SUCC BIP(1013): ! PHRASE CHECKIMPS R=R-4; ! AVOID HOLE LEFT BY TEXTTEXT TEXTTEXT(0) ->FAIL %IF HIT=0 ->SUCC BIP(1014): ! PHRASE DUMMY APP A(R)=2; A(R+1)=2 R=R+2; ->SUCC BIP(1015): ! PHRASE DOWN=NEW TEXT LEVEL LEVEL=LEVEL+1 TO AR4(R,0) DISPLAY(LEVEL)=R SFS(LEVEL)=0 R=R+4 ->SUCC BIP(1016): ! PHRASE UP 1 TEXTUAL LEVEL DISPLAY(LEVEL)=0 %WHILE SFS(LEVEL)#0 %CYCLE POP(SFS(LEVEL),I,J,K) %IF I=1 %THEN FAULT(53,K,0); ! FINISH MISSING %IF I=2 %THEN FAULT(13,K,0); ! %REPEAT MISSING %REPEAT LEVEL=LEVEL-1 ->SUCC BIP(1017): ! PHRASE LISTON LIST=1; ->SUCC BIP(1018): ! PHRASE LISTOFF LIST=0; ->SUCC BIP(1019): ! PHRASE COLON FOR LABEL ->FAIL %UNLESS CC(Q-1)=':' ->SUCC BIP(1020): ! PHRASE NOTE CONST %IF CTYPE=5 %THEN TOAR4(S-4,STRLINK) %AND STRLINK=S-4 ->SUCC BIP(1021): ! TRACE FOR ON CONDITIONS PARMTRACE=1; ->SUCC BIP(1022): ! SET MNEMONIC I=CC(Q); ! OBTAIN CURRENT CHARACTER S=M' ' %WHILE 'A'<=I<='Z' %CYCLE S=S<<8!I; Q=Q+1; I=CC(Q) %REPEAT ->FAIL %UNLESS I='_' %AND S#M' ' Q=Q+1; ->SUCC BIP(1023): ! PRIMARY FORMAT MNEMOINC %CYCLE I=7,1,126 ->PFND %IF OPC(I)=S %REPEAT ->FAIL PFND: ->FAIL %IF 8<=I>>3<=11 %AND I&7<=3 A(R)=2*I; ->UPR BIP(1024): ! SECONDARY FORMAT MNEMONIC %CYCLE I=64,8,88 %CYCLE J=0,1,3 ->SFND %IF OPC(I+J)=S %REPEAT %REPEAT ->FAIL SFND: A(R)=2*(I+J); ->UPR BIP(1025): ! TERTIARY FORMAT MNEMONIC %CYCLE I=3,-1,1 %IF OPC(I)=S %THEN A(R)=2*I %AND ->UPR %REPEAT; ->FAIL BIP(1026): ! P(OP)=+,-,&,****,**,*,!!,!, ! //,/,>>,<<,.,\\,\; I=CC(Q); ! OBTAIN CURRENT CHARACTER ->FAIL %UNLESS 32>((I-32)&31)&X'4237000A'#0 Q=Q+1 %IF I='+' %THEN A(R)=1 %AND ->UPR %IF I='-' %THEN A(R)=2 %AND ->UPR %IF I='&' %THEN A(R)=3 %AND ->UPR J=CC(Q) %IF I='*' %THEN %START %IF J#I %THEN A(R)=6 %AND ->UPR %IF CC(Q+1)=I=CC(Q+2) %THEN A(R)=4 %AND Q=Q+3 %AND ->UPR A(R)=5; Q=Q+1; ->UPR %FINISH %IF I='/' %THEN %START %IF J#I %THEN A(R)=10 %AND ->UPR A(R)=9; Q=Q+1; ->UPR %FINISH %IF I='!' %THEN %START %IF J#I %THEN A(R)=8 %AND ->UPR A(R)=7; Q=Q+1; ->UPR %FINISH %IF I='.' %THEN A(R)=13 %AND ->UPR %IF I=J='<' %THEN A(R)=12 %AND Q=Q+1 %AND ->UPR %IF I=J='>' %THEN A(R)=11 %AND Q=Q+1 %AND ->UPR %IF I='\' %THEN %START %IF J#I %THEN A(R)=15 %AND ->UPR Q=Q+1; A(R)=14; ->UPR %FINISH ->FAIL BIP(1027): ! PHRASE CHECK UI I=CC(Q); ! OBTAIN CURRENT CHARACTER ->SUCC %IF TRTAB(I)=2 %OR I='-' ->SUCC %IF X'80000000'>>(I&31)&X'14043000'#0 ->FAIL BIP(1028): ! P(+')=+,-,\,0 I=CC(Q); ! OBTAIN CURRENT CHARACTER %IF I='\' %OR I=X'7E' %THEN A(R)=3 %AND Q=Q+1 %AND ->UPR %IF I='-' %THEN A(R)=2 %AND Q=Q+1 %AND ->UPR %IF I='+' %THEN A(R)=1 %AND Q=Q+1 %AND ->UPR A(R)=4; ->UPR BIP(1029): ! PHRASE NOTE CYCLE TOAR4(R,0) PUSH(SFS(LEVEL),2,R,LINE) R=R+4 ->SUCC BIP(1030): ! P(,')=',',0 ! ! THIS IS VERY AWKWARD AS IT MEANS IT IS VERY TO HARD TO FIND ! THE END OF A PARAMETER LIST WITHOUT CHURNING. BY MAKING THIS A BIP ! WE CAN PEEP AHEAD FOR ')' AND FAIL HERE. ! I=CC(Q); ! OBTAIN CURRENT CHARACTER %IF I=')' %THEN ->FAIL %IF I=',' %THEN Q=Q+1 ->SUCC BIP(1031): ! PHRASE CHECKTYPE IE ENSURE ! FIRST LETTER IS(B,H,I,L,R,S) & ! 3RD LETTER IS (A,L,N,R,T) I=CC(Q); ! OBTAIN CURRENT CHARACTER ->FAIL %UNLESS I>128 %AND X'80000000'>>(I&31)&X'20C83000'#0%C %AND X'80000000'>>(CC(Q+2)&31)&X'400A2800'#0 ->SUCC BIP(1032): ! PHRASE COMP1 BIP(1037): ! PHRASE COMP2(IS 2ND HALF OF DSIDED) I=CC(Q); ! OBTAIN CURRENT CHARACTER ->FAIL %UNLESS 32>(I&31)&X'1004000E'#0 ! '='=1,'>='=2,'>'=3 ! '#' OR '\=' OR '<>'=4 ! '<='=5,'<'=6 ! 7UNUSED,'->'=8,'=='=9 ! '##' OR '\==' =10 %IF I='=' %THEN %START %IF CC(Q+1)=I %THEN J=9 %AND ->JOIN1 J=1; ->JOIN %FINISH %IF I='#' %THEN %START %IF CC(Q+1)=I %THEN J=10 %AND ->JOIN1 J=4; ->JOIN %FINISH %IF I='\' %AND CC(Q+1)='=' %THEN %START Q=Q+1 %IF CC(Q+1)='=' %THEN J=10 %AND ->JOIN1 J=4; ->JOIN %FINISH %IF I='>' %THEN %START %IF CC(Q+1)='=' %THEN J=2 %AND ->JOIN1 J=3; ->JOIN %FINISH %IF I='<' %THEN %START %IF CC(Q+1)='>' %THEN J=4 %AND ->JOIN1 %IF CC(Q+1)='=' %THEN J=5 %AND ->JOIN1 J=6; ->JOIN %FINISH %IF I='-' %AND CC(Q+1)='>' %THEN J=8 %AND ->JOIN1 ->FAIL JOIN1:Q=Q+1 JOIN: Q=Q+1 A(R)=J %IF ITEM=1032 %THEN SAVECOMP=J %AND ->UPR ! SAVE J TO CHECK DSIDED %IF SAVECOMP>6 %OR J>6 %THEN Q=Q-1 %AND ->FAIL;! ILLEGAL DSIDED ->UPR; ! NB OWNS WONT WORK IF ! COND EXPRS ALLOWED AS THE ! CAN BE NESTED! BIP(1033): ! P(ASSOP)- ==,=,<-,-> I=CC(Q); ! OBTAIN CURRENT CHARACTER %IF I='=' %THEN %START %IF CC(Q+1)='=' %THEN A(R)=1 %AND Q=Q+2 %AND ->UPR A(R)=2; Q=Q+1; ->UPR %FINISH %IF I='<' %AND CC(Q+1)='-' %THEN A(R)=3 %AND Q=Q+2 %AND ->UPR %IF I='-' %AND CC(Q+1)='>' %THEN A(R)=4 %AND Q=Q+2 %AND ->UPR ->FAIL BIP(1034): ! NOTE START TOAR4(R,0); ! HOLE FOR FORWARD PTR PUSH(SFS(LEVEL),1,R,LINE) R=R+4 ->SUCC BIP(1035): ! NOTE FINISH %IF SFS(LEVEL)=0 %THEN FAULT(51,0,0) %AND ->SUCC POP(SFS(LEVEL),I,J,K) %IF I=2 %THEN FAULT(59,K,0) TOAR4(J,STARSTART) ->SUCC BIP(1036): ! NOTE REPEAT %IF SFS(LEVEL)=0 %THEN FAULT(1,0,0) %AND ->SUCC POP(SFS(LEVEL),I,J,K) %IF I=1 %THEN FAULT(52,K,0); ! START INSTEAD OF CYCLE TOAR4(J,STARSTART) ->SUCC BIP(1038): ! INCLUDE "FILE" ->FAIL %IF VMEB=YES I=CC(Q) ->FAIL %UNLESS I=NL %OR I=';' Q=Q+1 %IF I=';' ->FAIL %UNLESS CTYPE=5 PUSH(IHEAD,FILEADDR,FILEPTR,FILEEND) CONSOURCE(STRING(ADDR(A(S))),FILEADDR);! DEPARTS IF FAILS FILEPTR=FILEADDR+INTEGER(FILEADDR+4) FILEEND=FILEADDR+INTEGER(FILEADDR) ->SUCC %END; !OF ROUTINE 'COMPARE' %ROUTINE PNAME(%INTEGER MODE) !*********************************************************************** !* MODE=0 FOR OLD NAME(ALREADY IN DICT), MODE=1 FOR NEW NAME * !*********************************************************************** %CONSTINTEGERARRAY HASH(0:7)=71,47,97,79,29,37,53,59; %INTEGER JJ, KK, LL, FQ, FS, T, S, I %LONGINTEGER DRDES,ACCDES HIT=0; FQ=Q; FS=CC(Q) %RETURN %UNLESS TRTAB(FS)=2 %AND M'"'#CC(Q+1)#M'''' ! 1ST CHAR MUST BE LETTER T=1 LETT(NEXT+1)=FS; JJ=71*FS %IF USE IMP=YES %THEN %START %CYCLE Q=Q+1 I=CC(Q) %EXIT %IF TRTAB(I)=0 JJ=JJ+HASH(T) %IF T<=7 T=T+1 LETT(NEXT+T)=I %REPEAT %FINISH %ELSE %START CYC: *LB_Q *ADB_1 *STB_Q *LB_(CC+%B) *LSS_(TRTAB+%B) *JAT_4, *STB_I *LSS_%B; ! I TO ACC *LB_T *CPB_7 *JCC_2, *IMY_(HASH+%B) *IAD_JJ *ST_JJ SKIP: *ADB_1 *STB_T *LSS_I *ADB_NEXT *ST_(LETT+%B) *J_ EXIT: %FINISH LETT(NEXT)=T; ! INSERT LENGTH S=T+1 FAULT(103,0,0) %IF NEXT+S>DSIZE; !DICTIONARY OVERFLOW JJ=(JJ+113*T)&NNAMES %IF USE IMP=YES %THEN %START %CYCLE KK=JJ, 1, NNAMES LL=WORD(KK) ->HOLE %IF LL=0; ! NAME NOT KNOWN ->FND %IF STRING(ADDR(LETT(NEXT)))=STRING(ADDR(LETT(LL))) %REPEAT %CYCLE KK=0,1,JJ LL=WORD(KK) ->HOLE %IF LL=0; ! NAME NOT KNOWN ->FND %IF STRING(ADDR(LETT(NEXT)))=STRING(ADDR(LETT(LL))) %REPEAT %FINISH %ELSE %START *LDTB_X'18000000' *LDB_S *LDA_LETT+4 *STD_DRDES *INCA_NEXT *STD_ACCDES *LB_JJ CYC1: *STB_KK *LB_(WORD+%B) *JAT_12, *LSD_ACCDES *LD_DRDES *INCA_%B *CPS_%L=%DR *JCC_8, *LB_KK *CPIB_NNAMES *JCC_7, *LB_0 CYC2: *STB_KK *LB_(WORD+%B) *JAT_12, *LSD_ACCDES *LD_DRDES *INCA_%B *CPS_%L=%DR *JCC_8, *LB_KK *CPIB_JJ *JCC_7, %FINISH FAULT(104, 0, 0); ! TOO MANY NAMES HOLE: %IF MODE=0 %THEN Q=FQ %AND %RETURN WORD(KK)=NEXT; NEXT=NEXT+S FND: LASTAT=FQ; HIT=1; LASTNAME=KK A(R+1)<-LASTNAME A(R)=LASTNAME>>8; R=R+2 LASTEND=Q %END %ROUTINE CONST(%INTEGER MODE) !*********************************************************************** !* SYNTAX CHECK AND EVALUATE ALL THE FORMS OF IMP CONSTANT * !* MODE=0 FOR INTEGER CONSTANTS #0 FOR ANY SORT OF CONSTANT * !*********************************************************************** %INTEGER Z, DOTSEEN, EBCDIC, FS, CPREC, RR, S, T, SS %LONGLONGREAL X,CVALUE,DUMMY %LONGINTEGER RADIXV %CONSTLONGLONGREAL TEN=R'41A00000000000000000000000000000' CPREC=5; RR=R; R=R+1 DOTSEEN=0; HIT=0 CVALUE=0; DUMMY=0; X=0; FS=CC(Q) S=0; ->N %IF M'0'<=FS<=M'9' ->DOT %IF FS='.' %AND MODE=0 %AND '0'<=CC(Q+1)<='9' ! 1 DIDT MIN CTYPE=1; EBCDIC=0 ->QUOTE %IF FS=M'''' ->STR2 %IF FS=34 ->NOTQUOTE %UNLESS CC(Q+1)=M''''; Q=Q+2 ->HEX %IF FS='X' ->MULT %IF FS='M' ->BIN %IF FS=M'B' ->RHEX %IF FS='R' %AND MODE=0 ->OCT %IF FS='K' %IF FS='C' %THEN EBCDIC=1 %AND ->MULT %IF FS='D' %AND MODE=0 %THEN %START CPREC=7 %IF M'0'<=CC(Q)<=M'9' %THEN ->N %IF CC(Q)='.' %THEN ->DOT %FINISH Q=Q-2; %RETURN QUOTE: ! SINGLE CH BETWEEN QUOTES S=CC(Q+1) Q=Q+2 %IF S=NL %THEN READLINE(1,'''') %AND Q=1 %IF CC(Q)=M'''' %THEN %START Q=Q+1 %IF S#M'''' %THEN ->IEND %IF CC(Q)=M'''' %THEN Q=Q+1 %AND ->IEND %FINISH %RETURN; ! NOT VALID NOTQUOTE: ! CHECK FOR E"...." %RETURN %UNLESS FS='E' %AND CC(Q+1)=M'"' EBCDIC=1; Q=Q+1 STR2: ! DOUBLE QUOTED STRING A(RR)=X'35'; TEXTTEXT(EBCDIC) CTYPE=5; %RETURN HEX: T=0; ! HEX CONSTANTS %CYCLE I=CC(Q); Q=Q+1 %EXIT %IF I=M'''' T=T+1 %RETURN %UNLESS %C ('0'<=I<='9' %OR 'A'<=I<='F' %OR 'a'<=I<='f') %AND T<17 %IF T=9 %THEN SS=S %AND S=0 S=S<<4+I&15+9*I>>6 %REPEAT %IF T>8 %START Z=4*(T-8) S=S!(SS<>(32-Z); CPREC=6 %FINISH IEND: %IF CPREC=6 %THEN TOAR4(R,SS) %AND R=R+4 %IF CPREC=5 %AND 0<=S<=X'7FFF' %START CPREC=4; TOAR2(R,S); R=R+2 %FINISH %ELSE TOAR4(R,S) %AND R=R+4 HIT=1 %UNLESS MODE#0 %AND CPREC=6 A(RR)=CPREC<<4!CTYPE %RETURN RHEX: ! REAL HEX CONSTANTS T=0 %CYCLE I=CC(Q); Q=Q+1 %IF T&7=0 %AND T#0 %START TOAR4(R,S); R=R+4; S=0 %FINISH %EXIT %IF I=M''''; T=T+1 %RETURN %UNLESS '0'<=I<='9' %OR 'A'<=I<='F' %OR 'a'<=I<='f' S=S<<4+I&15+9*I>>6 %REPEAT %RETURN %UNLESS T=8 %OR T=16 %OR T=32 %IF T=32 %THEN CPREC=7 %ELSE CPREC=4+T//8 A(RR)=CPREC<<4!2 HIT=1; %RETURN OCT: ! OCTAL CONSTANTS T=0 %CYCLE I=CC(Q); Q=Q+1; T=T+1 %EXIT %IF I=M'''' %RETURN %UNLESS '0'<=I<='7' %AND T<12 S=S<<3!(I&7) %REPEAT ->IEND MULT: T=0; ! MULTIPLE CONSTANTS RADIXV=0 %CYCLE I=CC(Q); Q=Q+1; T=T+1 %IF I=M'''' %THEN %START %IF CC(Q)#M'''' %THEN %EXIT %ELSE Q=Q+1 %FINISH %RETURN %IF T>=9 %IF EBCDIC#0 %THEN I=ITOETAB(I) RADIXV=RADIXV<<8!I %REPEAT SS<-RADIXV>>32 S<-RADIXV %IF SS # 0 %THEN CPREC=6 ->IEND BIN: T=0; ! BINARY CONST %CYCLE I=CC(Q); Q=Q+1; T=T+1 %EXIT %IF I=M'''' %RETURN %UNLESS '0'<=I<='1' %AND T<33 S=S<<1!I&1 %REPEAT ->IEND RADIX: ! BASE_VALUE CONSTANTS T=0; RADIXV=0 Q=Q+1 %CYCLE I=CC(Q) %EXIT %UNLESS '0'<=I<='9' %OR 'A'<=I<='Z' %IF I<='9' %THEN I=I-'0' %ELSE I=I-('A'-10) %EXIT %IF I>=S; ! MUST BE LESS THAN BASE T=T+1; Q=Q+1 RADIXV=RADIXV*S+I %REPEAT %RETURN %IF T=0; ! NO VALID DIGIGITS SS<-RADIXV>>32 S<-RADIXV CTYPE=1 %IF SS#0 %THEN CPREC=6; ->IEND N: ! CONSTANT STARTS WITH DIGIT I=CC(Q) %UNTIL IM'9' %CYCLE CVALUE=TEN*CVALUE+(I&15) Q=Q+1; I=CC(Q); ! ONTO NEXT CHAR %REPEAT %IF I='_' %AND CVALUE<33 %THEN S=INT(CVALUE) %AND ->RADIX ->ALPHA %UNLESS MODE=0 %AND I='.' DOT: Q=Q+1; X=TEN; I=CC(Q) DOTSEEN=1; ! CONSTANT HAS DECIMAL POINT %WHILE M'0'<=I<=M'9' %CYCLE CVALUE=CVALUE+(I&15)/X X=TEN*X; Q=Q+1; I=CC(Q) %REPEAT ALPHA: ! TEST FOR EXPONENT %IF MODE=0 %AND CC(Q)='@' %THEN %START Q=Q+1; X=CVALUE Z=1; I=CC(Q) %IF I='-' %THEN Z=-1 %IF I='+' %OR I='-' %THEN Q=Q+1 CONST(2) %IF HIT=0 %THEN %RETURN HIT=0 R=RR+1 %IF A(R)>>4#4 %THEN %RETURN; ! EXPONENT MUST BE HALFINTEGER S=FROM AR2(R+1)*Z %IF S=-99 %THEN CVALUE=0 %ELSE %START %IF USE IMP=NO %THEN %START *MPSR_X'8080'; ! MASK OUT REAL OVERFLOW %FINISH %WHILE S>0 %CYCLE S=S-1 CVALUE=CVALUE*TEN %IF USE IMP=NO %THEN %START *JAT_15, %FINISH %REPEAT %WHILE S<0 %AND CVALUE#0 %CYCLE S=S+1 CVALUE=CVALUE/TEN %REPEAT %FINISH %FINISH ! SEE IF IT IS INTEGER %IF FS='D' %THEN %START I=CC(Q) %IF I='''' %THEN Q=Q+1 %ELSE %RETURN DOTSEEN=1; ! ENSURE NOT TAKEN AS INTEGER %FINISH %IF DOTSEEN=1 %OR CVALUE>IMAX %OR FRACPT(CVALUE)#0 %C %THEN CTYPE=2 %ELSE CTYPE=1 %AND S=INT(CVALUE) %IF CTYPE=1 %THEN ->IEND %IF CPREC=5 %THEN CPREC=6; ! NO 32 BIT REAL CONSTS %IF CPREC=6 %THEN %START %IF USE IMP=NO %THEN %START; ! SOFTWARE ROUND IN MC CODE ONLY *LSD_CVALUE *AND_X'FF00000000000000' *SLSD_CVALUE+8 *AND_X'0080000000000000' *LUH_%TOS *RAD_CVALUE *ST_CVALUE %FINISH %FINISH TOAR8(R,CVALUE); R=R+8 %IF CPREC=7 %THEN TOAR8(R,LONGREAL(ADDR(CVALUE)+8)) %C %AND R=R+8 A(RR)=CPREC<<4+CTYPE HIT=1 FAIL: %END %ROUTINE TEXTTEXT(%INTEGER EBCDIC) !*********************************************************************** !* PROCESSES TEXT BETWEEN DOUBLE QUOTES AND STORES IN ISO OR EBCDIC * !*********************************************************************** %INTEGER J, II %CONSTINTEGER QU='"' I=CC(Q) S=R+4; R=R+5; HIT=0 %RETURN %UNLESS I=QU; ! FAIL UNLESS INITIAL QUOTE Q=Q+1 %CYCLE I=CC(Q) %IF EBCDIC#0 %THEN II=ITOETAB(I) %ELSE II=I A(R)=II; R=R+1 %IF I=QU %THEN %START Q=Q+1 %IF CC(Q)#QU %THEN %EXIT %FINISH %IF I=10 %THEN READLINE(1,QU) %ELSE Q=Q+1 FAULT(106,0,0) %IF R-S>256 %REPEAT R=R-1; J=R-S-1 A(S)=J; HIT=1 %END BEND:%END; ! OF BLOCK CONTAINING PASS 1 %IF LEVEL>1 %THEN FAULT(15, LEVEL-1, 0) I=0 NEWLINE %IF FAULTY=0 %THEN %START WRITE(LINE, 5) PRINT STRING(" LINES ANALYSED IN") WRITE(INT(1000*(CPUTIME-CTIME)),5) PRINT STRING(" MSECS - SIZE=") WRITE(P1SIZE, 5) %IF LINE>90 %AND LIST#0 %THEN NEWPAGE %ELSE NEWLINE %FINISH %ELSE %START PRINTSTRING("CODE GENERATION NOT ATTEMPTED ") COMREG(24)=8 COMREG(47)=FAULTY %STOP %FINISH %BEGIN !*********************************************************************** !* SECOND OR CODE GENERATING PASS * !*********************************************************************** %INTEGERARRAY REGISTER, GRUSE, GRAT, GRINF1, GRINF2, OLINK(0:7) %BYTEINTEGERARRAY CODE, GLABUF(0:268) %INTEGERARRAY PLABS, DESADS, PLINK(0:31) %INTEGERARRAY SET, STACKBASE, RAL, FLAG, L, M, NMDECS, ONWORD, ONINF,%C JUMP, LABEL, JROUND, DIAGINF, DISPLAY, UNATT FORMATS, %C AUXSBASE, NAMES (0:MAXLEVELS) %INTEGERARRAY AVL WSP(0:4,0:MAXLEVELS) %INTEGERARRAYFORMAT CF(0:12*NNAMES) %INTEGERARRAYNAME CTABLE %ROUTINESPEC CNOP(%INTEGER I, J) %ROUTINESPEC PCONST(%INTEGER X) %ROUTINESPEC PSF1(%INTEGER OPCODE,K,N) %ROUTINESPEC PF1(%INTEGER OPCODE,KP,KPP,N) %ROUTINESPEC PSORLF1(%INTEGER OPCODE,KP,KPP,N) %ROUTINESPEC PF2(%INTEGER OPCODE,H,Q,N,MASK,FILLER) %ROUTINESPEC PF3(%INTEGER OPCODE,MASK,KPPP,N) %ROUTINESPEC NOTE CREF(%INTEGER CA) %INTEGERFNSPEC PARAM DES(%INTEGER PREC) %INTEGERFNSPEC MAPDES(%INTEGER PREC) %INTEGERFNSPEC SPECIAL CONSTS(%INTEGER WHICH) %ROUTINESPEC STORE CONST(%INTEGERNAME D,%INTEGER L,AD) %INTEGERFNSPEC WORD CONST(%INTEGER VALUE) %ROUTINESPEC DUMP CONSTS %ROUTINESPEC PLANT(%INTEGER VALUE) %ROUTINESPEC PLUG(%INTEGER I, J, K, BYTES) %ROUTINESPEC CODEOUT %ROUTINESPEC PROLOGUE %ROUTINESPEC EPILOGUE %ROUTINESPEC COMPILE A STMNT %ROUTINESPEC CSS(%INTEGER P) %ROUTINESPEC LOAD DATA %ROUTINESPEC ABORT !*DELSTART %ROUTINESPEC PRINT USE !*DELEND %CYCLE I=0,1,7 REGISTER(I)=0; GRUSE(I)=0; GRINF1(I)=0; GRAT(I)=0 GRINF2(I)=0 %REPEAT %CYCLE I=0, 1, MAXLEVELS SET(I)=0; STACKBASE(I)=0; RAL(I)=0 JUMP(I)=0; JROUND(I)=0 LABEL(I)=0; FLAG(I)=0; UNATT FORMATS(I)=0 L(I)=0; M(I)=0; DIAGINF(I)=0 DISPLAY(I)=0; ONWORD(I)=0; ONINF(I)=0 NAMES(I)=-1 %CYCLE J=0,1,4 AVL WSP(J,I)=0 %REPEAT %REPEAT CTABLE==ARRAY(ADDR(ASLIST(1)),CF) CONST HOLE=0 PROLOGUE LINE=0 NEXTP=1; LEVEL=1; STMTS=0 RLEVEL=0; RBASE=0 %WHILE A(NEXTP+3)!A(NEXTP+4)#0 %CYCLE COMPILE A STMNT %REPEAT LINE=99999 EPILOGUE LOAD DATA %STOP %ROUTINE COMPILE A STMNT %INTEGER I !*DELSTART %IF DCOMP#0 %AND CA>CABUF %THEN CODEOUT %AND PRINTUSE !*DELEND I=NEXTP NEXTP=NEXTP+A(NEXTP)<<16+A(NEXTP+1)<<8+A(NEXTP+2) LINE=A(I+3)<<8+A(I+4) STMTS=STMTS+1 CSS(I+5) ! CHECK ASL %IF LINE&7=0 %END %ROUTINE LOAD DATA !*********************************************************************** !* PASS INFORMATION TO LPUT TO ENABLE IT TO GENERATE THE * !* LOADER DATA AND COMPLETE THE PROGRAM FILE. * !*********************************************************************** %INTEGER LANGFLAG,PARMS GLACA=(GLACA+7)&(-8) USTPTR=(USTPTR+7)&(-8) CODE OUT CNOP(0, 8) DUMP CONSTS %IF PARMTRACE=0 %THEN LANGFLAG=6 %ELSE LANGFLAG=1 LANGFLAG=LANGFLAG<<24 PARMS=(PARMDIAG<<1!PARMLINE)<<1!PARMTRACE FIXED GLA(4)=LANGFLAG!RELEASE<<16!(CPRMODE&1)<<8!PARMS;! LANG RLSE & MAINPROG I=GLACA-GLACABUF %IF INHCODE=0 %THEN %START LPUT(2, I, GLACABUF, ADDR(GLABUF(0))) %UNLESS I=0 ! BACK OF GLAP LPUT(2, FIXEDGLALEN, 0, ADDR(FIXED GLA(0)));! FRONT OF GLAP LPUT(19,2,8,5); ! RELOCATE GLA ST ADDRESS LPUT(19,2,12,4); ! RELOCATE CODE ST ADDRESS I=X'E2E2E2E2' LPUT(4, 4, SSTL, ADDR(I)) ! %FINISH SSTL=(SSTL+11)&(-8) PRINTSTRING(" CODE") WRITE(CA, 6); PRINTSTRING(" BYTES GLAP") WRITE(GLACA, 3); PRINTSTRING("+") WRITE(USTPTR, 1); PRINTSTRING(" BYTES DIAG TABLES") WRITE(SSTL, 3); PRINTSTRING(" BYTES TOTAL") REGISTER(0)=CA; REGISTER(1)=GLACA REGISTER(2)=0 REGISTER(3)=SSTL REGISTER(4)=USTPTR K=CA+GLACA+SSTL+USTPTR; REGISTER(5)=K WRITE(K, 5); PRINTSTRING(" BYTES") NEWLINE; PRINT CH(13); ! MARKER FOR COMP TO PRINT !SUMMARY %IF FAULTY=0 %THEN %START WRITE(STMTS, 7); PRINTSTRING(" STATEMENTS COMPILED IN") WRITE(INT(1000*(CPUTIME-CTIME)),5) PRINTSTRING(" MSECS") COMREG(47)=STMTS; ! NO OF STMTS FOR COMPER %FINISH %ELSE %START PRINTSTRING("PROGRAM CONTAINS"); WRITE(FAULTY, 2) PRINTSTRING(" FAULT"); PRINTSYMBOL('S') %IF FAULTY>1 COMREG(47)=FAULTY; ! NO OF FAULTS FOR COMPER %FINISH NEWLINES(2) NEWLINE I=0; I=8 %IF FAULTY#0 COMREG(24)=I %IF INHCODE=0 %THEN LPUT(7, 24, 0, ADDR(REGISTER(0))) ! SUMMARY INFO..REGISTER AS BUF PPROFILE %STOP %END ! !*********************************************************************** !* IMP CODE PLANTING ROUTINES * !* CODE AND GLAP ARE PUT INTO THE BUFFERS 'CODE,GLABUF(0:268)' * !* BY A NUMBER OF TRIVIAL ROUTINES.LPUT IS CALLED TO ADD THE * !* BUFFER TO THE OUTPUT FILE. THE BUFFERS ARE BASICALLY 0:255 * !* WITH A 12-BYTE MARGIN TO MINIMISE THE NUMBER OF TESTS FOR * !* THE BUFFER FULL CONDITION * !* * !* PPCURR(GLACURR) IS THE BUFFER POINTER * !* CA(GLACA) IS THE RELATIVE ADDRESS OF THE NEXT BYTE * !* CABUF(GLACABUF) IS CA(GLACA) FOR START OF BUFFER * !*********************************************************************** !*DELSTART %ROUTINE RECODE(%INTEGER S,F,AD) %IF S#F %START PRINTSTRING(" CODE FOR LINE"); WRITE(LINE,5) NCODE(S,F,AD) %FINISH %END !*DELEND %ROUTINE CODEOUT %IF PPCURR>0 %THEN %START !*DELSTART RECODE(ADDR(CODE(0)), ADDR(CODE(PPCURR)), CABUF) %C %IF DCOMP#0 !*DELEND LPUT(1, PPCURR, CABUF, ADDR(CODE(0))) %IF INHCODE=0 PPCURR=0; CABUF=CA %FINISH %END %ROUTINE PLANT(%INTEGER HALFWORD) !*********************************************************************** !* ADD A HALF WORD OF BINARY TO THE BUFFER * !*********************************************************************** %IF USE IMP=YES %THEN %START CODE(PPCURR)<-HALFWORD>>8 CODE(PPCURR+1)<-HALFWORD PPCURR=PPCURR+2 %FINISH %ELSE %START *LDA_CODE+4 *LDTB_X'58000002' *LB_PPCURR *LSS_HALFWORD *ST_(%DR+%B) *ADB_2 *STB_PPCURR %FINISH CA=CA+2 CODEOUT %IF PPCURR>=256 %END %ROUTINE PCONST(%INTEGER WORD) !*********************************************************************** !* ADD A WORD OF BINARY TO THE BUFFER * !*********************************************************************** %IF USE IMP=YES %THEN %START %INTEGER I %CYCLE I=24,-8,0 CODE(PPCURR)=WORD>>I&255 PPCURR=PPCURR+1 %REPEAT %FINISH %ELSE %START *LDA_CODE+4 *LDTB_X'58000004' *LSS_WORD *LB_PPCURR *ST_(%DR+%B) *ADB_4 *STB_PPCURR %FINISH CA=CA+4 CODE OUT %IF PPCURR>=256 %END %ROUTINE PSF1(%INTEGER OPCODE,K,N) !*********************************************************************** !* PLANT THE HALFWORD FORMS OF PRIMARY FORMAT NR INSTRNS * !* IF N IS TOO LARGE FOR THE SHORT FORM PF1 IS CALLED TO PLANT * !* THE CORRESPONDING LONG FORM * !*********************************************************************** %INTEGER KPP ! ABORT %UNLESS 0<=K<=2 %AND OPCODE&1=0 %IF (K=0 %AND -64<=N<=63) %OR (K#0 %AND 0<=N<=511) %START %IF K#0 %THEN N=N//4 %IF USE IMP=YES %THEN %START CODE(PPCURR)=OPCODE!K>>1 CODE(PPCURR+1)=(K&1)<<7!N&127 PPCURR=PPCURR+2 %FINISH %ELSE %START *LSS_OPCODE *USH_1 *OR_K *USH_7 *SLSS_N *AND_127 *LB_PPCURR *OR_%TOS *LDA_CODE+4 *LDTB_X'58000002' *ST_(%DR+%B) *ADB_2 *STB_PPCURR %FINISH CA=CA+2 CODEOUT %IF PPCURR>=256 %FINISH %ELSE %START %IF K=0 %THEN KPP=0 %ELSE KPP=2 PF1(OPCODE,K>>1<<1,KPP,N) %FINISH %END %ROUTINE PF1(%INTEGER OPCODE,KP,KPP,N) !*********************************************************************** !* PLANT THE NORMAL FORMS OF PRIMARY FORMAT INSTRNS(IE THOSE * !* WHICH DO NOT DEPEND ON THE SIZE OF N) * !*********************************************************************** %INTEGER INC ! ABORT %UNLESS 0<=KP<=3 %AND 0<=KPP<=7 %AND OPCODE&1=0 INC=2 %IF KPP=PC %THEN %START %IF N<0 %THEN N=N&X'7FFFFFFF' %AND NOTE CREF(CA) N=(N-CA)//2 %FINISH %IF (1<>16&3) CODE(PPCURR+2)=N>>8&255 CODE(PPCURR+3)=N&255 %FINISH %ELSE %START *LSS_OPCODE *USH_1 *OR_3 *USH_2 *OR_KP *USH_3 *OR_KPP *USH_18 *SLSS_N *AND_X'3FFFF' *OR_%TOS *LDTB_X'58000004' *LDA_CODE+4 *LB_PPCURR *ST_(%DR+%B) %FINISH %IF KPP<=5 %THEN INC=4 PPCURR=PPCURR+INC CA=CA+INC CODEOUT %IF PPCURR>=256 %END %ROUTINE PSORLF1(%INTEGER OPCODE,KP,KPP,N) !*********************************************************************** !* AS PF1 BUT CUT VALID FORMS TO SHORT FORM * !*********************************************************************** %INTEGER INC INC=2 %IF (KPP=0=KP %AND -64<=N<=63) %OR%C (KPP=LNB %AND KP&1=0 %AND 0<=N<=511) %START %IF KPP=LNB %THEN KP=1+KP>>1 %IF KP#0 %THEN N=N//4 %IF USE IMP=YES %THEN %START CODE(PPCURR)=OPCODE!KP>>1 CODE(PPCURR+1)=(KP&1)<<7!(N&127) %FINISH %ELSE %START *LSS_OPCODE *USH_1 *OR_KP *USH_7 *SLSS_N *AND_127 *LB_PPCURR *OR_%TOS *LDA_CODE+4 *LDTB_X'58000002' *ST_(%DR+%B) %FINISH %FINISH %ELSE %START %IF KPP=PC %THEN %START %IF N<0 %THEN N=N&X'7FFFFFFF' %AND NOTE CREF(CA) N=(N-CA)//2 %FINISH %IF (1<>16&3) CODE(PPCURR+2)=N>>8&255 CODE(PPCURR+3)=N&255 %FINISH %ELSE %START *LSS_OPCODE *USH_1 *OR_3 *USH_2 *OR_KP *USH_3 *OR_KPP *USH_18 *SLSS_N *AND_X'3FFFF' *OR_%TOS *LDTB_X'58000004' *LDA_CODE+4 *LB_PPCURR *ST_(%DR+%B) %FINISH %IF KPP<=5 %THEN INC=4 %FINISH CA=CA+INC; PPCURR=PPCURR+INC CODEOUT %IF PPCURR>=256 %END %ROUTINE PF2(%INTEGER OPCODE,H,Q,N,MASK,FILLER) !*********************************************************************** !* PLANT SECONDARY(STORE TO STORE) FORMAT INSTRNS * !* THESE MAY BE 16 OR 32 BIT DEPENDING ON Q * !*********************************************************************** ! ABORT %UNLESS 0<=H<=1 %AND 0<=Q<=1 %AND 0<=N<=127 %C %AND OPCODE&1=0 PLANT(OPCODE<<8!H<<8!Q<<7!N) %IF Q#0 %THEN PLANT(MASK<<8!FILLER) %END %ROUTINE PF3(%INTEGER OPCODE,MASK,KPPP,N) !*********************************************************************** !* PLANT THE TERTIARY(JUMP) FORMAT INSTRUCTIONS * !*********************************************************************** ! ABORT %UNLESS 0<=MASK<=15 %AND 0<=KPPP<=7 %AND OPCODE&1=0 %IF KPPP=PC %THEN %START %IF N<0 %THEN N=N&X'7FFFFFFF' %AND NOTE CREF(CA) N=(N-CA)//2 %FINISH CODE(PPCURR)=OPCODE!MASK>>3&1 CODE(PPCURR+1)=(MASK&7)<<5!KPPP<<2!(N>>16&3) PPCURR=PPCURR+2 CA=CA+2 %IF KPPP<=5 %THEN %START CODE(PPCURR)=N>>8&255 CODE(PPCURR+1)=N&255 PPCURR=PPCURR+2; CA=CA+2 %FINISH CODEOUT %IF PPCURR>=256 %END %ROUTINE NOTE CREF(%INTEGER CA) !*********************************************************************** !* NOTE THAT A (PC+N) INSTRUCTION HAS N RELATIVE TO CONST TABLE * !* NOT REATIVE TO CODE. REMEMBER THE ADDRESS OF THE INSTRUCTION * !* SO THAT AN LPUT(18) CORRECTION CAN BE MADE AT END OF COMPILATION * !*********************************************************************** %RECORD(LISTF)%NAME CELL CELL==ASLIST(CREFHEAD) %IF CREFHEAD=0 %OR CELL_S3#0 %THEN %C PUSH(CREFHEAD,CA,0,0) %AND %RETURN %IF CELL_S2=0 %THEN CELL_S2=CA %ELSE CELL_S3=CA %END %ROUTINE CNOP(%INTEGER I, J) PSF1(JUNC,0,1) %WHILE CA&(J-1)#I %END %ROUTINE PGLA(%INTEGER BDRY, L, INF ADR) %INTEGER I, J J=GLACA; GLACA=(J+BDRY-1)&(-BDRY) GLACURR=GLACURR+GLACA-J; ! COMPLETE THE ROUNDING %IF L+GLACURR>256 %THEN %START %IF INHCODE=0 %C %THEN LPUT(2, GLACURR, GLACABUF, ADDR(GLABUF(0))) GLACURR=0; GLACABUF=GLACA %FINISH %CYCLE I=0,1,L-1 GLABUF(GLACURR+I)=BYTE INTEGER(I+INF ADR) %REPEAT GLACA=GLACA+L; GLACURR=GLACURR+L %END %ROUTINE PLUG(%INTEGER AREA, AT, VALUE, BYTES) !*********************************************************************** !* WRITE UP TO ONE WORD INTO OBJECT FILE OUT OF SEQUENCE * !*********************************************************************** %INTEGERNAME WCABUF %INTEGER I, RELAD, BUFAD WCABUF==CABUF; BUFAD=ADDR(CODE(0)) %IF AREA=2 %THEN WCABUF==GLACABUF %AND BUFAD=ADDR(GLABUF(0)) RELAD=AT-WCABUF %IF 0<=RELAD<=256 %AND AREA<=3 %THEN %START %CYCLE I=0,1,BYTES-1 BYTEINTEGER(RELAD+BUFAD+I)<-VALUE>>((BYTES-1-I)<<3) %REPEAT %FINISH %ELSE %START %IF RELAD=-2 %THEN CODEOUT %IF INHCODE=0 %THEN LPUT(AREA,BYTES,AT,ADDR(VALUE)+4-BYTES) !*DELSTART NCODE(ADDR(VALUE)+4-BYTES,ADDR(VALUE)+4,AT) %IF DCOMP=1=AREA !*DELEND %FINISH %END %INTEGERFN PARAM DES(%INTEGER PREC) !*********************************************************************** !* SET UP BNDED L=1 DESRIPTOR FOR PASSING VARIABLE BY REFERENCE * !* ONLY THE TOP HALF IS SET UP * !*********************************************************************** %INTEGER K,DES K=DESADS(PREC) %RESULT=K %UNLESS K=0 %IF PREC=4 %THEN DES=X'58000002' %ELSE DES=PREC<<27!1 K=WORD CONST(DES) DESADS(PREC)=K %RESULT=K %END %INTEGERFN MAPDES(%INTEGER PREC) !*********************************************************************** !* SET UP 8BIT ZERO ADDRESS UNSCALED BCI DESCRTR FOR MAPPING * !*********************************************************************** %INTEGER K,DES0,DES1 K=DESADS(PREC+8) %RESULT=K %UNLESS K=0 %IF PREC=4 %THEN DES0=X'58000002' %ELSE DES0=X'03000000'!PREC<<27 DES1=0; STORE CONST(K,8,ADDR(DES0)) DESADS(PREC+8)=K %RESULT=K %END %INTEGERFN SPECIAL CONSTS(%INTEGER WHICH) !*********************************************************************** !* PUTS CERTAIN SPECIAL CONSTANTS INTO THE CONSTANT TABLE ON * !* DEMAND AND REMEMBERS THEIR POSN TO AVOID SEARCHONG * !*********************************************************************** %CONSTINTEGERARRAY SCS(0:7) = X'40800000',0, X'41100000',0, 1,0, X'4F000000',0; %INTEGER K K=DESADS(WHICH+16) %RESULT=K %UNLESS K=0 STORE CONST(K,8,ADDR(SCS(2*WHICH))) DESADS(WHICH+16)=K %RESULT=K %END %INTEGERFN WORD CONST(%INTEGER VALUE) !*********************************************************************** !* SIMPLE INTERFACE TO STORE CONST FOR 32 BIT CONSTS * !*********************************************************************** %INTEGER K STORE CONST(K,4,ADDR(VALUE)) %RESULT=K %END %ROUTINE STORE CONST(%INTEGERNAME D, %INTEGER L, AD) !*********************************************************************** !* PUT THE CONSTANT VAL OF LENGTH 'L' INTO THE CONSTANT TABLE * !* A CHECK IS MADE TO SEE IF THE CONSTANT HAS ALREADY * !* BEEN INSERTED IN WHICH CASE THE OLD COPY IS REUSED * !*********************************************************************** %INTEGER I, J, K, C1, C2, C3, C4, LP LP=L//4; C2=0; C3=0; C4=0 %CYCLE I=0,1,L-1 BYTEINTEGER(ADDR(C1)+I)=BYTEINTEGER(AD+I) %REPEAT K=CONST BTM; ! AFTER STRINGS IN CTABLE %IF L=4 %THEN %START %IF USE IMP=YES %THEN %START %WHILE K *ICP_(%DR+%B) *JCC_7, *CPB_CONSTHOLE *JCC_8, *LSS_%B *IMY_4 *OR_X'80000000' *ST_(D) *EXIT_-64 %FINISH %FINISH %ELSE %START J=CONSTPTR-LP %WHILE K<=J %CYCLE %IF CTABLE(K)=C1 %AND CTABLE(K+1)=C2 %AND %C (CONSTHOLE=K+LP) %START %IF L=8 %OR (CTABLE(K+2)=C3 %C %AND CTABLE(K+3)=C4) %THEN D=4*K!X'80000000' %C %AND %RETURN %FINISH K=K+2 %REPEAT %FINISH SKIP: %IF L=4 %AND CONSTHOLE#0 %START CTABLE(CONSTHOLE)=C1 D=4*CONSTHOLE!X'80000000' CONSTHOLE=0 %RETURN %FINISH %IF L>4 %AND CONST PTR&1#0 %C %THEN CONSTHOLE=CONST PTR %AND CONSTPTR=CONST PTR+1 D=4*CONST PTR!X'80000000' CTABLE(CONSTPTR)=C1 CTABLE(CONSTPTR+1)=C2 %IF L=16 %THEN CTABLE(CONSTPTR+2)=C3 %C %AND CTABLE(CONSTPTR+3)=C4 CONST PTR=CONST PTR+LP %IF CONST PTR>CONST LIMIT %THEN FAULT(102, WKFILEK,0) %END %ROUTINE GET ENV(%INTEGERNAME HEAD) !*********************************************************************** !* SAVE A COPY OF THE REGISTER STATE FOR FUTURE REFERENCE * !*********************************************************************** %INTEGER I, USE %CYCLE I=0, 1, 7 USE=GRUSE(I)&X'FF'; ! MAIN USE ONLY PUSH(HEAD, GRINF1(I), GRAT(I), I<<8!USE) %IF USE#0 %REPEAT %END %ROUTINE RESTORE(%INTEGER HEAD) !*********************************************************************** !* RESET THE REGISTERS TO ENVIRONMENT IN LIST HEADED BY 'HEAD' * !*********************************************************************** %INTEGER I, R, USE, INF, AT %CYCLE I=0, 1, 7 %IF REGISTER(I)>=0 %THEN GRUSE(I)=0 %AND GRINF1(I)=0 %REPEAT %WHILE HEAD#0 %CYCLE POP(HEAD, INF, AT, I) R=I>>8; USE=I&255 %IF REGISTER(R)>=0 %THEN GRUSE(R)=USE %AND GRINF1(R)=INF GRAT(R)=AT %REPEAT %END %ROUTINE RELOCATE(%INTEGER GLARAD,VALUE,AREA) !*********************************************************************** !* PLANTS A WORD IN THE GLA (IF GLARAD<0) AND ARRANGES TO * !* RELOCATE IT RELATIVE TO AN AREA(CODE=1,GLA=2,CST=4,GST=5 * !* IF THE RELOCATION IS RELATIVE TO SYMBOL TABLES THE WORD * !* CAN NOT BE RELOCATED TILL SIZE OF THE CODE(OR GLA) IS KNOWN * !*********************************************************************** %IF GLARAD<0 %THEN PGLA(4,4,ADDR(VALUE)) %AND GLARAD=GLACA-4 LPUT(19,2,GLARAD,AREA) %END %ROUTINE GXREF(%STRING(31) NAME,%INTEGER MODE,XTRA,AT) !*********************************************************************** !* ASK LPUT TO ARRANGE FOR A DOUBLE WORD AT 'AT' IN THE GLA * !* TO CONTAIN A DESCRIPTOR FOR NAME 'NAME'. * !* MODE=0 STATIC CODE XREF * !* MODE=1 DYNAMIC CODE XREF * !* MODE=2 DATA XREF XTRA=MINIMIUM LENGTH * !*********************************************************************** %INTEGER LPUTNO %IF MODE=2 %THEN LPUTNO=15 %ELSE LPUTNO=MODE+12 LPUT(LPUTNO,XTRA,AT,ADDR(NAME)) %END %ROUTINE CXREF(%STRING(255) NAME,%INTEGER MODE,XTRA,%INTEGERNAME AT) !*********************************************************************** !* CREATE A ZEROED AREA IN THE GLA AND CALL GXREF TO GET * !* IT FILLED AT LOAD TIME WITH INFORMATION ON AN EXTERNAL OBJECT * !* PARAMETERS ARE AS FOR GXREF. * !*********************************************************************** %INTEGER Z1,Z2 Z1=0; Z2=0 PGLA(8,8,ADDR(Z1)); ! 2 ZERO WORDS AT=GLACA-8 GXREF(NAME,MODE,XTRA,AT) %END %ROUTINE CODEDES(%INTEGERNAME AT) !*********************************************************************** !* PUT A CODE DESCRIPTOR INTO THE PLT FOR USE BY DEFINE EP * !*********************************************************************** %INTEGER DESC1,DESC2 DESC1=X'E1000000'; DESC2=0 %IF CDCOUNT=0 %THEN FIXED GLA(0)=DESC1 %AND AT=0 %C %ELSE PGLA(8,8,ADDR(DESC1)) %AND AT=GLACA-8 CDCOUNT=CDCOUNT+1 %END %ROUTINE DEFINE EP(%STRING(255)NAME, %INTEGER ADR,AT,MAIN) !*********************************************************************** !* AN EP CONSISTS OF A CODE DESCRIPTOR IN THE GLA(PLT) OF * !* FILE CONTAINING THE EP. LPUT IS TOLD ABOUT THIS AND THE LOADER* !* ARRANGES TO PUT A DESCRIPTOR-DESCRIPTOR TO THE CODE-DESC * !* IN THE GLA OF ANY FILE REFERENCES THIS EP. THIS FIRST WORD * !* OF ICLS PLT IS THE MAIN EP AND WE MIMIC THIS AS FAR AS POSS * !*********************************************************************** %IF AT=0 %THEN FIXED GLA(1)=ADR %ELSE PLUG(2,AT+4,ADR,4) RELOCATE(AT+4,ADR,1) LPUT(11,MAIN<<31!2,AT,ADDR(NAME)) %IF NAME#"" %END %ROUTINE PROLOGUE !*********************************************************************** !* GENERATES THE SUBROUTINE THAT ALWAYS ARE REQUIRED ONTO THE * !* FRONT OF THE OBJECT PROGRAM WHERE THEY ARE DIRECTLY ADDRESABLE* !*********************************************************************** %INTEGERFNSPEC STRINGIN(%INTEGER POS) %ROUTINESPEC ERR EXIT(%INTEGER A, B, C) %INTEGER I, K, L, STCA I=X'C2C2C2C2' LPUT(4,4,0,ADDR(I)) SSTL=4 %CYCLE I=0, 1, 31 PLABS(I)=0; PLINK(I)=0 DESADS(I)=0 %REPEAT ! ! GENERATE THE FIXED-FLOAT CONSTANTS THAT MAY BE NEEDED ! PLABS(1)=CA %CYCLE I=0, 1, 1 PCONST(UNASSPAT) %REPEAT ! ! GENERATE THE RUN TIME ERROR ROUTINE :- ! MDIAGS FOR NR IS %ROUTINE MDIAGS(%INT PC,LNB,ERROR,XTRA) ! PC IS A DUMMY (SEG FIELD ONLY USED) EXCEPT AFTER CONTINGENCY ! ON ENTRY TO THIS SUBROUTINE ERROR & XTRA ARE IN ACC AS 64 BIT INTEGER ! ENTRY HAS BEEN BY JLK SO RETURN ADDRESS STACKED ! !RTF PRCL 4 TO PLANT PARAMS ! JLK +1 STACK DUMMY PC ! STLN TOS LNB AS SECOND PARAMETER ! ST TOS ERROR NO AS THIRD PARAM ! LXN (LNB+4) POINTER TO GLA ! RALN 9 TO STORED LNB ! CALL ((XNB+10)) VIA XREF=DESCRIPTOR-DESCRIPTOR ! J TOS BACK AFTER A MONITOR ! PLABS(2)=CA PSF1(PRCL,0,4) PSF1(JLK,0,1) PF1(STLN,0,TOS,0) PF1(ST,0,TOS,0) PSF1(LXN,1,16) PSF1(RALN,0,9) PF1(CALL,2,XNB,40) PF1(JUNC,0,TOS,0) ! ! SUBROUTINE TO CALL DEBUG ROUTINE(S#IMPMON) LINE NO IN ACC ! ! PRCL 4 ! ST TOS ! LXN (LNB+4) ! RALN 6 ! CALL ((XNB+IMPMONEPDISP)) ! JUNC TOS ! %IF PARMDBUG#0 %THEN %START PLABS(3)=CA CXREF("S#IMPMON",PARMDYNAMIC,2,K) PSF1(PRCL,0,4) PF1(ST,0,TOS,0) PSF1(LXN,1,16) PSF1(RALN,0,6) PF1(CALL,2,XNB,K) PF1(JUNC,0,TOS,0) %FINISH ! ! SUBROUTINE TO ADVANCE STACK FRONT BY B WORDS AND FILL WITH UNASSIGNED ! ! JAT 12,*+13 B IS ZERO ! LSS TOS ! STSF TOS ! LDTB STRING DECRIPTOR SET UP DESCRIPTOR FOR MVL ! LDA TOS ! ASF B ADVANCE BY B WORDS ! MYB 4 CHANGE B TO BYTES ! LDB B AND MOVE TO BOUND FIELD ! MVL L=DR AND FILL WITH X80S ! ST TOS ! J TOS RETURN ! %IF PARMCHK=1 %THEN %START; ! ONLY REQUIRED WITH CHKING CNOP(0,4); K=CA PCONST(X'58000000') PLABS(4)=CA PF3(JAT,12,0,13) PF1(LSS,0,TOS,0) PF1(STSF,0,TOS,0) PF1(LDTB,0,PC,K) PF1(LDA,0,TOS,0) PF1(ASF,0,BREG,0) PSF1(MYB,0,4) PF1(LDB,0,BREG,0) PF2(MVL,1,1,0,0,UNASSPAT&255) PF1(ST,0,TOS,0) PF1(JUNC,0,TOS,0) %FINISH ! ! SOME ERROR ROUTINES ! ERR EXIT(5, X'801', 0) %IF PARMOPT#0; ! UNASSIGNED VARIABLE ERR EXIT(6, X'802', 0); ! SWITCH LABEL UNSET ERR EXIT(7, X'505', 1); ! ILLEGEAL EXPONENTIATION ERR EXIT(8,X'201', 0) %IF PARMOPT#0; ! EXCESS BLOCKS ERR EXIT(9, X'601', 0); ! CAPACITY EXCEEDED ERR EXIT(10,21, 0) ; ! NO RESULT ERR EXIT(11,X'501', 0) %IF PARMOPT#0; ! CYCLE NOT VALID ERR EXIT(12,X'701',0); ! RES FAILS ERR EXIT(13,36,0) %IF PARMOPT#0; ! WRONG NO OF PARAMS ! ! PUT THE STRINGS ONTO THE FRONT OF CONSTANT AREA ! CTABLE(0)=X'18000001' CTABLE(1)=4 STCA=8; L=ADDR(CTABLE(0)) CONST PTR=2; ! IN CASE NO STRINGS %WHILE STRLINK#0 %CYCLE I=STRLINK; STRLINK=FROM AR4(I) TO AR4(I,STRINGIN(I+4)); ! CHANGE LINK TO STRING ADDR %REPEAT STRLINK=X'80000000' CONST BTM=CONST PTR %IF PARMOPT#0 %THEN CTABLE(CONST PTR)=M'IDIA' %AND %C CONST PTR=CONST PTR+1 GXREF(MDEP,PARMDYNAMIC,2,40) %IF PARMPROF#0 %THEN %START; ! ALLOCATE PROFILE COUNT AREA I=X'38000001'+LINE K=8 PARMPROF=GLACA PGLA(4,8,ADDR(I)) K=0 %CYCLE I=0,1,LINE PGLA(4,4,ADDR(K)) %REPEAT LINE=0 %FINISH LEVEL=1 %CYCLE I=0,1,31 %IF PLINK(I)#0 %THEN CLEAR LIST(PLINK(I)) %REPEAT %RETURN %INTEGERFN STRINGIN(%INTEGER POS) !*********************************************************************** !* PUT A STRING INTO THE CONSTANT AREA CHECKING FOR DUPLICATES * !*********************************************************************** %INTEGER J,K,IND,HD %RECORD(LISTF)%NAME CELL K=A(POS) %IF K=0 %THEN %RESULT=0 IND=K&31; HD=PLINK(IND) %WHILE HD#0 %CYCLE CELL==ASLIST(HD) %IF CELL_S1=K %AND STRING(L+CELL_S2)=STRING(ADDR(A(POS))) %C %THEN %RESULT=CELL_S2-4 HD=CELL_LINK %REPEAT HD=STCA BYTEINTEGER(L+STCA)=K; STCA=STCA+1 %CYCLE J=POS+1,1,POS+K BYTE INTEGER(L+STCA)=A(J) STCA=STCA+1 %REPEAT CONST PTR=((STCA+7)&(-8))>>2 PUSH(PLINK(IND),K,HD,0) %RESULT=HD-4 %END %ROUTINE ERR EXIT(%INTEGER LAB, ERRNO, MODE) !*********************************************************************** !* MODE=0 FOR DUMMY(ZERO) XTRA - MODE=1 XTRA IN BREG * !*********************************************************************** PLABS(LAB)=CA %IF ERRNO=36 %THEN PSF1(LLN,1,0);! WRONG NO OF PARAMS ! UNDO WRONG RALN BEFORE DIAGS %IF MODE=0 %THEN PSF1(LSS,0,0) %ELSE PF1(LSS,0,BREG,0) PSF1(LUH,0,ERRNO) PSF1(JLK,0,(PLABS(2)-CA)//2) %END %END %ROUTINE CSS(%INTEGER P) %ROUTINESPEC MERGE INFO %ROUTINESPEC REDUCE ENV(%INTEGERNAME HEAD) %ROUTINESPEC ENTER JUMP(%INTEGER MASK,STAD,FLAG) %INTEGERFNSPEC ENTER LAB(%INTEGER M,FLAG) %ROUTINESPEC REMOVE LAB(%INTEGER LAB) %ROUTINESPEC CEND(%INTEGER KKK) %INTEGERFNSPEC CCOND(%INTEGER CTO,A,B) %ROUTINESPEC CHECK STOF %INTEGERFNSPEC REVERSE(%INTEGER MASK) %ROUTINESPEC SET LINE %INTEGERFNSPEC SET XORYNB(%INTEGER WHICH,RLEVEL) %INTEGERFNSPEC XORYNB(%INTEGER USE,INF) %ROUTINESPEC GET IN ACC(%INTEGER ACC,SIZE,AC,AREA,DISP) %INTEGERFNSPEC AREA CODE %INTEGERFNSPEC AREA CODE2(%INTEGER BS) %ROUTINESPEC CUI(%INTEGER CODE) %ROUTINESPEC ASSIGN(%INTEGER A,B) %ROUTINESPEC CSTART(%INTEGER CCRES,MODE) %ROUTINESPEC CCYCBODY(%INTEGER UA,ELAB,CLAB) %ROUTINESPEC CLOOP(%INTEGER ALT,MARKC,MARKUI) %ROUTINESPEC CIFTHEN(%INTEGER MARKIU,MARKC,MARKUI,MARKE,MARKR,SKIP) %ROUTINESPEC CREATE AH(%INTEGER MODE) %ROUTINESPEC TORP(%INTEGERNAME HEAD,BOT,NOPS) %INTEGERFNSPEC INTEXP(%INTEGERNAME VALUE) %INTEGERFNSPEC CONSTEXP(%INTEGER PRECTYPE) %ROUTINESPEC CSEXP(%INTEGER REG,MODE) %ROUTINESPEC CSTREXP(%INTEGER A,B) %ROUTINESPEC CRES(%INTEGER LAB) %ROUTINESPEC EXPOP(%INTEGER A,B,C,D) %ROUTINESPEC TEST APP(%INTEGERNAME NUM) %ROUTINESPEC SKIP EXP %ROUTINESPEC SKIP APP %ROUTINESPEC NO APP %INTEGERFNSPEC DOPE VECTOR(%INTEGER A,B,MODE,ID,%INTEGERNAME C,D) %ROUTINESPEC DECLARE ARRAYS(%INTEGER A,B) %ROUTINESPEC DECLARE SCALARS(%INTEGER A,B) %ROUTINESPEC MAKE DECS(%INTEGER Q) %ROUTINESPEC SAVE AUX STACK %ROUTINESPEC RESET AUX STACK %ROUTINESPEC CRSPEC(%INTEGER M) %INTEGERFNSPEC SET SWITCHLAB(%INTEGER HEAD,LAB,FNAME,BIT) %ROUTINESPEC CFPLIST(%INTEGERNAME A,B) %ROUTINESPEC CFPDEL %ROUTINESPEC CLT %ROUTINESPEC CQN(%INTEGER P) %ROUTINESPEC GET WSP(%INTEGERNAME PLACE,%INTEGER SIZE) %ROUTINESPEC RETURN WSP(%INTEGER PLACE,SIZE) %INTEGERFNSPEC TSEXP(%INTEGERNAME VALUE) %ROUTINESPEC CRCALL(%INTEGER RTNAME) %ROUTINESPEC NAMEOP(%INTEGER Z,REG,SIZE,NAMEP) %ROUTINESPEC CNAME(%INTEGER Z,REG) %ROUTINESPEC CANAME(%INTEGER Z,BS,DP) %ROUTINESPEC CSNAME(%INTEGER Z,REG) %ROUTINESPEC TEST ASS(%INTEGER REG,TYPE,SIZE) %ROUTINESPEC COPY TAG(%INTEGER KK) %ROUTINESPEC REDUCE TAG %ROUTINESPEC RT JUMP(%INTEGER CODE,%INTEGERNAME L) %ROUTINESPEC STORE TAG(%INTEGER KK,SLINK) %ROUTINESPEC UNPACK %ROUTINESPEC PACK(%INTEGERNAME PTYPE) %ROUTINESPEC DIAG POINTER(%INTEGER LEVEL) %ROUTINESPEC RDISPLAY(%INTEGER KK) %ROUTINESPEC RHEAD(%INTEGER KK) %ROUTINESPEC ODD ALIGN %INTEGERFNSPEC PTR OFFSET(%INTEGER RLEV) %ROUTINESPEC PPJ(%INTEGER MASK,N) %INTEGERFNSPEC CFORMATREF %ROUTINESPEC CRFORMAT(%INTEGERNAME OPHEAD,OPBOT,NLIST,MRL,%INTEGER INIT) %INTEGERFNSPEC DISPLACEMENT(%INTEGER LINK) %INTEGERFNSPEC COPY RECORD TAG(%INTEGERNAME SUBS) %ROUTINESPEC SAVE IRS %ROUTINESPEC COPY DR %ROUTINESPEC BOOT OUT(%INTEGER REG) %ROUTINESPEC CHANGE RD(%INTEGER REG) %ROUTINESPEC FORGET(%INTEGER REG) %ROUTINESPEC REMEMBER %ROUTINESPEC NOTE ASSMENT(%INTEGER REG,ASSOP,VAR) %SWITCH SW(1:24) %RECORDFORMAT RD(%BYTEINTEGER UPTYPE,PTYPE,XB,FLAG,%C %INTEGER D,XTRA) %INTEGER SNDISP,ACC,K,KFORM,STNAME,MIDCELL %INTEGER TCELL,NUMMOD,JJ,JJJ,KK,QQ,MARKER,REPORTUI,XDISP,MASK, %C BASE,AREA,ACCESS,DISP,EXTRN, CURR INST,VALUE,STRINGL, %C PTYPE,I,J,OLDI,USEBITS,TWSPHEAD,STRFNRES, %C MARKIU,MARKUI,MARKC,MARKE,MARKR,INAFORMAT %INTEGER LITL,ROUT,NAM,ARR,PREC,TYPE %INTEGERARRAY SGRUSE,SGRINF(0:7) %RECORD(RD) EXPOPND; ! RESULT RECORD FOR EXPOP CURR INST=0 INAFORMAT=0 TWSPHEAD=0 LITL=0; ROUT=0; PTYPE=-1; NAM=0; ARR=0; SNDISP=0; KFORM=0; ACC=0 ->SW(A(P)) SW(13): ! INCLUDE SOMETHING SW(24): ! REDUNDANT SEP SW(2): ! CSSEXIT: LAST INST=CURR INST %WHILE TWSPHEAD#0 %CYCLE POP(TWSPHEAD,JJ,KK,QQ) RETURN WSP(JJ,KK) %REPEAT %RETURN SW(1): !(UI)(S) FAULT(57,0,0) %UNLESS LEVEL>=2 MARKER=P+1+A(P+1)<<8+A(P+2) P=P+3 ->LABFND %IF A(MARKER)=1 %IF A(MARKER)=2 %THEN SET LINE %AND CUI(0) %AND ->CSSEXIT MARKE=0; MARKR=0 MARKUI=P; MARKIU=MARKER+1 MARKC=MARKIU+1 %IF A(MARKER)=3 %THEN CIFTHEN(MARKIU,MARKC,MARKUI,0,0,NO) %C %AND ->CSSEXIT CLOOP(A(MARKIU),MARKC+2,MARKUI) ->CSSEXIT LABFND: ->SWITCH %UNLESS A(P)=1 %AND A(P+5)=2; ! 1ST OF UI AND NO APP ->SWITCH %UNLESS A(P+6)=2 %AND A(P+7)=2;! NO ENAMSE OR ASSNMNT JJ=ENTER LAB(FROM AR2(P+3),0); ->CSSEXIT SW(5): ! %CYCLE FAULT(57,0,0) %UNLESS LEVEL>=2 %IF A(P+5)=2 %THEN %START; ! OPEN CYCLE CLOOP(0,P+1,0) %FINISH %ELSE %START SET LINE CLOOP(6,P+6,P+1) %FINISH ->CSSEXIT ! SW(6): ! REPEAT ->CSSEXIT SW(22): ! '%CONTROL' (CONST) J=FROM AR4(P+2) CODEOUT DCOMP=J>>28; ->CSSEXIT ! SW(3): ! (%IU)(COND)%THEN(UI)(ELSE') MARKIU=P+1; MARKC=MARKIU+3 MARKR=P+2+A(P+2)<<8+A(P+3); ! ! FROMAR2(P+2) MARKE=0; MARKUI=0 %IF A(MARKR)=3 %THEN %START MARKE=MARKR+1+FROMAR2(MARKR+1) MARKUI=MARKR+3 %FINISH CIFTHEN(MARKIU,MARKC,MARKUI,MARKE,MARKR,NO) ->CSSEXIT SW(4): ! '%FINISH(ELSE')(S) ->CSSEXIT SWITCH: %BEGIN; ! SWITCH LABEL %INTEGER NAPS,FNAME FNAME=FROM AR2(P+3) %UNLESS A(P)=1 %AND A(P+5)=1 %THEN FAULT(5,0,FNAME) %AND ->BEND ! 1ST OF UI + APP P=P+3; TEST APP(NAPS) P=P+6 %UNLESS INTEXP(JJ)=0 %THEN FAULT(41,0,0) %AND ->BEND ! UNLESS EXPRESSION EVALUATES AND %UNLESS NAPS=1 %THEN FAULT(21,NAPS-1,FNAME) %AND ->BEND ! NO REST OF APP %UNLESS A(P+1)=2=A(P+2) %THEN FAULT(5,0,FNAME) %AND ->BEND ! NO ENAME OR REST OF ASSIGMENT COPY TAG(FNAME) %IF OLDI#LEVEL %OR TYPE#6 %THEN FAULT(4,0,FNAME) %AND ->BEND %IF SET SWITCHLAB(K,JJ,FNAME,1)#0 %THEN FAULT(6,JJ,FNAME) BEND: %END; ->CSSEXIT SW(23): ! SWITCH(*): %BEGIN %INTEGER FNAME,LB,UB,JJ,RES FNAME=FROM AR2(P+1) COPY TAG (FNAME) %IF OLDI=LEVEL %AND TYPE=6 %START FROM123(K,JJ,LB,UB) %CYCLE JJ=LB,1,UB RES=SET SWITCHLAB(K,JJ,FNAME,0) %REPEAT %FINISH %ELSE FAULT(4,0,FNAME) %END; ->CSSEXIT ! SW(7): ! (%WU)(SC)(COND)(RESTOFWU) FAULT(57,0,0) %UNLESS LEVEL>=2 MARKIU=P+1; ! TO WHILE/UNTIL MARKC=MARKIU+3; ! TO (SC)(COND) CLOOP(A(MARKIU)+3,MARKC,MARKIU+1+FROMAR2(MARKIU+1)) ->CSSEXIT ! SW(8): ! SIMPLE DECLN FAULT(57,0,0) %UNLESS LEVEL>=2 FAULT(40,0,0) %IF NMDECS(LEVEL)&1#0 QQ=P; P=P+5 MARKER=P+FROMAR2(P); ! TO ALT OF DECLN P=P+2; ROUT=0; LITL=0 %IF A(MARKER)#1 %THEN %START; ! ARRAY DECLARATIONS CLT FAULT(70,ACC-1,0) %IF TYPE=5 %AND (ACC<=0 %OR ACC>256) NAM=0 SET LINE QQ=2-A(P+1); P=P+2; ! QQ=1 FOR ARRAYFORMATS DECLARE ARRAYS(QQ,KFORM) %FINISH %ELSE %START %IF A(QQ+1)=128 %OR A(P)>3 %START;! NOT LINKED&SHUFFLED CLT CQN(P+1); P=P+2 DECLARE SCALARS(1,KFORM) %FINISH %FINISH ->CSSEXIT ! SW(9): ! %END %BEGIN %SWITCH S(1:5) -> S(A(P+1)) S(1): ! ENDOFPROGRAM S(2): ! ENDOFFILE %IF CPRMODE=0 %THEN CPRMODE=2 FAULT(15,LEVEL+CPRMODE-3,0) %UNLESS LEVEL+CPRMODE=3 CEND(CPRMODE) ->BEND S(3): ! ENDOFLIST LIST=0; ->BEND S(4): ! END %IF CPRMODE=1 %AND LEVEL=2 %THEN FAULT(14,0,0) %ELSE %C CEND(FLAG(LEVEL)) BEND: %END ->CSSEXIT ! SW(11): %BEGIN %INTEGER MARKER1,KK,KKK,PTR,PTYPEP,CNT,PP %RECORD(LISTF)%NAME LCELL %STRING(34)XNAME P=P+1; MARKER1=FROM AR2(P)+P; ! (SEX)(RT)(SPEC')(NAME)(FPP) AGN: Q=P; KK=FROM AR2(MARKER1+5); ! KK ON NAME EXTRN=A(P+2) LITL=EXTRN&3 %IF A(MARKER1)=1 %THEN %START;! P<%SPEC'>='%SPEC' P=P+3; CRSPEC(1-EXTRN>>2);! 0 FOR ROUTINESPEC ! 1 FOR EXTERNAL (ETC) SPEC ->BEND %FINISH COPY TAG(KK) XNAME<-STRING(DICTBASE+WORD(KK)) %IF EXTRN=1 %THEN XNAME<-"S#".XNAME %IF A(MARKER1+7)=1 %THEN XNAME<-STRING(ADDR(A(MARKER1+8))) %IF OLDI=LEVEL %THEN %START %IF CPRMODE=0 %THEN CPRMODE=2;! FLAG AS FILE OF ROUTINES ! %IF (CPRMODE=2 %AND LEVEL=1) %START %IF EXTRN=3 %THEN EXTRN=2 %IF EXTRN=4 %THEN XNAME="" JJ=MIDCELL; ! CODE DESCRIPTOR REL ADDR %IF J=14 %THEN CODEDES(JJ);! TWO DESCR FOR XSPEC/XRTINE %IF EXTRN#4 %THEN USEBITS=2 DEFINE EP(XNAME,CA,JJ,0) %IF JJ#0 %THEN PSF1(INCA,0,-JJ) %FINISH %ELSE %START; ! EXTERNALS IN PRGM OR WRNG LEVEL FAULT(56,0,KK) %UNLESS EXTRN=4; EXTRN=4 %FINISH %IF A(P+3)=1 %THEN KKK=LITL<<14!X'1000' %ELSE %START ROUT=1; P=P+4; ! FIGURE OUT PTYPE FOR FNS&MAPS CLT; ARR=0; NAM=0 %IF A(P)=2 %THEN NAM=2; ! SET NAME ARRAY BIT FOR MAPS PACK(KKK); ! AND STORE PTYPE IN KKK %FINISH %FINISH %UNLESS OLDI=LEVEL %AND J>=14 %AND PTYPE=KKK %START P=Q+3; CRSPEC(0); P=Q; ->AGN %FINISH PTYPE=PTYPE!(EXTRN&3)<<14; ! DEAL WITH %ROUTINESPEC FOLLOWED ! BY %EXTERNALROUTINE LCELL==ASLIST(TAGS(KK)) LCELL_S1=LCELL_S1&X'3FF0'!PTYPE<<16!USEBITS<<14 ! NEWPTYPE & SET J=0 %IF J=14 %THEN LCELL_S2=JJ; ! NO OUTSTANDING JUMP TO EXTERNAL ! SUB ENTRY DESAD FOR REF DESAD JJ=K; PLABEL=PLABEL-1 %UNLESS COMPILER=1 %OR (CPRMODE=2 %AND LEVEL=1) %START %IF JROUND(LEVEL+1)=0 %START; ! NOT JUMP OUTSTANDING JROUND(LEVEL+1)=PLABEL ENTER JUMP(15,PLABEL,0) %FINISH %FINISH PTYPEP=PTYPE P=MARKER1+8 %IF A(P-1)=1 %THEN P=P+A(P)+1; ! SKIP OVER ALIASNAME RHEAD(KK) N=20; CNT=1 %WHILE A(P)=1 %CYCLE; ! WHILE SOME (MORE) FP PART PP=P+1+FROMAR2(P+1) P=P+3 CFPDEL PTR=P %UNTIL A(PTR-1)=2 %CYCLE; ! CYCLE DOWN NAMELIST %IF JJ#0 %THEN %START FROM12(JJ,J,JJJ); ! EXTRACT PTYPE XTRA INFO %UNLESS J>>16=PTYPE %AND(PTYPE#5 %OR JJJ>>16=ACC)%C %THEN FAULT(9,CNT,KK) %FINISH %ELSE FAULT(8,0,KK);! MORE FPS THAN IN SPEC PTR=PTR+3 CNT=CNT+1 MLINK(JJ) %REPEAT DECLARE SCALARS(0,KFORM) P=PP %REPEAT; ! UNTIL NO MORE FP-PART N=(N+3)&(-4); ! TO WORD BOUNDARY AFTER ALL SYSTEM ! STANDARD PARAMETERS HAVE BEEN DECLARED FAULT(10,0,KK) %UNLESS JJ=0 PTYPE=PTYPEP %IF PTYPE&X'F0F'=5 %THEN N=N+8;! STR FNS RESULT PARAM IS STACKED ! AS XTRA PARM JUST BEFORE DISPLAY RDISPLAY(KK) MAKE DECS(MARKER1+1) BEND: %END; ->CSSEXIT ! ! SW(14): !%BEGIN %BEGIN PTYPE=0 %IF LEVEL=1 %AND RLEVEL=0 %START %IF CPRMODE=0 %THEN %START CODE DES(JJ) DEFINE EP(MAINEP, CA, JJ, 1) RLEVEL=1; RBASE=1 L(1)=0; M(1)=0; DIAGINF(1)=0; AUXSBASE(1)=0 CPRMODE=1 N=24; NMAX=N FORGET(-1) DIAG POINTER(LEVEL+1) ! ! THE CODE PLANTED IS AS FOLLOWS:- ! STD (LNB+3) SAVE DESCRIPTOG TO GLA(PLT) ! LXN (LNB+4) TO GLA(PLT) ! STLN (XNB+5) SAVE LNB FOR STOP SEQUENCE ! ASF 1 FOR REPORT WORD ! PSF1(STD,1,12) PSF1(LXN,1,16) PF1(STLN,0,XNB,20) PSF1(ASF,0,1) ! ! ! SET THE PROGRAM MASK TO MASK OUT UNDERFLOW AND ALLOW ALL OTHER INTS ! ! MPSR X'40C0' ! PF1(MPSR,0,0,X'40C0') PTYPE=1 %FINISH %ELSE FAULT(58,0,0) %FINISH %ELSE SET LINE; ! SO 'ENTERED FROM LINE' IS OK RHEAD(-1) RDISPLAY(-1) MAKE DECS(P+1) %END ->CSSEXIT ! SW(15): ! '%ON'(EVENT')(N)(NLIST)'%START' FAULT(57,0,0) %UNLESS LEVEL>=2 FAULT(40,0,0) %IF NMDECS(LEVEL)&1#0 NMDECS(LEVEL)=NMDECS(LEVEL)!X'11';! NO MORE DECS AND IN ONCOND %IF STACK=0 %THEN %START SAVE AUX STACK DISP=AUXSBASE(LEVEL) PSF1(LSS,2,DISP); ! SAVE TOP OF AUX STACK PSF1(ST,1,DISP+12) %FINISH GRUSE(ACCR)=0 PSF1(CPSR,1,N+8) PLABEL=PLABEL-1 JJJ=PLABEL ENTER JUMP(15,JJJ,B'10'); ! JUMP ROUND ON BODY ! P=P+2; JJ=0; ! SET UP A BITMASK IN JJ %UNTIL A(P-1)=2 %CYCLE; ! UNTIL NO MORE NLIST KK=A(P) FAULT(26,KK,0) %UNLESS 1<=KK<=14 JJ=JJ!1<<(KK-1) P=P+2 %REPEAT KK=CA; PGLA(4,4,ADDR(CA)) RELOCATE(GLACA-4,KK,1); ! ENTRY ADDRESS IN PLT ONWORD(LEVEL)=JJ<<18!(GLACA-4) FORGET(-1) PSF1(ST,1,N); ! STORE EVENT,SUBEVENT&LINE PSF1(MPSR,1,N+8) ONINF(LEVEL)=N; N=N+12 %IF STACK=0 %THEN %START PSF1(LSS,1,DISP+12); ! RESET AUX STACK TOP PSF1(ST,2,DISP) %FINISH CSTART(0,3) NMDECS(LEVEL)=NMDECS(LEVEL)!!X'10';! NOT IN ONCOND JJ=ENTER LAB(JJJ,B'111'); ! REPLACE ENVIRONMENT ->CSSEXIT SW(16): FAULT(57,0,0) %UNLESS LEVEL>=2 %BEGIN; ! %SWITCH (SWITCH LIST) %INTEGER Q,RANGE,KKK,KK,LB,PP,D0,D1,OPHEAD,V,ARRP,R Q=P ARRP=1 %IF PARMOPT=0 %THEN ARRP=2 %UNTIL A(Q)=2 %CYCLE; ! UNTIL NO'REST OF SW LIST' P=P+3 P=P+3 %WHILE A(P)=1 P=P+4; ! TO P(+') KKK=INTEXP(LB); ! EXTRACT LOWER BOUND P=P+3 KKK=KKK!INTEXP(KK); ! EXTRACT UPPER BOUND RANGE=(KK-LB+1) %IF RANGE<=0 %OR KKK#0 %START FAULT(38,1-RANGE,FROMAR2(Q+1)) LB=0; KK=10; RANGE=11 %FINISH %IF GLACA+8-4*LB<0 %THEN ARRP=1;! ZEROETH ELEMENT OFF FRONT PTYPE=X'56'+ARRP<<8; ! WORD LABEL ARRAY PP=P; P=Q+1 %UNTIL A(P-1)=2 %CYCLE; ! DOWN NAMELIST K=FROM AR2(P) P=P+3 OPHEAD=0; R=LB ! ! SET UP A BIT LIST (96 BITS PER CELL) TO CHECK FOR SWITCH LABELS ! SET TWICE ! %UNTIL R>KK %CYCLE PUSH(OPHEAD,0,0,0) R=R+96 %REPEAT ! ! FOR CHECKING MODE USE A BOUNDED WORD DESCRIPTOR AND WORD SIZE ! ENTRIES PRESET TO "SW LABEL NOT SET". OPTIMISING USE BCI WORD ! ARRAYS WITH BASE SET TO ZEROETH ELEMENT D1=(GLACA+15)&(-8); ! FIRST TABLE ENTRY D0=X'28000000'!RANGE; ! SCALED WORD DES %IF ARRP=2 %THEN %START D0=D0!X'01000000' %UNLESS LB=0;! SET BCI BIT D1=D1-4*LB %FINISH PGLA(8,8,ADDR(D0)) SNDISP=GLACA>>2-2; ! WORD PLT DISP RELOCATE(GLACA-4,D1,2); ! RELOCATE RELATIVE TO GLA PUSH(OPHEAD,D1,LB,KK) KFORM=0; ACC=4 J=1; STORE TAG(K,OPHEAD) ! !THE TABLE WILL CONSIST OF RELATIVE DISPLACEMENTS FROM THE TABLE HEAD ! TO THE LABEL POSN. SET ALL TO GO TO PLAB(6) INITIALLY ! V=PLABS(6) %CYCLE KKK=LB,1,KK RELOCATE(-1,V,1); ! PLABS(6) RELOCATED BY HD OF CODE %REPEAT %REPEAT; ! FOR ANY MORE NAMES IN NAMELIST Q=PP; P=Q %REPEAT; ! UNTIL A(Q)=2 %END;->CSSEXIT ! SW(17): LIST=1; ->CSSEXIT ! SW(12): ! '%OWN' (TYPE)(OWNDEC) %BEGIN !*********************************************************************** !* INITIALISED DECLARATION GO INTO THE GLA OR GLA SYMBOL TABLES * !* EXCEPT FOR CONST ARRAYS WHICH GO INTO THE CODE SYMBOL TABLES * !* STRINGS AND ARRAYS HAVE A HEADER IN THE GLA. LPUT ARRANGES * !* FOR THE LOADER TO RELOCATE THE HEADERS. * !* EXTERNALS ARE IDENTICAL WITH OWN BUT ALSO HAVE A DATA EP DEFN * !* IN THE LOAD DATA SO THEY CAN BE FOUND AT LOAD TIME * !* EXTRINSICS HAVE A DATA REFERENCE AND A DUMMY HEADER IN THE GLA* !* THE LOADER USES THE FORMER TO RELOCATE THE LATTER. * !*********************************************************************** %ROUTINESPEC CLEAR(%INTEGER L) %ROUTINESPEC STAG(%INTEGER J, DATALEN) %ROUTINESPEC XTRACT CONST(%INTEGER CONTYPE, CONPREC) %ROUTINESPEC INIT SPACE(%INTEGER A, B) %INTEGER LENGTH, PP, SIGN, UICONST, ICONST, %C TAGDISP, EPTYPE, EPDISP, AH1, AH2, AH3, AH4, AD, %C STALLOC, SPOINT, CONSTSFOUND, CPREC, EXTRN, NNAMES, %C MARK, LPUTP, LB, CTYPE, CONSTP, FORMAT, %C DIMEN, SACC, TYPEP %LONGREAL RCONST, LRCONST %OWNLONGREAL ZERO=0 %STRING (255) SCONST, NAMTXT %INTEGERNAME STPTR LPUTP=5; STPTR==USTPTR; ! NORMAL CASE GLA SYMBOLTABLES ! FAULT(40,0,0) %IF NMDECS&1#0 EXTRN=A(P+1) P=P+2 %IF EXTRN>=4 %THEN EXTRN=0; ! CONST & CONSTANT->0 SNDISP=0 CONSTS FOUND=0 %IF EXTRN=0 %THEN LPUTP=4 %AND STPTR==SSTL CLT ! ! CHECK FOR %SPEC AND CHANGE EXTERNAL SPEC TO EXTRINSIC ! %IF A(P+2)=1 %START %IF EXTRN=2 %THEN EXTRN=3 %ELSE FAULT(46,0,0) %FINISH %IF 2<=EXTRN<=3 %AND ((A(P)=1 %AND A(P+1)#3) %OR %C (A(P)=2 %AND A(P+1)#2)) %THEN FAULT(46,0,0) LITL=EXTRN %IF LITL<=1 %THEN LITL=LITL!!1 %IF A(P)=1 %THEN CQN(P+1) %ELSE ARR=1 %AND NAM=0 %IF TYPE=5 %AND NAM=0 %AND (ACC<=0 %OR ACC>256) %THEN %C FAULT(70,ACC-1,0) %AND ACC=2 STALLOC=ACC; ! ALLOCATION OF STORE FOR ITEM OR POINTER ROUT=0; PACK(PTYPE) %IF NAM#0 %START; ! OWN POINTERS %IF ARR#0 %THEN STALLOC=16 %ELSE STALLOC=8 %FINISH %ELSE %START; ! OWN VARS & ARRAYS ->NON SCALAR %IF ARR#0 %FINISH P=P+2 %UNTIL A(MARK)=2 %CYCLE; ! UNTIL NULL MARK=P+1+FROM AR2(P+1) PP=P+3; P=PP+2; ! PP ON FIRST NAME' K=FROM AR2(PP); ! FOR ERROR MESSAGES RE CONST NAMTXT=STRING(DICTBASE+WORD(K)) %IF A(P)=1 %THEN NAMTXT<-STRING(ADDR(A(P+1))) %AND %C P=P+A(P+1)+1 P=P+1; ! P ON CONST' ! ! OBTAIN THE INITIAL CONSTANT,ITS TYPE(CTYPE) AND SIGN(SIGN) ! ICONST=0; UICONST=0 RCONST=0; LRCONST=0; SCONST="" SIGN=3; CTYPE=TYPE; CONSTSFOUND=0; CPREC=PREC %IF TYPE=3 %THEN CTYPE=1; ! RECS INITTED TO REPEATED BYTE %IF NAM#0 %THEN CTYPE=1 %AND CPREC=5 P=P+1 %IF A(P-1)=1 %THEN %START; ! CONSTANT GIVEN XTRACT CONST(CTYPE,CPREC) %FINISH %ELSE %START WARN(7,K) %IF EXTRN=0; ! %CONST NOT INITIALISED %FINISH J=0 %IF NAM#0 %THEN %START; ! OWNNAMES AND ARRAYNAMES %IF ARR=0 %THEN %START UICONST=X'FFFF'!PREC<<27 PGLA(8,STALLOC,ADDR(UICONST)) %FINISH %ELSE %START; ! ARRAYNAMES %IF TYPE<=3 %AND EXTRN=0 %THEN ARR=2 %AND PACK(PTYPE) AH1=PREC<<27!X'FFFFFF' %IF PREC=4 %THEN AH1=X'58000002' AH1=AH1!(1-PARMARR)<<24 %IF TYPE=3 %THEN AH1=AH1!1<<25 AH2=ICONST AH3=5<<27!3 SNDISP=DOPE VECTOR(TYPE,ACC,-1,K,QQ,LB) AH4=SNDISP+12 %IF EXTRN#0 %THEN SNDISP=0 %ELSE %C SNDISP=(SNDISP&X'3FFFF')>>2 PGLA(8,STALLOC,ADDR(AH1)) RELOCATE(GLACA-4,AH4,1) AH4=AH4<<1>>3!X'80000000' NOTE CREF(AH4!(GLACA-4)>>2<<16) %FINISH TAGDISP=GLACA-STALLOC; EPDISP=TAGDISP STAG(TAGDISP,STALLOC) %CONTINUE %FINISH %IF EXTRN=3 %THEN %START; ! EXTRINISIC PTYPE=PTYPE!X'400'; ! FORCE NAM=1 (IE VIA POINTER) AH2=PREC<<27!(STALLOC//BYTES(PREC)) AH3=0 PGLA(8,8,ADDR(AH2)) TAGDISP=GLACA-8 GXREF(NAMTXT,2,2<<24!STALLOC,TAGDISP+4);! RELOCATE BY EXTERNAL STAG(TAGDISP,STALLOC) %CONTINUE %FINISH %IF TYPE=5 %THEN %START; ! STRING AH3=STPTR AD=ADDR(SCONST) LPUT(LPUTP,STALLOC,AH3,AD) %IF INHCODE=0 ! /P STRING STPTR=(STPTR+ACC+3)&(-4) AH2=3<<27!STALLOC PGLA(8,8,ADDR(AH2)) TAGDISP=GLACA-8 RELOCATE(TAGDISP+4,AH3,LPUTP) EPTYPE=5; EPDISP=AH3; ! DATA IN GLA SYMBOL TABLES %FINISH %IF TYPE=3 %THEN %START; ! RECORDS EPDISP=(GLACA+15)&(-8) AH3=EPDISP AH2=X'18000000'+STALLOC; ! TOP WORD OF DESRCIPTOR PGLA(8,4,ADDR(AH2)); ! TOP HALF OF DESCR TO GLA RELOCATE(-1,AH3,2); ! PUT BOTTOM HALF INTO GLA TAGDISP=EPDISP; ! AND RELOCATE REL APPROPIATE AREA EPTYPE=2; ! DATA IN GLA TABLES I=0; ICONST=ICONST&255 ICONST=ICONST<<8!ICONST ICONST=ICONST<<16!ICONST %WHILE IBEND NONSCALAR: ! OWN AND OWNRECORD ARRAYS !*********************************************************************** !* OWN ARRAYS CAN BE INITIALISED BUT ONLY ONE ARRAY CAN BE * !* DECLARED IN A STATEMENT.(THANK HEAVENS!) * !* OWN RECORD ARRAYS ARE INITIALISED AS BYTE ARRAYS * !*********************************************************************** P=P+1 FORMAT=2-A(P) PP=P+2; P=P+4; NNAMES=1 K=FROM AR2(PP) NAMTXT=STRING(DICTBASE+WORD(K)) SACC=ACC; TYPEP=PTYPE AH4=12+DOPE VECTOR(TYPE,STALLOC,0,K,QQ,LB) SNDISP=AH4-12; ! DV DISP (+TOP BIT FLAG) %IF SNDISP=-1 %THEN SNDISP=0; ! BUM DOPE VECTOR SNDISP=(SNDISP&X'3FFFF')>>2; ! AS WORD DISPLACEMENT DIMEN=J; ! SAVE NO OF DIMENESIONS ACC=SACC; PTYPE=TYPEP; UNPACK %IF LB=0 %AND J=1 %AND TYPE<=3 %C %THEN ARR=2 %AND PACK(PTYPE) %IF TYPE=3 %THEN LENGTH=QQ %ELSE LENGTH=QQ//STALLOC;! NO OF ELEMENTS SPOINT=STPTR %IF FORMAT=0 %THEN %START %IF A(P)=1 %THEN P=P+1 %AND INIT SPACE(QQ,LENGTH) %FINISH %IF CONSTS FOUND=0 %THEN %START; ! NO CONSTANTS GIVEN ! SO CLEAR AN AREA TO ZERO CONSTS FOUND=LENGTH CLEAR(QQ) %UNLESS LENGTH<1 %OR EXTRN=3 %OR FORMAT#0 %FINISH %ELSE %START FAULT(49,0,K) %IF EXTRN=3 %OR FORMAT#0 %FINISH %IF EXTRN=3 %THEN EPDISP=0 %ELSE EPDISP=SPOINT ! OUTPUT AN ARRAYHEAD INTO THE GLA RELATIVE TO THE START OF THE SYMBOL- ! TABLES IN WHICH THE ARRAY RESIDES. J=DIMEN; ! RESET DIMENSIONS AFTER INITTING %IF TYPE<=2 %THEN AH1=PREC<<27!LENGTH %C %ELSE AH1=3<<27!1<<25!QQ AH1=AH1!(1-PARMARR)<<24; ! SET BCI IF BASE TO BE SHIFTED %IF PREC=4 %THEN AH1=X'58000002' AH2=EPDISP AH3=5<<27!3*J; ! DV DESPTR = WORD CHKD %IF TYPE<=3 %AND PARMARR=0=FORMAT %AND PARMCHK=0 %C %AND J=1 %THEN AH2=AH2-STALLOC*LB PGLA(8,16,ADDR(AH1)) TAGDISP=GLACA-16 %IF EXTRN=3 %THEN %START; ! EXTRINSIC ARRAYS GXREF(NAMTXT,2,2<<24!QQ,TAGDISP+4); ! RELOCATE ADDR(A(FIRST)) %FINISH %ELSE %START RELOCATE(TAGDISP+4,AH2,LPUTP); ! RELOCATE ADDR(A(FIRST)) %FINISH RELOCATE(TAGDISP+12,AH4,1); ! RELOCATE DV POINTER AH4=(AH4<<1>>3)!X'80000000' NOTE CREF(AH4!(TAGDISP+12)>>2<<16) EPTYPE=5; ! DATA IN GLA SYMBOL TABLES STAG(TAGDISP,QQ) ->BEND %ROUTINE INIT SPACE(%INTEGER SIZE, NELS) !*********************************************************************** !* P IS TO FIRST ENTRY FOR CONSTLIST * !* MAP SPACE ONTO WORKFILE END TO GIVE SANE ERROR MESSAGE IF * !* THERE WAS NOT ENOUGH SPACE * !*********************************************************************** %INTEGER RF, I, II, ELSIZE, AD, SPP, LENGTH, SAVER, WRIT %BYTEINTEGERARRAYNAME SP %BYTEINTEGERARRAYFORMAT SPF(0:4096+256) SAVER=R; R=R+(4096+256) %IF R>ARSIZE %THEN FAULT(102, WKFILEK,0) SP==ARRAY(ADDR(A(SAVER)),SPF) %IF TYPE=1 %THEN AD=ADDR(ICONST)+4-ACC %IF TYPE=2 %THEN AD=ADDR(RCONST) %IF TYPE=3 %THEN AD=ADDR(ICONST)+3 %IF TYPE=5 %THEN AD=ADDR(SCONST) SPP=0; WRIT=0 ELSIZE=SIZE//NELS %UNTIL A(P-1)=2 %CYCLE XTRACT CONST(TYPE,PREC) %IF A(P)=1 %START; ! REPITITION FACTOR P=P+2 %IF A(P-1)=2 %THEN RF=NELS-CONSTS FOUND %ELSE %START P=P+2 %IF INTEXP(RF)#0 %THEN FAULT(41,0,0) %AND RF=1 %FINISH P=P+1 %FINISH %ELSE RF=1 %AND P=P+2 FAULT(42,RF,0) %IF RF<=0 %CYCLE I=RF,-1,1 %CYCLE II=0,1,ELSIZE-1 %IF CONSTS FOUND<=NELS %THEN SP(SPP)= %C BYTE INTEGER(AD+II) %AND SPP=SPP+1 %REPEAT CONSTS FOUND=CONSTS FOUND+1 %IF SPP>=4096 %START; ! EMPTY BUFFER LPUT(LPUTP,SPP,STPTR+WRIT,ADDR(SP(0))) %C %IF INHCODE=0 WRIT=WRIT+SPP SPP=0 %FINISH %REPEAT %REPEAT; ! UNTIL P=%NULL %IF CONSTS FOUND#NELS %THEN FAULT(45,CONSTS FOUND,NELS) STPTR=(STPTR+3)&(-4) LENGTH=(SIZE+3)&(-4) LPUT(LPUTP,LENGTH-WRIT,STPTR+WRIT,ADDR(SP(0))) %C %IF INHCODE=0 STPTR=STPTR+LENGTH R=SAVER %END %ROUTINE CLEAR(%INTEGER LENGTH) STPTR=(STPTR+3)&(-4) LENGTH=(LENGTH+3)&(-4) LPUT(LPUTP,LENGTH,STPTR,0) %IF INHCODE=0 STPTR=STPTR+LENGTH %END %ROUTINE STAG(%INTEGER J, DATALEN) %IF EXTRN=2 %THEN LPUT(14,EPTYPE<<24!DATALEN,EPDISP,ADDR( %C NAMTXT)) RBASE=0 STORE TAG(K,J) RBASE=RLEVEL %END %ROUTINE XTRACT CONST(%INTEGER CONTYPE, CONPREC) !*********************************************************************** !* P POINTS TO P<+'> OF <+'> AND IS UPDATED* !* THE CONST IS CONVERTED TO REQUIRED FORM AND IF INTEGER * !* IS LEFT IN ICONST, IF REAL IN RCONST AND IF STRING IN SCONST * !*********************************************************************** %INTEGER LENGTH, STYPE, SACC, CPREC, MODE, I STYPE=PTYPE; SACC=ACC; ! MAY BE CHANGED IF CONST IS EXPR %IF CONTYPE=5 %THEN %START CTYPE=5 %IF A(P)=4 %AND A(P+1)=2 %AND A(P+2)=X'35' %C %AND A(P+A(P+7)+8)=2 %START SCONST=STRING(ADDR(A(P+7))) LENGTH=A(P+7) P=P+A(P+7)+9 %FINISH %ELSE %START FAULT(44,CONSTS FOUND,K); SCONST="" LENGTH=0; P=P-3; SKIP EXP %FINISH %FINISH %ELSE %START MODE=CONPREC<<4!CONTYPE %IF CONPREC<5 %THEN MODE=CONTYPE!X'50' CONSTP=CONSTEXP(MODE) %IF CONSTP=0 %THEN FAULT(41,0,0) %AND CONSTP=ADDR(ZERO) ! CANT EVALUATE EXPT CTYPE=TYPE; CPREC=PREC %IF CTYPE=1 %THEN %START ICONST=INTEGER(CONSTP) %IF CONPREC=6 %THEN UICONST=ICONST %C %AND ICONST=INTEGER(CONSTP+4) %FINISH %ELSE %START RCONST=LONGREAL(CONSTP) %IF CONPREC=7 %THEN %START; ! LONGLONGS UNALIGNED IN AR %CYCLE I=0,1,15 BYTEINTEGER(ADDR(RCONST)+I)=BYTEINTEGER( %C CONSTP+I) %REPEAT %FINISH %FINISH %FINISH PTYPE=STYPE; UNPACK; ACC=SACC ! FAULT ANY OBVIOUS ERRORS IE:- ! CONSTANT FOR EXTRINSIC OR INCOMPATIBLE TYPE OR STRING TOO LONG %IF EXTRN=3 %THEN FAULT(49,0,K) %AND %RETURN %IF (CTYPE=5 %AND LENGTH>=ACC) %C %OR (CONTYPE=1 %AND ((CONPREC=3 %AND ICONST>255) %C %OR (CONPREC=4 %AND ICONST>X'FFFF'))) %C %THEN FAULT(44,CONSTS FOUND,K) %END BEND: %END; ->CSSEXIT SW(18): ABORT SW(10): %BEGIN; ! %RECORDFORMAT (RDECLN) %INTEGER NAME,OPHEAD,OPBOT,NLIST,MRL,CELLREF %RECORD(LISTF)%NAME LCELL,FRCELL SNDISP=0 NAME=FROM AR2(P+1); P=P+3 COPY TAG(NAME) %UNLESS PTYPE=4 %AND J=15 %AND OLDI=LEVEL %START KFORM=0 PUSH(KFORM,0,0,0) ACC=X'7FFF' PTYPE=4; J=0 STORETAG(NAME,KFORM); ! IN CASE OF REFS IN FORMAT %FINISH%ELSE %START LCELL==ASLIST(TAGS(NAME)) LCELL_S1=LCELL_S1&X'FFFFFFF0';! J=15 TO J=0 %FINISH LCELL==ASLIST(KFORM) OPHEAD=0; OPBOT=0 NLIST=0; MRL=0 INAFORMAT=1 CRFORMAT(OPHEAD,OPBOT,NLIST,MRL,X'80000000') INAFORMAT=0 CLEAR LIST(NLIST) ! ! IN CASE OF FORWARD REFS COPY TOP CELL OF FORMAT CHAIN INTO DUMMY ! SET UP BEFORE CALL OF CRFORMAT. ALSO RESET J&ACC TO CORRECT VALUE ! %WHILE LCELL_S3#0 %CYCLE; ! THROUGH FORWARD REFS POP(LCELL_S3,CELLREF,I,I) FRCELL==ASLIST(CELLREF) FRCELL_S1=FRCELL_S1&X'FFFFFFF0';! SET J BACK TO 0 FRCELL_S2=FRCELL_S2&X'FFFF0000'!ACC;! ACC TO CORRECT VALUE %REPEAT POP(OPHEAD,LCELL_S1,LCELL_S2,LCELL_S3) LCELL_LINK=OPHEAD LCELL==ASLIST(TAGS(NAME)) LCELL_S2=LCELL_S2&X'FFFF0000'!ACC %END;->CSSEXIT ! SW(19): ! '*' (UCI) (S) FAULT(57,0,0) %UNLESS LEVEL>=2 %BEGIN %ROUTINESPEC CIND %INTEGER FNAME,ALT,OPCODE,FORM,H,Q,MASK,FILLER %SWITCH SW,F(1:3),POP(1:6),TOP(1:4) ALT=A(P+1); P=P+2 OPCODE=CALL ->SW(ALT) SW(1): ! PUT (HEX HALFWORD) TYPE=A(P) PREC=TYPE>>4; TYPE=TYPE&7 FAULT(97,0,0) %UNLESS TYPE=1 %AND PREC<6 %IF PREC=5 %THEN P=P+2 PLANT(FROM AR2(P+1)) ->EXIT SW(3): ! CNOP CNOP(A(P),A(P+1)) ->EXIT SW(2): ! ASSEMBLER FORM=A(P); ! FORM=PRIMARY,SECONDARY OR 3RY OPCODE=A(P+1) P=P+2; ->F(FORM) F(1): ! ALL PRIMARY FORMAT INSTRUCTIONS ALT=A(P); P=P+1 ->POP(ALT) POP(1): ! LABELNAME FNAME=FROM AR2(P); P=P+2 ENTER JUMP(OPCODE<<24!3<<23,FNAME,0) ->EXIT POP(2): ! DIRECT SYMBOLIC CIND POPI: PSORLF1(OPCODE,ACCESS,AREA,DISP) ->EXIT POP(3): ! INDIRECT SYMBOLIC CIND ACCESS=4-A(P); P=P+1 ->POPI POP(4): ! DR SYMBOLICALLY MODIFIED CIND; ACCESS=1; ->POPI POP(5): ! (DR) & (DR+B) ACCESS=4-A(P); AREA=7 DISP=0; P=P+1 ->POPI POP(6): ! B ACCESS=0 AREA=7; DISP=0; ->POPI F(2): ! SECONDARY (STORE-TO STORE)FORMAT MASK=0; FILLER=0; Q=0; FNAME=0 H=2-A(P) %IF H=0 %THEN FNAME=FROM AR2(P+1)-1 %AND P=P+2 FAULT(96,FNAME+1,0) %UNLESS 0<=FNAME<=127 ALT=A(P+1); P=P+2 %IF ALT=1 %THEN %START Q=1 MASK=FROM AR2(P) FILLER=FROM AR2(P+2) P=P+4 %IF MASK>255 %THEN FAULT(96,MASK,0) %IF FILLER>255 %THEN FAULT(96,FILLER,0) %FINISH PF2(OPCODE,H,Q,FNAME,MASK,FILLER) ->EXIT F(3): ! TERTIARY FORMAT MASK=FROM AR2(P) ALT=A(P+2) FAULT(96,MASK,0) %UNLESS 0<=MASK<=15 P=P+3; ->TOP(ALT) TOP(1): ! LABEL FNAME=FROM AR2(P); P=P+2 ENTER JUMP(OPCODE<<24!MASK<<21,FNAME,0) ->EXIT TOP(2): ! SYMBOLIC OPERAND CIND FAULT(97,0,0) %IF AREA>=6 %IF AREA=LNB %OR AREA=XNB %OR AREA=CTB %THEN DISP=DISP//4 TOPI: PF3(OPCODE,MASK,AREA,DISP) ->EXIT TOP(3): ! (DR) & (DR+B) DISP=0; AREA=8-A(P) P=P+1; ->TOPI TOP(4): ! (DR+N) DISP=FROM AR2(P); P=P+2 AREA=1; ->TOPI %ROUTINE CIND !*********************************************************************** !* COMPILE A SYMBOLIC OPERAND BY SETTING ACCESS,AREA &DISP * !*********************************************************************** %INTEGER ALT,AFN,FN0,FN1,FN2,FN3,JJ,D,CTYPE,CPREC %SWITCH SW(1:4) AFN=ADDR(FN0) FN0=0; FN1=0; FN2=0; FN3=0 ALT=A(P); ACCESS=0 P=P+1; ->SW(ALT) SW(1): ! (=')(PLUS')(ICONST) P=P+1; ! PAST (=') D=A(P); CTYPE=A(P+1) CPREC=CTYPE>>4; CTYPE=CTYPE&7 %IF CPREC=4 %THEN FN0=FROM AR2(P+2) %ELSE %START %CYCLE JJ=0,1,BYTES(CPREC)-1 BYTEINTEGER(AFN+JJ)=A(P+JJ+2) %REPEAT %FINISH P=P+2+BYTES(CPREC) %IF D=2 %THEN %START %IF CTYPE=2 %THEN FN0=FN0!!X'80000000' %ELSE %START %IF CPREC=6 %THEN LONGINTEGER(AFN)=-LONGINTEGER(AFN) %C %ELSE FN0=-FN0 %FINISH %FINISH CNST: ->LIT %UNLESS CTYPE=1 %AND CPREC<=5 %AND %C X'FFFE0000'<=FN0<=X'1FFFF' AREA=0; DISP=FN0 %RETURN LIT: FAULT(96,FN0,0) %UNLESS 1<=CTYPE<=2 %AND 5<=CPREC<=7 STORE CONST(DISP,BYTES(CPREC),AFN) AREA=PC; ACCESS=0 %RETURN SW(2): ! (NAME)(OPTINC) FN0=FROM AR2(P); P=P+2 COPY TAG(FN0) %IF (LITL=1 %AND NAM=ARR=0) %START CTYPE=TYPE; CPREC=PREC ALT=TAGS(FN0) FROM123(ALT,D,FN0,FN1) %IF CPREC=7 %THEN AFN=FN1 ->CNST %FINISH %IF TYPE>=6 %OR TYPE=4 %OR %C (ROUT=1 %AND NAM=0) %THEN FAULT(95,0,FN0) %AND %RETURN %IF ROUT=1 %THEN K=FROM1(K) AREA=LNB %IF I#RBASE %THEN AREA=SET XORYNB(XNB,I) ALT=A(P); D=FROM AR2(P+1) %IF ALT=1 %THEN K=K+D %IF ALT=2 %THEN K=K-D P=P+1; P=P+2 %IF ALT<=2 DISP=K; %RETURN SW(3): ! '('(REG)(OPTINC)')' AREA=A(P)+1; ALT=A(P+1); P=P+2 DISP=0 D=FROM AR2(P) %IF ALT=1 %THEN DISP=D %IF ALT=2 %THEN FAULT(96,-D,0) %IF AREA=PC %THEN DISP=CA+2*DISP %ELSE DISP=4*DISP P=P+2 %UNLESS ALT=3 %RETURN SW(4): ! '%TOS' AREA=6; DISP=0 %END EXIT: GRUSE(ACCR)=0 GRUSE(DR)=0 GRUSE(BREG)=0 GRUSE(XNB)=0 %IF OPCODE=CALL %OR OPCODE=LXN %OR OPCODE=JLK %C %OR OPCODE=OUT GRUSE(CTB)=0 %IF OPCODE=CALL %OR OPCODE=LCT %OR OPCODE=JLK %C %OR OPCODE=OUT %END ->CSSEXIT SW(20): ! '%TRUSTEDPROGRAM' COMPILER=1 %IF PARMARR=0 %AND PARMCHK=0; ->CSSEXIT SW(21): ! '%MAINEP'(NAME) KK=FROM AR2(P+1) FAULT(97,0,0) %UNLESS CPRMODE=0 MAINEP<-STRING(DICTBASE+WORD(KK)) ->CSSEXIT %INTEGERFN CFORMATREF !*********************************************************************** !* P IS TO ALT OF FORMAT REF * !* P::=(NAME),(RFDEC)(RESTOFRFDEC)(ALTRFDEC) * !* RETURNS CELL NO OF TOP CELL OF THE FORMATLIST * !*********************************************************************** %INTEGER FNAM,OPHEAD,OPBOT,NHEAD,MRL %RECORD(LISTF)%NAME LCELL %IF A(P)=1 %START; ! A RECORD OF RECORDFORMAT NAME FNAM=FROM AR2(P+1) P=P+3 COPY TAG(FNAM) %IF 3<=TYPE<=4 %THEN %RESULT=KFORM %IF INAFORMAT#0 %AND OLDI#LEVEL %START KFORM=0; SNDISP=0;ACC=X'7FFF' PTYPE=4; J=15 PUSH(KFORM,0,0,0) STORE TAG(FNAM,KFORM) %RESULT=KFORM %FINISH FAULT(62,0,FNAM); ! NOT A RECORD OF FORMAT NAME ACC=8; ! GUESS A RECORD SIZE %RESULT=DUMMY FORMAT %FINISH ! FORMAT ACTUALLY SPECIFIED P=P+1 OPHEAD=0; OPBOT=0 NHEAD=0; MRL=0 CRFORMAT(OPHEAD,OPBOT,NHEAD,MRL,X'80000000') CLEAR LIST(NHEAD) %IF UNATT FORMATS(LEVEL)#0 %START LCELL==ASLIST(UNATT FORMATS(LEVEL)) %IF LCELL_S2=0 %THEN LCELL_S2=OPHEAD %AND %RESULT=OPHEAD %IF LCELL_S3=0 %THEN LCELL_S3=OPHEAD %AND %RESULT=OPHEAD %FINISH PUSH(UNATT FORMATS(LEVEL),OPHEAD,0,0) %RESULT=OPHEAD %END %ROUTINE CRFORMAT(%INTEGERNAME OPHEAD, OPBOT, NLIST, MRL, %INTEGER INIT) !*********************************************************************** !* CONVERTS A RECORDFORMAT STATEMENT TO A LIST HEADED BY OPHEAD * !* FORMAT OF AN ENTRY. * !* S1=SUBNAME<<20!PTYPE<<4!J * !* S2,S3=4 16 BIT DISPLACEMENTS D2,ACC,D1,KFORM * !* NORMALLY D1=RECORD RELATIVE DISPLACEMENT AND ACC=LMAX(STRINGS)* !* FOR ARRAYS D2=FIRST ELEMENT DISPLACEMENT AND D1=DISPLACEMENT * !* OF RECORD RELATIVE ARRAYHEAD IN THE GLA * !* KFORM IS ONLY USED FOR RECORDS AND POINTS TO THE FORMAT * !* ON EXIT ACC HAS THE RECORD SIZE ROUNDED UP TO THE BOUNDARY * !* REQUIRED BY ITS LARGEST COMPONENT * !*********************************************************************** %INTEGER D1, D2, FORM, RL, UNSCAL, SC, DESC, STALLOC, INC, Q, %C R, A0, A1, A2, DV, RFD, LB, TYPEP, SACC %ROUTINESPEC SN(%INTEGER Q) %ROUTINESPEC ROUND FORM=0; ACC=0 INC=INIT&X'FFFF'; ! INC COUNTS DOWN RECORD %CYCLE ROUT=0; LITL=0; NAM=0; RFD=A(P) P=P+1 %IF RFD=1 %THEN %START CLT FORM=KFORM STALLOC=ACC P=P+1 %IF A(P-1)=1 %START ! (TYPE) (QNAME')(NAMELIST) FORM=KFORM CQN(P); P=P+1 %IF NAM=1 %THEN %START STALLOC=8 %IF ARR#0 %THEN STALLOC=16 %FINISH PACK(PTYPE); D2=0 RL=3 %IF NAM=0 %AND TYPE#3 %AND 3<=PREC<=4 %C %THEN RL=PREC-3 ROUND; J=0 %UNTIL A(P-1)=2 %CYCLE D1=INC; SN(P) P=P+3; INC=INC+STALLOC %REPEAT %FINISH %ELSE %START ! (TYPE)%ARRAY(NAMELIST)(BPAIR) Q=P+1; ARR=1; PACK(PTYPE) %IF TYPE<=2 %THEN UNSCAL=0 %AND SC=PREC %C %ELSE UNSCAL=1 %AND SC=3 %IF PREC=4 %THEN DESC=X'58000002' %C %ELSE DESC=SC<<27!UNSCAL<<25!(1-PARMARR)<<24 %CYCLE P=Q P=P+3 %UNTIL A(P-1)=2 TYPEP=PTYPE; SACC=ACC DV=DOPE VECTOR(TYPE,ACC,0,FROMAR2(Q),R,LB)+12 ! DOPE VECTOR INTO SHAREABLE S.T. ACC=SACC; PTYPE=TYPEP; UNPACK %IF TYPE=5 %OR (TYPE=1 %AND PREC=3) %C %THEN RL=0 %ELSE RL=3 ROUND %CYCLE A0=R; %IF UNSCAL=0 %THEN A0=A0//ACC %IF PREC=4 %THEN A0=0; ! STRING DESCRIPTORS ! A0=A0!DESC; A1=INC %IF TYPE<=3 %AND PARMARR=0=PARMCHK %C %AND J=1 %THEN A1=A1-LB*ACC A2=5<<27!3*J PGLA(4,16,ADDR(A0)) D1=GLACA-16 RELOCATE(D1+12,DV,1); ! RELOCATE DV POINTER NOTE CREF(X'80000000'!(DV<<1>>3)!(D1+12)>>2<<16) D2=INC SN(Q); INC=INC+R Q=Q+3 %REPEAT %UNTIL A(Q-1)=2;! TILL NAMELIST NULL P=P+1; Q=P+1 %REPEAT %UNTIL A(P-1)=2; ! UNTIL NULL %FINISH %FINISH %ELSE %START ! (FORMAT) CRFORMAT(OPHEAD,OPBOT,NLIST,MRL,INC) INC=ACC %FINISH P=P+1 %REPEAT %UNTIL A(P-1)=2; ! UNTIL NULL ! FINISH OFF %IF A(P)=1 %START; ! WHILE %OR CLAUSES P=P+1 CRFORMAT(OPHEAD,OPBOT,NLIST,MRL,INIT&X'FFFF') %IF ACC>INC %THEN INC=ACC %FINISH %ELSE P=P+1 %IF INIT<0 %THEN RL=MRL %AND ROUND ACC=INC; ! SIZE ROUNDED APPROPRIATELY FAULT(63,X'7FFF',0) %UNLESS INC<=X'7FFF' %RETURN %ROUTINE SN(%INTEGER Q) !*********************************************************************** !* CHECK THE SUBNAME HAS NOT BEEN USED BEFORE IN THIS FORMAT * !* AND ENTER IT WITH ITS DESCRIPTORS INTO THE LIST. * !*********************************************************************** FNAME=FROM AR2(Q) FAULT(61,0,FNAME) %UNLESS FIND(FNAME,NLIST)=-1 BINSERT(OPHEAD,OPBOT,FNAME<<20!PTYPE<<4!J,D2<<16!ACC,D1<< %C 16!FORM) PUSH(NLIST,0,FNAME,0) %IF PTYPE=X'433' %AND ACC=X'7FFF' %THEN %C PUSH(ASLIST(FORM)_S3,OPBOT,0,0);! NOTE FORWARD REFERENCE %END %ROUTINE ROUND MRL=RL %IF RL>MRL INC=INC+1 %WHILE INC&RL#0 %END %END; ! OF ROUTINE CRFORMAT %INTEGERFN DISPLACEMENT(%INTEGER LINK) !*********************************************************************** !* SEARCH A FORMAT LIST FOR A SUBNAME * !* A(P) HAS ENAME--LINK IS HEAD OF RFORMAT LIST. RESULT IS DISP * !* FROM START OF RECORD * !*********************************************************************** %RECORD(LISTF)%NAME FCELL,PCELL,LCELL %INTEGER RR,II,ENAME,CELL ENAME=A(P)<<8+A(P+1); CELL=0 %IF LINK#0 %THEN %START; ! CHK RECORDSPEC NOT OMITTED FCELL==ASLIST(LINK); ! ONTO FIRST CELL CELL=LINK; II=-1; ACC=-1 %WHILE LINK>0 %CYCLE LCELL==ASLIST(LINK) %IF LCELL_S1>>20=ENAME %START;! RIGHT SUBNAME LOCATED TCELL=LINK RR=LCELL_S1 SNDISP=LCELL_S2 K=LCELL_S3 J=RR&15; PTYPE=RR>>4&X'FFFF' ACC=SNDISP&X'FFFF'; SNDISP=SNDISP&X'FFFF0000'//X'10000' KFORM=K&X'FFFF'; K=K>>16 %IF LINK#CELL %START; ! NOT TOP CELL OF FORMAT PCELL_LINK=LCELL_LINK LCELL_LINK=FCELL_LINK FCELL_LINK=LINK %FINISH; ! ARRANGING LIST WITH THIS SUBNAME ! NEXT TO THE TOP %RESULT=K %FINISH PCELL==LCELL LINK=LCELL_LINK %REPEAT %FINISH FAULT(65,0,ENAME) %IF CELL>0 %THEN %C PUSH(ASLIST(CELL)_LINK,ENAME<<20!7<<4,0,0) PTYPE=7; TCELL=0 %RESULT=-1 %END %INTEGERFN COPY RECORD TAG(%INTEGERNAME SUBS) !*********************************************************************** !* PRODUCE PTYPE ETC FOR A COMPOUND NAME BY CHAINING DOWN ONE * !* ONE OR MORE RECORD FORMAT LISTS. ON EXIT RESULT =0 IF NO * !* SUBNAME FOUND OR SUBNAME IS OF TYPE RECORD WITH NO FURTHER * !* SUBNAME ATTACHED. RESULT#0 IF BONE-FIDE SUBNAME LOCATED * !* ON ENTRY KFORM HAS POINTER TO THE (FIRST ) FORMAT LIST AND * !* P POINTS TO THE A.R. ENTRY FOR (FIRST) ENAME * !*********************************************************************** %INTEGER Q,FNAME SUBS=0 %UNTIL TYPE#3 %CYCLE FNAME=KFORM P=P+2; SKIP APP %RESULT=0 %IF A(P)=2 %OR FNAME<=0;! NO (FURTHER) ENAME SUBS=SUBS+1 P=P+1; Q=DISPLACEMENT (FNAME) UNPACK %REPEAT %RESULT=Q+1; ! GIVES 0 IF SUBNAME NOT KNOWN %END %ROUTINE CRNAME(%INTEGER Z,REG,MODE,BS,AR,DP,%INTEGERNAME NAMEP) !*********************************************************************** !* DEAL WITH RECORD ELEMENT NAMES.Z AS FOR CNAME.CLINK=TAGS(RN) * !* MODE=ACCESS FOR RECORD(NOT THE ELEMENT!) * !* ON EXIT BASE,AREA & DISP POINT TO REQUIRED ELEMENT * !* RECURSIVE CALL IS NEEDED TO DEAL WITH RECORDS IN RECORDS * !* DEPTH SHEWS RECURSIVE LEVELS- NEEDED TO AVOID MIS SETTING * !* REGISTER IN USE IF RECORDNAME IN RECORD HAS THE SAME NAME AS * !* A GENUINE RECORD NAME. * !*********************************************************************** %INTEGER DEPTH,FNAME %ROUTINESPEC CENAME(%INTEGER MODE,FNAME,BS,AR,DP,XD) DEPTH=0 FNAME=KFORM; ! POINTER TO FORMAT %IF ARR=0 %OR (Z=6 %AND A(P+2)=2) %START;! SIMPLE RECORD %IF A(P+2)=2 %THEN P=P+3 %ELSE NO APP CENAME(MODE,FNAME,BS,AR,DP,0) %FINISH %ELSE %START CANAME(ARR,BS,DP) CENAME(ACCESS,FNAME,BASE,AREA,DISP,0) %FINISH; %RETURN ! %ROUTINE CENAME(%INTEGER MODE,FNAME,BS,AR,DP,XD) !*********************************************************************** !* FINDS OUT ABOUT SUBNAME AND ACTS ACCORDINGLY.MOSTLY ACTION * !* CONSISTS OF UPPING XD BY OFFSET OF THE SUBNAME BUT IS VERY * !* HAIRY FOR RECORDS IN RECORDS ETC * !* MODE IS ACCESS FOR THE RECORD * !*********************************************************************** %ROUTINESPEC FETCH RAD %ROUTINESPEC LOCALISE(%INTEGER SIZE) %INTEGER Q,QQ,D,C,W DEPTH=DEPTH+1 %IF A(P)=2 %THEN %START; ! ENAME MISSING ACCESS=MODE; AREA=AR; XDISP=XD BASE=BS; DISP=DP; ! FOR POINTER %IF Z<14 %THEN %START; ! NOT A RECORD OPERATION %UNLESS 3<=Z<=4 %OR Z=6 %START; ! ADDR(RECORD) FAULT(64,0,NAMEP&X'FFFF'); BASE=RBASE; AREA=-1 DISP=0; ACCESS=0; PTYPE=1; UNPACK %FINISH %FINISH %RETURN %FINISH P=P+1; ! FIND OUT ABOUT SUBNAME Q=DISPLACEMENT(FNAME); ! TCELL POINTS TO CELL HOLDING UNPACK; ! INFO ABOUT THE SUBNAME %IF Q=-1=ACC %OR PTYPE=7 %START; ! WRONG SUBNAME(HAS BEEN FAULTED) P=P+2; SKIP APP; P=P-3 ACCESS=0; BASE=RBASE; DISP=0; AREA=-1 %RETURN %FINISH NAMEP=(A(P)<<8!A(P+1))<<16!NAMEP; ! NAMEP=-1 UNALTERED ! ->AE %IF ARR=1; ! ARRAYS INCLUDING RECORDARRAYS %IF A(P+2)=2 %THEN P=P+3 %ELSE NO APP %IF TYPE<=2 %OR TYPE=5 %OR %C (TYPE=3 %AND A(P)=2 %AND (3<=Z<=4 %OR Z=6)) %START ACCESS=MODE+4+4*NAM; BASE=BS; AREA=AR; DISP=DP; XDISP=XD+Q %RETURN %FINISH ! ! NOW CODING BECOMES HAIRY:- STILL LEFT ARE ! A) RECORDS IN RECORDS Q POINTS TO SECONDARY RECORD ! B) RECORDNAMES IN RECORDS Q HAS OFF-SET OF A POINTER ! C) RECORDARRAYNAMES IN RECORDS Q HAS OFF-SET A HEADER IN RECORD ! D) RECORDARRAYS IN RECORDS NOT YET ALLOWED ! Q WOULD HAVE OFF-SET OF A RECORD RELATIVE HEADER IN THE GLA ! XD=XD+Q NAMEP=-1 %IF NAM=1 %THEN %START %IF MODE=0 %START DP=DP+XD; XD=0; MODE=2 %FINISH %ELSE %START LOCALISE(8); ! PICK UP RECNAME DESCR &STCK AR=AREA; DP=DISP; BS=BASE %FINISH %FINISH CENAME(MODE,KFORM,BS,AR,DP,XD) %RETURN AE: ! ARRAYS AND ARRAYNAMES AS ELEMEN FROM123(TCELL,Q,SNDISP,K) ACC=SNDISP&X'FFFF'; SNDISP=SNDISP&X'FFFF0000'//X'10000' KFORM=K&X'FFFF'; K=K>>16 C=ACC; D=SNDISP; Q=K; QQ=KFORM %IF (Z=6 %OR Z=12) %AND A(P+2)=2 %START;! 'GET ARRAYHEAD' CALL P=P+3 %IF NAM=1 %THEN %START ACCESS=MODE+8; BASE=BS AREA=AR; DISP=DP; XDISP=XD+Q %RETURN %FINISH ! ! PASSING AN ARRAY IN A RECORD BY NAME MUST CONSTRUCT PROPER ARRAYHEAD ! FROM THE RECORD RELATIVE ONE AT Q(GLA) ! NAMEP=-1 FETCH RAD AREA=-1; DISP=Q BASE=0; ACCESS=0; CREATE AH(1) %FINISH %ELSE %START; ! ARRAY ELEMENTS IN RECORDS NAMEP=-1 %IF NAM=1 %THEN %START; ! ARRAYNAMES-FULLHEAD IN RECORD XD=XD+Q LOCALISE(16); ! MOVE HEAD UNDER LNB CANAME(3,BASE,DISP); ! ARRAY MODE SETS DISP,AREA&BASE %FINISH %ELSE %START; ! ARRAY RELATIVE HEAD IN GLA %IF MODE=0 %OR MODE=2 %%START %IF MODE=0 %THEN W=DP-4 %ELSE W=DP+4 %FINISH %ELSE %START FETCH RAD; ! RECORD ADDR TO ACC GET WSP(W,1) PSF1(ST,1,W); XD=0 BS=RBASE %FINISH CANAME(3,0,Q); ! RECORD REL ARRAY ACCESS ! CAN RETURN ACCESS=1 OR 3 ONLY %IF PARMARR=0=PARMCHK %AND ACCESS=3 %AND %C (PREC=3 %OR TYPE>=3) %START PSORLF1(ADB,0,AREA CODE2(BS),W) PSF1(ADB,0,XD) %UNLESS XD=0 GRUSE(BREG)=0 %FINISH %ELSE %START GET IN ACC(DR,2,0,AREA CODE,Q) PSORLF1(INCA,0,AREA CODE2(BS),W) %IF ACCESS=1 %THEN ACCESS=2 %AND AREA=7 %C %AND XD=XD+NUMMOD*BYTES(PREC) PSF1(INCA,0,XD) %UNLESS XD=0 FORGET (DR) AREA=7; DISP=0; ! AND ACCESS = 2 OR 3 ONLY %IF TYPE=3 %AND A(P)=1 %START; ! WILL BE A FURTHER CALL ! ON ROUTINE CENAME GET WSP(DISP,2) PSF1(STD,1,DISP) AREA=LNB; BASE=RBASE %FINISH %FINISH %FINISH %IF TYPE=3 %THEN CENAME(ACCESS,QQ,BASE,AREA,DISP,0) %FINISH %RETURN %ROUTINE FETCH RAD !*********************************************************************** !* SET ACC TO 32 BIT ADDRESS OF RECORD. * !*********************************************************************** ACCESS=MODE+4 AREA=AR; BASE=BS DISP=DP; XDISP=XD NAMEOP(4,ACCR,4,-1) %END %ROUTINE LOCALISE(%INTEGER SIZE) !*********************************************************************** !* REMOVES A DESCRIPTOR OR ARRAYHEAD FROM A RECORD AND STORES * !* IT IN A TEMPORARY UNDER LNB. * !*********************************************************************** %INTEGER HOLE ACCESS=MODE+4 AREA=AR; BASE=BS; DISP=DP XDISP=XD NAMEOP(2,ACCR,SIZE,-1) GET WSP(HOLE,SIZE>>2) PSF1(ST,1,HOLE) MODE=2; AREA=LNB BASE=RBASE; DISP=HOLE; XD=0 %END; ! OF ROUTINE LOCALISE %END; ! OF ROUTINE CENAME %END; ! OF ROUTINE CRNAME %ROUTINE CSTREXP(%INTEGER MODE,REG) !*********************************************************************** !* PLANT IN-LINE CODE FOR CONCATENATION. A WORK AREA UNDER * !* BASE REGISTER COVER IS USUALLY REQUIRED. THE CURRENT LENGTH * !* OF STRING IN THE WORK AREA IS KEPT IN A REGISTER (BREG) * !* WHICH IS PROTECTED THROUGH THE NORMAL INTERMEDIATE-RESULT * !* MECHANISMS. * !* ON ENTRY:- * !* MODE=0 NORMAL. WK AREA NOT USED FOR ONE OPERAND EXPSSNS * !* MODE=1 STRING MUST GO TO WORK AREA * !* (AND TO COME) * !* MODE=3 CONCATENATE INTO LHS OF =ASSNMNT (E.G. A=B.C) * !* MODE=4 OPTIMISE S=S.T BY NOT COPYING S * !* 2**4 BIT OF MODE IS SET IF WK-AREA NOT TO BE FREED ON EXIT * !* ON EXIT:- * !* BASE,DISP & INDEX DEFINE RESULT * !* VALUE#0 %IF RESULT IN A WORK AREA(CCOND MUST KNOW) * !* STRINGL SET IF STRING LENGTH KNOWN. STRFNRES DEFINES LENREG * !*********************************************************************** %INTEGER PP,WKAREA,DOTS,REXP,ERR,CLEN,KEEPWA,FNAM %INTEGERFNSPEC STROP(%INTEGER REG) KEEPWA=MODE&16; MODE=MODE&15 PP=P; STRINGL=0; FNAM=0; WKAREA=0 REXP=2-A(P+1+FROM AR2(P+1)); ! =0 %IF ONE OPERAND EXP -> NORMAL %UNLESS A(P+3)=4 %AND REXP=0 %AND MODE=0 -> SIMPLE %IF A(P+4)=2 -> NORMAL %UNLESS A(P+4)=1 ! COPY TAG(FROM AR2(P+5)) ! %IF PTYPE=SNPT %THEN PTYPE=TSNAME(K) ! -> NORMAL %UNLESS ROUT=0 ; ! BEWARE OF MAP=FN ! -> NORMAL %IF PARMARR=1 %AND(ARR#0 %OR A(P+7)=1) SIMPLE: P=P+4 ERR=STROP(REG) -> ERROR %UNLESS ERR=0 VALUE=WKAREA P=P+1; STRFNRES=0 %RETURN ERROR: FAULT(ERR,0,FNAM) BASE=RBASE; DISP=0 VALUE=0; ACCESS=0 P=PP; SKIP EXP %RETURN NORMAL: CLEN=0; P=P+3; ! LENGTH OF CONSTANT PART ERR=72; ->ERROR %UNLESS A(P)=4 P=P+1 GET WSP(WKAREA,268); ! GET NEXT OPERAND DOTS=0; ! NO OPERATORS YET NEXT: STRINGL=0 ERR=STROP(DR); ! GET NEXT OPERAND -> ERROR %UNLESS ERR=0 %IF REGISTER(ACCR)#0 %THEN BOOT OUT(ACCR) PSF1(LB,0,WKAREA); ! BYTE DISP FROM LNB PPJ(0,19+DOTS); ! TO SUBROUTINE 19 OR 20 %IF A(P)=2 %THEN -> TIDY; ! NO MORE OPERATIONS ERR=72; -> ERROR %UNLESS A(P+1)=CONCOP; ! CONCATENATE DOTS=DOTS!1 P=P+2; -> NEXT TIDY: ! FINISH OFF VALUE=WKAREA P=P+1; ! PAST REST OF EXPRN RETURN WSP(WKAREA,268) %IF KEEPWA=0 STRINGL=0 %RETURN %INTEGERFN STROP(%INTEGER REG) !*********************************************************************** !* DEALS WITH OPERAND FOR CONCATENATION. RETURN RESULT=0 FOR * !* VALID OPERAND OTHERWISE AN ERROR NUMBER. * !*********************************************************************** %INTEGER CTYPE,MODE MODE=A(P); ! ALTERNATIVE OF OPERAND %RESULT=75 %IF MODE>2 %IF MODE#1 %THEN %START CTYPE=A(P+1); ! GET CONST TYPE & LOSE AMCK FLAGS %IF CTYPE=X'35' %THEN %START STRINGL=A(P+6) DISP=FROM AR4(P+2) P=P+STRINGL+7 %FINISH %ELSE %RESULT=73 PF1(LDRL,0,PC,STRLINK) PSF1(INCA,0,DISP) %IF DISP#0 %IF STRINGL#1 %THEN %START %IF STRINGL<=63 %THEN PSF1(LDB,0,STRINGL) %C %ELSE PF1(LDB,2,7,0);! ((DR)) %FINISH GRUSE(DR)=0 %IF REG=ACCR %THEN COPY DR %FINISH %ELSE %START P=P+1; ! MUST CHECK FIRST REDUCE TAG; ! SINCE CNAME ONLY LOADS STRINGS ! AND LONGINTS TO DR! %IF 5#TYPE#7 %THEN FNAM=FROMAR2(P) %AND %RESULT=71 CNAME(2,REG) STRINGL=0 %IF ROUT#0 %AND NAM<=1%AND STRFNRES#0 %START;! WAS FUNCTION NOT MAP %IF WKAREA=0 %AND KEEPWA#0 %THEN %C WKAREA=STRFNRES %ELSE RETURN WSP(STRFNRES,268) %FINISH %FINISH %RESULT=0 %END; ! OF INTEGERFN STROP %END; ! OF ROUTINE CSTREXP %ROUTINE CRES (%INTEGER LAB) !********************************************************************** !* COMPILES A RESOLUTION E.G A->B.(C).D.(E).F AND JUMPS TO LAB * !* ON FAILURE. (LAB=0 FOR UNCONDITIONAL RESOLUTION TO PERM ON * !* FAILURE ). * !* THE METHOD IS TO CALL A SUBROUTINE PASSING 3 PARAMS:- * !* P1 POINTS TO LHS(A) * !* P2 STRING TO CONTAIN FRAGMENT (PASSED BY NAME) * !* P3 THE EXPRESSION PASSED AS DESCRIPTOR * !* SUBROUTINE TRIES TO PERFORM THE RESOLUTION AND SETS THE * !* CONDITION CODE =8 IF IT SUCCEEDS. * !* * !* ON ENTRY LHS IS DEFINED BY DESCRIPTOR REG. * !* P POINTS TO P(+') OF RHS DEFINED AS (+')(OPERAND)(RESTOFEXP) * !* * !$ THE ROUTINE IS COMPACT BUT DIFFICULT TO FOLLOW (OR ALTER) * !* THE TIME IN PERM IS LARGE SO IT IS NOT WORTHWHILE TO PERSUE * !* CODE EFFICIENCY TOO INDUSTRIOUSLY . * !********************************************************************** %INTEGER P1,P2,SEXPRN,W,LAST,ERR,FNAM %RECORD(RD) R LAST=0; FNAM=0; ! =1 WHEN END OF EXPRNSN FOUND SEXPRN=0; ! RESOLUTION(BRKTD) EXPRESSNS ERR=74; ! NORMAL CRES FAULT PSF1(INCA,0,1); ! TO FIRST CHAR P1=P; P=P+3 ->RES %IF A(P)=4; ! LHS MUST BE A STRING ! BUT THIS CHECKED BEFORE CALL ERR=72 ERROR: FAULT(ERR,0,FNAM) P=P1; SKIP EXP; %RETURN RES: P=P+1; ! TO P(OPERAND) PSF1(PRCL,0,4) %IF SEXPRN=0 %THEN W=STD %ELSE W=ST PF1(W,0,TOS,0) %IF A(P)=3 %THEN PSF1(LSD,0,0) %AND GRUSE(ACCR)=0 %ELSE %START;! B OMITTED ->ERROR %UNLESS A(P)=1; ! P(OPERAND)=NAME P=P+1; P2=P CNAME(3,ACCR) %IF TYPE#5 %THEN ERR=71 %AND FNAM=FROMAR2(P2) %AND ->ERROR %IF A(P+1)#CONCOP %THEN ERR=72 %AND ->ERROR P=P+2 %FINISH PF1(ST,0,TOS,0); ! B (OR DUMMY) TO P2 ->ERROR %UNLESS A(P)=3; ! P(OPERAND)='('(EXPR)')' SEXPRN=SEXPRN+1; P=P+1 CSTREXP(0,DR); ! TO REGISTER DR ! PF1(STD,0,TOS,0) PSF1(RALN,0,11) PPJ(-1,16) ! DEAL WITH CC#8 IE RESLN FAILED %IF LAB#0 %THEN ENTER JUMP(7,LAB,B'11') %ELSE PPJ(7,12) ! -> END %IF A(P)=2 %IF A(P+1)#CONCOP %THEN ERR=72 %AND ->ERROR P2=P+1; P=P2+1 %IF A(P)=3 %THEN P=P2 %AND ->RES ->ERROR %UNLESS A(P)=1 P=P+3 %AND SKIP APP %UNTIL A(P)=2 %IF A(P+1)=1 %THEN P=P2 %AND ->RES P1=P+1 REGISTER(ACCR)=1 OLINK(ACCR)=ADDR(R) R_PTYPE=1; R_XB=ACCR R_FLAG=9 P=P2+2; CNAME(1,DR) %IF R_FLAG#9 %THEN PF1(LSD,0,TOS,0) REGISTER(ACCR)=0 PF1(STUH,0,BREG,0) PF1(LUH,0,BREG,0) PF2(MVL,0,0,0,0,0) %IF ROUT#0 %OR NAM#0 %THEN PPJ(0,18);! ASSNMNT CHECK (Q.V) PF2(MV,1,1,0,0,UNASSPAT&255) GRUSE(ACCR)=0 %IF PARMARR=1 %START PSF1(USH,0,8) PSF1(USH,0,-40) PPJ(36,9) %FINISH P=P1 END: P=P+1 %END %ROUTINE SAVE AUX STACK !*********************************************************************** !* COPY AUX STACK DESCRPTR & POINTER INTO CURRENT STACK FRAME * !* FIVE WORDS ARE USED FOR THIS PURPOSE:- * !* 1&2 HOLD AUX STACK DESCRIPTOR * !* 3 HOLDS VALUE AT BLK ENTRY FOR USE AT EXIT * !* 4 HOLDS STACKTOP VALUE AFTER ALL ARRAY DECLNS(FOR %ONS) * !* 5 HOLD STACKLIMIT FOR CHECKING AT ARRAY DECLARATIONS * !* THE LATTER IS OMITTED INPARM=OPT * !*********************************************************************** %INTEGER XYNB, DR0, DR1 %IF AUXST=0 %THEN %START; ! FIRST REF PUT REF IN PLT DR0=X'30000001'; DR1=0 PGLA(8,8,ADDR(DR0)) AUXST=GLACA-8 GXREF(AUXSTEP,2,X'02000008',AUXST+4) %FINISH %IF AUXSBASE(LEVEL)=0 %START XYNB=SET XORYNB(-1,-1) PF1(LD,2,XYNB,AUXST) %IF PARMOPT#0 %THEN %START PF1(LSS,1,0,2); ! PICK UP STACKTOP PSF1(ST,1,N+16) %FINISH PF1(LSS,2,7,0) PSF1(STD,1,N) PSF1(ST,1,N+8) AUXSBASE(LEVEL)=N; N=N+16 %IF PARMOPT#0 %THEN N=N+4 GRUSE(DR)=0; GRUSE(ACCR)=11; GRINF1(ACCR)=0 %FINISH %END %ROUTINE RESET AUX STACK !*********************************************************************** !* IF ANY ARRAYS HAVE BEEN PUT ON THE AUXSTACK THEN UNDECLARE * !*********************************************************************** %IF AUXSBASE(LEVEL)#0 %START PSF1(LB,1,AUXSBASE(LEVEL)+8) PSF1(STB,2,AUXSBASE(LEVEL)) GRUSE(BREG)=0 %FINISH %END %ROUTINE RT EXIT !*********************************************************************** !* THIS ROUTINE COMPILES CODE FOR ROUTINE EXIT(IE '%RETURN') * !*********************************************************************** RESET AUX STACK PSF1(EXIT,0,-X'40') %END %ROUTINE CLAIM ST FRAME(%INTEGER AT,VALUE) !*********************************************************************** !* FILL ASF INSTN IN RT ENTRY SEQUENCE TO CLAIM THE STACKFRAME * !*********************************************************************** %INTEGER INSTR, WK WK=AT>>18; ! BYTES CLAIMED BY ENTRY SEQ AT=AT&X'3FFFF'; ! ADRR OF ASF INSTRN INSTR=(ASF+12*PARMCHK)<<24!3<<23!(VALUE-WK+3)>>2 PLUG(1,AT,INSTR,4) %END %ROUTINE CEND (%INTEGER KKK) !*********************************************************************** !* DEAL WITH ALL OCCURENCES OF '%END' * !* KKK=PTYPE(>=X'1000') FOR ROUTINES,FNS AND MAPS * !* KKK=0 FOR ENDS OF '%BEGIN' BLOCKS * !* KKK=1 FOR '%ENDOFPROGRAM' * !* %ENDOFPROGRAM IS REALLY TWO ENDS. THE FIRST IS THE USERS * !* AND THE SECOND IS PERMS. KKK=2 FOR A RECURSIVE CALL OF CEND * !* ON END OF PROGRAM TO DEAL WITH THE %END CORRESPONDING TO * !* THE %BEGIN COMPILED IN THE INITIALISATION SEQUENCE * !*********************************************************************** %INTEGER KP,JJ,BIT %ROUTINESPEC DTABLE(%INTEGER LEVEL) SET LINE %UNLESS KKK=2 FORGET(-1) BIT=1<X'1000' %AND COMPILER=0 %AND LAST INST=0 %C %THEN PPJ(15,10); ! RUN FAULT 11 NMAX=N %IF N>NMAX; ! WORK SPACE POINTER ! ! CLEAR OUT THE LABEL LIST FAULTING LABELS WITH JUMPS OUTSTANDING ! AS NOT SET AND COMMENTING ON LABELS NOT USED ! %WHILE LABEL(LEVEL)#0 %CYCLE POP(LABEL(LEVEL),I,J,KP) I=I>>24 %IF J&X'FFFF'#0 %THEN %START J=J&X'FFFF' %IF 0=X'1000' %OR KKK=1 %THEN CLAIM ST FRAME(SET(RLEVEL),NMAX) ! ! NOW PLANT THE BLOCK EXIT SEQUENCE ! %IF KKK&X'3FFF'=X'1000' %AND LAST INST=0 %THEN RT EXIT PPJ(15,21) %IF KKK=1 %AND LAST INST=0;! %STOP AT %ENDOFPROGRAM %IF KKK=0 %THEN %START; ! BEGIN BLOCK EXIT %IF PARMTRACE=1 %THEN %START; ! RESTORE DIAGS POINTERS PSF1(LD,1,12) DIAG POINTER(LEVEL-1) PSF1(STD,1,12) %FINISH %IF STACK#0 %START JJ=NMDECS(LEVEL)>>14 %IF JJ#0 %THEN %START; ! ARRAYS TO BE UNDECLARED PF1(STSF,0,TOS,0) PF1(LSS,0,TOS,0) PSF1(ISB,1,JJ) PSF1(USH,0,-2) PF1(ST,0,TOS,0) PF1(ASF,0,TOS,0) GRUSE(ACCR)=0 %FINISH %FINISH %ELSE RESET AUX STACK %FINISH ! ! RETURN TO PREVIOUS LEVEL PROVIDED THERE IS A VALID ONE ! ! %UNLESS LEVEL>2 %OR (LEVEL=2 %AND CPRMODE=2) %THEN %START %IF KKK=1 %AND LEVEL=2 %THEN KKK=2 %ELSE FAULT(109,0,0) ! SHOULD BE CHKD IN PASS1 %FINISH LEVEL=LEVEL-1 %IF KKK>=X'1000' %THEN %START RLEVEL=RLEVEL-1 RBASE=RLEVEL %FINISH ! ! RESTORE INFORMATION ABOUT THE (NEW) CURRENT LEVEL ! POP(LEVELINF,KP,N,KP) NMAX=N>>16 %IF KKK>=X'1000' N=N&X'7FFF' %IF KKK=2 %THEN CEND(KKK); ! ROUND AGAIN FOR 'ENDOFPROGRAM' ! ! COMPLETE THE JUMP AROUND ALL NON-EXTERNAL ROUTINES EXCEPT WHEN ! %TRUSTEDPROGRAM IS IN OPERATION. ! %IF ASL WARN#0 %THEN ASL WARN=0 %AND EPILOGUE %IF KKK>=X'1000' %AND COMPILER=0 %AND(RLEVEL>0 %OR CPRMODE#2)%C %THEN %START JJ=NEXTP+6 %UNLESS A(NEXTP+5)=11 %AND A(JJ+FROMAR2(JJ))=2 %START JJ=ENTER LAB(JROUND(LEVEL+1),0) JROUND(LEVEL+1)=0 %FINISH %FINISH %RETURN ! ! LAYOUT OF DIAGNOSIC TABLES ! ****** ** ********* ****** ! ! THE BOUND FIELD OF PLT DESCRIPTOR STORED AT (LNB+3 & LNB+4) IF ! USED TO CONTAIN A DISPLACEMENT RELATIVE TO THE START OF SST OF THE ! DIAGNOSTIC TABLES FOR THE BLOCK OR ROUTINE BEING EXECUTED. ! A ZERO BOUND MEANS NO DIAGNOSTIC REQUESTED.(NB THIS MAY MEAN A DUMMY ! FIRST WORD IN THE SST). ! THE ABSOLUTE ADDRESS OF THE SST FOR THE CURRENT CODE SEGMENT WILL ! ALWAYS BE FOUND IN THE STANDARD 10 WORDS OF THE GLA/PLT ! ! FORM OF THE TABLES:- ! ! WORD 0 = LINE OF RT IN SOURCE PROG <<16 ! LINE NO POSN(FROM LNB) ! WORD 1 = (12 LANG DEPENDENT BITS)<<18 ! ENVIRONMENT ! ( TOP 2 BITS OF LANG DEPENDENT HAS LITL FROM PTYPE) ! ( BOTTOM 4 BITS HAVE TEXTUAL LEVEL) ! WORD 2 = DISPLAY POSN (FROM LNB)<<16 ! RT TYPE INFO ! WORD 3 = ZERO FOR BLKS OR STRING(<=11BYTES) BEING THE ! RT NAME. THIS WILL TAKE WORDS 4 AND 5 IF NEEDED ! WORD 6 = LANGUAGE DEPENDENT INFO . IMP ON CONDITIONS ETC ! ! THE REST IS MADE UP OF VARIABLE ENTRIES AND THE SECTION IS TERMINATED BY ! A WORD OF X'FFFFFFFF' ! ! EACH VARIABLE ENTRY CONSISTS OF THE VARIABLE WORD FOLLOWED BY ! THE VARIABLE NAME AS A STRING. THE WORD CONSISTS OF ! BITS 2**31 TO 2**20 TYPE INFORMATION (MAY BE LANGUAGE DEPENDENT ! BIT 2**19 =0 UNDER LNB =1 IN GLA ! BITS 2**18 TO 2**0 DISPLACEMENT FROM LNB(GLA) IN BYTES ! ! ! THE ENVIRONMENT IS A POINTER (RELATIVE TO SST) OF THE NEXT OUTERMOST ! BLOCK OR A POINTER TO GLOBAL OWNS, EXTERNAL OR COMMON AREAS ! A ZERO MEANS NO ENCLOSING BLOCK. WORD1=WORD3=0 IS AN ! IMP MAIN PROGRAM AND WILL TERMINATE THE DIAGNOSTICS. ! %ROUTINE DTABLE(%INTEGER LEVEL) !*********************************************************************** !* THIS ROUTINE LOOKS AT THE DECLARATIONS FOR THE CURRENT LEVEL & * !* SETS UP THE SEGMENT OF SHARABLE SYMBOL TABLES TO DESCRIBE THEM.* !* FOR MAIN PROGRAMS OR EXTERNAL ROUTINES THE 'GLOBAL' VARIABLES * !* (IF ANY) ARE ALSO INCLUDED. * !*********************************************************************** %STRING(31) RT NAME %STRING(11) LOCAL NAME %RECORD(LISTF)%NAME LCELL %CONSTINTEGER LARRROUT=X'F300' %INTEGER DPTR,LNUM,ML,KK,JJ,Q,DEND,BIT,S1,S2,S3,S4,LANGD,II %INTEGERARRAY DD(0:500); ! BUFFER FOR SEGMENT OF SST ! ! FILL ALL OUTSTANDING REFERENCES TO THIS DIAGS BLOCK ! BIT=1<>14<<30!LEVEL<<18; ! GET LITL FROM PTYPE %WHILE RAL(LEVEL)#0 %CYCLE POP(RAL(LEVEL),Q,JJ,KK) PLUG(Q,JJ,KK!SSTL,4) %REPEAT PUSH(RAL(LEVEL-1),4,SSTL+4,LANGD) %IF PARMTRACE#0 DD(0)=L(LEVEL)<<16!(DIAGINF(LEVEL)) DD(1)=LANGD DD(2)=DISPLAY(RLEVEL)<<16!FLAG(LEVEL)&X'3FFF' ML=M(LEVEL); ! ROUTINE NAME(=0 FOR %BEGIN) %IF ML#0 %THEN ML=WORD(ML-1); ! IF NOT BLOCK GET DIRPTR LNUM=BYTEINTEGER(DICTBASE+ML); ! LENGTH OF THE NAME DPTR=4; DEND=0 %IF LNUM=0 %THEN DD(3)=0 %ELSE %START Q=DICTBASE+ML RT NAME<-STRING(Q); ! FOR RTS MOVE IN 1ST 32 CHARS LNUM=BYTE INTEGER(ADDR(RT NAME)) STRING(ADDR(DD(3)))=RTNAME; ! AND UPDATE POINTER PAST DPTR=DPTR+LNUM>>2; ! ACTUAL NO OF CHARS %FINISH DD(DPTR)=ONWORD(LEVEL); ! ON CONDITION WORD DPTR=DPTR+1 JJ=NAMES(LEVEL) %WHILE 0<=JJ>16; TYPE=PTYPE&15 ! ! FAULT ALL UNUSED NAMES EXCEPT CONSTINTEGERS&REALS ! %IF (TYPE>2 %OR PTYPE&X'FF00'#X'4000' %OR PARMY#0) %C %AND S1&X'F000'=0 %THEN WARN(2,JJ) I=S1>>4&15 J=S1&15 K=S3>>16 ! ! ALLOW OWNS (LITL=0) AND EXTERNALS (=2) NOT CONSTS(=1) OR EXTRINSIC(=3) ! %IF PARMDIAG#0 %AND PTYPE&X'7300'<=X'200' %AND DPTR<497 %C %AND (TYPE=1 %OR TYPE=2 %OR TYPE=5) %START Q=DICTBASE+WORD(JJ); ! ADDRESS OF NAME %IF I=0 %THEN II=1 %ELSE II=0; ! GLA OR LNB BIT DD(DPTR)=PTYPE<<20!II<<18!K LOCAL NAME<-STRING(Q); ! TEXT OF NAME FROM DICTIONARY LNUM=BYTE INTEGER(ADDR(LOCAL NAME)) STRING(ADDR(DD(DPTR))+4)=LOCAL NAME;! MOVE IN NAME DPTR=DPTR+(LNUM+8)>>2 %FINISH %IF J=15 %AND PTYPE&X'30000'#0 %AND S1&X'C000'#0 %THEN %C FAULT(28,0,JJ) ! SPEC&USED BUT NO BODY GIVEN %IF J=15 %AND TYPE=4 %THEN FAULT(62,0,JJ) %IF PTYPE&X'3000'#0 %OR TYPE=4 %OR TYPE=6 %THEN %C CLEAR LIST(K) %ELSE %START %IF I#0 %AND K>511 %AND PTYPE&LARRROUT=0 %AND TYPE#7 %C %THEN WARN(5,JJ) %FINISH JJ=S4>>18 %REPEAT DD(DPTR)=-1; ! 'END OF SEGMENT' MARK DPTR=DPTR<<2+4 %IF PARMTRACE=1 %THEN %START LPUT(4,DPTR,SSTL,ADDR(DD(0)));! ADD TO SHARABLE SYM TABS SSTL=SSTL+DPTR %FINISH %END; ! OF ROUTINE DTABLE %END %ROUTINE MAKE DECS(%INTEGER Q) !*********************************************************************** !* Q IS TO AR ENTRY FOR HEAD OF LINKED DECLARATIONS * !*********************************************************************** %INTEGER QQ,HEAD,PRIO,COUNT,SL,MARKER %INTEGERNAME THEAD %RECORD(LISTF)%NAME CELL SL=LINE; QQ=FROM AR4(Q) HEAD=0; COUNT=0 %WHILE QQ#0 %CYCLE COUNT=COUNT+1 ABORT %UNLESS A(QQ+5)=8; ! LINE IS A DECLARATION P=QQ+10 MARKER=P+FROMAR2(P) P=P+2 %IF A(P)<=3 %AND A(MARKER)=1 %START;! 1ST 3 ALTS OF TYPE ! ARE INT,REAL LONG INT&REAL CLT PRIO=PREC<<4!TYPE %IF A(P+1)#3 %THEN PRIO=X'FFFE';! POINTER HAVE LOW PRIORITY THEAD==HEAD %CYCLE CELL==ASLIST(THEAD) %IF THEAD=0 %OR PRIO=7 %START GET WSP(QQ,2); ! A DIUBLE WORD %IF AVL WSP(1,LEVEL)=0 %THEN GET WSP(QQ,1) %FINISH %WHILE HEAD#0 %CYCLE POP(HEAD,PRIO,QQ,COUNT) LINE=FROM AR2(QQ+3) P=QQ+12; CLT ROUT=0; LITL=0 CQN(P+1); P=P+2 DECLARE SCALARS(1,KFORM) %REPEAT LINE=SL %END %ROUTINE DECLARE SCALARS(%INTEGER PERMIT,XTRA) !*********************************************************************** !* THIS ROUTINE DECLARES A LIST OF SCALARS FROM INFORMATION * !* IN THE GLOBAL VARIABLES ROUT,NAM,ARR,PREC,TYPE & ACC.IT WORKS * !* OUT ROUNDING FACTORS FOR ITSELF. * !* P POINTS TO THE NAMELIST ON ENTRY AND IS UPDATED. * !* PERMIT IS 0 IF DECLARING FORMAL PARAMETERS * !*********************************************************************** %INTEGER INC,Q,SCHAIN,DMADE,NPARMS,SCAL NAME,TYPEP PACK(PTYPE); J=0 INC=ACC; DMADE=0; SNDISP=0 %IF PTYPE=X'33' %THEN INC=(INC+3)&(-4) %IF NAM#0 %AND ROUT=0 %AND ARR=0 %THEN INC=8 %IF NAM>0 %AND ARR>0 %THEN INC=16 %IF PTYPE=X'35' %AND (ACC<=0 %OR ACC>256) %THEN FAULT(70,ACC-1,0) %IF PERMIT#0 %AND (INC=8 %OR INC=16) %THEN ODD ALIGN %IF PERMIT#0 %AND (PTYPE=X'33' %OR PTYPE=X'35')%START Q=WORD CONST(X'18000000'+ACC) PF1(LDTB,0,PC,Q) GRUSE(DR)=0 %FINISH %IF PTYPE=X'35' %START INC=8 %IF PERMIT#0 %START PF1(STSF,0,TOS,0) PF1(LDA,0,TOS,0) %FINISH %FINISH N=(N+3)&(-4) %IF PTYPE=X'33' %AND PERMIT#0 %THEN %START PSF1(LDA,1,PTR OFFSET(RBASE)) PSF1(INCA,0,N+8) %FINISH %UNTIL A(P-1)=2 %CYCLE; ! DOWN THE NAMELIST DMADE=DMADE+1 SCAL NAME=FROM AR2(P) %IF PTYPE=X'31' %AND PERMIT=0 %THEN N=N+3;! BYTE PARAMS %IF PTYPE=X'41' %AND PERMIT=0 %THEN N=N+2 SCHAIN=N KFORM=XTRA %IF ROUT=1 %THEN %START TYPEP=PTYPE; ! CHANGED BY CFPLIST! Q=P P=P+3 %UNTIL A(P-1)=2; ! TO FPP CFPLIST(SCHAIN,NPARMS) P=Q J=13 KFORM=NPARMS; ! NO OF PARAMS OF FORMAL ACC=N; ! DISPLACEMENT TO MIDCELL PTYPE=TYPEP; UNPACK %FINISH P=P+3 %IF PTYPE=X'33' %THEN %START %IF PERMIT#0 %START PSF1(STD,1,N) %IF A(P-1)=1 %THEN PSF1(INCA,0,INC+8) %FINISH N=N+8; SCHAIN=N %FINISH %IF PTYPE=X'35' %AND PERMIT#0 %START PSF1(STD,1,N) %IF A(P-1)=1 %THEN PSF1(INCA,0,(ACC+3)&(-4)) %ELSE %START Q=((ACC+3)>>2)*DMADE PSF1(ASF+12*PARMCHK,0,Q) %IF PARMCHK#0 %THEN PPJ(0,4) %FINISH %FINISH STORE TAG(SCAL NAME,SCHAIN) N=N+INC %REPEAT %IF PERMIT#0 %THEN N=(N+3)&(-4); ! THIS IS NECESSARY ! %END %INTEGERFN DOPE VECTOR(%INTEGER TYPEP,ELSIZE,MODE,IDEN, %C %INTEGERNAME ASIZE,LB) !*********************************************************************** !* CONSTRUCTS THE DOPE-VECTOR FOR A CONSTANT ARRAY IN THE * !* SHAREABLE SYMBOL TABLES AND RETURNS ITS DISPLACEMENT AS RESULT* !* EVENTUALLY ALL NON DYNAMIC DOPE VECTORS SHOULD GO VIA HERE * !* P IS TO ALT (MUST BE 1!) OF P * !* DOPE VECTOR CONSISTS OF :- * !* DESRIPTOR (SCALED WORD) POINTING AT FIRST TRIPLE BND=3*ND * !* SIZE (IN BYTES OF ENTIRE ARRAY) FOR STACK ADJUSTMENT * !* AND ND TRIPLES EACH CONSISTING OF:- * !* LBI - THE LOWER BOUND OF THE ITH DIMENSION * !* MI - THE STRIDE FOR THE ITH DIMENSION * !* CBI THE UPPER CHECK =(UBI-LBI+1)*MI * !* WHERE M1=1(SCALED ARRAYS) OR THE ELEMENT SIZE AND * !* MI = M(I-1)*RANGE(I-1) * !* MODE=0 DV MUST BE CONST, MODE#0 CAN BE DYNAMIC * !* MODE=-1 SPECIAL FOR CONSTARRAYNAMES 1D 0:INFINITY * !* P TO ALT (ALWAYS=1) OF P(BPAIR) * !*********************************************************************** %INTEGER I, JJ, K, ND, D, UNSCAL, M0, HEAD, NOPS, TYPEPP, PIN, PTR %RECORD(LISTF)%NAME LCELL %INTEGERARRAY LBH,LBB,UBH,UBB(0:12) %INTEGERARRAY DV(0:39); ! ENOUGH FOR 12 DIMENSIONS ND=0; NOPS=0; TYPEPP=0; PIN=P %IF TYPEP>2 %OR (TYPEP=1 %AND PREC=4)%C %THEN UNSCAL=1 %AND M0=ELSIZE %C %ELSE UNSCAL=0 %AND M0=1 %IF MODE=-1 %THEN %START ND=1; DV(3)=0 DV(4)=M0 M0=X'FFFFFF' DV(5)=M0 %FINISH %ELSE %START %UNTIL A(P)=2 %CYCLE ND=ND+1; P=P+4 FAULT(37,0,IDEN) %AND ND=1 %IF ND>12 LBH(ND)=0; LBB(ND)=0 UBB(ND)=0; UBH(ND)=0 TORP(LBH(ND),LBB(ND),NOPS) P=P+3 TYPEPP=TYPEPP!TYPE TORP(UBH(ND),UBB(ND),NOPS) TYPEPP=TYPEPP!TYPE %REPEAT P=P+1 ->NONCONST %UNLESS TYPEPP=1 %AND NOPS&X'40040000'=0 ! ! NOW ONE CAN WORK OUT AND FILL IN THE TRIPLES ! PTR=1 %CYCLE D=ND,-1,1 K=3*D EXPOP(LBH(PTR),ACCR,NOPS,X'251') EXPOPND_D=0 %AND FAULT(41,0,0) %UNLESS %C EXPOPND_FLAG<=1 %AND EXPOPND_PTYPE=X'51' DV(K)=EXPOPND_D DV(K+1)=M0 EXPOP(UBH(PTR),ACCR,NOPS,X'251') EXPOPND_D=10 %AND FAULT(41,0,0) %UNLESS %C EXPOPND_FLAG<=1 %AND EXPOPND_PTYPE=X'51' JJ=EXPOPND_D M0=M0*(JJ-DV(K)+1) FAULT(38,1-M0,IDEN) %UNLESS JJ>=DV(K) DV(K+2)=M0 PTR=PTR+1 %REPEAT %IF UNSCAL=0 %THEN M0=M0*ELSIZE %FINISH ! %IF ND=1 %THEN LB=DV(3) FAULT(39,0,IDEN) %IF M0>X'FFFFFF' ASIZE=M0 DV(2)=ASIZE DV(1)=12 DV(0)=5<<27!3*ND; ! DESPTR FOR DV K=3*ND+2 J=ND; ! DIMENSIONALITY FOR DECLN HEAD=DVHEADS(ND) %WHILE HEAD#0 %CYCLE LCELL==ASLIST(HEAD) %IF LCELL_S2=ASIZE %AND LCELL_S3=DV(5) %START %CYCLE D=0,1,K ->ON %UNLESS DV(D)=CTABLE(D+LCELL_S1) %REPEAT %RESULT=X'80000000'!4*LCELL_S1 %FINISH ON: HEAD=LCELL_LINK %REPEAT %IF CONST PTR&1#0 %THEN CONST HOLE=CONST PTR %AND %C CONST PTR=CONST PTR+1 I=4*CONST PTR!X'80000000' PUSH(DVHEADS(ND),CONSTPTR,ASIZE,DV(5)) %CYCLE D=0,1,K CTABLE(CONST PTR)=DV(D) CONST PTR=CONST PTR+1 %REPEAT %IF CONST PTR>CONST LIMIT %THEN FAULT(102, WKFILEK,0) WAYOUT: %IF MODE=-1 %THEN %RESULT=I; ! NO EXPRESSION CELLS TO RETURN %CYCLE D=ND,-1,1 ASLIST(LBB(D))_LINK=ASL ASL=LBH(D) ASLIST(UBB(D))_LINK=ASL ASL=UBH(D) %REPEAT %RESULT =I NONCONST: ! NOT A CONST DV J=ND; I=-1 LB=0; ASIZE=ELSIZE %IF MODE=0 %THEN FAULT(41,0,0) %ELSE P=PIN ->WAYOUT %END %ROUTINE DECLARE ARRAYS(%INTEGER FORMAT, FINF) !*********************************************************************** !* FORMAT=1 FOR 'ARRAYFORMAT' =0 OTHERWISE * !* FINF>0 FOR RECORD FORMAT INFORMATION =0 OTHERWISE * !* P IS AT P IN * !* * !* P= * !* P = '('':'*')' * !* * !* ARRAYS WITH CONSTANT BOUNDS HAVE THEIR D-V IN THE SST * !* ALL OTHER ARRAYS HAVE A DOPE VECTOR AMONG THE LOCALS AND GET * !* THEIR SPACE OFF THE STACK AT RUN TIME * !* BOTH SORTS OF ARRAYS HAVE A FOUR WORD HEAD AND D-V TO EMAS * !* SYSTEM STANDARDS * !*********************************************************************** %ROUTINESPEC CLAIM AS %INTEGER DVDISP, PP, DVF, ELSIZE, TOTSIZE, D0, D1, PTYPEP, %C ARRP, NN, ND, II, JJ, QQ, R, CDV, UNSCAL, DESC, SC, %C LWB, PTYPEPP, JJJ, JJJJ, ADJ %IF STACK#0 %AND FLAG(LEVEL)=0=NMDECS(LEVEL)>>14 %START PSF1(STSF,1,N) NMDECS(LEVEL)=NMDECS(LEVEL)!(N<<14) N=N+4 %FINISH %IF STACK=0 %THEN SAVE AUX STACK ARRP=2*FORMAT+1; ARR=ARRP; PACK(PTYPEP) ELSIZE=ACC %IF TYPE>2 %OR (TYPE=1 %AND PREC=4)%C %THEN UNSCAL=1 %AND SC=3 %C %ELSE UNSCAL=0 %AND SC=PREC DESC=SC<<27!UNSCAL<<25!(1-PARMARR)<<24;! ARRAY DESCRIPTOR SKELETON %IF PREC=4 %THEN DESC=X'58000002' START:NN=1; P=P+1; ! NO OF NAMES IN NAMELIST PP=P; CDV=0; PTYPEPP=PTYPEP P=P+3 %AND NN=NN+1 %WHILE A(P+2)=1 P=P+3 DVDISP=DOPE VECTOR(TYPE,ELSIZE,1,FROMAR2(PP),TOTSIZE,LWB) ND=J ->CONSTDV %UNLESS DVDISP=-1 ! NORMAL CASE - PLANT CODE TO SET UP DOPE-VECTOR AT RUN TIME DVF=0; TOTSIZE=X'FFFF' DVDISP=N; ! DVDISP IS D-V POSITION N=N+12*ND+12; ! CLAIM SPACE FOR THE D-V D0=5<<27!3*ND; D1=12; ! DESCPTR FOR DV STORE CONST(JJ,8,ADDR(D0)) PF1(LD,0,PC,JJ) PSF1(STD,1,DVDISP) GRUSE(DR)=0 %IF UNSCAL=0 %THEN JJ=1 %ELSE JJ=ELSIZE PSF1(LSS,0,JJ); ! M1 THE FIRST MULTIPLIER GRUSE(ACCR)=0 %CYCLE II=ND,-1,1 P=P+1 QQ=DVDISP+12*II; ! TRIPLE FOR IITH DIMENSION PSF1(ST,1,QQ+4); ! STORE MULTIPLIER CSEXP(ACCR,X'51'); ! LOWER BOUND %IF ND=1 %AND PTYPEP&7<=3 %AND FORMAT=0 %AND GRUSE(ACCR)=5 %C %AND GRINF1(ACCR)=0 %THEN PTYPEPP=PTYPEPP+256 PSF1(ST,1,QQ); ! STORED IN DV CSEXP(ACCR,X'51'); ! UPPER BOUND PSF1(ISB,1,QQ) GRUSE(ACCR)=0 %IF COMPILER=0 %OR PARMARR#0 %START PF3(JAF,6,0,3); ! JUMP UNLESS NEGATIVE PSF1(LSS,0,-1); ! SET UP -1 (ENSURES 0 ELEMENTS %FINISH PSF1(IAD,0,1); ! CONVERTED TO RANGE PSF1(IMY,1,QQ+4); ! RANGE*MULTIPLIER PSF1(ST,1,QQ+8); ! AND STORED IN DV %REPEAT P=P+1 %IF UNSCAL=0 %AND ELSIZE#1 %THEN PSF1(IMY,0,ELSIZE) PSF1(ST,1,DVDISP+8) SNDISP=0; ! DV NOT AVAILABLE AT COMPILETIME ->DECL CONSTDV: ! ONE DIMENSION - CONSTANT BOUNDS DVF=1; CDV=1 %IF ND=1 %AND LWB=0 %AND PTYPEP&15<=3 %C %AND FORMAT=0 %THEN PTYPEPP=PTYPEP+256 ! SET ARR=2 IF LWB=ZERO SNDISP=(DVDISP&X'FFFFFF')>>2 DECL: ! MAKE DECLN - BOTH WAYS J=ND ODD ALIGN PTYPE=PTYPEPP; UNPACK %IF DVF#0 %THEN %START; ! ARRAY IS STRING OF LOCALS R=TOTSIZE %IF UNSCAL=0 %THEN R=R//ELSIZE D0=DESC D0=D0!R %UNLESS PREC=4 STORE CONST(D1,4,ADDR(D0)) PF1(LB,0,PC,D1) %FINISH %ELSE %START STORE CONST(D1,4,ADDR(DESC)) PF1(LB,0,PC,D1) PSF1(ADB,1,DVDISP+20) %UNLESS PREC=4 %FINISH %IF DVF#0 %THEN QQ=PC %ELSE QQ=LNB PSORLF1(LDRL,0,QQ,DVDISP) GRUSE(BREG)=0; GRUSE(DR)=0 %CYCLE JJJ=0,1,NN-1; ! DOWN NAMELIST PSF1(STB,1,N+16*JJJ); ! ARRAY BOUND PSF1(STD,1,N+8+16*JJJ); ! DV POINTER %REPEAT %IF PARMARR=0 %AND PARMCHK=0 %AND ND=1 %AND TYPE<=3 %C %AND PTYPEPP&X'F00'#X'200' %THEN ADJ=1 %ELSE ADJ=0 %CYCLE JJJ=0,1,NN-1; ! DOWN NAMELIST %IF ADJ#0 %START; ! ADJUST DESC %IF STACK#0 %START; ! ARRAY ON AUTOMATIC STACK PF1(STSF,0,BREG,0); ! CURRENT SF TO B %IF DVF#0 %THEN PSF1(SBB,0,LWB*ELSIZE) %ELSE %START %IF ELSIZE=1 %THEN PSF1(SBB,1,DVDISP+12) %ELSESTART PSF1(SLB,1,DVDISP+12) PSF1(MYB,0,ELSIZE) PF1(SLB,0,TOS,0) PF1(SBB,0,TOS,0) %FINISH %FINISH PSF1(STB,1,N+4) GRUSE(BREG)=0 %FINISH %ELSE %START; ! ARRAY ON AUX STACK %IF DVF#0 %START; ! CONST DOPE VECTOR %UNLESS GRUSE(ACCR)=11 %%START PSF1(LSS,2,AUXSBASE(LEVEL)) GRUSE(ACCR)=11; GRINF1(ACCR)=0 %FINISH JJJJ=LWB*ELSIZE-GRINF1(ACCR) PSF1(ISB,0,JJJJ) %UNLESS JJJJ=0 GRINF1(ACCR)=LWB*ELSIZE %FINISH %ELSE %START; ! DYNAMIC ARRAYS %IF GRUSE(ACCR)=11 %AND GRINF1(ACCR)=0 %AND %C ELSIZE=1 %THEN PSF1(ISB,1,DVDISP+12) %ELSESTART PSF1(LSS,1,DVDISP+12) PSF1(IMY,0,ELSIZE) %UNLESS ELSIZE=1 PSF1(IRSB,2,AUXSBASE(LEVEL)) %FINISH GRUSE(ACCR)=0 %FINISH PSF1(ST,1,N+4) %FINISH %FINISH %ELSE %START; ! NO ADJUSTMENT OF DESCRPT %IF STACK#0 %THEN PSF1(STSF,1,N+4) %ELSE %START PSF1(LSS,2,AUXSBASE(LEVEL)) %UNLESS GRUSE(ACCR)=11 %C %AND GRINF1(ACCR)=0 PSF1(ST,1,N+4) GRUSE(ACCR)=11; GRINF1(ACCR)=0 %FINISH %FINISH ACC=ELSIZE; ! RESET ACC AFTER DV CMPLD KFORM=FINF; ! FORMAT INFORMATION K=FROM AR2(PP+3*JJJ) STORE TAG(K,N) CLAIM AS %IF FORMAT = 0 N=N+16 %REPEAT P=P+1; ! PAST REST OF ARRAYLIST %IF A(P-1)=1 %THEN ->START %RETURN %ROUTINE CLAIM AS !*********************************************************************** !* CLAIM THE SPACE FOR AN ARRAY FROM STACK OR AUX STACK * !*********************************************************************** %INTEGER T, B, D,ADJMENT %IF STACK=1 %THEN %START; ! FROM AUTOMATIC STACK %IF CDV=1 %THEN %START; ! CONSTANT BOUNDS T=(TOTSIZE+3)//4 PSF1(ASF+12*PARMCHK,0,T); ! ASF OR LB PPJ(0,4) %IF PARMCHK#0 %FINISH %ELSE %START; ! DYNAMIC BOUNDS %IF PARMCHK=0 %AND PTYPEP&7<=2 %AND %C (ELSIZE=4 %OR ELSIZE=8) %START PSF1(ASF,1,DVDISP+20); ! SIZE IN ELEMENTS WORD PSF1(ASF,1,DVDISP+20) %IF ELSIZE=8 %FINISH %ELSE %START PSF1(LSS,1,DVDISP+8); ! ARRAY SIZE BYTES PSF1(IAD,0,3) %IF ELSIZE&3#0 PSF1(USH,0,-2); ! ARRAY SIZE WORDS PF1(ST,0,BREG,0) FORGET(BREG) %IF PARMCHK#0 %THEN PPJ(0,4) %ELSE PF1(ASF,0,BREG,0) %FINISH %FINISH CHECK STOF %FINISH %ELSE %START %UNLESS GRUSE(ACCR)=11 %AND (GRINF1(ACCR)=0 %OR CDV=1) %START PSF1(LSS,2,AUXSBASE(LEVEL)) GRUSE(ACCR)=11; GRINF1(ACCR)=0 %FINISH %IF CDV=1 %THEN %START ADJMENT=(TOTSIZE+7)&(-8)+GRINF1(ACCR) %IF ADJMENT>4 TYPE=TYPE&7 P=P+1 ACC=BYTES(PREC) PACK(PTYPEP); ! PRESERVE ALL COMPONENT ! BEFORE CALLINT INTEXP ETC %IF TYPE=5 %THEN %START; ! P='%STRING' %IF A(P)=1 %THEN %START; ! MAX LENGTH GIVEN %IF A(P+1)=1 %START; ! EXPRESSION NOT STAR P=P+4 %IF INTEXP(I)#0 %THEN FAULT(41,0,0) ACC=I+1 PTYPE=PTYPEP; UNPACK %FINISH %ELSE ACC=0 %AND P=P+2 %FINISH %ELSE ACC=0 %AND P=P+1 %FINISH KFORM=0 %IF TYPE=3 %THEN KFORM=CFORMATREF %AND PTYPE=PTYPEP %AND UNPACK %END %ROUTINE CQN(%INTEGER P) !*********************************************************************** !* SET NAM & ARR FROM ALTERNATIVE OF PHRASE * !* P='%ARRAYNAME','%NAME',<%NULL> * !* P POINTS TO THE ANALYSIS RECORD ENTRY AS IS NOT UPDATED * !*********************************************************************** %INTEGER I I=A(P);NAM=0;ARR=0 %IF I=1 %THEN ARR=1; ! ARRAYNAMES %IF I<=2 %THEN NAM=1; ! ARRAYNAMES & NAMES %END %INTEGERFN SET SWITCHLAB(%INTEGER HEAD,LAB,FNAME,BIT) !*********************************************************************** !* SET A SWITCH LABEL AND RETURNS RESULT=0 %UNLESS THE LABEL * !* HAS BEEN ALREADY SET WHEN IT RETURNS RESULT#0 * !* HEAD IS HEAD OF THE TAGS SIDECHAIN FOR THE SWITCH * !*********************************************************************** %INTEGER Q,QQ,JJJ,LB,UB,BASEPT %RECORDFORMAT BITFORM(%INTEGERARRAY BITS(0:2),%INTEGER LINK) %RECORD(BITFORM)%NAME BCELL %RECORD(LISTF)%NAME LCELL FORGET(-1) LCELL==ASLIST(HEAD) BASEPT=LCELL_S1 LB=LCELL_S2 UB=LCELL_S3 HEAD=LCELL_LINK BCELL==ASLIST(HEAD) %UNLESS LB<=LAB<=UB %THEN FAULT(50,LAB,FNAME) %AND %RESULT=0 Q=LAB-LB %WHILE Q>=96 %%CYCLE HEAD=BCELL_LINK BCELL==ASLIST(HEAD) Q=Q-96 %REPEAT ! ! ASLIST(HEAD) IS THE START OF 96 BIT ENTRY IN THE BIT LIST ! CHECK BIT NO Q TO SEE IF LABEL ALREADY SET AND THEN SET BIT Q ! QQ=Q>>5; ! RIGHT WORD Q=Q&31; JJJ=1<=%ROUTINE TYPEP=LITL<<14!X'1000' P=P+2; ! IGNORING ALT OF P(SPEC') %FINISH %ELSE %START; ! P= ROUT=1; ARR=0; P=P+1 CLT; NAM=0 %IF A(P)=2 %THEN NAM=2; ! 2 FOR MAP 0 FOR FN PACK(TYPEP) P=P+2; ! AGAIN IGNORING ALT OF P(SPEC') %FINISH P=P+4; ! PAST HOLE FOR DECLINKS KK=FROM AR2(P) XNAME<-STRING(DICTBASE+WORD(KK)) %IF EXTRN=1 %THEN XNAME<-"S#".XNAME JJ=0 P=P+3 %IF A(P-1)=1 %THEN XNAME<-STRING(ADDR(A(P))) %AND %C P=P+A(P)+1 CFPLIST(OPHEAD,NPARMS) %IF M=1 %THEN %START CXREF(XNAME,PARMDYNAMIC!(EXTRN//3),2,JJ); ! %STSTEM & %EXTERNAL =STATIC ! %DYNAMIC = DYNAMIC %FINISH %IF M=0 %AND RLEVEL=0 %START CODE DES(JJ) %IF CPRMODE=0 %THEN CPRMODE=2 %IF CPRMODE#2 %THEN FAULT(56,0,KK) %FINISH J=15-M; PTYPE=TYPEP KFORM=NPARMS SNDISP=JJ>>16 ACC=JJ&X'FFFF' STORE TAG(KK,OPHEAD) %END %ROUTINE CFPLIST(%INTEGERNAME OPHEAD,NPARMS) !*********************************************************************** !* COMPILE A FORMAL PARAMETER PART INTO A LIST OF PARAMETER TYPES * !* P(FPP)='('{(HOLE)(FPDEL)(NAMELIST)(MARK)}*')',0. * !* * !* THE LIST OF PARAMETER LOOKS LIKE:- * !* S1 = PTYPE FOR PARAM<<16! DIMENSION (DIMEN DEDUCED LATER) * !* S2 = ACC <<16 ! SPARE * !* S3 = 0 (RESERVED FOR FPP OF RTS) * !* * !* ON ENTRY P IS AT ALT OF FPP (WHICH MAY BE NULL) * !*********************************************************************** %INTEGER OPBOT, PP OPHEAD=0; OPBOT=0 NPARMS=0; ! ZERO PARAMETERS AS YET %WHILE A(P)=1 %CYCLE; ! WHILE SOME(MORE) FPS PP=P+1+FROMAR2(P+1); ! TO NEXT FPDEL P=P+3; ! TO ALT OF FPDEL CFPDEL; ! GET TYPE & ACC FOR NEXT GROUP %UNTIL A(P-1)=2 %CYCLE; ! DOWN FOR EACH DEL BINSERT(OPHEAD,OPBOT,PTYPE<<16,ACC<<16,0) NPARMS=NPARMS+1 P=P+3 %REPEAT P=PP %REPEAT P=P+1 %END %ROUTINE CFPDEL !*********************************************************************** !* SET UP PTYPE & ACC FOR A FORMAL PARAMETER DEFINITION * !* P=<%QNAME'>, * !* (RT)(%NAME')(NAMELIST)(FPP), * !* '%NAME'. * !*********************************************************************** %SWITCH FP(1:3) %INTEGER FPALT FPALT=A(P); P=P+1 KFORM=0; LITL=0 ->FP(FPALT) FP(1): ! (TYPE)(%QNAME') ROUT=0; CLT CQN(P) FAULT(70,ACC-1,0) %IF TYPE=5 %AND NAM=0 %AND (ACC<=0 %OR ACC>256) P=P+1 ->PK FP(2): ! (RT)(%NAME')(NAMELIST)(FPP) ROUT=1; NAM=1 ARR=0 %IF A(P)=1 %THEN %START; ! RT=%ROUITNE TYPE=0; PREC=0 P=P+2 %FINISH %ELSE %START P=P+1; CLT; ! RT=(TYPE)(FM) NAM=1 %IF A(P)=2 %THEN NAM=3; ! 1 FOR FN 3 FOR MAP P=P+2; ! PAST (%NAME') WHICH IS IGNORED %FINISH ACC=16 ->PK FP(3): ! %NAME ACC=8; NAM=1 ROUT=0; TYPE=0 ARR=0; PREC=0 PK: PACK(PTYPE) %END %ROUTINE DIAG POINTER(%INTEGER LEVEL) %IF PARMTRACE#0 %THEN %START PUSH(RAL(LEVEL),1,CA,LDB<<24!3<<23) PF1(LDB,0,0,0) GRUSE(DR)=0 %FINISH %END %ROUTINE RHEAD(%INTEGER KK) !*********************************************************************** !* COMPILES CODE FOR BLOCK AND ROUTINE ENTRY * !* KK IS THE RT/FN/MAP NAME (=-1 FOR %BEGIN BLOCKS) * !*********************************************************************** %INTEGER W1, W3, INSRN, AT PUSH(LEVELINF, 0, NMAX<<16!N, 0) LEVEL=LEVEL+1 NMDECS(LEVEL)=0; AUXSBASE(LEVEL)=0 NAMES(LEVEL)=-1 ONINF(LEVEL)=0; ONWORD(LEVEL)=0 %IF KK>=0 %THEN %START RLEVEL=RLEVEL+1; RBASE=RLEVEL %FINISH FAULT(34, 0, 0) %IF LEVEL=MAX LEVELS FAULT(105, 0, 0) %IF LEVEL>MAX LEVELS %IF KK>=0 %AND RLEVEL>1 %START;! ROUTINE ENTRY COPY TAG(KK); JJ=K; ! LIST OF JUMPS J=MIDCELL %IF J=0 %AND LEVEL>2 %START;! REPLACE 'NOT USED' BIT REPLACE1(TAGS(KK), FROM1(TAGS(KK))&X'FFFF3FFF') %FINISH ! ! NOW FILL ANY JUMPS TO THIS ROUTINE PLANTED SINCE ! THE ROUTINESPEC WAS COMPILED. SEE ALSO 'RT JUMP' ! %WHILE J#0 %CYCLE POP(J, INSRN, AT, W1) W3=CA-AT W3=W3//2 %IF INSRN>>25=CALL>>1 INSRN=INSRN+W3 PLUG(1, AT, INSRN,4) %REPEAT REPLACE2(TAGS(KK), CA); ! NOTE ADDR FOR FUTURE CALLS %FINISH %IF KK>=0 %AND RLEVEL=1 %THEN DIAG POINTER(LEVEL) %C %AND PSF1(STD,1,12) %IF KK<0 %THEN W3=0 %ELSE W3=KK+1 L(LEVEL)=LINE; M(LEVEL)=W3 FLAG(LEVEL)=PTYPE; ! CURRENT BLOCK TYPE MARKER %END %ROUTINE RDISPLAY(%INTEGER KK) !*********************************************************************** !* SET UP OR COPY THE DISPLAY (A WORD ARRAY CONTAINING COPIES OF * !* LNB FOR THE GLOBAL LEVELS. THE HIGHEST LEVEL ENTRY IS TO THE * !* GLA(PLT) FOR OWNS AND IS ALSO KEPT IN(LNB+4) IN CASE WE WISH * !* TO MOVE TO READ-ONLY PLTS. ON INTERNAL CALLS THE LNB FOR THE * !* NEXT MOST GLOBAL LEVEL IS STACKED AS AN EXTRA PARAMETER * !*********************************************************************** %INTEGER W1,W2,STACK,OP,INC %IF KK>=0 %OR LEVEL=2 %START; ! DISPLAY NEEDED STACK=0; DISPLAY(RLEVEL)=N GRUSE(XNB)=0 GRUSE(CTB)=0; GRUSE(BREG)=0 %IF LEVEL#2 %THEN %START ! PF1(LXN,0,TOS,0) GRUSE(XNB)=4; GRINF1(XNB)=RLEVEL-1; GRAT(XNB)=CA PF1(LD,0,XNB,12); ! COPY PLT DESCRIPTOR DIAG POINTER(LEVEL) PSF1(STD,1,12) W1=RLEVEL-1; W2=DISPLAY(W1) %IF W1=1 %THEN PF1(STXN,0,TOS,0) %AND N=N+4 %ELSE %START %WHILE W1>0 %CYCLE OP=LSS; INC=1 %IF W1>=2 %THEN OP=LSD %AND INC=2 %IF W1>=4 %THEN OP=LSQ %AND INC=4 PF1(OP+STACK,0,XNB,W2) STACK=-32; N=N+4*INC W2=W2+4*INC; W1=W1-INC %REPEAT %FINISH %FINISH %IF STACK#0 %THEN PF1(ST,0,TOS,0); ! ST TOS PF1(STLN,0,TOS,0) N=N+4 %FINISH ! ! IF IN DIAGNOSTIC MODE PLANT CODE TO SAVE THE LINE & ROUTINE NO OF ! THE CALLING ROUTINE AND SET UP THE NEW BLOCK/ROUTINE IDENT NO. ! %IF PARMTRACE#0 %START PF1(LSS,0,PC,4*CONST BTM!X'80000000') %IF PARMOPT#0;! M'IDIA' %IF KK>=0 %OR LEVEL=2 %START %IF PARMOPT#0 %THEN %START PSF1(SLSS,0,LINE) N=N+4 %FINISH %ELSE PSF1(LSS,0,LINE) PF1(ST,0,TOS,0) %FINISH %ELSE %START %IF PARMOPT#0 %THEN %START PSF1(ST,1,N) N=N+4 %FINISH PSF1(LSS,0,LINE) PSF1(ST,1,N) PSF1(LD,1,12); ! UPDATE BND FIELD DIAG POINTER(LEVEL) PSF1(STD,1,12) %FINISH DIAGINF(LEVEL)=N N=N+4 GRUSE(ACCR)=0; ! NEEDED FOR %BEGIN BLOCKS %FINISH %IF PARMOPT#0 %AND KK>=0 %AND LEVEL=2 %START PF1(STSF,0,BREG,0) PF1(STLN,0,TOS,0) PF1(SBB,0,TOS,0) PSF1(CPB,0,N) PPJ(7,13) %FINISH ! ! CLAIM (THE REST OF) THE STACK FRAME ! %IF KK>=0 %OR LEVEL=2 %START SET(RLEVEL)=N<<18!CA NMAX=N PF1(ASF+12*PARMCHK,0,0,0); ! ASF OR LB PPJ(0,4) %IF PARMCHK#0 %FINISH ! %IF KK>=0 %AND PARMCHK#0 %START CHECK STOF; ! CHECK FOR STACK O'FLOW %FINISH %IF PARMDBUG#0 %THEN SET LINE; ! TO CALL DBUG PACKAGE %END %ROUTINE CHECK STOF !*********************************************************************** !* CHECK THE STACK FOR OVERFLOW (LEAVING 4K MARGIN FOR MDIAG * !*********************************************************************** %IF PARMOPT#0 %THEN %START ! ! STSF TOS GET STACK POINTER ! LSS TOS ! USH +14 ! USH -15 LOSE SEGMENT NO ! ICP X'1F800' CHECK WITHIN SEG ADDRESS ! SHIFTED DOWN 1 PLACE ! JCC 2,EXCESS BLKS ! PF1(STSF,0,TOS,0) PF1(LSS,0,TOS,0) PSF1(USH,0,14) PSF1(USH,0,-15) PF1(ICP,0,0,ST LIMIT>>1) PPJ(2,8) %FINISH %END; ! OF ROUTINE RHEAD %ROUTINE CIOCP(%INTEGER N,REG) !*********************************************************************** !* COMPILES A CALL ON IOCP ENTRY POINT NO 'N' * !* 2ND PARAMETER IS ALREAD IN THE ACC WHICH IS 32 BITS * !*********************************************************************** %INTEGER XYNB,OP1,OP2 %IF IOCPDISP=0 %THEN CXREF(IOCPEP,PARMDYNAMIC,2,IOCPDISP) %IF REGISTER(BREG)#0 %THEN BOOT OUT(BREG) %IF REG=ACCR %THEN OP1=LUH %AND OP2=ST %C %ELSE OP1=LDTB %AND OP2=STD PSF1(OP1,0,N) PSF1(PRCL,0,4) PF1(OP2,0,TOS,0) XYNB=SET XORYNB(-1,-1); ! TO PLT PSF1(RALN,0,7) PF1(CALL,2,XYNB,IOCPDISP) FORGET(-1) %END %ROUTINE CUI(%INTEGER CODE) !*********************************************************************** !* COMPILE AN UNCONDITIONAL INSTRN WHEREEVER IT OCCURS * !* CODE=0 UNCONDITIOALLY,=1 AFTER %THEN, =2 AFTER %ELSE * !*********************************************************************** %INTEGER MARKER,J,LNAME,TYPEP,PRECP,GWRDD,LWB,XYNB,ARRP,ALT %SWITCH SW(1:9) REPORTUI=0 ALT=A(P) ->SW(ALT) SW(1): ! (NAME)(APP)(ASSMNT?) P=P+1; MARKER=P+FROMAR2(P) %IF A(MARKER)=1 %THEN %START J=P+2; P=MARKER+2 ASSIGN(A(MARKER+1),J) %FINISH %ELSE %START P=P+2 CNAME(0,0) P=P+1 %FINISH AUI: J=A(P); P=P+1 %IF J=1 %THEN CUI(CODE) %RETURN SW(2): ! -> (NAME)(APP) NMDECS(LEVEL)=NMDECS(LEVEL)!1 CURR INST=1 %IF CODE=0 LNAME=FROM AR2(P+1) J=A(P+3); P=P+4 %IF J=2 %THEN %START; ! SIMPLE LABEL ENTER JUMP(15,LNAME,0) REPORTUI=1 %FINISH %ELSE %START; ! SWITCH LABELS COPY TAG(LNAME) ARRP=ARR GWRDD=SNDISP<<2; ! BYTE DISP OF DESCRIPTOR IN PLT %UNLESS OLDI=LEVEL %AND TYPE=6 %START FAULT(4,0,LNAME); P=P-1; SKIP APP %RETURN %FINISH LWB=FROM2(K); ! GET LOWER BOUND CSEXP(BREG,X'51') %IF ARRP=1 %THEN PSF1(SBB,0,LWB) XYNB=SET XORYNB(-1,-1); ! TO PLT PF1(JUNC,3,XYNB,GWRDD); ! JUMP INDIRECT VIA WORD ARRAY ! OF 32 BIT RELOCATED ADDRESSES REPORTUI=1; FORGET(-1) %FINISH %RETURN SW(3): ! RETURN FAULT(30,0,0) %UNLESS FLAG(LEVEL)&X'3FFF'=X'1000' P=P+1 RET: RT EXIT REPORT UI=1 CURR INST=1 %IF CODE=0 %RETURN SW(4): ! %RESULT(ASSOP)(EXPR) PTYPE=FLAG(LEVEL)&X'3FFF'; UNPACK %IF PTYPE>X'1000' %AND A(P+1)#3 %THEN %START;! ASSOP #'->' %IF A(P+1)=1 %AND NAM#0 %AND A(P+5)=4 %AND A(P+6)=1 %START P=P+7; TYPEP=TYPE; PRECP=PREC; J=P CNAME(4,ACCR) FAULT(81,0,0) %UNLESS A(P)=2; P=P+1 FAULT(83,M(LEVEL)-1,FROMAR2(J)) %C %UNLESS TYPEP=TYPE %AND PRECP=PREC ->RET %FINISH %IF A(P+1)=2 %THEN %START; ! ASSOP='=' P=P+2 %IF NAM#0 %THEN TYPE=1; ! MAPS HAVE INTEGER RESULTS %IF TYPE=5 %THEN %START CSTREXP(0,ACCR) PSF1(LD,1,DISPLAY(RBASE)-8); ! RESULT DESCRPT PF1(IAD,0,PC,SPECIAL CONSTS(2)) PF2(MV,1,1,0,0,UNASSPAT&255) PSF1(LDB,2,DISPLAY(RBASE)-8) COPY DR %FINISH %ELSE %START %IF PREC<5 %THEN PREC=5 %IF NAM=0 %THEN KK=PREC<<4!TYPE %ELSE KK=X'51' CSEXP(ACCR,KK) %FINISH; ->RET %FINISH %FINISH FAULT(31,0,0) P=P+2; SKIP EXP; ! IGNORE SPURIOUS RESULT %RETURN SW(5): ! %MONITOR (AUI) PSF1(LSD,0,0); ! ERR=0 & EXTRA =0 PPJ(0,2); ! TO ERROR ROUTINE P=P+1; ->AUI SW(6): ! %STOP PPJ(0,21) P=P+1 CURR INST=1 %IF CODE=0 REPORTUI=1 %RETURN SW(7): !'%SIGNAL'(EVENT')(N)(OPEXPR) PSF1(PRCL,0,4) PSF1(JLK,0,1); ! STACK DUMMY PC %IF NMDECS(LEVEL)&16 #0 %START;! IN AN 'ON' GROUP %IF FLAG(LEVEL)<=2 %START; ! IN A BEGIN BLOCK PSF1(LD,1,12); ! SO RESET DIAG POINTER DIAGPOINTER(LEVEL-1); ! TO NEXT OUTER BLOCK PSF1(STD,1,12) PF1(STLN,0,TOS,0) %FINISH %ELSE %START; ! 'ON IN A RT/FN/MAP PSF1(LSS,1,0); ! GET PREVIOUS LNB PF1(ST,0,TOS,0); ! AND STACK THAT %FINISH %FINISH %ELSE PF1(STLN,0,TOS,0) GRUSE(ACCR)=0 J=A(P+2); ! EVENT NO FAULT(26,J,0) %UNLESS 1<=J<=15 %IF A(P+3)=1 %START; ! SUBEVENT SPECIFIED P=P+4; CSEXP(ACCR,X'51') PF1(AND,0,0,255) PF1(OR,0,0,256*J) %FINISH %ELSE PF1(LSS,0,0,256*J) PSF1(SLSS,0,0) PF1(ST,0,TOS,0) XYNB=SET XORYNB(-1,-1); ! TO PLT PSF1(RALN,0,9) PF1(CALL,2,XYNB,40) CURR INST=1 %IF CODE=0 REPORTUI=1; %RETURN SW(8): ! %EXIT SW(9): ! %CONTINUE ALT=ALT&7; ! 0 FOR EXIT 1 FOR CONTINUE %IF EXITLAB=0 %THEN FAULT(54+ALT,0,0) %AND %RETURN KK=INTEGER(ADDR(EXITLAB)+4*ALT) ENTER JUMP(15,KK,B'10') REPORTUI=1 CURR INST=1 %IF CODE=0 %END %ROUTINE CIFTHEN(%INTEGER MARKIU,MARKC,MARKUI,MARKE,MARKR,SKIP) !*********************************************************************** !* THIS ROUTINE COMPILES CONDITIONAL EXPRESSIONS.IT REQUIRES THE * !* FOLLOWING PARAMETERS TO BE SET TO THEIR A .R. ENTRY. * !* MARKIU TO THE ENTRY FOR P(%IU) * !* MARKC TO THE ENTRY FOR P(COND) * !* MARKUI TO THE ENTRY FOR (FIRST OCCURRENCE OF) P(UI) * !* MARKE TO THE ENTRY FOR P(ELSE') - =0 FOR BACKWARDS CONDITION * !* MARKR TO ENTRY FOR P(RESTOFIU) - =0 FOR BACKWARDS CONDITION * !*********************************************************************** %INTEGER ALTUI,CCRES,ELRES,THENLAB,ELSELAB,USERLAB,REPORT,START, %C ELSEALT,K %CONSTINTEGER NULL ELSE=4 %SWITCH ESW(1:NULL ELSE) SET LINE %UNLESS SKIP=YES MARKIU=A(MARKIU); ! ALT OF IU 1=%IF,2=%UNLESS PLABEL=PLABEL-1 THENLAB=PLABEL START=0; ! NO START IN CONDITION YET ELSELAB=0; ! MEANS NO ELSE CLAUSE P=MARKC %IF MARKR>0 %AND A(MARKR)<=2 %THEN START=1;! '%START' OR '%THENSTART' %IF MARKE#0 %AND LEVEL<2 %AND START=0 %THEN FAULT(57,0,0) USERLAB=-1 %IF START#0 %THEN ALTUI=0 %ELSE ALTUI=A(MARKUI) %IF ALTUI=2 %AND A(MARKUI+3)=2 %THEN %C USERLAB=FROM AR2(MARKUI+1); ! UI = SIMPLE LABEL %IF 8<=ALTUI<=9 %AND EXITLAB#0 %START; ! VALID EXIT %IF ALTUI=8 %THEN USERLAB=EXITLAB %ELSE USERLAB=CONTLAB %FINISH ! %IF SKIP=YES %THEN %START; ! NO CODE NEEDED %IF START#0 %START P=MARKR+1 CSTART(2,1); ! NO CODE MARKE=P %FINISH CCRES=1; ! NO CODE FOR ELSE ->ELSE %FINISH ! %IF USERLAB>=0 %THEN %START; ! FIRST UI IS'->'