!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<127 %AND %C
X'80000000'>>(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<=92 %AND %C
X'80000000'>>(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,<EXIT>
!QIN; *STB_I
!QIN; *LSS_%B; ! I TO ACC
!QIN; *LB_T
!QIN; *CPB_7
!QIN; *JCC_2,<SKIP>
!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_<CYC>
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,<HOLE>
!QIN; *LSD_ACCDES
!QIN; *LD_DRDES
!QIN; *INCA_%B
!QIN; *CPS_%L=%DR
!QIN; *JCC_8,<FND>
!QIN; *LB_KK
!QIN; *CPIB_NNAMES
!QIN; *JCC_7,<CYC1>
!QIN; *LB_0
CYC2:
!QIN; *STB_KK
!QIN; *LB_(WORD+%B)
!QIN; *JAT_12,<HOLE>
!QIN; *LSD_ACCDES
!QIN; *LD_DRDES
!QIN; *INCA_%B
!QIN; *CPS_%L=%DR
!QIN; *JCC_8,<FND>
!QIN; *LB_KK
!QIN; *CPIB_JJ
!QIN; *JCC_7,<CYC2>
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<<Z)
SS=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 I<M'0' %OR I>M'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,<FAIL>
%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<<KPP)&B'101100'#0 %THEN N=N//4
CODE(PPCURR)=OPCODE!1
CODE(PPCURR+1)=((4!KP)<<3!KPP)<<2!(N>>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<CONST PTR %CYCLE
%IF CTABLE(K)=C1 %AND CONSTHOLE#K %C
%THEN D=4*K!X'80000000' %AND %RETURN
K=K+1
%REPEAT
%FINISH %ELSE %START
J=CONSTPTR-LP
%WHILE K<=J %CYCLE
%IF CTABLE(K)=C1 %AND CTABLE(K+1)=C2 %AND %C
(CONSTHOLE<K %OR 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)=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): ! <CMARK> <COMMENT TEXT>
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 <BEGIN ANOTHER TRAVERSE>
%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'->'<LABEL>
NMDECS(LEVEL)=NMDECS(LEVEL)!1
P=MARKC; CCOND(3-MARKIU,KKK)
%IF MARKE>0 %AND A(MARKE)<=2 %START; ! THERE IS AN ELSE CLAUSE
%IF A(MARKE)=1 %THEN CSTART(0) %ELSE %START
P=MARKE+1; MASK=15
CUI(0)
%FINISH
%FINISH
->BEND
%FINISH
!
PLABEL=PLABEL-1; KKK=PLABEL
P=MARKC; CCOND(MARKIU,KKK)
P=MARKUI; MASK=15; CUI(1)
%UNLESS MARKE>0 %AND A(MARKE)<=2 %START; ! UNLESS %ELSE FOLLOWS
ENTER LAB(KKK,B'11'!REPORTUI<<2); ->BEND;! CONDITIONAL&MERGE
%FINISH
!
%IF A(MARKE)=1 %THEN %START; ! '%ELSESTART'
%IF REPORTUI=0 %THEN %C
ENTER JUMP(15,SFLABEL-1,B'10');! LONG JUMP BUT SAVE ENV
CSTART(2)
ENTER LAB(KKK,B'111'); ! CONDITIONAL & REPLACE ENV
%FINISH %ELSE %START; ! '%ELSE<UI>'
P=MARKE+1
PLABEL=PLABEL-1; JJJ=PLABEL
%IF REPORTUI=0 %THEN %C
ENTER JUMP(15,JJJ,B'11'); ! SHORT JUMP AND SAVE ENV
ENTER LAB(KKK,B'111'); ! CONDITIONAL REPLACE ENV
MASK=15; CUI(2)
ENTER LAB(JJJ,B'11'!REPORTUI<<2);! CONDITIONAL MERGE
%FINISH
BEND: %END; ->CSSEXIT
SW(4):
%BEGIN; ! '%FINISH(ELSE')(S)
%INTEGER J,CODE,CYC,FLAB
POP(SBR(LEVEL),CODE,FLAB,CYC)
%IF CODE=3 %THEN NMDECS(LEVEL)=NMDECS(LEVEL)&X'FFFFFFEF'
%IF CODE<0 %THEN FAULT(51,0) %AND ->BEND
%IF CYC#CYCLE(LEVEL) %THEN FAULT(52,0)
!
%IF A(P+1)<=2 %THEN %START; ! %ELSE CLAUSE PRESENT
FAULT(47,0) %UNLESS CODE=1; ! DANGLING ELSE
%IF A(P+1)=1 %THEN %START; ! %ELSE %START
!
! PLANT A ROUND NEXT START-FINISH %UNLESS PREVIOUS INSTRUCTION WAS ->
!
ENTER JUMP(15,SFLABEL-1,B'10') %IF LAST INST=0
CSTART(2)
%FINISH %ELSE %START; ! %ELSE (UI)
%IF LAST INST=0 %THEN %START
PLABEL=PLABEL-1; J=PLABEL
ENTER JUMP(15,J,B'11')
%FINISH
P=P+2
!
! PLANT THE LABEL FOR THE JUMP ROUND THE START FINISH BLOCK JUST ENDED
! THE LABEL IS CONDITIONAL ON THERE HAVING BEEN A JUMP. ENVIRONMENTS ARE
! MERGED UNLESS THE PREVIOUS INSTN IS A -> ETC WHEN ENV IS REPLACED
!
ENTER LAB(FLAB,B'011'!LAST INST<<2)
SET LINE; MASK=15
%IF LAST INST#0 %THEN CUI(0) %AND ->BEND
CUI(2); FLAB=J
LAST INST=REPORT UI
%FINISH
!
%FINISH %ELSE %START
->BEND %IF CODE=0
%FINISH
!
ENTER LAB(FLAB,B'011'!LAST INST<<2)
BEND: %END; ->CSSEXIT
SWITCH: %BEGIN; ! SWITCH LABEL
%INTEGER HEAD,BASEPT,BP,FNAME
%INTEGERARRAY BITS(0:2)
FORGET(-1)
FNAME=FROM AR2(P+3)
->SERR %UNLESS A(P)=1 %AND A(P+5)=1; ! 1ST OF UI + APP
->SERR %UNLESS A(P+9)#3 %AND A(P+10)=2 %AND A(P+11)=X'51'
->SERR %UNLESS A(P+16)=2=A(P+17); !NO R.OF.EXP. OR R.OF.APP
->SERR %UNLESS A(P+18)=2; ! NO ENAME
COPY TAG(FNAME)
HEAD=K
%IF OLDI#LEVEL %OR TYPE#6 %THEN FAULT(4,FNAME) %AND ->BEND
FROM123(HEAD,BASEPT,KKK,KK); ! EXTRACT TABLE ADDR,LB & UB
MLINK(HEAD); ! K POINTS TO BIT LIST
JJ=FROM AR4(P+12)
JJ=-JJ %IF A(P+9)=2
->INBD %IF KKK<=JJ<=KK
SERR: FAULT(5,FNAME); ->BEND
INBD: Q=JJ-KKK
%WHILE Q>=96 %THEN MLINK(HEAD) %AND Q=Q-96
!
! 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
!
FROM123(HEAD,BITS(0),BITS(1),BITS(2))
QQ=Q>>5; ! RIGHT WORD
Q=Q&31; JJJ=1<<Q; ! BIT IN WORD
FAULT(6,FNAME) %UNLESS BITS(QQ)&JJJ=0
BITS(QQ)=BITS(QQ)!JJJ
REPLACE123(HEAD,BITS(0),BITS(1),BITS(2))
!
! OPTIMISED (ARR=2) SWITCHES USE HALFWORDS AND BASEPT POINTS TO THE
! ZEROETH NOT THE FIRST ELEMENT
!
BP=4//ARR
%IF ARR=2 %THEN KKK=0
Q=CA-BASEPT
QQ=BASEPT+(JJ-KKK)*BP; ! REL POSITION OF LABEL
PLUG(1,QQ,Q,BP); ! OVERWRITE THE WORD IN TABLE
%IF ARR=2 %AND Q>X'FFFF' %THEN ABORT
BEND: %END; ->CSSEXIT
SW(7): ! (%WU)(SC)(COND)(RESTOFWU)
FAULT(57,0) %UNLESS LEVEL>=2
MARKIU=P+1; ! TO WHILE/UNTIL
MARKC=MARKIU+3; ! TO (SC)(COND)
MARKR=P+2+FROM AR2(P+2); ! TO RESTOF WU
MARKUI=MARKR+1; ! TO P(UI) IF ANY
WHILE: %BEGIN
%INTEGER L1,L2
MARKIU=A(MARKIU); ! =1 FOR'WHILE' =2 FOR'UNTIL'
SFLABEL=SFLABEL-1
L1=SFLABEL
PLABEL=PLABEL-1; ! RESERVE 2 LABELS
L2=PLABEL
->WCYCLE %IF MARKR>0 %AND A(MARKR)<=2
SET LINE
ENTER LAB(L1,0); ! UNCONDITIONAL LAB FOR REPEAT
%IF MARKIU=1 %THEN %START
P=MARKC
CCOND(1,L2)
%FINISH
!
MASK=15; P=MARKUI
CUI(1)
!
%IF MARKIU=1 %THEN %START
ENTER JUMP(15,L1,0); ! UNCODITIONALLY TO WHILE COND
ENTER LAB(L2,B'111')
%FINISH %ELSE %START
P=MARKC; CCOND(1,L1); ! UNTIL CONDITION AT END
%FINISH
->BEND
WCYCLE:
!***********************************************************************
!* WHILE CYCLES JUST LIKE %WHILE...%THEN<UI> BUT %UNTIL CYCLES *
!* STORE AWWAY AN A.R. TO BE COMPILED TO PUT THE *
!* CONDITION AT THE END. IF IT WAS PUT AT THE BEGINING 2 EXTRA *
!* JUMPS ARE NEEDED TO OBTAIN THE CORRECT EFFECT. *
!* WHILE CYCLES:- S1=FLAG(=1)<<28! LABEL FOR REPITITION *
!* S2=LAB FOR EXIT<<16 ! LAB FOR TERMINATION *
!* S3= NOT USED *
!* UNTIL CYCLES:- S1=FLAG(=2)<<28! LAB FOR REPITITION *
!* S2=LAB FOR EXIT<<16! LINE NO OF CONDITION *
!* S3= POINTER TO AR FOR CONDITION *
!***********************************************************************
XLABEL=XLABEL-1
ENTER LAB(L1,0); ! UNCONDITIONAL FOR REPEAT
%IF MARKIU=2 %THEN %START; ! '%UNTIL....%CYCLE'
L2=LINE
%FINISH %ELSE %START; ! '%WHILE...%CYCLE
SET LINE
P=MARKC
CCOND(1,L1-1)
SFLABEL=SFLABEL-1
%FINISH
PUSH(CYCLE(LEVEL),L1!MARKIU<<28,XLABEL<<16!L2,MARKC)
BEND: %END; ->CSSEXIT
!
SW(8): ! SIMPLE DECLN
FAULT(57,0) %UNLESS LEVEL>=2
FAULT(40,0) %IF NMDECS(LEVEL)&1#0
P=P+5;CLT;ROUT=0; LITL=0
%IF A(P)#1 %THEN %START; ! ARRAY DECLARATIONS
FAULT(70,0) %IF TYPE=5 %AND ACC=0
NAM=0
SET LINE
QQ=2-A(P+1); P=P+2; ! QQ=1 FOR ARRAYFORMATS
DECLARE ARRAYS(QQ,0)
%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,0) %UNLESS LEVEL+CPRMODE=3
FAULT(56,0) %UNLESS A(P+1)=CPRMODE
CEND(CPRMODE)
->BEND
S(3): ! ENDOFLIST
LIST=0;
->BEND
S(4): ! END
CEND(FLAG(LEVEL))
BEND: %END
->CSSEXIT
!
SW(11):
%BEGIN
%INTEGER MARKER1,KK,KKK
%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+2; CRSPEC(1-EXTRN>>2);! 0 FOR ROUTINESPEC
! 1 FOR EXTERNAL (ETC) SPEC
->BEND
%FINISH
COPY TAG(KK)
%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
XNAME<-STRING(DICTBASE+WORD(KK))
%IF EXTRN=1 %THEN XNAME<-'S#'.XNAME
%IF EXTRN=4 %THEN XNAME=''
JJ=FROM1(K); ! CODE DESCRIPTOR REL ADDR
%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(55,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=(A(P)-1)<<1; ! SET NAME ARRAY BIT FOR MAPS
PACK(KKK); ! AND STORE PTYPE IN KKK
%FINISH
%FINISH
%UNLESS OLDI=LEVEL %AND J=15 %AND PTYPE=KKK %START
P=Q+2; CRSPEC(0); P=Q; ->AGN
%FINISH
%BEGIN
%INTEGER PTR,PTYPEP
J=0; REPLACE TAG(KK);! BODY GIVEN SO UPDATE TAGS INFO
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+6
RHEAD(KK)
N=20
%IF A(P+1)=1 %THEN %START; ! FORMAL PARAMETERS TO DEAL WITH
%UNTIL A(P)=2 %CYCLE; ! UNTIL NO MORE FP-PART
P=P+2
CFPDEL
PTR=P
%UNTIL A(PTR-1)=2 %CYCLE;! CYCLE DOWN NAMELIST
MLINK(JJ)
%IF JJ#0 %THEN %START
FROM12(JJ,J,JJJ);! EXTRACT PTYPE XTRA INFO
%UNLESS J=PTYPE %AND (PTYPE#5 %OR JJJ>>16=ACC) %C
%THEN FAULT(9,FROM AR2(PTR))
%FINISH %ELSE FAULT(8,KK);! MORE FPS THAN IN SPEC
PTR=PTR+3
%REPEAT
DECLARE SCALARS(0,0)
%REPEAT; ! UNTIL NO MORE FP-PART
N=(N+3)&(-4); ! TO WORD BOUNDARY AFTER ALL SYSTEM
! STANDARD PARAMETERS HAVE BEEN DECLARED
%FINISH
MLINK(JJ)
FAULT(10,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)
%END
BEND: %END; ->CSSEXIT
!
SW(13): !REALS(LN)
ALL LONG=A(P+1)&1;->CSSEXIT
!
SW(14): !%BEGIN
%BEGIN
PTYPE=0
%IF LEVEL=1 %AND RLEVEL=0 %AND CPRMODE=0 %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)
!
! LAY DOWN A CONTINGENCY AGAINST ERROR IN PROGRAM
! IE COMPILE EXTERNAL CALL 'S#SIGNAL(0,PC,LNB,FLAG)'
!
CXREF(SIGEP,0,2,SIGREFDIS); ! REFERENCE TO SIGNAL
!
! 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
! PRCL 4 TO PLANT PARAMS
! LSS 0
! ST TOS FIRST PARAM
! JLK +3 2ND PARAM AND JUMP ROUND NEXT INSTR
! JCC 15,PERM15 TO RECOVERY SUBROUTINE
! STLN TOS 3RD PARAM
! LDTB WORD DES DESC USED FOR 'INTEGER()'
! LDA (XNB+5) ADD IN LNB
! INCA +20 TO WORD 5 OF FRAME(REPORT WORD)
! STD TOS 4TH AND LAST PARAM
! RALN 10
! CALL SIGREF
!
PSF1(STD,1,12)
PSF1(LXN,1,16)
PF1(STLN,0,XNB,20)
! PSF1(ASF,0,1)
!
! THE NEXT 8 INSTRUCTIONS ARE REQUIRED TO SET SF 6 WORDS IN FRONT OF LNB
! AN ASF 1 WORKS AS WELL EXCEPT FOR K-STAND ALONE WHEN THERE MAY BE
! A USELESS REDUNDANT DESCRIPTOR ON THE STACK
!
PF1(STLN,0,TOS,0)
PF1(LSS,0,TOS,0)
PSF1(IAD,0,24)
PF1(STSF,0,TOS,0)
PF1(ISB,0,TOS,0)
PSF1(ISH,0,-2)
PF1(ST,0,BREG,0)
PF1(ASF,0,BREG,0)
!
PSF1(PRCL,0,4)
PSF1(LSS,0,0)
PF1(ST,0,TOS,0)
PSF1(JLK,0,3)
PPJ(15,15)
PF1(STLN,0,TOS,0)
PF1(LDTB,0,PC,PARAM DES(5))
PF1(LDA,0,XNB,20)
PSF1(INCA,0,20)
PF1(STD,0,TOS,0)
PSF1(RALN,0,10)
PF1(CALL,2,XNB,SIGREFDIS)
!
! 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 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) %UNLESS LEVEL>=2
FAULT(40,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
ENTER JUMP(15,SFLABEL-1,B'10');! JUMP ROUND ON BODY
CSTART(3)
!
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,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
ONINF(LEVEL)=N; N=N+8
%IF STACK=0 %THEN %START
PSF1(LSS,1,DISP+12); ! RESET AUX STACK TOP
PSF1(ST,2,DISP)
%FINISH
->CSSEXIT
SW(16):
FAULT(57,0) %UNLESS LEVEL>=2
%BEGIN; ! %SWITCH (SWITCH LIST)
%INTEGER Q,RANGE,KKK,KK,LB,PP,D0,D1,OPHEAD,V
Q=P
FAULT(56,0) %UNLESS LEVEL>=2
CNOP(0,4)
PLABEL=PLABEL-1
ENTER JUMP(15,PLABEL,B'10')
ARR=1
%IF PARMOPT=0 %AND(COMPILER#0 %OR P1SIZE<128000) %THEN ARR=2
%UNTIL A(Q)=2 %CYCLE; ! UNTIL NO'REST OF SW LIST'
P=P+3
%WHILE A(P)=1 %THEN P=P+3
CBPAIR(LB,KK); ! LOWER BOUND TO LB UPPER TO KK
RANGE=(KK-LB+1)
%IF CA-2*LB<0 %THEN ARR=1; ! ZEROETH ELEMENT OFF FRONT
PTYPE=X'56'+ARR<<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". OPTIMISEING USE 2BYTE STRING
! ARRAYS WITH BASE SET TO ZEROETH ELEMENT
!
%IF ARR=1 %THEN %START
D0=5<<27!RANGE
D1=CA
%FINISH %ELSE %START
D0=X'58000002'; D1=CA-2*LB
%FINISH
PGLA(8,8,ADDR(D0))
SNDISP=GLACA>>2-2; ! WORD PLT DISP
RELOCATE(GLACA-4,D1,1); ! RELOCATE RELATIVE TO CODE
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)-D1
%CYCLE KKK=LB,1,KK
%IF ARR=1 %THEN PCONST(V) %ELSE PLANT(0)
%REPEAT
%REPEAT; ! FOR ANY MORE NAMES IN NAMELIST
Q=PP; P=Q
%REPEAT; ! UNTIL A(Q)=2
ENTER LAB(PLABEL,B'110')
%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,BP,PP,SIGN,CBASE,MODE,UICONST,ICONST,TAGDISP,EPTYPE, %C
EPDISP,AH1,AH2,AH3,AH4,AD,FNAM,FINF,SPOINT,CONSTSFOUND,CPREC,%C
EXTRN,NNAMES,MARK,LPUTP,MARKER1,LB,CTYPE,CONSTP,FORMAT,PTSIZE
%LONGREAL RCONST,LRCONST
%STRING(255) SCONST,NAMTXT
%INTEGERNAME STPTR
LPUTP=5; STPTR==USTPTR; ! NORMAL CASE GLA SYMBOLTABLES
! FAULT(40,0) %IF NMDECS&1#0
EXTRN=A(P+1)&3; LITL=EXTRN
%IF LITL<=1 %THEN LITL=LITL!!1
KFORM=0; SNDISP=0
%IF EXTRN=0 %THEN LPUTP=4 %AND STPTR==SSTL
P=P+3; CBASE=0
MODE=A(P-1); ! MODE =1 FOR NORMAL OWNS
->RECORD %IF MODE>1; ! MODE =2 FOR OWN RECORDS
CLT; ! MODE =3 FOR OWN RECORD ARRAYS
%IF A(P)=1 %THEN CQN(P+1) %ELSE ARR=1 %AND NAM=0
%IF TYPE=5 %AND ACC=0=NAM %THEN FAULT(70,0) %AND ACC=2
ROUT=0; PACK(PTYPE)
-> NON SCALAR %IF ARR#0 %AND NAM=0
P=P+1
%UNTIL A(MARK)=2 %CYCLE; ! UNTIL <RESTOFOWNDEC> NULL
MARK= P+1+FROM AR2(P+1)
NNAMES=1
PP=P+3; P=PP+2; ! PP ON FIRST NAME'
%WHILE A(P)=1 %THEN NNAMES=NNAMES+1 %AND P=P+3
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 NAM#0 %THEN CTYPE=1 %AND CPREC=5
!
%IF A(P)=1 %THEN %START; ! CONSTANT GIVEN
P=P+1
XTRACT CONST(CTYPE,CPREC)
%FINISH
!
%UNTIL NNAMES=0 %CYCLE; ! DOWN <NAMELIST>
J=0; K=FROM AR2(PP)
NAMTXT=STRING(DICTBASE+WORD(K))
%IF NAM#0 %THEN %START; ! OWNNAMES AND ARRAYNAMES
%IF EXTRN=3 %THEN FAULT(46,K);! NO EXTRINSIC NAMES
UICONST=X'FFFF'!PREC<<27
PGLA(8,ACC,ADDR(UICONST))
TAGDISP=GLACA-ACC; EPDISP=TAGDISP
%FINISH %ELSE %START
%IF TYPE=5 %THEN %START; ! STRING
QQ=STPTR; AD=ADDR(SCONST)
%IF EXTRN=3 %THEN %START; ! EXTRINSIC STRINGS
AH3=0; AH2=PREC<<27!ACC; ! DUMMY STRING HEADER
%FINISH %ELSE %START
LPUT(LPUTP,ACC,QQ,AD) %IF INHCODE=0;! O/P STRING
STPTR=(STPTR+ACC+3)&(-4)
AH3=QQ; AH2=3<<27!ACC
%FINISH
PGLA(8,8,ADDR(AH2))
TAGDISP=GLACA-8
%IF EXTRN=3 %THEN GXREF(NAMTXT,2,2<<24!ACC,TAGDISP+4) %C
%ELSE RELOCATE(TAGDISP+4,AH3,LPUTP)
EPTYPE=5; EPDISP=QQ; ! DATA IN GLA SYMBOL TABLES
%FINISH %ELSE %START; ! INTEGER & REAL
%IF EXTRN=3 %THEN %START; ! EXTRINSICS
PTYPE=PTYPE!1<<10; ! EXTRINSICS VIA PTR
AH2=PREC<<27; AH3=0
PGLA(8,8,ADDR(AH2))
TAGDISP=GLACA-8
GXREF(NAMTXT,2,2<<24!ACC,TAGDISP+4)
%FINISH %ELSE %START; ! OWN,EXTERNAL&CONST
%IF TYPE=2 %THEN %START
AD=ADDR(RCONST)
%FINISH %ELSE %START; ! INTEGER VARIABLES
AD=ADDR(ICONST)+4-ACC
%FINISH
%IF EXTRN#0 %THEN %C
PGLA(ACC,ACC,AD); ! PUT CONSTANT INTO GLA
TAGDISP=GLACA-ACC; ! OFFSET OF VAR FOR TAGS
EPDISP=TAGDISP; ! AND FOR ENTRY DEFN
EPTYPE=2; ! DATA IN ADRESSABLE GLA
%FINISH
%FINISH
%FINISH
STAG(TAGDISP,ACC)
%IF EXTRN=0=NAM %START; ! CONST = LITERAL
%IF PREC<=6 %THEN REPLACE2(TAGS(K),INTEGER(AD&(-4)));! BYTES!
%IF PREC=6 %THEN REPLACE3(TAGS(K),INTEGER(AD+4))
%IF PREC=7 %THEN REPLACE3(TAGS(K),ADDR(A(CONSTP)))
%FINISH
PP=PP+3
NNAMES=NNAMES-1
%REPEAT
P=MARK
%REPEAT
->BEND
RECORD: ! <XOWN>'%RECORD'<NAMELIST>
!***********************************************************************
!* NO INITIALISATION OF OWN RECORDS ALLOWED SO THEY ARE ALL *
!* CLEARED TO ZERO. *
!***********************************************************************
MARKER1=P+1+FROM AR2(P+1); ! TO FORMAT NAME
FNAM=FROM AR2(MARKER1)
COPYTAG(FNAM)
FINF=TCELL
%IF PTYPE#4 %THEN FAULT(62,FNAM) %AND ->BEND
PTYPE=X'133'!LITL<<14
KFORM=FINF; UNPACK
%IF MODE=3 %THEN FORMAT=2-A(P) %AND P=P+2 %AND ->RECIN
P=P+1; BP=ACC; ! SIZE OF RECORD FROM FORMAT
PTYPE=X'33'; J=0
%IF A(P-1)#3 %THEN CQN(P-1) %AND PACK(PTYPE)
P=P+1; PTSIZE=ACC; ! SIZE OF HOLE FOR POINTER
%UNTIL A(P)=2 %CYCLE
P=P+1; K=FROM AR2(P)
NAMTXT=STRING(DICTBASE+WORD(K))
%IF NAM#0 %THEN %START; ! OWNNAMES AND ARRAYNAMES
%IF EXTRN=3 %THEN FAULT(46,K);! NO EXTRINSIC NAMES
UICONST=X'FFFF'!PREC<<27
PGLA(8,PTSIZE,ADDR(UICONST))
TAGDISP=GLACA-PTSIZE; EPDISP=TAGDISP
%FINISH %ELSE %START
%IF EXTRN=3 %THEN %START; ! EXTRINISIC
PTYPE=PTYPE!X'400'; ! FORCE NAM=1 (IE VIA POINTER)
AH2=X'18000000'+BP
AH3=0
PGLA(8,8,ADDR(AH2))
TAGDISP=GLACA-8
GXREF(NAMTXT,2,2<<24!BP,TAGDISP+4); ! RELOCATE BY EXTERNAL
%FINISH %ELSE %START
EPDISP=(GLACA+15)&(-8)
AH3=EPDISP
AH2=X'18000000'+BP; ! TOP WORD OFDESRCIPTOR
PGLA(8,4,ADDR(AH2)); ! ADDED 18MAR76 TO FIX BUG
RELOCATE(-1,AH3,2); ! PUT DISP INTO GLA
TAGDISP=EPDISP; ! AND RELOCATE REL APPROPIATE AREA
EPTYPE=2; ! DATA IN GLA TABLES
I=0; ICONST=0
%WHILE I<BP %CYCLE
PGLA(4,4,ADDR(ICONST))
I=I+4
%REPEAT
%FINISH
%FINISH
ACC=BP; ! ACC TO SIZE OF RECORD
STAG(TAGDISP,BP)
P=P+2
%REPEAT
->BEND
NONSCALAR: ! OWN AND OWNRECORD ARRAYS
!***********************************************************************
!* OWN ARRAYS CAN BE INITIALISED BUT ONLY ONE ARRAY CAN BE *
!* DECLARED IN A STATEMENT.(THANK HEAVENS!) *
!* OWN RECORD ARRAYS ARE CLEARED TO ZERO *
!***********************************************************************
P=P+1
FORMAT=2-A(P)
RECIN: PP=P+1; P=P+3; NNAMES=1
K=FROM AR2(PP)
NAMTXT=STRING(DICTBASE+WORD(K))
%IF TYPE>=3 %THEN BP=ACC %ELSE BP=BYTES(PREC)
AH4=12+DOPE VECTOR(TYPE,BP,QQ,LB)
%IF LB=0 %AND J=1 %AND TYPE<=2 %THEN %C
ARR=2 %AND PACK (PTYPE)
LENGTH=QQ//BP; ! NO OF ELEMENTS
CONSTS FOUND=0
SPOINT=STPTR
%IF MODE#3 %AND FORMAT=0 %THEN %START; ! NOT A RECORD ARRAY
%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(46,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.
!
%IF TYPE<=2 %THEN AH1=PREC<<27!(1-PARMARR)<<24!LENGTH %ELSE %C
AH1=3<<27!1<<25!QQ
%IF PREC=4 %THEN AH1=X'58000002'
AH2=EPDISP
AH3=5<<27!3*J; ! DV DESPTR = WORD CHKD
%IF TYPE<=2 %AND PARMARR=0=FORMAT %AND J=1 %THEN AH2=AH2-BP*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 *
!***********************************************************************
%INTEGER RF,I,K,ELSIZE,AD,SPP,ELSEEN,LENGTH
%BYTEINTEGERARRAY SP(0:SIZE+256)
%IF TYPE=1 %THEN AD=ADDR(ICONST)+4-ACC
%IF TYPE=2 %THEN AD=ADDR(RCONST)
%IF TYPE=5 %THEN AD=ADDR(SCONST)
SPP=0; ELSEEN=0
ELSIZE=SIZE//NELS
%UNTIL A(P-1)=2 %CYCLE
XTRACT CONST(TYPE,PREC)
%IF A(P)=2 %THEN RF=1 %ELSE RF=FROMAR2(P+1) %AND P=P+2
P=P+2
FAULT(44,0) %IF RF=0
%CYCLE I=1,1,RF
%CYCLE K=0,1,ELSIZE-1
%IF ELSEEN<=NELS %THEN SP(SPP)=BYTE INTEGER(AD+K) %C
%AND SPP=SPP+1
%REPEAT
ELSEEN=ELSEEN+1
%REPEAT
%REPEAT; ! UNTIL P<ROCL>=%NULL
%IF ELSEEN#NELS %THEN FAULT(45,ELSEEN)
STPTR=(STPTR+3)&(-4)
LENGTH=(SIZE+3)&(-4)
LPUT(LPUTP,LENGTH,STPTR,ADDR(SP(0))) %IF INHCODE=0
STPTR=STPTR+LENGTH
CONSTS FOUND=ELSEEN
%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 %C
LPUT(14,EPTYPE<<24!DATALEN,EPDISP,ADDR(NAMTXT))
RBASE=CBASE
STORE TAG(K,J)
RBASE=RLEVEL
%END
%ROUTINE XTRACT CONST(%INTEGER CONTYPE,CONPREC)
!***********************************************************************
!* P POINTS TO P<+'> OF <+'><CONST> AND IS UPDATED *
!* THE CONST IS CONVERTED TO ALL LEGAL FORM AND THE INTEGER *
!* IS LEFT IN ICONST, THE REAL IN RCONST AND THE STRING IN SCONST*
!***********************************************************************
%INTEGER LENGTH,CPREC
SIGN=A(P); CTYPE=A(P+1); CPREC=CTYPE>>4; CTYPE=CTYPE&7
CONSTP=P+2
%IF CTYPE=2 %THEN %START; ! REAL CONSTANT
RCONST=FROMAR8(P+2); P=P+10
LRCONST=0
%IF CPREC=7 %THEN LRCONST=FROMAR8(P) %AND P=P+8
%IF SIGN=2 %THEN RCONST=-RCONST
%FINISH
!
%IF CTYPE=5 %THEN SCONST=STRING(ADDR(A(P+6)))%C
%AND P=P+A(P+6)+7
!
%IF CTYPE=1 %THEN %START; ! INTEGER CONSTANT
ICONST=FROMAR4(P+2); P=P+6
%IF SIGN=2 %THEN ICONST=-ICONST
%IF CPREC=6 %THEN %START
UICONST=ICONST
ICONST=FROM AR4(P); P=P+4
%FINISH %ELSE %START
%IF ICONST<0 %THEN UICONST=-1 %ELSE UICONST=0
%FINISH
%IF CONTYPE=2 %THEN RCONST=ICONST;! INTEGER A SPECIAL CASE OF REAL
%FINISH
LENGTH=BYTEINTEGER(ADDR(SCONST))
!
! FAULT ANY OBVIOUS ERRORS IE:-
! CONSTANT FOR EXTRINSIC OR INCOMPATIBLE TYPE OR STRING TOO LONG
!
%IF EXTRN=3 %OR (CTYPE=2 %AND CONTYPE#2) %OR %C
(CONTYPE=5 %AND CTYPE#5) %OR %C
(CTYPE=5 %AND (CONTYPE#5 %OR SIGN#3 %OR LENGTH>=ACC)) %C
%OR (CONTYPE=1 %AND ((CONPREC=3 %AND ICONST>255) %OR %C
(CONPREC=4 %AND ICONST>X'FFFF'))) %THEN FAULT(44,0)
%END
BEND: %END; ->CSSEXIT
SW(18):
P=P+1
CRSPEC(2); ->CSSEXIT
SW(19):
ABORT
SW(10):
%BEGIN; ! %RECORD (RDECLN)
!***********************************************************************
!* RECORDS ARE ALLOCATED AT COMPILE TIME WHEN POSSIBLE *
!* SEE CRFORMAT FOR ACTION ON RECORD FORMAT DECLARATIONS *
!***********************************************************************
%INTEGER MODE,RECL,ALLOC,FNAM,FINF,NAME,OPHEAD
P=P+1; MODE=A(P); SNDISP=0
%IF MODE=1 %THEN %START; ! DEAL WITH FORMAT
NAME=FROM AR2(P+1); P=P+3
CRFORMAT(OPHEAD); K=NAME
PTYPE=4; J=0
KFORM=OPHEAD
STORE TAG(K,OPHEAD)
->BEND
%FINISH
P=P+1; MARKER=P+FROM AR2(P)
FNAM=FROM AR2(MARKER); ! FORMAT NAME
COPY TAG(FNAM)
FINF=TCELL
%IF TYPE#4 %THEN %START
FINF=DUMMY FORMAT
ACC=4; FAULT(62,FNAM)
%FINISH
RECL=ACC
%IF MODE=2%THEN %START; ! '%RECORDSPEC'
COPY TAG(FROM AR2(P+2))
%IF A(P+4)=1 %AND TYPE=4 %START;! SPEC FOR FORMAT ELEMENT
P=P+5
Q=DISPLACEMENT(TCELL)
UNPACK
%FINISH
%IF TYPE=3 %AND NAM=1 %AND FROM3(TCELL)&X'FFFF'=0 %START
REPLACE3(TCELL,FINF!K<<16)
REPLACE2(TCELL,SNDISP<<16!RECL)
%FINISH %ELSE FAULT(63,0)
%FINISH %ELSE %START; ! RECORD DECLARATION
FAULT(57,0) %UNLESS LEVEL>=2
FAULT(40,0) %IF NMDECS(LEVEL)&1#0
TYPE=3; PREC=3; ROUT=0
%IF A(P+2)=1 %THEN %START; ! SIMPLE RECORD AND RECORDNAMES
ALLOC=ACC; CQN(P+3)
ACC=ALLOC; P=P+4
DECLARE SCALARS(1,FINF)
%FINISH %ELSE %START; ! ARRAYS OF RECORDS
NAM=0
Q=2-A(P+3); P=P+4; ! Q=1 FOR ARRAY FORMAT
DECLARE ARRAYS(Q,FINF)
%FINISH
%FINISH
BEND: %END;->CSSEXIT
!
SW(20):
! '*' (UCI) (S)
FAULT(57,0) %UNLESS LEVEL>=2
%BEGIN
%ROUTINESPEC CIND
%INTEGER FNAME,ALT,OPCODE,FORM,H,Q,MASK,FILLER
%SWITCH SW(1:5),F(1:3),POP(1:6),TOP(1:4)
ALT=A(P+1); P=P+2
OPCODE=CALL
->SW(ALT)
SW(1):SW(2):
FNAME=FROM AR2(P)
COPY TAG(FNAME)
FAULT(33,FNAME) %UNLESS ROUT=NAM=0 %AND ARR=0 %AND %C
PREC>4 %AND I=RBASE %AND TYPE#7
%IF ALT=1 %THEN PSF1(ST,1,K) %ELSE %C
GET IN ACC(ACCR,BYTES(PREC)>>2,0,LNB,K)
->EXIT
SW(3): ! PUT (HEX HALFWORD)
PLANT(FROM AR2(P+3))
->EXIT
SW(5): ! CNOP
CNOP(A(P),A(P+1))
->EXIT
SW(4): ! 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(33,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
FAULT(33,0) %UNLESS 0<=MASK!FILLER<=255
%FINISH
PF2(OPCODE,H,Q,FNAME,MASK,FILLER)
->EXIT
F(3): ! TERTIARY FORMAT
MASK=FROM AR2(P)
ALT=A(P+2)
FAULT(33,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(33,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,FN,FN2,D,CTYPE,CPREC
%SWITCH SW(1:4)
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
FN=FROM AR4(P+2); FN2=ADDR(A(P+2))
P=P+2+BYTES(CPREC)
%IF D=2 %THEN %START
%IF CTYPE=2 %THEN FN=FN!!X'80000000' %ELSE FN=-FN
%FINISH
CNST: ->LIT %UNLESS CTYPE=1 %AND CPREC<=5 %AND %C
X'FFFE0000'<=FN<=X'1FFFF'
AREA=0; DISP=FN
%RETURN
LIT: FAULT(33,0) %UNLESS 1<=CTYPE<=2 %AND 5<=CPREC<=7
STORE CONST(DISP,BYTES(CPREC),FN2)
AREA=PC; ACCESS=0
%RETURN
SW(2): ! (NAME)(OPTINC)
FN=FROM AR2(P); P=P+2
COPY TAG(FN)
%IF (LITL=1 %AND ARR=0) %START
CTYPE=TYPE; CPREC=PREC
ALT=TAGS(FN)
FROM123(ALT,D,FN,FN2)
%IF CPREC#7 %THEN FN2=ADDR(ASLIST(ALT)_S2)
->CNST
%FINISH
%IF TYPE>=6 %OR TYPE=4 %OR %C
(ROUT=1 %AND NAM=0) %THEN FAULT(33,FN) %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(33,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(21):
! '%TRUSTEDPROGRAM'
COMPILER=1 %IF PARMARR=0; ->CSSEXIT
SW(22): ! '%MAINEP'(NAME)
KK=FROM AR2(P+1)
FAULT(33,0) %UNLESS CPRMODE=0
MAINEP<-STRING(DICTBASE+WORD(KK))
->CSSEXIT
%ROUTINE CRFORMAT(%INTEGERNAME OPHEAD)
!***********************************************************************
!* 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,NLIST,FORM,RL,MRL,UNSCAL,SC,DESC,FN,INC,Q,R,A0,A1,A2, %C
DV,RFD,LB,OB
%SWITCH RFEL(1:5)
%ROUTINESPEC SN(%INTEGER Q)
%ROUTINESPEC ROUND
NLIST=0; OPHEAD=0; FORM=0; ACC=0; OB=0
MRL=0; INC=0; ! INC COUNTS DOWN RECORD
NEXT: ROUT=0; LITL=0; NAM=0; RFD=A(P)
%IF RFD<=2 %THEN P=P+1 %AND CLT
->RFEL(RFD)
RFEL(1): ! (TYPE) (QNAME')(NAMELIST)
CQN(P); P=P+1
PACK(PTYPE); D2=0
RL=3
%IF NAM=0 %AND 3<=PREC<=4 %THEN RL=PREC-3
AGN: ROUND ; J=0
%UNTIL A(P-1)=2 %CYCLE
D1=INC; SN(P)
P=P+3; INC=INC+ACC
%REPEAT
P=P+RFD>>2<<1; ! EXTRA 2 FOR RECORDS TO SKIP FORMAT
TRY END: -> END %IF A(P)=2
P=P+1; -> NEXT
RFEL(2):RFEL2: ! (TYPE)%ARRAY(NAMELIST)(CBPAIR)
Q=P; 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' %ELSE %C
DESC=SC<<27!UNSCAL<<25!(1-PARMARR)<<24
%UNTIL A(P-1)=2 %CYCLE; ! UNTIL <RESTOFARRAYLIST> NULL
P=P+3 %UNTIL A(P-1)=2
DV=DOPE VECTOR(TYPE,ACC,R,LB)+12;! DOPE VECTOR INTO SHAREABLE S.T.
%IF TYPE=5 %OR PREC=3 %THEN RL=0 %ELSE RL=3
ROUND
%UNTIL A(Q-1)=2 %CYCLE; ! HEAD INTO GLA FOR EACH ARRAY
A0=R; %IF UNSCAL=0 %THEN A0=A0//ACC
%IF PREC=4 %THEN A0=0; ! STRING DESCRIPTORS !
A0=A0!DESC; A1=INC
%IF TYPE<=2 %AND PARMARR=0 %AND J= 1 %THEN %C
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
P=P+1; Q=P
%REPEAT
P=P+2 %IF RFD=5
-> TRY END
RFEL(3): ! %RECORD (%ARRAY) %NAME
TYPE=3; PREC=3; NAM=1
ARR=2-A(P+1); P=P+2
PACK(PTYPE); D2=0
RL=3; ACC=8+8*ARR
FORM=0
->AGN
RFEL(4): ! RECORDS IN RECORDS
RFEL(5): ! RECORDARRAYS IN RECORDS
Q=P+FROM AR2(P+1)+1
FN=FROM AR2(Q)
COPY TAG(FN); ! COPY FORMAT TAG & SET ACC
FAULT(62,FN) %UNLESS PTYPE=4
TYPE=3; PREC=3; FORM=TCELL
%IF RFD=4 %THEN %START
PTYPE=X'33'; P=P+3; D2=0
RL=3; ->AGN
%FINISH
P=P+3; ->RFEL2
END: ! FINISH OFF
RL=MRL; ROUND
ACC=INC; ! SIZE ROUNDED APPROPRIATELY
FAULT(98,0) %UNLESS INC<=X'7FFF'
CLEAR LIST(NLIST)
%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(7,FNAME) %UNLESS FIND(FNAME,NLIST)=-1
BINSERT(OPHEAD,OB,FNAME<<20!PTYPE<<4!J,D2<<16!ACC,D1<<16!FORM)
PUSH(NLIST,0,FNAME,0)
%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 *
!***********************************************************************
%RECORDNAME LCELL(LISTF)
%INTEGER RR,II,ENAME,CELL
ENAME=A(P)<<8+A(P+1); CELL=0
%IF LINK#0 %THEN %START; ! CHK RECORDSPEC NOT OMITTED
LINK=FROM3(LINK)&X'7FFF'; ! LINK TO SIDE CHAIN
CELL=LINK; II=-1; ACC=-1
%WHILE LINK>0 %CYCLE
LCELL==ASLIST(LINK)
TCELL=LINK
%IF LCELL_S1>>20=ENAME %START; ! RIGHT SUBNAME LOCATED
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&X'FFFF0000'//X'10000'
%RESULT=K
%FINISH
LINK=LCELL_LINK
%REPEAT
%FINISH
FAULT(65,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 *
!***********************************************************************
%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); 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
->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
%IF NAM=1 %THEN %START
LOCALISE(8); ! PICK UP RECNAME DESCR &STCK
AR=AREA; DP=DISP; BS=BASE
NAMEP=-1
%FINISH
CENAME(MODE,KFORM,BS,AR,DP,XD)
%RETURN
AE: ! ARRAYS AND ARRAYNAMES AS ELEMEN
NAMEP=-1
FROM123(TCELL,Q,SNDISP,K)
ACC=SNDISP&X'FFFF'; SNDISP=SNDISP&X'FFFF0000'//X'10000'
KFORM=K&X'FFFF'; K=K&X'FFFF0000'//X'10000'
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)
!
FETCH RAD
AREA=-1; DISP=Q
BASE=0; ACCESS=0;
CREATE AH(1)
%FINISH %ELSE %START; ! ARRAY ELEMENTS IN RECORDS
%IF NAM=1 %THEN %START; ! ARRAYNAMES-FULLHEAD IN RECORD
XD=XD+Q
LOCALISE(16); ! MOVE HEAD UNDER LNB
CANAME(1,BASE,DISP); ! ARRAY MODE SETS DISP,AREA&BASE
%FINISH %ELSE %START; ! ARRAY RELATIVE HEAD IN GLA
%IF MODE=2 %AND BS=RBASE %THEN W=DP+4 %ELSESTART
FETCH RAD; ! RECORD ADDR TO ACC
GET WSP(W,1)
PSF1(ST,1,W); XD=0
%FINISH
CANAME(1,0,Q); ! RECORD REL ARRAY ACCESS
%IF PARMARR=0 %AND (PREC=3 %OR TYPE>=3) %THEN %START
PSF1(ADB,1,W)
PSF1(ADB,0,XD) %UNLESS XD=0
GRUSE(BREG)=0
%FINISH %ELSE %START
GET IN ACC(DR,2,0,AREA CODE,Q)
PSF1(INCA,1,W)
PSF1(INCA,0,XD) %UNLESS XD=0
FORGET (DR)
ACCESS=3
%IF TYPE=3 %OR Z=4 %START; ! WILL BE A FURTHER CALL
! ON ROUTINE CENAME
GET WSP(DISP,2)
PSF1(STD,1,DISP)
AREA=LNB; BASE=RBASE
%FINISH %ELSE AREA=7 %AND DISP=0
%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. NEST DEFINES LENREG *
!***********************************************************************
%INTEGER PP,WKAREA,DOTS,REXP,ERR,CLEN,KEEPWA
%INTEGERFNSPEC STROP
KEEPWA=MODE&16; MODE=MODE&15
PP=P; STRINGL=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
-> ERROR %UNLESS ERR=0
VALUE=0
P=P+1; NEST=0
%IF REG=ACCR %THEN COPY DR
%RETURN
ERROR: FAULT(ERR,0)
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; ! 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
!***********************************************************************
!* DEALS WITH OPERAND FOR CONCATENATION. RETURN RESULT=0 FOR *
!* VALID OPERAND OTHERWISE AN ERROR NUMBER. *
!***********************************************************************
%INTEGER CTYPE,VAL,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=5 %THEN %START
STRINGL=A(P+6)
DISP=FROM AR4(P+2)
P=P+STRINGL+7
%FINISH %ELSE %START
VAL=FROM AR4(P+2)
%RESULT=71 %UNLESS CTYPE=X'51' %AND VAL=0
P=P+6
DISP=0
STRINGL=0
%FINISH
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
%FINISH %ELSE %START
P=P+1; ! MUST CHECK FIRST
REDUCE TAG; ! SINCE CNAME ONLY LOADS STRINGS
%RESULT=71 %IF 7#TYPE#5; ! AND LONGINTS TO DR!
CNAME(2,DR)
STRINGL=0
%FINISH
%RESULT=0
%END; ! OF INTEGERFN STROP
%END; ! OF ROUTINE CSTREXP
%ROUTINE CRES (%INTEGER LAB)
!**********************************************************************
!* COMPILES A RESOLUTION E.G A->B.(C).D.(E).F AND JUMPS TO LAB *
!* ON FAILURE. (LAB=0 FOR UNCONDITIONAL RESOLUTION TO PERM ON *
!* FAILURE ). *
!* THE METHOD IS TO CALL A SUBROUTINE PASSING 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
%RECORD R(RD)
LAST=0; ! =1 WHEN END OF EXPRNSN FOUND
SEXPRN=0; ! RESOLUTION(BRKTD) EXPRESSNS
PSF1(INCA,0,1); ! TO FIRST CHAR
P1=P; P=P+3
->RES %IF A(P)=4 %AND TYPE=5; ! LHS MUST BE A STRING
ERROR: FAULT(74,0)
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) %ELSE %START;! B OMITTED
->ERROR %UNLESS A(P)=1; ! P(OPERAND)=NAME
P=P+1; P2=P
CNAME(3,ACCR)
->ERROR %UNLESS TYPE=5 %AND A(P+1)=CONCOP;! DOT OPERATOR
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
->ERROR %UNLESS A(P+1)=CONCOP %AND A(P+2)=1
P2=P+1; P=P2+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 *
!***********************************************************************
%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)
PF1(LSS,2,7,0)
PSF1(STD,1,N)
PSF1(ST,1,N+8)
AUXSBASE(LEVEL)=N; N=N+16
GRUSE(DR)=0; GRUSE(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<<LEVEL
!
! FIRST CHECK FOR ANY '%STARTS' WITHOUT FINISHES
!
%WHILE SBR(LEVEL)#0 %CYCLE
FROM12 (SBR(LEVEL),J,KP)
FAULT(53,0); ! FINISH MISSING
A(2)=4; A(3)=3; CSS(2); ! SO COMPILE IT IN
%REPEAT
!
! NOW PLANT AN ERROR EXIT FOR FNS AND MAPS - CONTROL SHOULD BE RETURNED
! VIA %RESULT= AN SHOULD NEVVER REACH THE %END INSTRUCTION
!
%IF KKK&X'3FFF'>X'1000' %AND 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'
CLEAR LIST(J)
%IF 0<KP<=MAX ULAB %THEN FAULT(11,KP)
%FINISH %ELSE %START
%IF I=0 %AND KP<MAX ULAB %THEN WARN(3,KP)
%FINISH
%REPEAT
!
%CYCLE JJ=0,1,4
CLEAR LIST(AVL WSP(JJ,LEVEL));! RELEASE TEMPORARY LOCATIONS
%REPEAT
!
DTABLE(LEVEL); ! OUTPUT DIAGNOSTIC TABLES
!
! CLEAR DECLARATIONS - POP UP ANY GLOBAL NAMES THAT WERE REDECLARED
! DESTROY SIDE CHAINS FOR ROUTINES,FORMATS AND SWITCHES
!
!
! CHECK FOR MISSING REPEATS
!
%WHILE CYCLE(LEVEL)#0 %THEN FAULT(13,0)%AND %C
POP(CYCLE(LEVEL),I,I,I)
!
! NOW CLAIM THE STACK FRAME BY FILING THE ASF IN THE BLOCK ENTRY CODING
!
NMAX=(NMAX+3)&(-4)
%IF KKK=2 %THEN %RETURN
%IF KKK>=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 %C
FAULT(14,0) %AND %STOP
%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 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
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)<<20 ! 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
%RECORDNAME LCELL(LISTF)
%CONSTINTEGER LARRROUT=X'F300'
%INTEGER DPTR,LNUM,ML,KK,JJ,Q,DEND,BIT,S1,S2,S3,S4,LANGD,II
%INTEGERARRAY DD(0:300); ! BUFFER FOR SEGMENT OF SST
!
! FILL ALL OUTSTANDING REFERENCES TO THIS DIAGS BLOCK
!
BIT=1<<LEVEL
LANGD=KKK>>14<<30!LEVEL<<18; ! GET LITL FROM PTYPE
%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)
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<X'3FFF' %CYCLE
LCELL==ASLIST(TAGS(JJ))
! OBTAIN NEXT NAME FORM DECLNS
%IF LCELL_S1&X'F000'=0 %THEN WARN(2,JJ)
!
! GET ONLY THE MINIMUM OF DETALS NECESSARY
!
S1=LCELL_S1; S2=LCELL_S2
S3=LCELL_S3; S4=LCELL_LINK
LCELL_LINK=ASL; ASL=TAGS(JJ)
TAGS(JJ)=S4&X'3FFFF'
PTYPE=S1>>16; TYPE=PTYPE&15
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<297 %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 %THEN FAULT(28,JJ);! SPEC BUT NO BODY GIVEN
%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
%INTEGERNAME THEAD
%RECORDNAME CELL(LISTF)
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; CLT
%IF PREC=3 %OR A(P)#1 %OR A(P+1)# 3 %START
INSERT AT END(HEAD,X'FFFF',QQ,0) %IF A(P)=1
%FINISH %ELSE %START
PRIO=PREC<<4!TYPE
THEAD==HEAD
%CYCLE
CELL==ASLIST(THEAD)
%IF THEAD=0 %OR PRIO<CELL_S1 %THEN %C
PUSH(THEAD,PRIO,QQ,0) %AND %EXIT
THEAD==CELL_LINK
%REPEAT
%FINISH
QQ=FROM AR4(QQ+6)
%REPEAT
!
! NOW MAKE THE ORDEREED DECLARATIONS
! FIRST GRAB TWO TEMPORARIES IF SPACE IS LIKELY TO BE TIGHT
!
%IF COUNT>=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+10; CLT
ROUT=0; LITL=0
CQN(P+1); P=P+2
DECLARE SCALARS(1,0)
%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. *
!***********************************************************************
%INTEGER INC,Q,SCHAIN,DMADE,D0
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 %THEN FAULT(70,0)
%IF PERMIT#0 %AND (INC=8 %OR INC=16) %THEN ODD ALIGN
%IF PTYPE=X'33' %OR (PTYPE=X'35' %AND PERMIT#0)%START
D0=X'18000000'+ACC
STORE CONST(Q,4,ADDR(D0))
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' %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
K=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
%IF ROUT=1 %THEN %START
SCHAIN=0; J=13
PUSH(SCHAIN,N,1000,0)
%FINISH
KFORM=XTRA
P=P+3
%IF PTYPE=X'33' %THEN %START
PSF1(STD,1,N)
N=N+8; SCHAIN=N
%IF A(P-1)=1 %THEN PSF1(INCA,0,INC+8)
%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(K,SCHAIN)
N=N+INC
%REPEAT
N=(N+3)&(-4) %IF PERMIT#0;! NO ROUNDING AMONG PARAMS
%END
%INTEGERFN DOPE VECTOR(%INTEGER TYPEP, ELSIZE, %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<CBPAIR> *
!* 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) *
!***********************************************************************
%INTEGER I, JJ, K, ND, D, UNSCAL, PP, M0, HEAD
%RECORDNAME LCELL(LISTF)
%INTEGERARRAY DV(0:39); ! ENOUGH FOR 12 DIMENSIONS
ND=0; PP=P
ND=ND+1 %AND P=P+13 %UNTIL A(P)=2
P=PP
!
! NOW ONE CAN WORK OUT AND FILL IN THE TRIPLES
!
%IF TYPEP>2 %OR (TYPEP=1 %AND PREC=4)%C
%THEN UNSCAL=1 %AND M0=ELSIZE %C
%ELSE UNSCAL=0 %AND M0=1
%CYCLE D=ND,-1,1
CBPAIR(I, JJ)
K=3*D
DV(K)=I
DV(K+1)=M0
M0=M0*(JJ-I+1)
DV(K+2)=M0
%REPEAT
P=P+1
!
%IF UNSCAL=0 %THEN M0=M0*ELSIZE
%IF ND=1 %THEN LB=I
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
%RESULT =I
%END
%ROUTINE DECLARE ARRAYS(%INTEGER FORMAT, FINF)
!***********************************************************************
!* FORMAT=1 FOR 'ARRAYFORMAT' =0 OTHERWISE *
!* FINF>0 FOR RECORD FORMAT INFORMATION =0 OTHERWISE *
!* P IS AT P<ADECLN> IN *
!* *
!* P<ADECLN>=<NAMELIST> <BPAIR> <RESTOFDECLN> *
!* P<BPAIR> = <CBPAIR>,'('<EXPR>':'<EXRR><RESTOFBP>*')' *
!* *
!* ARRAYS WITH CONSTANT BOUNDS HAVE THEIR D-V IN THE SST *
!* ALL OTHER ARRAYS HAVE A DOPE VECTOR AMONG THE LOCALS AND GET *
!* THEIR SPACE OFF THE STACK AT RUN TIME *
!* BOTH SORTS OF ARRAYS HAVE A FOUR WORD HEAD AND D-V TO EMAS *
!* SYSTEM STANDARDS *
!***********************************************************************
%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
%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; SNDISP=0
%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
%IF A(P)=1 %THEN ->CONSTDV; ! P<BPAIR> =<CBPAIR>
! NORMAL CASE - PLANT CODE TO SET UP DOPE-VECTOR AT RUN TIME
ND=0; JJ=P; DVF=0; TOTSIZE=X'FFFF'
%UNTIL A(P)=2 %CYCLE; ! TILL NO MORE BPAIRS
P=P+1; ND=ND+1; ! COUNT NO OF DIMENSIONS
SKIP EXP; SKIP EXP
%REPEAT
P=JJ; DVDISP=N; ! DVDISP IS D-V POSITION
N=N+12*ND+12; ! CLAIM SPACE FOR THE D-V
FAULT(37,0) %IF ND>12; ! TOO MANY DIMENSIONS
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<=2 %AND FORMAT=0 %AND GRUSE(ACCR)=5 %C
%AND GRINF(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)
->DECL
CONSTDV: ! ONE DIMENSION - CONSTANT BOUNDS
DVF=1; P=P+1; CDV=1
DVDISP=DOPE VECTOR(TYPE,ELSIZE,TOTSIZE,LWB);! AND GENERATE A D-V
ND=J
%IF ND=1 %AND LWB=0 %AND TYPE<=2 %C
%AND FORMAT=0 %THEN PTYPEPP=PTYPEP+256
! SET ARR=2 IF LWB=ZERO
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(LSS,0,PC,D1)
%FINISH %ELSE %START
STORE CONST(D1,4,ADDR(DESC))
PF1(LSS,0,PC,D1)
PSF1(OR,1,DVDISP+20) %UNLESS PREC=4
%FINISH
%IF DVF#0 %THEN QQ=PC %ELSE QQ=LNB
PSORLF1(LDRL,0,QQ,DVDISP)
%CYCLE JJJ=0,1,NN-1; ! DOWN NAMELIST
PSF1(ST,1,N+16*JJJ); ! ARRAY BOUND
PSF1(STD,1,N+8+16*JJJ); ! DV POINTER
%REPEAT
%CYCLE JJJ=0,1,NN-1; ! DOWN NAMELIST
%IF PARMARR=0 %AND ND=1 %AND TYPE<=2 %AND PTYPEPP&X'F00'#2 %C
%START
! ADJUST DESC
%IF DVF#0 %THEN %START
PSF1(LSS,0,LWB*ELSIZE)
%FINISH %ELSE %START
PSF1(LSS,1,DVDISP+12)
PSF1(IMY,0,ELSIZE) %UNLESS ELSIZE=1
%FINISH
%IF STACK#0 %THEN %START
PF1(STSF,0,TOS,0)
PF1(IRSB,0,TOS,0)
%FINISH %ELSE PSF1(IRSB,2,AUXSBASE(LEVEL))
PSF1(ST,1,N+4)
%FINISH %ELSE %START; ! NO ADJUSTMENT OF DESCRPT
%IF STACK#0 %THEN PSF1(STSF,1,N+4) %ELSE %START
PSF1(LSS,2,AUXSBASE(LEVEL))
PSF1(ST,1,N+4)
%FINISH
%FINISH
ACC=ELSIZE; ! RESET ACC AFTER DV CMPLD
KFORM=FINF; ! FORMAT INFORMATION
K=FROM AR2(PP+3*JJJ)
STORE TAG(K,N)
N=N+16
CLAIM AS
%REPEAT
P=P+1; ! PAST REST OF ARRAYLIST
%IF A(P-1)=1 %THEN ->START
GRUSE(ACCR)=0
GRUSE(DR)=0
%RETURN
%ROUTINE CLAIM AS
!***********************************************************************
!* CLAIM THE SPACE FOR AN ARRAY FROM STACK OR AUX STACK *
!***********************************************************************
%INTEGER T, D
%IF FORMAT#0 %THEN %RETURN
%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
PSF1(LSS,1,DVDISP+8); ! ARRAY SIZE BYTES
PSF1(IAD,0,3)
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
CHECK STOF
%FINISH %ELSE %START
%IF CDV=1 %THEN %START
TOTSIZE=(TOTSIZE+3)&(-4)
%IF TOTSIZE<X'1FFFF' %THEN PSF1(LSS,0,TOTSIZE) %C
%ELSE %START
STORE CONST(D,4,ADDR(TOTSIZE))
PF1(LSS,0,PC,D)
%FINISH
%FINISH %ELSE %START
PSF1(LSS,1,DVDISP+8)
PSF1(IAD,0,3)
PSF1(AND,0,-4)
%FINISH
%IF PARMCHK#0 %THEN %START
PF1(ST,0,TOS,0)
PSF1(LB,2,AUXSBASE(LEVEL))
FORGET(BREG)
PF1(IAD,0,BREG,0)
%FINISH %ELSE PSF1(IAD,2,AUXSBASE(LEVEL))
PF1(ST,2,7,0); ! STORE UPDATED POINTER
%IF PARMOPT#0 %THEN %START
PF1(ICP,1,0,2)
PPJ(2,8)
%FINISH
%IF PARMCHK#0 %START
PF1(LDTB,0,PC,PARAM DES(3))
PF1(LDB,0,TOS,0)
PF1(LDA,0,BREG,0)
PF2(MVL,1,1,0,0,UNASSPAT&255)
%FINISH
%FINISH
FORGET(ACCR)
%END
%END
! %ROUTINE TEST NST
!!***********************************************************************
!!* SEE IF NAME 'K' HAS BEEN DECLARED BEFORE AT THIS LEVEL *
!!***********************************************************************
! FNAME=K
! FAULT(7,FNAME) %IF FROM1(TAGS(FNAME))>>8&15=LEVEL
! %END
%ROUTINE CLT
!***********************************************************************
!* DEAL WITH PHRASE TYPE AND SET PREC,TYPE & ACC *
!* ONLY PROBLEM IS STRING WHICH HAS OPTIONAL MAX LENGTH ALSO *
!* P ON PHRASE TYPE AT ENTRY - TO NEXT PHRASE AT EXIT. *
!***********************************************************************
%CONSTBYTEINTEGERARRAY TYPEFLAG(1:10)= %C
X'51',X'52',0,X'31',X'35',
X'41',0,X'62',X'61',X'72';
%INTEGER ALT
ALT=A(P)
TYPE=TYPEFLAG(ALT)
%IF TYPE=0 %THEN P=P+1 %AND TYPE=TYPEFLAG(A(P)+7)
PREC=TYPE>>4
TYPE=TYPE&7
PREC=6 %IF TYPE=2 %AND ALL LONG#0 %AND PREC<=5;! DEAL WITH '%REALSLONG'
ACC=BYTES(PREC)
%IF TYPE=5 %THEN %START; ! P<TYPE>='%STRING'
%IF A(P+1)=1 %THEN %START;! MAX LENGTH GIVEN
P=P+2
ACC=A(P)+1
%FINISH %ELSE ACC=0 %AND P=P+1
%FINISH
P=P+1
%END
%ROUTINE CQN(%INTEGER P)
!***********************************************************************
!* SET NAM,ARR & ACC FROM ALTERNATIVE OF PHRASE <QNAME'> *
!* P<QNAME'>='%ARRAYNAME','%NAME',<%NULL> *
!* P POINTS TO THE ANALYSIS RECORD ENTRY AS IS NOT UPDATED *
!***********************************************************************
%INTEGER I
I=A(P);NAM=0;ARR=0
%IF I=1 %THEN ARR=1 %AND ACC=16;! ARRAYNAMES
%IF I<=2 %THEN NAM=1; ! ARRAYNAMES & NAMES
%IF I=2 %THEN ACC=8; ! NAMES USE 8-BYTE DESCRIPTOR
%END
%ROUTINE CRSPEC (%INTEGER M)
!***********************************************************************
!* MODE=0 FOR NORMAL ROUTINE SPEC *
!* MODE=1 FOR EXTERNAL(ETC) ROUTINE SPECS XREF NEEDED *
!* MODE=2 FOR %SPEC FOR RT PARAMS *
!***********************************************************************
%INTEGER KK,JJ,Q,TYPEP,INC,PPOSN,OPHEAD,OPBOT
%STRING(34) XNAME
Q=0; LITL=EXTRN&3
%IF M#2 %THEN %START
!
! WORK OUT TYPEP IE TYPE OF ENTITITY BY INSPECTING AR FOR P<RT>
!
%IF A(P+1)=1 %THEN %START; ! P<RT>=%ROUTINE
TYPEP=LITL<<14!X'1000'; P=P+3
%FINISH %ELSE %START; ! P<RT>=<TYPE><FNORMAP>
ROUT=1; ARR=0; P=P+2
CLT; NAM=(A(P)-1)<<1
PACK(TYPEP)
P=P+2
%FINISH
P=P+4; ! PAST HOLE FOR DECLINKS
%FINISH
KK=FROM AR2(P); COPYTAG(KK)
!
! IF KK IS A VALID RT TYPE PARAM IT MUST BE DECLARED AT THE CURRENT
! LEVEL AND HAVE 1000 PARAMS. IF KK IS A NEW DECLARATION '%SPEC' CANNOT
! BE USED AND THE NAME MUST NOT BE SET AT THE CURRENT LEVEL.
!
OPHEAD=K
%IF SNPT#PTYPE>=X'1000' %THEN FROM12(OPHEAD,JJ,Q)
%UNLESS OLDI=LEVEL %AND Q=1000 %AND %C
(M=2 %OR PTYPE&X'FBFF'=TYPEP) %THEN %START
!
! KK IS NOT A VALID RT TYPE PARAM
!
%UNLESS OLDI#LEVEL %AND M<=1 %THEN %START;! KK VALID DECLN
%IF M#0 %THEN FAULT(7-M>>1<<2,KK) %AND %RETURN
! FAULT 3(SPEC?)OR 7(SET TWICE)
! STORE TAG GIVES FAULT(7) FOR
! M=0 WHEN REPLACE TAG ESSENTIAL
%FINISH
JJ=0; OPHEAD=NEWCELL; ! SO MAKE DECLARATION
J=15-M; PTYPE=TYPEP
KFORM=0; ACC=0; SNDISP=0
STORE TAG(KK,OPHEAD)
%FINISH
PPOSN=20; ! DISPLCMENT OF EACH PARAM
INC=1
P=P+2; Q=0; ! Q COUNTS NO OF FORMAL PARAMS
OPBOT=OPHEAD
%WHILE A(P)=1 %CYCLE; ! WHILE SOME(MORE) FPS
P=P+INC; ! P<COMMA'> BETWEEN FPDELS
CFPDEL; ! GET TYPE & ACC FOR NEXT GROUP
%IF KFORM=1 %THEN PPOSN=PPOSN+3
%UNTIL A(P-1)=2 %CYCLE; ! DOWN <NAMELIST> FOR EACH DEL
BINSERT(OPHEAD,OPBOT,PTYPE,ACC<<16!PPOSN,0)
Q=Q+1; P=P+3
%IF PTYPE=X'35' %THEN PPOSN=PPOSN+3 %ELSE PPOSN=PPOSN+ACC
%REPEAT
INC=2; ! TO IGNORE ALT OF P<COMMA'>
%REPEAT
%IF M=1 %THEN %START
XNAME<-STRING(DICTBASE+WORD(KK))
%IF EXTRN=1 %THEN XNAME<-'S#'.XNAME
CXREF(XNAME,0,2,JJ)
%FINISH
%IF M=0 %AND RLEVEL=0 %THEN CODE DES(JJ)
REPLACE123(OPHEAD,JJ,Q,0)
%END
%ROUTINE CFPDEL
!***********************************************************************
!* SET UP PTYPE & ACC FOR A LIST OF FORMAL PARAMETERS *
!* P<FPDEL>=<RT><%NAME'>,<TYPE><%QNAME'>,'%NAME', *
!* '%RECORD'<%ARRAY'>'%NAME'. *
!***********************************************************************
%SWITCH FP(1:4)
%INTEGER FPALT
FPALT=A(P); P=P+1; KFORM=4; LITL=0
->FP(FPALT)
FP(1): ! (TYPE)(FMQNAME)
ROUT=0; CLT
%IF A(P)=1 %THEN %START; ! FN OR MAP
ROUT=1; P=P+1; ARR=0
NAM=(A(P)-1)<<1+1; ! 1 FOR FN 3 FOR MAP
P=P+2; ACC=16
%FINISH %ELSE %START
P=P+1; CQN(P)
FAULT(70,0) %IF TYPE=5 %AND ACC=0
%IF NAM=0 %AND PREC=3 %AND TYPE=1 %THEN KFORM=1;! BYTE BY VALUE
P=P+1
%FINISH
->PK
FP(2): ! RECORD(%ARRAY')%NAME
ARR=2-A(P); ROUT=0
ACC=8+8*ARR; TYPE=3; PREC=3
NAM=1; P=P+1; ->PK
FP(3): ! %ROUTINE (%NAME')
ROUT=1; NAM=1
ARR=0; TYPE=0; PREC=0
P=P+1; ACC=16
->PK
FP(4): ! %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) %IF LEVEL=MAX LEVELS
FAULT(105, 0) %IF LEVEL>MAX LEVELS
%IF KK>=0 %AND RLEVEL>1 %START;! ROUTINE ENTRY
COPY TAG(KK); JJ=K; ! LIST OF JUMPS
J=FROM1(JJ)
%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
REPLACE1(JJ, 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=WORD(KK)
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
%IF LEVEL#2 %THEN %START
! PF1(LXN,0,TOS,0)
GRUSE(XNB)=4; GRINF(XNB)=RLEVEL-1; GRAT(XNB)=CA
GRUSE(CTB)=0; GRUSE(BREG)=0
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 %START; ! ENSURE FNS RETURN RIGHT ACS
CHECK STOF; ! CHECK FOR STACK O'FLOW
%FINISH
%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,0,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
%SWITCH SW(1:8)
REPORTUI=0; ->SW(A(P))
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(MASK,LNAME,0)
REPORTUI=1 %IF MASK=15
%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,LNAME); P=P-1; SKIP APP
%RETURN
%FINISH
LWB=FROM2(K); ! GET LOWER BOUND
CSEXP(BREG,X'51')
%IF ARRP=1 %THEN %START
PSF1(SBB,0,LWB) %UNLESS LWB=0
%FINISH %ELSE PSF1(MYB,0,2)
XYNB=SET XORYNB(-1,-1); ! TO PLT
PF1(LB,3,XYNB,GWRDD); ! RELATIVE DISP TO B
PF1(ADB,0,XYNB,GWRDD+4); ! MAKE ABSOLUTE
PF1(JUNC,0,BREG,0); ! AND JUMP TO IT
REPORTUI=1; FORGET(-1)
%FINISH
%RETURN
SW(3): ! RETURN
FAULT(30,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
CNAME(4,ACCR)
FAULT(81,0) %UNLESS A(P)=2; P=P+1
FAULT(83,0) %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(LD,1,DISPLAY(RBASE)-8)
PF1(LDB,2,7,0)
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)
P=P+2; SKIP EXP; ! IGNORE SPURIOUS RESULT
%RETURN
SW(5): ! %MONITOR (AUI)
PSF1(LSS,0,0); ! ERR=0
PF1(ST,0,TOS,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,0) %UNLESS 1<=J<=14
%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
KK=FROM2(CYCLE(LEVEL))
%IF KK=-1 %THEN FAULT(54,0) %AND %RETURN
REPLACE2(CYCLE(LEVEL),KK!X'80000000')
ENTER JUMP(MASK,KK>>16&X'7FFF',B'10')
REPORTUI=1 %IF MASK=15
CURR INST=1 %IF CODE=0
%END
%ROUTINE CSTART(%INTEGER CODE)
!***********************************************************************
!* NOTE A START FOR APPROPIATE ACTION AT THE FINISH *
!***********************************************************************
SFLABEL=SFLABEL-1
PUSH(SBR(LEVEL),CODE,SFLABEL,CYCLE(LEVEL))
%END
%ROUTINE ASSIGN(%INTEGER ASSOP,P1)
!***********************************************************************
!* HANDLES ARITHMETIC,STRING & ADDRESS ASSIGNMENTS TO VARIABLES *
!* FORMAL PARAMETERS AND DOPEVECTORS *
!* ASSOP:- *
!* 1 IS FOR '==' *
!* 2 IS FOR '=' *
!* 3 IS FOR '<-' (JAM TRANSFER) *
!* 4 IS FOR '->' (UNCONDITIONAL RESOLUTION) *
!* >4 IS FOR STORE ACC BY 'ASSOP&3' INTO NAME *
!* *
!* P POINTS TO THE EXPRESSION. P1 TO THE NAME ON LHS *
!***********************************************************************
%INTEGER Q,QQ,KK,TYPEP,PRECP,PTYPEP,JJJ,P2,JJ, %C
RHTYPE,ACCP,II,HEAD1,NOPS,TPCELL,LVL,BOT1
%RECORD R(RD)
%SWITCH SW(0:3); ! TO SWITCH ON ASSOP
P2=P
%IF ASSOP>4 %THEN RHTYPE=TYPE
P=P1; REDUCE TAG; ! LOOK AT LH SIDE
PTYPEP=PTYPE; JJ=J
KK=K; II=I; LVL=OLDI
TPCELL=TCELL; ACCP=ACC
P=P2; TYPEP=TYPE; PRECP=PREC; ! SAVE USEFUL INFO FOR LATER
-> SW(ASSOP&3)
!
SW(2):SW(3): ! ARITHMETIC ASSIGNMENTS
%IF TYPE=3 %THEN ->RECOP
TYPE=1 %UNLESS TYPE=2 %OR TYPE=5;! IN CASE OF RUBBISHY SUBNAMES
->ST %IF TYPE=5; ! LHS IS A STRING
BACK: HEAD1=0; ! CLEAR TEMPORAYRY LIST HEADS
TYPE=1 %UNLESS TYPE=2; ! DEAL WITH UNSET NAMES
TYPEP=TYPE
NOPS=1<<18+1; P=P2+3
PUSH(HEAD1,ASSOP&3+33,PRECP,0); ! ASSIGNMENT OPERATOR
BOT1=HEAD1
PUSH(HEAD1,PTYPEP<<16!2,P1,0); ! LHS
%IF ASSOP>4 %THEN %START
FAULT(24,0) %UNLESS TYPE=RHTYPE
PUSH(HEAD1,RHTYPE<<16!9,0,0)
OLINK(ACCR)=HEAD1
%FINISH %ELSE TORP(HEAD1,BOT1,NOPS); ! RHS TO REVERSE POLISH
Q=P; EXPOP(HEAD1,-1,NOPS,256+PRECP<<4+TYPEP); ! PLANT CODE
P=Q
! CLEAR LIST(HEAD1)
ASLIST(BOT1)_LINK=ASL
ASL=HEAD1
%RETURN
!NA: NOTE ASSMENT(-1,ASSOP&3,A(P1))
ST: ! STRINGS
!
! PICK OFF NULL STRINGS AND SUBSTITUTE A CRAFTY MVL FOR S='' OR S=""
!
%IF A(P+3)=4 %AND A(P+4)=2 %AND((A(P+5)=X'51' %AND %C
FROMAR4(P+6)=0 %AND A(P+10)=2) %OR %C
(A(P+5)=5 %AND A(P+10)=0 %AND A(P+11)=2)) %THEN %START
Q=P+12-A(P+10)>>1
P=P1; CNAME(1,DR)
PF2(MVL,0,1,0,0,0)
P=Q; %RETURN
%FINISH
%IF ASSOP<=3 %THEN CSTREXP(0,ACCR)
ASSOP=ASSOP&3
QQ=STRINGL; Q=P
REGISTER(ACCR)=1
OLINK(ACCR)=ADDR(R)
R_PTYPE=X'51'; R_FLAG=9; R_UPTYPE=0
R_XB=ACCR
P=P1; CNAME(1,DR)
%IF R_FLAG#9 %THEN PF1(LSD,0,TOS,0)
PF1(IAD,0,PC,SPECIAL CONSTS(2))
%IF (ROUT#0 %OR NAM#0=ARR) %AND QQ=0 %START; ! LHS=MAP : DR BOUND NOT VALID
%IF PARMOPT#0 %THEN PPJ(0,18) %ELSE %START
PF1(STUH,0,BREG,0)
PF1(LUH,0,BREG,0)
PF1(LDB,0,BREG,0)
%FINISH
GRUSE(BREG)=0
%FINISH
GRUSE(ACCR)=0
REGISTER(ACCR)=0
%IF QQ>0 %AND ASSOP#3 %THEN PF2(MV,0,0,QQ,0,0) %ELSESTART
%IF ASSOP=3 %THEN PF1(STD,0,TOS,0)
PF2(MV,1,1,0,0,UNASSPAT&255)
%IF PARMARR#0 %OR ASSOP=3 %THEN PSF1(USH,0,8) %ANDC
PSF1(USH,0,-40)
%IF PARMARR#0 %AND ASSOP=2 %THEN PPJ(36,9)
%IF ASSOP=3 %THEN %START
PF1(IRSB,2,TOS,0)
PF1(ST,2,7,0); ! STORE AMENDED CURRENT LENGTH
%FINISH
%FINISH
P=Q; %RETURN
!
! THIS SECTION DEALS WITH OPERATIONS ON COMPLETE RECORDS
!
RECOP: ! LHS IS RECORD WITHOUT SUBNAME
Q=TSEXP(JJJ)
%IF Q=1 %AND JJJ=0 %START; ! CLEAR A RECORD TO ZERO
P=P1; CNAME(3,DR)
%IF ACC<=128 %THEN JJ=0 %AND KK=ACC-1 %ELSE %START
JJ=1; KK=0
%IF NAM#0 %THEN PSF1(LDB,0,ACC)
%FINISH
PF2(MVL,JJ,1,KK,0,0)
%FINISH %ELSE %START
->BACK %UNLESS TYPE=3 %AND A(P2+3)=4 %AND A(P2+4)=1
P=P2+5; CNAME(3,ACCR)
ACCP=ACC
->F66 %UNLESS A(P)=2
R_PTYPE=X'61'; R_FLAG=9
R_XB=ACCR<<5; R_D=0
OLINK(ACCR)=ADDR(R)
REGISTER(ACCR)=1
P=P1; CNAME(3,DR)
REGISTER(ACCR)=0
%IF R_FLAG#9 %THEN PF1(LSD,0,TOS,0)
->F66 %IF ASSOP=2 %AND ACCP#ACC
%IF ACCP>ACC %THEN ACCP=ACC
%UNTIL ACCP=0 %CYCLE
%IF ACCP>128 %THEN KK=128 %ELSE KK=ACCP
PF2(MV,0,0,KK-1,0,0)
ACCP=ACCP-KK
%REPEAT
GRUSE(ACCR)=0
%FINISH
P=P2; SKIP EXP
GRUSE(DR)=0
%RETURN
SW(0): ! RESOLUTION
P=P1; CNAME(2,DR)
P=P2; CRES(0); %RETURN
SW(1): ! '==' AND %NAME PARAMETERS
->F2 %UNLESS A(P2+3)=4 %AND A(P2+4)=1
Q=82 %AND ->F00 %UNLESS NAM=1; ! ONLY POINTERS ON LHS OF==
P=P2+5; ->ARRNAME %IF ARR=1
CNAME(3,ACCR); ! DESCRPTR TO ACC
R_PTYPE=X'61'; R_FLAG=9
R_XB=ACCR
OLINK(ACCR)=ADDR(R)
REGISTER(ACCR)=1
->F2 %UNLESS A(P)=2; ! NO REST OF EXP ON LHS
Q=P+1; P=P1
Q=83 %AND ->F00 %UNLESS TYPE=TYPEP %AND PREC=PRECP
CNAME(6,0)
%IF R_FLAG#9 %THEN PF1(LSD,0,TOS,0) %AND GRUSE(ACCR)=0
REGISTER(ACCR)=0
COM: PSORLF1(ST,ACCESS,AREA CODE,DISP)
NOTE ASSMENT(ACCR,1,A(P1)<<8!A(P1+1))
P=Q; %RETURN
ARRNAME: CNAME(12,ACCR)
%IF ACCESS>=8 %THEN ACCESS=ACCESS-4 %ELSE ACCESS=0
Q=83 %AND ->F00 %UNLESS TYPE=TYPEP %AND PREC=PRECP %C
%AND ARR>0 %AND OLDI<=LVL
TYPE=0
NAMEOP(2,ACCR,16,-1)
R_PTYPE=X'72'; R_UPTYPE=0
R_FLAG=9; R_XB=ACCR
R_D=-1
REGISTER(ACCR)=1
OLINK(ACCR)=ADDR(R)
->F2 %UNLESS A(P)=2
Q=P+1; P=P1
CNAME(6,0)
PF1(LSQ,0,TOS,0) %UNLESS R_FLAG=9
REGISTER(ACCR)=0
->COM
F66: Q=66; ->F00
F2: Q=81; ! RHS AN EXPRSSN
F00:
REGISTER(ACCR)=0
%IF Q=82 %THEN JJ=FROM AR2(P1) %ELSE JJ=0
FAULT(Q,JJ)
P=P2; SKIP EXP
%END
%ROUTINE CSEXP(%INTEGER REG,MODE)
!***********************************************************************
!* COMPILE A SIGNED EXPRESSION TO REGISTER 'REG' IN MODE 'MODE' *
!* MODE=1 FOR %INTEGER, =2 REAL, =3 LONG,=0 INTEGER %IF POSSIBLE *
!* MODE=5 FOR ADDRESS EXPRESSNS(IE LEAVE ANY CONSTANT IN 'ADISP')*
!***********************************************************************
%INTEGER EXPHEAD,NOPS,PP,BDISP,EXPBOT
EXPHEAD=0; EXPBOT=0
NOPS=0
P=P+3
TORP(EXPHEAD,EXPBOT,NOPS)
%IF EXPHEAD=0 %THEN NEST=0 %AND %RETURN;! EXPR CONSTANT ONLY
!
BDISP=ADISP
PP=P
EXPOP(EXPHEAD,REG,NOPS,MODE)
P=PP
ADISP=BDISP
! CLEAR LIST(EXPHEAD)
ASLIST(EXPBOT)_LINK=ASL
ASL=EXPHEAD
%END
%ROUTINE TORP(%INTEGERNAME HEAD,BOT,NOPS)
!***********************************************************************
!* CONVERT THE SIGNED EXPRESSION INDEXED BY P INTO REVERSE *
!* POLISH NOTATION. THE REVERSE POLISH LIST IS ADDED TO 'HEAD' *
!* WHICH MAY CONTAIN ANOTHER EXPRESSION. THE NUMBER OF OPERATORS *
!* IS ADDED TO NOPS. *
!* N.B. AN INTEGER EXPRESSION IS A SPECIAL CASE OF A REAL EXPRSN *
!***********************************************************************
%SWITCH OPERAND(1:3)
%CONSTBYTEINTEGERARRAY PRECEDENCE(1:15)=3,3,4,5,5,4,3,3,4,4,5,5,3,5,5;
%CONSTBYTEINTEGERARRAY OPVAL(1:15)=20,21,27,37,30,24,22,23,25,26,
28,29,20,37,30;
%INTEGER RPHEAD,PASSHEAD,SAVEHEAD,REAL,REALOP,COMPLEX,%C
OPERATOR,OPPREC,OPND,C,D,E,RPTYPE,RPINF,BDISP,%C
OPNAME,OPMASK,XTRA,RPBOT,OPSTK,OPPSTK,PASSBOT
%RECORDNAME LCELL(LISTF)
!
PASSHEAD=0; RPHEAD=0; SAVEHEAD=0
REAL=0; REALOP=0; BDISP=0
RPBOT=0; OPSTK=0; OPPSTK=0
!
C=A(P)
%IF 2<=C<=3 %THEN %START; ! INITIAL '-' OR '\'
NOPS=NOPS+1
! '-' =(11,3) '\' =(10,5)
OPSTK=4-C
OPPSTK=C<<1-1
OPMASK=1<<(19+C); ! - %OR !!
%FINISH %ELSE OPMASK=0
NEXTOPND:OPND=A(P+1); P=P+2
COMPLEX=0; XTRA=0
-> OPERAND(OPND); ! SWITCH ON OPERAND
OPERAND(1): ! NAME
OPNAME=A(P)<<8+A(P+1)
LCELL==ASLIST(TAGS(OPNAME))
PTYPE=LCELL_S1>>16
%IF PTYPE=0 %THEN PTYPE=7; ! NAME NOT SET
TYPE=PTYPE&7; PREC=PTYPE>>4&15
%IF PTYPE=SNPT %THEN %START
K=LCELL_S3>>16
%IF K=38 %AND A(P+2)=2 %THEN %START; ! PICK OFF NL
RPTYPE=0; RPINF=10; PTYPE=X'51'; P=P+2; ->SKNAM
%FINISH
%IF K=52 %AND A(P+2)=2 %START;! PICK OFF PI
RPTYPE=1; PTYPE=X'62'; RPINF=X'413243F6'
XTRA=X'A8885A31'
P=P+2; REAL=1; ->SKNAM
%FINISH
COMPLEX=1
PTYPE=TSNAME(K); UNPACK
%FINISH
%IF PTYPE&X'FF00'=X'4000' %AND A(P+2)=2 %C
%AND 1<=TYPE<=2 %THEN %START; ! CONST VAR
LCELL_S1=LCELL_S1!X'8000'; ! SET USED BIT
RPINF=LCELL_S2; XTRA=LCELL_S3
RPTYPE=1; PTYPE=PTYPE&255
%IF TYPE=1 %AND PREC<=5 %AND X'FFFE0000'<=RPINF<=X'1FFFF'%C
%THEN RPTYPE=0
%IF PREC=7 %THEN RPTYPE=3
REAL=1 %IF TYPE=2
P=P+2; ->SKNAM
%FINISH
XTRA=OPNAME
%IF PTYPE&X'3F00'#0 %OR PARMCHK=1 %OR PREC<5 %C
%THEN COMPLEX=1
OPMASK=OPMASK!(COMPLEX<<19)
%IF TYPE=3 %THEN %START
D=P; KFORM=LCELL_S3&X'FFFF'
C=COPY RECORD TAG(E); P=D;
COMPLEX=1 %UNLESS E=1 %AND 1<=TYPE<=2 %AND NAM=ARR=0 %C
%AND PREC#3
%FINISH
%IF TYPE=5 %THEN FAULT(42,OPNAME)
%IF TYPE=2 %THEN REAL=1
RPTYPE=2; RPINF=P; PTYPE=1 %IF PTYPE=7
RPTYPE=0 %AND PTYPE=1 %IF TYPE=5; ! CHANGE TO SHORT CONST
P=P+2
SKNAM: %IF A(P)=2 %THEN P=P+1 %ELSE SKIP APP
%IF A(P)=1 %THEN P=P+3 %AND ->SKNAM
P=P+2
INS: BINSERT(RPHEAD,RPBOT,PTYPE<<16!COMPLEX<<8!RPTYPE,RPINF,XTRA)
-> OP
OPERAND(2): ! CONSTANT
PTYPE=A(P); D=PTYPE>>4
C=PTYPE&7; RPINF=FROM AR4(P+1)
REAL=1 %IF C=2; RPTYPE=1
%IF D=6 %THEN XTRA=FROM AR4(P+5)
%IF C=5 %THEN %START; ! STRING CONSTANT
FAULT(42,0); RPINF=1; RPTYPE=0
P=P+A(P+5)+7
%FINISH %ELSE %START
%IF D=7 %THEN XTRA=ADDR(A(P+1)) %AND RPTYPE=3
%IF PTYPE=X'51' %AND RPINF>>17=0 %THEN RPTYPE=0
P=P+2+BYTES(D)
%FINISH; -> INS
OPERAND(3): ! SUB EXPRESSION
PASSHEAD=0; PASSBOT=0
P=P+3
TORP(PASSHEAD,PASSBOT,NOPS)
REAL=1 %IF TYPE=2
! CONCAT(RPHEAD,PASSHEAD)
%IF RPBOT=0 %THEN RPHEAD=PASSHEAD %ELSE %C
ASLIST(RPBOT)_LINK=PASSHEAD
RPBOT=PASSBOT
P=P+1
OP: ! DEAL WITH OPERATOR
-> EOE %IF A(P-1)=2; ! EXPR FINISHED
OPERATOR=A(P)
!
! THE STRING OPERATOR '.' CAUSES CHAOS IN AN ARITHMETIC EXPRSN
! SO FAULT IT AND CHANGE IT TO THE INNOCUOUS '+'
!
%IF OPERATOR=CONCOP %THEN FAULT(42,0)
OPPREC=PRECEDENCE(OPERATOR)
OPERATOR=OPVAL(OPERATOR)
%IF OPERATOR=26 %OR OPERATOR=30 %THEN REAL=1
OPMASK=OPMASK!(1<<OPERATOR)
NOPS=NOPS+1
!
! UNLOAD THE OPERATOR STACK OF ALL OPERATORS WHOSE PRECEDENCE IS
! NOT LOWER THAN THE CURRENT OPERATOR. AN EMPTY STACK GIVES'-1'
! AS PRECEDENCE.
!
%WHILE OPPREC<=OPPSTK&31 %CYCLE
BINSERT(RPHEAD,RPBOT,OPSTK&31+9,0,0)
OPSTK=OPSTK>>5; OPPSTK=OPPSTK>>5
%REPEAT
!
! THE CURRENT OPERATOR CAN NOW BE STORED
!
OPSTK=OPSTK<<5!(OPERATOR-9)
OPPSTK=OPPSTK<<5!OPPREC
-> NEXTOPND
EOE: ! END OF EXPRESSION
! EMPTY REMAINING OPERATORS
%WHILE OPSTK#0 %CYCLE
BINSERT(RPHEAD,RPBOT,OPSTK&31+9,0,0)
OPSTK=OPSTK>>5
%REPEAT
PTYPE=REAL+1
TYPE=PTYPE
! CONCAT(RPHEAD,HEAD)
%IF HEAD=0 %THEN BOT=RPBOT %ELSE %C
ASLIST(RPBOT)_LINK=HEAD
HEAD=RPHEAD; ! HEAD BACK TO TOP OF LIST
NOPS=NOPS!OPMASK
%END
%ROUTINE EXPOP(%INTEGER INHEAD,REG,NOPS,MODE)
!***********************************************************************
!* EVALUATE A LIST OF OPERAND AND'NOPS' OPERATORS AND LEAVE *
!* THE RESULT IN REG *
!* INHEAD HOLDS THE LIST THE BOTTOM BYTE OF STREAM 1 DEFINES THE *
!* ENTRY AS FOLLOWS:- *
!* 0 = SHORT (INTEGER) CONSTANT <18 BITS --S2=CONSTANT *
!* 1 = OTHER CONSTANT S2 (+S3 IF NEEDED) = CONSTANT *
!* 2 = VARIABLE S2 POINT TO AR ENTRY FOR NAME&SUBSCRIPTS *
!* (3 = DOPE VECTOR ITEM IF NEEDED) *
!* (4 = CONDITONAL EXPRESSION AS IN ALGOL) *
!* 7 = INTERMEDIATE RESULT UNDER LNB S2=DISPLCMNT FROM LNB *
!* 8 = INTERMEDIATE RESULT STACKED *
!* 9 = INTERMEDIATE RESULT IN A REGISTER S2 = REG *
!* *
!* 10-19 = UNARY OPERATOR S2=OP S3 =EXTRA *
!* 20 UP = BINARY OPERATOR *
!* *
!* ARRAY MCINST HOLD THE OPCODES CORRESPONDING TO THE OPERATORS:- *
!* TOP BYTE = REAL FORWARD FORM *
!* 2ND BYTE = REAL REVERSE FORM *
!* 3RD BYTE = INTEGER FORWARD FORM *
!* BTM BYTE = INTEGER REVERSE FORM *
!* MODE HAS TYPE & PREC REQD +256 BIT IF NO RESULT REQD *
!***********************************************************************
%ROUTINESPEC CTOP(%INTEGERNAME A)
%ROUTINESPEC CHOOSE(%INTEGERNAME I)
%ROUTINESPEC PUT
%ROUTINESPEC STARSTAR
%ROUTINESPEC REXP
%ROUTINESPEC LOAD(%RECORDNAME OP,%INTEGER REG,MODE)
%ROUTINESPEC FLOAT(%RECORDNAME OPND,%INTEGER OTHERPTYPE)
%ROUTINESPEC COERCET(%RECORDNAME OP1,OP2,%INTEGER MODE)
%ROUTINESPEC COERCEP(%RECORDNAME OP1,OP2)
%ROUTINESPEC LENGTHEN(%RECORDNAME OP)
%ROUTINESPEC SHORTEN (%RECORDNAME OP)
!
%INTEGERARRAY OPERAND(1:2),STK(0:99)
%RECORDNAME LIST(LISTF)
%RECORDNAME OPND1,OPND2,OPND (RD)
!
%INTEGER C,D,KK,JJ,OPCODE,COMM,XTRA,NEWCC,PP,PT,JJJ,LOADREG,EVALREG,%C
STPTR,RDFORM
%CONSTINTEGERARRAY MCINST(10:37)=X'8E8E',X'F4F4E4E4',X'A8A8',
X'F4F4E4E4',0(6),
X'F0F0E0E0',X'F2F4E2E4',
X'8E8E',X'8C8C',X'FAFAEAEA',
X'AAAC',X'BABC0000',
X'8A8A',X'C800'(2),X'FA000000',
X'F6F6E6E6',X'00F600E6',
X'2C002C00',X'02000200',
X'48004800'(2),X'EA00';
%CONSTBYTEINTEGERARRAY CORULES(20:37)=X'1F'(2),X'11'(2),X'1F',X'11',
X'12',X'11',1,1,0,X'1F'(2),
0(4),1;
%CONSTBYTEINTEGERARRAY FCOMP(1:28)=%C
8,10,2,7,12,4,7,
8,12,4,7,10,2,7,
16,34,17,32,33,18,32,
16,33,18,32,34,17,32;
%SWITCH SW(10:37)
!
STPTR=0; RDFORM= MODE&256
NEWCC=0
EVALREG=ACCR; ! EVALUATE IN ACC UNLESS
%IF REG=BREG %AND NOPS&X'7EC00000'=0 %C
%THEN EVALREG=BREG; ! ONLY '+' %AND '*' PRESENT
! %IF REG<0 %AND NOPS&X'7EC400FF'<=2 %AND MODE&255=X'51' %C
%AND REGISTER(BREG)=0 %AND GRUSE(BREG)<3 %AND GRUSE(ACCR)>3%C
%THEN EVALREG=BREG
NEXT: LIST==ASLIST(INHEAD)
C=LIST_S1; XTRA=LIST_S2
JJ=C&255; D=INHEAD
INHEAD=LIST_LINK
-> OPERATOR %IF JJ>=10
!
! ANY OPERAND WHICH MAY NEED DR OR B OR ACC IN THEIR EVALUATION
! EG FUNCTIONS,ARRAY ELEMENTS ETC ARE FETCHED AND STACKKED FIRST
!
OPERAND(1)=ADDR(ASLIST(D))
OPND1==ASLIST(D)
%IF OPND1_FLAG=2 %AND OPND1_XB#0 %THEN LOAD(OPND1,EVALREG,0)
STK(STPTR)=OPERAND(1)
STPTR=STPTR+1
ABORT %IF STPTR>99
ANYMORE:
->NEXT %UNLESS INHEAD=0 %OR MODE=100
-> FINISH
OPERATOR:
%IF JJ<19 %THEN KK=1 %ELSE KK=2; ! UNARY OR BINARY
%CYCLE KK=KK,-1,1
STPTR=STPTR-1
C=STK(STPTR)
OPERAND(KK)=C
%REPEAT
OPCODE=MCINST(JJ)
COMM=1
OPND1 == RECORD(OPERAND(1))
OPND2 == OPND1
%IF JJ>=19 %THEN %START
OPND2==RECORD(OPERAND(2))
C=CORULES(JJ)
%IF C&15#0 %THEN COERCET(OPND1,OPND2,C&15)
%IF C>>4#0 %THEN COERCEP(OPND1,OPND2)
%FINISH
%IF JJ>19 %START
CHOOSE(COMM)
OPND1==RECORD(OPERAND(COMM))
OPND2==RECORD(OPERAND(3-COMM))
%FINISH
PTYPE=OPND1_PTYPE; TYPE=PTYPE&7
%IF TYPE=1 %THEN OPCODE=OPCODE&X'FFFF' %C
%ELSE OPCODE=OPCODE>>16;! INTEGER OR REAL FORMS
%IF OPND1_FLAG<2 %AND OPND2_FLAG<2 %THEN CTOP(JJ)
-> STRES %IF JJ=0; ! CTOP CARRIED OUT
-> SW(JJ)
SW(10): ! \
LOAD(OPND1,EVALREG,2)
FAULT(24,0) %UNLESS TYPE=1
PSF1(OPCODE&255,0,-1); ! NEQ -1
GRUSE(EVALREG)=0
SUSE: OLINK(EVALREG)=OPERAND(COMM)
STRES: STK(STPTR)=OPERAND(COMM)
STPTR=STPTR+1
->ANYMORE
SW(11): ! NEGATE
LOAD(OPND1,EVALREG,2)
%IF EVALREG=BREG %THEN PSF1(SLB,0,0) %AND PF1(SBB,0,TOS,0) %C
%ELSE PSF1(OPCODE&255,0,0); ! IRSB 0 OR RRSB 0
GRUSE(EVALREG)=0
-> SUSE
SW(12): ! FLOAT
ABORT
SW(13): ! ABS
LOAD(OPND1,EVALREG,2); ! OPERAND TO ACC
%IF TYPE=2 %THEN C=2 %ELSE C=6
PF3(JAF,C,0,3); ! JAF *+3 ON ACC<0
PSF1(OPCODE&255,0,0); ! IRSB 0 OR RRSB 0
GRUSE(EVALREG)=0
->SUSE
SW(14): ! STRETCH
ABORT
SW(20): ! ADD
%IF TYPE=1 %AND GRUSE(EVALREG)=10 %AND OPND1_FLAG=2 %C
%AND OPND2_FLAG=0 %AND REGISTER(EVALREG)=0 %START
P=OPND1_D; D=GRINF(EVALREG)
%IF FROMAR2(P)=D&X'FFFF' %AND A(P+2)=2=A(P+3) %START
%IF EVALREG=ACCR %THEN C=IAD %ELSE C=ADB
PSF1(C,0,OPND2_D-D>>16)
GRINF(EVALREG)=D&X'FFFF'!OPND2_D<<16
REGISTER(EVALREG)=1
OPND1_FLAG=9; OPND1_XB=EVALREG<<4
OPND1_D=0; ->SUSE
%FINISH
%FINISH
BINOP: LOAD(OPND1,EVALREG,2);
LOAD(OPND2,EVALREG,1)
PUT; -> SUSE
SW(21): ! SUBTRACT
->BINOP
SW(22): ! EXCLUSIVE OR
SW(23): ! OR
SW(27): ! AND
->BINOP %IF TYPE=1
F24: FAULT(24,0) %UNLESS TYPE=7
JJ=20; OPCODE=MCINST(20)
->BINOP; ! CHANGE OPN TO +
SW(28): ! SRL
%IF OPND2_FLAG=0 %THEN OPND2_D=-OPND2_D %ELSE %START
LOAD(OPND2,EVALREG,2); ! OPND TO ACC
PSF1(IRSB,0,0); ! AND NEGATE IT
GRUSE(EVALREG)=0
%FINISH
SW(29): ! SLL
->F24 %IF OPND2_PTYPE>>4>=6;! NO SHIFT BY LONG INT
-> BINOP
SW(24): ! MULT
-> BINOP
SW(25): ! INTEGER DIVISION
->F24 %UNLESS TYPE=1
-> BINOP
SW(26): ! NORMAL DIVISION
-> BINOP
SW(30): ! EXP IN REAL EXPRSN
%IF OPND1_PTYPE&7=1 %THEN FLOAT(OPND1,0)
%IF OPND2_PTYPE&7=1 %THEN STARSTAR %AND ->SUSE
! REAL**REAL BY SUBROUTINE
REXP; COMM=2; ->SUSE
SW(37): ! EXP IN INTEGER CONTEXT
STARSTAR; -> SUSE
SW(31): ! COMPARISONS
SW(32): ! DSIDED COMPARISONS
PTYPE=OPND1_PTYPE
->Z1 %IF OPND1_FLAG<=1 %AND 0=OPND1_D %AND JJ=31 %AND %C
(OPND1_XTRA=0 %OR PTYPE>>4=5)
-> Z2 %IF OPND2_FLAG<=1 %AND 0=OPND2_D %AND %C
(OPND2_XTRA=0 %OR OPND2_PTYPE>>4=5)
LOAD(OPND1,EVALREG,2)
LOAD(OPND2,EVALREG,1)
PUT
REGISTER(EVALREG)=0
BFFLAG=COMM-1; ! NOTE BACKWARDS OR FORWARDS
MASK=FCOMP(XTRA+7*BFFLAG)
COMM=2; ->STRES; ! 2ND OPERAND MAY BE NEEDED IN
! DOUBLE SIDED AND IS THEREFORE
! TAKEN AS THE 'RESULT'
Z1: COMM=3-COMM
Z2: OPND==RECORD(OPERAND(COMM))
C=EVALREG; D=EVALREG!!7
%IF OPND_FLAG=2 %AND GRUSE(D)=9 %AND %C
(GRINF(D)&X'FFFF'=OPND_XTRA %OR GRINF(D)>>16=OPND_XTRA) %C
%THEN C=D
LOAD(OPND,C,2)
REGISTER(C)=0
MASK=FCOMP(XTRA+7*COMM+7)
%IF TYPE=1 %THEN MASK=MASK+4
%IF C=BREG %THEN MASK=MASK+8
COMM=2; ->STRES
SW(33): ! SPECIAL MH FOR ARRAY ACCESS
C=OPND2_D>>16; ! CURRENT DIMENSION
D=OPND2_D&31; ! TOTAL NO OF DIMENSIONS
%IF OPND1_FLAG=9 %AND OPND1_XB>>4=ACCR %THEN %START
PF1(ST,0,TOS,0); ! ACC CANNOT BE USED IN DVM
CHANGE RD(ACCR)
REGISTER(ACCR)=0
%FINISH
!
%IF C=D %THEN %START; ! TOP DIMENSION LOAD DV DES
BASE=OPND2_XTRA>>18; AREA=-1
GET IN ACC(DR,2,0,AREA CODE,OPND2_XTRA&X'1FFFF'+8)
%FINISH
!
LOAD(OPND1,EVALREG,0)
%IF OPND1_PTYPE>>4>=6 %THEN FAULT(24,0)
%IF C=D %AND REGISTER(BREG)>=1 %AND %C
(OPND1_FLAG#9 %OR OPND1_XB>>4#BREG) %THEN %START
OPND==RECORD(OLINK(BREG))
OPND_D=0
REGISTER(BREG)=2
BOOT OUT(BREG)
%FINISH
AREA=OPND1_XB>>4; ACCESS=OPND1_XB&15
PSORLF1(OPCODE>>8,ACCESS,AREA,OPND1_D)
GRUSE(BREG)=0
!
%IF C=1=D %THEN LOADREG=BREG %ELSE %START
LOADREG=ACCR
%IF C=D %THEN GET IN ACC(ACCR,1,0,7,0) %ELSE %C
PF1(IAD,0,BREG,0) %AND GRUSE(BREG)=0
%IF C=1 %THEN %START
PF1(ST,0,BREG,0)
GRUSE(BREG)=0
REGISTER(ACCR)=0
LOADREG=BREG
%FINISH
%FINISH
REGISTER(LOADREG)=1
OPND1_FLAG=9; OPND1_XB=LOADREG<<4
OLINK(LOADREG)=OPERAND(COMM)
%IF C=1 %THEN ->STRES
->ANYMORE
SW(34): ! ->LAB MASKS AND LAB AS OPND2
! OPND1 MIDDLE OF D-SIDED
LOAD(OPND1,EVALREG,2) %IF INHEAD#0; ! PROTECT MIDDLE OPND IN DSIDED
%IF XTRA=1 %THEN MASK=REVERSE(MASK)
ENTER JUMP(MASK,OPND2_D,B'11')
->STRES; ! RETURN MIDDLE OPND AS RESULT
SW(35): ! ASSIGN(=)
SW(36): ! ASSIGN(<-)
PT=OPND2_PTYPE; PP=OPND2_D
%IF PT&7=1 %AND OPND1_PTYPE&7=2 %THEN FAULT(24,0)
%IF PT&7=2 %AND OPND1_PTYPE&7=1 %THEN FLOAT(OPND1,OPND2_PTYPE)
LOAD(OPND1,EVALREG,2); ! RHS TO ACC
REGISTER(EVALREG)=2
C=PT>>4; D=OPND1_PTYPE>>4
%IF C<5 %THEN C=5
%IF D<5 %THEN D=5
%WHILE D<C %THEN LENGTHEN(OPND1) %AND D=OPND1_PTYPE>>4
%WHILE (C<D %AND TYPE=1 %AND JJ#36) %OR C<D-1 %THEN %C
SHORTEN(OPND1) %AND D=OPND1_PTYPE>>4
P=PP; CNAME(1,0); ! STORE CALL
D=DISP; C=ACCESS; JJJ=AREA; ! SAVE INFO FOR STORE
KK=PREC
LOAD(OPND1,EVALREG,2); ! IN CASE STACKED
%IF JJ=36 %AND TYPE=1 %START
%IF 3<=XTRA<=4 %THEN PF1(AND,0,0,(-1)>>(8*(6-XTRA)))%C
%AND GRUSE(ACCR)=0
%IF KK<=5 %AND PREC=6 %THEN %C
PSF1(MPSR,0,17) %AND GRUSE(ACCR)=0
%FINISH
%IF TYPE=2 %AND KK<PREC %THEN KK=STUH %ELSE KK=ST
%IF EVALREG=BREG %THEN KK=STB
PSORLF1(KK,C,JJJ,D)
%IF A(PP+2)=2=A(PP+3) %THEN NOTE ASSMENT(EVALREG,JJ-33,STNAME)
%IF C>=2 %START
%IF STNAME>=0 %THEN GRUSE(DR)=7 %AND GRINF(DR)=STNAME %C
%ELSE GRUSE(DR)=0
%FINISH
%IF KK=STUH %THEN GRUSE(ACCR)=0
COMM=1; ->STRES
FINISH: C=STK(STPTR-1)
OPERAND(1)=C
OPND1==RECORD(C)
%IF OPND1_PTYPE>>4&15<5 %THEN %C
OPND1_PTYPE=OPND1_PTYPE&X'F'!X'50';! BITS&BYTES->INTEGERS
%IF RDFORM =0 %START
D=MODE>>4&7; D=5 %IF D<5
%IF MODE&7=2 %AND OPND1_PTYPE&7=1 %THEN FLOAT(OPND1,D<<4)
%WHILE D<OPND1_PTYPE>>4 %THEN SHORTEN(OPND1)
%WHILE D>OPND1_PTYPE>>4 %THEN LENGTHEN(OPND1)
LOAD(OPND1,REG,2)
%FINISH
PTYPE=OPND1_PTYPE
TYPE=PTYPE&7; PREC=PTYPE>>4
%IF TYPE=2 %AND MODE&7=1 %THEN FAULT(24,0)
NEST=-1
%IF OPND1_FLAG=9 %THEN %START
NEST=OPND1_XB>>4
REGISTER(NEST)=0
%FINISH
%RETURN
!
%ROUTINE CHOOSE(%INTEGERNAME CHOICE)
%RECORDNAME OPND1,OPND2(RD)
OPND1==RECORD(OPERAND(1))
OPND2==RECORD(OPERAND(2))
CHOICE=1
%RETURN %IF JJ=21 %AND EVALREG=BREG;! NO REVERSE SUBTRACT B
CHOICE=2 %IF OPCODE&X'FF00FF00'=0 %OR %C
(OPCODE&X'FF00FF'#0 %AND (OPND2_FLAG=9 %C
%OR(OPND2_FLAG=2 %AND GRUSE(EVALREG)=9 %AND %C
GRINF(EVALREG)=OPND2_XTRA>0)))
%END
%ROUTINE LOAD(%RECORDNAME OPND,%INTEGER REG,MODE)
!***********************************************************************
!* LOAD OPERAND OPND AS DIRECTED BY MODE TO REGISTER REG *
!* MODE=0 LEAVE IN STORE IF POSSIBLE *
!* MODE=1 LEAVE IN STORE IF SUITABLE FOR RX INSTRUCTIONS *
!* MODE=2 LOAD TO REGISTER REGARDLESS *
!***********************************************************************
%INTEGER K,KK
%RECORDSPEC OPND(RD)
%SWITCH SW(0:9)
K=OPND_FLAG
%RETURN %UNLESS MODE=2 %OR K=2 %OR(K<=3 %AND MODE=1)
PTYPE=OPND_PTYPE
TYPE=PTYPE&15
PREC=PTYPE>>4
%IF K<0 %OR K>9 %THEN ABORT
->SW(K)
SW(0):LITCONST: ! CONSTANT < 18 BITS
AREA=0; ACCESS=0
DISP=OPND_D
%IF MODE=2 %THEN %START; ! FETCH TO REG
%IF GRUSE(REG)=5 %AND GRINF(REG)=DISP %AND PREC=5 %START
%IF REGISTER(REG)#0 %THEN BOOT OUT(REG)
%FINISHELSE GET IN ACC(REG,BYTES(PREC)>>2,ACCESS,AREA,DISP)
%IF PREC<=5 %THEN GRUSE(REG)=5 %AND GRINF(REG)=DISP
->LDED
%FINISH
%IF PREC=3 %THEN OPND_PTYPE=X'51'; ! CONSTBYTEINTEGERS AGAIN
OPND_FLAG=7; OPND_XB=AREA<<4!ACCESS
OPND_D=DISP
%RETURN
SW(1): ! LONG CONSTANT
%IF OPND_D=0=OPND_XTRA %AND PREC<=6 %THEN ->LITCONST
SW(3): ! 128 BIT CONSTANT
%IF PREC=7 %THEN KK=OPND_XTRA %ELSE KK=ADDR(OPND_D)
STORE CONST(DISP,BYTES(PREC),KK)
%IF MODE#2 %THEN %START
OPND_FLAG=7; OPND_XB=PC<<4
OPND_D=DISP; %RETURN
%FINISH
%IF GRUSE(REG)=6 %AND GRINF(REG)=DISP %THEN %START
%IF REGISTER(REG)#0 %THEN BOOT OUT (REG)
%FINISH %ELSE GET IN ACC(REG,BYTES(PREC)>>2,0,PC,DISP)
GRUSE(REG)=6; GRINF(REG)=DISP
->LDED
SW(2): ! NAME
P=OPND_D
-> LOAD %IF MODE=2 %OR OPND_XB#0;! COMPLEX NAMES MUST BE LOADED
CNAME(5,REG)
->LDED %IF NEST>=0
AREA=-1
AREA=AREA CODE
OPND_PTYPE<-PTYPE
OPND_FLAG=7
OPND_XB=AREA<<4!ACCESS
OPND_D=DISP; %RETURN
LOAD: CNAME(2,REG)
LDED: REGISTER(REG)=1; ! CLAIM THE REGISTER
OLINK(REG)=ADDR(OPND)
%IF PREC<5 %THEN OPND_PTYPE=OPND_PTYPE&15!X'50'
OPND_FLAG=9; OPND_D=0; OPND_XB=REG<<4
%IF REG=BREG %AND REGISTER(ACCR)&1#0 %THEN %C
REGISTER(BREG)=2
%RETURN
SW(4): ! CONDITIONAL EXPRESSION
SW(5): ! UNASSIGNED
SW(6): ! UNASSIGNED
ABORT
SW(7): ! I-R IN A STACK FRAME
AREA=OPND_XB>>4
ACCESS=OPND_XB&15
DISP=OPND_D
PICKUP: GET IN ACC(REG,BYTES(PREC)>>2,ACCESS,AREA,DISP)
->LDED
SW(8): ! I-R THAT HAS BEEN STACKED
AREA=TOS; ACCESS=0; DISP=0; ->PICK UP
SW(9): ! I-R IN A REGISTER
%IF OPND_XB>>4=REG %THEN -> LDED
%IF REG#ACCR %THEN PF1(ST,0,BREG,0) %ELSE %C
GETINACC(ACCR,1,0,BREG,0)
REGISTER(OPND_XB>>4)=0
OPND_XB=REG<<4; GRUSE(REG)=0
REGISTER(REG)=1; OLINK(REG)=ADDR(OPND)
%END
%ROUTINE PUT
!***********************************************************************
!* THIS ROUTINE PLANTS CODE TO PERFORM THE BASIC *
!* OPERATION DEFINED BY OPND1,OPND2 & OPCODE *
!***********************************************************************
%INTEGER CODE,OCODE
CODE=OPCODE
%IF COMM=1 %THEN CODE=CODE>>8
CODE=CODE&255; OCODE=CODE
%IF EVALREG=BREG %THEN CODE=CODE-X'C0'
ABORT %UNLESS OPND1_FLAG=9
PSORLF1(CODE,OPND2_XB&15,OPND2_XB>>4,OPND2_D)
%IF OCODE=IAD %AND GRUSE(EVALREG)=9 %AND OPND2_XB=0 %C
%AND OPND2_D<4095 %THEN %START
GRUSE(EVALREG)=10
GRINF(EVALREG)=GRINF(EVALREG)&X'FFFF'!OPND2_D<<16
%FINISH %ELSE %START
GRUSE(EVALREG)=0 %UNLESS 31<=JJ<=32
%FINISH
OLINK(EVALREG)=OPERAND(COMM)
%END
%ROUTINE FLOAT(%RECORDNAME OPND,%INTEGER OTHERPTYPE)
!***********************************************************************
!* PLANT CODE TO CONERT OPERAND FROM FIXED TO FLOATING *
!***********************************************************************
%RECORDSPEC OPND(RD)
%IF OPND_FLAG<=1 %THEN %START
CVALUE=OPND_D
OPND_D=INTEGER(ADDR(CVALUE))
OPND_XTRA=INTEGER(ADDR(CVALUE)+4)
OPND_FLAG=1
%FINISH %ELSE %START
LOAD(OPND,ACCR,2)
%IF OTHERPTYPE&X'F0'=X'70' %AND OPND_PTYPE&X'F0'<=X'50' %C
%THEN PSF1(IMYD,0,1) %AND OPND_PTYPE=OPND_PTYPE&15!X'60'
PSF1(FLT,0,0)
GRUSE(ACCR)=0
%FINISH
OPND_PTYPE=OPND_PTYPE+X'11'
TYPE=2
%END
%ROUTINE COERCET(%RECORDNAME OPND1,OPND2,%INTEGER MODE)
!***********************************************************************
!* MODE=1 BOTH OPERANDS INTEGER ELSE ERROR *
!* MODE=2 FORCE BOTH OPERAND TO BE OF TYPE REAL *
!* MODE=15 BOTH OPERANDS TO BE OF LAGEST TYPE *
!***********************************************************************
%RECORDSPEC OPND1(RD)
%RECORDSPEC OPND2(RD)
%INTEGER PT1,PT2
PT1=OPND1_PTYPE&7
PT2=OPND2_PTYPE&7
%IF (MODE=1 %OR MODE=15) %AND PT1=1=PT2 %THEN %RETURN
%IF MODE=1 %THEN FAULT(24,0) %AND %RETURN
%IF PT1=1 %THEN FLOAT(OPND1,OPND2_PTYPE)
%IF PT2=1 %THEN FLOAT(OPND2,OPND1_PTYPE)
%END
%ROUTINE COERCEP(%RECORDNAME OPND1,OPND2)
!***********************************************************************
!* FORCE BOTH OPERAND TO THE SAME PRECISION BEFORE OPRNTN *
!***********************************************************************
%RECORDSPEC OPND1(RD)
%RECORDSPEC OPND2(RD)
%INTEGER PREC1,PREC2
PREC1=OPND1_PTYPE>>4
PREC2=OPND2_PTYPE>>4
%WHILE PREC1<PREC2 %CYCLE
LENGTHEN(OPND1)
PREC1=OPND1_PTYPE>>4
%REPEAT
!
%WHILE PREC2<PREC1 %CYCLE
LENGTHEN(OPND2)
PREC2=OPND2_PTYPE>>4
%REPEAT
%END
%ROUTINE LENGTHEN(%RECORDNAME OPND)
!***********************************************************************
!* INCREASE OPND PRECISION BY ONE SIZE AT COMPILE TIME IF POSS *
!***********************************************************************
%RECORDSPEC OPND(RD)
%INTEGER TP,PR
TP=OPND_PTYPE&7
PR=OPND_PTYPE>>4
%IF OPND_FLAG<=1 %AND PR<=5 %START; ! LENGTHEN CONSTANT
%IF TP=1 %AND OPND_FLAG=1 %START;! INTEGER CONSTANT
OPND_XTRA=OPND_D
%IF OPND_XTRA<0 %THEN OPND_D=-1 %ELSE OPND_D=0
%FINISH %ELSE OPND_XTRA=0
%FINISH %ELSE %START; ! CODE PLANTING REQRD
LOAD(OPND,ACCR,2)
%IF TP=1 %THEN PSF1(IMYD,0,1) %ELSE %C
PF1(RMYD,0,PC,SPECIAL CONSTS(1));! REAL ONE=X'41000000'
GRUSE(ACCR)=0
%FINISH
OPND_PTYPE=(PR+1)<<4+TP
%END
%ROUTINE SHORTEN(%RECORDNAME OPND)
!***********************************************************************
!* PLANT CODE TO REDUCE ACC SIZE. NO COMPILETIME OPTION *
!* SINCE ONLY AN IDIOT WILL GIVE OVERLENGTH CONSTANTS. *
!***********************************************************************
%RECORDSPEC OPND(RD)
%INTEGER TY,PR
TY=OPND_PTYPE&7
PR=OPND_PTYPE>>4
LOAD(OPND,ACCR,2)
%IF PR=7 %THEN %START; ! SHORTEN QUAD
PF1(RDDV,0,PC,SPECIAL CONSTS(1))
%FINISH %ELSE %START
%IF TYPE=1=PARMARR %THEN PSF1(ISH,0,32)
PSF1(USH,0,-32) %IF PARMARR=1 %OR TYPE#1
%IF REGISTER(BREG)=0 %THEN PF1(STUH,0,BREG,0) %AND %C
GRUSE(BREG)=0 %ELSE PSF1(MPSR,0,17);! ACS TO 1 WORD
%FINISH
GRUSE(ACCR)=0
OPND_PTYPE=(PR-1)<<4+TY
%END
%ROUTINE CTOP(%INTEGERNAME FLAG)
!***********************************************************************
!* AN OPERATION HAS BEEN FOUND WHERE BOTH OPERANDS ARE CONSTANTS *
!* THIS ROUTINE ATTEMPTS TO INTERPRET THIS OPERATION IF IT *
!* CAN BE DONE SAFELY *
!* ON EXIT FLAG=0 %IF OPERATION CARRIED OUT *
!***********************************************************************
%INTEGER K,VAL1,VAL2,TYPEP,PRECP,OP,TYPEPP
%LONGREAL RVAL1,RVAL2
%SWITCH ISW,RSW(10:30)
! NEWCC=0; !COMPILE TIME OPS CAN NOT SET CC
TYPEP=TYPE; PRECP=PTYPE>>4&15; OP=FLAG
K=OPND2_PTYPE; TYPEPP=K&7; K=K>>4
%IF TYPEP=2 %THEN %START; ! BOTH OPERANDS ARE REAL
INTEGER(ADDR(RVAL1))=OPND1_D
INTEGER(ADDR(RVAL1)+4)=OPND1_XTRA
%FINISH %ELSE %START
VAL1=OPND1_D; RVAL1=VAL1 %IF TYPEPP=2
%FINISH
%IF TYPEPP=2 %THEN %START
INTEGER(ADDR(RVAL2))=OPND2_D
INTEGER(ADDR(RVAL2)+4)=OPND2_XTRA
%FINISH %ELSE %START
VAL2=OPND2_D
%FINISH
%IF TYPEP<TYPEPP %THEN TYPEP=TYPEPP
%IF PRECP<K %THEN PRECP=K
%RETURN %IF OP>30 %OR PRECP=7 %OR(PRECP=6 %AND TYPEP=1)
%IF TYPEP=2 %THEN ->RSW(OP) %ELSE ->ISW(OP)
ISW(10): ! \
VAL1=\VAL1
INTEND: FLAG=0; OPND1_PTYPE=X'51'
%IF X'FFFE0000'<=VAL1<=X'1FFFF' %THEN OPND1_FLAG=0 %ELSE %C
OPND1_FLAG=1; OPND1_D=VAL1;
%RETURN
ISW(11): ! INTEGER NEGATE
VAL1=-VAL1; -> INT END
ISW(13): ! INTEGER ABS
VAL1=IMOD(VAL1); -> INT END
ISW(12): ! INTEGER FLOAT
RVAL1=VAL1; PRECP=5+XTRA
->REAL END
RSW(14): ! STRETCH REAL
PRECP=6
REAL END:OPND1_FLAG=1
OPND1_D=INTEGER(ADDR(RVAL1))
OPND1_XTRA=INTEGER(ADDR(RVAL1)+4)
FLAG=0; OPND1_PTYPE=16*PRECP+2
%RETURN
ISW(14): ! STRETCH INTEGER
RSW(12): ! FLOAT REAL
ABORT
ISW(20): ! ADD
VAL1=VAL1+VAL2; -> INT END
ISW(21): ! MINUS
VAL1=VAL1-VAL2; -> INT END
ISW(22): ! EXCLUSIVE OR
VAL1=VAL1!!VAL2; -> INT END
ISW(23): ! OR
VAL1=VAL1!VAL2; -> INT END
ISW(24): ! MULT
VAL1=VAL1*VAL2; -> INT END
ISW(26): %RETURN; ! / DIVISION
ISW(25): %RETURN %IF VAL2=0; ! // DIVISION
VAL1=VAL1//VAL2; -> INT END
ISW(27): ! AND
VAL1=VAL1&VAL2; -> INT END
ISW(29): ! SLL
VAL1=VAL1<<VAL2; -> INT END
ISW(28): ! SRL
VAL1=VAL1>>VAL2; -> INT END
RSW(11): ! NEGATE
RVAL1=-RVAL1; -> REAL END
RSW(13): ! ABS
RVAL1=MOD(RVAL1); -> REAL END
RSW(20): ! ADD
RVAL1=RVAL1+RVAL2; -> REAL END
RSW(21): ! SUBTRACT
RVAL1=RVAL1-RVAL2; -> REAL END
RSW(24): ! MULT
RVAL1=RVAL1*RVAL2; -> REAL END
RSW(26): ! DIVISION
%RETURN %IF RVAL2=0; ! AVOID DIV BY ZERO
RVAL1=RVAL1/RVAL2; -> REAL END
ISW(30): ! '**' WITH 2 INTEGER OPERANDS
RVAL1=VAL1
RSW(30): ! EXP
%IF OPND2_FLAG#0 %THEN %RETURN
RVAL1=RVAL1**OPND2_D; -> REAL END
RSW(22):RSW(23):
RSW(25):RSW(27):RSW(28):RSW(29):
%END
%ROUTINE REXP
!***********************************************************************
!* CALLS A PERM ROUTINE TO PERFORM REAL**REAL *
!***********************************************************************
%INTEGER I,PR
%RECORDNAME OPND(RD)
%IF REGISTER(BREG)>0 %THEN BOOT OUT(BREG)
%CYCLE I=1,1,2
OPND==RECORD(OPERAND(I))
LOAD(OPND,ACCR,2) %UNLESS I=1 %AND OPND_FLAG=8
PR=OPND_PTYPE>>4
%IF PR<6 %THEN LENGTHEN(OPND)
%IF PR>6 %THEN SHORTEN(OPND)
%REPEAT
PPJ(0,17)
%END
%ROUTINE STARSTAR
!***********************************************************************
!* PLANT IN-LINE CODE FOR EXPONENTIATION *
!* IMP ALLOWS EXPONENTS IN INTEGER EXPRESSIONS FROM 0-63 AND *
!* IN REAL EXPRESSIONS FROM-255 TO +255 *
!***********************************************************************
%INTEGER TYPEP,PRECP,WORK,C,EXPWORK,VALUE
PTYPE=OPND1_PTYPE; ! INSPECT THE OPERAND
UNPACK
TYPEP=TYPE; PRECP=PREC
%IF TYPEP=2 %THEN OPCODE=X'FA' %ELSE OPCODE=X'EA'
VALUE=0
%IF OPND2_FLAG=0 %AND 1<=OPND2_D<=63*TYPE %THEN %C
VALUE=OPND2_D; ! EXPONENT IS #0 AND CONSTANT
LOAD(OPND1,ACCR,2); ! FETCH OPERAND TO ACC
%IF TYPEP=2 %AND PRECP=5 %THEN LENGTHEN(OPND1)%AND PRECP=6
!
! OPTIMISE **2 **3 AND **4
!
%IF 2<=VALUE<=4 %THEN %START
PF1(ST,0,TOS,0)
%IF VALUE=3 %THEN PF1(ST,0,TOS,0)
PF1(OPCODE,0,TOS,0)
%IF VALUE=4 %THEN PF1(ST,0,TOS,0)
%IF VALUE>2 %THEN PF1(OPCODE,0,TOS,0)
%RETURN
%FINISH
!
! OTHERWISE STORE OPERAND IN 'WORK' AND GET HOLD OF EXPONENT
!
GET WSP(WORK,BYTES(PRECP)>>2)
%IF TYPEP=2 %THEN GET WSP(EXPWORK,1)
PSF1(ST,1,WORK)
REGISTER(ACCR)=0
PLABEL=PLABEL-1; ! LABEL FOR JUMPING OUT
LOAD(OPND2,BREG,2); ! EXPONENT TO ANY REGISTER
%IF TYPE=2 %OR PREC>5 %START;! EXPONENT IS REAL OR LONG INT
FAULT(39,0)
%FINISH
%IF TYPEP=2 %THEN PSF1(STB,1,EXPWORK)
!
! GET '1' INTO ACC IN APPROPIATE FORM
!
GET IN ACC(ACCR,BYTES(PRECP+1-TYPEP)>>2,0,0,1)
%IF TYPEP=2 %THEN PSF1(FLT,0,0)
!
! IF EXPONENT NOT KNOWN AT COMPILE TIME TO BE +VE CONSTANT MUST
! ALLOW FOR ZERO :- XX**0=1 FOR ALL XX
! ALSO ALLOW FOR X**(-N) WHICH IS 1/(X**N) FOR ALL X & N
!
%IF VALUE=0 %THEN %START; ! NOT +VE CONSTANT
ENTER JUMP(28,PLABEL,B'11'); ! J(B=0) END OF EXP ROUTINE
%IF TYPEP=2 %THEN %START
PF3(JAT,13,0,4); ! J*+4 IF B>0
PSF1(SLB,0,0)
PF1(SBB,0,TOS,0)
%FINISH
!
! IN CHECKING MODE PLANT CODE TO CHECK RANGE OF EXPONENT
!
%IF PARMOPT=1 %THEN %START
%IF TYPEP=1 %THEN PPJ(30,7); ! JUMP B<0
PSF1(CPB,0,64*TYPEP*TYPEP-1)
PPJ(2,7)
%FINISH
%FINISH
C=CA
PSF1(OPCODE,1,WORK)
PSF1(DEBJ,0,(C-CA)//2)
!
! FOR REAL EXPONENTS CHECK IF NEGATIVE AND EVALUATE INVERSE
!
%IF VALUE=0 %AND TYPEP=2 %THEN %START
PSF1(LB,1,EXPWORK); ! LB ON ORIGINAL EXPONENT
ENTER JUMP(46,PLABEL,B'11');! BP END OF EXP ROUTINE
%IF PRECP<7 %THEN PF1(RRDV,0,PC,SPECIAL CONSTS(1))%ELSESTART
PSF1(SLSD,0,1); PSF1(FLT,0,0)
PF1(RDV,0,TOS,0)
%FINISH
%FINISH
!
! ALL OVER. REAL RESULTS ARE IN FR WORK. INT RESULTS IN GR WORK+1
! FREE AND FORGET ANY OTHER REGISTERS
!
TYPE=TYPEP; PREC=PRECP
REGISTER(BREG)=0
GRUSE(BREG)=0
REGISTER(ACCR)=1
OPND1_PTYPE=16*PREC+TYPE
OPND1_XB=0; OPND1_D=ACCR
ENTER LAB(PLABEL,B'11'); ! LABEL AT END OF EXP ROUTINE
%END
%END; ! OF ROUTINE EXPOP
%ROUTINE REDUCE ENV(%INTEGERNAME HEAD)
!***********************************************************************
!* HEAD HAS AN ENVIRONMENT - THIS ROUTINE REMOVES ANYTHING *
!* INCOMPATIBLE WITH THE CURRENT REGISTER STATE *
!***********************************************************************
%INTEGER NEWHEAD,I,J,K,REG,USE
NEWHEAD=0
%WHILE HEAD#0 %CYCLE
POP(HEAD,I,J,K)
REG=K>>8; USE=K&255
%IF USE=GRUSE(REG) %AND I=GRINF(REG) %THEN %C
PUSH(NEWHEAD,I,J,K)
%REPEAT
HEAD=NEWHEAD
%END
%ROUTINE CCOND(%INTEGER IU,FARLAB)
!***********************************************************************
!* COMPILES <IU><SC><RESTOFCOND>%THEN<UI1>%ELSE<UI2> *
!* IU=1 FOR %IF =2 FOR UNLESS. FARLAB TO GO ON UI2 *
!* THE ROUTINE MAKES FOUR PASSES THROUGH THE CONDITION *
!* PASS 1 ANALYSES THE STRUCTURE AND DECIDES TO BRANCH ON TRUE *
!* (TF=2) OR ON FALSE (TF=1) FOR EACH COMPARISON *
!* PASS 2 WORKS OUT WHERE THE BRANCHES OF PASS 1 SHOULD GO TO *
!* PASS 3 ASSIGNS LABEL NUMBERS *
!* PASS 4 EVALUATES COMPARISIONS AND PLANTS THE CODE *
!* *
!* ON ENTRY P POINTS TO <SC> IN<HOLE><SC><RESTOFCOND> *
!***********************************************************************
!%ROUTINESPEC WRITE CONDLIST
%ROUTINESPEC SKIP SC
%ROUTINESPEC SKIP COND
%ROUTINESPEC CCOMP
!
! FCOMP HAS BC MASKS FOR EACH STRING COMPARATOR.
! THE FIRST 7 ARE TO BRANCH IF TRUE WITH NORMAL COMPARISON
! THE SECOND SEVEN ARE TO BRANCH IF TRUE WITH BACKWARDS COMPARISON
!
%CONSTINTEGERARRAY FCOMP(1:21)=8,13,5,7,10,2,7,
8,10,2,7,13,5,7,
27,0,0,43,0,0,43;
!
%INTEGER PIN,PP,II,L,CPTR,CMAX,LL
%RECORDFORMAT CF(%BYTEINTEGER TF,CMP1,CMP2,LABU,LVL,JMP, %C
%INTEGER LABNO,SP1,SP2)
%RECORDARRAY CLIST(1:30)(CF)
%RECORDNAME C1,C2(CF)
!
! PASS 1. ANALYSES THE CONDITION
!
PIN=P; ! SAVE INITIAL AR POINTER
CPTR=1; L=3; ! LEVEL=3 TO ALLOW 2 LOWER
C1==CLIST(CPTR); ! SET UP RECORD FOR FIRST CMPARSN
C1=0
SKIP SC; ! SKIP THE 1ST CMPARSN
SKIP COND; ! AND ANY %AND/%OR CLAUSES
C1_LVL=2; ! LEVEL =-1 FOR %IF/%THEN ENTRY
C1_TF=IU
CMAX=CPTR+1
C1==CLIST(CMAX); C1=0
C1_LVL=1; ! LEVEL =-2 FOR ELSE ENTRY
C1_TF=3-IU; C1_LABNO=FARLAB
PP=P; ! SAVE FINAL AR POINTER
FAULT(209,0) %IF CMAX>29; ! TOO COMPLICATED
!
! PASS 2 WORKS OUT WHERE TO JUMP TO
! THE JUMP IS FORWARD TO THE START OF THE CLAUSE WITH A DIFFERENT
! CONNECTOR (AND/OR) PROVIDED THIS IS AT A LOWER LEVEL THAN THE BRANCH
! AND ALSO AT A LOWER LEVEL THAN THE LOWEST POINT REACHED ENROUTE
!
! ALSO CONTAINS PASS 3 (TRIVIAL)
! ASSIGN LABELS WHERE LABU SHOWS THEY ARE REQUIRED
!
%CYCLE CPTR=1,1,CMAX-1
C1==CLIST(CPTR)
L=C1_LVL; LL=L; ! LL FOR LOWEST LEVEL ENROUTE
%CYCLE II=CPTR+1,1,CMAX+1
C2==CLIST(II)
%EXIT %IF C1_TF#C2_TF %AND C2_LVL<LL
%IF C2_LVL<LL %THEN LL=C2_LVL
%REPEAT
C1_JMP=II; ! CLAUSE TO JUMP TO
C2_LABU=C2_LABU+1
%IF C1_CMP2#0 %OR C1_CMP1=8 %START; ! D-SIDED OR RESLN
! REQIUIRES A LABEL ON THE
C1_LABU=C1_LABU+1; ! THE NEXT SIMPLE CONDITION
%FINISH
%IF C1_LABU#0 %AND C1_LABNO<=0 %THEN PLABEL=PLABEL-1 %C
%AND C1_LABNO=PLABEL
%REPEAT
!
! PASS 4 GENERATE THE CODE
!
! WRITE CONDLIST %IF DCOMP=1
%CYCLE CPTR=1,1,CMAX-1
C1==CLIST(CPTR)
CCOMP
%IF C1_LABNO>0 %THEN ENTER LAB(C1_LABNO,B'11')
%REPEAT
!
P=PP; %RETURN
%ROUTINE SKIP SC
!***********************************************************************
!* SKIPS OVER A SIMPLE CONDITION. P ON ALT OF<SC> *
!***********************************************************************
%INTEGER ALT
ALT=A(P); P=P+1
%IF ALT=1 %THEN %START; ! <EXP><COMP><EXP><SECONDSIDE>
C1_SP1=P-PIN
SKIP EXP
C1_CMP1=A(P)
P=P+1; C1_SP2=P-PIN
SKIP EXP
%IF A(P)=2 %THEN P=P+1 %ELSE %START
C1_CMP2=A(P+1); ! DEAL WITH 2ND HALF OF D-SIDED
P=P+2; SKIP EXP
%FINISH
%FINISH %ELSE %START; ! '('<SC><RESTOFCOND>')'
L=L+1
SKIP SC
SKIP COND
L=L-1
%FINISH
%END; ! OF ROUTINE SKIP SC
%ROUTINE SKIP COND
!***********************************************************************
!* SKIPS OVER <RESTOFCOND> *
!***********************************************************************
%INTEGER ALT,ALTP
ALT=A(P); ! 1=%AND<ANDC>,2=%OR<ORC>,3=NULL
P=P+1
%IF ALT\=3 %THEN %START; ! NULL ALTERNATIVE NOTHING TO DO
%UNTIL ALTP=2 %CYCLE; ! UNTIL NO MORE <SC>S
C1_LVL=L; C1_TF=ALT
CPTR=CPTR+1
C1==CLIST(CPTR); C1=0
SKIP SC
ALTP=A(P); P=P+1
%REPEAT
%FINISH
%END
! %ROUTINE WRITE CONDLIST
! %CONSTSTRING(5) %ARRAY CM(0:8)=' ',' =',' >=',' >',
! ' #',' <=',' <',' \=',' ->'
! PRINTSTRING('
! NO TF C1 C2 LABU LVL JMP LABNO
!')
! %CYCLE CPTR=1,1,CMAX
! C1==CLIST(CPTR)
! WRITE(CPTR,2)
! WRITE(C1_TF,4)
! PRINTSTRING(CM(C1_CMP1))
! PRINTSTRING(CM(C1_CMP2))
! WRITE(C1_LABU,6)
! WRITE(C1_LVL,5)
! WRITE(C1_JMP,4)
! WRITE(C1_LABNO,7)
! NEWLINE
! %REPEAT
! %END
%ROUTINE CCOMP
!***********************************************************************
!* COMPILES A COMPARISION: THREE DIFFERENT CASES *
!* 1) ARITHMETIC EXPRESSIONS EXPOP IS USED *
!* 2) STRING EXPRESSION AD-HOC CODE PLANTED BY THIS ROUTINE *
!* 3) RESOLUTIONS - CRES CAN BE USED *
!***********************************************************************
%ROUTINESPEC ACOMP(%INTEGER TF,LAB,DS)
%ROUTINESPEC SCOMP(%INTEGER DS,TF,LAB,%INTEGERNAME WA)
%INTEGER HEAD1,HEAD2,NOPS,TE1,TE2,TEX1,TEX2,MASK,P1,P2,FEXIT,IEXIT, %C
CMP,WA1,WA2,WA3,BOT1,BOT2
!
HEAD1=0; HEAD2=0; NOPS=0
BOT1=0; BOT2=0
FEXIT=CLIST(C1_JMP)_LABNO; ! FINAL EXIT
IEXIT=FEXIT; ! INTERMEDIATE EXIT (D-SIDED ETC)
%IF C1_TF=2 %AND (C1_CMP1=8 %OR C1_CMP2#0) %THEN %C
IEXIT=C1_LABNO
!
P=PIN+C1_SP2
P2=P; P1=PIN+C1_SP1
%IF C1_CMP1=8 %OR C1_CMP2=8 %THEN %START
! CONDITIONAL RESOLUTION
! NB CRES BRANCHES ON FALSE!!
P=P1
%IF C1_CMP2=0 %AND A(P+3)=4 %AND A(P+4)=1 %START
P=P+5; CNAME(2,DR); ! LH STRING TO DR
%IF A(P)=2 %AND TYPE=5 %THEN %START
P=P2
CRES(IEXIT); ! FAILURES -> IEXIT
%IF C1_TF=2 %THEN ENTER JUMP(15,FEXIT,B'11')
%RETURN
%FINISH
%FINISH
FAULT(73,0)
%RETURN
%FINISH
MASK=FCOMP(C1_CMP1)
TE2=TSEXP(TEX2)
->STR %IF TYPE=5
->ARITH %UNLESS TE2=1
P=P1; TE1=TSEXP(TEX1)
->STR %IF TYPE=5
ARITH: ! ARITHMETIC COMPARISIONS
P=P1+3
TORP(HEAD1,BOT1,NOPS); ! FIRST EXPRESSION TO REVERSE POL
CMP=C1_CMP1
P=P2+3
%IF C1_CMP2#0 %THEN %START; ! IF D-SIDED DEAL WITH MIDDLE
ACOMP(1,IEXIT,1); ! BRANCH IEXIT %IF FALSE
P=P+5; ! TO THE THIRD EXPRSN
CMP=C1_CMP2; ! COMPARATOR NO 2
%FINISH
!
ACOMP(C1_TF,FEXIT,0); ! SECOND OR ONLY COMPARISION
!
EXPOP(HEAD1,-1,NOPS,256+16*PREC+TYPE); ! PLANT THE CODE
! CLEAR LIST(HEAD1)
ASLIST(BOT1)_LINK=ASL
ASL=HEAD1
%RETURN
STR: ! STRING COMPARISIONS
! SOME CARE IS NEEDED IN FREEING
! STRING WK-AREAS SET BY CSTREXP
P=P1
WA1=0; WA2=0; WA3=0
%IF C1_CMP2=0 %AND 7<=FCOMP(C1_CMP1)<=8 %AND A(P2+3)=4 %AND %C
A(P2+4)=2 %AND ((A(P2+5)=X'51' %AND FROM AR4(P2+6)=0 %ANDC
A(P2+10)=2)%OR(A(P2+5)=5 %AND A(P2+10)=0 %AND A(P2+11)=2))%C
%THEN %START
CSTREXP(0,DR)
MASK=FCOMP(C1_CMP1+14)
%IF C1_TF=1 %THEN MASK=REVERSE(MASK)
ENTER JUMP(MASK,FEXIT,B'11')
%RETURN
%FINISH
CSTREXP(17,ACCR); ! DO NOT FREE WK-AREA
WA1=VALUE; ! SAVE ADDRESS OF WK-AREA
CMP=C1_CMP1
P=P2
!
%IF C1_CMP2#0 %THEN %START; ! D-SIDED DEAL WITH MIDDLE
SCOMP(1,1,IEXIT,WA2)
P=P+2; CMP=C1_CMP2
%IF WA1#0 %THEN RETURN WSP(WA1,256) %AND WA1=0
%FINISH
!
SCOMP(0,C1_TF,FEXIT,WA3)
%CYCLE CMP=ADDR(WA1),4,ADDR(WA3)
%IF INTEGER(CMP)#0 %THEN RETURN WSP(INTEGER(CMP),256)
%REPEAT
%RETURN
%ROUTINE ACOMP(%INTEGER TF,LAB,DS)
!***********************************************************************
!* TYPE & PREC DEFINE THE EXPRSN IN REVERSE POLISH IN HEAD1 *
!* THIS ROUTINE CONVERTS THE NEXT EXPRSN TO REVERSE POLISH AND *
!* ADDS OPERATORS FOR TYPE CHANGING(IF REQ) CMPRSN AND JUMP *
!***********************************************************************
%INTEGER PRECP,TYPEP,COP
PRECP=PREC; TYPEP=TYPE
!
! ADD OPERATORS IN THE REVERSE ORDER. IE JUMP(34) THEN COMPARE(31)
!
PUSH(HEAD2,34,TF,0)
BOT2=HEAD2
PUSH(HEAD2,1<<16,LAB,0)
PUSH(HEAD2,31+DS,CMP,0)
NOPS=(NOPS+2)!1<<31; ! FLAG COMPARE
!
! CONVERT NEXT EXPRSN TO REVERSE POLISH AND TO THE SAME TYPE AS THE
! FIRST IF POSSIBLE. MODE=0 INTEGER IF POSSIBLE,=2 REAL, =3 LONGREAL
!
TORP(HEAD2,BOT2,NOPS)
%IF TYPEP>TYPE %THEN TYPE=TYPEP
! CONCAT(HEAD1,HEAD2)
ASLIST(BOT1)_LINK=HEAD2
BOT1=BOT2; BOT2=0; HEAD2=0
%END
%ROUTINE SCOMP(%INTEGER DS,TF,LAB,%INTEGERNAME WA)
!***********************************************************************
!* 1ST STRING IS DEFINED BY (ACCR) *
!* THIS ROUTINE EVALUATES THE NEXT STRING EXPRS AND PERFORMS *
!* THE COMPARISON & BRANCH. *
!* DS=0 UNLESS THIS COMPARISON IS THE FIRST HALF OF A DBLE-SIDED *
!***********************************************************************
%INTEGER MASK
%RECORD R(RD)
!
REGISTER(ACCR)=1
OLINK(ACCR)=ADDR(R)
R_PTYPE=1; R_XB=ACCR<<4; R_FLAG=9
MASK=FCOMP(CMP)
%IF TF=1 %THEN MASK=REVERSE(MASK); ! REVERSE MASK TO JMP IF FALS
!
CSTREXP(16+DS,DR); ! SAVE WK-AREA
WA=VALUE
REGISTER(ACCR)=0
%IF R_FLAG#9 %THEN PF1(LSD,0,TOS,0)
%IF DS#0 %THEN PF1(STD,0,TOS,0)
PSF1(INCA,0,1); PSF1(IAD,0,1)
PF2(CPS,1,1,0,0,0)
GRUSE(ACCR)=0; GRUSE(DR)=0
!
! IF CC=8 MUST CHECK THAT ACC STRING IS EXHAUSTED OTHERWISE CHANGE CC
! TO GIVE RESULT ACC>DR. THIS IS BEST FIDDLED USING ISH.
! CAN SKIP THIS CHECK IF MASK IS SUCH THAT 2**3 &2**2 BITS SET THE SAME
!
%IF 0#MASK&X'C'#X'C' %THEN %START
PF3(JCC,7,0,4)
PSF1(USH,0,-32)
PSF1(ISH,0,-24)
%FINISH
%IF DS#0 %THEN PF1(LSD,0,TOS,0); ! DOES NOT CHANGE CC
ENTER JUMP(MASK,LAB,B'11')
%END
%END
%END
%INTEGERFN REVERSE(%INTEGER MASK)
!***********************************************************************
!* REVERSE THE MASK FOR A JCC(MASK<=15),JAT(>15) OR JAF(>31 *
!***********************************************************************
%IF MASK>15 %THEN MASK=MASK!!X'30' %ELSE MASK=MASK!!15
%RESULT=MASK
%END
%ROUTINE ENTER LAB(%INTEGER LAB,FLAGS)
!***********************************************************************
!* ENTER A NEW LABEL ON THE LABEL LIST FOR THE CURRENT LEVEL *
!* 2**0 OF FLAGS = 1 CONDITIONAL ENTRY *
!* 2**1 OF FLAGS = 1 UPDATE ENVIRONMENT *
!* 2**2 OF FLAGS = 1 REPLACE ENV =0 MERGE ENV *
!* THE LABEL LIST *
!* S1 = USE BITS<<8 ! LABEL ADDR *
!* S2 = ENVIRONMENT LIST << 16 ! UNFILLED JUMPS LIST *
!* S3 = LAB NO - RESET TO FFFF WHEN USED FOR INTERNAL LABELS *
!***********************************************************************
%INTEGER CELL,AT,ENVHEAD,JUMPHEAD,INSTRN,OLDCELL,WORK
%RECORDNAME LCELL(LISTF)
%INTEGERNAME LHEAD
CELL=LABEL(LEVEL); OLDCELL=0
%WHILE CELL>0 %CYCLE
LCELL==ASLIST(CELL)
%EXIT %IF LCELL_S3=LAB
OLDCELL=CELL; CELL=LCELL_LINK
%REPEAT
!
%IF CELL<=0 %THEN %START; ! LABEL NOT KNOWN
%IF FLAGS&1=0 %THEN %START;! UNCONDITIONAL ENTRY
PUSH(LABEL(LEVEL),CA,0,LAB)
FORGET(-1)
%FINISH
%RETURN
%FINISH
!
! LABEL HAS BEEN REFERENCED - FILL IN ITS ADDRESS
!
%IF LCELL_S1&X'FFFFFF'# 0 %THEN %START
FAULT(2,LAB); ! LABEL SET TWICE
%FINISH %ELSE %START
LCELL_S1=X'1000000'!CA
%FINISH
!
! SORT OUT ENVIRONMENTS - AS DIRECTED BY FLAGS
!
JUMPHEAD=LCELL_S2
ENVHEAD=JUMPHEAD>>16
JUMPHEAD=JUMPHEAD&X'FFFF'
%IF FLAGS&2=0 %THEN %START
FORGET(-1)
CLEAR LIST(ENVHEAD)
%FINISH %ELSE %START
REMEMBER %IF FLAGS&4=0
RESTORE (ENVHEAD)
ENVHEAD=0
MERGE INFO %IF FLAGS&4=0
%FINISH
!
! NOW FILL JUMPS TO THIS LABEL - JUMP LIST FORMAT GIVEN IN 'ENTER JMP'
!
%WHILE JUMPHEAD#0 %CYCLE
POP(JUMPHEAD,AT,INSTRN,WORK)
PLUG(1,AT,INSTRN!(CA-AT)//2,4)
%REPEAT
LCELL_S2=0
%IF LAB> MAX ULAB %THEN %START
%IF OLDCELL=0 %THEN LHEAD==LABEL(LEVEL) %ELSE %C
LHEAD==ASLIST(OLDCELL)_LINK
POP(LHEAD,AT,AT,AT)
%FINISH
%END
%ROUTINE ENTER JUMP(%INTEGER MASK,LAB,FLAGS)
!***********************************************************************
!* IF LAB HAS BEEN ENCOUNTERED THEN PLANT A JCC OTHERWISE ENTER *
!* THE LABEL IN THE LABEL LIST AND ATTACH THE JUMP TO IT SO IT *
!* CAN BE PLANTED WHEN THE LABEL IS FOUND *
!* THE LABEL LIST IS DESCRIBED UNDER 'ENTER LAB' *
!* THE JUMP SUB-LIST HAS THE FORM *
!* S1= ADDR OF JUMP *
!* S2=INSTRN *
!* *
!* FLAGS BITS SIGNIFY AS FOLLOWS *
!* 2**0 =1 JUMP IS KNOWN TO BE SHORT *
!* 2**1 =1 ENVIRONMENT MERGEING REQUIRED *
!***********************************************************************
%INTEGER AT,CELL,J,JJ,LABADDR,I,ENVHEAD,OLDENV,JCODE,INSTRN
%RECORDNAME LCELL(LISTF)
ENVHEAD=0; AT=CA
%IF LAB<MAX ULAB %THEN FLAGS=FLAGS&X'FD';! NO MERGE
%IF LAB<21000 %THEN FLAGS=FLAGS&X'FE'; ! SF OR USER LAB=LONG
CELL=LABEL(LEVEL)
%WHILE CELL>0 %CYCLE
LCELL==ASLIST(CELL)
%IF LAB=LCELL_S3 %THEN %EXIT
CELL=LCELL_LINK
%REPEAT
INSTRN=MASK
%IF INSTRN>>8=0 %THEN %START
JCODE=JCC
%IF MASK>=16 %THEN JCODE=JAT
%IF MASK>=32 %THEN JCODE=JAF
INSTRN=JCODE<<24!(MASK&15)<<21
%IF MASK=15 %THEN INSTRN=JUNC<<24!3<<23
%FINISH
-> FIRSTREF %IF CELL<=0
LABADDR=LCELL_S1&X'FFFFFF'
-> NOT YET SET %IF LABADDR=0
LCELL_S1=LABADDR!X'1000000';! FLAG LABEL AS USED
I=(LABADDR-CA)//2
%IF MASK=15 %THEN PSF1(JUNC,0,I) %ELSE %C
PCONST(INSTRN!(I&X'3FFFF'))
%RETURN
FIRSTREF: ! FIRST REFERENCE TO A NEW LABEL
%IF LAB>MAX ULAB %AND FLAGS&2#0 %THEN GET ENV(ENV HEAD)
PUSH(LABEL(LEVEL),X'1000000',ENVHEAD<<16,LAB)
CELL=LABEL(LEVEL)
LCELL==ASLIST(CELL)
-> CODE
NOT YET SET: ! LABEL REFERENCED BEFORE
%IF LAB>MAX ULAB %AND FLAGS&2#0 %THEN %START
I=LCELL_S2
OLDENV=I>>16
REDUCE ENV(OLD ENV)
LCELL_S2=OLDENV<<16!I&X'FFFF'
%FINISH
CODE: ! ACTUALLY PLANT THE JUMP
J=LCELL_S2
JJ=J&X'FFFF'
PUSH(JJ,CA,INSTRN,0)
LCELL_S2=J&X'FFFF0000'!JJ
PCONST(INSTRN)
%END
%ROUTINE REMOVE LAB(%INTEGER LAB)
!***********************************************************************
!* REMOVES A ALBEL FROM THE CURRENT LABEL LIST WHEN KNOWN TO *
!* BE REDUNDANT. MAINLY USED FOR CYCLE LABELS *
!***********************************************************************
%RECORDNAME LCELL(LISTF)
%INTEGERNAME LHEAD
%INTEGER CELL,AT
LHEAD==LABEL(LEVEL); CELL=LHEAD
%WHILE CELL>0 %CYCLE
LCELL==ASLIST(CELL)
%EXIT %IF LCELL_S3=LAB
LHEAD==LCELL_LINK
CELL=LHEAD
%REPEAT
%IF CELL>0 %THEN POP(LHEAD,AT,AT,AT)
%END
%ROUTINE MERGE INFO
!***********************************************************************
!* MERGE THE CURRENT STATUS OF THE REGISTERS WITH THE VALUES *
!* AT THE START OF THE CONDITIONAL CLAUSE. THIS PERMITS THE *
!* THE COMPILER TO REMEMBER UNCHANGED REGISTERS BUT NOT THOSE *
!* WHICH DEPEND ON A PARTICULAR RUN TIME ROUTE BEING TAKEN *
!***********************************************************************
%INTEGER I
%CYCLE I=0,1,7
GRUSE(I)=0 %UNLESS SGRUSE(I)=GRUSE(I) %AND SGRINF(I)=GRINF(I)
%REPEAT
%END
%ROUTINE REMEMBER
%INTEGER I
%CYCLE I=0,1,7
SGRUSE(I)=GRUSE(I)
SGRINF(I)=GRINF(I)
%REPEAT
%END
%ROUTINE CREATE AH(%INTEGER MODE)
!***********************************************************************
!* CREATE AN ARRAY HEAD IN TEMPORARY SPACE BY MODIFYING THE HEAD *
!* THE HEAD AT AREA,ACCESS & DISP AS FOLOWS:- *
!* MODE=0 (ARRAY MAPPING) ACC HAS ADDR(1ST ELEMENT) *
!* MODE=1 (ARRAYS IN RECORDS) ACC HAS RELOCATION FACTOR *
!***********************************************************************
%INTEGER WK
GET WSP(WK,4)
AREA=AREA CODE
%IF MODE=0 %THEN %START
%IF COMPILER=1=J %AND TYPE<=2 %START
PF1(SLSS,2,AREA,DISP+8); ! LWB TO ACC
PSF1(IMY,0,-BYTES(PREC)) %UNLESS PREC=3
PF1(IAD,0,TOS,0)
GRUSE(DR)=0
%FINISH
PSORLF1(LUH,ACCESS,AREA,DISP)
%FINISH %ELSE %START
PSF1(LUH,0,0)
PSORLF1(IAD,ACCESS,AREA,DISP)
%FINISH
!
PSF1(ST,1,WK); ! 1ST PART OF HEAD =DESC TO ARRAY
PSORLF1(LSD,ACCESS,AREA,DISP+8)
PSF1(ST,1,WK+8); ! 2ND PART = DESCPTR TO DV
GRUSE(ACCR)=0
ACCESS=0; AREA=LNB; DISP=WK
%END
%ROUTINE CSNAME(%INTEGER Z,REG)
!***********************************************************************
!* COMPILE A SPECIAL NAME - PTYPE=10006 (=%ROUTINE %LABEL) *
!* THEIR TRUE PTYPE IS IN GLOBAL ARRAY TSNAME. *
!* SNINFO HAS A FOUR BYTE RECORD FOR EACH NAME (%BI FLAG,PTR, *
!* %SI XTRA). THE TOP BITS OF FLAG CATEGORISE AS FOLLOWS:- *
!* 2**7 SET FOR IMPLICITLY SPECIFIED CONSTRUCT A %SPEC *
!* 2**6 SET FOR IOCP CALL *
!* 2**5 SET FOR BUILT IN MAPPING FUNCTIONS *
!* 2**4 SET IF AD-HOC CODE PLANTED BY THIS ROUTINE *
!* 2**3 SET IF FIRST PARAMETER IS OF %NAME TYPE *
!* 2**2-2**0 HOLD NUMBER OF PARAMS *
!* *
!* THE FULL SPECS ARE AS FOLLOWS:- *
!* 0=%ROUTINE SELECT INPUT(%INTEGER STREAM) *
!* 1=%ROUTINE SELECT OUTPUT(%INTEGER STREAM) *
!* 2=%ROUTINE NEWLINE *
!* 3=%ROUTINE SPACE *
!* 4=%ROUTINE SKIP SYMBOL *
!* 5=%ROUTINE READ STRINWG(%STRINGNAME S) *
!* 6=%ROUTINE NEWLINES(%INTEGER N) *
!* 7=%ROUTINE SPACES(%INTEGER N) *
!* 8=%INTEGERFN NEXT SYMBOL *
!* 9=%ROUTINE PRINT SYMBOL(%INTEGER SYMBOL) *
!* 10=%ROUTINE READ SYMBOL(%NAME SYMBOL) *
!* 11=%ROUTINE READ(%NAME NUMBER) *
!* 12=%ROUTINE WRITE(%INTEGER VALUE,PLACES) *
!* 13=%ROUTINE NEWPAGE *
!* 14=%INTEGERFN ADDR(%NAME VARIABLE) *
!* 15=%LONGREALFN ARCSIN(%LONGREAL X) *
!* 16=%INTEGERFN INT(%LONGREAL X) *
!* 17=%INTEGERFN INTPT(%LONRGREAL X) *
!* 18=%LONGREALFN FRACPT(%LONGREAL X) *
!* 19=%ROUTINE PRINT(%LONGREAL NUMBER,%INTEGER BEFORE,AFTER) *
!* 20=%ROUTINE PRINTFL(%LONGREAL NUMBER,%INTEGER PLACES) *
!* 21=%REALMAP REAL(%INTEGER VAR ADDR) *
!* 22=%INTEGERMAP INTEGER(%INTEGER VAR ADDR) *
!* 23=%LONGREALFN MOD(%LONGREAL X) *
!* 24=%LONGREALFN ARCCOS(%LONGREAL X) *
!* 25=%LONGREALFN SQRT(%LONGREAL X) *
!* 26=%LONGREALFN LOG(%LONGREAL X) *
!* 27=%LONGREALFN SIN(%LONGREAL X) *
!* 28=%LONGREALFN COS(%LONGREAL X) *
!* 29=%LONGREALFN TAN(%LONGREAL X) *
!* 30=%LONGREALFN EXP(%LONGREAL X) *
!* 31=%ROUTINE CLOSE STREAM(%INTEGER STREAM) *
!* 32=%BYTEINTEGERMAP BYTE INTEGER(%INTEGER VAR ADDR) *
!* 33=%INTEGERFN EVENTINF *
!* 34=%LONGREALFN RADIUS(%LONGREAL X,Y) *
!* 35=%LONGREALFN ARCTAN(%LONGREAL X,Y) *
!* 36=%BYTEINTEGERMAP LENGTH(%STRINGNAME S) *
!* 37=%ROUTINE PRINT STRING(%STRING(255) MESSAGE) *
!* 38=%INTEGERFN NL *
!* 39=%LONGREALMAP LONG REAL(%INTEGER VAR ADDR) *
!* 40=%ROUTINE PRINT CH(%INTEGER CHARACTER) *
!* 41=%ROUTINE READ CH(%NAME CHARACTER) *
!* 42=%STRINGMAP STRING(%INTEGER VAR ADDR) *
!* 43=%ROUTINE READ ITEM(%STRINGNAME ITEM) *
!* 44=%STRING(1)%FN NEXT ITEM *
!* 45=%BYTEINTEGERMAP CHARNO(%STRINGNAME STR,%INTEGER CHARREQD) *
!* 46=%STRING(1)%FN TOSTRING(%INTEGER SYMBOL) *
!* 47=%STRING(255)%FN FROMSTRING(%STRING(255)S,%INTEGER BEG,END) *
!* 48=%RECORDMAP RECORD(%INTEGER REC ADDR) *
!* 49=%ARRAYMAP ARRAY(%INTEGER A1ADDR,%ARRAYNAME FORMAT) *
!* 50=%ROUTINE SETMARGINS(%INTEGER INOUT,LHM,RHM) *
!* 51=%INTEGERFN IMOD(%INTEGER VALUE) *
!* 52=%LONGREALFN PI *
!* 53=%INTEGERFN EVENTLINE *
!* 54=%LONGINTEGERMAP LONGINTEGER(%INTEGER ADR) *
!* 55=%LONGLONGREALMAP LONGLONGREAL(%INTEGER ADR) *
!* 56=%LONGINTGEREFN LENGTHENI(%INTEGER VAL) *
!* 57=%LONGLONGREALFN LENGTHENR(%LONGREAL VAL) *
!* 58=%INTEGERFN SHORTENI(%LONGINTEGER VAL) *
!* 59=%LONGREALFN SHORTENR(%LONGLONGREAL VAL) *
!* 60=%INTEGERFN NEXTCH *
!* 61=%HALFINTEGERMAP HALFINTEGER(%INTEGER ADDR) *
!***********************************************************************
%INTEGERFNSPEC OPTMAP
%SWITCH ADHOC(1:14)
%CONSTINTEGERARRAY SNINFO(0:61)=%C
X'41080001',X'41090001',X'408A0001',X'40A00001',
X'40010001',X'800D0000',X'11010001',X'11010001',
X'10020024',X'41030001',X'19030001',X'80130001',
X'801B0014',X'408C0001',X'19050024',X'80010002',
X'11040024',X'11040024',X'80010005',X'80090006',
X'80060007',X'2100003E',X'2100003E',X'11060024',
X'80010008',X'80010009',X'8001000A',X'8001000B',
X'8001000C',X'8001000D',X'8001000E',X'8015000F',
X'2100003E',X'100D0024',X'80030010',X'80030011',
X'1907003E',X'41070001',X'10080024',X'2100003E',
X'41050001',X'19030001',X'2100003E',X'19030001',
X'10020024',X'1A07003E',X'11090024',X'800F0012',
X'110A8018',X'120B1000',X'80170013',X'11060024',
X'100C0024',X'100D0024',X'2100003E'(2),
X'110E0024'(4),
X'10020024',X'2100003E';
%CONSTSTRING(11)%ARRAY SNXREFS(0:20)=%C
'READSTRING', 'S#READ', 'S#IARCSIN', 'S#INT',
'S#INTPT' , 'S#FRACPT', 'S#PRINT' , 'S#PRINTFL',
'S#IARCCOS','S#ISQRT' , 'S#ILOG' , 'S#ISIN',
'S#ICOS' , 'S#ITAN' , 'S#IEXP' , 'CLOSESTREAM',
'S#IRADIUS','S#IARCTAN','FROMSTRING','SETMARGINS',
'S#WRITE' ;
!
! SNPARAMS HOLDS NUMBER AND PTYPE OF FORMAL PARAMETER FOR IMPLICITLY
! SPECIFIED EXTERNAL ROUTINES. A POINTER IN SNINFO MEANS THAT NO
! DUPLICATES NEED TO BE RECORDED.
!
%CONSTINTEGERARRAY SNPARAMS(0:29)=0,
1,X'62', 2,X'62',X'62', 2,X'62',X'51',
3,X'62',X'51',X'51', 1,X'435', 3,X'35',X'51',X'51',
1,X'400', 1,X'51', 3,X'51',X'51',X'51',
2,X'51',X'51';
!
%ROUTINESPEC RTOS(%INTEGER REG)
%RECORD R(RD)
%INTEGER ERRNO,FLAG,POINTER
%INTEGER PIN,SNNO,SNNAME,NAPS,SNPTYPE,JJ,%C
XTRA,IOCPEP,B,D,SNINF,P0,OPHEAD
!
SNNAME=FROM AR2(P)
SNNO=K; ! INDEX INTO SNINFO
TESTAPP(NAPS); ! COUNT ACTUAL PARAMETERS
PIN=P; P=P+2
SNPTYPE=TSNAME(SNNO)
SNINF=SNINFO(SNNO)
XTRA=SNINF&X'FFFF'
POINTER=(SNINF>>16)&255
FLAG=SNINF>>24
!
! THE IMPLICITLY SPECIFIED ROUTINE ARE THE EASIEST OF ALL TO DEAL WITH.
! JUST SET UP THE EXTERNAL SPEC & PARAMETERS. THEN A RECURSIVE CALL
! OF CNAME THEN FINDS THE ROUTINE UNDER ITS TRUE COLOURS AND COMPILES
! THE CALL. ALL CALLS EXCEPT THE FIRST ARE DEALT WITH DIRECTLY BY CNAME.
! ALL NONTRIVIAL ROUTINES SHOULD BE DEALT WITH IN THIS MANNER
! XTRA HAS INDEX INTO ARRAY OF EXTERNAL NAMES SO THAT THESE
! CAN EASILY BE CHANGED.
!
%IF FLAG&X'80'#0 %THEN %START
CXREF(SNXREFS(XTRA),0,2,JJ);! JJ SET WITH REF DISPLACEMENT
%IF SNNO=26 %THEN LOGEPDISP=JJ
%IF SNNO=31 %THEN EXPEPDISP=JJ
OPHEAD=0; P0=SNPARAMS(POINTER)
PUSH(OPHEAD,JJ,P0,0)
K=OPHEAD; JJ=1; D=64
%WHILE JJ<=P0 %CYCLE
PTYPE=SNPARAMS(POINTER+JJ)
UNPACK
%IF NAM=0 %THEN ACC=BYTES(PREC) %ELSE ACC=8
%IF PTYPE=X'35' %THEN ACC=256;!STRING BY VALUE
INSERTAT END(OPHEAD,PTYPE,ACC<<16!D,0)
D=D+ACC
JJ=JJ+1
%REPEAT
I=1; J=14
OLDI=0; PTYPE=SNPTYPE
REPLACETAG(SNNAME)
P=PIN; CNAME(Z,REG); ! RECURSIVE CALL
NEST=REG
P=P-2; %RETURN; ! DUPLICATES CHECK OF <ENAME>
%FINISH
!
! ALL ROUTINES EXCEPT THE IMPLICITS REQUIRE A CHECK THAT THE USE OF THE
! NAME IS LEGAL AND THAT THE CORRECT NO OF PARAMETERS(BOTTOM 2 BITS OF
! FLAG) HAS BEEN SUPPLIED. THE CHECK IS TRIVIAL - THE PROBLEM
! IS TO GET THE RIGHT ERROR NUMBER.
! XTRA HAS A BITMASK OF ALLOWED USES(IE ALLOWED Z VALUES)
!
%IF NAPS#FLAG&3 %THEN ERRNO=19 %AND ->ERREXIT
JJ=1<<Z
%IF JJ&XTRA=0 %THEN %START; ! ILLEGAL USE
ERRNO=23
%IF Z=0 %THEN ERRNO=17
%IF Z=1 %OR 3<=Z<=4 %THEN ERRNO=29
%IF XTRA&X'F000'#0 %THEN ERRNO=84
->ERR EXIT
%FINISH
!
! A NUMBER OF INPUT-OUTPUT ROUTINES ARE MAPPED ONTO CALLS OF IOCP.
! THIS ARRANGEMENT HAS THE ADVANTAGE OF REQUIRING ONL 1 EXTERNAL REF
! IN THE GLA BUT HAS THE DISADVANTAGE THAT THE I-O ROUTINES CAN NOT
! BE PASSED AS RT-TYPE PARAMETERS AS WELL AS REQUIRING MESSY CODE
! HEREABOUTS. SNINF_PTR HOLD EITHER:-
! 1) THE IOCP ENTRY POINT NO
! OR 2) THE SYMBOL TO BE OUTPUT WITH 2**7 BIT SET
!
! THIS SECTION DEALS WITH SELECT INPUT,SELECT OUTPUT,NEWLINE,NEWPAGE
! SPACE,SKIP SYMBOL,PRINT SYMBOL,PRINT STRING
! AND PRINT CH
!
%IF FLAG&X'40'#0 %THEN %START
IOCPEP=POINTER; B=ACCR
%IF FLAG&3#0 %THEN %START; ! RT HAS PARAMS
P=P+1
%IF SNNO=37 %THEN CSTREXP(0,DR) %AND B=DR %C
%ELSE CSEXP(ACCR,X'51')
%FINISH
%IF IOCPEP>127 %THEN PSF1(LSS,0,IOCPEP&127) %AND IOCPEP=5
%IF SNNO=4 %THEN PSF1(LSS,0,0);! SKIP SYMBOL FORCE ACS=1
CIOCP(IOCPEP,B); ! PLANT CALL OF IOCP
->OKEXIT
%FINISH
!
! THE BUILT-IN MAPS (INTEGER ETC BUT NOT RECORD OR ARRAY)
!
%IF FLAG&X'20'#0 %THEN %START
SNPTYPE=X'1400'+SNPTYPE; ! ADD MAP BITS
%IF PARMOPT=0 %AND OPTMAP#0 %THEN ->OKEXIT
%IF Z=1 %THEN BIMSTR=1; ! SPECIAL FLAG FOR STORE VIA MAP
P=P+1
CSEXP(BREG,X'51'); P=P+1
%IF Z=1 %THEN BIMSTR=0
JJ=SNPTYPE>>4&15
DISP=MAPDES(JJ)
AREA=PC; ACCESS=3
->OKEXIT
%FINISH
!
! ADHOC CODING IS REQUIRED FOR THE REMAINING ROUTINES APART FROM
! A CHECK FOR NAMETYPE PARAMETERS. THE SWITCH NO IS KEPT IN POINTER
!
P=P+1
%IF FLAG&8#0 %AND(A(P+3)#4 %OR A(P+4)#1 %OR %C
A(P+FROM AR2(P+1)+1)#2) %THEN ERRNO=22 %AND ->ERREXIT
->ADHOC(POINTER)
ADHOC(1): ! NEWLINES(=6) & SPACES(=7)
CSEXP(ACCR,X'51'); ! REPITITION NO TO ACC
%IF SNNO=6 %THEN JJ=10 %ELSE JJ=32
PSF1(USH,0,8); ! SHIFT UP 8 PLACES
PSF1(OR,0,JJ); ! OR SYMBOL
CIOCP(17,ACCR)
->OKEXIT
ADHOC(2): ! NEXTSYMBOL(=8) & NEXTITEM(=44)
! ALSO NEXTCH(=60)
GET IN ACC(ACCR,1,0,0,0); ! PRESERVE ANY INTERMEDIATES
%IF SNNO=60 %THEN JJ=18 %ELSE JJ=2
CIOCP(JJ,ACCR); ! LEAVES THE SYMBOL IN ACC
%IF SNNO=44 %THEN %START
RTOS(BREG)
SNPTYPE=X'1435'
AREA=PC; ACCESS=3
DISP=MAPDES(3)
%FINISH
NEST=ACCR; ! CONVERT R1 TO STRING
->OKEXIT
ADHOC(3): ! READSYMBOL(=10),CH(=41)&ITEM(=43)
%IF SNNO=41 %THEN JJ=4 %ELSE JJ=1
PSF1(LSS,0,0)
CIOCP(JJ,ACCR); ! SYMBOL OR CH TO GR1
P=P+5
%IF SNNO=43 %THEN %START
TYPE=5; RTOS(ACCR)
PF1(LUH,0,PC,PARAM DES(3))
%FINISH %ELSE %START
REGISTER(ACCR)=1; TYPE=1
%FINISH
JJ=TYPE
ASSIGN(6,P); ! BY '=' TO PARAMETER
P=PIN+5+FROM AR2(PIN+4)
->OKEXIT
ADHOC(4): ! INT(=16) AND INTPT (=17)
CSEXP(ACCR,X'62')
%IF SNNO=16 %THEN PF1(RAD,0,PC,SPECIAL CONSTS(0));! RAD 0.5
%IF PARMOPT=0 %THEN PSF1(RSC,0,55) %AND PSF1(RSC,0,-55)
%IF REGISTER(BREG)#0 %THEN BOOT OUT(BREG)
PF1(FIX,0,BREG,0)
PSF1(MYB,0,4)
PSF1(CPB,0,-64)
PF3(JCC,10,0,3)
PSF1(LB,0,-64)
PF1(ISH,0,BREG,0)
PF1(STUH,0,BREG,0)
GRUSE(ACCR)=0; GRUSE(BREG)=0
NEST=ACCR
->OKEXIT
ADHOC(5): ! ADDR(=14)
P=P+5; CNAME(4,REG); ! FETCH ADDRESS MODE
NEST=REG
P=P+1; ->OKEXIT
ADHOC(6): ! MOD(=23), IMOD(=51)
%IF SNNO=51 %THEN %START
JJ=X'51'; B=5; D=IRSB
%FINISH %ELSE %START
JJ=X'62'; B=1; D=RRSB
%FINISH
CSEXP(ACCR,JJ); ! INTEGER OR LONGREAL MODE
PF3(JAT,B,0,3); ! JUMP ACC >0
PSF1(D,0,0)
GRUSE(ACCR)=0
NEST=ACCR
->OKEXIT
ADHOC(7): ! CHARNO(=45) & LENGTH(=36)
P=P+5
CNAME(4,BREG)
ERRNO=22
->ERREXIT %UNLESS TYPE=5
P=P+2
%IF SNNO#36 %THEN %START
PF1(STB,0,TOS,0)
CSEXP(BREG,X'51')
P=P+1
PF1(ADB,0,TOS,0)
GRUSE(BREG)=0
%FINISH
DISP=MAPDES(3)
AREA=PC; ACCESS=3
SNPTYPE=SNPTYPE+X'1400'
->OKEXIT
ADHOC(12): ! PI(=52)
ADHOC(8): ! NL(=38). THIS FN IS PICKED OFF
NEST=0; ! IN CSEXP.ONLY COMES HERE IN
->OKEXIT; ! ERROR EG NL=A+B
ADHOC(9): ! TOSTRING(=46)
CSEXP(ACCR,X'51'); ! RET EXPSN
P=P+1
RTOS(BREG)
DISP=MAPDES(3)
AREA=PC; ACCESS=3
SNPTYPE=SNPTYPE+X'1400'
->OKEXIT
ADHOC(10): ! RECORD(=48)
%IF RECTB=0 %THEN JJ=X'1800FFFF' %AND %C
STORECONST(RECTB,4,ADDR(JJ))
%IF REG=ACCR %THEN %START
CSEXP(ACCR,X'51')
PF1(LUH,0,PC,RECTB)
%FINISH %ELSE %START
CSEXP(BREG,X'51')
PF1(LDTB,0,PC,RECTB)
PF1(LDA,0,BREG,0)
%FINISH
P=P+1
GRUSE(REG)=0
OLDI=0; ACC=X'FFFF'
SNPTYPE=SNPTYPE+X'1400'; ! ADD MAP BITS
->OKEXIT
ADHOC(11): ! ARRAY(=49)
CSEXP(ACCR,X'51'); ! ADDR(A(0)) TO ACCR
ERRNO=22
->ERREXIT %UNLESS A(P+4)=4 %AND A(P+5)=1
REGISTER(ACCR)=1; OLINK(ACCR)=ADDR(R)
R=0; R_PTYPE=X'51'
R_FLAG=9; R_XB=ACCR
P=P+6; CNAME(12,0)
%IF R_FLAG#9 %THEN PF1(LSS,0,TOS,0)
REGISTER(ACCR)=0
->ERREXIT %UNLESS A(P)=2 %AND ARR>0
P=P+2
CREATE AH(0)
%RETURN
ADHOC(13): ! EVENTINF(=33) & EVENTLINE
D=ONINF(LEVEL)
FAULT(16,SNNAME) %IF D=0
D=D+4 %IF SNNO#33
PSF1(LSS,1,D)
GRUSE(ACCR)=0
NEST=ACCR
->OKEXIT
ADHOC(14): ! LENGTHEN AND SHORTEN
D=(SNNO&3)*8
CSEXP(ACCR,X'62517261'>>D&255)
P=P+1; NEST=ACCR
OKEXIT: ! NORMAL EXIT
PTYPE=SNPTYPE; UNPACK
%RETURN
ERREXIT: ! ERROR EXIT
FAULT(ERRNO,SNNAME)
BASE=0; DISP=0; ACCESS=0; AREA=0
P=PIN+2; SKIP APP
P=P-1; %RETURN
%INTEGERFN OPTMAP
!***********************************************************************
!* LOOK FOR EXPRESSION LIKE INTEGER(ADDR(X)) AND AVOID USING DR *
!***********************************************************************
%INTEGER VARNAME,REXP,PP,CVAL,OP
%IF 3<=Z<=4 %OR SNNO=42 %OR SNNO=32 %OR SNNO=61 %THEN %RESULT=0
PP=P+2; REXP=FROM AR2(PP)+PP; ! TO REST OF EXP
VARNAME=FROM AR2(PP+4); ! SHOULD BE ADDR
%RESULT=0 %UNLESS A(PP+2)=4 %AND A(PP+3)=1 %AND A(PP+6)=1
COPY TAG(VARNAME); ! CHECK IT WAS ADDR
%RESULT=0 %UNLESS PTYPE=SNPT %AND K=14
PP=PP+10
%RESULT=0 %UNLESS A(PP)=4 %AND A(PP+1)=1 %AND %C
A(PP+4)=2=A(PP+5) %AND A(PP+6)=2=A(PP+7) %AND A(PP+8)=2
VARNAME=FROM AR2(PP+2); COPY TAG(VARNAME)
%RESULT=0 %UNLESS PTYPE&X'FF0C'=0
%IF A(REXP)=2 %THEN P=REXP+2 %ELSE %START
OP=A(REXP+1)
%RESULT=0 %UNLESS 1<=OP<=2 %AND A(REXP+2)=2 %AND %C
A(REXP+3)=X'51' %AND A(REXP+8)=2
CVAL=FROM AR4(REXP+4)
%IF OP=1 %THEN K=K+CVAL %ELSE K=K-CVAL
%RESULT=0 %IF K<0
P=REXP+10
%FINISH
BASE=I
DISP=K; AREA=-1; ACCESS=0
AREA=AREA CODE
%RESULT=1
%END
%ROUTINE RTOS(%INTEGER REG)
!***********************************************************************
!* PLANTS CODE TO CONVERT A SYMBOL IN ACC TO A ONE *
!* CHARACTER STRING IN A TEMPORARARY VARIABLE. *
!***********************************************************************
%INTEGER KK
GET WSP(KK,1); ! GET 1 WORD WK AREA
STRINGL=1; DISP=KK+2
PF1(OR,0,0,256)
PSF1(ST,1,KK)
GET IN ACC(REG,1,0,LNB,PTR OFFSET(RBASE))
%IF REG=BREG %THEN KK=ADB %ELSE KK=IAD
PSF1(KK,0,DISP)
GRUSE(BREG)=0
%END
%END; ! OF ROUTINE CSNAME
%ROUTINE CANAME(%INTEGER ARRP,BS,DP)
!***********************************************************************
!* BS & DP DEFINE THE POSITION OF THE ARRAY HEAD *
!* ARRP=1 FOR ARRAYS,2 FOR VECTORS,3 FOR ARRAYS IN RECORDS *
!* BASIC DISP = DISPMNT OF A(0) FOR VECTORS OR ARRAYS IN RECORDS *
!***********************************************************************
%INTEGER HEAD1,HEAD2,HEAD3,NOPS,PTYPEP,KK,PP,JJ, %C
TYPEP,ARRNAME,Q,PRECP,ELSIZE,NAMINF,BOT1,BOT2,BOT3
PP=P; TYPEP=TYPE
JJ=J; PTYPEP=PTYPE; PRECP=PREC
%IF TYPE<=2 %THEN ELSIZE=BYTES(PRECP) %C
%ELSE ELSIZE=ACC
ARRNAME=FROM AR2(P); ! NAME OF ENTITY
NAMINF=TAGS(ARRNAME)
FAULT(29,ARRNAME) %IF ARR=3; ! ARRAYFORMAT USED AS ARRAY
NAMINF=-2 %IF ARRP>2; ! SWITCHES&ARRAYS IN RECORDS
ARRP=ARRP&X'F'; ! NOT OPTIMISED
TEST APP(Q); ! COUNT NO OF SUBSCRIPTS
!
! CHECK CORRECT NO OF SUBSCRIPTS PROVIDED. HOWEVER ENTITIES DECLARED
! AS %<TYPE>ARRAYNAME HAVE NO DIMENSION . THIS SECTION SETS THE
! DIMENSION FROM THE FIRST USE OF THE NAME.
!
%IF JJ=0 %THEN %START; ! 0 DIMENSIONS = NOT KNOWN
REPLACE1(TCELL,FROM1(TCELL)!Q);! DIMSN IS BOTTOM 4 BITS OF TAG
JJ=Q
%FINISH
%IF JJ=Q#0 %THEN %START; ! IN LINE CODE
!
! FOR IN-LINE CODE WE SET UP A CHAIN OF REVERSE POLISH OPERATIONS TO
! EVALUATE THE VARIOUS SUBSCRIPTS,MULTIPLY BY THE MULTIPLIERS AND
! ADD THEM TOGETHER.
!
NOPS=0;HEAD1=0;HEAD2=0;HEAD3=0;! CLEAR LISTHEADS
BOT1=0; BOT3=0
!
! NOW PROCESS THE SUBSCRIPTS CALLINR TORP TO CONVERT THE EXPRESSIONS
! TO REVERSE POLISH AND ADDING THE EXTRA OPERATIONS.
!
P=PP+3
%IF ARRP=2 %OR (JJ=1 %AND TYPE<=2 %AND PARMARR=0 %AND %C
(NAM=0 %OR COMPILER#0)) %START
CSEXP(BREG,X'51'); P=P+1
%IF PRECP=4 %THEN PF1(ADB,0,BREG,0) %AND GRUSE(BREG)=0
%FINISH %ELSE %START
%CYCLE KK=1,1,JJ; ! THROUGH THE SUBSCRIPTS
P=P+3; BOT2=0
TORP(HEAD2,BOT2,NOPS); ! SUBSCRIPT TO REVERSE POLISH
P=P+1
!
! MULTIPLIERS ARE DOPE VECTOR ITEMS (OPTYPE=3)
!
! N SUBSCRIPTS WILL REQUIRE (N-1) MULTIPLICATIONS AND ADDITIONS
!
NOPS=(NOPS+1)!1<<24; ! DVM AS '*'
PUSH(HEAD3,33,0,0); ! DOPE VECTOR MULTIPLY
BOT3=HEAD3 %IF BOT3=0
PUSH(HEAD3,1<<16,KK<<16!JJ,BS<<18!DP);! MULTIPLIER
! CONCAT (HEAD1,HEAD2); ! OPERANDS TO MAIN LIST
%IF HEAD1=0 %THEN HEAD1=HEAD2 %ELSE %C
ASLIST(BOT1)_LINK=HEAD2
BOT1=BOT2; HEAD2=0
%REPEAT
!
! ADD OPERATORS TO THE BACK OF OPERANDS AND EVALUATE
!
! CONCAT(HEAD1,HEAD3); ! OPERATORS LINKED ON
ASLIST(BOT1)_LINK=HEAD3
BOT1=BOT3
PP=P
EXPOP(HEAD1,BREG,NOPS,X'51'); ! EVALUATE THE REVERSE POLISH LIST
P=PP
!
! CLEAR LIST(HEAD1); ! RETURN SPACE
ASLIST(BOT1)_LINK=ASL
ASL=HEAD1
%FINISH
BASE=BS; DISP=DP; ACCESS=3; AREA=-1
%FINISH %ELSE %START
FAULT(19,ARRNAME)
P=P+1; SKIP APP
BASE=BS; DISP=0; ACCESS=3; AREA=-1
%FINISH
ACC=ELSIZE
PTYPE=PTYPEP; UNPACK; J=JJ
%END; ! OF ROUTINE CANAME
%ROUTINE CNAME(%INTEGER Z, REG)
!***********************************************************************
!* THIS IS THE MAIN ROUTINE FOR PROCESSING NAMES.CANAME,CSNAME *
!* AND CRNAME ARE ONLY CALLED FROM HERE,THE NAME (AND ANY PARAMS *
!* OR SUBNAMES) ARE ACCESSED BY P WHICH IS ADVANCED. *
!* Z SPECIFIES ACTION AS FOLLOWS:- *
!* Z=0 COMPILE A ROUTINE CALL *
!* Z=1 SET ACCESS,AREA AND DISP FOR A 'STORE' OPERATION *
!* Z=2 FETCH NAME TO 'REG' *
!* Z=3 SET DESCRIPTOR IN REG FOR PASSING BY NAME *
!* Z=4 SET 32 BIT ADDRESS OF NAME IN REG *
!* Z=5 DELAYED FETCH IF NAME SIMPLE ELSE AS Z=2 *
!* Z=6 STORE 'REG' (CONTAINS POINTER) INTO POINTER VARIABLE *
!* Z=7->11 NOT NOW USED *
!* Z=12 SET BASE AND DISP TO POINT TO ARRAYHEAD *
!* Z=13 SET REG TO POINT TO 4 WORD ROUTINE DISCRIPTOR *
!* (INTERNAL ROUTINES FIRST CREATE THE DISCRIPTOR) *
!* Z=14 STORE 'REG' INTO A RECORD NAME VARIABLE *
!* Z=15 SET 'REG' TO POINT TO A RECORD *
!* Z=16 SET BASE AND DISP FOR RECORD *
!* *
!* REG (WHERE APPROPRIATE) IS SET AS FOLLOWS:- *
!* >=0 A REGISTER *
!* -1 MEANS CHOOSE ANY REGISTER *
!* IF A REGISTER IS CHOSEN THEN NEST IS SET WITH CHOICE *
!***********************************************************************
%INTEGER JJ, JJJ, KK, RR, LEVELP, DISPP, NAMEP, PP, SAVESL, FNAME
%SWITCH S, FUNNY(12:13), SW(0:8), MAP(0:3)
PP=P
FNAME=A(P)<<8+A(P+1)
%IF Z=1 %OR Z=6 %THEN STNAME=FNAME
COPYTAG(FNAME)
%IF I=-1 %THEN %START
FAULT(16, FNAME)
I=RLEVEL; J=0; K=FNAME
KFORM=0; SNDISP=0; ACC=4
PTYPE=7; STORE TAG(K, N)
K=N; N=N+4; COPYTAG(FNAME);! SET USE BITS!
%FINISH
SAVESL=ACC
JJ=J; JJ=0 %IF JJ=15
NAMEP=FNAME
LEVELP=I; DISPP=K
FAULT(29, FNAME) %IF LITL=1 %AND ROUT=0 %AND %C
(Z=1 %OR Z=3 %OR (Z=4 %AND TYPE<5 %AND ARR=0))
->NOT SET %IF TYPE=7
%IF (Z=0 %AND (ROUT#1 %OR 0#TYPE#6)) %OR (Z=13 %AND ROUT=0) %C
%THEN FAULT(17,FNAME) %AND ->NOT SET
->FUNNY(Z) %IF Z>=10
->RTCALL %IF ROUT=1
->SW(TYPE)
SW(6):
SW(4): !RECORD FORMAT NAME
FAULT(20, FNAME)
SW(7):
NOT SET: ! NAME NOT SET
NEST=0; BASE=I; DISP=K; ACCESS=0
AREA=LNB; PTYPE=1; UNPACK
P=P+2; SKIP APP; ->CHKEN
FUNNY(12): ! SET BASE & DISP FOR ARRAYHEAD
->SW(3) %IF TYPE=3 %AND (ARR=0 %OR A(P+2)=1)
%IF PTYPE=SNPT %THEN CSNAME(12,REG) %ELSE %START
ACCESS=0; BASE=I; DISP=K; AREA=-1
%IF ARR=1=J %AND PARMARR=0=NAM %AND TYPE<=2 %START;! ADJUST DESR TO 1ST ELMNT
GET WSP(JJ,4)
GET IN ACC(ACCR,4,0,AREA CODE,DISP)
PSF1(ST,1,JJ)
GET IN ACC(BREG,1,2,LNB,JJ+8);
KK=MODD
%IF PREC=4 %THEN PF1(ADB,0,BREG,0) %AND KK=INCA
PSF1(LD,1,JJ)
PF1(KK,0,BREG,0); ! ADJUST DESCRPTR
PSF1(STD,1,JJ)
GRUSE(DR)=0; GRUSE(ACCR)=0
GRUSE(BREG)=0; AREA=LNB; DISP=JJ
%FINISH
%IF A(P+2)=2 %THEN P=P+3 %ELSE NO APP
%FINISH
S(12): ! ARRAYS IN RECORDS BY NAME
->CHKEN
FUNNY(13): ! LOAD ADDR FOR RT-TYPE
%IF PTYPE=SNPT %THEN CSNAME(Z,REG) %AND P=P+1 %AND->CHKEN
DISP=FROM1(K); BASE=I
%IF NAM&1#0 %THEN %START
AREA=-1
GET IN ACC(REG,4,0,AREA CODE,DISP)
%FINISH %ELSE %START
%IF J=14 %THEN %START; ! EXTERNAL ROUTINE PASSED
GET IN ACC(REG,2,0,0,0); ! ZERO ENVIRONMENT
GET IN ACC(DR,2,0,SET XORYNB(-1,-1),DISP)
! PSF1(MODD,0,0); ! PROVOKE ESCAPE IF DYNAMIC
%FINISH %ELSE %START
%IF BASE=0 %AND CPRMODE=2 %START;! IN FILE OF RTS
PSF1(LD,1,12)
PSF1(INCA,0,DISP) %UNLESS DISP=0
GET IN ACC(ACCR,2,0,0,0)
%FINISH %ELSE %START
PSF1(JLK,0,1); ! GET PC TO TOS
RTJUMP(LDA,ASLIST(K)_S1); ! ADD N TO POINT @ ENTRY
PF1(INCA,0,TOS,0); ! AND TO DES REG
JJ=X'E0000001'
STORE CONST(JJJ,4,ADDR(JJ))
PF1(LDTB,0,PC,JJJ)
GET IN ACC(ACCR,1,0,LNB,PTR OFFSET(BASE))
PSF1(LUH,0,0); ! SPARE FIELD IN RT HDDR
%FINISH
%FINISH
PF1(STD,0,TOS,0); ! DR TO TOP OF STACK
PF1(LUH,0,TOS,0); ! AND TO TOP 64 BITS OF ACC
GRUSE(DR)=0
%FINISH
%IF A(P+2)=2 %THEN P=P+3 %ELSE NO APP; ->CHKEN
SW(3): ! RECORD
CRNAME(Z, REG, 2*NAM, I, -1, K, NAMEP)
->S(Z) %IF Z>=10
STNAME=-1 %IF Z=1 %OR Z=6
->STRINREC %IF TYPE=5 %AND Z#6
->NOT SET %IF TYPE=7
NAMEOP(Z,REG,BYTES(PREC),NAMEP)
->CHKEN
SW(5): ! TYPE =STRING
!
! ALL STRING OPERATIONS ARE ON THE RELEVANT DESCRIPTOR. Z=2 &Z=5
! REQUIRE A CURRENT LENGTH(IE MODIFIED) DESCRIPTOR. OTHER OPERATIONS
! REQUIRE THE MAX LENGTH DESCRIPTOR (IE UNMODIFIED HEADER)
!
%IF Z=6 %THEN ->SW(1)
->STRARR %IF ARR>=1
%IF A(P+2)=2 %THEN P=P+3 %ELSE NO APP
BASE=I; ACCESS=2; AREA=-1; DISP=K
SNINREC: %IF Z=1 %THEN Z=3; ! STRINGNAMES IN RECORDS
%IF Z=3 %OR Z=4 %THEN NAMEOP(Z,REG,8,-1) %AND ->CHKEN
%IF ACCESS=2 %AND PARMCHK=0 %AND REGISTER(DR)=0 %START
PSORLF1(LDB,2,AREA CODE,DISP);! LOAD BND & DR IN 1 INSTRN
GRUSE(DR)=0
%IF REG=ACCR %THEN COPY DR
->CHKEN
%FINISH
NAMEOP(3,DR,8,-1)
MBND: %IF PARMCHK=1 %THEN TEST ASS(DR,5,8)
PF1(LDB,2,7,0); ! LBOUND FIRST BYTE=CURRENT L
%IF REG=ACCR %THEN COPY DR
->CHKEN
STRARR: ! STRINGARRAYS & ARRAYNAMES
CANAME(ARR, I, K)
SAINREC: ! STRING ARRAYS IN RECORDS
%IF Z=1 %OR Z=3 %THEN %START
%IF NAM=1 %THEN %START
PSF1(INCA,0,-8); ! DR TO SIZE ITEM IN DV
PF1(SLB,2,7,0); ! STACK MODIFIER FETCH SIZE
! PSF1(SBB,0,1); ! REMOVE CURR LENGTH BYTE
%FINISH
GET IN ACC(DR,2,0,AREA CODE,DISP)%IF AREA#7;! ALREADY IN DR
%IF NAM=1 %THEN %START
PF1(MODD,0,TOS,0)
PF1(LDB,0,BREG,0)
%FINISH %ELSE %START
PF1(MODD,0,BREG,0)
PSF1(LDB,0,ACC)
%FINISH
%IF REG=ACCR %THEN COPY DR
->CHKEN
%FINISH
%IF Z=4 %THEN ACCESS=3 %AND NAMEOP(Z,REG,4,-1) %AND ->CHKEN
! SPECIAL FOR Z=4 IN CRNAME !
GET IN ACC(DR,2,0,AREA CODE,DISP) %UNLESS AREA=7
PF1(MODD,0,BREG,0)
->MBND
STRINREC: ! STRINGS IN RECORDS
->SAINREC %IF ARR#0
->SNINREC %IF NAM#0 %OR Z=4
!
! STRINGS IN RECORDS HAVE NO HEADER AND ARE SPECIAL
!
NAMEOP(4,BREG,4,-1)
PF1(LDTB,0,PC,PARAM DES(3))
PF1(LDA,0,BREG,0)
PSF1(LDB,0,ACC) %UNLESS Z=2 %AND PARMCHK=0
GRUSE(DR)=0
->MBND %IF Z=2
COPY DR %IF REG=ACCR
->CHKEN
!
! SECTION TO DEAL WITH ALL NAMES INVOLVING ROUTINE CALL
!
RTCALL: ! FIRST CHECK
%IF TYPE=0 %AND Z#0 %THEN FAULT(23, FNAME) %AND ->NOT SET
! RT NAME IN EXPRSN
%IF PTYPE=SNPT %THEN %START
CSNAME(Z, REG); ! SPECIAL NAME
->BIM %IF ROUT=1 %AND NAM>=1 %AND Z#0
%IF TYPE#0 %AND NEST=ACCR %THEN ->MVFNRES
P=P+1; ->CHKEN
%FINISH
%IF FROM2(K)=1000 %THEN FAULT(21, FNAME) %AND ->NOT SET
! USE BEFORE %SPEC GIVEN
CRCALL(FNAME); P=P+1; ! DEAL WITH PARAMS
->CHKEN %IF PTYPE&15=0
->UDM %IF NAM>1; ! MAPS
%UNLESS Z=2 %OR Z=5 %THEN %START; ! FUNCTIONS
FAULT(29, FNAME); BASE=0
ACCESS=0; DISP=0
%FINISH
MVFNRES: %IF TYPE=5 %THEN %START; ! STRING FNS
%IF REG=DR %THEN PF1(ST,0,TOS,0) %AND PF1(LD,0,TOS,0)
%FINISH %ELSE %START
%IF REG=BREG %THEN PF1(ST,0,BREG,0)
%FINISH
NEST=REG; ->CHKEN
UDM: ! USER DEFINED MAPS
PF1(ST,0,BREG,0); ! RETURN 32 BIT ADDR IN ACC
DISP=MAPDES(PREC)
ACCESS=3; AREA=PC
NAMEP=-1
BIM: ! BUILT IN MAPS
NAMEP=-1 %UNLESS AREA=PC %AND ACCESS=3
->CHKEN %IF TYPE=3; ! MAP RECORD USE VERY LIMITED
%IF Z=3 %OR (TYPE=5 %AND Z#4) %START
PF1(LDTB,0,PC,DISP)
%IF TYPE=5 %AND (PARMCHK#0 %OR Z#2) %THEN PSF1(LDB,0,255)
PF1(LDA,0,BREG,0)
GRUSE(DR)=0
%FINISH %ELSE %START
%IF GRUSE(DR)=7 %AND GRINF(DR)=NAMEP>0 %AND 1<=Z<=2 %C
%THEN AREA=7; ! CHANGE TO(%DR+%B) FORM
%FINISH
NAM=0
KK=Z; KK=2 %IF Z=5
->MAP(KK&3)
MAP(0): ! FETCH ADDRESS
%IF REG#BREG %THEN GETINACC(ACCR,1,0,BREG,0)
->CHKEN
MAP(1): ! STORE
->CHKEN %UNLESS TYPE=5; ->MAP(3)
MAP(2): ! FETCH
%IF TYPE=5 %THEN ->MBND
GET IN ACC(REG,BYTES(PREC)>>2,ACCESS,AREA,DISP)
%IF NAMEP>0 %THEN GRUSE(DR)=7 %AND GRINF(DR)=NAMEP
%IF PARMCHK=1 %AND PREC>=5 %THEN TEST ASS(REG,1,BYTES(PREC))
->CHKEN
MAP(3): ! SET DESCRIPTOR
%IF TYPE=5 %THEN PF1(LDB,0,0,256)
COPY DR %UNLESS REG=DR
->CHKEN
SW(0): ! %NAME PARAMETERS NO TYPE
! ALLOW FETCH ADDR OPERATIONS
! AND SPECIAL FOR BUILTIN MAPS
%UNLESS 3<=Z<=4 %THEN %START
FAULT(12, FNAME); TYPE=1
%FINISH
SW(1): ! TYPE =INTEGER
SW(2): ! TYPE=REAL
%IF ARR=0 %OR (Z=6 %AND A(P+2)=2) %THEN %START
BASE=I; ACCESS=2*NAM
DISP=K; AREA=-1
%IF A(P+2)=2 %THEN P=P+3 %ELSE NO APP
%FINISH %ELSE %START
CANAME(ARR, I, K)
NAM=0
%FINISH
NAMEOP(Z,REG,BYTES(PREC),NAMEP)
->CHKEN
!
! GENERAL FETCHING & STORING
!SECTION
!
CHKEN: %WHILE A(P)=1 %CYCLE
FAULT(69,FNAME)
P=P+3; SKIP APP
%REPEAT
P=P+1
%END
%ROUTINE NAMEOP(%INTEGER Z,REG,SIZE,NAMEP)
!***********************************************************************
!* FETCH OR STORE REG FROM OR TO VARIABLE DEFINED BY AREA ACCESS *
!* BASE AND DISP. *
!***********************************************************************
%SWITCH MOD(0:47)
%INTEGER KK,JJJ,TOTHER,XYNB,JJ,OP1,OP2
KK=Z; KK=2 %IF Z=5
%IF Z=6 %THEN %START
FAULT(17,0) %UNLESS NAM=1 %AND ROUT=0 %AND %C
(ACCESS>=8 %OR ACCESS=2)
KK=1; SIZE=8
%IF ACCESS>=8 %THEN ACCESS=ACCESS-4 %ELSE ACCESS=0
%FINISH
KK=KK&3
->MOD(ACCESS<<2!KK)
!
! AREA AND ACCESS
! **** *** ******
! THESE VARIABLES DEFINE HOW TO ACCESS ANY IMP VARIABLE. AREA HAS THE
! THREE BIT AREA CODE FROM THE PRIMARY FORMAT INSTRN.(EG 6=TOS ETC)
! THE SPECIAL CASE AREA=-1 IS USED FOR ENTITIES IN STACK FRAME 'BASE'
! THE FN AREA CODE CONVERTS THIS CASE TO AREA=LNB OR AREA=XNB ARRANGING
! TO LOAD XNB IF NECESSARY.
!
! ACCESS HAS TWO VERSIONS OF THE 2-BIT INDIRECTION CODE FROM PRIMARY
! FORMAT INSTRNS:-
! =0 VARIABLE DIRECTLY ADDRESSED IN 'AREA' BY 'DISP'
! =1 VARIABLE ADDRESSED BY DR MODIFIED BY 'AREA' & 'DISP'
! =2 DESCRIPTOR TO VARIABLE DIRECTLY ADDRESS BY 'AREA' & 'DISP'
! =3 DESCRIPTOR AS IN =2 IS TO BE MODIFIED BY 'B'
! =4 VARIABLE 'XDISP' INTO RECORD DIRECTLY ADDRESSED BY 'AREA' & 'DISP'
! =5 VARIABLE 'XDISP' INTO RECORD ADDRESSED BY DR MODIFIED AS =1
! =6 VAR 'XDISP' INTO RECORD ADDRESSED BY DESCRIPTOR AT 'AREA' & 'DISP'
! =7 AS =6 BUT DESCRIPTOR MODIFIED BY B
! =8-11 AS 4-7 BUT THERE IS A DESCRIPTOR TO ITEM AT 'XDISP' INTO RECORD
!
! THESE COVER ALL THE COMMON CASES. ITEMS LIKE ARRAYS IN RECORD ARRAYS
! NEED AN INTERMEDIATE DESCRIPTOR TO BE CALCULATED AND(USUALLY) STACKED
!
MOD(0): ! ACCESS=0 FETCH ADDRESS
%IF TYPE=3 %THEN GETINACC(REG,1,0,AREA CODE,DISP-4) %ANDRETURN
GET IN ACC(REG,1,0,LNB,PTR OFFSET(BASE))
%IF REG=BREG %THEN JJJ=ADB %ELSE JJJ=IAD
PSF1(JJJ,0,DISP)
%IF BIMSTR=1 %THEN NOTE ASSMENT(REG,3,NAMEP)
%RETURN
MOD(1): ! ACCESS=0 STORE
%IF 1<=SIZE<=2 %THEN %START; ! BYTES & HALFS REQUIRE DESCRIPTOR
PF1(LDTB,0,PC,MAP DES(SIZE+2)) %UNLESS GRUSE(DR)=SIZE+11
PSF1(LDA,1,PTR OFFSET(BASE)) %C
%UNLESS 12<=GRUSE(DR)<=13 %AND GRINF(DR)=BASE
GRUSE(DR)=SIZE+11; GRINF(DR)=BASE
ACCESS=1; AREA=0
%FINISH %ELSE AREA=AREA CODE
%RETURN
MOD(2): ! ACCESS=0 FETCH
%IF SIZE>2 %AND Z=5 %AND PARMCHK=0 %THEN NEST=-1 %AND %RETURN
MOD(10): ! ACCESS=2 FETCH
%IF GRUSE(REG)=9 %AND NAMEP>0 %THEN %START
%IF GRINF(REG)&X'FFFF'=NAMEP %OR GRINF(REG)>>16=NAMEP %START
%IF REGISTER(REG)#0 %THEN BOOT OUT(REG)
NEST=REG; %RETURN
%FINISH
%FINISH
TOTHER=REG!!7
%IF GRUSE(TOTHER)=9 %AND NAMEP>0 %START
KK=GRINF(TOTHER)
%IF KK&X'FFFF'=NAMEP %OR KK>>16=NAMEP %START
%IF REG=BREG %AND REGISTER(BREG)=0 %START
PF1(ST,0,BREG,0); ! ACC TO BRGE
GRUSE(REG)=9; GRINF(REG)=KK
NEST=REG
%RETURN
%FINISH
%IF REG=ACCR %AND Z=2 %THEN %START
ACCESS=0; AREA=7
SIZE=4; DISP=0
%FINISH
%FINISH
%FINISH
%IF 1<=SIZE<=2 %AND ACCESS=0 %THEN %START; ! BYTES
PF1(LDTB,0,PC,MAP DES(SIZE+2)) %UNLESS GRUSE(DR)=SIZE+11
PSF1(LDA,1,PTR OFFSET(BASE)) %C
%UNLESS 12<=GRUSE(DR)<=13 %AND GRINF(DR)=BASE
GRUSE(DR)=SIZE+11; GRINF(DR)=BASE
%IF Z=5 %AND PARMCHK=0 %START
ACCESS=1; AREA=0; NEST=-1; %RETURN
%FINISH
GET IN ACC(REG,1,1,0,DISP)
%IF PARMCHK#0 %AND SIZE=2 %THEN TEST ASS(REG,TYPE,SIZE)
NEST=REG; %RETURN
%FINISH
MOD(6): ! ACCESS=1 FETCH
MOD(14): ! ACCESS=3 FETCH
%IF ACCESS>=2 %AND GRUSE(DR)=7 %AND GRINF(DR)=NAMEP>0 %THEN %C
AREA=7 %AND DISP=0 %ELSE AREA=AREA CODE
GET IN ACC(REG,SIZE>>2,ACCESS,AREA,DISP)
%IF PARMCHK=1 %AND SIZE#1 %THEN TEST ASS(REG,TYPE,SIZE)
%IF (ACCESS=0 %OR ACCESS=2) %AND NAMEP>0 %THEN %C
GRUSE(REG)=9; GRINF(REG)=NAMEP
%IF ACCESS>=2 %AND NAMEP>0 %THEN %C
GRUSE(DR)=7 %AND GRINF(DR)=NAMEP
NEST=REG; %RETURN
MOD(3): ! ACCESS=0 SET DESCRIPTOR
ABORT %UNLESS REG=ACCR %OR REG=DR
%IF TYPE=3 %THEN %START
! JJ=X'18000000'+ACC
! STORE CONST(JJJ,4,ADDR(JJ))
GET IN ACC(REG,2,0,AREA CODE,DISP-8);! PTR BEFORE START
%RETURN
%FINISH %ELSE JJJ=PARAM DES(PREC)
!
%IF REG=ACCR %THEN %START
GET IN ACC(REG,1,0,LNB,PTR OFFSET(BASE))
OP1=IAD; OP2=LUH
%FINISH %ELSE %START
PSF1(LDA,1,PTR OFFSET(BASE))
OP1=INCA; OP2=LDTB
%FINISH
PSF1(OP1,0,DISP)
PF1(OP2,0,PC,JJJ)
GRUSE(REG)=0
%RETURN
MOD(4): ! ACCESS=1 FETCH ADDRESS
MOD(7): ! ACCESS=1 SET DESCRIPTOR
PSORLF1(INCA,0,AREA CODE,DISP) %UNLESS AREA=0=DISP
COPY DR
PSF1(MPSR,0,X'11') %IF KK=4; ! HALVE ACC SIZE
%RETURN
MOD(5): ! ACCESS=1 STORE
AREA=AREA CODE; %RETURN
MOD(12): ! ACCESS=3 FETCH ADDRESS
JJJ=BYTES(PREC)
PSF1(MYB,0,JJJ) %AND GRUSE(BREG)=0 %UNLESS JJJ=1
MD12: %IF REG=BREG %THEN %START
PF1(ADB,0,AREA CODE,DISP+4)
GRUSE(BREG)=0
%RETURN
%FINISH
MOD(8): ! ACCESS=2 FETCH ADDRESS
GET IN ACC(REG,1,0,AREA CODE,DISP+4)
%IF ACCESS&3=3 %THEN PF1(IAD,0,BREG,0)
%RETURN
MOD(9): ! ACCESS=2 STORE
MOD(13): ! ACCESS=3 STORE
%IF GRUSE(DR)=7 %AND GRINF(DR)=NAMEP>0 %THEN %C
AREA=7 %AND DISP=0 %ELSE AREA=AREA CODE
%RETURN
MOD(11): ! ACCESS=2 SET DESCRIPTOR
%IF AREA=7 %THEN %START
COPY DR %UNLESS REG=DR
%RETURN
%FINISH
GET IN ACC(REG,2,0,AREA CODE,DISP)
%RETURN
MOD(15): ! ACCESS=3 SET DESCRIPTOR
GET IN ACC(DR,2,0,AREA CODE,DISP) %UNLESS AREA=7
%IF PREC=4 %THEN JJ=INCA %ELSE JJ=MODD
PF1(JJ,0,BREG,0)
%IF REG#DR %THEN COPY DR
GRUSE(DR)=0
%RETURN
MOD(17): ! ACCESS=4 STORE
MOD(18): ! ACCESS=4 FETCH
%IF SIZE=1 %THEN DISP=DISP-8 %AND ->MD2526
DISP=DISP+XDISP
ACCESS=0; NAMEP=0
->MOD(KK); ! REDUCES TO ACCESS=0
MOD(20): ! ACCESS=5 FETCH ADDRESS
MOD(21): ! ACCESS=5 STORE
MOD(22): ! ACCESS=5 FETCH
MOD(23): ! ACCESS=5 SET DESCRIPTOR
MOD(36): ! ACCESS=9 FETCH ADDRESS
MOD(37): ! ACCESS=9 STORE
MOD(38): ! ACCESS=9 FETCH
MOD(39): ! ACCESS=9 SET DESCRIPTOR
ABORT
MOD(16): ! ACCESS=4 FETCH ADDRESS
DISP=DISP-8
MOD(24): ! ACCESS=6 FETCH ADDRESS
GET IN ACC(REG,1,0,AREA CODE,DISP+4)
%IF REG=BREG %THEN KK=ADB %ELSE KK=IAD
PSF1(KK,0,XDISP) %UNLESS XDISP=0
%RETURN
MD2526:
MOD(25): ! ACCESS=6 STORE
MOD(26): ! ACCESS=6 FETCH
%IF SIZE>2 %START
XYNB=XORYNB(8,NAMEP)
PSORLF1(LDCODE(XYNB),0,AREA CODE,DISP+4) %UNLESS %C
GRUSE(XYNB)=8 %AND GRINF(XYNB)=NAMEP>0
GRUSE(XYNB)=0
%IF NAMEP>0 %THEN %C
GRUSE(XYNB)=8 %AND GRINF(XYNB)=NAMEP %AND GRAT(XYNB)=CA
AREA=XYNB; ACCESS=0
%FINISH %ELSE %START
PSORLF1(LD,0,AREA CODE,DISP) %UNLESS %C
GRUSE(DR)=7 %AND GRINF(DR)=NAMEP>0
GRUSE(DR)=0
%IF SIZE=2 %THEN PF1(LDTB,0,PC,MAP DES(4)) %ELSE %START
%IF NAMEP>0 %THEN GRUSE(DR)=7 %AND GRINF(DR)=NAMEP
%FINISH
ACCESS=1; AREA=0
%FINISH
DISP=XDISP; NAMEP=0
->MOD(ACCESS<<2!KK)
MOD(19): ! ACCESS=4 SET DESCRIPTOR
DISP=DISP-8
MOD(27): ! ACCESS=6 SET DESCRIPTOR
MOD(31): ! ACCESS=7 SET DESRCPTOR
GET IN ACC(DR,2,0,AREA CODE,DISP)
PSF1(INCA,0,XDISP) %UNLESS XDISP=0
PF1(INCA,0,BREG,0) %IF ACCESS=7
%IF TYPE=3 %OR TYPE=5 %THEN JJJ=3 %ELSE JJJ=PREC
PF1(LDTB,0,PC,PARAM DES(JJJ))
%IF TYPE=3 %OR TYPE=5 %THEN PSORLF1(LDB,0,0,ACC)
%IF REG#DR %THEN COPY DR
%RETURN
MOD(28): ! ACCESS=7 FETCH ADDRESS
PSF1(ADB,0,XDISP) %AND GRUSE(BREG)=0 %UNLESS XDISP=0
ACCESS=3; ->MD12
MOD(29): ! ACCESS=7 STORE
MOD(30): ! ACCESS=7 FETCH
%IF 1<=SIZE<=2 %THEN %START
PSORLF1(LD,0,AREA CODE,DISP)
GRUSE(DR)=0
%IF SIZE=2 %THEN PF1(LDTB,0,PC,MAPDES(4))
PF1(INCA,0,BREG,0)
ACCESS=1; AREA=0
%FINISH %ELSE %START
PSORLF1(ADB,0,AREA CODE,DISP+4)
GRUSE(BREG)=0
XYNB=XORYNB(0,0)
PF1(LDCODE(XYNB),0,BREG,0)
GRUSE(XYNB)=0
AREA=XYNB; ACCESS=0
%FINISH
NAMEP=0
DISP=XDISP; ->MOD(ACCESS<<2!KK)
MOD(32): ! ACCESS=8 FETCH ADDRESS
MOD(33): ! ACCESS=8 STORE
MOD(34): ! ACCESS=8 FETCH
MOD(35): ! ACCESS=8 SET DESCRIPTOR
DISP=DISP+XDISP
NAMEP=0
ACCESS=2; ->MOD(KK+8)
MOD(40): ! ACCESS=10 FETCH ADDRESS
MOD(41): ! ACCESS=10 STORE
MOD(42): ! ACCESS=10 FETCH
MOD(43): ! ACCESS=10 SET DESCRIPTOR
%IF NAMEP>0 %THEN XYNB=XORYNB(8,NAMEP) %ELSE XYNB=XORYNB(0,0)
PSORLF1(LDCODE(XYNB),0,AREA CODE,DISP+4) %UNLESS %C
GRUSE(XYNB)=8 %AND GRINF(XYNB)=NAMEP>0
GRUSE(XYNB)=0
%IF NAMEP>0 %THEN GRUSE(XYNB)=8 %AND GRINF(XYNB)=NAMEP
AREA=XYNB; ACCESS=2; DISP=XDISP
NAMEP=0
->MOD(KK+8)
MOD(44): ! ACCESS=11 FETCH ADDRESS
MOD(45): ! ACCESS=11 STORE
MOD(46): ! ACCESS=11 FETCH
MOD(47): ! ACCESS=11 SET DESCRIPTOR
PSORLF1(ADB,0,AREA CODE,DISP+4)
XYNB=XORYNB(0,0)
PF1(LDCODE(XYNB),0,BREG,0)
GRUSE(XYNB)=0
NAMEP=0; AREA=XYNB
ACCESS=2; DISP=XDISP; ->MOD(KK+8)
%END
%ROUTINE CRCALL(%INTEGER RTNAME)
!***********************************************************************
!* COMPILE A ROUTINE OR FN CALL *
!* THE PROCEDURE CONSIST OF THREE PARTS:- *
!* A) PLANT THE PARAMETER (IF ANY) *
!* B) ENTER THE ROUTINE OR FN *
!* C) FORGET ANY REGISTERS WHICH HOLD ENTITIES THAT CAN BE *
!* ALTERED BY THE CALLED PROCEDURE. *
!***********************************************************************
%SWITCH FPD(0:3)
%INTEGER II,III,QQQ,DLINK,JJ,JJJ,NPARMS,PT,LP,PSIZE, %C
FPTR,TYPEP,PRECP,NAMP,TL,MOVEPTR,CLINK,RDISP
%RECORDNAME LCELL(LISTF)
PT=PTYPE; JJJ=J; TL=OLDI
LP=I; CLINK=K; DLINK=CLINK
TYPEP=TYPE; PRECP=PREC; NAMP=NAM
LCELL==ASLIST(CLINK)
RDISP=LCELL_S1
!
! NOW CHECK THAT THE RIGHT NUMBER OF PARAMETERS HAVE BEEN PROVIDED
!
TEST APP(NPARMS)
P=P+2
%IF LCELL_S2#NPARMS %THEN %START
FAULT(19,RTNAME); ! WRONG NO OF PARAMETERS GIVEN
SKIP APP; P=P-1
%RETURN
%FINISH
!
SAVE IRS; ! STACK ANY IRS BEFORS ASF
PSF1(PRCL,0,4)
FPTR=20
-> ENTRY SEQ %IF NPARMS=0; ! NO PARAMETERS TO BE PLANTED
!
NEXT PARM:CLINK=LCELL_LINK
->ENTRY SEQ %IF CLINK=0
LCELL==ASLIST(CLINK)
PSIZE=LCELL_S2>>16
P=P+1
PTYPE=LCELL_S1
UNPACK
II=TYPE;III=PREC
JJ=(NAM<<1!ARR)&3
%UNLESS (JJ=0 %AND ROUT=0) %OR %C
(A(P+3)=4 %AND A(P+4)=1 %AND A(P+FROMAR2(P+1)+1)=2) %START
FAULT(22,0); SKIP EXP
->NEXT PARM
%FINISH
!
! RT TYPE PARAMS, PASS 4 WORDS SET UP AS CODE DESC,DUMMY & ENVIRONMENT
!
%IF ROUT=1 %THEN %START
II=PTYPE; P=P+5
CNAME(13,ACCR); ! SET UP 4 WDS IN ACC
FAULT(22,0) %IF II&255#PTYPE&255;! PREC&TYPE SIMILAR
P=P+1; MOVEPTR=16
->STUFF
%FINISH
->FPD(JJ)
FPD(0): ! VALUE PARAMETERS
%IF TYPE=5 %THEN %START
CSTREXP(17,DR); ! TO WK AREA & KEEP WK AREA
PSF1(LDB,0,PSIZE)
%IF REGISTER(ACCR)=3 %THEN PF1(ST,0,TOS,0) %C
%AND REGISTER(ACCR)=0
PF1(STD,0,TOS,0)
PUSH(TWSPHEAD,VALUE,268,0); ! RETURN WK AREA AT STMNT END
FPTR=FPTR+8; ->NEXT PARM
%FINISH %ELSE %START
%IF PREC=6 %THEN JJ=3 %ELSE JJ=TYPE
CSEXP(ACCR,III<<4!II)
MOVEPTR=((BYTES(III)+3)&(-4))
%FINISH
->STUFF
!
FPD(2): ! NAME PARAMETERS
P=P+5
FNAME=FROM AR2(P)
COPY TAG(FNAME)
%IF II#0 %OR TYPE=0 %START
CNAME(3,ACCR)
FAULT(22,FNAME) %UNLESS II=TYPE %AND III=PREC
%FINISH %ELSE %START
CNAME(4,ACCR)
%IF TYPE<=2 %THEN JJ=PREC<<27!TYPE %ELSE JJ=X'1A'<<24+ACC
STORE CONST(III,4,ADDR(JJ))
PF1(LUH,0,PC,III)
%FINISH
P=P+1; MOVEPTR=8
->STUFF
!
FPD(1):FPD(3): ! ARRAY NAME (&VALUE)
!
! FOR ARRAYNAME PARAMETERS THE NO OF DIMENSIONS OF THE ARRAY IS
! DEDUCED FROM THE FIRST CALL AND STORED IN STREAM3 OF THE PARAMETER
! LIST. ON ANY SUBSEQUENT CALL ONLY ARRAYS OF THE SAME DIMENSION CAN
! BE PASSED
!
P=P+5
CNAME(12,ACCR)
GET IN ACC(ACCR,4,0,AREA CODE,DISP)
P=P+1; MOVEPTR=16
FAULT(22,0) %AND ->STUFF %UNLESS 1<=ARR<=2 %AND %C
II=TYPE %AND III=PREC
QQQ=FROM1(TCELL)&15; ! DIMENSION OF ACTUAL(IF KNOWN)
JJ=LCELL_S3; ! DIMENSION OF FORMAL
%IF JJ=0 %THEN JJ=QQQ %AND LCELL_S3=JJ
%IF QQQ=0 %THEN QQQ=JJ %AND REPLACE1(TCELL,FROM1(TCELL)!JJ)
FAULT(22,0) %UNLESS JJ=QQQ
STUFF: REGISTER(ACCR)=3
FPTR=FPTR+MOVEPTR
-> NEXT PARM
ENTRY SEQ: ! CODE FOR RT ENTRY
%IF REGISTER(ACCR)=3 %THEN %C
PF1(ST,0,TOS,0) %AND REGISTER(ACCR)=0
J=JJJ
!
! STRING FNS NEED A WORK AREA TO RETURN THEIR RESULTS
!
%IF TYPEP=5 %AND NAMP<=1 %THEN %START
GET WSP(QQQ,268)
RETURN WSP(QQQ,268); ! SAFE AS STRING IMMEDIATLY COPIED
III=X'18000100'; QQQ=QQQ+8
STORE CONST(JJ,8,ADDR(III))
PF1(LD,0,PC,JJ)
PSF1(INCA,1,PTR OFFSET(RBASE))
PF1(STD,0,TOS,0)
FPTR=FPTR+8
%FINISH
!
! ORDINARY ROUTINES WILL AND RT PARAMS MAY REQUIRE AN EXTRA PARAMETER
! BEING LNB FOR THE LEVEL OF ROUTINE DECLARATION TO BE STACKED
!
%IF JJJ=14 %THEN %START; ! EXTERNAL
NMDECS(LEVEL)=NMDECS(LEVEL)!2
II=SET XORYNB(-1,-1)
PSF1(RALN,0,FPTR>>2)
PF1(CALL,2,II,RDISP)
%FINISH %ELSE %START
%IF NAMP&1=0 %THEN %START;! INTERNAL RT CALLS
%IF LP=0 %THEN %START
PSF1(LD,1,12)
PSF1(INCA,0,RDISP) %UNLESS RDISP=0
PSF1(RALN,0,FPTR>>2)
PF1(CALL,2,7,0)
%FINISH %ELSE %START;! NORMAL INTERNAL CALL
II=SET XORYNB(XNB,LP)
PSF1(RALN,0,FPTR>>2)
RT JUMP(CALL,ASLIST(DLINK)_S1)
%FINISH
%FINISH %ELSE %START
AREA=-1; BASE=LP
AREA=AREA CODE
GET IN ACC(DR,2,0,AREA,RDISP);! DESCR TO DR
PSORLF1(LXN,0,AREA,RDISP+12);! XNB TO ENVIRONMENT
PSF1(RALN,0,FPTR>>2); ! RAISE FOR NORMAL PARAMS
PF1(CALL,2,7,0) ;! AND ENTER VIA DESCRPTR IN DR
%FINISH
%FINISH
FORGET(-1)
ROUT=1; TYPE=TYPEP; NAM=NAMP
PREC=PRECP; PTYPE=PT
%END
%ROUTINE RT JUMP(%INTEGER CODE,%INTEGERNAME LINK)
!***********************************************************************
!* PLANTS A CALL TO THE APPROPIATE ENTRY ADDRESS IN LINK *
!* IF ROUTINE HAS BEEN SPECIFIED BUT NOT DESCRIBED THE JUMP CAN *
!* NOT BE PLANTED AND IS LINKED INTO A LIST HEADED BY LINK *
!* TO AWAIT FILLING (BY ' RHEAD ') WHEN THE BODY IS GIVEN. *
!* THE FORMAT OF AN ENTRY IS :- *
!* S1(32 BITS) = INSTRN TO BE PLANTED *
!* S2(32 BITS) = ADDRESS OF JUMP TO BE FILLED *
!* THE CODING ASSUMES I,J&OLDI ARE SET UP FOR THE CALLED ROUTINE *
!***********************************************************************
%INTEGER DP
%IF J=15 %THEN %START; ! RT BODY NOT GIVEN YET
PUSH(LINK,CODE<<24!3<<23,CA,0)
PF1(CODE,0,0,0)
%FINISH %ELSE %START; ! BODY GIVEN AND ADDRESS KNOWN
DP=LINK-CA
DP=DP//2 %IF CODE=CALL; ! CALL WORKS IN HALFWORDS!
PSF1(CODE,0,DP)
%FINISH
%END
%INTEGERFN TSEXP(%INTEGERNAME VALUE)
%SWITCH SW(1:3)
%INTEGER PP,REXP,KK,SIGN,CT
TYPE=1; PP=P
REXP=2-A(P+1+FROM AR2(P+1))
P=P+3
SIGN=A(P)
->TYPED %UNLESS SIGN=4 %OR A(P+1)=2
->SW(A(P+1))
SW(1): ! NAME
P=P+2; REDUCE TAG
->TYPED
SW(2): ! CONSTANT
CT=A(P+2); TYPE=CT&7
->TYPED %UNLESS CT=X'51' %AND SIGN#3
KK=FROMAR4(P+3)
%IF REXP#0 %AND A(P+8)=CONCOP %THEN TYPE=5 %AND ->TYPED
->TYPED %UNLESS REXP=0 %AND 0<=KK<=255
VALUE=KK
P=P+8
%IF SIGN#2 %THEN %RESULT=1
VALUE=-VALUE; %RESULT=-1
SW(3): ! SUB EXPRN
TYPED: P=PP; %RESULT=0
%END
%ROUTINE SKIP EXP
!***********************************************************************
!* SKIPS OVER THE EXPRESSION POINTED AT BY P. USED FOR ERROR *
!* RECOVERY AND TO EXTRACT INFORMATION ABOUT THE EXPRESSION. *
!***********************************************************************
%INTEGER OPTYPE, PIN, J
PIN=P
P=P+3; ! TO P<+'>
%CYCLE; ! DOWN THE LIST OF OPERATORS
OPTYPE=A(P+1); ! ALT OF P<OPERAND>
P=P+2
%IF OPTYPE=0 %OR OPTYPE>3 %THEN ABORT
%IF OPTYPE=3 %THEN SKIP EXP; ! SUB EXPRESSIONS
!
%IF OPTYPE=2 %THEN %START; ! OPERAND IS A CONSTANT
J=A(P)&7; ! CONSTANT TYPE
%IF J=5 %THEN P=P+A(P+5)+6 %ELSE P=P+1+BYTES(A(P)>>4)
%FINISH
!
%IF OPTYPE=1 %THEN %START; ! NAME
P=P-1
%UNTIL A(P)=2 %THEN P=P+3 %AND SKIP APP;! TILL NO ENAME
P=P+1
%FINISH
!
P=P+1
%IF A(P-1)=2 %THEN %EXIT; ! NO MORE REST OF EXP
%REPEAT
%END; ! OF ROUTINE SKIP EXP
%ROUTINE SKIP APP
!***********************************************************************
!* SKIPS ACTUAL PARAMETER PART *
!* P IS ON ALT OF P<APP> AT ENTRY *
!***********************************************************************
%INTEGER PIN
PIN=P
%WHILE A(P)=1 %THEN P=P+1 %AND SKIP EXP
P=P+1
%END
%ROUTINE NO APP
P=P+2
%IF A(P)=1 %THEN %START; ! <APP> PRESENT
FAULT(19,FROM AR2(P-2))
SKIP APP
%FINISH %ELSE P=P+1; ! P NOW POINTS TO ENAME
%END
%ROUTINE TEST APP(%INTEGERNAME NUM)
!***********************************************************************
!* THIS ROUTINE COUNTS THE NUMBER OF ACTUAL PARAMETERS *
!* WHICH IT RETURNS IN NUM. *
!***********************************************************************
%INTEGER PP, Q
Q=0; PP=P; P=P+2; ! P ON NAME AT ENTRY
%WHILE A(P)=1 %CYCLE; ! NO (MORE) PARAMETERS
P=P+1; Q=Q+1
SKIP EXP
%REPEAT
P=PP; NUM=Q
%END
%ROUTINE TEST ASS(%INTEGER REG,TYPE,SIZE)
!***********************************************************************
!* TEST ACC OR B FOR THE UNASSIGNED PATTERN *
!***********************************************************************
%INTEGER OPCODE,A,D
%IF TYPE=5 %THEN %START
ABORT %UNLESS REG=DR
PF1(STD,0,TOS,0)
PF2(SWEQ,1,1,0,0,UNASSPAT&255)
%FINISH %ELSE %START
%IF REG=BREG %THEN OPCODE=CPB %ELSE OPCODE=UCP
%IF SIZE=16 %THEN PF1(STUH,0,TOS,0)
%IF SIZE=2 %THEN A=0 %AND D=UNASSPAT>>16 %ELSE %C
A=PC %AND D=PLABS(1)
PF1(OPCODE,0,A,D)
%IF SIZE=16 %THEN PF1(LUH,0,TOS,0)
%FINISH
PPJ(8,5); ! BE ERROR ROUTINE 5
%IF TYPE=5 %THEN PF1(LD,0,TOS,0)
%END
%ROUTINE CBPAIR(%INTEGERNAME LB,UB)
!***********************************************************************
!* EXTRACT UPPER AND LOWER BOUNDS FROM A CONSTANT BOUND PAIR *
!***********************************************************************
%INTEGER KK,KKK,JJ,BP
P=P+1; KK=0
%CYCLE JJ=1,1,2
KKK=KK
%IF A(P)=2 %THEN KK=-1 %ELSE KK=1; ! EXTRACT SIGN
BP=FROMAR4(P+2)
KK=KK*BP
P=P+6
%REPEAT
%IF KKK>KK %THEN FAULT(43,0) %AND KK=KKK
LB=KKK; UB=KK
%END
%ROUTINE GET WSP(%INTEGERNAME PLACE,%INTEGER SIZE)
!***********************************************************************
!* FIND OR CREATE A TEMPORARY VARIABLE OF 'SIZE' WORDS *
!***********************************************************************
%INTEGER J,K,L
%IF SIZE>4 %THEN SIZE=0
POP(AVL WSP(SIZE,LEVEL),J,K,L)
%IF K<=0 %THEN %START; ! MUST CREATE TEMPORARY
%IF SIZE>1 %THEN ODD ALIGN
K=N
%IF SIZE=0 %THEN N=N+268 %ELSE N=N+SIZE<<2
%FINISH
PLACE=K
PUSH(TWSPHEAD,K,SIZE,0) %UNLESS SIZE=0
%END
%ROUTINE RETURN WSP(%INTEGER PLACE,SIZE)
%IF SIZE>4 %THEN SIZE=0
%IF PLACE<511 %THEN PUSH(AVL WSP(SIZE,LEVEL),0,PLACE,0) %C
%ELSE INSERT AT END(AVL WSP(SIZE,LEVEL),0,PLACE,0)
%END
%ROUTINE SETLINE
!***********************************************************************
!* UPDATE THE STATEMENT NO *
!***********************************************************************
%IF PARMLINE=1 %THEN %START
PSF1(LSS,0,LINE)
PSF1(ST, 1, DIAGINF(LEVEL))
GRUSE(ACCR)=5; GRINF(ACCR)=LINE
%FINISH
%END
%ROUTINE FORGET(%INTEGER REG)
%INTEGER L,U
L=REG; U=L
%IF L<0 %THEN L=0 %AND U=7
%CYCLE REG=L,1,U
%IF REGISTER(REG)>= 0 %THEN GRUSE(REG)=0 %AND GRINF(REG)=0
%REPEAT
%END
%ROUTINE SAVE IRS
!***********************************************************************
!* DUMP ACC AND-OR B ONTO THE STACK. USED BEFORE CALLING FNS *
!* IN EXPRESSIONS. *
!***********************************************************************
ABORT %IF REGISTER(ACCR)=1=REGISTER(BREG)
%IF REGISTER(ACCR)>=1 %THEN BOOT OUT(ACCR)
%IF REGISTER(BREG)>=1 %THEN BOOT OUT(BREG)
%IF REGISTER(DR)>=1 %THEN BOOT OUT(DR)
%END
%ROUTINE BOOT OUT(%INTEGER REG)
!***********************************************************************
!* REMOVE TEMPORARIES FROM REG INTO LOCAL OR ONTO STACK *
!* IT IS VITAL THAT ACC IS STACKED FIRST BEFORE B OR DR *
!* OTHERWISE MIXUPS OCCUR WHEN PASSING MULTI-DIMENSION ARRAY *
!* ELEMENTS WITH FNS AS SUBSCRIPTS AS VALUE SCALARS *
!***********************************************************************
%CONSTBYTEINTEGERARRAY BOOTCODE(0:7)=X'48',X'58',X'5C',0(4),X'5A';
%INTEGER CODE
%RECORDNAME R(RD)
CODE=BOOTCODE(REG)
ABORT %UNLESS 1<=REGISTER(REG)<=3 %AND CODE#0
R==RECORD(OLINK(REG))
%IF REGISTER(REG)=2 %THEN %START
%IF R_D=0 %THEN GET WSP(R_D,BYTES(R_PTYPE>>4)>>2)
PSF1(CODE,1,R_D)
%FINISH %ELSE %START
%IF REG#ACCR %AND(REGISTER(ACCR)=1 %OR REGISTER(ACCR)=3)%C
%THEN BOOT OUT(ACCR)
PF1(CODE,0,TOS,0)
%FINISH
CHANGE RD(REG)
REGISTER(REG)=0
%END
%ROUTINE COPY DR
!***********************************************************************
!* COPY THE DR TO ACC SAVING ANYTHING IN ACC *
!***********************************************************************
%IF REGISTER (ACCR)#0 %THEN BOOT OUT(ACCR)
PSF1(CYD,0,0)
GRUSE(ACCR)=0
%END
%ROUTINE CHANGE RD(%INTEGER REG)
!***********************************************************************
!* CHANGE A RESULT DESCRIPTOR WHEN OPERAND IS STACKED *
!***********************************************************************
%RECORDNAME OPND(RD)
ABORT %UNLESS 1<=REGISTER(REG)<=3;! I-R OR PARAM
OPND==RECORD(OLINK(REG))
%IF REGISTER(REG)=1 %THEN %START; ! CHANGE RESULT DESCRIPTOR
ABORT %UNLESS OPND_FLAG=9 %AND OPND_XB>>4=REG
OPND_FLAG=8; ! CHANGE TO 'STACKED'
OPND_XB=TOS<<4
%FINISH
%IF REGISTER(REG)=2 %START
OPND_FLAG=7; OPND_XB=LNB<<4
%FINISH
%END
%ROUTINE STORE TAG(%INTEGER KK, SLINK)
%INTEGER Q, QQ, QQQ, I, TCELL
%RECORDNAME LCELL(LISTF)
TCELL=TAGS(KK)
Q=PTYPE<<16!LEVEL<<8!RBASE<<4!J
! ABORT %UNLESS (KFORM!ACC)>>16=0
QQQ=SLINK<<16!KFORM
QQ=SNDISP<<16!ACC
%IF FROM1(TCELL)>>8&63=LEVEL %THEN %START
FAULT(7,KK)
Q=FROM1(TCELL)&X'C000'!Q;! COPY USED BITS ACCROSS
REPLACE123(TCELL,Q,QQ,QQQ)
%FINISH %ELSE %START
I=ASL; %IF I=0 %THEN I=MORE SPACE
LCELL==ASLIST(I)
ASL=LCELL_LINK
LCELL_LINK=TAGS(KK)!NAMES(LEVEL)<<18
LCELL_S1=Q; LCELL_S2=QQ; LCELL_S3=QQQ
TAGS(KK)=I
NAMES(LEVEL)=KK
%FINISH
%END
%ROUTINE COPY TAG(%INTEGER KK)
%INTEGER QQ,QQQ
%RECORDNAME LCELL(LISTF)
TCELL=TAGS(KK)
%IF TCELL=0 %THEN %START; ! NAME NOT SET
TYPE=7; PTYPE=X'57'; PREC=5
ROUT=0; NAM=0; ARR=0; LITL=0; ACC=4
I=-1; J=-1; K=-1; OLDI=-1
%FINISH %ELSE %START
LCELL==ASLIST(TCELL)
KK=LCELL_S1
LCELL_S1=KK!X'8000'
QQ=LCELL_S2
QQQ=LCELL_S3
PTYPE=KK>>16; USEBITS=KK>>14&3
OLDI=KK>>8&63; I=KK>>4&15; J=KK&15
SNDISP=QQ&X'FFFF0000'//X'10000'
ACC=QQ&X'FFFF'
K=QQQ&X'FFFF0000'//X'10000'
KFORM=QQQ&X'FFFF'
LITL=PTYPE>>14
ROUT=PTYPE>>12&3
NAM=PTYPE>>10&3
ARR=PTYPE>>8&3
PREC=PTYPE>>4&15
TYPE=PTYPE&15
%FINISH
%END
%ROUTINE REDUCE TAG
!***********************************************************************
!* AS COPY TAG FOR NAME AT A(P) EXCEPT:- *
!* 1) SPECIAL NAMES HAVE THEIR CORRECT PREC & TYPE SUBSTITUTED *
!* 2) RECORD ELEMENTS HAVE THE SUBNAME PARTICULARS RETURNED *
!***********************************************************************
%INTEGER SUBS,QQ,PP
COPY TAG(FROMAR2(P))
%IF PTYPE=SNPT %THEN %START
PTYPE=TSNAME(K); UNPACK
ROUT=1
%FINISH; ! TO AVOID CHECKING PARAMS
%IF TYPE=3 %THEN %START
PP=P; QQ=COPY RECORD TAG(SUBS); P=PP
%FINISH
%END
%ROUTINE REPLACE TAG(%INTEGER KK)
%INTEGER P, Q
P=TAGS(KK)
Q=PTYPE<<16!USEBITS<<14!OLDI<<8!I<<4!J
REPLACE 1(P, Q)
REPLACE3(P, K<<16!KFORM)
%END
! LAYOUT OF PTYPE
! ****** ** *****
! PTYPE REQUIRES 16 BITS TO DEFINE A VARIABLE AND CAN BE REGARDED AS
! AS TWO BYTEINTEGERS:=
! UPPER ONE(UPTYPE):= LITL<<6!ROUT<<4!NAM<<2!ARR
! LOWER ONE(PTYPE) :=PREC<<4!TYPE
! OFTEN (EG IN EXPOP) ONLY THE LOWER PART IS REQUIRED AS FUNCTIONS
! ETC ARE PREFETCHED AND STACKED.
! LITL:= 1=CONST,2=EXTERNAL,3=EXTRINSIC(OR DYNAMIC), 0=NONE OF THESE
! ROUT:= 1 FOR ROUTINE OR FN OR MAP, =0 NONE OF THESE
! NAM := 2 FOR MAPS AND 'REFREFS',=1 FOR NAMES ,=0 DIRECTLY ADDRESSED
! ARR :=1 FOR ARRAYS =0 SCALARS
! PREC IS DESCRIPTOR SIZE CODE FOR EACH PRECISION:-
! :=0 BITS,=3 BYTES, =5 WORDS, =6 D-WRDS, =7,QUAD WRDS
! TYPE:= THE VARIABLE TYPE
! :=0 (TYPE GENERAL),=1 INTEGER, =2 REAL, =3 RECORD
! :=4 (RECORDFORMAT),=5 STRING, =6 LABEL/SWITCH. =7 NOT SET
!
%ROUTINE UNPACK
LITL=PTYPE>>14
ROUT=PTYPE>>12&3
NAM=PTYPE>>10&3
ARR=PTYPE>>8&3
PREC=PTYPE>>4&15
TYPE=PTYPE&15
%END
%ROUTINE PACK(%INTEGERNAME PTYPE)
PTYPE=((((LITL<<2!ROUT)<<2!NAM)<<2!ARR)<<4!PREC)<<4!TYPE
%END
%ROUTINE PPJ(%INTEGER MASK,N)
!***********************************************************************
!* PLANT A 'JCC MASK,PERMENTRY(N)' *
!* IF MASK=0 THEN PLANT A JLK *
!* IF MASK=-1 THEN PLANT A CALL TO PERM *
!***********************************************************************
%INTEGER VAL, INSTRN, CODE
%IF MASK=0 %THEN CODE=JLK %ELSE CODE=CALL
%IF MASK>0 %THEN CODE=JCC
%IF MASK>=16 %THEN CODE=JAT
%IF MASK>=32 %THEN CODE=JAF
VAL=PLABS(N)
%IF MASK<=0 %THEN INSTRN=CODE<<24!3<<23 %ELSE %C
INSTRN=CODE<<24!(MASK&15)<<21
%IF VAL>0 %THEN INSTRN=INSTRN!((VAL-CA)//2)&X'3FFFF' %ELSE %C
PUSH(PLINK(N),CA,INSTRN,0)
PCONST(INSTRN)
FORGET(-1) %IF MASK<=0
%END
%INTEGERFN SET XORYNB(%INTEGER WHICH,RLEV)
!***********************************************************************
!* SET EXTRA NAME BASE TO ADDRESS ROUTINE LEVEL 'RLEV' *
!* RLEV=0 FOR OWNS, =-1 FOR THE PLT THESE ARE THE SAME! BUT CODED*
!* SEPARATELY SO THAT THEY CAN BE SEPARATED IF NECESSARY *
!***********************************************************************
%INTEGER USE,INF,OFFSET
ABORT %UNLESS -1<=RLEV<=RLEVEL
%IF RLEV<=0 %THEN USE=3 %AND INF=0 %ELSE USE=4 %AND INF=RLEV
%IF WHICH<=0 %THEN WHICH=XORYNB(USE,INF)
%IF GRUSE(WHICH)=USE %AND GRINF(WHICH)=INF %THEN %C
GRAT(WHICH)=CA %AND %RESULT=WHICH
OFFSET=PTR OFFSET(RLEV)
PSF1(LDCODE(WHICH),1,OFFSET)
GRUSE(WHICH)=USE; GRINF(WHICH)=INF; GRAT(WHICH)=CA
%RESULT=WHICH
%END
%INTEGERFN XORYNB(%INTEGER USE,INF)
!***********************************************************************
!* CHECKS IF XNB OR YNB SET UP. IF NOT DECIDES WHICH TO OVERWRITE *
!***********************************************************************
%IF GRUSE(XNB)=USE %AND GRINF(XNB)=INF %THEN GRAT(XNB)=CA %C
%AND %RESULT=XNB
%IF GRUSE(CTB)=USE %AND GRINF(CTB)=INF %THEN GRAT(CTB)=CA %C
%AND %RESULT=CTB
%IF GRUSE(XNB)!GRUSE(CTB)=0 %THEN %START;! BOTH REGS ARE FREE
%IF USE=3 %THEN %RESULT=CTB
%RESULT=XNB
%FINISH
!
! IF ONLY ONE FREE THEN NO PROBLEM
%IF GRUSE(XNB)=0 %THEN %RESULT=XNB
%IF GRUSE(CTB)=0 %THEN %RESULT=CTB
!
! BOTH ARE IN USE. THIS IS WORTH CAREFUL CONSIDERATION AND EXPERIMENT
! A VALUE TABLE MAY BE USE AS MAY LOOK AHEAD. CURRENTLY TRY LRU
!
%IF GRAT(XNB)<GRAT(CTB) %THEN %RESULT=XNB
%RESULT=CTB
%END
%ROUTINE ODDALIGN
!***********************************************************************
!* SETS N TO ODD WORD BOUNDARY. SINCE PRECALL ALSO SETS SF TO ODD *
!* WORD BOUNDARY THIS MEANS 64 BIT QUANTITIES ARE 64 BIT ALIGNED *
!* AND CAN BE REFERNCED IN A SINGL CORE CYCLE *
!***********************************************************************
%IF N&7=0 %THEN RETURN WSP(N,1) %AND N=N+4
%END
%INTEGERFN PTROFFSET(%INTEGER RLEV)
!***********************************************************************
!* RETURNS OFFSET FROM LNB OF RELEVANT ITEM IN THE CURRENT DISPLAY *
!* WHICH ENABLES TEXTTUAL LEVEL 'RLEV' TO BE ADDRESSED *
!* A FUNCTION IS USED TO ALLOW CHANGES IN THE DISPLAY FORMAT *
!***********************************************************************
%IF RLEV<=0 %THEN %RESULT=16
%RESULT=DISPLAY(RLEVEL)+(RLEV-1)<<2
%END
%INTEGERFN AREA CODE
!***********************************************************************
!* RETURNS THE AREA CODE FOR ROUTINE LEVEL 'BASE' LOADING *
!* XNB WHERE THIS IS NEEDED *
!***********************************************************************
%IF AREA<0 %THEN %START
%IF BASE=RBASE %THEN AREA=LNB %AND %RESULT=LNB;! LOCAL LEVEL
AREA=SET XORYNB(-1,BASE)
%FINISH
%RESULT=AREA
%END
%ROUTINE GET IN ACC(%INTEGER REG,SIZE,ACCESS,AREA,DISP)
!***********************************************************************
!* LOADS THE REGISTER SPECIFIED ARRANGING FOR AUTOMATIC *
!* STACKING WHEN THIS IS NEEDED *
!* IT IS VITAL THAT ACC IS STACKED FIRST BEFORE B OR DR *
!* OTHERWISE MIXUPS OCCUR WHEN PASSING MULTI-DIMENSION ARRAY *
!* ELEMENTS WITH FNS AS SUBSCRIPTS AS VALUE SCALARS *
!***********************************************************************
%INTEGER OPCODE
SIZE=1 %IF SIZE=0; ! BITS ABD BYTES!
! ABORT %UNLESS REG=ACCR %OR(REG=DR %AND SIZE=2) %OR %C
(REG=BREG %AND SIZE=1)
%IF REG=DR %THEN OPCODE=LD %ELSE %START
%IF REG=BREG %THEN OPCODE=LB %ELSE OPCODE=LSS+SIZE&6
%FINISH
!
%IF REGISTER(REG)>=1 %THEN %START
%IF REGISTER(REG)=2 %THEN BOOT OUT(REG) %ELSE %START
%IF REG#ACCR %AND(REGISTER(ACCR)=1 %OR REGISTER(ACCR)=3)%C
%THEN BOOT OUT(ACCR)
CHANGE RD(REG)
REGISTER(REG)=0
%IF REG=ACCR %THEN OPCODE=OPCODE-32 %ELSE OPCODE=OPCODE-40
%FINISH
%FINISH
PSORLF1(OPCODE,ACCESS,AREA,DISP)
%IF ACCESS>=2 %THEN GRUSE(DR)=0
GRUSE(REG)=0
%END
%ROUTINE NOTE ASSMENT(%INTEGER REG, ASSOP, VAR)
!***********************************************************************
!* NOTES THE ASSIGNMENT TO SCALAR 'VAR'. THIS INVOLVES REMOVING *
!* OLD COPIES FROM REGISTERS TO AVOID CONFUSING OLD AND NEW VALUE*
!* ASSOP =1 FOR'==',=2 FOR '=',=3 FOR '<-' *
!***********************************************************************
%CONSTINTEGER EEMASK=B'11110000000'
%INTEGER I
%IF ASSOP=1 %THEN %START
%CYCLE I=0,1,7
GRUSE(I)=0 %IF EEMASK&1<<GRUSE(I)#0 %AND %C
(GRINF(I)&X'FFFF'=VAR %OR GRINF(I)>>16=VAR)
%REPEAT
%FINISH %ELSE %START
%CYCLE I=0,7,7
GRUSE(I)=0 %IF 9<=GRUSE(I)<=10 %AND %C
(GRINF(I)&X'FFFF'=VAR %OR GRINF(I)>>16=VAR)
%REPEAT
%IF ASSOP=2 %AND VAR>0 %AND(GRUSE(REG)#5 %OR GRINF(REG)<0%C
%OR GRINF(REG)>3) %THEN %START
%IF GRUSE(REG)#9 %THEN GRUSE(REG)=9 %AND GRINF(REG)=0
GRINF(REG)=GRINF(REG)<<16!VAR
%FINISH
%FINISH
%END
%END; ! OF ROUTINE CSS
!*DELSTART
%ROUTINE PRINTUSE
%CONSTSTRING(3)%ARRAY REGS(0:7)='ACC',' DR','LNB','XNB',
' PC','CTB','TOS',' B';
%CONSTSTRING(15)%ARRAY USES(0:15) =' NOT KNOWN ',' I-RESULT ',
' TEMPORARY ',' PLTBASE ',
' NAMEBASE ',' LIT CONST ',
' TAB CONST ',' DESC FOR ',
' RECD BASE ',' LOCAL VAR ',
' NAME+CNST ',' FREE ',
' BYTE DES ',' HALF DES ',
' FREE ',' FREE ';
%CONSTSTRING(11)%ARRAY STATE(-1:3)=%C
' LOCKED ',' FREE ',
' I-RESULT ',' TEMPORARY ',
' RT-PARAM ';
%INTEGER I,USE,INF
%CYCLE I=0,1,7
%IF REGISTER(I)!GRUSE(I)#0 %START
USE=GRUSE(I); INF=GRINF(I)
PRINTSTRING(REGS(I).STATE(REGISTER(I)). %C
' USE = '.USES(USE))
%IF 7<=USE<=10 %THEN PRINTNAME(INF&X'FFFF') %C
%ELSE WRITE(INF,1)
%IF USE=10 %THEN PRINTSYMBOL('+') %AND %C
WRITE(INF>>16,1)
%IF USE=9 %AND INF>>16#0 %THEN PRINT SYMBOL('+') %C
%AND PRINT NAME(INF>>16)
NEWLINE
%FINISH
%REPEAT
%END
!*DELEND
%ROUTINE ABORT
PRINTSTRING('
**************** ABORT******************** ABORT *******')
!*DELSTART
NCODE(ADDR(CODE(0)), ADDR(CODE(PPCURR)), CABUF) %C
%UNLESS CA=CABUF
PRINT USE
!*DELEND
%MONITOR
%STOP
%END
%ROUTINE EPILOGUE
!***********************************************************************
!* PLANT ANY SUBROUINES THAT HAVE BEEN REQUIRED DURING *
!* THE CODE GENERATION PHASE *
!***********************************************************************
%INTEGER D,J
%ROUTINESPEC FILL(%INTEGER LAB)
%IF PLINK(15)=0 %THEN ->P16
FILL(15)
!
! CONTINGENCY ENTRY - LNB RESTORE FOR MAIN PROGRAM. ACC HAS WORD DECP
! TO 18 WORD AREA OF FAILURE & IMAGE STORE:-
! WORD0 = FAILURE?, WORD1=XTRA?,WORD2=LNB,WORD4=PC
! THIS ROUTINE TRANSCRIBES THESE INTO A CALL ON MDIAGS
!
! ST TOS
! PRCL 4 REPLACE THE CONTINGENCY
! LSS -1
! ST TOS
! JLK +2 ROUND NEXT INST
! J -5 BACK TO ENTRY POINT
! STLN TOS
! LDTB WORD DESCRIPTOR FOR REPORT WORD
! LXN (LNB+4) TO PLT
! LDA (XNB+5) BY STORED LNB IN PLT
! INCA 20
! STD TOS
! RALN 10
! CALL ROUTINE SIGNAL
!
! LD TOS DESCRIPTOR TO DR
! PRCL 4 TO PLANT PARAMS
! LSS (DR+4) PC FIRST PARAM
! SLSS (DR+2) LNB SECOND PARAM
! SLSS 10 ERROR NO 10
! SLSS (DR) XTRA IS FAILURE NO
! ST TOS
! LXN (LNB+4) TO PLT(GLA)
! RALN 9
! CALL ((XNB+10)) TO MDIAGS - DOES NOT RETURN
!
PF1(ST,0,TOS,0)
PSF1(PRCL,0,4)
PSF1(LSS,0,-1)
PF1(ST,0,TOS,0)
PSF1(JLK,0,2)
PSF1(JUNC,0,-5)
PF1(STLN,0,TOS,0)
PF1(LDTB,0,PC,PARAM DES(5))
PSF1(LXN,1,16)
PF1(LDA,0,XNB,20)
PSF1(INCA,0,20)
PF1(STD,0,TOS,0)
PSF1(RALN,0,10)
PF1(CALL,2,XNB,SIGREFDIS)
PF1(LD,0,TOS,0)
PSF1(PRCL,0,4)
PF1(LSS,1,0,4)
PF1(SLSS,1,0,2)
PSF1(SLSS,0,10)
PF1(SLSS,2,7,0)
PF1(ST,0,TOS,0)
PSF1(LXN,1,16)
PSF1(RALN,0,9)
PF1(CALL,2,XNB,40)
P16:
!
! STRING RESOLUTION SUBROUTINE
! THIS IS ENTERED VIA A CALL INSTRN AND HAS 3 PARAMETERS
! P1(LNB+5) = RESD A CURRENT LENGTH DESCRIPTOR POINTING AT THE FIRST BYTE
! OF THE STRING BEING RESOLVED
! P2(LNB+7) = STD A MAX LENGTH DESCRIPTOR TO THE STRING IN WHICH ANY
! FRAGMENT IS TO BE STORED
! P3(LNB+9) - EXPD A CURRENT LENGTH DESCRIPTOR POINTING AT THE
! LENGTH BYTE OF STRING TO BE SEARCHED FOR
!
! IF RESOLUTION IS SUCCESSFULL CC IS SET TO 0 AND AN UPDATED VERSION
! OF RESD IS RETURNED IN THE ACC IN CASE THERE ARE FURTHER RESLNS
!
! CODE IS AS FOLLOWS:-
!
! LXN (LNB+0) OLD LNB
! LD (XNB+3) PLT DESCRIPTOR
! LDB 0 ZERO BOUND FOR MDIAG
! STD (LNB+3) STANDARD PLACE
! ASF 4 GRAB 2 TEMPORARIES
! LD (LNB+5) RESULT IF NULL ROUTE TAKEN
! SLD (LNB+9) EXPD
! LB 0
! JAT 11,LNULL JUMP IF EXP NULL
! INCA 1 TO FIRST CHAR
! LB @DR FIRST CHAR INTO B
! STD (LNB+11) TEMP1
! LSS (LNB+5) TYPE&BND OF RESD
! AND XIFF
! JAT 4,RESFAIL RESD IS NULL &EXPD NOT NULL
! LD (LNB+5) RESD TO DR
!AGN SWNE L=DR SEARCH FOR FIRST CHAR
! JCC 8,RESFAIL NOT FOUND
! STD (LNB+13) SAVE IN TEMP 2
! CYD 0
! LD (LNB+11) EXP DESCRIPTOR FOR COMPARISON
! CPS L=DR,FILLER=FF CHECK REST OF EXPRSN
! JCC 8,L2 RESLN HAS SUCCEEDED
! LD (LNB+13) RESUME SCANNING
! SWEQ L=1 ADVANCE BY 1 AVOIDING MODD
! J AGN
!
! RESOLUTION COMPLETE. ARRANGE TO STORE FRAGMENT WITHOUT ANY FILLER CHARS
! SO S->S.(T).Z WORKS OK AND ALLOWING STD TO BE NULL
!
!L2 SLSS (LNB+5) STORE UPDATED DES & GET BND
! ISB (LNB+13) GIVE LENGTH OF FRAGMENT
! ST B
! LSS (LNB+7) LENGTH OF STD
! JAF 4,*+6 ! ZERO FOR NO 1ST PART RESLN
! LSS 1
! AND X1FF
! ICP B
! JCC 12,RESFAIL
!LNULL LD (LNB+7) STD TO DR
! JAT 11,L3 STD NULL DONT SET LENGTH
! LSD (LNB+5) ORIGINIAL STRING
! MVL L=1 SET LENGTH BYTE FROM B
! LDB B TO STORE CHARS
! MV L=DR,FILLER=X'80' ASSIGN
!L3 LD TOS RESULT AND SET CC=0
! CYD 0
! EXIT
!RESFAIL MPSR X'24' SET CC=1
! EXIT
%IF PLINK(16)=0 %THEN ->P17
FILL(16)
PSF1(LXN,1,0)
PF1(LD,0,XNB,12)
PSF1(LDB,0,0)
PSF1(STD,1,12)
PSF1(ASF,0,4)
PSF1(LD,1,20)
PSF1(SLD,1,36)
PSF1(LB,0,0)
PF3(JAT,11,0,X'24')
PSF1(INCA,0,1)
PF1(LB,2,7,0)
PSF1(STD,1,44)
PSF1(LSS,1,20)
PF1(AND,0,0,X'1FF')
PF3(JAT,4,0,X'27')
PSF1(LD,1,23)
PF2(SWNE,1,0,0,0,0)
PF3(JCC,8,0,X'23')
PSF1(STD,1,52)
PSF1(CYD,0,0)
PSF1(LD,1,44)
PF2(CPS,1,1,0,0,X'FF')
PF3(JCC,8,0,5)
PSF1(LD,1,52)
PF2(SWEQ,0,0,0,0,0)
PSF1(JUNC,0,-12)
PSF1(SLSS,1,20)
PSF1(ISB,1,52)
PF1(ST,0,BREG,0)
PSF1(LSS,1,28)
PF3(JAF,4,0,3)
PSF1(LSS,0,1)
PF1(AND,0,0,X'1FF')
PF1(ICP,0,BREG,0)
PF3(JCC,12,0,13)
PSF1(LD,1,28)
PF3(JAT,11,0,7)
PSF1(LSD,1,20)
PF2(MVL,0,0,0,0,0)
PF1(LDB,0,BREG,0)
PF2(MV,1,1,0,0,UNASSPAT&255)
PF1(LD,0,TOS,0)
PSF1(CYD,0,0)
PSF1(EXIT,0,-X'40')
PSF1(MPSR,0,X'24')
PSF1(EXIT,0,-X'40')
P17:
!
! EVALUATE X**Y
! ******** ****
! Y IS IN ACC X IS STACKED BELOW THE LINK(UNAVOIDABLE)
! FAULT(21) IS GIVEN IF X<0 OR (X=0 AND Y<=0)
! REPEATED MULTIPLICATION IS USED IF Y>0 AND FRACPT(Y)=0
! OTHERWISE RESULT=EXP(Y*LOG(Y))
!
! LB TOS SWOP RETURN ADDRESS & X
! LD TOS X TO DR
! STB TOS
! STD TOS
! SLSD TOS X TO ACC Y TO TOS
! JAT 2,EXPERR ERROR IF X<0
! JAF 0,TRYMULT JUMP X#0
! SLSD TOS STACK X & GET Y
! JAF 1.EXPERR Y<=0
! LSD TOS X (=0) =RESULT TO ACC
! J TOS RETURN
!TRYMULT X IS IN ACC & Y STACKED
! SLSD TOS Y TO ACC AND X STACKED
! ST TOS Y STACKED
! JAT 2,NONINT Y IS NEGATAIVE
! RSC 55
! RSC -55
! FIX B FIX PINCHED FROM ICL ALGOL
! MYB 4
! CPB -64
! JCC 10,*+3
! LB -64
! ISH B
! STUH B ACC TO 1 WORD
! JCC 7,NONINT JUMP IF TRUNCATION
! ASF -2 LOSE Y OF STACK
! ST B INTEGER VERSION OF Y TO B
! LSS 1
! FLT 0
! JAF 12,MUL JUMP IF B#0
! ASF -2 LOSE X OFF STACK
! J TOS X**0 =1
!AGN STD TOS STACK ANOTHER COPY OF X
!MUL RMY TOS
! DEBJ AGN REPEATED MULTIPLICATION
! J TOS
!NONINT Y IS STACKED OVER X
! LSD TOS
! SLSD TOS
! PRCL 4
! ST TOS
! LXN (LNB+4)
! RALN 7
! CALL ((XNB+LOGEPDISP)
! RMY TOS
! PRCL 4
! ST TOS
! LXN (LNB+4) TO PLT
! RALN 7
! CALL ((XNB+EXPEPDISP)) CALL EXP
! J TOS
!EXPERR J ERROR RT NO 7
!
%IF PLINK(17)=0 %THEN ->P18
FILL(17)
%IF LOGEPDISP=0 %THEN CXREF('S#ILOG',0,2,LOGEPDISP)
%IF EXPEPDISP=0 %THEN CXREF('S#IEXP',0,2,EXPEPDISP)
PF1(LB,0,TOS,0)
PF1(LD,0,TOS,0)
PF1(STB,0,TOS,0)
PF1(STD,0,TOS,0)
PF1(SLSD,0,TOS,0)
PF3(JAT,2,0,X'35')
PF3(JAF,0,0,7)
PF1(SLSD,0,TOS,0)
PF3(JAF,1,0,X'30')
PF1(LSD,0,TOS,0)
PF1(JUNC,0,TOS,0)
PF1(SLSD,0,TOS,0)
PF1(ST,0,TOS,0)
PF3(JAT,2,0,26)
PSF1(RSC,0,55)
PSF1(RSC,0,-55)
PF1(FIX,0,BREG,0)
PSF1(MYB,0,4)
PSF1(CPB,0,-64)
PF3(JCC,10,0,3)
PSF1(LB,0,-64)
PF1(ISH,0,BREG,0)
PF1(STUH,0,BREG,0)
PF3(JCC,7,0,14)
PSF1(ASF,0,-2)
PF1(ST,0,BREG,0)
PSF1(LSS,0,1)
PSF1(FLT,0,0)
PF3(JAF,12,0,5)
PSF1(ASF,0,-2)
PF1(JUNC,0,TOS,0)
PF1(STD,0,TOS,0)
PF1(RMY,0,TOS,0)
PSF1(DEBJ,0,-2)
PF1(JUNC,0,TOS,0)
PF1(LSD,0,TOS,0)
PF1(SLSD,0,TOS,0)
PSF1(PRCL,0,4)
PF1(ST,0,TOS,0)
PSF1(LXN,1,16)
PSF1(RALN,0,7)
PF1(CALL,2,XNB,LOGEPDISP)
PF1(RMY,0,TOS,0)
PSF1(PRCL,0,4)
PF1(ST,0,TOS,0)
PSF1(LXN,1,16)
PSF1(RALN,0,7)
PF1(CALL,2,XNB,EXPEPDISP)
PF1(JUNC,0,TOS,0)
PF1(JUNC,0,0,(PLABS(7)-CA)//2)
P18:
!
! MAPPED STRING ASSIGNMENT CHECK. CHECKING MODE ONLY. MUST MOVE ONLY
! CURRENT LENGTH INTO MAPPED STRINGS BUT MUST NOT OMIT THE CAPACITY
! CHECK. ACC & DR SET FOR MV
!
! ST TOS SAVE ACC DESRPTR
! AND X'FF00000000' GET CURRENT LENGTH
! STUH B INTO BREG
! LSD TOS RESTORE ACC
! STD TOS SAVE DR DESCRPTR
! SBB 1
! JAF 13,*+3
! MODD B PROVOKE FAILURE IF RELEVANT
! ADB 1
! LD TOS
! LDB B BOUND=CURRENT L +1(FOR LBYTE)
! J TOS
!
%IF PLINK(18)=0 %THEN ->P19
CNOP(0,8)
D=CA
PCONST(255)
PCONST(0); ! XFF00000000
FILL(18)
PF1(ST,0,TOS,0)
PF1(AND,0,PC,D)
PF1(STUH,0,BREG,0)
PF1(LSD,0,TOS,0)
PF1(STD,0,TOS,0)
PSF1(SBB,0,1)
PF3(JAF,13,0,3)
PF1(MODD,0,BREG,0)
PSF1(ADB,0,1)
PF1(LD,0,TOS,0)
PF1(LDB,0,BREG,0)
PF1(JUNC,0,TOS,0)
P19:
! CONCATENATION ONE
! COPY THE FIRST STRING INTO THE WORK AREA
! B HAS REL DISP OF THE WORK AREA FROM LNB
! DR HAS CURRENT LENGTH DESCRIPTOR OF FIRST STRING
! RESULT IS A CURRENT LENGTH DESCRIPTOR TO WORK AREA IN DR AND ACC
!
! STLN TOS
! ADB TOS
! LXN B XNB TO WORK AREA
! SLB @DR CURRENT LENGTH TO B
! STB (%XNB+2) INTO LENGTH BYTE OF WK AREA
! INCA 1 DR PAST LENGTH BYTE
! CYD 0 BECOMES SOURCE STRING
! LD =X'180000FF0000000C'
! INCA TOS DESCRIPTOR TO WK STRING
! STD (%XNB+0) STORED FOR LATER
! LDB B ADJUSTED SO NO FILLING
! MV L=DR THE MOVE
! LD (%XNB+0) SET UP DR WITH RESULT
! LDB B CURRENT LENGTH AS BOUND
! INCA -1 TO POINT AT LENGTH BYTE
! CYD 0 TO ACC AS WELL
! J TOS RETURN
%IF PLINK(19)!PLINK(20)=0 %THEN ->P21
CNOP(0,8); ! DOUBLE WORD ALLIGN
D=CA
PCONST(X'180000FF'); PCONST(12)
FILL(19)
PF1(STLN,0,TOS,0)
PF1(ADB,0,TOS,0)
PF1(LXN,0,BREG,0)
PF1(SLB,2,7,0)
PF1(STB,0,XNB,8)
PSF1(INCA,0,1)
PSF1(CYD,0,0)
PF1(LD,0,PC,D)
PF1(INCA,0,TOS,0)
PF1(STD,0,XNB,0)
PF1(LDB,0,BREG,0)
PF2(MV,1,0,0,0,0)
PF1(LD,0,XNB,0)
PF1(LDB,0,BREG,0)
PSF1(INCA,0,-1)
PSF1(CYD,0,0)
PF1(JUNC,0,TOS,0)
!
! CONCATENATION TWO
! ADD THE SECOND AND SUBSEQUENT STRINGS TO THE FIRST
! PARAMETERS AND RESULTS AS CONCATENATION ONE
!
! STLN TOS
! ADB TOS
! LXN B XNB TO WORK AREA
! LB @DR CURRENT LENGTH TO B
! STB TOS KEEP FOR THE MOVE
! ADB (%XNB+2) ADD OLD LENGTH
! INCA 1 PAST LENGTH BYTE
! CYD 0 BECOMES SOURCE STRING
! LD (%XNB+0) GET DESCRIPTOR TO WK STRING
! MODD (%XNB+2) MOVE ON PAST FIRST STRING
! LDB TOS TO MOVE RIGHT AMOUNT
! MV L=DR
! STB (%XNB+2) UP DATE WK STRING LENGTH
! CPB 255
! JCC 2,CAPACITY EXCEEDED
! LD (%XNB+0) SET UP DR WITH RESULT
! LDB B CURRENT LENGTH AS BOUND
! INCA -1 TO POINT AT LENGTH BYTE
! CYD 0 TO ACC AS WELL
! J TOS RETURN
%IF PLINK(20)=0 %THEN ->P21
FILL(20)
PF1(STLN,0,TOS,0)
PF1(ADB,0,TOS,0)
PF1(LXN,0,BREG,0)
PF1(LB,2,7,0)
PF1(STB,0,TOS,0)
PF1(ADB,0,XNB,8)
PSF1(INCA,0,1)
PSF1(CYD,0,0)
PF1(LD,0,XNB,0)
PF1(MODD,0,XNB,8)
PF1(LDB,0,TOS,0)
PF2(MV,1,0,0,0,0)
PF1(STB,0,XNB,8)
PF1(CPB,0,0,255)
PF3(JCC,2,0,(PLABS(9)-CA)//2)
PF1(LD,0,XNB,0)
PF1(LDB,0,BREG,0)
PSF1(INCA,0,-1)
PSF1(CYD,0,0)
PF1(JUNC,0,TOS,0)
P21:
!
! THE STOP SEQUENCE
! CALL %SYSTEMROUTINE STOP(NO PARAMETERS)
!
!STOP1 PRCL 4
! LXN (LNB+4)
! RALN 5
! CALL ((XNB+STOPEPDISP)) ! **PLEASE DONT COME BACK**
!
%IF PLINK(21)=0 %THEN ->P22
FILL(21)
CXREF('S#STOP',0,2,J)
PSF1(PRCL,0,4)
PSF1(LXN,1,16)
PSF1(RALN,0,5)
PF1(CALL,2,XNB,J)
PF1(X'4E',0,0,X'B00B'); ! IDLE B00B
P22:
%RETURN
%ROUTINE FILL(%INTEGER LAB)
!***********************************************************************
!* FILL JUMPS TO THIS LAB WITH JUMP TO CURRENT ADDRESS *
!***********************************************************************
%INTEGER AT,INSTRN,SPARE
%WHILE PLINK(LAB)#0 %CYCLE
POP(PLINK(LAB),AT,INSTRN,SPARE)
INSTRN=INSTRN!(CA-AT)>>1
PLUG(1,AT,INSTRN,4)
%REPEAT
PLABS(LAB)=CA
%END
%END
%ROUTINE DUMP CONSTS
!***********************************************************************
!* OUTPUT THE CONSTANT TABLE AND MAKE ANY RELEVANT RELOCATIONS *
!***********************************************************************
%ROUTINESPEC DOIT(%INTEGER VAL)
%INTEGER I,J,K,DISP
LPUT(1,CONSTPTR*4,CA,ADDR(CTABLE(0))) %IF CONSTPTR#0
!*DELSTART
%IF DCOMP#0 %START
PRINTSTRING("
CONSTANT TABLE")
I=0
%CYCLE
NEWLINE
PRHEX(CA+4*I,5)
%CYCLE J=0,1,7
SPACES(2)
PRHEX(CTABLE(I+J),8)
%REPEAT
SPACE
%CYCLE J=0,1,31
K=BYTEINTEGER(ADDR(CTABLE(I))+J)
%IF K<31 %OR K>95 %THEN K=32
PRINT SYMBOL(K)
%REPEAT
I=I+8
%EXIT %IF I>=CONSTPTR
%REPEAT
%FINISH
!*DELEND
!
DISP=CA//2; ! RELOCATION FACTOR
%WHILE CREFHEAD#0 %CYCLE
POP(CREFHEAD,I,J,K)
DOIT(I)
%IF J#0 %THEN DOIT(J)
%IF K#0 %THEN DOIT(K)
%REPEAT
CA=CA+4*((CONSTPTR+1)&(-2))
%RETURN
%ROUTINE DOIT(%INTEGER VAL)
!***********************************************************************
!* IF VAL +VE THEN VAL IS CODE ADDRESS FOR LPUT(18) UPDATE *
!* IF VAL -VE IT IS GLAWRDADDRR<<16!CTABLE WRD ADDR *
!* THE GLA WORD IS TO RELOCATED BY HEAD OF CODE(ALREADY DONE) *
!* HOWEVER THE GLAWORD NEEDS UPDATING FROM REL CTABLE TO REL CODE *
!***********************************************************************
%INTEGER I,J
%IF VAL>0 %THEN LPUT(18,0,VAL,DISP) %ELSE %START
I=(VAL>>16&X'7FFF')<<2; ! GLA BYTE ADDRESS
J=4*(VAL&X'FFFF')+CA; ! CTABLE ENTRY REL HD OF CODE
PLUG(2,I,J,4); ! UPDATE THE GLA WORD
%FINISH
%END
%END
%END; ! OF SUBBLOCK CONTAINING PASS2
%ROUTINE MESSAGE(%INTEGER N)
!***********************************************************************
!* OUTPUTS AN ERROR MESSAGE STORED IN A COMPRESSED FORMAT *
!***********************************************************************
%CONSTBYTEINTEGERARRAY WORD(0: 330)=0,%C
1, 1, 2, 3, 0, 2, 4, 5,
7, 8, 4, 9, 10, 11, 7, 5,
9, 4, 12, 0, 6, 9, 4, 7,
8, 7, 10, 7, 8, 0, 8, 13,
14, 11, 16, 9, 13, 14, 11, 16,
10, 13, 14, 11, 16, 11, 4, 11,
7, 0, 13, 1, 18, 0, 0, 14,
2, 3, 20, 0, 15, 18, 20, 0,
0, 16, 10, 11, 7, 0, 17, 11,
21, 10, 0, 18, 9, 23, 12, 0,
19, 24, 25, 26, 14, 20, 9, 10,
27, 28, 22, 30, 14, 11, 16, 23,
21, 10, 27, 28, 24, 31, 27, 32,
28, 25, 34, 35, 11, 32, 26, 37,
38, 24, 39, 28, 21, 40, 18, 0,
29, 41, 11, 42, 0, 30, 44, 45,
26, 46, 31, 48, 45, 26, 46, 34,
2, 3, 49, 0, 35, 2, 3, 21,
49, 36, 50, 37, 25, 0, 39, 31,
52, 0, 0, 40, 23, 53, 0, 0,
42, 55, 35, 27, 28, 43, 56, 57,
45, 0, 44, 50, 58, 0, 0, 45,
24, 25, 26, 58, 47, 50, 59, 0,
0, 48, 60, 61, 27, 38, 51, 62,
2, 3, 0, 52, 1, 18, 63, 62,
53, 62, 18, 0, 0, 54, 64, 45,
26, 46, 57, 65, 18, 0, 0, 62,
11, 66, 10, 0, 64, 67, 18, 0,
0, 65, 67, 11, 27, 66, 66, 50,
69, 70, 0, 67, 11, 69, 10, 0,
69, 67, 45, 26, 46, 70, 50, 55,
23, 0, 71, 35, 27, 55, 28, 72,
50, 55, 72, 0, 73, 74, 45, 26,
46, 74, 74, 24, 66, 0, 81, 50,
76, 0, 0, 82, 41, 11, 78, 10,
83, 80, 76, 0, 0, 84, 50, 69,
70, 0, 85, 81, 0, 0, 0, 98,
84, 0, 0, 0, 99, 84, 0, 0,
0, 103, 87, 2, 88, 0, 104, 2,
3, 87, 0, 106, 55, 58, 2, 88,
108, 89, 61, 27, 38, 127, 90, 0,
0, 0
%CONSTINTEGERARRAY LETT(0: 92)=0,%C
X'48B02868',X'51EF0000',X'342EC800',X'30222B00',
X'25D60B13',X'13EF9000',X'4CB40000',X'52E91940',
X'4EE9A0D0',X'382D2800',X'39F40000',X'16527C80',
X'19F26858',X'40320B4B',X'50B29800',X'067F9C0B',
X'0C000000',X'35339A5D',X'1C000000',X'15C49800',
X'49F5A25D',X'14000000',X'10A36380',X'5E4F71C0',
X'39E00000',X'3CC00000',X'25C00000',X'171094E7',
X'38000000',X'0474A858',X'48A16000',X'25D429CB',
X'48000000',X'0F236140',X'58324845',X'30A00000',
X'18356500',X'4E8D7500',X'30B62B00',X'09E4C800',
X'31130000',X'10B3A3A9',X'38000000',X'48B4AC9C',
X'3EB40000',X'0DEEA171',X'50000000',X'48B3AB28',
X'30B62B26',X'258C29C3',X'30000000',X'17107500',
X'35338303',X'0CA40000',X'4E924B8E',X'06520E40',
X'25D3490A',X'0DEE9D00',X'15932800',X'4EA20000',
X'0D019000',X'192E4CD0',X'06800000',X'1709A000',
X'08A74B80',X'19F26868',X'4EA2705B',X'14000000',
X'48A37C88',X'3E059069',X'38000000',X'3E059069',
X'3E400000',X'48B37B2B',X'512F7000',X'16354D83',
X'30AE1940',X'41E9750B',X'48000000',X'39EE0000',
X'112D2BA7',X'25EE0B13',X'53200000',X'04849167',
X'4C224B13',X'53200000',X'382D2CC0',X'31EE3800',
X'15A00000',X'4CA5FA5B',X'43ED0BAB',X'05800000'
%INTEGER I,J,K,M,Q,S
PRINTSTRING(' (')
I=-4
%UNTIL N=WORD(I) %OR I= 326 %THEN I=I+5
%CYCLE J=1,1,4
K=WORD(I+J)
%IF K=0 %THEN %EXIT
SPACE %UNLESS J=1
%UNTIL M&1=0 %CYCLE
M=LETT(K); S=26
%UNTIL S<0 %CYCLE
Q=M>>S&31;
%IF Q=31 %THEN Q=-32
%IF Q\=0 %THEN PRINT SYMBOL(Q+64)
S=S-5
%REPEAT
K=K+1
%REPEAT
%REPEAT
PRINTSTRING(') ')
%END
%ROUTINE FAULT(%INTEGER N, FNAME)
%INTEGER I, J, QP
!*DELSTART
%MONITOR %IF SMAP#0 %OR PRINTMAP#0
!*DELEND
QP=Q
%IF N=100 %THEN %START
PRINTSTRING('
* FAILED TO ANALYSE LINE ')
WRITE(LINE, 2)
NEWLINE; SPACES(5)
FAULTY=FAULTY+1
%IF LINE#OLDLINE %THEN PRINTSTRING(%C
"TEXT MODE FAILURE-- ERRONEOUS SOURCE LINE NOT AVAILABLE
") %AND %RETURN
T=0; J=0; S=0
%UNTIL (J=';' %AND Q>QMAX) %OR Q=LENGTH %CYCLE
I=J; J=BYTEINTEGER(FNAME+Q);! FNAME HAS ADDR(CC(0))
%IF J>128 %AND I<128 %THEN PRINTSTRING(' %') %AND T=T+2
%IF I>128 %AND J<128 %THEN SPACE %AND T=T+1
PRINT SYMBOL(J)
T=T+1
%IF Q=QMAX %THEN S=T
Q=Q+1
%REPEAT
%IF Q=QMAX %THEN S=T
!
%IF S<115 %THEN %START
NEWLINE; SPACES(S+4)
PRINT SYMBOL('!')
%FINISH
NEWLINE
%FINISH %ELSE %START
PRINTSTRING('
*'); WRITE(LINE, 4)
I=3; I=3*LEVEL %IF LIST=0; SPACES(I)
PARMOPT=1; FAULTY=FAULTY+1
INHCODE=1; ! STOP GENERATING CODE
PRINTSTRING('FAULT'); WRITE(N, 2)
MESSAGE(N)
%IF N>100 %THEN %START
PRINTSTRING(' DISASTER ')
%MONITOR; %STOP
%FINISH
%IF N=45 %THEN WRITE(FNAME,1) %ELSE %START
PRINTNAME(FNAME) %UNLESS FNAME=0
%FINISH
%FINISH
%IF TTOPUT#0 %THEN %START
Q=QP; TTOPUT=0
SELECT OUTPUT(87)
FAULT(N, FNAME)
FAULTY=FAULTY-1
NEWLINE
SELECT OUTPUT(82)
TTOPUT=1
%FINISH
%IF N>100 %THEN %MONITOR %AND %STOP
%END
%ROUTINE WARN(%INTEGER N,V)
%CONSTSTRING(23)%ARRAY MESS(1:5)=' SHORT INTEGER USED',
' NAME ? NOT USED ',
' LABEL ? NOT USED',
' GLOBAL CYCLE CONTROL ?',
' NAME ? NOT ADDRESSABLE'
%STRING(30) T; %STRING(120) S
%IF MESS(N)->S.("?").T %THEN S=S.STRING(DICTBASE+WORD(V)) %C
.T %ELSE S=MESS(N)
PRINTSTRING('
? WARNING :- '.S.' AT LINE NO')
WRITE(LINE,1)
NEWLINE
%END
! THE NEXT 4 ROUTINES CAN BE
!MACROISED USING MVC
!
%ROUTINE TOAR2(%INTEGER PTR,VALUE)
!QOUT; A(PTR+1)<-VALUE
!QOUT; A(PTR)<-VALUE>>8
!QIN *LSS_VALUE
!QIN *LDTB_X'58000002'
!QIN *LDA_A+4
!QIN *INCA_PTR
!QIN *ST_(%DR)
%END
%ROUTINE TOAR4(%INTEGER PTR, VALUE)
!QOUT;%INTEGER I
!QOUT; %CYCLE I=0,1,3
!QOUT; A(PTR+I)=BYTE INTEGER(ADDR(VALUE)+I)
!QOUT; %REPEAT
!QIN *LSS_VALUE
!QIN *LDTB_X'58000004'
!QIN *LDA_A+4
!QIN *INCA_PTR
!QIN *ST_(%DR)
%END
%ROUTINE TOAR8(%INTEGER PTR, %LONGREAL VALUE)
!QOUT;%INTEGER I
!QOUT; %CYCLE I=0,1,7
!QOUT; A(PTR+I)=BYTE INTEGER(ADDR(VALUE)+I)
!QOUT; %REPEAT
!QIN *LSD_VALUE
!QIN *LDTB_X'58000008'
!QIN *LDA_A+4
!QIN *INCA_PTR
!QIN *ST_(%DR)
%END
%INTEGERFN FROMAR2(%INTEGER PTR)
!QOUT; %RESULT=A(PTR)<<8!A(PTR+1)
!QIN *LDTB_X'58000002'
!QIN *LDA_A+4
!QIN *INCA_PTR
!QIN *LSS_(%DR)
!QIN *EXIT_-64
%END
%INTEGERFN FROMAR4(%INTEGER PTR)
!QOUT; %RESULT=A(PTR)<<24!A(PTR+1)<<16!A(PTR+2)<<8!A(PTR+3)
!QIN *LDTB_X'58000004'
!QIN *LDA_A+4
!QIN *INCA_PTR
!QIN *LSS_(%DR)
!QIN *EXIT_-64
%END
%LONGREALFN FROMAR8(%INTEGER PTR)
!QOUT;%LONGREAL AD
!QOUT;%INTEGER I
!QOUT; %CYCLE I=0,1,7
!QOUT; BYTE INTEGER(ADDR(AD)+I)=A(PTR+I)
!QOUT; %REPEAT
!QOUT; %RESULT=AD
!QIN *LDTB_X'58000008'
!QIN *LDA_A+4
!QIN *INCA_PTR
!QIN *LSD_(%DR)
!QIN *EXIT_-64
%END
%ROUTINE PRINTNAME(%INTEGER N)
%INTEGER V, K
SPACE; V=WORD(N)
K=BYTE INTEGER(DICTBASE+V)
%IF K=0 %THEN PRINTSTRING('???') %ELSE %C
PRINTSTRING(STRING(DICTBASE+V))
%END
!*DELSTART
%ROUTINE PRHEX(%INTEGER VALUE, PLACES)
%CONSTBYTEINTEGERARRAY HEX(0:15)='0','1','2','3','4',
'5','6','7','8','9','A','B','C','D','E','F'
%INTEGER I
%CYCLE I=PLACES<<2-4, -4, 0
PRINT SYMBOL(HEX(VALUE>>I&15))
%REPEAT
%END
%ROUTINE PRINT LIST(%INTEGER HEAD)
%INTEGER I,J,K
%WHILE HEAD#0 %CYCLE
FROM123(HEAD,I,J,K)
NEWLINE
WRITE(HEAD,3)
SPACES(3)
PRHEX(I,8)
SPACES(3)
PRHEX(J,8)
SPACES(3)
PRHEX(K,8)
NEWLINE
MLINK(HEAD)
%REPEAT
%END
!
%ROUTINE CHECK ASL
!***********************************************************************
!* CHECK ASL AND PRINT NO OF FREE CELLS. DEBUGGING SERVICE ONLY *
!***********************************************************************
%INTEGER N,Q
Q=ASL; N=0
%WHILE Q#0 %CYCLE
N=N+1
Q=ASLIST(Q)_LINK
%REPEAT
NEWLINE
PRINTSTRING('FREE CELLS AFTER LINE ')
WRITE(LINE,3)
PRINTSYMBOL('=')
WRITE(N,3)
%END
!*DELEND
%INTEGERFN MORE SPACE
!***********************************************************************
!* FORMATS UP SOME MORE OF THE ASL *
!***********************************************************************
%INTEGER I,N
N=ASL CUR BTM-1
ASL CUR BTM=ASL CUR BTM-(NNAMES+1)//8
%IF ASL CUR BTM<=1 %THEN ASL CUR BTM=1
CONST LIMIT=4*ASL CUR BTM-8
%IF ASL CUR BTM>=N %OR CONST PTR>CONST LIMIT %THEN FAULT(107,0)
%CYCLE I=ASL CUR BTM,1,N-1
ASLIST(I+1)_LINK=I
%REPEAT
ASLIST(ASL CUR BTM)_LINK=0
ASL=N; %RESULT=N
%END
%INTEGERFN NEW CELL
!***********************************************************************
!* PROVIDE A NEW LIST PROCESSING CELL. CRAPOUT IF NONE AVAILABLE *
!***********************************************************************
%INTEGER I
%IF ASL=0 %THEN ASL=MORE SPACE
I=ASL; ASL=ASLIST(ASL)_LINK
ASLIST(I)_LINK=0
%RESULT =I
%END
%ROUTINE PUSH(%INTEGERNAME CELL, %INTEGER S1, S2, S3)
!***********************************************************************
!* PUSH A CELL CONTAINING THE 3 STREAMS OF INFORMATION GIVEN *
!* ONTO THE TOP OF THE LIST POINTED AT BY CELL. *
!***********************************************************************
%RECORDNAME LCELL(LISTF)
%INTEGER I
I=ASL
%IF I=0 %THEN I=MORE SPACE
LCELL==ASLIST(I)
ASL=LCELL_LINK
LCELL_LINK=CELL; CELL=I
LCELL_S1=S1
LCELL_S2=S2
LCELL_S3=S3
%END
%ROUTINE POP(%INTEGERNAME CELL, S1, S2, S3)
!***********************************************************************
!* COPY THE INFORMATION FROM THE TOP CELL OF LIST 'CELL' INTO *
!* S1,S2&S3 AND THEN POP THE LIST UP 1 CELL. EMPTYLIST GIVE -1S*
!***********************************************************************
%RECORDNAME LCELL(LISTF)
%INTEGER I
I=CELL; LCELL==ASLIST(I)
S1=LCELL_S1
S2=LCELL_S2
S3=LCELL_S3
%IF I# 0 %THEN %START
CELL=LCELL_LINK
LCELL_LINK=ASL
ASL=I
%FINISH
%END
%ROUTINE REPLACE1(%INTEGER CELL, S1)
ASLIST(CELL)_S1=S1
%END
%ROUTINE REPLACE2(%INTEGER CELL, S2)
ASLIST(CELL)_S2=S2
%END
%ROUTINE REPLACE3(%INTEGER CELL, S3)
ASLIST(CELL)_S3=S3
%END
%ROUTINE BINSERT(%INTEGERNAME TOP,BOT,%INTEGER S1,S2,S3)
!***********************************************************************
!* INSERT A CELL AT THE BOTTOM OF A LIST *
!* UPDATING TOP AND BOTTOM POINTERS APPROPIATELY *
!***********************************************************************
%INTEGER I
%RECORDNAME LCELL(LISTF)
I=ASL
%IF I=0 %THEN I=MORE SPACE
LCELL==ASLIST(I)
ASL=LCELL_LINK
LCELL_S1=S1; LCELL_S2=S2
LCELL_S3=S3; LCELL_LINK=0
J=BOT
%IF J=0 %THEN BOT=I %AND TOP=BOT %ELSE %START
ASLIST(J)_LINK=I
BOT=I
%FINISH
%END
%ROUTINE INSERT AT END(%INTEGERNAME CELL, %INTEGER S1, S2, S3)
!***********************************************************************
!* ADD A CELL TO THE BOTTOM OF THE LIST HEADED BY 'CELL' *
!***********************************************************************
%INTEGER I,J,N
%RECORDNAME LCELL(LISTF)
I=CELL; J=I
%WHILE I#0 %THEN J=I %AND I=ASLIST(J)_LINK
N=ASL
%IF N=0 %THEN N=MORE SPACE
LCELL==ASLIST(N)
ASL=LCELL_LINK
%IF J=0 %THEN CELL=N %ELSE ASLIST(J)_LINK=N
LCELL_S1=S1
LCELL_S2=S2
LCELL_S3=S3
LCELL_LINK=0
%END
%ROUTINE REPLACE123(%INTEGER CELL,S1,S2,S3)
ASLIST(CELL)_S1=S1
ASLIST(CELL)_S2=S2
ASLIST(CELL)_S3=S3
%END
%ROUTINE MLINK(%INTEGERNAME CELL)
CELL=ASLIST(CELL)_LINK
%END
%INTEGERFN FIND(%INTEGER LAB, LIST)
!***********************************************************************
!* THIS FUNCTION SEARCHES LIST 'LIST' FOR LAB IN STREAM2 AND *
!* RETURNS THE CORRESPONDING CELL NO.IT USED FOR MORE THAN *
!* SCANNING LABEL LISTS. *
!***********************************************************************
%WHILE LIST#0 %CYCLE
%RESULT=LIST %IF LAB=ASLIST(LIST)_S2
LIST=ASLIST(LIST)_LINK
%REPEAT
%RESULT=-1
%END
%INTEGERFN FIND3(%INTEGER S3, LIST)
!***********************************************************************
!* SEARCHES LIST FOR S3 IN STREAM 3 *
!* RETURNS CELL NO AS RESULT *
!***********************************************************************
%WHILE LIST#0 %CYCLE
%RESULT=LIST %IF S3=ASLIST(LIST)_S3
LIST=ASLIST(LIST)_LINK
%REPEAT
%RESULT=-1
%END
%ROUTINE FROM123(%INTEGER CELL, %INTEGERNAME S1, S2, S3)
!***********************************************************************
!* ALL THE FROMS RETURN INFO FROM CELLS OF A LIST WITHOUT *
!* AFFECTING THE LIST IN ANY WAY. *
!***********************************************************************
LCELL==ASLIST(CELL)
S1=LCELL_S1
S2=LCELL_S2
S3=LCELL_S3
%END
%ROUTINE FROM12(%INTEGER CELL, %INTEGERNAME S1, S2)
LCELL==ASLIST(CELL)
S1=LCELL_S1
S2=LCELL_S2
%END
%INTEGERFN FROM1(%INTEGER CELL)
%RESULT =ASLIST(CELL)_S1
%END
%INTEGERFN FROM2(%INTEGER CELL)
%RESULT =ASLIST(CELL)_S2
%END
%INTEGERFN FROM3(%INTEGER CELL)
%RESULT =ASLIST(CELL)_S3
%END
%ROUTINE CLEAR LIST(%INTEGERNAME OPHEAD)
!***********************************************************************
!* THROW AWAY A COMPLETE LIST (MAY BE NULL!) *
!***********************************************************************
%INTEGER I, J
I=OPHEAD; J=I
%WHILE I#0 %THEN J=I %AND I=ASLIST(J)_LINK
%IF J#0 %START
ASLIST(J)_LINK=ASL
ASL=OPHEAD; OPHEAD=0
%FINISH
%END
!%ROUTINE CONCAT(%INTEGERNAME LIST1, LIST2)
!!***********************************************************************
!!* ADDS LIST2 TO BOTTOM OF LIST1 *
!!***********************************************************************
!%INTEGER I,J
! I=LIST1
! J=I
! %WHILE I#0 %THEN J=I %AND I=ASLIST(J)_LINK
! %IF J=0 %THEN LIST1=LIST2 %ELSE ASLIST(J)_LINK=LIST2
! LIST2=0
!%END; ! AN ERROR PUTS CELL TWICE ONTO
! FREE LIST - CATASTROPHIC!
%ENDOFPROGRAM