%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<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=5%AND 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<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!!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)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): !-> 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)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 0S(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=1%AND TYPE=6%AND 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 017 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)=2%C =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%C IN RECORD FORMAT FOR RECORD ARRAYS LINK POINTS TO LP CELL HOLDING%C 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=4%C 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 LEVELP371 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)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