BEGIN
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)
PRINTTEXT'E.R.C.C. IMP(SYS1) COMPILER '
PRINTTEXT' RELEASE 5 ALL-IMP VERSION'
PRINTTEXT' 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)
SYSTEMROUTINESPEC 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)
EXTERNAL C
ROUTINESPEC RECODE (INTEGER START,FINISH,CA)
ROUTINESPEC READ LINE(BYTEINTEGER N)
FAULT 9->INEND,18->SUBSCHAR
! START OF COMPILATION
INITIALISE
LPUT(0,1,1,ADDR(LETT(1)))
8: READLINE(0); Q=1
5: R=1; P=SS
OLDLINE=LINE; COMPARE
FAULT(102) IF R>ARSIZE
->6 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
->7 IF A(1)=13; ! END OF PROGRAM
9: ->8 IF Q>=LENGTH ;->5
6: FAULT(100); ->9
7: !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)
15: READSYMBOL(I); ->8 IF I=10
PRINTSYMBOL(I); ->15
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'
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 '
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)
->129 IF FAULTY #0
NEWLINE; WRITE(STMTS,4)
PRINTTEXT' STATEMENTS COMPILED SUCCESSFULLY'
120: PRINTTEXT'
CODE OCCUPIES'
WRITE(K,3);PRINTTEXT' BYTES GLAP'
WRITE(N0<<2,3); PRINTTEXT' +'
WRITE(CONSTPTR<<2,1); PRINTTEXT' BYTES DIAG TABLES'
WRITE(SSTL+4,4); PRINTTEXT' 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); PRINTTEXT' BYTES'
NEWLINE
NEWLINE
LPUT(7,24,0,ADDR(ST(0)))
RETURN
129: PRINTTEXT'
PROGRAM CONTAINS'; WRITE(FAULTY,2); PRINTTEXT' FAULTS'; ->120
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
1: ->START UNLESS N=0 AND NEXT SYMBOL=10; ! IGNORE EMPTY LINES
SKIP SYMBOL; ->1; ! IN PROGRAM MODE ONLY
START: ->2 IF LIST=0
WRITE(LINE,5)
PRINT SYMBOL(M'''') IF N#0
SPACES(4*LEVEL-N)
2: READ SYMBOL(I)
PRINT SYMBOL(I) UNLESS LIST=0
->4 UNLESS N=0
->3 UNLESS I='%'
DEL=128; ->2
3: DEL=0 UNLESS 'A'<=I<='Z'
->2 IF I=' '
4: LENGTH=LENGTH+1
CC(LENGTH)=I!DEL
IF I=M'''' THEN N=1-N
->2 UNLESS I=10
RETURN UNLESS CC(LENGTH-1)= 'C'+128
LENGTH=LENGTH-1
->2 IF LIST=0
SPACES(5); PRINTSYMBOL('C'); SPACES(4*LEVEL); ->2
END
ROUTINE FAULT(BYTEINTEGER N)
SHORTROUTINE
INTEGER I,J,QP
PRINTTEXT'
*'; WRITE(LINE,4); I=3; I=3*LEVEL IF LIST=0 ; SPACES(I)
FAULTY=FAULTY+1
->9 IF N=100; PRINTTEXT'FAULT'; WRITE(N,2)
->2 IF N<100; PRINTTEXT' DISASTER '
MONITORSTOP
2: PRINTNAME(FNAME) UNLESS 7#N#16; ->99
9: PRINTTEXT' SYNTAX '
->11 IF LINE#OLDLINE
QP=Q
CYCLE Q=Q,1,LENGTH-1
PRINTSYMBOL(CC(Q))
->10 IF CC(Q)=';'
REPEAT
10: Q =Q+1
->99 IF I+20+Q-QP>120
NEWLINE; SPACES(I+QMAX-QP+17)
PRINTSYMBOL('!')
NEWLINE
->99
11: PRINTTEXT'
TEXT MODE FAILURE '; WRITE(LINE-OLDLINE,1)
PRINTTEXT' LINES LOST '
NEWLINE; Q=QMAX
99: 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
1: R=R+1
BIP(1000):2: ! SUCCESS ON TO NEXT ITEM
RS=RS+1; ->8 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
->4 IF ITEM>=1300; ! BRICK IS A PHRASE TYPE
->6 IF ITEM>=1000; ! BRICK IS BUILT IN PHRASE
CYCLE J=1,1,CLETT(ITEM); ! BRICK IS LITERAL
->3 UNLESS CC(Q)=CLETT(J+ITEM)
Q=Q+1; REPEAT; !CHECK IT WITH LITERAL DICT ENTRY
->2; ! MATCHED SUCCESSFULLY
4: ! PHRASE TYPE ALTERNATE
P=ITEM; COMPARE; ! RCALL COMPARE TO RECOGNISE IT
->2 IF HIT#0; ! FOUND
3: QMAX=Q IF Q>QMAX; ! FAILURE - NOTE POSITION REACHD
Q=RQ; R=RR; ! RESET LINE AND A.R. POINTERS
->7 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); ->1
8: ! COMPLETE SUCCESS
HIT=1; RETURN
7: ! UTTER FAILURE
HIT=0; RETURN
6: ! BUILT IN PHRASE
I=CC(Q); ->BIP(ITEM); ! SO SWITCH TO IT
BIP(1001): ! PHRASE NAME
PNAME; ->1 IF HIT=1; ->3
BIP(1002): ! PHRASE U/CODE INSRN
->3 UNLESS 'A'<=I<='Z'
S=I; J=1
200: Q=Q+1; I=CC(Q)
->201 UNLESS 'A'<=I<='Z'
S=S<<8!I;J=J+1; ->200
201: ->3 UNLESS I='_' AND J<=4
Q=Q+1; ->2
BIP(1003): ! PHRASE CONST
CONST(0)
->3 IF HIT=0
->1 IF CTYPE=5
->26 IF CTYPE=2; ! %REAL
->22 IF S>>12=0
A(R)=1
TOAR4(R+1,S); R=R+3; ->2
22: A(R)=9; R=R+1; A(R)=S; ->1
26: A(R)=2; TOAR8(R+1,CVALUE); R=R+5; ->2
BIP(1005): ! PHRASE N
->3 UNLESS '0'<=I<='9'; ! MUST START WITH DIGIT
CONST(2); A(R)=S; ->1
BIP(1004): ! PHRASE CONSTLIST
CONSTLIST;->1
BIP(1006): ! PHRASE S=SEPARATOR
->2 IF I=10
->3 UNLESS I=';'
Q=Q+1; ->2
BIP(1007):30: ! PHRASE TEXT=COMMENT TEXT
->1 UNLESS 10#I#';'
Q=Q+1; I=CC(Q); ->30
BIP(1008): ! PHRASE TEXTTEXT=BETWEEN QUOTES
TEXTTEXT
->3 IF HIT=0;->1
BIP(1009): ! PHRASE NAMELIST
! GIVES AR IN FORM NNAMES,NAME1,....NAMEN
U=R; V=1; R=R+1
PNAME; ->3 IF HIT=0
90: ->91 UNLESS CC(Q)=','
Q=Q+1; R=R+1
I=CC(Q)
PNAME
->92 IF HIT=0; V=V+1; ->90
92: R=R-1; Q=Q-1
91: A(U)=V; ->1
BIP(1010): ! PHRASE HOLE
MARKER=R; ->1
BIP(1011): ! PHRASE MARK
A(MARKER)=R-MARKER; ->2
BIP(1012): ! PHRASE UCRR=RR FORMAT
->124 IF S&255='R'; ! LAST LETTER=R
CYCLE I=0,1,2
->120 IF S=NEM(I)
REPEAT; ->3
120: A(R)=OPC(I)&63; ->1
124: J=S>>8; CYCLE I=2,1,48
->120 IF J=NEM(I)
REPEAT; ->3
BIP(1013): ! PHRASE UCRX=RX FORMAT
CYCLE I=18,1,64
->130 IF S=NEM(I)
REPEAT; ->3
130: A(R)=OPC(I); ->1
BIP(1014): ! PHRASE UCRS=R,R,DB FORMAT
CYCLE I=66,1,69
->130 IF S=NEM(I)
REPEAT; ->3
BIP(1015): ! PHRASE UCSI=STORE IMDTE
CYCLE I=71,1,83
->130 IF S=NEM(I)
REPEAT; ->3
BIP(1016): ! PHRASE UCSHIFT=SHIFT INSTRNS
CYCLE I=85,1,92
->130 IF S=NEM(I)
REPEAT; ->3
BIP(1017): ! PHRASE UCSS=STORE TO STORE
CYCLE I=94,1,106
->130 IF S=NEM(I)
REPEAT; ->3
BIP(1018): ! PHRASE UCPD=PACKED DECIMAL
CYCLE I=108,1,116
->130 IF S=NEM(I)
REPEAT; ->3
BIP(1019): ! PHRASE UCSPEC=THE FUNNIES
CYCLE I=118,1,120
->130 IF S=NEM(I)
REPEAT; ->3
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)
-> 3 UNLESS 'A'<=I<='Z'; ! 1ST CHAR MUST BE LETTER
->3 IF CC(Q+1)=M'''' AND(I='B' OR I='X' OR I='M')
S=2; T=1; -> 10
12: Q=Q+1; I=CC(Q)
-> 101 UNLESS 'A'<=I<='Z' OR '0'<=I<='9'
T=T+1; S=S+1
10: LETT(NEXT+T)=I; ->12
101: 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)
-> 2 IF LL=0; ! NAME NOT KNOWN
CYCLE JJ=1,1,LETT(LL)
-> FAIL UNLESS LETT(NEXT+JJ)=LETT(LL+JJ)
REPEAT; -> 41; ! NAME FOUND
FAIL: REPEAT
FAULT(104); ! TOO MANY NAMES
2: WORD(KK)=NEXT; NEXT=NEXT+S
41: A(R)=KK; HIT=1
3: 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 M'0'<=I<=M'9'
->DOT IF I='.' AND MODE=0 AND '0'<=CC(Q+1)<='9'; ! 1 DIDT MIN
-> PI IF I='$' AND MODE=0
->101 IF I=M''''
->150 UNLESS CC(Q+1)=M''''; Q=Q+2
->102 IF I='X'; ->MULT IF I='M'
->104 IF I=M'B'
Q=Q-2; ->150
PI:
CVALUE=3.14159 26535 89793 23846; Q=Q+1; ->40
101: S=R; A(R)=5; R=R+1
TEXTTEXT
->24 IF A(S+1)=0; ! NULL STRING
->27 IF A(S+1)=1; ! SINGLE CHAR CONSTANT
CTYPE=5; RETURN
24: R=S; S=0; ->99
27: R=S; S=A(S+2); ->99
102: I=CC(Q); Q=Q+1; ! HEX CONSTANTS
->99 IF I=M''''
->5 IF M'0'<=I<=M'9'
->150 UNLESS M'A'<=I<=M'F'
S=S<<4!(I-'A'+10); ->102
5: S=S<<4!(I-'0'); ->102
MULT: T=0; ! MULTIPLE CONSTANTS
28: I=CC(Q); Q=Q+1; ->22 IF I=M''''
29: S=S<<8!I; T=T+1; ->150 IF T>=5; ->28
22: ->99 UNLESS CC(Q)=M''''; Q=Q+1; ->29
104: T=Q; ! BINARY CONST
32: I=CC(Q); Q=Q+1
->31 IF M'1'#I#M'0'
S=S<<1!(I-'0')
->150 IF Q-T>=33; ->32
31: ->99 IF I=M''''; ->150
N: I=I&15; CVALUE=10*CVALUE+I
Q=Q+1; I=CC(Q)
->N IF M'0'<=I<=M'9'
-> ALPHA UNLESS MODE=0 AND I='.'
DOT: Q=Q+1; X=10
45: I=CC(Q); -> ALPHA UNLESS M'0'<=I<=M'9'
I=I&15; CVALUE=CVALUE+I/X
X=10*X
Q=Q+1; ->45
ALPHA: COMMENT TEST FOR EXPONENT
-> FIX UNLESS MODE=0 AND CC(Q)='@'
Q=Q+1; X=CVALUE
Z=1; ->39 IF '+'#CC(Q)#'-'
Z=-1 IF CC(Q)='-'; Q=Q+1
39: CONST(2); ->150 IF HIT=0; S=S*Z
IF S=-99 THEN CVALUE=0 ELSE CVALUE=X*10**S
FIX: COMMENT SEE IF IT IS INTEGER
->40 IF CVALUE>IMAX; ! TOO BIG
->41 IF FRACPT(CVALUE)=0
40: CTYPE=2; HIT=1; RETURN
41: S=INT(CVALUE)
99: CTYPE=1; HIT=1; RETURN
150: 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
6: RQ=Q; I=CC(Q); SIGN=1; ->7 IF I='-'
->8 IF I='+'; ->9
7: SIGN=-1; ->99 IF CPW=4
8: Q=Q+1; I=CC(Q)
9: CONST(0); RF=1
->98 IF HIT=0
->1 UNLESS CC(Q)='('
J=S; Q=Q+1; C=CVALUE
CONST(2); ->98 UNLESS HIT=1 AND S>0 AND CC(Q)=')'
Q=Q+1
CVALUE=C; RF=S; S=J
1: ->21 IF TYPEP=2
->51 IF TYPEP=5
->99 IF CPW=4 AND S>255
->99 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
->5 UNLESS (CPW-1)&NCONST=0
PSYM(VALUE); VALUE=0
5: REPEAT
11: ->99 UNLESS CC(Q)=','; Q=Q+1
->6 UNLESS CC(Q)=10
READLINE(0); Q=1; ->6
21: 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; ->11
51: ->52 IF CTYPE=5
->98 UNLESS CTYPE=1 AND S<=127
A(RP+3)=1; A(RP+4)=S
52: ->98 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
->55 UNLESS N<0
PSYM(VALUE); N=24; VALUE=0
55: REPEAT
NCONST=NCONST+1
REPEAT; R=RP+2; ->11
98: Q=RQ
99: 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
->98 UNLESS I=M'''' ; !FAIL UNLESS INITIAL QUOTE
Q=Q+1
1: I=CC(Q);A(R)=I;R=R+1
->31 IF I=M''''
->32 IF I=10
Q=Q+1;FAULT(106) IF R-S>256
->1
32: READ LINE(1);Q=1;->1
31: ->35 UNLESS CC(Q+1)=M''''
Q=Q+2;->1
35: R=R-2;J=R-S;->36 UNLESS J&1=0
R=R+1;A(R)=0
36: A(S)=J;Q=Q+1;HIT=1;->99
98: HIT=0
99: END
ROUTINE SET UP LIST
SHORTROUTINE
INTEGER J,K
CYCLE J=0,8,ASL-16
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
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)
SHORT INTEGER(AD)<- A(PTR)
SHORT INTEGER(AD+2)<- A(PTR+1)
END
ROUTINE FROMAR8(INTEGER PTR,LONGREALNAME VALUE)
INTEGER AD; AD=ADDR(VALUE)
SHORT INTEGER(AD)<- A(PTR)
SHORT INTEGER(AD+2)<- A(PTR+1)
SHORT INTEGER(AD+4)<- A(PTR+2)
SHORT INTEGER(AD+6)<- A(PTR+3)
END
ROUTINE PRINTNAME (INTEGER N)
SHORTROUTINE
INTEGER J,V
->4 IF N>=0; N=-N
->5 UNLESS 16384<=N<=16384+NNAMES
N=N-16384; ->4
5: WRITE(N,1); ->3
4: SPACE; V=WORD(N)
CYCLE J=1,1,LETT(V)
PRINT SYMBOL(LETT(V+J))
REPEAT
3: 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
1: ->9 IF CA&J=I; PLANT(X'0700'); ->1
9: 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) ; ->99
INBUF: CODE((J-CABUF)>>1)<-K
99: 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
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)
->1 IF TOTAL>FREE
REPEAT
RETURN
1: ->2 UNLESS J=0
PRINTTEXT'NOT ENOUGH CORE ALLOCATED FOR IMP'
MONITORSTOP
2: 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)
ROUTINESPEC STORE STRING(INTEGER Z,FROM,TO,BML,DML)
ROUTINESPEC CEND(INTEGER KKK)
ROUTINESPEC CBPAIR(INTEGERNAME LB,UB)
ROUTINESPEC UNDCRF (SHORTINTEGERNAME OPHEAD)
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)
ROUTINESPEC FROM LIST(INTEGER CELL,INTEGERNAME S1,S2)
ROUTINESPEC POP(SHORTINTEGERNAME CELL,INTEGERNAME S1,S2)
ROUTINESPEC PUSH(SHORTINTEGERNAME CELL,INTEGER S1,S2)
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; ->101 IF A(MARKER2)=2
MASK=15; CUI(0); ->1
101: Q=P
FAULT(54) IF A(P)=9; ! START
SAVE13=R13; CHNGE13=0
->103 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)
104: PUSH(LOCAL LABEL,CA,KKK)
R13=0 UNLESS R13=SAVE13 AND CHNGE13=0
102: REGISTER(LOCAL BASE)=0 UNLESS LOCAL BASE=10 OR LOCALBASE=0
FILL LOCAL JUMPS; ->1
103: 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); ->102
!
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)
->202 IF CHECKSP=0
DUMP(0,2,INC,0,RBASE); PPJ(17)
202: PLAB(-1); REGISTER(4)=0
DUMP(1,1,0,0,4)
PUSH(CYCLE(LEVEL),K,INC+4096*BXLE)
->1
!
SW(3): !REPEAT
SET LINE
POP(CYCLE(LEVEL),J,K)
->302 UNLESS J=-1
FAULT(1); ->1
302: BXLE=K>>12; K=K&4095
PRX(X'98',2,4,RBASE,K); ! LM 2,4,?
DUMP(2,1,0,0,4); ->301 IF BXLE=1
PLANT(X'1A12'); ! AR 1,2
PCONST(X'59304000'); ! C 3,0(4)
K=J; PJ(7,K); ->1
301: I=FIND(J,LABEL(LEVEL))
PRX(X'87',1,2,10,I-CODEBASE(LEVEL)); ->1;! BXLE 1,2,ADDR
SW(4): ! (LABEL)':'
K=A(P+2)+(A(P+1)-1)<<14
->402 IF FIND(K,LABEL(LEVEL))=-1
FAULT(2); ->1
402: PLAB(K); ->1
SW(5): Q=P+1; MARKER2=P+3+A (P+2);
SET LINE; P=MARKER2
SAVE13=R13; CHNGE13=0
->510 IF A(P)=3; ! UI=JUMP
->520 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)
->104 UNLESS A(P)=1; ! %ELSE FOLLOWS
P=P+1; ->107 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; ->104
107: PJ(15,SFLABEL-1)
CUI(2); ->104
510: 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; ->102 UNLESS A(P)=1
P=P+1; MASK=15; CUI(0); ->102
520: 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; ->102
SW(6):1: ! %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);->1
VECTOR: ARR=2; NAM=0; PACK(PTYPE)
P=P+1; SET LINE; CVDECLN; ->1
SCALAR: J=0;ROUT=0;CQN(P+1);P=P+2
INC=N
QQ=ACC;ACC=4 IF TYPE=5;JJ=0
->701 UNLESS ACC=8 AND N&7#0
PUSH(WSP(LEVEL),0,N);N=N+4 ;!DOUBLE WORD BOUNDARY
701: SET LINE IF TYPE=5
PACK(PTYPE)
CYCLE KK=1,1,A(P)
K=A(P+KK);TESTNST
STORE TAG(K,N)
->705 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
705: N=N+ACC;REPEAT
N=N+3; N=N&(-4)
SET80(INC,N-INC) IF UNASS=1 AND TYPE#5
->1
SW(8): ! %END
CEND(FLAG(LEVEL))
->1
SW(9): P=P+1; MARKER1=A(P)+P; !(SEX)(RT)(SPEC')(NAME)(FPP)
900: Q=P; KKK=A(MARKER1+1); !KKK ON NAME
EXTRN=A(P+1)
->902 IF A(MARKER1)=2
P=P+1; CRSPEC(0); ->1 IF EXTRN=3
N0=N0-1; KK='S'*(2-EXTRN)
GXREF(KKK,KK); JJ=TAGS(KKK)
FROM1(JJ,Q)
REPLACE1(JJ,Q&(-2)); ->1
902: FILL JUMPS(LEVEL)
KK=KKK
COPY TAG(KKK); ->939 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
->908 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); ->909
908: KKK=10000
909: ->940 IF J=15 AND PTYPE=KKK
FNAME=KK; FAULT(7) UNLESS PTYPE&7=7
939: P=Q+1; CRSPEC(0); P=Q; ->900
940: J=0; REPLACETAG(KK); JJ=K; ! CHANGE TAGTO ROUT SPECIFIED%C
!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
->942 IF A(P+1)=2
943: P=P+2; COMPILE FORMAL PARAMETER
CYCLE BXLE=1,1,A(P)
MLINK(JJ); -> 945 UNLESS JJ=0
FAULT(8); ->946
945: FROM LIST(JJ,J,JJJ)
->946 IF J=PTYPE AND(PTYPE#5 OR JJJ=ACC)
FAULT(9); PRINT NAME(A(P+BXLE))
946: K=A(P+BXLE); TESTNST
OPHEAD=0; UNPACK
->947 IF ROUT=1; ! RT TYPES
->9040 IF PTYPE=5; J=JJJ
->948 IF TYPE=3; !RECORDS
R=N; ->950 IF ARR=1
->949 IF PREC=3 AND NAM=0; ! LONG
N=N+4-ACC; R=N
950: STORE TAG(K,N)
N=R+ACC; ->999
947: PUSH(OPHEAD,N,1000); !SET DUMMY SIDECHAIN FOR RT TYPES
J=13
951: KK=OPHEAD
R=N; N=KK; ->950
9040: 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); ->999
948: PUSH(OPHEAD,0,N); J=0; ->951; ! DUMMY SIDECHAIN FOR RECORD
949: R=N; ->950 IF N&7=0
PUSH(WSP(LEVEL),0,N)
N=N+4; R=N; ->950; !ALLIGN ON D W BOUNDARY
999: REPEAT
P=P+1+BXLE; ->943 IF A(P)=1
942: MLINK(JJ); FAULT(10) UNLESS JJ=0; ->1202
!
SW(10): ! COMMENT
->1
!
SW(11): !REALS(LN)
ALL LONG=A(P+1)&1;->1
SW(12): !%BEGIN
FILL JUMPS(LEVEL)
RAL(LEVEL)=SBFLAG<<15!N
PTYPE=0; RHEAD(-1)
FLAG(LEVEL)=0
->1 IF LEVEL=1=RLEVEL
->1202 UNLESS LEVEL=2
CPRMODE=1 IF CPRMODE=0
DEFINE EP(0,0,0)
FAULT(55) UNLESS CPRMODE=1
1202: PLANT(X'05A0'); CODEBASE(LEVEL)=CA; ->1
SW(13): ! %ENDOFPROGRAM
FAULT(15) UNLESS LEVEL=2
FAULT(56) UNLESS CPRMODE=1
PERM=0; CEND(1)
LOAD DATA; ->1
SW(14): BEGIN; !SWITCH LABEL
SHORTROUTINE
R13=0;MONE=1
COPYTAG(A(P+1))
->1401 IF OLDI=LEVEL AND TYPE=6
FAULT(4); ->1
1401: FROM LIST(K,ACC,KKK)
MLINK(K); FROM LIST(K,QQ,KK); ! UB & BIT LIST PART 1
->1411 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
->1402 IF KKK<=JJ<=KK
1411: FAULT(5); ->1
1402: Q=JJ-KKK
1404: ->1403 IF 31>=Q
MLINK(K); Q=Q-32
FROM LIST(K,QQ,JJJ); ->1404
1403: JJJ=1<<Q; FAULT(6) UNLESS JJJ&QQ=0
REPLACE1(K,QQ!JJJ); ! UPDATE BIT LIST
Q=CA-CODEBASE(LEVEL)
->1407 IF PREC#0
QQ=ACC+8+(JJ-KKK)<<2; ! WHERE TO PLUG
PLUG(QQ,Q>>16) UNLESS Q>>16=0
1406: PLUG(QQ+2,Q&X'FFFF'); ->1
1407: QQ=ACC+6+(JJ-KKK)<<1
FAULT(99) IF Q>X'7FFF';->1406
!
1: END;->1
SW(15): BEGIN; !SWITCH (SWITCH LIST)
SHORTROUTINE
INTEGER BP,QQQ
Q=P;CNOP(0,4);PJ(15,PLABEL-1)
FAULT(56) UNLESS LEVEL>=2
1528: P=Q+A(Q+1)+2
CBPAIR(KKK,KK); ! LB TO KKK, UB TO KK
->1501 UNLESS !KKK!<X'7FFF'>!KK!
->1535 IF KKK<=KK; FAULT(27); KK=KKK
1535: 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)
1503: ->1504 IF KK-R<32
INSERT AFTER(OPHEAD,0,0)
R=R+32; ->1503; ! SET UP BIT LIST
1504: 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; ->1528 UNLESS A(Q)=2
PLAB(-1); ->1
1501: FAULT(18); KK=0; KKK=0; ->1535
1: END;->1
SW(16): QU=¬A(P+1)&1; P=P+2; ->1
!
SW(17): ! '%REGISTER' (NAME)
KK=CLAIMABLE REG
->1999 IF KK=0
REGISTER(KK)=-LEVEL
UVARREG(KK)=LEVEL
PTYPE=8; J=0
K=A(P+1); TESTNST
STORE TAG(K,KK); ->1
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
->1801 UNLESS A(P)=2; ! NO CONST
A(P+1)=4; A(P+2)=9; A(P+3)=0; ! 0== NULL STRING ALSO
1801: SIGN=A(P+1); ->1820 IF TYPE=5; ! STRING
JJ= SORT CONST(P+2,PREC&1,TYPE)
->1810 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
1803: 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); ->99
1810: FAULT(44) IF SIGN=3; ! ¬ WITH REAL
->1803 UNLESS SIGN=2
ST(JJ>>2)=ST(JJ>>2)!X'80000000';! OR IN SIGN BIT
->1803
1820: ! STRINGS
->1822 UNLESS A(P+2)=9 AND A(P+3)<127
A(P+2)=5; A(P+4)=A(P+3); A(P+3)=1
1822: 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; ->99
NONSCALAR:CBPAIR(KK,KKK)
IF TYPE=5 THEN BP=ACC ELSE BP=BYTES(PREC)
LENGTH=KKK-KK+1
IF A(P+1)=0 THEN ->3; ! NO CONSTLIST
1: 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; ->99
3: A(P+2)=CONSTPTR
A(P+1)=LENGTH; ->1 IF LENGTH<1
CYCLE JJ=1,1,(LENGTH*BP+3)//4
PSYM(0); REPEAT; ->1
99: END; ->1
SW(19): ! %CLAIM/RELEASE ETC
COPY TAG(A(P+3))
->1910 IF A(P+2)=1; ! '%ARRAY'
->1999 UNLESS ARR=0 AND TYPE=3
FROM2(K,K); ->1920
1910: ->1999 UNLESS ARR=1 AND TYPE<=3 AND J<=2
1920: ->1930 IF A(P+1)=2; ! %RELEASE
KK=CLAIMABLE REG; ->1999 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
1925: REPLACE1(JJ,JJJ); ->1
1930: ->1999 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'; ->1925
1999: FAULT(58); ->1
SW(26): COMPILER=1; UNASS=0; ->1
SW(27): ! '%SPEC' FPP
P=P+1; ->2701 IF A(P+1)=1
CRSPEC(2); ->1
2701: COPY TAG(A(P))
->3901 UNLESS PTYPE=4 AND A(P+4)=2=A(P+3)
P=P+2; K=DISPLACEMENT(TAGS(A(P-2)))
->1 IF K=-1; OPHEAD=K;
P=P+2; CRSPEC(3); ->1
SW(20): MCSWITCH=1; PERM=1; ->1; ! %MCODE
SW(21): SBFLAG=1; ->1
SW(22): P=2; CUCI; ->1; ! *UCI(S)
SW(23): ! %FAULT FAULTLIST
FAULT(26) UNLESS LEVEL=2 AND CPRMODE#2
P=P+1; Q=P+1
2302: IF A(Q)=2 THEN ->2303
Q=Q+2; ->2302
2303: 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; ->2303 IF A(P-1)=1
->1 IF A(P+2)=2
P=P+3; Q=P+1; ->2302
SW(24): FAULT(56) UNLESS CPRMODE=2 AND RLEVEL=1
LOAD DATA;FINALISE
STOP
SW(25): MCSWITCH=0; PERM=0; ->1; ! %ENDOFMCODE
SW(28): !%NAME - SPECIAL NAME
J=0; PTYPE=10006
STORE TAG(A(P+1),SNUM)
SNUM=SNUM+1;->1
SW(29): LIST=1; ->1; ! %LIST
SW(30): LIST=0; ->1
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
->1
SW(32): POP(SBR(LEVEL),J,K); ! FINISH (ELSE')
->321 UNLESS J=-1; FAULT(51); ->1
321: POP(CYCLE(LEVEL),JJ,KK)
->322 IF 0>=JJ
FAULT(52); ->321
322: ->402 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); ->1
SW(33): !RECORD FORMAT
FAULT(56) UNLESS LEVEL>=2
SET LINE; CRFORMAT; ->1
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;->1 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
3401: 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
->1 IF A(P)=2
P=P+1;CHECK RF;->3401
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; ->1
ROUTINE TEST AND SET
TEST NST
JJJ=NEWCELL
STORE TAG(K,JJJ)
REPLACE BOTH(JJJ,TAGS(A(MARKER1)),N)
END
1: END;->1
SW(35): ! (RT)'%NAME'(NAMELIST)
P=P+1; MARKER1=P+A(P)
->3801 IF A(P+1)=1
ROUT=1; P=P+2;CLT
ARR=2-A(P+1);NAM=(A(P+2)-1)<<1
PACK(PTYPE); ->3802
3801: PTYPE=11000
3802: 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; ->1
SW(36): ! RECORD SPEC
P=P+1; MARKER1=P+A(P)
CHECK RF; ->1 IF K=-1
P=P+1; COPYTAG(A(P))
->3910 IF A(P+1)=1
->3902 IF TYPE=3 AND NAM=1
3901: FAULT(63); ->1
3902: FROM1(K,Q)
FAULT(63) UNLESS Q=0
REPLACE1(K,TAGS(A(MARKER1))); ->1
3910:
P=P+2; K=DISPLACEMENT(TAGS(A(P-2)))
->3901 IF K=-1; ->3902
SW(37): ->1; ! (S)
!
ROUTINE CEND (INTEGER KKK)
SHORT ROUTINE
INTEGER DPTR,LNUM,W1,W2
INTEGERARRAY DD(0:300)
SET LINE; R13=0; MONE=1
1: FROM LIST (SBR(LEVEL),J,K)
->2 IF J=-1; FAULT (53); ! FINISH MISSING
A(2)=32; A(3)=2; CSS(2); ! SO COMPILE IT IN
->1
2: FILL JUMPS(LEVEL)
NMAX=N IF N>NMAX; ! WORK SPACE POINTER
POP (JUMP(LEVEL),J,K)
->3 IF J=-1
->2 IF K>=SFLABEL; FAULT(11)
IF K<16384 THEN WRITE(K,4) ELSE PRINTNAME(K-16384); ->2;
3: 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
->10 IF DIAGS1=0
LNUM=LETT(M(LEVEL))
DD(0)=X'C2C2C2C2'
DD(1)=L(LEVEL)<<16!RBASE<<8!LNUM
DPTR=3; ->9 UNLESS LNUM=0
DD(2)=L(LEVEL-1); ->10
9: 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
10: POP(NAME(LEVEL),J,JJ)
->20 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
->12 UNLESS J=15
FAULT (28); PRINT NAME (JJ)
12: OPHEAD=K; ->13 IF TYPE=4
->14 UNLESS ROUT=1 OR TYPE=3 OR TYPE=6 OR ARR=2
CLEAR LIST(OPHEAD); ->10
13: UNDCRF (OPHEAD)
->10
14: ->10 UNLESS TYPE=1 OR TYPE=2 OR TYPE=5
->10 UNLESS ARR=0 AND DIAGS1=1 AND ROUT=0
->10 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;->10
20: ->21 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
21: ->22 IF CYCLE(LEVEL)=0
FROM2(CYCLE(LEVEL),J)
->22 IF J=0
POP(CYCLE(LEVEL),I,I)
FAULT (13); ->21
22: 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
->23 IF KKK=10000
->24 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; ->30; ! 'STOP' AT END OF PROGRAM
23: P=P+1; A(P)=5; CUI(0); ->30; ! COMPILE '%RTURN' FOR ROUTINES
24: 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
30: ->99 IF KKK=2; NEWLINE
IF PRINTMAP=1 AND LIST=1 AND KKK#0 THEN START
PRINTTEXT' LOCALS EXTEND TO '
WRITE(NMAX,2); NEWLINE; FINISH
->31 IF LIST#0; WRITE(LINE,5)
SPACES(3*LEVEL-3); PRINTTEXT 'END'
31: ->33 IF LEVEL>2 OR PERM=1 OR CPRMODE=2
->32 IF KKK=1
FAULT(14); A(1)=13; ->99; ! TOO MANY ENDS
32: KKK=2
33: 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
->2 IF KKK=2; ! ROUND AGAIN FOR 'ENDOFPROGRAM'
->99 IF RLEVEL=1 AND CPRMODE=2
->99 IF KKK=0 OR COMPILER=1
FROM2(JUMP(LEVEL),J) ; PLAB(J)
99: END
ROUTINE CRSPEC (BYTEINTEGER M)
SHORTROUTINE
INTEGER PP,KK,JJ,JJJ,Q,TYPEP
->12 IF M=3
PP=P; ->2 UNLESS M=2
KK=A(P); P=P+1; COPYTAG(KK)
->1 IF OLDI=LEVEL AND 10006#PTYPE>=10000
FAULT(3); ->99
1: FROM LIST(K,JJ,Q); OPHEAD=K
->12 IF Q=1000; ->10
2: ->3 IF A(PP+1)=2
TYPEP=10000; P=PP+3; ->4
3: ROUT=1;ARR=0;P=PP+2;CLT
NAM=(A(P)-1)*2; PACK(TYPEP); P=P+2
4: KK=A(P); COPYTAG(KK)
->11 IF OLDI#LEVEL
->1 IF PTYPE=TYPEP OR !PTYPE-TYPEP!=1000
10: FNAME=KK;FAULT(7) UNLESS PTYPE=7
->99 IF M=2
11: 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)
12: JJJ=OPHEAD; Q=0; ->24 IF A(P+1)=2; ! NO FORMAL PARAMS
13: 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; ->13 IF A(P)=1
24: REPLACE2(JJJ,Q)
->99 IF M=3
REPLACE1(JJJ,JJ)
99: 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
->1 UNLESS A(P+1)=1
PREC=0;TYPE=0;P=P+3; ->98
1: P=P+2; CLT;NAM =2*(A(P)-1)+1
P=P+2; ACC=16; ->98
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; ->98
FPD(3): !%NAME
TYPE=0
31: NAM=1; ARR=2-A(P+1); ROUT=0
ACC=4+12*ARR
PREC=0; P=P+2; ->98
FPD(4): TYPE=3; ->31
98: 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
->34 IF TYPE=2
->50 IF TYPE=5
->35 IF TYPE=3
->32 IF NAM=0 AND TYPE=1 AND ARR=0
33: P=P2+1
KK=0; KK=4 UNLESS ARR=0 AND ROUT=0 AND 1>=TYPE
36: 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
30:
P=KK; IF A(P)=1=QU THEN CQUERY (REG)
P=P+1; ->1
31: PRINTTEXT' CRUNCH '; MONITORSTOP
32: ->33 IF ROUT=1 OR A(P1+2)=1 OR A(P1+3)=1; ! ACTUAL PARAMS
->33 IF UNASS =1
PRECP=PREC; TYPEP=PTYPE
KK=K; REG=I; Q=TSEXP(JJJ)
PTYPE=TYPEP; UNPACK
->33 IF Q=0 OR A(P)=1=QU
->37 IF 10<=Q<=12 AND Q-10=PRECP
->33 UNLESS Q=1 AND PRECP=1
PSI(X'92',JJJ,REG,KK); ! MVI TO SET BYTE
P=P+1;->1; ! SKIP QUERY IF ANY
37: PSS(X'D2',BYTES(PRECP),REG,KK,I,K); ! MVC IF POSSIBL
P=P+1; ->1
34: Q=2; Q=3 IF PREC=3
IF A(P1+2)=1 THEN START
P=P1+2; FFLAG=0; SKIP APP; ->55 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
->30
35: P=P1+1; Q=COPY RECORD TAG
P=P2+1
TYPE=1 UNLESS TYPE=2 OR TYPE=5
->50 IF TYPE=5
KK=4; ->36 IF TYPE=1; ->34
50: CSTREXP(4);KK=P
REGISTER(4)=1
P=P1+1;
CNAME((ASSOP-1)**2,4)
REGISTER(4)=0
REG=4; ->30
MAPS: IF PTYPE=10006 THEN START
TYPE=TSNAME(K);PREC=TYPE>>3
TYPE=TYPE&7; FINISH
->33 IF TYPE=1; ! NORMAL CHANNELS FOR INT MAPS
->50 IF TYPE=5; ! STRING MAPS
55: 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); ->30; ! 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; ->1
SW(4): !ASSOP=->
P=P1+1; CNAME(2,1)
P=P2+1
CRES(0,0)
P=P+1;->1
SW(1): !ASSOP='=='
P=P1+1; COPYTAG(A(P))
->9 IF I=-1;Q=1
IF TYPE=3 THEN Q=COPY RECORD TAG
->201 IF Q=0
FAULT(81) UNLESS A(P2+1)=4 AND A(P2+2)=1
->101 IF ROUT=1; NEST=4
->S((NAM&2+ARR)<<2!(NAM&1)*2!(2-A(P+1)))
9: 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):
10: FAULT(82)
P=P2+1; SKIPEXP; P=P+1; ->1
S(2): ! NAM=1; S(9):!NAMARR + APP; S(15):! NAMARR +NAM+APP; S(13):
Z=3; ZP=6
12: P=P2+3; CNAME(Z,4)
->10 UNLESS A(P)=2; PRECP=PREC
TYPEP=TYPE
KK=P+2; P=P1+1; CNAME(ZP,4)
14:
P=KK; ->1 IF PREC=PRECP AND TYPE=TYPEP
FAULT(83); ->1
S(6): ! ARRAYNAME-NO APP
S(14): !NAMARRAYNAME-NO APP
Z=12; ZP=11; ->12
201:
->S(6) IF ARR=1 AND NAM=1 AND A(P+1)=2
Z=15; ZP=14; ->12
101: P=P1+1; CNAME(13,1); ! ASSIGNMENTS TO RECORDNAMES
PRECP=PREC; TYPEP=TYPE; JJJ=K;
->10 UNLESS J=0 AND NAM=1
REG=FINDPP; ->31 IF REG=0
DUMP(0,REG,DISP,INDEX,BASE); ! ADDRESS OF LHS TO SAFE PLACE
P=P2+3; CNAME(13,1); ! RHSIDE
->102 IF BASE=GLA AND J=0; ! COMMON OR GARDEN ROUTINE
PSS(X'D2',16,REG,0,BASE,DISP)
->103 IF J=14; ! EXTERNAL ROUTINE
110: REGISTER(REG)=0; KK=P+2
FROM2(JJJ,Z); FROM2(K,ZP)
FAULT(83) UNLESS Z=ZP
->14
102: 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); ->110; ! STUFF OFF + ENVRMNT
103: PRX(X'50',9,0,REG,12); ->110; ! EXTRNS DUMMY ENVRMNT
1: 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)
->3 IF A(MARKER 1)=1
P=P+1; CNAME(0,0); P=P+1; ->1
3: ASSIGN(P,MARKER1+1); ->1
SW(2): !-><NAME><EXRN>
NMDECS(LEVEL)=1
COPY TAG(A(P+1))
PTYPEP=PTYPE
KK=K; P=P+2
->200 IF OLDI=LEVEL AND TYPE=6
FAULT(4);SKIP EXP; ->1
200: CSEXP(1,1);PTYPE=PTYPEP; UNPACK
FROM LIST(KK,QQ,JJ)
QQ=QQ-CODEBASE(LEVEL)
->205 IF CHECKSP=0
201: LOADAD( 2,10,0,QQ);PPJ(7); ->1
205: JJ=8+QQ-JJ*BYTES(PREC); !@ SW(0)
->201 UNLESS 0<=JJ<=4095
->210 IF PREC=0
PLANT(X'1A11');KK= X'48'; !AR_1,1
207: PRX(KK,1,1,10,JJ); !L(H)_1,JJ(1,10)
PCONST(X'47F1A000');->1; !BC_15,0(1,10)
210: PCONST(X'89100002');KK= X'58';->207;! SLL_1,2
SW(3): ! '->'(LABEL)
NMDECS(LEVEL)=1
K=A(P+2)+(A(P+1)-1)<<14
PJ(MASK,K); P=P+3; ->1
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; ->1
SW(5): !RETURN
FAULT(30) UNLESS FLAG(LEVEL)=10000 OR PERM=1
P=P+1
6: 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); ->1; ! BR LINK
SW(6): ! %RESULT =EXPR
P=P+1; KK=FLAG(LEVEL)
FAULT(31) UNLESS KK>10000
->61 IF KK=10002
->62 IF KK=10032
->63 IF KK=10005
CSEXP(1,1); ->6
61: CSEXP(2,2); ->6
62: CSEXP(2,3); ->6
63: CSTREXP(1); ->6
SW(7):SW(8): ! STOP & MONITORSTOP
PPJ(6*(A(P)-6)); P=P+1; ->1
SW(9): SFLABEL=SFLABEL-1
PUSH(SBR(LEVEL),CODE,SFLABEL)
PUSH(CYCLE(LEVEL),0,0)
->1
SW(11): ! %QUERIES (ONOFF)
KK=2-A(P+1); P=P+2
PSI(X'92',KK,GLA,1); ->1
SW(10): PPJ(31); P=P+1; ; ! MONITOR
1: 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
->101 IF A(P)=2; ! NO FPP
1: P=P+1; COMPILE FORMAL PARAMETER
LENGTHP=ACC-1; LENGTHP=3 IF ACC>8
2: ->3 IF INCP&LENGTHP=0; INCP=INCP+1; ->2
3: CYCLE REP=1,1,A(P); P=P+1
CODE=255; LENGTHP=ACC
->11 IF ROUT=1
->12 IF TYPE=3;QQQ=INCP
->4 UNLESS TYPE=5
CODE=250; LENGTHP=ACC-1; QQQ=INC
4: 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
->15
11: QQQ=NEWCELL; REPLACE BOTH(QQQ,INCP,100)
FAULT(41) UNLESS PTYPE=11000; ! FUNCTIONS TOO DICEY AT PRESENT
ACC=40; LENGTHP=ACC; ->4; ! RT NAME MUST CARRY ENVRMNT
12: QQQ=NEWCELL; REPLACE BOTH(QQQ,0,INCP); ->4
15: REPEAT
P=P+1; ! P ON REST OF FP LIST
->101 IF A(P)=2; P=P+1; ->1
101: P=P+1
102: ->201 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)
103:
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
105: INSERT AFTER(OPHEAD,J!PTYPE<<4!A(P)<<20,INC)
INC=INC+16; Q=Q+1
P=P+1; ->106 IF P=REP
PSS(X'D2',16,RBASE,N+INC,RBASE,N+INC-16); ->105
106: P=JJ+2
->103 IF A(P-1)=1; ->102; ! P ON RESTOFARRAYLIST
201: 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
1: P=A(Q+1)+Q+1
KK=0; IF MODE=1 THEN ->4
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'
4: 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
->41 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); ->42
41: 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)
42: ->4 IF A(P)=1; ! FOR NEXT BOUND PAIR
->5 IF KK<=2
FAULT(37) IF KK>6
PACLOD(27,3,KK); ! L 1,=A(DV)--MVI 1(1),KK
5: QQ=Q+1; J=KK; PTYPE=PTYPEP; ->9 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; ->1 IF A(Q-1)=1
9: 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;
101: OPPREC(1)=2+OP(1)//6; QP=1; ->1
S(3): OP(1)=23; ->101; !INITIAL NOT
S(1):S(4):1: ! 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
->19 IF TYPE=3 AND ARR=0 AND INREG#0
->171 IF ARR=2 AND A(P+1)=1
->17 IF 1<=TYPE<=2 AND ARR=0 AND ROUT=0 AND A(P+1)=2=A(P+2)
10:
->14 UNLESS TYPE=1 OR(ROUT=1AND TYPE=6AND TSNAME(K)&7=1)
C=P; ->11 IF QP>1
P=P+1; SKIPAPP; ->11 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; ->80; ! ONE OPND EXPR
11: P=C
C=FINDPP; ->14 IF C=0
CNAME(2,C); NEST=C
->80 IF QP=1 AND A(P)=2;P=P+1; ! ONE OPND EXPR
12: ST(N0)=9; ST(N0+1)=C; N0=N0+3
REGISTER(C)=1
->50
14: 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
->80 IF QP=1 AND A(P)=2
16: ->15 IF TYPE=1
REAL=1; LONGREAL=1 IF PREC=3
->161 IF A(P)=2; ! EXPRESSION ENDED
C=PARKF(NEST,PREC)
FREG(NEST)=0
13: ST(N0)=10; P=P+1
ST(N0+1)=RBASE!(TYPE!PREC<<3!NAM<<6)<<8
ST(N0+2)=C; N0=N0+3; ->50
161: ST(N0)=8; ST(N0+1)=NEST+512+PREC<<11
FREG(NEST)=1
N0=N0+3; P=P+1; ->50
15: C=NEST
C=PARK(NEST)
REGISTER(NEST)=0 UNLESS NEST=C
->18 IF C>0; ! IN GENERAL REGISTER
C=!C!; PREC=0; ->13; ! IN CORE EQUIVALENT TO INTEGER
18: P=P+1; ->12
17: 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
->50 UNLESS UNASS=1 AND(PREC=0 OR PREC=3)
->50 IF NAM=1
PSS(X'D5',BYTES(PREC),I,K,GLA,128); ! CLC V,=X'80808080'
PRX(X'47',8,0,CODER,40); ->50;;! CHECK ASSIGNED
171: ->10 UNLESS A(P+2)=4 AND A(P+3)=2 AND A(P+4)=9
->10 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)
->10 UNLESS 0<C<4096; K=C; P=P+6; ->17
19: ->14 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)
->191 IF I=-1; UNPACK
->17 IF ARR=0 AND ROUT=0 AND 1<=TYPE<=2 AND A(P+1)=2C
=A(P+2); ! NO APP OR SECOND ENAME
191: P=P-3; ->14
REGVAR: ->14 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; ->50
SW(2): !CONSTANT
C=A(P); ST(N0+1)=P; ST(N0+2)=A(P+1)
->24 IF C&7=2
IF C=5 THEN START
FAULT(42); P=P+A(P+1)&X'FE'+1
C=9; FINISH
->22 UNLESS C>8; !GO UNLESS IMMEDIATE
ST(N0)=0
21: N0=N0+3; P=P+3;
->50
22: ST(N0)=1; P=P+1; ->21
24: REAL=1; P=P+2; ->22
SW(3):SW(4): ! SUB EXPRESSION
D=0; D=1 IF MODE=1 OR LASTOP=12; ! INTEGER EXPONENTS
CSEXP(0,D)
->32 UNLESS OPND=4
D=16*TYPE
D=48 IF TYPE=2 AND PREC=0
PRR(D,NEST,NEST); !DEAL WITH MOD SIGNS
32: LONGREAL=1 IF PREC=3
->80 IF QP=1 AND A(P)=2; !ONE OPD EXPRESSION
->16 ; !TO STORE RESULT
50: COMMENT DEAL WITH OPERATOR
->60 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)
51: ->52 IF C>OPPREC(QP-1); !OPERATOR MAY BE STORED
QP=QP-1
ST(N0)=OP(QP)
N0=N0+3; ->51; !UNLOAD STACK
52: OP(QP)=10+OPERATOR
OPPREC(QP)=C; ->1; !FOR NEXT OPERAND
60: 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
->70 IF REAL=1
COMMENT - CAN EVALUATE AS INTEGER
PRINT ORDERS
61: ->71 IF MODE>=2
72: 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; ->99
70: COMMENT EVALUATE AS REAL
FAULT(24) IF MODE=1; ! REAL IN INTEGER EXPRN
LONGREAL=1 IF MODE=3
EVALUATE=16*LONGREAL
PRINT ORDERS
->72
71: LONGREAL=1 IF MODE=3
REAL=1
EVALUATE=16*LONGREAL
->72
80: 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
->61 IF TYPE=1; ->71
99: END;->99
INTEGERFN FINDR
SHORTROUTINE
INTEGER I
->2 IF 0>=REG
I=REG; ->1 IF REGISTER(I)=0
2: CYCLE I=1,1,RBASE-1
->1 IF REGISTER(I)=0
REPEAT; FAULT(241)
1: 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
->1 IF FREG (I)=0
REPEAT; FAULT(242)
1: 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) ; ->98 ;! PICK UP VARIABLE
INREG: ->90 IF MODE=1
->99 IF BSI=REG
->LOCKED IF REGISTER(BSI)<0
->99 IF 0>REG
REGISTER(BSI)=0
SWOP: PRR(X'18',REG,BSI); ->98
LOCKED: REG=FINDR IF 0>REG; ->SWOP
90: ->91 IF BSI=0; !CURRENTLY CAN LEAVE NOTHING INFR0
->99 IF BSI=REG OR 0>REG
91:
REG=FINDFR IF 0>REG
PRR(X'38'-EVALUATE,REG,BSI)
FREG(BSI)=0; ->98
SHORT CONST: REG=FINDR IF 0>REG
DUMP(0,REG,DPI,0,0); !LOAD ADDRESS
98: BSI=REG; DPI=-2
99: 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));->99
RROP: PRR(OPCODE-64,R1,BSR2)
IF REAL=1 THEN FREG(BSR2)=0
IF REAL=0 AND REGISTER(BSR2)>0 THEN REGISTER(BSR2)=0
99: 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
-> SHORT CONST 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
1: LBASE=GLA; -> FINISH
INGLA: LDISP= 8*LDISP+40; ->1
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
->30 IF PT(I)=255 AND DP(I)=2
->1 IF DP(I)<0 AND REGISTER(BS(I))>=0
5: REPEAT
I=1; K=FINDPR
LOAD(I,K+1,0); ->11
1: ->14 IF BS(I)&1=1 AND I>0 AND REGISTER(BS(I)-1)=0
->12 IF BS(I)&1=0 AND REGISTER(BS(I)+1)=0
->5
12: K=BS(I); REGISTER(K+1)=1
PRR(X'18',K+1,K); ->13
14: REGISTER(BS(I)-1)=1
11: BS(I)=BS(I)-1
13: TEST(3-I); PLANT(X'5C',I,3-I);! MULTIPLY
->15 IF CHECKSP=0
PRX(X'8F',BS(I),0,0,32); ! SLDA ?,32
15: RESULT=257+BS(I)-CHECKSP
REGISTER(BS(I)+CHECKSP)=0
AFLAG=CHECKS
->99
30: K= 3-I; LOAD(K,-1,0)
PRR(X'1A',BS(K),BS(K))
AFLAG=1; RESULT=256+BS(K)
99: END
ROUTINE DIV(INTEGERNAME RESULT)
SHORTROUTINE
INTEGER I,K
->3 IF DP(1)<0
1: K=FIND PR
2: I=1; LOAD(I,K,0); ->10
3: ->4 IF BS(1)&1=0 AND REGISTER(BS(1)+1)=0
K=FINDPR; ->2
4: ->1 IF REGISTER(BS(1))<0; !A CLAIMED REGISTER
REGISTER(BS(1)+1)=1; K=BS(1)
10: PRX(X'8E',K,0,0,32); ! SRDA K,32
TEST(2); PLANT(X'5D',1,2); ! DIVIDE
->20 IF CHECKSP=0
->20 IF OPCODE=17; PRR(X'12',K,K); ! LTR
PRX(X'47',7,0,CODER,64); ! BC 7,64(CODE)
20: 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);->99
S(1): ! LONG INT CONST IN INT EXPRN
C=SORT CONST(ST(JJ+1),0,1)
D=256+GLA;->99
S(26): ! LONG ICONST IN EXPRN
D=512+GLA; D=D+3<<11 IF LONGREAL=1
C=SORT CONST(ST(JJ+1),LONGREAL,2);->99
S(2): S(27): !LOCAL VARIABLE
D=ST(JJ+1); C=ST(JJ+2); ->99
S(33): ! REAL IN FR
D=ST(JJ+1); C=-2; ->99
S(9): S(34): !(INTEGER) IN G.R.
D=256+ST(JJ+1); C=-2; ->99
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); ->99
S(11): ! NEGATE IN INTEGER EXPRN
-> 109 UNLESS PT(1)=255 AND DP(1)=1
AFLAG=0; D=256+GLA; C=16; ->99 ;! OPTIMISE (-1)
S(36): ! NEGATE IN REAL EXPRN
109: C=1; D=X'13'+REAL*(32-EVALUATE)
LOAD(C,-1,REAL)
AFLAG=1
PRR(D,BS(1),BS(1)); ! LCR,LCER,LCDR
111: D=(REAL+1+24*LONGREAL)<<8!BS(C)
C=-2; ->99
S(23): !INITIAL NOT
C=1; AFLAG=2; LOAD(C,-1,0)
PRX(X'57',BS(1),0,GLA,16); ->111
S(12): S(37): !ADDITION
AFLAG=1;D=X'5A'
125: C=0
126: LOAD(C,-1,REAL); TEST(3-C)
D=D+REAL*(X'20'-EVALUATE)
PLANT(D,C,3-C);->111
S(13): S(38): !SUBTRACTION
AFLAG=1; D=X'5B';C=1
->126 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);->111 ;!BCTR TO SUBTRACT 1 OR 2
S(14): D=X'57'; !EXCLUSIVE OR
141: AFLAG=2; ->125
S(15): D=X'56';->141; !OR
S(16): MULT(D); C=-2; ->99
S(17):S(18): DIV(D); C=-2; ->99
S(19): D=X'54';->141; !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; ->111
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
->221 IF REGISTER(0)#0
C=2; AFLAG=0
REGISTER(0)=1
PPJ(15); BS(2)=0; ->111; ! RESULT IN R0
221: 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; ->111
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; ! ¬ -> -
->S(OPCODE); ! ! TREAT OTHERS AS +
S(41): !REAL MULT
D=X'5C';C=0
410: AFLAG=0; -> 126
S(43): ! REAL DIVISION
D=X'5D';C=1;->410
S(47): !REAL EXPONENTIATION
C=1; LOAD(C,-1,1)
->222 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;->111
222: PRR(X'3C'-EVALUATE,BS(1),BS(1))
C=1; ->111
99: 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
99: END; ! OF ROUTINE CSEXP
INTEGERFN SORT CONST(INTEGER P,LONG,TYPE)
SHORTROUTINE
LONGREAL CVALUE
INTEGER I,K
->50 IF TYPE=2
FAULT(24) IF A(P)&7#1
IF A(P)=9 THEN I=A(P+1) ELSE FROMAR4(P+1,I)
40: K=N0
ST(K)=I; N0=N0+1
RESULT =K<<2
50: CVALUE=0
->60 UNLESS A(P)&7=1
IF A(P)=9 THEN I=A(P+1) ELSE FROMAR4(P+1,I)
CVALUE=I;->70
60: FROMAR8(P+1,CVALUE)
70: ->75 IF LONG#0
I=INTEGER(ADDR(CVALUE)); ->40
75: 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); ->71 IF JJ=20 AND REG>=0
P=PP; REG=!REG!
WKAREA=GET STR WSP
PSI(X'92',0,RBASE,WKAREA); ! CLEAR WORK AREA
->2 IF A(P)=4
1: FAULT(71)
4: P=PP; SKIP EXP; ->99
5: FAULT(72); ->4
2: ->10 IF A(P+1)=2
->1 UNLESS A(P+1)=1 ; !NAME
P=P+2; CNAME(2,1)
->1 UNLESS TYPE=5;->20
10: P=P+2;->14 IF A(P)=5
->1 UNLESS A(P)=9 AND A(P+1)<127
->11 IF A(P+1)=0
PRX(X'41',1,0,0,A(P+1))
P=P+2;->20
11: P=P+2; ->21; ! NULL STRING
14: COMMENT STRING CONSTANT PUT IN CODE CF (TEXTTEXT)
KK=(CA+6+A(P+1)-CODEBASE(LEVEL))&(-2)
QQ=0;->15 IF KK<4095
KK=KK+4;QQ=1
PRX(X'58',1,GLA,0,PAGENO(KK)<<2)
15: 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
20: PRX(X'41',2,RBASE,0,WKAREA)
PPJ(26)
21: ->90 IF A(P)=2; ! END OF EXPRN
->5 UNLESS A(P+1)=12
P=P+1;->2
71: DUMP(2,REG,K,I,0); ->99
90: P=P+1
PUSH(STR WSP(LEVEL),0,WKAREA)
PRX(X'41',REG,0,RBASE,WKAREA)
99: 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;->1 IF A(P)=4
1000: P=P1;SKIP EXP
FAULT(74);->99
1: ->1000 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
->10 IF A(P-1)=3 ; !SUB EXPRESSION
->1000 UNLESS A(P-1)=1
3: P2=P;SKIP NAME
->50 IF A(P)=2 ; !END
->1000 UNLESS A(P+1)=12 ; !ONLY - PERMITTED
->1000 UNLESS A(P+2)=3; P=P+3
10: 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
->15 IF P2<0
P3=P;P=P2
CNAME(1,4)
FAULT(71) UNLESS TYPE=5
P=P3
12: ->1000 UNLESS A(P)=1 AND A(P+1)=12 AND A(P+2)=1
P=P+3;->3
15: PSI(X'95',0,4,0)
FAIL(7);->12
50: ->1000 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
99: PUSH(LWSP(LEVEL),0,W)
RETURN
ROUTINE SKIP NAME
1: P=P+1;SKIP APP
P=P+1;RETURN IF A(P-1)=2
P=P+1;->1
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 ; -> 99
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; ->1
SW(-10): ! FIRST OPERAND SIMPLE STRING
CSTREXP(1); NEST=1; DUMP(2,2,DISP,0,BASE); ->161
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); ->20; !CR
REG1: Q=X'59'; ->RCOM
REG2: Q=X'49'
RCOM: PRX(Q,DISP,0,I,K); ->20; !C OR CH
REG3: PRR(X'18',1,DISP); ->37 ; !TO FLOAT ETC
SW(-5): !FIRST OPERAND LONG REAL
CSEXP(0,3); Q=X'69'; ! COMPILE LONG
51: PRX(Q,NEST,0,BASE,DISP); ->21
SW(-4): !FIRST OPERAND SHORT REAL
Q=X'79'; CSEXP(0,2)
40: ->51 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); ->20
SW(-3): !FIRST OPERAND ASHORT CONSTANY
CSEXP(0,0)
->30 IF VALUE=0
->36 IF TYPE=2
R=2
R=1 IF NEST=2
DUMP(0,R,VALUE,0,0); !LOAD ADDR FOR CONSTANT
29: PRR(X'19',R,NEST); ->20; !CR2,1
30: !COMPARISONS WITH ZERO
->35 IF TYPE=5
->32 IF AFLAG=1
->31 IF TYPE=2
->32 IF AFLAG=2 AND 7<=FCOMP(M)<=8
31: PRR((TYPE-1)*(2-PREC&1)*16+X'12',NEST,NEST); !LTR,LTER,LTDR
32: ->21 IF C=-3; ->20
35: PSI(X'95',0,NEST,0); ->20; ! NULL STRING LENGTH=0
36: DUMP(0,1,VALUE,0,0);
37: PPJ(43);
PRR((1-PREC&1)*16+X'29',0,NEST); ! CDR OR CER
->20
SW(-2): Q=X'49'; !OPERAND SHORT
24: CSEXP(0,0); ->25 IF TYPE=2
PRX(Q,NEST,0,BASE,DISP); ->21; ! C OR CH
25: R=2; R=6 IF Q=X'49'; ! HERE FOR REALS
26: DUMP(R,1,DISP,0,BASE); ->37
SW(-1): ! FIRST OPERAND A BYTE
T=P; R=TSEXP(Q); L=1
->18 IF R=11 AND A(P)=2
->19 IF R=1 AND A(P)=2
P=T;CSEXP(0,0); ->14 IF TYPE=2
R=2; R=1 IF NEST=2
DUMP(4,R,DISP,0,BASE); ->29
14: R=4; ->26
18: PSS(X'D5',L,BASE,DISP,I,K); ->20; ! CLC COMPARISONS
19: PSI(X'95',Q,BASE,DISP);->20; !CLI FOR BYTE/INTEGER
SW(0): !FIRST OPERAND INTEGER
T=P; R=TSEXP(Q); L=4
->RSTORE UNLESS R=10 AND A(P)=2
->18 IF 7<=FCOMP(M)<=8
RSTORE: P=T; Q=X'59'; ->24
SW(1): !FIRST OPERAND EXPRESSION
SW(2): !2ND HALT OF DOUBLE SEDED
T=P; PTYPEP=PTYPE; R=TSEXP(VALUE)
PTYPE=PTYPEP;UNPACK
->30 IF R=1 AND VALUE=0 AND(A(P)=2 OR C=2)
->160 IF TYPE=5
->150 IF TYPE=2
->120 IF R=0 OR 14<=R<=15 OR(A(P)=1 AND C=1)
->130 IF UNASS=1 OR R=100 OR R=11 OR R<=2
->131 IF R=50; ! REGISTER VARIABLE
Q=X'59'; Q=X'49' IF R=12
PRX(Q,NEST,0,I,K); ->20
130: !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; ->29
131: PRR(X'19',NEST,K); ->20
120: !1ST OPND INTEGER EXPRN IN NEST-SECOND OPND UNKNOWN
Q=PARK(NEST); P=T
CSEXP(0,0); ->122 IF TYPE=2
UNPARK(X'59',NEST,Q); ->21
122: UNPARK(X'58',1,Q); ->37; ! TO FLOAT FIRST OPERAND
150: P=T; Q=PARKF(NEST,PREC); !
->155 IF PREC=0
CSEXP(0,3); !1ST OPND LONG REAL EXPR
PUSH(LWSP(LEVEL),0,Q)
BASE=RBASE
DISP=Q; Q=X'69'; ->51
155: CSEXP(0,2); !1ST OPND SHORT REAL EXPRN
PUSH(WSP(LEVEL),0,Q)
BASE=RBASE;DISP=Q
Q=X'79'; ->40
160: 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)
161: ->162 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); ->20; ! EX_3,COMPARISON
162: PPJ(35); ! GO TO SUBROUTINE FOR COMPARISON
20: MASK=FCOMP(M); ->1; ! MASK FOR NORMAL COMPARISON
21: MASK=BCOMP(M); ! BACKWARDS COMPARISON
1: END
ROUTINE CCC
SHORTROUTINE
INTEGER LINE,FLAB
CSC(FLAB)
C=A(P) ; P=P+1
CLAUSES=CLAUSES+1
->10 IF T=0 OR(CLAUSES>1 AND C=2)
-> 2 IF FAILPT#0
FAILPT=1 ; LINE=1 ; ->3
2: LINE=0
3:
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
-> 10 IF LINE=0
MASK=MASK!!15 IF JNPORFP=NEARLAB
10: 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: -> 1 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); ->9
REDUND:CCOND(IU,NEARLAB,FARLAB); ->9
REDUND2: CCOND(IU,NEARLAB,FARLAB)
MASK=MASK!!15 IF JNPORFP=NEARLAB ;->9
LAST: CCOND(IU,NEAR,FARLAB)
NEARLAB=0; ->9
1: COMMENT CLASSIFY SIMPLE CONDITION AND ACT ACCORDINGLY
P=P+2; S=P; SKIP EXP
->21 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); ->8
REGVAR: DISP=K; CCOMP(-9); ->8
STR: P=S; CSTREXP(1); NEST=1; CCOMP(1); ->8
CONST: VALUE=R; CCOMP(-3); ->8
21: P=S+2; ->22 UNLESS A(S)=4 AND A(S+1)=1
CNAME(2,1)
->23 IF A(P)=2 AND TYPE=5
22: P=S; SKIP EXP
28: P=P+1; SKIP EXP
FAULT(73); ->8
23: 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)
->28 UNLESS A(P)=2 ; ! NO DOUBLE SIDED RESOLUTION
P=P+1;
MASK=15; ->10
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)
8: P=P+1
->10 IF A(P-1)=2; ! GO UNLESS DOUBLESIDED
FLAB=NEAR UNLESS NEAR=NEARLAB
->ORCOND IF T=2
R=JNPORFP; ->7
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
7:
PLOCAL JUMP(MASK!!15,R)
CCOMP(2)
10: MASK=MASK!!15 IF T=1 OR(T=0 AND IU=0)
9: END
99: END ; !OF CCOND
ROUTINE FILL LOCAL JUMPS
SHORTROUTINE
INTEGER T,C,J
1: POP(LOCAL JUMP,T,C)
->98 IF T=-1
J=FIND(C,LOCAL LABEL)
FAULT(233) IF J=-1
J=J-LOCAL ADDR
PLUG(T+2,J); ->1
98: CLEAR LIST(LOCAL LABEL)
END
ROUTINE P LOCAL JUMP(INTEGER MASK,LABEL)
SHORTROUTINE
RETURN IF MASK=0
CHNGE13=1 UNLESS SAVE13=R13
->1 IF LABEL>21000
PJ(MASK,LABEL); ->99
1: ->2 UNLESS LOCAL BASE=0
LOCAL BASE=10; LOCAL ADDR=CODEBASE(LEVEL)
->2 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
2: PUSH(LOCAL JUMP,CA,LABEL)
PRX(X'47',MASK,LOCAL BASE,0,0)
99: 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
->1010 IF V&15=15
->1001 IF V>>4#JJ; V=V&15
->1002 IF V=0 AND Z#0; ! ROUTINE CALL IN EXPRESSION
->1003 IF V=2 AND Z#2; ! FN CALLED INCORRECTLY
->1005 IF Z=0 AND V#0
1010: ->SW(KK)
1001: FAULT(19); PRINTNAME(FNAME)
1000: P=PP; SKIP APP; P=P-1; ->99
1002: FAULT(23); ->1000
1003: FAULT(29); ->1000
1004: FAULT(22); ->1000
1005: FAULT(17); ->1000
1: PPJ(PL); ->99
SW(4): CIOCP(1); ->99; ! SKIP SYMBOL
SW(2): V=10; ! NEWLINE
PRX(X'41',1,0,0,V)
23: CIOCP(3); ->99
21: PRX(X'41',1,0,0,V); ->1
SW(3): V=32; ->21; ! SPACE
SW(5): V=0; ! RUNOUT
51: CSEXP(2,1); ->21
SW(6): V=10; ->51; ! NEWLINES(N)
SW(7): V=32; ->51; ! SPACES(N)
SW(0):SW(1): ! SELECT INPUT AND OUTPUT
CSEXP(1,1); CIOCP(KK+8)
->99
SW(9): ! PRINTSYMBOL
CSEXP(1,1); ->23
SW(8): CIOCP(2); ! NEXT SYMBOL
81: UNLESS REG=1 THEN PRR(X'18',REG,1)
82: PTYPE=10001;UNPACK; ->99
SW(10): CIOCP(1); ! READ SYMBOL
106: ->1004 UNLESS A(P)=4 AND A(P+1)=1
P=P+2; COPYTAG(A(P)); UNPACK
->104 UNLESS TYPE=1 AND ARR=0 AND ROUT=0
CNAME(1,1)
102: ->1004 UNLESS A(P)=2; P=P+1; ->99
104: PLANT(X'1841'); REGISTER(4)=1
CNAME(1,4); REGISTER(4)=0
->1004 UNLESS TYPE=1; ->102
SW(11): ! READ
B(0)=1; B(1)=1000
110: JJ=10000; ->1004 IF 0#Z#13; ->302
SW(12): ! WRITE
CSEXP(1,1); P=P+1
JJ=P; V=TSEXP(KK)
->121 UNLESS V=0
V=PARK(1); CSEXP(2,1)
UNPARK(X'58',1,V)
120: PPJ(PL); ->99
121: P=JJ; REGISTER(1)=1
CSEXP(2,1); REGISTER(1)=0; ->120
SW(13): ! NEWPAGE
PRX(X'41',1,0,0,12); ! LA 0,12
CIOCP(5); ->99
SW(14): ->1004 UNLESS A(P)=4 AND A(P+1)=1; ! ADDR
P=P+2
CNAME(3,REG); ->1004 UNLESS A(P)=2
P=P+1; ->82
SW(16): ! INT
SW(17): ! INTPT
CSEXP(0,3)
PRR(X'28',0,NEST)UNLESS NEST=0
PPJ(PL); ->81
SW(18): CSEXP(6,3) ; ! FRACPT
PCLOD(32); !INSERT FRACPT SR IN LINE
PRR(X'28',REG,2) UNLESS REG=2
PTYPE=10032; UNPACK; ->99
SW(19): ! PRINT
B(0)=3;B(3)=1
191: B(1)=32;B(2)=1;->110
SW(20): ! PRINTFL
QPREAL=N0<<2+4
B(0)=2;->191
SW(39): JJ=11032; ->210; ! LONGREAL
SW(21): JJ=11002; ! REAL
210: CSEXP(0,1); P=P+1
->212 UNLESS NEST=0
PLANT(X'1810'); NEST=1
212: PTYPE=JJ; UNPACK; ->99
SW(22): JJ=11001; ->210; ! INTEGER
SW(23): CSEXP(REG,3); ! MOD
PRR(X'20',REG,REG); ->99; ! LPDR
SW(25):SW(26):SW(27): ! SQRT,LOG,SIN
SW(28):SW(29):SW (30): ! COS,TAN,EXP
B(0)=1
301: B(1)=32;JJ=10032;
->1004 IF 2#Z#13
302: REDEFINE EP(JJ,B)
CNAME(Z,REG);P=P-2;->99
SW(31): ! MAP RECORD
CSEXP(REG,1); FAULT(84) UNLESS Z=15
PTYPE=3; UNPACK
->99
SW(32): JJ=11011; ->210; ! BYTEINTEGER
SW(33): JJ=11021; ->210; ! SHORT INTEGER
SW(34):SW(35): !RADIUS & ARCTAN
B(0)=2; B(2)=32; ->301
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'
->99
SW(37): CSTREXP(1); CIOCP(7); ->99; ! PRINT STRING
SW(38): PRX(X'41',REG,0,0,10); ->82
SW(40): ! PRINTCH
CSEXP(1,1); CIOCP(5); ->99
SW(41): ! READ CH
CIOCP(4); ->106
SW(42): JJ=11005; ->210; ! STRING
99: 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; ->1 UNLESS JJ=0
FROM1(CLINK,JJ)
REPLACE1(CLINK,JJ!Q); JJ=Q
1: ->4 IF JJ=Q#0
FAULT(19); PRINTNAME(FNAME)
P=P+1; SKIP APP; ->99
4:
IF ARRP=2 THEN FROM LIST(K,BASIC DISP,DP)
->12 UNLESS CHECKSP=0 AND JJ=1 AND Z#3
->12 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)
->12 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
->12 UNLESS JJJ=100
DUMP(2+2*PREC,1,K,0,I); P=P+1; ->9
REGVAR: JJJ=K; P=P+1; ->8; !CAN ONLY OPTIMISE BYTES
RDISP: ->REGVAR IF PRECP=1
PRR(X'18',1,K); P=P+1; ->9
12: P=PP+2; DIS=0
->21 UNLESS JJ=1
CSEXP(1,1);P=P+1
->10 IF CHECKSP=1
9: JJJ=1
8: IF BASEREG#LINK THEN ->5
->VECTOR IF ARRP=2
RP13=R13; R13=BS<<12!DP
PRX(X'58',LINK,0,BS,DP) UNLESS R13=RP13; ! ADDR A0
->5
VECTOR: DIS=DIS+BASIC DISP; BASEREG=BS
5: PTYPE=PTYPEP; UNPACK
->6 IF JJJ=0
->STR IF TYPE=5
->S(PREC) UNLESS TYPE=3; ! RECORDS
3: PRX(X'4C',1,0,BSRF,DPRF); ->6
STR: PRX(X'58',2,0,BS,DP+8); ! ADDR OF DV
BSRF=2; DPRF=2; ->3
S(3): !LONG REAL
S(0): ! %INTEGER
PCONST(X'89100002'! PREC); ->6; ! SLL 1,2 OR 3
S(2): ! %SHORT
PLANT(X'1A11'); ! AR 1,1
S(1):6: DISP=DIS; INDEX=JJJ; BASE=BASEREG; ->99
CONST: JJJ=0; P=P+1; ! 1 D WITH A CONSTANT SUFFIX
->8
10: ! 1 DIMENSION PLUS CHECKS
DUMP(0,3,DP,0,BS); ! ADDR ARRAYHEAD
PPJ(22+JJ); JJJ=1; ! PERM CHECKS BOUNDS AND SHIFTS
11: PTYPE=PTYPEP; UNPACK
->6
21: ! TWO DIMENSIONS
->31 UNLESS JJ=2 AND CHECKSP=0
CSEXP(2,1);JJJ=2;P=P+1
KK=P;Q=TSEXP(PP);P=KK
->22 UNLESS Q=0
JJJ=PARK(2)
22: 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
->9
31: !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
->11
99: 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
->2 IF A(P)=1
->1 IF Z>=14; FAULT(64)
P=P-2
PTYPE=1; UNPACK; ->99
1: BASE=BS; DISP=DP
DISP=-1 IF MODE#0
INDEX=0; ->99
2: P=P+1; Q=DISPLACEMENT(FNAME); UNPACK
! K POINTS TO CELL HOLD ING DETAILS FOR THOS CELL
->98 IF Q=-1; ->50 IF TYPE =3
->20 IF ARR=1
->30 IF TYPE=5
->11 IF MODE#0
RP13=R13; R13=BS<<12!DP
PRX(X'58',LINK,0,BS,DP) UNLESS R13=RP13
BASE=LINK
7: INDEX=0; DISP=Q
IF ROUT=1 THEN FROM1(Q,DISP); ->99
11: BASE=BS; ->7
20: ! DEAL WITH ARRAY IN RECORD
FROM LIST(FNAME,BSRF,QQQ)
BSRF=BSRF>>4&15
FROM1(QQQ,DPRF)
->21 IF Z<10 OR A(P+1)=1; K=DPRF+Q
I=BSRF; ! SS5V1
DUMP(2,1,DP,0,BS) IF MODE=0; ->99; ! R1 NOW POINTS TO REORD
21: ->22 UNLESS MODE=0 AND BS<4; ! WILL POINTER BE DESTROTED?
DUMP(2,1,DP,0,BS); MODE=1; BS=1; ! YES-- SO SAVE IT
22: 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
->99
30: 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; ->99
50: ! 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); ->99
98: P=P+1; SKIP APP; P=P-2
99: 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)
->50 IF ARR=0
I=BS; K=DP;
->99 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)
->3 UNLESS MODE=0 AND BS<4; ! WILL POINTER BE DESTROTED?
DUMP(2,1,DP,0,BS); MODE=1; BS=1; ! YES-- SO SAVE IT
3:
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); ->99
50: P=P+1; ->51 IF A(P)=2
FAULT(19); SKIP APP
51: P=P+1
IF INREG=0 OR Z=14 THEN CENAME(Z,0,BS,DP) ELSE C
CENAME(Z,2,INREG,0)
99: END
ROUTINE CNAME(INTEGER Z,REG)
INTEGER JJ,JJJ,KK,RR,PTYPEP,LEVELP
INTEGER DISPP
COMMENT Z=0-RTCALL,Z=1STORE(=), Z=2 FETCH,Z=3 FETCH ADDR,Z=4C
! STORE N<-), Z=6 STORE PTR, Z=12 FETCH ARRAYHEAD, Z=11 STORE %C
! ARRAY HEAD
SWITCH S,FUNNY(10:15)
SWITCH SW(0:8),MOD(0:31)
FNAME=A(P); COPYTAG(FNAME)
->3 UNLESS I=-1; FAULT(16)
I=LEVEL; J=0; K=FNAME
PTYPE=7;STORE TAG(K,N)
K=N; N=N+4; UNPACK
3: JJ=J; JJ=0 IF JJ=15
LEVELP=I; DISPP=K
->502 IF TYPE=7
-> 500 IF Z=0 AND (ROUT#1 OR 0#TYPE#6)
->FUNNY(Z) IF Z>=10
->501 IF ROUT=1
->SW(TYPE)
500: ->SW(3) IF TYPE=3
FAULT(17) UNLESS TYPE=7; ->502
SW(6): ->661 UNLESS Z=3 AND ARR=1
K=K<<2; ARR=0; I=10; ->600
SW(4): !RECORD FORMAT NAME
661: FAULT(20)
SW(7):502: P=P+1; ! NAME NOT SET
PTYPE=1; UNPACK; ->6 IF A(P)=2; ->102
FUNNY(11): ->1011 IF TYPE=3
FAULT(17) UNLESS ARR=1 AND NAM=1 AND K>>12=0
PRX(X'90',0,3,I,K); ->91
1011: 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); ->91
FUNNY(12): ->SW(3) IF TYPE=3
->1202 IF ARR=2; ! VECTORS
FAULT(17) UNLESS ARR=1
1201: PRX(X'98',0,3,I,K&4095); ->91
1202: FROM2(K,K); ->1201
S(12): ->1201 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); ->91
FUNNY(13): ! SET BASE & DISP FOR ROUTINE ADDR
->SW(3) IF TYPE=3
->1302 IF PTYPE=10006
->1301 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
1300: ->500 UNLESS ROUT=1
->91
1301: BASE=I; FROM1(K,DISP)
INDEX=0; ->91
1302: CSNAME(Z,REG); ->6
S(13): FROM2(K,K); ->1300
FUNNY(15): ! FETCH RECORD NAME
->1501 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; ->661
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
1401: DUMP(Z-13,REG,DISP,INDEX,BASE)
P=P+1; ->9005
S(15): ->661 UNLESS TYPE=3
->1401 IF DISP>=0
DUMP(0,REG,0,INDEX,BASE); P=P+1; ->9005
1501: CSNAME(Z,REG)
FAULT(22) UNLESS A(P)=2 AND A(P+1)=2; P=P+2; ->9005
SW(3): ! RECORD
FROM2(K,JJJ)
CRNAME(Z,0,TAGS(A(P)),I,JJJ)
->S(Z) IF Z>=10
->5020 IF TYPE=5
->601 UNLESS Z=0
->500 UNLESS ROUT=1 AND NAM=1
LEVELP=PARK(BASE); RR=DISP
PTYPEP=PTYPE; FROM2(K,JJ)
FROM2(JJ,K); ->22
SW(5): !STRINGS
BASE=I; INDEX=0; DISP=K
JJJ=2; ->5000 UNLESS ARR=1
CANAME(Z,I,K,TAGS(FNAME),0,0)
4998: NAM=NAM>>1;JJJ=0
->5000 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); ->9
COMMENT L 2,LMAX. BCTR 2,0. SLL 2,24. OR REG,2
5000: ->605 IF 2<=Z<=3
PRR(X'18',4,REG) UNLESS REG=4
DUMP(JJJ,1,DISP,INDEX,BASE)
->5001 IF ARR=0
PRX(X'58',2,0,LEVELP,DISPP+8) IF Z=4 OR CHECKS#0
I=2; K=3
5001: STORE STRING(Z,4,1,I,K);->9
5020: ! STRINGS IN RE CORDS
->5025 IF ARR=1
->9 IF 2<=Z<=3
PRR(X'18',4,REG) UNLESS REG=4; ->5001
5025: ! STRING ARRAYS IN RECORDS
LEVELP=I; DISPP=K; ->4998
SW(8): !REGISTER VARIABLE
FAULT(29) UNLESS 1<=Z<=2 OR Z=4
->9 IF K=REG
IF Z=2 THEN PRR(X'18',REG,K) ELSE PRR(X'18',K,REG)
->9
SW(0): UNLESS Z=3 OR Z>10 THEN START
FAULT(12); TYPE=1; PTYPE=PTYPE+1; FINISH
SW(2): !REAL
SW(1): ->600 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; ->601
501: ->503 UNLESS Z#0 AND PTYPE=10000; ! ROUTINES
FAULT(23); PRINTNAME(A(P)); ->503
503: PTYPEP=PTYPE
->20 UNLESS PTYPE=10006
CSNAME(Z,REG)
->202 IF ROUT=1 AND NAM>=1 AND Z#0; ->6; ! MAPS
20: KK=K; FROM LIST(KK,RR,K)
22: ->21 UNLESS K=1000; FAULT(21); ->502
21: CRCALL(KK)
PTYPE=PTYPEP; UNPACK
->37 IF NAM&1=1
->36 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
371: MONE=1; R13=0
P=P+1
->1 IF PTYPE=10000 OR PTYPE=11000; ! ROUTINE OR RTNAME
->201 IF NAM>1; !MAPS
FAULT(29) UNLESS Z=2; !FN OUT OF CONTEXT
->43 IF TYPE=2
44: PRR(X'18',REG,1) UNLESS REG=1; ->1
43: PRR(X'28',REG,2) UNLESS REG=2; ->1
36: ! CALL OF EXTERNAL ROUTINE
PACLOD(55,4,RA(RR)+4); !STM 4,14 - LM 12,14-BALR 13,14
->371
37: ! 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
->371
201: COMMENT - REAL MAPS AND INTEGER MAPS
NEST=1
202:
->205 IF TYPE=5; ! STRING MAPS
->203 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
->1
203: PRR(X'18',REG,NEST) UNLESS REG=NEST; ->1
205: COMMENT STRING MAPS
IF NEST#1 THEN PRR(X'18',1,NEST)
->206 IF 2<=Z<=3
STORE STRING(Z,REG,1,0,255); ->1
206: PCLOD(69);->44; ! LA 0,255--SLL 0,24 OR 1,0
!ARR=0
600: BASE=I; INDEX=0; DISP=K
601: ->602 IF Z=6
->MOD(NAM<<4!PREC<<2!Z&3)
602: FAULT(17) IF NAM=0
R13=0 IF R13=BASE<<12!DISP
JJJ=1; ->605
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
605: 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
->9
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;->605
MOD(15): !LONG REAL FETCH ADDR
MOD(3): ! INTEGER FETCH ADDR
MOD(7): ! BYTE FETCH ADDR
MOD(11): ! SHORT FETCH ADDR
JJJ=0;->605
MOD(6): ! BYTE FETCH
MOD(10): ! SHORT FETCH
JJJ=PREC<<1+2;->605
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
9: ->1 UNLESS ARR=0
91: P=P+1
->6 IF A(P)=2
FAULT (19)
102: SKIP APP; ->1
6: P=P+1
1: P=P+1; ->9005 IF A(P-1)=2
FAULT(69); ->91
9005: 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; ->2 IF K=KK
FAULT(19); PRINTNAME(FNAME)
SKIP APP; P=P-1; ->99
2: ->99 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
7: MLINK(CLINK)
FROM1(CLINK,PTYPE)
P=P+1; UNPACK
II=TYPE; III=PREC; QQQ=P
PP=(NAM<<1!ARR)&3
->10 UNLESS(PP=0 AND ROUT=0) OR(A(P)=4 AND A(P+1)=1)
->12 IF ROUT=1; ->FPD(PP)
10: P=QQQ; SKIP EXP;
11: FAULT (22); ->53
COMMENT ROUTINE TYPE PARAMETERS
12: II=PTYPE; P=P+2; CNAME(13,0)
->10 IF 1000#!PTYPE-II!#0
->10 IF A(P)=1; P=P+1
->13 IF J=14; ! EXTERNAL
->15 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); ->69
13: PRX(X'98',0,2,BASE,DISP); ! CODE,GLA,EP
PRR(X'18',3,9); ->69; ! ANYTHING D W ALIGNED AS ENVRMNT
15: PRX(X'98',0,3,BASE,DISP); ->69
FPD(0): ->41 IF PREC=3
->45 IF TYPE=5
-> 39 UNLESS UNASS=0 AND TYPE=1
PP=P; TYPEP=PREC
II=TSEXP(III)
->42 IF II=10 AND TYPEP=0
->43 IF II=1 AND TYPEP=1
P=PP; TYPE=1
39: 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;->50
42: MOVEBACK
PSS(X'D2',4,WSPR,QQ-MOVED,I,K)
TOMOVE=4; ->50
43: MOVEBACK
PSI(X'92',III,WSPR,QQ-MOVED+3)
TOMOVE=4; ->50
41: II=0; II=4 UNLESS QQ&7=0; !LONG REAL
CSEXP(0,3)
DUMP(15,NEST,QQ-MOVED+II,0,WSPR)
TOMOVE=8+II;->50
45: 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); ->50
FPD(2): ! NAME TYPES INCLUDES RECORDNAME
P=P+2
IF TYPE=3 THEN CNAME(15,1) ELSE CNAME(3,1)
->10 IF A(P)=1; P=P+1; ! CHECK NO RESTOF EXPRN
->11 UNLESS (II=TYPE AND III=PREC) OR II=0
MOVE BACK
DUMP(1,1,QQ-MOVED,0,WSPR)
TOMOVE=4;->50 UNLESS II=0
FAULT(12) UNLESS 2>=TYPE
PSI(X'92',PREC<<3!TYPE,WSPR,QQ-MOVED); ->50;!FLAG FOR %NAME
FPD(1):FPD(3): ! ARRAYNAME (+ARRAY VALUE)
P=P+2; CNAME(12,0); ->10 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)
69: MOVE BACK
PRX(X'90',0,3,WSPR,QQ-MOVED); ! STM
TOMOVE=16
50: QQ=QQ+TOMOVE
->53 IF RF=1 OR Q=KK-1
II=(QQ+7)&(-8)-MOVED
MOVER(WSPR,II); MOVED=MOVED+II
53: Q=Q+1; ->7 UNLESS Q=KK
MOVER(WSPR,-MOVED) UNLESS RF=1
55: POP(LIST,Q,QQ); ->99 IF Q=-1
PRX(X'50',WSPR,0,WSPR,Q); ->55;! POINTER TO SAVE AREA RTTYPES
ROUTINE MOVEBACK
->1 IF QQ>=MOVED
MOVER(WSPR,QQ-MOVED); MOVED=QQ
1: END
99: 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
->10 IF Z=4
->2 IF CHECKS=0
->1 IF BML>0
PSI(X'95',DML,FROM,0); ->3; ! CLI FOR FIXED LENGTH
1:
PSS(X'D5',1,FROM,0,BML,DML) ;!CLC_ACTUALL(1),MAX
3:
PRX(X'47',2,0,CODER,88) ;!BH_FAIL
2: PRX(X'43',2,0,FROM,0) ;!IC_2,ACTUALL
PRX(X'44',2,0,GLA,STRINST) ;!EX_2,MOVE
->99
10: PRX(X'43',2,0,BML,DML) ;!IC_2,MAXL
PPJ(39)
99: 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)
->99
SW(2): PPJ(A(P+1)); ->99
SW(4): ! *PUT_CONST
->401 IF A(P+1)#9
PLANT(A(P+2)); P=P+3; ->99
401: FAULT(32) UNLESS A(P+1)=1
PLANT(A(P+3)); ! LEAST SIGNIFICANT 16 BITS ONLY
P=P+4; ->99
SW(3): OPCODE=A(P+2);P=P+3; ->S(A(P-2))
S(1): ->87 IF OPCODE=0;
PRR(OPCODE,A(P),A(P+1)); P=P+2; ->99; ! RR
S(2): REG=A(P); P=P+1;DXB; !RX
11: PRX(OPCODE,REG,X,I,K);->99
S(3): REG=A(P); X=A(P+1);P=P+2; !RS
DB; ->11
S(4): DB;Z=0;->41 IF A(P)=2;Z=A(P+2); !SI
FAULT(32) UNLESS A(P+1)=9 AND Z<256
P=P+2
41: PSI(OPCODE,Z,I,K);P=P+1; ->99
S(5): REG=A(P);P=P+1; DB; !SHIFT INSTR.
X=0; ->11
S(6): DLB;KK=K;Z=X;REG=I;DB; !SS FORMAT
Z=1 IF Z=0
61: PSS(OPCODE,Z,REG,KK,I,K); ->99
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; ->61
S(8): REG=A(P); P=P+1; !FUNNIES
-> 85 IF OPCODE=X'80' ; ! IDL
->83 IF OPCODE=10; ! SVC
PRR(OPCODE,REG,0);->99
83: PLANT(X'A00'!REG); ->99
85: PSI(OPCODE,REG,0,0); ->99
87: CNOP(A(P),A(P+1)); ->99
ROUTINE DB
->2 IF A(P)=1
K=A(P+1); I=0; P=P+3
->99 IF A(P-1)=2
I=A(P);P=P+1;->99
2: CUCS
99: END
ROUTINE DXB
SWITCH SW(1:3)
->2 IF A(P)=2
CUCS;X=0;P=P+1
->99 IF A(P-1)=2
X=A(P);P=P+1; ->99
2: 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
99: END
ROUTINE DLB
->2 IF A(P)=2
K=A(P+1); X=A(P+2); I=A(P+3); P=P+4; ->99
2: CUCS; X=A(P); P=P+1
99: END
ROUTINE CUCS
SWITCH UTYPE(0:8)
P=P+1
->10 IF A(P)=2
FNAME=A(P+1); COPYTAG(FNAME)
P=P+3; ->1 UNLESS I=-1
FAULT(16); J=0; I=LEVEL; PTYPE=7; UNPACK
STORE TAG(FNAME,N);K=N;N=N+4
1: FAULT(33) IF ROUT=1; ->UTYPE(TYPE)
UTYPE(3): FROM2(K,K); ->9; ! RECORDS
UTYPE(4): FROM1(K,K); ->9; ! FORMATS
UTYPE(8):FAULT(33); ->9
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):
->9 UNLESS ARR=2; ! VECTOR
FROM2(K,K); ! EXTRACT DISPLACEMENT
9: ->99 IF A(P-1)=2
K=K+A(P); P=P+1; ->99
10: K=A(P+2)+(A(P+1)-1)<<14
J=FIND(K,LABEL(LEVEL))
->25 IF J=-1
K=J-CODEBASE(LEVEL); I=10
FAULT(99) IF K>4095; P=P+3; ->99
25: PUSH(JUMP(LEVEL),CA!LABSET,K)
K=0; I=0; P=P+3
99: END
99: END
ROUTINE TEST ASS(INTEGER REG)
SHORTROUTINE
INTEGER J
RETURN UNLESS 1<=TYPE<=2
->5 IF TYPE=1
J=X'79'; J=X'69' IF PREC=3
3: PRX(J,REG,0,GLA,128)
PRX(X'47',8,0,CODER,40); ->99
5: ->99 UNLESS PREC=0
J=X'59'; ->3
99: 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)); ->1 IF HASH=0
ST(I+5)=HASH<<16!'#'<<8
K=K+2; N=N+2
NP=6 IF NP>6
1: 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)
INTEGER I,J
SHORTINTEGER OP
COMMENT UNSCRAMBLES RECORD FORMAT TAGS LIST & SIDECHAIN
POP (OPHEAD,I,J); ! LST ITEM IS DESPMENT
1: POP (OPHEAD,I,J)
->9 IF I=-1
OP=J;PTYPE=I>>4&X'FFFF';UNPACK
IF ROUT=1 OR TYPE=3 THEN CLEAR LIST(OP)
->1
9: 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
->99 UNLESS TYPE=5
->2 UNLESS A(P)=2
ACC=0; P=P+1; ->99
1: P=P+1;FAULT(70);->99
2: P=P+1;ACC=A(P)+1
->1 UNLESS 2<=ACC<=256
P=P+1
99: 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
3: P=P+1; ->SW(A(P)); ! SWITCH ON OPERAND
SW(1): P=P+2; ! OPERAND = NAME
J=ADDR(ASLIST(TAGS(A(P-1))))
->5 IF SHORT INTEGER(J)<RT; FFLAG=1
5: SKIP APP; P=P+1
->1 IF A(P-1)=2; P=P+1; ->5
SW(2): ! CONST
P=P+1; J=A(P)
IF J=9 THEN START; P=P+2; ->1; FINISH
IF J=1 THEN START; P=P+3; ->1; FINISH
IF J=2 THEN START; P=P+5; ->1; FINISH
P=P+A(P+1)&X'FE'+3; ->1
SW(3):SW(4): P=P+1; SKIP EXP
1: P=P+1; ->3 IF A(P-1)=1
END
ROUTINE SKIP APP; ! SKIPS ACTUAL PARAMETER PART
5: P=P+1; ->1 IF A(P-1)=2; SKIP EXP; ->5
1: 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
->1 IF TYPE=2
->5 IF TYPE=5
PRR(X'18',1,REG) UNLESS REG=1; ! LR 1,REG
PCONST(X'4120000B'); ! LA 2,11
PPJ(4); ->9; ! TO WRITE
1: 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'
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); ->9
5: PCONST(X'4110000A'); PPJ(3); ! NEWLINE
PRR(X'18',1,REG); PPJ(5)
9: 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
->9 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
->40 IF TYPE=8; !REGISTER VARIABLE
->30 IF TYPE=3 AND ARR=0 AND INREG#0
->50 IF ARR=2 AND TYPE=1
->9 UNLESS A(P+3)=2 =A(P+4); ! NO APP OR ENAME
->9 UNLESS ROUT=0 AND ARR=0
->20 IF TYPE=5
->9 UNLESS NAM=0
->14 IF TYPE=2
->9 UNLESS TYPE=1
->11 IF A(P+5)=2; ! NO RST OF EXPS
->9 UNLESS A(P+6)=2=A(P+7)
->9 UNLESS A(P+8)=9 AND A(P+10)=2
CODE=A(P+9); P=P+11; RESULT=100
11: P=P+6; RESULT=10+PREC
14: ->9 UNLESS A(P+5)=2; !NO NOT OF EXPRN
P=P+6; RESULT=14+PREC&1
20: ->9 UNLESS A(P+5)=2
P=P+6; RESULT=20
30: ->9 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
->9 IF I=-1 OR ARR#0 OR ROUT#0
->9 UNLESS 1<=TYPE<=2 AND A(P+1)=2=A(P+2)
->9 UNLESS A(P+3)=2; ! NO REST OF EXPRN
P=P-2; ->11 IF TYPE=1; ->14
40: ->41 IF A(P+5)=2; !NO REST OF EXP
->9 UNLESS A(P+6)=2=A(P+7)
->9 UNLESS A(P+8)=9 AND A(P+10)=2
CODE=A(P+9);P=P+11; RESULT=101
41: P=P+6; RESULT=50
50: ->9 UNLESS A(P+3)=1 AND A(P+4)=4 AND A(P+5)=2
->9 UNLESS A(P+6)=9 AND A(P+7)<256 AND A(P+8)=2
->9 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)
->9 UNLESS 0<=K<4096
P=P+12; RESULT=10+PREC
SW(2): TYPE=A(P+2)&7
->9 UNLESS A(P+2)=9
->21 IF A(P+4)=1; ! REST OF EXPR
CODE=A(P+3); P=P+5
RESULT=1 IF 256>CODE
RESULT=2
21: IF A(P+5)=12 THEN TYPE=5; ! STRING EXPRESSION
SW(3):SW(4):9:RESULT=0
END
ROUTINE MOVE R(INTEGER R,N)
SHORTROUTINE
->99 IF N=0; ->2 IF 0>N
DUMP(0,R,N,0,R); ->99
2: N=-N; ->3 UNLESS N=4 OR N=8
PRX(X'5A',R,0,GLA,76+N); ->99
3: PCONST(X'41000000'!N); ! LA 0,N
PRR(X'1B',R,0); ! SR R,0
99: END
INTEGERFN FIND PP
SHORTROUTINE
INTEGER I
CYCLE I=9-RLEVEL,-1,4
->1 IF REGISTER(I)=0
REPEAT
RESULT=0
1: REGISTER(I)=1
RESULT=I
END
ROUTINE UNPARK(INTEGER OPCODE,REG,Q)
SHORTROUTINE
->1 IF 0>Q
PRR(OPCODE-X'40',REG,Q); REGISTER(Q)=0; ->9
1: Q=!Q!; PRX(OPCODE,REG,0,RBASE,Q)
PUSH(WSP(LEVEL),0,Q);
9: END
INTEGERFN PARK(INTEGER REG)
SHORTROUTINE
INTEGER I,J,P
P=CLAIMABLE REG
->1 IF P=0
REGISTER(P)=1
->2 IF P=REG
PRR(X'18',P,REG); ! LR P,REG
2: RESULT=P
1: POP(WSP(LEVEL),I,J); ->3 UNLESS J=-1
J=N; N=N+4
3: DUMP(1,REG,J,0,RBASE); RESULT=-J
END
INTEGERFN CLAIMABLE REG
SHORTROUTINE
INTEGER I
-> 1 IF RBASE<= 4
CYCLE I=5,1,RBASE
RESULT=I IF REGISTER(I)=0
REPEAT
1: RESULT=0
END
INTEGERFN PARKF (INTEGER REG,PREC)
SHORTROUTINE
INTEGER I,J
->10 UNLESS PREC=0
POP(WSP(LEVEL),I,J)
->3 UNLESS J=-1
J=N; N=N+4
3: DUMP(9+2*PREC,REG,J,0,RBASE)
RESULT=J
10: J=GET DBLE WRD;->3 ;!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)
->1 IF J>0
J=N; N=N+24
1: RESULT =J
END
ROUTINE RHEAD(INTEGER KK)
SHORTROUTINE
INTEGER FLAG,W1,W2
FLAG=KK;FLAG=10000 IF RLEVEL=0
->5 IF RLEVEL=0
->5 UNLESS LIST=0
NEWLINE;WRITE(LINE,5);SPACES(3*LEVEL)
IF KK<0 THEN PRINTTEXT'BEGIN' ELSE START
PRINTTEXT'RT/FN/MAP '; PRINTNAME(KK); FINISH
WRITE(CA,6)
5: LEVEL=LEVEL+1
->6 IF FLAG<0
RLEVEL=RLEVEL+1;RBASE=10-RLEVEL;R13=0
FAULT(35) IF RBASE=4 OR REGISTER(RBASE)#0
REGISTER(RBASE)=1
6: FAULT(34) IF LEVEL=10
FAULT(105) IF LEVEL>MAX LEVELS
NMDECS(LEVEL)=0
->10 IF FLAG>=0
PRX(X'90',10,11,RBASE,N); ! STM 10,11,?
N=N+12;W1=RBASE;W2=N-4
->20
10: ->25 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
20: ->21 IF DIAGS1=0
PSS(X'D2',4,W1,W2,GLA,20)
LOADAD(0,0,0,LINE)
PCONST(X'4000D014') ; !STH 0,20(GLA)
21: MONE=1;SET LINE
25: 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
1: ->2 IF N<=256
PSS(X'D2',256,RBASE,K+1,RBASE,K)
K=K+256; N=N-256; ->1
2: 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
1: POP(EPLINK,JJ,KK)
-> 10 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; ->1
10: 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
LENGTH=4; ID1=M'S#G'; ID2=M'O '; ->10
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; ->10
SW(2): COMMENT ENTRY TO EXTERNAL ROUTINE
LENGTH=LETT(KK)
CYCLE JJ=1,1,8
BYTE INTEGER(ADDR(ID1)+JJ)=LETT(KK+JJ)
REPEAT
10: 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
->1 IF PARAMS(0)=0 ; CYCLE KK=1,1,PARAMS(0)
INSERT AFTER(OPHEAD,PARAMS(KK),0)
REPEAT
1: 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)
->3 UNLESS I=-1
->2 IF N&7=0
PUSH(WSP(LEVEL),0,N);N=N+4
2: J=N;N=N+8
3: RESULT =J
END
INTEGERFN GET STR WSP
SHORTROUTINE
INTEGER I,J
POP(STR WSP(LEVEL),I,J)
->2 UNLESS J=-1
J=N; N=N+256
2: 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
->9 IF MONE=0
PSI(X'92',LINE>>8,GLA,22); ! MVI
9: MONE=0; END
ROUTINE CHECK CAPACITY(INTEGER REG,DIS,X,LEVEL)
SHORTROUTINE
INTEGER MASK
RETURN UNLESS TYPE=1 AND 1<=PREC<=2
->3 IF PREC=1; ! %YTE
MASK=7
PRX(X'49',REG,LEVEL,X,DIS); ! CH REG,STORED VALUE
1: PRX(X'47',MASK,12,0,88); ->99; ! BC MASK,CAPACITY EXCE
3: PRX(X'55',REG,0,GLA,24); ! CL_1,=F'255'
MASK=2; ->1
99: 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
SHORT INTEGER(ADDR(ASLIST(P+6)))=0; ! LINK OF NEWCELL TO 0
RESULT=P
END
ROUTINE PUSH(SHORTINTEGERNAME CELL,INTEGER S1,S2)
INTEGER P,Q
P=NEWCELL
Q=ADDR(ASLIST(P))
INTEGER(Q)=S1
SHORT INTEGER(Q+4)=S2
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)
-> 1 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
1: 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)
-> 1 IF CELL=0
PUSH(SHORT INTEGER(ADDR(ASLIST(CELL+6))),S1,S2)
CELL=SHORT INTEGER(ADDR(ASLIST(CELL+6)))
RETURN
1: PUSH(CELL,S1,S2)
END
INTEGERFN FIND(INTEGER LAB,LIST)
3: ->1 IF LIST=0
->4 IF SHORT INTEGER(ADDR(ASLIST(LIST+4)))=LAB
MLINK(LIST); ->3
4: RESULT=INTEGER(ADDR(ASLIST(LIST)))
1: 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
1: POP(OPHEAD,I,J)
->1 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
1: ->2 IF A(P)=2
P=P+1; Q=Q+1; SKIP EXP; ->1
2: 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
->2 IF LINK=0
FROM2(LINK,LINK)
1: MLINK(LINK); FROM LIST(LINK,RR,II)
->2 IF II=-1
J=RR&15;PTYPE=RR>>4&X'FFFF'
RR=RR>>20;K=LINK
INREG=0
->99 IF RR=A(P); ->1
2: FAULT(65); PRINT NAME(A(P))
PTYPE=1
99: 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
1: 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; ->1; FINISH
RESULT=-1 IF Q=-1
RESULT=1
END
ROUTINE COPY TAG(INTEGER KK)
INTEGER Q
FROM LIST(TAGS(KK),Q,K)
-> NOT SET IF Q=-1
PTYPE=Q>>16
INREG=Q>>12&15
OLDI=Q>>8&15
I=Q>>4&15
J=Q&15
1: UNPACK
RETURN
NOTSET: PTYPE=7
I=-1; J=I; OLDI=J; -> 1
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
1: POP(JUMP(LEVEL),J,K); ->3 IF J=-1
Q=FIND(K,LABEL(LEVEL))
->2 UNLESS Q=-1;
PUSH(OPHEAD,J,K); ->1
2: KK=0
Q=Q-CODEBASE(LEVEL); K=Q>>12
->22 IF J&LABSET#0
->23 IF SBFLAG=1
PLUG(J,X'58E0')
PLUG(J+2,GLA<<12!4*PAGENO(Q)); J=J+4
KK=14 UNLESS K=0
21: PLUG(J+2,KK<<12!Q&X'FFF'); ->1
22: J=J&X'FFFFFF'; KK=10
23: FAULT(99) IF Q>4095; ->21
3: JUMP(LEVEL)=OPHEAD
END
ROUTINE PJ(INTEGER MASK,LAB)
SHORTROUTINE
INTEGER I,J,Q
J=FIND(LAB,LABEL(LEVEL)); ->200 IF J=-1
I=J-CODEBASE(LEVEL); ->50 IF I>=4096
PRX(X'47',MASK,0,10,I); ->999;! BC MASK,I(10,0)
50: 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); ->999;! BC MASK,?(10,14)
200: PUSH(JUMP(LEVEL),CA,LAB); PCONST(0) UNLESS SBFLAG=1
PRX(X'47',MASK,10,0,0); ! BC MASK,?(10,?)
999: END
ROUTINE PLAB(INTEGER M)
SHORTROUTINE
MONE=1
IF M>=0 THEN ->1
PLABEL=PLABEL-1; K=PLABEL
M=K
1: PUSH(LABEL(LEVEL),CA,M)
R13=0
END
!********** END **** OF **** LABEL ****** ROUTINES **************
ROUTINE CHECK RF
SHORTROUTINE
COPYTAG(A(MARKER1))
->1 UNLESS TYPE=4
JJ=K; FROM LIST(JJ,Q,FNAME)
DUMP(0,4,Q,0,I); ! ADDR OF FORMAT TO R4
->9
1: K=-1; FAULT(62)
9: 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
->4 IF CODE=4; ! IC NEEDED
->1 UNLESS CODE=0=DIS; ! OPTIMISE LOAD ADDR
->3 UNLESS LEVEL=0=X
PRR(X'1F',REG,REG); ->99; ! SLR INSTEAD LO LA REG,0
3: ->1 UNLESS LEVEL=0 OR X=0
PRR(X'18',REG,X+LEVEL) UNLESS REG=X+LEVEL;->99
4: PRR(X'1F',REG,REG) IF X#REG#LEVEL; ! SLR FOR BYTE
1: 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
99: END
END
ENDOFPROGRAM