MAINEP ICL9CEZIMP80
TRUSTEDPROGRAM
BEGIN
CONSTINTEGER RELEASE=1
CONSTINTEGER YES=1,NO=0
CONSTINTEGER USE IMP=NO
CONSTINTEGER VMEB=NO
CONSTSTRING (10) LADATE="03 Apr 84"; ! LAST ALTERED
INTEGER I, J, K
! PRODUCED BY OLDPS FROM IMP80PS05 ON 02/03/84
CONSTBYTEINTEGERARRAY CLETT(0: 440)= 1,
43, 1, 45, 1, 40, 1, 41, 1, 42, 1, 44, 2, 201, 198,
6, 213, 206, 204, 197, 211, 211, 5, 215, 200, 201, 204, 197, 5,
213, 206, 212, 201, 204, 3, 198, 207, 210, 1, 61, 5, 193, 204,
201, 193, 211, 7, 201, 206, 212, 197, 199, 197, 210, 4, 210, 197,
193, 204, 4, 204, 207, 206, 199, 4, 194, 217, 212, 197, 6, 211,
212, 210, 201, 206, 199, 4, 200, 193, 204, 198, 5, 211, 200, 207,
210, 212, 6, 210, 197, 195, 207, 210, 196, 7, 210, 207, 213, 212,
201, 206, 197, 2, 198, 206, 3, 205, 193, 208, 8, 198, 213, 206,
195, 212, 201, 207, 206, 4, 206, 193, 205, 197, 5, 193, 210, 210,
193, 217, 9, 207, 198, 208, 210, 207, 199, 210, 193, 205, 6, 207,
198, 198, 201, 204, 197, 6, 207, 198, 204, 201, 211, 212, 6, 198,
207, 210, 205, 193, 212, 3, 206, 207, 212, 3, 193, 206, 196, 2,
207, 210, 1, 58, 4, 211, 208, 197, 195, 3, 207, 215, 206, 8,
197, 216, 212, 197, 210, 206, 193, 204, 9, 197, 216, 212, 210, 201,
206, 211, 201, 195, 8, 195, 207, 206, 211, 212, 193, 206, 212, 5,
195, 207, 206, 211, 212, 5, 197, 214, 197, 206, 212, 5, 211, 212,
193, 210, 212, 4, 212, 200, 197, 206, 4, 197, 204, 211, 197, 1,
95, 6, 211, 217, 211, 212, 197, 205, 7, 196, 217, 206, 193, 205,
201, 195, 4, 80, 85, 84, 95, 5, 67, 78, 79, 80, 95, 2,
204, 61, 1, 60, 1, 62, 4, 40, 196, 210, 43, 2, 196, 210,
1, 194, 3, 212, 207, 211, 3, 204, 206, 194, 3, 216, 206, 194,
2, 208, 195, 3, 195, 212, 194, 2, 45, 62, 6, 210, 197, 212,
213, 210, 206, 6, 210, 197, 211, 213, 204, 212, 7, 205, 207, 206,
201, 212, 207, 210, 4, 211, 212, 207, 208, 6, 211, 201, 199, 206,
193, 204, 4, 197, 216, 201, 212, 8, 195, 207, 206, 212, 201, 206,
213, 197, 6, 198, 201, 206, 201, 211, 200, 5, 195, 217, 195, 204,
197, 6, 210, 197, 208, 197, 193, 212, 3, 197, 206, 196, 7, 201,
206, 195, 204, 213, 196, 197, 5, 194, 197, 199, 201, 206, 2, 207,
206, 6, 211, 215, 201, 212, 195, 200, 4, 204, 201, 211, 212, 14,
212, 210, 213, 211, 212, 197, 196, 208, 210, 207, 199, 210, 193, 205,
6, 205, 193, 201, 206, 197, 208, 7, 195, 207, 206, 212, 210, 207,
204, 4, 40, 42, 41, 58;
CONSTINTEGERARRAY SYMBOL(1300: 2171)= 1307,
1303, 0, 1305, 2, 1307, 1000, 1319, 1312, 1001, 1366,
1790, 1315, 1003, 1020, 1319, 4, 1345, 6, 1329, 1323,
1001, 1014, 1325, 1003, 1329, 4, 1329, 6, 1336, 1336,
1010, 1028, 1319, 1011, 1359, 1345, 1343, 1010, 1028, 1319,
1011, 1359, 1345, 8, 1352, 1352, 1010, 1028, 1307, 1011,
1352, 1359, 1357, 1026, 1307, 999, 1359, 1000, 1366, 1364,
1026, 1319, 999, 1366, 1000, 1374, 1372, 4, 1345, 1374,
6, 1374, 1000, 1381, 1379, 10, 1345, 999, 1381, 1000,
1386, 1384, 12, 1386, 15, 1410, 1393, 22, 1010, 1539,
1559, 1011, 1399, 28, 1010, 1539, 1559, 1011, 1410, 34,
1010, 1001, 38, 1345, 10, 1345, 10, 1345, 1011, 1416,
1414, 40, 1013, 1416, 1000, 1423, 1421, 10, 1001, 999,
1423, 1000, 1428, 1426, 46, 1428, 1000, 1436, 1431, 54,
1433, 46, 1436, 59, 54, 1461, 1439, 46, 1441, 54,
1444, 59, 1428, 1447, 64, 1423, 1450, 69, 1693, 1453,
76, 1423, 1456, 81, 1423, 1461, 87, 4, 1852, 6,
1468, 1464, 94, 1468, 1004, 1436, 1468, 1475, 1471, 102,
1473, 105, 1475, 109, 1491, 1481, 1436, 1496, 1001, 1416,
1487, 1461, 1491, 1001, 1416, 1504, 1491, 118, 1001, 1416,
1496, 1494, 118, 1496, 1000, 1504, 1500, 123, 118, 1502,
118, 1504, 1000, 1514, 1512, 4, 1010, 1475, 1011, 1514,
6, 1514, 1000, 1523, 1521, 1030, 1010, 1475, 1011, 999,
1523, 1000, 1534, 1527, 129, 1016, 1529, 139, 1532, 146,
1018, 1534, 1016, 1539, 1537, 153, 1539, 1000, 1553, 1545,
1345, 1032, 1345, 1553, 1550, 4, 1539, 1559, 6, 1553,
160, 1539, 1559, 1557, 1037, 1345, 1559, 1000, 1570, 1564,
164, 1539, 1570, 1568, 168, 1539, 1577, 1570, 1000, 1577,
1575, 164, 1539, 999, 1577, 1000, 1584, 1582, 168, 1539,
999, 1584, 1000, 1592, 1588, 1033, 1345, 1590, 171, 1592,
1000, 1598, 1596, 173, 1008, 1598, 1015, 1602, 1601, 173,
1602, 1611, 1609, 10, 1345, 171, 1345, 1602, 1611, 1000,
1620, 1616, 1496, 1001, 1416, 1620, 123, 1534, 1620, 1626,
1626, 1001, 1416, 1798, 1626, 1632, 1630, 10, 1620, 1632,
1000, 1650, 1642, 1496, 1598, 1010, 1001, 1410, 1806, 1011,
1650, 1650, 123, 1534, 1598, 1001, 1410, 1798, 1672, 1661,
1659, 10, 1010, 1001, 1410, 1806, 1011, 1650, 1661, 1000,
1672, 1664, 178, 1666, 182, 1668, 191, 1670, 201, 1672,
210, 1683, 1681, 38, 1012, 1028, 1319, 1359, 1693, 1683,
1683, 1000, 1693, 1691, 10, 1028, 1319, 1359, 1693, 999,
1693, 1000, 1700, 1698, 4, 1336, 6, 1700, 1000, 1707,
1705, 10, 1329, 999, 1707, 1000, 1712, 1710, 216, 1712,
1000, 1718, 1716, 10, 1345, 1718, 1000, 1731, 1729, 10,
1001, 1416, 4, 1345, 171, 1345, 6, 999, 1731, 1000,
1738, 1736, 28, 1539, 1559, 1738, 1000, 1751, 1741, 1019,
1743, 1006, 1748, 1381, 1539, 1559, 1006, 1751, 1386, 1006,
1765, 1755, 222, 1034, 1759, 228, 222, 1034, 1765, 228,
1010, 2012, 1011, 1771, 1771, 1769, 164, 2012, 1771, 1000,
1777, 1775, 233, 1777, 1777, 1000, 1790, 1781, 222, 1034,
1788, 1381, 1010, 1539, 1559, 1011, 1751, 1790, 2012, 1798,
1796, 238, 1001, 1366, 1790, 1798, 1000, 1806, 1806, 4,
1345, 171, 1345, 1602, 6, 1814, 1812, 38, 1028, 1319,
1359, 1814, 1000, 1823, 1817, 240, 1819, 182, 1821, 247,
1823, 1000, 1834, 1832, 1001, 38, 1345, 10, 1345, 10,
1345, 1834, 1000, 1841, 1839, 10, 1859, 999, 1841, 1000,
1852, 1845, 173, 1001, 1852, 1001, 4, 1859, 1834, 1877,
6, 1859, 1855, 1001, 1859, 1859, 1834, 1877, 1869, 1863,
1436, 1869, 1869, 4, 1859, 1834, 1877, 6, 1877, 1874,
1496, 1001, 1416, 1877, 123, 1620, 1885, 1883, 168, 1859,
1834, 999, 1885, 1000, 1902, 1890, 255, 1002, 1006, 1894,
1022, 1902, 1006, 1900, 260, 1009, 10, 1009, 1006, 1902,
1031, 1916, 1906, 1023, 1916, 1911, 1024, 266, 1955, 1960,
1916, 1025, 1005, 10, 1939, 1939, 1921, 269, 1001, 271,
1923, 1988, 1928, 4, 1988, 1977, 6, 1932, 273, 1988,
6, 1937, 4, 278, 1977, 6, 1939, 281, 1955, 1944,
269, 1001, 271, 1946, 1988, 1951, 4, 278, 1977, 6,
1955, 273, 1005, 6, 1960, 1958, 278, 1960, 1005, 1968,
1966, 10, 1005, 10, 1005, 1968, 1000, 1977, 1972, 0,
1005, 1975, 2, 1005, 1977, 1000, 1983, 1981, 0, 281,
1983, 1000, 1988, 1986, 38, 1988, 1000, 2003, 1993, 1983,
1300, 1003, 1996, 1001, 1968, 2001, 4, 2003, 1968, 6,
2003, 283, 2012, 2006, 287, 2008, 291, 2010, 295, 2012,
298, 2045, 2021, 1010, 1001, 1366, 1790, 1011, 1584, 1765,
2025, 302, 1001, 1366, 2027, 305, 2031, 312, 1033, 1345,
2034, 319, 1765, 2036, 327, 2041, 332, 1707, 1329, 1712,
2043, 339, 2045, 344, 2172, 2052, 1027, 1010, 2012, 1011,
1738, 2054, 1007, 2062, 1381, 1010, 1539, 1559, 1011, 1751,
1006, 2067, 353, 1035, 1771, 1006, 2072, 360, 1029, 1823,
1006, 2077, 366, 1036, 1731, 1006, 2082, 1386, 360, 1029,
1006, 2090, 1004, 1008, 1010, 1436, 1011, 1611, 1006, 2094,
373, 1523, 1006, 2099, 87, 153, 1841, 1006, 2109, 1010,
1814, 1461, 1011, 1592, 1001, 1410, 1504, 1006, 2114, 1661,
1436, 1632, 1006, 2118, 377, 1003, 1038, 2122, 385, 1015,
1006, 2131, 391, 1021, 1707, 1329, 1700, 222, 1034, 1006,
2142, 394, 1001, 1416, 4, 1345, 171, 1345, 6, 1718,
1006, 2146, 401, 1006, 1017, 2152, 233, 1035, 1039, 1034,
1006, 2155, 8, 1885, 2158, 406, 1006, 2162, 421, 1001,
1006, 2166, 428, 1003, 1006, 2170, 1001, 436, 1019, 2172,
1006;
CONSTINTEGER SS= 2045
CONST BYTE INTEGER ARRAY I TO E TAB(0 : 127) = C
X'40',X'40',X'40',X'40',X'40',X'40',X'40',X'40',
X'40',X'40',X'15',X'40',X'0C',X'40',X'40',X'40',
X'40',X'40',X'40',X'40',X'40',X'40',X'40',X'40',
X'40',X'40',X'40',X'40',X'40',X'40',X'40',X'40',
X'40',X'4F',X'7F',X'7B',X'5B',X'6C',X'50',X'7D',
X'4D',X'5D',X'5C',X'4E',X'6B',X'60',X'4B',X'61',
X'F0',X'F1',X'F2',X'F3',X'F4',X'F5',X'F6',X'F7',
X'F8',X'F9',X'7A',X'5E',X'4C',X'7E',X'6E',X'6F',
X'7C',X'C1',X'C2',X'C3',X'C4',X'C5',X'C6',X'C7',
X'C8',X'C9',X'D1',X'D2',X'D3',X'D4',X'D5',X'D6',
X'D7',X'D8',X'D9',X'E2',X'E3',X'E4',X'E5',X'E6',
X'E7',X'E8',X'E9',X'4A',X'5F',X'5A',X'6A',X'6D',
X'7C',X'81',X'82',X'83',X'84',X'85',X'86',X'87',
X'88',X'89',X'91',X'92',X'93',X'94',X'95',X'96',
X'97',X'98',X'99',X'A2',X'A3',X'A4',X'A5',X'A6',
X'A7',X'A8',X'A9',X'C0',X'40',X'D0',X'40',X'40'
CONSTINTEGERARRAY OPC(0:126)=0,
M' JCC',M' JAT',M' JAF',0(4),
M' VAL',M' CYD',M'INCA',M'MODD',M'PRCL',M' J',M' JLK',M'CALL',
M' ADB',M' SBB',M'DEBJ',M' CPB',M' SIG',M' MYB',M' VMY',M'CPIB',
M' LCT',M'MPSR',M'CPSR',M'STCT',M'EXIT',M'ESEX',M' OUT',M' ACT',
M' SL',M'SLSS',M'SLSD',M'SLSQ',M' ST',M'STUH',M'STXN',M'IDLE',
M' SLD',M' SLB',M'TDEC',M'INCT',M' STD',M' STB',M'STLN',M'STSF',
M' L',M' LSS',M' LSD',M' LSQ',M'RRTC',M' LUH',M'RALN',M' ASF',
M'LDRL',M' LDA',M'LDTB',M' LDB',M' LD',M' LB',M' LLN',M' LXN',
M' TCH',M'ANDS',M' ORS',M'NEQS',M'EXPA',M' AND',M' OR',M' NEQ',
M' PK',M' INS',M'SUPK',M' EXP',M'COMA',M' DDV',M'DRDV',M'DMDV',
M'SWEQ',M'SWNE',M' CPS',M' TTR',M' FLT',M' IDV',M'IRDV',M'IMDV',
M' MVL',M' MV',M'CHOV',M' COM',M' FIX',M' RDV',M'RRDV',M'RDVD',
M' UAD',M' USB',M'URSB',M' UCP',M' USH',M' ROT',M' SHS',M' SHZ',
M' DAD',M' DSB',M'DRSB',M' DCP',M' DSH',M' DMY',M'DMYD',M'CBIN',
M' IAD',M' ISB',M'IRSB',M' ICP',M' ISH',M' IMY',M'IMYD',M'CDEC',
M' RAD',M' RSB',M'RRSB',M' RCP',M' RSC',M' RMY',M'RMYD';
CONSTBYTEINTEGERARRAY ONE CASE(0 : 127) = C
0, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15,
16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,
32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,
48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,
64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,
80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,
96,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,
80,81,82,83,84,85,86,87,88,89,90,123,124,125,126,127;
CONSTINTEGER NO OF SNS=65
CONSTHALFINTEGERARRAY TSNAME (0:NO OF SNS)=X'1000'(8),
X'1001',X'1000'(5),X'1001',X'1062',X'1001'(2),X'1062',
X'1000'(2),X'52',X'51',X'62',X'1062'(7),
X'1000',X'31',X'51',X'1062'(2),X'31',X'1000',
X'51',X'62',X'1000'(2),X'35',X'1000',X'1035',
X'31',X'35',X'1035',X'33',0,X'1001',X'51',X'52',X'51',
X'61',X'72',X'61',X'72',X'51',X'62',X'1051',X'41',
X'1000',X'62',X'1061'(2);
!
OWNINTEGERARRAY FIXED GLA(0:11)=0,
X'50000000',0(2),-1,0,0(6);
CONSTBYTEINTEGERARRAY BYTES(0:7)=0(3),1,2,4,8,16;
CONSTBYTEINTEGERARRAY TRTAB(0:255)=0(48),
1(10),0(7),2(26),0(6),2(26),0(5),0(128)
CONSTINTEGER MAXLEVELS=31,CONCOP=13,FIXEDGLALEN=48
CONSTINTEGER JOBBERBIT=X'40000000'; ! SET IN JOBBER MODE
CONSTINTEGER CEBIT=1; ! SET IN COMPILER ENVIRONMENT
CONSTINTEGER MAXDICT=X'100'; ! SET FOR MAX OF EVERYTHING
!
! THE PRINCIPAL OPCODES ARE HERE DEFINED AS THEIR MNEMONICS(AMENDED)
!
CONSTINTEGER LB=X'7A',SLB=X'52',STB=X'5A',ADB=X'20',CPB=X'26', C
MYB=X'2A',SBB=X'22',CPIB=X'2E',OUT=X'3C',CPSR=X'34'
CONSTINTEGER LD=X'78',LDA=X'72',INCA=X'14',STD=X'58',LDB=X'76', C
LDTB=X'74',LDRL=X'70',CYD=X'12',MODD=X'16',SLD=X'50'
CONSTINTEGER STLN=X'5C',ASF=X'6E',ST=X'48',RALN=X'6C',LXN=X'7E',C
LLN=X'7C',LSS=X'62',SLSS=X'42',MPSR=X'32',STSF=X'5E',C
LUH=X'6A',STUH=X'4A',LSD=X'64',SLSD=X'44',PRCL=X'18', C
LSQ=X'66',SLSQ=X'46',STXN=X'4C',LCT=X'30',STCT=X'36'
CONSTINTEGER JUNC=X'1A',JLK=X'1C',CALL=X'1E',EXIT=X'38',JCC=2, C
JAT=4,JAF=6,DEBJ=X'24'
CONSTINTEGER IAD=X'E0',ICP=X'E6',USH=X'C8',ISB=X'E2',IRSB=X'E4',C
OR=X'8C',UCP=X'C6',IMY=X'EA',IMDV=X'AE',AND=X'8A', C
ISH=X'E8',IMYD=X'EC',IDV=X'AA'
CONSTINTEGER RAD=X'F0',RSB=X'F2',RRSB=X'F4',FLT=X'A8',RRDV=X'BC', C
RSC=X'F8',FIX=X'B8',RDV=X'BA',RDDV=X'BE',RMYD=X'FC', C
RMY=X'FA'
!
CONSTINTEGER MVL=X'B0',MV=X'B2',SWEQ=X'A0',SWNE=X'A2',CPS=X'A4'
!
! DEFINE SOME MNEMONICS FOR THE VISIBLE REGISTERS (XCEPT LNB)
!
CONSTINTEGER ACCR=0,DR=1,LNB=2,XNB=3,PC=4,CTB=5,TOS=6,BREG=7
CONSTBYTEINTEGERARRAY LDCODE(0:7)=0,LD,LLN,LXN,0,LCT,0,LB;
!
CONSTSTRING (8)MDEP="S#NDIAG"
CONSTSTRING (8)IOCPEP="S#IOCP"; ! EP FOR IOCP
CONSTSTRING (11)AUXSTEP="ICL9CEAUXST";! DATA REF FOR INDIRECT AUX ST
CONSTINTEGER SNPT=X'1006'; ! SPECIALNAME PTYPE
CONSTINTEGER COMMALT=2,ENDALT=9,UNASSPAT=X'81818181',DECALT=8
!
INTEGER DICTBASE, CONSTPTR, CONSTBTM, CONSTHOLE, WKFILEAD, C
WKFILEK, DUMMYFORMAT, P1SIZE, LEVELINF, IOCPDISP, PARMBITS1, C
PARMBITS2,PARMLET
!
INTEGER ASL, NNAMES, ARSIZE, CABUF, PPCURR, CONSTLIMIT, OLDLINE, C
LINE, LENGTH, NEXTP, SNUM, RLEVEL, NMAX, USTPTR, PLABEL,C
LEVEL, CA, LASTNAME, CDCOUNT, ASL CUR BTM, PARMDYNAMIC
!
INTEGER FAULTY, HIT, INHCODE, IMPS, TTOPUT, LIST, PARMDIAG, C
WARNFLAG, PARMTRACE, PARMLINE, PARMOPT, CTYPE, DCOMP, C
CPRMODE, PARMCHK, PARMARR, PARMDBUG,C
COMPILER, LAST INST, SMAP, STACK, AUXST, PARMY, BFFLAG
!
INTEGER RBASE, N, FREE FORMAT, PARMPROF, EXITLAB, CONTLAB, C
Q, R, S, NEST, FNAME, LDPTR, GLACA, GLACABUF, C
GLACURR, CREFHEAD, SSTL, QMAX, STMTS, LASTAT, C
FILE ADDR, FILE PTR, FILE END, FILE SIZE, LASTEND, C
BIMSTR,STLIMIT,STRLINK,RECTB,ASL WARN,IHEAD,IDEPTH
!
INTEGER MAX ULAB, SFLABEL
LONGREAL CVALUE, IMAX, CTIME
STRING (31)MAINEP
RECORDFORMAT LISTF((HALFINTEGER PTYPE,(HALF UIOJ OR BYTE XB,FLAG),
HALF SNDISP,ACC,SLINK,KFORM OR INTEGER S1,S2,S3),INTEGER LINK)
RECORDFORMAT RD((INTEGER S1 OR BYTE UPTYPE,PTYPE,XB,FLAG),
(LONGREAL LR OR (INTEGER D OR REAL R), INTEGER XTRA))
INTEGER LOGEPDISP,EXPEPDISP
!
EXTERNALINTEGERMAPSPEC COMREG ALIAS "S#COMREG"(INTEGER N)
BEGIN
FILE ADDR=COMREG(46); ! SOURCE FILE IF CLEAN
PARMBITS1=COMREG(27)
PARMBITS2=COMREG(28)
WKFILEAD=COMREG(14)
WKFILEK=INTEGER(WKFILEAD+8)>>10
IF FILE ADDR<=0 THEN FILESIZE=64000 AND FILE ADDR=0 ELSESTART
FILE PTR=FILE ADDR+INTEGER(FILE ADDR+4)
FILE END=FILE ADDR+INTEGER(FILE ADDR)
FILE SIZE=INTEGER(FILE ADDR)
FINISH
NNAMES=255
IF FILESIZE>10000 THEN NNAMES=511
IF PARMBITS1&JOBBER BIT=0 START
IF FILESIZE>32000 THEN NNAMES=1023
IF FILESIZE>256*1024 OR PARMBITS2&MAXDICT#0 OR C
WKFILEK>512 THEN NNAMES=2047
FINISH
ASL=3*NNAMES
ASL=4095 IF ASL>4095 AND (WKFILEK<=512 AND PARMBITS2&MAXDICT=0)
! STAY WITHIN 128K AUXSTACK
ARSIZE=WKFILEK*768-300
END
BYTEINTEGERARRAYFORMAT AF(0:ARSIZE)
BYTEINTEGERARRAYNAME A
RECORD (LISTF)ARRAY ASLIST(0:ASL)
INTEGERARRAY WORD, TAGS(0:NNAMES)
INTEGERARRAY DVHEADS(0:12)
INTEGERFNSPEC FROMAR4(INTEGER PTR)
INTEGERFNSPEC FROMAR2(INTEGER PTR)
ROUTINESPEC TOAR8(INTEGER PTR, LONGREAL VALUE)
ROUTINESPEC TOAR4(INTEGER PTR, VALUE)
ROUTINESPEC TOAR2(INTEGER PTR,VALUE)
ROUTINESPEC WARN(INTEGER N,V)
ROUTINESPEC FAULT(INTEGER N,VAL,IDEN)
STRINGFNSPEC PRINTNAME(INTEGER N)
INTEGERFNSPEC MORE SPACE
!%INTEGERFNSPEC NEWCELL
ROUTINESPEC INSERTATEND(INTEGERNAME S, INTEGER A, B, C)
ROUTINESPEC FROM12(INTEGER CELL, INTEGERNAME S1, S2)
ROUTINESPEC FROM123(INTEGER CELL, INTEGERNAME S1, S2, S3)
ROUTINESPEC POP(INTEGERNAME C, P, Q, R)
ROUTINESPEC PUSH(INTEGERNAME C, INTEGER S1, S2, S3)
INTEGERFNSPEC FIND(INTEGER LAB, LIST)
ROUTINESPEC MLINK(INTEGERNAME CELL)
ROUTINESPEC REPLACE1(INTEGER CELL, S1)
ROUTINESPEC REPLACE2(INTEGER CELL, S2)
ROUTINESPEC REPLACE3(INTEGER CELL,S3)
ROUTINESPEC REPLACE123(INTEGER CELL,A1,A2,S3)
INTEGERFNSPEC FROM2(INTEGER CELL)
INTEGERFNSPEC FROM1(INTEGER CELL)
INTEGERFNSPEC FROM3(INTEGER CELL)
ROUTINESPEC BINSERT(INTEGERNAME T,B,INTEGER S1,S2,S3)
ROUTINESPEC CLEARLIST(INTEGERNAME HEAD)
STRING (255)FNSPEC MESSAGE(INTEGER N)
EXTERNALROUTINESPEC LPUT ALIAS "S#LPUT"(INTEGER A, B, C, D)
EXTERNALLONGREALFNSPEC CPUTIME ALIAS "S#CPUTIME"
!*DELSTART
EXTERNALROUTINESPEC NCODE ALIAS "S#NCODE"(INTEGER START, FINISH, CA)
ROUTINESPEC PRINTLIST(INTEGER HEAD)
ROUTINESPEC PRHEX(INTEGER VALUE,PLACES)
ROUTINESPEC CHECK ASL
!*DELEND
IF VMEB=NO THEN START
EXTERNALROUTINESPEC CONSOURCE ALIAS "S#CONSOURCE"(STRING (31)FILE,INTEGERNAME AD)
FINISH
! START OF COMPILATION
A==ARRAY(WKFILE AD+256*WKFILEK, AF)
BEGIN
!***********************************************************************
!* THIS BLOCK INITIALISE THE COMPILER SCALARS AND ARRAYS *
!* WAS ORIGINALLY ROUTINE 'INITIALISE'. *
!* THE INITIALISATION OF THE CONSTANT LISTS WITH THE VALUES *
!* IN PERM MAY BE OMITTED IN BATCH OR CUT-DOWN VERSIONS. *
!***********************************************************************
ROUTINESPEC READ LINE(INTEGER MODE,CHAR)
INTEGERFNSPEC COMPARE(INTEGER P)
ROUTINESPEC PNAME(INTEGER MODE)
ROUTINESPEC CONST(INTEGER MODE)
ROUTINESPEC TEXTTEXT(INTEGER EBCDIC)
INTEGER DSIZE,NEXT,ATLINE1,STARSTART,CCSIZE
DSIZE=7*NNAMES; CCSIZE=256*(WKFILEK-1)
IF PARMBITS2&MAXDICT#0 THEN DSIZE=DSIZE+NNAMES
INTEGERARRAY DISPLAY,SFS(0:MAXLEVELS)
BYTEINTEGERARRAY TLINE(-20:255),LETT(0:DSIZE+20)
BYTEINTEGERARRAYFORMAT CCF(0:CCSIZE)
BYTEINTEGERARRAYNAME CC
LONGINTEGER ATL0,ASYM0
CONSTBYTEINTEGERARRAY ILETT(0: 513)= 11,
'S','E','L','E','C','T','I','N','P','U','T', 12,'S','E','L','E',
'C','T','O','U','T','P','U','T', 7,'N','E','W','L','I','N','E',
5,'S','P','A','C','E', 10,'S','K','I','P','S','Y','M','B','O',
'L', 10,'R','E','A','D','S','T','R','I','N','G', 8,'N','E','W',
'L','I','N','E','S', 6,'S','P','A','C','E','S', 10,'N','E','X',
'T','S','Y','M','B','O','L', 11,'P','R','I','N','T','S','Y','M',
'B','O','L', 10,'R','E','A','D','S','Y','M','B','O','L', 4,'R',
'E','A','D', 5,'W','R','I','T','E', 7,'N','E','W','P','A','G',
'E', 4,'A','D','D','R', 6,'A','R','C','S','I','N', 3,'I','N',
'T', 5,'I','N','T','P','T', 6,'F','R','A','C','P','T', 5,'P',
'R','I','N','T', 7,'P','R','I','N','T','F','L', 4,'R','E','A',
'L', 7,'I','N','T','E','G','E','R', 3,'M','O','D', 6,'A','R',
'C','C','O','S', 4,'S','Q','R','T', 3,'L','O','G', 3,'S','I',
'N', 3,'C','O','S', 3,'T','A','N', 3,'E','X','P', 11,'C','L',
'O','S','E','S','T','R','E','A','M', 11,'B','Y','T','E','I','N',
'T','E','G','E','R', 8,'E','V','E','N','T','I','N','F',
6,'R','A','D','I','U','S', 6,'A','R','C','T','A','N',
6,'L','E','N','G','T','H', 11,'P','R','I','N','T','S','T','R',
'I','N','G', 2,'N','L', 8,'L','O','N','G','R','E','A','L', 7,
'P','R','I','N','T','C','H', 6,'R','E','A','D','C','H', 6,'S',
'T','R','I','N','G', 8,'R','E','A','D','I','T','E','M', 8,'N',
'E','X','T','I','T','E','M', 6,'C','H','A','R','N','O', 8,'T',
'O','S','T','R','I','N','G', 9,'S','U','B','S','T','R','I',
'N','G', 6,'R','E','C','O','R','D', 5,'A','R','R','A','Y', 6,
'S','I','Z','E','O','F',4,'I','M','O','D',2,'P',
'I',9,'E','V','E','N','T','L','I','N','E',11,'L','O','N','G',
'I','N','T','E','G','E','R',12,'L','O','N','G','L','O','N','G',
'R','E','A','L',9,'L','E','N','G','T','H','E','N','I',
9,'L','E','N','G','T','H','E','N','R',
8,'S','H','O','R','T','E','N','I',
8,'S','H','O','R','T','E','N','R',
6,'N','E','X','T','C','H',
11,'H','A','L','F','I','N','T','E','G','E','R',
8,'P','P','R','O','F','I','L','E',
5,'F','L','O','A','T',
4,'L','I','N','T',
6,'L','I','N','T','P','T',255;
CC==ARRAY(WKFILEAD+32,CCF)
IMAX=(-1)>>1;PLABEL=24999
LETT(0)=0
ATLINE1=ADDR(TLINE(1))
INTEGER(ADDR(ATL0)+4)=ATLINE1-1
INTEGER(ADDR(ATL0))=X'18000100'
INTEGER(ADDR(ASYM0))=X'28000C00'
INTEGER(ADDR(ASYM0)+4)=ADDR(SYMBOL(1300))-4*1300
N=12;
MAX ULAB=NNAMES+16384; ! LARGEST VALID USER LABEL
GLACURR=0; GLACA=FIXEDGLALEN; GLACABUF=GLACA
PARMOPT=1 ; PARMARR=1; LAST INST=0
PARMLINE=1; PARMTRACE=1; PARMDIAG=1
LIST=1; SFLABEL=20999; PARMCHK=1
EXITLAB=0; CONTLAB=0
CABUF=0; PPCURR=0; OLDLINE=0; COMPILER=0
RLEVEL=0; NMAX=0; USTPTR=0
LEVEL=0; CA=0; LASTAT=0
FAULTY=0; WARNFLAG=0; INHCODE=0
DCOMP=0; BFFLAG=0; CPRMODE=0
NEXT=1; LDPTR=0
IOCPDISP=0; CREFHEAD=0; AUXST=0
RBASE=10; LOGEPDISP=0; EXPEPDISP=0; STRLINK=0
RECTB=0; IHEAD=0; IDEPTH=0
SSTL=0; STMTS=1; SNUM=0; LEVELINF=0
CDCOUNT=0
BIMSTR=0
LOGEPDISP=0; EXPEPDISP=0
MAINEP="S#GO"; ! DEFAULT MAIN ENTRY
DICTBASE=ADDR(LETT(0))
!
! OPEN OBJECT FILE HERE BEFORE MORE PAGES OF COMPILER CODE
! ARE PAGED IN AND SUB-SYSTEM PAGES MOVE OUT
!
LPUT(0,0,0,0)
CTIME=CPUTIME
I=COMREG(27)
STLIMIT=X'1F000'
IF I>>24&1#0 THEN STLIMIT=COMREG(48)-4096
IF I&2=2 THEN LIST=0
IF I&4=4 THEN PARMDIAG=0
IF I&X'800000'#0 THEN PARMLINE=0
IF I&16=16 THEN PARMCHK=0
IF I&32=32 THEN PARMARR=0
PARMPROF=(I>>15&1)!(I>>7&1); ! USE MAP OR PROFILE BIT PRO TEM
PARMDYNAMIC=I>>20&1
PARMLET=I>>13&1
DCOMP=I>>14&1; ! PARM CODE OR D
PARMDBUG=I>>18&1
IF I&64=64 THEN PARMTRACE=0 AND PARMDIAG=0
FREE FORMAT=I&X'80000'
STACK=I>>3&1
SMAP=I>>26&1; ! USE PARMZ BIT FOR DUMPING WKFILE
PARMY=I>>27&1; ! PARMY FLAGS UNUSED CONSTS
TTOPUT=COMREG(40)
IF I&(1<<16)#0 THEN START
PARMARR=0; PARMOPT=0
PARMLINE=0; PARMCHK=0; PARMDIAG=0
FINISH
PARMTRACE=PARMTRACE!PARMOPT; ! ALLOW NOTRACE ONLY WITH OPT
IMPS=I>>23&1; ! BIT SET IF IMPS REQUESTED
IMPS=1; ! FOR TESTING
NEWLINES(3); SPACES(14)
PRINTSTRING("ERCC. Imp80")
PRINTSTRING(" Compiler Release")
WRITE(RELEASE,1)
PRINTSTRING(" Version ".LADATE)
NEWLINES(3)
WRITE(NNAMES,5); WRITE(ASL,5)
NEWLINE
ASL WARN=0
ASL CUR BTM=ASL-240
CONST LIMIT=4*ASL CUR BTM-8
CYCLE I=ASL CUR BTM,1,ASL-1
ASLIST(I+1)_LINK=I
REPEAT
ASLIST(ASL CUR BTM)_LINK=0
ASLIST(0)_S1=-1
ASLIST(0)_S2=-1
ASLIST(0)_S3=-1
ASLIST(0)_LINK=0
CYCLE I=0,1,NNAMES
WORD(I)=0; TAGS(I)=0;
REPEAT
CYCLE I=0,1,12
DVHEADS(I)=0
REPEAT
CYCLE I=0,1,MAXLEVELS
SFS(I)=0
REPEAT
!
! NOW DECLARE THE SPECIAL NAMES WHICH ARE IN ARRAY ILETT.
!
K=0; NEXT=1
I=ILETT(0)
WHILE I<255 CYCLE
CYCLE J=I,-1,1
CC(J)=ILETT(K+J)
REPEAT
CC(I+1)=';'
R=2; Q=1; PNAME(1)
PUSH(TAGS(LASTNAME),SNPT<<16!X'8000',0,SNUM<<16)
SNUM=SNUM+1
K=K+I+1; I=ILETT(K)
REPEAT
!
COMREG(24)=16; ! RETURN CODE
DUMMY FORMAT=0; ! DUMMY RECORD FORMAT
PUSH(DUMMY FORMAT,0,0,0); ! FOR BETTER ERROR RECOVERY
LINE=0; LENGTH=0; Q=1
R=1; LEVEL=1
CYCLE
IF Q>=LENGTH THEN QMAX=1 AND READ LINE(0,0)
WARNFLAG=0
STARSTART=R
R=R+3
OLDLINE=LINE
A(R)=LINE>>8
A(R+1)=LINE&255
R=R+2
IF COMPARE(SS)=0 THEN START
FAULT(100,ADDR(CC(0)),0)
R=STARSTART
FINISH ELSE START
FAULT(102, WKFILEK, 0) IF R>ARSIZE
IF A(STARSTART+5)=COMMALT THEN R=STARSTART ELSE START
I=R-STARSTART
A(STARSTART)=I>>16
A(STARSTART+1)=I>>8&255
A(STARSTART+2)=I&255
IF A(STARSTART+5)=DECALT AND LEVEL>1 THEN START
IF SFS(LEVEL)=0 THEN START
TO AR4(DISPLAY(LEVEL),STARSTART)
DISPLAY(LEVEL)=STARSTART+6
FINISH ELSE A(STARSTART+6)=128;! FLAG AS UNLINKED
FINISH
!*DELSTART
IF SMAP#0 THEN START
NEWLINE; WRITE(LINE, 5)
WRITE(STARSTART,5); NEWLINE; J=0
CYCLE I=STARSTART, 1, R-1
WRITE(A(I), 5)
J=J+1
IF J>=20 THEN NEWLINE AND J=0
REPEAT
NEWLINE
FINISH
!*DELEND
IF A(STARSTART+5)=ENDALT AND C
1<=A(STARSTART+6)<=2 START ;! ENDOF PROG OR FILE
IF IHEAD=0 THEN EXIT
IDEPTH=IDEPTH-1
POP(IHEAD,FILEADDR,FILEPTR,FILEEND)
R=STARSTART; ! IGNORE ENDOFFILE LIKE IMP77
LENGTH=1
CONTINUE
FINISH
IF LEVEL=0 THEN START
FAULT(14, 0, 0)
R=STARSTART; ! IGNORE IT
LEVEL=1
FINISH
FINISH
FINISH
REPEAT
TO AR8(R,0); R=R+8
IF R+NEXT>ARSIZE THEN FAULT(102, WKFILEK,0)
P1SIZE=R
IF USE IMP=YES THEN START
CYCLE I=0,1,NEXT
A(R+I)=LETT(I)
REPEAT
FINISH ELSE START
*LDTB_X'18000000'
*LDB_NEXT
*LDA_LETT+4
*CYD_0
*LDA_A+4
*INCA_R
*MV_L =DR
FINISH
DICTBASE=ADDR(A(R))
R=R+NEXT+1
->BEND
ROUTINE READ LINE(INTEGER MODE,CHAR)
ROUTINESPEC GET LINE
INTEGER DEL, LL, LP, PREV, LATC
LL=0; LP=0; Q=1; LATC=-5
LENGTH=0; DEL=0
NEXT:
IF USE IMP=YES THEN START
LP=LP+1
IF LP>LL THEN GET LINE AND LP=1
I=TLINE(LP)
IF MODE=0 THEN START
WHILE I='{' CYCLE
CYCLE
PREV=I
LP=LP+1
I=TLINE(LP)
REPEAT UNTIL PREV='}' OR I=NL
REPEAT
IF I='%' THEN DEL=128 AND ->NEXT
I=ONE CASE(I)
IF 'A'<=I<='Z' THEN I=I!DEL ELSE START
DEL=0
->NEXT IF I=' '
FINISH
LENGTH=LENGTH+1
CC(LENGTH)=I
IF I='''' OR I=34 THEN MODE=1 AND CHAR=I
FINISH ELSE START
LENGTH=LENGTH+1
CC(LENGTH)=I
IF I=CHAR THEN MODE=0
FINISH
->NEXT UNLESS I=NL
FINISH ELSE START
*LB_LP
*ADB_1
*CPB_LL
*JCC_12,<RLL1>
GET LINE
*LB_1
RLL1:
*STB_LP
*LB_(ATL0+B )
*LSS_MODE
*JAF_4,<RLL2>
CB4:
*CPB_123; !'{'
*JCC_7,<CB1>
*LB_LP
CB2:
*ADB_1
*LSS_(DR +B )
*ICP_10
*JCC_8,<CB3>
*ICP_125; ! '}'
*JCC_7,<CB2>
*ADB_1
*LSS_(DR +B )
CB3:
*STB_LP
*ST_B ; ! CHAR TO BREG FOR MAIN SEQUENCE
*J_<CB4>
CB1:
*CPB_37; !'%'
*JCC_7,<RLL3>
*L_128
*ST_DEL
*J_<NEXT>
RLL3:
*LSS_(ONE CASE+B ); ! LOWER CASE TO UPPER
*ICP_65; !'A'
*JCC_4,<RLL4>
*ICP_90; !'Z'
*JCC_2,<RLL4>
*OR_DEL
*J_<RLL5>
RLL4:
*LB_0
*STB_DEL
*ICP_32; !' '
*JCC_8,<NEXT>
RLL5:
*LB_LENGTH
*ADB_1
*STB_LENGTH
*ST_(CC+B )
*ICP_39; !''''
*JCC_8,<RLL6>
*ICP_34; !'"'
*JCC_7,<RLL7>
RLL6:
*ST_CHAR
*LB_1
*STB_MODE
RLL7:
*ICP_10
*JCC_7,<NEXT>
*J_<RLL8>
RLL2:
*LSS_B
*LB_LENGTH
*ADB_1
*STB_LENGTH
*ST_(CC+B )
*ICP_CHAR
*JCC_7,<RLL9>
*LB_0
*STB_MODE
RLL9:
*ICP_10
*JCC_7,<NEXT>
RLL8:
FINISH
IF LENGTH-1=LATC THEN LENGTH=LATC AND ->NEXT; ! NULL CONTINUATION IS IGNORED
I=CC(LENGTH-1)
IF I='C'+128 THEN LENGTH=LENGTH-2 AND LATC=LENGTH AND ->NEXT
IF MODE=0 AND I=',' THEN C
LENGTH=LENGTH-1 AND LATC=LENGTH AND ->NEXT
FAULT(101,0,0) IF LENGTH>CCSIZE
RETURN
ROUTINE GET LINE
EXTERNALROUTINESPEC IOCP ALIAS "S#IOCP"(INTEGER A,B)
CONSTBYTEINTEGERARRAY ITOI(0:255)=C
32(10),10,32(14),25,26,32(5),
32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,
48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,
64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,
80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,
96,97,98,99,100,101,102,103,104,105,106,107,108,109,
110,111,112,113,114,115,116,117,118,119,
120,121,122,123,124,125,126,32,
26(5),10,26(10),
26(16),
26(14),92,38,
26(11),35,26(4),
26(16),
26(9),35,26(5),94,
26(32);
INTEGER K
LL=0
IF FILE ADDR=0 THEN START ; ! SOURCE NOT A 'CLEAN' FILE
UNTIL K=NL CYCLE
READ SYMBOL(K)
TLINE(LL+1)=ITOI(K)
LL=LL+1
REPEAT
FINISH ELSE START
IF FILEPTR>=FILE END START
IF IHEAD#0 THEN POP(IHEAD,FILEADDR,FILEPTR,FILEEND) C
AND IDEPTH=IDEPTH-1 AND GETLINE AND RETURN
FAULT(110,0,0)
FINISH
IF USE IMP=NO THEN START
*LDA_FILEPTR
*LB_FILEEND
*SBB_FILEPTR
*ADB_X'18000000'
*LDTB_B
*SWNE_L =DR ,0,10
*JCC_8,<IMP>
*CYD_0
*STUH_B
*IAD_1
*ST_B
*ISB_FILEPTR
*ST_LL
*LDA_FILEPTR
*STB_FILEPTR
*LDB_LL
*CYD_0
*LDA_ATLINE1
*MV_L =DR ,0,0
*LDA_ATLINE1; *LDTB_X'18000000'
*LDB_LL
*LSS_ITOI+4; *LUH_X'180000FF'
*TTR_L =DR
->OLIST
FINISH
IMP:
UNTIL K=NL OR K=0 CYCLE
K=BYTE INTEGER(FILEPTR); ! NEXT CHAR FROM SORCE FILE
FILE PTR=FILE PTR+1
TLINE(LL+1)=ITOI(K)
LL=LL+1
REPEAT
OLIST:
FINISH
! %IF MODE=0 %AND LL=1 %THEN GET LINE %AND %RETURN
! LINE=LINE+1 %UNLESS MODE=0 %AND LENGTH>0
LINE=LINE+1; ! COUNT ALL LINES
IF LIST#0 THEN START
IF MODE=0 AND LENGTH>0 THEN C
PRINTSTRING(" C") ELSE WRITE(LINE, 5)
! SPACES(8)
CYCLE K=-7,1,0
TLINE(K)=' '
REPEAT
IF MODE#0 THEN TLINE(-7)=M'"'
TLINE(-8)=LL+8
IOCP(15,ADDR(TLINE(-8)))
FINISH
IF FREE FORMAT=0 AND LL>73 THEN TLINE(73)=10 AND LL=73
END
END
INTEGERFN COMPARE(INTEGER P)
INTEGER I, J, ITEM, RA, RL, RP, RQ, RR, RS, MARKER, SSL, ALT, PP
OWNINTEGER SAVECOMP; ! FOR CHECKING DSIDED CONDS
SWITCH BIP(999:1039)
IF USE IMP=YES THEN START
RP=SYMBOL(P)
RL=LEVEL
P=P+1
PP=P; ! ROUTINE REALLY STARTS HERE
FINISH ELSE START
*LB_P
*JLK_2
*EXIT_-64
SUBENTRY:
*LSS_(ASYM0+B )
*LUH_LEVEL
*ST_RL
*ADB_1
*STB_P
*STB_PP
FINISH
COMM:
IF USE IMP=YES THEN START
RQ=Q; ! RESET VALUES OF LINE&AR PTRS
RR=R
SSL=STRLINK; ! SAVE STRING LINK
ALT=1; ! FIRST ALTERNATIVE TO BE TRIED
RA=SYMBOL(P); ! RA TO NEXT PHRASE ALTERNATIVE
RS=P
FINISH ELSE START
*LSD_Q
*ST_RQ
*LSS_1
*LUH_STRLINK
*ST_SSL
*LB_P
*LSS_(ASYM0+B )
*ST_RA
*STB_RS
FINISH
UPR: R=R+1
SUCC: ! SUCCESS ON TO NEXT ITEM
IF USE IMP=YES THEN START
RS=RS+1; ! RS=NEXT ALTERNATIVE MEANS THAT
! THIS ALT HAS BEEN COMPLETED SO
! EXIT WITH HIT=1
IF RS=RA THEN ->FINI
ITEM=SYMBOL(RS); ! NEXT BRICK IN THE CURRENT ALT
IF ITEM<999 THEN ->LIT
FINISH ELSE START
*LB_RS
*ADB_1
*CPB_RA
*JCC_8,<FINI>
*STB_RS
*LB_(ASYM0+B )
*CPB_999
*JCC_4,<LIT>
*STB_ITEM
FINISH
IF ITEM<1300 THEN ->BIP(ITEM)
! BRICK IS A PHRASE TYPE
IF USE IMP=YES THEN START
IF COMPARE(ITEM)=0 THEN ->FAIL
FINISH ELSE START
*LSD_RA
*SLSQ_RP
*SLSQ_MARKER
*ST_TOS
*LB_ITEM
*JLK_<SUBENTRY>
*ST_B ; ! RESULT=0 FOR FAIL
*LSQ_TOS ; *ST_MARKER
*LSQ_TOS ; *ST_RP
*LSD_TOS ; *ST_RA
*JAT_12,<FAIL>
FINISH
->SUCC
LIT: ! BRICK IS LITERAL
IF USE IMP=YES THEN START
I=CC(Q); ! OBTAIN CURRENT CHARACTER
->FAIL UNLESS I=CLETT(ITEM+1)
Q=Q+1
K=CLETT(ITEM)+ITEM
ITEM=ITEM+2
WHILE ITEM<=K CYCLE
->FAIL UNLESS CC(Q)=CLETT(ITEM)
Q=Q+1
ITEM=ITEM+1
REPEAT ; ! CHECK IT WITH LITERAL DICT ENTRY
FINISH ELSE START
*LDB_(CLETT+B )
*INCA_B
*INCA_1
*LSS_Q
*IAD_CC+4
*LUH_CC
*CPS_L =DR ,0,0
*JCC_7,<FAIL>
*STUH_B
*ISB_CC+4
*ST_Q
FINISH
->SUCC; ! MATCHED SUCCESSFULLY
FAIL: ! FAILURE - NOTE POSITION REACHD
IF USE IMP=YES THEN START
IF RA=RP THEN ->TFAIL; ! TOTAL FAILURE NO ALT TO TRY
QMAX=Q IF Q>QMAX
Q=RQ; ! RESET LINE AND A.R. POINTERS
R=RR+1; ! AVOID GOING VIA UPR:
STRLINK=SSL
ALT=ALT+1; ! MOVE TO NEXT ALT OF PHRASE
RS=RA
RA=SYMBOL(RA)
FINISH ELSE START
*LB_RA
*CPB_RP
*JCC_8,<TFAIL>
*LSS_Q
*ICP_QMAX
*JCC_12,<CPL1>
*ST_QMAX
CPL1: *LSD_RQ
*IAD_1
*ST_Q
*L_SSL
*STUH_STRLINK
*IAD_1
*ST_ALT
*STB_RS
*L_(ASYM0+B )
*ST_RA
FINISH
->SUCC
TFAIL:
LEVEL=RL
IF USE IMP=YES THEN START
RESULT =0
FINISH ELSE START
*LSS_0; *J_TOS
FINISH
BIP(999): ! REPEATED PHRASE
A(RR)=ALT; P=PP
->COMM
BIP(1000):FINI: ! NULL ALWAYS LAST & OK
A(RR)=ALT
IF USE IMP=YES THEN START
RESULT =1
FINISH ELSE START
*LSS_1; *J_TOS
FINISH
BIP(1001): ! PHRASE NAME
I=CC(Q); ! OBTAIN CURRENT CHARACTER
->FAIL UNLESS TRTAB(I)=2
PNAME(ITEM-1004)
->SUCC IF HIT=1; ->FAIL
BIP(1002): ! PHRASE INTEGER CONSTANT
BIP(1003): ! PHRASE CONST
CONST(ITEM-1003)
->FAIL IF HIT=0
->SUCC
BIP(1004): ! PHRASE CHECK EXTENDEDTYPE
! FIRST LETTER IS (B,H,I,L,R,S)
! 3RD LETTER (A,L,N,R,T,C)
I=CC(Q)
->FAIL UNLESS I>128 AND X'80000000'>>(I&31)&X'20C83000'#0C
AND X'80000000'>>(CC(Q+2)&31)&X'500B2800'#0
->SUCC
BIP(1005): ! PHRASE N
I=CC(Q); ! OBTAIN CURRENT CHARACTER
->FAIL UNLESS '0'<=I<='9'
S=0
WHILE '0'<=I<='9' CYCLE
S=10*S+I&15
Q=Q+1; I=CC(Q)
REPEAT
TOAR2(R,S)
R=R+2; ->SUCC
BIP(1006): ! PHRASE S=SEPARATOR
I=CC(Q); ! OBTAIN CURRENT CHARACTER
->SUCC IF I=NL
->FAIL UNLESS I=';'
Q=Q+1; ->SUCC
BIP(1007):
! PHRASE COMMENT TEXT
I=CC(Q); ! OBTAIN CURRENT CHARACTER
->FAIL UNLESS I='!' OR I='|' OR (I='C'+128 AND CC(Q+1)=C
'O'+128 AND CC(Q+2)=CC(Q+3)='M'+128 AND CC(Q+4)='E'+128 C
AND CC(Q+5)='N'+128 AND CC(Q+6)='T'+128)
Q=Q+1+6*(I>>7); J=CC(Q)
CYCLE
EXIT IF J=NL
WARN(6,0) IF J=';' AND CC(Q+1)#'!'
Q=Q+1; J=CC(Q)
REPEAT
->SUCC
BIP(1008): ! PHRASE BIGHOLE
TO AR4(R,0)
R=R+4; ->SUCC
BIP(1009): ! PHRASE N255
I=CC(Q); ! OBTAIN CURRENT CHARACTER
->FAIL UNLESS '0'<=I<='9'
S=0
WHILE '0'<=I<='9' CYCLE
S=10*S+I&15
Q=Q+1; I=CC(Q)
REPEAT
->FAIL UNLESS 0<=S<=255
A(R)=S; ->UPR
BIP(1010): ! PHRASE HOLE
MARKER=R; R=R+2; ->SUCC
BIP(1011): ! PHRASE MARK
I=R-MARKER
A(MARKER+1)<-I
A(MARKER)<-I>>8
->SUCC
BIP(1012): ! PHRASE READLINE?
I=CC(Q); ! OBTAIN CURRENT CHARACTER
WHILE I=NL CYCLE
READLINE(0,0)
RQ=1
I=CC(Q)
REPEAT
FAULT(102, WKFILEK,0) IF R>ARSIZE
->SUCC
BIP(1013): ! PHRASE CHECKIMPS
R=R-4; ! AVOID HOLE LEFT BY TEXTTEXT
TEXTTEXT(0)
->FAIL IF HIT=0
->SUCC
BIP(1014): ! PHRASE DUMMY APP
A(R)=2; A(R+1)=2
R=R+2; ->SUCC
BIP(1015): ! PHRASE DOWN=NEW TEXT LEVEL
LEVEL=LEVEL+1
TO AR4(R,0)
DISPLAY(LEVEL)=R
SFS(LEVEL)=0
R=R+4
->SUCC
BIP(1016): ! PHRASE UP 1 TEXTUAL LEVEL
DISPLAY(LEVEL)=0
WHILE SFS(LEVEL)#0 CYCLE
POP(SFS(LEVEL),I,J,K)
IF I=1 THEN FAULT(53,K,0); ! FINISH MISSING
IF I=2 THEN FAULT(13,K,0); ! %REPEAT MISSING
REPEAT
LEVEL=LEVEL-1
->SUCC
BIP(1017): ! PHRASE LISTON
LIST=1; ->SUCC
BIP(1018): ! PHRASE LISTOFF
LIST=0; ->SUCC
BIP(1019): ! PHRASE COLON FOR LABEL
->FAIL UNLESS CC(Q-1)=':'
->SUCC
BIP(1020): ! PHRASE NOTE CONST
IF CTYPE=5 THEN TOAR4(S-4,STRLINK) AND STRLINK=S-4
->SUCC
BIP(1021): ! TRACE FOR ON CONDITIONS
PARMTRACE=1; ->SUCC
BIP(1022): ! SET MNEMONIC
I=CC(Q); ! OBTAIN CURRENT CHARACTER
S=M' '
WHILE 'A'<=I<='Z' CYCLE
S=S<<8!I; Q=Q+1; I=CC(Q)
REPEAT
->FAIL UNLESS I='_' AND S#M' '
Q=Q+1; ->SUCC
BIP(1023): ! PRIMARY FORMAT MNEMOINC
CYCLE I=7,1,126
->PFND IF OPC(I)=S
REPEAT
->FAIL
PFND:
->FAIL IF 8<=I>>3<=11 AND I&7<=3
A(R)=2*I; ->UPR
BIP(1024): ! SECONDARY FORMAT MNEMONIC
CYCLE I=64,8,88
CYCLE J=0,1,3
->SFND IF OPC(I+J)=S
REPEAT
REPEAT
->FAIL
SFND: A(R)=2*(I+J); ->UPR
BIP(1025): ! TERTIARY FORMAT MNEMONIC
CYCLE I=3,-1,1
IF OPC(I)=S THEN A(R)=2*I AND ->UPR
REPEAT ; ->FAIL
BIP(1031): ! UCWRONG ERRORS AND OTHER M-CS
I=CC(Q)
CYCLE
Q=Q+1
EXIT IF I=NL OR I=';'
I=CC(Q)
REPEAT
->SUCC
BIP(1026): ! P(OP)=+,-,&,****,**,*,!!,!,
! //,/,>>,<<,.,¬¬,¬;
I=CC(Q); ! OBTAIN CURRENT CHARACTER
->FAIL UNLESS 32<I<127 AND C
X'80000000'>>((I-32)&31)&X'4237000A'#0
Q=Q+1
IF I='+' THEN A(R)=1 AND ->UPR
IF I='-' THEN A(R)=2 AND ->UPR
IF I='&' THEN A(R)=3 AND ->UPR
J=CC(Q)
IF I='*' THEN START
IF J#I THEN A(R)=6 AND ->UPR
IF CC(Q+1)=I=CC(Q+2) THEN A(R)=4 AND Q=Q+3 AND ->UPR
A(R)=5; Q=Q+1; ->UPR
FINISH
IF I='/' THEN START
IF J#I THEN A(R)=10 AND ->UPR
A(R)=9; Q=Q+1; ->UPR
FINISH
IF I='!' THEN START
IF J#I THEN A(R)=8 AND ->UPR
A(R)=7; Q=Q+1; ->UPR
FINISH
IF I='.' THEN A(R)=13 AND ->UPR
IF I=J='<' THEN A(R)=12 AND Q=Q+1 AND ->UPR
IF I=J='>' THEN A(R)=11 AND Q=Q+1 AND ->UPR
IF I='¬' THEN START
IF J#I THEN A(R)=15 AND ->UPR
Q=Q+1; A(R)=14; ->UPR
FINISH
->FAIL
BIP(1027): ! PHRASE CHECK UI
I=CC(Q); ! OBTAIN CURRENT CHARACTER
->SUCC IF TRTAB(I)=2 OR I='-'
->SUCC IF X'80000000'>>(I&31)&X'14043000'#0
->FAIL
BIP(1028): ! P(+')=+,-,¬,0
I=CC(Q); ! OBTAIN CURRENT CHARACTER
IF I='¬' OR I=X'7E' THEN A(R)=3 AND Q=Q+1 AND ->UPR
IF I='-' THEN A(R)=2 AND Q=Q+1 AND ->UPR
IF I='+' THEN A(R)=1 AND Q=Q+1 AND ->UPR
A(R)=4; ->UPR
BIP(1029): ! PHRASE NOTE CYCLE
TOAR4(R,0)
PUSH(SFS(LEVEL),2,R,LINE)
R=R+4
->SUCC
BIP(1030): ! P(,')=',',0
!
! THIS IS VERY AWKWARD AS IT MEANS IT IS VERY TO HARD TO FIND
! THE END OF A PARAMETER LIST WITHOUT CHURNING. BY MAKING THIS A BIP
! WE CAN PEEP AHEAD FOR ')' AND FAIL HERE.
!
I=CC(Q); ! OBTAIN CURRENT CHARACTER
IF I=')' THEN ->FAIL
IF I=',' THEN Q=Q+1
->SUCC
BIP(1032): ! PHRASE COMP1
BIP(1037): ! PHRASE COMP2(IS 2ND HALF OF DSIDED)
I=CC(Q); ! OBTAIN CURRENT CHARACTER
->FAIL UNLESS 32<I<=92 AND C
X'80000000'>>(I&31)&X'1004000E'#0
! '='=1,'>='=2,'>'=3
! '#' OR '¬=' OR '<>'=4
! '<='=5,'<'=6
! 7UNUSED,'->'=8,'=='=9
! '##' OR '¬==' =10
IF I='=' THEN START
IF CC(Q+1)=I THEN J=9 AND ->JOIN1
J=1; ->JOIN
FINISH
IF I='#' THEN START
IF CC(Q+1)=I THEN J=10 AND ->JOIN1
J=4; ->JOIN
FINISH
IF I='¬' AND CC(Q+1)='=' THEN START
Q=Q+1
IF CC(Q+1)='=' THEN J=10 AND ->JOIN1
J=4; ->JOIN
FINISH
IF I='>' THEN START
IF CC(Q+1)='=' THEN J=2 AND ->JOIN1
J=3; ->JOIN
FINISH
IF I='<' THEN START
IF CC(Q+1)='>' THEN J=4 AND ->JOIN1
IF CC(Q+1)='=' THEN J=5 AND ->JOIN1
J=6; ->JOIN
FINISH
IF I='-' AND CC(Q+1)='>' THEN J=8 AND ->JOIN1
->FAIL
JOIN1:Q=Q+1
JOIN: Q=Q+1
A(R)=J
IF ITEM=1032 THEN SAVECOMP=J AND ->UPR
! SAVE J TO CHECK DSIDED
IF SAVECOMP>6 OR J>6 THEN Q=Q-1 AND ->FAIL;! ILLEGAL DSIDED
->UPR; ! NB OWNS WONT WORK IF
! COND EXPRS ALLOWED AS THE
! CAN BE NESTED!
BIP(1033): ! P(ASSOP)- ==,=,<-,->
I=CC(Q); ! OBTAIN CURRENT CHARACTER
IF I='=' THEN START
IF CC(Q+1)='=' THEN A(R)=1 AND Q=Q+2 AND ->UPR
A(R)=2; Q=Q+1; ->UPR
FINISH
IF I='<' AND CC(Q+1)='-' THEN A(R)=3 AND Q=Q+2 AND ->UPR
IF I='-' AND CC(Q+1)='>' THEN A(R)=4 AND Q=Q+2 AND ->UPR
->FAIL
BIP(1034): ! NOTE START
TOAR4(R,0); ! HOLE FOR FORWARD PTR
PUSH(SFS(LEVEL),1,R,LINE)
R=R+4
->SUCC
BIP(1035): ! NOTE FINISH
IF SFS(LEVEL)=0 THEN FAULT(51,0,0) AND ->SUCC
POP(SFS(LEVEL),I,J,K)
IF I=2 THEN FAULT(59,K,0)
TOAR4(J,STARSTART)
->SUCC
BIP(1036): ! NOTE REPEAT
IF SFS(LEVEL)=0 THEN FAULT(1,0,0) AND ->SUCC
POP(SFS(LEVEL),I,J,K)
IF I=1 THEN FAULT(52,K,0); ! START INSTEAD OF CYCLE
TOAR4(J,STARSTART)
->SUCC
BIP(1038): ! INCLUDE "FILE"
IF VMEB=NO THEN START
->FAIL IF IDEPTH>10
I=CC(Q)
->FAIL UNLESS I=NL OR I=';'
Q=Q+1 IF I=';'
->FAIL UNLESS CTYPE=5
IDEPTH=IDEPTH+1
PUSH(IHEAD,FILEADDR,FILEPTR,FILEEND)
CONSOURCE(STRING(ADDR(A(S))),FILEADDR);! DEPARTS IF FAILS
FILEPTR=FILEADDR+INTEGER(FILEADDR+4)
FILEEND=FILEADDR+INTEGER(FILEADDR)
->SUCC
FINISH ELSE ->FAIL
BIP(1039): ! DUMMYSTART GIVE SAME AR AS ELSE START
A(R)=1; A(R+1)=1; ! ALT 1 OF ELSE ALT 1 OF AFTER ELSE
R=R+2; ->SUCC
END ; !OF ROUTINE 'COMPARE'
ROUTINE PNAME(INTEGER MODE)
!***********************************************************************
!* MODE=0 FOR OLD NAME(ALREADY IN DICT), MODE=1 FOR NEW NAME *
!***********************************************************************
CONSTINTEGERARRAY HASH(0:7)=71,47,97,79,29,37,53,59;
INTEGER JJ, KK, LL, FQ, FS, T, S, I
LONGINTEGER DRDES,ACCDES
HIT=0; FQ=Q; FS=CC(Q)
RETURN UNLESS TRTAB(FS)=2 AND M'"'#CC(Q+1)#M''''
! 1ST CHAR MUST BE LETTER
T=1
LETT(NEXT+1)=FS; JJ=71*FS
IF USE IMP=YES THEN START
CYCLE
Q=Q+1
I=CC(Q)
EXIT IF TRTAB(I)=0
JJ=JJ+HASH(T) IF T<=7
T=T+1
LETT(NEXT+T)=I
REPEAT
FINISH ELSE START
CYC:
*LB_Q
*ADB_1
*STB_Q
*LB_(CC+B )
*LSS_(TRTAB+B )
*JAT_4,<EXIT>
*STB_I
*LSS_B ; ! I TO ACC
*LB_T
*CPB_7
*JCC_2,<SKIP>
*IMY_(HASH+B )
*IAD_JJ
*ST_JJ
SKIP:
*ADB_1
*STB_T
*LSS_I
*ADB_NEXT
*ST_(LETT+B )
*J_<CYC>
EXIT:
FINISH
LETT(NEXT)=T; ! INSERT LENGTH
S=T+1
FAULT(103,0,0) IF NEXT+S>DSIZE; !DICTIONARY OVERFLOW
JJ=(JJ+113*T)&NNAMES
IF USE IMP=YES THEN START
CYCLE KK=JJ, 1, NNAMES
LL=WORD(KK)
->HOLE IF LL=0; ! NAME NOT KNOWN
->FND IF STRING(ADDR(LETT(NEXT)))=STRING(ADDR(LETT(LL)))
REPEAT
CYCLE KK=0,1,JJ
LL=WORD(KK)
->HOLE IF LL=0; ! NAME NOT KNOWN
->FND IF STRING(ADDR(LETT(NEXT)))=STRING(ADDR(LETT(LL)))
REPEAT
FINISH ELSE START
*LDTB_X'18000000'
*LDB_S
*LDA_LETT+4
*STD_DRDES
*INCA_NEXT
*STD_ACCDES
*LB_JJ
CYC1:
*STB_KK
*LB_(WORD+B )
*JAT_12,<HOLE>
*LSD_ACCDES
*LD_DRDES
*INCA_B
*CPS_L =DR
*JCC_8,<FND>
*LB_KK
*CPIB_NNAMES
*JCC_7,<CYC1>
*LB_0
CYC2:
*STB_KK
*LB_(WORD+B )
*JAT_12,<HOLE>
*LSD_ACCDES
*LD_DRDES
*INCA_B
*CPS_L =DR
*JCC_8,<FND>
*LB_KK
*CPIB_JJ
*JCC_7,<CYC2>
FINISH
FAULT(104, 0, 0); ! TOO MANY NAMES
HOLE: IF MODE=0 THEN Q=FQ AND RETURN
WORD(KK)=NEXT; NEXT=NEXT+S
FND: LASTAT=FQ; HIT=1; LASTNAME=KK
A(R+1)<-LASTNAME
A(R)=LASTNAME>>8; R=R+2
LASTEND=Q
END
ROUTINE CONST(INTEGER MODE)
!***********************************************************************
!* SYNTAX CHECK AND EVALUATE ALL THE FORMS OF IMP CONSTANT *
!* MODE=0 FOR INTEGER CONSTANTS #0 FOR ANY SORT OF CONSTANT *
!***********************************************************************
INTEGER Z, DOTSEEN, EBCDIC, FS, CPREC, RR, S, T, SS
LONGLONGREAL X,CVALUE,DUMMY
LONGINTEGER RADIXV
CONSTLONGLONGREAL TEN=R'41A00000000000000000000000000000'
ON EVENT 1,2 START
RETURN
FINISH
CPREC=5; RR=R; R=R+1
DOTSEEN=0; HIT=0
CVALUE=0; DUMMY=0; X=0; FS=CC(Q)
S=0; ->N IF M'0'<=FS<=M'9'
->DOT IF FS='.' AND MODE=0 AND '0'<=CC(Q+1)<='9'
! 1 DIDT MIN
CTYPE=1; EBCDIC=0
->QUOTE IF FS=M''''
->STR2 IF FS=34
->NOTQUOTE UNLESS CC(Q+1)=M''''; Q=Q+2
->HEX IF FS='X'
->MULT IF FS='M'
->BIN IF FS=M'B'
->RHEX IF FS='R' AND MODE=0
->OCT IF FS='K'
IF FS='C' THEN EBCDIC=1 AND ->MULT
IF FS='D' AND MODE=0 THEN START
CPREC=7
IF M'0'<=CC(Q)<=M'9' THEN ->N
IF CC(Q)='.' THEN ->DOT
FINISH
Q=Q-2; RETURN
QUOTE: ! SINGLE CH BETWEEN QUOTES
S=CC(Q+1)
Q=Q+2
IF S=NL THEN READLINE(1,'''') AND Q=1
IF CC(Q)=M'''' THEN START
Q=Q+1
IF S#M'''' THEN ->IEND
IF CC(Q)=M'''' THEN Q=Q+1 AND ->IEND
FINISH
RETURN ; ! NOT VALID
NOTQUOTE: ! CHECK FOR E"...."
RETURN UNLESS FS='E' AND CC(Q+1)=M'"'
EBCDIC=1; Q=Q+1
STR2: ! DOUBLE QUOTED STRING
A(RR)=X'35'; TEXTTEXT(EBCDIC)
CTYPE=5; RETURN
HEX: T=0; ! HEX CONSTANTS
CYCLE
I=CC(Q); Q=Q+1
EXIT IF I=M''''
T=T+1
RETURN UNLESS C
('0'<=I<='9' OR 'A'<=I<='F' OR 'a'<=I<='f') AND T<17
IF T=9 THEN SS=S AND S=0
S=S<<4+I&15+9*I>>6
REPEAT
IF T>8 START
Z=4*(T-8)
S=S!(SS<<Z)
SS=SS>>(32-Z); CPREC=6
FINISH
IEND: IF CPREC=6 THEN TOAR4(R,SS) AND R=R+4
IF CPREC=5 AND 0<=S<=X'7FFF' START
CPREC=4; TOAR2(R,S); R=R+2
FINISH ELSE TOAR4(R,S) AND R=R+4
HIT=1 UNLESS MODE#0 AND CPREC=6
A(RR)=CPREC<<4!CTYPE
RETURN
RHEX: ! REAL HEX CONSTANTS
T=0
CYCLE
I=CC(Q); Q=Q+1
IF T&7=0 AND T#0 START
TOAR4(R,S); R=R+4; S=0
FINISH
EXIT IF I=M''''; T=T+1
RETURN UNLESS '0'<=I<='9' OR 'A'<=I<='F' OR 'a'<=I<='f'
S=S<<4+I&15+9*I>>6
REPEAT
RETURN UNLESS T=8 OR T=16 OR T=32
IF T=32 THEN CPREC=7 ELSE CPREC=4+T//8
A(RR)=CPREC<<4!2
HIT=1; RETURN
OCT: ! OCTAL CONSTANTS
T=0
CYCLE
I=CC(Q); Q=Q+1; T=T+1
EXIT IF I=M''''
RETURN UNLESS '0'<=I<='7' AND T<12
S=S<<3!(I&7)
REPEAT
->IEND
MULT: T=0; ! MULTIPLE CONSTANTS
RADIXV=0
CYCLE
I=CC(Q); Q=Q+1; T=T+1
IF I=M'''' THEN START
IF CC(Q)#M'''' THEN EXIT ELSE Q=Q+1
FINISH
RETURN IF T>=9
IF EBCDIC#0 THEN I=ITOETAB(I)
RADIXV=RADIXV<<8!I
REPEAT
SS<-RADIXV>>32
S<-RADIXV
IF SS # 0 THEN CPREC=6
->IEND
BIN: T=0; ! BINARY CONST
CYCLE
I=CC(Q); Q=Q+1; T=T+1
EXIT IF I=M''''
RETURN UNLESS '0'<=I<='1' AND T<33
S=S<<1!I&1
REPEAT
->IEND
RADIX: ! BASE_VALUE CONSTANTS
T=0; RADIXV=0
Q=Q+1
CYCLE
I=CC(Q)
EXIT UNLESS '0'<=I<='9' OR 'A'<=I<='Z'
IF I<='9' THEN I=I-'0' ELSE I=I-('A'-10)
EXIT IF I>=S; ! MUST BE LESS THAN BASE
T=T+1; Q=Q+1
RADIXV=RADIXV*S+I
REPEAT
RETURN IF T=0; ! NO VALID DIGIGITS
SS<-RADIXV>>32
S<-RADIXV
CTYPE=1
IF SS#0 THEN CPREC=6; ->IEND
N: ! CONSTANT STARTS WITH DIGIT
I=CC(Q)
UNTIL I<M'0' OR I>M'9' CYCLE
CVALUE=TEN*CVALUE+(I&15)
Q=Q+1; I=CC(Q); ! ONTO NEXT CHAR
REPEAT
IF I='_' AND CVALUE<33 THEN S=INT(CVALUE) AND ->RADIX
->ALPHA UNLESS MODE=0 AND I='.'
DOT: Q=Q+1; X=TEN; I=CC(Q)
DOTSEEN=1; ! CONSTANT HAS DECIMAL POINT
WHILE M'0'<=I<=M'9' CYCLE
CVALUE=CVALUE+(I&15)/X
X=TEN*X; Q=Q+1; I=CC(Q)
REPEAT
ALPHA: ! TEST FOR EXPONENT
IF MODE=0 AND CC(Q)='@' THEN START
Q=Q+1; X=CVALUE
Z=1; I=CC(Q)
IF I='-' THEN Z=-1
IF I='+' OR I='-' THEN Q=Q+1
CONST(2)
IF HIT=0 THEN RETURN
HIT=0
DOTSEEN=1; ! @ IMPLIES REAL IN IMP80
R=RR+1
IF A(R)>>4#4 THEN RETURN ; ! EXPONENT MUST BE HALFINTEGER
S=FROM AR2(R+1)*Z
IF S=-99 THEN CVALUE=0 ELSE START
IF USE IMP=NO THEN START
*MPSR_X'8080'; ! MASK OUT REAL OVERFLOW
FINISH
WHILE S>0 CYCLE
S=S-1
CVALUE=CVALUE*TEN
IF USE IMP=NO THEN START
*JAT_15,<FAIL>
FINISH
REPEAT
WHILE S<0 AND CVALUE#0 CYCLE
S=S+1
CVALUE=CVALUE/TEN
REPEAT
FINISH
FINISH
! SEE IF IT IS INTEGER
IF FS='D' THEN START
I=CC(Q)
IF I='''' THEN Q=Q+1 ELSE RETURN
DOTSEEN=1; ! ENSURE NOT TAKEN AS INTEGER
FINISH
IF DOTSEEN=1 OR CVALUE>IMAX THEN CTYPE=2 ELSE C
CTYPE=1 AND S=INT(CVALUE)
IF CTYPE=1 THEN ->IEND
IF CPREC=5 THEN CPREC=6; ! NO 32 BIT REAL CONSTS
IF CPREC=6 THEN START
IF USE IMP=NO THEN START ; ! SOFTWARE ROUND IN MC CODE ONLY
*LSD_CVALUE
*AND_X'FF00000000000000'
*SLSD_CVALUE+8
*AND_X'0080000000000000'
*LUH_TOS
*RAD_CVALUE
*ST_CVALUE
FINISH
FINISH
TOAR8(R,CVALUE); R=R+8
IF CPREC=7 THEN TOAR8(R,LONGREAL(ADDR(CVALUE)+8)) C
AND R=R+8
A(RR)=CPREC<<4+CTYPE
HIT=1
FAIL: END
ROUTINE TEXTTEXT(INTEGER EBCDIC)
!***********************************************************************
!* PROCESSES TEXT BETWEEN DOUBLE QUOTES AND STORES IN ISO OR EBCDIC *
!***********************************************************************
INTEGER J, II
CONSTINTEGER QU='"'
I=CC(Q)
S=R+4; R=R+5; HIT=0
RETURN UNLESS I=QU; ! FAIL UNLESS INITIAL QUOTE
Q=Q+1
CYCLE
I=CC(Q)
IF EBCDIC#0 THEN II=ITOETAB(I) ELSE II=I
A(R)=II; R=R+1
IF I=QU THEN START
Q=Q+1
IF CC(Q)#QU THEN EXIT
FINISH
IF I=10 THEN READLINE(1,QU) ELSE Q=Q+1
FAULT(106,0,0) IF R-S>256
REPEAT
R=R-1; J=R-S-1
A(S)=J; HIT=1
END
BEND:END ; ! OF BLOCK CONTAINING PASS 1
IF LEVEL>1 THEN FAULT(15, LEVEL-1, 0)
I=0
NEWLINE
IF FAULTY=0 THEN START
WRITE(LINE, 5)
PRINT STRING(" LINES ANALYSED IN")
WRITE(INT(1000*(CPUTIME-CTIME)),5)
PRINT STRING(" MSECS - SIZE=")
WRITE(P1SIZE, 5)
IF LINE>90 AND LIST#0 THEN NEWPAGE ELSE NEWLINE
FINISH ELSE START
PRINTSTRING("CODE GENERATION NOT ATTEMPTED
")
COMREG(24)=8
COMREG(47)=FAULTY
STOP
FINISH
BEGIN
!***********************************************************************
!* SECOND OR CODE GENERATING PASS *
!***********************************************************************
INTEGERARRAY REGISTER, GRUSE, GRAT, GRINF1, GRINF2, OLINK(0:7)
BYTEINTEGERARRAY CODE, GLABUF(0:268)
INTEGERARRAY PLABS, DESADS, PLINK(0:31)
INTEGERARRAY SET, STACKBASE, RAL, FLAG, L, M, NMDECS, ONWORD, ONINF,C
JUMP, LABEL, JROUND, DIAGINF, DISPLAY, UNATT FORMATS, C
AUXSBASE, NAMES (0:MAXLEVELS)
INTEGERARRAY AVL WSP(0:4,0:MAXLEVELS)
INTEGERARRAYFORMAT CF(0:12*NNAMES)
INTEGERARRAYNAME CTABLE
ROUTINESPEC CNOP(INTEGER I, J)
ROUTINESPEC PCONST(INTEGER X)
ROUTINESPEC PSF1(INTEGER OPCODE,K,N)
ROUTINESPEC PF1(INTEGER OPCODE,KP,KPP,N)
ROUTINESPEC PSORLF1(INTEGER OPCODE,KP,KPP,N)
ROUTINESPEC PF2(INTEGER OPCODE,H,Q,N,MASK,FILLER)
ROUTINESPEC PF3(INTEGER OPCODE,MASK,KPPP,N)
ROUTINESPEC NOTE CREF(INTEGER CA)
INTEGERFNSPEC PARAM DES(INTEGER PREC)
INTEGERFNSPEC MAPDES(INTEGER PREC)
INTEGERFNSPEC SPECIAL CONSTS(INTEGER WHICH)
ROUTINESPEC STORE CONST(INTEGERNAME D,INTEGER L,AD)
INTEGERFNSPEC WORD CONST(INTEGER VALUE)
ROUTINESPEC DUMP CONSTS
ROUTINESPEC PLANT(INTEGER VALUE)
ROUTINESPEC PLUG(INTEGER I, J, K, BYTES)
ROUTINESPEC CODEOUT
ROUTINESPEC PROLOGUE
ROUTINESPEC EPILOGUE
ROUTINESPEC COMPILE A STMNT
ROUTINESPEC CSS(INTEGER P)
ROUTINESPEC LOAD DATA
ROUTINESPEC ABORT
!*DELSTART
ROUTINESPEC PRINT USE
!*DELEND
CYCLE I=0,1,7
REGISTER(I)=0; GRUSE(I)=0; GRINF1(I)=0; GRAT(I)=0
GRINF2(I)=0
REPEAT
CYCLE I=0, 1, MAXLEVELS
SET(I)=0; STACKBASE(I)=0; RAL(I)=0
JUMP(I)=0; JROUND(I)=0
LABEL(I)=0; FLAG(I)=0; UNATT FORMATS(I)=0
L(I)=0; M(I)=0; DIAGINF(I)=0
DISPLAY(I)=0; ONWORD(I)=0; ONINF(I)=0
NAMES(I)=-1
CYCLE J=0,1,4
AVL WSP(J,I)=0
REPEAT
REPEAT
CTABLE==ARRAY(ADDR(ASLIST(1)),CF)
CONST HOLE=0
PROLOGUE
LINE=0
NEXTP=1; LEVEL=1; STMTS=0
RLEVEL=0; RBASE=0
WHILE A(NEXTP+3)!A(NEXTP+4)#0 CYCLE
COMPILE A STMNT
REPEAT
LINE=99999
EPILOGUE
LOAD DATA
STOP
ROUTINE COMPILE A STMNT
INTEGER I
!*DELSTART
IF DCOMP#0 AND CA>CABUF THEN CODEOUT AND PRINTUSE
!*DELEND
I=NEXTP
NEXTP=NEXTP+A(NEXTP)<<16+A(NEXTP+1)<<8+A(NEXTP+2)
LINE=A(I+3)<<8+A(I+4)
STMTS=STMTS+1
CSS(I+5)
! CHECK ASL %IF LINE&7=0
END
ROUTINE LOAD DATA
!***********************************************************************
!* PASS INFORMATION TO LPUT TO ENABLE IT TO GENERATE THE *
!* LOADER DATA AND COMPLETE THE PROGRAM FILE. *
!***********************************************************************
INTEGER LANGFLAG,PARMS
GLACA=(GLACA+7)&(-8)
USTPTR=(USTPTR+7)&(-8)
CODE OUT
CNOP(0, 8)
DUMP CONSTS
IF PARMTRACE=0 THEN LANGFLAG=6 ELSE LANGFLAG=1
LANGFLAG=LANGFLAG<<24
PARMS=(PARMDIAG<<1!PARMLINE)<<1!PARMTRACE
FIXED GLA(4)=LANGFLAG!RELEASE<<16!(CPRMODE&1)<<8!PARMS;! LANG RLSE & MAINPROG
I=GLACA-GLACABUF
IF INHCODE=0 THEN START
LPUT(2, I, GLACABUF, ADDR(GLABUF(0))) UNLESS I=0
! BACK OF GLAP
LPUT(2, FIXEDGLALEN, 0, ADDR(FIXED GLA(0)));! FRONT OF GLAP
LPUT(19,2,8,5); ! RELOCATE GLA ST ADDRESS
LPUT(19,2,12,4); ! RELOCATE CODE ST ADDRESS
LPUT(19,2,24,1); ! RELOCATE CODEHEAD ADDR FOR SWITCHES
I=X'E2E2E2E2'
LPUT(4, 4, SSTL, ADDR(I))
!
FINISH
SSTL=(SSTL+11)&(-8)
PRINTSTRING("
CODE")
WRITE(CA, 6); PRINTSTRING(" BYTES GLAP")
WRITE(GLACA, 3); PRINTSTRING("+")
WRITE(USTPTR, 1); PRINTSTRING(" BYTES DIAG TABLES")
WRITE(SSTL, 3); PRINTSTRING(" BYTES
TOTAL")
REGISTER(0)=CA; REGISTER(1)=GLACA
REGISTER(2)=0
REGISTER(3)=SSTL
REGISTER(4)=USTPTR
K=CA+GLACA+SSTL+USTPTR; REGISTER(5)=K
WRITE(K, 5); PRINTSTRING(" BYTES")
NEWLINE; PRINT CH(13); ! MARKER FOR COMP TO PRINT
!SUMMARY
IF FAULTY=0 THEN START
WRITE(STMTS, 7); PRINTSTRING(" STATEMENTS COMPILED IN")
WRITE(INT(1000*(CPUTIME-CTIME)),5)
PRINTSTRING(" MSECS")
COMREG(47)=STMTS; ! NO OF STMTS FOR COMPER
FINISH ELSE START
PRINTSTRING("PROGRAM CONTAINS"); WRITE(FAULTY, 2)
PRINTSTRING(" FAULT"); PRINTSYMBOL('S') IF FAULTY>1
COMREG(47)=FAULTY; ! NO OF FAULTS FOR COMPER
FINISH
NEWLINES(2)
NEWLINE
I=0; I=8 IF FAULTY#0
COMREG(24)=I
IF INHCODE=0 THEN LPUT(7, 24, 0, ADDR(REGISTER(0)))
! SUMMARY INFO..REGISTER AS BUF
PPROFILE
STOP
END
!
!***********************************************************************
!* IMP CODE PLANTING ROUTINES *
!* CODE AND GLAP ARE PUT INTO THE BUFFERS 'CODE,GLABUF(0:268)' *
!* BY A NUMBER OF TRIVIAL ROUTINES.LPUT IS CALLED TO ADD THE *
!* BUFFER TO THE OUTPUT FILE. THE BUFFERS ARE BASICALLY 0:255 *
!* WITH A 12-BYTE MARGIN TO MINIMISE THE NUMBER OF TESTS FOR *
!* THE BUFFER FULL CONDITION *
!* *
!* PPCURR(GLACURR) IS THE BUFFER POINTER *
!* CA(GLACA) IS THE RELATIVE ADDRESS OF THE NEXT BYTE *
!* CABUF(GLACABUF) IS CA(GLACA) FOR START OF BUFFER *
!***********************************************************************
!*DELSTART
ROUTINE RECODE(INTEGER S,F,AD)
IF S#F START
PRINTSTRING("
CODE FOR LINE"); WRITE(LINE,5)
NCODE(S,F,AD)
FINISH
END
!*DELEND
ROUTINE CODEOUT
IF PPCURR>0 THEN START
!*DELSTART
RECODE(ADDR(CODE(0)), ADDR(CODE(PPCURR)), CABUF) C
IF DCOMP#0
!*DELEND
LPUT(1, PPCURR, CABUF, ADDR(CODE(0))) IF INHCODE=0
PPCURR=0; CABUF=CA
FINISH
END
ROUTINE PLANT(INTEGER HALFWORD)
!***********************************************************************
!* ADD A HALF WORD OF BINARY TO THE BUFFER *
!***********************************************************************
IF USE IMP=YES THEN START
CODE(PPCURR)<-HALFWORD>>8
CODE(PPCURR+1)<-HALFWORD
PPCURR=PPCURR+2
FINISH ELSE START
*LDA_CODE+4
*LDTB_X'58000002'
*LB_PPCURR
*LSS_HALFWORD
*ST_(DR +B )
*ADB_2
*STB_PPCURR
FINISH
CA=CA+2
CODEOUT IF PPCURR>=256
END
ROUTINE PCONST(INTEGER WORD)
!***********************************************************************
!* ADD A WORD OF BINARY TO THE BUFFER *
!***********************************************************************
IF USE IMP=YES THEN START
INTEGER I
CYCLE I=24,-8,0
CODE(PPCURR)=WORD>>I&255
PPCURR=PPCURR+1
REPEAT
FINISH ELSE START
*LDA_CODE+4
*LDTB_X'58000004'
*LSS_WORD
*LB_PPCURR
*ST_(DR +B )
*ADB_4
*STB_PPCURR
FINISH
CA=CA+4
CODE OUT IF PPCURR>=256
END
ROUTINE PSF1(INTEGER OPCODE,K,N)
!***********************************************************************
!* PLANT THE HALFWORD FORMS OF PRIMARY FORMAT NR INSTRNS *
!* IF N IS TOO LARGE FOR THE SHORT FORM PF1 IS CALLED TO PLANT *
!* THE CORRESPONDING LONG FORM *
!***********************************************************************
INTEGER KPP
! ABORT %UNLESS 0<=K<=2 %AND OPCODE&1=0
IF (K=0 AND -64<=N<=63) OR (K#0 AND 0<=N<=511) START
IF K#0 THEN N=N//4
IF USE IMP=YES THEN START
CODE(PPCURR)=OPCODE!K>>1
CODE(PPCURR+1)=(K&1)<<7!N&127
PPCURR=PPCURR+2
FINISH ELSE START
*LSS_OPCODE
*USH_1
*OR_K
*USH_7
*SLSS_N
*AND_127
*LB_PPCURR
*OR_TOS
*LDA_CODE+4
*LDTB_X'58000002'
*ST_(DR +B )
*ADB_2
*STB_PPCURR
FINISH
CA=CA+2
CODEOUT IF PPCURR>=256
FINISH ELSE START
IF K=0 THEN KPP=0 ELSE KPP=2
PF1(OPCODE,K>>1<<1,KPP,N)
FINISH
END
ROUTINE PF1(INTEGER OPCODE,KP,KPP,N)
!***********************************************************************
!* PLANT THE NORMAL FORMS OF PRIMARY FORMAT INSTRNS(IE THOSE *
!* WHICH DO NOT DEPEND ON THE SIZE OF N) *
!***********************************************************************
INTEGER INC
! ABORT %UNLESS 0<=KP<=3 %AND 0<=KPP<=7 %AND OPCODE&1=0
INC=2
IF KPP=PC THEN START
IF N<0 THEN N=N&X'7FFFFFFF' AND NOTE CREF(CA)
N=(N-CA)//2
FINISH
IF (1<<KPP)&B'101100'#0 THEN N=N//4
IF USE IMP=YES THEN START
CODE(PPCURR)=OPCODE!1
CODE(PPCURR+1)=X'80'!KP<<5!KPP<<2!(N>>16&3)
CODE(PPCURR+2)=N>>8&255
CODE(PPCURR+3)=N&255
FINISH ELSE START
*LSS_OPCODE
*USH_1
*OR_3
*USH_2
*OR_KP
*USH_3
*OR_KPP
*USH_18
*SLSS_N
*AND_X'3FFFF'
*OR_TOS
*LDTB_X'58000004'
*LDA_CODE+4
*LB_PPCURR
*ST_(DR +B )
FINISH
IF KPP<=5 THEN INC=4
PPCURR=PPCURR+INC
CA=CA+INC
CODEOUT IF PPCURR>=256
END
ROUTINE PSORLF1(INTEGER OPCODE,KP,KPP,N)
!***********************************************************************
!* AS PF1 BUT CUT VALID FORMS TO SHORT FORM *
!***********************************************************************
INTEGER INC
INC=2
IF (KPP=0=KP AND -64<=N<=63) OR C
(KPP=LNB AND KP&1=0 AND 0<=N<=511) START
IF KPP=LNB THEN KP=1+KP>>1
IF KP#0 THEN N=N//4
IF USE IMP=YES THEN START
CODE(PPCURR)=OPCODE!KP>>1
CODE(PPCURR+1)=(KP&1)<<7!(N&127)
FINISH ELSE START
*LSS_OPCODE
*USH_1
*OR_KP
*USH_7
*SLSS_N
*AND_127
*LB_PPCURR
*OR_TOS
*LDA_CODE+4
*LDTB_X'58000002'
*ST_(DR +B )
FINISH
FINISH ELSE START
IF KPP=PC THEN START
IF N<0 THEN N=N&X'7FFFFFFF' AND NOTE CREF(CA)
N=(N-CA)//2
FINISH
IF (1<<KPP)&B'101100'#0 THEN N=N//4
IF USE IMP=YES THEN START
CODE(PPCURR)=OPCODE!1
CODE(PPCURR+1)=((4!KP)<<3!KPP)<<2!(N>>16&3)
CODE(PPCURR+2)=N>>8&255
CODE(PPCURR+3)=N&255
FINISH ELSE START
*LSS_OPCODE
*USH_1
*OR_3
*USH_2
*OR_KP
*USH_3
*OR_KPP
*USH_18
*SLSS_N
*AND_X'3FFFF'
*OR_TOS
*LDTB_X'58000004'
*LDA_CODE+4
*LB_PPCURR
*ST_(DR +B )
FINISH
IF KPP<=5 THEN INC=4
FINISH
CA=CA+INC; PPCURR=PPCURR+INC
CODEOUT IF PPCURR>=256
END
ROUTINE PF2(INTEGER OPCODE,H,Q,N,MASK,FILLER)
!***********************************************************************
!* PLANT SECONDARY(STORE TO STORE) FORMAT INSTRNS *
!* THESE MAY BE 16 OR 32 BIT DEPENDING ON Q *
!***********************************************************************
! ABORT %UNLESS 0<=H<=1 %AND 0<=Q<=1 %AND 0<=N<=127 %C
AND OPCODE&1=0
PLANT(OPCODE<<8!H<<8!Q<<7!N)
IF Q#0 THEN PLANT(MASK<<8!FILLER)
END
ROUTINE PF3(INTEGER OPCODE,MASK,KPPP,N)
!***********************************************************************
!* PLANT THE TERTIARY(JUMP) FORMAT INSTRUCTIONS *
!***********************************************************************
! ABORT %UNLESS 0<=MASK<=15 %AND 0<=KPPP<=7 %AND OPCODE&1=0
IF KPPP=PC THEN START
IF N<0 THEN N=N&X'7FFFFFFF' AND NOTE CREF(CA)
N=(N-CA)//2
FINISH
CODE(PPCURR)=OPCODE!MASK>>3&1
CODE(PPCURR+1)=(MASK&7)<<5!KPPP<<2!(N>>16&3)
PPCURR=PPCURR+2
CA=CA+2
IF KPPP<=5 THEN START
CODE(PPCURR)=N>>8&255
CODE(PPCURR+1)=N&255
PPCURR=PPCURR+2; CA=CA+2
FINISH
CODEOUT IF PPCURR>=256
END
ROUTINE NOTE CREF(INTEGER CA)
!***********************************************************************
!* NOTE THAT A (PC+N) INSTRUCTION HAS N RELATIVE TO CONST TABLE *
!* NOT REATIVE TO CODE. REMEMBER THE ADDRESS OF THE INSTRUCTION *
!* SO THAT AN LPUT(18) CORRECTION CAN BE MADE AT END OF COMPILATION *
!***********************************************************************
RECORD (LISTF)NAME CELL
CELL==ASLIST(CREFHEAD)
IF CREFHEAD=0 OR CELL_S3#0 THEN C
PUSH(CREFHEAD,CA,0,0) AND RETURN
IF CELL_S2=0 THEN CELL_S2=CA ELSE CELL_S3=CA
END
ROUTINE CNOP(INTEGER I, J)
PSF1(JUNC,0,1) WHILE CA&(J-1)#I
END
ROUTINE PGLA(INTEGER BDRY, L, INF ADR)
INTEGER I, J
J=GLACA; GLACA=(J+BDRY-1)&(-BDRY)
GLACURR=GLACURR+GLACA-J; ! COMPLETE THE ROUNDING
IF L+GLACURR>256 THEN START
IF INHCODE=0 C
THEN LPUT(2, GLACURR, GLACABUF, ADDR(GLABUF(0)))
GLACURR=0; GLACABUF=GLACA
FINISH
CYCLE I=0,1,L-1
GLABUF(GLACURR+I)=BYTE INTEGER(I+INF ADR)
REPEAT
GLACA=GLACA+L; GLACURR=GLACURR+L
END
ROUTINE PLUG(INTEGER AREA, AT, VALUE, BYTES)
!***********************************************************************
!* WRITE UP TO ONE WORD INTO OBJECT FILE OUT OF SEQUENCE *
!***********************************************************************
INTEGERNAME WCABUF
INTEGER I, RELAD, BUFAD
WCABUF==CABUF; BUFAD=ADDR(CODE(0))
IF AREA=2 THEN WCABUF==GLACABUF AND BUFAD=ADDR(GLABUF(0))
RELAD=AT-WCABUF
IF 0<=RELAD<=256 AND AREA<=3 THEN START
CYCLE I=0,1,BYTES-1
BYTEINTEGER(RELAD+BUFAD+I)<-VALUE>>((BYTES-1-I)<<3)
REPEAT
FINISH ELSE START
IF RELAD=-2 THEN CODEOUT
IF INHCODE=0 THEN LPUT(AREA,BYTES,AT,ADDR(VALUE)+4-BYTES)
!*DELSTART
NCODE(ADDR(VALUE)+4-BYTES,ADDR(VALUE)+4,AT) IF DCOMP=1=AREA
!*DELEND
FINISH
END
INTEGERFN PARAM DES(INTEGER PREC)
!***********************************************************************
!* SET UP BNDED L=1 DESRIPTOR FOR PASSING VARIABLE BY REFERENCE *
!* ONLY THE TOP HALF IS SET UP *
!***********************************************************************
INTEGER K,DES
K=DESADS(PREC)
RESULT =K UNLESS K=0
IF PREC=4 THEN DES=X'58000002' ELSE DES=PREC<<27!1
K=WORD CONST(DES)
DESADS(PREC)=K
RESULT =K
END
INTEGERFN MAPDES(INTEGER PREC)
!***********************************************************************
!* SET UP 8BIT ZERO ADDRESS UNSCALED BCI DESCRTR FOR MAPPING *
!***********************************************************************
INTEGER K,DES0,DES1
K=DESADS(PREC+8)
RESULT =K UNLESS K=0
IF PREC=4 THEN DES0=X'58000002' ELSE DES0=X'03000000'!PREC<<27
DES1=0; STORE CONST(K,8,ADDR(DES0))
DESADS(PREC+8)=K
RESULT =K
END
INTEGERFN SPECIAL CONSTS(INTEGER WHICH)
!***********************************************************************
!* PUTS CERTAIN SPECIAL CONSTANTS INTO THE CONSTANT TABLE ON *
!* DEMAND AND REMEMBERS THEIR POSN TO AVOID SEARCHONG *
!***********************************************************************
CONSTINTEGERARRAY SCS(0:7) = X'40800000',0,
X'41100000',0,
1,0,
X'4F000000',0;
INTEGER K
K=DESADS(WHICH+16)
RESULT =K UNLESS K=0
STORE CONST(K,8,ADDR(SCS(2*WHICH)))
DESADS(WHICH+16)=K
RESULT =K
END
INTEGERFN WORD CONST(INTEGER VALUE)
!***********************************************************************
!* SIMPLE INTERFACE TO STORE CONST FOR 32 BIT CONSTS *
!***********************************************************************
INTEGER K
STORE CONST(K,4,ADDR(VALUE))
RESULT =K
END
ROUTINE STORE CONST(INTEGERNAME D, INTEGER L, AD)
!***********************************************************************
!* PUT THE CONSTANT VAL OF LENGTH 'L' INTO THE CONSTANT TABLE *
!* A CHECK IS MADE TO SEE IF THE CONSTANT HAS ALREADY *
!* BEEN INSERTED IN WHICH CASE THE OLD COPY IS REUSED *
!***********************************************************************
INTEGER I, J, K, C1, C2, C3, C4, LP
LP=L//4; C2=0; C3=0; C4=0
CYCLE I=0,1,L-1
BYTEINTEGER(ADDR(C1)+I)=BYTEINTEGER(AD+I)
REPEAT
K=CONST BTM; ! AFTER STRINGS IN CTABLE
IF L=4 THEN START
IF USE IMP=YES THEN START
WHILE K<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
*LD_CTABLE
*LB_K
*SBB_1
*LSS_C1
AGN1:
*ADB_1
*CPB_CONSTPTR
*JCC_10,<SKIP>
*ICP_(DR +B )
*JCC_7,<AGN1>
*CPB_CONSTHOLE
*JCC_8,<AGN1>
*LSS_B
*IMY_4
*OR_X'80000000'
*ST_(D)
*EXIT_-64
FINISH
FINISH ELSE START
J=CONSTPTR-LP
WHILE K<=J CYCLE
IF CTABLE(K)=C1 AND CTABLE(K+1)=C2 AND C
(CONSTHOLE<K 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)=C3 C
AND CTABLE(CONSTPTR+3)=C4
CONST PTR=CONST PTR+LP
IF CONST PTR>CONST LIMIT THEN FAULT(102, WKFILEK,0)
END
ROUTINE GET ENV(INTEGERNAME HEAD)
!***********************************************************************
!* SAVE A COPY OF THE REGISTER STATE FOR FUTURE REFERENCE *
!***********************************************************************
INTEGER I, USE
CYCLE I=0, 1, 7
USE=GRUSE(I)&X'FF'; ! MAIN USE ONLY
PUSH(HEAD, GRINF1(I), GRAT(I), I<<8!USE) IF USE#0
REPEAT
END
ROUTINE RESTORE(INTEGER HEAD)
!***********************************************************************
!* RESET THE REGISTERS TO ENVIRONMENT IN LIST HEADED BY 'HEAD' *
!***********************************************************************
INTEGER I, R, USE, INF, AT
CYCLE I=0, 1, 7
IF REGISTER(I)>=0 THEN GRUSE(I)=0 AND GRINF1(I)=0
REPEAT
WHILE HEAD#0 CYCLE
POP(HEAD, INF, AT, I)
R=I>>8; USE=I&255
IF REGISTER(R)>=0 THEN GRUSE(R)=USE AND GRINF1(R)=INF
GRAT(R)=AT
REPEAT
END
ROUTINE RELOCATE(INTEGER GLARAD,VALUE,AREA)
!***********************************************************************
!* PLANTS A WORD IN THE GLA (IF GLARAD<0) AND ARRANGES TO *
!* RELOCATE IT RELATIVE TO AN AREA(CODE=1,GLA=2,CST=4,GST=5 *
!* IF THE RELOCATION IS RELATIVE TO SYMBOL TABLES THE WORD *
!* CAN NOT BE RELOCATED TILL SIZE OF THE CODE(OR GLA) IS KNOWN *
!***********************************************************************
IF GLARAD<0 THEN PGLA(4,4,ADDR(VALUE)) AND GLARAD=GLACA-4
LPUT(19,2,GLARAD,AREA)
END
ROUTINE GXREF(STRING (31) NAME,INTEGER MODE,XTRA,AT)
!***********************************************************************
!* ASK LPUT TO ARRANGE FOR A DOUBLE WORD AT 'AT' IN THE GLA *
!* TO CONTAIN A DESCRIPTOR FOR NAME 'NAME'. *
!* MODE=0 STATIC CODE XREF *
!* MODE=1 DYNAMIC CODE XREF *
!* MODE=2 DATA XREF XTRA=MINIMIUM LENGTH *
!***********************************************************************
INTEGER LPUTNO
IF MODE=2 THEN LPUTNO=15-5*PARMLET ELSE LPUTNO=MODE+12
! PARMLET MEANS ALLOW DATA=COMMON
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(4,4,ADDR(DESC2)) AND AT=GLACA-8
CDCOUNT=CDCOUNT+1
END
ROUTINE DEFINE EP(STRING (255)NAME, INTEGER ADR,AT,MAIN)
!***********************************************************************
!* AN EP CONSISTS OF A CODE DESCRIPTOR IN THE GLA(PLT) OF *
!* FILE CONTAINING THE EP. LPUT IS TOLD ABOUT THIS AND THE LOADER*
!* ARRANGES TO PUT A DESCRIPTOR-DESCRIPTOR TO THE CODE-DESC *
!* IN THE GLA OF ANY FILE REFERENCES THIS EP. THIS FIRST WORD *
!* OF ICLS PLT IS THE MAIN EP AND WE MIMIC THIS AS FAR AS POSS *
!***********************************************************************
IF AT=0 THEN FIXED GLA(1)=ADR ELSE PLUG(2,AT+4,ADR,4)
RELOCATE(AT+4,ADR,1)
LPUT(11,MAIN<<31!2,AT,ADDR(NAME)) IF NAME#""
END
ROUTINE PROLOGUE
!***********************************************************************
!* GENERATES THE SUBROUTINE THAT ALWAYS ARE REQUIRED ONTO THE *
!* FRONT OF THE OBJECT PROGRAM WHERE THEY ARE DIRECTLY ADDRESABLE*
!***********************************************************************
INTEGERFNSPEC STRINGIN(INTEGER POS)
ROUTINESPEC ERR EXIT(INTEGER A, B, C)
INTEGER I, K, L, STCA
I=X'C2C2C2C2'
LPUT(4,4,0,ADDR(I))
SSTL=4
CYCLE I=0, 1, 31
PLABS(I)=0; PLINK(I)=0
DESADS(I)=0
REPEAT
!
! GENERATE THE FIXED-FLOAT CONSTANTS THAT MAY BE NEEDED
!
PLABS(1)=CA
CYCLE I=0, 1, 1
PCONST(UNASSPAT)
REPEAT
!
! GENERATE THE RUN TIME ERROR ROUTINE :-
! MDIAGS FOR NR IS %ROUTINE MDIAGS(%INT PC,LNB,ERROR,XTRA)
! PC IS A DUMMY (SEG FIELD ONLY USED) EXCEPT AFTER CONTINGENCY
! ON ENTRY TO THIS SUBROUTINE ERROR & XTRA ARE IN ACC AS 64 BIT INTEGER
! ENTRY HAS BEEN BY JLK SO RETURN ADDRESS STACKED
!
!RTF LXN (LNB+4) POINTER TO GLA
! PRCL 4 TO PLANT PARAMS
! JLK +1 STACK DUMMY PC
! STLN TOS LNB AS SECOND PARAMETER
! ST TOS ERROR NO AS THIRD PARAM
! RALN 9 TO STORED LNB
! CALL ((XNB+10)) VIA XREF=DESCRIPTOR-DESCRIPTOR
! J TOS BACK AFTER A MONITOR
!
PLABS(2)=CA
PSF1(LXN,1,16)
PSF1(PRCL,0,4)
PSF1(JLK,0,1)
PF1(STLN,0,TOS,0)
PF1(ST,0,TOS,0)
PSF1(RALN,0,9)
PF1(CALL,2,XNB,40)
PF1(JUNC,0,TOS,0)
!
! SUBROUTINE TO CALL DEBUG ROUTINE(S#IMPMON) LINE NO IN ACC
!
! PRCL 4
! ST TOS
! LXN (LNB+4)
! RALN 6
! CALL ((XNB+IMPMONEPDISP))
! JUNC TOS
!
IF PARMDBUG#0 THEN START
PLABS(3)=CA
CXREF("S#IMPMON",PARMDYNAMIC,2,K)
PSF1(PRCL,0,4)
PF1(ST,0,TOS,0)
PSF1(LXN,1,16)
PSF1(RALN,0,6)
PF1(CALL,2,XNB,K)
PF1(JUNC,0,TOS,0)
FINISH
!
! SUBROUTINE TO ADVANCE STACK FRONT BY B WORDS AND FILL WITH UNASSIGNED
!
! JAT 12,*+13 B IS ZERO
! LSS TOS
! STSF TOS
! LDTB STRING DECRIPTOR SET UP DESCRIPTOR FOR MVL
! LDA TOS
! ASF B ADVANCE BY B WORDS
! MYB 4 CHANGE B TO BYTES
! LDB B AND MOVE TO BOUND FIELD
! MVL L=DR AND FILL WITH X80S
! ST TOS
! J TOS RETURN
!
IF PARMCHK=1 THEN START ; ! ONLY REQUIRED WITH CHKING
CNOP(0,4); K=CA
PCONST(X'58000000')
PLABS(4)=CA
PF3(JAT,12,0,13)
PF1(LSS,0,TOS,0)
PF1(STSF,0,TOS,0)
PF1(LDTB,0,PC,K)
PF1(LDA,0,TOS,0)
PF1(ASF,0,BREG,0)
PSF1(MYB,0,4)
PF1(LDB,0,BREG,0)
PF2(MVL,1,1,0,0,UNASSPAT&255)
PF1(ST,0,TOS,0)
PF1(JUNC,0,TOS,0)
FINISH
!
! SOME ERROR ROUTINES
!
ERR EXIT(5, X'801', 0) IF PARMOPT#0; ! UNASSIGNED VARIABLE
ERR EXIT(6, X'802', 0); ! SWITCH LABEL UNSET
ERR EXIT(7, X'505', 1); ! ILLEGEAL EXPONENTIATION
ERR EXIT(8,X'201', 0) IF PARMOPT#0; ! EXCESS BLOCKS
ERR EXIT(9, X'601', 0); ! CAPACITY EXCEEDED
ERR EXIT(10,21, 0) ; ! NO RESULT
ERR EXIT(11,X'501', 0) IF PARMOPT#0; ! CYCLE NOT VALID
ERR EXIT(12,X'701',0); ! RES FAILS
ERR EXIT(13,36,0) IF PARMOPT#0; ! WRONG NO OF PARAMS
!
! PUT THE STRINGS ONTO THE FRONT OF CONSTANT AREA
!
CTABLE(0)=X'18000001'
CTABLE(1)=4
STCA=8; L=ADDR(CTABLE(0))
CONST PTR=2; ! IN CASE NO STRINGS
WHILE STRLINK#0 CYCLE
I=STRLINK; STRLINK=FROM AR4(I)
TO AR4(I,STRINGIN(I+4)); ! CHANGE LINK TO STRING ADDR
REPEAT
STRLINK=X'80000000'
CONST BTM=CONST PTR
IF PARMOPT#0 THEN CTABLE(CONST PTR)=M'IDIA' AND C
CONST PTR=CONST PTR+1
GXREF(MDEP,PARMDYNAMIC,2,40)
IF PARMPROF#0 THEN START ; ! ALLOCATE PROFILE COUNT AREA
I=X'38000001'+LINE
K=8
PARMPROF=GLACA
PGLA(4,8,ADDR(I))
K=0
CYCLE I=0,1,LINE
PGLA(4,4,ADDR(K))
REPEAT
LINE=0
FINISH
LEVEL=1
CYCLE I=0,1,31
IF PLINK(I)#0 THEN CLEAR LIST(PLINK(I))
REPEAT
RETURN
INTEGERFN STRINGIN(INTEGER POS)
!***********************************************************************
!* PUT A STRING INTO THE CONSTANT AREA CHECKING FOR DUPLICATES *
!***********************************************************************
INTEGER J,K,IND,HD
RECORD (LISTF)NAME CELL
K=A(POS)
IF K=0 THEN RESULT =0
IND=K&31; HD=PLINK(IND)
WHILE HD#0 CYCLE
CELL==ASLIST(HD)
IF CELL_S1=K AND STRING(L+CELL_S2)=STRING(ADDR(A(POS))) C
THEN RESULT =CELL_S2-4
HD=CELL_LINK
REPEAT
HD=STCA
BYTEINTEGER(L+STCA)=K; STCA=STCA+1
CYCLE J=POS+1,1,POS+K
BYTE INTEGER(L+STCA)=A(J)
STCA=STCA+1
REPEAT
CONST PTR=((STCA+7)&(-8))>>2
PUSH(PLINK(IND),K,HD,0)
RESULT =HD-4
END
ROUTINE ERR EXIT(INTEGER LAB, ERRNO, MODE)
!***********************************************************************
!* MODE=0 FOR DUMMY(ZERO) XTRA - MODE=1 XTRA IN BREG *
!***********************************************************************
INTEGER EXTRA
EXTRA=0; ! NORMALLY ENTER AT PLABS 2
PLABS(LAB)=CA
IF ERRNO=36 THEN START ; ! WRONG NO OF PARAMS
PSF1(LXN,1,16); ! GET PLT BASE
PSF1(LLN,1,0); ! RESET TO CALLING FRAME
EXTRA=2; ! ENTER 2 BYTE ON (PAST LXN)
FINISH
IF MODE=0 THEN PSF1(LSS,0,0) ELSE PF1(LSS,0,BREG,0)
PSF1(LUH,0,ERRNO)
PSF1(JLK,0,(PLABS(2)+EXTRA-CA)//2)
END
END
ROUTINE CSS(INTEGER P)
ROUTINESPEC MERGE INFO
ROUTINESPEC REDUCE ENV(INTEGERNAME HEAD)
ROUTINESPEC ENTER JUMP(INTEGER MASK,STAD,FLAG)
INTEGERFNSPEC ENTER LAB(INTEGER M,FLAG)
ROUTINESPEC REMOVE LAB(INTEGER LAB)
ROUTINESPEC CEND(INTEGER KKK)
INTEGERFNSPEC CCOND(INTEGER CTO,A,B,ULINE)
ROUTINESPEC CHECK STOF
INTEGERFNSPEC REVERSE(INTEGER MASK)
ROUTINESPEC SET LINE
INTEGERFNSPEC SET XORYNB(INTEGER WHICH,RLEVEL)
INTEGERFNSPEC XORYNB(INTEGER USE,INF)
ROUTINESPEC GET IN ACC(INTEGER ACC,SIZE,AC,AREA,DISP)
INTEGERFNSPEC AREA CODE
INTEGERFNSPEC AREA CODE2(INTEGER BS)
ROUTINESPEC CUI(INTEGER CODE)
ROUTINESPEC ASSIGN(INTEGER A,B)
ROUTINESPEC CSTART(INTEGER CCRES,MODE)
ROUTINESPEC CCYCBODY(INTEGER UA,ELAB,CLAB)
ROUTINESPEC CLOOP(INTEGER ALT,MARKC,MARKUI)
ROUTINESPEC CIFTHEN(INTEGER MARKIU,MARKC,MARKUI,MARKE,MARKR,SKIP)
ROUTINESPEC CREATE AH(INTEGER MODE)
ROUTINESPEC TORP(INTEGERNAME HEAD,BOT,NOPS)
INTEGERFNSPEC INTEXP(INTEGERNAME VALUE)
INTEGERFNSPEC CONSTEXP(INTEGER PRECTYPE)
ROUTINESPEC CSEXP(INTEGER REG,MODE)
ROUTINESPEC CSTREXP(INTEGER A,B)
ROUTINESPEC CRES(INTEGER LAB)
ROUTINESPEC EXPOP(INTEGER A,B,C,D)
ROUTINESPEC TEST APP(INTEGERNAME NUM)
ROUTINESPEC SKIP EXP
ROUTINESPEC SKIP APP
ROUTINESPEC NO APP
INTEGERFNSPEC DOPE VECTOR(INTEGER A,B,MODE,ID,INTEGERNAME C,D)
ROUTINESPEC DECLARE ARRAYS(INTEGER A,B)
ROUTINESPEC DECLARE SCALARS(INTEGER A,B)
ROUTINESPEC MAKE DECS(INTEGER Q)
ROUTINESPEC SAVE AUX STACK
ROUTINESPEC RESET AUX STACK
ROUTINESPEC CRSPEC(INTEGER M)
INTEGERFNSPEC SET SWITCHLAB(INTEGER HEAD,LAB,FNAME,BIT)
ROUTINESPEC CFPLIST(INTEGERNAME A,B)
ROUTINESPEC CFPDEL
ROUTINESPEC CLT
ROUTINESPEC CQN(INTEGER P)
ROUTINESPEC GET WSP(INTEGERNAME PLACE,INTEGER SIZE)
ROUTINESPEC RETURN WSP(INTEGER PLACE,SIZE)
INTEGERFNSPEC TSEXP(INTEGERNAME VALUE)
ROUTINESPEC CRCALL(INTEGER RTNAME)
ROUTINESPEC NAMEOP(INTEGER Z,REG,SIZE,NAMEP)
ROUTINESPEC CNAME(INTEGER Z,REG)
ROUTINESPEC CANAME(INTEGER Z,BS,DP)
ROUTINESPEC CSNAME(INTEGER Z,REG)
ROUTINESPEC TEST ASS(INTEGER REG,TYPE,SIZE)
ROUTINESPEC COPY TAG(INTEGER KK)
ROUTINESPEC REDUCE TAG
ROUTINESPEC RT JUMP(INTEGER CODE,INTEGERNAME L)
ROUTINESPEC STORE TAG(INTEGER KK,SLINK)
ROUTINESPEC UNPACK
ROUTINESPEC PACK(INTEGERNAME PTYPE)
ROUTINESPEC DIAG POINTER(INTEGER LEVEL)
ROUTINESPEC RDISPLAY(INTEGER KK)
ROUTINESPEC RHEAD(INTEGER KK,STRING (127) XNAME)
ROUTINESPEC ODD ALIGN
INTEGERFNSPEC PTR OFFSET(INTEGER RLEV)
ROUTINESPEC PPJ(INTEGER MASK,N)
INTEGERFNSPEC CFORMATREF
ROUTINESPEC CRFORMAT(INTEGERNAME OPHEAD,OPBOT,NLIST,MRL,INTEGER INIT)
INTEGERFNSPEC DISPLACEMENT(INTEGER LINK)
INTEGERFNSPEC COPY RECORD TAG(INTEGERNAME SUBS)
ROUTINESPEC SAVE IRS
ROUTINESPEC COPY DR
ROUTINESPEC BOOT OUT(INTEGER REG)
ROUTINESPEC CHANGE RD(INTEGER REG)
ROUTINESPEC FORGET(INTEGER REG)
ROUTINESPEC REMEMBER
ROUTINESPEC NOTE ASSMENT(INTEGER REG,ASSOP,VAR)
SWITCH SW(1:24)
INTEGER SNDISP,ACC,K,KFORM,STNAME
INTEGER TCELL,NUMMOD,JJ,JJJ,KK,QQ,MARKER,REPORTUI,XDISP,MASK, C
BASE,AREA,ACCESS,DISP,EXTRN, CURR INST,VALUE,STRINGL, C
PTYPE,I,J,OLDI,USEBITS,TWSPHEAD,STRFNRES, C
MARKIU,MARKUI,MARKC,MARKE,MARKR,INAFORMAT
INTEGER LITL,ROUT,NAM,ARR,PREC,TYPE
INTEGERARRAY SGRUSE,SGRINF(0:7)
RECORD (RD) EXPOPND; ! RESULT RECORD FOR EXPOP
CURR INST=0
INAFORMAT=0
TWSPHEAD=0
LITL=0; ROUT=0; PTYPE=-1; NAM=0; ARR=0;
SNDISP=0; KFORM=0; ACC=0
->SW(A(P))
SW(13): ! INCLUDE SOMETHING
SW(24): ! REDUNDANT SEP
SW(2): ! <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,0) UNLESS LEVEL>=2
MARKER=P+1+A(P+1)<<8+A(P+2)
P=P+3
->LABFND IF A(MARKER)=1
IF A(MARKER)=2 THEN SET LINE AND CUI(0) AND ->CSSEXIT
MARKE=0; MARKR=0
MARKUI=P; MARKIU=MARKER+1
MARKC=MARKIU+1
IF A(MARKER)=3 THEN CIFTHEN(MARKIU,MARKC,MARKUI,0,0,NO) C
AND ->CSSEXIT
CLOOP(A(MARKIU),MARKC+2,MARKUI)
->CSSEXIT
LABFND: ->SWITCH UNLESS A(P)=1 AND A(P+5)=2; ! 1ST OF UI AND NO APP
->SWITCH UNLESS A(P+6)=2 AND A(P+7)=2;! NO ENAMSE OR ASSNMNT
JJ=ENTER LAB(FROM AR2(P+3),0); ->CSSEXIT
SW(5): ! %CYCLE
FAULT(57,0,0) UNLESS LEVEL>=2
IF A(P+5)=2 THEN START ; ! OPEN CYCLE
CLOOP(0,P+1,0)
FINISH ELSE START
SET LINE
CLOOP(6,P+6,P+1)
FINISH
->CSSEXIT
!
SW(6): ! REPEAT
->CSSEXIT
SW(22): ! '%CONTROL' (CONST)
J=FROM AR4(P+2)
CODEOUT
DCOMP=J>>28; ->CSSEXIT
!
SW(3): ! (%IU)(COND)%THEN(UI)(ELSE')
MARKIU=P+1; MARKC=MARKIU+3
MARKR=P+2+A(P+2)<<8+A(P+3); ! ! FROMAR2(P+2)
MARKE=0; MARKUI=0
IF A(MARKR)=3 THEN START
MARKE=MARKR+1+FROMAR2(MARKR+1)
MARKUI=MARKR+3
FINISH
CIFTHEN(MARKIU,MARKC,MARKUI,MARKE,MARKR,NO)
->CSSEXIT
SW(18): ! SOLO ELSE MEANING FINISH ELSE START
SW(4):
! '%FINISH(ELSE')(S)
->CSSEXIT
SWITCH: BEGIN ; ! SWITCH LABEL
INTEGER NAPS,FNAME
FNAME=FROM AR2(P+3)
UNLESS A(P)=1 AND A(P+5)=1 THEN FAULT(5,0,FNAME) AND ->BEND
! 1ST OF UI + APP
P=P+3; TEST APP(NAPS)
P=P+6
UNLESS INTEXP(JJ)=0 THEN FAULT(41,0,0) AND ->BEND
! UNLESS EXPRESSION EVALUATES AND
UNLESS NAPS=1 THEN FAULT(21,NAPS-1,FNAME) AND ->BEND
! NO REST OF APP
UNLESS A(P+1)=2=A(P+2) THEN FAULT(5,0,FNAME) AND ->BEND
! NO ENAME OR REST OF ASSIGMENT
COPY TAG(FNAME)
IF OLDI#LEVEL OR TYPE#6 THEN FAULT(4,0,FNAME) AND ->BEND
IF SET SWITCHLAB(K,JJ,FNAME,1)#0 THEN FAULT(6,JJ,FNAME)
BEND: END ; ->CSSEXIT
SW(23):
! SWITCH(*):
BEGIN
INTEGER FNAME,LB,UB,JJ,RES
FNAME=FROM AR2(P+1)
COPY TAG (FNAME)
IF OLDI=LEVEL AND TYPE=6 START
FROM123(K,JJ,LB,UB)
CYCLE JJ=LB,1,UB
RES=SET SWITCHLAB(K,JJ,FNAME,0)
REPEAT
FINISH ELSE FAULT(4,0,FNAME)
END ; ->CSSEXIT
!
SW(7): ! (%WU)(SC)(COND)(RESTOFWU)
FAULT(57,0,0) UNLESS LEVEL>=2
MARKIU=P+1; ! TO WHILE/UNTIL
MARKC=MARKIU+3; ! TO (SC)(COND)
CLOOP(A(MARKIU)+3,MARKC,MARKIU+1+FROMAR2(MARKIU+1))
->CSSEXIT
!
SW(8): ! SIMPLE DECLN
FAULT(57,0,0) UNLESS LEVEL>=2
FAULT(40,0,0) IF NMDECS(LEVEL)&1#0
QQ=P; P=P+5
MARKER=P+FROMAR2(P); ! TO ALT OF DECLN
P=P+2; ROUT=0; LITL=0
IF A(MARKER)#1 THEN START ; ! ARRAY DECLARATIONS
CLT
FAULT(70,ACC-1,0) IF TYPE=5 AND (ACC<=0 OR ACC>256)
NAM=0
SET LINE
QQ=2-A(P+1); P=P+2; ! QQ=1 FOR ARRAYFORMATS
DECLARE ARRAYS(QQ,KFORM)
FINISH ELSE START
IF A(QQ+1)=128 OR A(P)>3 START ;! NOT LINKED&SHUFFLED
CLT
CQN(P+1); P=P+2
DECLARE SCALARS(1,KFORM)
FINISH
FINISH
->CSSEXIT
!
SW(9): ! %END
BEGIN
SWITCH S(1:5)
-> S(A(P+1))
S(1): ! ENDOFPROGRAM
S(2): ! ENDOFFILE
IF CPRMODE=0 THEN CPRMODE=2
FAULT(15,LEVEL+CPRMODE-3,0) UNLESS LEVEL+CPRMODE=3
CEND(CPRMODE)
->BEND
S(3): ! ENDOFLIST
LIST=0;
->BEND
S(4): ! END
IF CPRMODE=1 AND LEVEL=2 THEN FAULT(14,0,0) ELSE C
CEND(FLAG(LEVEL))
BEND: END
->CSSEXIT
!
SW(11):
BEGIN
INTEGER MARKER1,RTNAME,KKK,PTR,PTYPEP,CNT,PP,PCHAIN
RECORD (LISTF)NAME LCELL
STRING (34)XNAME
P=P+1; MARKER1=FROM AR2(P)+P; ! (SEX)(RT)(SPEC')(NAME)(FPP)
AGN: Q=P; RTNAME=FROM AR2(MARKER1+5); ! RTNAME ON NAME
EXTRN=A(P+2); ! 1=SYSTEM,2=EXTERNAL
! 3=DYNAMIC, 4=INTERNAL
LITL=EXTRN&3
IF A(MARKER1)=1 THEN START ; ! P<%SPEC'>='%SPEC'
P=P+3; CRSPEC(1-EXTRN>>2); ! 0 FOR ROUTINESPEC
! 1 FOR EXTERNAL (ETC) SPEC
->BEND
FINISH
LCELL==ASLIST(TAGS(RTNAME))
OLDI=LCELL_S1>>8&63; ! DONT COPY TAG OF GLOBAL NAME
! UPSETS NOT USED BITS
XNAME<-STRING(DICTBASE+WORD(RTNAME))
IF EXTRN=3 THEN EXTRN=2
IF EXTRN=1 THEN XNAME<-"S#".XNAME
IF A(MARKER1+7)=1 THEN XNAME<-STRING(ADDR(A(MARKER1+8)))
IF EXTRN=4 THEN XNAME=""
IF OLDI#LEVEL THEN START
P=Q+3; CRSPEC(0); P=Q; ->AGN
FINISH ELSE START ; ! NAME ALREADY KNOWN AT THIS LEVEL
COPY TAG(RTNAME); ! MUST BE RIGHT TAG OR FAULT
IF CPRMODE=0 THEN CPRMODE=2; ! FLAG AS FILE OF ROUTINES
FAULT(56,0,RTNAME) UNLESS EXTRN=4 OR (CPRMODE=2 AND LEVEL=1)
IF A(P+3)=1 THEN KKK=LITL<<14!X'1000' ELSE START
ROUT=1; P=P+4; ! FIGURE OUT PTYPE FOR FNS&MAPS
CLT; ARR=0; NAM=0
IF A(P)=2 THEN NAM=2; ! SET NAME ARRAY BIT FOR MAPS
PACK(KKK); ! AND STORE PTYPE IN KKK
FINISH
FINISH
!
! UNLESS A MATCH WAS OBTAINED BETWEEN HEADING AND SPEC SOMETHING
! HAS GONE WRONG. COMPILE HEADING AGAIN AS SPEC. THIS WILL
! PREVENT ANY INCONSISTENCIED AND CAUSE A "NAME SET TWICE"
! FOR ANY ERROR
!
UNLESS (J=15 OR J=7*EXTRN) AND PTYPE=KKK START
P=Q+3; CRSPEC(0); P=Q; ->AGN
FINISH
PTYPE=PTYPE!(EXTRN&3)<<14; ! DEAL WITH %ROUTINESPEC FOLLOWED
! BY %EXTERNALROUTINE
!
! RESET THE TAGS TO BODY GIVEN AND ALLOWING FOR SPEC/EXTERNALROUTINE
! AND EXTERNALSPEC/EXTERNAL ROUTINE COMBINATIONS. LEAVE THE USE
! BITS WHICH WILL SHOW USED AS A RESULT OF THE COPYTAG IN THIS SEQUENCE
! FOR UNUSED ROUTINES WITHOUT EXTERNAL ENTRY RHEAD WILL RESET
!
LCELL_S1=LCELL_S1&X'FFF0'!PTYPE<<16
! NEWPTYPE & SET J=0
IF J=14 THEN LCELL_SNDISP=0; ! NO OUTSTANDING JUMP TO EXTERNAL
PTYPEP=PTYPE
PCHAIN=LCELL_S3>>16; ! CHAIN OF PARAMETER DESCRIPTUONS
RHEAD(RTNAME,XNAME); ! FIRST PART OF ENTRY SEQUENCE
!
! NOW DECLARE THE FORMAL PARAMETERS. FOLLOW BY CLAIMING DISPLAY
! AND SETTING DIAGNOSTIC PTR IN ROUTINE RDISPLAY
!
P=MARKER1+8
IF A(P-1)=1 THEN P=P+A(P)+1; ! SKIP OVER ALIASNAME
N=20; CNT=1
WHILE A(P)=1 CYCLE ; ! WHILE SOME (MORE) FP PART
PP=P+1+FROMAR2(P+1)
P=P+3
CFPDEL
PTR=P
UNTIL A(PTR-1)=2 CYCLE ; ! CYCLE DOWN NAMELIST
IF PCHAIN#0 THEN START
FROM12(PCHAIN,J,JJJ); ! EXTRACT PTYPE XTRA INFO
UNLESS J>>16=PTYPE AND (PTYPE#5 OR JJJ>>16=ACC)C
THEN FAULT(9,CNT,RTNAME)
FINISH ELSE FAULT(8,0,RTNAME);! MORE FPS THAN IN SPEC
PTR=PTR+3
CNT=CNT+1
MLINK(PCHAIN)
REPEAT
DECLARE SCALARS(0,KFORM)
P=PP
REPEAT ; ! UNTIL NO MORE FP-PART
N=(N+3)&(-4); ! TO WORD BOUNDARY AFTER ALL SYSTEM
! STANDARD PARAMETERS HAVE BEEN DECLARED
FAULT(10,0,RTNAME) UNLESS PCHAIN=0
PTYPE=PTYPEP
N=N+8 UNLESS 3#PTYPE&X'F0F'#5; ! STR FNS RESULT PARAM IS STACKED
! AS XTRA PARM JUST BEFORE DISPLAY
RDISPLAY(RTNAME)
MAKE DECS(MARKER1+1)
BEND: END ; ->CSSEXIT
!
SW(14): !%BEGIN
BEGIN
PTYPE=0
IF LEVEL=1 AND RLEVEL=0 START
IF CPRMODE=0 THEN START
RLEVEL=1; RBASE=1
L(1)=0; M(1)=0; DIAGINF(1)=0; AUXSBASE(1)=0
CPRMODE=1
RHEAD(-1,MAINEP)
N=20
RDISPLAY(-1)
FORGET(-1)
!
! THE CODE PLANTED IS AS FOLLOWS:-
! LXN (LNB+4) TO GLA(PLT)
! STLN (XNB+5) SAVE LNB FOR STOP SEQUENCE
!
PSF1(LXN,1,16)
PF1(STLN,0,XNB,20)
IF VMEB=YES START
CXREF("ICL9CEAJINIT",0,2,JJ)
PSF1(PRCL,0,4)
PSF1(RALN,0,5)
PF1(CALL,2,XNB,JJ); ! ON VME INITIALISE RUNTIME SYSTEM
FINISH
!
! SET THE PROGRAM MASK TO MASK OUT UNDERFLOW AND ALLOW ALL OTHER INTS
!
! MPSR X'40C0'
!
PF1(MPSR,0,0,X'40C0')
PTYPE=1
FINISH ELSE FAULT(58,0,0)
FINISH ELSE START
SET LINE; ! SO 'ENTERED FROM LINE' IS OK
RHEAD(-1,"")
RDISPLAY(-1)
FINISH
MAKE DECS(P+1)
END
->CSSEXIT
!
SW(15):
! '%ON'(EVENT')(N)(NLIST)'%START'
FAULT(57,0,0) UNLESS LEVEL>=2
FAULT(40,0,0) IF NMDECS(LEVEL)&1#0
NMDECS(LEVEL)=NMDECS(LEVEL)!X'11';! NO MORE DECS AND IN ONCOND
IF STACK=0 THEN START
SAVE AUX STACK
DISP=AUXSBASE(LEVEL)
PSF1(LSS,2,DISP); ! SAVE TOP OF AUX STACK
PSF1(ST,1,DISP+12)
FINISH
GRUSE(ACCR)=0
PSF1(CPSR,1,N+8)
PLABEL=PLABEL-1
JJJ=PLABEL
ENTER JUMP(15,JJJ,B'10'); ! JUMP ROUND ON BODY
!
P=P+1; JJ=0; ! SET UP A BITMASK IN JJ
UNTIL A(P)=2 CYCLE ; ! UNTIL NO MORE NLIST
KK=-1; P=P+4
FAULT(26,KK,0) UNLESS INTEXP(KK)=0 AND 1<=KK<=14
JJ=JJ!1<<(KK-1)
REPEAT
P=P+1
KK=CA; PGLA(4,4,ADDR(CA))
RELOCATE(GLACA-4,KK,1); ! ENTRY ADDRESS IN PLT
ONWORD(LEVEL)=JJ<<18!(GLACA-4)
FORGET(-1)
PSF1(ST,1,N); ! STORE EVENT,SUBEVENT&LINE
PSF1(MPSR,1,N+8)
ONINF(LEVEL)=N; N=N+12
IF STACK=0 THEN START
PSF1(LSS,1,DISP+12); ! RESET AUX STACK TOP
PSF1(ST,2,DISP)
FINISH
CSTART(0,3)
NMDECS(LEVEL)=NMDECS(LEVEL)!!X'10';! NOT IN ONCOND
JJ=ENTER LAB(JJJ,B'011'); ! MERGE ENVIRONMENT
->CSSEXIT
SW(16):
FAULT(57,0,0) UNLESS LEVEL>=2
BEGIN ; ! %SWITCH (SWITCH LIST)
INTEGER Q,RANGE,KKK,KK,LB,PP,D0,D1,OPHEAD,V,ARRP,R
Q=P
ARRP=1
IF PARMOPT=0 THEN ARRP=2
UNTIL A(Q)=2 CYCLE ; ! UNTIL NO'REST OF SW LIST'
P=P+3
P=P+3 WHILE A(P)=1
P=P+4; ! TO P(+')
KKK=INTEXP(LB); ! EXTRACT LOWER BOUND
P=P+3
KKK=KKK!INTEXP(KK); ! EXTRACT UPPER BOUND
RANGE=(KK-LB+1)
IF RANGE<=0 OR KKK#0 START
FAULT(38,1-RANGE,FROMAR2(Q+1))
LB=0; KK=10; RANGE=11
FINISH
IF SSTL-4*LB<0 THEN ARRP=1;! ZEROETH ELEMENT OFF FRONT
PTYPE=X'56'+ARRP<<8; ! WORD LABEL ARRAY
PP=P; P=Q+1
UNTIL A(P-1)=2 CYCLE ; ! DOWN NAMELIST
K=FROM AR2(P)
P=P+3
OPHEAD=0; R=LB
!
! SET UP A BIT LIST (96 BITS PER CELL) TO CHECK FOR SWITCH LABELS
! SET TWICE
!
UNTIL R>KK CYCLE
PUSH(OPHEAD,0,0,0)
R=R+96
REPEAT
!
! FOR CHECKING MODE USE A BOUNDED WORD DESCRIPTOR AND WORD SIZE
! ENTRIES PRESET TO "SW LABEL NOT SET". OPTIMISING USE BCI WORD
! ARRAYS WITH BASE SET TO ZEROETH ELEMENT
SSTL=(SSTL+3)&(-4)
D1=SSTL; ! FIRST TABLE ENTRY
D0=X'28000000'!RANGE; ! SCALED WORD DES
IF ARRP=2 THEN START
D0=D0!X'01000000' UNLESS LB=0;! SET BCI BIT
D1=D1-4*LB
FINISH
PGLA(4,8,ADDR(D0))
SNDISP=GLACA>>2-2; ! WORD PLT DISP
RELOCATE(GLACA-4,D1,4); ! RELOCATE RELATIVE TO SST
PUSH(OPHEAD,SSTL,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)
LPUT(44,4<<24!RANGE,SSTL,ADDR(V))
SSTL=SSTL+4*RANGE
REPEAT ; ! FOR ANY MORE NAMES IN NAMELIST
Q=PP; P=Q
REPEAT ; ! UNTIL A(Q)=2
END ;->CSSEXIT
!
SW(17): LIST=1; ->CSSEXIT
!
SW(12): ! '%OWN' (TYPE)(OWNDEC)
BEGIN
!***********************************************************************
!* INITIALISED DECLARATION GO INTO THE GLA OR GLA SYMBOL TABLES *
!* EXCEPT FOR CONST ARRAYS WHICH GO INTO THE CODE SYMBOL TABLES *
!* STRINGS AND ARRAYS HAVE A HEADER IN THE GLA. LPUT ARRANGES *
!* FOR THE LOADER TO RELOCATE THE HEADERS. *
!* EXTERNALS ARE IDENTICAL WITH OWN BUT ALSO HAVE A DATA EP DEFN *
!* IN THE LOAD DATA SO THEY CAN BE FOUND AT LOAD TIME *
!* EXTRINSICS HAVE A DATA REFERENCE AND A DUMMY HEADER IN THE GLA*
!* THE LOADER USES THE FORMER TO RELOCATE THE LATTER. *
!***********************************************************************
ROUTINESPEC CLEAR(INTEGER L)
ROUTINESPEC STAG(INTEGER J, DATALEN)
ROUTINESPEC XTRACT CONST(INTEGER CONTYPE, CONPREC)
ROUTINESPEC INIT SPACE(INTEGER A, B)
INTEGER LENGTH, PP, SIGN, UICONST, ICONST, C
TAGDISP, EPTYPE, EPDISP, AH1, AH2, AH3, AH4, AD, C
STALLOC, SPOINT, CONSTSFOUND, CPREC, EXTRN, NNAMES, C
MARK, LPUTP, LB, CTYPE, CONSTP, FORMAT, C
DIMEN, SACC, TYPEP
LONGREAL RCONST, LRCONST
OWNLONGREAL ZERO=0
STRING (255) SCONST, NAMTXT
INTEGERNAME STPTR
LPUTP=5; STPTR==USTPTR; ! NORMAL CASE GLA SYMBOLTABLES
! FAULT(40,0,0) %IF NMDECS&1#0
EXTRN=A(P+1)
P=P+2
IF EXTRN>=4 THEN EXTRN=0; ! CONST & CONSTANT->0
SNDISP=0
CONSTS FOUND=0
IF EXTRN=0 THEN LPUTP=4 AND STPTR==SSTL
CLT
!
! CHECK FOR %SPEC AND CHANGE EXTERNAL SPEC TO EXTRINSIC
!
IF A(P+2)=1 START
IF EXTRN=2 THEN EXTRN=3 ELSE FAULT(46,0,0)
FINISH
IF 2<=EXTRN<=3 AND ((A(P)=1 AND A(P+1)#3) OR C
(A(P)=2 AND A(P+1)#2)) THEN FAULT(46,0,0)
LITL=EXTRN
IF LITL<=1 THEN LITL=LITL!!1
IF A(P)=1 THEN CQN(P+1) ELSE ARR=1 AND NAM=0
IF TYPE=5 AND NAM=0 AND (ACC<=0 OR ACC>256) THEN C
FAULT(70,ACC-1,0) AND ACC=2
STALLOC=ACC; ! ALLOCATION OF STORE FOR ITEM OR POINTER
ROUT=0; PACK(PTYPE)
IF NAM#0 START ; ! OWN POINTERS
IF ARR#0 THEN STALLOC=16 ELSE STALLOC=8
FINISH ELSE START ; ! OWN VARS & ARRAYS
->NON SCALAR IF ARR#0
FINISH
P=P+2
UNTIL A(MARK)=2 CYCLE ; ! UNTIL <RESTOFOWNDEC> NULL
MARK=P+1+FROM AR2(P+1)
PP=P+3; P=PP+2; ! PP ON FIRST NAME'
K=FROM AR2(PP); ! FOR ERROR MESSAGES RE CONST
NAMTXT=STRING(DICTBASE+WORD(K))
IF A(P)=1 THEN NAMTXT<-STRING(ADDR(A(P+1))) AND C
P=P+A(P+1)+1
P=P+1; ! P ON CONST'
!
! OBTAIN THE INITIAL CONSTANT,ITS TYPE(CTYPE) AND SIGN(SIGN)
!
ICONST=0; UICONST=0
RCONST=0; LRCONST=0; SCONST=""
SIGN=3; CTYPE=TYPE; CONSTSFOUND=0; CPREC=PREC
IF TYPE=3 THEN CTYPE=1; ! RECS INITTED TO REPEATED BYTE
IF NAM#0 THEN CTYPE=1 AND CPREC=5
P=P+1
IF A(P-1)=1 THEN START ; ! CONSTANT GIVEN
XTRACT CONST(CTYPE,CPREC)
FINISH ELSE START
WARN(7,K) IF EXTRN=0; ! %CONST NOT INITIALISED
FINISH
J=0
IF NAM#0 THEN START ; ! OWNNAMES AND ARRAYNAMES
IF ARR=0 THEN START
UICONST=X'FFFF'!PREC<<27
PGLA(8,STALLOC,ADDR(UICONST))
FINISH ELSE START ; ! ARRAYNAMES
IF TYPE<=3 AND EXTRN=0 THEN ARR=2 AND PACK(PTYPE)
AH1=PREC<<27!X'FFFFFF'
IF PREC=4 THEN AH1=X'58000002'
AH1=AH1!(1-PARMARR)<<24
IF TYPE=3 THEN AH1=AH1!1<<25
AH2=ICONST
AH3=5<<27!3
SNDISP=DOPE VECTOR(TYPE,ACC,-1,K,QQ,LB)
AH4=SNDISP+12
IF EXTRN#0 THEN SNDISP=0 AND J=0 ELSE C
SNDISP=(SNDISP&X'3FFFF')>>2
PGLA(8,STALLOC,ADDR(AH1))
RELOCATE(GLACA-4,AH4,1)
AH4=AH4<<1>>3!X'80000000'
NOTE CREF(AH4!(GLACA-4)>>2<<16)
FINISH
TAGDISP=GLACA-STALLOC; EPDISP=TAGDISP
STAG(TAGDISP,STALLOC)
CONTINUE
FINISH
IF EXTRN=3 THEN START ; ! EXTRINISIC
PTYPE=PTYPE!X'400'; ! FORCE NAM=1 (IE VIA POINTER)
AH2=PREC<<27!(STALLOC//BYTES(PREC))
IF PREC=4 THEN AH2=X'58000002'
AH3=0
PGLA(8,8,ADDR(AH2))
TAGDISP=GLACA-8
GXREF(NAMTXT,2,2<<24!STALLOC,TAGDISP+4);! RELOCATE BY EXTERNAL
STAG(TAGDISP,STALLOC)
CONTINUE
FINISH
IF TYPE=5 THEN START ; ! STRING
IF EXTRN=0 START ; ! CONSTSTRINGS
TAGDISP=4*CONST PTR-4
STRING(ADDR(CTABLE(CONST PTR)))=SCONST
ACC=BYTE INTEGER(ADDR(SCONST))+1
CONST PTR=CONST PTR+(ACC+3)>>2
FINISH ELSE START
AH3=STPTR
AD=ADDR(SCONST)
LPUT(LPUTP,STALLOC,AH3,AD) IF INHCODE=0
! /P STRING
STPTR=(STPTR+ACC+3)&(-4)
AH2=3<<27!STALLOC
PGLA(8,8,ADDR(AH2))
TAGDISP=GLACA-8
RELOCATE(TAGDISP+4,AH3,LPUTP)
EPTYPE=5; EPDISP=AH3; ! DATA IN GLA SYMBOL TABLES
FINISH
FINISH
IF TYPE=3 THEN START ; ! RECORDS
EPDISP=(GLACA+15)&(-8)
AH3=EPDISP
AH2=X'18000000'+STALLOC; ! TOP WORD OF DESRCIPTOR
PGLA(8,4,ADDR(AH2)); ! TOP HALF OF DESCR TO GLA
RELOCATE(-1,AH3,2); ! PUT BOTTOM HALF INTO GLA
TAGDISP=EPDISP; ! AND RELOCATE REL APPROPIATE AREA
EPTYPE=2; ! DATA IN GLA TABLES
I=0; ICONST=ICONST&255
ICONST=ICONST<<8!ICONST
ICONST=ICONST<<16!ICONST
WHILE I<STALLOC CYCLE ; ! RECORDS INITIALISED AS REPEATED BYTE
PGLA(4,4,ADDR(ICONST))
I=I+4
REPEAT
FINISH
IF 1<=TYPE<=2 START ; ! INTEGER & REAL
IF TYPE=2 THEN START
AD=ADDR(RCONST)
FINISH ELSE START ; ! INTEGER VARIABLES
AD=ADDR(ICONST)+4-STALLOC
FINISH
IF EXTRN#0 THEN 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
STAG(TAGDISP,ACC)
IF EXTRN=0=NAM AND TYPE<=2 START ;! CONST = LITERAL
REPLACE2(TAGS(K),INTEGER(AD&(-4)));! BYTES!
IF PREC=6 THEN REPLACE3(TAGS(K),INTEGER(AD+4))
IF PREC=7 THEN REPLACE3(TAGS(K),CONSTP)
FINISH
P=MARK
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 INITIALISED AS BYTE ARRAYS *
!***********************************************************************
P=P+1
FORMAT=2-A(P)
IF FORMAT#0 THEN ARR=3 AND PACK(PTYPE)
PP=P+2; P=P+4; NNAMES=1
K=FROM AR2(PP)
NAMTXT=STRING(DICTBASE+WORD(K))
IF A(P)=1 THEN NAMTXT<-STRING(ADDR(A(P+1))) AND C
P=P+A(P+1)+1
P=P+1; ! P ON CONSTLIST
SACC=ACC; TYPEP=PTYPE
AH4=12+DOPE VECTOR(TYPE,STALLOC,0,K,QQ,LB)
SNDISP=AH4-12; ! DV DISP (+TOP BIT FLAG)
IF SNDISP=-1 THEN SNDISP=0; ! BUM DOPE VECTOR
SNDISP=(SNDISP&X'3FFFF')>>2; ! AS WORD DISPLACEMENT
DIMEN=J; ! SAVE NO OF DIMENESIONS
ACC=SACC; PTYPE=TYPEP; UNPACK
IF LB=0=FORMAT AND J=1 AND TYPE<=3 C
THEN ARR=2 AND PACK(PTYPE)
IF TYPE=3 THEN LENGTH=QQ ELSE LENGTH=QQ//STALLOC;! NO OF ELEMENTS
SPOINT=STPTR
IF FORMAT=0 THEN START
IF A(P)=1 THEN P=P+1 AND INIT SPACE(QQ,LENGTH)
FINISH
IF CONSTS FOUND=0 THEN START ; ! NO CONSTANTS GIVEN
! SO CLEAR AN AREA TO ZERO
CONSTS FOUND=LENGTH
CLEAR(QQ) UNLESS LENGTH<1 OR EXTRN=3 OR FORMAT#0
FINISH ELSE START
FAULT(49,0,K) IF EXTRN=3 OR FORMAT#0
FINISH
IF EXTRN=3 THEN EPDISP=0 ELSE EPDISP=SPOINT
! OUTPUT AN ARRAYHEAD INTO THE GLA RELATIVE TO THE START OF THE SYMBOL-
! TABLES IN WHICH THE ARRAY RESIDES.
J=DIMEN; ! RESET DIMENSIONS AFTER INITTING
IF TYPE<=2 THEN AH1=PREC<<27!LENGTH C
ELSE AH1=3<<27!1<<25!QQ
AH1=AH1!(1-PARMARR)<<24; ! SET BCI IF BASE TO BE SHIFTED
IF PREC=4 THEN AH1=X'58000002'
AH2=EPDISP
AH3=5<<27!3*J; ! DV DESPTR = WORD CHKD
IF TYPE<=3 AND PARMARR=0=FORMAT AND PARMCHK=0 C
AND J=1 THEN AH2=AH2-STALLOC*LB
PGLA(8,16,ADDR(AH1))
TAGDISP=GLACA-16
IF EXTRN=3 THEN START ; ! EXTRINSIC ARRAYS
GXREF(NAMTXT,2,2<<24!QQ,TAGDISP+4); ! RELOCATE ADDR(A(FIRST))
FINISH ELSE START
RELOCATE(TAGDISP+4,AH2,LPUTP); ! RELOCATE ADDR(A(FIRST))
FINISH
RELOCATE(TAGDISP+12,AH4,1); ! RELOCATE DV POINTER
AH4=(AH4<<1>>3)!X'80000000'
NOTE CREF(AH4!(TAGDISP+12)>>2<<16)
EPTYPE=5; ! DATA IN GLA SYMBOL TABLES
STAG(TAGDISP,QQ)
->BEND
ROUTINE INIT SPACE(INTEGER SIZE, NELS)
!***********************************************************************
!* P IS TO FIRST ENTRY FOR CONSTLIST *
!* MAP SPACE ONTO WORKFILE END TO GIVE SANE ERROR MESSAGE IF *
!* THERE WAS NOT ENOUGH SPACE *
!***********************************************************************
INTEGER RF, I, II, ELSIZE, AD, SPP, LENGTH, SAVER, WRIT
BYTEINTEGERARRAYNAME SP
BYTEINTEGERARRAYFORMAT SPF(0:4096+256)
SAVER=R; R=R+(4096+256)
IF R>ARSIZE THEN FAULT(102, WKFILEK,0)
SP==ARRAY(ADDR(A(SAVER)),SPF)
IF TYPE=1 THEN AD=ADDR(ICONST)+4-ACC
IF TYPE=2 THEN AD=ADDR(RCONST)
IF TYPE=3 THEN AD=ADDR(ICONST)+3
IF TYPE=5 THEN AD=ADDR(SCONST)
SPP=0; WRIT=0
ELSIZE=SIZE//NELS
UNTIL A(P-1)=2 CYCLE
XTRACT CONST(TYPE,PREC)
IF A(P)=1 START ; ! REPITITION FACTOR
P=P+2
IF A(P-1)=2 THEN RF=NELS-CONSTS FOUND ELSE START
P=P+2
IF INTEXP(RF)#0 THEN FAULT(41,0,0) AND RF=1
FINISH
P=P+1
FINISH ELSE RF=1 AND P=P+2
FAULT(42,RF,0) IF RF<=0
CYCLE I=RF,-1,1
CYCLE II=0,1,ELSIZE-1
IF CONSTS FOUND<=NELS THEN SP(SPP)= C
BYTE INTEGER(AD+II) AND SPP=SPP+1
REPEAT
CONSTS FOUND=CONSTS FOUND+1
IF SPP>=4096 START ; ! EMPTY BUFFER
LPUT(LPUTP,SPP,STPTR+WRIT,ADDR(SP(0))) C
IF INHCODE=0
WRIT=WRIT+SPP
SPP=0
FINISH
REPEAT
REPEAT ; ! UNTIL P<ROCL>=%NULL
IF CONSTS FOUND#NELS THEN FAULT(45,CONSTS FOUND,NELS)
STPTR=(STPTR+3)&(-4)
LENGTH=(SIZE+3)&(-4)
LPUT(LPUTP,LENGTH-WRIT,STPTR+WRIT,ADDR(SP(0))) C
IF INHCODE=0
STPTR=STPTR+LENGTH
IF COMPILER=0 AND STPTR>256*WKFILEK THEN FAULT(102,WKFILEK,0)
! TOO MANY OWNS OR CONSTS
R=SAVER
END
ROUTINE CLEAR(INTEGER LENGTH)
STPTR=(STPTR+3)&(-4)
LENGTH=(LENGTH+3)&(-4)
LPUT(LPUTP,LENGTH,STPTR,0) IF INHCODE=0
STPTR=STPTR+LENGTH
END
ROUTINE STAG(INTEGER J, DATALEN)
IF EXTRN=2 THEN LPUT(14,EPTYPE<<24!DATALEN,EPDISP,ADDR( C
NAMTXT))
RBASE=0
STORE TAG(K,J)
RBASE=RLEVEL
END
ROUTINE XTRACT CONST(INTEGER CONTYPE, CONPREC)
!***********************************************************************
!* P POINTS TO P<+'> OF <+'><OPERNAD><RESTOFEXPR> AND IS UPDATED*
!* THE CONST IS CONVERTED TO REQUIRED FORM AND IF INTEGER *
!* IS LEFT IN ICONST, IF REAL IN RCONST AND IF STRING IN SCONST *
!***********************************************************************
INTEGER LENGTH, STYPE, SACC, CPREC, MODE, I
STYPE=PTYPE; SACC=ACC; ! MAY BE CHANGED IF CONST IS EXPR
IF CONTYPE=5 THEN START
CTYPE=5
IF A(P)=4 AND A(P+1)=2 AND A(P+2)=X'35' C
AND A(P+A(P+7)+8)=2 START
SCONST=STRING(ADDR(A(P+7)))
LENGTH=A(P+7)
P=P+A(P+7)+9
FINISH ELSE START
FAULT(44,CONSTS FOUND,K); SCONST=""
LENGTH=0; P=P-3; SKIP EXP
FINISH
FINISH ELSE START
MODE=CONPREC<<4!CONTYPE
IF CONPREC<5 THEN MODE=CONTYPE!X'50'
CONSTP=CONSTEXP(MODE)
IF CONSTP=0 THEN START
FAULT(41,0,0)
FAULT(44,CONSTSFOUND,K)
CONSTP=ADDR(ZERO)
FINISH
! CANT EVALUATE EXPT
CTYPE=TYPE; CPREC=PREC
IF CTYPE=1 THEN START
ICONST=INTEGER(CONSTP)
IF CONPREC=6 THEN UICONST=ICONST C
AND ICONST=INTEGER(CONSTP+4)
FINISH ELSE START
RCONST=LONGREAL(CONSTP)
IF CONPREC=7 THEN START ; ! LONGLONGS UNALIGNED IN AR
CYCLE I=0,1,15
BYTEINTEGER(ADDR(RCONST)+I)=BYTEINTEGER( C
CONSTP+I)
REPEAT
FINISH
FINISH
FINISH
PTYPE=STYPE; UNPACK; ACC=SACC
!
! FAULT ANY OBVIOUS ERRORS IE:-
! CONSTANT FOR EXTRINSIC OR INCOMPATIBLE TYPE OR STRING TOO LONG
! FOR OWN OR EXTERNAL. CONSTS LENGTHS ARE REVISED HERE.
!
IF EXTRN=3 THEN FAULT(49,0,K) AND RETURN
IF (CTYPE=5 AND LENGTH>=ACC AND (EXTRN#0 OR ARR#0)) C
OR (CONTYPE=1 AND ((CONPREC=3 AND ICONST>255) C
OR (CONPREC=4 AND ICONST>X'FFFF'))) C
THEN FAULT(44,CONSTS FOUND,K)
END
BEND: END ; ->CSSEXIT
SW(10):
BEGIN ; ! %RECORDFORMAT (RDECLN)
INTEGER NAME,OPHEAD,OPBOT,NLIST,MRL,CELLREF,FHEAD,SPEC
RECORD (LISTF)NAME LCELL,FRCELL
SNDISP=0
SPEC=A(P+1); ! 1 FOR SPEC 2 FOR FORMAT
NAME=FROM AR2(P+2); P=P+4
COPY TAG(NAME)
IF SPEC=1 OR NOT (PTYPE=4 AND J=15 AND OLDI=LEVEL) START
KFORM=0
PUSH(KFORM,0,0,0)
ACC=X'7FFF'
PTYPE=4; J=15
STORETAG(NAME,KFORM); ! IN CASE OF REFS IN FORMAT
FINISH
IF SPEC=2 START
OPHEAD=0; OPBOT=0
NLIST=0; MRL=0
INAFORMAT=1
CRFORMAT(OPHEAD,OPBOT,NLIST,MRL,X'80000000')
INAFORMAT=0
CLEAR LIST(NLIST)
!
! IN CASE OF FORWARD REFS COPY TOP CELL OF FORMAT CHAIN INTO DUMMY
! SET UP BEFORE CALL OF CRFORMAT. ALSO RESET J&ACC TO CORRECT VALUE
!
LCELL==ASLIST(TAGS(NAME))
KFORM=LCELL_KFORM
POP(KFORM,I,I,FHEAD); ! THROW DUMMY CELL
! GET HEAD OF FORWARD REFS
WHILE FHEAD>0 CYCLE ; ! THROUGH FORWARD REFS
POP(FHEAD,CELLREF,I,I)
FRCELL==ASLIST(CELLREF)
FRCELL_UIOJ=FRCELL_UIOJ&X'FFFFFFF0';! SET J BACK TO 0
FRCELL_ACC=ACC; ! ACC TO CORRECT VALUE
FRCELL_KFORM=OPHEAD; ! CORRECT KFORM
REPEAT
LCELL_UIOJ=LCELL_UIOJ&X'FFFFFFF0'; ! J BACK TO ZERO
LCELL_ACC=ACC
LCELL_SLINK=OPHEAD; ! KFORM&SLINK(HISTORIC) TO SIDECHAIN
LCELL_KFORM=OPHEAD
FINISH
END ;->CSSEXIT
!
SW(19):
! '*' (UCI) (S)
FAULT(57,0,0) UNLESS LEVEL>=2
BEGIN
ROUTINESPEC CIND
INTEGER FNAME,ALT,OPCODE,FORM,H,Q,MASK,FILLER
SWITCH SW,F(1:4),POP(1:6),TOP(1:4)
ALT=A(P+1); P=P+2
OPCODE=CALL
->SW(ALT)
SW(1): ! PUT (HEX HALFWORD)
TYPE=A(P)
PREC=TYPE>>4; TYPE=TYPE&7
FAULT(97,0,0) UNLESS TYPE=1 AND PREC<6
IF PREC=5 THEN P=P+2
PLANT(FROM AR2(P+1))
->EXIT
SW(3): ! CNOP
CNOP(A(P),A(P+1))
->EXIT
SW(4): ! UC WRONG INCORRECT ASSEMBLER
FAULT(97,0,0)
->EXIT
SW(2): ! ASSEMBLER
FORM=A(P); ! FORM=PRIMARY,SECONDARY OR 3RY
OPCODE=A(P+1)
P=P+2; ->F(FORM)
F(1): ! ALL PRIMARY FORMAT INSTRUCTIONS
ALT=A(P); P=P+1
->POP(ALT)
POP(1): ! LABELNAME
FNAME=FROM AR2(P); P=P+2
ENTER JUMP(OPCODE<<24!3<<23,FNAME,0)
->EXIT
POP(2): ! DIRECT SYMBOLIC
CIND
POPI: PSORLF1(OPCODE,ACCESS,AREA,DISP)
->EXIT
POP(3): ! INDIRECT SYMBOLIC
CIND
ACCESS=4-A(P); P=P+1
->POPI
POP(4): ! DR SYMBOLICALLY MODIFIED
CIND; ACCESS=1; ->POPI
POP(5): ! (DR) & (DR+B)
ACCESS=4-A(P); AREA=7
DISP=0; P=P+1
->POPI
POP(6): ! B
ACCESS=0
AREA=7; DISP=0; ->POPI
F(2): ! SECONDARY (STORE-TO STORE)FORMAT
MASK=0; FILLER=0; Q=0; FNAME=0
H=2-A(P)
IF H=0 THEN FNAME=FROM AR2(P+1)-1 AND P=P+2
FAULT(96,FNAME+1,0) UNLESS 0<=FNAME<=127
ALT=A(P+1); P=P+2
IF ALT=1 THEN START
Q=1
MASK=FROM AR2(P)
FILLER=FROM AR2(P+2)
P=P+4
IF MASK>255 THEN FAULT(96,MASK,0)
IF FILLER>255 THEN FAULT(96,FILLER,0)
FINISH
PF2(OPCODE,H,Q,FNAME,MASK,FILLER)
->EXIT
F(3): ! TERTIARY FORMAT
MASK=FROM AR2(P)
ALT=A(P+2)
FAULT(96,MASK,0) UNLESS 0<=MASK<=15
P=P+3; ->TOP(ALT)
TOP(1): ! LABEL
FNAME=FROM AR2(P); P=P+2
ENTER JUMP(OPCODE<<24!MASK<<21,FNAME,0)
->EXIT
TOP(2): ! SYMBOLIC OPERAND
CIND
FAULT(97,0,0) IF AREA>=6
IF AREA=LNB OR AREA=XNB OR AREA=CTB THEN DISP=DISP//4
TOPI: PF3(OPCODE,MASK,AREA,DISP)
->EXIT
TOP(3): ! (DR) & (DR+B)
DISP=0; AREA=8-A(P)
P=P+1; ->TOPI
TOP(4): ! (DR+N)
DISP=FROM AR2(P); P=P+2
AREA=1; ->TOPI
ROUTINE CIND
!***********************************************************************
!* COMPILE A SYMBOLIC OPERAND BY SETTING ACCESS,AREA &DISP *
!***********************************************************************
INTEGER ALT,AFN,FN0,FN1,FN2,FN3,JJ,D,CTYPE,CPREC
SWITCH SW(1:4)
AFN=ADDR(FN0)
FN0=0; FN1=0; FN2=0; FN3=0
ALT=A(P); ACCESS=0
P=P+1; ->SW(ALT)
SW(1): ! (=')(PLUS')(ICONST)
P=P+1; ! PAST (=')
D=A(P); CTYPE=A(P+1)
CPREC=CTYPE>>4; CTYPE=CTYPE&7
IF CPREC=4 THEN FN0=FROM AR2(P+2) ELSE START
CYCLE JJ=0,1,BYTES(CPREC)-1
BYTEINTEGER(AFN+JJ)=A(P+JJ+2)
REPEAT
FINISH
P=P+2+BYTES(CPREC)
IF D=2 THEN START
IF CTYPE=2 THEN FN0=FN0!!X'80000000' ELSE START
IF CPREC=6 THEN LONGINTEGER(AFN)=-LONGINTEGER(AFN) C
ELSE FN0=-FN0
FINISH
FINISH
CNST: ->LIT UNLESS CTYPE=1 AND CPREC<=5 AND C
X'FFFE0000'<=FN0<=X'1FFFF'
AREA=0; DISP=FN0
RETURN
LIT: FAULT(96,FN0,0) UNLESS 1<=CTYPE<=2 AND 5<=CPREC<=7
STORE CONST(DISP,BYTES(CPREC),AFN)
AREA=PC; ACCESS=0
RETURN
SW(2): ! (NAME)(OPTINC)
FN0=FROM AR2(P); P=P+2
COPY TAG(FN0)
IF (LITL=1 AND NAM=ARR=0) START
CTYPE=TYPE; CPREC=PREC
ALT=TAGS(FN0)
FROM123(ALT,D,FN0,FN1)
IF CPREC=7 THEN AFN=FN1
->CNST
FINISH
IF TYPE>=6 OR TYPE=4 OR C
(ROUT=1 AND NAM=0) THEN FAULT(95,0,FN0) AND RETURN
IF ROUT=1 THEN K=FROM1(K)
AREA=LNB
IF I#RBASE THEN AREA=SET XORYNB(XNB,I)
ALT=A(P); D=FROM AR2(P+1)
IF ALT=1 THEN K=K+D
IF ALT=2 THEN K=K-D
P=P+1; P=P+2 IF ALT<=2
DISP=K; RETURN
SW(3): ! '('(REG)(OPTINC)')'
AREA=A(P)+1; ALT=A(P+1); P=P+2
DISP=0
D=FROM AR2(P)
IF ALT=1 THEN DISP=D
IF ALT=2 THEN FAULT(96,-D,0)
IF AREA=PC THEN DISP=CA+2*DISP ELSE DISP=4*DISP
P=P+2 UNLESS ALT=3
RETURN
SW(4): ! '%TOS'
AREA=6; DISP=0
END
EXIT: GRUSE(ACCR)=0
GRUSE(DR)=0
GRUSE(BREG)=0
GRUSE(XNB)=0 IF OPCODE=CALL OR OPCODE=LXN OR OPCODE=JLK C
OR OPCODE=OUT
GRUSE(CTB)=0 IF OPCODE=CALL OR OPCODE=LCT OR OPCODE=JLK C
OR OPCODE=OUT
END
->CSSEXIT
SW(20):
! '%TRUSTEDPROGRAM'
COMPILER=1 IF PARMARR=0 AND PARMCHK=0; ->CSSEXIT
SW(21): ! '%MAINEP'(NAME)
KK=FROM AR2(P+1)
FAULT(97,0,0) UNLESS CPRMODE=0
MAINEP<-STRING(DICTBASE+WORD(KK))
->CSSEXIT
INTEGERFN CFORMATREF
!***********************************************************************
!* P IS TO ALT OF FORMAT REF *
!* P<FORMTAREF>::=(NAME),(RFDEC)(RESTOFRFDEC)(ALTRFDEC) *
!* RETURNS CELL NO OF TOP CELL OF THE FORMATLIST *
!***********************************************************************
INTEGER FNAM,OPHEAD,OPBOT,NHEAD,MRL
RECORD (LISTF)NAME LCELL
IF A(P)=1 START ; ! A RECORD OF RECORDFORMAT NAME
FNAM=FROM AR2(P+1)
P=P+3
COPY TAG(FNAM)
IF 3<=TYPE<=4 THEN RESULT =KFORM
IF INAFORMAT#0 AND OLDI#LEVEL START
KFORM=0; SNDISP=0;ACC=X'7FFF'
PTYPE=4; J=15
PUSH(KFORM,0,0,0)
STORE TAG(FNAM,KFORM)
RESULT =KFORM
FINISH
FAULT(62,0,FNAM); ! NOT A RECORD OF FORMAT NAME
ACC=8; ! GUESS A RECORD SIZE
RESULT =DUMMY FORMAT
FINISH
! FORMAT ACTUALLY SPECIFIED
P=P+1
OPHEAD=0; OPBOT=0
NHEAD=0; MRL=0
CRFORMAT(OPHEAD,OPBOT,NHEAD,MRL,X'80000000')
CLEAR LIST(NHEAD)
IF UNATT FORMATS(LEVEL)#0 START
LCELL==ASLIST(UNATT FORMATS(LEVEL))
IF LCELL_S2=0 THEN LCELL_S2=OPHEAD AND RESULT =OPHEAD
IF LCELL_S3=0 THEN LCELL_S3=OPHEAD AND RESULT =OPHEAD
FINISH
PUSH(UNATT FORMATS(LEVEL),OPHEAD,0,0)
RESULT =OPHEAD
END
ROUTINE CRFORMAT(INTEGERNAME OPHEAD, OPBOT, NLIST, MRL, INTEGER INIT)
!***********************************************************************
!* CONVERTS A RECORDFORMAT STATEMENT TO A LIST HEADED BY OPHEAD *
!* FORMAT OF AN ENTRY. *
!* S1=SUBNAME<<20!PTYPE<<4!J *
!* S2,S3=4 16 BIT DISPLACEMENTS D2,ACC,D1,KFORM *
!* NORMALLY D1=RECORD RELATIVE DISPLACEMENT AND ACC=LMAX(STRINGS)*
!* FOR ARRAYS D2=FIRST ELEMENT DISPLACEMENT AND D1=DISPLACEMENT *
!* OF RECORD RELATIVE ARRAYHEAD IN THE GLA *
!* KFORM IS ONLY USED FOR RECORDS AND POINTS TO THE FORMAT *
!* ON EXIT ACC HAS THE RECORD SIZE ROUNDED UP TO THE BOUNDARY *
!* REQUIRED BY ITS LARGEST COMPONENT *
!***********************************************************************
INTEGER D1, D2, FORM, RL, UNSCAL, SC, DESC, STALLOC, INC, Q, C
R, A0, A1, A2, DV, RFD, LB, TYPEP, SACC
ROUTINESPEC SN(INTEGER Q)
ROUTINESPEC ROUND
FORM=0; ACC=0
INC=INIT&X'FFFF'; ! INC COUNTS DOWN RECORD
CYCLE
ROUT=0; LITL=0; NAM=0; RFD=A(P)
P=P+1
IF RFD=1 THEN START
CLT
FORM=KFORM
STALLOC=ACC
P=P+1
IF A(P-1)=1 START
! (TYPE) (QNAME')(NAMELIST)
FORM=KFORM
CQN(P); P=P+1
IF NAM=1 THEN START
STALLOC=8
IF ARR#0 THEN STALLOC=16
FINISH
PACK(PTYPE); D2=0
RL=3
IF NAM=0 AND TYPE#3 AND 3<=PREC<=4 C
THEN RL=PREC-3
ROUND; J=0
UNTIL A(P-1)=2 CYCLE
D1=INC; SN(P)
P=P+3; INC=INC+STALLOC
REPEAT
FINISH ELSE START
! (TYPE)%ARRAY(NAMELIST)(BPAIR)
Q=P+1; ARR=1; PACK(PTYPE)
IF TYPE<=2 THEN UNSCAL=0 AND SC=PREC C
ELSE UNSCAL=1 AND SC=3
IF PREC=4 THEN DESC=X'58000002' C
ELSE DESC=SC<<27!UNSCAL<<25!(1-PARMARR)<<24
CYCLE
P=Q
P=P+3 UNTIL A(P-1)=2
TYPEP=PTYPE; SACC=ACC
DV=DOPE VECTOR(TYPE,ACC,0,FROMAR2(Q),R,LB)+12
! DOPE VECTOR INTO SHAREABLE S.T.
ACC=SACC; PTYPE=TYPEP; UNPACK
IF TYPE=5 OR (TYPE=1 AND PREC=3) C
THEN RL=0 ELSE IF PREC=4 THEN RL=1 ELSE RL=3
ROUND
CYCLE
A0=R; IF UNSCAL=0 THEN A0=A0//ACC
IF PREC=4 THEN A0=0; ! STRING DESCRIPTORS !
A0=A0!DESC; A1=INC
IF TYPE<=3 AND PARMARR=0=PARMCHK C
AND J=1 THEN A1=A1-LB*ACC
A2=5<<27!3*J
PGLA(4,16,ADDR(A0))
D1=GLACA-16
RELOCATE(D1+12,DV,1); ! RELOCATE DV POINTER
NOTE CREF(X'80000000'!(DV<<1>>3)!(D1+12)>>2<<16)
D2=INC
SN(Q); INC=INC+R
Q=Q+3
REPEAT UNTIL A(Q-1)=2;! TILL NAMELIST NULL
P=P+1; Q=P+1
REPEAT UNTIL A(P-1)=2; ! UNTIL <RESTOFARRAYLIST> NULL
FINISH
FINISH ELSE START
! (FORMAT)
CRFORMAT(OPHEAD,OPBOT,NLIST,MRL,INC)
INC=ACC
FINISH
P=P+1
REPEAT UNTIL A(P-1)=2; ! UNTIL <RESTOFRFDEC> NULL
! FINISH OFF
IF A(P)=1 START ; ! WHILE %OR CLAUSES
P=P+1
CRFORMAT(OPHEAD,OPBOT,NLIST,MRL,INIT&X'FFFF')
IF ACC>INC THEN INC=ACC
FINISH ELSE P=P+1
IF INIT<0 THEN RL=MRL AND ROUND
ACC=INC; ! SIZE ROUNDED APPROPRIATELY
FAULT(63,X'7FFF',0) UNLESS INC<=X'7FFF'
RETURN
ROUTINE SN(INTEGER Q)
!***********************************************************************
!* CHECK THE SUBNAME HAS NOT BEEN USED BEFORE IN THIS FORMAT *
!* AND ENTER IT WITH ITS DESCRIPTORS INTO THE LIST. *
!***********************************************************************
FNAME=FROM AR2(Q)
FAULT(61,0,FNAME) UNLESS FIND(FNAME,NLIST)=-1
BINSERT(OPHEAD,OPBOT,FNAME<<20!PTYPE<<4!J,D2<<16!ACC,D1<< C
16!FORM)
PUSH(NLIST,0,FNAME,0)
IF PTYPE=X'433' AND ACC=X'7FFF' THEN C
PUSH(ASLIST(FORM)_S3,OPBOT,0,0);! NOTE FORWARD REFERENCE
END
ROUTINE ROUND
MRL=RL IF RL>MRL
INC=INC+1 WHILE INC&RL#0
END
END ; ! OF ROUTINE CRFORMAT
INTEGERFN DISPLACEMENT(INTEGER LINK)
!***********************************************************************
!* SEARCH A FORMAT LIST FOR A SUBNAME *
!* A(P) HAS ENAME--LINK IS HEAD OF RFORMAT LIST. RESULT IS DISP *
!* FROM START OF RECORD *
!***********************************************************************
RECORD (LISTF)NAME FCELL,PCELL,LCELL
INTEGER RR,II,ENAME,CELL
ENAME=A(P)<<8+A(P+1); CELL=0
IF LINK#0 THEN START ; ! CHK RECORDSPEC NOT OMITTED
FCELL==ASLIST(LINK); ! ONTO FIRST CELL
CELL=LINK; II=-1; ACC=-1
WHILE LINK>0 CYCLE
LCELL==ASLIST(LINK)
IF LCELL_S1>>20=ENAME START ;! RIGHT SUBNAME LOCATED
TCELL=LINK
RR=LCELL_S1
SNDISP=LCELL_S2
K=LCELL_S3
J=RR&15; PTYPE=RR>>4&X'FFFF'
ACC=SNDISP&X'FFFF'; SNDISP=SNDISP&X'FFFF0000'//X'10000'
KFORM=K&X'FFFF'; K=K>>16
IF LINK#CELL START ; ! NOT TOP CELL OF FORMAT
PCELL_LINK=LCELL_LINK
LCELL_LINK=FCELL_LINK
FCELL_LINK=LINK
FINISH ; ! ARRANGING LIST WITH THIS SUBNAME
! NEXT TO THE TOP
RESULT =K
FINISH
PCELL==LCELL
LINK=LCELL_LINK
REPEAT
FINISH
FAULT(65,0,ENAME)
IF CELL>0 THEN C
PUSH(ASLIST(CELL)_LINK,ENAME<<20!7<<4,0,0)
PTYPE=7; TCELL=0
RESULT =-1
END
INTEGERFN COPY RECORD TAG(INTEGERNAME SUBS)
!***********************************************************************
!* PRODUCE PTYPE ETC FOR A COMPOUND NAME BY CHAINING DOWN ONE *
!* ONE OR MORE RECORD FORMAT LISTS. ON EXIT RESULT =0 IF NO *
!* SUBNAME FOUND OR SUBNAME IS OF TYPE RECORD WITH NO FURTHER *
!* SUBNAME ATTACHED. RESULT#0 IF BONE-FIDE SUBNAME LOCATED *
!* ON ENTRY KFORM HAS POINTER TO THE (FIRST ) FORMAT LIST AND *
!* P POINTS TO THE A.R. ENTRY FOR (FIRST) ENAME *
!***********************************************************************
INTEGER Q,FNAME
SUBS=0
UNTIL TYPE#3 CYCLE
FNAME=KFORM
P=P+2; SKIP APP
RESULT =0 IF A(P)=2 OR FNAME<=0;! NO (FURTHER) ENAME
SUBS=SUBS+1
P=P+1; Q=DISPLACEMENT (FNAME)
UNPACK
REPEAT
RESULT =Q+1; ! GIVES 0 IF SUBNAME NOT KNOWN
END
ROUTINE CRNAME(INTEGER Z,REG,MODE,BS,AR,DP,INTEGERNAME NAMEP)
!***********************************************************************
!* DEAL WITH RECORD ELEMENT NAMES.Z AS FOR CNAME.CLINK=TAGS(RN) *
!* MODE=ACCESS FOR RECORD(NOT THE ELEMENT!) *
!* ON EXIT BASE,AREA & DISP POINT TO REQUIRED ELEMENT *
!* RECURSIVE CALL IS NEEDED TO DEAL WITH RECORDS IN RECORDS *
!* DEPTH SHEWS RECURSIVE LEVELS- NEEDED TO AVOID MIS SETTING *
!* REGISTER IN USE IF RECORDNAME IN RECORD HAS THE SAME NAME AS *
!* A GENUINE RECORD NAME. *
!***********************************************************************
INTEGER DEPTH,FNAME
ROUTINESPEC CENAME(INTEGER MODE,FNAME,BS,AR,DP,XD)
DEPTH=0
FNAME=KFORM; ! POINTER TO FORMAT
IF ARR=0 OR (Z=6 AND A(P+2)=2) START ;! SIMPLE RECORD
IF A(P+2)=2 THEN P=P+3 ELSE NO APP
CENAME(MODE,FNAME,BS,AR,DP,0)
FINISH ELSE START
CANAME(ARR,BS,DP)
CENAME(ACCESS,FNAME,BASE,AREA,DISP,0)
FINISH ; RETURN
!
ROUTINE CENAME(INTEGER MODE,FNAME,BS,AR,DP,XD)
!***********************************************************************
!* FINDS OUT ABOUT SUBNAME AND ACTS ACCORDINGLY.MOSTLY ACTION *
!* CONSISTS OF UPPING XD BY OFFSET OF THE SUBNAME BUT IS VERY *
!* HAIRY FOR RECORDS IN RECORDS ETC *
!* MODE IS ACCESS FOR THE RECORD *
!***********************************************************************
ROUTINESPEC FETCH RAD
ROUTINESPEC LOCALISE(INTEGER SIZE)
INTEGER Q,QQ,D,C,W
DEPTH=DEPTH+1
IF A(P)=2 THEN START ; ! ENAME MISSING
ACCESS=MODE; AREA=AR; XDISP=XD
BASE=BS; DISP=DP; ! FOR POINTER
UNLESS 3<=Z<=5 OR Z=6 START ; ! ADDR(RECORD)
FAULT(64,0,NAMEP&X'FFFF'); BASE=RBASE; AREA=-1
DISP=0; ACCESS=0; PTYPE=1; UNPACK
FINISH
RETURN
FINISH
P=P+1; ! FIND OUT ABOUT SUBNAME
Q=DISPLACEMENT(FNAME); ! TCELL POINTS TO CELL HOLDING
UNPACK; ! INFO ABOUT THE SUBNAME
IF Q=-1=ACC OR PTYPE=7 START ; ! WRONG SUBNAME(HAS BEEN FAULTED)
P=P+2; SKIP APP; P=P-3
ACCESS=0; BASE=RBASE; DISP=0; AREA=-1
RETURN
FINISH
NAMEP=(A(P)<<8!A(P+1))<<16!NAMEP; ! NAMEP=-1 UNALTERED !
->AE IF ARR=1; ! ARRAYS INCLUDING RECORDARRAYS
IF A(P+2)=2 THEN P=P+3 ELSE NO APP
IF TYPE<=2 OR TYPE=5 OR C
(TYPE=3 AND A(P)=2 AND (3<=Z<=5 OR Z=6)) START
ACCESS=MODE+4+4*NAM; BASE=BS;
AREA=AR; DISP=DP; XDISP=XD+Q
RETURN
FINISH
!
! NOW CODING BECOMES HAIRY:- STILL LEFT ARE
! A) RECORDS IN RECORDS Q POINTS TO SECONDARY RECORD
! B) RECORDNAMES IN RECORDS Q HAS OFF-SET OF A POINTER
! C) RECORDARRAYNAMES IN RECORDS Q HAS OFF-SET A HEADER IN RECORD
! D) RECORDARRAYS IN RECORDS NOT YET ALLOWED
! Q WOULD HAVE OFF-SET OF A RECORD RELATIVE HEADER IN THE GLA
!
XD=XD+Q
NAMEP=-1
IF NAM=1 THEN START
IF MODE=0 START
DP=DP+XD; XD=0; MODE=2
FINISH ELSE START
LOCALISE(8); ! PICK UP RECNAME DESCR &STCK
AR=AREA; DP=DISP; BS=BASE
FINISH
FINISH
CENAME(MODE,KFORM,BS,AR,DP,XD)
RETURN
AE: ! ARRAYS AND ARRAYNAMES AS ELEMEN
FROM123(TCELL,Q,SNDISP,K)
ACC=SNDISP&X'FFFF'; SNDISP=SNDISP&X'FFFF0000'//X'10000'
KFORM=K&X'FFFF'; K=K>>16
C=ACC; D=SNDISP; Q=K; QQ=KFORM
IF (Z=6 OR Z=12) AND A(P+2)=2 START ;! 'GET ARRAYHEAD' CALL
P=P+3
IF NAM=1 THEN START
ACCESS=MODE+8; BASE=BS
AREA=AR; DISP=DP; XDISP=XD+Q
RETURN
FINISH
!
! PASSING AN ARRAY IN A RECORD BY NAME MUST CONSTRUCT PROPER ARRAYHEAD
! FROM THE RECORD RELATIVE ONE AT Q(GLA)
!
NAMEP=-1
FETCH RAD
AREA=-1; DISP=Q
BASE=0; ACCESS=0;
CREATE AH(1)
FINISH ELSE START ; ! ARRAY ELEMENTS IN RECORDS
NAMEP=-1
IF NAM=1 THEN START ; ! ARRAYNAMES-FULLHEAD IN RECORD
XD=XD+Q
LOCALISE(16); ! MOVE HEAD UNDER LNB
CANAME(3,BASE,DISP); ! ARRAY MODE SETS DISP,AREA&BASE
FINISH ELSE START ; ! ARRAY RELATIVE HEAD IN GLA
IF MODE=0 OR MODE=2 START
IF MODE=0 THEN W=DP-4 ELSE W=DP+4
FINISH ELSE START
FETCH RAD; ! RECORD ADDR TO ACC
GET WSP(W,1)
PSF1(ST,1,W); XD=0
BS=RBASE
FINISH
CANAME(3,0,Q); ! RECORD REL ARRAY ACCESS
! CAN RETURN ACCESS=1 OR 3 ONLY
IF PARMARR=0=PARMCHK AND ACCESS=3 AND C
(PREC=3 OR TYPE>=3) START
PSORLF1(ADB,0,AREA CODE2(BS),W)
PSF1(ADB,0,XD) UNLESS XD=0
GRUSE(BREG)=0
FINISH ELSE START
GET IN ACC(DR,2,0,AREA CODE,Q)
PSORLF1(INCA,0,AREA CODE2(BS),W)
IF ACCESS=1 THEN START
ACCESS=2; AREA=7
IF PREC=4 THEN XD=XD+NUMMOD ELSE C
XD=XD+NUMMOD*BYTES(PREC);! HALF ALREADY SCALED BY 'VMY'
FINISH
PSF1(INCA,0,XD) UNLESS XD=0
FORGET (DR)
AREA=7; DISP=0; ! AND ACCESS = 2 OR 3 ONLY
IF TYPE=3 AND A(P)=1 START ; ! WILL BE A FURTHER CALL
! ON ROUTINE CENAME
GET WSP(DISP,2)
PSF1(STD,1,DISP)
AREA=LNB; BASE=RBASE
FINISH
FINISH
FINISH
IF TYPE=3 THEN CENAME(ACCESS,QQ,BASE,AREA,DISP,0)
FINISH
RETURN
ROUTINE FETCH RAD
!***********************************************************************
!* SET ACC TO 32 BIT ADDRESS OF RECORD. *
!***********************************************************************
ACCESS=MODE+4
AREA=AR; BASE=BS
DISP=DP; XDISP=XD
NAMEOP(4,ACCR,4,-1)
END
ROUTINE LOCALISE(INTEGER SIZE)
!***********************************************************************
!* REMOVES A DESCRIPTOR OR ARRAYHEAD FROM A RECORD AND STORES *
!* IT IN A TEMPORARY UNDER LNB. *
!***********************************************************************
INTEGER HOLE
ACCESS=MODE+4
AREA=AR; BASE=BS; DISP=DP
XDISP=XD
NAMEOP(2,ACCR,SIZE,-1)
GET WSP(HOLE,SIZE>>2)
PSF1(ST,1,HOLE)
MODE=2; AREA=LNB
BASE=RBASE; DISP=HOLE; XD=0
END ; ! OF ROUTINE LOCALISE
END ; ! OF ROUTINE CENAME
END ; ! OF ROUTINE CRNAME
ROUTINE CSTREXP(INTEGER MODE,REG)
!***********************************************************************
!* PLANT IN-LINE CODE FOR CONCATENATION. A WORK AREA UNDER *
!* BASE REGISTER COVER IS USUALLY REQUIRED. THE CURRENT LENGTH *
!* OF STRING IN THE WORK AREA IS KEPT IN A REGISTER (BREG) *
!* WHICH IS PROTECTED THROUGH THE NORMAL INTERMEDIATE-RESULT *
!* MECHANISMS. *
!* ON ENTRY:- *
!* MODE=0 NORMAL. WK AREA NOT USED FOR ONE OPERAND EXPSSNS *
!* MODE=1 STRING MUST GO TO WORK AREA *
!* (AND TO COME) *
!* MODE=3 CONCATENATE INTO LHS OF =ASSNMNT (E.G. A=B.C) *
!* MODE=4 OPTIMISE S=S.T BY NOT COPYING S *
!* 2**4 BIT OF MODE IS SET IF WK-AREA NOT TO BE FREED ON EXIT *
!* ON EXIT:- *
!* BASE,DISP & INDEX DEFINE RESULT *
!* VALUE#0 %IF RESULT IN A WORK AREA(CCOND MUST KNOW) *
!* STRINGL SET IF STRING LENGTH KNOWN. STRFNRES DEFINES LENREG *
!***********************************************************************
INTEGER PP,WKAREA,DOTS,REXP,ERR,CLEN,KEEPWA,FNAM
INTEGERFNSPEC STROP(INTEGER REG)
KEEPWA=MODE&16; MODE=MODE&15
PP=P; STRINGL=0; FNAM=0; WKAREA=0
REXP=2-A(P+1+FROM AR2(P+1)); ! =0 %IF ONE OPERAND EXP
-> NORMAL UNLESS A(P+3)=4 AND REXP=0 AND MODE=0
-> SIMPLE IF A(P+4)=2
-> NORMAL UNLESS A(P+4)=1
! COPY TAG(FROM AR2(P+5))
! %IF PTYPE=SNPT %THEN PTYPE=TSNAME(K)
! -> NORMAL %UNLESS ROUT=0 ; ! BEWARE OF MAP=FN
! -> NORMAL %IF PARMARR=1 %AND(ARR#0 %OR A(P+7)=1)
SIMPLE: P=P+4
ERR=STROP(REG)
-> ERROR UNLESS ERR=0
VALUE=WKAREA
P=P+1; STRFNRES=0
RETURN
ERROR: FAULT(ERR,0,FNAM)
BASE=RBASE; DISP=0
VALUE=0; ACCESS=0
P=PP; SKIP EXP
RETURN
NORMAL: CLEN=0; P=P+3; ! LENGTH OF CONSTANT PART
ERR=72; ->ERROR UNLESS A(P)=4
P=P+1
GET WSP(WKAREA,268); ! GET NEXT OPERAND
DOTS=0; ! NO OPERATORS YET
NEXT: STRINGL=0
ERR=STROP(DR); ! GET NEXT OPERAND
-> ERROR UNLESS ERR=0
IF REGISTER(ACCR)#0 THEN BOOT OUT(ACCR)
PSF1(LB,0,WKAREA); ! BYTE DISP FROM LNB
PPJ(0,19+DOTS); ! TO SUBROUTINE 19 OR 20
IF A(P)=2 THEN -> TIDY; ! NO MORE OPERATIONS
ERR=72; -> ERROR UNLESS A(P+1)=CONCOP; ! CONCATENATE
DOTS=DOTS!1
P=P+2; -> NEXT
TIDY: ! FINISH OFF
VALUE=WKAREA
P=P+1; ! PAST REST OF EXPRN
RETURN WSP(WKAREA,268) IF KEEPWA=0
STRINGL=0
RETURN
INTEGERFN STROP(INTEGER REG)
!***********************************************************************
!* DEALS WITH OPERAND FOR CONCATENATION. RETURN RESULT=0 FOR *
!* VALID OPERAND OTHERWISE AN ERROR NUMBER. *
!***********************************************************************
INTEGER CTYPE,MODE
MODE=A(P); ! ALTERNATIVE OF OPERAND
RESULT =75 IF MODE>2
IF MODE#1 THEN START
CTYPE=A(P+1); ! GET CONST TYPE & LOSE AMCK FLAGS
IF CTYPE=X'35' THEN START
STRINGL=A(P+6)
DISP=FROM AR4(P+2)
P=P+STRINGL+7
FINISH ELSE RESULT =73
PF1(LDRL,0,PC,STRLINK)
PSF1(INCA,0,DISP) IF DISP#0
IF STRINGL#1 THEN START
IF STRINGL<=63 THEN PSF1(LDB,0,STRINGL) C
ELSE PF1(LDB,2,7,0);! ((DR))
FINISH
GRUSE(DR)=0
IF REG=ACCR THEN COPY DR
FINISH ELSE START
P=P+1; ! MUST CHECK FIRST
REDUCE TAG; ! SINCE CNAME ONLY LOADS STRINGS
! AND LONGINTS TO DR!
IF 5#TYPE#7 THEN FNAM=FROMAR2(P) AND RESULT =71
CNAME(2,REG)
IF LITL=1 AND ROUT=0 AND ARR=NAM=0 THEN STRINGL=ACC-1 C
ELSE STRINGL=0
IF ROUT#0 AND NAM<=1AND STRFNRES#0 START ;! WAS FUNCTION NOT MAP
IF WKAREA=0 AND KEEPWA#0 THEN C
WKAREA=STRFNRES ELSE RETURN WSP(STRFNRES,268)
FINISH
FINISH
RESULT =0
END ; ! OF INTEGERFN STROP
END ; ! OF ROUTINE CSTREXP
ROUTINE CRES (INTEGER LAB)
!**********************************************************************
!* COMPILES A RESOLUTION E.G A->B.(C).D.(E).F AND JUMPS TO LAB *
!* ON FAILURE. (LAB=0 FOR UNCONDITIONAL RESOLUTION TO PERM ON *
!* FAILURE ). *
!* THE METHOD IS TO CALL A SUBROUTINE PASSING 3 PARAMS:- *
!* P1 POINTS TO LHS(A) *
!* P2 STRING TO CONTAIN FRAGMENT (PASSED BY NAME) *
!* P3 THE EXPRESSION PASSED AS DESCRIPTOR *
!* SUBROUTINE TRIES TO PERFORM THE RESOLUTION AND SETS THE *
!* CONDITION CODE =8 IF IT SUCCEEDS. *
!* *
!* ON ENTRY LHS IS DEFINED BY DESCRIPTOR REG. *
!* P POINTS TO P(+') OF RHS DEFINED AS (+')(OPERAND)(RESTOFEXP) *
!* *
!$ THE ROUTINE IS COMPACT BUT DIFFICULT TO FOLLOW (OR ALTER) *
!* THE TIME IN PERM IS LARGE SO IT IS NOT WORTHWHILE TO PERSUE *
!* CODE EFFICIENCY TOO INDUSTRIOUSLY . *
!**********************************************************************
INTEGER P1,P2,SEXPRN,W,LAST,ERR,FNAM
RECORD (RD) R
LAST=0; FNAM=0; ! =1 WHEN END OF EXPRNSN FOUND
SEXPRN=0; ! RESOLUTION(BRKTD) EXPRESSNS
ERR=74; ! NORMAL CRES FAULT
PSF1(INCA,0,1); ! TO FIRST CHAR
P1=P; P=P+3
->RES IF A(P)=4; ! LHS MUST BE A STRING
! BUT THIS CHECKED BEFORE CALL
ERR=74
ERROR: FAULT(ERR,0,FNAM)
P=P1; SKIP EXP; RETURN
RES: P=P+1; ! TO P(OPERAND)
PSF1(PRCL,0,4)
IF SEXPRN=0 THEN W=STD ELSE W=ST
PF1(W,0,TOS,0)
IF A(P)=3 THEN PSF1(LSD,0,0) AND GRUSE(ACCR)=0 ELSE START ;! B OMITTED
->ERROR UNLESS A(P)=1; ! P(OPERAND)=NAME
P=P+1; P2=P
CNAME(3,ACCR)
IF TYPE#5 THEN ERR=71 AND FNAM=FROMAR2(P2) AND ->ERROR
IF A(P)=2 THEN ->ERROR; ! END OF EXPRESSION PREMATURELY
IF A(P+1)#CONCOP THEN ERR=72 AND ->ERROR
P=P+2
FINISH
PF1(ST,0,TOS,0); ! B (OR DUMMY) TO P2
->ERROR UNLESS A(P)=3; ! P(OPERAND)='('(EXPR)')'
SEXPRN=SEXPRN+1; P=P+1
CSTREXP(0,DR); ! TO REGISTER DR
!
PF1(STD,0,TOS,0)
PSF1(RALN,0,11)
PPJ(-1,16)
! DEAL WITH CC#8 IE RESLN FAILED
IF LAB#0 THEN ENTER JUMP(7,LAB,B'11') ELSE PPJ(7,12)
!
-> END IF A(P)=2
IF A(P+1)#CONCOP THEN ERR=72 AND ->ERROR
P2=P+1; P=P2+1
IF A(P)=3 THEN P=P2 AND ->RES
->ERROR UNLESS A(P)=1
P=P+3 AND SKIP APP UNTIL A(P)=2
IF A(P+1)=1 THEN P=P2 AND ->RES
P1=P+1
REGISTER(ACCR)=1
OLINK(ACCR)=ADDR(R)
R_PTYPE=1; R_XB=ACCR
R_FLAG=9
P=P2+2; CNAME(1,DR)
IF R_FLAG#9 THEN PF1(LSD,0,TOS,0)
REGISTER(ACCR)=0
PF1(STUH,0,BREG,0)
PF1(LUH,0,BREG,0)
PF2(MVL,0,0,0,0,0)
IF ROUT#0 OR NAM#0 THEN PPJ(0,18);! ASSNMNT CHECK (Q.V)
PF2(MV,1,1,0,0,UNASSPAT&255)
GRUSE(ACCR)=0
IF PARMARR=1 START
PSF1(USH,0,8)
PSF1(USH,0,-40)
PPJ(36,9)
FINISH
P=P1
END:
P=P+1
END
ROUTINE SAVE AUX STACK
!***********************************************************************
!* COPY AUX STACK DESCRPTR & POINTER INTO CURRENT STACK FRAME *
!* FIVE WORDS ARE USED FOR THIS PURPOSE:- *
!* 1&2 HOLD AUX STACK DESCRIPTOR *
!* 3 HOLDS VALUE AT BLK ENTRY FOR USE AT EXIT *
!* 4 HOLDS STACKTOP VALUE AFTER ALL ARRAY DECLNS(FOR %ONS) *
!* 5 HOLD STACKLIMIT FOR CHECKING AT ARRAY DECLARATIONS *
!* THE LATTER IS OMITTED INPARM=OPT *
!***********************************************************************
INTEGER XYNB, DR0, DR1
IF AUXST=0 THEN START ; ! FIRST REF PUT REF IN PLT
DR0=X'30000001'; DR1=0
PGLA(8,8,ADDR(DR0))
AUXST=GLACA-8
GXREF(AUXSTEP,2,X'02000008',AUXST+4)
FINISH
IF AUXSBASE(LEVEL)=0 START
XYNB=SET XORYNB(-1,-1)
PF1(LD,2,XYNB,AUXST)
IF PARMOPT#0 THEN START
PF1(LSS,1,0,2); ! PICK UP STACKTOP
PSF1(ST,1,N+16)
FINISH
PF1(LSS,2,7,0)
PSF1(STD,1,N)
PSF1(ST,1,N+8)
AUXSBASE(LEVEL)=N; N=N+16
IF PARMOPT#0 THEN N=N+4
GRUSE(DR)=0; GRUSE(ACCR)=11; GRINF1(ACCR)=0
FINISH
END
ROUTINE RESET AUX STACK
!***********************************************************************
!* IF ANY ARRAYS HAVE BEEN PUT ON THE AUXSTACK THEN UNDECLARE *
!***********************************************************************
IF AUXSBASE(LEVEL)#0 START
PSF1(LB,1,AUXSBASE(LEVEL)+8)
PSF1(STB,2,AUXSBASE(LEVEL))
GRUSE(BREG)=0
FINISH
END
ROUTINE RT EXIT
!***********************************************************************
!* THIS ROUTINE COMPILES CODE FOR ROUTINE EXIT(IE '%RETURN') *
!***********************************************************************
RESET AUX STACK
PSF1(EXIT,0,-X'40')
END
ROUTINE CLAIM ST FRAME(INTEGER AT,VALUE)
!***********************************************************************
!* FILL ASF INSTN IN RT ENTRY SEQUENCE TO CLAIM THE STACKFRAME *
!***********************************************************************
INTEGER INSTR, WK
WK=AT>>18; ! BYTES CLAIMED BY ENTRY SEQ
AT=AT&X'3FFFF'; ! ADRR OF ASF INSTRN
INSTR=(ASF+12*PARMCHK)<<24!3<<23!(VALUE-WK+3)>>2
PLUG(1,AT,INSTR,4)
END
ROUTINE CEND (INTEGER KKK)
!***********************************************************************
!* DEAL WITH ALL OCCURENCES OF '%END' *
!* KKK=PTYPE(>=X'1000') FOR ROUTINES,FNS AND MAPS *
!* KKK=0 FOR ENDS OF '%BEGIN' BLOCKS *
!* KKK=1 FOR '%ENDOFPROGRAM' *
!* %ENDOFPROGRAM IS REALLY TWO ENDS. THE FIRST IS THE USERS *
!* AND THE SECOND IS PERMS. KKK=2 FOR A RECURSIVE CALL OF CEND *
!* ON END OF PROGRAM TO DEAL WITH THE %END CORRESPONDING TO *
!* THE %BEGIN COMPILED IN THE INITIALISATION SEQUENCE *
!***********************************************************************
INTEGER KP,JJ,BIT
ROUTINESPEC DTABLE(INTEGER LEVEL)
SET LINE UNLESS KKK=2
FORGET(-1)
BIT=1<<LEVEL
!
! 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'
IF 0<KP<=MAX ULAB THEN FAULT(11,FROM3(J),KP)
CLEAR LIST(J)
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
WHILE UNATT FORMATS(LEVEL)#0 CYCLE
POP(UNATT FORMATS(LEVEL),I,J,JJ)
CLEAR LIST(I)
CLEAR LIST(J)
CLEAR LIST(JJ)
REPEAT
!
! CLEAR DECLARATIONS - POP UP ANY GLOBAL NAMES THAT WERE REDECLARED
! DESTROY SIDE CHAINS FOR ROUTINES,FORMATS AND SWITCHES
!
!
! NOW CLAIM THE STACK FRAME BY FILING THE ASF IN THE BLOCK ENTRY CODING
!
NMAX=(NMAX+7)&(-8)
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
JJ=NMDECS(LEVEL)>>14
IF JJ#0 THEN START ; ! STRINGS OR ARRAYS TO BE UNDECLARED
PF1(STSF,0,TOS,0)
PF1(LSS,0,TOS,0)
PSF1(IRSB,1,JJ)
PSF1(ISH,0,-2)
PF1(ST,0,TOS,0)
PF1(ASF,0,TOS,0)
GRUSE(ACCR)=0
FINISH
IF STACK=0 THEN RESET AUX STACK
FINISH
!
! RETURN TO PREVIOUS LEVEL PROVIDED THERE IS A VALID ONE !
!
UNLESS LEVEL>2 OR (LEVEL=2 AND CPRMODE=2) THEN START
IF KKK=1 AND LEVEL=2 THEN KKK=2 ELSE FAULT(109,0,0)
! SHOULD BE CHKD IN PASS1
FINISH
LEVEL=LEVEL-1
IF KKK>=X'1000' THEN START
RLEVEL=RLEVEL-1
RBASE=RLEVEL
FINISH
!
! RESTORE INFORMATION ABOUT THE (NEW) CURRENT LEVEL
!
POP(LEVELINF,KP,N,KP)
NMAX=N>>16 IF KKK>=X'1000'
N=N&X'7FFF'
IF KKK=2 THEN CEND(KKK); ! ROUND AGAIN FOR 'ENDOFPROGRAM'
!
! COMPLETE THE JUMP AROUND ALL NON-EXTERNAL ROUTINES EXCEPT WHEN
! %TRUSTEDPROGRAM IS IN OPERATION.
!
IF ASL WARN#0 AND KKK>=X'1000' THEN ASL WARN=0 AND EPILOGUE
IF KKK>=X'1000' AND COMPILER=0 AND (RLEVEL>0 OR CPRMODE#2)C
THEN START
JJ=NEXTP+6
UNLESS A(NEXTP+5)=11 AND A(JJ+FROMAR2(JJ))=2 START
JJ=ENTER LAB(JROUND(LEVEL+1),0)
JROUND(LEVEL+1)=0
FINISH
FINISH
RETURN
!
! LAYOUT OF DIAGNOSIC TABLES
! ****** ** ********* ******
!
! THE BOUND FIELD OF PLT DESCRIPTOR STORED AT (LNB+3 & LNB+4) IF
! USED TO CONTAIN A DISPLACEMENT RELATIVE TO THE START OF SST OF THE
! DIAGNOSTIC TABLES FOR THE BLOCK OR ROUTINE BEING EXECUTED.
! A ZERO BOUND MEANS NO DIAGNOSTIC REQUESTED.(NB THIS MAY MEAN A DUMMY
! FIRST WORD IN THE SST).
! THE ABSOLUTE ADDRESS OF THE SST FOR THE CURRENT CODE SEGMENT WILL
! ALWAYS BE FOUND IN THE STANDARD 10 WORDS OF THE GLA/PLT
!
! FORM OF THE TABLES:-
!
! WORD 0 = LINE OF RT IN SOURCE PROG <<16 ! LINE NO POSN(FROM LNB)
! WORD 1 = (12 LANG DEPENDENT BITS)<<18 ! ENVIRONMENT
! ( TOP 2 BITS OF LANG DEPENDENT HAS LITL FROM PTYPE)
! ( BOTTOM 4 BITS HAVE TEXTUAL LEVEL)
! WORD 2 = DISPLAY POSN (FROM LNB)<<16 ! RT TYPE INFO
! WORD 3 = ZERO FOR BLKS OR STRING(<=11BYTES) BEING THE
! RT NAME. THIS WILL TAKE WORDS 4 AND 5 IF NEEDED
! WORD 6 = LANGUAGE DEPENDENT INFO . IMP ON CONDITIONS ETC
!
! THE REST IS MADE UP OF VARIABLE ENTRIES AND THE SECTION IS TERMINATED BY
! A WORD OF X'FFFFFFFF'
!
! EACH VARIABLE ENTRY CONSISTS OF THE VARIABLE WORD FOLLOWED BY
! THE VARIABLE NAME AS A STRING. THE WORD CONSISTS OF
! BITS 2**31 TO 2**20 TYPE INFORMATION (MAY BE LANGUAGE DEPENDENT
! BIT 2**19 =0 UNDER LNB =1 IN GLA
! BITS 2**18 TO 2**0 DISPLACEMENT FROM LNB(GLA) IN BYTES
!
!
! THE ENVIRONMENT IS A POINTER (RELATIVE TO SST) OF THE NEXT OUTERMOST
! BLOCK OR A POINTER TO GLOBAL OWNS, EXTERNAL OR COMMON AREAS
! A ZERO MEANS NO ENCLOSING BLOCK. WORD1=WORD3=0 IS AN
! IMP MAIN PROGRAM AND WILL TERMINATE THE DIAGNOSTICS.
!
ROUTINE DTABLE(INTEGER LEVEL)
!***********************************************************************
!* THIS ROUTINE LOOKS AT THE DECLARATIONS FOR THE CURRENT LEVEL & *
!* SETS UP THE SEGMENT OF SHARABLE SYMBOL TABLES TO DESCRIBE THEM.*
!* FOR MAIN PROGRAMS OR EXTERNAL ROUTINES THE 'GLOBAL' VARIABLES *
!* (IF ANY) ARE ALSO INCLUDED. *
!***********************************************************************
STRING (31) RT NAME
STRING (11) LOCAL NAME
RECORD (LISTF)NAME LCELL
CONSTINTEGER LARRROUT=X'F300'
INTEGER DPTR,LNUM,ML,KK,JJ,Q,DEND,BIT,S1,S2,S3,S4,LANGD,II
INTEGERARRAY DD(0:500); ! BUFFER FOR SEGMENT OF SST
!
! FILL ALL OUTSTANDING REFERENCES TO THIS DIAGS BLOCK
!
BIT=1<<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)
IF ML#0 THEN ML=WORD(ML-1); ! IF NOT BLOCK GET DIRPTR
LNUM=BYTEINTEGER(DICTBASE+ML); ! LENGTH OF THE NAME
DPTR=4; DEND=0
IF LNUM=0 THEN DD(3)=0 ELSE START
Q=DICTBASE+ML
RT NAME<-STRING(Q); ! FOR RTS MOVE IN 1ST 32 CHARS
LNUM=BYTE INTEGER(ADDR(RT NAME))
STRING(ADDR(DD(3)))=RTNAME; ! AND UPDATE POINTER PAST
DPTR=DPTR+LNUM>>2; ! ACTUAL NO OF CHARS
FINISH
DD(DPTR)=ONWORD(LEVEL); ! ON CONDITION WORD
DPTR=DPTR+1
JJ=NAMES(LEVEL)
WHILE 0<=JJ<X'3FFF' CYCLE
LCELL==ASLIST(TAGS(JJ))
! OBTAIN NEXT NAME FORM DECLNS
!
! 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
!
! FAULT ALL UNUSED NAMES EXCEPT CONSTINTEGERS&REALS
!
IF (TYPE>2 OR PTYPE&X'FF00'#X'4000' OR PARMY#0) C
AND S1&X'F000'=0 THEN WARN(2,JJ)
I=S1>>4&15
J=S1&15
K=S3>>16
!
! ALLOW OWNS (LITL=0) AND EXTERNALS (=2) NOT CONSTS(=1) OR EXTRINSIC(=3)
!
IF PARMDIAG#0 AND PTYPE&X'7300'<=X'200' AND DPTR<497 C
AND (1<=TYPE<=3 OR TYPE=5) START
Q=DICTBASE+WORD(JJ); ! ADDRESS OF NAME
IF I=0 THEN II=1 ELSE II=0; ! GLA OR LNB BIT
DD(DPTR)=PTYPE<<20!II<<18!K
LOCAL NAME<-STRING(Q); ! TEXT OF NAME FROM DICTIONARY
LNUM=BYTE INTEGER(ADDR(LOCAL NAME))
STRING(ADDR(DD(DPTR))+4)=LOCAL NAME;! MOVE IN NAME
DPTR=DPTR+(LNUM+8)>>2
FINISH
IF J=15 AND PTYPE&X'3000'#0 AND S1&X'C000'#0 THEN C
FAULT(28,0,JJ)
! SPEC&USED BUT NO BODY GIVEN
IF J=15 AND TYPE=4 THEN FAULT(62,0,JJ)
IF PTYPE&X'3000'#0 OR TYPE=4 OR TYPE=6 THEN C
CLEAR LIST(K) ELSE START
IF I#0 AND K>511 AND PTYPE&LARRROUT=0 AND TYPE#7 C
THEN WARN(5,JJ)
FINISH
JJ=S4>>18
REPEAT
DD(DPTR)=-1; ! 'END OF SEGMENT' MARK
DPTR=DPTR<<2+4
IF PARMTRACE=1 THEN START
LPUT(4,DPTR,SSTL,ADDR(DD(0)));! ADD TO SHARABLE SYM TABS
SSTL=SSTL+DPTR
FINISH
END ; ! OF ROUTINE DTABLE
END
ROUTINE MAKE DECS(INTEGER Q)
!***********************************************************************
!* Q IS TO AR ENTRY FOR HEAD OF LINKED DECLARATIONS *
!***********************************************************************
INTEGER QQ,HEAD,PRIO,COUNT,SL,MARKER
INTEGERNAME THEAD
RECORD (LISTF)NAME CELL
SL=LINE; QQ=FROM AR4(Q)
HEAD=0; COUNT=0
WHILE QQ#0 CYCLE
COUNT=COUNT+1
ABORT UNLESS A(QQ+5)=8; ! LINE IS A DECLARATION
P=QQ+10
MARKER=P+FROMAR2(P)
P=P+2
IF A(P)<=3 AND A(MARKER)=1 START ;! 1ST 3 ALTS OF TYPE
! ARE INT,REAL LONG INT&REAL
CLT
PRIO=PREC<<4!TYPE
IF A(P+1)#3 THEN PRIO=X'FFFE';! POINTER HAVE LOW PRIORITY
THEAD==HEAD
CYCLE
CELL==ASLIST(THEAD)
IF THEAD=0 OR PRIO<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+12; CLT
ROUT=0; LITL=0
CQN(P+1); P=P+2
DECLARE SCALARS(1,KFORM)
REPEAT
LINE=SL
END
ROUTINE DECLARE SCALARS(INTEGER PERMIT,XTRA)
!***********************************************************************
!* THIS ROUTINE DECLARES A LIST OF SCALARS FROM INFORMATION *
!* IN THE GLOBAL VARIABLES ROUT,NAM,ARR,PREC,TYPE & ACC.IT WORKS *
!* OUT ROUNDING FACTORS FOR ITSELF. *
!* P POINTS TO THE NAMELIST ON ENTRY AND IS UPDATED. *
!* PERMIT IS 0 IF DECLARING FORMAL PARAMETERS *
!***********************************************************************
INTEGER INC,Q,SCHAIN,DMADE,NPARMS,SCAL NAME,TYPEP
PACK(PTYPE); J=0
INC=ACC; DMADE=0; SNDISP=0
IF PTYPE=X'33' THEN INC=(INC+3)&(-4)
IF NAM#0 AND ROUT=0 AND ARR=0 THEN INC=8
IF NAM>0 AND ARR>0 THEN INC=16
IF PTYPE=X'35' AND (ACC<=0 OR ACC>256) THEN FAULT(70,ACC-1,0)
IF PERMIT#0 AND (INC=8 OR INC=16) THEN ODD ALIGN
IF PERMIT#0 AND (PTYPE=X'33' OR PTYPE=X'35')START
Q=WORD CONST(X'18000000'+ACC)
PF1(LDTB,0,PC,Q)
GRUSE(DR)=0
FINISH
N=(N+3)&(-4)
IF PTYPE=X'35' START
IF FLAG(LEVEL)=0=NMDECS(LEVEL)>>14 START
PSF1(STSF,1,N); ! BEGIN BLOCK SAVE ST PTR
NMDECS(LEVEL)=NMDECS(LEVEL)!N<<14
N=N+4
FINISH
INC=8
IF PERMIT#0 START
PF1(STSF,0,TOS,0)
PF1(LDA,0,TOS,0)
FINISH
FINISH
IF PTYPE=X'33' AND PERMIT#0 THEN START
PSF1(LDA,1,PTR OFFSET(RBASE))
PSF1(INCA,0,N+8)
FINISH
UNTIL A(P-1)=2 CYCLE ; ! DOWN THE NAMELIST
DMADE=DMADE+1
SCAL NAME=FROM AR2(P)
IF PTYPE=X'31' AND PERMIT=0 THEN N=N+3;! BYTE PARAMS
IF PTYPE=X'41' AND PERMIT=0 THEN N=N+2
SCHAIN=N
KFORM=XTRA
IF ROUT=1 THEN START
TYPEP=PTYPE; ! CHANGED BY CFPLIST!
Q=P
P=P+3 UNTIL A(P-1)=2; ! TO FPP
CFPLIST(SCHAIN,NPARMS)
IF NPARMS>0 THEN ASLIST(SCHAIN)_S3=NPARMS
P=Q
J=13
SNDISP=N; ! DISPLACEMENT
PTYPE=TYPEP; UNPACK
FINISH
P=P+3
IF PTYPE=X'33' THEN START
IF PERMIT#0 START
PSF1(STD,1,N)
IF A(P-1)=1 THEN PSF1(INCA,0,INC+8)
FINISH
N=N+8; SCHAIN=N
FINISH
IF PTYPE=X'35' AND PERMIT#0 START
PSF1(STD,1,N)
IF A(P-1)=1 THEN PSF1(INCA,0,(ACC+3)&(-4)) ELSE START
Q=((ACC+3)>>2)*DMADE
PSF1(ASF+12*PARMCHK,0,Q)
IF PARMCHK#0 THEN PPJ(0,4)
FINISH
FINISH
STORE TAG(SCAL NAME,SCHAIN)
N=N+INC
REPEAT
IF PERMIT#0 THEN N=(N+3)&(-4); ! THIS IS NECESSARY !
END
INTEGERFN DOPE VECTOR(INTEGER TYPEP,ELSIZE,MODE,IDEN, C
INTEGERNAME ASIZE,LB)
!***********************************************************************
!* CONSTRUCTS THE DOPE-VECTOR FOR A CONSTANT ARRAY IN THE *
!* SHAREABLE SYMBOL TABLES AND RETURNS ITS DISPLACEMENT AS RESULT*
!* EVENTUALLY ALL NON DYNAMIC DOPE VECTORS SHOULD GO VIA HERE *
!* P IS TO ALT (MUST BE 1!) OF P<BPAIR> *
!* DOPE VECTOR CONSISTS OF :- *
!* DESRIPTOR (SCALED WORD) POINTING AT FIRST TRIPLE BND=3*ND *
!* SIZE (IN BYTES OF ENTIRE ARRAY) FOR STACK ADJUSTMENT *
!* AND ND TRIPLES EACH CONSISTING OF:- *
!* LBI - THE LOWER BOUND OF THE ITH DIMENSION *
!* MI - THE STRIDE FOR THE ITH DIMENSION *
!* CBI THE UPPER CHECK =(UBI-LBI+1)*MI *
!* WHERE M1=1(SCALED ARRAYS) OR THE ELEMENT SIZE AND *
!* MI = M(I-1)*RANGE(I-1) *
!* MODE=0 DV MUST BE CONST, MODE#0 CAN BE DYNAMIC *
!* MODE=-1 SPECIAL FOR CONSTARRAYNAMES 1D 0:INFINITY *
!* P TO ALT (ALWAYS=1) OF P(BPAIR) *
!***********************************************************************
INTEGER I, JJ, K, ND, D, UNSCAL, M0, HEAD, NOPS, TYPEPP, PIN, PTR
RECORD (LISTF)NAME LCELL
INTEGERARRAY LBH,LBB,UBH,UBB(0:12)
INTEGERARRAY DV(0:39); ! ENOUGH FOR 12 DIMENSIONS
ND=0; NOPS=0; TYPEPP=0; PIN=P
IF TYPEP>2 OR (TYPEP=1 AND PREC=4)C
THEN UNSCAL=1 AND M0=ELSIZE C
ELSE UNSCAL=0 AND M0=1
IF MODE=-1 THEN START
ND=1; DV(3)=0
DV(4)=M0
M0=X'FFFFFF'
DV(5)=M0
FINISH ELSE START
UNTIL A(P)=2 CYCLE
ND=ND+1; P=P+4
FAULT(37,0,IDEN) AND ND=1 IF ND>12
LBH(ND)=0; LBB(ND)=0
UBB(ND)=0; UBH(ND)=0
TORP(LBH(ND),LBB(ND),NOPS)
P=P+3
TYPEPP=TYPEPP!TYPE
TORP(UBH(ND),UBB(ND),NOPS)
TYPEPP=TYPEPP!TYPE
REPEAT
P=P+1
->NONCONST UNLESS TYPEPP=1 AND NOPS&X'40040000'=0
!
! NOW ONE CAN WORK OUT AND FILL IN THE TRIPLES
!
PTR=1
CYCLE D=ND,-1,1
K=3*D
EXPOP(LBH(PTR),ACCR,NOPS,X'251')
EXPOPND_D=0 AND FAULT(41,0,0) UNLESS C
EXPOPND_FLAG<=1 AND EXPOPND_PTYPE=X'51'
DV(K)=EXPOPND_D
DV(K+1)=M0
EXPOP(UBH(PTR),ACCR,NOPS,X'251')
EXPOPND_D=10 AND FAULT(41,0,0) UNLESS C
EXPOPND_FLAG<=1 AND EXPOPND_PTYPE=X'51'
JJ=EXPOPND_D
M0=M0*(JJ-DV(K)+1)
FAULT(38,1-M0,IDEN) UNLESS JJ>=DV(K)
IF M0>X'FFFFFF' THEN FAULT(39,0,IDEN) AND M0=1
DV(K+2)=M0
PTR=PTR+1
REPEAT
IF UNSCAL=0 THEN M0=M0*ELSIZE
FINISH
!
IF ND=1 THEN LB=DV(3)
FAULT(39,0,IDEN) IF M0>X'FFFFFF'
ASIZE=M0
DV(2)=ASIZE
DV(1)=12
DV(0)=5<<27!3*ND; ! DESPTR FOR DV
K=3*ND+2
J=ND; ! DIMENSIONALITY FOR DECLN
HEAD=DVHEADS(ND)
WHILE HEAD#0 CYCLE
LCELL==ASLIST(HEAD)
IF LCELL_S2=ASIZE AND LCELL_S3=DV(5) START
CYCLE D=0,1,K
->ON UNLESS DV(D)=CTABLE(D+LCELL_S1)
REPEAT
RESULT =X'80000000'!4*LCELL_S1
FINISH
ON:
HEAD=LCELL_LINK
REPEAT
IF CONST PTR&1#0 THEN CONST HOLE=CONST PTR AND C
CONST PTR=CONST PTR+1
I=4*CONST PTR!X'80000000'
PUSH(DVHEADS(ND),CONSTPTR,ASIZE,DV(5))
CYCLE D=0,1,K
CTABLE(CONST PTR)=DV(D)
CONST PTR=CONST PTR+1
REPEAT
IF CONST PTR>CONST LIMIT THEN FAULT(102, WKFILEK,0)
WAYOUT:
IF MODE=-1 THEN RESULT =I; ! NO EXPRESSION CELLS TO RETURN
CYCLE D=ND,-1,1
ASLIST(LBB(D))_LINK=ASL
ASL=LBH(D)
ASLIST(UBB(D))_LINK=ASL
ASL=UBH(D)
REPEAT
RESULT =I
NONCONST: ! NOT A CONST DV
J=ND; I=-1
LB=0; ASIZE=ELSIZE
IF MODE=0 THEN FAULT(41,0,0) ELSE P=PIN
->WAYOUT
END
ROUTINE DECLARE ARRAYS(INTEGER FORMAT, FINF)
!***********************************************************************
!* FORMAT=1 FOR 'ARRAYFORMAT' =0 OTHERWISE *
!* FINF>0 FOR RECORD FORMAT INFORMATION =0 OTHERWISE *
!* P IS AT P<ADECLN> IN *
!* *
!* P<ADECLN>=<NAMELIST> <BPAIR> <RESTOFDECLN> *
!* P<BPAIR> = '('<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, JJJ, JJJJ, ADJ
IF STACK#0 AND FLAG(LEVEL)=0=NMDECS(LEVEL)>>14 START
PSF1(STSF,1,N)
NMDECS(LEVEL)=NMDECS(LEVEL)!(N<<14)
N=N+4
FINISH
IF STACK=0 THEN SAVE AUX STACK
ARRP=2*FORMAT+1; ARR=ARRP; PACK(PTYPEP)
ELSIZE=ACC
IF TYPE>2 OR (TYPE=1 AND PREC=4)C
THEN UNSCAL=1 AND SC=3 C
ELSE UNSCAL=0 AND SC=PREC
DESC=SC<<27!UNSCAL<<25!(1-PARMARR)<<24;! ARRAY DESCRIPTOR SKELETON
IF PREC=4 THEN DESC=X'58000002'
START:NN=1; P=P+1; ! NO OF NAMES IN NAMELIST
PP=P; CDV=0; PTYPEPP=PTYPEP
P=P+3 AND NN=NN+1 WHILE A(P+2)=1
P=P+3
DVDISP=DOPE VECTOR(TYPE,ELSIZE,1,FROMAR2(PP),TOTSIZE,LWB)
ND=J
->CONSTDV UNLESS DVDISP=-1
! NORMAL CASE - PLANT CODE TO SET UP DOPE-VECTOR AT RUN TIME
DVF=0; TOTSIZE=X'FFFF'
DVDISP=N; ! DVDISP IS D-V POSITION
N=N+12*ND+12; ! CLAIM SPACE FOR THE D-V
D0=5<<27!3*ND; D1=12; ! DESCPTR FOR DV
STORE CONST(JJ,8,ADDR(D0))
PF1(LD,0,PC,JJ)
PSF1(STD,1,DVDISP)
GRUSE(DR)=0
IF UNSCAL=0 THEN JJ=1 ELSE JJ=ELSIZE
PSF1(LSS,0,JJ); ! M1 THE FIRST MULTIPLIER
GRUSE(ACCR)=0
CYCLE II=ND,-1,1
P=P+1
QQ=DVDISP+12*II; ! TRIPLE FOR IITH DIMENSION
PSF1(ST,1,QQ+4); ! STORE MULTIPLIER
CSEXP(ACCR,X'51'); ! LOWER BOUND
IF ND=1 AND PTYPEP&7<=3 AND FORMAT=0 AND GRUSE(ACCR)=5 C
AND GRINF1(ACCR)=0 THEN PTYPEPP=PTYPEPP+256
PSF1(ST,1,QQ); ! STORED IN DV
CSEXP(ACCR,X'51'); ! UPPER BOUND
PSF1(ISB,1,QQ)
GRUSE(ACCR)=0
IF COMPILER=0 OR PARMARR#0 START
PF3(JAF,6,0,3); ! JUMP UNLESS NEGATIVE
PSF1(LSS,0,-1); ! SET UP -1 (ENSURES 0 ELEMENTS
FINISH
PSF1(IAD,0,1); ! CONVERTED TO RANGE
PSF1(IMY,1,QQ+4); ! RANGE*MULTIPLIER
PSF1(ST,1,QQ+8); ! AND STORED IN DV
REPEAT
P=P+1
IF UNSCAL=0 AND ELSIZE#1 THEN PSF1(IMY,0,ELSIZE)
PSF1(ST,1,DVDISP+8)
SNDISP=0; ! DV NOT AVAILABLE AT COMPILETIME
->DECL
CONSTDV: ! ONE DIMENSION - CONSTANT BOUNDS
DVF=1; CDV=1
IF ND=1 AND LWB=0 AND PTYPEP&15<=3 C
AND FORMAT=0 THEN PTYPEPP=PTYPEP+256
! SET ARR=2 IF LWB=ZERO
SNDISP=(DVDISP&X'FFFFFF')>>2
DECL: ! MAKE DECLN - BOTH WAYS
J=ND
ODD ALIGN
PTYPE=PTYPEPP; UNPACK
IF DVF#0 THEN START ; ! ARRAY IS STRING OF LOCALS
R=TOTSIZE
IF UNSCAL=0 THEN R=R//ELSIZE
D0=DESC
D0=D0!R UNLESS PREC=4
STORE CONST(D1,4,ADDR(D0))
PF1(LB,0,PC,D1)
FINISH ELSE START
STORE CONST(D1,4,ADDR(DESC))
PF1(LB,0,PC,D1)
PSF1(ADB,1,DVDISP+20) UNLESS PREC=4
FINISH
IF DVF#0 THEN QQ=PC ELSE QQ=LNB
PSORLF1(LDRL,0,QQ,DVDISP)
GRUSE(BREG)=0; GRUSE(DR)=0
CYCLE JJJ=0,1,NN-1; ! DOWN NAMELIST
PSF1(STB,1,N+16*JJJ); ! ARRAY BOUND
PSF1(STD,1,N+8+16*JJJ); ! DV POINTER
REPEAT
IF PARMARR=0 AND PARMCHK=0 AND ND=1 AND TYPE<=3 C
AND PTYPEPP&X'F00'#X'200' THEN ADJ=1 ELSE ADJ=0
CYCLE JJJ=0,1,NN-1; ! DOWN NAMELIST
IF ADJ#0 START ; ! ADJUST DESC
IF STACK#0 START ; ! ARRAY ON AUTOMATIC STACK
PF1(STSF,0,BREG,0); ! CURRENT SF TO B
IF DVF#0 THEN PSF1(SBB,0,LWB*ELSIZE) ELSE START
IF ELSIZE=1 THEN PSF1(SBB,1,DVDISP+12) ELSESTART
PSF1(SLB,1,DVDISP+12)
PSF1(MYB,0,ELSIZE)
PF1(SLB,0,TOS,0)
PF1(SBB,0,TOS,0)
FINISH
FINISH
PSF1(STB,1,N+4)
GRUSE(BREG)=0
FINISH ELSE START ; ! ARRAY ON AUX STACK
IF DVF#0 START ; ! CONST DOPE VECTOR
UNLESS GRUSE(ACCR)=11 START
PSF1(LSS,2,AUXSBASE(LEVEL))
GRUSE(ACCR)=11; GRINF1(ACCR)=0
FINISH
JJJJ=LWB*ELSIZE-GRINF1(ACCR)
PSF1(ISB,0,JJJJ) UNLESS JJJJ=0
GRINF1(ACCR)=LWB*ELSIZE
FINISH ELSE START ; ! DYNAMIC ARRAYS
IF GRUSE(ACCR)=11 AND GRINF1(ACCR)=0 AND C
ELSIZE=1 THEN PSF1(ISB,1,DVDISP+12) ELSESTART
PSF1(LSS,1,DVDISP+12)
PSF1(IMY,0,ELSIZE) UNLESS ELSIZE=1
PSF1(IRSB,2,AUXSBASE(LEVEL))
FINISH
GRUSE(ACCR)=0
FINISH
PSF1(ST,1,N+4)
FINISH
FINISH ELSE START ; ! NO ADJUSTMENT OF DESCRPT
IF STACK#0 THEN PSF1(STSF,1,N+4) ELSE START
PSF1(LSS,2,AUXSBASE(LEVEL)) UNLESS GRUSE(ACCR)=11 C
AND GRINF1(ACCR)=0
PSF1(ST,1,N+4)
GRUSE(ACCR)=11; GRINF1(ACCR)=0
FINISH
FINISH
ACC=ELSIZE; ! RESET ACC AFTER DV CMPLD
KFORM=FINF; ! FORMAT INFORMATION
K=FROM AR2(PP+3*JJJ)
STORE TAG(K,N)
CLAIM AS IF FORMAT = 0
N=N+16
REPEAT
P=P+1; ! PAST REST OF ARRAYLIST
IF A(P-1)=1 THEN ->START
RETURN
ROUTINE CLAIM AS
!***********************************************************************
!* CLAIM THE SPACE FOR AN ARRAY FROM STACK OR AUX STACK *
!***********************************************************************
INTEGER T, B, D,ADJMENT
IF STACK=1 THEN START ; ! FROM AUTOMATIC STACK
IF CDV=1 THEN START ; ! CONSTANT BOUNDS
T=(TOTSIZE+3)//4
PSF1(ASF+12*PARMCHK,0,T); ! ASF OR LB
PPJ(0,4) IF PARMCHK#0
FINISH ELSE START ; ! DYNAMIC BOUNDS
IF PARMCHK=0 AND PTYPEP&7<=2 AND C
(ELSIZE=4 OR ELSIZE=8) START
PSF1(ASF,1,DVDISP+20); ! SIZE IN ELEMENTS WORD
PSF1(ASF,1,DVDISP+20) IF ELSIZE=8
FINISH ELSE START
PSF1(LSS,1,DVDISP+8); ! ARRAY SIZE BYTES
PSF1(IAD,0,3) IF ELSIZE&3#0
PSF1(USH,0,-2); ! ARRAY SIZE WORDS
PF1(ST,0,BREG,0)
FORGET(BREG)
IF PARMCHK#0 THEN PPJ(0,4) ELSE PF1(ASF,0,BREG,0)
FINISH
FINISH
CHECK STOF
FINISH ELSE START
UNLESS GRUSE(ACCR)=11 AND (GRINF1(ACCR)=0 OR CDV=1) START
PSF1(LSS,2,AUXSBASE(LEVEL))
GRUSE(ACCR)=11; GRINF1(ACCR)=0
FINISH
IF CDV=1 THEN START
ADJMENT=(TOTSIZE+7)&(-8)+GRINF1(ACCR)
IF ADJMENT<X'1FFFF' THEN B=0 AND D=ADJMENT C
ELSE B=PC AND D=WORD CONST(ADJMENT)
IF ADJ=1 AND JJJ#NN-1 AND PARMOPT=0 THEN C
GRINF1(ACCR)=ADJMENT ELSE START
GRINF1(ACCR)=0
PSORLF1(IAD,0,B,D) UNLESS B=D=0
FINISH
FINISH ELSE START
B=LNB; D=DVDISP+8
PSF1(IAD,1,D)
UNLESS ELSIZE&7=0 START
PSF1(IAD,0,7)
PSF1(AND,0,-8)
FINISH
GRINF1(ACCR)=0
FINISH
PSF1(ST,2,AUXSBASE(LEVEL)) IF JJJ=NN-1 OR (ADJ=1 AND CDV=0)
IF PARMOPT#0 THEN START
PSF1(ICP,1,AUXSBASE(LEVEL)+16)
PPJ(2,8)
FINISH
IF PARMCHK#0 START
PF1(LDTB,0,PC,PARAM DES(3))
PSORLF1(LDB,0,B,D)
PSF1(LDA,1,N+4)
PF2(MVL,1,1,0,0,UNASSPAT&255)
GRUSE(DR)=0
FINISH
FINISH
END
END
ROUTINE CLT
!***********************************************************************
!* DEAL WITH PHRASE TYPE AND SET PREC,TYPE & ACC *
!* ONLY PROBLEM ARE STRINGS WHICH HAS OPTIONAL MAX LENGTH ALSO *
!* RECORD WHICH HAVE A FORMAT *
!* P ON PHRASE TYPE AT ENTRY - TO NEXT PHRASE AT EXIT. *
!***********************************************************************
CONSTBYTEINTEGERARRAY TYPEFLAG(1:11)= C
X'51',X'52',0,X'31',X'35',
X'41',X'51',X'33',X'62',X'61',X'72';
INTEGER ALT,PTYPEP,I,SJ
ALT=A(P)
TYPE=TYPEFLAG(ALT)
IF TYPE=0 THEN P=P+1 AND TYPE=TYPEFLAG(A(P)+8)
IF ALT=4 OR ALT=6 THEN P=P+1
IF ALT=7 THEN P=P+1 AND WARN(9,0);! WARN ON %SHORT
PREC=TYPE>>4
TYPE=TYPE&7
P=P+1
ACC=BYTES(PREC)
PACK(PTYPEP); ! PRESERVE ALL COMPONENT
! BEFORE CALLINT INTEXP ETC
IF TYPE=5 THEN START ; ! P<TYPE>='%STRING'
IF A(P)=1 THEN START ; ! MAX LENGTH GIVEN
IF A(P+1)=1 START ; ! EXPRESSION NOT STAR
P=P+4
IF INTEXP(I)#0 THEN FAULT(41,0,0)
ACC=I+1
PTYPE=PTYPEP; UNPACK
FINISH ELSE ACC=0 AND P=P+2
FINISH ELSE ACC=0 AND P=P+1
FINISH
KFORM=0
IF TYPE=3 THEN START
SJ=J
KFORM=CFORMATREF
PTYPE=PTYPEP
J=SJ
UNPACK
FINISH
END
ROUTINE CQN(INTEGER P)
!***********************************************************************
!* SET NAM & ARR 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; ! ARRAYNAMES
IF I<=2 THEN NAM=1; ! ARRAYNAMES & NAMES
END
INTEGERFN SET SWITCHLAB(INTEGER HEAD,LAB,FNAME,BIT)
!***********************************************************************
!* SET A SWITCH LABEL AND RETURNS RESULT=0 %UNLESS THE LABEL *
!* HAS BEEN ALREADY SET WHEN IT RETURNS RESULT#0 *
!* HEAD IS HEAD OF THE TAGS SIDECHAIN FOR THE SWITCH *
!***********************************************************************
INTEGER Q,QQ,JJJ,LB,UB,BASEPT
RECORDFORMAT BITFORM(INTEGERARRAY BITS(0:2),INTEGER LINK)
RECORD (BITFORM)NAME BCELL
RECORD (LISTF)NAME LCELL
FORGET(-1)
LCELL==ASLIST(HEAD)
BASEPT=LCELL_S1
LB=LCELL_S2
UB=LCELL_S3
HEAD=LCELL_LINK
BCELL==ASLIST(HEAD)
UNLESS LB<=LAB<=UB THEN FAULT(50,LAB,FNAME) AND RESULT =0
Q=LAB-LB
WHILE Q>=96 CYCLE
HEAD=BCELL_LINK
BCELL==ASLIST(HEAD)
Q=Q-96
REPEAT
!
! ASLIST(HEAD) IS THE START OF 96 BIT ENTRY IN THE BIT LIST
! CHECK BIT NO Q TO SEE IF LABEL ALREADY SET AND THEN SET BIT Q
!
QQ=Q>>5; ! RIGHT WORD
Q=Q&31; JJJ=1<<Q; ! BIT IN WORD
RESULT =1 UNLESS BCELL_BITS(QQ)&JJJ=0
BCELL_BITS(QQ)=BCELL_BITS(QQ)!BIT<<Q;! DONT SET BIT ON SW(*) ENTRIES
!
! ALL SWITCHES BASEPT HAS OFFSET OF ACTUAL FIRST ELEMENT
!
QQ=BASEPT+(LAB-LB)*4; ! REL POSITION OF LABEL
LPUT(4,4,QQ,ADDR(CA)); ! OVERWRITE THE WORD IN TABLE
RESULT =0
END
ROUTINE CRSPEC (INTEGER M)
!***********************************************************************
!* MODE=0 FOR NORMAL ROUTINE SPEC *
!* MODE=1 FOR EXTERNAL(ETC) ROUTINE SPECS XREF NEEDED *
!* P ON ENTRY TO P(RT) IN (RT)(MARK)(%SPEC')(NAME)(FPP) *
!* tags for a procedure type as follows *
!* kform points to format for record fns etc *
!* sndisp has entry disp(>>2 for code addresses) ot listhead *
!* acc has size of returned object *
!* k has parameter list(=0 for no params) *
!***********************************************************************
INTEGER KK,JJ,TYPEP,OPHEAD,NPARMS,SKFORM,SACC
STRING (34) XNAME
LITL=EXTRN&3
IF A(P)=1 THEN START ; ! P<RT>=%ROUTINE
TYPEP=LITL<<14!X'1000'
P=P+2; ! IGNORING ALT OF P(SPEC')
FINISH ELSE START ; ! P<RT>=<TYPE><FNORMAP>
ROUT=1; ARR=0; P=P+1
CLT; NAM=0
IF A(P)=2 THEN NAM=2; ! 2 FOR MAP 0 FOR FN
PACK(TYPEP)
P=P+2; ! AGAIN IGNORING ALT OF P(SPEC')
FINISH
P=P+4; ! PAST HOLE FOR DECLINKS
KK=FROM AR2(P)
XNAME<-STRING(DICTBASE+WORD(KK))
IF EXTRN=1 THEN XNAME<-"S#".XNAME
JJ=0
P=P+3
IF A(P-1)=1 THEN XNAME<-STRING(ADDR(A(P))) AND C
P=P+A(P)+1
SKFORM=KFORM; SACC=ACC
IF TYPE=3 AND NAM=0 AND ACC>256 THEN FAULT(63,256,0)
CFPLIST(OPHEAD,NPARMS)
IF M=1 THEN START
CXREF(XNAME,PARMDYNAMIC!(EXTRN//3),2,JJ); ! %STSTEM & %EXTERNAL =STATIC
! %DYNAMIC = DYNAMIC
FINISH ELSE START
IF RLEVEL=0 START
IF CPRMODE=0 THEN CPRMODE=2
IF CPRMODE#2 THEN FAULT(56,0,KK)
FINISH
FINISH
J=15-M; PTYPE=TYPEP
IF NPARMS>0 THEN ASLIST(OPHEAD)_S3=NPARMS
KFORM=SKFORM
SNDISP=JJ
ACC=SACC
STORE TAG(KK,OPHEAD)
END
ROUTINE CFPLIST(INTEGERNAME OPHEAD,NPARMS)
!***********************************************************************
!* COMPILE A FORMAL PARAMETER PART INTO A LIST OF PARAMETER TYPES *
!* P(FPP)='('{(HOLE)(FPDEL)(NAMELIST)(MARK)}*')',0. *
!* *
!* THE LIST OF PARAMETER LOOKS LIKE:- *
!* S1 = PTYPE FOR PARAM<<16! DIMENSION (DIMEN DEDUCED LATER) *
!* S2 = ACC <<16 ! SPARE *
!* S3 = 0 (RESERVED FOR FPP OF RTS) *
!* (S3 OF 1ST PARAM HAS NO OF PARAMS IN BTM 8 BITS) *
!* *
!* ON ENTRY P IS AT ALT OF FPP (WHICH MAY BE NULL) *
!***********************************************************************
INTEGER OPBOT, PP
OPHEAD=0; OPBOT=0
NPARMS=0; ! ZERO PARAMETERS AS YET
WHILE A(P)=1 CYCLE ; ! WHILE SOME(MORE) FPS
PP=P+1+FROMAR2(P+1); ! TO NEXT FPDEL
P=P+3; ! TO ALT OF FPDEL
CFPDEL; ! GET TYPE & ACC FOR NEXT GROUP
UNTIL A(P-1)=2 CYCLE ; ! DOWN <NAMELIST> FOR EACH DEL
BINSERT(OPHEAD,OPBOT,PTYPE<<16,ACC<<16,0)
NPARMS=NPARMS+1
P=P+3
REPEAT
P=PP
REPEAT
P=P+1
END
ROUTINE CFPDEL
!***********************************************************************
!* SET UP PTYPE & ACC FOR A FORMAL PARAMETER DEFINITION *
!* P<FPDEL>=<TYPE><%QNAME'>, *
!* (RT)(%NAME')(NAMELIST)(FPP), *
!* '%NAME'. *
!***********************************************************************
SWITCH FP(1:3)
INTEGER FPALT
FPALT=A(P); P=P+1
KFORM=0; LITL=0
->FP(FPALT)
FP(1): ! (TYPE)(%QNAME')
ROUT=0; CLT
CQN(P)
FAULT(70,ACC-1,0) IF TYPE=5 AND NAM=0 AND (ACC<=0 OR ACC>256)
P=P+1
->PK
FP(2): ! (RT)(%NAME')(NAMELIST)(FPP)
ROUT=1; NAM=1
ARR=0
IF A(P)=1 THEN START ; ! RT=%ROUITNE
TYPE=0; PREC=0
P=P+2
FINISH ELSE START
P=P+1; CLT; ! RT=(TYPE)(FM)
NAM=1
IF A(P)=2 THEN NAM=3; ! 1 FOR FN 3 FOR MAP
P=P+2; ! PAST (%NAME') WHICH IS IGNORED
FINISH
ACC=16
->PK
FP(3): ! %NAME
ACC=8; NAM=1
ROUT=0; TYPE=0
ARR=0; PREC=0
PK: PACK(PTYPE)
END
ROUTINE DIAG POINTER(INTEGER LEVEL)
IF PARMTRACE#0 THEN START
PUSH(RAL(LEVEL),1,CA,LDB<<24!3<<23)
PF1(LDB,0,0,0)
GRUSE(DR)=0
FINISH
END
ROUTINE RHEAD(INTEGER RTNAME,STRING (127) XNAME)
!***********************************************************************
!* COMPILES CODE FOR BLOCK AND ROUTINE ENTRY *
!* RTNAME IS THE RT/FN/MAP NAME (=-1 FOR %BEGIN BLOCKS) *
!* XNAME IS THE EXTERNAL NAME (="" FOR INTERNALS&BLOCKS *
!* ACTIONS INCLUDE PLANTING JUMPS ROUND RT BODY AND *
!* DEFINING EXTERNAL ENTRIES AS WELL AS PLANTING ENTRY CODE *
!***********************************************************************
INTEGER W1, W3, INSRN, AT, HEAD
RECORD (LISTF)NAME LCELL
PUSH(LEVELINF, 0, NMAX<<16!N, 0); ! SAVE DETAIL OF CURRENT LEVEL
IF RTNAME>=0 THEN START ; ! SECTION FOR ROUTINES
LCELL==ASLIST(TAGS(RTNAME))
!
! FIRST JUMP ROUND BODY UNLESS AT TOP LEVEL OR IN COMPILER
! OR A JUMP IS ALREADY OUTSTANDING AT THIS LEVEL
! MUST DO THIS HERE BEFORE LEVEL IS CHANGED OR LABEL LIST IS WRONG
!
IF COMPILER=0 AND LEVEL>1 AND JROUND(LEVEL+1)=0 START
PLABEL=PLABEL-1
JROUND(LEVEL+1)=PLABEL
ENTER JUMP(15,PLABEL,0)
FINISH
RLEVEL=RLEVEL+1; RBASE=RLEVEL
FINISH
LEVEL=LEVEL+1
NMDECS(LEVEL)=0; AUXSBASE(LEVEL)=0
NAMES(LEVEL)=-1
ONINF(LEVEL)=0; ONWORD(LEVEL)=0
FAULT(34, 0, 0) IF LEVEL=MAX LEVELS
FAULT(105, 0, 0) IF LEVEL>MAX LEVELS
!
! DEAL WITH EXTERNAL ENTRIES SO THAT THEY COME TO THIS POINT
! IN THE CODE. THE DESCRIPTORS SET UP ARE OF NO INTEREST TO THIS MODULE
! ONLY TO OTHER MODULES SO NO DETAILS OF THEN ARE RECORDED IN TAGS
!
IF XNAME#"" START ; ! A NAME MEANS AN ENTRY
CODEDES(W1); ! SET UP CODE DESCRIPTOR
W3=0
IF RTNAME<0 THEN W3=1; ! MAIN PROGRAM ENTRY
DEFINEEP(XNAME,CA,W1,W3); ! RELOCATE DESCPTR AND RECORD
IF W1 #0 THEN PSF1(INCA,0,-W1);! RESET DR TO GLA START
IF CA&3=0 THEN PF1(JUNC,0,0,4) ELSE PSF1(JUNC,0,3)
! JOIN INTERNAL AFTER LD
! ALLOWING FOR NOOPS
FINISH
CNOP(0,4); ! WORD ALIGN AS TAGS CAN ONLY
! STORE A WORD OFFSET IN 16 BITS
IF RTNAME>=0 THEN START ; ! ROUTINE ENTRY
IF LCELL_SNDISP=0 AND XNAME="" START ;! REPLACE 'NOT USED' BIT
LCELL_S1=LCELL_S1&X'FFFF3FFF'
FINISH
!
! NOW FILL ANY JUMPS TO THIS ROUTINE PLANTED SINCE
! THE ROUTINESPEC WAS COMPILED. SEE ALSO 'RT JUMP'
!
HEAD=LCELL_S2>>16
WHILE HEAD#0 CYCLE
POP(HEAD, INSRN, AT, W1)
W3=CA-AT
W3=W3//2 IF INSRN>>25=CALL>>1
INSRN=INSRN+W3
PLUG(1, AT, INSRN,4)
REPEAT
LCELL_S2=LCELL_S2&X'FFFF'!(CA>>2<<16);! NOTE ADDR FOR FUTURE CALLS
FINISH
!
! INTERNAL ENTRIES COME HERE. PLANT INTERNAL ENTRY PATH
!
IF RTNAME>=0 OR LEVEL=2 START
! PF1(LXN,0,TOS,0); ! WOULD BE NEEDED FOR FULL COMAPATABILITY
! WITH ICL SOFTWARE
PF1(LD,0,XNB,12); ! XNB== SOME OTHER DISPALY
! ACTIVE IN THIS MODULE
FINISH
!
! EXTERNAL AND INTERNAL PATHS JOIN HERE
!
IF RTNAME<0 THEN W3=0 ELSE W3=RTNAME+1
L(LEVEL)=LINE; M(LEVEL)=W3
FLAG(LEVEL)=PTYPE; ! CURRENT BLOCK TYPE MARKER
END
ROUTINE RDISPLAY(INTEGER RTNAME)
!***********************************************************************
!* 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 IN XNB *
!***********************************************************************
INTEGER W1,W2,STACK,OP,INC
IF RTNAME>=0 OR LEVEL=2 START ; ! DISPLAY NEEDED
STACK=0; DISPLAY(RLEVEL)=N
GRUSE(XNB)=0
GRUSE(CTB)=0; GRUSE(BREG)=0
IF RLEVEL>1 THEN GRUSE(XNB)=4 AND GRINF1(XNB)=RLEVEL-1
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
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 RTNAME>=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 RTNAME>=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 RTNAME>=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 RTNAME>=0 AND PARMCHK#0 START
CHECK STOF; ! CHECK FOR STACK O'FLOW
FINISH
IF PARMDBUG#0 THEN SET LINE; ! TO CALL DBUG PACKAGE
END
ROUTINE CHECK STOF
!***********************************************************************
!* CHECK THE STACK FOR OVERFLOW (LEAVING 4K MARGIN FOR MDIAG *
!***********************************************************************
IF PARMOPT#0 THEN START
!
! STSF TOS GET STACK POINTER
! LSS TOS
! USH +14
! USH -15 LOSE SEGMENT NO
! ICP X'1F800' CHECK WITHIN SEG ADDRESS
! SHIFTED DOWN 1 PLACE
! JCC 2,EXCESS BLKS
!
PF1(STSF,0,TOS,0)
PF1(LSS,0,TOS,0)
PSF1(USH,0,14)
PSF1(USH,0,-15)
PF1(ICP,0,0,ST LIMIT>>1)
PPJ(2,8)
FINISH
END ; ! OF ROUTINE RHEAD
ROUTINE CIOCP(INTEGER N,REG)
!***********************************************************************
!* COMPILES A CALL ON IOCP ENTRY POINT NO 'N' *
!* 2ND PARAMETER IS ALREAD IN THE ACC WHICH IS 32 BITS *
!***********************************************************************
INTEGER XYNB,OP1,OP2
IF IOCPDISP=0 THEN CXREF(IOCPEP,PARMDYNAMIC,2,IOCPDISP)
IF REGISTER(BREG)#0 THEN BOOT OUT(BREG)
IF REG=ACCR THEN OP1=LUH AND OP2=ST C
ELSE OP1=LDTB AND OP2=STD
PSF1(OP1,0,N)
PSF1(PRCL,0,4)
PF1(OP2,0,TOS,0)
XYNB=SET XORYNB(-1,-1); ! TO PLT
PSF1(RALN,0,7)
PF1(CALL,2,XYNB,IOCPDISP)
FORGET(-1)
END
ROUTINE CUI(INTEGER CODE)
!***********************************************************************
!* COMPILE AN UNCONDITIONAL INSTRN WHEREEVER IT OCCURS *
!* CODE=0 UNCONDITIOALLY,=1 AFTER %THEN, =2 AFTER %ELSE *
!***********************************************************************
INTEGER MARKER,J,LNAME,TYPEP,PRECP,GWRDD,LWB,XYNB,ARRP,ALT,ASSOP
SWITCH SW(1:9)
REPORTUI=0
ALT=A(P)
->SW(ALT)
SW(1): ! (NAME)(APP)(ASSMNT?)
P=P+1; MARKER=P+FROMAR2(P)
IF A(MARKER)=1 THEN START
J=P+2; P=MARKER+2
ASSIGN(A(MARKER+1),J)
FINISH ELSE START
P=P+2
CNAME(0,0)
P=P+1
FINISH
AUI: J=A(P); P=P+1
IF J=1 THEN CUI(CODE)
RETURN
SW(2): ! -> (NAME)(APP)
NMDECS(LEVEL)=NMDECS(LEVEL)!1
CURR INST=1 IF CODE=0
LNAME=FROM AR2(P+1)
J=A(P+3); P=P+4
IF J=2 THEN START ; ! SIMPLE LABEL
ENTER JUMP(15,LNAME,0)
REPORTUI=1
FINISH ELSE START ; ! SWITCH LABELS
COPY TAG(LNAME)
ARRP=ARR
GWRDD=SNDISP<<2; ! BYTE DISP OF DESCRIPTOR IN PLT
UNLESS OLDI=LEVEL AND TYPE=6 START
FAULT(4,0,LNAME); P=P-1; SKIP APP
RETURN
FINISH
LWB=FROM2(K); ! GET LOWER BOUND
CSEXP(BREG,X'51')
IF ARRP=1 THEN PSF1(SBB,0,LWB)
XYNB=SET XORYNB(-1,-1); ! TO PLT
PF1(LB,3,XYNB,GWRDD); ! OFFSET FROM HD OF CODE
PF1(ADB,0,XYNB,24); ! RELOCATE
PF1(JUNC,0,BREG,0); ! AND GO
REPORTUI=1; FORGET(-1)
FINISH
RETURN
SW(3): ! RETURN
FAULT(30,0,0) UNLESS FLAG(LEVEL)&X'3FFF'=X'1000'
P=P+1
RET: RT EXIT
REPORT UI=1
CURR INST=1 IF CODE=0
RETURN
SW(4): ! %RESULT(ASSOP)(EXPR)
PTYPE=FLAG(LEVEL)&X'3FFF'; UNPACK
ASSOP=A(P+1); P=P+2
IF PTYPE>X'1000' AND ASSOP#3 THEN START ;! ASSOP #'->'
IF ASSOP=1 AND NAM#0 AND A(P+3)=4 AND A(P+4)=1 START
P=P+5; TYPEP=TYPE; PRECP=PREC; J=P
CNAME(4,ACCR)
FAULT(81,0,0) UNLESS A(P)=2; P=P+1
FAULT(83,M(LEVEL)-1,FROMAR2(J)) C
UNLESS TYPEP=TYPE AND PRECP=PREC
->RET
FINISH
IF ASSOP=2 THEN START ; ! ASSOP='='
IF NAM#0 THEN TYPE=1; ! MAPS HAVE INTEGER RESULTS
IF TYPE=5 THEN START
CSTREXP(0,ACCR)
PSF1(LD,1,DISPLAY(RBASE)-8); ! RESULT DESCRPT
PF1(IAD,0,PC,SPECIAL CONSTS(2))
PF2(MV,1,1,0,0,UNASSPAT&255)
PSF1(LDB,2,DISPLAY(RBASE)-8)
COPY DR
FINISH ELSE IF TYPE=3 START
->BADRES UNLESS A(P+3)=4 AND A(P+4)=1
P=P+5
CNAME(3,ACCR)
FAULT(66,0,M(LEVEL)-1) UNLESS TYPE=3
PSF1(LD,1,DISPLAY(RBASE)-8)
PF2(MV,1,1,0,0,UNASSPAT&255)
PSF1(LSD,1,DISPLAY(RBASE)-8)
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
BADRES:
FAULT(31,0,0)
SKIP EXP; ! IGNORE SPURIOUS RESULT
RETURN
SW(5): ! %MONITOR (AUI)
PSF1(LSD,0,0); ! ERR=0 & EXTRA =0
PPJ(0,2); ! TO ERROR ROUTINE
P=P+1; ->AUI
SW(6): ! %STOP
PPJ(0,21)
P=P+1
CURR INST=1 IF CODE=0
REPORTUI=1
RETURN
SW(7): !'%SIGNAL'(EVENT')(N)(OPEXPR)
PSF1(PRCL,0,4)
PSF1(JLK,0,1); ! STACK DUMMY PC
IF NMDECS(LEVEL)&16 #0 START ;! IN AN 'ON' GROUP
IF FLAG(LEVEL)<=2 START ; ! IN A BEGIN BLOCK
PSF1(LD,1,12); ! SO RESET DIAG POINTER
DIAGPOINTER(LEVEL-1); ! TO NEXT OUTER BLOCK
PSF1(STD,1,12)
PF1(STLN,0,TOS,0)
FINISH ELSE START ; ! 'ON IN A RT/FN/MAP
PSF1(LSS,1,0); ! GET PREVIOUS LNB
PF1(ST,0,TOS,0); ! AND STACK THAT
FINISH
FINISH ELSE PF1(STLN,0,TOS,0)
GRUSE(ACCR)=0
P=P+5; KK=INTEXP(J); ! EVENT NO TO J
FAULT(26,J,0) UNLESS KK=0 AND 1<=J<=15
IF A(P)=1 START ; ! SUBEVENT SPECIFIED
P=P+1; CSEXP(ACCR,X'51')
PF1(AND,0,0,255)
PF1(OR,0,0,256*J)
FINISH ELSE PF1(LSS,0,0,256*J)
PSF1(SLSS,0,0)
PF1(ST,0,TOS,0)
XYNB=SET XORYNB(-1,-1); ! TO PLT
PSF1(RALN,0,9)
PF1(CALL,2,XYNB,40)
CURR INST=1 IF CODE=0
REPORTUI=1; RETURN
SW(8): ! %EXIT
SW(9): ! %CONTINUE
ALT=ALT&7; ! 0 FOR EXIT 1 FOR CONTINUE
IF EXITLAB=0 THEN FAULT(54+ALT,0,0) AND RETURN
KK=INTEGER(ADDR(EXITLAB)+4*ALT)
ENTER JUMP(15,KK,B'10')
REPORTUI=1
CURR INST=1 IF CODE=0
END
ROUTINE CIFTHEN(INTEGER MARKIU,MARKC,MARKUI,MARKE,MARKR,SKIP)
!***********************************************************************
!* THIS ROUTINE COMPILES CONDITIONAL EXPRESSIONS.IT REQUIRES THE *
!* FOLLOWING PARAMETERS TO BE SET TO THEIR A .R. ENTRY. *
!* MARKIU TO THE ENTRY FOR P(%IU) *
!* MARKC TO THE ENTRY FOR P(COND) *
!* MARKUI TO THE ENTRY FOR (FIRST OCCURRENCE OF) P(UI) *
!* MARKE TO THE ENTRY FOR P(ELSE') - =0 FOR BACKWARDS CONDITION *
!* MARKR TO ENTRY FOR P(RESTOFIU) - =0 FOR BACKWARDS CONDITION *
!***********************************************************************
INTEGER ALTUI,CCRES,ELRES,THENLAB,ELSELAB,USERLAB,REPORT,START, C
ELSEALT,K
CONSTINTEGER NULL ELSE=4
SWITCH ESW(1:NULL ELSE)
MARKIU=A(MARKIU); ! ALT OF IU 1=%IF,2=%UNLESS
PLABEL=PLABEL-1
THENLAB=PLABEL
START=0; ! NO START IN CONDITION YET
ELSELAB=0; ! MEANS NO ELSE CLAUSE
P=MARKC
IF MARKR>0 AND A(MARKR)<=2 THEN START=1;! '%START' OR '%THENSTART'
IF MARKE#0 AND LEVEL<2 AND START=0 THEN FAULT(57,0,0)
USERLAB=-1
IF START#0 THEN ALTUI=0 ELSE ALTUI=A(MARKUI)
IF ALTUI=2 AND A(MARKUI+3)=2 THEN C
USERLAB=FROM AR2(MARKUI+1); ! UI = SIMPLE LABEL
IF 8<=ALTUI<=9 AND EXITLAB#0 START ; ! VALID EXIT
IF ALTUI=8 THEN USERLAB=EXITLAB ELSE USERLAB=CONTLAB
FINISH
!
IF SKIP=YES THEN START ; ! NO CODE NEEDED
IF START#0 START
P=MARKR+1
CSTART(2,1); ! NO CODE
MARKE=P
FINISH
CCRES=1; ! NO CODE FOR ELSE
->ELSE
FINISH
!
IF USERLAB>=0 THEN START ; ! FIRST UI IS'->'<LABEL>
NMDECS(LEVEL)=NMDECS(LEVEL)!1
CCRES=CCOND(0,3-MARKIU,USERLAB,1);! UPDATE LINE ALSO
IF CCRES#0 THEN CCRES=CCRES!!3;! CONDITION BACKWARDS!
THENLAB=0; ! NO THENLAB IN THIS CASE
REPORT=1; ! UI TRANSFERED CONTROL
FINISH ELSE START
CCRES=CCOND(1,MARKIU,THENLAB,1);! UPDATE LINE ALSO
IF START#0 THEN START ; ! %THEN %START
IF CCRES=0 START ; ! CONDITIONAL
FAULT(57,0,0) IF LEVEL<2
NMDECS(LEVEL)=NMDECS(LEVEL)!1
FINISH
P=MARKR+1
CSTART(CCRES,1)
IF A(P)<=2 THEN PLABEL=PLABEL-1 AND ELSELAB=PLABEL
MARKE=P
REPORT=LAST INST
FINISH ELSE START
IF CCRES#2 START
P=MARKUI; CUI(1)
REPORT=REPORTUI
FINISH ELSE START ; ! FIRST UI NEVER EXECUTED
REPORT=1
FINISH
FINISH
FINISH
ELSE: ! ELSE PART
IF MARKE=0 OR A(MARKE)=2 THEN C
ELSEALT=NULL ELSE AND P=MARKE+1 ELSE START
ELSEALT=A(MARKE+1)
P=MARKE+2
PLABEL=PLABEL-1
ELSELAB=PLABEL
FINISH
IF REPORT=0=CCRES AND ELSEALT<NULL ELSE THEN REPORT=1 AND C
ENTER JUMP(15,ELSELAB,B'10');! LONG JUMP BUT SAVE ENV
IF THENLAB>0 THEN ELRES=ENTER LAB(THENLAB,B'11'!REPORT<<2)
! CONDITIONAL&MERGE OR REPLACE
->ESW(ELSEALT)
ESW(1): ! '%ELSESTART'
IF CCRES=0 THEN NMDECS(LEVEL)=NMDECS(LEVEL)!1
CSTART(CCRES,2)
REPORT=LAST INST
->ENTER ELSELAB
ESW(2): ! '%ELSE' (%IU) ETC
MARKE=0; MARKUI=0
MARKR=P+1+FROMAR2(P+1)
IF A(MARKR)=3 THEN START
MARKE=MARKR+1+FROM AR2(MARKR+1)
MARKUI=MARKR+3
FINISH
IF CCRES=1 OR SKIP=YES THEN K=YES ELSE K=NO
CIFTHEN(P,P+3,MARKUI,MARKE,MARKR,K)
REPORT=0; ! CANT TELL IN GENERAL
->ENTER ELSELAB
ESW(3): ! '%ELSE'<UI>
IF CCRES#1 THEN START
IF START#0 THEN SET LINE; ! FOR CORRECT LINE IF FAILS IN UI
IF THENLAB=0 THEN K=0 ELSE K=2
CUI(K)
REPORT=REPORTUI
FINISH
ENTER ELSELAB:
IF ELSELAB>0 THEN ELRES=ENTER LAB(ELSELAB,B'11'!REPORT<<2)
! CONDITIONAL MERGE
ESW(NULL ELSE): ! NULL ELSE CLAUSE
END
ROUTINE CSTART(INTEGER CCRES,CODE)
!***********************************************************************
!* COMPILE A COMPLETE START-FINISH BLOCK BY RECURSION *
!* IF START NEVER EXECUTED SKIP TO CORRESPONDING FINISH *
!* CODE=0 WAS UNCONDITIONAL NOW SHOULD BE UNUSED *
!* CODE=1 AFTER THEN *
!* CODE=2 AFTER ELSE *
!* CODE=3 AFTER ONEVENT *
!* P ON ENTRY TO FORWARD POINTER TO THE RIGHT FINISH *
!* P ON EXIT TO THE ELSE CLAUSE AFTER THE RIGHT FINISH *
!***********************************************************************
INTEGER SKIPCODE,FINISHAR,OLDNEXTP,OLDLINE
SKIPCODE=NO
IF 1<=CODE<=2 AND CCRES!CODE=3 THEN SKIPCODE=YES;! NEVER EXECUTED
FINISHAR=FROMAR4(P); ! TO START OF AR FOR FINISH
IF FINISHAR<=P THEN ABORT; ! FOR TESTING
OLDLINE=LINE; ! FOR ERROR MESSAGES
CYCLE ; ! THROUGH INTERVENING STATMNTS
OLDNEXTP=NEXTP
IF SKIP CODE=NO THEN COMPILE A STMNT ELSE START
LINE=A(NEXTP+3)<<8!A(NEXTP+4)
NEXTP=NEXTP+A(NEXTP)<<16+A(NEXTP+1)<<8+A(NEXTP+2)
FINISH
REPEAT UNTIL OLDNEXTP>=FINISHAR;! HAVING COMPILED FINISH
P=FINISHAR+6; ! TO ELSE CLAUSE
!
IF A(P)=1 AND CODE#1 THEN FAULT(45+CODE,OLDLINE,0)
IF SKIPCODE=YES THEN LAST INST=1
END
ROUTINE CCYCBODY(INTEGER UA,ELAB,CLAB)
!***********************************************************************
!* COMPILES A CYCLE REPEAT BODY BY RECURSION *
!* ON ENTRY P IS TO FORWARD POINTER. ON EXIT TO ALT OF UNTIL *
!* UA = O IF UNTIL NOT ALLOWED *
!* ELAB&CLAB ARE LABELS FOR ELSE & CONTINUE *
!***********************************************************************
INTEGER FINISHAR,OLDLINE,SAVEE,SAVEC
FINISHAR=FROMAR4(P)
IF FINISHAR<=P THEN ABORT
OLDLINE=LINE; SAVEE=EXIT LAB; SAVEC=CONTLAB
EXITLAB=ELAB; CONTLAB=CLAB
WHILE NEXTP<=FINISHAR CYCLE
COMPILE A STMNT
REPEAT
EXIT LAB=SAVEE; CONTLAB=SAVEC
P=FINISHAR+6
IF A(P)=1 AND UA=0 THEN FAULT(12,OLDLINE,0)
END
ROUTINE CLOOP(INTEGER ALT, MARKC, MARKUI)
!***********************************************************************
!* ALT=1 FOR %WHILE, =2 FOR %UNTIL, =3 FOR %FOR *
!* MARKC IS TO THE CONDITION OR CONTROL CLAUSE *
!* MARKUI IS TO THE UI, SPECIAL FOR %CYCLE *
!***********************************************************************
INTEGER L1,L2,L3,CCRES,ELRES,FLINE
INTEGER FORNAME,INITTYPE,INITVAL,STEPTYPE,STEPVAL,FINALTYPE,FINALVAL,C
FACC,FDISP,FBASE,INITP,REPMASK,USEDEBJ,DEBTO,FPREC
ROUTINESPEC FOREXP(INTEGERNAME ETYPE,EVALUE,INTEGER TT,REG)
ROUTINESPEC VALIDATE FOR
SWITCH SW(0:6)
P=MARKC
SFLABEL=SFLABEL-2
L1=SFLABEL; L2=L1+1
!
! SET L3 FOR ALTS 0,5&6 ONLY
!
L3=0
IF B'1100001'&1<<ALT#0 THEN L3=SFLABEL-1 AND SFLABEL=L3
!
! UPDATE THE LINE NUMBER FOR ALTS 1 TO 3 ONLY
!
IF 1<=ALT<=3 THEN SET LINE
!
! ENTER THE FIRST LABEL(L1) FOR ALL ALTS EXCEPT 3 & 6
!
IF B'0110111'&1<<ALT#0 THEN ELRES=ENTER LAB(L1,0)
->SW(ALT)
SW(0): ! %CYCLE
C CYC BODY(1,L2,L3)
ELRES=ENTER LAB(L3,B'011')
IF A(P)=1 START ; ! %REPEAT %UNTIL <COND>
P=P+1; CCRES=CCOND(0,1,L1,1);! UPDATE LINE ALSO
FINISH ELSE ENTER JUMP(15,L1,0)
ELRES=ENTER LAB(L2,B'011')
WAYOUT: ! REMOVE LABELS NOT REQUIRED
REMOVE LAB(L1)
REMOVE LAB(L2)
REMOVE LAB(L3) IF L3>0
RETURN
SW(1): ! UI WHILE COND
CCRES=CCOND(0,1,L2,0)
P=MARKUI
CUI(1)
ENTERJUMP(15,L1,0); ! UNCONDITIONALLY BACK TO WHILE
ELRES =ENTER LAB(L2,B'111'); ! CONDITIONAL(?) & REPLACE ENV
->WAYOUT
SW(2): ! UI %UNTIL COND
P=MARKUI
CUI(1)
P=MARKC
CCRES=CCOND(0,1,L1,0)
->WAYOUT
SW(6): ! %FOR ... %CYCLE
SET LINE
SW(3): ! UI %FOR ....
FORNAME=FROMAR2(P)
INITP=P+2; P=INITP
COPY TAG(FORNAME)
FDISP=K; FBASE=I; FACC=2*NAM; FPREC=PREC
FAULT(91,0,FORNAME) UNLESS TYPE=1 AND 4<=PREC<=5 AND ROUT=0=ARR
WARN(4,FORNAME) UNLESS FBASE=RBASE
!
SKIP EXP; ! P TO STEP EXPRSN
FOR EXP(STEPTYPE,STEPVAL,1,ACCR); ! STEP TO ACCR AND TEMP
IF STEPTYPE=0 START
FAULT(92,0,0) IF STEPVAL=0; ! ZERO STEP
FINISH ELSE START
IF PARMOPT#0 THEN PPJ(20,11);! FAULT COMPUTED ZERO STEP
FINISH
!
FOR EXP(FINALTYPE,FINALVAL,1,ACCR);! EVALUATE FINAL
!
P=INITP
FOR EXP(INITTYPE,INITVAL,0,BREG);! INITIAL VALUE TO B
IF PARMOPT#0 THEN VALIDATE FOR
!
USEDEBJ=0; ! DONT USE IT
IF STEPVAL=-1 AND FINALTYPE!STEPTYPE=0 AND FINALVAL=1 START
USEDEBJ=1; ! CAN USE BEST BRANCH INSTRN
PSF1(LB,0,INITVAL) IF INITTYPE=0
UNLESS INITTYPE=0 AND INITVAL>=1 THEN C
ENTERJUMP(32+13,L2,B'10'); ! JAF B>0 NO TRAVERSES
DEBTO=CA; ! SAVE CA FOR DEBJ
FORGET(-1)
FINISH ELSE START
IF INITTYPE!STEPTYPE=0 THEN START
PSF1(LB,0,INITVAL-STEPVAL)
FINISH ELSE START
PSF1(LB,0,INITVAL) IF INITTYPE=0
PSF1(SBB,STEPTYPE,STEPVAL)
FINISH
!
! HAVE B SET TO INIT-STEP. FOR COMPUTED STEPS NOW MUST CHECK
! FOR NEGATIVE TRAVERSES. FOR FIXED STEPS THIS CAN BE SET
! IN MASK FOR REPEATING
!
IF STEPTYPE=1 THEN START
PF1(LSS,0,BREG,0)
PSF1(IRSB,FINALTYPE,FINALVAL)
PSF1(IDV,1,STEPVAL)
GRUSE(ACCR)=0
ENTERJUMP(37,L2,B'10')
REPMASK=8
FINISH ELSE REPMASK=8!(2<<(STEPVAL>>31)); ! A OR C
!
ELRES=ENTER LAB(L1,0); ! LABEL FOR REPEATING
!
IF STEPTYPE=0 AND STEPVAL=1 START
PSF1(CPIB,FINALTYPE,FINALVAL)
FINISH ELSE START
PSF1(CPB,FINALTYPE,FINALVAL)
PSF1(ADB,STEPTYPE,STEPVAL)
FINISH
GRUSE(BREG)=0
ENTER JUMP(REPMASK,L2,B'10')
FINISH
BASE=FBASE; AREA=-1
ACCESS=FACC; DISP=FDISP
NAMEOP(1,BREG,BYTES(FPREC),FORNAME)
PSORLF1(STB,ACCESS,AREA,DISP)
NOTE ASSMENT(BREG,2,FORNAME)
!
P=MARKUI; ! TO UI OR '%CYCLE'(HOLE)
IF ALT=3 THEN START ; ! DEAL WITH CONTROLLED STMNTS
CUI(0)
FINISH ELSE START
CCYCBODY(0,L2,L3)
ELRES=ENTER LAB(L3,B'011'); ! LABEL FOR CONTINUE
FINISH
BASE=FBASE; ACCESS=FACC
AREA=-1; DISP=FDISP
NAMEOP(2,BREG,BYTES(FPREC),FORNAME);! CONTROL TO B
IF USEDEBJ=0 THEN ENTER JUMP(15,L1,0) ELSE C
PSF1(DEBJ,0,(DEBTO-CA)//2) AND GRUSE(BREG)=0
ELRES=ENTERLAB(L2,B'111'!!(USEDEBJ<<2));! REPLACE ENV UNLESS DEBJ
! WHEN MERGE ENV
->WAYOUT
SW(4): ! %WHILE COND %CYCLE
CCRES = CCOND(0,1,L2,1); ! UPDATE LINE IF NEEDED
C CYC BODY(0,L2,L1)
ENTER JUMP(15,L1,0)
ELRES = ENTER LAB(L2,B'111'); ! CONDITIONAL & REPLACE ENV
->WAYOUT
SW(5): ! %UNTIL ... %CYCLE
! ALSO %CYCLE... %REPEAT %UNTIL
! MARKUI TO %CYCLE
P=MARKUI
FLINE=LINE
C CYC BODY(0,L2,L3)
P=MARKC; ELRES=ENTER LAB(L3,B'011');! CONTINUE LABEL IF NEEDED
LINE=FLINE; SET LINE
CCRES=CCOND(0,1,L1,1); ! UPDATE LINE IF NEEDED
ELRES=ENTER LAB(L2,B'011')
->WAYOUT
ROUTINE FOREXP(INTEGERNAME ETYPE,EVALUE,INTEGER TOTEMP,USEREG)
!***********************************************************************
!* P INDEXES EXPRESSION. IF CONST PUT INTO EVALUE OTHERWISE *
!* COMPILE TO USEREG AND STORE IN TEMP IF TOTEMP#0 *
!***********************************************************************
INTEGER INP,VAL,OP
INP=P; P=P+3
IF INTEXP(VAL)=0 AND X'FFFE0000'<=VAL<=X'1FFFF' START
EVALUE=VAL; ETYPE=0; ! EXPRESSION A LITERAL CONST
RETURN
FINISH
P=INP
CSEXP(USEREG,X'51'); ! INTEGER MODE TO REG
ETYPE=1; ! NOT CONST
IF TOTEMP#0 START
GET WSP(VAL,1)
IF USEREG=ACCR THEN OP=ST ELSE OP=STB
PSF1(OP,1,VAL)
EVALUE=VAL
FINISH
END
ROUTINE VALIDATE FOR
!***********************************************************************
!* INITIAL VALUE IN BREG OR A CONSTANT *
!***********************************************************************
INTEGER J
IF INITTYPE!STEPTYPE!FINALTYPE=0 START
J=FINALVAL-INITVAL; ! ALL CONSTANT CAN CHECK NOW
IF STEPVAL=0 OR (J//STEPVAL)*STEPVAL#J THEN FAULT(93,0,0)
RETURN
FINISH
IF STEPTYPE=0 AND (STEPVAL=1 OR STEPVAL=-1) THEN RETURN
!
! CHECK BY PLANTING CODE
!
IF INITTYPE=0 THEN PSF1(LSS,0,INITVAL) ELSE PF1(LSS,0,BREG,0)
PSF1(IRSB,FINALTYPE,FINALVAL)
PSF1(IMDV,STEPTYPE,STEPVAL)
PF1(LSS,0,TOS,0)
GRUSE(ACCR)=0
PPJ(36,11)
END
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,REG,STCODE,SWKAREA, C
RHTYPE,ACCP,II,HEAD1,NOPS,TPCELL,LVL,BOT1,LHNAME,RHNAME
RECORD (RD) R
SWITCH SW(0:3); ! TO SWITCH ON ASSOP
P2=P
IF ASSOP>4 THEN RHTYPE=TYPE
LHNAME=A(P1)<<8!A(P1+1)
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 ; ! ONLY USED FOR READCH ETC
FAULT(25,0,0) UNLESS TYPE=RHTYPE
PUSH(HEAD1,RHTYPE<<16!9,0,0)
OLINK(ACCR)=HEAD1
FINISH ELSE TORP(HEAD1,BOT1,NOPS); ! RHS TO REVERSE POLISH
EXPOP(HEAD1,-1,NOPS,256+PRECP<<4+TYPEP); ! PLANT CODE
! 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=""
!
IF A(P+3)=4 AND A(P+4)=2 AND C
A(P+5)=X'35' 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(16,ACCR)
ASSOP=ASSOP&3
SWKAREA=VALUE; ! REMEMBER AND HOLD WKAREA
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 ASSOP#3 AND (ROUT#0 OR NAM#0=ARR) AND QQ=0 START
! LHS=MAP : DR BOUND NOT VALID
! ALSO NAMES MAPPED ==STRING(ADDR)
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 START
IF QQ>128 THEN PF2(MV,0,0,127,0,0) AND QQ=QQ-128
PF2(MV,0,0,QQ&127,0,0)
FINISH 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
IF SWKAREA>0 THEN RETURN WSP(SWKAREA,268);! RETURN WKAREA
! WHICH MUST BE HELD DURING LHS
! EVALUATION FOR CERTAIN PATHOLOGICAL
! PROGRAMS
P=Q; RETURN
!
! THIS SECTION DEALS WITH OPERATIONS ON COMPLETE RECORDS
!
RECOP: ! LHS IS RECORD WITHOUT SUBNAME
REG=ACCR; ! IN CASE FAULT 66
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 OR ARR#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(5,ACCR); ! 5 TO ALLOW RECORD FNS
ACCP=ACC
UNLESS A(P)=2 THEN FAULT(66,0,LHNAME) AND ->F00
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)
IF ASSOP=2 AND ACCP#ACC THEN C
FAULT(67,LHNAME,FROMAR2(P2+5)) AND ->F00
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;
IF TYPE=5 THEN CRES(0) ELSE START
SKIP EXP
FAULT(71,0,FROMAR2(P1)) UNLESS TYPE=7
FINISH
RETURN
SW(1): ! '==' AND %NAME PARAMETERS
REG=ACCR; STCODE=ST; ! NORMALLY USE ACC
->F81 UNLESS A(P2+3)=4 AND A(P2+4)=1
FAULT(82,0,LHNAME) AND ->F00 UNLESS NAM=1 AND LITL#1
! ONLY NON-CONST POINTERS ON LHS OF==
P=P2+5
RHNAME=A(P)<<8!A(P+1)
->ARRNAME IF ARR=1
IF A(P1+2)=2=A(P1+3) START ; ! LHS SCALAR POINTERNAME
COPYTAG(RHNAME) ; ! LOOK AT RHS
IF PTYPE#SNPT AND ARR#0 THEN REG=DR AND STCODE=STD
FINISH
CNAME(3,REG); ! DESCRPTR TO ACC
R_PTYPE=X'61'; R_FLAG=9
R_XB=REG
OLINK(REG)=ADDR(R)
REGISTER(REG)=1
->F81 UNLESS A(P)=2; ! NO REST OF EXP ON RHS
Q=P+1; P=P1
->F83 UNLESS TYPE=TYPEP AND PREC=PRECP
->F86 UNLESS OLDI<=LVL OR BASE=0 OR NAM#0
! GLOBAL == NONOWN LOCAL
CNAME(6,0)
IF R_FLAG#9 THEN START
IF REG#ACCR THEN ABORT
PF1(LSD,0,TOS,0)
GRUSE(ACCR)=0
FINISH
REGISTER(REG)=0
COM: PSORLF1(STCODE,ACCESS,AREA CODE,DISP)
IF REG=DR AND ACCESS#0 THEN ABORT
NOTE ASSMENT(REG,1,A(P1)<<8!A(P1+1))
P=Q; RETURN
ARRNAME: CNAME(12,ACCR)
IF ACCESS>=8 THEN ACCESS=ACCESS-4 ELSE ACCESS=0
->F83 UNLESS TYPE=TYPEP AND PREC=PRECP C
AND ARR>0
->F86 UNLESS OLDI<=LVL OR BASE=0 OR NAM#0
! GLOBAL == NONOWN LOCAL
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)
->F81 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
F83: FAULT(83,LHNAME,RHNAME); ->F00
F86: FAULT(86,LHNAME,RHNAME); ->F00
F81: FAULT(81,0,LHNAME)
F00:
REGISTER(REG)=0
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,EXPBOT
EXPHEAD=0; EXPBOT=0
NOPS=0
P=P+3
TORP(EXPHEAD,EXPBOT,NOPS)
!
EXPOP(EXPHEAD,REG,NOPS,MODE)
! CLEAR LIST(EXPHEAD)
ASLIST(EXPBOT)_LINK=ASL
ASL=EXPHEAD
END
INTEGERFN CONSTEXP(INTEGER PRECTYPE)
!***********************************************************************
!* COMPILES AN EXPRESSION WHICH SHOULD EVALUATE TO A CONSTANT OF *
!* TYPE 'PRECTYPE'. P AS FOR FN INTEXP. *
!***********************************************************************
INTEGER EXPHEAD,EXPBOT,NOPS,RES
EXPHEAD=0; EXPBOT=0; NOPS=0; RES=0
TORP(EXPHEAD,EXPBOT,NOPS)
->WAYOUT UNLESS NOPS&X'00040000'=0
EXPOP(EXPHEAD,ACCR,NOPS,X'200'+PRECTYPE)
IF EXPOPND_FLAG=3 THEN RES=EXPOPND_XTRA AND ->WAYOUT
->WAYOUT UNLESS EXPOPND_FLAG<=1
RES=ADDR(EXPOPND_D)
WAYOUT:
MONITOR IF RES=0 AND DCOMP#0
ASLIST(EXPBOT)_LINK=ASL
ASL=EXPHEAD
RESULT =RES
END
INTEGERFN INTEXP(INTEGERNAME VALUE)
!***********************************************************************
!* COMPILES AN EXPRESSION WHICH SHOULD EVALUATE TO A CONSTANT *
!* VALUE RETURNED IN VALUE. RESULT#0 IF FAILED TO EVALUATE *
!* P POINTS TO P(+') IN (+')(OPERNAD)(RESTOFEXPR) *
!***********************************************************************
INTEGER EXPHEAD,EXPBOT,NOPS,CODE,SPTYPE,SACC
EXPHEAD=0; EXPBOT=0; NOPS=0; CODE=0
SPTYPE=PTYPE; SACC=ACC; ! CALLED IN DECLARATIONS
TORP(EXPHEAD,EXPBOT,NOPS)
IF NOPS&X'00040000'=0 AND TYPE=1 START
EXPOP(EXPHEAD,ACCR,NOPS,X'251')
CODE=1 UNLESS EXPOPND_FLAG<=1 AND EXPOPND_PTYPE=X'51'
VALUE=EXPOPND_D
FINISH ELSE CODE=1 AND VALUE=1
ASLIST(EXPBOT)_LINK=ASL
ASL=EXPHEAD
ACC=SACC; PTYPE=SPTYPE
UNPACK
RESULT =CODE
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 *
!* THE TOP 20 BITS OF NOPS ARE USED TO RETURN DETAILS OF THE EXPR *
!* THESE BITS SIGNIFY AS FOLLOWS:- *
!* 1<<17 CONTAINS VARIABLE OF MORE THAN 32 BITS *
!* 1<<18 NOT CONSTANT EXPRSSN IE CONTAINS AT LEAST 1 VARIABLE *
!* 1<<19 COMPLEX IE CONTAINS FN CALL OR NEEDS DR TO EVALUATE *
!* 1<<20 CONTAINS THE OPERATOR + *
!* 1<<21 CONTAINS THE - OPERATOR(INCLUDES UNARY MINUS) *
!* 1<<22 CONTAINS OPERATOR !! (INCUDES UNARY NOT) *
!* 1<<23-7 CONTAINS OPERATORS !,*,//,/,& RESPECTIVELY *
!* 1<28&9 CONTAINS << OR >> *
!* 1<<30 CONTAINS EXPONETIATION *
!***********************************************************************
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
RECORD (LISTF)NAME LCELL
!
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=X'FFFF' THEN PTYPE=7;! NAME NOT SET
TYPE=PTYPE&7; PREC=PTYPE>>4&15
IF PTYPE=SNPT THEN START
D=LCELL_S3>>16
IF D=38 AND A(P+2)=2 THEN START ; ! PICK OFF NL
RPTYPE=0; RPINF=10; PTYPE=X'51'; P=P+2; ->SKNAM
FINISH
IF D=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(D); UNPACK
FINISH
IF PTYPE&X'FF00'=X'4000' AND A(P+2)=2=A(P+3) 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 AND PTYPE=X'51'
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 AND XTRA=-1
OPMASK=OPMASK!(COMPLEX<<19)
IF A(P+2)#2 OR A(P+3)#2 THEN XTRA=-1;! XTRA=NAME FOR LOCAL SCALRS ONLY
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 PREC>=6 THEN OPMASK=OPMASK!1<<17;! MORE THAN 32 BITS
RPTYPE=2; RPINF=P; PTYPE=X'51' IF PTYPE=7
IF TYPE=5 THEN FAULT(76,0,OPNAME) AND RPTYPE=0 AND C
PTYPE=X'51'
IF TYPE=2 THEN REAL=1
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: IF RPTYPE=2 THEN OPMASK=OPMASK!1<<18
BINSERT(RPHEAD,RPBOT,PTYPE<<16!COMPLEX<<8!RPTYPE,RPINF,XTRA)
-> OP
OPERAND(2): ! CONSTANT
PTYPE=A(P); D=PTYPE>>4
IF D>=6 THEN OPMASK=OPMASK!1<<17;! MORE THAN 32 BIT OPERAND
C=PTYPE&7
IF D=4 THEN START
RPINF=FROM AR2(P+1)
PTYPE=X'51'
FINISH ELSE 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(77,0,0); RPINF=1; RPTYPE=0
P=P+A(P+5)+7; PTYPE=X'51'
FINISH ELSE START
IF D=7 THEN XTRA=ADDR(A(P+1)) AND RPTYPE=3
IF PTYPE=X'51' AND X'FFFE0000'<=RPINF<=X'1FFFF' THEN C
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(78,0,0)
OPPREC=PRECEDENCE(OPERATOR)
OPERATOR=OPVAL(OPERATOR)
IF OPERATOR=26 OR OPERATOR=30 THEN REAL=1
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
IF OPERATOR>=31 THEN OPERATOR=30
OPMASK=OPMASK!(1<<OPERATOR)
-> 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 VMY
ROUTINESPEC VMY1
ROUTINESPEC CHOOSE(INTEGERNAME I)
ROUTINESPEC PUT
ROUTINESPEC STARSTAR
ROUTINESPEC REXP
ROUTINESPEC LOAD(RECORD (RD)NAME OP,INTEGER REG,MODE)
ROUTINESPEC FLOAT(RECORD (RD)NAME OPND,INTEGER OTHERPTYPE)
ROUTINESPEC COERCET(RECORD (RD)NAME OP1,OP2,INTEGER MODE)
ROUTINESPEC COERCEP(RECORD (RD)NAME OP1,OP2)
ROUTINESPEC LENGTHEN(RECORD (RD)NAME OP)
ROUTINESPEC SHORTEN (RECORD (RD)NAME OP)
!
INTEGERARRAY OPERAND(1:2),STK(0:99)
RECORD (LISTF)NAME LIST
RECORD (RD)NAME OPND1,OPND2,OPND
!
INTEGER C,D,KK,JJ,OPCODE,COMM,XTRA,PP,PT,JJJ,LOADREG,EVALREG,C
STPTR,CONSTFORM,CONDFORM,SAVEP
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; CONSTFORM= MODE&512
CONDFORM=MODE&256
SAVEP=P
EVALREG=ACCR; ! EVALUATE IN ACC UNLESS
IF REG=BREG AND NOPS&X'7EC20000'=0 THEN EVALREG=BREG
! ONLY '+' %AND '*' PRESENT
! NOTHING >32 BITS
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 2#OPND1_FLAG<4 AND 2#OPND2_FLAG<4 THEN CTOP(JJ)
-> STRES IF JJ=0; ! CTOP CARRIED OUT
-> SW(JJ)
SW(10): ! ¬
LOAD(OPND1,EVALREG,2)
FAULT(24,0,0) UNLESS TYPE=1 OR TYPE=7
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): ! SHORTEN LONGINTEGER
IF PTYPE=X'61' THEN SHORTEN(OPND1)
->SUSE
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=GRINF1(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)
GRINF1(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
IF OPND2_FLAG<=1 AND ((OPND2_D=-1 AND OPND1_PTYPE=X'51') C
OR (OPND1_PTYPE=X'61' AND OPND2_D=-1=OPND2_XTRA)) C
AND JJ#22 THEN WARN(8,0)
->BINOP IF TYPE=1
F24: FAULT(24,0,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
IF OPND2_PTYPE>>4=6 THEN SHORTEN(OPND2);! LONINT TO INT
IF OPND2_FLAG<=1 AND (OPND2_D<-31 OR OPND2_D>31) AND C
OPND1_PTYPE=X'51' THEN WARN(8,0)
-> 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 OPND1_D=0 AND JJ=31 AND C
(OPND1_XTRA=0 OR PTYPE>>4=5);! INT 0 OR LONGINT 0
-> Z2 IF OPND2_FLAG<=1 AND OPND2_D=0 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
(GRINF1(D)&X'FFFF'=OPND_XTRA OR GRINF1(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>>24; ! CURRENT DIMENSION
D=OPND2_D>>16&31; ! TOTAL NO OF DIMENSIONS
IF D=1 THEN VMY1 ELSE VMY
IF OPND1_FLAG>1 THEN C
OLINK(LOADREG)=OPERAND(COMM);! IF RESULT THEN PROTECT IT
IF C=1 THEN ->STRES
->ANYMORE
SW(34): ! ->LAB MASKS AND LAB AS OPND2
! OPND1 MIDDLE OF D-SIDED
ABORT
SW(35): ! ASSIGN(=)
SW(36): ! ASSIGN(<-)
PT=OPND2_PTYPE; PP=OPND2_D
!
! PDS BELIEVES THE NEXT LINE IS REDUNDANT THIS CASE ALWAYS BEING
! NOTED BY THE CHECK 15 LINES AFTER LABEL "FINISH:"
! %IF PT&7=1 %AND OPND1_PTYPE&7=2 %THEN FAULT(25,0,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
LENGTHEN(OPND1) AND D=OPND1_PTYPE>>4 WHILE D<C
WHILE (C<D AND TYPE=1 AND JJ#36) OR C<D-1 CYCLE
SHORTEN(OPND1)
D=OPND1_PTYPE>>4
REPEAT
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 (C&1=0 AND STNAME>0) OR (C=3 AND STNAME>>16>0) THEN C
NOTE ASSMENT(EVALREG,JJ-33,STNAME)
IF C>=2 AND JJJ#7 START ; ! DR WILL BE LOADED SY STORE
IF STNAME>0 THEN GRUSE(DR)=7 AND C
GRINF1(DR)=STNAME&X'FFFF' 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 CONDFORM=0 START ; ! IN CONDS ONLY CC MATTERS
! SKIP GETIING OPND INRIGHT FORM
! AND IN THE RIGHT REGISTER
D=MODE>>4&7; D=5 IF D<5
IF MODE&7=2 AND OPND1_PTYPE&7=1 THEN FLOAT(OPND1,D<<4)
SHORTEN(OPND1) WHILE D<OPND1_PTYPE>>4
LENGTHEN(OPND1) WHILE D>OPND1_PTYPE>>4
IF CONSTFORM=0 OR 2<=OPND1_FLAG#3 THEN LOAD(OPND1,REG,2)
FINISH
EXPOPND=OPND1; ! SET RESULT RECORD
PTYPE=OPND1_PTYPE
TYPE=PTYPE&7; PREC=PTYPE>>4
IF TYPE=2 AND MODE&7=1 THEN FAULT(25,0,0)
IF OPND1_FLAG=9 THEN REGISTER(OPND1_XB>>4)=0
P=SAVEP
RETURN
!
ROUTINE CHOOSE(INTEGERNAME CHOICE)
RECORD (RD)NAME OPND1,OPND2
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
GRINF1(EVALREG)=OPND2_XTRA>0)))
END
ROUTINE LOAD(RECORD (RD)NAME 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
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
IF PREC<=5 THEN DISP=OPND_D ELSE START
DISP=OPND_XTRA
ABORT UNLESS (DISP>=0 AND OPND_D=0) OR C
(DISP<0 AND OPND_D=-1)
FINISH
IF MODE=2 THEN START ; ! FETCH TO REG
IF GRUSE(REG)&255=5=PREC AND GRINF1(REG)=DISP 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 GRINF1(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)&255=6 AND GRINF1(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; GRINF1(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 START
BOOT OUT(BREG) UNLESS REGISTER(BREG)=0
PF1(ST,0,BREG,0)
FINISH ELSE GET IN ACC(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 AND GRINF1(EVALREG)>>16=0 THEN START
GRUSE(EVALREG)=10
GRINF1(EVALREG)=GRINF1(EVALREG)&X'FFFF'!OPND2_D<<16
FINISH ELSE START
GRUSE(EVALREG)=0 UNLESS 31<=JJ<=32
FINISH
OLINK(EVALREG)=OPERAND(COMM)
END
ROUTINE FLOAT(RECORD (RD)NAME OPND,INTEGER OTHERPTYPE)
!***********************************************************************
!* PLANT CODE TO CONERT OPERAND FROM FIXED TO FLOATING *
!***********************************************************************
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(RECORD (RD)NAME 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 *
!***********************************************************************
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,0) AND RETURN
IF PT1=1 THEN FLOAT(OPND1,OPND2_PTYPE)
IF PT2=1 THEN FLOAT(OPND2,OPND1_PTYPE)
END
ROUTINE COERCEP(RECORD (RD)NAME OPND1,OPND2)
!***********************************************************************
!* FORCE BOTH OPERAND TO THE SAME PRECISION BEFORE OPRNTN *
!***********************************************************************
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(RECORD (RD)NAME OPND)
!***********************************************************************
!* INCREASE OPND PRECISION BY ONE SIZE AT COMPILE TIME IF POSS *
!***********************************************************************
INTEGER TP,PR
TP=OPND_PTYPE&7
PR=OPND_PTYPE>>4
IF OPND_FLAG<=1 AND PR<=4+TP 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 START
IF PR=6 THEN START
TOAR8(R,LONGREAL(ADDR(OPND_D)))
TOAR8(R+8,0)
OPND_XTRA=ADDR(A(R))
OPND_FLAG=3
R=R+16
FINISH ELSE OPND_XTRA=0
FINISH
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(RECORD (RD)NAME OPND)
!***********************************************************************
!* PLANT CODE TO REDUCE ACC SIZE *
!***********************************************************************
INTEGER TY,PR,F,I,J
TY=OPND_PTYPE&7
PR=OPND_PTYPE>>4
F=OPND_FLAG
IF F=3 START ; ! LONGLONGREAL CONSTS
CYCLE I=0,1,3
BYTEINTEGER(ADDR(J)+I)=BYTEINTEGER(OPND_XTRA+4+I)
REPEAT
OPND_XTRA=J
OPND_FLAG=1; ! CONST NOW IN _D & _XTRA
->WAYOUT
FINISH
IF F<=1 START
IF TY=2 THEN ->WAYOUT
IF (OPND_D=0 AND OPND_XTRA>=0) OR (OPND_D=-1 AND C
OPND_XTRA<0) THEN OPND_D=OPND_XTRA AND ->WAYOUT
FINISH
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
WAYOUT:
OPND_PTYPE=(PR-1)<<4+TY
END
ROUTINE EXTRACT(RECORD (RD)NAME OPND,LONGINTEGERNAME VAL, C
LONGLONGREALNAME RVAL)
!***********************************************************************
!* EXTRACTS A CONTANT OPERAND RETURNING REAL &INT VALUES *
!***********************************************************************
INTEGER TYPE,PREC,S,I,AD
TYPE=OPND_PTYPE; PREC=TYPE>>4
TYPE=TYPE&15
IF TYPE=1 THEN START
IF PREC<=5 THEN VAL=OPND_D ELSE START
INTEGER(ADDR(VAL))=OPND_D
INTEGER(ADDR(VAL)+4)=OPND_XTRA
FINISH
RVAL=VAL
FINISH ELSE START
RVAL=0
IF PREC=7 THEN S=15 AND AD=OPND_XTRA C
ELSE S=7 AND AD=ADDR(OPND_D)
CYCLE I=0,1,S
BYTEINTEGER(ADDR(RVAL)+I)=BYTEINTEGER(AD+I)
REPEAT
FINISH
END
ROUTINE VMY1
!***********************************************************************
!* DOES VECTOR MULTIPLIES FOR ONE DIMENSION ARRAYS *
!***********************************************************************
INTEGER OPNAME,VUSE,DVPOS,DVNAME,X,Y,DTYPE,DPREC,DACC,DPTYPE
DPTYPE=XTRA>>16
DVNAME=XTRA&X'FFFF'
DVPOS=OPND2_D&X'FFFF'
IF DVPOS>0 AND OPND1_FLAG<=1 START ;! CONST ITEM & DV FOLD IT
X=OPND1_D
X=X-CTABLE(DVPOS+3)
X=X*CTABLE(DVPOS+4)
IF X<0 OR X>=CTABLE(DVPOS+5) THEN FAULT(50,OPND1_D,DVNAME)
!
! IF ARRAY BASE HAS BEEN SHIFTED TO ZERO ELEMENT PUT BACK THE LB CORRN
! NOW THE BOUND CHECK HAS BEEN COMPUTED
!
IF PARMARR=0=PARMCHK AND DPTYPE&X'C0F'<=3 THEN C
X=X+CTABLE(DVPOS+3)*CTABLE(DVPOS+4)
OPND1_D=X
OPND1_FLAG=1
IF X'FFFE0000'<=X<=X'1FFFF' THEN OPND1_FLAG=0
RETURN
FINISH
OPNAME=-1
IF OPND1_FLAG=2 AND DVNAME#X'FFFF' THEN OPNAME=OPND1_XTRA
VUSE=DVNAME!OPNAME<<16
IF OPNAME>=0 AND GRUSE(BREG)=14 AND GRINF1(BREG)= C
VUSE THEN ->DONE
IF PARMARR=0=PARMCHK AND DVPOS>0 START
LOAD(OPND1,BREG,2)
X=CTABLE(DVPOS+4)
IF X#1 THEN PSF1(MYB,0,X) AND GRUSE(BREG)=0
Y=X*CTABLE(DVPOS+3)
IF DPTYPE&X'C0F'<=3 THEN START
IF X#1 THEN ->DONE
->OUT
FINISH
! TEST NAM=0 WHEN ZERO ADJSTD
IF Y#0 THEN PSF1(SBB,0,Y) AND GRUSE(BREG)=0
->DONE
FINISH
IF PARMARR=0=PARMCHK AND (DPTYPE&X'300'=X'200' OR C
DPTYPE&X'C0F'<=3 OR COMPILER#0)START ;! IE ARR=2 OR NAM=0
DTYPE=DPTYPE&15; DPREC=DPTYPE>>4&7
LOAD (OPND1,BREG,2) UNLESS OPND1_FLAG<=1
IF DTYPE>=3 OR DPREC=4 THEN START
DACC=LIST_S3; ! PUT THERE BY CANAME
IF OPND1_FLAG<=1 THEN OPND1_D=OPND1_D*DACC AND RETURN
PSF1(MYB,0,DACC) UNLESS DACC=1
GRUSE(BREG)=0
->DONE
FINISH
IF OPND1_FLAG<=1 THEN RETURN
LOADREG=BREG; ->OUT
FINISH
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
!
BASE=OPND2_XTRA>>18; AREA=-1
GET IN ACC(DR,2,0,AREA CODE,OPND2_XTRA&X'1FFFF'+8)
!
LOAD(OPND1,EVALREG,0)
IF REGISTER(BREG)>=1 AND (OPND1_FLAG#9 OR OPND1_XB>>4#BREG) C
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
DONE:
IF OPNAME>=0 THEN START
GRUSE(BREG)=14
GRINF1(BREG)=VUSE
GRINF2(BREG)=0
FINISH
OUT:
LOADREG=BREG
REGISTER(LOADREG)=1
OPND1_FLAG=9; OPND1_XB=LOADREG<<4
END
ROUTINE VMY
!***********************************************************************
!* DOES ALL VECTOR MULTIPLIES EXCEPT ONE DIMENSION *
!***********************************************************************
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 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
!
LOADREG=ACCR
IF C=D THEN GET IN ACC(ACCR,1,0,7,0) ELSE C
PF1(IAD,0,BREG,0)
IF C=1 THEN START
PF1(ST,0,BREG,0)
REGISTER(ACCR)=0
LOADREG=BREG
FINISH
REGISTER(LOADREG)=1
OPND1_FLAG=9; OPND1_XB=LOADREG<<4
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 *
!***********************************************************************
CONSTINTEGER TRUNCMASK=X'01300800'
INTEGER K,TYPEP,PRECP,OP,VAL,SVAL1,SVAL2
OWNLONGLONGREAL ONE=1.0
LONGINTEGER VAL1,VAL2
LONGLONGREAL RVAL1,RVAL2
SWITCH ISW,RSW(10:32)
ON EVENT 1,2 START
RETURN
FINISH
TYPEP=TYPE; PRECP=PTYPE>>4&15; OP=FLAG
EXTRACT(OPND1,VAL1,RVAL1)
EXTRACT(OPND2,VAL2,RVAL2)
SVAL1<-VAL1; SVAL2<-VAL2
IF TYPEP=1 AND OP=37 THEN ->ISW37
RETURN IF OP>32
IF TYPEP=2 THEN ->RSW(OP) ELSE ->ISW(OP)
ISW(10): ! ¬
VAL1=¬VAL1
INTEND:
IF PRECP=6 THEN START
OPND1_D<-VAL1>>32
OPND1_XTRA<-VAL1
FLAG=0
FINISH ELSE START
VAL<-VAL1
IF VAL=VAL1 OR 1<<OP&TRUNCMASK=0 THEN C
FLAG=0 AND OPND1_D=VAL;! NO ARITH OFLOW CONDITION
FINISH
IF FLAG=0 START
OPND1_PTYPE=PRECP<<4!1
IF X'FFFE0000'<=VAL1<=X'1FFFF' THEN OPND1_FLAG=0 C
ELSE OPND1_FLAG=1
FINISH
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=PRECP+1
REAL END:OPND1_FLAG=1
RVAL1=RVAL1*ONE; ! ENSURE SECOND EXPONENT ETC SET&NORMALISED
OPND1_D=INTEGER(ADDR(RVAL1))
OPND1_XTRA=INTEGER(ADDR(RVAL1)+4)
IF PRECP=7 THEN START
OPND1_FLAG=3
OPND1_XTRA=ADDR(A(R))
CYCLE K=0,1,15
A(R)=BYTEINTEGER(ADDR(RVAL1)+K)
R=R+1
REPEAT
FINISH
FLAG=0; OPND1_PTYPE=16*PRECP+2
RETURN
ISW(14): ! STRETCH INTEGER
IF PRECP=6 AND VAL1=SVAL1 THEN PRECP=5 AND ->INT END
RETURN
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
IF PRECP=6 THEN VAL1=VAL1<<SVAL2 ELSE VAL1=SVAL1<<SVAL2
->INT END
ISW(28): ! SRL
IF PRECP=6 THEN VAL1=VAL1>>SVAL2 ELSE VAL1=SVAL1>>SVAL2
->INT END
ISW(31):ISW(32): ! COMPARISONS
RSW(31):RSW(32): ! REAL COMPARISONS
BFFLAG=COMM-1
MASK=FCOMP(XTRA+7*BFFLAG)
COMM=2; FLAG=0
IF TYPE=2 THEN ->RCOMP
IF (MASK&8#0 AND VAL1=VAL2) OR (MASK&4#0 AND VAL1<VAL2)C
OR (MASK&2#0 AND VAL1>VAL2) THEN MASK=15 ELSE MASK=0
RETURN
RCOMP:
IF (MASK&8#0 AND RVAL1=RVAL2) OR (MASK&4#0 AND RVAL1<RVAL2)C
OR (MASK&2#0 AND RVAL1>RVAL2) THEN MASK=15 ELSE MASK=0
RETURN
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
RSW(30): ! '**' WITH AT LEAST ONE REAL
IF OPND2_PTYPE&7=1 THEN RVAL1=RVAL1**VAL2 AND ->REALEND
RETURN
ISW37: ! '****' WITH 2 INTEGER OPERAND
VAL1=VAL1****SVAL2
->INT 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
RECORD (RD)NAME OPND
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)
GRUSE(ACCR)=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
IF OPND2_PTYPE>>4=6 THEN SHORTEN(OPND2);! LONG EXPONENT
LOAD(OPND2,BREG,2); ! EXPONENT TO ANY REGISTER
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(ACCR)=0
GRUSE(BREG)=0
REGISTER(ACCR)=1
OPND1_PTYPE=16*PREC+TYPE
OPND1_XB=0; OPND1_D=ACCR
C=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)&255 AND I=GRINF1(REG) THEN C
PUSH(NEWHEAD,I,J,K)
REPEAT
HEAD=NEWHEAD
END
INTEGERFN CCOND(INTEGER CTO,IU,FARLAB,UPLINE)
!***********************************************************************
!* COMPILES <IU><SC><RESTOFCOND>%THEN<UI1>%ELSE<UI2> *
!* CTO=0 JUMP TO FARLAB MUST BE PLANTED IF COND UNCONDITIONAL *
!* CTO#0 JUMP MAY BE OMITTED *
!* IU=1 FOR %IF =2 FOR UNLESS. FARLAB TO GO ON UI2 *
!* ULINE #0 IF CODE TO UPDATE LINE IS TO BE PLANTED BEFORE THE *
!* THE CONDTION IS COMPILED. DONE HERE TO AVOID UNNECESSRY *
!* UPDATES DURING CONDITIONAL COMPILATION *
!* 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> *
!* RESULT=0 CONDITION COMPILED *
!* RESULT=1 UNCONDITIONALLY TO 1ST ALTERNATIVE *
!* RESULT=2 UNCONDITIONALLY TO 2ND ALTERNATIVE(FARLAB) *
!***********************************************************************
!%ROUTINESPEC WRITE CONDLIST
ROUTINESPEC SKIP SC(INTEGER REVERSED)
ROUTINESPEC SKIP COND(INTEGER REVERSED)
INTEGERFNSPEC CCOMP
ROUTINESPEC JUMP(INTEGER MASK,LAB,FLAGS)
ROUTINESPEC NOTE JUMP(INTEGER LAB)
ROUTINESPEC LAB UNUSED(INTEGER LAB)
ROUTINESPEC OMIT TO(INTEGER LAB)
!
! 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
!
CONSTBYTEINTEGERARRAY 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,BITMASK,LA
RECORDFORMAT CF(BYTEINTEGER TF,CMP1,CMP2,LABU,LVL,JMP,REV,JUMPED, C
INTEGER LABNO,SP1,SP2)
RECORD (CF)ARRAY CLIST(1:30)
RECORD (CF)NAME C1,C2
!
! 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(0); ! SKIP THE 1ST CMPARSN
SKIP COND(0); ! 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_REV NEVER SET HERE (PDS HOPES)
C1_LABNO=FARLAB
PP=P; ! SAVE FINAL AR POINTER
FAULT(108,0,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
! MAINTAIN BIT MASK TO HELP. 2**0 JUMP TO FAR LAB PLANTED
! 2**1 JUMP TO INTERMEDIATE LAB PLANTED
!
! WRITE CONDLIST %IF DCOMP=1
BITMASK=0
CPTR=1
CYCLE
C1==CLIST(CPTR)
LA=CCOMP
IF LA#0 START
OMIT TO(LA)
IF CPTR>=CMAX THEN START
IF CTO=0 THEN ENTER JUMP(15,LA,B'11')
RESULT =2
FINISH
C1==CLIST(CPTR)
FINISH
IF C1_LABNO>0 THEN II=ENTER LAB(C1_LABNO,B'11')
CPTR=CPTR+1
EXIT IF CPTR>=CMAX
REPEAT
!
P=PP;
RESULT =1 IF BITMASK&1=0
RESULT =0
ROUTINE LAB UNUSED(INTEGER LAB)
!***********************************************************************
!* A LABEL IS NOT JUMPED TO AS CONDITION ALWAYS FALSE *
!* REMOVE IT FROM LIST *
!***********************************************************************
INTEGER I
RECORD (CF)NAME C1
CYCLE I=CPTR,1,CMAX-1
C1==CLIST(I)
IF C1_LABNO=LAB START
C1_LABU=C1_LABU-1; ! COUNT DOWN USE COUNT
IF C1_LABU=0 THEN C1_LABNO=0
RETURN
FINISH
REPEAT
END
ROUTINE OMIT TO(INTEGER LAB)
!***********************************************************************
!* A JUMP TURNS OUT TO BE UNCONDITIONAL. OMIT CODE FOR SKIPPED BIT *
!***********************************************************************
RECORD (CF)NAME C1
CYCLE
C1==CLIST(CPTR)
IF C1_LABNO>0 START
IF C1_LABNO=LAB THEN RETURN
IF C1_JUMPED>0 THEN JUMP(15,LAB,B'11') AND RETURN
FINISH
CPTR=CPTR+1
EXIT IF CPTR>=CMAX
REPEAT
END
ROUTINE SKIP SC(INTEGER REVERSED)
!***********************************************************************
!* REVERSED=1 FOR RECURSIVE CALL IN %NOT(SC) *
!* SKIPS OVER A SIMPLE CONDITION. P ON ALT OF<SC> *
!***********************************************************************
SWITCH SCALT(1:3)
INTEGER ALT
ALT=A(P); P=P+1
->SCALT(ALT)
SCALT(1): ! <EXP><COMP><EXP><SECONDSIDE>
C1_SP1=P-PIN
SKIP EXP
C1_CMP1=A(P)
C1_REV=3*REVERSED
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
RETURN
SCALT(2): ! '('<SC><RESTOFCOND>')'
L=L+1
SKIP SC(REVERSED)
SKIP COND(REVERSED)
L=L-1
RETURN
SCALT(3): ! %NOT(SC)
SKIP SC(REVERSED!!1)
END ; ! OF ROUTINE SKIP SC
ROUTINE SKIP COND(INTEGER REVERSED)
!***********************************************************************
!* 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
C1_TF=C1_TF!!(3*REVERSED)
CPTR=CPTR+1
C1==CLIST(CPTR); C1=0
SKIP SC(REVERSED)
ALTP=A(P); P=P+1
REPEAT
FINISH
END
!%ROUTINE WRITE CONDLIST
!%CONSTSTRING(5) %ARRAY CM(0:10)=" "," ="," >="," >",
! " #"," <="," <"," ¬="," ->",
! " =="," ¬==";
! PRINTSTRING("
! NO TF C1 C2 LABU LVL JMP REV LABNO JUMPED
!")
! %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_REV,4)
! WRITE(C1_LABNO,7)
! WRITE(C1_JUMPED,6)
! NEWLINE
! %REPEAT
!%END
INTEGERFN 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 *
!* 4) EQUIVALENCES INTEGER COMPARISONS ON ADDRESSES *
!* RESULT=0 CODE COMPILED *
!* RESULT#0 UNCODITIONAL JUMP TO LAB=RESULT *
!***********************************************************************
ROUTINESPEC ACOMP(INTEGER TF,DS)
ROUTINESPEC ADCOMP(INTEGER TF)
ROUTINESPEC SCOMP(INTEGER DS,TF,LAB,INTEGERNAME WA)
INTEGER HEAD1,HEAD2,NOPS,TE1,TE2,TEX1,TEX2,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_REV!!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 THEN START
! CONDITIONAL RESOLUTION
! NB CRES BRANCHES ON FALSE!!
P=P1
IF A(P+3)=4 AND A(P+4)=1 START
IF UPLINE>0 THEN SET LINE AND UPLINE=0
P=P+5; CNAME(2,DR); ! LH STRING TO DR
IF A(P)=2 THEN START
IF TYPE#5 THEN FAULT(71,0,FROMAR2(P1+5)) C
AND RESULT =0
P=P2
CRES(IEXIT); ! FAILURES -> IEXIT
NOTE JUMP(IEXIT)
IF IEXIT=FARLAB THEN BITMASK=BITMASK!1 ELSE C
BITMASK=BITMASK!2
IF C1_REV!!C1_TF=2 THEN JUMP(15,FEXIT,B'11')
RESULT =0
FINISH
FINISH
FAULT(74,0,0)
RESULT =0
FINISH
IF C1_CMP1>8 THEN ->ADRCOMP
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,1); ! BRANCH IEXIT %IF FALSE
IF MASK=15 THEN RESULT =IEXIT
JUMP(MASK,IEXIT,B'11')
P=P+5; ! TO THE THIRD EXPRSN
CMP=C1_CMP2; ! COMPARATOR NO 2
FINISH
!
ACOMP(C1_REV!!C1_TF,0); ! SECOND OR ONLY COMPARISION
IF MASK=15 THEN RESULT =FEXIT
JUMP(MASK,FEXIT,B'11')
RESULT =0
STR: ! STRING COMPARISIONS
! SOME CARE IS NEEDED IN FREEING
! STRING WK-AREAS SET BY CSTREXP
P=P1
IF UPLINE>0 THEN SET LINE AND UPLINE=0
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'35' AND A(P2+10)=0 C
AND A(P2+11)=2 THEN START
CSTREXP(0,DR)
MASK=FCOMP(C1_CMP1+14)
IF C1_REV!!C1_TF=1 THEN MASK=REVERSE(MASK)
JUMP(MASK,FEXIT,B'11')
RESULT =0
FINISH
CSTREXP(16,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_REV!!C1_TF,FEXIT,WA3)
CYCLE CMP=ADDR(WA1),4,ADDR(WA3)
IF INTEGER(CMP)#0 THEN RETURN WSP(INTEGER(CMP),256)
REPEAT
RESULT =0
ADRCOMP: ! ADRESS COMPARISONS
IF UPLINE>0 THEN SET LINE AND UPLINE=0
ADCOMP(C1_REV!!C1_TF)
JUMP(MASK,FEXIT,B'11')
RESULT =0
ROUTINE ADCOMP(INTEGER TF)
!***********************************************************************
!* COMPILES AN == OR ADDRESS COMPARISON WHICH CAN NOT BE *
!* DOUBLESIDED. BETTER CODE COULD BE GENERATED FOR THE *
!* MOST COMMON CASE IE POINTERNAME==VARIABLE *
!************************************************************************
INTEGER TYPEP,PRECP,LHNAME,RHNAME,FNAME
RECORD (RD) R
LHNAME=A(P1+5)<<8!A(P1+6)
FNAME=RHNAME
RHNAME=A(P2+5)<<8!A(P2+6)
->FLT UNLESS A(P1+3)=4 AND A(P1+4)=1
P=P1+5; CNAME(4,ACCR)
->FLT UNLESS A(P)=2; ! NO REST OF EXPR
TYPEP=TYPE; PRECP=PREC
REGISTER(ACCR)=1
OLINK(ACCR)=ADDR(R)
R_PTYPE=1; R_XB=ACCR<<4
R_FLAG=9
!
FNAME=LHNAME
->FLT UNLESS A(P2+3)=4 AND A(P2+4)=1
P=P2+5; CNAME(4,ACCR)
->FLT UNLESS A(P)=2; ! NO REST OF EXPR
FAULT(83,LHNAME,RHNAME) UNLESS TYPEP=TYPE AND PRECP=PREC
PF1(ICP,0,TOS,0)
IF C1_CMP1=10 THEN MASK=7 ELSE MASK=8
IF TF=1 THEN MASK=REVERSE(MASK)
RETURN
FLT: REGISTER(ACCR)=0
FAULT(80,0,FNAME)
MASK=7
END
ROUTINE ACOMP(INTEGER TF,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,REG
PRECP=PTYPE>>4&15; TYPEP=TYPE
!
! ADD OPERATOR AT BOTTOM. EITHER COMPARE(31) OR DS COMPARE(32)
!
PUSH(HEAD2,31+DS,CMP,0)
BOT2=HEAD2
NOPS=(NOPS+1)!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
IF UPLINE>0 AND NOPS&(1<<18)#0 THEN SET LINE AND UPLINE=0
EXPOP(HEAD1,-1,NOPS,256+16*PRECP+TYPE); ! PLANT THE CODE
! CLEAR LIST(HEAD1)
ASLIST(BOT1)_LINK=ASL
ASL=HEAD1
HEAD1=0
IF DS#0 START
PUSH(HEAD1,INTEGER(ADDR(EXPOPND)),EXPOPND_D,EXPOPND_XTRA)
BOT1=HEAD1
IF EXPOPND_FLAG=9 START
REG=EXPOPND_XB>>4
REGISTER(REG)=1
OLINK(REG)=ADDR(ASLIST(HEAD1))
FINISH
FINISH
IF TF=1 THEN MASK=REVERSE(MASK)
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 (RD) R
!
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,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
JUMP(MASK,LAB,B'11')
END
END
ROUTINE JUMP(INTEGER MASK,LAB,FLAGS)
!***********************************************************************
!* CALLS ENTER JUMP WHILE MAINTAINING BITMASK *
!***********************************************************************
IF MASK=0 THEN LAB UNUSED(LAB) AND RETURN
ENTER JUMP(MASK,LAB,FLAGS)
NOTE JUMP(LAB)
IF LAB=FARLAB THEN BITMASK=BITMASK!1 ELSE BITMASK=BITMASK!2
END
ROUTINE NOTE JUMP(INTEGER LABEL)
!***********************************************************************
!* RECORD LABEL JUMPED TO FOR SKIPPING COMPLEX CONDITIONS *
!***********************************************************************
INTEGER I
RECORD (CF)NAME C
CYCLE I=1,1,CMAX
C==CLIST(I)
IF C_LABNO=LABEL THEN C_JUMPED=C_JUMPED+1 AND EXIT
REPEAT
END
END ; ! OF CCOND
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
INTEGERFN 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 *
!* RESULT = 1 LABEL ENTERED *
!* RESULT = 0 CONDITIONAL LABEL NOT REQUIRED *
!***********************************************************************
INTEGER CELL,AT,ENVHEAD,JUMPHEAD,INSTRN,OLDCELL,WORK
RECORD (LISTF)NAME LCELL
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)
RESULT =1
FINISH
RESULT =0
FINISH
!
! LABEL HAS BEEN REFERENCED - FILL IN ITS ADDRESS
!
IF LCELL_S1&X'FFFFFF'# 0 THEN START
FAULT(2,0,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
RESULT =1
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 *
!* S3=LINE NO OF JUMP FOR DIAGNOSTICS *
!* *
!* 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
RECORD (LISTF)NAME LCELL
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,LINE)
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 *
!***********************************************************************
RECORD (LISTF)NAME LCELL
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 C
SGRUSE(I)=GRUSE(I)&255 AND SGRINF(I)=GRINF1(I)
REPEAT
END
ROUTINE REMEMBER
INTEGER I
CYCLE I=0,1,7
SGRUSE(I)=GRUSE(I)&255
SGRINF(I)=GRINF1(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 STRING(%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 SUBSTRING(%STRINGNAME S,%INTEGER BEG,END) *
!* 48=%RECORDMAP RECORD(%INTEGER REC ADDR) *
!* 49=%ARRAYMAP ARRAY(%INTEGER A1ADDR,%ARRAYNAME FORMAT) *
!* 50=%INTEGERFN SIZEOF(%NAME X) *
!* 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) *
!* 62=%ROUTINE PPROFILE *
!* 63=%LONGREALFN FLOAT(%INTEGER VALUE) *
!* 64=%LONINTEGERFN LINT(%LONGLONGREAL X) *
!* 65=%LONGINTEGERFN LINTPT(%LONGLONGREAL X) *
!***********************************************************************
INTEGERFNSPEC OPTMAP
SWITCH ADHOC(1:16)
CONSTINTEGERARRAY SNINFO(0:NO OF SNS)=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'80170014',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'110A0038',X'120B1000',X'80130013',X'11060024',
X'100C0024',X'100D0024',X'2100003E'(2),
X'110E0024'(4),
X'10020024',X'2100003E',X'100F0001',X'11100024',
X'801A0003',X'801A0004';
CONSTSTRING (11)ARRAY SNXREFS(0:20)=C
"READSTRING", "S#READ", "S#IARCSIN", "S#LINT",
"S#LINTPT" , "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","S#SUBSTRING","S#SIZEOF",
"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.
!
CONSTHALFINTEGERARRAY SNPARAMS(0:27)=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'435',X'51',X'51',
1,X'400', 1,X'51', 2,X'51',X'51', 1,X'72';
! KEY TO PARAMETER TABLE
! 0 X0 == (NO PARAMS)
! 1 X1 == (%LONGREAL X)
! 3 X3 == (%LONGREAL X,Y)
! 6 X6 == (%LONGREAL X,%INTEGER I)
! 9 X9 == (%LONGREAL X,%INTEGER I,J)
! 13 XD == (%STRINGNAME S)
! 15 XF == (%STRINGNAME S,%INTEGER I,J)
! 19 X13 == (%NAME X)
! 21 X15 == (%INTEGER I)
! 23 X17 == (%INTEGER I,J)
! 26 X1A == (%LONGLONGREAL X)
!
!
CONSTBYTEINTEGERARRAY WRONGZ(0:15)=27,29,23,29,29,23,82,109(5),
23,27,109(2);
ROUTINESPEC RTOS(INTEGER REG)
RECORD (RD) R
RECORD (LISTF)NAME LCELL
INTEGER ERRNO,FLAG,POINTER,WREG,PIN,SNNO,SNNAME,NAPS,SNPTYPE,JJ,C
XTRA,IOCPEP,B,D,SNINF,P0,OPHEAD,ERRVAL,EXPHEAD,EXPBOT,NOPS
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),PARMDYNAMIC,2,JJ);! JJ SET WITH REF DISPLACEMENT
IF SNNO=26 THEN LOGEPDISP=JJ
IF SNNO=30 THEN EXPEPDISP=JJ
OPHEAD=0; P0=SNPARAMS(POINTER)
D=1
WHILE D<=P0 CYCLE
PTYPE=SNPARAMS(POINTER+D)
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<<16,ACC<<16,P0)
D=D+1
REPEAT
LCELL==ASLIST(TAGS(SNNAME))
LCELL_S1=1<<4!14!SNPTYPE<<16; ! I=1 & J=14
LCELL_S2=JJ<<16!BYTES(SNPTYPE>>4&15);! RT ENTRY DISPLACEMENT & ACC
LCELL_S3=OPHEAD<<16; ! K & KFORM
P=PIN; CNAME(Z,REG); ! RECURSIVE CALL
NEST=REG
P=P-1; 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)
!
ERRVAL=NAPS-FLAG&3
IF ERRVAL>0 THEN ERRNO=19 AND ->ERREXIT
IF ERRVAL<0 THEN ERRNO=18 AND ERRVAL=-ERRVAL AND ->ERREXIT
JJ=1<<Z
IF JJ&XTRA=0 THEN START ; ! ILLEGAL USE
ERRNO=WRONGZ(Z)
->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
P=P+1
->OKEXIT
FINISH
!
! THE BUILT-IN MAPS (INTEGER ETC BUT NOT RECORD OR ARRAY)
!
IF FLAG&X'20'#0 THEN START
SNPTYPE=X'1C00'+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
OLDI=0; ! FOR CHECK IN == ASSGNMNT
->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 C
(A(P+3)#4 OR A(P+4)#1 OR A(P+FROM AR2(P+1)+1)#2) THEN C
ERRNO=22 AND ERRVAL=1 AND ->ERREXIT
->ADHOC(POINTER)
ADHOC(1): ! NEWLINES(=6) & SPACES(=7)
IF SNNO=6 THEN JJ=10 ELSE JJ=32
EXPHEAD=0; NOPS=2
PUSH(EXPHEAD,23,0,0); ! OPERATOR '!'
EXPBOT=EXPHEAD
PUSH(EXPHEAD,X'510000',JJ,0); ! CONST JJ
PUSH(EXPHEAD,29,0,0); ! OPERATOR '<<'
PUSH(EXPHEAD,X'510000',8,0); ! CONST 8
P=P+3; TORP(EXPHEAD,EXPBOT,NOPS)
EXPOP(EXPHEAD,ACCR,NOPS,X'51'); ! EVAL REPTN<<8!SYMBOL IN GR1
ASLIST(EXPBOT)_LINK=ASL
ASL=EXPHEAD
CIOCP(17,ACCR)
P=P+1
->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 ->TOST; ! TREAT AS TOSTRING
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
VALUE=0; ! NEEDED FOR STRING ASSIGN
ASSIGN(6,P); ! BY '=' TO PARAMETER
FAULT(22,1,SNNAME) UNLESS TYPE=JJ
P=PIN+6+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
P=P+1
->OKEXIT
ADHOC(5): ! ADDR(=14)
P=P+5; CNAME(4,REG); ! FETCH ADDRESS MODE
NEST=REG
P=P+2; ->OKEXIT
ADHOC(6): ! MOD(=23), IMOD(=51)
IF SNNO=51 THEN START
JJ=X'51'; B=5; D=IRSB
XTRA=3; WREG=ACCR
IF REG=BREG START
B=13; D=SLB; XTRA=4; WREG=BREG
FINISH
FINISH ELSE START
JJ=X'62'; B=1; D=RRSB
XTRA=3; WREG=ACCR
FINISH
CSEXP(WREG,JJ); ! INTEGER OR LONGREAL MODE
PF3(JAT,B,0,XTRA); ! JUMP ACC >0
PSF1(D,0,0)
IF WREG=BREG THEN PF1(SBB,0,TOS,0)
GRUSE(WREG)=0
NEST=WREG
P=P+1
->OKEXIT
ADHOC(7): ! CHARNO(=45) & LENGTH(=36)
P=P+5
IF PARMARR!PARMCHK#0 AND SNNO=45 THEN CNAME(3,DR) C
ELSE CNAME(4,BREG)
ERRNO=22; ERRVAL=1
->ERREXIT UNLESS TYPE=5 AND (ROUT=0 OR NAM>=2)
IF NAM=0 AND LITL=1 AND (Z=1 OR Z=3 OR Z=4) THEN C
FAULT(43,0,FROMAR2(PIN+8))
P=P+2
IF SNNO#36 THEN START
IF PARMARR!PARMCHK=0 THEN START
PF1(STB,0,TOS,0)
CSEXP(BREG,X'51')
PF1(ADB,0,TOS,0)
FINISH ELSE START ; ! FRIG BND CHECK FOR PARM=ARR
GET WSP(JJ,2)
IF Z=2 OR Z=5 THEN B=INCA ELSE B=MODD
PSF1(B,0,1)
PSF1(STD,1,JJ)
CSEXP(BREG,X'51')
PSF1(LD,1,JJ)
PSF1(SBB,0,1)
PF1(MODD,0,BREG,0)
GRUSE(DR)=0
PSF1(ADB,1,JJ+4)
FINISH
P=P+1
GRUSE(BREG)=0
FINISH
DISP=MAPDES(3)
AREA=PC; ACCESS=3
STNAME=-1 IF Z=1; ! CANT REMEBER NAME
SNPTYPE=SNPTYPE+X'1C00'
->OKEXIT
ADHOC(12): ! PI(=52)
ADHOC(8): ! NL(=38). THIS FN IS PICKED OFF
NEST=0; ! IN CSEXP.ONLY COMES HERE IN
P=P+1
->OKEXIT; ! ERROR EG NL=A+B
ADHOC(9): ! TOSTRING(=46)
CSEXP(ACCR,X'51'); ! RET EXPSN
P=P+1
TOST: RTOS(REG)
IF REG=ACCR THEN JJ=LUH ELSE JJ=LDTB
PF1(JJ,0,PC,PARAM DES(3)); ! LUH(LDTB)_X'18000001'
NEST=REG
STRFNRES=0
SNPTYPE=X'1035'; ! TYPED AS STRING FN
->OKEXIT
ADHOC(10): ! RECORD(=48)
IF RECTB=0 THEN RECTB=WORD CONST(X'1800FFFF')
IF REG=ACCR THEN START
CSEXP(ACCR,X'51')
PF1(LUH,0,PC,RECTB) UNLESS Z=4
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'1C00'; ! ADD MAP BITS
->OKEXIT
ADHOC(11): ! ARRAY(=49)
CSEXP(ACCR,X'51'); ! ADD(A(0)) TO ACCR
ERRNO=22; ERRVAL=2
->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,0,SNNAME) IF D=0
D=D+4 IF SNNO#33
GET IN ACC(ACCR,1,0,LNB,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
ADHOC(15): ! PPROFILE(IGNORED UNLESS PARM SET)
PPJ(0,22) UNLESS PARMPROF=0
->OKEXIT
ADHOC(16): ! FLOAT
CSEXP(ACCR,X'62')
P=P+1; NEST=ACCR
OKEXIT: ! NORMAL EXIT
PTYPE=SNPTYPE; UNPACK
RETURN
ERREXIT: ! ERROR EXIT
FAULT(ERRNO,ERRVAL,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,XYNB
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
COPY TAG(VARNAME); ! CHECK IT WAS ADDR
->WASADR IF PTYPE=SNPT AND K=14 AND A(PP+6)=1
->WASLOC IF PTYPE&X'FBFF'=X'51' AND A(PP+6)=2=A(PP+7)
RESULT =0
WASADR: 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'41' AND A(REXP+6)=2
CVAL=FROM AR2(REXP+4)
IF OP=1 THEN K=K+CVAL ELSE K=K-CVAL
RESULT =0 IF K<0
P=REXP+8
FINISH
BASE=I
DISP=K; AREA=-1; ACCESS=0
AREA=AREA CODE
RESULT =1
WASLOC: ! FORM INTEGER(NAME+CONST)
CVAL=0
IF A(REXP)=2 THEN PP=REXP+2 AND ->FETCH
RESULT =0 UNLESS A(REXP+1)=1 AND A(REXP+2)=2
IF A(REXP+3)=X'41' AND A(REXP+6)=2 THEN C
CVAL=FROM AR2(REXP+4) AND PP=REXP+8 AND ->FETCH
IF A(REXP+3)=X'51' AND A(REXP+8)=2 THEN C
CVAL=FROM AR4(REXP+4) AND PP=REXP+10 AND ->FETCH
RESULT =0
FETCH: RESULT =0 UNLESS CVAL&3=0 AND CVAL>>20=0;! MAX FOR XNB+N
XYNB=XORYNB(9,VARNAME)
UNLESS GRUSE(XYNB)=9 AND GRINF1(XYNB)=VARNAME START
AREA=-1; BASE=I
PSORLF1(LDCODE(XYNB),2*NAM,AREA CODE,K)
GRUSE(XYNB)=9; GRINF1(XYNB)=VARNAME
FINISH
P=PP; AREA=XYNB
ACCESS=0; DISP=CVAL
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,OP
GET WSP(KK,1); ! GET 1 WORD WK AREA
STRINGL=1; DISP=KK+2
PF1(OR,0,0,256)
GRUSE(ACCR)=0
PSF1(ST,1,KK)
IF REG=DR THEN KK=INCA AND OP=LDA ELSE C
KK=IAD AND OP=LSS
PSF1(OP,1,PTR OFFSET(RBASE))
PSF1(KK,0,DISP)
GRUSE(REG)=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,SOLDI,PRIVOPS, C
TYPEP,ARRNAME,Q,PRECP,ELSIZE,NAMINF,BOT1,BOT2,BOT3,DVD,VMYOP
PP=P; TYPEP=TYPE
JJ=J; PTYPEP=PTYPE; PRECP=PREC; SOLDI=OLDI
IF TYPE<=2 THEN ELSIZE=BYTES(PRECP) C
ELSE ELSIZE=ACC
DVD=SNDISP; ! LOCATION OF DV IF CONSTANT
ARRNAME=FROM AR2(P); ! NAME OF ENTITY
NAMINF=TAGS(ARRNAME)
FAULT(87,0,ARRNAME) IF ARR=3; ! ARRAYFORMAT USED AS ARRAY
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.
!
ARRNAME=X'FFFF' AND NAMINF=-2 AND DVD=0 IF ARRP>2; ! ARRAYS IN RECORDS
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
CYCLE KK=1,1,JJ; ! THROUGH THE SUBSCRIPTS
P=P+3; BOT2=0; PRIVOPS=0
TORP(HEAD2,BOT2,PRIVOPS); ! SUBSCRIPT TO REVERSE POLISH
IF PTYPE=1 AND PRIVOPS&1<<17#0 THEN C
WARN(1,0) AND BINSERT(HEAD2,BOT2,14,0,0);! SHORTEN
NOPS=(NOPS+PRIVOPS&X'FFF')!PRIVOPS&X'FFFF0000'
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,PTYPEP<<16!ARRNAME,ELSIZE);! DOPE VECTOR MULTIPLY
BOT3=HEAD3 IF BOT3=0
VMYOP=KK<<24!JJ<<16!DVD
PUSH(HEAD3,1<<16,VMYOP,BS<<18!DP);! MULTIPLIER
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
!
ASLIST(BOT1)_LINK=HEAD3
BOT1=BOT3
EXPOP(HEAD1,BREG,NOPS,X'251'); ! EVALUATE THE REVERSE POLISH LIST
! CONSTANT ACCEPTABLE AS RESULT
ASLIST(BOT1)_LINK=ASL
ASL=HEAD1
BASE=BS; DISP=DP; ACCESS=3; AREA=-1
IF EXPOPND_FLAG<=1 START ; ! EVALUATED TO CONSTANT
NUMMOD=EXPOPND_D; ! VALUE OF CONSTANT
IF NUMMOD<0 THEN GETINACC(BREG,1,0,0,NUMMOD) ELSE C
ACCESS=1; ! DESCPTR WITH CONST MODIFIER
FINISH
FINISH ELSE START
IF JJ>Q THEN FAULT(20,JJ-Q,ARRNAME) C
ELSE FAULT(21,Q-JJ,ARRNAME)
P=P+2; SKIP APP
BASE=BS; DISP=0; ACCESS=3; AREA=-1
FINISH
ACC=ELSIZE
PTYPE=PTYPEP; UNPACK; J=JJ
OLDI=SOLDI; ! FOR NAME==A(EL) VALIDATION
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 OR ODD 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) *
!* *
!* 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, KK, 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, 0, 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(43, 0, FNAME) IF LITL=1 AND ROUT=0=NAM 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(27,0,FNAME) AND ->NOT SET
->FUNNY(Z) IF Z>=10
->RTCALL IF ROUT=1
->SW(TYPE)
SW(6):
FAULT(5, 0, FNAME)
->NOT SET
SW(4): !RECORD FORMAT NAME
FAULT(87,0,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) AND ->CHKEN
IF A(P+2)=2 THEN P=P+3 ELSE NO APP
ACCESS=0; BASE=I; DISP=K; AREA=-1
ADJUST HEAD:
IF ARR=1=J AND PARMARR=0=NAM AND PARMCHK=0 AND C
TYPE<=3 START ; ! ADJUST DESR TO 1ST ELMNT
GET WSP(JJ,4)
GET IN ACC(ACCR,4,ACCESS,AREA CODE,DISP)
PSF1(ST,1,JJ)
GET IN ACC(BREG,1,2,LNB,JJ+8);
IF TYPE=3 THEN KK=ACC ELSE KK=BYTES(PREC)
PSF1(MYB,0,KK) UNLESS KK=1
PSF1(LD,1,JJ)
PF1(INCA,0,BREG,0); ! ADJUST DESCRPTR
PSF1(STD,1,JJ)
GRUSE(DR)=0; GRUSE(ACCR)=0
GRUSE(BREG)=0; AREA=LNB; DISP=JJ
FINISH
->CHKEN
S(12): ! ARRAYS IN RECORDS BY NAME
NAMEOP(1,ACCR,16,NAMEP); ! Z=STORE TO UPDATE BASE&DISP
->ADJUST HEAD
FUNNY(13): ! LOAD ADDR FOR RT-TYPE
IF PTYPE=SNPT THEN CSNAME(Z,REG) AND ->CHKEN
DISP=SNDISP; 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
PSF1(JLK,0,1); ! GET PC TO TOS
RTJUMP(LDA,ASLIST(TAGS(FNAME))_S2);! ADD N TO POINT @ ENTRY
PF1(INCA,0,TOS,0); ! AND TO DES REG
PF1(LDTB,0,PC,WORD CONST(X'E0000001'))
IF BASE=0 THEN BASE=1; ! FOR FILE OF RTS
GET IN ACC(ACCR,1,0,LNB,PTR OFFSET(BASE))
PF1(LUH,0,PC,WORD CONST(M'IMP'));! SPARE FIELD IN RT HDDR
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
RMAP: ! USER DEFINED RECORD MAPES
JJ=X'18000000'+SAVESL
PF1(LUH,0,PC,WORD CONST(JJ))
RFUN: IF REG=ACCR AND Z=3 AND A(P)>1 THEN ->CHKEN
GET WSP(JJ,2)
PSF1(ST,1,JJ); ! STORE A LOCAL POINTER
COPY TAG(NAMEP); ! SET UP KFORM ETC
NAM=1; I=RBASE; K=JJ
P=P-3; ! AND DROP THRO TO FECTH ENAME
SW(3): ! RECORD
CRNAME(Z, REG, 2*NAM, I, -1, K, NAMEP)
->S(Z) IF Z>=10
STNAME=NAMEP IF Z=1 OR Z=6
->STRINREC IF TYPE=5 AND Z#6
->NOT SET IF TYPE=7
IF Z=5 AND TYPE=3 THEN Z=3
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
IF LITL=1 AND NAM=0 START ;! CONST STRINGS IN CTABLE
PF1(LDRL,0,PC,STRLINK)
PSF1(INCA,0,K)
PF1(LDB,2,7,0)
GRUSE(DR)=0
IF Z=2 OR Z=5 THEN ->COPY
AREA=7; ACCESS=2; DISP=0
FINISH ELSE START
BASE=I; ACCESS=2; AREA=-1; DISP=K
FINISH
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
->COPY
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
COPY: IF REG=ACCR THEN COPY DR
->CHKEN
STRARR: ! STRINGARRAYS & ARRAYNAMES
CANAME(ARR, I, K)
NAMEP=-1
IF Z=1 OR Z=6 THEN STNAME=NAMEP
SAINREC: ! STRING ARRAYS IN RECORDS
IF Z=1 OR Z=3 THEN START
IF NAM=1 THEN START
GET IN ACC(DR,2,0,AREA CODE,DISP+8);! DV DR
! CANAME WILL HAVE SET J=DIMEN
! FOR ALL CASES INCLUDING RECORDS
PF1(SLB,1,0,1+3*(J-1)); ! STACK MODIFIER AND
GRUSE(BREG)=0; ! SET BREG TO STRING LENGTH
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
IF ACCESS=1 THEN START
PSF1(MODD,0,NUMMOD) UNLESS NUMMOD=0
FINISH ELSE START
PF1(MODD,0,BREG,0) IF ACCESS=3
FINISH
PSF1(LDB,0,ACC)
FINISH
IF REG=ACCR THEN COPY DR
->CHKEN
FINISH
IF Z=4 THEN NAMEOP(Z,REG,4,-1) AND ->CHKEN
GET IN ACC(DR,2,0,AREA CODE,DISP) UNLESS AREA=7
IF ACCESS=1 THEN START
PSF1(MODD,0,NUMMOD) UNLESS NUMMOD=0
FINISH ELSE START
PF1(MODD,0,BREG,0) IF ACCESS=3
FINISH
->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, 0, 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
->CHKEN
FINISH
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, 0, FNAME); BASE=0
ACCESS=0; DISP=0
FINISH
MVFNRES: IF TYPE=3 THEN ->RFUN
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 START
BOOT OUT(BREG) IF REGISTER(BREG)#0
PF1(ST,0,BREG,0)
FINISH
FINISH
NEST=REG; ->CHKEN
UDM: ! USER DEFINED MAPS
->RMAP IF TYPE=3
PF1(ST,0,BREG,0); ! RETURN 32 BIT ADDR IN ACC
DISP=MAPDES(PREC)
ACCESS=3; AREA=PC
NAMEP=-1; STNAME=-1
BIM: ! BUILT IN MAPS
->CHKEN IF TYPE=3; ! MAP RECORD USE VERY LIMITED
NAMEP=-1 AND STNAME=-1 UNLESS AREA=PC AND ACCESS=3
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 NAMEP>0 AND C
GRINF1(DR)=NAMEP&X'FFFF' AND 1<=Z<=2 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 GET IN ACC(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 GRINF1(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(90,0,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,FROMAR2(P+1),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)
INTEGERFNSPEC BASEREG(INTEGER GRUSEVAL,GRINFVAL)
INTEGER KK, JJJ, TOTHER, XYNB, JJ, OP1, OP2
KK=Z; KK=2 IF Z=5
IF Z=6 THEN START
FAULT(82,0,NAMEP) UNLESS NAM=1 AND ROUT=0 C
AND (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 DESCPTR AT AREA & DISP MODDED BY CONST NUMMOD
! =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
!
! NOTE THAT ACCESS=1 AS USED ON VARIABLES IS DIFFERENT FROM ACCESS=1
! AS USED IN ACTUAL PLANTING ROUTINES PF1 ETC. THE CODE ACCESS=1 NEEDS
! THE RELEVANT DESCRIPOR IN DR FIRST !
!
! AREA=7 WITH ACCESS =2 OR 3 IS USED WHEN THE DESCRIPTOR IS ALREADY
! LOADED IN DR. THIS IS AWKARD ESPECIALLY ON THE GET 32 BIT ADDR
! CASE AND NEEDS PLANTING OF IMAGE STORE FORMAT INSTRNS
!
MOD(0): ! ACCESS=0 FETCH ADDRESS
IF TYPE=3 THEN GETINACC(REG,1,0,AREA CODE,DISP-4) C
AND RETURN
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 GRINF1(DR)=BASE
GRUSE(DR)=SIZE+11; GRINF1(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 C
THEN NEST=-1 AND RETURN
MOD(10): ! ACCESS=2 FETCH
IF GRUSE(REG)>=9 AND NAMEP>0 THEN START
IF (GRINF1(REG)=NAMEP AND GRUSE(REG)&255=9) C
OR (GRINF2(REG)=NAMEP AND GRUSE(REG)>>16=9) 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=GRINF1(TOTHER)
IF (KK=NAMEP AND GRUSE(TOTHER)&255=9) C
OR (GRINF2(TOTHER)=NAMEP C
AND GRUSE(TOTHER)>>16=9) START
IF REG=BREG AND REGISTER(BREG)=0 START
PF1(ST,0,BREG,0); ! ACC TO BRGE
GRUSE(REG)=GRUSE(TOTHER)
GRINF1(REG)=GRINF1(TOTHER)
GRINF2(REG)=GRINF2(TOTHER)
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 GRINF1(DR)=BASE
GRUSE(DR)=SIZE+11; GRINF1(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 C
THEN TEST ASS(REG,TYPE,SIZE)
NEST=REG; RETURN
FINISH
MOD(14): ! ACCESS=3 FETCH
IF ACCESS>=2 AND (AREA=7 OR (GRUSE(DR)=7 AND NAMEP>0 C
AND GRINF1(DR)=NAMEP&X'FFFF')) THEN AREA=7 AND DISP=0 C
ELSE AREA=AREA CODE
DRFETCH:
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 C
THEN GRUSE(REG)=9 AND GRINF1(REG)=NAMEP
IF ACCESS>=2 AND AREA#7 AND NAMEP>0 C
THEN GRUSE(DR)=7 AND GRINF1(DR)=NAMEP&X'FFFF'
NEST=REG; RETURN
MOD(3): ! ACCESS=0 SET DESCRIPTOR
ABORT UNLESS REG=ACCR OR REG=DR
IF TYPE=3 THEN START
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
JJ=NUMMOD
JJ=JJ*BYTES(PREC) IF PREC>4; ! HALF COME WITH BYTE MODIFIER
->MD20
MOD(20): ! ACCESS=5 FETCH ADDRESS
JJ=NUMMOD+XDISP
MD20: GET IN ACC(REG,1,0,AREA CODE,DISP+4);! BACK HALF OF DESCTR
IF REG=ACCR THEN OP1=IAD ELSE OP1=ADB
PSF1(OP1,0,JJ) UNLESS JJ=0
RETURN
MOD(7): ! ACCESS=1 SET DESCRIPTOR
JJ=NUMMOD
JJ=JJ*BYTES(PREC) IF PREC>4; ! HALF COME WITH BYTE MODIFIER
GET IN ACC(REG,2,0,AREA CODE,DISP);! DESCTR
IF REG=ACCR THEN OP1=IAD ELSE OP1=INCA
PSF1(OP1,0,JJ) UNLESS JJ=0
RETURN
MOD(5): ! ACCESS=1 STORE
MOD(6): ! ACCESS=1 FETCH
IF NUMMOD=0 THEN ACCESS=2 AND ->MOD(KK+8)
UNLESS GRUSE(DR)=7 AND NAMEP>0 AND GRINF1(DR)=NAMEP&X'FFFF'C
THEN GET IN ACC(DR,2,0,AREA CODE,DISP)
IF NAMEP>0 THEN GRUSE(DR)=7 AND GRINF1(DR)=NAMEP&X'FFFF'
AREA=0; DISP=NUMMOD
->DRFETCH IF Z=2
RETURN
MOD(12): ! ACCESS=3 FETCH ADDRESS
JJJ=BYTES(PREC)
!
! REMEMBER HALF INTEGERS READY SCALED BY VMY OR IN CANAME
!
PSF1(MYB,0,JJJ) AND GRUSE(BREG)=0 UNLESS JJJ=1 OR PREC=4
MD12: IF REG=BREG THEN START
IF AREA=7 START
PF1(INCA,0,BREG,0)
GRUSE(DR)=0
PF1(LB,2,0,11); ! DR BTM HALF TO B VIA IMAGE STORE INSTRUCTION
FINISH ELSE PF1(ADB,0,AREA CODE,DISP+4)
GRUSE(BREG)=0
RETURN
FINISH
MOD(8): ! ACCESS=2 FETCH ADDRESS
IF AREA=7 THEN GET IN ACC(REG,1,2,0,11) ELSE C
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 AREA=7 THEN DISP=0 AND RETURN
IF GRUSE(DR)=7 AND NAMEP>0 AND GRINF1(DR)=NAMEP&X'FFFF' C
THEN 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 OR (TYPE=3 AND PARMARR=0) 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
->MOD(KK); ! REDUCES TO ACCESS=0
MOD(36): ! ACCESS=9 FETCH ADDRESS
MOD(37): ! ACCESS=9 STORE
MOD(38): ! ACCESS=9 FETCH
MOD(39): ! ACCESS=9 SET DESCRIPTOR
XYNB=BASEREG(8,NAMEP&X'FFFF')
DISP=NUMMOD+XDISP; AREA=XYNB
ACCESS=3; NAMEP=0
->MOD(KK+8); ! HAS REDUCED TO ACCESS=2
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=BASEREG(8,NAMEP&X'FFFF')
AREA=XYNB; ACCESS=0
DISP=XDISP; ->MOD(KK)
FINISH
IF SIZE=1 THEN START ; ! SIZE = 1 FOR BYTES
PSORLF1(LD,0,AREA CODE,DISP) C
UNLESS GRUSE(DR)=7 AND NAMEP>0 C
AND GRINF1(DR)=NAMEP&X'FFFF'
FINISH ELSE START ; ! SIZE=2 FOR HALFS
PF1(LDTB,0,PC,MAP DES(4)) UNLESS GRUSE(DR)=13 OR GRUSE(DR)=15
PSORLF1(LDA,0,AREA CODE,DISP+4) UNLESS C
NAMEP>0 AND GRINF1(DR)=NAMEP&X'FFFF' AND C
(GRUSE(DR)=7 OR GRUSE(DR)=15)
FINISH
GRUSE(DR)=0
IF NAMEP>0 THEN GRUSE(DR)=8*SIZE-1 AND GRINF1(DR)=NAMEP&X'FFFF'
ACCESS=1; AREA=0
DISP=XDISP
IF DISP=0 AND ACCESS=1 C
THEN AREA=7 AND ACCESS=2
->DRFETCH IF Z=2
RETURN
MOD(23): ! ACCESS=5 SET DESCRIPTOR
XDISP=NUMMOD+XDISP
->MD31
MOD(19): ! ACCESS=4 SET DESCRIPTOR
DISP=DISP-8
MOD(27): ! ACCESS=6 SET DESCRIPTOR
MOD(31): ! ACCESS=7 SET DESRCPTOR
MD31: 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 PSORLF1(LDB,0,0,ACC) ELSE C
PF1(LDTB,0,PC,PARAM DES(PREC))
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
MOD(21): ! ACCESS=5 STORE
MOD(22): ! ACCESS=5 FETCH
IF 1<=SIZE<=2 THEN START
IF SIZE=1 THEN START
PSORLF1(LD,0,AREA CODE,DISP) UNLESS GRUSE(DR)=7 AND C
NAMEP>0 AND GRINF1(DR)=NAMEP&X'FFFF'
FINISH ELSE START ; ! SIZE=2 HALFS
PSORLF1(LDA,0,AREA CODE,DISP+4) UNLESS NAMEP>=0 C
AND GRINF1(DR)=NAMEP&X'FFFF' AND C
(GRUSE(DR)=7 OR GRUSE(DR)=15)
PF1(LDTB,0,PC,MAPDES(4)) UNLESS C
GRUSE(DR)=13 OR GRUSE(DR)=15
FINISH
GRUSE(DR)=0
IF NAMEP>0 THEN GRUSE(DR)=8*SIZE-1 AND C
GRINF1(DR)=NAMEP&X'FFFF'
IF ACCESS=7 START
PSF1(ADB,0,XDISP) IF XDISP#0
ACCESS=3; AREA=7
DISP=0
GRUSE(BREG)=0
FINISH ELSE START ; ! ACCESS = 5
DISP=XDISP+NUMMOD
ACCESS=1; AREA=0
FINISH
NAMEP=0
->DRFETCH IF Z=2
RETURN
FINISH
IF ACCESS=7 START
PSORLF1(ADB,0,AREA CODE,DISP+4)
GRUSE(BREG)=0
XYNB=XORYNB(0,0)
PF1(LDCODE(XYNB),0,BREG,0)
GRUSE(XYNB)=0
DISP=XDISP
FINISH ELSE START ; ! ACCESS=5
XYNB=BASEREG(8,NAMEP&X'FFFF')
DISP=NUMMOD+XDISP
FINISH
AREA=XYNB; ACCESS=0
NAMEP=0
->MOD(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
XYNB=BASEREG(8,NAMEP&X'FFFF')
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)
GRUSE(BREG)=0
XYNB=XORYNB(0,0)
PF1(LDCODE(XYNB),0,BREG,0)
GRUSE(XYNB)=0
NAMEP=0; AREA=XYNB
ACCESS=2; DISP=XDISP; ->MOD(KK+8)
INTEGERFN BASEREG(INTEGER GRUSEVAL,GRINFVAL)
!***********************************************************************
!* SETS A BASE REGISTER FOR RECORD WHOSE POINTER IS AT AREA&DISP *
!***********************************************************************
INTEGER XYNB
IF NAMEP<=0 THEN GRUSEVAL=0 AND GRINFVAL=0
XYNB=XORYNB(GRUSEVAL,GRINFVAL)
PSORLF1(LDCODE(XYNB),0,AREA CODE,DISP+4) UNLESS C
GRUSE(XYNB)=GRUSEVAL>0 AND GRINF1(XYNB)=GRINFVAL
GRUSE(XYNB)=GRUSEVAL
GRINF1(XYNB)=GRINFVAL
GRAT(XYNB)=CA
RESULT =XYNB
END
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,JJ,JJJ,NPARMS,PT,LP,PSIZE,TWSP,PARMNO,ERRNO,PP,C
FPTR,TYPEP,PRECP,NAMP,TL,MOVEPTR,CLINK,RDISP,PSPECED,SACC
RECORD (LISTF)NAME LCELL
PT=PTYPE; JJJ=J; TL=OLDI
TWSP=0
LP=I; CLINK=K
TYPEP=TYPE; PRECP=PREC; NAMP=NAM
RDISP=SNDISP; SACC=ACC
IF CLINK=0 THEN PSPECED=0 ELSE PSPECED=ASLIST(CLINK)_S3&255
!
! NOW CHECK THAT THE RIGHT NUMBER OF PARAMETERS HAVE BEEN PROVIDED
!
TEST APP(NPARMS)
P=P+2
IF PSPECED#NPARMS THEN START
! WRONG NO OF PARAMETERS GIVEN
IF PSPECED=0 THEN ERRNO=17 ELSE C
IF NPARMS<PSPECED THEN ERRNO=18 ELSE ERRNO=19
FAULT(ERRNO,IMOD(PSPECED-NPARMS),RTNAME)
SKIP APP; P=P-1
RETURN
FINISH
!
SAVE IRS; ! STACK ANY IRS BEFORS ASF
PSF1(PRCL,0,4)
FPTR=20
PARMNO=0
->FIRST PARM
!
BAD PARM: ! BAD PARAMETER FAULT IT
P=PP
FAULT(22,PARMNO,RTNAME)
SKIP EXP
NEXT PARM:CLINK=LCELL_LINK
FIRSTPARM:->ENTRY SEQ IF CLINK=0; ! DEPART AT ONCE IF NO PARAMS
LCELL==ASLIST(CLINK)
PSIZE=LCELL_S2>>16
PARMNO=PARMNO+1
P=P+1; PP=P
PTYPE=LCELL_S1>>16
UNPACK
II=TYPE;III=PREC
JJ=(NAM<<1!ARR)&3
->BAD PARM 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)
!
! 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
->BAD PARM 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(TWSP,VALUE,268,0); ! RETURN WK AREA AT CALL
FPTR=FPTR+8; ->NEXT PARM
FINISH
IF TYPE=3 START ; ! RECORDS BY VALUE
II=TSEXP(III); ! CHECK FOR ZERO AS RECORD VALUE
IF II=1 AND III=0 START
III=MVL
FINISH ELSE START
P=PP; ! RESET NEEDED AFTER TSEXP
->BAD PARM UNLESS A(P+3)=4 AND A(P+4)=1 AND C
A(P+FROMAR2(P+1)+1)=2
II=0; III=MV
P=P+5
CNAME(5,ACCR)
->BADPARM UNLESS TYPE=3 AND PSIZE=ACC
P=P+1
FINISH
PF1(LDTB,0,PC,WORD CONST(X'18000000'+PSIZE))
PF1(STSF,0,BREG,0)
PSF1(ADB,0,8)
PF1(LDA,0,BREG,0)
PF1(STD,0,TOS,0)
PSF1(ASF,0,(PSIZE+3)>>2)
PF2(III,1,II,0,0,0)
GRUSE(BREG)=0
GRUSE(ACCR)=0
GRUSE(DR)=0
FPTR=FPTR+8+(PSIZE+3)&(-4)
->NEXT PARM
FINISH
IF PREC=6 THEN JJ=3 ELSE JJ=TYPE
CSEXP(ACCR,III<<4!II)
MOVEPTR=((BYTES(III)+3)&(-4))
->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)
->BAD PARM UNLESS II=TYPE AND III=PREC
FINISH ELSE START
CNAME(4,ACCR)
IF TYPE<=2 THEN START
IF PREC=4 THEN JJ=X'58000002' ELSE JJ=PREC<<27!TYPE
FINISH ELSE JJ=X'1A'<<24+ACC
PF1(LUH,0,PC,WORD CONST(JJ))
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
->BAD PARM UNLESS 1<=ARR<=2 AND II=TYPE AND III=PREC
QQQ=FROM1(TCELL)&15; ! DIMENSION OF ACTUAL(IF KNOWN)
JJ=LCELL_S1&15; ! DIMENSION OF FORMAL
IF JJ=0 THEN JJ=QQQ AND LCELL_S1=LCELL_S1!JJ
IF QQQ=0 THEN QQQ=JJ AND REPLACE1(TCELL,FROM1(TCELL)!JJ)
->BAD PARM 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
!
! RETURN ANY STRING WSPACE HERE. CAN BE UXED AGAIN FOR RESULT
!
WHILE TWSP#0 CYCLE
POP(TWSP,QQQ,JJ,III)
RETURN WSP(QQQ,268)
REPEAT
!
! STRING AND RECORD FNS NEED A WORK AREA TO RETURN THEIR RESULTS
!
IF (TYPEP=3 OR TYPEP=5) AND NAMP<=1 THEN START
GET WSP(QQQ,268)
STRFNRES=QQQ; ! FOR CSTREXP TO USE
IF TYPEP=5 AND SACC<=2 THEN SACC=256
III=X'18000000'+SACC; 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
IF TYPEP=3 THEN PUSH(TWSPHEAD,STRFNRES,268,0)
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 IF NAMP&1=0 THEN START ;! INTERNAL RT CALLS
IF LP=0 THEN LP=1; ! FOR TOPLEVEL OF FILE OF RTS
II=SET XORYNB(XNB,LP)
PSF1(RALN,0,FPTR>>2)
RT JUMP(CALL,ASLIST(TAGS(RTNAME))_S2)
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
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,TOP
IF J=15 THEN START ; ! RT BODY NOT GIVEN YET
TOP=LINK>>16
PUSH(TOP,CODE<<24!3<<23,CA,0)
PF1(CODE,0,0,0)
LINK=LINK&X'FFFF'!TOP<<16
FINISH ELSE START ; ! BODY GIVEN AND ADDRESS KNOWN
DP=LINK>>16<<2-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'41' AND SIGN#3
KK=FROMAR2(P+3)
IF REXP#0 AND A(P+6)=CONCOP THEN TYPE=5 AND ->TYPED
->TYPED UNLESS REXP=0 AND 0<=KK<=255
VALUE=KK
P=P+6
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
P=P+3 AND SKIP APP UNTIL A(P)=2 ;! 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
P=P+1 AND SKIP EXP WHILE A(P)=1
P=P+1
END
ROUTINE NO APP
P=P+2
IF A(P)=1 THEN START ; ! <APP> PRESENT
FAULT(17,0,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
RETURN 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 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)
!***********************************************************************
!* RETURNS WORKSPACE TO ORDERED FREE LIST. ADDRESSABLE CELLS *
!* ARE PUT AT THE TOP. NON-ADDRESSABLE ON THE BACK *
!***********************************************************************
ABORT UNLESS (20<=PLACE<=N AND PLACE&3=0) OR FAULTY#0
! UNDECLARED VARS RIVE RUBBISH
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 *
!***********************************************************************
INTEGER XYNB,I,LDI,STI,REG
LDI=LSS; STI=ST; REG=ACCR
! %IF PARMDBUG!PARMPROF=0 %AND GRUSE(ACCR)#0 %AND %C
! (GRUSE(BREG)=0 %OR GRUSE(BREG)=5) %START
! LDI=LB
! STI=STB
! REG=BREG
! %FINISH
PSF1(LDI,0,LINE) IF PARMLINE!PARMDBUG#0
IF PARMLINE=1 THEN START
PSF1(STI, 1, DIAGINF(LEVEL))
GRUSE(REG)=5; GRINF1(REG)=LINE
FINISH
IF PARMDBUG#0 THEN PPJ(0,3)
IF PARMPROF#0 THEN START
XYNB=SET XORYNB(-1,0); ! TO PLT
I=PARMPROF+8+4*LINE
PF1(X'56',0,XYNB,I); ! INCT
GRUSE(ACCR)=0
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 GRINF1(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)=ST,STD,STLN,STXN,0,STCT,STSF,STB;
INTEGER CODE
RECORD (RD)NAME R
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 *
!***********************************************************************
RECORD (RD)NAME OPND
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
RECORD (LISTF)NAME LCELL
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,0,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)
!***********************************************************************
!* A TAG IS A LIST CELL POINTED AT BY TAGS(NAME) *
!* S1 HAS PTYPE<<16!USEBITS(2)!TEXT LEVEL(OLDI6)!RTLEVE(4)!DIMEN *
!* S2 HAS SECONDARY DISP(SIGNED)<<16! ACC OR ITEM SIZE IN BYTES *
!* S3 HAS PRIMARY DISP(K)<<16!KFORM WHICH IS POINTER TO FORMAT *
!* SIDE CHAIN FOR ITEMS OF TYPE RECORD *
!* LINK HAS PTR TO TAG OF NAME HIDDEN WHEN THIS ONE DECLARED *
!***********************************************************************
INTEGER QQQ,MIDCELL
RECORD (LISTF)NAME LCELL
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'
MIDCELL=LCELL_S2
QQQ=LCELL_S3
PTYPE=KK>>16; USEBITS=KK>>14&3
OLDI=KK>>8&63; I=KK>>4&15; J=KK&15
SNDISP=MIDCELL&X'FFFF0000'//X'10000'
ACC=MIDCELL&X'FFFF'
K=QQQ>>16
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
! 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&3)<<2!ROUT&3)<<2!NAM&3)<<2!ARR&3)<<4! C
PREC&15)<<4!TYPE&15
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, J
RECORD (LISTF)NAME LCELL
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' ELSESTART
LCELL==ASLIST(PLINK(N))
J=INSTRN!CA; ! ONLY 18 BITS NEEDED FOR CA
IF LCELL_S3#0 THEN PUSH(PLINK(N),J,0,0) ELSE START
IF LCELL_S2=0 THEN LCELL_S2=J ELSE LCELL_S3=J
FINISH
FINISH
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 GRINF1(WHICH)=INF THEN C
GRAT(WHICH)=CA AND RESULT =WHICH
OFFSET=PTR OFFSET(RLEV)
PSF1(LDCODE(WHICH),1,OFFSET)
GRUSE(WHICH)=USE; GRINF1(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 GRINF1(XNB)=INF THEN GRAT(XNB)=CA C
AND RESULT =XNB
IF GRUSE(CTB)=USE AND GRINF1(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
INTEGERFN AREA CODE2(INTEGER BS)
!***********************************************************************
!* A VERSION OF AREA CODE WITHOUT SIDE EFFECTS ! *
!***********************************************************************
IF BS=RBASE THEN RESULT =LNB
RESULT =SET XORYNB(-1,BS)
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 OR (ACCESS=2 AND AREA=0)THEN C
BOOT OUT(REG) ELSE START ; ! CANNOT SLSS ISN ON ALL MCS
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 AND 0#AREA#7 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'1100011110000000';! MASK OF USES RELEVANT TO ==
CONSTINTEGER EMASK=B'100011000000000';! MASK OF USES RELEVANT TO =
CONSTINTEGER NREGS=5
CONSTINTEGER REGS=16*16*16*16*CTB+16*16*16*XNB+16*16*ACCR+16*BREG+DR
INTEGER I,USE1,USE2,II
RETURN IF VAR<=0
IF ASSOP=1 THEN START
CYCLE I=0,1,7
USE1=GRUSE(I); USE2=USE1>>16; USE1=USE1&255
IF EEMASK&1<<USE2#0 AND (GRINF2(I)&X'FFFF'=VAR OR C
GRINF2(I)>>16=VAR) THEN GRUSE(I)=USE1 AND USE2=0
IF EEMASK&1<<USE1#0 AND (GRINF1(I)&X'FFFF'=VAR OR C
GRINF1(I)>>16=VAR) THEN GRUSE(I)=USE2 AND C
GRINF1(I)=GRINF2(I)
REPEAT
GRUSE(REG)=7
GRINF1(REG)=VAR
FINISH ELSE START
CYCLE II=0,4,4*(NREGS-1)
I=REGS>>II&15
USE1=GRUSE(I); USE2=USE1>>16; USE1=USE1&255
IF EMASK&1<<USE2#0 AND (GRINF2(I)&X'FFFF'=VAR OR C
GRINF2(I)>>16=VAR OR GRINF2(I)=VAR) THEN C
GRUSE(I)=USE1 AND USE2=0
IF EMASK&1<<USE1#0 AND (GRINF1(I)&X'FFFF'=VAR OR C
GRINF1(I)>>16=VAR OR GRINF1(I)=VAR) THEN C
GRUSE(I)=USE2 AND GRINF1(I)=GRINF2(I)
!
! ALL THE FOREGOING CONDITIONS ARE NOT AS SILLY AS THEY SEEM. MUST
! BEAR IN MIND THAT BOTH GRINF&VAR MAY BE RECORD ELEMENTS DEFINED
! BY ALL 32 BITS OF INF AS WELL AS MODIFIED SCALARS WHEN THE NAME
! ONLY TAKES 16 BITS
!
REPEAT
IF ASSOP=2 AND VAR>0 START
USE1=GRUSE(REG)
IF 5<=USE1&255<=6 START ; ! ASSIGN CONST TO VAR
GRUSE(REG)=USE1&255!(9<<16)
GRINF2(REG)=VAR
FINISH ELSE START ; ! ASSIGN VAR OR EXP TO VAR
GRUSE(REG)=USE1<<16!9
GRINF2(REG)=GRINF1(REG); ! PREVIOUS USE BECOMES 2NDRY
GRINF1(REG)=VAR
FINISH
FINISH
FINISH
END
END ; ! OF ROUTINE CSS
!*DELSTART
ROUTINE PRINTUSE
!***********************************************************************
!* UP TO TWO USES ARE REMEMBERED INFO IN GRINF1 & GRINF2 *
!* BOTTOM HALF OF GRUSE RELATES TO INF1 TOP HALF TO INF2 *
!* THE MEANS CLEARING GRUSE TO FORGETS THE REG COMPLETELY *
!* ARRAY REGISTER KEEPS THE CLAIM STATUS AND GRAT THE LAST USE *
!***********************************************************************
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 "," AUXSTPTR- ",
" BYTE DES "," HALF DES ",
" VMY RES "," REC HDES ";
CONSTSTRING (11)ARRAY STATE(-1:3)=C
" LOCKED "," FREE ",
" I-RESULT "," TEMPORARY ",
" RT-PARAM ";
ROUTINESPEC OUT(INTEGER USE,INF)
INTEGER I,USE
CYCLE I=0,1,7
IF REGISTER(I)!GRUSE(I)#0 START
USE=GRUSE(I)
PRINTSTRING(REGS(I).STATE(REGISTER(I)))
OUT(USE&255,GRINF1(I))
IF USE>>16#0 THEN PRINTSTRING(" ALSO ") C
AND OUT(USE>>16,GRINF2(I))
NEWLINE
FINISH
REPEAT
RETURN
ROUTINE OUT(INTEGER USE,INF)
CONSTINTEGER LNMASK=B'1100011110000000'
CONSTINTEGER UNMASK=B'0100001110000000'
PRINTSTRING(" USE = ".USES(USE))
IF LNMASK&1<<USE#0 THEN PRINTSTRING(PRINTNAME(INF&X'FFFF')) C
ELSE WRITE(INF,1)
IF USE=10 THEN PRINTSYMBOL('+') AND WRITE(INF>>16,1)
IF UNMASK&1<<USE#0 AND INF>>16#0 THEN PRINTSTRING(" MODBY ") C
AND PRINTSTRING(PRINTNAME(INF>>16))
END
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
ABORT
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
! JAT 4,LNULL ! ZERO FOR NO 1ST PART RESLN
! 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'23')
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'26')
PSF1(LD,1,22)
PF2(SWNE,1,0,0,0,0)
PF3(JCC,8,0,X'22')
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(JAT,4,0,7)
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)
! EVENT 5/5 IS SIGNALLED 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",PARMDYNAMIC,2,LOGEPDISP)
IF EXPEPDISP=0 THEN CXREF("S#IEXP",PARMDYNAMIC,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'1FF00000000' 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(511)
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",PARMDYNAMIC,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:
!
! PRINTPROFILE
!
IF PLINK(22)=0 THEN ->P23
FILL(22)
CXREF("S#PPROFILE",PARMDYNAMIC,2,J)
PSF1(PRCL,0,4)
PSF1(LXN,1,16)
PF1(LDRL,0,XNB,PARMPROF)
PF1(STD,0,TOS,0)
PSF1(RALN,0,7)
PF1(CALL,2,XNB,J)
PF1(JUNC,0,TOS,0)
P23:
RETURN
ROUTINE FILL(INTEGER LAB)
!***********************************************************************
!* FILL JUMPS TO THIS LAB WITH JUMP TO CURRENT ADDRESS *
!***********************************************************************
INTEGER AT,INSTRN,I
INTEGERARRAY A(0:2)
WHILE PLINK(LAB)#0 CYCLE
POP(PLINK(LAB),A(0),A(1),A(2))
CYCLE I=0,1,2
INSTRN=A(I)
IF INSTRN#0 THEN START
AT=INSTRN&X'3FFFF'
INSTRN=INSTRN&X'FFFC0000'
INSTRN=INSTRN!(CA-AT)>>1
PLUG(1,AT,INSTRN,4)
FINISH
REPEAT
REPEAT
PLABS(LAB)=CA
END
END
ROUTINE DUMP CONSTS
!***********************************************************************
!* OUTPUT THE CONSTANT TABLE AND MAKE ANY RELEVANT RELOCATIONS *
!***********************************************************************
ROUTINESPEC DOIT(INTEGER VAL)
ROUTINESPEC FILL(INTEGER CREFHEAD)
INTEGER I,J,K,DISP,SIZE,BASE
BASE=0
SIZE=CONSTPTR-BASE
IF SIZE<=0 THEN RETURN
CNOP(0,8) UNLESS CA&7=0
CODE OUT
LPUT(1,SIZE*4,CA,ADDR(CTABLE(BASE)))
!*DELSTART
IF DCOMP#0 START
PRINTSTRING("
CONSTANT TABLE")
I=BASE
CYCLE
NEWLINE
PRHEX(CA+4*(I-BASE),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
!
FILL(CREFHEAD)
SIZE=(SIZE+1)&(-2)
CA=CA+4*SIZE
CABUF=CA
RETURN
ROUTINE FILL(INTEGER CREFHEAD)
DISP=(CA-4*BASE)//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
END
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
STRINGFN MESSAGE(INTEGER N)
!***********************************************************************
!* OUTPUTS AN ERROR MESSAGE STORED IN A COMPRESSED FORMAT *
!* 1 %REPEAT is not required *
!* 2 Label & has already been set in this block *
!* 4 & is not a Switch name at current textual level *
!* 5 Switch name & in expression or assignment *
!* 6 Switch label &(#) set a second time *
!* 7 Name & has already been declared *
!* 8 Routine or fn & has more parameters than specified *
!* 9 Parameter # of & differs in type from specification *
!* 10 Routine or fn & has fewer parameters than specified *
!* 11 Label & referenced at line # has not been set *
!* 12 %CYCLE at line # has two control clauses *
!* 13 %REPEAT for %CYCLE at line # is missing *
!* 14 %END is not required *
!* 15 # %ENDs are missing *
!* 16 Name & has not been declared *
!* 17 Name & does not require parameters or subscripts *
!* 18 # too few parameters provided for & *
!* 19 # too many parameters provided for & *
!* 20 # too few subscripts provided for array & *
!* 21 # too many subscripts provided for array & *
!* 22 Actual parameter # of & conflicts with specification *
!* 23 Routine name & in an expression *
!* 24 Integer operator has Real operands *
!* 25 Real expression in integer context *
!* 26 # is not a valid %EVENT number *
!* 27 & is not a routine name *
!* 28 Routine or fn & has specification but no body *
!* 29 %FUNCTION name & not in expression *
!* 30 %RETURN outwith routine body *
!* 31 %RESULT outwith fn or map body *
!* 34 Too many textual levels *
!* 37 Array & has too many dimensions *
!* 38 Array & has upper bound # less than lower bound *
!* 39 Size of Array & is more than X'FFFFFF' bytes *
!* 40 Declaration is not at head of block *
!* 41 Constant cannot be evaluated at compile time *
!* 42 # is an invalid repetition factor *
!* 43 %CONSTANT name & not in expression *
!* 44 Invalid constant initialising & after # items *
!* 45 Array initialising items expected ## items given # *
!* 46 Invalid %EXTERNAL %EXTRINSIC or variable %SPEC *
!* 47 %ELSE already given at line # *
!* 48 %ELSE invalid after %ON %EVENT *
!* 49 Attempt to initialise %EXTRINSIC or %FORMAT & *
!* 50 Subscript of # is outwith the bounds of & *
!* 51 %FINISH is not required *
!* 52 %REPEAT instead of %FINISH for %START at line # *
!* 53 %FINISH for %START at line # is missing *
!* 54 %EXIT outwith %CYCLE %REPEAT body *
!* 55 %CONTINUE outwith %CYCLE %REPEAT body *
!* 56 %EXTERNALROUTINE & at wrong textual level *
!* 57 Executable statement found at textual level zero *
!* 58 Program among external routines *
!* 59 %FINISH instead of %REPEAT for %CYCLE at line # *
!* 61 Name & has already been used in this %FORMAT *
!* 62 & is not a %RECORD or %RECORD %FORMAT name *
!* 63 %RECORD length is greater than # bytes *
!* 64 Name & requires a subname in this context *
!* 65 Subname & is not in the %RECORD %FORMAT *
!* 66 Expression assigned to record & *
!* 67 Records && and & have different formats *
!* 69 Subname && is attached to & which is not of type %RECORD *
!* 70 String declaration has invalid max length of # *
!* 71 & is not a String variable *
!* 72 Arithmetic operator in a String expression *
!* 73 Arithmetic constant in a String expression *
!* 74 Resolution is not the correct format *
!* 75 String expression contains a sub expression *
!* 76 String variable & in arithmetic expression *
!* 77 String constant in arithmetic expression *
!* 78 String operator '.' in arithmetic expression *
!* 80 Pointer variable & compared with expression *
!* 81 Pointer variable & equivalenced to expression *
!* 82 & is not a pointer name *
!* 83 && and & are not equivalent in type *
!* 86 Global pointer && equivalenced to local & *
!* 87 %FORMAT name & used in expression *
!* 90 Untyped name & used in expression *
!* 91 %FOR control variable & not integer *
!* 92 %FOR clause has zero step *
!* 93 %FOR clause has noninteger number of traverses *
!* 95 Name & not valid in assembler *
!* 96 Operand # not valid in assembler *
!* 97 Assembler construction not valid *
!* 101 Source line has too many continuations *
!* 102 Workfile of # Kbytes is too small *
!* 103 Dictionary completely full *
!* 104 Dictionary completely full *
!* 105 Too many textual levels *
!* 106 String constant too long *
!* 107 Compiler tables are completely full *
!* 108 Condition too complicated *
!* 109 Compiler inconsistent *
!* 110 Input ended *
!* 201 Long integers are inefficient as subscripts *
!* 202 Name & not used *
!* 203 Label & not used *
!* 204 Global %FOR control variable & *
!* 205 Name & not addressable *
!* 206 Semicolon in comment text *
!* 207 %CONSTANT variable & not initialised *
!* 208 Unproductive logical operation noted *
!* 209 %SHORT not available - %INTEGER substituted *
!* 255 Contact Advisory Service *
!***********************************************************************
CONSTBYTEINTEGERARRAY OUTTT(0:63)='?','A','B','C','D','E','F','G',
'H','I','J','K','L','M','N',
'O','P','Q','R','S','T','U',
'V','W','X','Y','Z','&','-',
'/','''','(',')',
'a','b','c','d','e','f','g',
'h','i','j','k','l','m','n',
'o','p','q','r','s','t','u',
'v','w','x','y','z','.','%',
'#','?'(2)
CONSTINTEGER WORDMAX= 765,DEFAULT= 761
CONSTHALFINTEGERARRAY WORD(0:WORDMAX)=0,C
1, 32769, 32771, 32772, 32773, 2, 32775, 32776,
32777, 32778, 32780, 32781, 32782, 32783, 32784, 4,
32776, 32771, 32772, 32785, 32786, 32788, 32789, 32790,
32792, 32794, 5, 32786, 32788, 32776, 32782, 32795,
32797, 32798, 6, 32786, 32800, 32801, 32781, 32785,
32802, 32804, 7, 32805, 32776, 32777, 32778, 32780,
32806, 8, 32808, 32797, 32810, 32776, 32777, 32811,
32812, 32814, 32815, 9, 32817, 32819, 32820, 32776,
32821, 32782, 32823, 32824, 32825, 10, 32808, 32797,
32810, 32776, 32777, 32828, 32812, 32814, 32815, 11,
32775, 32776, 32829, 32789, 32831, 32819, 32777, 32772,
32780, 32781, 12, 32832, 32789, 32831, 32819, 32777,
32834, 32835, 32837, 13, 32769, 32839, 32832, 32789,
32831, 32819, 32771, 32840, 14, 32842, 32771, 32772,
32773, 15, 32819, 32843, 32844, 32840, 16, 32805,
32776, 32777, 32772, 32780, 32806, 17, 32805, 32776,
32845, 32772, 32846, 32812, 32797, 32848, 18, 32819,
32850, 32851, 32812, 32852, 32839, 32776, 19, 32819,
32850, 32854, 32812, 32852, 32839, 32776, 20, 32819,
32850, 32851, 32848, 32852, 32839, 32855, 32776, 21,
32819, 32850, 32854, 32848, 32852, 32839, 32855, 32776,
22, 32856, 32858, 32819, 32820, 32776, 32860, 32862,
32825, 23, 32808, 32788, 32776, 32782, 32863, 32795,
24, 32864, 32866, 32777, 32868, 32869, 25, 32868,
32795, 32782, 32871, 32873, 26, 32819, 32771, 32772,
32785, 32875, 32876, 32878, 27, 32776, 32771, 32772,
32785, 32880, 32788, 28, 32808, 32797, 32810, 32776,
32777, 32825, 32882, 32883, 32884, 29, 32885, 32788,
32776, 32772, 32782, 32795, 30, 32887, 32889, 32880,
32884, 31, 32891, 32889, 32810, 32797, 32893, 32884,
34, 32894, 32854, 32792, 32895, 37, 32897, 32776,
32777, 32850, 32854, 32898, 38, 32897, 32776, 32777,
32900, 32901, 32819, 32902, 32814, 32903, 32901, 39,
32904, 32820, 32897, 32776, 32771, 32811, 32814, 32905,
32907, 40, 32908, 32771, 32772, 32789, 32911, 32820,
32784, 41, 32912, 32914, 32916, 32917, 32789, 32919,
32804, 42, 32819, 32771, 32863, 32921, 32923, 32925,
43, 32927, 32788, 32776, 32772, 32782, 32795, 44,
32929, 32931, 32933, 32776, 32936, 32819, 32937, 45,
32897, 32933, 32937, 32938, 32940, 32937, 32941, 32819,
46, 32929, 32942, 32944, 32797, 32946, 32948, 47,
32949, 32778, 32941, 32789, 32831, 32819, 48, 32949,
32921, 32936, 32950, 32876, 49, 32951, 32953, 32954,
32944, 32797, 32956, 32776, 50, 32958, 32820, 32819,
32771, 32889, 32960, 32961, 32820, 32776, 51, 32963,
32771, 32772, 32773, 52, 32769, 32965, 32820, 32963,
32839, 32967, 32789, 32831, 32819, 53, 32963, 32839,
32967, 32789, 32831, 32819, 32771, 32840, 54, 32969,
32889, 32832, 32769, 32884, 55, 32970, 32889, 32832,
32769, 32884, 56, 32972, 32776, 32789, 32976, 32792,
32794, 57, 32977, 32979, 32981, 32789, 32792, 32794,
32982, 58, 32983, 32985, 32986, 32988, 59, 32963,
32965, 32820, 32769, 32839, 32832, 32789, 32831, 32819,
61, 32805, 32776, 32777, 32778, 32780, 32990, 32782,
32783, 32956, 62, 32776, 32771, 32772, 32785, 32991,
32797, 32991, 32956, 32788, 63, 32991, 32993, 32771,
32995, 32814, 32819, 32907, 64, 32805, 32776, 32997,
32785, 32999, 32782, 32783, 32873, 65, 33001, 32776,
32771, 32772, 32782, 32960, 32991, 32956, 66, 33003,
33005, 32953, 33007, 32776, 67, 33009, 33011, 33012,
32776, 33013, 33014, 33016, 69, 33001, 33011, 32771,
33018, 32953, 32776, 33020, 32771, 32772, 32820, 32823,
32991, 70, 33021, 33023, 32777, 32921, 33026, 32993,
32820, 32819, 71, 32776, 32771, 32772, 32785, 33021,
32946, 72, 33027, 32866, 32782, 32785, 33021, 32795,
73, 33027, 32931, 32782, 32785, 33021, 32795, 74,
33029, 32771, 32772, 32960, 33031, 33033, 75, 33021,
32795, 33035, 32785, 33037, 32795, 76, 33021, 32946,
32776, 32782, 33038, 32795, 77, 33021, 32931, 32782,
33038, 32795, 78, 33021, 32866, 33040, 32782, 33038,
32795, 80, 33041, 32946, 32776, 33043, 32862, 32795,
81, 33041, 32946, 32776, 33045, 32953, 32795, 82,
32776, 32771, 32772, 32785, 33048, 32788, 83, 33011,
33012, 32776, 32844, 32772, 33050, 32782, 32823, 86,
33052, 33048, 33011, 33045, 32953, 33054, 32776, 87,
32956, 32788, 32776, 32990, 32782, 32795, 90, 33055,
32788, 32776, 32990, 32782, 32795, 91, 33057, 32835,
32946, 32776, 32772, 32871, 92, 33057, 33058, 32777,
32982, 33060, 93, 33057, 33058, 32777, 33061, 32878,
32820, 33063, 90, 33055, 32788, 32776, 32990, 33065,
32946, 95, 32805, 32776, 32772, 32875, 32782, 33066,
96, 33068, 32819, 32772, 32875, 32782, 33066, 97,
33070, 33072, 32772, 32875, 101, 33075, 32831, 32777,
32850, 32854, 33077, 102, 33080, 32820, 32819, 33082,
32771, 32850, 33084, 103, 33085, 33087, 33089, 104,
33085, 33087, 33089, 105, 32894, 32854, 32792, 32895,
106, 33021, 32931, 32850, 33090, 107, 33091, 33093,
32844, 33087, 33089, 108, 33095, 32850, 33097, 109,
33091, 33100, 110, 33103, 33104, 201, 33105, 33106,
32844, 33108, 33065, 32848, 202, 32805, 32776, 32772,
32990, 203, 32775, 32776, 32772, 32990, 204, 33052,
33057, 32835, 32946, 32776, 205, 32805, 32776, 32772,
33111, 206, 33114, 32782, 33116, 33118, 207, 32927,
32946, 32776, 32772, 33119, 208, 33122, 33125, 33127,
33129, 209, 33130, 32772, 33132, 33134, 33135, 33137,
255, 33140, 33142, 33144, 0
CONSTINTEGERARRAY LETT(0: 377)=0,C
X'7890A80B',X'02A00000',X'53980000',X'5D7E8000',
X'652E3AD3',X'652C8000',X'190C52D8',X'36000000',
X'510E6000',X'436652C3',X'49C80000',X'452CB700',
X'672E8000',X'53700000',X'69453980',X'4565F1D6',
X'42000000',X'27BD3A47',X'50000000',X'5D0DB280',
X'43A00000',X'47AE594B',X'5DA00000',X'692F1A6B',
X'43600000',X'592ED2D8',X'4BC6194B',X'679D37DC',
X'5F900000',X'439E74CF',X'5D6CB768',X'590C52D8',
X'36FFB000',X'672C77DD',X'48000000',X'694DB280',
X'1D0DB280',X'492C7643',X'652C8000',X'257EBA53',
X'5D280000',X'4D700000',X'5B7E5280',X'610E50DB',
X'4BA4B966',X'69443700',X'6784B1D3',X'4D4CB200',
X'210E50DB',X'4BA4B900',X'7A000000',X'5F300000',
X'494CD34B',X'65980000',X'69CE1280',X'4D95F680',
X'6784B1D3',X'4D4C70E9',X'537DC000',X'4D2EF2E4',
X'652CD2E5',X'4B7472C8',X'594DD280',X'781B2199',
X'0A000000',X'69BDE000',X'477DDA65',X'5F600000',
X'47643AE7',X'4B980000',X'4D7E4000',X'5B4E79D3',
X'5D380000',X'7829C200',X'7829C266',X'4394A000',
X'497CB980',X'652E3AD3',X'65280000',X'67AC59C7',
X'654E1A66',X'697DE000',X'4D2EE000',X'6195FB53',
X'492C8000',X'5B0DDC80',X'439650F2',X'031E9AC3',
X'58000000',X'610E50DB',X'4BA4B900',X'477DD359',
X'531E9980',X'6F4E9400',X'43700000',X'137692CF',
X'4B900000',X'5F84B943',X'697E4000',X'252C3600',
X'5F84B943',X'5D266000',X'537692CF',X'4B900000',
X'477DDA4B',X'71A00000',X'6D0D94C8',X'782AC29D',
X'28000000',X'5DADB14B',X'64000000',X'657EBA53',
X'5D280000',X'45AE8000',X'5D780000',X'457C9C80',
X'7832A707',X'2849E700',X'7890AA2B',X'24700000',
X'5FAE9BD3',X'69400000',X'7890A9AB',X'18A00000',
X'5B0E0000',X'297DE000',X'592ED2D9',X'66000000',
X'039650F2',X'494DB2DD',X'674DF766',X'6B8612E4',
X'457EB748',X'592E7980',X'597EF2E4',X'274F5280',
X'30F0C30D',X'0C30CF00',X'45CE92E6',X'092C7643',
X'650E94DF',X'5C000000',X'512C3200',X'077DD9E9',
X'43768000',X'470DD75F',X'68000000',X'45280000',
X'4BB4366B',X'43A4B200',X'477DB853',X'59280000',
X'5376D0D9',X'53200000',X'652E12E9',X'53A537DC',
X'4D0C7A5F',X'64000000',X'7819E727',X'2809CA00',
X'1376D0D9',X'53200000',X'477DD9E9',X'43768000',
X'53753A53',X'436539D3',X'5D380000',X'433692E4',
X'53A4B6E6',X'4BC612C7',X'692C8000',X'7BE80000',
X'4F4ED2DC',X'782B0A0B',X'24702600',X'782B0A25',
X'12726486',X'6D0E54C3',X'4564A000',X'789A0286',
X'7829898A',X'7879C000',X'03A692DB',X'61A00000',
X'69780000',X'53753A53',X'436539CA',X'7831E91B',
X'02A00000',X'27AC59C7',X'654E1A00',X'6944A000',
X'457EB749',X'66000000',X'78312713',X'26400000',
X'53767A4B',X'43200000',X'789A80A5',X'28000000',
X'782B04A8',X'7819E729',X'1272A280',X'782B0A0B',
X'24702625',X'1EAA849D',X'0A000000',X'6F95F74E',
X'0BC4B1EB',X'690C564A',X'67A43A4B',X'5B2DDA00',
X'4D7EB748',X'752E5780',X'2195F3E5',X'43680000',
X'436DF74E',X'4BC692E5',X'5D0D8000',X'657EBA53',
X'5D2E6000',X'6B9CB200',X'7890A19F',X'24200000',
X'592DD3E9',X'50000000',X'4F94B0E9',X'4B900000',
X'652E3AD3',X'652E6000',X'67AC5743',X'5B280000',
X'27AC5743',X'5B280000',X'0BC6194B',X'679D37DC',
X'439E74CF',X'5D2C8000',X'652C77E5',X'48000000',
X'252C77E5',X'49980000',X'36D80000',X'43748000',
X'510ED280',X'494CD34B',X'652DDA00',X'4D7E56C3',
X'69980000',X'43A690C7',X'512C8000',X'6F4531D0',
X'27A654DD',X'4E000000',X'492C7643',X'650E94DF',
X'5C000000',X'5B0F0000',X'03953A51',X'5B2E94C6',
X'252E77D9',X'6BA537DC',X'477E594B',X'47A00000',
X'4D7E56C3',X'68000000',X'477DDA43',X'53766000',
X'67AC4000',X'43953A51',X'5B2E94C6',X'3DDBC000',
X'217D3769',X'4B900000',X'477DB843',X'652C8000',
X'4B8EB4ED',X'4364B747',X'4B200000',X'617D3769',
X'4B900000',X'4B8EB4ED',X'4364B768',X'0F65F143',
X'58000000',X'597C70D8',X'2B769CE1',X'4B200000',
X'7831E900',X'47643AE7',X'4A000000',X'67A4B800',
X'5D7DD4DD',X'692CF2E4',X'69943B4B',X'659CB980',
X'43980000',X'439E72DB',X'4564B900',X'1F84B943',
X'5D200000',X'039E72DB',X'4564B900',X'477DD9E9',
X'65AC7A53',X'5F700000',X'277EB947',X'4A000000',
X'477DDA53',X'5DAC3A53',X'5F766000',X'2F7E55CD',
X'5364A000',X'17173A4B',X'66000000',X'676C3658',
X'094C7A53',X'5F743972',X'477DB859',X'4BA4B672',
X'4DAD9600',X'597DD380',X'077DB853',X'592E4000',
X'690C564B',X'66000000',X'077DD253',X'694DF700',
X'477DB859',X'531C3A4B',X'48000000',X'537477DD',
X'674E7A4B',X'5DA00000',X'13761AE8',X'4B7492C8',
X'197DD380',X'537692CF',X'4B966000',X'5374B34D',
X'531D32DD',X'68000000',X'4324994B',X'679C3159',
X'4A000000',X'272DB4C7',X'5F65F700',X'477DB6CB',
X'5DA00000',X'692F1A00',X'53753A53',X'436539CB',
X'48000000',X'2B76195F',X'49AC7A53',X'6D280000',
X'597CF4C7',X'43600000',X'5F84B943',X'694DF700',
X'5D7E92C8',X'789907A5',X'28000000',X'43B434D9',
X'43159280',X'38000000',X'7849CA0B',X'0E2A4000',
X'67AC59E9',X'53A6BA4B',X'48000000',X'077DDA43',
X'47A00000',X'0326D4E7',X'5F972000',X'272E5B53',
X'47280000'
INTEGER I,J,K,M,Q,S
STRING (70)OMESS
OMESS=" "
CYCLE I=1,1,WORDMAX-1
->FOUND IF N=WORD(I)
REPEAT
I=DEFAULT
FOUND:
J=1
CYCLE
K=WORD(I+J)
IF K&X'8000'=0 THEN EXIT
K=K&X'7FFF'
OMESS=OMESS." " UNLESS J=1
UNTIL M&1=0 CYCLE
M=LETT(K); S=25
UNTIL S<0 CYCLE
Q=M>>S&63;
IF Q¬=0 THEN OMESS=OMESS.TOSTRING(OUTTT(Q))
S=S-6
REPEAT
K=K+1
REPEAT
J=J+1
REPEAT
RESULT =OMESS
END
STRING (16)FN SWRITE(INTEGER VALUE, PLACES)
STRING (16) S
INTEGER D0, D1, D2, D3, L, AD
PLACES=PLACES&15
AD=ADDR(S)
*LSS_VALUE; *CDEC_0
*LDA_AD; *LDTB_X'18000011'; *INCA_1; *STD_TOS
*CPB_B ; ! SET CC=0
*SUPK_L =15,0,32; ! UNPACK & SPACE FILL
*STD_D2; *JCC_8,<WASZERO>
*LD_TOS ; *STD_D0; ! FOR SIGN INSERTION
*LD_TOS
*MVL_L =15,63,0; ! FORCE ISO ZONE CODES
IF VALUE<0 THEN BYTEINTEGER(D1)='-'
L=D3-D1
OUT: IF PLACES>=L THEN L=PLACES+1
D3=D3-L-1
BYTEINTEGER(D3)=L
RESULT =STRING(D3)
WASZERO:
BYTEINTEGER(D3-1)='0'
L=2; ->OUT
END
ROUTINE FAULT(INTEGER N, DATA, IDENT)
!***********************************************************************
!* SETS UP AN ERROR MESSAGE AND SHOVES IT OUT ONTO THE LISTING *
!* AN ALSO OPTIONALLY TO THE TERMINAL *
!***********************************************************************
INTEGER I, J, T
STRING (255)MESS1,MESS2,WK1,WK2
!*DELSTART
MONITOR IF FAULTY<=2 AND (SMAP#0 OR DCOMP#0)
!*DELEND
MESS1=""; MESS2=""
FAULTY=FAULTY+1
IF N=100 THEN START ; ! SYNTAX FAULTS ARE SPECIAL
MESS1="
* Failed to analyse line ".SWRITE(LINE,2)."
"
IF LINE#OLDLINE THEN MESS1=MESS1.C
"Text mode failure - erroneous source line not available
" ELSE START
J=0; S=0; T=0
UNTIL (J=';' AND Q>QMAX) OR Q=LENGTH CYCLE
I=J; J=BYTEINTEGER(DATA+Q);! DATA HAS ADDR(CC(0))
IF J>128 AND I<128 THEN MESS2=MESS2." %" AND T=T+2
IF I>128 AND J<128 THEN MESS2=MESS2." " AND T=T+1
MESS2=MESS2.TOSTRING(J)
T=T+1
IF Q=QMAX THEN S=T
Q=Q+1
EXIT IF T>=250
REPEAT
IF Q=QMAX THEN S=T
FINISH
FINISH ELSE START
MESS1="
*".SWRITE(LINE, 4)." "
PARMOPT=1
INHCODE=1 IF PARMLET=0; ! STOP GENERATING CODE
MESS1=MESS1."FAULT".SWRITE(N,2)
MESS2=MESSAGE(N)
IF MESS2->WK1.("##").WK2 THEN C
MESS2=WK1.SWRITE(IDENT,1).WK2
IF MESS2->WK1.("#").WK2 THEN C
MESS2=WK1.SWRITE(DATA,1).WK2
IF MESS2->WK1.("&&").WK2 THEN C
MESS2=WK1.PRINTNAME(DATA).WK2
IF MESS2->WK1.("&").WK2 THEN C
MESS2=WK1.PRINTNAME(IDENT).WK2
IF N>100 THEN MESS2=MESS2." Disaster"
FINISH
CYCLE I=2,-1,1
SELECT OUTPUT(TTOPUT) IF I=1
PRINTSTRING(MESS1)
PRINTSTRING(MESS2) IF MESS2#""
IF N=100 AND S<115 THEN START
NEWLINE; SPACES(S+4); PRINTSYMBOL('!')
FINISH
NEWLINE
SELECT OUTPUT(82) IF I=1
EXIT IF TTOPUT<=0
REPEAT
IF N>100 THEN STOP
END
ROUTINE WARN(INTEGER N,V)
STRING (30) T; STRING (120) S
S=MESSAGE(N+200)
IF S->S.("&").T THEN S=S.PRINTNAME(V).T
PRINTSTRING("
? Warning :- ".S." at line No".SWRITE(LINE,1))
NEWLINE
END
! THE NEXT 4 ROUTINES CAN BE
!MACROISED USING MVC
!
ROUTINE TOAR2(INTEGER PTR,VALUE)
IF USE IMP=YES THEN START
A(PTR+1)<-VALUE
A(PTR)<-VALUE>>8
FINISH ELSE START
*LSS_VALUE
*LDTB_X'58000002'
*LDA_A+4
*INCA_PTR
*ST_(DR )
FINISH
END
ROUTINE TOAR4(INTEGER PTR, VALUE)
IF USE IMP=YES THEN START
INTEGER I
CYCLE I=0,1,3
A(PTR+I)=BYTE INTEGER(ADDR(VALUE)+I)
REPEAT
FINISH ELSE START
*LSS_VALUE
*LDTB_X'58000004'
*LDA_A+4
*INCA_PTR
*ST_(DR )
FINISH
END
ROUTINE TOAR8(INTEGER PTR, LONGREAL VALUE)
IF USE IMP=YES THEN START
INTEGER I
CYCLE I=0,1,7
A(PTR+I)=BYTE INTEGER(ADDR(VALUE)+I)
REPEAT
FINISH ELSE START
*LSD_VALUE
*LDTB_X'58000008'
*LDA_A+4
*INCA_PTR
*ST_(DR )
FINISH
END
INTEGERFN FROMAR2(INTEGER PTR)
IF USE IMP=YES THEN RESULT =A(PTR)<<8!A(PTR+1) ELSE START
*LDTB_X'58000002'
*LDA_A+4
*INCA_PTR
*LSS_(DR )
*EXIT_-64
FINISH
END
INTEGERFN FROMAR4(INTEGER PTR)
IF USE IMP=YES THEN START
RESULT =A(PTR)<<24!A(PTR+1)<<16!A(PTR+2)<<8!A(PTR+3)
FINISH ELSE START
*LDTB_X'58000004'
*LDA_A+4
*INCA_PTR
*LSS_(DR )
*EXIT_-64
FINISH
END
STRINGFN PRINTNAME(INTEGER N)
INTEGER V, K
STRING (255)S
S="???"
IF 0<=N<=NNAMES START
V=WORD(N)
K=BYTE INTEGER(DICTBASE+V)
IF K#0 THEN S=STRING(DICTBASE+V)
FINISH
RESULT =S
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
PRINTSTRING("
PRINT OF LIST ")
WRITE(HEAD,2)
NEWLINE
WHILE HEAD#0 CYCLE
FROM123(HEAD,I,J,K)
WRITE(HEAD,3)
SPACES(3)
PRHEX(I,8)
SPACES(3)
PRHEX(J,8)
SPACES(3)
PRHEX(K,8)
NEWLINE
MLINK(HEAD)
HEAD=HEAD&X'FFFF'; ! EXTRA LINK IN TAGS LIST!!
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,CL,AMOUNT
N=ASL CUR BTM-1
AMOUNT=(NNAMES+1)>>3; ! EIGHTTH OF NNAMES
I=ASL CUR BTM-((CONST PTR+8)>>2);! GAP BETWEEN CONSTS &ASL
IF I>>1<AMOUNT THEN AMOUNT=I>>1 AND ASL WARN=1;! HALF THE GAP MAX
IF AMOUNT<20 THEN AMOUNT=0
ASL CUR BTM=ASL CUR BTM-AMOUNT
IF ASL CUR BTM<=1 THEN ASL CUR BTM=1
CL=4*ASL CUR BTM-8
IF ASL CUR BTM>=N OR CONST PTR>CL THEN START
ASL CUR BTM=N+1; ! AS YOU WERE
CYCLE I=12,-1,1
IF DVHEADS(I)#0 THEN CLEAR LIST(DVHEADS(I))
REPEAT
IF ASL#0 THEN RESULT =ASL
FAULT(102, WKFILEK,0)
FINISH ELSE CONST LIMIT=CL; ! NEW VALUE WITH BIGGER ASL
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. *
!***********************************************************************
IF USEIMP=YES THEN START
RECORD (LISTF)NAME LCELL
FINISH
INTEGER I
I=ASL
IF I=0 THEN I=MORE SPACE
IF USE IMP=YES THEN START
LCELL==ASLIST(I)
ASL=LCELL_LINK
LCELL_LINK=CELL
CELL=I
LCELL_S1=S1
LCELL_S2=S2
LCELL_S3=S3
FINISH ELSE START
*LB_I
*MYB_16
*ADB_ASLIST+4
*LCT_B
*LSS_(CTB +3)
*ST_ASL
*LB_I
*LSS_(CELL)
*STB_(DR )
*LUH_S3
*LUH_S1
*ST_(CTB +0)
FINISH
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*
!***********************************************************************
INTEGER I
IF USE IMP=YES THEN START
RECORD (LISTF)NAME LCELL
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
FINISH ELSE START
*LB_(CELL)
*STB_I
*MYB_16
*ADB_ASLIST+4
*LCT_B
*LSD_(CTB +0)
*STUH_(S1)
*LB_I
*ST_(S2)
*LSD_(CTB +2)
*STUH_(S3)
*JAT_12,<END>
*ST_(CELL)
*LSS_ASL
*ST_(CTB +3)
*STB_ASL
END:
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,J
RECORD (LISTF)NAME LCELL
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
RECORD (LISTF)NAME LCELL
I=CELL; J=I
WHILE I#0 CYCLE
J=I
I=ASLIST(J)_LINK
REPEAT
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
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. *
!***********************************************************************
RECORD (LISTF)NAME LCELL
LCELL==ASLIST(CELL)
S1=LCELL_S1
S2=LCELL_S2
S3=LCELL_S3
END
ROUTINE FROM12(INTEGER CELL, INTEGERNAME S1, S2)
RECORD (LISTF)NAME LCELL
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 CYCLE
J=I
I=ASLIST(J)_LINK
REPEAT
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