! Currently throwing a syntax error if more than one %OWN variable declared in one statement
CONTROL X'10000000' ; ! Decode
! There are two places where errors are generated when compiling the clean source of this
! compiler. Since it should probably be expected to be able to compile itself, these errors
! are almost certainly bogus and a result of some difference in the sparc compiler used to
! compile this. I have commented out those two error reports (look for '{' and 'erroneous')
! and when that is done the source does compile and the output looks plausible.
! I've supplied a recode and an lput which were missing from the allimpc1 source, and modified
! lput to output all the generated code and data, not just the code that recode outputs.
! Successive runs with no source changes produce *slightly* different output in the 'D' psect.
! This is either due to something time-related, or more likely, an unassigned variable.
! (It's not time-related as this code doesn't access CPU TIME, TIME, or DATE functions)
! Using the sparc compiler solves the problems that arose using other Imp77 compilers
! on little-endian machines like the Vax and X86. Also the x86 compilers do not
! support both 32 bit integers and 16 bit integers.
! The Imp to C translator *ought* to be able to compile and run this if the
! mips C compiler is used as it too is big-endian. Mips code runs under emulation
! on the X86 linux transparently.
! Note the compile-time warnings, Warning: value truncated to 16 bits signed at line 215
! - this is because %SHORTINTEGER is a signed 16 bit quantity but some of the data
! in the tables is initialised with *unsigned* 16 bit data in excess of 32767. These
! constants could be replaced in the source with the negative literal values that
! would allow the source to compile without warnings. This has not yet been done.
BEGIN
constinteger debug=0
owninteger com2 = 20000 ; ! free memory size?
owninteger com24 = 0 ; ! exit code I think
integerfn com(integer idx)
if idx=24 then result = com24
if idx=2 then result = com2
stop
end
routine setcom(integer idx, val)
if idx=24 then com24=val and return
if idx=2 then com2 =val and return
stop
end
routine set short integer(integer address, short value)
short integer(address) = value
end
INTEGER I,J,K,SS
OWNBYTEINTEGERARRAY CLETT(1: 425)= 1,
43, 1, 45, 1, 92, 1, 40, 1, 41, 1, 33, 1, 44, 2,
42, 42, 2, 33, 33, 1, 42, 2, 47, 47, 1, 47, 1, 38,
2, 62, 62, 2, 60, 60, 1, 46, 1, 63, 2, 201, 198, 6,
213, 206, 204, 197, 211, 211, 7, 201, 206, 212, 197, 199, 197, 210,
4, 210, 197, 193, 204, 4, 194, 217, 212, 197, 5, 211, 200, 207,
210, 212, 4, 204, 207, 206, 199, 6, 211, 212, 210, 201, 206, 199,
7, 210, 207, 213, 212, 201, 206, 197, 2, 198, 206, 3, 205, 193,
208, 4, 206, 193, 205, 197, 6, 210, 197, 195, 207, 210, 196, 4,
211, 212, 207, 208, 7, 195, 207, 205, 208, 201, 204, 197, 6, 201,
199, 206, 207, 210, 197, 2, 207, 206, 3, 207, 198, 198, 5, 193,
210, 210, 193, 217, 3, 193, 206, 196, 2, 207, 210, 2, 61, 61,
1, 61, 2, 60, 45, 2, 45, 62, 4, 211, 208, 197, 195, 6,
206, 207, 210, 205, 193, 204, 6, 214, 197, 195, 212, 207, 210, 1,
58, 2, 62, 61, 1, 62, 1, 35, 2, 60, 61, 1, 60, 2,
92, 61, 4, 197, 204, 211, 197, 1, 95, 6, 211, 217, 211, 212,
197, 205, 8, 197, 216, 212, 197, 210, 206, 193, 204, 5, 195, 204,
193, 201, 205, 7, 210, 197, 204, 197, 193, 211, 197, 1, 80, 3,
80, 85, 84, 1, 64, 9, 208, 210, 201, 206, 212, 212, 197, 216,
212, 6, 210, 197, 212, 213, 210, 206, 7, 210, 197, 211, 213, 204,
212, 61, 7, 205, 207, 206, 201, 212, 207, 210, 5, 211, 212, 193,
210, 212, 7, 209, 213, 197, 210, 201, 197, 211, 5, 195, 217, 195,
204, 197, 6, 210, 197, 208, 197, 193, 212, 4, 212, 200, 197, 206,
3, 197, 206, 196, 7, 195, 207, 205, 205, 197, 206, 212, 5, 210,
197, 193, 204, 211, 5, 194, 197, 199, 201, 206, 2, 207, 198, 7,
208, 210, 207, 199, 210, 193, 205, 6, 211, 215, 201, 212, 195, 200,
8, 210, 197, 199, 201, 211, 212, 197, 210, 3, 207, 215, 206, 5,
205, 195, 207, 196, 197, 5, 198, 193, 213, 204, 212, 4, 198, 201,
204, 197, 6, 196, 197, 198, 201, 206, 197, 1, 210, 7, 211, 208,
197, 195, 201, 193, 204, 4, 204, 201, 211, 212, 7, 195, 207, 206,
212, 210, 207, 204, 6, 198, 201, 206, 201, 211, 200, 6, 198, 207,
210, 205, 193, 212;
OWNSHORTINTEGERARRAY SYMBOL(1300: 2148)= 1309,
1303, 1, 1305, 3, 1307, 5, 1309, 1000, 1316, 1312,
1, 1314, 3, 1316, 1000, 1335, 1321, 1001, 1342, 1706,
1323, 1003, 1329, 7, 1300, 1316, 1335, 9, 1335, 11,
1300, 1316, 1335, 11, 1342, 1340, 1361, 1316, 1335, 1342,
1000, 1352, 1350, 7, 1300, 1316, 1335, 1352, 9, 1352,
1000, 1361, 1359, 13, 1300, 1316, 1335, 1352, 1361, 1000,
1388, 1364, 15, 1366, 1, 1368, 3, 1370, 18, 1372,
11, 1374, 21, 1376, 23, 1378, 26, 1380, 28, 1382,
30, 1384, 33, 1386, 36, 1388, 1000, 1393, 1391, 38,
1393, 1000, 1398, 1396, 13, 1398, 1000, 1403, 1401, 40,
1403, 43, 1420, 1406, 50, 1408, 58, 1411, 63, 50,
1414, 68, 50, 1417, 74, 58, 1420, 79, 1883, 1426,
1423, 86, 1426, 1403, 1426, 1431, 1429, 94, 1431, 97,
1445, 1435, 1420, 1467, 1438, 1403, 1472, 1441, 1462, 101,
1445, 106, 1462, 101, 1450, 1448, 1005, 1450, 1001, 1457,
1453, 113, 1455, 118, 1457, 126, 1462, 1460, 133, 1462,
136, 1467, 1465, 140, 1467, 1000, 1472, 1470, 101, 1472,
1000, 1484, 1477, 101, 140, 101, 1480, 140, 101, 1482,
101, 1484, 1000, 1493, 1491, 7, 1431, 1009, 1493, 9,
1493, 1000, 1501, 1499, 1393, 1431, 1009, 1493, 1501, 1000,
1520, 1513, 1010, 1300, 1316, 1335, 1669, 1300, 1316, 1335,
1520, 1011, 1520, 7, 1010, 1501, 1528, 1011, 9, 1528,
1526, 1669, 1300, 1316, 1335, 1528, 1000, 1539, 1533, 146,
1501, 1539, 1537, 150, 1501, 1546, 1539, 1000, 1546, 1544,
146, 1501, 1539, 1546, 1000, 1553, 1551, 150, 1501, 1546,
1553, 1000, 1562, 1560, 1562, 1300, 1316, 1335, 1388, 1562,
1000, 1571, 1565, 153, 1567, 156, 1569, 158, 1571, 161,
1576, 1574, 164, 1576, 1000, 1581, 1579, 74, 1581, 169,
1588, 1586, 13, 1714, 1581, 1588, 1000, 1599, 1592, 1472,
1009, 1596, 1467, 140, 1599, 1599, 176, 1613, 1607, 1607,
1009, 7, 1714, 1581, 9, 1607, 1613, 1611, 13, 1599,
1613, 1000, 1618, 1618, 1009, 1635, 1618, 1624, 1622, 13,
1613, 1624, 1000, 1635, 1629, 1001, 1723, 1006, 1635, 140,
1001, 1635, 1890, 1004, 1644, 1644, 7, 1309, 1003, 183,
1309, 1003, 9, 1651, 1649, 13, 1005, 1644, 1651, 1000,
1661, 1659, 13, 1005, 1644, 161, 1445, 1651, 1661, 1000,
1669, 1667, 13, 1009, 1635, 1661, 1669, 1000, 1686, 1672,
156, 1674, 185, 1676, 188, 1678, 190, 1680, 192, 1682,
195, 1684, 197, 1686, 161, 1694, 1689, 1006, 1694, 1398,
1501, 1528, 1006, 1700, 1698, 200, 1902, 1700, 1000, 1706,
1704, 205, 1001, 1706, 1000, 1714, 1712, 205, 1001, 1342,
1706, 1714, 1000, 1723, 1723, 1300, 1316, 1335, 183, 1300,
1316, 1335, 1730, 1728, 156, 1300, 1003, 1730, 1000, 1737,
1733, 207, 1735, 214, 1737, 1000, 1742, 1740, 223, 1742,
229, 1747, 1745, 140, 1747, 106, 1757, 1755, 1393, 1403,
1467, 140, 1599, 1747, 1757, 1000, 1764, 1762, 1431, 1009,
1493, 1764, 1000, 1772, 1768, 1001, 1857, 1772, 195, 1445,
188, 1785, 1780, 1005, 7, 1005, 13, 1005, 9, 1785,
1764, 7, 1005, 9, 1792, 1789, 1764, 1883, 1792, 1005,
1792, 1805, 1799, 7, 1005, 13, 1005, 9, 1803, 7,
1005, 9, 1805, 1000, 1811, 1809, 13, 1003, 1811, 1000,
1817, 1814, 1764, 1817, 1005, 1883, 1857, 1823, 1012, 1005,
13, 1005, 1828, 1013, 1005, 13, 1785, 1835, 1014, 1005,
13, 1005, 13, 1811, 1839, 1015, 1811, 1805, 1844, 1016,
1005, 13, 1811, 1849, 1017, 1772, 13, 1811, 1854, 1018,
1772, 13, 1772, 1857, 1019, 1005, 1863, 1861, 1, 1005,
1863, 1000, 1883, 1872, 21, 1005, 13, 1895, 1001, 1342,
1706, 1876, 161, 237, 1005, 1879, 1002, 1817, 1883, 239,
205, 1003, 1890, 1888, 7, 1005, 9, 1890, 1000, 1895,
1893, 156, 1895, 1000, 1902, 1898, 243, 1900, 156, 1902,
1000, 1943, 1910, 1010, 1001, 1342, 1706, 1011, 1553, 1918,
161, 1001, 7, 1300, 1316, 1335, 9, 1921, 161, 1445,
1924, 245, 1008, 1926, 255, 1931, 262, 1300, 1316, 1335,
1933, 113, 1936, 270, 113, 1938, 278, 1940, 270, 1943,
284, 1457, 2149, 1949, 1010, 1902, 1011, 1686, 1967, 292,
1001, 1342, 1706, 156, 1300, 1316, 1335, 13, 1300, 1316,
1335, 13, 1300, 1316, 1335, 1006, 1970, 298, 1006, 1973,
1445, 183, 1985, 1398, 1010, 1501, 1528, 305, 1011, 1010,
1902, 1011, 1694, 1006, 1988, 11, 1007, 1992, 1403, 1588,
1006, 1995, 310, 1006, 2004, 1010, 1730, 1420, 1011, 1571,
1001, 1484, 1006, 2007, 314, 1007, 2011, 322, 1576, 1006,
2014, 328, 1006, 2019, 310, 334, 337, 1006, 2026, 1001,
7, 1309, 1003, 9, 183, 2032, 345, 1009, 1635, 1661,
1006, 2036, 1450, 284, 1006, 2040, 352, 1001, 1006, 2044,
361, 1403, 1624, 2050, 1737, 1742, 352, 1001, 1006, 2053,
365, 1006, 2057, 68, 86, 1006, 2061, 21, 1863, 1006,
2069, 371, 1005, 1644, 161, 1445, 1651, 1006, 2074, 310,
334, 377, 1006, 2079, 310, 334, 365, 1006, 2084, 382,
118, 389, 1006, 2090, 164, 1001, 1706, 1484, 1006, 2095,
391, 101, 1001, 1006, 2098, 399, 1006, 2103, 310, 334,
399, 1006, 2107, 404, 1003, 1006, 2111, 412, 1694, 1006,
2120, 106, 419, 1001, 7, 1757, 1747, 9, 1006, 2129,
106, 1010, 1588, 1011, 7, 1001, 9, 1006, 2136, 1010,
1420, 101, 1011, 1009, 1006, 2147, 106, 164, 1010, 1001,
1700, 1011, 7, 1001, 9, 1006, 2149, 1006;
SS= 1943
OWNBYTEINTEGERARRAY OPC(0:120)=0,
8,9,X'10',X'11',X'12',
X'13',X'20',X'21',X'22',X'23',
X'30',X'31',X'32',X'33',X'24',
X'34',0,X'45',X'46',X'47',
X'54',X'55',X'56',X'57',X'58',X'59',X'5A',X'5B',X'5C',
X'5D',X'5E',X'5F',X'68',X'69',X'6A',
X'6B',X'6C',X'6D',X'6E',X'6F',
X'78',X'79',X'7A',X'7B',X'7C',
X'7D',X'7E',X'7F',0,X'70',
X'60',X'50',X'4E',X'4F',X'4C',
X'4B',X'4A',X'49',X'48',X'44',
X'43',X'42',X'41',X'40',0,
X'90',X'98',X'86',X'87',0,
X'91',X'92',X'94',X'95',X'96',
X'97',X'9C',X'9E',X'9D',X'9F',
X'82',X'84',X'85',0,X'88',
X'89',X'8A',X'8B',X'8C',X'8D',
X'8E',X'8F',0,X'D0',X'D1',
X'D2',X'D4',X'D5',X'D6',X'D7',
X'D8',X'DC',X'DD',X'DE',X'DF',
X'D3',0,X'F1',X'F2',X'F3',
X'F8',X'F9',X'FA',X'FB',X'FC',
X'FD',0,10,4,X'80';
OWNINTEGERARRAY NEM(0:120)=M'CNOP',
M'ISK',M'SSK',M'LP',M'LN',M'LT',
M'LC',M'LPD',M'LND',M'LTD',M'LCD',
M'LPE',M'LNE',M'LTE',M'LCE',M'HD',
M'HE',0,M'BAL',M'BCT',M'BC',
'N',M'CL','O','X','L','C','A','S','M','D',
M'AL',M'SL',M'LD',M'CD',M'AD',
M'SD',M'MD',M'DD',M'AW',M'SW',
M'LE',M'CE',M'AE',M'SE',M'ME',
M'DE',M'AU',M'SU',0,M'STE',
M'STD',M'ST',M'CVD',M'CVB',M'MH',
M'SH',M'AH',M'CH',M'LH',M'EX',
M'IC',M'STC',M'LA',M'STH',0,
M'STM',M'LM',M'BXH',M'BXLE',0,
M'TM',M'MVI',M'NI',M'CLI',M'OI',
M'XI',M'SDV',M'HDV',M'TDV',M'CKC',
M'PC',M'WRD',M'RDD',0,M'SRL',
M'SLL',M'SRA',M'SLA',M'SRDL',M'SLDL',
M'SRDA',M'SLDA',0,M'SSP',M'MVN',
M'MVC',M'NC',M'CLC',M'OC',M'XC',
M'LSP',M'TR',M'TRT',M'ED',M'EDMK',
M'MVZ',0,M'MVO',M'PACK',M'UNPK',
M'ZAP',M'CP',M'AP',M'SP',M'MP',
M'DP',0,M'SVC',M'SPM',M'IDL';
OWNSHORTINTEGERARRAY CLODS(0:88)= C
4,X'50CD',X'001C',X'58CD',X'5C',
4,X'50FB',X'003C',X'45FC',X'4C',
6,X'5820',X'2000',X'0620',
X'8920',24,X'1602',0,
8,X'50B0',0,X'4AB0',X'4002',
X'41BB',X'7',X'54BD',84,
4,X'581D',36,X'9200',X'1001',
11,X'0510',X'2826',X'6E6D',X'48',
X'6A6D',X'28',X'2B26',X'47B0',
X'1014',X'6A2D',X'30',
4, X'9003',X'B000',X'41BB',X'10',
5, X'4100',0,X'58EC',186,X'5FE',
5, X'904E',X'B010',X'98CE',
X'D000',X'5FE',
7, X'904E',X'B010',X'98CF',0,
X'9859',X'F014',X'5FE',
5,X'4100',255,X'8900',X'18',X'1610',
6,X'4100',4,X'59BD',X'44',
X'4720',X'C054',
6,X'6000',X'B040',X'4100',12,X'5000',X'B048'
OWNBYTEINTEGERARRAY TSNAME (0:50)=0(8),
1,0(5),1,26,1,1,26,0(2),2,1,26(8),
3,9,17,26(2),1,0,1,26,0(2),5,0(8)
NEWLINES(3); SPACES(30)
print string("E.R.C.C. IMP(SYS1) COMPILER ")
print string(" RELEASE 5 ALL-IMP VERSION")
print string(" DATED 1/5/70")
NEWLINES(3)
OWNBYTEINTEGERARRAY BYTES(0:3)=4,1,2,8;
OWNBYTEINTEGERARRAY PRECEDENCE (1:12)=0,3,3,3,3,4,4,4,4,5,5,5;
OWNBYTEINTEGERARRAY TYPEFLAG(1:6)=1,2,
B'1001',B'10001',B'11010',5;
OWNINTEGER MASK1=X'0F0F0F0F'
OWNINTEGER MASK2=X'0F0F0F0F'
OWNSHORTINTEGER MAXLEVELS=11
OWNINTEGER CODER=12
OWNINTEGER LINK =15
OWNINTEGER WSPR =11
OWNINTEGER GLA =13
SHORTINTEGER CCSIZE,ARSIZE,DSIZE,NROUTS
ROUTINESPEC SIZES
INTEGER ASL,NNAMES
INTEGER CABUF,PPCURR,QPREAL,OLDLINE
INTEGER LINE,LENGTH,LENGTHP,N0,NUM,SNUM
INTEGER RLEVEL,NMAX,OWNLINK,CONSTPTR
INTEGER PLABEL,LEVEL,CA,MARKER1,MARKER2,LABSET
INTEGER R13,RP13,SIGFIGS
BYTEINTEGER AFLAG,FFLAG,CHECKS,SBFLAG
BYTEINTEGER FAULTY,MONE,HIT,QU,PERM,MCSWITCH,LIST,ALLLONG
BYTEINTEGER LINENOS,DIAGS1,DIAGS2,CHECKSP
BYTEINTEGER CTYPE,DCOMP,COMPILER,CPRMODE
BYTEINTEGER UNASS,PRINTMAP
LONGREAL CVALUE,IMAX
INTEGER MASK,RBASE,SFLABEL
INTEGER NEXT,N,NR,ITEM,STRINST
INTEGER P,Q,R,S,T,U,V,NEST,FNAME
INTEGER XREFLINK,LDPTR
SHORTINTEGER NEPS,EPLINK
INTEGER SSTL,QMAX,STMTS
INTEGERARRAY REGISTER(0:15)
INTEGERARRAY ST(0:1300)
INTEGER ARRAY SET,CODEBASE,FREG,RAL(0:MAXLEVELS)
SHORTINTEGERARRAY CYCLE,JUMP,NAME,LABEL,FLAG,SBR,WSP,C
L,M,LWSP,MDARR,RNEXT,NMDECS,STRWSP(0:MAXLEVELS)
SHORTINTEGERARRAY CODE(0:192)
SHORTINTEGERARRAY PAGENOS(0:50)
INTEGERARRAY UVARREG(5:8)
SIZES
BYTEINTEGERARRAY CC(0:CCSIZE),ASLIST(0:ASL),LETT(0:DSIZE+20)
SHORTINTEGERARRAY RA(0:NROUTS),A(-2:ARSIZE)
SHORTINTEGERARRAY WORD,TAGS(0:NNAMES)
{%SYSTEMINTEGERFNSPEC COM(%INTEGER N)
{%SYSTEMROUTINESPEC SET COM(%INTEGER I,J)
{%SYSTEMROUTINESPEC IOCP(%INTEGER A,B)
ROUTINESPEC CNOP(INTEGER I,J)
ROUTINESPEC PCONST(INTEGER X)
ROUTINESPEC PSI(INTEGER OPCODE,J,BASE,DISP)
ROUTINESPEC PSS(INTEGER OPCODE,N,BASE,DISP,P,Q)
ROUTINESPEC PRX(INTEGER OPCODE,R1,R2,BASE,DISP)
ROUTINESPEC PACLOD(INTEGER PTR,AT,VALUE)
ROUTINESPEC PCLOD(INTEGER PTR)
ROUTINESPEC PLANT(INTEGER VALUE)
ROUTINESPEC PRR (INTEGER OPCODE,R1,R2)
EXTERNALROUTINESPEC LPUT(INTEGER A,B,C,D)
ROUTINESPEC PLUG(INTEGER J,K)
ROUTINESPEC PRHEX(INTEGER VALUE,PLACES)
ROUTINESPEC INITIALISE
ROUTINESPEC PSYM(INTEGER X)
ROUTINESPEC COMPARE
ROUTINESPEC PNAME
ROUTINESPEC CONST(BYTEINTEGER MODE)
ROUTINESPEC CONSTLIST
ROUTINESPEC TEXTTEXT
ROUTINESPEC FROMAR8(INTEGER PTR,LONGREALNAME VALUE)
ROUTINESPEC FROMAR4(INTEGER PTR,INTEGERNAME VALUE)
ROUTINESPEC TOAR8(INTEGER PTR,LONGREAL VALUE)
ROUTINESPEC TOAR4(INTEGER PTR,VALUE)
ROUTINESPEC CSS(INTEGER P)
ROUTINESPEC FAULT(BYTEINTEGER N)
ROUTINESPEC FINALISE
ROUTINESPEC PRINT NAME (INTEGER N)
! Using an alternative RECODE extracted from PSR's IMPI interpreter.
EXTERNALROUTINESPEC RECODE (INTEGER START,FINISH,CA)
ROUTINESPEC READ LINE(BYTEINTEGER N)
on event 9 {,18} start
if 0=0 {event_event = 9} {TEMP UNTIL RECORD FIELDS WORKING} then ->INEND
! %if event_event = 18 %then ->SUBSCHAR
! I need to find out which characters were being substituted!
! %signal %event event
finish
! START OF COMPILATION
INITIALISE
LPUT(0,1,1,ADDR(LETT(1)))
L8: READLINE(0); Q=1
L5: R=1; P=SS
OLDLINE=LINE; COMPARE
FAULT(102) IF R>ARSIZE
->L6 IF HIT=0
STMTS=STMTS+1
CSS(1)
IF DCOMP#0 AND CA>CABUF THEN START
RECODE(ADDR(CODE(0)),ADDR(CODE(PPCURR)),CABUF)
NEWLINE
LPUT(1,CA-CABUF,CABUF,ADDR(CODE(0)))
PPCURR=0; CABUF=CA; FINISH
->L7 IF A(1)=13; ! END OF PROGRAM
L9: ->L8 IF Q>=LENGTH ;->L5
L6: FAULT(100); ->L9
L7: !DEAL WITH END OF PROGRAM
FINALISE
SET COM(24,0) IF COMPILER =0 AND FAULTY=0
STOP
INEND: FAULT(108)
SUBSCHAR:LINE=LINE+1;FAULT(48)
SPACES(5)
L15: READSYMBOL(I); ->L8 IF I=10
PRINTSYMBOL(I); ->L15
ROUTINE FINALISE
N0=N0+1 IF N0&1#1
CNOP(0,8);ST(0)=X'20000'
ST(1)=X'10100000'
ST(4)=-1; ST(6)=255
ST(8)=OWNLINK
ST(12)=X'41100000'; ! D'1'
ST(14)=X'41200000'; ! D'2'
ST(18)=X'4E000000'; ! FOR IN LINE FLOATING
ST(20)=-4; ST(21)=-8
ST(22)=XREFLINK; XREFLINK=88
ST(26)=X'80000000'; ST(27)=X'06492350'; ST(28)=M'ERMA'
!! ^^^^^^^^^ ^^^^^^ WARNING! Big-endian issue?
ST(29)=X'904EB010'; ! ROUTINE ENTRY SUBROUTINE
ST(30)= X'5A10D01C'
ST(31)=X'07F10700'
ST(32)=X'80808080'
ST(33)=X'80808080'
ST(38)=X'80000000'; ST(39)=X'06532349'; ST(40)=M'OCP '
!! ^^^^^^^^^^^ ^^^^^^^ WARNING! More Big-endianness?
K=CA
LPUT(1,CA-CABUF,CABUF,ADDR(CODE(0))) UNLESS CA=CABUF
LPUT(2,N0<<2+4,0,ADDR(ST(0)));! GLA
FAULT(99) IF N0>1023
I=X'E2E2E2E2'
LPUT(4,4,SSTL,ADDR(I))
IF CONSTPTR&1#0 THEN PSYM(0)
->L129 IF FAULTY #0
NEWLINE; WRITE(STMTS,4)
print string(" STATEMENTS COMPILED SUCCESSFULLY")
L120: print string("
CODE OCCUPIES")
WRITE(K,3);print string(" BYTES GLAP")
WRITE(N0<<2,3); print string(" +")
WRITE(CONSTPTR<<2,1); print string(" BYTES DIAG TABLES")
WRITE(SSTL+4,4); print string(" BYTES TOTAL")
ST(0)=CA; ST(1)=N0<<2+4
ST(2)=(LDPTR<<2+7)&(-8); ST(3)=(SSTL+11)&(-8)
ST(4)=CONSTPTR<<2
ST(5)=CA+ST(1)+ST(2)+ST(3)+ST(4)
WRITE(ST(5),5); print string(" BYTES")
NEWLINE
NEWLINE
LPUT(7,24,0,ADDR(ST(0)))
RETURN
L129: print string("
PROGRAM CONTAINS"); WRITE(FAULTY,2); print string(" FAULTS"); ->L120
END
ROUTINE READ LINE(BYTEINTEGER N)
!%SHORTROUTINE
INTEGER DEL
BYTEINTEGER NP
COMMENT ABOUT 30 CPU TIME OF COMPILATION IS SPENT IN THIS
COMMENT ROUTINE AS WRITTEN. A HAND CODED VERSION USING I
COMMENT ISO CARD NOT READ SYMBOL IS USED IN PRODUCTION VRSN
Q=1; LINE=LINE+1
LENGTH=0; DEL=0
L1: ->START UNLESS N=0 AND NEXT SYMBOL=10; ! IGNORE EMPTY LINES
SKIP SYMBOL; ->L1; ! IN PROGRAM MODE ONLY
START: ->L2 IF LIST=0
WRITE(LINE,5)
PRINT SYMBOL('''') IF N#0
SPACES(4*LEVEL-N)
L2: READ SYMBOL(I)
PRINT SYMBOL(I) UNLESS LIST=0
->L4 UNLESS N=0
->L3 UNLESS I='%'
DEL=128; ->L2
L3: DEL=0 UNLESS 'A'<=I<='Z'
->L2 IF I=' '
L4: LENGTH=LENGTH+1
CC(LENGTH)=I!DEL
IF I='''' THEN N=1-N
->L2 UNLESS I=10
RETURN UNLESS CC(LENGTH-1)= 'C'+128
LENGTH=LENGTH-1
->L2 IF LIST=0
SPACES(5); PRINTSYMBOL('C'); SPACES(4*LEVEL); ->L2
END
ROUTINE FAULT(BYTEINTEGER N)
!%SHORTROUTINE
INTEGER I,J,QP
print string("
*"); WRITE(LINE,4); I=3; I=3*LEVEL IF LIST=0 ; SPACES(I)
FAULTY=FAULTY+1
->L9 IF N=100; print string("FAULT"); WRITE(N,2)
->L2 IF N<100; print string(" DISASTER ")
MONITOR ; STOP
L2: PRINTNAME(FNAME) UNLESS 7#N#16; ->L99
L9: print string(" SYNTAX ")
->L11 IF LINE#OLDLINE
QP=Q
CYCLE Q=Q,1,LENGTH-1
IF CC(Q)&128 # 0 THEN PRINTSYMBOL(CC(Q)&127-'A'+'a') ELSE PRINTSYMBOL(CC(Q))
->L10 IF CC(Q)=';'
REPEAT
L10: Q =Q+1
->L99 IF I+20+Q-QP>120
NEWLINE; SPACES(I+QMAX-QP+17)
PRINTSYMBOL('!')
NEWLINE
->L99
L11: print string("
TEXT MODE FAILURE "); WRITE(LINE-OLDLINE,1)
print string(" LINES LOST ")
NEWLINE; Q=QMAX
L99: NEWLINE; END
ROUTINE COMPARE
!%SHORTROUTINE
INTEGER RA,RP,RQ,RR,RS,MARKER
SWITCH BIP(1000:1019)
RP=SYMBOL(P)
RQ=Q; RR=R; ! RESET VALUES OF LINE&AR PTRS
A(R)=1; ! FIRST ALTERNATIVE TO BE TRIED
P=P+1; RA=SYMBOL(P); RS=P; ! RA TO NEXT PHRASE ALTERNATIVE
COMMENT ROUTINE REALLY STARTS HERE
L1: R=R+1
BIP(1000):L2: ! SUCCESS ON TO NEXT ITEM
RS=RS+1; ->L8 IF RS=RA; ! RS=NEXT ALTERNATIVE MEANS THAT
! THIS ALT HAS BEEN COMPLETED SO
! EXIT WITH HIT=1
ITEM=SYMBOL(RS); ! NEXT BRICK IN THE CURRENT ALT
->L4 IF ITEM>=1300; ! BRICK IS A PHRASE TYPE
->L6 IF ITEM>=1000; ! BRICK IS BUILT IN PHRASE
CYCLE J=1,1,CLETT(ITEM); ! BRICK IS LITERAL
->L3 UNLESS CC(Q)=CLETT(J+ITEM)
Q=Q+1; REPEAT; !CHECK IT WITH LITERAL DICT ENTRY
->L2; ! MATCHED SUCCESSFULLY
L4: ! PHRASE TYPE ALTERNATE
P=ITEM; COMPARE; ! RCALL COMPARE TO RECOGNISE IT
->L2 IF HIT#0; ! FOUND
L3: QMAX=Q IF Q>QMAX; ! FAILURE - NOTE POSITION REACHD
Q=RQ; R=RR; ! RESET LINE AND A.R. POINTERS
->L7 IF RA=RP; !TOTAL FAILURE NO ALT LEFT TO TRY
RS=RA; A(R)=A(R)+1; ! MOVE TO NEXT ALT OF PHRASE
RA=SYMBOL(RA); ->L1
L8: ! COMPLETE SUCCESS
HIT=1; RETURN
L7: ! UTTER FAILURE
HIT=0; RETURN
L6: ! BUILT IN PHRASE
I=CC(Q); ->BIP(ITEM); ! SO SWITCH TO IT
BIP(1001): ! PHRASE NAME
PNAME; ->L1 IF HIT=1; ->L3
BIP(1002): ! PHRASE U/CODE INSRN
->L3 UNLESS 'A'<=I<='Z'
S=I; J=1
L200: Q=Q+1; I=CC(Q)
->L201 UNLESS 'A'<=I<='Z'
S=S<<8!I;J=J+1; ->L200
L201: ->L3 UNLESS I='_' AND J<=4
Q=Q+1; ->L2
BIP(1003): ! PHRASE CONST
CONST(0)
->L3 IF HIT=0
->L1 IF CTYPE=5
->L26 IF CTYPE=2; ! %REAL
->L22 IF S>>12=0
A(R)=1
TOAR4(R+1,S); R=R+3; ->L2
L22: A(R)=9; R=R+1; A(R)=S; ->L1
L26: A(R)=2; TOAR8(R+1,CVALUE); R=R+5; ->L2
BIP(1005): ! PHRASE N
->L3 UNLESS '0'<=I<='9'; ! MUST START WITH DIGIT
CONST(2); A(R)=S; ->L1
BIP(1004): ! PHRASE CONSTLIST
CONSTLIST;->L1
BIP(1006): ! PHRASE S=SEPARATOR
->L2 IF I=10
->L3 UNLESS I=';'
Q=Q+1; ->L2
BIP(1007):L30: ! PHRASE TEXT=COMMENT TEXT
->L1 UNLESS 10#I#';'
Q=Q+1; I=CC(Q); ->L30
BIP(1008): ! PHRASE TEXTTEXT=BETWEEN QUOTES
TEXTTEXT
->L3 IF HIT=0;->L1
BIP(1009): ! PHRASE NAMELIST
! GIVES AR IN FORM NNAMES,NAME1,....NAMEN
U=R; V=1; R=R+1
PNAME; ->L3 IF HIT=0
L90: ->L91 UNLESS CC(Q)=','
Q=Q+1; R=R+1
I=CC(Q)
PNAME
->L92 IF HIT=0; V=V+1; ->L90
L92: R=R-1; Q=Q-1
L91: A(U)=V; ->L1
BIP(1010): ! PHRASE HOLE
MARKER=R; ->L1
BIP(1011): ! PHRASE MARK
A(MARKER)=R-MARKER; ->L2
BIP(1012): ! PHRASE UCRR=RR FORMAT
->L124 IF S&255='R'; ! LAST LETTER=R
CYCLE I=0,1,2
->L120 IF S=NEM(I)
REPEAT; ->L3
L120: A(R)=OPC(I)&63; ->L1
L124: J=S>>8; CYCLE I=2,1,48
->L120 IF J=NEM(I)
REPEAT; ->L3
BIP(1013): ! PHRASE UCRX=RX FORMAT
CYCLE I=18,1,64
->L130 IF S=NEM(I)
REPEAT; ->L3
L130: A(R)=OPC(I); ->L1
BIP(1014): ! PHRASE UCRS=R,R,DB FORMAT
CYCLE I=66,1,69
->L130 IF S=NEM(I)
REPEAT; ->L3
BIP(1015): ! PHRASE UCSI=STORE IMDTE
CYCLE I=71,1,83
->L130 IF S=NEM(I)
REPEAT; ->L3
BIP(1016): ! PHRASE UCSHIFT=SHIFT INSTRNS
CYCLE I=85,1,92
->L130 IF S=NEM(I)
REPEAT; ->L3
BIP(1017): ! PHRASE UCSS=STORE TO STORE
CYCLE I=94,1,106
->L130 IF S=NEM(I)
REPEAT; ->L3
BIP(1018): ! PHRASE UCPD=PACKED DECIMAL
CYCLE I=108,1,116
->L130 IF S=NEM(I)
REPEAT; ->L3
BIP(1019): ! PHRASE UCSPEC=THE FUNNIES
CYCLE I=118,1,120
->L130 IF S=NEM(I)
REPEAT; ->L3
END ; !OF ROUTINE 'COMPARE'
INTEGERFN HASH(INTEGER ADDR)
RESULT=NNAMES &(19*BYTE INTEGER(ADDR)+31*BYTE INTEGER(ADDR+1))
END
ROUTINE PNAME
INTEGER JJ,KK,LL
!%SHORTROUTINE
HIT=0; I=CC(Q)
->L3 UNLESS 'A'<=I<='Z'; ! 1ST CHAR MUST BE LETTER
->L3 IF CC(Q+1)='''' AND(I='B' OR I='X' OR I='M')
S=2; T=1; ->L10
L12: Q=Q+1; I=CC(Q)
->L101 UNLESS 'A'<=I<='Z' OR '0'<=I<='9'
T=T+1; S=S+1
L10: LETT(NEXT+T)=I; ->L12
L101: LETT(NEXT)=T; ! INSERT LENGTH
FAULT(108) IF NEXT+S>DSIZE; !DICTIONARY OVERFLOW
JJ=HASH(ADDR(LETT(NEXT))); !PREPARE TO LOOK UP
CYCLE NUM=JJ,1,JJ+NNAMES
KK=NUM&NNAMES; ! TREAT DICTIONARY AS CYCLIC
LL=WORD(KK)
->L2 IF LL=0; ! NAME NOT KNOWN
CYCLE JJ=1,1,LETT(LL)
->FAIL UNLESS LETT(NEXT+JJ)=LETT(LL+JJ)
REPEAT; ->L41; ! NAME FOUND
FAIL: REPEAT
FAULT(104); ! TOO MANY NAMES
L2: WORD(KK)=NEXT; NEXT=NEXT+S
L41: A(R)=KK; HIT=1
L3: END
ROUTINE CONST(BYTEINTEGER MODE)
COMMENT MODE=0 FOR NORMAL MODE=2 FOR EXPONENT ETC
INTEGER Z
LONGREAL X
CVALUE=0; I=CC(Q)
!%SHORTROUTINE
S=0; ->N IF '0'<=I<='9'
->DOT IF I='.' AND MODE=0 AND '0'<=CC(Q+1)<='9'; ! 1 DIDT MIN
->PI IF I='$' AND MODE=0; ! PI was represented back then by the character which now prints as '$'!
->L101 IF I=''''
->L150 UNLESS CC(Q+1)=''''; Q=Q+2
->L102 IF I='X'; ->MULT IF I='M'
->L104 IF I='B'
Q=Q-2; ->L150
PI:
CVALUE=3.14159 26535 89793 23846; Q=Q+1; ->L40
L101: S=R; A(R)=5; R=R+1
TEXTTEXT
->L24 IF A(S+1)=0; ! NULL STRING
->L27 IF A(S+1)=1; ! SINGLE CHAR CONSTANT
CTYPE=5; RETURN
L24: R=S; S=0; ->L99
L27: R=S; S=A(S+2); ->L99
L102: I=CC(Q); Q=Q+1; ! HEX CONSTANTS
->L99 IF I=''''
->L5 IF '0'<=I<='9'
->L150 UNLESS 'A'<=I<='F'
S=S<<4!(I-'A'+10); ->L102
L5: S=S<<4!(I-'0'); ->L102
MULT: T=0; ! MULTIPLE CONSTANTS
L28: I=CC(Q); Q=Q+1; ->L22 IF I=''''
L29: S=S<<8!I; T=T+1; ->L150 IF T>=5; ->L28
L22: ->L99 UNLESS CC(Q)=''''; Q=Q+1; ->L29
L104: T=Q; ! BINARY CONST
L32: I=CC(Q); Q=Q+1
->L31 IF '1'#I#'0'
S=S<<1!(I-'0')
->L150 IF Q-T>=33; ->L32
L31: ->L99 IF I=''''; ->L150
N: I=I&15; CVALUE=10*CVALUE+I
Q=Q+1; I=CC(Q)
->N IF '0'<=I<='9'
->ALPHA UNLESS MODE=0 AND I='.'
DOT: Q=Q+1; X=10
L45: I=CC(Q); ->ALPHA UNLESS '0'<=I<='9'
I=I&15; CVALUE=CVALUE+I/X
X=10*X
Q=Q+1; ->L45
ALPHA: COMMENT TEST FOR EXPONENT
->FIX UNLESS MODE=0 AND CC(Q)='@'
Q=Q+1; X=CVALUE
Z=1; ->L39 IF '+'#CC(Q)#'-'
Z=-1 IF CC(Q)='-'; Q=Q+1
L39: CONST(2); ->L150 IF HIT=0; S=S*Z
IF S=-99 THEN CVALUE=0 ELSE CVALUE=X*10^^S
FIX: COMMENT SEE IF IT IS INTEGER
->L40 IF CVALUE>IMAX; ! TOO BIG
->L41 IF {FRACPT(CVALUE)=0}INTPT(CVALUE)=CVALUE
L40: CTYPE=2; HIT=1; RETURN
L41: S=INT(CVALUE)
L99: CTYPE=1; HIT=1; RETURN
L150: HIT=0; ! FAILURE
END
ROUTINE CONSTLIST
!%SHORTROUTINE
INTEGER PRECP,NCONST,RF,J,K,CPW
INTEGER KK,SIGN,SP,RQ,VALUE
INTEGER TYPEP,ACC,RP,N,JJ
LONGREAL C
VALUE=0; NCONST=0
IF CONSTPTR&1#0 THEN PSYM(0)
A(R+1)=CONSTPTR
RP=R; R=R+2; ACC=0; N=24
TYPEP=TYPEFLAG(A(2)); PRECP=TYPEP>>3
TYPEP=TYPEP&7
IF TYPEP=5 THEN ACC=A(4)
PRECP=3 IF TYPEP=2 AND ALL LONG=1
CPW=4//BYTES(PRECP)
CPW=4 IF TYPEP=5
L6: RQ=Q; I=CC(Q); SIGN=1; ->L7 IF I='-'
->L8 IF I='+'; ->L9
L7: SIGN=-1; ->L99 IF CPW=4
L8: Q=Q+1; I=CC(Q)
L9: CONST(0); RF=1
->L98 IF HIT=0
->L1 UNLESS CC(Q)='('
J=S; Q=Q+1; C=CVALUE
CONST(2); ->L98 UNLESS HIT=1 AND S>0 AND CC(Q)=')'
Q=Q+1
CVALUE=C; RF=S; S=J
L1: ->L21 IF TYPEP=2
->L51 IF TYPEP=5
->L99 IF CPW=4 AND S>255
->L99 IF CPW=2 AND |S|>>16#0; ! SHORT TOO LARGE
S=S*SIGN
S=S&X'FFFF' IF CPW=2
CYCLE KK=1,1,RF
J=NCONST//CPW
K=NCONST-CPW*J
SP=S<<(32*(CPW-K-1)//CPW)
VALUE=SP!VALUE
NCONST=NCONST+1
->L5 UNLESS (CPW-1)&NCONST=0
PSYM(VALUE); VALUE=0
L5: REPEAT
L11: ->L99 UNLESS CC(Q)=','; Q=Q+1
->L6 UNLESS CC(Q)=10
READLINE(0); Q=1; ->L6
L21: IF CTYPE=1 THEN CVALUE=S
CVALUE=SIGN*CVALUE
J=INTEGER(ADDR(CVALUE))
K=INTEGER(ADDR(CVALUE)+4)
CYCLE KK=1,1,RF; NCONST=NCONST+1
PSYM(J); PSYM(K) IF PRECP=3
REPEAT; ->L11
L51: ->L52 IF CTYPE=5
->L98 UNLESS CTYPE=1 AND S<=127
A(RP+3)=1; A(RP+4)=S
L52: ->L98 UNLESS SIGN=1 AND ACC>=A(RP+3)
CYCLE KK=1,1,RF
CYCLE JJ=0,1,ACC
S=A(RP+JJ+3)&127
SP=S<<N
VALUE=SP!VALUE; N=N-8
->L55 UNLESS N<0
PSYM(VALUE); N=24; VALUE=0
L55: REPEAT
NCONST=NCONST+1
REPEAT; R=RP+2; ->L11
L98: Q=RQ
L99: R=RP; A(R)=NCONST
PSYM(VALUE) IF(TYPEP=5AND N#24)OR(TYPEP#5 AND(CPW-1)&NCONST#0)
END
ROUTINE TEXTTEXT
!%SHORTROUTINE
INTEGER S,J
S=R; R=R+1
->L98 UNLESS I='''' ; !FAIL UNLESS INITIAL QUOTE
Q=Q+1
L1: I=CC(Q);A(R)=I;R=R+1
->L31 IF I=''''
->L32 IF I=10
Q=Q+1;FAULT(106) IF R-S>256
->L1
L32: READ LINE(1);Q=1;->L1
L31: ->L35 UNLESS CC(Q+1)=''''
Q=Q+2;->L1
L35: R=R-2;J=R-S;->L36 UNLESS J&1=0
R=R+1;A(R)=0
L36: A(S)=J;Q=Q+1;HIT=1;->L99
L98: HIT=0
L99: END
ROUTINE SET UP LIST
!%SHORTROUTINE
INTEGER J,K
CYCLE J=0,8,ASL-16
SET SHORT INTEGER(ADDR(ASLIST(J))+14, J)
REPEAT
INTEGER(ADDR(ASLIST(0)))=-1; ! INITIALISE BOTTOM CELL
INTEGER(ADDR(ASLIST(4)))=X'FFFF0000'
ASL=ASL-8
END
ROUTINE INITIALISE
!%SHORTROUTINE
OWNBYTEINTEGERARRAY ILETT(1:320)=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',
6,'R','U','N','O','U','T',
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',
9,'M','A','P','R','E','C','O','R','D' ,
11,'B','Y','T','E','I','N','T','E','G','E','R',
12,'S','H','O','R','T','I','N','T','E','G','E','R',
6,'R','A','D','I','U','S',
6,'A','R','C','T','A','N',
6,'P','A','R','I','T','Y',
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'
OWNSHORTINTEGERARRAY IWORD(0:42)=1,
13,26,34,40,51,58,67,74,85,97,
108,113,119,127,132,139,143,149,156,162,
170,175,183,187,194,199,203,207,211,215,
219,229,241,254,261,268,275,287,290,299,307,
314
INTEGER I
open input(1, "TEST.imp")
select input(1)
CABUF=0; PPCURR=0; QPREAL=0; OLDLINE=0
LINE=0; RLEVEL=0; NMAX=0; CONSTPTR=0
LEVEL=0; CA=0; AFLAG=0; FFLAG=0; SBFLAG=0
FAULTY=0; PERM=0; MCSWITCH=0; ALL LONG=0
DCOMP=0; COMPILER=0; CPRMODE=0; PRINT MAP=0
NEXT=1; NR=0; LDPTR=0; NEPS=0; EPLINK=0
RBASE=0; STRINST=0
IMAX=(-1)>>1;PLABEL=24999
SSTL=0; STMTS=0; SNUM=0
LABSET=3<<30;LETT(0)=0
N0=41; N=12
CHECKSP=1 ; CHECKS=1
LINENOS=1; DIAGS1=1; QU=1; MONE=1
LIST=1; SFLABEL=20999; UNASS=1
OWNLINK=0; XREFLINK=136
I=COM(24)
LIST=0 IF I&2#0
LINENOS=0 IF I&4#0
UNASS=0 IF I&16#0
CHECKS=0 IF I&32#0
PRINTMAP=1 IF I&X'8000'#0
DIAGS1=0 IF I&64#0
CYCLE I=0,1,MAXLEVELS
SET(I)=0; CODEBASE(I)=0; FREG(I)=0; RAL(I)=0
LWSP(I)=0; MDARR(I)=0; RNEXT(I)=0; STRWSP(I)=0
CYCLE(I)=0; JUMP(I)=0; NAME(I)=0
LABEL(I)=0; FLAG(I)=0; SBR(I)=0; WSP(I)=0
REPEAT
CYCLE I=0,1,50
ST(I)=0; PAGENOS(I)=0
REGISTER(I)=0 IF I<16
UVARREG(I)=0 IF 5<=I<=8
REPEAT; PAGENOS(1)=10
CYCLE I=0,1,NNAMES
WORD(I)=0; TAGS(I)=0
REPEAT
SET UP LIST
PCLOD(0); ! ST 12,28(GLA)--L 12,92(GLA)
PCLOD(5); ! ST 15,60(11)--BAL 15,RTI
A(1)=28
CYCLE I=0,1,42
J=IWORD(I)
CYCLE K=1,1,ILETT(J)
CC(K)=ILETT(J+K); ! COPY SPECIAL NAMES TO SOURCE
REPEAT; CC(K+1)=';'
R=2;Q=1; PNAME; ! SPECIAL NAME TO DICTIONARY
CSS(1); REPEAT; ! AND COMPILED
A(1)=12; CSS(1); ! COMPILE A BEGIN
END
!
COMMENT THE NEXT 4 ROUTINES CAN BE MACROISED USING MVC
!
ROUTINE TOAR4(INTEGER PTR,VALUE)
INTEGER AD; AD=ADDR(VALUE)
A(PTR)<-SHORT INTEGER(AD)
A(PTR+1)<-SHORT INTEGER (AD+2)
END
ROUTINE TOAR8(INTEGER PTR,LONGREAL VALUE)
INTEGER AD; AD=ADDR(VALUE)
A(PTR)<-SHORT INTEGER(AD)
A(PTR+1)<-SHORT INTEGER(AD+2)
A(PTR+2)<-SHORT INTEGER(AD+4)
A(PTR+3)<-SHORT INTEGER(AD+6)
END
ROUTINE FROMAR4(INTEGER PTR,INTEGERNAME VALUE)
INTEGER AD; AD=ADDR(VALUE)
SET SHORT INTEGER(AD, A(PTR))
SET SHORT INTEGER(AD+2, A(PTR+1))
END
ROUTINE FROMAR8(INTEGER PTR,LONGREALNAME VALUE)
INTEGER AD; AD=ADDR(VALUE)
SET SHORT INTEGER(AD, A(PTR))
SET SHORT INTEGER(AD+2, A(PTR+1))
SET SHORT INTEGER(AD+4, A(PTR+2))
SET SHORT INTEGER(AD+6, A(PTR+3))
END
ROUTINE PRINTNAME (INTEGER N)
!%SHORTROUTINE
INTEGER J,V
->L4 IF N>=0; N=-N
->L5 UNLESS 16384<=N<=16384+NNAMES
N=N-16384; ->L4
L5: WRITE(N,1); ->L3
L4: SPACE; V=WORD(N)
CYCLE J=1,1,LETT(V)
PRINT SYMBOL(LETT(V+J))
REPEAT
L3: END
ROUTINE PCLOD(INTEGER PTR)
INTEGER I
CYCLE I=PTR+1,1,PTR+CLODS(PTR)
PLANT(CLODS(I))
REPEAT
END
ROUTINE PACLOD(INTEGER PTR,AT,VALUE)
INTEGER I,J,K
J=CLODS(PTR); AT=AT+PTR
CYCLE I=PTR+1,1,PTR+J
K=CLODS(I)
K=K!VALUE IF I=AT
PLANT(K);REPEAT
END
ROUTINE PLANT(INTEGER VALUE)
!%SHORTROUTINE
CODE(PPCURR)<-VALUE
PPCURR=PPCURR+1; CA=CA+2
RETURN UNLESS PPCURR=192
LPUT(1,384,CABUF,ADDR(CODE(0)))
PPCURR=0; CABUF=CA
END
ROUTINE PRR (INTEGER OPCODE,R1,R2)
PLANT(OPCODE<<8!R1<<4!R2)
END
ROUTINE PRX(INTEGER OPCODE,R1,R2,BASE,DISP)
PLANT(OPCODE<<8!R1<<4!R2)
PLANT(BASE<<12!DISP)
END
ROUTINE PSI(INTEGER OPCODE,J,BASE,DISP)
PLANT(OPCODE<<8!J)
PLANT(BASE<<12!DISP)
END
ROUTINE PSS(INTEGER OPCODE,N,BASE,DISP,P,Q)
PLANT(OPCODE<<8!(N-1))
PLANT(BASE<<12!DISP)
PLANT(P<<12!Q)
END
ROUTINE PCONST(INTEGER X)
PLANT(X>>16); PLANT(X&X'FFFF')
END
ROUTINE CNOP(INTEGER I,J)
J=J-1
L1: ->L9 IF CA&J=I; PLANT(X'0700'); ->L1
L9: END
ROUTINE PSYM(INTEGER X)
LPUT(5,4,CONSTPTR<<2,ADDR(X))
CONSTPTR=CONSTPTR+1
END
ROUTINE PLUG(INTEGER J,K)
!%SHORTROUTINE
->INBUF IF J>=CABUF
LPUT(1,2,J,ADDR(K)+2) ; ->L99
INBUF: CODE((J-CABUF)>>1)<-K
L99: END
ROUTINE PRHEX(INTEGER VALUE,PLACES)
OWNBYTEINTEGERARRAY 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 SIZES
!%SHORTROUTINE
ROUTINESPEC SUM(INTEGER I)
INTEGER I,J,FREE,TOTAL
free=20000
sum(5)
if debug=1 start
print string("NNAMES="); write(NNAMES,0);
print string(" CCSIZE="); write(CCSIZE,0);
print string(" NROUTS="); write(NROUTS,0);
print string(" ASL="); write(ASL,0);
print string(" ARSIZE="); write(ARSIZE,0);
print string(" DSIZE="); write(DSIZE,0);
print string(" TOTAL="); write(TOTAL,0);
newlines(2)
finish
!!I=COM(2)
!!FREE=INTEGER(I+4); !TOP OF STORE
!!FREE=FREE-ADDR(TOTAL)-10000
! TOTAL IS CURRENT TOP OF STACK - 10K FOR COMPARE
!!%CYCLE J=0,1,5; SUM(J)
!!->L1 %IF TOTAL>FREE
!!%REPEAT
RETURN
L1: ->L2 UNLESS J=0
print string("NOT ENOUGH CORE ALLOCATED FOR IMP")
MONITOR ; STOP
L2: SUM(J-1)
RETURN
ROUTINE SUM(INTEGER I)
NNAMES=128*2^^I-1
CCSIZE=200+40*I
NROUTS=NNAMES//2
ASL =24*NNAMES
ASL=32760 IF ASL>32760; ! MAX FOR 16BIT LINKS
ARSIZE=300+50*I
DSIZE= 6*NNAMES
TOTAL=CCSIZE+ASL+2*(NROUTS+ARSIZE+DSIZE)
END
END
!
ROUTINE CSS (INTEGER P)
ROUTINESPEC REDEFINE EP(INTEGER TYPEP,INTEGERARRAYNAME PARAMS)
ROUTINESPEC CIOCP(INTEGER N)
ROUTINESPEC DEFINE EP(INTEGER MODE, NAME, ADDR)
ROUTINESPEC LOAD DATA
ROUTINESPEC P LOCAL JUMP(INTEGER MASK,LAB)
ROUTINESPEC FILL LOCAL JUMPS
ROUTINESPEC CLEAR LIST (SHORTINTEGERNAME OPHEAD) ; ! Care needed with short conversion!
ROUTINESPEC STORE STRING(INTEGER Z,FROM,TO,BML,DML)
ROUTINESPEC CEND(INTEGER KKK)
ROUTINESPEC CBPAIR(INTEGERNAME LB,UB)
ROUTINESPEC UNDCRF (SHORTINTEGERNAME OPHEAD) ; ! Care needed with short conversion!
ROUTINESPEC CCOND(INTEGER IU,REG,ADDR)
ROUTINESPEC FILL JUMPS(INTEGER LEVEL)
ROUTINESPEC SET LINE
ROUTINESPEC CUI(BYTEINTEGER CODE)
ROUTINESPEC SET80(INTEGER WHERE,N)
ROUTINESPEC CVDECLN
ROUTINESPEC CSEXP(INTEGER REG,BYTEINTEGER MODE)
ROUTINESPEC CSTREXP(INTEGER REG)
ROUTINESPEC CHECK RF
ROUTINESPEC ASSIGN (INTEGER P1,P2)
INTEGERFNSPEC COPY RECORD TAG
INTEGERFNSPEC COUNT APS
INTEGERFNSPEC DISPLACEMENT(INTEGER LINK)
ROUTINESPEC LOADAD(INTEGER REG,BASE,X,DISP)
ROUTINESPEC SKIP APP
ROUTINESPEC CQUERY(INTEGER REG)
ROUTINESPEC CRFORMAT
ROUTINESPEC CADCLN(BYTEINTEGER MODE)
ROUTINESPEC CQN(INTEGER P)
ROUTINESPEC CLT
ROUTINESPEC MOVE R(INTEGER R,N)
INTEGERFNSPEC GET ARR WSP
INTEGERFNSPEC GET DBLE WRD
ROUTINESPEC CRCALL (INTEGER CLINK)
ROUTINESPEC CNAME(INTEGER Z,REG)
ROUTINESPEC CRNAME(INTEGER Z,MODE,CLINK,BS,DP)
ROUTINESPEC CANAME(INTEGER Z,BS,DP,LINK,BSRF,DPRF)
ROUTINESPEC CENAME(INTEGER Z,MODE,BS,DP)
ROUTINESPEC INSERTAFTER(SHORTINTEGERNAME STAD,INTEGER S1,S2) ; ! Care needed with short conversion!
ROUTINESPEC FROM LIST(INTEGER CELL,INTEGERNAME S1,S2)
ROUTINESPEC POP(SHORTINTEGERNAME CELL,INTEGERNAME S1,S2) ; ! Care needed with short conversion!
ROUTINESPEC PUSH(SHORTINTEGERNAME CELL,INTEGER S1,S2) ; ! Care needed with short conversion!
INTEGERFNSPEC FIND(INTEGER LAB,LIST)
ROUTINESPEC MLINK(INTEGERNAME CELL)
ROUTINESPEC REPLACE2(INTEGER CELL,S2)
ROUTINESPEC REPLACE1(INTEGER CELL,S1)
ROUTINESPEC REPLACE BOTH(INTEGER CELL,S1,S2)
ROUTINESPEC FROM2(INTEGER CELL,INTEGERNAME S2)
ROUTINESPEC FROM1(INTEGER CELL,INTEGERNAME S1)
ROUTINESPEC CRES(INTEGER MODE,LAB)
INTEGERFNSPEC NEWCELL
ROUTINESPEC COPY TAG (INTEGER KK)
ROUTINESPEC CSNAME(INTEGER Z,REG)
ROUTINESPEC REPLACE TAG (INTEGER KK)
INTEGERFNSPEC PARK(INTEGER REG)
INTEGERFN SPEC PARKF (INTEGER REG,PREC)
INTEGERFNSPEC CLAIMABLE REG
INTEGERFNSPEC FIND PP
INTEGERFNSPEC GET STR WSP
ROUTINESPEC SETEX
ROUTINESPEC GXREF(INTEGER NAME,HASH)
ROUTINESPEC UNPARK(INTEGER OPCODE,REG,Q)
ROUTINESPEC STORE TAG(INTEGER KK,SLINK)
INTEGERFNSPEC PAGENO(INTEGER N)
ROUTINESPEC TESTNST
ROUTINESPEC CUCI
ROUTINESPEC SKIP EXP
ROUTINESPEC UNPACK
INTEGERFNSPEC SORT CONST(INTEGER P,LONG,TYPE)
ROUTINESPEC PACK(INTEGERNAME PTYPE)
ROUTINESPEC CRSPEC (BYTEINTEGER M)
ROUTINESPEC DUMP(INTEGER CODE,REG,DIS,X,LEVEL)
ROUTINESPEC RHEAD(INTEGER KK)
ROUTINESPEC TEST ASS(INTEGER REG)
ROUTINESPEC PJ(INTEGER MASK,STAD)
ROUTINESPEC COMPILE FORMAL PARAMETER
ROUTINESPEC PPJ(BYTEINTEGER N)
ROUTINESPEC PLAB(INTEGER M)
ROUTINESPEC CHECK CAPACITY(INTEGER REG,DIS,X,LEVEL)
INTEGERFNSPEC TSEXP(INTEGERNAME CODE)
SWITCH SW(1:45)
INTEGER INC,INCP,BXLE,ACC
SHORTINTEGER OPHEAD
INTEGER JJ,JJJ,KK,KKK,Q,QQ,EXTRN
INTEGER BASE,DISP,VALUE,INDEX
INTEGER LOCAL BASE, LOCAL ADDR
SHORTINTEGER LOCAL JUMP,LOCAL LABEL
BYTEINTEGER ROUT,NAM,ARR,PREC,TYPE,PRECP
INTEGER PTYPE,I,J,K,OLDI,INREG
INTEGER PTYPEP,SAVE13,CHNGE13
LOCAL JUMP=0;LOCAL LABEL=0
LOCAL BASE=0
OLDI=0; ->SW(A(P))
SW(1): MARKER2=P+1+A(P+1); SET LINE
P=P+2; ->L101 IF A(MARKER2)=2
MASK=15; CUI(0); ->L1
L101: Q=P
FAULT(54) IF A(P)=9; ! START
SAVE13=R13; CHNGE13=0
->L103 IF A(P)=3; ! UI =JUMP
PLABEL=PLABEL-2; JJJ=PLABEL+1
KKK=PLABEL; P=MARKER2+2
CCOND(A(P-1)-1,JJJ,KKK)
PLOCAL JUMP(MASK,KKK)
R13=0 UNLESS R13=SAVE13 AND CHNGE13=0
PUSH(LOCAL LABEL,CA,JJJ)
P=Q; CUI(1)
L104: PUSH(LOCAL LABEL,CA,KKK)
R13=0 UNLESS R13=SAVE13 AND CHNGE13=0
L102: REGISTER(LOCAL BASE)=0 UNLESS LOCAL BASE=10 OR LOCALBASE=0
FILL LOCAL JUMPS; ->L1
L103: PLABEL=PLABEL-1; JJJ=PLABEL
NMDECS(LEVEL)=1
KKK=A(P+2)+(A(P+1)-1)<<14
P=MARKER2+2; CCOND(2-A(P-1),JJJ,KKK)
PLOCAL JUMP(MASK,KKK)
R13=0 UNLESS R13=SAVE13 AND CHNGE13=0
PUSH(LOCAL LABEL,CA,JJJ); ->L102
!
SW(2): SET LINE;P=P+1; BXLE=0; CNAME(3,4)
INC=N; N=N+12
FAULT(25) UNLESS TYPE=1 AND PREC=0
Q=P; SKIP EXP; REGISTER(4)=1
JJ=P; BXLE=1 IF 3900>CA-CODEBASE(LEVEL)AND 1<=TSEXP(JJJ)<=2
P=JJ; CSEXP(2,1); ! INTEGER TO REG2
JJJ=P; KKK=TSEXP(QQ); P=JJJ
DUMP(1,2,INC,0,RBASE) IF KKK=0
CSEXP(3,1)
IF KKK=0 THEN PRX(X'90',3,4,RBASE,INC+4) ELSE C
PRX(X'90',2,4,RBASE,INC)
P=Q; CSEXP(1,1)
->L202 IF CHECKSP=0
DUMP(0,2,INC,0,RBASE); PPJ(17)
L202: PLAB(-1); REGISTER(4)=0
DUMP(1,1,0,0,4)
PUSH(CYCLE(LEVEL),K,INC+4096*BXLE)
->L1
!
SW(3): !REPEAT
SET LINE
POP(CYCLE(LEVEL),J,K)
->L302 UNLESS J=-1
FAULT(1); ->L1
L302: BXLE=K>>12; K=K&4095
PRX(X'98',2,4,RBASE,K); ! LM 2,4,?
DUMP(2,1,0,0,4); ->L301 IF BXLE=1
PLANT(X'1A12'); ! AR 1,2
PCONST(X'59304000'); ! C 3,0(4)
K=J; PJ(7,K); ->L1
L301: I=FIND(J,LABEL(LEVEL))
PRX(X'87',1,2,10,I-CODEBASE(LEVEL)); ->L1;! BXLE 1,2,ADDR
SW(4): ! (LABEL)':'
K=A(P+2)+(A(P+1)-1)<<14
->L402 IF FIND(K,LABEL(LEVEL))=-1
FAULT(2); ->L1
L402: PLAB(K); ->L1
SW(5): Q=P+1; MARKER2=P+3+A (P+2);
SET LINE; P=MARKER2
SAVE13=R13; CHNGE13=0
->L510 IF A(P)=3; ! UI=JUMP
->L520 IF A(P)=9; ! UI =START
PLABEL=PLABEL-2; JJJ=PLABEL+1; KKK=PLABEL
P=Q+2; CCOND(A(Q)-1,JJJ,KKK)
P LOCAL JUMP(MASK,KKK)
R13=0 UNLESS R13=SAVE13 AND CHNGE13=0
PUSH(LOCAL LABEL,CA,JJJ)
P=MARKER2; CUI(1)
->L104 UNLESS A(P)=1; ! %ELSE FOLLOWS
P=P+1; ->L107 IF A(P)=9; ! UI=START
PLABEL=PLABEL-1; JJJ=PLABEL
P LOCAL JUMP(15,JJJ)
PUSH(LOCAL LABEL,CA,KKK)
R13=0 UNLESS R13=SAVE13 AND CHNGE13=0
MASK=15; CUI(2); KKK=JJJ; ->L104
L107: PJ(15,SFLABEL-1)
CUI(2); ->L104
L510: PLABEL=PLABEL-1; JJJ=PLABEL
NMDECS(LEVEL)=1
KKK=A(P+2)+(A(P+1)-1)<<14
P=Q+2; CCOND(2-A(Q),JJJ,KKK)
PLOCAL JUMP(MASK,KKK)
R13=0 UNLESS R13=SAVE13 AND CHNGE13=0
PUSH(LOCAL LABEL,CA,JJJ)
P=MARKER2+3; ->L102 UNLESS A(P)=1
P=P+1; MASK=15; CUI(0); ->L102
L520: PLABEL=PLABEL-1; JJJ=PLABEL
KKK=SFLABEL-1
P=Q+2; CCOND(A(Q)-1,JJJ,KKK)
P LOCAL JUMP(MASK,KKK)
R13=0 UNLESS R13=SAVE13 AND CHNGE13=0
PUSH(LOCAL LABEL,CA,JJJ)
P=MARKER2; CUI(1); P=P+1
FAULT(53) IF A(P)=1; ->L102
SW(6):L1: ! %COMMENT
RETURN
SW(7): ! SIMPLE DECLN
FAULT(57) UNLESS LEVEL>=2
FAULT(40) IF NMDECS(LEVEL)#0
P=P+1;CLT;ROUT=0
FAULT(70) IF TYPE=5 AND ACC=0
->SCALAR IF A(P)=1
->VECTOR IF A(P)=3
ARR=1; NAM=(2-A(P+1))<<1; ! NAME ARRAY BIT
PACK(PTYPE); P=P+2; SET LINE
ACC=4 IF NAM#0;CADCLN(0);->L1
VECTOR: ARR=2; NAM=0; PACK(PTYPE)
P=P+1; SET LINE; CVDECLN; ->L1
SCALAR: J=0;ROUT=0;CQN(P+1);P=P+2
INC=N
QQ=ACC;ACC=4 IF TYPE=5;JJ=0
->L701 UNLESS ACC=8 AND N&7#0
PUSH(WSP(LEVEL),0,N);N=N+4 ;!DOUBLE WORD BOUNDARY
L701: SET LINE IF TYPE=5
PACK(PTYPE)
CYCLE KK=1,1,A(P)
K=A(P+KK);TESTNST
STORE TAG(K,N)
->L705 UNLESS TYPE=5
JJ=JJ+QQ
PSS(X'D2',2,WSPR,0,GLA,128) IF UNASS=1
PRX(X'50',WSPR,RBASE,0,N) ;!STORE POINTER
PSI(X'92',QQ-1,RBASE,N) ;!STORE MAX LENGTH
IF KK=A(P) THEN QQ=QQ+(JJ+7)&(-8)-JJ
PRX(X'41',WSPR,WSPR,0,QQ) ;!ADVANCE WORK SPACE
L705: N=N+ACC;REPEAT
N=N+3; N=N&(-4)
SET80(INC,N-INC) IF UNASS=1 AND TYPE#5
->L1
SW(8): ! %END
CEND(FLAG(LEVEL))
->L1
SW(9): P=P+1; MARKER1=A(P)+P; !(SEX)(RT)(SPEC')(NAME)(FPP)
L900: Q=P; KKK=A(MARKER1+1); !KKK ON NAME
EXTRN=A(P+1)
->L902 IF A(MARKER1)=2
P=P+1; CRSPEC(0); ->L1 IF EXTRN=3
N0=N0-1; KK='S'*(2-EXTRN)
GXREF(KKK,KK); JJ=TAGS(KKK)
FROM1(JJ,Q)
REPLACE1(JJ,Q&(-2)); ->L1
L902: FILL JUMPS(LEVEL)
KK=KKK
COPY TAG(KKK); ->L939 IF OLDI#LEVEL
UNLESS EXTRN=3 THEN START
CPRMODE=2 IF CPRMODE=0
FAULT(55) UNLESS CPRMODE=2 AND LEVEL=1
DEFINE EP(EXTRN,KKK,CA)
PCLOD(0); ! ST 12,28(GLA)--L 12,=A(PERM)
FINISH
->L908 IF A(P+2)=1; ROUT=1
P=P+3
CLT;ARR=0;NAM=(A(P)-1)<<1; ! SET NAME ARRAY BIT FOR MAPS
PACK(KKK); ->L909
L908: KKK=10000
L909: ->L940 IF J=15 AND PTYPE=KKK
FNAME=KK; FAULT(7) UNLESS PTYPE&7=7
L939: P=Q+1; CRSPEC(0); P=Q; ->L900
L940: J=0; REPLACETAG(KK); JJ=K; ! CHANGE TAG TO ROUT SPECIFIED AND DESCRIBED
PLABEL=PLABEL-1
PJ(15,PLABEL) UNLESS COMPILER=1 OR(CPRMODE=2 AND LEVEL=1)
RAL(LEVEL)=NMAX<<16!SBFLAG<<15!N
RHEAD(KK)
PPJ(40) UNLESS EXTRN=3; ! TO RELOCATE OWNS
FLAG(LEVEL)=PTYPE
P=MARKER1+1
->L942 IF A(P+1)=2
L943: P=P+2; COMPILE FORMAL PARAMETER
CYCLE BXLE=1,1,A(P)
MLINK(JJ); ->L945 UNLESS JJ=0
FAULT(8); ->L946
L945: FROM LIST(JJ,J,JJJ)
->L946 IF J=PTYPE AND(PTYPE#5 OR JJJ=ACC)
FAULT(9); PRINT NAME(A(P+BXLE))
L946: K=A(P+BXLE); TESTNST
OPHEAD=0; UNPACK
->L947 IF ROUT=1; ! RT TYPES
->L9040 IF PTYPE=5; J=JJJ
->L948 IF TYPE=3; !RECORDS
R=N; ->L950 IF ARR=1
->L949 IF PREC=3 AND NAM=0; ! LONG
N=N+4-ACC; R=N
L950: STORE TAG(K,N)
N=R+ACC; ->L999
L947: PUSH(OPHEAD,N,1000); !SET DUMMY SIDECHAIN FOR RT TYPES
J=13
L951: KK=OPHEAD
R=N; N=KK; ->L950
L9040: PRX(X'41',1,0,RBASE,N+4); ! STRING VALUE SET PTR
PRX(X'50',1,0,RBASE,N)
PSI(X'92',JJJ-1,RBASE,N)
STORE TAG(K,N)
N=N+(ACC+7)&(-4); ->L999
L948: PUSH(OPHEAD,0,N); J=0; ->L951; ! DUMMY SIDECHAIN FOR RECORD
L949: R=N; ->L950 IF N&7=0
PUSH(WSP(LEVEL),0,N)
N=N+4; R=N; ->L950; !ALLIGN ON D W BOUNDARY
L999: REPEAT
P=P+1+BXLE; ->L943 IF A(P)=1
L942: MLINK(JJ); FAULT(10) UNLESS JJ=0; ->L1202
!
SW(10): ! COMMENT
->L1
!
SW(11): !REALS(LN)
ALL LONG=A(P+1)&1;->L1
SW(12): !%BEGIN
FILL JUMPS(LEVEL)
RAL(LEVEL)=SBFLAG<<15!N
PTYPE=0; RHEAD(-1)
FLAG(LEVEL)=0
->L1 IF LEVEL=1=RLEVEL
->L1202 UNLESS LEVEL=2
CPRMODE=1 IF CPRMODE=0
DEFINE EP(0,0,0)
FAULT(55) UNLESS CPRMODE=1
L1202: PLANT(X'05A0'); CODEBASE(LEVEL)=CA; ->L1
SW(13): ! %ENDOFPROGRAM
FAULT(15) UNLESS LEVEL=2
FAULT(56) UNLESS CPRMODE=1
PERM=0; CEND(1)
LOAD DATA; ->L1
SW(14): BEGIN; !SWITCH LABEL
!%SHORTROUTINE
R13=0;MONE=1
COPYTAG(A(P+1))
->L1401 IF OLDI=LEVEL AND TYPE=6
FAULT(4); ->L1
L1401: FROM LIST(K,ACC,KKK)
MLINK(K); FROM LIST(K,QQ,KK); ! UB & BIT LIST PART 1
->L1411 UNLESS A(P+3)&7=1
IF A(P+3)=9 THEN JJ=A(P+4) ELSE START
FROMAR4(P+4,JJ); P=P+1; FINISH
JJ=-JJ IF A(P+2)=2
->L1402 IF KKK<=JJ<=KK
L1411: FAULT(5); ->L1
L1402: Q=JJ-KKK
L1404: ->L1403 IF 31>=Q
MLINK(K); Q=Q-32
FROM LIST(K,QQ,JJJ); ->L1404
L1403: JJJ=1<<Q; FAULT(6) UNLESS JJJ&QQ=0
REPLACE1(K,QQ!JJJ); ! UPDATE BIT LIST
Q=CA-CODEBASE(LEVEL)
->L1407 IF PREC#0
QQ=ACC+8+(JJ-KKK)<<2; ! WHERE TO PLUG
PLUG(QQ,Q>>16) UNLESS Q>>16=0
L1406: PLUG(QQ+2,Q&X'FFFF'); ->L1
L1407: QQ=ACC+6+(JJ-KKK)<<1
FAULT(99) IF Q>X'7FFF';->L1406
!
L1: END;->L1
SW(15): BEGIN; !SWITCH (SWITCH LIST)
!%SHORTROUTINE
INTEGER BP,QQQ
Q=P;CNOP(0,4);PJ(15,PLABEL-1)
FAULT(56) UNLESS LEVEL>=2
L1528: P=Q+A(Q+1)+2
CBPAIR(KKK,KK); ! LB TO KKK, UB TO KK
->L1501 UNLESS |KKK|<X'7FFF'>|KK|
->L1535 IF KKK<=KK; FAULT(27); KK=KKK
L1535: CYCLE QQ=1,1,A(Q+1)
K=A(Q+QQ+1);TEST NST
PREC=0
PREC=2 IF SBFLAG=1 OR COMPILER=1
TYPE=6; ROUT=0; NAM=0; ARR=1; PACK(PTYPE)
OPHEAD=NEWCELL; JJ=OPHEAD
J=0;STORE TAG(K,OPHEAD);R=KKK
INSERT AFTER (OPHEAD,0,KK)
L1503: ->L1504 IF KK-R<32
INSERT AFTER(OPHEAD,0,0)
R=R+32; ->L1503; ! SET UP BIT LIST
L1504: REPLACE BOTH(JJ,CA,KKK)
PCONST(KKK&X'FFFFFF'!PREC<<24)
PCONST(KK)
JJJ=KK-KKK
JJJ=(JJJ+1)//2 IF PREC=2
CYCLE I=0,1,JJJ
PCONST(0);REPEAT
REPEAT
Q=P; ->L1528 UNLESS A(Q)=2
PLAB(-1); ->L1
L1501: FAULT(18); KK=0; KKK=0; ->L1535
L1: END;->L1
SW(16): QU=¬A(P+1)&1; P=P+2; ->L1
!
SW(17): ! '%REGISTER' (NAME)
KK=CLAIMABLE REG
->L1999 IF KK=0
REGISTER(KK)=-LEVEL
UVARREG(KK)=LEVEL
PTYPE=8; J=0
K=A(P+1); TESTNST
STORE TAG(K,KK); ->L1
SW(18): ! '%OWN' (TYPE)(OWNDEC)
BEGIN
!%SHORTROUTINE
INTEGER WSP1,LENGTH,BP,PP,SIGN
INTEGERNAME VAR
FAULT(40) UNLESS NMDECS(LEVEL)=0
P=P+1; CLT
FAULT(70) IF TYPE=5 AND ACC=0
NAM=0; ROUT=0; ARR=A(P)-1; PACK(PTYPE)
PP=P+1; P=P+2; ->NONSCALAR UNLESS ARR=0
->L1801 UNLESS A(P)=2; ! NO CONST
A(P+1)=4; A(P+2)=9; A(P+3)=0; ! 0== NULL STRING ALSO
L1801: SIGN=A(P+1); ->L1820 IF TYPE=5; ! STRING
JJ= SORT CONST(P+2,PREC&1,TYPE)
->L1810 IF TYPE=2
VAR==ST(N0-1)
FAULT(44)IF(PREC=1 AND VAR>255)OR(PREC=2 AND |VAR|>>16#0)
FAULT(44) IF A(P+2)&7=2; ! REAL CONST FOR INTEGER VARIABLE
IF SIGN=2 THEN VAR=-VAR
IF SIGN=3 THEN VAR=¬VAR
L1803: K=A(PP); TESTNST
JJ=JJ+4-BYTES(PREC) UNLESS PREC=3
PUSH(TAGS(K),PTYPE<<16!LEVEL<<8!GLA<<4,JJ)
PUSH(NAME(LEVEL),0,K); ->L99
L1810: FAULT(44) IF SIGN=3; ! ¬ WITH REAL
->L1803 UNLESS SIGN=2
ST(JJ>>2)=ST(JJ>>2)!X'80000000';! OR IN SIGN BIT
->L1803
L1820: ! STRINGS
->L1822 UNLESS A(P+2)=9 AND A(P+3)<127
A(P+2)=5; A(P+4)=A(P+3); A(P+3)=1
L1822: FAULT(44) UNLESS SIGN=4 AND A(P+2)=5 AND A(P+3)<ACC
QQ=CONSTPTR<<2
CYCLE JJ=0,4,(ACC-1)&(-4)
WSP1=A(P+JJ+3)<<8!A(P+JJ+4)&255;! COLLECT THE SYMBOLS FROM
WSP1=WSP1<<8!A(P+JJ+5)&255; ! A.R AND ASSEMBLE INTO FOURS
WSP1=WSP1<<8!A(P+JJ+6)&255
PSYM(WSP1); ! THEN ADD TO SYMBOL TABLES
REPEAT
PRX(X'58',2,0,GLA,8); ! BASE OF ST TO REG2
LOADAD(1,2,GLA,QQ); ! ABSOLUTE ADDR OF STING
PRX(X'50',1,0,RBASE,N); ! STUFF IT OFF
PSI(X'92',ACC-1,RBASE,N); !
K=A(PP); TESTNST
J=0;STORE TAG(K,N)
N=N+4; ->L99
NONSCALAR:CBPAIR(KK,KKK)
IF TYPE=5 THEN BP=ACC ELSE BP=BYTES(PREC)
LENGTH=KKK-KK+1
IF A(P+1)=0 THEN ->L3; ! NO CONSTLIST
L1: FAULT(45) UNLESS KKK>=KK AND LENGTH=A(P+1)
QQ=CONSTPTR<<2
JJ=A(P+2)<<2
COMMENT OUTPUT AN ARRAYHEAD RELATIVE TO QQ
ST(N0)=JJ-KK*BP
ST(N0+1)=JJ
ST(N0+2)=QQ
ST(N0+3)=OWNLINK
COMMENT NOW OUTPUT DOPE VECTOR
PSYM(1<<16!BP)
PSYM(KK)
PSYM(KKK)
COMMENT NOW PLANT CODE
K=A(PP); J=1; TEST NST
OWNLINK=N0<<2
RBASE=GLA; STORETAG(K,OWNLINK)
RBASE=10-RLEVEL; N0=N0+4; ->L99
L3: A(P+2)=CONSTPTR
A(P+1)=LENGTH; ->L1 IF LENGTH<1
CYCLE JJ=1,1,(LENGTH*BP+3)//4
PSYM(0); REPEAT; ->L1
L99: END; ->L1
SW(19): ! %CLAIM/RELEASE ETC
COPY TAG(A(P+3))
->L1910 IF A(P+2)=1; ! '%ARRAY'
->L1999 UNLESS ARR=0 AND TYPE=3
FROM2(K,K); ->L1920
L1910: ->L1999 UNLESS ARR=1 AND TYPE<=3 AND J<=2
L1920: ->L1930 IF A(P+1)=2; ! %RELEASE
KK=CLAIMABLE REG; ->L1999 IF KK=0
REGISTER(KK)=A(P+3)+1
PRX(X'58',KK,0,I,K); ! LOAD THE REGISTER
JJ=TAGS(A(P+3))
FROM1(JJ,JJJ)
JJJ=JJJ!KK<<12
L1925: REPLACE1(JJ,JJJ); ->L1
L1930: ->L1999 UNLESS INREG#0 AND REGISTER(INREG)=A(P+3)+1
REGISTER(INREG)=0; JJ=TAGS(A(P+3))
FROM1(JJ,JJJ)
JJJ=JJJ&X'FFFF0FFF'; ->L1925
L1999: FAULT(58); ->L1
SW(26): COMPILER=1; UNASS=0; ->L1
SW(27): ! '%SPEC' FPP
P=P+1; ->L2701 IF A(P+1)=1
CRSPEC(2); ->L1
L2701: COPY TAG(A(P))
->L3901 UNLESS PTYPE=4 AND A(P+4)=2=A(P+3)
P=P+2; K=DISPLACEMENT(TAGS(A(P-2)))
->L1 IF K=-1; OPHEAD=K;
P=P+2; CRSPEC(3); ->L1
SW(20): MCSWITCH=1; PERM=1; ->L1; ! %MCODE
SW(21): SBFLAG=1; ->L1
SW(22): P=2; CUCI; ->L1; ! *UCI(S)
SW(23): ! %FAULT FAULTLIST
FAULT(26) UNLESS LEVEL=2 AND CPRMODE#2
P=P+1; Q=P+1
L2302: IF A(Q)=2 THEN ->L2303
Q=Q+2; ->L2302
L2303: K=A(Q+2)+(A(Q+1)-1)<<14
KKK=A(P);PCONST(X'41100000'!KKK)
FAULT(36) IF KKK>32 OR KKK=0 OR KKK=29 OR 12<=KKK<=13
PPJ(20); QQ=CA
PJ(15,K); ! JUMP TO LABEL
PCONST(X'07000700') UNLESS CA=QQ+8; ! JUMP MUST BE 8 BYTES
P=P+2; ->L2303 IF A(P-1)=1
->L1 IF A(P+2)=2
P=P+3; Q=P+1; ->L2302
SW(24): FAULT(56) UNLESS CPRMODE=2 AND RLEVEL=1
LOAD DATA;FINALISE
STOP
SW(25): MCSWITCH=0; PERM=0; ->L1; ! %ENDOFMCODE
SW(28): !%NAME - SPECIAL NAME
J=0; PTYPE=10006
STORE TAG(A(P+1),SNUM)
SNUM=SNUM+1;->L1
SW(29): LIST=1; ->L1; ! %LIST
SW(30): LIST=0; ->L1
SW(31): ! %CONTROL CONST
IF A(P+1)=9 THEN J=A(P+2) ELSE FROMAR4(P+2,J)
K=J&15; LINENOS=K UNLESS K=15
K=J>>4&15; DIAGS1=K UNLESS K=15
K=J>>8&15
CHECKS=K UNLESS K=15
CHECKSP=K&14 UNLESS K=15
K=J>>12&15
UNASS=K UNLESS K=15
K=J>>28
DCOMP=K UNLESS K=15
->L1
SW(32): POP(SBR(LEVEL),J,K); ! FINISH (ELSE')
->L321 UNLESS J=-1; FAULT(51); ->L1
L321: POP(CYCLE(LEVEL),JJ,KK)
->L322 IF 0>=JJ
FAULT(52); ->L321
L322: ->L402 UNLESS A(2)=1; ! ELSE FOLLOWS
FAULT(47) UNLESS J=1
P=P+2; KK=K
MONE=0;R13=0;SET LINE ;!CLEAR AFTER FINISH
IF A(P)=9 THEN JJ=SFLABEL-1 ELSE JJ=PLABEL-1
PJ(15,JJ); PLAB(KK); CUI(2); PLAB(-1); ->L1
SW(33): !RECORD FORMAT
FAULT(56) UNLESS LEVEL>=2
SET LINE; CRFORMAT; ->L1
SW(34): !RECORDS
BEGIN
!%SHORTROUTINE
ROUTINESPEC TEST AND SET
SET LINE; P=P+1; MARKER1=P+A(P)
FAULT(57) UNLESS LEVEL>=2
FAULT(40) IF NMDECS(LEVEL)#0
CHECK RF;->L1 IF K=-1
TYPE=3;PREC=0;ROUT=0
->SCALAR IF A(P+1)=1
FAULT(41) UNLESS A(P+2)=2; ! RECORD NAME ARRAYS FAULTED
NAM=0; ARR=1; PACK(PTYPE)
P=P+3
L3401: QQ=P+1
PSS(X'D2',4,WSPR,0,4,0); ! MVC FOR LENGTH
CADCLN(2)
CYCLE Q=1,1,A(QQ)
K=A(Q+QQ)
TEST AND SET
PPJ(13)
PRX(X'90',0,3,RBASE,N)
N=N+16
REPEAT
->L1 IF A(P)=2
P=P+1;CHECK RF;->L3401
SCALAR: CQN(P+2);P=P+3;J=0
PACK(PTYPE)
CYCLE Q=1,1,A(P)
K=A(P+Q)
TEST AND SET
IF NAM=1 THEN PSS(X'D2',4,RBASE,N,GLA,128) ELSE C
PACLOD(18,2,RBASE<<12!N)
COMMENT = ST WSP,? - AH WSP,LENGTH - LA WSP,7(WSP) - N WSP,=F'-8'
N=N+4; REPEAT; ->L1
ROUTINE TEST AND SET
TEST NST
JJJ=NEWCELL
STORE TAG(K,JJJ)
REPLACE BOTH(JJJ,TAGS(A(MARKER1)),N)
END
L1: END;->L1
SW(35): ! (RT)'%NAME'(NAMELIST)
P=P+1; MARKER1=P+A(P)
->L3801 IF A(P+1)=1
ROUT=1; P=P+2;CLT
ARR=2-A(P+1);NAM=(A(P+2)-1)<<1
PACK(PTYPE); ->L3802
L3801: PTYPE=11000
L3802: J=0;CYCLE KK=1,1,A(MARKER1)
K=A(MARKER1+KK)
TESTNST; OPHEAD=0
PUSH(OPHEAD,N,1000); ! SIDE CHAIN AS RT PARAM
STORE TAG(K,OPHEAD); !LINK IN SIDE CHAIN
N=N+40; REPEAT; ->L1
SW(36): ! RECORD SPEC
P=P+1; MARKER1=P+A(P)
CHECK RF; ->L1 IF K=-1
P=P+1; COPYTAG(A(P))
->L3910 IF A(P+1)=1
->L3902 IF TYPE=3 AND NAM=1
L3901: FAULT(63); ->L1
L3902: FROM1(K,Q)
FAULT(63) UNLESS Q=0
REPLACE1(K,TAGS(A(MARKER1))); ->L1
L3910:
P=P+2; K=DISPLACEMENT(TAGS(A(P-2)))
->L3901 IF K=-1; ->L3902
SW(37): ->L1; ! (S)
!
ROUTINE CEND (INTEGER KKK)
!%SHORT %ROUTINE
INTEGER DPTR,LNUM,W1,W2
INTEGERARRAY DD(0:300)
SET LINE; R13=0; MONE=1
L1: FROM LIST (SBR(LEVEL),J,K)
->L2 IF J=-1; FAULT(53); ! FINISH MISSING
A(2)=32; A(3)=2; CSS(2); ! SO COMPILE IT IN
->L1
L2: FILL JUMPS(LEVEL)
NMAX=N IF N>NMAX; ! WORK SPACE POINTER
POP (JUMP(LEVEL),J,K)
->L3 IF J=-1
->L2 IF K>=SFLABEL; FAULT(11)
IF K<16384 THEN WRITE(K,4) ELSE PRINTNAME(K-16384); ->L2;
L3: CLEAR LIST(LABEL(LEVEL))
CLEAR LIST (WSP (LEVEL))
CLEAR LIST(LWSP(LEVEL))
CLEAR LIST(MDARR(LEVEL))
CLEAR LIST(STR WSP(LEVEL))
COMMENT CLEAR DECLARATIONS -PLANT DIAGNOSTICS IF REQUIRED
->L10 IF DIAGS1=0
LNUM=LETT(M(LEVEL))
DD(0)=X'C2C2C2C2'
DD(1)=L(LEVEL)<<16!RBASE<<8!LNUM
DPTR=3; ->L9 UNLESS LNUM=0
DD(2)=L(LEVEL-1); ->L10
L9: W1=M(LEVEL)
CYCLE W2=1,1,LNUM
BYTE INTEGER(ADDR(DD(0))+7+W2)=LETT(W1+W2);! MOVE IN RT NAME
REPEAT
DPTR=DPTR+(LNUM-1)>>2
L10: POP(NAME(LEVEL),J,JJ)
->L20 IF J=-1
COPY TAG(JJ);POP(TAGS(JJ),KK,KK)
IF PTYPE=8 THEN START
REGISTER(K)=0; UVARREG(K)=0; FINISH; !RELEASE REGISTERS
IF INREG#0 THEN REGISTER(INREG) =0
->L12 UNLESS J=15
FAULT(28); PRINT NAME (JJ)
L12: OPHEAD=K; ->L13 IF TYPE=4
->L14 UNLESS ROUT=1 OR TYPE=3 OR TYPE=6 OR ARR=2
CLEAR LIST(OPHEAD); ->L10
L13: UNDCRF (OPHEAD)
->L10
L14: ->L10 UNLESS TYPE=1 OR TYPE=2 OR TYPE=5
->L10 UNLESS ARR=0 AND DIAGS1=1 AND ROUT=0
->L10 IF DPTR>297
Q=WORD(JJ);LNUM=LETT(Q)
LNUM=8 IF LNUM>8; ! TRUNCATE NAMES TO 8 CHARS
PTYPE= NAM<<6!PREC<<3!TYPE
DD(DPTR)=PTYPE<<24!I<<20!K<<8!LNUM
CYCLE W1=1,1,LNUM
BYTE INTEGER(ADDR(DD(DPTR))+W1+3)=LETT(W1+Q)
REPEAT
DPTR=DPTR+1+(LNUM+3)>>2;->L10
L20: ->L21 IF DIAGS 1=0
DD(DPTR)=-1
LPUT(4,DPTR<<2+4,SSTL,ADDR(DD(0)))
SSTL=SSTL+DPTR<<2+4
COMMENT CHECK CYCLE-REPEATS
L21: ->L22 IF CYCLE(LEVEL)=0
FROM2(CYCLE(LEVEL),J)
->L22 IF J=0
POP(CYCLE(LEVEL),I,I)
FAULT(13); ->L21
L22: COMMENT GARBAGE COLECT DICTIONARY
NEXT=RNEXT(LEVEL)
CYCLE W1=0,1,NNAMES
WORD(W1)=0 IF WORD(W1)>NEXT
REPEAT
COMMENT PLANT ANY NECESSARY CODE
NMAX=(NMAX+7)&(-8)
FAULT(99) IF NMAX>4092
PLUG(SET(RLEVEL),NMAX) IF KKK>=10000 OR KKK=1
->L23 IF KKK=10000
->L24 IF KKK=0
IF KKK>10000 AND COMPILER =0 THEN START
PCONST(X'4100000B') ;!LA 0,11 --- FAULT 11
PPJ(21);FINISH ; ! *->RTF1
PPJ(6) IF KKK=1; ->L30; ! 'STOP' AT END OF PROGRAM
L23: P=P+1; A(P)=5; CUI(0); ->L30; ! COMPILE '%RTURN' FOR ROUTINES
L24: JJ=X'FFF'&RAL(LEVEL-1)
PRX(X'98',10,11,RBASE,JJ); ! RESTORE R11&12
PSS(X'D2',4,GLA,20,RBASE,JJ+8) IF DIAGS1=1
L30: ->L99 IF KKK=2; NEWLINE
IF PRINTMAP=1 AND LIST=1 AND KKK#0 THEN START
print string(" LOCALS EXTEND TO ")
WRITE(NMAX,2); NEWLINE; FINISH
->L31 IF LIST#0; WRITE(LINE,5)
SPACES(3*LEVEL-3); print string("END")
L31: ->L33 IF LEVEL>2 OR PERM=1 OR CPRMODE=2
->L32 IF KKK=1
FAULT(14); A(1)=13; ->L99; ! TOO MANY ENDS
L32: KKK=2
L33: LEVEL=LEVEL-1
RLEVEL=RLEVEL-1 IF KKK>=10000
RBASE=10-RLEVEL; REGISTER (9-RLEVEL)=0
N=RAL(LEVEL); SBFLAG=N>>15&1
NMAX=N>>16 IF KKK>=10000; N=N&4095
->L2 IF KKK=2; ! ROUND AGAIN FOR 'ENDOFPROGRAM'
->L99 IF RLEVEL=1 AND CPRMODE=2
->L99 IF KKK=0 OR COMPILER=1
FROM2(JUMP(LEVEL),J) ; PLAB(J)
L99: END
ROUTINE CRSPEC (BYTEINTEGER M)
!%SHORTROUTINE
INTEGER PP,KK,JJ,JJJ,Q,TYPEP
->L12 IF M=3
PP=P; ->L2 UNLESS M=2
KK=A(P); P=P+1; COPYTAG(KK)
->L1 IF OLDI=LEVEL AND 10006#PTYPE>=10000
FAULT(3); ->L99
L1: FROM LIST(K,JJ,Q); OPHEAD=K
->L12 IF Q=1000; ->L10
L2: ->L3 IF A(PP+1)=2
TYPEP=10000; P=PP+3; ->L4
L3: ROUT=1;ARR=0;P=PP+2;CLT
NAM=(A(P)-1)*2; PACK(TYPEP); P=P+2
L4: KK=A(P); COPYTAG(KK)
->L11 IF OLDI#LEVEL
->L1 IF PTYPE=TYPEP OR |PTYPE-TYPEP|=1000
L10: FNAME=KK;FAULT(7) UNLESS PTYPE=7
->L99 IF M=2
L11: JJ=NR; NR=NR+1; RA(JJ)=4*N0; N0=N0+1
FAULT(109) IF NR>NROUTS
OPHEAD=NEWCELL;J=15;PTYPE=TYPEP
STORE TAG(KK,OPHEAD)
L12: JJJ=OPHEAD; Q=0; ->L24 IF A(P+1)=2; ! NO FORMAL PARAMS
L13: P=P+2; COMPILE FORMAL PARAMETER
CYCLE PP=1,1,A(P)
KK=0; KK=ACC IF PTYPE=5
INSERT AFTER(OPHEAD,PTYPE,KK);! FOR STRINGS PUSH IN LMAX
Q=Q+1; REPEAT
P=P+PP+1; ->L13 IF A(P)=1
L24: REPLACE2(JJJ,Q)
->L99 IF M=3
REPLACE1(JJJ,JJ)
L99: END
ROUTINE COMPILE FORMAL PARAMETER
!%SHORT %ROUTINE
SWITCH FPD(1:5)
->FPD(A(P))
FPD(1): !(RT)
ACC=16;ROUT=1;NAM=1
ARR=0
->L1 UNLESS A(P+1)=1
PREC=0;TYPE=0;P=P+3; ->L98
L1: P=P+2; CLT;NAM =2*(A(P)-1)+1
P=P+2; ACC=16; ->L98
FPD(2): !(LENGTH')(TYPE)(ARRAY')(NAME)
P=P+1; CLT
CQN(P); ROUT=0
FAULT(70) IF TYPE=5 AND ACC=0
P=P+1; ->L98
FPD(3): !%NAME
TYPE=0
L31: NAM=1; ARR=2-A(P+1); ROUT=0
ACC=4+12*ARR
PREC=0; P=P+2; ->L98
FPD(4): TYPE=3; ->L31
L98: PACK(PTYPE)
END
ROUTINE ASSIGN (INTEGER P1,P2)
!%SHORTROUTINE
INTEGER Q,ASSOP,KK,REG,PRECP,Z,ZP,TYPEP
INTEGER JJJ
SWITCH SW(1:4), S(0:15)
ASSOP=A(P2); ->SW(ASSOP); !P2 ON ASSOP
SW(2):SW(3): COPYTAG(A(P1+1)); P=P2+1
->REGVAR IF TYPE=8
->MAPS IF ROUT=1
->L34 IF TYPE=2
->L50 IF TYPE=5
->L35 IF TYPE=3
->L32 IF NAM=0 AND TYPE=1 AND ARR=0
L33: P=P2+1
KK=0; KK=4 UNLESS ARR=0 AND ROUT=0 AND 1>=TYPE
L36: IF KK=4 AND REGISTER(4)#0 THEN KK=14
CSEXP(KK,1); REG=NEST;KK=P
REGISTER(REG)=1 IF REGISTER(REG)=0
P=P1+1; CNAME((ASSOP-1)*(ASSOP-1),REG)
REGISTER(REG)=0 IF REGISTER(REG)>0
L30:
P=KK; IF A(P)=1=QU THEN CQUERY (REG)
P=P+1; ->L1
L31: print string(" CRUNCH "); MONITOR ; STOP
L32: ->L33 IF ROUT=1 OR A(P1+2)=1 OR A(P1+3)=1; ! ACTUAL PARAMS
->L33 IF UNASS =1
PRECP=PREC; TYPEP=PTYPE
KK=K; REG=I; Q=TSEXP(JJJ)
PTYPE=TYPEP; UNPACK
->L33 IF Q=0 OR A(P)=1=QU
->L37 IF 10<=Q<=12 AND Q-10=PRECP
->L33 UNLESS Q=1 AND PRECP=1
PSI(X'92',JJJ,REG,KK); ! MVI TO SET BYTE
P=P+1;->L1; ! SKIP QUERY IF ANY
L37: PSS(X'D2',BYTES(PRECP),REG,KK,I,K); ! MVC IF POSSIBL
P=P+1; ->L1
L34: Q=2; Q=3 IF PREC=3
IF A(P1+2)=1 THEN START
P=P1+2; FFLAG=0; SKIP APP; ->L55 IF FFLAG#0
P=P2+1; FINISH
CSEXP(0,Q); KK=P
FREG(NEST)=1; REG=NEST
P=P1+1; CNAME(1,NEST)
FREG(REG)=0
->L30
L35: P=P1+1; Q=COPY RECORD TAG
P=P2+1
TYPE=1 UNLESS TYPE=2 OR TYPE=5
->L50 IF TYPE=5
KK=4; ->L36 IF TYPE=1; ->L34
L50: CSTREXP(4);KK=P
REGISTER(4)=1
P=P1+1;
CNAME((ASSOP-1)^^2,4)
REGISTER(4)=0
REG=4; ->L30
MAPS: IF PTYPE=10006 THEN START
TYPE=TSNAME(K);PREC=TYPE>>3
TYPE=TYPE&7; FINISH
->L33 IF TYPE=1; ! NORMAL CHANNELS FOR INT MAPS
->L50 IF TYPE=5; ! STRING MAPS
L55: P=P2+1; PRECP=PREC
CSEXP(0,2+PREC&1)
Q=PARKF(NEST,3)
KK=P; P=P1+1; CNAME(3,1); ! ADDR TO GR1
DUMP(16,0,Q,0,RBASE); ! PICK UP TO FR0
DUMP(9+2*PREC,0,0,0,1); ! STUFF IT OFF
PUSH(LWSP(LEVEL),0,Q); ->L30; ! TO QUERY PRINT
REGVAR: FAULT(59) UNLESS A(P1+2)=2=A(P1+3)
KK=K; CSEXP(KK,1)
REGISTER(KK)=-1
IF A(P)=1=QU THEN CQUERY(REG)
P=P+1; ->L1
SW(4): !ASSOP=->L
P=P1+1; CNAME(2,1)
P=P2+1
CRES(0,0)
P=P+1;->L1
SW(1): !ASSOP='=='
P=P1+1; COPYTAG(A(P))
->L9 IF I=-1;Q=1
IF TYPE=3 THEN Q=COPY RECORD TAG
->L201 IF Q=0
FAULT(81) UNLESS A(P2+1)=4 AND A(P2+2)=1
->L101 IF ROUT=1; NEST=4
->S((NAM&2+ARR)<<2!(NAM&1)*2!(2-A(P+1)))
L9: FNAME=A(P); FAULT(16)
S(0):S(1):S(3):S(4):S(5):
S(7):S(8):S(10):S(11):S(12):
L10: FAULT(82)
P=P2+1; SKIPEXP; P=P+1; ->L1
S(2): ! NAM=1; S(9):!NAMARR + APP; S(15):! NAMARR +NAM+APP; S(13):
Z=3; ZP=6
L12: P=P2+3; CNAME(Z,4)
->L10 UNLESS A(P)=2; PRECP=PREC
TYPEP=TYPE
KK=P+2; P=P1+1; CNAME(ZP,4)
L14:
P=KK; ->L1 IF PREC=PRECP AND TYPE=TYPEP
FAULT(83); ->L1
S(6): ! ARRAYNAME-NO APP
S(14): !NAMARRAYNAME-NO APP
Z=12; ZP=11; ->L12
L201:
->S(6) IF ARR=1 AND NAM=1 AND A(P+1)=2
Z=15; ZP=14; ->L12
L101: P=P1+1; CNAME(13,1); ! ASSIGNMENTS TO RECORDNAMES
PRECP=PREC; TYPEP=TYPE; JJJ=K;
->L10 UNLESS J=0 AND NAM=1
REG=FINDPP; ->L31 IF REG=0
DUMP(0,REG,DISP,INDEX,BASE); ! ADDRESS OF LHS TO SAFE PLACE
P=P2+3; CNAME(13,1); ! RHSIDE
->L102 IF BASE=GLA AND J=0; ! COMMON OR GARDEN ROUTINE
PSS(X'D2',16,REG,0,BASE,DISP)
->L103 IF J=14; ! EXTERNAL ROUTINE
L110: REGISTER(REG)=0; KK=P+2
FROM2(JJJ,Z); FROM2(K,ZP)
FAULT(83) UNLESS Z=ZP
->L14
L102: DUMP(2,2,DISP,INDEX,BASE); ! PICK UP RT ADDR
PRX(X'5A',2,0,GLA,28); ! RELOCATE
PCONST(X'180C181D'); ! LR 0,12 LR1,13 PERM AND GLA
PRR(X'18',3,REG); ! CUNNING PTR TO ENVRMNT
PRX(X'90',0,9,REG,0); ->L110; ! STUFF OFF + ENVRMNT
L103: PRX(X'50',9,0,REG,12); ->L110; ! EXTRNS DUMMY ENVRMNT
L1: END
ROUTINE CUI(BYTEINTEGER CODE)
!%SHORTROUTINE
INTEGER KK,JJ,QQ
SWITCH SW(1:11)
->SW(A(P))
SW(1): P=P+1; MARKER1=P+A(P); !(NAME)(APP)(RESTOFUI)
->L3 IF A(MARKER 1)=1
P=P+1; CNAME(0,0); P=P+1; ->L1
L3: ASSIGN(P,MARKER1+1); ->L1
SW(2): !->L<NAME><EXRN>
NMDECS(LEVEL)=1
COPY TAG(A(P+1))
PTYPEP=PTYPE
KK=K; P=P+2
->L200 IF OLDI=LEVEL AND TYPE=6
FAULT(4);SKIP EXP; ->L1
L200: CSEXP(1,1);PTYPE=PTYPEP; UNPACK
FROM LIST(KK,QQ,JJ)
QQ=QQ-CODEBASE(LEVEL)
->L205 IF CHECKSP=0
L201: LOADAD( 2,10,0,QQ);PPJ(7); ->L1
L205: JJ=8+QQ-JJ*BYTES(PREC); !@ SW(0)
->L201 UNLESS 0<=JJ<=4095
->L210 IF PREC=0
PLANT(X'1A11');KK= X'48'; !AR_1,1
L207: PRX(KK,1,1,10,JJ); !L(H)_1,JJ(1,10)
PCONST(X'47F1A000');->L1; !BC_15,0(1,10)
L210: PCONST(X'89100002');KK= X'58';->L207;! SLL_1,2
SW(3): ! '->L'(LABEL)
NMDECS(LEVEL)=1
K=A(P+2)+(A(P+1)-1)<<14
PJ(MASK,K); P=P+3; ->L1
SW(4): !PRINT TEXT
K=(A(P+1)+2)//2; P=P+1; PPJ(30)
CYCLE KK=1,1,K; PLANT(A(P)<<8!A(P+1))
P=P+2; REPEAT; ->L1
SW(5): !RETURN
FAULT(30) UNLESS FLAG(LEVEL)=10000 OR PERM=1
P=P+1
L6: PSS(X'D2',4,GLA,20,RBASE,0) IF DIAGS1=1
COMMENT CHECK FOR REGISTER VARS & UPDATE CORE COPY
CYCLE KK=5,1,8
IF 0#UVARREG(KK)<LEVEL THEN PRX(X'50',KK,0,RBASE,KK<<2)
REPEAT
PRX(X'98',4,15,RBASE,16); ! LM OLD REGISTERS
R13=0; PRR(7,15,LINK); ->L1; ! BR LINK
SW(6): ! %RESULT =EXPR
P=P+1; KK=FLAG(LEVEL)
FAULT(31) UNLESS KK>10000
->L61 IF KK=10002
->L62 IF KK=10032
->L63 IF KK=10005
CSEXP(1,1); ->L6
L61: CSEXP(2,2); ->L6
L62: CSEXP(2,3); ->L6
L63: CSTREXP(1); ->L6
SW(7):SW(8): ! STOP & MONITORSTOP
PPJ(6*(A(P)-6)); P=P+1; ->L1
SW(9): SFLABEL=SFLABEL-1
PUSH(SBR(LEVEL),CODE,SFLABEL)
PUSH(CYCLE(LEVEL),0,0)
->L1
SW(11): ! %QUERIES (ONOFF)
KK=2-A(P+1); P=P+2
PSI(X'92',KK,GLA,1); ->L1
SW(10): PPJ(31); P=P+1; ; ! MONITOR
L1: END
ROUTINE CRFORMAT
!%SHORTROUTINE
INTEGER LENGTHP,QQQ,REP,CODE
K=A(P+1);TEST NST
J=0;PTYPE=4;OPHEAD=NEWCELL
JJJ=OPHEAD;STORE TAG(K,JJJ)
P=3;Q=0;INC=4;INCP=0
! INC COUNTS ALONG RECORD FORMAT DOPEVECTOR..INCP BYTES FROM RECORDHD
->L101 IF A(P)=2; ! NO FPP
L1: P=P+1; COMPILE FORMAL PARAMETER
LENGTHP=ACC-1; LENGTHP=3 IF ACC>8
L2: ->L3 IF INCP&LENGTHP=0; INCP=INCP+1; ->L2
L3: CYCLE REP=1,1,A(P); P=P+1
CODE=255; LENGTHP=ACC
->L11 IF ROUT=1
->L12 IF TYPE=3;QQQ=INCP
->L4 UNLESS TYPE=5
CODE=250; LENGTHP=ACC-1; QQQ=INC
L4: INSERT AFTER(OPHEAD,PTYPE<<4!A(P)<<20,QQQ)
PSI(X'92',CODE,RBASE,N+INC)
PSI(X'92',LENGTHP,RBASE,N+INC+1)
Q=Q+1
INC=INC+4; INCP=INCP+ACC
->L15
L11: QQQ=NEWCELL; REPLACE BOTH(QQQ,INCP,100)
FAULT(41) UNLESS PTYPE=11000; ! FUNCTIONS TOO DICEY AT PRESENT
ACC=40; LENGTHP=ACC; ->L4; ! RT NAME MUST CARRY ENVRMNT
L12: QQQ=NEWCELL; REPLACE BOTH(QQQ,0,INCP); ->L4
L15: REPEAT
P=P+1; ! P ON REST OF FP LIST
->L101 IF A(P)=2; P=P+1; ->L1
L101: P=P+1
L102: ->L201 IF A(P)=2; ! NO ARRAYS
P=P+2; CLT
NAM= 2*(2-A(P))
ACC=4 IF NAM#0;P=P+1
ROUT=0; ARR=1; PACK(PTYPE)
L103:
PSI(X'92',0,RBASE,N+INC); ! FLAG FOR ARRAYS
DUMP(1,WSPR,N+INC+8,0,RBASE); ! PTR TO DOPE VECTOR
QQ=P; CADCLN(1)
JJ=P; P=QQ+2
REP=P+A(P-1); ! AFTER LAST NAME
L105: INSERT AFTER(OPHEAD,J!PTYPE<<4!A(P)<<20,INC)
INC=INC+16; Q=Q+1
P=P+1; ->L106 IF P=REP
PSS(X'D2',16,RBASE,N+INC,RBASE,N+INC-16); ->L105
L106: P=JJ+2
->L103 IF A(P-1)=1; ->L102; ! P ON RESTOFARRAYLIST
L201: REPLACE BOTH(JJJ,N,Q)
PRX(X'41',1,0,0,Q); ! LA 1,ITEMS
DUMP(5,1,N,0,RBASE); !STH
DUMP(0,1,N,0,RBASE)
PPJ(25); N=N+INC
END
ROUTINE CADCLN(BYTEINTEGER MODE)
!%SHORTROUTINE
! MODE=0 NORMAL DECN, =1 IN RECORD FORMAY, =2 RECORD ARRAY
! P POINTS TO NAMELIST -1
INTEGER Q,QQ,KK,S,JJ,JJJ
Q=P; PTYPEP=PTYPE
L1: P=A(Q+1)+Q+1
KK=0; IF MODE=1 THEN ->L4
PRX(X'50',WSPR,0,GLA,36); ! PTR TO DOPE VECTOR INTO GLA
PSI(X'92',1,GLA,36) IF UNASS=1; ! FLAG TO FILL WITH X'000'
L4: P=P+2; JJ=P; KK=KK+1
SKIP EXP; QQ=TSEXP(JJJ); P=JJ
IF QQ=0 THEN CSEXP(4,1) ELSE CSEXP(1,1)
REGISTER(4)=1; CSEXP(2,1); REGISTER(4)=0
PRR(X'18',1,4) IF QQ=0; ! BOUND PAIR NOW IN R1 & R2
->L41 UNLESS KK=1; S=1
UNLESS MODE=2 THEN START
S=0; PRX(X'41',0,0,0,ACC); FINISH;
PRX(X'90',S,2,WSPR,4*S); ! STM TO DUMP BOUND PAIR & R0
PSI(X'92',3-A(P),WSPR,1); ! MVI TO SET DIMENSION
MOVER(WSPR,16); ->L42
L41: S=(KK&1)<<2
IF S=0 THEN JJJ=8*A(P) ELSE JJJ=16
PRX(X'90',1,2,WSPR,S)
MOVER(WSPR,JJJ)
L42: ->L4 IF A(P)=1; ! FOR NEXT BOUND PAIR
->L5 IF KK<=2
FAULT(37) IF KK>6
PACLOD(27,3,KK); ! L 1,=A(DV)--MVI 1(1),KK
L5: QQ=Q+1; J=KK; PTYPE=PTYPEP; ->L9 IF MODE >=1
CYCLE JJJ=1,1,A(QQ)
K=A(QQ+JJJ); TESTNST; J=KK
STORE TAG(K,N);PPJ(13)
PRX(X'90',0,3,RBASE,N); ! STM 0,3--SAVE ARRAYHEAD
N=N+16; REPEAT
Q=P+2; ->L1 IF A(Q-1)=1
L9: END
ROUTINE CVDECLN
!%SHORTROUTINE
INTEGER LB,UB,ADV,Q,QQ,RANGE,JJJ,KK,DISP0,DISP1
Q=P
P=A(Q+1)+Q+2
CBPAIR(LB,UB)
ADV=N0
ST(N0)=1<<16!ACC
ST(N0+1)=LB
ST(N0+2)=UB
RANGE=UB-LB+1
ST(N0+3)=RANGE; N0=N0+4
FAULT(44) IF LB>UB
PRX(X'41',2,0,GLA,ADV<<2)
PRX(X'41',3,0,0,RANGE)
QQ=Q+1; J=1
CYCLE JJJ=1,1,A(QQ)
N=(N+7)&(-8)
DISP1=N+16
DISP0=DISP1-LB*ACC; FAULT(44) UNLESS 0<DISP0<4095
KK=NEWCELL; REPLACE BOTH(KK,DISP0,N)
PRX(X'41',0,0,RBASE,DISP0)
PRX(X'41',1,0,RBASE,DISP1)
K=A(QQ+JJJ); TESTNST
STORE TAG(K,KK)
PRX(X'90',0,3,RBASE,N)
SET80(DISP1,ACC*RANGE) IF UNASS=1
N=DISP1+ACC*RANGE
REPEAT
P=P+1; IF A(P-1)=1 THEN CVDECLN
N=(N+3)&(-4)
END
ROUTINE CSEXP(INTEGER REG,BYTEINTEGER MODE)
COMMENT MODE=1 FOR INTEGER, =2REAL, =3LONG,=0INTEGER IF PNS
INTEGER C,D,QP,NOP,X,JJ,OPCODE
INTEGER EVALUATE,OPND
SHORTINTEGER OPHEAD
BYTEINTEGER REAL,LONGREAL,REALOP
INTEGER OPERATOR,NOPS,LASTOP
INTEGERARRAY BS,PT,DP(1:2)
INTEGERARRAY OP,OPPREC(0:5)
ROUTINESPEC TEST(INTEGER N)
ROUTINESPEC PLANT(INTEGER A,B,C)
INTEGERFNSPEC FINDR
ROUTINESPEC LOAD(INTEGERNAME N,INTEGER REG,MODE)
ROUTINESPEC PRINT ORDERS
OWNINTEGER N0=1024
QP=0; OPHEAD=0; OPCODE=0
REAL=0; LONGREAL=0; REALOP=0
NOPS=0; LASTOP=0
BEGIN
!%SHORTROUTINE
SWITCH S,SW(1:4)
AFLAG=0; NOP=N0
OP(0)=0; OPPREC(0)=0
->S(A(P)); !SWITCH ON PHRASE (+1)
S(2): !NEGATE
OP(1)=11;
L101: OPPREC(1)=2+OP(1)//6; QP=1; ->L1
S(3): OP(1)=23; ->L101; !INITIAL NOT
S(1):S(4):L1: ! PLUS OR NULL ALTERNATIVE
OPND=A(P+1); P=P+2; QP=QP+1
->SW(OPND); ! SWITCH ON OPERAND
SW(1): !NAME
COPYTAG(A(P))
->REGVAR IF TYPE=8
->L19 IF TYPE=3 AND ARR=0 AND INREG#0
->L171 IF ARR=2 AND A(P+1)=1
->L17 IF 1<=TYPE<=2 AND ARR=0 AND ROUT=0 AND A(P+1)=2=A(P+2)
L10:
->L14 UNLESS TYPE=1 OR(ROUT=1AND TYPE=6AND TSNAME(K)&7=1)
C=P; ->L11 IF QP>1
P=P+1; SKIPAPP; ->L11 UNLESS A(P)=A(P+1)=2
P=C; C=REG
IF REG<=0 THEN START
C=FINDR; REGISTER(C)=0
FINISH
CNAME(2,C); NEST=C; ->L80; ! ONE OPND EXPR
L11: P=C
C=FINDPP; ->L14 IF C=0
CNAME(2,C); NEST=C
->L80 IF QP=1 AND A(P)=2;P=P+1; ! ONE OPND EXPR
L12: ST(N0)=9; ST(N0+1)=C; N0=N0+3
REGISTER(C)=1
->L50
L14: COMMENT OPERAND MUST BE FETCHED AND STORED
CNAME (2,2);NEST =2
IF TYPE=5 THEN START; FAULT(42); TYPE=1; FINISH;
IF TYPE=2 THEN FREG(2)=1 ELSE REGISTER(2)=1
NAM=0;ARR=0;ROUT=0
LONGREAL=1 IF PREC=3
->L80 IF QP=1 AND A(P)=2
L16: ->L15 IF TYPE=1
REAL=1; LONGREAL=1 IF PREC=3
->L161 IF A(P)=2; ! EXPRESSION ENDED
C=PARKF(NEST,PREC)
FREG(NEST)=0
L13: ST(N0)=10; P=P+1
ST(N0+1)=RBASE!(TYPE!PREC<<3!NAM<<6)<<8
ST(N0+2)=C; N0=N0+3; ->L50
L161: ST(N0)=8; ST(N0+1)=NEST+512+PREC<<11
FREG(NEST)=1
N0=N0+3; P=P+1; ->L50
L15: C=NEST
C=PARK(NEST)
REGISTER(NEST)=0 UNLESS NEST=C
->L18 IF C>0; ! IN GENERAL REGISTER
C=|C|; PREC=0; ->L13; ! IN CORE EQUIVALENT TO INTEGER
L18: P=P+1; ->L12
L17: COMMENT OPND HAS BASE REGISTER COVER
ST(N0)=2; ST(N0+1)=I!(TYPE!PREC<<3!NAM<<6)<<8
ST(N0+2)=K; P=P+4; N0=N0+3
REAL=1 IF TYPE=2
LONGREAL=1 IF PREC=3
->L50 UNLESS UNASS=1 AND(PREC=0 OR PREC=3)
->L50 IF NAM=1
PSS(X'D5',BYTES(PREC),I,K,GLA,128); ! CLC V,=X'80808080'
PRX(X'47',8,0,CODER,40); ->L50;;! CHECK ASSIGNED
L171: ->L10 UNLESS A(P+2)=4 AND A(P+3)=2 AND A(P+4)=9
->L10 UNLESS A(P+5)<256 AND A(P+6)=2 AND A(P+7)=2=A(P+8)
FROM1(K,C); C=C+BYTES(PREC)*A(P+5)
->L10 UNLESS 0<C<4096; K=C; P=P+6; ->L17
L19: ->L14 UNLESS A(P+1)=2 AND A(P+2)=1; ! NO APP BIUT ENAME
P=P+3; FROM1(K,FNAME); I=INREG
K=DISPLACEMENT(FNAME)
->L191 IF I=-1; UNPACK
->L17 IF ARR=0 AND ROUT=0 AND 1<=TYPE<=2 AND A(P+1)=2C
=A(P+2); ! NO APP OR SECOND ENAME
L191: P=P-3; ->L14
REGVAR: ->L14 UNLESS A(P+1)=2=A(P+2); ! NO APP OR ENAME
P=P+4; ST(N0)=9; ST(N0+1)=K
N0=N0+3; ->L50
SW(2): !CONSTANT
C=A(P); ST(N0+1)=P; ST(N0+2)=A(P+1)
->L24 IF C&7=2
IF C=5 THEN START
FAULT(42); P=P+A(P+1)&X'FE'+1
C=9; FINISH
->L22 UNLESS C>8; !GO UNLESS IMMEDIATE
ST(N0)=0
L21: N0=N0+3; P=P+3;
->L50
L22: ST(N0)=1; P=P+1; ->L21
L24: REAL=1; P=P+2; ->L22
SW(3):SW(4): ! SUB EXPRESSION
D=0; D=1 IF MODE=1 OR LASTOP=12; ! INTEGER EXPONENTS
CSEXP(0,D)
->L32 UNLESS OPND=4
D=16*TYPE
D=48 IF TYPE=2 AND PREC=0
PRR(D,NEST,NEST); !DEAL WITH MOD SIGNS
L32: LONGREAL=1 IF PREC=3
->L80 IF QP=1 AND A(P)=2; !ONE OPD EXPRESSION
->L16 ; !TO STORE RESULT
L50: COMMENT DEAL WITH OPERATOR
->L60 IF A(P-1)=2; !EXPRESSION FINISHED
OPERATOR=A(P)
IF OPERATOR=12 THEN START; ! '.'
FAULT(42); OPERATOR=2; FINISH; ! CHANGE TO +
OPERATOR = 6 IF OPERATOR=13; !%NULL == *
REALOP=1 IF OPERATOR=1 OR OPERATOR=8
OPERATOR=12 IF OPERATOR=1
NOPS=NOPS+1; LASTOP=OPERATOR
C=PRECEDENCE(OPERATOR)
L51: ->L52 IF C>OPPREC(QP-1); !OPERATOR MAY BE STORED
QP=QP-1
ST(N0)=OP(QP)
N0=N0+3; ->L51; !UNLOAD STACK
L52: OP(QP)=10+OPERATOR
OPPREC(QP)=C; ->L1; !FOR NEXT OPERAND
L60: COMMENT - END OF EXPRESSION
CYCLE JJ=QP-1,-1,0
ST(N0)=OP(JJ)
N0=N0+3; REPEAT; !EMPTY OPERATOR STACK
REAL=1 IF MODE#1 AND REALOP=1
->L70 IF REAL=1
COMMENT - CAN EVALUATE AS INTEGER
PRINT ORDERS
L61: ->L71 IF MODE>=2
L72: D=1; REG=REG-1 IF 0>=REG
LOAD(D,REG,REAL) UNLESS REAL=0 AND 0>REG AND DP(1)<0 C
AND REGISTER(BS(1))<0; ! RESULT IN LOCKED REG
NEST=BS(1)
IF REAL=1 THEN FREG(NEST)=0 ELSE START
REGISTER(NEST)=0 IF REGISTER(NEST)>0; FINISH
PTYPE=1+30*LONGREAL+REAL
N0=NOP; UNPACK; ->L99
L70: COMMENT EVALUATE AS REAL
FAULT(24) IF MODE=1; ! REAL IN INTEGER EXPRN
LONGREAL=1 IF MODE=3
EVALUATE=16*LONGREAL
PRINT ORDERS
->L72
L71: LONGREAL=1 IF MODE=3
REAL=1
EVALUATE=16*LONGREAL
->L72
L80: COMMENT SINGLE OPERAND EXPRESSION
BS(1)=NEST; DP(1)=-1
PT(1)=PREC<<3!TYPE
AFLAG=0; P=P+1
FAULT(24) IF TYPE=2 AND MODE=1
->L61 IF TYPE=1; ->L71
L99: END;->L99
INTEGERFN FINDR
!%SHORTROUTINE
INTEGER I
->L2 IF 0>=REG
I=REG; ->L1 IF REGISTER(I)=0
L2: CYCLE I=1,1,RBASE-1
->L1 IF REGISTER(I)=0
REPEAT; FAULT(241)
L1: REGISTER(I)=1; RESULT=I; END
INTEGERFN FINDPR
INTEGER I
CYCLE I=0,2,6
->FOUND IF REGISTER(I)=0 AND REGISTER(I+1)=0
REPEAT
FAULT(242)
FOUND: REGISTER(I)=1
REGISTER(I+1)=1
RESULT=I
END
INTEGERFN FIND FR
!%SHORTROUTINE
INTEGER I
CYCLE I=6,-2,0
->L1 IF FREG (I)=0
REPEAT; FAULT(242)
L1: FREG(I)=1; RESULT=I
END
ROUTINE LOAD(INTEGERNAME N,INTEGER REG,MODE)
!%SHORTROUTINE
INTEGER I,X
INTEGERNAME BSI,DPI,PTI
I=N; ->NOCHOICE UNLESS I=0
I=1; ->CHOSEN IF DP(1)<0 AND REGISTER(BS(1))>=0
I=2; ->CHOSEN IF DP(2)<0 AND REGISTER(BS(2))>=0
->CHOSEN IF MODE=0 AND (PT(2)=255 OR PT(2)&24=8)
->CHOSEN IF MODE=1 AND (PT(2)&7=1 OR (EVALUATE>0 AND C
PT(2)&24=0)); I=1
CHOSEN: N=I
NOCHOICE:BSI==BS(I);DPI==DP(I);PTI==PT(I)
->SHORT CONST IF MODE=0 AND PTI=255
TEST(I) IF MODE=1 OR PTI&64#0
->INREG IF DPI<0
->NOFIND IF REG>=0
IF MODE=0 THEN REG=FINDR ELSE REG=FINDFR
NOFIND: X=MODE<<3! (PTI>>2&6)+2
DUMP(X,REG,DPI,0,BSI) ; ->L98 ;! PICK UP VARIABLE
INREG: ->L90 IF MODE=1
->L99 IF BSI=REG
->LOCKED IF REGISTER(BSI)<0
->L99 IF 0>REG
REGISTER(BSI)=0
SWOP: PRR(X'18',REG,BSI); ->L98
LOCKED: REG=FINDR IF 0>REG; ->SWOP
L90: ->L91 IF BSI=0; !CURRENTLY CAN LEAVE NOTHING INFR0
->L99 IF BSI=REG OR 0>REG
L91:
REG=FINDFR IF 0>REG
PRR(X'38'-EVALUATE,REG,BSI)
FREG(BSI)=0; ->L98
SHORT CONST: REG=FINDR IF 0>REG
DUMP(0,REG,DPI,0,0); !LOAD ADDRESS
L98: BSI=REG; DPI=-2
L99: END
ROUTINE PLANT(INTEGER OPCODE,R1,R2)
!%SHORTROUTINE
INTEGER BSR2
BSR2=BS(R2);R1=BS(R1)
->RROP IF DP(R2)<0
IF PT(R2)&24=16 AND X'5A'<=OPCODE<=X'5B' THEN C
OPCODE=OPCODE-16; ! CAN PLANT HALF LENGTH OP
PRX(OPCODE,R1,0,BSR2,DP(R2));->L99
RROP: PRR(OPCODE-64,R1,BSR2)
IF REAL=1 THEN FREG(BSR2)=0
IF REAL=0 AND REGISTER(BSR2)>0 THEN REGISTER(BSR2)=0
L99: END
ROUTINE TEST(INTEGER N)
!%SHORTROUTINE
COMMENT INSPECTS OPERAND - MAKES TYPE CONVERSIONS ETC.
INTEGER X
INTEGERNAME LBASE,LDISP,LPTYPE
BYTEINTEGER LPREC
LPTYPE==PT(N); LDISP==DP(N)
LBASE==BS(N); LPREC=LPTYPE>>3&3
->SHORTCONST IF LPTYPE=255
->START UNLESS LPTYPE&64 #0 ; ! GO UNLESS NAME TYPE
RP13=R13;R13=LBASE<<12!LDISP
PRX(X'58',LINK,0,LBASE,LDISP) UNLESS R13=RP13
LPTYPE=LPTYPE&31; LBASE=LINK;LDISP=0
START: ->FLOATING IF REAL#0
->FINISH IF LPREC=0 OR (LPREC=2 AND 12<=OPCODE<=13)
PICKUP: LOAD(N,-1,0)
LPREC=0; ->FINISH
SHORTCONST: LPREC=0; ->PICK UP IF REAL=0
->INGLA IF 0<=LDISP<=2; ! THESE 3 ALWAYS IN THE GLA
A(-2)=9; A(-1)=LDISP
LDISP= SORT CONST(-2,LONGREAL,2);! COMPILE TIME FLOAT
L1: LBASE=GLA; ->FINISH
INGLA: LDISP= 8*LDISP+40; ->L1
FLOATING:->FLOAT IT IF LPTYPE&7=1 ; ! INTEGER - RUN TIME FLOAT
->FINISH IF LPREC=3 OR EVALUATE=0
COMMENT MUST STRETCH A 32 BIT REAL
FREG(LBASE)=1 IF LDISP<0
X=FINDFR;PRR(X'2B',X,X); !FIND AND CLEAR REGISTER
IF LDISP<0 THEN START
PRR(X'38',X,LBASE); ! LER_X,LBASE
FREG(LBASE)=0;
FINISH ELSE PRX(X'78',X,0,LBASE,LDISP)
LBASE=X;LDISP=-2; ->FINISH
FLOATIT: LOAD(N,1,0);PPJ(43); REGISTER(1)=0
LBASE=0; LDISP=-2
FINISH: LPTYPE=(1+REAL)!LPREC<<3
IF LONGREAL=1 AND REAL=1 THEN LPTYPE=LPTYPE!24
END
ROUTINE MULT(INTEGERNAME RESULT)
!%SHORTROUTINE
INTEGER I,K
CYCLE I=1,1,2
->L30 IF PT(I)=255 AND DP(I)=2
->L1 IF DP(I)<0 AND REGISTER(BS(I))>=0
L5: REPEAT
I=1; K=FINDPR
LOAD(I,K+1,0); ->L11
L1: ->L14 IF BS(I)&1=1 AND I>0 AND REGISTER(BS(I)-1)=0
->L12 IF BS(I)&1=0 AND REGISTER(BS(I)+1)=0
->L5
L12: K=BS(I); REGISTER(K+1)=1
PRR(X'18',K+1,K); ->L13
L14: REGISTER(BS(I)-1)=1
L11: BS(I)=BS(I)-1
L13: TEST(3-I); PLANT(X'5C',I,3-I);! MULTIPLY
->L15 IF CHECKSP=0
PRX(X'8F',BS(I),0,0,32); ! SLDA ?,32
L15: RESULT=257+BS(I)-CHECKSP
REGISTER(BS(I)+CHECKSP)=0
AFLAG=CHECKS
->L99
L30: K= 3-I; LOAD(K,-1,0)
PRR(X'1A',BS(K),BS(K))
AFLAG=1; RESULT=256+BS(K)
L99: END
ROUTINE DIV(INTEGERNAME RESULT)
!%SHORTROUTINE
INTEGER I,K
->L3 IF DP(1)<0
L1: K=FIND PR
L2: I=1; LOAD(I,K,0); ->L10
L3: ->L4 IF BS(1)&1=0 AND REGISTER(BS(1)+1)=0
K=FINDPR; ->L2
L4: ->L1 IF REGISTER(BS(1))<0; !A CLAIMED REGISTER
REGISTER(BS(1)+1)=1; K=BS(1)
L10: PRX(X'8E',K,0,0,32); ! SRDA K,32
TEST(2); PLANT(X'5D',1,2); ! DIVIDE
->L20 IF CHECKSP=0
->L20 IF OPCODE=17; PRR(X'12',K,K); ! LTR
PRX(X'47',7,0,CODER,64); ! BC 7,64(CODE)
L20: REGISTER(K)=0
AFLAG=0;RESULT=K+257
END
ROUTINE PRINT ORDERS
!%SHORTROUTINE
SWITCH S(0:49)
INTEGER C,D,LAST,KK
LAST=N0-6
CYCLE JJ=NOP,3,LAST
OPCODE=ST(JJ)
->SKIP IF 10>=OPCODE OR OPCODE=24
IF OPCODE=11 OR OPCODE=23 THEN KK=1 ELSE KK=2
CYCLE KK=KK,-1,1
POP(OPHEAD,C,DP(KK))
PT(KK)=C>>8; BS(KK)=C&15
REPEAT
SKIP: ->S(OPCODE+25*REAL)
S(0): ! INTEGER CONST<4096 IN INT EXP
S(25): ! INT CONST<4096 IN REAL EXRRN
D=X'FF00'; C=ST(JJ+2);->L99
S(1): ! LONG INT CONST IN INT EXPRN
C=SORT CONST(ST(JJ+1),0,1)
D=256+GLA;->L99
S(26): ! LONG ICONST IN EXPRN
D=512+GLA; D=D+3<<11 IF LONGREAL=1
C=SORT CONST(ST(JJ+1),LONGREAL,2);->L99
S(2): S(27): !LOCAL VARIABLE
D=ST(JJ+1); C=ST(JJ+2); ->L99
S(33): ! REAL IN FR
D=ST(JJ+1); C=-2; ->L99
S(9): S(34): !(INTEGER) IN G.R.
D=256+ST(JJ+1); C=-2; ->L99
S(10): S(35): !PARKED IN CORE
C=ST(JJ+2);D=ST(JJ+1)
IF REAL=1 AND D>>8&24=24 THEN PUSH(LWSP(LEVEL),0,C) ELSE C
PUSH(WSP(LEVEL),0,C); ->L99
S(11): ! NEGATE IN INTEGER EXPRN
->L109 UNLESS PT(1)=255 AND DP(1)=1
AFLAG=0; D=256+GLA; C=16; ->L99 ;! OPTIMISE (-1)
S(36): ! NEGATE IN REAL EXPRN
L109: C=1; D=X'13'+REAL*(32-EVALUATE)
LOAD(C,-1,REAL)
AFLAG=1
PRR(D,BS(1),BS(1)); ! LCR,LCER,LCDR
L111: D=(REAL+1+24*LONGREAL)<<8!BS(C)
C=-2; ->L99
S(23): !INITIAL NOT
C=1; AFLAG=2; LOAD(C,-1,0)
PRX(X'57',BS(1),0,GLA,16); ->L111
S(12): S(37): !ADDITION
AFLAG=1;D=X'5A'
L125: C=0
L126: LOAD(C,-1,REAL); TEST(3-C)
D=D+REAL*(X'20'-EVALUATE)
PLANT(D,C,3-C);->L111
S(13): S(38): !SUBTRACTION
AFLAG=1; D=X'5B';C=1
->L126 UNLESS REAL=0 AND PT(2)=255 AND 1<=DP(2)<=2
AFLAG=0; LOAD(C,-1,0)
PRR(6,BS(1),0) IF DP(2)=2
PRR(6,BS(1),0);->L111 ;!BCTR TO SUBTRACT 1 OR 2
S(14): D=X'57'; !EXCLUSIVE OR
L141: AFLAG=2; ->L125
S(15): D=X'56';->L141; !OR
S(16): MULT(D); C=-2; ->L99
S(17):S(18): DIV(D); C=-2; ->L99
S(19): D=X'54';->L141; !AND
S(20):S(21): !SLL(21) AND SLR
D=0
C=1; LOAD(C,-1,0)
D=1 IF PT(2)=255
C=2; LOAD(C,-1,0) IF D=0
PRX(X'89'+OPCODE-21,BS(1),0,BS(2),D*DP(2))
REGISTER(BS(2))=0 IF D=0
C=1; AFLAG=0; ->L111
S(22): CYCLE C=1,1,2
LOAD(C,-1,0)
DUMP(1,BS(C),28+4*C,0,GLA)
REGISTER(BS(C))=0; REPEAT
->L221 IF REGISTER(0)#0
C=2; AFLAG=0
REGISTER(0)=1
PPJ(15); BS(2)=0; ->L111; ! RESULT IN R0
L221: C=FINDR; D=FINDR; PRR(X'18',C,0)
PPJ(15); PRR(X'18',D,0); PRR(X'18',0,C)
REGISTER(C)=0; C=2; AFLAG=0; BS(2)=D; ->L111
S(39):S(40):S(42):S(44):S(45):S(46):S(48): !INTEGER OP IN REAL
FAULT(24); ! INTEGER OP IN REAL
IF OPCODE=23 THEN OPCODE=36 ELSE OPCODE=37; ! ¬ ->L - ...
->S(OPCODE); ! ! TREAT OTHERS AS +
S(41): !REAL MULT
D=X'5C';C=0
L410: AFLAG=0; ->L126
S(43): ! REAL DIVISION
D=X'5D';C=1;->L410
S(47): !REAL EXPONENTIATION
C=1; LOAD(C,-1,1)
->L222 IF PT(2)=255 AND DP(2)=2; ! OPTIMISE **2
PRR(X'38'-EVALUATE,0,BS(1))
C=2; FAULT(39) UNLESS PT(2)=255 OR PT(2)&7<=1
LOAD(C,1,0); PPJ(36)
REGISTER(1)=0
PRR(X'38'-EVALUATE,BS(1),0)
C=1;->L111
L222: PRR(X'3C'-EVALUATE,BS(1),BS(1))
C=1; ->L111
L99: PUSH(OPHEAD,D,C) UNLESS JJ=LAST
S(24):S(49): REPEAT
DP(1)=C;PT(1)=D>>8;BS(1)=D&15 ;! FINAL RESULT
END
L99: END; ! OF ROUTINE CSEXP
INTEGERFN SORT CONST(INTEGER P,LONG,TYPE)
!%SHORTROUTINE
LONGREAL CVALUE
INTEGER I,K
->L50 IF TYPE=2
{ FAULT(24) %IF A(P)&7#1 ; ! This is faulting erroneously on the sparc
IF A(P)=9 THEN I=A(P+1) ELSE FROMAR4(P+1,I)
L40: K=N0
ST(K)=I; N0=N0+1
RESULT =K<<2
L50: CVALUE=0
->L60 UNLESS A(P)&7=1
IF A(P)=9 THEN I=A(P+1) ELSE FROMAR4(P+1,I)
CVALUE=I;->L70
L60: FROMAR8(P+1,CVALUE)
L70: ->L75 IF LONG#0
I=INTEGER(ADDR(CVALUE)); ->L40
L75: K=(N0+1)&(-2)
ST(K)=INTEGER(ADDR(CVALUE))
ST(K+1)=INTEGER(ADDR(CVALUE)+4)
N0=K+2
RESULT=K<<2
END
ROUTINE CSTREXP(INTEGER REG)
!%SHORTROUTINE
COMMENT EVALUATES STRING EXPR USING CURRENT
COMMENT WORKAREA AND 1 SUBROUTINES LEAVES ADDR IN
COMMENT REG -VE IF STRING MUST BE MOVED TO WK.ARREA
INTEGER JJ,QQ,KK,WKAREA,PP
SETEX UNLESS STRINST#0
PP=P
JJ=TSEXP(QQ); ->L71 IF JJ=20 AND REG>=0
P=PP; REG=|REG|
WKAREA=GET STR WSP
PSI(X'92',0,RBASE,WKAREA); ! CLEAR WORK AREA
->L2 IF A(P)=4
L1: FAULT(71)
L4: P=PP; SKIP EXP; ->L99
L5: FAULT(72); ->L4
L2: ->L10 IF A(P+1)=2
->L1 UNLESS A(P+1)=1 ; !NAME
P=P+2; CNAME(2,1)
->L1 UNLESS TYPE=5;->L20
L10: P=P+2;->L14 IF A(P)=5
->L1 UNLESS A(P)=9 AND A(P+1)<127
->L11 IF A(P+1)=0
PRX(X'41',1,0,0,A(P+1))
P=P+2;->L20
L11: P=P+2; ->L21; ! NULL STRING
L14: COMMENT STRING CONSTANT PUT IN CODE CF (TEXTTEXT)
KK=(CA+6+A(P+1)-CODEBASE(LEVEL))&(-2)
QQ=0;->L15 IF KK<4095
KK=KK+4;QQ=1
PRX(X'58',1,GLA,0,PAGENO(KK)<<2)
L15: PRX(X'45',1,10,QQ,KK&4095)
P=P+1; CYCLE KK=1,1,(A(P)+2)//2
PLANT(A(P)<<8!A(P+1))
P=P+2;REPEAT
L20: PRX(X'41',2,RBASE,0,WKAREA)
PPJ(26)
L21: ->L90 IF A(P)=2; ! END OF EXPRN
->L5 UNLESS A(P+1)=12
P=P+1;->L2
L71: DUMP(2,REG,K,I,0); ->L99
L90: P=P+1
PUSH(STR WSP(LEVEL),0,WKAREA)
PRX(X'41',REG,0,RBASE,WKAREA)
L99: PTYPE=5; UNPACK; END
ROUTINE CRES(INTEGER MODE,LAB)
ROUTINESPEC SKIP NAME
ROUTINESPEC FAIL(INTEGER MASK)
!%SHORTROUTINE
INTEGER P1,P2,P3,W,SEXPRN
COMMENT MODE=0 UNCONDITIONAL # 0 CONDITIONAL
COMMENT ENTER WITH ADDR OF LHS IN R1 AND P ON PLUS''
SEXPRN=0;W=GET DBLE WRD
P1=P;->L1 IF A(P)=4
L1000: P=P1;SKIP EXP
FAULT(74);->L99
L1: ->L1000 UNLESS TYPE=5
PRR(X'1B',2,2) ;!SR_2,2
PRX(X'90',1,2,RBASE,W) ;!STM_1,2,W(RBASE)
P2=-1;P=P+2
->L10 IF A(P-1)=3 ; !SUB EXPRESSION
->L1000 UNLESS A(P-1)=1
L3: P2=P;SKIP NAME
->L50 IF A(P)=2 ; !END
->L1000 UNLESS A(P+1)=12 ; !ONLY - PERMITTED
->L1000 UNLESS A(P+2)=3; P=P+3
L10: CSTREXP(-4); ! STRING MUST GO TO WK.AREA
! IN CASE OF SIDE EFFECTS
SEXPRN=SEXPRN+1
PRX(X'98',1,2,RBASE,W)
PPJ(27)
FAIL(7)
PRX(X'90',1,2,RBASE,W); ! SAVE R1 AND R2 FOR LATER
->L15 IF P2<0
P3=P;P=P2
CNAME(1,4)
FAULT(71) UNLESS TYPE=5
P=P3
L12: ->L1000 UNLESS A(P)=1 AND A(P+1)=12 AND A(P+2)=1
P=P+3;->L3
L15: PSI(X'95',0,4,0)
FAIL(7);->L12
L50: ->L1000 IF SEXPRN=0
PRX(X'98',1,2,RBASE,W); ! SAVE R1 AND R2 FOR LATER
PPJ(37)
P3=P;P=P2
CNAME(1,4)
FAULT(71) UNLESS TYPE=5
P=P3+1
L99: PUSH(LWSP(LEVEL),0,W)
RETURN
ROUTINE SKIP NAME
L1: P=P+1;SKIP APP
P=P+1;RETURN IF A(P-1)=2
P=P+1;->L1
END
ROUTINE FAIL(INTEGER MASK)
IF MODE=0 THEN PRX(X'47',MASK,0,CODER,152) ELSE C
P LOCAL JUMP(MASK,LAB)
END
END
ROUTINE CCOND(INTEGER IU,NEARLAB,FARLAB)
COMMENT IU=0 FOR IF =1 FOR UNLESS
ROUTINESPEC CCC
ROUTINESPEC CSC(INTEGERNAME FLAB)
COMMENT P ON ALT OF (SC)
INTEGER T,C,FAILPT,BASE,DISP
INTEGER JNPORFP,TP,CLAUSES
CLAUSES=0
T=A(P+1+A(P+1))
T=0 IF T=3; !0=SC 1=%AND 2=%OR
TP=T ; TP=TP+1 IF T=0
IF IU!!(TP-1)=0 THEN JNPORFP=FARLAB ELSE JNPORFP=NEARLAB
FAILPT = 0; CCC ; ->L99
ROUTINE CCOMP(INTEGER C)
!%SHORTROUTINE
! C=1 FIRST TIME, 2 SECOND
INTEGER M,L,Q,R,T
OWNBYTEINTEGERARRAY FCOMP(1:7)=8,10,2,7,12,4,7;
OWNBYTEINTEGERARRAY BCOMP(1:7)=8,12,4,7,10,2,7;
SWITCH SW(-10:2)
M=A(P)
P=P+1; ->SW(C) UNLESS M=8
FAULT(73); SKIP EXP; ->L1
SW(-10): ! FIRST OPERAND SIMPLE STRING
CSTREXP(1); NEST=1; DUMP(2,2,DISP,0,BASE); ->L161
SW(-9): T=P; R=TSEXP(Q)
->REG1 IF R=10 AND A(P)=2
->REG2 IF R=11 AND A(P)=2
P=T; CSEXP(0,0)
->REG3 IF TYPE=2
PRR(X'19',DISP,NEST); ->L20; !CR
REG1: Q=X'59'; ->RCOM
REG2: Q=X'49'
RCOM: PRX(Q,DISP,0,I,K); ->L20; !C OR CH
REG3: PRR(X'18',1,DISP); ->L37 ; !TO FLOAT ETC
SW(-5): !FIRST OPERAND LONG REAL
CSEXP(0,3); Q=X'69'; ! COMPILE LONG
L51: PRX(Q,NEST,0,BASE,DISP); ->L21
SW(-4): !FIRST OPERAND SHORT REAL
Q=X'79'; CSEXP(0,2)
L40: ->L51 IF PREC=0; !SHORT EXPRESSION
PRR(X'2B',0,0)
PRX(X'78',0,0,BASE,DISP); !STETCH IST OPN
PRR(X'29',0,NEST); ->L20
SW(-3): !FIRST OPERAND ASHORT CONSTANY
CSEXP(0,0)
->L30 IF VALUE=0
->L36 IF TYPE=2
R=2
R=1 IF NEST=2
DUMP(0,R,VALUE,0,0); !LOAD ADDR FOR CONSTANT
L29: PRR(X'19',R,NEST); ->L20; !CR2,1
L30: !COMPARISONS WITH ZERO
->L35 IF TYPE=5
->L32 IF AFLAG=1
->L31 IF TYPE=2
->L32 IF AFLAG=2 AND 7<=FCOMP(M)<=8
L31: PRR((TYPE-1)*(2-PREC&1)*16+X'12',NEST,NEST); !LTR,LTER,LTDR
L32: ->L21 IF C=-3; ->L20
L35: PSI(X'95',0,NEST,0); ->L20; ! NULL STRING LENGTH=0
L36: DUMP(0,1,VALUE,0,0);
L37: PPJ(43);
PRR((1-PREC&1)*16+X'29',0,NEST); ! CDR OR CER
->L20
SW(-2): Q=X'49'; !OPERAND SHORT
L24: CSEXP(0,0); ->L25 IF TYPE=2
PRX(Q,NEST,0,BASE,DISP); ->L21; ! C OR CH
L25: R=2; R=6 IF Q=X'49'; ! HERE FOR REALS
L26: DUMP(R,1,DISP,0,BASE); ->L37
SW(-1): ! FIRST OPERAND A BYTE
T=P; R=TSEXP(Q); L=1
->L18 IF R=11 AND A(P)=2
->L19 IF R=1 AND A(P)=2
P=T;CSEXP(0,0); ->L14 IF TYPE=2
R=2; R=1 IF NEST=2
DUMP(4,R,DISP,0,BASE); ->L29
L14: R=4; ->L26
L18: PSS(X'D5',L,BASE,DISP,I,K); ->L20; ! CLC COMPARISONS
L19: PSI(X'95',Q,BASE,DISP);->L20; !CLI FOR BYTE/INTEGER
SW(0): !FIRST OPERAND INTEGER
T=P; R=TSEXP(Q); L=4
->RSTORE UNLESS R=10 AND A(P)=2
->L18 IF 7<=FCOMP(M)<=8
RSTORE: P=T; Q=X'59'; ->L24
SW(1): !FIRST OPERAND EXPRESSION
SW(2): !2ND HALT OF DOUBLE SEDED
T=P; PTYPEP=PTYPE; R=TSEXP(VALUE)
PTYPE=PTYPEP;UNPACK
->L30 IF R=1 AND VALUE=0 AND(A(P)=2 OR C=2)
->L160 IF TYPE=5
->L150 IF TYPE=2
->L120 IF R=0 OR 14<=R<=15 OR(A(P)=1 AND C=1)
->L130 IF UNASS=1 OR R=100 OR R=11 OR R<=2
->L131 IF R=50; ! REGISTER VARIABLE
Q=X'59'; Q=X'49' IF R=12
PRX(Q,NEST,0,I,K); ->L20
L130: !1ST OPND INTEGER IN NEST-2ND OPN SIMPLE INTEGER EXPRN
R=NEST; REGISTER(R)=1 IF REGISTER(R)=0
P=T; CSEXP(0,1)
REGISTER(R)=0 IF REGISTER(R)>0; ->L29
L131: PRR(X'19',NEST,K); ->L20
L120: !1ST OPND INTEGER EXPRN IN NEST-SECOND OPND UNKNOWN
Q=PARK(NEST); P=T
CSEXP(0,0); ->L122 IF TYPE=2
UNPARK(X'59',NEST,Q); ->L21
L122: UNPARK(X'58',1,Q); ->L37; ! TO FLOAT FIRST OPERAND
L150: P=T; Q=PARKF(NEST,PREC); !
->L155 IF PREC=0
CSEXP(0,3); !1ST OPND LONG REAL EXPR
PUSH(LWSP(LEVEL),0,Q)
BASE=RBASE
DISP=Q; Q=X'69'; ->L51
L155: CSEXP(0,2); !1ST OPND SHORT REAL EXPRN
PUSH(WSP(LEVEL),0,Q)
BASE=RBASE;DISP=Q
Q=X'79'; ->L40
L160: COMMENT 1ST OPERAND A STRING EXPRESSION PTR IN NEST
P=T; POP(STR WSP(LEVEL),R,T);! RMEOVE WKAREA WITH STRING%C
!FROM FREE LIST TO PREVENT CORRUPTION
R=PARK(NEST)
CSTREXP(1); NEST=1
UNPARK(X'58',2,R)
PUSH(STR WSP(LEVEL),0,T)
L161: ->L162 UNLESS 7<=FCOMP(M)<=8; ! OPTIMISE = & ¬=
PRX(X'43',3,0,1,0); ! IC TO SET UP FOR EX
PRX(X'44',3,0,GLA,STRINST+6); ->L20; ! EX_3,COMPARISON
L162: PPJ(35); ! GO TO SUBROUTINE FOR COMPARISON
L20: MASK=FCOMP(M); ->L1; ! MASK FOR NORMAL COMPARISON
L21: MASK=BCOMP(M); ! BACKWARDS COMPARISON
L1: END
ROUTINE CCC
!%SHORTROUTINE
INTEGER LINE,FLAB
CSC(FLAB)
C=A(P) ; P=P+1
CLAUSES=CLAUSES+1
->L10 IF T=0 OR(CLAUSES>1 AND C=2)
->L2 IF FAILPT#0
FAILPT=1 ; LINE=1 ; ->L3
L2: LINE=0
L3:
PLOCAL JUMP(MASK,JNPORFP)
UNLESS FLAB=0 THEN START
PUSH(LOCAL LABEL,CA,FLAB)
R13=0 UNLESS R13=SAVE13 AND CHNGE13=0
FINISH
CCC; !FIX NEXT CLAUSE
->L10 IF LINE=0
MASK=MASK!!15 IF JNPORFP=NEARLAB
L10: END
ROUTINE CSC(INTEGERNAME FLAB)
!%SHORTROUTINE
INTEGER LINE,Q,R,S,TP,NEAR
FLAB=0
S=A(P+1+A(P+1))
LINE=S
NEAR=NEARLAB
->START IF T=0 OR(S=2 AND CLAUSES>0)
PLABEL=PLABEL-1; NEAR=PLABEL
START: ->L1 IF A(P)=1
P=P+2
->REDUND IF T=0
->REDUND2 IF T=A(P+1+A(P+1))
FLAB=NEAR UNLESS NEAR=NEARLAB
TP=T-1; ->LAST IF NEAR=NEARLAB
CCOND(TP,NEAR,FARLAB); ->L9
REDUND:CCOND(IU,NEARLAB,FARLAB); ->L9
REDUND2: CCOND(IU,NEARLAB,FARLAB)
MASK=MASK!!15 IF JNPORFP=NEARLAB ;->L9
LAST: CCOND(IU,NEAR,FARLAB)
NEARLAB=0; ->L9
L1: COMMENT CLASSIFY SIMPLE CONDITION AND ACT ACCORDINGLY
P=P+2; S=P; SKIP EXP
->L21 IF A(P)=8; ! RESOLUTION (ALL OCCURRENCES)
P=P+1; Q=TSEXP(R); ! TEST MIDDLE OPERAND FIRST
IF TYPE=3 THEN START
P=P+2; R=COPY RECORD TAG; FINISH
->STR IF TYPE=5
->ZERO IF Q=1 AND R=0 AND A(P)=2; ! ! NOT DOUBLE SIDED
P=S; Q=TSEXP(R); ! TEST LHS
->CONST IF 1<=Q<=2
->SIMPLE IF Q=20
->REGVAR IF Q=50
->STR IF TYPE=5
->NORMAL UNLESS UNASS=0 AND 10<=Q<=15
SIMPLE: BASE=I; DISP=K; CCOMP(10-Q); ->L8
REGVAR: DISP=K; CCOMP(-9); ->L8
STR: P=S; CSTREXP(1); NEST=1; CCOMP(1); ->L8
CONST: VALUE=R; CCOMP(-3); ->L8
L21: P=S+2; ->L22 UNLESS A(S)=4 AND A(S+1)=1
CNAME(2,1)
->L23 IF A(P)=2 AND TYPE=5
L22: P=S; SKIP EXP
L28: P=P+1; SKIP EXP
FAULT(73); ->L8
L23: P=P+2
FLAB=NEAR UNLESS NEAR=NEARLAB
IF T#2 THEN R=JNPORFP ELSE START
IF JNPORFP#FARLAB AND LINE=2 AND CLAUSES>0 C
THEN R=FARLAB ELSE R=NEAR
FINISH
CRES(1,R)
->L28 UNLESS A(P)=2 ; ! NO DOUBLE SIDED RESOLUTION
P=P+1;
MASK=15; ->L10
ZERO: P=S; Q=TSEXP(R); ->SIMPLE IF Q=11; ! CLI FOR BYTE/ZERO
->STR IF TYPE=5
NORMAL: P=S; CSEXP(0,0); CCOMP(1)
L8: P=P+1
->L10 IF A(P-1)=2; ! GO UNLESS DOUBLESIDED
FLAB=NEAR UNLESS NEAR=NEARLAB
->ORCOND IF T=2
R=JNPORFP; ->L7
ORCOND: IF JNPORFP#FARLAB AND LINE=2 AND CLAUSES>0 THEN C
R=FARLAB ELSE R=NEAR
COMMENT LAST DOUBLESIDED IN OR CONDITION IS SPECIAL
L7:
PLOCAL JUMP(MASK!!15,R)
CCOMP(2)
L10: MASK=MASK!!15 IF T=1 OR(T=0 AND IU=0)
L9: END
L99: END ; !OF CCOND
ROUTINE FILL LOCAL JUMPS
!%SHORTROUTINE
INTEGER T,C,J
L1: POP(LOCAL JUMP,T,C)
->L98 IF T=-1
J=FIND(C,LOCAL LABEL)
FAULT(233) IF J=-1
J=J-LOCAL ADDR
PLUG(T+2,J); ->L1
L98: CLEAR LIST(LOCAL LABEL)
END
ROUTINE P LOCAL JUMP(INTEGER MASK,LABEL)
!%SHORTROUTINE
RETURN IF MASK=0
CHNGE13=1 UNLESS SAVE13=R13
->L1 IF LABEL>21000
PJ(MASK,LABEL); ->L99
L1: ->L2 UNLESS LOCAL BASE=0
LOCAL BASE=10; LOCAL ADDR=CODEBASE(LEVEL)
->L2 IF SBFLAG=1 OR 3000+800*COMPILER>CA-CODEBASE(LEVEL)
LOCAL BASE=FIND PP
FAULT(231) IF LOCAL BASE<=0
PRR(5,LOCAL BASE,0); LOCAL ADDR=CA
L2: PUSH(LOCAL JUMP,CA,LABEL)
PRX(X'47',MASK,LOCAL BASE,0,0)
L99: END
ROUTINE CSNAME(INTEGER Z,REG)
INTEGERARRAY B(0:5)
OWNBYTEINTEGERARRAY PLABEL(0:45)=9,9,3,3,
1,14(3),2,3,1,18,4,3,12(2),
33,42,34,35,32,12(16),5,12(8);
OWNBYTEINTEGERARRAY MODE(0:45)=16(2),
0(3),16(3),2,16(2),31,32,0,
18,31,18(3),63,47,23(2),18,31(7),
31,23(2),47(2),18,16,2,23,16(2),
23,0(3);
! TOP 4 BITS OF MODE = NO OF PARAMS BOTTOM 4 ALLOWED Z VALUE
SWITCH SW(0:45)
INTEGER PL,KK,PP,V,JJ
KK=K; JJ=COUNTAPS
PL=PLABEL(KK); PP=P+1; V=MODE(K)
P=P+1; P=P+1 IF V>>4#0
->L1010 IF V&15=15
->L1001 IF V>>4#JJ; V=V&15
->L1002 IF V=0 AND Z#0; ! ROUTINE CALL IN EXPRESSION
->L1003 IF V=2 AND Z#2; ! FN CALLED INCORRECTLY
->L1005 IF Z=0 AND V#0
L1010: ->SW(KK)
L1001: FAULT(19); PRINTNAME(FNAME)
L1000: P=PP; SKIP APP; P=P-1; ->L99
L1002: FAULT(23); ->L1000
L1003: FAULT(29); ->L1000
L1004: FAULT(22); ->L1000
L1005: FAULT(17); ->L1000
L1: PPJ(PL); ->L99
SW(4): CIOCP(1); ->L99; ! SKIP SYMBOL
SW(2): V=10; ! NEWLINE
PRX(X'41',1,0,0,V)
L23: CIOCP(3); ->L99
L21: PRX(X'41',1,0,0,V); ->L1
SW(3): V=32; ->L21; ! SPACE
SW(5): V=0; ! RUNOUT
L51: CSEXP(2,1); ->L21
SW(6): V=10; ->L51; ! NEWLINES(N)
SW(7): V=32; ->L51; ! SPACES(N)
SW(0):SW(1): ! SELECT INPUT AND OUTPUT
CSEXP(1,1); CIOCP(KK+8)
->L99
SW(9): ! PRINTSYMBOL
CSEXP(1,1); ->L23
SW(8): CIOCP(2); ! NEXT SYMBOL
L81: UNLESS REG=1 THEN PRR(X'18',REG,1)
L82: PTYPE=10001;UNPACK; ->L99
SW(10): CIOCP(1); ! READ SYMBOL
L106: ->L1004 UNLESS A(P)=4 AND A(P+1)=1
P=P+2; COPYTAG(A(P)); UNPACK
->L104 UNLESS TYPE=1 AND ARR=0 AND ROUT=0
CNAME(1,1)
L102: ->L1004 UNLESS A(P)=2; P=P+1; ->L99
L104: PLANT(X'1841'); REGISTER(4)=1
CNAME(1,4); REGISTER(4)=0
->L1004 UNLESS TYPE=1; ->L102
SW(11): ! READ
B(0)=1; B(1)=1000
L110: JJ=10000; ->L1004 IF 0#Z#13; ->L302
SW(12): ! WRITE
CSEXP(1,1); P=P+1
JJ=P; V=TSEXP(KK)
->L121 UNLESS V=0
V=PARK(1); CSEXP(2,1)
UNPARK(X'58',1,V)
L120: PPJ(PL); ->L99
L121: P=JJ; REGISTER(1)=1
CSEXP(2,1); REGISTER(1)=0; ->L120
SW(13): ! NEWPAGE
PRX(X'41',1,0,0,12); ! LA 0,12
CIOCP(5); ->L99
SW(14): ->L1004 UNLESS A(P)=4 AND A(P+1)=1; ! ADDR
P=P+2
CNAME(3,REG); ->L1004 UNLESS A(P)=2
P=P+1; ->L82
SW(16): ! INT
SW(17): ! INTPT
CSEXP(0,3)
PRR(X'28',0,NEST)UNLESS NEST=0
PPJ(PL); ->L81
SW(18): CSEXP(6,3) ; ! FRACPT
PCLOD(32); !INSERT FRACPT SR IN LINE
PRR(X'28',REG,2) UNLESS REG=2
PTYPE=10032; UNPACK; ->L99
SW(19): ! PRINT
B(0)=3;B(3)=1
L191: B(1)=32;B(2)=1;->L110
SW(20): ! PRINTFL
QPREAL=N0<<2+4
B(0)=2;->L191
SW(39): JJ=11032; ->L210; ! LONGREAL
SW(21): JJ=11002; ! REAL
L210: CSEXP(0,1); P=P+1
->L212 UNLESS NEST=0
PLANT(X'1810'); NEST=1
L212: PTYPE=JJ; UNPACK; ->L99
SW(22): JJ=11001; ->L210; ! INTEGER
SW(23): CSEXP(REG,3); ! MOD
PRR(X'20',REG,REG); ->L99; ! LPDR
SW(25):SW(26):SW(27): ! SQRT,LOG,SIN
SW(28):SW(29):SW (30): ! COS,TAN,EXP
B(0)=1
L301: B(1)=32;JJ=10032;
->L1004 IF 2#Z#13
L302: REDEFINE EP(JJ,B)
CNAME(Z,REG);P=P-2;->L99
SW(31): ! MAP RECORD
CSEXP(REG,1); FAULT(84) UNLESS Z=15
PTYPE=3; UNPACK
->L99
SW(32): JJ=11011; ->L210; ! BYTEINTEGER
SW(33): JJ=11021; ->L210; ! SHORT INTEGER
SW(34):SW(35): !RADIUS & ARCTAN
B(0)=2; B(2)=32; ->L301
SW(36): ! %INTEGERFN PARITY
CSEXP(REG,1)
PRX(X'89',REG,0,0,31); ! SLL REL,31
PRX(X'8A',REG,0,0,30); ! SRA REG,30
PRX(X'5B',REG,0,GLA,16);! S_REG,,=F'-1'
->L99
SW(37): CSTREXP(1); CIOCP(7); ->L99; ! PRINT STRING
SW(38): PRX(X'41',REG,0,0,10); ->L82
SW(40): ! PRINTCH
CSEXP(1,1); CIOCP(5); ->L99
SW(41): ! READ CH
CIOCP(4); ->L106
SW(42): JJ=11005; ->L210; ! STRING
L99: END
ROUTINE CIOCP(INTEGER N)
PRX(X'41',0,0,0,N); ! LA 0,N
PRX(X'90',4,1,11,16); ! STM 4,1,16(11)
PRX(X'98',12,14,GLA,140); ! LM 12,14,=V(IOCP)
PRR(X'05',15,14); ! BALR 15,14
R13=0
END
ROUTINE CANAME(INTEGER Z,BS,DP,CLINK,BSRF,DPRF)
! BS& DP FOR ARRAY HEAD BSRF & DPRF POINT TO MULTIPLIER
! IN RECORD FORMAT FOR RECORD ARRAYS LINK POINTS TO LP CELL HOLDING
! DIMENSION OF ARRAY IN CASE THIS HAS TO BE DEDUCED & INSERTED
!%SHORTROUTINE
SWITCH S(0:3)
INTEGER PTYPEP,KK,RR,PP,JJ,JJJ
INTEGER KKK,DIS,Q,PRECP,CHECKSP
INTEGER BASEREG,ARRP,BASIC DISP
CHECKSP=CHECKS; CHECKSP=1 IF TYPE=0; ! NO TYPE MUST GO TO PERM
PP=P; BASEREG=LINK
IF INREG#0 THEN START
CHECKSP=0 IF TYPE#0; BASEREG=INREG
FINISH
JJ=J; PTYPEP=PTYPE
ARRP=ARR
Q=COUNT APS; ->L1 UNLESS JJ=0
FROM1(CLINK,JJ)
REPLACE1(CLINK,JJ!Q); JJ=Q
L1: ->L4 IF JJ=Q#0
FAULT(19); PRINTNAME(FNAME)
P=P+1; SKIP APP; ->L99
L4:
IF ARRP=2 THEN FROM LIST(K,BASIC DISP,DP)
->L12 UNLESS CHECKSP=0 AND JJ=1 AND Z#3
->L12 UNLESS 2>=TYPE
PRECP=PREC; KKK=0; P=PP+2; JJJ=TSEXP(KKK)
IF 3<=JJJ<=99 THEN DIS=0 ELSE DIS=KKK*BYTES(PRECP)
->L12 IF DIS>4095 OR (ARRP=2 AND DIS+BASIC DISP>4095)
->REGVAR IF JJJ=50 AND PRECP=1
->RDISP IF JJJ=101
->CONST IF 1<=JJJ<=2
->L12 UNLESS JJJ=100
DUMP(2+2*PREC,1,K,0,I); P=P+1; ->L9
REGVAR: JJJ=K; P=P+1; ->L8; !CAN ONLY OPTIMISE BYTES
RDISP: ->REGVAR IF PRECP=1
PRR(X'18',1,K); P=P+1; ->L9
L12: P=PP+2; DIS=0
->L21 UNLESS JJ=1
CSEXP(1,1);P=P+1
->L10 IF CHECKSP=1
L9: JJJ=1
L8: IF BASEREG#LINK THEN ->L5
->VECTOR IF ARRP=2
RP13=R13; R13=BS<<12!DP
PRX(X'58',LINK,0,BS,DP) UNLESS R13=RP13; ! ADDR A0
->L5
VECTOR: DIS=DIS+BASIC DISP; BASEREG=BS
L5: PTYPE=PTYPEP; UNPACK
->L6 IF JJJ=0
->STR IF TYPE=5
->S(PREC) UNLESS TYPE=3; ! RECORDS
L3: PRX(X'4C',1,0,BSRF,DPRF); ->L6
STR: PRX(X'58',2,0,BS,DP+8); ! ADDR OF DV
BSRF=2; DPRF=2; ->L3
S(3): !LONG REAL
S(0): ! %INTEGER
PCONST(X'89100002'! PREC); ->L6; ! SLL 1,2 OR 3
S(2): ! %SHORT
PLANT(X'1A11'); ! AR 1,1
S(1):L6: DISP=DIS; INDEX=JJJ; BASE=BASEREG; ->L99
CONST: JJJ=0; P=P+1; ! 1 D WITH A CONSTANT SUFFIX
->L8
L10: ! 1 DIMENSION PLUS CHECKS
DUMP(0,3,DP,0,BS); ! ADDR ARRAYHEAD
PPJ(22+JJ); JJJ=1; ! PERM CHECKS BOUNDS AND SHIFTS
L11: PTYPE=PTYPEP; UNPACK
->L6
L21: ! TWO DIMENSIONS
->L31 UNLESS JJ=2 AND CHECKSP=0
CSEXP(2,1);JJJ=2;P=P+1
KK=P;Q=TSEXP(PP);P=KK
->L22 UNLESS Q=0
JJJ=PARK(2)
L22: CSEXP(1,1);P=P+1
PRX(X'4C',1,0,BS,DP+14); ! MH 1,MULTIPLIER
UNPARK(X'5A',1,JJJ); !ADD 1ST SUFFIX
->L9
L31: !MULTIDIMENSION - ALWAYS VIA PERM
RR=GET ARR WSP
CYCLE PP=0,1,JJ-1
CSEXP(0,1);P=P+1
DUMP(1,NEST,RR+PP<<2,0,RBASE)
REPEAT
DUMP(0,1,RR+PP<<2,0,RBASE); !LA 1,2
DUMP(0,2,DP,0,BS) ;!LA 2,ARRAY HEAD
PPJ(24);JJJ=1;
PUSH(MDARR(LEVEL),0,RR) ;!FREE WORK SPACE
->L11
L99: J=JJ; END
ROUTINE CENAME(INTEGER Z,MODE,BS,DP)
!%SHORTROUTINE
COMMENT MODE=0 POINTER TO RECORD IN CORE AT BS & DP
COMMENT MODE=1 POINTER TO RECORD IN REGISTER BS DP RUBBISH
COMMENT MODE=2 RECORD REG CLAIMED
! P POINTS TO (ENAME)***** FNAME HOLD FORMAT NAME
INTEGER Q,QQQ,BSRF,DPRF
->L2 IF A(P)=1
->L1 IF Z>=14; FAULT(64)
P=P-2
PTYPE=1; UNPACK; ->L99
L1: BASE=BS; DISP=DP
DISP=-1 IF MODE#0
INDEX=0; ->L99
L2: P=P+1; Q=DISPLACEMENT(FNAME); UNPACK
! K POINTS TO CELL HOLD ING DETAILS FOR THOS CELL
->L98 IF Q=-1; ->L50 IF TYPE =3
->L20 IF ARR=1
->L30 IF TYPE=5
->L11 IF MODE#0
RP13=R13; R13=BS<<12!DP
PRX(X'58',LINK,0,BS,DP) UNLESS R13=RP13
BASE=LINK
L7: INDEX=0; DISP=Q
IF ROUT=1 THEN FROM1(Q,DISP); ->L99
L11: BASE=BS; ->L7
L20: ! DEAL WITH ARRAY IN RECORD
FROM LIST(FNAME,BSRF,QQQ)
BSRF=BSRF>>4&15
FROM1(QQQ,DPRF)
->L21 IF Z<10 OR A(P+1)=1; K=DPRF+Q
I=BSRF; ! SS5V1
DUMP(2,1,DP,0,BS) IF MODE=0; ->L99; ! R1 NOW POINTS TO REORD
L21: ->L22 UNLESS MODE=0 AND BS<4; ! WILL POINTER BE DESTROTED?
DUMP(2,1,DP,0,BS); MODE=1; BS=1; ! YES-- SO SAVE IT
L22: QQQ=PARK(1) IF MODE=1
CANAME(3,BSRF,DPRF+Q,K,0,0)
R13=0
IF MODE=0 THEN PRX(X'5A',INDEX,BS,0,DP)
IF MODE=1 THEN UNPARK(X'5A',INDEX,QQQ)
IF MODE=2 THEN PRR(X'1A',INDEX,BS)
I=BSRF; K=DPRF+Q
->L99
L30: FROMLIST(FNAME,BSRF,QQQ)
FROM1(QQQ,DPRF); BSRF=BSRF>>4&15
PRR(X'18',1,BS) IF MODE#0 AND BS#1
PRX(X'58',1,BS,0,DP) IF MODE=0
PRX(X'5A',1,BSRF,0,DPRF+Q)
BASE=1; INDEX=0; DISP=0
I=BSRF; K=DPRF+Q; ->L99
L50: ! RECORDNAME IN RECORD--Q POINTS TO SIDECHAIN
DUMP(2,1,DP,0,BS) IF MODE=0; ! LOAD PTR TO FIRST RECORD
PRR(X'18',1,BS) IF MODE#0
FROM2(Q,QQQ)
CRNAME(Z,1,K,1,QQQ); ->L99
L98: P=P+1; SKIP APP; P=P-2
L99: END
ROUTINE CRNAME(INTEGER Z,MODE,CLINK,BS,DP)
!%SHORTROUTINE
COMMENT DEALS WITH RECORD NAME CALLING CENAME TO COMPILE SUBFIELDS
COMMENT MODE=0 POINTER TO RECORD IN CORE AT BS & DP
COMMENT MODE=1 POINTER TO RECORD IN REGISTER BS DP RUBBISH
COMMENT CLINK POINTS TO CELL CONTAING NAME DETAILS
INTEGER KK,JJ,Q,QQ
FROM2(CLINK,Q)
FROM1(Q,FNAME)
->L50 IF ARR=0
I=BS; K=DP;
->L99 IF 11<=Z<=12 AND A(P+1)=2 ; ! FETCH ARRAYHEAD
FROM LIST(FNAME,KK,JJ)
KK=KK>>4&15; ! BASE REG OF FORMAT
FROM1(JJ,JJ)
IF MODE=2 THEN PRR(X'1A',INDEX,BS)
->L3 UNLESS MODE=0 AND BS<4; ! WILL POINTER BE DESTROTED?
DUMP(2,1,DP,0,BS); MODE=1; BS=1; ! YES-- SO SAVE IT
L3:
QQ=BS; QQ=PARK(BS) IF MODE=1
CANAME(Z,QQ,DP,CLINK,KK,JJ+2)
FROM1(Q,FNAME)
REGISTER(QQ)=0 IF MODE=1
PRR(X'1A',1,LINK)
CENAME(Z,1,1,0); ->L99
L50: P=P+1; ->L51 IF A(P)=2
FAULT(19); SKIP APP
L51: P=P+1
IF INREG=0 OR Z=14 THEN CENAME(Z,0,BS,DP) ELSE C
CENAME(Z,2,INREG,0)
L99: END
ROUTINE CNAME(INTEGER Z,REG)
INTEGER JJ,JJJ,KK,RR,PTYPEP,LEVELP
INTEGER DISPP
COMMENT Z=0-RTCALL, Z=1 STORE(=), Z=2 FETCH, Z=3 FETCH ADDR, Z=4 STORE(<-), Z=6 STORE PTR, Z=12 FETCH ARRAYHEAD, Z=11 STORE ARRAY HEAD
SWITCH S,FUNNY(10:15)
SWITCH SW(0:8),MOD(0:31)
FNAME=A(P); COPYTAG(FNAME)
->L3 UNLESS I=-1;
{ FAULT(16) ;! Generating erroneous fault
I=LEVEL; J=0; K=FNAME
PTYPE=7;STORE TAG(K,N)
K=N; N=N+4; UNPACK
L3: JJ=J; JJ=0 IF JJ=15
LEVELP=I; DISPP=K
->L502 IF TYPE=7
->L500 IF Z=0 AND (ROUT#1 OR 0#TYPE#6)
->FUNNY(Z) IF Z>=10
->L501 IF ROUT=1
->SW(TYPE)
L500: ->SW(3) IF TYPE=3
FAULT(17) UNLESS TYPE=7; ->L502
SW(6): ->L661 UNLESS Z=3 AND ARR=1
K=K<<2; ARR=0; I=10; ->L600
SW(4): !RECORD FORMAT NAME
L661: FAULT(20)
SW(7):L502: P=P+1; ! NAME NOT SET
PTYPE=1; UNPACK; ->L6 IF A(P)=2; ->L102
FUNNY(11): ->L1011 IF TYPE=3
FAULT(17) UNLESS ARR=1 AND NAM=1 AND K>>12=0
PRX(X'90',0,3,I,K); ->L91
L1011: PCLOD(44);->SW(3); !STM 0,3,0(11) - LA 11,16(11)
S(11): MOVER(WSPR,-16)
PSS(X'D2',16,1,0,WSPR,0); ->L91
FUNNY(12): ->SW(3) IF TYPE=3
->L1202 IF ARR=2; ! VECTORS
FAULT(17) UNLESS ARR=1
L1201: PRX(X'98',0,3,I,K&4095); ->L91
L1202: FROM2(K,K); ->L1201
S(12): ->L1201 IF TYPE=3 AND ARR=1
PRR(X'18',0,1)
PRX(X'5A',0,0,I,K)
PRX(X'5A',1,0,I,K+4)
PRX(X'98',2,3,I,K+8); ->L91
FUNNY(13): ! SET BASE & DISP FOR ROUTINE ADDR
->SW(3) IF TYPE=3
->L1302 IF PTYPE=10006
->L1301 IF ROUT=1 AND NAM&1=1
BASE=GLA; FROM1(K,DISP)
INDEX=0; DISP=RA(DISP)
DISP=DISP+4 IF J=14; ! EXTERNAL ROUTINES SKIP LINK
L1300: ->L500 UNLESS ROUT=1
->L91
L1301: BASE=I; FROM1(K,DISP)
INDEX=0; ->L91
L1302: CSNAME(Z,REG); ->L6
S(13): FROM2(K,K); ->L1300
FUNNY(15): ! FETCH RECORD NAME
->L1501 IF PTYPE=10006
FUNNY(14): ! STORE INTO RECORD NAME
RR=0; IF ARR=0 AND INREG#0 AND A(P+1)=2=A(P+2)THEN RR=INREG
->SW(3) IF TYPE=3; ->L661
S(14): FAULT(20) UNLESS TYPE=3 AND NAM=1
PRR(X'18',RR,REG) IF REG#RR#0
DISP=0 IF DISP<0
R13=0 IF R13=BASE<<12!DISP
L1401: DUMP(Z-13,REG,DISP,INDEX,BASE)
P=P+1; ->L9005
S(15): ->L661 UNLESS TYPE=3
->L1401 IF DISP>=0
DUMP(0,REG,0,INDEX,BASE); P=P+1; ->L9005
L1501: CSNAME(Z,REG)
FAULT(22) UNLESS A(P)=2 AND A(P+1)=2; P=P+2; ->L9005
SW(3): ! RECORD
FROM2(K,JJJ)
CRNAME(Z,0,TAGS(A(P)),I,JJJ)
->S(Z) IF Z>=10
->L5020 IF TYPE=5
->L601 UNLESS Z=0
->L500 UNLESS ROUT=1 AND NAM=1
LEVELP=PARK(BASE); RR=DISP
PTYPEP=PTYPE; FROM2(K,JJ)
FROM2(JJ,K); ->L22
SW(5): !STRINGS
BASE=I; INDEX=0; DISP=K
JJJ=2; ->L5000 UNLESS ARR=1
CANAME(Z,I,K,TAGS(FNAME),0,0)
L4998: NAM=NAM>>1;JJJ=0
->L5000 UNLESS Z=3
DUMP(0,REG,DISP,INDEX,BASE)
PRX (X'58',2,0,LEVELP,DISPP+8) IF CHECKS#0
PACLOD(10,6,REG<<4); ->L9
COMMENT L 2,LMAX. BCTR 2,0. SLL 2,24. OR REG,2
L5000: ->L605 IF 2<=Z<=3
PRR(X'18',4,REG) UNLESS REG=4
DUMP(JJJ,1,DISP,INDEX,BASE)
->L5001 IF ARR=0
PRX(X'58',2,0,LEVELP,DISPP+8) IF Z=4 OR CHECKS#0
I=2; K=3
L5001: STORE STRING(Z,4,1,I,K);->L9
L5020: ! STRINGS IN RE CORDS
->L5025 IF ARR=1
->L9 IF 2<=Z<=3
PRR(X'18',4,REG) UNLESS REG=4; ->L5001
L5025: ! STRING ARRAYS IN RECORDS
LEVELP=I; DISPP=K; ->L4998
SW(8): !REGISTER VARIABLE
FAULT(29) UNLESS 1<=Z<=2 OR Z=4
->L9 IF K=REG
IF Z=2 THEN PRR(X'18',REG,K) ELSE PRR(X'18',K,REG)
->L9
SW(0): UNLESS Z=3 OR Z>10 THEN START
FAULT(12); TYPE=1; PTYPE=PTYPE+1; FINISH
SW(2): !REAL
SW(1): ->L600 IF ARR=0; ! TYPE 1 = %INTEGER
CANAME(Z,I,K,TAGS(FNAME),0,0)
TYPE=1 IF TYPE=0; ! IN CASE OF ABUSE OF ARRAYNAME
NAM=NAM>>1; ->L601
L501: ->L503 UNLESS Z#0 AND PTYPE=10000; ! ROUTINES
FAULT(23); PRINTNAME(A(P)); ->L503
L503: PTYPEP=PTYPE
->L20 UNLESS PTYPE=10006
CSNAME(Z,REG)
->L202 IF ROUT=1 AND NAM>=1 AND Z#0; ->L6; ! MAPS
L20: KK=K; FROM LIST(KK,RR,K)
L22: ->L21 UNLESS K=1000; FAULT(21); ->L502
L21: CRCALL(KK)
PTYPE=PTYPEP; UNPACK
->L37 IF NAM&1=1
->L36 IF JJ=14
DUMP(2,1,RA(RR),0,GLA) ;! RT ADDR TO REG1
PRX(X'45',LINK,0,GLA,116); ! BAL 15,SR IN PERM
L371: MONE=1; R13=0
P=P+1
->L1 IF PTYPE=10000 OR PTYPE=11000; ! ROUTINE OR RTNAME
->L201 IF NAM>1; !MAPS
FAULT(29) UNLESS Z=2; !FN OUT OF CONTEXT
->L43 IF TYPE=2
L44: PRR(X'18',REG,1) UNLESS REG=1; ->L1
L43: PRR(X'28',REG,2) UNLESS REG=2; ->L1
L36: ! CALL OF EXTERNAL ROUTINE
PACLOD(55,4,RA(RR)+4); !STM 4,14 - LM 12,14-BALR 13,14
->L371
L37: ! CALL OF RT PARAM******** REGISTERS MUST BE RESET
REGISTER(LEVELP)=0 IF LEVELP<RBASE
PACLOD(61,4,LEVELP<<12!RR)
COMMENT STM 4,14,?--LM 12,15 ? -- LM 5,9,20(15) -- BALR 15,14
->L371
L201: COMMENT - REAL MAPS AND INTEGER MAPS
NEST=1
L202:
->L205 IF TYPE=5; ! STRING MAPS
->L203 IF Z=3
JJJ=Z; JJJ=1 IF Z=4
JJJ=TYPE<<3+PREC<<1-8+JJJ
DUMP(JJJ,REG,0,0,NEST)
CHECK CAPACITY(REG,0,0,NEST) IF Z=1 AND CHECKS=1
TEST ASS(REG) IF Z=2 AND UNASS=1
->L1
L203: PRR(X'18',REG,NEST) UNLESS REG=NEST; ->L1
L205: COMMENT STRING MAPS
IF NEST#1 THEN PRR(X'18',1,NEST)
->L206 IF 2<=Z<=3
STORE STRING(Z,REG,1,0,255); ->L1
L206: PCLOD(69);->L44; ! LA 0,255--SLL 0,24 OR 1,0
!ARR=0
L600: BASE=I; INDEX=0; DISP=K
L601: ->L602 IF Z=6
->MOD(NAM<<4!PREC<<2!Z&3)
L602: FAULT(17) IF NAM=0
R13=0 IF R13=BASE<<12!DISP
JJJ=1; ->L605
MOD(1): ! INTEGER STORE (=)
MOD(0): ! INTEGER STORE(<-)
MOD(5): ! BYTE STORE(=)
MOD(4): ! BYTE STORE(<-)
MOD(9): ! SHORT STORE(=)
MOD(8): ! SHORT STORE(<-)
MOD(12): !LONG REAL STORE (<-)
MOD(13): !LONG REAL STORE (=)
MOD(2): !INTEGER OR REAL FETCH
MOD(14): !LONGREAL FETCH
JJJ=Z; JJJ=1 IF Z=4
JJJ=TYPE<<3+PREC<<1-8+JJJ
L605: DUMP(JJJ,REG,DISP,INDEX,BASE)
CHECK CAPACITY(REG,DISP,INDEX,BASE) IF Z=1 AND CHECKS=1
TEST ASS(REG) IF Z=2 AND UNASS=1
->L9
MOD(31): !LONG REAL NAME FETCH ADDR
MOD(19): ! INTEGER NAME FETCH ADDR
MOD(23): ! BYTE NAME FETCH ADDR
MOD(27): ! SHORT NAME FETCH ADDR
JJJ=2;->L605
MOD(15): !LONG REAL FETCH ADDR
MOD(3): ! INTEGER FETCH ADDR
MOD(7): ! BYTE FETCH ADDR
MOD(11): ! SHORT FETCH ADDR
JJJ=0;->L605
MOD(6): ! BYTE FETCH
MOD(10): ! SHORT FETCH
JJJ=PREC<<1+2;->L605
MOD(16): ! INTEGER NAME STORE (<-)
MOD(20): ! BYTE NAME STORE (<-)
MOD(24): ! SHORT NAME STORE (<-)
MOD(17): ! INTEGER NAME STORE (=)
MOD(21): ! BYTE NAME STORE (=)
MOD(25): ! SHORT NAME STORE (=)
MOD(28): !LONG REAL NAME STORE (<-)
MOD(29): !LONG REAL NAME STORE (=)
MOD(18): ! INTEGER NAME FETCH
MOD(22): ! BYTE NAME FETCH
MOD(26): ! SHORT NAME FETCH
MOD(30): !LONG REAL NAME FETCH
RP13=R13; R13=BASE<<12!DISP
PRX(X'58',LINK,INDEX,BASE,DISP) UNLESS R13=RP13 AND INDEX=0
JJJ=Z; JJJ=1 IF Z=4
JJJ=TYPE<<3+PREC<<1-8+JJJ
DUMP(JJJ,REG,0,0,LINK)
CHECK CAPACITY(REG,0,0,LINK) IF Z=1 AND CHECKS=1
TEST ASS (REG) IF Z=2 AND UNASS=1
L9: ->L1 UNLESS ARR=0
L91: P=P+1
->L6 IF A(P)=2
FAULT(19)
L102: SKIP APP; ->L1
L6: P=P+1
L1: P=P+1; ->L9005 IF A(P-1)=2
FAULT(69); ->L91
L9005: END
ROUTINE CRCALL (INTEGER CLINK)
!%SHORTROUTINE
SWITCH FPD(0:3)
INTEGER KK,II,III,Q,QQ,QQQ,PP,RF
ROUTINESPEC MOVEBACK
INTEGER MOVED,TOMOVE,TYPEP
SHORTINTEGER LIST; LIST=0
FFLAG=0; KK=COUNT APS
P=P+1; ->L2 IF K=KK
FAULT(19); PRINTNAME(FNAME)
SKIP APP; P=P-1; ->L99
L2: ->L99 IF K=0; ! NO PARAMETERS
Q=0; QQ=64; RF=1-FFLAG; ! RF=1 NO NEED TO MOVE WSPR
MOVED=0; RF=1 IF KK=1
L7: MLINK(CLINK)
FROM1(CLINK,PTYPE)
P=P+1; UNPACK
II=TYPE; III=PREC; QQQ=P
PP=(NAM<<1!ARR)&3
->L10 UNLESS(PP=0 AND ROUT=0) OR(A(P)=4 AND A(P+1)=1)
->L12 IF ROUT=1; ->FPD(PP)
L10: P=QQQ; SKIP EXP;
L11: FAULT(22); ->L53
COMMENT ROUTINE TYPE PARAMETERS
L12: II=PTYPE; P=P+2; CNAME(13,0)
->L10 IF 1000#|PTYPE-II|#0
->L10 IF A(P)=1; P=P+1
->L13 IF J=14; ! EXTERNAL
->L15 IF NAM&1#0; ! RT NAME OR RTTYPE
DUMP(2,2,DISP,INDEX,BASE); ! PICK UP RT ADDR
PRX(X'5A',2,0,GLA,28); ! RELOCATE
PCONST(X'180C181D'); ! LR 0,12 LR1,13 PERM AND GLA
PUSH(LIST,QQ+12,0); ->L69
L13: PRX(X'98',0,2,BASE,DISP); ! CODE,GLA,EP
PRR(X'18',3,9); ->L69; ! ANYTHING D W ALIGNED AS ENVRMNT
L15: PRX(X'98',0,3,BASE,DISP); ->L69
FPD(0): ->L41 IF PREC=3
->L45 IF TYPE=5
->L39 UNLESS UNASS=0 AND TYPE=1
PP=P; TYPEP=PREC
II=TSEXP(III)
->L42 IF II=10 AND TYPEP=0
->L43 IF II=1 AND TYPEP=1
P=PP; TYPE=1
L39: CSEXP(0,TYPE)
MOVE BACK
DUMP(8*TYPE-7,NEST,QQ-MOVED,0,WSPR)
CHECK CAPACITY(NEST,QQ-MOVED,0,WSPR) IF CHECKS=1
TOMOVE=4;->L50
L42: MOVEBACK
PSS(X'D2',4,WSPR,QQ-MOVED,I,K)
TOMOVE=4; ->L50
L43: MOVEBACK
PSI(X'92',III,WSPR,QQ-MOVED+3)
TOMOVE=4; ->L50
L41: II=0; II=4 UNLESS QQ&7=0; !LONG REAL
CSEXP(0,3)
DUMP(15,NEST,QQ-MOVED+II,0,WSPR)
TOMOVE=8+II;->L50
L45: CSTREXP(4); FROM2(CLINK,III)
PRX(X'41',1,0,WSPR,QQ-MOVED+4)
STORE STRING(1,4,1,0,III-1)
TOMOVE =(III+7)&(-4); ->L50
FPD(2): ! NAME TYPES INCLUDES RECORDNAME
P=P+2
IF TYPE=3 THEN CNAME(15,1) ELSE CNAME(3,1)
->L10 IF A(P)=1; P=P+1; ! CHECK NO RESTOF EXPRN
->L11 UNLESS (II=TYPE AND III=PREC) OR II=0
MOVE BACK
DUMP(1,1,QQ-MOVED,0,WSPR)
TOMOVE=4;->L50 UNLESS II=0
FAULT(12) UNLESS 2>=TYPE
PSI(X'92',PREC<<3!TYPE,WSPR,QQ-MOVED); ->L50;!FLAG FOR %NAME
FPD(1):FPD(3): ! ARRAYNAME (+ARRAY VALUE)
P=P+2; CNAME(12,0); ->L10 IF A(P)=1; ! REST OF EXPRN
P=P+1
FROM2(CLINK,PP)
IF PP=0 THEN START; REPLACE2(CLINK,J); FINISH
FAULT(22) UNLESS ARR>0 AND(J=0 OR PP=0 OR J=PP)
FAULT(22) UNLESS II=0 OR(TYPE=II AND III=PREC)
L69: MOVE BACK
PRX(X'90',0,3,WSPR,QQ-MOVED); ! STM
TOMOVE=16
L50: QQ=QQ+TOMOVE
->L53 IF RF=1 OR Q=KK-1
II=(QQ+7)&(-8)-MOVED
MOVER(WSPR,II); MOVED=MOVED+II
L53: Q=Q+1; ->L7 UNLESS Q=KK
MOVER(WSPR,-MOVED) UNLESS RF=1
L55: POP(LIST,Q,QQ); ->L99 IF Q=-1
PRX(X'50',WSPR,0,WSPR,Q); ->L55;! POINTER TO SAVE AREA RTTYPES
ROUTINE MOVEBACK
->L1 IF QQ>=MOVED
MOVER(WSPR,QQ-MOVED); MOVED=QQ
L1: END
L99: END
COMMENT Z=1 FOR= ,4 FOR <- AND MAX LENGTH IN BYTE DEFINED BY BML&DML
ROUTINE STORE STRING(INTEGER Z,FROM,TO,BML,DML)
!%SHORTROUTINE
COMMENT REGISTER 2 IS ASSUMED TO BE USABLE.
FAULT(239) UNLESS TO=1 AND FROM=4
->L10 IF Z=4
->L2 IF CHECKS=0
->L1 IF BML>0
PSI(X'95',DML,FROM,0); ->L3; ! CLI FOR FIXED LENGTH
L1:
PSS(X'D5',1,FROM,0,BML,DML) ;!CLC_ACTUALL(1),MAX
L3:
PRX(X'47',2,0,CODER,88) ;!BH_FAIL
L2: PRX(X'43',2,0,FROM,0) ;!IC_2,ACTUALL
PRX(X'44',2,0,GLA,STRINST) ;!EX_2,MOVE
->L99
L10: PRX(X'43',2,0,BML,DML) ;!IC_2,MAXL
PPJ(39)
L99: END
ROUTINE TEST NST
FNAME=K
FAULT(7) UNLESS FIND(FNAME,NAME(LEVEL))=-1
END
ROUTINE CUCI
!%SHORTROUTINE
ROUTINESPEC DXB
ROUTINESPEC DLB
ROUTINESPEC DB
ROUTINESPEC CUCS
INTEGER Z,KK,X,OPCODE,REG
SWITCH SW(1:4),S(1:8)
P=2; ->SW(A(P))
SW(1): ! **(N),(@')(NAME)(APP)
NEST=A(3); P=5; Z=A(4)-1
Z=3 IF Z=0; CNAME(Z,NEST)
->L99
SW(2): PPJ(A(P+1)); ->L99
SW(4): ! *PUT_CONST
->L401 IF A(P+1)#9
PLANT(A(P+2)); P=P+3; ->L99
L401: FAULT(32) UNLESS A(P+1)=1
PLANT(A(P+3)); ! LEAST SIGNIFICANT 16 BITS ONLY
P=P+4; ->L99
SW(3): OPCODE=A(P+2);P=P+3; ->S(A(P-2))
S(1): ->L87 IF OPCODE=0;
PRR(OPCODE,A(P),A(P+1)); P=P+2; ->L99; ! RR
S(2): REG=A(P); P=P+1;DXB; !RX
L11: PRX(OPCODE,REG,X,I,K);->L99
S(3): REG=A(P); X=A(P+1);P=P+2; !RS
DB; ->L11
S(4): DB;Z=0;->L41 IF A(P)=2;Z=A(P+2); !SI
FAULT(32) UNLESS A(P+1)=9 AND Z<256
P=P+2
L41: PSI(OPCODE,Z,I,K);P=P+1; ->L99
S(5): REG=A(P);P=P+1; DB; !SHIFT INSTR.
X=0; ->L11
S(6): DLB;KK=K;Z=X;REG=I;DB; !SS FORMAT
Z=1 IF Z=0
L61: PSS(OPCODE,Z,REG,KK,I,K); ->L99
S(7): DLB; KK=K; Z=X; REG=I; !PACKED DECIMAL
DLB; Z=1 IF Z=0
X=1 IF X=0
Z=(Z-1)<<4!X; ->L61
S(8): REG=A(P); P=P+1; !FUNNIES
->L85 IF OPCODE=X'80' ; ! IDL
->L83 IF OPCODE=10; ! SVC
PRR(OPCODE,REG,0);->L99
L83: PLANT(X'A00'!REG); ->L99
L85: PSI(OPCODE,REG,0,0); ->L99
L87: CNOP(A(P),A(P+1)); ->L99
ROUTINE DB
->L2 IF A(P)=1
K=A(P+1); I=0; P=P+3
->L99 IF A(P-1)=2
I=A(P);P=P+1;->L99
L2: CUCS
L99: END
ROUTINE DXB
SWITCH SW(1:3)
->L2 IF A(P)=2
CUCS;X=0;P=P+1
->L99 IF A(P-1)=2
X=A(P);P=P+1; ->L99
L2: K=A(P+1);P=P+2;I=0;X=0
->SW(A(P))
SW(1): X=A(P+1);P=P+1
SW(2): I=A(P+1);P=P+1
SW(3): P=P+1
L99: END
ROUTINE DLB
->L2 IF A(P)=2
K=A(P+1); X=A(P+2); I=A(P+3); P=P+4; ->L99
L2: CUCS; X=A(P); P=P+1
L99: END
ROUTINE CUCS
SWITCH UTYPE(0:8)
P=P+1
->L10 IF A(P)=2
FNAME=A(P+1); COPYTAG(FNAME)
P=P+3; ->L1 UNLESS I=-1
FAULT(16); J=0; I=LEVEL; PTYPE=7; UNPACK
STORE TAG(FNAME,N);K=N;N=N+4
L1: FAULT(33) IF ROUT=1; ->UTYPE(TYPE)
UTYPE(3): FROM2(K,K); ->L9; ! RECORDS
UTYPE(4): FROM1(K,K); ->L9; ! FORMATS
UTYPE(8):FAULT(33); ->L9
UTYPE(6): FROM1(K,K); ! SWITCHES
K=K-CODEBASE(OLDI); FAULT(99) IF K>4095
I=10
UTYPE(0):UTYPE(1):UTYPE(2):UTYPE(5):UTYPE(7):
->L9 UNLESS ARR=2; ! VECTOR
FROM2(K,K); ! EXTRACT DISPLACEMENT
L9: ->L99 IF A(P-1)=2
K=K+A(P); P=P+1; ->L99
L10: K=A(P+2)+(A(P+1)-1)<<14
J=FIND(K,LABEL(LEVEL))
->L25 IF J=-1
K=J-CODEBASE(LEVEL); I=10
FAULT(99) IF K>4095; P=P+3; ->L99
L25: PUSH(JUMP(LEVEL),CA!LABSET,K)
K=0; I=0; P=P+3
L99: END
L99: END
ROUTINE TEST ASS(INTEGER REG)
!%SHORTROUTINE
INTEGER J
RETURN UNLESS 1<=TYPE<=2
->L5 IF TYPE=1
J=X'79'; J=X'69' IF PREC=3
L3: PRX(J,REG,0,GLA,128)
PRX(X'47',8,0,CODER,40); ->L99
L5: ->L99 UNLESS PREC=0
J=X'59'; ->L3
L99: END
ROUTINE GXREF(INTEGER NAME,HASH)
!%SHORTROUTINE
INTEGER I,J,K,N,NP
I=N0; N0=N0+7; J=WORD(NAME)
ST(I+1)=0; ST(I+2)=0; ST(I+3)=0
N=LETT(J); NP=N; NP=8 IF NP>8
K=ADDR(ST(I+5)); ->L1 IF HASH=0
ST(I+5)=HASH<<16!'#'<<8
K=K+2; N=N+2
NP=6 IF NP>6
L1: CYCLE NP=1,1,NP
BYTEINTEGER(K+NP)=LETT(J+NP); REPEAT
N=8 IF N>8; ST(I+4)=X'80000000'; ! MARK NEW FORMAT
ST(I)=XREFLINK; XREFLINK=I<<2; ! LINK IN REFERENCE
BYTE INTEGER(ADDR(ST(I+5)))=N
N0=N0+1 IF N=8
END
ROUTINE UNDCRF (SHORTINTEGERNAME OPHEAD) ; ! Care needed with short conversion!
INTEGER I,J
SHORTINTEGER OP
COMMENT UNSCRAMBLES RECORD FORMAT TAGS LIST & SIDECHAIN
POP (OPHEAD,I,J); ! LST ITEM IS DESPMENT
L1: POP (OPHEAD,I,J)
->L9 IF I=-1
OP=J;PTYPE=I>>4&X'FFFF';UNPACK
IF ROUT=1 OR TYPE=3 THEN CLEAR LIST(OP)
->L1
L9: END
ROUTINE CLT
!%SHORTROUTINE
COMMENT P ON PHRASE TYPE AT ENTRY - TO NEXT PHRASE AT EXIT
TYPE=TYPEFLAG(A(P))
PREC=TYPE>>3; TYPE=TYPE&7
PREC=3 IF TYPE=2 AND ALL LONG#0
ACC=BYTES(PREC);P=P+1
->L99 UNLESS TYPE=5
->L2 UNLESS A(P)=2
ACC=0; P=P+1; ->L99
L1: P=P+1;FAULT(70);->L99
L2: P=P+1;ACC=A(P)+1
->L1 UNLESS 2<=ACC<=256
P=P+1
L99: END
ROUTINE CQN(INTEGER P)
!%SHORTROUTINE
BYTEINTEGER I
I=A(P);NAM=0;ARR=0
NAM=2 IF I=1 ;ARR=1 IF I<=2
NAM=NAM!1 IF I<=3;ACC=16 IF ARR=1
ACC=4 IF I=3
END
ROUTINE SKIP EXP
!%SHORTROUTINE
SWITCH SW(1:4);INTEGER J
OWNINTEGER RT=10000
L3: P=P+1; ->SW(A(P)); ! SWITCH ON OPERAND
SW(1): P=P+2; ! OPERAND = NAME
J=ADDR(ASLIST(TAGS(A(P-1))))
->L5 IF SHORT INTEGER(J)<RT; FFLAG=1
L5: SKIP APP; P=P+1
->L1 IF A(P-1)=2; P=P+1; ->L5
SW(2): ! CONST
P=P+1; J=A(P)
IF J=9 THEN START; P=P+2; ->L1; FINISH
IF J=1 THEN START; P=P+3; ->L1; FINISH
IF J=2 THEN START; P=P+5; ->L1; FINISH
P=P+A(P+1)&X'FE'+3; ->L1
SW(3):SW(4): P=P+1; SKIP EXP
L1: P=P+1; ->L3 IF A(P-1)=1
END
ROUTINE SKIP APP; ! SKIPS ACTUAL PARAMETER PART
L5: P=P+1; ->L1 IF A(P-1)=2; SKIP EXP; ->L5
L1: END
ROUTINE CQUERY(INTEGER REG)
!%SHORTROUTINE
PSI(X'95',0,GLA,1); ! CLI 1(GLA),0
PJ(8,PLABEL-1); ! JUMP ROUND IF QUERIES OFF
->L1 IF TYPE=2
->L5 IF TYPE=5
PRR(X'18',1,REG) UNLESS REG=1; ! LR 1,REG
PCONST(X'4120000B'); ! LA 2,11
PPJ(4); ->L9; ! TO WRITE
L1: PCONST(X'41100020'); PPJ(3); ! OUTPUT SPACE
IF QPREAL=0 THEN START
QPREAL=N0<<2+4
ST(N0)=XREFLINK; XREFLINK=QPREAL-4
ST(N0+4)=8; ST(N0+5)=M'I#PR'; ST(N0+6)=M'INTF'
!! ^^^^^^ ^^^^^^^ WARNING! Endianness
N0=N0+7; FINISH
PACLOD(82,1,REG<<4)
COMMENT STD REG,64(11).LA 0,12.ST 0,68(11) ABD SS ENTRYPRINTF
PACLOD(55,4,QPREAL); ->L9
L5: PCONST(X'4110000A'); PPJ(3); ! NEWLINE
PRR(X'18',1,REG); PPJ(5)
L9: PLAB(-1)
END
ROUTINE LOADAD(INTEGER REG,BASE,X,DISP)
!%SHORTROUTINE
! LOADS ADDRESS & DEALS CORRECTLY WITH DISP>4095
INTEGER I
PRX(X'41',REG,X,BASE,DISP&4095)
I=PAGENO(DISP)
PRX(X'5A',REG,0,GLA,4*I)UNLESS 4095>=DISP
END
INTEGERFN TSEXP(INTEGERNAME CODE)
!%SHORTROUTINE
SWITCH SW(1:4)
TYPE=1
->L9 IF 1#A(P)#4; ->SW(A(P+1))
SW(1): CODE=A(P+2); COPYTAG(CODE)
IF PTYPE=10006 THEN START
TYPE=TSNAME(K);PREC=TYPE>>3
TYPE=TYPE&7; FINISH
->L40 IF TYPE=8; !REGISTER VARIABLE
->L30 IF TYPE=3 AND ARR=0 AND INREG#0
->L50 IF ARR=2 AND TYPE=1
->L9 UNLESS A(P+3)=2 =A(P+4); ! NO APP OR ENAME
->L9 UNLESS ROUT=0 AND ARR=0
->L20 IF TYPE=5
->L9 UNLESS NAM=0
->L14 IF TYPE=2
->L9 UNLESS TYPE=1
->L11 IF A(P+5)=2; ! NO RST OF EXPS
->L9 UNLESS A(P+6)=2=A(P+7)
->L9 UNLESS A(P+8)=9 AND A(P+10)=2
CODE=A(P+9); P=P+11; RESULT=100
L11: P=P+6; RESULT=10+PREC
L14: ->L9 UNLESS A(P+5)=2; !NO NOT OF EXPRN
P=P+6; RESULT=14+PREC&1
L20: ->L9 UNLESS A(P+5)=2
P=P+6; RESULT=20
L30: ->L9 UNLESS A(P+3)=2 AND A(P+4)=1; ! NO APP BUT ENAME
P=P+5; FROM1(K,FNAME); I=INREG
K=DISPLACEMENT(FNAME); UNPACK
->L9 IF I=-1 OR ARR#0 OR ROUT#0
->L9 UNLESS 1<=TYPE<=2 AND A(P+1)=2=A(P+2)
->L9 UNLESS A(P+3)=2; ! NO REST OF EXPRN
P=P-2; ->L11 IF TYPE=1; ->L14
L40: ->L41 IF A(P+5)=2; !NO REST OF EXP
->L9 UNLESS A(P+6)=2=A(P+7)
->L9 UNLESS A(P+8)=9 AND A(P+10)=2
CODE=A(P+9);P=P+11; RESULT=101
L41: P=P+6; RESULT=50
L50: ->L9 UNLESS A(P+3)=1 AND A(P+4)=4 AND A(P+5)=2
->L9 UNLESS A(P+6)=9 AND A(P+7)<256 AND A(P+8)=2
->L9 UNLESS A(P+9)=2 AND A(P+10)=2 AND A(P+11)=2
FROM1(K,K); K=K+A(P+7)*BYTES(PREC)
->L9 UNLESS 0<=K<4096
P=P+12; RESULT=10+PREC
SW(2): TYPE=A(P+2)&7
->L9 UNLESS A(P+2)=9
->L21 IF A(P+4)=1; ! REST OF EXPR
CODE=A(P+3); P=P+5
RESULT=1 IF 256>CODE
RESULT=2
L21: IF A(P+5)=12 THEN TYPE=5; ! STRING EXPRESSION
SW(3):SW(4):L9:RESULT=0
END
ROUTINE MOVE R(INTEGER R,N)
!%SHORTROUTINE
->L99 IF N=0; ->L2 IF 0>N
DUMP(0,R,N,0,R); ->L99
L2: N=-N; ->L3 UNLESS N=4 OR N=8
PRX(X'5A',R,0,GLA,76+N); ->L99
L3: PCONST(X'41000000'!N); ! LA 0,N
PRR(X'1B',R,0); ! SR R,0
L99: END
INTEGERFN FIND PP
!%SHORTROUTINE
INTEGER I
CYCLE I=9-RLEVEL,-1,4
->L1 IF REGISTER(I)=0
REPEAT
RESULT=0
L1: REGISTER(I)=1
RESULT=I
END
ROUTINE UNPARK(INTEGER OPCODE,REG,Q)
!%SHORTROUTINE
->L1 IF 0>Q
PRR(OPCODE-X'40',REG,Q); REGISTER(Q)=0; ->L9
L1: Q=|Q|; PRX(OPCODE,REG,0,RBASE,Q)
PUSH(WSP(LEVEL),0,Q);
L9: END
INTEGERFN PARK(INTEGER REG)
!%SHORTROUTINE
INTEGER I,J,P
P=CLAIMABLE REG
->L1 IF P=0
REGISTER(P)=1
->L2 IF P=REG
PRR(X'18',P,REG); ! LR P,REG
L2: RESULT=P
L1: POP(WSP(LEVEL),I,J); ->L3 UNLESS J=-1
J=N; N=N+4
L3: DUMP(1,REG,J,0,RBASE); RESULT=-J
END
INTEGERFN CLAIMABLE REG
!%SHORTROUTINE
INTEGER I
->L1 IF RBASE<= 4
CYCLE I=5,1,RBASE
RESULT=I IF REGISTER(I)=0
REPEAT
L1: RESULT=0
END
INTEGERFN PARKF (INTEGER REG,PREC)
!%SHORTROUTINE
INTEGER I,J
->L10 UNLESS PREC=0
POP(WSP(LEVEL),I,J)
->L3 UNLESS J=-1
J=N; N=N+4
L3: DUMP(9+2*PREC,REG,J,0,RBASE)
RESULT=J
L10: J=GET DBLE WRD;->L3 ;!PARKING SPACE
END
INTEGERFN GET ARR WSP
COMMENT PRODUCES 6 CONTIGUOUS WORDS UNDER BASE
COMMENT REGISTER COVER FOR ARRAY ACCESS
INTEGER I,J
POP(MDARR(LEVEL),I,J)
->L1 IF J>0
J=N; N=N+24
L1: RESULT =J
END
ROUTINE RHEAD(INTEGER KK)
!%SHORTROUTINE
INTEGER FLAG,W1,W2
FLAG=KK;FLAG=10000 IF RLEVEL=0
->L5 IF RLEVEL=0
->L5 UNLESS LIST=0
NEWLINE;WRITE(LINE,5);SPACES(3*LEVEL)
IF KK<0 THEN print string("BEGIN") ELSE START
print string("RT/FN/MAP "); PRINTNAME(KK); FINISH
WRITE(CA,6)
L5: LEVEL=LEVEL+1
->L6 IF FLAG<0
RLEVEL=RLEVEL+1;RBASE=10-RLEVEL;R13=0
FAULT(35) IF RBASE=4 OR REGISTER(RBASE)#0
REGISTER(RBASE)=1
L6: FAULT(34) IF LEVEL=10
FAULT(105) IF LEVEL>MAX LEVELS
NMDECS(LEVEL)=0
->L10 IF FLAG>=0
PRX(X'90',10,11,RBASE,N); ! STM 10,11,?
N=N+12;W1=RBASE;W2=N-4
->L20
L10: ->L25 IF KK<0
FROM LIST(JJ,J,K);ST(RA(J)>>2)=CA
PRX(X'50',LINK,0,WSPR,60); !SAVE LINK
W1=WSPR; W2=0
L20: ->L21 IF DIAGS1=0
PSS(X'D2',4,W1,W2,GLA,20)
LOADAD(0,0,0,LINE)
PCONST(X'4000D014') ; !STH 0,20(GLA)
L21: MONE=1;SET LINE
L25: PRR(X'18',RBASE,WSPR) UNLESS FLAG<0
IF KK<0 THEN W1=0 ELSE W1=WORD(KK)
L(LEVEL)=LINE;M(LEVEL)=W1
RNEXT(LEVEL)=NEXT
RETURN IF FLAG<0
SET(RLEVEL)=CA+2
PRX(X'41',WSPR,WSPR,0,0); ! LA WSP,?(WSP)
IF CHECKS#0 THEN PCLOD(75); ! CHECK VFOR EXCESS BLOCKS
N=64; NMAX=N;
END
ROUTINE SET80(INTEGER WHERE,N)
RETURN IF N<=2
INTEGER K
!%SHORTROUTINE
PSI(X'92',X'80',RBASE,WHERE)
N=N-1; K=WHERE
L1: ->L2 IF N<=256
PSS(X'D2',256,RBASE,K+1,RBASE,K)
K=K+256; N=N-256; ->L1
L2: PSS(X'D2',N,RBASE,K+1,RBASE,K)
END
ROUTINE CBPAIR(INTEGERNAME LB,UB)
!%SHORTROUTINE
INTEGER KK,KKK,JJ,BP
P=P+1; KK=0
CYCLE JJ=1,1,2; KKK=KK
IF A(P)=2 THEN KK=-1 ELSE KK=1
->REAL IF A(P+1)&7=2
->STRING IF A(P+1)&7=5
IF A(P+1)=9 THEN BP=A(P+2) ELSE START
FROMAR4(P+2,BP); P=P+1; FINISH
KK=KK*BP; P=P+3; ->AGAIN
REAL: FAULT(24); P=P+6; KK=0; ->AGAIN
STRING: FAULT(42); P=P*A(P+2)&X'FE'+2; KK=0
AGAIN: REPEAT
LB=KKK; UB=KK
END
ROUTINE LOAD DATA
!%SHORTROUTINE
INTEGER LDLINK,JJ,KK,PTR,JJJ
SHORTINTEGER HEAD
LDPTR=8+8*NEPS
INTEGERARRAY BUFFER(0:LDPTR)
BUFFER(0)=7; BUFFER(2)=88
BUFFER(3)=0; BUFFER(4)=0
BUFFER(5)=0; BUFFER(6)=64
PTR=8; LDLINK=0
L1: POP(EPLINK,JJ,KK)
->L10 IF JJ<0
HEAD=KK
BUFFER(PTR)=LDLINK
LDLINK=PTR<<2
BUFFER(PTR+1)=0
BUFFER(PTR+2)=0
BUFFER(PTR+3)=JJ
BUFFER(PTR+4)=X'80000000'
POP(HEAD,BUFFER(PTR+5),KK); ! FIRST BIT OF ID.
IF KK>3 THEN POP(HEAD,BUFFER(PTR+6),JJJ)
PTR=PTR+7; IF KK>7 THEN START
POP(HEAD,BUFFER(PTR),JJJ); PTR=PTR+1; FINISH; ->L1
L10: BUFFER(1)=LDLINK
LPUT(3,PTR<<2,0,ADDR(BUFFER(0)))
LDPTR=PTR
END
ROUTINE DEFINE EP(INTEGER MODE,NAME,ADR)
!%SHORTROUTINE
SHORTINTEGER HEAD
INTEGER JJ,KK,LENGTH,ID1,ID2,ID3
SWITCH SW(0:2)
KK=WORD(NAME)
HEAD=0; ->SW(MODE)
SW(0): COMMENT DEFINE S#GO
!! WARNING!!! The fact that these M'xxx' constants are 3 bytes, and
!! the length byte is plugged in below suggests that we are looking
!! at some big-endian-dependent code here! Which might explain why
!! there are problems with the PRIMs.
LENGTH=4; ID1=M'S#G'; ID2=M'O '; ->L10
!! ^^^^^^
SW(1): COMMENT SYSTEM EP
LENGTH=LETT(KK)+2
ID1=M'S#A'; CYCLE JJ=1,1,6
!! ^^^^^^
BYTEINTEGER(ADDR(ID1)+JJ+2)=LETT(KK+JJ)
REPEAT; ->L10
SW(2): COMMENT ENTRY TO EXTERNAL ROUTINE
LENGTH=LETT(KK)
CYCLE JJ=1,1,8
BYTE INTEGER(ADDR(ID1)+JJ)=LETT(KK+JJ)
REPEAT
L10: LENGTH=8 IF LENGTH>8
BYTE INTEGER(ADDR(ID1))=LENGTH
IF LENGTH>7 THEN PUSH(HEAD,ID3,0)
IF LENGTH>3 THEN PUSH(HEAD,ID2,0)
PUSH(HEAD,ID1,LENGTH) ; ! COMPLETE SIDE CHAIN
PUSH(EPLINK,ADR,HEAD); ! LINK TO MAIN LIST
NEPS=NEPS+1
END
ROUTINE REDEFINE EP(INTEGER TYPEP,INTEGERARRAYNAME PARAMS)
!%SHORTROUTINE
INTEGER JJ,KK;SHORTINTEGER OPHEAD
JJ=N0;P=P-2;GXREF(A(P),'I')
K=NEWCELL;OPHEAD=K
->L1 IF PARAMS(0)=0 ; CYCLE KK=1,1,PARAMS(0)
INSERT AFTER(OPHEAD,PARAMS(KK),0)
REPEAT
L1: I=9;J=14;OLDI=0;PTYPE=TYPEP
REPLACE TAG(A(P));REPLACE BOTH(K,NR,PARAMS(0))
RA(NR)=JJ<<2;NR=NR+1
END
INTEGERFN GET DBLE WRD
!%SHORT %ROUTINE
COMMENT PRODUCES A DOUBLE WORD OF TEMPORARY SPACE
COMMENT COVERED BY CURRENT BASE REGISTER (RBASE)
INTEGER I,J
POP(LWSP(LEVEL),I,J)
->L3 UNLESS I=-1
->L2 IF N&7=0
PUSH(WSP(LEVEL),0,N);N=N+4
L2: J=N;N=N+8
L3: RESULT =J
END
INTEGERFN GET STR WSP
!%SHORTROUTINE
INTEGER I,J
POP(STR WSP(LEVEL),I,J)
->L2 UNLESS J=-1
J=N; N=N+256
L2: RESULT=J
END
ROUTINE SETEX
RETURN UNLESS STRINST=0
ST(N0)=X'D2001000'
ST(N0+1)=X'4000D500'
ST(N0+2)=X'20001000'
STRINST=N0<<2; N0=N0+3
END
ROUTINE SETLINE
!%SHORTROUTINE
INTEGER K
OWNINTEGER VALUE
RETURN UNLESS LINENOS=1
K=LINE&255
MONE=1 IF K=0
PSI(X'92',K,GLA,23) UNLESS K=VALUE AND MONE=0
VALUE=K
->L9 IF MONE=0
PSI(X'92',LINE>>8,GLA,22); ! MVI
L9: MONE=0; END
ROUTINE CHECK CAPACITY(INTEGER REG,DIS,X,LEVEL)
!%SHORTROUTINE
INTEGER MASK
RETURN UNLESS TYPE=1 AND 1<=PREC<=2
->L3 IF PREC=1; ! %YTE
MASK=7
PRX(X'49',REG,LEVEL,X,DIS); ! CH REG,STORED VALUE
L1: PRX(X'47',MASK,12,0,88); ->L99; ! BC MASK,CAPACITY EXCE
L3: PRX(X'55',REG,0,GLA,24); ! CL_1,=F'255'
MASK=2; ->L1
L99: END
! ******* LIST***PROCESSING***ROUTINES
COMMENT MACROISING THE FROMS,REPLACES & MLINK SAVES TIME & SPACE;
COMMENT MACROISING THE OTHERS SAVES TIME BUT INCREASES SIZE
ROUTINE FROM LIST(INTEGER CELL,INTEGERNAME S1,S2)
INTEGER J
J=ADDR(ASLIST(CELL))
S1=INTEGER(J)
S2= SHORT INTEGER(J+4)
END
INTEGERFN NEW CELL
INTEGER P
P=ASL; FAULT(107) IF P=0
ASL= SHORT INTEGER(ADDR(ASLIST(P+6)));! NEXT FREE CELL
SET SHORT INTEGER(ADDR(ASLIST(P+6)), 0); ! LINK OF NEWCELL TO 0
RESULT=P
END
ROUTINE PUSH(SHORTINTEGERNAME CELL,INTEGER S1,S2) ; ! Care needed with short conversion!
INTEGER P,Q
P=NEWCELL
Q=ADDR(ASLIST(P))
INTEGER(Q)=S1
SET SHORT INTEGER(Q+4, S2)
SET SHORT INTEGER(Q+6, CELL)
CELL=P
END
ROUTINE POP(SHORTINTEGERNAME CELL,INTEGERNAME S1,S2)
INTEGER P,Q
Q=ADDR(ASLIST(CELL))
S1=INTEGER(Q)
S2=SHORT INTEGER(Q+4)
->L1 IF CELL=0; ! LIST ALREADY EMPTY
P=CELL; CELL=SHORT INTEGER(Q+6);! CELL ONTO NEXT CELL
SHORT INTEGER(Q+6)=ASL; ASL=P;! OLD CELL ONTO FREE LIST
L1: END
ROUTINE REPLACE1(INTEGER CELL,S1)
INTEGER(ADDR(ASLIST(CELL)))=S1
END
ROUTINE REPLACE2(INTEGER CELL,S2)
SHORT INTEGER(ADDR(ASLIST(CELL+4)))=S2
END
ROUTINE MLINK(INTEGERNAME CELL)
CELL=SHORT INTEGER(ADDR(ASLIST(CELL+6)))
END
ROUTINE INSERT AFTER(SHORTINTEGERNAME CELL,INTEGER S1,S2)
->L1 IF CELL=0
PUSH(SHORT INTEGER(ADDR(ASLIST(CELL+6))),S1,S2)
CELL=SHORT INTEGER(ADDR(ASLIST(CELL+6)))
RETURN
L1: PUSH(CELL,S1,S2)
END
INTEGERFN FIND(INTEGER LAB,LIST)
L3: ->L1 IF LIST=0
->L4 IF SHORT INTEGER(ADDR(ASLIST(LIST+4)))=LAB
MLINK(LIST); ->L3
L4: RESULT=INTEGER(ADDR(ASLIST(LIST)))
L1: RESULT =-1
END
ROUTINE FROM1(INTEGER CELL,INTEGERNAME S1)
S1=INTEGER(ADDR(ASLIST(CELL)))
END
ROUTINE FROM2(INTEGER CELL,INTEGERNAME S2)
S2=SHORT INTEGER(ADDR(ASLIST(CELL+4)))
END
ROUTINE REPLACE BOTH(INTEGER CELL,S1,S2)
INTEGER I
I=ADDR(ASLIST(CELL))
INTEGER(I)=S1
SHORT INTEGER(I+4)=S2
END
ROUTINE CLEAR LIST (SHORTINTEGERNAME OPHEAD)
INTEGER I,J
L1: POP(OPHEAD,I,J)
->L1 UNLESS I=-1
END
! ************END****OF****LIST****PROCESSING ROUTINES
ROUTINE STORE TAG(INTEGER KK,SLINK)
PUSH(TAGS(KK),PTYPE<<16!LEVEL<<8!RBASE<<4!J,SLINK)
PUSH(NAME(LEVEL),0,KK) UNLESS LEVEL<=1
END
INTEGERFN COUNT APS
INTEGER PP,Q
Q=0; PP=P; P=P+1; ! P ON NAME AT ENTRY
L1: ->L2 IF A(P)=2
P=P+1; Q=Q+1; SKIP EXP; ->L1
L2: P=PP; RESULT=Q
END
INTEGERFN DISPLACEMENT(INTEGER LINK)
!%SHORTROUTINE
! A(P) HAS ENAME--LINK IS HEAD OF RFORMAT LIST. RESULT IS DISP FROM
! START OF RECORD FOR SCALAR DISP OF DV FROM RECORD FORMAT FOR ARRAY
INTEGER RR,II
->L2 IF LINK=0
FROM2(LINK,LINK)
L1: MLINK(LINK); FROM LIST(LINK,RR,II)
->L2 IF II=-1
J=RR&15;PTYPE=RR>>4&X'FFFF'
RR=RR>>20;K=LINK
INREG=0
->L99 IF RR=A(P); ->L1
L2: FAULT(65); PRINT NAME(A(P))
PTYPE=1
L99: RESULT=II
END
INTEGERFN COPY RECORD TAG
!%SHORTROUTINE
! AS COPY TAG-GIVES TYNE ETC OF THE ENAME
!P POINTS TO RECORD NAME
INTEGER Q,FNAME
! K POINT TO SIDE CHAIN
L1: FROM1(K,FNAME)
P=P+1; SKIP APP
RESULT=0 IF A(P)=2
P=P+1; Q=DISPLACEMENT (FNAME)
PTYPE=7 IF Q=-1
UNPACK
IF TYPE=3 THEN START
K=Q; ->L1; FINISH
RESULT=-1 IF Q=-1
RESULT=1
END
ROUTINE COPY TAG(INTEGER KK)
INTEGER Q
FROM LIST(TAGS(KK),Q,K)
->NOTSET IF Q=-1
PTYPE=Q>>16
INREG=Q>>12&15
OLDI=Q>>8&15
I=Q>>4&15
J=Q&15
L1: UNPACK
RETURN
NOTSET: PTYPE=7
I=-1; J=I; OLDI=J; ->L1
END
ROUTINE REPLACE TAG (INTEGER KK)
!%SHORTROUTINE
INTEGER P,Q
P=TAGS(KK)
Q=PTYPE<<16!INREG<<12!OLDI<<8!I<<4!J
REPLACE BOTH(P,Q,K)
END
ROUTINE UNPACK
INTEGER Q
ROUT=PTYPE//10000
Q=PTYPE-10000*ROUT
NAM=Q//1000
Q=Q-1000*NAM
ARR=Q//100
Q=Q-100*ARR
PREC=Q//10
TYPE=Q-10*PREC
END
ROUTINE PACK(INTEGERNAME PTYPE)
INTEGER Q
Q=10000*ROUT+1000*NAM+100*ARR
PTYPE=Q+10*PREC+TYPE
END
!************* LABEL ***** AND**** JUMP **** ROUTINES*************
ROUTINE PPJ(BYTEINTEGER N)
R13=0; PCONST(X'45F0C000'!N<<2); ! BAL LINP,PLAB N
END
INTEGERFN PAGENO(INTEGER N)
INTEGER I,J
J=N>>12; I=PAGENOS(J)
RESULT=I UNLESS I=0
ST(N0)=J<<12
PAGENOS(J)=N0
N0=N0+1
RESULT=N0-1
END
ROUTINE FILL JUMPS(INTEGER LEVEL)
!%SHORTROUTINE
INTEGER J,K,Q,KK
OPHEAD=0
L1: POP(JUMP(LEVEL),J,K); ->L3 IF J=-1
Q=FIND(K,LABEL(LEVEL))
->L2 UNLESS Q=-1;
PUSH(OPHEAD,J,K); ->L1
L2: KK=0
Q=Q-CODEBASE(LEVEL); K=Q>>12
->L22 IF J&LABSET#0
->L23 IF SBFLAG=1
PLUG(J,X'58E0')
PLUG(J+2,GLA<<12!4*PAGENO(Q)); J=J+4
KK=14 UNLESS K=0
L21: PLUG(J+2,KK<<12!Q&X'FFF'); ->L1
L22: J=J&X'FFFFFF'; KK=10
L23: FAULT(99) IF Q>4095; ->L21
L3: JUMP(LEVEL)=OPHEAD
END
ROUTINE PJ(INTEGER MASK,LAB)
!%SHORTROUTINE
INTEGER I,J,Q
J=FIND(LAB,LABEL(LEVEL)); ->L200 IF J=-1
I=J-CODEBASE(LEVEL); ->L50 IF I>=4096
PRX(X'47',MASK,0,10,I); ->L999;! BC MASK,I(10,0)
L50: Q=4*PAGENO(I); ! DISPLACEMENT OF MULTIPLE OF 4K
PCONST(X'58E0D000'!Q); ! L 14,Q(GLA)
PRX(X'47',MASK,14,10,I&4095); ->L999;! BC MASK,?(10,14)
L200: PUSH(JUMP(LEVEL),CA,LAB); PCONST(0) UNLESS SBFLAG=1
PRX(X'47',MASK,10,0,0); ! BC MASK,?(10,?)
L999: END
ROUTINE PLAB(INTEGER M)
!%SHORTROUTINE
MONE=1
IF M>=0 THEN ->L1
PLABEL=PLABEL-1; K=PLABEL
M=K
L1: PUSH(LABEL(LEVEL),CA,M)
R13=0
END
!********** END **** OF **** LABEL ****** ROUTINES **************
ROUTINE CHECK RF
!%SHORTROUTINE
COPYTAG(A(MARKER1))
->L1 UNLESS TYPE=4
JJ=K; FROM LIST(JJ,Q,FNAME)
DUMP(0,4,Q,0,I); ! ADDR OF FORMAT TO R4
->L9
L1: K=-1; FAULT(62)
L9: END
ROUTINE DUMP(INTEGER CODE,REG,DIS,X,LEVEL)
!%SHORTROUTINE
COMMENT CODE=8*(TYPE-1)+2*PREC+Z
INTEGER J
OWNBYTEINTEGERARRAY OPCODE(0:16)=X'41',
X'50',X'58',X'42',X'43',X'40',X'48',X'59',X'49',
X'70',X'78',0(4),X'60',X'68'
J=OPCODE(CODE);FAULT(248) IF J=0
->L4 IF CODE=4; ! IC NEEDED
->L1 UNLESS CODE=0=DIS; ! OPTIMISE LOAD ADDR
->L3 UNLESS LEVEL=0=X
PRR(X'1F',REG,REG); ->L99; ! SLR INSTEAD LO LA REG,0
L3: ->L1 UNLESS LEVEL=0 OR X=0
PRR(X'18',REG,X+LEVEL) UNLESS REG=X+LEVEL;->L99
L4: PRR(X'1F',REG,REG) IF X#REG#LEVEL; ! SLR FOR BYTE
L1: PRX(J,REG,X,LEVEL,DIS)
COMMENT AND WITH 255 FOR BYTE IF SLR NOT POSSIBLE AS ADDR IN R
PRX(X'54',REG,0,GLA,24) UNLESS CODE#4 OR X#REG#LEVEL
L99: END
END
ENDOFPROGRAM