!QIN; %MAINEP ICL9CEZIMP %TRUSTEDPROGRAM %BEGIN %INTEGER I, J, K ! PRODUCED BY OLDPS FROM NRIMPPS3 ON 06/04/78 %CONSTBYTEINTEGERARRAY CLETT(0: 478)= 1, 40, 1, 41, 1, 44, 2, 201, 198, 6, 213, 206, 204, 197, 211, 211, 5, 215, 200, 201, 204, 197, 5, 213, 206, 212, 201, 204, 4, 210, 197, 193, 204, 7, 201, 206, 212, 197, 199, 197, 210, 8, 204, 207, 206, 199, 210, 197, 193, 204, 4, 204, 207, 206, 199, 11, 194, 217, 212, 197, 201, 206, 212, 197, 199, 197, 210, 6, 211, 212, 210, 201, 206, 199, 11, 200, 193, 204, 198, 201, 206, 212, 197, 199, 197, 210, 7, 210, 207, 213, 212, 201, 206, 197, 2, 198, 206, 3, 205, 193, 208, 6, 210, 197, 195, 207, 210, 196, 4, 206, 193, 205, 197, 5, 193, 210, 210, 193, 217, 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, 4, 211, 208, 197, 195, 3, 193, 206, 196, 2, 207, 210, 1, 58, 6, 206, 207, 210, 205, 193, 204, 3, 207, 215, 206, 8, 197, 216, 212, 197, 210, 206, 193, 204, 9, 197, 216, 212, 210, 201, 206, 211, 201, 195, 5, 195, 207, 206, 211, 212, 1, 61, 5, 197, 214, 197, 206, 212, 2, 62, 61, 1, 62, 1, 35, 2, 60, 61, 1, 60, 2, 92, 61, 2, 45, 62, 5, 211, 212, 193, 210, 212, 9, 212, 200, 197, 206, 211, 212, 193, 210, 212, 4, 212, 200, 197, 206, 5, 195, 217, 195, 204, 197, 9, 212, 200, 197, 206, 195, 217, 195, 204, 197, 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, 2, 42, 61, 1, 42, 4, 80, 85, 84, 95, 5, 67, 78, 79, 80, 95, 2, 204, 61, 4, 40, 196, 210, 43, 2, 196, 210, 1, 194, 1, 43, 1, 45, 3, 212, 207, 211, 3, 204, 206, 194, 3, 216, 206, 194, 2, 208, 195, 3, 195, 212, 194, 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, 6, 198, 201, 206, 201, 211, 200, 6, 210, 197, 208, 197, 193, 212, 3, 197, 206, 196, 5, 210, 197, 193, 204, 211, 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; %CONSTINTEGERARRAY SYMBOL(1300: 2182)= 1312, 1305, 1001, 1326, 1793, 1308, 1003, 1020, 1312, 0, 1312, 2, 1319, 1319, 1010, 1028, 1300, 1011, 1319, 1326, 1324, 1026, 1300, 999, 1326, 1000, 1334, 1332, 0, 1312, 1334, 2, 1334, 1000, 1341, 1339, 4, 1312, 999, 1341, 1000, 1346, 1344, 6, 1346, 9, 1351, 1349, 16, 1351, 22, 1358, 1356, 4, 1001, 999, 1358, 1000, 1365, 1361, 28, 1363, 33, 1365, 41, 1380, 1368, 33, 1370, 28, 1373, 50, 1358, 1375, 55, 1378, 67, 1895, 1380, 74, 1387, 1383, 86, 1387, 1031, 1365, 1387, 1392, 1390, 94, 1392, 97, 1398, 1396, 1387, 1416, 1398, 1421, 1411, 1402, 1365, 1392, 1406, 101, 1411, 108, 1409, 86, 1416, 1411, 108, 1416, 1414, 113, 1416, 1000, 1421, 1419, 108, 1421, 1000, 1428, 1424, 119, 1426, 108, 1428, 1000, 1438, 1436, 0, 1398, 1001, 1351, 1438, 2, 1438, 1000, 1447, 1445, 1030, 1398, 1001, 1351, 1438, 1447, 1000, 1458, 1451, 129, 1016, 1453, 139, 1456, 146, 1018, 1458, 1016, 1463, 1461, 153, 1463, 1000, 1487, 1471, 153, 1001, 0, 1846, 1839, 2, 1480, 160, 1010, 1001, 1787, 1011, 0, 1001, 2, 1487, 1010, 1558, 1011, 0, 1001, 2, 1498, 1493, 1312, 1722, 1312, 1498, 1498, 0, 1487, 1505, 2, 1505, 1503, 1032, 1722, 1312, 1505, 1000, 1516, 1510, 165, 1487, 1516, 1514, 169, 1487, 1523, 1516, 1000, 1523, 1521, 165, 1487, 1516, 1523, 1000, 1530, 1528, 169, 1487, 1523, 1530, 1000, 1538, 1534, 1033, 1312, 1536, 172, 1538, 1000, 1544, 1542, 160, 1008, 1544, 1015, 1549, 1547, 50, 1549, 174, 1558, 1556, 4, 1312, 172, 1312, 1549, 1558, 1000, 1567, 1563, 1421, 1001, 1351, 1567, 113, 1458, 1567, 1573, 1573, 1001, 1351, 1801, 1573, 1579, 1577, 4, 1567, 1579, 1000, 1595, 1589, 1421, 1010, 1001, 1351, 1811, 1011, 1595, 1006, 1595, 113, 1458, 1001, 1668, 1642, 1606, 1604, 4, 1010, 1001, 1351, 1811, 1011, 1595, 1606, 1000, 1615, 1609, 181, 1611, 185, 1613, 194, 1615, 204, 1642, 1619, 1365, 1579, 1630, 101, 1421, 1010, 1001, 1351, 1011, 0, 1001, 2, 1006, 1642, 101, 113, 1458, 1010, 1001, 1668, 1011, 0, 1001, 2, 1006, 1651, 1649, 210, 1029, 1003, 1661, 1651, 1651, 1000, 1661, 1659, 4, 1012, 1029, 1003, 1661, 999, 1661, 1000, 1668, 1666, 0, 1005, 2, 1668, 1000, 1678, 1678, 0, 1029, 1002, 172, 1029, 1002, 1678, 2, 1689, 1687, 4, 1029, 1002, 172, 1029, 1002, 1678, 1689, 1000, 1696, 1694, 4, 1009, 1689, 1696, 1000, 1701, 1699, 212, 1701, 1000, 1707, 1705, 4, 1312, 1707, 1000, 1722, 1720, 4, 1001, 1351, 0, 1029, 1002, 172, 1029, 1002, 2, 1707, 1722, 1000, 1739, 1725, 210, 1727, 218, 1729, 221, 1731, 223, 1733, 225, 1735, 228, 1737, 230, 1739, 233, 1754, 1742, 1019, 1744, 1006, 1749, 1341, 1487, 1505, 1006, 1754, 1346, 1487, 1505, 1006, 1765, 1757, 236, 1759, 242, 1765, 252, 1010, 2030, 1011, 1779, 1773, 1768, 257, 1770, 263, 1773, 252, 2030, 1779, 1777, 165, 2030, 1779, 1000, 1787, 1782, 273, 1785, 283, 2030, 1787, 1000, 1793, 1791, 288, 1001, 1793, 1000, 1801, 1799, 288, 1001, 1326, 1793, 1801, 1000, 1811, 1804, 1668, 1811, 0, 1312, 172, 1312, 1549, 2, 1818, 1816, 210, 1029, 1003, 1818, 1000, 1828, 1822, 290, 1013, 1824, 185, 1826, 297, 1828, 1000, 1839, 1837, 1001, 210, 1312, 4, 1312, 4, 1312, 1839, 1000, 1846, 1844, 4, 1846, 1839, 1846, 1000, 1886, 1852, 1365, 1421, 1001, 1351, 1859, 1365, 113, 1001, 1351, 1668, 1886, 1865, 101, 1411, 108, 1001, 1351, 1874, 101, 1010, 1001, 1351, 1011, 0, 1001, 2, 1886, 101, 113, 1010, 1001, 1351, 1668, 1886, 1011, 0, 1001, 2, 1895, 1893, 4, 1001, 1351, 1668, 999, 1895, 1000, 1902, 1900, 0, 1009, 2, 1902, 1000, 1920, 1906, 305, 1001, 1909, 308, 1001, 1912, 310, 1002, 1915, 1022, 1920, 1920, 315, 1009, 4, 1009, 1934, 1924, 1023, 1934, 1929, 1024, 321, 1973, 1978, 1934, 1025, 1005, 4, 1957, 1957, 1939, 228, 1001, 221, 1941, 2006, 1946, 0, 2006, 1995, 2, 1950, 324, 2006, 2, 1955, 0, 329, 1995, 2, 1957, 332, 1973, 1962, 228, 1001, 221, 1964, 2006, 1969, 0, 329, 1995, 2, 1973, 324, 1005, 2, 1978, 1976, 329, 1978, 1005, 1986, 1984, 4, 1005, 4, 1005, 1986, 1000, 1995, 1990, 334, 1005, 1993, 336, 1005, 1995, 1000, 2001, 1999, 334, 332, 2001, 1000, 2006, 2004, 210, 2006, 1000, 2021, 2011, 2001, 1029, 1003, 2014, 1001, 1986, 2019, 0, 2021, 1986, 2, 2021, 338, 2030, 2024, 342, 2026, 346, 2028, 350, 2030, 353, 2061, 2039, 1010, 1001, 1326, 1793, 1011, 1530, 1773, 2043, 233, 1001, 1326, 2045, 357, 2049, 364, 1033, 1312, 2052, 371, 1773, 2054, 379, 2059, 384, 1696, 1009, 1701, 2061, 391, 2183, 2068, 1027, 1010, 2030, 1011, 1739, 2070, 1007, 2078, 1341, 1010, 1487, 1505, 1011, 1754, 1006, 2082, 396, 1779, 1006, 2086, 257, 1828, 1006, 2089, 403, 1006, 2097, 1346, 1010, 1487, 1505, 1011, 1765, 1006, 2103, 1031, 1008, 1365, 1558, 1006, 2107, 410, 1447, 1006, 2111, 101, 1463, 1006, 2120, 1010, 1818, 1380, 1011, 1538, 1001, 1428, 1006, 2123, 1606, 1615, 2127, 414, 1544, 1006, 2131, 420, 1015, 1006, 2139, 426, 1021, 1696, 1009, 1689, 236, 1006, 2152, 429, 1001, 1351, 0, 1029, 1002, 172, 1029, 1002, 2, 1707, 1006, 2156, 436, 1006, 1017, 2161, 160, 1001, 1428, 1006, 2166, 441, 108, 1001, 1006, 2170, 308, 1902, 1006, 2173, 449, 1006, 2177, 464, 1001, 1006, 2181, 471, 1003, 1006, 2183, 1006; %CONSTINTEGER SS= 2061 ! %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(1:126)=%C 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'; %CONSTINTEGERARRAY TSNAME (0:61)=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'1000',X'31',X'52',X'51', X'61',X'72',X'61',X'72',X'51',X'62',X'1051',X'41'; ! %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 ! ! 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' %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' %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,X'78',X'7C',X'7E',0,48,0,X'7A'; ! %CONSTSTRING(8)MDEP='S#NDIAG' %CONSTSTRING(8)IOCPEP='S#IOCP'; ! EP FOR IOCP %CONSTSTRING(8)SIGEP='S#SIGNAL'; ! EP FOR SIGNAL %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, DFHEAD, CONSTHOLE, %C DUMMY FORMAT, P1SIZE, LEVELINF, IOCPDISP ! %INTEGER ASL, NNAMES, ARSIZE, CABUF, PPCURR, CONSTLIMIT, OLDLINE, %C LINE, LENGTH, NEXTP, SNUM, RLEVEL, NMAX, USTPTR, PLABEL,%C LEVEL, CA, RR, LASTNAME, CDCOUNT, ASL CUR BTM ! %INTEGER FAULTY, HIT, INHCODE, IMPS, TTOPUT, LIST, PARMDIAG, %C WARNFLAG, PARMTRACE, PARMLINE, PARMOPT, CTYPE, DCOMP, %C CPRMODE, PARMCHK, PRINTMAP, PARMARR, ALLLONG,%C COMPILER, LAST INST, SMAP, STACK, AUXST, SIGREFDIS, BFFLAG ! %INTEGER MASK, RBASE, N, FREE FORMAT, %C P, Q, R, S, T, 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 ! %INTEGER MAX ULAB, XLABEL, SFLABEL %LONGREAL CVALUE, IMAX, CTIME %STRING(31)MAINEP %RECORDFORMAT LISTF(%INTEGER S1,S2,S3,LINK) %RECORDNAME LCELL(LISTF) %INTEGER LOGEPDISP,EXPEPDISP ! %SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N) %BEGIN FILE ADDR=COMREG(46); ! SOURCE FILE IF CLEAN %IF -1<=FILE ADDR<=0 %THEN %START FILE SIZE=32000*(FILE ADDR+2) %FINISH %ELSE %START FILE PTR=FILE ADDR+INTEGER(FILE ADDR+4) FILE END=FILE ADDR+INTEGER(FILE ADDR) FILE SIZE=INTEGER(FILE ADDR) %FINISH %IF FILE ADDR=-1 %THEN FILE ADDR=0 ARSIZE=INTEGER(COMREG(14)+8)-24*4096-300 NNAMES=255 %IF FILESIZE>10000 %THEN NNAMES=511 %IF FILESIZE>32000 %THEN NNAMES=1023 %IF FILESIZE>256*1024 %THEN NNAMES=2047 ASL=3*NNAMES %END %BYTEINTEGERARRAYFORMAT AF(0:ARSIZE) %BYTEINTEGERARRAYNAME A %RECORDARRAY ASLIST(0:ASL)(LISTF) %INTEGERARRAY WORD, TAGS(0:NNAMES) !%ROUTINESPEC PRHEX(%INTEGER VALUE, PLACES) %LONGREALFNSPEC FROMAR8(%INTEGER PTR) %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, VALUE) %ROUTINESPEC PRINT NAME(%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) %INTEGERFNSPEC FIND3(%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) %ROUTINESPEC MESSAGE(%INTEGER N) %SYSTEMROUTINESPEC LPUT(%INTEGER A, B, C, D) %SYSTEMLONGREALFNSPEC CPUTIME !*DELSTART %SYSTEMROUTINESPEC NCODE(%INTEGER START, FINISH, CA) %ROUTINESPEC PRHEX(%INTEGER VALUE,PLACES) %ROUTINESPEC CHECK ASL !*DELEND ! START OF COMPILATION A==ARRAY(COMREG(14)+24*4096, 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) %ROUTINESPEC COMPARE %ROUTINESPEC PNAME(%INTEGER MODE) %ROUTINESPEC CONST(%INTEGER MODE) %ROUTINESPEC TEXTTEXT(%INTEGER EBCDIC) %INTEGER CCSIZE,DSIZE,NEXT CCSIZE=600; DSIZE=7*NNAMES %INTEGERARRAY DISPLAY(0:MAXLEVELS) %BYTEINTEGERARRAY TLINE(-60:161),CC(0:CCSIZE),LETT(0:DSIZE+20) %CONSTBYTEINTEGERARRAY ILETT(0: 491)= 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', 10,'F','R','O','M','S','T','R','I', 'N','G', 6,'R','E','C','O','R','D', 5,'A','R','R','A','Y', 10, 'S','E','T','M','A','R','G','I','N','S',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',255; IMAX=(-1)>>1;PLABEL=24999 LETT(0)=0 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 XLABEL=19999; ! FOR EXIT STATEMENTS CABUF=0; PPCURR=0; OLDLINE=0; COMPILER=0 LINE=0; RLEVEL=0; NMAX=0; USTPTR=0 LEVEL=0; CA=0; LASTAT=0 FAULTY=0; WARNFLAG=0; ALLLONG=0; INHCODE=0 DCOMP=0; BFFLAG=0; CPRMODE=0; PRINT MAP=0 NEXT=1; LDPTR=0 IOCPDISP=0; CREFHEAD=0; AUXST=0 RBASE=10; LOGEPDISP=0; EXPEPDISP=0; STRLINK=0 RECTB=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 %IF I&(128<<8)#0 %THEN PRINTMAP=1 %IF I&64=64 %THEN PARMTRACE=0 %AND PARMDIAG=0 FREE FORMAT=I&X'80000' STACK=I>>3&1 SMAP=I>>7&1 TTOPUT=I>>21&1 %IF I&(1<<16)#0 %THEN %START PARMARR=0; PARMOPT=0 PARMLINE=0; PARMCHK=0; PARMDIAG=0 %FINISH %IF PARMOPT#0 %THEN PARMTRACE=1 IMPS=I>>23&1; ! BIT SET IF IMPS REQUESTED IMPS=1; ! FOR TESTING NEWLINES(3); SPACES(14) PRINTSTRING('E.R.C.C. NRIMP') %IF IMPS#0 %THEN PRINTSYMBOL('S') PRINTSTRING(' COMPILER RELEASE 7 VERSION 10NOV78') NEWLINES(3) WRITE(NNAMES,5); WRITE(ASL,5) NEWLINE 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 ! ! NOW DECLARE THE SPECIAL NAMES WHICH ARE IN ARRAY ILETT. ! K=0; NEXT=1 I=ILETT(0) %WHILE I<255 %CYCLE %CYCLE J=1,1,I CC(J)=ILETT(K+J) %REPEAT; CC(J+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 DFHEAD=0 PUSH(DFHEAD,0,0,0) PUSH(DUMMY FORMAT,0,0,DFHEAD); ! 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) P=SS; WARNFLAG=0 RR=R R=R+3 OLDLINE=LINE A(R)=LINE>>8 A(R+1)=LINE&255 R=R+2 COMPARE FAULT(102, 0) %IF R>ARSIZE %IF HIT=0 %THEN %START FAULT(100,ADDR(CC(0))) R=RR %FINISH %ELSE %START %IF A(RR+5)=COMMALT %THEN R=RR %ELSE %START I=R-RR A(RR)=I>>16 A(RR+1)=I>>8&255 A(RR+2)=I&255 %IF A(RR+5)=DECALT %AND LEVEL>=2 %THEN %START TO AR4(DISPLAY(LEVEL),RR) DISPLAY(LEVEL)=RR+6 %FINISH !*DELSTART %IF SMAP#0 %THEN %START NEWLINE; WRITE(LINE, 5) WRITE(RR,5); NEWLINE; J=0 %CYCLE I=RR, 1, R-1 WRITE(A(I), 5) J=J+1 %IF J>=20 %THEN NEWLINE %AND J=0 %REPEAT NEWLINE %FINISH !*DELEND %EXIT %IF A(RR+5)=ENDALT %AND 1<=A(RR+6)<=2;! ENDOF PROG OR FILE %IF LEVEL=0 %THEN FAULT(14, 0) %AND %EXIT %FINISH %FINISH %REPEAT TO AR8(R,0); R=R+8 P1SIZE=R !QOUT %CYCLE I=0,1,NEXT !QOUT A(R+I)=LETT(I) !QOUT %REPEAT !QIN; *LDTB_X'18000000' !QIN; *LDB_NEXT !QIN; *LDA_LETT+4 !QIN; *CYD_0 !QIN; *LDA_A+4 !QIN; *INCA_R !QIN; *MV_%L=%DR DICTBASE=ADDR(A(R)) R=R+NEXT+1 ->BEND %ROUTINE READ LINE(%INTEGER MODE,CHAR) %ROUTINESPEC GET LINE %INTEGER DEL, LL, LP LL=0; LP=0; Q=1 LENGTH=0; DEL=0 NEXT: LP=LP+1 %IF LP>LL %THEN GET LINE %AND LP=1 I=TLINE(LP) %IF MODE=0 %THEN %START %IF I='%' %THEN DEL=128 %AND ->NEXT DEL=0 %UNLESS 'A'<=I<='Z' ->NEXT %IF I=' ' I=I!DEL 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 %IF CC(LENGTH-1)='C'+128 %THEN LENGTH=LENGTH-2 %AND ->NEXT FAULT(101,0) %IF LENGTH>CCSIZE %RETURN %ROUTINE GET LINE %SYSTEMROUTINESPEC IOCP(%INTEGER A,B) %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)=K LL=LL+1 %REPEAT %FINISH %ELSE %START !QOUT %MONITOR 9 %IF FILEPTR>=FILE END !QIN; %SIGNAL %EVENT 9,1 %IF FILEPTR>=FILE END %UNTIL K=NL %OR K=0 %CYCLE K=BYTE INTEGER(FILEPTR); ! NEXT CHAR FROM SORCE FILE FILE PTR=FILE PTR+1 TLINE(LL+1)=K LL=LL+1 %REPEAT %FINISH %IF MODE=0 %AND LL=1 %THEN GET LINE %AND %RETURN LINE=LINE+1 %UNLESS MODE=0 %AND LENGTH>0 %IF LIST#0 %THEN %START %IF MODE=0 %AND LENGTH>0 %THEN %C PRINTSTRING(' C') %ELSE WRITE(LINE, 5) ! SPACES(4*LEVEL-MODE) %CYCLE K=0,-1,1-4*LEVEL TLINE(K)=' ' %REPEAT %IF MODE#0 %THEN TLINE(K)=M'''' K=K-1 TLINE(K)=LL+4*LEVEL IOCP(15,ADDR(TLINE(K))) %FINISH %IF FREE FORMAT=0 %AND LL>73 %THEN TLINE(73)=10 %AND LL=73 %END %END %ROUTINE COMPARE %INTEGER I, J, ITEM, RA, RL, RP, RQ, RR, RS, MARKER, ALT, PP, SSL %SWITCH BIP(999:1033) RP=SYMBOL(P) RL=LEVEL P=P+1 PP=P; ->COMM; ! ROUTINE REALLY STARTS HERE BIP(999): ! REPEATED PHRASE A(RR)=ALT; P=PP COMM: RQ=Q; RR=R; ! RESET VALUES OF LINE&AR PTRS SSL=STRLINK; ! SAVE STRING LINK ALT=1; ! FIRST ALTERNATIVE TO BE TRIED RA=SYMBOL(P); RS=P; ! RA TO NEXT PHRASE ALTERNATIVE UPR: R=R+1 SUCC: ! SUCCESS ON TO NEXT ITEM RS=RS+1; ! RS=NEXT ALTERNATIVE MEANS THAT ! THIS ALT HAS BEEN COMPLETED SO ! EXIT WITH HIT=1 %IF RS#RA %THEN ->NEXTBR BIP(1000): ! NULL ALWAYS LAST & OK A(RR)=ALT HIT=1 %RETURN NEXTBR: ITEM=SYMBOL(RS); ! NEXT BRICK IN THE CURRENT ALT ! WRITE(ITEM,5) %IF PRINTMAP#0 %IF ITEM>=1300 %START; ! BRICK IS A PHRASE TYPE P=ITEM; COMPARE %IF HIT=0 %THEN ->FAIL %ELSE ->SUCC %FINISH I=CC(Q); ! OBTAIN CURRENT CHARACTER ->BIP(ITEM) %IF ITEM>=999; ! BRICK IS BUILT IN PHRASE ! BRICK IS LITERAL ->FAIL %UNLESS I=CLETT(ITEM+1) Q=Q+1 K=CLETT(ITEM) K=K+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 ->SUCC; ! MATCHED SUCCESSFULLY FAIL: ! FAILURE - NOTE POSITION REACHD %IF RA=RP %START; ! TOTAL FAILURE NO ALT TO TRY LEVEL=RL; HIT=0; %RETURN %FINISH QMAX=Q %IF Q>QMAX Q=RQ; R=RR; ! RESET LINE AND A.R. POINTERS STRLINK=SSL RS=RA; ALT=ALT+1; ! MOVE TO NEXT ALT OF PHRASE RA=SYMBOL(RA); ->UPR BIP(1001): ! PHRASE NAME BIP(1004): ! PHRASE OLDNAME ->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(1005): ! PHRASE N ->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 ->SUCC %IF I=NL ->FAIL %UNLESS I=';' Q=Q+1; ->SUCC BIP(1007): ! PHRASE COMMENT TEXT ->TX %IF I=';' %OR I=NL ->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); I=CC(Q) Q=Q+1 %AND I=CC(Q) %WHILE NL#I#';' TX: Q=Q+1 %IF I=';' ->SUCC BIP(1008): ! PHRASE BIGHOLE TO AR4(R,0) R=R+4; ->SUCC BIP(1009): ! PHRASE N255 ->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? %WHILE I=NL %THEN READLINE(0,0) %AND RQ=1 %AND I=CC(Q) ->SUCC BIP(1013): ! PHRASE CHECKIMPS ->FAIL %UNLESS IMPS=1; ->SUCC BIP(1014): ! PHRASE WARN %MONITOR; %STOP BIP(1015): ! PHRASE DOWN=NEW TEXT LEVEL LEVEL=LEVEL+1 TO AR4(R,0) DISPLAY(LEVEL)=R R=R+4 ->SUCC BIP(1016): ! PHRASE UP 1 TEXTUAL LEVEL DISPLAY(LEVEL)=0 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 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=1,1,3 %IF OPC(I)=S %THEN A(R)=2*I %AND ->UPR %REPEAT; ->FAIL BIP(1026): ! P(OP)=+,-,&,****,**,*,!!,!, ! //,/,>>,<<,.,\\,\; ->FAIL %UNLESS 32>(I-32)&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 ->SUCC Q=Q+1; A(R)=14; ->SUCC %FINISH ->FAIL BIP(1027): ! PHRASE CHECK UI ->SUCC %IF TRTAB(I)=2 %OR I='-' ->SUCC %IF X'80000000'>>(I&31)&X'04043000'#0 ->FAIL BIP(1028): ! P(+')=+,-,\,0 %IF I='\' %THEN A(R)=3 %AND Q=Q+1 %AND ->UPR BIP(1029): ! P(PLUS')=+,-,0 %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)=1032-ITEM; ->UPR 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. ! %IF I=')' %THEN ->FAIL %IF I=',' %THEN A(R)=1 %AND Q=Q+1 %ELSE A(R)=2 ->UPR BIP(1031): ! PHRASE CHECKTYPE IE ENSURE ! FIRST LETTER IS(B,H,I,L,R,S) & ! 3RD LETTER IS (A,L,N,R,T) ->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 CHECK COMPARATOR ->FAIL %UNLESS 32>(I&31)&X'1004000E'#0 ->SUCC BIP(1033): ! P(ASSOP)- ==,=,<-,-> %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 %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 !QIN;%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 !QOUT %CYCLE !QOUT Q=Q+1 !QOUT I=CC(Q) !QOUT %EXIT %IF TRTAB(I)=0 !QOUT JJ=JJ+HASH(T) %IF T<=7 !QOUT T=T+1 !QOUT LETT(NEXT+T)=I !QOUT %REPEAT CYC: !QIN; *LB_Q !QIN; *ADB_1 !QIN; *STB_Q !QIN; *LB_(CC+%B) !QIN; *LSS_(TRTAB+%B) !QIN; *JAT_4, !QIN; *STB_I !QIN; *LSS_%B; ! I TO ACC !QIN; *LB_T !QIN; *CPB_7 !QIN; *JCC_2, !QIN; *IMY_(HASH+%B) !QIN; *IAD_JJ !QIN; *ST_JJ SKIP: !QIN; *ADB_1 !QIN; *STB_T !QIN; *LSS_I !QIN; *ADB_NEXT !QIN; *ST_(LETT+%B) !QIN; *J_ EXIT: LETT(NEXT)=T; ! INSERT LENGTH S=T+1 FAULT(103,0) %IF NEXT+S>DSIZE;!DICTIONARY OVERFLOW JJ=(JJ+113*T)&NNAMES !QOUT %CYCLE KK=JJ, 1, NNAMES !QOUT LL=WORD(KK) !QOUT ->HOLE %IF LL=0; ! NAME NOT KNOWN !QOUT ->FND %IF STRING(ADDR(LETT(NEXT)))=STRING(ADDR(LETT(LL))) !QOUT %REPEAT !QOUT %CYCLE KK=0,1,JJ !QOUT LL=WORD(KK) !QOUT ->HOLE %IF LL=0; ! NAME NOT KNOWN !QOUT ->FND %IF STRING(ADDR(LETT(NEXT)))=STRING(ADDR(LETT(LL))) !QOUT %REPEAT !QIN; *LDTB_X'18000000' !QIN; *LDB_S !QIN; *LDA_LETT+4 !QIN; *STD_DRDES !QIN; *INCA_NEXT !QIN; *STD_ACCDES !QIN; *LB_JJ CYC1: !QIN; *STB_KK !QIN; *LB_(WORD+%B) !QIN; *JAT_12, !QIN; *LSD_ACCDES !QIN; *LD_DRDES !QIN; *INCA_%B !QIN; *CPS_%L=%DR !QIN; *JCC_8, !QIN; *LB_KK !QIN; *CPIB_NNAMES !QIN; *JCC_7, !QIN; *LB_0 CYC2: !QIN; *STB_KK !QIN; *LB_(WORD+%B) !QIN; *JAT_12, !QIN; *LSD_ACCDES !QIN; *LD_DRDES !QIN; *INCA_%B !QIN; *CPS_%L=%DR !QIN; *JCC_8, !QIN; *LB_KK !QIN; *CPIB_JJ !QIN; *JCC_7, FAULT(104, 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 !QOUT%LONGREAL X,CVALUE,DUMMY !QOUT%CONSTLONGREAL TEN=10 !QIN;%LONGLONGREAL X,CVALUE,DUMMY !QIN;%CONSTLONGLONGREAL TEN=R'41A00000000000000000000000000000' CPREC=5; RR=R; R=R+1 DOTSEEN=0; HIT=0 CVALUE=0; DUMMY=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 ->STR %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' ->EBCD %IF FS='E' %IF FS='C' %THEN EBCDIC=1 %AND ->MULT %IF FS='D' %AND MODE=0 %THEN CPREC=7 %AND ->N Q=Q-2; %RETURN NOTQUOTE: ! CHECK FOR E"...." %RETURN %UNLESS FS='E' %AND CC(Q+1)=M'"' Q=Q+2 EBCD: EBCDIC=1; Q=Q-1; I=CC(Q) STR: A(RR)=5 TEXTTEXT(EBCDIC) %IF A(RR+5)>1-EBCDIC %THEN CTYPE=5 %AND %RETURN R=RR+1 %IF A(R+4)=0 %THEN S=0 %ELSE S=A(R+5) ->IEND STR2: ! DOUBLE QUOTED STRING A(RR)=5; TEXTTEXT(0) CTYPE=5; %RETURN HEX: T=0; ! HEX CONSTANTS %CYCLE I=CC(Q); Q=Q+1 %EXIT %IF I=M'''' T=T+1 %RETURN %UNLESS ('0'<=I<='9' %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 TOAR4(R,S); 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' 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 %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>=5 %IF EBCDIC#0 %THEN I=ITOETAB(I) S=S<<8!I %REPEAT ->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 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 ->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 S=FROM AR4(R+1)*Z %IF S=-99 %THEN CVALUE=0 %ELSE %START !QIN; *MPSR_X'8080'; ! MASK OUT REAL OVERFLOW %WHILE S>0 %CYCLE S=S-1 CVALUE=CVALUE*TEN !QIN; *JAT_15, %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 !QIN; *LSD_CVALUE !QIN; *AND_X'FF00000000000000' !QIN; *SLSD_CVALUE+8 !QIN; *AND_X'0080000000000000' !QIN; *LUH_%TOS !QIN; *RAD_CVALUE !QIN; *ST_CVALUE %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) %INTEGER J, QU, II I=CC(Q) S=R+4; R=R+5; HIT=0 %RETURN %UNLESS I=M'''' %OR I=34;! FAIL UNLESS INITIAL QUOTE QU=I 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) %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, 0) I=0 NEWLINE PRINTCH(13) %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, GRINF, OLINK(0:7) %BYTEINTEGERARRAY CODE, GLABUF(0:268) %INTEGERARRAY PLABS, DESADS, PLINK(0:31), DVHEADS(0:12) %INTEGERARRAY SET, STACKBASE, RAL, FLAG, L, M, NMDECS, ONWORD, ONINF,%C CYCLE, JUMP, LABEL, JROUND, DIAGINF, DISPLAY, SBR, %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 PCLOD(%INTEGER FROM, TO) %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) %ROUTINESPEC DUMP CONSTS %ROUTINESPEC PLANT(%INTEGER VALUE) %ROUTINESPEC PLUG(%INTEGER I, J, K, BYTES) %ROUTINESPEC CODEOUT %ROUTINESPEC PROLOGUE %ROUTINESPEC EPILOGUE %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; GRINF(I)=0 %REPEAT %CYCLE I=0, 1, MAXLEVELS SET(I)=0; STACKBASE(I)=0; RAL(I)=0 CYCLE(I)=0; JUMP(I)=0; JROUND(I)=0 LABEL(I)=0; FLAG(I)=0; SBR(I)=0 L(I)=0; M(I)=0; DIAGINF(I)=0 DISPLAY(I)=0; ONWORD(I)=0; ONINF(I)=0 DVHEADS(I)=0 %IF I<=12 NAMES(I)=-1 %CYCLE J=0,1,4 AVL WSP(J,I)=0 %REPEAT %REPEAT CTABLE==ARRAY(ADDR(ASLIST(1)),CF) CONST HOLE=0 DCOMP=PRINTMAP LINE=0 PROLOGUE NEXTP=1; LEVEL=1; STMTS=0 RLEVEL=0; RBASE=0 %CYCLE !*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) %EXIT %IF LINE=0 STMTS=STMTS+1 CSS(I+5) ! CHECK ASL %IF LINE&3=0 %REPEAT LINE=99999 EPILOGUE LOAD DATA %STOP %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!1<<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 %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 * !*********************************************************************** CODE(PPCURR)<-HALFWORD>>8 CODE(PPCURR+1)<-HALFWORD PPCURR=PPCURR+2 CA=CA+2 CODEOUT %IF PPCURR>=256 %END %ROUTINE PCONST(%INTEGER WORD) !*********************************************************************** !* ADD A WORD OF BINARY TO THE BUFFER * !*********************************************************************** %INTEGER I %CYCLE I=24,-8,0 CODE(PPCURR)=WORD>>I&255 PPCURR=PPCURR+1 %REPEAT 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 CODE(PPCURR)=OPCODE!K>>1 CODE(PPCURR+1)=(K&1)<<7!N&127 CA=CA+2 PPCURR=PPCURR+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) * !*********************************************************************** ! ABORT %UNLESS 0<=KP<=3 %AND 0<=KPP<=7 %AND OPCODE&1=0 %IF KPP=PC %THEN %START %IF N<0 %THEN N=N&X'7FFFFFFF' %AND NOTE CREF(CA) N=(N-CA)//2 %FINISH %IF KPP=LNB %OR KPP=XNB %OR KPP=CTB %THEN N=N//4 CODE(PPCURR)=OPCODE!1 CODE(PPCURR+1)=X'80'!KP<<5!KPP<<2!(N>>16&3) CA=CA+2; PPCURR=PPCURR+2 %IF KPP<=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 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 CODE(PPCURR)=OPCODE!KP>>1 CODE(PPCURR+1)=(KP&1)<<7!(N&127) %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) %IF KPP<=5 %THEN %START CODE(PPCURR+2)=N>>8&255 CODE(PPCURR+3)=N&255 INC=4 %FINISH %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 * !*********************************************************************** %RECORDNAME CELL (LISTF) 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 PCLOD(%INTEGER FROM, TO) !*********************************************************************** !* PLANT A SERIES OF INTRUNS FROM ARRAY FIXED CODE * !*********************************************************************** %INTEGER I !%CONSTINTEGERARRAY FIXED CODE(0:127) ! %CYCLE I=FROM, 1, TO ! PCONST(FIXED CODE(I)) ! %REPEAT %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 RELAD>=0 %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 STORE CONST (K,4,ADDR(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:5) = X'40800000',0, X'41100000',0, 1,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 %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 %IF PARMOPT#0 %THEN ->SKIP K=CONST BTM; ! AFTER STRINGS IN CTABLE %IF L=4 %THEN %START %WHILE K=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)=C2 %C %AND CTABLE(CONSTPTR+3)=C4 CONST PTR=CONST PTR+LP %IF CONST PTR>CONST LIMIT %THEN FAULT(107,0) %END %ROUTINE GET ENV(%INTEGERNAME HEAD) !*********************************************************************** !* SAVE A COPY OF THE REGISTER STATE FOR FUTURE REFERENCE * !*********************************************************************** %INTEGER I %CYCLE I=0, 1, 7 PUSH(HEAD, GRINF(I), GRAT(I), I<<8!GRUSE(I)) %C %IF GRUSE(I)#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 GRINF(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 GRINF(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 IS IN ACC. XTRA HAS BEEN STACKED ! ENTRY HAS BEEN BY JLK SO RETURN ADDRESS ALSO STACKED ! !RTF LB TOS RETURN ADDRESS TO B ! SLB TOS XTRA TO B,RETURN ADDR TO TOS ! PRCL 4 TO PLANT PARAMS ! JLK +1 STACK DUMMY PC ! STLN TOS LNB AS SECOND PARAMETER ! ST TOS ERROR NO AS THIRD PARAM ! STB TOS XTRA AS FOURTH PARAMETER ! LXN (LNB+4) POINTER TO GLA ! RALN 9 TO STORED LNB ! CALL ((XNB+10)) VIA XREF=DESCRIPTOR-DESCRIPTOR ! J TOS BACK AFTER A MONITOR ! ! PLUG(1,0,X'1B800000'!CA>>1,4);! FILL JUMP TO ERROR SEQUENCE PLABS(2)=CA PF1(LB,0,TOS,0) PF1(SLB,0,TOS,0) PSF1(PRCL,0,4) PSF1(JLK,0,1) PF1(STLN,0,TOS,0) PF1(ST,0,TOS,0) PF1(STB,0,TOS,0) PSF1(LXN,1,16) PSF1(RALN,0,9) PF1(CALL,2,XNB,40) PF1(JUNC,0,TOS,0) ! ! 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'504', 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', 1); ! 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,0,2,40) 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 %RECORDNAME CELL(LISTF) 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 ACC * !*********************************************************************** PLABS(LAB)=CA %IF MODE=0 %THEN PSF1(LSS,0,0) PSF1(SLSS,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) %ROUTINESPEC ENTER LAB(%INTEGER M,FLAG) %ROUTINESPEC REMOVE LAB(%INTEGER LAB) %ROUTINESPEC CEND(%INTEGER KKK) %ROUTINESPEC CBPAIR(%INTEGERNAME LB,UB) %ROUTINESPEC CCOND(%INTEGER 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 %ROUTINESPEC CUI(%INTEGER CODE) %ROUTINESPEC ASSIGN(%INTEGER A,B) %ROUTINESPEC CSTART(%INTEGER MODE) %ROUTINESPEC CREATE AH(%INTEGER MODE) %ROUTINESPEC TORP(%INTEGERNAME HEAD,BOT,NOPS) %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,%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) %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 REPLACE TAG (%INTEGER KK) %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) %ROUTINESPEC CRFORMAT(%INTEGERNAME OPHEAD) %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 %INTEGER TCELL,ADISP,JJ,JJJ,KK,QQ,MARKER,REPORTUI,XDISP, %C BASE,AREA,ACCESS,DISP,EXTRN, CURR INST,VALUE,STRINGL, %C PTYPE,I,J,OLDI,USEBITS,TWSPHEAD,KKK, %C MARKIU,MARKUI,MARKC,MARKE,MARKR %INTEGER LITL,ROUT,NAM,ARR,PREC,TYPE CURR INST=0 TWSPHEAD=0 %INTEGERARRAY SGRUSE,SGRINF(0:7) ->SW(A(P)) 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) %UNLESS LEVEL>=2 MARKER=P+1+A(P+1)<<8+A(P+2) P=P+3 ->LABFND %IF A(MARKER)=1 SET LINE; MASK=15 %IF A(MARKER)=2 %THEN CUI(0) %AND ->CSSEXIT MARKE=0; MARKR=0 MARKUI=P; MARKIU=MARKER+1 MARKC=MARKIU+1 ->CONEXP %IF A(MARKER)=3 ->WHILE 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 ENTER LAB(FROM AR2(P+3),0); ->CSSEXIT SW(5): ! %CYCLE FAULT(57,0) %UNLESS LEVEL>=2 !*********************************************************************** !* THE LAYOUT OF AN ENTRY ON THE CYCLE LIST IS:- * !* S1= CNAME<<16!LABEL NO * !* S2= EL<<16! CYCLE WORK AREA DISPLACEMENT FROM RBASE * !* S3= NOT USED * !* WHERE :- * !* CNAME= CYCLE CONTROL NAME * !* LABEL= NO OF INTERNAL LABEL FOR REPEAT TO JUMP TO * !* EL=LABEL NO FOR EXIT STATEMENT (TOP BIT SET WHEN USED) * !*********************************************************************** %BEGIN %INTEGER PP,Q,INC,NAME,TNAME,PASS,OPEN,XTRA,KK SET LINE INC=0; XTRA=0 OPEN=A(P+1)-1; P=P+2; PP=P %IF OPEN #0 %THEN %START; ! OPEN CYCLES ENTRY AS WHILE PASS=X'10000000' %FINISH %ELSE %START NAME=FROM AR2(P) P=P+2 TNAME = TAGS(NAME) PASS=NAME<<16 COPY TAG (NAME) FAULT(25,NAME) %UNLESS TYPE=1 %AND PREC=5 %AND ROUT=ARR=0 WARN(4,NAME) %UNLESS I=RLEVEL GET WSP(INC,2); ! WORKAREA TO INC POP(TWSPHEAD,JJ,KK,Q); ! MUST NOT BE FREED BEFORE REPEAT Q=P; SKIP EXP; JJ=P; ! Q TO 1ST EXP, JJ TO SECOND %IF PARMOPT=0 %AND IMOD(TSEXP(XTRA))=1 %AND XTRA#0 %START XTRA=XTRA<<16 %FINISH %ELSE %START P=JJ CSEXP(ACCR,X'51'); ! INCREMENT EXPRESSION TO ACC PSF1(ST,1,INC); ! AND TO WORK AREA %FINISH %IF PARMOPT#0 %THEN PPJ(20,11); ! FAULT ZERO INCREMENT JJ=P %IF PARMOPT=0 %AND IMOD(TSEXP(KK))=1 %AND KK#0 %START XTRA=XTRA!(KK&X'FFFF') %FINISH %ELSE %START P=JJ CSEXP(ACCR,X'51'); ! FINAL VALUE TO ACC PSF1(ST,1,INC+4); ! AND TO WORK AREA %FINISH P=Q; CSEXP(BREG,X'51'); ! INITIAL VALUE TO B %IF PARMOPT#0 %THEN %START; ! VALIDATE CYCLE PSF1(LSS,1,INC+4); ! FINAL PF1(ISB,0,BREG,0); ! FINAL-INITIAL PSF1(IMDV,1,INC); ! (F-I)//INC PPJ(22,11); ! -VE REPITIONS PF1(LSS,0,TOS,0); ! REMAINDER PPJ(36,11); ! IS NOT ZERO %FINISH GRUSE(ACCR)=0 GRUSE(DR)=0 GRUSE(XNB)=0 %FINISH PLABEL=PLABEL-1; PASS=PASS!PLABEL ENTER LAB(PLABEL,0) %IF OPEN#0 %THEN PLABEL=PLABEL-1 %ELSE %START COPY TAG(NAME) BASE=I; AREA=-1 PSORLF1(STB,2*NAM,AREA CODE,K) NOTE ASSMENT(BREG,2,NAME) %FINISH XLABEL=XLABEL-1 PUSH(CYCLE(LEVEL),PASS,XLABEL<<16!INC,XTRA) %END; ->CSSEXIT ! SW(6): ! REPEAT FAULT(57,0) %UNLESS LEVEL>=2 %BEGIN %INTEGER NAME,TOPREG,DSP,WSPL,LAB,XTRA,ELABEL,EUSED, %C IT,IV,FT,FV,CELL %SWITCH CTYPE(0:3) EUSED=0 %IF -1<=FROM1(CYCLE(LEVEL))<=0 %THEN FAULT(1,0) %AND ->BEND POP(CYCLE(LEVEL),J,DSP,XTRA) ELABEL=DSP>>16&X'7FFF'; ! FOR ANY EXITS EUSED=DSP>>31 DSP=DSP&X'7FFF'; LAB=J&X'FFFF' ->CTYPE(J>>28) CTYPE(0): ! STEP CYCLE LOCAL SCALAR CONTROL SET LINE TOPREG=3; WSPL=2; NAME=J>>16 %IF PARMCHK=1 %THEN %START; ! CHECK CYCLE ENTERD OK PSF1(LSS,1,DSP) TEST ASS(ACCR,1,4) %FINISH ! ! SET UP CYCLE PARAMETERS FROM WKAREA UNLESS THEY ARE CONSTANT ! IT=1; FT=1 IV=DSP; FV=DSP+4 %IF XTRA>>16#0 %THEN IT=0 %AND IV=XTRA&X'FFFF0000'//X'10000' %IF XTRA&X'FFFF' #0 %THEN FT=0 %AND FV=XTRA<<16//X'10000' ! ! GET CONTROL TO B DIRECTLY ! COPY TAG(NAME) BASE=I; AREA=-1 ACCESS=2*NAM; DISP=K NAMEOP(2,BREG,4,NAME) ! ! NOW PLANT CODE TO DO THE TEST AND BRANCH. ! %IF IT=0=FT %AND IV=-1 %AND FV=1 %START CELL=FIND3(LAB,LABEL(LEVEL)) XTRA=FROM1(CELL)&X'FFFFFF' REPLACE1(CELL,XTRA!X'1000000') XTRA=(XTRA-CA)//2 PSF1(DEBJ,0,XTRA) %FINISH %ELSE %START %IF IT=0 %AND IV=1 %THEN PSF1(CPIB,FT,FV) %ELSE %START PSF1(CPB,FT,FV); ! COMPARE B WITH FINAL PSF1(ADB,IT,IV); ! ADB INCREMENT(CC UNALTERED) %FINISH ENTER JUMP(7,LAB,0); ! BNE %FINISH GRUSE(BREG)=0 RETURN WSP(DSP,WSPL); ! WORKAREA TO FREE LIST %IF PARMCHK=1 %THEN %START PF1(LSS,0,PC,PLABS(1)) PSF1(ST,1,DSP); ! INC TO UNASSGND GRUSE(ACCR)=0 %FINISH ->BEND CTYPE(1): ! '%WHILE' '%CYCLE' ENTER JUMP(15,LAB,0); ! UNCONDITIONALLY TO WHILE CLAUS ENTER LAB(LAB-1,B'111'); ! CONDITIONAL/REPLACE ENV ->BEND CTYPE(2): ! '%UNTIL' ... '%CYCLE' LINE=DSP SET LINE P=XTRA CCOND(1,LAB) BEND: %IF EUSED#0 %THEN ENTER LAB(ELABEL,B'11') REMOVE LAB(LAB) %END; ->CSSEXIT SW(23): ! '%CONTROL' (CONST) J=FROM AR4(P+2) CODEOUT DCOMP=J>>28; ->CSSEXIT ! SW(3): ! (%IU)(COND)%THEN(UI)(ELSE') FAULT(57,0) %UNLESS LEVEL>=2 MARKIU=P+1; MARKC=MARKIU+3 MARKR=P+2+A(P+2)<<8+A(P+3); ! ! FROMAR2(P+2) MARKE=0 %IF A(MARKR)=3 %THEN %START MARKE=MARKR+1+FROMAR2(MARKR+1) MARKUI=MARKR+3 %FINISH SET LINE CONEXP: %BEGIN !*********************************************************************** !* THIS BLOCK COMPILES CONDITIONAL EXPRESSIONS.IT REQUIRES THE * !* FOLLOWING GLOBAL POINTERS 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) * !*********************************************************************** MARKIU=A(MARKIU); ! ALT OF IU 1=%IF,2=%UNLESS KKK=-1 %IF MARKR>0 %AND A(MARKR)<=2 %START;! '%START' OR '%THENSTART' KKK=SFLABEL-1 P=MARKC; CCOND(MARKIU,KKK) CSTART(1) ->BEND %FINISH %IF A(MARKUI)=2 %AND A(MARKUI+3)=2 %THEN %C KKK=FROM AR2(MARKUI+1); ! UI = SIMPLE LABEL ! %IF A(MARKUI)=8 %AND CYCLE(LEVEL)#0 %START; ! VALID EXIT KKK=FROM2(CYCLE(LEVEL)) REPLACE2(CYCLE(LEVEL),KKK!X'80000000') KKK=KKK>>16&X'7FFF' %FINISH ! %IF KKK>=0 %THEN %START; ! FIRST UI IS'->'