! ! JALGOL RELEASE 1 DATED JAN 78 ! 1) BOOTSTRAPPED FROM ALGOL(E) RELEASE 3.0 [INCLDG CHANGES 1-6]. ! JALGOL RELEASE 1.1 DATED AUG78 ! 1) HAS CHANGE TO ALLOW @ AS ALT TO & IN CONSTANTS ! 2) HAS CHANGE TO TRAP OVERFLOW IN CONST ! 3) HAS CHANGE IN CANAME FOR REAL SUBSCRIPTS ! 4) HAS CHANGE TO DECLARE SWITCH FOR 2960 WHICH DOES NOT JUMP ! TO CODE DESCRIPTORS. MAY BE REPPED BACK IF 2960 MODIFIED ! 5) HAS CHANGE IN GOTOLAB FOR COMPLEX SWITCHES IN PROG SANS ARRAYS ! 6) REMOVES FAULT 202 FROM CUI AS THIS CAN HAPPEN ! 7) HAS CHANGE TO PROTECT AGAINST DUPLICATE PROC BODIES ! !QIN %MAINEP ICL9CEZALGOL; %TRUSTEDPROGRAM %BEGIN %INTEGER I, J, K ! PRODUCED FROM JALGPS01 BY PSPROG2S ON 30/12/77 %CONSTINTEGERARRAY SYMBOL(1300: 2270)= 1305, 1305, 1001, 1018, 1305, 1313, 1311, 44, 1001, 1018, 999, 1313, 1000, 1323, 1317, 1001, 1355, 1319, 1003, 1323, 40, 1323, 41, 1348, 1342, 201, 198, 1453, 212, 200, 197, 206, 1010, 1038, 1313, 1011, 1348, 197, 204, 211, 197, 1323, 1348, 1010, 1038, 1313, 1011, 1348, 1355, 1353, 1039, 1313, 999, 1355, 1000, 1373, 1364, 1030, 1041, 1010, 1323, 1011, 1373, 1042, 1371, 40, 1010, 1761, 1011, 1777, 41, 1373, 1000, 1382, 1380, 44, 1010, 1323, 1011, 999, 1382, 1000, 1399, 1390, 1041, 1010, 1323, 1011, 1373, 1042, 1397, 40, 1010, 1761, 1011, 1777, 41, 1399, 1000, 1411, 1405, 212, 210, 213, 197, 1411, 198, 193, 204, 211, 197, 1436, 1416, 193, 206, 196, 1419, 207, 210, 1424, 201, 205, 208, 204, 1430, 197, 209, 213, 201, 214, 1432, 38, 1434, 33, 1436, 124, 1442, 1440, 1044, 1470, 1442, 1470, 1446, 1446, 1436, 1446, 1453, 1451, 1411, 1436, 999, 1453, 1000, 1470, 1468, 201, 198, 1453, 212, 200, 197, 206, 1442, 197, 204, 211, 197, 1453, 1470, 1442, 1484, 1475, 1323, 1966, 1323, 1478, 1001, 1355, 1480, 1399, 1484, 40, 1453, 41, 1508, 1493, 201, 206, 212, 197, 199, 197, 210, 1498, 210, 197, 193, 204, 1506, 194, 207, 207, 204, 197, 193, 206, 1508, 1000, 1521, 1519, 59, 1599, 214, 193, 204, 213, 197, 1012, 1013, 1521, 1000, 1551, 1530, 204, 193, 194, 197, 204, 1026, 1300, 1539, 211, 215, 201, 212, 195, 200, 1043, 1300, 1548, 211, 212, 210, 201, 206, 199, 1028, 1300, 1551, 1484, 1551, 1576, 1560, 193, 210, 210, 193, 217, 1021, 1300, 1573, 208, 210, 207, 195, 197, 196, 213, 210, 197, 1022, 1300, 1622, 1576, 1017, 1300, 1584, 1582, 40, 1001, 1584, 41, 1584, 1000, 1591, 1589, 1591, 1001, 999, 1591, 1000, 1599, 1594, 44, 1599, 41, 1014, 58, 40, 1613, 1611, 195, 207, 205, 205, 197, 206, 212, 1005, 1013, 999, 1613, 1000, 1622, 1620, 59, 1599, 1521, 1013, 999, 1622, 1000, 1644, 1642, 59, 195, 207, 205, 205, 197, 206, 212, 1010, 40, 1001, 1584, 41, 1649, 1660, 1011, 1013, 1040, 1644, 1000, 1649, 1647, 58, 1649, 1000, 1660, 1658, 1644, 214, 193, 204, 213, 197, 1012, 1660, 1000, 1667, 1665, 1644, 1667, 1660, 1667, 1000, 1694, 1675, 204, 193, 194, 197, 204, 1716, 1683, 211, 215, 201, 212, 195, 200, 1716, 1691, 211, 212, 210, 201, 206, 199, 1716, 1694, 1484, 1694, 1716, 1702, 193, 210, 210, 193, 217, 1716, 1713, 208, 210, 207, 195, 197, 196, 213, 210, 197, 1716, 1716, 1017, 1716, 1720, 1720, 1001, 1720, 1727, 1725, 44, 1001, 999, 1727, 1000, 1735, 1731, 1001, 1382, 1735, 40, 1735, 41, 1752, 1750, 201, 198, 1453, 212, 200, 197, 206, 1727, 197, 204, 211, 197, 1735, 1752, 1727, 1761, 1759, 44, 1010, 1735, 1011, 999, 1761, 1000, 1777, 1764, 1008, 1768, 1001, 1355, 1035, 1771, 1323, 1035, 1774, 1453, 1035, 1777, 1735, 1035, 1786, 1784, 1591, 1010, 1761, 1011, 999, 1786, 1000, 1801, 1794, 1020, 1355, 58, 61, 1801, 1453, 1801, 1019, 1355, 58, 61, 1812, 1323, 1812, 1810, 1025, 1004, 1020, 1355, 58, 61, 999, 1812, 1000, 1823, 1821, 1025, 1004, 1019, 1355, 58, 61, 999, 1823, 1000, 1845, 1836, 211, 212, 197, 208, 1323, 213, 206, 212, 201, 204, 1323, 1843, 215, 200, 201, 204, 197, 1453, 1845, 1000, 1853, 1851, 44, 1323, 1823, 999, 1853, 1000, 1862, 1860, 44, 1323, 58, 1323, 999, 1862, 1000, 1874, 1866, 1017, 1300, 1874, 193, 210, 210, 193, 217, 1021, 1916, 1879, 1879, 1300, 1885, 1879, 1885, 1883, 44, 1874, 1885, 1000, 1895, 1888, 1895, 1895, 1041, 1323, 58, 1323, 1853, 1042, 1905, 1905, 1041, 1038, 1002, 58, 1038, 1002, 1905, 1042, 1916, 1914, 44, 1038, 1002, 58, 1038, 1002, 1905, 1916, 1000, 1921, 1921, 1300, 1895, 1921, 1927, 1925, 44, 1916, 1927, 1000, 1966, 1953, 208, 210, 207, 195, 197, 196, 213, 210, 197, 1022, 1033, 1010, 1001, 1018, 1576, 1015, 1508, 1613, 59, 1599, 1013, 1011, 2002, 2105, 1962, 193, 210, 210, 193, 217, 1021, 1024, 1874, 1966, 1017, 1023, 1300, 2002, 1969, 61, 1972, 62, 61, 1974, 62, 1976, 35, 1979, 60, 61, 1981, 60, 1984, 92, 61, 1987, 197, 209, 1990, 199, 197, 1993, 199, 212, 1996, 206, 197, 1999, 204, 197, 2002, 204, 212, 2011, 2009, 1029, 1001, 58, 1034, 2002, 2011, 1000, 2029, 2014, 2164, 2019, 198, 207, 210, 2029, 2029, 201, 198, 1453, 212, 200, 197, 206, 2002, 2082, 2044, 2044, 1010, 1004, 1355, 58, 61, 1323, 1823, 1011, 1845, 196, 207, 2002, 2072, 2064, 2047, 2164, 2052, 198, 207, 210, 2029, 2062, 201, 198, 1453, 212, 200, 197, 206, 2002, 2082, 2064, 1000, 2072, 2070, 1599, 2002, 2011, 1036, 2072, 1015, 2082, 2080, 194, 197, 199, 201, 206, 1015, 2082, 2044, 2100, 2090, 194, 197, 199, 201, 206, 2064, 2095, 198, 207, 210, 2029, 2098, 2164, 2144, 2100, 2144, 2105, 2103, 1001, 2105, 1000, 2144, 2114, 193, 204, 199, 207, 204, 2100, 1016, 2125, 197, 216, 212, 197, 210, 206, 193, 204, 2100, 1016, 2135, 198, 207, 210, 212, 210, 193, 206, 2100, 1016, 2141, 194, 197, 199, 201, 206, 2144, 1037, 2044, 2154, 2152, 197, 204, 211, 197, 2002, 2154, 2154, 1000, 2164, 2162, 194, 197, 199, 201, 206, 2064, 2164, 2044, 2178, 2169, 1025, 1004, 1786, 2172, 1001, 1355, 2178, 199, 207, 212, 207, 1735, 2271, 2182, 2011, 1006, 2190, 197, 206, 196, 1016, 1007, 2144, 1006, 2199, 195, 207, 205, 205, 197, 206, 212, 1005, 2203, 1484, 1927, 1006, 2210, 194, 197, 199, 201, 206, 1015, 2228, 211, 215, 201, 212, 195, 200, 1027, 1001, 1018, 1031, 58, 61, 1010, 1735, 1011, 1752, 1006, 2236, 207, 215, 206, 1032, 1484, 1862, 1006, 2242, 1029, 1001, 58, 1034, 2178, 2244, 59, 2252, 195, 207, 196, 197, 207, 206, 1006, 2261, 195, 207, 196, 197, 207, 198, 198, 1006, 2271, 208, 210, 207, 199, 210, 193, 205, 1001, 1006; %CONSTINTEGER SS= 2178 %OWNINTEGERARRAY SNNNO(0:77) %CONSTBYTEINTEGERARRAY TSNAME(0:76)=2,1(3),0,2(8),1,2,0,0,1,0(7),1,2, 0(5),1,0(3),2,0(3),1, 1,0,0,3,0(3),2,1,0(8), 1,2,1(7),2(3),1,1,2(5); NEWLINES(3); SPACES(5) PRINTSTRING( 'EDINBURGH ALGOL 60(J) COMPILER ') PRINTSTRING( ' RELEASE 1.0') PRINTSTRING( ' DATED 28/08/78') NEWLINES(3) %CONSTINTEGERARRAY BYTES(0:4)=0,4,8,4,8 %CONSTINTEGERARRAY SIZECODE(0:5)=0,5,6,5,5,3; %CONSTINTEGERARRAY DESRAD(0:5)=0,32,16,32,0,24; %OWNINTEGERARRAY FIXED GLA(0:13)=0, 0(3),-1,0,0(6),X'30000000',0; %CONSTBYTEINTEGERARRAY TRTAB(0:255)=0(48), 1(10),0(7),2(26),0(6),2(26),0(5),0(128) %CONSTINTEGERARRAY GRMAP(0:4)=0,1,3,5,7; %CONSTINTEGER MAXLEVELS=31 ! ! THE PRINCIPAL OPCODES ARE HERE DEFINED AS THEIR MNEMONICS(AMENDED) ! %CONSTINTEGER LB=X'7A',SLB=X'52',STB=X'5A',ADB=X'20',CPB=X'26', %C MYB=X'2A',SBB=X'22',CPIB=X'2E' %CONSTINTEGER LD=X'78',LDA=X'72',INCA=X'14',STD=X'58',LDB=X'76', %C LDTB=X'74',LDRL=X'70',CYD=X'12',MODD=X'16' %CONSTINTEGER STLN=X'5C',ASF=X'6E',ST=X'48',RALN=X'6C',LXN=X'7E',%C LLN=X'7C',LSS=X'62',SLSS=X'42',MPSR=X'32',STSF=X'5E',%C LUH=X'6A',STUH=X'4A',LSD=X'64',SLSD=X'44',PRCL=X'18', %C LSQ=X'66',SLSQ=X'46',STXN=X'4C',LCT=X'30',STCT=X'36' %CONSTINTEGER JUNC=X'1A',JLK=X'1C',CALL=X'1E',EXIT=X'38',JCC=2, %C JAT=4,JAF=6,DEBJ=X'24',CPSR=X'34',ESEX=X'3A' %CONSTINTEGER IAD=X'E0',ICP=X'E6',USH=X'C8',ISB=X'E2',IRSB=X'E4',%C OR=X'8C',UCP=X'C6',IMY=X'EA',IMDV=X'AE',AND=X'8A', %C ISH=X'E8',NEQ=X'8E' %CONSTINTEGER RAD=X'F0',RSB=X'F2',RRSB=X'F4',FLT=X'A8',RRDV=X'BC', %C RSC=X'F8',FIX=X'B8',RMY=X'FA',RCP=X'F6' ! %CONSTINTEGER MVL=X'B0',MV=X'B2' %CONSTBYTEINTEGERARRAY OCODE(-1:47)=X'1E',X'1C',2(14),X'1A',4(16),6(16); ! JLK=1C,J=1A,JCC=2,JAT=4,JAF=6 ! ! DEFINE SOME MNEMONICS FOR THE VISIBLE REGISTERS ! %CONSTINTEGER ACCR=0,DR=1,LNB=2,XNB=3,PC=4,CTB=5,TOS=6,BREG=7 ! %CONSTSTRING(4)DEFAULTMAINEP='S#GO' %CONSTSTRING(8)MDEP='S#NDIAG' %CONSTSTRING(8)SIGEP='S#SIGNAL'; ! EP FOR SIGNAL %CONSTSTRING(11)AUXSTEP='ICL9CEAUXST';! EP FOR AUX STACK %CONSTINTEGER LABBYNAME=1; ! BIT SET IN PASS2INF FOR LABS %CONSTINTEGER SWBYNAME=2; ! DITTO FOR SWITCHES AS PARAMS ! %CONSTINTEGER SNPT=X'1006'; ! SPECIALNAME PTYPE %INTEGER DSIZE, CONSTL1, CONSTL4, CONSTL8, CNSTAT, SPCNST, %C RPPTR, KYCHAR1, KYCHAR2, LEVELINF, RPBASE, %C AUXST,CDCOUNT, FREE FORMAT, PASS2INF %INTEGER ASL, NNAMES, ARSIZE, CABUF, PPCURR, LINE, %C LENGTH, NEXTP, N0, SNUM, RLEVEL, NMAX, CONSTPTR, PLABEL,%C LEVEL, CA, RR, TYPE, LASTNAME, STLIMIT %INTEGER FAULTY, HIT, INHCODE, TTOPUT, LIST, ADFLAG, %C PARMLINE, PARMTRCE, PARMDIAG, PARMOPT, CTYPE, DCOMP, %C CPRMODE, PARMCHK, PRINTMAP, PARMARR, SMAP %LONGREAL CVALUE, IMAX %INTEGER MASK, NEXT, N, ITEM, LOGEPDISP, EXPEPDISP, CODEPDISP,%C P, Q, R, S, T, U, V, NEST, FNAME, GLACA, GLACABUF, %C GLACURR, SSTL, QMAX, STMTS, LASTAT, SLINES, STRLINK, %C FILE ADDR, FILE PTR, FILE END, FILE SIZE, LASTEND, UNASSPAT %SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N) %RECORDFORMAT LISTF(%INTEGER S1,S2,S3,LINK) %BEGIN FILE ADDR=COMREG(46); ! SOURCE FILE IF CLEAN %IF -1<=FILE ADDR<=0 %THEN %START FILE SIZE=32000*(FILE ADDR+2) %FINISH %ELSE %START FILE PTR=FILE ADDR+INTEGER(FILE ADDR+4) FILE END=FILE ADDR+INTEGER(FILE ADDR) FILE SIZE=INTEGER(FILE ADDR) %FINISH %IF FILE ADDR=0 %OR COMREG(27)&8#0 %THEN FILE SIZE=64*4096 %IF FILE ADDR=-1 %THEN FILE ADDR=0 ARSIZE=2*FILESIZE+4096 NNAMES=511 %IF FILESIZE>32000 %THEN NNAMES=1023 ASL=2*NNAMES DSIZE=6*NNAMES %END %INTEGERARRAY REGISTER, OLINK, GRUSE, GRAT, GRINF(0:7) %INTEGERARRAY SET, STACKBASE, RAL, FLAG, L, M, NMDECS, AUXSBASE, %C LABEL, JROUND, DIAGINF, DISPLAY, NAMES(0:MAXLEVELS) %INTEGERARRAY AVL WSP(1:4,0:MAXLEVELS) %BYTEINTEGERARRAY CODE, GLABUF(0:268) %INTEGERARRAY PLABS,PLINK(0:20) %BYTEINTEGERARRAYFORMAT CCF(0:FILESIZE+7) %BYTEINTEGERARRAYNAME CC %INTEGERARRAYFORMAT AF(0:ARSIZE) %INTEGERARRAYNAME A %RECORDARRAY ASLIST(0:ASL)(LISTF) %BYTEINTEGERARRAY LETT(0:DSIZE+20) %INTEGERARRAY WRD, TAGS, NTYPE, DPOSN(0:NNAMES) %ROUTINESPEC CNOP(%INTEGER I, J) %ROUTINESPEC PCLOD(%INTEGER FROM, TO) %ROUTINESPEC PCONST(%INTEGER X) %ROUTINESPEC PSF1(%INTEGER OPCODE,K,N) %ROUTINESPEC PF1(%INTEGER OPCODE,KP,KPP,N) %ROUTINESPEC PSORLF1(%INTEGER OPCODE,KP,KPP,N) %ROUTINESPEC PF2(%INTEGER OPCODE,H,Q,N,MASK,FILLER) %ROUTINESPEC PF3(%INTEGER OPCODE,MASK,KPPP,N) !%ROUTINESPEC LIST PRG %ROUTINESPEC PLANT(%INTEGER VALUE) %SYSTEMROUTINESPEC LPUT(%INTEGER A, B, C, D) %ROUTINESPEC PLUG(%INTEGER I, J, K) !%ROUTINESPEC PRHEX(%INTEGER VALUE, PLACES) %ROUTINESPEC COMPARE %ROUTINESPEC PNAME(%INTEGER MODE) %ROUTINESPEC CONST(%INTEGER MODE) %ROUTINESPEC TEXTTEXT %ROUTINESPEC CODEOUT %ROUTINESPEC PROLOGUE %ROUTINESPEC EPILOGUE %ROUTINESPEC CSS(%INTEGER P) %ROUTINESPEC ABORT %ROUTINESPEC WARN(%INTEGER N,V) %ROUTINESPEC FAULT(%INTEGER N, VALUE) %ROUTINESPEC PRINT NAME(%INTEGER N) %ROUTINESPEC FROM12(%INTEGER CELL, %INTEGERNAME S1, S2) %ROUTINESPEC FROM123(%INTEGER CELL, %INTEGERNAME S1, S2, S3) %ROUTINESPEC POP(%INTEGERNAME CELL, %INTEGERNAME S1, S2) %ROUTINESPEC POP123(%INTEGERNAME C, %INTEGERNAME P, Q, R) %ROUTINESPEC PUSH(%INTEGERNAME CELL, %INTEGER S1, S2) %ROUTINESPEC PUSH123(%INTEGERNAME C, %INTEGER S1, S2, S3) %INTEGERFNSPEC FIND(%INTEGER LAB, LIST) !%INTEGERFNSPEC FIND3(%INTEGER LAB, LIST) %ROUTINESPEC MLINK(%INTEGERNAME CELL) %ROUTINESPEC REPLACE2(%INTEGER CELL, S2) %ROUTINESPEC REPLACE1(%INTEGER CELL, S1) %INTEGERFNSPEC FROM2(%INTEGER CELL) %INTEGERFNSPEC FROM1(%INTEGER CELL) %INTEGERFNSPEC FROM3(%INTEGER CELL) %STRING(31)MAINEP %LONGREALARRAY TINF(0:3) %SYSTEMLONGREALFNSPEC CPUTIME !*DELSTART %ROUTINESPEC RECODE(%INTEGER START, FINISH, CA) %SYSTEMROUTINESPEC NCODE(%INTEGER A,B,C) %ROUTINESPEC PRINT USE !*DELEND %ROUTINESPEC READ PRG ! %FAULT 9->INEND ! START OF COMPILATION CC==ARRAY(COMREG(14)+INTEGER(COMREG(14)+4), CCF) A==ARRAY(ADDR(CC(0))+4096, AF) %BEGIN %CONSTBYTEINTEGERARRAY ILETT(0:636)=3, 'A','B','S', 4,'I','A','B','S', 4,'S','I','G','N', 6,'E','N','T','I','E','R', 5,'C','L','O','S','E', 4,'S','Q','R','T', 3,'S','I','N', 3,'C','O','S', 6,'A','R','C','T','A','N', 2,'L','N', 3,'E','X','P', 7,'M','A','X','R','E','A','L', 7,'M','I','N','R','E','A','L', 6,'M','A','X','I','N','T', 7,'E','P','S','I','L','O','N', 5,'F','A','U','L','T', 4,'S','T','O','P', 6,'C','H','A','R','I','N', 7,'C','H','A','R','O','U','T', 4,'O','P','E','N', 7,'O','U','T','R','E','A','L', 9,'R','E','A','D','A','R','R','A','Y', 10,'W','R','I','T','E','A','R','R','A','Y', 10,'I','R','E','A','D','A','R','R','A','Y', 11,'I','W','R','I','T','E','A','R','R','A','Y', 6,'L','E','N','G','T','H', 7,'C','P','U','T','I','M','E', 10,'B','R','E','A','D','A','R','R','A','Y', 11,'B','W','R','I','T','E','A','R','R','A','Y', 7,'N','E','W','L','I','N','E', 5,'S','P','A','C','E', 3,'G','A','P', 6,'F','O','R','M','A','T', 6,'R','E','W','I','N','D', 4,'S','K','I','P', 11,'I','N','T','E','R','C','H','A','N','G','E', 4,'R','E','A','D', 4,'P','A','G','E', 5,'W','R','I','T','E', 6,'I','W','R','I','T','E', 4,'C','O','D','E', 11,'I','N','T','E','G','E','R','R','E','A','D', 3,'T','A','B', 6,'O','U','T','P','U','T', 11,'R','E','A','D','B','O','O','L','E','A','N', 12,'W','R','I','T','E','B','O','O','L','E','A','N', 9,'W','R','I','T','E','T','E','X','T', 8,'C','O','P','Y','T','E','X','T', 5,'F','R','E','A','D', 13,'I','N','B','A','S','I','C','S','Y','M','B','O','L', 14,'O','U','T','B','A','S','I','C','S','Y','M','B','O','L', 10,'R','E','A','D','B','I','N','A','R','Y', 7,'M','O','N','I','T','O','R', 11,'I','R','E','A','D','B','I','N','A','R','Y', 11,'B','R','E','A','D','B','I','N','A','R','Y', 11,'W','R','I','T','E','B','I','N','A','R','Y', 12,'I','W','R','I','T','E','B','I','N','A','R','Y', 12,'B','W','R','I','T','E','B','I','N','A','R','Y', 8,'R','E','A','D','O','I','N','T', 8,'I','N','T','D','O','R','E','A', 8,'S','P','O','J','I','L','I','P', 8,'S','E','T','I','L','E','V','E', 8,'S','E','T','I','P','R','A','V', 8,'E','X','T','I','L','E','V','E', 8,'E','X','T','I','P','R','A','V', 7,'C','I','S','P','O','L','E', 8,'C','I','S','R','A','D','E','K', 8,'S','I','I','D','O','R','E','A', 8,'S','E','T','I','L','R','E','A', 8,'S','E','T','I','P','R','E','A', 8,'E','X','I','L','Z','R','E','A', 8,'E','X','I','P','Z','R','E','A', 8,'S','P','O','J','R','L','R','P', 8,'S','E','T','R','L','E','V','E', 8,'S','E','T','R','P','R','A','V', 8,'E','X','T','R','L','E','V','E', 8,'E','X','T','R','P','R','A','V', 255 %CONSTBYTEINTEGERARRAY ITYPE(0:77)=0,130, 129(3),128,130(8),129,130,128(10),129,130, 128(5),129,128(3),130,128(3),129, 129,128(2),131,128(3),130,129,128(8), 129,130,129(7),130(3),129(2),130(5); %INTEGER I, J, LL CABUF=0; PPCURR=0; PASS2INF=0 LINE=0; RLEVEL=0; NMAX=0; CONSTPTR=0 LEVEL=0; CA=0; LASTAT=0 FAULTY=0; ADFLAG=0; STRLINK=0 DCOMP=0; CPRMODE=0; PRINT MAP=0 NEXT=1 LOGEPDISP=0; EXPEPDISP=0; CODEPDISP=0 CONSTL1=0; CONSTL4=0; CONSTL8=0 IMAX=(-1)>>1; PLABEL=24999 SSTL=0; STMTS=1; SNUM=0; CDCOUNT=0; RPPTR=0 LETT(0)=0 N0=14; N=12 GLACA=N0<<2; GLACABUF=GLACA GLACURR=0; PARMOPT=1; PARMARR=1 PARMLINE=1; PARMTRCE=1; PARMDIAG=1; INHCODE=0 LIST=1; PARMCHK=1 LEVELINF=0 I=COMREG(27) STLIMIT=X'1F000' %IF I>>24&1#0 %THEN STLIMIT=COMREG(48)-4096 FREE FORMAT=I&X'80000'; ! FREE = NO SEQUENCE NOS LIST=0 %IF I&2#0 PARMLINE=0 %IF I&X'800000'#0 PARMDIAG=0 %IF I&4#0 PARMCHK=0 %IF I&16#0 PARMARR=0 %IF I&32#0 PRINTMAP=1 %IF I&X'8000'#0 TTOPUT=I>>21&1 SMAP=I>>7&1 PARMTRCE=0 %AND PARMDIAG=0 %IF I&64#0 %IF I&(1<<16)#0 %THEN %START PARMARR=0; PARMOPT=0 PARMLINE=0; PARMCHK=0; PARMDIAG=0 %FINISH MAINEP=DEFAULT MAINEP KYCHAR1=''''; KYCHAR2='''' %CYCLE I=0, 1, MAXLEVELS SET(I)=0; STACKBASE(I)=0; RAL(I)=0 FLAG(I)=0; DIAGINF(I)=0; DISPLAY(I)=0 L(I)=0; M(I)=0; AUXSBASE(I)=0; LABEL(I)=0; JROUND(I)=0 NAMES(I)=-1 %CYCLE J=1,1,4 AVL WSP(J,I)=0 %REPEAT %REPEAT %CYCLE I=0, 1, 7 REGISTER(I)=0; GRUSE(I)=0 GRAT(I)=0; GRINF(I)=0 %REPEAT %CYCLE I=0, 1, NNAMES WRD(I)=0; TAGS(I)=0; NTYPE(I)=0 %REPEAT %CYCLE I=0, 1, ASL-1 ASLIST(I+1)_LINK=I %REPEAT ASLIST(0)_S1=0 ASLIST(0)_S2=-1 ASLIST(0)_S3=-1 ASLIST(0)_LINK=0 K=0; LL=1; I=ILETT(0) %WHILE I<255 %CYCLE %CYCLE J=1, 1, I CC(J)=ILETT(J+K); ! COPY SPECIAL NAMES TO SOURCE %REPEAT; CC(J+1)=';' R=2; Q=1; PNAME(1); ! SPECIAL NAME TO DICTIONARY NTYPE(LASTNAME)<-ITYPE(LL)<<8 DPOSN(LASTNAME)=-1 SNNNO(LL)=LASTNAME LL=LL+1 K=K+I+1 I=ILETT(K) %REPEAT; ! AND COMPILED SNUM=LL-1 LASTAT=-2 %END LPUT(0, 1, 1, ADDR(LETT(1))) TINF(0)=CPUTIME READPRG INEND: LENGTH=LENGTH+5 CC(LENGTH)=';' CC(LENGTH+1)='C'+128 CC(LENGTH+2)='E'+128 CC(LENGTH+3)='N'+128 CC(LENGTH+4)='D'+128 CC(LENGTH+5)=';' LENGTH=LENGTH+5 NEWLINES(2) ! LIST PRG I=(ADDR(CC(LENGTH))+LENGTH+4095)>>12<<12 J=ADDR(CC(0))+16*4096 %IF J>I %THEN I=J A==ARRAY(I, AF) !*DELSTART TINF(1)=CPUTIME !*DELEND SLINES=LINE Q=1; QMAX=1; LINE=0 %CYCLE R=0,1,7 A(R)=0 %REPEAT STACKBASE(1)=5; ! TO LINK GLOBAL PROCS R=8; LEVEL=1 %UNTIL Q>=LENGTH-6 %CYCLE P=SS LINE=LINE+1 RR=R; A(R+1)=LINE R=R+2 COMPARE FAULT(102, 0) %IF R>ARSIZE %IF HIT=0 %THEN FAULT(100,0) %AND R=RR %ELSE %START A(RR)=R-RR %IF LEVEL=0 %THEN FAULT(14, 0) %AND %EXIT %FINISH %REPEAT !DEAL WITH END OF PROGRAM A(R)=0; R=R+1 A(R)=0; R=R+1 RPPTR=(R+256)&(-256) RPBASE=RPPTR %IF LEVEL>1 %THEN FAULT(15, 0) I=0 NEWLINE PRINTCH(13) %IF FAULTY=0 %THEN %START WRITE(LINE, 5) PRINT STRING(' STATEMENTS ANALYSED:- SIZE=') WRITE(4*R, 5) WRITE(PASS2INF,5) NEWLINE %FINISH %ELSE %START PRINTSTRING(' CODE GENERATION NOT ATTEMPTED ') COMREG(24)=8 COMREG(47)=FAULTY %STOP %FINISH !*DELSTART TINF(2)=CPUTIME NEXTP=8 %WHILE SMAP#0 %CYCLE I=NEXTP; NEXTP=NEXTP+A(NEXTP) LINE=A(I+1) %EXIT %IF LINE=0 NEWLINE; WRITE(LINE,5); WRITE(I,5) NEWLINE %CYCLE J=I,1,NEXTP-1 WRITE(A(J),5) %REPEAT NEWLINE %REPEAT !*DELEND LINE=0 DCOMP=PRINTMAP PROLOGUE NEXTP=8 LEVEL=1; RLEVEL=0 %CYCLE !*DELSTART %IF DCOMP#0 %AND CA>CABUF %THEN CODEOUT %AND PRINTUSE !*DELEND I=NEXTP NEXTP=NEXTP+A(NEXTP) LINE=A(I+1) %EXIT %IF LINE=0 CSS(I+2) %REPEAT LINE=9999 EPILOGUE CODEOUT !*********************************************************************** !* PASS INFORMATION TO LPUT TO ENABLE IT TO GENERATE THE * !* LOADER DATA AND COMPLETE THE PROGRAM FILE. * !*********************************************************************** GLACA=(GLACA+7)&(-8) CONSTPTR=(CONSTPTR+7)&(-8) CNOP(0, 8) I=(PARMDIAG<<1!PARMLINE)<<1!PARMTRCE ! ! ALGOL LANGUAGE VALUE IS 5. 6 IS RESERVED FOR ANY OPTIMISED PROGRAM ! FIXED GLA(4)=(6-PARMTRCE)<<24!1<<16!(CPRMODE&1)<<8!I CODE OUT I=GLACA-GLACABUF %IF INHCODE=0 %THEN %START LPUT(2, I, GLACABUF, ADDR(GLABUF(0))) %UNLESS I=0 ! BACK OF GLAP LPUT(2, N0<<2, 0, ADDR(FIXED GLA(0)));! FRONT OF GLAP I=X'E2E2E2E2' LPUT(4, 4, SSTL, ADDR(I)) LPUT(19, 2, 12, 4); ! RELOCATE POINTER TO CST LPUT(19, 2, 8, 5); ! RELOCATE PTR TO GLAST %FINISH SSTL=(SSTL+11)&(-8) PRINTSTRING( ' CODE') WRITE(CA, 6); PRINTSTRING( ' BYTES GLAP') WRITE(GLACA, 3); PRINTSTRING( '+') WRITE(CONSTPTR, 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)=CONSTPTR K=CA+GLACA+SSTL+CONSTPTR; REGISTER(5)=K WRITE(K, 5); PRINTSTRING( ' BYTES') NEWLINE; PRINT CH(13); ! MARKER FOR COMP TO PRINT !SUMMARY TINF(3)=CPUTIME %IF FAULTY=0 %THEN %START WRITE(STMTS, 7); PRINTSTRING( ' STATEMENTS COMPILED IN') WRITE(INT(1000*(TINF(3)-TINF(0))),6) PRINTSTRING(' MSECS') COMREG(47)=STMTS; ! NO OF STMTS %FINISH %ELSE %START PRINTSTRING( 'PROGRAM CONTAINS'); WRITE(FAULTY, 2) PRINTSTRING( ' FAULT'); PRINTSYMBOL('S') %IF FAULTY>1 COMREG(47)=FAULTY; ! NO OF FAULTS %FINISH NEWLINES(2) !*DELSTART %CYCLE I=0,1,2 WRITE(INT(1000*(TINF(I+1)-TINF(I))),7) %REPEAT WRITE(INT(60*STMTS/(TINF(3)-TINF(0))),6) WRITE(INT(60*SLINES/(TINF(3)-TINF(0))),6) NEWLINE NEWLINE !*DELEND 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 %STOP ! ! THE ARRAY KEYCHK IS TO ALLOW ECMA KEYWORDS TO BE CHECKED. SINCE PASS 2 ! DOES A FULL CHECK THIS APPEARS UNNECESSARY BUT IT HELPS TO STOP THE ! LEXICAL SCANNER GETIING INTO TROUBLE WHEN SPARE SINGLE QUOTES ARE ! SCATTERED ABOUT THE SOURCE TEXT. ! FOR EACH INITIAL LETTER THERE IS A BITMASK. THE TOP 24 BITS INDICATE ! VALID SECOND LETTERS X'80000000'=A ETC AND THE BOTTOM 8 BIT INDICATE ! VALID KEYWORD LENGTHS 1=2LETTERS X'80'=9LETTERS ETC ! THE ARRAY IS BASE ON THE FOLLOWING ALGOL KEYWORDS:- ! ! AND,ALGOL,ARRAY,BOOLEAN,BEGIN,COMMENT,CODEON,CODEOFF,DO,DIV ! EQUIV,ELSE,EQ,END,EXTERNAL,FOR,FORTRAN,FALSE,GT,GE,GOTO,GO ! IF,IMPL,INTEGER,LABEL,LT,LE,NOT,NE,OR,OWN ! PROCEDURE,PROGRAM,POWER,REAL,SWITCH,STRING,STEP ! THEN,TRUE,TO,UNTIL,VALUE,WHILE ! %CONSTINTEGERARRAY KEYCHK('A':'Z')=%C X'0014400A',X'08020028',X'00020030',X'00820003', X'0014814F',X'8002002A',X'08021005',0, X'040C0025',0,0,X'88001009', 0,X'08020003',X'00004203',X'000240A8', 0,X'08000004',X'00001214',X'01024005', X'00040008',X'80000008',X'01000008',0, 0(2); %ROUTINE READ PRG %ROUTINESPEC GET LINE %INTEGER DEL %BYTEINTEGERARRAY BLINE,TLINE(0:161) %CONSTINTEGER NBASICS=8 %CONSTINTEGER MAXSIZE=11 %CONSTINTEGERARRAY BASSYM(0:9)='<','[','>',']','(',123, ')',125,'_','_'; %INTEGERARRAY WORD(0:MAXSIZE+1) %INTEGER SIZE,LETTERFLAG,LL,LP,I,J LL=0; LP=0 LENGTH=-4; DEL=0 %IF LIST#0 %THEN PRINTSTRING(' LINE STMNT ') L2: LP=LP+1 %IF LP>LL %THEN %START GET LINE LP=1 %IF BLINE(1)=25 %THEN %RETURN %FINISH I=TLINE(LP) %IF 10#I<=31 %OR I>126 %THEN ->L2 %IF I='''' %START ! ! QLAG=1 IFF PARM(BCD),IE USING 1900 OR D.I.N. REPRESENTATIONS ! LETTERFLAG=1 SIZE=0 %CYCLE LP=LP+1 %IF LP>LL %THEN GET LINE %AND LP=1 I=TLINE(LP) %EXIT %IF I='''' ;! ***END OF QUOTED WORD %IF 33<=I<=126 %START SIZE=SIZE+1 ;! ***LENGTH OF QUOTED WORD WORD(SIZE)=I %IF I<'A' %OR I>'Z' %THEN LETTERFLAG=0 ! ! ***NOT ALL LETTERS-CANNOT BE KEYWORD ! CC(LENGTH+SIZE+4)=I+128 %EXIT %IF SIZE>MAXSIZE %FINISH %ELSE %START %IF I=25 %THEN ->CODS %FINISH %REPEAT ! ! HAVE A KEYWORD OF SORTS IN WORD AND THE UNDERLINED VERSION OF SAME ! ALREADY PLACED IN CC ! ! CHECK FIRST FOR VALID UNDERLINED WORD ! %IF LETTERFLAG=1 %AND 0>(WORD(2)-'A')=0 %OR %C I&1<<(SIZE-2)=0 %THEN ->CODS LENGTH=LENGTH+SIZE I=CC(LENGTH+4) ->STNUMCHK %FINISH ! ! NEXT CHECK FOR NON ALPHABETIC BASIC SYMBOL USING TABLE BASSYM ! %IF SIZE=1 %THEN %START I=WORD(1); ! THE ONLY SYMBOL %IF I='/' %THEN %START CC(LENGTH+5)='D'+128 CC(LENGTH+6)='I'+128 CC(LENGTH+7)='V'+128 LENGTH=LENGTH+3; ->L2 %FINISH %CYCLE J=0,2,NBASICS %IF I=BASSYM(J) %THEN %START CC(LENGTH+5)=BASSYM(J+1) LENGTH=LENGTH+1; ->L2 %FINISH %REPEAT %FINISH ! %IF SIZE=2 %START %IF WORD(1)='1' %AND WORD(2)='0' %START LENGTH=LENGTH+1 CC(LENGTH+4)='&' ->L2 %FINISH %IF WORD(1)='*'=WORD(2) %START LENGTH=LENGTH+2 CC(LENGTH+3)='*' CC(LENGTH+4)='*' ->L2 %FINISH %FINISH ! ! KEYWORD IS A LOAD OF CODSWALLOP. STUFF IT INTO CC AND ALLOW ! NEXT PASS TO REPORT IT (NB IT MAY BE IN A STRING OR COMMENT) ! TREAT THE LAST QUOTE AS FIRST QUOTE AGAIN IN CASE OF A MISSING QUOTE ! CODS: LENGTH=LENGTH+1 CC(LENGTH+4)='''' %IF SIZE>0 %START %CYCLE I=1,1,SIZE LENGTH=LENGTH+1 J=WORD(I); CC(LENGTH+4)=J %IF J=';' %THEN STMTS=STMTS+1 %REPEAT %FINISH %IF TLINE(LP)=M'''' %THEN LP=LP-1; ->L2 ! %FINISH ->L2 %IF I=' ' %OR I=NL LENGTH=LENGTH+1; CC(LENGTH+4)=I %IF I=';' %THEN STMTS=STMTS+1 ! STNUMCHK: %IF I='N'+128 %AND CC(LENGTH+3)='I'+128 %C %AND CC(LENGTH+2)='G'+128 %AND CC(LENGTH+1)='E'+128 %C %AND CC(LENGTH)='B'+128 %THEN STMTS=STMTS+1 ! %IF I='D'+128 %AND CC(LENGTH+3)='N'+128 %C %AND CC(LENGTH+2)='E'+128 %AND ':'#CC(LENGTH+1)#';' %C %AND(CC(LENGTH+1)#'N'+128 %OR CC(LENGTH)#'I'+128 %OR %C CC(LENGTH-1)#'G'+128 %OR CC(LENGTH-2)#'E'+128 %OR %C CC(LENGTH-3)#'B'+128) %THEN STMTS=STMTS+1 ! ->L2 %ROUTINE GET LINE %SYSTEMROUTINESPEC IOCP(%INTEGER EP,N) %SYSTEMROUTINESPEC SIM2(%INTEGER EP,R1,R2,%INTEGERNAME R3) %INTEGER K,PU,ST,LS %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); LL=0 %IF FILE ADDR=0 %THEN %START; ! SOURCE NOT A 'CLEAN' FILE SIM2(0,ADDR(BLINE(1)),0,K) LL=K !QIN *LD_BLINE !QIN *INCA_1 !QIN *LDB_LL !QIN *LSS_ITOI+4 !QIN *LUH_=X'180000FF' !QIN *TTR_%L=%DR %IF BLINE(1)=25 %THEN %START TLINE(1)=25; TLINE(2)=10 %RETURN %FINISH %FINISH %ELSE %START %IF FILEPTR>=FILE END %THEN %START BLINE(1)=25; TLINE(1)=25 TLINE(2)=10; LL=2 %RETURN %FINISH %UNTIL K=NL %OR K=0 %CYCLE K=BYTE INTEGER(FILEPTR); ! NEXT CHAR FROM SORCE FILE FILE PTR=FILE PTR+1 BLINE(LL+1)=K LL=LL+1 %REPEAT %FINISH LINE=LINE+1 %IF LIST#0 %THEN %START WRITE(LINE, 5) WRITE(STMTS, 5) SPACES(5) BLINE(0)=LL-1 IOCP(15,ADDR(BLINE(0))) NEWLINE %FINISH %IF FREE FORMAT=0 %AND LL>73 %THEN BLINE(73)=10 %AND LL=73 PU=1; ST=1; LS=0 !QOUT; %UNTIL K=10 %CYCLE !QOUT; K=BLINE(PU) !QOUT; PU=PU+1 !QOUT; %IF K#' '%THEN TLINE(ST)=K %AND ST=ST+1 !QOUT; %REPEAT !QOUT; LL=ST-1 !QIN *LD_BLINE !QIN *INCA_=1 !QIN *LDB_LL !QIN *SWEQ_%L=%DR,0,32 !QIN *CYD_=0 !QIN *LDA_TLINE+4 !QIN *INCA_=1 !QIN *MV_%L=%DR !QIN *INCA_=-2; ! TO LAST SPACE !QIN *LSS_=32 !QINBACK: *ICP_(%DR) !QIN *JCC_7, !QIN *INCA_=-1 !QIN *J_ !QINOUT: *LSS_=10 !QIN *INCA_=1 !QIN *ST_(%DR) !QIN *STD_ST !QIN *LSS_LS !QIN *ISB_TLINE+4 !QIN *ST_LL %END %END !%ROUTINE LIST PRG !%INTEGER I, THIS SYM, LAST SYM ! THIS SYM=0 ! %CYCLE I=1, 1, LENGTH ! LAST SYM=THIS SYM ! THIS SYM=CC(I) ! %IF THISSYM>128 %AND LASTSYM<128 %THEN PRINTSYMBOL(KYCHAR1) ! %IF LASTSYM>128 %AND THISSYM<128 %THEN PRINTSYMBOL(KYCHAR2) ! PRINT SYMBOL(THIS SYM) ! %IF THIS SYM=' ' %THEN THIS SYM='_' ! %IF THIS SYM=59 %THEN NEWLINE ! %REPEAT ! NEWLINES(3) !%END %ROUTINE MESSAGE(%INTEGER N) !*********************************************************************** !* OUTPUTS AN ERROR MESSAGE STORED IN A COMPRESSED FORMAT * !*********************************************************************** %CONSTBYTEINTEGERARRAY WORD(0: 200)=0,%C 2, 1, 2, 4, 5, 4, 6, 7, 8, 4, 5, 1, 7, 9, 10, 7, 7, 4, 5, 0, 8, 12, 7, 9, 14, 9, 12, 16, 18, 0, 10, 16, 21, 23, 0, 11, 1, 8, 4, 0, 12, 1, 8, 25, 0, 14, 27, 28, 29, 0, 15, 30, 29, 0, 0, 16, 7, 8, 4, 0, 17, 8, 32, 7, 0, 18, 34, 35, 36, 37, 19, 34, 35, 36, 39, 20, 41, 43, 34, 44, 21, 41, 32, 8, 46, 22, 47, 16, 8, 48, 23, 32, 7, 9, 10, 24, 50, 9, 52, 10, 25, 54, 50, 55, 0, 26, 57, 58, 8, 60, 27, 62, 9, 43, 63, 29, 12, 7, 9, 64, 34, 27, 28, 67, 0, 35, 27, 28, 32, 67, 37, 43, 27, 28, 68, 40, 70, 71, 0, 0, 42, 52, 50, 9, 10, 43, 43, 73, 74, 0, 47, 75, 77, 0, 0, 48, 78, 79, 9, 80, 57, 81, 30, 0, 0, 98, 82, 0, 0, 0, 99, 82, 0, 0, 0, 103, 85, 27, 86, 0, 104, 27, 28, 85, 0, 106, 87, 88, 27, 86, 108, 89, 79, 9, 80, 127, 90, 0, 0, 0 %CONSTINTEGERARRAY LETT(0: 92)=0,%C X'30222B00',X'25D60B13',X'13EF9000',X'4CB40000', X'52E91940',X'4EE9A0D0',X'382D2800',X'39F40000', X'25C00000',X'171094E7',X'38000000',X'25D60B13', X'10000000',X'582CA97F',X'3133A000',X'40320B4B', X'50B20000',X'4E051A4D',X'2461A25F',X'38000000', X'25C37CA5',X'14746640',X'4E051A4D',X'24A40000', X'04632CE7',X'244C2800',X'51EF0000',X'342EC800', X'15C49800',X'35339A5D',X'1C000000',X'424F1949', X'56450000',X'5E4F71C0',X'39E00000',X'3CC00000', X'4EA298E5',X'26149800',X'40320B4B',X'50B29800', X'40320B4B',X'52491800',X'06520E40',X'112D2BA7', X'25EE0000',X'582C4900',X'0474A858',X'40B26A69', X'50A40000',X'58324845',X'30A00000',X'09EF6143', X'38000000',X'19F20000',X'25C37CA5',X'14740000', X'11360000',X'3E05905D',X'12600000',X'25D429CB', X'48000000',X'31E30B00',X'09F57100',X'30A6A403', X'4A9F6267',X'50000000',X'30B62B26',X'112D2BA7', X'25EE9800',X'10A36380',X'35338303',X'0CA40000', X'25D3490A',X'3EB40000',X'258C29C3',X'30000000', X'15932800',X'4EA20000',X'0D019000',X'4E8D7500', X'08A74B80',X'04849167',X'4C224B13',X'53200000', X'382D2CC0',X'31EE3800',X'4E924B8E',X'0DEE9D00', X'15A00000',X'4CA5F859',X'1DECFB43',X'3AA16000' %INTEGER I,J,K,M,Q,S PRINTSTRING(' (') I=-4 %UNTIL N=WORD(I) %OR I= 196 %THEN I=I+5 %CYCLE J=1,1,4 K=WORD(I+J) %IF K=0 %THEN %EXIT SPACE %UNLESS J=1 %UNTIL M&1=0 %CYCLE M=LETT(K); S=26 %UNTIL S<0 %CYCLE Q=M>>S&31; %IF Q=31 %THEN Q=-32 %IF Q\=0 %THEN PRINT SYMBOL(Q+64) S=S-5 %REPEAT K=K+1 %REPEAT %REPEAT PRINTSTRING(') ') %END %ROUTINE FAULT(%INTEGER N, FNAME) %INTEGER I, J, QP !*DELSTART %MONITOR %IF PRINTMAP#0 %OR SMAP#0 !*DELEND QP=Q %IF N=100 %THEN %START %UNTIL Q>=QMAX %CYCLE %IF CC(Q)=';' %THEN LINE=LINE+1 Q=Q+1 %REPEAT Q=QP PRINTSTRING(' * FAILED TO ANALYSE STATEMENT ') WRITE(LINE, 2) NEWLINE; SPACES(5) FAULTY=FAULTY+1 T=0; J=0; S=0 %UNTIL (J=';' %AND Q>QMAX) %OR Q=LENGTH %OR %C (CC(Q)='E'+128 %AND CC(Q+1)='N'+128 %AND %C CC(Q+2)='D'+128) %OR(CC(Q)='B'+128 %AND %C CC(Q+1)='E'+128 %AND CC(Q+2)='G'+128 %AND CC(Q+3)= %C 'I'+128 %AND CC(Q+4)='N'+128 %AND Q>QMAX)%CYCLE I=J; J=CC(Q) %IF J>128 %AND I<128 %START SPACE PRINTSYMBOL(KYCHAR1) T=T+2 %FINISH %IF I>128 %AND J<128 %START PRINTSYMBOL(KYCHAR2) T=T+1 %FINISH PRINT SYMBOL(J) T=T+1 %IF Q=QMAX %THEN S=T Q=Q+1 %REPEAT ! %IF S<115 %THEN %START NEWLINE; SPACES(S+4) PRINT SYMBOL('!') %FINISH %IF J#';' %AND CC(Q)='B'+128 %AND Q100 %THEN %START PRINTSTRING( ' DISASTER ') ABORT; %STOP %FINISH PRINTNAME(FNAME) %UNLESS FNAME=0 %FINISH %IF TTOPUT#0 %THEN %START Q=QP; TTOPUT=0 SELECT OUTPUT(87) FAULT(N, FNAME) FAULTY=FAULTY-1 NEWLINE SELECT OUTPUT(82) TTOPUT=1 %FINISH %END %ROUTINE WARN(%INTEGER N,V) %CONSTSTRING(23)%ARRAY MESS(1:5)=' KEYWORD IN COMMENT', ' NAME ? NOT USED ', ' LAB ? PASSED BY NAME!', ' DUMMY STMNT COMPILED', ' STRING CNST TRUNCATED' %STRING(30) T; %STRING(120) S %IF MESS(N)->S.('?').T %THEN S=S.STRING(ADDR(LETT(WRD(V)))) %C .T %ELSE S=MESS(N) PRINTSTRING(' ? WARNING :- '.S.' AT STATEMENT NO') WRITE(LINE,1) %END %ROUTINE ABORT PRINTSTRING( ' **************** ABORT******************** ABORT *******') !*DELSTART RECODE(ADDR(CODE(0)), ADDR(CODE(PPCURR)), CABUF) %C %UNLESS CA=CABUF PRINT USE !*DELEND %MONITOR; %STOP %END %ROUTINE COMPARE %LONGREAL ALIGN %INTEGER RA, RL, RP, RQ, RR, RS, MARKER, ALT, SC, PP, SSL, I, J %CONSTINTEGERARRAY OPMASK(0:7)=0,X'00350000',2,0(3),X'08008000',0; %SWITCH BIP(999:1044) !QIN *JLK_2 !QIN *EXIT_-64 SUBENTRY: RP=SYMBOL(P) RL=LEVEL %IF P=SS %START I=CC(Q) %IF I>'Z' %AND I#'F'+128 %AND I#'G'+128 %AND %C (I#'I'+128 %OR CC(Q+1)#'F'+128) %START RQ=Q; RR=R; SSL=STRLINK; ALT=2; SC=LINE; P=P+1 RS=SYMBOL(P); RA=SYMBOL(RS); ->UPR %FINISH %FINISH P=P+1; PP=P ->COMM ! ROUTINE REALLY STARTS HERE BIP(999): ! REPEATING PHRASES A(RR)=ALT; P=PP; ! P BACK TO CURRENT PHRASE AGN COMM: ! COMMON INITIALISE CODEING RQ=Q; RR=R; ! RESET VALUES OF LINE&AR PTRS SSL=STRLINK; ! SAVE STRLINK IN CASE BACK- ! -TRACKING ACROSS A RT CALL ALT=1; SC=LINE; ! FIRST ALTERNATIVE TO BE TRIED RA=SYMBOL(P); RS=P; ! RA TO NEXT PHRASE ALTERNATIVE 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 ->NEXTBR BIP(1000): A(RR)=ALT HIT=1 !QOUT; %RETURN !QIN *J_%TOS NEXTBR: ! ONTO NEXT BRICK ITEM=SYMBOL(RS); ! NEXT BRICK IN THE CURRENT ALT ! WRITE(ITEM,5) %IF SMAP#0 %IF ITEM<999 %START %IF CC(Q)=ITEM %THEN Q=Q+1 %AND ->SUCC ->FAIL %FINISH %IF ITEM <1300 %THEN ->BIP(ITEM) P=ITEM !QOUT; COMPARE !QIN *LSQ_RA !QIN *SLSQ_RR !QIN *SLSQ_SC !QIN *ST_%TOS !QIN *JLK_ !QIN *LSQ_%TOS !QIN *ST_SC !QIN *LSQ_%TOS !QIN *ST_RR !QIN *LSQ_%TOS !QIN *ST_RA %IF HIT#0 %THEN ->SUCC FAIL: QMAX=Q %IF Q>QMAX; ! FAILURE - NOTE POSITION REACHD Q=RQ; R=RR; LINE=SC; ! RESET LINE AND A.R. POINTERS STRLINK=SSL %IF RA=RP %START; ! TOTAL FAILURE NO ALT LEFT TO !TRY LEVEL=RL; HIT=0 !QOUT; %RETURN !QIN *J_%TOS %FINISH RS=RA; ALT=ALT+1; ! MOVE TO NEXT ALT OF PHRASE RA=SYMBOL(RA); ->UPR BIP(1001): ! PHRASE NAME BIP(1004): ! PHRASE OLDNAME %IF LASTAT=Q %THEN %START A(R)=LASTNAME Q=LASTEND ->UPR %FINISH ->FAIL %UNLESS TRTAB(CC(Q))=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 %IF CTYPE=2 %START; ! %REAL A(R)=2 A(R+1)=INTEGER(ADDR(CVALUE)) A(R+2)=INTEGER(ADDR(CVALUE)+4) R=R+3 %FINISH %ELSE %START A(R)=1 A(R+1)= S; R=R+2 %FINISH; ->SUCC BIP(1005): ! PHRASE COMMENT TEXT S=0 I=CC(Q) %WHILE I#';' %CYCLE %IF I&128#0 %THEN %START S=1 %IF I='N'+128 %AND CC(Q-1)='I'+128 %AND CC(Q-2)='G'+128%C %AND CC(Q-3)='E'+128 %AND CC(Q-4)='B'+128 %THEN %C LINE=LINE+1 %IF I='E'+128 %AND CC(Q+1)='N'+128 %AND CC(Q+2)='D'+128%C %THEN LINE=LINE+1 %FINISH Q=Q+1; I=CC(Q) %REPEAT %IF S#0 %THEN WARN(1,0) Q=Q+1; ->SUCC BIP(1006): ! PHRASE S=SEPARATOR J=Q-5 %IF CC(J+4)='N'+128 %AND CC(J+3)='I'+128 %C %AND CC(J+2)='G'+128 %AND CC(J+1)='E'+128 %C %AND CC(J)='B'+128 %THEN ->SEP I=CC(Q) %IF I=';' %THEN Q=Q+1 %AND ->SEP %IF I='E'+128 %AND CC(Q+1)='N'+128 %C %AND CC(Q+2)='D'+128 %THEN ->SEP ->FAIL SEP: ! SEPERATOR FOUND %IF JROUND(LEVEL)#0 %AND JROUND(LEVEL)&255=0 %THEN ->UP ->SUCC BIP(1007): S=0 %CYCLE; ! PHRASE ENDTEXT=COMMENT TEXT %WHILE ';'#CC(Q)#'E'+128 %CYCLE %IF CC(Q)>128 %AND S=0 %THEN S=1 %AND WARN(1,0) Q=Q+1 %REPEAT ->SUCC %IF CC(Q)=';' ->SUCC %IF CC(Q+1)='N'+128 %AND CC(Q+2)='D'+128 ->SUCC %IF CC(Q+1)='L'+128 %AND CC(Q+2)='S'+128 %C %AND CC(Q+3)='E'+128 Q=Q+1 %REPEAT BIP(1008): ! PHRASE TEXTTEXT=BETWEEN QUOTES TEXTTEXT ->FAIL %IF HIT=0; ->UPR BIP(1009): ! PHRASE NAMELIST BIP(1012): ! PHRASE OLD NAMELIST ! GIVES AR IN FORM NNAMES,NAME1,....NAMEN U=R; V=1; R=R+1 PNAME(ITEM-1012) ->FAIL %IF HIT=0 %CYCLE J=CC(Q) Q=Q+1 %EXIT %UNLESS J=',' I=CC(Q) PNAME(ITEM-1012) %EXIT %IF HIT=0; V=V+1 %REPEAT Q=Q-1 A(U)=V; ->SUCC BIP(1010): ! PHRASE HOLE MARKER=R; ->UPR BIP(1011): ! PHRASE MARK A(MARKER)=R-MARKER ->SUCC BIP(1013): ! PHRASE UP STATEMENT COUNT LINE=LINE+1; ->SUCC BIP(1014): ! PHRASE LETTER STRING I=CC(Q) ->FAIL %UNLESS 'A'<=I<='Z' Q=Q+1 %WHILE 'A'<=CC(Q)<='Z' ->SUCC BIP(1015): ! PHRASE DOWN=NEW TEXT LEVEL %IF LEVEL>=2 %THEN %C A(SET(LEVEL))=A(SET(LEVEL))+X'1000';! NOTE NESTED BLK LEVEL=LEVEL+1 JROUND(LEVEL)=0 RAL(LEVEL)=R; !RAL FOR LINKING LABELS A(R)=0; R=R+1 FLAG(LEVEL)=R; ! FLAG FOR LINKING SCALARS A(R)=0; R=R+1 L(LEVEL)=R; ! L FOR LINKING ARRAYS A(R)=0; R=R+1 M(LEVEL)=R; ! M FOR LINKING SWITCHES A(R)=0; R=R+1 NMDECS(LEVEL)=R; ! NMDECS FOR LINKING OWNS A(R)=0; R=R+1 STACKBASE(LEVEL)=R; ! STACKBASE FOR LINKING PROCS A(R)=0; R=R+1 SET(LEVEL)=R; ! A(SET(LEVEL)) COUNTS EMBEDDED LABS A(R)=0; R=R+1; ->SUCC BIP(1016): ! PHRASE UP 1 TEXTUAL LEVEL %IF JROUND(LEVEL)&255#0 %THEN %C JROUND(LEVEL)=JROUND(LEVEL)-1 %AND ->SUCC UP: I=NAMES(LEVEL) %WHILE 0<=I<=NNAMES %CYCLE J=NTYPE(I) NTYPE(I)=0 %IF TAGS(I)#0 %THEN POP(TAGS(I), NTYPE(I), DPOSN(I)) I=J>>16 %REPEAT NAMES(LEVEL)=-1 LEVEL=LEVEL-1 ->SUCC BIP(1017): ! PHRASE SCALAR TYPE TYPE=A(R-2); ->SUCC %UNLESS TYPE=4; ->FAIL BIP(1018): ! PHRASE DECLARE NAME I=A(R-1) J=NTYPE(I) %IF J&31=LEVEL %THEN %START QMAX=Q-T %AND Q=QMAX %AND ->FAIL %C %UNLESS TYPE=J>>8&255 %AND (TYPE>=128 %OR TYPE=38) %FINISH %ELSE %START %IF J#0 %THEN PUSH(TAGS(I), J, DPOSN(I)) NTYPE(I)=TYPE<<8!LEVEL!NAMES(LEVEL)<<16 DPOSN(I)=R-1 NAMES(LEVEL)=I %FINISH ->SUCC BIP(1019): ! PHRASE TYPE=ARITHMETIC ->SUCC %IF 1<=NTYPE(LASTNAME)>>8&7<=2 QMAX=QMAX-T; Q=QMAX; ->FAIL BIP(1020): ! PHRASE TYPE=BOOLEAN ->SUCC %IF NTYPE(LASTNAME)>>8&7=3 QMAX=QMAX-T; Q=QMAX; ->FAIL BIP(1021): ! PHRASE ARRAYTYPE TYPE=A(R-2)+32 TYPE=34 %IF TYPE=36; ->SUCC BIP(1022): ! PHRASE PROCTYPE TYPE=A(R-2)&3+128; ->SUCC BIP(1023): ! PHRASE LINK SCALAR DECLNS ->FAIL %IF LEVEL<=1 A(FLAG(LEVEL))=R-FLAG(LEVEL)-1 A(R)=0; FLAG(LEVEL)=R; R=R+1; ->SUCC BIP(1024): ! PHRASE LINK ARRAY DECLNS ->FAIL %IF LEVEL<=1 A(L(LEVEL))=R-L(LEVEL)-1 A(R)=0; L(LEVEL)=R; R=R+1; ->SUCC BIP(1025): ! PHRASE CHKLPL(LOOK FOR :=) ->FAIL %UNLESS TRTAB(CC(Q))=2 I=Q I=I+1 %WHILE ';'#CC(I)#':' %IF CC(I)=':' %AND CC(I+1)='=' %THEN ->SUCC ->FAIL BIP(1026): ! PHRASE LABTYPE PASS2INF=PASS2INF!LABBYNAME; ! NOTE PRESENCE OF LAB PARAMETERS TYPE=6; ->SUCC BIP(1043): ! PHRASE SWITCH BY NAME PASS2INF=PASS2INF!SWBYNAME; ! NOTE PRESENCE OF FORMAL SWITCH BIP(1027): ! PHRASE SWTYPE TYPE=38; ->SUCC BIP(1028): ! PHRASE STRTYPE TYPE=5; ->SUCC BIP(1029): ! PHRASE CHK LAB I=Q I=I+1 %WHILE TRTAB(CC(I))#0 %IF CC(I)=':' %AND CC(I+1)#'=' %AND %C (CC(I+1)#'C'+128 %OR CC(I+2)#'O'+128 %OR CC(I+3)#'M'+128)%C %THEN ->SUCC ->FAIL BIP(1030): ! TYPE=ARR ->FAIL %IF NTYPE(LASTNAME)>>8&32=0 ->SUCC %IF CC(Q)='[' %OR (CC(Q)='(' %AND CC(Q+1)='/') I=DPOSN(LASTNAME) A(I)=A(I)!X'10000' ->SUCC BIP(1031): ! PHRASE LINK SWITCH DECLNS ->FAIL %IF LEVEL<=1 A(M(LEVEL))=R-M(LEVEL)-2 A(R)=0; M(LEVEL)=R; R=R+1; ->SUCC BIP(1032): ! PHRASE LINK OWN DECLNS ->FAIL %IF LEVEL<=1 A(NMDECS(LEVEL))=R-NMDECS(LEVEL) A(R)=0; NMDECS(LEVEL)=R; R=R+1; ->SUCC BIP(1033): ! PHRASE LINK PROC STMNTS A(STACKBASE(LEVEL))=R-STACKBASE(LEVEL)-1 A(R)=0; STACKBASE(LEVEL)=R; R=R+1; ->SUCC BIP(1034): ! PHRASE LINKLAB ->FAIL %IF LEVEL<=1 A(RAL(LEVEL))=R-RAL(LEVEL)-2 A(R)=0; RAL(LEVEL)=R; I=LEVEL-1 %WHILE I>=2 %CYCLE A(SET(I))=A(SET(I))+1 I=I-1 %REPEAT R=R+1; ->SUCC BIP(1035): ! PHRASE NOMORE I=CC(Q) ->SUCC %IF I=')' %OR I=',' ->FAIL BIP(1036): ! PHRASE CMPND I=CC(Q) ->FAIL %UNLESS I=';' %OR I='E'+128 %OR CC(Q-1)='N'+128 JROUND(RL)=JROUND(RL)+1 LINE=LINE+1; ->SUCC BIP(1037): ! PHRASE UP AT (NEXT) SEP JROUND(LEVEL)=JROUND(LEVEL)+256 ->SUCC BIP(1038): ! P(PLUS')='+','-',0 I=CC(Q) %IF I='-' %THEN A(R)=2 %AND Q=Q+1 %ELSE A(R)=3 %IF I='+' %THEN Q=Q+1 ->UPR BIP(1039): ! P(OP)=^,**,+,-,*,/,%DIV,// I=CC(Q) ->FAIL %UNLESS OPMASK(I>>5)&X'80000000'>>(I&31)#0 Q=Q+1 %IF I='-' %THEN A(R)=4 %AND ->UPR %IF I='+' %THEN A(R)=3 %AND ->UPR J=CC(Q) %IF I='*' %THEN %START %IF J#'*' %THEN A(R)=5 %AND ->UPR Q=Q+1; A(R)=2; ->UPR %FINISH %IF I='/' %THEN %START %IF J#'/' %THEN A(R)=6 %AND ->UPR Q=Q+1; A(R)=7; ->UPR %FINISH %IF I='^' %THEN A(R)=1 %AND ->UPR %IF I='D'+128 %AND J='I'+128 %AND CC(Q+1)='V'+128 %THEN %C Q=Q+2 %AND A(R)=7 %AND ->UPR ! %IF I='P'+128 %AND J='O'+128 %AND CC(Q+1)='W'+128 %AND %C CC(Q+2)='E'+128 %AND CC(Q+3)='R'+128 %THEN %C Q=Q+4 %AND A(R)=8 %AND ->UPR ->FAIL BIP(1040): ! PHRASE CHECKSC ->SUCC %IF CC(Q)=';'; ->FAIL BIP(1041): ! PHRASE LEFT SQUARE BRACKET I=CC(Q) %IF I='[' %THEN Q=Q+1 %AND ->SUCC %UNLESS I='(' %AND CC(Q+1)='/' %THEN ->FAIL Q=Q+2; ->SUCC BIP(1042): ! PHRASE RIGHT SQUARE BRACKET I=CC(Q) %IF I=']' %THEN Q=Q+1 %AND ->SUCC %UNLESS I='/' %AND CC(Q+1)=')' %THEN ->FAIL Q=Q+2; ->SUCC BIP(1044): ! (NOT)=%NOT OR \ I=CC(Q) %IF I='\' %THEN Q=Q+1 %AND ->SUCC %IF I='N'+128 %AND CC(Q+1)='O'+128 %AND CC(Q+2)='T'+128 %C %THEN Q=Q+3 %AND ->SUCC ->FAIL %END; !OF ROUTINE 'COMPARE' %ROUTINE PNAME(%INTEGER MODE) !*********************************************************************** !* MODE=0 FOR OLD NAME(ALREADY IN DICT), MODE=1 FOR NEW NAME * !*********************************************************************** %CONSTINTEGERARRAY HASH(1:7)=47,97,79,29,37,53,59; %INTEGER JJ, KK, LL, FQ, FS, NUM, S, I HIT=0; FQ=Q; FS=CC(Q) %RETURN %UNLESS TRTAB(FS)=2; ! 1ST CHAR MUST BE LETTER S=2; 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)*I %IF T<=7 T=T+1; S=S+1 LETT(NEXT+T)=I %REPEAT %IF T>8 %THEN T=8 %AND S=9 LETT(NEXT)=T; ! INSERT LENGTH FAULT(108,0) %IF NEXT+S>DSIZE;!DICTIONARY OVERFLOW JJ=JJ+113*T %CYCLE NUM=JJ, 1, JJ+NNAMES KK=NUM&NNAMES; ! TREAT DICTIONARY AS CYCLIC LL=WRD(KK) ->HOLE %IF LL=0; ! NAME NOT KNOWN ->FND %IF STRING(ADDR(LETT(NEXT)))=STRING(ADDR(LETT(LL))) %REPEAT FAULT(104, 0); ! TOO MANY NAMES HOLE: %IF MODE=0 %THEN Q=FQ %AND ->XIT WRD(KK)=NEXT; NEXT=NEXT+S FND: LASTAT=FQ; HIT=1; LASTNAME=KK A(R)=LASTNAME R=R+1 LASTEND=Q XIT: %END %ROUTINE CONST(%INTEGER MODE) !*********************************************************************** !* MODE=0 FOR NORMAL MODE=2 FOR EXPONENT (IE INTEGER CONSTANTS) * !*********************************************************************** %INTEGER Z, I !QOUT;%LONGREAL X,CV !QOUT;%CONSTLONGREAL TEN=10 !QIN%LONGLONGREAL X,CV !QIN %CONSTLONGLONGREAL TEN=R'41A00000000000000000000000000000' CV=0; I=CC(Q); CTYPE=1; HIT=0 S=0; ->N %IF M'0'<=I<=M'9' ->DOT %IF I='.' %AND MODE=0 ! 1 DIDT MIN %IF I='&' %AND MODE=0 %THEN CV=1 %AND ->ALPHA %RETURN N: I=I&15; CV=TEN*CV+I Q=Q+1; I=CC(Q) ->N %IF M'0'<=I<=M'9' ->ALPHA %UNLESS MODE=0 %AND I='.' DOT: Q=Q+1; X=TEN; CTYPE=2 I=CC(Q) %RETURN %UNLESS '0'<=I<='9'; ! '23.' NOT VALID IN ALGOL %WHILE '0'<=I<='9' %CYCLE CV=CV+(I&15)/X X=TEN*X; Q=Q+1 I=CC(Q) %REPEAT ALPHA: ! TEST FOR EXPONENT ->FIX %UNLESS MODE=0 %AND (CC(Q)='&' %OR CC(Q)='@') Q=Q+1; X=CV; CTYPE=2 Z=1; %UNLESS '+'#CC(Q)#'-' %START Z=-1 %IF CC(Q)='-'; Q=Q+1 %FINISH CONST(2); %RETURN %IF HIT=0; S=S*Z HIT=0; CTYPE=2 %RETURN %UNLESS -78<=S<=78 %OR S=-99;! OUTSIDE RANGE %IF S=-99 %THEN CV=0 %ELSE %START CV=X !QIN *MPSR_X'8080' %WHILE S>0 %CYCLE S=S-1 CV=CV*TEN !QIN *JAT_15, %REPEAT %WHILE S<0 %AND CV#0 %CYCLE S=S+1 CV=CV/TEN %REPEAT %FINISH FIX: ! SEE IF IT IS INTEGER !QOUT; CVALUE=CV !QIN *LSD_X'7F00000000000000' !QIN *AND_CV !QIN *SLSD_X'0080000000000000' !QIN *AND_CV+8 !QIN *LUH_%TOS !QIN *RAD_CV !QIN *STUH_CVALUE %IF CTYPE#1 %THEN HIT=1 %AND %RETURN %IF CVALUE<=IMAX %THEN %START S=INT(CVALUE) CTYPE=1; HIT=1; %RETURN %FINISH FAIL: %END %ROUTINE TEXTTEXT %CONSTINTEGER TXT1='<' %INTEGER S, J, BR, FIRST, LAST, OLDLINE, I, AAR S=R; R=R+2; BR=1; HIT=0; OLDLINE=LINE I=CC(Q) %RETURN %UNLESS I=TXT1 %OR I=123; !FAIL UNLESS INITIAL QUOTE FIRST=I; LAST=FIRST+2 Q=Q+1; J=0; AAR=ADDR(A(R)) %UNTIL BR=0 %CYCLE I=CC(Q) %IF I=FIRST %THEN BR=BR+1 %IF I=LAST %THEN BR=BR-1 %IF I=';' %THEN LINE=LINE+1 %IF I>128 %AND CC(Q-1)<128 %THEN %C BYTE INTEGER(AAR+J)=KYCHAR1 %AND J=J+1 %IF I<128 %AND CC(Q-1)>128 %THEN %C BYTE INTEGER(AAR+J)=KYCHAR2 %AND J=J+1 BYTE INTEGER(AAR+J)=I J=J+1; Q=Q+1 %IF Q>LENGTH %THEN LINE=OLDLINE %AND FAULT(106,0) %REPEAT %IF J>256 %THEN WARN(5,0) %AND J=256 J=J-1 R=R+(J+3)>>2 A(S+1)=J A(S)=STRLINK; STRLINK=S HIT=1 %END ! THE NEXT 4 ROUTINES CAN BE !MACROISED USING MVC ! %ROUTINE PRINTNAME(%INTEGER N) %INTEGER V, K SPACE; V=WRD(N) K=LETT(V) %IF K=0 %THEN PRINTSTRING('???') %ELSE %C PRINTSTRING(STRING(ADDR(LETT(V)))) %END ! !*********************************************************************** !* IMP CODE PLANTING ROUTINES * !* CODE AND GLAP ARE PUT INTO THE BUFFERS 'CODE,GLABUF(0:268)' * !* BY A NUMBER OF TRIVIAL ROUTINES.LPUT IS CALLED TO ADD THE * !* BUFFER TO THE OUTPUT FILE. THE BUFFERS ARE BASICALLY 0:255 * !* WITH A 12-BYTE MARGIN TO MINIMISE THE NUMBER OF TESTS FOR * !* THE BUFFER FULL CONDITION * !* * !* PPCURR(GLACURR) IS THE BUFFER POINTER * !* CA(GLACA) IS THE RELATIVE ADDRESS OF THE NEXT BYTE * !* CABUF(GLACABUF) IS CA(GLACA) FOR START OF BUFFER * !*********************************************************************** !*DELSTART %ROUTINE RECODE(%INTEGER S,F,AD) %IF S#F %START PRINTSTRING(' CODE FOR STATEMENT'); WRITE(LINE,5) NCODE(S,F,AD) %FINISH %END !*DELEND %ROUTINE CODEOUT %IF PPCURR>0 %THEN %START !*DELSTART RECODE(ADDR(CODE(0)), ADDR(CODE(PPCURR)), CABUF) %C %IF DCOMP#0 !*DELEND LPUT(1, PPCURR, CABUF, ADDR(CODE(0))) %IF INHCODE=0 PPCURR=0; CABUF=CA %FINISH %END %ROUTINE PLANT(%INTEGER HALFWORD) !*********************************************************************** !* ADD A HALF WORD OF BINARY TO THE BUFFER * !*********************************************************************** CODE(PPCURR)<-HALFWORD>>8 CODE(PPCURR+1)<-HALFWORD PPCURR=PPCURR+2 CA=CA+2 CODEOUT %IF PPCURR>=256 %END %ROUTINE PCONST(%INTEGER WORD) !*********************************************************************** !* ADD A WORD OF BINARY TO THE BUFFER * !*********************************************************************** %INTEGER I %CYCLE I=24,-8,0 CODE(PPCURR)=WORD>>I&255 PPCURR=PPCURR+1 %REPEAT CA=CA+4 CODE OUT %IF PPCURR>=256 %END %ROUTINE PSF1(%INTEGER OPCODE,K,N) !*********************************************************************** !* PLANT THE HALFWORD FORMS OF PRIMARY FORMAT NR INSTRNS * !* IF N IS TOO LARGE FOR THE SHORT FORM PF1 IS CALLED TO PLANT * !* THE CORRESPONDING LONG FORM * !*********************************************************************** %INTEGER KPP ! ABORT %UNLESS 0<=K<=2 %AND OPCODE&1=0 %IF (K=0 %AND -64<=N<=63) %OR (K#0 %AND 0<=N<=511) %START %IF K#0 %THEN N=N//4 CODE(PPCURR)=OPCODE!K>>1 CODE(PPCURR+1)=(K&1)<<7!N&127 CA=CA+2 PPCURR=PPCURR+2 CODEOUT %IF PPCURR>=256 %FINISH %ELSE %START %IF K=0 %THEN KPP=0 %ELSE KPP=2 PF1(OPCODE,K>>1<<1,KPP,N) %FINISH %END %ROUTINE PF1(%INTEGER OPCODE,KP,KPP,N) !*********************************************************************** !* PLANT THE NORMAL FORMS OF PRIMARY FORMAT INSTRNS(IE THOSE * !* WHICH DO NOT DEPEND ON THE SIZE OF N) * !*********************************************************************** %INTEGER INC ! ABORT %UNLESS 0<=KP<=3 %AND 0<=KPP<=7 %AND OPCODE&1=0 %IF KPP=PC %THEN N=(N-CA)//2 %IF (1<>16&3) %IF KPP<=5 %THEN %START CODE(PPCURR+2)=N>>8&255 CODE(PPCURR+3)=N&255 INC=4 %FINISH CA=CA+INC; PPCURR=PPCURR+INC CODEOUT %IF PPCURR>=256 %END %ROUTINE PSORLF1(%INTEGER OPCODE,KP,KPP,N) !*********************************************************************** !* AS PF1 BUT CUT VALID FORMS TO SHORT FORM * !*********************************************************************** %INTEGER INC INC=2 %IF (KPP=0=KP %AND -64<=N<=63) %OR%C (KPP=LNB %AND KP&1=0 %AND 0<=N<=511) %START %IF KPP=LNB %THEN KP=1+KP>>1 %IF KP#0 %THEN N=N//4 CODE(PPCURR)=OPCODE!KP>>1 CODE(PPCURR+1)=(KP&1)<<7!(N&127) %FINISH %ELSE %START %IF KPP=PC %THEN N=(N-CA)//2 %IF (1<>16&3) %IF KPP<=5 %THEN %START CODE(PPCURR+2)=N>>8&255 CODE(PPCURR+3)=N&255 INC=4 %FINISH %FINISH CA=CA+INC; PPCURR=PPCURR+INC CODEOUT %IF PPCURR>=256 %END %ROUTINE PF2(%INTEGER OPCODE,H,Q,N,MASK,FILLER) !*********************************************************************** !* PLANT SECONDARY(STORE TO STORE) FORMAT INSTRNS * !* THESE MAY BE 16 OR 32 BIT DEPENDING ON Q * !*********************************************************************** ! ABORT %UNLESS 0<=H<=1 %AND 0<=Q<=1 %AND 0<=N<=127 %C %AND OPCODE&1=0 PLANT(OPCODE<<8!H<<8!Q<<7!N) %IF Q#0 %THEN PLANT(MASK<<8!FILLER) %END %ROUTINE PF3(%INTEGER OPCODE,MASK,KPPP,N) !*********************************************************************** !* PLANT THE TERTIARY(JUMP) FORMAT INSTRUCTIONS * !*********************************************************************** ! ABORT %UNLESS 0<=MASK<=15 %AND 0<=KPPP<=7 %AND OPCODE&1=0 %IF KPPP=PC %THEN N=(N-CA)//2 CODE(PPCURR)=OPCODE!MASK>>3&1 CODE(PPCURR+1)=(MASK&7)<<5!KPPP<<2!(N>>16&3) PPCURR=PPCURR+2 CA=CA+2 %IF KPPP<=5 %THEN %START CODE(PPCURR)=N>>8&255 CODE(PPCURR+1)=N&255 PPCURR=PPCURR+2; CA=CA+2 %FINISH CODEOUT %IF PPCURR>=256 %END %ROUTINE PCLOD(%INTEGER FROM, TO) !*********************************************************************** !* PLANT A SERIES OF INTRUNS FROM ARRAY FIXED CODE * !*********************************************************************** %INTEGER I,T,B %CONSTINTEGERARRAY FIXED CODE(0:117)= %C X'7B985398',X'5D986E04', X'1C015D98',X'49985B98', X'7E846C09',X'1FCC000A', X'1B981A01',0, X'0580000B',X'63985F98', X'73986F9C',X'2A04779C', X'B1800081',X'49981B98', X'00000000',X'5F98E398', X'E87EE001',X'43986F98', X'49981B98',0, X'49987998',X'5D986E04', X'63A00004',X'43A00002', X'422343DC',X'49987E84', X'6C091FCC',X'000A1A01', 0, M'FREE', M'FREE',M'FREE', M'FREE',M'FREE', M'FREE',M'FREE', M'FREE',M'FREE', M'FREE',M'FREE', M'FREE',0, X'7E807F8C',X'00046485', X'499879CC',X'000C63DC', X'48866289',X'E8658A07', X'E79C0240',X'00320280', X'00188A03',X'EA044285', X'8B81FFFF',X'EB98499C', X'E08649DC',X'E7A00002', X'02400044',X'779C7398', X'12007286',X'B3006685', X'38006201',X'E81BE089', X'48858B81',X'FFFF499C', X'EA08E086',X'49DCE7A0', X'00020240',X'002D2201', X'63E80009',X'A80049E8', X'00050783',X'FFFA6685', X'38006201',X'E81BE489', X'48858B81',X'FFFF499C', X'EA04E086',X'49DCE7A0', X'00020240',X'00152201', X'65E80009',0, X'F837F849',X'5B98B99C', X'2A04E99C',X'32117B98', X'49E80005',X'0783FFF1', X'66853800',0, X'7B987998',X'5B985998', X'45980440',X'00370600', X'00074598',X'06200032', X'65981B98',X'45984998', X'0440001A',X'F837F849', X'B99C2A04',X'26400340', X'00037A40',X'E99C4B9C', X'02E0000E',X'6E7E499C', X'6201A800',X'07800005', X'6E7E1B98',X'5998FB98', X'247E1B98',X'65984598', X'5D986E04',X'49987E84', X'6C071A01',X'FB985D98', X'6E044998',X'7E846C07'; B=(TO-FROM+1)*4 B=B-2 %IF FIXED CODE(TO)&X'FFFF'=X'1A01' CODE OUT %IF PPCURR+B>=256 T=ADDR(FIXED CODE(FROM)) %CYCLE I=0,1,B-1 CODE(PP CURR)=BYTEINTEGER(T+I) PP CURR=PP CURR+1 %REPEAT CA=CA+B %END %ROUTINE CNOP(%INTEGER I, J) PSF1(JUNC,0,1) %WHILE CA&(J-1)#I %END %ROUTINE PGLA(%INTEGER BDRY, L, INF ADR) %INTEGER I, J J=GLACA; GLACA=(J+BDRY-1)&(-BDRY) GLACURR=GLACURR+GLACA-J; ! COMPLETE THE ROUNDING %IF L+GLACURR>256 %THEN %START %IF INHCODE=0 %C %THEN LPUT(2, GLACURR, GLACABUF, ADDR(GLABUF(0))) GLACURR=0; GLACABUF=GLACA %FINISH %CYCLE I=0,1,L-1 GLABUF(GLACURR+I)=BYTE INTEGER(I+INF ADR) %REPEAT GLACA=GLACA+L; GLACURR=GLACURR+L %END %ROUTINE PLUG(%INTEGER AREA, AT, VALUE) !*********************************************************************** !* WRITE ONE WORD INTO OBJECT FILE OUT OF SEQUENCE * !*********************************************************************** %INTEGERNAME WCABUF %INTEGER RELAD, BUFAD WCABUF==CABUF; BUFAD=ADDR(CODE(0)) %IF AREA=2 %THEN WCABUF==GLACABUF %AND BUFAD=ADDR(GLABUF(0)) RELAD=AT-WCABUF %IF RELAD>=0 %AND AREA<=3 %THEN %START %CYCLE I=0,1,3 BYTEINTEGER(RELAD+BUFAD+I)<-VALUE>>((3-I)<<3) %REPEAT %FINISH %ELSE %START %IF RELAD=-2 %THEN CODEOUT %IF INHCODE=0 %THEN LPUT(AREA, 4, AT, ADDR(VALUE)) !*DELSTART NCODE(ADDR(VALUE),ADDR(VALUE)+4,AT) %IF DCOMP=1=AREA !*DELEND %FINISH %END %ROUTINE ALLOC CSPACE !*********************************************************************** !* ALLOCATE 30 WORDS IN THE CODE FOR CONSTANTS * !*********************************************************************** %INTEGER I CNOP(2,4) PSF1(JUNC,0,61) CNSTAT=CA CODE OUT %CYCLE I=0,1,119 CODE(I)=0 %REPEAT SPCNST=30 PP CURR=120 CA=CA+120 %END %ROUTINE GET ENV(%INTEGERNAME HEAD) !*********************************************************************** !* SAVE A COPY OF THE REGISTER STATE FOR FUTURE REFERENCE * !*********************************************************************** %INTEGER I,J %CYCLE J=0, 1, 4; I=GRMAP(J) PUSH123(HEAD, GRINF(I), GRAT(I), I<<8!GRUSE(I)) %C %IF GRUSE(I)>1 %REPEAT %END %ROUTINE RESTORE(%INTEGER HEAD) !*********************************************************************** !* RESET THE REGISTERS TO ENVIRONMENT IN LIST HEADED BY 'HEAD' * !*********************************************************************** %INTEGER I, J, R, USE, INF, AT %CYCLE J=0, 1, 4; I=GRMAP(J) GRUSE(I)=0; GRINF(I)=0 %REPEAT %WHILE HEAD#0 %CYCLE POP123(HEAD, INF, AT, I) R=I>>8; USE=I&255 GRUSE(R)=USE; GRINF(R)=INF GRAT(R)=AT %REPEAT %END !*DELSTART %ROUTINE PRHEX(%INTEGER VALUE, PLACES) %CONSTBYTEINTEGERARRAY HEX(0:15)='0','1','2','3','4', '5','6','7','8','9','A','B','C','D','E','F' %INTEGER I %CYCLE I=PLACES<<2-4, -4, 0 PRINT SYMBOL(HEX(VALUE>>I&15)) %REPEAT %END %ROUTINE CHECK ASL %INTEGER N,Q N=0; Q=ASL %WHILE Q#0 %THEN N=N+1 %AND MLINK(Q) NEWLINE; WRITE(LINE,5) PRINTSTRING('FREE CELLS =') WRITE(N,5); NEWLINE %END %ROUTINE PRINT LIST(%INTEGER HEAD) %INTEGER I,J,K %WHILE HEAD#0 %CYCLE FROM123(HEAD,I,J,K) NEWLINE WRITE(HEAD,3) SPACES(3) PRHEX(I,8) SPACES(3) PRHEX(J,8) SPACES(3) PRHEX(K,8) NEWLINE MLINK(HEAD) %REPEAT %END ! !*DELEND %ROUTINE PUSH(%INTEGERNAME CELL, %INTEGER S1, S2) !*********************************************************************** !* THE OLD (TWO STREAM) VERSION OF PUSH123 * !*********************************************************************** %INTEGER I %RECORDNAME LCELL(LISTF) I=ASL %IF I=0 %THEN FAULT(107,0) %ELSE %START LCELL==ASLIST(I) ASL=LCELL_LINK LCELL_LINK=CELL; CELL=I LCELL_S1=S1 LCELL_S2=S2 LCELL_S3=0 %FINISH %END %ROUTINE PUSH123(%INTEGERNAME CELL, %INTEGER S1, S2, S3) !*********************************************************************** !* PUSH A CELL CONTAINING THE 3 STREAMS OF INFORMATION GIVEN * !* ONTO THE TOP OF THE LIST POINTED AT BY CELL. * !*********************************************************************** %INTEGER I %RECORDNAME LCELL(LISTF) I=ASL %IF I=0 %THEN FAULT(107,0) %ELSE %START LCELL==ASLIST(I) ASL=LCELL_LINK LCELL_LINK=CELL; CELL=I LCELL_S1=S1 LCELL_S2=S2 LCELL_S3=S3 %FINISH %END %ROUTINE POP(%INTEGERNAME CELL, S1, S2) !*********************************************************************** !* OLD (TWO STREAM) VERSION OF POP123 * !*********************************************************************** %INTEGER I %RECORDNAME LCELL(LISTF) I=CELL; LCELL==ASLIST(I) S1=LCELL_S1 S2=LCELL_S2 %IF I# 0 %THEN %START CELL=LCELL_LINK LCELL_LINK=ASL ASL=I %FINISH %END %ROUTINE POP123(%INTEGERNAME CELL, S1, S2, S3) !*********************************************************************** !* COPY THE INFORMATION FROM THE TOP CELL OF LIST 'CELL' INTO * !* S1,S2&S3 AND THEN POP THE LIST UP 1 CELL. EMPTYLIST GIVE -1S* !*********************************************************************** %INTEGER I %RECORDNAME LCELL(LISTF) I=CELL; LCELL==ASLIST(I) S1=LCELL_S1 S2=LCELL_S2 S3=LCELL_S3 %IF I# 0 %THEN %START CELL=LCELL_LINK LCELL_LINK=ASL ASL=I %FINISH %END %ROUTINE REPLACE1(%INTEGER CELL, S1) ASLIST(CELL)_S1=S1 %END %ROUTINE REPLACE2(%INTEGER CELL, S2) ASLIST(CELL)_S2=S2 %END %ROUTINE REPLACE3(%INTEGER CELL, S3) ASLIST(CELL)_S3=S3 %END !%ROUTINE REPLACE123(%INTEGER CELL,S1,S2,S3) ! ASLIST(CELL)_S1=S1 ! ASLIST(CELL)_S2=S2 ! ASLIST(CELL)_S3=S3 !%END %ROUTINE MLINK(%INTEGERNAME CELL) CELL=ASLIST(CELL)_LINK %END %INTEGERFN FIND(%INTEGER LAB, LIST) !*********************************************************************** !* THIS FUNCTION SEARCHES LIST 'LIST' FOR LAB IN STREAM2 AND * !* RETURNS THE CORRESPONDING CELL NO.IT USED FOR MORE THAN * !* SCANNING LABEL LISTS. * !*********************************************************************** %WHILE LIST#0 %CYCLE %RESULT=LIST %IF LAB=ASLIST(LIST)_S2 LIST=ASLIST(LIST)_LINK %REPEAT %RESULT=-1 %END !%INTEGERFN FIND3(%INTEGER S3, LIST) !!*********************************************************************** !!* SEARCHES LIST FOR S3 IN STREAM 3 * !!* RETURNS CELL NO AS RESULT * !!*********************************************************************** ! %WHILE LIST#0 %CYCLE ! %RESULT=LIST %IF S3=ASLIST(LIST)_S3 ! LIST=ASLIST(LIST)_LINK ! %REPEAT ! %RESULT=-1 !%END %ROUTINE FROM123(%INTEGER CELL, %INTEGERNAME S1, S2, S3) !*********************************************************************** !* ALL THE FROMS RETURN INFO FROM CELLS OF A LIST WITHOUT * !* AFFECTING THE LIST IN ANY WAY. * !*********************************************************************** %RECORDNAME LCELL(LISTF) LCELL==ASLIST(CELL) S1=LCELL_S1 S2=LCELL_S2 S3=LCELL_S3 %END %ROUTINE FROM12(%INTEGER CELL, %INTEGERNAME S1, S2) %RECORDNAME LCELL(LISTF) LCELL==ASLIST(CELL) S1=LCELL_S1 S2=LCELL_S2 %END %INTEGERFN FROM1(%INTEGER CELL) %RESULT =ASLIST(CELL)_S1 %END %INTEGERFN FROM2(%INTEGER CELL) %RESULT =ASLIST(CELL)_S2 %END %INTEGERFN FROM3(%INTEGER CELL) %RESULT =ASLIST(CELL)_S3 %END %ROUTINE CLEAR LIST(%INTEGERNAME OPHEAD) !*********************************************************************** !* THROW AWAY A COMPLETE LIST (MAY BE NULL!) * !*********************************************************************** %INTEGER I, J I=OPHEAD; J=I %WHILE I#0 %THEN J=I %AND I=ASLIST(J)_LINK %IF J#0 %START ASLIST(J)_LINK=ASL ASL=OPHEAD; OPHEAD=0 %FINISH %END %ROUTINE CONCAT(%INTEGERNAME LIST1, LIST2) !*********************************************************************** !* ADDS LIST2 TO BOTTOM OF LIST1 * !*********************************************************************** %INTEGER I,J I=LIST1; J=I %WHILE I#0 %THEN J=I %AND I=ASLIST(J)_LINK %IF J=0 %THEN LIST1=LIST2 %ELSE ASLIST(J)_LINK=LIST2 LIST2=0 %END; ! AN ERROR PUTS CELL TWICE ONTO ! FREE LIST - CATASTROPHIC! %ROUTINE BINSERT(%INTEGERNAME TOP,BOT,%INTEGER S1,S2,S3) !*********************************************************************** !* INSERT A CELL AT THE BOTTOM OF A LIST * !* UPDATING TOP AND BOTTOM POINTERS APPROPIATELY * !*********************************************************************** %INTEGER I %RECORDNAME LCELL(LISTF) I=ASL %IF I=0 %THEN FAULT(107,0) %ELSE %START LCELL==ASLIST(I) ASL=LCELL_LINK LCELL_S1=S1; LCELL_S2=S2 LCELL_S3=S3; LCELL_LINK=0 J=BOT %IF J=0 %THEN BOT=I %AND TOP=BOT %ELSE %START ASLIST(J)_LINK=I BOT=I %FINISH %FINISH %END !%ROUTINE RETURN LIST(%INTEGERNAME TOP,BOT) !!*********************************************************************** !!* RETURN A WHOLE LIST TO ASL * !!*********************************************************************** !%INTEGER CELL,J ! %IF TOP#0 %START !! CELL=TOP !! %WHILE CELL#0 %THEN J=CELL %AND CELL=ASLIST(CELL)_LINK !! ABORT %IF J#BOT ! CELL=ASL ! ASL=TOP ! ASLIST(BOT)_LINK=CELL ! TOP=0 ! %FINISH !%END %ROUTINE RELOCATE(%INTEGER GLARAD,VALUE,AREA) !*********************************************************************** !* PLANTS A WORD IN THE GLA (IF GLARAD<0) AND ARRANGES TO * !* RELOCATE IT RELATIVE TO AN AREA(CODE=1,GLA=2,CST=4,GST=5 * !* IF THE RELOCATION IS RELATIVE TO SYMBOL TABLES THE WORD * !* CAN NOT BE RELOCATED TILL SIZE OF THE CODE(OR GLA) IS KNOWN * !*********************************************************************** %IF GLARAD<0 %THEN PGLA(4,4,ADDR(VALUE)) %AND GLARAD=GLACA-4 LPUT(19,2,GLARAD,AREA) %END %ROUTINE GXREF(%STRING(255) NAME,%INTEGER MODE,XTRA,AT) !*********************************************************************** !* ASK LPUT TO ARRANGE FOR A DOUBLE WORD AT 'AT' IN THE GLA * !* TO CONTAIN A DESCRIPTOR FOR NAME 'NAME'. * !* MODE=0 STATIC CODE XREF * !* MODE=1 DYNAMIC CODE XREF * !* MODE=2 DATA XREF XTRA=MINIMIUM LENGTH * !*********************************************************************** %INTEGER LPUTNO %IF MODE=2 %THEN LPUTNO=15 %ELSE LPUTNO=MODE+12 LPUT(LPUTNO,XTRA,AT,ADDR(NAME)) %END %ROUTINE CXREF(%STRING(255) NAME,%INTEGER MODE,XTRA,%INTEGERNAME AT) !*********************************************************************** !* CREATE A ZEROED AREA IN THE GLA AND CALL GXREF TO GET * !* IT FILLED AT LOAD TIME WITH INFORMATION ON AN EXTERNAL OBJECT * !* PARAMETERS ARE AS FOR GXREF. * !*********************************************************************** %INTEGER Z1,Z2 Z1=0; Z2=0 PGLA(4,8,ADDR(Z1)); ! 2 ZERO WORDS AT=GLACA-8 GXREF(NAME,MODE,XTRA,AT) %END %ROUTINE CODEDES(%INTEGERNAME AT) !*********************************************************************** !* PUT A CODE DESCRIPTOR INTO THE PLT FOR USE BY DEFINE EP * !*********************************************************************** %INTEGER DESC1,DESC2 DESC1=X'E1000000'; DESC2=0 %IF CDCOUNT=0 %THEN FIXED GLA(0)=DESC1 %AND AT=0 %C %ELSE PGLA(4,8,ADDR(DESC1)) %AND AT=GLACA-8 CDCOUNT=CDCOUNT+1 %END %ROUTINE DEFINE EP(%STRING(255)NAME, %INTEGER ADR,AT,MAIN) !*********************************************************************** !* AN EP CONSISTS OF A CODE DESCRIPTOR IN THE GLA(PLT) OF * !* FILE CONTAINING THE EP. LPUT IS TOLD ABOUT THIS AND THE LOADER* !* ARRANGES TO PUT A DESCRIPTOR-DESCRIPTOR TO THE CODE-DESC * !* IN THE GLA OF ANY FILE REFERENCES THIS EP. THIS FIRST WORD * !* OF ICLS PLT IS THE MAIN EP AND WE MIMIC THIS AS FAR AS POSS * !*********************************************************************** %IF AT=0 %THEN FIXED GLA(1)=ADR %ELSE PLUG(2,AT+4,ADR) RELOCATE(AT+4,ADR,1) LPUT(11,MAIN<<31!2,AT,ADDR(NAME)) %IF NAME#'' %END %ROUTINE PROLOGUE !*********************************************************************** !* GENERATES THE SUBROUTINE THAT ALWAYS ARE REQUIRED ONTO THE * !* FRONT OF THE OBJECT PROGRAM WHERE THEY ARE DIRECTLY ADDRESABLE* !*********************************************************************** %ROUTINESPEC ERR EXIT(%INTEGER A, B, C) %CONSTINTEGERARRAY FIXEDCA(0:19)=X'40800000',0, X'41100000',0, X'30000001',0, X'18000001',0, X'28000001',0, X'58000000',0, X'81818181'(2), M'ADIA',X'E1000000', X'E5000000',X'E5000001', X'4E000000',0; %INTEGER I, J, K, L, STCA J=X'C2C2C2C2' LPUT(4,4,0,ADDR(J)) SSTL=4 ! ! NEXT GENERATE THE FIXED-FLOAT CONSTANTS THAT MAY BE NEEDED ! PLABS(1)=CA %CYCLE I=0, 1, 19 PCONST(FIXEDCA(I)) %REPEAT UNASSPAT=FIXEDCA(12); ! THE UNASSIGNED PATTERN ! ! 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 IS IN ACC. XTRA HAS BEEN STACKED ! ENTRY HAS BEEN BY JLK SO RETURN ADDRESS ALSO STACKED ! !RTF LB TOS RETURN ADDRESS TO B ! SLB TOS XTRA TO B,RETURN ADDR TO TOS ! STLN TOS START AN EXTERNAL CALL ! ASF 4 TO PLANT PARAMS ! JLK +1 STACK DUMMY PC ! STLN TOS LNB AS SECOND PARAMETER ! ST TOS ERROR NO AS THIRD PARAM ! STB TOS XTRA AS FOURTH PARAMETER ! LXN (LNB+4) POINTER TO GLA ! RALN 9 TO STORED LNB ! CALL ((XNB+10)) VIA XREF=DESCRIPTOR-DESCRIPTOR ! J TOS BACK AFTER A MONITOR ! PLABS(2)=CA ! PF1(LB,0,TOS,0) ! PF1(SLB,0,TOS,0) ! PF1(STLN,0,TOS,0) ! PSF1(ASF,0,4) ! PSF1(JLK,0,1) ! PF1(STLN,0,TOS,0) ! PF1(ST,0,TOS,0) ! PF1(STB,0,TOS,0) ! PSF1(LXN,1,16) ! PSF1(RALN,0,9) ! PF1(CALL,2,XNB,40) ! PF1(JUNC,0,TOS,0) PCLOD(0,6) ! ! SUBROUTINE TO ADVANCE STACK FRONT BY B WORDS AND FILL WITH UNASSIGNED ! ! JAT 12,*+13 B IS ZERO ! LSS TOS ! STSF TOS ! LDTB STRING DECRIPTOR SET UP DESCRIPTOR FOR MVL ! LDA TOS ! ASF B ADVANCE BY B WORDS ! MYB 4 CHANGE B TO BYTES ! LDB B AND MOVE TO BOUND FIELD ! MVL L=DR AND FILL WITH X80S ! ST TOS ! J TOS RETURN ! %IF PARMCHK=1 %THEN %START; ! ONLY REQUIRED WITH CHKING PLABS(3)=CA PF1(LDTB,0,PC,PLABS(1)+40) ! PF3(JAT,12,0,11) ! PF1(LSS,0,TOS,0) ! PF1(STSF,0,TOS,0) ! PF1(LDA,0,TOS,0) ! PF1(ASF,0,BREG,0) ! PSF1(MYB,0,4) ! PF1(LDB,0,BREG,0) ! PF2(MVL,1,1,0,0,UNASSPAT&255) ! PF1(ST,0,TOS,0) ! PF1(JUNC,0,TOS,0) PCLOD(8,13) %FINISH ! ! SUBROUTINE TO RESET STACK FRONT TO VALUE IN ACC. LINK IS ON TOS ! !RESET STSF TOS IN BYTES ! ISB TOS ADJUSTMENT IN BYTES ! ISH -2 IN WORDS ! IAD 1 ALLOW FOR DESTACKING RETURN ADDR ! SLSS TOS ! ASF TOS ! ST TOS ! J TOS ! PLABS(4)=CA ! PF1(STSF,0,TOS,0) ! PF1(ISB,0,TOS,0) ! PSF1(ISH,0,-2) ! PSF1(IAD,0,1) ! PF1(SLSS,0,TOS,0) ! PF1(ASF,0,TOS,0) ! PF1(ST,0,TOS,0) ! PF1(JUNC,0,TOS,0) PCLOD(15,18) ! ! SOME ERROR ROUTINES ! ERR EXIT(5, X'801', 0) %IF PARMCHK#0;! UNASSIGNED VARIABLE ! ERR EXIT(6, X'602', 0); ! ARRAY BOUND EXCEEDED ERR EXIT(7, X'505', 0) %IF PARMOPT#0;! ILLEGEAL EXPONENTIATION ERR EXIT(8, X'201', 0) %IF PARMOPT#0;! EXCESS BLOCKS ERR EXIT(9, 22, 0); ! LHS NOT DESTIN ERR EXIT(10,36,0) %IF PARMOPT#0; ! WRONG PARAM TO EXTERNAL ! ! DUMMY ENTRIES FOR THE TWO ARRAY SUBROUTINES ADEC1 AND ADEC2 ! ALSO THE ARRAY BY VALUE SUBROUTINE AND REAL**REAL ! %CYCLE I=11, 1, 19 PLABS(I)=0; PLINK(I)=0 %REPEAT ! ! INSERT THE INTEGER CONSTANTS INTO THE CONST AREA ! CONSTL4=0 PUSH123(CONSTL4,UNASSPAT,0,PLABS(1)+48) ! ! SIMILARLY FOR THE REAL CONSTANTS ! CONSTL8=0 PUSH123(CONSTL8,UNASSPAT,UNASSPAT,PLABS(1)+48) PUSH123(CONSTL8,X'41100000',0,PLABS(1)+8) PUSH123(CONSTL8,X'40800000',0,PLABS(1)) ! ! NOW THE STRINGS ! CNOP(0,8); STCA=CA %IF STRLINK#0 %START PCONST(X'18000100') PCONST(8) %FINISH %WHILE STRLINK#0 %CYCLE I=STRLINK; STRLINK=A(I) K=A(I+1); A(I)=CA L=ADDR(A(I+2)); ! POINTS TO FIRST CHAR PLANT(K<<8!BYTE INTEGER(L)&127) J=1 %WHILE JP14 FILL(13) ! PSF1(LXN,1,0) ! PF1(LXN,0,XNB,16) ! PSF1(LSD,1,20) ! PF1(ST,0,TOS,0) ! PF1(LD,2,XNB,AUXST); ! NB CHANGES WITH AUXST**** ! PF1(LSS,2,7,0) ! PSF1(ST,1,24) ! PSF1(LSS,1,36) ! PSF1(ISH,0,-27) ! PSF1(AND,0,7) ! PF1(ICP,0,BREG,0) ! PF3(JCC,2,0,50) ! PF3(JCC,4,0,24) ! PSF1(AND,0,3) ! PSF1(IMY,0,4) ! PSF1(SLSS,1,20) ! PF1(AND,0,0,X'1FFFF') ! PF1(IMY,0,TOS,0) ! PF1(ST,0,BREG,0) ! PSF1(IAD,1,24) ! PF1(ST,2,7,0) ! PF1(ICP,1,0,2) ! PF3(JCC,2,0,X'44') PCLOD(42,56) PF1(LDTB,0,PC,PLABS(1)+24) ! PF1(LDB,0,BREG,0) ! PF1(LDA,0,TOS,0) ! PSF1(CYD,0,0) ! PSF1(LDA,1,24) ! PF2(MV,1,0,0,0,0) ! PSF1(LSQ,1,20) ! PSF1(EXIT,0,0) ! PSF1(LSS,0,1) ! PSF1(ISH,0,27) ! PSF1(IAD,1,36) ! PSF1(ST,1,20) ! PF1(AND,0,0,X'1FFFF') ! PF1(ST,0,BREG,0) ! PSF1(IMY,0,8) ! PSF1(IAD,1,24) ! PF1(ST,2,7,0) ! PF1(ICP,1,0,2) ! PF3(JCC,2,0,X'2D') ! PSF1(SBB,0,1) ! PF1(LSS,3,LNB,36) !! PSF1(FLT,0,0) ! PF1(ST,3,LNB,20) ! PF3(JAF,12,0,-6) ! PSF1(LSQ,1,20) ! PSF1(EXIT,0,0) ! PSF1(LSS,0,1) ! PSF1(ISH,0,27) ! PSF1(IRSB,1,36) ! PSF1(ST,1,20) ! PF1(AND,0,0,X'1FFFF') ! PF1(ST,0,BREG,0) ! PSF1(IMY,0,4) ! PSF1(IAD,1,24) ! PF1(ST,2,7,0) ! PF1(ICP,1,0,2) ! PF3(JCC,2,0,X'15') ! PSF1(SBB,0,1) ! PF1(LSD,3,LNB,36) PCLOD(57,80) PF1(RAD,0,PC,PLABS(1)) ! PSF1(RSC,0,55) ! PSF1(RSC,0,-55) ! PF1(STB,0,TOS,0) ! PF1(FIX,0,BREG,0) ! PSF1(MYB,0,4) ! PF1(ISH,0,BREG,0) ! PSF1(MPSR,0,17) ! PF1(LB,0,TOS,0) ! PF1(ST,3,LNB,20) ! PF3(JAF,12,0,-15) ! PSF1(LSQ,1,20) ! PSF1(EXIT,0,0) PCLOD(82,88) PF1(JUNC,0,0,(PLABS(8)-CA)//2) P14: ! ! EVALUATE X**Y ! ******** **** ! Y IS IN ACC X IS STACKED BELOW THE LINK(UNAVOIDABLE) ! FAULT(21) IS GIVEN IF X<0 OR (X=0 AND Y<=0) ! REPEATED MULTIPLICATION IS USED IF Y>0 AND FRACPT(Y)=0 ! OTHERWISE RESULT=EXP(Y*LOG(Y)) ! ! LB TOS SWOP RETURN ADDRESS & X ! LD TOS X TO DR ! STB TOS ! STD TOS ! SLSD TOS X TO ACC Y TO TOS ! JAT 2,EXPERR ERROR IF X<0 ! JAF 0,TRYMULT JUMP X#0 ! SLSD TOS STACK X & GET Y ! JAF 1.EXPERR Y<=0 ! LSD TOS X (=0) =RESULT TO ACC ! J TOS RETURN !TRYMULT X IS IN ACC & Y STACKED ! SLSD TOS Y TO ACC AND X STACKED ! ST TOS Y STACKED ! JAT 2,NONINT Y IS NEGATIVE ! RSC 55 ! RSC -55 ! FIX B FIX PINCHED FROM ICL ALGOL ! MYB 4 ! CPB -64 ! JCC 10,*+3 ! LB -64 ! ISH B ! STUH B ACC TO 1 WORD ! JCC 7,NONINT JUMP IF TRUNCATION ! ASF -2 LOSE Y OF STACK ! ST B INTEGER VERSION OF Y TO B ! LSS 1 ! FLT 0 ! JAF 12,MUL JUMP IF B#0 ! ASF -2 LOSE X OFF STACK ! J TOS X**0 =1 !AGN STD TOS STACK ANOTHER COPY OF X !MUL RMY TOS ! DEBJ AGN REPEATED MULTIPLICATION ! J TOS !NONINT Y IS STACKED OVER X ! LSD TOS ! SLSD TOS ! STLN TOS ! ASF 4 ! ST TOS ! LXN (LNB+4) ! RALN 7 ! CALL ((XNB+LOGEPDISP) ! RMY TOS ! STLN TOS ! ASF 4 ! ST TOS ! LXN (LNB+4) TO PLT ! RALN 7 ! CALL ((XNB+EXPEPDISP)) CALL EXP ! J TOS !EXPERR J ERROR RT NO 7 ! %IF PLINK(14)=0 %THEN ->P15 FILL(14) %IF LOGEPDISP=0 %THEN CXREF('S#ILOG',0,2,LOGEPDISP) %IF EXPEPDISP=0 %THEN CXREF('S#IEXP',0,2,EXPEPDISP) ! PF1(LB,0,TOS,0) ! PF1(LD,0,TOS,0) ! PF1(STB,0,TOS,0) ! PF1(STD,0,TOS,0) ! PF1(SLSD,0,TOS,0) ! PF3(JAT,2,0,X'37') ! PF3(JAF,0,0,7) ! PF1(SLSD,0,TOS,0) ! PF3(JAF,1,0,X'32') ! PF1(LSD,0,TOS,0) ! PF1(JUNC,0,TOS,0) ! PF1(SLSD,0,TOS,0) ! PF1(ST,0,TOS,0) ! PF3(JAT,2,0,26) ! PSF1(RSC,0,55) ! PSF1(RSC,0,-55) ! PF1(FIX,0,BREG,0) ! PSF1(MYB,0,4) ! PSF1(CPB,0,-64) ! PF3(JCC,10,0,3) ! PSF1(LB,0,-64) ! PF1(ISH,0,BREG,0) ! PF1(STUH,0,BREG,0) ! PF3(JCC,7,0,14) ! PSF1(ASF,0,-2) ! PF1(ST,0,BREG,0) ! PSF1(LSS,0,1) ! PSF1(FLT,0,0) ! PF3(JAF,12,0,5) ! PSF1(ASF,0,-2) ! PF1(JUNC,0,TOS,0) ! PF1(STD,0,TOS,0) ! PF1(RMY,0,TOS,0) ! PSF1(DEBJ,0,-2) ! PF1(JUNC,0,TOS,0) ! PF1(LSD,0,TOS,0) ! PF1(SLSD,0,TOS,0) ! PF1(STLN,0,TOS,0) ! PSF1(ASF,0,4) ! PF1(ST,0,TOS,0) ! PSF1(LXN,1,16) ! PSF1(RALN,0,7) PCLOD(90,114) PF1(CALL,2,XNB,LOGEPDISP) ! PF1(RMY,0,TOS,0) ! PF1(STLN,0,TOS,0) ! PSF1(ASF,0,4) ! PF1(ST,0,TOS,0) ! PSF1(LXN,1,16) ! PSF1(RALN,0,7) PCLOD(115,117) PF1(CALL,2,XNB,EXPEPDISP) PF1(JUNC,0,TOS,0) PF1(JUNC,0,0,(PLABS(7)-CA)//2) P15: %IF PLINK(15)=0 %THEN ->P16 FILL(15) ! ! CONTINGENCY ENTRY - LNB RESTORE FOR MAIN PROGRAM. ACC HAS WORD DECP ! TO 18 WORD AREA OF FAILURE & IMAGE STORE:- ! WORD0 = FAILURE?, WORD1=XTRA?,WORD2=LNB,WORD4=PC ! THIS ROUTINE TRANSCRIBES THESE INTO A CALL ON MDIAGS ! ! ST TOS ! LD TOS DESCRIPTOR TO DR ! STLN TOS START RT CALL ! ASF 4 TO PLANT PARAMS ! LSS (DR+4) PC FIRST PARAM ! SLSS (DR+2) LNB SECOND PARAM ! SLSS 10 INTERRUPT OF CLASS ! SLSS (DR) XTRA IS CLASS NO ! ST TOS ! LXN (LNB+4) TO PLT(GLA) ! RALN 9 ! CALL ((XNB+10)) TO MDIAGS - DOES NOT RETURN ! ! PF1(ST,0,TOS,0) ! PF1(LD,0,TOS,0) ! PF1(STLN,0,TOS,0) ! PSF1(ASF,0,4) ! PF1(LSS,1,0,4) ! PF1(SLSS,1,0,2) ! PSF1(SLSS,0,10) ! PF1(SLSS,2,7,0) ! PF1(ST,0,TOS,0) ! PSF1(LXN,1,16) ! PSF1(RALN,0,9) ! PF1(CALL,2,XNB,40) PCLOD(20,27) P16: %IF PLINK(16)=0 %THEN ->P17 FILL(16) ! ! THE STOP SEQUENCE ! CALL %SYSTEMROUTINE STOP(NO PARAMETERS) ! !STOP1 STLN TOS ! ASF 4 ! LXN (LNB+4) ! RALN 5 ! CALL ((XNB+STOPEPDISP)) ! **PLEASE DONT COME BACK** ! IDLE B00B ! CXREF('S#STOP',0,2,J) PF1(STLN,0,TOS,0) PSF1(ASF,0,4) PSF1(LXN,1,16) PSF1(RALN,0,5) PF1(CALL,2,XNB,J) PF1(X'4E',0,0,X'B00B'); ! IDLE B00B ! THESE LOCATIONS ARE NOW FREE PCLOD(29,40) P17: %RETURN %ROUTINE FILL(%INTEGER LAB) !*********************************************************************** !* FILL JUMPS TO THIS LAB WITH JUMP TO CURRENT ADDRESS * !*********************************************************************** %INTEGER AT,INSTRN,SPARE %WHILE PLINK(LAB)#0 %CYCLE POP123(PLINK(LAB),AT,INSTRN,SPARE) INSTRN=INSTRN!(CA-AT)>>1 PLUG(1,AT,INSTRN) %REPEAT PLABS(LAB)=CA %END %END %ROUTINE CSS(%INTEGER P) %ROUTINESPEC MERGE INFO %ROUTINESPEC REDUCE ENV(%INTEGERNAME HEAD) %ROUTINESPEC ENTER JUMP(%INTEGER MASK,STAD,FLAG) %ROUTINESPEC ENTER LAB(%INTEGER M,FLAG,LEVEL) %ROUTINESPEC CEND(%INTEGER KKK) %ROUTINESPEC RESET AUX STACK %ROUTINESPEC SAVE AUX STACK(%INTEGER ARRS) %ROUTINESPEC RT EXIT %ROUTINESPEC CBPAIR(%INTEGERNAME LB,UB) %ROUTINESPEC CCOND %ROUTINESPEC SET LINE %ROUTINESPEC C FORSTMNT %ROUTINESPEC CSTMNT %ROUTINESPEC CUI %ROUTINESPEC GOTOLAB(%INTEGER MODE) %ROUTINESPEC CDE(%INTEGER MODE) %ROUTINESPEC CSDE(%INTEGER MODE) %ROUTINESPEC CCMPNDSTMNT %ROUTINESPEC CBLK(%INTEGER BLKTYPE) %ROUTINESPEC ETORP(%INTEGERNAME A,B,%INTEGER C) %ROUTINESPEC TORP(%INTEGERNAME HEAD,NOPS,%INTEGER MODE) %ROUTINESPEC SET USE(%INTEGER R,U,I) %ROUTINESPEC CSEXP(%INTEGER REG,MODE,NME) %ROUTINESPEC SAVE IRS %ROUTINESPEC BOOT OUT(%INTEGER MODE) %ROUTINESPEC EXPOP(%INTEGER A,B,C,D) %ROUTINESPEC TEST APP(%INTEGERNAME NUM) %ROUTINESPEC SKIP EXP(%INTEGER MODE) %ROUTINESPEC SKIP SEXP(%INTEGER MODE) %ROUTINESPEC SKIP APP %INTEGERFNSPEC DOPE VECTOR(%INTEGER A,B,%INTEGERNAME C,D) %ROUTINESPEC MAKE DECS(%INTEGER P,K) %ROUTINESPEC DECLARE OWNS %ROUTINESPEC DECLARE ARRAYS %ROUTINESPEC DECLARE SCALARS %ROUTINESPEC DECLARE LAB %ROUTINESPEC DECLARE PROC %ROUTINESPEC DECLARE SWITCH %ROUTINESPEC CLABEL %ROUTINESPEC COLABEL %ROUTINESPEC GET WSP(%INTEGERNAME PLACE,%INTEGER SIZE) %ROUTINESPEC RETURN WSP(%INTEGER PLACE,SIZE) %ROUTINESPEC GTHUNKS(%INTEGER A,B) %INTEGERFNSPEC CHECK FPROCS(%INTEGER A,B) %ROUTINESPEC CRCALL(%INTEGER A,B) %ROUTINESPEC CALL THUNKS(%INTEGER A,REG,B,C) %ROUTINESPEC FETCH STRING(%INTEGER REG) %ROUTINESPEC CNAME(%INTEGER Z,REG) %ROUTINESPEC CANAME(%INTEGER Z,BS,DP) %ROUTINESPEC CSNAME(%INTEGER Z,REG) %ROUTINESPEC COPY TAG(%INTEGER KK) %ROUTINESPEC REDUCE TAG %ROUTINESPEC REPLACE TAG (%INTEGER KK) %ROUTINESPEC RT JUMP(%INTEGER CODE,%INTEGERNAME RT) %ROUTINESPEC STORE TAG(%INTEGER KK,SLINK) ! %ROUTINESPEC TEST NST %ROUTINESPEC UNPACK %ROUTINESPEC PACK(%INTEGERNAME PTYPE) %ROUTINESPEC RHEAD(%INTEGER KK) %ROUTINESPEC RDISPLAY(%INTEGER KK) %ROUTINESPEC ODDALIGN %INTEGERFNSPEC PTR OFFSET(%INTEGER RLEV) %ROUTINESPEC PPJ(%INTEGER MASK,N) %ROUTINESPEC FORGET(%INTEGER REG) %ROUTINESPEC REMEMBER %ROUTINESPEC STORE CONST(%INTEGERNAME B,%INTEGER L,AD,D) %INTEGERFNSPEC REVERSE(%INTEGER MASK) %INTEGERFNSPEC AREA CODE %ROUTINESPEC SET XNB(%INTEGER L) %ROUTINESPEC GET IN ACC(%INTEGER A,B,C,D,E) %ROUTINESPEC NO APP %ROUTINESPEC DIAG POINTER(%INTEGER L) %ROUTINESPEC COPY DR %ROUTINESPEC CHECK STOF %ROUTINESPEC CHANGE RD(%INTEGER REG) %ROUTINESPEC TEST ASS(%INTEGER REG) %ROUTINESPEC NOTE ASSMENT(%INTEGER REG,VAR) %SWITCH SW(1:13) %RECORDFORMAT RD(%BYTEINTEGER UPTYPE,PTYPE,XB,FLAG,%C %INTEGER D,XTRA) %INTEGER TWSPHEAD,RDHEAD,SNDISP,ACC,K,KFORM %INTEGER TCELL,JJ,JJJ,KK,BASE,DISP,AREA,ACCESS, %C PTYPE,I,J,OLDI,USEBITS,ROUT,NAM,ARR,TYPE %INTEGERARRAY SGRUSE,SGRINF(0:7) TWSPHEAD=0 ->SW(A(P)) SW(1): ! SET LINE %IF PARMLINE#0 %IF LEVEL<=1 %THEN FAULT(57,0) %AND %RETURN NMDECS(LEVEL)=NMDECS(LEVEL)!1 P=P+1; CSTMNT CSSEXIT: %WHILE TWSPHEAD#0 %CYCLE POP(TWSPHEAD,JJ,KK) RETURN WSP(JJ,KK) %REPEAT %RETURN SW(2): ! %END SET LINE %IF PARMLINE#0 CEND(FLAG(LEVEL)) %RETURN SW(4): ! %PROCEDURE ->VDEC %UNLESS A(P+2)=1 %BEGIN %INTEGER PNAME, EXTRN, Q, PP, PTYPEP, PARN, DISP, TYPEP, LINK, NP,%C LINEP, PE, PL, OPHEAD, AVHEAD, OPBOT P=P+1 PP=P; PNAME=A(P+4); ! PROCEDURE NAME EXTRN=P+3+A(P+3); ! TO OLABEL PL=EXTRN %WHILE A(EXTRN)=1 %THEN EXTRN=EXTRN+3 PE=EXTRN+1; ! TO ALT OF PROCSTMNT EXTRN=A(PE) %IF LEVEL=1 %AND CPRMODE=0 %THEN CPRMODE=2 %AND MAKE DECS(0,-1) COPY TAG(PNAME); Q=K LINEP=SNDISP P=PP %UNLESS ROUT=1 %AND OLDI=LEVEL %THEN DECLARE PROC P=PP ->L99 %IF EXTRN<=3 %OR J=14 %IF LEVEL=1 %THEN %START CPRMODE=2 %IF CPRMODE=0 FAULT(105, PNAME) %IF CPRMODE#2 JJ=FROM1(Q) DEFINE EP(STRING(ADDR(LETT(WRD(PNAME)))), CA, JJ, 0) %IF JJ#0 %THEN PSF1(INCA,0,-JJ) DIAG POINTER(LEVEL+1) %FINISH COPY TAG(PNAME) LINK=K; Q=ACC JJ=LINK; NP=FROM2(LINK); ! NO OF PARAMS PLABEL=PLABEL-1 %UNLESS CPRMODE=2 %AND LEVEL=1 %START JROUND(LEVEL+1)=PLABEL ENTER JUMP(15,PLABEL, 0) %FINISH PTYPEP=PTYPE RHEAD(PNAME) ! ! CHANGE TAGS TO 'BODY GIVEN' BY SETTING 'J'(DIMEN) TO 0 AFTER RHEAD ! HAS USED J TO CHECK JUMP LIST ! REPLACE1(TAGS(PNAME),FROM1(TAGS(PNAME))&X'FFFFFFF0') ! ! GO DOWN THE PARAMETER LIST OF THE PROCEDURE AND DECLARE THE ! PARAMETERS AS LOCAL VARIABLE AT THIS LEVEL ! MLINK(LINK); AVHEAD=0 %WHILE LINK#0 %CYCLE FROM123(LINK, TYPEP, PARN, DISP) J=PARN>>16; PTYPE=TYPEP %IF PTYPE&X'F00'>X'100' %THEN PTYPE=PTYPE&X'F0FF'!X'100' TYPE=PTYPE&7 K=PARN&X'FFFF'; ACC=0; KFORM=LINK ! TEST NST; SNDISP=M'FP' ACC=BYTES(TYPE) %IF TYPE<=3 %AND PTYPE<4096 %IF PTYPE>=4096 %START; ! PROCEDURE PARAMETERS OPHEAD=0; OPBOT=0; JJ=J %WHILE JJ>0 %CYCLE BINSERT(OPHEAD,OPBOT,FROM1(JJ), %C FROM2(JJ),FROM3(JJ)) MLINK(JJ) %REPEAT; J=0 REPLACE1(OPHEAD,DISP&X'FFFF') DISP=OPHEAD %FINISH STORE TAG(K, DISP&X'FFFF') %IF PTYPE&X'FF0'=X'10' %START; ! ARRAYS BY VALUE PUSH(AVHEAD,DISP,SIZECODE(PTYPE&7)) %FINISH MLINK(LINK) %REPEAT N=Q; ! TOTAL SPACE OCCUPIED BY SAVE !AREA AND PARAMS Q=PP+6 PTYPE=PTYPEP RDISPLAY(PNAME) %WHILE AVHEAD#0 %CYCLE POP(AVHEAD,DISP,JJ) SAVE AUX STACK(1); ! ARRAYS ON STACK PF1(STLN,0,TOS,0) PSF1(ASF,0,4) PSF1(LSQ,1,DISP&X'FFFF') PF1(ST,0,TOS,0) PSF1(LB,0,JJ) PSF1(RALN,0,9) PPJ(-1,13); ! CALL PERM SUBROUTINE PSF1(ST,1,DISP&X'FFFF') %REPEAT %IF NP>0 %THEN Q=Q+3*NP-1 MAKE DECS(Q, PTYPEP) P=PL; COLABEL %IF EXTRN=5 %THEN %START P=PE+1; LINE=LINEP; SET LINE %IF PARMLINE#0 CSTMNT; P=PP-1; ! A(P) MUST BE #1 FOR CEND CEND(FLAG(LEVEL)) %FINISH L99: %END ->CSSEXIT VDEC: SW(7): ! '%OWN' (TYPE)(OWNDEC) FAULT(40,0) %UNLESS NMDECS(LEVEL)=0 %RETURN SW(5): ! %BEGIN %BEGIN PTYPE=0 %IF LEVEL=1 %AND RLEVEL=0 %THEN %START RLEVEL=1 FAULT(105,0) %IF CPRMODE#0 CODE DES(JJ) DEFINE EP(MAINEP, CA, JJ, 1) L(1)=0; M(1)=0 DIAGINF(1)=0; AUXSBASE(1)=0 CPRMODE=1 N=24; NMAX=N FORGET(-1) DIAGPOINTER(LEVEL+1) ! ! LAY DOWN A CONTINGENCY AGAINST ERROR IN PROGRAM ! IE COMPILE EXTERNAL CALL 'S#SIGNAL(0,PC,LNB,FLAG)' ! CXREF(SIGEP,0,2,JJ); ! REFERENCE TO SIGNAL ! ! THE CODE PLANTED IS AS FOLLOWS:- ! LXN (LNB+4) TO GLA(PLT) ! STLN (XNB+5) SAVE LNB FOR STOP SEQUENCE ! ASF 1 FOR REPORT WORD ! STLN TOS START OF STANDARD CALL ! ASF 4 TO PLANT PARAMS ! LSS 0 ! ST TOS FIRST PARAM ! JLK +3 2ND PARAM AND JUMP ROUND NEXT INSTR ! JCC 15,PERM15 TO RECOVERY SUBROUTINE ! STLN TOS 3RD PARAM ! LD WORD DES DESC USED FOR 'INTEGER()' ! INCA (XNB+5) ADD IN LNB ! INCA +20 TO WORD 5 OF FRAME(REPORT WORD) ! STD TOS 4TH AND LAST PARAM ! RALN 10 ! CALL SIGREF ! PSF1(LXN,1,16) PF1(STLN,0,XNB,20) ! PSF1(ASF,0,1) ! ! THE NEXT 8 INSTRUCTIONS ARE REQUIRED TO SET SF 6 WORDS IN FRONT OF LNB ! AN ASF 1 WORKS AS WELL EXCEPT FOR K-STAND ALONE WHEN THERE MAY BE ! A USELESS REDUNDANT DESCRIPTOR ON THE STACK ! PF1(STLN,0,TOS,0) PF1(LSS,0,TOS,0) PSF1(IAD,0,24) PF1(STSF,0,TOS,0) PF1(ISB,0,TOS,0) PSF1(ISH,0,-2) PF1(ST,0,BREG,0) PF1(ASF,0,BREG,0) ! PF1(STLN,0,TOS,0) PSF1(ASF,0,4) PSF1(LSS,0,0) PF1(ST,0,TOS,0) PSF1(JLK,0,3) PPJ(15,15) PF1(STLN,0,TOS,0) PF1(LD,0,PC,PLABS(1)+32) PF1(INCA,0,XNB,20) PSF1(INCA,0,20) PF1(STD,0,TOS,0) PSF1(RALN,0,10) PF1(CALL,2,XNB,JJ) ! ! SET THE PROGRAM MASK TO MASK OUT UNDERFLOW AND ALLOW ALL OTHER INTS ! ! MPSR X'40C0' ! PF1(MPSR,0,0,X'40C0') PTYPE=1 %FINISH RHEAD(-1) RDISPLAY(-1) MAKE DECS(P+1,-1) %END ->CSSEXIT SW(6): ! %SWITCH := %BEGIN %INTEGER N,DIS,REP,I,PL,FLAG,SWNAME,J SWNAME=A(P+1)&X'FFFF' COPYTAG(SWNAME) REP=0; N=KFORM %IF ARR=1 %THEN %START; ! SWITCH NOT SIMPLE DIS=(K&X'FFFF')*4 P=P+4 PLABEL=PLABEL-1 PL=PLABEL FLAG=B'10' ENTER JUMP(15,PL,FLAG) %CYCLE I=0,1,N-1 J=CA-DIS PLUG(1,DIS+4*I,J) %CYCLE J=0,1,7; GRUSE(J)=0; %REPEAT CDE(2) P=P+2 %REPEAT ENTER LAB(PL,B'110',LEVEL) %FINISH %END ->CSSEXIT SW(8): ! : P=P+1; CLABEL; CSS(P) SW(3): ! %COMMENT !*DELSTART %RETURN !*DELEND SW(10): ! %CODEON SW(11): ! %CODEOFF !*DELSTART CODEOUT DCOMP=(A(P)-1)&1 !*DELEND %RETURN SW(13): ! %SPECIALNAME Q=A(P+1) PUSH123(TAGS(Q),SNPT<<16!X'8000',0,SNUM<<16) SNUM=SNUM+1 %RETURN SW(9): ! NMDECS(LEVEL)=NMDECS(LEVEL)!1 %RETURN SW(12): ! %PROGRAM (NAME)(S) FAULT(40,0) %UNLESS CPRMODE=0 Q=A(P+1) MAINEP<-STRING(ADDR(LETT(WRD(Q)))) %RETURN %ROUTINE DECLARE OWNS !*********************************************************************** !* OWN DECLARATION GO INTO THE GLA OR GLA SYMBOL TABLES * !* ARRAYS HAVE A HEADER IN THE GLA. LPUT ARRANGES * !* FOR THE LOADER TO RELOCATE THE HEADERS. * !*********************************************************************** %ROUTINESPEC CLEAR(%INTEGER L) %ROUTINESPEC STAG(%INTEGER J) %INTEGER LENGTH, BP, PP, ICONST1, ICONST2, TAGDISP, AH1, AH2, AH3, %C AH4, AD, NNAMES, PTYPEP, PTYPEPP, LB, APARM FAULT(40,0) %IF NMDECS(LEVEL)&1#0 P=P+3 NAM=0; ARR=A(P)-1; ROUT=0 ICONST1=0; ICONST2=0 TYPE=A(P-1); TYPE=2 %IF TYPE=4 ACC=BYTES(TYPE); P=P+2 PACK(PTYPE); PTYPEP=PTYPE ->NON SCALAR %UNLESS ARR=0 ! %UNTIL A(P-1)=2 %CYCLE; ! DOWN J=0; K=A(P) KFORM=0; AD=ADDR(ICONST1) PGLA(ACC, ACC, AD); ! PUT CONSTANT INTO GLA TAGDISP=GLACA-ACC; ! OFFSET OF VAR FOR TAGS STAG(TAGDISP) P=P+2 %REPEAT %RETURN NONSCALAR: ! OWN ARRAYS !*********************************************************************** !* P:= * !* P:=',',%NULL * !*********************************************************************** P=P+1; PP=P; NNAMES=1; ! P TO START OF DECLIST APARM=A(P) %WHILE A(P+1)=1 %THEN APARM=APARM!A(P) %AND %C P=P+2 %AND NNAMES=NNAMES+1 APARM=1-APARM>>16 P=P+2; BP=ACC; PTYPEPP=PTYPEP ! ! NOW OUTPUT A DOPE VECTOR ! AH4=DOPE VECTOR(BP, APARM, LENGTH, LB)+12 %IF LB=0 %AND J=1 %THEN PTYPEPP=PTYPEPP+16;! SET ARR=2 NO DVM NEEDED %UNTIL NNAMES=0 %CYCLE K=A(PP)&X'FFFF' CONSTPTR=(CONSTPTR+3)&(-4) ! ! OUTPUT AN ARRAYHEAD INTO THE GLA RELATIVE TO THE START OF THE SYMBOL- ! TABLES IN WHICH THE ARRAY RESIDES. THE LOADER WILL RELOCATE ! BY ADDING INTO AH1-3 THE VIRTUAL ADDRESS OF THE START OF THE ! APPROPIATE AREA. ! %IF TYPE=2 %THEN AH1=6 %ELSE AH1=5 AH1=AH1<<27!LENGTH AH2=CONSTPTR AH3=5<<27!3*J; ! DV DESCPTR = WORD + CHECKED CLEAR(LENGTH) PGLA(8, 16, ADDR(AH1)) TAGDISP=GLACA-16 RELOCATE(TAGDISP+4, AH2, 5);! RELOCATE ADDR(A(FIRST)) RELOCATE(TAGDISP+12, AH3, 4);! RELOCATE DV POINTER PTYPE=PTYPEPP STAG(TAGDISP) PP=PP+2 NNAMES=NNAMES-1 %REPEAT %IF A(P)=1 %THEN P=P+2 %AND ->NONSCALAR %RETURN %ROUTINE CLEAR(%INTEGER LENGTH) LENGTH=(LENGTH+3)&(-4) LPUT(5, LENGTH, CONSTPTR, 0) %IF INHCODE=0 CONSTPTR=CONSTPTR+LENGTH %END %ROUTINE STAG(%INTEGER J) %INTEGER RL ! TEST NST RL=RLEVEL SNDISP=0 RLEVEL=0 STORE TAG(K, J) RLEVEL=RL %END %END; %ROUTINE MAKE DECS(%INTEGER PP, KK) !*********************************************************************** !* PP TO LIST OF LIKS:- * !* A(PP) = LINKS FOR LABELS, A(PP+1) = LINKS FOR SCALARS * !* A(PP+2) = LINK FOR ARRAYS, A(PP+3) = LINK FOR SWITCHES * !* A(PP+4) = LINK FOR OWN DECS,A(PP+5) = LINK FOR PROCEDURES * !* A(PP+6) = COUNT OF BLKS & (LABELS IN INNER BLOCKS) * !* KK <0 FOR BEGIN BLOCKS >0 FOR PROCEDURES * !*********************************************************************** %ROUTINESPEC DOWN LIST(%INTEGER Q,LN,INC,%ROUTINE DEC) %INTEGER SAVELINE, Q, QQ, ARRS, INTLABS, LABPARAMS, INNERBLKS SAVELINE=LINE ARRS=AUXSBASE(LEVEL)!A(PP+2); ! =0 IF THERE ARE NO ARRAYS TO BE ! DECLARED & THERE WERE NO ARRAYS ! PASSED BY VALUE LABPARAMS=PASS2INF&(LABBYNAME!SWBYNAME) INNERBLKS=A(PP+6)>>12 INTLABS=A(PP)!A(PP+6)&X'FFF'; ! =0 IF NOLABS IN BLK OR SUBBLKS ! ! PROGRAMS AND EXTERNAL ROUTINES NEED A COPY OF AUX STACKTOP IN CASE ! A LABEL IS PASSED BY NAME INTO A SEPARATELY COMPILED ENTITY WHICH ! HAS DECLARED ARRAYS. IF PASS 2 REPORTS NO LABEL OR SWITCH PARAMETERS ! AND THERE ARE NO NESTED BLOCKS OR THIS BLOCK + ALL CONTAINED ! BLOCKS&PROCS HAVE NO LABELS THEN THIS CASE CAN NOT ARRISE ! %IF LEVEL=2 %AND (INTLABS#0 %%AND INNERBLKS!LABPARAMS#0) %C %THEN SAVE AUX STACK(ARRS) ! DOWN LIST(PP+1,1,2,DECLARE SCALARS) ! DOWN LIST(PP+4,1,1,DECLARE OWNS) ! DOWN LIST(PP,0,3,DECLARE LAB) ! Q=PP+3; QQ=A(Q) %IF QQ#0 %START CNOP(0,4); PLABEL=PLABEL-1 ENTER JUMP(15,PLABEL,B'10') DOWN LIST(Q,1,3,DECLARE SWITCH) ENTER LAB(PLABEL,0,LEVEL) %FINISH ! DOWN LIST(PP+5,2,2,DECLARE PROC) ! Q=PP+2 DOWN LIST(Q,2,2,DECLARE ARRAYS) ! LINE=SAVELINE Q=AUXSBASE(LEVEL)&X'3FFFF' %IF Q#0 %THEN %START %IF ARRS#0 %START ! ! WE HAVE AN AUX STACK: DO WE NEED TO STORE THE AUGMENTED TOP? ! ONLY IF WE CAN PASS A LABEL FROM THIS OR INNER BLOCK OUT OR ! IF WE CAN JUMP INTO THIS(OR INNER)BLK FROM NESTED BLK ! %IF INTLABS#0 %AND INNERBLKS!LABPARAMS#0 %THEN %START PSF1(LSS,2,Q) %IF A(PP+2)=0;! NOT STILL GOT AUXSF IN ACC PSF1(ST,1,Q+12); ! ONLY USED AFTER JUMP OUT OF ! AN INNER BLK OR PROCEDURE %FINISH %FINISH %FINISH %ELSE AUXSBASE(LEVEL)=AUXSBASE(LEVEL-1) ! ! MUST STORE STACKTOP IN CASE THIS PROC IS REENTERED BY BY JUMPING OUT ! OF AN INNER BLOCK OR FN WHEN THE STACK MUST BE RESET. IF THE BLOCK ! HAS NO LABELS IN IT AND NO LABELS IN ANY INNER BLOCK CAN OMIT THIS ! %IF KK>0 %OR LEVEL=2 %START ! ! DO WE NEED TO STORE SF AT THIS POINT. YES FOR REASONS OF AUX STACK FRNT ! %IF INTLABS#0 %AND INNERBLKS!LABPARAMS#0 %START PSF1(STSF,1,N) STACKBASE(RLEVEL)=N N=N+4 %FINISH %ELSE STACKBASE(RLEVEL)=-1 %FINISH %RETURN %ROUTINE DOWN LIST(%INTEGER Q,LN,INC,%ROUTINE DECLARE) !*********************************************************************** !* SCANS DOWN A LINKED LIST OF ARS MAKING THE APPROPIATE * !* DECLARATIONS. THIS BRINGS ALL DECLARATIONS INCLUDING PROCS * !* TO THE FRONTOF THE BLOCK AND SIDESTEPS FORWARD REFS * !*********************************************************************** %INTEGER QQ %SPEC DECLARE QQ=A(Q) %WHILE QQ#0 %CYCLE Q=Q+QQ-1 %IF LN=0 %THEN LINE=SAVELINE %C %ELSE LINE=A(Q-LN) P=Q; DECLARE Q=Q+INC QQ=A(Q) %REPEAT %END %END %ROUTINE DECLARE LAB !*********************************************************************** !* THIS ROUTINE DECLARES ALL THE LABELS SO THAT A %GOTO CAN * !* BE CLASSIFIED AS INTERNAL OR EXTERNAL IMMEDIATELY * !*********************************************************************** K=A(P+2); ! K IS NAME PTYPE=6; SNDISP=0 KFORM=0; J=0; ACC=0 ! TEST NST STORE TAG(K, 0) %END %ROUTINE DECLARE SWITCH !*********************************************************************** !* P IS TO ALT OF P(SS) * !* THIS ROUTINE RESERVES SPACE IN THE SST FOR THE SWITCH AND * !* DECLARES THE NAME BUT NO CODE IS GENERERATED * !*********************************************************************** %INTEGER I, N, MARK, D0, D1, SIMPLE, SWNAME SWNAME=A(P+2)&X'FFFF'; N=0; SIMPLE=1 SIMPLE=0; ! FOR 2960 TO AVOID CODE DESCRPTR ! WHICH DONT WORK. IF H-W CHANGED ! REP OUT THIS LINE MARK=P+3 %UNTIL A(MARK)#1 %CYCLE N=N+1 SIMPLE=0 %UNLESS A(MARK+2)=2 %AND A(MARK+3)=1 %AND %C A(MARK+5)=3 %IF SIMPLE#0 %START COPY TAG(A(MARK+4)) SIMPLE=0 %UNLESS OLDI=LEVEL %AND PTYPE=6 %FINISH MARK=MARK+1+A(MARK+1) %REPEAT %IF SIMPLE=0 %THEN D0=5<<27!N %ELSE D0=X'E0'<<24!(2*N) D1=CA PGLA(4,8,ADDR(D0)); ! DESCPTR TO SW IN PLT RELOCATE(GLACA-4,D1,1) SNDISP=GLACA>>2-2; KFORM=N J=1; K=SWNAME ACC=4; PTYPE=(SIMPLE+1)<<4!6; ! LABEL ARRAY ! TEST NST STORE TAG(K, CA>>2) MARK=P+3 %CYCLE I=1,1,N %IF SIMPLE=0 %THEN PCONST(0) %ELSE ENTERJUMP(15,A(MARK+4),0) MARK=MARK+1+A(MARK+1) %REPEAT %END %ROUTINE DECLARE PROC !*********************************************************************** !* P TO TYPE OF PROCEDURE-1 * !* SIDE CHAIN SET UP IN OPHEAD CONSISTS OF:- * !* PTYPE, NAME AND DISPLACEMENT FOR EACH FORMAL PARAMETER * !* FOR RTPARAMS THE TOP HALF OF NAME IS THE PARAMLIST * !* THE TOP CELL HAS:- * !* RTADDR , NO OF PARAMS AND INFO * !* INFO 2**0 BIT SET IF PARAMS ARE SIMPLE * !* 2**1 BIT SET IF THUNKS ARE REQUIRED * !*********************************************************************** %ROUTINESPEC CFP %ROUTINESPEC CFPARAMS(%INTEGERNAME OPHEAD,OPBOT,%INTEGERNAME NP) %ROUTINESPEC CVALLIST(%INTEGERNAME OPHEAD,%INTEGER MODE) %ROUTINESPEC CCOMMENT %ROUTINESPEC CTYPELIST(%INTEGERNAME OPHEAD,%INTEGER MODE) %ROUTINESPEC CHECK FPS(%INTEGERNAME OPHEAD,%INTEGER MODE) %INTEGER PNAME, TYPEP, INC, I, N, CELL, NP, LINK, EXTRN, OPBOT, %C OPHEAD, RTHEAD, EPNAME OPHEAD=0; NP=0; OPBOT=0 TYPEP=4096+A(P)&3 P=P+1 PNAME=A(P+3) P=P+4; INC=1; ! TO ALT OF FPP CFPARAMS(OPHEAD,OPBOT,NP) P=P+8; ! PAST 7 HOLES TO VALUE LIST CVALLIST(OPHEAD,0) CTYPELIST(OPHEAD,0) P=P+1 %UNTIL A(P)=2 P=P+1 %WHILE A(P)=1 %THEN P=P+3; ! SKIP OLABEL (IF ANY) EXTRN=A(P+1) CHECK FPS(OPHEAD,0) J=15; I=0 %IF EXTRN<=3 %THEN %START J=14; EPNAME=PNAME %IF A(P+2)=1 %THEN EPNAME=A(P+3) CXREF(STRING(ADDR(LETT(WRD(EPNAME)))),0,2,I) %FINISH %ELSE %START %IF LEVEL=1 %THEN CODE DES(I) %FINISH PUSH123(OPHEAD, I, NP, 0) LINE=LINE+1 K=PNAME; SNDISP=LINE; ACC=INC KFORM=0 PTYPE=TYPEP ! TEST NST STORE TAG(K, OPHEAD) %RETURN %ROUTINE CFPARAMS(%INTEGERNAME OPHEAD,OPBOT,%INTEGERNAME NP) %WHILE A(P)=1 %CYCLE P=P+INC; NP=NP+1 K=A(P); ! NAME %IF FIND(K, OPHEAD)>=0 %THEN FAULT(7, K) %C %ELSE BINSERT(OPHEAD,OPBOT, 256, K, 0) ! TYPE=?NAME P=P+1; INC=2; ! P TO REST OF FPP %REPEAT %END %ROUTINE CVALLIST(%INTEGERNAME OPHEAD,%INTEGER MODE) !*********************************************************************** !* COMPILING THE VALUE LIST CONSISTS OF CHECKING EACH NAME HAS * !* APPEARED IN FPLIST AND RESETING NAME FIELD IN THE TYPE WORD * !* MODE=0 FOR COMPILING PROC STMNT,#0 FOR FUNNY COMMENT * !*********************************************************************** %IF A(P)=1 %THEN %START; ! IF THERE IS A VALUE LIST LINE=LINE+1 P=P+1 %UNTIL A(P)=2 %OR MODE#0;! PAST COMMENTS N=A(P+1); P=P+2 %CYCLE I=1, 1, N; ! DOWN THE NAMELIST K=A(P) CELL=FIND(K, OPHEAD) %IF CELL>0 %THEN REPLACE1(CELL, 0) %ELSE FAULT(8, K) P=P+1 %REPEAT %FINISH %ELSE P=P+1 %END %ROUTINE CTYPELIST(%INTEGERNAME OPHEAD,%INTEGER MODE) !*********************************************************************** !* COMPILING THE TYPE DECLARATIONS IS SIMILAR TO THE VALUE LIST * !* MODE IS ZERO WHEN COMPILING A PROC #0 FOR FUNNY COMMENT * !*********************************************************************** %INTEGER CELL,PIN,ACCP PIN=P %WHILE A(P)=1 %CYCLE; ! WHILE (MORE) DECLARATIONS LINE=LINE+1 P=P+1 %UNTIL A(P)=2 %OR MODE#0 P=P+1; CFP P=P+1 %UNTIL A(P-1)=2 %CYCLE; ! UNTIL NO MORE OF DECLIST K=A(P)&X'FFFF' CELL=FIND(K, OPHEAD) %IF CELL<0 %OR FROM1(CELL)&X'F0FF'#0 %C %THEN FAULT(9, K) %ELSE %START I=FROM1(CELL) REPLACE1(CELL, PTYPE!I) %IF PTYPE>=4096 %AND MODE=0 %START CCOMMENT REPLACE2(CELL,RTHEAD<<16!FROM2(CELL)) %FINISH %IF PTYPE<6 %AND I#0 %THEN ACCP=8 %ELSE ACCP=ACC REPLACE3(CELL, ACCP) %FINISH P=P+2 %REPEAT %IF PTYPE>=4096 %AND MODE=0 %START;! SKIP OVER FUNNY COMMENT %IF A(P)=2 %THEN P=P+1 %ELSE P=P+1+A(P+1) %C %AND LINE=LINE+1 %FINISH %REPEAT %END %ROUTINE CHECK FPS(%INTEGERNAME OPHEAD, %INTEGER MODE) !*********************************************************************** !* PASS DOWN THE LIST AGAIN CHECKING EVERYTHING HAS BEEN GIVEN * !* A VALID TYPE AND ALSO ASSIGNING PARAMETER DISPLACEMENTS * !*********************************************************************** INC=20 LINK=OPHEAD %WHILE LINK>0 %CYCLE FROM123(LINK, PTYPE, J, I) UNPACK %IF TYPE=6 %AND NAM=0 %THEN %START REPLACE1(LINK,PTYPE+256) NAM=1 WARN(3,J) %FINISH ! ! FAULT ANY VALUE PARAMETERS FOR FORTRAN ! %IF NAM=0=MODE %AND EXTRN=3 %THEN FAULT (10,J) %IF MODE=0 %AND 2<=EXTRN<=3 %AND ROUT=0 %AND 1<=TYPE<=3 %C %AND NAM#0 %THEN NAM=EXTRN %AND %C REPLACE1(LINK,PTYPE+256*(EXTRN-1)) FAULT(10, J) %C %IF PTYPE=0 %OR PTYPE=256 %OR (ROUT=1 %AND NAM=0) %OR %C (MODE=0 %AND EXTRN=3 %AND TYPE>3) J=0 J=1 %IF NAM=1 %AND (ARR=0 %OR TYPE=6)%AND ROUT=0 %AND TYPE#5 REPLACE3(LINK, INC!J<<16) INC=INC+I MLINK(LINK) %REPEAT %END %ROUTINE CCOMMENT !*********************************************************************** !* DEAL WITH FUNNY COMMENT SPECIFYING PARAMS FOR RT TYPES * !*********************************************************************** %INTEGER NNP,PP,LINEP,PTYPEP,ACCP,RTBOT NNP=0; PP=P PTYPEP=PTYPE; ACCP=ACC LINEP=LINE; RTHEAD=0; RTBOT=0 P=P+2 %WHILE A(P+1)=1; ! FIND END OF DECLIST P=P+2 %IF A(P)=1 %THEN %START; ! THERE IS A COMMENT INC=2 CFPARAMS(RTHEAD,RTBOT,NNP) P=P+1 CVALLIST(RTHEAD,1) LINE=LINEP CTYPELIST(RTHEAD,1) LINE=LINEP CHECKFPS(RTHEAD,1) %FINISH PUSH123(RTHEAD,0,NNP,0) P=PP; PTYPE=PTYPEP; ACC=ACCP %END %ROUTINE CFP !*********************************************************************** !* SETS PTYPE AND ACC FOR EACH ALT OF FORMAL PARAMETER * !*********************************************************************** %SWITCH ALT(1:7) ->ALT(A(P)) ALT(1): ! %LABEL PTYPE=6; ->SAC ALT(2): ! %SWITCH PTYPE=22; ->SAC ALT(3): ! %STRING PTYPE=5; ->SAC ALT(4): !(TYPE')(VDECLN) TYPE=A(P+1); P=P+2 ->ALT(A(P)+4) ALT(5): ! '%ARRAY' (ADECLN) ARR=1; ROUT=0; NAM=0 P=P+1; ACC=16 TYPE=2 %IF TYPE=4 PACK(PTYPE); %RETURN ALT(6): ! (TYPE')(PROCEDURE) ROUT=1; NAM=0; ARR=0; ACC=16 TYPE=TYPE&3; P=P+1 PACK(PTYPE); %RETURN ALT(7): ! (TYPE) PTYPE=TYPE ACC=BYTES(PTYPE) P=P+1; %RETURN SAC: ACC=8 P=P+1 %END %END %ROUTINE DECLARE SCALARS !*********************************************************************** !* THIS ROUTINE DECLARES A LIST OF SCALARS FROM INFORMATION * !* IN THE GLOBAL VARIABLES ROUT,NAM,ARR,TYPE & ACC.IT WORKS * !* OUT ROUNDING FACTORS FOR ITSELF. * !* P POINTS TO THE DECLIST ON ENTRY AND IS UPDATED. * !*********************************************************************** %INTEGER INC TYPE=A(P) ROUT=0; NAM=0; ARR=0 P=P+4 PACK(PTYPE); J=0 INC=4; ACC=BYTES(TYPE) %IF ROUT=0 %AND ARR=0 %THEN INC=BYTES(TYPE) %IF INC=8 %OR INC=16 %THEN ODD ALIGN %UNTIL A(P-1)=2 %CYCLE; ! DOWN THE NAMELIST K=A(P) ! TEST NST SNDISP=0; KFORM=0 STORE TAG(K, N) N=N+INC P=P+2 %REPEAT %END %ROUTINE DECLARE ARRAYS !*********************************************************************** !* P IS AT P IN * !* * !* P= * !* P = ,'('':'*')' * !* * !* ARRAYS WITH CONSTANT BOUNDS HAVE THEIR * !* DOPE-VECTOR IN THE CONSTANT AREA AND MAY HAVE THEIR SPACE * !* ALLOCATED AT COMPILE TIME AMONG THE SCALARS * !* ALL OTHER ARRAYS HAVE A DOPE VECTOR AMONG THE LOCALS AND GET * !* THEIR SPACE OFF THE STACK AT RUN TIME * !* BOTH SORTS OF ARRAYS HAVE A FOUR WORD HEAD AND D-V TO EMAS * !* SYSTEM STANDARDS * !*********************************************************************** %ROUTINESPEC CLAIM AS %INTEGER DVDISP, PP, DVF, ELSIZE, TOTSIZE, R, LBND, PTYPEPP, %C PTYPEP, ARRP, NN, ND, II, JJ, QQ, CDV, D0, D1, DESC, APARM SET LINE %IF PARMLINE#0 SAVE AUX STACK(1) TYPE=A(P) TYPE=2 %IF TYPE=4 NAM=0; ROUT=0; ADFLAG=1 P=P+5 ARRP=1; ARR=ARRP; PACK(PTYPEP) ELSIZE=BYTES(TYPE) DESC=SIZECODE(TYPE)<<27 START: NN=1; APARM=A(P); ! FIND NO OF NAMES IN NAMELIST PP=P; CDV=0; PTYPEPP=PTYPEP %WHILE A(P+1)=1 %THEN P=P+2 %AND APARM=APARM!A(P) %AND NN=NN+1 APARM=1-APARM>>16; ! 0 IS PASSED ,1 NOT PASSED P=P+2; ! TO ALT OF P %IF A(P)=1 %THEN ->CONSTDV; ! P = ! ! NORMAL CASE - PLANT CODE TO SET UP DOPE-VECTOR AT RUN TIME ! ND=0; JJ=P; DVF=0; TOTSIZE=X'FFFF' %UNTIL A(P)=2 %CYCLE; ! TILL NO MORE BPAIRS P=P+1; ND=ND+1; ! COUNT NO OF DIMENSIONS SKIP EXP(0); SKIP EXP(0) %REPEAT P=JJ; DVDISP=N; ! DVDISP IS D-V POSITION N=N+12*ND+12; ! CLAIM SPACE FOR THE D-V FAULT(37, 0) %IF ND>12; ! TOO MANY DIMENSIONS ! D0=5<<27!3*ND; D1=DVDISP+12; ! DESCPTR FOR DV STORE CONST(JJ,8,D0,D1) PF1(LD,0,PC,JJ) PSF1(INCA,1,PTR OFFSET(RLEVEL)) PSF1(STD,1,DVDISP) GRUSE(DR)=0 ! PSF1(LSS,0,1); ! M1 THE FIRST MULTIPLIER GRUSE(ACCR)=5; GRINF(ACCR)=1 %CYCLE II=ND,-1,1 P=P+1 QQ=DVDISP+12*II; ! TRIPLE FOR IITH DIMENSION PSF1(ST,1,QQ+4); ! STORE MULTIPLIER %IF ND<=2 %AND PARMARR=0 %AND A(P)=2 %AND A(P+2)=3 %C %AND A(P+3)=2 %AND A(P+4)=1 %AND A(P+6)=2 %AND %C 0<=A(P+5)<=APARM %AND II=ND %START PSF1(LSS,0,0); GRUSE(ACCR)=0 P=P+7; PTYPEPP=PTYPEPP+16 %FINISH %ELSE CSEXP(ACCR,1,0);! LOWER BOUND PSF1(ST,1,QQ); ! STORED IN DV CSEXP(ACCR,1,0); ! UPPER BOUND PSF1(ISB,1,QQ) PF3(JAF,6,0,3); ! JUMP UNLESS NEGATIVE PSF1(LSS,0,-1); ! SET UP -1 (ENSURES 0 ELEMENTS PSF1(IAD,0,1); ! CONVERTED TO RANGE PSF1(IMY,1,QQ+4); ! RANGE*MULTIPLIER PSF1(ST,1,QQ+8); ! AND STORED IN DV GRUSE(ACCR)=0 %REPEAT PSF1(IMY,0,ELSIZE) PSF1(ST,1,DVDISP+8) P=P+1 -> DECL CONSTDV: ! CONSTANT BOUNDS DVF=1; P=P+1; CDV=1 DVDISP=DOPE VECTOR(ELSIZE, APARM, TOTSIZE, LBND); ! AND GENERATE A D-V ND=J %IF LBND=0 %AND ND<=2 %THEN PTYPEPP=PTYPEPP+16 ! %UNLESS GRUSE(XNB)=14 %THEN %START SET XNB(-1); ! XNB TO PLT PF1(LXN,0,XNB,12); ! XNB TO SST GRUSE(XNB)=14 %FINISH ! DECL: ! MAKE DECLN - BOTH WAYS ODD ALIGN PTYPE=PTYPEPP J=ND %CYCLE JJJ=0, 1, NN-1; ! DOWN NAMELIST %IF DVF#0 %THEN %START; ! ARRAY IS STRING OF LOCALS R=TOTSIZE//ELSIZE D0=DESC!R STORE CONST(D1,4,D0,0) PF1(LDTB,0,PC,D1) PSF1(STD,1,N); ! ARRAY DESC TO HEAD %FINISH %ELSE %START STORE CONST(D1,4,DESC,0) PF1(LDTB,0,PC,D1) PSF1(LDB,1,DVDISP+20) PSF1(STD,1,N) %FINISH GRUSE(DR)=0 PSF1(LSS,2,AUXSBASE(LEVEL)&X'3FFFF') PSF1(ST,1,N+4) %IF DVF#0 %THEN PF1(LDRL,0,XNB,DVDISP) %AND PSF1(STD,1,N+8)%C %ELSE PSF1(LSD,1,DVDISP) %AND PSF1(ST,1,N+8) SNDISP=0 GRUSE(DR)=0; GRUSE(ACCR)=0 ! ACC=ELSIZE; ! RESET ACC AFTER DV CMPLD KFORM=0 K=A(2*JJJ+PP)&X'FFFF' ! TEST NST STORE TAG(K, N) N=N+16 CLAIM AS %REPEAT P=P+1; ! PAST REST OF ARRAYLIST %IF A(P-1)=1 %THEN P=P+2 %AND ->START ADFLAG=0 %RETURN %ROUTINE CLAIM AS !*********************************************************************** !* CLAIM THE SPACE FOR AN ARRAY FROM STACK OR AUX STACK * !*********************************************************************** %INTEGER D %IF CDV=1 %THEN %START TOTSIZE=(TOTSIZE+3)&(-4) %IF TOTSIZE * !* DOPE VECTOR CONSISTS OF :- * !* DESRIPTOR (SCALED WORD) POINTING AT FIRST TRIPLE BND=3*ND * !* SIZE (IN BYTES OF ENTIRE ARRAY) FOR STACK ADJUSTMENT * !* AND ND TRIPLES EACH CONSISTING OF:- * !* LBI - THE LOWER BOUND OF THE ITH DIMENSION * !* MI - THE STRIDE FOR THE ITH DIMENSION * !* CBI THE UPPER CHECK =(UBI-LBI+1)*MI * !* WHERE M1=1(SCALED ARRAYS) OR THE ELEMENT SIZE AND * !* MI = M(I-1)*RANGE(I-1) * !*********************************************************************** %INTEGER I, JJ, K, ND, D, PP, M0 %INTEGERARRAY DV(0:39); ! ENOUGH FOR 12 DIMENSIONS ND=0; PP=P ND=ND+1 %AND P=P+7 %UNTIL A(P)=2 P=PP M0=1 %CYCLE D=ND,-1,1 CBPAIR(I, JJ) K=3*D %IF PARMARR=0 %AND D=ND<=2 %AND 1<=I<=APARM %THEN I=0 DV(K)=I DV(K+1)=M0 M0=M0*(JJ-I+1) DV(K+2)=M0 %REPEAT P=P+1 ! ASIZE=M0*ELSIZE DV(2)=ASIZE DV(1)=12 DV(0)=5<<27!3*ND; ! DESPTR FOR DV LB=DV(3*ND) K=12*ND+12 I=SSTL LPUT(4, K, SSTL, ADDR(DV(0))) %IF INHCODE=0 SSTL=SSTL+K J=ND; ! DIMENSIONALITY FOR DECLN %RESULT =I %END !%ROUTINE TEST NST !!*********************************************************************** !!* SEE IF NAME 'K' HAS BEEN DECLARED BEFORE AT THIS LEVEL * !!*********************************************************************** !%INTEGER Q ! FNAME=K ! Q=TAGS(FNAME) ! FAULT(7, FNAME) %IF FROM1(Q)>>8&15=LEVEL !%END %ROUTINE RT JUMP(%INTEGER CODE,%INTEGERNAME LINK) !*********************************************************************** !* PLANTS A 'BAL' TO THE APPROPIATE ENTRY ADDRESS IN LINK * !* IF ROUTINE HAS BEEN SPECIFIED BUT NOT DESCRIBED THE JUMP CAN * !* NOT BE PLANTED AND IS LINKED INTO A LIST HEADED BY LINK * !* TO AWAIT FILLING (BY ' RHEAD ') WHEN THE BODY IS GIVEN. * !* THE FORMAT OF AN ENTRY IS :- * !* S2(32 BITS) = ADDRESS OF JUMP TO BE FILLED * !* THE CODING ASSUMES I,J&OLDI ARE SET UP FOR THE CALLED ROUTINE * !*********************************************************************** %INTEGER DP %IF J=15 %THEN %START; ! RT BODY NOT GIVEN YET PUSH123(LINK, CODE<<24!3<<23, CA, 0) PF1(CODE,0,0,0) %FINISH %ELSE %START; ! BODY GIVEN AND ADDRESS KNOWN DP=LINK-CA DP=DP//2 %IF CODE=CALL PSF1(CODE,0,DP) %FINISH %END %ROUTINE DIAG POINTER (%INTEGER LEVEL) !*********************************************************************** !* INSERT A POINTER TO THE DIAG TABLE INTO THE DESCRIPTOR IN * !* IN DR AND STORE THE DESCRIPTOR IN ITS PROPER PLACE * !*********************************************************************** %IF PARMTRCE#0 %THEN %START PUSH123(RAL(LEVEL),1,CA,LDB<<24!3<<23) PF1(LDB,0,0,0) GRUSE(DR)=0 %FINISH PSF1(STD,1,12) %END %ROUTINE CEND(%INTEGER KKK) !*********************************************************************** !* DEAL WITH ALL OCCURENCES OF '%END' * !* KKK=PTYPE(>=4096) FOR ROUTINES,FNS AND MAPS * !* KKK=0 FOR ENDS OF '%BEGIN' BLOCKS * !* KKK=-1 FOR BLOCKS AFTER %DO OR %ELSE * !* KKK=-2 FOR BLOCKS AFTER %THEN (IE %ELSE IS VALID) * !* KKK=-3 FOR THE HYPOTHETICAL BLOCK TO STOP JUMPS INTO %FOR * !* %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, WK, JJ, KK, BIT %ROUTINESPEC DTABLE(%INTEGER LEVEL) BIT=1<=-1 %THEN FAULT(47,0) 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 POP123(LABEL(LEVEL), I, J, KP) %IF J&X'FFFF'#0 %THEN %START J=J&X'FFFF' CLEAR LIST(J) %FINISH %REPEAT ! %WHILE TWSPHEAD#0 %CYCLE POP(TWSPHEAD,JJ,KK) RETURN WSP(JJ,KK) %REPEAT %CYCLE J=1, 1, 4 %IF AVL WSP(J,LEVEL)#0 %THEN %C CLEAR LIST(AVL WSP(J, LEVEL)) ! RELEASE TEMPORARY LOCATIONS %REPEAT ! ! ! CLEAR DECLARATIONS - POP UP ANY GLOBAL NAMES THAT WERE REDECLARED ! DESTROY SIDE CHAINS FOR ROUTINES ! NB PROCEDURES WITH PROCEDURE PARAMS HAVE SECONDARY SIDECHAINS ! ! AT THE SAME TIME CONSTRUCTTHE DIAGNOSTIC TABLES DTABLE(LEVEL); ! OUTPUT DIAGNOSTIC TABLES ! ! CLAIM THE STACK FRAME BY FILLING THE ASF IN THE BLOCK ENTRY CODING. ! NMAX=(NMAX+7)&(-8) %IF KKK=2 %THEN %RETURN JJ=SET(RLEVEL) %IF KKK>=4096 %OR KKK=1 %THEN %START WK=JJ>>18; JJ=JJ&X'3FFFF' KP=(ASF+12*PARMCHK)<<24!3<<23!(NMAX-WK+3)>>2 PLUG(1,JJ,KP) %FINISH ! ! NOW PLANT THE BLOCK EXIT SEQUENCE ! %IF KKK>=4096 %THEN %START; ! PROCEDURE END JJ=KKK&7 %IF JJ#0 %THEN %START %IF JJ=2 %THEN KP=2 %ELSE KP=1 %IF GRUSE(ACCR)#10 %OR WRD(GRINF(ACCR))#M(LEVEL) %START GET IN ACC(ACCR,KP,0,LNB,SET(RLEVEL)>>18);! LOAD RESULT %IF PARMCHK#0 %THEN TYPE=JJ %AND TEST ASS(ACCR) %FINISH %FINISH RT EXIT %FINISH %IF KKK<=0 %THEN %START; ! BEGIN BLOCK EXIT JJ=AUXSBASE(LEVEL-1) %IF JJ#AUXSBASE(LEVEL) %THEN RESET AUX STACK %IF PARMTRCE=1 %AND KKK#-3 %START;! RESTORE DIAGS POINTERS PSF1(LD,1,12) DIAG POINTER(LEVEL-1) %FINISH %FINISH FORGET(-1) %IF KKK>=0 ! ! 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 %C %ELSE FAULT(14, 0) %AND %STOP %FINISH LEVEL=LEVEL-1 %IF KKK>=4096 %THEN %START RLEVEL=RLEVEL-1 %FINISH ! ! RESTORE INFORMATION ABOUT THE (NEW) CURRENT LEVEL ! POP(LEVELINF, JJ, N) NMAX=N>>16 %IF KKK>=4096 N=N&X'7FFF' %IF KKK=2 %THEN PPJ(15,16) %AND CEND(KKK) ! ROUND AGAIN FOR 'ENDOFPROGRAM' ! ! COMPLETE THE JUMP AROUND ALL NON-EXTERNAL ROUTINES EXCEPT WHEN ! %TRUSTEDPROGRAM IS IN OPERATION. ! %IF KKK>=4096 %AND (RLEVEL#0 %OR CPRMODE#2) %C %THEN ENTER LAB(JROUND(LEVEL+1), 0,LEVEL) %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)<<20 ! ENVIRONMENT ! 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.* !*********************************************************************** %STRING (31) RT NAME %STRING (8) LOCAL NAME %INTEGER DPTR, LNUM, ML, KK, JJ, Q, BIT, S1, S2, S3, S4 %RECORDNAME LCELL(LISTF) %INTEGERARRAY DD(0:1000); ! BUFFER FOR SEGMENT OF SST ! ! FILL ALL OUTSTANDING REFERENCES TO THIS DIAGS BLOCK ! BIT=1<>2; ! ACTUAL NO OF CHARS %FINISH ! ! FOR TYPED PROCEDURES ADD THE RESULT VARIABLE TO THE DIAG TABLES ! %IF KKK>4096 %AND PARMDIAG#0 %START TYPE=KKK&7 DD(DPTR)=SIZECODE(TYPE)<<24!TYPE<<20!%C SET(RLEVEL)>>18 LOCAL NAME<-RT NAME LNUM=BYTEINTEGER(ADDR(LOCAL NAME)) STRING(ADDR(DD(DPTR))+4)=LOCAL NAME DPTR=DPTR+(LNUM+8)>>2 %FINISH JJ=NAMES(LEVEL) %WHILE 0<=JJ>16 %IF PTYPE=6 %AND S2&X'FFFF'#0 %THEN FAULT(12,JJ) %IF PTYPE&X'F000'#0 %THEN %START K=S3>>16 POP(K,KK,KK) %WHILE K>0 %CYCLE KK=FROM2(K)>>16; ! SECONDARY CHAIN IF PROCEDURE %IF FROM1(K)>=4096 %THEN CLEAR LIST(KK) POP(K,KK,KK) %REPEAT %FINISH %IF PARMDIAG#0 %AND DPTR<997 %AND 1<=PTYPE&X'F0FF'<=5 %START %IF PTYPE=5 %THEN NAM=1 %ELSE NAM=PTYPE>>8&3 TYPE=PTYPE&7 Q=ADDR(LETT(WRD(JJ))); ! ADDRESS OF NAME %IF S1>>4&15=0 %THEN I=1 %ELSE I=0 DD(DPTR)=NAM<<30!SIZECODE(TYPE)<<24! %C TYPE<<20!I<<18!S3>>16 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 JJ=S4>>18 %REPEAT DD(DPTR)=-1; ! 'END OF SEGMENT' MARK DPTR=DPTR<<2+4 %IF PARMTRCE=1 %AND KKK#-3 %THEN %START LPUT(4, DPTR, SSTL, ADDR(DD(0)));! ADD TO SHARABLE SYM TABS SSTL=SSTL+DPTR %FINISH %END; ! OF ROUTINE DTABLE %END %ROUTINE SAVE AUX STACK(%INTEGER ARRS) !*********************************************************************** !* COPY THE AUX STACK DESCRIPTOR UNDER LNB AND SAVE THE STACK PTR* !* FOUR WORDS ARE NEEDED TO SAVE THE AUXILLARY STACK STATUS * !* 1&2 HOLD A COPY OF THE STACK DESCRIPTOR(FOR CONVENIENCE) * !* 3 HAS COPY OF STACKTOP ON ENTRY(FOR RESETTING ON EXIT) * !* 4 HAS COPY OF STACKTOP AFTER DECLARATIONS. NEEDED ONLY IF * !* THE INNER BLOCKS ARE JUMPED OUT OF INTO CURR BLK * !*********************************************************************** %IF AUXSBASE(LEVEL)=0 %START AREA=-1; BASE=0 GET IN ACC(DR,2,2,AREA CODE,AUXST) PF1(LSS,2,7,0); ! LSS @DR GRUSE(ACCR)=0 PSF1(STD,1,N) PSF1(ST,1,N+8) %IF ARRS=0 %THEN %C PSF1(ST,1,N+12); ! IF NO ARRAYS LAST 2 WORDS ! ARE IDENTICAL AUXSBASE(LEVEL)=RLEVEL<<18!N N=N+16 %FINISH %END %ROUTINE RESET AUX STACK !*********************************************************************** !* IF ANY ARRAYS HAVE BEEN PUT ON THE AUXSTACK THEN UNDECLARE * !*********************************************************************** %IF AUXSBASE(LEVEL)>>18=RLEVEL %START PSF1(LB,1,AUXSBASE(LEVEL)&X'3FFFF'+8) PSF1(STB,2,AUXSBASE(LEVEL)&X'3FFFF') GRUSE(BREG)=0 %FINISH %END %ROUTINE RT EXIT !*********************************************************************** !* THIS ROUTINE COMPILES CODE FOR ROUTINE EXIT(IE '%RETURN') * !*********************************************************************** RESET AUX STACK PSF1(EXIT,0,-X'40') %END %ROUTINE RHEAD(%INTEGER KK) !*********************************************************************** !* COMPILES CODE FOR BLOCK AND ROUTINE ENTRY * !* KK IS THE RT/FN/MAP NAME (=-1 FOR %BEGIN BLOCKS) * !* THE FIRST (PERM) BEGIN WHICH HAS TO BE TREATED AS A ROUTINE * !*********************************************************************** %INTEGER W1, W3, INSRN, AT PUSH123(LEVELINF, 0, NMAX<<16!N, 0) LEVEL=LEVEL+1 NMDECS(LEVEL)=0 AUXSBASE(LEVEL)=0; NAMES(LEVEL)=-1 DIAGINF(LEVEL)=DIAGINF(LEVEL-1) %IF KK>=0 %THEN %START RLEVEL=RLEVEL+1 %FINISH FAULT(34, 0) %IF LEVEL=MAX LEVELS FAULT(105, 0) %IF LEVEL>MAX LEVELS %IF KK>=0 %AND LEVEL>2 %START; ! ROUTINE ENTRY COPY TAG(KK); JJ=K; ! LIST OF JUMPS %IF J#0 %THEN %START; ! SKIP IF BODY ALREADY GIVEN J=FROM1(JJ) %IF J=0 %AND LEVEL>2 %START;! REPLACE 'NOT USED' BIT W1=TAGS(KK) REPLACE1(W1, FROM1(W1)&X'FFFF3FFF') %FINISH ! ! NOW FILL ANY JUMPS TO THIS ROUTINE PLANTED SINCE ! THE ROUTINESPEC WAS COMPILED. SEE ALSO 'RT JUMP' ! %WHILE J#0 %CYCLE POP123(J, INSRN, AT, W1) W3=CA-AT W3=W3//2 %IF INSRN>>25=CALL>>1 INSRN=INSRN+W3 PLUG(1, AT, INSRN) %REPEAT REPLACE1(JJ, CA); ! NOTE ADDR FOR FUTURE CALLS %FINISH %FINISH %IF KK<0 %THEN W3=0 %ELSE W3=WRD(KK) L(LEVEL)=LINE; M(LEVEL)=W3 FLAG(LEVEL)=PTYPE; ! CURRENT BLOCK TYPE MARKER %END; ! OF ROUTINE RHEAD %ROUTINE RDISPLAY(%INTEGER KK) !*********************************************************************** !* SET UP OR COPY THE DISPLAY (A WORD ARRAY CONTAINING COPIES OF * !* LNB FOR THE GLOBAL LEVELS. THE HIGHEST LEVEL ENTRY IS TO THE * !* GLA(PLT) FOR OWNS AND IS ALSO KEPT IN(LNB+4) IN CASE WE WISH * !* TO MOVE TO READ-ONLY PLTS. ON INTERNAL CALLS THE LNB FOR THE * !* NEXT MOST GLOBAL LEVEL IS STACKED AS AN EXTRA PARAMETER * !*********************************************************************** %INTEGER W1,W2,STACK,OP,INC %IF KK>=0 %OR LEVEL=2 %START; ! DISPLAY NEEDED STACK=0; DISPLAY(RLEVEL)=N %IF LEVEL=2 %THEN %START PSF1(LSS,1,16); ! POINTER TO GLA(PLT) STACK=-32; N=N+4 %FINISH %ELSE %START ! PF1(LXN,0,TOS,0) GRUSE(XNB)=4; GRINF(XNB)=RLEVEL-1 PF1(LD,0,XNB,12); ! COPY PLT DESCRIPTOR DIAG POINTER(LEVEL) W1=RLEVEL; W2=DISPLAY(W1-1) %WHILE W1>0 %CYCLE OP=LSS; INC=1 %IF W1>=2 %THEN OP=LSD %AND INC=2 %IF W1>=4 %THEN OP=LSQ %AND INC=4 PF1(OP+STACK,0,XNB,W2) STACK=-32; N=N+4*INC W2=W2+4*INC; W1=W1-INC %REPEAT %FINISH %IF STACK#0 %THEN PF1(ST,0,TOS,0); ! ST TOS PF1(STLN,0,TOS,0) N=N+4 %FINISH ! ! IF IN DIAGNOSTIC MODE PLANT CODE TO SAVE THE LINE & ROUTINE NO OF ! THE CALLING ROUTINE AND SET UP THE NEW BLOCK/ROUTINE IDENT NO. ! %IF PARMTRCE#0 %START DIAGINF(LEVEL)=N PF1(LSS,0,PC,PLABS(1)+4*14) %IF KK>=0 %OR LEVEL=2 %START PSF1(SLSS,0,LINE) PF1(ST,0,TOS,0) %FINISH %ELSE %START PSF1(ST,1,DIAGINF(LEVEL)) PSF1(LSS,0,LINE) PSF1(ST,1,DIAGINF(LEVEL)+4) PSF1(LD,1,12) DIAGPOINTER(LEVEL) %FINISH N=N+8 GRUSE(ACCR)=0; ! NEEDED FOR %BEGIN BLOCKS %FINISH ! ! IN SEPARATELY COMPILED PROCEDURES CHECK THE CORRECT AMOUNT OF PARAMS ! ARE PRESENT ON THE STACK. THIS IS THE BEST POSSIBLE AT THIS DATE ! %IF PARMOPT#0 %AND KK>=0 %AND LEVEL=2 %START PF1(STSF,0,BREG,0) PF1(STLN,0,TOS,0) PF1(SBB,0,TOS,0) PSF1(CPB,0,N) PPJ(7,10) %FINISH ! ! CLAIM (THE REST OF) THE STACK FRAME ! %IF KK>=0 %OR LEVEL=2 %START SET(RLEVEL)=N<<18!CA NMAX=N PF1(ASF+12*PARMCHK,0,0,0); ! ASF OR LB PPJ(0,3) %IF PARMCHK#0 %IF KK>=0 %AND PTYPE&7#0 %THEN N=N+8; ! FOR RESULT %FINISH ! %IF KK>=0 %THEN %START CHECK STOF; ! CHECK FOR STACK O'FLOW %FINISH %END %ROUTINE CHECK STOF !*********************************************************************** !* CHECK THE STACK FOR OVERFLOW (LEAVING 4K MARGIN FOR MDIAG * !*********************************************************************** %IF PARMOPT#0 %THEN %START ! ! STSF TOS GET STACK POINTER ! LSS TOS ! USH +14 ! USH -15 LOSE SEGMENT NO ! ICP X'1F800' CHECK WITHIN SEG ADDRESS ! SHIFTED DOWN 1 PLACE ! JCC 2,EXCESS BLKS ! PF1(STSF,0,TOS,0) PF1(LSS,0,TOS,0) PSF1(USH,0,14) PSF1(USH,0,-15) PF1(ICP,0,0,ST LIMIT>>1) PPJ(2,8) %FINISH %END; ! OF ROUTINE RHEAD %ROUTINE CLABEL !*********************************************************************** !* P POINTS TO IN * !*********************************************************************** %INTEGER LNAME,T,USE LNAME=A(P) %IF LEVEL>1 %THEN %START; ! LABELS BEFORE 1ST BEGIN T=TAGS(LNAME); USE=FROM1(T) %UNLESS USE>>16=6 %AND FROM3(T)=0 %THEN %C FAULT(2,LNAME) %ELSE ENTER LAB(LNAME,0,USE>>8&63);! USE>>8&63=OLDI %FINISH P=P+2 %END %ROUTINE COLABEL !*********************************************************************** !* P POINTS TO ALT OF P * !*********************************************************************** %WHILE A(P)=1 %THEN P=P+1 %AND CLABEL P=P+1 %END %ROUTINE CBLK(%INTEGER BLKTYPE) !*********************************************************************** !* SUCK IN A BLOCK OCCURRING IN IF..THEN ETC * !*********************************************************************** %INTEGER I,OLDLEV,KK KK=0 %CYCLE I=P,1,P+5; KK=KK+A(I); %REPEAT %IF KK=0 %THEN BLKTYPE=-3 PTYPE=BLKTYPE OLDLEV=LEVEL; RHEAD(-1) %IF BLKTYPE=-3 %THEN %START AUXSBASE(LEVEL)=AUXSBASE(LEVEL-1) %FINISH %ELSE %START RDISPLAY(-1) MAKE DECS(P,-1) %FINISH %UNTIL LEVEL=OLDLEV %CYCLE; ! TILL CORRESPONDING END I=NEXTP; NEXTP=NEXTP+A(NEXTP) !*DELSTART %IF DCOMP#0 %AND CA>CABUF %THEN CODEOUT %AND PRINTUSE !*DELEND LINE=A(I+1) CSS(I+2) %REPEAT P=I+3; ! TO ELSE AFTER %END %END %ROUTINE CCMPNDSTMNT !*********************************************************************** !* SUCK IN A COMPOUND STATEMENT (IE BLOCK WITH NO DECLNS) * !* P TO PHRASE IN THE SEQUENCE:- * !* '%BEGIN' * !*********************************************************************** %INTEGER I,OLDLEVEL OLDLEVEL=LEVEL %WHILE A(P)=1 %THEN P=P+1; ! PAST ANY COMMENTS P=P+1; COLABEL LINE=LINE+1 SET LINE %IF PARMLINE#0 CSTMNT %CYCLE I=NEXTP; NEXTP=NEXTP+A(NEXTP) !*DELSTART %IF DCOMP#0 %AND CA>CABUF %THEN CODEOUT %AND PRINTUSE !*DELEND LINE=A(I+1) P=I+2 %WHILE A(P)=8 %THEN P=P+1 %AND CLABEL I=P-2 %IF LEVEL=OLDLEVEL %AND A(P)=2 %THEN %EXIT CSS(P) %REPEAT P=I+3; ! TO ELSE IF ANY %END %ROUTINE C FORSTMNT !*********************************************************************** !* COMPILE A FOR STATEMENT TREATING SIMPLE CASES WELL * !*********************************************************************** %ROUTINESPEC C FORLISTEL %ROUTINESPEC INTO FOR %ROUTINESPEC C FOR BODY %INTEGER FORNAME,FORLISTE,FORTYPE,FORPTYPE,FPL,FP,FCMPLX,FBP FBP=P+2+A(P+2) FORLISTE=A(FBP); ! =2 IF ONE ELEMENT LIST %IF FORLISTE=2 %THEN %START FBP=FBP+1 %WHILE A(FBP)=1 %THEN FBP=FBP+3 FBP=FBP+1 %FINISH FORNAME=A(P+3) FP=P+3; P=FP+1 COPYTAG(FORNAME) FCMPLX=ROUT!NAM!ARR!PARMCHK FAULT(25,FORNAME) %UNLESS (1<=TYPE<=2 %OR TYPE=7) %AND %C ARR=ROUT=0 %AND A(P)=3 FORTYPE=TYPE; FORPTYPE=PTYPE %IF A(P)#3 %THEN SKIP APP %AND P=P-1 PLABEL=PLABEL-1; FPL=PLABEL %UNTIL FORLISTE=2 %OR A(P)=2 %CYCLE;! UNTIL FORLIST EXHAUSTED P=P+1; C FORLISTEL %REPEAT %IF FORLISTE#2 %THEN P=P+1 %AND C FORBODY %RETURN %ROUTINE C FORLISTEL !*********************************************************************** !* COMPILE ONE ELEMENT OF A FOR LIST * !* P TO * !*********************************************************************** %INTEGER PP, FALT,QQ,FEXITPL,STEPP,STEPTMP,STEPRP,CONTROLRP,CNSTSTEP,%C STEPVAL,COPCODE,CXTRA,STEPHEAD,ASSHEAD,OPHEAD,NOPS,NSE,OPBOT,%C ASSBOT,STEPBOT,FETYPE,RR,FINACC,FINAREA,FINDISP,FINBASE,RRR,CPI %SWITCH FALTNO(1:3) OPHEAD=0; CNSTSTEP=0; STEPVAL=0 ASSHEAD=0; STEPHEAD=0; NSE=0; CPI=0 STEPBOT=0; OPBOT=0; ASSBOT=0 PLABEL=PLABEL-1; QQ=PLABEL PLABEL=PLABEL-1; FEXITPL=PLABEL RR=RPPTR CONTROLRP=FORTYPE<<16!FCMPLX<<8!2 NOPS=1; ETORP(OPHEAD,NOPS,FORTYPE) RRR=RPPTR-3 A(RRR)=99 A(RRR+1)=RPPTR; ! TIC TO NEXT =NO-OP A(RPPTR)=FORPTYPE<<16!2 A(RPPTR+1)=FP A(RPPTR+2)=TAGS(FORNAME) A(RPPTR+3)=31; ! 31=ASSIGN RPPTR=RPPTR+6 FALT=A(P); FETYPE=TYPE P=P+1 ->FALTNO(FALT) FALTNO(1): ! STEP -UNTIL ! ! FIRST CHECK FOR CONSTANT STEPS WHICH DO NOT NEED TO BE EVALUATED ! OR ASSIGNED TO TEMPORARIES ! %IF A(P)=2 %AND A(P+3)=2 %AND A(P+4)=1 %AND A(P+5)#0 %C %AND A(P+6)=2 %THEN %START CNSTSTEP=1; STEPVAL=A(P+5) %IF A(P+2)=2 %THEN STEPVAL=-STEPVAL P=P+7 STEPRP=1<<16!1 STEPTMP=STEPVAL %IF FCMPLX=0 %AND FORTYPE=FETYPE %THEN NSE=1 ! NO SIDE EFFECTS IN INCREMENTING %IF NSE=FORTYPE=1 %AND PARMOPT=0 %AND A(P)=2 %AND %C A(P+1+A(P+1))=2 %START %IF A(P+3)=2 %AND A(P+4)=1 %START FINDISP=A(P+5); FINACC=0; FINAREA=0; FINBASE=0 %IF A(P+2)=2 %THEN FINDISP=-FINDISP %IF IMOD(FINDISP)>>18=0 %THEN ->CPIB %FINISH ! %IF A(P+3)=1 %AND A(P+5)=3 %START; ! NAME --NO APP COPYTAG(A(P+4)) %IF PTYPE&X'FEFF'=1 %START;! OMIT NAM BIT FINACC=PTYPE>>7; ! 0 FOR LOCAL-2 FOR NAMETYPE FINAREA=-1; FINDISP=K FINBASE=I; ->CPIB %FINISH %FINISH %FINISH %FINISH %ELSE %START GET WSP(STEPTMP,FORTYPE); ! TEMPORARY FOR STEP STEPRP=FORTYPE<<16!RLEVEL<<8!7;! REVERSE POLISH DESCRPTR %FINISH ! ! EVALUATE STEP AND ASSIGN TO TEMPORARY ! STEPP=P %IF CNSTSTEP=0 %THEN %START NOPS=NOPS+1; ETORP(STEPHEAD,NOPS,FORTYPE) A(RPPTR-3)=STEPRP A(RPPTR-2)=STEPTMP A(RPPTR)=31 RPPTR=RPPTR+3 %FINISH %IF NSE#0 %START A(RRR+6)=30; ! REPLACE 31(:=) BY 30(::=) A(RRR)=12; ! MOVE LABEL TO ST INSTN A(RRR+1)=QQ!1<<16; ! AND FORCE A LOAD %FINISH %ELSE %START A(RPPTR)=12 A(RPPTR+1)=QQ RPPTR=RPPTR+3 %FINISH ! ! EVALUATE (V-C)*SIGN(D) ! COPCODE=27; CXTRA=5; ! '<=' %IF STEPVAL<0 %THEN CXTRA=2; ! '>=' %IF NSE=0 %START A(RPPTR)=CONTROLRP A(RPPTR+1)=FP RPPTR=RPPTR+3 %FINISH ! NOPS=NOPS+3 ETORP(ASSHEAD,NOPS,FORTYPE) RPPTR=RPPTR-3 %IF CNSTSTEP=0 %THEN COPCODE=16 A(RPPTR)=COPCODE A(RPPTR+1)=CXTRA RPPTR=RPPTR+3 ! %IF CNSTSTEP=0 %THEN %START A(RPPTR)=STEPRP A(RPPTR+1)=STEPTMP RPPTR=RPPTR+3 A(RPPTR)=14; ! SIGN A(RPPTR+3)=19; ! MULTIPLY RPPTR=RPPTR+6 %FINISH A(RPPTR)=100; ! TERMINATE RPPTR=RPPTR+3 PP=P; EXPOP(RR,ACCR,NOPS,FORTYPE) P=PP; RPPTR=RR %IF COPCODE=16 %START %IF CNSTSTEP#0 %AND STEPVAL<0 %THEN MASK=18 %ELSE MASK=17 %IF FORTYPE=1 %THEN MASK=MASK+4 %FINISH ENTER JUMP(MASK,FEXITPL,B'10') COMM: INTO FOR %IF CPI#0 %START P=FP; CSEXP(BREG,1,2); ! EXPRESSION OF SINGLE NAME %FINISH %ELSE %START ! ! INCREMENT CONTROL BY STEP ! P=STEPP; NOPS=1 %IF CNSTSTEP=0 %THEN %START ETORP(OPHEAD,NOPS,FORTYPE); RPPTR=RPPTR-3; ! EVALUATE STEP %FINISH A(RPPTR)=STEPRP A(RPPTR+1)=STEPTMP RPPTR=RPPTR+3 ! %IF CNSTSTEP=0 %START A(RPPTR)=30; ! ASSIGN VARIABLE STEP TO TEMP RPPTR=RPPTR+3 %FINISH A(RPPTR)=CONTROLRP A(RPPTR+1)=FP RPPTR=RPPTR+3 A(RPPTR)=15; ! ADD STEP TO CONTROL RPPTR=RPPTR+3 ! %IF NSE=0 %START A(RPPTR)=FORPTYPE<<16!2 A(RPPTR+1)=FP A(RPPTR+2)=TAGS(FORNAME) A(RPPTR+3)=31; ! ASSIGN INCREMENT CONTROL RPPTR=RPPTR+6 %FINISH ! A(RPPTR)=100 RPPTR=RPPTR+3 EXPOP(RR,ACCR,NOPS,FORTYPE) %FINISH RPPTR=RR ENTER JUMP(15,QQ,0) ENTER LAB(FEXITPL,B'111',LEVEL) P=PP; %RETURN CPIB: ! CAN USE CPIB OR EQIVALENT PP=P+7; CPI=1 A(RRR)=STEPRP; A(RRR+1)=STEPTMP A(RRR+3)=16; ! SUBTRACT A(RRR+6)=100 EXPOP(RR,BREG,NOPS,FORTYPE); ! (INIT-STEP) TO BREG ! ACCESS=FINACC; AREA=FINAREA BASE=FINBASE ENTER LAB(QQ,0,LEVEL) %IF STEPVAL=1 %START PSORLF1(CPIB,ACCESS,AREA CODE,FINDISP) %IF STEPVAL>=0 %THEN MASK=10 %ELSE MASK=12 %FINISH %ELSE %START PSF1(ADB,0,STEPVAL) PSORLF1(CPB,ACCESS,AREA CODE,FINDISP) %IF STEPVAL>=0 %THEN MASK=2 %ELSE MASK=4 %FINISH ! ! BEWARE OF ESCAPE DESCRIPTORS SINCE THESE ARE ALLOWED FOR FINAL VALUE ! DELETE THE NEXT STATEMENT WHEN 'STXN' ARRIVES AND ESCAPES ARE TRANSPARENT ! %IF FINACC#0 %THEN GRUSE(XNB)=0; ! MAY HAVE BEEN CORRUPTED GRUSE(BREG)=0 COPY TAG(FORNAME) ACCESS=0; AREA=-1; BASE=I PSORLF1(STB,ACCESS,AREA CODE,K) NOTE ASSMENT(BREG,FORNAME) ENTER JUMP(MASK,FEXITPL,B'10') P=PP; ->COMM FALTNO(2): ! WHILE ENTER LAB(QQ,0,LEVEL) A(RPPTR)=100 RPPTR=RPPTR+3 PP=P; EXPOP(RR,-1,NOPS,FORTYPE!16) RPPTR=RR P=PP; CCOND ENTER JUMP(MASK,FEXITPL,B'11') INTO FOR ENTER JUMP(15,QQ,0); ! UNCONDITIONALLY TO WHILE ENTER LAB(FEXITPL,B'111',LEVEL); ! TO EXIT WHEN BE FALSE %RETURN FALTNO(3): ! NULL PP=P A(RPPTR)=100 RPPTR=RPPTR+3 EXPOP(RR,-1,NOPS,FORTYPE!16) P=PP; RPPTR=RR INTO FOR %END %ROUTINE INTOFOR %INTEGER I %IF FORLISTE#2 %THEN %START ENTERJUMP(0,FPL,0) %CYCLE I=0,1,7; GRUSE(I)=0; %REPEAT %FINISH %ELSE %START P=P+1 C FOR BODY %FINISH %END %ROUTINE C FORBODY !*********************************************************************** !* A FOR BODY IS NORMALLY ENTERED BY A JLK * !*********************************************************************** %INTEGER FBALT,I,PL,RAD %IF FORLISTE#2 %THEN %START PLABEL=PLABEL-1; PL=PLABEL ENTER JUMP(15,PL,B'10') ENTER LAB(FPL,0,LEVEL) RAD=N; N=RAD+4 PF1(LSS,0,TOS,0); ! GET RETURN ADDRESS PSF1(ST,1,RAD); ! AND SAVE IN STACK FRAME %FINISH PTYPE=-3; I=P RHEAD(-1) AUXSBASE(LEVEL)=AUXSBASE(LEVEL-1) COLABEL FBALT=A(P); P=P+1 %IF FBALT=1 %THEN %START; ! %BEGIN CBLK(-2) %FINISH %ELSE %START CSTMNT %FINISH CEND(FLAG(LEVEL)) %IF FORLISTE#2 %THEN %START PSF1(JUNC,1,RAD) ENTER LAB(PL,B'111',LEVEL) %FINISH %END %END %ROUTINE CSTMNT !*********************************************************************** !* COMPILE AN ALGOL STATEMENT WHICH CAN BE A DUMMY * !*********************************************************************** %SWITCH ALT,UALT(1:4) %INTEGER SALT,PL1,PL2,CORB,PP,LNAM PP=P ->ALT(A(P)) ALT(1): ! UI P=P+1; CUI %RETURN ALT(2): ! FOR STMNT C FOR STMNT %RETURN ALT(3): ! %IF %THEN ... P=P+1; CCOND PLABEL=PLABEL-1; PL1=PLABEL ! ! A SIMPLE PIECE OF OPTIMISATION IS TO AVOID JUMPING ROUND A ONE- ! INSTRUCTION JUMP WHICH OCCURS WHEN THE STATEMENT TURNS OUT TO BE A ! UNLABELLED 'GOTO' TO A LABEL IN THE CURRENT BLOCK ! %IF A(P)=2 %AND A(P+1)=3 %AND A(P+2)=3 %AND A(P+3)=2 %AND %C A(P+4)=1 %AND A(P+6)=3 %START LNAM=A(P+5); COPY TAG(LNAM) %IF PTYPE=6 %AND OLDI=LEVEL %THEN %START ENTER JUMP(REVERSE(MASK),LNAM,0) P=P+7 %IF A(P)#1 %THEN %RETURN PL2=PL1; ->UON %FINISH %FINISH ! ! END OF A SIMPLE PIECE OF OPTIMISATION WHICH WILL NOT CATCH JUMPS OUT ! OF FOR LOOPS BUT SHOULD CATCH ALL OTHHER 1 INSTRUCTION GOTOS ! ENTER JUMP(MASK,PL1,B'10'); ! MERGE NOT SHORT COLABEL; SALT=A(P); P=P+1 ->UALT(SALT) UALT(1): ! BEGIN CORB=A(P); P=P+1 %IF CORB=1 %THEN CCMPNDSTMNT %ELSE CBLK(-2) ->UBACK UALT(2): ! FOR STMNT P=P-1 C FOR STMNT; ->UBACK UALT(3): ! UI CUI; ->UBACK UALT(4): ! NULL UBACK: %IF A(P)#1 %THEN %C ENTER LAB(PL1,B'11',LEVEL) %AND %RETURN; ! MERGE %IF SALT=2 %THEN FAULT(47,0); ! %ELSE AFTER %FOR PLABEL=PLABEL-1; PL2=PLABEL ENTER JUMP(15,PL2,B'10') ENTER LAB(PL1,B'111',LEVEL); ! REPLACE UON: P=P+1; COLABEL SALT=A(P); P=P+1 %IF SALT#1 %THEN CSTMNT %ELSE %START CORB=A(P); P=P+1 %IF CORB=1 %THEN CCMPNDSTMNT %ELSE CBLK(-1) %FINISH ENTER LAB(PL2,B'11',LEVEL); ! MERGE %RETURN ALT(4): ! DUMMY STATEMENT WARN(4,0) %END %ROUTINE CUI !*********************************************************************** !* COMPILE AN UNCONDITIONAL STATEMENT * !*********************************************************************** %SWITCH ALT(1:3) %INTEGER OPHEAD,NOPS,BOT,TYPEP,LPALT,LPNAM,STOREOP,JJ,KK,LP,RR ->ALT(A(P)) ALT(1): ! ASSIGNMENT RR=RPPTR; NOPS=0 JJ=TAGS(A(P+1)) TYPEP=FROM1(JJ)>>16&7 STOREOP=31; ! ALLOW MVC ON SINGLE LPLS LPALT=A(P+2) %IF (LPALT=1 %AND TYPEP#3) %OR (LPALT=2 %AND TYPEP>=3) %C %THEN %START %IF LPALT=1 %THEN FAULT(24,A(P+1)) %ELSE FAULT(42,A(P+1)) TYPEP=LPALT-4 %FINISH ! ! SHIFT THE ENTRY FOR P UP ONE PLACE TO OVERWRITE THE ALT OF P ! SO THAT IT IS NEXT TO P FOR CNAME ETC AND THE FIRST DESTINATION ! IN LEFT PART LIST CAN THEN BE TREATED AS ANY SUBSEQUENT ENTRY ! A(P+2)=A(P+1); P=P+2 AGN: LPNAM=A(P) BOT=RPPTR TCELL=TAGS(LPNAM) PTYPE=FROM1(TCELL)>>16 FAULT(29,LPNAM) %UNLESS PTYPE&7=TYPEP %IF PTYPE&X'F0'#0 %THEN %START CNAME(1,ACCR) %IF A(P)=1 %THEN %START; ! MORE LPL FOLLOWS JJ=TAGS(A(P+1)) %IF FROM1(JJ)&X'F0000F'=X'200001' %START A(RPPTR)=X'51'<<16!BREG<<12!9 REGISTER(BREG)=1 OLINK(BREG)=ADDR(A(RPPTR)) %FINISH %ELSE %START PF1(STB,0,TOS,0); ! STACK SUBSCRIPT A(RPPTR)=X'51'<<16!TOS<<12!8 %FINISH A(RPPTR+1)=0 %FINISH %ELSE %START GET WSP(KK,1); ! LOCAL TEMPORARY A(RPPTR)=X'51'<<16!BREG<<12!9 A(RPPTR+1)=KK REGISTER(BREG)=2 OLINK(BREG)=ADDR(A(RPPTR)) %FINISH A(RPPTR+3)=32 A(RPPTR+4)=LPNAM RPPTR=RPPTR+6 %FINISH %ELSE %START JJ=PTYPE<<16!2; KK=P %IF PTYPE&X'F000'#0 %START I=FROM1(TCELL)>>4&15 %CYCLE LP=LEVEL,-1,1 %IF WRD(LPNAM)=M(LP) %START JJ=(PTYPE&7)<<16!(I+1)<<8!9 KK=SET(I+1)>>18; %EXIT %FINISH %REPEAT %IF LEVEL=1 %OR A(P+1)#3 %THEN FAULT(29,LPNAM) %FINISH A(RPPTR)=JJ A(RPPTR+1)=KK A(RPPTR+2)=TCELL A(RPPTR+3)=STOREOP A(RPPTR+4)=A(P) RPPTR=RPPTR+6 P=P+1; %IF A(P)=3 %THEN P=P+1 %ELSE SKIP APP %FINISH %IF STOREOP=30 %THEN JJ=99 %ELSE JJ=100 A(RPPTR)=JJ A(RPPTR+1)=BOT-9 RPPTR=RPPTR+3 STOREOP=30; NOPS=NOPS+1 %IF A(P)=1 %THEN P=P+1 %AND ->AGN P=P+1 ETORP(OPHEAD,NOPS,TYPEP) A(RPPTR-3)=99 A(RPPTR-2)=BOT; ! TIC BACK TO LEFTPART LIST ! WHICH IS BACK LINKED ! SO THAT ASSIGNMENTS ARE MADE ! R TO L AS SUBCRIPTS UNSTACKED LP=P EXPOP(OPHEAD,-1,NOPS,TYPEP!16) P=LP RPPTR=RR %RETURN ALT(2): ! PROCEDURE CALL P=P+1 CNAME(0,0) %RETURN ALT(3): ! %GOTO P=P+1 CDE(0) %END %ROUTINE GOTOLAB(%INTEGER MODE) !*********************************************************************** !* GOTO A SIMPLE LAB OR ELEMENT OF SWITCH UNCONDITIONALLY * !* MODE =0 NORMAL GOTO STMNT * !* MODE=1 IF IN THUNKS (IE LABEL PASSED BY NAME) * !* MODE=2 IF IN SWITCH LIST (FAILURES HANDLED DIFFERENTLY) * !* MODE=3 SWITCH BEING PASSED BY NAME * !* MODE=5 AS MODE=1 BUT P HAS BEEN PARSED AS AN EXPRSN * !* THIS IS UNAVOIDABLE IN THE CASE OF ACTUAL PARAMETERS AS * !* BOTH LABELS AND PARAMETERLESS PROCEDURE CAN BE USED * !* WITHOUT BEING DECLARED! * !*********************************************************************** %ROUTINESPEC RESET STACK %INTEGER LNAM, SB, B, D, PP, F, SSN, RANGE, ARRP, LEVELP LNAM=A(P); P=P+1; ! LNAM =LABEL(SWITCH)NAME PP=P COPYTAG(LNAM) RANGE=KFORM; ARRP=ARR; LEVELP=OLDI B=I; D=K SSN=SNDISP<<2 %IF A(P)=2 %THEN F=22 %AND ->ERROR %IF ARRP>=1 %AND MODE#3 %AND A(P)=3 %THEN F=18 %AND ->ERROR %IF TYPE#6 %OR ROUT=1 %THEN F=11 %AND ->ERROR SB=STACKBASE(B) ->SWITCH %IF ARRP>=1; ! SWITCHES ABORT %IF SB<0 %AND B#RLEVEL %AND NAM=0 ! %IF A(P)=1 %THEN F=4 %AND ->ERROR P=P+1 %IF NAM=1 %THEN %START; ! LABEL BY NAME CALL THUNKS(0, -1, B, D) %RETURN %FINISH ! RESET STACK ! ENTER JUMP(15, LNAM, 0) %RETURN ERROR: FAULT(F,LNAM) P=PP; SKIP APP; %RETURN ! SWITCH: ! GOTO SWITCH P=P+1 P=P+1 %UNLESS MODE=3; ! PAST (HOLE) IN P(APP) %IF NAM=1 %THEN %START CSEXP(ACCR, 1, 0) %UNLESS MODE=3 CALL THUNKS(0, -1, B, D); ! CAN NOT RETURN %FINISH %ELSE %START %IF MODE#3 %THEN CSEXP(BREG, 1, 0) %ELSE PF1(ST,0,BREG,0) REGISTER(BREG)=1 SET XNB(-1) PSF1(SBB,0,1); ! ALGOL SWITCHES START AT 1 %IF ARRP=2 %START PSF1(MYB,0,2) RESET STACK PF1(JUNC,3,XNB,SSN); ! USE BOUNDED CODE DESCRIPOR %FINISH %ELSE %START PF1(LB,3,XNB,SSN); ! LB REL DISP OF SW ELMNT PF1(ADB,0,XNB,SSN+4); ! RELOCATE ! ! MUST SET LNB TO EXPECTED VALUE BEFORE BRANCHING INTO THE SWITCH ! CODE. ! %IF B#RLEVEL %THEN PSF1(LLN,1,PTR OFFSET(B)) PF1(JUNC,0,BREG,0) %FINISH REGISTER(BREG)=0; GRUSE(BREG)=0 %FINISH %IF MODE#3 %THEN %START %IF A(P)=1 %THEN F=18 %AND ->ERROR P=P+1 %FINISH %RETURN %ROUTINE RESET STACK %INTEGER I ! ! IF JUMPING OUT OF A BLOCK IT MAY BE NECESSARY TO RESET BLOCK NO ! AND/OR THE TOP OF STACK POINTER ! %IF PARMTRCE=0 %OR B#RLEVEL %OR LEVELP=LEVEL %THEN ->NEXT ! ! IT IS STILL NOT NECESSARY TO RESET DIAG POINTER IF THE ONLY BLOCKS ! BEING LEFT ARE THE HYPOTHETICAL BLOCKS SURROUNDING FOR STMNTS ! %CYCLE I=LEVEL,-1,LEVELP+1 ->RESET %IF FLAG(I)#-3; ! ANYTHING BUT FOR LOOP %REPEAT ->NEXT RESET: PSF1(LD,1,12); ! PLT DESCRIPTOR GRUSE(DR)=0 DIAG POINTER(LEVELP) ! NEXT: DISP=AUXSBASE(LEVELP) %IF DISP#0 %AND(DISP#AUXSBASE(LEVEL) %OR MODE#0) %START AREA=-1; BASE=DISP>>18 DISP=DISP&X'3FFFF' GET IN ACC(ACCR,1,0,AREA CODE,DISP+12) PSORLF1(ST,2,AREA,DISP) %FINISH ! %IF SB>0 %AND(B#RLEVEL %OR MODE#0) %START;! AUTO STACK NEEDS RESETTING PSF1(LLN,1,PTR OFFSET(B)) %UNLESS B=RLEVEL PSF1(LSS,1,SB) PPJ(0,4) %FINISH %END %END %ROUTINE CSDE(%INTEGER MODE) !*********************************************************************** !* COMPILE A SIMPLE DESIGNATIONAL EXPRESSION * !* P:=,'('')' * !* MODE AS FOR ROUTINE GOTOLAB * !*********************************************************************** %INTEGER PP,PLUSALT,OPALT PP=P; P=P+1 %IF MODE#5 %THEN %START %IF A(PP)=2 %THEN CDE(MODE) %ELSE GOTOLAB(MODE) %FINISH %ELSE %START PLUSALT=A(P); OPALT=A(P+1) ->ERROR %UNLESS PLUSALT=3 %AND OPALT#2;! NOT INTEGER CONSTANT P=P+2; ! POINTS TO OPERAND %IF OPALT=3 %THEN CDE(5) %ELSE GOTOLAB(5) ->ERROR %UNLESS A(P)=2; ! NO REST OF EXPRN P=P+1 %FINISH %RETURN ERROR: FAULT(5,0) P=PP; SKIP EXP(0) %END %ROUTINE CDE(%INTEGER MODE) !*********************************************************************** !* COMPILE A DESIGNATIONAL EXPRSSION * !* P:-%IF%THEN%ELSE, * !* MODE AS FOR ROUTINE GOTOLAB * !*********************************************************************** %INTEGER R, PL1, PL2 %IF A(P)=2 %THEN P=P+1 %AND CSDE(MODE) %AND %RETURN P=P+1; CCOND PLABEL=PLABEL-1; PL1=PLABEL ENTER JUMP(MASK, PL1, B'11'); ! ROUND FIRST SDE ON FALSE R=0; CSDE(MODE) PLABEL=PLABEL-1; PL2=PLABEL %IF R#0 %THEN ENTER JUMP(15, PL2, B'11') ENTER LAB(PL1, B'110',LEVEL); ! UNCONDITIONAL AND REPLACE CDE(MODE) ENTER LAB(PL2, B'11',LEVEL); ! CONDITIONAL AND MERGE %END %ROUTINE CCOND !*********************************************************************** !* COMPILES A CONDITION INDEXED BY P AND LEAVES MASK SET UP * !* READY FOR A BRANCH IF FALSE OPERATION * !*********************************************************************** %INTEGER PP, EXPHEAD, NOPS, RR RR=RPPTR; NOPS=0 ETORP(EXPHEAD,NOPS,4) PP=P EXPOP(EXPHEAD,ACCR,NOPS,3) P=PP %IF NEST>=0 %THEN MASK=20 RPPTR=RR %END %ROUTINE CSEXP(%INTEGER REG, MODE, NME) !*********************************************************************** !* COMPILE A SIGNED EXPRESSION TO REGISTER 'REG' IN MODE 'MODE' * !* MODE=1 FOR %INTEGER, =2 REAL, =3 BOOL * !* NME=2 IF EXPRESSION IS A SINGLE NAME, #2 FOR GENUINE EXPRSN * !*********************************************************************** %INTEGER EXPHEAD, NOPS, PP, RR, ENAME, T RR=RPPTR %IF NME=2 %THEN %START; ! EXPRSN (PARAM)IS NAME APP ENAME=A(P) T=TAGS(ENAME) PTYPE=FROM1(T)>>16 %IF PTYPE&7=MODE %THEN CNAME(2,REG) %AND %RETURN %IF PTYPE=SNPT %THEN REDUCE TAG %ELSE TYPE=PTYPE&7 %IF MODE=3 %AND TYPE#3 %THEN FAULT(24, ENAME) %IF MODE<3 %AND TYPE=3 %THEN FAULT(42, ENAME) EXPHEAD=RPPTR A(RPPTR)=PTYPE<<16!2 A(RPPTR+1)=P A(RPPTR+3)=100 RPPTR=RPPTR+6 NOPS=1 %FINISH %ELSE %START NOPS=0 ETORP(EXPHEAD, NOPS, MODE) %FINISH PP=P EXPOP(EXPHEAD, REG, NOPS, MODE) P=PP RPPTR=RR %END %ROUTINE ETORP(%INTEGERNAME HEAD, NOPS, %INTEGER MODE) !*********************************************************************** !* CONVERT EXPRESSION TO REVERSE POLISH * !*********************************************************************** %INTEGER TYPEP, TMODE, BHEAD, EHEAD1, EHEAD2, RR ! ABORT %UNLESS 1<=A(P)<=2 %IF A(P)=2 %THEN %START P=P+1 TORP(HEAD,NOPS,MODE) %FINISH %ELSE %START P=P+1 RR=RPPTR; HEAD=RR; RPPTR=RPPTR+3 %IF MODE>=3 %THEN TMODE=3 %ELSE TMODE=0 ETORP(BHEAD,NOPS,4) TORP(EHEAD1,NOPS,TMODE) TYPEP=PTYPE; EHEAD2=0 ETORP(EHEAD2,NOPS,TMODE) PTYPE=2 %UNLESS TYPEP=1 %IF TMODE=3 %THEN PTYPE=3 A(RR)=99 A(RR+1)=RPPTR A(RPPTR)=PTYPE<<16!4 A(RPPTR+1)=(BHEAD-RPBASE)<<16!(EHEAD1-RPBASE) A(RPPTR+2)=EHEAD2 A(RPPTR+3)=100 RPPTR=RPPTR+6 NOPS=NOPS!X'80000000' ;! SOMETHING NASTY BIT SET %FINISH %END %ROUTINE TORP(%INTEGERNAME HEAD, NOPS, %INTEGER MODE) !*********************************************************************** !* CONVERT THE SIGNED EXPRESSION INDEXED BY P INTO REVERSE * !* POLISH NOTATION. THE REVERSE POLISH LIST IS ADDED TO 'HEAD' * !* WHICH MAY CONTAIN ANOTHER EXPRESSION. THE NUMBER OF OPERATORS * !* IS ADDED TO NOPS. MODE SIGNIFIES :- * !* MODE=1 INTEGER EXPRESSION * !* MODE=2 REAL EXPRESSION * !* MODE=3 BOOLEAN EXPRESSION * !* MODE=4 A COMPARISION * !* MODE=0 INTEGER IF POSIIBLE OTHERWISE REAL * !* N.B. AN INTEGER EXPRESSION IS A SPECIAL CASE OF A REAL EXPRSN * !*********************************************************************** %SWITCH OPERAND(1:12) %INTEGER RPHEAD, PASSHEAD, SAVEHEAD, RPBOT, PASSBOT, SAVEBOT, %C REAL, BOOL, OPSEEN, COMPLEX, OPERATOR, OPPREC, OPND, C, D, %C PP, RPTYPE, RPINF, XTRA, OPMASK, OPSTK, OPPSTK %CONSTINTEGERARRAY OPINF(1:12)=X'519'(2),X'30F', X'310',X'413',X'415',X'414', X'519',X'416',X'312',X'217',X'111' ! OPINF IS THE PRECEDENCE<<8!EXPOP SWITCH VALUE OF ALT OF P OPSTK=0; OPPSTK=0; PASSHEAD=0; RPHEAD=0; OPSEEN=0 SAVEHEAD=0; REAL=0; OPMASK=0; BOOL=0 RPBOT=0; SAVEBOT=0; PASSBOT=0 PP=P; HEAD=RPPTR %IF MODE=3 %OR MODE=4 %THEN BOOL=8 NEXTB: P=P+1; ! PAST HOLE C=A(P) %IF 2=C %AND BOOL=0 %THEN %START;! INITIAL '-' OPMASK=1<<21 NOPS=NOPS+1; OPSEEN=1 OPSTK=11; OPPSTK=3 %FINISH %IF BOOL#0 %AND C=1 %START OPMASK=OPMASK!1<<22 NOPS=NOPS+1; OPSEEN=1 %WHILE 5<=OPPSTK&31 %CYCLE A(RPPTR)=OPSTK&31 RPPTR=RPPTR+3 OPSTK=OPSTK>>5; OPPSTK=OPPSTK>>5 %REPEAT OPSTK=OPSTK<<5!10; OPPSTK=OPPSTK<<5!5 %FINISH NEXTOPND: OPND=A(P+1); P=P+2 COMPLEX=0; XTRA=0 ->OPERAND(BOOL+OPND); ! SWITCH ON OPERAND OPERAND(1): ! NAME OPERAND(10): ! BOOLEAN NAME C=A(P) D=TAGS(C); PTYPE=FROM1(D)>>16 %IF PTYPE=0 %THEN PTYPE=7; ! NAME NOT SET GIVES 0 %IF PTYPE=SNPT %THEN PTYPE=X'1000'+TSNAME(FROM3(D)>>16) TYPE=PTYPE&7 %IF PTYPE&X'FFF0'#0 %OR PARMCHK=1 %THEN COMPLEX=1 %IF PTYPE&X'F000'#0 %THEN OPMASK=OPMASK!X'80000000' ! SET SOMETHING NASTY BIT FOR RTS %IF ADFLAG#0 %START REDUCE TAG %IF OLDI=LEVEL %AND SNDISP#M'FP' %THEN FAULT(27,C) %FINISH %IF TYPE=2 %THEN REAL=1 RPTYPE=2; RPINF=P %IF BOOL=0 %THEN %START %IF PTYPE=7 %THEN PTYPE=1 %AND UNPACK %IF TYPE>=3 %THEN %START FAULT(42,C) RPTYPE=0; PTYPE=1 %FINISH %FINISH %ELSE %START %IF PTYPE=7 %THEN PTYPE=3 %AND UNPACK %IF TYPE#3 %THEN %START FAULT(24,C) RPTYPE=0; PTYPE=3 %FINISH %FINISH P=P+1 %IF A(P)=3 %THEN P=P+1 %ELSE SKIP APP; P=P+1 INS: A(RPPTR)=PTYPE<<16!COMPLEX<<8!RPTYPE A(RPPTR+1)=RPINF A(RPPTR+2)=XTRA RPPTR=RPPTR+3 ->OP OPERAND(2): ! CONSTANT C=A(P); RPTYPE=1 %IF C=2 %THEN %START; ! REAL CONSTANT PTYPE=2; RPINF=A(P+1) XTRA=A(P+2) P=P+4 REAL=1 %FINISH %ELSE %START D=A(P+1) %IF D>>17=0 %THEN RPTYPE=0 RPINF=D P=P+3; PTYPE=1 %FINISH; ->INS OPERAND(9): ! (EXPR)(COMP)(EXPR) ETORP(PASSHEAD,NOPS,0) RPPTR=RPPTR-3 C=A(P); P=P+1 %IF C>7 %THEN C=C-7; ! MAP ECMA FORM ONTO IMP FORM ETORP(SAVEHEAD,NOPS,0) ! ! OPTIMISE SIMPLE CONDITIONS HERE ! %IF MODE=4 %AND OPSEEN=0 %AND A(P)=2 %THEN D=27 %ELSE D=26 A(RPPTR-3)=D; A(RPPTR-2)=C; ! COMPARAISON & COMPARATOR P=P+1; ->OP OPERAND(11): ! BOOLEAN CONSTANT C=A(P); P=P+2; ! 0=FALSE -1=TRUE PTYPE=3; RPTYPE=0 RPINF=C-2; ->INS OPERAND(3): ! SUB EXPRESSION OPERAND(12): ! SUB EXPRESSION ETORP(PASSHEAD,NOPS,3*(BOOL>>3)) RPPTR=RPPTR-3 REAL=1 %IF TYPE=2 P=P+1 OP: ! DEAL WITH OPERATOR ->EOE %IF A(P-1)=2; ! EXPR FINISHED OPERATOR=A(P) ! OPPREC=OPINF(OPERATOR+BOOL) OPERATOR=OPPREC&63 %IF OPERATOR=21 %THEN REAL=1 OPPREC=OPPREC>>8 OPMASK=OPMASK!1<<(OPERATOR+5) NOPS=NOPS+1; OPSEEN=1 ! ! UNLOAD THE OPERATOR STACK OF ALL OPERATORS WHOSE PRECEDENCE IS ! NOT LOWER THAN THE CURRENT OPERATOR. AN EMPTY STACK GIVES'-1' ! AS PRECEDENCE. ! %WHILE OPPREC<=OPPSTK&31 %CYCLE A(RPPTR)=OPSTK&31 RPPTR=RPPTR+3 OPSTK=OPSTK>>5; OPPSTK=OPPSTK>>5 %REPEAT ! ! THE CURRENT OPERATOR CAN NOW BE STORED ! OPSTK=OPSTK<<5!OPERATOR; OPPSTK=OPPSTK<<5!OPPREC ->NEXTOPND %IF BOOL=0; ->NEXTB EOE: ! END OF EXPRESSION %WHILE OPSTK#0 %CYCLE A(RPPTR)=OPSTK&31 RPPTR=RPPTR+3 OPSTK=OPSTK>>5 %REPEAT A(RPPTR)=100 RPPTR=RPPTR+3 %IF BOOL#0 %THEN PTYPE=3 %ELSE PTYPE=1+REAL TYPE=PTYPE %IF REAL=1 %THEN OPMASK=OPMASK!1<<26;! REALS CANNOT BE EVALUATED IN B NOPS=NOPS!OPMASK %END %ROUTINE EXPOP(%INTEGER INHEAD, REG, NOPS, MODE) !*********************************************************************** !* EVALUATE A LIST OF OPERAND AND'NOPS' OPERATORS AND LEAVE * !* THE RESULT IN REG * !* INHEAD HOLDS THE LIST THE BOTTOM BYTE OF STREAM 1 DEFINES THE * !* ENTRY AS FOLLOWS:- * !* 0 = SHORT (INTEGER) CONSTANT <18 BITS --S2=CONSTANT * !* 1 = OTHER CONSTANT S2 (+S3 IF NEEDED) = CONSTANT * !* 2 = VARIABLE S2 POINT TO AR ENTRY FOR NAME&SUBSCRIPTS * !* (3 = DOPE VECTOR ITEM IF NEEDED) * !* (4 = CONDITONAL EXPRESSION AS IN ALGOL) * !* 7 = INTERMEDIATE RESULT UNDER LNB S2=DISPLCMNT FROM LNB * !* 8 = INTERMEDIATE RESULT STACKED * !* 9 = INTERMEDIATE RESULT IN A REGISTER S2 = REG * !* * !* 10-19 = UNARY OPERATOR S2=OP S3 =EXTRA * !* 20 UP = BINARY OPERATOR * !* * !* ARRAY MCINST HOLD THE OPCODES CORRESPONDING TO THE OPERATORS:- * !* TOP BYTE = REAL FORWARD FORM * !* 2ND BYTE = REAL REVERSE FORM * !* 3RD BYTE = INTEGER FORWARD FORM * !* BTM BYTE = INTEGER REVERSE FORM * !*********************************************************************** %INTEGERARRAY OPERAND(1:2),STK(0:99) %RECORDNAME OPND1, OPND2, OPND3(RD) %INTEGER C, D, KK, JJ, OPCODE, COMM, XTRA, STPTR, RDFORM, EVALREG, %C NEWCC, PP, PT, JJJ, LOADREG %ROUTINESPEC FLOAT(%INTEGER OP) %ROUTINESPEC TYPE CHK(%INTEGER MODE) %ROUTINESPEC FIX(%INTEGER OP, MODE) %ROUTINESPEC CTOP(%INTEGERNAME A) %ROUTINESPEC CHOOSE(%INTEGERNAME I) %ROUTINESPEC PUT %ROUTINESPEC STARSTAR %ROUTINESPEC REXP %ROUTINESPEC LOAD(%INTEGER OP, REG, MODE) %CONSTINTEGERARRAY MCINST(10:32)=X'8E8E',X'F4F4E4E4',0(3), X'F0F0E0E0',X'F2F4E2E4', X'8E8E',X'8C8C',X'FAFAEAEA', X'AAAC',X'BABC0000',X'8A8A', X'8C00',0,X'FA00EA00', X'F6F6E6E6'(2),X'2C002C00', X'02000200',X'48004800'(3); %CONSTBYTEINTEGERARRAY FCOMP(1:28)=%C 8,10,2,7,12,4,7, 8,12,4,7,10,2,7, 16,34,17,32,33,18,32, 16,33,18,32,34,17,32; %SWITCH SW(10:32) STPTR=0; RDFORM=MODE&16 NEWCC=0 EVALREG=ACCR %IF REG=BREG %AND NOPS&X'FEE00000'=0 %THEN %C EVALREG=BREG %IF REG=BREG#EVALREG %AND REGISTER(BREG)>0 %THEN BOOTOUT(BREG) NEXT: C=A(INHEAD) XTRA=A(INHEAD+1) %IF C=99 %THEN INHEAD=XTRA %AND ->NEXT; ! 99=TIC JJ=C&255; D=INHEAD INHEAD=INHEAD+3 ->FINISH %IF C=100 ->OPERATOR %IF 10<=JJ ! ! ANY OPERAND WHICH MAY NEED DR OR B OR ACC IN THEIR EVALUATION ! EG FUNCTIONS,ARRAY ELEMENTS ETC ARE FETCHED AND STACKKED FIRST ! OPERAND(1)=ADDR(A(D)) OPND1==RECORD(OPERAND(1)) %IF (OPND1_FLAG=2 %AND OPND1_XB#0) %OR OPND1_FLAG=4 %START JJ=EVALREG %IF JJ=BREG %AND REGISTER(ACCR)=1 %THEN JJ=ACCR LOAD( 1,JJ,0) %FINISH STK(STPTR)=OPERAND(1); STPTR=STPTR+1 ABORT %IF STPTR>99 ANYMORE: ->NEXT %UNLESS C=100 ->FINISH OPERATOR: %IF JJ<15 %THEN KK=1 %ELSE KK=2; ! UNARY OR BINARY %CYCLE KK=KK,-1,1 STPTR=STPTR-1 C=STK(STPTR) OPERAND(KK)=C %REPEAT OPCODE=MCINST(JJ) COMM=1 %IF JJ>14 %AND OPCODE&X'00FF00FF'#0 %THEN CHOOSE(COMM) OPND1==RECORD(OPERAND(COMM)) OPND2==OPND1 %IF JJ>=15 %THEN OPND2==RECORD(OPERAND(3-COMM)) %IF OPND1_FLAG<2>OPND2_FLAG %THEN CTOP(JJ) ->STRES %IF JJ=0; ! CTOP CARRIED OUT %IF OPND1_PTYPE&7#OPND2_PTYPE&7 %AND %C (JJ=15 %OR JJ=16 %OR JJ=19 %OR 26<=JJ<=27 %OR 30<=JJ<=31) %C %THEN TYPE CHK((JJ+2)>>5) ->SW(JJ) SW(10): ! \ LOAD(1,EVALREG,2) PSF1(NEQ,0,-1) GRUSE(ACCR)=0 ! ABORT %UNLESS EVALREG=ACCR SUSE: OLINK(EVALREG)=OPERAND(COMM) STRES: STK(STPTR)=OPERAND(COMM); STPTR=STPTR+1 ->NEXT SW(11): ! NEGATE ! OPMASK STOPS US EVER GETTING HERE WITH EVALREG=BREG (PDS HOPES) LOAD(1,EVALREG,2) %IF TYPE=2 %THEN OPCODE=OPCODE>>16 PSF1(OPCODE&255,0,0); ! IRSB 0 OR RRSB 0 GRUSE(ACCR)=0 ! ABORT %UNLESS EVALREG=ACCR ->SUSE SW(12): !ENTER LAB LOAD(1,EVALREG,2) %IF XTRA>>16#0 ENTERLAB(XTRA&X'FFFF',0,LEVEL) ->SUSE SW(13): ! ENTIER %IF OPND1_PTYPE&7=1 %THEN FLOAT(1) FIX(1,XTRA); ->SUSE SW(14): ! SIGN LOAD(1,EVALREG,2) %IF TYPE=2 %THEN C=63 %AND D=0 %ELSE C=31 %AND D=4 PF3(JAT,D,0,5); ! SIGN(0)=0 PSF1(USH,0,-C) PSF1(USH,0,1) PSF1(IRSB,0,1) GRUSE(ACCR)=0 %IF TYPE=2 %THEN %START %IF REGISTER(BREG)=0 %THEN PF1(STUH,0,BREG,0) %AND %C GRUSE(BREG)=0 %ELSE PSF1(MPSR,0,17) %FINISH OPND1_PTYPE=1; OPND1_XB=ACCR<<4 OPND1_FLAG=9; OPND1_D=0 ! ABORT %UNLESS EVALREG=ACCR ->SUSE SW(15): ! ADD BINOP: LOAD(COMM,EVALREG,2) %UNLESS %C OPND1_FLAG=9 %AND OPND1_XB>>4=EVALREG LOAD(3-COMM,EVALREG,1) %IF OPND2_FLAG<=4 PUT; ->SUSE %UNLESS JJ=17 PSF1(NEQ,0,-1) ->SUSE SW(16): ! SUBTRACT ->BINOP SW(17): ! EXCLUSIVE OR SW(18): ! OR SW(22): ! AND ->BINOP %IF OPND1_PTYPE&7=3=OPND2_PTYPE&7 FAULT(24,0) F25: JJ=15; OPCODE=MCINST(15); ->BINOP; ! CHANGE OPN TO + F26: FAULT(26,0); ->F25 SW(23): ! %IMPLIES LOAD(1,EVALREG,2) PSF1(NEQ,0,-1) SW(24): ! SLL SW(19): ! MULT ->BINOP SW(20): ! INTEGER DIVISION ->F26 %UNLESS OPND1_PTYPE&7=1=OPND2_PTYPE&7 ->BINOP SW(21): ! NORMAL DIVISION TYPE CHK(2); ->BINOP SW(25): ! EXP %IF OPND2_PTYPE=1 %AND OPND2_FLAG<=1 %AND OPND2_D>0 %C %THEN STARSTAR %AND ->SUSE %IF OPND1_PTYPE&7=1 %THEN FLOAT(1) %IF OPND2_PTYPE&7=1 %THEN STARSTAR %AND ->SUSE REXP; COMM=2; ->SUSE SW(26): ! COMPARISON TO BOOLEAN CONVERSION SW(27): ! COMPARISONS ->Z1 %IF OPND1_FLAG<=1 %AND OPND1_D=0 %AND JJ=27 ->Z2 %IF OPND2_FLAG<=1 %AND OPND2_D=0 %AND JJ=27 LOAD(COMM,EVALREG,2) LOAD(3-COMM,EVALREG,1) %IF JJ=26 %THEN %START PUT PSF1(LSS,0,0) GRUSE(ACCR)=0; LOADREG=ACCR %FINISH %ELSE %START PUT; LOADREG=-1 %FINISH MASK=REVERSE(FCOMP(XTRA+7*(COMM-1))) REGISTER(EVALREG)=0 %IF LOADREG=-1 %THEN NEST=-1 %AND %RETURN PF3(JCC,MASK,0,3) PSF1(LSS,0,-1) OPND1_PTYPE=3; OPND1_XB=ACCR<<4 OPND1_FLAG=9; OPND1_D=0 TYPE=3 REGISTER(ACCR)=1 ->SUSE Z1: C=3-COMM; ->Z3 Z2: C=COMM Z3: LOAD(C,ACCR,2) MASK=REVERSE(FCOMP(XTRA+7*COMM+7)) %IF TYPE=1 %THEN MASK=MASK+4 NEST=-1; REGISTER(ACCR)=0 %RETURN SW(28): ! SPECIAL MH FOR ARRAY ACCESS C=OPND2_D>>16; ! CURRENT DIMENSION D=OPND2_D&31; ! TOTAL NO OF DIMENSIONS %IF OPND1_FLAG=9 %AND OPND1_XB>>4=ACCR %THEN %START PF1(ST,0,TOS,0); ! ACC CANNOT BE USED IN DVM CHANGE RD(ACCR) REGISTER(ACCR)=0 %FINISH ! %IF C=D %THEN %START; ! TOP DIMENSION LOAD DV DES BASE=OPND2_XTRA>>18; AREA=-1 GET IN ACC(DR,2,0,AREA CODE,OPND2_XTRA&X'1FFFF'+8) %FINISH ! LOAD(1,EVALREG,0) AREA=OPND1_XB>>4; ACCESS=OPND1_XB&15 %IF C=D %AND REGISTER(BREG)>=1 %AND %C (OPND1_FLAG#9 %OR AREA#BREG) %THEN %START OPND3==RECORD(OLINK(BREG)) OPND3_D=0 REGISTER(BREG)=2 BOOT OUT(BREG) %FINISH ! ! TWO DIMENSIONAL UNCHECKED ARRAYS AVOID VMY ON FIRST DIMENSION WHERE ! THEMULTIPLIER IS 1. THE AVOIDS HAVING TO COPY BTO ACC ! %IF C=1 %AND D=2 %AND PARMARR=0 %START PF1(SBB,2,7,0) %UNLESS XTRA=2;! DR POINTS AT LB OPCODE=ADB<<8 %FINISH ACCESS=OPND1_XB&15; AREA=OPND1_XB>>4 PSORLF1(OPCODE>>8&255,ACCESS,AREA,OPND1_D) GRUSE(BREG)=0 ! %IF D=1 %OR(D=2 %AND PARMARR=0) %THEN LOADREG=BREG %C %ELSE %START LOADREG=ACCR %IF C=D %THEN GET IN ACC(ACCR,1,0,7,0) %ELSE %C PF1(IAD,0,BREG,0) %IF C=1 %THEN %START PF1(ST,0,BREG,0) REGISTER(ACCR)=0 LOADREG=BREG %FINISH %FINISH REGISTER(LOADREG)=1 OPND1_FLAG=9; OPND1_XB=LOADREG<<4 OLINK(LOADREG)=OPERAND(COMM) %IF C=1 %THEN ->STRES ->ANYMORE SW(29): ! ->LAB MASKS AND LAB AS OPND2 ABORT SW(30): ! ASSIGN(=) SW(31): ! ASSIGN(WITH MVC ALLOWED) PP=OPND2_D; ! SAVE POINTER TO NAME PT=OPND2_PTYPE; ! AND ITS ORIGINAL PTYPE D=OPND2_FLAG; ! SAVE NAME OR R-DESCRPTOR LOAD(1,ACCR,2) %UNLESS OPND1_FLAG=9 %AND OPND1_XB>>4=ACCR %IF D=2 %THEN %START; ! RHS= A NAME %IF OPND2_PTYPE<=3 %AND OPND2_UPTYPE=0 %START D=FROM3(OPND2_XTRA)>>16 AREA=-1; C=0 BASE=FROM1(OPND2_XTRA)>>4&15 %IF BASE=RLEVEL %THEN JJJ=LNB %ELSE JJJ=AREA CODE %FINISH %ELSE %START P=PP; CNAME(1,0) D=DISP; C=ACCESS %IF AREA<0 %THEN AREA=AREA CODE;! ONLY NEEDED FOR BUM LHS JJJ=AREA %FINISH %FINISH %ELSE %START; ! LHS A FUNCTION DESIGNATOR D=PP; C=0; BASE=OPND2_XB AREA=-1; JJJ=AREA CODE %FINISH LOAD(1,ACCR,2) %UNLESS OPND1_FLAG=9 PSORLF1(ST,C,JJJ,D) %IF OPND2_FLAG=2 %THEN NOTE ASSMENT(ACCR,A(PP)) %ELSE %C SET USE(ACCR,10,XTRA); ! NOTE FN RESULT %IF JJ=31 %THEN REGISTER(EVALREG)=0 COMM=1; ->SUSE SW(32): ! ARRAY ASSNMT XTRA=ARRNAME C=TAGS(XTRA) D=FROM1(C); ! XTRA=LPNAME JJJ=D>>4&15; D=D>>16&15; ! D=TYPE : JJJ=I C=FROM3(C)>>16; ! C=K %IF D=2 %AND OPND1_PTYPE&7=1 %THEN FLOAT(1) %IF D=1 %AND OPND1_PTYPE&7=2 %THEN FIX(1,0) LOAD(1,ACCR,2) %UNLESS OPND1_FLAG=9 %AND OPND1_XB>>4=ACCR;! RHS %IF GRUSE(DR)=7 %AND GRINF(DR)=XTRA %START %IF 7<=OPND2_FLAG<=8 %START ACCESS=1 %IF OPND2_FLAG=7 %THEN AREA=LNB %AND DISP=OPND2_D %C %ELSE AREA=TOS %AND DISP=0 %FINISH %ELSE %START LOAD(2,BREG,2) %UNLESS OPND2_FLAG=9 %AND OPND2_XB>>4=BREG ACCESS=3; AREA=7; DISP=0 %FINISH PF1(ST,ACCESS,AREA,DISP) %FINISH %ELSE %START LOAD(2,BREG,2) %UNLESS OPND2_FLAG=9 %AND OPND2_XB>>4=BREG;! SUBSCRIPT EXP TO B AREA=-1; BASE=JJJ %IF BASE=RLEVEL %THEN AREA=LNB %ELSE AREA=AREA CODE PF1(ST,3,AREA,C) %FINISH REGISTER(BREG)=0 GRUSE(DR)=7; GRINF(DR)=XTRA COMM=1; ->STRES FINISH: C=STK(STPTR-1) OPERAND(1)=C OPND1==RECORD(C) %IF OPND1_PTYPE&7=1 %AND MODE=2 %THEN FLOAT(1) %IF OPND1_PTYPE&7=2 %AND MODE=1 %THEN FIX(1,0) LOAD(1,REG,2) %UNLESS%C RDFORM#0 %OR(OPND1_FLAG=9 %AND OPND1_XB>>4=REG) PTYPE=OPND1_PTYPE TYPE=PTYPE&7 NEST=-1 %IF OPND1_FLAG=9 %THEN %START NEST=OPND1_XB>>4 REGISTER(NEST)=0 %FINISH %RETURN ! %ROUTINE CHOOSE(%INTEGERNAME CHOICE) %INTEGER X1 %RECORDNAME OPND1, OPND2(RD) OPND1==RECORD(OPERAND(1)) OPND2==RECORD(OPERAND(2)) X1=OPCODE %IF OPND1_PTYPE&7=2 %OR OPND2_PTYPE&7=2 %THEN X1=X1>>16 CHOICE=1 CHOICE=2 %IF X1>>8=0 %OR (X1&255#0 %AND OPND2_FLAG=9) %END %ROUTINE LOAD(%INTEGER OP, REG, MODE) !*********************************************************************** !* LOAD OPERAND TO REGISTER CONDITIONALLY * !* MODE=0 LEAVE IN STORE IF POSSIBLE * !* MODE=1 LEAVE IN STORE IF SUITABLE FOR RX INSTRUCTIONS * !* MODE=2 LOAD TO REGISTER REGARDLESS * !*********************************************************************** %INTEGER J, K, C, D, HEAD1, HEAD2 %RECORDNAME OPND(RD) %SWITCH SW(0:9) OPND==RECORD(OPERAND(OP)) PTYPE=OPND_PTYPE; TYPE=PTYPE&7 K=OPND_FLAG ->SW(K) %IF MODE=2 %OR 2<=K<=4 %OR (K<2 %AND MODE=1) %RETURN SW(0):LITCONST: ! CONSTANT < 18 BITS AREA=0; ACCESS=0 DISP=OPND_D %IF MODE=2 %THEN %START; ! FETCH TO REG %IF GRUSE(REG)=5 %AND GRINF(REG)=DISP %AND TYPE=1 %START %IF REGISTER(REG)#0 %THEN BOOT OUT(REG) %FINISH %ELSE GETINACC(REG,BYTES(TYPE)>>2,ACCESS,AREA,DISP) %IF TYPE=1 %THEN GRUSE(REG)=5 %AND GRINF(REG)=DISP ->LDED %FINISH OPND_FLAG=7; OPND_XB=AREA<<4!ACCESS OPND_D=DISP %RETURN SW(1): ! LONG CONSTANT %IF OPND_D=0=OPND_XTRA %THEN ->LITCONST %IF TYPE=1 %AND IMOD(OPND_D)>>17=0 %THEN ->LITCONST STORE CONST(DISP,BYTES(TYPE),OPND_D,OPND_XTRA) %IF MODE#2 %START OPND_FLAG=7; OPND_XB=PC<<4 OPND_D=DISP; %RETURN %FINISH %IF GRUSE(REG)=6 %AND GRINF(REG)=DISP %START %IF REGISTER(REG)#0 %THEN BOOT OUT(REG) %FINISH %ELSE GETINACC(REG,BYTES(TYPE)>>2,0,PC,DISP) GRUSE(REG)=6; GRINF(REG)=DISP ->LDED SW(2): ! NAME P=OPND_D -> LOAD %IF MODE=2 %OR OPND_XB#0;! COMPLEX NAMES MUST BE LOADED CNAME(5,REG) ->LDED %IF NEST>=0 OPND_PTYPE=PTYPE OPND_FLAG=7 OPND_XB=AREA<<4!ACCESS OPND_D=DISP; %RETURN LOAD: CNAME(2,REG) LDED: REGISTER(REG)=1; ! CLAIM THE REGISTER OLINK(REG)=ADDR(OPND) OPND_FLAG=9; OPND_D=0; OPND_XB=REG<<4; %RETURN SW(4): ! CONDITIONAL EXPRSSN C=TYPE HEAD1=OPND_D>>16+RPBASE HEAD2=OPND_D&X'FFFF'+RPBASE SAVEIRS EXPOP(HEAD1,ACCR,2,3) %IF NEST>=0 %THEN MASK=20 PLABEL=PLABEL-1; J=PLABEL ENTER JUMP(MASK,J,B'11') EXPOP(HEAD2,REG,2,C) %IF REG>=0 %THEN D=REG %ELSE D=NEST PLABEL=PLABEL-1 ENTER JUMP(15,PLABEL,B'11') HEAD1=OPND_XTRA ENTER LAB(J,B'111',LEVEL) J=PLABEL EXPOP(HEAD1,D,2,C) ENTER LAB(J,B'11',LEVEL) GRUSE(D)=0; OLINK(REG)=ADDR(OPND) OPND_PTYPE=C; REGISTER(D)=1 OPND_FLAG=9; OPND_XB=REG<<4 OPND_D=0; %RETURN SW(7): ! I-R IN A STACK FRAME AREA=LNB ACCESS=0 DISP=OPND_D PICKUP: GET IN ACC(REG,BYTES(TYPE)>>2,ACCESS,AREA,DISP) ->LDED SW(8): ! I-R THAT HAS BEEN STACKED AREA=TOS; ACCESS=0; DISP=0; ->PICK UP SW(9): ! I-R IN A REGISTER %IF OPND_XB>>4=REG %THEN ->LDED %IF REG#ACCR %THEN %START BOOTOUT(BREG) %IF REGISTER(BREG)#0 PF1(ST,0,BREG,0) GRUSE(BREG)=GRUSE(ACCR) GRINF(BREG)=GRINF(ACCR) %FINISH %ELSE %START GET IN ACC(ACCR,1,0,7,0) GRUSE(ACCR)=GRUSE(BREG) GRINF(ACCR)=GRINF(BREG) %FINISH REGISTER(OPND_XB>>4)=0 OPND_XB=REG<<4 REGISTER(REG)=1; OLINK(REG)=OPERAND(OP) %END %ROUTINE PUT !*********************************************************************** !* THIS ROUTINE PLANTS CODE TO PERFORM THE BASIC * !* OPERATION DEFINED BY OPND1,OPND2 & OPCODE * !*********************************************************************** %INTEGER CODE CODE=OPCODE %IF OPND2_PTYPE&7=2 %THEN CODE=CODE>>16 %IF COMM=1 %THEN CODE=CODE>>8 CODE=CODE&255 !QOUT; ABORT %UNLESS OPND1_FLAG=9 %IF EVALREG=BREG %THEN CODE=CODE-X'C0' AREA=OPND2_XB>>4 ACCESS=OPND2_XB&15 DISP=OPND2_D PSORLF1(CODE,ACCESS,AREA,DISP) GRUSE(EVALREG)=0 %UNLESS JJ=27 OLINK(EVALREG)=OPERAND(COMM) %END %ROUTINE CTOP(%INTEGERNAME FLAG) !*********************************************************************** !* THIS ROUTINE IS CALLED WHEN AN EXPRESSION OPERATION IS FOUND * !* BETWEEN TWO CONSTANTS. SOME OPERATIONS ARE INTERPRETED * !* ON EXIT FLAG=0 %IF OPERATION CARRIED OUT * !*********************************************************************** %INTEGER VAL1, VAL2, TYPEP, OP %LONGREAL RVAL1, RVAL2, X %SWITCH SW(10:28) NEWCC=0; !COMPILE TIME OPS CAN NOT SET CC OP=FLAG TYPEP=OPND1_PTYPE!OPND2_PTYPE %RETURN %IF OP>28 %OR TYPEP>=3 %IF OPND1_PTYPE=2 %THEN %START INTEGER(ADDR(RVAL1))=OPND1_D INTEGER(ADDR(RVAL1)+4)=OPND1_XTRA %IF MOD(RVAL1)SW(OP) INTEND: FLAG=0; OPND1_PTYPE=1 %IF 0<=VAL1<=4095 %THEN OPND1_FLAG=0 %ELSE OPND1_FLAG=1 OPND1_D=VAL1 %RETURN SW(11): ! NEGATE %IF TYPEP=1 %THEN VAL1=-VAL1 %AND ->INT END RVAL1=-RVAL1; ->REAL END SW(13): ! ENTIER %RETURN %IF MOD(RVAL1)>IMAX; ! TOO BIG VAL1=INT(RVAL1); ->INT END REAL END: OPND1_FLAG=1 OPND1_D=INTEGER(ADDR(RVAL1)) OPND1_XTRA=INTEGER(ADDR(RVAL1)+4) FLAG=0; OPND1_PTYPE=2 %RETURN SW(14): ! SIGN VAL1=0 %IF RVAL1>0 %THEN VAL1=1 %IF RVAL1<0 %THEN VAL1=-1 ->INTEND SW(15): ! ADD %IF TYPEP=1 %THEN VAL1=VAL1+VAL2 %AND ->INT END RVAL1=RVAL1+RVAL2; ->REAL END SW(16): ! MINUS %IF TYPEP=1 %THEN VAL1=VAL1-VAL2 %AND ->INT END RVAL1=RVAL1-RVAL2; ->REAL END SW(19): ! MULT SW(28): ! ARRAY BOUND MULT %IF TYPEP=1 %THEN VAL1=VAL1*VAL2 %AND ->INT END RVAL1=RVAL1*RVAL2; ->REAL END SW(21): ! REAL DIVISION %RETURN %IF RVAL2=0; ! AVOID DIV BY ZERO RVAL1=RVAL1/RVAL2; ->REAL END SW(20): ! '%DIV' DIVISION %RETURN %IF VAL2=0 %OR TYPEP#1 VAL1=VAL1//VAL2; ->INT END SW(25): ! EXP %RETURN %IF RVAL1<=0 %IF TYPEP=1 %AND 32>VAL2>0 %THEN %START X=RVAL1**VAL2 %IF MOD(X)>IMAX %THEN %RETURN VAL1=INT(X); ->INT END %FINISH %IF OPND2_PTYPE=1 %AND 63>IMOD(VAL2) %C %THEN RVAL1=RVAL1**VAL2 %AND ->REAL END SW(10): SW(12): SW(17): SW(18): SW(22): SW(23): SW(24): SW(26): SW(27): %END %ROUTINE FLOAT(%INTEGER OP) !*********************************************************************** !* PLANT CODE TO CONERT OPERAND1 FROM FIXED TO FLOATING * !*********************************************************************** %RECORDNAME OPND1(RD) OPND1==RECORD(OPERAND(OP)) %IF OPND1_FLAG<=1 %THEN %START CVALUE=OPND1_D OPND1_D=INTEGER(ADDR(CVALUE)) OPND1_XTRA=INTEGER(ADDR(CVALUE)+4) OPND1_FLAG=1 %FINISH %ELSE %START LOAD(OP,ACCR,2) PSF1(FLT,0,0) GRUSE(ACCR)=0 %FINISH OPND1_PTYPE=2 TYPE=2 %END %ROUTINE TYPE CHK(%INTEGER MODE) !*********************************************************************** !* MODE=0 ARITHMETIC := MAKE BOTH REAL UNLESS BOTH INTEGER * !* MODE=1 ASSIGNMENT := FORCE OPERAND1 TO TYPE OF OPERAND 2 * !* MODE=2 REAL DIVISION := MAKE BOTH REAL * !*********************************************************************** %INTEGER PT1,PT2 PT1=OPND1_PTYPE&7 PT2=OPND2_PTYPE&7 %IF MODE#2 %AND PT1=1=PT2 %THEN %RETURN %IF MODE=1 %THEN %START %IF PT2=1 %AND PT1=2 %THEN FIX(COMM,0) %AND %RETURN %FINISH %ELSE %START %IF PT2=1 %THEN FLOAT(3-COMM) %FINISH %IF PT1=1 %THEN FLOAT(COMM) %END %ROUTINE FIX(%INTEGER OP, MODE) !*********************************************************************** !* PLANT CODE TO CONVERT OPERAND TO FIXED POINT FORM * !* CODE PLANTED IS AS FOR THE IMP ROUTINE 'INT' * !* MODE =0 FOR ROUNDING * !* MODE #0 FOR TRUNCATION * !*********************************************************************** %INTEGER CAREA %RECORDNAME OPND(RD) CAREA=PLABS(1); ! ADDRESS OF CONSTANT AREA OPND==RECORD(OPERAND(OP)) %IF OPND_FLAG=1 %THEN %START INTEGER(ADDR(CVALUE))=OPND_D INTEGER(ADDR(CVALUE)+4)=OPND_XTRA %IF MOD(CVALUE)>16 OPCODE=(OPCODE>>8)&255 VALUE=0 %IF OPND2_FLAG=0 %AND 1<=OPND2_D<=63*TYPE %THEN %C VALUE=OPND2_D; ! EXPONENT IS #0 AND CONSTANT LOAD(1,ACCR,2); ! FETCH OPERAND TO ACC ! ! OPTIMISE **2 **3 AND **4 ! %IF 2<=VALUE<=4 %THEN %START PF1(ST,0,TOS,0) %IF VALUE=3 %THEN PF1(ST,0,TOS,0) PF1(OPCODE,0,TOS,0) %IF VALUE=4 %THEN PF1(ST,0,TOS,0) %IF VALUE>2 %THEN PF1(OPCODE,0,TOS,0) GRUSE(ACCR)=0 %RETURN %FINISH ! ! OTHERWISE STORE OPERAND IN 'WORK' AND GET HOLD OF EXPONENT ! GET WSP(WORK,BYTES(TYPE)>>2) %IF TYPEP=2 %THEN GET WSP(EXPWORK,1) PSF1(ST,1,WORK) PLABEL=PLABEL-1; ! LABEL FOR JUMPING OUT LOAD(2,BREG,2); ! EXPONENT TO ANY REGISTER PF3(JAF,12,0,4); ! J (B#0) ROUND NEXT JUMP PPJ(16,7); ! 0**0 IS ERROR IN ALGOL %IF TYPEP=2 %THEN PSF1(STB,1,EXPWORK) ! ! GET '1' INTO ACC IN APPROPIATE FORM ! %IF TYPEP=1 %THEN PSF1(LSS,0,1) %ELSE %C PF1(X'60',0,PC,PLABS(1)+8); ! LD(E) WORK,=D'1' ! ! IF EXPONENT NOT KNOWN AT COMPILE TIME TO BE +VE CONSTANT MUST ! ALLOW FOR ZERO :- XX**0=1 FOR ALL XX ! ALSO ALLOW FOR X**(-N) WHICH IS 1/(X**N) FOR ALL X & N ! %IF VALUE=0 %THEN %START; ! NOT +VE CONSTANT ENTER JUMP(28,PLABEL,B'11'); ! J(B=0) END OF EXP ROUTINE %IF TYPEP=2 %THEN %START PF3(JAT,13,0,4); ! J*+4 IF B>0 PSF1(SLB,0,0) PF1(SBB,0,TOS,0) %FINISH %FINISH C=CA PSF1(OPCODE,1,WORK) PSF1(DEBJ,0,(C-CA)//2) ! ! FOR REAL EXPONENTS CHECK IF NEGATIVE AND EVALUATE INVERSE ! %IF VALUE=0 %AND TYPEP=2 %THEN %START PSF1(LB,1,EXPWORK); ! LB ON ORIGINAL EXPONENT ENTER JUMP(46,PLABEL,B'11');! BP END OF EXP ROUTINE PPJ(16,7) %IF PARMARR=1; ! TILL DIVIDE ERROR INT FIXED! PF1(RRDV,0,PC,PLABS(1)+8) %FINISH ! ! ALL OVER. REAL RESULTS ARE IN FR WORK. INT RESULTS IN GR WORK+1 ! FREE AND FORGET ANY OTHER REGISTERS ! TYPE=TYPEP REGISTER(BREG)=0; GRUSE(BREG)=0 OPND1_PTYPE=+TYPE OPND1_XB=0; OPND1_D=ACCR ENTER LAB(PLABEL,B'11',LEVEL);! LABEL AT END OF EXP ROUTINE %END %ROUTINE REXP !*********************************************************************** !* CALLS A PERM ROUTINE TO PERFORM REAL**REAL * !*********************************************************************** %IF REGISTER(BREG)>0 %THEN BOOT OUT(BREG) LOAD(1,ACCR,2) %UNLESS OPND1_FLAG=8 LOAD(2,ACCR,2) PPJ(0,14) %END %END %ROUTINE STORE CONST(%INTEGERNAME D,%INTEGER L,VAL1,VAL2) !*********************************************************************** !* PUT THE CONSTANT VAL OF LENGTH 'L' INTO THE CODE * !* AND RECORD ITS POSITION IN CASE THIS CONSTANT IS REUSED * !* A CHECK IS MADE USING 'CONST FIND' TO SEE IF THE CONSTANT HAS * !* BEEN INSERTED IN WHICH CASE THE OLD COPY IS REUSED * !*********************************************************************** %INTEGERNAME LIST %INTEGER LST %RECORDNAME LCELL(LISTF) %IF L=4 %THEN LST=CONSTL4 %ELSE LST=CONSTL8 %IF PARMOPT=0 %START %WHILE LST>0 %CYCLE LCELL==ASLIST(LST) %IF VAL1=LCELL_S1 %AND VAL2=LCELL_S2 %THEN %C D=LCELL_S3 %AND %RETURN LST=LCELL_LINK %REPEAT %FINISH LIST==CONSTL4 %IF SPCNST>2 %THEN ALLOC CSPACE D=CNSTAT; PLUG(1,D,VAL1) CNSTAT=CNSTAT+4 %IF L=8 %THEN PLUG(1,CNSTAT,VAL2) %AND %C CNSTAT=CNSTAT+4 %AND LIST==CONSTL8 SPCNST=SPCNST-L>>2 PUSH123(LIST,VAL1,VAL2,D) %IF PARMOPT=0 %END %ROUTINE REDUCE ENV(%INTEGERNAME HEAD) !*********************************************************************** !* HEAD HAS AN ENVIRONMENT - THIS ROUTINE REMOVES ANYTHING * !* INCOMPATIBLE WITH THE CURRENT REGISTER STATE * !*********************************************************************** %INTEGER I,J,K,REG,USE %INTEGERNAME OHEAD OHEAD==HEAD %WHILE OHEAD#0 %CYCLE K=FROM3(OHEAD) REG=K>>8; USE=K&255 %UNLESS USE=GRUSE(REG) %AND %C FROM1(OHEAD)=GRINF(REG) %THEN %C POP(OHEAD,I,J) %ELSE OHEAD==ASLIST(OHEAD)_LINK %REPEAT %END %INTEGERFN REVERSE(%INTEGER MASK) !*********************************************************************** !* REVERSE THE MASK FOR A JCC(MASK<=15),JAT(>15) OR JAF(>31 * !*********************************************************************** %IF MASK>15 %THEN MASK=MASK!!X'30' %ELSE MASK=MASK!!15 %RESULT=MASK %END %ROUTINE ENTER LAB(%INTEGER LAB,FLAGS,LEVL) !*********************************************************************** !* ENTER A NEW LABEL ON THE LABEL LIST FOR THE CURRENT LEVEL * !* 2**0 OF FLAGS = 1 CONDITIONAL ENTRY * !* 2**1 OF FLAGS = 1 UPDATE ENVIRONMENT * !* 2**2 OF FLAGS = 1 REPLACE ENV =0 MERGE ENV * !* THE LABEL LIST * !* S1 = LABEL NO * !* S2 = ENVIRONMENT LIST << 16 ! UNFILLED JUMPS LIST * !* S3 = LEVEL <<24 ! LABEL ADDR * !*********************************************************************** %INTEGER CELL,AT,ENVHEAD,JUMPHEAD,INSTRN,L,OLDCELL ! MAP CELL ONTO CORRECT LIST CELL =TAGSCELL FOR USER LABELS ! FLAGS=FLAGS&1 %IF PARMOPT#0 %IF LAB<=NNAMES %THEN CELL=TAGS(LAB) %ELSE %START CELL=LABEL(LEVL); OLDCELL=0 %WHILE CELL>0 %CYCLE %EXIT %IF ASLIST(CELL)_S1=LAB OLDCELL=CELL CELL=ASLIST(CELL)_LINK %REPEAT %FINISH %IF CELL<=0 %THEN %START; ! LABEL NOT KNOWN %IF FLAGS&1=0 %THEN %START;! UNCONDITIONAL ENTRY PUSH123(LABEL(LEVL),LAB,0,LEVEL<<24!CA) %CYCLE L=0,1,7; GRUSE(L)=0; %REPEAT %FINISH %RETURN %FINISH ! ! LABEL HAS BEEN REFERENCED - FILL IN ITS ADDRESS ! %IF FROM3(CELL)&X'FFFFFF'# 0 %THEN %START FAULT(2,LAB); ! LABEL SET TWICE %RETURN %FINISH %ELSE %START REPLACE3(CELL,LEVEL<<24!CA) %FINISH ! ! SORT OUT ENVIRONMENTS - AS DIRECTED BY FLAGS ! JUMPHEAD=FROM2(CELL) ENVHEAD=JUMPHEAD>>16 JUMPHEAD=JUMPHEAD&X'FFFF' %IF FLAGS&2=0 %THEN %START %CYCLE L=0,1,7; GRUSE(L)=0; %REPEAT CLEAR LIST(ENVHEAD) %IF ENVHEAD#0 %FINISH %ELSE %START REMEMBER %IF FLAGS&4=0 RESTORE (ENVHEAD) ENVHEAD=0 MERGE INFO %IF FLAGS&4=0 %FINISH ! ! NOW FILL JUMPS TO THIS LABEL - JUMP LIST FORMAT GIVEN IN 'ENTER JMP' ! %WHILE JUMPHEAD#0 %CYCLE POP123(JUMPHEAD,AT,INSTRN,L) FAULT(12,LAB) %IF L NNAMES %THEN %START %IF OLDCELL#0 %THEN POP(ASLIST(OLDCELL)_LINK,AT,AT) %ELSE %C POP(LABEL(LEVL),AT,AT) %FINISH %END %ROUTINE ENTER JUMP(%INTEGER MASK,LAB,FLAGS) !*********************************************************************** !* IF LAB HAS BEEN ENCOUNTERED THEN PLANT A JCC OTHERWISE ENTER * !* THE LABEL IN THE LABEL LIST AND ATTACH THE JUMP TO IT SO IT * !* CAN BE PLANTED WHEN THE LABEL IS FOUND * !* THE LABEL LIST IS DESCRIBED UNDER 'ENTER LAB' * !* THE JUMP SUB-LIST HAS THE FORM * !* S1= ADDR OF JUMP * !* S2=INSTRN * !* S3=LEVEL * !* * !* FLAGS BITS SIGNIFY AS FOLLOWS * !* 2**0 =1 JUMP IS KNOWN TO BE SHORT * !* 2**1 =1 ENVIRONMENT MERGEING REQUIRED * !*********************************************************************** %INTEGER AT,CELL,J,JJ,LABADDR,I,ENVHEAD,OLDENV,JCODE,LEVL FLAGS=FLAGS&1 %IF PARMOPT#0 ENVHEAD=0; AT=CA; LEVL=LEVEL %IF LAB<21000 %THEN FLAGS=FLAGS&X'FE'; ! SF OR USER LAB=LONG %IF LAB<=NNAMES %THEN %START CELL=TAGS(LAB) LEVL=FROM1(CELL)>>8&63; ! OLDI FLAGS=FLAGS&X'FD'; ! NO MERGE %FINISH %ELSE %START CELL=LABEL(LEVL) %WHILE CELL#0 %CYCLE %EXIT %IF ASLIST(CELL)_S1=LAB CELL=ASLIST(CELL)_LINK %REPEAT %FINISH JCODE=OCODE(MASK) -> FIRSTREF %IF CELL<=0 LABADDR=FROM3(CELL)&X'FFFFFF' -> NOT YET SET %IF LABADDR=0 I=(LABADDR-CA)//2 FAULT(12,LAB) %IF FROM3(CELL)>>24>LEVEL %IF JCODE>6 %THEN PSF1(JCODE,0,I) %ELSE %C PF3(JCODE,MASK&15,0,I) %RETURN FIRSTREF: ! FIRST REFERENCE TO A NEW LABEL %IF LAB>NNAMES %AND FLAGS&2#0 %THEN GET ENV(ENV HEAD) PUSH123(LABEL(LEVL),LAB,ENVHEAD<<16,0) CELL=LABEL(LEVL) -> CODE NOT YET SET: ! LABEL REFERENCED BEFORE %IF LAB>NNAMES %AND FLAGS&2#0 %THEN %START I=FROM2(CELL) OLDENV=I>>16 REDUCE ENV(OLD ENV) REPLACE2(CELL,OLDENV<<16!I&X'FFFF') %FINISH CODE: ! ACTUALLY PLANT THE JUMP %IF JCODE>6 %THEN I=JCODE<<24!3<<23 %C %ELSE I=JCODE<<24!(MASK&15)<<21 J=FROM2(CELL) JJ=J&X'FFFF' PUSH123(JJ,CA,I,LEVEL) REPLACE2(CELL,J&X'FFFF0000'!JJ) PCONST(I) %END %ROUTINE MERGE INFO !*********************************************************************** !* MERGE THE CURRENT STATUS OF THE REGISTERS WITH THE VALUES * !* AT THE START OF THE CONDITIONAL CLAUSE. THIS PERMITS THE * !* THE COMPILER TO REMEMBER UNCHANGED REGISTERS BUT NOT THOSE * !* WHICH DEPEND ON A PARTICULAR RUN TIME ROUTE BEING TAKEN * !*********************************************************************** %INTEGER I,J %CYCLE J=0,1,4; I=GRMAP(J) GRUSE(I)=0 %UNLESS SGRUSE(I)=GRUSE(I) %AND SGRINF(I)=GRINF(I) %REPEAT %END %ROUTINE REMEMBER %INTEGER I,J %CYCLE J=0,1,4; I=GRMAP(J) SGRUSE(I)=GRUSE(I) SGRINF(I)=GRINF(I) %REPEAT %END %ROUTINE CSNAME(%INTEGER Z,REG) !*********************************************************************** !* COMPILE A SPECIAL NAME - PTYPE=X'1006' (=%ROUTINE %LABEL) * !* THEIR TRUE PTYPE IS IN GLOBAL ARRAY TSNAME. * !* SNINFO HAS A FOUR BYTE RECORD FOR EACH NAME (%BI FLAG,PTR, * !* %SI XTRA). THE TOP BITS OF FLAG CATEGORISE AS FOLLOWS:- * !* 2**7 SET FOR IMPLICITLY SPECIFIED CONSTRUCT A %SPEC * !* 2**6 SET FOR IOCP CALL * !* 2**4 SET IF AD-HOC CODE PLANTED BY THIS ROUTINE * !* 2**2-2**0 HOLD NUMBER OF PARAMS * !* * !* THE FULL SPECS ARE AS FOLLOWS:- * !* 0=%REALFN ABS(%REAL VALUE) * !* 1=%INTEGERFN IABS(%INTEGER VALUE) * !* 2=%INTEGERFN SIGN(%REAL VALUE) * !* 3=%INTEGERFN ENTIER(%REAL VALUE) * !* 4=%ROUTINE CLOSE(%INTEGER STRM) * !* 5=%LONGREALFN SQRT(%LONGREAL X) * !* 6=%LONGREALFN SIN(%LONGREAL X) * !* 7=%LONGREALFN COS(%LONGREAL X) * !* 8=%LONGREALFN ARCTAN(%LONGREAL X) * !* 9=%LONGREALFN LN(%LONGREAL X) * !* 10=%LONGREALFN EXP(%LONGREAL X) * !* 11=%REALFN MAXREAL * !* 12=%REALFN MINREAL * !* 13=%INTEGERFN MAXINT * !* 14=%REALFN EPSILON * !* 15=%ROUTINE FAULT(%STRINGNAME FNO,%REAL VALUE) * !* 16=%ROUTINE STOP * !* 17=%INTEGERFN CHARIN(%INTEGER CH) * !* 18=%ROUTINE CHAROUT(%INTEGER CH,SYM) * !* 19=%ROUTINE OPEN(%INTEGER STRM) * !* 20=%ROUTINE OUTREAL(%INTEGER CHANNEL,%LONGREAL NUMBER) * !* 21=%ROUTINE READARRAY(%INTEGER STRM,%ARRAY A,%STRING S) * !* 22=%ROUTINE WRITEARRAY(%INTEGER S,F,D,%ARRAY A,%STRING S) * !* 23=%ROUTINE IREADARRAY(%INTEGER STRM,%ARRAY A,%STRING S) * !* 24=%ROUTINE IWRITEARRAY(%INTEGER S,F,D,%ARRAY A,%STRING S) * !* 25=%INTEGERFN LENGTH(%STRING(255) S) * !* 26=%REALFN CPUTIME * !* 27=%ROUTINE BREADARRAY(%INTEGER S,F,%ARRAY A,%STRING S) * !* 28=%ROUTINE BWRITEARRAY(%INTEGER S,F,D,%ARRAY A,%STRING S) * !* 29=%ROUTINE NEWLINE(%INTEGER STRM,N) * !* 30=%ROUTINE SPACE(%INTEGER STRM,N) * !* 31=%ROUTINE GAP(%INTEGER STRM,N) * !* 32=%INTEGERFN FORMAT(%STRING FORM) * !* 33=%ROUTINE REWIND(%INTEGER BINCH) * !* 34=%ROUTINE SKIP(%INTEGER BINCH,HOWMANY) * !* 35=%ROUTINE INTERCHANGE(%INTEGER BINCH) * !* 36=%LONGREALFN READ(%INTEGER STRM) * !* 37=%ROUTINE PAGE(%INTEGER STRM,N) * !* 38=%ROUTINE WRITE(%INTEGER STRM,FORM,%LONGREAL VALUE) * !* 39=%ROUTINE IWRITE(%INTEGER STRM,FORM,VALUE) * !* 40=%INTEGERFN CODE(%STRING(1) CHAR) * !* 41=%INTEGERFN INTEGER READ(%INTEGER STRM) * !* 42=%ROUTINE TAB(%INTEGER STRM,N) * !* 43=%ROUTINE OUTPUT(%INTEGER STRM,%LONGREAL X) * !* 44=%BOOLEANFN READ BOOLEAN(%INTEGER STRM) * !* 45=%ROUTINE WRITE BOOLEAN(%INTEGER STRM,%BOOLEAN BOOL) * !* 46=%ROUTINE WRITE TEXT(%INTEGER STRM,%STRINGNAME TEXT) * !* 47=%ROUTINE COPYTEXT(%INTEGER STRM,STRM2,%STRINGNAME TEXT) * !* 48=%LONGREALFN FREAD(%INTEGER STRM,%STRING FIXFORM) * !* 49=%INTEGERFN INBASIC SYMBOL(%INTEGER STRM) * !* 50=%ROUTINE OUTBASICSYMBOL(%INTEGER STRM,SYM) * !* 51=%ROUTINE READ BINARY(%INTEGER CH,%ARRAY A,%STRING S) * !* 52=%ROUTINE MONITOR * !* 53=%ROUTINE IREAD BINARY(%INTEGER CH,%ARRAY A,%STRING S) * !* 54=%ROUTINE BREAD BINARY(%INTEGER CH,%ARRAY A,%STRING S) * !* 55=%ROUTINE WRITE BINARY(%INTEGER CH,%ARRAY A,%STRING S) * !* 56=%ROUTINE IWRITE BINARY(%INTEGER CH,%ARRAY A,%STRING S) * !* 57=%ROUTINE BWRITE BINARY(%INTEGER CH,%ARRAY A,%STRING S) * !* 58=%INTEGERFN JREADOINT(%LONGREAL C0) * !* 59=%LONGREALFN JINTDOREA(%INTEGER C0) * !* 60=%INTEGERFN JSPOJILIP(%INTEGER IL,IP) * !* 61=%INTEGERFN JSETILEVE(%INTEGER KAM,IL) * !* 62=%INTEGERFN JSETIPRAV(%INTEGER KAM,IP) * !* 63=%INTEGERFN JEXTILEVE(%INTEGER KDE) * !* 64=%INTEGERFN JETIRPRAV(%INTEGER KDE) * !* 65=%INTEGERFN JCISPOLE(%LONGREAL KDE) * !* 66=%INTEGERFN JCISRADEK(%LONGREAL KDE) * !* 67=%LONGREALFN JSIIDOREA(%INTEGER LEV,PRA) * !* 68=%LONGREALFN JSETILREA(%LONGREAL KAM,%INTEGER IL) * !* 69=%LONGREALFN JSETIPREA(%LONGREAL KAM,%INTEGER IP) * !* 70=%INTEGERFN JEXILZREA(%LONGREAL KDE) * !* 71=%INTEGERFN JEXIPZREA(%LONGREAL KDE) * !* 72=%LONGREALFN JSPOJRLRP(%LONGREAL RL,RP) * !* 73=%LONGREALFN JSETRLEVE(%LONGREAL KAM,RL) * !* 74=%LONGREALFN JSETRPRAV(%LONGREAL KAM,RP) * !* 75=%LONGREALFN JEXTRLEVE(%LONGREAL KDE) * !* 76=%LONGREALFN JEXTRPRAV(%LONGREAL KDE) * !*********************************************************************** %SWITCH ADHOC(1:7) %CONSTINTEGERARRAY SNINFO(0:76)=%C X'11010024',X'11020024',X'11030024',X'11050024', X'80190000',X'80010000'(3), X'80010000'(3),X'80000000', X'80000000'(3),X'802A0000', X'10040001',X'80190000',X'80130000',X'80190000', X'80030000',X'80060000',X'80240000',X'80060000', X'80240000',X'80110000',X'80000000',X'801B0000', X'80240000',X'80130000'(3), X'80110000',X'80190000',X'80130000',X'80190000', X'80190000',X'80130000',X'80200000',X'802D0000', X'11060024',X'80190000',X'80130000',X'80030000', X'80190000',X'800E0000',X'80160000',X'800A0000', X'80160000',X'80190000',X'80130000',X'80060000', X'10070001',X'80060000'(5), X'80010000',X'80190000',X'80130000', X'80130000'(2),X'80190000'(2), X'80010000'(2),X'80130000',X'80310000', X'80310000',X'80010000'(2),X'80340000', X'80340000'(2),X'80010000'(2); ! ! SNPARAMS HOLDS NUMBER AND PTYPE OF FORMAL PARAMETER FOR IMPLICITLY ! SPECIFIED EXTERNAL ROUTINES. A POINTER IN SNINFO MEANS THAT NO ! DUPLICATES NEED TO BE RECORDED. ! FIRST WORD OF GROUP HAS NO OF PARAMS ! THE REMAINDER ARE THE TYPE OF EACH PARAM ! %CONSTINTEGERARRAY SNPARAMS(0:54)=0, 1,2, 2,1,2, 3,1,X'110',5, 3,1,1,5, 2,1,3, 1,5, 2,1,1, 2,1,5, 1,1, 4,1,1,X'110',5, 3,1,1,2, 5,1,1,1,X'110',5, 2,5,2, 3,1,1,1, 2,2,1, 2,2,2; ! KEY TO PARAMETER TABLE ! 0 X0 == (NO PARAMS) ! 1 X1 == (%LONGREAL X) ! 3 X3 == (%INTEGER I,%LONGREAL X) ! 6 X6 == (%INTEGER I,%ARRAY A,%STRING S) ! 10 XA == (%INTEGER I,J,%STRING S) ! 14 XE == (%INTEGER I,%BOOLEAN B) ! 17 X11 == (%STRING S) ! 19 X13 == (%INTEGER I,J) ! 22 X16 == (%INTEGER I,%STRING S) ! 25 X19 == (%INTEGER I) ! 27 X1B == (%INTEGER I,J,%ARRAY A,%STRING S) ! 32 X20 == (%INTEGER I,J,%LONGREAL X) ! 36 X24 == (%INTEGER I,J,K,%ARRAY A,%STRING S) ! 42 X2A == (%STRING S,%LONGREAL VALUE) ! 45 X2D == (%INTEGER I,J,K) ! 49 X31 == (%LONGREAL X,%INTEGER I) ! 52 X34 == (%LONGREAL X,Y) ! %CONSTSTRING(12)%ARRAY SNXREFS(0:76)='S#ABS','S#IABS','S#SIGN', 'S#INTPT','S#JCLOSE','S#ISQRT','S#ISIN', 'S#ICOS','S#AARCTAN','S#ILOG','S#IEXP', 'S#MAXREAL','S#MINREAL','S#MAXINT','S#EPSILON', 'S#JFAULT','S#STOP','S#JCHARIN','S#JCHAROUT', 'S#JOPEN','S#JOUTPUT','S#JRARRAY','S#JWARRAY', 'S#JIRARRAY','S#JIWARRAY','S#LENGTH','S#CPUTIME', 'S#JBRARRAY','S#JBWARRAY','S#JNEWL','S#JSPACE', 'S#JGAP','S#JFORMAT','S#JRWND','S#JSKIP', 'S#JINTCH','S#JREAD','S#JPAGE','S#JWRITE', 'S#JIWRITE','S#AICODE','S#JIREAD','S#JTAB', 'S#JOUTPUT','S#JREADBOOL','S#JWRITEBOOL', 'S#JWRITETEXT','S#JCOPYTEXT','S#JFREAD','S#JINBS', 'S#JOUTBS','S#JRDBIN','S#ALGMON','S#JRDBIN', 'S#JRDBIN','S#JWRBIN','S#JWRBIN','S#JWRBIN', "S#JREADOINT","S#JINTDOREA","S#JSPOJILIP","S#JSETILEVE", "S#JSETIPRAV","S#JEXTILEVE","S#JEXTIPRAV","S#JCISPOLE", "S#JCISRADEK","S#JSIIDOREA","S#JSETILREA","S#JSETIPREA", "S#JEXILZREA","S#JEXIPZREA","S#JSPOJRLRP","S#JSETRLEVE", "S#JSETRPRAV","S#JEXTRLEVE","S#JEXTRPRAV"; ! %INTEGER ERRNO,FLAG,POINTER,OPHEAD,OPBOT,PIN,SNNO,SNNAME,NAPS, %C SNPTYPE,JJ,XTRA,B,D,SNINF,P0 ! SNNAME=A(P) SNNO=K; ! INDEX INTO SNINFO TESTAPP(NAPS); ! COUNT ACTUAL PARAMETERS PIN=P; P=P+1 SNPTYPE=TSNAME(SNNO) SNINF=SNINFO(SNNO) XTRA=SNINF&X'FFFF' POINTER=(SNINF>>16)&255 FLAG=SNINF>>24 ! ! THE IMPLICITLY SPECIFIED ROUTINE ARE THE EASIEST OF ALL TO DEAL WITH. ! JUST SET UP THE EXTERNAL SPEC & PARAMETERS. THEN A RECURSIVE CALL ! OF CNAME THEN FINDS THE ROUTINE UNDER ITS TRUE COLOURS AND COMPILES ! THE CALL. ALL CALLS EXCEPT THE FIRST ARE DEALT WITH DIRECTLY BY CNAME. ! ALL NONTRIVIAL ROUTINES SHOULD BE DEALT WITH IN THIS MANNER ! %IF Z=13 %AND FLAG&X'80'=0 %START; ! RT PARAM FLAG=X'80'; ! GIVE FORMAL PROCEDURE %IF SNNO=1 %THEN POINTER=25 %ELSE POINTER=1 %IF SNNO=16 %OR SNNO=52 %THEN POINTER=0 %IF SNNO=40 %THEN POINTER=16 %FINISH ! %IF FLAG&X'80'#0 %THEN %START CXREF(SNXREFS(SNNO),0,2,JJ); ! JJ SET WITH REF DISPLACEMENT %IF SNNO=9 %THEN LOGEPDISP=JJ %IF SNNO=10 %THEN EXPEPDISP=JJ OPHEAD=0; P0=SNPARAMS(POINTER) PUSH123(OPHEAD,JJ,P0&15,P0>>4) OPBOT=OPHEAD K=OPHEAD; JJ=1; D=64 P0=P0&15 %WHILE JJ<=P0 %CYCLE PTYPE=SNPARAMS(POINTER+JJ) %IF PTYPE=2 %THEN ACC=8 %ELSE ACC=4 D=(D&X'FFFF'+ACC-1)&(-ACC) %IF PTYPE&X'F0'=0 %THEN D=D!(PTYPE&X'F00')<<8 BINSERT(OPHEAD,OPBOT,PTYPE,SNNAME,D) D=D+ACC JJ=JJ+1 %REPEAT I=9; J=14; KFORM=0 OLDI=0; PTYPE=SNPTYPE+4096 USEBITS=3 REPLACE TAG(SNNAME) P=PIN; CNAME(Z,REG); ! RECURSIVE CALL %RETURN %FINISH ! ! ALL ROUTINES EXCEPT THE IMPLICITS REQUIRE A CHECH THAT THE USE OF THE ! NAME IS LEGAL AND THAT THE CORRECT NO OF PARAMETERS(BOTTOM 2 BITS OF ! FLAG) HAS BEEN SUPPLIED. THE CHECK IS TRIVIAL - THE PROBLEM ! IS TO GET THE RIGHT ERROR NUMBER. ! XTRA HAS A BITMASK OF ALLOWED USES(IE ALLOWED Z VALUES) ! %IF NAPS#FLAG&3 %THEN ERRNO=19 %AND ->ERREXIT JJ=1<ERR EXIT %FINISH ! ! A NUMBER OF INPUT-OUTPUT ROUTINES ARE MAPPED ONTO CALLS OF IOCP. ! THIS ARRANGEMENT HAS THE ADVANTAGE OF REQUIRING ONL 1 EXTERNAL REF ! IN THE GLA BUT HAS THE DISADVANTAGE THAT THE I-O ROUTINES CAN NOT ! BE PASSED AS RT-TYPE PARAMETERS AS WELL AS REQUIRING MESSY CODE ! HEREABOUTS. SNINF_PTR HOLD EITHER:- ! 1) THE IOCP ENTRY POINT NO ! OR 2) THE SYMBOL TO BE OUTPUT WITH 2**7 BIT SET ! ! THIS SECTION DEALS WITH SELECT INPUT,SELECT OUTPUT,NEWLINE,NEWPAGE ! SPACE,SKIP SYMBOL,PRINT SYMBOL,PRINT STRING ! AND PRINT CH ! ! %IF FLAG&X'40'#0 %THEN %START ! IOCPEP=POINTER ! %IF FLAG&3#0 %THEN %START; ! RT HAS PARAMS ! P=P+1 ! %IF SNNO=37 %THEN CSTREXP(1,1) %ELSE CSEXP(1,1) ! %FINISH ! %IF IOCPEP>127 %THEN DUMP(X'41',1,IOCPEP&127,0,0) %AND IOCPEP=5 ! CIOCP(IOCPEP); ! PLANT CALL OF IOCP ! ->OKEXIT ! %FINISH ! ! ADHOC CODING IS REQUIRED FOR THE REMAINING ROUTINES APART FROM ! A CHECK FOR NAMETYPE PARAMETERS. THE SWITCH NO IS KEPT IN POINTER ! ERRNO=22 ->ADHOC(POINTER) ADHOC(1): ! ABS ADHOC(2): ! IABS B=3-POINTER; ! TYPE ->ERREXIT %UNLESS A(P)=2 D=A(P+2); P=P+3 ->ERREXIT %UNLESS 2<=D<=3 CSEXP(ACCR,B,D) REG=NEST %IF REG<0 %IF SNNO=1 %THEN %START PF3(JAT,5,0,3) PSF1(IRSB,0,0) %FINISH %ELSE %START PF3(JAT,1,0,3) PSF1(RRSB,0,0) %FINISH GRUSE(ACCR)=0 ->OKEXIT ADHOC(3): ! SIGN ADHOC(5): ! ENTIER ->ERREXIT %UNLESS A(P)=2 D=A(P+2); P=P+3 ->ERREXIT %UNLESS 2<=D<=3 CSEXP(ACCR,2,D) REGISTER(ACCR)=1 OPHEAD=RPPTR A(RPPTR)=2<<16!9 A(RPPTR+1)=0 A(RPPTR+3)=16-SNNO; ! 13 FOR ENTIER, 14 FOR SIGN A(RPPTR+4)=1 A(RPPTR+6)=100 RPPTR=RPPTR+9 P0=P; EXPOP(OPHEAD,ACCR,1,1) P=P0; RPPTR=OPHEAD ->OKEXIT ADHOC(4): ! STOP PPJ(15,16) ->OKEXIT ADHOC(6): ! CODE ->ERREXIT %UNLESS A(P)=2 %IF A(P+2)=2 %THEN ->CONAM ->ERREXIT %UNLESS A(P+2)=1 B=A(P+5); D=B>>16&255; B=B>>24;! FIRST 2 CHARS %IF A(P+4)=2 %THEN %START %IF B='E' %AND D='L' %THEN B=NL %AND ->COD %IF B='S'=D %THEN B='%' %AND ->COD %FINISH ->ERREXIT %UNLESS A(P+4)=1 %IF B='_' %THEN B=' ' %IF B='\' %THEN B=NL P=P-1 COD: GET IN ACC(ACCR,1,0,0,B) GRUSE(ACCR)=5; GRINF(ACCR)=B P=P+6 ->OKEXIT CONAM: ! STRINGNAME PARAMETER P=P+3; SAVEIRS; CNAME(2,ACCR) ->ERREXIT %UNLESS TYPE=5 %IF CODEPDISP=0 %THEN CXREF("S#AICODE",0,2,CODEPDISP) PF1(STLN,0,TOS,0) PSF1(ASF,0,4) PF1(ST,0,TOS,0) PSF1(LXN,1,16) PSF1(RALN,0,7) PF1(CALL,2,XNB,CODEPDISP) FORGET(-1) ->OKEXIT ADHOC(7): ! MONITOR PSF1(LSS,0,0) PF1(ST,0,TOS,0) PPJ(0,2) OKEXIT: ! NORMAL EXIT P=P+1 PTYPE=SNPTYPE %RETURN ERREXIT: ! ERROR EXIT FAULT(ERRNO,SNNAME) P=PIN+1; SKIP APP P=P-1; %RETURN %END; ! OF ROUTINE CSNAME %ROUTINE CALL THUNKS(%INTEGER Z, REG, B, D) !*********************************************************************** !* A THUNKS CONSISTS OF AN ESCAPE DESCRIPTOR AT D(B) WHICH POINTS* !* TO STORED VALUES OF PC & LNB FOR THE THUNKS. THE BOUND FIELD * !* IS SET TO NONZERO IF A STORE IS NOT ALLOWED * !*********************************************************************** BASE=B; AREA=-1 GET IN ACC(DR,2,0,AREA CODE,D) %IF Z=1 %AND PARMARR#0 %THEN PF3(JCC,14,0,4) %AND PPJ(43,9) GRUSE(XNB)=0; ! TILL STXN BECOMES AVAILABLE %IF Z=0 %THEN PSF1(MODD,0,0) %AND %RETURN %IF Z#1 %THEN %START GET IN ACC(REG,BYTES(TYPE)>>2,2,7,0) %FINISH %END %ROUTINE CANAME(%INTEGER Z, BS, DP) !*********************************************************************** !* BS & DP DEFINE THE POSITION OF THE ARRAY HEAD * !* Z AS FOR CNAME. ON Z=1 (STORE INTO ARRAY) THE SUSBSCRIPTS * !* ARE EVALUATED AND LEFT AS A RESULT DESCRIPTOR. THIS IS * !* BECAUSE OF THE ALGOL DEFINITION OF LEFTPARTLIST * !* IN-LINE CODE IS PLANTED EVEN IF PARM=NOARRAY IS REQUESTED * !*********************************************************************** %INTEGER HEAD1, HEAD2, HEAD3, NOPS, PTYPEP, KK, PP, %C JJ, TYPEP, ARRNAME, Q, ELSIZE, ARRP, PARAMS PP=P; TYPEP=TYPE; ARRP=PTYPE>>4&15 JJ=J; PTYPEP=PTYPE ELSIZE=BYTES(TYPE) ARRNAME=A(P); ! NAME OF ENTITY PARAMS=A(P+1) TEST APP(Q); ! COUNT NO OF SUBSCRIPTS ! ! CHECK CORRECT NO OF SUBSCRIPTS PROVIDED. HOWEVER ENTITIES PASSED ! AS %ARRAYNAME HAVE NO DIMENSION . THIS SECTION SETS THE ! DIMENSION FROM THE FIRST USE OF THE NAME. ! %IF JJ=0 %THEN %START; ! 0 DIMENSIONS = NOT KNOWN REPLACE1(TCELL, FROM1(TCELL)!Q) ! DIMSN IS BOTTOM 4 BITS OF TAG JJ=Q KFORM=FROM3(TCELL)&X'FFFF' %IF KFORM#0 %THEN REPLACE2(KFORM,Q<<16!FROM2(KFORM)) %FINISH %IF JJ=Q %AND PARAMS=1 %START; ! CORRECT DIMENSIONALITY ! ! FOR IN-LINE CODE WE SET UP A CHAIN OF REVERSE POLISH OPERATIONS TO ! EVALUATE THE VARIOUS SUBSCRIPTS,MULTIPLY BY THE MULTIPLIERS AND ! ADD THEM TOGETHER. ! P=PP+3 %IF ARRP=2 %AND JJ=1 %THEN %START CSEXP(BREG,1,0); P=P+1 %FINISH %ELSE %START HEAD3=0; NOPS=0 HEAD1=RPPTR ! ! NOW PROCESS THE SUBSCRIPTS CALLINR ETORP TO CONVERT THE EXPRESSIONS ! TO REVERSE POLISH AND ADDING THE EXTRA OPERATIONS. ! %CYCLE KK=1, 1, JJ; ! THROUGH THE SUBSCRIPTS ETORP(HEAD2,NOPS, 1);! SUBSCRIPT TO REVERSE POLISH RPPTR=RPPTR-3 %IF TYPE=2 %THEN A(RPPTR)=13 %AND A(RPPTR+1)=0 %C %AND RPPTR=RPPTR+3 P=P+2 %REPEAT P=P-1 ! ! N SUBSCRIPTS WILL REQUIRE (N-1) MULTIPLICATIONS AND ADDITIONS ! %CYCLE KK=JJ,-1,1 NOPS=(NOPS+1)!1<<24; ! TREAT DVM AS '*' A(RPPTR)=X'51'<<16 A(RPPTR+1)=KK<<16!JJ A(RPPTR+2)=BS<<18!DP A(RPPTR+3)=28 A(RPPTR+4)=ARRP RPPTR=RPPTR+6 %REPEAT ! ! ADD OPERATORS TO THE BACK OF OPERANDS AND EVALUATE ! A(RPPTR)=100 RPPTR=RPPTR+3 PP=P EXPOP(HEAD1, BREG, NOPS, 5);! EVALUATE THE REVERSE POLISH LIST P=PP RPPTR=HEAD1 %FINISH BASE=BS; DISP=DP ACCESS=3; AREA=-1; %FINISH %ELSE %START FAULT(18, ARRNAME) BASE=BS; DISP=DP ACCESS=3; AREA=-1; P=P+1; SKIP APP %FINISH ACC=ELSIZE PTYPE=PTYPEP; J=JJ %END; ! OF ROUTINE CANAME %ROUTINE CNAME(%INTEGER Z, REG) !*********************************************************************** !* THIS IS THE MAIN ROUTINE FOR PROCESSING NAMES.CANAME,CSNAME * !* AND CRNAME ARE ONLY CALLED FROM HERE,THE NAME (AND ANY PARAMS * !* OR SUBNAMES) ARE INDEXED BY P WHICH IS ADVANCED. * !* Z SPECIFIES ACTION AS FOLLOWS:- * !* Z=0 COMPILE A ROUTINE CALL * !* Z=1 SET BASE,INDEX AND DISP FOR A 'STORE' OPERATION * !* Z=2 FETCH NAME TO 'REG' * !* Z=3 SET ADDR(NAME) IN REG FOR PASSING BY NAME (TOP BYTE SET) * !* Z=5 IF NAME IS IN A REGISTER THEN AS Z=2 ELSE SET BASE ETC * !* Z=6->11 NOT NOW USED * !* Z=12 SET BASE AND DISP TO POINT TO ARRAYHEAD * !* Z=13 SET REG TO POINT TO 4 WORD ROUTINE DISCRIPTOR * !* (INTERNAL ROUTINES FIRST CREATE THE DISCRIPTOR) * !* * !* REG (WHERE APPROPRIATE) IS SET AS FOLLOWS:- * !* >=0 A REGISTER * !* -1 MEANS CHOOSE ANY REGISTER * !* IF A REGISTER IS CHOSEN THEN NEST IS SET WITH CHOICE * !*********************************************************************** %INTEGER JJ, KK, RR, LEVELP, DISPP, NAMEP, FNAME %SWITCH SW, MOD(0:7) %RECORDNAME LCELL(LISTF) FNAME=A(P); NAMEP=FNAME TCELL=TAGS(FNAME) %IF TCELL<=0 %THEN %START FAULT(16, FNAME) I=LEVEL; J=0; K=FNAME KFORM=0; SNDISP=0; ACC=4 PTYPE=7; STORE TAG(K, N) N=N+4; COPY TAG(FNAME) LEVELP=I; DISPP=K %FINISH %ELSE %START LCELL==ASLIST(TCELL) KK=LCELL_S1; LCELL_S1=KK!X'8000' PTYPE=KK>>16; TYPE=PTYPE&7 OLDI=KK>>8&15; I=KK>>4&15; LEVELP=I J=KK&15 K=LCELL_S3>>16; DISPP=K %FINISH JJ=J; JJ=0 %IF JJ=15 ->NOT SET %IF TYPE=7 %IF (Z=0 %OR Z=13) %AND PTYPE>>12=0 %THEN FAULT(17,FNAME) %C %AND ->NOT SET ->ARRHEAD %IF Z=12 ->RTNAME %IF Z=13 ->RTCALL %IF PTYPE>>12#0 ->SW(TYPE) SW(6): SW(0): SW(4): !RECORD FORMAT NAME ILLEGAL TYPE: FAULT(5, FNAME) SW(7): NOT SET: P=P+1; ! NAME NOT SET NEST=0; BASE=I; DISP=K; ACCESS=0 PTYPE=1; TYPE=1 SKIP APP; %RETURN ARRHEAD: ! SET BASE & DISP FOR ARRAYHEAD BASE=I; ACCESS=0; DISP=K; AREA=-1 NO APP; %RETURN RTNAME: ! LOAD ADDR FOR RT-TYPE %IF PTYPE=SNPT %THEN CSNAME(Z, REG) %AND P=P+1 %AND %RETURN DISP=FROM1(K); BASE=I %IF PTYPE&X'100'#0 %THEN %START;! TEST NAM BIT SET FORFORMAL PROCS AREA=-1 GET IN ACC(REG,4,0,AREA CODE,DISP) %FINISH %ELSE %START %IF J=14 %THEN %START; ! EXTERNAL ROUTINE PASSED GET IN ACC(REG,2,0,0,0); ! ZERO ENVIRONMENT SET XNB(-1); ! TO PLT PF1(LUH,0,XNB,DISP) %FINISH %ELSE %START %IF BASE=0 %AND CPRMODE=2 %START PSF1(LD,1,12) PSF1(INCA,0,DISP) %UNLESS DISP=0 GRUSE(DR)=0 GET IN ACC(ACCR,2,0,0,0) %FINISH %ELSE %START PSF1(JLK,0,1); ! GET PC TO TOS RTJUMP(LDA,ASLIST(K)_S1); ! ADD N TO POINT @ ENTRY PF1(INCA,0,TOS,0); ! AND TO DES REG PF1(LDTB,0,PC,PLABS(1)+60) GRUSE(DR)=0 GET IN ACC(ACCR,1,0,LNB,PTR OFFSET(BASE)) PSF1(LUH,0,0); ! SPARE FIELD IN RT HDDR %FINISH PF1(STD,0,TOS,0); ! DR TO TOP OF STACK PF1(LUH,0,TOS,0); ! AND TO TOP 64 BITS OF ACC %FINISH %FINISH NO APP; %RETURN ! ! SECTION TO DEAL WITH ALL NAMES INVOLVING ROUTINE CALL ! RTCALL: ! FIRST CHECK %IF TYPE=0 %AND Z#0 %THEN FAULT(23, FNAME) %AND ->NOT SET ! RT NAME IN EXPRSN %IF PTYPE=SNPT %THEN CSNAME(Z,REG) %AND %RETURN CRCALL(K, FROM1(K)); ! DEAL WITH PARAMS %RETURN %IF PTYPE=X'1000' %OR PTYPE=X'1100' %UNLESS Z=0 %OR Z=2 %OR Z=5 %THEN %START; ! FUNCTIONS BASE=0; ACCESS=0; AREA=-1; DISP=0 %FINISH %IF REG=BREG %THEN PF1(ST,0,BREG,0) %RETURN SW(5): ! TYPE=STRING ->ILLEGAL TYPE %UNLESS Z=2; ! ONLY FETCH ALLOWED BASE=I; AREA=-1 GET IN ACC(REG,2,0,AREA CODE,K) NO APP; %RETURN SW(1): ! TYPE =INTEGER SW(2): ! TYPE=REAL SW(3): ! BOOLEAN %IF PTYPE&X'F0'=0 %THEN %START BASE=I; DISP=K ACCESS=0; AREA=-1 %IF A(P+1)=3 %THEN P=P+1 %ELSE NO APP %FINISH %ELSE %START CANAME(Z, I, K) PTYPE=PTYPE&X'F0FF'; ! NAM=0 TYPE=PTYPE&7 %IF GRUSE(DR)=7 %AND GRINF(DR)=NAMEP %THEN AREA=7 %FINISH KK=Z; KK=2 %IF Z=5 NAM=PTYPE>>8&15 ->MOD(NAM<<2!KK&3) MOD(1): ! SCALAR STORE %IF PTYPE&X'F0'=0 %THEN %START %IF BASE=RLEVEL %THEN AREA=LNB %ELSE AREA=AREA CODE %FINISH %RETURN MOD(6): ! SCALARNAME FETCH CALL THUNKS(2, REG, BASE, DISP) TEST ASS(REG) %IF PARMCHK#0 NEST=REG; %RETURN MOD(2): ! SCALAR FETCH %IF BASE=RLEVEL %AND AREA<0 %THEN AREA=LNB %ELSE AREA=AREA CODE %IF ACCESS=0 %AND GRUSE(REG)=9 %AND GRINF(REG)=NAMEP %START %IF REGISTER(REG)=0 %OR Z#5 %START %IF REGISTER(REG)>0 %THEN BOOT OUT(REG) NEST=REG; %RETURN %FINISH %FINISH %IF PARMCHK=0 %AND Z=5 %THEN NEST=-1 %AND %RETURN GET IN ACC(REG,BYTES(TYPE)>>2,ACCESS,AREA,DISP) %IF ACCESS=3 %THEN GRUSE(DR)=7 %AND GRINF(DR)=NAMEP %IF ACCESS=0 %THEN GRUSE(REG)=9 %AND GRINF(REG)=NAMEP %IF PARMCHK=1 %THEN %START %IF REG=BREG %THEN JJ=CPB %ELSE JJ=UCP PF1(JJ,0,PC,PLABS(1)+48) PCONST(JCC<<24!8<<21!((PLABS(5)-CA)//2)&X'3FFFF') %FINISH NEST=REG %RETURN MOD(7): ! SCALAR NAME FETCH POINTER GET IN ACC(REG,2,0,AREA CODE,DISP) %RETURN MOD(3): ! SCALAR FETCH ADDR %IF ACCESS=3 %THEN %START GET IN ACC(DR,2,0,AREA CODE,DISP) %UNLESS AREA=7 PF1(MODD,0,BREG,0) GRUSE(DR)=0 COPY DR %IF REG#DR %FINISH %ELSE %START %IF REG#DR %THEN %START GET INACC(ACCR,1,0,LNB,PTR OFFSET(BASE)) PSF1(IAD,0,DISP) PF1(LUH,0,PC,PLABS(1)+DESRAD(TYPE)) %FINISH %ELSE %START GET IN ACC(DR,2,0,PC,PLABS(1)+DESRAD(TYPE)) PSF1(LDA,1,PTR OFFSET(BASE)) PSF1(INCA,0,DISP) %FINISH %FINISH NEST=REG %RETURN MOD(5): ! SCALAR NAME STORE CALL THUNKS(1,-1,BASE,DISP) DISP=0; ACCESS=2; AREA=7 %END %ROUTINE NO APP !*********************************************************************** !* CHECK FOR APP AND FAULT IF FOUND * !*********************************************************************** P=P+1 %IF A(P)=3 %THEN P=P+1 %ELSE %START FAULT(19,A(P-1)) SKIP APP %FINISH %END %ROUTINE GTHUNKS(%INTEGER PTYPEP,PNAME) !*********************************************************************** !* GENERATE A THUNKS FOR THE ACTUAL PARAMETER INDEXED BY P * !* PTYPEP IF THE FORMAL PARAMETER TYPE. * !*********************************************************************** %INTEGER TYPEP, APALT, D, TOPREG, PL, NOSTORE, CTYPE, ICONST, AD, D1, D2 %LONGREAL RCONST %SWITCH PARTYPE(0:7) ! ! FIRST CHECK FOR THUNKS PASSED ON AS THUNKS. IF FOUND THEN IT IS ! SUFFICIENT TO COPY THE THUNKS POINTER ! APALT=A(P); NOSTORE=0 TYPEP=PTYPEP&7; TOPREG=15 %IF APALT=2 %AND A(P+2)=3 %START; ! NAME,NO APP COPYTAG(A(P+1)) %IF ROUT=0 %AND TYPE=TYPEP %AND (ARR=0 %OR TYPE=6) %START BASE=I; AREA=-1 %IF NAM=1 %THEN GETINACC(ACCR,2,0,AREA CODE,K) %ANDRETURN ! ! A SIMPLE LOCAL NAME DOES NOT REQUIRE A PROPER THUNKS ! A NORMAL DESCRIPTOR IS MORE THAN ADEQUATE ! %IF TYPEP<=3 %THEN P=P+1 %AND CNAME(3,ACCR) %AND %RETURN %FINISH %FINISH ! ! CHECK FOR A SIMPLE CONSTANT BEING PASSED BY NAME. IF FOUND IT IS OK ! TO PASS A DESCRIPTOR TO THE CONSTANT AREA. ! %IF APALT=3 %AND A(P+1)=2 %AND A(P+2+A(P+2))=2 %AND %C A(P+4)=2 %AND 1<=TYPEP<=2 %AND PARMOPT=0 %START CTYPE=A(P+5) ICONST=0; RCONST=0 %IF CTYPE=1 %THEN %START ICONST=A(P+6) RCONST=ICONST %FINISH %ELSE %START INTEGER(ADDR(RCONST))=A(P+6) INTEGER(ADDR(RCONST)+4)=A(P+7) ICONST=INT(RCONST) %IF TYPEP=1 %FINISH ! %IF A(P+3)=2 %THEN ICONST=-ICONST %AND RCONST=-RCONST %IF TYPEP=1 %THEN AD=ADDR(ICONST) %ELSE AD=ADDR(RCONST) STORE CONST(D2,BYTES(TYPEP),INTEGER(AD),INTEGER(AD+4)) D1=SIZE CODE(TYPEP)<<27+1 PGLA(4,8,ADDR(D1)) D=GLACA-8 RELOCATE(D+4,D2,1) AREA=-1; BASE=0 GET IN ACC(ACCR,2,0,AREA CODE,D) %RETURN %FINISH ! ! A PROPER THUNKS IS NEEDED ! %IF REGISTER(ACCR)#0 %THEN BOOT OUT(ACCR) PLABEL=PLABEL-1; PL=PLABEL ENTER JUMP(0,PL,B'11') PF1(STLN,0,TOS,0) PF1(ST,0,TOS,0) PF1(STB,0,TOS,0) PF1(CPSR,0,BREG,0) PSF1(ADB,0,16) PF1(STB,0,TOS,0) PF1(LLN,1,0,4) FORGET(-1) ->PARTYPE(TYPEP) PARTYPE(0): PARTYPE(4): PARTYPE(5): PARTYPE(7): ERROR: FAULT(22, PNAME) %RETURN PARTYPE(3): ! BOOLEAN FORMAL ->ERROR %UNLESS APALT=2 %OR APALT=4 ->COM PARTYPE(1): ! INTEGER FORMAL PARTYPE(2): ! REAL FORMAL ->ERROR %UNLESS 2<=APALT<=3 COM: %IF APALT=2 %THEN %START; ! ACTUAL= COPYTAG(A(P+1)) %IF ROUT=0 %AND TYPE=TYPEP %START P=P+1; CNAME(3, DR) ->THUNKSEND %FINISH %FINISH P=P+1 CSEXP(ACCR, TYPEP, APALT) GET WSP(D, BYTES(TYPEP)>>2); ! 1 OR 2 WORDS PSF1(ST,1,D) PF1(LDTB,0,PC,PLABS(1)+DESRAD(TYPEP)) PSF1(LDA,1,PTR OFFSET(RLEVEL)) PSF1(INCA,0,D) NOSTORE=4 THUNKSEND: ! EXIT SEQUENCE PF1(MPSR,0,TOS,0) PF1(LB,0,TOS,0) PF1(X'60',0,TOS,0); ! L =LOAD ACS PF1(LLN,0,TOS,0) PSF1(ESEX,0,0) PASS DES:ENTER LAB(PL,B'111',LEVEL) GET WSP(D,2) PF1(LSS,0,TOS,0) PSF1(ST,1,D) PSF1(STLN,1,D+4) PSF1(LSS,1,PTR OFFSET(RLEVEL)) PSF1(IAD,0,D) PF1(LUH,0,PC,PLABS(1)+64+NOSTORE) GRUSE(ACCR)=0 %RETURN PARTYPE(6): ! LABEL AND SWITCH %IF PTYPEP&255>16 %START ->ERROR %UNLESS APALT=2 %AND A(P+2)=3 P=P+1; GOTOLAB(3) ->PASS DES %FINISH %IF APALT=3 %OR APALT=5 %THEN %START P=P+1; CDE(11-APALT<<1); ! MODE = 5 OR 3 ->PASS DES %FINISH ->ERROR %UNLESS APALT=2 P=P+1; GOTOLAB(1) ->PASS DES %END %ROUTINE FETCH STRING(%INTEGER REG) !*********************************************************************** !* FETCH A STRING POINTER FOR PASSING.P TO ALT OF ACTUAL PARAM * !*********************************************************************** %INTEGER I %IF A(P)=1 %THEN %START I=A(P+1)-(STRLINK+8) PF1(LDRL,0,PC,STRLINK) PSF1(INCA,0,I) %UNLESS I=0 %IF REG#DR %THEN COPY DR %FINISH %ELSE P=P+1 %AND CNAME(2,REG) %END %INTEGERFN CHECK FPROCS(%INTEGER ACTHEAD,FORMALHEAD) !*********************************************************************** !* CHECK THAT THE PARAMETERLIST OF A ROUTINE BEING PASSED AS * !* A PAREMETER IS THE SAME AS THAT GIVEN (VIA A COMMENT) FOR THE * !* FORMAL PROCEDURE. REGRETABLY IF THE FORMAL IS OF A PROCEDURE * !* WHICH IS ITSELF A FORMAL PROCEDURE THEN NO CHECK CAN BE MADE * !* %IN MIXED LANGUAGE SITUATIONS NAM=1 (SUBSTITUTION),NAM=2 (REF) * !* AND NAM=3 (FORTRAN RESULT) MUST BE TREATED AS EQUIVALENT * !*********************************************************************** %INTEGER NPS,FPTYPE,APTYPE NPS=FROM2(FORMALHEAD) %RESULT=1 %IF 0<=NPS#FROM2(ACTHEAD) ! %WHILE NPS>0 %CYCLE MLINK(ACTHEAD) MLINK(FORMALHEAD) APTYPE=FROM1(ACTHEAD) FPTYPE=FROM1(FORMALHEAD) %RESULT=1 %UNLESS FPTYPE=APTYPE %OR %C (APTYPE&X'F00'#0 %AND FPTYPE&X'F00'#0 %AND %C APTYPE&X'F0FF'=FPTYPE&X'F0FF') NPS=NPS-1 %REPEAT %RESULT=0; ! CORRESPONDENCE COMPLETE %END %ROUTINE CRCALL(%INTEGER CLINK,RDISP) !*********************************************************************** !* COMPILE A ROUTINE OR FN CALL * !* THE PROCEDURE CONSIST OF THREE PARTS:- * !* A) PLANT THE PARAMETER (IF ANY) * !* B) ENTER THE ROUTINE OR FN * !* C) FORGET ANY REGISTERS WHICH HOLD ENTITIES THAT CAN BE * !* ALTERED BY THE CALLED PROCEDURE. * !*********************************************************************** %INTEGER II,PXTRA,DLINK,JJJ,NPARMS,PT,LP,PSIZE,III, %C RTNAME,TL,MOVEPTR,PP,PNAM,NP,ALT,JJ JJJ=J; LP=I; DLINK=CLINK; TL=OLDI RTNAME=A(P);PT=PTYPE ! ! NOW CHECK THAT THE RIGHT NUMBER OF PARAMETERS HAVE BEEN PROVIDED ! TEST APP(NPARMS) P=P+1 %IF FROM2(CLINK)#NPARMS %THEN %START FAULT(19,RTNAME); ! WRONG NO OF PARAMETERS GIVEN SKIP APP %RETURN %FINISH ! SAVE IRS %UNLESS REGISTER(ACCR)!REGISTER(BREG)=0 PF1(STLN,0,TOS,0) PSF1(ASF,0,4) P=P+1 MOVEPTR=5 -> ENTRY SEQ %IF NPARMS=0; ! NO PARAMETERS TO BE PLANTED NP=0; PP=P-2 ! NEXT PARM:MLINK(CLINK) NP=NP+1 P=PP+1 ->ENTRY SEQ %IF CLINK=0 FROM123(CLINK,PTYPE,PNAM,II) PSIZE=II>>16 PXTRA=PNAM>>16 PNAM=PNAM&X'FFF' P=PP+2; PP=P+A(P) P=P+1 ROUT=PTYPE>>12 NAM=PTYPE>>8&15 ARR=PTYPE>>4&15 TYPE=PTYPE&15 II=TYPE ALT=A(P); ! SYNTACTIC ALTERNATIVE OF APP %IF PSIZE<=0 %AND((ROUT!ARR#0 %AND ALT#2) %OR %C (TYPE=5 %AND ALT>2) %OR (NAM=2 %AND ALT#2) %OR %C (PTYPE&X'F0F0'#0 %AND TYPE<=2 %AND(ALT=1 %OR ALT>3))%OR %C (PTYPE&X'F0FF'=3 %AND ALT&1=1) %C %OR (PTYPE&X'F0FF'<=2 %AND (ALT=1 %OR ALT>=4))) %THEN %C FAULT(22,PNAM) %AND ->NEXT PARM ! ! FOR RT TYPE PARAMS, PASS 1 WORD POINTING TO 4 WORDS SET ! UP AS CODE,GLA,EP ADDR & ENVIRONMENT ! %IF ROUT=1 %THEN %START II=PTYPE; P=P+1 CNAME(13,ACCR); ! SET UP 4 WDS & SET PTR FAULT(21,PNAM) %IF PTYPE>>12#0 %AND %C (II&15#PTYPE&15 %OR CHECK FPROCS(K,PXTRA)#0);! TYPE SIMILAR P=P+1 MOVEPTR=MOVEPTR+4 STUFF: REGISTER(ACCR)=3 ->NEXT PARM %FINISH ! %IF ARR=0 %AND (NAM=2 %OR(NAM=3 %AND ALT=2)) %START P=P+1; CNAME(3,ACCR) FAULT(22,PNAM) %UNLESS II=PTYPE&7 %AND PTYPE&X'F00'=0 MOVEPTR=MOVEPTR+2 ->STUFF %FINISH ! %IF PSIZE>0 %THEN %START; ! A THUNKS HAS BEEN SET GTHUNKS(PTYPE,PNAM) MOVEPTR=MOVEPTR+2 ->STUFF %FINISH ! ! FOR ARRAYNAME PARAMETERS THE NO OF DIMENSIONS OF THE ARRAY IS ! DEDUCED FROM THE FIRST CALL AND STORED IN STREAM2 OF THE PARAMETER ! LIST. ON ANY SUBSEQUENT CALL ONLY ARRAYS OF THE SAME DIMENSION CAN ! BE PASSED ! %IF ARR=1 %THEN %START III=NAM; ! 0 FOR ARRAY BY VALUE %IF A(P)=2 %AND A(P+2)=3 %THEN %START P=P+1; CNAME(12,ACCR); TYPE=PTYPE&7 %IF III=3 %THEN JJ=2 %ELSE JJ=4 GET IN ACC(ACCR,JJ,0,AREA CODE,DISP) %IF ARR#0 %AND (II=0 %OR II=TYPE %OR %C (III=0 %AND II#3#TYPE))%START %IF II#0 %THEN %START; ! NOT GENERAL ARRAY NAME %IF PXTRA=0 %THEN PXTRA=J %AND %C REPLACE2(CLINK,PXTRA<<16!PNAM) %IF J=0 %THEN %START;! ACTUAL DIMENSN UNKNOWN FNAME=A(P-2) J=PXTRA; II=TAGS(FNAME) REPLACE1(II,FROM1(II)!PXTRA) %FINISH FAULT(20,PNAM) %IF 0#J#PXTRA %AND III#3 %FINISH MOVEPTR=MOVEPTR+JJ ->STUFF %FINISH %FINISH FAULT(22,PNAM) ->NEXT PARM %FINISH ! %IF TYPE=5 %THEN %START; ! STRINGS FETCH STRING(ACCR) FAULT(22,PNAM) %UNLESS TYPE=5 MOVEPTR=MOVEPTR+2 ->STUFF %FINISH ! ! %IF TYPE=6 %THEN %START; ! LABEL BY VALUE ! %MONITOR ! %STOP ! %FINISH %IF TYPE<=3 %THEN %START P=P+1; III=NAM CSEXP(ACCR,TYPE,ALT) JJ=BYTES(II)>>2 %IF III=0 %THEN MOVEPTR=MOVEPTR+JJ %ELSE %START GET WSP(III,JJ) PSF1(ST,1,III) PSF1(LSS,0,III) PSF1(IAD,1,PTR OFFSET(RLEVEL)) PF1(LUH,0,PC,PLABS(1)+DESRAD(II)) GRUSE(ACCR)=0 MOVEPTR=MOVEPTR+2 %FINISH ->STUFF %FINISH -> NEXT PARM ENTRY SEQ: ! CODE FOR RT ENTRY ! %IF REGISTER(ACCR)=3 %THEN %C PF1(ST,0,TOS,0) %AND REGISTER(ACCR)=0 PTYPE=PT; J=JJJ ! ! ORDINARY ROUTINES WILL AND RT PARAMS MAY REQUIRE AN EXTRA PARAMETER ! BEING LNB FOR THE LEVEL OF ROUTINE DECLARATION TO BE STACKED ! %IF JJJ=14 %THEN %START; ! EXTERNAL SET XNB(-1); ! XNB TO PLT PSF1(RALN,0,MOVEPTR) PF1(CALL,2,XNB,RDISP) %FINISH %ELSE %START %IF PTYPE&X'100'=0 %THEN %START;! INTERNAL RT CALLS %IF LP=0 %THEN %START PSF1(LD,1,12) PSF1(INCA,0,RDISP) %UNLESS RDISP=0 PSF1(RALN,0,MOVEPTR) PF1(CALL,2,7,0) %FINISH %ELSE %START SET XNB(LP) PSF1(RALN,0,MOVEPTR) RT JUMP(CALL,ASLIST(DLINK)_S1) %FINISH %FINISH %ELSE %START AREA=-1; BASE=LP AREA=AREA CODE GET IN ACC(DR,2,0,AREA,RDISP) PSORLF1(LXN,0,AREA,RDISP+12) PSF1(RALN,0,MOVEPTR); ! RAISE FOR NORMAL PARAMS PF1(CALL,2,7,0); ! AND ENTER VIA DESCRPTR IN DR %FINISH %FINISH %CYCLE II=0,1,7; GRUSE(II)=0; %REPEAT %END %ROUTINE SKIP EXP(%INTEGER MODE) !*********************************************************************** !* SKIP OVER AN EXPRESSION WHICH IS EITHER A CONDITIOAL EXPR * !* OR A SIMPLE EXPRESSION. MODE AS FOR SKIP SEXP * !* P:='%IF''%THEN''%ELSE', * !* P:='%IF''%THEN''%ESLE' * !*********************************************************************** %INTEGER ALT, PIN PIN=P ALT=A(P); P=P+1; ! ALT OF EXPRESSION %IF ALT=2 %THEN SKIP SEXP(MODE) %ELSE %START SKIP EXP(1) SKIP SEXP(MODE) SKIP EXP(MODE) %FINISH %END %ROUTINE SKIP SEXP(%INTEGER MODE) !*********************************************************************** !* SKIPS OVER A BOOLEAN EXPRESSION * !* MODE=0 FOR ARITHMETIC, =1 FOR BOOLEAN EXPRESSIO * !* P TO HOLE IN <+'> * !* OR P TO WHERE :- * !* P:= * !*********************************************************************** %INTEGER BOP, PIN, J %SWITCH ALT(1:8) PIN=P %UNTIL BOP#1 %CYCLE BOP=A(P+2); P=P+3; ! BOP =ALT OF P ->ALT(BOP+MODE<<2) ALT(1): ! ALT(6): ! P=P+1; SKIP APP; ->END ALT(2): ! P=P+A(P)+1 ->END ALT(7): ! P=P+1; ->END ALT(3): ! '('')' ALT(8): ! '('')' SKIP EXP(MODE); ->END ALT(5): ! SKIP EXP(0); P=P+1; SKIP EXP(0) END: ! ANY MORE RESTOF BEXP? BOP=A(P) P=P+1 %IF MODE#0 %REPEAT P=P+1 %IF MODE=0 %END %ROUTINE SKIP APP !*********************************************************************** !* SKIP OVER ARRAY OR RT ACTUAL PARAMETER PART * !* P POINTS TO THE ALT OF P. * !*********************************************************************** %INTEGER ALT, PIN PIN=P; ALT=A(P) %IF ALT#3 %THEN %START %IF ALT=2 %THEN %START P=P+1+A(P+1) %WHILE A(P)=1 %THEN P=A(P+2)+P+2 %FINISH %ELSE %START %WHILE A(P)=1 %THEN P=P+1 %AND P=P+A(P) %FINISH %FINISH P=P+1 %END %ROUTINE TEST APP(%INTEGERNAME NUM) !*********************************************************************** !* THIS ROUTINE COUNTS THE NUMBER OF ACTUAL PARAMETERS * !* WHICH IT RETURNS IN NUM. * !*********************************************************************** %INTEGER PP, Q Q=0; PP=P; P=P+1; ! P ON NAME AT ENTRY %IF A(P)=2 %THEN %START Q=1; P=P+1+A(P+1) %WHILE A(P)=1 %THEN Q=Q+1 %AND P=P+2+A(P+2) %FINISH %ELSE %START %WHILE A(P)=1 %CYCLE; ! NO (MORE) PARAMETERS P=P+1; Q=Q+1 P=P+A(P) %REPEAT %FINISH P=PP; NUM=Q %END %ROUTINE TEST ASS(%INTEGER REG) !*********************************************************************** !* TEST ACC OR B FOR THE UNASSIGNED PATTERN * !*********************************************************************** %INTEGER OPCODE %IF REG=BREG %THEN OPCODE=CPB %ELSE OPCODE=UCP PF1(OPCODE,0,PC,PLABS(1)+48) PCONST(JCC<<24!8<<21!((PLABS(5)-CA)//2)&X'3FFFF') %END %ROUTINE CBPAIR(%INTEGERNAME LB,UB) !*********************************************************************** !* EXTRACT UPPER AND LOWER BOUNDS FROM A CONSTANT BOUND PAIR * !*********************************************************************** %INTEGER KK,KKK,JJ,BP P=P+1; KK=0 %CYCLE JJ=1,1,2 KKK=KK %IF A(P)=2 %THEN KK=-1 %ELSE KK=1; ! EXTRACT SIGN BP=A(P+2) KK=KK*BP P=P+3 %REPEAT %IF KKK>KK %THEN FAULT(43,0) %AND KK=KKK LB=KKK; UB=KK %END %ROUTINE GET WSP(%INTEGERNAME PLACE,%INTEGER SIZE) !*********************************************************************** !* FIND OR CREATE A TEMPORARY VARIABLE OF 'SIZE' WORDS * !*********************************************************************** %INTEGER J,K %IF SIZE>4 %THEN SIZE=0 POP(AVL WSP(SIZE,LEVEL),J,K) %IF K<=0 %THEN %START; ! MUST CREATE TEMPORARY %IF SIZE>1 %THEN ODD ALIGN K=N %IF SIZE=0 %THEN N=N+268 %ELSE N=N+SIZE<<2 %FINISH PLACE=K PUSH(TWSPHEAD,K,SIZE) %UNLESS SIZE=0 %END %ROUTINE RETURN WSP(%INTEGER PLACE,SIZE) %IF SIZE>4 %THEN SIZE=0 PUSH(AVL WSP(SIZE,LEVEL),0,PLACE) %END %ROUTINE SET LINE !*********************************************************************** !* UPDATE THE STATEMENT NO * !*********************************************************************** PCONST(X'63800000'!LINE) PSF1(ST, 1, DIAGINF(LEVEL)+4) GRUSE(ACCR)=5; GRINF(ACCR)=LINE %END %ROUTINE FORGET(%INTEGER REG) %INTEGER L,U L=REG; U=L %IF L<0 %THEN L=0 %AND U=7 %CYCLE REG=L,1,U GRUSE(REG)=0 ; GRINF(REG)=0 %REPEAT %END %ROUTINE SET USE(%INTEGER R,U,I) !*********************************************************************** !* NOTE THAT THE USE OF REGISTER 'R' IS NOW 'U' & 'I' * !*********************************************************************** GRUSE(R)=U ; GRINF(R)=I GRAT(R)=CA %END %ROUTINE SAVE IRS !*********************************************************************** !* DUMP ACC AND-OR B ONTO THE STACK. USED BEFORE CALLING FNS * !* IN EXPRESSIONS. * !*********************************************************************** %IF REGISTER(BREG)>=1 %THEN BOOT OUT(BREG) %IF REGISTER(ACCR)>=1 %THEN BOOT OUT(ACCR) %IF REGISTER(DR)>=1 %THEN BOOT OUT(DR) %END %ROUTINE BOOT OUT(%INTEGER REG) !*********************************************************************** !* REMOVE TEMPORARIES FROM REG INTO LOCAL OR ONTO STACK * !* IT IS VITAL THAT ACC IS STACKED FIRST BEFORE B OR DR * !* OTHERWISE MIXUPS OCCUR WHEN PASSING MULTI-DIMENSION ARRAY * !* ELEMENTS WITH FNS AS SUBSCRIPTS AS VALUE SCALARS * !*********************************************************************** %CONSTBYTEINTEGERARRAY BOOTCODE(0:7)=X'48',X'58',X'5C',0(4),X'5A'; %INTEGER CODE %RECORDNAME R(RD) CODE=BOOTCODE(REG) ! ABORT %UNLESS 1<=REGISTER(REG)<=3 %AND CODE#0 R==RECORD(OLINK(REG)) %IF REGISTER(REG)=2 %THEN %START %IF R_D=0 %THEN GET WSP(R_D,BYTES(R_PTYPE&7)>>2) PSF1(CODE,1,R_D) %FINISH %ELSE %START %IF REG#ACCR %AND (REGISTER(ACCR)=1 %OR REGISTER(ACCR)=3)%C %THEN BOOT OUT(ACCR) PF1(CODE,0,TOS,0) %FINISH CHANGE RD(REG) REGISTER(REG)=0 %END %ROUTINE COPY DR !*********************************************************************** !* COPY THE DR TO ACC SAVING ANYTHING IN ACC * !*********************************************************************** %IF REGISTER (ACCR)#0 %THEN BOOT OUT(ACCR) PSF1(CYD,0,0) GRUSE(ACCR)=0 %END %ROUTINE CHANGE RD(%INTEGER REG) !*********************************************************************** !* CHANGE A RESULT DESCRIPTOR WHEN OPERAND IS STACKED * !*********************************************************************** %INTEGER I,RR %RECORDNAME OPND(RD) RR=REGISTER(REG) ! ABORT %UNLESS 1<=RR<=3 OPND==RECORD(OLINK(REG)) %IF RR=1 %THEN %START; ! CHANGE RESULT DESCRIPTOR ! ABORT %UNLESS OPND_FLAG=9 %AND OPND_XB>>4=REG OPND_FLAG=8; ! CHANGE TO 'STACKED' OPND_XB=TOS<<4 %FINISH %IF RR=2 %START OPND_FLAG=7; OPND_XB=LNB<<4 %FINISH %END %ROUTINE STORE TAG(%INTEGER KK, SLINK) %INTEGER Q, QQ, QQQ, I %RECORDNAME LCELL(LISTF) Q=TAGS(KK) %IF FROM1(Q)>>8&63=LEVEL %THEN FAULT(7,KK) %ELSE %START Q=PTYPE<<16!LEVEL<<8!RLEVEL<<4!J ! ABORT %UNLESS (KFORM!ACC)>>16=0 QQQ=SLINK<<16!KFORM QQ=SNDISP<<16!ACC I=ASL; %IF I=0 %THEN FAULT(107,0) %ELSE %START LCELL==ASLIST(I) ASL=LCELL_LINK LCELL_LINK=TAGS(KK)!NAMES(LEVEL)<<18 LCELL_S1=Q; LCELL_S2=QQ; LCELL_S3=QQQ TAGS(KK)=I NAMES(LEVEL)=KK %FINISH %FINISH %END %ROUTINE COPY TAG(%INTEGER KK) %INTEGER QQ,QQQ %RECORDNAME LCELL(LISTF) TCELL=TAGS(KK) %IF TCELL=0 %THEN %START; ! NAME NOT SET TYPE=7; PTYPE=7 ROUT=0; NAM=0; ARR=0; ACC=4 I=-1; J=-1; K=-1; OLDI=-1 KFORM=0; SNDISP=0 %FINISH %ELSE %START LCELL==ASLIST(TCELL) KK=LCELL_S1 LCELL_S1=KK!X'8000'; ! SET 'NAME USED' BIT QQ=LCELL_S2 QQQ=LCELL_S3 PTYPE=KK>>16; USEBITS=KK>>14&3 OLDI=KK>>8&63; I=KK>>4&15; J=KK&15 SNDISP=QQ//X'10000' ACC=QQ&X'FFFF' K=QQQ//X'10000' KFORM=QQQ&X'FFFF' TYPE=PTYPE&15 ARR=PTYPE>>4&15 NAM=PTYPE>>8&15 ROUT=PTYPE>>12 %FINISH %END %ROUTINE REDUCE TAG !*********************************************************************** !* AS COPY TAG FOR NAME AT A(P) EXCEPT:- * !* 1) SPECIAL NAMES HAVE THEIR CORRECT PREC & TYPE SUBSTITUTED * !*********************************************************************** COPY TAG(A(P)) %IF PTYPE=SNPT %THEN %START PTYPE=TSNAME(K); UNPACK ROUT=1 %FINISH; ! TO AVOID CHECKING PARAMS %END %ROUTINE REPLACE TAG(%INTEGER KK) %INTEGER P, Q P=TAGS(KK) Q=PTYPE<<16!USEBITS<<14!OLDI<<8!I<<4!J REPLACE1(P, Q) REPLACE3(P, K<<16!KFORM) %END %ROUTINE UNPACK TYPE=PTYPE&15 ARR=PTYPE>>4&15 NAM=PTYPE>>8&15 ROUT=PTYPE>>12 %END %ROUTINE PACK(%INTEGERNAME PTYPE) PTYPE=ROUT<<12!NAM<<8!ARR<<4!TYPE %END %ROUTINE PPJ(%INTEGER MASK,N) !*********************************************************************** !* PLANT A 'JCC MASK,PERMENTRY(N)' * !* IF MASK=0 THEN PLANT A JLK * !* IF MASK=-1 THEN PLANT A CALL TO PERM * !*********************************************************************** %INTEGER VAL, INSTRN, CODE CODE=OCODE(MASK) INSTRN=CODE<<24 VAL=PLABS(N) %IF CODE>6 %THEN INSTRN=INSTRN!3<<23 %ELSE %C INSTRN=INSTRN!(MASK&15)<<21 %IF VAL>0 %THEN INSTRN=INSTRN!((VAL-CA)//2)&X'3FFFF' %ELSE %C PUSH123(PLINK(N),CA,INSTRN,0) PCONST(INSTRN) %IF CODE>6 %START %CYCLE VAL=0,1,7; GRUSE(VAL)=0; %REPEAT %FINISH %END %ROUTINE SET XNB(%INTEGER RLEV) !*********************************************************************** !* SET EXTRA NAME BASE TO ADDRESS ROUTINE LEVEL 'RLEV' * !* RLEV=0 FOR OWNS, =-1 FOR THE PLT THESE ARE THE SAME! BUT CODED* !* SEPARATELY SO THAT THEY CAN BE SEPARATED IF NECESSARY * !*********************************************************************** ! ABORT %UNLESS -1<=RLEV<=RLEVEL %IF GRUSE(XNB)=4 %AND (GRINF(XNB)=RLEV %OR (RLEV=-1 %AND %C GRINF(XNB)=0)) %THEN %RETURN %IF RLEV<=0 %AND GRUSE(XNB)=3 %THEN %RETURN %IF RLEV=-1 %THEN %START PSF1(LXN,1,16) GRUSE(XNB)=3; GRINF(XNB)=0 %FINISH %ELSE %START PSF1(LXN,1,PTR OFFSET(RLEV)) GRUSE(XNB)=4; GRINF(XNB)=RLEV %FINISH %END %ROUTINE ODDALIGN !*********************************************************************** !* SETS N TO ODD WORD BOUNDARY. SINCE PRECALL ALSO SETS SF TO ODD * !* WORD BOUNDARY THIS MEANS 64 BIT QUANTITIES ARE 64 BIT ALIGNED * !* AND CAN BE REFERNCED IN A SINGL CORE CYCLE * !*********************************************************************** %IF N&7=0 %THEN RETURN WSP(N,1) %AND N=N+4 %END %INTEGERFN PTROFFSET(%INTEGER RLEV) !*********************************************************************** !* RETURNS OFFSET FROM LNB OF RELEVANT ITEM IN THE CURRENT DISPLAY * !* WHICH ENABLES TEXTTUAL LEVEL 'RLEV' TO BE ADDRESSED * !* A FUNCTION IS USED TO ALLOW CHANGES IN THE DISPLAY FORMAT * !*********************************************************************** %IF RLEV<0 %THEN %RESULT=16 %RESULT=DISPLAY(RLEVEL)+RLEV<<2 %END %INTEGERFN AREA CODE !*********************************************************************** !* RETURNS THE AREA CODE FOR ROUTINE LEVEL 'BASE' LOADING * !* XNB WHERE THIS IS NEEDED * !*********************************************************************** %IF AREA<0 %THEN %START %IF BASE=RLEVEL %THEN AREA=LNB %AND %RESULT=LNB;! LOCAL LEVEL SET XNB(BASE) %UNLESS GRINF(XNB)=BASE %AND GRUSE(XNB)=4 AREA=XNB %FINISH %RESULT=AREA %END %ROUTINE NOTE ASSMENT(%INTEGER REG,VAR) !*********************************************************************** !* NOTES THE ASSIGNMENT TO SCALAR VARIABLE 'VAR'. REMOVES ALL * !* OLD COPIES FROM THE REGISTERS. IF VAR IS A SUBSTITUION * !* PARAMETER ALL VARIABLES ARE REMOVED BECAUSE OF POSSIBLE SIDE * !* EFFECTS. * !*********************************************************************** %INTEGER I,NAM I=TAGS(VAR) NAM=FROM1(I)>>24&15 %CYCLE I=0,7,7; ! ONLY ACC &BREG RELEVANT %IF GRUSE(I)=9 %AND (GRINF(I)=VAR %OR NAM#0) %THEN %C GRUSE(I)=0 %REPEAT %IF NAM=0 %AND GRUSE(REG)<=3 %THEN %C GRUSE(REG)=9 %AND GRINF(REG)=VAR %END %ROUTINE GET IN ACC(%INTEGER REG,SIZE,ACCESS,AREA,DISP) !*********************************************************************** !* LOADS THE REGISTER SPECIFIED ARRANGING FOR AUTOMATIC * !* STACKING WHEN THIS IS NEEDED * !* IT IS VITAL THAT ACC IS STACKED FIRST BEFORE B OR DR * !* OTHERWISE MIXUPS OCCUR WHEN PASSING MULTI-DIMENSION ARRAY * !* ELEMENTS WITH FNS AS SUBSCRIPTS AS VALUE SCALARS * !*********************************************************************** %INTEGER OPCODE %CONSTINTEGERARRAY GETCODE(0:7)=X'62',X'76',0(5),X'7A'; !QOUT; ABORT %UNLESS REG=ACCR %OR(REG=DR %AND SIZE=2) %OR %C (REG=BREG %AND SIZE<=1) OPCODE=GETCODE(REG)+SIZE&6 ! %IF REGISTER(REG)>0 %THEN %START %IF REGISTER(REG)=2 %THEN BOOT OUT(REG) %ELSE %START %IF REG#ACCR %AND(REGISTER(ACCR)=1 %OR REGISTER(ACCR)=3)%C %THEN BOOT OUT(ACCR) CHANGE RD(REG) REGISTER(REG)=0 %IF REG=ACCR %THEN OPCODE=OPCODE-32 %ELSE OPCODE=OPCODE-40 %FINISH %FINISH PSORLF1(OPCODE,ACCESS,AREA,DISP) %IF ACCESS>=2 %THEN GRUSE(DR)=0 GRUSE(REG)=0 %END %END !*DELSTART %ROUTINE PRINTUSE %CONSTSTRING(3)%ARRAY REGS(0:7)='ACC',' DR','LNB','XNB', ' PC','LTB','TOS',' B'; %CONSTSTRING(15)%ARRAY USES(0:15) =' NOT KNOWN ',' I-RESULT ', ' TEMPORARY ',' PLTBASE ', ' NAMEBASE ',' LIT CONST ', ' TAB CONST ',' DESC FOR ', ' RECD BASE ',' LOCAL VAR ', ' FN RESULT ', ' ??? '(3),' SST BASE ', ' RT PARAM '; %CONSTSTRING(11)%ARRAY STATE(-1:3)=%C ' LOCKED ',' FREE ', ' I-RESULT ',' TEMPORARY ', ' RT-PARAM '; %INTEGER I %CYCLE I=0,1,7 %IF REGISTER(I)!GRUSE(I)#0 %START PRINTSTRING(REGS(I).STATE(REGISTER(I)). %C ' USE = '.USES(GRUSE(I))) %IF 7<=GRUSE(I)<=10 %THEN PRINTNAME(GRINF(I)) %ELSE %C WRITE(GRINF(I),1) NEWLINE %FINISH %REPEAT %END !*DELEND %ENDOFPROGRAM