%MAINEP ICL9CEZIBMIMP %TRUSTEDPROGRAM %BEGIN %CONSTINTEGER RELEASE=1 %CONSTINTEGER YES=1,NO=0 %CONSTINTEGER USE IMP=NO %CONSTINTEGER VMEB=NO %CONSTSTRING(9) LADATE="30 Nov 81"; ! LAST ALTERED %INTEGER I, J, K ! PRODUCED BY OLDPS FROM IBM_PS02 ON 06/01/82 %CONSTBYTEINTEGERARRAY CLETT(0: 454)= 1, 40, 1, 41, 1, 42, 1, 44, 2, 201, 198, 6, 213, 206, 204, 197, 211, 211, 5, 215, 200, 201, 204, 197, 5, 213, 206, 212, 201, 204, 3, 198, 207, 210, 1, 61, 5, 193, 204, 201, 193, 211, 7, 201, 206, 212, 197, 199, 197, 210, 4, 210, 197, 193, 204, 4, 204, 207, 206, 199, 4, 194, 217, 212, 197, 6, 211, 212, 210, 201, 206, 199, 5, 211, 200, 207, 210, 212, 6, 210, 197, 195, 207, 210, 196, 7, 210, 207, 213, 212, 201, 206, 197, 2, 198, 206, 3, 205, 193, 208, 8, 198, 213, 206, 195, 212, 201, 207, 206, 4, 206, 193, 205, 197, 9, 193, 210, 210, 193, 217, 206, 193, 205, 197, 9, 207, 198, 208, 210, 207, 199, 210, 193, 205, 6, 207, 198, 198, 201, 204, 197, 6, 207, 198, 204, 201, 211, 212, 6, 198, 207, 210, 205, 193, 212, 3, 206, 207, 212, 3, 193, 206, 196, 2, 207, 210, 1, 58, 4, 211, 208, 197, 195, 5, 193, 210, 210, 193, 217, 3, 207, 215, 206, 8, 197, 216, 212, 197, 210, 206, 193, 204, 9, 197, 216, 212, 210, 201, 206, 211, 201, 195, 8, 195, 207, 206, 211, 212, 193, 206, 212, 5, 195, 207, 206, 211, 212, 5, 197, 214, 197, 206, 212, 5, 211, 212, 193, 210, 212, 9, 212, 200, 197, 206, 211, 212, 193, 210, 212, 4, 212, 200, 197, 206, 9, 197, 204, 211, 197, 211, 212, 193, 210, 212, 4, 197, 204, 211, 197, 1, 95, 6, 211, 217, 211, 212, 197, 205, 7, 196, 217, 206, 193, 205, 201, 195, 4, 80, 85, 84, 95, 5, 67, 78, 79, 80, 95, 7, 85, 83, 73, 78, 71, 42, 44, 4, 68, 82, 79, 80, 1, 43, 1, 45, 1, 60, 1, 62, 2, 45, 62, 6, 210, 197, 212, 213, 210, 206, 6, 210, 197, 211, 213, 204, 212, 7, 205, 207, 206, 201, 212, 207, 210, 4, 211, 212, 207, 208, 6, 211, 201, 199, 206, 193, 204, 4, 197, 216, 201, 212, 8, 195, 207, 206, 212, 201, 206, 213, 197, 6, 198, 201, 206, 201, 211, 200, 5, 195, 217, 195, 204, 197, 6, 210, 197, 208, 197, 193, 212, 3, 197, 206, 196, 7, 201, 206, 195, 204, 213, 196, 197, 5, 194, 197, 199, 201, 206, 2, 207, 206, 6, 211, 215, 201, 212, 195, 200, 4, 204, 201, 211, 212, 7, 211, 208, 197, 195, 201, 193, 204, 14, 212, 210, 213, 211, 212, 197, 196, 208, 210, 207, 199, 210, 193, 205, 6, 205, 193, 201, 206, 197, 208, 7, 195, 207, 206, 212, 210, 207, 204, 4, 40, 42, 41, 58; %CONSTINTEGERARRAY SYMBOL(1300: 2162)= 1312, 1305, 1001, 1359, 1786, 1308, 1003, 1020, 1312, 0, 1338, 2, 1322, 1316, 1001, 1014, 1318, 1003, 1322, 0, 1322, 2, 1329, 1329, 1010, 1028, 1312, 1011, 1352, 1338, 1336, 1010, 1028, 1312, 1011, 1352, 1338, 4, 1345, 1345, 1010, 1028, 1300, 1011, 1345, 1352, 1350, 1026, 1300, 999, 1352, 1000, 1359, 1357, 1026, 1312, 999, 1359, 1000, 1367, 1365, 0, 1338, 1367, 2, 1367, 1000, 1374, 1372, 6, 1338, 999, 1374, 1000, 1379, 1377, 8, 1379, 11, 1403, 1386, 18, 1010, 1537, 1557, 1011, 1392, 24, 1010, 1537, 1557, 1011, 1403, 30, 1010, 1001, 34, 1338, 6, 1338, 6, 1338, 1011, 1409, 1407, 36, 1013, 1409, 1000, 1416, 1414, 6, 1001, 999, 1416, 1000, 1421, 1419, 42, 1421, 1000, 1438, 1424, 42, 1426, 50, 1429, 55, 50, 1432, 60, 1416, 1435, 65, 1692, 1438, 72, 1416, 1460, 1441, 42, 1443, 50, 1446, 55, 50, 1449, 60, 1416, 1452, 65, 1692, 1455, 72, 1416, 1460, 78, 0, 1837, 2, 1467, 1463, 85, 1467, 1031, 1421, 1467, 1474, 1470, 93, 1472, 96, 1474, 100, 1490, 1480, 1438, 1495, 1001, 1409, 1486, 1460, 1490, 1001, 1409, 1502, 1490, 109, 1001, 1409, 1495, 1493, 109, 1495, 1000, 1502, 1498, 114, 1500, 109, 1502, 1000, 1512, 1510, 0, 1010, 1474, 1011, 1512, 2, 1512, 1000, 1521, 1519, 1030, 1010, 1474, 1011, 999, 1521, 1000, 1532, 1525, 124, 1016, 1527, 134, 1530, 141, 1018, 1532, 1016, 1537, 1535, 148, 1537, 1000, 1551, 1543, 1338, 1032, 1338, 1551, 1548, 0, 1537, 1557, 2, 1551, 155, 1537, 1557, 1555, 1037, 1338, 1557, 1000, 1568, 1562, 159, 1537, 1568, 1566, 163, 1537, 1575, 1568, 1000, 1575, 1573, 159, 1537, 999, 1575, 1000, 1582, 1580, 163, 1537, 999, 1582, 1000, 1590, 1586, 1033, 1338, 1588, 166, 1590, 1000, 1596, 1594, 168, 1008, 1596, 1015, 1600, 1599, 168, 1600, 1609, 1607, 6, 1338, 166, 1338, 1600, 1609, 1000, 1618, 1614, 1495, 1001, 1409, 1618, 173, 1532, 1618, 1624, 1624, 1001, 1409, 1794, 1624, 1630, 1628, 6, 1618, 1630, 1000, 1648, 1641, 1495, 1596, 1010, 1001, 1403, 1802, 1011, 1648, 1006, 1648, 173, 1532, 1596, 1001, 1794, 1670, 1659, 1657, 6, 1010, 1001, 1403, 1802, 1011, 1648, 1659, 1000, 1670, 1662, 179, 1664, 183, 1666, 192, 1668, 202, 1670, 211, 1681, 1679, 34, 1012, 1028, 1312, 1352, 1692, 1681, 1681, 1000, 1692, 1690, 6, 1012, 1028, 1312, 1352, 1692, 999, 1692, 1000, 1699, 1697, 0, 1329, 2, 1699, 1000, 1706, 1704, 6, 1322, 999, 1706, 1000, 1711, 1709, 217, 1711, 1000, 1717, 1715, 6, 1338, 1717, 1000, 1730, 1728, 6, 1001, 1409, 0, 1338, 166, 1338, 2, 999, 1730, 1000, 1737, 1735, 24, 1537, 1557, 1737, 1000, 1750, 1740, 1019, 1742, 1006, 1747, 1374, 1537, 1557, 1006, 1750, 1379, 1006, 1763, 1754, 223, 1034, 1757, 229, 1034, 1763, 239, 1010, 2000, 1011, 1769, 1769, 1767, 159, 2000, 1769, 1000, 1786, 1773, 244, 1034, 1781, 254, 1374, 1010, 1537, 1557, 1011, 1750, 1784, 254, 2000, 1786, 1000, 1794, 1792, 259, 1001, 1359, 1786, 1794, 1000, 1802, 1802, 0, 1338, 166, 1338, 1600, 2, 1810, 1808, 34, 1028, 1312, 1352, 1810, 1000, 1819, 1813, 261, 1815, 183, 1817, 268, 1819, 1000, 1830, 1828, 1001, 34, 1338, 6, 1338, 6, 1338, 1830, 1000, 1837, 1835, 6, 1844, 999, 1837, 1000, 1844, 1840, 1001, 1844, 1844, 1830, 1862, 1854, 1848, 1438, 1854, 1854, 0, 1844, 1830, 1862, 2, 1862, 1859, 1495, 1001, 1409, 1862, 173, 1618, 1870, 1868, 163, 1844, 1830, 999, 1870, 1000, 1888, 1874, 276, 1002, 1877, 1022, 1953, 1882, 281, 1009, 6, 1009, 1885, 287, 1009, 1888, 295, 1009, 1897, 1892, 300, 1005, 1895, 302, 1005, 1897, 1000, 1908, 1901, 1001, 1888, 1905, 304, 1001, 306, 1908, 4, 1888, 1921, 1916, 1005, 0, 1009, 6, 1009, 2, 1921, 1897, 0, 1009, 2, 1928, 1925, 1897, 1993, 1928, 1005, 1928, 1941, 1935, 0, 1009, 6, 1009, 2, 1939, 0, 1009, 2, 1941, 1000, 1947, 1945, 6, 1002, 1947, 1000, 1953, 1950, 1897, 1953, 1005, 1993, 1993, 1959, 1023, 1009, 6, 1009, 1964, 1024, 1009, 6, 1921, 1971, 1025, 1009, 6, 1009, 6, 1947, 1975, 1039, 1947, 1941, 1980, 1040, 1009, 6, 1947, 1985, 1041, 1908, 6, 1947, 1990, 1042, 1908, 6, 1908, 1993, 1043, 1009, 2000, 1998, 0, 1009, 2, 2000, 1000, 2033, 2009, 1010, 1001, 1359, 1786, 1011, 1582, 1763, 2013, 308, 1001, 1359, 2015, 311, 2019, 318, 1033, 1338, 2022, 325, 1763, 2024, 333, 2029, 338, 1706, 1322, 1711, 2031, 345, 2033, 350, 2163, 2040, 1027, 1010, 2000, 1011, 1737, 2042, 1007, 2050, 1374, 1010, 1537, 1557, 1011, 1750, 1006, 2055, 359, 1035, 1769, 1006, 2060, 366, 1029, 1819, 1006, 2065, 372, 1036, 1730, 1006, 2070, 1379, 366, 1029, 1006, 2078, 1004, 1008, 1010, 1438, 1011, 1609, 1006, 2082, 379, 1521, 1006, 2092, 78, 148, 1001, 0, 1844, 1830, 1862, 2, 1006, 2102, 1010, 1810, 1460, 1011, 1590, 1001, 1403, 1502, 1006, 2106, 1659, 1438, 1630, 2110, 383, 1003, 1038, 2114, 391, 1015, 1006, 2123, 397, 1021, 1706, 1322, 1699, 223, 1034, 1006, 2134, 400, 1001, 1409, 0, 1338, 166, 1338, 2, 1717, 1006, 2138, 407, 1006, 1017, 2143, 412, 109, 1001, 1006, 2147, 4, 1870, 1006, 2150, 420, 1006, 2154, 435, 1001, 1006, 2158, 442, 1003, 1006, 2161, 1001, 450, 2163, 1006; %CONSTINTEGER SS= 2033 ! %CONST %BYTE %INTEGER %ARRAY I TO E TAB(0 : 127) = %C X'40',X'40',X'40',X'40',X'40',X'40',X'40',X'40', X'40',X'40',X'15',X'40',X'0C',X'40',X'40',X'40', X'40',X'40',X'40',X'40',X'40',X'40',X'40',X'40', X'40',X'40',X'40',X'40',X'40',X'40',X'40',X'40', X'40',X'4F',X'7F',X'7B',X'5B',X'6C',X'50',X'7D', X'4D',X'5D',X'5C',X'4E',X'6B',X'60',X'4B',X'61', X'F0',X'F1',X'F2',X'F3',X'F4',X'F5',X'F6',X'F7', X'F8',X'F9',X'7A',X'5E',X'4C',X'7E',X'6E',X'6F', X'7C',X'C1',X'C2',X'C3',X'C4',X'C5',X'C6',X'C7', X'C8',X'C9',X'D1',X'D2',X'D3',X'D4',X'D5',X'D6', X'D7',X'D8',X'D9',X'E2',X'E3',X'E4',X'E5',X'E6', X'E7',X'E8',X'E9',X'4A',X'5F',X'5A',X'6A',X'6D', X'7C',X'81',X'82',X'83',X'84',X'85',X'86',X'87', X'88',X'89',X'91',X'92',X'93',X'94',X'95',X'96', X'97',X'98',X'99',X'A2',X'A3',X'A4',X'A5',X'A6', X'A7',X'A8',X'A9',X'C0',X'40',X'D0',X'40',X'40' %CONSTBYTEINTEGERARRAY 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'; %CONSTINTEGERARRAY NEM(0:120)=0, M'SSK',M'ISK',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'; %CONSTBYTEINTEGERARRAY ONE CASE(0 : 127) = %C 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15, 16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31, 32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47, 48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63, 64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79, 80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95, 96,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79, 80,81,82,83,84,85,86,87,88,89,90,123,124,125,126,127; %CONSTINTEGER NO OF SNS=63 %CONSTHALFINTEGERARRAY TSNAME (0:NO OF SNS)=X'1000'(8), X'1001',X'1000'(5),X'1001',X'1062',X'1001'(2),X'1062', X'1000'(2),X'52',X'51',X'62',X'1062'(7), X'1000',X'31',X'51',X'1062'(2),X'31',X'1000', X'51',X'62',X'1000'(2),X'35',X'1000',X'1035', X'31',X'35',X'1035',X'33',0,X'1001',X'51',X'52',X'51', X'61',X'72',X'61',X'72',X'51',X'62',X'1051',X'41', X'1000',X'62'; ! ! FIXED GLA CURRENTLY USED AS FOLLOWS ! 0-7 FREE(WAS 2900 ENTRY DESCRIPTOR) ! 8-11 ADDRESS OF UNSHARED SYMBOL TABLES ! 12-15 ADDRESS OF SHARED SYMBOL TABLES ! 16-19 LANGUAGE & COMPILER DATA ! 20-23 RESERVED (BUT IN MAIN PROGS IS FILLED WITH STACKPTR@ENTRY) ! 24-27 ADDRESS OF CONSTANT TABL ! 28-31 ADDRESS OF A WORD CONTAINING STACKTOP 0FOR NO CHECKS ! 32-39 FREE ! 40-55 DEFINES THE ENTRY POINT OF MDIAGS ! %OWNINTEGERARRAY FIXED GLA(0:13)=0(14); %CONSTBYTEINTEGERARRAY BYTES(0:7)=0(3),1,2,4,8,16; %CONSTBYTEINTEGERARRAY TRTAB(0:255)=0(48), 1(10),0(7),2(26),0(6),2(26),0(5),0(128) %CONSTINTEGER MAXLEVELS=31,CONCOP=13,FIXEDGLALEN=56 %CONSTINTEGER JOBBERBIT=X'40000000'; ! SET IN JOBBER MODE %CONSTINTEGER CEBIT=1; ! SET IN COMPILER ENVIRONMENT %CONSTINTEGER MAXDICT=X'100'; ! SET FOR MAX OF EVERYTHING ! ! IBM VERSION OF THE OPCODES ! %CONSTINTEGER FOURKTDISP=16 %CONSTINTEGER LGR=X'58',ST=X'50',LM=X'98',STM=X'90',MVC=X'D2',CLC=X'D5', LR=X'18',BCR=7,BAL=X'45',BC=X'47',CR=X'19',COMP=X'59',LA=X'41', %C IC=X'43',STC=X'42',STH=X'40',STE=X'70',STD=X'60', CH=X'49', BCTR=6,BALR=X'05',MVI=X'92',SPM=4,SRL=X'88',SLL=X'89',LH=X'48', SRDA=X'8E',SLDA=X'8F',BCT=X'46',EX=X'44',CLI=X'95',CL=X'55' %CONSTINTEGER LE=X'78',LD=X'68',LDR=X'28',LER=X'38',LCDR=X'23', %C LPDR=X'20',ADR=X'2A',SDR=X'2B',MDR=X'2C',DDR=X'2D',CDR=X'29', AD=X'6A',SD=X'6B',MD=X'6C',DD=X'6D',LTDR=X'22',AW=X'6E' ! INTEGER ARIRTHEMETIC FOLLOW ! %CONSTINTEGER AR=X'1A',SR=X'1B',MR=X'1C',LTR=X'12',LPR=X'10', %C LCR=X'13',XR=X'17',NR=X'14',OR=X'16',DR=X'1D',MH=X'4C', AH=X'4A',SH=X'4B' %CONSTINTEGER ADD=X'5A',SUB=X'5B',MULT=X'5C',DIV=X'5D',AND=X'54', OI=X'96' ! %CONSTINTEGER SHUFFLEDECS=B'1011110'; ! WHICH ALTS OF DEC ARE REORDERED %CONSTINTEGER MARGIN=512; ! MARGIN FOR ADRESSABILITY %CONSTINTEGER MAXREG=22; ! FOR DECLARING REGISTER ETC %CONSTINTEGER CODER=12 %CONSTINTEGER WSPR =11 %CONSTINTEGER GLA =13 %CONSTINTEGER LINKREG=15; ! REGISTER FOR RETURN ADDRESS %CONSTINTEGER EPREG=14; ! REGISTER HOLDING RT ENTRYPOINT %CONSTINTEGER CTABLEREG=14; ! REGISTER HOLDING CONSTANT TABLE %CONSTINTEGER IRESULT=1,TEMPBASE=2,RTPARAM=3,NAMEBASE=4,LITCONST=5, TABCONST=6,ADDROF=7,BASEOF=8,LOCALVAR=9,LOCALTIMES=10, FOURKMULT=11,LABFOURK=12,BASEREG=13,PERMFOURK=14,DVBASE=15, STRWKAREA=16 ! ! THE FOLLOWING FUNNY WORDS ARE CYCLE CONTROL WORDS FOR SEARCHING THE ! LIST OF FREE REGISTERS. THE TOP HALF IS INC(SIGNED) AND THE BOTTOM ! TWO BYTES ARE START AND FINISH RESPECTIVELY ! %CONSTINTEGER GR0 =X'1000F'; ! 0,1,15 %CONSTINTEGER GR1 =X'1010F'; ! 1,1,15 %CONSTINTEGER FR0 =X'FFFE1610'; ! 6,-2,0 %CONSTINTEGER ADDREG=X'FFFF0901'; ! 9,-1,1 %CONSTINTEGER SAFE =X'FFFF0904'; ! 9,-1,4 %CONSTINTEGER CLMABL=X'10509'; ! 5,1,9 %CONSTINTEGER FPRESULTREG=16; ! FOR RESULTS OF REAL FNS %CONSTBYTEINTEGERARRAY GRMAP(0:14)=0,1,2,3,15,16,18,20,22, 4,5,6,7,8,9; %CONSTBYTEINTEGERARRAY LOADCODE(0:7,3:6)=0,IC,0(5),IC, 0,LH,0(5),LH, 0,LGR,LE,0,0,LGR,0,LGR, 0,0,LD,0,0,0,0,LD; %CONSTBYTEINTEGERARRAY STORECODE(0:7,3:6)=0,STC,0(5),STC, 0,STH,0(5),STH, 0,ST,STE,0,0,ST,0,ST, 0,0,STD,0,0,0,0,STD; ! %CONSTSTRING(8)STACKTOPEP="I#STKTOP" %CONSTSTRING(8)MDEP="S#NDIAG" %CONSTSTRING(8)IOCPEP="S#IOCP"; ! EP FOR IOCP %CONSTINTEGER SNPT=X'1006'; ! SPECIALNAME PTYPE %CONSTINTEGER COMMALT=2,ENDALT=9,UNASSPAT=X'80808080',DECALT=8 ! %INTEGER DICTBASE, CONSTPTR, CONSTBTM, CONSTHOLE, WKFILEAD, %C WKFILEK, DUMMYFORMAT, P1SIZE, LEVELINF, IOCPDISP, PARMBITS1, %C PARMBITS2,PARMLET, MAX4KMULT, CCSTATE ! %INTEGER ASL, NNAMES, ARSIZE, CONSTLIMIT, OLDLINE, %C LENGTH, NEXTP, SNUM, RLEVEL, NMAX, USTPTR, PLABEL,%C LEVEL, LASTNAME, CDCOUNT, ASL CUR BTM, PARMDYNAMIC ! %INTEGER FAULTY, HIT, IMPS, TTOPUT, LIST, PARMDIAG, %C WARNFLAG, PARMTRACE, PARMLINE, CTYPE, %C CPRMODE, PARMCHK, PARMARR, PARMDBUG,%C COMPILER, LAST INST, SMAP, PARMY, BFFLAG ! %INTEGER RBASE, N, FREE FORMAT, PARMPROF, EXITLAB, CONTLAB, %C Q, R, S, NEST, FNAME, LDPTR, %C CREFHEAD, SSTL, QMAX, STMTS, LASTAT, %C FILE ADDR, FILE PTR, FILE END, FILE SIZE, LASTEND, %C BIMSTR,STLIMIT,STRLINK,ASL WARN,IHEAD ! %INTEGER MAX ULAB, SFLABEL %LONGREAL CVALUE, IMAX, CTIME %STRING(31)MAINEP %RECORDFORMAT LISTF(%INTEGER S1,S2,S3,LINK) %INTEGER LOGEPDISP,EXPEPDISP ! %EXTERNALINTEGER CA=0,CABUF=0,GLACA=FIXEDGLALEN,GLACABUF=FIXEDGLALEN %EXTERNALINTEGER PPCURR=0,LCA=0,INHCODE=0,DCOMP=0 %EXTERNALINTEGER PARMOPT=1,LINE=0 %EXTERNALBYTEINTEGERARRAY CODE(0:268) %EXTERNALBYTEINTEGERARRAY GLABUF(0:268) %EXTERNALINTEGERARRAY PLABS(0:31) %EXTERNALINTEGERARRAY PLINK(0:31) %SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N) %BEGIN FILE ADDR=COMREG(46); ! SOURCE FILE IF CLEAN PARMBITS1=COMREG(27) PARMBITS2=COMREG(28) WKFILEAD=COMREG(14) WKFILEK=INTEGER(WKFILEAD+8)>>10 %IF FILE ADDR<=0 %THEN FILESIZE=64000 %AND FILE ADDR=0 %ELSESTART FILE PTR=FILE ADDR+INTEGER(FILE ADDR+4) FILE END=FILE ADDR+INTEGER(FILE ADDR) FILE SIZE=INTEGER(FILE ADDR) %FINISH NNAMES=255 %IF FILESIZE>10000 %THEN NNAMES=511 %IF PARMBITS1&JOBBER BIT=0 %START %IF FILESIZE>32000 %THEN NNAMES=1023 %IF FILESIZE>256*1024 %OR PARMBITS2&MAXDICT#0 %OR %C WKFILEK>512 %THEN NNAMES=2047 %FINISH ASL=3*NNAMES ASL=4095 %IF ASL>4095 %AND PARMBITS2&MAXDICT=0;! STAY WITHIN 128K AUXSTACK ARSIZE=WKFILEK*768-300 %END %BYTEINTEGERARRAYFORMAT AF(0:ARSIZE) %BYTEINTEGERARRAYNAME A %RECORD(LISTF)%ARRAY ASLIST(0:ASL) %INTEGERARRAY WORD, TAGS(0:NNAMES) %INTEGERARRAY DVHEADS(0:12) %INTEGERFNSPEC FROMAR4(%INTEGER PTR) %INTEGERFNSPEC FROMAR2(%INTEGER PTR) %ROUTINESPEC TOAR8(%INTEGER PTR, %LONGREAL VALUE) %ROUTINESPEC TOAR4(%INTEGER PTR, VALUE) %ROUTINESPEC TOAR2(%INTEGER PTR,VALUE) %ROUTINESPEC WARN(%INTEGER N,V) %ROUTINESPEC FAULT(%INTEGER N,VAL,IDEN) %STRINGFNSPEC PRINTNAME(%INTEGER N) %INTEGERFNSPEC MORE SPACE !%INTEGERFNSPEC NEWCELL %ROUTINESPEC INSERTATEND(%INTEGERNAME S, %INTEGER A, B, C) %ROUTINESPEC FROM12(%INTEGER CELL, %INTEGERNAME S1, S2) %ROUTINESPEC FROM123(%INTEGER CELL, %INTEGERNAME S1, S2, S3) %ROUTINESPEC POP(%INTEGERNAME C, P, Q, R) %ROUTINESPEC PUSH(%INTEGERNAME C, %INTEGER S1, S2, S3) %INTEGERFNSPEC FIND(%INTEGER LAB, LIST) %ROUTINESPEC MLINK(%INTEGERNAME CELL) %ROUTINESPEC REPLACE1(%INTEGER CELL, S1) %ROUTINESPEC REPLACE2(%INTEGER CELL, S2) %ROUTINESPEC REPLACE3(%INTEGER CELL,S3) %ROUTINESPEC REPLACE123(%INTEGER CELL,A1,A2,S3) %INTEGERFNSPEC FROM2(%INTEGER CELL) %INTEGERFNSPEC FROM1(%INTEGER CELL) %INTEGERFNSPEC FROM3(%INTEGER CELL) %ROUTINESPEC BINSERT(%INTEGERNAME T,B,%INTEGER S1,S2,S3) %ROUTINESPEC CLEARLIST(%INTEGERNAME HEAD) %EXTERNALSTRING(16)%FNSPEC SWRITE(%INTEGER VALUE,PLACES) %EXTERNALSTRING(255)%FNSPEC MESSAGE(%INTEGER N) %SYSTEMROUTINESPEC LPUT(%INTEGER A, B, C, D) %SYSTEMLONGREALFNSPEC CPUTIME !*DELSTART %EXTERNALROUTINESPEC IBMCODE(%INTEGER START, FINISH, CA) %ROUTINESPEC PRINTLIST(%INTEGER HEAD) %ROUTINESPEC PRHEX(%INTEGER VALUE,PLACES) %ROUTINESPEC CHECK ASL !*DELEND %IF VMEB=NO %THEN %START %SYSTEMROUTINESPEC CONSOURCE(%STRING(31)FILE,%INTEGERNAME AD) %FINISH ! START OF COMPILATION A==ARRAY(WKFILE AD+256*WKFILEK, AF) %BEGIN !*********************************************************************** !* THIS BLOCK INITIALISE THE COMPILER SCALARS AND ARRAYS * !* WAS ORIGINALLY ROUTINE 'INITIALISE'. * !* THE INITIALISATION OF THE CONSTANT LISTS WITH THE VALUES * !* IN PERM MAY BE OMITTED IN BATCH OR CUT-DOWN VERSIONS. * !*********************************************************************** %ROUTINESPEC READ LINE(%INTEGER MODE,CHAR) %INTEGERFNSPEC COMPARE(%INTEGER P) %ROUTINESPEC PNAME(%INTEGER MODE) %ROUTINESPEC CONST(%INTEGER MODE) %ROUTINESPEC TEXTTEXT(%INTEGER EBCDIC) %INTEGER DSIZE,NEXT,ATLINE1,STARSTART,CCSIZE DSIZE=7*NNAMES; CCSIZE=256*(WKFILEK-1) %INTEGERARRAY DISPLAY,SFS(0:MAXLEVELS) %BYTEINTEGERARRAY TLINE(-60:161),LETT(0:DSIZE+20) %BYTEINTEGERARRAYFORMAT CCF(0:CCSIZE) %BYTEINTEGERARRAYNAME CC %CONSTBYTEINTEGERARRAY ILETT(0: 502)= 11, 'S','E','L','E','C','T','I','N','P','U','T', 12,'S','E','L','E', 'C','T','O','U','T','P','U','T', 7,'N','E','W','L','I','N','E', 5,'S','P','A','C','E', 10,'S','K','I','P','S','Y','M','B','O', 'L', 10,'R','E','A','D','S','T','R','I','N','G', 8,'N','E','W', 'L','I','N','E','S', 6,'S','P','A','C','E','S', 10,'N','E','X', 'T','S','Y','M','B','O','L', 11,'P','R','I','N','T','S','Y','M', 'B','O','L', 10,'R','E','A','D','S','Y','M','B','O','L', 4,'R', 'E','A','D', 5,'W','R','I','T','E', 7,'N','E','W','P','A','G', 'E', 4,'A','D','D','R', 6,'A','R','C','S','I','N', 3,'I','N', 'T', 5,'I','N','T','P','T', 6,'F','R','A','C','P','T', 5,'P', 'R','I','N','T', 7,'P','R','I','N','T','F','L', 4,'R','E','A', 'L', 7,'I','N','T','E','G','E','R', 3,'M','O','D', 6,'A','R', 'C','C','O','S', 4,'S','Q','R','T', 3,'L','O','G', 3,'S','I', 'N', 3,'C','O','S', 3,'T','A','N', 3,'E','X','P', 11,'C','L', 'O','S','E','S','T','R','E','A','M', 11,'B','Y','T','E','I','N', 'T','E','G','E','R', 8,'E','V','E','N','T','I','N','F', 6,'R','A','D','I','U','S', 6,'A','R','C','T','A','N', 6,'L','E','N','G','T','H', 11,'P','R','I','N','T','S','T','R', 'I','N','G', 2,'N','L', 8,'L','O','N','G','R','E','A','L', 7, 'P','R','I','N','T','C','H', 6,'R','E','A','D','C','H', 6,'S', 'T','R','I','N','G', 8,'R','E','A','D','I','T','E','M', 8,'N', 'E','X','T','I','T','E','M', 6,'C','H','A','R','N','O', 8,'T', 'O','S','T','R','I','N','G', 9,'S','U','B','S','T','R','I', 'N','G', 6,'R','E','C','O','R','D', 5,'A','R','R','A','Y', 6, 'S','I','Z','E','O','F',4,'I','M','O','D',2,'P', 'I',9,'E','V','E','N','T','L','I','N','E',11,'L','O','N','G', 'I','N','T','E','G','E','R',12,'L','O','N','G','L','O','N','G', 'R','E','A','L',9,'L','E','N','G','T','H','E','N','I', 9,'L','E','N','G','T','H','E','N','R', 8,'S','H','O','R','T','E','N','I', 8,'S','H','O','R','T','E','N','R', 6,'N','E','X','T','C','H', 12,'S','H','O','R','T','I','N','T','E','G','E','R', 8,'P','P','R','O','F','I','L','E', 5,'F','L','O','A','T',255; CC==ARRAY(WKFILEAD+32,CCF) IMAX=(-1)>>1;PLABEL=24999 LETT(0)=0 ATLINE1=ADDR(TLINE(1)) N=12; MAX ULAB=NNAMES+16384; ! LARGEST VALID USER LABEL PARMARR=1; LAST INST=0 PARMLINE=1; PARMTRACE=1; PARMDIAG=1 LIST=1; SFLABEL=20999; PARMCHK=1 EXITLAB=0; CONTLAB=0 OLDLINE=0; COMPILER=0 RLEVEL=0; NMAX=0; USTPTR=0 LEVEL=0; LASTAT=0 FAULTY=0; WARNFLAG=0; INHCODE=0 BFFLAG=0; CPRMODE=0 NEXT=1; LDPTR=0 IOCPDISP=0; CREFHEAD=0 RBASE=10; LOGEPDISP=0; EXPEPDISP=0; STRLINK=0 IHEAD=0 CCSTATE=0; SSTL=0; STMTS=1; SNUM=0; LEVELINF=0 CDCOUNT=0; LCA=0 BIMSTR=0 LOGEPDISP=0; EXPEPDISP=0 MAINEP="S#GO"; ! DEFAULT MAIN ENTRY DICTBASE=ADDR(LETT(0)) ! ! OPEN OBJECT FILE HERE BEFORE MORE PAGES OF COMPILER CODE ! ARE PAGED IN AND SUB-SYSTEM PAGES MOVE OUT ! LPUT(0,0,0,0) CTIME=CPUTIME I=COMREG(27) STLIMIT=X'1F000' %IF I>>24&1#0 %THEN STLIMIT=COMREG(48)-4096 %IF I&2=2 %THEN LIST=0 %IF I&4=4 %THEN PARMDIAG=0 %IF I&X'800000'#0 %THEN PARMLINE=0 %IF I&16=16 %THEN PARMCHK=0 %IF I&32=32 %THEN PARMARR=0 PARMPROF=(I>>15&1)!(I>>7&1); ! USE MAP OR PROFILE BIT PRO TEM PARMDYNAMIC=I>>20&1 PARMLET=I>>13&1 DCOMP=I>>14&1; ! PARM CODE OR D PARMDBUG=I>>18&1 %IF I&64=64 %THEN PARMTRACE=0 %AND PARMDIAG=0 FREE FORMAT=I&X'80000' SMAP=I>>26&1; ! USE PARMZ BIT FOR DUMPING WKFILE TTOPUT=COMREG(40) %IF I&(1<<16)#0 %THEN %START PARMARR=0; PARMOPT=0 PARMLINE=0; PARMCHK=0; PARMDIAG=0 %FINISH PARMTRACE=PARMTRACE!PARMOPT; ! ALLOW NOTRACE ONLY WITH OPT IMPS=I>>23&1; ! BIT SET IF IMPS REQUESTED IMPS=1; ! FOR TESTING NEWLINES(3); SPACES(14) PRINTSTRING("ERCC. IBM Imp80") PRINTSTRING(" Compiler Release") WRITE(RELEASE,1) PRINTSTRING(" Version ".LADATE) NEWLINES(3) WRITE(NNAMES,5); WRITE(ASL,5) NEWLINE ASL WARN=0 ASL CUR BTM=ASL-240 CONST LIMIT=4*ASL CUR BTM-8 %CYCLE I=ASL CUR BTM,1,ASL-1 ASLIST(I+1)_LINK=I %REPEAT ASLIST(ASL CUR BTM)_LINK=0 ASLIST(0)_S1=-1 ASLIST(0)_S2=-1 ASLIST(0)_S3=-1 ASLIST(0)_LINK=0 %CYCLE I=0,1,NNAMES WORD(I)=0; TAGS(I)=0; %REPEAT %CYCLE I=0,1,12 DVHEADS(I)=0 %REPEAT ! ! NOW DECLARE THE SPECIAL NAMES WHICH ARE IN ARRAY ILETT. ! K=0; NEXT=1 I=ILETT(0) %WHILE I<255 %CYCLE %CYCLE J=I,-1,1 CC(J)=ILETT(K+J) %REPEAT CC(I+1)=';' R=2; Q=1; PNAME(1) PUSH(TAGS(LASTNAME),SNPT<<16!X'8000',0,SNUM<<16) SNUM=SNUM+1 K=K+I+1; I=ILETT(K) %REPEAT ! COMREG(24)=16; ! RETURN CODE DUMMY FORMAT=0; ! DUMMY RECORD FORMAT PUSH(DUMMY FORMAT,0,0,0); ! FOR BETTER ERROR RECOVERY LINE=0; LENGTH=0; Q=1 R=1; LEVEL=1 %CYCLE %IF Q>=LENGTH %THEN QMAX=1 %AND READ LINE(0,0) WARNFLAG=0 STARSTART=R R=R+3 OLDLINE=LINE A(R)=LINE>>8 A(R+1)=LINE&255 R=R+2 %IF COMPARE(SS)=0 %THEN %START FAULT(100,ADDR(CC(0)),0) R=STARSTART %FINISH %ELSE %START FAULT(102, WKFILEK, 0) %IF R>ARSIZE %IF A(STARSTART+5)=COMMALT %THEN R=STARSTART %ELSE %START I=R-STARSTART A(STARSTART)=I>>16 A(STARSTART+1)=I>>8&255 A(STARSTART+2)=I&255 %IF A(STARSTART+5)=DECALT %AND LEVEL>1 %THEN %START %IF SFS(LEVEL)=0 %THEN %START TO AR4(DISPLAY(LEVEL),STARSTART) DISPLAY(LEVEL)=STARSTART+6 %FINISH %ELSE A(STARSTART+6)=128;! FLAG AS UNLINKED %FINISH !*DELSTART %IF SMAP#0 %THEN %START NEWLINE; WRITE(LINE, 5) WRITE(STARSTART,5); NEWLINE; J=0 %CYCLE I=STARSTART, 1, R-1 WRITE(A(I), 5) J=J+1 %IF J>=20 %THEN NEWLINE %AND J=0 %REPEAT NEWLINE %FINISH !*DELEND %IF A(STARSTART+5)=ENDALT %AND %C 1<=A(STARSTART+6)<=2 %START;! ENDOF PROG OR FILE %IF IHEAD=0 %THEN %EXIT POP(IHEAD,FILEADDR,FILEPTR,FILEEND) R=STARSTART; ! IGNORE ENDOFFILE LIKE IMP77 LENGTH=1 %CONTINUE %FINISH %IF LEVEL=0 %THEN %START FAULT(14, 0, 0) R=STARSTART; ! IGNORE IT LEVEL=1 %FINISH %FINISH %FINISH %REPEAT TO AR8(R,0); R=R+8 %IF R+NEXT>ARSIZE %THEN FAULT(102, WKFILEK,0) P1SIZE=R %CYCLE I=0,1,NEXT A(R+I)=LETT(I) %REPEAT DICTBASE=ADDR(A(R)) R=R+NEXT+1 ->BEND %ROUTINE READ LINE(%INTEGER MODE,CHAR) %ROUTINESPEC GET LINE %INTEGER DEL, LL, LP, PREV LL=0; LP=0; Q=1 LENGTH=0; DEL=0 NEXT: LP=LP+1 %IF LP>LL %THEN GET LINE %AND LP=1 I=TLINE(LP) %IF MODE=0 %THEN %START %IF I='{' %THEN %START %CYCLE PREV=I LP=LP+1 I=TLINE(LP) %REPEAT %UNTIL PREV='}' %OR I=NL %FINISH %IF I='%' %THEN DEL=128 %AND ->NEXT I=ONE CASE(I) %IF 'A'<=I<='Z' %THEN I=I!DEL %ELSE %START DEL=0 ->NEXT %IF I=' ' %FINISH LENGTH=LENGTH+1 CC(LENGTH)=I %IF I='''' %OR I=34 %THEN MODE=1 %AND CHAR=I %FINISH %ELSE %START LENGTH=LENGTH+1 CC(LENGTH)=I %IF I=CHAR %THEN MODE=0 %FINISH ->NEXT %UNLESS I=NL I=CC(LENGTH-1) %IF I='C'+128 %THEN LENGTH=LENGTH-2 %AND ->NEXT %IF MODE=0 %AND I=',' %THEN LENGTH=LENGTH-1 %AND ->NEXT FAULT(101,0,0) %IF LENGTH>CCSIZE %RETURN %ROUTINE GET LINE %SYSTEMROUTINESPEC IOCP(%INTEGER A,B) %CONSTBYTEINTEGERARRAY ITOI(0:255)=%C 32(10),10,32(14),25,26,32(5), 32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47, 48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63, 64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79, 80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95, 96,97,98,99,100,101,102,103,104,105,106,107,108,109, 110,111,112,113,114,115,116,117,118,119, 120,121,122,123,124,125,126,32, 26(5),10,26(10), 26(16), 26(14),92,38, 26(11),35,26(4), 26(16), 26(9),35,26(5),94, 26(32); %INTEGER K LL=0 %IF FILE ADDR=0 %THEN %START; ! SOURCE NOT A 'CLEAN' FILE %UNTIL K=NL %CYCLE READ SYMBOL(K) TLINE(LL+1)=ITOI(K) LL=LL+1 %REPEAT %FINISH %ELSE %START %IF FILEPTR>=FILE END %START %IF IHEAD#0 %THEN POP(IHEAD,FILEADDR,FILEPTR,FILEEND) %C %AND GETLINE %AND %RETURN FAULT(110,0,0) %FINISH %UNTIL K=NL %OR K=0 %CYCLE K=BYTE INTEGER(FILEPTR); ! NEXT CHAR FROM SORCE FILE FILE PTR=FILE PTR+1 TLINE(LL+1)=ITOI(K) LL=LL+1 %REPEAT %FINISH ! %IF MODE=0 %AND LL=1 %THEN GET LINE %AND %RETURN ! LINE=LINE+1 %UNLESS MODE=0 %AND LENGTH>0 LINE=LINE+1; ! COUNT ALL LINES %IF LIST#0 %THEN %START %IF MODE=0 %AND LENGTH>0 %THEN %C PRINTSTRING(" C") %ELSE WRITE(LINE, 5) ! SPACES(8) %CYCLE K=-7,1,0 TLINE(K)=' ' %REPEAT %IF MODE#0 %THEN TLINE(-7)=M'"' TLINE(-8)=LL+8 IOCP(15,ADDR(TLINE(-8))) %FINISH %IF FREE FORMAT=0 %AND LL>73 %THEN TLINE(73)=10 %AND LL=73 %END %END %INTEGERFN COMPARE(%INTEGER P) %INTEGER I, J, ITEM, RA, RL, RP, RQ, RR, RS, MARKER, SSL, ALT, PP %OWNINTEGER SAVECOMP; ! FOR CHECKING DSIDED CONDS %SWITCH BIP(999:1043) RP=SYMBOL(P) RL=LEVEL P=P+1 PP=P; ! ROUTINE REALLY STARTS HERE COMM: RQ=Q; ! RESET VALUES OF LINE&AR PTRS RR=R SSL=STRLINK; ! SAVE STRING LINK ALT=1; ! FIRST ALTERNATIVE TO BE TRIED RA=SYMBOL(P); ! RA TO NEXT PHRASE ALTERNATIVE RS=P UPR: R=R+1 SUCC: ! SUCCESS ON TO NEXT ITEM RS=RS+1; ! RS=NEXT ALTERNATIVE MEANS THAT ! THIS ALT HAS BEEN COMPLETED SO ! EXIT WITH HIT=1 %IF RS=RA %THEN ->FINI ITEM=SYMBOL(RS); ! NEXT BRICK IN THE CURRENT ALT %IF ITEM<999 %THEN ->LIT %IF ITEM<1300 %THEN ->BIP(ITEM) ! BRICK IS A PHRASE TYPE %IF COMPARE(ITEM)=0 %THEN ->FAIL ->SUCC LIT: ! BRICK IS LITERAL I=CC(Q); ! OBTAIN CURRENT CHARACTER ->FAIL %UNLESS I=CLETT(ITEM+1) Q=Q+1 K=CLETT(ITEM)+ITEM ITEM=ITEM+2 %WHILE ITEM<=K %CYCLE ->FAIL %UNLESS CC(Q)=CLETT(ITEM) Q=Q+1 ITEM=ITEM+1 %REPEAT; ! CHECK IT WITH LITERAL DICT ENTRY ->SUCC; ! MATCHED SUCCESSFULLY FAIL: ! FAILURE - NOTE POSITION REACHD %IF RA=RP %THEN ->TFAIL; ! TOTAL FAILURE NO ALT TO TRY QMAX=Q %IF Q>QMAX Q=RQ; ! RESET LINE AND A.R. POINTERS R=RR+1; ! AVOID GOING VIA UPR: STRLINK=SSL ALT=ALT+1; ! MOVE TO NEXT ALT OF PHRASE RS=RA RA=SYMBOL(RA) ->SUCC TFAIL: LEVEL=RL %RESULT=0 BIP(999): ! REPEATED PHRASE A(RR)=ALT; P=PP ->COMM BIP(1000):FINI: ! NULL ALWAYS LAST & OK A(RR)=ALT %RESULT=1 BIP(1001): ! PHRASE NAME I=CC(Q); ! OBTAIN CURRENT CHARACTER ->FAIL %UNLESS TRTAB(I)=2 PNAME(ITEM-1004) ->SUCC %IF HIT=1; ->FAIL BIP(1002): ! PHRASE INTEGER CONSTANT BIP(1003): ! PHRASE CONST CONST(ITEM-1003) ->FAIL %IF HIT=0 ->SUCC BIP(1004): ! PHRASE CHECK EXTENDEDTYPE ! FIRST LETTER IS (B,H,I,L,R,S) ! 3RD LETTER (A,C,L,N,O,R,T) I=CC(Q) ->FAIL %UNLESS I>128 %AND X'80000000'>>(I&31)&X'20C83000'#0%C %AND X'80000000'>>(CC(Q+2)&31)&X'500B2800'#0 ->SUCC BIP(1005): ! PHRASE N I=CC(Q); ! OBTAIN CURRENT CHARACTER ->FAIL %UNLESS '0'<=I<='9' S=0 %WHILE '0'<=I<='9' %CYCLE S=10*S+I&15 Q=Q+1; I=CC(Q) %REPEAT TOAR2(R,S) R=R+2; ->SUCC BIP(1006): ! PHRASE S=SEPARATOR I=CC(Q); ! OBTAIN CURRENT CHARACTER ->SUCC %IF I=NL ->FAIL %UNLESS I=';' Q=Q+1; ->SUCC BIP(1007): ! PHRASE COMMENT TEXT I=CC(Q); ! OBTAIN CURRENT CHARACTER ->FAIL %UNLESS I='!' %OR I='|' %OR (I='C'+128 %AND CC(Q+1)=%C 'O'+128 %AND CC(Q+2)=CC(Q+3)='M'+128 %AND CC(Q+4)='E'+128 %C %AND CC(Q+5)='N'+128 %AND CC(Q+6)='T'+128) Q=Q+1+6*(I>>7); J=CC(Q) %CYCLE %EXIT %IF J=NL WARN(6,0) %IF J=';' %AND CC(Q+1)#'!' Q=Q+1; J=CC(Q) %REPEAT ->SUCC BIP(1008): ! PHRASE BIGHOLE TO AR4(R,0) R=R+4; ->SUCC BIP(1009): ! PHRASE N255 I=CC(Q); ! OBTAIN CURRENT CHARACTER ->FAIL %UNLESS '0'<=I<='9' S=0 %WHILE '0'<=I<='9' %CYCLE S=10*S+I&15 Q=Q+1; I=CC(Q) %REPEAT ->FAIL %UNLESS 0<=S<=255 A(R)=S; ->UPR BIP(1010): ! PHRASE HOLE MARKER=R; R=R+2; ->SUCC BIP(1011): ! PHRASE MARK I=R-MARKER A(MARKER+1)<-I A(MARKER)<-I>>8 ->SUCC BIP(1012): ! PHRASE READLINE? I=CC(Q); ! OBTAIN CURRENT CHARACTER %WHILE I=NL %%CYCLE READLINE(0,0) RQ=1 I=CC(Q) %REPEAT FAULT(102, WKFILEK,0) %IF R>ARSIZE ->SUCC BIP(1013): ! PHRASE CHECKIMPS R=R-4; ! AVOID HOLE LEFT BY TEXTTEXT TEXTTEXT(0) ->FAIL %IF HIT=0 ->SUCC BIP(1014): ! PHRASE DUMMY APP A(R)=2; A(R+1)=2 R=R+2; ->SUCC BIP(1015): ! PHRASE DOWN=NEW TEXT LEVEL LEVEL=LEVEL+1 TO AR4(R,0) DISPLAY(LEVEL)=R SFS(LEVEL)=0 R=R+4 ->SUCC BIP(1016): ! PHRASE UP 1 TEXTUAL LEVEL DISPLAY(LEVEL)=0 %WHILE SFS(LEVEL)#0 %CYCLE POP(SFS(LEVEL),I,J,K) %IF I=1 %THEN FAULT(53,K,0); ! FINISH MISSING %IF I=2 %THEN FAULT(13,K,0); ! %REPEAT MISSING %REPEAT LEVEL=LEVEL-1 ->SUCC BIP(1017): ! PHRASE LISTON LIST=1; ->SUCC BIP(1018): ! PHRASE LISTOFF LIST=0; ->SUCC BIP(1019): ! PHRASE COLON FOR LABEL ->FAIL %UNLESS CC(Q-1)=':' ->SUCC BIP(1020): ! PHRASE NOTE CONST %IF CTYPE=5 %THEN TOAR4(S-4,STRLINK) %AND STRLINK=S-4 ->SUCC BIP(1021): ! TRACE FOR ON CONDITIONS PARMTRACE=1; ->SUCC BIP(1022): ! SET MNEMONIC I=CC(Q); ! OBTAIN CURRENT CHARACTER S=0 %WHILE 'A'<=I<='Z' %CYCLE S=S<<8!I; Q=Q+1; I=CC(Q) %REPEAT ->FAIL %UNLESS I='_' %AND S#0 Q=Q+1; ->SUCC BIP(1023): ! UCRR =RR FORMAT MNEMONIC %IF S&255='R' %THEN %START J=S>>8 %CYCLE I=2,1,48 ->PFND %IF NEM(I)=J %REPEAT %FINISH %ELSE %START %CYCLE I=1,1,2 ->PFND %IF NEM(I)=S %REPEAT %FINISH ->FAIL PFND: A(R)=OPC(I)&63; ->UPR BIP(1024): ! UCRX = RX FORMAT MNEMONIC %CYCLE I=18,1,64 ->SFND %IF NEM(I)=S %REPEAT ->FAIL SFND: A(R)=OPC(I); ->UPR BIP(1025): ! UCRS RS FORMAT MNEMONIC %CYCLE I=66,1,69 %IF NEM(I)=S %THEN ->SFND %REPEAT; ->FAIL BIP(1026): ! P(OP)=+,-,&,****,**,*,!!,!, ! //,/,>>,<<,.,\\,\ I=CC(Q); ! OBTAIN CURRENT CHARACTER ->FAIL %UNLESS 32>((I-32)&31)&X'4237000A'#0 Q=Q+1 %IF I='+' %THEN A(R)=1 %AND ->UPR %IF I='-' %THEN A(R)=2 %AND ->UPR %IF I='&' %THEN A(R)=3 %AND ->UPR J=CC(Q) %IF I='*' %THEN %START %IF J#I %THEN A(R)=6 %AND ->UPR %IF CC(Q+1)=I=CC(Q+2) %THEN A(R)=4 %AND Q=Q+3 %AND ->UPR A(R)=5; Q=Q+1; ->UPR %FINISH %IF I='/' %THEN %START %IF J#I %THEN A(R)=10 %AND ->UPR A(R)=9; Q=Q+1; ->UPR %FINISH %IF I='!' %THEN %START %IF J#I %THEN A(R)=8 %AND ->UPR A(R)=7; Q=Q+1; ->UPR %FINISH %IF I='.' %THEN A(R)=13 %AND ->UPR %IF I=J='<' %THEN A(R)=12 %AND Q=Q+1 %AND ->UPR %IF I=J='>' %THEN A(R)=11 %AND Q=Q+1 %AND ->UPR %IF I='\' %THEN %START %IF J#I %THEN A(R)=15 %AND ->UPR Q=Q+1; A(R)=14; ->UPR %FINISH ->FAIL BIP(1027): ! PHRASE CHECK UI I=CC(Q); ! OBTAIN CURRENT CHARACTER ->SUCC %IF TRTAB(I)=2 %OR I='-' ->SUCC %IF X'80000000'>>(I&31)&X'14043000'#0 ->FAIL BIP(1028): ! P(+')=+,-,\,0 I=CC(Q); ! OBTAIN CURRENT CHARACTER %IF I='\' %OR I=X'7E' %THEN A(R)=3 %AND Q=Q+1 %AND ->UPR %IF I='-' %THEN A(R)=2 %AND Q=Q+1 %AND ->UPR %IF I='+' %THEN A(R)=1 %AND Q=Q+1 %AND ->UPR A(R)=4; ->UPR BIP(1029): ! PHRASE NOTE CYCLE TOAR4(R,0) PUSH(SFS(LEVEL),2,R,LINE) R=R+4 ->SUCC BIP(1030): ! P(,')=',',0 ! ! THIS IS VERY AWKWARD AS IT MEANS IT IS VERY TO HARD TO FIND ! THE END OF A PARAMETER LIST WITHOUT CHURNING. BY MAKING THIS A BIP ! WE CAN PEEP AHEAD FOR ')' AND FAIL HERE. ! I=CC(Q); ! OBTAIN CURRENT CHARACTER %IF I=')' %THEN ->FAIL %IF I=',' %THEN Q=Q+1 ->SUCC BIP(1031): ! PHRASE CHECKTYPE IE ENSURE ! FIRST LETTER IS(B,H,I,L,R,S) & ! 3RD LETTER IS (A,L,N,O,R,T) I=CC(Q); ! OBTAIN CURRENT CHARACTER ->FAIL %UNLESS I>128 %AND X'80000000'>>(I&31)&X'20C83000'#0%C %AND X'80000000'>>(CC(Q+2)&31)&X'400B2800'#0 ->SUCC BIP(1032): ! PHRASE COMP1 BIP(1037): ! PHRASE COMP2(IS 2ND HALF OF DSIDED) I=CC(Q); ! OBTAIN CURRENT CHARACTER ->FAIL %UNLESS 32>(I&31)&X'1004000E'#0 ! '='=1,'>='=2,'>'=3 ! '#' OR '\=' OR '<>'=4 ! '<='=5,'<'=6 ! 7UNUSED,'->'=8,'=='=9 ! '##' OR '\==' =10 %IF I='=' %THEN %START %IF CC(Q+1)=I %THEN J=9 %AND ->JOIN1 J=1; ->JOIN %FINISH %IF I='#' %THEN %START %IF CC(Q+1)=I %THEN J=10 %AND ->JOIN1 J=4; ->JOIN %FINISH %IF I='\' %AND CC(Q+1)='=' %THEN %START Q=Q+1 %IF CC(Q+1)='=' %THEN J=10 %AND ->JOIN1 J=4; ->JOIN %FINISH %IF I='>' %THEN %START %IF CC(Q+1)='=' %THEN J=2 %AND ->JOIN1 J=3; ->JOIN %FINISH %IF I='<' %THEN %START %IF CC(Q+1)='>' %THEN J=4 %AND ->JOIN1 %IF CC(Q+1)='=' %THEN J=5 %AND ->JOIN1 J=6; ->JOIN %FINISH %IF I='-' %AND CC(Q+1)='>' %THEN J=8 %AND ->JOIN1 ->FAIL JOIN1:Q=Q+1 JOIN: Q=Q+1 A(R)=J %IF ITEM=1032 %THEN SAVECOMP=J %AND ->UPR ! SAVE J TO CHECK DSIDED %IF SAVECOMP>6 %OR J>6 %THEN Q=Q-1 %AND ->FAIL;! ILLEGAL DSIDED ->UPR; ! NB OWNS WONT WORK IF ! COND EXPRS ALLOWED AS THE ! CAN BE NESTED! BIP(1033): ! P(ASSOP)- ==,=,<-,-> I=CC(Q); ! OBTAIN CURRENT CHARACTER %IF I='=' %THEN %START %IF CC(Q+1)='=' %THEN A(R)=1 %AND Q=Q+2 %AND ->UPR A(R)=2; Q=Q+1; ->UPR %FINISH %IF I='<' %AND CC(Q+1)='-' %THEN A(R)=3 %AND Q=Q+2 %AND ->UPR %IF I='-' %AND CC(Q+1)='>' %THEN A(R)=4 %AND Q=Q+2 %AND ->UPR ->FAIL BIP(1034): ! NOTE START TOAR4(R,0); ! HOLE FOR FORWARD PTR PUSH(SFS(LEVEL),1,R,LINE) R=R+4 ->SUCC BIP(1035): ! NOTE FINISH %IF SFS(LEVEL)=0 %THEN FAULT(51,0,0) %AND ->SUCC POP(SFS(LEVEL),I,J,K) %IF I=2 %THEN FAULT(59,K,0) TOAR4(J,STARSTART) ->SUCC BIP(1036): ! NOTE REPEAT %IF SFS(LEVEL)=0 %THEN FAULT(1,0,0) %AND ->SUCC POP(SFS(LEVEL),I,J,K) %IF I=1 %THEN FAULT(52,K,0); ! START INSTEAD OF CYCLE TOAR4(J,STARSTART) ->SUCC BIP(1038): ! INCLUDE "FILE" ->FAIL %IF VMEB=YES I=CC(Q) ->FAIL %UNLESS I=NL %OR I=';' Q=Q+1 %IF I=';' ->FAIL %UNLESS CTYPE=5 PUSH(IHEAD,FILEADDR,FILEPTR,FILEEND) CONSOURCE(STRING(ADDR(A(S))),FILEADDR);! DEPARTS IF FAILS FILEPTR=FILEADDR+INTEGER(FILEADDR+4) FILEEND=FILEADDR+INTEGER(FILEADDR) ->SUCC BIP(1039): ! UCSI = SI FORMAT MNEMONICS %CYCLE I=71,1,83 ->SFND %IF NEM(I)=S %REPEAT ->FAIL BIP(1040): ! UCSHIFT = SHIFT MNEMONICS %CYCLE I=85,1,92 ->SFND %IF NEM(I)=S %REPEAT; ->FAIL BIP(1041): ! UCSS = SS FORMAT MNEMONICS %CYCLE I=94,1,106 ->SFND %IF NEM(I)=S %REPEAT; ->FAIL BIP(1042): ! UCPD = DECIMAL MNEMONICS %CYCLE I=108,1,116 ->SFND %IF NEM(I)=S %REPEAT; ->FAIL BIP(1043): ! UCSPEC THE FUNNIES %CYCLE I=11,1,120 ->SFND %IF NEM(I)=S %REPEAT; ->FAIL %END; !OF ROUTINE 'COMPARE' %ROUTINE PNAME(%INTEGER MODE) !*********************************************************************** !* MODE=0 FOR OLD NAME(ALREADY IN DICT), MODE=1 FOR NEW NAME * !*********************************************************************** %CONSTINTEGERARRAY HASH(0:7)=71,47,97,79,29,37,53,59; %INTEGER JJ, KK, LL, FQ, FS, T, S, I HIT=0; FQ=Q; FS=CC(Q) %RETURN %UNLESS TRTAB(FS)=2 %AND M'"'#CC(Q+1)#M'''' ! 1ST CHAR MUST BE LETTER T=1 LETT(NEXT+1)=FS; JJ=71*FS %CYCLE Q=Q+1 I=CC(Q) %EXIT %IF TRTAB(I)=0 JJ=JJ+HASH(T) %IF T<=7 T=T+1 LETT(NEXT+T)=I %REPEAT LETT(NEXT)=T; ! INSERT LENGTH S=T+1 FAULT(103,0,0) %IF NEXT+S>DSIZE; !DICTIONARY OVERFLOW JJ=(JJ+113*T)&NNAMES %CYCLE KK=JJ, 1, NNAMES LL=WORD(KK) ->HOLE %IF LL=0; ! NAME NOT KNOWN ->FND %IF STRING(ADDR(LETT(NEXT)))=STRING(ADDR(LETT(LL))) %REPEAT %CYCLE KK=0,1,JJ LL=WORD(KK) ->HOLE %IF LL=0; ! NAME NOT KNOWN ->FND %IF STRING(ADDR(LETT(NEXT)))=STRING(ADDR(LETT(LL))) %REPEAT FAULT(104, 0, 0); ! TOO MANY NAMES HOLE: %IF MODE=0 %THEN Q=FQ %AND %RETURN WORD(KK)=NEXT; NEXT=NEXT+S FND: LASTAT=FQ; HIT=1; LASTNAME=KK A(R+1)<-LASTNAME A(R)=LASTNAME>>8; R=R+2 LASTEND=Q %END %ROUTINE CONST(%INTEGER MODE) !*********************************************************************** !* SYNTAX CHECK AND EVALUATE ALL THE FORMS OF IMP CONSTANT * !* MODE=0 FOR INTEGER CONSTANTS #0 FOR ANY SORT OF CONSTANT * !*********************************************************************** %INTEGER Z, DOTSEEN, EBCDIC, FS, CPREC, RR, S, T %LONGREAL X,CVALUE,DUMMY %INTEGER RADIXV %CONSTLONGREAL TEN=R'41A0000000000000' %ON %EVENT 1,2 %START HIT=0; %RETURN %FINISH CPREC=5; RR=R; R=R+1 DOTSEEN=0; HIT=0 CVALUE=0; DUMMY=0; X=0; FS=CC(Q) S=0; ->N %IF M'0'<=FS<=M'9' ->DOT %IF FS='.' %AND MODE=0 %AND '0'<=CC(Q+1)<='9' ! 1 DIDT MIN CTYPE=1; EBCDIC=0 ->QUOTE %IF FS=M'''' ->STR2 %IF FS=34 ->NOTQUOTE %UNLESS CC(Q+1)=M''''; Q=Q+2 ->HEX %IF FS='X' ->MULT %IF FS='M' ->BIN %IF FS=M'B' ->RHEX %IF FS='R' %AND MODE=0 ->OCT %IF FS='K' %IF FS='C' %THEN EBCDIC=1 %AND ->MULT ! %IF FS='D' %AND MODE=0 %THEN %START ! CPREC=7 ! %IF M'0'<=CC(Q)<=M'9' %THEN ->N ! %IF CC(Q)='.' %THEN ->DOT ! %FINISH Q=Q-2; %RETURN QUOTE: ! SINGLE CH BETWEEN QUOTES S=CC(Q+1); Q=Q+2 %IF S=NL %THEN READLINE(1,'''') %AND Q=1 %IF CC(Q)=M'''' %THEN %START Q=Q+1 %IF S#M'''' %THEN ->IEND %IF CC(Q)=M'''' %THEN Q=Q+1 %AND ->IEND %FINISH %RETURN; ! NOT VALID NOTQUOTE: ! CHECK FOR E"...." %RETURN %UNLESS FS='E' %AND CC(Q+1)=M'"' EBCDIC=1; Q=Q+1 STR2: ! DOUBLE QUOTED STRING A(RR)=X'35'; TEXTTEXT(EBCDIC) CTYPE=5; %RETURN HEX: T=0; ! HEX CONSTANTS %CYCLE I=CC(Q); Q=Q+1 %EXIT %IF I=M'''' T=T+1 %RETURN %UNLESS %C ('0'<=I<='9' %OR 'A'<=I<='F' %OR 'a'<=I<='f') %AND T<9 ! %IF T=9 %THEN SS=S %AND S=0 S=S<<4+I&15+9*I>>6 %REPEAT ! %IF T>8 %START ! Z=4*(T-8) ! S=S!(SS<>(32-Z) ! CPREC=6 ! %FINISH IEND: ! %IF CPREC=6 %THEN TOAR4(R,SS) %AND R=R+4 %IF CPREC=5 %AND 0<=S<=X'7FFF' %START CPREC=4; TOAR2(R,S); R=R+2 %FINISH %ELSE TOAR4(R,S) %AND R=R+4 HIT=1 %UNLESS MODE#0 %AND CPREC=6 A(RR)=CPREC<<4!CTYPE %RETURN RHEX: ! REAL HEX CONSTANTS T=0 %CYCLE I=CC(Q); Q=Q+1 %IF T&7=0 %AND T#0 %START TOAR4(R,S); R=R+4; S=0 %FINISH %EXIT %IF I=M''''; T=T+1 %RETURN %UNLESS '0'<=I<='9' %OR 'A'<=I<='F' %OR 'a'<=I<='f' S=S<<4+I&15+9*I>>6 %REPEAT ! %RETURN %UNLESS T=8 %OR T=16 %OR T=32 ! %IF T=32 %THEN CPREC=7 %ELSE CPREC=4+T//8 %RETURN %UNLESS T=8 %OR T=16 CPREC=4+T//8 A(RR)=CPREC<<4!2 HIT=1; %RETURN OCT: ! OCTAL CONSTANTS T=0 %CYCLE I=CC(Q); Q=Q+1; T=T+1 %EXIT %IF I=M'''' %RETURN %UNLESS '0'<=I<='7' %AND T<12 S=S<<3!(I&7) %REPEAT ->IEND MULT: T=0; ! MULTIPLE CONSTANTS %CYCLE I=CC(Q); Q=Q+1; T=T+1 %IF I=M'''' %THEN %START %IF CC(Q)#M'''' %THEN %EXIT %ELSE Q=Q+1 %FINISH %RETURN %IF T>=5 %IF EBCDIC#0 %THEN I=ITOETAB(I) S=S<<8!I %REPEAT ->IEND BIN: T=0; ! BINARY CONST %CYCLE I=CC(Q); Q=Q+1; T=T+1 %EXIT %IF I=M'''' %RETURN %UNLESS '0'<=I<='1' %AND T<33 S=S<<1!I&1 %REPEAT ->IEND RADIX: ! BASE_VALUE CONSTANTS T=0; RADIXV=0 Q=Q+1 %CYCLE I=CC(Q) %EXIT %UNLESS '0'<=I<='9' %OR 'A'<=I<='Z' %IF I<='9' %THEN I=I-'0' %ELSE I=I-('A'-10) %EXIT %IF I>=S; ! MUST BE LESS THAN BASE T=T+1; Q=Q+1 RADIXV=RADIXV*S+I %REPEAT %RETURN %IF T=0; ! NO VALID DIGIGITS ! SS<-RADIXV>>32 S<-RADIXV CTYPE=1 ! %IF SS#0 %THEN CPREC=6 ->IEND N: ! CONSTANT STARTS WITH DIGIT I=CC(Q) %UNTIL IM'9' %CYCLE CVALUE=TEN*CVALUE+(I&15) Q=Q+1; I=CC(Q); ! ONTO NEXT CHAR %REPEAT %IF I='_' %AND CVALUE<33 %THEN S=INT(CVALUE) %AND ->RADIX ->ALPHA %UNLESS MODE=0 %AND I='.' DOT: Q=Q+1; X=TEN; I=CC(Q) DOTSEEN=1; ! CONSTANT HAS DECIMAL POINT %WHILE M'0'<=I<=M'9' %CYCLE CVALUE=CVALUE+(I&15)/X X=TEN*X; Q=Q+1; I=CC(Q) %REPEAT ALPHA: ! TEST FOR EXPONENT %IF MODE=0 %AND CC(Q)='@' %THEN %START Q=Q+1; X=CVALUE Z=1; I=CC(Q) %IF I='-' %THEN Z=-1 %IF I='+' %OR I='-' %THEN Q=Q+1 CONST(2) %IF HIT=0 %THEN %RETURN HIT=0 R=RR+1 %IF A(R)>>4#4 %THEN %RETURN; ! EXPONENT MUST BE HALFINTEGER S=FROM AR2(R+1)*Z %IF S=-99 %THEN CVALUE=0 %ELSE %START %WHILE S>0 %CYCLE S=S-1 CVALUE=CVALUE*TEN %REPEAT %WHILE S<0 %AND CVALUE#0 %CYCLE S=S+1 CVALUE=CVALUE/TEN %REPEAT %FINISH %FINISH ! SEE IF IT IS INTEGER %IF FS='D' %THEN %START I=CC(Q) %IF I='''' %THEN Q=Q+1 %ELSE %RETURN DOTSEEN=1; ! ENSURE NOT TAKEN AS INTEGER %FINISH %IF DOTSEEN=1 %OR CVALUE>IMAX %OR FRACPT(CVALUE)#0 %C %THEN CTYPE=2 %ELSE CTYPE=1 %AND S=INT(CVALUE) %IF CTYPE=1 %THEN ->IEND %IF CPREC=5 %THEN CPREC=6; ! NO 32 BIT REAL CONSTS %IF CPREC=6 %THEN %START %FINISH TOAR8(R,CVALUE); R=R+8 %IF CPREC=7 %THEN TOAR8(R,LONGREAL(ADDR(CVALUE)+8)) %C %AND R=R+8 A(RR)=CPREC<<4+CTYPE HIT=1 %END %ROUTINE TEXTTEXT(%INTEGER EBCDIC) !*********************************************************************** !* PROCESSES TEXT BETWEEN DOUBLE QUOTES AND STORES IN ISO OR EBCDIC * !*********************************************************************** %INTEGER J, II %CONSTINTEGER QU='"' I=CC(Q) S=R+4; R=R+5; HIT=0 %RETURN %UNLESS I=QU; ! FAIL UNLESS INITIAL QUOTE Q=Q+1 %CYCLE I=CC(Q) %IF EBCDIC#0 %THEN II=ITOETAB(I) %ELSE II=I A(R)=II; R=R+1 %IF I=QU %THEN %START Q=Q+1 %IF CC(Q)#QU %THEN %EXIT %FINISH %IF I=10 %THEN READLINE(1,QU) %ELSE Q=Q+1 FAULT(106,0,0) %IF R-S>256 %REPEAT R=R-1; J=R-S-1 A(S)=J; HIT=1 %END BEND:%END; ! OF BLOCK CONTAINING PASS 1 %IF LEVEL>1 %THEN FAULT(15, LEVEL-1, 0) I=0 NEWLINE %IF FAULTY=0 %THEN %START WRITE(LINE, 5) PRINT STRING(" LINES ANALYSED IN") WRITE(INT(1000*(CPUTIME-CTIME)),5) PRINT STRING(" MSECS - SIZE=") WRITE(P1SIZE, 5) %IF LINE>90 %AND LIST#0 %THEN NEWPAGE %ELSE NEWLINE %FINISH %ELSE %START PRINTSTRING("CODE GENERATION NOT ATTEMPTED ") COMREG(24)=8 COMREG(47)=FAULTY %STOP %FINISH %BEGIN !*********************************************************************** !* SECOND OR CODE GENERATING PASS * !*********************************************************************** %INTEGERARRAY REGISTER, GRUSE, GRAT, GRINF1, GRINF2, OLINK(0:MAXREG) %INTEGERARRAY DESADS(0:31) %INTEGERARRAY SET, RAL, FLAG, L, M, NMDECS, ONWORD, ONINF,%C JUMP, LABEL, JROUND, UNATT FORMATS, %C NAMES (0:MAXLEVELS) %INTEGERARRAY AVL WSP(0:4,0:MAXLEVELS) %INTEGERARRAYFORMAT CF(0:12*NNAMES) %INTEGERARRAYNAME CTABLE %EXTERNALROUTINESPEC CNOP(%INTEGER I, J) %EXTERNALROUTINESPEC PCONST(%INTEGER X) %EXTERNALROUTINESPEC PRR(%INTEGER OPCODE,R1,R2) %EXTERNALROUTINESPEC PRX(%INTEGER OPCODE,R1,R2,B,D) %EXTERNALROUTINESPEC PSI(%INTEGER OPCODE,I,B,D) %EXTERNALROUTINESPEC PSS(%INTEGER OPCODE,N,B,D,B,D) %EXTERNALROUTINESPEC PMVC(%INTEGER N,B,D,B,D) %ROUTINESPEC NOTE CREF(%INTEGER CA) %INTEGERFNSPEC SPECIAL CONSTS(%INTEGER WHICH) %ROUTINESPEC STORE CONST(%INTEGERNAME D,%INTEGER L,AD) %INTEGERFNSPEC WORD CONST(%INTEGER VALUE) %ROUTINESPEC DUMP CONSTS %EXTERNALROUTINESPEC PLANT(%INTEGER VALUE) %EXTERNALROUTINESPEC PLUG(%INTEGER I, J, K, BYTES) %EXTERNALROUTINESPEC PGLA(%INTEGER BDRY,L,AD) %EXTERNALROUTINESPEC GXREF(%STRING(31) NAME,%INTEGER MODE,XTRA,AT) %EXTERNALROUTINESPEC CXREF(%STRING(255) NAME, %INTEGER MODE,XTRA,%INTEGERNAME AT) %EXTERNALROUTINESPEC CODEOUT %ROUTINESPEC PROLOGUE %EXTERNALROUTINESPEC IMPEPILOGUE(%INTEGERNAME LEP,EEP,%ROUTINE POP) %ROUTINESPEC COMPILE A STMNT %ROUTINESPEC CSS(%INTEGER P) %ROUTINESPEC LOAD DATA %ROUTINESPEC ABORT !*DELSTART %ROUTINESPEC PRINT USE !*DELEND %CYCLE I=0,1,MAXREG REGISTER(I)=0; GRUSE(I)=0; GRINF1(I)=0; GRAT(I)=0 GRINF2(I)=0 %REPEAT REGISTER(WSPR)=-1 REGISTER(CODER)=-1 REGISTER(GLA)=-1 REGISTER(CTABLEREG)=-1 %CYCLE I=0, 1, MAXLEVELS SET(I)=0; RAL(I)=0 JUMP(I)=0; JROUND(I)=0 LABEL(I)=0; FLAG(I)=0; UNATT FORMATS(I)=0 L(I)=0; M(I)=0 ONWORD(I)=0; ONINF(I)=0 NAMES(I)=-1 %CYCLE J=0,1,4 AVL WSP(J,I)=0 %REPEAT %REPEAT CTABLE==ARRAY(ADDR(ASLIST(1)),CF) CONST HOLE=0 LINE=0 PROLOGUE NEXTP=1; LEVEL=1; STMTS=0 RLEVEL=0; RBASE=11 %WHILE A(NEXTP+3)!A(NEXTP+4)#0 %CYCLE COMPILE A STMNT %REPEAT LINE=99999 IMPEPILOGUE(LOGEPDISP,EXPEPDISP,POP) LOAD DATA %STOP %ROUTINE COMPILE A STMNT %INTEGER I !*DELSTART %IF DCOMP#0 %AND CA>CABUF %THEN CODEOUT %AND PRINTUSE !*DELEND I=NEXTP NEXTP=NEXTP+A(NEXTP)<<16+A(NEXTP+1)<<8+A(NEXTP+2) LINE=A(I+3)<<8+A(I+4) STMTS=STMTS+1 CSS(I+5) ! %CYCLE I=0,1,4 ! ABORT %IF REGISTER(I)#0 ! %REPEAT ! CHECK ASL %IF LINE&7=0 %END %ROUTINE LOAD DATA !*********************************************************************** !* PASS INFORMATION TO LPUT TO ENABLE IT TO GENERATE THE * !* LOADER DATA AND COMPLETE THE PROGRAM FILE. * !*********************************************************************** %INTEGER LANGFLAG,PARMS GLACA=(GLACA+7)&(-8) USTPTR=(USTPTR+7)&(-8) CODE OUT CNOP(0, 8) FIXED GLA(6)=CA; ! CONST TABLE ADDRESS DUMP CONSTS %IF PARMTRACE=0 %THEN LANGFLAG=6 %ELSE LANGFLAG=1 LANGFLAG=LANGFLAG<<24 PARMS=(PARMDIAG<<1!PARMLINE)<<1!PARMTRACE FIXED GLA(4)=LANGFLAG!RELEASE<<16!(CPRMODE&1)<<8!PARMS;! LANG RLSE & MAINPROG I=GLACA-GLACABUF %IF INHCODE=0 %THEN %START LPUT(2, I, GLACABUF, ADDR(GLABUF(0))) %UNLESS I=0 ! BACK OF GLAP LPUT(2, FIXEDGLALEN, 0, ADDR(FIXED GLA(0)));! FRONT OF GLAP LPUT(19,2,8,5); ! RELOCATE GLA ST ADDRESS LPUT(19,2,12,4); ! RELOCATE CODE ST ADDRESS LPUT(19,2,24,1); ! RELOCATE CONSTANT TABLE I=X'E2E2E2E2' LPUT(4, 4, SSTL, ADDR(I)) ! %FINISH SSTL=(SSTL+11)&(-8) PRINTSTRING(" CODE") WRITE(CA, 6); PRINTSTRING(" BYTES GLAP") WRITE(GLACA, 3); PRINTSTRING("+") WRITE(USTPTR, 1); PRINTSTRING(" BYTES DIAG TABLES") WRITE(SSTL, 3); PRINTSTRING(" BYTES TOTAL") REGISTER(0)=CA; REGISTER(1)=GLACA REGISTER(2)=0 REGISTER(3)=SSTL REGISTER(4)=USTPTR K=CA+GLACA+SSTL+USTPTR; REGISTER(5)=K WRITE(K, 5); PRINTSTRING(" BYTES ") %IF FAULTY=0 %THEN %START WRITE(STMTS, 7); PRINTSTRING(" STATEMENTS COMPILED IN") WRITE(INT(1000*(CPUTIME-CTIME)),5) PRINTSTRING(" MSECS") COMREG(47)=STMTS; ! NO OF STMTS FOR COMPER %FINISH %ELSE %START PRINTSTRING("PROGRAM CONTAINS"); WRITE(FAULTY, 2) PRINTSTRING(" FAULT"); PRINTSYMBOL('S') %IF FAULTY>1 COMREG(47)=FAULTY; ! NO OF FAULTS FOR COMPER %FINISH NEWLINES(2) I=0; I=8 %IF FAULTY#0 COMREG(24)=I %IF INHCODE=0 %THEN LPUT(7, 24, 0, ADDR(REGISTER(0))) ! SUMMARY INFO..REGISTER AS BUF PPROFILE %STOP %END %ROUTINE NOTE CREF(%INTEGER CA) !*********************************************************************** !* NOTE THAT A (PC+N) INSTRUCTION HAS N RELATIVE TO CONST TABLE * !* NOT REATIVE TO CODE. REMEMBER THE ADDRESS OF THE INSTRUCTION * !* SO THAT AN LPUT(18) CORRECTION CAN BE MADE AT END OF COMPILATION * !*********************************************************************** %RECORD(LISTF)%NAME CELL CELL==ASLIST(CREFHEAD) %IF CREFHEAD=0 %OR CELL_S3#0 %THEN %C PUSH(CREFHEAD,CA,0,0) %AND %RETURN %IF CELL_S2=0 %THEN CELL_S2=CA %ELSE CELL_S3=CA %END %INTEGERFN SPECIAL CONSTS(%INTEGER WHICH) !*********************************************************************** !* PUTS CERTAIN SPECIAL CONSTANTS INTO THE CONSTANT TABLE ON * !* DEMAND AND REMEMBERS THEIR POSN TO AVOID SEARCHONG * !*********************************************************************** %CONSTINTEGERARRAY SCS(0:7) = X'40800000',0, X'41100000',0, 1,0, X'4F000000',0; %INTEGER K K=DESADS(WHICH) %RESULT=K %UNLESS K=0 STORE CONST(K,8,ADDR(SCS(2*WHICH))) DESADS(WHICH)=K %RESULT=K %END %INTEGERFN WORD CONST(%INTEGER VALUE) !*********************************************************************** !* SIMPLE INTERFACE TO STORE CONST FOR 32 BIT CONSTS * !*********************************************************************** %INTEGER K STORE CONST(K,4,ADDR(VALUE)) %RESULT=K %END %ROUTINE STORE CONST(%INTEGERNAME D, %INTEGER L, AD) !*********************************************************************** !* PUT THE CONSTANT VAL OF LENGTH 'L' INTO THE CONSTANT TABLE * !* A CHECK IS MADE TO SEE IF THE CONSTANT HAS ALREADY * !* BEEN INSERTED IN WHICH CASE THE OLD COPY IS REUSED * !*********************************************************************** %INTEGER I, J, K, C1, C2, C3, C4, LP LP=L//4; C2=0; C3=0; C4=0 %CYCLE I=0,1,L-1 BYTEINTEGER(ADDR(C1)+I)=BYTEINTEGER(AD+I) %REPEAT K=CONST BTM; ! AFTER STRINGS IN CTABLE %IF L=4 %THEN %START %WHILE K=K+LP) %START %IF L=8 %OR (CTABLE(K+2)=C3 %C %AND CTABLE(K+3)=C4) %THEN D=4*K %AND %RETURN %FINISH K=K+2 %REPEAT %FINISH %IF L=4 %AND CONSTHOLE#0 %START CTABLE(CONSTHOLE)=C1 D=4*CONSTHOLE CONSTHOLE=0 %RETURN %FINISH %IF L>4 %AND CONST PTR&1#0 %C %THEN CONSTHOLE=CONST PTR %AND CONSTPTR=CONST PTR+1 D=4*CONST PTR CTABLE(CONSTPTR)=C1 CTABLE(CONSTPTR+1)=C2 %IF L=16 %THEN CTABLE(CONSTPTR+2)=C3 %C %AND CTABLE(CONSTPTR+3)=C4 CONST PTR=CONST PTR+LP %IF CONST PTR>CONST LIMIT %THEN FAULT(102, WKFILEK,0) %END %ROUTINE GET ENV(%INTEGERNAME HEAD) !*********************************************************************** !* SAVE A COPY OF THE REGISTER STATE FOR FUTURE REFERENCE * !*********************************************************************** %INTEGER I, USE %CYCLE I=0, 1, MAXREG USE=GRUSE(I)&X'FF'; ! MAIN USE ONLY PUSH(HEAD, GRINF1(I), GRAT(I), I<<8!USE) %IF USE#0 %REPEAT %END %ROUTINE RESTORE(%INTEGER HEAD) !*********************************************************************** !* RESET THE REGISTERS TO ENVIRONMENT IN LIST HEADED BY 'HEAD' * !*********************************************************************** %INTEGER I, R, USE, INF, AT %CYCLE I=0, 1, MAXREG %IF REGISTER(I)>=0 %THEN GRUSE(I)=0 %AND GRINF1(I)=0 %REPEAT %WHILE HEAD#0 %CYCLE POP(HEAD, INF, AT, I) R=I>>8; USE=I&255 %IF REGISTER(R)>=0 %THEN GRUSE(R)=USE %AND GRINF1(R)=INF GRAT(R)=AT %REPEAT %END %ROUTINE RELOCATE(%INTEGER GLARAD,VALUE,AREA) !*********************************************************************** !* PLANTS A WORD IN THE GLA (IF GLARAD<0) AND ARRANGES TO * !* RELOCATE IT RELATIVE TO AN AREA(CODE=1,GLA=2,CST=4,GST=5 * !*********************************************************************** %IF GLARAD<0 %THEN PGLA(4,4,ADDR(VALUE)) %AND GLARAD=GLACA-4 LPUT(19,2,GLARAD,AREA) %END %ROUTINE DEFINE EP(%STRING(255)NAME, %INTEGER ADR,AT,MAIN) !*********************************************************************** !* TO DEFINE AN EP SIMPLY TELL LPUT THE EP ADDRESS RELATIVE TO THE * !* START IF CODE. THIS IS STORED IN THE LOAD DATA. AT LOAD TIME * !* THE THREE WORDS IN THE GLA OF THE CALLING ROUTINE ARE FILLED * !* WITH START IF CODE,START OF GLA AND EP ADDRESS RESPECTIVELY * !* (DOCUMENTATION OF OBJECT FORMAT & LPUT DIFFER HEREABOUTS!) * !*********************************************************************** LPUT(11,MAIN<<31!1,AT,ADDR(NAME)) %END %ROUTINE PROLOGUE !*********************************************************************** !* GENERATES THE SUBROUTINE THAT ALWAYS ARE REQUIRED ONTO THE * !* FRONT OF THE OBJECT PROGRAM WHERE THEY ARE DIRECTLY ADDRESABLE* !*********************************************************************** %INTEGERFNSPEC STRINGIN(%INTEGER POS) %ROUTINESPEC ERR EXIT(%INTEGER A, B, C) %INTEGER I, K, L, STCA I=X'C2C2C2C2' LPUT(4,4,0,ADDR(I)) SSTL=4 %CYCLE I=0, 1, 31 PLABS(I)=0; PLINK(I)=0 DESADS(I)=0 %REPEAT ! ! GENERATE THE FIXED-FLOAT CONSTANTS THAT MAY BE NEEDED ! PLABS(1)=CA %CYCLE I=0, 1, 1 PCONST(UNASSPAT) %REPEAT PCONST(X'80000000') PCONST(255); ! FOR MASKING BYTES MAX4KMULT=R//4096+3 %IF MAX4KMULT<7 %THEN MAX4KMULT=7 %CYCLE I=0,1,MAX4KMULT PCONST(4096*I) %REPEAT ! ! GENERATE THE RUN TIME ERROR ROUTINE :- ! MDIAGS FOR NR IS %ROUTINE MDIAGS(%INT PC,LNB,ERROR,XTRA) ! PC IS A DUMMY (SEG FIELD ONLY USED) EXCEPT AFTER CONTINGENCY ! ON ENTRY TO THIS SUBROUTINE ERROR & XTRA ARE IN GRS 0&1 ! ENTRY HAS BEEN BY BAL LINKREG SO RETURN ADDRESS IS AVAILABLE ! ! ST 15,64(11) ! STM 0,1,72(11) ! LR 0,10 ! LR 1,9 ! BAL LINKREG,CHECK IF R9 A VALID LNB ! LR 1,8 ! BAL LINKREG,CHECK DITTO FOR R8 ! LR 1,7 ! BAL LINKREG,CHECK DITTO ! LR 1,6 ! BAL LINKREG,CHECK DITTO ! LR 1,5 ! BAL LINKREG,CHECK DITTO !CHFAIL ST 0,68(11) ! STM 4,14,16(11) ! LM CODER,EPREG,40(13) MDIAG ENTRY POINT ! L 15,64(11) ! BCR 15,EPREG !CHECK CR 1,11 ! BC 2,CHFAIL ! CR 1,0 ! BC 12,CHKAIL ! C 1,44(1) CHECK STORE STACK POINTER ! BC 7,CHFAIL ! LR 0,1 ! BCR 15,LINKREG ! PLABS(2)=CA PRX(ST,15,0,11,64) PRX(STM,0,1,11,72) PRR(LR,0,10) %CYCLE I=9,-1,5 PRR(LR,1,I) PRX(BAL,LINKREG,0,CODER,CA+22+6*(I-5)) %REPEAT K=CA PRX(ST,0,0,11,68) PRX(STM,4,14,11,16) PRX(LM,CODER,EPREG,GLA,40) PRX(LGR,15,0,11,64) PRR(BCR,15,EPREG) PRR(CR,1,11) PRX(BC,2,0,CODER,K) PRR(CR,1,0) PRX(BC,12,0,CODER,K) PRX(COMP,1,0,1,44) PRX(BC,7,0,CODER,K) PRR(LR,0,1) PRR(BCR,15,LINKREG) ! ! SUBROUTINE TO CALL DEBUG ROUTINE(S#IMPMON) LINE NO IN GR0 ! ! STM 4,0,16(11) ! LM CODER,EPREG,EPDIST ! BCR 15,LINKREG RETURN ADDR ALREADY IN GR15 ! %IF PARMDBUG#0 %THEN %START PLABS(3)=CA CXREF("S#IMPMON",PARMDYNAMIC,2,K) PRX(STM,4,0,16,11) PRX(LM,CODER,EPREG,GLA,K) PRR(BCR,15,LINKREG) %FINISH ! ! SUBROUTINE TO ADVANCE STACK FRONT BY GR0 WORDS AND FILL WITH UNASSIGNED ! GR1 HAS BYTES OF PARAMETERS WHICH MUST NOT BE OVERWRITTEN ! ! ! AR 1,11 BYTE TO START CLEARING ! AR 11,0 CLAIM SPACE !AGN CR 1,11 ! BCR 10,LINKREG ! MVI 0(1),UNASSPAT ! MVC 1(255,1),0(1) ! LA 1,256(1) ! BC 15,AGN ! %IF PARMCHK=1 %THEN %START; ! ONLY REQUIRED WITH CHKING PLABS(4)=CA PRR(AR,1,WSPR) PRR(AR,WSPR,0) PRR(CR,1,WSPR) PRR(BCR,10,LINKREG) PSI(MVI,UNASSPAT&255,1,0) PSS(MVC,255,1,1,1,0) PRX(LA,1,0,1,256) PRX(BC,15,0,CODER,PLABS(4)+4) %FINISH ! ! SOME ERROR ROUTINES ! ERR EXIT(5, X'801', 0) %IF PARMOPT#0; ! UNASSIGNED VARIABLE ERR EXIT(6, X'802', 0); ! SWITCH LABEL UNSET ERR EXIT(7, X'505', 1); ! ILLEGEAL EXPONENTIATION ERR EXIT(8,X'201', 0) %IF PARMOPT#0; ! EXCESS BLOCKS ERR EXIT(9, X'601', 0); ! CAPACITY EXCEEDED ERR EXIT(10,21, 0) ; ! NO RESULT ERR EXIT(11,X'501', 0) %IF PARMOPT#0; ! CYCLE NOT VALID ERR EXIT(12,X'701',0); ! RES FAILS ERR EXIT(13,X'602',0) %IF PARMOPT#0; ! ARRAY BOUND FAULT ! ! PUT THE STRINGS ONTO THE FRONT OF CONSTANT AREA ! CTABLE(0)=0 STCA=1; L=ADDR(CTABLE(0)) CONST PTR=0; ! IN CASE NO STRINGS %WHILE STRLINK#0 %CYCLE I=STRLINK; STRLINK=FROM AR4(I) TO AR4(I,STRINGIN(I+4)+CA); ! CHANGE LINK TO STRING ADDR %REPEAT %CYCLE I=0,1,CONST PTR PCONST(CTABLE(I)) %REPEAT CONST PTR=0 CONST BTM=CONST PTR %IF PARMOPT#0 %THEN CTABLE(CONST PTR)=M'IDIA' %AND %C CONST PTR=CONST PTR+1 GXREF(MDEP,PARMDYNAMIC,2,40) GXREF(STACKTOPEP,2,4,28); ! FOR STACK TOP CHECKING %IF PARMPROF#0 %THEN %START; ! ALLOCATE PROFILE COUNT AREA I=LINE PARMPROF=GLACA PGLA(4,4,ADDR(I)) K=0 %CYCLE I=0,1,LINE PGLA(4,4,ADDR(K)) %REPEAT LINE=0 %FINISH LEVEL=1 %CYCLE I=0,1,31 %IF PLINK(I)#0 %THEN CLEAR LIST(PLINK(I)) %REPEAT %RETURN %INTEGERFN STRINGIN(%INTEGER POS) !*********************************************************************** !* PUT A STRING INTO THE CONSTANT AREA CHECKING FOR DUPLICATES * !*********************************************************************** %INTEGER J,K,IND,HD %RECORD(LISTF)%NAME CELL K=A(POS) %IF K=0 %THEN %RESULT=0 IND=K&31; HD=PLINK(IND) %WHILE HD#0 %CYCLE CELL==ASLIST(HD) %IF CELL_S1=K %AND STRING(L+CELL_S2)=STRING(ADDR(A(POS))) %C %THEN %RESULT=CELL_S2 HD=CELL_LINK %REPEAT HD=STCA BYTEINTEGER(L+STCA)=K; STCA=STCA+1 %CYCLE J=POS+1,1,POS+K BYTE INTEGER(L+STCA)=A(J) STCA=STCA+1 %REPEAT CONST PTR=((STCA+7)&(-8))>>2 PUSH(PLINK(IND),K,HD,0) %RESULT=HD %END %ROUTINE ERR EXIT(%INTEGER LAB, ERRNO, MODE) !*********************************************************************** !* MODE=0 FOR DUMMY(ZERO) XTRA - MODE=1 XTRA IN GR1 * !*********************************************************************** PLABS(LAB)=CA %IF MODE=0 %THEN PRR(SR,0,0) PRX(LA,0,0,0,ERRNO) PRX(BC,15,0,CODER,PLABS(2)) %END %END %ROUTINE CSS(%INTEGER P) %RECORDFORMAT RD(%BYTEINTEGER UPTYPE,PTYPE,XB,FLAG,%C %INTEGER D,XTRA) %ROUTINESPEC MERGE INFO %ROUTINESPEC REDUCE ENV(%INTEGERNAME HEAD) %ROUTINESPEC ENTER JUMP(%INTEGER MASK,STAD,FLAG) %INTEGERFNSPEC ENTER LAB(%INTEGER M,FLAG) %ROUTINESPEC REMOVE LAB(%INTEGER LAB) %ROUTINESPEC CEND(%INTEGER KKK) %INTEGERFNSPEC CCOND(%INTEGER CTO,A,B,JFLAGS) %ROUTINESPEC CHECK STOF %INTEGERFNSPEC REVERSE(%INTEGER MASK) %ROUTINESPEC SET LOCAL BASE(%INTEGERNAME B,A) %ROUTINESPEC SET LINE %ROUTINESPEC CUI(%INTEGER CODE) %ROUTINESPEC ASSIGN(%INTEGER A,B) %ROUTINESPEC CSTART(%INTEGER CCRES,MODE) %INTEGERFNSPEC CHECKBLOCK(%INTEGER P) %ROUTINESPEC CCYCBODY(%INTEGER UA,ELAB,CLAB) %ROUTINESPEC CLOOP(%INTEGER ALT,MARKC,MARKUI) %ROUTINESPEC CIFTHEN(%INTEGER MARKIU,MARKC,MARKUI,MARKE,MARKR,SKIP) %ROUTINESPEC CREATE AH(%INTEGER MODE,REG,BS,DP) %ROUTINESPEC TORP(%INTEGERNAME HEAD,BOT,NOPS) %INTEGERFNSPEC INTEXP(%INTEGERNAME VALUE) %INTEGERFNSPEC CONSTEXP(%INTEGER PRECTYPE) %ROUTINESPEC CSEXP(%INTEGER REG,MODE) %ROUTINESPEC CSTREXP(%INTEGER A,B) %ROUTINESPEC CRES(%INTEGER LAB) %ROUTINESPEC EXPOP(%INTEGER A,B,C,D) %ROUTINESPEC TEST APP(%INTEGERNAME NUM) %ROUTINESPEC SKIP EXP %ROUTINESPEC SKIP APP %ROUTINESPEC NO APP %INTEGERFNSPEC DOPE VECTOR(%INTEGER A,B,MODE,ID,%INTEGERNAME C,D) %ROUTINESPEC DECLARE ARRAYS(%INTEGER A,B) %ROUTINESPEC DECLARE SCALARS(%INTEGER A,B) %ROUTINESPEC MAKE DECS(%INTEGER Q) %ROUTINESPEC CRSPEC(%INTEGER M) %INTEGERFNSPEC SET SWITCHLAB(%INTEGER HEAD,LAB,FNAME,BIT) %ROUTINESPEC CFPLIST(%INTEGERNAME A,B) %ROUTINESPEC CFPDEL %ROUTINESPEC CLT %ROUTINESPEC CQN(%INTEGER P) %ROUTINESPEC GET WSP(%INTEGERNAME PLACE,%INTEGER SIZE) %ROUTINESPEC RETURN WSP(%INTEGER PLACE,SIZE) %INTEGERFNSPEC TSEXP(%INTEGERNAME VALUE) %ROUTINESPEC MOVER(%INTEGER REG,N) %ROUTINESPEC CRCALL(%INTEGER RTNAME) %ROUTINESPEC NAMEOP(%INTEGER Z,REG,SIZE,NAMEP) %ROUTINESPEC CNAME(%INTEGER Z,REG) %ROUTINESPEC CANAME(%INTEGER Z,BS,DP) %ROUTINESPEC CSNAME(%INTEGER Z,REG) %ROUTINESPEC TEST ASS(%INTEGER REG,TYPE,SIZE) %ROUTINESPEC COPY TAG(%INTEGER KK) %ROUTINESPEC REDUCE TAG %ROUTINESPEC RT JUMP(%INTEGER CODE,REG,%INTEGERNAME L) %ROUTINESPEC STORE TAG(%INTEGER KK,SLINK) %ROUTINESPEC UNPACK %ROUTINESPEC PACK(%INTEGERNAME PTYPE) %ROUTINESPEC DIAG POINTER(%INTEGER LEVEL) %ROUTINESPEC RDISPLAY(%INTEGER KK) %ROUTINESPEC RHEAD(%INTEGER KK) %ROUTINESPEC EVEN ALIGN %ROUTINESPEC PPJ(%INTEGER MASK,N,SAVE) %INTEGERFNSPEC CFORMATREF %ROUTINESPEC CRFORMAT(%INTEGERNAME OPHEAD,OPBOT,NLIST,MRL,%INTEGER INIT) %INTEGERFNSPEC DISPLACEMENT(%INTEGER LINK) %INTEGERFNSPEC COPY RECORD TAG(%INTEGERNAME SUBS) %ROUTINESPEC SAVE IRS(%INTEGER UPPER) %ROUTINESPEC FORGET(%INTEGER REG) %ROUTINESPEC FREE AND FORGET(%INTEGER REG) %ROUTINESPEC FORGETM(%INTEGER UPPER) %ROUTINESPEC SET USE(%INTEGER R,U,I) %ROUTINESPEC FINDREG(%INTEGER CONTROL,%INTEGERNAME REG) %ROUTINESPEC CLAIM(%INTEGER CONTROL,%INTEGERNAME REG) %ROUTINESPEC CLAIM PAIR(%INTEGERNAME PAIR) %ROUTINESPEC CLAIM THIS REG(%INTEGER REG) %ROUTINESPEC FIND USE(%INTEGERNAME REG,%INTEGER TYPE,USE,INF) %ROUTINESPEC FINDSEQ(%INTEGERNAME ONE,TWO) %ROUTINESPEC ADJUST INDEX(%INTEGER MODE,%INTEGERNAME INDEX,DISP) %ROUTINESPEC BULKM(%INTEGER M,L,B1,D1,B2,D2) %ROUTINESPEC DUMPRX(%INTEGER CODE,REG,X,L,DIS) %ROUTINESPEC DUMPSI(%INTEGER CODE,L,B,D) %ROUTINESPEC DUMPM(%INTEGER CODE,R1,R2,B,D) %ROUTINESPEC DUMPSS(%INTEGER CODE,L,B1,D1,B2,D2) %INTEGERFNSPEC EXECUTESS(%INTEGER CODE,B1,D1,B2,D2) %ROUTINESPEC BOOT OUT(%INTEGER REG) %INTEGERFNSPEC RELOAD(%RECORD(RD)%NAME R) %ROUTINESPEC CHANGE RD(%INTEGER REG) %ROUTINESPEC REMEMBER %ROUTINESPEC NOTE ASSMENT(%INTEGER REG,ASSOP,VAR) %SWITCH SW(1:24) %INTEGER SNDISP,ACC,K,KFORM,STNAME,MIDCELL %INTEGER TCELL,NUMMOD,JJ,JJJ,KK,QQ,MARKER,REPORTUI,XDISP,MASK, %C BASE,AREA,ACCESS,INDEX,DISP,EXTRN, CURR INST,VALUE,STRINGL, %C PTYPE,I,J,OLDI,USEBITS,TWSPHEAD,STRFNRES,BML,DML, %C MARKIU,MARKUI,MARKC,MARKE,MARKR,INAFORMAT %INTEGER LITL,ROUT,NAM,ARR,PREC,TYPE %OWNINTEGER FPTR %RECORD(RD) EXPOPND; ! RESULT RECORD FOR EXPOP %INTEGERARRAY SGRUSE,SGRINF(0:MAXREG) CURR INST=0; INAFORMAT=0 TWSPHEAD=0 ->SW(A(P)) SW(13): ! INCLUDE SOMETHING SW(24): ! REDUNDANT SEP SW(2): ! CSSEXIT: LAST INST=CURR INST %WHILE TWSPHEAD#0 %CYCLE POP(TWSPHEAD,JJ,KK,QQ) RETURN WSP(JJ,KK) %REPEAT %RETURN SW(1): !(UI)(S) FAULT(57,0,0) %UNLESS LEVEL>=2 MARKER=P+1+A(P+1)<<8+A(P+2) P=P+3 ->LABFND %IF A(MARKER)=1 %IF A(MARKER)=2 %THEN SET LINE %AND CUI(0) %AND ->CSSEXIT MARKE=0; MARKR=0 MARKUI=P; MARKIU=MARKER+1 MARKC=MARKIU+1 %IF A(MARKER)=3 %THEN CIFTHEN(MARKIU,MARKC,MARKUI,0,0,NO) %C %AND ->CSSEXIT CLOOP(A(MARKIU),MARKC+2,MARKUI) ->CSSEXIT LABFND: OLDLINE=0 ->SWITCH %UNLESS A(P)=1 %AND A(P+5)=2; ! 1ST OF UI AND NO APP ->SWITCH %UNLESS A(P+6)=2 %AND A(P+7)=2;! NO ENAMSE OR ASSNMNT JJ=ENTER LAB(FROM AR2(P+3),0); ->CSSEXIT SW(5): ! %CYCLE FAULT(57,0,0) %UNLESS LEVEL>=2 %IF A(P+5)=2 %THEN %START; ! OPEN CYCLE CLOOP(0,P+1,P+1) %FINISH %ELSE %START SET LINE CLOOP(6,P+6,P+1) %FINISH ->CSSEXIT ! SW(6): ! REPEAT ->CSSEXIT SW(22): ! '%CONTROL' (CONST) J=FROM AR4(P+2) CODEOUT DCOMP=J>>28; ->CSSEXIT ! SW(3): ! (%IU)(COND)%THEN(UI)(ELSE') MARKIU=P+1; MARKC=MARKIU+3 MARKR=P+2+A(P+2)<<8+A(P+3); ! ! FROMAR2(P+2) MARKE=0 %IF A(MARKR)=3 %THEN %START MARKE=MARKR+1+FROMAR2(MARKR+1) MARKUI=MARKR+3 %FINISH CIFTHEN(MARKIU,MARKC,MARKUI,MARKE,MARKR,NO) ->CSSEXIT SW(4): ! '%FINISH(ELSE')(S) ->CSSEXIT SWITCH: %BEGIN; ! SWITCH LABEL %INTEGER NAPS,FNAME FNAME=FROM AR2(P+3) %UNLESS A(P)=1 %AND A(P+5)=1 %THEN FAULT(5,0,FNAME) %AND ->BEND ! 1ST OF UI + APP P=P+3; TEST APP(NAPS) P=P+6 %UNLESS INTEXP(JJ)=0 %THEN FAULT(41,0,0) %AND ->BEND ! UNLESS EXPRESSION EVALUATES AND %UNLESS NAPS=1 %THEN FAULT(21,NAPS-1,FNAME) %AND ->BEND ! NO REST OF APP %UNLESS A(P+1)=2=A(P+2) %THEN FAULT(5,0,FNAME) %AND ->BEND ! NO ENAME OR REST OF ASSIGMENT COPY TAG(FNAME) %IF OLDI#LEVEL %OR TYPE#6 %THEN FAULT(4,0,FNAME) %AND ->BEND %IF SET SWITCHLAB(K,JJ,FNAME,1)#0 %THEN FAULT(6,JJ,FNAME) BEND: %END; ->CSSEXIT SW(23): ! SWITCH(*): %BEGIN %INTEGER FNAME,LB,UB,JJ,RES FNAME=FROM AR2(P+1) COPY TAG (FNAME) %IF OLDI=LEVEL %AND TYPE=6 %START FROM123(K,JJ,LB,UB) %CYCLE JJ=LB,1,UB RES=SET SWITCHLAB(K,JJ,FNAME,0) %REPEAT %FINISH %ELSE FAULT(4,0,FNAME) %END; ->CSSEXIT ! SW(7): ! (%WU)(SC)(COND)(RESTOFWU) FAULT(57,0,0) %UNLESS LEVEL>=2 MARKIU=P+1; ! TO WHILE/UNTIL MARKC=MARKIU+3; ! TO (SC)(COND) CLOOP(A(MARKIU)+3,MARKC,MARKIU+1+FROMAR2(MARKIU+1)) ->CSSEXIT ! SW(8): ! SIMPLE DECLN FAULT(57,0,0) %UNLESS LEVEL>=2 FAULT(40,0,0) %IF NMDECS(LEVEL)&1#0 QQ=P; P=P+5 MARKER=P+FROMAR2(P); ! TO ALT OF DECLN P=P+2; ROUT=0; LITL=0 %IF A(MARKER)#1 %THEN %START; ! ARRAY DECLARATIONS CLT %IF TYPE=5 %AND (ACC<=0 %OR ACC>256) %THEN %C FAULT(70,ACC-1,0) %AND ACC=255 NAM=0 SET LINE QQ=2-A(P+1); P=P+2; ! QQ=1 FOR ARRAYFORMATS DECLARE ARRAYS(QQ,KFORM) %FINISH %ELSE %START %IF A(QQ+1)=128 %OR 1<CSSEXIT ! SW(9): ! %END %BEGIN %SWITCH S(1:5) -> S(A(P+1)) S(1): ! ENDOFPROGRAM S(2): ! ENDOFFILE %IF CPRMODE=0 %THEN CPRMODE=2 FAULT(15,LEVEL+CPRMODE-3,0) %UNLESS LEVEL+CPRMODE=3 CEND(CPRMODE) ->BEND S(3): ! ENDOFLIST LIST=0; ->BEND S(4): ! END %IF CPRMODE=1 %AND LEVEL=2 %THEN FAULT(14,0,0) %ELSE %C CEND(FLAG(LEVEL)) BEND: %END ->CSSEXIT ! SW(11): %BEGIN %INTEGER MARKER1,KK,KKK,PTR,PTYPEP,CNT,PP %RECORD(LISTF)%NAME LCELL %STRING(34)XNAME P=P+1; MARKER1=FROM AR2(P)+P; ! (SEX)(RT)(SPEC')(NAME)(FPP) AGN: Q=P; KK=FROM AR2(MARKER1+5); ! KK ON NAME EXTRN=A(P+2) LITL=EXTRN&3 %IF A(MARKER1)=1 %THEN %START;! P<%SPEC'>='%SPEC' P=P+3; CRSPEC(1-EXTRN>>2);! 0 FOR ROUTINESPEC ! 1 FOR EXTERNAL (ETC) SPEC ->BEND %FINISH COPY TAG(KK) XNAME<-STRING(DICTBASE+WORD(KK)) %IF EXTRN=1 %THEN XNAME<-"S#".XNAME %IF A(MARKER1+7)=1 %THEN XNAME<-STRING(ADDR(A(MARKER1+8))) %IF OLDI=LEVEL %THEN %START %IF CPRMODE=0 %THEN CPRMODE=2;! FLAG AS FILE OF ROUTINES ! %IF (CPRMODE=2 %AND LEVEL=1) %START %IF EXTRN=3 %THEN EXTRN=2 %IF EXTRN=4 %THEN XNAME="" JJ=MIDCELL; ! CODE DESCRIPTOR REL ADDR %IF EXTRN#4 %THEN USEBITS=2 %AND DEFINE EP(XNAME,CA,CA,0) %FINISH %ELSE %START; ! EXTERNALS IN PRGM OR WRNG LEVEL FAULT(56,0,KK) %UNLESS EXTRN=4; EXTRN=4 %FINISH %IF A(P+3)=1 %THEN KKK=LITL<<14!X'1000' %ELSE %START ROUT=1; P=P+4; ! FIGURE OUT PTYPE FOR FNS&MAPS CLT; ARR=0; NAM=0 %IF A(P)=2 %THEN NAM=2; ! SET NAME ARRAY BIT FOR MAPS PACK(KKK); ! AND STORE PTYPE IN KKK %FINISH %FINISH %UNLESS OLDI=LEVEL %AND J>=14 %AND PTYPE=KKK %START P=Q+3; CRSPEC(0); P=Q; ->AGN %FINISH PTYPE=PTYPE!(EXTRN&3)<<14; ! DEAL WITH %ROUTINESPEC FOLLOWED ! BY %EXTERNALROUTINE LCELL==ASLIST(TAGS(KK)) LCELL_S1=LCELL_S1&X'3FF0'!PTYPE<<16!USEBITS<<14 %IF J=14 %THEN LCELL_S2=0; ! NO OUTSTANDING JUMPS ! NEWPTYPE & SET J=0 JJ=K; PLABEL=PLABEL-1 %UNLESS COMPILER=1 %OR (CPRMODE=2 %AND LEVEL=1) %START %IF JROUND(LEVEL+1)=0 %START; ! NOT JUMP OUTSTANDING JROUND(LEVEL+1)=PLABEL ENTER JUMP(15,PLABEL,0) %FINISH %FINISH PTYPEP=PTYPE P=MARKER1+8 %IF A(P-1)=1 %THEN P=P+A(P)+1; ! SKIP OVER ALIASNAME RHEAD(KK) N=64; CNT=1 %WHILE A(P)=1 %CYCLE; ! WHILE SOME (MORE) FP PART PP=P+1+FROMAR2(P+1) P=P+3 CFPDEL PTR=P %UNTIL A(PTR-1)=2 %CYCLE; ! CYCLE DOWN NAMELIST %IF JJ#0 %THEN %START FROM12(JJ,J,JJJ); ! EXTRACT PTYPE XTRA INFO %UNLESS J>>16=PTYPE %AND(PTYPE#5 %OR JJJ>>16=ACC)%C %THEN FAULT(9,CNT,KK) %FINISH %ELSE FAULT(8,0,KK);! MORE FPS THAN IN SPEC PTR=PTR+3 CNT=CNT+1 MLINK(JJ) %REPEAT DECLARE SCALARS(0,KFORM) P=PP %REPEAT; ! UNTIL NO MORE FP-PART N=(N+3)&(-4); ! TO WORD BOUNDARY AFTER ALL SYSTEM ! STANDARD PARAMETERS HAVE BEEN DECLARED FAULT(10,0,KK) %UNLESS JJ=0 PTYPE=PTYPEP RDISPLAY(KK) MAKE DECS(MARKER1+1) BEND: %END; ->CSSEXIT ! SW(14): ! %BEGIN %BEGIN PTYPE=0 %IF LEVEL=1 %AND RLEVEL=0 %START %IF CPRMODE=0 %THEN %START DEFINE EP(MAINEP, CA, CA, 1) RLEVEL=1; RBASE=10 REGISTER(RBASE)=-1 GRUSE(RBASE)=NAMEBASE GRINF1(RBASE)=RLEVEL L(1)=0; M(1)=0 CPRMODE=1 N=64; NMAX=N FORGETM(14) ! ! THE CODE PLANTED IS AS FOLLOWS:- ! L CTABLEREG,24(GLA) LOAD POINTER TO CONSTANT ! PRX(LGR,CTABLEREG,0,GLA,24) ! ! SET THE PROGRAM MASK TO MASK OUT UNDERFLOW AND ALLOW ALL OTHER INTS ! ! LA 1,8 ! SLL 1,244 SET 8 IN TOP BYTE ! SPM 1 ALLOW OVERFLOW MASK OTHER ! PRX(LA,1,0,0,8) PRX(SLL,1,0,0,24) PRR(SPM,1,0) PTYPE=1 %FINISH %ELSE FAULT(58,0,0) %FINISH %ELSE SET LINE; ! SO 'ENTERED FROM LINE' IS OK RHEAD(-1) RDISPLAY(-1) MAKE DECS(P+1) %END ->CSSEXIT ! SW(15): ! '%ON'(EVENT')(N)(NLIST)'%START' FAULT(57,0,0) %UNLESS LEVEL>=2 FAULT(40,0,0) %IF NMDECS(LEVEL)&1#0 NMDECS(LEVEL)=NMDECS(LEVEL)!X'11';! NO MORE DECS AND IN ONCOND PRR(BALR,0,0); ! GET PROGRAM MASK DUMPRX(ST,0,0,RBASE,N+8); ! AND SAVE IT PLABEL=PLABEL-1 JJJ=PLABEL ENTER JUMP(15,JJJ,B'10'); ! JUMP ROUND ON BODY ! P=P+1; JJ=0; ! SET UP A BITMASK IN JJ %UNTIL A(P)=2 %CYCLE; ! UNTIL NO MORE NLIST KK=-1; P=P+4 FAULT(26,KK,0) %UNLESS INTEXP(KK)=0 %AND 1<=KK<=14 JJ=JJ!1<<(KK-1) %REPEAT P=P+1 KK=CA; PGLA(4,4,ADDR(CA)) RELOCATE(GLACA-4,KK,1); ! ENTRY ADDRESS IN PLT ONWORD(LEVEL)=JJ<<18!(GLACA-4) FORGETM(14) REGISTER(0)=1; REGISTER(1)=1; ! PROTECT EVENT,SUPE&LINE DUMPM(STM,0,1,RBASE,N); ! AND SAVE THEM DUMPRX(LGR,1,0,RBASE,N+8); ! RETRIEVE PROGRAM MASK PRR(SPM,1,0); ! AND RESET IT REGISTER(0)=0; REGISTER(1)=0 ONINF(LEVEL)=N; N=N+12 OLDLINE=0 CSTART(0,3) NMDECS(LEVEL)=NMDECS(LEVEL)!!X'10';! NOT IN ONCOND JJ=ENTER LAB(JJJ,B'111'); ! REPLACE ENVIRONMENT ->CSSEXIT SW(16): FAULT(57,0,0) %UNLESS LEVEL>=2 %BEGIN; ! %SWITCH (SWITCH LIST) %INTEGER Q,RANGE,KKK,KK,LB,PP,D0,D1,OPHEAD,V,ARRP,R Q=P ARRP=1 %UNTIL A(Q)=2 %CYCLE; ! UNTIL NO'REST OF SW LIST' P=P+3 P=P+3 %WHILE A(P)=1 P=P+4; ! TO P(+') KKK=INTEXP(LB); ! EXTRACT LOWER BOUND P=P+3 KKK=KKK!INTEXP(KK); ! EXTRACT UPPER BOUND RANGE=(KK-LB+1) %IF RANGE<=0 %OR KKK#0 %START FAULT(38,1-RANGE,FROMAR2(Q+1)) LB=0; KK=10; RANGE=11 %FINISH %IF GLACA+8-4*LB<0 %THEN ARRP=1;! ZEROETH ELEMENT OFF FRONT PTYPE=X'56'+ARRP<<8; ! WORD LABEL ARRAY PP=P; P=Q+1 %UNTIL A(P-1)=2 %CYCLE; ! DOWN NAMELIST K=FROM AR2(P) P=P+3 OPHEAD=0; R=LB ! ! SET UP A BIT LIST (96 BITS PER CELL) TO CHECK FOR SWITCH LABELS ! SET TWICE ! %UNTIL R>KK %CYCLE PUSH(OPHEAD,0,0,0) R=R+96 %REPEAT ! ! FOR CHECKING MODE USE A BOUNDED WORD DESCRIPTOR AND WORD SIZE ! ENTRIES PRESET TO "SW LABEL NOT SET". OPTIMISING USE BCI WORD ! ARRAYS WITH BASE SET TO ZEROETH ELEMENT D0=SSTL; PGLA(4,4,ADDR(D0)) SNDISP=GLACA>>2-1; ! WORD PLT DISP RELOCATE(GLACA-4,D0,4); ! RELOCATE RELATIVE TO SST PUSH(OPHEAD,D0,LB,KK) KFORM=0; ACC=4 J=1; STORE TAG(K,OPHEAD) ! !THE TABLE WILL CONSIST OF RELATIVE DISPLACEMENTS FROM THE TABLE HEAD ! TO THE LABEL POSN. SET ALL TO GO TO PLAB(6) INITIALLY ! V=PLABS(6) %CYCLE KKK=LB,1,KK LPUT(4,4,SSTL,ADDR(V)) SSTL=SSTL+4 %REPEAT %REPEAT; ! FOR ANY MORE NAMES IN NAMELIST Q=PP; P=Q %REPEAT; ! UNTIL A(Q)=2 %END;->CSSEXIT ! SW(17): LIST=1; ->CSSEXIT ! SW(12): ! '%OWN' (TYPE)(OWNDEC) %BEGIN !*********************************************************************** !* INITIALISED DECLARATION GO INTO THE GLA OR GLA SYMBOL TABLES * !* EXCEPT FOR CONST ARRAYS WHICH GO INTO THE CODE SYMBOL TABLES * !* STRINGS AND ARRAYS HAVE A HEADER IN THE GLA. LPUT ARRANGES * !* FOR THE LOADER TO RELOCATE THE HEADERS. * !* EXTERNALS ARE IDENTICAL WITH OWN BUT ALSO HAVE A DATA EP DEFN * !* IN THE LOAD DATA SO THEY CAN BE FOUND AT LOAD TIME * !* EXTRINSICS HAVE A DATA REFERENCE AND A DUMMY HEADER IN THE GLA* !* THE LOADER USES THE FORMER TO RELOCATE THE LATTER. * !*********************************************************************** %ROUTINESPEC CLEAR(%INTEGER L) %ROUTINESPEC STAG(%INTEGER J, DATALEN) %ROUTINESPEC XTRACT CONST(%INTEGER CONTYPE, CONPREC) %ROUTINESPEC INIT SPACE(%INTEGER A, B) %INTEGER LENGTH, PP, SIGN, UICONST, ICONST, %C TAGDISP, EPTYPE, EPDISP, AH1, AH2, AH3, AH4, AD, %C STALLOC, SPOINT, CONSTSFOUND, CPREC, EXTRN, NNAMES, %C MARK, LPUTP, LB, CTYPE, CONSTP, FORMAT, %C DIMEN, SACC, TYPEP %LONGREAL RCONST, LRCONST %OWNLONGREAL ZERO=0 %STRING (255) SCONST, NAMTXT %INTEGERNAME STPTR LPUTP=5; STPTR==USTPTR; ! NORMAL CASE GLA SYMBOLTABLES ! FAULT(40,0,0) %IF NMDECS&1#0 EXTRN=A(P+1) P=P+2 %IF EXTRN>=4 %THEN EXTRN=0; ! CONST & CONSTANT->0 SNDISP=0 CONSTS FOUND=0 %IF EXTRN=0 %THEN LPUTP=4 %AND STPTR==SSTL CLT ! ! CHECK FOR %SPEC AND CHANGE EXTERNAL SPEC TO EXTRINSIC ! %IF A(P+2)=1 %START %IF EXTRN=2 %THEN EXTRN=3 %ELSE FAULT(46,0,0) %FINISH %IF 2<=EXTRN<=3 %AND ((A(P)=1 %AND A(P+1)#3) %OR %C (A(P)=2 %AND A(P+1)#2)) %THEN FAULT(46,0,0) LITL=EXTRN %IF LITL<=1 %THEN LITL=LITL!!1 %IF A(P)=1 %THEN CQN(P+1) %ELSE ARR=1 %AND NAM=0 %IF TYPE=5 %AND NAM=0 %AND (ACC<=0 %OR ACC>256) %THEN %C FAULT(70,ACC-1,0) %AND ACC=2 STALLOC=ACC; ! ALLOCATION OF STORE FOR ITEM OR POINTER ROUT=0; PACK(PTYPE) %IF NAM#0 %START; ! OWN POINTERS %IF ARR#0 %THEN STALLOC=16 %ELSE STALLOC=8 %FINISH %ELSE %START; ! OWN VARS & ARRAYS ->NON SCALAR %IF ARR#0 %FINISH P=P+2 %UNTIL A(MARK)=2 %CYCLE; ! UNTIL NULL MARK=P+1+FROM AR2(P+1) PP=P+3; P=PP+2; ! PP ON FIRST NAME' K=FROM AR2(PP); ! FOR ERROR MESSAGES RE CONST NAMTXT=STRING(DICTBASE+WORD(K)) %IF A(P)=1 %THEN NAMTXT<-STRING(ADDR(A(P+1))) %AND %C P=P+A(P+1)+1 P=P+1; ! P ON CONST' ! ! OBTAIN THE INITIAL CONSTANT,ITS TYPE(CTYPE) AND SIGN(SIGN) ! ICONST=0; UICONST=0 RCONST=0; LRCONST=0; SCONST="" SIGN=3; CTYPE=TYPE; CONSTSFOUND=0; CPREC=PREC %IF TYPE=3 %THEN CTYPE=1; ! RECS INITTED TO REPEATED BYTE %IF NAM#0 %THEN CTYPE=1 %AND CPREC=5 P=P+1 %IF A(P-1)=1 %THEN %START; ! CONSTANT GIVEN XTRACT CONST(CTYPE,CPREC) %FINISH %ELSE %START WARN(7,K) %IF EXTRN=0; ! %CONST NOT INITIALISED %FINISH J=0 %IF NAM#0 %THEN %START; ! OWNNAMES AND ARRAYNAMES %IF ARR=0 %THEN %START %IF TYPE=5 %THEN ICONST=ICONST!(ACC-1)<<24 PGLA(4,STALLOC,ADDR(ICONST)) %FINISH %ELSE %START; ! ARRAYNAMES AH1=ICONST AH2=ICONST SNDISP=DOPE VECTOR(TYPE,ACC,-1,K,QQ,LB) AH3=SNDISP %IF J=1 %THEN AH4=ACC %ELSE AH4=CTABLE(SNDISP>>2+5) %IF TYPE=5 %THEN AH4=AH4!(ACC-1)<<24 %IF EXTRN#0 %THEN SNDISP=0 %ELSE %C SNDISP=(SNDISP&X'3FFFF')>>2 PGLA(8,STALLOC,ADDR(AH1)) RELOCATE(GLACA-8,AH3,1) AH3=AH3<<1>>3!X'80000000' NOTE CREF(AH3!(GLACA-8)>>2<<16) %FINISH TAGDISP=GLACA-STALLOC; EPDISP=TAGDISP STAG(TAGDISP,STALLOC) P=MARK %CONTINUE %FINISH %IF EXTRN=3 %THEN %START; ! EXTRINISIC PTYPE=PTYPE!X'400'; ! FORCE NAM=1 (IE VIA POINTER) AH3=0 PGLA(4,4,ADDR(AH3)) TAGDISP=GLACA-4 GXREF(NAMTXT,2,2<<24,TAGDISP);! RELOCATE BY EXTERNAL STAG(TAGDISP,STALLOC) P=MARK %CONTINUE %FINISH %IF TYPE=5 %THEN %START; ! STRING PTYPE=PTYPE!X'400'; ! FORCE NAM = 1 AH3=STPTR AD=ADDR(SCONST) LPUT(LPUTP,STALLOC,AH3,AD) %IF INHCODE=0 ! /P STRING STPTR=(STPTR+ACC+3)&(-4) AH3=AH3!(ACC-1)<<24 PGLA(4,4,ADDR(AH3)) TAGDISP=GLACA-4 RELOCATE(TAGDISP,AH3,LPUTP) EPTYPE=5; EPDISP=AH3; ! DATA IN GLA SYMBOL TABLES %FINISH %IF TYPE=3 %THEN %START; ! RECORDS PGLA(8,0,ADDR(AH1)); ! ALIGN EPDISP=GLACA TAGDISP=EPDISP; ! AND RELOCATE REL APPROPIATE AREA EPTYPE=2; ! DATA IN GLA TABLES I=0; ICONST=ICONST&255 ICONST=ICONST<<8!ICONST ICONST=ICONST<<16!ICONST %WHILE IBEND NONSCALAR: ! OWN AND OWNRECORD ARRAYS !*********************************************************************** !* OWN ARRAYS CAN BE INITIALISED BUT ONLY ONE ARRAY CAN BE * !* DECLARED IN A STATEMENT.(THANK HEAVENS!) * !* OWN RECORD ARRAYS ARE INITIALISED AS BYTE ARRAYS * !*********************************************************************** P=P+1 FORMAT=2-A(P) PP=P+2; P=P+4; NNAMES=1 K=FROM AR2(PP) NAMTXT=STRING(DICTBASE+WORD(K)) SACC=ACC; TYPEP=PTYPE AH3=DOPE VECTOR(TYPE,STALLOC,0,K,QQ,LB) SNDISP=AH3; ! DV DISP %IF SNDISP=-1 %THEN SNDISP=0; ! BUM DOPE VECTOR SNDISP=(SNDISP&X'3FFFF')>>2; ! AS WORD DISPLACEMENT DIMEN=J; ! SAVE NO OF DIMENESIONS ACC=SACC; PTYPE=TYPEP; UNPACK %IF TYPE=3 %THEN LENGTH=QQ %ELSE LENGTH=QQ//STALLOC;! NO OF ELEMENTS SPOINT=STPTR %IF FORMAT=0 %THEN %START %IF A(P)=1 %THEN P=P+1 %AND INIT SPACE(QQ,LENGTH) %FINISH %IF CONSTS FOUND=0 %THEN %START; ! NO CONSTANTS GIVEN ! SO CLEAR AN AREA TO ZERO CONSTS FOUND=LENGTH CLEAR(QQ) %UNLESS LENGTH<1 %OR EXTRN=3 %OR FORMAT#0 %FINISH %ELSE %START FAULT(49,0,K) %IF EXTRN=3 %OR FORMAT#0 %FINISH %IF EXTRN=3 %THEN EPDISP=0 %ELSE EPDISP=SPOINT ! OUTPUT AN ARRAYHEAD INTO THE GLA RELATIVE TO THE START OF THE SYMBOL- ! TABLES IN WHICH THE ARRAY RESIDES. J=DIMEN; ! RESET DIMENSIONS AFTER INITTING AH1=EPDISP-LB AH2=EPDISP AH4=STALLOC %IF DIMEN=2 %THEN AH4=CTABLE(SNDISP+5) %IF TYPE=5 %THEN AH4=AH4!(STALLOC-1)<<24 PGLA(8,16,ADDR(AH1)) TAGDISP=GLACA-16 %IF EXTRN=3 %THEN %START; ! EXTRINSIC ARRAYS GXREF(NAMTXT,2,2<<24,TAGDISP); ! RELOCATE ADDR(A(0)) GXREF(NAMTXT,2,2<<24,TAGDISP+4);! RELOCATE A(FIRST) %FINISH %ELSE %START RELOCATE(TAGDISP,AH1,LPUTP) RELOCATE(TAGDISP+4,AH2,LPUTP); ! RELOCATE ADDR(A(FIRST)) %FINISH RELOCATE(TAGDISP+12,AH3,1); ! RELOCATE DV POINTER AH3=(AH3<<1>>3)!X'80000000' NOTE CREF(AH3!(TAGDISP+8)>>2<<16) EPTYPE=5; ! DATA IN GLA SYMBOL TABLES STAG(TAGDISP,QQ) ->BEND %ROUTINE INIT SPACE(%INTEGER SIZE, NELS) !*********************************************************************** !* P IS TO FIRST ENTRY FOR CONSTLIST * !* MAP SPACE ONTO WORKFILE END TO GIVE SANE ERROR MESSAGE IF * !* THERE WAS NOT ENOUGH SPACE * !*********************************************************************** %INTEGER RF, I, II, ELSIZE, AD, SPP, LENGTH, SAVER, WRIT %BYTEINTEGERARRAYNAME SP %BYTEINTEGERARRAYFORMAT SPF(0:4096+256) SAVER=R; R=R+(4096+256) %IF R>ARSIZE %THEN FAULT(102, WKFILEK,0) SP==ARRAY(ADDR(A(SAVER)),SPF) %IF TYPE=1 %THEN AD=ADDR(ICONST)+4-ACC %IF TYPE=2 %THEN AD=ADDR(RCONST) %IF TYPE=3 %THEN AD=ADDR(ICONST)+3 %IF TYPE=5 %THEN AD=ADDR(SCONST) SPP=0; WRIT=0 ELSIZE=SIZE//NELS %UNTIL A(P-1)=2 %CYCLE XTRACT CONST(TYPE,PREC) %IF A(P)=1 %START; ! REPITITION FACTOR P=P+2 %IF A(P-1)=2 %THEN RF=NELS-CONSTS FOUND %ELSE %START P=P+2 %IF INTEXP(RF)#0 %THEN FAULT(41,0,0) %AND RF=1 %FINISH P=P+1 %FINISH %ELSE RF=1 %AND P=P+2 FAULT(42,RF,0) %IF RF<=0 %CYCLE I=RF,-1,1 %CYCLE II=0,1,ELSIZE-1 %IF CONSTS FOUND<=NELS %THEN SP(SPP)= %C BYTE INTEGER(AD+II) %AND SPP=SPP+1 %REPEAT CONSTS FOUND=CONSTS FOUND+1 %IF SPP>=4096 %START; ! EMPTY BUFFER LPUT(LPUTP,SPP,STPTR+WRIT,ADDR(SP(0))) %C %IF INHCODE=0 WRIT=WRIT+SPP SPP=0 %FINISH %REPEAT %REPEAT; ! UNTIL P=%NULL %IF CONSTS FOUND#NELS %THEN FAULT(45,CONSTS FOUND,NELS) STPTR=(STPTR+3)&(-4) LENGTH=(SIZE+3)&(-4) LPUT(LPUTP,LENGTH-WRIT,STPTR+WRIT,ADDR(SP(0))) %C %IF INHCODE=0 STPTR=STPTR+LENGTH R=SAVER %END %ROUTINE CLEAR(%INTEGER LENGTH) STPTR=(STPTR+3)&(-4) LENGTH=(LENGTH+3)&(-4) LPUT(LPUTP,LENGTH,STPTR,0) %IF INHCODE=0 STPTR=STPTR+LENGTH %END %ROUTINE STAG(%INTEGER J, DATALEN) %IF EXTRN=2 %THEN LPUT(14,EPTYPE<<24!DATALEN,EPDISP,ADDR( %C NAMTXT)) RBASE=GLA STORE TAG(K,J) RBASE=11-RLEVEL %END %ROUTINE XTRACT CONST(%INTEGER CONTYPE, CONPREC) !*********************************************************************** !* P POINTS TO P<+'> OF <+'> AND IS UPDATED* !* THE CONST IS CONVERTED TO REQUIRED FORM AND IF INTEGER * !* IS LEFT IN ICONST, IF REAL IN RCONST AND IF STRING IN SCONST * !*********************************************************************** %INTEGER LENGTH, STYPE, SACC, CPREC, MODE, I STYPE=PTYPE; SACC=ACC; ! MAY BE CHANGED IF CONST IS EXPR %IF CONTYPE=5 %THEN %START CTYPE=5 %IF A(P)=4 %AND A(P+1)=2 %AND A(P+2)=X'35' %C %AND A(P+A(P+7)+8)=2 %START SCONST=STRING(ADDR(A(P+7))) LENGTH=A(P+7) P=P+A(P+7)+9 %FINISH %ELSE %START FAULT(44,CONSTS FOUND,K); SCONST="" LENGTH=0; P=P-3; SKIP EXP %FINISH %FINISH %ELSE %START MODE=CONPREC<<4!CONTYPE %IF CONPREC<5 %THEN MODE=CONTYPE!X'50' CONSTP=CONSTEXP(MODE) %IF CONSTP=0 %THEN FAULT(41,0,0) %AND CONSTP=ADDR(ZERO) ! CANT EVALUATE EXPT CTYPE=TYPE; CPREC=PREC %IF CTYPE=1 %THEN %START ICONST=INTEGER(CONSTP) %IF CONPREC=6 %THEN UICONST=ICONST %C %AND ICONST=INTEGER(CONSTP+4) %FINISH %ELSE %START RCONST=LONGREAL(CONSTP) %IF CONPREC=7 %THEN %START; ! LONGLONGS UNALIGNED IN AR %CYCLE I=0,1,15 BYTEINTEGER(ADDR(RCONST)+I)=BYTEINTEGER( %C CONSTP+I) %REPEAT %FINISH %FINISH %FINISH PTYPE=STYPE; UNPACK; ACC=SACC ! FAULT ANY OBVIOUS ERRORS IE:- ! CONSTANT FOR EXTRINSIC OR INCOMPATIBLE TYPE OR STRING TOO LONG %IF EXTRN=3 %THEN FAULT(49,0,K) %AND %RETURN %IF (CTYPE=5 %AND LENGTH>=ACC) %C %OR (CONTYPE=1 %AND ((CONPREC=3 %AND ICONST>255) %C %OR (CONPREC=4 %AND ICONST>X'FFFF'))) %C %THEN FAULT(44,CONSTS FOUND,K) %END BEND: %END; ->CSSEXIT SW(18): ABORT SW(10): %BEGIN; ! %RECORDFORMAT (RDECLN) %INTEGER NAME,OPHEAD,OPBOT,NLIST,MRL,CELLREF %RECORD(LISTF)%NAME LCELL,FRCELL SNDISP=0 NAME=FROM AR2(P+1); P=P+3 COPY TAG(NAME) %UNLESS PTYPE=4 %AND J=15 %AND OLDI=LEVEL %START KFORM=0 PUSH(KFORM,0,0,0) ACC=X'7FFF' PTYPE=4; J=0 STORETAG(NAME,KFORM); ! IN CASE OF REFS IN FORMAT %FINISH%ELSE %START LCELL==ASLIST(TAGS(NAME)) LCELL_S1=LCELL_S1&X'FFFFFFF0';! J=15 TO J=0 %FINISH LCELL==ASLIST(KFORM) OPHEAD=0; OPBOT=0 NLIST=0; MRL=0 INAFORMAT=1 CRFORMAT(OPHEAD,OPBOT,NLIST,MRL,X'80000000') INAFORMAT=0 CLEAR LIST(NLIST) ! ! IN CASE OF FORWARD REFS COPY TOP CELL OF FORMAT CHAIN INTO DUMMY ! SET UP BEFORE CALL OF CRFORMAT. ALSO RESET J&ACC TO CORRECT VALUE ! %WHILE LCELL_S3#0 %CYCLE; ! THROUGH FORWARD REFS POP(LCELL_S3,CELLREF,I,I) FRCELL==ASLIST(CELLREF) FRCELL_S1=FRCELL_S1&X'FFFFFFF0';! SET J BACK TO 0 FRCELL_S2=FRCELL_S2&X'FFFF0000'!ACC;! ACC TO CORRECT VALUE %REPEAT POP(OPHEAD,LCELL_S1,LCELL_S2,LCELL_S3) LCELL_LINK=OPHEAD LCELL==ASLIST(TAGS(NAME)) LCELL_S2=LCELL_S2&X'FFFF0000'!ACC %END;->CSSEXIT ! SW(19): ! '*' (UCI) (S) FAULT(57,0,0) %UNLESS LEVEL>=2 %BEGIN !*********************************************************************** !* COMPILE USERCODE INSTRUCTION. MOST WORK IS DONE BY HAIRY * !* BUILT-IN PHRASE IN COMPARE. SINCE ALMOST ANYTHING IS LEGAL * !* IN USERCODE THIS BLOCK HAS ONLT TO ASSEMBLE AND PLANT THE * !* THE INSTRUCTION. * !*********************************************************************** %ROUTINESPEC DXB %ROUTINESPEC DLB %ROUTINESPEC DB %ROUTINESPEC CUCS %OWNINTEGER USING,AT %INTEGER Z,KK,X,REG,OPNUM,FNAME,ALT,OPCODE %SWITCH UCITYPE(1:6),OPTYPE(1:8) ALT=A(P+1); P=P+2 ->UCITYPE(ALT) UCITYPE(1): ! PUT (HEX HALFWORD) TYPE=A(P) PREC=TYPE>>4; TYPE=TYPE&7 FAULT(97,0,0) %UNLESS TYPE=1 %AND PREC<6 %IF PREC=5 %THEN P=P+2 PLANT(FROM AR2(P+1)) ->EXIT UCITYPE(3): ! CNOP CNOP(A(P),A(P+1)) ->EXIT UCITYPE(2): ! '*''_' OPCODE=A(P+1); OPNUM=A(P) P=P+2; ->OPTYPE(OPNUM) UCITYPE(4): ! 'USING' '*,' Z=A(P) %IF 1<=Z<=15 %THEN %START USING=Z; AT=CA %FINISH %ELSE FAULT(96,Z,0) ->EXIT UCITYPE(5): ! 'DROP' Z=A(P) %IF Z=USING %THEN %START USING=0; AT=0 %FINISH %ELSE FAULT(96,Z,0) ->EXIT OPTYPE(1): ! RR FORMAT INSTRUCTION PRR(OPCODE,A(P),A(P+1)) P=P+2 ->EXIT OPTYPE(2): ! RX FORMAT INSTRUCTION OPTYPE(3): ! RS FORMAT INSTRUCION OPTYPE(5): ! SHIFT INSTRUCTION REG=A(P) %IF OPNUM=2 %THEN P=P+1 %AND DXB %ELSE %START %IF OPNUM=5 %THEN X=0 %AND P=P+1 %ELSE X=A(P+1) %AND P=P+2 DB %FINISH PRX(OPCODE,REG,X,I,K) ->EXIT OPTYPE(4): ! STORE-IMMEDIATE FORMAT DB %IF A(P)=2 %THEN Z=0 %ELSE %START TYPE=A(P+1); Z=FROM AR2(P+2) FAULT(96,Z,0) %UNLESS TYPE=X'41' %AND 0<=Z<=255 P=P+3 %FINISH PSI(OPCODE,Z,I,K);P=P+1 ->EXIT OPTYPE(6): ! SS FORMAT OPTYPE(7): ! PACKED DECIMAL FORMAT DLB; KK=K; Z=X REG=I; Z=1 %IF Z=0 %IF OPNUM=6 %THEN DB %ELSE %START DLB; X=1 %IF X=0 Z=(Z-1)<<4!X %FINISH PSS(OPCODE,Z,REG,KK,I,K) ->EXIT OPTYPE(8): ! FUNNIES REG=A(P); P=P+1 %IF OPCODE=X'80' %THEN PSI(OPCODE,REG,0,0) %ELSE %START %IF OPCODE=10 %THEN PLANT(X'A00'!REG) %ELSE PRR(OPCODE,REG,0) %FINISH ->EXIT %ROUTINE DB !*********************************************************************** !* DEAL WITH OPERANDS FOR A DB INSTRUCTION. P ON ALT OF P * !* P=, * !* P='('')',%NULL * !*********************************************************************** %IF A(P)=1 %THEN CUCS %ELSE %START K=FROM AR2(P+1); I=A(P+3); P=P+4;! I IS ALT OF P %IF I=2 %THEN I=0 %ELSE I=A(P) %AND P=P+1 %FINISH FAULT(99,0,0) %UNLESS 0<=K<=4095 %END %ROUTINE DXB !*********************************************************************** !* DEAL WITH OPERANDS FOR A DXB INSTRN. P ON ALT OF P * !* P=, * !* P='('','')','('')',%NULL * !*********************************************************************** %INTEGER ALT X=0 %IF A(P)=1 %THEN %START CUCS %IF A(P)=1 %THEN X=A(P+1) %AND P=P+1 %FINISH %ELSE %START K=FROM AR2(P+1); I=0 ALT=A(P+3); P=P+3 %IF ALT=1 %THEN X=A(P+1) %AND P=P+1 %IF ALT<=2 %THEN I=A(P+1) %AND P=P+1 %FINISH P=P+1 FAULT(99,0,0) %UNLESS 0<=K<=4095 %END %ROUTINE DLB !*********************************************************************** !* DEAL WITH OPERAND FOR A DB INSTRUCTION. P ON ALT OF P * !* P='('','')','('')' * !*********************************************************************** %IF A(P)=1 %THEN %START; ! EXPLICT FORM K=FROM AR2(P+1); X=A(P+3) I=A(P+4); P=P+5 %FINISH %ELSE %START CUCS; X=A(P); P=P+1 %FINISH FAULT(99,0,0) %UNLESS 0<=K<=4095 %END %ROUTINE CUCS !*********************************************************************** !* DEAL WITH SYMBOLIC REFERENCES IN USERCODE STATEMENTS * !* P=,'<''>','*' * !* P='+','-',%NULL * !*********************************************************************** %INTEGER X,Y,AD,ALT,LAB,JJ,CELL %RECORD(LISTF)%NAME LCELL X=USING; Y=AT %IF X=0 %THEN X=CODER %AND Y=0 ALT=A(P+1); ! ALT OF P %IF ALT#1 %AND CA-Y>4095 %THEN FAULT(99,0,0) %IF ALT=2 %THEN %START ! ! OPERAND IS AN IMP LABEL WHICH MAY OR MAY NOT BE SET BUT MUST BE WITHIN ! 4095 OF THE BASE REGISTER WHETHER IMPLIED OR SET BY 'USING' ! LAB=A(P+2)<<8!A(P+3) P=P+4 CELL=LABEL(LEVEL) %WHILE CELL>0 %CYCLE LCELL==ASLIST(CELL) %IF LAB=LCELL_S3 %THEN %EXIT CELL=LCELL_LINK %REPEAT %IF CELL<0 %THEN PUSH(LABEL(LEVEL),0,0,LAB) %AND %C LCELL==ASLIST(LABEL(LEVEL)) AD=LCELL_S1 LCELL_S1=AD!X'01000000' %IF AD&X'FFFFFF'#0 %THEN K=AD-Y %AND I=X %ELSE %START K=0; I=0; JJ=LCELL_S2&X'FFFF' PUSH(JJ,CA,X<<24!Y,LINE) LCELL_S2=LCELL_S2&X'FFFF0000'!JJ %FINISH %FINISH %ELSE %START %IF ALT=1 %THEN %START FNAME=A(P+2)<<8!A(P+3) COPY TAG(FNAME) P=P+4 FAULT(95,0,FNAME) %IF ROUT=1 %OR TYPE=4 %OR TYPE>=6 %FINISH %ELSE %START I=X; K=CA-Y P=P+2 %FINISH ALT=A(P); P=P+1 %IF ALT#3 %THEN %START JJ=FROM AR2(P) %IF ALT=1 %THEN K=K+JJ %ELSE K=K-JJ P=P+2 %FINISH %FINISH %END EXIT: %END ->CSSEXIT SW(20): ! '%TRUSTEDPROGRAM' COMPILER=1 %IF PARMARR=0 %AND PARMCHK=0; ->CSSEXIT SW(21): ! '%MAINEP'(NAME) KK=FROM AR2(P+1) FAULT(97,0,0) %UNLESS CPRMODE=0 MAINEP<-STRING(DICTBASE+WORD(KK)) ->CSSEXIT %INTEGERFN CFORMATREF !*********************************************************************** !* P IS TO ALT OF FORMAT REF * !* P::=(NAME),(RFDEC)(RESTOFRFDEC)(ALTRFDEC) * !* RETURNS CELL NO OF TOP CELL OF THE FORMATLIST * !*********************************************************************** %INTEGER FNAM,OPHEAD,OPBOT,NHEAD,MRL %RECORD(LISTF)%NAME LCELL %IF A(P)=1 %START; ! A RECORD OF RECORDFORMAT NAME FNAM=FROM AR2(P+1) P=P+3 COPY TAG(FNAM) %IF 3<=TYPE<=4 %THEN %RESULT=KFORM %IF INAFORMAT#0 %AND OLDI#LEVEL %START KFORM=0; SNDISP=0;ACC=X'7FFF' PTYPE=4; J=15 PUSH(KFORM,0,0,0) STORE TAG(FNAM,KFORM) %RESULT=KFORM %FINISH FAULT(62,0,FNAM); ! NOT A RECORD OF FORMAT NAME ACC=8; ! GUESS A RECORD SIZE %RESULT=DUMMY FORMAT %FINISH ! FORMAT ACTUALLY SPECIFIED P=P+1 OPHEAD=0; OPBOT=0 NHEAD=0; MRL=0 CRFORMAT(OPHEAD,OPBOT,NHEAD,MRL,X'80000000') CLEAR LIST(NHEAD) %IF UNATT FORMATS(LEVEL)#0 %START LCELL==ASLIST(UNATT FORMATS(LEVEL)) %IF LCELL_S2=0 %THEN LCELL_S2=OPHEAD %AND %RESULT=OPHEAD %IF LCELL_S3=0 %THEN LCELL_S3=OPHEAD %AND %RESULT=OPHEAD %FINISH PUSH(UNATT FORMATS(LEVEL),OPHEAD,0,0) %RESULT=OPHEAD %END %ROUTINE CRFORMAT(%INTEGERNAME OPHEAD, OPBOT, NLIST, MRL, %INTEGER INIT) !*********************************************************************** !* CONVERTS A RECORDFORMAT STATEMENT TO A LIST HEADED BY OPHEAD * !* FORMAT OF AN ENTRY. * !* S1=SUBNAME<<20!PTYPE<<4!J * !* S2,S3=4 16 BIT DISPLACEMENTS D2,ACC,D1,KFORM * !* NORMALLY D1=RECORD RELATIVE DISPLACEMENT AND ACC=LMAX(STRINGS)* !* FOR ARRAYS D2=FIRST ELEMENT DISPLACEMENT AND D1=DISPLACEMENT * !* OF RECORD RELATIVE ARRAYHEAD IN THE GLA * !* KFORM IS ONLY USED FOR RECORDS AND POINTS TO THE FORMAT * !* ON EXIT ACC HAS THE RECORD SIZE ROUNDED UP TO THE BOUNDARY * !* REQUIRED BY ITS LARGEST COMPONENT * !*********************************************************************** %INTEGER D1, D2, FORM, RL, UNSCAL, SC, DESC, STALLOC, INC, Q, %C R, A0, A1, A2, A3, RFD, LB, TYPEP, SACC %ROUTINESPEC SN(%INTEGER Q) %ROUTINESPEC ROUND FORM=0; ACC=0 INC=INIT&X'FFFF'; ! INC COUNTS DOWN RECORD %CYCLE ROUT=0; LITL=0; NAM=0; RFD=A(P) P=P+1 %IF RFD=1 %THEN %START CLT FORM=KFORM STALLOC=ACC P=P+1 %IF A(P-1)=1 %START ! (TYPE) (QNAME')(NAMELIST) FORM=KFORM CQN(P); P=P+1 %IF NAM=1 %THEN %START STALLOC=4 %IF ARR#0 %THEN STALLOC=16 %FINISH PACK(PTYPE); D2=0 RL=3 %IF NAM=0 %AND TYPE#3 %AND 3<=PREC<=4 %C %THEN RL=PREC-3 %IF TYPE=3 %OR PREC=6 %THEN RL=7 ROUND; J=0 %UNTIL A(P-1)=2 %CYCLE D1=INC; SN(P) P=P+3; INC=INC+STALLOC %REPEAT %FINISH %ELSE %START ! (TYPE)%ARRAY(NAMELIST)(BPAIR) Q=P+1; ARR=1; PACK(PTYPE) %IF TYPE<=2 %THEN UNSCAL=0 %AND SC=PREC %C %ELSE UNSCAL=1 %AND SC=3 %IF PREC=4 %THEN DESC=X'58000002' %C %ELSE DESC=SC<<27!UNSCAL<<25!(1-PARMARR)<<24 %CYCLE P=Q P=P+3 %UNTIL A(P-1)=2 TYPEP=PTYPE; SACC=ACC A2=DOPE VECTOR(TYPE,ACC,0,FROMAR2(Q),R,LB) ! DOPE VECTOR INTO SHAREABLE S.T. ACC=SACC; PTYPE=TYPEP; UNPACK %IF TYPE=5 %OR (TYPE=1 %AND PREC=3) %C %THEN RL=0 %ELSE RL=3 ROUND %CYCLE A1=INC A0=INC-LB A3=ACC %IF J=2 %THEN A3=CTABLE(A2>>2+5) %IF TYPE=5 %THEN A3=A3!(ACC-1)<<24 PGLA(4,16,ADDR(A0)) D1=GLACA-16 RELOCATE(D1+8,A2,1); ! RELOCATE DV POINTER NOTE CREF(X'80000000'!(A2<<1>>3)!(D1+8)>>2<<16) D2=INC SN(Q); INC=INC+R Q=Q+3 %REPEAT %UNTIL A(Q-1)=2;! TILL NAMELIST NULL P=P+1; Q=P+1 %REPEAT %UNTIL A(P-1)=2; ! UNTIL NULL %FINISH %FINISH %ELSE %START ! (FORMAT) CRFORMAT(OPHEAD,OPBOT,NLIST,MRL,INC) INC=ACC %FINISH P=P+1 %REPEAT %UNTIL A(P-1)=2; ! UNTIL NULL ! FINISH OFF %IF A(P)=1 %START; ! WHILE %OR CLAUSES P=P+1 CRFORMAT(OPHEAD,OPBOT,NLIST,MRL,INIT&X'FFFF') %IF ACC>INC %THEN INC=ACC %FINISH %ELSE P=P+1 %IF INIT<0 %THEN RL=MRL %AND ROUND ACC=INC; ! SIZE ROUNDED APPROPRIATELY FAULT(63,X'7FFF',0) %UNLESS INC<=X'7FFF' %RETURN %ROUTINE SN(%INTEGER Q) !*********************************************************************** !* CHECK THE SUBNAME HAS NOT BEEN USED BEFORE IN THIS FORMAT * !* AND ENTER IT WITH ITS DESCRIPTORS INTO THE LIST. * !*********************************************************************** FNAME=FROM AR2(Q) FAULT(61,0,FNAME) %UNLESS FIND(FNAME,NLIST)=-1 BINSERT(OPHEAD,OPBOT,FNAME<<20!PTYPE<<4!J,D2<<16!ACC,D1<< %C 16!FORM) PUSH(NLIST,0,FNAME,0) %IF PTYPE=X'433' %AND ACC=X'7FFF' %THEN %C PUSH(ASLIST(FORM)_S3,OPBOT,0,0);! NOTE FORWARD REFERENCE %END %ROUTINE ROUND MRL=RL %IF RL>MRL INC=INC+1 %WHILE INC&RL#0 %END %END; ! OF ROUTINE CRFORMAT %INTEGERFN DISPLACEMENT(%INTEGER LINK) !*********************************************************************** !* SEARCH A FORMAT LIST FOR A SUBNAME * !* A(P) HAS ENAME--LINK IS HEAD OF RFORMAT LIST. RESULT IS DISP * !* FROM START OF RECORD * !*********************************************************************** %RECORD(LISTF)%NAME FCELL,PCELL,LCELL %INTEGER RR,II,ENAME,CELL ENAME=A(P)<<8+A(P+1); CELL=0 %IF LINK#0 %THEN %START; ! CHK RECORDSPEC NOT OMITTED FCELL==ASLIST(LINK); ! ONTO FIRST CELL CELL=LINK; II=-1; ACC=-1 %WHILE LINK>0 %CYCLE LCELL==ASLIST(LINK) %IF LCELL_S1>>20=ENAME %START;! RIGHT SUBNAME LOCATED TCELL=LINK RR=LCELL_S1 SNDISP=LCELL_S2 K=LCELL_S3 J=RR&15; PTYPE=RR>>4&X'FFFF' ACC=SNDISP&X'FFFF'; SNDISP=SNDISP&X'FFFF0000'//X'10000' KFORM=K&X'FFFF'; K=K>>16 %IF LINK#CELL %START; ! NOT TOP CELL OF FORMAT PCELL_LINK=LCELL_LINK LCELL_LINK=FCELL_LINK FCELL_LINK=LINK %FINISH; ! ARRANGING LIST WITH THIS SUBNAME ! NEXT TO THE TOP %RESULT=K %FINISH PCELL==LCELL LINK=LCELL_LINK %REPEAT %FINISH FAULT(65,0,ENAME) %IF CELL>0 %THEN %C PUSH(ASLIST(CELL)_LINK,ENAME<<20!7<<4,0,0) PTYPE=7; TCELL=0 %RESULT=-1 %END %INTEGERFN COPY RECORD TAG(%INTEGERNAME SUBS) !*********************************************************************** !* PRODUCE PTYPE ETC FOR A COMPOUND NAME BY CHAINING DOWN ONE * !* ONE OR MORE RECORD FORMAT LISTS. ON EXIT RESULT =0 IF NO * !* SUBNAME FOUND OR SUBNAME IS OF TYPE RECORD WITH NO FURTHER * !* SUBNAME ATTACHED. RESULT#0 IF BONE-FIDE SUBNAME LOCATED * !* ON ENTRY KFORM HAS POINTER TO THE (FIRST ) FORMAT LIST AND * !* P POINTS TO THE A.R. ENTRY FOR (FIRST) ENAME * !*********************************************************************** %INTEGER Q,FNAME SUBS=0 %UNTIL TYPE#3 %CYCLE FNAME=KFORM P=P+2; SKIP APP %RESULT=0 %IF A(P)=2 %OR FNAME<=0;! NO (FURTHER) ENAME SUBS=SUBS+1 P=P+1; Q=DISPLACEMENT (FNAME) UNPACK %REPEAT %RESULT=Q+1; ! GIVES 0 IF SUBNAME NOT KNOWN %END %ROUTINE CRNAME(%INTEGER Z,REG,MODE,BS,IX,DP,%INTEGERNAME NAMEP) !*********************************************************************** !* DEAL WITH RECORD ELEMENT NAMES.Z AS FOR CNAME.CLINK=TAGS(RN) * !* MODE=ACCESS FOR RECORD(NOT THE ELEMENT!) * !* ON EXIT BASE,AREA & DISP POINT TO REQUIRED ELEMENT * !* RECURSIVE CALL IS NEEDED TO DEAL WITH RECORDS IN RECORDS * !* DEPTH SHEWS RECURSIVE LEVELS- NEEDED TO AVOID MIS SETTING * !* REGISTER IN USE IF RECORDNAME IN RECORD HAS THE SAME NAME AS * !* A GENUINE RECORD NAME. * !*********************************************************************** %INTEGER DEPTH,FNAME %ROUTINESPEC CENAME(%INTEGER MODE,FNAME,BS,IX,DP,XD) DEPTH=0 FNAME=KFORM; ! POINTER TO FORMAT %IF ARR=0 %OR (Z=6 %AND A(P+2)=2) %START;! SIMPLE RECORD %IF A(P+2)=2 %THEN P=P+3 %ELSE NO APP CENAME(MODE,FNAME,BS,IX,DP,0) %FINISH %ELSE %START CANAME(ARR,BS,DP) NAMEP=0 CENAME(ACCESS,FNAME,BASE,INDEX,DISP,0) %FINISH; %RETURN ! %ROUTINE CENAME(%INTEGER MODE,FNAME,BS,IX,DP,XD) !*********************************************************************** !* FINDS OUT ABOUT SUBNAME AND ACTS ACCORDINGLY.MOSTLY ACTION * !* CONSISTS OF UPPING XD BY OFFSET OF THE SUBNAME BUT IS VERY * !* HAIRY FOR RECORDS IN RECORDS ETC * !* MODE IS ACCESS FOR THE RECORD * !*********************************************************************** %ROUTINESPEC FETCH RAD %ROUTINESPEC LOCALISE(%INTEGER SIZE) %INTEGER Q,QQ,D,C,W DEPTH=DEPTH+1 %IF A(P)=2 %THEN %START; ! ENAME MISSING ACCESS=MODE; INDEX=IX; XDISP=XD BASE=BS; DISP=DP; ! FOR POINTER %IF Z<14 %THEN %START; ! NOT A RECORD OPERATION %UNLESS 3<=Z<=4 %OR Z=6 %START; ! ADDR(RECORD) FAULT(64,0,NAMEP&X'FFFF'); BASE=RBASE; INDEX=0 DISP=0; ACCESS=0; PTYPE=X'51'; UNPACK %FINISH %FINISH %RETURN %FINISH P=P+1; ! FIND OUT ABOUT SUBNAME Q=DISPLACEMENT(FNAME); ! TCELL POINTS TO CELL HOLDING UNPACK; ! INFO ABOUT THE SUBNAME %IF Q=-1=ACC %OR PTYPE=7 %START; ! WRONG SUBNAME(HAS BEEN FAULTED) P=P+2; SKIP APP; P=P-3 ACCESS=0; BASE=RBASE; DISP=0; INDEX=0 %RETURN %FINISH NAMEP=(A(P)<<8!A(P+1))<<16!NAMEP; ! NAMEP=-1 UNALTERED ! ->AE %IF ARR=1; ! ARRAYS INCLUDING RECORDARRAYS %IF A(P+2)=2 %THEN P=P+3 %ELSE NO APP %IF TYPE<=2 %OR TYPE=5 %OR %C (TYPE=3 %AND A(P)=2 %AND (3<=Z<=4 %OR Z=6)) %START ACCESS=MODE+4+4*NAM; BASE=BS; INDEX=IX; DISP=DP; XDISP=XD+Q %RETURN %FINISH ! ! NOW CODING BECOMES HAIRY:- STILL LEFT ARE ! A) RECORDS IN RECORDS Q POINTS TO SECONDARY RECORD ! B) RECORDNAMES IN RECORDS Q HAS OFF-SET OF A POINTER ! C) RECORDARRAYNAMES IN RECORDS Q HAS OFF-SET A HEADER IN RECORD ! D) RECORDARRAYS IN RECORDS NOT YET ALLOWED ! Q WOULD HAVE OFF-SET OF A RECORD RELATIVE HEADER IN THE GLA ! XD=XD+Q NAMEP=-1 %IF NAM=1 %THEN %START %IF MODE=0 %START DP=DP+XD; XD=0; MODE=2 %FINISH %ELSE %START LOCALISE(4); ! PICK UP RECNAME DESCR &STCK IX=INDEX; DP=DISP; BS=BASE %FINISH %FINISH CENAME(MODE,KFORM,BS,IX,DP,XD) %RETURN AE: ! ARRAYS AND ARRAYNAMES AS ELEMEN FROM123(TCELL,Q,SNDISP,K) ACC=SNDISP&X'FFFF'; SNDISP=SNDISP&X'FFFF0000'//X'10000' KFORM=K&X'FFFF'; K=K>>16 C=ACC; D=SNDISP; Q=K; QQ=KFORM %IF (Z=6 %OR Z=12) %AND A(P+2)=2 %START;! 'GET ARRAYHEAD' CALL P=P+3 %IF NAM=1 %THEN %START ACCESS=MODE+8; BASE=BS INDEX=IX; DISP=DP; XDISP=XD+Q %RETURN %FINISH ! ! PASSING AN ARRAY IN A RECORD BY NAME MUST CONSTRUCT PROPER ARRAYHEAD ! FROM THE RECORD RELATIVE ONE AT Q(GLA) ! NAMEP=-1 FETCH RAD ACCESS=0; W=NEST; REGISTER(W)=1 CREATE AH(1,NEST,GLA,Q) REGISTER(W)=0 %FINISH %ELSE %START; ! ARRAY ELEMENTS IN RECORDS NAMEP=-1 %IF NAM=1 %THEN %START; ! ARRAYNAMES-FULLHEAD IN RECORD XD=XD+Q LOCALISE(16); ! MOVE HEAD UNDER LNB CANAME(3,BASE,DISP); ! ARRAY MODE SETS DISP,AREA&BASE %FINISH %ELSE %START; ! ARRAY RELATIVE HEAD IN GLA %IF MODE=2 %AND IX=0 %START W=DP %FINISH %ELSE %START FETCH RAD; ! RECORD ADDR TO ACC GET WSP(W,1) DUMPRX(ST,NEST,0,RBASE,W) XD=0; BS=RBASE %FINISH CANAME(3,GLA,Q); ! RECORD REL ARRAY ACCESS ! CAN RETURN ACCESS=1 OR 3 ONLY %IF ACCESS=3 %START DUMPRX(ADD,INDEX,0,BS,W);! COMBINE POITER WITH INDEX GRUSE(INDEX)=0 %FINISH %ELSE %START DUMPRX(LGR,-2,0,BS,W) INDEX=NEST; ACCESS=3 GRUSE(INDEX)=0; REGISTER(INDEX)=2 XD=XD+NUMMOD %FINISH %FINISH XDISP=XD %IF TYPE=3 %THEN CENAME(ACCESS,QQ,BASE,INDEX,DISP,XD) %FINISH ACC=C; ! NEEDED FOR STRING ARRAYS %RETURN %ROUTINE FETCH RAD !*********************************************************************** !* SET ACC TO 32 BIT ADDRESS OF RECORD. * !*********************************************************************** ACCESS=MODE+4 INDEX=IX; BASE=BS DISP=DP; XDISP=XD NAMEOP(4,-2,4,-1) %END %ROUTINE LOCALISE(%INTEGER SIZE) !*********************************************************************** !* REMOVES A POINTER OR ARRAYHEAD FROM A RECORD AND STORES * !* IT IN A TEMPORARY UNDER LNB. * !*********************************************************************** %INTEGER HOLE ACCESS=MODE+4 %IF IX=0=MODE %AND RBASE<=BASE<=10 %AND DP+XD<=4095 %START ! IS ADDRESSABE AND WONT VANISH DISP=DP+XD; XD=0 INDEX=0; BASE=BS %RETURN %FINISH INDEX=IX; BASE=BS; DISP=DP XDISP=XD %IF IX=0 %AND MODE=0 %AND DP+XD<=4095 %THEN %C BASE=BS %AND DISP=DP+XD %ELSE %START NAMEOP(4,-2,SIZE,-1) BASE=NEST; DISP=0 %FINISH GET WSP(HOLE,SIZE>>2) PSS(MVC,SIZE,RBASE,HOLE,BASE,DISP) MODE=2; INDEX=0 BASE=RBASE; DISP=HOLE; XD=0 %END; ! OF ROUTINE LOCALISE %END; ! OF ROUTINE CENAME %END; ! OF ROUTINE CRNAME %ROUTINE CSTREXP(%INTEGER MODE,REG) !*********************************************************************** !* PLANT IN-LINE CODE FOR CONCATENATION. A WORK AREA UNDER * !* BASE REGISTER COVER IS USUALLY REQUIRED. THE CURRENT LENGTH * !* OF STRING IN THE WORK AREA IS KEPT IN A REGISTER (BREG) * !* WHICH IS PROTECTED THROUGH THE NORMAL INTERMEDIATE-RESULT * !* MECHANISMS. * !* ON ENTRY:- * !* MODE=0 NORMAL. WK AREA NOT USED FOR ONE OPERAND EXPSSNS * !* MODE=1 STRING MUST GO TO WORK AREA * !* (AND TO COME) * !* MODE=3 CONCATENATE INTO LHS OF =ASSNMNT (E.G. A=B.C) * !* MODE=4 OPTIMISE S=S.T BY NOT COPYING S * !* 2**4 BIT OF MODE IS SET IF WK-AREA NOT TO BE FREED ON EXIT * !* ON EXIT:- * !* BASE,DISP & INDEX DEFINE RESULT * !* VALUE#0 %IF RESULT IN A WORK AREA(CCOND MUST KNOW) * !* STRINGL SET IF STRING LENGTH KNOWN. STRFNRES DEFINES LENREG * !*********************************************************************** %INTEGER PP,WKAREA,DOTS,REXP,ERR,CLEN,KEEPWA,FNAM,I %INTEGERFNSPEC STROP(%INTEGER REG) KEEPWA=MODE&16; MODE=MODE&15 PP=P; STRINGL=0; FNAM=0; WKAREA=0 REXP=2-A(P+1+FROM AR2(P+1)); ! =0 %IF ONE OPERAND EXP -> NORMAL %UNLESS A(P+3)=4 %AND REXP=0 %AND MODE=0 -> SIMPLE %IF A(P+4)=2 -> NORMAL %UNLESS A(P+4)=1 COPY TAG(FROM AR2(P+5)) %IF PTYPE=SNPT %THEN PTYPE=TSNAME(K) -> NORMAL %UNLESS ROUT=0 ; ! BEWARE OF MAP=FN ! -> NORMAL %IF PARMARR=1 %AND(ARR#0 %OR A(P+7)=1) SIMPLE: P=P+4 ERR=STROP(REG) -> ERROR %UNLESS ERR=0 VALUE=WKAREA P=P+1; STRFNRES=0 %RETURN ERROR:FAULT(ERR,0,FNAM) BASE=RBASE; DISP=0 VALUE=0; ACCESS=0 P=PP; SKIP EXP %RETURN NORMAL: CLEN=0; P=P+3; ! LENGTH OF CONSTANT PART ERR=72; ->ERROR %UNLESS A(P)=4 P=P+1 %CYCLE I=0,1 ,1 %IF REGISTER(I)#0 %THEN BOOT OUT(I) %REPEAT GET WSP(WKAREA,268); ! GET NEXT OPERAND DOTS=0; ! NO OPERATORS YET NEXT: STRINGL=0 ERR=STROP(1); ! GET NEXT OPERAND -> ERROR %UNLESS ERR=0 REGISTER(1)=1; GRUSE(1)=0 %IF DOTS=0 %AND STRINGL>0 %START DUMPSS(MVC,STRINGL+1,RBASE,WKAREA+3,1,0) %FINISH %ELSE %START DUMPRX(LA,0,0,RBASE,WKAREA) %UNLESS %C GRUSE(0)=STRWKAREA %AND GRINF1(0)=WKAREA;! ADDRESS OF WKAREA REGISTER(0)=1; GRUSE(0)=STRWK AREA; GRINF1(0)=WKAREA PPJ(0,19+DOTS,NO); ! TO SUBROUTINE 19 OR 20 %FINISH GRUSE(LINKREG)=0 REGISTER(1)=0; REGISTER(0)=0 %IF A(P)=2 %THEN -> TIDY; ! NO MORE OPERATIONS ERR=72; -> ERROR %UNLESS A(P+1)=CONCOP; ! CONCATENATE DOTS=DOTS!1 P=P+2; -> NEXT TIDY: ! FINISH OFF VALUE=WKAREA %IF REG>0 %THEN %START DUMPRX(LA,REG,0,RBASE,WKAREA+3) BASE=NEST; DISP=0 %FINISH %ELSE BASE=RBASE %AND DISP=WKAREA+3 P=P+1; ! PAST REST OF EXPRN RETURN WSP(WKAREA,268) %IF KEEPWA=0 STRINGL=0 %RETURN %INTEGERFN STROP(%INTEGER REG) !*********************************************************************** !* DEALS WITH OPERAND FOR CONCATENATION. RETURN RESULT=0 FOR * !* VALID OPERAND OTHERWISE AN ERROR NUMBER. * !*********************************************************************** %INTEGER CTYPE,MODE MODE=A(P); ! ALTERNATIVE OF OPERAND %RESULT=75 %IF MODE>2 %IF MODE#1 %THEN %START CTYPE=A(P+1); ! GET CONST TYPE & LOSE AMCK FLAGS %IF CTYPE=X'35' %THEN %START STRINGL=A(P+6) DISP=FROM AR4(P+2) P=P+STRINGL+7 %FINISH %ELSE %RESULT=73 %IF REG>0 %THEN %START DUMPRX(LA,REG,0,CODER,DISP) GRUSE(REG)=0 BASE=REG; DISP=0 %FINISH %ELSE BASE=CODER %FINISH %ELSE %START P=P+1; ! MUST CHECK FIRST REDUCE TAG; ! SINCE CNAME ONLY LOADS STRINGS ! AND LONGINTS TO DR! %IF 5#TYPE#7 %THEN FNAM=FROMAR2(P) %AND %RESULT=71 CNAME(2,REG) STRINGL=0 DISP=0 %IF REG>0 %THEN BASE=REG %ELSE BASE=NEST %FINISH %RESULT=0 %END; ! OF INTEGERFN STROP %END; ! OF ROUTINE CSTREXP %ROUTINE CRES (%INTEGER LAB) !********************************************************************** !* COMPILES A RESOLUTION E.G A->B.(C).D.(E).F AND JUMPS TO LAB * !* ON FAILURE. (LAB=0 FOR UNCONDITIONAL RESOLUTION TO PERM ON * !* FAILURE ). * !* THE METHOD IS TO CALL A SUBROUTINE PASSING 4 PARAMS:- * !* P1 POINTS TO LHS(A) * !* P2 BYTES USED UP ALREADY INITIALLY 0 * !* P3 STRING TO CONTAIN FRAGMENT (PASSED BY NAME) * !* P4 THE EXPRESSION PASSED AS DESCRIPTOR * !* SUBROUTINE TRIES TO PERFORM THE RESOLUTION AND SETS THE * !* CONDITION CODE =8 IF IT SUCCEEDS. * !* * !* ON ENTRY LHS IS DEFINED BY REG NEST. * !* P POINTS TO P(+') OF RHS DEFINED AS (+')(OPERAND)(RESTOFEXP) * !* * !$ THE ROUTINE IS COMPACT BUT DIFFICULT TO FOLLOW (OR ALTER) * !* THE TIME IN PERM IS LARGE SO IT IS NOT WORTHWHILE TO PERSUE * !* CODE EFFICIENCY TOO INDUSTRIOUSLY . * !********************************************************************** %INTEGER P1,P2,SEXPRN,W,LAST,ERR,FNAM,REG %RECORD(RD) R LAST=0; FNAM=0; ! =1 WHEN END OF EXPRNSN FOUND SEXPRN=0; ! RESOLUTION(BRKTD) EXPRESSNS ERR=74; ! NORMAL CRES FAULT %IF REGISTER(0)#0 %THEN BOOT OUT (0) GET WSP(W,4); ! TO HOLD PARAMS REGISTER(NEST)=1 REG=(NEST+1)&15 %IF REGISTER(REG)#0 %THEN FIND REG(GR0,REG) PRR(SR,REG,REG) DUMPRX(ST,NEST,0,RBASE,W) DUMPRX(ST,REG,0,RBASE,W+4) REGISTER(NEST)=0 SET USE(REG,LITCONST,0) P1=P; P=P+3 ->RES %IF A(P)=4; ! LHS MUST BE A STRING ! BUT THIS CHECKED BEFORE CALL ERR=72 ERROR:FAULT(ERR,0,FNAM) P=P1; SKIP EXP; %RETURN RES: P=P+1; ! TO P(OPERAND) %IF A(P)=3 %THEN %START; ! B OMITTED PRR(SR,REG,REG) %UNLESS GRUSE(REG)=LITCONST %AND GRINF1(REG)=0 %FINISH %ELSE %START ->ERROR %UNLESS A(P)=1; ! P(OPERAND)=NAME P=P+1; P2=P CNAME(3,REG) %IF TYPE#5 %THEN ERR=71 %AND FNAM=FROMAR2(P2) %AND ->ERROR %IF A(P+1)#CONCOP %THEN ERR=72 %AND ->ERROR P=P+2 %FINISH DUMPRX(ST,REG,0,RBASE,W+8) ->ERROR %UNLESS A(P)=3; ! P(OPERAND)='('(EXPR)')' SEXPRN=SEXPRN+1; P=P+1 CSTREXP(0,-1); ! TO REGISTER DR ! %IF DISP=0 %THEN NEST=BASE %ELSE %C DUMPRX(LA,-1,0,BASE,DISP) DUMPRX(ST,NEST,0,RBASE,W+12) DUMPRX(LA,0,0,RBASE,W) PPJ(0,16,NO) GRUSE(LINKREG)=0 ! DEAL WITH CC#8 IE RESLN FAILED %IF LAB#0 %THEN ENTER JUMP(7,LAB,B'11') %ELSE PPJ(7,12,NO) ! -> END %IF A(P)=2 %IF A(P+1)#CONCOP %THEN ERR=72 %AND ->ERROR P2=P+1; P=P2+1 %IF A(P)=3 %THEN P=P2 %AND ->RES ->ERROR %UNLESS A(P)=1 P=P+3 %AND SKIP APP %UNTIL A(P)=2 %IF A(P+1)=1 %THEN P=P2 %AND ->RES P1=P+1 P=P2+2 CNAME(3,-2) DUMPRX(ST,NEST,0,RBASE,W+8) DUMPRX(LA,0,0,RBASE,W) PPJ(0,15,NO) GRUSE(LINKREG)=0 P=P1 END: P=P+1 %END %ROUTINE RT EXIT !*********************************************************************** !* THIS ROUTINE COMPILES CODE FOR ROUTINE EXIT(IE '%RETURN') * !*********************************************************************** PRX(LM,4,15,RBASE,16) PRR(BCR,15,LINKREG) %END %ROUTINE CLAIM ST FRAME(%INTEGER AT,VALUE) !*********************************************************************** !* FILL LA INSTN IN RT ENTRY SEQUENCE TO CLAIM THE STACKFRAME * !*********************************************************************** %INTEGER INSTR INSTR=LA<<24!VALUE %IF VALUE<4095 %THEN %START %IF PARMCHK=0 %THEN INSTR=INSTR!(WSPR<<4!WSPR)<<16 PLUG(1,AT,INSTR,4) %FINISH %ELSE ABORT; ! DEAL WITH BIG FRAMES LATER %END %ROUTINE CEND (%INTEGER KKK) !*********************************************************************** !* DEAL WITH ALL OCCURENCES OF '%END' * !* KKK=PTYPE(>=X'1000') FOR ROUTINES,FNS AND MAPS * !* KKK=0 FOR ENDS OF '%BEGIN' BLOCKS * !* KKK=1 FOR '%ENDOFPROGRAM' * !* %ENDOFPROGRAM IS REALLY TWO ENDS. THE FIRST IS THE USERS * !* AND THE SECOND IS PERMS. KKK=2 FOR A RECURSIVE CALL OF CEND * !* ON END OF PROGRAM TO DEAL WITH THE %END CORRESPONDING TO * !* THE %BEGIN COMPILED IN THE INITIALISATION SEQUENCE * !*********************************************************************** %INTEGER KP,JJ,BIT %ROUTINESPEC DTABLE(%INTEGER LEVEL) SET LINE %UNLESS KKK=2 FORGETM(14) BIT=1<X'1000' %AND COMPILER=0 %AND LAST INST=0 %C %THEN PPJ(15,10,NO); ! RUN FAULT 11 NMAX=N %IF N>NMAX; ! WORK SPACE POINTER ! ! CLEAR OUT THE LABEL LIST FAULTING LABELS WITH JUMPS OUTSTANDING ! AS NOT SET AND COMMENTING ON LABELS NOT USED ! %WHILE LABEL(LEVEL)#0 %CYCLE POP(LABEL(LEVEL),I,J,KP) I=I>>24 %IF J&X'FFFF'#0 %THEN %START J=J&X'FFFF' %IF 0=X'1000' %OR KKK=1 %THEN CLAIM ST FRAME(SET(RLEVEL),NMAX) ! ! NOW PLANT THE BLOCK EXIT SEQUENCE ! %IF KKK&X'3FFF'=X'1000' %AND LAST INST=0 %THEN RT EXIT PPJ(15,21,NO) %IF KKK=1 %AND LAST INST=0;! %STOP AT %ENDOFPROGRAM %IF KKK=0 %THEN %START; ! BEGIN BLOCK EXIT %IF PARMTRACE=1 %THEN %START; ! RESTORE DIAGS POINTERS DIAG POINTER(LEVEL-1) %FINISH JJ=NMDECS(LEVEL)>>14 %IF JJ#0 %THEN %START; ! ARRAYS TO BE UNDECLARED DUMPRX(LGR,WSPR,0,RBASE,JJ) %FINISH %FINISH ! ! RETURN TO PREVIOUS LEVEL PROVIDED THERE IS A VALID ONE ! ! %UNLESS LEVEL>2 %OR (LEVEL=2 %AND CPRMODE=2) %THEN %START %IF KKK=1 %AND LEVEL=2 %THEN KKK=2 %ELSE FAULT(109,0,0) ! SHOULD BE CHKD IN PASS1 %FINISH LEVEL=LEVEL-1 %IF KKK>=X'1000' %THEN %START REGISTER(RBASE)=0 RLEVEL=RLEVEL-1 RBASE=11-RLEVEL %FINISH ! ! RESTORE INFORMATION ABOUT THE (NEW) CURRENT LEVEL ! POP(LEVELINF,KP,N,KP) NMAX=N>>16 %IF KKK>=X'1000' N=N&X'7FFF' %IF KKK=2 %THEN CEND(KKK); ! ROUND AGAIN FOR 'ENDOFPROGRAM' ! ! COMPLETE THE JUMP AROUND ALL NON-EXTERNAL ROUTINES EXCEPT WHEN ! %TRUSTEDPROGRAM IS IN OPERATION. ! %IF ASL WARN#0 %THEN %C ASL WARN=0 %AND IMPEPILOGUE(LOGEPDISP,EXPEPDISP,POP) %IF KKK>=X'1000' %AND COMPILER=0 %AND(RLEVEL>0 %OR CPRMODE#2)%C %THEN %START JJ=NEXTP+6 %UNLESS A(NEXTP+5)=11 %AND A(JJ+FROMAR2(JJ))=2 %START JJ=ENTER LAB(JROUND(LEVEL+1),0) JROUND(LEVEL+1)=0 %FINISH %FINISH %RETURN ! ! LAYOUT OF DIAGNOSIC TABLES ! ****** ** ********* ****** ! ! THE BOUND FIELD OF PLT DESCRIPTOR STORED AT (LNB+3 & LNB+4) IF ! USED TO CONTAIN A DISPLACEMENT RELATIVE TO THE START OF SST OF THE ! DIAGNOSTIC TABLES FOR THE BLOCK OR ROUTINE BEING EXECUTED. ! A ZERO BOUND MEANS NO DIAGNOSTIC REQUESTED.(NB THIS MAY MEAN A DUMMY ! FIRST WORD IN THE SST). ! THE ABSOLUTE ADDRESS OF THE SST FOR THE CURRENT CODE SEGMENT WILL ! ALWAYS BE FOUND IN THE STANDARD 10 WORDS OF THE GLA/PLT ! ! FORM OF THE TABLES:- ! ! WORD 0 = LINE OF RT IN SOURCE PROG <<16 ! LINE NO POSN(FROM LNB) ! WORD 1 = (12 LANG DEPENDENT BITS)<<18 ! ENVIRONMENT ! ( TOP 2 BITS OF LANG DEPENDENT HAS LITL FROM PTYPE) ! ( BOTTOM 4 BITS HAVE TEXTUAL LEVEL) ! WORD 2 = DISPLAY POSN (FROM LNB)<<16 ! RT TYPE INFO ! WORD 3 = ZERO FOR BLKS OR STRING(<=11BYTES) BEING THE ! RT NAME. THIS WILL TAKE WORDS 4 AND 5 IF NEEDED ! WORD 6 = LANGUAGE DEPENDENT INFO . IMP ON CONDITIONS ETC ! ! THE REST IS MADE UP OF VARIABLE ENTRIES AND THE SECTION IS TERMINATED BY ! A WORD OF X'FFFFFFFF' ! ! EACH VARIABLE ENTRY CONSISTS OF THE VARIABLE WORD FOLLOWED BY ! THE VARIABLE NAME AS A STRING. THE WORD CONSISTS OF ! BITS 2**31 TO 2**20 TYPE INFORMATION (MAY BE LANGUAGE DEPENDENT ! BIT 2**19 =0 UNDER LNB =1 IN GLA ! BITS 2**18 TO 2**0 DISPLACEMENT FROM LNB(GLA) IN BYTES ! ! ! THE ENVIRONMENT IS A POINTER (RELATIVE TO SST) OF THE NEXT OUTERMOST ! BLOCK OR A POINTER TO GLOBAL OWNS, EXTERNAL OR COMMON AREAS ! A ZERO MEANS NO ENCLOSING BLOCK. WORD1=WORD3=0 IS AN ! IMP MAIN PROGRAM AND WILL TERMINATE THE DIAGNOSTICS. ! %ROUTINE DTABLE(%INTEGER LEVEL) !*********************************************************************** !* THIS ROUTINE LOOKS AT THE DECLARATIONS FOR THE CURRENT LEVEL & * !* SETS UP THE SEGMENT OF SHARABLE SYMBOL TABLES TO DESCRIBE THEM.* !* FOR MAIN PROGRAMS OR EXTERNAL ROUTINES THE 'GLOBAL' VARIABLES * !* (IF ANY) ARE ALSO INCLUDED. * !*********************************************************************** %STRING(31) RT NAME %STRING(11) LOCAL NAME %RECORD(LISTF)%NAME LCELL %CONSTINTEGER LARRROUT=X'F300' %INTEGER DPTR,LNUM,ML,KK,JJ,Q,DEND,BIT,S1,S2,S3,S4,LANGD,II %INTEGERARRAY DD(0:500); ! BUFFER FOR SEGMENT OF SST ! ! FILL ALL OUTSTANDING REFERENCES TO THIS DIAGS BLOCK ! BIT=1<>14<<30!LEVEL<<18; ! GET LITL FROM PTYPE %WHILE RAL(LEVEL)#0 %CYCLE POP(RAL(LEVEL),Q,JJ,KK) %IF Q=1 %THEN %START PLUG(1,JJ,MVI<<24!RBASE<<12!(SSTL>>10&255)<<16,4) PLUG(1,JJ+4,MVI<<24!1!RBASE<<12!(SSTL>>2&255)<<16,4) %FINISH %ELSE PLUG(Q,JJ,KK!SSTL,4) %REPEAT PUSH(RAL(LEVEL-1),4,SSTL+4,LANGD) %IF PARMTRACE#0 DD(0)=L(LEVEL)<<16!2 DD(1)=LANGD DD(2)=4*RBASE!FLAG(LEVEL)&X'3FFF' ML=M(LEVEL); ! ROUTINE NAME(=0 FOR %BEGIN) %IF ML#0 %THEN ML=WORD(ML-1); ! IF NOT BLOCK GET DIRPTR LNUM=BYTEINTEGER(DICTBASE+ML); ! LENGTH OF THE NAME DPTR=4; DEND=0 %IF LNUM=0 %THEN DD(3)=0 %ELSE %START Q=DICTBASE+ML RT NAME<-STRING(Q); ! FOR RTS MOVE IN 1ST 32 CHARS LNUM=BYTE INTEGER(ADDR(RT NAME)) STRING(ADDR(DD(3)))=RTNAME; ! AND UPDATE POINTER PAST DPTR=DPTR+LNUM>>2; ! ACTUAL NO OF CHARS %FINISH DD(DPTR)=ONWORD(LEVEL); ! ON CONDITION WORD DPTR=DPTR+1 JJ=NAMES(LEVEL) %WHILE 0<=JJ>16; TYPE=PTYPE&15 ! ! FAULT ALL UNUSED NAMES EXCEPT CONSTINTEGERS&REALS ! %IF (TYPE>2 %OR PTYPE&X'FF00'#X'4000') %C %AND S1&X'C000'=0 %THEN WARN(2,JJ) I=S1>>4&15 J=S1&15 K=S3>>16 ! ! ALLOW OWNS (LITL=0) AND EXTERNALS (=2) NOT CONSTS(=1) OR EXTRINSIC(=3) ! %IF PARMDIAG#0 %AND PTYPE&X'7300'<=X'200' %AND DPTR<497 %C %AND (TYPE=1 %OR TYPE=2 %OR TYPE=5) %START Q=DICTBASE+WORD(JJ); ! ADDRESS OF NAME %IF I=0 %THEN II=1 %ELSE II=0; ! GLA OR LNB BIT DD(DPTR)=PTYPE<<20!II<<18!K LOCAL NAME<-STRING(Q); ! TEXT OF NAME FROM DICTIONARY LNUM=BYTE INTEGER(ADDR(LOCAL NAME)) STRING(ADDR(DD(DPTR))+4)=LOCAL NAME;! MOVE IN NAME DPTR=DPTR+(LNUM+8)>>2 %FINISH %IF J=15 %AND PTYPE&X'3000'#0 %AND S1&X'C000'#0 %THEN %C FAULT(28,0,JJ) ! SPEC&USED BUT NO BODY GIVEN %IF J=15 %AND TYPE=4 %THEN FAULT(62,0,JJ) %IF PTYPE&X'3000'#0 %OR TYPE=4 %OR TYPE=6 %THEN %C CLEAR LIST(K) %ELSE %START %IF I#0 %AND K>4095 %AND PTYPE&LARRROUT=0 %AND TYPE#7 %C %THEN WARN(5,JJ) %FINISH JJ=S4>>18 %REPEAT DD(DPTR)=-1; ! 'END OF SEGMENT' MARK DPTR=DPTR<<2+4 %IF PARMTRACE=1 %THEN %START LPUT(4,DPTR,SSTL,ADDR(DD(0)));! ADD TO SHARABLE SYM TABS SSTL=SSTL+DPTR %FINISH %END; ! OF ROUTINE DTABLE %END %ROUTINE MAKE DECS(%INTEGER Q) !*********************************************************************** !* Q IS TO AR ENTRY FOR HEAD OF LINKED DECLARATIONS * !*********************************************************************** %INTEGER QQ,HEAD,PRIO,COUNT,SL,MARKER %INTEGERNAME THEAD %RECORD(LISTF)%NAME CELL SL=LINE; QQ=FROM AR4(Q) HEAD=0; COUNT=0 %WHILE QQ#0 %CYCLE COUNT=COUNT+1 ABORT %UNLESS A(QQ+5)=8; ! LINE IS A DECLARATION P=QQ+10 MARKER=P+FROMAR2(P) P=P+2 %IF 1<0 %AND ARR>0 %THEN INC=16 %IF PTYPE=X'35' %AND (ACC<=0 %OR ACC>256) %THEN %C FAULT(70,ACC-1,0) %AND ACC=255 %IF PERMIT#0 %AND (INC=8 %OR INC=16) %THEN EVEN ALIGN %IF PTYPE=X'62' %OR PTYPE=X'33' %THEN EVEN ALIGN N=(N+3)&(-4) %UNTIL A(P-1)=2 %CYCLE; ! DOWN THE NAMELIST DMADE=DMADE+1 SCAL NAME=FROM AR2(P) %IF PTYPE=X'31' %AND PERMIT=0 %THEN N=N+3;! BYTE PARAMS %IF PTYPE=X'41' %AND PERMIT=0 %THEN N=N+2 SCHAIN=N KFORM=XTRA %IF ROUT=1 %THEN %START TYPEP=PTYPE; ! CHANGED BY CFPLIST! Q=P P=P+3 %UNTIL A(P-1)=2; ! TO FPP CFPLIST(SCHAIN,NPARMS) P=Q J=13 KFORM=NPARMS; ! NO OF PARAMS OF FORMAL ACC=N; ! DISPLACEMENT TO MIDCELL PTYPE=TYPEP; UNPACK %FINISH P=P+3 %IF PTYPE=X'33' %THEN %START SCHAIN=N %FINISH STORE TAG(SCAL NAME,SCHAIN) N=N+INC %REPEAT %IF PERMIT#0 %THEN N=(N+3)&(-4); ! THIS IS NECESSARY ! %END %INTEGERFN DOPE VECTOR(%INTEGER TYPEP,ELSIZE,MODE,IDEN, %C %INTEGERNAME ASIZE,LB) !*********************************************************************** !* CONSTRUCTS THE DOPE-VECTOR FOR A CONSTANT ARRAY IN THE * !* SHAREABLE SYMBOL TABLES AND RETURNS ITS DISPLACEMENT AS RESULT* !* EVENTUALLY ALL NON DYNAMIC DOPE VECTORS SHOULD GO VIA HERE * !* P IS TO ALT (MUST BE 1!) OF P * !* DOPE VECTOR CONSISTS OF :- * !* WORD CONTAINING THE NO OF DIMENSIONS ND * !* SIZE (IN BYTES) OF A SINGLE ELEMENT * !* SIZE (IN BYTES OF ENTIRE ARRAY) FOR STACK ADJUSTMENT * !* AND ND TRIPLES EACH CONSISTING OF:- * !* LBI - THE LOWER BOUND OF THE ITH DIMENSION * !* UBI THE UPPER BOUND OF THE ITH DIMENSION * !* RI - THE STRIDE FOR THE ITH DIMENSION=(UBI-LBI+1) * !* MODE=0 DV MUST BE CONST, MODE#0 CAN BE DYNAMIC * !* MODE=-1 SPECIAL FOR CONSTARRAYNAMES 1D 0:INFINITY * !* P TO ALT (ALWAYS=1) OF P(BPAIR) * !*********************************************************************** %INTEGER I, JJ, K, ND, D, M0, HEAD, NOPS, TYPEPP, PIN, PTR %RECORD(LISTF)%NAME LCELL %INTEGERARRAY LBH,LBB,UBH,UBB(0:12) %INTEGERARRAY DV(0:39); ! ENOUGH FOR 12 DIMENSIONS ND=0; NOPS=0; TYPEPP=0; PIN=P M0=1 %IF MODE=-1 %THEN %START ND=1; DV(3)=0 M0=X'FFFFFF' DV(4)=M0 DV(5)=M0 ASIZE=M0 %FINISH %ELSE %START %UNTIL A(P)=2 %CYCLE ND=ND+1; P=P+4 FAULT(37,0,IDEN) %AND ND=1 %IF ND>12 LBH(ND)=0; LBB(ND)=0 UBB(ND)=0; UBH(ND)=0 TORP(LBH(ND),LBB(ND),NOPS) P=P+3 TYPEPP=TYPEPP!TYPE TORP(UBH(ND),UBB(ND),NOPS) TYPEPP=TYPEPP!TYPE %REPEAT P=P+1 ->NONCONST %UNLESS TYPEPP=1 %AND NOPS&X'40040000'=0 ! ! NOW ONE CAN WORK OUT AND FILL IN THE TRIPLES ! PTR=1 %CYCLE D=1,1,ND K=3*D EXPOP(LBH(PTR),-1,NOPS,X'251') EXPOPND_D=0 %AND FAULT(41,0,0) %UNLESS %C EXPOPND_FLAG<=1 %AND EXPOPND_PTYPE=X'51' DV(K)=EXPOPND_D EXPOP(UBH(PTR),-1,NOPS,X'251') EXPOPND_D=10 %AND FAULT(41,0,0) %UNLESS %C EXPOPND_FLAG<=1 %AND EXPOPND_PTYPE=X'51' JJ=EXPOPND_D DV(K+1)=JJ DV(K+2)=JJ-DV(K)+1 FAULT(38,1-DV(K+2),IDEN) %UNLESS JJ>=DV(K) M0=M0*DV(K+2) PTR=PTR+1 %REPEAT ASIZE=M0*ELSIZE %FINISH ! ! CALCULATE THE OFF SET OF A(FIRST,..) FROM A(0,..) ! LB=DV(3); I=6 %WHILE I<=3*ND %CYCLE LB=LB+DV(I)*DV(I-1) I=I+3 %REPEAT LB=LB*ELSIZE FAULT(39,0,IDEN) %IF ASIZE>X'FFFFFF' DV(2)=(ASIZE+7)&(-8) DV(0)=ND DV(1)=ELSIZE K=3*ND+2 J=ND; ! DIMENSIONALITY FOR DECLN HEAD=DVHEADS(ND) %WHILE HEAD#0 %CYCLE LCELL==ASLIST(HEAD) %IF LCELL_S2=ASIZE %AND LCELL_S3=DV(5) %START %CYCLE D=0,1,K ->ON %UNLESS DV(D)=CTABLE(D+LCELL_S1) %REPEAT %RESULT=4*LCELL_S1 %FINISH ON: HEAD=LCELL_LINK %REPEAT I=4*CONST PTR PUSH(DVHEADS(ND),CONSTPTR,ASIZE,DV(5)) %CYCLE D=0,1,K CTABLE(CONST PTR)=DV(D) CONST PTR=CONST PTR+1 %REPEAT %IF CONST PTR>CONST LIMIT %THEN FAULT(102, WKFILEK,0) WAYOUT: %IF MODE=-1 %THEN %RESULT=I; ! NO EXPRESSION CELLS TO RETURN %CYCLE D=ND,-1,1 ASLIST(LBB(D))_LINK=ASL ASL=LBH(D) ASLIST(UBB(D))_LINK=ASL ASL=UBH(D) %REPEAT %RESULT =I NONCONST: ! NOT A CONST DV J=ND; I=-1 LB=0; ASIZE=ELSIZE %IF MODE=0 %THEN FAULT(41,0,0) %ELSE P=PIN ->WAYOUT %END %ROUTINE DECLARE ARRAYS(%INTEGER FORMAT, FINF) !*********************************************************************** !* FORMAT=1 FOR 'ARRAYFORMAT' =0 OTHERWISE * !* FINF>0 FOR RECORD FORMAT INFORMATION =0 OTHERWISE * !* P IS AT P IN * !* * !* P= * !* P = '('':'*')' * !* * !* ARRAYS WITH CONSTANT BOUNDS HAVE THEIR D-V IN THE SST * !* ALL OTHER ARRAYS HAVE A DOPE VECTOR AMONG THE LOCALS AND GET * !* THEIR SPACE OFF THE STACK AT RUN TIME * !* BOTH SORTS OF ARRAYS HAVE A FOUR WORD HEAD AND D-V TO EMAS * !* SYSTEM STANDARDS * !*********************************************************************** %ROUTINESPEC CLAIM AS %ROUTINESPEC COMPUTE ZAD %INTEGER DVDISP, PP, DVF, ELSIZE, TOTSIZE, LB, LAD, PTYPEP, WREG, %C ARRP, NN, ND, II, QQ, R, CDV, INITN, LWB, PTYPEPP, JJJ %INTEGERARRAY LBNDS(0:12) %IF FLAG(LEVEL)=0 %AND NMDECS(LEVEL)>>14=0 %START DUMPRX(ST,WSPR,0,RBASE,N); ! SAVE STACK PTR NMDECS(LEVEL)=NMDECS(LEVEL)!N<<14 N=N+4 %FINISH ARRP=2*FORMAT+1; ARR=ARRP; PACK(PTYPEP) ELSIZE=ACC START:NN=1; P=P+1; ! NO OF NAMES IN NAMELIST PP=P; CDV=0; PTYPEPP=PTYPEP P=P+3 %AND NN=NN+1 %WHILE A(P+2)=1 P=P+3 DVDISP=DOPE VECTOR(TYPE,ELSIZE,1,FROMAR2(PP),TOTSIZE,LWB) ND=J ->CONSTDV %UNLESS DVDISP=-1 ! ! NORMAL CASE - PLANT CODE TO SET UP DOPE-VECTOR AT RUN TIME ! DVF=1; TOTSIZE=X'FFFF' DVDISP=N; ! DVDISP IS D-V POSITION N=N+12*ND+12; ! CLAIM SPACE FOR THE D-V FIND SEQ(WREG,R) DUMPRX(LA,WREG,0,0,ND) GRUSE(WREG)=LITCONST; GRINF1(WREG)=ND %IF ELSIZE=ND %THEN PRR(LR,R,WREG) %ELSE DUMPRX(LA,R,0,0,ELSIZE) GRUSE(R)=LITCONST; GRINF1(R)=ELSIZE DUMPM(STM,WREG,R,RBASE,DVDISP) ! %CYCLE II=1,1,ND LBNDS(II)=X'1000000' P=P+1 QQ=DVDISP+12*II; ! TRIPLE FOR IITH DIMENSION CSEXP(-1,X'51'); ! LOWER BOUND WREG=EXPOPND_XB ! ! KEEP TRACK OF LOWER BOUNDS TO MINIMISE RUN TIME WORK IN COMPUTING ! THE BASE ADDRESS ! %IF GRUSE(WREG)=LITCONST %START LBNDS(II)=GRINF1(WREG) DVF=0 %UNLESS II=1 %OR LBNDS(II)=0 %FINISH %ELSE DVF=0 DUMPRX(ST,WREG,0,RBASE,QQ) CSEXP(-1,X'51'); ! UPPER BOUND WREG=EXPOPND_XB DUMPRX(ST,WREG,0,RBASE,QQ+4) %IF LBNDS(II)DECL CONSTDV: ! ONE DIMENSION - CONSTANT BOUNDS DVF=1; CDV=1 %IF ND=1 %AND LWB=0 %AND PTYPEP&15<=3 %C %AND FORMAT=0 %THEN PTYPEPP=PTYPEP+256 ! SET ARR=2 IF LWB=ZERO SNDISP=(DVDISP&X'FFFFFF')>>2 DECL: ! MAKE DECLN - BOTH WAYS J=ND %CYCLE JJJ=0,1,3 CLAIM THIS REG(JJJ) GRUSE(JJJ)=0 %REPEAT PTYPE=PTYPEPP; UNPACK %IF CDV#0 %THEN R=CTABLEREG %ELSE R=RBASE DUMPRX(LA,2,0,R,DVDISP) %IF ND=2 %THEN R=20 %ELSE R=4 PRX(LGR,3,0,2,R) %IF TYPE=5 %THEN %C DUMPRX(X'56',3,0,CTABLEREG,WORDCONST((ELSIZE-1)<<24)) INITN=N %CYCLE JJJ=0,1,NN-1; ! DOWN NAMELIST %IF DVF#0 %START; ! COMPILETIME DV %IF LWB=0 %THEN PRR(LR,0,WSPR) %ELSE %START DUMPRX(LGR,0,0,CTABLEREG,WORDCONST(-LWB)) PRR(AR,0,WSPR) %FINISH %FINISH %ELSE %START; ! DYNAMIC ARRAYS %IF JJJ#0 %THEN %START; ! ALL BAR THE FIRST IN LIST DUMPRX(LGR,0,0,RBASE,INITN) DUMPRX(SUB,0,0,RBASE,INITN+4) %FINISH %ELSE COMPUTE ZAD PRR(AR,0,WSPR) %FINISH PRR(LR,1,WSPR) DUMPM(STM,0,3,RBASE,N) ACC=ELSIZE; ! RESET ACC AFTER DV CMPLD KFORM=FINF; ! FORMAT INFORMATION K=FROM AR2(PP+3*JJJ) STORE TAG(K,N) CLAIM AS %IF FORMAT = 0 N=N+16 %REPEAT %CYCLE JJJ=0,1,3 REGISTER(JJJ)=0 %REPEAT P=P+1; ! PAST REST OF ARRAYLIST %IF A(P-1)=1 %THEN ->START %RETURN %ROUTINE COMPUTE ZAD !*********************************************************************** !* FIND THE OFFSET OF A(0...) FROM A(FIRST...) BY COMPUTING * !* THE OFFSET OF A(FIRST...) FROM A(0...) AND NEGATING * !*********************************************************************** %INTEGER JJ,OP %IF ND=1 %THEN OP=LGR %ELSE %START;! MULTI DIMENSION DUMPRX(LGR,0,0,RBASE,DVDISP+12*ND) DUMPRX(MH,0,0,RBASE,DVDISP+12*ND-2) %CYCLE JJ=ND-1,-1,2 %IF LBNDS(JJ)#0 %THEN %START DUMPRX(LGR,-1,0,RBASE,DVDISP+12*JJ) DUMPRX(MH,NEST,0,RBASE,DVDISP+12*JJ-2) PRR(AR,0,NEST) %FINISH %REPEAT OP=ADD %FINISH DUMPRX(OP,0,0,RBASE,DVDISP+12) %UNLESS LBNDS(1)=0 %AND OP=ADD DUMPRX(MH,0,0,CTABLEREG,WORD CONST(-ELSIZE)+2) %END %ROUTINE CLAIM AS !*********************************************************************** !* CLAIM THE SPACE FOR AN ARRAY FROM STACK * !*********************************************************************** %IF PARMCHK=0 %THEN %START DUMPRX(ADD,WSPR,0,2,8) %FINISH %ELSE %START PRR(SR,1,1) DUMPRX(LGR,0,0,2,8) DUMPRX(BAL,LINKREG,0,CODER,PLABS(4)) GRUSE(1)=0 GRUSE(0)=0 GRUSE(LINKREG)=0 %FINISH CHECK STOF %IF PARM OPT#0 %END %END %ROUTINE CLT !*********************************************************************** !* DEAL WITH PHRASE TYPE AND SET PREC,TYPE & ACC * !* ONLY PROBLEM ARE STRINGS WHICH HAS OPTIONAL MAX LENGTH ALSO * !* RECORD WHICH HAVE A FORMAT * !* P ON PHRASE TYPE AT ENTRY - TO NEXT PHRASE AT EXIT. * !*********************************************************************** %CONSTBYTEINTEGERARRAY TYPEFLAG(1:7)= %C X'51',X'52',X'62',X'31',X'35', X'41',X'33'; %INTEGER ALT,PTYPEP,I ALT=A(P) TYPE=TYPEFLAG(ALT) %IF ALT=4 %OR ALT=6 %THEN P=P+1 PREC=TYPE>>4 TYPE=TYPE&7 P=P+1 ACC=BYTES(PREC) PACK(PTYPEP); ! PRESERVE ALL COMPONENT ! BEFORE CALLINT INTEXP ETC %IF TYPE=5 %THEN %START; ! P='%STRING' %IF A(P)=1 %THEN %START; ! MAX LENGTH GIVEN %IF A(P+1)=1 %START; ! EXPRESSION NOT STAR P=P+4 %IF INTEXP(I)#0 %THEN FAULT(41,0,0) ACC=I+1 PTYPE=PTYPEP; UNPACK %FINISH %ELSE ACC=0 %AND P=P+2 %FINISH %ELSE ACC=0 %AND P=P+1 %FINISH KFORM=0 %IF TYPE=3 %THEN KFORM=CFORMATREF %AND PTYPE=PTYPEP %AND UNPACK %END %ROUTINE CQN(%INTEGER P) !*********************************************************************** !* SET NAM & ARR FROM ALTERNATIVE OF PHRASE * !* P='%ARRAYNAME','%NAME',<%NULL> * !* P POINTS TO THE ANALYSIS RECORD ENTRY AS IS NOT UPDATED * !*********************************************************************** %INTEGER I I=A(P);NAM=0;ARR=0 %IF I=1 %THEN ARR=1; ! ARRAYNAMES %IF I<=2 %THEN NAM=1; ! ARRAYNAMES & NAMES %END %INTEGERFN SET SWITCHLAB(%INTEGER HEAD,LAB,FNAME,BIT) !*********************************************************************** !* SET A SWITCH LABEL AND RETURNS RESULT=0 %UNLESS THE LABEL * !* HAS BEEN ALREADY SET WHEN IT RETURNS RESULT#0 * !* HEAD IS HEAD OF THE TAGS SIDECHAIN FOR THE SWITCH * !*********************************************************************** %INTEGER Q,QQ,JJJ,LB,UB,BASEPT %RECORDFORMAT BITFORM(%INTEGERARRAY BITS(0:2),%INTEGER LINK) %RECORD(BITFORM)%NAME BCELL %RECORD(LISTF)%NAME LCELL FORGETM(14) OLDLINE=0 LCELL==ASLIST(HEAD) BASEPT=LCELL_S1 LB=LCELL_S2 UB=LCELL_S3 HEAD=LCELL_LINK BCELL==ASLIST(HEAD) %UNLESS LB<=LAB<=UB %THEN FAULT(50,LAB,FNAME) %AND %RESULT=0 Q=LAB-LB %WHILE Q>=96 %%CYCLE HEAD=BCELL_LINK BCELL==ASLIST(HEAD) Q=Q-96 %REPEAT ! ! ASLIST(HEAD) IS THE START OF 96 BIT ENTRY IN THE BIT LIST ! CHECK BIT NO Q TO SEE IF LABEL ALREADY SET AND THEN SET BIT Q ! QQ=Q>>5; ! RIGHT WORD Q=Q&31; JJJ=1<=%ROUTINE TYPEP=LITL<<14!X'1000' P=P+2; ! IGNORING ALT OF P(SPEC') %FINISH %ELSE %START; ! P= ROUT=1; ARR=0; P=P+1 CLT; NAM=0 %IF A(P)=2 %THEN NAM=2; ! 2 FOR MAP 0 FOR FN PACK(TYPEP) P=P+2; ! AGAIN IGNORING ALT OF P(SPEC') %FINISH P=P+4; ! PAST HOLE FOR DECLINKS KK=FROM AR2(P) XNAME<-STRING(DICTBASE+WORD(KK)) %IF EXTRN=1 %THEN XNAME<-"S#".XNAME JJ=0 P=P+3 %IF A(P-1)=1 %THEN XNAME<-STRING(ADDR(A(P))) %AND %C P=P+A(P)+1 CFPLIST(OPHEAD,NPARMS) %IF M=1 %THEN %START CXREF(XNAME,PARMDYNAMIC!(EXTRN//3),2,JJ); ! %STSTEM & %EXTERNAL =STATIC ! %DYNAMIC = DYNAMIC %FINISH %IF M=0 %AND RLEVEL=0 %START %IF CPRMODE=0 %THEN CPRMODE=2 %IF CPRMODE#2 %THEN FAULT(56,0,KK) %FINISH J=15-M; PTYPE=TYPEP KFORM=NPARMS SNDISP=JJ>>16 ACC=JJ&X'FFFF' STORE TAG(KK,OPHEAD) %END %ROUTINE CFPLIST(%INTEGERNAME OPHEAD,NPARMS) !*********************************************************************** !* COMPILE A FORMAL PARAMETER PART INTO A LIST OF PARAMETER TYPES * !* P(FPP)='('{(HOLE)(FPDEL)(NAMELIST)(MARK)}*')',0. * !* * !* THE LIST OF PARAMETER LOOKS LIKE:- * !* S1 = PTYPE FOR PARAM<<16! DIMENSION (DIMEN DEDUCED LATER) * !* S2 = ACC <<16 ! SPARE * !* S3 = 0 (RESERVED FOR FPP OF RTS) * !* * !* ON ENTRY P IS AT ALT OF FPP (WHICH MAY BE NULL) * !*********************************************************************** %INTEGER OPBOT, PP, PSIMPLE OPHEAD=0; OPBOT=0 NPARMS=0; PSIMPLE=1; ! ZERO PARAMETERS AS YET %WHILE A(P)=1 %CYCLE; ! WHILE SOME(MORE) FPS PP=P+1+FROMAR2(P+1); ! TO NEXT FPDEL P=P+3; ! TO ALT OF FPDEL CFPDEL; ! GET TYPE & ACC FOR NEXT GROUP PSIMPLE=0 %UNLESS PTYPE=X'51' %OR %C (ROUT=0 %AND ARR=0 %AND NAM=1 %AND TYPE#0) %UNTIL A(P-1)=2 %CYCLE; ! DOWN FOR EACH DEL BINSERT(OPHEAD,OPBOT,PTYPE<<16,ACC<<16,0) NPARMS=NPARMS+1 P=P+3 %REPEAT P=PP %REPEAT P=P+1 %IF NPARMS>0 %THEN NPARMS=NPARMS!PSIMPLE<<12 %END %ROUTINE CFPDEL !*********************************************************************** !* SET UP PTYPE & ACC FOR A FORMAL PARAMETER DEFINITION * !* P=<%QNAME'>, * !* (RT)(%NAME')(NAMELIST)(FPP), * !* '%NAME'. * !*********************************************************************** %SWITCH FP(1:3) %INTEGER FPALT FPALT=A(P); P=P+1 KFORM=0; LITL=0 ->FP(FPALT) FP(1): ! (TYPE)(%QNAME') ROUT=0; CLT CQN(P) %IF TYPE=5 %AND NAM=0 %AND (ACC<=0 %OR ACC>256) %THEN %C FAULT(70,ACC-1,0) %AND ACC=255 P=P+1 ->PK FP(2): ! (RT)(%NAME')(NAMELIST)(FPP) ROUT=1; NAM=1 ARR=0 %IF A(P)=1 %THEN %START; ! RT=%ROUITNE TYPE=0; PREC=0 P=P+2 %FINISH %ELSE %START P=P+1; CLT; ! RT=(TYPE)(FM) NAM=1 %IF A(P)=2 %THEN NAM=3; ! 1 FOR FN 3 FOR MAP P=P+2; ! PAST (%NAME') WHICH IS IGNORED %FINISH ACC=16 ->PK FP(3): ! %NAME ACC=8; NAM=1 ROUT=0; TYPE=0 ARR=0; PREC=0 PK: PACK(PTYPE) %END %ROUTINE DIAG POINTER(%INTEGER LEVEL) !*********************************************************************** !* PLANT CODE TO UPDATE THE DIAGNOSTIC POINTER. SINCE THE * !* VALUE WILL NOT BE KNOWN TILL THE DTABLE IS GENERATED PLANT * !* NO-OPS AND OVERWRITE IN ROUTINE DTABLE * !*********************************************************************** %IF PARMTRACE#0 %THEN %START PUSH(RAL(LEVEL),1,CA,0) PCONST(X'47000000') PCONST(X'47000000') %FINISH %END %ROUTINE RHEAD(%INTEGER KK) !*********************************************************************** !* COMPILES CODE FOR BLOCK AND ROUTINE ENTRY * !* KK IS THE RT/FN/MAP NAME (=-1 FOR %BEGIN BLOCKS) * !*********************************************************************** %INTEGER W1, W3, INSRN, AT PUSH(LEVELINF, 0, NMAX<<16!N, 0) LEVEL=LEVEL+1 NMDECS(LEVEL)=0 NAMES(LEVEL)=-1 ONINF(LEVEL)=0; ONWORD(LEVEL)=0 %IF KK>=0 %THEN %START RLEVEL=RLEVEL+1; RBASE=11-RLEVEL REGISTER(RBASE)=-1 GRUSE(RBASE)=NAMEBASE GRINF1(RBASE)=RLEVEL %FINISH FAULT(34, 0, 0) %IF LEVEL=MAX LEVELS FAULT(105, 0, 0) %IF LEVEL>MAX LEVELS %IF KK>=0 %START; ! ROUTINE ENTRY COPY TAG(KK); JJ=K; ! LIST OF JUMPS J=MIDCELL %IF J=0 %AND LEVEL>2 %START; ! REPLACE 'NOT USED' BIT REPLACE1(TAGS(KK), FROM1(TAGS(KK))&X'FFFF3FFF') %FINISH ! ! NOW FILL ANY JUMPS TO THIS ROUTINE PLANTED SINCE ! THE ROUTINESPEC WAS COMPILED. SEE ALSO 'RT JUMP' ! %WHILE J#0 %CYCLE POP(J, INSRN, AT, W1) W3=CA>>12 FAULT(98,0,0) %IF W3>MAX4KMULT PLUG(1, AT+2, W3<<2+FOURKTDISP, 2) PLUG(1, AT+6, CODER<<12!CA&4095, 2) %REPEAT REPLACE2(TAGS(KK), CA); ! NOTE ADDR FOR FUTURE CALLS %FINISH %IF KK<0 %THEN W3=0 %ELSE W3=KK+1 L(LEVEL)=LINE; M(LEVEL)=W3 FLAG(LEVEL)=PTYPE; ! CURRENT BLOCK TYPE MARKER %END %ROUTINE RDISPLAY(%INTEGER KK) !*********************************************************************** !* SET UP OR COPY THE DISPLAY * !* SINCE THIS IS IN REGISTERS ON 360 IT IS EASY * !* ALSO CLAIM STACK SPACE AND SET DIAGNOSTIC POINTERS * !*********************************************************************** %INTEGER W1,W2 %IF KK>=0 %OR LEVEL=2 %START; ! DISPLAY NEEDED FORGETM(14) CCSTATE=-1 %IF KK>=0 %AND EXTRN<4 %THEN %C PRX(LGR,CTABLEREG,0,GLA,24) PRX(ST,LINKREG,0,WSPR,60); ! SAVE RETURN ADDRESS PRR(LR,RBASE,WSPR) %FINISH ! ! IF IN DIAGNOSTIC MODE PLANT CODE TO SAVE THE LINE & ROUTINE NO OF ! THE CALLING ROUTINE AND SET UP THE NEW BLOCK/ROUTINE IDENT NO. ! %IF PARMTRACE#0 %START DIAG POINTER(LEVEL) %FINISH OLDLINE=0 SET LINE ! ! NORMALLY CODE IS PLANTED HERE TO CHECK PARAMETERS BUT I CANNOT ! SEE HOW TO DO THIS ON 360 ARCHITECTURE ! ! ! CLAIM (THE REST OF) THE STACK FRAME ! %IF KK>=0 %OR LEVEL=2 %START SET(RLEVEL)=CA NMAX=N %IF PARMCHK#0 %THEN W1=0 %ELSE W1=WSPR PRX(LA,W1,W1,0,0) PRX(LA,1,0,0,N) %AND PPJ(0,4,YES) %IF PARMCHK#0 CHECK STOF %FINISH %END %ROUTINE CHECK STOF !*********************************************************************** !* CHECK THE STACK FOR OVERFLOW. WORD 7 OF GLA HOLDS * !* THE ADDRESS OF A SYSTEM WORD HOLDING THE STACK LIMIT * !*********************************************************************** %INTEGER BASE,ADD,REG %IF PARMOPT#0 %THEN %START ! ! L 1,28(GLA) GET ADDRESS ! LTR 1,1 CHECK FOR ZERO ! BC 8,*+12 AND OMIT THE CHECK ! C WSPR,0(1) ! BC 2,STACK OVERFLOW ! SET LOCAL BASE(BASE,ADD) FINDREG(GR1,REG) PRX(LGR,REG,GLA,0,28) PRR(LTR,REG,REG) PRX(BC,8,BASE,0,CA+12-ADD) PRX(COMP,WSPR,REG,0,0) PPJ(2,8,NO) FORGET(REG) %FINISH %END %ROUTINE CIOCP(%INTEGER N) !*********************************************************************** !* COMPILES A CALL ON IOCP ENTRY POINT NO 'N' * !* 2ND PARAMETER IS ALREADY IN GR1 * !*********************************************************************** %INTEGER MOVEPTR %IF IOCPDISP=0 %THEN CXREF(IOCPEP,PARMDYNAMIC,2,IOCPDISP) MOVEPTR=(FPTR+7)&(-8) SAVEIRS(8) %IF FPTR>64 %THEN MOVER(WSPR,MOVEPTR) DUMPRX(LA,0,0,0,N) DUMPM(STM,4,1,WSPR,16) DUMPM(LM,CODER,EPREG,GLA,IOCPDISP) PRR(BALR,LINKREG,EPREG) %IF FPTR>64 %THEN MOVER(WSPR,-MOVEPTR) FORGETM(8) %END %ROUTINE CUI(%INTEGER CODE) !*********************************************************************** !* COMPILE AN UNCONDITIONAL INSTRN WHEREEVER IT OCCURS * !* CODE=0 UNCONDITIOALLY,=1 AFTER %THEN, =2 AFTER %ELSE * !*********************************************************************** %INTEGER MARKER,J,LNAME,TYPEP,PRECP,GWRDD,LWB,UPB,SREG,ARRP,ALT,KK %INTEGER HEAD1,BOT1,NOPS %SWITCH SW(1:9) REPORTUI=0 ALT=A(P) ->SW(ALT) SW(1): ! (NAME)(APP)(ASSMNT?) P=P+1; MARKER=P+FROMAR2(P) %IF A(MARKER)=1 %THEN %START J=P+2; P=MARKER+2 ASSIGN(A(MARKER+1),J) %FINISH %ELSE %START P=P+2 CNAME(0,0) P=P+1 %FINISH AUI: J=A(P); P=P+1 %IF J=1 %THEN CUI(CODE) %RETURN SW(2): ! -> (NAME)(APP) NMDECS(LEVEL)=NMDECS(LEVEL)!1 CURR INST=1 %IF CODE=0 LNAME=FROM AR2(P+1) J=A(P+3); P=P+4 %IF J=2 %THEN %START; ! SIMPLE LABEL ENTER JUMP(15,LNAME,0) REPORTUI=1 %FINISH %ELSE %START; ! SWITCH LABELS COPY TAG(LNAME) ARRP=ARR GWRDD=SNDISP<<2; ! BYTE DISP OF DESCRIPTOR IN PLT %UNLESS OLDI=LEVEL %AND TYPE=6 %START FAULT(4,0,LNAME); P=P-1; SKIP APP %RETURN %FINISH LWB=FROM2(K); ! GET LOWER BOUND UPB=FROM3(K); ! AND UPPER BOUND CSEXP(-2,X'51') SREG=NEST; REGISTER(SREG)=1 DUMPRX(SUB,SREG,0,CTABLEREG,WORDCONST(LWB)) %C %UNLESS PARMARR=0 %AND LWB=0 %IF PARMARR#0 %START; ! PERFORM THE BOUND CHECK PPJ(4,13,NO) DUMPRX(COMP,SREG,0,CTABLEREG,WORDCONST(UPB-LWB)) PPJ(2,13,NO) %FINISH PRX(SLL,SREG,0,0,2); ! SCALE DUMPRX(LGR,-2,0,GLA,GWRDD) DUMPRX(LGR,SREG,NEST,SREG,0); ! PICK UP TBALE ENTRY DUMPRX(BC,15,SREG,CODER,0) REGISTER(SREG)=0; GRUSE(SREG)=0 GRUSE(NEST)=0 REPORTUI=1; FORGETM(14) %FINISH %RETURN SW(3): ! RETURN FAULT(30,0,0) %UNLESS FLAG(LEVEL)&X'3FFF'=X'1000' P=P+1 RET: RT EXIT REPORT UI=1 CURR INST=1 %IF CODE=0 %RETURN SW(4): ! %RESULT(ASSOP)(EXPR) PTYPE=FLAG(LEVEL)&X'3FFF'; UNPACK %IF PTYPE>X'1000' %AND A(P+1)#3 %THEN %START;! ASSOP #'->' %IF A(P+1)=1 %AND NAM#0 %AND A(P+5)=4 %AND A(P+6)=1 %START P=P+7; TYPEP=TYPE; PRECP=PREC; J=P CNAME(4,1) FAULT(81,0,0) %UNLESS A(P)=2; P=P+1 FAULT(83,M(LEVEL)-1,FROMAR2(J)) %C %UNLESS TYPEP=TYPE %AND PRECP=PREC ->RET %FINISH %IF A(P+1)=2 %THEN %START; ! ASSOP='=' P=P+2 %IF NAM#0 %THEN TYPE=1; ! MAPS HAVE INTEGER RESULTS %IF TYPE=5 %THEN %START CSTREXP(0,1) %FINISH %ELSE %START %IF PREC<5 %THEN PREC=5 %IF NAM=0 %THEN KK=PREC<<4!TYPE %ELSE KK=X'51' %IF TYPE=2 %THEN J=FPRESULTREG %ELSE J=1 CSEXP(J,KK) %FINISH; ->RET %FINISH %FINISH FAULT(31,0,0) P=P+2; SKIP EXP; ! IGNORE SPURIOUS RESULT %RETURN SW(5): ! %MONITOR (AUI) PRR(SR,0,0); ! ERR=0 PRR(SR,1,1); ! EXTRA=0 PPJ(0,2,YES); ! TO ERROR ROUTINE P=P+1; ->AUI SW(6): ! %STOP PPJ(0,21,YES) P=P+1 CURR INST=1 %IF CODE=0 REPORTUI=1 %RETURN SW(7): !'%SIGNAL'(EVENT')(N)(OPEXPR) P=P+5; KK=INTEXP(J) FAULT(26,J,0) %UNLESS KK=0 %AND 1<=J<=15 HEAD1=0; NOPS=0 PUSH(HEAD1,X'51'<<16!1,256*J,0); ! EVENT<<8 AS CONST BOT1=HEAD1 %IF A(P)=1 %START; ! SUBEVENT SPECIFIED PUSH(HEAD1,27,0,0); ! OPERATOR & PUSH(HEAD1,X'51'<<16!1,255,0); ! CONST=F'255' P=P+4; TORP(HEAD1,BOT1,NOPS) BINSERT(HEAD1,BOT1,23,0,0); ! OPERATOR ! NOPS=NOPS+2 %FINISH EXPOP(HEAD1,0,NOPS,X'51'); ! EVALUATE TO GR0 ASLIST(BOT1)_LINK=ASL ASL=HEAD1 HEAD1=0 PRR(SR,1,1) %IF NMDECS(LEVEL)&16 #0 %START; ! IN AN 'ON' GROUP %IF FLAG(LEVEL)<=2 %START; ! IN A BEGIN BLOCK DIAGPOINTER(LEVEL-1); ! TO NEXT OUTER BLOCK %FINISH %ELSE %START; ! 'ON IN A RT/FN/MAP PRX(LM,4,WSPR,RBASE,16) %FINISH %FINISH PPJ(0,2,YES) CURR INST=1 %IF CODE=0 REPORTUI=1; %RETURN SW(8): ! %EXIT SW(9): ! %CONTINUE ALT=ALT&7; ! 0 FOR EXIT 1 FOR CONTINUE %IF EXITLAB=0 %THEN FAULT(54+ALT,0,0) %AND %RETURN KK=INTEGER(ADDR(EXITLAB)+4*ALT) ENTER JUMP(15,KK&X'FFFFFF',B'10'!KK>>31) REPORTUI=1 CURR INST=1 %IF CODE=0 %END %ROUTINE CIFTHEN(%INTEGER MARKIU,MARKC,MARKUI,MARKE,MARKR,SKIP) !*********************************************************************** !* THIS ROUTINE COMPILES CONDITIONAL EXPRESSIONS.IT REQUIRES THE * !* FOLLOWING PARAMETERS TO BE SET TO THEIR A .R. ENTRY. * !* MARKIU TO THE ENTRY FOR P(%IU) * !* MARKC TO THE ENTRY FOR P(COND) * !* MARKUI TO THE ENTRY FOR (FIRST OCCURRENCE OF) P(UI) * !* MARKE TO THE ENTRY FOR P(ELSE') - =0 FOR BACKWARDS CONDITION * !* MARKR TO ENTRY FOR P(RESTOFIU) - =0 FOR BACKWARDS CONDITION * !*********************************************************************** %INTEGER ALTUI,CCRES,ELRES,THENLAB,ELSELAB,USERLAB,REPORT,START, %C ELSEALT,K,CS %CONSTINTEGER NULL ELSE=4 %SWITCH ESW(1:NULL ELSE) SET LINE %UNLESS SKIP=YES MARKIU=A(MARKIU); ! ALT OF IU 1=%IF,2=%UNLESS PLABEL=PLABEL-1 THENLAB=PLABEL START=0; CS=0; ! NO START IN CONDITION YET ELSELAB=0; ! MEANS NO ELSE CLAUSE P=MARKC %IF MARKR>0 %AND A(MARKR)<=2 %THEN %C START=1 %AND CS=CHECK BLOCK(MARKR+1);! '%START' OR '%THENSTART' %IF MARKE#0 %AND LEVEL<2 %AND START=0 %THEN FAULT(57,0,0) USERLAB=-1 %IF START#0 %THEN ALTUI=0 %ELSE ALTUI=A(MARKUI) %IF ALTUI=2 %AND A(MARKUI+3)=2 %THEN %C USERLAB=FROM AR2(MARKUI+1); ! UI = SIMPLE LABEL %IF 8<=ALTUI<=9 %AND EXITLAB#0 %START; ! VALID EXIT %IF ALTUI=8 %THEN USERLAB=EXITLAB %ELSE USERLAB=CONTLAB %FINISH ! %IF SKIP=YES %THEN %START; ! NO CODE NEEDED %IF START#0 %START P=MARKR+1 CSTART(2,1); ! NO CODE MARKE=P %FINISH CCRES=1; ! NO CODE FOR ELSE ->ELSE %FINISH ! %IF USERLAB>=0 %THEN %START; ! FIRST UI IS'->'